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 346e211f435a88662bb8694f430205f49588ceeb..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 "miscops:" 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 b653257d20bc89f8be2208f7c304bf1ba9315efe..0000000000000000000000000000000000000000
--- a/assembler/rompconst.lisp
+++ /dev/null
@@ -1,1097 +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..A3.  The function must take no more than 4 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)
-  (unless (<= 0 nargs 4)
-    (error "Losing NARGS: ~D." nargs))
-  ;; Allocate frame+1 to preserve the assembly-level stack top.
-  `((cal SP SP (* 4 (1+ %escape-frame-size)))
-    ;; 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 FP as OLD-FP.
-    (storew FP SP (* 4 (+ (- %escape-frame-size) c::old-fp-save-offset)))
-    ;; Compute escape frame start from SP.
-    (cal FP 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 FP FP (* 4 (+ %escape-frame-general-register-start-slot
-			      c::sp-offset)))
-    ;; Zero ENV save area to indicate an escape frame.
-    (loadi NL1 0)
-    (storew NL1 FP (* 4 c::env-save-offset))
-    ;; Save miscop return PC as PC escape frame is returning to.
-    (storew PC FP (* 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-FP FP) ; OLD-FP gets escape frame.
-    (lr FP SP) ; So escape frame doesn't get overwritten.
-    ;;
-    ;; If 4 args, set up arg frame.
-    ,@(when (= nargs 4)
-	'((cal SP SP (* 4 4))
-	  (storew A3 SP -4)))
-    ;; 
-    ;; 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>.
-    ;; FP should be restored to the escape frame by returning function.
-    (lm SP FP (* 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-fp 10)		; Fp to return to
-(register old-cont 10)		; Fp to return to (old name)
-(register l4 11)		; Boxed Temporary
-(register args 11)		; Pointer to stack arguments
-(register bs 12)		; Binding Stack Pointer
-(register fp 13)		; Frame Pointer 
-(register cont 13)		; Current Fp (old name)
-(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/assembly/assemfile.lisp b/assembly/assemfile.lisp
deleted file mode 100644
index 215e4af42dde6d13a0a76ef4db8b175cb428747c..0000000000000000000000000000000000000000
--- a/assembly/assemfile.lisp
+++ /dev/null
@@ -1,218 +0,0 @@
-;;; -*- Package: C -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/assemfile.lisp,v 1.33 1992/08/03 12:50:33 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the extra code necessary to feed an entire file of
-;;; assembly code to the assembler.
-;;;
-(in-package "C")
-
-(export '(define-assembly-routine))
-
-
-(defvar *do-assembly* nil
-  "If non-NIL, emit assembly code.  If NIL, emit VOP templates.")
-
-(defvar *lap-output-file* nil
-  "The FASL file currently being output to.")
-
-(defvar *assembler-routines* nil
-  "A List of (name . label) for every entry point.")
-
-(defun assemble-file (name &key
-			   (output-file
-			    (make-pathname :defaults name
-					   :type "assem"))
-			   trace-file)
-  (let* ((*do-assembly* t)
-	 (name (pathname name))
-	 (*lap-output-file* (open-fasl-file (pathname output-file) name))
-	 (*assembler-routines* nil)
-	 (*load-verbose* nil)
-	 (won nil)
-	 (*code-segment* nil)
-	 (*elsewhere* nil)
-	 (*assembly-optimize* nil)
-	 (*compiler-trace-output* nil)
-	 (*fixups* nil))
-    (unwind-protect
-	(progn
-	  (pushnew :assembler *features*)
-	  (when trace-file
-	    (setf *compiler-trace-output*
-		  (open (if (eq trace-file t)
-			    (make-pathname :defaults name
-					   :type "trace")
-			    trace-file)
-			:direction :output
-			:if-exists :supersede)))
-	  (init-assembler)
-	  (load (merge-pathnames name (make-pathname :type "lisp")))
-	  (fasl-dump-cold-load-form `(in-package ,(package-name *package*))
-				    *lap-output-file*)
-	  (new-assem:append-segment *code-segment* *elsewhere*)
-	  (setf *elsewhere* nil)
-	  (let ((length (new-assem:finalize-segment *code-segment*)))
-	    (dump-assembler-routines *code-segment*
-				     length
-				     *fixups*
-				     *assembler-routines*
-				     *lap-output-file*))
-	  (setq won t))
-      (deletef :assembler *features*)
-      (new-assem:release-segment *code-segment*)
-      (when *elsewhere*
-	(new-assem:release-segment *elsewhere*))
-      (when *compiler-trace-output*
-	(close *compiler-trace-output*))
-      (close-fasl-file *lap-output-file* (not won)))
-    won))
-
-
-
-(defstruct (reg-spec
-	    (:print-function %print-reg-spec))
-  (kind :temp :type (member :arg :temp :res))
-  (name nil :type symbol)
-  (temp nil :type symbol)
-  (scs nil :type (or list symbol))
-  (offset nil))
-
-(defun %print-reg-spec (spec stream depth)
-  (declare (ignore depth))
-  (format stream
-	  "#<reg ~S ~S scs=~S offset=~S>"
-	  (reg-spec-kind spec)
-	  (reg-spec-name spec)
-	  (reg-spec-scs spec)
-	  (reg-spec-offset spec)))
-
-(defun reg-spec-sc (spec)
-  (if (atom (reg-spec-scs spec))
-      (reg-spec-scs spec)
-      (car (reg-spec-scs spec))))
-
-(defun parse-reg-spec (kind name sc offset)
-  (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset)))
-    (ecase kind
-      (:temp)
-      ((:arg :res)
-       (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
-    reg))
-
-
-(defun emit-assemble (name options regs code)
-  (collect ((decls))
-    (loop
-      (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
-	  (decls (pop code))
-	  (return)))
-    `(let (,@(mapcar
-	      #'(lambda (reg)
-		  `(,(reg-spec-name reg)
-		    (make-random-tn
-		     :kind :normal
-		     :sc (sc-or-lose ',(reg-spec-sc reg))
-		     :offset ,(reg-spec-offset reg))))
-	      regs))
-       ,@(decls)
-       (new-assem:assemble (*code-segment* ',name)
-	 ,name
-	 (push (cons ',name ,name) *assembler-routines*)
-	 ,@code
-	 ,@(generate-return-sequence
-	    (or (cadr (assoc :return-style options)) :raw)))
-       (when *compile-print*
-	 (format *error-output* "~S assembled~%" ',name)))))
-
-(defun arg-or-res-spec (reg)
-  `(,(reg-spec-name reg)
-    :scs ,(if (atom (reg-spec-scs reg))
-	      (list (reg-spec-scs reg))
-	      (reg-spec-scs reg))
-    ,@(unless (eq (reg-spec-kind reg) :res)
-	`(:target ,(reg-spec-temp reg)))))
-
-(defun emit-vop (name options vars)
-  (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq))
-	 (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
-	 (results (remove :res vars :key #'reg-spec-kind :test-not #'eq))
-	 (return-style (or (cadr (assoc :return-style options)) :raw))
-	 (cost (or (cadr (assoc :cost options)) 247))
-	 (vop (make-symbol "VOP")))
-    (unless (member return-style '(:raw :full-call :none))
-      (error "Unknown return-style for ~S: ~S" name return-style))
-    (multiple-value-bind
-	(call-sequence call-temps)
-	(let ((*backend* *target-backend*))
-	  (generate-call-sequence name return-style vop))
-      `(define-vop ,(if (atom name) (list name) name)
-	 (:args ,@(mapcar #'arg-or-res-spec args))
-	 ,@(let ((index -1))
-	     (mapcar #'(lambda (arg)
-			 `(:temporary (:sc ,(reg-spec-sc arg)
-					   :offset ,(reg-spec-offset arg)
-					   :from (:argument ,(incf index))
-					   :to (:eval 2))
-				      ,(reg-spec-temp arg)))
-		     args))
-	 ,@(mapcar #'(lambda (temp)
-		       `(:temporary (:sc ,(reg-spec-sc temp)
-					 :offset ,(reg-spec-offset temp)
-					 :from (:eval 1)
-					 :to (:eval 3))
-				    ,(reg-spec-name temp)))
-		   temps)
-	 ,@call-temps
-	 (:vop-var ,vop)
-	 ,@(let ((index -1))
-	     (mapcar #'(lambda (res)
-			 `(:temporary (:sc ,(reg-spec-sc res)
-					   :offset ,(reg-spec-offset res)
-					   :from (:eval 2)
-					   :to (:result ,(incf index))
-					   :target ,(reg-spec-name res))
-				      ,(reg-spec-temp res)))
-		     results))
-	 (:results ,@(mapcar #'arg-or-res-spec results))
-	 (:ignore ,@(mapcar #'reg-spec-name temps))
-	 ,@(remove-if #'(lambda (x)
-			  (member x '(:return-style :cost)))
-		      options
-		      :key #'car)
-	 (:generator ,cost
-	   ,@(mapcar #'(lambda (arg)
-			 (if (target-featurep :hppa)
-			     `(move ,(reg-spec-name arg)
-				    ,(reg-spec-temp arg))
-			     `(move ,(reg-spec-temp arg)
-				    ,(reg-spec-name arg))))
-		     args)
-	   ,@call-sequence
-	   ,@(mapcar #'(lambda (res)
-			 (if (target-featurep :hppa)
-			     `(move ,(reg-spec-temp res)
-				    ,(reg-spec-name res))
-			     `(move ,(reg-spec-name res)
-				    ,(reg-spec-temp res))))
-		     results))))))
-
-(defmacro define-assembly-routine (name&options vars &rest code)
-  (multiple-value-bind (name options)
-		       (if (atom name&options)
-			   (values name&options nil)
-			   (values (car name&options)
-				   (cdr name&options)))
-    (let* ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars)))
-      (if *do-assembly*
-	  (emit-assemble name options regs code)
-	  (emit-vop name options regs)))))
diff --git a/assembly/hppa/alloc.lisp b/assembly/hppa/alloc.lisp
deleted file mode 100644
index b4dc39007dc0aeb8088fcc44d8b2d9906c09d9dc..0000000000000000000000000000000000000000
--- a/assembly/hppa/alloc.lisp
+++ /dev/null
@@ -1,24 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/alloc.lisp,v 1.1 1992/06/12 04:00:00 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Stuff to handle allocation of stuff we don't want to do inline.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "HPPA")
-
-;;; Given that the pseudo-atomic sequence is so short, there is
-;;; nothing that qualifies.  But we want to keep the file around
-;;; in case we decide to add something later.
-
diff --git a/assembly/hppa/arith.lisp b/assembly/hppa/arith.lisp
deleted file mode 100644
index 06f8a1cbccf7cc805add589f855745836ba1ff60..0000000000000000000000000000000000000000
--- a/assembly/hppa/arith.lisp
+++ /dev/null
@@ -1,282 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/arith.lisp,v 1.7 1992/07/13 01:47:53 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Stuff to handle simple cases for generic arithmetic.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "HPPA")
-
-
-;;;; Multiplication and Division helping routines.
-
-#+assembler
-(define-assembly-routine
-    multiply
-    ((:arg x (signed-reg) nl0-offset)
-     (:arg y (signed-reg) nl1-offset)
-
-     (:res res (signed-reg) nl2-offset)
-
-     (:temp tmp (unsigned-reg) nl3-offset)
-     (:temp sign (unsigned-reg) nl4-offset))
-
-  ;; Determine the sign of the result.
-  (inst extrs x 0 1 sign :=)
-  (inst sub zero-tn x x)
-  (inst extrs y 0 1 tmp :=)
-  (inst sub zero-tn y y)
-  (inst xor sign tmp sign)
-
-  ;; Make sure X is less then Y.
-  (inst comclr x y tmp :<<)
-  (inst xor x y tmp)
-  (inst xor x tmp x)
-  (inst xor y tmp y)
-  ;; Blow out of here if the result is zero.
-  (inst comb := x zero-tn done)
-  (inst li 0 res)
-
-  LOOP
-  (inst extru x 31 1 zero-tn :ev)
-  (inst add y res res)
-  (inst extru x 30 1 zero-tn :ev)
-  (inst sh1add y res res)
-  (inst extru x 29 1 zero-tn :ev)
-  (inst sh2add y res res)
-  (inst extru x 28 1 zero-tn :ev)
-  (inst sh3add y res res)
-
-  (inst srl x 4 x)
-  (inst comb :<> x zero-tn loop)
-  (inst sll y 4 y)
-
-  DONE
-  (inst xor res sign res)
-  (inst add res sign res))
-
-
-#+assembler
-(define-assembly-routine
-    (truncate)
-    ((:arg dividend signed-reg nl0-offset)
-     (:arg divisor signed-reg nl1-offset)
-
-     (:res quo signed-reg nl2-offset)
-     (:res rem signed-reg nl3-offset))
-  
-  ;; Move abs(divident) into quo.
-  (inst move dividend quo :>=)
-  (inst sub zero-tn quo quo)
-  ;; Do one divive-step with -divisor to prime V  (use rem as a temp)
-  (inst sub zero-tn divisor rem)
-  (inst ds zero-tn rem zero-tn)
-  ;; Shift the divident/quotient one bit, setting the carry flag.
-  (inst add quo quo quo)
-  ;; The first real divive-step.
-  (inst ds zero-tn divisor rem)
-  (inst addc quo quo quo)
-  ;; And 31 more of them.
-  (dotimes (i 31)
-    (inst ds rem divisor rem)
-    (inst addc quo quo quo))
-  ;; If the remainder is negative, we need to add the absolute value of the
-  ;; divisor.
-  (inst comb :>= rem zero-tn remainder-positive)
-  (inst comclr divisor zero-tn zero-tn :<)
-  (inst add rem divisor rem :tr)
-  (inst sub rem divisor rem)
-  REMAINDER-POSITIVE
-  ;; Now we have to fix the signs of quo and rem.
-  (inst xor divisor dividend zero-tn :>=)
-  (inst sub zero-tn quo quo)
-  (inst move dividend zero-tn :>=)
-  (inst sub zero-tn rem rem))
-
-
-
-;;;; Generic arithmetic.
-
-(define-assembly-routine (generic-+
-			  (:cost 10)
-			  (:return-style :full-call)
-			  (:translate +)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg any-reg) a0-offset)
-
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  (inst extru x 31 2 zero-tn :=)
-  (inst b do-static-fun :nullify t)
-  (inst extru y 31 2 zero-tn :=)
-  (inst b do-static-fun :nullify t)
-  (inst addo x y res)
-  (lisp-return lra :offset 1)
-
-  DO-STATIC-FUN
-  (inst ldw (static-function-offset 'two-arg-+) null-tn lip)
-  (inst li (fixnum 2) nargs)
-  (inst move cfp-tn ocfp)
-  (inst bv lip)
-  (inst move csp-tn cfp-tn))
-
-(define-assembly-routine (generic--
-			  (:cost 10)
-			  (:return-style :full-call)
-			  (:translate -)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg any-reg) a0-offset)
-
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  (inst extru x 31 2 zero-tn :=)
-  (inst b do-static-fun :nullify t)
-  (inst extru y 31 2 zero-tn :=)
-  (inst b do-static-fun :nullify t)
-  (inst subo x y res)
-  (lisp-return lra :offset 1)
-
-  DO-STATIC-FUN
-  (inst ldw (static-function-offset 'two-arg--) null-tn lip)
-  (inst li (fixnum 2) nargs)
-  (inst move cfp-tn ocfp)
-  (inst bv lip)
-  (inst move csp-tn cfp-tn))
-
-
-
-;;;; Comparison routines.
-
-(macrolet
-    ((define-cond-assem-rtn (name translate static-fn cond)
-       `(define-assembly-routine (,name
-				  (:cost 10)
-				  (:return-style :full-call)
-				  (:policy :safe)
-				  (:translate ,translate)
-				  (:save-p t))
-				 ((:arg x (descriptor-reg any-reg) a0-offset)
-				  (:arg y (descriptor-reg any-reg) a1-offset)
-				  
-				  (:res res descriptor-reg a0-offset)
-				  
-				  (:temp lip interior-reg lip-offset)
-				  (:temp lra descriptor-reg lra-offset)
-				  (:temp nargs any-reg nargs-offset)
-				  (:temp ocfp any-reg ocfp-offset))
-	  (inst extru x 31 2 zero-tn :=)
-	  (inst b do-static-fn :nullify t)
-	  (inst extru y 31 2 zero-tn :=)
-	  (inst b do-static-fn :nullify t)
-
-	  (inst comclr x y zero-tn ,cond)
-	  (inst move null-tn res :tr)
-	  (load-symbol res t)
-	  (lisp-return lra :offset 1)
-
-	  DO-STATIC-FN
-	  (inst ldw (static-function-offset ',static-fn) null-tn lip)
-	  (inst li (fixnum 2) nargs)
-	  (inst move cfp-tn ocfp)
-	  (inst bv lip)
-	  (inst move csp-tn cfp-tn))))
-
-  (define-cond-assem-rtn generic-< < two-arg-< :<)
-  (define-cond-assem-rtn generic-> > two-arg-> :>))
-
-
-(define-assembly-routine
-    (generic-eql
-     (:cost 10)
-     (:return-style :full-call)
-     (:policy :safe)
-     (:translate eql)
-     (:save-p t))
-    ((:arg x (descriptor-reg any-reg) a0-offset)
-     (:arg y (descriptor-reg any-reg) a1-offset)
-     
-     (:res res descriptor-reg a0-offset)
-     
-     (:temp lip interior-reg lip-offset)
-     (:temp lra descriptor-reg lra-offset)
-     (:temp nargs any-reg nargs-offset)
-     (:temp ocfp any-reg ocfp-offset))
-
-  (inst comb := x y return-t :nullify t)
-  (inst extru x 31 2 zero-tn :<>)
-  (inst b return-nil :nullify t)
-  (inst extru y 31 2 zero-tn :=)
-  (inst b do-static-fn :nullify t)
-
-  RETURN-NIL
-  (inst move null-tn res)
-  (lisp-return lra :offset 1)
-
-  DO-STATIC-FN
-  (inst ldw (static-function-offset 'eql) null-tn lip)
-  (inst li (fixnum 2) nargs)
-  (inst move cfp-tn ocfp)
-  (inst bv lip)
-  (inst move csp-tn cfp-tn)
-
-  RETURN-T
-  (load-symbol res t))
-
-(define-assembly-routine
-    (generic-=
-     (:cost 10)
-     (:return-style :full-call)
-     (:policy :safe)
-     (:translate =)
-     (:save-p t))
-    ((:arg x (descriptor-reg any-reg) a0-offset)
-     (:arg y (descriptor-reg any-reg) a1-offset)
-     
-     (:res res descriptor-reg a0-offset)
-     
-     (:temp lip interior-reg lip-offset)
-     (:temp lra descriptor-reg lra-offset)
-     (:temp nargs any-reg nargs-offset)
-     (:temp ocfp any-reg ocfp-offset))
-
-  (inst comb := x y return-t :nullify t)
-  (inst extru x 31 2 zero-tn :=)
-  (inst b do-static-fn :nullify t)
-  (inst extru y 31 2 zero-tn :=)
-  (inst b do-static-fn :nullify t)
-
-  (inst move null-tn res)
-  (lisp-return lra :offset 1)
-
-  DO-STATIC-FN
-  (inst ldw (static-function-offset 'two-arg-=) null-tn lip)
-  (inst li (fixnum 2) nargs)
-  (inst move cfp-tn ocfp)
-  (inst bv lip)
-  (inst move csp-tn cfp-tn)
-
-  RETURN-T
-  (load-symbol res t))
diff --git a/assembly/hppa/array.lisp b/assembly/hppa/array.lisp
deleted file mode 100644
index df222e0eab8d56c35eb78c2706211e2975000c0b..0000000000000000000000000000000000000000
--- a/assembly/hppa/array.lisp
+++ /dev/null
@@ -1,112 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/array.lisp,v 1.4 1992/07/08 03:09:54 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the support routines for arrays and vectors.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "HPPA")
-
-(define-assembly-routine
-    (allocate-vector
-     (:policy :fast-safe)
-     (:translate allocate-vector)
-     (:arg-types positive-fixnum
-		 positive-fixnum
-		 positive-fixnum))
-    ((:arg type any-reg a0-offset)
-     (:arg length any-reg a1-offset)
-     (:arg words any-reg a2-offset)
-     (:res result descriptor-reg a0-offset)
-     
-     (:temp ndescr non-descriptor-reg nl0-offset)
-     (:temp vector descriptor-reg a3-offset))
-  (pseudo-atomic ()
-    (move alloc-tn vector)
-    (inst dep other-pointer-type 31 3 vector)
-    (inst addi (* (1+ vector-data-offset) word-bytes) words ndescr)
-    (inst dep 0 31 3 ndescr)
-    (inst add ndescr alloc-tn alloc-tn)
-    (inst srl type word-shift ndescr)
-    (storew ndescr vector 0 other-pointer-type)
-    (storew length vector vector-length-slot other-pointer-type))
-  (move vector result))
-
-
-
-;;;; Hash primitives
-
-#+assembler
-(defparameter *sxhash-simple-substring-entry* (gen-label))
-
-(define-assembly-routine
-    (sxhash-simple-string
-     (:translate %sxhash-simple-string)
-     (:policy :fast-safe)
-     (:result-types positive-fixnum))
-    ((:arg string descriptor-reg a0-offset)
-     (:res result any-reg a0-offset)
-
-     (:temp length any-reg a1-offset)
-     (:temp accum non-descriptor-reg nl0-offset)
-     (:temp data non-descriptor-reg nl1-offset)
-     (:temp offset non-descriptor-reg nl2-offset))
-
-  (declare (ignore result accum data offset))
-
-  ;; Save the return address.
-  (inst b *sxhash-simple-substring-entry*)
-  (loadw length string vector-length-slot other-pointer-type))
-
-(define-assembly-routine
-    (sxhash-simple-substring
-     (:translate %sxhash-simple-substring)
-     (:policy :fast-safe)
-     (:arg-types * positive-fixnum)
-     (:result-types positive-fixnum))
-    
-    ((:arg string descriptor-reg a0-offset)
-     (:arg length any-reg a1-offset)
-     (:res result any-reg a0-offset)
-
-     (:temp accum non-descriptor-reg nl0-offset)
-     (:temp data non-descriptor-reg nl1-offset)
-     (:temp offset non-descriptor-reg nl2-offset))
-
-  (emit-label *sxhash-simple-substring-entry*)
-
-  (inst li (- (* vector-data-offset word-bytes) other-pointer-type) offset)
-  (inst b test)
-  (move zero-tn accum)
-
-  LOOP
-  (inst xor accum data accum)
-  (inst shd accum accum 5 accum)
-
-  TEST
-  (inst ldwx offset string data)
-  (inst addib :>= (fixnum -4) length loop)
-  (inst addi (fixnum 1) offset offset)
-
-  (inst addi (fixnum 4) length length)
-  (inst comb := zero-tn length done :nullify t)
-  (inst sub zero-tn length length)
-  (inst sll length 1 length)
-  (inst mtctl length :sar)
-  (inst shd zero-tn data :variable data)
-  (inst xor accum data accum)
-
-  DONE
-
-  (inst sll accum 5 result)
-  (inst srl result 3 result))
diff --git a/assembly/hppa/assem-rtns.lisp b/assembly/hppa/assem-rtns.lisp
deleted file mode 100644
index 14b6af7c66fc14b43e294b1093d8007e1f738e26..0000000000000000000000000000000000000000
--- a/assembly/hppa/assem-rtns.lisp
+++ /dev/null
@@ -1,218 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/assem-rtns.lisp,v 1.3 1992/07/08 01:40:27 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains a handful of random assembly routines.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "HPPA")
-
-
-;;;; Return-multiple with other than one value
-
-#+assembler ;; we don't want a vop for this one.
-(define-assembly-routine
-    (return-multiple
-     (:return-style :none))
-
-     ;; These four are really arguments.
-    ((:temp nvals any-reg nargs-offset)
-     (:temp vals any-reg nl0-offset)
-     (:temp old-fp any-reg nl1-offset)
-     (:temp lra descriptor-reg lra-offset)
-
-     ;; These are just needed to facilitate the transfer
-     (:temp count any-reg nl2-offset)
-     (:temp src any-reg nl3-offset)
-     (:temp dst any-reg nl4-offset)
-     (:temp temp descriptor-reg l0-offset)
-
-     ;; These are needed so we can get at the register args.
-     (:temp a0 descriptor-reg a0-offset)
-     (:temp a1 descriptor-reg a1-offset)
-     (:temp a2 descriptor-reg a2-offset)
-     (:temp a3 descriptor-reg a3-offset)
-     (:temp a4 descriptor-reg a4-offset)
-     (:temp a5 descriptor-reg a5-offset))
-
-  (inst movb := nvals count default-a0-and-on :nullify t)
-  (loadw a0 vals 0)
-  (inst addib := (fixnum -1) count default-a1-and-on :nullify t)
-  (loadw a1 vals 1)
-  (inst addib := (fixnum -1) count default-a2-and-on :nullify t)
-  (loadw a2 vals 2)
-  (inst addib := (fixnum -1) count default-a3-and-on :nullify t)
-  (loadw a3 vals 3)
-  (inst addib := (fixnum -1) count default-a4-and-on :nullify t)
-  (loadw a4 vals 4)
-  (inst addib := (fixnum -1) count default-a5-and-on :nullify t)
-  (loadw a5 vals 5)
-
-  ;; Copy the remaining args to the top of the stack.
-  (inst addi (* 6 word-bytes) vals src)
-  (inst addi (* 6 word-bytes) cfp-tn dst)
-
-  LOOP
-  (inst ldwm 4 src temp)
-  (inst addib :< (fixnum -1) count loop)
-  (inst stwm temp 4 dst)
-
-  (inst b done :nullify t)
-
-  DEFAULT-A0-AND-ON
-  (inst move null-tn a0)
-  DEFAULT-A1-AND-ON
-  (inst move null-tn a1)
-  DEFAULT-A2-AND-ON
-  (inst move null-tn a2)
-  DEFAULT-A3-AND-ON
-  (inst move null-tn a3)
-  DEFAULT-A4-AND-ON
-  (inst move null-tn a4)
-  DEFAULT-A5-AND-ON
-  (inst move null-tn a5)
-
-  DONE
-  ;; Clear the stack.
-  (move cfp-tn ocfp-tn)
-  (move old-fp cfp-tn)
-  (inst add ocfp-tn nvals csp-tn)
-  
-  ;; Return.
-  (lisp-return lra))
-
-
-
-;;;; tail-call-variable.
-
-#+assembler ;; no vop for this one either.
-(define-assembly-routine
-    (tail-call-variable
-     (:return-style :none))
-
-    ;; These are really args.
-    ((:temp args any-reg nl0-offset)
-     (:temp lexenv descriptor-reg lexenv-offset)
-
-     ;; We need to compute this
-     (:temp nargs any-reg nargs-offset)
-
-     ;; These are needed by the blitting code.
-     (:temp src any-reg nl1-offset)
-     (:temp dst any-reg nl2-offset)
-     (:temp count any-reg nl3-offset)
-     (:temp temp descriptor-reg l0-offset)
-
-     ;; These are needed so we can get at the register args.
-     (:temp a0 descriptor-reg a0-offset)
-     (:temp a1 descriptor-reg a1-offset)
-     (:temp a2 descriptor-reg a2-offset)
-     (:temp a3 descriptor-reg a3-offset)
-     (:temp a4 descriptor-reg a4-offset)
-     (:temp a5 descriptor-reg a5-offset))
-
-
-  ;; Calculate NARGS (as a fixnum)
-  (inst sub csp-tn args nargs)
-     
-  ;; Load the argument regs (must do this now, 'cause the blt might
-  ;; trash these locations)
-  (loadw a0 args 0)
-  (loadw a1 args 1)
-  (loadw a2 args 2)
-  (loadw a3 args 3)
-  (loadw a4 args 4)
-  (loadw a5 args 5)
-
-  ;; Calc SRC, DST, and COUNT
-  (inst addi (fixnum (- register-arg-count)) nargs count)
-  (inst comb :<= count zero-tn done :nullify t)
-  (inst addi (* word-bytes register-arg-count) args src)
-  (inst addi (* word-bytes register-arg-count) cfp-tn dst)
-	
-  LOOP
-  ;; Copy one arg.
-  (inst ldwm 4 src temp)
-  (inst addib :> (fixnum -1) count loop)
-  (inst stwm temp 4 dst)
-	
-  DONE
-  ;; We are done.  Do the jump.
-  (loadw temp lexenv closure-function-slot function-pointer-type)
-  (lisp-jump temp))
-
-
-
-;;;; Non-local exit noise.
-
-#+assembler
-(defparameter *unwind-entry-point* (gen-label))
-
-(define-assembly-routine
-    (unwind
-     (:translate %continue-unwind)
-     (:policy :fast-safe))
-    ((:arg block (any-reg descriptor-reg) a0-offset)
-     (:arg start (any-reg descriptor-reg) ocfp-offset)
-     (:arg count (any-reg descriptor-reg) nargs-offset)
-     (:temp lra descriptor-reg lra-offset)
-     (:temp cur-uwp any-reg nl0-offset)
-     (:temp next-uwp any-reg nl1-offset)
-     (:temp target-uwp any-reg nl2-offset))
-  (declare (ignore start count))
-
-  (emit-label *unwind-entry-point*)
-
-  (let ((error (generate-error-code nil invalid-unwind-error)))
-    (inst bc := nil block zero-tn error))
-  
-  (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
-  (loadw target-uwp block unwind-block-current-uwp-slot)
-  (inst bc :<> nil cur-uwp target-uwp do-uwp)
-      
-  (move block cur-uwp)
-
-  DO-EXIT
-      
-  (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
-  (loadw code-tn cur-uwp unwind-block-current-code-slot)
-  (loadw lra cur-uwp unwind-block-entry-pc-slot)
-  (lisp-return lra :frob-code nil)
-
-  DO-UWP
-
-  (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
-  (inst b do-exit)
-  (store-symbol-value next-uwp lisp::*current-unwind-protect-block*))
-
-
-(define-assembly-routine
-    throw
-    ((:arg target descriptor-reg a0-offset)
-     (:arg start any-reg ocfp-offset)
-     (:arg count any-reg nargs-offset)
-     (:temp catch any-reg a1-offset)
-     (:temp tag descriptor-reg a2-offset))
-  (declare (ignore start count)) ; We just need them in the registers.
-
-  (load-symbol-value catch lisp::*current-catch-block*)
-  
-  LOOP
-  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
-    (inst bc := nil catch zero-tn error))
-  (loadw tag catch catch-block-tag-slot)
-  (inst comb :<> tag target loop :nullify t)
-  (loadw catch catch catch-block-previous-catch-slot)
-  
-  (inst b *unwind-entry-point*)
-  (inst move catch target))
diff --git a/assembly/hppa/support.lisp b/assembly/hppa/support.lisp
deleted file mode 100644
index 1ed87574ffcf8da0aba409992965f2419835fdf6..0000000000000000000000000000000000000000
--- a/assembly/hppa/support.lisp
+++ /dev/null
@@ -1,80 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/support.lisp,v 1.1 1992/07/13 03:49:21 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the machine specific support routines needed by
-;;; the file assembler.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "HPPA")
-
-
-(def-vm-support-routine generate-call-sequence (name style vop)
-  (ecase style
-    (:raw
-     (let ((fixup (gensym "FIXUP-")))
-       (values
-	`((let ((fixup (make-fixup ',name :assembly-routine)))
-	    (inst ldil fixup ,fixup)
-	    (inst ble fixup lisp-heap-space ,fixup :nullify t))
-	  (inst nop))
-	`((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1))
-		      ,fixup)))))
-    (:full-call
-     (let ((temp (make-symbol "TEMP"))
-	   (nfp-save (make-symbol "NFP-SAVE"))
-	   (lra (make-symbol "LRA")))
-       (values
-	`((let ((lra-label (gen-label))
-		(cur-nfp (current-nfp-tn ,vop)))
-	    (when cur-nfp
-	      (store-stack-tn ,nfp-save cur-nfp))
-	    (inst compute-lra-from-code code-tn lra-label ,temp ,lra)
-	    (note-this-location ,vop :call-site)
-	    (let ((fixup (make-fixup ',name :assembly-routine)))
-	      (inst ldil fixup ,temp)
-	      (inst be fixup lisp-heap-space ,temp :nullify t))
-	    (emit-return-pc lra-label)
-	    (note-this-location ,vop :single-value-return)
-	    (move ocfp-tn csp-tn)
-	    (inst compute-code-from-lra code-tn lra-label ,temp code-tn)
-	    (when cur-nfp
-	      (load-stack-tn cur-nfp ,nfp-save))))
-	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
-		      ,temp)
-	  (:temporary (:sc descriptor-reg :offset lra-offset
-			   :from (:eval 0) :to (:eval 1))
-		      ,lra)
-	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
-		      ,nfp-save)
-	  (:save-p :compute-only)))))
-    (:none
-     (let ((fixup (gensym "FIXUP-")))
-       (values
-	`((let ((fixup (make-fixup ',name :assembly-routine)))
-	    (inst ldil fixup ,fixup)
-	    (inst be fixup lisp-heap-space ,fixup :nullify t)))
-	`((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1))
-		      ,fixup)))))))
-
-
-(def-vm-support-routine generate-return-sequence (style)
-  (ecase style
-    (:raw
-     `((inst bv lip-tn :nullify t)))
-    (:full-call
-     `((lisp-return (make-random-tn :kind :normal
-				    :sc (sc-or-lose 'descriptor-reg)
-				    :offset lra-offset)
-		    :offset 1)))
-    (:none)))
diff --git a/assembly/mips/alloc.lisp b/assembly/mips/alloc.lisp
deleted file mode 100644
index 4d4bc61dbdc9b8044d013f64c4e16d409f24429b..0000000000000000000000000000000000000000
--- a/assembly/mips/alloc.lisp
+++ /dev/null
@@ -1,21 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/alloc.lisp,v 1.3 1992/07/28 20:41:49 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Stuff to handle allocating simple objects.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "MIPS")
-
-;;; But we do everything inline now that we have a better pseudo-atomic.
diff --git a/assembly/mips/arith.lisp b/assembly/mips/arith.lisp
deleted file mode 100644
index ce1d09d242a646adfed17680af821915170e5b1a..0000000000000000000000000000000000000000
--- a/assembly/mips/arith.lisp
+++ /dev/null
@@ -1,307 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/arith.lisp,v 1.11 1992/07/28 20:42:28 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Stuff to handle simple cases for generic arithmetic.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "MIPS")
-
-
-(define-assembly-routine (generic-+
-			  (:cost 10)
-			  (:return-style :full-call)
-			  (:translate +)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg any-reg) a0-offset)
-
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  (inst and temp x 3)
-  (inst bne temp DO-STATIC-FUN)
-  (inst and temp y 3)
-  (inst bne temp DO-STATIC-FUN)
-  (inst nop)
-  (inst add res x y)
-  (lisp-return lra lip :offset 2)
-
-  DO-STATIC-FUN
-  (inst lw lip null-tn (static-function-offset 'two-arg-+))
-  (inst li nargs (fixnum 2))
-  (inst move ocfp cfp-tn)
-  (inst j lip)
-  (inst move cfp-tn csp-tn))
-
-
-(define-assembly-routine (generic--
-			  (:cost 10)
-			  (:return-style :full-call)
-			  (:translate -)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg any-reg) a0-offset)
-
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  (inst and temp x 3)
-  (inst bne temp DO-STATIC-FUN)
-  (inst and temp y 3)
-  (inst bne temp DO-STATIC-FUN)
-  (inst nop)
-  (inst sub res x y)
-  (lisp-return lra lip :offset 2)
-
-  DO-STATIC-FUN
-  (inst lw lip null-tn (static-function-offset 'two-arg--))
-  (inst li nargs (fixnum 2))
-  (inst move ocfp cfp-tn)
-  (inst j lip)
-  (inst move cfp-tn csp-tn))
-
-
-(define-assembly-routine (generic-*
-			  (:cost 25)
-			  (:return-style :full-call)
-			  (:translate *)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg any-reg) a0-offset)
-
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp lo non-descriptor-reg nl1-offset)
-			  (:temp hi non-descriptor-reg nl2-offset)
-			  (:temp pa-flag non-descriptor-reg nl4-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  ;; If either arg is not a fixnum, call the static function.
-  (inst and temp x 3)
-  (inst bne temp DO-STATIC-FUN)
-  (inst and temp y 3)
-  (inst bne temp DO-STATIC-FUN)
-  (inst nop)
-
-  ;; Remove the tag from one arg so that the result will have the correct
-  ;; fixnum tag.
-  (inst sra temp x 2)
-  (inst mult temp y)
-  (inst mflo res)
-  (inst mfhi hi)
-  ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
-  ;; is just 32 copies of the sign bit of the low word).
-  (inst sra temp res 31)
-  (inst xor temp hi)
-  (inst beq temp DONE)
-  ;; Shift the double word hi:res down two bits into hi:low to get rid of the
-  ;; fixnum tag.
-  (inst srl lo res 2)
-  (inst sll temp hi 30)
-  (inst or lo temp)
-  (inst sra hi 2)
-  ;; Allocate a BIGNUM for the result.
-  (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
-    (let ((one-word (gen-label)))
-      (inst or res alloc-tn other-pointer-type)
-      ;; Do we need one word or two?
-      (inst sra temp lo 31)
-      (inst xor temp hi)
-      (inst beq temp one-word)
-      (inst li temp (logior (ash 1 type-bits) bignum-type))
-      ;; Nope, we need two.
-      (inst li temp (logior (ash 2 type-bits) bignum-type))
-      (storew hi res (1+ bignum-digits-offset) other-pointer-type)
-      (emit-label one-word)
-      (storew temp res 0 other-pointer-type)
-      (storew lo res bignum-digits-offset other-pointer-type)))
-  ;; Out of here
-  (lisp-return lra lip :offset 2)
-
-  DO-STATIC-FUN
-  (inst lw lip null-tn (static-function-offset 'two-arg-*))
-  (inst li nargs (fixnum 2))
-  (inst move ocfp cfp-tn)
-  (inst j lip)
-  (inst move cfp-tn csp-tn)
-
-  DONE)
-
-
-
-;;;; Comparison routines.
-
-(macrolet
-    ((define-cond-assem-rtn (name translate static-fn cmp not-p)
-       `(define-assembly-routine (,name
-				  (:cost 10)
-				  (:return-style :full-call)
-				  (:policy :safe)
-				  (:translate ,translate)
-				  (:save-p t))
-				 ((:arg x (descriptor-reg any-reg) a0-offset)
-				  (:arg y (descriptor-reg any-reg) a1-offset)
-				  
-				  (:res res descriptor-reg a0-offset)
-				  
-				  (:temp temp non-descriptor-reg nl0-offset)
-				  (:temp lip interior-reg lip-offset)
-				  (:temp nargs any-reg nargs-offset)
-				  (:temp ocfp any-reg ocfp-offset))
-	  (inst and temp x 3)
-	  (inst bne temp DO-STATIC-FN)
-	  (inst and temp y 3)
-	  (inst beq temp DO-COMPARE)
-	  ,cmp
-	  
-	  DO-STATIC-FN
-	  (inst lw lip null-tn (static-function-offset ',static-fn))
-	  (inst li nargs (fixnum 2))
-	  (inst move ocfp cfp-tn)
-	  (inst j lip)
-	  (inst move cfp-tn csp-tn)
-	  
-	  DO-COMPARE
-	  (inst ,(if not-p 'bne 'beq) temp done)
-	  (inst move res null-tn)
-	  (load-symbol res t)
-	  DONE)))
-
-  (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) nil)
-  (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) nil))
-
-
-(define-assembly-routine (generic-eql
-			  (:cost 10)
-			  (:return-style :full-call)
-			  (:policy :safe)
-			  (:translate eql)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-			  
-			  (:res res descriptor-reg a0-offset)
-			  
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  (inst beq x y RETURN-T)
-  (inst and temp x 3)
-  (inst beq temp RETURN-NIL)
-  (inst and temp y 3)
-  (inst bne temp DO-STATIC-FN)
-  (inst nop)
-
-  RETURN-NIL
-  (inst move res null-tn)
-  (lisp-return lra lip :offset 2)
-
-  DO-STATIC-FN
-  (inst lw lip null-tn (static-function-offset 'eql))
-  (inst li nargs (fixnum 2))
-  (inst move ocfp cfp-tn)
-  (inst j lip)
-  (inst move cfp-tn csp-tn)
-
-  RETURN-T
-  (load-symbol res t))
-
-(define-assembly-routine (generic-=
-			  (:cost 10)
-			  (:return-style :full-call)
-			  (:policy :safe)
-			  (:translate =)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-			  
-			  (:res res descriptor-reg a0-offset)
-			  
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  (inst beq x y RETURN-T)
-  (inst and temp x 3)
-  (inst bne temp DO-STATIC-FN)
-  (inst and temp y 3)
-  (inst bne temp DO-STATIC-FN)
-  (inst nop)
-
-  (inst move res null-tn)
-  (lisp-return lra lip :offset 2)
-
-  DO-STATIC-FN
-  (inst lw lip null-tn (static-function-offset 'two-arg-=))
-  (inst li nargs (fixnum 2))
-  (inst move ocfp cfp-tn)
-  (inst j lip)
-  (inst move cfp-tn csp-tn)
-
-  RETURN-T
-  (load-symbol res t))
-
-(define-assembly-routine (generic-/=
-			  (:cost 10)
-			  (:return-style :full-call)
-			  (:policy :safe)
-			  (:translate /=)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-			  
-			  (:res res descriptor-reg a0-offset)
-			  
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  (inst beq x y RETURN-NIL)
-  (inst and temp x 3)
-  (inst bne temp DO-STATIC-FN)
-  (inst and temp y 3)
-  (inst bne temp DO-STATIC-FN)
-  (inst nop)
-
-  (load-symbol res t)
-  (lisp-return lra lip :offset 2)
-
-  DO-STATIC-FN
-  (inst lw lip null-tn (static-function-offset 'two-arg-=))
-  (inst li nargs (fixnum 2))
-  (inst move ocfp cfp-tn)
-  (inst j lip)
-  (inst move cfp-tn csp-tn)
-
-  RETURN-NIL
-  (inst move res null-tn))
diff --git a/assembly/mips/array.lisp b/assembly/mips/array.lisp
deleted file mode 100644
index 3e159ce5852e0b25ffd6d89f7988493ed2ecab47..0000000000000000000000000000000000000000
--- a/assembly/mips/array.lisp
+++ /dev/null
@@ -1,252 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/array.lisp,v 1.19 1992/07/28 20:42:50 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the support routines for arrays and vectors.
-;;;
-;;; Written by William Lott.
-;;; 
-(in-package "MIPS")
-
-
-(define-assembly-routine (allocate-vector
-			  (:policy :fast-safe)
-			  (:translate allocate-vector)
-			  (:arg-types positive-fixnum
-				      positive-fixnum
-				      positive-fixnum))
-			 ((:arg type any-reg a0-offset)
-			  (:arg length any-reg a1-offset)
-			  (:arg words any-reg a2-offset)
-			  (:res result descriptor-reg a0-offset)
-
-			  (:temp ndescr non-descriptor-reg nl0-offset)
-			  (:temp pa-flag non-descriptor-reg nl4-offset)
-			  (:temp vector descriptor-reg a3-offset))
-  (pseudo-atomic (pa-flag)
-    (inst or vector alloc-tn other-pointer-type)
-    ;; This is kinda sleezy, changing words like this.  But we can because
-    ;; the vop thinks it is temporary.
-    (inst addu words (+ (1- (ash 1 lowtag-bits))
-			(* vector-data-offset word-bytes)))
-    (inst li ndescr (lognot lowtag-mask))
-    (inst and words ndescr)
-    (inst addu alloc-tn words)
-    (inst srl ndescr type word-shift)
-    (storew ndescr vector 0 other-pointer-type)
-    (storew length vector vector-length-slot other-pointer-type))
-  (move result vector))
-
-
-
-;;;; Hash primitives
-
-(define-assembly-routine (sxhash-simple-string
-			  (:translate %sxhash-simple-string)
-			  (:policy :fast-safe)
-			  (:result-types positive-fixnum))
-			 ((:arg string descriptor-reg a0-offset)
-			  (:res result any-reg a0-offset)
-
-			  (:temp lip interior-reg lip-offset)
-			  (:temp length any-reg a2-offset)
-			  (:temp accum non-descriptor-reg nl0-offset)
-			  (:temp data non-descriptor-reg nl1-offset)
-			  (:temp byte non-descriptor-reg nl2-offset)
-			  (:temp retaddr non-descriptor-reg nl3-offset))
-
-  ;; Save the return address.
-  (inst subu retaddr lip-tn code-tn)
-
-  (loadw length string vector-length-slot other-pointer-type)
-  (inst addu lip string
-	(- (* vector-data-offset word-bytes) other-pointer-type))
-  (inst b test)
-  (move accum zero-tn)
-
-  loop
-
-  (inst and byte data #xff)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  (inst srl byte data 8)
-  (inst and byte byte #xff)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  (inst srl byte data 16)
-  (inst and byte byte #xff)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  (inst srl byte data 24)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  (inst addu lip lip 4)
-
-  test
-
-  (inst addu length length (fixnum -4))
-  (inst lw data lip 0)
-  (inst bgez length loop)
-  (inst nop)
-
-  (inst addu length length (fixnum 3))
-  (inst beq length zero-tn one-more)
-  (inst addu length length (fixnum -1))
-  (inst beq length zero-tn two-more)
-  (inst addu length length (fixnum -1))
-  (inst bne length zero-tn done)
-  (inst nop)
-
-  (inst srl byte data 16)
-  (inst and byte byte #xff)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  two-more
-
-  (inst srl byte data 8)
-  (inst and byte byte #xff)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  one-more
-
-  (inst and byte data #xff)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  done
-
-  (inst sll result accum 5)
-  (inst srl result result 3)
-
-  ;; Restore the return address.
-  (inst addu lip-tn retaddr code-tn))
-
-
-(define-assembly-routine (sxhash-simple-substring
-			  (:translate %sxhash-simple-substring)
-			  (:policy :fast-safe)
-			  (:arg-types * positive-fixnum)
-			  (:result-types positive-fixnum))
-			 ((:arg string descriptor-reg a0-offset)
-			  (:arg length any-reg a1-offset)
-			  (:res result any-reg a0-offset)
-
-			  (:temp lip interior-reg lip-offset)
-			  (:temp accum non-descriptor-reg nl0-offset)
-			  (:temp data non-descriptor-reg nl1-offset)
-			  (:temp byte non-descriptor-reg nl2-offset)
-			  (:temp retaddr non-descriptor-reg nl3-offset))
-  ;; Save the return address.
-  (inst subu retaddr lip-tn code-tn)
-
-  (inst addu lip string
-	(- (* vector-data-offset word-bytes) other-pointer-type))
-  (inst b test)
-  (move accum zero-tn)
-
-  loop
-
-  (inst and byte data #xff)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  (inst srl byte data 8)
-  (inst and byte byte #xff)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  (inst srl byte data 16)
-  (inst and byte byte #xff)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  (inst srl byte data 24)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  (inst addu lip lip 4)
-
-  test
-
-  (inst addu length length (fixnum -4))
-  (inst lw data lip 0)
-  (inst bgez length loop)
-  (inst nop)
-
-  (inst addu length length (fixnum 3))
-  (inst beq length zero-tn one-more)
-  (inst addu length length (fixnum -1))
-  (inst beq length zero-tn two-more)
-  (inst addu length length (fixnum -1))
-  (inst bne length zero-tn done)
-  (inst nop)
-
-  (inst srl byte data 16)
-  (inst and byte byte #xff)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  two-more
-
-  (inst srl byte data 8)
-  (inst and byte byte #xff)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  one-more
-
-  (inst and byte data #xff)
-  (inst xor accum accum byte)
-  (inst sll byte accum 5)
-  (inst srl accum accum 27)
-  (inst or accum accum byte)
-
-  done
-
-  (inst sll result accum 5)
-  (inst srl result result 3)
-
-  ;; Restore the return address.
-  (inst addu lip-tn retaddr code-tn))
-
diff --git a/assembly/mips/assem-rtns.lisp b/assembly/mips/assem-rtns.lisp
deleted file mode 100644
index 8a9bad2b260b5769649f1a0dd55ee0bb0af5572d..0000000000000000000000000000000000000000
--- a/assembly/mips/assem-rtns.lisp
+++ /dev/null
@@ -1,238 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/assem-rtns.lisp,v 1.28 1992/07/28 20:43:19 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-(in-package "MIPS")
-
-
-;;;; Return-multiple with other than one value
-
-#+assembler ;; we don't want a vop for this one.
-(define-assembly-routine
-    (return-multiple
-     (:return-style :none))
-
-     ;; These four are really arguments.
-    ((:temp nvals any-reg nargs-offset)
-     (:temp vals any-reg nl0-offset)
-     (:temp ocfp any-reg nl1-offset)
-     (:temp lra descriptor-reg lra-offset)
-
-     ;; These are just needed to facilitate the transfer
-     (:temp lip interior-reg lip-offset)
-     (:temp count any-reg nl2-offset)
-     (:temp src any-reg nl3-offset)
-     (:temp dst any-reg nl4-offset)
-     (:temp temp descriptor-reg l0-offset)
-
-     ;; These are needed so we can get at the register args.
-     (:temp a0 descriptor-reg a0-offset)
-     (:temp a1 descriptor-reg a1-offset)
-     (:temp a2 descriptor-reg a2-offset)
-     (:temp a3 descriptor-reg a3-offset)
-     (:temp a4 descriptor-reg a4-offset)
-     (:temp a5 descriptor-reg a5-offset))
-
-  ;; Note, because of the way the return-multiple vop is written, we can
-  ;; assume that we are never called with nvals == 1 and that a0 has already
-  ;; been loaded.
-  (inst blez nvals default-a0-and-on)
-  (inst subu count nvals (fixnum 2))
-  (inst blez count default-a2-and-on)
-  (inst lw a1 vals (* 1 vm:word-bytes))
-  (inst subu count (fixnum 1))
-  (inst blez count default-a3-and-on)
-  (inst lw a2 vals (* 2 vm:word-bytes))
-  (inst subu count (fixnum 1))
-  (inst blez count default-a4-and-on)
-  (inst lw a3 vals (* 3 vm:word-bytes))
-  (inst subu count (fixnum 1))
-  (inst blez count default-a5-and-on)
-  (inst lw a4 vals (* 4 vm:word-bytes))
-  (inst subu count (fixnum 1))
-  (inst blez count done)
-  (inst lw a5 vals (* 5 vm:word-bytes))
-
-  ;; Copy the remaining args to the top of the stack.
-  (inst addu src vals (* 6 vm:word-bytes))
-  (inst addu dst cfp-tn (* 6 vm:word-bytes))
-
-  LOOP
-  (inst lw temp src)
-  (inst addu src vm:word-bytes)
-  (inst sw temp dst)
-  (inst subu count (fixnum 1))
-  (inst bne count zero-tn loop)
-  (inst addu dst vm:word-bytes)
-		
-  (inst b done)
-  (inst nop)
-
-  DEFAULT-A0-AND-ON
-  (inst move a0 null-tn)
-  (inst move a1 null-tn)
-  DEFAULT-A2-AND-ON
-  (inst move a2 null-tn)
-  DEFAULT-A3-AND-ON
-  (inst move a3 null-tn)
-  DEFAULT-A4-AND-ON
-  (inst move a4 null-tn)
-  DEFAULT-A5-AND-ON
-  (inst move a5 null-tn)
-  DONE
-  
-  ;; Clear the stack.
-  (move ocfp-tn cfp-tn)
-  (move cfp-tn ocfp)
-  (inst addu csp-tn ocfp-tn nvals)
-  
-  ;; Return.
-  (lisp-return lra lip))
-
-
-
-;;;; tail-call-variable.
-
-#+assembler ;; no vop for this one either.
-(define-assembly-routine
-    (tail-call-variable
-     (:return-style :none))
-
-    ;; These are really args.
-    ((:temp args any-reg nl0-offset)
-     (:temp lexenv descriptor-reg lexenv-offset)
-
-     ;; We need to compute this
-     (:temp nargs any-reg nargs-offset)
-
-     ;; These are needed by the blitting code.
-     (:temp src any-reg nl1-offset)
-     (:temp dst any-reg nl2-offset)
-     (:temp count any-reg nl3-offset)
-     (:temp temp descriptor-reg l0-offset)
-
-     ;; Needed for the jump
-     (:temp lip interior-reg lip-offset)
-
-     ;; These are needed so we can get at the register args.
-     (:temp a0 descriptor-reg a0-offset)
-     (:temp a1 descriptor-reg a1-offset)
-     (:temp a2 descriptor-reg a2-offset)
-     (:temp a3 descriptor-reg a3-offset)
-     (:temp a4 descriptor-reg a4-offset)
-     (:temp a5 descriptor-reg a5-offset))
-
-
-  ;; Calculate NARGS (as a fixnum)
-  (inst subu nargs csp-tn args)
-     
-  ;; Load the argument regs (must do this now, 'cause the blt might
-  ;; trash these locations)
-  (inst lw a0 args (* 0 vm:word-bytes))
-  (inst lw a1 args (* 1 vm:word-bytes))
-  (inst lw a2 args (* 2 vm:word-bytes))
-  (inst lw a3 args (* 3 vm:word-bytes))
-  (inst lw a4 args (* 4 vm:word-bytes))
-  (inst lw a5 args (* 5 vm:word-bytes))
-
-  ;; Calc SRC, DST, and COUNT
-  (inst addu count nargs (fixnum (- register-arg-count)))
-  (inst blez count done)
-  (inst addu src args (* vm:word-bytes register-arg-count))
-  (inst addu dst cfp-tn (* vm:word-bytes register-arg-count))
-	
-  LOOP
-  ;; Copy one arg.
-  (inst lw temp src)
-  (inst addu src src vm:word-bytes)
-  (inst sw temp dst)
-  (inst addu count (fixnum -1))
-  (inst bgtz count loop)
-  (inst addu dst dst vm:word-bytes)
-	
-  DONE
-  ;; We are done.  Do the jump.
-  (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type)
-  (lisp-jump temp lip))
-
-
-
-;;;; Non-local exit noise.
-
-(define-assembly-routine (unwind
-			  (:translate %continue-unwind)
-			  (:policy :fast-safe))
-			 ((:arg block (any-reg descriptor-reg) a0-offset)
-			  (:arg start (any-reg descriptor-reg) ocfp-offset)
-			  (:arg count (any-reg descriptor-reg) nargs-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp cur-uwp any-reg nl0-offset)
-			  (:temp next-uwp any-reg nl1-offset)
-			  (:temp target-uwp any-reg nl2-offset))
-  (declare (ignore start count))
-
-  (let ((error (generate-error-code nil invalid-unwind-error)))
-    (inst beq block zero-tn error))
-  
-  (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)
-  (inst nop)
-      
-  (move cur-uwp block)
-
-  do-exit
-      
-  (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot)
-  (loadw code-tn cur-uwp vm:unwind-block-current-code-slot)
-  (loadw lra cur-uwp vm:unwind-block-entry-pc-slot)
-  (lisp-return lra lip :frob-code nil)
-
-  do-uwp
-
-  (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot)
-  (inst b do-exit)
-  (store-symbol-value next-uwp lisp::*current-unwind-protect-block*))
-
-
-(define-assembly-routine throw
-			 ((:arg target descriptor-reg a0-offset)
-			  (:arg start any-reg ocfp-offset)
-			  (:arg count any-reg nargs-offset)
-			  (:temp catch any-reg a1-offset)
-			  (:temp tag descriptor-reg a2-offset))
-  
-  (progn start count) ; We just need them in the registers.
-
-  (load-symbol-value catch lisp::*current-catch-block*)
-  
-  loop
-  
-  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
-    (inst beq catch zero-tn error)
-    (inst nop))
-  
-  (loadw tag catch vm:catch-block-tag-slot)
-  (inst beq tag target exit)
-  (inst nop)
-  (loadw catch catch vm:catch-block-previous-catch-slot)
-  (inst b loop)
-  (inst nop)
-  
-  exit
-  
-  (move target catch)
-  (inst j (make-fixup 'unwind :assembly-routine))
-  (inst nop))
-
-
diff --git a/assembly/mips/bit-bash.lisp b/assembly/mips/bit-bash.lisp
deleted file mode 100644
index 6137424653e5aa0d6139de4d60d9eb5982b23933..0000000000000000000000000000000000000000
--- a/assembly/mips/bit-bash.lisp
+++ /dev/null
@@ -1,527 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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/assembly/mips/bit-bash.lisp,v 1.13 1991/02/02 22:50:15 wlott Exp $
-;;;
-;;; Stuff to implement bit bashing.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "MIPS")
-
-
-;;;; Blitting macros.  Used only at assemble time.
-
-#+assembler
-(eval-when (compile eval)
-
-;;; The main dispatch.  Assumes that the following TNs are bound:
-;;;   dst, dst-offset  --  where to put the stuff.
-;;;   src, src-offset  --  where to get the stuff.
-;;;   dst-bit-offset, src-bit-offset
-;;;   length  -- the number of bits to move.
-;;;   temp1, temp2 -- random descriptor temp
-;;;   ntemp1, ntemp2, ntemp3  --  random non-descriptor temps.
-
-(defmacro do-copy ()
-  '(let ((wide-copy (gen-label))
-	 (copy-left (gen-label))
-	 (copy-right (gen-label)))
-     (compute-bit/word-offsets src src-offset src-bit-offset)
-     (compute-bit/word-offsets dst dst-offset dst-bit-offset)
-     
-     (inst addu temp1 dst-bit-offset length)
-     (inst subu temp1 (fixnum 32))
-     (inst bgez temp1 wide-copy)
-     (inst sltu ntemp1 src dst)
-
-     (narrow-copy)
-
-     (emit-label wide-copy)
-     (inst bne ntemp1 copy-right)
-     (inst nop)
-     (inst bne src dst copy-left)
-     (inst sltu ntemp1 src-bit-offset dst-bit-offset)
-     (inst bne ntemp1 copy-right)
-     (inst beq src-bit-offset dst-bit-offset done)
-     (inst nop)
-
-     (emit-label copy-left)
-     (wide-copy-left)
-
-     (emit-label copy-right)
-     (wide-copy-right)))
-
-(defmacro compute-bit/word-offsets (ptr offset bit)
-  `(progn
-     (inst and ,bit ,offset (fixnum 31))
-     (inst sra ntemp1 ,offset 7)
-     (inst sll ntemp1 2)
-     (inst addu ,ptr ntemp1)))
-
-     
-(defmacro narrow-copy ()
-  '(let ((aligned (gen-label))
-	 (only-one-src-word (gen-label))
-	 (merge-and-write (gen-label)))
-     (inst beq src-bit-offset dst-bit-offset aligned)
-     (inst lw ntemp1 src)
-
-     ;; It's not aligned, so get the source bits and align them.
-     (inst sra ntemp2 src-bit-offset 2)
-     (inst add temp1 src-bit-offset length)
-     (inst sub temp1 (fixnum 32))
-     (inst blez temp1 only-one-src-word)
-     (inst srl ntemp1 ntemp2)
-
-     (inst lw ntemp3 src 4)
-     (inst subu ntemp2 zero-tn ntemp2)
-     (inst sll ntemp3 ntemp2)
-     (inst or ntemp1 ntemp3)
-
-     (emit-label only-one-src-word)
-     (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign))
-     (inst addu ntemp3 length)
-     (inst lw ntemp3 ntemp3)
-     (inst sra ntemp2 dst-bit-offset 2)
-     (inst and ntemp1 ntemp3)
-     (inst sll ntemp1 ntemp2)
-     (inst b merge-and-write)
-     (inst sll ntemp3 ntemp2)
-
-     (emit-label aligned)
-     (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign))
-     (inst addu ntemp3 length)
-     (inst lw ntemp3 ntemp3)
-     (inst sra ntemp2 dst-bit-offset 2)
-     (inst sll ntemp3 ntemp2)
-     (inst and ntemp1 ntemp3)
-
-     (emit-label merge-and-write)
-     ;; ntemp1 has the bits we need to deposit, and ntemp3 has the mask.
-     ;; Both are aligned with dst.
-     (inst lw ntemp2 dst)
-     (inst nor ntemp3 ntemp3 zero-tn)
-     (inst and ntemp2 ntemp3)
-     (inst or ntemp1 ntemp2)
-     (inst b done)
-     (inst sw ntemp1 dst)))
-
-
-(defmacro wide-copy-left ()
-  '(let ((aligned (gen-label)))
-     ;; Check to see if they are aligned.
-     (inst beq src-bit-offset dst-bit-offset aligned)
-
-     ;; Calc src-shift
-     (inst subu src-shift dst-offset src-offset)
-     (inst and src-shift (fixnum 31))
-
-     (macrolet
-	 ((middle (&rest before-last-inst)
-	    `(progn
-	       (inst lw ntemp1 src)
-	       (inst lw ntemp2 src 4)
-	       (inst addu src 4)
-	       (inst sra ntemp3 src-shift 2)
-	       (inst sll ntemp2 ntemp2 ntemp3)
-	       (inst subu ntemp3 zero-tn ntemp3)
-	       (inst srl ntemp1 ntemp1 ntemp3)
-	       ,@before-last-inst
-	       (inst or ntemp1 ntemp2)))
-	  (get-src (where)
-	     (ecase where
-	       (:left
-		'(let ((dont-load (gen-label))
-		       (done-load (gen-label)))
-		   (inst sltu ntemp1 src-bit-offset dst-bit-offset)
-		   (inst bne ntemp1 dont-load)
-		   (middle (inst b done-load))
-		   (emit-label dont-load)
-		   (inst sra ntemp3 src-shift 2)
-		   (inst sll ntemp1 ntemp3)
-		   (emit-label done-load)))
-	       (:middle '(middle))
-	       (:right
-		'(let ((dont-load (gen-label))
-		       (done-load (gen-label)))
-		   (inst sltu ntemp1 src-shift final-bits)
-		   (inst beq ntemp1 dont-load)
-		   (middle (inst b done-load))
-		   (emit-label dont-load)
-		   (inst sra ntemp3 src-shift 2)
-		   (inst subu ntemp3 zero-tn ntemp3)
-		   (inst srl ntemp1 ntemp3)
-		   (emit-label done-load))))))
-       (wide-copy-left-aux))
-
-     (macrolet
-	 ((get-src (where)
-	    (declare (ignore where))
-	    '(progn
-	       (inst lw ntemp1 src)
-	       (inst addu src 4))))
-       (emit-label aligned)
-       (wide-copy-left-aux))))
-
-(defmacro wide-copy-left-aux ()
-  '(let ((left-aligned (gen-label))
-	 (loop (gen-label))
-	 (check-right (gen-label))
-	 (final-bits temp1)
-	 (interior temp2))
-     (inst beq dst-bit-offset left-aligned)
-     (inst nop)
-     
-     (get-src :left)
-     (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign))
-     (inst addu ntemp3 dst-bit-offset)
-     (inst lw ntemp3 ntemp3)
-     (inst lw ntemp2 dst)
-     (inst addu dst 4)
-     (inst and ntemp2 ntemp3)
-     (inst nor ntemp3 ntemp3 zero-tn)
-     (inst and ntemp1 ntemp3)
-     (inst or ntemp2 ntemp1)
-     (inst sw ntemp2 dst -4)
-
-     (emit-label left-aligned)
-
-     (inst addu final-bits length dst-bit-offset)
-     (inst and final-bits (fixnum 31))
-     (inst subu ntemp1 length final-bits)
-     (inst srl ntemp1 7)
-     (inst beq ntemp1 check-right)
-     (inst sll interior ntemp1 2)
-
-     (emit-label loop)
-     (get-src :middle)
-     (inst sw ntemp1 dst)
-     (check-for-interrupts)
-     (inst subu interior 4)
-     (inst bgtz interior loop)
-     (inst addu dst 4)
-
-     (emit-label check-right)
-     (inst beq final-bits done)
-     (inst nop)
-
-     (get-src :right)
-     (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign))
-     (inst addu ntemp3 final-bits)
-     (inst lw ntemp3 ntemp3)
-     (inst lw ntemp2 dst)
-     (inst and ntemp1 ntemp3)
-     (inst nor ntemp3 zero-tn ntemp3)
-     (inst and ntemp2 ntemp3)
-     (inst or ntemp1 ntemp2)
-     (inst b done)
-     (inst sw ntemp1 dst)))
-
-
-(defmacro wide-copy-right ()
-  '(let ((aligned (gen-label))
-	 (final-bits temp1))
-     ;; Compute final-bits, the number of bits in the final dst word.
-     (inst addu ntemp3 dst-bit-offset length)
-     (inst and final-bits ntemp3 (fixnum 31))
-
-     ;; Increase src and dst so they point to the end of the buffers instead
-     ;; of the beginning.
-     ;; 
-     (inst srl ntemp3 7)
-     (inst sll ntemp3 2)
-     (inst addu dst ntemp3)
-
-     (inst addu ntemp3 src-bit-offset length)
-     (inst subu ntemp3 final-bits)
-     (inst srl ntemp3 7)
-     (inst sll ntemp3 2)
-     (inst add src ntemp3)
-
-     ;; Check to see if they are aligned.
-     (inst beq src-bit-offset dst-bit-offset aligned)
-
-     ;; Calc src-shift
-     (inst subu src-shift dst-bit-offset src-bit-offset)
-     (inst and src-shift (fixnum 31))
-
-     (macrolet
-	 ((merge (&rest before-last-inst)
-	    `(progn
-	       (inst sra ntemp3 src-shift 2)
-	       (inst sll ntemp2 ntemp3)
-	       (inst subu ntemp3 zero-tn ntemp3)
-	       (inst srl ntemp1 ntemp3)
-	       ,@before-last-inst
-	       (inst or ntemp1 ntemp2)))
-	  (get-src (where)
-	     (ecase where
-	       (:left
-		'(let ((dont-load (gen-label))
-		       (done-load (gen-label)))
-		   (inst sltu ntemp1 src-bit-offset dst-bit-offset)
-		   (inst bne ntemp1 dont-load)
-		   (inst lw ntemp2 src 4)
-		   (inst lw ntemp1 src)
-		   (merge (inst b done-load))
-		   (emit-label dont-load)
-		   (inst sra ntemp3 src-shift 2)
-		   (inst sll ntemp1 ntemp2 ntemp3)
-		   (emit-label done-load)))
-	       (:middle
-		'(progn
-		   (inst lw ntemp1 src)
-		   (inst lw ntemp2 src 4)
-		   (merge)
-		   (inst subu src 4)))
-	       (:right
-		'(let ((dont-load (gen-label))
-		       (done-load (gen-label)))
-		   (inst sltu ntemp1 src-shift final-bits)
-		   (inst beq ntemp1 dont-load)
-		   (inst lw ntemp1 src)
-		   (inst lw ntemp2 src 4)
-		   (merge (inst b done-load))
-		   (emit-label dont-load)
-		   (inst sra ntemp3 src-shift 2)
-		   (inst subu ntemp3 zero-tn ntemp3)
-		   (inst srl ntemp1 ntemp3)
-		   (emit-label done-load))))))
-       (wide-copy-right-aux)
-       (inst b done)
-       (inst nop))
-
-     (macrolet
-	 ((get-src (where)
-	    `(progn
-	       (inst lw ntemp1 src)
-	       ,@(unless (eq where :right)
-		   '((inst subu src 4))))))
-       (emit-label aligned)
-       (wide-copy-right-aux))))
-
-(defmacro wide-copy-right-aux ()
-  '(let ((right-aligned (gen-label))
-	 (loop (gen-label))
-	 (check-left (gen-label))
-	 (interior temp2))
-     (inst beq final-bits right-aligned)
-     (inst nop)
-     
-     (get-src :right)
-     (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign))
-     (inst addu ntemp3 final-bits)
-     (inst lw ntemp3 ntemp3)
-     (inst lw ntemp2 dst)
-     (inst and ntemp1 ntemp3)
-     (inst nor ntemp3 ntemp3 zero-tn)
-     (inst and ntemp2 ntemp3)
-     (inst or ntemp2 ntemp1)
-     (inst sw ntemp2 dst)
-
-     (emit-label right-aligned)
-     (inst subu dst 4)
-     (inst subu src 4)
-
-     (inst subu ntemp1 length final-bits)
-     (inst srl ntemp1 7)
-     (inst beq ntemp1 check-left)
-     (inst sll interior ntemp1 2)
-
-     (emit-label loop)
-     (get-src :middle)
-     (inst sw ntemp1 dst)
-     (check-for-interrupts)
-     (inst subu interior 4)
-     (inst bgtz interior loop)
-     (inst subu dst 4)
-
-     (emit-label check-left)
-     (inst beq dst-bit-offset done)
-     (inst nop)
-
-     (get-src :left)
-     (inst li ntemp3 (make-fixup "bit_bash_low_masks" :foreign))
-     (inst addu ntemp3 dst-bit-offset)
-     (inst lw ntemp3 ntemp3)
-     (inst lw ntemp2 dst)
-     (inst nop)
-     (inst and ntemp2 ntemp3)
-     (inst nor ntemp3 zero-tn ntemp3)
-     (inst and ntemp1 ntemp3)
-     (inst or ntemp1 ntemp2)
-     (inst sw ntemp1 dst)))
-     
-(defmacro check-for-interrupts ()
-  nil)
-
-) ; eval-when (compile eval)
-
-
-
-;;;; The actual routines.
-
-(define-assembly-routine (copy-to-system-area
-			  (:policy :fast-safe)
-			  (:translate copy-to-system-area)
-			  (:arg-types * tagged-num
-				      system-area-pointer tagged-num
-				      tagged-num))
-			 ((:arg src-arg descriptor-reg a0-offset)
-			  (:arg src-offset any-reg a1-offset)
-			  (:arg dst sap-reg nl0-offset)
-			  (:arg dst-offset any-reg a2-offset)
-			  (:arg length any-reg a3-offset)
-			  (:res res descriptor-reg null-offset)
-			  
-			  (:temp src interior-reg lip-offset)
-			  (:temp temp1 descriptor-reg a4-offset)
-			  (:temp temp2 descriptor-reg a5-offset)
-			  (:temp src-shift descriptor-reg cname-offset)
-			  (:temp src-bit-offset descriptor-reg lexenv-offset)
-			  (:temp dst-bit-offset descriptor-reg l0-offset)
-			  (:temp ntemp1 non-descriptor-reg nl1-offset)
-			  (:temp ntemp2 non-descriptor-reg nl2-offset)
-			  (:temp ntemp3 non-descriptor-reg nl3-offset)
-			  (:temp retaddr non-descriptor-reg nargs-offset))
-
-  (progn res) ; don't complain that it's unused.
-
-  ;; Save the return address.
-  (inst subu retaddr lip-tn code-tn)
-
-  (inst subu src src-arg vm:other-pointer-type)
-  (inst and ntemp1 dst 3)
-  (inst xor dst ntemp1)
-  (inst sll ntemp1 5)
-  (inst addu dst-offset ntemp1)
-  (do-copy)
-  done
-
-  ;; Restore the return address.
-  (inst addu lip-tn retaddr code-tn))
-
-(define-assembly-routine (copy-from-system-area
-			  (:policy :fast-safe)
-			  (:translate copy-from-system-area)
-			  (:arg-types system-area-pointer tagged-num
-				      * tagged-num tagged-num))
-			 ((:arg src sap-reg nl0-offset)
-			  (:arg src-offset any-reg a0-offset)
-			  (:arg dst-arg descriptor-reg a1-offset)
-			  (:arg dst-offset any-reg a2-offset)
-			  (:arg length any-reg a3-offset)
-			  (:res res descriptor-reg null-offset)
-			  
-			  (:temp dst interior-reg lip-offset)
-			  (:temp temp1 descriptor-reg a4-offset)
-			  (:temp temp2 descriptor-reg a5-offset)
-			  (:temp src-shift descriptor-reg cname-offset)
-			  (:temp src-bit-offset descriptor-reg lexenv-offset)
-			  (:temp dst-bit-offset descriptor-reg l0-offset)
-			  (:temp ntemp1 non-descriptor-reg nl1-offset)
-			  (:temp ntemp2 non-descriptor-reg nl2-offset)
-			  (:temp ntemp3 non-descriptor-reg nl3-offset)
-			  (:temp retaddr non-descriptor-reg nargs-offset))
-  (progn res) ; don't complain that it's unused.
-
-  ;; Save the return address.
-  (inst sub retaddr lip-tn code-tn)
-
-  (inst and ntemp1 src 3)
-  (inst xor src ntemp1)
-  (inst sll ntemp1 5)
-  (inst addu src-offset ntemp1)
-  (inst subu dst dst-arg vm:other-pointer-type)
-  (do-copy)
-  done
-
-  ;; Restore the return address.
-  (inst add lip-tn retaddr code-tn))
-
-(define-assembly-routine (system-area-copy
-			  (:policy :fast-safe)
-			  (:translate system-area-copy)
-			  (:arg-types system-area-pointer tagged-num
-				      system-area-pointer tagged-num
-				      tagged-num))
-			 ((:arg src sap-reg nl1-offset)
-			  (:arg src-offset any-reg a0-offset)
-			  (:arg dst sap-reg nl0-offset)
-			  (:arg dst-offset any-reg a1-offset)
-			  (:arg length any-reg a2-offset)
-			  (:res res descriptor-reg null-offset)
-			  
-			  (:temp temp1 descriptor-reg a4-offset)
-			  (:temp temp2 descriptor-reg a5-offset)
-			  (:temp src-shift descriptor-reg cname-offset)
-			  (:temp src-bit-offset descriptor-reg lexenv-offset)
-			  (:temp dst-bit-offset descriptor-reg l0-offset)
-			  (:temp ntemp1 non-descriptor-reg nl2-offset)
-			  (:temp ntemp2 non-descriptor-reg nl3-offset)
-			  (:temp ntemp3 non-descriptor-reg nl4-offset))
-  (progn res) ; don't complain that it's unused.
-
-  (inst and ntemp1 src 3)
-  (inst xor src ntemp1)
-  (inst sll ntemp1 5)
-  (inst addu src-offset ntemp1)
-  (inst and ntemp1 dst 3)
-  (inst xor dst ntemp1)
-  (inst sll ntemp1 5)
-  (inst addu dst-offset ntemp1)
-  (do-copy)
-  done)
-
-(define-assembly-routine (bit-bash-copy
-			  (:policy :fast-safe)
-			  (:translate bit-bash-copy)
-			  (:arg-types * tagged-num * tagged-num tagged-num))
-			 ((:arg src-arg descriptor-reg a0-offset)
-			  (:arg src-offset any-reg a1-offset)
-			  (:arg dst-arg descriptor-reg a2-offset)
-			  (:arg dst-offset any-reg a3-offset)
-			  (:arg length any-reg a4-offset)
-			  (:res res descriptor-reg null-offset)
-			  
-			  (:temp src non-descriptor-reg nl0-offset)
-			  (:temp dst non-descriptor-reg nl1-offset)
-			  (:temp temp1 descriptor-reg a5-offset)
-			  (:temp temp2 descriptor-reg l0-offset)
-			  (:temp src-shift descriptor-reg cname-offset)
-			  (:temp src-bit-offset descriptor-reg lexenv-offset)
-			  (:temp dst-bit-offset descriptor-reg l1-offset)
-			  (:temp ntemp1 non-descriptor-reg nl2-offset)
-			  (:temp ntemp2 non-descriptor-reg nl3-offset)
-			  (:temp ntemp3 non-descriptor-reg nl4-offset))
-  (progn res) ; don't complain that it's unused.
-
-  (let ((done (gen-label)))
-    (pseudo-atomic (ntemp1)
-      (inst subu src src-arg vm:other-pointer-type)
-      (inst subu dst dst-arg vm:other-pointer-type)
-      (macrolet
-	  ((check-for-interrupts ()
-	     '(let ((label (gen-label)))
-		(inst and ntemp1 flags-tn (ash 1 interrupted-flag))
-		(inst beq ntemp1 label)
-		(inst nop)
-		(inst subu src src-arg)
-		(inst subu dst dst-arg)
-		(inst and flags-tn (logxor (ash 1 atomic-flag) #Xffff))
-		(inst break vm:pending-interrupt-trap)
-		(inst and flags-tn (logxor (ash 1 interrupted-flag) #Xffff))
-		(inst or flags-tn flags-tn (ash 1 atomic-flag))
-		(inst addu src src-arg)
-		(inst addu dst dst-arg)
-		(emit-label label))))
-	(do-copy))
-      (emit-label done))))
diff --git a/assembly/mips/support.lisp b/assembly/mips/support.lisp
deleted file mode 100644
index e54c65e956785a3de42226d63f0fd1aa422e23a7..0000000000000000000000000000000000000000
--- a/assembly/mips/support.lisp
+++ /dev/null
@@ -1,72 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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/assembly/mips/support.lisp,v 1.9 1992/07/31 21:54:14 wlott Exp $
-;;;
-;;; This file contains the machine specific support routines needed by
-;;; the file assembler.
-;;;
-(in-package "MIPS")
-
-(def-vm-support-routine generate-call-sequence (name style vop)
-  (ecase style
-    (:raw
-     (values
-      `((inst jal (make-fixup ',name :assembly-routine))
-	(inst nop))
-      nil))
-    (:full-call
-     (let ((temp (make-symbol "TEMP"))
-	   (nfp-save (make-symbol "NFP-SAVE"))
-	   (lra (make-symbol "LRA")))
-       (values
-	`((let ((lra-label (gen-label))
-		(cur-nfp (current-nfp-tn ,vop)))
-	    (when cur-nfp
-	      (store-stack-tn ,nfp-save cur-nfp))
-	    (inst compute-lra-from-code ,lra code-tn lra-label ,temp)
-	    (note-next-instruction ,vop :call-site)
-	    (inst j (make-fixup ',name :assembly-routine))
-	    (inst nop)
-	    (emit-return-pc lra-label)
-	    (note-this-location ,vop :single-value-return)
-	    (without-scheduling ()
-	      (move csp-tn ocfp-tn)
-	      (inst nop))
-	    (inst compute-code-from-lra code-tn code-tn
-		  lra-label ,temp)
-	    (when cur-nfp
-	      (load-stack-tn cur-nfp ,nfp-save))))
-	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
-		      ,temp)
-	  (:temporary (:sc descriptor-reg :offset lra-offset
-			   :from (:eval 0) :to (:eval 1))
-		      ,lra)
-	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
-		      ,nfp-save)
-	  (:save-p :compute-only)))))
-    (:none
-     (values
-      `((inst j (make-fixup ',name :assembly-routine))
-	(inst nop))
-      nil))))
-
-
-(def-vm-support-routine generate-return-sequence (style)
-  (ecase style
-    (:raw
-     `((inst j lip-tn)
-       (inst nop)))
-    (:full-call
-     `((lisp-return (make-random-tn :kind :normal
-				    :sc (sc-or-lose
-					 'descriptor-reg)
-				    :offset lra-offset)
-		    lip-tn :offset 2)))
-    (:none)))
diff --git a/assembly/mips/wrlist.lisp b/assembly/mips/wrlist.lisp
deleted file mode 100644
index f8ee79666a2318f0ec5dd2c578403bdf34c933c6..0000000000000000000000000000000000000000
--- a/assembly/mips/wrlist.lisp
+++ /dev/null
@@ -1,304 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/mips/wrlist.lisp,v 1.6 1992/03/12 16:28:31 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the assembly routines for write-list support.
-;;;
-
-(in-package "MIPS")
-
-(define-assembly-routine
-    (write-list-record)
-    ((:arg object descriptor-reg a0-offset)
-     (:arg offset non-descriptor-reg nl2-offset)
-     (:arg value descriptor-reg a1-offset)
-
-     (:temp nl0 non-descriptor-reg nl0-offset)
-     (:temp nl1 non-descriptor-reg nl1-offset)
-
-     (:temp nl3 non-descriptor-reg nl3-offset)
-     (:temp nl4 non-descriptor-reg nl4-offset)
-     (:temp nl5 non-descriptor-reg nl5-offset)
-     (:temp nargs non-descriptor-reg nargs-offset)
-
-     (:temp a2 any-reg a2-offset)
-     (:temp a3 any-reg a3-offset)
-     (:temp a4 any-reg a4-offset)
-     (:temp a5 any-reg a5-offset)
-     (:temp cname any-reg cname-offset)
-     (:temp lexenv any-reg lexenv-offset)
-     (:temp l0 any-reg l0-offset)
-     (:temp l1 any-reg l1-offset)
-     (:temp l2 any-reg l2-offset)
-     (:temp l3 any-reg l3-offset)
-     (:temp nfp any-reg nfp-offset)
-     (:temp ocfp any-reg ocfp-offset)
-     (:temp lra any-reg lra-offset))
-
-  ;; The write into memory and the write into the write-list have to be atomic.
-  (start-pseudo-atomic)
-
-  TRY-AGAIN
-
-  ;; First, make sure there is space available in the write list.
-  (inst lw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes))
-  (inst lw nl1 mutator-tn (* mutator-write-list-end-slot word-bytes))
-  (inst nop)
-  (inst bne nl0 nl1 space-available)
-  (inst nop)
-
-  ;; No space, so we have to call out to gengc_FlushWriteList.
-
-  ;; We have to save all the descriptor registers on the stack in case
-  ;; we end up collecting garbage while in C.
-
-  ;; Save all lisp regs on the stack, so the garbage collector can find them.
-  (save-regs-on-stack (object value a2 a3 a4 a5 cname lexenv
-		       l0 l1 l2 l3 nfp ocfp code-tn lra null-tn)
-
-    ;; Convert the return address into an offset.  We don't have to save l0
-    ;; across the call-out because it is one of the saved regs.
-    (inst subu l0 lip-tn code-tn)
-
-    ;; Decache all the lisp state from the mutator structure.
-    (storew csp-tn mutator-tn mutator-control-stack-pointer-slot)
-    (storew cfp-tn mutator-tn mutator-control-frame-pointer-slot)
-
-    ;; Indicate that we are now in foreign-function-call land.
-    (storew csp-tn mutator-tn mutator-foreign-fn-call-active-slot)
-
-    ;; Turn off pseudo-atomic.
-    (end-pseudo-atomic nl0)
-
-    ;; Move offset to one of the saved registers.
-    (inst move l1 offset)
-
-    ;; Move the other non-descriptor regs into saved regs.
-    (inst move l2 nl3)
-    (inst move l3 nl4)
-    (inst move nfp nl5)
-    (inst move ocfp nargs)
-
-    ;; Allocate the stack frame.
-    (inst subu nsp-tn nsp-tn (* 4 word-bytes))
-
-    ;; Restore GP
-    (inst li null-tn (make-fixup "_gp" :foreign))
-
-    ;; Call-out to gengc_Allocate, setting up the single argument.
-    (inst jal (make-fixup "gengc_FlushWriteList" :foreign))
-    (inst move nl0 mutator-tn)
-
-    ;; Deallocate the stack frame.
-    (inst addu nsp-tn nsp-tn (* 4 word-bytes))
-
-    ;; Restore offset from the saved reg.
-    (inst move offset l1)
-
-    ;; Restore the other non-descriptor regs.
-    (inst move nl3 l2)
-    (inst move nl4 l3)
-    (inst move nl5 nfp)
-    (inst move nargs ocfp)
-
-    ;; Turn pseudo-atomic back on.
-    (start-pseudo-atomic)
-
-    ;; No longer in foreign-foreign-call land.
-    (storew zero-tn mutator-tn mutator-foreign-fn-call-active-slot)
-
-    ;; Cache lisp state from the mutator structure.
-    (loadw csp-tn mutator-tn mutator-control-stack-pointer-slot)
-    (loadw cfp-tn mutator-tn mutator-control-frame-pointer-slot)
-
-    ;; We can't restore the return address yet, because code hasn't been
-    ;; restored.  But if we wait until after code has been restored,
-    ;; then l0 will have been trashed.  So we have to move the value
-    ;; out of l0 and into nl0.
-    (inst move nl0 l0)
-
-    ;; Restore all the saved regs. (by dropping out of the save-regs-on-stack)
-    )
-
-  ;; Regenerate the return address from the saved offset.
-  (inst addu lip-tn nl0 code-tn)
-    
-  ;; Because we turned off pseudo-atomic, we might have taken an interrupt,
-  ;; so we can't be sure the write-list will be empty.
-  (inst b try-again)
-  (inst nop)
-
-  SPACE-AVAILABLE
-
-  (inst addu nl1 object offset)
-  (inst sw nl1 nl0)
-  (inst sw value nl1)
-  (inst addu nl0 4)
-  (inst sw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes))
-
-  (end-pseudo-atomic nl0))
-
-
-(define-assembly-routine
-    (set-fdefn-function)
-    ((:arg fdefn descriptor-reg a0-offset)
-     (:arg function descriptor-reg a1-offset)
-
-     (:temp nl0 non-descriptor-reg nl0-offset)
-     (:temp nl1 non-descriptor-reg nl1-offset)
-
-     (:temp nl2 non-descriptor-reg nl2-offset)
-     (:temp nl3 non-descriptor-reg nl3-offset)
-     (:temp nl4 non-descriptor-reg nl4-offset)
-     (:temp nl5 non-descriptor-reg nl5-offset)
-     (:temp nargs non-descriptor-reg nargs-offset)
-
-     (:temp a2 any-reg a2-offset)
-     (:temp a3 any-reg a3-offset)
-     (:temp a4 any-reg a4-offset)
-     (:temp a5 any-reg a5-offset)
-     (:temp cname any-reg cname-offset)
-     (:temp lexenv any-reg lexenv-offset)
-     (:temp l0 any-reg l0-offset)
-     (:temp l1 any-reg l1-offset)
-     (:temp l2 any-reg l2-offset)
-     (:temp l3 any-reg l3-offset)
-     (:temp nfp any-reg nfp-offset)
-     (:temp ocfp any-reg ocfp-offset)
-     (:temp lra any-reg lra-offset))
-
-  ;; The write into memory and the write into the write-list have to be atomic.
-  (start-pseudo-atomic)
-
-  ;; First, check to see if we don't need to make a write-list entry because
-  ;; the fdefn object is ephemeral.
-  (inst srl nl0 fdefn 30)
-  (inst bne nl0 zero-tn just-do-write)
-  (inst nop)
-
-  TRY-AGAIN
-
-  ;; Now make sure there is space available in the write list.
-  (inst lw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes))
-  (inst lw nl1 mutator-tn (* mutator-write-list-end-slot word-bytes))
-  (inst nop)
-  (inst bne nl0 nl1 space-available)
-  (inst nop)
-
-  ;; No space, so we have to call out to gengc_FlushWriteList.
-
-  ;; We have to save all the descriptor registers on the stack in case
-  ;; we end up collecting garbage while in C.
-
-  ;; Save all lisp regs on the stack, so the garbage collector can find them.
-  (save-regs-on-stack (fdefn function a2 a3 a4 a5 cname lexenv
-		       l0 l1 l2 l3 nfp ocfp code-tn lra null-tn)
-
-    ;; Convert the return address into an offset.  We don't have to save l0
-    ;; across the call-out because it is one of the saved regs.
-    (inst subu l0 lip-tn code-tn)
-
-    ;; Decache all the lisp state from the mutator structure.
-    (storew csp-tn mutator-tn mutator-control-stack-pointer-slot)
-    (storew cfp-tn mutator-tn mutator-control-frame-pointer-slot)
-
-    ;; Indicate that we are now in foreign-function-call land.
-    (storew csp-tn mutator-tn mutator-foreign-fn-call-active-slot)
-
-    ;; Turn off pseudo-atomic.
-    (end-pseudo-atomic nl0)
-
-    ;; Move the non-descriptor regs into saved regs.
-    (inst move l1 nl2)
-    (inst move l2 nl3)
-    (inst move l3 nl4)
-    (inst move nfp nl5)
-    (inst move ocfp nargs)
-
-    ;; Allocate the stack frame.
-    (inst subu nsp-tn nsp-tn (* 4 word-bytes))
-
-    ;; Restore GP
-    (inst li null-tn (make-fixup "_gp" :foreign))
-
-    ;; Call-out to gengc_Allocate, setting up the single argument.
-    (inst jal (make-fixup "gengc_FlushWriteList" :foreign))
-    (inst move nl0 mutator-tn)
-
-    ;; Deallocate the stack frame.
-    (inst addu nsp-tn nsp-tn (* 4 word-bytes))
-
-    ;; Restore the non-descriptor regs.
-    (inst move nl2 l1)
-    (inst move nl3 l2)
-    (inst move nl4 l3)
-    (inst move nl5 nfp)
-    (inst move nargs ocfp)
-
-    ;; Turn pseudo-atomic back on.
-    (start-pseudo-atomic)
-
-    ;; No longer in foreign-foreign-call land.
-    (storew zero-tn mutator-tn mutator-foreign-fn-call-active-slot)
-
-    ;; Cache lisp state from the mutator structure.
-    (loadw csp-tn mutator-tn mutator-control-stack-pointer-slot)
-    (loadw cfp-tn mutator-tn mutator-control-frame-pointer-slot)
-
-    ;; We can't restore the return address yet, because code hasn't been
-    ;; restored.  But if we wait until after code has been restored,
-    ;; then l0 will have been trashed.  So we have to move the value
-    ;; out of l0 and into nl0.
-    (inst move nl0 l0)
-
-    ;; Restore all the saved regs. (by dropping out of the save-regs-on-stack)
-    )
-
-  ;; Regenerate the return address from the saved offset.
-  (inst addu lip-tn nl0 code-tn)
-    
-  ;; Because we turned off pseudo-atomic, we might have taken an interrupt,
-  ;; so we can't be sure the write-list will be empty.
-  (inst b try-again)
-  (inst nop)
-
-  SPACE-AVAILABLE
-
-  (inst subu nl1 fdefn other-pointer-type)
-  (inst sw nl1 nl0)
-  (inst addu nl0 4)
-  (inst sw nl0 mutator-tn (* mutator-write-list-fill-pointer-slot word-bytes))
-
-  JUST-DO-WRITE
-
-  (load-type nl0 function (- vm:function-pointer-type))
-  (inst nop)
-  (inst xor nl0 vm:closure-header-type)
-  (inst beq nl0 zero-tn closure)
-  (inst xor nl0 (logxor closure-header-type funcallable-instance-header-type))
-  (inst beq nl0 zero-tn closure)
-  (inst xor nl0 (logxor funcallable-instance-header-type function-header-type))
-  (inst beq nl0 zero-tn normal-fn)
-  (inst addu nl1 function
-	(- (ash vm:function-header-code-offset vm:word-shift)
-	   vm:function-pointer-type))
-  (end-pseudo-atomic nl0)
-  (error-call nil kernel:object-not-function-error function)
-
-  CLOSURE
-  (inst li nl1 (make-fixup "closure_tramp" :foreign))
-
-  NORMAL-FN
-  (storew function fdefn fdefn-function-slot other-pointer-type)
-  (storew nl1 fdefn fdefn-raw-addr-slot other-pointer-type)
-
-  (end-pseudo-atomic nl0))
diff --git a/assembly/rt/alloc.lisp b/assembly/rt/alloc.lisp
deleted file mode 100644
index 2d129bbee1873fee4d80938d17d02e37557021b7..0000000000000000000000000000000000000000
--- a/assembly/rt/alloc.lisp
+++ /dev/null
@@ -1,95 +0,0 @@
-;;; -*- Package: RT -*-
-;;;
-;;; **********************************************************************
-;;; 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/assembly/rt/alloc.lisp,v 1.5 1991/10/22 19:07:16 wlott Exp $
-;;;
-;;; Stuff to handle allocating simple objects.
-;;;
-;;; Written by William Lott.
-;;; Converted to the IBM RT by Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-(define-for-each-primitive-object (obj)
-  (let* ((options (primitive-object-options obj))
-	 (alloc-trans (getf options :alloc-trans))
-	 (alloc-vop (getf options :alloc-vop alloc-trans))
-	 (header (primitive-object-header obj))
-	 (lowtag (primitive-object-lowtag obj))
-	 (size (primitive-object-size obj))
-	 (variable-length (primitive-object-variable-length obj))
-	 (need-unbound-marker nil))
-    (collect ((args) (init-forms))
-      (when (and alloc-vop variable-length)
-	(args 'extra-words))
-      (dolist (slot (primitive-object-slots obj))
-	(let* ((name (slot-name slot))
-	       (offset (slot-offset slot)))
-	  (ecase (getf (slot-options slot) :init :zero)
-	    (:zero)
-	    (:null
-	     (init-forms `(storew null-tn result ,offset ,lowtag)))
-	    (:unbound
-	     (setf need-unbound-marker t)
-	     (init-forms `(storew temp result ,offset ,lowtag)))
-	    (:arg
-	     (args name)
-	     (init-forms `(storew ,name result ,offset ,lowtag))))))
-      (when (and (null alloc-vop) (args))
-	(error "Slots ~S want to be initialized, but there is no alloc vop ~
-	defined for ~S."
-	       (args) (primitive-object-name obj)))
-      (when alloc-vop
-	`(define-assembly-routine
-	     (,alloc-vop
-	      (:cost 35)
-	      ,@(when alloc-trans
-		  `((:translate ,alloc-trans)))
-	      (:policy :fast-safe))
-	     (,@(let ((arg-offsets (cdr register-arg-offsets)))
-		  (mapcar #'(lambda (name)
-			      (unless arg-offsets
-				(error "Too many args in ~S" alloc-vop))
-			      `(:arg ,name (descriptor-reg any-reg)
-				     ,(pop arg-offsets)))
-			  (args)))
-		(:temp alloc non-descriptor-reg nl0-offset)
-		(:temp temp non-descriptor-reg ocfp-offset)
-		(:res result descriptor-reg a0-offset))
-	   (pseudo-atomic (temp)
-	     (load-symbol-value alloc *allocation-pointer*)
-	     (inst cal result alloc ,lowtag)
-	     ,@(cond ((and header variable-length)
-		      `((inst cal temp extra-words (fixnum (1- ,size)))
-			(inst cas alloc temp alloc)
-			(inst sl temp (- type-bits word-shift))
-			(inst oil temp ,header)
-			(storew temp result 0 ,lowtag)
-			(inst cal alloc alloc (+ (fixnum 1) lowtag-mask))
-			(inst li temp (lognot lowtag-mask))
-			(inst n alloc temp)))
-		     (variable-length
-		      (error ":REST-P T with no header in ~S?"
-			     (primitive-object-name obj)))
-		     (header
-		      `((inst cal alloc alloc (pad-data-block ,size))
-			(inst li temp
-			      ,(logior (ash (1- size) type-bits)
-				       (symbol-value header)))
-			(storew temp result 0 ,lowtag)))
-		     (t
-		      `((inst cal alloc alloc (pad-data-block ,size)))))
-	     ,@(when need-unbound-marker
-		 `((inst li temp unbound-marker-type)))
-	     ,@(init-forms)
-	     (store-symbol-value alloc *allocation-pointer*))
-	   (load-symbol-value temp *internal-gc-trigger*)
-	   (inst tlt temp alloc))))))
diff --git a/assembly/rt/arith.lisp b/assembly/rt/arith.lisp
deleted file mode 100644
index 01c092fc23360714d54627863216bb557fc7687b..0000000000000000000000000000000000000000
--- a/assembly/rt/arith.lisp
+++ /dev/null
@@ -1,478 +0,0 @@
-;;; -*- Package: RT -*-
-;;;
-;;; **********************************************************************
-;;; 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/assembly/rt/arith.lisp,v 1.6 1991/10/24 09:49:02 wlott Exp $
-;;;
-;;; Stuff to handle simple cases for generic arithmetic.
-;;;
-;;; Written by William Lott.
-;;; Converted to IBM RT by Bill Chiles.
-
-(in-package "RT")
-
-
-(define-assembly-routine (generic-+
-			  (:cost 25)
-			  (:return-style :full-call)
-			  (:translate +)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg any-reg) a0-offset)
-
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp cname descriptor-reg cname-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  ;; If either arg is not a fixnum, call the static function.
-  (move temp x)
-  (inst nilz temp 3)
-  (inst bnc :eq DO-STATIC-FUN)
-  (move temp y)
-  (inst nilz temp 3)
-  (inst bnc :eq DO-STATIC-FUN)
-  ;; Use ocfp as a temporary result.
-  (move ocfp x)
-  (inst a ocfp y)
-  (inst bnc :ov fixnum-result)
-  ;; If we overflowed, shift the operands down to lose the fixnum lowtag bits
-  ;; and do the add again.
-  (move ocfp x)
-  (inst sar ocfp 2)
-  (move temp y)
-  (inst sar temp 2)
-  (inst a ocfp temp)
-  ;; Allocate a bignum for sum.
-  (with-fixed-allocation (res temp cname bignum-type
-			      (1+ bignum-digits-offset))
-    (storew ocfp res bignum-digits-offset other-pointer-type))
-  ;; Now get out of here.
-  (lisp-return lra lip :offset 1)
-
-  DO-STATIC-FUN
-  (load-symbol cname 'two-arg-+)
-  (inst li nargs (fixnum 2))
-  (loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
-  (move ocfp cfp-tn)
-  ;; Tail call TWO-ARG-+.
-  (inst bx lip)
-  (move cfp-tn csp-tn)
-
-  FIXNUM-RESULT
-  ;; Ocfp was used for the temporary result.
-  (move res ocfp))
-
-(define-assembly-routine (generic--
-			  (:cost 25)
-			  (:return-style :full-call)
-			  (:translate -)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg any-reg) a0-offset)
-
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp cname descriptor-reg cname-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  ;; If either arg is not a fixnum, call the static function.
-  (move temp x)
-  (inst nilz temp 3)
-  (inst bnc :eq DO-STATIC-FUN)
-  (move temp y)
-  (inst nilz temp 3)
-  (inst bnc :eq DO-STATIC-FUN)
-  ;; Use ocfp as a temporary result.
-  (move ocfp x)
-  (inst s ocfp y)
-  (inst bnc :ov fixnum-result)
-  ;; If we overflowed, shift the operands down to lose the fixnum lowtag bits
-  ;; and do the subtract again.
-  (move ocfp x)
-  (inst sar ocfp 2)
-  (move temp y)
-  (inst sar temp 2)
-  (inst s ocfp temp)
-  ;; Allocate a bignum for sum.
-  (with-fixed-allocation (res temp cname bignum-type
-			      (1+ bignum-digits-offset))
-    (storew ocfp res bignum-digits-offset other-pointer-type))
-  ;; Now get out of here.
-  (lisp-return lra lip :offset 1)
-
-  DO-STATIC-FUN
-  (load-symbol cname 'two-arg--)
-  (inst li nargs (fixnum 2))
-  (loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
-  (move ocfp cfp-tn)
-  ;; Tail call TWO-ARG-+.
-  (inst bx lip)
-  (move cfp-tn csp-tn)
-
-  FIXNUM-RESULT
-  ;; Ocfp was used for the temporary result.
-  (move res ocfp))
-
-(define-assembly-routine (generic-*
-			  (:cost 70)
-			  (:return-style :full-call)
-			  (:translate *)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg any-reg) a0-offset)
-
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp alloc word-pointer-reg a2-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs/high non-descriptor-reg nargs-offset)
-			  (:temp ocfp/low non-descriptor-reg ocfp-offset)
-			  (:temp cname descriptor-reg cname-offset))
-  ;; If either arg is not a fixnum, call the static function.
-  (move temp x)
-  (inst nilz temp 3)
-  (inst bnc :eq DO-STATIC-FUN)
-  (move temp y)
-  (inst nilz temp 3)
-  (inst bnc :eq DO-STATIC-FUN)
-
-  ;; Remove the tag from one arg so that the result will have the correct
-  ;; fixnum lowtag.  Without this, the result if off by a factor of 16, but we
-  ;; want it off by a factor of 4 (the fixnum lowtag).
-  (move temp x)
-  (inst sar temp 2)
-  ;; Setup system register for multiply.
-  (inst mtmqscr temp)
-
-  ;; Do the multiply.
-  ;; Subtract high from high to set it to zero and to set the C0 condition
-  ;; bit appropriately for the m instruction.
-  (inst s nargs/high nargs/high)
-  (dotimes (i 16)
-    (inst m nargs/high y))
-  (inst mfmqscr res)
-
-  ;; Check to see if the result will fit in a fixnum.  (I.e. the high word is
-  ;; just 32 copies of the sign bit of the low word).
-  (move temp res)
-  (inst sar temp 31)
-  (inst c temp nargs/high)
-  (inst bc :eq DONE)
-  ;; Build two bignum-digits by shifting the double word high:res down two bits
-  ;; into high:low to get rid of the fixnum lowtag.
-  (move ocfp/low res)
-  (inst sr ocfp/low 2)
-  (move temp nargs/high)
-  (inst sl temp 30)
-  (inst o ocfp/low temp)
-  (inst sar nargs/high 2)
-  ;; Allocate a bignum for the result.
-  (pseudo-atomic (temp)
-    (let ((one-word (gen-label)))
-      (load-symbol-value alloc *allocation-pointer*)
-      (inst cal res alloc other-pointer-type)
-      ;; Assume we need one word.
-      (inst cal alloc alloc (pad-data-block (1+ bignum-digits-offset)))
-      ;; Is that correct?
-      (move temp ocfp/low)
-      (inst sar temp 31)
-      (inst c temp nargs/high)
-      (inst bcx :eq one-word)
-      (inst li temp (logior (ash 1 type-bits) bignum-type))
-      ;; Nope, we need two, so allocate the addition space.
-      (inst cal alloc alloc (- (pad-data-block (+ 2 bignum-digits-offset))
-			       (pad-data-block (1+ bignum-digits-offset))))
-      (inst li temp (logior (ash 2 type-bits) bignum-type))
-      (storew nargs/high res (1+ bignum-digits-offset) other-pointer-type)
-      (emit-label one-word)
-      (store-symbol-value alloc *allocation-pointer*)
-      (storew temp res 0 other-pointer-type)
-      (storew ocfp/low res bignum-digits-offset other-pointer-type)))
-  (load-symbol-value temp *internal-gc-trigger*)
-  (inst tlt temp alloc)
-  ;; Out of here
-  (lisp-return lra lip :offset 1)
-
-  DO-STATIC-FUN
-  (load-symbol cname 'two-arg-*)
-  (inst li nargs/high (fixnum 2))
-  (loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
-  (move ocfp/low cfp-tn)
-  (inst bx lip)
-  (move cfp-tn csp-tn)
-
-  DONE)
-
-(define-assembly-routine (generic-truncate
-			  (:cost 95)
-			  (:return-style :full-call)
-			  (:translate truncate)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res quo (descriptor-reg any-reg) a0-offset)
-			  (:res rem (descriptor-reg any-reg) a1-offset)
-
-			  (:temp temp1 non-descriptor-reg nl0-offset)
-			  (:temp alloc word-pointer-reg a2-offset)
-			  (:temp lip interior-reg lip-offset)
-
-			  ;; High holds the sign of x and becomes the remainder.
-			  (:temp nargs/high non-descriptor-reg nargs-offset)
-			  (:temp cname descriptor-reg cname-offset)
-			  (:temp ocfp/temp2 non-descriptor-reg ocfp-offset))
-  ;; If either arg is not a fixnum, call the static function.
-  (move temp1 x)
-  (inst nilz temp1 3)
-  (inst bnc :eq DO-STATIC-FUN)
-  (move temp1 y)
-  (inst nilz temp1 3)
-  (inst bnc :eq DO-STATIC-FUN)
-
-  ;; Make sure y is not 0, 1, or -1.
-  (inst c y 0)
-  (inst bcx :eq zero-divisor)
-  (inst c y (fixnum 1))
-  (inst bcx :eq one-divisor)
-  (inst c y (fixnum -1))
-  (inst bc :eq neg-one-divisor)
-
-  ;; Do the division.
-  (move nargs/high x)
-  (inst sar nargs/high 31)
-  (inst mtmqscr x)
-  (dotimes (i 32)
-    (inst d nargs/high y))
-  ;; Check preliminary remainder by considering signs of high and y.
-  ;; This is an extra step to account for the non-restoring divide-step instr.
-  ;; We don't actually have to check this since the d instruction set :c0
-  ;; when the signs of high and y are the same.
-  (inst bc :c0 rem-okay)
-  (inst a nargs/high y)
-  REM-OKAY
-
-  ;; The RT gives us some random division concept, but we're writing TRUNCATE.
-  ;; The fixup involves adding one to the quotient and subtracting the divisor
-  ;; from the remainder under certain circumstances:
-  ;; IF the remainder is zero, we're done.
-  (inst c nargs/high 0)
-  (inst bc :eq move-results)
-  ;; ELSE-IF the remainder is equal to the divisor, we can obviously take
-  ;; one more divisor out of the dividend, so do it.
-  (inst c nargs/high y)
-  (inst bc :eq do-it)
-  ;; ELSE-IF the divisor and dividend had different signs, adjust the results.
-  (move temp1 x)
-  (inst x temp1 y)
-  (inst bnc :lt move-results)
-
-  DO-IT
-  ;; Add 1 to quotient and subtract divisor from remainder.
-  (inst mfmqscr temp1)
-  (inst sl temp1 2)
-  (inst a quo temp1 (fixnum 1))
-  ;; Since rem and y are the same register, this subtracts the divisor from
-  ;; the remainder, putting the result in our rem result register.
-  (inst sf y nargs/high)
-
-  (inst b done)
-
-  MOVE-RESULTS
-  (inst mfmqscr temp1)
-  (inst sl temp1 2)
-  (move quo temp1)
-  ;; The remainder is always on the same order of magnitude as the dividend,
-  ;; so it already has fixnum lowtag bits.
-  (move rem nargs/high)
-  (inst b done)
-
-  DO-STATIC-FUN
-  (load-symbol cname 'truncate)
-  (inst li nargs/high (fixnum 2))
-  (loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
-  (move ocfp/temp2 cfp-tn)
-  ;; Get out of here, doing a tail call.
-  (inst bx lip)
-  (move cfp-tn csp-tn)
-
-
-  ZERO-DIVISOR
-  ;; signal an error somehow.
-
-  NEG-ONE-DIVISOR
-  (inst li rem 0)
-  (inst neg quo x)
-  ;; If quo still fits in a fixnum, go to done.
-  (inst bnc :ov done)
-  ;; Allocate a bignum for quo.
-  (with-fixed-allocation (temp1 ocfp/temp2 alloc bignum-type
-				(+ 2 bignum-digits-offset))
-    ;; If we overflowed quo, then we must have made a positive value from a
-    ;; negative one.  The overflow would be one bit and some zero's for sign.
-    (inst li ocfp/temp2 0)
-    (storew quo temp1 bignum-digits-offset other-pointer-type)
-    (storew ocfp/temp2 temp1 (1+ bignum-digits-offset) other-pointer-type))
-  (move quo temp1)
-
-  (inst b done)
-
-  ONE-DIVISOR
-  (inst li rem 0)
-  (move quo x)
-
-  DONE)
-
-
-
-;;;; Conditionals
-
-(define-assembly-routine (generic-<
-			  (:cost 25)
-			  (:return-style :full-call)
-			  (:translate <)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg) a0-offset)
-
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp cname descriptor-reg cname-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  ;; If either arg is not a fixnum, call the static function.
-  (move temp x)
-  (inst nilz temp 3)
-  (inst bnc :eq DO-STATIC-FUN)
-  (move temp y)
-  (inst nilz temp 3)
-  (inst bnc :eq DO-STATIC-FUN)
-
-  ;; They are both fixnums, we can compare them.
-  (inst c x y)
-  (inst bcx :lt DONE)
-  (load-symbol res t)
-
-  (inst bx DONE)
-  (move res null-tn)
-
-  DO-STATIC-FUN
-  (load-symbol cname 'two-arg-<)
-  (inst li nargs (fixnum 2))
-  (loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
-  (move ocfp cfp-tn)
-  ;; Tail call TWO-ARG->.
-  (inst bx lip)
-  (move cfp-tn csp-tn)
-
-  DONE)
-
-(define-assembly-routine (generic->
-			  (:cost 25)
-			  (:return-style :full-call)
-			  (:translate >)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg) a0-offset)
-
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp cname descriptor-reg cname-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  ;; If either arg is not a fixnum, call the static function.
-  (move temp x)
-  (inst nilz temp 3)
-  (inst bnc :eq DO-STATIC-FUN)
-  (move temp y)
-  (inst nilz temp 3)
-  (inst bnc :eq DO-STATIC-FUN)
-
-  ;; They are both fixnums, we can compare them.
-  (inst c x y)
-  (inst bcx :gt DONE)
-  (load-symbol res t)
-
-  (inst bx DONE)
-  (move res null-tn)
-
-  DO-STATIC-FUN
-  (load-symbol cname 'two-arg->)
-  (inst li nargs (fixnum 2))
-  (loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
-  (move ocfp cfp-tn)
-  ;; Tail call TWO-ARG->.
-  (inst bx lip)
-  (move cfp-tn csp-tn)
-
-  DONE)
-
-
-(define-assembly-routine (generic-=
-			  (:cost 25)
-			  (:return-style :full-call)
-			  (:translate =)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg) a0-offset)
-
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp cname descriptor-reg cname-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  ;; If they are eq, they must be =
-  (inst c x y)
-  (inst bc :eq TRUE)
-
-  ;; If both args are fixnums, we know the result is NIL.  Otherwise, we
-  ;; have to hit the static fun.
-  (move temp x)
-  (inst nilz temp 3)
-  (inst bnc :eq DO-STATIC-FUN)
-  (move temp y)
-  (inst nilz temp 3)
-  (inst bnc :eq DO-STATIC-FUN)
-
-  (inst bx DONE)
-  (move res null-tn)
-
-  DO-STATIC-FUN
-  (load-symbol cname 'two-arg-=)
-  (inst li nargs (fixnum 2))
-  (loadw lip cname symbol-raw-function-addr-slot other-pointer-type)
-  (move ocfp cfp-tn)
-  ;; Tail call TWO-ARG-=.
-  (inst bx lip)
-  (move cfp-tn csp-tn)
-
-  TRUE
-  (load-symbol res t)
-  DONE)
diff --git a/assembly/rt/array.lisp b/assembly/rt/array.lisp
deleted file mode 100644
index da95439f0abebffac1cc934a904f3765c0c2835c..0000000000000000000000000000000000000000
--- a/assembly/rt/array.lisp
+++ /dev/null
@@ -1,124 +0,0 @@
-;;; -*- Package: RT -*-
-;;;
-;;; **********************************************************************
-;;; 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/assembly/rt/array.lisp,v 1.4 1991/10/22 16:50:36 wlott Exp $
-;;;
-;;; This file contains the support routines for arrays and vectors.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "RT")
-
-
-(define-assembly-routine (allocate-vector
-			  (:policy :fast-safe)
-			  (:translate allocate-vector)
-			  (:arg-types positive-fixnum
-				      positive-fixnum
-				      positive-fixnum))
-			 ((:arg type any-reg a0-offset)
-			  (:arg length any-reg a1-offset)
-			  (:arg words any-reg a2-offset)
-			  (:res result descriptor-reg a0-offset)
-
-			  (:temp ndescr non-descriptor-reg nl0-offset)
-			  (:temp alloc word-pointer-reg ocfp-offset)
-			  (:temp vector descriptor-reg cname-offset))
-  (pseudo-atomic (ndescr)
-    (load-symbol-value alloc *allocation-pointer*)
-    (inst cal vector alloc vm:other-pointer-type)
-    (inst cal alloc alloc (+ (1- (ash 1 vm:lowtag-bits))
-			     (* vm:vector-data-offset vm:word-bytes)))
-    (inst cas alloc alloc words)
-    (inst li ndescr (lognot vm:lowtag-mask))
-    (inst n alloc ndescr)
-    (move ndescr type)
-    (inst sr ndescr vm:word-shift)
-    (storew ndescr vector 0 vm:other-pointer-type)
-    (storew length vector vm:vector-length-slot vm:other-pointer-type)
-    (store-symbol-value alloc *allocation-pointer*))
-  (load-symbol-value ndescr *internal-gc-trigger*)
-  (inst tlt ndescr alloc)
-  (move result vector))
-
-
-
-;;;; Hash primitives
-
-(defparameter sxhash-simple-substring-entry (gen-label))
-
-(define-assembly-routine (sxhash-simple-string
-			  (:translate %sxhash-simple-string)
-			  (:policy :fast-safe)
-			  (:result-types positive-fixnum))
-			 ((:arg string descriptor-reg a0-offset)
-			  (:res result any-reg a0-offset)
-			  (:temp length any-reg a1-offset)
-			  (:temp accum non-descriptor-reg nl0-offset)
-			  (:temp data non-descriptor-reg nargs-offset)
-			  (:temp temp non-descriptor-reg ocfp-offset))
-  (declare (ignore result accum data temp))
-  (inst bx sxhash-simple-substring-entry)
-  (loadw length string vm:vector-length-slot vm:other-pointer-type))
-
-
-(define-assembly-routine (sxhash-simple-substring
-			  (:translate %sxhash-simple-substring)
-			  (:policy :fast-safe)
-			  (:arg-types * positive-fixnum)
-			  (:result-types positive-fixnum))
-			 ((:arg string descriptor-reg a0-offset)
-			  (:arg length any-reg a1-offset)
-			  (:res result any-reg a0-offset)
-			  (:temp accum non-descriptor-reg nl0-offset)
-			  (:temp data non-descriptor-reg nargs-offset)
-			  (:temp temp non-descriptor-reg ocfp-offset)
-			  (:temp lip interior-reg lip-offset))
-  (emit-label sxhash-simple-substring-entry)
-  ;; Get a stack slot to save the return-pc.
-  (inst inc csp-tn word-bytes)
-  ;; Save the return-pc as a byte offset from the component start, shifted
-  ;; left to look like a fixnum.
-  (inst s lip code-tn)
-  (inst sl lip 2)
-  (storew lip csp-tn (* -1 word-bytes))
-  ;; Compute start of string as interior pointer.
-  (inst a lip string (- (* vector-data-offset word-bytes) other-pointer-type))
-  (inst bx test)
-  (inst li accum 0)
-  LOOP
-  (inst x accum data)
-  (move temp accum)
-  (inst sl temp 27)
-  (inst sr accum 5)
-  (inst o accum temp)
-  (inst inc lip 4)
-  TEST
-  (inst s length (fixnum 4))
-  (inst bncx :lt loop)
-  (loadw data lip)
-  (inst a length (fixnum 4))
-  (inst bc :eq done)
-  (inst neg length)
-  (inst sl length 1)
-  (inst nilz length #x1f)
-  (inst sr data length)
-  (inst x accum data)
-  DONE
-  ;; Give it fixnum low-tag bits.
-  (inst sl accum 3)
-  (move result accum)
-  ;; Make it positive.
-  (inst sr result 1)
-
-  (loadw lip csp-tn (* -1 word-bytes))
-  (inst dec csp-tn word-bytes)
-  (inst sr lip 2)
-  (inst cas lip lip code-tn))
diff --git a/assembly/rt/assem-rtns.lisp b/assembly/rt/assem-rtns.lisp
deleted file mode 100644
index 5b06012e337a4ac7c075041785b8f089ea6beda7..0000000000000000000000000000000000000000
--- a/assembly/rt/assem-rtns.lisp
+++ /dev/null
@@ -1,319 +0,0 @@
-;;; -*- Package: RT; 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/assembly/rt/assem-rtns.lisp,v 1.5 1991/10/26 05:48:13 wlott Exp $
-;;;
-
-(in-package "RT")
-
-
-
-;;;; Non-local exit noise.
-
-(define-assembly-routine (unwind (:translate %continue-unwind)
-				 (:return-style :none)
-				 (:policy :fast-safe))
-			 ((:arg block (word-pointer-reg any-reg descriptor-reg)
-				a0-offset)
-			  (:arg start (word-pointer-reg any-reg descriptor-reg)
-				ocfp-offset)
-			  (:arg count (any-reg descriptor-reg) nargs-offset)
-			  (:temp lip interior-reg lip-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp cur-uwp any-reg nl0-offset)
-			  (:temp next-uwp any-reg cname-offset)
-			  (:temp target-uwp any-reg lexenv-offset))
-  (declare (ignore start count))
-
-  (let ((error (generate-error-code nil invalid-unwind-error)))
-    (inst c block 0)
-    (inst bc :eq error))
-
-  (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
-  (loadw target-uwp block unwind-block-current-uwp-slot)
-  (inst c cur-uwp target-uwp)
-  (inst bnc :eq do-uwp)
-
-  (move cur-uwp block)
-
-  DO-EXIT
-
-  (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
-  (loadw code-tn cur-uwp unwind-block-current-code-slot)
-  (loadw lra cur-uwp unwind-block-entry-pc-slot)
-  (lisp-return lra lip :frob-code nil)
-
-  DO-UWP
-
-  (loadw next-uwp cur-uwp unwind-block-current-uwp-slot)
-  (inst bx do-exit)
-  (store-symbol-value next-uwp lisp::*current-unwind-protect-block*))
-
-(define-assembly-routine (throw
-			  (:return-style :none))
-			 ((:arg target descriptor-reg a0-offset)
-			  (:arg start word-pointer-reg ocfp-offset)
-			  (:arg count any-reg nargs-offset)
-			  (:temp catch any-reg a1-offset)
-			  (:temp tag descriptor-reg a2-offset)
-			  (:temp ndescr non-descriptor-reg nl0-offset))
-  
-  ;; These are needed by UNWIND, but not by us directly.
-  (declare (ignore start count))
-
-  (load-symbol-value catch lisp::*current-catch-block*)
-  
-  LOOP
-
-  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
-    (inst c catch 0)
-    (inst bc :eq error))
-
-  (loadw tag catch catch-block-tag-slot)
-  (inst c tag target)
-  (inst bc :eq exit)
-  (loadw catch catch catch-block-previous-catch-slot)
-  (inst b loop)
-
-  EXIT
-
-  (move target catch)
-  (inst cai ndescr (make-fixup 'unwind :assembly-routine))
-  (inst b ndescr))
-
-
-
-;;;; Return unknown multiple values (known not to be one value).
-
-(define-assembly-routine really-return-multiple
-			 ((:arg ocfp any-reg nl0-offset)
-			  (:arg lra descriptor-reg lra-offset)
-			  ;; Pointer into cstack, so looks like fixnum.
-			  (:arg src any-reg cname-offset)
-			  (:arg nvals any-reg nargs-offset)
-
-			  (:temp lip interior-reg lip-offset)
-			  (:temp count any-reg ocfp-offset)
-			  ;; Pointer into cstack, so looks like fixnum.
-			  (:temp dst any-reg lexenv-offset)
-			  (:temp temp any-reg nfp-offset)
-			  (:temp a0 descriptor-reg a0-offset)
-			  (:temp a1 descriptor-reg a1-offset)
-			  (:temp a2 descriptor-reg a2-offset))
-  ;;
-  ;; Load the register args, bailing out when we are done.
-  (inst c nvals 0)
-  (inst bc :eq default-a0-and-on)
-  (loadw a0 src 0)
-  (inst c nvals (fixnum 1))
-  (inst bc :eq default-a1-and-on)
-  (loadw a1 src 1)
-  (inst c nvals (fixnum 2))
-  (inst bc :eq default-a2-and-on)
-  (loadw a2 src 2)
-  ;;
-  ;; Copy the remaining args to the top of the stack.
-  (inst inc src (* word-bytes register-arg-count))
-  (inst cal dst cfp-tn (* word-bytes register-arg-count))
-  (inst s count nvals (fixnum 3))
-  (inst bnc :gt done)
-  LOOP
-  (loadw temp src)
-  (inst inc src word-bytes)
-  (storew temp dst)
-  (inst inc dst word-bytes)
-  (inst s count (fixnum 1))
-  (inst bc :gt loop)
-  (inst b done)
-  ;;
-  ;; Default some number of registers.
-  DEFAULT-A0-AND-ON
-  (move a0 null-tn)
-  DEFAULT-A1-AND-ON
-  (move a1 null-tn)
-  DEFAULT-A2-AND-ON
-  (move a2 null-tn)
-  ;;
-  ;; Clear the stack.
-  DONE
-  (move count cfp-tn) ;Put pointer to the start of values in ocfp.
-  (inst cas csp-tn nvals count) ;Adjust the stack top: <ptr-to-vals>+<nvals>.
-  (move cfp-tn ocfp) ;Restore returnee's fp.
-  ;;
-  ;; Return.
-  (lisp-return lra lip))
-
-
-
-;;;; Copying more args on call (known to be at least one more arg.)
-
-;;; REALLY-COPY-MORE-ARGS -- Assembler Routine.
-;;;
-;;; This miscop has weird register usage conventions, since it is called at the
-;;; very beginning of entry to a more-arg XEP.  All of the registers used
-;;; by the full call convention are in use, and must not be trashed, but none
-;;; of the normal local & temporary registers are in use, since we haven't done
-;;; anything yet.  The number of fixed arguments is passed in a3, since we
-;;; can't trash a0..a2.
-;;;
-;;; The VOP COPY-MORE-ARG has allocated some temporaries for us: a3, l0, l1.
-
-;;; The registers we can use are NL1, A3, L0 and L1.  We save L2 and L3 to give
-;;; us some more registers to work with.  The caller saves the function return
-;;; PC in L2 (the now unused NAME) so that it can be used for the miscop return
-;;; PC.
-;;;
-;;; What we do is fairly simple: we copy the incoming more arguments (index >=
-;;; a3) onto the top of the stack.  The loop runs backwards, since we are
-;;; copying args upward on the stack, and the source and destination can
-;;; overlap.
-;;;
-;;; This loop terminates when we either run out of more args to copy or we run
-;;; out of stack arguments.  If we run out of stack arguments before we finish,
-;;; then there are register more args.  In this case, we dispatch off of the
-;;; number of fixed arguments (A3) to determine how many argument registers to
-;;; store.
-;;;
-(define-assembly-routine really-copy-more-args
-			 ;; Fixedargs contains the number of fixed arguments.
-			 ((:arg fixedargs any-reg cname-offset)
-			  (:temp count/src any-reg nfp-offset)
-			  (:temp ocsp any-reg nl0-offset)
-			  ;; Temporaries to get my hands on argument registers.
-			  (:temp a0 any-reg a0-offset)
-			  (:temp a1 any-reg a1-offset)
-			  (:temp a2 any-reg a2-offset)
-			  ;; We save the contents of these registers before
-			  ;; using them.
-			  (:temp srcstart any-reg lexenv-offset)
-			  (:temp dstend any-reg lra-offset)
-			  (:temp temp any-reg ocfp-offset))
-  ;; First, save count/src (the NFP) on the number stack.  We need to do this
-  ;; instead of with the other saves, because we need to use this register to
-  ;; figure out where to save the others.  We can't same them all there,
-  ;; because some of the others hold descriptor values.
-  (storew count/src nsp-tn -1)
-  ;; How many more args are there to copy to the stack?
-  (move count/src nargs-tn)
-  (inst s count/src fixedargs)
-  ;; Save the current stack top as the start of the more args.
-  (move ocsp csp-tn)
-  ;; Bump the stack by the number of more args.
-  (inst cas csp-tn csp-tn count/src)
-  ;; Bump the stack three for the registers we have to save.
-  (inst cal csp-tn csp-tn (* 3 word-bytes))
-
-  ;; Dump the registers to make room for the temporaries we need.
-  (storew srcstart csp-tn -3)
-  (storew dstend csp-tn -2)
-  (storew temp csp-tn -1)
-
-  ;; Compute the source start, but remember we are copying from the end.
-  ;; The start location is the last one we copy.
-  (inst cal srcstart cfp-tn (* register-arg-count word-bytes))
-  ;; Compute the source location of the last more arg.
-  (inst cas count/src nargs-tn cfp-tn)
-  (inst dec count/src word-bytes) ;not an exclusive end.
-  ;; Compute destination end, which is the stack pointer minus three register
-  ;; slots we saved and minus one to make it an inclusive end.
-  (inst cal dstend csp-tn (* -4 word-bytes))
-
-  ;; Copy some args.
-  (inst b cma-test)
-  CMA-LOOP
-  (loadw temp count/src)
-  (storew temp dstend)
-  (inst dec count/src word-bytes)
-  (inst dec dstend word-bytes)
-  CMA-TEST
-  ;; Are we totally done?
-  (inst c dstend ocsp)
-  (inst bc :lt CMA-DONE)
-  ;; Are we done copying stack more args?
-  (inst c count/src srcstart)
-  (inst bnc :lt CMA-LOOP)
-  
-  ;; Figure out which argument registers may be more args.
-  (inst c fixedargs (fixnum 2))
-  (inst bc :eq two-fixed-args)
-  (inst c fixedargs (fixnum 1))
-  (inst bc :eq one-fixed-arg)
-  
-  ;; Copy register more args being careful to stop before running out of args.
-  (storew a0 ocsp)
-  (inst c nargs-tn (fixnum 1))
-  (inst bc :eq CMA-DONE)
-  (inst inc ocsp word-bytes)
-  ONE-FIXED-ARG
-  (storew a1 ocsp)
-  (inst c nargs-tn (fixnum 2))
-  (inst bc :eq CMA-DONE)
-  (inst inc ocsp word-bytes)
-  TWO-FIXED-ARGS
-  (storew a2 ocsp)
-
-  ;; Restore registers we dumped.
-  CMA-DONE
-  (loadw srcstart csp-tn -3)
-  (loadw dstend csp-tn -2)
-  (loadw temp csp-tn -1)
-  (inst dec csp-tn (* 3 word-bytes))
-  (loadw count/src nsp-tn -1)
-  (inst b lip-tn))
-
-
-
-;;;; Tail call variable.
-
-(define-assembly-routine (really-tail-call-variable (:return-style :none))
-			 ;; These are really args.
-			 ((:temp args any-reg nl0-offset)
-			  ;; These are needed by the blitting code.
-			  (:temp count any-reg lra-offset)
-			  (:temp dst any-reg lexenv-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp temp descriptor-reg cname-offset)
-			  ;; These are needed so we can get at the register args.
-			  (:temp a0 descriptor-reg a0-offset)
-			  (:temp a1 descriptor-reg a1-offset)
-			  (:temp a2 descriptor-reg a2-offset))
-  ;; Calculate NARGS (as a fixnum).
-  (move nargs csp-tn)
-  (inst s nargs args)
-  ;; Load the argument registers now because the argument moving might trash
-  ;; these locations.
-  (loadw a0 args 0)
-  (loadw a1 args 1)
-  (loadw a2 args 2)
-  ;; Are we done?
-  (inst c nargs (fixnum register-arg-count))
-  (inst bnc :gt done)
-  ;; Calc DST and COUNT after saving those registers.
-  (inst inc csp-tn (* word-bytes 2))
-  (storew count csp-tn -1)
-  (storew dst csp-tn -2)
-  (inst a count nargs (fixnum (- register-arg-count)))
-  (inst a args (* vm:word-bytes register-arg-count))
-  (inst a dst cfp-tn (* vm:word-bytes register-arg-count))
-  LOOP
-  ;; Copy one arg.
-  (loadw temp args)
-  (inst inc args vm:word-bytes)
-  (storew temp dst)
-  (inst s count (fixnum 1))
-  (inst bcx :gt loop)
-  (inst inc dst vm:word-bytes)
-  ;; Restore
-  (loadw count csp-tn -1)
-  (loadw dst csp-tn -2)
-  (inst dec csp-tn (* word-bytes 2))
-  DONE
-  ;; We are done.  Do the jump.
-  (loadw temp dst vm:closure-function-slot vm:function-pointer-type)
-  (lisp-jump temp lip-tn))
diff --git a/assembly/rt/support.lisp b/assembly/rt/support.lisp
deleted file mode 100644
index 1cc9de630b54baa2acd0da091ded880bc0a6219c..0000000000000000000000000000000000000000
--- a/assembly/rt/support.lisp
+++ /dev/null
@@ -1,65 +0,0 @@
-;;; -*- Package: RT -*-
-;;;
-;;; **********************************************************************
-;;; 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/assembly/rt/support.lisp,v 1.2 1991/04/22 10:13:28 chiles Exp $
-;;;
-;;; This file contains the machine specific support routines needed by
-;;; the file assembler.
-;;;
-
-(in-package "RT")
-
-(def-vm-support-routine generate-call-sequence (name style vop)
-  (ecase style
-    (:raw
-     (values
-      `((inst bala (make-fixup ',name :assembly-routine)))
-      nil))
-    (:full-call
-     (let ((nfp-save (make-symbol "NFP-SAVE"))
-	   (lra (make-symbol "LRA")))
-       (values
-	`((let ((lra-label (gen-label))
-		(cur-nfp (current-nfp-tn ,vop)))
-	    (when cur-nfp
-	      (store-stack-tn cur-nfp ,nfp-save))
-	    (inst compute-lra-from-code ,lra code-tn lra-label)
-	    ;; This absolute branch trashes the LIP register, but we don't use
-	    ;; it when calling assembly routines.
-	    (inst bala (make-fixup ',name :assembly-routine))
-	    (emit-return-pc lra-label)
-	    (note-this-location ,vop :unknown-return)
-	    ;; Don't use MOVE.  Use a known 32-bit long instruction, so the
-	    ;; returner can know how many bytes we used here in the
-	    ;; multiple-value return case.  The returner wants to add a known
-	    ;; quantity to LRA indicating how many values it returned.
-	    (inst cal csp-tn ocfp-tn 0)
-	    (inst compute-code-from-lra code-tn code-tn lra-label)
-	    (when cur-nfp
-	      (load-stack-tn cur-nfp ,nfp-save))))
-	`((:temporary (:sc descriptor-reg :offset lra-offset
-			   :from (:eval 0) :to (:eval 1))
-		      ,lra)
-	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
-		      ,nfp-save)))))
-    (:none
-     (values
-      ;; This absolute branch trashes the LIP register, but we don't use it
-      ;; when calling assembly routines.
-      `((inst bala (make-fixup ',name :assembly-routine)))
-      nil))))
-
-
-(def-vm-support-routine generate-return-sequence (style)
-  (ecase style
-    (:raw
-     `((inst b lip-tn)))
-    (:full-call
-     `((lisp-return lra-tn lip-tn :offset 1)))
-    (:none)))
diff --git a/assembly/sparc/alloc.lisp b/assembly/sparc/alloc.lisp
deleted file mode 100644
index 7f461e625863c0df4ff8832c8496e387b09a00e5..0000000000000000000000000000000000000000
--- a/assembly/sparc/alloc.lisp
+++ /dev/null
@@ -1,21 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/alloc.lisp,v 1.4 1992/12/13 15:24:14 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Stuff to handle allocating simple objects.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "SPARC")
-
-;;; But we do everything inline now that we have a better pseudo-atomic.
diff --git a/assembly/sparc/arith.lisp b/assembly/sparc/arith.lisp
deleted file mode 100644
index 205e4f439b8139c5b087e8f2b5605f3878dccac3..0000000000000000000000000000000000000000
--- a/assembly/sparc/arith.lisp
+++ /dev/null
@@ -1,512 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/arith.lisp,v 1.11 1992/12/17 09:45:50 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Stuff to handle simple cases for generic arithmetic.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "SPARC")
-
-
-
-;;;; Addition and subtraction.
-
-(define-assembly-routine (generic-+
-			  (:cost 10)
-			  (:return-style :full-call)
-			  (:translate +)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg any-reg) a0-offset)
-
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp temp2 non-descriptor-reg nl1-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  (inst andcc zero-tn x 3)
-  (inst b :ne DO-STATIC-FUN)
-  (inst andcc zero-tn y 3)
-  (inst b :ne DO-STATIC-FUN)
-  (inst nop)
-  (inst addcc temp x y)
-  (inst b :vc done)
-  (inst nop)
-
-  (inst sra temp x 2)
-  (inst sra temp2 y 2)
-  (inst add temp2 temp)
-  (with-fixed-allocation (res temp bignum-type (1+ bignum-digits-offset))
-    (storew temp2 res bignum-digits-offset other-pointer-type))
-  (lisp-return lra :offset 2)
-
-  DO-STATIC-FUN
-  (inst ld code-tn null-tn (static-function-offset 'two-arg-+))
-  (inst li nargs (fixnum 2))
-  (inst move ocfp cfp-tn)
-  (inst j code-tn
-	(- (* function-code-offset word-bytes) function-pointer-type))
-  (inst move cfp-tn csp-tn)
-
-  DONE
-  (move res temp))
-
-
-(define-assembly-routine (generic--
-			  (:cost 10)
-			  (:return-style :full-call)
-			  (:translate -)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg any-reg) a0-offset)
-
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp temp2 non-descriptor-reg nl1-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  (inst andcc zero-tn x 3)
-  (inst b :ne DO-STATIC-FUN)
-  (inst andcc zero-tn y 3)
-  (inst b :ne DO-STATIC-FUN)
-  (inst nop)
-  (inst subcc temp x y)
-  (inst b :vc done)
-  (inst nop)
-
-  (inst sra temp x 2)
-  (inst sra temp2 y 2)
-  (inst sub temp2 temp temp2)
-  (with-fixed-allocation (res temp bignum-type (1+ bignum-digits-offset))
-    (storew temp2 res bignum-digits-offset other-pointer-type))
-  (lisp-return lra :offset 2)
-
-  DO-STATIC-FUN
-  (inst ld code-tn null-tn (static-function-offset 'two-arg--))
-  (inst li nargs (fixnum 2))
-  (inst move ocfp cfp-tn)
-  (inst j code-tn
-	(- (* function-code-offset word-bytes) function-pointer-type))
-  (inst move cfp-tn csp-tn)
-
-  DONE
-  (move res temp))
-
-
-
-;;;; Multiplication
-
-
-(define-assembly-routine (generic-*
-			  (:cost 50)
-			  (:return-style :full-call)
-			  (:translate *)
-			  (:policy :safe)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res (descriptor-reg any-reg) a0-offset)
-
-			  (:temp temp non-descriptor-reg nl0-offset)
-			  (:temp lo non-descriptor-reg nl1-offset)
-			  (:temp hi non-descriptor-reg nl2-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  ;; If either arg is not a fixnum, call the static function.
-  (inst andcc zero-tn x 3)
-  (inst b :ne DO-STATIC-FUN)
-  (inst andcc zero-tn y 3)
-  (inst b :ne DO-STATIC-FUN)
-  (inst nop)
-
-  ;; Remove the tag from one arg so that the result will have the correct
-  ;; fixnum tag.
-  (inst sra temp x 2)
-  (inst wry temp)
-  (inst andcc hi zero-tn)
-  (inst nop)
-  (inst nop)
-  (dotimes (i 32)
-    (inst mulscc hi y))
-  (inst mulscc hi zero-tn)
-  (inst cmp x)
-  (inst b :ge MULTIPLIER-POSITIVE)
-  (inst nop)
-  (inst sub hi y)
-  MULTIPLIER-POSITIVE
-  (inst rdy lo)
-
-  ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
-  ;; is just 32 copies of the sign bit of the low word).
-  (inst sra temp lo 31)
-  (inst xorcc temp hi)
-  (inst b :eq LOW-FITS-IN-FIXNUM)
-  ;; Shift the double word hi:lo down two bits to get rid of the fixnum tag.
-  (inst sll temp hi 30)
-  (inst srl lo 2)
-  (inst or lo temp)
-  (inst sra hi 2)
-  ;; Allocate a BIGNUM for the result.
-  (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
-    (let ((one-word (gen-label)))
-      (inst or res alloc-tn other-pointer-type)
-      ;; We start out assuming that we need one word.  Is that correct?
-      (inst sra temp lo 31)
-      (inst xorcc temp hi)
-      (inst b :eq one-word)
-      (inst li temp (logior (ash 1 type-bits) bignum-type))
-      ;; Nope, we need two, so allocate the addition space.
-      (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
-			    (pad-data-block (1+ bignum-digits-offset))))
-      (inst li temp (logior (ash 2 type-bits) bignum-type))
-      (storew hi res (1+ bignum-digits-offset) other-pointer-type)
-      (emit-label one-word)
-      (storew temp res 0 other-pointer-type)
-      (storew lo res bignum-digits-offset other-pointer-type)))
-  ;; Out of here
-  (lisp-return lra :offset 2)
-
-  DO-STATIC-FUN
-  (inst ld code-tn null-tn (static-function-offset 'two-arg-*))
-  (inst li nargs (fixnum 2))
-  (inst move ocfp cfp-tn)
-  (inst j code-tn
-	(- (* function-code-offset word-bytes) function-pointer-type))
-  (inst move cfp-tn csp-tn)
-
-  LOW-FITS-IN-FIXNUM
-  (move res lo))
-
-(macrolet
-    ((frob (name note cost type sc)
-       `(define-assembly-routine (,name
-				  (:note ,note)
-				  (:cost ,cost)
-				  (:translate *)
-				  (:policy :fast-safe)
-				  (:arg-types ,type ,type)
-				  (:result-types ,type))
-				 ((:arg x ,sc nl0-offset)
-				  (:arg y ,sc nl1-offset)
-				  (:res res ,sc nl0-offset)
-				  (:temp temp ,sc nl2-offset))
-	  ,@(when (eq type 'tagged-num)
-	      `((inst sra x 2)))
-	  (inst wry x)
-	  (inst andcc temp zero-tn)
-	  (inst nop)
-	  (inst nop)
-	  (dotimes (i 32)
-	    (inst mulscc temp y))
-	  (inst mulscc temp zero-tn)
-	  (inst rdy res))))
-  (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
-  (frob signed-* "unsigned *" 41 signed-num signed-reg)
-  (frob fixnum-* "fixnum *" 30 tagged-num any-reg))
-
-
-
-;;;; Division.
-
-#+assembler
-(defun emit-divide-loop (divisor rem quo tagged)
-  (inst li quo 0)
-  (labels
-      ((do-loop (depth)
-	 (cond
-	  ((zerop depth)
-	   (inst unimp 0))
-	  (t
-	   (let ((label-1 (gen-label))
-		 (label-2 (gen-label)))
-	     (inst cmp divisor rem)
-	     (inst b :geu label-1)
-	     (inst nop)
-	     (inst sll divisor 1)
-	     (do-loop (1- depth))
-	     (inst srl divisor 1)
-	     (inst cmp divisor rem)
-	     (emit-label label-1)
-	     (inst b :gtu label-2)
-	     (inst sll quo 1)
-	     (inst add quo (if tagged (fixnum 1) 1))
-	     (inst sub rem divisor)
-	     (emit-label label-2))))))
-    (do-loop (if tagged 30 32))))
-
-(define-assembly-routine (positive-fixnum-truncate
-			  (:note "unsigned fixnum truncate")
-			  (:cost 45)
-			  (:translate truncate)
-			  (:policy :fast-safe)
-			  (:arg-types positive-fixnum positive-fixnum)
-			  (:result-types positive-fixnum positive-fixnum))
-			 ((:arg dividend any-reg nl0-offset)
-			  (:arg divisor any-reg nl1-offset)
-
-			  (:res quo any-reg nl2-offset)
-			  (:res rem any-reg nl0-offset))
-
-  (move rem dividend)
-  (emit-divide-loop divisor rem quo t))
-
-
-(define-assembly-routine (fixnum-truncate
-			  (:note "fixnum truncate")
-			  (:cost 50)
-			  (:policy :fast-safe)
-			  (:translate truncate)
-			  (:arg-types tagged-num tagged-num)
-			  (:result-types tagged-num tagged-num))
-			 ((:arg dividend any-reg nl0-offset)
-			  (:arg divisor any-reg nl1-offset)
-
-			  (:res quo any-reg nl2-offset)
-			  (:res rem any-reg nl0-offset)
-
-			  (:temp quo-sign any-reg nl5-offset)
-			  (:temp rem-sign any-reg nargs-offset))
-  
-  (inst xor quo-sign dividend divisor)
-  (inst move rem-sign dividend)
-  (let ((label (gen-label)))
-    (inst cmp dividend)
-    (inst ba :lt label)
-    (inst neg dividend)
-    (emit-label label))
-  (let ((label (gen-label)))
-    (inst cmp divisor)
-    (inst ba :lt label)
-    (inst neg divisor)
-    (emit-label label))
-  (move rem dividend)
-  (emit-divide-loop divisor rem quo t)
-  (let ((label (gen-label)))
-    ;; If the quo-sign is negative, we need to negate quo.
-    (inst cmp quo-sign)
-    (inst ba :lt label)
-    (inst neg quo)
-    (emit-label label))
-  (let ((label (gen-label)))
-    ;; If the rem-sign is negative, we need to negate rem.
-    (inst cmp rem-sign)
-    (inst ba :lt label)
-    (inst neg rem)
-    (emit-label label)))
-
-
-(define-assembly-routine (signed-truncate
-			  (:note "(signed-byte 32) truncate")
-			  (:cost 60)
-			  (:policy :fast-safe)
-			  (:translate truncate)
-			  (:arg-types signed-num signed-num)
-			  (:result-types signed-num signed-num))
-
-			 ((:arg dividend signed-reg nl0-offset)
-			  (:arg divisor signed-reg nl1-offset)
-
-			  (:res quo signed-reg nl2-offset)
-			  (:res rem signed-reg nl0-offset)
-
-			  (:temp quo-sign signed-reg nl5-offset)
-			  (:temp rem-sign signed-reg nargs-offset))
-  
-  (inst xor quo-sign dividend divisor)
-  (inst move rem-sign dividend)
-  (let ((label (gen-label)))
-    (inst cmp dividend)
-    (inst ba :lt label)
-    (inst neg dividend)
-    (emit-label label))
-  (let ((label (gen-label)))
-    (inst cmp divisor)
-    (inst ba :lt label)
-    (inst neg divisor)
-    (emit-label label))
-  (move rem dividend)
-  (emit-divide-loop divisor rem quo nil)
-  (let ((label (gen-label)))
-    ;; If the quo-sign is negative, we need to negate quo.
-    (inst cmp quo-sign)
-    (inst ba :lt label)
-    (inst neg quo)
-    (emit-label label))
-  (let ((label (gen-label)))
-    ;; If the rem-sign is negative, we need to negate rem.
-    (inst cmp rem-sign)
-    (inst ba :lt label)
-    (inst neg rem)
-    (emit-label label)))
-
-
-;;;; Comparison
-
-(macrolet
-    ((define-cond-assem-rtn (name translate static-fn cmp)
-       `(define-assembly-routine (,name
-				  (:cost 10)
-				  (:return-style :full-call)
-				  (:policy :safe)
-				  (:translate ,translate)
-				  (:save-p t))
-				 ((:arg x (descriptor-reg any-reg) a0-offset)
-				  (:arg y (descriptor-reg any-reg) a1-offset)
-				  
-				  (:res res descriptor-reg a0-offset)
-				  
-				  (:temp nargs any-reg nargs-offset)
-				  (:temp ocfp any-reg ocfp-offset))
-	  (inst andcc zero-tn x 3)
-	  (inst b :ne DO-STATIC-FN)
-	  (inst andcc zero-tn y 3)
-	  (inst b :eq DO-COMPARE)
-	  (inst cmp x y)
-	  
-	  DO-STATIC-FN
-	  (inst ld code-tn null-tn (static-function-offset ',static-fn))
-	  (inst li nargs (fixnum 2))
-	  (inst move ocfp cfp-tn)
-	  (inst j code-tn
-		(- (* function-code-offset word-bytes) function-pointer-type))
-	  (inst move cfp-tn csp-tn)
-	  
-	  DO-COMPARE
-	  (inst b ,cmp done)
-	  (load-symbol res t)
-	  (inst move res null-tn)
-	  DONE)))
-
-  (define-cond-assem-rtn generic-< < two-arg-< :lt)
-  (define-cond-assem-rtn generic-<= <= two-arg-<= :le)
-  (define-cond-assem-rtn generic-> > two-arg-> :gt)
-  (define-cond-assem-rtn generic->= >= two-arg->= :ge))
-
-
-(define-assembly-routine (generic-eql
-			  (:cost 10)
-			  (:return-style :full-call)
-			  (:policy :safe)
-			  (:translate eql)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-			  
-			  (:res res descriptor-reg a0-offset)
-
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  (inst cmp x y)
-  (inst b :eq RETURN-T)
-  (inst andcc zero-tn x 3)
-  (inst b :eq RETURN-NIL)
-  (inst andcc zero-tn y 3)
-  (inst b :ne DO-STATIC-FN)
-  (inst nop)
-
-  RETURN-NIL
-  (inst move res null-tn)
-  (lisp-return lra :offset 2)
-
-  DO-STATIC-FN
-  (inst ld code-tn null-tn (static-function-offset 'eql))
-  (inst li nargs (fixnum 2))
-  (inst move ocfp cfp-tn)
-  (inst j code-tn
-	(- (* function-code-offset word-bytes) function-pointer-type))
-  (inst move cfp-tn csp-tn)
-
-  RETURN-T
-  (load-symbol res t))
-
-(define-assembly-routine (generic-=
-			  (:cost 10)
-			  (:return-style :full-call)
-			  (:policy :safe)
-			  (:translate =)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res descriptor-reg a0-offset)
-
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  (inst cmp x y)
-  (inst b :eq RETURN-T)
-  (inst andcc zero-tn x 3)
-  (inst b :ne DO-STATIC-FN)
-  (inst andcc zero-tn y 3)
-  (inst b :ne DO-STATIC-FN)
-  (inst nop)
-
-  (inst move res null-tn)
-  (lisp-return lra :offset 2)
-
-  DO-STATIC-FN
-  (inst ld code-tn null-tn (static-function-offset 'two-arg-=))
-  (inst li nargs (fixnum 2))
-  (inst move ocfp cfp-tn)
-  (inst j code-tn
-	(- (* function-code-offset word-bytes) function-pointer-type))
-  (inst move cfp-tn csp-tn)
-
-  RETURN-T
-  (load-symbol res t))
-
-(define-assembly-routine (generic-/=
-			  (:cost 10)
-			  (:return-style :full-call)
-			  (:policy :safe)
-			  (:translate /=)
-			  (:save-p t))
-			 ((:arg x (descriptor-reg any-reg) a0-offset)
-			  (:arg y (descriptor-reg any-reg) a1-offset)
-
-			  (:res res descriptor-reg a0-offset)
-
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp nargs any-reg nargs-offset)
-			  (:temp ocfp any-reg ocfp-offset))
-  (inst cmp x y)
-  (inst b :eq RETURN-NIL)
-  (inst andcc zero-tn x 3)
-  (inst b :ne DO-STATIC-FN)
-  (inst andcc zero-tn y 3)
-  (inst b :ne DO-STATIC-FN)
-  (inst nop)
-
-  (load-symbol res t)
-  (lisp-return lra :offset 2)
-
-  DO-STATIC-FN
-  (inst ld code-tn null-tn (static-function-offset 'two-arg-=))
-  (inst li nargs (fixnum 2))
-  (inst move ocfp cfp-tn)
-  (inst j code-tn
-	(- (* function-code-offset word-bytes) function-pointer-type))
-  (inst move cfp-tn csp-tn)
-
-  RETURN-NIL
-  (inst move res null-tn))
diff --git a/assembly/sparc/array.lisp b/assembly/sparc/array.lisp
deleted file mode 100644
index 69a0513b2d321ca184e683d4213321e928dba3ce..0000000000000000000000000000000000000000
--- a/assembly/sparc/array.lisp
+++ /dev/null
@@ -1,111 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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/assembly/sparc/array.lisp,v 1.3 1992/03/11 21:41:02 wlott Exp $
-;;;
-;;;    This file contains the support routines for arrays and vectors.
-;;;
-;;; Written by William Lott.
-;;; 
-(in-package "SPARC")
-
-
-(define-assembly-routine (allocate-vector
-			  (:policy :fast-safe)
-			  (:translate allocate-vector)
-			  (:arg-types positive-fixnum
-				      positive-fixnum
-				      positive-fixnum))
-			 ((:arg type any-reg a0-offset)
-			  (:arg length any-reg a1-offset)
-			  (:arg words any-reg a2-offset)
-			  (:res result descriptor-reg a0-offset)
-
-			  (:temp ndescr non-descriptor-reg nl0-offset)
-			  (:temp vector descriptor-reg a3-offset))
-  (pseudo-atomic ()
-    (inst or vector alloc-tn vm:other-pointer-type)
-    (inst add ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes))
-    (inst andn ndescr 7)
-    (inst add alloc-tn ndescr)
-    (inst srl ndescr type vm:word-shift)
-    (storew ndescr vector 0 vm:other-pointer-type)
-    (storew length vector vm:vector-length-slot vm:other-pointer-type))
-  (move result vector))
-
-
-
-;;;; Hash primitives
-
-#+assembler
-(defparameter sxhash-simple-substring-entry (gen-label))
-
-(define-assembly-routine (sxhash-simple-string
-			  (:translate %sxhash-simple-string)
-			  (:policy :fast-safe)
-			  (:result-types positive-fixnum))
-			 ((:arg string descriptor-reg a0-offset)
-			  (:res result any-reg a0-offset)
-
-			  (:temp length any-reg a1-offset)
-			  (:temp accum non-descriptor-reg nl0-offset)
-			  (:temp data non-descriptor-reg nl1-offset)
-			  (:temp temp non-descriptor-reg nl2-offset)
-			  (:temp offset non-descriptor-reg nl3-offset))
-
-  (declare (ignore result accum data temp offset))
-
-  (inst b sxhash-simple-substring-entry)
-  (loadw length string vm:vector-length-slot vm:other-pointer-type))
-
-
-(define-assembly-routine (sxhash-simple-substring
-			  (:translate %sxhash-simple-substring)
-			  (:policy :fast-safe)
-			  (:arg-types * positive-fixnum)
-			  (:result-types positive-fixnum))
-			 ((:arg string descriptor-reg a0-offset)
-			  (:arg length any-reg a1-offset)
-			  (:res result any-reg a0-offset)
-
-			  (:temp accum non-descriptor-reg nl0-offset)
-			  (:temp data non-descriptor-reg nl1-offset)
-			  (:temp temp non-descriptor-reg nl2-offset)
-			  (:temp offset non-descriptor-reg nl3-offset))
-  (emit-label sxhash-simple-substring-entry)
-
-  (inst li offset (- (* vector-data-offset word-bytes) other-pointer-type))
-  (inst b test)
-  (move accum zero-tn)
-
-  LOOP
-
-  (inst xor accum data)
-  (inst sll temp accum 27)
-  (inst srl accum 5)
-  (inst or accum temp)
-  (inst add offset 4)
-
-  TEST
-
-  (inst subcc length (fixnum 4))
-  (inst b :ge loop)
-  (inst ld data string offset)
-
-  (inst addcc length (fixnum 4))
-  (inst b :eq done)
-  (inst neg length)
-  (inst sll length 1)
-  (inst srl data length)
-  (inst xor accum data)
-
-  DONE
-
-  (inst sll result accum 5)
-  (inst srl result result 3))
diff --git a/assembly/sparc/assem-rtns.lisp b/assembly/sparc/assem-rtns.lisp
deleted file mode 100644
index 32b1afd2697a2a4d28d1bd9f3d682ebdb7076e5a..0000000000000000000000000000000000000000
--- a/assembly/sparc/assem-rtns.lisp
+++ /dev/null
@@ -1,242 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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/assembly/sparc/assem-rtns.lisp,v 1.1 1990/11/22 11:51:05 wlott Exp $
-;;;
-;;;
-(in-package "SPARC")
-
-
-;;;; Return-multiple with other than one value
-
-#+assembler ;; we don't want a vop for this one.
-(define-assembly-routine
-    (return-multiple
-     (:return-style :none))
-
-     ;; These four are really arguments.
-    ((:temp nvals any-reg nargs-offset)
-     (:temp vals any-reg nl0-offset)
-     (:temp ocfp any-reg nl1-offset)
-     (:temp lra descriptor-reg lra-offset)
-
-     ;; These are just needed to facilitate the transfer
-     (:temp count any-reg nl2-offset)
-     (:temp src any-reg nl3-offset)
-     (:temp dst any-reg nl4-offset)
-     (:temp temp descriptor-reg l0-offset)
-
-     ;; These are needed so we can get at the register args.
-     (:temp a0 descriptor-reg a0-offset)
-     (:temp a1 descriptor-reg a1-offset)
-     (:temp a2 descriptor-reg a2-offset)
-     (:temp a3 descriptor-reg a3-offset)
-     (:temp a4 descriptor-reg a4-offset)
-     (:temp a5 descriptor-reg a5-offset))
-
-  ;; Note, because of the way the return-multiple vop is written, we can
-  ;; assume that we are never called with nvals == 1 and that a0 has already
-  ;; been loaded.
-  (inst cmp nvals)
-  (inst b :le default-a0-and-on)
-  (inst cmp nvals (fixnum 2))
-  (inst b :le default-a2-and-on)
-  (inst ld a1 vals (* 1 vm:word-bytes))
-  (inst cmp nvals (fixnum 3))
-  (inst b :le default-a3-and-on)
-  (inst ld a2 vals (* 2 vm:word-bytes))
-  (inst cmp nvals (fixnum 4))
-  (inst b :le default-a4-and-on)
-  (inst ld a3 vals (* 3 vm:word-bytes))
-  (inst cmp nvals (fixnum 5))
-  (inst b :le default-a5-and-on)
-  (inst ld a4 vals (* 4 vm:word-bytes))
-  (inst cmp nvals (fixnum 6))
-  (inst b :le done)
-  (inst ld a5 vals (* 5 vm:word-bytes))
-
-  ;; Copy the remaining args to the top of the stack.
-  (inst add src vals (* 6 vm:word-bytes))
-  (inst add dst cfp-tn (* 6 vm:word-bytes))
-  (inst subcc count nvals (fixnum 6))
-
-  LOOP
-  (inst ld temp src)
-  (inst add src vm:word-bytes)
-  (inst st temp dst)
-  (inst add dst vm:word-bytes)
-  (inst b :gt loop)
-  (inst subcc count (fixnum 1))
-		
-  (inst b done)
-  (inst nop)
-
-  DEFAULT-A0-AND-ON
-  (inst move a0 null-tn)
-  (inst move a1 null-tn)
-  DEFAULT-A2-AND-ON
-  (inst move a2 null-tn)
-  DEFAULT-A3-AND-ON
-  (inst move a3 null-tn)
-  DEFAULT-A4-AND-ON
-  (inst move a4 null-tn)
-  DEFAULT-A5-AND-ON
-  (inst move a5 null-tn)
-  DONE
-  
-  ;; Clear the stack.
-  (move ocfp-tn cfp-tn)
-  (move cfp-tn ocfp)
-  (inst add csp-tn ocfp-tn nvals)
-  
-  ;; Return.
-  (lisp-return lra))
-
-
-
-;;;; tail-call-variable.
-
-#+assembler ;; no vop for this one either.
-(define-assembly-routine
-    (tail-call-variable
-     (:return-style :none))
-
-    ;; These are really args.
-    ((:temp args any-reg nl0-offset)
-     (:temp lexenv descriptor-reg lexenv-offset)
-
-     ;; We need to compute this
-     (:temp nargs any-reg nargs-offset)
-
-     ;; These are needed by the blitting code.
-     (:temp src any-reg nl1-offset)
-     (:temp dst any-reg nl2-offset)
-     (:temp count any-reg nl3-offset)
-     (:temp temp descriptor-reg l0-offset)
-
-     ;; These are needed so we can get at the register args.
-     (:temp a0 descriptor-reg a0-offset)
-     (:temp a1 descriptor-reg a1-offset)
-     (:temp a2 descriptor-reg a2-offset)
-     (:temp a3 descriptor-reg a3-offset)
-     (:temp a4 descriptor-reg a4-offset)
-     (:temp a5 descriptor-reg a5-offset))
-
-
-  ;; Calculate NARGS (as a fixnum)
-  (inst sub nargs csp-tn args)
-     
-  ;; Load the argument regs (must do this now, 'cause the blt might
-  ;; trash these locations)
-  (inst ld a0 args (* 0 vm:word-bytes))
-  (inst ld a1 args (* 1 vm:word-bytes))
-  (inst ld a2 args (* 2 vm:word-bytes))
-  (inst ld a3 args (* 3 vm:word-bytes))
-  (inst ld a4 args (* 4 vm:word-bytes))
-  (inst ld a5 args (* 5 vm:word-bytes))
-
-  ;; Calc SRC, DST, and COUNT
-  (inst addcc count nargs (fixnum (- register-arg-count)))
-  (inst b :le done)
-  (inst add src args (* vm:word-bytes register-arg-count))
-  (inst add dst cfp-tn (* vm:word-bytes register-arg-count))
-	
-  LOOP
-  ;; Copy one arg.
-  (inst ld temp src)
-  (inst add src src vm:word-bytes)
-  (inst st temp dst)
-  (inst addcc count (fixnum -1))
-  (inst b :gt loop)
-  (inst add dst dst vm:word-bytes)
-	
-  DONE
-  ;; We are done.  Do the jump.
-  (loadw temp lexenv vm:closure-function-slot vm:function-pointer-type)
-  (lisp-jump temp))
-
-
-
-;;;; Non-local exit noise.
-
-(define-assembly-routine (unwind
-			  (:return-style :none)
-			  (:translate %continue-unwind)
-			  (:policy :fast-safe))
-			 ((:arg block (any-reg descriptor-reg) a0-offset)
-			  (:arg start (any-reg descriptor-reg) ocfp-offset)
-			  (:arg count (any-reg descriptor-reg) nargs-offset)
-			  (:temp lra descriptor-reg lra-offset)
-			  (:temp cur-uwp any-reg nl0-offset)
-			  (:temp next-uwp any-reg nl1-offset)
-			  (:temp target-uwp any-reg nl2-offset))
-  (declare (ignore start count))
-
-  (let ((error (generate-error-code nil invalid-unwind-error)))
-    (inst cmp block)
-    (inst b :eq error))
-  
-  (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
-  (loadw target-uwp block vm:unwind-block-current-uwp-slot)
-  (inst cmp cur-uwp target-uwp)
-  (inst b :ne do-uwp)
-  (inst nop)
-      
-  (move cur-uwp block)
-
-  DO-EXIT
-      
-  (loadw cfp-tn cur-uwp vm:unwind-block-current-cont-slot)
-  (loadw code-tn cur-uwp vm:unwind-block-current-code-slot)
-  (loadw lra cur-uwp vm:unwind-block-entry-pc-slot)
-  (lisp-return lra :frob-code nil)
-
-  DO-UWP
-
-  (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot)
-  (inst b do-exit)
-  (store-symbol-value next-uwp lisp::*current-unwind-protect-block*))
-
-
-(define-assembly-routine (throw
-			  (:return-style :none))
-			 ((:arg target descriptor-reg a0-offset)
-			  (:arg start any-reg ocfp-offset)
-			  (:arg count any-reg nargs-offset)
-			  (:temp catch any-reg a1-offset)
-			  (:temp tag descriptor-reg a2-offset)
-			  (:temp temp non-descriptor-reg nl0-offset))
-  
-  (declare (ignore start count))
-
-  (load-symbol-value catch lisp::*current-catch-block*)
-  
-  loop
-  
-  (let ((error (generate-error-code nil unseen-throw-tag-error target)))
-    (inst cmp catch)
-    (inst b :eq error)
-    (inst nop))
-  
-  (loadw tag catch vm:catch-block-tag-slot)
-  (inst cmp tag target)
-  (inst b :eq exit)
-  (inst nop)
-  (loadw catch catch vm:catch-block-previous-catch-slot)
-  (inst b loop)
-  (inst nop)
-  
-  exit
-  
-  (move target catch)
-  (inst li temp (make-fixup 'unwind :assembly-routine))
-  (inst j temp)
-  (inst nop))
-
-
diff --git a/assembly/sparc/support.lisp b/assembly/sparc/support.lisp
deleted file mode 100644
index 372dfe55b0e62e78cae9ec63e1050afe701e0166..0000000000000000000000000000000000000000
--- a/assembly/sparc/support.lisp
+++ /dev/null
@@ -1,80 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/support.lisp,v 1.7 1992/07/31 21:55:12 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-(in-package "SPARC")
-
-(def-vm-support-routine generate-call-sequence (name style vop)
-  (ecase style
-    (:raw
-     (let ((temp (make-symbol "TEMP"))
-	   (lip (make-symbol "LIP")))
-       (values 
-	`((inst jali ,lip ,temp (make-fixup ',name :assembly-routine))
-	  (inst nop))
-	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
-		      ,temp)
-	  (:temporary (:scs (interior-reg) :from (:eval 0) :to (:eval 1))
-		      ,lip)))))
-    (:full-call
-     (let ((temp (make-symbol "TEMP"))
-	   (nfp-save (make-symbol "NFP-SAVE"))
-	   (lra (make-symbol "LRA")))
-       (values
-	`((let ((lra-label (gen-label))
-		(cur-nfp (current-nfp-tn ,vop)))
-	    (when cur-nfp
-	      (store-stack-tn ,nfp-save cur-nfp))
-	    (inst compute-lra-from-code ,lra code-tn lra-label ,temp)
-	    (note-next-instruction ,vop :call-site)
-	    (inst ji ,temp (make-fixup ',name :assembly-routine))
-	    (inst nop)
-	    (emit-return-pc lra-label)
-	    (note-this-location ,vop :single-value-return)
-	    (without-scheduling ()
-	      (move csp-tn ocfp-tn)
-	      (inst nop))
-	    (inst compute-code-from-lra code-tn code-tn
-		  lra-label ,temp)
-	    (when cur-nfp
-	      (load-stack-tn cur-nfp ,nfp-save))))
-	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
-		      ,temp)
-	  (:temporary (:sc descriptor-reg :offset lra-offset
-			   :from (:eval 0) :to (:eval 1))
-		      ,lra)
-	  (:temporary (:scs (control-stack) :offset nfp-save-offset)
-		      ,nfp-save)
-	  (:save-p :compute-only)))))
-    (:none
-     (let ((temp (make-symbol "TEMP")))
-       (values 
-	`((inst ji ,temp (make-fixup ',name :assembly-routine))
-	  (inst nop))
-	`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
-		      ,temp)))))))
-
-(def-vm-support-routine generate-return-sequence (style)
-  (ecase style
-    (:raw
-     `((inst j
-	     (make-random-tn :kind :normal
-			     :sc (sc-or-lose 'interior-reg *backend*)
-			     :offset lip-offset)
-	     8)
-       (inst nop)))
-    (:full-call
-     `((lisp-return (make-random-tn :kind :normal
-				    :sc (sc-or-lose 'descriptor-reg *backend*)
-				    :offset lra-offset)
-		    :offset 2)))
-    (:none)))
diff --git a/benchmarks/cascor1.lisp b/benchmarks/cascor1.lisp
deleted file mode 100644
index 02e38795512418a32bafd74547a4287274f6e294..0000000000000000000000000000000000000000
--- a/benchmarks/cascor1.lisp
+++ /dev/null
@@ -1,1470 +0,0 @@
-;;; -*- Mode: Lisp; Package: User -*-
-;;; ***************************************************************************
-;;; Common Lisp implementation of Cascade-Correlation learning algorithm.
-;;; This version for export.  Non-portable user-interface stuff excised.
-;;; 
-;;; Written by:   Scott E. Fahlman
-;;;               School of Computer Science
-;;;               Carnegie-Mellon University
-;;;               Pittsburgh, PA 15217
-;;;
-;;;               Phone: (412) 268-2575
-;;;               Internet: fahlman@cs.cmu.edu
-;;;
-;;; This code has been placed in the public domain by the author.  As a
-;;; matter of simple courtesy, anyone using or adapting this code is
-;;; expected to acknowledge the source.  The author would like to hear
-;;; about any attempts to use this system, successful or not.
-;;;
-;;; For an explanation of this algorithm and some results, see "The
-;;; Cascade-Correlation Learning Architecture" by Scott E. Fahlman and
-;;; Christian Lebiere in D. S. Touretzky (ed.), "Advances in Neural
-;;; Information Processing Systems 2", Morgan Kaufmann, 1990.  A somewhat
-;;; longer version is available as CMU Computer Science Tech Report
-;;; CMU-CS-90-100.
-;;;
-;;; ***************************************************************************
-;;; EDIT HISTORY SINCE FIRST RELEASE:
-;;;
-;;; 8/24/90:
-;;; Modified TEST-EPOCH so that it wouldn't mess up error statistics being
-;;; passed from the output-training to input-training phase.  Thanks to
-;;; Scott Crowder for spotting this.
-;;; 
-;;; 6/1/90:
-;;; Fixed bug in INSTALL-NEW-UNIT.  New unit's initial weight was being
-;;; computed using *CAND-COR* values of the successful candidate, which is
-;;; already zero.  Now uses *CAND-PREV-COR*.  Thanks to Tim Howells for
-;;; spotting this.
-;;;
-;;; Modify BUILD-NET to check that *MAX-UNITS* is large enough.  A couple of
-;;; people got mysterious failures the first time they used lots of inputs.
-;;;
-;;; Made a small change in QUICKPROP-UPDATE to prevent rare divide-by-zero
-;;; errors when p = s = 0.0.  Thanks to Tom Dietterich.
-;;; 
-;;; Added CHANGED-TRAINING-SET, which should be called when the training set
-;;; is changed but you don't want to reinitialize the net.  This rebuilds
-;;; the caches.
-;;; 
-;;; 11/9/90:
-;;; Added some additional type declarations for maximum speed under certain
-;;; Common Lisp compilers.
-;;; ***************************************************************************
-;;;
-(in-package "USER")
-
-;;; This proclamation buys a certain amount of overall speed at the expense
-;;; of runtime checking.  Comment it out when debugging new, bug-infested code.
-;;;
-#+declare-unsafe
-(proclaim '(optimize (speed 3) (space 0) (safety 0)))
-
-;;; Style note: Because some of these runs take a long time, this code is
-;;; extensively hacked for good performance under a couple of Common Lisp
-;;; systems, some of which have poor performance on multi-dimensional
-;;; arrays and some of which have weak type-inference in the compiler.
-;;; Elegance and clarity have in some cases been sacrificed for speed.
-
-;;; In some problems, floating point underflow errors may occur as a result
-;;; of weight-decay and other operations.  Most Common Lisp implementations
-;;; have an option to turn floating underflows into zero values without
-;;; signalling an error.  You should enable this facility if it is
-;;; available.  If not, you'll either have to write a condition handler for
-;;; floating underflows or live with the occasional underflow error.
-
-;;; In CMU Common Lisp, we use the following incantation:
-;;;     (setq extensions:*ignore-floating-point-underflow* t)
-
-
-;;; Compensate for the clumsy Common Lisp declaration system and weak
-;;; type-inference in some Common Lisp compilers.
-
-;;; INCF-SF, *SF, etc. are like INCF, *, etc., but they declare their
-;;; operands and results to be short-floats.  The code gets unreadable
-;;; quickly if you insert all these declarations by hand.
-
-(defmacro incf-sf (place &optional (increment 1.0))
-  `(the short-float (incf (the short-float ,place)
-			  (the short-float ,increment))))
-
-(defmacro decf-sf (place &optional (increment 1.0))
-  `(the short-float (decf (the short-float ,place)
-			  (the short-float ,increment))))
-
-(defmacro *sf (&rest args)
-  `(the short-float
-	(* ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args))))
-
-(defmacro +sf (&rest args)
-  `(the short-float
-	(+ ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args))))
-
-(defmacro -sf (&rest args)
-  `(the short-float
-	(- ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args))))
-
-(defmacro /sf (&rest args)
-  `(the short-float
-	(/ ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args))))
-
-;;; DOTIMES1 is like DOTIMES, only with the loop counter declared as a
-;;; fixnum.  This is for compilers with weak type inference.
-
-(defmacro dotimes1 (form1 &body body)
-  `(dotimes ,form1 (declare (fixnum ,(car form1))) . ,body))
-
-;;; Create vector-access forms similar to SVREF, but for vectors of
-;;; element-type SHORT-FLOAT and FIXNUM.
-
-(eval-when (compile load eval)
-  (defconstant fvector-type
-    (array-element-type (make-array '(1) :element-type 'short-float)))
-  (defconstant ivector-type
-    (array-element-type (make-array '(1) :element-type 'fixnum))))
-
-(defmacro fvref (a i)
-  "Like SVREF, but with vectors of element-type SHORT-FLOAT."
-  (if (eq fvector-type t)
-    `(the short-float (svref ,a ,i))
-    `(the short-float
-	  (aref (the (simple-array ,fvector-type (*)) ,a) ,i))))
-
-(defmacro ivref (a i)
-  "Like SVREF, but with vectors of element-type FIXNUM."
-  (if (eq ivector-type t)
-    `(the fixnum (svref ,a ,i))
-    `(the fixnum
-	  (aref (the (simple-array ,ivector-type (*)) ,a) ,i))))
-
-
-;;;; Assorted Parameters and Controls.
-
-;;; Thse parameters and switches control the quickprop learning algorithm
-;;; used to train the output weights and candidate units.
-
-(defvar *unit-type* :sigmoid
-  "The type of activation function used by the hidden units.  Options
-  currently implemented are :sigmoid, :asigmoid, and :gaussian.  Sigmoid is
-  symmetric in range -0.5 to +0.5, while Asigmoid is asymmetric, 0.0 to
-  1.0.")
-
-(defvar *output-type* :sigmoid
-  "The activation function to use on the output units.  Options currently
-  implemented are :linear and :sigmoid.")
-
-(defvar *raw-error* nil
-  "If T, candidate units will try to correlate with the raw difference
-  between actual and desired outputs.  Else, they use the difference modified
-  by the derivative of the output unit activation function.")
-
-(defvar *sigmoid-prime-offset* 0.1
-  "This is added to the derivative of the sigmoid function to prevent the
-  system from getting stuck at the points where sigmoid-prime goes to
-  zero.")
-(proclaim '(short-float *sigmoid-prime-offset*))
-
-(defvar *weight-range* 1.0
-  "Input weights in the network get inital random values between plus and
-  minus *weight-range*.  This parameter also controls the initial weights
-  on direct input-to-output links.")
-(proclaim '(short-float *weight-range*))
-
-(defvar *weight-multiplier* 1.0
-  "The output weights for cadidate units get an initial value that is the
-  negative of the correlation times this factor.")
-(proclaim '(short-float *weight-multiplier*))
-
-(defvar *output-mu* 2.0
-  "Mu parmater used for quickprop training of output weights.  The
-  step size is limited to mu times the previous step.")
-(proclaim '(short-float *output-mu*))
-
-(defvar *output-shrink-factor* (/ *output-mu* (+ 1.0 *output-mu*))
-  "Derived from *output-mu*.  Used in computing whether the proposed step is
-  too large.")
-(proclaim '(short-float *output-shrink-factor*))
-
-(defvar *output-epsilon* 0.35
-  "Controls the amount of linear gradient descent to use in updating
-  output weights.")
-(proclaim '(short-float *output-epsilon*))
-
-(defvar *output-decay* 0.0001
-  "This factor times the current weight is added to the slope at the
-  start of each output-training epoch.  Keeps weights from growing too big.")
-(proclaim '(short-float *output-decay*))
-
-(defvar *output-patience* 8
-  "If we go for this many epochs with no significant change, it's time to
-  stop tuning.  If 0, go on forever.")
-(proclaim '(fixnum *output-patience*))
-
-(defvar *output-change-threshold* 0.01
-  "The error must change by at least this fraction of its old value in
-  order to count as a significant change.")
-(proclaim '(short-float *output-change-threshold*))
-
-(defvar *input-mu* 2.0
-  "Mu parmater used for quickprop training of input weights.  The
-  step size is limited to mu times the previous step.")
-(proclaim '(short-float *input-mu*))
-
-(defvar *input-shrink-factor* (/ *input-mu* (+ 1.0 *input-mu*))
-  "Derived from *input-mu*.  Used in computing whether the proposed step is
-  too large.")
-(proclaim '(short-float *input-shrink-factor*))
-
-(defvar *input-epsilon* 1.0
-  "Controls the amount of linear gradient descent to use in updating
-  unit input weights.")
-(proclaim '(short-float *input-epsilon*))
-
-(defvar *input-decay* 0.0
-  "This factor times the current weight is added to the slope at the
-  start of each output-training epoch.  Keeps weights from growing too big.")
-(proclaim '(short-float *input-decay*))
-
-(defvar *input-patience* 8
-  "If we go for this many epochs with no significant change, it's time to
-  stop tuning.  If 0, go on forever.")
-(proclaim '(fixnum *input-patience*))
-
-(defvar *input-change-threshold* 0.03
-  "The correlation score for the best unit must change by at least
-  this fraction of its old value in order to count as a significant
-  change.")
-(proclaim '(short-float *input-change-threshold*))
-
-;;; Variables related to error and correlation.
-
-(defvar *score-threshold* 0.4
-  "An output is counted as correct for a given case if the difference
-  between that output and the desired value is smaller in magnitude than
-  this value.")
-(proclaim '(short-float *score-threshold*))
-
-(defvar *error-bits* 0
-  "Count number of bits in epoch that are wrong by more than
-  *SCORE-THRESHOLD*")
-(proclaim '(fixnum *error-bits*))
-
-(defvar *true-error* 0.0
-  "The sum-squared error at the network outputs.  This is the value the
-  algorithm is ultimately trying to minimize.")
-(proclaim '(short-float *true-error*))
-
-(defvar *sum-error* 0.0
-  "Accumulate the sum of the error values after output training phase.")
-(proclaim '(short-float *sum-error*))
-
-(defvar *sum-sq-error* 0.0
-  "Accumulate the sum of the squared error values after output
-  training phase.")
-(proclaim '(short-float *sum-sq-error*))
-
-(defvar *avg-error* 0.0
-  "Holds the average of error values after output training phase.")
-(proclaim '(short-float *avg-error*))
-
-(defvar *best-candidate-score* 0.0
-  "The best correlation score found among all candidate units being
-  trained.")
-(proclaim '(short-float *best-candidate-score*))
-
-(defvar *best-candidate* 0
-  "The index of the candidate unit whose correlation score is best
-  at present.")
-(proclaim '(fixnum *best-candidate*))
-
-;;; These variables and switches control the simulation and display.
-
-(defvar *use-cache* t
-  "If T, cache the forward-pass values instead of repeatedly
-  computing them.  This can save a *lot* of time if all the cached values
-  fit into memory.")
-
-(defparameter *epoch* 0
-  "Count of the number of times the entire training set has been presented.")
-(proclaim '(fixnum *epoch*))
-
-(defvar *test* nil
-  "If T, run a test epoch every so often during output training.")
-
-(defvar *test-interval* 0
-  "Run a test epoch every *test-interval* output training cycles.")
-(proclaim '(fixnum *test-interval*))
-
-(defvar *single-pass* nil
-  "When on, pause after next forward/backward cycle.")
-
-(defvar *single-epoch* nil
-  "When on, pause after next training epoch.")
-
-(defparameter *step* nil
-  "Turned briefly to T in order to continue after a pause.")
-
-;;; The sets of training inputs and outputs are stored in parallel vectors.
-;;; Each element is a SIMPLE-VECTOR holding short-float values, one for
-;;; each input or output.  Note: this is a simple vector, not a specialized
-;;; vector of element-type short-float.
-
-(defvar *training-inputs* (make-array 0)
-  "Vector of input patterns for training the net.")
-(proclaim '(simple-vector *training-inputs*))
-
-(defvar *training-outputs* (make-array 0)
-  "Vector of output patterns for training the net.")
-(proclaim '(simple-vector *training-outputs*))
-
-(defvar *goal* (make-array 0)
-  "The goal vector for the current training or testing case.")
-(proclaim '(simple-vector *goal*))
-
-(defvar *max-cases* 0
-  "Maximum number of training cases that can be accommdated by the current
-  data structures.")
-(proclaim '(fixnum *max-cases*))
-
-(defvar *ncases* 0
-  "Number of training cases currently in use.  Assume a contiguous block
-  beginning with *FIRST-CASE*.")
-(proclaim '(fixnum *ncases*))
-
-(defvar *first-case* 0
-  "Address of the first training case in the currently active set.  Usually
-  zero, but may differ if we are training on different chunks of the training
-  set at different times.")
-(proclaim '(fixnum *first-case*))
-
-;;; For some benchmarks there is a separate set of values used for testing
-;;; the network's ability to generalize.  These values are not used during
-;;; training.
-
-(defvar *test-inputs* '#()
-  "Vector of input patterns for testing the net.")
-(proclaim '(simple-vector *test-inputs*))
-
-(defvar *test-outputs* '#()
-  "Vector of output patterns for testing the net.")
-(proclaim '(simple-vector *test-outputs*))
-
-
-;;;; Fundamental data structures.
-
-;;; Unit values and weights are short flonums.
-
-;;; Instead of representing each unit by a structure, we represent the
-;;; unit by a fixnum.  This is used to index into various vectors that hold
-;;; per-unit information, such as the activation value of each unit.
-;;; So the information concerning a given unit is found in a slice of values
-;;; across many vectors, all with the same unit-index.
-
-;;; Per-connection information for each connection COMING INTO unit is
-;;; stored in a vector of vectors.  The outer vector is indexed by the unit
-;;; number, and the inner vector is then indexed by connection number.
-;;; This is a sleazy way of implementing a 2-D array, faster in most Lisp
-;;; systems than multiplying to do the index arithmetic, and more efficient
-;;; if the units are sparsely connected.
-
-;;; Unit 0, the "bias unit" is always at a maximum-on value.  Next come
-;;; some input "units", then some hidden units.
-
-;;; Output units have their own separate set of data structures and
-;;; indices.  The units and outputs together form the "active" network.
-;;; There are also separate data structures and indices for the "candidate"
-;;; units that have not yet been added to the network.
-
-(defvar *max-units* 30
-  "Maximum number of input values and hidden units in the network.")
-(proclaim '(fixnum *max-units*))
-
-(defvar *ninputs* 0
-  "Number of inputs for this problem.")
-(proclaim '(fixnum *ninputs*))
-
-(defvar *noutputs* 0
-  "Number of outputs for this problem.")
-(proclaim '(fixnum *noutputs*))
-
-(defvar *nunits* 0
-  "Current number of active units in the network.  This count includes all
-  inputs to the network and the bias unit.")
-(proclaim '(fixnum *nunits*))
-
-(defvar *ncandidates* 8
-  "Number of candidate units whose inputs will be trained at once.")
-(proclaim '(fixnum *ncandidates*))
-
-;;; The following vectors hold values related to hidden units in the active
-;;; net and their input weights.  The vectors are created by BUILD-NET, after
-;;; the dimension variables have been set up.
-
-(defvar *values* nil
-  "Vector holding the current activation value for each unit and input in
-  the active net.")
-
-(defvar *values-cache* nil
-  "Holds a distinct *VALUES* vector for each of the *MAX-CASES* training
-  cases.  Once we have computed the *VALUES* vector for each training case,
-  we can use it repeatedly until the weights or training cases change.")
-
-(defvar *extra-values* nil
-  "Extra values vector to use when not using the cache.")
-
-;;; Note: the *NCONNECTIONS* and *CONNECTIONS* vectors could be eliminated
-;;; if we wanted to commit to total connectivity for all units.
-;;; For now, we want to allow for sparse or irregular connectivity.
-
-(defvar *nconnections* nil
-  "Vector holding the number of incoming connections for each unit.")
-
-(defvar *connections* nil
-  "Vector that holds a connection vector for each unit J.
-  Each entry in the connection vector holds a unit index I,
-  indicating that this connection is from I to J.")
-
-(defvar *weights* nil
-  "Vector of vectors with structure parallel to the *connections* vector.
-  Each entry gives the weight associated with an incoming connection.")
-
-;;; The following vectors hold values for the outputs of the active
-;;; network and the output-side weights.
-
-(defvar *outputs* nil
-  "Vector holding the network output values.")
-
-(defvar *errors* nil
-  "Vector holding the current error value for each output.")
-
-(defvar *errors-cache* nil
-  "Holds a distinct *ERRORS* vector for each of the *MAX-CASES* training
-  cases.  Once we have computed the *ERRORS* vector for a given training
-  case, we can use it repeatedly until the weights of the training cases
-  change.")
-
-(defvar *extra-errors* nil
-  "Extra errors vector to use when not using the cache.")
-
-(defvar *output-weights* nil
-  "Vector of vectors.  For each output, we have a vector of output weights
-  coming from the unit indicated by the index.")
-
-(defvar *output-deltas* nil
-  "Vector of vectors, parallel with output weights.  Each entry is the
-  amount by which the corresponding output weight was changed last time.")
-
-(defvar *output-slopes* nil
-  "Vector of vectors, parallel with output weights.  Each entry is the
-  partial derivative of the total error with repsect to the corresponding
-  weight.")
-
-(defvar *output-prev-slopes* nil
-  "Vector of vectors, parallel with output weights.  Each entry is the
-  previous value of the corresponding *OUTPUT-SLOPES* entry.")
-
-(defvar *output-weights-record* nil
-  "The vector of output weights is recorded here after each output-training
-  phase and just prior to the addition of the next unit.  This record
-  allows us to reconstruct the network's performance at each of these
-  points in time.")
-
-;;; The following vectors have one entry for each candidate unit in the
-;;; pool of trainees.
-
-(defvar *cand-sum-values* nil
-  "For each candidate unit, the sum of its values over an entire
-  training set.")
-
-(defvar *cand-cor* nil
-  "A vector with one entry for each candidate unit.  This entry is a vector
-  that holds the correlation between this unit's value and the residual
-  error at each of the outputs, computed over a whole epoch.")
-
-(defvar *cand-prev-cor* nil
-  "Holds the *cand-cor* values computed in the previous candidate training
-  epoch.")
-
-(defvar *cand-weights* nil
-  "A vector with one entry for each candidate unit.  This entry is a vector
-  that holds the current input weights for that candidate unit.")
-
-(defvar *cand-deltas* nil
-  "A vector with one entry for each candidate unit.  This entry is a vector
-  that holds the input weights deltas for that candidate unit.")
-
-(defvar *cand-slopes* nil
-  "A vector with one entry for each candidate unit.  This entry is a vector
-  that holds the input weights slopes for that candidate unit.")
-
-(defvar *cand-prev-slopes* nil
-  "A vector with one entry for each candidate unit.  This entry is a vector
-  that holds the previous values of the input weight slopes for that
-  candidate unit.")
-
-;;; At present, each candidate receives a connection from every input and
-;;; pre-existing unit.  Rather than cons up a new *connections* vector for
-;;; each of these, we can just use this one for all of them.
-
-(defvar *all-connections* nil
-  "A *CONNECTIONS* vector that can be used by any unit that connects to
-  all lower-numbered units, in order.")
-
-
-;;;; Network-building utilities.
-
-(defun build-net (ninputs noutputs)
-  "Create the network data structures, given the number of input and output
-  connections.  Get *MAX-UNITS* and other dimesntions from variables."
-  (declare (fixnum ninputs noutputs))
-  ;; Check to make sure *MAX-UNITS* is big enough.
-  (unless (> *max-units* (+ ninputs 1))
-    (error "*MAX-UNITS* must be greater than number of inputs plus 1."))
-  ;; Fill in assorted variables and create top-level vectors.
-  (setq *ninputs* ninputs
-	*noutputs* noutputs
-	*max-cases* (length *training-inputs*)
-	*ncases* *max-cases*
-	*first-case* 0
-	*nunits* (+ 1 *ninputs*)
-	*values-cache* (make-array *max-cases* :initial-element nil)
-	*extra-values* (make-array *max-units*
-				   :element-type 'short-float
-				   :initial-element 0.0)
-	*values* *extra-values*
-	*nconnections* (make-array *max-units*
-				   :element-type 'fixnum
-				   :initial-element 0)
-	*connections* (make-array *max-units* :initial-element nil)
-	*weights* (make-array *max-units* :initial-element nil)
-	*outputs* (make-array *noutputs*
-			      :element-type 'short-float
-			      :initial-element 0.0)
-	*errors-cache* (make-array *max-cases* :initial-element nil)
-	*extra-errors* 	(make-array *noutputs*
-				    :element-type 'short-float
-				    :initial-element 0.0)
-	*errors* *extra-errors*
-	*output-weights* (make-array *noutputs* :initial-element nil)
-	*output-weights-record* (make-array *max-units* :initial-element nil)
-	*output-deltas* (make-array *noutputs* :initial-element nil)
-	*output-slopes* (make-array *noutputs* :initial-element nil)
-	*output-prev-slopes* (make-array *noutputs* :initial-element nil)
-	*cand-sum-values* (make-array *ncandidates*
-				      :element-type 'short-float
-				      :initial-element 0.0)
-	*cand-cor* (make-array *ncandidates* :initial-element nil)
-	*cand-prev-cor* (make-array *ncandidates* :initial-element nil)
-	*cand-weights* (make-array *ncandidates* :initial-element nil)
-	*cand-deltas* (make-array *ncandidates* :initial-element nil)
-	*cand-slopes* (make-array *ncandidates* :initial-element nil)
-	*cand-prev-slopes* (make-array *ncandidates* :initial-element nil))
-  ;; Only create the caches if *USE-CACHE* is on -- may not always have room.
-  (when *use-cache*
-    (dotimes1 (i *max-cases*)
-      (setf (svref *values-cache* i)
-	    (make-array *max-units*
-			:element-type 'short-float
-			:initial-element 0.0))
-      (setf (svref *errors-cache* i)
-	    (make-array *noutputs*
-			:element-type 'short-float
-			:initial-element 0.0))))
-  ;; For each output, create the vectors holding per-weight information.
-  (dotimes1 (i *noutputs*)
-    (setf (svref *output-weights* i)
-	  (make-array *max-units*
-		      :element-type 'short-float
-		      :initial-element 0.0))
-    (setf (svref *output-deltas* i)    
-	  (make-array *max-units*
-		      :element-type 'short-float
-		      :initial-element 0.0))
-    (setf (svref *output-slopes* i)
-	  (make-array *max-units*
-		      :element-type 'short-float
-		      :initial-element 0.0))
-    (setf (svref *output-prev-slopes* i)
-	  (make-array *max-units*
-		      :element-type 'short-float
-		      :initial-element 0.0)))
-  ;; For each candidate unit, create the vectors holding the correlations,
-  ;; incoming weights, and other stats.
-  (dotimes1 (i *ncandidates*)
-    (setf (svref *cand-cor* i)
-	  (make-array *noutputs*
-		      :element-type 'short-float
-		      :initial-element 0.0))
-    (setf (svref *cand-prev-cor* i)
-	  (make-array *noutputs*
-		      :element-type 'short-float
-		      :initial-element 0.0))
-    (setf (svref *cand-weights* i)
-	  (make-array *max-units*
-		      :element-type 'short-float
-		      :initial-element 0.0))
-    (setf (svref *cand-deltas* i)
-	  (make-array *max-units*
-		      :element-type 'short-float
-		      :initial-element 0.0))
-    (setf (svref *cand-slopes* i)
-	  (make-array *max-units*
-		      :element-type 'short-float
-		      :initial-element 0.0))
-    (setf (svref *cand-prev-slopes* i)
-	  (make-array *max-units*
-		      :element-type 'short-float
-		      :initial-element 0.0))))
-
-(defun random-weight ()
-  "Select a random weight, uniformly distributed over the
-  interval from minus to plus *weight-range*."
-  (-sf (random (*sf 2.0 *weight-range*)) *weight-range*))
-
-(defun init-net ()
-  "Set up the network for a learning problem.  Clean up all the data
-  structures that may have become corrupted.  Initialize the output weights
-  to random values controlled by *weight-range*."
-  ;; Set up the *ALL-CONNECTIONS* vector.
-  (setq *all-connections*
-	(make-array *max-units* :element-type 'fixnum))
-  (dotimes1 (i *max-units*)
-    (setf (ivref *all-connections* i) i))
-  ;; Initialize the active unit data structures.
-  (dotimes1 (i *max-units*)
-    (setf (fvref *extra-values* i) 0.0)
-    (setf (ivref *nconnections* i) 0)
-    (setf (svref *connections* i) nil)
-    (setf (svref *weights* i) nil)
-    (setf (svref *output-weights-record* i) nil))
-  ;; Initialize the per-output data structures.
-  (dotimes1 (i *noutputs*)
-    (setf (fvref *outputs* i) 0.0)
-    (setf (fvref *extra-errors* i) 0.0)
-    (let ((ow (svref *output-weights* i))
-	  (od (svref *output-deltas* i))
-	  (os (svref *output-slopes* i))
-	  (op (svref *output-prev-slopes* i)))
-      (dotimes1 (j *max-units*)
-	(setf (fvref ow j) 0.0)
-	(setf (fvref od j) 0.0)
-	(setf (fvref os j) 0.0)
-	(setf (fvref op j) 0.0))
-      ;; Set up initial random weights for the input-to-output connections.
-      (dotimes1 (j (1+ *ninputs*))
-	(setf (fvref ow j) (random-weight)))))
-  ;; Initialize the caches if they are in use.
-  (when *use-cache*
-    (dotimes1 (j *max-cases*)
-      (let ((v (svref *values-cache* j))
-	    (e (svref *errors-cache* j)))
-	(dotimes1 (i *max-units*)
-	  (setf (fvref v i) 0.0))
-	(dotimes1 (i *noutputs*)
-	  (setf (fvref e i) 0.0)))))	
-  ;; Candidate units get initialized in a separate routine.
-  (init-candidates)
-  ;; Do some other assorted housekeeping.
-  (setf (fvref *extra-values* 0) 1.0)
-  (setq *epoch* 0)
-  (setq *nunits* (+ 1 *ninputs*))
-  (setq *error-bits* 0)
-  (setq *true-error* 0.0)
-  (setq *sum-error* 0.0)
-  (setq *sum-sq-error* 0.0)
-  (setq *best-candidate-score* 0.0)
-  (setq *best-candidate* 0))
-
-(defun changed-training-set ()
-  "Call this instead of BUILD-NET and INIT-NET if you want to leave
-  existing hidden units in place and start from here with new training
-  examples.  Assumes that the number of net inputs and outputs remains the
-  same, but the number of cases may have changed.  Rebuilds the caches."
-  (setq *max-cases* (length *training-inputs*)
-	*ncases* *max-cases*
-	*first-case* 0
-	*values-cache* (make-array *max-cases* :initial-element nil)
-	*errors-cache* (make-array *max-cases* :initial-element nil))
-  ;; Only create the caches if *USE-CACHE* is on -- may not always have room.
-  (when *use-cache*
-    (dotimes1 (i *max-cases*)
-      (setf (svref *errors-cache* i)
-	    (make-array *noutputs*
-			:element-type 'short-float
-			:initial-element 0.0))
-      (setq *values* (make-array *max-units*
-				 :element-type 'short-float
-				 :initial-element 0.0))
-      (setf (svref *values-cache* i) *values*)
-      (set-up-inputs (svref *training-inputs* i))
-      (do ((j (1+ *ninputs*) (1+ j)))
-	  ((= j *nunits*))
-	(declare (fixnum j))
-	(compute-unit-value j)))))
-
-;;;; Utilities for learning.
-
-(proclaim '(inline activation activation-prime))
-
-(defun activation (sum)
-  "Given the sum of weighted inputs, compute the unit's activation value.
-  Defined unit types are :sigmoid, :asigmoid, and :gaussian."
-  (declare (short-float sum))
-  (ecase *unit-type*
-    (:sigmoid
-     ;; Symmetric sigmoid function in range -0.5 to +0.5.
-     (cond ((< sum -15.0) -0.5)
-	   ((> sum 15.0) +0.5)
-	   (t (-sf (/sf (+sf 1.0 (exp (-sf sum)))) 0.5))))
-    (:asigmoid
-     ;; Asymmetric sigmoid in range 0.0 to 1.0.
-     (cond ((< sum -15.0) 0.0)
-	   ((> sum 15.0) 1.0)
-	   (t (/sf 1.0 (+sf 1.0 (exp (-sf sum)))))))
-    (:gaussian
-     ;; Gaussian activation function in range 0.0 to 1.0.
-     (let ((x (*sf -0.5 sum sum)))
-       (if (< x -75.0) 0.0 (exp x))))))
-
-;;; Note: do not use *SIGMOID-PRIME-OFFSET* here, as it confuses the
-;;; correlation machinery.  But do use it in output-prime, since it does no
-;;; harm there and the output units often get stuck at extreme values.
-
-(defun activation-prime (value sum)
-  "Given the unit's activation value and sum of weighted inputs, compute
-  the derivative of the activation with respect to the sum.  Defined unit
-  types are :sigmoid, :asigmoid, and :gaussian."
-  (declare (short-float value sum))
-  (ecase *unit-type*
-    (:sigmoid
-     (-sf 0.25 (*sf value value)))
-    (:asigmoid
-     (*sf value (-sf 1.0 value)))
-    (:gaussian
-     (*sf (-sf value) sum))))
-
-(proclaim '(inline output-function output-prime))
-
-(defun output-function (sum)
-  "Compute the value of an output, given the weighted sum of incoming values.
-  Defined output types are :sigmoid and :linear."
-  (declare (short-float sum))
-  (ecase *output-type*
-    (:sigmoid (cond ((< sum -15.0) -0.5)
-		    ((> sum 15.0) +0.5)
-		    (t (-sf (/sf 1.0 (+sf 1.0 (exp (-sf sum)))) 0.5))))
-    (:linear sum)))
-
-(defun output-prime (output)
-  "Compute the derivative of an output with respect to the weighted sum of
-  incoming values.  Defined output types are :sigmoid and :linear."
-  (declare (short-float output))
-  (ecase *output-type*
-    (:sigmoid 
-     (+sf *sigmoid-prime-offset* (-sf 0.25 (*sf output output))))
-    (:linear 1.0)))
-
-;;; The basic routine for doing Quickprop-style update of weights.
-;;; Distilled essence of a year's work...
-
-(proclaim '(inline quickprop-update))
-
-(defun quickprop-update (i weights deltas slopes prevs
-			   epsilon decay mu shrink-factor)
-  "Given vectors holding weights, deltas, slopes, and previous slopes,
-  and an index i, update weight(i) and delta(i) appropriately.  Move
-  slope(i) to prev(i) and zero out slope(i).  Add weight decay term to
-  each slope before doing the update."
-  (let* ((w (fvref weights i))
-	 (d (fvref deltas i))
-	 (s (+sf (fvref slopes i) (*sf decay w)))
-	 (p (fvref prevs i))
-	 (next-step 0.0))
-    (declare (short-float w p s d next-step)) 
-    ;; The step must always be downhill.
-    (cond
-     ;; If last step was negative...
-     ((minusp d)
-      ;; First, add in linear term if current slope is still positive.
-      (when (plusp s)
-	(decf-sf next-step (*sf epsilon s)))
-      (cond
-       ;; If current slope is close to or larger than prev slope...
-       ((>= s (*sf shrink-factor p))
-	;; Take maximum size negative step.
-	(incf-sf next-step (*sf mu d)))
-       ;; Else, use quadratic estimate.
-       (t (incf-sf next-step (*sf d (/sf s (-sf p s)))))))
-     ;; If last step was positive...
-     ((plusp d)
-      ;; First, add in linear term if current slope is still negative.
-      (when (minusp s)
-	(decf-sf next-step (*sf epsilon s)))
-      (cond
-       ;; If current slope is close to or more neg than prev slope...
-       ((<= s (*sf shrink-factor p))
-	;; Take maximum size positive step.
-	(incf-sf next-step (*sf mu d)))
-       ;; Else, use quadratic estimate.
-       (t (incf-sf next-step (*sf d (/sf s (-sf p s)))))))
-     ;; Last step was zero, so use only linear term.
-     (t (decf-sf next-step (*sf epsilon s))))
-    ;; Having computed the next step, update the data vectors.
-    (setf (fvref deltas i) next-step)
-    (setf (fvref weights i) (+sf w next-step))
-    (setf (fvref prevs i) s)
-    (setf (fvref slopes i) 0.0)
-    nil))
-
-
-;;;; Machinery for training output weights.
-
-(defun set-up-inputs (input)
-  "Set up all the inputs from the INPUT vector as the first few entries in
-  in the values vector."
-  (declare (simple-vector input))
-  (setf (fvref *values* 0) 1.0)
-  (dotimes1 (i *ninputs*)
-    (setf (fvref *values* (1+ i))
-	  (the short-float (svref input i)))))
-
-(defun output-forward-pass ()
-  "Assume the *VALUES* vector has been set up.  Just compute the network's
-  outputs."
-  (dotimes1 (j *noutputs*)
-    (let ((ow (svref *output-weights* j))
-	  (sum 0.0))
-      (declare (short-float sum))
-      (dotimes1 (i *nunits*)
-	(incf-sf sum (*sf (fvref *values* i) (fvref ow i))))
-      (setf (fvref *outputs* j)
-	    (output-function sum)))))
-
-(defun compute-unit-value (j)
-  "Assume that *VALUES* vector has been set up for all units with index less
-  than J.  Compute and record the value for unit J."
-  (declare (fixnum j))
-  (let* ((c (svref *connections* j))
-	 (w (svref *weights* j))
-	 (sum 0.0))
-    (declare (short-float sum))
-    (dotimes1 (i (ivref *nconnections* j))
-      (incf-sf sum (*sf (fvref *values* (ivref c i))
-			(fvref w i))))
-    (setf (fvref *values* j) (activation sum))
-    nil))
-
-(defun full-forward-pass (input)
-  "Set up the inputs from the INPUT vector, then propagate activation values
-  forward through all hidden units and output units."
-  (set-up-inputs input)
-  ;; For each hidden unit J, compute the activation value.
-  (do ((j (1+ *ninputs*) (1+ j)))
-      ((= j *nunits*))
-    (declare (fixnum j))
-    (compute-unit-value j))
-  ;; Now compute outputs.
-  (output-forward-pass))
-
-;;; Note: We fill the *ERRORS* vector and related statistics with either
-;;; the raw error or the error after modification by output-prime,
-;;; depending on the *RAW-ERROR* switch.  This controls what form of error
-;;; the candidate units try to correlate with.  All experiments reported in
-;;; TR CMU-CS-90-100 assume *RAW-ERROR* is NIL, but this might not always
-;;; be the best choice.
-
-(defun compute-errors (goal output-slopes-p stats-p)
-  "GOAL is a vector of desired values for the output units.  Compute and
-  record the output errors for the current training case.  If
-  OUTPUT-SLOPES-P is T, then use errors to compute slopes for output
-  weights.  If STATS-P is T, accumulate error statistics."
-  (declare (simple-vector goal))
-  (dotimes1 (j *noutputs*)
-    (let* ((out (fvref *outputs* j))
-	   (dif (-sf out (svref goal j)))
-	   (err-prime (*sf dif (output-prime out)))
-	   (os (svref *output-slopes* j)))
-      (declare (short-float dif err-prime))
-      (when stats-p
-	(unless (< (abs dif) *score-threshold*)
-	  (incf *error-bits*))
-	(incf-sf *true-error* (*sf dif dif)))
-      (cond (*raw-error*
-	     (setf (fvref *errors* j) dif)      
-	     (incf-sf *sum-error* dif)
-	     (incf-sf *sum-sq-error* (*sf dif dif)))
-	    (t
-	     (setf (fvref *errors* j) err-prime)      
-	     (incf-sf *sum-error* err-prime)
-	     (incf-sf *sum-sq-error* (*sf err-prime err-prime))))
-      (when output-slopes-p
-	(dotimes1 (i *nunits*)
-	  (incf-sf (fvref os i) (*sf err-prime (fvref *values* i))))))))
-
-;;; Note: Scaling *OUTPUT-EPSILON* by the number of cases seems to keep the
-;;; quickprop update in a good range across many different-sized training
-;;; sets, but it's something of a hack.  Choosing good epsilon values
-;;; still requires some trial and error.
-
-(defun update-output-weights ()
-  "Update the output weights, using the pre-computed slopes, prev-slopes,
-  and delta values.  Uses the quickprop update function."
-  (let ((eps (/ *output-epsilon* *ncases*)))
-    (dotimes1 (j *noutputs*)
-      (let ((ow (svref *output-weights* j))
-	    (od (svref *output-deltas* j))
-	    (os (svref *output-slopes* j))
-	    (op (svref *output-prev-slopes* j)))
-	(dotimes1 (i *nunits*)
-	  (quickprop-update i ow od os op eps *output-decay*
-			    *output-mu* *output-shrink-factor*))))))
-
-
-;;;; Outer loops for training output weights.
-
-(defun train-outputs-epoch ()
-  "Perform forward propagation once for each set of weights in the
-  training vectors, computing errors and slopes.  Then update the output
-  weights."
-  ;; Zero error accumulators.
-  (setq *error-bits* 0)
-  (setq *true-error* 0.0)
-  (setq *sum-error* 0.0)
-  (setq *sum-sq-error* 0.0)
-  ;; User may have changed mu between epochs, so fix shrink-factor.
-  (setq *output-shrink-factor*
-	(/sf *output-mu* (+sf 1.0 *output-mu*)))
-  ;; Now run through the training examples.
-  (do ((i *first-case* (1+ i)))
-      ((= i (the fixnum (+ *first-case* *ncases*))))
-    (declare (fixnum i))
-    (setq *goal* (svref *training-outputs* i))
-    (cond (*use-cache*
-	   (setq *values* (svref *values-cache* i))
-	   (setq *errors* (svref *errors-cache* i))
-	   (output-forward-pass))
-	  (t (setq *values* *extra-values*)
-	     (setq *errors* *extra-errors*)
-	     (full-forward-pass (svref *training-inputs* i))))
-    (compute-errors *goal* t t))
-  ;; Do not change weights or count epoch if this run was perfect.
-  (unless (= 0 *error-bits*)
-    (update-output-weights)
-    (incf *epoch*)))
-
-(defun record-output-weights ()
-  "Store the output weights developed after each output-training phase
-  in the *ouput-weights-record* vector."
-  (let ((record (make-array *noutputs* :initial-element nil)))
-    (dotimes1 (o *noutputs*)
-      (let ((original (svref *output-weights* o))
-	    (copy (make-array *nunits* :element-type 'short-float
-			      :initial-element 0.0)))
-	(dotimes1 (u *nunits*)
-	  (setf (fvref copy u) (fvref original u)))
-	(setf (svref record o) copy)))
-    (setf (svref *output-weights-record* (1- *nunits*)) record)))
-
-(defun train-outputs (max-epochs)
-  "Train the output weights.  If we exhaust MAX-EPOCHS, stop with value
-  :TIMEOUT.  If there are zero error bits, stop with value :WIN.  Else,
-  keep going until the true error has not changed by a significant amount
-  for *OUTPUT-PATIENCE* epochs.  Then return :STAGNANT.  If
-  *OUTPUT-PATIENCE* is zero, we do not stop until victory or until
-  MAX-EPOCHS is used up."
-  (declare (fixnum max-epochs))
-  (let ((last-error 0.0)
-	(quit-epoch (+ *epoch* *output-patience*))
-	(first-time t))
-    (declare (fixnum quit-epoch)
-	     (short-float last-error))
-    (dotimes1 (i max-epochs (progn
-			     (record-output-weights)
-			     :timeout))
-      ;; Maybe run a test epoch to see how we're doing.
-      (when (and *test*
-		 (not (= 0 *test-interval*))
-		 (= 0 (mod i *test-interval*)))
-	   (test-epoch))
-      (train-outputs-epoch)
-      (cond ((zerop *error-bits*)
-	     (record-output-weights)
-	     (return :win))
-	    ((zerop *output-patience*))
-	    (first-time
-	     (setq first-time nil)
-	     (setq last-error *true-error*))
-	    ((> (abs (- *true-error* last-error))
-		(* last-error *output-change-threshold*))
-	     (setq last-error *true-error*)
-	     (setq quit-epoch (+ *epoch* *output-patience*)))
-	    ((>= *epoch* quit-epoch)
-	     (record-output-weights)
-	     (return :stagnant))))))
-
-
-;;;; Machinery for Training, Selecting, and Installing Candidate Units.
-
-(defun init-candidates ()
-  "Give new random weights to all of the candidate units.  Zero the other
-  candidate-unit statistics."
-  (dotimes1 (i *ncandidates*)
-    (setf (fvref *cand-sum-values* i) 0.0)
-    (let ((cw (svref *cand-weights* i))
-	  (cd (svref *cand-deltas* i))
-	  (cs (svref *cand-slopes* i))
-	  (cp (svref *cand-prev-slopes* i))
-	  (cc (svref *cand-cor* i))
-	  (cpc (svref *cand-prev-cor* i)))
-      (dotimes1 (j *nunits*)
-	(setf (fvref cw j) (random-weight))
-	(setf (fvref cd j) 0.0)
-	(setf (fvref cs j) 0.0)
-	(setf (fvref cp j) 0.0))
-      (dotimes1 (o *noutputs*)
-	(setf (fvref cc o) 0.0)
-	(setf (fvref cpc o) 0.0)))))
-
-(defun install-new-unit ()
-  "Add the candidate-unit with the best correlation score to the active
-  network.  Then reinitialize the candidate pool."
-  (when (>= *nunits* *max-units*)
-    (error "Cannot add any more units."))
-  ;; For now, assume total connectivity.
-  (setf (ivref *nconnections* *nunits*) *nunits*)
-  (setf (svref *connections* *nunits*) *all-connections*)
-  ;; Copy the weight vector for the new unit.
-  (let ((w (make-array *nunits* :element-type 'short-float))
-	(cw (svref *cand-weights* *best-candidate*)))
-    (dotimes1 (i *nunits*)
-      (setf (fvref w i) (fvref cw i)))
-    (setf (svref *weights* *nunits*) w)
-    ;; Tell user about the new unit.
-    (format t "  Add unit ~S: ~S~%"
-	    (+ 1 *nunits*) w))
-  ;; Fix up output weights for candidate unit.
-  ;; Use minus the correlation times the *weight-multiplier* as an
-  ;; initial guess.  At least the sign should be right.
-  (dotimes1 (o *noutputs*)
-    (setf (fvref (svref *output-weights* o) *nunits*)
-	  (*sf (-sf (fvref (svref *cand-prev-cor* *best-candidate*) o))
-	       *weight-multiplier*)))
-  ;; If using cache, run an epoch to compute this unit's values.
-  (when *use-cache*
-    (dotimes1 (i *max-cases*)
-      (setq *values* (svref *values-cache* i))
-      (compute-unit-value *nunits*)))
-  ;; Reinitialize candidate units with random weights.
-  (incf *nunits*)
-  (init-candidates))
-
-;;; Note: Ideally, after each adjustment of the candidate weights, we would
-;;; run two epochs.  The first would just determine the correlations
-;;; between the candidate unit outputs and the residual error.  Then, in a
-;;; second pass, we would adjust each candidate's input weights so as to
-;;; maximize the absolute value of the correlation.  We need to know the
-;;; sign of the correlation for each candidate-output pair so that we know
-;;; which direction to tune the input weights.
-
-;;; Since this ideal method doubles the number of epochs required for
-;;; training candidates, we cheat slightly and use the correlation values
-;;; computed BEFORE the most recent weight update.  This combines the two
-;;; epochs, saving us almost a factor of two.  To bootstrap the process, we
-;;; begin with a single epoch that computes only the correlation.
-
-;;; Since we look only at the sign of the correlation and since that sign
-;;; should change very infrequently, this probably is OK.  But keep a
-;;; lookout for pathological situations in which this might cause
-;;; oscillation.
-
-
-;;; This function is used only once at the start of each output-training
-;;; phase to prime the pump.  After that, each call to compute-slopes also
-;;; computes the error-value products for the next epoch.
-
-(defun compute-correlations ()
-  "For the current training pattern, compute the value of each candidate
-  unit and begin to compute the correlation between that unit's value and
-  the error at each output.  We have already done a forward-prop and
-  computed the error values for active units."
-  (dotimes1 (u *ncandidates*)
-    (let ((sum 0.0)
-	  (v 0.0)
-	  (cw (svref *cand-weights* u))
-	  (cc (svref *cand-cor* u)))
-      (declare (short-float sum v))
-      ;; Determine activation value of each candidate unit.
-      (dotimes1 (i *nunits*)
-	(incf-sf sum (*sf (fvref cw i)
-			  (fvref *values* i))))
-      (setq v (activation sum))
-      (incf-sf (fvref *cand-sum-values* u) v)
-      ;; Accumulate value of each unit times error at each output.
-      (dotimes1 (o *noutputs*)
-	(incf-sf (fvref cc o) (*sf v (fvref *errors* o)))))))
-
-;;; Note: When we were computing true correlations between candidates and
-;;; outputs, this is where the normalization factors went in.  Currently we
-;;; are just using covariances, as explained in the tech report.  So we
-;;; make only two adjustments here.  First, we subtract out the product of
-;;; the mean error and the mean candidate value to keep things from
-;;; exploding when the error has a non-zero mean.  Second, we effectively
-;;; scale the error values by the sum-squared error over all training
-;;; cases.  This just keeps us from having to adjust *input-epsilon*
-;;; repeatedly as the error is gradually reduced to a small fraction of its
-;;; initial size.
-
-(defun adjust-correlations ()
-  "Normalize each accumulated correlation value, and stuff the normalized
-  form into the *cand-prev-cor* data structure.  Then zero *cand-cor* to
-  prepare for the next round.  Note the unit with the best total
-  correlation score."
-  (setq *best-candidate* 0)
-  (setq *best-candidate-score* 0.0)
-  (dotimes1 (u *ncandidates*)
-    (let* ((cc (svref *cand-cor* u))
-	   (cpc (svref *cand-prev-cor* u))
-	   (offset (*sf (fvref *cand-sum-values* u) *avg-error*))
-	   (cor 0.0)
-	   (score 0.0))
-      (declare (short-float offset cor score))
-      (dotimes1 (o *noutputs*)
-	(setq cor (/sf (-sf (fvref cc o) offset) *sum-sq-error*))
-	(setf (fvref cpc o) cor)
-	(setf (fvref cc o) 0.0)
-	(incf-sf score (abs cor)))
-      ;; Keep track of the candidate with the best overall correlation.
-      (when (> score *best-candidate-score*)
-	(setq *best-candidate-score* score)
-	(setq *best-candidate* u)))))
-
-;;; This is the key function in the candidate training process.
-
-(defun compute-slopes ()
-  "Given the correlation values for each candidate-output pair, compute
-  the derivative of the candidate's score with respect to each incoming
-  weight."
-  (dotimes1 (u *ncandidates*)
-    (let* ((sum 0.0)
-	   (value 0.0)
-	   (actprime 0.0)
-	   (direction 0.0)
-	   (cw (svref *cand-weights* u))
-	   (cs (svref *cand-slopes* u))
-	   (cc (svref *cand-cor* u))
-	   (cpc (svref *cand-prev-cor* u)))
-      (declare (short-float sum value actprime direction))
-      ;; Forward pass through each candidate unit to compute activation-prime.
-      (dotimes1 (i *nunits*)
-	(incf-sf sum (*sf (fvref cw i)
-			  (fvref *values* i))))
-      (setq value (activation sum))
-      (setq actprime (activation-prime value sum))
-      ;; Now compute which way we want to adjust each unit's incoming
-      ;; activation.
-      (dotimes1 (o *noutputs*)
-	(let ((error (fvref *errors* o)))
-	  (decf-sf direction
-		   (*sf (if (minusp (fvref cpc o)) -1.0 1.0)
-			(*sf actprime
-			     (/sf (-sf error *avg-error*)
-				  *sum-sq-error*))))
-	  ;; Also accumulate the error-value products for use next epoch.
-	  (incf-sf (fvref cc o) (*sf error value))))
-      ;; Given the direction we want to push the candidate, compute
-      ;; which way we want to tweak each incoming weight.
-      (dotimes1 (i *nunits*)
-	(incf-sf (fvref cs i)
-		 (*sf direction (fvref *values* i)))))))
-
-;;; Note: Scaling *INPUT-EPSILON* by the number of cases and number of
-;;; inputs to each unit seems to keep the quickprop update in a good range,
-;;; as the network goes from small to large, and across many
-;;; different-sized training sets.  Still, choosing a good epsilon value
-;;; requires some trial and error.
-
-(defun update-input-weights ()
-  "Update the input weights, using the pre-computed slopes, prev-slopes,
-  and delta values.  Uses the quickprop update function."
-  (let ((eps (/ *input-epsilon* (* *ncases* *nunits*))))
-    (dotimes1 (u *ncandidates*)
-      (let ((cw (svref *cand-weights* u))
-	    (cd (svref *cand-deltas* u))
-	    (cs (svref *cand-slopes* u))
-	    (cp (svref *cand-prev-slopes* u)))
-	(dotimes1 (i *nunits*)
-	  (quickprop-update i cw cd cs cp eps *input-decay*
-			    *input-mu* *input-shrink-factor*))))))
-
-;;; Outer loop for training the candidate unit(s).
-
-(defun train-inputs-epoch ()
-  "For each training pattern, perform a forward pass.  Tune the candidate units'
-  weights to maximize the correlation score of each."
-  (do ((i *first-case* (1+ i)))
-      ((= i (the fixnum (+ *first-case* *ncases*))))
-    (declare (fixnum i))
-    (setq *goal* (svref *training-outputs* i))
-    ;; Compute values and errors, or recall cached values.
-    (cond (*use-cache*
-	   (setq *values* (svref *values-cache* i))
-	   (setq *errors* (svref *errors-cache* i)))
-	  (t (setq *values* *extra-values*)
-	     (setq *errors* *extra-errors*)
-	     (full-forward-pass (svref *training-inputs* i))
-	     (compute-errors *goal* nil nil)))
-    ;; Compute the slopes we will use to adjust candidate weights.
-    (compute-slopes))
-  ;; User may have changed mu between epochs, so fix shrink-factor.
-  (setq *input-shrink-factor* (/sf *input-mu*
-				   (+sf 1.0 *input-mu*)))
-  ;; Now adjust the candidate unit input weights using quickprop.
-  (update-input-weights)
-  ;; Fix up the correlation values for the next epoch.
-  (adjust-correlations)
-  (incf *epoch*))
-
-(defun correlations-epoch ()
-  "Do an epoch through all active training patterns just to compute the
-  initial correlations.  After this one pass, we will update the
-  correlations as we train."
-  (do ((i *first-case* (1+ i)))
-      ((= i (the fixnum (+ *first-case* *ncases*))))
-    (declare (fixnum i))
-    (setq *goal* (svref *training-outputs* i))
-    (cond (*use-cache*
-	   (setq *values* (svref *values-cache* i))
-	   (setq *errors* (svref *errors-cache* i)))
-	  (t (setq *values* *extra-values*)
-	     (setq *errors* *extra-errors*)
-	     (full-forward-pass (svref *training-inputs* i))
-	     (compute-errors *goal* nil nil)))
-    (compute-correlations))
-  (adjust-correlations)
-  (incf *epoch*))
-
-(defun train-inputs (max-epochs)
-  "Train the input weights of all candidates.  If we exhaust MAX-EPOCHS,
-  stop with value :TIMEOUT.  Else, keep going until the best candidate
-  unit's score has changed by a significant amount, and then until it does
-  not change significantly for PATIENCE epochs.  Then return :STAGNANT.  If
-  PATIENCE is zero, we do not stop until victory or until MAX-EPOCHS is
-  used up."
-  (declare (fixnum max-epochs))
-  (setq *avg-error* (/ *sum-error* (* *ncases* *noutputs*)))
-  (correlations-epoch)
-  (let ((last-score 0.0)
-	(quit max-epochs)
-	(first-time t))
-    (declare (fixnum quit)
-	     (short-float last-score))
-    (dotimes1 (i max-epochs :timeout)
-      (train-inputs-epoch)
-      (cond ((zerop *input-patience*))
-	    (first-time
-	     (setq first-time nil)
-	     (setq last-score *best-candidate-score*))
-	    ((> (abs (-sf *best-candidate-score* last-score))
-		(* last-score *input-change-threshold*))
-	     (setq last-score *best-candidate-score*)
-	     (setq quit (+ i *input-patience*)))
-	    ((>= i quit)
-	     (return :stagnant))))))
-
-;;;; Outer Loop.
-
-(defun list-parameters ()
-  "Print out the current training parameters in abbreviated form."
-  (format t "SigOff ~,2F, WtRng ~,2F, WtMul ~,2F~%"
-	  *sigmoid-prime-offset* *weight-range* *weight-multiplier*)
-  (format t "OMu ~,2F, OEps ~,2F, ODcy ~,4F, OPat ~D, OChange ~,3F~%"
-	  *output-mu* *output-epsilon* *output-decay* *output-patience*
-	  *output-change-threshold*)
-  (format t "IMu ~,2F, IEps ~,2F, IDcy ~,4F, IPat ~D, IChange ~,3F~%"
-	  *input-mu* *input-epsilon* *input-decay* *input-patience*
-	  *input-change-threshold*)
-  (format t "Utype ~S, Otype ~S, RawErr ~S, Pool ~D~%"
-	  *unit-type* *output-type* *raw-error* *ncandidates*))
-
-(defun train (outlimit inlimit rounds &optional (restart nil))
-  "Train the output weights until stagnation or victory is reached.  Then
-  train the input weights to stagnation or victory.  Then install the best
-  candidate unit and repeat.  OUTLIMIT and INLIMIT are upper limits on the number
-  of cycles in each output and input phase.  ROUNDS is an upper limit on
-  the number of unit-installation cycles.  If RESTART is non-nil, we are
-  restarting training from the current point -- do not reinitialize the net."
-  (declare (fixnum outlimit inlimit rounds))
-  (unless restart (init-net))
-  (list-parameters)
-  (when *use-cache*
-    (dotimes1 (i *max-cases*)
-      (setq *values* (svref *values-cache* i))
-      (set-up-inputs (svref *training-inputs* i))))
-  (dotimes1 (r rounds  :lose)
-    (case (train-outputs outlimit)
-      (:win
-       (list-parameters)
-       (format t "Victory at ~S epochs, ~S units, ~S hidden, Error ~S.~%"
-	       *epoch* *nunits* (- *nunits* *ninputs* 1) *true-error*)
-       (return nil))
-      (:timeout
-       (format t "Epoch ~D: Out Timeout  ~D bits wrong, error ~S.~2%"
-	       *epoch* *error-bits* *true-error*))
-      (:stagnant
-       (format t "Epoch ~D: Out Stagnant ~D bits wrong, error ~S.~2%"
-	       *epoch* *error-bits* *true-error*)))
-    (when *test* (test-epoch))
-    (case (train-inputs inlimit)
-      (:timeout
-       (format t "Epoch ~D: In Timeout.  Cor: ~D~%"
-	       *epoch* *best-candidate-score*))
-      (:stagnant
-       (format t "Epoch ~D: In Stagnant.  Cor: ~D~%"
-	       *epoch* *best-candidate-score*)))
-    (install-new-unit)))
-
-(defun test-epoch (&optional (*score-threshold* 0.49999))
-  "Perform forward propagation once for each set of weights in the training
-  and testing vectors.  Reporting the performance.  Do not change any
-  weights.  Do not use the caches."
-  (let ((*use-cache* nil)
-	(*values* *extra-values*)
-	(*errors* *extra-errors*)
-	(*error-bits* 0)
-	(*true-error* 0.0)
-	(*sum-error* 0.0)
-	(*sum-sq-error* 0.0))
-    ;; Run all training patterns and count errors.
-    (dotimes1 (i (length *training-inputs*))
-      (setq *goal* (svref *training-outputs* i))
-      (full-forward-pass (svref *training-inputs* i))
-      (compute-errors *goal* nil t))
-    (format t "Training: ~D of ~D wrong, error ~S."
-	    *error-bits* (length *training-inputs*) *true-error*)
-    ;; Zero some accumulators again.
-    (setq *error-bits* 0)
-    (setq *true-error* 0.0)
-    (setq *sum-error* 0.0)
-    (setq *sum-sq-error* 0.0)
-    ;; Now run all test patterns and report the results.
-    (when *test-inputs*
-      (dotimes1 (i (length *test-inputs*))
-	(setq *goal* (svref *test-outputs* i))
-	(full-forward-pass (svref *test-inputs* i))
-	(compute-errors *goal* nil t)))
-    (format t "  Test: ~D of ~D wrong, error ~S.~%"
-	    *error-bits* (length *test-inputs*) *true-error*)))
-
-(defun test-setup (nunits weights output-weights)
-  "Set up a network for testing, given stored weights and output weights."
-  (init-net)
-  (setq *weights* weights)
-  (setq *output-weights* output-weights)
-  (setq *nunits* nunits)
-  (do ((i (1+ *ninputs*) (1+ i)))
-      ((= i *nunits*))
-    (declare (fixnum i))
-    (setf (ivref *nconnections* i) i)
-    (setf (svref *connections* i) *all-connections*)))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Example Applications ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; Zig-Zag problem.  An easy one, useful for testing the code.
-
-(defun build-zig-zag (n)
-  "Build N pairs of 1-D zig-zag."
-  (declare (fixnum n))
-  (setq *ninputs* 1)
-  (setq *noutputs* 1)
-  (let ((ti (make-array (* 2 n)))
-	(to (make-array (* 2 n))))
-    (dotimes1 (i n)
-      (setf (svref ti (* i 2))
-	    (vector (+ i 1.0)))
-      (setf (svref to (* i 2))
-	    (vector (if (evenp i) 0.5 -0.5)))
-      (setf (svref ti (1+ (* i 2)))
-	    (vector (- (+ i 1.0))))
-      (setf (svref to (1+ (* i 2)))
-	    (vector (if (evenp i) -0.5 0.5))))
-    (setq *training-inputs* ti)
-    (setq *training-outputs* to)
-    (setq *test-inputs* ti)
-    (setq *test-outputs* to))
-  (build-net 1 1)
-  (init-net))
-
-;;; Call this with something like (BUILD-ZIG-ZAG 4), then call
-;;; something like (train 100 100 25).
-
-
-;;; Two spirals problem.
-
-(defun build-two-spirals (&optional (n 97))
-  "Build N point-pairs of the two-spiral problem, with standard default
-  of 97 pairs."
-  (declare (fixnum n))
-  (setq *ninputs* 2)
-  (setq *noutputs* 1)
-  (let ((ti (make-array (* 2 n)))
-	(to (make-array (* 2 n))))
-    (dotimes1 (i n)
-      (let* ((angle (/ (* i (coerce pi 'short-float)) 16.0))
-	     (radius (/ (* 6.5 (- 104.0 i)) 104))
-	     (x (* radius (sin angle)))
-	     (y (* radius (cos angle))))
-	(setf (svref ti (* i 2))
-	      (vector x y))
-	(setf (svref to (* i 2))
-	      (vector 0.5))
-	(setf (svref ti (1+ (* i 2)))
-	      (vector (- x) (- y)))
-	(setf (svref to (1+ (* i 2)))
-	      (vector -0.5))))
-    ;; Put the inner part of the spiral first on the list.
-    (setq ti (nreverse ti))
-    (setq to (nreverse to))
-    (setq *training-inputs* ti)
-    (setq *training-outputs* to)
-    (setq *test-inputs* ti)
-    (setq *test-outputs* to))
-  (build-net 2 1)
-  (init-net))
-
-;;; To run this, call (BUILD-TWO-SPIRALS), set various control parameters,
-;;; and then call something like (TRAIN 100 100 25).
-
-;;; For parameters, try these:
-;;; SigOff 0.10, WtRng 1.00, WtMul 1.00
-;;; OMu 2.00, OEps 1.00, ODcy 0.0001, OPat 12, OChange 0.010
-;;; IMu 2.00, IEps 100.00, IDcy 0.00000, IPat 8, IChange 0.030
-;;; Utype :SIGMOID, Otype :SIGMOID, RawErr NIL, Pool 8
-
-(defvar *save-random-state*
-  #+cmu
-  #S(RANDOM-STATE
-     J 6
-     K 37
-     SEED #(495959915 319289337 100972028 135321524 137984323
-	    177928266 385820814 500959740 328846885 254554634
-	    354844676 133704123 362896421 217869951 380210131
-	    323670005 366246053 40575617 346460653 10417936
-	    34276234 300730891 211595838 199986777 291429322
-	    1196272 425488031 328015953 24567252 297307474
-	    82341400 29130711 247126684 98716216 478723257
-	    47355455 81983578 248879315 97829219 533448623
-	    148633156 77868250 28344376 162872116 404460195
-	    321766796 8557425 441861346 455213668 302826847
-	    256874625 271153816 11749650 277043774 234844262))
-  #-cmu (make-random-state))
-
-(defun time-two-spirals ()
-  (setq *random-state* (make-random-state *save-random-state*))
-  (build-two-spirals)
-  (time (train 100 100 25)))
-	
-;;; The End.
-
diff --git a/benchmarks/gabriel/bmarks.lisp b/benchmarks/gabriel/bmarks.lisp
deleted file mode 100644
index cc73b619d5c9a17ac2544376f83bfb2039789366..0000000000000000000000000000000000000000
--- a/benchmarks/gabriel/bmarks.lisp
+++ /dev/null
@@ -1,2385 +0,0 @@
-;;;; -*- Mode: Lisp; Package: User -*-
-;;;;
-;;;; This file contains the common lisp version of the lisp performance
-;;;; benchmarks from Stanford.  These were translated and tested using
-;;;; Symbolics Common Lisp on a Symbolics 3600.  The benchmarks in this
-;;;; file have not been "tuned" to any particular implementation.
-;;;;
-;;;; The benchmarks have been substantially cleaned up and made truly
-;;;; Common Lisp at CMU by Rob Maclachlan and Skef Wholey.  Timing
-;;;; functions for each benchmark have been added.  Declarations have
-;;;; been added by David B. McDonald.  Declarations should only affect
-;;;; performance on general purpose hardware.  Also, this reduces or
-;;;; eliminates the error checking and may allow the system to be
-;;;; corrupted if incorrect programs are run.
-;;;;
-;;;; Suggestions or problems to PW@SAIL.
-
-(in-package "USER")
-#+proclaim-unsafe
-(proclaim '(optimize (safety 0) (speed 3) (space 0)))
-(proclaim '(inline assoc member))
-#-cmu
-(proclaim '(declaration start-block end-block))
-
-
-(proclaim '(start-block boyer))
-;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer.
-;;; Fairly CONS intensive.
-
-(defvar unify-subst)
-(defvar temp-temp)
-
-(defun add-lemma (term)
-  (cond ((and (not (atom term))
-	      (eq (car term)
-		  (quote equal))
-	      (not (atom (cadr term))))
-	 (setf (get (car (cadr term)) (quote lemmas))
-	       (cons term (get (car (cadr term)) (quote lemmas)))))
-	(t (error "~%ADD-LEMMA did not like term:  ~a" term))))
-
-(defun add-lemma-lst (lst)
-  (cond ((null lst)
-	 t)
-	(t (add-lemma (car lst))
-	   (add-lemma-lst (cdr lst)))))
-
-(defun apply-subst (alist term)
-  (cond ((atom term)
-	 (cond ((setq temp-temp (assoc term alist :test #'eq))
-		(cdr temp-temp))
-	       (t term)))
-	(t (cons (car term)
-		 (apply-subst-lst alist (cdr term))))))
-
-(defun apply-subst-lst (alist lst)
-  (cond ((null lst)
-	 nil)
-	(t (cons (apply-subst alist (car lst))
-		 (apply-subst-lst alist (cdr lst))))))
-
-(defun falsep (x lst)
-  (or (equal x (quote (f)))
-      (member x lst :test #'eq)))
-
-(defun one-way-unify (term1 term2)
-  (progn (setq unify-subst nil)
-	 (one-way-unify1 term1 term2)))
-
-(defun one-way-unify1 (term1 term2)
-  (cond ((atom term2)
-	 (cond ((setq temp-temp (assoc term2 unify-subst :test #'eq))
-		(equal term1 (cdr temp-temp)))
-	       (t (setq unify-subst (cons (cons term2 term1)
-					  unify-subst))
-		  t)))
-	((atom term1)
-	 nil)
-	((eq (car term1)
-	     (car term2))
-	 (one-way-unify1-lst (cdr term1)
-			     (cdr term2)))
-	(t nil)))
-
-(defun one-way-unify1-lst (lst1 lst2)
-  (cond ((null lst1)
-	 t)
-	((one-way-unify1 (car lst1)
-			 (car lst2))
-	 (one-way-unify1-lst (cdr lst1)
-			     (cdr lst2)))
-	(t nil)))
-
-(defun rewrite (term)
-  (cond ((atom term)
-	 term)
-	(t (rewrite-with-lemmas (cons (car term)
-				      (rewrite-args (cdr term)))
-				(get (car term)
-				     (quote lemmas))))))
-
-(defun rewrite-args (lst)
-  (cond ((null lst)
-	 nil)
-	(t (cons (rewrite (car lst))
-		 (rewrite-args (cdr lst))))))
-
-(defun rewrite-with-lemmas (term lst)
-  (cond ((null lst)
-	 term)
-	((one-way-unify term (cadr (car lst)))
-	 (rewrite (apply-subst unify-subst (caddr (car lst)))))
-	(t (rewrite-with-lemmas term (cdr lst)))))
-
-(defun setup-boyer ()
-  (add-lemma-lst
-    (quote ((equal (compile form)
-		   (reverse (codegen (optimize form)
-				     (nil))))
-	    (equal (eqp x y)
-		   (equal (fix x)
-			  (fix y)))
-	    (equal (greaterp x y)
-		   (lessp y x))
-	    (equal (lesseqp x y)
-		   (not (lessp y x)))
-	    (equal (greatereqp x y)
-		   (not (lessp x y)))
-	    (equal (boolean x)
-		   (or (equal x (t))
-		       (equal x (f))))
-	    (equal (iff x y)
-		   (and (implies x y)
-			(implies y x)))
-	    (equal (even1 x)
-		   (if (zerop x)
-		       (t)
-		       (odd (1- x))))
-	    (equal (countps- l pred)
-		   (countps-loop l pred (zero)))
-	    (equal (fact- i)
-		   (fact-loop i 1))
-	    (equal (reverse- x)
-		   (reverse-loop x (nil)))
-	    (equal (divides x y)
-		   (zerop (remainder y x)))
-	    (equal (assume-true var alist)
-		   (cons (cons var (t))
-			 alist))
-	    (equal (assume-false var alist)
-		   (cons (cons var (f))
-			 alist))
-	    (equal (tautology-checker x)
-		   (tautologyp (normalize x)
-			       (nil)))
-	    (equal (falsify x)
-		   (falsify1 (normalize x)
-			     (nil)))
-	    (equal (prime x)
-		   (and (not (zerop x))
-			(not (equal x (add1 (zero))))
-			(prime1 x (1- x))))
-	    (equal (and p q)
-		   (if p (if q (t)
-			     (f))
-		       (f)))
-	    (equal (or p q)
-		   (if p (t)
-		       (if q (t)
-			   (f))
-		       (f)))
-	    (equal (not p)
-		   (if p (f)
-		       (t)))
-	    (equal (implies p q)
-		   (if p (if q (t)
-			     (f))
-		       (t)))
-	    (equal (fix x)
-		   (if (numberp x)
-		       x
-		       (zero)))
-	    (equal (if (if a b c)
-		       d e)
-		   (if a (if b d e)
-		       (if c d e)))
-	    (equal (zerop x)
-		   (or (equal x (zero))
-		       (not (numberp x))))
-	    (equal (plus (plus x y)
-			 z)
-		   (plus x (plus y z)))
-	    (equal (equal (plus a b)
-			  (zero))
-		   (and (zerop a)
-			(zerop b)))
-	    (equal (difference x x)
-		   (zero))
-	    (equal (equal (plus a b)
-			  (plus a c))
-		   (equal (fix b)
-			  (fix c)))
-	    (equal (equal (zero)
-			  (difference x y))
-		   (not (lessp y x)))
-	    (equal (equal x (difference x y))
-		   (and (numberp x)
-			(or (equal x (zero))
-			    (zerop y))))
-	    (equal (meaning (plus-tree (append x y))
-			    a)
-		   (plus (meaning (plus-tree x)
-				  a)
-			 (meaning (plus-tree y)
-				  a)))
-	    (equal (meaning (plus-tree (plus-fringe x))
-			    a)
-		   (fix (meaning x a)))
-	    (equal (append (append x y)
-			   z)
-		   (append x (append y z)))
-	    (equal (reverse (append a b))
-		   (append (reverse b)
-			   (reverse a)))
-	    (equal (times x (plus y z))
-		   (plus (times x y)
-			 (times x z)))
-	    (equal (times (times x y)
-			  z)
-		   (times x (times y z)))
-	    (equal (equal (times x y)
-			  (zero))
-		   (or (zerop x)
-		       (zerop y)))
-	    (equal (exec (append x y)
-			 pds envrn)
-		   (exec y (exec x pds envrn)
-			 envrn))
-	    (equal (mc-flatten x y)
-		   (append (flatten x)
-			   y))
-	    (equal (member x (append a b))
-		   (or (member x a)
-		       (member x b)))
-	    (equal (member x (reverse y))
-		   (member x y))
-	    (equal (length (reverse x))
-		   (length x))
-	    (equal (member a (intersect b c))
-		   (and (member a b)
-			(member a c)))
-	    (equal (nth (zero)
-			i)
-		   (zero))
-	    (equal (exp i (plus j k))
-		   (times (exp i j)
-			  (exp i k)))
-	    (equal (exp i (times j k))
-		   (exp (exp i j)
-			k))
-	    (equal (reverse-loop x y)
-		   (append (reverse x)
-			   y))
-	    (equal (reverse-loop x (nil))
-		   (reverse x))
-	    (equal (count-list z (sort-lp x y))
-		   (plus (count-list z x)
-			 (count-list z y)))
-	    (equal (equal (append a b)
-			  (append a c))
-		   (equal b c))
-	    (equal (plus (remainder x y)
-			 (times y (quotient x y)))
-		   (fix x))
-	    (equal (power-eval (big-plus1 l i base)
-			       base)
-		   (plus (power-eval l base)
-			 i))
-	    (equal (power-eval (big-plus x y i base)
-			       base)
-		   (plus i (plus (power-eval x base)
-				 (power-eval y base))))
-	    (equal (remainder y 1)
-		   (zero))
-	    (equal (lessp (remainder x y)
-			  y)
-		   (not (zerop y)))
-	    (equal (remainder x x)
-		   (zero))
-	    (equal (lessp (quotient i j)
-			  i)
-		   (and (not (zerop i))
-			(or (zerop j)
-			    (not (equal j 1)))))
-	    (equal (lessp (remainder x y)
-			  x)
-		   (and (not (zerop y))
-			(not (zerop x))
-			(not (lessp x y))))
-	    (equal (power-eval (power-rep i base)
-			       base)
-		   (fix i))
-	    (equal (power-eval (big-plus (power-rep i base)
-					 (power-rep j base)
-					 (zero)
-					 base)
-			       base)
-		   (plus i j))
-	    (equal (gcd x y)
-		   (gcd y x))
-	    (equal (nth (append a b)
-			i)
-		   (append (nth a i)
-			   (nth b (difference i (length a)))))
-	    (equal (difference (plus x y)
-			       x)
-		   (fix y))
-	    (equal (difference (plus y x)
-			       x)
-		   (fix y))
-	    (equal (difference (plus x y)
-			       (plus x z))
-		   (difference y z))
-	    (equal (times x (difference c w))
-		   (difference (times c x)
-			       (times w x)))
-	    (equal (remainder (times x z)
-			      z)
-		   (zero))
-	    (equal (difference (plus b (plus a c))
-			       a)
-		   (plus b c))
-	    (equal (difference (add1 (plus y z))
-			       z)
-		   (add1 y))
-	    (equal (lessp (plus x y)
-			  (plus x z))
-		   (lessp y z))
-	    (equal (lessp (times x z)
-			  (times y z))
-		   (and (not (zerop z))
-			(lessp x y)))
-	    (equal (lessp y (plus x y))
-		   (not (zerop x)))
-	    (equal (gcd (times x z)
-			(times y z))
-		   (times z (gcd x y)))
-	    (equal (value (normalize x)
-			  a)
-		   (value x a))
-	    (equal (equal (flatten x)
-			  (cons y (nil)))
-		   (and (nlistp x)
-			(equal x y)))
-	    (equal (listp (gopher x))
-		   (listp x))
-	    (equal (samefringe x y)
-		   (equal (flatten x)
-			  (flatten y)))
-	    (equal (equal (greatest-factor x y)
-			  (zero))
-		   (and (or (zerop y)
-			    (equal y 1))
-			(equal x (zero))))
-	    (equal (equal (greatest-factor x y)
-			  1)
-		   (equal x 1))
-	    (equal (numberp (greatest-factor x y))
-		   (not (and (or (zerop y)
-				 (equal y 1))
-			     (not (numberp x)))))
-	    (equal (times-list (append x y))
-		   (times (times-list x)
-			  (times-list y)))
-	    (equal (prime-list (append x y))
-		   (and (prime-list x)
-			(prime-list y)))
-	    (equal (equal z (times w z))
-		   (and (numberp z)
-			(or (equal z (zero))
-			    (equal w 1))))
-	    (equal (greatereqpr x y)
-		   (not (lessp x y)))
-	    (equal (equal x (times x y))
-		   (or (equal x (zero))
-		       (and (numberp x)
-			    (equal y 1))))
-	    (equal (remainder (times y x)
-			      y)
-		   (zero))
-	    (equal (equal (times a b)
-			  1)
-		   (and (not (equal a (zero)))
-			(not (equal b (zero)))
-			(numberp a)
-			(numberp b)
-			(equal (1- a)
-			       (zero))
-			(equal (1- b)
-			       (zero))))
-	    (equal (lessp (length (delete x l))
-			  (length l))
-		   (member x l))
-	    (equal (sort2 (delete x l))
-		   (delete x (sort2 l)))
-	    (equal (dsort x)
-		   (sort2 x))
-	    (equal (length (cons x1
-				 (cons x2
-				       (cons x3 (cons x4
-						      (cons x5
-							    (cons x6 x7)))))))
-		   (plus 6 (length x7)))
-	    (equal (difference (add1 (add1 x))
-			       2)
-		   (fix x))
-	    (equal (quotient (plus x (plus x y))
-			     2)
-		   (plus x (quotient y 2)))
-	    (equal (sigma (zero)
-			  i)
-		   (quotient (times i (add1 i))
-			     2))
-	    (equal (plus x (add1 y))
-		   (if (numberp y)
-		       (add1 (plus x y))
-		       (add1 x)))
-	    (equal (equal (difference x y)
-			  (difference z y))
-		   (if (lessp x y)
-		       (not (lessp y z))
-		       (if (lessp z y)
-			   (not (lessp y x))
-			   (equal (fix x)
-				  (fix z)))))
-	    (equal (meaning (plus-tree (delete x y))
-			    a)
-		   (if (member x y)
-		       (difference (meaning (plus-tree y)
-					    a)
-				   (meaning x a))
-		       (meaning (plus-tree y)
-				a)))
-	    (equal (times x (add1 y))
-		   (if (numberp y)
-		       (plus x (times x y))
-		       (fix x)))
-	    (equal (nth (nil)
-			i)
-		   (if (zerop i)
-		       (nil)
-		       (zero)))
-	    (equal (last (append a b))
-		   (if (listp b)
-		       (last b)
-		       (if (listp a)
-			   (cons (car (last a))
-				 b)
-			   b)))
-	    (equal (equal (lessp x y)
-			  z)
-		   (if (lessp x y)
-		       (equal t z)
-		       (equal f z)))
-	    (equal (assignment x (append a b))
-		   (if (assignedp x a)
-		       (assignment x a)
-		       (assignment x b)))
-	    (equal (car (gopher x))
-		   (if (listp x)
-		       (car (flatten x))
-		       (zero)))
-	    (equal (flatten (cdr (gopher x)))
-		   (if (listp x)
-		       (cdr (flatten x))
-		       (cons (zero)
-			     (nil))))
-	    (equal (quotient (times y x)
-			     y)
-		   (if (zerop y)
-		       (zero)
-		       (fix x)))
-	    (equal (get j (set i val mem))
-		   (if (eqp j i)
-		       val
-		       (get j mem)))))))
-
-(defun tautologyp (x true-lst false-lst)
-  (cond ((truep x true-lst)
-	 t)
-	((falsep x false-lst)
-	 nil)
-	((atom x)
-	 nil)
-	((eq (car x)
-	     (quote if))
-	 (cond ((truep (cadr x)
-		       true-lst)
-		(tautologyp (caddr x)
-			    true-lst false-lst))
-	       ((falsep (cadr x)
-			false-lst)
-		(tautologyp (cadddr x)
-			    true-lst false-lst))
-	       (t (and (tautologyp (caddr x)
-				   (cons (cadr x)
-					 true-lst)
-				   false-lst)
-		       (tautologyp (cadddr x)
-				   true-lst
-				   (cons (cadr x)
-					 false-lst))))))
-	(t nil)))
-
-(defun tautp (x)
-  (tautologyp (rewrite x)
-	      nil nil))
-
-(defun boyer ()
-  (prog (ans term)
-	(setq term
-	      (apply-subst
-		(quote ((x f (plus (plus a b)
-				   (plus c (zero))))
-			(y f (times (times a b)
-				    (plus c d)))
-			(z f (reverse (append (append a b)
-					      (nil))))
-			(u equal (plus a b)
-			   (difference x y))
-			(w lessp (remainder a b)
-			   (member a (length b)))))
-		(quote (implies (and (implies x y)
-				     (and (implies y z)
-					  (and (implies z u)
-					       (implies u w))))
-				(implies x w)))))
-	(setq ans (tautp term))))
-
-(defun trans-of-implies (n)
-  (list (quote implies)
-	(trans-of-implies1 n)
-	(list (quote implies)
-	      0 n)))
-
-(defun trans-of-implies1 (n)
-  (declare (fixnum n))
-  (cond ((eql n 1)
-	 (list (quote implies)
-	       0 1))
-	(t (list (quote and)
-		 (list (quote implies)
-		       (1- n)
-		       n)
-		 (trans-of-implies1 (1- n))))))
-
-(defun truep (x lst)
-  (or (equal x (quote (t)))
-      (member x lst :test #'eq)))
-
-(eval-when (load eval)
-  (setup-boyer))
-
-(defun time-boyer ()
-  (time (boyer)))
-
-(proclaim '(start-block browse))
-;;; BROWSE -- Benchmark to create and browse through an AI-like data base of units.
-
-;;; n is # of symbols
-;;; m is maximum amount of stuff on the plist
-;;; npats is the number of basic patterns on the unit
-;;; ipats is the instantiated copies of the patterns
-
-(defvar browse-rand 21.)
-
-(defmacro char1 (x) `(aref (string ,x) 0))
-
-(defun init-browse (n m npats ipats)
-  (declare (fixnum n m npats))
-  (let ((ipats (copy-tree ipats)))
-    (do ((p ipats (cdr p)))
-	((null (cdr p)) (rplacd p ipats)))	
-    (do ((n n (1- n))
-	 (i m (cond ((= (the fixnum i) 0) m)
-		    (t (1- i))))
-	 (name (gentemp) (gentemp))
-	 (a ()))
-	((= (the fixnum n) 0) a)
-      (declare (fixnum n i m))
-      (push name a)
-      (do ((i i (1- i)))
-	  ((= (the fixnum i) 0))
-	(declare (fixnum i))
-	(setf (get name (gensym)) nil))
-      (setf (get name 'pattern)
-	    (do ((i npats (1- i))
-		 (ipats ipats (cdr ipats))
-		 (a ()))
-		((= (the fixnum i) 0) a)
-	      (declare (fixnum i))
-	      (push (car ipats) a)))
-      (do ((j (- m i) (1- j)))
-	  ((= (the fixnum j) 0))
-	(declare (fixnum j))
-	(setf (get name (gensym)) nil)))))  
-
-(defun browse-random ()
-  (setq browse-rand (mod (the fixnum (* (the fixnum browse-rand) 17.)) 251.)))
-
-(defun randomize (l)
-  (do ((a ()))
-      ((null l) a)
-    (let ((n (mod (browse-random) (length l))))
-      (declare (fixnum n))
-      (cond ((= (the fixnum n) 0)
-	     (push (car l) a)
-	     (setq l (cdr l)))
-	    (t 
-	     (do ((n n (1- n))
-		  (x l (cdr x)))
-		 ((= n 1)
-		  (push (cadr x) a)
-		  (rplacd x (cddr x)))
-	       (declare (fixnum n))))))))
-
-(defun match (pat dat alist)
-  (cond ((null pat)
-	 (null dat))
-	((null dat) ())
-	((or (eq (car pat) '?)
-	     (eq (car pat)
-		 (car dat)))
-	 (match (cdr pat) (cdr dat) alist))
-	((eq (car pat) '*)
-	 (or (match (cdr pat) dat alist)
-	     (match (cdr pat) (cdr dat) alist)
-	     (match pat (cdr dat) alist)))
-	(t (cond ((atom (car pat))
-		  (cond ((eq (char1 (car pat)) #\?)
-			 (let ((val (assoc (car pat) alist)))
-			   (cond (val (match (cons (cdr val)
-						   (cdr pat))
-					     dat alist))
-				 (t (match (cdr pat)
-					   (cdr dat)
-					   (cons (cons (car pat)
-						       (car dat))
-						 alist))))))
-			((eq (char1 (car pat)) #\*)
-			 (let ((val (assoc (car pat) alist)))
-			   (cond (val (match (append (cdr val)
-						     (cdr pat))
-					     dat alist))
-				 (t 
-				  (do ((l () (nconc l (cons (car d) nil)))
-				       (e (cons () dat) (cdr e))
-				       (d dat (cdr d)))
-				      ((null e) ())
-				    (cond ((match (cdr pat) d
-						  (cons (cons (car pat) l)
-							alist))
-					   (return t))))))))))
-		 (t (and 
-		      (not (atom (car dat)))
-		      (match (car pat)
-			     (car dat) alist)
-		      (match (cdr pat)
-			     (cdr dat) alist)))))))
-
-(defun browse ()
-  (investigate (randomize 
-		 (init-browse 100. 10. 4. '((a a a b b b b a a a a a b b a a a)
-					    (a a b b b b a a
-					       (a a)(b b))
-					    (a a a b (b a) b a b a))))
-	       '((*a ?b *b ?b a *a a *b *a)
-		 (*a *b *b *a (*a) (*b))
-		 (? ? * (b a) * ? ?))))
-
-(defun investigate (units pats)
-  (do ((units units (cdr units)))
-      ((null units))
-    (do ((pats pats (cdr pats)))
-	((null pats))
-      (do ((p (get (car units) 'pattern)
-	      (cdr p)))
-	  ((null p))
-	(match (car pats) (car p) ())))))
-
-(defun time-browse ()
-  (time (browse)))
-
-(proclaim '(start-block ctak))
-;;; CTAK -- A version of the TAKeuchi function that uses the CATCH/THROW facility.
-
-(defun ctak (x y z)
-  (declare (fixnum x y z))
-  (catch 'ctak (ctak-aux x y z)))
-
-(defun ctak-aux (x y z)
-  (declare (fixnum x y z))
-  (cond ((not (< y x))
-	 (throw 'ctak z))
-	(t (ctak-aux
-	     (catch 'ctak
-	       (ctak-aux (the fixnum (1- x))
-			 y
-			 z))
-	     (catch 'ctak
-	       (ctak-aux (the fixnum (1- y))
-			 z
-			 x))
-	     (catch 'ctak
-	       (ctak-aux (the fixnum (1- z))
-			 x
-			 y))))))
-
-(defun time-ctak ()
-  (format t "Note: 10 iterations.~%")
-  (time (dotimes (i 10) (ctak 18 12 6))))
-
-(proclaim '(start-block dderiv-run))
-;;; DDERIV -- The Common Lisp version of a symbolic derivative benchmark, written
-;;; by Vaughn Pratt.
-
-;;; This benchmark is a variant of the simple symbolic derivative program 
-;;; (DERIV). The main change is that it is `table-driven.'  Instead of using a
-;;; large COND that branches on the CAR of the expression, this program finds
-;;; the code that will take the derivative on the property list of the atom in
-;;; the CAR position. So, when the expression is (+ . <rest>), the code
-;;; stored under the atom '+ with indicator DERIV will take <rest> and
-;;; return the derivative for '+. The way that MacLisp does this is with the
-;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an
-;;; atomic name in that it expects an argument list and the compiler compiles
-;;; code, but the name of the function with that code is stored on the
-;;; property list of FOO under the indicator BAR, in this case. You may have
-;;; to do something like:
-
-;;; :property keyword is not Common Lisp.
-
-(defun dderiv-aux (a) 
-  (list '/ (dderiv a) a))
-
-(defun +-dderiv (a)
-  (cons '+ (mapcar #'dderiv a)))
-(setf (get '+ 'dderiv)  #'+-dderiv)
-
-(defun --dderiv (a)
-  (cons '- (mapcar #'dderiv a)))
-(setf (get '- 'dderiv) #'--dderiv)
-
-(defun *-dderiv (a)
-  (list '* (cons '* a)
-	(cons '+ (mapcar #'dderiv-aux a))))
-(setf (get '* 'dderiv) #'*-dderiv)
-
-(defun /-dderiv (a)
-  (list '- 
-	(list '/ 
-	      (dderiv (car a)) 
-	      (cadr a))
-	(list '/ 
-	      (car a) 
-	      (list '*
-		    (cadr a)
-		    (cadr a)
-		    (dderiv (cadr a))))))
-(setf (get '/ 'dderiv) #'/-dderiv)
-
-(defun dderiv (a)
-  (cond 
-    ((atom a)
-     (cond ((eq a 'x) 1) (t 0)))
-    (t (let ((dderiv (get (car a) 'dderiv)))
-	 (cond (dderiv (funcall (the function dderiv) (cdr a)))
-	       (t 'error))))))
-
-(defun dderiv-run ()
-  (do ((i 0 (1+ i)))
-      ((= i 1000.))
-    (declare (fixnum i))
-    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
-    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
-    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
-    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
-    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))))
-
-(defun time-dderiv ()
-  (time (dderiv-run)))
-
-(proclaim '(start-block deriv-run))
-;;; DERIV -- This is the Common Lisp version of a symbolic derivative benchmark
-;;; written by Vaughn Pratt.  It uses a simple subset of Lisp and does a lot of 
-;;; CONSing. 
-
-(defun deriv-aux (a) (list '/ (deriv a) a))
-
-(defun deriv (a)
-  (cond 
-    ((atom a)
-     (cond ((eq a 'x) 1) (t 0)))
-    ((eq (car a) '+)	
-     (cons '+ (mapcar #'deriv (cdr a))))
-    ((eq (car a) '-) 
-     (cons '- (mapcar #'deriv 
-		      (cdr a))))
-    ((eq (car a) '*)
-     (list '* 
-	   a 
-	   (cons '+ (mapcar #'deriv-aux (cdr a)))))
-    ((eq (car a) '/)
-     (list '- 
-	   (list '/ 
-		 (deriv (cadr a)) 
-		 (caddr a))
-	   (list '/ 
-		 (cadr a) 
-		 (list '*
-		       (caddr a)
-		       (caddr a)
-		       (deriv (caddr a))))))
-    (t 'error)))
-
-(defun deriv-run ()
-#|  (declare (fixnum i))	;improves the code a little
-Why, pray tell?
-|#
-  (do ((i 0 (1+ i)))
-      ((= i 1000.))	;runs it 5000 times
-    (declare (fixnum i))
-    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
-    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
-    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
-    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
-    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))))
-
-(defun time-deriv ()
-  (time (deriv-run)))
-
-(proclaim '(start-block destructive))
-;;; DESTRU -- Destructive operation benchmark
-
-(defun destructive (n m)
-  (declare (fixnum n m))
-  (let ((l (do ((i 10. (the fixnum (1- i)))
-		(a () (push () a)))
-	       ((= (the fixnum i) 0) a)
-	     (declare (fixnum i)))))
-    (do ((i n (the fixnum (1- i))))
-	((= (the fixnum i) 0))
-      (declare (fixnum i))
-      (cond ((null (car l))
-	     (do ((l l (cdr l)))
-		 ((null l))
-	       (or (car l) 
-		   (rplaca l (cons () ())))
-	       (nconc (car l)
-		      (do ((j m (the fixnum (1- j)))
-			   (a () (push () a)))
-			  ((= (the fixnum j) 0) a)
-			(declare (fixnum j))))))
-	    (t
-	     (do ((l1 l (cdr l1))
-		  (l2 (cdr l) (cdr l2)))
-		 ((null l2))
-	       (rplacd (do ((j (floor (length (car l2)) 2)
-			       (the fixnum (1- j)))
-			    (a (car l2) (cdr a)))
-			   ((zerop (the fixnum j)) a)
-			 (declare (fixnum j))
-			 (rplaca a i))
-		       (let ((n (floor (length (car l1)) 2)))
-			 (cond ((= (the fixnum n) 0) (rplaca l1 ())
-				(car l1))
-			       (t 
-				(do ((j n (the fixnum (1- j)))
-				     (a (car l1) (cdr a)))
-				    ((= j 1)
-				     (prog1 (cdr a)
-					    (rplacd a ())))
-				  (declare (fixnum j))
-				  (rplaca a i))))))))))))
-
-(defun time-destructive ()
-  (time (destructive 600 50)))
-
-(proclaim '(start-block div2-test-1 div2-test-2))
-
-;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s.
-;;; This file contains a recursive as well as an iterative test.
-
-(defun create-n (n)
-  (declare (fixnum n))
-  (do ((n n (1- n))
-       (a () (push () a)))
-      ((= (the fixnum n) 0) a)
-    (declare (fixnum n))))
-
-(defvar div2-l (create-n 200.))
-
-(defun iterative-div2 (l)
-  (do ((l l (cddr l))
-       (a () (push (car l) a)))
-      ((null l) a)))
-
-(defun recursive-div2 (l)
-  (cond ((null l) ())
-	(t (cons (car l) (recursive-div2 (cddr l))))))
-
-(defun div2-test-1 (l)
-  (do ((i 300. (1- i)))
-      ((= (the fixnum i) 0))
-    (declare (fixnum i))
-    (iterative-div2 l)
-    (iterative-div2 l)
-    (iterative-div2 l)
-    (iterative-div2 l)))
-
-(defun div2-test-2 (l)
-  (do ((i 300. (1- i)))
-      ((= (the fixnum i) 0))
-    (recursive-div2 l)
-    (recursive-div2 l)
-    (recursive-div2 l)
-    (recursive-div2 l)))
-
-(defun time-iterative-div2 ()
-  (time (div2-test-1 div2-l)))
-
-(defun time-recursive-div2 ()
-  (time (div2-test-2 div2-l)))
-
-(proclaim '(start-block fft))
-
-;;; FFT -- This is an FFT benchmark written by Harry Barrow.  It tests a
-;;; variety of floating point operations, including array references.
-
-(defvar re (make-array 1025. :element-type 'single-float :initial-element 0.0))	
-(defvar im (make-array 1025. :element-type 'single-float :initial-element 0.0))
-
-
-;areal = real part 
-;aimag = imaginary part
-(defun fft (areal aimag)
-  (declare (type (simple-array single-float (1025)) areal aimag))
-  (prog ((ar areal)
-	 (ai aimag)
-	 (i 0)
-	 (j 0)
-	 (k 0)
-	 (m 0)
-	 (n 0)
-	 (le 0)
-	 (le1 0)
-	 (ip 0)
-	 (nv2 0)
-	 (ur 0.0)
-	 (ui 0.0)
-	 (wr 0.0)
-	 (wi 0.0)
-	 (tr 0.0)
-	 (ti 0.0))
-    (declare (fixnum i j k m n le le1 ip nv2)
-	     (single-float ur ui wr wi tr ti))
-    (setq n (array-dimension ar 0)
-	  n (1- n)
-	  nv2 (floor n 2)
-	  m 0					;compute m = log(n)
-	  i 1)
- l1 (cond ((< i n)
-	   (setq m (1+ m)
-		 i (+ i i))
-	   (go l1)))
-    (cond ((not (equal n (expt 2 m)))
-	   (princ "error ... array size not a power of two.")
-	   (read)
-	   (return (terpri))))
-    (setq j 1					;interchange elements
-	  i 1)					;in bit-reversed order
- l3 (cond ((< i j)
-	   (setq tr (aref ar j)
-		 ti (aref ai j))
-	   (setf (aref ar j) (aref ar i))
-	   (setf (aref ai j) (aref ai i))
-	   (setf (aref ar i) tr)
-	   (setf (aref ai i) ti)))
-    (setq k nv2)
- l6 (cond ((< k j) 
-	   (setq j (- j k)
-		 k (/ k 2))
-	   (go l6)))
-    (setq j (+ j k)
-	  i (1+ i))
-    (cond ((< i n)
-	   (go l3)))
-    (do ((l 1 (1+ l)))
-	((> l m))			;loop thru stages
-      (declare (fixnum l))
-      (setq le (expt 2 l)
-	    le1 (floor le 2)
-	    ur 1.0
-	    ui 0.0
-	    wr (cos (/ 3.14159265 (float le1)))
-	    wi (sin (/ 3.14159265 (float le1))))
-      (do ((j 1 (1+ j)))
-	  ((> j le1))		;loop thru butterflies
-	(declare (fixnum j))
-	(do ((i j (+ i le)))
-	    ((> i n))		;do a butterfly
-	  (declare (fixnum i))
-	  (setq ip (+ i le1)
-		tr (- (* (aref ar ip) ur)
-		      (* (aref ai ip) ui))
-		ti (+ (* (aref ar ip) ui)
-		      (* (aref ai ip) ur)))
-	  (setf (aref ar ip) (- (aref ar i) tr))
-	  (setf (aref ai ip) (- (aref ai i) ti))
-	  (setf (aref ar i) (+ (aref ar i) tr))
-	  (setf (aref ai i) (+ (aref ai i) ti))))
-	(setq tr (- (* ur wr) (* ui wi))
-	      ti (+ (* ur wi) (* ui wr))
-	      ur tr
-	      ui ti))
-    (return t)))
-
-(defmacro fft-bench ()
-  '(do ((ntimes 0 (1+ ntimes)))
-      ((= ntimes 10.))
-     (declare (fixnum ntimes))
-     (fft re im)))
-
-(defun time-fft ()
-  (time (fft-bench)))
-
-
-(proclaim '(end-block))
-;;; FPRINT -- Benchmark to print to a file.
-
-(defvar test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67 
-			      mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12 
-			      wxyzab23 xyzabc34 123456ab 234567bc 345678cd 
-			      456789de 567890ef 678901fg 789012gh 890123hi))
-
-(defun fprint-init-aux (m n atoms)
-  (declare (fixnum m n))
-  (cond ((= (the fixnum m) 0) (pop atoms))
-	(t (do ((i n (- i 2))
-		(a ()))
-	       ((< i 1) a)
-	     (declare (fixnum i))
-	     (push (pop atoms) a)
-	     (push (fprint-init-aux (1- m) n atoms) a)))))
-
-(defun fprint-init (m n atoms)
-  (let ((atoms (subst () () atoms)))
-    (do ((a atoms (cdr a)))
-	((null (cdr a)) (rplacd a atoms)))
-    (fprint-init-aux m n atoms)))
-
-(defvar test-pattern (fprint-init 6. 6. test-atoms))
-
-(defun fprint ()
-  (let ((stream (open "fprint.tst" :direction :output
-		      :if-exists :supersede)))
-    (print test-pattern stream)
-    (close stream)))
-
-(defun time-fprint ()
-  (time (fprint)))
-
-;;; FREAD -- Benchmark to read from a file.
-;;; Pronounced "FRED".  Requires the existance of FPRINT.TST which is created
-;;; by FPRINT.
-
-(defun fread ()
-  (let ((stream (open "fprint.tst" :direction :input)))
-    (read stream)
-    (close stream)))
-
-(defun time-fread ()
-  (time (fread)))
-
-(proclaim '(start-block pexptsq))
-
-;;; FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic.
-;;; Originally writen in Franz Lisp by Richard Fateman.
-;;; PDIFFER1 appears in the code, but is not defined; is not called for in this
-;;; test, however.
-
-(defvar *frpoly-v*)
-(defvar *x*)
-(defvar *alpha*)
-(defvar *a*)
-(defvar *b*)
-(defvar *chk)
-(defvar *l)
-(defvar *p)
-(defvar q*)
-(defvar u*)
-(defvar *var)
-(defvar *y*)
-(defvar frpoly-r)
-(defvar frpoly-r2)
-(defvar frpoly-r3)
-
-(defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order)))
-(defmacro pcoefp (e) `(atom ,e))
-
-(defmacro pzerop (x) 
-  `(if (numberp ,x) 					; no signp in CL
-       (zerop ,x)))
-(defmacro pzero () 0)
-(defmacro cplus (x y) `(+ ,x ,y))
-(defmacro ctimes (x y) `(* ,x ,y))
-
-(defun pcoefadd (e c x) 
-  (if (pzerop c)
-      x
-      (cons e (cons c x))))
-
-(defun pcplus (c p)
-  (if (pcoefp p)
-      (cplus p c)
-      (psimp (car p) (pcplus1 c (cdr p)))))
-
-(defun pcplus1 (c x)
-  (cond ((null x)
-	 (if (pzerop c)
-	     nil
-	     (cons 0 (cons c nil))))
-	((pzerop (car x))
-	 (pcoefadd 0 (pplus c (cadr x)) nil))
-	(t
-	 (cons (car x) (cons (cadr x) (pcplus1 c (cddr x)))))))
-
-(defun pctimes (c p) 
-  (if (pcoefp p)
-      (ctimes c p)
-      (psimp (car p) (pctimes1 c (cdr p)))))
-
-(defun pctimes1 (c x)
-  (if (null x)
-      nil
-      (pcoefadd (car x)
-		(ptimes c (cadr x))
-		(pctimes1 c (cddr x)))))
-
-(defun pplus (x y) 
-  (cond ((pcoefp x)
-	 (pcplus x y))
-	((pcoefp y)
-	 (pcplus y x))
-	((eq (car x) (car y))
-	 (psimp (car x) (pplus1 (cdr y) (cdr x))))
-	((pointergp (car x) (car y))
-	 (psimp (car x) (pcplus1 y (cdr x))))
-	(t
-	 (psimp (car y) (pcplus1 x (cdr y))))))
-
-(defun pplus1 (x y)
-  (cond ((null x) y)
-	((null y) x)
-	((= (car x) (car y))
-	 (pcoefadd (car x)
-		   (pplus (cadr x) (cadr y))
-		   (pplus1 (cddr x) (cddr y))))
-	((> (car x) (car y))
-	 (cons (car x) (cons (cadr x) (pplus1 (cddr x) y))))
-	(t (cons (car y) (cons (cadr y) (pplus1 x (cddr y)))))))
-
-(defun psimp (var x)
-  (cond ((null x) 0)
-	((atom x) x)
-	((zerop (car x))
-	 (cadr x))
-	(t
-	 (cons var x))))
-
-(defun ptimes (x y) 
-  (cond ((or (pzerop x) (pzerop y))
-	 (pzero))
-	((pcoefp x)
-	 (pctimes x y))
-	((pcoefp y)
-	 (pctimes y x))
-	((eq (car x) (car y))
-	 (psimp (car x) (ptimes1 (cdr x) (cdr y))))
-	((pointergp (car x) (car y))
-	 (psimp (car x) (pctimes1 y (cdr x))))
-	(t
-	 (psimp (car y) (pctimes1 x (cdr y))))))
-
-(defun ptimes1 (*x* y) 
-  (prog (u* *frpoly-v*)
-	(setq *frpoly-v* (setq u* (ptimes2 y)))
-     a  
-	(setq *x* (cddr *x*))
-	(if (null *x*)
-	    (return u*))
-	(ptimes3 y)
-	(go a)))
-
-(defun ptimes2 (y)
-  (if (null y)
-      nil
-      (pcoefadd (+ (car *x*) (car y))
-		(ptimes (cadr *x*) (cadr y))
-		(ptimes2 (cddr y)))))
-
-(defun ptimes3 (y) 
-  (prog (e u c) 
-     a1	(if (null y) 
-	    (return nil))
-	(setq e (+ (car *x*) (car y))
-	      c (ptimes (cadr y) (cadr *x*) ))
-	(cond ((pzerop c)
-	       (setq y (cddr y)) 
-	       (go a1))
-	      ((or (null *frpoly-v*) (> e (car *frpoly-v*)))
-	       (setq u* (setq *frpoly-v* (pplus1 u* (list e c))))
-	       (setq y (cddr y))
-	       (go a1))
-	      ((= e (car *frpoly-v*))
-	       (setq c (pplus c (cadr *frpoly-v*)))
-	       (if (pzerop c) 			; never true, evidently
-		   (setq u* (setq *frpoly-v* (pdiffer1 u* (list (car *frpoly-v*) (cadr *frpoly-v*)))))
-		   (rplaca (cdr *frpoly-v*) c))
-	       (setq y (cddr y))
-	       (go a1)))
-     a  (cond ((and (cddr *frpoly-v*) (> (caddr *frpoly-v*) e))
-	       (setq *frpoly-v* (cddr *frpoly-v*))
-	       (go a)))
-	(setq u (cdr *frpoly-v*))
-     b  (if (or (null (cdr u)) (< (cadr u) e))
-	    (rplacd u (cons e (cons c (cdr u)))) (go e))
-	(cond ((pzerop (setq c (pplus (caddr u) c)))
-	       (rplacd u (cdddr u))
-	       (go d))
-	      (t
-	       (rplaca (cddr u) c)))
-     e  (setq u (cddr u))
-     d  (setq y (cddr y))
-	(if (null y)
-	    (return nil))
-	(setq e (+ (car *x*) (car y))
-	      c (ptimes (cadr y) (cadr *x*)))
-     c  (cond ((and (cdr u) (> (cadr u) e))
-	       (setq u (cddr u))
-	       (go c)))
-	(go b))) 
-
-(defun pexptsq (p n)
-  (do ((n (floor n 2) (floor n 2))
-       (s (if (oddp n) p 1)))
-      ((zerop n) s)
-    (setq p (ptimes p p))
-    (and (oddp n) (setq s (ptimes s p)))))
-
-(eval-when (load eval)
-  (setf (get 'x 'order) 1)
-  (setf (get 'y 'order) 2)
-  (setf (get 'z 'order) 3)
-  (defparameter frpoly-r
-    (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1)))) ; r= x+y+z+1)
-  (defparameter frpoly-r2 (ptimes frpoly-r 100000)) ; r2 = 100000*r
-  (defparameter frpoly-r3 (ptimes frpoly-r 1.0))) ; r3 = r with floating point coefficients	
-
-(defun time-frpoly-fixnum ()
-  (time (dolist (exp '(2 5 10 15))
-	  (pexptsq frpoly-r exp))))
-
-(defun time-frpoly-bignum ()
-  (time (dolist (exp '(2 5 10 15))
-	  (pexptsq frpoly-r2 exp))))
-
-(defun time-frpoly-float ()
-  (time (dolist (exp '(2 5 10 15))
-	  (pexptsq frpoly-r3 exp))))
-
-
-(proclaim '(start-block puzzle))
-
-;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
-
-(eval-when (compile load eval)
-(defconstant size 511)	
-(defconstant classmax 3)
-(defconstant typemax 12)
-);
-
-(defvar iii 0)
-(defvar kount 0)
-(defconstant dee 8)
-
-(proclaim '(type fixnum size classmax typemax iii kount dee))
-
-(deftype class-vector () `(simple-vector ,(1+ classmax)))
-(deftype type-vector () `(simple-vector ,(1+ typemax)))
-(deftype size-vector () `(simple-vector ,(1+ size)))
-(deftype p-array () `(simple-array t (,(1+ typemax) ,(1+ size))))
-
-(defvar piececount (make-array (1+ classmax) :initial-element 0))
-(defvar class (make-array (1+ typemax) :initial-element 0))
-(defvar piecemax (make-array (1+ typemax) :initial-element 0))
-(defvar puzzle (make-array (1+ size)))
-(defvar puzzle-p (make-array (list (1+ typemax) (1+ size))))
-
-(proclaim '(type type-vector class piecemax))
-(proclaim '(type class-vector piececount))
-(proclaim '(type size-vector puzzle))
-(proclaim '(type p-array puzzle-p))
-
-(defun fit (i j)
-  (declare (fixnum i j))
-  (let ((end (svref piecemax i)))
-    (declare (fixnum end))
-    (do ((k 0 (1+ k)))
-	((> k end) t)
-      (declare (fixnum k))
-      (cond ((aref puzzle-p i k)
-	     (cond ((svref puzzle (+ j k))
-		    (return nil))))))))
-
-(defun place (i j)
-  (declare (fixnum i j))
-  (let ((end (svref piecemax i)))
-    (declare (fixnum end))
-    (do ((k 0 (1+ k)))
-	((> k end))
-      (declare (fixnum k))
-      (cond ((aref puzzle-p i k) 
-	     (setf (svref puzzle (+ j k)) t))))
-    (setf (svref piececount (svref class i))
-	  (the fixnum (- (the fixnum (svref piececount (svref class i))) 1)))
-    (do ((k j (1+ k)))
-	((> k size)
-;	 (terpri)
-;	 (princ "Puzzle filled")
-	 0)
-      (declare (fixnum k))
-      (cond ((not (svref puzzle k))
-	     (return k))))))
-
-(defun puzzle-remove (i j)
-  (declare (fixnum i j))
-  (let ((end (svref piecemax i)))
-    (declare (fixnum end))
-    (do ((k 0 (1+ k)))
-	((> k end))
-      (declare (fixnum k))
-      (cond ((aref puzzle-p i k)
-	     (setf (svref puzzle (+ j k))  nil))))
-      (setf (svref piececount (svref class i))
-	    (the fixnum (+ (the fixnum (svref piececount (svref class i)))
-			   1)))))
-
-(defun trial (j)
-  (declare (fixnum j))
-  (let ((k 0))
-    (declare (fixnum k))
-    (do ((i 0 (1+ i)))
-	((> i typemax)
-	 (setq kount (the fixnum (1+ (the fixnum kount))))
-	 nil)
-      (declare (fixnum i))
-      (cond ((not (eql (svref piececount (svref class i)) 0))
-	     (cond ((fit i j)
-		    (setq k (place i j))
-		    (cond ((or (trial k)
-			       (= k 0))
-;			   (format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1))
-			   (setq kount (the fixnum (1+ (the fixnum kount))))
-			   (return t))
-			  (t (puzzle-remove i j))))))))))
-
-(defun definepiece (iclass ii jj kk)
-  (declare (fixnum ii jj kk))
-  (let ((index 0))
-    (declare (fixnum index))
-    (do ((i 0 (1+ i)))
-	((> i ii))
-      (declare (fixnum i))
-      (do ((j 0 (1+ j)))
-	  ((> j jj))
-	(declare (fixnum j))
-	(do ((k 0 (1+ k)))
-	    ((> k kk))
-	  (declare (fixnum k))
-	  (setq index  (+ i (the fixnum
-				 (* dee (the fixnum
-					     (+ j (the fixnum (* dee k))))))))
-	  (setf (aref puzzle-p iii index)  t))))
-    (setf (svref class iii) iclass)
-    (setf (svref piecemax iii) index) 
-    (cond ((not (= iii typemax))
-	   (setq iii (+ iii 1))))))
-
-(defun puzzle ()
-  (do ((m 0 (1+ m)))
-      ((> m size))
-    (declare (fixnum m))
-    (setf (svref puzzle m) t))
-  (do ((i 1 (1+ i)))
-      ((> i 5))
-    (declare (fixnum i))
-    (do ((j 1 (1+ j)))
-	((> j 5))
-      (declare (fixnum j))
-      (do ((k 1 (1+ k)))
-	  ((> k 5))
-	(declare (fixnum k))
-	(setf (svref puzzle
-		     (+ i
-			(the fixnum
-			     (* dee (the fixnum
-					 (+ j (the fixnum (* dee k))))))))
-	      nil))))
-  (do ((i 0 (1+ i)))
-      ((> i typemax))
-    (declare (fixnum i))
-    (do ((m 0 (1+ m)))
-	((> m size))
-      (declare (fixnum m))
-      (setf (aref puzzle-p i m)  nil)))
-  (setq iii 0)
-  (definePiece 0 3 1 0)
-  (definePiece 0 1 0 3)
-  (definePiece 0 0 3 1)
-  (definePiece 0 1 3 0)
-  (definePiece 0 3 0 1)
-  (definePiece 0 0 1 3)
-  
-  (definePiece 1 2 0 0)
-  (definePiece 1 0 2 0)
-  (definePiece 1 0 0 2)
-  
-  (definePiece 2 1 1 0)
-  (definePiece 2 1 0 1)
-  (definePiece 2 0 1 1)
-  
-  (definePiece 3 1 1 1)
-  
-  (setf (svref pieceCount 0) 13.)
-  (setf (svref pieceCount 1) 3)
-  (setf (svref pieceCount 2) 1)
-  (setf (svref pieceCount 3) 1)
-  (let ((m (+ 1 (the fixnum (* dee (the fixnum (+ 1 dee))))))
-	(n 0)
-	(kount 0))
-    (declare (fixnum m n kount))
-    (cond ((fit 0 m) (setq n (place 0 m)))
-	  (t (format t "~%Error.")))
-    (cond ((trial n) 
-	   (format t "~%Success in ~4D trials." kount))
-	  (t (format t "~%Failure.")))))
-
-(defun time-puzzle ()
-  (time (puzzle)))
-
-(proclaim '(start-block tak trtak))
-
-;;; TAK -- A vanilla version of the TAKeuchi function and one with tail recursion
-;;; removed.
-
-(defun tak (x y z)
-  (declare (fixnum x y z))
-  (if (not (< y x))
-      z
-      (tak (tak (the fixnum (1- x)) y z)
-	   (tak (the fixnum (1- y)) z x)
-	   (tak (the fixnum (1- z)) x y))))
-
-(defun trtak (x y z)
-  (declare (fixnum x y z))
-  (prog ()
-    tak
-    (if (not (< y x))
-	(return z)
-	(let ((a (tak (1- x) y z))
-	      (b (tak (1- y) z x)))
-	  (setq z (tak (1- z) x y)
-		x a
-		y b)
-	  (go tak)))))
-
-(defun time-tak ()
-  (format t "Note: 10 iterations.~%")
-  (time (dotimes (i 10) (tak 18 12 6))))
-
-(defun time-rtak ()
-  (format t "Note: 10 iterations.~%")
-  (time (dotimes (i 10) (trtak 18 12 6))))
-
-(proclaim '(start-block mas))
-
-;;; TAKL -- The TAKeuchi function using lists as counters.
-
-(defun listn (n)
-  (if (not (= 0 (the fixnum n)))
-      (cons n (listn (1- n)))))
-
-(defvar l18 (listn 18.))
-(defvar l12 (listn 12.))
-(defvar  l6 (listn 6.))
-
-(defun mas (x y z)
-  (declare (list x y z))
-  (if (not (shorterp y x))
-      z
-      (mas (mas (cdr x)
-		 y z)
-	    (mas (cdr y)
-		 z x)
-	    (mas (cdr z)
-		 x y))))
-
-(defun shorterp (x y)
-  (declare (list x y))
-  (and y (or (null x)
-	     (shorterp (cdr x)
-		       (cdr y)))))
-
-(defun time-takl ()
-  (format t "Note: 10 iterations.~%")
-  (time (dotimes (i 10) (mas l18 l12 l6))))
-
-#|
-;;; TAKR  -- 100 function (count `em) version of TAK that tries to defeat cache
-;;; memory effects.  Results should be the same as for TAK on stack machines.
-;;; Distribution of calls is not completely flat.
-
-(defun tak0 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak1 (tak37 (the fixnum (1- x)) y z)
-		 (tak11 (the fixnum (1- y)) z x)
-		 (tak17 (the fixnum (1- z)) x y)))))
-(defun tak1 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak2 (tak74 (the fixnum (1- x)) y z)
-		 (tak22 (the fixnum (1- y)) z x)
-		 (tak34 (the fixnum (1- z)) x y)))))
-(defun tak2 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak3 (tak11 (the fixnum (1- x)) y z)
-		 (tak33 (the fixnum (1- y)) z x)
-		 (tak51 (the fixnum (1- z)) x y)))))
-(defun tak3 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak4 (tak48 (the fixnum (1- x)) y z)
-		 (tak44 (the fixnum (1- y)) z x)
-		 (tak68 (the fixnum (1- z)) x y)))))
-(defun tak4 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak5 (tak85 (the fixnum (1- x)) y z)
-		 (tak55 (the fixnum (1- y)) z x)
-		 (tak85 (the fixnum (1- z)) x y)))))
-(defun tak5 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak6 (tak22 (the fixnum (1- x)) y z)
-		 (tak66 (the fixnum (1- y)) z x)
-		 (tak2 (the fixnum (1- z)) x y)))))
-(defun tak6 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak7 (tak59 (the fixnum (1- x)) y z)
-		 (tak77 (the fixnum (1- y)) z x)
-		 (tak19 (the fixnum (1- z)) x y)))))
-(defun tak7 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak8 (tak96 (the fixnum (1- x)) y z)
-		 (tak88 (the fixnum (1- y)) z x)
-		 (tak36 (the fixnum (1- z)) x y)))))
-(defun tak8 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak9 (tak33 (the fixnum (1- x)) y z)
-		 (tak99 (the fixnum (1- y)) z x)
-		 (tak53 (the fixnum (1- z)) x y)))))
-(defun tak9 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak10 (tak70 (the fixnum (1- x)) y z)
-		  (tak10 (the fixnum (1- y)) z x)
-		  (tak70 (the fixnum (1- z)) x y)))))
-(defun tak10 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak11 (tak7 (the fixnum (1- x)) y z)
-		  (tak21 (the fixnum (1- y)) z x)
-		  (tak87 (the fixnum (1- z)) x y)))))
-(defun tak11 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak12 (tak44 (the fixnum (1- x)) y z)
-		  (tak32 (the fixnum (1- y)) z x)
-		  (tak4 (the fixnum (1- z)) x y)))))
-(defun tak12 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak13 (tak81 (the fixnum (1- x)) y z)
-		  (tak43 (the fixnum (1- y)) z x)
-		  (tak21 (the fixnum (1- z)) x y)))))
-(defun tak13 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak14 (tak18 (the fixnum (1- x)) y z)
-		  (tak54 (the fixnum (1- y)) z x)
-		  (tak38 (the fixnum (1- z)) x y)))))
-(defun tak14 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak15 (tak55 (the fixnum (1- x)) y z)
-		  (tak65 (the fixnum (1- y)) z x)
-		  (tak55 (the fixnum (1- z)) x y)))))
-(defun tak15 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak16 (tak92 (the fixnum (1- x)) y z)
-		  (tak76 (the fixnum (1- y)) z x)
-		  (tak72 (the fixnum (1- z)) x y)))))
-(defun tak16 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak17 (tak29 (the fixnum (1- x)) y z)
-		  (tak87 (the fixnum (1- y)) z x)
-		  (tak89 (the fixnum (1- z)) x y)))))
-(defun tak17 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak18 (tak66 (the fixnum (1- x)) y z)
-		  (tak98 (the fixnum (1- y)) z x)
-		  (tak6 (the fixnum (1- z)) x y)))))
-(defun tak18 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak19 (tak3 (the fixnum (1- x)) y z)
-		  (tak9 (the fixnum (1- y)) z x)
-		  (tak23 (the fixnum (1- z)) x y)))))
-(defun tak19 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak20 (tak40 (the fixnum (1- x)) y z)
-		  (tak20 (the fixnum (1- y)) z x)
-		  (tak40 (the fixnum (1- z)) x y)))))
-(defun tak20 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak21 (tak77 (the fixnum (1- x)) y z)
-		  (tak31 (the fixnum (1- y)) z x)
-		  (tak57 (the fixnum (1- z)) x y)))))
-(defun tak21 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak22 (tak14 (the fixnum (1- x)) y z)
-		  (tak42 (the fixnum (1- y)) z x)
-		  (tak74 (the fixnum (1- z)) x y)))))
-(defun tak22 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak23 (tak51 (the fixnum (1- x)) y z)
-		  (tak53 (the fixnum (1- y)) z x)
-		  (tak91 (the fixnum (1- z)) x y)))))
-(defun tak23 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak24 (tak88 (the fixnum (1- x)) y z)
-		  (tak64 (the fixnum (1- y)) z x)
-		  (tak8 (the fixnum (1- z)) x y)))))
-(defun tak24 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak25 (tak25 (the fixnum (1- x)) y z)
-		  (tak75 (the fixnum (1- y)) z x)
-		  (tak25 (the fixnum (1- z)) x y)))))
-(defun tak25 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak26 (tak62 (the fixnum (1- x)) y z)
-		  (tak86 (the fixnum (1- y)) z x)
-		  (tak42 (the fixnum (1- z)) x y)))))
-(defun tak26 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak27 (tak99 (the fixnum (1- x)) y z)
-		  (tak97 (the fixnum (1- y)) z x)
-		  (tak59 (the fixnum (1- z)) x y)))))
-(defun tak27 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak28 (tak36 (the fixnum (1- x)) y z)
-		  (tak8 (the fixnum (1- y)) z x)
-		  (tak76 (the fixnum (1- z)) x y)))))
-(defun tak28 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak29 (tak73 (the fixnum (1- x)) y z)
-		  (tak19 (the fixnum (1- y)) z x)
-		  (tak93 (the fixnum (1- z)) x y)))))
-(defun tak29 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak30 (tak10 (the fixnum (1- x)) y z)
-		  (tak30 (the fixnum (1- y)) z x)
-		  (tak10 (the fixnum (1- z)) x y)))))
-(defun tak30 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak31 (tak47 (the fixnum (1- x)) y z)
-		  (tak41 (the fixnum (1- y)) z x)
-		  (tak27 (the fixnum (1- z)) x y)))))
-(defun tak31 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak32 (tak84 (the fixnum (1- x)) y z)
-		  (tak52 (the fixnum (1- y)) z x)
-		  (tak44 (the fixnum (1- z)) x y)))))
-(defun tak32 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak33 (tak21 (the fixnum (1- x)) y z)
-		  (tak63 (the fixnum (1- y)) z x)
-		  (tak61 (the fixnum (1- z)) x y)))))
-(defun tak33 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak34 (tak58 (the fixnum (1- x)) y z)
-		  (tak74 (the fixnum (1- y)) z x)
-		  (tak78 (the fixnum (1- z)) x y)))))
-(defun tak34 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak35 (tak95 (the fixnum (1- x)) y z)
-		  (tak85 (the fixnum (1- y)) z x)
-		  (tak95 (the fixnum (1- z)) x y)))))
-(defun tak35 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak36 (tak32 (the fixnum (1- x)) y z)
-		  (tak96 (the fixnum (1- y)) z x)
-		  (tak12 (the fixnum (1- z)) x y)))))
-(defun tak36 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak37 (tak69 (the fixnum (1- x)) y z)
-		  (tak7 (the fixnum (1- y)) z x)
-		  (tak29 (the fixnum (1- z)) x y)))))
-(defun tak37 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak38 (tak6 (the fixnum (1- x)) y z)
-		  (tak18 (the fixnum (1- y)) z x)
-		  (tak46 (the fixnum (1- z)) x y)))))
-(defun tak38 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak39 (tak43 (the fixnum (1- x)) y z)
-		  (tak29 (the fixnum (1- y)) z x)
-		  (tak63 (the fixnum (1- z)) x y)))))
-(defun tak39 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak40 (tak80 (the fixnum (1- x)) y z)
-		  (tak40 (the fixnum (1- y)) z x)
-		  (tak80 (the fixnum (1- z)) x y)))))
-(defun tak40 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak41 (tak17 (the fixnum (1- x)) y z)
-		  (tak51 (the fixnum (1- y)) z x)
-		  (tak97 (the fixnum (1- z)) x y)))))
-(defun tak41 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak42 (tak54 (the fixnum (1- x)) y z)
-		  (tak62 (the fixnum (1- y)) z x)
-		  (tak14 (the fixnum (1- z)) x y)))))
-(defun tak42 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak43 (tak91 (the fixnum (1- x)) y z)
-		  (tak73 (the fixnum (1- y)) z x)
-		  (tak31 (the fixnum (1- z)) x y)))))
-(defun tak43 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak44 (tak28 (the fixnum (1- x)) y z)
-		  (tak84 (the fixnum (1- y)) z x)
-		  (tak48 (the fixnum (1- z)) x y)))))
-(defun tak44 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak45 (tak65 (the fixnum (1- x)) y z)
-		  (tak95 (the fixnum (1- y)) z x)
-		  (tak65 (the fixnum (1- z)) x y)))))
-(defun tak45 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak46 (tak2 (the fixnum (1- x)) y z)
-		  (tak6 (the fixnum (1- y)) z x)
-		  (tak82 (the fixnum (1- z)) x y)))))
-(defun tak46 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak47 (tak39 (the fixnum (1- x)) y z)
-		  (tak17 (the fixnum (1- y)) z x)
-		  (tak99 (the fixnum (1- z)) x y)))))
-(defun tak47 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak48 (tak76 (the fixnum (1- x)) y z)
-		  (tak28 (the fixnum (1- y)) z x)
-		  (tak16 (the fixnum (1- z)) x y)))))
-(defun tak48 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak49 (tak13 (the fixnum (1- x)) y z)
-		  (tak39 (the fixnum (1- y)) z x)
-		  (tak33 (the fixnum (1- z)) x y)))))
-(defun tak49 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak50 (tak50 (the fixnum (1- x)) y z)
-		  (tak50 (the fixnum (1- y)) z x)
-		  (tak50 (the fixnum (1- z)) x y)))))
-(defun tak50 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak51 (tak87 (the fixnum (1- x)) y z)
-		  (tak61 (the fixnum (1- y)) z x)
-		  (tak67 (the fixnum (1- z)) x y)))))
-(defun tak51 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak52 (tak24 (the fixnum (1- x)) y z)
-		  (tak72 (the fixnum (1- y)) z x)
-		  (tak84 (the fixnum (1- z)) x y)))))
-(defun tak52 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak53 (tak61 (the fixnum (1- x)) y z)
-		  (tak83 (the fixnum (1- y)) z x)
-		  (tak1 (the fixnum (1- z)) x y)))))
-(defun tak53 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak54 (tak98 (the fixnum (1- x)) y z)
-		  (tak94 (the fixnum (1- y)) z x)
-		  (tak18 (the fixnum (1- z)) x y)))))
-(defun tak54 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak55 (tak35 (the fixnum (1- x)) y z)
-		  (tak5 (the fixnum (1- y)) z x)
-		  (tak35 (the fixnum (1- z)) x y)))))
-(defun tak55 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak56 (tak72 (the fixnum (1- x)) y z)
-		  (tak16 (the fixnum (1- y)) z x)
-		  (tak52 (the fixnum (1- z)) x y)))))
-(defun tak56 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak57 (tak9 (the fixnum (1- x)) y z)
-		  (tak27 (the fixnum (1- y)) z x)
-		  (tak69 (the fixnum (1- z)) x y)))))
-(defun tak57 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak58 (tak46 (the fixnum (1- x)) y z)
-		  (tak38 (the fixnum (1- y)) z x)
-		  (tak86 (the fixnum (1- z)) x y)))))
-(defun tak58 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak59 (tak83 (the fixnum (1- x)) y z)
-		  (tak49 (the fixnum (1- y)) z x)
-		  (tak3 (the fixnum (1- z)) x y)))))
-(defun tak59 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak60 (tak20 (the fixnum (1- x)) y z)
-		  (tak60 (the fixnum (1- y)) z x)
-		  (tak20 (the fixnum (1- z)) x y)))))
-(defun tak60 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak61 (tak57 (the fixnum (1- x)) y z)
-		  (tak71 (the fixnum (1- y)) z x)
-		  (tak37 (the fixnum (1- z)) x y)))))
-(defun tak61 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak62 (tak94 (the fixnum (1- x)) y z)
-		  (tak82 (the fixnum (1- y)) z x)
-		  (tak54 (the fixnum (1- z)) x y)))))
-(defun tak62 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak63 (tak31 (the fixnum (1- x)) y z)
-		  (tak93 (the fixnum (1- y)) z x)
-		  (tak71 (the fixnum (1- z)) x y)))))
-(defun tak63 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak64 (tak68 (the fixnum (1- x)) y z)
-		  (tak4 (the fixnum (1- y)) z x)
-		  (tak88 (the fixnum (1- z)) x y)))))
-(defun tak64 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak65 (tak5 (the fixnum (1- x)) y z)
-		  (tak15 (the fixnum (1- y)) z x)
-		  (tak5 (the fixnum (1- z)) x y)))))
-(defun tak65 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak66 (tak42 (the fixnum (1- x)) y z)
-		  (tak26 (the fixnum (1- y)) z x)
-		  (tak22 (the fixnum (1- z)) x y)))))
-(defun tak66 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak67 (tak79 (the fixnum (1- x)) y z)
-		  (tak37 (the fixnum (1- y)) z x)
-		  (tak39 (the fixnum (1- z)) x y)))))
-(defun tak67 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak68 (tak16 (the fixnum (1- x)) y z)
-		  (tak48 (the fixnum (1- y)) z x)
-		  (tak56 (the fixnum (1- z)) x y)))))
-(defun tak68 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak69 (tak53 (the fixnum (1- x)) y z)
-		  (tak59 (the fixnum (1- y)) z x)
-		  (tak73 (the fixnum (1- z)) x y)))))
-(defun tak69 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak70 (tak90 (the fixnum (1- x)) y z)
-		  (tak70 (the fixnum (1- y)) z x)
-		  (tak90 (the fixnum (1- z)) x y)))))
-(defun tak70 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak71 (tak27 (the fixnum (1- x)) y z)
-		  (tak81 (the fixnum (1- y)) z x)
-		  (tak7 (the fixnum (1- z)) x y)))))
-(defun tak71 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak72 (tak64 (the fixnum (1- x)) y z)
-		  (tak92 (the fixnum (1- y)) z x)
-		  (tak24 (the fixnum (1- z)) x y)))))
-(defun tak72 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak73 (tak1 (the fixnum (1- x)) y z)
-		  (tak3 (the fixnum (1- y)) z x)
-		  (tak41 (the fixnum (1- z)) x y)))))
-(defun tak73 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak74 (tak38 (the fixnum (1- x)) y z)
-		  (tak14 (the fixnum (1- y)) z x)
-		  (tak58 (the fixnum (1- z)) x y)))))
-(defun tak74 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak75 (tak75 (the fixnum (1- x)) y z)
-		  (tak25 (the fixnum (1- y)) z x)
-		  (tak75 (the fixnum (1- z)) x y)))))
-(defun tak75 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak76 (tak12 (the fixnum (1- x)) y z)
-		  (tak36 (the fixnum (1- y)) z x)
-		  (tak92 (the fixnum (1- z)) x y)))))
-(defun tak76 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak77 (tak49 (the fixnum (1- x)) y z)
-		  (tak47 (the fixnum (1- y)) z x)
-		  (tak9 (the fixnum (1- z)) x y)))))
-(defun tak77 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak78 (tak86 (the fixnum (1- x)) y z)
-		  (tak58 (the fixnum (1- y)) z x)
-		  (tak26 (the fixnum (1- z)) x y)))))
-(defun tak78 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak79 (tak23 (the fixnum (1- x)) y z)
-		  (tak69 (the fixnum (1- y)) z x)
-		  (tak43 (the fixnum (1- z)) x y)))))
-(defun tak79 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak80 (tak60 (the fixnum (1- x)) y z)
-		  (tak80 (the fixnum (1- y)) z x)
-		  (tak60 (the fixnum (1- z)) x y)))))
-(defun tak80 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak81 (tak97 (the fixnum (1- x)) y z)
-		  (tak91 (the fixnum (1- y)) z x)
-		  (tak77 (the fixnum (1- z)) x y)))))
-(defun tak81 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak82 (tak34 (the fixnum (1- x)) y z)
-		  (tak2 (the fixnum (1- y)) z x)
-		  (tak94 (the fixnum (1- z)) x y)))))
-(defun tak82 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak83 (tak71 (the fixnum (1- x)) y z)
-		  (tak13 (the fixnum (1- y)) z x)
-		  (tak11 (the fixnum (1- z)) x y)))))
-(defun tak83 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak84 (tak8 (the fixnum (1- x)) y z)
-		  (tak24 (the fixnum (1- y)) z x)
-		  (tak28 (the fixnum (1- z)) x y)))))
-(defun tak84 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak85 (tak45 (the fixnum (1- x)) y z)
-		  (tak35 (the fixnum (1- y)) z x)
-		  (tak45 (the fixnum (1- z)) x y)))))
-(defun tak85 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak86 (tak82 (the fixnum (1- x)) y z)
-		  (tak46 (the fixnum (1- y)) z x)
-		  (tak62 (the fixnum (1- z)) x y)))))
-(defun tak86 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak87 (tak19 (the fixnum (1- x)) y z)
-		  (tak57 (the fixnum (1- y)) z x)
-		  (tak79 (the fixnum (1- z)) x y)))))
-(defun tak87 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak88 (tak56 (the fixnum (1- x)) y z)
-		  (tak68 (the fixnum (1- y)) z x)
-		  (tak96 (the fixnum (1- z)) x y)))))
-(defun tak88 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak89 (tak93 (the fixnum (1- x)) y z)
-		  (tak79 (the fixnum (1- y)) z x)
-		  (tak13 (the fixnum (1- z)) x y)))))
-(defun tak89 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak90 (tak30 (the fixnum (1- x)) y z)
-		  (tak90 (the fixnum (1- y)) z x)
-		  (tak30 (the fixnum (1- z)) x y)))))
-(defun tak90 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak91 (tak67 (the fixnum (1- x)) y z)
-		  (tak1 (the fixnum (1- y)) z x)
-		  (tak47 (the fixnum (1- z)) x y)))))
-(defun tak91 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak92 (tak4 (the fixnum (1- x)) y z)
-		  (tak12 (the fixnum (1- y)) z x)
-		  (tak64 (the fixnum (1- z)) x y)))))
-(defun tak92 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak93 (tak41 (the fixnum (1- x)) y z)
-		  (tak23 (the fixnum (1- y)) z x)
-		  (tak81 (the fixnum (1- z)) x y)))))
-(defun tak93 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak94 (tak78 (the fixnum (1- x)) y z)
-		  (tak34 (the fixnum (1- y)) z x)
-		  (tak98 (the fixnum (1- z)) x y)))))
-(defun tak94 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak95 (tak15 (the fixnum (1- x)) y z)
-		  (tak45 (the fixnum (1- y)) z x)
-		  (tak15 (the fixnum (1- z)) x y)))))
-(defun tak95 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak96 (tak52 (the fixnum (1- x)) y z)
-		  (tak56 (the fixnum (1- y)) z x)
-		  (tak32 (the fixnum (1- z)) x y)))))
-(defun tak96 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak97 (tak89 (the fixnum (1- x)) y z)
-		  (tak67 (the fixnum (1- y)) z x)
-		  (tak49 (the fixnum (1- z)) x y)))))
-(defun tak97 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak98 (tak26 (the fixnum (1- x)) y z)
-		  (tak78 (the fixnum (1- y)) z x)
-		  (tak66 (the fixnum (1- z)) x y)))))
-(defun tak98 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak99 (tak63 (the fixnum (1- x)) y z)
-		  (tak89 (the fixnum (1- y)) z x)
-		  (tak83 (the fixnum (1- z)) x y)))))
-(defun tak99 (x y z) 
-  (declare (fixnum x y z))
-  (cond ((not (< y x)) z)
-	(t (tak0 (tak0 (the fixnum (1- x)) y z)
-		 (tak0 (the fixnum (1- y)) z x)
-		 (tak0 (the fixnum (1- z)) x y)))))
-
-(defun time-takr ()
-  (time (tak0 18 12 6)))
-|#
-
-(proclaim '(start-block stak))
-;;; STAK -- The TAKeuchi function with special variables instead of parameter
-;;; passing.
-
-(defvar stak-x)
-(defvar stak-y)
-(defvar stak-z)
-
-(defun stak (stak-x stak-y stak-z)
-  (stak-aux))
-
-(defun stak-aux ()
-  (if (not (< (the fixnum stak-y) (the fixnum stak-x)))
-      stak-z
-      (let ((stak-x (let ((stak-x (the fixnum (1- (the fixnum stak-x))))
-			  (stak-y stak-y)
-			  (stak-z stak-z))
-		      (stak-aux)))
-	    (stak-y (let ((stak-x (the fixnum (1- (the fixnum stak-y))))
-			  (stak-y stak-z)
-			  (stak-z stak-x))
-		      (stak-aux)))
-	    (stak-z (let ((stak-x (the fixnum (1- (the fixnum stak-z))))
-			  (stak-y stak-x)
-			  (stak-z stak-y))
-		      (stak-aux))))
-	(stak-aux))))
-
-(defun time-stak ()
-  (format t "Note: 10 iterations.~%")
-  (time (dotimes (i 10) (stak 18 12 6))))
-
-(proclaim '(end-block))
-;;; TPRINT -- Benchmark to print and read to the terminal.
-
-(defvar test-atoms '(abc1 cde2 efg3 ghi4 ijk5 klm6 mno7 opq8 qrs9
-			  stu0 uvw1 wxy2 xyz3 123a 234b 345c 456d 
-			  567d 678e 789f 890g))
-
-(defun tprint-init (m n atoms)
-  (let ((atoms (subst () () atoms)))
-    (do ((a atoms (cdr a)))
-	((null (cdr a)) (rplacd a atoms)))
-    (tprint-init-aux m n atoms)))
-
-(defun tprint-init-aux (m n atoms)
-  (declare (fixnum m n))
-  (cond ((= (the fixnum m) 0) (pop atoms))
-	(t (do ((i n (- i 2))
-		(a ()))
-	       ((< i 1) a)
-	     (declare (fixnum i))
-	     (push (pop atoms) a)
-	     (push (tprint-init-aux (1- m) n atoms) a)))))
-
-(defvar test-pattern (tprint-init 6. 6. test-atoms))
-
-(defun time-tprint ()
-  (time (print test-pattern)))
-
-(proclaim '(start-block init-traverse run-traverse))
-
-;;; TRAVERSE --  Benchmark which creates and traverses a tree structure.
-
-(defstruct node
-  (parents ())
-  (sons ())
-  (sn (snb))
-  (entry1 ())
-  (entry2 ())
-  (entry3 ())
-  (entry4 ())
-  (entry5 ())
-  (entry6 ())
-  (mark ()))
-
-(defvar sn 0)
-(defvar rand 21.)
-(defvar count 0)
-(defvar marker nil)
-(defvar root)
-
-(proclaim '(fixnum sn rand count))
-
-(defun snb ()
-  (setq sn (the fixnum (1+ (the fixnum sn)))))
-
-(defun seed ()
-  (setq rand 21.))
-
-(defun traverse-random ()
-  (setq rand (rem (the fixnum (* (the fixnum rand) 17.)) 251.)))
-
-(defun traverse-remove (n q)
-  (cond ((eq (cdr (car q)) (car q))
-	 (prog2 () (caar q) (rplaca q ())))
-	((= (the fixnum n) 0)
-	 (prog2 () (caar q)
-		(do ((p (car q) (cdr p)))
-		    ((eq (cdr p) (car q))
-		     (rplaca q
-			     (rplacd p (cdr (car q))))))))
-	(t (do ((n n (the fixnum (1- n)))
-		(q (car q) (cdr q))
-		(p (cdr (car q)) (cdr p)))
-	       ((= (the fixnum n) 0) (prog2 () (car q) (rplacd q p)))
-	     (declare (fixnum n))))))
-
-(defun traverse-select (n q)
-  (do ((n n (the fixnum (1- n)))
-       (q (car q) (cdr q)))
-      ((= (the fixnum n) 0) (car q))
-    (declare (fixnum n))))
-
-(defun add (a q)
-  (cond ((null q)
-	 `(,(let ((x `(,a)))
-	      (rplacd x x) x)))
-	((null (car q))
-	 (let ((x `(,a)))
-	   (rplacd x x)
-	   (rplaca q x)))
-	(t (rplaca q
-		   (rplacd (car q) `(,a .,(cdr (car q))))))))
-
-(defun create-structure (n)
-  (declare (fixnum n))
-  (let ((a `(,(make-node))))
-    (do ((m (the fixnum (1- n)) (the fixnum (1- m)))
-	 (p a))
-	((= (the fixnum m) 0) (setq a `(,(rplacd p a)))
-	 (do ((unused a)
-	      (used (add (traverse-remove 0 a) ()))
-	      (x) (y))
-	     ((null (car unused))
-	      (find-root (traverse-select 0 used) n))
-	   (setq x (traverse-remove (rem (traverse-random) n) unused))
-	   (setq y (traverse-select (rem (traverse-random) n) used))
-	   (add x used)
-	   (setf (node-sons y) `(,x .,(node-sons y)))
-	   (setf (node-parents x) `(,y .,(node-parents x))) ))
-      (declare (fixnum m))
-      (push (make-node) a))))
-
-(defun find-root (node n)
-  (declare (fixnum n))
-  (do ((n n (the fixnum (1- n))))
-      ((= (the fixnum n) 0) node)
-    (declare (fixnum n))
-    (cond ((null (node-parents node))
-	   (return node))
-	  (t (setq node (car (node-parents node)))))))
-
-(defun travers (node mark)
-  (cond ((eq (node-mark node) mark) ())
-	(t (setf (node-mark node) mark)
-	   (setq count (the fixnum (1+ count)))
-	   (setf (node-entry1 node) (not (node-entry1 node)))
-	   (setf (node-entry2 node) (not (node-entry2 node)))
-	   (setf (node-entry3 node) (not (node-entry3 node)))
-	   (setf (node-entry4 node) (not (node-entry4 node)))
-	   (setf (node-entry5 node) (not (node-entry5 node)))
-	   (setf (node-entry6 node) (not (node-entry6 node)))
-	   (do ((sons (node-sons node) (cdr sons)))
-	       ((null sons) ())
-	     (travers (car sons) mark)))))
-
-(defun traverse (root)
-  (let ((count 0))
-    (travers root (setq marker (not marker)))
-    count))
-
-(defun init-traverse()
-  (prog1 nil (setq root (create-structure 100.))))
-
-(defun run-traverse ()
-  (do ((i 50. (the fixnum (1- i))))
-      ((= (the fixnum i) 0))
-    (declare (fixnum i))
-    (traverse root)
-    (traverse root)
-    (traverse root)
-    (traverse root)
-    (traverse root)))
-
-(defun time-init-traverse ()
-  (time (init-traverse)))
-
-(defun time-run-traverse ()
-  (time (run-traverse)))
-
-(proclaim '(start-block triangle))
-
-;;; TRIANG -- Board game benchmark.  
-
-(defvar board (make-array 16. :initial-element 1))
-(setf (aref board 5) 0)
-
-(defvar triang-sequence (make-array 14. :initial-element 0))
-(defvar triang-a (make-array 37. :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4 7 11 8 12
-						13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 6)))
-(defvar triang-b (make-array 37. :initial-contents  '(2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5
-						 2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 5)))
-(defvar triang-c (make-array 37. :initial-contents  '(4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6
-						 1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4)))
-(defvar answer)
-(defvar final)
-
-(proclaim '(type simple-vector board triang-sequence triang-a triang-b triang-c))
-
-(defun last-position ()
-  (do ((i 1 (1+ i)))
-      ((= i 16.) 0)
-    (declare (fixnum i))
-    (if (= 1 (the fixnum (aref board i)))
-	(return i))))
-
-(defun try (i depth)
-  (declare (fixnum i depth))
-  (cond ((= depth 14) 
-	 (let ((lp (last-position)))
-	   (unless (member lp final)
-	     (push lp final)))
-	 (push (cdr (coerce (the simple-vector triang-sequence) 'list))
-	       answer) t)	; this is a hack to replace LISTARRAY
-	((and (= 1 (the fixnum (aref board (aref triang-a i))))
-	      (= 1 (the fixnum (aref board (aref triang-b i))))
-	      (= 0 (the fixnum (aref board (aref triang-c i)))))
-	 (setf (aref board (aref triang-a i)) 0)
-	 (setf (aref board (aref triang-b i)) 0)
-	 (setf (aref board (aref triang-c i)) 1)
-	 (setf (aref triang-sequence depth) i)
-	 (do ((j 0 (1+ j))
-	      (depth (1+ depth)))
-	     ((or (= j 36.)
-		  (try j depth)) ())
-	   (declare (fixnum j depth)))
-	 (setf (aref board (aref triang-a i)) 1) 
-	 (setf (aref board (aref triang-b i)) 1)
-	 (setf (aref board (aref triang-c i)) 0) ())))
-
-(defun triangle (i)
-  (let ((answer ())
-	(final ()))
-    (try i 1)))
-
-(defun time-triangle ()
-  (time (triangle 22)))
diff --git a/benchmarks/gabriel/ctak.lisp b/benchmarks/gabriel/ctak.lisp
deleted file mode 100644
index de3e6dd8dcae6e43c4044752f4993b40a67b2e31..0000000000000000000000000000000000000000
--- a/benchmarks/gabriel/ctak.lisp
+++ /dev/null
@@ -1,28 +0,0 @@
-(in-package "USER")
-
-;;; CTAK -- A version of the TAKeuchi function that uses the CATCH/THROW facility.
-
-(defun ctak (x y z)
-  (declare (fixnum x y z))
-  (catch 'ctak (ctak-aux x y z)))
-
-(defun ctak-aux (x y z)
-  (declare (fixnum x y z))
-  (cond ((not (< y x))
-	 (throw 'ctak z))
-	(t (ctak-aux
-	     (catch 'ctak
-	       (ctak-aux (the fixnum (1- x))
-			 y
-			 z))
-	     (catch 'ctak
-	       (ctak-aux (the fixnum (1- y))
-			 z
-			 x))
-	     (catch 'ctak
-	       (ctak-aux (the fixnum (1- z))
-			 x
-			 y))))))
-
-(defun time-ctak ()
-  (time (ctak 18 12 6)))
diff --git a/benchmarks/gabriel/fft.lisp b/benchmarks/gabriel/fft.lisp
deleted file mode 100644
index 0d81d5493bd5b95efaea0216906df2c719c26783..0000000000000000000000000000000000000000
--- a/benchmarks/gabriel/fft.lisp
+++ /dev/null
@@ -1,102 +0,0 @@
-(in-package "USER")
-(proclaim '(optimize (safety 0) (speed 3) (space 0)))
-
-;;; FFT -- This is an FFT benchmark written by Harry Barrow.  It tests a
-;;; variety of floating point operations, including array references.
-
-(defvar re (make-array 1025. :element-type 'single-float :initial-element 0.0))	
-(defvar im (make-array 1025. :element-type 'single-float :initial-element 0.0))
-
-
-;areal = real part 
-;aimag = imaginary part
-(defun fft (areal aimag)
-  (declare (type (simple-array single-float (1025)) areal aimag))
-  (prog ((ar areal)
-	 (ai aimag)
-	 (i 0)
-	 (j 0)
-	 (k 0)
-	 (m 0)
-	 (n 0)
-	 (le 0)
-	 (le1 0)
-	 (ip 0)
-	 (nv2 0)
-	 (ur 0.0)
-	 (ui 0.0)
-	 (wr 0.0)
-	 (wi 0.0)
-	 (tr 0.0)
-	 (ti 0.0))
-    (declare (fixnum i j k m n le le1 ip nv2)
-	     (single-float ur ui wr wi tr ti))
-    (setq n (array-dimension ar 0)
-	  n (1- n)
-	  nv2 (floor n 2)
-	  m 0					;compute m = log(n)
-	  i 1)
- l1 (cond ((< i n)
-	   (setq m (1+ m)
-		 i (+ i i))
-	   (go l1)))
-    (cond ((not (equal n (expt 2 m)))
-	   (princ "error ... array size not a power of two.")
-	   (read)
-	   (return (terpri))))
-    (setq j 1					;interchange elements
-	  i 1)					;in bit-reversed order
- l3 (cond ((< i j)
-	   (setq tr (aref ar j)
-		 ti (aref ai j))
-	   (setf (aref ar j) (aref ar i))
-	   (setf (aref ai j) (aref ai i))
-	   (setf (aref ar i) tr)
-	   (setf (aref ai i) ti)))
-    (setq k nv2)
- l6 (cond ((< k j) 
-	   (setq j (- j k)
-		 k (/ k 2))
-	   (go l6)))
-    (setq j (+ j k)
-	  i (1+ i))
-    (cond ((< i n)
-	   (go l3)))
-    (do ((l 1 (1+ l)))
-	((> l m))			;loop thru stages
-      (declare (fixnum l))
-      (setq le (expt 2 l)
-	    le1 (floor le 2)
-	    ur 1.0
-	    ui 0.0
-	    wr (cos (/ 3.14159265 (float le1)))
-	    wi (sin (/ 3.14159265 (float le1))))
-      (do ((j 1 (1+ j)))
-	  ((> j le1))		;loop thru butterflies
-	(declare (fixnum j))
-	(do ((i j (+ i le)))
-	    ((> i n))		;do a butterfly
-	  (declare (fixnum i))
-	  (setq ip (+ i le1)
-		tr (- (* (aref ar ip) ur)
-		      (* (aref ai ip) ui))
-		ti (+ (* (aref ar ip) ui)
-		      (* (aref ai ip) ur)))
-	  (setf (aref ar ip) (- (aref ar i) tr))
-	  (setf (aref ai ip) (- (aref ai i) ti))
-	  (setf (aref ar i) (+ (aref ar i) tr))
-	  (setf (aref ai i) (+ (aref ai i) ti))))
-	(setq tr (- (* ur wr) (* ui wi))
-	      ti (+ (* ur wi) (* ui wr))
-	      ur tr
-	      ui ti))
-    (return t)))
-
-(defmacro fft-bench ()
-  '(do ((ntimes 0 (1+ ntimes)))
-      ((= ntimes 10.))
-     (declare (fixnum ntimes))
-     (fft re im)))
-
-(defun time-fft ()
-  (time (fft-bench)))
diff --git a/benchmarks/gabriel/puzzle.c b/benchmarks/gabriel/puzzle.c
deleted file mode 100644
index 2e2a598f0f03e1240cd82b53ea59ced8c2fd8704..0000000000000000000000000000000000000000
--- a/benchmarks/gabriel/puzzle.c
+++ /dev/null
@@ -1,230 +0,0 @@
-# define size     511
-# define classMax 3
-# define typeMax  12
-# define d	  8
-# define true     1
-# define false    0
-
-static int class[typeMax+1];
-static int pieceCount[classMax+1];
-static int pieceMax[typeMax+1];
-static int puzzle[size+1];
-static int p[typeMax+1][size+1];
-static int kount,clock;
-
-
-fit(i,j)
-int i,j;
-  {
-    register k,plim;
-    plim = pieceMax[i];
-    for (k=0; k <= plim; k++)
-      {
-        if (p[i][k])
-	  {
-            if (puzzle[j+k]) return (false);
-	  }
-       }
-    return(true);
-  }
-
-int place (i,j)
-int i,j;
-  {
-    register k,plim;
-    plim = pieceMax[i];
-    for (k = 0; k <= plim; k++)
-      if (p[i][k]) puzzle[j+k] = true;
-    pieceCount[class[i]] = pieceCount[class[i]] - 1;
-    for (k=j; k <= size; k++)
-      if (!puzzle[k])
-	{
-          return(k);
-	}
-    printf("Puzzle filled.\n");
-    return(0);
-  }
-
-remove(i,j)
-int i,j;
-  {
-    register k,plim;   
-    plim = pieceMax[i];
-    for (k=0; k<=plim; k++)
-      if (p[i][k]) puzzle[j+k] = false;
-    pieceCount[class[i]] = pieceCount[class[i]] + 1;
-  }
-
-trial(j)
-int j;
-  {
-    register i,k;
-    for (i = 0; i <= typeMax; i++)
-      if (pieceCount[class[i]] != 0) 
-        if (fit (i, j))
-	  {
-            k = place (i, j);
-            if (trial(k)||(k == 0))
-	      {                                         
-/*	        printf("piece %d at %d\n",i+1,k+1); */
-		kount = kount + 1;
-		return(true);
-	      }
-            else remove (i, j);
-          }
-    kount = kount + 1;
-    return(false);
-  }
-
-main()
-  {
-    register i,j,k,m,n;
-
-/*    printf("starting\n"); */
-
-    for (m = 0; m<=size; m++)
-      puzzle[m] = true;
-
-    for (i=1; i <= 5; i++)
-      for (j=1; j<=5; j++)
-	for (k=1; k<=5 ; k++)
-          puzzle[i+d*(j+d*k)] = false;
-
-    for (i=0;i<=typeMax;i++)
-      for (j=0;j<=size;j++)
-        p[i][j] = false;
-
-    for (i=0;i<=3;i++)
-      for (j=0;j<=1;j++)
-	for (k = 0;k<=0;k++)
-          p[0][i+d*(j+d*k)] = true;
-
-    class[0] = 0;
-    pieceMax[0] = 3+d*1+d*d*0;
-
-    for (i=0;i<=1;i++) 
-      for (j=0;j<=0;j++)
-	for (k=0;k<=3;k++)
-          p[1][i+d*(j+d*k)] = true;
-
-    class[1] = 0;
-    pieceMax[1] = 1+d*0+d*d*3;
-
-    for (i=0;i<=0;i++) 
-      for (j=0;j<=3;j++)
-	for (k=0;k<=1;k++)
-          p[2][i+d*(j+d*k)] = true;
-
-    class[2] = 0;
-    pieceMax[2] = 0+d*3+d*d*1;
-
-    for (i=0;i<=1;i++) 
-      for (j=0;j<=3;j++)
-	for (k=0;k<=0;k++)
-          p[3][i+d*(j+d*k)] = true;
-
-    class[3] = 0;
-    pieceMax[3] = 1+d*3+d*d*0;
-
-    for (i=0;i<=3;i++) 
-      for (j=0;j<=0;j++)
-	for (k=0;k<=1;k++)
-          p[4][i+d*(j+d*k)] = true;
-
-    class[4] = 0;
-    pieceMax[4] = 3+d*0+d*d*1;
-
-    for (i=0;i<=0;i++) 
-      for (j=0;j<=1;j++)
-	for (k=0;k<=3;k++)
-          p[5][i+d*(j+d*k)] = true;
-
-    class[5] = 0;
-    pieceMax[5] = 0+d*1+d*d*3;
-
-    for (i=0;i<=2;i++) 
-      for (j=0;j<=0;j++)
-	for (k=0;k<=0;k++)
-          p[6][i+d*(j+d*k)] = true;
-
-    class[6] = 1;
-    pieceMax[6] = 2+d*0+d*d*0;
-
-    for (i=0;i<=0;i++) 
-      for (j=0;j<=2;j++)
-	for (k=0;k<=0;k++)
-          p[7][i+d*(j+d*k)] = true;
-
-    class[7] = 1;
-    pieceMax[7] = 0+d*2+d*d*0;
-
-    for (i=0;i<=0;i++) 
-      for (j=0;j<=0;j++)
-	for (k=0;k<=2;k++)
-          p[8][i+d*(j+d*k)] = true;
-
-    class[8] = 1;
-    pieceMax[8] = 0+d*0+d*d*2;
-
-    for (i=0;i<=1;i++) 
-      for (j=0;j<=1;j++)
-	for (k=0;k<=0;k++)
-          p[9][i+d*(j+d*k)] = true;
-
-    class[9] = 2;
-    pieceMax[9] = 1+d*1+d*d*0;
-
-    for (i=0;i<=1;i++) 
-      for (j=0;j<=0;j++)
-	for (k=0;k<=1;k++)
-          p[10][i+d*(j+d*k)] = true;
-
-    class[10] = 2;
-    pieceMax[10] = 1+d*0+d*d*1;
-
-    for (i=0;i<=0;i++) 
-      for (j=0;j<=1;j++)
-	for (k=0;k<=1;k++)
-          p[11][i+d*(j+d*k)] = true;
-
-    class[11] = 2;
-    pieceMax[11] = 0+d*1+d*d*1;
-
-    for (i=0;i<=1;i++) 
-      for (j=0;j<=1;j++)
-	for (k=0;k<=1;k++)
-          p[12][i+d*(j+d*k)] = true;
-
-    class[12] = 3;
-    pieceMax[12] = 1+d*1+d*d*1;
-    pieceCount[0] = 13;
-    pieceCount[1] = 3;
-    pieceCount[2] = 1;
-    pieceCount[3] = 1;
-    m = 1+d*(1+d*1);
-    kount = 0;
-
-    if (fit(0, m)) 
-      {
-        n = place(0, m) ;
-      }
-    else 
-      {
-	printf("error 1\n");
-      }
-
-/*    printf("n = %d n\n",n); */
-
-    if (trial(n)) 
-      {
-	printf("success in %d trials\n", kount);
-      }
-    else 
-      {
-	printf("failure\n");
-      }
-
-/*    printf("elapsed user time:\n"); */
-  }
-
-
diff --git a/benchmarks/gabriel/puzzle.lisp b/benchmarks/gabriel/puzzle.lisp
deleted file mode 100644
index 4920c9025f12f5fcf67b784253f87801448e69c6..0000000000000000000000000000000000000000
--- a/benchmarks/gabriel/puzzle.lisp
+++ /dev/null
@@ -1,167 +0,0 @@
-;;;; -*- Mode: Lisp; Package: User -*-
-;;;;
-
-(in-package "USER")
-(proclaim '(optimize (safety 0) (speed 3)))
-
-;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
-
-(defconstant size 511)	
-(defconstant classmax 3)
-(defconstant typemax 12)
-
-(defvar iii 0)
-(defvar kount 0)
-(defconstant dee 8)
-
-(proclaim '(type fixnum size classmax typemax iii kount dee))
-
-(defvar piececount (make-array (1+ classmax) :initial-element 0))
-(defvar class (make-array (1+ typemax) :initial-element 0))
-(defvar piecemax (make-array (1+ typemax) :initial-element 0))
-(defvar puzzle (make-array (1+ size)))
-(defvar p (make-array (list (1+ typemax) (1+ size))))
-
-(proclaim '(type simple-vector piececount class piecemax puzzle))
-
-(defun fit (i j)
-  (declare (fixnum i j))
-  (let ((end (svref piecemax i)))
-    (do ((k 0 (1+ k)))
-	((> k end) t)
-      (declare (fixnum k))
-      (cond ((aref p i k)
-	     (cond ((svref puzzle (+ j k))
-		    (return nil))))))))
-
-(defun place (i j)
-  (declare (fixnum i j))
-  (let ((end (svref piecemax i)))
-    (do ((k 0 (1+ k)))
-	((> k end))
-      (declare (fixnum k))
-      (cond ((aref p i k) 
-	     (setf (svref puzzle (+ j k)) t))))
-    (setf (svref piececount (svref class i))
-	  (- (svref piececount (svref class i)) 1))
-    (do ((k j (1+ k)))
-	((> k size)
-;	 (terpri)
-;	 (princ "Puzzle filled")
-	 0)
-      (declare (fixnum k))
-      (cond ((not (svref puzzle k))
-	     (return k))))))
-
-(defun puzzle-remove (i j)
-  (declare (fixnum i j))
-  (let ((end (svref piecemax i)))
-    (do ((k 0 (1+ k)))
-	((> k end))
-      (declare (fixnum k))
-      (cond ((aref p i k)
-	     (setf (svref puzzle (+ j k))  nil))))
-    (setf (svref piececount (svref class i))
-	  (+ (svref piececount (svref class i)) 1))))
-
-(defun trial (j)
-  (declare (fixnum j))
-  (let ((k 0))
-    (declare (fixnum k))
-    (do ((i 0 (1+ i)))
-	((> i typemax) (setq kount (1+ kount)) 	 nil)
-      (declare (fixnum i))
-      (cond ((not (= (svref piececount (svref class i)) 0))
-	     (cond ((fit i j)
-		    (setq k (place i j))
-		    (cond ((or (trial k)
-			       (= k 0))
-;			   (format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1))
-			   (setq kount (+ kount 1))
-			   (return t))
-			  (t (puzzle-remove i j))))))))))
-
-(defun definepiece (iclass ii jj kk)
-  (declare (fixnum ii jj kk))
-  (let ((index 0))
-    (do ((i 0 (1+ i)))
-	((> i ii))
-      (declare (fixnum i))
-      (do ((j 0 (1+ j)))
-	  ((> j jj))
-	(declare (fixnum j))
-	(do ((k 0 (1+ k)))
-	    ((> k kk))
-	  (declare (fixnum k))
-	  (setq index  (+ i (* dee (+ j (* dee k)))))
-	  (setf (aref p iii index)  t))))
-    (setf (svref class iii) iclass)
-    (setf (svref piecemax iii) index) 
-    (cond ((not (= iii typemax))
-	   (setq iii (+ iii 1))))))
-
-(defun puzzle ()
-  (do ((m 0 (1+ m)))
-      ((> m size))
-    (declare (fixnum m))
-    (setf (svref puzzle m) t))
-  (do ((i 1 (1+ i)))
-      ((> i 5))
-    (declare (fixnum i))
-    (do ((j 1 (1+ j)))
-	((> j 5))
-      (declare (fixnum j))
-      (do ((k 1 (1+ k)))
-	  ((> k 5))
-	(declare (fixnum k))
-	(setf (svref puzzle (+ i (* dee (+ j (* dee k))))) nil))))
-  (do ((i 0 (1+ i)))
-      ((> i typemax))
-    (declare (fixnum i))
-    (do ((m 0 (1+ m)))
-	((> m size))
-      (declare (fixnum m))
-      (setf (aref p i m)  nil)))
-  (setq iii 0)
-  (definePiece 0 3 1 0)
-  (definePiece 0 1 0 3)
-  (definePiece 0 0 3 1)
-  (definePiece 0 1 3 0)
-  (definePiece 0 3 0 1)
-  (definePiece 0 0 1 3)
-  
-  (definePiece 1 2 0 0)
-  (definePiece 1 0 2 0)
-  (definePiece 1 0 0 2)
-  
-  (definePiece 2 1 1 0)
-  (definePiece 2 1 0 1)
-  (definePiece 2 0 1 1)
-  
-  (definePiece 3 1 1 1)
-  
-  (setf (svref pieceCount 0) 13.)
-  (setf (svref pieceCount 1) 3)
-  (setf (svref pieceCount 2) 1)
-  (setf (svref pieceCount 3) 1)
-  (let ((m (+ 1 (* dee (+ 1 dee))))
-	(n 0)
-	(kount 0))
-    (declare (fixnum m n kount))
-    (cond ((fit 0 m) (setq n (place 0 m)))
-	  (t
-	   (write-string "
-Error.")))
-    (cond ((trial n)
-	   (write-string "
-Success in ")
-	   (print kount)
-	   (write-string " trials."))
-	  (t
-	   (write-string "
-Failure.")
-	   ))))
-
-
-(defun time-puzzle ()
-  (time (puzzle)))
diff --git a/benchmarks/gabriel/tak.lisp b/benchmarks/gabriel/tak.lisp
deleted file mode 100644
index da24990a080fd5b141a8bb9172427eb523ea74ba..0000000000000000000000000000000000000000
--- a/benchmarks/gabriel/tak.lisp
+++ /dev/null
@@ -1,28 +0,0 @@
-;;; TAK -- A vanilla version of the TAKeuchi function.
-
-(in-package "USER")
-(proclaim '(optimize (speed 1) (safety 1) (brevity 0)))
-
-(defun tak (x y z)
-  (declare (fixnum x y z))
-  (if (not (< y x))
-      z
-      (tak (tak (the fixnum (1- x)) y z)
-	   (tak (the fixnum (1- y)) z x)
-	   (tak (the fixnum (1- z)) x y))))
-
-(defun time-tak ()
-  (time (tak 18 12 6)))
-
-(proclaim '(optimize (speed 3) (safety 0)))
-
-(defun fast-tak (x y z)
-  (declare (fixnum x y z))
-  (if (not (< y x))
-      z
-      (fast-tak (fast-tak (the fixnum (1- x)) y z)
-		(fast-tak (the fixnum (1- y)) z x)
-		(fast-tak (the fixnum (1- z)) x y))))
-
-(defun time-fast-tak ()
-  (time (fast-tak 18 12 6)))
diff --git a/benchmarks/gabriel/triang.lisp b/benchmarks/gabriel/triang.lisp
deleted file mode 100644
index 5cb59a1b6a4a4f99b881bd0be6df72182b2e131c..0000000000000000000000000000000000000000
--- a/benchmarks/gabriel/triang.lisp
+++ /dev/null
@@ -1,57 +0,0 @@
-
-;;; TRIANG -- Board game benchmark.  
-
-(defvar board (make-array 16. :initial-element 1))
-(setf (aref board 5) 0)
-
-(defvar sequence (make-array 14. :initial-element 0))
-(defvar a (make-array 37. :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4 7 11 8 12
-						13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 6)))
-(defvar b (make-array 37. :initial-contents  '(2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5
-						 2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 5)))
-(defvar c (make-array 37. :initial-contents  '(4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6
-						 1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4)))
-(defvar answer)
-(defvar final)
-
-(proclaim '(type simple-vector board sequence a b c))
-
-(defun last-position ()
-  (do ((i 1 (1+ i)))
-      ((= i 16.) 0)
-    (declare (fixnum i))
-    (if (= 1 (the fixnum (aref board i)))
-	(return i))))
-
-(defun try (i depth)
-  (declare (fixnum i depth))
-  (cond ((= depth 14) 
-	 (let ((lp (last-position)))
-	   (unless (member lp final)
-	     (push lp final)))
-	 (push (cdr (coerce (the simple-vector sequence) 'list))
-	       answer) t)	; this is a hack to replace LISTARRAY
-	((and (= 1 (the fixnum (aref board (aref a i))))
-	      (= 1 (the fixnum (aref board (aref b i))))
-	      (= 0 (the fixnum (aref board (aref c i)))))
-	 (setf (aref board (aref a i)) 0)
-	 (setf (aref board (aref b i)) 0)
-	 (setf (aref board (aref c i)) 1)
-	 (setf (aref sequence depth) i)
-	 (do ((j 0 (1+ j))
-	      (depth (1+ depth)))
-	     ((or (= j 36.)
-		  (try j depth)) ())
-	   (declare (fixnum j depth)))
-	 (setf (aref board (aref a i)) 1) 
-	 (setf (aref board (aref b i)) 1)
-	 (setf (aref board (aref c i)) 0) ())))
-
-(defun triangle (i)
-  (let ((answer ())
-	(final ()))
-    (try i 1)))
-#|
-(defun time-triangle ()
-  (time (triangle 22)))
-|#
diff --git a/benchmarks/oprofile.lisp b/benchmarks/oprofile.lisp
deleted file mode 100644
index 104cc4c5ec4deafd130dc1b86056a769fbbeb4fb..0000000000000000000000000000000000000000
--- a/benchmarks/oprofile.lisp
+++ /dev/null
@@ -1,317 +0,0 @@
-;;; -*- Mode: Lisp; Package: Profile; Log: profile.log -*-
-;;;
-;;; This code has been placed in the public domain by the author.
-;;; It is distributed without warranty of any kind.
-;;;
-;;; Description: Simple profiling facility.
-;;;
-;;; Author: Skef Wholey, Rob MacLachlan
-;;;
-;;; Current maintainer:	Rob MacLachlan
-;;;
-;;; Address: Carnegie-Mellon University
-;;;          Computer Science Department
-;;;	     Pittsburgh, PA 15213
-;;;
-;;; Net address: ram@cs.cmu.edu
-;;;
-;;; Copyright status: Public domain.
-;;;
-;;; Compatibility: Runs in any valid Common Lisp.  Three small implementation-
-;;;   dependent changes can be made to improve performance and prettiness.
-;;;
-;;; Dependencies: The macro Quickly-Get-Time and the function
-;;;   Required-Arguments should probably be tailored to the implementation for
-;;;   the best results.  They will default to working, albeit inefficent, forms
-;;;   in non-CMU implementations.  The Total-Consing macro is used to profile
-;;;   consing: in unknown implementations 0 will be used.
-;;;   See the "Implementation Parameters" section.
-;;;
-;;; Note: a timing overhead factor is computed at load time.  This will be
-;;;   incorrect if profiling code is run in a different environment than this
-;;;   file was loaded in.  For example, saving a core image on a high
-;;;   performance machine and running it on a low performance one will result
-;;;   in use of an erroneously small timing overhead factor.
-;;;
-(in-package "OPROFILE")
-
-(export '(*timed-functions* profile unprofile report-time reset-time))
-
-
-
-(progn
-  #-:cmu
-  (eval-when (compile eval)
-    (warn
-     "You may want to supply an implementation-specific ~
-     Quickly-Get-Time function."))
-
-  (defconstant quick-time-units-per-second internal-time-units-per-second)
-  
-  (defmacro quickly-get-time ()
-    `(get-internal-run-time)))
-
-
-;;; To avoid unnecessary consing in the "encapsulation" code, we find out the
-;;; number of required arguments, and use &rest to capture only non-required
-;;; arguments.  The function Required-Arguments returns two values: the first
-;;; is the number of required arguments, and the second is T iff there are any
-;;; non-required arguments (e.g. &optional, &rest, &key).
-
-#+nil
-(defun required-arguments (name)
-  (let ((function (symbol-function name)))
-    (if (eql (system:%primitive get-type function) system:%function-type)
-	(let ((min (ldb system:%function-min-args-byte
-			(system:%primitive header-ref function
-					   system:%function-min-args-slot)))
-	      (max (ldb system:%function-max-args-byte
-			(system:%primitive header-ref function
-					   system:%function-max-args-slot)))
-	      (rest (ldb system:%function-rest-arg-byte
-			 (system:%primitive header-ref function
-					    system:%function-rest-arg-slot)))
-	      (key (ldb system:%function-keyword-arg-byte
-			(system:%primitive header-ref function
-					   system:%function-keyword-arg-slot))))
-	  (values min (or (/= min max) (/= rest 0) (/= key 0))))
-	(values 0 t))))
-	   
-
-#-:cmu
-(progn
- (eval-when (compile eval)
-   (warn
-    "You may want to add an implementation-specific Required-Arguments function."))
- (eval-when (load eval)
-   (defun required-arguments (name)
-     (declare (ignore name))
-     (values 0 t))))
-
-
-
-;;; The Total-Consing macro is called to find the total number of bytes consed
-;;; since the beginning of time.
-
-#+cmu
-(defmacro total-consing () '(ext:get-bytes-consed))
-
-#-:cmu
-(progn
-  (eval-when (compile eval)
-    (warn "No consing will be reported unless a Total-Consing function is ~
-           defined."))
-
-  (defmacro total-consing () '0))
-    
-
-(defvar *timed-functions* ()
-  "List of functions that are currently being timed.")
-
-
-(defmacro profile (&rest names)
-  "Wraps profiling code around the named functions.  The Names are not evaluated,
-  as in Trace."
-  (do ((names names (cdr names))
-       (stuff ()))
-      ((null names)
-       ;; Keep the compiler quiet by sending standard output to bit bucket.
-       `(compiler-let (#|(*standard-output* (make-broadcast-stream))|#)
-	  ,@stuff
-	  (values)))
-    (push (profile-1-function (car names)) stuff)))
-
-
-;;; A function is profiled by replacing its definition with a closure created by
-;;; the following function.  The closure records the starting time, calls the
-;;; original function, and records finishing time.  Other closures are used to
-;;; perform various operations on the encapsulated function.
-
-(defun profile-1-function (name)
-  (multiple-value-bind (min-args optionals-p)
-		       (required-arguments name)
-    (let ((required-args ()))
-      (dotimes (i min-args)
-	(push (gensym) required-args))
-      `(funcall
-	(compile
-	 nil
-	 ;; Use ' instead of #' below so guaranteed null lexical environment.
-	 '(lambda ()
-	    (let* ((time 0)
-		   (count 0)
-		   (consed 0)
-		   (old-definition (symbol-function ',name))
-		   (new-definition
-		    #'(lambda (,@required-args
-			       ,@(if optionals-p
-				     `(&rest optional-args)))
-			(incf count)
-			(let ((old-time time)
-			      (start-time (quickly-get-time))
-			      (old-consed consed)
-			      (start-consed (total-consing)))
-			  (multiple-value-prog1
-			    ,(if optionals-p
-				 `(apply old-definition
-					 ,@required-args optional-args)
-				 `(funcall old-definition ,@required-args))
-			    (setq time
-				  (+ old-time (- (quickly-get-time)
-						 start-time)))
-			    (setq consed
-				  (+ old-consed (- (total-consing)
-						   start-consed))))))))
-	      (pushnew ',name *timed-functions*)
-	      (setf (get ',name 'read-time)
-		    #'(lambda ()
-			(values count time consed))
-		    (get ',name 'reset-time)
-		    #'(lambda ()
-			(setq count 0)
-			(setq time 0)
-			(setq consed 0)
-			t)
-		    (symbol-function ',name)
-		    new-definition
-		    (get ',name 'reset-definition)
-		    #'(lambda ()
-			(remprop ',name 'read-time)
-			(remprop ',name 'reset-time)
-			(if (eq (symbol-function ',name) new-definition)
-			    (setf (symbol-function ',name) old-definition)
-			    (warn "The function ~S was redefined without ~
-				  unprofiling and reprofiling.~%~
-				  Timing figures have not been updated ~
-				  since that redefinition."
-				  ',name))
-			(remprop ',name 'reset-definition)
-			(setq *timed-functions*
-			      (delete ',name *timed-functions*))
-			nil)))))))))
-
-
-(defmacro unprofile (&rest names)
-  "Unwraps the profiling code around the named functions.  Names defaults to the
-  list of all currently profiled functions."
-  `(dolist (name ,(if names `',names '*timed-functions*) (values))
-     (unprofile-1-function name)))
-
-(defun unprofile-1-function (name)
-  (if (get name 'reset-definition)
-      (funcall (get name 'reset-definition))
-      (error "~S is not a function being profiled." name)))
-
-
-(defmacro report-time (&rest names)
-  "Reports the time spent in the named functions.  Names defaults to the list of
-  all currently profiled functions."
-  `(%report-times ,(if names `',names '*timed-functions*)))
-
-
-;;; We average the timing overhead over this many iterations.
-;;;
-(defconstant timer-overhead-iterations 5000)
-
-;;; Compute-Time-Overhead  --  Internal
-;;;
-;;;    Return as a float the total number of seconds it takes to call both
-;;; Quickly-Get-Time and Total-Consing together, plus a funcall thrown in
-;;; to represent some of the other overhead.   We also return a something
-;;; computed from the results in order to frustrate clever compilers.
-;;;
-(defun compute-time-overhead-aux (x)
-  x)
-(proclaim '(notinline compute-time-overhead-aux))
-;;;
-(defun compute-time-overhead ()
-  (let ((foo 0)
-	(fun (symbol-function 'compute-time-overhead-aux))
-	(start (quickly-get-time)))
-    (funcall fun nil)
-    (dotimes (i timer-overhead-iterations)
-      (setq foo (logxor (funcall fun (quickly-get-time))
-			(total-consing)
-			foo)))
-    (let ((now (quickly-get-time)))
-      (values
-       (/ (float (- now start))
-	  (float timer-overhead-iterations)
-	  (float quick-time-units-per-second))
-       foo))))
-
-
-(defvar *time-overhead* (compute-time-overhead))
-
-(defstruct (time-info
-	    (:constructor make-time-info (name calls time consing)))
-  name
-  calls
-  time
-  consing)
-
-
-(defun %report-times (names)
-  (let ((info ())
-	(no-call ()))
-    (dolist (name names)
-      (multiple-value-bind
-	  (calls time consing)
-	  (funcall (or (get name 'read-time)
-		       (error "~S is not profiled.")))
-	(if (zerop calls)
-	    (push name no-call)
-	    (let ((compensated
-		   (- (/ (float time) (float quick-time-units-per-second))
-		      (* *time-overhead* (float calls)))))
-	      (push (make-time-info name calls
-				    (if (minusp compensated) 0.0 compensated)
-				    consing)
-		    info)))))
-    
-    (setq info (sort info #'>= :key #'time-info-time))
-
-    (format *trace-output*
-	    "~&  Seconds  |  Consed   |  Calls  |  Sec/Call  |  Name:~@
-	       ------------------------------------------------------~%")
-
-    (let ((total-time 0.0)
-	  (total-consed 0)
-	  (total-calls 0))
-      (dolist (time info)
-	(incf total-time (time-info-time time))
-	(incf total-calls (time-info-calls time))
-	(incf total-consed (time-info-consing time))
-	(format *trace-output*
-		"~10,3F | ~9:D | ~7:D | ~10,5F | ~S~%"
-		(time-info-time time)
-		(time-info-consing time)
-		(time-info-calls time)
-		(/ (time-info-time time) (float (time-info-calls time)))
-		(time-info-name time)))
-      (format *trace-output*
-	      "------------------------------------------------------~@
-	      ~10,3F | ~9:D | ~7:D |            | Total~%"
-	      total-time total-consed total-calls)
-
-      (format *trace-output*
-	      "~%Estimated total profiling overhead: ~4,2F seconds~%"
-	      (* *time-overhead* (float total-calls) 2.0)))
-
-    (when no-call
-      (format *trace-output*
-	      "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
-	      (sort no-call #'string< :key #'symbol-name)))
-    (values)))
-
-
-(defmacro reset-time (&rest names)
-  "Resets the time counter for the named functions.  Names defaults to the list
-  of all currently profiled functions."
-  `(dolist (name ,(if names `',names '*timed-functions*) (values))
-     (reset-1-time name)))
-
-(defun reset-1-time (name)
-  (if (get name 'reset-time)
-      (funcall (get name 'reset-time))
-      (error "~S is not a function being profiled.")))
diff --git a/benchmarks/richards/RICHARDS_MAIL b/benchmarks/richards/RICHARDS_MAIL
deleted file mode 100644
index 34e3e6a68d154a12006efeb1415603b33e42e76d..0000000000000000000000000000000000000000
--- a/benchmarks/richards/RICHARDS_MAIL
+++ /dev/null
@@ -1,63 +0,0 @@
-Newsgroups: comp.lang.smalltalk
-Distribution: comp
-Subject: Smalltalk vs. C(++) performance
-
-Executive summary: a non-trivial benchmark written in C++ and
-Smalltalk is available from otis.stanford.edu; please send me your
-results.
--------------------------------------------------------------------
-
-As some have pointed out, it is difficult to compare the runtime
-performance of Smalltalk programs with the performance of equivalent C
-programs.  One reason for this is that for most non-trivial programs
-there is no equivalent program written in the other language (because
-it would be a non-trivial effort to write it).
-
-The "best" benchmark I know of is the Richards benchmark, an operating
-system simulation.  It is written in an object-oriented style, uses
-polymorphism, and is reasonably non-trivial (700 lines).  It's
-probably not the world's greatest benchmark, but better than 
-micro-benchamrks, and it is available in Smalltalk, Self, T (an
-object-oriented version of Scheme) and C++.
-
-[Historical note: the Richards benchmark was originally written in
-BCPL by Mark Richards.  Many thanks to L. Peter Deutsch for the
-Smalltalk version.]
-
-The sources for Richards are available from otis.stanford.edu
-(36.22.0.201) in /pub/benchmarks.  I would be interested in
-comparisons of the performance of the C++ and Smalltalk versions on
-various systems.  We measured it a while ago for the Sun-3/4 versions
-of PP 2.4, and the difference was about a factor of 10.
-
-Disclaimer: Richards is *not* a typical application: it is relatively
-small and contains no graphics or other user interaction.  Thus it may
-not reflect the relative performance of Your Own Real-World (TM)
-Application, but I think it tests the efficiency of the basic language
-mechanisms fairly well.  If you think you have a better benchmark
-which is available both in ST-80 and C (or Fortran or...), please let
-me know.
-
-******* ADVERTISEMENT ******** 
-
-The goal of the Self project at Stanford is to improve the performance
-of dynamically-typed object-oriented languages such as Smalltalk and
-Self.  Though similar to Smalltalk, Self is simpler and more flexible.
-Our current system runs significantly faster than any Smalltalk
-implementation we know of.  For example, here are the numbers for
-Richards on a Sun-4/260:
-
-	C++  (-O2)	730ms
-	Self	       2160ms (Nov'90; 1940ms for an experimental system)
-	PP ST-80 2.4   7740ms
-	T	       9800ms (8100ms with some not-so-kosher "tuning")
-
-[On some other benchmarks, the Stanford Integer Benchmarks, Self
-actually looks even better, running at around 60-70% of the speed of
-optimized C.]
-
-More information (papers, documentation, how to get the current system)
-is available via anonymous ftp from otis.stanford.edu.
-
-******* END OF ADVERTISEMENT ******** 
-
diff --git a/benchmarks/richards/cbase.h b/benchmarks/richards/cbase.h
deleted file mode 100644
index d88baddea20adcb80c31521525e966b400859aa8..0000000000000000000000000000000000000000
--- a/benchmarks/richards/cbase.h
+++ /dev/null
@@ -1,15 +0,0 @@
-/* cbase.h */
-
-#ifndef CBASE
-
-#define CBASE
-
-#define BOOLEAN int
-#define TRUE 1
-#define FALSE 0
-
-#include <stdio.h>
-#include <ctype.h>
-#include <assert.h>
-
-#endif
diff --git a/benchmarks/richards/rbase.h b/benchmarks/richards/rbase.h
deleted file mode 100644
index 6f4abbbaeaf754379d44bd3137048d9db9b8afc0..0000000000000000000000000000000000000000
--- a/benchmarks/richards/rbase.h
+++ /dev/null
@@ -1,16 +0,0 @@
-/* rbase.h */
-#ifndef RBASE
-
-#define RBASE
-
-typedef enum {DevicePacket, WorkPacket} 
-	PacketKind;
-typedef enum {Idler, Worker, HandlerA, HandlerB, DeviceA, DeviceB}
-	Identity;
-
-#define NTASKS 6                        /* # elements of Identity */
-				 	/* = # of tasks		  */
-#define NoWork NULL
-#define NoTask NULL
-
-#endif
diff --git a/benchmarks/richards/richards.c b/benchmarks/richards/richards.c
deleted file mode 100644
index 7c223cb3f47f4ef9a33248ff4bcd6482f8d9f954..0000000000000000000000000000000000000000
--- a/benchmarks/richards/richards.c
+++ /dev/null
@@ -1,235 +0,0 @@
-/* richards.c - Richards Benchmark in C++ */
-/* uh 2/2/89 */
-
-#include <time.h>
-#define  clock_t long		/* because Sun library isn't ANSI */
-#define  CLK_TCK 1000000
-#include "richards.h"   
-
-
-/*
-// creation
-*/
-
-void RBench::CreateDevice (Identity id, int prio,  Packet *work,
-                           TaskState *state)
-{   DeviceTaskRec *data;
-    TaskControlBlock *t;
-
-    data = new DeviceTaskRec;
-    t = new DeviceTCB(taskList, id, prio, work, state, data);
-    EnterTask(id, t);
-}
-
-
-void RBench::CreateHandler(Identity id, int prio,  Packet *work,
-                           TaskState *state)
-{   HandlerTaskRec *data;
-    TaskControlBlock *t;
-
-    data = new HandlerTaskRec;
-    t = new HandlerTCB(taskList, id, prio, work, state, data);
-    EnterTask(id, t);
-}
-
-
-void RBench::CreateIdler  (Identity id, int prio,  Packet *work,
-                           TaskState *state)
-{   IdleTaskRec *data;
-    TaskControlBlock *t;
-
-    data = new IdleTaskRec;
-    t = new IdlerTCB(taskList, id, prio, work, state, data);
-    EnterTask(id, t);
-}
-
-
-void RBench::CreateWorker (Identity id, int prio,  Packet *work,
-                           TaskState *state)
-{   WorkerTaskRec *data;
-    TaskControlBlock *t;
-
-    data = new WorkerTaskRec;
-    t = new WorkerTCB(taskList, id, prio, work, state, data);
-    EnterTask(id, t);
-}
-
-
-void RBench::EnterTask(Identity id, TaskControlBlock *t)
-{
-    taskList = t;
-    taskTable[id] = t;
-}
-
-
-/*
-//private
-*/
-
-TaskControlBlock *RBench::FindTask(Identity id)
-{   TaskControlBlock *t;
-
-    t = taskTable[id];
-    if (t == NULL) printf("***error: FindTask failed! ");
-    return t;
-}
-
-
-TaskControlBlock *RBench::HoldSelf()
-{
-    holdCount++;
-    currentTask->SetTaskHolding(TRUE);
-    return currentTask->Link();
-}
-
-
-TaskControlBlock *RBench::QueuePacket(Packet *p)
-{   TaskControlBlock *t;
-
-    t = FindTask(p->Ident());
-    queuePacketCount++;
-    p->SetLink(NoWork);
-    p->SetIdent(currentTaskIdent);
-    return t->AddPacket(p, currentTask);
-}
-
-
-TaskControlBlock *RBench::Release(Identity id)
-{   TaskControlBlock *t;
-
-    t = FindTask(id);
-    t->SetTaskHolding(FALSE);
-    return (t->Priority() > currentTask->Priority()) ? t : currentTask;
-}
-
-
-void RBench::Trace(Identity id)
-{
-    if(! --layout) {printf("\n"); layout = 50;} 
-    printf("%d", id + 1);
-}
-
-
-TaskControlBlock *RBench::Wait()
-{
-    currentTask->SetTaskWaiting(TRUE);
-    return currentTask;
-}
-
-
-/*
-//scheduling
-*/
-
-void RBench::Schedule()
-{
-    currentTask = taskList;
-    while (currentTask != NoTask) {
-         if (currentTask->IsTaskHoldingOrWaiting()) 
-              currentTask = currentTask->Link();
-         else {
-              currentTaskIdent = currentTask->Ident();
-              if (tracing) Trace(currentTaskIdent);
-              currentTask = currentTask->RunTask();
-         }
-    }
-}
-
-/*
-//initializing
-*/
-
-void RBench::InitScheduler()
-{
-    queuePacketCount = 0;
-    holdCount = 0;
-    for (int i = 0; i < NTASKS; i++) {taskTable[i] = NoTask;}
-    taskList = NoTask;
-}
-
-
-void RBench::InitTrace()
-{   char c;
-
-    printf("Trace (y/n)? ");
-    c = getchar();
-    tracing = (_toupper(c) == 'Y');
-}
-
-
-void RBench::Start(BOOLEAN trace) {
-//    clock_t t1, t2, t3, t4;
-    TaskState *t;
-    Packet *workQ;
-
-    if (trace) InitTrace(); else tracing = FALSE;
-    InitScheduler();
-//    t1 = clock();
-//    printf("\nRichards benchmark: initializing...\n");
-    t = new TaskState; t->Running();				// Idler
-    CreateIdler(Idler, 0, NoWork, t);
-
-    workQ = new Packet(NoWork, Worker, WorkPacket);		// Worker
-    workQ = new Packet(workQ , Worker, WorkPacket);
-    t = new TaskState; t->WaitingWithPacket();
-    CreateWorker(Worker, 1000, workQ, t);
-
-    workQ = new Packet(NoWork, DeviceA, DevicePacket);		// HandlerA
-    workQ = new Packet(workQ , DeviceA, DevicePacket);
-    workQ = new Packet(workQ , DeviceA, DevicePacket);
-    t = new TaskState; t->WaitingWithPacket();
-    CreateHandler(HandlerA, 2000, workQ, t);
-
-    workQ = new Packet(NoWork, DeviceB, DevicePacket);		// HandlerB
-    workQ = new Packet(workQ , DeviceB, DevicePacket);
-    workQ = new Packet(workQ , DeviceB, DevicePacket);
-    t = new TaskState; t->WaitingWithPacket();
-    CreateHandler(HandlerB, 3000, workQ, t);
-
-    t = new TaskState; t->Waiting();				// DeviceA
-    CreateDevice(DeviceA, 4000, NoWork, t);
-    t = new TaskState; t->Waiting();				// DeviceB
-    CreateDevice(DeviceB, 5000, NoWork, t);
-
-//    printf("starting...\n");
-//    t2 = clock();
-    Schedule();
-//    t3 = clock();
-//    printf("done.\n");
-
-//    printf("QueuePacketCount = %d, HoldCount = %d.\nThese results are %s",
-//           queuePacketCount, holdCount,
-//           (queuePacketCount == 23246 && holdCount == 9297) ? 
-//                "correct." : "wrong!"
-//          );
-    if (! (queuePacketCount == 23246 && holdCount == 9297)) {
-      printf("error: richards results are incorrect\n");
-    }
-
-//    t4 = clock();
-//    printf("\nScheduler time = %g seconds, total time = %g\n",
-//           (double)(t3 - t2) / CLK_TCK,
-//           (double)(t4 - t1) / CLK_TCK);
-}
-
-
-#define ITER  10		/* # of iterations in main loop  */
-
-int main()
-{   clock_t t_start, t_stop;
-
-    t_start = clock();
-    for (int i = 0; i < ITER; i++) 
-        bm.Start(ITER == 1);
-    t_stop = clock();
-
-    clock_t diff = (t_stop - t_start)/ITER;
-
-    printf("richards: %d ms\n", diff/(CLK_TCK/1000));
-
-//    if (ITER > 1) 
-//         printf("\n*** %d iterations, average of %g secs / iteration.\n",
-//		ITER,
-//		(double)(t_stop - t_start) / (ITER * CLK_TCK));
-}
-
diff --git a/benchmarks/richards/richards.h b/benchmarks/richards/richards.h
deleted file mode 100644
index 87f8191e6d2a2198c30c97947f2cce888a206bc5..0000000000000000000000000000000000000000
--- a/benchmarks/richards/richards.h
+++ /dev/null
@@ -1,52 +0,0 @@
-/* richards.h */
-/* Richards benchmark in C++, translated from Smalltalk */
-/* uh 2/2/89  */
-
-#include "rbase.h" 
-#include "tasks.h"
-
-/*
-// RBench class definition
-*/
-
-class RBench {
-    private:
-         TaskControlBlock *taskList, *currentTask;
-         Identity currentTaskIdent;
-         TaskControlBlock *taskTable[NTASKS];
-         int layout;
-         int holdCount, queuePacketCount;
-
-         /* creation */
-         void CreateDevice (Identity id, int prio,  Packet *work,
-                           TaskState *state);
-         void CreateHandler(Identity id, int prio,  Packet *work,
-                           TaskState *state);
-         void CreateIdler  (Identity id, int prio,  Packet *work,
-                           TaskState *state);
-         void CreateWorker (Identity id, int prio,  Packet *work,
-                           TaskState *state);
-         void EnterTask(Identity id, TaskControlBlock *t);
-
-         /* scheduling */
-         void Schedule();
-
-         /* initializing */
-         void InitScheduler();
-         void InitTrace();
-    public:
-         /* task management */
-         TaskControlBlock *FindTask(Identity id);
-         TaskControlBlock *HoldSelf();
-         TaskControlBlock *QueuePacket(Packet *p);
-         TaskControlBlock *Release(Identity id);
-         TaskControlBlock *Wait();
-         /* tracing */
-         BOOLEAN tracing;
-         void Trace(Identity id);
-
-         void Start(BOOLEAN askTrace);
-};
-
-RBench bm;		// benchmark currently executing
-
diff --git a/benchmarks/richards/richards.lisp b/benchmarks/richards/richards.lisp
deleted file mode 100644
index cd29c02495c6489a0412825deda93bbbaad00e10..0000000000000000000000000000000000000000
--- a/benchmarks/richards/richards.lisp
+++ /dev/null
@@ -1,407 +0,0 @@
-(in-package "USER")
-#+declare-unsafe
-(proclaim '(optimize speed (space 0) (safety 0) (compilation-speed 0)))
-
-(defconstant deviceA 5)
-(defconstant deviceB 6)
-(defconstant devicePacketKind 1)
-(defconstant handlerA 3)
-(defconstant handlerB 4)
-(defconstant idler 1)
-(defconstant noWork nil)
-(defconstant noTask nil)
-(defconstant worker 2)
-(defconstant workPacketKind 2)
-
-(defvar taskList noTask)
-(defvar currentTask nil)
-(defvar currentTaskIdentity nil)
-(defvar taskTable (make-array 6 :initial-element noTask))
-(proclaim '(simple-vector taskTable))
-(defvar tracing nil)
-(defvar layout 0)
-(defvar queuePacketCount 0)
-(defvar holdCount 0)
-(proclaim '(fixnum layout queuePacketCount holdCount))
-
-(declaim (inline make-taskControlBlock make-packet make-deviceTaskDataRecord
-		 make-handlerTaskDataRecord make-idleTaskDataRecord
-		 make-workerTaskDataRecord wait))
-
-(defstruct (taskControlBlock (:constructor make-taskControlBLock ()))
-  packetPending taskWaiting taskHolding link identity
-  (priority 0 :type fixnum)
-  input state handle)
-
-(defstruct (packet (:constructor make-packet ()))
-  link identity
-  (kind 0 :type fixnum)
-  (datum 0 :type fixnum) 
-  (data '#() :type simple-vector))
-
-(defstruct (deviceTaskDataRecord (:constructor make-deviceTaskDataRecord ()))
-  pending)
-
-(defstruct (handlerTaskDataRecord (:constructor make-handlerTaskDataRecord ()))
-  workIn deviceIn)
-
-(defstruct (idleTaskDataRecord (:constructor make-idleTaskDataRecord ()))
-  (control 0 :type fixnum)
-  (count 0 :type fixnum))
-
-(defstruct (workerTaskDataRecord (:constructor make-workerTaskDataRecord ()))
-  (destination 0 :type fixnum)
-  (count 0 :type fixnum))
-
-(defun wait ()
-  (setf (taskControlBlock-taskWaiting currentTask) t)
-  currentTask)
-
-#+cmu
-(declaim (ext:freeze-type taskControlBlock packet deviceTaskDataRecord
-			  handlerTaskDataRecord idleTaskDataRecord
-			  workerTaskDataRecord))
-#+cmu
-(declaim (ext:start-block richards))
-
-(defun deviceTaskDataRecord-run (self work)
-  (let ((functionWork work))
-    (if (eq noWork functionWork)
-	(progn
-	 (setq functionWork (deviceTaskDataRecord-pending self))
-	 (if (eq noWork functionWork)
-	     (wait)
-	   (progn
-	    (setf (deviceTaskDataRecord-pending self) noWork)
-	    (queuePacket functionWork))))
-      (progn
-       (setf (deviceTaskDataRecord-pending self) functionWork)
-       (if tracing (trace-it (packet-datum functionWork)))
-       (holdSelf)))))
-
-(defun handlerTaskDataRecord-run (self work)
-  (if (eq noWork work)
-      nil
-    (if (= workPacketKind (packet-kind work))
-	(workInAdd self work)
-      (deviceInAdd self work)))
-  (let ((workPacket (handlerTaskDataRecord-workIn self)))
-    (if (eq noWork workPacket)
-	(wait)
-      (let ((count (packet-datum workPacket)))
-	(if (> count 4)
-	    (progn
-	     (setf (handlerTaskDataRecord-workIn self)
-		   (packet-link workPacket))
-	     (queuePacket workPacket))
-	  (let ((devicePacket (handlerTaskDataRecord-deviceIn self)))
-	    (if (eq noWork devicePacket)
-		(wait)
-	      (progn
-	       (setf (handlerTaskDataRecord-deviceIn self)
-		     (packet-link devicePacket))
-	       (setf (packet-datum devicePacket)
-		     (svref (packet-data workPacket) (- count 1)))
-	       (setf (packet-datum workPacket) (+ count 1))
-	       (queuePacket devicePacket)))))))))
-
-(defun idleTaskDataRecord-run (self work)
-  (declare (ignore work))
-  (setf (idleTaskDataRecord-count self)
-	(- (idleTaskDataRecord-count self) 1))
-  (if (= 0 (idleTaskDataRecord-count self))
-      (holdSelf)
-    (if (= 0 (logand (idleTaskDataRecord-control self) 1))
-	(progn
-	 (setf (idleTaskDataRecord-control self)
-	       (floor (idleTaskDataRecord-control self) 2))
-	 (release deviceA))
-      (progn
-       (setf (idleTaskDataRecord-control self)
-	     (logxor (floor (idleTaskDataRecord-control self) 2)
-		     53256))
-       (release deviceB)))))
-
-(defun workerTaskDataRecord-run (self work)
-  (if (eq noWork work)
-      (wait)
-    (progn
-     (setf (workerTaskDataRecord-destination self)
-	   (if (= handlerA (workerTaskDataRecord-destination self))
-	       handlerB
-	     handlerA))
-     (setf (packet-identity work) (workerTaskDataRecord-destination self))
-     (setf (packet-datum work) 1)
-     (do ((i 0 (+ i 1)))
-	 ((> i 3) nil)
-       (declare (fixnum i))
-	 (setf (workerTaskDataRecord-count self)
-	       (+ (workerTaskDataRecord-count self) 1))
-	 (if (> (workerTaskDataRecord-count self) 256)
-	     (setf (workerTaskDataRecord-count self) 1))
-	 (setf (svref (packet-data work) i)
-	       (the fixnum
-		    (+ (char-code #\A)
-		       (- (workerTaskDataRecord-count self) 1)))))
-     (queuePacket work))))
-
-(defun appendHead (packet queueHead)
-  (setf (packet-link packet) noWork)
-  (if (eq noWork queueHead)
-      packet
-    (let ((mouse queueHead))
-      (let ((link (packet-link mouse)))
-	(do ()
-	    ((eq noWork link) nil)
-	    (setq mouse link)
-	    (setq link (packet-link mouse)))
-	(setf (packet-link mouse) packet)
-	queueHead))))
-
-(defun initialize-globals ()
-  (setq taskList noTask)
-  (setq currentTask nil)
-  (setq currentTaskIdentity nil)
-  (setq taskTable (make-array 6 :initial-element noTask))
-  (setq tracing nil)
-  (setq layout 0)
-  (setq queuePacketCount 0)
-  (setq holdCount 0))
-
-(defun richards ()
-  (initialize-globals)
-
-  (createIdler idler 0 noWork (running (make-taskControlBlock)))
-
-  (let ((workQ))
-
-    (setq workQ (createPacket noWork worker workPacketKind))
-    (setq workQ (createPacket workQ worker workPacketKind))
-    (createWorker worker 1000 workQ (waitingWithPacket))
-
-    (setq workQ (createPacket noWork deviceA devicePacketKind))
-    (setq workQ (createPacket workQ deviceA devicePacketKind))
-    (setq workQ (createPacket workQ deviceA devicePacketKind))
-    (createHandler handlerA 2000 workQ (waitingWithPacket))
-    
-    (setq workQ (createPacket noWork deviceB devicePacketKind))
-    (setq workQ (createPacket workQ deviceB devicePacketKind))
-    (setq workQ (createPacket workQ deviceB devicePacketKind))
-    (createHandler handlerB 3000 workQ (waitingWithPacket))
-    
-    (createDevice deviceA 4000 noWork (waiting))
-    (createDevice deviceB 5000 noWork (waiting))
-
-    )
-
-  (schedule)
-
-  (if (not (and (= queuePacketCount 23246) (= holdCount 9297)))
-      (error "richards results incorrect"))
-
-  nil)
-
-(defun schedule ()
-  (setq currentTask taskList)
-  (do ()
-      ((eq noTask currentTask) nil)
-    (if (isTaskHoldingOrWaiting currentTask)
-	(setq currentTask (taskControlBlock-link currentTask))
-	(progn
-	 (setq currentTaskIdentity (taskControlBlock-identity currentTask))
-	 (if tracing (trace-it currentTaskIdentity))
-	 (setq currentTask (runTask currentTask))))))
-
-(defun findTask (identity)
-  (declare (fixnum identity))
-  (let ((tk (svref taskTable (- identity 1))))
-    (if (eq noTask tk) (error "findTask failed"))
-    tk))
-
-(defun holdSelf ()
-  (setq holdCount (+ holdCount 1))
-  (setf (taskControlBlock-taskHolding currentTask) t)
-  (taskControlBlock-link currentTask))
-
-(defun queuePacket (packet)
-  (let ((tk (findTask (packet-identity packet))))
-    (if (eq noTask tk)
-	noTask
-	(progn
-	 (setq queuePacketCount (+ queuePacketCount 1))
-	 (setf (packet-link packet) noWork)
-	 (setf (packet-identity packet) currentTaskIdentity)
-	 (addInput tk packet currentTask)))))
-
-(defun release (identity)
-  (let ((tk (findTask identity)))
-    (if (eq noTask tk)
-	noTask
-	(progn
-	 (setf (taskControlBlock-taskHolding tk) nil)
-	 (if (> (taskControlBlock-priority tk)
-		(taskControlBlock-priority currentTask))
-	     tk
-	     currentTask)))))
-
-(defun trace-it (id)
-  (setq layout (- layout 1))
-  (if (>= 0 layout)
-      (progn
-       (format t "~%")
-       (setq layout 30)))
-  (format t "~a " id))
-
-(defun createDevice (identity priority work state)
-  (let ((data (create-deviceTaskDataRecord)))
-    (createTask identity priority work state data)))
-
-(defun createHandler (identity priority work state)
-  (let ((data (create-handlerTaskDataRecord)))
-    (createTask identity priority work state data)))
-
-(defun createIdler (identity priority work state)
-  (let ((data (create-idleTaskDataRecord)))
-    (createTask identity priority work state data)))
-
-(defun createWorker (identity priority work state)
-  (let ((data (create-workerTaskDataRecord)))
-    (createTask identity priority work state data)))
-
-(defun createTask (identity priority work state data)
-  (let ((tk (create-taskControlBlock
-	     taskList identity priority work state data)))
-    (setq taskList tk)
-    (setf (svref taskTable (- identity 1)) tk)))
-
-(defun createPacket (link identity kind)
-  (create-packet link identity kind))
-
-(defun running (tcb)
-  (setf (taskControlBlock-packetPending tcb) nil)
-  (setf (taskControlBlock-taskWaiting tcb) nil)
-  (setf (taskControlBlock-taskHolding tcb) nil)
-  tcb)
-
-(defun waiting ()
-  (let ((tcb (make-taskControlBlock)))
-    (setf (taskControlBlock-packetPending tcb) nil)
-    (setf (taskControlBlock-taskWaiting tcb) t)
-    (setf (taskControlBlock-taskHolding tcb) nil)
-    tcb))
-
-(defun waitingWithPacket ()
-  (let ((tcb (make-taskControlBlock)))
-    (setf (taskControlBlock-packetPending tcb) t)
-    (setf (taskControlBlock-taskWaiting tcb) t)
-    (setf (taskControlBlock-taskHolding tcb) nil)
-    tcb))
-
-(defun isTaskHoldingOrWaiting (tcb)
-  (or (taskControlBlock-taskHolding tcb)
-      (and (not (taskControlBlock-packetPending tcb))
-	   (taskControlBlock-taskWaiting tcb))))
-
-(defun isWaitingWithPacket (tcb)
-  (and (taskControlBlock-packetPending tcb)
-       (and (taskControlBlock-taskWaiting tcb)
-	    (not (taskControlBlock-taskHolding tcb)))))
-
-(defun packetNowPending (tcb)
-  (setf (taskControlBlock-packetPending tcb) t)
-  (setf (taskControlBlock-taskWaiting tcb) nil)
-  (setf (taskControlBlock-taskHolding tcb) nil)
-  tcb)
-
-(defun create-taskControlBlock
-  (link identity priority initialWorkQueue initialState privateData)
-  (let ((r (make-taskControlBlock)))
-    (setf (taskControlBlock-link r) link)
-    (setf (taskControlBlock-identity r) identity)
-    (setf (taskControlBlock-priority r) priority)
-    (setf (taskControlBlock-input r) initialWorkQueue)
-    (setf (taskControlBlock-packetPending r)
-	 (taskControlBlock-packetPending initialState))
-    (setf (taskControlBlock-taskWaiting r)
-	 (taskControlBlock-taskWaiting initialState))
-    (setf (taskControlBlock-taskHolding r)
-	 (taskControlBlock-taskHolding initialState))
-    (setf (taskControlBlock-handle r) privateData)
-    (setf (taskControlBlock-state r) nil)
-    r))
-
-(defun addInput (tcb packet oldTask)
-  (if (eq noWork (taskControlBlock-input tcb))
-      (progn
-       (setf (taskControlBlock-input tcb) packet)
-       (setf (taskControlBlock-packetPending tcb) t)
-       (if (> (taskControlBlock-priority tcb)
-	      (taskControlBlock-priority oldTask))
-	   tcb
-	   oldTask))
-      (progn
-       (setf (taskControlBlock-input tcb)
-	    (appendHead packet (taskControlBlock-input tcb)))
-       oldTask)))
-
-(defun runTask (tcb)
-  (let ((message nil))
-    (if (isWaitingWithPacket tcb)
-	(progn
-	  (setq message (taskControlBlock-input tcb))
-	  (setf (taskControlBlock-input tcb) (packet-link message))
-	  (if (eq noWork (taskControlBlock-input tcb))
-	      (running tcb)
-	    (packetNowPending tcb)))
-      (setq message noWork))
-    (run (taskControlBlock-handle tcb) message)))
-
-(defun run (self work)
-  (typecase self
-	    (deviceTaskDataRecord (deviceTaskDataRecord-run self work))
-	    (handlerTaskDataRecord (handlerTaskDataRecord-run self work))
-	    (idleTaskDataRecord (idleTaskDataRecord-run self work))
-	    (workerTaskDataRecord (workerTaskDataRecord-run self work))))
-
-(defun create-packet (link identity kind)
-  (let ((p (make-packet)))
-    (setf (packet-link p) link)
-    (setf (packet-identity p) identity)
-    (setf (packet-kind p) kind)
-    (setf (packet-datum p) 1)
-    (let ((v (make-array 4 :initial-element 0)))
-      (setf (packet-data p) v))
-    p))
-
-(defun create-deviceTaskDataRecord ()
-  (let ((tk (make-deviceTaskDataRecord)))
-    (setf (deviceTaskDataRecord-pending tk) noWork)
-    tk))
-
-(defun create-handlerTaskDataRecord ()
-  (let ((tk (make-handlerTaskDataRecord)))
-    (setf (handlerTaskDataRecord-workIn tk) noWork)
-    (setf (handlerTaskDataRecord-deviceIn tk) noWork)
-    tk))
-
-(defun deviceInAdd (tk packet)
-  (setf (handlerTaskDataRecord-deviceIn tk)
-       (appendHead packet (handlerTaskDataRecord-deviceIn tk)))
-  tk)
-
-(defun workInAdd (tk packet)
-  (setf (handlerTaskDataRecord-workIn tk)
-       (appendHead packet (handlerTaskDataRecord-workIn tk)))
-  tk)
-
-(defun create-idleTaskDataRecord ()
-  (let ((tk (make-idleTaskDataRecord)))
-    (setf (idleTaskDataRecord-control tk) 1)
-    (setf (idleTaskDataRecord-count tk) 10000)
-    tk))
-
-(defun create-workerTaskDataRecord ()
-  (let ((tk (make-workerTaskDataRecord)))
-    (setf (workerTaskDataRecord-destination tk) handlerA)
-    (setf (workerTaskDataRecord-count tk) 0)
-    tk))
diff --git a/benchmarks/richards/richards.t b/benchmarks/richards/richards.t
deleted file mode 100644
index 4368dbfe4d685591906ce99acdd1f28f2be7b1ed..0000000000000000000000000000000000000000
--- a/benchmarks/richards/richards.t
+++ /dev/null
@@ -1,378 +0,0 @@
-(herald richards)
-
-(define deviceA 5)
-(define deviceB 6)
-(define devicePacketKind 1)
-(define handlerA 3)
-(define handlerB 4)
-(define idler 1)
-(define noWork nil)
-(define noTask nil)
-(define worker 2)
-(define workPacketKind 2)
-
-(lset taskList noTask)
-(lset currentTask nil)
-(lset currentTaskIdentity nil)
-(lset taskTable (make-vector 6))
-(lset tracing nil)
-(lset layout 0)
-(lset queuePacketCount 0)
-(lset holdCount 0)
-
-(define-operation (run self work))
-
-(vector-fill taskTable noTask)
-
-(define (hash-obj l)
-  (if l (object-hash l) nil))
-
-(define-structure-type taskControlBlock
-  packetPending taskWaiting taskHolding link identity priority input state
-  handle)
-
-(define-structure-type packet
-  link identity kind datum data)
-
-(define-structure-type deviceTaskDataRecord
-  pending
-  (((run self work)
-    (lset functionWork work)
-    (if (equal? noWork functionWork)
-	(block
-	 (set functionWork (deviceTaskDataRecord-pending self))
-	 (if (equal? noWork functionWork)
-	     (wait)
-	     (block
-	      (set (deviceTaskDataRecord-pending self) noWork)
-	      (queuePacket functionWork))))
-	(block
-	 (set (deviceTaskDataRecord-pending self) functionWork)
-	 (if tracing (trace (packet-datum functionWork)))
-	 (holdSelf))))))
-
-(define-structure-type handlerTaskDataRecord
-  workIn deviceIn
-  (((run self work)
-    (if (equal? noWork work)
-	nil
-	(if (equal? workPacketKind (packet-kind work))
-	    (workInAdd self work)
-	    (deviceInAdd self work)))
-    (let ((workPacket (handlerTaskDataRecord-workIn self)))
-      (if (equal? noWork workPacket)
-	  (wait)
-	  (let ((count (packet-datum workPacket)))
-	    (if (> count 4)
-		(block
-		 (set (handlerTaskDataRecord-workIn self)
-		      (packet-link workPacket))
-		 (queuePacket workPacket))
-		(let ((devicePacket (handlerTaskDataRecord-deviceIn self)))
-		  (if (equal? noWork devicePacket)
-		      (wait)
-		      (block
-		       (set (handlerTaskDataRecord-deviceIn self)
-			    (packet-link devicePacket))
-		       (set (packet-datum devicePacket)
-			    (vref (packet-data workPacket) (- count 1)))
-		       (set (packet-datum workPacket) (+ count 1))
-		       (queuePacket devicePacket)))))))))))
-
-(define-structure-type idleTaskDataRecord
-  control count
-  (((run self work)
-    (ignorable work)
-    (set (idleTaskDataRecord-count self)
-	 (- (idleTaskDataRecord-count self) 1))
-    (if (equal? 0 (idleTaskDataRecord-count self))
-	(holdSelf)
-	(if (equal? 0 (logand (idleTaskDataRecord-control self) 1))
-	    (block
-	     (set (idleTaskDataRecord-control self)
-		  (quotient (idleTaskDataRecord-control self) 2))
-	     (release deviceA))
-	    (block
-	     (set (idleTaskDataRecord-control self)
-		  (logxor (quotient (idleTaskDataRecord-control self) 2)
-			  53256))
-	     (release deviceB)))))))
-
-(define-structure-type workerTaskDataRecord
-  destination count
-  (((run self work)
-    (if (equal? noWork work)
-	(wait)
-	(block
-	 (set (workerTaskDataRecord-destination self)
-	      (if (equal? handlerA (workerTaskDataRecord-destination self))
-		  handlerB
-		  handlerA))
-	 (set (packet-identity work) (workerTaskDataRecord-destination self))
-	 (set (packet-datum work) 1)
-	 (do ((i 0 (+ i 1)))
-	     ((> i 3) nil)
-	   (set (workerTaskDataRecord-count self)
-		(+ (workerTaskDataRecord-count self) 1))
-	   (if (> (workerTaskDataRecord-count self) 256)
-	       (set (workerTaskDataRecord-count self) 1))
-	   (vset (packet-data work) i
-		 (+ (char->ascii #\A)
-		    (- (workerTaskDataRecord-count self) 1))))
-	 (queuePacket work))))))
-
-(define (appendHead packet queueHead)
-  (set (packet-link packet) noWork)
-  (if (equal? noWork queueHead)
-      packet
-      (block
-       (lset mouse queueHead)
-       (lset link (packet-link mouse))
-       (do ()
-	   ((equal? noWork link) nil)
-	 (set mouse link)
-	 (set link (packet-link mouse)))
-       (set (packet-link mouse) packet)
-       queueHead)))
-
-(define (initialize-globals)
-  (set taskList noTask)
-  (set currentTask nil)
-  (set currentTaskIdentity nil)
-  (set taskTable (make-vector 6))
-  (set tracing nil)
-  (set layout 0)
-  (set queuePacketCount 0)
-  (set holdCount 0)
-  (vector-fill taskTable noTask))
-
-(define (richards)
-  (initialize-globals)
-
-  (createIdler idler 0 noWork (running (make-taskControlBlock)))
-
-  (lset workQ (createPacket noWork worker workPacketKind))
-  (set workQ (createPacket workQ worker workPacketKind))
-  (createWorker worker 1000 workQ (waitingWithPacket))
-
-  (set workQ (createPacket noWork deviceA devicePacketKind))
-  (set workQ (createPacket workQ deviceA devicePacketKind))
-  (set workQ (createPacket workQ deviceA devicePacketKind))
-  (createHandler handlerA 2000 workQ (waitingWithPacket))
-
-  (set workQ (createPacket noWork deviceB devicePacketKind))
-  (set workQ (createPacket workQ deviceB devicePacketKind))
-  (set workQ (createPacket workQ deviceB devicePacketKind))
-  (createHandler handlerB 3000 workQ (waitingWithPacket))
-
-  (createDevice deviceA 4000 noWork (waiting))
-  (createDevice deviceB 5000 noWork (waiting))
-
-  (schedule)
-
-  (if (not (and (equal? queuePacketCount 23246) (equal? holdCount 9297)))
-      (error "richards results incorrect"))
-
-  nil)
-
-(define (schedule)
-  (set currentTask taskList)
-  (do ()
-      ((equal? noTask currentTask) nil)
-    (if (isTaskHoldingOrWaiting currentTask)
-	(set currentTask (taskControlBlock-link currentTask))
-	(block
-	 (set currentTaskIdentity (taskControlBlock-identity currentTask))
-	 (if tracing (trace currentTaskIdentity))
-	 (set currentTask (runTask currentTask))))))
-
-(define (findTask identity)
-  (let ((tk (vref taskTable (- identity 1))))
-    (if (equal? noTask tk) (error "findTask failed"))
-    tk))
-
-(define (holdSelf)
-  (set holdCount (+ holdCount 1))
-  (set (taskControlBlock-taskHolding currentTask) t)
-  (taskControlBlock-link currentTask))
-
-(define (queuePacket packet)
-  (let ((tk (findTask (packet-identity packet))))
-    (if (equal? noTask tk)
-	noTask
-	(block
-	 (set queuePacketCount (+ queuePacketCount 1))
-	 (set (packet-link packet) noWork)
-	 (set (packet-identity packet) currentTaskIdentity)
-	 (addInput tk packet currentTask)))))
-
-(define (release identity)
-  (let ((tk (findTask identity)))
-    (if (equal? noTask tk)
-	noTask
-	(block
-	 (set (taskControlBlock-taskHolding tk) nil)
-	 (if (> (taskControlBlock-priority tk)
-		(taskControlBlock-priority currentTask))
-	     tk
-	     currentTask)))))
-
-(define (trace id)
-  (set layout (- layout 1))
-  (if (>= 0 layout)
-      (block
-       (format (debug-output) "~%")
-       (set layout 30)))
-  (format (debug-output) "~a " id))
-
-(define (wait)
-  (set (taskControlBlock-taskWaiting currentTask) t)
-  currentTask)
-
-(define (createDevice identity priority work state)
-  (let ((data (create-deviceTaskDataRecord)))
-    (createTask identity priority work state data)))
-
-(define (createHandler identity priority work state)
-  (let ((data (create-handlerTaskDataRecord)))
-    (createTask identity priority work state data)))
-
-(define (createIdler identity priority work state)
-  (let ((data (create-idleTaskDataRecord)))
-    (createTask identity priority work state data)))
-
-(define (createWorker identity priority work state)
-  (let ((data (create-workerTaskDataRecord)))
-    (createTask identity priority work state data)))
-
-(define (createTask identity priority work state data)
-  (let ((tk (create-taskControlBlock
-	     taskList identity priority work state data)))
-    (set taskList tk)
-    (vset taskTable (- identity 1) tk)))
-
-(define (createPacket link identity kind)
-  (create-packet link identity kind))
-
-(define (running tcb)
-  (set (taskControlBlock-packetPending tcb) nil)
-  (set (taskControlBlock-taskWaiting tcb) nil)
-  (set (taskControlBlock-taskHolding tcb) nil)
-  tcb)
-
-(define (waiting)
-  (let ((tcb (make-taskControlBlock)))
-    (set (taskControlBlock-packetPending tcb) nil)
-    (set (taskControlBlock-taskWaiting tcb) t)
-    (set (taskControlBlock-taskHolding tcb) nil)
-    tcb))
-
-(define (waitingWithPacket)
-  (let ((tcb (make-taskControlBlock)))
-    (set (taskControlBlock-packetPending tcb) t)
-    (set (taskControlBlock-taskWaiting tcb) t)
-    (set (taskControlBlock-taskHolding tcb) nil)
-    tcb))
-
-(define (isTaskHoldingOrWaiting tcb)
-  (or (taskControlBlock-taskHolding tcb)
-      (and (not (taskControlBlock-packetPending tcb))
-	   (taskControlBlock-taskWaiting tcb))))
-
-(define (isWaitingWithPacket tcb)
-  (and (taskControlBlock-packetPending tcb)
-       (and (taskControlBlock-taskWaiting tcb)
-	    (not (taskControlBlock-taskHolding tcb)))))
-
-(define (packetNowPending tcb)
-  (set (taskControlBlock-packetPending tcb) t)
-  (set (taskControlBlock-taskWaiting tcb) nil)
-  (set (taskControlBlock-taskHolding tcb) nil)
-  tcb)
-
-(define (create-taskControlBlock
-	 link identity priority initialWorkQueue initialState privateData)
-  (let ((r (make-taskControlBlock)))
-    (set (taskControlBlock-link r) link)
-    (set (taskControlBlock-identity r) identity)
-    (set (taskControlBlock-priority r) priority)
-    (set (taskControlBlock-input r) initialWorkQueue)
-    (set (taskControlBlock-packetPending r)
-	 (taskControlBlock-packetPending initialState))
-    (set (taskControlBlock-taskWaiting r)
-	 (taskControlBlock-taskWaiting initialState))
-    (set (taskControlBlock-taskHolding r)
-	 (taskControlBlock-taskHolding initialState))
-    (set (taskControlBlock-handle r) privateData)
-    (set (taskControlBlock-state r) nil)
-    r))
-
-(define (addInput tcb packet oldTask)
-  (if (equal? noWork (taskControlBlock-input tcb))
-      (block
-       (set (taskControlBlock-input tcb) packet)
-       (set (taskControlBlock-packetPending tcb) t)
-       (if (> (taskControlBlock-priority tcb)
-	      (taskControlBlock-priority oldTask))
-	   tcb
-	   oldTask))
-      (block
-       (set (taskControlBlock-input tcb)
-	    (appendHead packet (taskControlBlock-input tcb)))
-       oldTask)))
-
-(define (runTask tcb)
-  (lset message nil)
-  (if (isWaitingWithPacket tcb)
-      (block
-       (set message (taskControlBlock-input tcb))
-       (set (taskControlBlock-input tcb) (packet-link message))
-       (if (equal? noWork (taskControlBlock-input tcb))
-	   (running tcb)
-	   (packetNowPending tcb)))
-      (set message noWork))
-  (run (taskControlBlock-handle tcb) message))
-
-(define (create-packet link identity kind)
-  (let ((p (make-packet)))
-    (set (packet-link p) link)
-    (set (packet-identity p) identity)
-    (set (packet-kind p) kind)
-    (set (packet-datum p) 1)
-    (let ((v (make-vector 4)))
-      (vector-fill v 0)
-      (set (packet-data p) v))
-    p))
-
-(define (create-deviceTaskDataRecord)
-  (let ((tk (make-deviceTaskDataRecord)))
-    (set (deviceTaskDataRecord-pending tk) noWork)
-    tk))
-
-(define (create-handlerTaskDataRecord)
-  (let ((tk (make-handlerTaskDataRecord)))
-    (set (handlerTaskDataRecord-workIn tk) noWork)
-    (set (handlerTaskDataRecord-deviceIn tk) noWork)
-    tk))
-
-(define (deviceInAdd tk packet)
-  (set (handlerTaskDataRecord-deviceIn tk)
-       (appendHead packet (handlerTaskDataRecord-deviceIn tk)))
-  tk)
-
-(define (workInAdd tk packet)
-  (set (handlerTaskDataRecord-workIn tk)
-       (appendHead packet (handlerTaskDataRecord-workIn tk)))
-  tk)
-
-(define (create-idleTaskDataRecord)
-  (let ((tk (make-idleTaskDataRecord)))
-    (set (idleTaskDataRecord-control tk) 1)
-    (set (idleTaskDataRecord-count tk) 10000)
-    tk))
-
-(define (create-workerTaskDataRecord)
-  (let ((tk (make-workerTaskDataRecord)))
-    (set (workerTaskDataRecord-destination tk) handlerA)
-    (set (workerTaskDataRecord-count tk) 0)
-    tk))
diff --git a/benchmarks/richards/tasks.c b/benchmarks/richards/tasks.c
deleted file mode 100644
index 6d4b6ef637a67f93fe3ffdccd3e5ac8d50b4aab0..0000000000000000000000000000000000000000
--- a/benchmarks/richards/tasks.c
+++ /dev/null
@@ -1,153 +0,0 @@
-/* tasks.c */
-
-#include "tasks.h"
-#include "richards.h"
-
-/*
-// TaskControlBlock
-*/
-
-TaskControlBlock::TaskControlBlock(TaskControlBlock *l, Identity id, int prio,
-                         Packet *initialWork, TaskState *initialState,
-                         void *privateData)
-{
-    link = l; ident = id; priority = prio; input = initialWork;
-    packetPending = initialState->IsPacketPending();
-    taskWaiting = initialState->IsTaskWaiting();
-    taskHolding = initialState->IsTaskHolding();
-    handle = privateData;
-}
-
-
-TaskControlBlock *TaskControlBlock::AddPacket(Packet *p,
-                                              TaskControlBlock *oldTask)
-{
-    if (input == NoWork) {
-         input = p;
-         packetPending = TRUE;
-         if (priority > oldTask->priority) return this;
-    }
-    else AddToList(input, p);
-    return oldTask;
-}
-
-
-TaskControlBlock *TaskControlBlock::RunTask()
-{   Packet *msg;
-
-    if (IsWaitingWithPacket()) {
-         msg = input;
-         input = input->Link();
-         if (input == NoWork)
-              Running();
-         else PacketPending();
-    }
-    else msg = NoWork;
-    return this->ActionFunc(msg, handle);
-}
-
-
-/*
-// action functions
-*/
-
-TaskControlBlock *TaskControlBlock::ActionFunc(Packet *p, void *handle)
-{
-    p, handle, 0;
-    printf("***error: virtual TaskControlBlock.ActionFunc called!\n");
-    return NoTask;
-}
-
-
-TaskControlBlock *DeviceTCB::ActionFunc(Packet *p, void *handle)
-{   DeviceTaskRec *data = (DeviceTaskRec *)handle;
-
-    if (p == NoWork) {
-         if ((p = data->Pending()) == NoWork)
-              return bm.Wait();
-         else {
-              data->SetPending(NoWork);
-              return bm.QueuePacket(p);
-         }
-    }
-    else {
-         data->SetPending(p);
-         if (bm.tracing) bm.Trace(p->Datum());
-         return bm.HoldSelf();
-    }
-}
-
-
-TaskControlBlock *HandlerTCB::ActionFunc(Packet *p, void *handle)
-{   HandlerTaskRec *data = (HandlerTaskRec *)handle;
-    Packet *work, *devicePacket;
-    int count;
-
-    if (p != NoWork) {
-         if (p->Kind() == WorkPacket)
-              data->WorkInAdd(p);
-         else data->DeviceInAdd(p);
-    }
-    if ((work = data->WorkIn()) == NoWork)
-         return bm.Wait();
-    else {
-         count = work->Datum();
-         if (count > 4) {
-              data->SetWorkIn(work->Link());
-              return bm.QueuePacket(work);
-         }
-         else {
-              if ((devicePacket = data->DeviceIn()) == NoWork)
-                   return bm.Wait();
-              else {
-                   data->SetDeviceIn(devicePacket->Link());
-                   devicePacket->SetDatum(work->Data()[count-1]);
-                   work->SetDatum(count + 1);
-                   return bm.QueuePacket(devicePacket);
-              }
-         }
-    }
-}
-
-
-TaskControlBlock *IdlerTCB::ActionFunc(Packet *p, void *handle)
-/* p is not used here */
-{   IdleTaskRec *data = (IdleTaskRec *)handle;
-
-    p, 0;
-
-    data->SetCount(data->Count() - 1);
-    if (data->Count() == 0)
-         return bm.HoldSelf();
-    else if ((data->Control() & 1) == 0) {
-              data->SetControl(data->Control() / 2);
-              return bm.Release(DeviceA);
-         }
-         else {
-              data->SetControl((data->Control() / 2) ^ 53256);
-              return bm.Release(DeviceB);
-         }
-}
-
-
-TaskControlBlock *WorkerTCB::ActionFunc(Packet *p, void *handle)
-{   WorkerTaskRec *data = (WorkerTaskRec *)handle;
-    Identity dest;
-
-    if (p == NoWork)
-         return bm.Wait();
-    else {
-         dest = (data->Destination() == HandlerA) ? HandlerB : HandlerA;
-         data->SetDestination(dest);
-         p->SetIdent(dest);
-         p->SetDatum(1);
-         for(int i = 0; i < 4; i++) {
-              data->SetCount(data->Count() + 1);
-              if (data->Count() > 26) data->SetCount(1);
-              p->Data()[i] = 'A' + data->Count();
-         }
-         return bm.QueuePacket(p);
-    }
-}
-
-
diff --git a/benchmarks/richards/tasks.h b/benchmarks/richards/tasks.h
deleted file mode 100644
index 295bde66d51a37b0ff86450173c59c57615dd96e..0000000000000000000000000000000000000000
--- a/benchmarks/richards/tasks.h
+++ /dev/null
@@ -1,122 +0,0 @@
-/* tasks.h - definitions of TaskState, TaskControlBlock and xxxTCB 
- * The subclasses of TaskControlBlock differ only in their
- * implementation of the action function 				  */
-
-#ifndef TASKS
-
-#define TASKS
-
-#include "types.h"
-
-/*
-// TaskState
-*/
-
-class TaskState {
-    protected:
-        BOOLEAN packetPending, taskWaiting, taskHolding;
-	
-    public:
-        /* initializing */
-        TaskState() {packetPending = TRUE; taskWaiting = taskHolding = FALSE;}
-	void PacketPending() {packetPending = TRUE; taskHolding = taskWaiting = FALSE;}
-	void Waiting() {packetPending = taskHolding = FALSE; taskWaiting = TRUE;}
-	void Running() {packetPending = taskWaiting = taskHolding = FALSE;}
-	void WaitingWithPacket() {packetPending = taskWaiting = TRUE; taskHolding = FALSE;}
-	/* accessing */
-	BOOLEAN IsPacketPending() {return packetPending;}
-	BOOLEAN IsTaskWaiting() {return taskWaiting;}
-	BOOLEAN IsTaskHolding() {return taskHolding;}
-	void SetTaskHolding(BOOLEAN state) {taskHolding = state;}
-	void SetTaskWaiting(BOOLEAN state) {taskWaiting = state;}
-	/* testing */
-	BOOLEAN IsRunning() {return !packetPending && !taskWaiting && !taskHolding;}
-	BOOLEAN IsTaskHoldingOrWaiting() {return taskHolding || !packetPending && taskWaiting;}
-	BOOLEAN IsWaiting() {return !packetPending && taskWaiting && !taskHolding;}
-	BOOLEAN IsWaitingWithPacket() {return packetPending && taskWaiting && !taskHolding;}
-};
-
-/*
-// TaskControlBlock
-*/
-
-class TaskControlBlock : public TaskState {
-
-    protected:
-        TaskControlBlock *link;
-	Identity ident;
-	int priority;
-	Packet *input;
-	void *handle;
-	
-    public:
-        /* initializing */
-        TaskControlBlock(TaskControlBlock *l, Identity id, int prio,
-                         Packet *initialWork, TaskState *initialState,
-                         void *privateData);
-	/* accessing */
-        Identity Ident() {return ident;}
-        int Priority() {return priority;}
-        TaskControlBlock *Link() {return link;}
-	/* scheduling */
-        TaskControlBlock *AddPacket(Packet *p, TaskControlBlock *old);
-        virtual TaskControlBlock *ActionFunc(Packet *p, void *handle);
-        TaskControlBlock *RunTask();
-};
-
-/*
-// DeviceTCB 
-*/
-
-class DeviceTCB : public TaskControlBlock {
-    public:
-        DeviceTCB(TaskControlBlock *l, Identity id, int prio,
-                  Packet *initialWork, TaskState *initialState,
-                  void *privateData) :
-                 (l, id, prio, initialWork, initialState, privateData){}
-        TaskControlBlock *ActionFunc(Packet *p, void *handle);
-};
-
-
-/*
-// HandlerTCB
-*/
-
-class HandlerTCB : public TaskControlBlock {
-    public:
-        HandlerTCB(TaskControlBlock *l, Identity id, int prio,
-                   Packet *initialWork, TaskState *initialState,
-                   void *privateData) :
-                  (l, id, prio, initialWork, initialState, privateData){}
-        TaskControlBlock *ActionFunc(Packet *p, void *handle);
-};
-
-
-/*
-// IdlerTCB
-*/
-
-class IdlerTCB : public TaskControlBlock {
-    public:
-        IdlerTCB(TaskControlBlock *l, Identity id, int prio,
-                 Packet *initialWork, TaskState *initialState,
-                 void *privateData) :
-                (l, id, prio, initialWork, initialState, privateData){}
-        TaskControlBlock *ActionFunc(Packet *p, void *handle);
-};
-
-
-/*
-// WorkerTCB
-*/
-
-class WorkerTCB : public TaskControlBlock {
-    public:
-        WorkerTCB(TaskControlBlock *l, Identity id, int prio,
-                  Packet *initialWork, TaskState *initialState,
-                  void *privateData) :
-                 (l, id, prio, initialWork, initialState, privateData){}
-        TaskControlBlock *ActionFunc(Packet *p, void *handle);
-};
-
-#endif
diff --git a/benchmarks/richards/types.c b/benchmarks/richards/types.c
deleted file mode 100644
index 81bc9ef272bd9d1ed19abb520f5671bd601146e8..0000000000000000000000000000000000000000
--- a/benchmarks/richards/types.c
+++ /dev/null
@@ -1,28 +0,0 @@
-/* types.c */
-
-#include "types.h"
-
-/*
-// AddToList - list utility (append elem at end of list, return head)
-*/
-Packet *AddToList(Packet *list, Packet *elem)
-{   Packet *p, *next;
-
-    elem->SetLink(NoWork);
-    if (list != NoWork) {
-         p = list;
-         while((next = p->Link()) != NoWork) p = next;
-         p->SetLink(elem);
-    }
-    else list = elem;
-    return list;
-}
-
-Packet::Packet(Packet *l, Identity id, PacketKind k)
-{
-    link = l;
-    ident = id;
-    kind = k;
-    datum = 1;
-    for(int i = 0; i < 4; i++) data[i] = 0;
-}
diff --git a/benchmarks/richards/types.h b/benchmarks/richards/types.h
deleted file mode 100644
index ab9578b329fd44e637fcccc1efd4e6f528ac9c3f..0000000000000000000000000000000000000000
--- a/benchmarks/richards/types.h
+++ /dev/null
@@ -1,100 +0,0 @@
-/* types.h -- basic classes (Packet, {Device,Idle,...}TaskRec)	*/
-
-#include "cbase.h"
-#include "rbase.h"
-
-/*
-// Packet
-*/
-
-class Packet {
-    private:
-        Packet *link;		// next packet in queue
-	Identity ident;		// Idle, Worker, DeviceA, ...
-	PacketKind kind;	// DevicePacket or WorkPacket
-	int datum;
-	char data[4];
-    public:
-        Packet(Packet *l, Identity id, PacketKind k);
-	char *Data() {return data;}
-	void SetData(char d[4]) {for(int i=0; i < 4; i++) data[i] = d[i];}
-        int Datum() {return datum;}
-        void SetDatum(int n) {datum = n;}
-	Identity Ident() {return ident;}
-	void SetIdent(Identity i) {ident = i;}
-	PacketKind Kind() {return kind;}
-	void SetKind(PacketKind k) {kind = k;}
-	Packet *Link() {return link;}
-	void SetLink(Packet *l) {link = l;}
-};
-
-/*
-// AddToList - list utility (append elem at end of list, return head)
-*/
-Packet *AddToList(Packet *list, Packet *elem);
-
-/*
-// DeviceTaskRec
-*/
-
-class DeviceTaskRec {
-    private:
-        Packet *pending;
-    public:
-        DeviceTaskRec() {pending = NoWork;}
-	Packet *Pending() {return pending;}
-	void SetPending(Packet *p) {pending = p;}
-};
-
-
-
-/*
-// IdleTaskRec 
-*/
-
-class IdleTaskRec {
-    private:
-        int control, count;
-    public:
-        IdleTaskRec() {control = 1; count = 10000;}
-        int Control() {return control;}
-        void SetControl(int n) {control = n;}
-        int Count() {return count;}
-        void SetCount(int n) {count = n;}
-};
-
-
-/*
-// HandlerTaskRec
-*/
-
-class HandlerTaskRec {
-    private:
-        Packet *workIn, *deviceIn;
-    public:
-        HandlerTaskRec() {workIn = deviceIn = NoWork;}
-        Packet *WorkIn() {return workIn;}
-        void SetWorkIn(Packet *p) {workIn = p;}
-        Packet *WorkInAdd(Packet *p) {return workIn = AddToList(workIn, p);}
-        Packet *DeviceIn() {return deviceIn;}
-        void SetDeviceIn(Packet *p) {deviceIn = p;}
-        Packet *DeviceInAdd(Packet *p) {return deviceIn = AddToList(deviceIn, p);}
-};
-
-
-/*
-// WorkerTaskRec
-*/
-
-class WorkerTaskRec {
-    private:
-        Identity destination;
-	int count;
-    public:
-        WorkerTaskRec() {destination = HandlerA; count = 0;}
-        int Count() {return count;}
-        void SetCount(int n) {count = n;}
-        Identity Destination() {return destination;}
-        void SetDestination(Identity d) {destination = d;}
-};
-
diff --git a/benchmarks/soar/default.soar b/benchmarks/soar/default.soar
deleted file mode 100644
index 5ecbc6ff79684f37aeefde295a75e61899844696..0000000000000000000000000000000000000000
--- a/benchmarks/soar/default.soar
+++ /dev/null
@@ -1,705 +0,0 @@
-(comment default soar  version 4.0)
-(comment inter-lisp version  go to lower case for other versions)
-
-(comment this production gathers all relevant preferences and makes them
-         available to the decision procedure through the decide action.
-         users should never create decide productions)
-
-(sp decision*gather-preferences decide
-    (gc <g> ^problem-space <p> ^state <s> ^operator <q>)
-    (preference <id> ^role <role> ^value <value> ^reference <c> 
-		^goal <g> ^problem-space <p> ^state <s> ^operator <q>)
-    -->
-    (decide ^goal <g> ^identifier <id> ^role <role> ^value <value> ^reference <c>))
-
-
-
-(comment ****** common search-control productions ******)
-
-(comment all operator augmentations of the problem space have
-         acceptable-preferences created for them)
-
-(sp default*make-all-operators-acceptable
-  (gc <g> ^problem-space <p>)
-  (problem-space <p> ^operator <x>)
- -(preference <x> ^role operator ^value acceptable ^problem-space <p>)
-  -->
-  (preference <x> ^role operator ^value acceptable
-    ^problem-space <p>))
-
-
-(comment if an operator has just been applied to a state -
-         detected by using the preference created for that state -
-         reject the operator for that state so it will not be reapplied
-         in the future)
-
-(sp default*no-operator-retry
-    (gc <g> ^problem-space <p> ^state <s2>)
-    (preference ^object <s2> ^role state ^value acceptable
-		^goal <g> ^problem-space <p> ^state <s>
-		^operator { <> undecided <> nil <q> })
-    -->
-    (preference <q> ^role operator ^value reject
-	  ^goal <g> ^problem-space <p> ^state <s>))
-
-
-(comment if there is a reject-preference for the current state - 
-         make an acceptable-preference for the prior state so problem
-         solving can backup)
-
-(sp default*backup-if-failed-state
-    (gc <g> ^problem-space <p> ^state <s>)
-    (preference <s> ^role state ^value reject 
-		^goal <g> ^problem-space <p>)
-    (preference <s> ^role state ^value acceptable
-		^goal <g> ^problem-space <p> ^state { <> undecided <> nil <n> }
-		^operator <> undecided)
-    --> 
-    (preference <n> ^role state ^value acceptable
-	  ^goal <g> ^problem-space <p> ^state <s>))
-
-(comment ****** default knowledge for impasses ******
-         ****** tie impasses ******)
-
-(comment if the problem space for handling the subgoal fails -
-         signified by the choices none impasse below it -
-         make a worst-preference for each tied object)
-
- (sp default*problem-space-tie
-    (gc <g3> ^role goal ^choices none ^supergoal <g2>)
-    (gc <g2> ^role problem-space ^impasse tie ^supergoal <g1>
-		^item <p>)
-     -->
-    (preference <p> ^role problem-space ^value worst
-		^goal <g1>))
-
-(sp default*state-tie
-    (gc <g3> ^role goal ^choices none ^supergoal <g2>)
-    (gc <g2> ^role state ^impasse tie ^supergoal <g1> ^item <s>)
-    (gc <g1> ^problem-space <p>)
-     -->
-    (preference <s> ^role state ^value worst
-		^goal <g1> ^problem-space <p>))
-
-(sp default*operator-tie
-    (gc <g3> ^role goal ^choices none ^supergoal <g2>)
-    (gc <g2> ^role operator ^impasse tie ^supergoal <g1>
-		^item <q>)
-    (gc <g1> ^problem-space <p> ^state <s>)
-     -->
-    (preference <q> ^role operator ^value worst
-		^goal <g1> ^problem-space <p> ^state <s>))
-
-
-(comment ****** conflict impasses ******)
-
-(comment if the problem space for handling the subgoal fails -
-         signified by the choices none impasse below it -
-         make a reject-preference for each conflicted object)
-
- (sp default*problem-space-conflict
-    (gc <g3> ^role goal ^choices none ^supergoal <g2>)
-    (gc <g2> ^role problem-space ^impasse conflict ^supergoal <g1>
-		^item <p>)
-     -->
-    (preference <p> ^role problem-space ^value reject
-		^goal <g1>))
-
-(sp default*state-conflict
-    (gc <g3> ^role goal ^choices none ^supergoal <g2>)
-    (gc <g2> ^role state ^impasse conflict
-		^supergoal <g1> ^item <s>)
-    (gc <g1> ^problem-space <p>)
-     -->
-    (preference <s> ^role state ^value reject
-		^goal <g1> ^problem-space <p>))
-
-(sp default*operator-conflict
-    (gc <g3> ^role goal ^choices none ^supergoal <g2>)
-    (gc <g2> ^role operator ^impasse conflict ^supergoal <g1>
-		^item <q>)
-    (gc <g1> ^problem-space <p> ^state <s>)
-     -->
-    (preference <q> ^role operator ^value reject
-		^goal <g1> ^problem-space <p> ^state <s>))
-
-
-(comment ****** no-choice impasses ******)
-
-(comment if no problem spaces are available for the top goal -
-         terminate the problem solving session with halt)
-
-(sp default*goal-no-choices
-    (gc <g3> ^role goal ^choices none ^supergoal <g2>)
-   -(gc <g2> ^supergoal)
-    -->
-    (write1 (crlf) "No problem space can be selected for top goal.")
-    (write1 (crlf) "Soar must terminate.")
-    (halt))
-
-
-(comment if no states are available for a problem space -
-         and there is no problem space to find more -
-         reject that problem space)
-
-(sp default*problem-space-no-choices
-    (gc <g3> ^role goal ^choices none ^supergoal <g2>)
-    (gc <g2> ^role problem-space ^choices none ^supergoal <g1>)
-    (gc <g1> ^problem-space <p>)
-    -->
-    (preference <p> ^role problem-space ^value reject ^goal <g1>))
-
-
-(comment if no operators are available for a state -
-         and there is no problem space to find more -
-         reject that state)
-
-(sp default*state-no-choices
-    (gc <g3> ^role goal ^choices none ^supergoal <g2>)
-    (gc <g2> ^role state ^choices none ^supergoal <g1>)
-    (gc <g1> ^problem-space <p> ^state <s>)
-     -->
-    (preference <s> ^role state ^value reject
-		^goal <g1> ^problem-space <p>))
-
-(comment if no changes for an operator -
-         and there is no problem space to find more -
-         reject that operator)
-
-(sp default*operator-no-choices
-    (gc <g3> ^role goal ^choices none ^supergoal <g2>)
-    (gc <g2> ^role operator ^impasse no-change ^supergoal <g1>)
-    (gc <g1> ^problem-space <p> ^state <s> ^operator <q>)
-    -->
-    (preference <q> ^role operator ^value reject
-	  ^goal <g1> ^problem-space <p> ^state <s>))
-
-
-(comment ************** selection problem space ****************)
-
-
-(comment use the selection problem space for all choice multiple
-         impasses - make it worst so that any other will dominate)
-
-(sp select*selection-space elaborate
-    (gc <g> ^choices multiple)
-    -->
-    (preference <p> ^role problem-space ^value acceptable ^goal <g>)
-    (preference <p> ^role problem-space ^value worst ^goal <g>)
-    (problem-space <p> ^name selection))
-
-
-(comment the state of the selection problem space is empty)
-
-(sp select*create-state
-   (gc <g> ^problem-space <p> ^state undecided)
-   (space <p> ^name selection)
-   -->
-   (preference <s> ^role state ^value acceptable 
-	^goal <g> ^problem-space <p> ^state undecided))
-
-
-
-(comment ************** evaluate-object operator ****************)
-
-
-(comment create evaluate operator in selection problem space)
-
-(sp eval*select-evaluate 
-   (gc <g> ^problem-space <p> ^state <s> ^supergoal <g2> ^item <x>)
-   (problem-space <p> ^name selection)
-   -->
-   (operator <o> ^state <s> ^name evaluate-object ^object <x>)
-   (preference <o> ^role operator ^value indifferent
-	^goal <g> ^problem-space <p> ^state <s> )
-   (preference <o> ^role operator ^value acceptable
-	^goal <g> ^problem-space <p> ^state <s> ))
-
-
-(comment for parallel evaluation
-         remove this comment if you want parallel evaluation of
-         the alternatives.
-
-(sp eval*parallel-evaluate 
-   (gc <g> ^problem-space <p> ^state <s> ^role operator ^supergoal <g2>)
-   (problem-space <p> ^name selection )
-   (operator <q1> ^state <s> ^object <y>)
-   (operator <q2> ^state <s> ^object { <> <y> <x> })
-   -->
-   (preference <q1> ^role operator ^value parallel 
-	^goal <g> ^problem-space <p> ^state <s> ^reference <q2>)))
-
-
-(comment create evaluation once the eval operator is selected)
-
-(sp eval*apply-evaluate 
-   (gc <g> ^problem-space <p> ^state <s> ^operator <q>
-	^role <role> ^supergoal <g2>)
-   (problem-space <p> ^name selection)
-   (gc <g2> ^problem-space <p2> ^state <s2> ^desired <d>)
-   (operator <q> ^name evaluate-object ^object <x>)
-   -->
-   (state <s> ^evaluation <e>)
-   (evaluation <e> ^object <x> ^state <s> ^operator <q> ^desired <d>)
-   (operator <q> ^role <role> ^evaluation <e> ^desired <d>
-	^supergoal <g2> ^superproblem-space <p2> ^superstate <s2>))
-
-
-(comment reject evaluate-object after it finished in selection space)
-
-(sp eval*reject-evaluate-finished elaborate
-   (gc <g> ^problem-space <p> ^state <s> ^operator <q>)
-   (problem-space <p> ^name selection)
-   (operator <q> ^name evaluate-object ^evaluation <e>)
-   (evaluation <e> ^ << numeric-value symbolic-value >>)
-   -->
-   (preference <q> ^role operator ^value reject ^goal <g> 
-	 ^problem-space <p> ^state <s>))
-
-
-(comment if two objects have equal evaluations they are indifferent)
-
-(sp eval*equal-eval-indifferent-preference
-   (gc <g> ^problem-space <p> ^state <s>	^role <role> ^supergoal <g2>)
-   (problem-space <p> ^name selection)
-   (state <s> ^evaluation <e1> ^evaluation { <> <e1> <e2> })
-   (gc <g2> ^problem-space <p2> ^state <s2> ^desired <d>)
-   (evaluation <e1> ^object <x> ^numeric-value <v> ^desired <d>)
-   (evaluation <e2> ^object <y> ^numeric-value <v> ^desired <d>)
-   -->
-   (preference <x> ^role <role> ^value indifferent ^reference <y>
-	 ^goal <g2> ^problem-space <p2> ^state <s2>))
-
-
-(comment generate operator preferences based on their evaluations and info 
-         as to whether higher or lower evaluations are better)
-
-(sp eval*prefer-higher-evaluation
-   (gc <g> ^problem-space <p> ^state <s>	^role <role> ^supergoal <g2>)
-   (problem-space <p> ^name selection)
-   (gc <g2> ^problem-space <p2> ^state <s2> ^desired <d>)
-   (state <s> ^evaluation <e1> ^evaluation { <> <e1> <e2> })
-   (evaluation <d> ^better higher)
-   (evaluation <e1> ^object <q1> ^numeric-value <v> ^desired <d>)
-   (evaluation <e2> ^object <q2> ^numeric-value < <v> ^desired <d>)
-   -->
-   (preference <q2> ^role <role> ^value worse ^reference <q1>
-	 ^goal <g2> ^problem-space <p2> ^state <s2>))
-
-(sp eval*prefer-lower-evaluation
-   (gc <g> ^problem-space <p> ^state <s>	^role <role> ^supergoal <g2>)
-   (problem-space <p> ^name selection)
-   (gc <g2> ^problem-space <p2> ^state <s2> ^desired <d>)
-   (state <s> ^evaluation <e1> ^evaluation { <> <e1> <e2> })
-   (evaluation <d> ^better lower)
-   (evaluation <e1> ^object <q1> ^numeric-value <v> ^desired <d>)
-   (evaluation <e2> ^object <q2> ^numeric-value > <v> ^desired <d>)
-   -->
-   (preference <q2> ^role operator ^value worse ^reference <q1>
-	 ^goal <g2> ^problem-space <p2> ^state <s2>))
-
-(comment productions that fire in the evaluation subgoal)
-
-
-(comment copy down the desired and create the appropriate context -
-         given the role of the object being evaluated)
-
-(sp eval*select-role-problem-space
-   (gc <g> ^problem-space undecided ^supergoal <g2> ^superoperator <q2>)
-   (gc <g2> ^operator <q2>)
-   (operator <q2> ^name evaluate-object ^role problem-space ^object <p> ^desired <d>)
-   -->
-   (gc <g> ^desired <d>)
-   (preference <p> ^role problem-space ^value acceptable ^goal <g>))
-
-
-(sp eval*select-role-state
-   (gc <g> ^problem-space undecided ^supergoal <g2> ^superoperator <q2>)
-   (gc <g2> ^operator <q2>)
-   (operator <q2> ^name evaluate-object ^role state ^object <s>
-	^superproblem-space <p> ^desired <d>)
-   -->
-   (gc <g> ^desired <d>)
-   (preference <p> ^role problem-space ^value acceptable ^goal <g>)
-   (preference <s> ^role state ^value acceptable
-	^goal <g> ^problem-space <p> ^state undecided)
-   (preference <s> ^role state ^value best
-	^goal <g> ^problem-space <p> ^state undecided))
-
-
-(sp eval*select-role-operator
-   (gc <g> ^problem-space undecided ^supergoal <g2> ^superoperator <q2>)
-   (gc <g2> ^operator <q2>)
-   (operator <q2> ^name evaluate-object ^role operator ^object <q>
-	^superproblem-space <p> ^superstate <s> ^desired <d>)
-   -->
-   (gc <g> ^desired <d>)
-   (preference <p> ^role problem-space ^value acceptable ^goal <g>)
-   (preference <s> ^role state ^value acceptable
-	^goal <g> ^problem-space <p> ^state undecided)
-   (preference <q> ^role operator ^value acceptable
-	 ^goal <g> ^problem-space <p> ^state <s>))
-
-
-(sp eval*reject-non-slot-operator
-   (gc <g> ^problem-space <p> ^state <s> ^supergoal <g2> ^superoperator <q2>)
-   (operator <q2> ^name evaluate-object ^role operator ^object <q>
-	 ^superstate <s>)
-   (preference { <> <q> <q3> } ^role operator ^value acceptable
-	 ^goal <g> ^problem-space <p> ^state <s>)
-   -->
-   (preference <q3> ^role operator ^value reject
-	 ^goal <g> ^problem-space <p> ^state <s>))
-
-(comment give symbol-value failure to an operator that has been rejected
-         during evaluation and did not create a new state and reject the eval-operator)
-
-(sp eval*failure-if-reject-evaling-operator 
-   (gc <g> ^problem-space <p> ^state <s> ^operator <q> 
-	^supergoal <g2> ^superoperator <q2>)
-   (gc <g2> ^problem-space <p2> ^state <s2>)
-   (operator <q2> ^name evaluate-object ^role operator
-	^object <q> ^superstate <s> ^evaluation <e2>)
-   (preference <q> ^role operator ^value reject
-	^goal <g> ^problem-space <p> ^state <s> ^operator <q>)
-  -(preference ^role state ^value acceptable
-	^goal <g> ^problem-space <p> ^state <s> ^operator <q>)
-   -->
-   (evaluation <e2> ^symbolic-value failure))
-
-(comment give symbol-value failure to an operator 
-         that produces a state that gets rejected in the subgoal)
-
-(sp eval*failure-if-reject-state 
-   (gc <g> ^problem-space <p> ^state <s>
-	^supergoal <g2> ^superoperator <q2>)
-   (gc <g2> ^problem-space <p2> ^state <s2>)
-   (operator <q2> ^name evaluate-object ^evaluation <e2>)
-   (preference <s> ^role state ^value reject
-	^goal <g> ^problem-space <p>)
-   -->
-   (evaluation <e2> ^symbolic-value failure))
-
-
-
-(comment if an operator leads to success and it is being
-         tried out in a subgoal to evaluate another operator -
-         give that second operator a success evaluation also)
-
-(sp eval*pass-back-success elaborate	
-   (gc <g> ^problem-space <p> ^state <s> ^operator <q> ^supergoal <g2>)
-   (problem-space <p> ^name selection)
-   (operator <q> ^name evaluate-object ^evaluation <e1> ^desired <eb>)
-   (evaluation <e1> ^symbolic-value success)
-   (gc <g2> ^superoperator <q3>)
-   (operator <q3> ^name evaluate-object ^evaluation <e2> ^desired <eb>)
-   -->
-   (evaluation <e2> ^symbolic-value success))
-
-
-(comment if an operator is evaluated to be lose or failure -
-         create a worst-preference for it)
-
-(sp eval*failure-becomes-worst
-   (gc <g> ^problem-space <p> ^state <s> ^operator <q> ^supergoal <g2>)
-   (problem-space <p> ^name selection)
-   (gc <g2> ^problem-space <p2> ^state <s2> ^desired <e>)
-   (operator <q> ^name evaluate-object ^evaluation <e1> ^desired <e>
-	^role <role> ^object <q1>)
-   (evaluation <e1> ^symbolic-value << lose failure >>)
-   -->
-   (preference <q1> ^role operator ^value worst
-	 ^goal <g2> ^problem-space <p2> ^state <s2>))
-
-
-(comment if an operator is evaluated to be success -
-         create a best-preference for it)
-
-(sp eval*success-becomes-best	
-   (gc <g> ^problem-space <p> ^state <s> ^operator <q> ^supergoal <g2>)
-   (problem-space <p> ^name selection)
-   (gc <g2> ^problem-space <p2> ^state <s2> ^desired <eb>)
-   (operator <q> ^name evaluate-object ^evaluation <e1> 
-	 ^desired <eb> ^object <q1> ^role <role>)
-   (evaluation <e1> ^symbolic-value success)
-   -->
-   (preference <q1> ^role <role> ^value best
-	 ^goal <g2> ^problem-space <p2> ^state <s2>))
-
-
-(comment convert state augmentations into evaluations)
-
-(sp eval*state-to-evaluation-success
-   (gc <g> ^problem-space <p> ^state <s> ^superoperator <sq>)
-   (operator <sq> ^name evaluate-object 
-	^evaluation <e> ^desired <eb>)
-   (state <s> ^success <eb> )
-   -->
-   (evaluation <e> ^symbolic-value success))
-
-(sp eval*state-to-evaluation-failure
-   (gc <g> ^problem-space <p> ^state <s> ^superoperator <sq>)
-   (operator <sq> ^name evaluate-object 
-	^evaluation <e> ^desired <eb>)
-   (state <s> ^failure <eb> )
-   -->
-   (evaluation <e> ^symbolic-value failure))
-
-(sp eval*state-to-evaluation-win
-   (gc <g> ^problem-space <p> ^state <s> ^superoperator <sq>)
-   (operator <sq> ^name evaluate-object 
-	^evaluation <e> ^desired <eb>)
-   (state <s> ^win <eb> )
-   -->
-   (evaluation <e> ^symbolic-value win))
-
-(sp eval*state-to-evaluation-draw
-   (gc <g> ^problem-space <p> ^state <s> ^superoperator <sq>)
-   (operator <sq> ^name evaluate-object 
-	^evaluation <e> ^desired <eb>)
-   (state <s> ^draw <eb> )
-   -->
-   (evaluation <e> ^symbolic-value draw))
-
-(sp eval*state-to-evaluation-lose
-   (gc <g> ^problem-space <p> ^state <s> ^superoperator <sq>)
-   (operator <sq> ^name evaluate-object 
-	^evaluation <e> ^desired <eb>)
-   (state <s> ^lose <eb> )
-   -->
-   (evaluation <e> ^symbolic-value lose))
-
-
-
-(comment handle state augmentations dealing with goal
-         termination for the top-level goal)
-
-(sp eval*detect-success
-  (gc <g> ^state <s> ^name <name> ^desired <eb> -^supergoal) 
-  (state <s> ^success <eb>)
-  -->
-  (write1 (crlf) "GOAL" <name> "ACHIEVED")
-  (halt))
-
-(sp eval*detect-win
-  (gc <g> ^state <s> ^name <name> -^supergoal ^desired <eb>) 
-  (state <s> ^win <eb>)
-  -->
-  (write1 (crlf) "GAME" <name> "WON")
-  (halt))
-
-(sp eval*detect-failure
-  (gc <g> ^state <s> ^name <name> -^supergoal ^desired <eb>) 
-  (state <s> ^failure <eb>)
-  -->
-  (preference <s> ^role state ^value reject
-	^goal <g> ^problem-space <p>))
-
-(sp eval*detect-lose
-  (gc <g> ^state <s> ^name <name> -^supergoal ^desired <eb>) 
-  (state <s> ^lose <eb>)
-  -->
-  (write1 (crlf) "GAME" <name> "LOST")
-  (halt))
-
-
-(comment two player games - win side oside lose)
-
-(sp eval*move-side-to-eval 	
-   (gc <g> ^state <s> ^superoperator <sq>)
-   (state <s> ^oside <side> ^ << lose win >>)
-   (operator <sq> ^name evaluate-object ^evaluation <e>)
-   -->
-   (evaluation <e> ^side <side>))
-
-(sp eval*winning-values 	
-   (gc <g> ^problem-space <p> ^state <s> ^supergoal <g1> ^operator <q>)
-   (problem-space <p> ^name selection)
-   (gc <g1> ^problem-space <p1> ^state <s1>)
-   (state <s1> ^side <side>)
-   (operator <q> ^name evaluate-object ^evaluation <e> ^object <q1> ^role <role>)
-   (evaluation <e> ^symbolic-value win ^side <side>)
-   -->
-   (preference <q1> ^role <role> ^value best
-	 ^goal <g1> ^problem-space <p1> ^state <s1>))
-
-(sp eval*winning-values2 	
-   (gc <g> ^problem-space <p> ^state <s> ^supergoal <g1> ^operator <q>)
-   (problem-space <p> ^name selection)
-   (gc <g1> ^problem-space <p1> ^state <s1>)
-   (state <s1> ^oside <side>)
-   (operator <q> ^name evaluate-object ^evaluation <e> ^object <q1> ^role <role>)
-   (evaluation <e> ^symbolic-value lose ^side <side>)
-   -->
-   (preference <q1> ^role <role> ^value best
-	 ^goal <g1> ^problem-space <p1> ^state <s1>))
-
-(sp eval*draw-values 	
-   (gc <g> ^problem-space <p> ^state <s> ^supergoal <g1> ^operator <q>)
-   (problem-space <p> ^name selection)
-   (gc <g1> ^problem-space <p1> ^state <s1>)
-   (operator <q> ^name evaluate-object ^evaluation <e> ^object <q1> ^role <role>)
-   (evaluation <e> ^symbolic-value draw)
-   -->
-   (preference <q1> ^role <role> ^value indifferent
-	 ^goal <g1> ^problem-space <p1> ^state <s1>))
-
-(sp eval*losing-values 	
-   (gc <g> ^problem-space <p> ^state <s> ^supergoal <g1> ^operator <q>)
-   (problem-space <p> ^name selection)
-   (gc <g1> ^problem-space <p1> ^state <s1>)
-   (state <s1> ^oside <side>)
-   (operator <q> ^name evaluate-object ^evaluation <e> ^object <q1> ^role <role>)
-   (evaluation <e> ^symbolic-value win ^side <side>)
-   -->
-   (preference <q1> ^role <role> ^value worst
-	 ^goal <g1> ^problem-space <p1> ^state <s1>))
-
-(sp eval*losing-values2 	
-   (gc <g> ^problem-space <p> ^state <s> ^supergoal <g1> ^operator <q>)
-   (problem-space <p> ^name selection)
-   (gc <g1> ^problem-space <p1> ^state <s1>)
-   (state <s1> ^side <side>)
-   (operator <q> ^name evaluate-object ^evaluation <e> ^object <q1> ^role <role>)
-   (evaluation <e> ^symbolic-value lose ^side <side>)
-   -->
-   (preference <q1> ^role <role> ^value worst
-	 ^goal <g1> ^problem-space <p1> ^state <s1>))
-
-(sp eval*pass-back-win 	
-   (gc <g> ^problem-space <p> ^state <s> ^supergoal <g2> ^operator <q>)
-   (problem-space <p> ^name selection)
-   (operator <q> ^name evaluate-object ^evaluation <e1> ^desired <eb>)
-   (evaluation <e1> ^symbolic-value win ^side <side>)
-   (gc <g2> ^superoperator <q3>)
-   (operator <q3> ^name evaluate-object ^evaluation <e2> ^desired <eb>
-	^superstate <s4>)
-   (state <s4> ^oside <side>)
-   -->
-   (evaluation <e2> ^symbolic-value win ^side <side>))
-
-(sp eval*pass-back-win2 	
-   (gc <g> ^problem-space <p> ^state <s> ^supergoal <g2> ^operator <q>)
-   (problem-space <p> ^name selection)
-   (operator <q> ^name evaluate-object ^evaluation <e1> ^desired <eb>)
-   (evaluation <e1> ^symbolic-value lose ^side <side>)
-   (gc <g2> ^superoperator <q3>)
-   (operator <q3> ^name evaluate-object ^evaluation <e2> ^desired <eb>
-	^superstate <s4>)
-   (state <s4> ^side <side>)
-   -->
-   (evaluation <e2> ^symbolic-value win ^side <side>))
-
-(comment **************** operator subgoaling ****************
-         there are two ways to do operator subgoal
-         just pass down most recent operator - or pass down all of them
-         this implementation passes down just the super operator as the
-         desired - uncomment opsub*go-for-it2 if you want all supergoals
-         to be included)
-
-(comment make the super-problem space the default
-         when there is a no-change for the operator)
-
-(sp opsub*try-operator-subgoaling elaborate
-  (gc <g> ^impasse no-change ^role operator 
-	^problem-space undecided ^supergoal <g2>)
-  (gc <g2> ^problem-space <p2>)
-  -->
-  (preference <p2> ^goal <g> ^role problem-space ^value acceptable)
-  (preference <p2> ^goal <g> ^role problem-space ^value worst))
-
-
-(comment if the superproblem-space is selected as the
-         current problem space then operator subgoaling
-         is being used so select the superstate -
-         the superoperator becomes the desired)
-
-(sp opsub*go-for-it elaborate
-  (gc <g> ^problem-space <p> ^state undecided 
-	^impasse no-change ^role operator ^supergoal <g2>)
-  (gc <g2> ^problem-space <p> ^state <s> ^operator <q>)
-  -->
-  (gc <g> ^name operator-subgoal ^desired <q>)
-  (preference <s> ^role state ^value acceptable
-	 ^goal <g> ^problem-space <p> ^state undecided))
-
-
-(comment  pass down all super operator subgoals as well
-(sp opsub*go-for-it2 elaborate
-  (gc <g> ^problem-space <p> ^state undecided 
-	^impasse no-change ^role operator ^supergoal <g2>)
-  (gc <g2> ^problem-space <p> ^state <s> ^desired <q>)
-  -->
-  (gc <g> ^desired <q>)) )
-
-
-(comment don't select the operator for the initial state that we are 
-         subgoaling on)
-
-(sp opsub*reject-opsub*operator
-  (gc <g> ^problem-space <p> ^state <s> ^desired <q>)
-  (op-info ^identifier <q>)
-  (preference <s> ^role state ^value acceptable
-	 ^goal <g> ^problem-space <p> ^state undecided)
-  -->
-  (preference <q> ^role operator ^value reject
-	 ^goal <g> ^problem-space <p> ^state <s>))
-
-
-(comment select superoperator for all new states)
-
-(sp opsub*select-opsub*operator elaborate
-  (gc <g1> ^problem-space <p> ^state <s> ^desired <q>)
-  (op-info ^identifier <q>)
-  -->
-  (preference <q> ^role operator ^value acceptable
-	^goal <g1> ^problem-space <p> ^state <s>)
-  (preference <q> ^role operator ^value best
-	^goal <g1> ^problem-space <p> ^state <s>))
-
-
-(comment if superoperator applied to a state then success
-         we make a preference for the state it created)
-
-(sp opsub*detect-direct-opsub-success elaborate
-  (gc <g0> ^problem-space <p> ^state <s> ^operator <q>
-	 ^supergoal <g1> ^name operator-subgoal)
-  (gc <g1> ^problem-space <p> ^state <s2> ^operator <q>)
-  (preference <ns> ^role state ^value acceptable 
-	^goal <g0> ^problem-space <p> ^state <s> ^operator <q>)
-  -->
-  (preference <ns> ^role state ^value acceptable
-	^goal <g1> ^problem-space <p> ^state <s2> ^operator <q>))
-
-
-(comment if there is an evaluation subgoal within
-         an operator subgoal and the operator being
-         subgoaled on is applied - success)
-
-(sp opsub*detect-indirect-opsub-success elaborate
-  (gc <g1> ^name operator-subgoal ^supergoal <g2>)
-  (gc <g2> ^problem-space <p> ^state <s2> ^operator <q>)
-  (gc <g0> ^problem-space <p> ^state <s> ^operator <q>
-	^desired <q> ^superoperator <sq>)
-  (operator <sq> ^name evaluate-object)
-  (preference <ns> ^role state ^value acceptable 
-	^goal <g0> ^problem-space <p> ^state <s> ^operator <q>)
-  -->
-  (state <s> ^success <q>))
-
-
-(comment if the operator being subgoaled on is the current
-         operator and a no-change subgoal is created for it 
-         then reject it in the subgoal)
-
-(sp opsub*reject-double-op-sub
-  (gc <g1> ^name operator-subgoal ^desired <q>)
-  (gc { <> <g1> <g3> } ^name operator-subgoal)
-  (gc <g3> ^supergoal <g4>)
-  (gc <g4> ^problem-space <p> ^state <s> ^operator <q>)
- -(gc ^supergoal <g3>)
-  -->
-  (preference <q> ^role operator ^value reject
-	^goal <g4> ^problem-space <p> ^state <s>))
-
-nil
diff --git a/benchmarks/soar/eight.soar b/benchmarks/soar/eight.soar
deleted file mode 100644
index 56b31da4cef35badaa4cd4854116a4f3e6c4c2df..0000000000000000000000000000000000000000
--- a/benchmarks/soar/eight.soar
+++ /dev/null
@@ -1,269 +0,0 @@
-(comment eight puzzle for soar 35)
-
-
-(comment this is the eight puzzle problem)
-(comment state structure 
-	each state contains nine bindings
-	the bindings connect together a cell -
-	one of the nine positions on the board -
-	and a tile - one of the movable pieces 
-	the cells have pointers ^cell to each of their
-	adjacent cells 
-	the state also has a pointer to the blank-cell and the cell
-	that the last moved tile is in  this improve efficiency and
-	simplify computations that depend on the previous operator)
-
-(comment each operator contains a pointer to the cell with the blank
-	and the cell with the tile to be moved)
-
-
-
-(multi-attributes  '((state binding 5) (desired binding 5)
-	(operator blank 3) (operator cell 2) (cell cell 4)))
-
-(trace-attributes '((operator tile-cell))) 
-
-(comment name the first subgoal eight-puzzle and create the 
-		problem space and operators)
-
-(sp eight*start
-    (gc <g> ^problem-space undecided - ^supergoal)
-    -->
-    (gc <g> ^name solve-eight-puzzle ^impasse <d> ^desired <d>)
-    (problem-space <p> ^name eight-puzzle)
-    (preference	 <p> ^role problem-space ^value acceptable 
-	^goal <g>))
-
-(comment define the initial state and the impasse state
-		each state is a set of bindings 
-		each binding points to a cell and a tile
-		each cell points to its neighboring cells)
-
-(sp eight*initial-desired-states
-  (gc <g> ^problem-space <p> ^state undecided
-	^name solve-eight-puzzle ^desired <d>)
-  (space <p> ^name eight-puzzle)
-  -->
-  (preference <s> ^role state ^value acceptable
-           ^goal <g> ^problem-space <p> ^state undecided)
-  (tile <t0> ^name 0)   (tile <t1> ^name 1)   (tile <t2> ^name 2)
-  (tile <t3> ^name 3)   (tile <t4> ^name 4)   (tile <t5> ^name 5)
-  (tile <t6> ^name 6)   (tile <t7> ^name 7)   (tile <t8> ^name 8)
-
-  (binding <bb0> ^cell c11 ^tile <t2>) 
-  (binding <bb1> ^cell c12 ^tile <t1>)
-  (binding <bb2> ^cell c13 ^tile <t7>)
-  (binding <bb3> ^cell c21 ^tile <t8>)
-  (binding <bb4> ^cell c22 ^tile <t6>)
-  (binding <bb5> ^cell c23 ^tile <t0>)
-  (binding <bb6> ^cell c31 ^tile <t3>)
-  (binding <bb7> ^cell c32 ^tile <t4>)
-  (binding <bb8> ^cell c33 ^tile <t5>)
-  (state <s> ^binding <bb0> <bb1> <bb2> <bb3>
-	<bb4> <bb5> <bb6> <bb7> <bb8> ^blank-cell c23)
-  (cell c11 ^cell c12 ^cell c21)
-  (cell c12 ^cell c11 ^cell c13 ^cell c22) 
-  (cell c13 ^cell c12 ^cell c23)
-  (cell c21 ^cell c11 ^cell c31 ^cell c22)
-  (cell c22 ^cell c21 ^cell c12 ^cell c23 ^cell c32)
-  (cell c23 ^cell c22 ^cell c33 ^cell c13)
-  (cell c31 ^cell c32 ^cell c21)
-  (cell c32 ^cell c31 ^cell c22 ^cell c33)
-  (cell c33 ^cell c32 ^cell c23)
-
-  (binding <d1> ^cell c11 ^tile <t1>)
-  (binding <d2> ^cell c12 ^tile <t8>)
-  (binding <d3> ^cell c13 ^tile <t7>)
-  (binding <d8> ^cell c21 ^tile <t2>)
-  (binding <d0> ^cell c22 ^tile <t0>)
-  (binding <d4> ^cell c23 ^tile <t6>)
-  (binding <d7> ^cell c31 ^tile <t3>)
-  (binding <d6> ^cell c32 ^tile <t4>)
-  (binding <d5> ^cell c33 ^tile <t5>)
-  (desired <d> ^binding <d0> <d1> <d2> <d3> <d4>
-	<d5> <d6> <d7> <d8>)
-  (evaluation <d> ^better higher)
-)
-
-(comment create an operator if it will apply)
-
-(sp eight*acceptable 
-  (gc <g> ^problem-space <p> ^state <s>)
-  (problem-space <p> ^name eight-puzzle)
-  (state <s> ^blank-cell <c1>)
-  (cell <c1> ^cell <c2>)
- -(op-info ^attribute state ^value <s>)
-  -->
-  (operator <q> ^name move-tile ^state <s> ^tile-cell <c2> ^blank-cell <c1>)
-  (preference <q> ^role operator ^value acceptable
-	^goal <g> ^problem-space <p> ^state <s>))
-
-
-
-(comment reject the operator that was applied to create this state)
-
-(sp eight*reject-undo
-  (gc <g> ^problem-space <p> ^state <s>)
-  (problem-space <p> ^name eight-puzzle)
-  (state <s> ^tile-cell <tc>)
-  (preference <q> ^role operator ^value acceptable
-	^problem-space <p> ^state <s>)
-  (operator <q> ^tile-cell <tc>)
-  -->
-  (preference <q> ^role operator ^value reject
-	 ^goal <g> ^problem-space <p> ^state <s>))
-
-
-
-(comment apply operator to state and copy unchanged bindings new state)
-
-(comment swap blank binding and one specified by operator)
-
-(sp eight*apply-move-tile
-  (gc <g> ^problem-space <p> ^state <s> ^operator <q>)
-  (problem-space <p> ^name eight-puzzle)
-  (state <s> ^binding <b1> <b2> ^blank-cell <c1>)
-  (binding <b1> ^tile <t1> ^cell <c1>)
-  (binding <b2> ^tile <t2> ^cell <c2>)
-  (operator <q> ^tile-cell <c2> ^blank-cell <c1> ^name move-tile)
-  -->
-  (preference <s2> ^role state ^value acceptable
-	 ^goal <g> ^problem-space <p> ^state <s> ^operator <q>)
-  (state <s2> ^blank-cell <c2> ^tile-cell <c1>
-	^binding <b3> ^binding <b4>)
-  (binding <b3> ^tile <t2> ^cell <c1>)
-  (binding <b4> ^tile <t1> ^cell <c2>)
-)
-
-(comment copy pointers to all untouched bindings)
-
-(sp eight*copy-unchanged
-  (gc <g> ^problem-space <p> ^state <s> ^operator <q>)
-  (problem-space <p> ^name eight-puzzle)
-  (preference <n> ^role state ^value acceptable
-	 ^problem-space <p> ^state { <> nil <s> } ^operator { <> nil <q> })
-  (state <s> ^binding <b>)
-  (binding <b> ^cell <c>)
-  (state <n> -^tile-cell <c> -^blank-cell <c>)
-  -->
-  (state <n> ^binding <b>))
-
-(comment detect success)
-
-(sp eight*detect-goal
-  (gc <g> ^problem-space <p> ^state <s> ^desired <d>)
-  (space <p> ^name eight-puzzle)
-  (state <s> ^binding <x11> <x12> <x13> <x21> <x22> <x23>
-	 <x31> <x32> <x33>)
-  (binding <x11> ^cell c11 ^tile <o11>)
-  (binding <x12> ^cell c12 ^tile <o12>)
-  (binding <x13> ^cell c13 ^tile <o13>)
-  (binding <x21> ^cell c21 ^tile <o21>)
-  (binding <x22> ^cell c22 ^tile <o22>)
-  (binding <x23> ^cell c23 ^tile <o23>)
-  (binding <x31> ^cell c31 ^tile <o31>)
-  (binding <x32> ^cell c32 ^tile <o32>)
-  (binding <x33> ^cell c33 ^tile <o33>)
-  (desired <d>
-	 ^binding <d11> <d12> <d13> <d21> <d22> <d23>
-	 <d31> <d32> <d33>)
-  (binding <d11> ^cell c11 ^tile <o11>)
-  (binding <d12> ^cell c12 ^tile <o12>)
-  (binding <d13> ^cell c13 ^tile <o13>)
-  (binding <d21> ^cell c21 ^tile <o21>)
-  (binding <d22> ^cell c22 ^tile <o22>)
-  (binding <d23> ^cell c23 ^tile <o23>)
-  (binding <d31> ^cell c31 ^tile <o31>)
-  (binding <d32> ^cell c32 ^tile <o32>)
-  (binding <d33> ^cell c33 ^tile <o33>)
-  -->
-  (state <s> ^success <d>))
-
-(comment monitor new states)
-
-(sp eight*monitor
-  (gc <g> ^problem-space <p> ^state <s> ^operator <q>)
-  (problem-space <p> ^name eight-puzzle)
-  (preference <n> ^role state ^value acceptable
-	 ^problem-space <p> ^state <s> ^operator <q>)
-  (operator <q> ^tile-cell <qname>)
-  (state <n> ^binding <x11> <x12> <x13> <x21> <x22> <x23>
-	 <x31> <x32> <x33>)
-  (binding <x11> ^cell c11 ^tile <o11>)
-  (binding <x12> ^cell c12 ^tile <o12>)
-  (binding <x13> ^cell c13 ^tile <o13>)
-  (binding <x21> ^cell c21 ^tile <o21>)
-  (binding <x22> ^cell c22 ^tile <o22>)
-  (binding <x23> ^cell c23 ^tile <o23>)
-  (binding <x31> ^cell c31 ^tile <o31>)
-  (binding <x32> ^cell c32 ^tile <o32>)
-  (binding <x33> ^cell c33 ^tile <o33>)
-  (tile <o11> ^name <v11>)
-  (tile <o12> ^name <v12>)
-  (tile <o13> ^name <v13>)
-  (tile <o21> ^name <v21>)
-  (tile <o22> ^name <v22>)
-  (tile <o23> ^name <v23>)
-  (tile <o31> ^name <v31>)
-  (tile <o32> ^name <v32>)
-  (tile <o33> ^name <v33>)
-  -->
-  (write2 (crlf) (crlf) <qname> "(" <s> ") --> " <n> (crlf))
-  (write1 "     -------------" (crlf))
-  (write1 "     |" <v11> "|" <v21> "|" <v31> "|" (crlf))
-  (write1 "     |---|---|---|" (crlf))
-  (write1 "     |" <v12> "|" <v22> "|" <v32> "|" (crlf))
-  (write1 "     |---|---|---|" (crlf))
-  (write1 "     |" <v13> "|" <v23> "|" <v33> "|" (crlf))
-  (write1 "     -------------" (crlf)))
-
-
-(comment compute evaluation function based on changes by operators)
-(comment 1 point for moving binding into its impasse location)
-
-(sp eight*eval-state-plus-one
-   (gc <g> ^problem-space <p> ^state { <> <ss> <s> } ^superoperator <sq>)
-   (problem-space <p> ^name eight-puzzle)
-   (operator <sq> ^name evaluate-object ^evaluation <e> 
-	^superstate <ss> ^desired <d>)
-   (state <s> ^tile-cell <c1> ^binding <b1>)
-   (binding <b1> ^cell <c1> ^tile <v1>)
-   (desired <d> ^binding <b2>)
-   (binding <b2> ^cell <c1> ^tile <v1>)
-   -->
-   (evaluation <e> ^numeric-value 1))
-
-(comment 0 points for not moving tile in or out of its impasse cell)
-
-(sp eight*eval-state-zero
-   (gc <g> ^problem-space <p> ^state { <> <ss> <s> } ^superoperator <sq>)
-   (space <p> ^name eight-puzzle)
-   (operator <sq> ^name evaluate-object ^evaluation <e>
-	^desired <d> ^superstate <ss>)
-   (state <s> ^tile-cell <c1> ^blank-cell <c0>
-	^binding <b1> <b2> <b3>)
-   (binding <b1> ^cell <c1> ^tile <v1>)
-   (binding <b2> ^tile <v2>)
-   (binding <b3> ^tile <v3>)
-   (desired <d> ^binding <b4> <b5>)
-   (binding <b4> ^cell <c1> ^tile { <> <v1> <v2> })
-   (binding <b5> ^cell <c0> ^tile { <> <v1> <v3> })
-   -->
-   (evaluation <e> ^numeric-value 0))
-
-
-(comment -1 points for moving tile out of its impasse cell)
-
-(sp eight*eval-state-minus-one
-   (gc <g> ^problem-space <p> ^state { <> <ss> <s> } ^superoperator <sq>)
-   (space <p> ^name eight-puzzle)
-   (operator <sq> ^name evaluate-object ^evaluation <e>
-	^desired <d> ^superstate <ss>)
-   (state <s>  ^tile-cell <c1> ^binding <b1> ^blank-cell <c0>)
-   (binding <b1> ^cell <c1> ^tile <v1>)
-   (desired <d> ^binding <b2>)
-   (binding <b2> ^cell <c0> ^tile <v1>)
-   -->
-   (evaluation <e> ^numeric-value -1))
-
-nil
diff --git a/benchmarks/soar/readme.txt b/benchmarks/soar/readme.txt
deleted file mode 100644
index 6a92d123540ab58b53624057d5f62114cda3375a..0000000000000000000000000000000000000000
--- a/benchmarks/soar/readme.txt
+++ /dev/null
@@ -1,8 +0,0 @@
-To run soar:
-   (load "soar.fasl")
-   (load "default.soar")
-   (load "eight.soar")
-   (d)
-
-Optionally before calling D, you can call WATCH with -1 to turn off tracing
-information.  This is desirable for timing situation.
diff --git a/benchmarks/soar/soar.lisp b/benchmarks/soar/soar.lisp
deleted file mode 100644
index 65f9e9e162d1a6100a0543c3d4ce48a4bb382bb4..0000000000000000000000000000000000000000
--- a/benchmarks/soar/soar.lisp
+++ /dev/null
@@ -1,7273 +0,0 @@
-;;; -*- Mode: LISP; Package: User -*-
-
-#+declare-unsafe (proclaim '(optimize (speed 3) (safety 0)))
-(proclaim
- '(special *matrix* *feature-count* *pcount* *vars* *cur-vars*
-	   *curcond* *subnum* *last-node* *last-branch* *first-node*
-	   *sendtocall* *flag-part* *alpha-flag-part* *data-part*
-	   *alpha-data-part* *ce-vars* *virtual-cnt* *real-cnt*
-	   *current-token* *record-array* *result-array* 
-	   *max-cs* *total-cs* *limit-cs* *cr-temp* *side*
-	   *conflict-set* *halt-flag* *phase* *critical*
-	   *cycle-count* *total-token* *max-token* *refracts* 
-	   *limit-token* *total-wm* *current-wm* *max-wm*
-	   *action-count* *wmpart-list* *wm* *data-matched* *p-name*
-	   *variable-memory* *ce-variable-memory* *max-index*
-	   *next-index* *size-result-array* *rest* *build-trace* *last*
-	   *ptrace* *wtrace* *in-rhs* *recording* *accept-file* *trace-file* 
-	   *write-file* *record-index* *max-record-index* *old-wm*
-	   *record* *filters* *break-flag* *strategy* *remaining-cycles*
-	   *wm-filter* *rhs-bound-vars* *rhs-bound-ce-vars* *ppline* 
-	   *ce-count* *brkpts* *class-list* *buckets* *action-type*))
-
-(proclaim '(special *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
-	   *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
-	   *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
-	   *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
-	   *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
-	   *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
-	   *c60* *c61* *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69*
-	   *c70* *c71* *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79*
-	   *c80* *c81* *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89*
-	   *c90* *c91* *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99*
-	   *c100* *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108* 
-	   *c109* *c110* *c111* *c112* *c113* *c114* *c115* *c116* *c117* 
-	   *c118* *c119* *c120* *c121* *c122* *c123* *c124* *c125* *c126* 
-	   *c127* ))
-
-(defmacro soarputprop (n v a)
-	`(setf (get ,n ,a) ,v))
-
-(defmacro soarassq (item alist)
-	`(assoc ,item ,alist :test #'eq))
-
-; getvector and putvector are fast routines for using ONE-DIMENSIONAL
-; arrays.  these routines do no checking; they assume
-;	1. the array is a vector with 0 being the index of the first
-;	   element
-;	2. the vector holds arbitrary list values
-
-(defmacro putvector (array index value)
-  `(setf (svref ,array ,index) ,value))
-
-(defmacro getvector (array index)
-  `(svref ,array ,index))
-
-(shadow 'remove (find-package 'user))
-
-(defmacro remove (&body z)
-  `(ops-remove ',z))
-
-(shadow 'write (find-package 'user))
-
-(defmacro write (&body z)
-  `(ops-write ',z))
-
-(defmacro princq (ob &optional st)
-  (cond ((eq st nil)
-	 `(princ ,ob))
-	(t
-	 `(princ ,ob ,st))))
-
-(defmacro literal (&body z)
-  `(ops-literal ',z))
-
-(defmacro literalize (&body z)
-  `(ops-literalize ',z))
-
-(defmacro vector-attribute (&body l)
-  `(ops-vector-attribute ',l))
-
-(defmacro p (&body z) 
-  `(ops-p ',z))
-
-(defmacro wm (&body a) 
-  `(ops-wm ',a))
-
-(defmacro make (&body z)
-  `(ops-make ',z))
-
-(defmacro modify (&body z)
-  `(ops-modify ',z))
-
-(defmacro bind (&body z)
-  `(ops-bind ',z))
-
-(defmacro cbind (&body z)
-  `(ops-cbind ',z))
-
-(defmacro call1 (&body z)
-  `(ops-call1 ',z))
-
-(defmacro build (&body z)
-  `(ops-build ',z))
-
-(defmacro openfile (&body z)
-  `(ops-openfile ',z))
-
-(defmacro closefile (&body z)
-  `(ops-closefile ',z))
-
-(defmacro default (&body z)
-  `(ops-default ',z))
-
-(defmacro accept (&body z)
-  `(ops-accept ',z))
-
-(defmacro acceptline (&body z)
-  `(ops-acceptline ',z))
-
-(defmacro substr (&body l)
-  `(ops-substr ',l))
-
-(defmacro compute (&body z)
-  `(ops-compute ',z))
-
-(defmacro arith (&body z)
-  `(ops-arith ',z))
-
-(defmacro litval (&body z)
-  `(ops-litval ',z))
-
-(defmacro rjust (&body z)
-  `(ops-rjust ',z))
-
-(defmacro crlf (&body z)
-  `(ops-crlf ',z))
-
-(defmacro tabto (&body z)
-  `(ops-tabto ',z))
-
-(defmacro ppwm (&body avlist)
-  `(ops-ppwm ',avlist))
-
-(defmacro pm (&body z)
-  `(ops-pm ',z))
-
-(defmacro matches (&body rule-list)
-  `(ops-matches ',rule-list))
-
-(defmacro excise (&body z)
-  `(ops-excise ',z))
-
-(defmacro run (&body z)
-  `(ops-run ',z))
-
-(defmacro strategy (&body z)
-  `(ops-strategy ',z))
-
-(defmacro cs (&body z)
-  `(ops-cs ',z))
-
-(defmacro watch (&body z)
-  `(ops-watch ',z))
-
-(defmacro external (&body z) 
-  `(ops-external ',z))
-
-(defmacro pbreak (&body z)
-  `(ops-pbreak ',z))
-
-(defmacro == (x y)
-  `(equal ,x ,y))
-
-(defmacro =alg (a b)
-  `(equalp ,a ,b))
-
-(defun ce-gelm (x k)
-  (declare (optimize speed))
-  (prog nil
-    loop (and (== k 1.) (return (car x)))
-    (setq k (1- k))
-    (setq x (cdr x))
-    (go loop))) 
-
-(defun gelm (x k)
-  (declare (optimize speed))
-  (prog (ce sub)
-    (setq ce (truncate  k 10000.))		;use multiple-value-setq???
-    (setq sub (- k (* ce 10000.)))		;@@@ ^
-    celoop (and (eq ce 0.) (go ph2))
-    (setq x (cdr x))
-    (and (eq ce 1.) (go ph2))
-    (setq x (cdr x))
-    (and (eq ce 2.) (go ph2))
-    (setq x (cdr x))
-    (and (eq ce 3.) (go ph2))
-    (setq x (cdr x))
-    (and (eq ce 4.) (go ph2))
-    (setq ce (- ce 4.))
-    (go celoop)
-    ph2  (setq x (car x))
-    subloop (and (eq sub 0.) (go finis))
-    (setq x (cdr x))
-    (and (eq sub 1.) (go finis))
-    (setq x (cdr x))
-    (and (eq sub 2.) (go finis))
-    (setq x (cdr x))
-    (and (eq sub 3.) (go finis))
-    (setq x (cdr x))
-    (and (eq sub 4.) (go finis))
-    (setq x (cdr x))
-    (and (eq sub 5.) (go finis))
-    (setq x (cdr x))
-    (and (eq sub 6.) (go finis))
-    (setq x (cdr x))
-    (and (eq sub 7.) (go finis))
-    (setq x (cdr x))
-    (and (eq sub 8.) (go finis))
-    (setq sub (- sub 8.))
-    (go subloop)
-    finis (return (car x))) )
-
-;;; Utility functions
-
-;;; intersect two lists using eq for the equality test
-(defun interq (x y)
-  (cond ((atom x) nil)
-	((member (car x) y) (cons (car x) (interq (cdr x) y)))
-	(t (interq (cdr x) y)))) 
-
-
-(eval-when (compile load eval)
-  (set-macro-character #\{ #'(lambda (s c)
-			       (declare (ignore s c))
-			       '\{))   ;5/5/83
-  (set-macro-character #\} #'(lambda (s c)
-			       (declare (ignore s c))
-			       '\}))   ;5/5/83
-  (set-macro-character #\^ #'(lambda (s c)
-			       (declare (ignore s c))
-			       '\^))   ;5/5/83
-  )
-
-(defun %warn (what where)
-  (prog nil
-    (terpri)
-    (princ '?)
-    (and *p-name* (princ *p-name*))
-    (princ '"..")
-    (princ where)
-    (princ '"..")
-    (princ what)
-    (return where))) 
-
-(defun %error (what where)
-  (%warn what where)
-  (throw '!error! '!error!))
-
-(defun top-levels-eq (la lb)
-  (prog nil
-    lx   (cond ((eq la lb) (return t))
-	       ((null la) (return nil))
-	       ((null lb) (return nil))
-	       ((not (eq (car la) (car lb))) (return nil)))
-    (setq la (cdr la))
-    (setq lb (cdr lb))
-    (go lx))) 
-
-;;; LITERAL and LITERALIZE
-
-(defun ops-literal (z)
-  (prog (atm val old)
-    top  (and (atom z) (return 'bound))
-    (or (eq (cadr z) '=) (return (%warn '|wrong format| z)))
-    (setq atm (car z))
-    (setq val (caddr z))
-    (setq z (cdddr z))
-    (cond ((not (numberp val))
-	   (%warn '|can bind only to numbers| val))
-	  ((or (not (symbolp atm)) (variablep atm))
-	   (%warn '|can bind only constant atoms| atm))
-	  ((and (setq old (literal-binding-of atm)) (not (equal old val)))
-	   (%warn '|attempt to rebind attribute| atm))
-	  (t (soarputprop atm val 'ops-bind))
-    (go top))))
-
-(defun ops-literalize (l)
-  (prog (class-name atts)
-    (setq class-name (car l))
-    (cond ((have-compiled-production)
-	   (%warn '|literalize called after p| class-name)
-	   (return nil))
-	  ((get class-name 'att-list)
-	   (%warn '|attempt to redefine class| class-name)
-	   (return nil)))
-    (setq *class-list* (cons class-name *class-list*))
-    (setq atts (remove-duplicates (cdr l)))		
-    (test-attribute-names atts)
-    (mark-conflicts atts atts)
-    (soarputprop class-name atts 'att-list)))
-
-(defun ops-vector-attribute (l)
-  (cond ((have-compiled-production)
-	 (%warn '|vector-attribute called after p| l))
-	(t 
-	 (test-attribute-names l)
-	 (mapc (function vector-attribute2) l)))) 
-
-(defun vector-attribute2 (att) (soarputprop att t 'vector-attribute))
-
-(defun is-vector-attribute (att) (get att 'vector-attribute))
-
-(defun test-attribute-names (l)
-  (mapc (function test-attribute-names2) l)) 
-
-(defun test-attribute-names2 (atm)
-  (cond ((or (not (symbolp atm)) (variablep atm))
-	 (%warn '|can bind only constant atoms| atm)))) 
-
-(defun have-compiled-production nil (not (zerop *pcount*))) 
-	   
-(defun put-ppdat (class)
-  (prog (al att ppdat)
-    (setq ppdat nil)
-    (setq al (get class 'att-list))
-    top  (cond ((not (atom al))
-		(setq att (car al))
-		(setq al (cdr al))
-		(setq ppdat
-		      (cons (cons (literal-binding-of att) att)
-			    ppdat))
-		(go top)))
-    (soarputprop class ppdat 'ppdat))) 
-
-; note-user-assigns and note-user-vector-assigns are needed only when
-; literal and literalize are both used in a program.  They make sure that
-; the assignments that are made explicitly with literal do not cause problems
-; for the literalized classes.
-
-(defun note-user-assigns (class)
-  (mapc (function note-user-assigns2) (get class 'att-list)))
-
-(defun note-user-assigns2 (att)
-  (prog (num conf buck clash)
-    (setq num (literal-binding-of att))
-    (and (null num) (return nil))
-    (setq conf (get att 'conflicts))
-    (setq buck (store-binding att num))
-    (setq clash (find-common-atom buck conf))
-    (and clash
-	 (%warn '|attributes in a class assigned the same number|
-		(cons att clash)))
-    (return nil)))
-
-(defun note-user-vector-assigns (att given needed)
-  (and (> needed given)
-       (%warn '|vector attribute assigned too small a value in literal| att)))
-
-(defun assign-scalars (class)
-  (mapc (function assign-scalars2) (get class 'att-list))) 
-
-(defun assign-scalars2 (att)
-  (prog (tlist num bucket conf)
-    (and (literal-binding-of att) (return nil))
-    (and (is-vector-attribute att) (return nil))
-    (setq tlist (buckets))
-    (setq conf (get att 'conflicts))
-    top  (cond ((atom tlist)
-		(%warn '|could not generate a binding| att)
-		(store-binding att -1.)
-		(return nil)))
-    (setq num (caar tlist))
-    (setq bucket (cdar tlist))
-    (setq tlist (cdr tlist))
-    (cond ((disjoint bucket conf) (store-binding att num))
-	  (t (go top))))) 
-
-(defun assign-vectors (class)
-  (mapc (function assign-vectors2) (get class 'att-list))) 
-
-(defun assign-vectors2 (att)
-  (prog (big conf new old need)
-    (and (not (is-vector-attribute att)) (return nil))
-    (setq big 1.)
-    (setq conf (get att 'conflicts))
-    top  (cond ((not (atom conf))
-		(setq new (car conf))
-		(setq conf (cdr conf))
-		(cond ((is-vector-attribute new)
-		       (%warn '|class has two vector attributes|
-			      (list att new)))
-		      (t (setq big (max (literal-binding-of new) big))))
-		(go top)))
-    (setq need (1+ big))			;"plus" changed to "+" by gdw
-    (setq old (literal-binding-of att))
-    (cond (old (note-user-vector-assigns att old need))
-	  (t (store-binding att need)))
-    (return nil)))
-
-(defun disjoint (la lb) (not (find-common-atom la lb))) 
-
-(defun find-common-atom (la lb)
-  (prog nil
-    top  (cond ((null la) (return nil))
-	       ((member (car la) lb) (return (car la)))
-	       (t (setq la (cdr la)) (go top))))) 
-
-(defun mark-conflicts (rem all)
-  (cond ((not (null rem))
-	 (mark-conflicts2 (car rem) all)
-	 (mark-conflicts (cdr rem) all)))) 
-
-(defun mark-conflicts2 (atm lst)
-  (prog (l)
-    (setq l lst)
-    top  (and (atom l) (return nil))
-    (conflict atm (car l))
-    (setq l (cdr l))
-    (go top))) 
-
-(defun conflict (a b)
-  (prog (old)
-    (setq old (get a 'conflicts))
-    (and (not (eq a b))
-	 (not (member b old))
-	 (soarputprop a (cons b old) 'conflicts)))) 
-
-(defun literal-binding-of (name) (get name 'ops-bind)) 
-
-(defun store-binding (name lit)
-  (soarputprop name lit 'ops-bind)
-  (add-bucket name lit)) 
-
-(defun add-bucket (name num)
-  (prog (buc)
-    (setq buc (assoc num (buckets)))
-    (and (not (member name buc))
-	 (rplacd buc (cons name (cdr buc))))
-    (return buc))) 
-
-(defun buckets nil
-  (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
-  *buckets*) 
-
-(defmacro ncons (x) `(cons ,x nil))
-
-(defun make-nums (k)
-  (prog (nums)
-    (setq nums nil)
-    l    (and (< k 2.) (return nums))
-    (setq nums (cons (ncons k) nums))
-    (setq k (1- k))
-    (go l))) 
-
-(defun erase-literal-info (class)
-  (mapc (function erase-literal-info2) (get class 'att-list))
-  (remprop class 'att-list)) 
-
-(defun erase-literal-info2 (att) (remprop att 'conflicts)) 
-
-
-;;; LHS Compiler
-
-(defun peek-lex nil (car *matrix*)) 
-
-(defun lex nil
-  (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*)))) 
-
-(defun end-of-p nil (atom *matrix*)) 
-
-(defun rest-of-p nil *matrix*) 
-
-(defun prepare-lex (prod) (setq *matrix* prod)) 
-
-(defun peek-sublex nil (car *curcond*)) 
-
-(defun sublex nil
-  (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*)))) 
-
-(defun end-of-ce nil (atom *curcond*)) 
-
-(defun rest-of-ce nil *curcond*) 
-
-(defun prepare-sublex (ce) (setq *curcond* ce)) 
-
-(defun make-bottom-node nil (setq *first-node* (list '&bus nil))) 
-
-(defun rating-part (pnode) (cadr pnode)) 
-
-(defun var-part (pnode) (car (cdddr pnode))) 
-
-(defun ce-var-part (pnode) (cadr (cdddr pnode))) 
-
-(defun rhs-part (pnode) (caddr (cdddr pnode))) 
-
-(defun kill-node (node)
-  (prog nil
-    top  (and (atom node) (return nil))
-    (rplaca node '&old)
-    (setq node (cdr node))
-    (go top))) 
-
-(defun cmp-negce nil (lex) (cmp-ce)) 
-
-(defun cmp-posce nil
-  (setq *ce-count* (1+ *ce-count*))
-  (cond ((eq (peek-lex) '\{) (cmp-ce+cevar))
-	(t (cmp-ce)))) 
-
-(defun cmp-ce+cevar nil
-  (prog (z)
-    (lex)
-    (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
-	  (t (cmp-ce) (cmp-cevar)))
-    (setq z (lex))
-    (or (eq z '\}) (%error '|missing '}'| z)))) 
-
-(defun new-subnum (k)
-  (or (numberp k) (%error '|tab must be a number| k))
-  (setq *subnum* (fix k))) 
-
-(defun incr-subnum nil (setq *subnum* (1+ *subnum*))) 
-
-(defun cmp-element nil
-  (and (eq (peek-sublex) '^) (cmp-tab))
-  (cond ((eq (peek-sublex) '\{) (cmp-product))
-	(t (cmp-atomic-or-any))))
-
-(defun cmp-atomic-or-any nil
-  (cond ((eq (peek-sublex) '<<) (cmp-any))
-	(t (cmp-atomic))))
-
-(defun cmp-any nil
-  (prog (a z)
-    (sublex)
-    (setq z nil)
-    la   (cond ((end-of-ce) (%error '|missing '>>'| a)))
-    (setq a (sublex))
-    (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
-    (link-new-node (list '&any nil (current-field) z)))) 
-
-(defun $litbind (x)
-  (prog (r)
-    (cond ((and (symbolp x) (setq r (literal-binding-of x)))
-	   (return r))
-	  (t (return x))))) 
-
-(defun get-bind (x)
-  (prog (r)
-    (cond ((and (symbolp x) (setq r (literal-binding-of x)))
-	   (return r))
-	  (t (return nil))))) 
-
-(defun cmp-atomic nil
-  (prog (test x)
-    (setq x (peek-sublex))
-    (cond ((eq x '= ) (setq test 'eq) (sublex))
-	  ((eq x '<>) (setq test 'ne) (sublex))
-	  ((eq x '<) (setq test 'lt) (sublex))
-	  ((eq x '<=) (setq test 'le) (sublex))
-	  ((eq x '>) (setq test 'gt) (sublex))
-	  ((eq x '>=) (setq test 'ge) (sublex))
-	  ((eq x '<=>) (setq test 'xx) (sublex))
-	  (t (setq test 'eq)))
-    (cmp-symbol test))) 
-
-(defun cmp-product nil
-  (prog (save)
-    (setq save (rest-of-ce))
-    (sublex)
-    la   (cond ((end-of-ce)
-		(cond ((member '\} save :test #'equal) 
-		       (%error '|wrong contex for '}'| save))
-		      (t (%error '|missing '}'| save))))
-	       ((eq (peek-sublex) '\}) (sublex) (return nil)))
-    (cmp-atomic-or-any)
-    (go la))) 
-
-(defun symbol-print-name (x)
-  (symbol-name x))
-
-(defun cmp-symbol (test)
-  (prog (flag)
-    (setq flag t)
-    (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
-    (cond ((and flag (variablep (peek-sublex)))
-	   (cmp-var test))
-	  ((numberp (peek-sublex)) (cmp-number test))
-	  ((symbolp (peek-sublex)) (cmp-constant test))
-	  (t (%error '|unrecognized symbol| (sublex)))))) 
-
-(defun cmp-constant (test)
-  (or (member test '(eq ne xx))
-      (%error '|non-numeric constant after numeric predicate| (sublex)))
-  (link-new-node (list (intern (concatenate 'string
-					    (symbol-print-name 't)
-					    (symbol-print-name  test)
-					    (symbol-print-name 'a)))
-		       nil
-		       (current-field)
-		       (sublex)))) 
-
-(defun cmp-number (test)
-  (link-new-node 
-    (list 
-      (intern 
-	(concatenate 'string
-	  (symbol-print-name 't)
-	  (symbol-print-name  test)
-          (symbol-print-name 'n)))
-      nil				;outs -- nodelist to traverse
-      (current-field)			;register 
-      (sublex))))			;constant
-
-; %%% things to change to convert set of *cN* to *c* array:
-; %%% current-field field-name *subnum*  eval-nodelist ?? wm-hash 
-; %%% send-to, &bus
-
-(defun current-field nil (field-name *subnum*)) 
-
-(defun field-name (num)
-  (cond ((= num 1.) '*c1*)
-	((= num 2.) '*c2*)
-	((= num 3.) '*c3*)
-	((= num 4.) '*c4*)
-	((= num 5.) '*c5*)
-	((= num 6.) '*c6*)
-	((= num 7.) '*c7*)
-	((= num 8.) '*c8*)
-	((= num 9.) '*c9*)
-	((= num 10.) '*c10*)
-	((= num 11.) '*c11*)
-	((= num 12.) '*c12*)
-	((= num 13.) '*c13*)
-	((= num 14.) '*c14*)
-	((= num 15.) '*c15*)
-	((= num 16.) '*c16*)
-	(t (%error '|condition is too long| (rest-of-ce))))) 
-
-
-;;; Compiling variables
-;
-;
-;
-; *cur-vars* are the variables in the condition element currently 
-; being compiled.  *vars* are the variables in the earlier condition
-; elements.  *ce-vars* are the condition element variables.  note
-; that the interpreter will not confuse condition element and regular
-; variables even if they have the same name.
-;
-; *cur-vars* is a list of triples: (name predicate subelement-number)
-; eg:		( (<x> eq 3)
-		  ;		  (<y> ne 1)
-		  ;		  . . . )
-;
-; *vars* is a list of triples: (name ce-number subelement-number)
-; eg:		( (<x> 3 3)
-		  ;		  (<y> 1 1)
-		  ;		  . . . )
-;
-; *ce-vars* is a list of pairs: (name ce-number)
-; eg:		( (ce1 1)
-		  ;		  (<c3> 3)
-		  ;		  . . . )
-
-
-(defun var-dope (var) (soarassq var *vars*))
-
-(defun ce-var-dope (var) (soarassq var *ce-vars*))
-
-(defun cmp-new-var (name test)
-  (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*))) 
-
-(defun cmp-old-eq-var (test old)  ; jgk inserted concatenate form
-  (link-new-node (list (intern (concatenate 'string
-					    (symbol-print-name 't)
-					    (symbol-print-name  test)
-					    (symbol-print-name 's)))
-		       nil
-		       (current-field)
-		       (field-name (caddr old))))) 
-
-;@@@ added defunb of delq
-;(defun delq (i l)
-;  (delete i l :test #'eq))
-
-;
-; Spdelete "special delete" is a function which deletes every occurence
-; of element from list. This function was defined because common lisp's
-; delete function only deletes top level elements from a list, not lists
-; from lists. 
-;
-(defun spdelete (element list)
-  
-  (cond ((null list) nil)
-	((equal element (car list)) (spdelete element (cdr list)))
-	(t (cons (car list) (spdelete element (cdr list))))))
-
-
-
-(defun cmp-new-eq-var (name old)  ;jgk inserted concatenate form
-  (prog (pred next)
-    (setq *cur-vars* (delq old *cur-vars*))
-    (setq next (soarassq name *cur-vars*))
-    (cond (next (cmp-new-eq-var name next))
-	  (t (cmp-new-var name 'eq)))
-    (setq pred (cadr old))
-    (link-new-node (list (intern (concatenate 'string
-					      (symbol-print-name 't)
-					      (symbol-print-name  pred)
-					      (symbol-print-name 's)))
-			 nil
-			 (field-name (caddr old))
-			 (current-field))))) 
-
-(defun cmp-cevar nil
-  (prog (name old)
-    (setq name (lex))
-    (setq old (soarassq name *ce-vars*))
-    (and old
-	 (%error '|condition element variable used twice| name))
-    (setq *ce-vars* (cons (list name 0.) *ce-vars*)))) 
-
-(defun cmp-not nil (cmp-beta '&not)) 
-
-(defun cmp-nobeta nil (cmp-beta nil)) 
-
-(defun cmp-and nil (cmp-beta '&and)) 
-
-(defun cmp-beta (kind)
-  (prog (tlist vdope vname #|vpred vpos|# old)
-    (setq tlist nil)
-    la   (and (atom *cur-vars*) (go lb))
-    (setq vdope (car *cur-vars*))
-    (setq *cur-vars* (cdr *cur-vars*))
-    (setq vname (car vdope))
-    ;;  (setq vpred (cadr vdope))    Dario - commented out (unused)
-    ;;  (setq vpos (caddr vdope))
-    (setq old (soarassq vname *vars*))
-    (cond (old (setq tlist (add-test tlist vdope old)))
-	  ((not (eq kind '&not)) (promote-var vdope)))
-    (go la)
-    lb   (and kind (build-beta kind tlist))
-    (or (eq kind '&not) (fudge))
-    (setq *last-branch* *last-node*))) 
-
-(defun add-test (list new old) ; jgk inserted concatenate form
-  (prog (ttype lloc rloc)
-    (setq *feature-count* (1+ *feature-count*))
-    (setq ttype (intern (concatenate 'string (symbol-print-name 't)
-				     (symbol-print-name (cadr new))
-				     (symbol-print-name 'b))))
-    (setq rloc (encode-singleton (caddr new)))
-    (setq lloc (encode-pair (cadr old) (caddr old)))
-    (return (cons ttype (cons lloc (cons rloc list)))))) 
-
-; the following two functions encode indices so that gelm can
-; decode them as fast as possible
-
-;; %%% change to use clisp hash fns ??
-(defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b))) 
-;"plus" changed to "+" by gdw
-
-(defun encode-singleton (a) (1- a)) 
-
-(defun fudge nil
-  (mapc (function fudge*) *vars*)
-  (mapc (function fudge*) *ce-vars*)) 
-
-(defun fudge* (z)
-  (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a))))) 
-
-(defun build-beta (type tests)
-  (prog (rpred lpred lnode lef)
-    (link-new-node (list '&mem nil nil (protomem)))
-    (setq rpred *last-node*)
-    (cond ((eq type '&and)
-	   (setq lnode (list '&mem nil nil (protomem))))
-	  (t (setq lnode (list '&two nil nil))))
-    (setq lpred (link-to-branch lnode))
-    (cond ((eq type '&and) (setq lef lpred))
-	  (t (setq lef (protomem))))
-    (link-new-beta-node (list type nil lef rpred tests)))) 
-
-(defun protomem nil (list nil)) 
-
-(defun memory-part (mem-node) (car (cadddr mem-node))) 
-
-(defun encode-dope nil
-  (prog (r all z k)
-    (setq r nil)
-    (setq all *vars*)
-    la   (and (atom all) (return r))
-    (setq z (car all))
-    (setq all (cdr all))
-    (setq k (encode-pair (cadr z) (caddr z)))
-    (setq r (cons (car z) (cons k r)))
-    (go la))) 
-
-(defun encode-ce-dope nil
-  (prog (r all z k)
-    (setq r nil)
-    (setq all *ce-vars*)
-    la   (and (atom all) (return r))
-    (setq z (car all))
-    (setq all (cdr all))
-    (setq k (cadr z))
-    (setq r (cons (car z) (cons k r)))
-    (go la))) 
-
-
-
-;;; Linking the nodes
-
-(defun link-new-node (r)
-  (cond ((not (member (car r) '(&p &mem &two &and &not) :test #'equal))
-	 (setq *feature-count* (1+ *feature-count*))))
-  (setq *virtual-cnt* (1+ *virtual-cnt*))
-  (setq *last-node* (link-left *last-node* r))) 
-
-(defun link-to-branch (r)
-  (setq *virtual-cnt* (1+ *virtual-cnt*))
-  (setq *last-branch* (link-left *last-branch* r))) 
-
-(defun link-new-beta-node (r)
-  (setq *virtual-cnt* (1+ *virtual-cnt*))
-  (setq *last-node* (link-both *last-branch* *last-node* r))
-  (setq *last-branch* *last-node*)) 
-
-(defun link-left (pred succ)
-  (prog (a r)
-    (setq a (left-outs pred))
-    (setq r (find-equiv-node succ a))
-    (and r (return r))
-    (setq *real-cnt* (1+ *real-cnt*))
-    (attach-left pred succ)
-    (return succ))) 
-
-(defun link-both (left right succ)
-  (prog (a r)
-    (setq a (interq (left-outs left) (right-outs right)))
-    (setq r (find-equiv-beta-node succ a))
-    (and r (return r))
-    (setq *real-cnt* (1+ *real-cnt*))
-    (attach-left left succ)
-    (attach-right right succ)
-    (return succ))) 
-
-(defun attach-right (old new)
-  (rplaca (cddr old) (cons new (caddr old)))) 
-
-(defun attach-left (old new)
-  (rplaca (cdr old) (cons new (cadr old)))) 
-
-(defun right-outs (node) (caddr node)) 
-
-(defun left-outs (node) (cadr node)) 
-
-(defun find-equiv-node (node list)
-  (prog (a)
-    (setq a list)
-    l1   (cond ((atom a) (return nil))
-	       ((equiv node (car a)) (return (car a))))
-    (setq a (cdr a))
-    (go l1))) 
-
-(defun find-equiv-beta-node (node list)
-  (prog (a)
-    (setq a list)
-    l1   (cond ((atom a) (return nil))
-	       ((beta-equiv node (car a)) (return (car a))))
-    (setq a (cdr a))
-    (go l1))) 
-
-; do not look at the predecessor fields of beta nodes; they have to be
-; identical because of the way the candidate nodes were found
-
-(defun equiv (a b)
-  (and (eq (car a) (car b))
-       (or (eq (car a) '&mem)
-	   (eq (car a) '&two)
-	   (equal (caddr a) (caddr b)))
-       (equal (cdddr a) (cdddr b)))) 
-
-(defun beta-equiv (a b)
-  (and (eq (car a) (car b))
-       (equal (cddddr a) (cddddr b))
-       (or (eq (car a) '&and) (equal (caddr a) (caddr b))))) 
-
-; the equivalence tests are set up to consider the contents of
-; node memories, so they are ready for the build action
-
-;;; Network interpreter
-
-(defun match (flag wme)
-  (sendto flag (list wme) 'left (list *first-node*)))
-
-; note that eval-nodelist is not set up to handle building
-; productions.  would have to add something like ops4's build-flag
-
-(defun eval-nodelist (nl)
-  (prog nil
-    top  (and (not nl) (return nil))
-    (setq *sendtocall* nil)
-    (setq *last-node* (car nl))
-    (apply (caar nl) (cdar nl))		;; %%% here's the apply cdar nl must 
-    					;; be the *cN* item, caar nl is test
-    (setq nl (cdr nl))
-    (go top))) 
-
-(defun sendto (flag data side nl)
-  (prog nil
-    top  (and (not nl) (return nil))
-    (setq *side* side)
-    (setq *flag-part* flag)
-    (setq *data-part* data)
-    (setq *sendtocall* t)
-    (setq *last-node* (car nl))
-    (apply (caar nl) (cdar nl))		;; %%% ditto
-    (setq nl (cdr nl))
-    (go top))) 
-
-(defun &any (outs register const-list)
-  (prog (z c)
-    (setq z (symbol-value register))
-    (cond ((numberp z) (go number)))
-    symbol (cond ((null const-list) (return nil))
-		 ((eq (car const-list) z) (go ok))
-		 (t (setq const-list (cdr const-list)) (go symbol)))
-    number (cond ((null const-list) (return nil))
-		 ((and (numberp (setq c (car const-list)))
-		       (=alg c z))
-		  (go ok))
-		 (t (setq const-list (cdr const-list)) (go number)))
-    ok   (eval-nodelist outs))) 
-
-(defun teqa (outs register constant)
-  (and (eq (symbol-value register) constant) (eval-nodelist outs))) 
-
-(defun tnea (outs register constant)
-  (and (not (eq (symbol-value register) constant)) (eval-nodelist outs))) 
-
-(defun txxa (outs register constant)
-  (declare (ignore constant))
-  (and (symbolp (symbol-value register)) (eval-nodelist outs))) 
-
-(defun teqn (outs register constant)
-  (prog (z)
-    (setq z (symbol-value register))
-    (and (numberp z)
-	 (=alg z constant)
-	 (eval-nodelist outs)))) 
-
-(defun tnen (outs register constant)
-  (prog (z)
-    (setq z (symbol-value register))
-    (and (or (not (numberp z))
-	     (not (=alg z constant)))
-	 (eval-nodelist outs)))) 
-
-(defun txxn (outs register constant)
-  (declare (ignore constant))
-  (prog (z)
-    (setq z (symbol-value register))
-    (and (numberp z) (eval-nodelist outs)))) 
-
-(defun tltn (outs register constant)
-  (prog (z)
-    (setq z (symbol-value register))
-    (and (numberp z)
-	 (> constant z)
-	 (eval-nodelist outs)))) 
-
-(defun tgtn (outs register constant)
-  (prog (z)
-    (setq z (symbol-value register))
-    (and (numberp z)
-	 (> z constant)
-	 (eval-nodelist outs)))) 
-
-(defun tgen (outs register constant)
-  (prog (z)
-    (setq z (symbol-value register))
-    (and (numberp z)
-	 (not (> constant z))
-	 (eval-nodelist outs)))) 
-
-(defun tlen (outs register constant)
-  (prog (z)
-    (setq z (symbol-value register))
-    (and (numberp z)
-	 (not (> z constant))
-	 (eval-nodelist outs)))) 
-
-(defun teqs (outs vara varb)
-  (prog (a b)
-    (setq a (symbol-value vara))
-    (setq b (symbol-value varb))
-    (cond ((eq a b) (eval-nodelist outs))
-	  ((and (numberp a)
-		(numberp b)
-		(=alg a b))
-	   (eval-nodelist outs))))) 
-
-(defun tnes (outs vara varb)
-  (prog (a b)
-    (setq a (symbol-value vara))
-    (setq b (symbol-value varb))
-    (cond ((eq a b) (return nil))
-	  ((and (numberp a)
-		(numberp b)
-		(=alg a b))
-	   (return nil))
-	  (t (eval-nodelist outs))))) 
-
-(defun txxs (outs vara varb)
-  (prog (a b)
-    (setq a (symbol-value vara))
-    (setq b (symbol-value varb))
-    (cond ((and (numberp a) (numberp b)) (eval-nodelist outs))
-	  ((and (not (numberp a)) (not (numberp b)))
-	   (eval-nodelist outs))))) 
-
-(defun tlts (outs vara varb)
-  (prog (a b)
-    (setq a (symbol-value vara))
-    (setq b (symbol-value varb))
-    (and (numberp a)
-	 (numberp b)
-	 (> b a)
-	 (eval-nodelist outs)))) 
-
-(defun tgts (outs vara varb)
-  (prog (a b)
-    (setq a (symbol-value vara))
-    (setq b (symbol-value varb))
-    (and (numberp a)
-	 (numberp b)
-	 (> a b)
-	 (eval-nodelist outs)))) 
-
-(defun tges (outs vara varb)
-  (prog (a b)
-    (setq a (symbol-value vara))
-    (setq b (symbol-value varb))
-    (and (numberp a)
-	 (numberp b)
-	 (not (> b a))
-	 (eval-nodelist outs)))) 
-
-(defun tles (outs vara varb)
-  (prog (a b)
-    (setq a (symbol-value vara))
-    (setq b (symbol-value varb))
-    (and (numberp a)
-	 (numberp b)
-	 (not (> a b))
-	 (eval-nodelist outs)))) 
-
-(defun &two (left-outs right-outs)
-  (prog (fp dp)
-    (cond (*sendtocall*
-	   (setq fp *flag-part*)
-	   (setq dp *data-part*))
-	  (t
-	   (setq fp *alpha-flag-part*)
-	   (setq dp *alpha-data-part*)))
-    (sendto fp dp 'left left-outs)
-    (sendto fp dp 'right right-outs))) 
-
-(defun &mem (left-outs right-outs memory-list)
-  (prog (fp dp)
-    (cond (*sendtocall*
-	   (setq fp *flag-part*)
-	   (setq dp *data-part*))
-	  (t
-	   (setq fp *alpha-flag-part*)
-	   (setq dp *alpha-data-part*)))
-    (sendto fp dp 'left left-outs)
-    (add-token memory-list fp dp nil)
-    (sendto fp dp 'right right-outs))) 
-
-(defun &and (outs lpred rpred tests)
-  (prog (mem)
-    (cond ((eq *side* 'right) (setq mem (memory-part lpred)))
-	  (t (setq mem (memory-part rpred))))
-    (cond ((not mem) (return nil))
-	  ((eq *side* 'right) (and-right outs mem tests))
-	  (t (and-left outs mem tests))))) 
-
-(defun and-left (outs mem tests)
-  (prog (fp dp memdp tlist tst lind rind res)
-    (setq fp *flag-part*)
-    (setq dp *data-part*)
-    fail (and (null mem) (return nil))
-    (setq memdp (car mem))
-    (setq mem (cdr mem))
-    (setq tlist tests)
-    tloop (and (null tlist) (go succ))
-    (setq tst (car tlist))
-    (setq tlist (cdr tlist))
-    (setq lind (car tlist))
-    (setq tlist (cdr tlist))
-    (setq rind (car tlist))
-    (setq tlist (cdr tlist))
-    ;###        (comment the next line differs in and-left & -right)
-    (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
-    (cond (res (go tloop))
-	  (t (go fail)))
-    succ 
-    ;###	(comment the next line differs in and-left & -right)
-    (sendto fp (cons (car memdp) dp) 'left outs)
-    (go fail))) 
-
-(defun and-right (outs mem tests)
-  (prog (fp dp memdp tlist tst lind rind res)
-    (setq fp *flag-part*)
-    (setq dp *data-part*)
-    fail (and (null mem) (return nil))
-    (setq memdp (car mem))
-    (setq mem (cdr mem))
-    (setq tlist tests)
-    tloop (and (null tlist) (go succ))
-    (setq tst (car tlist))
-    (setq tlist (cdr tlist))
-    (setq lind (car tlist))
-    (setq tlist (cdr tlist))
-    (setq rind (car tlist))
-    (setq tlist (cdr tlist))
-    ;###        (comment the next line differs in and-left & -right)
-    (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
-    (cond (res (go tloop))
-	  (t (go fail)))
-    succ 
-    ;###        (comment the next line differs in and-left & -right)
-    (sendto fp (cons (car dp) memdp) 'right outs)
-    (go fail))) 
-
-
-(defun teqb (new eqvar)
-  (cond ((eq new eqvar) t)
-	((not (numberp new)) nil)
-	((not (numberp eqvar)) nil)
-	((=alg new eqvar) t)
-	(t nil))) 
-
-(defun tneb (new eqvar)
-  (cond ((eq new eqvar) nil)
-	((not (numberp new)) t)
-	((not (numberp eqvar)) t)
-	((=alg new eqvar) nil)
-	(t t))) 
-
-(defun tltb (new eqvar)
-  (cond ((not (numberp new)) nil)
-	((not (numberp eqvar)) nil)
-	((> eqvar new) t)
-	(t nil))) 
-
-(defun tgtb (new eqvar)
-  (cond ((not (numberp new)) nil)
-	((not (numberp eqvar)) nil)
-	((> new eqvar) t)
-	(t nil))) 
-
-(defun tgeb (new eqvar)
-  (cond ((not (numberp new)) nil)
-	((not (numberp eqvar)) nil)
-	((not (> eqvar new)) t)
-	(t nil))) 
-
-(defun tleb (new eqvar)
-  (cond ((not (numberp new)) nil)
-	((not (numberp eqvar)) nil)
-	((not (> new eqvar)) t)
-	(t nil))) 
-
-(defun txxb (new eqvar)
-  (cond ((numberp new)
-	 (cond ((numberp eqvar) t)
-	       (t nil)))
-	(t
-	 (cond ((numberp eqvar) nil)
-	       (t t))))) 
-
-
-(defun &p (rating name var-dope ce-var-dope rhs)
-  (declare (ignore var-dope ce-var-dope rhs))
-  (prog (fp dp)
-    (cond (*sendtocall*
-	   (setq fp *flag-part*)
-	   (setq dp *data-part*))
-	  (t
-	   (setq fp *alpha-flag-part*)
-	   (setq dp *alpha-data-part*)))
-    (and (member fp '(nil old)) (removecs name dp))
-    (and fp (insertcs name dp rating)))) 
-
-(defun &old (a b c d e)
-  (declare (ignore a b c d e))
-  nil) 
-
-(defun &not (outs lmem rpred tests)
-  (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil)
-	((eq *side* 'right) (not-right outs (car lmem) tests))
-	(t (not-left outs (memory-part rpred) tests lmem)))) 
-
-(defun not-left (outs mem tests own-mem)
-  (prog (fp dp memdp tlist tst lind rind res c)
-    (setq fp *flag-part*)
-    (setq dp *data-part*)
-    (setq c 0.)
-    fail (and (null mem) (go fin))
-    (setq memdp (car mem))
-    (setq mem (cdr mem))
-    (setq tlist tests)
-    tloop (and (null tlist) (setq c (1+ c)) (go fail))
-    (setq tst (car tlist))
-    (setq tlist (cdr tlist))
-    (setq lind (car tlist))
-    (setq tlist (cdr tlist))
-    (setq rind (car tlist))
-    (setq tlist (cdr tlist))
-    ;###        (comment the next line differs in not-left & -right)
-    (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
-    (cond (res (go tloop))
-	  (t (go fail)))
-    fin  (add-token own-mem fp dp c)
-    (and (== c 0.) (sendto fp dp 'left outs)))) 
-
-(defun not-right (outs mem tests)
-  (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
-    (setq fp *flag-part*)
-    (setq dp *data-part*)
-    (cond ((not fp) (setq inc -1.) (setq newfp 'new))
-	  ((eq fp 'new) (setq inc 1.) (setq newfp nil))
-	  (t (return nil)))
-    fail (and (null mem) (return nil))
-    (setq memdp (car mem))
-    (setq newc (cadr mem))
-    (setq tlist tests)
-    tloop (and (null tlist) (go succ))
-    (setq tst (car tlist))
-    (setq tlist (cdr tlist))
-    (setq lind (car tlist))
-    (setq tlist (cdr tlist))
-    (setq rind (car tlist))
-    (setq tlist (cdr tlist))
-    ;###        (comment the next line differs in not-left & -right)
-    (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
-    (cond (res (go tloop))
-	  (t (setq mem (cddr mem)) (go fail)))
-    succ (setq newc (+ inc newc))		;"plus" changed to "+" by gdw
-    (rplaca (cdr mem) newc)
-    (cond ((or (and (== inc -1.) (== newc 0.))
-	       (and (== inc 1.) (== newc 1.)))
-	   (sendto newfp memdp 'right outs)))
-    (setq mem (cddr mem))
-    (go fail))) 
-
-
-
-;;; Node memories
-
-
-(defun add-token (memlis flag data-part num)
-  (prog (was-present)
-    (cond ((eq flag 'new)
-	   (setq was-present nil)
-	   (real-add-token memlis data-part num))
-	  ((not flag) 
-	   (setq was-present (remove-old memlis data-part num)))
-	  ((eq flag 'old) (setq was-present t)))
-    (return was-present))) 
-
-(defun real-add-token (lis data-part num)
-  (setq *current-token* (1+ *current-token*))
-  (cond (num (rplaca lis (cons num (car lis)))))
-  (rplaca lis (cons data-part (car lis)))) 
-
-(defun remove-old (lis data num)
-  (cond (num (remove-old-num lis data))
-	(t (remove-old-no-num lis data)))) 
-
-(defun remove-old-num (lis data)
-  (prog (m next last)
-    (setq m (car lis))
-    (cond ((atom m) (return nil))
-	  ((top-levels-eq data (car m))
-	   (setq *current-token* (1- *current-token*))
-	   (rplaca lis (cddr m))
-	   (return (car m))))
-    (setq next m)
-    loop (setq last next)
-    (setq next (cddr next))
-    (cond ((atom next) (return nil))
-	  ((top-levels-eq data (car next))
-	   (rplacd (cdr last) (cddr next))
-	   (setq *current-token* (1- *current-token*))
-	   (return (car next)))
-	  (t (go loop))))) 
-
-(defun remove-old-no-num (lis data)
-  (prog (m next last)
-    (setq m (car lis))
-    (cond ((atom m) (return nil))
-	  ((top-levels-eq data (car m))
-	   (setq *current-token* (1- *current-token*))
-	   (rplaca lis (cdr m))
-	   (return (car m))))
-    (setq next m)
-    loop (setq last next)
-    (setq next (cdr next))
-    (cond ((atom next) (return nil))
-	  ((top-levels-eq data (car next))
-	   (rplacd last (cdr next))
-	   (setq *current-token* (1- *current-token*))
-	   (return (car next)))
-	  (t (go loop))))) 
-
-
-
-;;; Conflict Resolution
-;
-;
-; each conflict set element is a list of the following form:
-; ((p-name . data-part) (sorted wm-recency) special-case-number)
-
-(defun order-tags (dat)
-  (prog (tags)
-    (setq tags nil)
-    l1p  (and (atom dat) (go l2p))
-    (setq tags (cons (creation-time (car dat)) tags))
-    (setq dat (cdr dat))
-    (go l1p)
-    l2p  (cond ((eq *strategy* 'mea)
-		(return (cons (car tags) (dsort (cdr tags)))))
-	       (t (return (dsort tags)))))) 
-
-; destructively sort x into descending order
-
-(defun dsort (x)
-  (prog (sorted cur next cval nval)
-    (and (atom (cdr x)) (return x))
-    loop (setq sorted t)
-    (setq cur x)
-    (setq next (cdr x))
-    chek (setq cval (car cur))
-    (setq nval (car next))
-    (cond ((> nval cval)
-	   (setq sorted nil)
-	   (rplaca cur nval)
-	   (rplaca next cval)))
-    (setq cur next)
-    (setq next (cdr cur))
-    (cond ((not (null next)) (go chek))
-	  (sorted (return x))
-	  (t (go loop))))) 
-
-(defun order-part (conflict-elem) (cdr conflict-elem)) 
-
-(defun conflict-set-compare (x y)
-  (prog (x-order y-order xl yl xv yv)
-    (setq x-order (order-part x))
-    (setq y-order (order-part y))
-    (setq xl (car x-order))
-    (setq yl (car y-order))
-    data (cond ((and (null xl) (null yl)) (go ps))
-	       ((null yl) (return t))
-	       ((null xl) (return nil)))
-    (setq xv (car xl))
-    (setq yv (car yl))
-    (cond ((> xv yv) (return t))
-	  ((> yv xv) (return nil)))
-    (setq xl (cdr xl))
-    (setq yl (cdr yl))
-    (go data)
-    ps   (setq xl (cdr x-order))
-    (setq yl (cdr y-order))
-    psl  (cond ((null xl) (return t)))
-    (setq xv (car xl))
-    (setq yv (car yl))
-    (cond ((> xv yv) (return t))
-	  ((> yv xv) (return nil)))
-    (setq xl (cdr xl))
-    (setq yl (cdr yl))
-    (go psl))) 
-
-
-
-;;; WM maintaining functions
-;
-; The order of operations in the following two functions is critical.
-; add-to-wm order: (1) change wm (2) record change (3) match 
-; remove-from-wm order: (1) record change (2) match (3) change wm
-; (back will not restore state properly unless wm changes are recorded
-; before the cs changes that they cause)  (match will give errors if 
-; the thing matched is not in wm at the time)
-
-; remove-from-wm uses eq, not equal to determine if wme is present
-
-; mapwm maps down the elements of wm, applying fn to each element
-; each element is of form (datum . creation-time)
-
-(defun mapwm (fn)
-  (prog (wmpl part)
-    (setq wmpl *wmpart-list*)
-    lab1 (cond ((atom wmpl) (return nil)))
-    (setq part (get (car wmpl) 'wmpart*))
-    (setq wmpl (cdr wmpl))
-    (mapc fn part)
-    (go lab1))) 
-
-(defun ops-wm (a) 
-  (mapc (function (lambda (z) (terpri) (ppelm z *standard-output*))) 
-	(get-wm a))
-  nil)
-
-(defun get-wm (z)
-  (setq *wm-filter* z)
-  (setq *wm* nil)
-  (mapwm (function get-wm2))
-  (prog2 nil *wm* (setq *wm* nil))) 
-
-(defun get-wm2 (elem) 
-  (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*))
-	(setq *wm* (cons (car elem) *wm*)))))
-
-(defun creation-time (wme)
-  (cdr (soarassq wme (get (wm-hash wme) 'wmpart*)))) 
-
-(defun refresh nil
-  (prog nil
-    (setq *old-wm* nil)
-    (mapwm (function refresh-collect))
-    (mapc (function refresh-del) *old-wm*)
-    (mapc (function refresh-add) *old-wm*)
-    (setq *old-wm* nil))) 
-
-(defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*))) 
-
-(defun refresh-del (x) (remove-from-wm (car x))) 
-
-;;;soar redefined add-to-wm 
-;;;;(defun refresh-add (x) (add-to-wm (car x) (cdr x))) 
-
-(defun trace-file ()
-  (prog (port)
-    (setq port *standard-output*)
-    (cond (*trace-file*
-	   (setq port ($ofile *trace-file*))
-	   (cond ((null port)
-		  (%warn '|trace: file has been closed| *trace-file*)
-		  (setq port *standard-output*)))))
-    (return port)))
-
-;;; Basic functions for RHS evaluation
-
-(defun time-tag-print (data port)
-  (cond ((not (null data))
-	 (time-tag-print (cdr data) port)
-	 (princq '| | port)
-	 (princq (creation-time (car data)) port))))
-
-(defun init-var-mem (vlist)
-  (prog (v ind r)
-    (setq *variable-memory* nil)
-    top  (and (atom vlist) (return nil))
-    (setq v (car vlist))
-    (setq ind (cadr vlist))
-    (setq vlist (cddr vlist))
-    (setq r (gelm *data-matched* ind))
-    (setq *variable-memory* (cons (cons v r) *variable-memory*))
-    (go top))) 
-
-(defun init-ce-var-mem (vlist)
-  (prog (v ind r)
-    (setq *ce-variable-memory* nil)
-    top  (and (atom vlist) (return nil))
-    (setq v (car vlist))
-    (setq ind (cadr vlist))
-    (setq vlist (cddr vlist))
-    (setq r (ce-gelm *data-matched* ind))
-    (setq *ce-variable-memory*
-	  (cons (cons v r) *ce-variable-memory*))
-    (go top))) 
-
-(defun make-ce-var-bind (var elem)
-  (setq *ce-variable-memory*
-	(cons (cons var elem) *ce-variable-memory*))) 
-
-(defun make-var-bind (var elem)
-  (setq *variable-memory* (cons (cons var elem) *variable-memory*))) 
-
-(defun get-ce-var-bind (x)
-  (prog (r)
-    (cond ((numberp x) (return (get-num-ce x))))
-    (setq r (soarassq x *ce-variable-memory*))
-    (cond (r (return (cdr r)))
-	  (t (return nil))))) 
-
-(defun get-num-ce (x)
-  (prog (r l d)
-    (setq r *data-matched*)
-    (setq l (length r))
-    (setq d (- l x))
-    (and (> 0. d) (return nil))
-    la   (cond ((null r) (return nil))
-	       ((> 1. d) (return (car r))))
-    (setq d (1- d))
-    (setq r (cdr r))
-    (go la))) 
-
-
-(defun build-collect (z)
-  (prog (r)
-    la   (and (atom z) (return nil))
-    (setq r (car z))
-    (setq z (cdr z))
-    (cond ((consp  r)	;dtpr\consp gdw
-	   ($value '\()
-		   (build-collect r)
-		   ($value '\)))
-	  ((eq r '\\) ($change (car z)) (setq z (cdr z)))
-	  (t ($value r)))
-    (go la))) 
-
-(defun unflat (x) (setq *rest* x) (unflat*)) 
-
-(defun unflat* nil
-  (prog (c)
-    (cond ((atom *rest*) (return nil)))
-    (setq c (car *rest*))
-    (setq *rest* (cdr *rest*))
-    (cond ((eq c '\() (return (cons (unflat*) (unflat*))))
-	   ((eq c '\)) (return nil))
-	  (t (return (cons c (unflat*))))))) 
-
-
-(defun $change (x)
-  (prog nil
-    (cond ((consp  x) (eval-function x))	;dtpr\consp gdw
-	  (t ($value ($varbind x)))))) 
-
-(defun eval-args (z)
-  (prog (r)
-    (rhs-tab 1.)
-    la   (and (atom z) (return nil))
-    (setq r (car z))
-    (setq z (cdr z))
-    (cond ((EQ R '^)
-	   (RHS-tab (car z))
-	   (setq r (cadr z))
-	   (setq z (cddr z))))
-    (cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
-	  (t ($change r)))
-    (go la))) 
-
-
-(defun eval-function (form)
-  (cond ((not *in-rhs*)
-	 (%warn '|functions cannot be used at top level| (car form)))
-	(t (eval form))))
-
-;;; Functions to manipulate the result array
-
-(defun $reset nil
-  (setq *max-index* 0.)
-  (setq *next-index* 1.)) 
-
-(defun rhs-tab (z) ($tab ($varbind z)))
-
-(defun $tab (z)
-  (prog (edge next)
-    (setq next ($litbind z))
-    (and (floatp next) (setq next (fix next)))
-    (cond ((or (not (numberp next)) 
-	       (> next *size-result-array*)
-	       (> 1. next))				; ( '| |)
-	   (%warn '|illegal index after ^| next)
-	   (return *next-index*)))
-    (setq edge (- next 1.))
-    (cond ((> *max-index* edge) (go ok)))
-    clear (cond ((== *max-index* edge) (go ok)))
-    (putvector *result-array* edge nil)
-    (setq edge (1- edge))
-    (go clear)
-    ok   (setq *next-index* next)
-    (return next))) 
-
-(defun $value (v)
-  (cond ((> *next-index* *size-result-array*)
-	 (%warn '|index too large| *next-index*))
-	(t
-	 (and (> *next-index* *max-index*)
-	      (setq *max-index* *next-index*))
-	 (putvector *result-array* *next-index* v)
-	 (setq *next-index* (1+ *next-index*))))) 
-
-
-(defun use-result-array nil
-  (prog (k r)
-    (setq k *max-index*)
-    (setq r nil)
-    top  (and (== k 0.) (return r))
-    (setq r (cons (getvector *result-array* k) r))
-    (setq k (1- k))
-    (go top))) 
-
-(defun $assert nil
-  (setq *last* (use-result-array))
-  (add-to-wm *last*))
-
-(defun $parametercount nil *max-index*)
-
-(defun $parameter (k)
-  (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
-	 (%warn '|illegal parameter number | k)
-	 nil)
-	((> k *max-index*) nil)
-	(t (getvector *result-array* k))))
-
-
-;;; RHS actions
-
-(defun ops-make (z)
-  (prog nil
-    ($reset)
-    (eval-args z)
-    ($assert))) 
-
-(defun ops-modify (z)
-  (prog (old)
-    (cond ((not *in-rhs*)
-	   (%warn '|cannot be called at top level| 'modify)
-	   (return nil)))
-    (setq old (get-ce-var-bind (car z)))
-    (cond ((null old)
-	   (%warn '|modify: first argument must be an element variable|
-		  (car z))
-	   (return nil)))
-    (remove-from-wm old)
-    (setq z (cdr z))
-    ($reset)
-    copy (and (atom old) (go fin))
-    ($change (car old))
-    (setq old (cdr old))
-    (go copy)
-    fin  (eval-args z)
-    ($assert))) 
-
-(defun ops-cbind (z)
-  (cond ((not *in-rhs*)
-	 (%warn '|cannot be called at top level| 'cbind))
-	((not (= (length z) 1.))
-	 (%warn '|cbind: wrong number of arguments| z))
-	((not (symbolp (car z)))
-	 (%warn '|cbind: illegal argument| (car z)))
-	((null *last*)
-	 (%warn '|cbind: nothing added yet| (car z)))
-	(t (make-ce-var-bind (car z) *last*)))) 
-
-(defun ops-remove (z)
-  (prog (old)
-    (and (not *in-rhs*)(return (top-level-remove z)))
-    top  (and (atom z) (return nil))
-    (setq old (get-ce-var-bind (car z)))
-    (cond ((null old)
-	   (%warn '|remove: argument not an element variable| (car z))
-	   (return nil)))
-    (remove-from-wm old)
-    (setq z (cdr z))
-    (go top))) 
-
-(defun ops-call1 (z)
-  (prog (f)
-    (setq f (car z))
-    ($reset)
-    (eval-args (cdr z))
-    (funcall f))) 
-
-(defmacro append-string (x)
-  `(setq wrstring (concatenate 'simple-string wrstring ,x)))
-
-(defun default-write-file ()
-  (prog (port)
-    (setq port *standard-output*)
-    (cond (*write-file*
-	   (setq port ($ofile *write-file*))
-	   (cond ((null port) 
-		  (%warn '|write: file has been closed| *write-file*)
-		  (setq port *standard-output*)))))
-    (return port)))
-
-(defun do-rjust (width value port)
-  (prog (size)
-    (cond ((eq value '|=== T A B T O ===|)
-	   (%warn '|rjust cannot precede this function| 'tabto)
-	   (return nil))
-	  ((eq value '|=== C R L F ===|)
-	   (%warn '|rjust cannot precede this function| 'crlf)
-	   (return nil))
-	  ((eq value '|=== R J U S T ===|)
-	   (%warn '|rjust cannot precede this function| 'rjust)
-	   (return nil)))
-    ;original->        (setq size (flatc value (1+ width)))
-    (setq size (min value (1+ width)))  ;### KLUGE
-    (cond ((> size width)
-	   (princq '| | port)
-	   (princq value port)
-	   (return nil)))
-    (princq value port)))
-
-(defun do-tabto (col &optional port)
-  (prog (pos)
-    (finish-output port);kluge
-    (setq pos 0);kluge
-    (do ((k (- col pos) (1- k))) ((not (> k 0))) (princq '| | port))
-    (return nil)))
-
-(defun halt nil 
-  (cond ((not *in-rhs*)
-	 (%warn '|cannot be called at top level| 'halt))
-	(t (setq *halt-flag* t)))) 
-
-(defun ops-build (z)
-  (prog (r)
-    (cond ((not *in-rhs*)
-	   (%warn '|cannot be called at top level| 'build)
-	   (return nil)))
-    ($reset)
-    (build-collect z)
-    (setq r (unflat (use-result-array)))
-    (and *build-trace* (funcall *build-trace* r))
-    (compile-production (car r) (cdr r)))) 
-
-(defun ops-openfile (z)
-  (prog (file mode id)
-    ($reset)
-    (eval-args z)
-    (cond ((not (equal ($parametercount) 3.))
-	   (%warn '|openfile: wrong number of arguments| z)
-	   (return nil)))
-    (setq id ($parameter 1))
-    (setq file ($parameter 2))
-    (setq mode ($parameter 3))
-    (cond ((not (symbolp id))
-	   (%warn '|openfile: file id must be a symbolic atom| id)
-	   (return nil))
-	  ((null id)
-	   (%warn '|openfile: 'nil' is reserved for the terminal| nil)
-	   (return nil))
-	  ((or ($ifile id)($ofile id))
-	   (%warn '|openfile: name already in use| id)
-	   (return nil)))
-       (cond ((eq mode 'in) (soarputprop id (setq id (infile file)) 'inputfile))
-	  ((eq mode 'out) (soarputprop id (setq id (outfile file)) 'outputfile))
-	  (t (%warn '|openfile: illegal mode| mode)
-	     (return nil)))
-    (return nil)))
-
-(defun $ifile (x) 
-  (cond ((symbolp x) (get x 'inputfile))
-	(t nil)))
-
-(defun $ofile (x) 
-  (cond ((symbolp x) (get x 'outputfile))
-	(t nil)))
-
-(defun ops-closefile (z)
-  ($reset)
-  (eval-args z)
-  (mapc (function closefile2) (use-result-array)))
-
-(defun closefile2 (file)
-  (prog (port)
-    (cond ((not (symbolp file))
-	   (%warn '|closefile: illegal file identifier| file))
-	  ((setq port ($ifile file))
-	   (close port)
-	   (remprop file 'inputfile))
-	  ((setq port ($ofile file))
-	   (close port)
-	   (remprop file 'outputfile)))
-    (return nil)))
-
-(defun ops-default (z)
-  (prog (file use)
-    ($reset)
-    (eval-args z)
-    (cond ((not (equal ($parametercount) 2.))
-	   (%warn '|default: wrong number of arguments| z)
-	   (return nil)))
-    (setq file ($parameter 1))
-    (setq use ($parameter 2))
-    (cond ((not (symbolp file))
-	   (%warn '|default: illegal file identifier| file)
-	   (return nil))
-	  ((not (member use '(write accept trace) :test #'equal))
-	   (%warn '|default: illegal use for a file| use)
-	   (return nil))
-	  ((and (member use '(write trace) :test #'equal)
-		(not (null file))
-		(not ($ofile file)))
-	   (%warn '|default: file has not been opened for output| file)
-	   (return nil))
-	  ((and (equal use 'accept) 
-		(not (null file))
-		(not ($ifile file)))
-	   (%warn '|default: file has not been opened for input| file)
-	   (return nil))
-	  ((equal use 'write) (setq *write-file* file))
-	  ((equal use 'accept) (setq *accept-file* file))
-	  ((equal use 'trace) (setq *trace-file* file)))
-    (return nil)))
-
-(defun flat-value (x)
-  (cond ((atom x) ($value x))
-	(t (mapc (function flat-value) x)))) 
-
-(defun ops-accept (z)
-  (prog (port arg)
-    (cond ((> (length z) 1.)
-	   (%warn '|accept: wrong number of arguments| z)
-	   (return nil)))
-    (setq port *standard-input*)
-    (cond (*accept-file*
-	   (setq port ($ifile *accept-file*))
-	   (cond ((null port) 
-		  (%warn '|accept: file has been closed| *accept-file*)
-		  (return nil)))))
-    (cond ((= (length z) 1)
-	   (setq arg ($varbind (car z)))
-	   (cond ((not (symbolp arg))
-		  (%warn '|accept: illegal file name| arg)
-		  (return nil)))
-	   (setq port ($ifile arg))
-	   (cond ((null port) 
-		  (%warn '|accept: file not open for input| arg)
-		  (return nil)))))
-    (cond ((equal (peek-char t port nil "eof" ) "eof" )
-	   ($value 'end-of-file)
-	   (return nil)))
-    (flat-value (read port)))) 
-
-(defun ops-acceptline (z)
-  (let ((port *standard-input*)
-	(def z))
-    (cond (*accept-file*
-	   (setq port ($ifile *accept-file*))
-	   (cond ((null port) 
-		  (%warn '|acceptline: file has been closed| 
-			 *accept-file*)
-		  (return-from ops-acceptline nil)))))
-    (cond ((> (length def) 0)
-	   (let ((arg ($varbind (car def))))
-	     (cond ((and (symbolp arg) ($ifile arg))
-		    (setq port ($ifile arg))
-		    (setq def (cdr def)))))))
-    (let ((line (read-line port nil 'eof)))
-      (declare (simple-string line))
-      ;; Strip meaningless characters from start and end of string.
-      (setq line (string-trim '(#\( #\) #\, #\tab #\space) line))
-      (when (equal line "")
-	(mapc (function $change) def)
-	(return-from ops-acceptline nil))
-      (setq line (concatenate 'simple-string "(" line ")"))
-      ;; Read all items from the line
-      (flat-value (read-from-string line)))))
-
-(defun ops-substr (l)
-  (prog (k elm start end)
-    (cond ((not (= (length l) 3.))
-	   (%warn '|substr: wrong number of arguments| l)
-	   (return nil)))
-    (setq elm (get-ce-var-bind (car l)))
-    (cond ((null elm)
-	   (%warn '|first argument to substr must be a ce var|
-		  l)
-	   (return nil)))
-    (setq start ($varbind (cadr l)))
-    (setq start ($litbind start))
-    (cond ((not (numberp start))
-	   (%warn '|second argument to substr must be a number|
-		  l)
-	   (return nil)))
-    ;###	(comment |if a variable is bound to INF, the following|
-			 ;	 |will get the binding and treat it as INF is|
-			 ;	 |always treated.  that may not be good|)
-    (setq end ($varbind (caddr l)))
-    (cond ((eq end 'inf) (setq end (length elm))))
-    (setq end ($litbind end))
-    (cond ((not (numberp end))
-	   (%warn '|third argument to substr must be a number|
-		  l)
-	   (return nil)))
-    (setq k 1.)
-    la   (cond ((> k end) (return nil))
-	       ((not (< k start)) ($value (car elm))))
-    (setq elm (cdr elm))
-    (setq k (1+ k))
-    (go la))) 
-
-(defun ops-compute (z) ($value (ari z))) 
-
-(defun ops-arith (z) ($value (ari z))) 
-
-(defun ari (x)
-  (cond ((atom x)
-	 (%warn '|bad syntax in arithmetic expression | x)
-	 0.)
-	((atom (cdr x)) (ari-unit (car x)))
-	((eq (cadr x) '+)
-	 (+ (ari-unit (car x)) (ari (cddr x))))
-	;"plus" changed to "+" by gdw
-	((eq (cadr x) '-)
-	 (- (ari-unit (car x)) (ari (cddr x))))
-	((eq (cadr x) '*)
-	 (* (ari-unit (car x)) (ari (cddr x))))
-	((eq (cadr x) '//)
-	 (floor (ari-unit (car x)) (ari (cddr x))))   ;@@@ quotient? /
-	;@@@ kluge only works for integers
-	;@@@ changed to floor by jcp (from round)
-	((eq (cadr x) '\\)
-	 (mod (fix (ari-unit (car x))) (fix (ari (cddr x)))))
-	(t (%warn '|bad syntax in arithmetic expression | x) 0.))) 
-
-(defun ari-unit (a)
-  (prog (r)
-    (cond ((consp  a) (setq r (ari a)))	;dtpr\consp gdw
-	  (t (setq r ($varbind a))))
-    (cond ((not (numberp r))
-	   (%warn '|bad value in arithmetic expression| a)
-	   (return 0.))
-	  (t (return r))))) 
-
-(defun genatom nil ($value (gensym))) 
-
-(defun ops-litval (z)
-  (prog (r)
-    (cond ((not (= (length z) 1.))
-	   (%warn '|litval: wrong number of arguments| z)
-	   ($value 0) 
-	   (return nil))
-	  ((numberp (car z)) ($value (car z)) (return nil)))
-    (setq r ($litbind ($varbind (car z))))
-    (cond ((numberp r) ($value r) (return nil)))
-    (%warn '|litval: argument has no literal binding| (car z))
-    ($value 0)))
-
-;;; Printing WM
-
-(defun ppwm2 (elm-tag)
-  (cond ((filter (car elm-tag))
-	 (terpri) (ppelm (car elm-tag) (default-write-file))))) 
-
-(defun filter (elm)
-  (prog (fl indx val)
-    (setq fl *filters*)
-    top  (and (atom fl) (return t))
-    (setq indx (car fl))
-    (setq val (cadr fl))
-    (setq fl (cddr fl))
-    (and (ident (nth (1- indx) elm) val) (go top))
-    (return nil))) 
-
-(defun ident (x y)
-  (cond ((eq x y) t)
-	((not (numberp x)) nil)
-	((not (numberp y)) nil)
-	((=alg x y) t)
-	(t nil))) 
-
-; the new ppelm is designed especially to handle literalize format
-; however, it will do as well as the old ppelm on other formats
-
-(defun ppelm (elm port)
-  (prog (ppdat sep val att mode lastpos)
-    (princq (creation-time elm) port)
-    (princq '|:  | port)
-    (setq mode 'vector)
-    (setq ppdat (get (car elm) 'ppdat))
-    (and ppdat (setq mode 'a-v))
-    (setq sep "(")				; ")" 
-    (setq lastpos 0)
-    (do ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
-	((atom vlist) nil)					; terminate
-      (setq val (car vlist))				; tagbody begin
-      (setq att (assoc curpos ppdat))	;should ret (curpos attr-name) 
-      (cond (att (setq att (cdr att)))	; att = (attr-name) ??
-	    (t (setq att curpos)))
-      (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
-      (cond ((or (not (null val)) (eq mode 'vector))
-	     (princq sep port)
-	     (ppval val att lastpos port)
-	     (setq sep '|    |)
-	     (setq lastpos curpos))))
-    (princq '|)| port)))
-
-(defun ppval (val att lastpos port)
-  ;  (break "in ppval")		
-  (cond ((not (equal att (1+ lastpos)))		; ok, if we got an att 
-	 (princq '^ port)
-	 (princq att port)
-	 (princq '| | port)))
-  (princq val port))
-
-;;; printing production memory
-
-(defun ppline2 ()
-  (prog (needspace)
-    (setq needspace nil)
-    top  (and (atom *ppline*) (return nil))
-    (and needspace (princ '| |))
-    (cond ((eq (car *ppline*) '^) (ppattval))
-	  (t (pponlyval)))
-    (setq needspace t)
-    (go top)))
-
-(defun getval ()
-  (prog (res v1)
-    (setq v1 (car *ppline*))
-    (setq *ppline* (cdr *ppline*))
-    (cond ((member v1 '(= <> < <= => > <=>))
-	   (setq res (cons v1 (getval))))
-	  ((eq v1 '{)
-	   (setq res (cons v1 (getupto '}))))
-	  ((eq v1 '<<)
-	   (setq res (cons v1 (getupto '>>))))
-	  ((eq v1 '//)
-	   (setq res (list v1 (car *ppline*)))
-	   (setq *ppline* (cdr *ppline*)))
-	  (t (setq res (list v1))))
-    (return res)))
-
-(defun getupto (end)
-  (prog (v)
-    (and (atom *ppline*) (return nil))
-    (setq v (car *ppline*))
-    (setq *ppline* (cdr *ppline*))
-    (cond ((eq v end) (return (list v)))
-	  (t (return (cons v (getupto end))))))) 
-
-;;; backing up
-
-(defun record-index-plus (k)
-  (setq *record-index* (+ k *record-index*))	;"plus" changed to "+" by gdw
-  (cond ((< *record-index* 0.)
-	 (setq *record-index* *max-record-index*))
-	((> *record-index* *max-record-index*)
-	 (setq *record-index* 0.)))) 
-
-(defun initialize-record nil
-  (setq *record-index* 0.)
-  (setq *recording* nil)
-  (setq *max-record-index* 31.)
-  (putvector *record-array* 0. nil)) 
-
-(defun begin-record (p data)
-  (setq *recording* t)
-  (setq *record* (list '=>refract p data))) 
-
-(defun end-record nil
-  (cond (*recording*
-	 (setq *record*
-	       (cons *cycle-count* (cons *p-name* *record*)))
-	 (record-index-plus 1.)
-	 (putvector *record-array* *record-index* *record*)
-	 (setq *record* nil)
-	 (setq *recording* nil)))) 
-
-(defun record-change (direct time elm)
-  (cond (*recording*
-	 (setq *record*
-	       (cons direct (cons time (cons elm *record*))))))) 
-
-(defun record-refract (rule data)
-  (and *recording*
-       (setq *record* (cons '<=refract (cons rule (cons data *record*))))))
-
-(defun refracted (rule data)
-  (prog (z)
-    (and (null *refracts*) (return nil))
-    (setq z (cons rule data))
-    (return (member z *refracts* :test #'equal))))
-
-(defun back (k)
-  (prog (r)
-    loop   (and (< k 1.) (return nil))
-    (setq r (getvector *record-array* *record-index*))	; (('))
-    (and (null r) (return '|nothing more stored|))
-    (putvector *record-array* *record-index* nil)
-    (record-index-plus -1.)
-    (undo-record r)
-    (setq k (1- k))
-    (go loop)))
-
-(defun undo-record (r)
-  (prog (save act a b rate)
-    (setq save *recording*)
-    (setq *refracts* nil)
-    (setq *recording* nil)
-    (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
-    (setq r (cddr r))
-    top  (and (atom r) (go fin))
-    (setq act (car r))
-    (setq a (cadr r))
-    (setq b (caddr r))
-    (setq r (cdddr r))
-    (and *wtrace* (back-print (list '|undo:| act a)))
-    (cond ((eq act '<=wm) (add-to-wm b a))
-	  ((eq act '=>wm) (remove-from-wm b))
-	  ((eq act '<=refract)
-	   (setq *refracts* (cons (cons a b) *refracts*)))
-	  ((and (eq act '=>refract) (still-present b))
-	   (setq *refracts* (spdelete (cons a b) *refracts*))
-	   (setq rate (rating-part (get a 'topnode)))
-	   (removecs a b)
-	   (insertcs a b rate))
-	  (t (%warn '|back: cannot undo action| (list act a))))
-    (go top)
-    fin  (setq *recording* save)
-    (setq *refracts* nil)
-    (return nil))) 
-
-(defun still-present (data)
-  (prog nil
-    loop
-    (cond ((atom data) (return t))
-	  ((creation-time (car data))
-	   (setq data (cdr data))
-	   (go loop))
-	  (t (return nil))))) 
-
-(defun back-print (x) 
-  (prog (port)
-    (setq port (trace-file))
-    (terpri port)
-    (print x port)))
-
-(defun ops-matches (rule-list)
-  (mapc (function matches2) rule-list)
-  (terpri)) 
-
-(defun matches2 (p)
-  (cond ((atom p)
-	 (terpri)
-	 (terpri)
-	 (princ p)
-	 (matches3 (get p 'backpointers) 2. (ncons 1.))))) 
-
-(defun matches3 (nodes ce part)
-  (cond ((not (null nodes))
-	 (terpri)
-	 (princ '| ** matches for |)
-	 (princ part)
-	 (princ '| ** |)
-	 (mapc (function write-elms) (find-left-mem (car nodes)))
-	 (terpri)
-	 (princ '| ** matches for |)
-	 (princ (ncons ce))
-	 (princ '| ** |)
-	 (mapc (function write-elms) (find-right-mem (car nodes)))
-	 (matches3 (cdr nodes) (1+ ce) (cons ce part))))) 
-
-(defun write-elms (wme-or-count)
-  (cond ((consp  wme-or-count)	;dtpr\consp gdw
-	 (terpri)
-	 (mapc (function write-elms2) wme-or-count)))) 
-
-(defun write-elms2 (x)
-  (princ '|  |)
-  (princ (creation-time x)))
-
-(defun find-left-mem (node)
-  (cond ((eq (car node) '&and) (memory-part (caddr node)))
-	(t (car (caddr node))))) 
-
-(defun find-right-mem (node) (memory-part (cadddr node))) 
-
-
-;;; Check the RHSs of productions 
-
-(defun check-rhs (rhs) (mapc (function check-action) rhs))
-
-(defun check-build (z)
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (check-build-collect (cdr z)))
-
-(defun check-build-collect (args)
-  (prog (r)
-    top	(and (null args) (return nil))
-    (setq r (car args))
-    (setq args (cdr args))
-    (cond ((consp  r) (check-build-collect r))	;dtpr\consp gdw
-	  ((eq r '\\)
-	   (and (null args) (%warn '|nothing to evaluate| r))
-	   (check-rhs-value (car args))
-	   (setq args (cdr args))))
-    (go top)))
-
-(defun check-remove (z) 				;@@@ kluge by gdw
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (mapc (function check-rhs-ce-var) (cdr z))) 
-
-(defun check-openfile (z)
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (check-change& (cdr z))) 
-
-(defun check-closefile (z)
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (check-change& (cdr z))) 
-
-(defun check-default (z)
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (check-change& (cdr z))) 
-
-(defun check-write (z)				;note this works w/write
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (check-change& (cdr z))) 
-
-(defun check-call1 (z)
-  (prog (f)
-    (and (null (cdr z)) (%warn '|needs arguments| z))
-    (setq f (cadr z))
-    (and (variablep f)
-	 (%warn '|function name must be a constant| z))
-    (or (symbolp f)
-	(%warn '|function name must be a symbolic atom| f))
-    (or (externalp f)
-	(%warn '|function name not declared external| f))
-    (check-change& (cddr z)))) 
-
-(defun check-halt (z)
-  (or (null (cdr z)) (%warn '|does not take arguments| z))) 
-
-(defun check-cbind (z)
-  (prog (v)
-    (or (= (length z) 2.) (%warn '|takes only one argument| z))
-    (setq v (cadr z))
-    (or (variablep v) (%warn '|takes variable as argument| z))
-    (note-ce-variable v))) 
-
-(defun check-bind (z)
-  (prog (v)
-    (or (> (length z) 1.) (%warn '|needs arguments| z))
-    (setq v (cadr z))
-    (or (variablep v) (%warn '|takes variable as argument| z))
-    (note-variable v)
-    (check-change& (cddr z)))) 
-
-
-(defun check-change& (z)
-  (prog (r tab-flag)
-    (setq tab-flag nil)
-    la   (and (atom z) (return nil))
-    (setq r (car z))
-    (setq z (cdr z))
-    (cond ((eq r '^)
-	   (and tab-flag
-		(%warn '|no value before this tab| (car z)))
-	   (setq tab-flag t)
-	   (check-tab-index (car z))
-	   (setq z (cdr z)))
-	  ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
-	  (t (setq tab-flag nil) (check-rhs-value r)))
-    (go la))) 
-
-(defun check-rhs-ce-var (v)
-  (cond ((and (not (numberp v)) (not (ce-bound? v)))
-	 (%warn '|unbound element variable| v))
-	((and (numberp v) (or (< v 1.) (> v *ce-count*)))
-	 (%warn '|numeric element designator out of bounds| v)))) 
-
-(defun check-rhs-atomic (x)
-  (and (variablep x) 
-       (not (bound? x)) 
-       (%warn '|unbound variable| x)))
-
-(defun check-rhs-function (x)
-  (prog (a)
-    (setq a (car x))
-    (cond ((eq a 'compute) (check-compute x))
-	  ((eq a 'arith) (check-compute x))
-	  ((eq a 'substr) (check-substr x))
-	  ((eq a 'accept) (check-accept x))
-	  ((eq a 'acceptline) (check-acceptline x))
-	  ((eq a 'crlf) (check-crlf x))
-	  ((eq a 'genatom) (check-genatom x))
-	  ((eq a 'litval) (check-litval x))
-	  ((eq a 'tabto) (check-tabto x))
-	  ((eq a 'rjust) (check-rjust x))
-	  ((not (externalp a))
-	   (%warn '"rhs function not declared external" a)))))
-
-(defun check-litval (x) 
-  (or (= (length x) 2) (%warn '|wrong number of arguments| x))
-  (check-rhs-atomic (cadr x)))
-
-(defun check-accept (x)
-  (cond ((= (length x) 1) nil)
-	((= (length x) 2) (check-rhs-atomic (cadr x)))
-	(t (%warn '|too many arguments| x))))
-
-(defun check-acceptline (x)
-  (mapc (function check-rhs-atomic) (cdr x)))
-
-(defun check-crlf (x) 
-  (check-0-args x)) 
-
-(defun check-genatom (x) (check-0-args x)) 
-
-(defun check-tabto (x)
-  (or (= (length x) 2) (%warn '|wrong number of arguments| x))
-  (check-print-control (cadr x)))
-
-(defun check-rjust (x)
-  (or (= (length x) 2) (%warn '|wrong number of arguments| x))
-  (check-print-control (cadr x)))
-
-(defun check-0-args (x)
-  (or (= (length x) 1.) (%warn '|should not have arguments| x))) 
-
-(defun check-substr (x)
-  (or (= (length x) 4.) (%warn '|wrong number of arguments| x))
-  (check-rhs-ce-var (cadr x))
-  (check-substr-index (caddr x))
-  (check-last-substr-index (cadddr x))) 
-
-(defun check-compute (x) (check-arithmetic (cdr x))) 
-
-(defun check-arithmetic (l)
-  (cond ((atom l)
-	 (%warn '|syntax error in arithmetic expression| l))
-	((atom (cdr l)) (check-term (car l)))
-	((not (member (cadr l) '(+ - * // \\)))	;"plus" changed to "+" by gdw
-	 (%warn '|unknown operator| l))
-	(t (check-term (car l)) (check-arithmetic (cddr l))))) 
-
-(defun check-term (x)
-  (cond ((consp  x) (check-arithmetic x))	;dtpr\consp gdw
-	(t (check-rhs-atomic x)))) 
-
-(defun check-last-substr-index (x)
-  (or (eq x 'inf) (check-substr-index x))) 
-
-(defun check-substr-index (x)
-  (prog (v)
-    (cond ((bound? x) (return x)))
-    (setq v ($litbind x))
-    (cond ((not (numberp v))
-	   (%warn '|unbound symbol used as index in substr| x))
-	  ((or (< v 1.) (> v 127.))
-	   (%warn '|index out of bounds in tab| x))))) 
-
-(defun check-print-control (x)
-  (prog ()
-    (cond ((bound? x) (return x)))
-    (cond ((or (not (numberp x)) (< x 1.) (> x 127.))
-	   (%warn '|illegal value for printer control| x))))) 
-
-(defun check-tab-index (x)
-  (prog (v)
-    (cond ((bound? x) (return x)))
-    (setq v ($litbind x))
-    (cond ((not (numberp v))
-	   (%warn '|unbound symbol occurs after ^| x))
-	  ((or (< v 1.) (> v 127.))
-	   (%warn '|index out of bounds after ^| x))))) 
-
-(defun note-variable (var)
-  (setq *rhs-bound-vars* (cons var *rhs-bound-vars*)))
-
-(defun bound? (var)
-  (or (member var *rhs-bound-vars*)
-      (var-dope var)))
-
-(defun note-ce-variable (ce-var)
-  (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*)))
-
-(defun ce-bound? (ce-var)
-  (or (member ce-var *rhs-bound-ce-vars*)
-      (ce-var-dope ce-var)))
-
-;;; Top level routines
-
-(defun process-changes (adds dels)
-  (prog (x)
-    process-deletes (and (atom dels) (go process-adds))
-    (setq x (car dels))
-    (setq dels (cdr dels))
-    (remove-from-wm x)
-    (go process-deletes)
-    process-adds (and (atom adds) (return nil))
-    (setq x (car adds))
-    (setq adds (cdr adds))
-    (add-to-wm x nil)
-    (go process-adds))) 
-
-(defun check-limits nil
-  (cond ((> (length *conflict-set*) *limit-cs*)
-	 (format t "~%~%conflict set size exceeded the limit of ~D after ~D~%"
-		 *limit-cs* *p-name*)
-	 (setq *halt-flag* t)))
-  (cond ((> *current-token* *limit-token*)
-	 (format t "~%~%token memory size exceeded the limit of ~D after ~D~%"
-		 *limit-token* *p-name*)
-	 (setq *halt-flag* t))))
-
-(defun top-level-remove (z)
-  (cond ((equal z '(*)) (process-changes nil (get-wm nil)))
-	(t (process-changes nil (get-wm z))))) 
-
-(defun ops-excise (z) (mapc (function excise-p) z))
-
-(defun ops-strategy (z)
-  (cond ((atom z) *strategy*)
-	((equal z '(lex)) (setq *strategy* 'lex))
-	((equal z '(mea)) (setq *strategy* 'mea))
-	(t 'what?))) 
-
-(defun ops-cs (z)
-  (cond ((atom z) (conflict-set))
-	(t 'what?))) 
-
-(defun ops-external (z) (catch '!error! (external2 z)))
-
-(defun external2 (z) (mapc (function external3) z))
-
-(defun external3 (x) 
-  (cond ((symbolp x) (soarputprop x t 'external-routine))
-	(t (%error '|not a legal function name| x))))
-
-(defun externalp (x)
-  (cond ((symbolp x) t)
-	(t (%warn '|not a legal function name| x) nil)))
-
-(defun rematm (atm list)
-  (cond ((atom list) list)
-	((eq atm (car list)) (rematm atm (cdr list)))
-	(t (cons (car list) (rematm atm (cdr list))))))
-
-(defun broken (rule) (member rule *brkpts*))
-
-(defun fix (x) (floor x))
-
-(defun infile (f_name)
-  (open f_name :direction :input))
-
-(defun sequencep (x) (typep x 'sequence))
-
-(defun outfile (f_name)
-  (open f_name :direction :output :if-exists :new-version))
-
-;**********
-; Soar 4.0
-;**********
-
-(proclaim '(special *3600-display* *action-closure* *action-list* 
-	            *already-fired* *always-learn*  *attribute-index*
-		    *begin-time* *big-index* *big-info-index* 
-                    *brknames* *brkrun* *cav* *cavi* *chunk-all-paths* 
-		    *chunk-classes* *chunk-free-problem-spaces* *chunks* 
-	            *closure* *condition-list* *condition-vars* *context* 
-                    *context-field-found* *context-stack* *copy-action-list* 
-		    *created-list* *creating-subgoal* 
-	            *current-goal* *current-list* *current-preferences*
-		    *current-production-trace* *data-matched* *decide-count*
-	            *decide-trace* *default-multi* *default-user-select*
-		    *dtrace* *elaborations-count* *elapsed-time*
-	            *first-action* *first-remove* *free-gensym-list* 
-                    *free-pname-list* *global-pair* *goal-index* *gtrace* 
-                    *id-index* *impasse-subset-not-equal* *indent* *init-wm* 
-                    *instance-attributes* *interlisp* *last-value-var* 
-		    *learn-ids* *learning* *ltrace* *max-chunk-conditions*
-	            *max-elaborations* *max-recurse* *multi-attribute*
-	            *never-learn* *new-chunks* *new-contexts* *new-root*
-	            *operator-index* *ops5-actions* *order-trace* *otrace*
-	            *p-type* *pick-first-condition* *pnames* 
-		    *preference-found* *print-attribute-list* *print-learn* 
-                    *print-pname* *print-spo-list* *prior-operator* 
-                    *problem-space-index* *prod-count* *rcontext* 
-		    *rcontext-stack* *remaining-decide* *result*
-	            *save-action* *save-class-list* *save-condition*
-	            *select-equal* *slot-index* *smaller-chunks* 
-                    *sp-classes* *split-actions* *spo-default-depth* 
-		    *state-index* *strace* *sub-context* *subgoal-results*
-	            *subgoal-tabs* *suspected-duplicates* *trace-number*
-	            *tracep* *tracep-list* *ttrace* *unbound* 
-	            *unbound-action-ids* *used-char-list* *used-gensym-list*
-	            *used-var-list* *user-ids* *value-index* *variable-pairs*
-	            *version-number* *warning* *watch-free-problem-spaces*
-		    *wme-list-stack*))
-
-; ******************************
-
-;;;  Macros and functions to help in the conversion of the Soar system
-;;;     from Interlisp to Commonlisp.
-
-(defmacro soarterpri (&body z)
-  (cons 'terpri z))
-
-(defmacro smake (&body z)
-  (cond ((assoc (car z) *sp-classes*)
-	 (spm-to-make z))
-	(t
-	 (cons 'make z))))
-
-(defmacro soarwarn (&body z)
-	(cons '%warn z))	; Using Ops5 %warn function	
-(defmacro %%warn (&body z)
-	(cons '%warn z))	; Using Ops5 %warn function	
-(defmacro %%error (&body z)
-	(cons '%error z))	; Using Ops5 %error function	
-
-(defmacro soarsort (list)
-	`(sort ,list #'string-lessp))
-
-(defmacro soardelq (item list)
-	`(delete ,item ,list :test #'eq))
-(defmacro dremove (item list)
-	`(delete ,item ,list :test #'eq))
-
-(defmacro soarassoc (item alist)
-	`(assoc ,item ,alist :test #'equalp))
-
-(defmacro soarmemq (item list)
-	`(member ,item ,list :test #'eq))
-(defmacro soarmember (item list)
-	`(member ,item ,list :test #'equalp))
-
-(defun addprop (n a v)
-	(soarputprop n (cons v (get n a)) a))
-
-(defmacro soarmapc (func list)
-	`(mapc ,func ,list))
-
-(defmacro soarmapcar (func list)
-	`(mapcar ,func ,list))
-
-(defmacro soarmapconc (func list)
-	`(mapcan ,func ,list))
-
-(defmacro soarpush (item list)
-	`(push ,item ,list))
-
-(defmacro quotient (x y)
-	`(float (/ ,x ,y)))
-
-(defmacro neq (&body z)
-	(list 'not  (cons 'eq z)))
-
-(defmacro copy (thing)
-	`(copy-tree ,thing))
-
-(defmacro soarnth (ind list)
-	`(nth ,ind ,list))
-
-(defmacro soarnthcdr (ind list)
-	`(nthcdr ,ind ,list))
-
-(defmacro alwaystime ()
-	`(get-internal-run-time))
-
-(defmacro time-conversion (tempus)
-        `(float (/ ,tempus internal-time-units-per-second)))
-
-(defmacro init-gensym (&body z)
-	(declare (ignore z))
-	`(gensym 0) )	
-
-(defun soargensymbol (x)
-	(gentemp (string x)))
-
-(defun soarnthchar (sym num)
-  (char (string sym) (- num 1)))
-
-(defun soarpack (a b c d)
-	(intern (format nil "~A~A~D~A" a b c d)))
-
-(defun soarpack2 (a b)
-	(intern (format nil "~A~A" a b)))
-
-(defmacro soarload (f)
-        `(load ,f))
-
-(defmacro soar-do (&body z)
-	(cons 'do z))
-
-(defmacro soarwhile (test &body z)
-  (append (list 'do '() (list (list 'not test))) z))
-
-(defun rplnode (x c d)
-        (rplaca x c)
-        (rplacd x d))
-
-(defmacro soarcarsort (x)
-	`(sort ,x #'string-lessp :key #'car))
-
-(defmacro array (n)
-	`(make-array ,n :initial-element () ))
-(defmacro makevector (n)
-	`(make-array ,n :initial-element () ))
-
-(defmacro soarcatch (&body z)
-	(cons 'catch z))
-
-(defmacro *throw (&body z)
-	(cons 'throw z))
-
-(defmacro readp (z)
-	`(listen ,z))
-
-(defmacro concat (&body z)
-	(cons 'concatenate (cons '(quote string) z)))
-
-(defmacro dreverse (x)
-	`(nreverse ,x))
-
-
-(eval-when (compile load eval)
-  (set-macro-character #\{ #'(lambda (s c)
-			       (declare (ignore s c))
-			       '\{))   ;5/5/83
-  (set-macro-character #\} #'(lambda (s c)
-			       (declare (ignore s c))
-			       '\}))   ;5/5/83
-  (set-macro-character #\^ #'(lambda (s c)
-			       (declare (ignore s c))
-			       '\^))   ;5/5/83
-  )
-
-(defmacro SETSYNTAX (&body z)
-	`() )		; I'm betting that these can be ignored
-
-(defun soarsyntax ()
-)
-
-(defun soarresetsyntax ()
-)
-
-(defmacro selectq (&body z)
-	(setq z (nreverse z))
-	(cond
-	  ((eq 'err (car z))
-	   (cons 'ecase (nreverse (cdr z))))
-	  (t
-	   (cons 'case (nreverse z))))
-)
-
-(defun soarclearprops (sym)
-	(setf (symbol-plist sym)  () )
-)
-
-(defun soarmachinetype ()
-	(setq *3600-display* nil)
-	(setq *interlisp* nil)
-)
-
-
-(defun interlisp-menu (x)
-	(declare (ignore x))
-	t
-)
-
-(defun pm-size () 
-	(terpri)
-	(printlinec (list *pcount* 'productions
-				(list *real-cnt* '// *virtual-cnt* 'nodes))))
-
-(defun printlinec (x)
-	(mapc (function printlinec*) x))
-
-(defun printlinec* (x)
-	(princ " ")
-	(princ  x))
-
-(defun flatc (x)
-    (cond ((numberp x)
-	   3)
-	  ((atom x)
-	   (length (string x)))
-          (t
-	   (+ (flatc (car x)) (flatc (cdr x)) 1))))
-
-(defun flast (list)
-	 (last list))
-(defun soarlast (list)
-	 (car (last list)))
-
-(defun soarlistp (thing)
-  (cond ((null thing)
-	 NIL)
-	(t
-	 (listp thing))))
-
-(defmacro comment (&body z)
-	(declare (ignore z))
-	t)
-
-
-(defmacro pop-match-elt (x)
-	`(prog (temp)
-	  (setq temp (classify-match-elt ,x))
-	  (setq ,x (car temp))
-	  (return (cdr temp))))
-
-(defmacro pop-term (x)
-	`(prog (temp)
-	  (setq temp (classify-term ,x))
-	  (setq ,x (car temp))
-	  (return (cdr temp))))
-
-(defun variablep (x)
-  (and (symbolp x) (equalp (soarnthchar x 1) #\<)
-       (not (predicatep x)) (not (eq x '<<))))
-
-; ******************************
-
-;;; Do not print a decimal point after integers
-(setq *nopoint* t)
-
-(defun start-soar nil
-	(i-g-v))
-
-(defun nwritn (x)
-  (send standard-output ':read-cursorpos ':character))
-
-; For version 4.0
-(defmacro class (x) `(car ,x))
-(defmacro identifier (x) `(cadr ,x))
-(defmacro sattribute (x) `(caddr ,x))
-(defmacro svalue (x) `(cadddr ,x))
-
-(defmacro call2 (&body z)
-  (list 'ops-call2 (list 'quote z)))
-
-(defmacro d (&body z)
-  (list 'ops-d (list 'quote z)))
-
-(defmacro sremove (&body z)
-  (list 'ops-sremove (list 'quote z)))
-
-(defmacro po (&body z)
-  (list 'ops-po (list 'quote z)))
-
-(defmacro pi (&body z)
-  (list 'ops-pi (list 'quote z)))
-
-(defmacro pop-goal (&body z)
-  (list 'ops-pop-goal (list 'quote z)))
-
-(defmacro ptrace (&body z)
-  (list 'ops-ptrace (list 'quote z)))
-
-(defmacro smatches (&body z)
-  (list 'ops-smatches (list 'quote z)))
-
-(defmacro spop (&body z)
-  (list 'ops-spop (list 'quote z)))
-
-(defmacro swatch (&body z)
-  (list 'ops-swatch (list 'quote z)))
-
-(defmacro tabstop (&body z)
-  (list 'ops-tabstop (list 'quote z)))
-
-(defmacro unpbreak (&body z)
-  (list 'ops-unpbreak (list 'quote z)))
-
-(defmacro write1 (&body z)
-  (list 'ops-write1 (list 'quote z)))
-
-(defmacro write2 (&body z)
-  (list 'ops-write2 (list 'quote z)))
-
-(defmacro sp (&body z)
-  (list 'ops-sp (list 'quote z)))
-
-(defmacro spm (&body z)
-  (list 'ops-spm (list 'quote z)))
-
-(defmacro spo (&body z)
-  (list 'ops-spo (list 'quote z)))
-
-(defmacro sppwm (&body z)
-  (list 'ops-sppwm (list 'quote z)))
-
-(defmacro spr (&body z)
-  (list 'ops-spr (list 'quote z)))
-
-(defmacro swm (&body z)
-  (list 'ops-swm (list 'quote z)))
-
-; common lisp ops should fix this with package
-;; (defmacro write (&body z)
-;;  (list 'ops-write (list 'quote z)))
-
-(defmacro back-trace (&body z)
-  (list 'ops-back-trace (list 'quote z)))
-
-(defmacro learn (&body z)
-  (list 'ops-learn (list 'quote z)))
-
-(defun back-trace-conditions (current-goal action-list trace-flag)
-  (prog (production-traces production-trace previously-traced action actions return-list
-         depth)
-        (cond (trace-flag
-               (soarprint " ")
-               (soarprinc "Backtracing to determine conditions")
-               (soarprinc " for goal: ")
-               (soarprint current-goal)
-               (soarprint "Working-memory elements being traced:")
-               (soarmapc #'ppline
-                (p-conds-to-sp (soarmapcar #'clean-up-element action-list)))
-               (soarprint " ")
-               (soarprinc "Productions and conditions traced through:")))
-        (setq depth 0)
-        (setq return-list nil)
-        (setq actions action-list)
-        (setq previously-traced nil)
-        (setq production-traces (get current-goal 'production-trace))
-     l0 (cond ((null action-list) (return return-list)))
-        (setq action (pop action-list))
-        (cond ((eq action 'mark) (setq depth (1- depth)) (go l0))
-              ((eq action '-)
-               (setq action (pop action-list))
-               (cond ((and (neq current-goal (get (svalue action) 'in-id-field))
-                           (not (soarmember action return-list)))
-                      (trace-new-condition action trace-flag depth '-)
-                      (soarpush action return-list)
-                      (soarpush '- return-list)))
-               (go l0))
-              ((and (eq (class action) 'goal-context-info)
-                    (or (not (soarmember action *created-list*))
-                        (and *smaller-chunks*
-                             (not (soarmemq action actions))
-                             (soarmember action *subgoal-results*))))
-               (cond ((not (soarmember action return-list))
-                      (trace-new-condition action trace-flag depth nil)
-                      (soarpush action return-list)))
-               (go l0))
-              ((and (neq (class action) 'goal-context-info)
-                    (or (not (soarmemq action *created-list*))
-                        (and *smaller-chunks*
-                             (not (soarmemq action actions))
-                             (soarmemq action *subgoal-results*))))
-               (cond ((not (soarmemq action return-list))
-                      (trace-new-condition action trace-flag depth nil)
-                      (soarpush action return-list)))
-               (go l0))
-              ((null action) (go l0)))
-        (setq production-trace (find-back-production action production-traces))
-        (cond ((null production-trace) (go l0)))
-        (cond ((soarmemq (car production-trace) previously-traced) (go l0))
-              (t (soarpush (car production-trace) previously-traced)))
-        (setq action-list (append (cadr production-trace) (cons 'mark action-list)))
-        (cond (trace-flag
-               (do-tabto (* 3 depth) (trace-file))
-               (soarprint (caddr production-trace))))
-        (setq depth (1+ depth))
-        (go l0)))
-
-(defun broken2 (value)
-  (cond ((or (soarlistp value)
-             (null value))
-         nil)
-        ((or (soarmemq (get value 'name) *brknames*)
-             (soarmemq value *brknames*)
-             (and *brkrun*
-                  (eq (get value 'name) *brkrun*))
-             (eq value *brkrun*)))))
-
-(defun build-sp-cond (avlist extralist)
-  (prog (result)
-        (soarmapc
-         #'(lambda (x) (setq result (append (car x) (append (nreverse (cdr x)) result))))
-         avlist)
-        (setq result (append (nreverse extralist) result))
-        (return result)))
-
-(defun ops-call2 (z)
-  (prog (sym val)
-        (cond ((not *in-rhs*)
-               (soarwarn "Cannot be called at top level " 'call2)
-               (return nil))
-              ((not (symbolp (car z)))
-               (soarwarn "Call2: illegal argument " (car z))
-               (return nil)))
-        ($reset)
-        (eval-args z)
-        (eval (use-result-array))))
-
-(defun cdrmember (element list)
-  (prog nil
-     l0 (cond ((null list) (return nil))
-              ((equal (cdr element) (cdr (pop list))) (return t)))
-        (go l0)))
-
-(defun check-decide nil
-  (or (eq *p-type* 'decide)
-      (soarwarn "Illegal decide in production type " *p-type*)))
-
-(defun check-default-make (z)
-  (or (soarmemq *p-type* '(elaborate-once elaborate))
-      (soarwarn "Illegal make in production type " *p-type*))
-  (and (null z)
-       (soarwarn "Arguments missing from make action " z))
-  (check-change& z))
-
-(defun check-remove-ops (z)
-  (soarwarn "Illegal remove in Soar production" *p-type*)
-  (and (null (cdr z))
-       (soarwarn "Missing arguments for remove " z))
-  (soarmapc #'check-rhs-ce-var (cdr z)))
-
-(defun clean-up-element (element)
-  (clean-up-clause element 'nil))
-
-(defun compare-conditions (elm1 elm2)
-  (cond ((and (null elm1)
-              (null elm2))
-         t)
-        ((or (null elm1)
-             (null elm2))
-         nil)
-        ((eq (car elm1) (car elm2)) (compare-conditions (cdr elm1) (cdr elm2)))
-        ((and (eq (get (car elm1) 'tested) 1)
-              (eq (get (car elm2) 'tested) 1))
-         (soarpush (car elm1) *suspected-duplicates*)
-         (compare-conditions (cdr elm1) (cdr elm2)))
-        (t nil)))
-
-(defun compute-choice (choice)
-  (cond ((and (get choice 'name)
-              (get choice 'instance))
-         (concat (get choice 'name) (soarmapcar #'compute-choice (get choice 'instance))))
-        ((get choice 'name) (get choice 'name))
-        ((get choice 'instance) (soarmapcar #'compute-choice (get choice 'instance)))
-        (t choice)))
-
-(defun compute-negation-index (matrix)
-  (prog (save-matrix negation-vars negation-list count1 neg-var save-negation-vars
-         negated-conditions condition)
-        (setq negated-conditions nil)
-        (setq negation-vars nil)
-        (setq negation-list nil)
-        (setq save-matrix matrix)
-     l1 (cond (matrix
-               (cond ((equal (car matrix) '-)
-                      (pop matrix)
-                      (soarpush (remove-condition-trash (car matrix)) negated-conditions)
-                      (setq negation-vars
-                             (merge-not-time (find-neg-variables (car negated-conditions))
-                              negation-vars))))
-               (pop matrix)
-               (go l1)))
-        (and (null negated-conditions)
-             (return nil))
-        (setq count1 0)
-     l3 (cond ((or (null save-matrix)
-                   (eq condition '-->))
-               (return (list negated-conditions negation-list))))
-        (setq condition (pop save-matrix))
-        (cond ((eq condition '-) (setq save-matrix (cdr save-matrix)) (go l3)))
-        (setq save-negation-vars negation-vars)
-        (setq negation-vars nil)
-     l4 (cond ((null save-negation-vars) (setq count1 (1+ count1)) (go l3)))
-        (setq neg-var (pop save-negation-vars))
-        (cond ((eq condition '-->) (soarpush neg-var negation-vars))
-              ((soarmemq neg-var condition)
-               (soarpush (list neg-var count1 (find-position neg-var condition))
-                negation-list))
-              (t (soarpush neg-var negation-vars)))
-        (go l4)))
-
-(defun condition-trace (x)
-  (trace-condition-action x 'condition))
-
-(defun conv-input-wme (input)
-  (cond ((numberp input) (get-wm (list input)))
-        ((and (soarlistp input)
-              (neq (car input) 'preference))
-         (soarmapconc #'sswm (sp-info-expand nil input nil)))
-        ((soarlistp input) (sswm input))
-        (t (sswm (append '(^ identifier) (list input))))))
-
-(defun create-goal-info (data-matched goal-id)
-  (setq *data-matched* data-matched)
-  (setq *first-action* t))
-
-(defun created (g)
-  (soarmapc #'print (get g 'created))
-  t)
-
-(defun ops-d (dc)
-  (cond ((atom dc) (run)) (t (eval (list 'run (car dc) 'd)))))
-
-(defun delprop (name attribute value)
-  (soarputprop name (dremove value (get name attribute)) attribute))
-
-(defun eliminate-trailing-nil (wme)
-  (prog nil
-        (cond ((atom wme) (return wme)) ((soarlast wme) (return wme)))
-        (setq wme (dreverse wme))
-     l1 (cond ((car wme) (return (dreverse wme))))
-        (setq wme (cdr wme))
-        (go l1)))
-
-(defun excise-chunks nil
-  (prog (chunks)
-        (setq chunks (append *chunks* nil))
-        (soarmapc #'(lambda (x) (setq *tracep-list* (dremove x *tracep-list*))) chunks)
-        (eval (cons 'excise chunks))))
-
-(defun fill-up (wme)
-  (fill-up-c wme 'new)
-  (sendto 'new (list wme) 'left (list *new-root*)))
-
-(defun fill-up-c (wme flag)
-  (prog (dp)
-        (setq *alpha-flag-part* flag)
-        (setq *alpha-data-part* (list wme))
-        (setq dp wme)
-        (setq *c1* (car dp))
-        (setq dp (cdr dp))
-        (setq *c2* (car dp))
-        (setq dp (cdr dp))
-        (setq *c3* (car dp))
-        (setq dp (cdr dp))
-        (setq *c4* (car dp))
-        (setq dp (cdr dp))
-        (setq *c5* (car dp))
-        (setq dp (cdr dp))
-        (setq *c6* (car dp))
-        (setq dp (cdr dp))
-        (setq *c7* (car dp))
-        (setq dp (cdr dp))
-        (setq *c8* (car dp))
-        (setq dp (cdr dp))
-        (setq *c9* (car dp))
-        (setq dp (cdr dp))
-        (setq *c10* (car dp))
-        (setq dp (cdr dp))
-        (setq *c11* (car dp))
-        (setq dp (cdr dp))
-        (setq *c12* (car dp))
-        (setq dp (cdr dp))
-        (setq *c13* (car dp))
-        (setq dp (cdr dp))
-        (setq *c14* (car dp))
-        (setq dp (cdr dp))
-        (setq *c15* (car dp))
-        (setq dp (cdr dp))
-        (setq *c16* (car dp))))
-
-(defun fill-up-wm (wm)
-  (soarmapc #'fill-up wm))
-
-(defun fill-up2 (wme)
-  (fill-up-c (car wme) 'new)
-  (sendto 'new (list (car wme)) 'left (list *new-root*)))
-
-(defun find-acceptable-preference (preferences id)
-  (prog (preference)
-     l0 (cond ((null preferences) (return nil)))
-        (setq preference (pop preferences))
-        (cond ((and (eq 'preference (class preference))
-                    (eq id (identifier preference))
-                    (eq 'acceptable (svalue preference)))
-               (return preference)))
-        (go l0)))
-
-(defun find-action-sets (actions subgoal)
-  (prog (return-list new-action-list current-closure moved-action action possible-actions)
-        (setq return-list nil)
-     l0 (and (null actions)
-             (return (nreverse return-list)))
-        (setq action (pop actions))
-        (setq new-action-list (list action))
-        (setq current-closure (find-unbound-symbols action))
-        (cond ((null current-closure)
-               (soarpush (nreverse new-action-list) return-list)
-               (go l0)))
-     l2 (setq moved-action nil)
-        (setq possible-actions actions)
-        (setq actions nil)
-     l1 (cond ((and (null possible-actions)
-                    moved-action)
-               (go l2))
-              ((null possible-actions)
-               (soarpush (nreverse new-action-list) return-list)
-               (go l0)))
-        (setq action (pop possible-actions))
-        (cond ((intrq (cons (cadr action) (cdddr action)) current-closure)
-               (setq current-closure
-                      (append (find-unbound-symbols action) current-closure))
-               (soarpush action new-action-list)
-               (setq moved-action t))
-              ((and *smaller-chunks*
-                    (neq (car action) 'preference)
-                    (intrq (list (cadr action)) current-closure))
-               (setq current-closure
-                      (append (find-unbound-symbols action) current-closure))
-               (soarpush action new-action-list)
-               (setq moved-action t))
-              ((and *smaller-chunks*
-                    (eq (car action) 'preference)
-                    (intrq (list (cddddr action)) current-closure))
-               (setq current-closure
-                      (append (find-unbound-symbols action) current-closure))
-               (soarpush action new-action-list)
-               (setq moved-action t))
-              (t (soarpush action actions)))
-        (go l1)))
-
-(defun find-back-production (action traces)
-  (cdr (cond ((eq (class action) 'goal-context-info) (soarassoc action traces))
-             (t (soarassq action traces)))))
-
-(defun find-max-goal-depth (goal-list)
-  (prog (max-depth max-depth-goal goal-depth)
-        (setq max-depth -1)
-        (setq max-depth-goal nil)
-     l0 (cond ((null goal-list) (return max-depth-goal)))
-        (setq goal-depth (get (cadar goal-list) 'goal-depth))
-        (cond ((and goal-depth
-                    (< max-depth goal-depth))
-               (setq max-depth goal-depth)
-               (setq max-depth-goal (cadar goal-list))))
-        (pop goal-list)
-        (go l0)))
-
-(defun find-neg-variables (condition)
-  (prog (return-list)
-        (setq return-list nil)
-     l1 (cond ((null condition) (return return-list))
-              ((variablep (car condition)) (soarpush (car condition) return-list)))
-        (pop condition)
-        (go l1)))
-
-(defun find-position (var condition)
-  (prog (attribute)
-     l1 (cond ((or (null condition)
-                   (eq var (car condition)))
-               (return (1- (literal-binding-of attribute))))
-              ((and (car condition)
-                    (predicatep (car condition)))
-               (setq condition (cddr condition)))
-              ((and (car condition)
-                    (eq (car condition) '^))
-               (setq attribute (cadr condition))
-               (setq condition (cddr condition)))
-              ((and (car condition)
-                    (soarmemq (car condition) '({ })))
-               (pop condition))
-              (t (pop condition)))
-        (go l1)))
-
-(defun find-selected-result (choice results)
-  (prog (result)
-        (cond ((numberp choice)
-               (cond ((or (< choice 1)
-                          (> choice (length results)))
-                      (return nil)))
-               (return (soarnth (1- choice) results))))
-     l1 (setq result (pop results))
-        (cond ((test-selected-result choice result)
-               (and (null *select-equal*)
-                    (setq *select-equal* *default-user-select*))
-               (return result))
-              ((null results) (return nil)))
-        (go l1)))
-
-(defun find-small-action-sets (actions subgoal)
-  (prog (action action-pi pi-action-list return-list rest-pi-list)
-        (setq pi-action-list nil)
-     l1 (cond ((null actions) (return (soarmapcar #'cdr pi-action-list))))
-        (setq action (pop actions))
-        (setq action-pi
-               (car (find-back-production action (get subgoal 'production-trace))))
-        (cond ((setq rest-pi-list (soarassq action-pi pi-action-list))
-               (rplacd rest-pi-list (cons action (cdr rest-pi-list))))
-              (t (soarpush (list action-pi action) pi-action-list)))
-        (go l1)))
-
-;** Chris Fedor 11/26/85
-;** added (not (numberp value)) test to avoid doing get on a number
-(defun find-subgoal-nonresults (subgoal supergoal created-list)
-  (prog (change-flag action id nonresult-list goal value)
-        (setq *subgoal-results* nil)
-     l1 (setq change-flag nil)
-        (setq nonresult-list nil)
-     l2 (cond ((and (null created-list)
-                    (null change-flag))
-               (setq *subgoal-results* (nreverse *subgoal-results*))
-               (return nonresult-list))
-              ((null created-list)
-	       (setq created-list (nreverse nonresult-list)) (go l1)))
-        (setq action (pop created-list))
-        (setq id (identifier action))
-        (setq goal (get id 'in-id-field))
-        (cond ((or (and (eq (car action) 'preference)
-                        (closure-preference action subgoal))
-                   (and (neq (car action) 'preference)
-                        (neq goal subgoal)))
-               (setq change-flag t)
-               (soarpush action *subgoal-results*)
-               (setq value (svalue action))
-	       (cond ((and (eq (car action) 'preference)
-			   (eq goal subgoal))
-		      (soarpush id *unbound-action-ids*)
-		      (and supergoal
-			   (soarputprop id supergoal 'in-id-field)))
-		     ((and (neq (car action) 'preference)
-			   (not (numberp value))
-			   (eq (get value 'in-id-field) subgoal))
-		      (and supergoal
-			   (soarputprop value supergoal 'in-id-field))
-		      (soarpush value *unbound-action-ids*)))
-	       (and supergoal (addprop supergoal 'created action)))
-	      (t (soarpush action nonresult-list)))
-	(go l2)))
-
-(defun find-variables (list)
-  (cond ((null list) nil)
-        ((variablep (car list)) (cons (car list) (find-variables (cdr list))))
-        (t (find-variables (cdr list)))))
-
-(defun find-reject-preferences (preferences)
-  (prog (preference return-list)
-        (setq return-list nil)
-     l0 (cond ((null preferences) (return return-list)))
-        (setq preference (pop preferences))
-        (cond ((and (eq 'preference (class preference))
-                    (eq 'reject (svalue preference)))
-               (soarpush preference return-list)))
-        (go l0)))
-
-(defun find-unbound-symbols (action)
-  (prog (return-list)
-        (setq return-list nil)
-     l1 (cond ((null action) (return return-list))
-              ((and (get (car action) 'in-id-field)
-                    (soarmemq (car action) *unbound-action-ids*))
-               (soarpush (car action) return-list)))
-        (pop action)
-        (go l1)))
-
-(defun flatten (l)
-  (soarmapconc #'(lambda (item) (cond ((atom item) (list item)) (t (flatten item)))) l))
-
-(defun gensyminit nil
-  (soarmapc #'soarclearprops *used-gensym-list*)
-  (soarmapc #'move-to-free-gensym-list *used-gensym-list*)
-  (setq *used-gensym-list* nil))
-
-(defun handle-back-trace-actions (action-list old-context prior-context new-context
-                                  subgoaled)
-  (prog (duplicate-list copy-list return-value closure condition-list negation-list
-         wme-list)
-        (clear-var-list)
-        (setq wme-list
-               (back-trace-conditions (get-current old-context 'goal) action-list
-                *ltrace*))
-        (setq *p-name* (get-current old-context 'goal))
-        (setq *first-action* t)
-        (soarmapc
-         #'(lambda (x) (save-production-trace x wme-list (get-current new-context 'goal)))
-         action-list)
-        (cond ((and (not *always-learn*)
-                    (or subgoaled
-                        (get-context-subgoaled old-context)))
-               (return t))
-              ((or (not *learning*)
-                   (soarmemq (get (get-current old-context 'problem-space) 'name)
-                    *chunk-free-problem-spaces*)
-                   (not (test-context prior-context)))
-               (return nil)))
-        (setq closure (find-closure wme-list))
-        (soarmapc #'build-variable-list closure)
-        (setq *action-closure* (find-action-closure action-list))
-        (setq condition-list
-               (soarmapcar #'(lambda (x) (clean-up-clause x 'condition)) wme-list))
-        (setq action-list (soarmapcar #'clean-up-action action-list))
-        (setq condition-list (process-negations condition-list))
-        (setq negation-list (cdr condition-list))
-        (setq condition-list (build-terse (soarcarsort (car condition-list))))
-        (cond ((test-chunk-for-content condition-list)
-               (and *ltrace*
-                    (soarmapc #'ppline (p-conds-to-sp condition-list)))
-               (return nil)))
-        (setq duplicate-list
-               (compactify-conditions (append condition-list negation-list) action-list))
-        (setq copy-list (bind-it *action-list*))
-        (setq *action-list* (rebind-action-ids *action-list* copy-list))
-        (setq *copy-action-list* *action-list*)
-        (setq return-value (build-a-production *condition-list* *action-list* wme-list))
-        (and duplicate-list
-             (soarmapc #'build-copies duplicate-list))
-        (return return-value)))
-
-(defun init-literalizes nil
-  (literalize preference object role value reference goal problem-space state operator)
-  (literalize goal-context-info identifier attribute value)
-  (literalize space-info identifier attribute value)
-  (literalize state-info identifier attribute value)
-  (literalize op-info identifier attribute value)
-  (literalize eval-info identifier attribute value)
-  (literalize desired-info identifier attribute value)
-  (literalize info identifier attribute value))
-
-(defun init-soar nil
-  (setq *in-rhs* nil)
-  (sremove)
-  (setq *init-wm* nil)
-  (setq *conflict-set* nil)
-  (setq *wmpart-list* nil)
-  (setq *p-name* nil)
-  (setq *phase* 'elaborate)
-  (setq *prod-count* (setq *decide-count* (setq *cycle-count* (setq *action-count* 0))))
-  (setq *total-token* (setq *max-token* (setq *current-token* 0)))
-  (setq *first-action* nil)
-  (gensyminit)
-  (setq *current-production-trace* 'cpt)
-  (soarmapc #'soarclearprops *user-ids*)
-  (setq *user-ids* nil)
-  (and *3600-display*
-       (clear-soar2-window))
-  (setq *total-cs* (setq *max-cs* 0))
-  (setq *total-wm* (setq *max-wm* (setq *current-wm* 0)))
-  (setq *elapsed-time* 0)
-  (setq *trace-number* 0)
-  (setq *context*
-         (list (soargensym 'goal)
-               'undecided
-               'undecided
-               'undecided
-               1
-               'nil
-               'nil
-               'nil
-               'nil
-               'nil
-               0))
-  (setq *context-stack* (list *context*))
-  (setq *data-matched* nil))
-
-(defun init-wm nil
-  (prog (cg cp cs co)
-        (cond ((not *init-wm*)
-               (setq *phase* 'decide)
-               (setq cg (get-current *context* 'goal))
-               (setq cp (get-current *context* 'problem-space))
-               (setq cs (get-current *context* 'state))
-               (setq co (get-current *context* 'operator))
-               (soarputprop cg 1 'goal-depth)
-               (and *learning*
-                    (learn))
-               (make-info 'goal-context-info cg 'problem-space cp)
-               (trace-object 'goal cg 0)
-               (trace-object 'problem-space cp 0)
-               (make-info 'goal-context-info cg 'state cs)
-               (trace-object 'state cs 0)
-               (make-info 'goal-context-info cg 'operator co)
-               (trace-object 'operator co 0)
-               (setq *init-wm* t)
-               (setq *phase* 'elaborate)))))
-
-(defun intrq (x y)
-  (cond ((atom x) nil)
-        ((soarmemq (car x) y) (cons (car x) (intrq (cdr x) y)))
-        (t (intrq (cdr x) y))))
-
-(defun last-chunk nil
-  (eval (cons 'spm (list (car *chunks*)))))
-
-(defun list-chunks nil
-  (eval (cons 'spm (reverse *chunks*))))
-
-(defun make-new-root (pname)
-  (link-new-node (list '&priv nil pname)))
-
-(defun make-nil-list (list-length)
-  (prog (nil-list)
-        (setq nil-list '(nil))
-     l1 (cond ((eq list-length (length nil-list)) (return nil-list)))
-        (soarpush 'nil nil-list)
-        (go l1)))
-
-(defun mark-in-id (wme)
-  (prog (id att value port)
-        (setq port (trace-file))
-        (setq id (identifier wme))
-        (setq att (sattribute wme))
-        (and (not id)
-             (return nil))
-        (cond ((and (neq *phase* 'decide)
-                    (eq 'goal-context-info (class wme))
-                    (soarmemq att '(problem-space state operator)))
-               (soarwarn "Illegal attempt to modify context" wme)
-               (return t))
-              ((eq *phase* 'decide) (setq *current-goal* (get-current *context* 'goal)))
-              ((and (not *current-goal*)
-                    (setq *current-goal* 'undecided)))
-              ((and *first-action*
-                    (eq (get *p-name* 'type) 'elaborate-once))
-               (and (eq (cdr (soarassq *p-name* *already-fired*)) *current-goal*)
-                    (return t))
-               (soarpush (cons *p-name* *current-goal*) *already-fired*)))
-        (cond ((and (not (get id 'gensymed))
-                    (not (soarmemq id *user-ids*)))
-               (soarpush id *user-ids*)))
-        (cond ((not (get id 'in-id-field)) (soarputprop id *current-goal* 'in-id-field)))
-        (setq value (svalue wme))
-        (cond ((eq att 'name) (soarputprop id value 'name))
-              ((soarmember (list (class wme) att) *instance-attributes*)
-               (addprop id 'instance value)))
-        (cond ((not *never-learn*)
-               (save-production-trace wme (reverse *data-matched*) *current-goal*)))
-        (cond (*first-action*
-               (cond ((and *ptrace*
-                           *ttrace*
-                           (not *wtrace*)
-                           (trace-problem-space?))
-                      (soarprinc "-->")))
-               (setq *first-remove* t)
-               (setq *first-action* nil)))
-        (addprop *current-goal* 'created wme)
-        (return nil)))
-
-(defun match-update (wme)
-  (fill-up-c (car wme) 'new)
-  (sendto 'new (list (car wme)) 'left (list *new-root*)))
-
-(defun mem-length (mem)
-  (prog (n)
-        (setq n 0)
-        (soarmapc #'(lambda (ci) (cond ((soarlistp ci) (setq n (+ n 1))))) mem)
-        (return n)))
-
-(defun merge-not-time (lista listb)
-  (prog (elm)
-        (and (null lista)
-             (return listb))
-        (setq elm (car lista))
-        (cond ((null listb) (return lista))
-              ((numberp elm) (return (merge-not-time (cdr lista) listb)))
-              ((soarmemq elm listb) (return (merge-not-time (cdr lista) listb)))
-              (t (return (cons elm (merge-not-time (cdr lista) listb)))))))
-
-(defun most-recent-subgoal (context-stack)
-  (cond ((null (cdr context-stack)) (caar context-stack))
-        (t (most-recent-subgoal (cadr context-stack)))))
-
-(defun move-to-free-gensym-list (symbol)
-  (prog (char sym-list)
-        (setq char (soarnthchar symbol 1))
-        (setq sym-list (soarassq char *free-gensym-list*))
-        (cond ((null sym-list)
-               (setq *free-gensym-list*
-                      (append *free-gensym-list* (list (list char symbol)))))
-              (t (rplacd sym-list (append (list symbol) (cdr sym-list)))))))
-
-(defun multi-attribute (x)
-  (prog (class)
-        (cond ((soarassq (car x) *sp-classes*)
-               (setq class (cdr (soarassq (car x) *sp-classes*))))
-              (t (setq class (soarpack2 (car x) '-info))
-                 (soarpush (cons (car x) class) *sp-classes*)))
-        (cond ((not (soarmemq class *save-class-list*))
-               (soarpush class *save-class-list*)
-               (soarputprop class (get 'state-info 'ppdat) 'ppdat)))
-        (setq x (cdr x))
-        (cond ((and (cdr x)
-                    (numberp (cadr x))
-                    (or (> (cadr x) 99)
-                        (< (cadr x) 1)))
-               (soarwarn "Illegal multi-attribute value" (cadr x))
-               (setq x (list (car x)))))
-        (soarpush (cons class x) *multi-attribute*)))
-
-(defun multi-attributes (x)
-  (soarmapc #'multi-attribute x))
-
-(defun new-variables (condition stack)
-  (prog (first elm)
-        (setq first (car stack))
-     l1 (setq elm (pop condition))
-        (cond ((null condition) (return stack))
-              ((and (variablep elm)
-                    (neq first elm))
-               (soarpush elm stack)))
-        (go l1)))
-
-(defun new-variable-list (condition list)
-  (prog (elm)
-     l1 (setq condition (cdr condition))
-        (setq elm (car condition))
-        (cond ((null condition) (return list))
-              ((and (variablep elm)
-                    (not (soarmemq elm list)))
-               (soarpush elm list)))
-        (go l1)))
-
-(defun ops-sremove (z)
-  (cond ((equal z '*) (process-changes nil (get-wm nil)))
-        (t (process-changes nil (get-wm z)))))
-
-
-(defun sswm (avlist)
-  (cond ((and (cdddr avlist)
-              (variablep (cadddr avlist)))
-         (rplacd avlist (cddddr avlist))))
-  (cond ((not (conv-to-attr-nums avlist nil)) nil)
-        (t (mapwm #'sswm2) (prog2 nil *wm* (setq *wm* nil)))))
-
-(defun sswm2 (elm-tag)
-  (cond ((filter (car elm-tag)) (soarpush (car elm-tag) *wm*))))
-
-(defun pgs nil
-  (pgs-frame *context-stack* 1 nil nil nil)
-  (soarprintc "Decision cycle ")
-  (soarprinc *decide-count*)
-  (terpri (trace-file)))
-
-(defun pgs-frame (context-stack depth difficulty results second-time)
-  (prog (slots slot id context difficulty2 super-op result port)
-        (setq port (trace-file))
-        (setq context (pop context-stack))
-        (cond ((null context) (return nil)) (second-time (terpri (trace-file))))
-        (setq super-op (get-context-super-operator context))
-        (setq difficulty2
-               (list (get-context-difficulty context) (get-context-slot context)))
-        (setq result (get-context-results context))
-        (setq slots '(g p s o))
-     l2 (cond (slots
-               (setq id (pop context))
-               (setq slot (pop slots))
-               (cond ((neq id 'undecided)
-                      (terpri port)
-                      (cond (*subgoal-tabs* (do-tabto (+ 2 (* depth 3)) port))
-                            (t (do-tabto 5 port)
-                               (soarprinc3 "(" (1- depth) ")")
-                               (do-tabto 11 port)))
-                      (soarprinc2 slot ": ")
-                      (print-id id)
-                      (setq difficulty nil)))
-               (go l2)))
-        (setq second-time nil)
-        (soarmapc
-         #'(lambda (x)
-             (pgs-frame x (1+ depth) difficulty2 result second-time)
-             (setq second-time t))
-         context-stack)))
-
-(defun ops-po (object)
-  (print-object (car object) (cadr object)))
-
-
-(defun ops-pi (z)
-  (print-partial-instantiation (car z) (cond ((cdr z) (cadr z)) (t 1))))
-
-
-(defun ppi3 (p i nodes ce part)
-  (prog (saved-mems n smatch-flg)
-        (cond ((null nodes)
-               (setq n 0)
-               (soarmapc
-                #'(lambda (ci)
-                    (cond ((eq (car ci) p)
-                           (setq n (+ n 1))
-                           (cond ((equal n i)
-                                  (soarmapc
-                                   #'(lambda (wme) (eval (list 'wm (creation-time wme))))
-                                   (reverse (cdr ci)))
-                                  (terpri (trace-file)))))))
-                *conflict-set*)
-               (terpri (trace-file))
-               (return ce))
-              ((null (setq saved-mems (find-left-mem (car nodes)))) (return nil))
-              ((not (setq smatch-flg (ppi3 p i (cdr nodes) (1+ ce) (cons ce part))))
-               (soarmapc #'(lambda (ci) (eval (list 'wm (creation-time ci))))
-                (reverse (soarnth (1- i) saved-mems)))
-               (terpri (trace-file))
-               (return ce)))
-        (return smatch-flg)))
-
-(defun ops-pop-goal (goals)
-  (cond ((null goals)
-         (soarmapc
-          #'(lambda (x)
-              (pop-subgoals x (most-recent-subgoal *context-stack*) *context-stack*
-               (car *context-stack*)))
-          (cdr *context-stack*)))
-        (t (soarmapc
-            #'(lambda (y)
-                (soarmapc
-                 #'(lambda (x) (pop-subgoals x y *context-stack* (car *context-stack*)))
-                 (cdr *context-stack*)))
-            goals)))
-  nil)
-
-
-(defun pop-subgoals (stack g prior-stack prior-context)
-  (cond (stack
-         (cond ((eq (caar stack) g)
-                (remove-subgoal-objects stack)
-                (rplacd prior-stack nil)
-                (rplaca (soarnthcdr 4 prior-context) 0)
-                (rplaca (soarnthcdr 5 prior-context) nil))
-               (t (soarmapc #'(lambda (x) (pop-subgoals x g stack (car stack)))
-                   (cdr stack)))))))
-
-(defun print-choice (choice)
-  (print-id choice)
-  (soarprint " "))
-
-(defun print-id (id)
-  (soarprinc2 id " ")
-  (cond ((and id
-              (atom id)
-              (neq id 'undecided))
-         (and (get id 'name)
-              (soarprinc (get id 'name)))
-         (setq *print-attribute-list* (list id))
-         (print-instance id)
-         (setq *print-attribute-list* nil))))
-
-(defun print-instance (id)
-  (prog (flag)
-        (cond ((get id 'instance)
-               (setq flag nil)
-               (soarprinc "(")
-               (soarmapc
-                #'(lambda (object)
-                    (and flag
-                         (soarprinc " "))
-                    (setq flag t)
-                    (cond ((get object 'name)
-                           (soarprinc (get object 'name))
-                           (cond ((not (soarmemq object *print-attribute-list*))
-                                  (soarpush object *print-attribute-list*)
-                                  (print-instance object))))
-                          (t (soarprinc object)
-                             (cond ((not (soarmemq object *print-attribute-list*))
-                                    (soarpush object *print-attribute-list*)
-                                    (print-instance object))))))
-                (get id 'instance))
-               (soarprinc ")")))))
-
-(defun print-instantiation (p i)
-  (prog (n)
-        (setq n 0)
-        (soarmapc
-         #'(lambda (inst)
-             (cond ((eq (car inst) p)
-                    (setq n (1+ n))
-                    (cond ((equal n i)
-                           (soarmapc
-                            #'(lambda (wme) (eval (list 'wm (creation-time wme))))
-                            (reverse (cdr inst)))
-                           (terpri (trace-file)))))))
-         *conflict-set*)))
-
-(defun print-partial-instantiation (p i)
-  (ppi3 p i (get p 'backpointers) 2 (ncons 1)))
-
-(defun printline (x)
-  (soarmapc #'soarprinc x)
-  (terpri (trace-file)))
-
-(defun print-object (object depth)
-  (cond ((and *3600-display*) (draw-current-contents object))
-        (t (eval (append '(ppwm ^ identifier) (list object))))))
-
-(defun print-status nil
-  (soarprintc "Learn status: ")
-  (cond (*learning* (soarprinc "on "))
-        (*never-learn* (soarprinc "never "))
-        (t (soarprinc "off ")))
-  (cond (*always-learn* (soarprinc "always ")) (t (soarprinc "bottom-up ")))
-  (cond ((eq *print-learn* 0) (soarprinc "print "))
-        (*print-learn* (soarprinc "full-print "))
-        (t (soarprinc "noprint ")))
-  (cond ((and *ltrace* *tracep*) (soarprint "full-trace "))
-        (*tracep* (soarprint "trace "))
-        (t (soarprint "notrace ")))
-  t)
-
-(defun process-instance (instance)
-  (prog nil
-        (setq *first-action* t)
-        (accum-stats)
-        (eval-rhs (car instance) (cdr instance))
-        (check-limits)
-        (and (broken (car instance))
-             (setq *break-flag* t))))
-
-(defun process-negations (conditions)
-  (prog (return-conditions element negations)
-        (setq negations nil)
-     l2 (cond ((null conditions)
-               (setq negations (variablize-negations negations))
-               (and negations
-                    (return (cons (nreverse return-conditions)
-                                  (nreverse (tersify-negations negations)))))
-               (return (list (nreverse return-conditions))))
-              ((eq (car conditions) '-)
-               (pop conditions)
-               (soarpush (pop conditions) negations))
-              (t (soarpush (pop conditions) return-conditions)))
-        (go l2)))
-
-(defun ops-ptrace (arg)
-  (cond ((atom arg) *tracep-list*)
-        (t (setq *tracep-list*
-                  (append *tracep-list*
-                          (soarmapcar
-                           #'(lambda (x)
-                               (cond ((or (numberp x)
-                                          (soarlistp x))
-                                      (car (conv-input-wme x)))
-                                     (t x)))
-                           arg))))))
-
-
-(defun remove-condition-attributes (condition)
-  ($reset)
-  (cond ((neq (cadr condition) '^)
-         (eval-args (append (cons (car condition) '(^ identifier)) (cdr condition))))
-        (t (eval-args condition)))
-  (use-result-array))
-
-(defun remove-condition-trash (condition)
-  (prog (return-condition pand-flag disjunction-flag)
-        (setq return-condition nil)
-        (setq pand-flag nil)
-        (setq disjunction-flag nil)
-     l1 (cond ((null condition) (return (nreverse return-condition)))
-              ((eq (car condition) '<<) (pop condition) (setq disjunction-flag t))
-              ((eq (car condition) '>>) (pop condition) (setq disjunction-flag nil))
-              (disjunction-flag (pop condition))
-              ((eq (car condition) '{) (pop condition) (setq pand-flag t))
-              ((eq (car condition) '})
-               (pop condition)
-               (and pand-flag
-                    (soarpush (soargenvar 'z) return-condition))
-               (setq pand-flag nil))
-              ((predicatep (car condition)) (setq condition (cddr condition)))
-              (t (soarpush (pop condition) return-condition) (setq pand-flag nil)))
-        (go l1)))
-
-(defun remove-current (goal slot old-value new-value)
-  (prog nil
-        (cond ((soarlistp old-value)
-               (soarmapc
-                #'(lambda (x) (remove-from-wm (list 'goal-context-info goal slot x)))
-                old-value))
-              (t (remove-from-wm (list 'goal-context-info goal slot old-value))))
-        (return (cond ((soarlistp new-value)
-                       (soarmapcar #'(lambda (x) (list 'goal-context-info goal slot x))
-                        new-value))
-                      (t (list (list 'goal-context-info goal slot new-value)))))))
-
-(defun remove-subgoal-objects (stack)
-  (cond (stack
-         (soarmapc #'remove-subgoal-objects (cdr stack))
-         (soarmapc #'remove-from-wm (get (caar stack) 'created))
-         (soarclearprops (caar stack)))))
-
-(defun restart-soar nil
-  (prog (pnames)
-        (setq pnames (append *pnames* nil))
-        (eval (cons 'excise pnames))
-        (soarmapc #'soarclearprops
-         (append *save-class-list* *class-list* *used-gensym-list*))
-        (i-g-v)))
-
-(defun save-production-trace (wme data-matched current-goal)
-  (cond (data-matched
-         (cond ((and *first-action* data-matched)
-                (setq *current-production-trace*
-                       (list (setq *trace-number* (1+ *trace-number*))
-                             data-matched
-                             *p-name*))))
-         (addprop current-goal 'production-trace (cons wme *current-production-trace*))
-         wme)))
-
-(defun showload (file)
-  (prog (in nextexpr)
-        (setq in (openfile file 'input))
-     l1 (setq nextexpr (read in))
-        (cond ((eq nextexpr 'stop) (return)))
-        (soarprinc "----> ")
-        (soarprinc nextexpr)
-        (terpri (trace-file))
-        (soarprinc (eval nextexpr))
-        (terpri (trace-file))
-        (go l1)))
-
-(defun ops-smatches (rule-list)
-  (soarmapc #'smatches2 rule-list)
-  (terpri (trace-file)))
-
-
-(defun smatches2 (p)
-  (cond ((atom p)
-         (terpri (trace-file))
-         (spprule p (smatches3 p (get p 'backpointers) 2 (ncons 1))))))
-
-(defun smatches3 (p nodes ce part)
-  (prog (saved-mems n smatch-flg temp-flg port)
-        (setq port (trace-file))
-        (cond ((null nodes)
-               (terpri (trace-file))
-               (cond ((not (soarassq p *conflict-set*)) (return nil)))
-               (soarprinc3 "** MATCHES FOR " (reverse part) " ** ")
-               (setq n 0)
-               (soarmapc
-                #'(lambda (ci)
-                    (cond ((eq (car ci) p) (swrite-elms (cdr ci)) (setq n (+ n 1)))))
-                *conflict-set*)
-               (terpri (trace-file))
-               (return (ncons n)))
-              (t (setq saved-mems (find-left-mem (car nodes)))
-                 (cond ((null saved-mems) (return nil)))
-                 (setq temp-flg (smatches3 p (cdr nodes) (1+ ce) (cons ce part)))
-                 (setq smatch-flg
-                        (cons (mem-length saved-mems)
-                              (cons (mem-length (find-right-mem (car nodes))) temp-flg)))
-                 (cond ((not temp-flg)
-                        (terpri (trace-file))
-                        (soarprinc3 "** MATCHES FOR " (reverse part) " ** ")
-                        (soarmapc #'swrite-elms saved-mems)
-                        (terpri (trace-file))
-                        (soarprinc3 "** MATCHES FOR " ce " ** ")
-                        (terpri (trace-file))
-                        (soarmapc
-                         #'(lambda (x)
-                             (cond ((soarlistp x) (soarmapc #'write-elms2 (reverse x)))))
-                         (find-right-mem (car nodes)))
-                        (terpri (trace-file))
-                        (return smatch-flg)))
-                 (return smatch-flg)))))
-
-(defun soarprinc (warning)
-  (princ warning (trace-file)))
-
-(defun soarprinc1 (x1 x2)
-  (princ x1 (trace-file))
-  (princ x2 (trace-file)))
-
-(defun soarprinc2 (x1 x2)
-  (princ x1 (trace-file))
-  (princ x2 (trace-file)))
-
-(defun soarprinc3 (x1 x2 x3)
-  (princ x1 (trace-file))
-  (princ x2 (trace-file))
-  (princ x3 (trace-file)))
-
-(defun soarprint (warning)
-  (prog2 nil (princ warning (trace-file)) (terpri (trace-file))))
-
-(defun soarprintc (warning)
-  (terpri (trace-file))
-  (princ warning (trace-file)))
-
-(defun soarwarn (warning warning2)
-  (prog (port)
-        (and (null *warning*)
-             (return warning2))
-        (setq port (trace-file))
-        (terpri port)
-        (princ "Warning: " port)
-        (and *p-name*
-             (princ *p-name*))
-        (princ ".." port)
-        (princ warning port)
-        (princ " " port)
-        (princ warning2 port)
-        (return warning2)))
-
-(defun ops-spop (object)
-  (setq *indent* 0)
-  (setq *print-spo-list* nil)
-  (cond ((or (null object)
-             (numberp (car object))))
-        ((not (numberp (soarlast object)))
-         (terpri (trace-file))
-         (spo1 (car object) *spo-default-depth* t)
-         (eval (cons 'spop (cdr object))))
-        (t (terpri (trace-file))
-           (spo1 (car object) (soarlast object) t)
-           (eval (cons 'spop (cdr object)))))
-  (setq *print-spo-list* nil))
-
-
-(defun spprule (name cond-nums)
-  (prog (matrix next lab cond-flg port)
-        (and (not (symbolp name))
-             (return nil))
-        (setq matrix (get name 'production))
-        (and (null matrix)
-             (return nil))
-        (setq port (trace-file))
-        (setq cond-flg nil)
-        (terpri port)
-        (soarprinc3 "(" 'p " ")
-        (soarprinc3 name " " (get name 'type))
-    top (and (atom matrix)
-             (go fin))
-        (setq next (car matrix))
-        (setq matrix (cdr matrix))
-        (setq lab nil)
-        (terpri port)
-        (cond ((and cond-nums
-                    (> (car cond-nums) 0))
-               (princ (car cond-nums) port)
-               (do-tabto 5 (trace-file))
-               (setq cond-nums (cddr cond-nums)))
-              ((eq next '-->) (princ "    " port) (setq cond-flg t))
-              (cond-flg (princ "    " port))
-              (t (princ ">>>>" port) (setq cond-flg t)))
-        (cond ((eq next '-)
-               (princ "- " port)
-               (setq next (car matrix))
-               (setq matrix (cdr matrix)))
-              ((neq next '-->) (princ "  " port)))
-        (ppline next)
-        (cond (lab (soarprinc3 " " lab '})))
-        (go top)
-    fin (soarprint ")")))
-
-(defun swrite-elms (wme-or-count)
-  (cond ((soarlistp wme-or-count)
-         (terpri (trace-file))
-         (soarmapc #'write-elms2 (reverse wme-or-count)))))
-
-(defun soargenpname (x)
-  (prog (sym-list sym)
-        (cond (*free-pname-list* (setq sym (pop *free-pname-list*)))
-              (t (setq sym (soargensymbol (soarnthchar x 1)))))
-        (soarputprop sym t 'gensymed)
-        (return sym)))
-
-(defun soargensym (x)
-  (prog (sym-list charx sym)
-        (setq charx (soarnthchar x 1))
-        (setq sym-list (soarassq charx *free-gensym-list*))
-        (cond ((null (cdr sym-list)) (setq sym (soargensymbol charx)))
-              (t (setq sym (cadr sym-list)) (rplacd sym-list (cddr sym-list))))
-        (soarputprop sym t 'gensymed)
-        (soarpush sym *used-gensym-list*)
-        (return sym)))
-
-(defun soargenvar (id)
-  (prog (first-char gen-number new-var)
-        (setq first-char (soarnthchar id 1))
-        (cond ((soarmemq first-char *used-char-list*)
-               (setq gen-number (get first-char 'var-count)))
-              (t (soarpush first-char *used-char-list*) (setq gen-number 1)))
-        (setq new-var (soarpack '< first-char gen-number '>))
-        (soarpush new-var *used-var-list*)
-        (soarputprop first-char (1+ gen-number) 'var-count)
-        (return new-var)))
-
-(defun ops-swatch (z)
-  (cond ((equal z '(0)) (setq *gtrace* nil) (setq *strace* nil) (setq *dtrace* nil) 0)
-        ((equal z '(1)) (setq *gtrace* t) (setq *strace* nil) (setq *dtrace* nil) 1)
-        ((equal z '(2)) (setq *gtrace* t) (setq *strace* t) (setq *dtrace* nil) 2)
-        ((equal z '(3)) (setq *gtrace* t) (setq *strace* t) (setq *dtrace* t) 3)
-        ((and (atom z)
-              (null *gtrace*))
-         0)
-        ((and (atom z)
-              (null *strace*))
-         1)
-        ((and (atom z)
-              (null *dtrace*))
-         2)
-        ((atom z) 3)
-        (t 'what?)))
-
-
-(defun t-in-list? (x)
-  (soarmemq 't (flatten x)))
-
-(defun ops-tabstop (z)
-  (prog (val)
-        (cond ((not *in-rhs*)
-               (soarwarn "TABSTOP can not be called at the top level" " ")
-               (return nil))
-              ((neq (length z) 1)
-               (soarwarn "Wrong number of arguments for Tabstop:" z)
-               (return nil))
-              ((not (variablep (car z)))
-               (soarwarn "Illegal argument for Tabstop:" (car z))
-               (return nil))
-              ((equalp (length z) 1)
-               (setq val (+ 3 (* (get-context-depth *context*) 3)))))
-        (make-var-bind (car z) val)))
-
-
-(defun test-connected-actions (actions)
-  (prog (changed-flag action save-action saved-actions found-variable)
-        (setq changed-flag t)
-        (setq saved-actions (cdr actions))
-     l1 (setq actions saved-actions)
-        (setq saved-actions nil)
-        (cond ((null actions) (return))
-              ((null changed-flag)
-               (soarwarn "Unconnected actions in production" (p-to-sp actions))
-               (return)))
-        (setq changed-flag nil)
-     l2 (cond ((null actions) (go l1)))
-        (setq action (pop actions))
-        (cond ((neq (car action) 'make) (go l2)))
-        (setq save-action action)
-        (setq found-variable nil)
-     l3 (cond ((and (null action)
-                    found-variable)
-               (soarpush save-action saved-actions)
-               (go l2))
-              ((null action) (go l2))
-              ((soarmemq (car action) *condition-vars*)
-               (setq *condition-vars*
-                      (append *condition-vars* (find-variables save-action)))
-               (setq changed-flag t)
-               (setq found-variable t)
-               (go l2))
-              ((variablep (car action)) (setq found-variable t)))
-        (pop action)
-        (go l3)))
-
-(defun test-preference-field (field subgoal)
-  (or (null field)
-      (eq field 'undecided)
-      (neq (get field 'in-id-field) subgoal)))
-
-(defun test-selected-result (choice result)
-  (or (eq choice result)
-      (eq choice (get result 'name))
-      (and (soarmemq choice (get result 'instance))
-           t)
-      (and (get result 'instance)
-           (soarmemq t
-            (flatten
-             (soarmapcar #'(lambda (x) (test-selected-result choice x))
-              (get result 'instance))))
-           t)))
-
-(defun test-subset (lista listb)
-  (cond ((null lista) t)
-        ((soarmemq (car lista) listb) (test-subset (cdr lista) listb))
-        (t nil)))
-
-(defun teqnilb (x y)
-  (or (eq x y)
-      (null x)))
-
-(defun trace-attribute (x)
-  (prog (class)
-        (cond ((soarassq (car x) *sp-classes*)
-               (soarpush (cons (cdr (soarassq (car x) *sp-classes*)) (cdr x))
-                *instance-attributes*))
-              (t (setq class (soarpack2 (car x) '-info))
-                 (soarpush (cons (car x) class) *sp-classes*)
-                 (soarpush class *save-class-list*)
-                 (soarputprop class (get 'state-info 'ppdat) 'ppdat)
-                 (soarpush (cons class (cdr x)) *instance-attributes*)))))
-
-(defun trace-attributes (x)
-  (soarmapc #'trace-attribute x))
-
-(defun trace-condition-action (wme flag)
-  (cond ((null *tracep-list*))
-        ((or (soarmember wme *tracep-list*)
-             (soarmemq (identifier wme) *tracep-list*)
-             (soarmemq (get (identifier wme) 'name) *tracep-list*))
-         (soarprintc *p-name*)
-         (cond ((eq flag 'action) (soarprinc ": -->")) (t (soarprinc ": matches ")))
-         (ppline (car (p-conds-to-sp (list (clean-up-clause wme 'action))))))))
-
-(defun trace-ids (item)
-  (print-id item))
-
-(defun trace-new-condition (action trace-flag depth negation)
-  (cond ((and trace-flag negation)
-         (do-tabto (* 3 depth) (trace-file))
-         (ppline (cons negation (car (p-conds-to-sp (list (clean-up-element action))))))
-         (soarprint " "))
-        (trace-flag
-         (do-tabto (* 3 depth) (trace-file))
-         (ppline (car (p-conds-to-sp (list (clean-up-element action)))))
-         (soarprint " "))))
-
-(defun trace-object (type id depth)
-  (cond ((or (and (not *gtrace*)
-                  (not *otrace*))
-             (not (trace-problem-space?))
-             (eq id 'undecided)))
-        ((and *otrace* id)
-         (cond ((and *3600-display* *gtrace*) (draw-current-object type id depth)))
-         (soarprintc *decide-count*)
-         (cond ((and *subgoal-tabs*
-                     (neq depth 0)
-                     (eq type 'goal))
-                (do-tabto (+ 2 (* depth 3)) (trace-file))
-                (princ '==> (trace-file)))
-               (*subgoal-tabs* (do-tabto (+ 5 (* depth 3)) (trace-file)))
-               (t (do-tabto 5 (trace-file))
-                  (soarprinc3 "(" depth ")")
-                  (do-tabto 11 (trace-file))))
-         (soarprinc2
-          (cond ((eq type 'goal) 'g)
-                ((eq type 'problem-space) 'p)
-                ((eq type 'state) 's)
-                ((eq type 'operator) 'o))
-          ": ")
-         (print-id id))))
-
-(defun trace-problem-space? nil
-  (not (soarmemq (get (get-current *context* 'problem-space) 'name)
-        *watch-free-problem-spaces*)))
-
-(defun ops-unpbreak (z)
-  (cond ((atom z) (setq *brkpts* nil) (setq *brknames* nil) nil)
-        (t (soarmapc #'unpbreak2 z) nil)))
-
-
-(defun unpbreak2 (rule)
-  (prog (type blist)
-        (cond ((or (not (symbolp rule))
-                   (soarlistp rule))
-               (soarwarn "Illegal argument:" rule))
-              ((soarmemq rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*)) rule)
-              ((soarmemq rule *brknames*) (setq *brknames* (rematm rule *brknames*)) rule)
-              (t nil))))
-
-(defun unptrace nil
-  (setq *tracep-list* nil))
-
-(defun untest (element)
-  (cond ((and element
-              (variablep (caddr element)))
-         (soarputprop (caddr element) (1- (get (caddr element) 'tested)) 'tested)
-         (untest (cdddr element)))
-        (element (untest (cdddr element)))))
-
-(defun variablize-negations (negations)
-  (prog (condition return-list new-condition id value)
-        (setq return-list nil)
-     l1 (cond ((null negations) (return return-list)))
-        (setq condition (pop negations))
-        (setq new-condition (list (pop condition)))
-     l2 (cond ((null condition)
-               (setq new-condition (nreverse new-condition))
-               (and (soarmember new-condition return-list)
-                    (go l1))
-               (soarpush new-condition return-list)
-               (go l1)))
-        (soarpush (pop condition) new-condition)
-        (soarpush (pop condition) new-condition)
-        (setq id (pop condition))
-        (setq value (cdr (soarassq id *learn-ids*)))
-        (cond (value
-               (soarputprop value
-                (1+ (or (get value 'tested)
-                        0))
-                'tested))
-              (t (setq value id)))
-        (soarpush value new-condition)
-        (go l2)))
-
-(defun write-trace (arg1 arg2 arg3)
-  (cond ((and *ptrace*
-              (trace-problem-space?))
-         (soarprintc *decide-count*)
-         (soarprinc3 '":" *cycle-count* arg1)
-         (soarprinc3 arg2 '" " arg3)
-         (soarprinc '" "))))
-
-(defun ops-write1 (z)
-  (prog (port max k x needspace)
-        (cond ((not *in-rhs*)
-               (soarwarn "Write1 cannot be called at the top level." " ")
-               (return nil)))
-        ($reset)
-        (eval-args z)
-        (setq k 1)
-        (setq max ($parametercount))
-        (cond ((< max 1) (soarwarn "Write1: nothing to print:" z) (return nil)))
-        (setq port (default-write-file))
-        (setq x ($parameter 1))
-        (cond ((and (symbolp x)
-                    ($ofile x))
-               (setq port ($ofile x))
-               (setq k 2)))
-        (setq needspace t)
-     la (and (> k max)
-             (return nil))
-        (setq x ($parameter k))
-        (cond ((equal x 'crlf) (setq needspace nil) (terpri port))
-              ((equal x 'rjust)
-               (setq k (+ 2 k))
-               (do-rjust ($parameter (1- k)) ($parameter k) port))
-              ((equal x 'tabto)
-               (setq needspace nil)
-               (setq k (1+ k))
-               (do-tabto ($parameter k) port))
-              (t (and needspace
-                      (princ " " port))
-                 (setq needspace t)
-                 (princ x port)))
-        (setq k (1+ k))
-        (go la)))
-
-
-(defun ops-write2 (z)
-  (prog (port max k x)
-        (cond ((not *in-rhs*)
-               (soarwarn "Write2 cannot be called at the top level" " ")
-               (return nil)))
-        ($reset)
-        (eval-args z)
-        (setq k 1)
-        (setq max ($parametercount))
-        (cond ((< max 1) (soarwarn "Write2: nothing to print" " ") (return nil)))
-        (setq port (default-write-file))
-        (setq x ($parameter 1))
-        (cond ((and (symbolp x)
-                    ($ofile x))
-               (setq port ($ofile x))
-               (setq k 2)))
-     la (and (> k max)
-             (return nil))
-        (setq x ($parameter k))
-        (cond ((equal x 'crlf) (terpri port))
-              ((equal x 'rjust)
-               (setq k (+ 2 k))
-               (do-rjust ($parameter (1- k)) ($parameter k) port))
-              ((equal x 'tabto) (setq k (1+ k)) (do-tabto ($parameter k) port))
-              (t (princ x port)))
-        (setq k (1+ k))
-        (go la)))
-
-
-(defun compose-p-conds (cl)
-  (soar-do
-   ((avlist) (c) (cl1 cl (skip-whole-cond cl1)) (type (car (get-pos-cond cl)))
-    (id-var (get-term (cdddr (get-pos-cond cl)))))
-   ((null cl1) (cons (conv-type-to-sp type) (append id-var (build-sp-cond avlist nil))))
-   (setq c (get-pos-cond cl1)) (cond ((eq (car c) 'make) (setq c (cdr c))))
-   (soar-do ((c1 (cddr c) (cdr c1)) (attr '*undefined**) (val '*undefined**) (x))
-    ((null c1)
-     (cond ((not (eq attr '*undefined**))
-            (setq x (soarassoc attr avlist))
-            (cond ((not (eq val '*undefined**))
-                   (cond (x (rplacd x (append val (cdr x))))
-                         (t (soarpush (cons attr val) avlist))))
-                  (t (soarpush (list attr) avlist))))
-           ((not (eq val '*undefined**)) (soarpush val extravals))))
-    (setq label (pop c1))
-    (cond ((eq label 'attribute)
-           (setq attr (cons '^ (get-term c1)))
-           (and (eq (car cl1) '-)
-                (soarpush '- attr)))
-          ((eq label 'value) (setq val (nreverse (get-term c1)))))
-    (pop-term c1))))
-
-(defun conv-to-attr-nums (avlist warnflag)
-  (prog (next a)
-        (setq *filters* nil)
-        (setq next 1)
-      l (and (atom avlist)
-             (return t))
-        (setq a (car avlist))
-        (setq avlist (cdr avlist))
-        (cond ((eq a '^)
-               (setq next (car avlist))
-               (setq avlist (cdr avlist))
-               (setq next ($litbind next))
-               (cond ((or (not (numberp next))
-                          (> next *size-result-array*)
-                          (> 1 next))
-                      (and warnflag
-                           (soarwarn "Illegal index after ^" next))
-                      (return nil))))
-              ((variablep a) (soarwarn "(S)PPWM does not take variables:" a) (return nil))
-              (t (setq *filters* (cons next (cons a *filters*))) (setq next (1+ next))))
-        (go l)))
-
-(defun conv-type-to-sp (type)
-  (soar-do ((cl *sp-classes* (cdr cl))) ((null cl) type)
-   (cond ((eq (cdar cl) type) (return (caar cl))))))
-
-(defun get-ids (infolist oldids)
-  (prog (newids pair)
-        (soarmapc
-         #'(lambda (x)
-             (setq pair (cons (cadddr x) (car x)))
-             (cond ((and (or (not oldids)
-                             (soarmember pair oldids))
-                         (not (soarmember pair newids)))
-                    (soarpush pair newids))))
-         infolist)
-        (return newids)))
-
-(defun get-pos-cond (cl)
-  (cond ((eq (car cl) '-) (cadr cl)) (t (car cl))))
-
-(defun get-similar-conds (cond cl)
-  (prog (rest result)
-        (setq rest (cons nil cl))
-        (soar-do
-         ((type (car cond)) (id-var (get-term (cdddr cond))) (negflag) (cl1 rest) (c))
-         ((or (null cl)
-              (eq (car cl) '-->)))
-         (setq c (pop cl))
-         (cond ((eq c '-) (setq c (pop cl)) (setq negflag t)) (t (setq negflag nil)))
-         (cond ((eq (car c) 'make) (setq c (cdr c))))
-         (cond ((and (equal id-var (get-term (cdddr c)))
-                     (eq type (car c)))
-                (cond (negflag (soarpush '- result) (rplacd cl1 (cddr cl1))))
-                (soarpush c result)
-                (rplacd cl1 (cddr cl1)))
-               (t (cond (negflag (setq cl1 (cdr cl1)))) (setq cl1 (cdr cl1)))))
-        (return (cons (nreverse result) (cdr rest)))))
-
-(defun get-term (c)
-  (list-head c (skip-term c)))
-
-(defun indent nil
-  (soar-do ((i *indent* (- i 1))) ((= i 0)) (princ " " (trace-file))))
-
-(defun list-head (whole tail)
-  (soar-do ((result)) ((null whole) (nreverse result))
-   (cond ((eq whole tail) (return (nreverse result)))
-         (t (setq result (cons (car whole) result)) (setq whole (cdr whole))))))
-
-(defun p-conds-to-sp (cl)
-  (prog (c pref cl1 result temp negs type)
-        (setq cl1 (copy cl))
-     l1 (setq c (get-pos-cond cl1))
-        (cond ((or (null c)
-                   (eq c '-->))
-               (return (nreverse result)))
-              ((eq (car c) 'make) (setq c (cdr c))))
-        (setq type (car c))
-        (cond ((soarmemq type *ops5-actions*) (soarpush c result) (setq cl1 (cdr cl1)))
-              ((or (eq type (conv-type-to-sp type))
-                   (not (eq 'identifier (caddr c))))
-               (cond ((equal (car cl1) '-) (soarpush '- result)))
-               (cond ((and (eq (caddr c) 'object)
-                           (eq type 'preference))
-                      (soarpush (cons 'preference (cdddr c)) result))
-                     (t (soarpush c result)))
-               (setq cl1 (skip-whole-cond cl1)))
-              (t (setq temp (get-similar-conds c cl1))
-                 (setq cl1 (cdr temp))
-                 (soarpush (compose-p-conds (car temp)) result)))
-        (go l1)))
-
-(defun p-to-sp (rule)
-  (prog (result)
-        (setq result (p-conds-to-sp rule))
-        (cond ((soarmemq '--> rule)
-               (setq result
-                      (append result
-                              (cons '--> (p-conds-to-sp (cdr (soarmemq '--> rule))))))))
-        (return result)))
-
-(defun pp-class-ids (ids)
-  (soarmapc
-   #'(lambda (x)
-       (soarmapc #'(lambda (y) (ppline y) (terpri (trace-file)))
-        (p-conds-to-sp (sppwm1 (list (cdr x) '^ 'identifier (car x))))))
-   ids))
-
-(defun ppelm1 (elm)
-  (prog (ppdat result val att vlist)
-        (setq ppdat (get (car elm) 'ppdat))
-        (setq result (list (car elm)))
-        (setq vlist (cdr elm))
-        (soar-do ((curpos 2 (+ 1 curpos))) ((atom vlist)) (setq val (car vlist))
-         (setq vlist (cdr vlist)) (setq att (cdr (soarassq curpos ppdat)))
-         (cond ((or (not (eq (car elm) 'preference))
-                    (not (null val)))
-                (soarpush '^ result)
-                (soarpush att result)
-                (soarpush val result))))
-        (return (nreverse result))))
-
-(defun skip-term (c)
-  (car (classify-term c)))
-
-(defun skip-whole-cond (cl)
-  (cond ((eq (car cl) '-) (cddr cl)) (t (cdr cl))))
-
-(defun ops-sp (xs)
-  (setq *xs* xs)
-  (soarcatch '!error! (eval (reorder-p-conds (sp-to-p *xs*))))
-  nil)
-
-
-(defun sp-form-expand (pname x in-actions follows-negation)
-  (prog (nf new-class)
-        (cond ((and (not (atom x))
-                    (eq (car x) 'make))
-               (setq x (cdr x))))
-        (setq nf
-               (cond ((atom x) (list x))
-                     ((soarassq (class x) *sp-classes*)
-                      (setq new-class (cdr (soarassq (class x) *sp-classes*)))
-                      (cond ((not (soarmemq new-class *save-class-list*))
-                             (soarpush new-class *save-class-list*)
-                             (soarputprop new-class (get 'state-info 'ppdat) 'ppdat)))
-                      (sp-info-expand pname x in-actions))
-                     ((and (cdr x)
-                           (not (eq (class x) 'preference))
-                           (not (eq (cadr x) '^))
-                           (or (not in-actions)
-                               (not (soarmemq (class x) *ops5-actions*))))
-                      (setq new-class (soarpack2 (class x) '-info))
-                      (soarpush (cons (class x) new-class) *sp-classes*)
-                      (soarpush new-class *save-class-list*)
-                      (soarputprop new-class (get 'state-info 'ppdat) 'ppdat)
-                      (sp-info-expand pname x in-actions))
-                     ((and in-actions
-                           (not (soarmemq (car x) *ops5-actions*)))
-                      (cond ((and (cdr x)
-                                  (not (eq (cadr x) '^))
-                                  (not (eq (cadr x) '-)))
-                             (list (cons 'make
-                                         (cons (car x)
-                                               (cons '^
-                                                     (cons
-                                                      (cond
-                                                       ((eq (car x) 'preference) 'object)
-                                                       (t 'identifier))
-                                                      (cdr x)))))))
-                            (t (list (cons 'make x)))))
-                     ((and in-actions
-                           (soarmemq (car x) *ops5-actions*))
-                      (list x))
-                     ((and (cdr x)
-                           (not (eq (cadr x) '^))
-                           (not (eq (cadr x) '-)))
-                      (list (cons (car x)
-                                  (cons '^
-                                        (cons (cond ((eq (car x) 'preference) 'object)
-                                                    (t 'identifier))
-                                              (cdr x))))))
-                     (t (list x))))
-        (cond ((and follows-negation
-                    (> (length nf) 1))
-               (%error "Attempt to negate a compound object" pname))
-              (t (return nf)))))
-
-(defun sp-info-expand (pname form in-actions)
-  (prog (avlist newform end-atom type id clist pand-id temp-form negated no-value)
-        (setq pand-id nil)
-        (setq clist nil)
-        (setq type (cdr (soarassq (car form) *sp-classes*)))
-        (cond ((variablep (cadr form)) (setq id (cadr form)) (setq avlist (cddr form)))
-              ((equal (cadr form) '^)
-               (setq id (soarpack '< 'x (soargensym (car form)) '>))
-               (setq avlist (cdr form)))
-              ((equal (cadr form) '{)
-               (setq pand-id t)
-               (setq avlist (cddr form))
-               (setq id (ncons '{))
-               (soarwhile
-                (and avlist
-                     (not (equal (car avlist) '})))
-                (soarpush (car avlist) id) (pop avlist))
-               (cond ((null avlist) (%error "Didn't find terminating }" form)))
-               (setq id (dreverse (cons '} id)))
-               (setq avlist (cdr avlist)))
-              (t (setq id (cadr form)) (setq avlist (cddr form))))
-   loop (cond ((not avlist) (return (reverse clist))))
-        (setq negated nil)
-        (cond ((equal (car avlist) '-) (pop avlist) (setq negated t)))
-        (cond ((not (equal (car avlist) '^))
-               (%error "Didn't find a ^ when expected" avlist)))
-        (pop avlist)
-        (setq end-atom
-               (cond ((eq (car avlist) '<<) '>>) ((eq (car avlist) '{) '}) (t nil)))
-        (cond (pand-id
-               (setq newform
-                      (append (list type '^ 'identifier)
-                              (append id (list '^ 'attribute (pop avlist))))))
-              (t (setq newform (list type '^ 'identifier id '^ 'attribute (pop avlist)))))
-        (cond (end-atom
-               (soarwhile
-                (and avlist
-                     (not (eq (car avlist) end-atom)))
-                (setq newform (append newform (list (pop avlist)))))
-               (cond ((null avlist) (%error "Didn't find terminator" end-atom)))
-               (setq newform (append newform (list (pop avlist))))))
-        (setq no-value t)
-        (cond ((and avlist
-                    (not (eq (car avlist) '^))
-                    (not (eq (car avlist) '-))
-                    (or (not (soarlistp (car avlist)))
-                        (not (eq (caar avlist) '^))))
-               (setq newform (append newform (list '^ 'value)))
-               (setq no-value nil)))
-        (setq temp-form newform)
-        (soarwhile
-         (and avlist
-              (not (eq (car avlist) '^))
-              (not (eq (car avlist) '-))
-              (or (not (soarlistp (car avlist)))
-                  (not (eq (caar avlist) '^))))
-         (setq newform temp-form)
-         (cond ((predicatep (car avlist))
-                (setq newform (append newform (list (pop avlist))))))
-         (setq end-atom
-                (cond ((eq (car avlist) '<<) '>>) ((eq (car avlist) '{) '}) (t nil)))
-         (setq newform (append newform (list (pop avlist))))
-         (cond (end-atom
-                (soarwhile
-                 (and avlist
-                      (not (eq (car avlist) end-atom)))
-                 (setq newform (append newform (list (pop avlist)))))
-                (cond ((null avlist) (%error "Didn't find terminator" end-atom)))
-                (setq newform (append newform (list (pop avlist))))))
-         (cond ((and avlist
-                     (soarlistp (car avlist)))
-                (setq newform (append newform (pop avlist)))))
-         (cond (in-actions (soarpush 'make newform))) (cond (negated (soarpush '- clist)))
-         (soarpush newform clist))
-        (cond (no-value
-               (cond ((and avlist
-                           (soarlistp (car avlist)))
-                      (setq newform (append newform (pop avlist)))))
-               (cond (in-actions (soarpush 'make newform)))
-               (cond (negated (soarpush '- clist)))
-               (soarpush newform clist)))
-        (go loop)))
-
-(defun sp-to-p (xs)
-  (prog (in-actions follows-negation forms pname)
-        (setq in-actions nil)
-        (setq follows-negation nil)
-        (setq pname (car xs))
-        (return (cons 'p
-                      (soarmapconc
-                       #'(lambda (x)
-                           (cond ((equal x '-->) (setq in-actions t)))
-                           (setq forms
-                          (sp-form-expand pname x in-actions follows-negation))
-                           (setq follows-negation (eq x '-))
-                           forms)
-                       xs)))))
-
-(defun ops-spm (z)
-  (setq *indent* 0)
-  (soarmapc #'(lambda (x) (pprule x 'sp)) z)
-  nil)
-
-
-(defun spm-to-make (form)
-  (soarmapc #'eval (sp-info-expand nil form t))
-  nil)
-
-(defun ops-spo (object)
-  (setq *indent* 0)
-  (cond ((or (null object)
-             (numberp (car object))))
-        ((not (numberp (soarlast object)))
-         (terpri (trace-file))
-         (spo1 (car object) *spo-default-depth* nil)
-         (eval (cons 'spo (cdr object))))
-        (t (terpri (trace-file))
-           (spo1 (car object) (soarlast object) nil)
-           (eval (cons 'spo (cdr object)))))
-  (setq *print-spo-list* nil))
-
-
-(defun spo1 (object depth prefflag)
-  (prog (out class out2 out1)
-        (cond ((soarmemq object *print-spo-list*) (return))
-              (t (soarpush object *print-spo-list*)))
-        (setq out (p-conds-to-sp (sppwm1 (append '(^ identifier) (list object)))))
-        (setq out1 nil)
-        (soarmapc
-         #'(lambda (x)
-             (cond ((eq prefflag (eq (car x) 'preference))
-                    (ppline x)
-                    (soarpush x out1)
-                    (terpri (trace-file)))))
-         out)
-        (cond ((<= depth 1) (return)))
-        (setq out out1)
-        (setq *indent* (+ *indent* 3))
-        (soar-do ((out2 out (cdr out2))) ((null out2))
-         (soar-do ((out1 (cdar out2) (cdr out1))) ((null out1))
-          (cond ((get (cadr out1) 'in-id-field) (spo1 (cadr out1) (- depth 1) prefflag)))))
-        (setq *indent* (- *indent* 3))))
-
-(defun ops-sppwm (avlist)
-  (prog (noclassflag condlist cond1 ids avinfos)
-        (soarterpri)
-        (setq *indent* 0)
-        (cond ((null avlist) (go l2))
-              ((not (soarassoc (car avlist) *sp-classes*))
-               (setq avlist (cons 'state avlist))
-               (setq noclassflag t)))
-        (cond ((null (cdr avlist))
-               (setq avinfos (list (list (cdr (soarassoc (car avlist) *sp-classes*))))))
-              ((null (cddr avlist))
-               (setq avinfos
-                      (list (list (cdr (soarassoc (car avlist) *sp-classes*))
-                                  '^
-                                  'identifier
-                                  (cadr avlist)))))
-              (t (soarcatch '!error! (setq avinfos (sp-form-expand nil avlist nil nil)))))
-        (cond ((variablep (cadddr (car avinfos)))
-               (soarmapc #'(lambda (x) (rplacd x (cdr (cdddr x)))) avinfos)))
-        (cond (noclassflag
-               (setq avinfos (soarmapcar #'cdr avinfos))
-               (setq avlist (cdr avlist))))
-        (setq ids (get-ids (sppwm1 (car avinfos)) nil))
-     l1 (setq avinfos (cdr avinfos))
-        (cond ((null avinfos) (go l2)))
-        (setq ids (get-ids (sppwm1 (car avinfos)) ids))
-        (cond ((null ids) (go l3)))
-        (go l1)
-     l2 (cond (avlist (setq ids (append ids (get-ids (sppwm1 avlist) nil)))))
-        (pp-class-ids ids)
-     l3 ))
-
-
-(defun sppwm1 (avlist)
-  (cond ((not (conv-to-attr-nums avlist nil)) nil)
-        (t (mapwm #'sppwm2) (prog2 nil *wm* (setq *wm* nil)))))
-
-(defun sppwm2 (elm-tag)
-  (cond ((filter (car elm-tag)) (setq *wm* (cons (ppelm1 (car elm-tag)) *wm*)))))
-
-(defun ops-spr (arg)
-  (cond ((get (car arg) 'in-id-field) (eval (cons 'spo arg)))
-        ((soarmemq (car arg) *pnames*) (eval (cons 'spm arg)))
-        ((numberp (car arg)) (eval (cons 'swm arg)))
-        ((null (car arg)) (pgs))
-        (t (eval (cons 'sppwm arg)))))
-
-
-(defun ops-swm (a)
-  (pp-class-ids (soarmapcar #'(lambda (x) (cons (cadr x) (car x))) (get-wm a))))
-
-(defun $varbind (x)
-  (prog (r)
-        (and (not *in-rhs*) (return x))
-        (setq r (soarassq x *variable-memory*))
-        (cond (r (return (cdr r)))
-              ((variablep x)
-               (setq r (soargensym (soarnthchar x 2)))
-               (make-var-bind x r)
-               (return r))
-              (t (return x)))))
-
-(defun &bus (outs)
-  (prog (dp)
-        (setq *alpha-flag-part* *flag-part*)
-        (setq *alpha-data-part* *data-part*)
-        (setq dp (car *data-part*))
-        (setq *c1* (car dp))
-        (setq dp (cdr dp))
-        (setq *c2* (car dp))
-        (setq dp (cdr dp))
-        (setq *c3* (car dp))
-        (setq dp (cdr dp))
-        (setq *c4* (car dp))
-        (setq dp (cdr dp))
-        (setq *c5* (car dp))
-        (setq dp (cdr dp))
-        (setq *c6* (car dp))
-        (setq dp (cdr dp))
-        (setq *c7* (car dp))
-        (setq dp (cdr dp))
-        (setq *c8* (car dp))
-        (setq dp (cdr dp))
-        (setq *c9* (car dp))
-        (setq dp (cdr dp))
-        (setq *c10* (car dp))
-        (setq dp (cdr dp))
-        (setq *c11* (car dp))
-        (setq dp (cdr dp))
-        (setq *c12* (car dp))
-        (setq dp (cdr dp))
-        (setq *c13* (car dp))
-        (setq dp (cdr dp))
-        (setq *c14* (car dp))
-        (setq dp (cdr dp))
-        (setq *c15* (car dp))
-        (setq dp (cdr dp))
-        (setq *c16* (car dp))
-        (eval-nodelist outs)))
-
-(defun &priv (outs name)
-  (prog nil
-        (eval-nodelist outs)))
-
-(defun accum-stats nil
-  (setq *prod-count* (+ *prod-count* 1))
-  (setq *total-token* (+ *total-token* *current-token*))
-  (cond ((> *current-token* *max-token*) (setq *max-token* *current-token*)))
-  (setq *total-wm* (+ *total-wm* *current-wm*))
-  (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))))
-
-(defun add-to-wm (wme)
-  (prog (class part timetag port match-time)
-        (setq port (trace-file))
-        (setq wme (eliminate-trailing-nil wme))
-        (setq class (class wme))
-        (setq part (get class 'wmpart*))
-        (cond ((soarassoc wme part)
-               (and *chunk-all-paths*
-                    (mark-in-id wme))
-               (return nil))
-              ((mark-in-id wme) (return nil))
-              ((soarmember wme *brkrun*) (setq *break-flag* t)))
-        (trace-condition-action wme 'action)
-        (setq *critical* t)
-        (setq *action-count* (1+ *action-count*))
-        (setq *current-wm* (1+ *current-wm*))
-        (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*)))
-        (or (soarmemq class *wmpart-list*)
-            (soarpush class *wmpart-list*))
-        (setq timetag *action-count*)
-        (soarputprop class (cons (cons wme timetag) part) 'wmpart*)
-        (match 'new wme)
-        (setq *critical* nil)
-        (cond ((or (not *in-rhs*)
-                   (not (trace-problem-space?))))
-              ((and (not *wtrace*)
-                    *ptrace*
-                    *ttrace*)
-               (time-tag-print (list wme) port))
-              (*wtrace* (soarprintc "=>WM: ") (ppelm wme port)))))
-
-(defun best-of (set)
-  (prog (cs entry best-list)
-        (setq cs set)
-        (setq best-list nil)
-     l1 (setq entry (car cs))
-        (setq cs (cdr cs))
-        (cond ((null entry) (return best-list))
-              ((or (eq *phase* (get (car entry) 'type))
-                   (and (eq *phase* 'elaborate)
-                        (eq (get (car entry) 'type) 'elaborate-once)))
-               (soarpush entry best-list)
-               (and (eq *phase* 'elaborate)
-                    (remove-cs entry))))
-        (go l1)))
-
-(defun ops-bind (z)
-  (prog (val)
-        (cond ((not *in-rhs*)
-               (soarwarn "Cannot be called at top level" 'bind)
-               (return nil))
-              ((< (length z) 1)
-               (soarwarn "Bind: Wrong number of arguments to" z)
-               (return nil))
-              ((not (symbolp (car z)))
-               (soarwarn "Bind: illegal argument" (car z))
-               (return nil))
-              ((equalp (length z) 1) (setq val (soargensym 's)))
-              (t ($reset) (eval-args (cdr z)) (setq val ($parameter 1))))
-        (make-var-bind (car z) val)))
-
-
-(defun check-action (x)
-  (prog (a)
-        (cond ((atom x) (soarwarn "Atomic Action" x) (return nil)))
-        (setq a (setq *action-type* (car x)))
-        (cond ((eq a 'bind) (check-bind x))
-              ((eq a 'cbind) (check-cbind x))
-              ((eq a 'call2) (return nil))
-              ((eq a 'tabstop) (check-bind x))
-              ((eq a 'decide) (check-decide))
-              ((eq a 'make) (check-make x))
-              ((eq a 'modify) (check-modify x))
-              ((eq a 'remove-ops) (check-remove-ops x))
-              ((eq a 'write) (check-write x))
-              ((eq a 'write1) (check-write x))
-              ((eq a 'write2) (check-write x))
-              ((eq a 'call1) (check-call1 x))
-              ((eq a 'halt) (check-halt x))
-              ((eq a 'openfile) (check-openfile x))
-              ((eq a 'closefile) (check-closefile x))
-              ((eq a 'default) (check-default x))
-              ((eq a 'build) (check-build x))
-              (t (soarwarn "Illegal Action" x)))))
-
-(defun check-make (z)
-  (or (soarmemq *p-type* '(elaborate-once elaborate))
-      (soarwarn "Illegal make in production type" *p-type*))
-  (and (null (cdr z))
-       (soarwarn "Missing arguments in Make" " "))
-  (check-change& (cdr z)))
-
-(defun check-modify (z)
-  (soarwarn "Illegal modify in Soar production" *p-type*)
-  (and (null (cdr z))
-       (soarwarn "Missing arguments in Modify" " "))
-  (check-rhs-ce-var (cadr z))
-  (and (null (cddr z))
-       (soarwarn "No changes to make in Modify" " "))
-  (check-change& (cddr z)))
-
-(defun check-rhs-value (x)
-  (cond ((soarlistp x) (check-rhs-function x))))
-
-(defun cmp-ce nil
-  (prog (z)
-        (new-subnum 0)
-        (setq *cur-vars* nil)
-        (setq z (lex))
-        (and (atom z)
-             (%error "Atomic conditions are not allowed" z))
-        (setq *preference-found* (eq (car z) 'preference))
-        (prepare-sublex z)
-     la (and (end-of-ce)
-             (return nil))
-        (incr-subnum)
-        (cmp-element)
-        (setq *context-field-found* nil)
-        (go la)))
-
-(defun cmp-tab nil
-  (prog (r)
-        (sublex)
-        (setq r (sublex))
-        (setq *context-field-found*
-               (and *preference-found*
-                    (soarmemq r '(goal problem-space state operator))))
-        (setq r ($litbind r))
-        (new-subnum r)))
-
-(defun cmp-var (test)
-  (prog (old name)
-        (setq name (sublex))
-        (setq old (soarassq name *cur-vars*))
-        (cond ((and old
-                    (eq (cadr old) 'eq))
-               (cmp-old-eq-var test old))
-              ((and old
-                    (eq test 'eq))
-               (cmp-new-eq-var name old))
-              ((and (eq test 'eq)
-                    *context-field-found*)
-               (cmp-new-var name 'eqnil))
-              (t (cmp-new-var name test)))))
-
-(defun cmp-p (name type matrix)
-  (prog (m bakptrs root)
-        (cond ((soarlistp name) (%error "Illegal production name" name))
-              ((equal (get name 'production) matrix) (return nil)))
-        (cond ((not (soarmemq type '(elaborate elaborate-once decide)))
-               (%error "Illegal production type" type)))
-        (and *print-pname*
-             (princ name (trace-file)))
-        (prepare-lex matrix)
-        (cond ((excise-p name) (princ (list 'excised name) (trace-file))))
-        (setq bakptrs nil)
-        (setq *last-node* *first-node*)
-        (and (> *current-wm* 0)
-             (make-new-root name))
-        (setq root (setq *new-root* *last-node*))
-        (setq *pcount* (1+ *pcount*))
-        (setq *feature-count* 0)
-        (setq *ce-count* 0)
-        (setq *vars* nil)
-        (setq *ce-vars* nil)
-        (setq *rhs-bound-vars* nil)
-        (setq *rhs-bound-ce-vars* nil)
-        (setq *last-branch* nil)
-        (setq m (rest-of-p))
-     l1 (and (end-of-p)
-             (%error "No '-->' in production" m))
-        (setq *last-node* root)
-        (cmp-prin)
-        (setq bakptrs (cons *last-branch* bakptrs))
-        (or (eq '--> (peek-lex))
-            (go l1))
-        (lex)
-        (cond ((not (soarmemq name *pnames*)) (setq *pnames* (cons name *pnames*))))
-        (check-rhs (rest-of-p))
-        (link-new-node
-         (list '&p
-               *feature-count*
-               name
-               (encode-dope)
-               (encode-ce-dope)
-               (cons 'progn (rest-of-p))))
-        (soarputprop name type 'type)
-        (soarputprop name (cdr (nreverse bakptrs)) 'backpointers)
-        (soarputprop name matrix 'production)
-        (soarputprop name (compute-negation-index matrix) 'negation-index)
-        (soarputprop name *last-node* 'topnode)
-        (cond ((> *current-wm* 0) (mapwm #'match-update)))
-        (return nil)))
-
-(defun cmp-prin nil
-  (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
-        ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
-        (t (cmp-posce) (cmp-and))))
-
-(defun compile-production (name type matrix)
-  (setq *p-type* type)
-  (setq *matrix* matrix)
-  (setq *p-name* name)
-  (soarcatch '!error! (cmp-p *p-name* *p-type* *matrix*))
-  (setq *p-name* nil))
-
-(defun conflict-resolution nil
-  (prog (best len)
-        (setq len (length *conflict-set*))
-        (cond ((> len *max-cs*) (setq *max-cs* len)))
-        (setq *total-cs* (+ *total-cs* len))
-        (cond (*conflict-set*
-               (setq best (best-of *conflict-set*))
-               (cond ((neq *phase* 'decide) (soarmapc #'remove-cs best)))
-               (return best))
-              (t (return nil)))))
-
-(defun conflict-set nil
-  (prog (cnts cs p z phase-type)
-        (setq cnts nil)
-        (setq cs *conflict-set*)
-        (setq phase-type 'decide)
-     l1 (and (atom cs)
-             (go l2))
-        (setq p (caar cs))
-        (and (neq (get p 'type) 'decide)
-             (setq phase-type 'elaborate))
-        (setq cs (cdr cs))
-        (setq z (soarassq p cnts))
-        (cond ((null z) (setq cnts (cons (cons p 1) cnts))) (t (rplacd z (1+ (cdr z)))))
-        (go l1)
-     l2 (cond ((atom cnts) (terpri (trace-file)) (return (list 'phase phase-type))))
-        (cond ((and (eq phase-type 'elaborate)
-                    (eq (get (caar cnts) 'type) 'decide))
-               (setq cnts (cdr cnts))
-               (go l2)))
-        (terpri (trace-file))
-        (soarprinc3 (caar cnts) " " (get (caar cnts) 'type))
-        (cond ((> (cdar cnts) 1) (soarprinc3 "	(" (cdar cnts) " OCCURRENCES)")))
-        (setq cnts (cdr cnts))
-        (go l2)))
-
-(defun ops-crlf (z)
-  (cond (z (soarwarn "CRLF: Does not take arguments" z)) (t ($value 'crlf))))
-
-
-(defun do-continue (wmi)
-  (cond (*critical* (soarprintc "WARNING: Network may be inconsistent")))
-  (process-changes wmi nil)
-  (main))
-
-(defun eval-rhs (pname data)
-  (prog (node port)
-        (cond ((and (trace-problem-space?)
-                    (or *ptrace*
-                        (soarmemq pname *tracep-list*)))
-               (setq port (trace-file))
-               (soarprintc (1+ *decide-count*))
-               (soarprinc3 ":" *cycle-count* " ")
-               (soarprinc pname)
-               (and *ptrace*
-                    *ttrace*
-                    (time-tag-print data port))))
-        (setq *data-matched* data)
-        (setq *p-name* pname)
-        (setq *last* nil)
-        (setq node (get pname 'topnode))
-        (init-var-mem (var-part node))
-        (init-ce-var-mem (ce-var-part node))
-        (setq *in-rhs* t)
-        (setq *current-goal* (find-max-goal-depth *data-matched*))
-        (soarmapc #'condition-trace *data-matched*)
-        (cond ((null *never-learn*)
-               (setq *data-matched*
-                      (append (add-negations *current-goal* (reverse *data-matched*))
-                              *data-matched*))))
-        (eval (rhs-part node))
-        (setq *in-rhs* nil)))
-
-(defun excise-p (name)
-  (prog nil
-        (cond ((and (symbolp name)
-                    (get name 'topnode))
-               (princ "#" (trace-file))
-               (setq *pcount* (1- *pcount*))
-               (remove-from-conflict-set name)
-               (kill-node (get name 'topnode))
-               (remprop name 'production)
-               (remprop name 'backpointers)
-               (remprop name 'topnode)
-               (remprop name 'type)
-               (remprop name 'negation-index)
-               (setq *chunks* (dremove name *chunks*))
-               (setq *pnames* (dremove name *pnames*))
-               (and (get name 'gensymed)
-                    (setq *free-pname-list* (soarsort (cons name *free-pname-list*))))
-               (return t))
-              (t (return nil)))))
-
-(defun finish-literalize nil
-  (cond ((not (null *class-list*))
-         (soarmapc #'note-user-assigns *class-list*)
-         (soarmapc #'assign-scalars *class-list*)
-         (soarmapc #'assign-vectors *class-list*)
-         (soarmapc #'put-ppdat *class-list*)
-         (soarmapc #'erase-literal-info *class-list*)
-         (setq *value-index* (1- (literal-binding-of 'value)))
-         (setq *attribute-index* (1- (literal-binding-of 'attribute)))
-         (setq *id-index* (1- (literal-binding-of 'identifier)))
-         (setq *goal-index* (1- (literal-binding-of 'goal)))
-         (setq *problem-space-index* (1- (literal-binding-of 'problem-space)))
-         (setq *state-index* (1- (literal-binding-of 'state)))
-         (setq *operator-index* (1- (literal-binding-of 'operator)))
-         (setq *slot-index* (1- (literal-binding-of 'role)))
-         (setq *big-info-index* (max *id-index* *attribute-index* *value-index*))
-         (setq *big-index*
-                (max *id-index*
-                     *goal-index*
-                     *problem-space-index*
-                     *state-index*
-                     *operator-index*
-                     *value-index*
-                     *slot-index*))
-         (setq *save-class-list* *class-list*)
-         (setq *class-list* nil)
-         (setq *buckets* nil))))
-
-(defun i-g-v nil
-  (prog (x)
-        (setq *save-class-list* nil)
-        (setq *class-list* nil)
-        (soarsyntax)
-        (soarputprop 'identifier 2 'ops-bind)
-        (soarputprop 'object 2 'ops-bind)
-        (soarputprop 'attribute 3 'ops-bind)
-        (soarputprop 'value 4 'ops-bind)
-        (setq *sp-classes*
-               '((state . state-info) (object . info) (problem-space . space-info)
-                 (space . space-info) (operator . op-info) (desired . desired-info)
-                 (gc . goal-context-info) (goal . goal-context-info)
-                 (context . goal-context-info) (goal-context . goal-context-info)
-                 (evaluation . eval-info)))
-        (setq *ops5-actions*
-               '(openfile closefile default write write1 write2 call1 halt decide bind
-                 call2 cbind obind build tabto tabstop))
-        (setq *impasse-subset-not-equal* nil)
-        (setq *brkpts* nil)
-        (setq *brkrun* nil)
-        (setq *brknames* nil)
-        (setq *default-multi* 5)
-        (setq *warning* t)
-        (setq *order-trace* nil)
-        (setq *print-pname* nil)
-        (setq *buckets* 16)
-        (setq *accept-file* nil)
-        (setq *write-file* nil)
-        (setq *trace-file* nil)
-        (setq *strategy* 'lex)
-        (setq *user-ids* nil)
-        (setq *in-rhs* nil)
-        (setq *decide-trace* nil)
-        (setq *pick-first-condition* t)
-        (setq *max-recurse* 2)
-        (setq *multi-attribute* nil)
-        (multi-attributes '((problem-space operator) (goal item) (state evaluation 2)))
-        (setq *instance-attributes* nil)
-        (trace-attributes
-         '((goal role) (goal impasse) (goal desired) (goal superoperator)
-           (operator object) (operator instance)))
-        (setq *watch-free-problem-spaces* nil)
-        (setq *chunk-free-problem-spaces* nil)
-        (setq *tracep-list* nil)
-        (setq *cav* nil)
-        (setq *cavi* nil)
-        (setq *tracep* t)
-        (setq *max-chunk-conditions* 200)
-        (setq *subgoal-results* nil)
-        (setq *chunk-all-paths* t)
-        (setq *smaller-chunks* nil)
-        (setq *chunks* nil)
-        (setq *chunk-classes* '(problem-space state operator))
-        (setq *always-learn* t)
-        (setq *new-chunks* nil)
-        (setq *wme-list-stack* nil)
-        (setq *learn-ids* nil)
-        (setq *learning* nil)
-        (setq *ltrace* nil)
-        (setq *never-learn* t)
-        (setq *print-learn* 0)
-        (setq *split-actions* t)
-        (setq *select-equal* 'first)
-        (setq *default-user-select* t)
-        (setq *pnames* nil)
-        (setq *free-pname-list* nil)
-        (setq *used-gensym-list* nil)
-        (setq *free-gensym-list* (list (list 'free-list)))
-        (setq *used-var-list* nil)
-        (setq *used-char-list* nil)
-        (init-gensym)
-        (soarmapc #'(lambda (x) (soarputprop x 't 'predicate)) '(< <= <=> <> = > >=))
-        (setq *recording* nil)
-        (setq *refracts* nil)
-        (setq *real-cnt* (setq *virtual-cnt* 0))
-        (setq *limit-token* 1000000)
-        (setq *limit-cs* 1000000)
-        (setq *critical* nil)
-        (setq *wmpart-list* nil)
-        (setq *global-pair* (list 'nil))
-        (setq *subgoal-tabs* t)
-        (setq *size-result-array* 15)
-        (setq *result-array* (makevector 16))
-        (setq *record-array* (makevector 16))
-        (setq x 0)
-   loop (putvector *result-array* x nil)
-        (putvector *record-array* x nil)
-        (setq x (1+ x))
-        (and (not (> x *size-result-array*))
-             (go loop))
-        (make-bottom-node)
-        (setq *pcount* 0)
-        (setq *already-fired* nil)
-        (setq *current-goal* nil)
-        (soarmachinetype)
-        (setq *spo-default-depth* 1)
-        (setq *print-spo-list* nil)
-        (setq *indent* 0)
-        (watch 0)
-        (swatch 0)
-        (setq *max-elaborations* 100)
-        (setq *remaining-cycles* 1000000)
-        (setq *remaining-decide* 1000000)
-        (setq *version-number* "4")
-	(setq *minor-version* "0")
-	(setq *release-number* "1")
-	(setq *public-version* t)
-	(setq *date-created* "November 14, 1985")
-	(soar-greeting)
-        (init-literalizes)
-        (init-soar)))
-
-(defun soar-greeting nil	
-    (soarprintc "Soar ")
-    (cond (*public-version*
-	      (soarprinc "(Version ")
-	      (soarprinc *version-number*)
-	      (soarprinc ", Release ")
-	      (soarprinc *release-number*)
-	      (soarprinc ")"))
-	  (t (soarprinc *version-number*)
-	     (soarprinc ".")
-	     (soarprinc *minor-version*)))
-    (soarprintc "Created ")
-    (soarprint *date-created*)
-    (cond (*public-version*
-	      (soarprint "Bugs and questions to soar@h.cs.cmu.edu")))
-    (soarprint "Copyright (c) 1985 Xerox Corporation.  All Rights Reserved.")
-    (terpri)
-    (soarprint "Use of this software is permitted for non-commercial")
-    (soarprint "research purposes, and it may be copied only for that use.")
-    (soarprint "This software is made available AS IS, and Xerox")
-    (soarprint "Corporation, Stanford University and Carnegie-Mellon")
-    (soarprint "University make no warranty about the software or its")
-    (soarprint "performance.")
-)
-
-(defun insertcs (name data rating)
-  (prog (instan)
-        (and (refracted name data)
-             (return nil))
-        (setq instan (cons name data))
-        (and (atom *conflict-set*)
-             (setq *conflict-set* nil))
-        (return (setq *conflict-set* (cons instan *conflict-set*)))))
-
-(defun instantiation (conflict-elem)
-  (cdr (pname-instantiation conflict-elem)))
-
-(defun main nil
-  (prog (phase-set r)
-        (setq *halt-flag* nil)
-        (setq *break-flag* nil)
-        (setq *elaborations-count* 0)
-        (setq phase-set nil)
-    dil (cond (*halt-flag* (setq r "End -- Explicit Halt") (go finis))
-              ((or (zerop *remaining-decide*)
-                   (zerop *remaining-cycles*))
-               (setq *break-flag* t)))
-        (cond ((or *break-flag*
-;                   (readp t)
-		   )
-               (setq r '***break***)
-               (go finis)))
-        (setq *first-remove* (setq *first-action* t))
-        (setq phase-set (conflict-resolution))
-        (cond ((eq *phase* 'decide)
-               (setq *remaining-cycles* (1- *remaining-cycles*))
-               (setq *remaining-decide* (1- *remaining-decide*))
-               (setq *cycle-count* (1+ *cycle-count*))
-               (setq *decide-count* (1+ *decide-count*))
-               (setq *elaborations-count* 0)
-               (setq *in-rhs* t)
-               (process-decide phase-set)
-               (setq *in-rhs* nil)
-               (setq *phase* 'elaborate))
-              ((not phase-set) (setq *phase* 'decide))
-              (t (setq *cycle-count* (1+ *cycle-count*))
-                 (cond ((and *wtrace*
-                             (trace-problem-space?))
-                        (soarprintc "--Elaboration Phase--")))
-                 (setq *already-fired* nil)
-                 (soarmapc #'process-instance phase-set)
-                 (setq *remaining-cycles* (1- *remaining-cycles*))
-                 (setq *elaborations-count* (1+ *elaborations-count*))
-                 (cond ((eq *max-elaborations* *elaborations-count*)
-                        (soarwarn
-                         "Exceeded *max-elaborations*. Proceeding to decision procedure."
-                         *max-elaborations*)
-                        (setq *phase* 'decide)))))
-        (go dil)
-  finis (setq *p-name* nil)
-        (terpri (trace-file))
-        (return r)))
-
-(defun ops-p (z)
-  (finish-literalize)
-  (princ '* (trace-file))
-  (cond ((soarlistp (cadr z)) (compile-production (car z) 'elaborate (cdr z)))
-        (t (compile-production (car z) (cadr z) (cddr z)))))
-
-(defun ops-pbreak (z)
-  (cond ((atom z)
-         (terpri (trace-file))
-         (soarprinc2 "Production breaks:" *brkpts*)
-         (terpri (trace-file))
-         (soarprinc2 "Name/identifier breaks:" *brknames*)
-         (terpri (trace-file))
-         nil)
-        (t (soarmapc #'pbreak2 z) z)))
-
-
-(defun pbreak2 (rule)
-  (prog (type blist)
-        (cond ((or (not (symbolp rule))
-                   (soarlistp rule))
-               (soarwarn "Illegal argument:" rule))
-              ((or (soarmemq rule *brkpts*)
-                   (soarmemq rule *brknames*))
-               nil)
-              ((get rule 'topnode) (soarpush rule *brkpts*) rule)
-              (t (soarpush rule *brknames*) rule))))
-
-(defun pname-instantiation (conflict-elem)
-  conflict-elem)
-
-(defun ops-pm (z)
-  (soarmapc #'(lambda (x) (pprule x nil)) z)
-  nil)
-
-
-(defun ppattval nil
-  (prog (att val)
-        (setq att (cadr *ppline*))
-        (setq *ppline* (cddr *ppline*))
-        (cond ((or (null *ppline*)
-                   (eq (car *ppline*) '^))
-               (setq val nil))
-              (t (setq val (getval))))
-        (cond ((> (+ (nwritn t) (flatc att) (flatc val)) 76) 
-	       (soarprintc " ") (indent)))
-        (soarprinc2 '^ att)
-        (soarmapc #'(lambda (z) (soarprinc2 " " z)) val)))
-
-(defun ppline (line)
-  (prog nil
-        (indent)
-        (cond ((atom line) (princ line (trace-file)))
-              (t (princ "(" (trace-file))
-                 (setq *ppline* line)
-                 (ppline2)
-                 (princ ")" (trace-file))))
-        (return nil)))
-
-(defun pponlyval nil
-  (prog (val needspace)
-        (setq val (getval))
-        (setq needspace nil)
-        (cond ((> (+ (nwritn t) (flatc val)) 76)
-               (setq needspace nil)
-               (soarprintc " ")
-               (indent)))
-    top (and (atom val)
-             (return nil))
-        (and needspace
-             (princ " " (trace-file)))
-        (setq needspace t)
-        (princ (car val) (trace-file))
-        (setq val (cdr val))
-        (go top)))
-
-(defun pprule (name flag)
-  (prog (matrix next lab port)
-        (and (not (symbolp name))
-             (return nil))
-        (setq matrix (get name 'production))
-        (and (null matrix)
-             (return nil))
-        (setq port (trace-file))
-        (soarprintc "(")
-        (cond ((eq flag 'sp) (setq matrix (p-to-sp matrix)) (princ 'sp port))
-              (t (princ 'p port)))
-        (soarprinc2 " " name)
-        (and (eq 'decide (get name 'type))
-             (soarprinc2 " " 'decide))
-    top (and (atom matrix)
-             (go fin))
-        (setq next (car matrix))
-        (setq matrix (cdr matrix))
-        (setq lab nil)
-        (terpri port)
-        (cond ((eq next '-)
-               (princ "  - " port)
-               (setq next (car matrix))
-               (setq matrix (cdr matrix)))
-              ((eq next '-->) (princ "  " port))
-              ((and (eq next '{)
-                    (atom (car matrix)))
-               (princ "   {" port)
-               (setq lab (car matrix))
-               (setq next (cadr matrix))
-               (setq matrix (cdddr matrix)))
-              ((eq next '{)
-               (princ "   {" port)
-               (setq lab (cadr matrix))
-               (setq next (car matrix))
-               (setq matrix (cdddr matrix)))
-              (t (princ "    " port)))
-        (ppline next)
-        (cond (lab (soarprinc3 " " lab "}")))
-        (go top)
-    fin (soarprint ")")))
-
-(defun ops-ppwm (avlist)
-  (conv-to-attr-nums avlist t)
-  (mapwm #'ppwm2)
-  nil)
-
-
-(defun print-stats nil
-  (setq *break-flag* nil)
-  (print-times "Run Statistics"))
-
-(defun print-times (mess)
-  (prog (cc ac pc dc time d-time)
-        (setq time (time-conversion *elapsed-time*))
-        (setq dc (+ (float *decide-count*) 1.0e-20))
-        (setq cc (+ (float *cycle-count*) 1.0e-20))
-        (setq pc (+ (float *prod-count*) 1.0e-20))
-        (setq ac (+ (float *action-count*) 1.0e-20))
-        (soarprintc mess)
-        (pm-size)
-        (cond ((eq *decide-count* 0) (terpri (trace-file)) (return)))
-        (printline (list time " Seconds Elapsed"))
-        (cond ((eq time 0) (setq time 1.0e-8)))
-        (printline
-         (list *decide-count*
-               " Decision Cycles "
-               (list (quotient (float *decide-count*) time) " Per Sec.")))
-        (printline
-         (list *cycle-count*
-               " Prod Cycles "
-               (list (quotient (float *cycle-count*) time) " Per Sec.")
-               " "
-               (list (- (quotient (float *cycle-count*) dc) 1)
-                     " E cycles/ D cycle")))
-        (printline
-         (list *prod-count*
-               " Prod. Firings "
-               (list (quotient (float *prod-count*) time) " Per Sec.")
-               " "
-               (and (< 0.01 (- cc *decide-count*))
-                    (list (quotient (float (- *prod-count* *decide-count*))
-                           (- cc *decide-count*))
-                          " Elab. prod. in parallel"))))
-        (printline
-         (list *action-count*
-               " RHS Actions "
-               (list (quotient (float *action-count*) time) " Per Sec.")))
-        (printline
-         (list (round (quotient (float *total-cs*) cc))
-               " Mean conflict set size "
-               (list *max-cs* " Maximum")))
-        (printline
-         (list (round (quotient (float *total-wm*) pc))
-               " Mean working memory size "
-               (list *max-wm* " Maximum " *current-wm* " Current ")))
-        (printline
-         (list (round (quotient (float *total-token*) pc))
-               " Mean token memory size "
-               (list *max-token* " Maximum " *current-token* " Current ")))))
-
-(defun promote-var (dope)
-  (prog (vname vpred vpos new)
-        (setq vname (car dope))
-        (setq vpred (cadr dope))
-        (setq vpos (caddr dope))
-        (cond ((eq vpred 'eqnil) (setq vpred 'eq))
-              ((not (eq vpred 'eq))
-               (%error "Illegal predicate for first occurrence" (list vname vpred))))
-        (setq new (list vname 0 vpos))
-        (setq *vars* (cons new *vars*))))
-
-(defun remove-cs (entry)
-  (setq *conflict-set* (dremove entry *conflict-set*)))
-
-(defun remove-from-conflict-set (name)
-  (prog (cs entry)
-     l1 (setq cs *conflict-set*)
-     l2 (cond ((atom cs) (return nil)))
-        (setq entry (car cs))
-        (setq cs (cdr cs))
-        (cond ((eq name (car entry))
-               (setq *conflict-set* (dremove entry *conflict-set*))
-               (go l1))
-              (t (go l2)))))
-
-(defun remove-from-wm (wme)
-  (prog (class z part timetag port match-time)
-        (setq port (trace-file))
-        (setq wme (eliminate-trailing-nil wme))
-        (setq class (wm-hash wme))
-        (setq part (get class 'wmpart*))
-        (setq z
-               (cond ((eq class 'goal-context-info) (soarassoc wme part))
-                     (t (soarassq wme part))))
-        (or z
-            (return nil))
-        (setq wme (car z))
-        (setq timetag (cdr z))
-        (cond ((and *in-rhs* *first-remove*)
-               (and *ptrace*
-                    *ttrace*
-                    (trace-problem-space?)
-                    (not *wtrace*)
-                    (princ " <--" port))
-               (setq *first-action* t)
-               (setq *first-remove* nil)))
-        (cond ((or (not *in-rhs*)
-                   (not (trace-problem-space?))))
-              ((and (not *wtrace*)
-                    *ptrace*
-                    *ttrace*)
-               (time-tag-print (list wme) port))
-              (*wtrace* (soarprintc "<=WM: ") (ppelm wme port)))
-        (setq *action-count* (1+ *action-count*))
-        (setq *critical* t)
-        (setq *current-wm* (1- *current-wm*))
-        (match nil wme)
-        (soarputprop class (dremove z part) 'wmpart*)
-        (setq *critical* nil)))
-
-(defun removecs (name data)
-  (prog (cr-data inst cs)
-        (setq cr-data (cons name data))
-        (setq cs *conflict-set*)
-      l (cond ((null cs) (record-refract name data) (return nil)))
-        (setq inst (car cs))
-        (setq cs (cdr cs))
-        (and (not (top-levels-eq inst cr-data))
-             (go l))
-        (setq *conflict-set* (dremove inst *conflict-set*))))
-
-(defun ops-rjust (z)
-  (prog (val)
-        (cond ((not (== (length z) 1))
-               (soarwarn "RJUST: Wrong number of arguments" z)
-               (return nil)))
-        (setq val ($varbind (car z)))
-        (cond ((or (not (numberp val))
-                   (< val 1)
-                   (> val 127))
-               (soarwarn "RJUST: Illegal value for field width" val)
-               (return nil)))
-        ($value 'rjust)
-        ($value val)))
-
-
-(defun ops-run (z)
-  (prog (result)
-        (cond ((eq *pcount* 0)
-               (terpri (trace-file))
-               (soarprint "Please load in some productions first.")
-               (return nil)))
-        (init-wm)
-        (setq *brkrun* nil)
-        (setq *begin-time* (alwaystime))
-        (setq *remaining-decide* 1000000)
-        (setq *remaining-cycles* 1000000)
-        (cond ((atom z))
-              ((and (atom (cdr z))
-                    (numberp (car z))
-                    (> (car z) -1))
-               (setq *remaining-cycles* (car z)))
-              ((and (numberp (car z))
-                    (eq (cadr z) 'd))
-               (setq *remaining-decide* (car z)))
-              ((soarlistp (car z))
-               (setq *brkrun* (conv-input-wme (car z)))
-               (and (null *brkrun*)
-                    (return "What?")))
-              (t (setq *brkrun* (car z))))
-        (setq result (do-continue nil))
-        (setq *elapsed-time*
-               (+ *elapsed-time* (- (alwaystime) *begin-time*)))
-        (return result)))
-
-
-(defun ops-tabto (z)
-  (prog (val)
-        (cond ((not (== (length z) 1))
-               (soarwarn "TABTO: Wrong number of arguments" z)
-               (return nil)))
-        (setq val ($varbind (car z)))
-        (cond ((or (not (numberp val))
-                   (< val 1)
-                   (> val 127))
-               (soarwarn "TABTO: Illegal column number" val)
-               (return nil)))
-        ($value 'tabto)
-        ($value val)))
-
-(defun ops-watch (z)
-  (cond ((equal z '(-1)) (setq *wtrace* nil)
-			 (setq *ptrace* nil) (setq *otrace* nil) -1)
-        ((equal z '(0)) (setq *wtrace* nil)
-			(setq *ptrace* nil) (setq *otrace* t) 0)
-        ((equal z '(0.5))
-         (setq *wtrace* nil)
-         (setq *ptrace* t)
-         (setq *ttrace* nil)
-         (setq *otrace* t)
-         0.5)
-        ((equal z '(1))
-         (setq *wtrace* nil)
-         (setq *ptrace* t)
-         (setq *ttrace* t)
-         (setq *otrace* t)
-         1)
-        ((equal z '(1.5))
-         (setq *wtrace* t)
-         (setq *ttrace* nil)
-         (setq *ptrace* t)
-         (setq *otrace* t)
-         1.5)
-        ((equal z '(2))
-         (setq *wtrace* t)
-         (setq *ttrace* t)
-         (setq *ptrace* t)
-         (setq *otrace* t)
-         2)
-        ((equal z '(3))
-         (setq *otrace* t)
-         (setq *wtrace* t)
-         (setq *ptrace* t)
-         '(2 -- conflict set trace not supported))
-        ((and (atom z)
-              (null *otrace*))
-         -1)
-        ((and (atom z)
-              (null *ptrace*))
-         0)
-        ((and (atom z)
-              (null *wtrace*))
-         1)
-        ((atom z) 2)
-        (t 'what?)))
-
-
-(defun wm-hash (x)
-  (car x))
-
-(defun ops-write (z)
-  (prog (port max k x needspace)
-        (cond ((not *in-rhs*)
-               (soarwarn "Write cannot be called at the top level" " ")
-               (return nil)))
-        ($reset)
-        (eval-args z)
-        (setq k 1)
-        (setq max ($parametercount))
-        (cond ((< max 1) (soarwarn "Write: nothing to print:" z) (return nil)))
-        (setq port (default-write-file))
-        (setq x ($parameter 1))
-        (cond ((and (symbolp x)
-                    ($ofile x))
-               (setq port ($ofile x))
-               (setq k 2)))
-        (setq needspace t)
-     la (and (> k max)
-             (return nil))
-        (setq x ($parameter k))
-        (cond ((equal x 'crlf) (setq needspace nil) (terpri port))
-              ((equal x 'rjust)
-               (setq k (+ 2 k))
-               (do-rjust ($parameter (1- k)) ($parameter k) port))
-              ((equal x 'tabto)
-               (setq needspace nil)
-               (setq k (1+ k))
-               (do-tabto ($parameter k) port))
-              (t (and needspace
-                      (princ " " port))
-                 (setq needspace t)
-                 (princ x port)))
-        (setq k (1+ k))
-        (go la)))
-
-
-(defun add-negations (current-goal data-matched)
-  (prog (negation-list return-list negation var-list condition new-condition element)
-        (and (null *p-name*)
-             (return nil))
-        (and (null (get *p-name* 'negation-index))
-             (return nil))
-        (setq return-list nil)
-        (setq negation-list (car (get *p-name* 'negation-index)))
-        (setq var-list (cadr (get *p-name* 'negation-index)))
-     l1 (cond ((null negation-list) (return return-list)))
-        (setq condition (pop negation-list))
-        (setq new-condition (list (pop condition)))
-     l2 (cond ((null condition)
-               (setq new-condition (nreverse new-condition))
-               (soarpush '- return-list)
-               (soarpush new-condition return-list)
-               (go l1)))
-        (soarpush (pop condition) new-condition)
-        (soarpush (pop condition) new-condition)
-        (cond ((variablep (car condition))
-               (setq element (cdr (soarassq (pop condition) var-list)))
-               (cond (element
-                      (soarpush
-                       (soarnth (cadr element) (soarnth (car element) data-matched))
-                       new-condition))
-                     (t (soarpush '<unbound> new-condition))))
-              ((eq (car condition) '<<)
-               (prog nil
-                  l3 (soarpush (pop condition) new-condition)
-                     (and condition
-                          (neq (car new-condition) '>>)
-                          (go l3))))
-              (t (soarpush (pop condition) new-condition)))
-        (cond ((eq current-goal (get (car new-condition) 'in-id-field)) (go l1)))
-        (go l2)))
-
-(defun ops-back-trace (objects)
-  (prog (wme goal)
-	(setq *unbound-action-ids* nil)
-        (cond ((and (not (numberp (car objects)))
-                    (get (car objects) 'goal-depth))
-               (setq goal (pop objects)))
-              ((null objects) (setq goal (most-recent-subgoal *context-stack*))))
-        (cond ((null objects)
-               (setq *created-list* (get goal 'created))
-               (find-subgoal-nonresults goal nil *created-list*)
-               (soarmapcar #'(lambda (x) (back-trace-conditions goal x t))
-                (cond (*split-actions* (find-action-sets *subgoal-results* goal))
-                      (t (list *subgoal-results*)))))
-              (t (setq wme (conv-input-wme (pop objects)))
-                 (setq goal
-                        (cond ((null objects) (most-recent-subgoal *context-stack*))
-                              (t (car objects))))
-                 (setq *created-list* (get goal 'created))
-                 (setq *subgoal-results* wme)
-                 (back-trace-conditions goal wme t)))
-        (setq *created-list* nil)
-        (setq *subgoal-results* nil)
-        (soarprint " ")))
-
-
-(defun bind-it (action-list)
-  (prog (variable-list)
-        (setq variable-list (find-constant-ids action-list))
-        (setq *learn-ids* (append variable-list *learn-ids*))
-        (return variable-list)))
-
-(defun build-a-production (condition-list action-list wme-list)
-  (prog (new-chunk)
-        (cond ((null action-list)
-               (soarwarn "No chunk was built because there were no actions" " ")
-               (return nil))
-              ((> (length condition-list) *max-chunk-conditions*)
-               (soarwarn
-                "No chunk was built because *max-chunk-conditions* was exceeded:"
-                (length condition-list))
-               (return nil)))
-     l1 (setq *p-name* (soargenpname 'p))
-        (cond ((soarmemq *p-name* *pnames*) (go l1)))
-        (setq *unbound* nil)
-        (setq condition-list
-               (nreverse (knotify-conditions (re-order-conditions condition-list))))
-        (and *unbound*
-             (setq condition-list (re-order-conditions condition-list)))
-        (setq new-chunk
-               (list (list 'quote *p-name*)
-                     (list 'quote 'elaborate)
-                     (list 'quote (nconc (nconc condition-list (list '-->)) action-list))))
-        (cond ((cdrmember new-chunk *new-chunks*)
-               (and *print-learn*
-                    (soarprintc "Duplicate chunk"))
-               (return t)))
-        (and *tracep*
-             (soarpush *p-name* *tracep-list*))
-        (soarpush *p-name* *chunks*)
-        (soarpush new-chunk *new-chunks*)
-        (soarpush wme-list *wme-list-stack*)
-        (return t)))
-
-(defun build-copies (duplicate)
-  (build-a-production
-   (append *condition-list* (soarmapcar #'cdr *copy-action-list*) (list (car duplicate)))
-   (rebind-action-ids (cdr duplicate) *learn-ids*) nil))
-
-(defun build-duplicates (action-list class-list duplicate-variable duplicates negations)
-  (prog (cond-list condition dup-list class)
-        (setq dup-list nil)
-        (setq *action-list* (prune-actions action-list duplicate-variable))
-        (setq *condition-list* nil)
-        (setq class-list (dremove 'goal-context-info class-list))
-        (soarpush 'goal-context-info class-list)
-     l1 (setq class (pop class-list))
-        (cond ((null class)
-               (cond ((null *action-list*)
-                      (setq *condition-list* *save-condition*)
-                      (setq *action-list* *save-action*)
-                      (return nil)))
-               (setq *condition-list* (nreverse (append negations *condition-list*)))
-               (return dup-list)))
-        (setq cond-list (get class 'condition))
-        (soarputprop class nil 'condition)
-     l2 (setq condition (pop cond-list))
-        (cond ((null condition) (go l1))
-              ((soarmemq condition duplicates)
-               (soarpush (cons condition (dup-action condition)) dup-list))
-              (t (soarpush condition *condition-list*)))
-        (go l2)))
-
-(defun build-terse (conditions)
-  (prog (return-conditions change-flag element)
-        (and *ltrace*
-             (soarprinc "Conditions that are tersed out: "))
-     l0 (setq change-flag nil)
-        (setq return-conditions nil)
-     l1 (setq element (pop conditions))
-        (cond ((and (null element)
-                    change-flag)
-               (setq conditions (nreverse return-conditions))
-               (go l0))
-              ((null element)
-               (and *ltrace*
-                    (terpri (trace-file)))
-               (return (nreverse return-conditions)))
-              ((and (neq (class element) 'preference)
-                    (free-condition element))
-               (setq change-flag t)
-               (and *ltrace*
-                    (ppline (car (p-conds-to-sp (list (clean-up-element element))))))
-               (untest (cdr element)))
-              (t (soarpush element return-conditions)))
-        (go l1)))
-
-(defun build-variable-list (element)
-  (and element
-       (get element 'in-id-field)
-       (setq *learn-ids* (cons (cons element (soargenvar element)) *learn-ids*))))
-
-(defun clean-up-action (action)
-  (cons 'make (clean-up-clause action 'action)))
-
-(defun clean-up-clause (condition c-or-a)
-  (prog (new-condition curpos att ppdat val class found-value element)
-        (cond ((or (eq condition '-)
-                   (eq (cadr condition) '^))
-               (return condition)))
-        (setq class (pop condition))
-        (setq found-value nil)
-        (setq new-condition (list class))
-        (setq ppdat (get class 'ppdat))
-        (cond ((null ppdat) (setq ppdat (get 'state-info 'ppdat))))
-        (setq curpos 1)
-     l1 (setq curpos (1+ curpos))
-        (cond ((null condition)
-               (and found-value
-                    (return new-condition))
-               (return (nconc new-condition '(^ value nil)))))
-        (setq element (pop condition))
-        (and (null element)
-             (go l1))
-        (setq att (cdr (soarassq curpos ppdat)))
-        (and (eq att 'value)
-             (setq found-value t))
-        (or att
-            (setq att curpos))
-        (and (eq att 'value)
-             (setq found-value t))
-        (setq val (soarassq element *learn-ids*))
-        (cond (val
-               (setq val (cdr val))
-               (and (eq c-or-a 'condition)
-                    (soarputprop val
-                     (1+ (or (get val 'tested)
-                             0))
-                     'tested)))
-              (t (setq val element)))
-        (nconc new-condition (list '^ att val))
-        (go l1)))
-
-(defun clear-var-list nil
-  (setq *learn-ids* nil)
-  (soarmapc #'soarclearprops *used-var-list*)
-  (soarmapc #'(lambda (x) (soarputprop x 1 'var-count)) *used-char-list*)
-  (setq *used-var-list* nil))
-
-(defun closure-preference (action subgoal)
-  (and (test-preference-field (soarnth *goal-index* action) subgoal)
-       (test-preference-field (soarnth *problem-space-index* action) subgoal)
-       (test-preference-field (soarnth *state-index* action) subgoal)
-       (test-preference-field (soarnth *operator-index* action) subgoal)))
-
-(defun compactify-conditions (condition-list action-list)
-  (prog (class-list class-name same-class element duplicates duplicate-variable sclass
-         negations)
-        (setq duplicates nil)
-        (setq *save-condition* condition-list)
-        (setq *save-action* action-list)
-        (setq negations nil)
-        (setq class-list nil)
-        (setq duplicate-variable nil)
-     l1 (setq element (pop condition-list))
-        (cond ((null element)
-               (return (build-duplicates action-list (reverse class-list)
-                        duplicate-variable duplicates negations)))
-              ((eq element '-)
-               (soarpush '- negations)
-               (soarpush (pop condition-list) negations)
-               (go l1)))
-        (setq class-name (car element))
-        (setq same-class (get class-name 'condition))
-        (cond ((and (neq class-name 'preference)
-                    (free-condition element))
-               (setq same-class nil)))
-     l4 (setq sclass (pop same-class))
-        (cond ((null sclass)
-               (addprop class-name 'condition element)
-               (and (not (soarmemq class-name class-list))
-                    (soarpush class-name class-list))
-               (go l1)))
-        (setq *suspected-duplicates* nil)
-        (cond ((compare-conditions element sclass)
-               (and (not (soarmemq sclass duplicates))
-                    (soarpush sclass duplicates))
-               (setq duplicate-variable (append duplicate-variable *suspected-duplicates*))
-               (go l1)))
-        (go l4)))
-
-(defun create-production nil
-  (prog (chunk wme-list)
-        (and (null *new-chunks*)
-             (return))
-        (setq *new-chunks* (nreverse *new-chunks*))
-        (setq *wme-list-stack* (nreverse *wme-list-stack*))
-     l1 (cond ((null *new-chunks*) (setq *wme-list-stack* nil) (return)))
-        (setq chunk (pop *new-chunks*))
-        (setq wme-list (pop *wme-list-stack*))
-        (eval (cons 'compile-production chunk))
-        (cond ((eq 1 *print-learn*)
-               (terpri (trace-file))
-               (eval (list 'spm (cadar chunk))))
-              (*print-learn* (soarprintc "Build:") (soarprinc (cadar chunk))))
-        (refract-new-p chunk wme-list)
-        (go l1)))
-
-(defun dup-action (condition)
-  (prog (element action action-list return-list save-action)
-        (setq action-list *action-list*)
-        (setq *action-list* nil)
-        (setq return-list nil)
-     l1 (setq action (pop action-list))
-        (and (null action)
-             (return return-list))
-        (cond ((eq (cadr action) 'preference) (soarpush action *action-list*) (go l1)))
-        (setq save-action action)
-     l2 (setq element (pop action))
-        (cond ((null element) (soarpush save-action *action-list*) (go l1))
-              ((and (variablep element)
-                    (soarmemq element (cddddr condition)))
-               (soarpush save-action return-list)
-               (go l1)))
-        (go l2)))
-
-(defun find-action-closure (listx)
-  (soarmapcar #'(lambda (x) (cdr (soarassq x *learn-ids*))) (find-closure listx)))
-
-(defun find-closure (listx)
-  (cond ((null listx) listx)
-        ((eq (car listx) '-) (find-closure (cddr listx)))
-        (t (merge-not-time (cdar listx) (find-closure (cdr listx))))))
-
-(defun find-constant-ids (action-list)
-  (prog (action-ids element action)
-        (setq action-ids nil)
-     l1 (setq action (pop action-list))
-        (and (null action)
-             (return action-ids))
-        (setq element (soarnth 4 action))
-        (cond ((and (not (variablep element))
-                    (not (soarassq element action-ids)))
-               (soarpush (cons element (soargenvar element)) action-ids)))
-        (go l1)))
-
-(defun free-condition (elm1)
-  (prog (carelm found-loser)
-        (setq elm1 (cddddr elm1))
-        (setq found-loser nil)
-     l1 (setq elm1 (cddr elm1))
-        (cond ((null elm1) (return found-loser)))
-        (setq carelm (pop elm1))
-        (and (numberp carelm)
-             (go l1))
-        (cond ((eq (get carelm 'tested) 1)
-               (cond ((soarmemq carelm *action-closure*) (return nil))
-                     (t (setq found-loser t)))))
-        (go l1)))
-
-(defun get-cav-value (class attribute)
-  (cdr (soarassq attribute (cdr (soarassq class *cav*)))))
-
-(defun get-cavi-id (class attribute value)
-  (cdr (soarassq value (cdr (soarassq attribute (cdr (soarassq class *cavi*)))))))
-
-(defun knotify (val variables)
-  (prog (result)
-        (setq result nil)
-     l1 (setq result (append result (list '<> (car variables))))
-        (setq variables (cdr variables))
-        (and variables (go l1))
-        (cond ((eq val '<unbound>) (setq *unbound* t) (return (append result '(}))))
-              (t (return (append result (list val '})))))))
-
-(defun knotify-conditions (conditions)
-  (prog (condition attribute return-conditions new-condition class value values id ids
-         idds s-condition variable-list)
-        (setq variable-list
-               (setq return-conditions
-                      (setq *cav* (setq *cavi* (setq *variable-pairs* nil)))))
-     l1 (setq condition (pop conditions))
-        (cond ((eq condition '-) (soarpush condition return-conditions) (go l1))
-              ((null condition) (setq *cav* (setq *cavi* nil)) (return return-conditions)))
-        (setq s-condition condition)
-        (setq new-condition (list (setq class (car condition))))
-        (setq condition (cddr condition))
-        (setq attribute 'worst)
-        (setq id 'worst)
-     l2 (cond ((eq (car condition) 'identifier) (setq id (cadr condition)))
-              ((eq (car condition) 'attribute) (setq attribute (cadr condition)))
-              ((eq (car condition) 'value)
-               (setq value (cadr condition))
-               (cond ((variablep value)
-                      (setq values (get-cav-value class attribute))
-                      (cond ((null values)
-                             (put-cav-attribute class attribute)
-                             (put-cav-value class attribute (list value))
-                             (and (not (soarmemq value variable-list))
-                                  (soarpush value variable-list)))
-                            ((and (not (soarmemq value values))
-                                  (not (soarmemq value variable-list)))
-                             (put-cav-value class attribute (cons value values))
-                             (setq new-condition
-                                    (append new-condition
-                                            '(^ value {)
-                                            (knotify value values)))
-                             (soarpush (cons value values) *variable-pairs*)
-                             (setq variable-list (cons value variable-list))
-                             (go l4))
-                            ((not (soarmemq value values))
-                             (put-cav-value class attribute (cons value values)))))
-                     ((and (neq id 'worst)
-                           (neq attribute 'worst)
-                           (neq value '{))
-                      (setq ids (get-cavi-id class attribute value))
-                      (setq idds (cons id ids))
-                      (cond ((null ids)
-                             (put-cavi-attribute class attribute)
-                             (put-cavi-value class attribute value)
-                             (put-cavi-id class attribute value idds))
-                            ((and (not (soarmemq id ids))
-                                  (not (soarassoc id *variable-pairs*)))
-                             (put-cavi-id class attribute value idds)
-                             (soarpush idds *variable-pairs*)
-                             (setq new-condition
-                                    (append (list class '^ 'identifier '{)
-                                            (knotify id ids)
-                                            (list '^ 'attribute attribute '^ 'value value)))
-                             (go l4))))
-                     ((eq value '{) (nconc new-condition (cons '^ condition)) (go l4)))))
-        (nconc new-condition (list '^ (car condition) (cadr condition)))
-        (setq condition (cdddr condition))
-        (and condition (go l2))
-     l4 (soarpush new-condition return-conditions)
-        (go l1)))
-
-(defun ops-learn (z)
-  (cond ((atom z) (print-status))
-        (t (cond ((eq (car z) 'on)
-                  (cond ((and *never-learn*
-                              (neq *cycle-count* 0))
-                         (terpri (trace-file))
-                         (soarprint
-                          "Error: Can not turn learning on.  Must init-soar first"))
-                        (t (setq *learning* t) (setq *never-learn* nil))))
-                 ((eq (car z) 'off)
-                  (cond ((and *never-learn*
-                              (neq *cycle-count* 0))
-                         (terpri (trace-file))
-                         (soarprint
-                          "Error: Can not turn learning to off.  Must init-soar first"))
-                        (t (setq *learning* nil) (setq *never-learn* nil))))
-                 ((eq (car z) 'never) (setq *learning* nil) (setq *never-learn* t))
-                 ((eq (car z) 'full-print) (setq *print-learn* 1))
-                 ((eq (car z) 'print) (setq *print-learn* 0))
-                 ((eq (car z) 'noprint) (setq *print-learn* nil))
-                 ((eq (car z) 'full-trace) (setq *ltrace* t) (setq *tracep* t))
-                 ((eq (car z) 'trace) (setq *tracep* t) (setq *ltrace* nil))
-                 ((eq (car z) 'notrace) (setq *tracep* nil) (setq *ltrace* nil))
-                 ((eq (car z) 'always) (setq *always-learn* t))
-                 ((eq (car z) 'bottom-up) (setq *always-learn* nil))
-                 (t (terpri (trace-file)) (soarprint "Error: unknown option")))
-           (eval (cons 'learn (cdr z))))))
-
-
-(defun learn-back-trace (old-context prior-context new-context subgoaled)
-  (prog (return-value condition-list subgoal)
-        (setq subgoal (get-current old-context 'goal))
-        (setq *created-list* (get subgoal 'created))
-        (setq *unbound-action-ids* nil)
-        (soarmapc #'remove-from-wm
-         (find-subgoal-nonresults subgoal (get-current prior-context 'goal)
-          *created-list*))
-        (cond (*never-learn* (soarclearprops subgoal) (return t)))
-        (setq return-value
-               (soarmapcar
-                #'(lambda (x)
-                    (handle-back-trace-actions x old-context prior-context new-context
-                     subgoaled))
-                (cond (*split-actions* (find-action-sets *subgoal-results* subgoal))
-                      (t (list *subgoal-results*)))))
-        (soarclearprops subgoal)
-        (setq *subgoal-results* nil)
-        (setq *learn-ids* nil)
-        (return (t-in-list? return-value))))
-
-(defun prune-actions (action-list duplicate-variable)
-  (prog (action save-action return-list)
-        (setq return-list nil)
-     l1 (and (null action-list)
-             (return return-list))
-        (setq action (pop action-list))
-        (setq save-action action)
-     l2 (cond ((null action) (soarpush save-action return-list) (go l1))
-              ((soarmemq (pop action) duplicate-variable) (go l1)))
-        (go l2)))
-
-(defun put-cav-attribute (class attribute)
-  (cond ((soarassq class *cav*)
-         (rplacd (soarassq class *cav*)
-                 (cons (list attribute) (cdr (soarassq class *cav*)))))
-        (t (setq *cav* (cons (cons class (list (list attribute))) *cav*)))))
-
-(defun put-cav-value (class attribute value)
-  (rplacd (soarassq attribute (cdr (soarassq class *cav*))) value))
-
-(defun put-cavi-attribute (class attribute)
-  (cond ((soarassq attribute (cdr (soarassq class *cavi*))))
-        ((soarassq class *cavi*)
-         (rplacd (soarassq class *cavi*)
-                 (cons (list attribute) (cdr (soarassq class *cavi*)))))
-        (t (setq *cavi* (cons (cons class (list (list attribute))) *cavi*)))))
-
-(defun put-cavi-id (class attribute value id)
-  (rplacd (soarassq value (cdr (soarassq attribute (cdr (soarassq class *cavi*))))) id))
-
-(defun put-cavi-value (class attribute value)
-  (rplacd (soarassq attribute (cdr (soarassq class *cavi*)))
-          (cons (list value) (cdr (soarassq attribute (cdr (soarassq class *cavi*)))))))
-
-(defun rebind-action-ids (action-list copy-list)
-  (prog (element new-element return-list val val2)
-        (setq return-list nil)
-     l1 (and (null action-list)
-             (return return-list))
-        (setq element (pop action-list))
-        (setq new-element nil)
-     l2 (and (null element)
-             (go l3))
-        (setq val2 (pop element))
-        (setq val (cdr (soarassq val2 copy-list)))
-        (or val
-            (setq val val2))
-        (soarpush val new-element)
-        (go l2)
-     l3 (soarpush (nreverse new-element) return-list)
-        (go l1)))
-
-(defun refract-new-p (new-p wme-list)
-  (prog (element prior-element)
-        (setq prior-element nil)
-        (setq new-p (cadar new-p))
-     l1 (cond ((setq element (soarassq new-p *conflict-set*))
-               (cond ((soarmemq element prior-element) (return t))
-                     ((or (null wme-list)
-                          (test-subset (cdr element) wme-list))
-                      (setq *conflict-set* (dremove element *conflict-set*)))
-		     (t (setq *conflict-set*
-			      (append (dremove element *conflict-set*)
-				      (list element)))))
-               (soarpush element prior-element)
-               (go l1))
-              (t (return t)))))
-
-(defun tersify-negations (negations)
-  (prog (condition return-list new-condition id value)
-        (setq return-list nil)
-     l1 (cond ((null negations) (return return-list)))
-        (setq condition (pop negations))
-        (setq new-condition (list (pop condition)))
-     l2 (cond ((null condition)
-               (setq new-condition (nreverse new-condition))
-               (and (soarmember new-condition return-list)
-                    (go l1))
-               (soarpush '- return-list)
-               (soarpush new-condition return-list)
-               (go l1)))
-        (soarpush (pop condition) new-condition)
-        (soarpush (pop condition) new-condition)
-        (setq id (pop condition))
-        (cond ((eq 1 (get id 'tested)) (soarpush '<unbound> new-condition) (go l2))
-              (t (soarpush id new-condition) (go l2)))))
-
-(defun test-chunk-for-content (conditions)
-  (prog (condition)
-     l1 (cond ((null conditions)
-               (soarwarn
-                "No chunk was built because no conditions had a class in *chunk-classes*"
-                " ")
-               (clear-var-list)
-               (return t)))
-        (setq condition (pop conditions))
-        (cond ((eq condition '-) (go l1))
-              ((soarmemq (conv-type-to-sp (car condition)) *chunk-classes*) (return nil)))
-        (go l1)))
-
-(defun ask-for-choice (choice-list)
-  (prog (choice count)
-        (setq *elapsed-time*
-               (+ *elapsed-time* (- (alwaystime) *begin-time*)))
-        (cond (*interlisp* (return (interlisp-menu choice-list))))
-     l1 (terpri (trace-file))
-        (soarprint "Choose from this list by position in list (1-n)")
-        (setq count 1)
-        (soarmapc
-         #'(lambda (x) (soarprinc2 count ": ") (print-choice x) (setq count (1+ count)))
-         choice-list)
-        (princ "? " (trace-file))
-        (setq choice (read))
-        (cond ((and (numberp choice)
-                    (> choice 0)
-                    (< choice (1+ (length choice-list))))
-               (setq *begin-time* (alwaystime))
-               (return (soarnth (1- choice) choice-list))))
-        (soarprintc "Your answer was not a number between 1 and n.")
-        (go l1)))
-
-(defun classify-decide (instance)
-  (prog (pname node action goal slot value id id2 compared)
-        (setq pname (car instance))
-        (setq *data-matched* (cdr instance))
-        (setq node (get pname 'topnode))
-        (init-var-mem (var-part node))
-        (init-ce-var-mem (ce-var-part node))
-        (setq action (cdddr (cadr (rhs-part node))))
-        (setq goal ($varbind (car action)))
-        (setq action (cdddr action))
-        (setq id ($varbind (car action)))
-        (setq action (cdddr action))
-        (setq slot ($varbind (car action)))
-        (setq action (cdddr action))
-        (setq value ($varbind (car action)))
-        (setq action (cdddr action))
-        (setq compared ($varbind (car action)))
-        (cond ((eq value 'indifferent) (cond (compared (setq value 'equal))))
-              ((eq value 'better)
-               (setq value 'worse)
-               (setq id2 compared)
-               (setq compared id)
-               (setq id id2)))
-        (addprop goal 'preferences (list slot value id compared (car *data-matched*)))))
-
-(defun decide-trace (arg)
-  (setq *decide-trace* arg))
-
-(defun decide-tracer (label list)
-  (cond (*decide-trace*
-         (terpri (trace-file))
-         (soarprinc3 " " label " ")
-         (soarmapc #'print-id list))))
-
-(defun decision-procedure (value-list current)
-  (prog (new-values saved-values)
-        (setq new-values (find-acceptable value-list))
-        (decide-tracer 'acceptable new-values)
-        (cond ((null new-values)
-               (cond ((and (neq current 'undecided)
-                           (null (prune-rejects (list (list current)) value-list current)))
-                      (return '(rejection))))
-               (return '(no-change))))
-        (setq new-values (process-indifferent new-values value-list))
-        (decide-tracer 'post-indifferent new-values)
-        (setq new-values (set-equals new-values value-list))
-        (decide-tracer 'post-equal new-values)
-        (setq new-values (prune-rejects new-values value-list current))
-        (decide-tracer 'post-reject new-values)
-        (cond ((or (null new-values)
-                   (null (car new-values)))
-               (return '(rejection))))
-        (setq saved-values new-values)
-        (setq new-values (prune-worse new-values value-list))
-        (decide-tracer 'post-worse new-values)
-        (and (null new-values)
-             (return (cons 'conflict (soarsort (flatten saved-values)))))
-        (and (null (car new-values))
-             (return (cons 'conflict (soarsort (flatten saved-values)))))
-        (setq new-values (select-best new-values value-list))
-        (decide-tracer 'post-best new-values)
-        (setq new-values (set-worst new-values value-list))
-        (decide-tracer 'post-worst new-values)
-        (and (cdr new-values)
-             (return (test-parallel (soarsort (flatten new-values)) value-list 'tie)))
-        (return (test-parallel new-values value-list nil))))
-
-(defun find-acceptable (value-list)
-  (dremove 'nil (flatten (find-all-assq 'acceptable value-list))))
-
-(defun find-all-assq (item alist)
-  (prog (alist2 element)
-        (setq alist2 nil)
-     l1 (and (null alist)
-             (return alist2))
-        (setq element (pop alist))
-        (cond ((and (eq item (car element))
-                    (not (soarmember (cdr element) alist2)))
-               (soarpush (cdr element) alist2)))
-        (go l1)))
-
-(defun find-goal-preferences (context)
-  (get (car context) 'preferences))
-
-(defun find-no-change-slot (context)
-  (cond ((eq (cadr context) 'undecided) 'goal)
-        ((eq (caddr context) 'undecided) 'problem-space)
-        ((eq (cadddr context) 'undecided) 'state)
-        (t 'operator)))
-
-(defun find-preference (data)
-  (prog nil
-     l1 (cond ((null data) (return nil))
-              ((eq (caar data) 'preference) (return (car data))))
-        (setq data (cdr data))
-        (go l1)))
-
-(defun find-worse (x ylist)
-  (cond ((null ylist) nil) ((soarmemq x (car ylist)) t) (t (find-worse x (cdr ylist)))))
-
-(defun make-info (info goal-id attribute value)
-  (prog (array)
-        (setq array (list info goal-id attribute value))
-        (add-to-wm array)
-        (return array)))
-
-(defun process-decide (phase-set)
-  (accum-stats)
-  (setq *new-chunks* nil)
-  (soarmapcar #'classify-decide phase-set)
-  (process-context-stack *context-stack*))
-
-(defun process-indifferent (new-values value-list)
-  (prog (worst-set return-list new-equals old-equals worst-list item)
-        (setq worst-list (find-all-assq 'indifferent value-list))
-        (setq new-equals nil)
-        (setq return-list nil)
-     l1 (cond ((null new-values)
-               (and new-equals
-                    (return (cons new-equals return-list)))
-               (return return-list)))
-        (setq old-equals (pop new-values))
-        (cond ((soarassq old-equals worst-list) (soarpush old-equals new-equals))
-              (t (soarpush (list old-equals) return-list)))
-        (go l1)))
-
-(defun process-results (results id)
-  (cond ((null (cdr results)) (car results))
-        ((soarmemq id results) id)
-        ((eq *select-equal* 'first) (car results))
-        ((soarlistp *select-equal*)
-         (cond ((find-selected-result (pop *select-equal*) results))
-               (t (setq *select-equal* t) (ask-for-choice results))))
-        (*select-equal* (ask-for-choice results))
-        (t (soarnth (random (1- (length results))) results))))
-
-(defun prune-rejects (new-values value-list current)
-  (prog (return-list reject-list new-value new-value-list)
-        (setq reject-list (dremove 'nil (flatten (find-all-assq 'reject value-list))))
-        (setq return-list nil)
-     l1 (cond ((null new-values)
-               (cond ((and (null return-list)
-                           (eq current 'undecided))
-                      (return nil))
-                     ((and (null return-list)
-                           (soarlistp current))
-                      (return (list (soarmapc
-                                     #'(lambda (x) (setq current (remove x current)))
-                                     reject-list))))
-                     ((and (null return-list)
-                           (not (soarmemq current reject-list)))
-                      (return (list current))))
-               (return return-list)))
-        (setq new-value (pop new-values))
-        (setq new-value-list nil)
-     l2 (cond ((null new-value)
-               (and new-value-list
-                    (soarpush new-value-list return-list))
-               (go l1))
-              ((not (soarmemq (car new-value) reject-list))
-               (soarpush (car new-value) new-value-list)))
-        (pop new-value)
-        (go l2)))
-
-(defun prune-remove (remove-list)
-  (prog (non-context-list wme)
-        (setq non-context-list nil)
-     l1 (and (null remove-list)
-             (return (nreverse non-context-list)))
-        (setq wme (pop remove-list))
-        (cond ((and (eq (class wme) 'goal-context-info)
-                    (soarmemq (sattribute wme) '(problem-space state operator)))
-               (remove-from-wm wme))
-              (t (soarpush wme non-context-list)))
-        (go l1)))
-
-(defun prune-worse (new-values value-list)
-  (prog (equal-set return-list equals old-equals old-values item item2 worse-list hit
-         worse-list2)
-        (setq worse-list (find-all-assq 'worse value-list))
-        (setq return-list nil)
-        (setq old-values new-values)
-     l1 (and (null new-values)
-             (return return-list))
-        (setq old-equals (setq equal-set (pop new-values)))
-        (setq equals nil)
-     l2 (cond ((null equal-set) (soarpush equals return-list) (go l1)))
-        (setq item (pop equal-set))
-        (setq worse-list2 worse-list)
-     l4 (cond ((null worse-list2) (soarpush item equals) (go l2)))
-        (setq item2 (pop worse-list2))
-        (cond ((and (eq (car item2) item)
-                    (neq item (cadr item2)))
-               (setq hit (cadr item2))
-               (cond ((soarmemq hit old-equals) (go l2))
-                     ((find-worse hit old-values) (go l1)))))
-        (go l4)))
-
-(defun select-best (new-values value-list)
-  (prog (return-list equal-list old-values best-list save-e-list e-item)
-        (setq best-list (find-all-assq 'best value-list))
-        (setq return-list nil)
-        (setq old-values new-values)
-     l1 (and (null new-values)
-             (null return-list)
-             (return old-values))
-        (and (null new-values)
-             (return (list return-list)))
-        (setq equal-list (pop new-values))
-        (setq save-e-list equal-list)
-     l2 (and (null equal-list)
-             (go l1))
-        (setq e-item (pop equal-list))
-        (cond ((soarassq e-item best-list) (soarpush e-item return-list)))
-        (go l2)))
-
-(defun user-select (x)
-  (setq *select-equal* x))
-
-(defun set-equals (new-values value-list)
-  (prog (equal-set new-equals return-list hit hit-list old-hit-list equal-list
-         equal-list2)
-        (setq equal-list (find-all-assq 'equal value-list))
-        (setq return-list nil)
-        (setq new-equals (pop new-values))
-        (setq equal-set nil)
-        (setq old-hit-list nil)
-        (setq hit-list nil)
-     l2 (cond ((null new-equals)
-               (and equal-set
-                    (soarpush equal-set return-list))
-               (and (null new-values)
-                    (return return-list))
-               (setq old-hit-list (append old-hit-list hit-list))
-               (setq new-equals (pop new-values))
-               (setq equal-set nil)
-               (cond ((soarmemq (car new-equals) old-hit-list) (pop new-equals) (go l2)))))
-        (setq equal-list2 equal-list)
-     l4 (cond ((null equal-list2) (soarpush (pop new-equals) equal-set) (go l2)))
-        (cond ((equal (caar equal-list2) (car new-equals))
-               (setq hit (cadar equal-list2))
-               (cond ((and (not (soarmemq hit equal-set))
-                           (not (soarmemq hit new-equals))
-                           (soarmemq hit (flatten new-values)))
-                      (setq new-equals (append new-equals (list hit)))
-                      (soarpush hit hit-list)))))
-        (pop equal-list2)
-        (go l4)))
-
-(defun set-worst (new-values value-list)
-  (prog (worst-set return-list new-equals old-equals worst-list item)
-        (setq worst-list (find-all-assq 'worst value-list))
-        (setq return-list nil)
-     l1 (and (null new-values)
-             (null return-list)
-             (return (list worst-set)))
-        (and (null new-values)
-             (return return-list))
-        (setq old-equals (pop new-values))
-        (setq new-equals nil)
-     l2 (cond ((null old-equals)
-               (and new-equals
-                    (soarpush new-equals return-list))
-               (go l1)))
-        (setq item (pop old-equals))
-        (cond ((soarassq item worst-list) (soarpush item worst-set))
-              (t (soarpush item new-equals)))
-        (go l2)))
-
-(defun test-parallel (results value-list difficulty)
-  (prog (parallel-list parallel-results new-results)
-        (setq parallel-list (find-all-assq 'parallel value-list))
-        (setq results (flatten results))
-        (and (null parallel-list)
-             (return (cons difficulty results)))
-        (setq parallel-results (list (car results)))
-        (setq new-results (cdr results))
-     l1 (cond ((null new-results)
-               (decide-tracer 'parallel results)
-               (return (cons 'parallel results))))
-        (cond ((soarmember (list (car new-results) (car parallel-results)) parallel-list)
-               (soarpush (pop new-results) parallel-results)
-               (go l1))
-              (t (return (cons difficulty results))))))
-
-(defun change-context (difficulty results old-context slot context-stack preferences)
-  (prog (new-context subgoaled)
-        (cond ((and *wtrace*
-                    (cdr context-stack)
-                    (trace-problem-space?))
-               (soarprintc "--Removal Phase--")))
-        (setq new-context (create-new-context difficulty results old-context slot))
-        (setq subgoaled
-               (soarmapcar #'(lambda (x) (process-sub-contexts x new-context old-context))
-                (cdr context-stack)))
-        (cond ((t-in-list? subgoaled)
-               (rplaca (soarnthcdr 9 old-context) t)
-               (rplaca (soarnthcdr 9 new-context) t)))
-        (cond ((and *wtrace*
-                    (trace-problem-space?))
-               (soarprintc "--Decision Phase--")))
-        (cond (difficulty
-               (write-trace " " difficulty slot)
-               (create-production)
-               (cond ((and (eq difficulty 'no-change)
-                           (soarlistp results))
-                      (rplacd context-stack
-                              (soarmapcar
-                               #'(lambda (x)
-                                   (create-goal-context difficulty slot x old-context
-                                    preferences))
-                               results)))
-                     (t (rplacd context-stack
-                                (list (create-goal-context difficulty slot results
-                                       old-context preferences)))))
-               (return new-context))
-              (t (write-trace " DECIDE " slot results)
-                 (rplacd context-stack nil)
-                 (change-to-new-context new-context old-context preferences)
-                 (return new-context)))))
-
-(defun change-to-new-context (new-context old-context preferences)
-  (prog (slots new-contexts slot depth context-changes)
-        (setq slots '(operator state problem-space))
-        (setq new-contexts nil)
-        (setq *p-name* 'decision-procedure)
-        (setq *context* new-context)
-        (setq depth (get-context-depth new-context))
-        (setq context-changes nil)
-     l1 (setq slot (pop slots))
-        (cond ((null slot)
-               (create-production)
-               (soarmapc #'(lambda (x) (trace-object (car x) (cdr x) depth))
-                context-changes)
-               (soarmapc
-                #'(lambda (x)
-                    (cond ((neq (svalue x) 'undecided)
-                           (setq *data-matched*
-                                  (list (find-acceptable-preference preferences (svalue x))))
-                           (setq *first-action* t))
-                          (t (setq *data-matched* nil) (setq *first-action* t)))
-                    (add-to-wm x))
-                new-contexts)
-               (return))
-              ((neq (get-current new-context slot) (get-current old-context slot))
-               (setq new-contexts
-                      (nconc (remove-current (get-current old-context 'goal) slot
-                              (get-current old-context slot)
-                              (get-current new-context slot))
-                             new-contexts))
-               (soarpush (cons slot (get-current new-context slot)) context-changes)))
-        (go l1)))
-
-(defun context-stack nil
-  (soarmapc #'print *context-stack*)
-  t)
-
-(defun create-goal-context (desired slot results context preferences)
-  (prog (goal-id created-list result superoperator temp supergoal)
-        (setq *p-name* 'decision-procedure)
-        (setq *data-matched* nil)
-        (setq supergoal (get-current context 'goal))
-        (setq goal-id (soargensym 'g))
-        (soarputprop goal-id (1+ (get supergoal 'goal-depth)) 'goal-depth)
-        (setq *context*
-               (list goal-id
-                     'undecided
-                     'undecided
-                     'undecided
-                     0
-                     nil
-                     nil
-                     nil
-                     results
-                     nil
-                     (1+ (get-context-depth context))))
-        (setq created-list
-               (list (make-info 'goal-context-info goal-id 'problem-space 'undecided)
-                     (make-info 'goal-context-info goal-id 'supergoal supergoal)
-                     (make-info 'goal-context-info goal-id 'state 'undecided)
-                     (make-info 'goal-context-info goal-id 'operator 'undecided)
-                     (make-info 'goal-context-info goal-id 'choices
-                      (cond ((or (eq desired 'no-change)
-                                 (eq desired 'rejection))
-                             'none)
-                            (t 'multiple)))))
-        (cond ((eq desired 'rejection)
-               (setq slot (cadr (soarmemq slot '(operator state problem-space goal))))
-               (create-goal-info (find-reject-preferences preferences) goal-id)))
-        (nconc created-list
-               (list (make-info 'goal-context-info goal-id 'impasse desired)))
-        (setq superoperator 'undecided)
-        (setq temp nil)
-        (cond ((eq desired 'no-change)
-               (cond ((eq slot 'operator) (setq superoperator results))
-                     ((eq slot 'state)
-                      (setq temp
-                             (list (list 'goal-context-info
-                                         supergoal
-                                         'operator
-                                         'undecided))))
-                     ((eq slot 'problem-space)
-                      (setq temp
-                             (list (list 'goal-context-info supergoal 'state 'undecided))))
-                     ((eq slot 'goal)
-                      (setq temp
-                             (list (list 'goal-context-info
-                                         supergoal
-                                         'problem-space
-                                         'undecided)))))))
-        (create-goal-info temp goal-id)
-        (nconc created-list (list (make-info 'goal-context-info goal-id 'role slot)))
-        (create-goal-info
-         (list (list 'goal-context-info supergoal 'operator superoperator)) goal-id)
-        (nconc created-list
-               (list (make-info 'goal-context-info goal-id 'superoperator superoperator)))
-     l4 (cond ((or (not results)
-                   (atom results))
-               (soarputprop goal-id created-list 'created)
-               (trace-object 'goal goal-id (1+ (get-context-depth context)))
-               (return (list *context*))))
-        (setq result (pop results))
-        (cond ((eq slot 'state)
-               (create-goal-info
-                (list (list 'goal-context-info
-                            supergoal
-                            'operator
-                            (get-current context 'operator))
-                      (find-acceptable-preference preferences result))
-                goal-id))
-              (t (create-goal-info (list (find-acceptable-preference preferences result))
-                  goal-id)))
-        (nconc created-list (list (make-info 'goal-context-info goal-id 'item result)))
-        (go l4)))
-
-(defun create-new-context (difficulty result old-context slot)
-  (prog (slots found-slot aslot return-list)
-        (cond (difficulty
-               (return (list (get-current old-context 'goal)
-                             (get-current old-context 'problem-space)
-                             (get-current old-context 'state)
-                             (get-current old-context 'operator)
-                             (get-context-pnumber old-context)
-                             slot
-                             difficulty
-                             result
-                             (get-context-super-operator old-context)
-                             (get-context-subgoaled old-context)
-                             (get-context-depth old-context)))))
-        (setq slots '(goal problem-space state operator))
-        (setq return-list nil)
-        (setq found-slot nil)
-     l1 (setq aslot (pop slots))
-        (cond ((null aslot)
-               (return (append return-list
-                               (list (get-context-pnumber old-context)
-                                     nil
-                                     nil
-                                     nil
-                                     (get-context-super-operator old-context)
-                                     (get-context-subgoaled old-context)
-                                     (get-context-depth old-context))))))
-        (cond (found-slot (setq return-list (append return-list '(undecided))))
-              ((eq aslot slot)
-               (setq found-slot t)
-               (setq return-list (append return-list (list result))))
-              (t (setq return-list
-                        (append return-list (list (get-current old-context aslot))))))
-        (go l1)))
-
-(defun get-context-depth (context)
-  (soarnth 10 context))
-
-(defun get-context-difficulty (context)
-  (soarnth 6 context))
-
-(defun get-context-pnumber (context)
-  (soarnth 4 context))
-
-(defun get-context-results (context)
-  (soarnth 7 context))
-
-(defun get-context-slot (context)
-  (soarnth 5 context))
-
-(defun get-context-subgoaled (context)
-  (soarnth 9 context))
-
-(defun get-context-super-operator (context)
-  (soarnth 8 context))
-
-(defun get-current (context slot)
-  (soarnth
-   (cdr (soarassq slot '((goal . 0) (problem-space . 1) (state . 2) (operator . 3))))
-   context))
-
-(defun init-context (problem-space state operator)
-  (prog (goal-name)
-        (init-soar)
-        (setq goal-name (soargensym 'g))
-        (setq *context*
-               (list goal-name
-                     problem-space
-                     state
-                     operator
-                     '0
-                     'nil
-                     'nil
-                     'nil
-                     'nil
-                     'nil
-                     '0))
-        (setq *context-stack* (list *context*))
-        (return goal-name)))
-
-(defun neq-result (difficulty result context slot)
-  (cond (difficulty
-         (or (neq difficulty (get-context-difficulty context))
-             (neq slot (get-context-slot context))
-             (not (test-results-subset result context))))
-        ((soarlistp result) (not (test-slot-subset result context)))
-        (t (neq result (get-current context slot)))))
-
-(defun process-a-parallel-operator (context-stack results prior-context)
-  (prog nil
-        (and (soarmemq (get-context-super-operator (car context-stack)) results)
-             (return (list context-stack)))
-        (process-sub-contexts context-stack prior-context prior-context)
-        (return nil)))
-
-(defun process-context (context context-stack)
-  (prog (context-preferences slot-preferences preferences slots slot ids results
-         difficulty pnumber current)
-        (setq context-preferences (find-goal-preferences context))
-        (remprop (car context) 'preferences)
-        (setq pnumber (length context-preferences))
-        (rplaca (soarnthcdr 4 context) pnumber)
-        (setq slots '(problem-space state operator))
-        (setq ids (cdr context))
-     l1 (setq current (pop ids))
-        (setq slot (pop slots))
-        (cond ((null slot)
-               (setq difficulty 'no-change)
-               (setq slot (find-no-change-slot context))
-               (setq current (get-current context slot))
-               (cond ((neq-result difficulty nil context slot)
-                      (rplaca context-stack
-                              (change-context difficulty current context slot
-                               context-stack nil))
-                      (return t))
-                     ((and (eq slot 'operator)
-                           (soarlistp current))
-                      (process-parallel-operators context context-stack)
-                      (return nil))
-                     (t (return nil)))))
-        (setq slot-preferences (find-all-assq slot context-preferences))
-        (setq preferences (soarmapcar #'(lambda (x) (car (reverse x))) slot-preferences))
-        (setq slot-preferences
-               (soarmapcar #'(lambda (x) (reverse (cdr (reverse x)))) slot-preferences))
-        (cond (*decide-trace* (soarprintc slot) (soarprinc " ") (print-id current)))
-        (setq results (decision-procedure slot-preferences current))
-        (setq difficulty (pop results))
-        (cond ((eq difficulty 'no-change) (go l1))
-              ((not difficulty) (setq results (process-results results current)))
-              ((eq difficulty 'parallel) (setq difficulty nil)))
-        (cond ((neq-result difficulty results context slot)
-               (and (broken2 results)
-                    (setq *remaining-decide* 0))
-               (rplaca context-stack
-                       (change-context difficulty results context slot context-stack
-                        preferences))
-               (return t))
-              (difficulty (return))
-              ((eq results 'undecided) (setq slots nil)))
-        (go l1)))
-
-(defun process-context-stack (context-stack)
-  (prog (context)
-        (setq context (car context-stack))
-        (cond ((null (cdr context-stack))
-               (process-context context context-stack)
-               (check-limits)
-               (return))
-              ((test-context context)
-               (cond ((process-context context context-stack) (check-limits) (return))))
-              (t (remprop (car context) 'preferences)))
-        (soarmapc #'(lambda (x) (process-context-stack x)) (cdr context-stack))))
-
-(defun process-parallel-operators (context context-stack)
-  (rplacd context-stack
-          (soarmapconc
-           #'(lambda (x)
-               (process-a-parallel-operator x (get-current context 'operator) context))
-           (cdr context-stack)))
-  (create-production))
-
-(defun process-sub-contexts (context-stack new-context prior-context)
-  (prog (old-context subgoaled)
-        (setq old-context (car context-stack))
-        (setq subgoaled nil)
-        (cond ((cdr context-stack)
-               (setq subgoaled
-                      (t-in-list?
-                       (soarmapcar
-                        #'(lambda (x) (process-sub-contexts x old-context old-context))
-                        (cdr context-stack))))))
-        (return (learn-back-trace old-context prior-context new-context subgoaled))))
-
-(defun push-context-stack (context)
-  (soarpush context *context-stack*)
-  (setq *context* context))
-
-(defun test-context (context)
-  (neq (length (find-goal-preferences context)) (get-context-pnumber context)))
-
-(defun test-if-subset (subset set)
-  (cond ((null subset) t)
-        ((atom set) nil)
-        ((soarmemq (car subset) set) (test-if-subset (cdr subset) set))
-        (t nil)))
-
-(defun test-results-subset (result context)
-  (cond (*impasse-subset-not-equal* (equal result (get-context-results context)))
-        ((test-if-subset result (get-context-results context))
-         (rplaca (soarnthcdr 7 context) result)
-         t)
-        (t nil)))
-
-(defun test-slot-subset (result context)
-  (cond ((test-if-subset result (get-current context 'operator))
-         (rplaca (soarnthcdr 3 context) result)
-         t)
-        (t nil)))
-
-(defun all-bound? (vlist)
-  (soar-do ((vl1 vlist (cdr vl1))) ((null vl1) t)
-   (cond ((not (bound-var? (car vl1))) (return nil)))))
-
-(defun bound-preference? (pr)
-  (all-bound? (get-context-vars-in-pref pr)))
-
-(defun bound-var? (v)
-  (get v 'bound))
-
-(defun check-negations (set-vars negations)
-  (soar-do ((neg negations (cddr neg)) (active) (unactive))
-   ((null neg) (cons active unactive))
-   (cond ((all-bound? (get-all-vars-in-neg (car neg)))
-          (soarpush '- active)
-          (soarpush (strip-condition (car neg)) active))
-         (t (soarpush '- unactive) (soarpush (car neg) unactive)))))
-
-(defun classify (set-vars dup-vars conditions flag)
-  (prog (attr-type attr-val val-type val-val temp c i mini result)
-        (setq mini 102)
-     l1 (setq c (pop conditions))
-        (cond ((null c) (return (rplnode *global-pair* mini (nreverse result))))
-              ((setq i (get-prev-rank c)) (cond (i (go l2))))
-              ((eq (get-condition-type c) 'preference)
-               (cond ((and (soarmemq 'role (cdr c))
-                           (eq 'operator (cadr (soarmemq 'role (cdr c)))))
-                      (setq i (+ 6 *default-multi*)))
-                     (t (setq i 3)))
-               (and flag
-                    (put-rank c i)))
-              (t (setq temp (get-attr-val-types c))
-                 (setq attr-type (caar temp))
-                 (setq val-type (cadr temp))
-                 (setq attr-val (cdar temp))
-                 (setq val-val (cddr temp))
-                 (cond ((and (eq attr-type 'var)
-                             (bound-var? attr-val))
-                        (setq attr-type 'set-var)))
-                 (cond ((and (eq val-type 'var)
-                             (bound-var? val-val))
-                        (setq val-type 'set-var)))
-                 (cond ((and (eq attr-type 'const)
-                             (eq val-type 'const))
-                        (setq i 1)
-                        (put-rank c 1))
-                       ((and (soarmemq attr-type '(const set-var))
-                             (soarmemq val-type '(const set-var)))
-                        (setq i 2)
-                        (and flag
-                             (put-rank c 2)))
-                       ((eq (get-condition-type c) 'goal-context-info)
-                        (cond ((eq (get-mult-num (get-condition-type c) attr-val) 1)
-                               (setq i 4))
-                              (t (setq i 5)))
-                        (put-rank c i))
-                       ((and (eq attr-type 'const)
-                             (eq val-type 'var)
-                             (soarmemq val-val dup-vars))
-                        (setq i (+ 6 (get-mult-num (get-condition-type c) attr-val))))
-                       ((and (soarmemq attr-type '(var set-var))
-                             (soarmemq attr-val dup-vars)
-                             (soarmemq val-type '(var set-var))
-                             (soarmemq val-val dup-vars))
-                        (setq i 100))
-                       (t (setq i 101) (put-rank c 101)))))
-     l2 (cond ((< i mini) (setq mini i) (setq result (list c)))
-              ((= i mini) (soarpush c result)))
-        (go l1)))
-
-(defun classify-match-elt (x)
-  (cond ((eq (car x) '<<) (rplnode *global-pair* (skip-disjunction x) '(other)))
-        ((predicatep (car x)) (rplnode *global-pair* (next-sym (next-sym x)) '(other)))
-        ((variablep (car x)) (rplnode *global-pair* (next-sym x) (cons 'var (car x))))
-        ((eq (car x) '//) (rplnode *global-pair* (next-sym x) (cons 'const (cadr x))))
-        (t (rplnode *global-pair* (next-sym x) (cons 'const (car x))))))
-
-(defun classify-term (x)
-  (prog (result)
-        (setq result '(other))
-        (cond ((eq (car x) '{)
-               (return (prog (next-elt)
-                             (setq x (cdr x))
-                        loop (cond ((eq (car x) '})
-                                    (return (rplnode *global-pair* (cdr x) result)))
-                                   (t (setq next-elt (pop-match-elt x))
-                                      (cond ((soarmemq (car next-elt) '(var const))
-                                             (setq result next-elt)))
-                                      (go loop))))))
-              (t (return (classify-match-elt x))))))
-
-(defun find-all-vars-in-condition (condition)
-  (soar-do ((c (cdddr condition)) (vars) (next-elt)) ((null c) vars)
-   (cond ((variablep (car c)) (soarpush (car c) vars) (setq c (next-sym c)))
-         ((eq (car c) '<<) (setq c (skip-disjunction c)))
-         (t (setq c (next-sym c))))))
-
-(defun find-best-condition (set-vars dup-vars active-conditions un-active-conditions ccl
-                            recurse-level minsofar)
-  (prog (ccl1 i c tie-conds minc minrank temp new-vars act-conds un-act-conds s-v best)
-        (setq i (car ccl))
-        (setq tie-conds (cdr ccl))
-        (cond ((> i 101) (return nil))
-              ((or (<= i 6)
-                   (= i 101)
-                   (and (null (cdr tie-conds))
-                        (or (not (= i 7))
-                            (= recurse-level 0)))
-                   (= recurse-level *max-recurse*))
-               (setq c (car tie-conds))
-               (return (cons (list i) c))))
-        (setq minrank '(102))
-        (cond ((and minsofar
-                    (or (> i (car minsofar))
-                        (and (= i (car minsofar))
-                             (cdr minsofar)
-                             (= 1 (cadr minsofar)))))
-               (return '((100)))))
-     l2 (setq c (pop tie-conds))
-        (and (null c)
-             (go l3))
-        (setq temp (get-attr-val-types c))
-        (cond ((eq (cadr temp) 'const) (setq new-vars (list (cdar temp))))
-              (t (setq new-vars (list (cddr temp)))))
-        (setq act-conds (remove c active-conditions))
-        (setq s-v (mark-as-set new-vars))
-        (setq temp (get-conditions-with-vars s-v un-active-conditions))
-        (setq act-conds (append (car temp) act-conds))
-        (setq un-act-conds (cdr temp))
-        (setq ccl1 (classify s-v dup-vars act-conds nil))
-        (setq best
-               (find-best-condition s-v dup-vars act-conds un-act-conds ccl1
-                (+ 1 recurse-level) (cdr minrank)))
-        (unmark-as-set s-v)
-        (cond ((or (and (equal (car best) minrank)
-                        (eq (get-id-var c) *last-value-var*))
-                   (lexless (car best) minrank))
-               (setq minrank (car best))
-               (setq minc c)))
-        (cond ((eq (car minrank) 1) (go l3)))
-        (go l2)
-     l3 (return (cons (cons i minrank) minc))))
-
-(defun find-info-on-cond (c flag)
-  (prog (label attr val id vars next-term prefvars)
-        (setq attr '(const))
-        (setq val '(const))
-        (setq c (cdr c))
-     l1 (setq c (cdr c))
-        (cond ((null c)
-               (cond (flag (return (list id vars prefvars nil)))
-                     (t (return (list id vars (cons attr val) nil))))))
-        (setq label (pop c))
-        (setq next-term (pop-term c))
-        (cond ((eq (car next-term) 'var) (soarpush (cdr next-term) vars)))
-        (cond ((and flag
-                    (soarmemq label '(goal problem-space state operator))
-                    (eq (car next-term) 'var)
-                    (soarpush (cdr next-term) prefvars))))
-        (cond ((eq label 'identifier)
-               (cond ((eq (car next-term) 'const)
-                      (soarwarn "Constant identifier field in:  " c)
-                      (setq id 'const))
-                     ((eq (car next-term) 'other)
-                      (soarwarn "Identifier field not constant or variable in:  " c)
-                      (setq id nil))
-                     (t (setq id (cdr next-term)))))
-              ((eq label 'object)
-               (cond ((eq (car next-term) 'const)
-                      (soarwarn "Constant object field in:  " c)
-                      (setq id 'const))
-                     ((eq (car next-term) 'other)
-                      (soarwarn "Object field not constant or variable in:  " c)
-                      (setq id nil))
-                     (t (setq id (cdr next-term)))))
-              ((eq label 'attribute) (setq attr next-term))
-              ((eq label 'value) (setq val next-term)))
-        (go l1)))
-
-(defun find-pred-vars-in-condition (c)
-  (soar-do ((type) (varlist)) ((null c) varlist)
-   (cond ((predicatep (car c))
-          (setq c (next-sym c))
-          (setq type (pop-match-elt c))
-          (cond ((eq (car type) 'var) (setq varlist (cons (cdr type) varlist)))))
-         ((eq (car c) '<<) (setq c (skip-disjunction c)))
-         (t (setq c (next-sym c))))))
-
-(defun get-all-vars-in-neg (neg)
-  (car neg))
-
-(defun get-attr-val-types (x)
-  (cadr (cddar x)))
-
-(defun get-condition-type (c)
-  (cadr c))
-
-(defun get-conditions-with-vars (vars cl)
-  (cond ((null vars) nil)
-        (t (soar-do ((cl1 cl (cdr cl1)) (result-with) (result-wo) (id))
-            ((null cl1) (cons (nreverse result-with) (nreverse result-wo)))
-            (setq id (get-id-var (car cl1)))
-            (cond ((and (or (and (not (eq (get-condition-type (car cl1)) 'preference))
-                                 (bound-var? id))
-                            (eq id 'const)
-                            (and (eq (get-condition-type (car cl1)) 'preference)
-                                 (bound-preference? (car cl1))))
-                        (no-unbound-predicates? vars (car cl1)))
-                   (soarpush (car cl1) result-with))
-                  (t (soarpush (car cl1) result-wo)))))))
-
-(defun get-context-vars-in-pref (pr)
-  (cadr (cddar pr)))
-
-(defun get-id-var (c)
-  (cadr (car c)))
-
-(defun get-mult-num (type attr)
-  (soar-do ((l *multi-attribute* (cdr l))) ((null l) 1)
-   (cond ((and (eq (caar l) type)
-               (eq (cadar l) attr))
-          (cond ((car (cddar l)) (return (car (cddar l)))) (t (return *default-multi*)))))))
-
-(defun get-pred-vars-in-condition (c)
-  (car (car c)))
-
-(defun get-prev-rank (c)
-  (car (cddddr (car c))))
-
-(defun get-twice-used-vars (cl)
-  (prog (varlist dup-vars)
-        (soar-do ((cl1 cl (cdr cl1))) ((null cl1))
-         (setq varlist
-                (append (get-pred-vars-in-condition (car cl1))
-                        (append (get-vars-in-condition (car cl1)) varlist))))
-        (soar-do ((vl varlist (cdr vl))) ((null vl))
-         (cond ((and (soarmemq (car vl) (cdr vl))
-                     (not (soarmemq (car vl) dup-vars)))
-                (soarpush (car vl) dup-vars))))
-        (return dup-vars)))
-
-(defun get-vars-in-condition (c)
-  (caddr (car c)))
-
-(defun insert-ne-undec (c2 dup-vars)
-  (prog (undecflag braceflag c1 var label c x)
-        (setq c c2)
-        (setq c (cdr c))
-     l1 (cond ((null c) (return c2)))
-        (setq undecflag nil)
-        (setq braceflag nil)
-        (setq var nil)
-        (pop c)
-        (setq label (pop c))
-        (cond ((and (eq label 'attribute)
-                    (not (soarmemq (car c) '(problem-space state operator))))
-               (return c2)))
-        (setq c1 c)
-     l2 (setq x (car c))
-        (cond ((eq x '{) (setq braceflag t) (pop c))
-              ((and (eq x '<>)
-                    (eq (cadr c) 'undecided))
-               (setq undecflag t)
-               (pop c)
-               (pop c))
-              ((and (not undecflag)
-                    (not (eq label 'identifier))
-                    (not (eq label 'object))
-                    (variablep x)
-                    (not (soarmemq x dup-vars)))
-               (setq var x)
-               (pop c))
-              ((eq x '}) (go l3))
-              (t (pop-match-elt c)))
-        (cond (braceflag (go l2)))
-     l3 (cond ((and var
-                    (not undecflag))
-               (cond (braceflag (rplacd c1 (append '(<> undecided) (cdr c1))))
-                     (t (rplacd c1 (append '(<> undecided) (cons x (cons '} (cdr c1)))))
-                        (rplaca c1 '{)))))
-        (go l1)))
-
-(defun lexless (a b)
-  (soar-do ((a1 a (cdr a1)) (b1 b (cdr b1))) ((null a1) t)
-   (cond ((null a1) (return t))
-         ((null b1) (return nil))
-         ((< (car a1) (car b1)) (return t))
-         ((< (car b1) (car a1)) (return nil)))))
-
-(defun mark-as-set (vlist)
-  (cond ((or (null vlist)
-             (equal vlist '(nil)))
-         nil)
-        (t (soar-do
-            ((vl1 (cond ((atom vlist) (list vlist)) (t vlist)) (cdr vl1)) (result))
-            ((null vl1) result)
-            (cond ((and (atom (car vl1))
-                        (not (get (car vl1) 'bound)))
-                   (soarputprop (car vl1) t 'bound)
-                   (soarpush (car vl1) result)))))))
-
-(defun next-sym (x)
-  (cond ((eq (car x) '//) (cddr x)) (t (cdr x))))
-
-(defun no-unbound-predicates? (vars c)
-  (all-bound? (get-pred-vars-in-condition c)))
-
-(defun predicatep (x)
-  (and (symbolp x)
-       (get x 'predicate)))
-
-(defun put-rank (c n)
-  (rplaca (cddddr (car c)) n))
-
-(defun re-order-conditions (cl)
-  (prog (un-active-conditions new-conditions set-vars dup ccl best active-conditions
-         negations temp already-no-active-conditions)
-        (cond ((null cl) (return nil)))
-        (setq cl (sort-conditions cl))
-        (setq *last-value-var* nil)
-        (setq negations (cadr cl))
-        (setq cl (car cl))
-        (setq dup (get-twice-used-vars cl))
-        (setq un-active-conditions cl)
-        (setq active-conditions nil)
-        (go l4)
-     l0 (cond ((null un-active-conditions)
-               (cond (negations
-                      (soar-do nil ((null negations)) (soarpush '- new-conditions)
-                       (soarpush (strip-condition (car negations)) new-conditions)
-                       (setq negations (cddr negations)))))
-               (unmark-as-set set-vars)
-               (setq *condition-vars* set-vars)
-               (return (nreverse new-conditions)))
-              ((or already-no-active-conditions
-                   (neq 'goal-context-info
-                        (get-condition-type (car un-active-conditions))))
-               (soarpush (strip-condition (car un-active-conditions)) new-conditions)
-               (setq un-active-conditions (cdr un-active-conditions))
-               (setq already-no-active-conditions nil)
-               (cond ((neq (class (car new-conditions)) 'preference)
-                      (soarwarn " Condition not linked to previous conditions "
-                       (car (p-to-sp (list (car new-conditions)))))))
-               (go l0)))
-     l4 (setq already-no-active-conditions t)
-        (setq set-vars
-               (append (mark-as-set (get-id-var (car un-active-conditions))) set-vars))
-     l3 (setq temp (get-conditions-with-vars set-vars un-active-conditions))
-        (setq active-conditions (append (car temp) active-conditions))
-        (setq un-active-conditions (cdr temp))
-     l1 (cond ((null active-conditions) (go l0)))
-        (setq ccl (classify set-vars dup active-conditions t))
-        (setq best
-               (find-best-condition set-vars dup active-conditions un-active-conditions
-                ccl 0 nil))
-        (setq already-no-active-conditions nil)
-        (cond ((null best) (go l0)))
-        (cond (*order-trace*
-               (progn (soarprint (cons (car best) (strip-condition (cdr best)))))))
-        (setq best (cdr best))
-        (setq active-conditions (dremove best active-conditions))
-     l2 (setq set-vars (append (mark-as-set (get-vars-in-condition best)) set-vars))
-        (setq temp (get-attr-val-types best))
-        (cond ((eq (cadr temp) 'var) (setq *last-value-var* (cddr temp)))
-              (t (setq *last-value-var* nil)))
-        (setq temp (strip-condition best))
-        (cond ((eq (get-condition-type best) 'goal-context-info)
-               (insert-ne-undec temp dup)))
-        (soarpush temp new-conditions)
-        (setq temp (check-negations set-vars negations))
-        (setq new-conditions (append (car temp) new-conditions))
-        (setq negations (cdr temp))
-        (go l3)))
-
-(defun reorder-p-conds (spxs)
-  (prog (type conds action)
-        (pop spxs)
-        (setq *p-name* (pop spxs))
-        (setq type
-               (cond ((or (eq (car spxs) 'elaborate-once)
-                          (eq (car spxs) 'elaborate)
-                          (eq (car spxs) 'decide))
-                      (pop spxs))
-                     (t 'elaborate)))
-        (setq conds nil)
-condloop (soarpush (pop spxs) conds)
-        (cond ((and spxs
-                    (neq (car spxs) '-->))
-               (go condloop)))
-        (setq action spxs)
-        (setq spxs (append (re-order-conditions (nreverse conds)) spxs))
-        (test-connected-actions action)
-        (soarpush type spxs)
-        (soarpush *p-name* spxs)
-        (soarpush 'p spxs)
-        (return spxs)))
-
-(defun skip-disjunction (x)
-  (soar-do nil ((eq (car x) '>>) (cdr x)) (setq x (next-sym x))))
-
-(defun sort-conditions (cl)
-  (prog (regulars c negations goal-contexts)
-        (setq negations nil)
-        (setq regulars nil)
-        (setq goal-contexts nil)
-     l1 (setq c (pop cl))
-        (cond ((null c)
-               (return (list (append (nreverse goal-contexts) (nreverse regulars))
-                             (nreverse negations))))
-              ((eq c '-)
-               (setq c (pop cl))
-               (soarpush (cons (find-all-vars-in-condition c) c) negations)
-               (unmark-as-set (get-all-vars-in-neg (car negations)))
-               (soarpush '- negations))
-              ((eq (car c) 'preference)
-               (soarpush
-                (cons (cons (find-pred-vars-in-condition c)
-                            (find-info-on-cond c 'preference))
-                      c)
-                regulars)
-               (unmark-as-set (get-pred-vars-in-condition (car regulars)))
-               (unmark-as-set (get-vars-in-condition (car regulars))))
-              ((eq (car c) 'goal-context-info)
-               (soarpush
-                (cons (cons (find-pred-vars-in-condition c) (find-info-on-cond c nil)) c)
-                goal-contexts)
-               (unmark-as-set (get-pred-vars-in-condition (car goal-contexts)))
-               (unmark-as-set (get-vars-in-condition (car goal-contexts))))
-              (t (soarpush
-                  (cons (cons (find-pred-vars-in-condition c) (find-info-on-cond c nil))
-                        c)
-                  regulars)
-                 (unmark-as-set (get-pred-vars-in-condition (car regulars)))
-                 (unmark-as-set (get-vars-in-condition (car regulars)))))
-        (go l1)))
-
-(defun strip-condition (x)
-  (cond ((atom x) x) (t (cdr x))))
-
-(defun unmark-as-set (vlist)
-  (soar-do ((vl1 (cond ((atom vlist) (list vlist)) (t vlist)) (cdr vl1)))
-   ((null vl1) vlist) (remprop (car vl1) 'bound)))
-
-(start-soar)
-(terpri)
diff --git a/clx/CHANGES b/clx/CHANGES
deleted file mode 100644
index 36bbe0da86c9ddb45e40b56921784cc9af3bf79e..0000000000000000000000000000000000000000
--- a/clx/CHANGES
+++ /dev/null
@@ -1,40 +0,0 @@
-Details of changes since R5:
-
-Changes in CLX 5.01:
-
-Support for MIT-MAGIC-COOKIE-1 authorization has been added.
-
-All VALUES declarations have been changed to CLX-VALUES declarations.
-VALUES is a CL type name and cannot be used as a declaration name.
-
-All ARRAY-REGISTER declarations have been removed as Genera no longer
-needs them.
-
-Many type declarations have been corrected or tightened up now that some
-Lisps look at them.
-
-Print functions have been defined for bitmap and pixmap formats.
-
-The DISPLAY-PLIST slot will be initialized to NIL.
-
-When debugging, don't optimize SPEED in the buffer macros.
-
-Make the CARD8<->CHAR and the window manager code work for sparse
-character sets (where some codes do not have corresponding characters).
-
-The default gcontext extension set and copy functions will take the
-correct number of arguments.
-
-PUT-IMAGE will now work for 24-bit images.
-
-The buffer accessors for MEMBER8, etc., will use the standard mechanisms
-for reporting type errors.
-
-Typographical errors in SET-WM-PROPERTIES, SET-STANDARD-COLORMAP, and
-POINTER-CONTROL have been fixed.
-
-Symbolics systems will do lazy macroexpansion in the buffer macros.
-
-A variety of changes for Symbolics Minima systems have been made.
-
-Some system-dependent code has been added for CMU Common Lisp.
diff --git a/clx/README b/clx/README
deleted file mode 100644
index 7f4aa19a846d3cae78674fa500b47193543f1893..0000000000000000000000000000000000000000
--- a/clx/README
+++ /dev/null
@@ -1,48 +0,0 @@
-These files contain beta code, but they have been tested to some extent under
-Symbolics, TI, Lucid and Franz.  The files have been given .l suffixes to keep
-them within 12 characters, to keep SysV sites happy.  Please rename them with
-more appropriate suffixes for your system.
-
-
-For Franz systems, see exclREADME.
-
-
-For Symbolics systems, first rename all the .l files to .lisp.  Then edit your
-sys.translations file so that sys:x11;clx; points to this directory and put a
-clx.system file in your sys:site;directory that has the form
-
-    (si:set-system-source-file "clx" "sys:x11;clx;defsystem.lisp")
-
-in it.   After that CLX can be compiled with the "Compile System CLX" command
-and loaded with the "Load System CLX" command.
-
-
-
-For TI systems, rename all the .l files to .lisp, and make a clx.translations
-file in your sys:site; directory pointing to this directory and a
-sys:site;clx.system file like the one described for symbolics systems above,
-but with the defsystem file being in the clx:clx; directory.  Then CLX can be
-compiled with (make-system "CLX" :compile :noconfirm) and loaded with
-(make-system "CLX" :noconfirm).
-
-
-
-For Lucid systems, you should rename all the .l files to .lisp too (This might
-not be possible on SysV systems).  After loading the defsystem.l file, CLX can
-be compiled with the (compile-clx) function and loaded with the
-(load-clx) form.  
-
-The ms-patch.uu file is a patch to Lucid version 2 systems.  You probably
-don't need it, as you are probably running Lucid version 3 or later, but if
-you are still using Lucid version 2, you need this patch.  You'll need to
-uudecode it to produce the binary.
-
-
-
-For kcl systems, after loading the defsystem.l file, CLX can be compiled with
-the (compile-clx) function and loaded with the (load-clx) form.
-
-
-
-For more information, see defsystem.l and provide.l.
-
diff --git a/clx/attributes.lisp b/clx/attributes.lisp
deleted file mode 100644
index 5eb1035d63a5bc1e2a5d330b8fdbe4e1ea4a5f73..0000000000000000000000000000000000000000
--- a/clx/attributes.lisp
+++ /dev/null
@@ -1,638 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;; Window Attributes
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-;;;	The special variable *window-attributes* is an alist containg:
-;;;	(drawable attributes attribute-changes geometry geometry-changes)
-;;;	Where DRAWABLE is the associated window or pixmap
-;;;	      ATTRIBUTES is NIL or a reply-buffer containing the drawable's
-;;;		         attributes for use by the accessors.
-;;;	      ATTRIBUTE-CHANGES is NIL or an array.  The first element
-;;;			 of the array is a "value-mask", indicating which
-;;;			 attributes have changed.  The other elements are
-;;;			 integers associated with the changed values, ready
-;;;			 for insertion into a server request.
-;;;	      GEOMETRY is like ATTRIBUTES, but for window geometry
-;;;	      GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry
-;;;
-;;;	Attribute and Geometry accessors and SETF's look on the special variable
-;;;	*window-attributes* for the drawable.  If its not there, the accessor is
-;;;     NOT within a WITH-STATE, and a server request is made to get or put a value.
-;;;     If an entry is found in *window-attributes*, the cache buffers are used
-;;;	for the access.
-;;;
-;;;	All WITH-STATE has to do (re)bind *Window-attributes* to a list including
-;;;	the new drawable.  The caches are initialized to NIL and allocated as needed.
-
-(in-package :xlib)
-
-(eval-when (compile load eval)			;needed by Franz Lisp
-(defconstant *attribute-size* 44)
-(defconstant *geometry-size* 24)
-(defconstant *context-size* (max *attribute-size* *geometry-size* (* 16 4))))
-
-(defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE
-
-;; Window Attribute reply buffer resource
-(defvar *context-free-list* nil) ;; resource of free reply buffers
-
-(defun allocate-context ()
-  (or (threaded-atomic-pop *context-free-list* reply-next reply-buffer)
-      (make-reply-buffer *context-size*)))
-
-(defun deallocate-context (context)
-  (declare (type reply-buffer context))
-  (threaded-atomic-push context *context-free-list* reply-next reply-buffer))
-
-(defmacro state-attributes (state) `(second ,state))
-(defmacro state-attribute-changes (state) `(third ,state))
-(defmacro state-geometry (state) `(fourth ,state))
-(defmacro state-geometry-changes (state) `(fifth ,state))
- 
-(defmacro drawable-equal-function ()
-  (if (member 'drawable *clx-cached-types*)
-      ''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's
-    ''drawable-equal))
-
-(defmacro window-equal-function ()
-  (if (member 'window *clx-cached-types*)
-      ''eq
-    ''drawable-equal))
-
-(defmacro with-state ((drawable) &body body)
-  ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
-  ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and
-  ;; ConfigureWindow.  The body is not surrounded by a with-display.  Within the
-  ;; indefinite scope of the body, on a per-process basis in a multi-process
-  ;; environment, the first call within an Accessor Group on the specified drawable
-  ;; (the object, not just the variable) causes the complete results of the protocol
-  ;; request to be retained, and returned in any subsequent accessor calls.  Calls
-  ;; within a Setf Group are delayed, and executed in a single request on exit from
-  ;; the body.  In addition, if a call on a function within an Accessor Group follows
-  ;; a call on a function in the corresponding Setf Group, then all delayed setfs for
-  ;; that group are executed, any retained accessor information for that group is
-  ;; discarded, the corresponding protocol request is (re)issued, and the results are
-  ;; (again) retained, and returned in any subsequent accessor calls.
-
-  ;; Accessor Group A (for GetWindowAttributes):
-  ;; window-visual, window-visual-info, window-class, window-gravity, window-bit-gravity,
-  ;; window-backing-store, window-backing-planes, window-backing-pixel,
-  ;; window-save-under, window-colormap, window-colormap-installed-p,
-  ;; window-map-state, window-all-event-masks, window-event-mask,
-  ;; window-do-not-propagate-mask, window-override-redirect
-
-  ;; Setf Group A (for ChangeWindowAttributes):
-  ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes,
-  ;; window-backing-pixel, window-save-under, window-event-mask,
-  ;; window-do-not-propagate-mask, window-override-redirect, window-colormap,
-  ;; window-cursor
-
-  ;; Accessor Group G (for GetGeometry):
-  ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width,
-  ;; drawable-height, drawable-border-width
-
-  ;; Setf Group G (for ConfigureWindow):
-  ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width,
-  ;; window-priority
-  (let ((state-entry (gensym)))
-     ;; alist of (drawable attributes attribute-changes geometry geometry-changes)
-    `(with-stack-list (,state-entry ,drawable nil nil nil nil)
-       (with-stack-list* (*window-attributes* ,state-entry *window-attributes*)
-	 (multiple-value-prog1
-	   (progn ,@body)
-	   (cleanup-state-entry ,state-entry))))))
-
-(defun cleanup-state-entry (state)
-  ;; Return buffers to the free-list
-  (let ((entry (state-attributes state)))
-    (when entry (deallocate-context entry)))
-  (let ((entry (state-attribute-changes state)))
-    (when entry
-      (put-window-attribute-changes (car state) entry)
-      (deallocate-gcontext-state entry)))
-  (let ((entry (state-geometry state)))
-    (when entry (deallocate-context entry)))
-  (let ((entry (state-geometry-changes state)))
-    (when entry
-      (put-drawable-geometry-changes (car state) entry)
-      (deallocate-gcontext-state entry))))
-
-
-
-(defun change-window-attribute (window number value)
-  ;; Called from window attribute SETF's to alter an attribute value
-  ;; number is the change-attributes request mask bit number
-  (declare (type window window)
-	   (type card8 number)
-	   (type card32 value))
-  (let ((state-entry nil)
-	(changes nil))
-    (if (and *window-attributes*
-	     (setq state-entry (assoc window (the list *window-attributes*)
-				      :test (window-equal-function))))
-	(progn					; Within a WITH-STATE - cache changes
-	  (setq changes (state-attribute-changes state-entry))
-	  (unless changes
-	    (setq changes (allocate-gcontext-state))
-	    (setf (state-attribute-changes state-entry) changes)
-	    (setf (aref changes 0) 0)) ;; Initialize mask to zero
-	  (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
-	  (setf (aref changes (1+ number)) value))	;; save value
-						; Send change to the server
-      (with-buffer-request ((window-display window) *x-changewindowattributes*)
-	(window window)
-	(card32 (ash 1 number) value)))))
-;;
-;; These two are twins (change-window-attribute change-drawable-geometry)
-;; If you change one, you probably need to change the other...
-;;
-(defun change-drawable-geometry (drawable number value)
-  ;; Called from drawable geometry SETF's to alter an attribute value
-  ;; number is the change-attributes request mask bit number
-  (declare (type drawable drawable)
-	   (type card8 number)
-	   (type card29 value))
-  (let ((state-entry nil)
-	(changes nil))
-    (if (and *window-attributes*
-	     (setq state-entry (assoc drawable (the list *window-attributes*)
-				      :test (drawable-equal-function))))
-	(progn					; Within a WITH-STATE - cache changes
-	  (setq changes (state-geometry-changes state-entry))
-	  (unless changes
-	    (setq changes (allocate-gcontext-state))
-	    (setf (state-geometry-changes state-entry) changes)
-	    (setf (aref changes 0) 0)) ;; Initialize mask to zero
-	  (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
-	  (setf (aref changes (1+ number)) value))	;; save value
-						; Send change to the server
-      (with-buffer-request ((drawable-display drawable) *x-configurewindow*)
-	(drawable drawable)
-	(card16 (ash 1 number))
-	(card29 value)))))
-
-(defun get-window-attributes-buffer (window)
-  (declare (type window window))
-  (let ((state-entry nil)
-	(changes nil))
-    (or (and *window-attributes*
-	     (setq state-entry (assoc window (the list *window-attributes*)
-				      :test (window-equal-function)))
-	     (null (setq changes (state-attribute-changes state-entry)))
-	     (state-attributes state-entry))
-	(let ((display (window-display window)))
-	  (with-display (display)
-	    ;; When SETF's have been done, flush changes to the server
-	    (when changes
-	      (put-window-attribute-changes window changes)
-	      (deallocate-gcontext-state (state-attribute-changes state-entry))
-	      (setf (state-attribute-changes state-entry) nil))
-	    ;; Get window attributes
-	    (with-buffer-request-and-reply (display *x-getwindowattributes* size :sizes (8))
-		 ((window window))
-	      (let ((repbuf (or (state-attributes state-entry) (allocate-context))))
-		(declare (type reply-buffer repbuf))
-		;; Copy into repbuf from reply buffer
-		(buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size)
-		(when state-entry (setf (state-attributes state-entry) repbuf))
-		repbuf)))))))
-
-;;
-;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer)
-;; If you change one, you probably need to change the other...
-;;
-(defun get-drawable-geometry-buffer (drawable)
-  (declare (type drawable drawable))
-  (let ((state-entry nil)
-	(changes nil))
-    (or (and *window-attributes*
-	     (setq state-entry (assoc drawable (the list *window-attributes*)
-				      :test (drawable-equal-function)))
-	     (null (setq changes (state-geometry-changes state-entry)))
-	     (state-geometry state-entry))
-	(let ((display (drawable-display drawable)))
-	  (with-display (display)
-	    ;; When SETF's have been done, flush changes to the server
-	    (when changes
-	      (put-drawable-geometry-changes drawable changes)
-	      (deallocate-gcontext-state (state-geometry-changes state-entry))
-	      (setf (state-geometry-changes state-entry) nil))
-	    ;; Get drawable attributes
-	    (with-buffer-request-and-reply (display *x-getgeometry* size :sizes (8))
-		 ((drawable drawable))
-	      (let ((repbuf (or (state-geometry state-entry) (allocate-context))))
-		(declare (type reply-buffer repbuf))
-		;; Copy into repbuf from reply buffer
-		(buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size)
-		(when state-entry (setf (state-geometry state-entry) repbuf))
-		repbuf)))))))
-
-(defun put-window-attribute-changes (window changes)
-  ;; change window attributes
-  ;; Always from Called within a WITH-DISPLAY
-  (declare (type window window)
-	   (type gcontext-state changes))
-  (let* ((display (window-display window))
-	 (mask (aref changes 0)))
-    (declare (type display display)
-	     (type mask32 mask))
-    (with-buffer-request (display *x-changewindowattributes*)
-      (window window)
-      (card32 mask)
-      (progn ;; Insert a word in the request for each one bit in the mask
-	(do ((bits mask (ash bits -1))
-	     (request-size 2)			;Word count
-	     (i 1 (index+ i 1)))		;Entry count
-	    ((zerop bits)
-	     (card16-put 2 (index-incf request-size))
-	     (index-incf (buffer-boffset display) (index* request-size 4)))
-	  (declare (type mask32 bits)
-		   (type array-index i request-size))
-	  (when (oddp bits)
-	    (card32-put (index* (index-incf request-size) 4) (aref changes i))))))))
-;;
-;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes)
-;; If you change one, you probably need to change the other...
-;;
-(defun put-drawable-geometry-changes (window changes)
-  ;; change window attributes or geometry (depending on request-number...)
-  ;; Always from Called within a WITH-DISPLAY
-  (declare (type window window)
-	   (type gcontext-state changes))
-  (let* ((display (window-display window))
-	 (mask (aref changes 0)))
-    (declare (type display display)
-	     (type mask16 mask))
-    (with-buffer-request (display *x-configurewindow*)
-      (window window)
-      (card16 mask)
-      (progn ;; Insert a word in the request for each one bit in the mask
-	(do ((bits mask (ash bits -1))
-	     (request-size 2)			;Word count
-	     (i 1 (index+ i 1)))		;Entry count
-	    ((zerop bits)
-	     (card16-put 2 (incf request-size))
-	     (index-incf (buffer-boffset display) (* request-size 4)))
-	  (declare (type mask16 bits)
-		   (type fixnum request-size)
-		   (type array-index i))
-	  (when (oddp bits)
-	    (card29-put (* (incf request-size) 4) (aref changes i))))))))
-
-(defmacro with-attributes ((window &rest options) &body body)
-  `(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window)))
-     (declare (type reply-buffer .with-attributes-reply-buffer.))
-     (prog1 
-       (with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body)
-       (unless *window-attributes*
-	 (deallocate-context .with-attributes-reply-buffer.)))))
-;;
-;; These two are twins (with-attributes with-geometry)
-;; If you change one, you probably need to change the other...
-;;
-(defmacro with-geometry ((window &rest options) &body body)
-  `(let ((.with-geometry-reply-buffer. (get-drawable-geometry-buffer ,window)))
-     (declare (type reply-buffer .with-geometry-reply-buffer.))
-     (prog1 
-       (with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body)
-       (unless *window-attributes*
-	 (deallocate-context .with-geometry-reply-buffer.)))))
-
-;;;-----------------------------------------------------------------------------
-;;; Group A: (for GetWindowAttributes)
-;;;-----------------------------------------------------------------------------
-
-(defun window-visual (window)
-  (declare (type window window))
-  (declare (clx-values resource-id))
-  (with-attributes (window :sizes 32)
-    (resource-id-get 8)))
-
-(defun window-visual-info (window)
-  (declare (type window window))
-  (declare (clx-values visual-info))
-  (with-attributes (window :sizes 32)
-    (visual-info (window-display window) (resource-id-get 8))))
-
-(defun window-class (window)
-  (declare (type window window))
-  (declare (clx-values (member :input-output :input-only)))
-  (with-attributes (window :sizes 16)
-    (member16-get 12 :copy :input-output :input-only)))
-
-(defun set-window-background (window background)
-  (declare (type window window)
-	   (type (or (member :none :parent-relative) pixel pixmap) background))
-  (cond ((eq background :none) (change-window-attribute window 0 0))
-	((eq background :parent-relative) (change-window-attribute window 0 1))
-	((integerp background) ;; Background pixel
-	 (change-window-attribute window 0 0) ;; pixmap :NONE
-	 (change-window-attribute window 1 background))
-	((type? background 'pixmap) ;; Background pixmap
-	 (change-window-attribute window 0 (pixmap-id background)))
-	(t (x-type-error background '(or (member :none :parent-relative) integer pixmap))))
-  background)
-
-#+Genera (eval-when (compile) (compiler:function-defined 'window-background))
-
-(defsetf window-background set-window-background)
-
-(defun set-window-border (window border)
-  (declare (type window window)
-	   (type (or (member :copy) pixel pixmap) border))
-  (cond ((eq border :copy) (change-window-attribute window 2 0))
-	((type? border 'pixmap) ;; Border pixmap
-	 (change-window-attribute window 2 (pixmap-id border)))
-	((integerp border) ;; Border pixel
-	 (change-window-attribute window 3 border))
-	(t (x-type-error border '(or (member :copy) integer pixmap))))
-  border)
-
-#+Genera (eval-when (compile) (compiler:function-defined 'window-border))
-
-(defsetf window-border set-window-border)
-
-(defun window-bit-gravity (window)
-  ;; setf'able
-  (declare (type window window))
-  (declare (clx-values bit-gravity))
-  (with-attributes (window :sizes 8)
-    (member8-vector-get 14 *bit-gravity-vector*)))
-
-(defun set-window-bit-gravity (window gravity)
-  (change-window-attribute
-    window 4 (encode-type (member-vector *bit-gravity-vector*) gravity))
-  gravity)
-
-(defsetf window-bit-gravity set-window-bit-gravity)
-
-(defun window-gravity (window)
-  ;; setf'able
-  (declare (type window window))
-  (declare (clx-values win-gravity))
-  (with-attributes (window :sizes 8)
-    (member8-vector-get 15 *win-gravity-vector*)))
-
-(defun set-window-gravity (window gravity)
-  (change-window-attribute
-    window 5 (encode-type (member-vector *win-gravity-vector*) gravity))
-  gravity)
-
-(defsetf window-gravity set-window-gravity)
-
-(defun window-backing-store (window)
-  ;; setf'able
-  (declare (type window window))
-  (declare (clx-values (member :not-useful :when-mapped :always)))
-  (with-attributes (window :sizes 8)
-    (member8-get 1 :not-useful :when-mapped :always)))
-
-(defun set-window-backing-store (window when)
-  (change-window-attribute
-    window 6 (encode-type (member :not-useful :when-mapped :always) when))
-  when)
-
-(defsetf window-backing-store set-window-backing-store)
-
-(defun window-backing-planes (window)
-  ;; setf'able
-  (declare (type window window))
-  (declare (clx-values pixel))
-  (with-attributes (window :sizes 32)
-    (card32-get 16)))
-
-(defun set-window-backing-planes (window planes)
-  (change-window-attribute window 7 (encode-type card32 planes))
-  planes)
-
-(defsetf window-backing-planes set-window-backing-planes)
-
-(defun window-backing-pixel (window)
-  ;; setf'able
-  (declare (type window window))
-  (declare (clx-values pixel))
-  (with-attributes (window :sizes 32)
-    (card32-get 20)))
-
-(defun set-window-backing-pixel (window pixel)
-  (change-window-attribute window 8 (encode-type card32 pixel))
-  pixel)
-
-(defsetf window-backing-pixel set-window-backing-pixel)
-
-(defun window-save-under (window)
-  ;; setf'able
-  (declare (type window window))
-  (declare (clx-values (member :off :on)))
-  (with-attributes (window :sizes 8)
-    (member8-get 24 :off :on)))
-
-(defun set-window-save-under (window when)
-  (change-window-attribute window 10 (encode-type (member :off :on) when))
-  when)
-
-(defsetf window-save-under set-window-save-under)
-
-(defun window-override-redirect (window)
-  ;; setf'able
-  (declare (type window window))
-  (declare (clx-values (member :off :on)))
-  (with-attributes (window :sizes 8)
-    (member8-get 27 :off :on)))
-
-(defun set-window-override-redirect (window when)
-  (change-window-attribute window 9 (encode-type (member :off :on) when))
-  when)
-
-(defsetf window-override-redirect set-window-override-redirect)
-
-(defun window-event-mask (window)
-  ;; setf'able
-  (declare (type window window))
-  (declare (clx-values mask32))
-  (with-attributes (window :sizes 32)
-    (card32-get 36)))
-
-(defsetf window-event-mask (window) (event-mask)
-  (let ((em (gensym)))
-    `(let ((,em ,event-mask))
-       (declare (type event-mask ,em))
-       (change-window-attribute ,window 11 (encode-event-mask ,em))
-       ,em)))
-
-(defun window-do-not-propagate-mask (window)
-  ;; setf'able
-  (declare (type window window))
-  (declare (clx-values mask32))
-  (with-attributes (window :sizes 32)
-    (card32-get 40)))
-
-(defsetf window-do-not-propagate-mask (window) (device-event-mask)
-  (let ((em (gensym)))
-    `(let ((,em ,device-event-mask))
-       (declare (type device-event-mask ,em))
-       (change-window-attribute ,window 12 (encode-device-event-mask ,em))
-       ,em)))
-
-(defun window-colormap (window)
-  (declare (type window window))
-  (declare (clx-values (or null colormap)))
-  (with-attributes (window :sizes 32)
-    (let ((id (resource-id-get 28)))
-      (if (zerop id) nil
-	(lookup-colormap (window-display window) id)))))
-
-(defun set-window-colormap (window colormap)
-  (change-window-attribute
-    window 13 (encode-type (or (member :copy) colormap) colormap))
-  colormap)
-
-(defsetf window-colormap set-window-colormap)
-
-(defun window-cursor (window)
-  (declare (type window window))
-  (declare (clx-values cursor))
-  window
-  (error "~S can only be set" 'window-cursor))
-
-(defun set-window-cursor (window cursor)
-  (change-window-attribute
-    window 14 (encode-type (or (member :none) cursor) cursor))
-  cursor)
-
-(defsetf window-cursor set-window-cursor)
-
-(defun window-colormap-installed-p (window)
-  (declare (type window window))
-  (declare (clx-values boolean))
-  (with-attributes (window :sizes 8)
-    (boolean-get 25)))
-
-(defun window-all-event-masks (window)
-  (declare (type window window))
-  (declare (clx-values mask32))
-  (with-attributes (window :sizes 32)
-    (card32-get 32)))
-
-(defun window-map-state (window)
-  (declare (type window window))
-  (declare (clx-values (member :unmapped :unviewable :viewable)))
-  (with-attributes (window :sizes 8)
-    (member8-get 26 :unmapped :unviewable :viewable)))
-
-
-;;;-----------------------------------------------------------------------------
-;;; Group G: (for GetGeometry)
-;;;-----------------------------------------------------------------------------
-
-(defun drawable-root (drawable)
-  (declare (type drawable drawable))
-  (declare (clx-values window))
-  (with-geometry (drawable :sizes 32)
-    (window-get 8 (drawable-display drawable))))
-
-(defun drawable-x (drawable)
-  ;; setf'able
-  (declare (type drawable drawable))
-  (declare (clx-values int16))
-  (with-geometry (drawable :sizes 16)
-    (int16-get 12)))
-
-(defun set-drawable-x (drawable x)
-  (change-drawable-geometry drawable 0 (encode-type int16 x))
-  x)
-
-(defsetf drawable-x set-drawable-x)
-
-(defun drawable-y (drawable)
-  ;; setf'able
-  (declare (type drawable drawable))
-  (declare (clx-values int16))
-  (with-geometry (drawable :sizes 16)
-    (int16-get 14)))
-
-(defun set-drawable-y (drawable y)
-  (change-drawable-geometry drawable 1 (encode-type int16 y))
-  y)
-
-(defsetf drawable-y set-drawable-y)
-
-(defun drawable-width (drawable)
-  ;; setf'able
-  ;; Inside width, excluding border.
-  (declare (type drawable drawable))
-  (declare (clx-values card16))
-  (with-geometry (drawable :sizes 16)
-    (card16-get 16)))
-
-(defun set-drawable-width (drawable width)
-  (change-drawable-geometry drawable 2 (encode-type card16 width))
-  width)
-
-(defsetf drawable-width set-drawable-width)
-
-(defun drawable-height (drawable)
-  ;; setf'able
-  ;; Inside height, excluding border.
-  (declare (type drawable drawable))
-  (declare (clx-values card16))
-  (with-geometry (drawable :sizes 16)
-    (card16-get 18)))
-
-(defun set-drawable-height (drawable height)
-  (change-drawable-geometry drawable 3 (encode-type card16 height))
-  height)
-
-(defsetf drawable-height set-drawable-height)
-
-(defun drawable-depth (drawable)
-  (declare (type drawable drawable))
-  (declare (clx-values card8))
-  (with-geometry (drawable :sizes 8)
-    (card8-get 1)))
-
-(defun drawable-border-width (drawable)
-  ;; setf'able
-  (declare (type drawable drawable))
-  (declare (clx-values integer))
-  (with-geometry (drawable :sizes 16)
-    (card16-get 20)))
-
-(defun set-drawable-border-width (drawable width)
-  (change-drawable-geometry drawable 4 (encode-type card16 width))
-  width)
-
-(defsetf drawable-border-width set-drawable-border-width)
-
-(defun set-window-priority (mode window sibling)
-  (declare (type (member :above :below :top-if :bottom-if :opposite) mode)
-	   (type window window)
-	   (type (or null window) sibling))
-  (with-state (window)
-    (change-drawable-geometry
-      window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode))
-    (when sibling
-      (change-drawable-geometry window 5 (encode-type window sibling))))
-  mode)
-
-#+Genera (eval-when (compile) (compiler:function-defined 'window-priority))
-
-(defsetf window-priority (window &optional sibling) (mode)
-  ;; A bit strange, but retains setf form.
-  `(set-window-priority ,mode ,window ,sibling))
diff --git a/clx/buffer.lisp b/clx/buffer.lisp
deleted file mode 100644
index 113867dceb509d968f44a62b9bb159e091722cd7..0000000000000000000000000000000000000000
--- a/clx/buffer.lisp
+++ /dev/null
@@ -1,1787 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;; This file contains definitions for the BUFFER object for Common-Lisp X
-;;; windows version 11
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-;; A few notes:
-;;
-;;  1. The BUFFER implements a two-way buffered byte / half-word
-;;     / word stream.  Hooks are left for implementing this with a
-;;     shared memory buffer, or with effenciency hooks to the network
-;;     code.
-;;
-;;  2. The BUFFER object uses overlapping displaced arrays for
-;;     inserting and removing bytes half-words and words.
-;;
-;;  3. The BYTE component of these arrays is written to a STREAM
-;;     associated with the BUFFER.  The stream has its own buffer.
-;;     This may be made more efficient by using the Zetalisp
-;;     :Send-Output-Buffer operation.
-;;
-;;  4. The BUFFER object is INCLUDED in the DISPLAY object.
-;;     This was done to reduce access time when sending requests,
-;;     while maintaing some code modularity.
-;;     Several buffer functions are duplicated (with-buffer,
-;;     buffer-force-output, close-buffer) to keep the naming
-;;     conventions consistent.
-;;
-;;  5. A nother layer of software is built on top of this for generating
-;;     both client and server interface routines, given a specification
-;;     of the protocol. (see the INTERFACE file)
-;;
-;;  6. Care is taken to leave the buffer pointer (buffer-bbuf) set to
-;;     a point after a complete request.  This is to ensure that a partial
-;;     request won't be left after aborts (e.g. control-abort on a lispm).
-
-(in-package :xlib)
-
-(defconstant *requestsize* 160) ;; Max request size (excluding variable length requests)
-
-;;; This is here instead of in bufmac so that with-display can be
-;;; compiled without macros and bufmac being loaded.
-
-(defmacro with-buffer ((buffer &key timeout inline)
-		       &body body &environment env)
-  ;; This macro is for use in a multi-process environment.  It provides
-  ;; exclusive access to the local buffer object for request generation and
-  ;; reply processing.
-  `(macrolet ((with-buffer ((buffer &key timeout) &body body)
-		;; Speedup hack for lexically nested with-buffers
-		`(progn
-		   (progn ,buffer ,@(and timeout `(,timeout)) nil)
-		   ,@body)))
-     ,(if (and (null inline) (macroexpand '(use-closures) env))
-	  `(flet ((.with-buffer-body. () ,@body))
-	     #+clx-ansi-common-lisp
-	     (declare (dynamic-extent #'.with-buffer-body.))
-	     (with-buffer-function ,buffer ,timeout #'.with-buffer-body.))
-	(let ((buf (if (or (symbolp buffer) (constantp buffer))
-		       buffer
-		     '.buffer.)))
-	  `(let (,@(unless (eq buf buffer) `((,buf ,buffer))))
-	     ,@(unless (eq buf buffer) `((declare (type buffer ,buf))))
-	     ,(declare-bufmac)
-	     (when (buffer-dead ,buf)
-	       (x-error 'closed-display :display ,buf))
-	     (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock"
-			    ,@(and timeout `(:timeout ,timeout)))
-	       ,@body))))))
-
-(defun with-buffer-function (buffer timeout function)
-  (declare (type display buffer)
-	   (type (or null number) timeout)
-	   (type function function)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent function)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg function))
-  (with-buffer (buffer :timeout timeout :inline t)
-    (funcall function)))
-
-;;; The following are here instead of in bufmac so that event-case can
-;;; be compiled without macros and bufmac being loaded.
-
-(defmacro read-card8 (byte-index)
-  `(aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index)))
-
-(defmacro read-int8 (byte-index)
-  `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index)))
-
-(defmacro read-card16 (byte-index)
-  #+clx-overlapping-arrays
-  `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
-  #-clx-overlapping-arrays
-  `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index)))
-
-(defmacro read-int16 (byte-index)
-  #+clx-overlapping-arrays
-  `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
-  #-clx-overlapping-arrays
-  `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index)))
-
-(defmacro read-card32 (byte-index)
-  #+clx-overlapping-arrays
-  `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
-  #-clx-overlapping-arrays
-  `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index)))
-
-(defmacro read-int32 (byte-index)
-  #+clx-overlapping-arrays
-  `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
-  #-clx-overlapping-arrays
-  `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index)))
-
-(defmacro read-card29 (byte-index)
-  #+clx-overlapping-arrays
-  `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
-  #-clx-overlapping-arrays
-  `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index)))
-
-(defmacro event-code (reply-buffer)
-  ;; The reply-buffer structure is used for events.
-  ;; The size slot is used for the event code.
-  `(reply-size ,reply-buffer))
-
-(defmacro reading-event ((event &rest options) &body body)
-  (declare (arglist (buffer &key sizes) &body body))
-  ;; BODY may contain calls to (READ32 &optional index) etc.
-  ;; These calls will read from the input buffer at byte
-  ;; offset INDEX.  If INDEX is not supplied, then the next
-  ;; word, half-word or byte is returned.
-  `(with-buffer-input (,event ,@options) ,@body))
-
-(defmacro with-buffer-input ((reply-buffer &key display (sizes '(8 16 32)) index)
-			     &body body)
-  (unless (listp sizes) (setq sizes (list sizes)))
-  ;; 160 is a special hack for client-message-events
-  (when (set-difference sizes '(0 8 16 32 160 256))
-    (error "Illegal sizes in ~a" sizes))
-  `(let ((%reply-buffer ,reply-buffer)
-	 ,@(and display `((%buffer ,display))))
-     (declare (type reply-buffer %reply-buffer)
-	      ,@(and display '((type display %buffer))))
-     ,(declare-bufmac)
-     ,@(and display '(%buffer))
-     (let* ((buffer-boffset (the array-index ,(or index 0)))
-	    #-clx-overlapping-arrays
-	    (buffer-bbuf (reply-ibuf8 %reply-buffer))
-	    #+clx-overlapping-arrays
-	    ,@(append
-		(when (member 8 sizes)
-		  `((buffer-bbuf (reply-ibuf8 %reply-buffer))))
-		(when (or (member 16 sizes) (member 160 sizes))
-		  `((buffer-woffset (index-ash buffer-boffset -1))
-		    (buffer-wbuf (reply-ibuf16 %reply-buffer))))
-		(when (member 32 sizes)
-		  `((buffer-loffset (index-ash buffer-boffset -2))
-		    (buffer-lbuf (reply-ibuf32 %reply-buffer))))))
-       (declare (type array-index buffer-boffset))
-       #-clx-overlapping-arrays
-       (declare (type buffer-bytes buffer-bbuf))
-       #+clx-overlapping-arrays
-       ,@(append
-	   (when (member 8 sizes)
-	     '((declare (type buffer-bytes buffer-bbuf))))
-	   (when (member 16 sizes)
-	     '((declare (type array-index buffer-woffset))
-	       (declare (type buffer-words buffer-wbuf))))
-	   (when (member 32 sizes)
-	     '((declare (type array-index buffer-loffset))
-	       (declare (type buffer-longs buffer-lbuf)))))
-       buffer-boffset
-       #-clx-overlapping-arrays
-       buffer-bbuf
-       #+clx-overlapping-arrays
-       ,@(append
-	   (when (member 8  sizes) '(buffer-bbuf))
-	   (when (member 16 sizes) '(buffer-woffset buffer-wbuf))
-	   (when (member 32 sizes) '(buffer-loffset buffer-lbuf)))
-       #+clx-overlapping-arrays
-       (macrolet ((%buffer-sizes () ',sizes))
-	 ,@body)
-       #-clx-overlapping-arrays
-       ,@body)))
-
-(defun make-buffer (output-size constructor &rest options)
-  (declare (dynamic-extent options))
-  ;; Output-Size is the output-buffer size in bytes.
-  (let ((byte-output (make-array output-size :element-type 'card8
-				 :initial-element 0)))
-    (apply constructor
-	   :size output-size
-	   :obuf8 byte-output
-	   #+clx-overlapping-arrays
-	   :obuf16
-	   #+clx-overlapping-arrays
-	   (make-array (index-ash output-size -1)
-		       :element-type 'overlap16
-		       :displaced-to byte-output)
-	   #+clx-overlapping-arrays
-	   :obuf32
-	   #+clx-overlapping-arrays
-	   (make-array (index-ash output-size -2)
-		       :element-type 'overlap32
-		       :displaced-to byte-output)
-	   options))) 
-
-(defun make-reply-buffer (size)
-  ;; Size is the buffer size in bytes
-  (let ((byte-input (make-array size :element-type 'card8
-				:initial-element 0)))
-    (make-reply-buffer-internal
-      :size size
-      :ibuf8 byte-input
-      #+clx-overlapping-arrays
-      :ibuf16
-      #+clx-overlapping-arrays
-      (make-array (index-ash size -1)
-		  :element-type 'overlap16
-		  :displaced-to byte-input)
-      #+clx-overlapping-arrays
-      :ibuf32
-      #+clx-overlapping-arrays
-      (make-array (index-ash size -2)
-		  :element-type 'overlap32
-		  :displaced-to byte-input))))
-
-(defun buffer-ensure-size (buffer size)
-  (declare (type buffer buffer)
-	   (type array-index size))
-  (when (index> size (buffer-size buffer))
-    (with-buffer (buffer)
-      (buffer-flush buffer)
-      (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size))))
-	     (new-buffer (make-array new-buffer-size :element-type 'card8
-				     :initial-element 0)))
-	(setf (buffer-obuf8 buffer) new-buffer)
-	#+clx-overlapping-arrays
-	(setf (buffer-obuf16 buffer)
-	      (make-array (index-ash new-buffer-size -1)
-			  :element-type 'overlap16
-			  :displaced-to new-buffer)
-	      (buffer-obuf32 buffer)
-	      (make-array (index-ash new-buffer-size -2)
-			  :element-type 'overlap32
-			  :displaced-to new-buffer))))))
-
-(defun buffer-pad-request (buffer pad)
-  (declare (type buffer buffer)
-	   (type array-index pad))
-  (unless (index-zerop pad)
-    (when (index> (index+ (buffer-boffset buffer) pad)
-		  (buffer-size buffer))
-      (buffer-flush buffer))
-    (incf (buffer-boffset buffer) pad)
-    (unless (index-zerop (index-mod (buffer-boffset buffer) 4))
-      (buffer-flush buffer))))
-
-(declaim (inline buffer-new-request-number))
-
-(defun buffer-new-request-number (buffer)
-  (declare (type buffer buffer))
-  (setf (buffer-request-number buffer)
-	(ldb (byte 16 0) (1+ (buffer-request-number buffer)))))
-
-(defun with-buffer-request-function (display gc-force request-function)
-  (declare (type display display)
-	   (type (or null gcontext) gc-force))
-  (declare (type function request-function)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent request-function)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg request-function))
-  (with-buffer (display :inline t)
-    (multiple-value-prog1
-      (progn
-	(when gc-force (force-gcontext-changes-internal gc-force))
-	(without-aborts (funcall request-function display)))
-      (display-invoke-after-function display))))
-
-(defun with-buffer-request-function-nolock (display gc-force request-function)
-  (declare (type display display)
-	   (type (or null gcontext) gc-force))
-  (declare (type function request-function)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent request-function)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg request-function))
-  (multiple-value-prog1
-    (progn
-      (when gc-force (force-gcontext-changes-internal gc-force))
-      (without-aborts (funcall request-function display)))
-    (display-invoke-after-function display)))
-
-(defstruct (pending-command (:copier nil) (:predicate nil))
-  (sequence 0 :type card16)
-  (reply-buffer nil :type (or null reply-buffer))
-  (process nil)
-  (next nil #-explorer :type #-explorer (or null pending-command)))
-
-(defun with-buffer-request-and-reply-function
-       (display multiple-reply request-function reply-function)
-  (declare (type display display)
-	   (type boolean multiple-reply))
-  (declare (type function request-function reply-function)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent request-function reply-function)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg request-function reply-function))
-  (let ((pending-command nil)
-	(reply-buffer nil))
-    (declare (type (or null pending-command) pending-command)
-	     (type (or null reply-buffer) reply-buffer))
-    (unwind-protect
-	(progn 
-	  (with-buffer (display :inline t)
-	    (setq pending-command (start-pending-command display))
-	    (without-aborts (funcall request-function display))
-	    (buffer-force-output display)
-	    (display-invoke-after-function display))
-	  (cond (multiple-reply
-		 (loop
-		   (setq reply-buffer (read-reply display pending-command))
-		   (when (funcall reply-function display reply-buffer) (return nil))
-		   (deallocate-reply-buffer (shiftf reply-buffer nil))))
-		(t
-		 (setq reply-buffer (read-reply display pending-command))
-		 (funcall reply-function display reply-buffer))))
-      (when reply-buffer (deallocate-reply-buffer reply-buffer))
-      (when pending-command (stop-pending-command display pending-command)))))
-
-;;
-;; Buffer stream operations
-;;
-
-(defun buffer-write (vector buffer start end)
-  ;; Write out VECTOR from START to END into BUFFER
-  ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
-  (declare (type buffer buffer)
-	   (type array-index start end))
-  (when (buffer-dead buffer)
-    (x-error 'closed-display :display buffer))
-  (wrap-buf-output (buffer)
-    (funcall (buffer-write-function buffer) vector buffer start end))
-  nil)
-
-(defun buffer-flush (buffer)
-  ;; Write the buffer contents to the server stream - doesn't force-output the stream
-  ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
-  (declare (type buffer buffer))
-  (unless (buffer-flush-inhibit buffer)
-    (let ((boffset (buffer-boffset buffer)))
-      (declare (type array-index boffset))
-      (when (index-plusp boffset)
-	(buffer-write (buffer-obuf8 buffer) buffer 0 boffset)
-	(setf (buffer-boffset buffer) 0)
-	(setf (buffer-last-request buffer) nil))))
-  nil)
-
-(defmacro with-buffer-flush-inhibited ((buffer) &body body)
-  (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.)))
-    `(let* (,@(and (not (eq buf buffer)) `((,buf ,buffer)))
-	    (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf)))
-       (unwind-protect
-	   (progn
-	     (setf (buffer-flush-inhibit ,buf) t)
-	     ,@body)
-	 (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.)))))
-
-(defun buffer-force-output (buffer)
-  ;; Output is normally buffered, this forces any buffered output to the server.
-  (declare (type buffer buffer))
-  (when (buffer-dead buffer)
-    (x-error 'closed-display :display buffer))
-  (buffer-flush buffer)
-  (wrap-buf-output (buffer)
-    (without-aborts
-      (funcall (buffer-force-output-function buffer) buffer)))
-  nil)
-
-(defun close-buffer (buffer &key abort)
-  ;; Close the host connection in BUFFER
-  (declare (type buffer buffer))
-  (unless (null (buffer-output-stream buffer))
-    (wrap-buf-output (buffer)
-      (funcall (buffer-close-function buffer) buffer :abort abort))
-    (setf (buffer-dead buffer) t)
-    ;; Zap pointers to the streams, to ensure they're GC'd
-    (setf (buffer-output-stream buffer) nil)
-    (setf (buffer-input-stream buffer) nil)
-    )
-  nil)
-
-(defun buffer-input  (buffer vector start end &optional timeout)
-  ;; Read into VECTOR from the buffer stream
-  ;; Timeout, when non-nil, is in seconds
-  ;; Returns non-nil if EOF encountered
-  ;; Returns :TIMEOUT when timeout exceeded
-  (declare (type buffer buffer)
-	   (type vector vector)
-	   (type array-index start end)
-	   (type (or null number) timeout))
-  (declare (clx-values eof-p))
-  (when (buffer-dead buffer)
-    (x-error 'closed-display :display buffer))
-  (unless (= start end)
-    (let ((result
-	    (wrap-buf-input (buffer)
-	      (funcall (buffer-input-function buffer)
-		       buffer vector start end timeout))))
-      (unless (or (null result) (eq result :timeout))
-	(close-buffer buffer))
-      result)))
-
-(defun buffer-input-wait  (buffer timeout)
-  ;; Timeout, when non-nil, is in seconds
-  ;; Returns non-nil if EOF encountered
-  ;; Returns :TIMEOUT when timeout exceeded
-  (declare (type buffer buffer)
-	   (type (or null number) timeout))
-  (declare (clx-values timeout))
-  (when (buffer-dead buffer)
-    (x-error 'closed-display :display buffer))
-  (let ((result
-	  (wrap-buf-input (buffer)
-	    (funcall (buffer-input-wait-function buffer)
-		     buffer timeout))))
-    (unless (or (null result) (eq result :timeout))
-      (close-buffer buffer))
-    result))
-
-(defun buffer-listen (buffer)
-  ;; Returns T if there is input available for the buffer. This should never
-  ;; block, so it can be called from the scheduler.
-  (declare (type buffer buffer))
-  (declare (clx-values input-available))
-  (or (not (null (buffer-dead buffer)))
-      (wrap-buf-input (buffer)
-	(funcall (buffer-listen-function buffer) buffer))))
-
-;;; Reading sequences of strings
-
-;;; a list of pascal-strings with card8 lengths, no padding in between
-;;; can't use read-sequence-char
-(defun read-sequence-string (buffer-bbuf length nitems result-type
-			     &optional (buffer-boffset 0))
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type array-index length nitems buffer-boffset))
-  length
-  (with-vector (buffer-bbuf buffer-bytes)
-    (let ((result (make-sequence result-type nitems)))
-      (do* ((index 0 (index+ index 1 string-length))
-	    (count 0 (index1+ count))
-	    (string-length 0)
-	    (string ""))
-	   ((index>= count nitems)
-	    result)
-	(declare (type array-index index count string-length)
-		 (type string string))
-	(setq string-length (read-card8 index)
-	      string (make-sequence 'string string-length))
-	(do ((i (index1+ index) (index1+ i))
-	     (j 0 (index1+ j)))
-	    ((index>= j string-length)
-	     (setf (elt result count) string))
-	  (declare (type array-index i j))
-	  (setf (aref string j) (card8->char (read-card8 i))))))))
-
-;;; Reading sequences of chars
-
-(defun read-sequence-char (reply-buffer result-type nitems &optional transform data
-			   (start 0) (index 0))
-  (declare (type reply-buffer reply-buffer)
-	   (type t result-type) ;; CL type
-	   (type array-index nitems start index)
-	   (type (or null sequence) data))
-  (declare (type (or null (function (character) t)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (if transform 
-      (flet ((card8->char->transform (v)
-	       (declare (type card8 v))
-	       (funcall transform (card8->char v))))
-	#+clx-ansi-common-lisp
-	(declare (dynamic-extent #'card8->char->transform))
-	(read-sequence-card8
-	  reply-buffer result-type nitems #'card8->char->transform
-	  data start index))
-    (read-sequence-card8
-      reply-buffer result-type nitems #'card8->char
-      data start index)))
-
-;;; Reading sequences of card8's
-
-(defun read-list-card8 (reply-buffer nitems data start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type list data))
-  (with-buffer-input (reply-buffer :sizes (8) :index index)
-    (do* ((j nitems (index- j 1))
-	  (lst (nthcdr start data)  (cdr lst))
-	  (index 0 (index+ index 1)))
-	 ((index-zerop j))
-      (declare (type array-index j index)
-	       (type cons lst))
-      (setf (car lst) (read-card8 index)))))
-
-(defun read-list-card8-with-transform (reply-buffer nitems data transform start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type list data))
-  (declare (type (function (card8) t) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-buffer-input (reply-buffer :sizes (8) :index index)
-    (do* ((j nitems (index- j 1))
-	  (lst (nthcdr start data) (cdr lst))
-	  (index 0 (index+ index 1)))
-	 ((index-zerop j))
-      (declare (type array-index j index)
-	       (type cons lst))
-      (setf (car lst) (funcall transform (read-card8 index))))))
-
-#-lispm
-(defun read-simple-array-card8 (reply-buffer nitems data start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type (simple-array card8 (*)) data))
-  (with-vector (data (simple-array card8 (*)))
-    (with-buffer-input (reply-buffer :sizes (8))
-      (buffer-replace data buffer-bbuf start (index+ start nitems) index))))
-
-#-lispm
-(defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type (simple-array card8 (*)) data))
-  (declare (type (function (card8) card8) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data (simple-array card8 (*)))
-    (with-buffer-input (reply-buffer :sizes (8) :index index)
-      (do* ((j start (index+ j 1))
-	    (end (index+ start nitems))
-	    (index 0 (index+ index 1)))
-	   ((index>= j end))
-	(declare (type array-index j end index))
-	(setf (aref data j) (the card8 (funcall transform (read-card8 index))))))))
-
-(defun read-vector-card8 (reply-buffer nitems data start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type vector data))
-  (with-vector (data vector)
-    (with-buffer-input (reply-buffer :sizes (8) :index index)
-      (do* ((j start (index+ j 1))
-	    (end (index+ start nitems))
-	    (index 0 (index+ index 1)))
-	   ((index>= j end))
-	(declare (type array-index j end index))
-	(setf (aref data j) (read-card8 index))))))
-
-(defun read-vector-card8-with-transform (reply-buffer nitems data transform start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type vector data))
-  (declare (type (function (card8) t) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data vector)
-    (with-buffer-input (reply-buffer :sizes (8) :index index)
-      (do* ((j start (index+ j 1))
-	    (end (index+ start nitems))
-	    (index 0 (index+ index 1)))
-	   ((index>= j end))
-	(declare (type array-index j end index))
-	(setf (aref data j) (funcall transform (read-card8 index)))))))
-
-(defun read-sequence-card8 (reply-buffer result-type nitems &optional transform data
-			    (start 0) (index 0))
-  (declare (type reply-buffer reply-buffer)
-	   (type t result-type) ;; CL type
-	   (type array-index nitems start index)
-	   (type (or null sequence) data))
-  (declare (type (or null (function (card8) t)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (let ((result (or data (make-sequence result-type nitems))))
-    (typecase result
-      (list
-	(if transform 
-	    (read-list-card8-with-transform
-	      reply-buffer nitems result transform start index)
-	  (read-list-card8 reply-buffer nitems result start index)))
-      #-lispm
-      ((simple-array card8 (*))
-       (if transform 
-	   (read-simple-array-card8-with-transform
-	     reply-buffer nitems result transform start index)
-	 (read-simple-array-card8 reply-buffer nitems result start index)))
-      (t
-	(if transform 
-	    (read-vector-card8-with-transform
-	      reply-buffer nitems result transform start index)
-	  (read-vector-card8 reply-buffer nitems result start index))))
-    result))
-
-;;; For now, perhaps performance it isn't worth doing better?
-
-(defun read-sequence-int8 (reply-buffer result-type nitems &optional transform data
-			   (start 0) (index 0))
-  (declare (type reply-buffer reply-buffer)
-	   (type t result-type) ;; CL type
-	   (type array-index nitems start index)
-	   (type (or null sequence) data))
-  (declare (type (or null (function (int8) t)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (if transform 
-      (flet ((card8->int8->transform (v)
-	       (declare (type card8 v))
-	       (funcall transform (card8->int8 v))))
-	#+clx-ansi-common-lisp
-	(declare (dynamic-extent #'card8->int8->transform))
-	(read-sequence-card8
-	  reply-buffer result-type nitems #'card8->int8->transform
-	  data start index))
-    (read-sequence-card8
-      reply-buffer result-type nitems #'card8->int8
-      data start index)))
-
-;;; Reading sequences of card16's
-
-(defun read-list-card16 (reply-buffer nitems data start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type list data))
-  (with-buffer-input (reply-buffer :sizes (16) :index index)
-    (do* ((j nitems (index- j 1))
-	  (lst (nthcdr start data) (cdr lst))
-	  (index 0 (index+ index 2)))
-	 ((index-zerop j))
-      (declare (type array-index j index)
-	       (type cons lst))
-      (setf (car lst) (read-card16 index)))))
-
-(defun read-list-card16-with-transform (reply-buffer nitems data transform start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type list data))
-  (declare (type (function (card16) t) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-buffer-input (reply-buffer :sizes (16) :index index)
-    (do* ((j nitems (index- j 1))
-	  (lst (nthcdr start data) (cdr lst))
-	  (index 0 (index+ index 2)))
-	 ((index-zerop j))
-      (declare (type array-index j index)
-	       (type cons lst))
-      (setf (car lst) (funcall transform (read-card16 index))))))
-
-#-lispm
-(defun read-simple-array-card16 (reply-buffer nitems data start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type (simple-array card16 (*)) data))
-  (with-vector (data (simple-array card16 (*)))
-    (with-buffer-input (reply-buffer :sizes (16) :index index)
-      #-clx-overlapping-arrays
-      (do* ((j start (index+ j 1))
-	    (end (index+ start nitems))
-	    (index 0 (index+ index 2)))
-	   ((index>= j end))
-	(declare (type array-index j end index))
-	(setf (aref data j) (the card16 (read-card16 index))))
-      #+clx-overlapping-arrays
-      (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2)))))
-
-#-lispm
-(defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type (simple-array card16 (*)) data))
-  (declare (type (function (card16) card16) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data (simple-array card16 (*)))
-    (with-buffer-input (reply-buffer :sizes (16) :index index)
-      (do* ((j start (index+ j 1))
-	    (end (index+ start nitems))
-	    (index 0 (index+ index 2)))
-	   ((index>= j end))
-	(declare (type array-index j end index))
-	(setf (aref data j) (the card16 (funcall transform (read-card16 index))))))))
-
-(defun read-vector-card16 (reply-buffer nitems data start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type vector data))
-  (with-vector (data vector)
-    (with-buffer-input (reply-buffer :sizes (16) :index index)
-      #-clx-overlapping-arrays
-      (do* ((j start (index+ j 1))
-	    (end (index+ start nitems))
-	    (index 0 (index+ index 2)))
-	   ((index>= j end))
-	(declare (type array-index j end index))
-	(setf (aref data j) (read-card16 index)))
-      #+clx-overlapping-arrays
-      (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2)))))
-
-(defun read-vector-card16-with-transform (reply-buffer nitems data transform start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type vector data))
-  (declare (type (function (card16) t) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data vector)
-    (with-buffer-input (reply-buffer :sizes (16) :index index)
-      (do* ((j start (index+ j 1))
-	    (end (index+ start nitems))
-	    (index 0 (index+ index 2)))
-	   ((index>= j end))
-	(declare (type array-index j end index))
-	(setf (aref data j) (funcall transform (read-card16 index)))))))
-
-(defun read-sequence-card16 (reply-buffer result-type nitems &optional transform data
-			     (start 0) (index 0))
-  (declare (type reply-buffer reply-buffer)
-	   (type t result-type) ;; CL type
-	   (type array-index nitems start index)
-	   (type (or null sequence) data))
-  (declare (type (or null (function (card16) t)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (let ((result (or data (make-sequence result-type nitems))))
-    (typecase result
-      (list
-	(if transform 
-	    (read-list-card16-with-transform reply-buffer nitems result transform start index)
-	  (read-list-card16 reply-buffer nitems result start index)))
-      #-lispm
-      ((simple-array card16 (*))
-       (if transform 
-	   (read-simple-array-card16-with-transform
-	     reply-buffer nitems result transform start index)
-	 (read-simple-array-card16 reply-buffer nitems result start index)))
-      (t
-	(if transform 
-	    (read-vector-card16-with-transform
-	      reply-buffer nitems result transform start index)
-	  (read-vector-card16 reply-buffer nitems result start index))))
-    result))
-  
-;;; For now, perhaps performance it isn't worth doing better?
-
-(defun read-sequence-int16 (reply-buffer result-type nitems &optional transform data
-			    (start 0) (index 0))
-  (declare (type reply-buffer reply-buffer)
-	   (type t result-type) ;; CL type
-	   (type array-index nitems start index)
-	   (type (or null sequence) data))
-  (declare (type (or null (function (int16) t)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (if transform 
-      (flet ((card16->int16->transform (v)
-	       (declare (type card16 v))
-	       (funcall transform (card16->int16 v))))
-	#+clx-ansi-common-lisp
-	(declare (dynamic-extent #'card16->int16->transform))
-	(read-sequence-card16
-	  reply-buffer result-type nitems #'card16->int16->transform
-	  data start index))
-    (read-sequence-card16
-      reply-buffer result-type nitems #'card16->int16
-      data start index)))
-
-;;; Reading sequences of card32's
-
-(defun read-list-card32 (reply-buffer nitems data start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type list data))
-  (with-buffer-input (reply-buffer :sizes (32) :index index)
-    (do* ((j nitems (index- j 1))
-	  (lst (nthcdr start data) (cdr lst))
-	  (index 0 (index+ index 4)))
-	 ((index-zerop j))
-      (declare (type array-index j index)
-	       (type cons lst))
-      (setf (car lst) (read-card32 index)))))
-
-(defun read-list-card32-with-transform (reply-buffer nitems data transform start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type list data))
-  (declare (type (function (card32) t) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-buffer-input (reply-buffer :sizes (32) :index index)
-    (do* ((j nitems (index- j 1))
-	  (lst (nthcdr start data) (cdr lst))
-	  (index 0 (index+ index 4)))
-	 ((index-zerop j))
-      (declare (type array-index j index)
-	       (type cons lst))
-      (setf (car lst) (funcall transform (read-card32 index))))))
-
-#-lispm
-(defun read-simple-array-card32 (reply-buffer nitems data start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type (simple-array card32 (*)) data))
-  (with-vector (data (simple-array card32 (*)))
-    (with-buffer-input (reply-buffer :sizes (32) :index index)
-      #-clx-overlapping-arrays
-      (do* ((j start (index+ j 1))
-	    (end (index+ start nitems))
-	    (index 0 (index+ index 4)))
-	   ((index>= j end))
-	(declare (type array-index j end index))
-	(setf (aref data j) (the card32 (read-card32 index))))
-      #+clx-overlapping-arrays
-      (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4)))))
-
-#-lispm
-(defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type (simple-array card32 (*)) data))
-  (declare (type (function (card32) card32) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data (simple-array card32 (*)))
-    (with-buffer-input (reply-buffer :sizes (32) :index index)
-      (do* ((j start (index+ j 1))
-	    (end (index+ start nitems))
-	    (index 0 (index+ index 4)))
-	   ((index>= j end))
-	(declare (type array-index j end index))
-	(setf (aref data j) (the card32 (funcall transform (read-card32 index))))))))
-
-(defun read-vector-card32 (reply-buffer nitems data start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type vector data))
-  (with-vector (data vector)
-    (with-buffer-input (reply-buffer :sizes (32) :index index)
-      #-clx-overlapping-arrays
-      (do* ((j start (index+ j 1))
-	    (end (index+ start nitems))
-	    (index 0 (index+ index 4)))
-	   ((index>= j end))
-	(declare (type array-index j end index))
-	(setf (aref data j) (read-card32 index)))
-      #+clx-overlapping-arrays
-      (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4)))))
-
-(defun read-vector-card32-with-transform (reply-buffer nitems data transform start index)
-  (declare (type reply-buffer reply-buffer)
-	   (type array-index nitems start index)
-	   (type vector data))
-  (declare (type (function (card32) t) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data vector)
-    (with-buffer-input (reply-buffer :sizes (32) :index index)
-      (do* ((j start (index+ j 1))
-	    (end (index+ start nitems))
-	    (index 0 (index+ index 4)))
-	   ((index>= j end))
-	(declare (type array-index j end index))
-	(setf (aref data j) (funcall transform (read-card32 index)))))))
-
-(defun read-sequence-card32 (reply-buffer result-type nitems &optional transform data
-			     (start 0) (index 0))
-  (declare (type reply-buffer reply-buffer)
-	   (type t result-type) ;; CL type
-	   (type array-index nitems start index)
-	   (type (or null sequence) data))
-  (declare (type (or null (function (card32) t)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (let ((result (or data (make-sequence result-type nitems))))
-    (typecase result
-      (list
-	(if transform 
-	    (read-list-card32-with-transform reply-buffer nitems result transform start index)
-	  (read-list-card32 reply-buffer nitems result start index)))
-      #-lispm
-      ((simple-array card32 (*))
-       (if transform 
-	   (read-simple-array-card32-with-transform
-	     reply-buffer nitems result transform start index)
-	 (read-simple-array-card32 reply-buffer nitems result start index)))
-      (t
-	(if transform 
-	    (read-vector-card32-with-transform
-	      reply-buffer nitems result transform start index)
-	  (read-vector-card32 reply-buffer nitems result start index))))
-    result))
-
-;;; For now, perhaps performance it isn't worth doing better?
-
-(defun read-sequence-int32 (reply-buffer result-type nitems &optional transform data
-			    (start 0) (index 0))
-  (declare (type reply-buffer reply-buffer)
-	   (type t result-type) ;; CL type
-	   (type array-index nitems start index)
-	   (type (or null sequence) data))
-  (declare (type (or null (function (int32) t)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (if transform 
-      (flet ((card32->int32->transform (v)
-	       (declare (type card32 v))
-	       (funcall transform (card32->int32 v))))
-	#+clx-ansi-common-lisp
-	(declare (dynamic-extent #'card32->int32->transform))
-	(read-sequence-card32
-	  reply-buffer result-type nitems #'card32->int32->transform
-	  data start index))
-    (read-sequence-card32
-      reply-buffer result-type nitems #'card32->int32
-      data start index)))
-
-;;; Writing sequences of chars
-
-(defun write-sequence-char
-       (buffer boffset data &optional (start 0) (end (length data)) transform)
-  (declare (type buffer buffer)
-	   (type sequence data)
-	   (type array-index boffset start end))
-  (declare (type (or null (function (t) character)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (if transform 
-      (flet ((transform->char->card8 (x)
-	       (char->card8 (the character (funcall transform x)))))
-	#+clx-ansi-common-lisp
-	(declare (dynamic-extent #'transform->char->card8))
-	(write-sequence-card8
-	  buffer boffset data start end #'transform->char->card8))
-    (write-sequence-card8 buffer boffset data start end #'char->card8)))
-
-;;; Writing sequences of card8's
-
-(defun write-list-card8 (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type list data)
-	   (type array-index boffset start end))
-  (writing-buffer-chunks card8
-			 ((lst (nthcdr start data)))
-			 ((type list lst))
-    (dotimes (j chunk)
-      (declare (type array-index j))
-      #-ti (write-card8 j (pop lst))		;TI Compiler bug
-      #+ti (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop lst))
-      ))
-  nil)
-
-(defun write-list-card8-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type list data)
-	   (type array-index boffset start end))
-  (declare (type (function (t) card8) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (writing-buffer-chunks card8
-			 ((lst (nthcdr start data)))
-			 ((type list lst))
-    (dotimes (j chunk)
-      (declare (type array-index j))
-      (write-card8 j (funcall transform (pop lst)))))
-  nil)
-
-;;; Should really write directly from data, instead of into the buffer first
-#-lispm
-(defun write-simple-array-card8 (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type (simple-array card8 (*)) data)
-	   (type array-index boffset start end))
-  (with-vector (data (simple-array card8 (*)))
-    (writing-buffer-chunks card8
-			   ((index start (index+ index chunk)))
-			   ((type array-index index))
-      (buffer-replace buffer-bbuf data
-		      buffer-boffset
-		      (index+ buffer-boffset chunk)
-		      index)))
-  nil)
-
-#-lispm
-(defun write-simple-array-card8-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type (simple-array card8 (*)) data)
-	   (type array-index boffset start end))
-  (declare (type (function (card8) card8) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data (simple-array card8 (*)))
-    (writing-buffer-chunks card8
-			   ((index start))
-			   ((type array-index index))
-      (dotimes (j chunk)
-	(declare (type array-index j))
-	(write-card8 j (funcall transform (aref data index)))
-	(setq index (index+ index 1)))))
-  nil)
-
-(defun write-vector-card8 (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type vector data)
-	   (type array-index boffset start end))
-  (with-vector (data vector)
-    (writing-buffer-chunks card8
-			   ((index start))
-			   ((type array-index index))
-      (dotimes (j chunk)
-	(declare (type array-index j))
-	(write-card8 j (aref data index))
-	(setq index (index+ index 1)))))
-  nil)
-
-(defun write-vector-card8-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type vector data)
-	   (type array-index boffset start end))
-  (declare (type (function (t) card8) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data vector)
-    (writing-buffer-chunks card8
-			   ((index start))
-			   ((type array-index index))
-      (dotimes (j chunk)
-	(declare (type array-index j))
-	(write-card8 j (funcall transform (aref data index)))
-	(setq index (index+ index 1)))))
-  nil)
-
-(defun write-sequence-card8
-       (buffer boffset data &optional (start 0) (end (length data)) transform)
-  (declare (type buffer buffer)
-	   (type sequence data)
-	   (type array-index boffset start end))
-  (declare (type (or null (function (t) card8)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (typecase data
-    (list
-      (if transform
-	  (write-list-card8-with-transform buffer boffset data start end transform)
-	  (write-list-card8 buffer boffset data start end)))
-    #-lispm
-    ((simple-array card8 (*))
-     (if transform
-	 (write-simple-array-card8-with-transform buffer boffset data start end transform)
-	 (write-simple-array-card8 buffer boffset data start end)))
-    (t
-      (if transform
-	  (write-vector-card8-with-transform buffer boffset data start end transform)
-	  (write-vector-card8 buffer boffset data start end)))))
-
-;;; For now, perhaps performance it isn't worth doing better?
-
-(defun write-sequence-int8
-       (buffer boffset data &optional (start 0) (end (length data)) transform)
-  (declare (type buffer buffer)
-	   (type sequence data)
-	   (type array-index boffset start end))
-  (declare (type (or null (function (t) int8)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (if transform 
-      (flet ((transform->int8->card8 (x)
-	       (int8->card8 (the int8 (funcall transform x)))))
-	#+clx-ansi-common-lisp
-	(declare (dynamic-extent #'transform->int8->card8))
-	(write-sequence-card8
-	  buffer boffset data start end #'transform->int8->card8))
-      (write-sequence-card8 buffer boffset data start end #'int8->card8)))
-
-;;; Writing sequences of card16's
-
-(defun write-list-card16 (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type list data)
-	   (type array-index boffset start end))
-  (writing-buffer-chunks card16
-			 ((lst (nthcdr start data)))
-			 ((type list lst))
-    ;; Depends upon the chunks being an even multiple of card16's big
-    (do ((j 0 (index+ j 2)))
-	((index>= j chunk))
-      (declare (type array-index j))
-      (write-card16 j (pop lst))))
-  nil)
-
-(defun write-list-card16-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type list data)
-	   (type array-index boffset start end))
-  (declare (type (function (t) card16) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (writing-buffer-chunks card16
-			 ((lst (nthcdr start data)))
-			 ((type list lst))
-    ;; Depends upon the chunks being an even multiple of card16's big
-    (do ((j 0 (index+ j 2)))
-	((index>= j chunk))
-      (declare (type array-index j))
-      (write-card16 j (funcall transform (pop lst)))))
-  nil)
-
-#-lispm
-(defun write-simple-array-card16 (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type (simple-array card16 (*)) data)
-	   (type array-index boffset start end))
-  (with-vector (data (simple-array card16 (*)))
-    (writing-buffer-chunks card16
-			   ((index start))
-			   ((type array-index index))
-      ;; Depends upon the chunks being an even multiple of card16's big
-      (do ((j 0 (index+ j 2)))
-	  ((index>= j chunk))
-	(declare (type array-index j))
-	(write-card16 j (aref data index))
-	(setq index (index+ index 1)))
-      ;; overlapping case
-      (let ((length (floor chunk 2)))
-	(buffer-replace buffer-wbuf data
-			buffer-woffset
-			(index+ buffer-woffset length)
-			index)
-	(setq index (index+ index length)))))
-  nil)
-
-#-lispm
-(defun write-simple-array-card16-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type (simple-array card16 (*)) data)
-	   (type array-index boffset start end))
-  (declare (type (function (card16) card16) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data (simple-array card16 (*)))
-    (writing-buffer-chunks card16
-			   ((index start))
-			   ((type array-index index))
-      ;; Depends upon the chunks being an even multiple of card16's big
-      (do ((j 0 (index+ j 2)))
-	  ((index>= j chunk))
-	(declare (type array-index j))
-	(write-card16 j (funcall transform (aref data index)))
-	(setq index (index+ index 1)))))
-  nil)
-
-(defun write-vector-card16 (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type vector data)
-	   (type array-index boffset start end))
-  (with-vector (data vector)
-    (writing-buffer-chunks card16
-			   ((index start))
-			   ((type array-index index))
-      ;; Depends upon the chunks being an even multiple of card16's big
-      (do ((j 0 (index+ j 2)))
-	  ((index>= j chunk))
-	(declare (type array-index j))
-	(write-card16 j (aref data index))
-	(setq index (index+ index 1)))
-      ;; overlapping case
-      (let ((length (floor chunk 2)))
-	(buffer-replace buffer-wbuf data
-			buffer-woffset
-			(index+ buffer-woffset length)
-			index)
-	(setq index (index+ index length)))))
-  nil)
-
-(defun write-vector-card16-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type vector data)
-	   (type array-index boffset start end))
-  (declare (type (function (t) card16) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data vector)
-    (writing-buffer-chunks card16
-			   ((index start))
-			   ((type array-index index))
-      ;; Depends upon the chunks being an even multiple of card16's big
-      (do ((j 0 (index+ j 2)))
-	  ((index>= j chunk))
-	(declare (type array-index j))
-	(write-card16 j (funcall transform (aref data index)))
-	(setq index (index+ index 1)))))
-  nil)
-
-(defun write-sequence-card16
-       (buffer boffset data &optional (start 0) (end (length data)) transform)
-  (declare (type buffer buffer)
-	   (type sequence data)
-	   (type array-index boffset start end))
-  (declare (type (or null (function (t) card16)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (typecase data
-    (list
-      (if transform
-	  (write-list-card16-with-transform buffer boffset data start end transform)
-	  (write-list-card16 buffer boffset data start end)))
-    #-lispm
-    ((simple-array card16 (*))
-     (if transform
-	 (write-simple-array-card16-with-transform buffer boffset data start end transform)
-	 (write-simple-array-card16 buffer boffset data start end)))
-    (t
-      (if transform
-	  (write-vector-card16-with-transform buffer boffset data start end transform)
-	  (write-vector-card16 buffer boffset data start end)))))
-
-;;; Writing sequences of int16's
-
-(defun write-list-int16 (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type list data)
-	   (type array-index boffset start end))
-  (writing-buffer-chunks int16
-			 ((lst (nthcdr start data)))
-			 ((type list lst))
-    ;; Depends upon the chunks being an even multiple of int16's big
-    (do ((j 0 (index+ j 2)))
-	((index>= j chunk))
-      (declare (type array-index j))
-      (write-int16 j (pop lst))))
-  nil)
-
-(defun write-list-int16-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type list data)
-	   (type array-index boffset start end))
-  (declare (type (function (t) int16) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (writing-buffer-chunks int16
-			 ((lst (nthcdr start data)))
-			 ((type list lst))
-    ;; Depends upon the chunks being an even multiple of int16's big
-    (do ((j 0 (index+ j 2)))
-	((index>= j chunk))
-      (declare (type array-index j))
-      (write-int16 j (funcall transform (pop lst)))))
-  nil)
-
-#-lispm
-(defun write-simple-array-int16 (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type (simple-array int16 (*)) data)
-	   (type array-index boffset start end))
-  (with-vector (data (simple-array int16 (*)))
-    (writing-buffer-chunks int16
-			   ((index start))
-			   ((type array-index index))
-      ;; Depends upon the chunks being an even multiple of int16's big
-      (do ((j 0 (index+ j 2)))
-	  ((index>= j chunk))
-	(declare (type array-index j))
-	(write-int16 j (aref data index))
-	(setq index (index+ index 1)))
-      ;; overlapping case
-      (let ((length (floor chunk 2)))
-	(buffer-replace buffer-wbuf data
-			buffer-woffset
-			(index+ buffer-woffset length)
-			index)
-	(setq index (index+ index length)))))
-  nil)
-
-#-lispm
-(defun write-simple-array-int16-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type (simple-array int16 (*)) data)
-	   (type array-index boffset start end))
-  (declare (type (function (int16) int16) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data (simple-array int16 (*)))
-    (writing-buffer-chunks int16
-			   ((index start))
-			   ((type array-index index))
-      ;; Depends upon the chunks being an even multiple of int16's big
-      (do ((j 0 (index+ j 2)))
-	  ((index>= j chunk))
-	(declare (type array-index j))
-	(write-int16 j (funcall transform (aref data index)))
-	(setq index (index+ index 1)))))
-  nil)
-
-(defun write-vector-int16 (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type vector data)
-	   (type array-index boffset start end))
-  (with-vector (data vector)
-    (writing-buffer-chunks int16
-			   ((index start))
-			   ((type array-index index))
-      ;; Depends upon the chunks being an even multiple of int16's big
-      (do ((j 0 (index+ j 2)))
-	  ((index>= j chunk))
-	(declare (type array-index j))
-	(write-int16 j (aref data index))
-	(setq index (index+ index 1)))
-      ;; overlapping case
-      (let ((length (floor chunk 2)))
-	(buffer-replace buffer-wbuf data
-			buffer-woffset
-			(index+ buffer-woffset length)
-			index)
-	(setq index (index+ index length)))))
-  nil)
-
-(defun write-vector-int16-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type vector data)
-	   (type array-index boffset start end))
-  (declare (type (function (t) int16) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data vector)
-    (writing-buffer-chunks int16
-			   ((index start))
-			   ((type array-index index))
-      ;; Depends upon the chunks being an even multiple of int16's big
-      (do ((j 0 (index+ j 2)))
-	  ((index>= j chunk))
-	(declare (type array-index j))
-	(write-int16 j (funcall transform (aref data index)))
-	(setq index (index+ index 1)))))
-  nil)
-
-(defun write-sequence-int16
-       (buffer boffset data &optional (start 0) (end (length data)) transform)
-  (declare (type buffer buffer)
-	   (type sequence data)
-	   (type array-index boffset start end))
-  (declare (type (or null (function (t) int16)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (typecase data
-    (list
-      (if transform
-	  (write-list-int16-with-transform buffer boffset data start end transform)
-	  (write-list-int16 buffer boffset data start end)))
-    #-lispm
-    ((simple-array int16 (*))
-     (if transform
-	 (write-simple-array-int16-with-transform buffer boffset data start end transform)
-	 (write-simple-array-int16 buffer boffset data start end)))
-    (t
-      (if transform
-	  (write-vector-int16-with-transform buffer boffset data start end transform)
-	  (write-vector-int16 buffer boffset data start end)))))
-
-;;; Writing sequences of card32's
-
-(defun write-list-card32 (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type list data)
-	   (type array-index boffset start end))
-  (writing-buffer-chunks card32
-			 ((lst (nthcdr start data)))
-			 ((type list lst))
-    ;; Depends upon the chunks being an even multiple of card32's big
-    (do ((j 0 (index+ j 4)))
-	((index>= j chunk))
-      (declare (type array-index j))
-      (write-card32 j (pop lst))))
-  nil)
-
-(defun write-list-card32-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type list data)
-	   (type array-index boffset start end))
-  (declare (type (function (t) card32) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (writing-buffer-chunks card32
-			 ((lst (nthcdr start data)))
-			 ((type list lst))
-    ;; Depends upon the chunks being an even multiple of card32's big
-    (do ((j 0 (index+ j 4)))
-	((index>= j chunk))
-      (declare (type array-index j))
-      (write-card32 j (funcall transform (pop lst)))))
-  nil)
-
-#-lispm
-(defun write-simple-array-card32 (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type (simple-array card32 (*)) data)
-	   (type array-index boffset start end))
-  (with-vector (data (simple-array card32 (*)))
-    (writing-buffer-chunks card32
-			   ((index start))
-			   ((type array-index index))
-      ;; Depends upon the chunks being an even multiple of card32's big
-      (do ((j 0 (index+ j 4)))
-	  ((index>= j chunk))
-	(declare (type array-index j))
-	(write-card32 j (aref data index))
-	(setq index (index+ index 1)))
-      ;; overlapping case
-      (let ((length (floor chunk 4)))
-	(buffer-replace buffer-lbuf data
-			buffer-loffset
-			(index+ buffer-loffset length)
-			index)
-	(setq index (index+ index length)))))
-  nil)
-
-#-lispm
-(defun write-simple-array-card32-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type (simple-array card32 (*)) data)
-	   (type array-index boffset start end))
-  (declare (type (function (card32) card32) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data (simple-array card32 (*)))
-    (writing-buffer-chunks card32
-			   ((index start))
-			   ((type array-index index))
-      ;; Depends upon the chunks being an even multiple of card32's big
-      (do ((j 0 (index+ j 4)))
-	  ((index>= j chunk))
-	(declare (type array-index j))
-	(write-card32 j (funcall transform (aref data index)))
-	(setq index (index+ index 1)))))
-  nil)
-
-(defun write-vector-card32 (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type vector data)
-	   (type array-index boffset start end))
-  (with-vector (data vector)
-    (writing-buffer-chunks card32
-			   ((index start))
-			   ((type array-index index))
-      ;; Depends upon the chunks being an even multiple of card32's big
-      (do ((j 0 (index+ j 4)))
-	  ((index>= j chunk))
-	(declare (type array-index j))
-	(write-card32 j (aref data index))
-	(setq index (index+ index 1)))
-      ;; overlapping case
-      (let ((length (floor chunk 4)))
-	(buffer-replace buffer-lbuf data
-			buffer-loffset
-			(index+ buffer-loffset length)
-			index)
-	(setq index (index+ index length)))))
-  nil)
-
-(defun write-vector-card32-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type vector data)
-	   (type array-index boffset start end))
-  (declare (type (function (t) card32) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data vector)
-    (writing-buffer-chunks card32
-			   ((index start))
-			   ((type array-index index))
-      ;; Depends upon the chunks being an even multiple of card32's big
-      (do ((j 0 (index+ j 4)))
-	  ((index>= j chunk))
-	(declare (type array-index j))
-	(write-card32 j (funcall transform (aref data index)))
-	(setq index (index+ index 1)))))
-  nil)
-
-(defun write-sequence-card32
-       (buffer boffset data &optional (start 0) (end (length data)) transform)
-  (declare (type buffer buffer)
-	   (type sequence data)
-	   (type array-index boffset start end))
-  (declare (type (or null (function (t) card32)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (typecase data
-    (list
-      (if transform
-	  (write-list-card32-with-transform buffer boffset data start end transform)
-	  (write-list-card32 buffer boffset data start end)))
-    #-lispm
-    ((simple-array card32 (*))
-     (if transform
-	 (write-simple-array-card32-with-transform buffer boffset data start end transform)
-	 (write-simple-array-card32 buffer boffset data start end)))
-    (t
-      (if transform
-	  (write-vector-card32-with-transform buffer boffset data start end transform)
-	  (write-vector-card32 buffer boffset data start end)))))
-
-;;; For now, perhaps performance it isn't worth doing better?
-
-(defun write-sequence-int32
-       (buffer boffset data &optional (start 0) (end (length data)) transform)
-  (declare (type buffer buffer)
-	   (type sequence data)
-	   (type array-index boffset start end))
-  (declare (type (or null (function (t) int32)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (if transform 
-      (flet ((transform->int32->card32 (x)
-	       (int32->card32 (the int32 (funcall transform x)))))
-	#+clx-ansi-common-lisp
-	(declare (dynamic-extent #'transform->int32->card32))
-	(write-sequence-card32
-	  buffer boffset data start end #'transform->int32->card32))
-    (write-sequence-card32 buffer boffset data start end #'int32->card32)))
-
-(defun read-bitvector256 (buffer-bbuf boffset data)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type array-index boffset)
-	   (type (or null (simple-bit-vector 256)) data))
-  (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0))))
-    (declare (type (simple-bit-vector 256) result))
-    (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte
-	 (j 8 (index+ j 8)))
-	((index>= j 256))
-      (declare (type array-index i j))
-      (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1))
-	   (k j (index+ k 1)))
-	  ((zerop byte)
-	   (when data ;; Clear uninitialized bits in data
-	     (do ((end (index+ j 8)))
-		 ((index= k end))
-	       (declare (type array-index end))
-	       (setf (aref result k) 0)
-	       (index-incf k))))
-	(declare (type array-index k)
-		 (type card8 byte))
-	(setf (aref result k) (the bit (logand byte 1)))))
-    result))
-
-(defun write-bitvector256 (buffer boffset map)
-  (declare (type buffer buffer)
-	   (type array-index boffset)
-	   (type (simple-array bit (*)) map))
-  (with-buffer-output (buffer :index boffset :sizes 8)
-    (do* ((i (index+ buffer-boffset 1) (index+ i 1))	; Skip first byte
-	  (j 8 (index+ j 8)))		
-	 ((index>= j 256))
-      (declare (type array-index i j))
-      (do ((byte 0)
-	   (bit (index+ j 7) (index- bit 1)))
-	  ((index< bit j)
-	   (aset-card8 byte buffer-bbuf i))
-	(declare (type array-index bit)
-		 (type card8 byte))
-	(setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit))))))))
-
-;;; Writing sequences of char2b's
-
-(defun write-list-char2b (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type list data)
-	   (type array-index boffset start end))
-  (writing-buffer-chunks card16
-			 ((lst (nthcdr start data)))
-			 ((type list lst))
-    (do ((j 0 (index+ j 2)))
-	((index>= j (1- chunk)) (setf chunk j))
-      (declare (type array-index j))
-      (write-char2b j (pop lst))))
-  nil)
-
-(defun write-list-char2b-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type list data)
-	   (type array-index boffset start end))
-  (declare (type (function (t) card16) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (writing-buffer-chunks card16
-			 ((lst (nthcdr start data)))
-			 ((type list lst))
-    (do ((j 0 (index+ j 2)))
-	((index>= j (1- chunk)) (setf chunk j))
-      (declare (type array-index j))
-      (write-char2b j (funcall transform (pop lst)))))
-  nil)
-
-#-lispm
-(defun write-simple-array-char2b (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type (simple-array card16 (*)) data)
-	   (type array-index boffset start end))
-  (with-vector (data (simple-array card16 (*)))
-    (writing-buffer-chunks card16
-			   ((index start))
-			   ((type array-index index))
-      (do ((j 0 (index+ j 2)))
-	  ((index>= j (1- chunk)) (setf chunk j))
-	(declare (type array-index j))
-	(write-char2b j (aref data index))
-	(setq index (index+ index 1)))))
-  nil)
-
-#-lispm
-(defun write-simple-array-char2b-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type (simple-array card16 (*)) data)
-	   (type array-index boffset start end))
-  (declare (type (function (card16) card16) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data (simple-array card16 (*)))
-    (writing-buffer-chunks card16
-			   ((index start))
-			   ((type array-index index))
-      (do ((j 0 (index+ j 2)))
-	  ((index>= j (1- chunk)) (setf chunk j))
-	(declare (type array-index j))
-	(write-char2b j (funcall transform (aref data index)))
-	(setq index (index+ index 1)))))
-  nil)
-
-(defun write-vector-char2b (buffer boffset data start end)
-  (declare (type buffer buffer)
-	   (type vector data)
-	   (type array-index boffset start end))
-  (with-vector (data vector)
-    (writing-buffer-chunks card16
-			   ((index start))
-			   ((type array-index index))
-      (do ((j 0 (index+ j 2)))
-	  ((index>= j (1- chunk)) (setf chunk j))
-	(declare (type array-index j))
-	(write-char2b j (aref data index))
-	(setq index (index+ index 1)))))
-  nil)
-
-(defun write-vector-char2b-with-transform (buffer boffset data start end transform)
-  (declare (type buffer buffer)
-	   (type vector data)
-	   (type array-index boffset start end))
-  (declare (type (function (t) card16) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (with-vector (data vector)
-    (writing-buffer-chunks card16
-			   ((index start))
-			   ((type array-index index))
-      (do ((j 0 (index+ j 2)))
-	  ((index>= j (1- chunk)) (setf chunk j))
-	(declare (type array-index j))
-	(write-char2b j (funcall transform (aref data index)))
-	(setq index (index+ index 1)))))
-  nil)
-
-(defun write-sequence-char2b
-       (buffer boffset data &optional (start 0) (end (length data)) transform)
-  (declare (type buffer buffer)
-	   (type sequence data)
-	   (type array-index boffset start end))
-  (declare (type (or null (function (t) card16)) transform)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent transform)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg transform))
-  (typecase data
-    (list
-      (if transform
-	  (write-list-char2b-with-transform buffer boffset data start end transform)
-	  (write-list-char2b buffer boffset data start end)))
-    #-lispm
-    ((simple-array card16 (*))
-     (if transform
-	 (write-simple-array-char2b-with-transform buffer boffset data start end transform)
-	 (write-simple-array-char2b buffer boffset data start end)))
-    (t
-      (if transform
-	  (write-vector-char2b-with-transform buffer boffset data start end transform)
-	  (write-vector-char2b buffer boffset data start end)))))
-
diff --git a/clx/bufmac.lisp b/clx/bufmac.lisp
deleted file mode 100644
index 1e002b824dfa240e93c10b6bd2858ab36f44bb8c..0000000000000000000000000000000000000000
--- a/clx/bufmac.lisp
+++ /dev/null
@@ -1,184 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;; This file contains macro definitions for the BUFFER object for Common-Lisp
-;;; X windows version 11
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them.
-
-(defmacro write-card8 (byte-index item)
-  `(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))
-
-(defmacro write-int8 (byte-index item)
-  `(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))
-
-(defmacro write-card16 (byte-index item)
-  #+clx-overlapping-arrays
-  `(aset-card16 (the card16 ,item) buffer-wbuf
-		(index+ buffer-woffset (index-ash ,byte-index -1)))
-  #-clx-overlapping-arrays
-  `(aset-card16 (the card16 ,item) buffer-bbuf
-		(index+ buffer-boffset ,byte-index)))
-
-(defmacro write-int16 (byte-index item)
-  #+clx-overlapping-arrays
-  `(aset-int16 (the int16 ,item) buffer-wbuf
-	       (index+ buffer-woffset (index-ash ,byte-index -1)))
-  #-clx-overlapping-arrays
-  `(aset-int16 (the int16 ,item) buffer-bbuf
-	       (index+ buffer-boffset ,byte-index)))
-
-(defmacro write-card32 (byte-index item)
-  #+clx-overlapping-arrays
-  `(aset-card32 (the card32 ,item) buffer-lbuf
-		(index+ buffer-loffset (index-ash ,byte-index -2)))
-  #-clx-overlapping-arrays
-  `(aset-card32 (the card32 ,item) buffer-bbuf
-		(index+ buffer-boffset ,byte-index)))
-
-(defmacro write-int32 (byte-index item)
-  #+clx-overlapping-arrays
-  `(aset-int32 (the int32 ,item) buffer-lbuf
-	       (index+ buffer-loffset (index-ash ,byte-index -2)))
-  #-clx-overlapping-arrays
-  `(aset-int32 (the int32 ,item) buffer-bbuf
-	       (index+ buffer-boffset ,byte-index)))
-
-(defmacro write-card29 (byte-index item)
-  #+clx-overlapping-arrays
-  `(aset-card29 (the card29 ,item) buffer-lbuf
-		(index+ buffer-loffset (index-ash ,byte-index -2)))
-  #-clx-overlapping-arrays
-  `(aset-card29 (the card29 ,item) buffer-bbuf
-		(index+ buffer-boffset ,byte-index)))
-
-;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries
-;; and always are written high-order byte first.
-(defmacro write-char2b (byte-index item)
-  ;; It is impossible to do an overlapping write, so only nonoverlapping here.
-  `(let ((%item ,item)
-	 (%byte-index (index+ buffer-boffset ,byte-index)))
-     (declare (type card16 %item)
-	      (type array-index %byte-index))
-     (aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index)
-     (aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1))))
-
-(defmacro set-buffer-offset (value &environment env)
-  env
-  `(let ((.boffset. ,value))
-     (declare (type array-index .boffset.))
-     (setq buffer-boffset .boffset.)
-     #+clx-overlapping-arrays
-     ,@(when (member 16 (macroexpand '(%buffer-sizes) env))
-	 `((setq buffer-woffset (index-ash .boffset. -1))))
-     #+clx-overlapping-arrays
-     ,@(when (member 32 (macroexpand '(%buffer-sizes) env))
-	 `((setq buffer-loffset (index-ash .boffset. -2))))
-     #+clx-overlapping-arrays
-     .boffset.))
-
-(defmacro advance-buffer-offset (value)
-  `(set-buffer-offset (index+ buffer-boffset ,value)))
-
-(defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body)
-  (unless (listp sizes) (setq sizes (list sizes)))
-  `(let ((%buffer ,buffer))
-     (declare (type display %buffer))
-     ,(declare-bufmac)
-     ,(when length
-	`(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer))
-	   (buffer-flush %buffer)))
-     (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer))))
-	    #-clx-overlapping-arrays
-	    (buffer-bbuf (buffer-obuf8 %buffer))
-	    #+clx-overlapping-arrays
-	    ,@(append
-		(when (member 8 sizes)
-		  `((buffer-bbuf (buffer-obuf8 %buffer))))
-		(when (or (member 16 sizes) (member 160 sizes))
-		  `((buffer-woffset (index-ash buffer-boffset -1))
-		    (buffer-wbuf (buffer-obuf16 %buffer))))
-		(when (member 32 sizes)
-		  `((buffer-loffset (index-ash buffer-boffset -2))
-		    (buffer-lbuf (buffer-obuf32 %buffer))))))
-       (declare (type array-index buffer-boffset))
-       #-clx-overlapping-arrays
-       (declare (type buffer-bytes buffer-bbuf))
-       #+clx-overlapping-arrays
-       ,@(append
-	   (when (member 8  sizes)
-	     '((declare (type buffer-bytes buffer-bbuf))))
-	   (when (member 16 sizes)
-	     '((declare (type array-index buffer-woffset))
-	       (declare (type buffer-words buffer-wbuf))))
-	   (when (member 32 sizes)
-	     '((declare (type array-index buffer-loffset))
-	       (declare (type buffer-longs buffer-lbuf)))))
-       buffer-boffset
-       #-clx-overlapping-arrays
-       buffer-bbuf
-       #+clx-overlapping-arrays
-       ,@(append
-	   (when (member 8  sizes) '(buffer-bbuf))
-	   (when (member 16 sizes) '(buffer-woffset buffer-wbuf))
-	   (when (member 32 sizes) '(buffer-loffset buffer-lbuf)))
-       #+clx-overlapping-arrays
-       (macrolet ((%buffer-sizes () ',sizes))
-	 ,@body)
-       #-clx-overlapping-arrays
-       ,@body)))
-
-;;; This macro is just used internally in buffer
-
-(defmacro writing-buffer-chunks (type args decls &body body)
-  (when (> (length body) 2)
-    (error "writing-buffer-chunks called with too many forms"))
-  (let* ((size (* 8 (index-increment type)))
-	 (form #-clx-overlapping-arrays
-	       (first body)
-	       #+clx-overlapping-arrays		; XXX type dependencies
-	       (or (second body)
-		   (first body))))
-    `(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8))))
-       ;; Loop filling the buffer
-       (do* (,@args
-	     ;; Number of bytes needed to output
-	     (len ,(if (= size 8)
-		       `(index- end start)
-		       `(index-ash (index- end start) ,(truncate size 16)))
-		  (index- len chunk))
-	     ;; Number of bytes available in buffer
-	     (chunk (index-min len (index- (buffer-size buffer) buffer-boffset))
-		    (index-min len (index- (buffer-size buffer) buffer-boffset))))
-	    ((not (index-plusp len)))
-	 (declare ,@decls
-		  (type array-index len chunk))
-	 ,form
-	 (index-incf buffer-boffset chunk)
-	 ;; Flush the buffer
-	 (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer)))
-	   (setf (buffer-boffset buffer) buffer-boffset)
-	   (buffer-flush buffer)
-	   (setq buffer-boffset (buffer-boffset buffer))
-	   #+clx-overlapping-arrays
-	   ,(case size
-	      (16 '(setq buffer-woffset (index-ash buffer-boffset -1)))
-	      (32 '(setq buffer-loffset (index-ash buffer-boffset -2))))))
-       (setf (buffer-boffset buffer) (lround buffer-boffset))))) 
diff --git a/clx/build-clx.lisp b/clx/build-clx.lisp
deleted file mode 100644
index 09673145192b43fad394b5ece2fe675d61e087f7..0000000000000000000000000000000000000000
--- a/clx/build-clx.lisp
+++ /dev/null
@@ -1,25 +0,0 @@
-;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
-
-;;; Load this file if you want to compile CLX in its entirety.
-#+nil
-(proclaim '(optimize (speed 3) (safety 0) (space 1)
-		     (compilation-speed 0)))
-
-
-;;; Hide CLOS from CLX, so objects stay implemented as structures.
-;;;
-(when (find-package "CLOS")
-  (rename-package (find-package "CLOS") "NO-CLOS-HERE"))
-(when (find-package "PCL")
-  (rename-package (find-package "PCL") "NO-PCL-HERE"))
-
-
-(when (find-package "XLIB")
-  (rename-package (find-package "XLIB") "OLD-XLIB"))
-
-;(make-package "XLIB" :use '("LISP"))
-
-(compile-file "clx:defsystem.lisp" :error-file nil :load t)
-
-(with-compilation-unit ()
-  (xlib:compile-clx (pathname "clx:")))
diff --git a/clx/clx.lisp b/clx/clx.lisp
deleted file mode 100644
index ab87349231dd132e6f183950124968b06f60d3c7..0000000000000000000000000000000000000000
--- a/clx/clx.lisp
+++ /dev/null
@@ -1,922 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-;; Primary Interface Author:
-;;	Robert W. Scheifler
-;;	MIT Laboratory for Computer Science
-;;	545 Technology Square, Room 418
-;;	Cambridge, MA 02139
-;;	rws@zermatt.lcs.mit.edu
-
-;; Design Contributors:
-;;	Dan Cerys, Texas Instruments
-;;	Scott Fahlman, CMU
-;;      Charles Hornig, Symbolics
-;;      John Irwin, Franz
-;;	Kerry Kimbrough, Texas Instruments
-;;	Chris Lindblad, MIT
-;;	Rob MacLachlan, CMU
-;;	Mike McMahon, Symbolics
-;;	David Moon, Symbolics
-;;	LaMott Oren, Texas Instruments
-;;	Daniel Weinreb, Symbolics
-;;	John Wroclawski, MIT
-;;	Richard Zippel, Symbolics
-
-;; Primary Implementation Author:
-;;	LaMott Oren, Texas Instruments
-
-;; Implementation Contributors:
-;;      Charles Hornig, Symbolics
-;;      John Irwin, Franz
-;;	Chris Lindblad, MIT
-;;	Robert Scheifler, MIT
-
-;;;
-;;; Change history:
-;;;
-;;;  Date	Author		Description
-;;; -------------------------------------------------------------------------------------
-;;; 04/07/87	R.Scheifler	Created code stubs
-;;; 04/08/87	L.Oren		Started Implementation
-;;; 05/11/87	L.Oren		Included draft 3 revisions
-;;; 07/07/87	L.Oren		Untested alpha release to MIT
-;;; 07/17/87	L.Oren		Alpha release
-;;; 08/**/87	C.Lindblad	Rewrite of buffer code
-;;; 08/**/87	et al		Various random bug fixes
-;;; 08/**/87	R.Scheifler	General syntactic and portability cleanups
-;;; 08/**/87	R.Scheifler	Rewrite of gcontext caching and shadowing
-;;; 09/02/87	L.Oren		Change events from resource-ids to objects
-;;; 12/24/87	R.Budzianowski	KCL support
-;;; 12/**/87	J.Irwin		ExCL 2.0 support
-;;; 01/20/88	L.Oren		Add server extension mechanisms
-;;; 01/20/88	L.Oren		Only force output when blocking on input
-;;; 01/20/88	L.Oren		Uniform support for :event-window on events
-;;; 01/28/88	L.Oren		Add window manager property functions
-;;; 01/28/88	L.Oren		Add character translation facility
-;;; 02/**/87	J.Irwin		Allegro 2.2 support
-
-;;; This is considered a somewhat changeable interface.  Discussion of better
-;;; integration with CLOS, support for user-specified subclassess of basic
-;;; objects, and the additional functionality to match the C Xlib is still in
-;;; progress.  Bug reports should be addressed to bug-clx@expo.lcs.mit.edu.
-
-;; Note: all of the following is in the package XLIB.
-
-(in-package :xlib)
-
-(pushnew :clx *features*)
-(pushnew :xlib *features*)
-
-(defparameter *version* "MIT R5.01")
-(pushnew :clx-mit-r4 *features*)
-(pushnew :clx-mit-r5 *features*)
-
-(defparameter *protocol-major-version* 11.)
-(defparameter *protocol-minor-version* 0)
-
-(defparameter *x-tcp-port* 6000) ;; add display number
-
-;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of
-;; the relationships should be fairly obvious.  We have no intention of writing yet
-;; another moby document for this interface.
-
-;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color.
-;; These types are defined solely by a functional interface; we do not specify
-;; whether they are implemented as structures or flavors or ...  Although functions
-;; below are written using DEFUN, this is not an implementation requirement (although
-;; it is a requirement that they be functions as opposed to macros or special forms).
-;; It is unclear whether with-slots in the Common Lisp Object System must work on
-;; them.
-
-;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as
-;; compound objects, rather than as integer resource-ids.  This allows applications
-;; to deal with multiple displays without having an explicit display argument in the
-;; most common functions.  Every function uses the display object indicated by the
-;; first argument that is or contains a display; it is an error if arguments contain
-;; different displays, and predictable results are not guaranteed.
-
-;; Each of window, pixmap, cursor, font, gcontext, and colormap have the following
-;; five functions:
-
-;(defun make-<mumble> (display resource-id)
-;  ;; This function should almost never be called by applications, except in handling
-;  ;; events.  To minimize consing in some implementations, this may use a cache in
-;  ;; the display.  Make-gcontext creates with :cache-p nil.  Make-font creates with
-;  ;; cache-p true.
-;  (declare (type display display)
-;	   (type integer resource-id)
-;	   (clx-values <mumble>)))
-
-;(defun <mumble>-display (<mumble>)
-;  (declare (type <mumble> <mumble>)
-;	   (clx-values display)))
-
-;(defun <mumble>-id (<mumble>)
-;  (declare (type <mumble> <mumble>)
-;	   (clx-values integer)))
-
-;(defun <mumble>-equal (<mumble>-1 <mumble>-2)
-;  (declare (type <mumble> <mumble>-1 <mumble>-2)))
-
-;(defun <mumble>-p (<mumble>-1 <mumble>-2)
-;  (declare (type <mumble> <mumble>-1 <mumble>-2)
-;	   (clx-values boolean)))
-
-(deftype boolean () '(or null (not null)))
-
-(deftype card32 () '(unsigned-byte 32))
-
-(deftype card29 () '(unsigned-byte 29))
-
-(deftype card24 () '(unsigned-byte 24))
-
-(deftype int32 () '(signed-byte 32))
-
-(deftype card16 () '(unsigned-byte 16))
-
-(deftype int16 () '(signed-byte 16))
-
-(deftype card8 () '(unsigned-byte 8))
-
-(deftype int8 () '(signed-byte 8))
-
-(deftype card4 () '(unsigned-byte 4))
-
-#-clx-ansi-common-lisp
-(deftype real (&optional (min '*) (max '*))
-  (labels ((convert (limit floatp)
-	     (typecase limit
-	       (number (if floatp (float limit 0s0) (rational limit)))
-	       (list (map 'list #'convert limit))
-	       (otherwise limit))))
-    `(or (float ,(convert min t) ,(convert max t))
-	 (rational ,(convert min nil) ,(convert max nil)))))
-
-#-clx-ansi-common-lisp
-(deftype base-char ()
-  'string-char)
-
-; Note that we are explicitly using a different rgb representation than what
-; is actually transmitted in the protocol.
-
-(deftype rgb-val () '(real 0 1))
-
-; Note that we are explicitly using a different angle representation than what
-; is actually transmitted in the protocol.
-
-(deftype angle () '(real #.(* -2 pi) #.(* 2 pi)))
-
-(deftype mask32 () 'card32)
-
-(deftype mask16 () 'card16)
-
-(deftype pixel () '(unsigned-byte 32))
-(deftype image-depth () '(integer 0 32))
-
-(deftype resource-id () 'card29)
-
-(deftype keysym () 'card32)
-
-; The following functions are provided by color objects:
-
-; The intention is that IHS and YIQ and CYM interfaces will also exist.
-; Note that we are explicitly using a different spectrum representation
-; than what is actually transmitted in the protocol.
-
-(def-clx-class (color (:constructor make-color-internal (red green blue))
-		      (:copier nil) (:print-function print-color))
-  (red 0.0 :type rgb-val)
-  (green 0.0 :type rgb-val)
-  (blue 0.0 :type rgb-val))
-
-(defun print-color (color stream depth)
-  (declare (type color color)
-	   (ignore depth))
-  (print-unreadable-object (color stream :type t)
-    (prin1 (color-red color) stream)
-    (write-string " " stream)
-    (prin1 (color-green color) stream)
-    (write-string " " stream)
-    (prin1 (color-blue color) stream)))
-
-(defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys)
-  (declare (type rgb-val red green blue))
-  (declare (clx-values color))
-  (make-color-internal red green blue))
-
-(defun color-rgb (color)
-  (declare (type color color))
-  (declare (clx-values red green blue))
-  (values (color-red color) (color-green color) (color-blue color)))
-
-(def-clx-class (bitmap-format (:copier nil) (:print-function print-bitmap-format))
-  (unit 8 :type (member 8 16 32))
-  (pad 8 :type (member 8 16 32))
-  (lsb-first-p nil :type boolean))
-
-(defun print-bitmap-format (bitmap-format stream depth)
-  (declare (type bitmap-format bitmap-format)
-	   (ignore depth))
-  (print-unreadable-object (bitmap-format stream :type t)
-    (format stream "unit ~D pad ~D ~:[M~;L~]SB first"
-	    (bitmap-format-unit bitmap-format)
-	    (bitmap-format-pad bitmap-format)
-	    (bitmap-format-lsb-first-p bitmap-format))))
-
-(def-clx-class (pixmap-format (:copier nil) (:print-function print-pixmap-format))
-  (depth 0 :type image-depth)
-  (bits-per-pixel 8 :type (member 1 4 8 16 24 32))
-  (scanline-pad 8 :type (member 8 16 32)))
-
-(defun print-pixmap-format (pixmap-format stream depth)
-  (declare (type pixmap-format pixmap-format)
-	   (ignore depth))
-  (print-unreadable-object (pixmap-format stream :type t)
-    (format stream "depth ~D bits-per-pixel ~D scanline-pad ~D"
-	    (pixmap-format-depth pixmap-format)
-	    (pixmap-format-bits-per-pixel pixmap-format)
-	    (pixmap-format-scanline-pad pixmap-format))))
-
-(defparameter *atom-cache-size* 200)
-(defparameter *resource-id-map-size* 500)
-
-(def-clx-class (display (:include buffer)
-			(:constructor make-display-internal)
-			(:print-function print-display)
-			(:copier nil))
-  (host)					; Server Host
-  (display 0 :type integer)			; Display number on host
-  (after-function nil)				; Function to call after every request
-  (event-lock
-    (make-process-lock "CLX Event Lock"))	; with-event-queue lock
-  (event-queue-lock
-    (make-process-lock "CLX Event Queue Lock"))	; new-events/event-queue lock
-  (event-queue-tail				; last event in the event queue
-    nil :type (or null reply-buffer))
-  (event-queue-head				; Threaded queue of events
-    nil :type (or null reply-buffer))
-  (atom-cache (make-hash-table :test (atom-cache-map-test) :size *atom-cache-size*)
-	      :type hash-table)			; Hash table relating atoms keywords
-						; to atom id's
-  (font-cache nil)				; list of font
-  (protocol-major-version 0 :type card16)	; Major version of server's X protocol
-  (protocol-minor-version 0 :type card16)	; minor version of servers X protocol
-  (vendor-name "" :type string)			; vendor of the server hardware
-  (resource-id-base 0 :type resource-id)	; resouce ID base
-  (resource-id-mask 0 :type resource-id)	; resource ID mask bits
-  (resource-id-byte nil)			; resource ID mask field (used with DPB & LDB)
-  (resource-id-count 0 :type resource-id)	; resource ID mask count
-						; (used for allocating ID's)
-  (resource-id-map (make-hash-table :test (resource-id-map-test)
-				    :size *resource-id-map-size*)
-		   :type hash-table)		; hash table maps resource-id's to
-						; objects (used in lookup functions)
-  (xid 'resourcealloc)				; allocator function
-  (byte-order #+clx-little-endian :lsbfirst     ; connection byte order
-	      #-clx-little-endian :msbfirst)
-  (release-number 0 :type card32)		; release of the server
-  (max-request-length 0 :type card16)		; maximum number 32 bit words in request
-  (default-screen)				; default screen for operations
-  (roots nil :type list)			; List of screens
-  (motion-buffer-size 0 :type card32)		; size of motion buffer
-  (xdefaults)					; contents of defaults from server
-  (image-lsb-first-p nil :type boolean)
-  (bitmap-format (make-bitmap-format)		; Screen image info
-		 :type bitmap-format)
-  (pixmap-formats nil :type sequence)		; list of pixmap formats
-  (min-keycode 0 :type card8)			; minimum key-code
-  (max-keycode 0 :type card8)			; maximum key-code
-  (error-handler 'default-error-handler)	; Error handler function
-  (close-down-mode :destroy)  			; Close down mode saved by Set-Close-Down-Mode
-  (authorization-name "" :type string)
-  (authorization-data "" :type string)
-  (last-width nil :type (or null card29))	; Accumulated width of last string
-  (keysym-mapping nil				; Keysym mapping cached from server
-		  :type (or null (array * (* *))))
-  (modifier-mapping nil :type list)		; ALIST of (keysym . state-mask) for all modifier keysyms
-  (keysym-translation nil :type list)		; An alist of (keysym object function)
-						; for display-local keysyms
-  (extension-alist nil :type list)		; extension alist, which has elements:
-						; (name major-opcode first-event first-error)
-  (event-extensions '#() :type vector)		; Vector mapping X event-codes to event keys
-  (performance-info)				; Hook for gathering performance info
-  (trace-history)				; Hook for debug trace
-  (plist nil :type list)			; hook for extension to hang data
-  ;; These slots are used to manage multi-process input.
-  (input-in-progress nil)			; Some process reading from the stream.
-						; Updated with CONDITIONAL-STORE.
-  (pending-commands nil)			; Threaded list of PENDING-COMMAND objects 
-						; for all commands awaiting replies.
-						; Protected by WITH-EVENT-QUEUE-INTERNAL.
-  (asynchronous-errors nil)			; Threaded list of REPLY-BUFFER objects
-						; containing error messages for commands
-						; which did not expect replies.
-						; Protected by WITH-EVENT-QUEUE-INTERNAL.
-  (report-asynchronous-errors			; When to report asynchronous errors
-    '(:immediately) :type list)			; The keywords that can be on this list 
-						; are :IMMEDIATELY, :BEFORE-EVENT-HANDLING,
-						; and :AFTER-FINISH-OUTPUT
-  (event-process nil)				; Process ID of process awaiting events.
-						; Protected by WITH-EVENT-QUEUE.
-  (new-events nil :type (or null reply-buffer))	; Pointer to the first new event in the
-						; event queue.
-						; Protected by WITH-EVENT-QUEUE.
-  (current-event-symbol				; Bound with PROGV by event handling macros 
-    (list (gensym) (gensym)) :type cons)
-  (atom-id-map (make-hash-table :test (resource-id-map-test)
-				:size *atom-cache-size*)
-	       :type hash-table)
-  )
-
-(defun print-display-name (display stream)
-  (declare (type (or null display) display))
-  (cond (display
-	 #-allegro (princ (display-host display) stream)
-	 #+allegro (write-string (string (display-host display)) stream)
-	 (write-string ":" stream)
-	 (princ (display-display display) stream))
-	(t
-	 (write-string "(no display)" stream)))
-  display)
-
-(defun print-display (display stream depth)
-  (declare (type display display)
-	   (ignore depth))
-  (print-unreadable-object (display stream :type t)
-    (print-display-name display stream)
-    (write-string " (" stream)
-    (write-string (display-vendor-name display) stream)
-    (write-string " R" stream)
-    (prin1 (display-release-number display) stream)
-    (write-string ")" stream)))
-
-;;(deftype drawable () '(or window pixmap))
-
-(def-clx-class (drawable (:copier nil) (:print-function print-drawable))
-  (id 0 :type resource-id)
-  (display nil :type (or null display))
-  (plist nil :type list)			; Extension hook
-  )
-
-(defun print-drawable (drawable stream depth)
-  (declare (type drawable drawable)
-	   (ignore depth))
-  (print-unreadable-object (drawable stream :type t)
-    (print-display-name (drawable-display drawable) stream)
-    (write-string " " stream)
-    (prin1 (drawable-id drawable) stream)))
-
-(def-clx-class (window (:include drawable) (:copier nil)
-		       (:print-function print-drawable))
-  )
-
-(def-clx-class (pixmap (:include drawable) (:copier nil)
-		       (:print-function print-drawable))
-  )
-
-(def-clx-class (visual-info (:copier nil) (:print-function print-visual-info))
-  (id 0 :type resource-id)
-  (display nil :type (or null display))
-  (class :static-gray :type (member :static-gray :static-color :true-color
-				    :gray-scale :pseudo-color :direct-color))
-  (red-mask 0 :type pixel)
-  (green-mask 0 :type pixel)
-  (blue-mask 0 :type pixel)
-  (bits-per-rgb 1 :type card8)
-  (colormap-entries 0 :type card16)
-  (plist nil :type list)			; Extension hook
-  )
-
-(defun print-visual-info (visual-info stream depth)
-  (declare (type visual-info visual-info)
-	   (ignore depth))
-  (print-unreadable-object (visual-info stream :type t)
-    (prin1 (visual-info-bits-per-rgb visual-info) stream)
-    (write-string "-bit " stream)
-    (princ (visual-info-class visual-info) stream)
-    (write-string " " stream)
-    (print-display-name (visual-info-display visual-info) stream)
-    (write-string " " stream)
-    (prin1 (visual-info-id visual-info) stream)))
-
-(def-clx-class (colormap (:copier nil) (:print-function print-colormap))
-  (id 0 :type resource-id)
-  (display nil :type (or null display))
-  (visual-info nil :type (or null visual-info))
-  )
-
-(defun print-colormap (colormap stream depth)
-  (declare (type colormap colormap)
-	   (ignore depth))
-  (print-unreadable-object (colormap stream :type t)
-    (when (colormap-visual-info colormap)
-      (princ (visual-info-class (colormap-visual-info colormap)) stream)
-      (write-string " " stream))
-    (print-display-name (colormap-display colormap) stream)
-    (write-string " " stream)
-    (prin1 (colormap-id colormap) stream)))
-
-(def-clx-class (cursor (:copier nil) (:print-function print-cursor))
-  (id 0 :type resource-id)
-  (display nil :type (or null display))
-  )
-
-(defun print-cursor (cursor stream depth)
-  (declare (type cursor cursor)
-	   (ignore depth))
-  (print-unreadable-object (cursor stream :type t)
-    (print-display-name (cursor-display cursor) stream)
-    (write-string " " stream)
-    (prin1 (cursor-id cursor) stream)))
-
-; Atoms are accepted as strings or symbols, and are always returned as keywords.
-; Protocol-level integer atom ids are hidden, using a cache in the display object.
-
-(deftype xatom () '(or string symbol))
-
-(defconstant *predefined-atoms*
-	     '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP
-		    :CARDINAL :COLORMAP :CURSOR
-		    :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
-		    :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7
-		    :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE
-		    :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP
-		    :RGB_BLUE_MAP :RGB_DEFAULT_MAP
-		    :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING
-		    :VISUALID :WINDOW :WM_COMMAND :WM_HINTS
-		    :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE
-		    :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS
-		    :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE
-		    :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y
-		    :SUBSCRIPT_X :SUBSCRIPT_Y
-		    :UNDERLINE_POSITION :UNDERLINE_THICKNESS
-		    :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT
-		    :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT
-		    :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE
-		    :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT
-		    :WM_CLASS :WM_TRANSIENT_FOR))
-
-(deftype stringable () '(or string symbol))
-
-(deftype fontable () '(or stringable font))
-
-; Nil stands for CurrentTime.
-
-(deftype timestamp () '(or null card32))
-
-(defconstant *bit-gravity-vector*
-	     '#(:forget :north-west :north :north-east :west
-		:center :east :south-west :south
-		:south-east :static))
-
-(deftype bit-gravity ()
-  '(member :forget :north-west :north :north-east :west
-	   :center :east :south-west :south :south-east :static))
-
-(defconstant *win-gravity-vector*
-	     '#(:unmap :north-west :north :north-east :west
-		:center :east :south-west :south :south-east
-		:static))
-
-(deftype win-gravity ()
-  '(member :unmap :north-west :north :north-east :west
-	   :center :east :south-west :south :south-east :static))
-
-(deftype grab-status ()
-  '(member :success :already-grabbed :invalid-time :not-viewable))
-
-; An association list.
-
-(deftype alist (key-type-and-name datum-type-and-name)
-  (declare (ignore key-type-and-name datum-type-and-name))
-  'list)
-
-(deftype clx-list (&optional element-type) (declare (ignore element-type)) 'list)
-(deftype clx-sequence (&optional element-type) (declare (ignore element-type)) 'sequence)
-
-; A sequence, containing zero or more repetitions of the given elements,
-; with the elements expressed as (type name).
-
-(deftype repeat-seq (&rest elts) elts 'sequence)
-
-(deftype point-seq () '(repeat-seq (int16 x) (int16 y)))
-
-(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)))
-
-(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)))
-
-(deftype arc-seq ()
-  '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)
-	       (angle angle1) (angle angle2)))
-
-(deftype gcontext-state () 'simple-vector)
-
-(def-clx-class (gcontext (:copier nil) (:print-function print-gcontext))
-  ;; The accessors convert to CLX data types.
-  (id 0 :type resource-id)
-  (display nil :type (or null display))
-  (drawable nil :type (or null drawable))
-  (cache-p t :type boolean)
-  (server-state (allocate-gcontext-state) :type gcontext-state)
-  (local-state (allocate-gcontext-state) :type gcontext-state)
-  (plist nil :type list)			; Extension hook
-  (next nil #-explorer :type #-explorer (or null gcontext))
-  )
-
-(defun print-gcontext (gcontext stream depth)
-  (declare (type gcontext gcontext)
-	   (ignore depth))
-  (print-unreadable-object (gcontext stream :type t)
-    (print-display-name (gcontext-display gcontext) stream)
-    (write-string " " stream)
-    (prin1 (gcontext-id gcontext) stream)))
-
-(defconstant *event-mask-vector*
-	     '#(:key-press :key-release :button-press :button-release
-		:enter-window :leave-window :pointer-motion :pointer-motion-hint
-		:button-1-motion :button-2-motion :button-3-motion :button-4-motion
-		:button-5-motion :button-motion :keymap-state :exposure :visibility-change
-		:structure-notify :resize-redirect :substructure-notify :substructure-redirect
-		:focus-change :property-change :colormap-change :owner-grab-button))
-
-(deftype event-mask-class ()
-  '(member :key-press :key-release :owner-grab-button :button-press :button-release
-	   :enter-window :leave-window :pointer-motion :pointer-motion-hint
-	   :button-1-motion :button-2-motion :button-3-motion :button-4-motion
-	   :button-5-motion :button-motion :exposure :visibility-change
-	   :structure-notify :resize-redirect :substructure-notify :substructure-redirect
-	   :focus-change :property-change :colormap-change :keymap-state))
-
-(deftype event-mask ()
-  '(or mask32 (clx-list event-mask-class)))
-
-(defconstant *pointer-event-mask-vector*
-	     '#(%error %error :button-press :button-release
-		:enter-window :leave-window :pointer-motion :pointer-motion-hint
-		:button-1-motion :button-2-motion :button-3-motion :button-4-motion
-		:button-5-motion :button-motion :keymap-state))
-
-(deftype pointer-event-mask-class ()
-  '(member :button-press :button-release
-	   :enter-window :leave-window :pointer-motion :pointer-motion-hint
-	   :button-1-motion :button-2-motion :button-3-motion :button-4-motion
-	   :button-5-motion :button-motion :keymap-state))
-
-(deftype pointer-event-mask ()
-  '(or mask32 (clx-list pointer-event-mask-class)))
-
-(defconstant *device-event-mask-vector*
-	     '#(:key-press :key-release :button-press :button-release :pointer-motion
-		:button-1-motion :button-2-motion :button-3-motion :button-4-motion
-		:button-5-motion :button-motion))
-
-(deftype device-event-mask-class ()
-  '(member :key-press :key-release :button-press :button-release :pointer-motion
-	   :button-1-motion :button-2-motion :button-3-motion :button-4-motion
-	   :button-5-motion :button-motion))
-
-(deftype device-event-mask ()
-  '(or mask32 (clx-list device-event-mask-class)))
-
-(defconstant *state-mask-vector*
-	     '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5
-		:button-1 :button-2 :button-3 :button-4 :button-5))
-
-(deftype modifier-key ()
-  '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
-
-(deftype modifier-mask ()
-  '(or (member :any) mask16 (clx-list modifier-key)))
-
-(deftype state-mask-key ()
-  '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
-
-(defconstant *gcontext-components*
-	     '(:function :plane-mask :foreground :background
-	       :line-width :line-style :cap-style :join-style :fill-style
-	       :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
-	       :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
-	       :arc-mode))
-
-(deftype gcontext-key ()
-  '(member :function :plane-mask :foreground :background
-	   :line-width :line-style :cap-style :join-style :fill-style
-	   :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
-	   :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
-	   :arc-mode))
-
-(deftype event-key ()
-  '(member :key-press :key-release :button-press :button-release :motion-notify
-	   :enter-notify :leave-notify :focus-in :focus-out :keymap-notify
-	   :exposure :graphics-exposure :no-exposure :visibility-notify
-	   :create-notify :destroy-notify :unmap-notify :map-notify :map-request
-	   :reparent-notify :configure-notify :gravity-notify :resize-request
-	   :configure-request :circulate-notify :circulate-request :property-notify
-	   :selection-clear :selection-request :selection-notify
-	   :colormap-notify :client-message :mapping-notify))
-
-(deftype error-key ()
-  '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
-	   :illegal-request :implementation :length :match :name :pixmap :value :window))
-
-(deftype draw-direction ()
-  '(member :left-to-right :right-to-left))
-
-(defconstant *boole-vector*
-	     '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1
-		#.boole-andc1 #.boole-2 #.boole-xor #.boole-ior
-		#.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2
-		#.boole-c1 #.boole-orc1 #.boole-nand #.boole-set))
-
-(deftype boole-constant ()
-  `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1
-	   ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior
-	   ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2
-	   ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set))
-
-(def-clx-class (screen (:copier nil) (:print-function print-screen))
-  (root nil :type (or null window))
-  (width 0 :type card16)
-  (height 0 :type card16)
-  (width-in-millimeters 0 :type card16)
-  (height-in-millimeters 0 :type card16)
-  (depths nil :type (alist (image-depth depth) ((clx-list visual-info) visuals)))
-  (root-depth 1 :type image-depth)
-  (root-visual-info nil :type (or null visual-info))
-  (default-colormap nil :type (or null colormap))
-  (white-pixel 0 :type pixel)
-  (black-pixel 1 :type pixel)
-  (min-installed-maps 1 :type card16)
-  (max-installed-maps 1 :type card16)
-  (backing-stores :never :type (member :never :when-mapped :always))
-  (save-unders-p nil :type boolean)
-  (event-mask-at-open 0 :type mask32)
-  (plist nil :type list)			; Extension hook
-  )
-
-(defun print-screen (screen stream depth)
-  (declare (type screen screen)
-	   (ignore depth))
-  (print-unreadable-object (screen stream :type t)
-    (let ((display (drawable-display (screen-root screen))))
-      (print-display-name display stream)
-      (write-string "." stream)
-      (princ (position screen (display-roots display)) stream))
-    (write-string " " stream)
-    (prin1 (screen-width screen) stream)
-    (write-string "x" stream)
-    (prin1 (screen-height screen) stream)
-    (write-string "x" stream)
-    (prin1 (screen-root-depth screen) stream)
-    (when (screen-root-visual-info screen)
-      (write-string " " stream)
-      (princ (visual-info-class (screen-root-visual-info screen)) stream))))
-
-(defun screen-root-visual (screen)
-  (declare (type screen screen)
-	   (clx-values resource-id))
-  (visual-info-id (screen-root-visual-info screen)))
-
-;; The list contains alternating keywords and integers.
-(deftype font-props () 'list)
-
-(def-clx-class (font-info (:copier nil) (:predicate nil))
-  (direction :left-to-right :type draw-direction)
-  (min-char 0 :type card16)   ;; First character in font
-  (max-char 0 :type card16)   ;; Last character in font
-  (min-byte1 0 :type card8)   ;; The following are for 16 bit fonts
-  (max-byte1 0 :type card8)   ;; and specify min&max values for
-  (min-byte2 0 :type card8)   ;; the two character bytes
-  (max-byte2 0 :type card8)
-  (all-chars-exist-p nil :type boolean)
-  (default-char 0 :type card16)
-  (min-bounds nil :type (or null vector))
-  (max-bounds nil :type (or null vector))
-  (ascent 0 :type int16)
-  (descent 0 :type int16)
-  (properties nil :type font-props))
-
-(def-clx-class (font (:constructor make-font-internal) (:copier nil)
-		     (:print-function print-font))
-  (id-internal nil :type (or null resource-id)) ;; NIL when not opened
-  (display nil :type (or null display))
-  (reference-count 0 :type fixnum)
-  (name "" :type (or null string)) ;; NIL when ID is for a GContext
-  (font-info-internal nil :type (or null font-info))
-  (char-infos-internal nil :type (or null (simple-array int16 (*))))
-  (local-only-p t :type boolean) ;; When T, always calculate text extents locally
-  (plist nil :type list)			; Extension hook
-  )
-
-(defun print-font (font stream depth)
-  (declare (type font font)
-	   (ignore depth))
-  (print-unreadable-object (font stream :type t)
-    (if (font-name font)
-	(princ (font-name font) stream)
-      (write-string "(gcontext)" stream))
-    (write-string " " stream)
-    (print-display-name (font-display font) stream)
-    (when (font-id-internal font)
-      (write-string " " stream)
-      (prin1 (font-id font) stream))))
-
-(defun font-id (font)
-  ;; Get font-id, opening font if needed
-  (or (font-id-internal font)
-      (open-font-internal font)))
-
-(defun font-font-info (font)
-  (or (font-font-info-internal font)
-      (query-font font)))
-
-(defun font-char-infos (font)
-  (or (font-char-infos-internal font)
-      (progn (query-font font)
-	     (font-char-infos-internal font))))
-
-(defun make-font (&key id
-		  display
-		  (reference-count 0)
-		  (name "")
-		  (local-only-p t)
-		  font-info-internal)
-  (make-font-internal :id-internal id
-		      :display display
-		      :reference-count reference-count
-		      :name name
-		      :local-only-p local-only-p
-		      :font-info-internal font-info-internal))
-
-; For each component (<name> <unspec> :type <type>) of font-info,
-; there is a corresponding function:
-
-;(defun font-<name> (font)
-;  (declare (type font font)
-;	   (clx-values <type>)))
-
-(macrolet ((make-font-info-accessors (useless-name &body fields)
-	     `(within-definition (,useless-name make-font-info-accessors)
-		,@(mapcar
-		    #'(lambda (field)
-			(let* ((type (second field))
-			       (n (string (first field)))
-			       (name (xintern 'font- n))
-			       (accessor (xintern 'font-info- n)))
-			  `(defun ,name (font)
-			     (declare (type font font))
-			     (declare (clx-values ,type))
-			     (,accessor (font-font-info font)))))
-		    fields))))
-  (make-font-info-accessors ignore
-    (direction draw-direction)
-    (min-char card16)
-    (max-char card16)
-    (min-byte1 card8)
-    (max-byte1 card8)
-    (min-byte2 card8)
-    (max-byte2 card8)
-    (all-chars-exist-p boolean)
-    (default-char card16)
-    (min-bounds vector)
-    (max-bounds vector)
-    (ascent int16)
-    (descent int16)
-    (properties font-props)))
-
-(defun font-property (font name)
-  (declare (type font font)
-	   (type keyword name))
-  (declare (clx-values (or null int32)))
-  (getf (font-properties font) name))
-
-(macrolet ((make-mumble-equal (type)
-	     ;; When cached, EQ works fine, otherwise test resource id's and displays
-	     (let ((predicate (xintern type '-equal))
-		   (id (xintern type '-id))
-		   (dpy (xintern type '-display)))
-	       (if (member type *clx-cached-types*)
-		   `(within-definition (,type make-mumble-equal)
-		      (declaim (inline ,predicate))
-		      (defun ,predicate (a b) (eq a b)))
-		   `(within-definition (,type make-mumble-equal)
-		      (defun ,predicate (a b)
-			(declare (type ,type a b))
-			(and (= (,id a) (,id b))
-			     (eq (,dpy a) (,dpy b)))))))))
-  (make-mumble-equal window)
-  (make-mumble-equal pixmap)
-  (make-mumble-equal cursor)
-  (make-mumble-equal font)
-  (make-mumble-equal gcontext)
-  (make-mumble-equal colormap)
-  (make-mumble-equal drawable))
-
-;;;
-;;; Event-mask encode/decode functions
-;;;    Converts from keyword-lists to integer and back
-;;;
-(defun encode-mask (key-vector key-list key-type)
-  ;; KEY-VECTOR is a vector containg bit-position keywords.  The position of the
-  ;; keyword in the vector indicates its bit position in the resulting mask
-  ;; KEY-LIST is either a mask or a list of KEY-TYPE
-  ;; Returns NIL when KEY-LIST is not a list or mask.
-  (declare (type (simple-array keyword (*)) key-vector)
-	   (type (or mask32 list) key-list))
-  (declare (clx-values (or mask32 null)))
-  (typecase key-list
-    (mask32 key-list)
-    (list (let ((mask 0))
-	    (dolist (key key-list mask)
-	      (let ((bit (position key (the vector key-vector) :test #'eq)))
-		(unless bit
-		  (x-type-error key key-type))
-		(setq mask (logior mask (ash 1 bit)))))))))
-
-(defun decode-mask (key-vector mask)
-  (declare (type (simple-array keyword (*)) key-vector)
-	   (type mask32 mask))
-  (declare (clx-values list))
-  (do ((m mask (ash m -1))
-       (bit 0 (1+ bit))
-       (len (length key-vector))
-       (result nil))       
-      ((or (zerop m) (>= bit len)) result)
-    (declare (type mask32 m)
-	     (fixnum bit len)
-	     (list result))
-    (when (oddp m)
-      (push (aref key-vector bit) result))))
-
-(defun encode-event-mask (event-mask)
-  (declare (type event-mask event-mask))
-  (declare (clx-values mask32))
-  (or (encode-mask *event-mask-vector* event-mask 'event-mask-class)
-      (x-type-error event-mask 'event-mask)))
-
-(defun make-event-mask (&rest keys)
-  ;; This is only defined for core events.
-  ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
-  (declare (type (clx-list event-mask-class) keys))
-  (declare (clx-values mask32))
-  (encode-mask *event-mask-vector* keys 'event-mask-class))
-
-(defun make-event-keys (event-mask)
-  ;; This is only defined for core events.
-  (declare (type mask32 event-mask))
-  (declare (clx-values (clx-list event-mask-class)))
-  (decode-mask *event-mask-vector* event-mask))
-
-(defun encode-device-event-mask (device-event-mask)
-  (declare (type device-event-mask device-event-mask))
-  (declare (clx-values mask32))
-  (or (encode-mask *device-event-mask-vector* device-event-mask
-		   'device-event-mask-class)
-      (x-type-error device-event-mask 'device-event-mask)))
-
-(defun encode-modifier-mask (modifier-mask)
-  (declare (type modifier-mask modifier-mask))
-  (declare (clx-values mask16))
-  (or (encode-mask *state-mask-vector* modifier-mask 'modifier-key)
-      (and (eq modifier-mask :any) #x8000)
-      (x-type-error modifier-mask 'modifier-mask)))
-
-(defun encode-state-mask (state-mask)
-  (declare (type (or mask16 (clx-list state-mask-key)) state-mask))
-  (declare (clx-values mask16))
-  (or (encode-mask *state-mask-vector* state-mask 'state-mask-key)
-      (x-type-error state-mask '(or mask16 (clx-list state-mask-key)))))
-
-(defun make-state-mask (&rest keys)
-  ;; Useful for constructing modifier-mask, state-mask.
-  (declare (type (clx-list state-mask-key) keys))
-  (declare (clx-values mask16))
-  (encode-mask *state-mask-vector* keys 'state-mask-key))
-
-(defun make-state-keys (state-mask)
-  (declare (type mask16 state-mask))
-  (declare (clx-values (clx-list state-mask-key)))
-  (decode-mask *state-mask-vector* state-mask))
-
-(defun encode-pointer-event-mask (pointer-event-mask)
-  (declare (type pointer-event-mask pointer-event-mask))
-  (declare (clx-values mask32))
-  (or (encode-mask *pointer-event-mask-vector* pointer-event-mask
-		   'pointer-event-mask-class)
-      (x-type-error pointer-event-mask 'pointer-event-mask)))
diff --git a/clx/cmudep.lisp b/clx/cmudep.lisp
deleted file mode 100644
index c77d181cdbcd965b488e67beceb6634d57652b94..0000000000000000000000000000000000000000
--- a/clx/cmudep.lisp
+++ /dev/null
@@ -1,19 +0,0 @@
-;;; -*- Package: XLIB -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/cmudep.lisp,v 1.1 1992/08/11 15:15:34 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-(in-package "XLIB")
-
-(alien:def-alien-routine ("connect_to_server" xlib::connect-to-server)
-			 c-call:int
-  (host c-call:c-string)
-  (port c-call:int))
diff --git a/clx/defsystem.lisp b/clx/defsystem.lisp
deleted file mode 100644
index e1174d1c0c151930b2f8c774854ce95912b20e2b..0000000000000000000000000000000000000000
--- a/clx/defsystem.lisp
+++ /dev/null
@@ -1,530 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: T;  -*-
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Portions Copyright (C) 1987 Texas Instruments Incorporated.
-;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-;;; Franz Incorporated provides this software "as is" without express or
-;;; implied warranty.
-
-;;; #+ features used in this file
-;;;   clx-ansi-common-lisp
-;;;   lispm
-;;;   genera
-;;;   minima
-;;;   lucid
-;;;   lcl3.0
-;;;   apollo
-;;;   kcl
-;;;   ibcl
-;;;   excl
-;;;   CMU
-
-#+(or Genera Minima)
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (common-lisp:pushnew :clx-ansi-common-lisp common-lisp:*features*))
-
-#+(and Genera clx-ansi-common-lisp)
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (setf *readtable* si:*ansi-common-lisp-readtable*))
-
-#-clx-ansi-common-lisp 
-(lisp:in-package :user)
-
-#+clx-ansi-common-lisp
-(common-lisp:in-package :common-lisp-user)
-
-
-;;;; Lisp Machines
-
-#+(and lispm (not genera))
-(global:defsystem CLX
-  (:pathname-default "clx:clx;")
-  (:patchable "clx:patch;" clx-ti)
-  (:initial-status :experimental)
-
-  (:module package "package")
-  (:module depdefs "depdefs")
-  (:module clx "clx")
-  (:module dependent "dependent")
-  (:module macros "macros")
-  (:module bufmac "bufmac")
-  (:module buffer "buffer")
-  (:module display "display")
-  (:module gcontext "gcontext")
-  (:module requests "requests")
-  (:module input "input")
-  (:module fonts "fonts")
-  (:module graphics "graphics")
-  (:module text "text")
-  (:module attributes "attributes")
-  (:module translate "translate")
-  (:module keysyms "keysyms")
-  (:module manager "manager")
-  (:module image "image")
-  (:module resource "resource")
-  (:module doc "doc")
-
-  (:compile-load package)
-  (:compile-load depdefs
-   (:fasload package))
-  (:compile-load clx
-   (:fasload package depdefs))
-  (:compile-load dependent
-   (:fasload package depdefs clx))
-  ;; Macros only needed for compilation
-  (:skip :compile-load macros
-   (:fasload package depdefs clx dependent))
-  ;; Bufmac only needed for compilation
-  (:skip :compile-load bufmac
-   (:fasload package depdefs clx dependent macros))
-  (:compile-load buffer
-   (:fasload package depdefs clx dependent macros bufmac))
-  (:compile-load display
-   (:fasload package depdefs clx dependent macros bufmac buffer))
-  (:compile-load gcontext
-   (:fasload package depdefs clx dependent macros bufmac buffer display))
-  (:compile-load input
-   (:fasload package depdefs clx dependent macros bufmac buffer display))
-  (:compile-load requests
-   (:fasload package depdefs clx dependent macros bufmac buffer display input))
-  (:compile-load fonts
-   (:fasload package depdefs clx dependent macros bufmac buffer display))
-  (:compile-load graphics
-   (:fasload package depdefs clx dependent macros fonts bufmac buffer display
-	     fonts))
-  (:compile-load text
-   (:fasload package depdefs clx dependent macros fonts bufmac buffer display
-	     gcontext fonts))
-  (:compile-load-init attributes
-   (dependent)
-   (:fasload package depdefs clx dependent macros bufmac buffer display))
-  (:compile-load translate
-   (:fasload package depdefs clx dependent macros bufmac buffer display))
-  (:compile-load keysyms
-   (:fasload package depdefs clx dependent macros bufmac buffer display
-	     translate))
-  (:compile-load manager
-   (:fasload package depdefs clx dependent macros bufmac buffer display))
-  (:compile-load image
-   (:fasload package depdefs clx dependent macros bufmac buffer display))
-  (:compile-load resource
-   (:fasload package depdefs clx dependent macros bufmac buffer display))
-  (:auxiliary doc)
-  )
-
-
-;;; Symbolics Lisp Machines
-#+Genera
-(scl:defsystem CLX
-    (:default-pathname "SYS:X11;CLX;"
-     :pretty-name "CLX"
-     :maintaining-sites (:scrc)
-     :distribute-sources t
-     :distribute-binaries t
-     :source-category :basic)
-  (:module doc ("doc")
-	   (:type :lisp-example))
-  (:serial
-    "package" "depdefs" "generalock" "clx" "dependent" "macros" "bufmac"
-    "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics"
-    "text" "attributes" "translate" "keysyms" "manager" "image" "resource"))
-
-#+Minima
-(zl:::scl:defsystem Minima-CLX
-    (:default-pathname "SYS:X11;CLX;"
-     :pretty-name "Minima CLX"
-     :maintain-journals nil
-     :maintaining-sites (:scrc)
-     :distribute-sources t
-     :distribute-binaries t
-     :source-category :basic
-     :default-module-type :minima-lisp)
-  (:module doc ("doc")
-	   (:type :lisp-example))
-  (:serial
-    "package" "depdefs" "clx" "dependent" "macros" "bufmac"
-    "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics"
-    "text" "attributes" "translate" "keysyms" "manager" "image" "resource"))
-
-
-;;; Franz
-
-;;
-;; The following is a suggestion.  If you comment out this form be
-;; prepared for possible deadlock, since no interrupts will be recognized
-;; while reading from the X socket if the scheduler is not running.
-;;
-#+excl
-(setq compiler::generate-interrupt-checks-switch
-      (compile nil
-	       '(lambda (safety size speed &optional debug)
-		  (declare (ignore size debug))
-		  (or (< speed 3) (> safety 0)))))
-
-
-;;; Allegro
-
-#+allegro
-(excl:defsystem :clx 
-  ()
-  |package|
-  (|excldep|
-    :load-before-compile (|package|)
-    :recompile-on (|package|))
-  (|depdefs|
-    :load-before-compile (|package| |excldep|)
-    :recompile-on (|excldep|))
-  (|clx|
-    :load-before-compile (|package| |excldep| |depdefs|)
-    :recompile-on (|package| |excldep| |depdefs|))
-  (|dependent|
-    :load-before-compile (|package| |excldep| |depdefs| |clx|)
-    :recompile-on (|clx|))
-  (|exclcmac|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|)
-    :recompile-on (|dependent|))
-  (|macros|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac|)
-    :recompile-on (|exclcmac|))
-  (|bufmac|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros|)
-    :recompile-on (|macros|))
-  (|buffer|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac|)
-    :recompile-on (|bufmac|))
-  (|display|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer|)
-    :recompile-on (|buffer|))
-  (|gcontext|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer| |display|)
-    :recompile-on (|display|))
-  (|input|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer| |display|)
-    :recompile-on (|display|))
-  (|requests|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer| |display|
-			  |input|)
-    :recompile-on (|display|))
-  (|fonts|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer| |display|)
-    :recompile-on (|display|))
-  (|graphics|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer| |display|
-			  |fonts|)
-    :recompile-on (|fonts|))
-  (|text|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer| |display|
-			  |gcontext| |fonts|)
-    :recompile-on (|gcontext| |fonts|)
-    :load-after (|translate|))
-  ;; The above line gets around a compiler macro expansion bug.
-  
-  (|attributes|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer| |display|)
-    :recompile-on (|display|))
-  (|translate|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer| |display|
-			  |text|)
-    :recompile-on (|display|))
-  (|keysyms|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer| |display|
-			  |translate|)
-    :recompile-on (|translate|))
-  (|manager|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer| |display|)
-    :recompile-on (|display|))
-  (|image|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer| |display|)
-    :recompile-on (|display|))
-  
-  ;; Don't know if l-b-c list is correct.  XX
-  (|resource|
-    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
-			  |exclcmac| |macros| |bufmac| |buffer| |display|)
-    :recompile-on (|display|))
-  )
-
-#+allegro
-(excl:defsystem :clx-debug
-    (:default-pathname "debug/"
-     :needed-systems (:clx)
-     :load-before-compile (:clx))
-  |describe| |keytrans| |trace| |util|)
-
-
-;;;; Compile CLX
-
-;;; COMPILE-CLX compiles the lisp source files and loads the binaries.
-;;; It goes to some trouble to let the source files be in one directory
-;;; and the binary files in another.  Thus the same set of sources can
-;;; be used for different machines and/or lisp systems.  It also allows
-;;; you to supply explicit extensions, so source files do not have to
-;;; be renamed to fit into the naming conventions of an implementation.
-
-;;; For example,
-;;;     (compile-clx "*.lisp" "machine/")
-;;; compiles source files from the connected directory and puts them
-;;; into the "machine" subdirectory.  You can then load CLX out of the
-;;; machine directory.
-
-;;; The code has no knowledge of the source file types (eg, ".l" or
-;;; ".lisp") or of the binary file types (eg, ".b" or ".sbin").  Calling
-;;; compile-file and load with a file type of NIL usually sorts things
-;;; out correctly, but you may have to explicitly give the source and
-;;; binary file types.
-
-;;; An attempt at compiling the C language sources is also made,
-;;; but you may have to set different compiler switches
-;;; should be.  If it doesn't do the right thing, then do
-;;;     (compile-clx "" "" :compile-c NIL)
-;;; to prevent the compilation.
-
-;;; compilation notes
-;;;   lucid2.0/hp9000s300
-;;;     must uudecode the file make-sequence-patch.uu
-
-#+(or lucid kcl ibcl)
-(defun clx-foreign-files (binary-path)
-
-  #+(and lucid (not lcl3.0) (or mc68000 mc68020))
-  (load (merge-pathnames "make-sequence-patch" binary-path))
-
-  #+(and lucid apollo)
-  (lucid::load-foreign-file
-    (namestring (merge-pathnames "socket" binary-path))
-    :preserve-pathname t)
-
-  #+(and lucid (not apollo))
-  (lucid::load-foreign-files
-    (list (namestring (merge-pathnames "socket.o" binary-path)))
-    '("-lc"))
-
-  #+(or kcl ibcl)
-  (progn
-    (let ((pathname (merge-pathnames "sockcl.o" binary-path))
-	  (options
-	    (concatenate
-	      'string
-	      (namestring (merge-pathnames "socket.o" binary-path))
-	      " -lc")))
-      (format t "~&Faslinking ~A with ~A.~%" pathname options)
-      (si:faslink (namestring pathname) options)
-      (format t "~&Finished faslinking ~A.~%" pathname)))
-  )
-
-#-(or lispm allegro Minima)
-(defun compile-clx (&optional
-		    (source-pathname-defaults "")
-		    (binary-pathname-defaults "")
-		    &key
-		    (compile-c t))
-
-  ;; The pathname-defaults above might only be strings, so coerce them
-  ;; to pathnames.  Build a default binary path with every component
-  ;; of the source except the file type.  This should prevent
-  ;; (compile-clx "*.lisp") from destroying source files.
-  (let* ((source-path (pathname source-pathname-defaults))
-	 (path        (make-pathname
-			:host      (pathname-host      source-path)
-			:device    (pathname-device    source-path)
-			:directory (pathname-directory source-path)
-			:name      (pathname-name      source-path)
-			:type      nil
-			:version   (pathname-version   source-path)))
-	 (binary-path (merge-pathnames binary-pathname-defaults
-				       path))
-	 #+clx-ansi-common-lisp (*compile-verbose* t)
-	 (*load-verbose* t))
-				       
-    ;; Make sure source-path and binary-path file types are distinct so
-    ;; we don't accidently overwrite the source files.  NIL should be an
-    ;; ok type, but anything else spells trouble.
-    (if (and (equal (pathname-type source-path)
-		    (pathname-type binary-path))
-	     (not (null (pathname-type binary-path))))
-	(error "Source and binary pathname defaults have same type ~s ~s"
-	       source-path binary-path))
-
-    (format t "~&;;; Default paths: ~s ~s~%" source-path binary-path)
-
-    ;; In lucid make sure we're using the compiler in production mode.
-    #+lcl3.0
-    (progn
-      (unless (member :pqc *features*)
-	(cerror
-	  "Go ahead anyway."
-	  "Lucid's production mode compiler must be loaded to compile CLX."))
-      (proclaim '(optimize (speed 3)
-			   (safety 1)
-			   (space 0)
-			   (compilation-speed 0))))
-
-    (labels ((compile-lisp (filename)
-	       (let ((source (merge-pathnames filename source-path))
-		     (binary (merge-pathnames filename binary-path)))
-		 ;; If the source and binary pathnames are the same,
-		 ;; then don't supply an output file just to be sure
-		 ;; compile-file defaults correctly.
-		 #+(or kcl ibcl) (load source)
-		 (if (equal source binary)
-		     (compile-file source)
-		     (compile-file source :output-file binary))
-		 binary))
-	     (compile-and-load (filename)
-	       (load (compile-lisp filename)))
-	     #+(or lucid kcl ibcl)
-	     (compile-c (filename)
-	       (let* ((c-filename (concatenate 'string filename ".c"))
-		      (o-filename (concatenate 'string filename ".o"))
-		      (src (merge-pathnames c-filename source-path))
-		      (obj  (merge-pathnames o-filename binary-path))
-		      (args (list "-c" (namestring src)
-				  "-o" (namestring obj)
-				  #+mips "-G 0"
-				  #+(or hp sysv) "-DSYSV"
-				  #+(and mips (not dec)) "-I/usr/include/bsd"
-				  #-(and mips (not dec)) "-DUNIXCONN"
-				  #+(and lucid pa) "-DHPUX -DHPUX7.0"
-				  )))
-		 (format t ";;; cc~{ ~A~}~%" args)
-		 (unless
-		   (zerop 
-		     #+lucid
-		     (multiple-value-bind (iostream estream exitstatus pid)
-			 ;; in 2.0, run-program is exported from system:
-			 ;; in 3.0, run-program is exported from lcl:
-			 ;; system inheirits lcl
-			 (system::run-program "cc" :arguments args)
-		       (declare (ignore iostream estream pid))
-		       exitstatus)
-		     #+(or kcl ibcl)
-		     (system (format nil "cc~{ ~A~}" args)))
-		   (error "Compile of ~A failed." src)))))
-
-      ;; Now compile and load all the files.
-      ;; Defer compiler warnings until everything's compiled, if possible.
-      (#+(or clx-ansi-common-lisp CMU) with-compilation-unit
-       #+lcl3.0 lucid::with-deferred-warnings
-       #-(or lcl3.0 clx-ansi-common-lisp CMU) progn
-       ()
-       
-       (compile-and-load "package")
-       #+(or lucid kcl ibcl) (when compile-c (compile-c "socket"))
-       #+(or kcl ibcl) (compile-lisp "sockcl")
-       #+(or lucid kcl ibcl) (clx-foreign-files binary-path)
-       #+excl (compile-and-load "excldep")
-       (compile-and-load "depdefs")
-       (compile-and-load "clx")
-       (compile-and-load "dependent")
-       #+excl (compile-and-load "exclcmac")	; these are just macros
-       (compile-and-load "macros")		; these are just macros
-       (compile-and-load "bufmac")		; these are just macros
-       (compile-and-load "buffer")
-       (compile-and-load "display")
-       (compile-and-load "gcontext")
-       (compile-and-load "input")
-       (compile-and-load "requests")
-       (compile-and-load "fonts")
-       (compile-and-load "graphics")
-       (compile-and-load "text")
-       (compile-and-load "attributes")
-       (compile-and-load "translate")
-       (compile-and-load "keysyms")
-       (compile-and-load "manager")
-       (compile-and-load "image")
-       (compile-and-load "resource")
-       ))))
-
-
-;;;; Load CLX
-
-;;; This procedure loads the binaries for CLX.  All of the binaries
-;;; should be in the same directory, so setting the default pathname
-;;; should point load to the right place.
-
-;;; You should have a module definition somewhere so the require/provide
-;;; mechanism can avoid reloading CLX.  In an ideal world, somebody would
-;;; just put
-;;;		(REQUIRE 'CLX)
-;;; in their file (some implementations don't have a central registry for
-;;; modules, so a pathname needs to be supplied).
-
-;;; The REQUIRE should find a file that does
-;;;		(IN-PACKAGE 'XLIB :USE '(LISP))
-;;;		(PROVIDE 'CLX)
-;;;		(LOAD <clx-defsystem-file>)
-;;;		(LOAD-CLX <binary-specific-clx-directory>)
-
-#-(or lispm allegro Minima)
-(defun load-clx (&optional (binary-pathname-defaults "")
-		 &key (macrosp nil))
-
-  (let* ((source-path (pathname ""))
-	 (path        (make-pathname
-			:host      (pathname-host      source-path)
-			:device    (pathname-device    source-path)
-			:directory (pathname-directory source-path)
-			:name      (pathname-name      source-path)
-			:type      nil
-			:version   (pathname-version   source-path)))
-	 (binary-path (merge-pathnames binary-pathname-defaults
-				       path))
-	 (*load-verbose* t))
-
-    (flet ((load-binary (filename)
-	     (let ((binary (merge-pathnames filename binary-path)))
-	       (load binary))))
-
-      (load-binary "package")
-      #+(or lucid kcl ibcl) (clx-foreign-files binary-path)
-      #+excl (load-binary "excldep")
-      (load-binary "depdefs")
-      (load-binary "clx")
-      (load-binary "dependent")
-      (when macrosp
-	#+excl (load-binary "exclcmac")
-	(load-binary "macros")
-	(load-binary "bufmac"))
-      (load-binary "buffer")
-      (load-binary "display")
-      (load-binary "gcontext")
-      (load-binary "input")
-      (load-binary "requests")
-      (load-binary "fonts")
-      (load-binary "graphics")
-      (load-binary "text")
-      (load-binary "attributes")
-      (load-binary "translate")
-      (load-binary "keysyms")
-      (load-binary "manager")
-      (load-binary "image")
-      (load-binary "resource")
-      )))
diff --git a/clx/depdefs.lisp b/clx/depdefs.lisp
deleted file mode 100644
index 6a89c31a8f43f6c219dbdf27a59f7d90ef62a2e0..0000000000000000000000000000000000000000
--- a/clx/depdefs.lisp
+++ /dev/null
@@ -1,652 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;; This file contains some of the system dependent code for CLX
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-;;;-------------------------------------------------------------------------
-;;; Declarations
-;;;-------------------------------------------------------------------------
-
-;;; fix a bug in kcl's RATIONAL...
-;;;   redefine both the function and the type.
-
-#+(or kcl ibcl)
-(progn
-  (defun rational (x)
-    (if (rationalp x)
-	x
-	(lisp:rational x)))
-  (deftype rational (&optional l u) `(lisp:rational ,l ,u)))
-
-;;; DECLAIM
-
-#-clx-ansi-common-lisp
-(defmacro declaim (&rest decl-specs)
-  (if (cdr decl-specs)
-      `(progn
-	 ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec))
-		   decl-specs))
-    `(proclaim ',(car decl-specs))))
-
-;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
-
-#-Genera
-(declaim (declaration clx-values))
-
-#+Genera
-(setf (get 'clx-values 'si:declaration-alias) 'scl:values)
-
-;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function.  Overrides
-;;; the documentation that might get generated by the real arglist of the
-;;; function.
-
-#-(or lispm lcl3.0)
-(declaim (declaration arglist))
-
-;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has
-;;; dynamic extent and therefore can be kept on the stack and not copied to
-;;; the heap, even though the value is passed out of the function.
-
-#-(or clx-ansi-common-lisp lcl3.0)
-(declaim (declaration dynamic-extent))
-
-;;; IGNORABLE var -- Tells the compiler that the variable might or might not be used.
-
-#-clx-ansi-common-lisp
-(declaim (declaration ignorable))
-
-;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
-;;; indent calls to the function or macro containing the declaration.  
-
-#-genera
-(declaim (declaration indentation))
-
-;;;-------------------------------------------------------------------------
-;;; Declaration macros
-;;;-------------------------------------------------------------------------
-
-;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local
-;;; and then does a type declaration and array register declaration
-(defmacro with-vector ((var type) &body body)
-  `(let ((,var ,var))
-     (declare (type ,type ,var))
-     ,@body))
-
-;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
-;;; Meta-.
-
-#+lispm
-(defmacro within-definition ((name type) &body body)
-  `(zl:local-declare
-     ((sys:function-parent ,name ,type))
-     (sys:record-source-file-name ',name ',type)
-     ,@body))
-
-#-lispm
-(defmacro within-definition ((name type) &body body)
-  (declare (ignore name type))
-  `(progn ,@body))
-
-
-;;;-------------------------------------------------------------------------
-;;; CLX can maintain a mapping from X server ID's to local data types.  If
-;;; one takes the view that CLX objects will be instance variables of
-;;; objects at the next higher level, then PROCESS-EVENT will typically map
-;;; from resource-id to higher-level object.  In that case, the lower-level
-;;; CLX mapping will almost never be used (except in rare cases like
-;;; query-tree), and only serve to consume space (which is difficult to
-;;; GC), in which case always-consing versions of the make-<mumble>s will
-;;; be better.  Even when maps are maintained, it isn't clear they are
-;;; useful for much beyond xatoms and windows (since almost nothing else
-;;; ever comes back in events).
-;;;--------------------------------------------------------------------------
-(defconstant *clx-cached-types*
-	     '( drawable
-		window
-		pixmap
-;		gcontext
-		cursor
-		colormap
-		font))
-
-(defmacro resource-id-map-test ()
-  #+excl '#'equal
-  #-excl '#'eql)
-					; (eq fixnum fixnum) is not guaranteed.
-(defmacro atom-cache-map-test ()
-  #+excl '#'equal
-  #-excl '#'eq)
-
-(defmacro keysym->character-map-test ()
-  #+excl '#'equal
-  #-excl '#'eql)
-
-;;; You must define this to match the real byte order.  It is used by
-;;; overlapping array and image code.
-
-#+(or lispm vax little-endian Minima)
-(eval-when (eval compile load)
-  (pushnew :clx-little-endian *features*))
-
-#+lcl3.0
-(eval-when (compile eval load)
-  (ecase lucid::machine-endian
-    (:big nil)
-    (:little (pushnew :clx-little-endian *features*))))
-
-#+cmu
-(eval-when (compile eval load)
-  (ecase #.(c:backend-byte-order c:*backend*)
-    (:big-endian)
-    (:little-endian (pushnew :clx-little-endian *features*))))
-
-;;; Steele's Common-Lisp states:  "It is an error if the array specified
-;;; as the :displaced-to argument  does not have the same :element-type
-;;; as the array being created" If this is the case on your lisp, then
-;;; leave the overlapping-arrays feature turned off.  Lisp machines
-;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays
-;;; with different element types to overlap.  CLX will take advantage of
-;;; this to do fast array packing/unpacking when the overlapping-arrays
-;;; feature is enabled.
-
-#+(and clx-little-endian lispm)
-(eval-when (eval compile load)
-  (pushnew :clx-overlapping-arrays *features*))
-
-#+(and clx-overlapping-arrays genera)
-(progn
-(deftype overlap16 () '(unsigned-byte 16))
-(deftype overlap32 () '(signed-byte 32))
-)
-
-#+(and clx-overlapping-arrays (or explorer lambda cadr))
-(progn
-(deftype overlap16 () '(unsigned-byte 16))
-(deftype overlap32 () '(unsigned-byte 32))
-)
-
-(deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))
-
-#+clx-overlapping-arrays
-(progn
-(deftype buffer-words () `(vector overlap16))
-(deftype buffer-longs () `(vector overlap32))
-)
-
-;;; This defines a type which is a subtype of the integers.
-;;; This type is used to describe all variables that can be array indices.
-;;; It is here because it is used below.
-;;; This is inclusive because start/end can be 1 past the end.
-(deftype array-index () `(integer 0 ,array-dimension-limit))
-
-
-;; this is the best place to define these?
-
-#-Genera
-(progn
-
-(defun make-index-typed (form)
-  (if (constantp form) form `(the array-index ,form)))
-
-(defun make-index-op (operator args)
-  `(the array-index
-	(values 
-	  ,(case (length args)
-	     (0 `(,operator))
-	     (1 `(,operator
-		  ,(make-index-typed (first args))))
-	     (2 `(,operator
-		  ,(make-index-typed (first args))
-		  ,(make-index-typed (second args))))
-	     (otherwise
-	       `(,operator
-		 ,(make-index-op operator (subseq args 0 (1- (length args))))
-		 ,(make-index-typed (first (last args)))))))))
-
-(defmacro index+ (&rest numbers) (make-index-op '+ numbers))
-(defmacro index-logand (&rest numbers) (make-index-op 'logand numbers))
-(defmacro index-logior (&rest numbers) (make-index-op 'logior numbers))
-(defmacro index- (&rest numbers) (make-index-op '- numbers))
-(defmacro index* (&rest numbers) (make-index-op '* numbers))
-
-(defmacro index1+ (number) (make-index-op '1+ (list number)))
-(defmacro index1- (number) (make-index-op '1- (list number)))
-
-(defmacro index-incf (place &optional (delta 1))
-  (make-index-op 'incf (list place delta)))
-(defmacro index-decf (place &optional (delta 1))
-  (make-index-op 'decf (list place delta)))
-
-(defmacro index-min (&rest numbers) (make-index-op 'min numbers))
-(defmacro index-max (&rest numbers) (make-index-op 'max numbers))
-
-(defmacro index-floor (number divisor)
-  (make-index-op 'floor (list number divisor)))
-(defmacro index-ceiling (number divisor)
-  (make-index-op 'ceiling (list number divisor)))
-(defmacro index-truncate (number divisor)
-  (make-index-op 'truncate (list number divisor)))
-
-(defmacro index-mod (number divisor)
-  (make-index-op 'mod (list number divisor)))
-
-(defmacro index-ash (number count)
-  (make-index-op 'ash (list number count)))
-
-(defmacro index-plusp (number) `(plusp (the array-index ,number)))
-(defmacro index-zerop (number) `(zerop (the array-index ,number)))
-(defmacro index-evenp (number) `(evenp (the array-index ,number)))
-(defmacro index-oddp  (number) `(oddp  (the array-index ,number)))
-
-(defmacro index> (&rest numbers)
-  `(> ,@(mapcar #'make-index-typed numbers)))
-(defmacro index= (&rest numbers)
-  `(= ,@(mapcar #'make-index-typed numbers)))
-(defmacro index< (&rest numbers)
-  `(< ,@(mapcar #'make-index-typed numbers)))
-(defmacro index>= (&rest numbers)
-  `(>= ,@(mapcar #'make-index-typed numbers)))
-(defmacro index<= (&rest numbers)
-  `(<= ,@(mapcar #'make-index-typed numbers)))
-
-)
-
-#+Genera
-(progn
-
-(defmacro index+ (&rest numbers) `(+ ,@numbers))
-(defmacro index-logand (&rest numbers) `(logand ,@numbers))
-(defmacro index-logior (&rest numbers) `(logior ,@numbers))
-(defmacro index- (&rest numbers) `(- ,@numbers))
-(defmacro index* (&rest numbers) `(* ,@numbers))
-
-(defmacro index1+ (number) `(1+ ,number))
-(defmacro index1- (number) `(1- ,number))
-
-(defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta)))
-(defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta)))
-
-(defmacro index-min (&rest numbers) `(min ,@numbers))
-(defmacro index-max (&rest numbers) `(max ,@numbers))
-
-(defun positive-power-of-two-p (x)
-  (when (symbolp x)
-    (multiple-value-bind (constantp value) (lt:named-constant-p x)
-      (when constantp (setq x value))))
-  (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x)))))
-
-(defmacro index-floor (number divisor)
-  (cond ((eql divisor 1) number)
-	((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
-	 `(si:%fixnum-floor ,number ,divisor))
-	(t `(floor ,number ,divisor))))
-
-(defmacro index-ceiling (number divisor)
-  (cond ((eql divisor 1) number)
-	((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling))
-	 `(si:%fixnum-ceiling ,number ,divisor))
-	(t `(ceiling ,number ,divisor))))
-
-(defmacro index-truncate (number divisor)
-  (cond ((eql divisor 1) number)
-	((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
-	 `(si:%fixnum-floor ,number ,divisor))
-	(t `(truncate ,number ,divisor))))
-
-(defmacro index-mod (number divisor)
-  (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod))
-	 `(si:%fixnum-mod ,number ,divisor))
-	(t `(mod ,number ,divisor))))
-
-(defmacro index-ash (number count)
-  (cond ((eql count 0) number)
-	((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor))
-	 `(si:%fixnum-floor ,number ,(expt 2 (- count))))
-	((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply))
-	 `(si:%fixnum-multiply ,number ,(expt 2 count)))
-	(t `(ash ,number ,count))))
-
-(defmacro index-plusp (number) `(plusp ,number))
-(defmacro index-zerop (number) `(zerop ,number))
-(defmacro index-evenp (number) `(evenp ,number))
-(defmacro index-oddp  (number) `(oddp  ,number))
-
-(defmacro index> (&rest numbers) `(> ,@numbers))
-(defmacro index= (&rest numbers) `(= ,@numbers))
-(defmacro index< (&rest numbers) `(< ,@numbers))
-(defmacro index>= (&rest numbers) `(>= ,@numbers))
-(defmacro index<= (&rest numbers) `(<= ,@numbers))
-
-)
-
-;;;; Stuff for BUFFER definition
-
-(defconstant *replysize* 32.)
-
-;; used in defstruct initializations to avoid compiler warnings
-(defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
-(declaim (type buffer-bytes *empty-bytes*))
-#+clx-overlapping-arrays
-(progn
-(defvar *empty-words* (make-sequence 'buffer-words 0))
-(declaim (type buffer-words *empty-words*))
-)
-#+clx-overlapping-arrays
-(progn
-(defvar *empty-longs* (make-sequence 'buffer-longs 0))
-(declaim (type buffer-longs *empty-longs*))
-)
-
-(defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal)
-			 (:copier nil) (:predicate nil))
-  (size 0 :type array-index)			;Buffer size
-  ;; Byte (8 bit) input buffer
-  (ibuf8 *empty-bytes* :type buffer-bytes)
-  ;; Word (16bit) input buffer
-  #+clx-overlapping-arrays
-  (ibuf16 *empty-words* :type buffer-words)
-  ;; Long (32bit) input buffer
-  #+clx-overlapping-arrays
-  (ibuf32 *empty-longs* :type buffer-longs)
-  (next nil #-explorer :type #-explorer (or null reply-buffer))
-  (data-size 0 :type array-index)
-  )
-
-(defconstant *buffer-text16-size* 256)
-(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,*buffer-text16-size*)))
-
-;; These are here because.
-
-(defparameter *xlib-package* (find-package :xlib))
-
-(defun xintern (&rest parts)
-  (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
-
-(defparameter *keyword-package* (find-package :keyword))
-
-(defun kintern (name)
-  (intern (string name) *keyword-package*))
-
-;;; Pseudo-class mechanism.
-
-(eval-when (eval compile load)
-(defvar *def-clx-class-use-defclass* #+Genera t #-Genera nil
-  "Controls whether DEF-CLX-CLASS uses DEFCLASS.  
-   If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of type names
-   for which DEFCLASS should be used. 
-   If it is not a list, then DEFCLASS is always used.
-   If it is NIL, then DEFCLASS is never used, since NIL is the empty list.")
-)
-
-(defmacro def-clx-class ((name &rest options) &body slots)
-  (if (or (not (listp *def-clx-class-use-defclass*))
-	  (member name *def-clx-class-use-defclass*))
-      (let ((clos-package #+clx-ansi-common-lisp
-			  (find-package :common-lisp)
-			  #-clx-ansi-common-lisp
-			  (or (find-package :clos)
-			      (find-package :pcl)
-			      (let ((lisp-pkg (find-package :lisp)))
-				(and (find-symbol (string 'defclass) lisp-pkg)
-				     lisp-pkg))))
-	    (constructor t)
-	    (constructor-args t)
-	    (include nil)
-	    (print-function nil)
-	    (copier t)
-	    (predicate t))
-	(dolist (option options)
-	  (ecase (pop option)
-	    (:constructor
-	      (setf constructor (pop option))
-	      (setf constructor-args (if (null option) t (pop option))))
-	    (:include
-	      (setf include (pop option)))
-	    (:print-function
-	      (setf print-function (pop option)))
-	    (:copier
-	      (setf copier (pop option)))
-	    (:predicate
-	      (setf predicate (pop option)))))
-	(flet ((cintern (&rest symbols)
-		 (intern (apply #'concatenate 'simple-string
-				(mapcar #'symbol-name symbols))
-			 *package*))
-	       (kintern (symbol)
-			(intern (symbol-name symbol) (find-package :keyword)))
-	       (closintern (symbol)
-		 (intern (symbol-name symbol) clos-package)))
-	  (when (eq constructor t)
-	    (setf constructor (cintern 'make- name)))
-	  (when (eq copier t)
-	    (setf copier (cintern 'copy- name)))
-	  (when (eq predicate t)
-	    (setf predicate (cintern name '-p)))
-	  (when include
-	    (setf slots (append (get include 'def-clx-class) slots)))
-	  (let* ((n-slots (length slots))
-		 (slot-names (make-list n-slots))
-		 (slot-initforms (make-list n-slots))
-		 (slot-types (make-list n-slots)))
-	    (dotimes (i n-slots)
-	      (let ((slot (elt slots i)))
-		(setf (elt slot-names i) (pop slot))
-		(setf (elt slot-initforms i) (pop slot))
-		(setf (elt slot-types i) (getf slot :type t))))
-	    `(progn
-
-	       (eval-when (compile load eval)
-		 (setf (get ',name 'def-clx-class) ',slots))
-
-	       ;; From here down are the system-specific expansions:
-
-	       (within-definition (,name def-clx-class)
-		 (,(closintern 'defclass)
-		  ,name ,(and include `(,include))
-		  (,@(map 'list
-			  #'(lambda (slot-name slot-initform slot-type)
-			      `(,slot-name
-				:initform ,slot-initform :type ,slot-type
-				:accessor ,(cintern name '- slot-name)
-				,@(when (and constructor
-					     (or (eq constructor-args t)
-						 (member slot-name
-							 constructor-args)))
-				    `(:initarg ,(kintern slot-name)))
-				))
-			  slot-names slot-initforms slot-types)))
-		 ,(when constructor
-		    (if (eq constructor-args t)
-			`(defun ,constructor (&rest args)
-			   (apply #',(closintern 'make-instance)
-				  ',name args))
-			`(defun ,constructor ,constructor-args
-			   (,(closintern 'make-instance) ',name
-			    ,@(mapcan #'(lambda (slot-name)
-					  (and (member slot-name slot-names)
-					       `(,(kintern slot-name) ,slot-name)))
-				      constructor-args)))))
-		 ,(when predicate
-		    #+allegro
-		    `(progn
-		       (,(closintern 'defmethod) ,predicate (object)
-			 (declare (ignore object))
-			 nil)
-		       (,(closintern 'defmethod) ,predicate ((object ,name))
-			 t))
-		    #-allegro
-		    `(defun ,predicate (object)
-		       (typep object ',name)))
-		 ,(when copier
-		    `(,(closintern 'defmethod) ,copier ((.object. ,name))
-		      (,(closintern 'with-slots) ,slot-names .object.
-		       (,(closintern 'make-instance) ',name
-			,@(mapcan #'(lambda (slot-name)
-				      `(,(kintern slot-name) ,slot-name))
-				  slot-names)))))
-		 ,(when print-function
-		    `(,(closintern 'defmethod)
-		      ,(closintern 'print-object)
-		      ((object ,name) stream)
-		      (,print-function object stream 0))))))))
-      `(within-definition (,name def-clx-class)
-	 (defstruct (,name ,@options)
-	   ,@slots))))
-
-#+Genera
-(progn
-  (scl:defprop def-clx-class "CLX Class" si:definition-type-name)
-  (scl:defprop def-clx-class zwei:defselect-function-spec-finder
-	       zwei:definition-function-spec-finder))
-
-
-;; We need this here so we can define DISPLAY for CLX.
-;;
-;; This structure is :INCLUDEd in the DISPLAY structure.
-;; Overlapping (displaced) arrays are provided for byte
-;; half-word and word access on both input and output.
-;;
-(def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
-  ;; Lock for multi-processing systems
-  (lock (make-process-lock "CLX Buffer Lock"))
-  #-excl (output-stream nil :type (or null stream))
-  #+excl (output-stream -1 :type fixnum)
-  ;; Buffer size
-  (size 0 :type array-index)
-  (request-number 0 :type (unsigned-byte 16))
-  ;; Byte position of start of last request
-  ;; used for appending requests and error recovery
-  (last-request nil :type (or null array-index))
-  ;; Byte position of start of last flushed request
-  (last-flushed-request nil :type (or null array-index))
-  ;; Current byte offset
-  (boffset 0 :type array-index)
-  ;; Byte (8 bit) output buffer
-  (obuf8 *empty-bytes* :type buffer-bytes)
-  ;; Word (16bit) output buffer
-  #+clx-overlapping-arrays
-  (obuf16 *empty-words* :type buffer-words)
-  ;; Long (32bit) output buffer
-  #+clx-overlapping-arrays
-  (obuf32 *empty-longs* :type buffer-longs)
-  ;; Holding buffer for 16-bit text
-  (tbuf16 (make-sequence 'buffer-text16 *buffer-text16-size* :initial-element 0))
-  ;; Probably EQ to Output-Stream
-  #-excl (input-stream nil :type (or null stream))
-  #+excl (input-stream -1 :type fixnum)
-  ;; T when the host connection has gotten errors
-  (dead nil :type (or null (not null)))
-  ;; T makes buffer-flush a noop.  Manipulated with with-buffer-flush-inhibited.
-  (flush-inhibit nil :type (or null (not null)))
-  
-  ;; Change these functions when using shared memory buffers to the server
-  ;; Function to call when writing the buffer
-  (write-function 'buffer-write-default)
-  ;; Function to call when flushing the buffer
-  (force-output-function 'buffer-force-output-default)
-  ;; Function to call when closing a connection
-  (close-function 'buffer-close-default)
-  ;; Function to call when reading the buffer
-  (input-function 'buffer-read-default)
-  ;; Function to call to wait for data to be input
-  (input-wait-function 'buffer-input-wait-default)
-  ;; Function to call to listen for input data
-  (listen-function 'buffer-listen-default)
-
-  #+Genera (debug-io nil :type (or null stream))
-  ) 
-
-;;-----------------------------------------------------------------------------
-;; Printing routines.
-;;-----------------------------------------------------------------------------
-
-#-(or clx-ansi-common-lisp Genera)
-(defun print-unreadable-object-function (object stream type identity function)
-  (declare #+lispm
-	   (sys:downward-funarg function))
-  (princ "#<" stream)
-  (when type
-    (let ((type (type-of object))
-	  (pcl-package (find-package :pcl)))
-      ;; Handle pcl type-of lossage
-      (when (and pcl-package
-		 (symbolp type)
-		 (eq (symbol-package type) pcl-package)
-		 (string-equal (symbol-name type) "STD-INSTANCE"))
-	(setq type
-	      (funcall (intern (symbol-name 'class-name) pcl-package)
-		       (funcall (intern (symbol-name 'class-of) pcl-package)
-				object))))
-      (prin1 type stream)))
-  (when (and type function) (princ " " stream))
-  (when function (funcall function))
-  (when (and (or type function) identity) (princ " " stream))
-  (when identity (princ "???" stream))
-  (princ ">" stream)
-  nil)
-  
-#-(or clx-ansi-common-lisp Genera)
-(defmacro print-unreadable-object
-	  ((object stream &key type identity) &body body)
-  (if body
-      `(flet ((.print-unreadable-object-body. () ,@body))
-	 (print-unreadable-object-function
-	   ,object ,stream ,type ,identity #'.print-unreadable-object-body.))
-    `(print-unreadable-object-function ,object ,stream ,type ,identity nil)))
-
-
-;;-----------------------------------------------------------------------------
-;; Image stuff
-;;-----------------------------------------------------------------------------
-
-(defconstant *image-bit-lsb-first-p*
-	     #+clx-little-endian t
-	     #-clx-little-endian nil)
-
-(defconstant *image-byte-lsb-first-p*
-	     #+clx-little-endian t
-	     #-clx-little-endian nil)
-
-(defconstant *image-unit* 32)
-
-(defconstant *image-pad* 32)
-
-
-;;-----------------------------------------------------------------------------
-;; Foreign Functions
-;;-----------------------------------------------------------------------------
-
-#+(and lucid apollo (not lcl3.0))
-(lucid::define-foreign-function '(connect-to-server "connect_to_server")
-  '((:val host    :string)
-    (:val display :integer32))
-  :integer32)
-
-#+(and lucid (not apollo) (not lcl3.0))
-(lucid::define-c-function connect-to-server (host display)
-  :result-type :integer)
-
-#+lcl3.0
-(lucid::def-foreign-function
-    (connect-to-server 
-      (:language :c)
-      (:return-type :signed-32bit))
-  (host :simple-string)
-  (display :signed-32bit))
diff --git a/clx/dependent.lisp b/clx/dependent.lisp
deleted file mode 100644
index 4d7cf24222d4c5548024cfff9904a50a519508d4..0000000000000000000000000000000000000000
--- a/clx/dependent.lisp
+++ /dev/null
@@ -1,3546 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;; This file contains some of the system dependent code for CLX
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-;;; The size of the output buffer.  Must be a multiple of 4.
-(defparameter *output-buffer-size* 8192)
-
-#+explorer
-(zwei:define-indentation event-case (1 1))
-
-;;; Number of seconds to wait for a reply to a server request
-(defparameter *reply-timeout* nil) 
-
-#-(or clx-overlapping-arrays (not clx-little-endian))
-(progn
-  (defconstant *word-0* 0)
-  (defconstant *word-1* 1)
-
-  (defconstant *long-0* 0)
-  (defconstant *long-1* 1)
-  (defconstant *long-2* 2)
-  (defconstant *long-3* 3))
-
-#-(or clx-overlapping-arrays clx-little-endian)
-(progn
-  (defconstant *word-0* 1)
-  (defconstant *word-1* 0)
-
-  (defconstant *long-0* 3)
-  (defconstant *long-1* 2)
-  (defconstant *long-2* 1)
-  (defconstant *long-3* 0))
-
-;;; Set some compiler-options for often used code
-
-(eval-when (eval compile load)
-
-(defconstant *buffer-speed* #+clx-debugging 1 #-clx-debugging 3
-  "Speed compiler option for buffer code.")
-(defconstant *buffer-safety* #+clx-debugging 3 #-clx-debugging 0
-  "Safety compiler option for buffer code.")
-
-(defun declare-bufmac ()
-  `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
-
-;;; It's my impression that in lucid there's some way to make a declaration
-;;; called fast-entry or something that causes a function to not do some
-;;; checking on args. Sadly, we have no lucid manuals here.  If such a
-;;; declaration is available, it would be a good idea to make it here when
-;;; *buffer-speed* is 3 and *buffer-safety* is 0.
-(defun declare-buffun ()
-  `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
-
-)
-
-(declaim (inline card8->int8 int8->card8
-		 card16->int16 int16->card16
-		 card32->int32 int32->card32))
-
-#-Genera
-(progn
-
-(defun card8->int8 (x)
-  (declare (type card8 x))
-  (declare (clx-values int8))
-  #.(declare-buffun)
-  (the int8 (if (logbitp 7 x)
-		(the int8 (- x #x100))
-	      x)))
-
-(defun int8->card8 (x)
-  (declare (type int8 x))
-  (declare (clx-values card8))
-  #.(declare-buffun)
-  (the card8 (ldb (byte 8 0) x)))
-
-(defun card16->int16 (x)
-  (declare (type card16 x))
-  (declare (clx-values int16))
-  #.(declare-buffun)
-  (the int16 (if (logbitp 15 x)
-		 (the int16 (- x #x10000))
-		 x)))
-
-(defun int16->card16 (x)
-  (declare (type int16 x))
-  (declare (clx-values card16))
-  #.(declare-buffun)
-  (the card16 (ldb (byte 16 0) x)))
-
-(defun card32->int32 (x)
-  (declare (type card32 x))
-  (declare (clx-values int32))
-  #.(declare-buffun)
-  (the int32 (if (logbitp 31 x)
-		 (the int32 (- x #x100000000))
-		 x)))
-
-(defun int32->card32 (x)
-  (declare (type int32 x))
-  (declare (clx-values card32))
-  #.(declare-buffun)
-  (the card32 (ldb (byte 32 0) x)))
-
-)
-
-#+Genera
-(progn
-
-(defun card8->int8 (x)
-  (declare lt:(side-effects simple reducible))
-  (if (logbitp 7 x) (- x #x100) x))
-
-(defun int8->card8 (x)
-  (declare lt:(side-effects simple reducible))
-  (ldb (byte 8 0) x))
-
-(defun card16->int16 (x)
-  (declare lt:(side-effects simple reducible))
-  (if (logbitp 15 x) (- x #x10000) x))
-
-(defun int16->card16 (x)
-  (declare lt:(side-effects simple reducible))
-  (ldb (byte 16 0) x))
-
-(defun card32->int32 (x)
-  (declare lt:(side-effects simple reducible))
-  (sys:%logldb (byte 32 0) x))
-
-(defun int32->card32 (x)
-  (declare lt:(side-effects simple reducible))
-  (ldb (byte 32 0) x))
-
-)
-
-(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
-
-#-(or Genera lcl3.0 excl)
-(progn
-
-(defun aref-card8 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values card8))
-  #.(declare-buffun)
-  (the card8 (aref a i)))
-
-(defun aset-card8 (v a i)
-  (declare (type card8 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (aref a i) v))
-
-(defun aref-int8 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values int8))
-  #.(declare-buffun)
-  (card8->int8 (aref a i)))
-
-(defun aset-int8 (v a i)
-  (declare (type int8 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (aref a i) (int8->card8 v)))
-
-)
-
-#+Genera
-(progn
-
-(defun aref-card8 (a i)
-  (aref a i))
-
-(defun aset-card8 (v a i)
-  (zl:aset v a i))
-
-(defun aref-int8 (a i)
-  (card8->int8 (aref a i)))
-
-(defun aset-int8 (v a i)
-  (zl:aset (int8->card8 v) a i))
-
-)
-
-#+(or excl lcl3.0 clx-overlapping-arrays)
-(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29
-		 aset-card16 aset-int16 aset-card32 aset-int32 aset-card29))
-
-#+(and clx-overlapping-arrays Genera)
-(progn
-
-(defun aref-card16 (a i)
-  (aref a i))
-
-(defun aset-card16 (v a i)
-  (zl:aset v a i))
-
-(defun aref-int16 (a i)
-  (card16->int16 (aref a i)))
-
-(defun aset-int16 (v a i)
-  (zl:aset (int16->card16 v) a i)
-  v)
-
-(defun aref-card32 (a i)
-  (int32->card32 (aref a i)))
-
-(defun aset-card32 (v a i)
-  (zl:aset (card32->int32 v) a i))
-
-(defun aref-int32 (a i) (aref a i))
-
-(defun aset-int32 (v a i)
-  (zl:aset v a i))
-
-(defun aref-card29 (a i)
-  (aref a i))
-
-(defun aset-card29 (v a i)
-  (zl:aset v a i))
-
-)
-
-#+(and clx-overlapping-arrays (not Genera))
-(progn
-
-(defun aref-card16 (a i)
-  (aref a i))
-
-(defun aset-card16 (v a i)
-  (setf (aref a i) v))
-
-(defun aref-int16 (a i)
-  (card16->int16 (aref a i)))
-
-(defun aset-int16 (v a i)
-  (setf (aref a i) (int16->card16 v))
-  v)
-
-(defun aref-card32 (a i)
-  (aref a i))
-
-(defun aset-card32 (v a i)
-  (setf (aref a i) v))
-
-(defun aref-int32 (a i)
-  (card32->int32 (aref a i)))
-
-(defun aset-int32 (v a i)
-  (setf (aref a i) (int32->card32 v))
-  v)
-
-(defun aref-card29 (a i)
-  (aref a i))
-
-(defun aset-card29 (v a i)
-  (setf (aref a i) v))
-
-)
-
-#+excl
-(progn
-  
-(defun aref-card8 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values card8))
-  #.(declare-buffun)
-  (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-			 :unsigned-byte)))
-
-(defun aset-card8 (v a i)
-  (declare (type card8 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-		    :unsigned-byte) v))
-
-(defun aref-int8 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values int8))
-  #.(declare-buffun)
-  (the int8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-			:signed-byte)))
-
-(defun aset-int8 (v a i)
-  (declare (type int8 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-		    :signed-byte) v))
-
-(defun aref-card16 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values card16))
-  #.(declare-buffun)
-  (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-			  :unsigned-word)))
-  
-(defun aset-card16 (v a i)
-  (declare (type card16 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-		    :unsigned-word) v))
-  
-(defun aref-int16 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values int16))
-  #.(declare-buffun)
-  (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-			 :signed-word)))
-  
-(defun aset-int16 (v a i)
-  (declare (type int16 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-		    :signed-word) v))
-  
-(defun aref-card32 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values card32))
-  #.(declare-buffun)
-  (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-			  :unsigned-long)))
-    
-(defun aset-card32 (v a i)
-  (declare (type card32 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-		    :unsigned-long) v))
-
-(defun aref-int32 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values int32))
-  #.(declare-buffun)
-  (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-			 :signed-long)))
-    
-(defun aset-int32 (v a i)
-  (declare (type int32 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-		    :signed-long) v))
-
-(defun aref-card29 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values card29))
-  #.(declare-buffun)
-  (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-			  :unsigned-long)))
-
-(defun aset-card29 (v a i)
-  (declare (type card29 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
-		    :unsigned-long) v))
-  
-)
-
-#+lcl3.0
-(progn
-
-(defun aref-card8 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i)
-	   (clx-values card8))
-  #.(declare-buffun)
-  (the card8 (lucid::%svref-8bit a i)))
-
-(defun aset-card8 (v a i)
-  (declare (type card8 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (lucid::%svref-8bit a i) v))
-
-(defun aref-int8 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i)
-	   (clx-values int8))
-  #.(declare-buffun)
-  (the int8 (lucid::%svref-signed-8bit a i)))
-
-(defun aset-int8 (v a i)
-  (declare (type int8 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (lucid::%svref-signed-8bit a i) v))
-
-(defun aref-card16 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i)
-	   (clx-values card16))
-  #.(declare-buffun)
-  (the card16 (lucid::%svref-16bit a (index-ash i -1))))
-  
-(defun aset-card16 (v a i)
-  (declare (type card16 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (lucid::%svref-16bit a (index-ash i -1)) v))
-  
-(defun aref-int16 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i)
-	   (clx-values int16))
-  #.(declare-buffun)
-  (the int16 (lucid::%svref-signed-16bit a (index-ash i -1))))
-  
-(defun aset-int16 (v a i)
-  (declare (type int16 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v))
-
-(defun aref-card32 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i)
-	   (clx-values card32))
-  #.(declare-buffun)
-  (the card32 (lucid::%svref-32bit a (index-ash i -2))))
-    
-(defun aset-card32 (v a i)
-  (declare (type card32 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (lucid::%svref-32bit a (index-ash i -2)) v))
-
-(defun aref-int32 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i)
-	   (clx-values int32))
-  #.(declare-buffun)
-  (the int32 (lucid::%svref-signed-32bit a (index-ash i -2))))
-    
-(defun aset-int32 (v a i)
-  (declare (type int32 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v))
-
-(defun aref-card29 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i)
-	   (clx-values card29))
-  #.(declare-buffun)
-  (the card29 (lucid::%svref-32bit a (index-ash i -2))))
-
-(defun aset-card29 (v a i)
-  (declare (type card29 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (lucid::%svref-32bit a (index-ash i -2)) v))
-
-)
-
-
-
-#-(or excl lcl3.0 clx-overlapping-arrays)
-(progn
-
-(defun aref-card16 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values card16))
-  #.(declare-buffun)
-  (the card16
-       (logior (the card16
-		    (ash (the card8 (aref a (index+ i *word-1*))) 8))
-	       (the card8
-		    (aref a (index+ i *word-0*))))))
-
-(defun aset-card16 (v a i)
-  (declare (type card16 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
-	(aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
-  v)
-
-(defun aref-int16 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values int16))
-  #.(declare-buffun)
-  (the int16
-       (logior (the int16
-		    (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8))
-	       (the card8
-		    (aref a (index+ i *word-0*))))))
-
-(defun aset-int16 (v a i)
-  (declare (type int16 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
-	(aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
-  v)
-
-(defun aref-card32 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values card32))
-  #.(declare-buffun)
-  (the card32
-       (logior (the card32
-		    (ash (the card8 (aref a (index+ i *long-3*))) 24))
-	       (the card29
-		    (ash (the card8 (aref a (index+ i *long-2*))) 16))
-	       (the card16
-		    (ash (the card8 (aref a (index+ i *long-1*))) 8))
-	       (the card8
-		    (aref a (index+ i *long-0*))))))
-
-(defun aset-card32 (v a i)
-  (declare (type card32 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
-	(aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
-	(aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
-	(aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
-  v)
-
-(defun aref-int32 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values int32))
-  #.(declare-buffun)
-  (the int32
-       (logior (the int32
-		    (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24))
-	       (the card29
-		    (ash (the card8 (aref a (index+ i *long-2*))) 16))
-	       (the card16
-		    (ash (the card8 (aref a (index+ i *long-1*))) 8))
-	       (the card8
-		    (aref a (index+ i *long-0*))))))
-
-(defun aset-int32 (v a i)
-  (declare (type int32 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
-	(aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
-	(aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
-	(aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
-  v)
-
-(defun aref-card29 (a i)
-  (declare (type buffer-bytes a)
-	   (type array-index i))
-  (declare (clx-values card29))
-  #.(declare-buffun)
-  (the card29
-       (logior (the card29
-		    (ash (the card8 (aref a (index+ i *long-3*))) 24))
-	       (the card29
-		    (ash (the card8 (aref a (index+ i *long-2*))) 16))
-	       (the card16
-		    (ash (the card8 (aref a (index+ i *long-1*))) 8))
-	       (the card8
-		    (aref a (index+ i *long-0*))))))
-
-(defun aset-card29 (v a i)
-  (declare (type card29 v)
-	   (type buffer-bytes a)
-	   (type array-index i))
-  #.(declare-buffun)
-  (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
-	(aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
-	(aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
-	(aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
-  v)
-
-)
-
-(defsetf aref-card8 (a i) (v)
-  `(aset-card8 ,v ,a ,i))
-
-(defsetf aref-int8 (a i) (v)
-  `(aset-int8 ,v ,a ,i))
-
-(defsetf aref-card16 (a i) (v)
-  `(aset-card16 ,v ,a ,i))
-
-(defsetf aref-int16 (a i) (v)
-  `(aset-int16 ,v ,a ,i))
-
-(defsetf aref-card32 (a i) (v)
-  `(aset-card32 ,v ,a ,i))
-
-(defsetf aref-int32 (a i) (v)
-  `(aset-int32 ,v ,a ,i))
-
-(defsetf aref-card29 (a i) (v)
-  `(aset-card29 ,v ,a ,i))
-
-;;; Other random conversions
-
-(defun rgb-val->card16 (value)
-  ;; Short floats are good enough
-  (declare (type rgb-val value))
-  (declare (clx-values card16))
-  #.(declare-buffun)
-  ;; Convert VALUE from float to card16
-  (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff)))))
-
-(defun card16->rgb-val (value) 
-  ;; Short floats are good enough
-  (declare (type card16 value))
-  (declare (clx-values short-float))
-  #.(declare-buffun)
-  ;; Convert VALUE from card16 to float
-  (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff))))
-
-(defun radians->int16 (value)
-  ;; Short floats are good enough
-  (declare (type angle value))
-  (declare (clx-values int16))
-  #.(declare-buffun)
-  (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0)))))
-
-(defun int16->radians (value)
-  ;; Short floats are good enough
-  (declare (type int16 value))
-  (declare (clx-values short-float))
-  #.(declare-buffun)
-  (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
-
-
-;;-----------------------------------------------------------------------------
-;; Character transformation
-;;-----------------------------------------------------------------------------
-
-
-;;; This stuff transforms chars to ascii codes in card8's and back.
-;;; You might have to hack it a little to get it to work for your machine.
-
-(declaim (inline char->card8 card8->char))
-
-(macrolet ((char-translators ()
-	     (let ((alist
-		     `(#-lispm
-		       ;; The normal ascii codes for the control characters.
-		       ,@`((#\Return . 13)
-			   (#\Linefeed . 10)
-			   (#\Rubout . 127)
-			   (#\Page . 12)
-			   (#\Tab . 9)
-			   (#\Backspace . 8)
-			   (#\Newline . 10)
-			   (#\Space . 32))
-		       ;; One the lispm, #\Newline is #\Return, but we'd really like
-		       ;; #\Newline to translate to ascii code 10, so we swap the
-		       ;; Ascii codes for #\Return and #\Linefeed. We also provide
-		       ;; mappings from the counterparts of these control characters
-		       ;; so that the character mapping from the lisp machine
-		       ;; character set to ascii is invertible.
-		       #+lispm
-		       ,@`((#\Return . 10)   (,(code-char  10) . ,(char-code #\Return))
-			   (#\Linefeed . 13) (,(code-char  13) . ,(char-code #\Linefeed))
-			   (#\Rubout . 127)  (,(code-char 127) . ,(char-code #\Rubout))
-			   (#\Page . 12)     (,(code-char  12) . ,(char-code #\Page))
-			   (#\Tab . 9)       (,(code-char   9) . ,(char-code #\Tab))
-			   (#\Backspace . 8) (,(code-char   8) . ,(char-code #\Backspace))
-			   (#\Newline . 10)  (,(code-char  10) . ,(char-code #\Newline))
-			   (#\Space . 32)    (,(code-char  32) . ,(char-code #\Space)))
-		       ;; The rest of the common lisp charater set with the normal
-		       ;; ascii codes for them.
-		       (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
-		       (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40)
-		       (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44)
-		       (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48)
-		       (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52)
-		       (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56)
-		       (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60)
-		       (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64)
-		       (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68)
-		       (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72)
-		       (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76)
-		       (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80)
-		       (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84)
-		       (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88)
-		       (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92)
-		       (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96)
-		       (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100)
-		       (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104)
-		       (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108)
-		       (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112)
-		       (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116)
-		       (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120)
-		       (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124)
-		       (#\} . 125) (#\~ . 126))))
-	       (cond ((dolist (pair alist nil)
-			(when (not (= (char-code (car pair)) (cdr pair)))
-			  (return t)))
-		      `(progn
-			 (defconstant *char-to-card8-translation-table*
-				      ',(let ((array (make-array
-						       (let ((max-char-code 255))
-							 (dolist (pair alist)
-							   (setq max-char-code
-								 (max max-char-code
-								      (char-code (car pair)))))
-							 (1+ max-char-code))
-						       :element-type 'card8)))
-					  (dotimes (i (length array))
-					    (setf (aref array i) (mod i 256)))
-					  (dolist (pair alist)
-					    (setf (aref array (char-code (car pair)))
-						  (cdr pair)))
-					  array))
-			 (defconstant *card8-to-char-translation-table*
-				      ',(let ((array (make-array 256)))
-					  (dotimes (i (length array))
-					    (setf (aref array i) (code-char i)))
-					  (dolist (pair alist)
-					    (setf (aref array (cdr pair)) (car pair)))
-					  array))
-			 #-Genera
-			 (progn
-  			   (defun char->card8 (char)
-			     (declare (type base-char char))
-			     #.(declare-buffun)
-			     (the card8 (aref (the (simple-array card8 (*))
-						   *char-to-card8-translation-table*)
-					      (the array-index (char-code char)))))
-			   (defun card8->char (card8)
-			     (declare (type card8 card8))
-			     #.(declare-buffun)
-			     (the base-char
-				  (or (aref (the simple-vector *card8-to-char-translation-table*)
-					    card8)
-				      (error "Invalid CHAR code ~D." card8))))
-			   )
-			 #+Genera
-			 (progn
-			   (defun char->card8 (char)
-			     (declare lt:(side-effects reader reducible))
-			     (aref *char-to-card8-translation-table* (char-code char)))
-			   (defun card8->char (card8)
-			     (declare lt:(side-effects reader reducible))
-			     (aref *card8-to-char-translation-table* card8))
-			   )
-			 #-Minima
-			 (dotimes (i 256)
-			   (unless (= i (char->card8 (card8->char i)))
-			     (warn "The card8->char mapping is not invertible through char->card8.  Info:~%~S"
-				   (list i
-					 (card8->char i)
-					 (char->card8 (card8->char i))))
-			     (return nil)))
-			 #-Minima
-			 (dotimes (i (length *char-to-card8-translation-table*))
-			   (let ((char (code-char i)))
-			     (unless (eql char (card8->char (char->card8 char)))
-			       (warn "The char->card8 mapping is not invertible through card8->char.  Info:~%~S"
-				     (list char
-					   (char->card8 char)
-					   (card8->char (char->card8 char))))
-			       (return nil))))))
-		     (t
-		      `(progn
-			 (defun char->card8 (char)
-			   (declare (type base-char char))
-			   #.(declare-buffun)
-			   (the card8 (char-code char)))
-			 (defun card8->char (card8)
-			   (declare (type card8 card8))
-			   #.(declare-buffun)
-			   (the base-char (code-char card8)))
-			 ))))))
-  (char-translators))
-
-;;-----------------------------------------------------------------------------
-;; Process Locking
-;;
-;;	Common-Lisp doesn't provide process locking primitives, so we define
-;;	our own here, based on Zetalisp primitives.  Holding-Lock is very
-;;	similar to with-lock on The TI Explorer, and a little more efficient
-;;	than with-process-lock on a Symbolics.
-;;-----------------------------------------------------------------------------
-
-;;; MAKE-PROCESS-LOCK: Creating a process lock.
-
-#-(or LispM excl Minima)
-(defun make-process-lock (name)
-  (declare (ignore name))
-  nil)
-
-#+excl
-(defun make-process-lock (name)
-  (mp:make-process-lock :name name))
-
-#+(and LispM (not Genera))
-(defun make-process-lock (name)
-  (vector nil name))
-
-#+Genera
-(defun make-process-lock (name)
-  (process:make-lock name :flavor 'clx-lock))
-
-#+Minima
-(defun make-process-lock (name)
-  (minima:make-lock name :recursive t))
-
-;;; HOLDING-LOCK: Execute a body of code with a lock held.
-
-;;; The holding-lock macro takes a timeout keyword argument.  EVENT-LISTEN
-;;; passes its timeout to the holding-lock macro, so any timeout you want to
-;;; work for event-listen you should do for holding-lock.
-
-;; If you're not sharing DISPLAY objects within a multi-processing
-;; shared-memory environment, this is sufficient
-#-(or lispm excl lcl3.0 Minima CMU)
-(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
-  (declare (ignore locator display whostate timeout))
-  `(progn ,@body))
-
-;;; HOLDING-LOCK for CMU Common Lisp.
-;;;
-;;; We are not multi-processing, but we use this macro to try to protect
-;;; against re-entering request functions.  This can happen if an interrupt
-;;; occurs and the handler attempts to use X over the same display connection.
-;;; This can happen if the GC hooks are used to notify the user over the same
-;;; display connection.  We lock out GC's just as a dummy check for our users.
-;;; Locking out interrupts has the problem that CLX always waits for replies
-;;; within this dynamic scope, so if the server cannot reply for some reason,
-;;; we potentially dead-lock without interrupts.
-;;;
-#+CMU
-(defmacro holding-lock ((locator display &optional whostate &key timeout)
-			&body body)
-  (declare (ignore locator display whostate timeout))
-  `(lisp::without-gcing (system:without-interrupts (progn ,@body))))
-
-#+Genera
-(defmacro holding-lock ((locator display &optional whostate &key timeout)
-			&body body)
-  (declare (ignore whostate))
-  `(process:with-lock (,locator :timeout ,timeout)
-     (let ((.debug-io. (buffer-debug-io ,display)))
-       (scl:let-if .debug-io. ((*debug-io* .debug-io.))
-	 ,@body))))
-
-#+(and lispm (not Genera))
-(defmacro holding-lock ((locator display &optional whostate &key timeout)
-			&body body)
-  (declare (ignore display))
-  ;; This macro is for use in a multi-process environment.
-  (let ((lock (gensym))
-	(have-lock (gensym))
-	(timeo (gensym)))
-    `(let* ((,lock (zl:locf (svref ,locator 0)))
-	    (,have-lock (eq (car ,lock) sys:current-process))
-	    (,timeo ,timeout))
-       (unwind-protect 
-	   (when (cond (,have-lock)
-		       ((#+explorer si:%store-conditional
-			 #-explorer sys:store-conditional
-			 ,lock nil sys:current-process))
-		       ((null ,timeo)
-			(sys:process-lock ,lock nil ,(or whostate "CLX Lock")))
-		       ((sys:process-wait-with-timeout
-			    ,(or whostate "CLX Lock") (round (* ,timeo 60.))
-			  #'(lambda (lock process)
-			      (#+explorer si:%store-conditional
-			       #-explorer sys:store-conditional
-			       lock nil process))
-			  ,lock sys:current-process)))
-	     ,@body)
-	 (unless ,have-lock
-	   (#+explorer si:%store-conditional
-	    #-explorer sys:store-conditional
-	    ,lock sys:current-process nil))))))
-
-;; Lucid has a process locking mechanism as well under release 3.0
-#+lcl3.0
-(defmacro holding-lock ((locator display &optional whostate &key timeout)
-			&body body)
-  (declare (ignore display))
-  (if timeout
-      ;; Hair to support timeout.
-      `(let ((.have-lock. (eq ,locator lcl:*current-process*))
-	     (.timeout. ,timeout))
-	 (unwind-protect
-	     (when (cond (.have-lock.)
-			 ((conditional-store ,locator nil lcl:*current-process*))
-			 ((null .timeout.)
-			  (lcl:process-lock ,locator)
-			  t)
-			 ((lcl:process-wait-with-timeout ,whostate .timeout.
-			    #'(lambda ()
-				(conditional-store ,locator nil lcl:*current-process*))))
-			 ;; abort the PROCESS-UNLOCK if actually timing out
-			 (t
-			  (setf .have-lock. :abort)
-			  nil))
-	       ,@body)
-	   (unless .have-lock. 
-	     (lcl:process-unlock ,locator))))
-    `(lcl:with-process-lock (,locator)
-       ,@body)))
-
-
-#+excl
-(defmacro holding-lock ((locator display &optional whostate &key timeout)
-			&body body)
-  (declare (ignore display))
-  `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.)
-     (unwind-protect
-	 (block .hl-doit.
-	   (when mp::*scheduler-stack-group* ; fast test for scheduler running
-	     (setq .hl-lock. ,locator
-		   .hl-curproc. mp::*current-process*)
-	     (when (and .hl-curproc.	; nil if in process-wait fun
-			(not (eq (mp::process-lock-locker .hl-lock.)
-				 .hl-curproc.)))
-	       ;; Then we need to grab the lock.
-	       ,(if timeout
-		    `(if (not (mp::process-lock .hl-lock. .hl-curproc.
-						,whostate ,timeout))
-			 (return-from .hl-doit. nil))
-		  `(mp::process-lock .hl-lock. .hl-curproc.
-				     ,@(when whostate `(,whostate))))
-	       ;; There is an apparent race condition here.  However, there is
-	       ;; no actual race condition -- our implementation of mp:process-
-	       ;; lock guarantees that the lock will still be held when it
-	       ;; returns, and no interrupt can happen between that and the
-	       ;; execution of the next form.  -- jdi 2/27/91
-	       (setq .hl-obtained-lock. t)))
-	   ,@body)
-       (if (and .hl-obtained-lock.
-		;; Note -- next form added to allow error handler inside
-		;; body to unlock the lock prematurely if it knows that
-		;; the current process cannot possibly continue but will
-		;; throw out (or is it throw up?).
-		(eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))
-	   (mp::process-unlock .hl-lock. .hl-curproc.)))))
-
-#+Minima
-(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
-  `(holding-lock-1 #'(lambda () ,@body) ,locator ,display
-		   ,@(and whostate `(:whostate ,whostate))
-		   ,@(and timeout `(:timeout ,timeout))))
-
-#+Minima
-(defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout)
-  (declare (dynamic-extent continuation))
-  (declare (ignore display whostate timeout))
-  (minima:with-lock (lock)
-    (funcall continuation)))
-
-;;; WITHOUT-ABORTS
-
-;;; If you can inhibit asynchronous keyboard aborts inside the body of this
-;;; macro, then it is a good idea to do this.  This macro is wrapped around
-;;; request writing and reply reading to ensure that requests are atomically
-;;; written and replies are atomically read from the stream.
-
-#-(or Genera excl lcl3.0)
-(defmacro without-aborts (&body body)
-  `(progn ,@body))
-
-#+Genera
-(defmacro without-aborts (&body body)
-  `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.")
-     ,@body))
-
-#+excl
-(defmacro without-aborts (&body body)
-  `(without-interrupts ,@body))
-    
-#+lcl3.0
-(defmacro without-aborts (&body body)
-  `(lcl:with-interruptions-inhibited ,@body))
-
-;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.
-;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
-;;; value changes.
-
-#-(or lispm excl lcl3.0 Minima)
-(defun process-block (whostate predicate &rest predicate-args)
-  (declare (ignore whostate))
-  (or (apply predicate predicate-args)
-      (error "Program tried to wait with no scheduler.")))
-
-#+Genera
-(defun process-block (whostate predicate &rest predicate-args)
-  (declare (type function predicate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent predicate)
-	   #-clx-ansi-common-lisp
-	   (sys:downward-funarg predicate))
-  (apply #'process:block-process whostate predicate predicate-args))
-
-#+(and lispm (not Genera))
-(defun process-block (whostate predicate &rest predicate-args)
-  (declare (type function predicate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent predicate)
-	   #-clx-ansi-common-lisp 
-	   (sys:downward-funarg predicate))
-  (apply #'global:process-wait whostate predicate predicate-args))
-
-#+excl
-(defun process-block (whostate predicate &rest predicate-args)
-  (if mp::*scheduler-stack-group*
-      (apply #'mp::process-wait whostate predicate predicate-args)
-      (or (apply predicate predicate-args)
-	  (error "Program tried to wait with no scheduler."))))
-
-#+lcl3.0
-(defun process-block (whostate predicate &rest predicate-args)
-  (declare (dynamic-extent predicate-args))
-  (apply #'lcl:process-wait whostate predicate predicate-args))
-
-#+Minima
-(defun process-block (whostate predicate &rest predicate-args)
-  (declare (type function predicate)
-	   (dynamic-extent predicate))
-  (apply #'minima:process-wait whostate predicate predicate-args))
-
-;;; PROCESS-WAKEUP: Check some other process' wait function.
-
-(declaim (inline process-wakeup))
-
-#-(or excl Genera Minima)
-(defun process-wakeup (process)
-  (declare (ignore process))
-  nil)
-
-#+excl
-(defun process-wakeup (process)
-  (let ((curproc mp::*current-process*))
-    (when (and curproc process)
-      (unless (mp::process-p curproc)
-	(error "~s is not a process" curproc))
-      (unless (mp::process-p process)
-	(error "~s is not a process" process))
-      (if (> (mp::process-priority process) (mp::process-priority curproc))
-	  (mp::process-allow-schedule process)))))
-
-#+Genera
-(defun process-wakeup (process)
-  (process:wakeup process))
-
-#+Minima
-(defun process-wakeup (process)
-  (when process
-    (minima:process-wakeup process)))
-
-;;; CURRENT-PROCESS: Return the current process object for input locking and
-;;; for calling PROCESS-WAKEUP.
-
-(declaim (inline current-process))
-
-;;; Default return NIL, which is acceptable even if there is a scheduler.
-
-#-(or lispm excl lcl3.0 Minima)
-(defun current-process ()
-  nil)
-
-#+lispm
-(defun current-process ()
-  sys:current-process)
-
-#+excl
-(defun current-process ()
-  (and mp::*scheduler-stack-group*
-       mp::*current-process*))
-
-#+lcl3.0
-(defun current-process ()
-  lcl:*current-process*)
-
-#+Minima
-(defun current-process ()
-  (minima:current-process))
-
-;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
-
-#-(or lispm excl lcl3.0 Minima)
-(defmacro without-interrupts (&body body)
-  `(progn ,@body))
-
-#+(and lispm (not Genera))
-(defmacro without-interrupts (&body body)
-  `(sys:without-interrupts ,@body))
-
-#+Genera
-(defmacro without-interrupts (&body body)
-  `(process:with-no-other-processes ,@body))
-
-#+LCL3.0
-(defmacro without-interrupts (&body body)
-  `(lcl:with-scheduling-inhibited ,@body))
-
-#+Minima
-(defmacro without-interrupts (&body body)
-  `(minima:with-no-other-processes ,@body))
-
-;;; CONDITIONAL-STORE:
-
-;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.
-;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.
-(defmacro conditional-store (place old-value new-value)
-  `(without-interrupts
-     (cond ((eq ,place ,old-value)
-	    (setf ,place ,new-value)
-	    t))))
-
-;;;----------------------------------------------------------------------------
-;;; IO Error Recovery
-;;;	All I/O operations are done within a WRAP-BUF-OUTPUT macro.
-;;;	It prevents multiple mindless errors when the network craters.
-;;;
-;;;----------------------------------------------------------------------------
-
-#-Genera
-(defmacro wrap-buf-output ((buffer) &body body)
-  ;; Error recovery wrapper
-  `(unless (buffer-dead ,buffer)
-     ,@body))
-
-#+Genera
-(defmacro wrap-buf-output ((buffer) &body body)
-  ;; Error recovery wrapper
-  `(let ((.buffer. ,buffer))
-     (unless (buffer-dead .buffer.)
-       (scl:condition-bind
-	 (((sys:network-error)
-	   #'(lambda (error)
-	       (scl:condition-case () 
-		    (funcall (buffer-close-function .buffer.) .buffer. :abort t)
-		  (sys:network-error))
-	       (setf (buffer-dead .buffer.) error)
-	       (setf (buffer-output-stream .buffer.) nil)
-	       (setf (buffer-input-stream .buffer.) nil)
-	       nil)))
-	 ,@body))))
-
-#-Genera
-(defmacro wrap-buf-input ((buffer) &body body)
-  (declare (ignore buffer))
-  ;; Error recovery wrapper
-  `(progn ,@body))
-
-#+Genera
-(defmacro wrap-buf-input ((buffer) &body body)
-  ;; Error recovery wrapper
-  `(let ((.buffer. ,buffer))
-     (scl:condition-bind
-       (((sys:network-error)
-	 #'(lambda (error)
-	     (scl:condition-case () 
-		  (funcall (buffer-close-function .buffer.) .buffer. :abort t)
-		(sys:network-error))
-	     (setf (buffer-dead .buffer.) error)
-	     (setf (buffer-output-stream .buffer.) nil)
-	     (setf (buffer-input-stream .buffer.) nil)
-	     nil)))
-       ,@body)))
-
-
-;;;----------------------------------------------------------------------------
-;;; System dependent IO primitives
-;;;	Functions for opening, reading writing forcing-output and closing 
-;;;	the stream to the server.
-;;;----------------------------------------------------------------------------
-
-;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
-;;; server
-
-#-(or explorer Genera lucid kcl ibcl excl Minima CMU)
-(defun open-x-stream (host display protocol)
-  host display protocol ;; unused
-  (error "OPEN-X-STREAM not implemented yet."))
-
-;;; Genera:
-
-;;; TCP and DNA are both layered products, so try to work with either one.
-
-#+Genera
-(when (fboundp 'tcp:add-tcp-port-for-protocol)
-  (tcp:add-tcp-port-for-protocol :x-window-system 6000))
-
-#+Genera
-(when (fboundp 'dna:add-dna-contact-id-for-protocol)
-  (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0"))
-
-#+Genera
-(net:define-protocol :x-window-system (:x-window-system :byte-stream)
-  (:invoke-with-stream ((stream :characters nil :ascii-translation nil))
-    stream))
-
-#+Genera
-(eval-when (compile)
-  (compiler:function-defined 'tcp:open-tcp-stream)
-  (compiler:function-defined 'dna:open-dna-bidirectional-stream))
-
-#+Genera
-(defun open-x-stream (host display protocol)
-  (let ((host (net:parse-host host)))
-    (if (or protocol (plusp display))
-	;; The protocol was specified or the display isn't 0, so we
-	;; can't use the Generic Network System.  If the protocol was
-	;; specified, then use that protocol, otherwise, blindly use
-	;; TCP.
-	(ccase protocol
-	  ((:tcp nil)
-	   (tcp:open-tcp-stream
-	     host (+ *x-tcp-port* display) nil
-	     :direction :io
-	     :characters nil
-	     :ascii-translation nil))
-	  ((:dna)
-	   (dna:open-dna-bidirectional-stream
-	     host (format nil "X$X~D" display)
-	     :characters nil
-	     :ascii-translation nil)))
-      (let ((neti:*invoke-service-automatic-retry* t))
-	(net:invoke-service-on-host :x-window-system host)))))
-
-#+explorer
-(defun open-x-stream (host display protocol)
-  (declare (ignore protocol))
-  (net:open-connection-on-medium
-    (net:parse-host host)			;Host
-    :byte-stream				;Medium
-    "X11"					;Logical contact name
-    :stream-type :character-stream
-    :direction :bidirectional
-    :timeout-after-open nil
-    :remote-port (+ *x-tcp-port* display)))
-
-#+explorer
-(net:define-logical-contact-name
-  "X11"
-  `((:local "X11")
-    (:chaos "X11")
-    (:nsp-stream "X11")
-    (:tcp ,*x-tcp-port*)))
-
-#+lucid
-(defun open-x-stream (host display protocol)
-  protocol ;; unused
-  (let ((fd (connect-to-server host display)))
-    (when (minusp fd)
-      (error "Failed to connect to server: ~A ~D" host display))
-    (user::make-lisp-stream :input-handle fd
-			    :output-handle fd
-			    :element-type 'unsigned-byte
-			    #-lcl3.0 :stream-type #-lcl3.0 :ephemeral)))
-
-#+(or kcl ibcl)
-(defun open-x-stream (host display protocol)
-  protocol ;; unused
-  (let ((stream (open-socket-stream host display)))
-    (if (streamp stream)
-	stream
-      (error "Cannot connect to server: ~A:~D" host display))))
-
-#+excl
-;;
-;; Note that since we don't use the CL i/o facilities to do i/o, the display
-;; input and output "stream" is really a file descriptor (fixnum).
-;;
-(defun open-x-stream (host display protocol)
-  (declare (ignore protocol));; unused
-  (let ((fd (connect-to-server (string host) display)))
-    (when (minusp fd)
-      (error "Failed to connect to server: ~A ~D" host display))
-    fd))
-
-#+Minima
-(defun open-x-stream (host display protocol)
-  (declare (ignore protocol));; unused
-  (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address
-						  (cdr (host-address host)))
-			  :foreign-port (+ *x-tcp-port* display)))
-
-;;; OPEN-X-STREAM -- for CMU Common Lisp.
-;;;
-;;; The file descriptor here just gets tossed into the stream slot of the
-;;; display object instead of a stream.
-;;;
-#+CMU
-(defun open-x-stream (host display protocol)
-  (declare (ignore protocol))
-  (let ((server-fd (connect-to-server host display)))
-    (unless (plusp server-fd)
-      (error "Failed to connect to X11 server: ~A (display ~D)" host display))
-    (system:make-fd-stream server-fd :input t :output t
-			   :element-type '(unsigned-byte 8))))
-
-;;; This loads the C foreign function used to make an IPC connection
-;;; to the X11 server.  It also defines the necessary types and things
-;;; to actually make the foreign call.  See the OPEN-X-STREAM function
-;;; in the dependent.lisp file.
-;;;
-#+CMU
-(ext:def-c-routine ("connect_to_server" connect-to-server) (ext:int)
-  (host system:null-terminated-string)
-  (port ext:int))
-
-;;; BUFFER-READ-DEFAULT - read data from the X stream
-
-#+(or Genera explorer)
-(defun buffer-read-default (display vector start end timeout)
-  ;; returns non-NIL if EOF encountered
-  ;; Returns :TIMEOUT when timeout exceeded
-  (declare (type display display)
-	   (type buffer-bytes vector)
-	   (type array-index start end)
-	   (type (or null (real 0 *)) timeout))
-  #.(declare-buffun)
-  (let ((stream (display-input-stream display)))
-    (or (cond ((null stream))
-	      ((funcall stream :listen) nil)
-	      ((and timeout (= timeout 0)) :timeout)
-	      ((buffer-input-wait-default display timeout)))
-	(multiple-value-bind (ignore eofp)
-	    (funcall stream :string-in nil vector start end)
-	  eofp))))
-
-
-#+excl
-;;
-;; Rewritten 10/89 to not use foreign function interface to do I/O.
-;;
-(defun buffer-read-default (display vector start end timeout)
-  (declare (type display display)
-	   (type buffer-bytes vector)
-	   (type array-index start end)
-	   (type (or null (real 0 *)) timeout))
-  #.(declare-buffun)
-    
-  (let* ((howmany (- end start))
-	 (fd (display-input-stream display)))
-    (declare (type array-index howmany)
-	     (fixnum fd))
-    (or (cond ((fd-char-avail-p fd) nil)
-	      ((and timeout (= timeout 0)) :timeout)
-	      ((buffer-input-wait-default display timeout)))
-	(fd-read-bytes fd vector start howmany))))
-
-
-#+lcl3.0
-(defmacro with-underlying-stream ((variable stream display direction) &body body)
-  `(let ((,variable
-	  (or (getf (display-plist ,display) ',direction)
-	      (setf (getf (display-plist ,display) ',direction)
-		    (lucid::underlying-stream
-		      ,stream ,(if (eq direction 'input) :input :output))))))
-     ,@body))
-
-#+lcl3.0
-(defun buffer-read-default (display vector start end timeout)
-  ;;Note that LISTEN must still be done on "slow stream" or the I/O system
-  ;;gets confused.  But reading should be done from "fast stream" for speed.
-  ;;We used to inhibit scheduling because there were races in Lucid's
-  ;;multitasking system.  Empirical evidence suggests they may be gone now.
-  ;;Should you decide you need to inhibit scheduling, do it around the
-  ;;lcl:read-array.
-  (declare (type display display)
-	   (type buffer-bytes vector)
-	   (type array-index start end)
-	   (type (or null (real 0 *)) timeout))
-  #.(declare-buffun)
-  (let ((stream (display-input-stream display)))
-    (declare (type (or null stream) stream))
-    (or (cond ((null stream))
-	      ((listen stream) nil)
-	      ((and timeout (= timeout 0)) :timeout)
-	      ((buffer-input-wait-default display timeout)))
-	(with-underlying-stream (stream stream display input)
-	  (eq (lcl:read-array stream vector start end nil :eof) :eof)))))
-
-#+Minima
-(defun buffer-read-default (display vector start end timeout)
-  ;; returns non-NIL if EOF encountered
-  ;; Returns :TIMEOUT when timeout exceeded
-  (declare (type display display)
-	   (type buffer-bytes vector)
-	   (type array-index start end)
-	   (type (or null (real 0 *)) timeout))
-  #.(declare-buffun)
-  (let ((stream (display-input-stream display)))
-    (or (cond ((null stream))
-	      ((listen stream) nil)
-	      ((and timeout (= timeout 0)) :timeout)
-	      ((buffer-input-wait-default display timeout)))
-	(eq :eof (minima:read-vector vector stream nil start end)))))
-
-;;; BUFFER-READ-DEFAULT for CMU Common Lisp.
-;;;
-;;;    If timeout is 0, then we call LISTEN to see if there is any input.
-;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without
-;;; first calling BUFFER-INPUT-WAIT-DEFAULT.
-;;;
-#+CMU
-(defun buffer-read-default (display vector start end timeout)
-  (declare (type display display)
-	   (type buffer-bytes vector)
-	   (type array-index start end)
-	   (type (or null (real 0 *)) timeout))
-  #.(declare-buffun)
-  (cond ((and (and timeout (= timeout 0))
-	      (not (listen (display-input-stream display))))
-	 :timeout)
-	(t
-	 (system:read-n-bytes (display-input-stream display)
-			      vector start (- end start))
-	 nil)))
-
-;;; WARNING:
-;;;	CLX performance will suffer if your lisp uses read-byte for
-;;;	receiving all data from the X Window System server.
-;;;	You are encouraged to write a specialized version of
-;;;	buffer-read-default that does block transfers.
-#-(or Genera explorer excl lcl3.0 Minima CMU)
-(defun buffer-read-default (display vector start end timeout)
-  (declare (type display display)
-	   (type buffer-bytes vector)
-	   (type array-index start end)
-	   (type (or null (real 0 *)) timeout))
-  #.(declare-buffun)
-  (let ((stream (display-input-stream display)))
-    (declare (type (or null stream) stream))
-    (or (cond ((null stream))
-	      ((listen stream) nil)
-	      ((and timeout (= timeout 0)) :timeout)
-	      ((buffer-input-wait-default display timeout)))
-	(do* ((index start (index1+ index)))
-	     ((index>= index end) nil)
-	  (declare (type array-index index))
-	  (let ((c (read-byte stream nil nil)))
-	    (declare (type (or null card8) c))
-	    (if (null c)
-		(return t)
-	      (setf (aref vector index) (the card8 c))))))))
-
-;;; BUFFER-WRITE-DEFAULT - write data to the X stream
-
-#+(or Genera explorer)
-(defun buffer-write-default (vector display start end)
-  ;; The default buffer write function for use with common-lisp streams
-  (declare (type buffer-bytes vector)
-	   (type display display)
-	   (type array-index start end))
-  #.(declare-buffun)
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-    (unless (null stream) 
-      (write-string vector stream :start start :end end))))
-
-#+excl
-(defun buffer-write-default (vector display start end)
-  (declare (type buffer-bytes vector)
-	   (type display display)
-	   (type array-index start end))
-  #.(declare-buffun)
-  (excl::filesys-write-bytes (display-output-stream display) vector start
-			     (- end start)))
-  
-#+lcl3.0
-(defun buffer-write-default (vector display start end)
-  ;;We used to inhibit scheduling because there were races in Lucid's
-  ;;multitasking system.  Empirical evidence suggests they may be gone now.
-  ;;Should you decide you need to inhibit scheduling, do it around the
-  ;;lcl:write-array.
-  (declare (type display display)
-	   (type buffer-bytes vector)
-	   (type array-index start end))
-  #.(declare-buffun)
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-    (unless (null stream) 
-      (with-underlying-stream (stream stream display output)
-	(lcl:write-array stream vector start end)))))
-
-#+Minima
-(defun buffer-write-default (vector display start end)
-  ;; The default buffer write function for use with common-lisp streams
-  (declare (type buffer-bytes vector)
-	   (type display display)
-	   (type array-index start end))
-  #.(declare-buffun)
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-    (unless (null stream) 
-      (minima:write-vector vector stream start end))))
-
-#+CMU
-(defun buffer-write-default (vector display start end)
-  (declare (type buffer-bytes vector)
-	   (type display display)
-	   (type array-index start end))
-  #.(declare-buffun)
-  (system:output-raw-bytes (display-output-stream display) vector start end)
-  nil)
-
-;;; WARNING:
-;;;	CLX performance will be severely degraded if your lisp uses
-;;;	write-byte to send all data to the X Window System server.
-;;;	You are STRONGLY encouraged to write a specialized version
-;;;	of buffer-write-default that does block transfers.
-
-#-(or Genera explorer excl lcl3.0 Minima CMU)
-(defun buffer-write-default (vector display start end)
-  ;; The default buffer write function for use with common-lisp streams
-  (declare (type buffer-bytes vector)
-	   (type display display)
-	   (type array-index start end))
-  #.(declare-buffun)
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-    (unless (null stream)
-      (with-vector (vector buffer-bytes)
-	(do ((index start (index1+ index)))
-	    ((index>= index end))
-	  (declare (type array-index index))
-	  (write-byte (aref vector index) stream))))))
-
-;;; buffer-force-output-default - force output to the X stream
-
-#+excl
-(defun buffer-force-output-default (display)
-  ;; buffer-write-default does the actual writing.
-  (declare (ignore display)))
-
-#-excl
-(defun buffer-force-output-default (display)
-  ;; The default buffer force-output function for use with common-lisp streams
-  (declare (type display display))
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-    (unless (null stream)
-      (force-output stream))))
-
-;;; BUFFER-CLOSE-DEFAULT - close the X stream
-
-#+excl
-(defun buffer-close-default (display &key abort)
-  ;; The default buffer close function for use with common-lisp streams
-  (declare (type display display)
-	   (ignore abort))
-  #.(declare-buffun)
-  (excl::filesys-checking-close (display-output-stream display)))
-
-#-excl
-(defun buffer-close-default (display &key abort)
-  ;; The default buffer close function for use with common-lisp streams
-  (declare (type display display))
-  #.(declare-buffun)
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-    (unless (null stream)
-      (close stream :abort abort))))
-
-;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the
-;;; buffer.  This is called in read-input between requests, so that a process
-;;; waiting for input is abortable when between requests.  Should return
-;;; :TIMEOUT if it times out, NIL otherwise.
-
-;;; The default implementation
-
-;; Poll for input every *buffer-read-polling-time* SECONDS.
-#-(or Genera explorer excl lcl3.0 CMU)
-(defparameter *buffer-read-polling-time* 0.5)
-
-#-(or Genera explorer excl lcl3.0 CMU)
-(defun buffer-input-wait-default (display timeout)
-  (declare (type display display)
-	   (type (or null (real 0 *)) timeout))
-  (declare (clx-values timeout))
-  
-  (let ((stream (display-input-stream display)))
-    (declare (type (or null stream) stream))
-    (cond ((null stream))
-	  ((listen stream) nil)
-	  ((and timeout (= timeout 0)) :timeout)
-	  ((not (null timeout))
-	   (multiple-value-bind (npoll fraction)
-	       (truncate timeout *buffer-read-polling-time*)
-	     (dotimes (i npoll)			; Sleep for a time, then listen again
-	       (sleep *buffer-read-polling-time*)
-	       (when (listen stream)
-		 (return-from buffer-input-wait-default nil)))
-	     (when (plusp fraction)
-	       (sleep fraction)			; Sleep a fraction of a second
-	       (when (listen stream)		; and listen one last time
-		 (return-from buffer-input-wait-default nil)))
-	     :timeout)))))
-
-#+CMU
-(defun buffer-input-wait-default (display timeout)
-  (declare (type display display)
-	   (type (or null (real 0 *)) timeout))
-  (let ((stream (display-input-stream display)))
-    (declare (type (or null stream) stream))
-    (cond ((null stream))
-	  ((listen stream) nil)
-	  ((and timeout (= timeout 0)) :timeout)
-	  (t
-	   (if (system:wait-until-fd-usable (system:fd-stream-fd stream)
-					    :input timeout)
-	       nil
-	       :timeout)))))
-
-#+Genera
-(defun buffer-input-wait-default (display timeout)
-  (declare (type display display)
-	   (type (or null (real 0 *)) timeout))
-  (declare (clx-values timeout))
-  (let ((stream (display-input-stream display)))
-    (declare (type (or null stream) stream))
-    (cond ((null stream))
-	  ((scl:send stream :listen) nil)
-	  ((and timeout (= timeout 0)) :timeout)
-	  ((null timeout) (si:stream-input-block stream "CLX Input"))
-	  (t
-	   (scl:condition-bind ((neti:protocol-timeout
-				  #'(lambda (error)
-				      (when (eq stream (scl:send error :stream))
-					(return-from buffer-input-wait-default :timeout)))))
-	     (neti:with-stream-timeout (stream :input timeout)
-	       (si:stream-input-block stream "CLX Input")))))
-    nil))
-
-#+explorer
-(defun buffer-input-wait-default (display timeout)
-  (declare (type display display)
-	   (type (or null (real 0 *)) timeout))
-  (declare (clx-values timeout))
-  (let ((stream (display-input-stream display)))
-    (declare (type (or null stream) stream))
-    (cond ((null stream))
-	  ((zl:send stream :listen) nil)
-	  ((and timeout (= timeout 0)) :timeout)
-	  ((null timeout)
-	   (si:process-wait "CLX Input" stream :listen))
-	  (t
-	   (unless (si:process-wait-with-timeout
-		       "CLX Input" (round (* timeout 60.)) stream :listen)
-	     (return-from buffer-input-wait-default :timeout))))
-    nil))
-
-#+excl
-;;
-;; This is used so an 'eq' test may be used to find out whether or not we can
-;; safely throw this process out of the CLX read loop.
-;;
-(defparameter *read-whostate* "waiting for input from X server")
-
-;;
-;; Note that this function returns nil on error if the scheduler is running,
-;; t on error if not.  This is ok since buffer-read will detect the error.
-;;
-#+excl
-(defun buffer-input-wait-default (display timeout)
-  (declare (type display display)
-	   (type (or null (real 0 *)) timeout))
-  (declare (clx-values timeout))
-  (let ((fd (display-input-stream display)))
-    (declare (fixnum fd))
-    (when (>= fd 0)
-      (cond ((fd-char-avail-p fd)
-	     nil)
-	    
-	    ;; Otherwise no bytes were available on the socket
-	    ((and timeout (= timeout 0))
-	     ;; If there aren't enough and timeout == 0, timeout.
-	     :timeout)
-	  
-	    ;; If the scheduler is running let it do timeouts.
-	    (mp::*scheduler-stack-group*
-	     #+allegro
-	     (if (not
-		  (mp:wait-for-input-available fd :whostate *read-whostate*
-					       :wait-function #'fd-char-avail-p
-					       :timeout timeout))
-		 (return-from buffer-input-wait-default :timeout))
-	     #-allegro
-	     (mp::wait-for-input-available fd :whostate *read-whostate*
-					   :wait-function #'fd-char-avail-p))
-	    
-	    ;; Otherwise we have to handle timeouts by hand, and call select()
-	    ;; to block until input is available.  Note we don't really handle
-	    ;; the interaction of interrupts and (numberp timeout) here.  XX
-	    (t
-	     (let ((res 0))
-	       (declare (fixnum res))
-	       (with-interrupt-checking-on
-		(loop
-		  (setq res (fd-wait-for-input fd (if (null timeout) 0
-						    (truncate timeout))))
-		  (cond ((plusp res)	; success
-			 (return nil))
-			((eq res 0)	; timeout
-			 (return :timeout))
-			((eq res -1)	; error
-			 (return t))
-			;; Otherwise we got an interrupt -- go around again.
-			)))))))))
-
-	   
-#+lcl3.0
-(defun buffer-input-wait-default (display timeout)
-  (declare (type display display)
-	   (type (or null (real 0 *)) timeout)
-	   (clx-values timeout))
-  #.(declare-buffun)
-  (let ((stream (display-input-stream display)))
-    (declare (type (or null stream) stream))
-    (cond ((null stream))
-	  ((listen stream) nil)
-	  ((and timeout (= timeout 0)) :timeout)
-	  ((with-underlying-stream (stream stream display input)
-	     (lucid::waiting-for-input-from-stream stream
-               (lucid::with-io-unlocked
-		 (if (null timeout)
-		     (lcl:process-wait "CLX Input" #'listen stream)
-		   (lcl:process-wait-with-timeout
-		     "CLX Input" timeout #'listen stream)))))
-	   nil)
-	  (:timeout))))
-
-
-;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
-;;; buffer. This should never block, so it can be called from the scheduler.
-
-;;; The default implementation is to just use listen.
-#-excl
-(defun buffer-listen-default (display)
-  (declare (type display display))
-  (let ((stream (display-input-stream display)))
-    (declare (type (or null stream) stream))
-    (if (null stream)
-	t
-      (listen stream))))
-
-#+excl 
-(defun buffer-listen-default (display)
-  (declare (type display display))
-  (let ((fd (display-input-stream display)))
-    (declare (type fixnum fd))
-    (if (= fd -1)
-	t
-      (fd-char-avail-p fd))))
-
-
-;;;----------------------------------------------------------------------------
-;;; System dependent speed hacks
-;;;----------------------------------------------------------------------------
-
-;;
-;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature.
-;; If your lisp doesn't have stack-lists, and you're worried about
-;; consing garbage, you may want to re-write this to allocate and
-;; initialize lists from a resource.
-;;
-#-lispm
-(defmacro with-stack-list ((var &rest elements) &body body)
-  ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
-  ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
-  ;; except that the list produced by MAPCAR resides on the stack and
-  ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
-  `(let ((,var (list ,@elements)))
-     (declare (type cons ,var)
-	      #+clx-ansi-common-lisp (dynamic-extent ,var))
-     ,@body))
-
-#-lispm
-(defmacro with-stack-list* ((var &rest elements) &body body)
-  ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
-  ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
-  ;; except that the list produced by MAPCAR resides on the stack and
-  ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
-  `(let ((,var (list* ,@elements)))
-     (declare (type cons ,var)
-	      #+clx-ansi-common-lisp (dynamic-extent ,var))
-     ,@body))
-
-(declaim (inline buffer-replace))
-
-#+lispm
-(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
-  (declare (type vector buf1 buf2)
-	   (type array-index start1 end1 start2))
-  (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1))
-
-#+excl
-(defun buffer-replace (target-sequence source-sequence target-start
-				       target-end &optional (source-start 0))
-  (declare (type buffer-bytes target-sequence source-sequence)
-	   (type array-index target-start target-end source-start)
-	   (optimize (speed 3) (safety 0)))
-  
-  (let ((source-end (length source-sequence)))
-    (declare (type array-index source-end))
-    
-    (excl:if* (and (eq target-sequence source-sequence)
-		   (> target-start source-start))
-       then (let ((nelts (min (- target-end target-start)
-			      (- source-end source-start))))
-	      (do ((target-index (+ target-start nelts -1) (1- target-index))
-		   (source-index (+ source-start nelts -1) (1- source-index)))
-		  ((= target-index (1- target-start)) target-sequence)
-		(declare (type array-index target-index source-index))
-		
-		(setf (aref target-sequence target-index)
-		  (aref source-sequence source-index))))
-       else (do ((target-index target-start (1+ target-index))
-		 (source-index source-start (1+ source-index)))
-		((or (= target-index target-end) (= source-index source-end))
-		 target-sequence)
-	      (declare (type array-index target-index source-index))
-
-	      (setf (aref target-sequence target-index)
-		(aref source-sequence source-index))))))
-
-#+cmu
-(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
-  (declare (type buffer-bytes buf1 buf2)
-	   (type array-index start1 end1 start2))
-  #.(declare-buffun)
-  (kernel:bit-bash-copy
-   buf2 (+ (* start2 vm:byte-bits)
-	   (* vm:vector-data-offset vm:word-bits))
-   buf1 (+ (* start1 vm:byte-bits)
-	   (* vm:vector-data-offset vm:word-bits))
-   (* (- end1 start1) vm:byte-bits)))
-
-#+lucid
-;;;The compiler is *supposed* to optimize calls to replace, but in actual
-;;;fact it does not.
-(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
-  (declare (type buffer-bytes buf1 buf2)
-	   (type array-index start1 end1 start2))
-  #.(declare-buffun)
-  (let ((end2 (lucid::%simple-8bit-vector-length buf2)))
-    (declare (type array-index end2))
-    (lucid::simple-8bit-vector-replace-internal
-      buf1 buf2 start1 end1 start2 end2)))
-
-#+(and clx-overlapping-arrays (not (or lispm excl)))
-(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
-  (declare (type vector buf1 buf2)
-	   (type array-index start1 end1 start2))
-  (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
-
-#-(or lispm lucid excl CMU clx-overlapping-arrays)
-(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
-  (declare (type buffer-bytes buf1 buf2)
-	   (type array-index start1 end1 start2))
-  (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
-
-#+ti
-(defun with-location-bindings (sys:&quote bindings &rest body)
-  (do ((bindings bindings (cdr bindings)))
-      ((null bindings)
-       (sys:eval-body-as-progn body))
-    (sys:bind (sys:*eval `(sys:locf ,(caar bindings)))
-	      (sys:*eval (cadar bindings)))))
-
-#+ti
-(compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form)
-  (let ((bindings (cadr form))
-	(body (cddr form)))
-    `(let ()
-       ,@(loop for (accessor value) in bindings
-	       collect `(si:bind (si:locf ,accessor) ,value))
-       ,@body)))
-
-#+ti
-(defun (:property with-location-bindings compiler::cw-handler) (exp)
-  (let* ((bindlist (mapcar #'compiler::cw-clause (second exp)))
-	 (body (compiler::cw-clause (cddr exp))))
-    (and compiler::cw-return-expansion-flag
-	 (list* (first exp) bindlist body))))
-
-#+(and lispm (not ti))
-(defmacro with-location-bindings (bindings &body body)
-  `(sys:letf* ,bindings ,@body))
-
-#+lispm
-(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
-				  &body body)
-  ;; don't use svref on LHS because Symbolics didn't define locf for it
-  (let* ((local-state (gensym))
-	 (bindings `(((aref ,local-state ,ts-index) 0))))	; will become zero anyway
-    (dolist (index indexes)
-      (push `((aref ,local-state ,index) (svref ,saved-state ,index))
-	    bindings))
-    `(let ((,local-state (gcontext-local-state ,gc)))
-       (declare (type gcontext-state ,local-state))
-       (unwind-protect
-	   (with-location-bindings ,bindings
-	     ,@body)
-	 (setf (svref ,local-state ,ts-index) 0)
-	 (when ,temp-gc
-	   (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
-	 (deallocate-gcontext-state ,saved-state)))))
-
-#-lispm
-(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
-				  &body body)
-  (let ((local-state (gensym))
-	(resets nil))
-    (dolist (index indexes)
-      (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index))
-	    resets))
-    `(unwind-protect
-	 (progn
-	   ,@body)
-       (let ((,local-state (gcontext-local-state ,gc)))
-	 (declare (type gcontext-state ,local-state))
-	 ,@resets
-	 (setf (svref ,local-state ,ts-index) 0))
-       (when ,temp-gc
-	 (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
-       (deallocate-gcontext-state ,saved-state))))
-
-;;;----------------------------------------------------------------------------
-;;; How error detection should CLX do?
-;;; Several levels are possible:
-;;;
-;;; 1. Do the equivalent of check-type on every argument.
-;;; 
-;;; 2. Simply report TYPE-ERROR.  This eliminates overhead of all the format
-;;;    strings generated by check-type.
-;;; 
-;;; 3. Do error checking only on arguments that are likely to have errors
-;;;    (like keyword names)
-;;; 
-;;; 4. Do error checking only where not doing so may dammage the envirnment
-;;;    on a non-tagged machine (i.e. when storing into a structure that has
-;;;    been passed in)
-;;; 
-;;; 5. No extra error detection code.  On lispm's, ASET may barf trying to
-;;;    store a non-integer into a number array. 
-;;; 
-;;; How extensive should the error checking be?  For example, if the server
-;;; expects a CARD16, is is sufficient for CLX to check for integer, or
-;;; should it also check for non-negative and less than 65536?
-;;;----------------------------------------------------------------------------
- 
-;; The *TYPE-CHECK?* constant controls how much error checking is done.
-;; Possible values are:
-;;    NIL      - Don't do any error checking
-;;    t        - Do the equivalent of checktype on every argument
-;;    :minimal - Do error checking only where errors are likely
-
-;;; This controls macro expansion, and isn't changable at run-time You will
-;;; probably want to set this to nil if you want good performance at
-;;; production time.
-(defconstant *type-check?* #+(or Genera Minima CMU) nil #-(or Genera Minima CMU) t)
-
-;; TYPE? is used to allow the code to do error checking at a different level from
-;; the declarations.  It also does some optimizations for systems that don't have
-;; good compiler support for TYPEP.  The definitions for CARD32, CARD16, INT16, etc.
-;; include range checks.  You can modify TYPE? to do less extensive checking
-;; for these types if you desire.
-
-;;
-;; ### This comment is a lie!  TYPE? is really also used for run-time type
-;; dispatching, not just type checking.  -- Ram.
-
-(defmacro type? (object type)
-  #+cmu
-  `(typep ,object ,type)
-  #-cmu
-  (if (not (constantp type))
-      `(typep ,object ,type)
-    (progn
-      (setq type (eval type))
-      #+(or Genera explorer Minima)
-      (if *type-check?*
-	  `(locally (declare (optimize safety)) (typep ,object ',type))
-	`(typep ,object ',type))
-      #-(or Genera explorer Minima)
-      (let ((predicate (assoc type
-			      '((drawable drawable-p) (window window-p)
-				(pixmap pixmap-p) (cursor cursor-p)
-				(font font-p) (gcontext gcontext-p)
-				(colormap colormap-p) (null null)
-				(integer integerp)))))
-	(cond (predicate
-	       `(,(second predicate) ,object))
-	      ((eq type 'boolean)
-	       't)			; Everything is a boolean.
-	      (*type-check?*
-	       `(locally (declare (optimize safety)) (typep ,object ',type)))
-	      (t
-	       `(typep ,object ',type)))))))
-
-;; X-TYPE-ERROR is the function called for type errors.
-;; If you want lots of checking, but are concerned about code size,
-;; this can be made into a macro that ignores some parameters.
-
-(defun x-type-error (object type &optional error-string)
-  (x-error 'x-type-error
-	   :datum object
-	   :expected-type type
-	   :type-string error-string))
-
-
-;;-----------------------------------------------------------------------------
-;; Error handlers
-;;    Hack up KMP error signaling using zetalisp until the real thing comes 
-;;    along
-;;-----------------------------------------------------------------------------
-
-(defun default-error-handler (display error-key &rest key-vals
-			      &key asynchronous &allow-other-keys)
-  (declare (type boolean asynchronous)
-	   (dynamic-extent key-vals))
-  ;; The default display-error-handler.
-  ;; It signals the conditions listed in the DISPLAY file.
-  (if asynchronous
-      (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals)
-      (apply #'x-error error-key :display display :error-key error-key key-vals)))
-
-#+(and lispm (not Genera) (not clx-ansi-common-lisp))
-(defun x-error (condition &rest keyargs)
-  (apply #'sys:signal condition keyargs))
-
-#+(and lispm (not Genera) (not clx-ansi-common-lisp))
-(defun x-cerror (proceed-format-string condition &rest keyargs)
-  (sys:signal (apply #'zl:make-condition condition keyargs)
-	      :proceed-types proceed-format-string))
-
-#+(and Genera (not clx-ansi-common-lisp))
-(defun x-error (condition &rest keyargs)
-  (declare (dbg:error-reporter))
-  (apply #'sys:signal condition keyargs))
-
-#+(and Genera (not clx-ansi-common-lisp))
-(defun x-cerror (proceed-format-string condition &rest keyargs)
-  (declare (dbg:error-reporter))
-  (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs))
-
-#+(or clx-ansi-common-lisp excl lcl3.0)
-(defun x-error (condition &rest keyargs)
-  (declare (dynamic-extent keyargs))
-  (apply #'error condition keyargs))
-
-#+(or clx-ansi-common-lisp excl lcl3.0 CMU)
-(defun x-cerror (proceed-format-string condition &rest keyargs)
-  (declare (dynamic-extent keyargs))
-  (apply #'cerror proceed-format-string condition keyargs))
-
-;;; X-ERROR for CMU Common Lisp
-;;;
-;;; We detect a couple condition types for which we disable event handling in
-;;; our system.  This prevents going into the debugger or returning to a
-;;; command prompt with CLX repeatedly seeing the same condition.  This occurs
-;;; because CMU Common Lisp provides for all events (that is, X, input on file
-;;; descriptors, Mach messages, etc.) to come through one routine anyone can
-;;; use to wait for input.
-;;;
-#+CMU
-(defun x-error (condition &rest keyargs)
-  (let ((condx (apply #'make-condition condition keyargs)))
-    (typecase condx
-      ;; This condition no longer exists.
-      #||
-      (server-disconnect
-	(let ((disp (server-disconnect-display condx)))
-	  (warn "Disabled event handling on ~S." disp)
-	  (ext::disable-clx-event-handling disp)))
-      ||#
-      (closed-display
-	(let ((disp (closed-display-display condx)))
-	  (warn "Disabled event handling on ~S." disp)
-	  (ext::disable-clx-event-handling disp))))
-    (error condx)))
-
-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
-(defun x-error (condition &rest keyargs)
-  (error "X-Error: ~a"
-	 (princ-to-string (apply #'make-condition condition keyargs))))
-
-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
-(defun x-cerror (proceed-format-string condition &rest keyargs)
-  (cerror proceed-format-string "X-Error: ~a"
-	 (princ-to-string (apply #'make-condition condition keyargs))))
-
-;; version 15 of Pitman error handling defines the syntax for define-condition to be:
-;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*]
-;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string)
-;; or (:report exp)
-
-#+lcl3.0 
-(defmacro define-condition (name parent-types &optional slots &rest args)
-  `(lcl:define-condition
-     ,name (,(first parent-types))
-     ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
-	      slots)
-     ,@args))
-
-#+(and excl (not clx-ansi-common-lisp))
-(defmacro define-condition (name parent-types &optional slots &rest args)
-  `(excl::define-condition
-     ,name (,(first parent-types))
-     ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
-	      slots)
-     ,@args))
-
-#+(and CMU (not clx-ansi-common-lisp))
-(defmacro define-condition (name parent-types &optional slots &rest args)
-  `(lisp:define-condition
-     ,name (,(first parent-types))
-     ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
-	      slots)
-     ,@args))
-
-#+(and lispm (not clx-ansi-common-lisp))
-(defmacro define-condition (name parent-types &body options)
-  (let ((slot-names
-	  (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
-		  (pop options)))
-	(documentation nil)
-	(conc-name (concatenate 'string (string name) "-"))	       
-	(reporter nil))
-    (dolist (item options)
-      (ecase (first item)
-	(:documentation (setq documentation (second item)))
-	(:conc-name (setq conc-name (string (second item))))
-	(:report (setq reporter (second item)))))
-    `(within-definition (,name define-condition)
-       (zl:defflavor ,name ,slot-names ,parent-types
-	 :initable-instance-variables
-	 #-Genera
-	 (:accessor-prefix ,conc-name)
-	 #+Genera
-	 (:conc-name ,conc-name)
-	 #-Genera
-	 (:outside-accessible-instance-variables ,@slot-names)
-	 #+Genera
-	 (:readable-instance-variables ,@slot-names))
-       ,(when reporter ;; when no reporter, parent's is inherited
-	  `(zl:defmethod #-Genera (,name :report)
-	                 #+Genera (dbg:report ,name) (stream)
-	      ,(if (stringp reporter)
-		   `(write-string ,reporter stream)
-		 `(,reporter global:self stream))
-	      global:self))
-       (zl:compile-flavor-methods ,name)
-       ,(when documentation
-	  `(setf (documentation name 'type) ,documentation))
-       ',name)))
-
-#+(and lispm (not Genera) (not clx-ansi-common-lisp))
-(zl:defflavor x-error () (global:error))
-
-#+(and Genera (not clx-ansi-common-lisp))
-(scl:defflavor x-error
-	((dbg:proceed-types '(:continue))	;
-	 continue-format-string)
-	(sys:error)
-  (:initable-instance-variables continue-format-string))
-
-#+(and Genera (not clx-ansi-common-lisp))
-(scl:defmethod (scl:make-instance x-error) (&rest ignore)
-  (when (not (sys:variable-boundp continue-format-string))
-    (setf dbg:proceed-types (remove :continue dbg:proceed-types))))
-
-#+(and Genera (not clx-ansi-common-lisp))
-(scl:defmethod (dbg:proceed x-error :continue) ()
-  :continue)
-
-#+(and Genera (not clx-ansi-common-lisp))
-(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)
-  (format stream continue-format-string))
-
-#+(or clx-ansi-common-lisp excl lcl3.0 CMU)
-(define-condition x-error (error) ())
-
-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
-(defstruct x-error
-  report-function)
-
-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
-(defmacro define-condition (name parent-types &body options)
-  ;; Define a structure that when printed displays an error message
-  (flet ((reporter-for-condition (name)
-	   (xintern "." name '-reporter.)))
-    (let ((slot-names
-	    (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
-		    (pop options)))
-	  (documentation nil)
-	  (conc-name (concatenate 'string (string name) "-"))	       
-	  (reporter nil)
-	  (condition (gensym))
-	  (stream (gensym))
-	  (report-function (reporter-for-condition name)))
-      (dolist (item options)
-	(ecase (first item)
-	  (:documentation (setq documentation (second item)))
-	  (:conc-name (setq conc-name (string (second item))))
-	  (:report (setq reporter (second item)))))
-      (unless reporter
-	(setq report-function (reporter-for-condition (first parent-types))))
-      `(within-definition (,name define-condition)
-	 (defstruct (,name (:conc-name ,(intern conc-name))
-		     (:print-function condition-print)
-		     (:include ,(first parent-types)
-		      (report-function ',report-function)))
-	   ,@slot-names)
-	 ,(when documentation
-	    `(setf (documentation name 'type) ,documentation))
-	 ,(when reporter
-	    `(defun ,report-function (,condition ,stream)
-	       ,(if (stringp reporter)
-		    `(write-string ,reporter ,stream)
-		  `(,reporter ,condition ,stream))
-	       ,condition))
-	 ',name))))
-
-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
-(defun condition-print (condition stream depth)
-  (declare (type x-error condition)
-	   (type stream stream)
-	   (ignore depth))
-  (if *print-escape*
-      (print-unreadable-object (condition stream :type t))
-    (funcall (x-error-report-function condition) condition stream))
-  condition)
-  
-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
-(defun make-condition (type &rest slot-initializations)
-  (declare (dynamic-extent slot-initializations))
-  (let ((make-function (intern (concatenate 'string (string 'make-) (string type))
-			       (symbol-package type))))
-    (apply make-function slot-initializations)))
-
-#-(or clx-ansi-common-lisp excl lcl3.0 CMU)
-(define-condition type-error (x-error)
-  ((datum :reader type-error-datum :initarg :datum)
-   (expected-type :reader type-error-expected-type :initarg :expected-type))
-  (:report
-    (lambda (condition stream)
-      (format stream "~s isn't a ~a"
-	      (type-error-datum condition)
-	      (type-error-expected-type condition)))))
-
-
-;;-----------------------------------------------------------------------------
-;;  HOST hacking
-;;-----------------------------------------------------------------------------
-
-#-(or explorer Genera Minima Allegro CMU)
-(defun host-address (host &optional (family :internet))
-  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
-  ;; and cdr is a list of network address bytes.
-  (declare (type stringable host)
-	   (type (or null (member :internet :decnet :chaos) card8) family))
-  (declare (clx-values list))
-  host family
-  (error "HOST-ADDRESS not implemented yet."))
-
-#+explorer
-(defun host-address (host &optional (family :internet))
-  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
-  ;; and cdr is a list of network address bytes.
-  (declare (type stringable host)
-	   (type (or null (member :internet :decnet :chaos) card8) family))
-  (declare (clx-values list))
-  (ecase family
-    ((:internet nil 0)
-     (let ((addr (ip:get-ip-address host)))
-       (unless addr (error "~s isn't an internet host name" host))
-       (list :internet
-	     (ldb (byte 8 24) addr)
-	     (ldb (byte 8 16) addr)
-	     (ldb (byte 8 8) addr)
-	     (ldb (byte 8 0) addr))))
-    ((:chaos 2)
-     (let ((addr (first (chaos:chaos-addresses host))))
-       (unless addr (error "~s isn't a chaos host name" host))
-       (list :chaos
-	     (ldb (byte 8 0) addr)
-	     (ldb (byte 8 8) addr))))))
-
-#+Genera
-(defun host-address (host &optional (family :internet))
-  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
-  ;; and cdr is a list of network address bytes.
-  (declare (type stringable host)
-	   (type (or null (member :internet :decnet :chaos) card8) family))
-  (declare (clx-values list))
-  (setf host (string host))
-  (let ((net-type (ecase family
-		    ((:internet nil 0) :internet)
-		    ((:DECnet 1) :dna)
-		    ((:chaos 2) :chaos))))
-    (dolist (addr
-	      (sys:send (net:parse-host host) :network-addresses)
-	      (error "~S isn't a valid ~(~A~) host name" host family))
-      (let ((network (car addr))
-	    (address (cadr addr)))
-	(when (sys:send network :network-typep net-type)
-	  (return (ecase family
-		    ((:internet nil 0)
-		     (multiple-value-bind (a b c d) (tcp:explode-internet-address address)
-		       (list :internet a b c d)))
-		    ((:DECnet 1)
-		     (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address)))
-		    ((:chaos 2)
-		     (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address))))))))))
-
-#+Minima
-(defun host-address (host &optional (family :internet))
-  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
-  ;; and cdr is a list of network address bytes.
-  (declare (type stringable host)
-	   (type (or null (member :internet :decnet :chaos) card8) family))
-  (declare (clx-values list))
-  (etypecase family
-    ((:internet nil 0)
-      (list* :internet
-	     (multiple-value-list
-	       (minima:ip-address-components (minima:parse-ip-address (string host))))))))
-
-#+Allegro
-(defun host-address (host &optional (family :internet))
-  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
-  ;; and cdr is a list of network address bytes.
-  (declare (type stringable host)
-	   (type (or null (member :internet :decnet :chaos) card8) family))
-  (declare (clx-values list))
-  (labels ((no-host-error ()
-	     (error "Unknown host ~S" host))
-	   (no-address-error ()
-	     (error "Host ~S has no ~S address" host family)))
-    (let ((hostent 0))
-      (unwind-protect
-	   (progn
-	     (setf hostent (ipc::gethostbyname (string host)))
-	     (when (zerop hostent)
-	       (no-host-error))
-	     (ecase family
-	       ((:internet nil 0)
-		(unless (= (ipc::hostent-addrtype hostent) 2)
-		  (no-address-error))
-		(assert (= (ipc::hostent-length hostent) 4))
-		(let ((addr (ipc::hostent-addr hostent)))
-		   (when (or (member comp::.target.
-				     '(:hp :sgi4d :sony :dec3100)
-				     :test #'eq)
-			     (probe-file "/lib/ld.so"))
-		     ;; BSD 4.3 based systems require an extra indirection
-		     (setq addr (si:memref-int addr 0 0 :unsigned-long)))
-		  (list :internet
-			(si:memref-int addr 0 0 :unsigned-byte)
-			(si:memref-int addr 1 0 :unsigned-byte)
-			(si:memref-int addr 2 0 :unsigned-byte)
-			(si:memref-int addr 3 0 :unsigned-byte))))))
-	(ff:free-cstruct hostent)))))
-
-#+CMU
-(defun host-address (host &optional (family :internet))
-  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
-  ;; and cdr is a list of network address bytes.
-  (declare (type stringable host)
-	   (type (or null (member :internet :decnet :chaos) card8) family))
-  (declare (clx-values list))
-  (labels ((no-host-error ()
-	     (error "Unknown host ~S" host))
-	   (no-address-error ()
-	     (error "Host ~S has no ~S address" host family)))
-    (let ((hostent (ext:lookup-host-entry (string host))))
-      (when (not hostent)
-	(no-host-error))
-      (ecase family
-	((:internet nil 0)
-	 (unless (= (ext::host-entry-addr-type hostent) 2)
-	   (no-address-error))
-	 (let ((addr (first (ext::host-entry-addr-list hostent))))
-	   (list :internet
-		 (ldb (byte 8 24) addr)
-		 (ldb (byte 8 16) addr)
-		 (ldb (byte 8  8) addr)
-		 (ldb (byte 8  0) addr))))))))
-
-;;;
-
-#+explorer ;; This isn't required, but it helps make sense of the results from access-hosts
-(defun get-host (host-object)
-  ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
-  ;; and cdr is a list of network address bytes.
-  (declare (type list host-object))
-  (declare (clx-values string family))
-  (let* ((family (first host-object))
-	 (address (ecase family
-		    (:internet
-		     (dpb (second host-object)
-			  (byte 8 24)
-			  (dpb (third host-object)
-			       (byte 8 16)
-			       (dpb (fourth host-object)
-				    (byte 8 8)
-				    (fifth host-object)))))
-		    (:chaos
-		     (dpb (third host-object) (byte 8 8) (second host-object))))))
-    (when (eq family :internet) (setq family :ip))
-    (let ((host (si:get-host-from-address address family)))
-      (values (and host (funcall host :name)) family))))
-
-;;; This isn't required, but it helps make sense of the results from access-hosts
-#+Genera
-(defun get-host (host-object)
-  ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
-  ;; and cdr is a list of network address bytes.
-  (declare (type list host-object))
-  (declare (clx-values string family))
-  (let ((family (first host-object)))
-    (values (sys:send (net:get-host-from-address 
-			(ecase family
-			  (:internet
-			    (apply #'tcp:build-internet-address (rest host-object)))
-			  ((:chaos :DECnet)
-			   (dpb (third host-object) (byte 8 8) (second host-object))))
-			(net:local-network-of-type (if (eq family :DECnet)
-						       :DNA
-						       family)))
-		      :name)
-	    family)))
-
-;;; This isn't required, but it helps make sense of the results from access-hosts
-#+Minima
-(defun get-host (host-object)
-  ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
-  ;; and cdr is a list of network address bytes.
-  (declare (type list host-object))
-  (declare (clx-values string family))
-  (let ((family (first host-object)))
-    (values (ecase family
-	      (:internet
-		(minima:ip-address-string
-		  (apply #'minima:make-ip-address (rest host-object)))))
-	    family)))
-
-
-;;-----------------------------------------------------------------------------
-;; Whether to use closures for requests or not.
-;;-----------------------------------------------------------------------------
-
-;;; If this macro expands to non-NIL, then request and locking code is
-;;; compiled in a much more compact format, as the common code is shared, and
-;;; the specific code is built into a closure that is funcalled by the shared
-;;; code.  If your compiler makes efficient use of closures then you probably
-;;; want to make this expand to T, as it makes the code more compact.
-
-(defmacro use-closures ()
-  #+(or lispm Minima) t
-  #-(or lispm Minima) nil)
-
-#+(or Genera Minima)
-(defun clx-macroexpand (form env)
-  (declare (ignore env))
-  form)
-
-#-(or Genera Minima)
-(defun clx-macroexpand (form env)
-  (macroexpand form env))
-
-
-;;-----------------------------------------------------------------------------
-;; Resource stuff
-;;-----------------------------------------------------------------------------
-
-
-;;; Utilities 
-
-(defun getenv (name)
-  #+excl (sys:getenv name)
-  #+lcl3.0 (lcl:environment-value name)
-  #+CMU (cdr (assoc name ext:*environment-list* :test #'string=))
-  #-(or excl lcl3.0 CMU) (progn name nil))
-
-(defun homedir-file-pathname (name)
-  (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
-       (merge-pathnames (user-homedir-pathname) (pathname name))))
-
-;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if
-;;; a resource manager isn't running.
-
-(defun default-resources-pathname ()
-  (homedir-file-pathname ".Xdefaults"))
-
-;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the
-;;; defaults have been loaded.
-
-(defun resources-pathname ()
-  (or (let ((string (getenv "XENVIRONMENT")))
-	(and string
-	     (pathname string)))
-      (homedir-file-pathname (concatenate 'string ".Xdefaults-"
-					  #+excl (short-site-name)
-					  #-excl (machine-instance)))))
-
-;;; AUTHORITY-PATHNAME - The pathname of the authority file.
-
-(defun authority-pathname ()
-  (or (let ((xauthority (getenv "XAUTHORITY")))
-	(and xauthority
-	     (pathname xauthority)))
-      (homedir-file-pathname ".Xauthority")))
-
-
-;;-----------------------------------------------------------------------------
-;; GC stuff
-;;-----------------------------------------------------------------------------
-
-(defun gc-cleanup ()
-  (declare (special *event-free-list*
-		    *pending-command-free-list*
-		    *reply-buffer-free-lists*
-		    *gcontext-local-state-cache*
-		    *temp-gcontext-cache*))
-  (setq *event-free-list* nil)
-  (setq *pending-command-free-list* nil)
-  (when (boundp '*reply-buffer-free-lists*)
-    (fill *reply-buffer-free-lists* nil))
-  (setq *gcontext-local-state-cache* nil)
-  (setq *temp-gcontext-cache* nil)
-  nil)
-
-#+Genera
-(si:define-gc-cleanup clx-cleanup ("CLX Cleanup")
-  (gc-cleanup))
-
-
-;;-----------------------------------------------------------------------------
-;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND)
-;;-----------------------------------------------------------------------------
-
-#-(or clx-ansi-common-lisp Genera)
-(defun with-standard-io-syntax-function (function)
-  (declare #+lispm
-	   (sys:downward-funarg function))
-  (let ((*package* (find-package :user))
-	(*print-array* t)
-	(*print-base* 10)
-	(*print-case* :upcase)
-	(*print-circle* nil)
-	(*print-escape* t)
-	(*print-gensym* t)
-	(*print-length* nil)
-	(*print-level* nil)
-	(*print-pretty* nil)
-	(*print-radix* nil)
-	(*read-base* 10)
-	(*read-default-float-format* 'single-float)
-	(*read-suppress* nil)
-	#+ticl (ticl:*print-structure* t)
-	#+lucid (lucid::*print-structure* t))
-    (funcall function)))
-
-#-(or clx-ansi-common-lisp Genera)
-(defmacro with-standard-io-syntax (&body body)
-  `(flet ((.with-standard-io-syntax-body. () ,@body))
-     (with-standard-io-syntax-function #'.with-standard-io-syntax-body.)))
-
-
-;;-----------------------------------------------------------------------------
-;; DEFAULT-KEYSYM-TRANSLATE
-;;-----------------------------------------------------------------------------
-
-;;; If object is a character, char-bits are set from state.
-;;;
-;;; [the following isn't implemented (should it be?)]
-;;; If object is a list, it is an alist with entries:
-;;; (base-char [modifiers] [mask-modifiers])
-;;; When MODIFIERS are specified, this character translation
-;;; will only take effect when the specified modifiers are pressed.
-;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
-;;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
-;;; In ambiguous cases, the most specific translation is used.
-
-#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU)
-(defun default-keysym-translate (display state object)
-  (declare (type display display)
-	   (type card16 state)
-	   (type t object)
-	   (clx-values t)
-	   (special left-meta-keysym right-meta-keysym
-		    left-super-keysym right-super-keysym
-		    left-hyper-keysym right-hyper-keysym))
-  (when (characterp object)
-    (when (logbitp (position :control *state-mask-vector*) state)
-      (setf (char-bit object :control) 1))
-    (when (or (state-keysymp display state left-meta-keysym)
-	      (state-keysymp display state right-meta-keysym))
-      (setf (char-bit object :meta) 1))
-    (when (or (state-keysymp display state left-super-keysym)
-	      (state-keysymp display state right-super-keysym))
-      (setf (char-bit object :super) 1))
-    (when (or (state-keysymp display state left-hyper-keysym)
-	      (state-keysymp display state right-hyper-keysym))
-      (setf (char-bit object :hyper) 1)))
-  object)
-
-#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU)
-(defun default-keysym-translate (display state object)
-  (declare (type display display)
-	   (type card16 state)
-	   (type t object)
-	   (ignore display state)
-	   (clx-values t))
-  object)
-
-
-;;-----------------------------------------------------------------------------
-;; Image stuff
-;;-----------------------------------------------------------------------------
-
-;;; Types
-
-(deftype pixarray-1-element-type ()
-  'bit)
-
-(deftype pixarray-4-element-type ()
-  '(unsigned-byte 4))
-
-(deftype pixarray-8-element-type ()
-  '(unsigned-byte 8))
-
-(deftype pixarray-16-element-type ()
-  '(unsigned-byte 16))
-
-(deftype pixarray-24-element-type ()
-  '(unsigned-byte 24))
-
-(deftype pixarray-32-element-type ()
-  #-(or Genera Minima) '(unsigned-byte 32)
-  #+(or Genera Minima) 'fixnum)
-
-(deftype pixarray-1  ()
-  '(array pixarray-1-element-type (* *)))
-
-(deftype pixarray-4  ()
-  '(array pixarray-4-element-type (* *)))
-
-(deftype pixarray-8  ()
-  '(array pixarray-8-element-type (* *)))
-
-(deftype pixarray-16 ()
-  '(array pixarray-16-element-type (* *)))
-
-(deftype pixarray-24 ()
-  '(array pixarray-24-element-type (* *)))
-
-(deftype pixarray-32 ()
-  '(array pixarray-32-element-type (* *)))
-
-(deftype pixarray ()
-  '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32))
-
-(deftype bitmap ()
-  'pixarray-1)
-
-;;; WITH-UNDERLYING-SIMPLE-VECTOR 
-
-#+Genera
-(defmacro with-underlying-simple-vector
-	  ((variable element-type pixarray) &body body)
-  (let ((bits-per-element
-	  (sys:array-bits-per-element
-	    (symbol-value (sys:type-array-element-type element-type)))))
-    `(scl:stack-let ((,variable
-		      (make-array
-			(index-ceiling
-			  (index* (array-total-size ,pixarray)
-				  (sys:array-element-size ,pixarray))
-			  ,bits-per-element)
-			:element-type ',element-type
-			:displaced-to ,pixarray)))
-       (declare (type (vector ,element-type) ,variable))
-       ,@body)))
-
-#+lcl3.0
-(defmacro with-underlying-simple-vector
-	  ((variable element-type pixarray) &body body)
-  `(let ((,variable (sys:underlying-simple-vector ,pixarray)))
-     (declare (type (simple-array ,element-type (*)) ,variable))
-     ,@body))
-
-#+excl
-(defmacro with-underlying-simple-vector
-	  ((variable element-type pixarray) &body body)
-  `(let ((,variable (cdr (excl::ah_data ,pixarray))))
-     (declare (type (simple-array ,element-type (*)) ,variable))
-     ,@body))
-
-;;; These are used to read and write pixels from and to CARD8s.
-
-;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s.
-
-(defmacro read-image-load-byte (size position integer)
-  (unless *image-bit-lsb-first-p* (setq position (- 7 position)))
-  `(the (unsigned-byte ,size)
-	(#-Genera ldb #+Genera sys:%logldb
-	 (byte ,size ,position)
-	 (the card8 ,integer))))
-
-;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from
-;;; the appropriate number of CARD8s.
-
-(defmacro read-image-assemble-bytes (&rest bytes)
-  (unless *image-byte-lsb-first-p* (setq bytes (reverse bytes)))
-  (let ((it (first bytes))
-	(count 0))
-    (dolist (byte (rest bytes))
-      (setq it
-	    `(#-Genera dpb #+Genera sys:%logdpb 
-	      (the card8 ,byte)
-	      (byte 8 ,(incf count 8))
-	      (the (unsigned-byte ,count) ,it))))
-    #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it)
-    #+Genera it))
-
-;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit
-;;; pixel.
-
-(defmacro write-image-load-byte (position integer integer-size)
-  integer-size
-  (unless *image-byte-lsb-first-p* (setq position (- integer-size 8 position)))
-  `(the card8
-	(#-Genera ldb #+Genera sys:%logldb
-	 (byte 8 ,position)
-	 #-Genera (the (unsigned-byte ,integer-size) ,integer)
-	 #+Genera ,integer
-	 )))
-
-;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit
-;;; pixels.
-
-(defmacro write-image-assemble-bytes (&rest bytes)
-  (unless *image-bit-lsb-first-p* (setq bytes (reverse bytes)))
-  (let ((size (floor 8 (length bytes)))
-	(it (first bytes))
-	(count 0))
-    (dolist (byte (rest bytes))
-      (setq it `(#-Genera dpb #+Genera sys:%logdpb
-		 (the (unsigned-byte ,size) ,byte)
-		 (byte ,size ,(incf count size))
-		 (the (unsigned-byte ,count) ,it))))
-    `(the card8 ,it)))
-
-#+(or Genera lcl3.0 excl)
-(defvar *computed-image-byte-lsb-first-p* *image-byte-lsb-first-p*)
-
-#+(or Genera lcl3.0 excl)
-(defvar *computed-image-bit-lsb-first-p* *image-bit-lsb-first-p*)
-
-;;; The following table gives the bit ordering within bytes (when accessed
-;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to
-;;; 31, where bit 0 should be leftmost on the display.  For a given byte
-;;; labelled A-B, A is for the most significant bit of the byte, and B is
-;;; for the least significant bit.
-;;; 
-;;; legend:
-;;; 	1   scanline-unit = 8
-;;; 	2   scanline-unit = 16
-;;; 	4   scanline-unit = 32
-;;; 	M   byte-order = MostSignificant
-;;; 	L   byte-order = LeastSignificant
-;;; 	m   bit-order = MostSignificant
-;;; 	l   bit-order = LeastSignificant
-;;; 
-;;; 
-;;; format	ordering
-;;; 
-;;; 1Mm	00-07 08-15 16-23 24-31
-;;; 2Mm	00-07 08-15 16-23 24-31
-;;; 4Mm	00-07 08-15 16-23 24-31
-;;; 1Ml	07-00 15-08 23-16 31-24
-;;; 2Ml	15-08 07-00 31-24 23-16
-;;; 4Ml	31-24 23-16 15-08 07-00
-;;; 1Lm	00-07 08-15 16-23 24-31
-;;; 2Lm	08-15 00-07 24-31 16-23
-;;; 4Lm	24-31 16-23 08-15 00-07
-;;; 1Ll	07-00 15-08 23-16 31-24
-;;; 2Ll	07-00 15-08 23-16 31-24
-;;; 4Ll	07-00 15-08 23-16 31-24
-
-#+(or Genera lcl3.0 excl) 
-(defconstant
-  *image-bit-ordering-table*
-  '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil))
-    ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil))
-    ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil))
-    ((1 (07 00) (15 08) (23 16) (31 24)) (nil t))
-    ((2 (15 08) (07 00) (31 24) (23 16)) (nil t))
-    ((4 (31 24) (23 16) (15 08) (07 00)) (nil t))
-    ((1 (00 07) (08 15) (16 23) (24 31)) (t   nil))
-    ((2 (08 15) (00 07) (24 31) (16 23)) (t   nil))
-    ((4 (24 31) (16 23) (08 15) (00 07)) (t   nil))
-    ((1 (07 00) (15 08) (23 16) (31 24)) (t   t))
-    ((2 (07 00) (15 08) (23 16) (31 24)) (t   t))
-    ((4 (07 00) (15 08) (23 16) (31 24)) (t   t))))
-  
-#+(or Genera lcl3.0 excl) 
-(defun compute-image-byte-and-bit-ordering ()
-  (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p))
-  ;; First compute the ordering 
-  (let ((ordering nil)
-	(a (make-array '(1 32) :element-type 'bit :initial-element 0)))
-    (dotimes (i 4)
-      (push (flet ((bitpos (a i n)
-		     (declare (optimize (speed 3) (safety 0) (space 0)))
-		     (declare (type (simple-array bit (* *)) a)
-			      (type fixnum i n))
-		     (with-underlying-simple-vector (v (unsigned-byte 8) a)
-		       (prog2
-			 (setf (aref v i) n)
-			 (dotimes (i 32)
-			   (unless (zerop (aref a 0 i))
-			     (return i)))
-			 (setf (aref v i) 0)))))
-	      (list (bitpos a i #b10000000)
-		    (bitpos a i #b00000001)))
-	    ordering))
-    (setq ordering (cons (floor *image-unit* 8) (nreverse ordering)))
-    ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p
-    (let ((byte-and-bit-ordering
-	    (second (assoc ordering *image-bit-ordering-table*
-			   :test #'equal))))
-      (unless byte-and-bit-ordering
-	(error "Couldn't determine image byte and bit ordering~@
-                measured image ordering = ~A"
-	       ordering))
-      (values-list byte-and-bit-ordering))))
-
-#+(or Genera lcl3.0 excl) 
-(multiple-value-setq
-  (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
-  (compute-image-byte-and-bit-ordering))
-
-;;; If you can write fast routines that can read and write pixarrays out of a
-;;; buffer-bytes, do it!  It makes the image code a lot faster.  The
-;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines
-;;; return T if they can do it, NIL if they can't.
-
-;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s
-
-#+(or lcl3.0 excl)
-(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height  
-			     padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-1 array)
-	   (type card16 x y width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (with-underlying-simple-vector (vector pixarray-1-element-type array)
-      (do* ((start (index+ index
-			   (index* y padded-bytes-per-line)
-			   (index-ceiling x 8))
-		   (index+ start padded-bytes-per-line))
-	    (y 0 (index1+ y))
-	    (left-bits (index-mod (index- x) 8))
-	    (right-bits (index-mod (index- width left-bits) 8))
-	    (middle-bits (index- width left-bits right-bits))
-	    (middle-bytes (index-floor middle-bits 8)))
-	   ((index>= y height))
-	(declare (type array-index start y
-		       left-bits right-bits middle-bits middle-bytes))
-	(cond ((index< middle-bits 0)
-	       (let ((byte (aref buffer-bbuf (index1- start)))
-		     (x (array-row-major-index array y left-bits)))
-		 (declare (type card8 byte)
-			  (type array-index x))
-		 (when (index> right-bits 6)
-		   (setf (aref vector (index- x 1))
-			 (read-image-load-byte 1 7 byte)))
-		 (when (and (index> left-bits 1)
-			    (index> right-bits 5))
-		   (setf (aref vector (index- x 2))
-			 (read-image-load-byte 1 6 byte)))
-		 (when (and (index> left-bits 2)
-			    (index> right-bits 4))
-		   (setf (aref vector (index- x 3))
-			 (read-image-load-byte 1 5 byte)))
-		 (when (and (index> left-bits 3)
-			    (index> right-bits 3))
-		   (setf (aref vector (index- x 4))
-			 (read-image-load-byte 1 4 byte)))
-		 (when (and (index> left-bits 4)
-			    (index> right-bits 2))
-		   (setf (aref vector (index- x 5))
-			 (read-image-load-byte 1 3 byte)))
-		 (when (and (index> left-bits 5)
-			    (index> right-bits 1))
-		   (setf (aref vector (index- x 6))
-			 (read-image-load-byte 1 2 byte)))
-		 (when (index> left-bits 6)
-		   (setf (aref vector (index- x 7))
-			 (read-image-load-byte 1 1 byte)))))
-	      (t
-	       (unless (index-zerop left-bits)
-		 (let ((byte (aref buffer-bbuf (index1- start)))
-		       (x (array-row-major-index array y left-bits)))
-		   (declare (type card8 byte)
-			    (type array-index x))
-		   (setf (aref vector (index- x 1))
-			 (read-image-load-byte 1 7 byte))
-		   (when (index> left-bits 1)
-		     (setf (aref vector (index- x 2))
-			   (read-image-load-byte 1 6 byte))
-		     (when (index> left-bits 2)
-		       (setf (aref vector (index- x 3))
-			     (read-image-load-byte 1 5 byte))
-		       (when (index> left-bits 3)
-			 (setf (aref vector (index- x 4))
-			       (read-image-load-byte 1 4 byte))
-			 (when (index> left-bits 4)
-			   (setf (aref vector (index- x 5))
-				 (read-image-load-byte 1 3 byte))
-			   (when (index> left-bits 5)
-			     (setf (aref vector (index- x 6))
-				   (read-image-load-byte 1 2 byte))
-			     (when (index> left-bits 6)
-			       (setf (aref vector (index- x 7))
-				     (read-image-load-byte 1 1 byte))
-			       ))))))))
-	       (do* ((end (index+ start middle-bytes))
-		     (i start (index1+ i))
-		     (x (array-row-major-index array y left-bits) (index+ x 8)))
-		    ((index>= i end)
-		     (unless (index-zerop right-bits)
-		       (let ((byte (aref buffer-bbuf end))
-			     (x (array-row-major-index
-				  array y (index+ left-bits middle-bits))))
-			 (declare (type card8 byte)
-				  (type array-index x))
-			 (setf (aref vector (index+ x 0))
-			       (read-image-load-byte 1 0 byte))
-			 (when (index> right-bits 1)
-			   (setf (aref vector (index+ x 1))
-				 (read-image-load-byte 1 1 byte))
-			   (when (index> right-bits 2)
-			     (setf (aref vector (index+ x 2))
-				   (read-image-load-byte 1 2 byte))
-			     (when (index> right-bits 3)
-			       (setf (aref vector (index+ x 3))
-				     (read-image-load-byte 1 3 byte))
-			       (when (index> right-bits 4)
-				 (setf (aref vector (index+ x 4))
-				       (read-image-load-byte 1 4 byte))
-				 (when (index> right-bits 5)
-				   (setf (aref vector (index+ x 5))
-					 (read-image-load-byte 1 5 byte))
-				   (when (index> right-bits 6)
-				     (setf (aref vector (index+ x 6))
-					   (read-image-load-byte 1 6 byte))
-				     )))))))))
-		 (declare (type array-index end i x))
-		 (let ((byte (aref buffer-bbuf i)))
-		   (declare (type card8 byte))
-		   (setf (aref vector (index+ x 0))
-			 (read-image-load-byte 1 0 byte))
-		   (setf (aref vector (index+ x 1))
-			 (read-image-load-byte 1 1 byte))
-		   (setf (aref vector (index+ x 2))
-			 (read-image-load-byte 1 2 byte))
-		   (setf (aref vector (index+ x 3))
-			 (read-image-load-byte 1 3 byte))
-		   (setf (aref vector (index+ x 4))
-			 (read-image-load-byte 1 4 byte))
-		   (setf (aref vector (index+ x 5))
-			 (read-image-load-byte 1 5 byte))
-		   (setf (aref vector (index+ x 6))
-			 (read-image-load-byte 1 6 byte))
-		   (setf (aref vector (index+ x 7))
-			 (read-image-load-byte 1 7 byte))))
-	       )))))
-  t)
-
-#+(or lcl3.0 excl)
-(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height 
-			     padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-4 array)
-	   (type card16 x y width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (with-underlying-simple-vector (vector pixarray-4-element-type array)
-      (do* ((start (index+ index
-			   (index* y padded-bytes-per-line)
-			   (index-ceiling x 2))
-		   (index+ start padded-bytes-per-line))
-	    (y 0 (index1+ y))
-	    (left-nibbles (index-mod (index- x) 2))
-	    (right-nibbles (index-mod (index- width left-nibbles) 2))
-	    (middle-nibbles (index- width left-nibbles right-nibbles))
-	    (middle-bytes (index-floor middle-nibbles 2)))
-	   ((index>= y height))
-	(declare (type array-index start y
-		       left-nibbles right-nibbles middle-nibbles middle-bytes))
-	(unless (index-zerop left-nibbles)
-	  (setf (aref array y 0)
-		(read-image-load-byte
-		  4 4 (aref buffer-bbuf (index1- start)))))
-	(do* ((end (index+ start middle-bytes))
-	      (i start (index1+ i))
-	      (x (array-row-major-index array y left-nibbles) (index+ x 2)))
-	     ((index>= i end)
-	      (unless (index-zerop right-nibbles)
-		(setf (aref array y (index+ left-nibbles middle-nibbles))
-		      (read-image-load-byte 4 0 (aref buffer-bbuf end)))))
-	  (declare (type array-index end i x))
-	  (let ((byte (aref buffer-bbuf i)))
-	    (declare (type card8 byte))
-	    (setf (aref vector (index+ x 0))
-		  (read-image-load-byte 4 0 byte))
-	    (setf (aref vector (index+ x 1))
-		  (read-image-load-byte 4 4 byte))))
-	)))
-  t)
-
-#+(or Genera lcl3.0 excl)
-(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height 
-			      padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-24 array)
-	   (type card16 width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (with-underlying-simple-vector (vector pixarray-24-element-type array)
-      (do* ((start (index+ index
-			   (index* y padded-bytes-per-line)
-			   (index* x 3))
-		   (index+ start padded-bytes-per-line))
-	    (y 0 (index1+ y)))
-	   ((index>= y height))
-	(declare (type array-index start y))
-	(do* ((end (index+ start (index* width 3)))
-	      (i start (index+ i 3))
-	      (x (array-row-major-index array y 0) (index1+ x)))
-	     ((index>= i end))
-	  (declare (type array-index end i x))
-	  (setf (aref vector x)
-		(read-image-assemble-bytes
-		  (aref buffer-bbuf (index+ i 0))
-		  (aref buffer-bbuf (index+ i 1))
-		  (aref buffer-bbuf (index+ i 2))))))))
-  t)
-
-#+lispm
-(defun fast-read-pixarray-using-bitblt
-       (bbuf boffset pixarray x y width height padded-bytes-per-line
-	bits-per-pixel)
-  (#+Genera sys:stack-let* #-Genera let*
-   ((dimensions (list (+ y height)
-		      (floor (* padded-bytes-per-line 8) bits-per-pixel)))
-    (a (make-array
-	 dimensions
-	 :element-type (array-element-type pixarray)
-	 :displaced-to bbuf
-	 :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))
-   (sys:bitblt boole-1 width height a x y pixarray 0 0))
-  t)
-
-#+(or Genera lcl3.0 excl)
-(defun fast-read-pixarray-with-swap
-       (bbuf boffset pixarray x y width height padded-bytes-per-line
-	bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
-  (declare (type buffer-bytes bbuf)
-	   (type array-index boffset
-		 padded-bytes-per-line)
-	   (type pixarray pixarray)
-	   (type card16 x y width height)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (type (member 8 16 32) unit)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p))
-  (unless (index= bits-per-pixel 24)
-    (let ((pixarray-padded-bits-per-line
-	    (if (index= height 1) 0
-	      (index* (index- (array-row-major-index pixarray 1 0)
-			      (array-row-major-index pixarray 0 0))
-		      bits-per-pixel)))
-	  (x-bits (index* x bits-per-pixel)))
-      (declare (type array-index pixarray-padded-bits-per-line x-bits))
-      (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
-		(and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
-		     (index-zerop (index-mod x-bits 8)))
-	      (and (index-zerop (index-mod pixarray-padded-bits-per-line *image-unit*))
-		   (index-zerop (index-mod x-bits *image-unit*))))
-	(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
-	    (image-swap-function
-	      bits-per-pixel 
-	      unit byte-lsb-first-p bit-lsb-first-p
-	      *image-unit* *computed-image-byte-lsb-first-p*
-	      *computed-image-bit-lsb-first-p*)
-	  (declare (type symbol image-swap-function)
-		   (type boolean image-swap-lsb-first-p))
-	  (with-underlying-simple-vector (dst card8 pixarray)
-	    (funcall
-	      (symbol-function image-swap-function) bbuf dst
-	      (index+ boffset
-		      (index* y padded-bytes-per-line)
-		      (index-floor x-bits 8))
-	      0 (index-ceiling (index* width bits-per-pixel) 8)
-	      padded-bytes-per-line
-	      (index-floor pixarray-padded-bits-per-line 8)
-	      height image-swap-lsb-first-p)))
-	t))))
-
-(defun fast-read-pixarray (bbuf boffset pixarray
-			   x y width height padded-bytes-per-line
-			   bits-per-pixel
-			   unit byte-lsb-first-p bit-lsb-first-p)
-  (declare (type buffer-bytes bbuf)
-	   (type array-index boffset
-		 padded-bytes-per-line)
-	   (type pixarray pixarray)
-	   (type card16 x y width height)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (type (member 8 16 32) unit)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p))
-  (progn bbuf boffset pixarray x y width height padded-bytes-per-line
-	 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
-  (or
-    #+(or Genera lcl3.0 excl)
-    (fast-read-pixarray-with-swap
-      bbuf boffset pixarray x y width height padded-bytes-per-line
-      bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
-    (let ((function
-	    (or #+lispm
-		(and (= (sys:array-element-size pixarray) bits-per-pixel)
-		     (zerop (index-mod padded-bytes-per-line 4))
-		     (zerop (index-mod
-			      (* #+Genera (sys:array-row-span pixarray)
-				 #-Genera (array-dimension pixarray 1)
-				 bits-per-pixel)
-			      32))
-		     #'fast-read-pixarray-using-bitblt)
-		#+(or lcl3.0 excl)
-		(and (index= bits-per-pixel 1)
-		     #'fast-read-pixarray-1)
-		#+(or lcl3.0 excl)
-		(and (index= bits-per-pixel 4)
-		     #'fast-read-pixarray-4)
-		#+(or Genera lcl3.0 excl)
-		(and (index= bits-per-pixel 24)
-		     #'fast-read-pixarray-24))))
-      (when function
-	(read-pixarray-internal
-	  bbuf boffset pixarray x y width height padded-bytes-per-line
-	  bits-per-pixel function
-	  unit byte-lsb-first-p bit-lsb-first-p
-	  *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)))))
-
-;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s
-
-#+(or lcl3.0 excl)
-(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height
-			      padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-1 array)
-	   (type card16 x y width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (with-underlying-simple-vector (vector pixarray-1-element-type array)
-      (do* ((h 0 (index1+ h))
-	    (y y (index1+ y))
-	    (right-bits (index-mod width 8))
-	    (middle-bits (index- width right-bits))
-	    (middle-bytes (index-ceiling middle-bits 8))
-	    (start index (index+ start padded-bytes-per-line)))
-	   ((index>= h height))
-	(declare (type array-index h y right-bits middle-bits
-		       middle-bytes start))
-	(do* ((end (index+ start middle-bytes))
-	      (i start (index1+ i))
-	      (start-x x)
-	      (x (array-row-major-index array y start-x) (index+ x 8)))
-	     ((index>= i end)
-	      (unless (index-zerop right-bits)
-		(let ((x (array-row-major-index
-			   array y (index+ start-x middle-bits))))
-		  (declare (type array-index x))
-		  (setf (aref buffer-bbuf end)
-			(write-image-assemble-bytes
-			  (aref vector (index+ x 0))
-			  (if (index> right-bits 1)
-			      (aref vector (index+ x 1))
-			    0)
-			  (if (index> right-bits 2)
-			      (aref vector (index+ x 2))
-			    0)
-			  (if (index> right-bits 3)
-			      (aref vector (index+ x 3))
-			    0)
-			  (if (index> right-bits 4)
-			      (aref vector (index+ x 4))
-			    0)
-			  (if (index> right-bits 5)
-			      (aref vector (index+ x 5))
-			    0)
-			  (if (index> right-bits 6)
-			      (aref vector (index+ x 6))
-			    0)
-			  0)))))
-	  (declare (type array-index end i start-x x))
-	  (setf (aref buffer-bbuf i)
-		(write-image-assemble-bytes
-		  (aref vector (index+ x 0))
-		  (aref vector (index+ x 1))
-		  (aref vector (index+ x 2))
-		  (aref vector (index+ x 3))
-		  (aref vector (index+ x 4))
-		  (aref vector (index+ x 5))
-		  (aref vector (index+ x 6))
-		  (aref vector (index+ x 7))))))))
-  t)
-
-#+(or lcl3.0 excl)
-(defun fast-write-pixarray-4 (buffer-bbuf index array x y width height
-			      padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-4 array)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (with-underlying-simple-vector (vector pixarray-4-element-type array)
-      (do* ((h 0 (index1+ h))
-	    (y y (index1+ y))
-	    (right-nibbles (index-mod width 2))
-	    (middle-nibbles (index- width right-nibbles))
-	    (middle-bytes (index-ceiling middle-nibbles 2))
-	    (start index (index+ start padded-bytes-per-line)))
-	   ((index>= h height))
-	(declare (type array-index h y right-nibbles middle-nibbles
-		       middle-bytes start))
-	(do* ((end (index+ start middle-bytes))
-	      (i start (index1+ i))
-	      (start-x x)
-	      (x (array-row-major-index array y start-x) (index+ x 2)))
-	     ((index>= i end)
-	      (unless (index-zerop right-nibbles)
-		(setf (aref buffer-bbuf end)
-		      (write-image-assemble-bytes
-			(aref array y (index+ start-x middle-nibbles))
-			0))))
-	  (declare (type array-index end i start-x x))
-	  (setf (aref buffer-bbuf i)
-		(write-image-assemble-bytes
-		  (aref vector (index+ x 0))
-		  (aref vector (index+ x 1))))))))
-  t)
-
-#+(or Genera lcl3.0 excl)
-(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
-			       padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-24 array)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (with-underlying-simple-vector (vector pixarray-24-element-type array)
-      (do* ((h 0 (index1+ h))
-	    (y y (index1+ y))
-	    (start index (index+ start padded-bytes-per-line)))
-	   ((index>= h height))
-	(declare (type array-index y start))
-	(do* ((end (index+ start (index* width 3)))
-	      (i start (index+ i 3))
-	      (x (array-row-major-index array y x) (index1+ x)))
-	     ((index>= i end))
-	  (declare (type array-index end i x))
-	  (let ((pixel (aref vector x)))
-	    (declare (type pixarray-24-element-type pixel))
-	    (setf (aref buffer-bbuf (index+ i 0))
-		  (write-image-load-byte 0 pixel 24))
-	    (setf (aref buffer-bbuf (index+ i 1))
-		  (write-image-load-byte 8 pixel 24))
-	    (setf (aref buffer-bbuf (index+ i 2))
-		  (write-image-load-byte 16 pixel 24)))))))
-  t)
-
-#+lispm
-(defun fast-write-pixarray-using-bitblt
-       (bbuf boffset pixarray x y width height padded-bytes-per-line
-	bits-per-pixel)
-  (#+Genera sys:stack-let* #-Genera let*
-   ((dimensions (list (+ y height)
-		      (floor (* padded-bytes-per-line 8) bits-per-pixel)))
-    (a (make-array
-	 dimensions
-	 :element-type (array-element-type pixarray)
-	 :displaced-to bbuf
-	 :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))
-   (sys:bitblt boole-1 width height pixarray x y a 0 0))
-  t)
-
-#+(or Genera lcl3.0 excl)
-(defun fast-write-pixarray-with-swap
-       (bbuf boffset pixarray x y width height padded-bytes-per-line
-	bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
-  (declare (type buffer-bytes bbuf)
-	   (type pixarray pixarray)
-	   (type card16 x y width height)
-	   (type array-index boffset padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (type (member 8 16 32) unit)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p))
-  (unless (index= bits-per-pixel 24)
-    (let ((pixarray-padded-bits-per-line
-	    (if (index= height 1) 0
-	      (index* (index- (array-row-major-index pixarray 1 0)
-			      (array-row-major-index pixarray 0 0))
-		      bits-per-pixel)))
-	  (pixarray-start-bit-offset
-	    (index* (array-row-major-index pixarray y x)
-		    bits-per-pixel)))
-      (declare (type array-index pixarray-padded-bits-per-line
-		     pixarray-start-bit-offset))
-      (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
-		(and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
-		     (index-zerop (index-mod pixarray-start-bit-offset 8)))
-	      (and (index-zerop (index-mod pixarray-padded-bits-per-line *image-unit*))
-		   (index-zerop (index-mod pixarray-start-bit-offset *image-unit*))))
-	(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
-	    (image-swap-function
-	      bits-per-pixel
-	      *image-unit* *computed-image-byte-lsb-first-p*
-	      *computed-image-bit-lsb-first-p*
-	      unit byte-lsb-first-p bit-lsb-first-p)
-	  (declare (type symbol image-swap-function)
-		   (type boolean image-swap-lsb-first-p))
-	  (with-underlying-simple-vector (src card8 pixarray)
-	    (funcall
-	      (symbol-function image-swap-function)
-	      src bbuf (index-floor pixarray-start-bit-offset 8) boffset
-	      (index-ceiling (index* width bits-per-pixel) 8)
-	      (index-floor pixarray-padded-bits-per-line 8)
-	      padded-bytes-per-line height image-swap-lsb-first-p))
-	  t)))))
-
-(defun fast-write-pixarray (bbuf boffset pixarray x y width height
-			    padded-bytes-per-line bits-per-pixel
-			    unit byte-lsb-first-p bit-lsb-first-p)
-  (declare (type buffer-bytes bbuf)
-	   (type pixarray pixarray)
-	   (type card16 x y width height)
-	   (type array-index boffset padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (type (member 8 16 32) unit)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p))
-  (progn bbuf boffset pixarray x y width height padded-bytes-per-line
-	 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
-  (or
-    #+(or Genera lcl3.0 excl)
-    (fast-write-pixarray-with-swap
-      bbuf boffset pixarray x y width height padded-bytes-per-line
-      bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
-    (let ((function
-	    (or #+lispm
-		(and (= (sys:array-element-size pixarray) bits-per-pixel)
-		     (zerop (index-mod padded-bytes-per-line 4))
-		     (zerop (index-mod
-			      (* #+Genera (sys:array-row-span pixarray)
-				 #-Genera (array-dimension pixarray 1)
-				 bits-per-pixel)
-			      32))
-		     #'fast-write-pixarray-using-bitblt)
-		#+(or lcl3.0 excl)
-		(and (index= bits-per-pixel 1)
-		     #'fast-write-pixarray-1)
-		#+(or lcl3.0 excl)
-		(and (index= bits-per-pixel 4)
-		     #'fast-write-pixarray-4)
-		#+(or Genera lcl3.0 excl)
-		(and (index= bits-per-pixel 24)
-		     #'fast-write-pixarray-24))))
-      (when function
-	(write-pixarray-internal
-	  bbuf boffset pixarray x y width height padded-bytes-per-line
-	  bits-per-pixel function
-	  *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*
-	  unit byte-lsb-first-p bit-lsb-first-p)))))
-
-;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another
-
-(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel)
-  (declare (type pixarray pixarray copy)
-	   (type card16 x y width height)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel))
-  (progn pixarray copy x y width height bits-per-pixel nil)
-  (or
-    #+lispm
-    (let* ((pixarray-padded-pixels-per-line
-	     #+Genera (sys:array-row-span pixarray)
-	     #-Genera (array-dimension pixarray 1))
-	   (pixarray-padded-bits-per-line
-	     (* pixarray-padded-pixels-per-line bits-per-pixel))
-	   (copy-padded-pixels-per-line
-	     #+Genera (sys:array-row-span copy)
-	     #-Genera (array-dimension copy 1))
-	   (copy-padded-bits-per-line
-	     (* copy-padded-pixels-per-line bits-per-pixel)))
-      (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
-		 (zerop (index-mod pixarray-padded-bits-per-line 32))
-		 (zerop (index-mod copy-padded-bits-per-line 32)))
-	(sys:bitblt boole-1 width height pixarray x y copy 0 0)
-	t))
-    #+(or lcl3.0 excl)
-    (unless (index= bits-per-pixel 24)
-      (let ((pixarray-padded-bits-per-line
-	      (if (index= height 1) 0
-		(index* (index- (array-row-major-index pixarray 1 0)
-				(array-row-major-index pixarray 0 0))
-			bits-per-pixel)))
-	    (copy-padded-bits-per-line
-	      (if (index= height 1) 0
-		(index* (index- (array-row-major-index copy 1 0)
-				(array-row-major-index copy 0 0))
-			bits-per-pixel)))
-	    (pixarray-start-bit-offset
-	      (index* (array-row-major-index pixarray y x)
-		      bits-per-pixel)))
-	(declare (type array-index pixarray-padded-bits-per-line
-		       copy-padded-bits-per-line pixarray-start-bit-offset))
-	(when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
-		  (and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
-		       (index-zerop (index-mod copy-padded-bits-per-line 8))
-		       (index-zerop (index-mod pixarray-start-bit-offset 8)))
-		(and (index-zerop (index-mod pixarray-padded-bits-per-line *image-unit*))
-		     (index-zerop (index-mod copy-padded-bits-per-line *image-unit*))
-		     (index-zerop (index-mod pixarray-start-bit-offset *image-unit*))))
-	  (with-underlying-simple-vector (src card8 pixarray)
-	    (with-underlying-simple-vector (dst card8 copy)
-	      (image-noswap
-		src dst
-		(index-floor pixarray-start-bit-offset 8) 0
-		(index-ceiling (index* width bits-per-pixel) 8)
-		(index-floor pixarray-padded-bits-per-line 8)
-		(index-floor copy-padded-bits-per-line 8)
-		height nil)))
-	  t)))
-    #+(or lcl3.0 excl)
-    (macrolet
-      ((copy (type element-type)
-	 `(let ((pixarray pixarray)
-		(copy copy))
-	    (declare (type ,type pixarray copy))
-	    #.(declare-buffun)
-	    (with-underlying-simple-vector (src ,element-type pixarray)
-	      (with-underlying-simple-vector (dst ,element-type copy)
-		(do* ((dst-y 0 (index1+ dst-y))
-		      (src-y y (index1+ src-y)))
-		     ((index>= dst-y height))
-		  (declare (type card16 dst-y src-y))
-		  (do* ((dst-idx (array-row-major-index copy dst-y 0)
-				 (index1+ dst-idx))
-			(dst-end (index+ dst-idx width))
-			(src-idx (array-row-major-index pixarray src-y x)
-				 (index1+ src-idx)))
-		       ((index>= dst-idx dst-end))
-		    (declare (type array-index dst-idx src-idx dst-end))
-		    (setf (aref dst dst-idx)
-			  (the ,element-type (aref src src-idx))))))))))
-      (ecase bits-per-pixel
-	(1  (copy pixarray-1  pixarray-1-element-type))
-	(4  (copy pixarray-4  pixarray-4-element-type))
-	(8  (copy pixarray-8  pixarray-8-element-type))
-	(16 (copy pixarray-16 pixarray-16-element-type))
-	(24 (copy pixarray-24 pixarray-24-element-type))
-	(32 (copy pixarray-32 pixarray-32-element-type)))
-      t)))
diff --git a/clx/display.lisp b/clx/display.lisp
deleted file mode 100644
index a8f5307b5058439593764c51b9a7dda48ef96cee..0000000000000000000000000000000000000000
--- a/clx/display.lisp
+++ /dev/null
@@ -1,574 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-;;; Authorizaton
-
-(defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1"))
-
-(defun get-best-authorization (host display protocol)
-  (labels ((read-short (stream &optional (eof-errorp t))
-	     (let ((high-byte (read-byte stream eof-errorp)))
-	       (and high-byte
-		    (dpb high-byte (byte 8 8) (read-byte stream)))))
-	   (read-short-length-string (stream)
-	     (let ((length (read-short stream)))
-	       (let ((string (make-string length)))
-		 (dotimes (k length)
-		   (setf (schar string k) (card8->char (read-byte stream))))
-		 string)))
-	   (read-short-length-vector (stream)
-	     (let ((length (read-short stream)))
-	       (let ((vector (make-array length :element-type '(unsigned-byte 8))))
-		 (dotimes (k length)
-		   (setf (aref vector k) (read-byte stream)))
-		 vector))))
-    (let ((pathname (authority-pathname)))
-      (when pathname
-	(with-open-file (stream pathname :element-type '(unsigned-byte 8)
-				:if-does-not-exist nil)
-	  (when stream
-	    (let* ((host-family (ecase protocol
-				  ((:tcp :internet nil) 0)
-				  ((:dna :DECnet) 1)
-				  ((:chaos) 2)))
-		   (host-address (rest (host-address host host-family)))
-		   (best-name nil)
-		   (best-data nil))
-	      (loop
-		(let ((family (read-short stream nil)))
-		  (when (null family)
-		    (return))
-		  (let* ((address (read-short-length-vector stream))
-			 (number (parse-integer (read-short-length-string stream)))
-			 (name (read-short-length-string stream))
-			 (data (read-short-length-vector stream)))
-		    (when (and (= family host-family)
-			       (equal host-address (coerce address 'list))
-			       (= number display)
-			       (let ((pos1 (position name *known-authorizations* :test #'string=)))
-				 (and pos1
-				      (or (null best-name)
-					  (< pos1 (position best-name *known-authorizations*
-							    :test #'string=))))))
-		      (setf best-name name)
-		      (setf best-data data)))))
-	      (when best-name
-		(return-from get-best-authorization
-		  (values best-name best-data)))))))))
-  (values "" ""))
-
-;;
-;; Resource id management
-;;
-(defun initialize-resource-allocator (display)
-  ;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask
-  (let ((id-mask (display-resource-id-mask display)))
-    (unless (zerop id-mask) ;; zero mask is an error
-      (do ((first 0 (index1+ first))
-	   (mask id-mask (the mask32 (ash mask -1))))
-	  ((oddp mask)
-	   (setf (display-resource-id-byte display)
-		 (byte (integer-length mask) first)))
-	(declare (type array-index first)
-		 (type mask32 mask))))))
-
-(defun resourcealloc (display)
-  ;; Allocate a resource-id for in DISPLAY
-  (declare (type display display))
-  (declare (clx-values resource-id))
-  (dpb (incf (display-resource-id-count display))
-       (display-resource-id-byte display)
-       (display-resource-id-base display)))
-
-(defmacro allocate-resource-id (display object type)
-  ;; Allocate a resource-id for OBJECT in DISPLAY
-  (if (member (eval type) *clx-cached-types*)
-      `(let ((id (funcall (display-xid ,display) ,display)))
-	 (save-id ,display id ,object)
-	 id)
-    `(funcall (display-xid ,display) ,display)))
-
-(defmacro deallocate-resource-id (display id type)
-  ;; Deallocate a resource-id for OBJECT in DISPLAY
-  (when (member (eval type) *clx-cached-types*)
-    `(deallocate-resource-id-internal ,display ,id)))
-
-(defun deallocate-resource-id-internal (display id)
-  (remhash id (display-resource-id-map display)))
-
-(defun lookup-resource-id (display id)
-  ;; Find the object associated with resource ID
-  (gethash id (display-resource-id-map display)))
-
-(defun save-id (display id object)
-  ;; Register a resource-id from another display.
-  (declare (type display display)
-	   (type integer id)
-	   (type t object))
-  (declare (clx-values object))
-  (setf (gethash id (display-resource-id-map display)) object))
-
-;; Define functions to find the CLX data types given a display and resource-id
-;; If the data type is being cached, look there first.
-(macrolet ((generate-lookup-functions (useless-name &body types)
-	    `(within-definition (,useless-name generate-lookup-functions)
-	       ,@(mapcar
-		   #'(lambda (type)
-		       `(defun ,(xintern 'lookup- type)
-			       (display id)
-			  (declare (type display display)
-				   (type resource-id id))
-			  (declare (clx-values ,type))
-			  ,(if (member type *clx-cached-types*)
-			       `(let ((,type (lookup-resource-id display id)))
-				  (cond ((null ,type) ;; Not found, create and save it.
-					 (setq ,type (,(xintern 'make- type)
-						      :display display :id id))
-					 (save-id display id ,type))
-					;; Found.  Check the type
-					,(cond ((null *type-check?*)
-						`(t ,type))
-					       ((member type '(window pixmap))
-						`((type? ,type 'drawable) ,type))
-					       (t `((type? ,type ',type) ,type)))
-					,@(when *type-check?*
-					    `((t (x-error 'lookup-error
-							  :id id
-							  :display display
-							  :type ',type
-							  :object ,type))))))
-			       ;; Not being cached.  Create a new one each time.
-			       `(,(xintern 'make- type)
-				 :display display :id id))))
-		   types))))
-  (generate-lookup-functions ignore
-    drawable
-    window
-    pixmap
-    gcontext
-    cursor
-    colormap
-    font))
-
-(defun id-atom (id display)
-  ;; Return the cached atom for an atom ID
-  (declare (type resource-id id)
-	   (type display display))
-  (declare (clx-values (or null keyword)))
-  (gethash id (display-atom-id-map display)))
-
-(defun atom-id (atom display)
-  ;; Return the ID for an atom in DISPLAY
-  (declare (type xatom atom)
-	   (type display display))
-  (declare (clx-values (or null resource-id)))
-  (gethash (if (or (null atom) (keywordp atom)) atom (kintern atom))
-	   (display-atom-cache display)))
-
-(defun set-atom-id (atom display id)
-  ;; Set the ID for an atom in DISPLAY
-  (declare (type xatom atom)
-	   (type display display)
-	   (type resource-id id))
-  (declare (clx-values resource-id))
-  (let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom))))
-    (setf (gethash id (display-atom-id-map display)) atom)
-    (setf (gethash atom (display-atom-cache display)) id)
-    id))
-
-(defsetf atom-id set-atom-id)
-
-(defun initialize-predefined-atoms (display)
-  (dotimes (i (length *predefined-atoms*))
-    (declare (type resource-id i))
-    (setf (atom-id (svref *predefined-atoms* i) display) i)))
-
-(defun visual-info (display visual-id)
-  (declare (type display display)
-	   (type resource-id visual-id)
-	   (clx-values visual-info))
-  (when (zerop visual-id)
-    (return-from visual-info nil))
-  (dolist (screen (display-roots display))
-    (declare (type screen screen))
-    (dolist (depth (screen-depths screen))
-      (declare (type cons depth))
-      (dolist (visual-info (rest depth))
-	(declare (type visual-info visual-info))
-	(when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info))
-	  (return-from visual-info visual-info)))))
-  (error "Visual info not found for id #x~x in display ~s." visual-id display))
-
-
-;;
-;; Display functions
-;;
-(defmacro with-display ((display &key timeout inline)
-			&body body)
-  ;; This macro is for use in a multi-process environment.  It provides exclusive
-  ;; access to the local display object for multiple request generation.  It need not
-  ;; provide immediate exclusive access for replies; that is, if another process is
-  ;; waiting for a reply (while not in a with-display), then synchronization need not
-  ;; (but can) occur immediately.  Except where noted, all routines effectively
-  ;; contain an implicit with-display where needed, so that correct synchronization
-  ;; is always provided at the interface level on a per-call basis.  Nested uses of
-  ;; this macro will work correctly.  This macro does not prevent concurrent event
-  ;; processing; see with-event-queue.
-  `(with-buffer (,display
-		 ,@(and timeout `(:timeout ,timeout))
-		 ,@(and inline `(:inline ,inline)))
-     ,@body))
-
-(defmacro with-event-queue ((display &key timeout inline)
-			    &body body &environment env)
-  ;; exclusive access to event queue
-  `(macrolet ((with-event-queue ((display &key timeout) &body body)
-		;; Speedup hack for lexically nested with-event-queues
-		`(progn
-		   (progn ,display ,@(and timeout `(,timeout)) nil)
-		   ,@body)))
-     ,(if (and (null inline) (macroexpand '(use-closures) env))
-	  `(flet ((.with-event-queue-body. () ,@body))
-	     #+clx-ansi-common-lisp
-	     (declare (dynamic-extent #'.with-event-queue-body.))
-	     (with-event-queue-function
-	       ,display ,timeout #'.with-event-queue-body.))
-	(let ((disp (if (or (symbolp display) (constantp display))
-			display
-		      '.display.)))
-	  `(let (,@(unless (eq disp display) `((,disp ,display))))
-	     (holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock"
-			    ,@(and timeout `(:timeout ,timeout)))
-	       ,@body))))))
-
-(defun with-event-queue-function (display timeout function)
-  (declare (type display display)
-	   (type (or null number) timeout)
-	   (type function function)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent function)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg function))
-  (with-event-queue (display :timeout timeout :inline t)
-    (funcall function)))
-
-(defmacro with-event-queue-internal ((display &key timeout) &body body)
-  ;; exclusive access to the internal event queues
-  (let ((disp (if (or (symbolp display) (constantp display)) display '.display.)))
-    `(let (,@(unless (eq disp display) `((,disp ,display))))
-       (holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock"
-		      ,@(and timeout `(:timeout ,timeout)))
-	 ,@body))))
-
-(defun open-display (host &key (display 0) protocol authorization-name authorization-data)
-  ;; Implementation specific routine to setup the buffer for a specific host and display.
-  ;; This must interface with the local network facilities, and will probably do special
-  ;; things to circumvent the nework when displaying on the local host.
-  ;;
-  ;; A string must be acceptable as a host, but otherwise the possible types
-  ;; for host and protocol are not constrained, and will likely be very
-  ;; system dependent.  The default protocol is system specific.  Authorization,
-  ;; if any, is assumed to come from the environment somehow.
-  (declare (type integer display))
-  (declare (clx-values display))
-  ;; Get the authorization mechanism from the environment.
-  (when (null authorization-name)
-    (multiple-value-setq (authorization-name authorization-data)
-      (get-best-authorization host display protocol)))
-  ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM.
-  (let* ((stream (open-x-stream host display protocol))
-	 (disp (make-buffer *output-buffer-size* #'make-display-internal
-			    :host host :display display
-			    :output-stream stream :input-stream stream))
-	 (ok-p nil))
-    (unwind-protect
-	(progn
-	  (display-connect disp
-			   :authorization-name authorization-name
-			   :authorization-data authorization-data)
-	  (setf (display-authorization-name disp) authorization-name)
-	  (setf (display-authorization-data disp) authorization-data)
-	  (initialize-resource-allocator disp)
-	  (initialize-predefined-atoms disp)
-	  (initialize-extensions disp)
-	  (setq ok-p t))
-      (unless ok-p (close-display disp :abort t)))
-    disp))
-
-(defun display-force-output (display)
-  ; Output is normally buffered, this forces any buffered output to the server.
-  (declare (type display display))
-  (with-display (display)
-    (buffer-force-output display)))
-
-(defun close-display (display &key abort)
-  ;; Close the host connection in DISPLAY
-  (declare (type display display))
-  (close-buffer display :abort abort))
-
-(defun display-connect (display &key authorization-name authorization-data)
-  (with-buffer-output (display :sizes (8 16))
-    (card8-put
-      0
-      (ecase (display-byte-order display)
-	(:lsbfirst #x6c)   ;; Ascii lowercase l - Least Significant Byte First
-	(:msbfirst #x42))) ;; Ascii uppercase B -  Most Significant Byte First
-    (card16-put 2 *protocol-major-version*)
-    (card16-put 4 *protocol-minor-version*)
-    (card16-put 6 (length authorization-name))
-    (card16-put 8 (length authorization-data))
-    (write-sequence-char display 12 authorization-name)
-    (if (stringp authorization-data)
-	(write-sequence-char display (lround (+ 12 (length authorization-name)))
-			     authorization-data)
-	(write-sequence-card8 display (lround (+ 12 (length authorization-name)))
-			      authorization-data)))
-  (buffer-force-output display)
-  (let ((reply-buffer nil))
-    (declare (type (or null reply-buffer) reply-buffer))
-    (unwind-protect
-	(progn
-	  (setq reply-buffer (allocate-reply-buffer #x1000))
-	  (with-buffer-input (reply-buffer :sizes (8 16 32))
-	    (buffer-input display buffer-bbuf 0 8)
-	    (let ((success (boolean-get 0))
-		  (reason-length (card8-get 1))
-		  (major-version (card16-get 2))
-		  (minor-version (card16-get 4))
-		  (total-length (card16-get 6))
-		  vendor-length
-		  num-roots
-		  num-formats)
-	      (declare (ignore total-length))
-	      (unless success
-		(x-error 'connection-failure
-			 :major-version major-version
-			 :minor-version minor-version
-			 :host (display-host display)
-			 :display (display-display display)
-			 :reason
-			 (progn (buffer-input display buffer-bbuf 0 reason-length)
-				(string-get reason-length 0 :reply-buffer reply-buffer))))
-	      (buffer-input display buffer-bbuf 0 32)
-	      (setf (display-protocol-major-version display) major-version)
-	      (setf (display-protocol-minor-version display) minor-version)
-	      (setf (display-release-number display) (card32-get 0))
-	      (setf (display-resource-id-base display) (card32-get 4))
-	      (setf (display-resource-id-mask display) (card32-get 8))
-	      (setf (display-motion-buffer-size display) (card32-get 12))
-	      (setq vendor-length (card16-get 16))
-	      (setf (display-max-request-length display) (card16-get 18))
-	      (setq num-roots (card8-get 20))
-	      (setq num-formats (card8-get 21))
-	      ;; Get the image-info
-	      (setf (display-image-lsb-first-p display) (zerop (card8-get 22)))
-	      (let ((format (display-bitmap-format display)))
-		(declare (type bitmap-format format))
-		(setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23)))
-		(setf (bitmap-format-unit format) (card8-get 24))
-		(setf (bitmap-format-pad format) (card8-get 25)))
-	      (setf (display-min-keycode display) (card8-get 26))
-	      (setf (display-max-keycode display) (card8-get 27))
-	      ;; 4 bytes unused
-	      ;; Get the vendor string
-	      (buffer-input display buffer-bbuf 0 (lround vendor-length))
-	      (setf (display-vendor-name display)
-		    (string-get vendor-length 0 :reply-buffer reply-buffer))
-	      ;; Initialize the pixmap formats
-	      (dotimes (i num-formats) ;; loop gathering pixmap formats
-		(declare (ignorable i))
-		(buffer-input display buffer-bbuf 0 8)
-		(push (make-pixmap-format :depth (card8-get 0)
-					  :bits-per-pixel (card8-get 1)
-					  :scanline-pad (card8-get 2))
-						; 5 unused bytes
-		      (display-pixmap-formats display)))
-	      (setf (display-pixmap-formats display)
-		    (nreverse (display-pixmap-formats display)))
-	      ;; Initialize the screens
-	      (dotimes (i num-roots)
-		(declare (ignorable i))
-		(buffer-input display buffer-bbuf 0 40)
-		(let* ((root-id (card32-get 0))
-		       (root (make-window :id root-id :display display))
-		       (root-visual (card32-get 32))
-		       (default-colormap-id (card32-get 4))
-		       (default-colormap
-			 (make-colormap :id default-colormap-id :display display))
-		       (screen
-			 (make-screen
-			   :root root
-			   :default-colormap default-colormap
-			   :white-pixel (card32-get 8)
-			   :black-pixel (card32-get 12)
-			   :event-mask-at-open (card32-get 16)
-			   :width  (card16-get 20)
-			   :height (card16-get 22)
-			   :width-in-millimeters  (card16-get 24)
-			   :height-in-millimeters (card16-get 26)
-			   :min-installed-maps (card16-get 28)
-			   :max-installed-maps (card16-get 30)
-			   :backing-stores (member8-get 36 :never :when-mapped :always)
-			   :save-unders-p (boolean-get 37)
-			   :root-depth (card8-get 38)))
-		       (num-depths (card8-get 39))
-		       (depths nil))
-		  ;; Save root window for event reporting
-		  (save-id display root-id root)
-		  (save-id display default-colormap-id default-colormap)
-		  ;; Create the depth AList for a screen, (depth . visual-infos)
-		  (dotimes (j num-depths)
-		    (declare (ignorable j))
-		    (buffer-input display buffer-bbuf 0 8)
-		    (let ((depth (card8-get 0))
-			  (num-visuals (card16-get 2))
-			  (visuals nil)) ;; 4 bytes unused
-		      (dotimes (k num-visuals)
-			(declare (ignorable k))
-			(buffer-input display buffer-bbuf 0 24)
-			(let* ((visual (card32-get 0))
-			       (visual-info (make-visual-info
-					      :id visual
-					      :display display
-					      :class (member8-get 4 :static-gray :gray-scale
-								  :static-color :pseudo-color
-								  :true-color :direct-color)
-					      :bits-per-rgb (card8-get 5)
-					      :colormap-entries (card16-get 6)
-					      :red-mask (card32-get 8)
-					      :green-mask (card32-get 12)
-					      :blue-mask (card32-get 16)
-					      ;; 4 bytes unused
-					      )))
-			  (push visual-info visuals)
-			  (when (funcall (resource-id-map-test) root-visual visual)
-			    (setf (screen-root-visual-info screen)
-				  (setf (colormap-visual-info default-colormap)
-					visual-info)))))
-		      (push (cons depth (nreverse visuals)) depths)))
-		  (setf (screen-depths screen) (nreverse depths))
-		  (push screen (display-roots display))))
-	      (setf (display-roots display) (nreverse (display-roots display)))
-	      (setf (display-default-screen display) (first (display-roots display))))))
-      (when reply-buffer
-	(deallocate-reply-buffer reply-buffer))))
-  display)
-
-(defun display-protocol-version (display)
-  (declare (type display display))
-  (declare (clx-values major minor))
-  (values (display-protocol-major-version display)
-	  (display-protocol-minor-version display)))
-
-(defun display-vendor (display)
-  (declare (type display display))
-  (declare (clx-values name release))
-  (values (display-vendor-name display)
-	  (display-release-number display)))
-
-(defun display-nscreens (display)
-  (declare (type display display))
-  (length (display-roots display)))
-
-#+comment ;; defined by the DISPLAY defstruct
-(defsetf display-error-handler (display) (handler)
-  ;; All errors (synchronous and asynchronous) are processed by calling an error
-  ;; handler in the display.  If handler is a sequence it is expected to contain
-  ;; handler functions specific to each error; the error code is used to index the
-  ;; sequence, fetching the appropriate handler.  Any results returned by the handler
-  ;; are ignored; it is assumed the handler either takes care of the error
-  ;; completely, or else signals. For all core errors, the keyword/value argument
-  ;; pairs are:
-  ;;    :display display
-  ;;    :error-key error-key
-  ;;    :major integer
-  ;;    :minor integer
-  ;;    :sequence integer
-  ;;    :current-sequence integer
-  ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and
-  ;; :window errors another pair is:
-  ;;    :resource-id integer
-  ;; For :atom errors, another pair is:
-  ;;    :atom-id integer
-  ;; For :value errors, another pair is:
-  ;;    :value integer
-  )
-
-  ;; setf'able
-  ;; If defined, called after every protocol request is generated, even those inside
-  ;; explicit with-display's, but never called from inside the after-function itself.
-  ;; The function is called inside the effective with-display for the associated
-  ;; request.  Default value is nil.  Can be set, for example, to
-  ;; #'display-force-output or #'display-finish-output.
-
-(defvar *inside-display-after-function* nil)
-
-(defun display-invoke-after-function (display)
-  ; Called after every protocal request is generated
-  (declare (type display display))
-  (when (and (display-after-function display)
-	     (not *inside-display-after-function*))
-    (let ((*inside-display-after-function* t)) ;; Ensure no recursive calls
-      (funcall (display-after-function display) display))))
-
-(defun display-finish-output (display)
-  ;; Forces output, then causes a round-trip to ensure that all possible
-  ;; errors and events have been received.
-  (declare (type display display))
-  (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32))
-       ()
-    )
-  ;; Report asynchronous errors here if the user wants us to.
-  (report-asynchronous-errors display :after-finish-output))
-
-(defparameter
-  *request-names*
-  '#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes"
-     "DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow"
-     "MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows"
-     "ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree"
-     "InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty"
-     "GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner"
-     "ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer"
-     "GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard"
-     "UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents"
-     "GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents"
-     "TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus"
-     "QueryKeymap" "OpenFont" "CloseFont" "QueryFont"
-     "QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath"
-     "GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC"
-     "ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles"
-     "FreeGC" "ClearToBackground" "CopyArea" "CopyPlane"
-     "PolyPoint" "PolyLine" "PolySegment" "PolyRectangle"
-     "PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc"
-     "PutImage" "GetImage" "PolyText8" "PolyText16"
-     "ImageText8" "ImageText16" "CreateColormap" "FreeColormap"
-     "CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps"
-     "AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes"
-     "FreeColors" "StoreColors" "StoreNamedColor" "QueryColors"
-     "LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor"
-     "RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions"
-     "SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl"
-     "Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver"
-     "GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl"
-     "ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver"
-     "SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping"))
diff --git a/clx/doc.lisp b/clx/doc.lisp
deleted file mode 100644
index bff618e145a667cfd9f1371932014bde3a35d233..0000000000000000000000000000000000000000
--- a/clx/doc.lisp
+++ /dev/null
@@ -1,3803 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;; Copyright 1987, 1988 Massachusetts Institute of Technology, and
-;;;			 Texas Instruments Incorporated
-
-;;; Permission to use, copy, modify, and distribute this document for any purpose
-;;; and without fee is hereby granted, provided that the above copyright notice
-;;; appear in all copies and that both that copyright notice and this permission
-;;; notice are retained, and that the name of M.I.T. not be used in advertising or
-;;; publicity pertaining to this document without specific, written prior
-;;; permission.  M.I.T. makes no representations about the suitability of this
-;;; document or the protocol defined in this document for any purpose.  It is
-;;; provided "as is" without express or implied warranty.
-
-;;; Texas Instruments Incorporated provides this document "as is" without
-;;; express or implied warranty.
-
-;; Version 4
-
-;; This is considered a somewhat changeable interface.  Discussion of better
-;; integration with CLOS, support for user-specified subclassess of basic
-;; objects, and the additional functionality to match the C Xlib is still in
-;; progress.
-
-;; Primary Interface Author:
-;;	Robert W. Scheifler
-;;	MIT Laboratory for Computer Science
-;;	545 Technology Square, Room 418
-;;	Cambridge, MA 02139
-;;	rws@zermatt.lcs.mit.edu
-
-;; Design Contributors:
-;;	Dan Cerys, Texas Instruments
-;;	Scott Fahlman, CMU
-;;      Charles Hornig, Symbolics
-;;      John Irwin, Franz
-;;	Kerry Kimbrough, Texas Instruments
-;;	Chris Lindblad, MIT
-;;	Rob MacLachlan, CMU
-;;	Mike McMahon, Symbolics
-;;	David Moon, Symbolics
-;;	LaMott Oren, Texas Instruments
-;;	Daniel Weinreb, Symbolics
-;;	John Wroclawski, MIT
-;;	Richard Zippel, Symbolics
-
-;; CLX Extensions
-;; Adds some of the functionality provided by the C XLIB library.
-;;
-;; Primary Author
-;;	LaMott G. Oren
-;;	Texas Instruments
-;; 
-;; Design Contributors:
-;;	Robert W. Scheifler, MIT
-
-
-;; Note: all of the following is in the package XLIB.
-
-(declaim (declaration arglist clx-values))
-
-;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of
-;; the relationships should be fairly obvious.  We have no intention of writing yet
-;; another moby document for this interface.
-
-(deftype card32 () '(unsigned-byte 32))
-
-(deftype card29 () '(unsigned-byte 29))
-
-(deftype int32 () '(signed-byte 32))
-
-(deftype card16 () '(unsigned-byte 16))
-
-(deftype int16 () '(signed-byte 16))
-
-(deftype card8 () '(unsigned-byte 8))
-
-(deftype int8 () '(signed-byte 8))
-
-(deftype mask32 () 'card32)
-
-(deftype mask16 () 'card16)
-
-(deftype resource-id () 'card29)
-
-;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color.
-;; These types are defined solely by a functional interface; we do not specify
-;; whether they are implemented as structures or flavors or ...  Although functions
-;; below are written using DEFUN, this is not an implementation requirement (although
-;; it is a requirement that they be functions as opposed to macros or special forms).
-;; It is unclear whether with-slots in the Common Lisp Object System must work on
-;; them.
-
-;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as
-;; compound objects, rather than as integer resource-ids.  This allows applications
-;; to deal with multiple displays without having an explicit display argument in the
-;; most common functions.  Every function uses the display object indicated by the
-;; first argument that is or contains a display; it is an error if arguments contain
-;; different displays, and predictable results are not guaranteed.
-
-;; Each of window, pixmap, drawable, cursor, font, gcontext, and colormap have the
-;; following five functions:
-
-(defun <mumble>-display (<mumble>)
-  (declare (type <mumble> <mumble>)
-	   (clx-values display)))
-
-(defun <mumble>-id (<mumble>)
-  (declare (type <mumble> <mumble>)
-	   (clx-values resource-id)))
-
-(defun <mumble>-equal (<mumble>-1 <mumble>-2)
-  (declare (type <mumble> <mumble>-1 <mumble>-2)))
-
-(defun <mumble>-p (<mumble>)
-  (declare (type <mumble> <mumble>)
-	   (clx-values boolean)))
-
-;; The following functions are provided by color objects:
-
-;; The intention is that IHS and YIQ and CYM interfaces will also exist.  Note that
-;; we are explicitly using a different spectrum representation than what is actually
-;; transmitted in the protocol.
-
-(deftype rgb-val () '(real 0 1))
-
-(defun make-color (&key red green blue &allow-other-keys)	; for expansion
-  (declare (type rgb-val red green blue)
-	   (clx-values color)))
-
-(defun color-rgb (color)
-  (declare (type color color)
-	   (clx-values red green blue)))
-
-(defun color-red (color)
-  ;; setf'able
-  (declare (type color color)
-	   (clx-values rgb-val)))
-
-(defun color-green (color)
-  ;; setf'able
-  (declare (type color color)
-	   (clx-values rgb-val)))
-
-(defun color-blue (color)
-  ;; setf'able
-  (declare (type color color)
-	   (clx-values rgb-val)))
-
-(deftype drawable () '(or window pixmap))
-
-;; Atoms are accepted as strings or symbols, and are always returned as keywords.
-;; Protocol-level integer atom ids are hidden, using a cache in the display object.
-
-(deftype xatom () '(or string symbol))
-
-(deftype stringable () '(or string symbol))
-
-(deftype fontable () '(or stringable font))
-
-;; Nil stands for CurrentTime.
-
-(deftype timestamp () '(or null card32))
-
-(deftype bit-gravity () '(member :forget :static :north-west :north :north-east
-				 :west :center :east :south-west :south :south-east))
-
-(deftype win-gravity () '(member :unmap :static :north-west :north :north-east
-				 :west :center :east :south-west :south :south-east))
-
-(deftype grab-status ()
-  '(member :success :already-grabbed :frozen :invalid-time :not-viewable))
-
-(deftype boolean () '(or null (not null)))
-
-(deftype pixel () '(unsigned-byte 32))
-(deftype image-depth () '(integer 0 32))
-
-(deftype keysym () 'card32)
-
-(deftype array-index () `(integer 0 ,array-dimension-limit))
-
-;; An association list.
-
-(deftype alist (key-type-and-name datum-type-and-name) 'list)
-
-(deftype clx-list (&optional element-type) 'list)
-(deftype clx-sequence (&optional element-type) 'sequence)
-
-;; A sequence, containing zero or more repetitions of the given elements,
-;; with the elements expressed as (type name).
-
-(deftype repeat-seq (&rest elts) 'sequence)
-
-(deftype point-seq () '(repeat-seq (int16 x) (int16 y)))
-
-(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)))
-
-(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)))
-
-;; Note that we are explicitly using a different angle representation than what
-;; is actually transmitted in the protocol.
-
-(deftype angle () '(real #.(* -2 pi) #.(* 2 pi)))
-
-(deftype arc-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)
-				 (angle angle1) (angle angle2)))
-
-(deftype event-mask-class ()
-  '(member :key-press :key-release :owner-grab-button :button-press :button-release
-	   :enter-window :leave-window :pointer-motion :pointer-motion-hint
-	   :button-1-motion :button-2-motion :button-3-motion :button-4-motion
-	   :button-5-motion :button-motion :exposure :visibility-change
-	   :structure-notify :resize-redirect :substructure-notify :substructure-redirect
-	   :focus-change :property-change :colormap-change :keymap-state))
-
-(deftype event-mask ()
-  '(or mask32 (clx-list event-mask-class)))
-
-(deftype pointer-event-mask-class ()
-  '(member :button-press :button-release
-	   :enter-window :leave-window :pointer-motion :pointer-motion-hint
-	   :button-1-motion :button-2-motion :button-3-motion :button-4-motion
-	   :button-5-motion :button-motion :keymap-state))
-
-(deftype pointer-event-mask ()
-  '(or mask32 (clx-list pointer-event-mask-class)))
-
-(deftype device-event-mask-class ()
-  '(member :key-press :key-release :button-press :button-release :pointer-motion
-	   :button-1-motion :button-2-motion :button-3-motion :button-4-motion
-	   :button-5-motion :button-motion))
-
-(deftype device-event-mask ()
-  '(or mask32 (clx-list device-event-mask-class)))
-
-(deftype modifier-key ()
-  '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
-
-(deftype modifier-mask ()
-  '(or (member :any) mask16 (clx-list modifier-key)))
-
-(deftype state-mask-key ()
-  '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
-
-(deftype gcontext-key ()
-  '(member :function :plane-mask :foreground :background
-	   :line-width :line-style :cap-style :join-style :fill-style :fill-rule
-	   :arc-mode :tile :stipple :ts-x :ts-y :font :subwindow-mode
-	   :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes))
-
-(deftype event-key ()
-  '(member :key-press :key-release :button-press :button-release :motion-notify
-	   :enter-notify :leave-notify :focus-in :focus-out :keymap-notify
-	   :exposure :graphics-exposure :no-exposure :visibility-notify
-	   :create-notify :destroy-notify :unmap-notify :map-notify :map-request
-	   :reparent-notify :configure-notify :gravity-notify :resize-request
-	   :configure-request :circulate-notify :circulate-request :property-notify
-	   :selection-clear :selection-request :selection-notify
-	   :colormap-notify :client-message))
-
-(deftype error-key ()
-  '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
-	   :illegal-request :implementation :length :match :name :pixmap :value :window))
-
-(deftype draw-direction ()
-  '(member :left-to-right :right-to-left))
-
-(defstruct bitmap-format
-  (unit <unspec> :type (member 8 16 32))
-  (pad <unspec> :type (member 8 16 32))
-  (lsb-first-p <unspec> :type boolean))
-
-(defstruct pixmap-format
-  (depth <unspec> :type image-depth)
-  (bits-per-pixel <unspec> :type (member 1 4 8 16 24 32))
-  (pad <unspec> :type (member 8 16 32)))
-
-(defstruct visual-info
-  (id <unspec> :type resource-id)
-  (display <unspec> :type display)
-  (class <unspec> :type (member :static-gray :static-color :true-color
-				:gray-scale :pseudo-color :direct-color))
-  (red-mask <unspec> :type pixel)
-  (green-mask <unspec> :type pixel)
-  (blue-mask <unspec> :type pixel)
-  (bits-per-rgb <unspec> :type card8)
-  (colormap-entries <unspec> :type card16))
-
-(defstruct screen
-  (root <unspec> :type window)
-  (width <unspec> :type card16)
-  (height <unspec> :type card16)
-  (width-in-millimeters <unspec> :type card16)
-  (height-in-millimeters <unspec> :type card16)
-  (depths <unspec> :type (alist (image-depth depth) ((clx-list visual-info) visuals)))
-  (root-depth <unspec> :type image-depth)
-  (root-visual-info <unspec> :type visual-info)
-  (default-colormap <unspec> :type colormap)
-  (white-pixel <unspec> :type pixel)
-  (black-pixel <unspec> :type pixel)
-  (min-installed-maps <unspec> :type card16)
-  (max-installed-maps <unspec> :type card16)
-  (backing-stores <unspec> :type (member :never :when-mapped :always))
-  (save-unders-p <unspec> :type boolean)
-  (event-mask-at-open <unspec> :type mask32))
-
-(defun screen-root-visual (screen)
-  (declare (type screen screen)
-	   (clx-values resource-id)))
-
-;; The list contains alternating keywords and integers.
-
-(deftype font-props () 'list)
-
-(defun open-display (host &key (display 0) protocol)
-  ;; A string must be acceptable as a host, but otherwise the possible types for host
-  ;; and protocol are not constrained, and will likely be very system dependent.  The
-  ;; default protocol is system specific.  Authorization, if any, is assumed to come
-  ;; from the environment somehow.
-  (declare (type integer display)
-	   (clx-values display)))
-
-(defun display-protocol-major-version (display)
-  (declare (type display display)
-	   (clx-values card16)))
-
-(defun display-protocol-minor-version (display)
-  (declare (type display display)
-	   (clx-values card16)))
-
-(defun display-vendor-name (display)
-  (declare (type display display)
-	   (clx-values string)))
-
-(defun display-release-number (display)
-  (declare (type display display)
-	   (clx-values card32)))
-
-(defun display-image-lsb-first-p (display)
-  (declare (type display display)
-	   (clx-values boolean)))
-
-(defun display-bitmap-formap (display)
-  (declare (type display display)
-	   (clx-values bitmap-format)))
-
-(defun display-pixmap-formats (display)
-  (declare (type display display)
-	   (clx-values (clx-list pixmap-formats))))
-
-(defun display-roots (display)
-  (declare (type display display)
-	   (clx-values (clx-list screen))))
-
-(defun display-motion-buffer-size (display)
-  (declare (type display display)
-	   (clx-values card32)))
-
-(defun display-max-request-length (display)
-  (declare (type display display)
-	   (clx-values card16)))
-
-(defun display-min-keycode (display)
-  (declare (type display display)
-	   (clx-values card8)))
-
-(defun display-max-keycode (display)
-  (declare (type display display)
-	   (clx-values card8)))
-
-(defun close-display (display)
-  (declare (type display display)))
-
-(defun display-error-handler (display)
-  (declare (type display display)
-	   (clx-values handler)))
-
-(defsetf display-error-handler (display) (handler)
-  ;; All errors (synchronous and asynchronous) are processed by calling an error
-  ;; handler in the display.  If handler is a sequence it is expected to contain
-  ;; handler functions specific to each error; the error code is used to index the
-  ;; sequence, fetching the appropriate handler.  Any results returned by the handler
-  ;; are ignored; it is assumed the handler either takes care of the error
-  ;; completely, or else signals. For all core errors, the keyword/value argument
-  ;; pairs are:
-  ;;    :major card8
-  ;;    :minor card16
-  ;;    :sequence card16
-  ;;    :current-sequence card16
-  ;;	:asynchronous (member t nil)
-  ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and
-  ;; :window errors another pair is:
-  ;;    :resource-id card32
-  ;; For :atom errors, another pair is:
-  ;;    :atom-id card32
-  ;; For :value errors, another pair is:
-  ;;    :value card32
-  (declare (type display display)
-	   (type (or (clx-sequence (function (display symbol &key &allow-other-keys)))
-		     (function (display symbol &key &allow-other-keys)))
-		 handler)))
-
-(defsetf display-report-asynchronous-errors (display) (when)
-  ;; Most useful in multi-process lisps.
-  ;;
-  ;; Synchronous errors are always signalled in the process that made the
-  ;; synchronous request.  An error is considered synchronous if a process is
-  ;; waiting for a reply with the same request-id as the error.
-  ;; 
-  ;; Asynchronous errors can be signalled at any one of these three times:
-  ;; 
-  ;; 1.  As soon as they are read.  They get signalled in whichever process 
-  ;; was doing the reading.  This is enabled by
-  ;;       (setf (xlib:display-report-asynchronous-errors display)
-  ;;             '(:immediately))
-  ;; This is the default.
-  ;; 
-  ;; 2.  Before any events are to be handled.  You get these by doing an
-  ;; event-listen with any timeout value other than 0, or in of the event
-  ;; processing forms.  This is useful if you using a background process to
-  ;; handle input.  This is enabled by
-  ;;       (setf (xlib:display-report-asynchronous-errors display)
-  ;;             '(:before-event-handling)) 
-  ;; 
-  ;; 3.  After a display-finish-output.  You get these by doing a
-  ;; display-finish-output.  A cliche using this might have a with-display
-  ;; wrapped around the display operations that possibly cause an asynchronous
-  ;; error, with a display-finish-output right the end of the with-display to
-  ;; catch any asynchronous errors.  This is enabled by
-  ;;       (setf (xlib:display-report-asynchronous-errors display)
-  ;;             '(:after-finish-output))
-  ;; 
-  ;; You can select any combination of the three keywords.  For example, to
-  ;; get errors reported before event handling and after finish-output,
-  ;;       (setf (xlib:display-report-asynchronous-errors display)
-  ;;             '(:before-event-handling :after-finish-output))
-  (declare (type list when))
-  )
-
-(defmacro define-condition (name base &body items)
-  ;; just a place-holder here for the real thing
-  )
-
-(define-condition request-error error
-  display
-  major
-  minor
-  sequence
-  current-sequence
-  asynchronous)
-
-(defun default-error-handler (display error-key &key &allow-other-keys)
-  ;; The default display-error-handler.
-  ;; It signals the conditions listed below.
-  (declare (type display display)
-	   (type symbol error-key))
-  )
-
-(define-condition resource-error request-error
-  resource-id)
-
-(define-condition access-error request-error)
-
-(define-condition alloc-error request-error)
-
-(define-condition atom-error request-error
-  atom-id)
-
-(define-condition colormap-error resource-error)
-
-(define-condition cursor-error resource-error)
-
-(define-condition drawable-error resource-error)
-
-(define-condition font-error resource-error)
-
-(define-condition gcontext-error resource-error)
-
-(define-condition id-choice-error resource-error)
-
-(define-condition illegal-request-error request-error)
-
-(define-condition implementation-error request-error)
-
-(define-condition length-error request-error)
-
-(define-condition match-error request-error)
-
-(define-condition name-error request-error)
-
-(define-condition pixmap-error resource-error)
-
-(define-condition value-error request-error
-  value)
-
-(define-condition window-error resource-error)
-
-(defmacro with-display ((display) &body body)
-  ;; This macro is for use in a multi-process environment.  It provides exclusive
-  ;; access to the local display object for multiple request generation.  It need not
-  ;; provide immediate exclusive access for replies; that is, if another process is
-  ;; waiting for a reply (while not in a with-display), then synchronization need not
-  ;; (but can) occur immediately.  Except where noted, all routines effectively
-  ;; contain an implicit with-display where needed, so that correct synchronization
-  ;; is always provided at the interface level on a per-call basis.  Nested uses of
-  ;; this macro will work correctly.  This macro does not prevent concurrent event
-  ;; processing; see with-event-queue.
-  )
-
-(defun display-force-output (display)
-  ;; Output is normally buffered; this forces any buffered output.
-  (declare (type display display)))
-
-(defun display-finish-output (display)
-  ;; Forces output, then causes a round-trip to ensure that all possible errors and
-  ;; events have been received.
-  (declare (type display display)))
-
-(defun display-after-function (display)
-  ;; setf'able
-  ;; If defined, called after every protocol request is generated, even those inside
-  ;; explicit with-display's, but never called from inside the after-function itself.
-  ;; The function is called inside the effective with-display for the associated
-  ;; request.  Default value is nil.  Can be set, for example, to
-  ;; #'display-force-output or #'display-finish-output.
-  (declare (type display display)
-	   (clx-values (or null (function (display))))))
-
-(defun create-window (&key parent x y width height (depth 0) (border-width 0)
-		      (class :copy) (visual :copy)
-		      background border gravity bit-gravity
-		      backing-store backing-planes backing-pixel save-under
-		      event-mask do-not-propagate-mask override-redirect
-		      colormap cursor)
-  ;; Display is obtained from parent.  Only non-nil attributes are passed on in the
-  ;; request: the function makes no assumptions about what the actual protocol
-  ;; defaults are.  Width and height are the inside size, excluding border.
-  (declare (type window parent)
-	   (type int16 x y)
-	   (type card16 width height depth border-width)
-	   (type (member :copy :input-output :input-only) class)
-	   (type (or (member :copy) visual-info) visual)
-	   (type (or null (member :none :parent-relative) pixel pixmap) background)
-	   (type (or null (member :copy) pixel pixmap) border)
-	   (type (or null win-gravity) gravity)
-	   (type (or null bit-gravity) bit-gravity)
-	   (type (or null (member :not-useful :when-mapped :always) backing-store))
-	   (type (or null pixel) backing-planes backing-pixel)
-	   (type (or null event-mask) event-mask)
-	   (type (or null device-event-mask) do-not-propagate-mask)
-	   (type (or null (member :on :off)) save-under override-redirect)
-	   (type (or null (member :copy) colormap) colormap)
-	   (type (or null (member :none) cursor) cursor)
-	   (clx-values window)))
-
-(defun window-class (window)
-  (declare (type window window)
-	   (clx-values (member :input-output :input-only))))
-
-(defun window-visual-info (window)
-  (declare (type window window)
-	   (clx-values visual-info)))
-
-(defun window-visual (window)
-  (declare (type window window)
-	   (clx-values resource-id)))
-
-(defsetf window-background (window) (background)
-  (declare (type window window)
-	   (type (or (member :none :parent-relative) pixel pixmap) background)))
-
-(defsetf window-border (window) (border)
-  (declare (type window window)
-	   (type (or (member :copy) pixel pixmap) border)))
-
-(defun window-gravity (window)
-  ;; setf'able
-  (declare (type window window)
-	   (clx-values win-gravity)))
-
-(defun window-bit-gravity (window)
-  ;; setf'able
-  (declare (type window window)
-	   (clx-values bit-gravity)))
-
-(defun window-backing-store (window)
-  ;; setf'able
-  (declare (type window window)
-	   (clx-values (member :not-useful :when-mapped :always))))
-
-(defun window-backing-planes (window)
-  ;; setf'able
-  (declare (type window window)
-	   (clx-values pixel)))
-
-(defun window-backing-pixel (window)
-  ;; setf'able
-  (declare (type window window)
-	   (clx-values pixel)))
-
-(defun window-save-under (window)
-  ;; setf'able
-  (declare (type window window)
-	   (clx-values (member :on :off))))
-
-(defun window-event-mask (window)
-  ;; setf'able
-  (declare (type window window)
-	   (clx-values mask32)))
-
-(defun window-do-not-propagate-mask (window)
-  ;; setf'able
-  (declare (type window window)
-	   (clx-values mask32)))
-
-(defun window-override-redirect (window)
-  ;; setf'able
-  (declare (type window window)
-	   (clx-values (member :on :off))))
-
-(defun window-colormap (window)
-  (declare (type window window)
-	   (clx-values (or null colormap))))
-
-(defsetf window-colormap (window) (colormap)
-  (declare (type window window)
-	   (type (or (member :copy) colormap) colormap)))
-
-(defsetf window-cursor (window) (cursor)
-  (declare (type window window)
-	   (type (or (member :none) cursor) cursor)))
-
-(defun window-colormap-installed-p (window)
-  (declare (type window window)
-	   (clx-values boolean)))
-
-(defun window-all-event-masks (window)
-  (declare (type window window)
-	   (clx-values mask32)))
-
-(defun window-map-state (window)
-  (declare (type window window)
-	   (clx-values (member :unmapped :unviewable :viewable))))
-
-(defsetf drawable-x (window) (x)
-  (declare (type window window)
-	   (type int16 x)))
-
-(defsetf drawable-y (window) (y)
-  (declare (type window window)
-	   (type int16 y)))
-
-(defsetf drawable-width (window) (width)
-  ;; Inside width, excluding border.
-  (declare (type window window)
-	   (type card16 width)))
-
-(defsetf drawable-height (window) (height)
-  ;; Inside height, excluding border.
-  (declare (type window window)
-	   (type card16 height)))
-
-(defsetf drawable-border-width (window) (border-width)
-  (declare (type window window)
-	   (type card16 border-width)))
-
-(defsetf window-priority (window &optional sibling) (mode)
-  ;; A bit strange, but retains setf form.
-  (declare (type window window)
-	   (type (or null window) sibling)
-	   (type (member :above :below :top-if :bottom-if :opposite) mode)))
-
-(defmacro with-state ((drawable) &body body)
-  ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
-  ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and
-  ;; ConfigureWindow.  The body is not surrounded by a with-display.  Within the
-  ;; indefinite scope of the body, on a per-process basis in a multi-process
-  ;; environment, the first call within an Accessor Group on the specified drawable
-  ;; (the object, not just the variable) causes the complete results of the protocol
-  ;; request to be retained, and returned in any subsequent accessor calls.  Calls
-  ;; within a Setf Group are delayed, and executed in a single request on exit from
-  ;; the body.  In addition, if a call on a function within an Accessor Group follows
-  ;; a call on a function in the corresponding Setf Group, then all delayed setfs for
-  ;; that group are executed, any retained accessor information for that group is
-  ;; discarded, the corresponding protocol request is (re)issued, and the results are
-  ;; (again) retained, and returned in any subsequent accessor calls.
-
-  ;; Accessor Group A (for GetWindowAttributes):
-  ;; window-visual-info, window-visual, window-class, window-gravity, window-bit-gravity,
-  ;; window-backing-store, window-backing-planes, window-backing-pixel,
-  ;; window-save-under, window-colormap, window-colormap-installed-p,
-  ;; window-map-state, window-all-event-masks, window-event-mask,
-  ;; window-do-not-propagate-mask, window-override-redirect
-
-  ;; Setf Group A (for ChangeWindowAttributes):
-  ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes,
-  ;; window-backing-pixel, window-save-under, window-event-mask,
-  ;; window-do-not-propagate-mask, window-override-redirect, window-colormap,
-  ;; window-cursor
-
-  ;; Accessor Group G (for GetGeometry):
-  ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width,
-  ;; drawable-height, drawable-border-width
-
-  ;; Setf Group G (for ConfigureWindow):
-  ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width,
-  ;; window-priority
-  )
-
-(defun destroy-window (window)
-  (declare (type window window)))
-
-(defun destroy-subwindows (window)
-  (declare (type window window)))
-
-(defun add-to-save-set (window)
-  (declare (type window window)))
-
-(defun remove-from-save-set (window)
-  (declare (type window window)))
-
-(defun reparent-window (window parent x y)
-  (declare (type window window parent)
-	   (type int16 x y)))
-
-(defun map-window (window)
-  (declare (type window window)))
-
-(defun map-subwindows (window)
-  (declare (type window window)))
-
-(defun unmap-window (window)
-  (declare (type window window)))
-
-(defun unmap-subwindows (window)
-  (declare (type window window)))
-
-(defun circulate-window-up (window)
-  (declare (type window window)))
-
-(defun circulate-window-down (window)
-  (declare (type window window)))
-
-(defun drawable-root (drawable)
-  (declare (type drawable drawable)
-	   (clx-values window)))
-
-(defun drawable-depth (drawable)
-  (declare (type drawable drawable)
-	   (clx-values card8)))
-
-(defun drawable-x (drawable)
-  (declare (type drawable drawable)
-	   (clx-values int16)))
-
-(defun drawable-y (drawable)
-  (declare (type drawable drawable)
-	   (clx-values int16)))
-
-(defun drawable-width (drawable)
-  ;; For windows, inside width, excluding border.
-  (declare (type drawable drawable)
-	   (clx-values card16)))
-
-(defun drawable-height (drawable)
-  ;; For windows, inside height, excluding border.
-  (declare (type drawable drawable)
-	   (clx-values card16)))
-
-(defun drawable-border-width (drawable)
-  (declare (type drawable drawable)
-	   (clx-values card16)))
-
-(defun query-tree (window &key (result-type 'list))
-  (declare (type window window)
-	   (type type result-type)
-	   (clx-values (clx-sequence window) parent root)))
-
-(defun change-property (window property data type format
-			&key (mode :replace) (start 0) end transform)
-  ;; Start and end affect sub-sequence extracted from data.
-  ;; Transform is applied to each extracted element.
-  (declare (type window window)
-	   (type xatom property type)
-	   (type (member 8 16 32) format)
-	   (type sequence data)
-	   (type (member :replace :prepend :append) mode)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type (or null (function (t) integer)) transform)))
-
-(defun delete-property (window property)
-  (declare (type window window)
-	   (type xatom property)))
-
-(defun get-property (window property
-		     &key type (start 0) end delete-p (result-type 'list) transform)
-  ;; Transform is applied to each integer retrieved.
-  ;; Nil is returned for type when the protocol returns None.
-  (declare (type window window)
-	   (type xatom property)
-	   (type (or null xatom) type)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type boolean delete-p)
-	   (type type result-type)
-	   (type (or null (function (integer) t)) transform)
-	   (clx-values data type format bytes-after)))
-
-(defun rotate-properties (window properties &optional (delta 1))
-  ;; Postive rotates left, negative rotates right (opposite of actual protocol request).
-  (declare (type window window)
-	   (type (clx-sequence xatom) properties)
-	   (type int16 delta)))
-
-(defun list-properties (window &key (result-type 'list))
-  (declare (type window window)
-	   (type type result-type)
-	   (clx-values (clx-sequence keyword))))
-
-;; Although atom-ids are not visible in the normal user interface, atom-ids might
-;; appear in window properties and other user data, so conversion hooks are needed.
-
-(defun intern-atom (display name)
-  (declare (type display display)
-	   (type xatom name)
-	   (clx-values resource-id)))
-
-(defun find-atom (display name)
-  (declare (type display display)
-	   (type xatom name)
-	   (clx-values (or null resource-id))))
-
-(defun atom-name (display atom-id)
-  (declare (type display display)
-	   (type resource-id atom-id)
-	   (clx-values keyword)))
-
-(defun selection-owner (display selection)
-  (declare (type display display)
-	   (type xatom selection)
-	   (clx-values (or null window))))
-
-(defsetf selection-owner (display selection &optional time) (owner)
-  ;; A bit strange, but retains setf form.
-  (declare (type display display)
-	   (type xatom selection)
-	   (type (or null window) owner)
-	   (type timestamp time)))
-
-(defun convert-selection (selection type requestor &optional property time)
-  (declare (type xatom selection type)
-	   (type window requestor)
-	   (type (or null xatom) property)
-	   (type timestamp time)))
-
-(defun send-event (window event-key event-mask &rest args
-		   &key propagate-p display &allow-other-keys)
-  ;; Additional arguments depend on event-key, and are as specified further below
-  ;; with declare-event, except that both resource-ids and resource objects are
-  ;; accepted in the event components.  The display argument is only required if the
-  ;; window is :pointer-window or :input-focus.  If an argument has synonyms, it is
-  ;; only necessary to supply a value for one of them; it is an error to specify
-  ;; different values for synonyms.
-  (declare (type (or window (member :pointer-window :input-focus)) window)
-	   (type (or null event-key) event-key)
-	   (type event-mask event-mask)
-	   (type boolean propagate-p)
-	   (type (or null display) display)))
-
-(defun grab-pointer (window event-mask
-		     &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time)
-  (declare (type window window)
-	   (type pointer-event-mask event-mask)
-	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
-	   (type (or null window) confine-to)
-	   (type (or null cursor) cursor)
-	   (type timestamp time)
-	   (clx-values grab-status)))
-
-(defun ungrab-pointer (display &key time)
-  (declare (type display display)
-	   (type timestamp time)))
-
-(defun grab-button (window button event-mask
-		    &key (modifiers 0)
-			 owner-p sync-pointer-p sync-keyboard-p confine-to cursor)
-  (declare (type window window)
-	   (type (or (member :any) card8) button)
-	   (type modifier-mask modifiers)
-	   (type pointer-event-mask event-mask)
-	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
-	   (type (or null window) confine-to)
-	   (type (or null cursor) cursor)))
-
-(defun ungrab-button (window button &key (modifiers 0))
-  (declare (type window window)
-	   (type (or (member :any) card8) button)
-	   (type modifier-mask modifiers)))
-
-(defun change-active-pointer-grab (display event-mask &optional cursor time)
-  (declare (type display display)
-	   (type pointer-event-mask event-mask)
-	   (type (or null cursor) cursor)
-	   (type timestamp time)))
-
-(defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time)
-  (declare (type window window)
-	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
-	   (type timestamp time)
-	   (clx-values grab-status)))
-
-(defun ungrab-keyboard (display &key time)
-  (declare (type display display)
-	   (type timestamp time)))
-
-(defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p)
-  (declare (type window window)
-	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
-	   (type (or (member :any) card8) key)
-	   (type modifier-mask modifiers)))
-
-(defun ungrab-key (window key &key (modifiers 0))
-  (declare (type window window)
-	   (type (or (member :any) card8) key)
-	   (type modifier-mask modifiers)))
-
-(defun allow-events (display mode &optional time)
-  (declare (type display display)
-	   (type (member :async-pointer :sync-pointer :reply-pointer
-			 :async-keyboard :sync-keyboard :replay-keyboard
-			 :async-both :sync-both)
-		 mode)
-	   (type timestamp time)))
-
-(defun grab-server (display)
-  (declare (type display display)))
-
-(defun ungrab-server (display)
-  (declare (type display display)))
-
-(defmacro with-server-grabbed ((display) &body body)
-  ;; The body is not surrounded by a with-display.
-  )
-
-(defun query-pointer (window)
-  (declare (type window window)
-	   (clx-values x y same-screen-p child mask root-x root-y root)))
-
-(defun pointer-position (window)
-  (declare (type window window)
-	   (clx-values x y same-screen-p)))
-
-(defun global-pointer-position (display)
-  (declare (type display display)
-	   (clx-values root-x root-y root)))
-
-(defun motion-events (window &key start stop (result-type 'list))
-  (declare (type window window)
-	   (type timestamp start stop)
-	   (type type result-type)
-	   (clx-values (repeat-seq (int16 x) (int16 y) (timestamp time)))))
-
-(defun translate-coordinates (src src-x src-y dst)
-  ;; If src and dst are not on the same screen, nil is returned.
-  (declare (type window src)
-	   (type int16 src-x src-y)
-	   (type window dst)
-	   (clx-values dst-x dst-y child)))
-
-(defun warp-pointer (dst dst-x dst-y)
-  (declare (type window dst)
-	   (type int16 dst-x dst-y)))
-
-(defun warp-pointer-relative (display x-off y-off)
-  (declare (type display display)
-	   (type int16 x-off y-off)))
-
-(defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y
-			       &optional src-width src-height)
-  ;; Passing in a zero src-width or src-height is a no-op.  A null src-width or
-  ;; src-height translates into a zero value in the protocol request.
-  (declare (type window dst src)
-	   (type int16 dst-x dst-y src-x src-y)
-	   (type (or null card16) src-width src-height)))
-
-(defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y
-					&optional src-width src-height)
-  ;; Passing in a zero src-width or src-height is a no-op.  A null src-width or
-  ;; src-height translates into a zero value in the protocol request.
-  (declare (type window src)
-	   (type int16 x-off y-off src-x src-y)
-	   (type (or null card16) src-width src-height)))
-
-(defun set-input-focus (display focus revert-to &optional time)
-  ;; Setf ought to allow multiple values.
-  (declare (type display display)
-	   (type (or (member :none :pointer-root) window) focus)
-	   (type (member :none :parent :pointer-root) revert-to)
-	   (type timestamp time)))
-
-(defun input-focus (display)
-  (declare (type display display)
-	   (clx-values focus revert-to)))
-
-(defun query-keymap (display)
-  (declare (type display display)
-	   (clx-values (bit-vector 256))))
-
-(defun open-font (display name)
-  ;; Font objects may be cached and reference counted locally within the display
-  ;; object.  This function might not execute a with-display if the font is cached.
-  ;; The protocol QueryFont request happens on-demand under the covers.
-  (declare (type display display)
-	   (type stringable name)
-	   (clx-values font)))
-
-;; We probably want a per-font bit to indicate whether caching on
-;; text-extents/width calls is desirable.  But what to name it?
-
-(defun discard-font-info (font)
-  ;; Discards any state that can be re-obtained with QueryFont.  This is simply
-  ;; a performance hint for memory-limited systems.
-  (declare (type font font)))
-
-;; This can be signalled anywhere a pseudo font access fails.
-
-(define-condition invalid-font error
-  font)
-
-;; Note: font-font-info removed.
-
-(defun font-name (font)
-  ;; Returns nil for a pseudo font returned by gcontext-font.
-  (declare (type font font)
-	   (clx-values (or null string))))
-
-(defun font-direction (font)
-  (declare (type font font)
-	   (clx-values draw-direction)))
-
-(defun font-min-char (font)
-  (declare (type font font)
-	   (clx-values card16)))
-
-(defun font-max-char (font)
-  (declare (type font font)
-	   (clx-values card16)))
-
-(defun font-min-byte1 (font)
-  (declare (type font font)
-	   (clx-values card8)))
-
-(defun font-max-byte1 (font)
-  (declare (type font font)
-	   (clx-values card8)))
-
-(defun font-min-byte2 (font)
-  (declare (type font font)
-	   (clx-values card8)))
-
-(defun font-max-byte2 (font)
-  (declare (type font font)
-	   (clx-values card8)))
-
-(defun font-all-chars-exist-p (font)
-  (declare (type font font)
-	   (clx-values boolean)))
-
-(defun font-default-char (font)
-  (declare (type font font)
-	   (clx-values card16)))
-
-(defun font-ascent (font)
-  (declare (type font font)
-	   (clx-values int16)))
-
-(defun font-descent (font)
-  (declare (type font font)
-	   (clx-values int16)))
-
-;; The list contains alternating keywords and int32s.
-
-(deftype font-props () 'list)
-
-(defun font-properties (font)
-  (declare (type font font)
-	   (clx-values font-props)))
-
-(defun font-property (font name)
-  (declare (type font font)
-	   (type keyword name)
-	   (clx-values (or null int32))))
-
-;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
-
-(defun char-<metric> (font index)
-  ;; Note: I have tentatively chosen to return nil for an out-of-bounds index
-  ;; (or an in-bounds index on a pseudo font), although returning zero or
-  ;; signalling might be better.
-  (declare (type font font)
-	   (type card16 index)
-	   (clx-values (or null int16))))
-
-(defun max-char-<metric> (font)
-  ;; Note: I have tentatively chosen separate accessors over allowing :min and
-  ;; :max as an index above.
-  (declare (type font font)
-	   (clx-values int16)))
-
-(defun min-char-<metric> (font)
-  (declare (type font font)
-	   (clx-values int16)))
-
-;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
-
-(defun close-font (font)
-  ;; This might not generate a protocol request if the font is reference
-  ;; counted locally or if it is a pseudo font.
-  (declare (type font font)))
-
-(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
-  (declare (type display display)
-	   (type string pattern)
-	   (type card16 max-fonts)
-	   (type type result-type)
-	   (clx-values (clx-sequence string))))
-
-(defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
-  ;; Returns "pseudo" fonts that contain basic font metrics and properties, but
-  ;; no per-character metrics and no resource-ids.  These pseudo fonts will be
-  ;; converted (internally) to real fonts dynamically as needed, by issuing an
-  ;; OpenFont request.  However, the OpenFont might fail, in which case the
-  ;; invalid-font error can arise.
-  (declare (type display display)
-	   (type string pattern)
-	   (type card16 max-fonts)
-	   (type type result-type)
-	   (clx-values (clx-sequence font))))
-
-(defun font-path (display &key (result-type 'list))
-  (declare (type display display)
-	   (type type result-type)
-	   (clx-values (clx-sequence (or string pathname)))))
-
-(defsetf font-path (display) (paths)
-  (declare (type display display)
-	   (type (clx-sequence (or string pathname)) paths)))
-
-(defun create-pixmap (&key width height depth drawable)
-  (declare (type card16 width height)
-	   (type card8 depth)
-	   (type drawable drawable)
-	   (clx-values pixmap)))
-
-(defun free-pixmap (pixmap)
-  (declare (type pixmap pixmap)))
-
-(defun create-gcontext (&key drawable function plane-mask foreground background
-			     line-width line-style cap-style join-style fill-style fill-rule
-			     arc-mode tile stipple ts-x ts-y font subwindow-mode
-			     exposures clip-x clip-y clip-mask clip-ordering
-			     dash-offset dashes
-			     (cache-p t))
-  ;; Only non-nil components are passed on in the request, but for effective caching
-  ;; assumptions have to be made about what the actual protocol defaults are.  For
-  ;; all gcontext components, a value of nil causes the default gcontext value to be
-  ;; used.  For clip-mask, this implies that an empty rect-seq cannot be represented
-  ;; as a list.  Note:  use of stringable as font will cause an implicit open-font.
-  ;; Note:  papers over protocol SetClipRectangles and SetDashes special cases.  If
-  ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext
-  ;; component will have no effect unless the new value differs from the cached
-  ;; value.  Component changes (setfs and with-gcontext) are always deferred
-  ;; regardless of the cache mode, and sent over the protocol only when required by a
-  ;; local operation or by an explicit call to force-gcontext-changes.
-  (declare (type drawable drawable)
-	   (type (or null boole-constant) function)
-	   (type (or null pixel) plane-mask foreground background)
-	   (type (or null card16) line-width dash-offset)
-	   (type (or null int16) ts-x ts-y clip-x clip-y)
-	   (type (or null (member :solid :dash :double-dash)) line-style)
-	   (type (or null (member :not-last :butt :round :projecting)) cap-style)
-	   (type (or null (member :miter :round :bevel)) join-style)
-	   (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style)
-	   (type (or null (member :even-odd :winding)) fill-rule)
-	   (type (or null (member :chord :pie-slice)) arc-mode)
-	   (type (or null pixmap) tile stipple)
-	   (type (or null fontable) font)
-	   (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode)
-	   (type (or null (member :on :off)) exposures)
-	   (type (or null (member :none) pixmap rect-seq) clip-mask)
-	   (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
-	   (type (or null (or card8 (clx-sequence card8))) dashes)
-	   (type boolean cache)
-	   (clx-values gcontext)))
-
-;; For each argument to create-gcontext (except font, clip-mask and
-;; clip-ordering) declared as (type <type> <name>), there is an accessor:
-
-(defun gcontext-<name> (gcontext)
-  ;; The value will be nil if the last value stored is unknown (e.g., the cache was
-  ;; off, or the component was copied from a gcontext with unknown state).
-  (declare (type gcontext gcontext)
-	   (clx-values <type>)))
-
-;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
-;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor:
-
-(defsetf gcontext-<name> (gcontext) (value)
-  (declare (type gcontext gcontext)
-	   (type <type> value)))
-
-(defun gcontext-font (gcontext &optional metrics-p)
-  ;; If the stored font is known, it is returned.  If it is not known and
-  ;; metrics-p is false, then nil is returned.  If it is not known and
-  ;; metrics-p is true, then a pseudo font is returned.  Full metric and
-  ;; property information can be obtained, but the font does not have a name or
-  ;; a resource-id, and attempts to use it where a resource-id is required will
-  ;; result in an invalid-font error.
-  (declare (type gcontext gcontext)
-	   (type boolean metrics-p)
-	   (clx-values (or null font))))
-
-(defun gcontext-clip-mask (gcontext)
-  (declare (type gcontext gcontext)
-	   (clx-values (or null (member :none) pixmap rect-seq)
-		   (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))))
-
-(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask)
-  ;; Is nil illegal here, or is it transformed to a vector?
-  ;; A bit strange, but retains setf form.
-  (declare (type gcontext gcontext)
-	   (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
-	   (type (or (member :none) pixmap rect-seq) clip-mask)))
-
-(defun force-gcontext-changes (gcontext)
-  ;; Force any delayed changes.
-  (declare (type gcontext gcontext)))
-
-(defmacro with-gcontext ((gcontext &key
-			  function plane-mask foreground background
-			  line-width line-style cap-style join-style fill-style fill-rule
-			  arc-mode tile stipple ts-x ts-y font subwindow-mode
-			  exposures clip-x clip-y clip-mask clip-ordering
-			  dashes dash-offset)
-			 &body body)
-  ;; Changes gcontext components within the dynamic scope of the body (i.e.,
-  ;; indefinite scope and dynamic extent), on a per-process basis in a multi-process
-  ;; environment.  The values are all evaluated before bindings are performed.  The
-  ;; body is not surrounded by a with-display.  If cache-p is nil or the some
-  ;; component states are unknown, this will implement save/restore by creating a
-  ;; temporary gcontext and doing gcontext-components to and from it.
-  )
-
-(defun copy-gcontext-components (src dst &rest keys)
-  (declare (type gcontext src dst)
-	   (type (clx-list gcontext-key) keys)))
-
-(defun copy-gcontext (src dst)
-  (declare (type gcontext src dst))
-  ;; Copies all components.
-  )
-	   
-(defun free-gcontext (gcontext)
-  (declare (type gcontext gcontext)))
-
-(defun clear-area (window &key (x 0) (y 0) width height exposures-p)
-  ;; Passing in a zero width or height is a no-op.  A null width or height translates
-  ;; into a zero value in the protocol request.
-  (declare (type window window)
-	   (type int16 x y)
-	   (type (or null card16) width height)
-	   (type boolean exposures-p)))
-
-(defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y)
-  (declare (type drawable src dst)
-	   (type gcontext gcontext)
-	   (type int16 src-x src-y dst-x dst-y)
-	   (type card16 width height)))
-
-(defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y)
-  (declare (type drawable src dst)
-	   (type gcontext gcontext)
-	   (type pixel plane)
-	   (type int16 src-x src-y dst-x dst-y)
-	   (type card16 width height)))
-
-(defun draw-point (drawable gcontext x y)
-  ;; Should be clever about appending to existing buffered protocol request, provided
-  ;; gcontext has not been modified.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)))
-
-(defun draw-points (drawable gcontext points &optional relative-p)
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type point-seq points)
-	   (type boolean relative-p)))
-
-(defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p)
-  ;; Should be clever about appending to existing buffered protocol request, provided
-  ;; gcontext has not been modified.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x1 y1 x2 y2)
-	   (type boolean relative-p)))
-
-(defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex))
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type point-seq points)
-	   (type boolean relative-p fill-p)
-	   (type (member :complex :non-convex :convex) shape)))
-
-(defun draw-segments (drawable gcontext segments)
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type seg-seq segments)))
-
-(defun draw-rectangle (drawable gcontext x y width height &optional fill-p)
-  ;; Should be clever about appending to existing buffered protocol request, provided
-  ;; gcontext has not been modified.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type boolean fill-p)))
-
-(defun draw-rectangles (drawable gcontext rectangles &optional fill-p)
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type rect-seq rectangles)
-	   (type boolean fill-p)))
-
-(defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p)
-  ;; Should be clever about appending to existing buffered protocol request, provided
-  ;; gcontext has not been modified.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type angle angle1 angle2)
-	   (type boolean fill-p)))
-
-(defun draw-arcs (drawable gcontext arcs &optional fill-p)
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type arc-seq arcs)
-	   (type boolean fill-p)))
-
-;; The following image routines are bare minimum.  It may be useful to define some
-;; form of "image" object to hide representation details and format conversions.  It
-;; also may be useful to provide stream-oriented interfaces for reading and writing
-;; the data.
-
-(defun put-raw-image (drawable gcontext data
-		      &key (start 0) depth x y width height (left-pad 0) format)
-  ;; Data must be a sequence of 8-bit quantities, already in the appropriate format
-  ;; for transmission; the caller is responsible for all byte and bit swapping and
-  ;; compaction.  Start is the starting index in data; the end is computed from the
-  ;; other arguments.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type (clx-sequence card8) data)
-	   (type array-index start)
-	   (type card8 depth left-pad)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type (member :bitmap :xy-pixmap :z-pixmap) format)))
-
-(defun get-raw-image (drawable &key data (start 0) x y width height
-				    (plane-mask 0xffffffff) format
-				    (result-type '(vector (unsigned-byte 8))))
-  ;; If data is given, it is modified in place (and returned), otherwise a new
-  ;; sequence is created and returned, with a size computed from the other arguments
-  ;; and the returned depth.  The sequence is filled with 8-bit quantities, in
-  ;; transmission format; the caller is responsible for any byte and bit swapping and
-  ;; compaction required for further local use.
-  (declare (type drawable drawable)
-	   (type (or null (clx-sequence card8)) data)
-	   (type array-index start)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type pixel plane-mask)
-	   (type (member :xy-pixmap :z-pixmap) format)
-	   (clx-values (clx-sequence card8) depth visual-info)))
-
-(defun translate-default (src src-start src-end font dst dst-start)
-  ;; dst is guaranteed to have room for (- src-end src-start) integer elements,
-  ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends
-  ;; on context.  font is the current font, if known.  The function should
-  ;; translate as many elements of src as possible into indexes in the current
-  ;; font, and store them into dst.  The first return value should be the src
-  ;; index of the first untranslated element.  If no further elements need to
-  ;; be translated, the second return value should be nil.  If a horizontal
-  ;; motion is required before further translation, the second return value
-  ;; should be the delta in x coordinate.  If a font change is required for
-  ;; further translation, the second return value should be the new font.  If
-  ;; known, the pixel width of the translated text can be returned as the third
-  ;; value; this can allow for appending of subsequent output to the same
-  ;; protocol request, if no overall width has been specified at the higher
-  ;; level.
-  (declare (type sequence src)
-	   (type array-index src-start src-end dst-start)
-	   (type (or null font) font)
-	   (type vector dst)
-	   (clx-values array-index (or null int16 font) (or null int32))))
-
-;; There is a question below of whether translate should always be required, or
-;; if not, what the default should be or where it should come from.  For
-;; example, the default could be something that expected a string as src and
-;; translated the CL standard character set to ASCII indexes, and ignored fonts
-;; and bits.  Or the default could expect a string but otherwise be "system
-;; dependent".  Or the default could be something that expected a vector of
-;; integers and did no translation.  Or the default could come from the
-;; gcontext (but what about text-extents and text-width?).
-
-(defun text-extents (font sequence &key (start 0) end translate)
-  ;; If multiple fonts are involved, font-ascent and font-descent will be the
-  ;; maximums.  If multiple directions are involved, the direction will be nil.
-  ;; Translate will always be called with a 16-bit dst buffer.
-  (declare (type sequence sequence)
-	   (type (or font gcontext) font)
-	   (type translate translate)
-	   (clx-values width ascent descent left right font-ascent font-descent direction
-		   (or null array-index))))
-
-(defun text-width (font sequence &key (start 0) end translate)
-  ;; Translate will always be called with a 16-bit dst buffer.
-  (declare (type sequence sequence)
-	   (type (or font gcontext) font)
-	   (type translate translate)
-	   (clx-values int32 (or null array-index))))
-
-;; This controls the element size of the dst buffer given to translate.  If
-;; :default is specified, the size will be based on the current font, if known,
-;; and otherwise 16 will be used.  [An alternative would be to pass the buffer
-;; size to translate, and allow it to return the desired size if it doesn't
-;; like the current size.  The problem is that the protocol doesn't allow
-;; switching within a single request, so to allow switching would require
-;; knowing the width of text, which isn't necessarily known.  We could call
-;; text-width to compute it, but perhaps that is doing too many favors?]  [An
-;; additional possibility is to allow an index-size of :two-byte, in which case
-;; translate would be given a double-length 8-bit array, and translate would be
-;; expected to store first-byte/second-byte instead of 16-bit integers.]
-
-(deftype index-size () '(member :default 8 16))
-
-;; In the glyph functions below, if width is specified, it is assumed to be the
-;; total pixel width of whatever string of glyphs is actually drawn.
-;; Specifying width will allow for appending the output of subsequent calls to
-;; the same protocol request, provided gcontext has not been modified in the
-;; interim.  If width is not specified, appending of subsequent output might
-;; not occur (unless translate returns the width).  Specifying width is simply
-;; a hint, for performance.
-
-(defun draw-glyph (drawable gcontext x y elt
-		   &key translate width (size :default))
-  ;; Returns true if elt is output, nil if translate refuses to output it.
-  ;; Second result is width, if known.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type translate translate)
-	   (type (or null int32) width)
-	   (type index-size size)
-	   (clx-values boolean (or null int32))))
-
-(defun draw-glyphs (drawable gcontext x y sequence
-		    &key (start 0) end translate width (size :default))
-  ;; First result is new start, if end was not reached.  Second result is
-  ;; overall width, if known.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type sequence sequence)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type (or null int32) width)
-	   (type translate translate)
-	   (type index-size size)
-	   (clx-values (or null array-index) (or null int32))))
-
-(defun draw-image-glyph (drawable gcontext x y elt
-			 &key translate width (size :default))
-  ;; Returns true if elt is output, nil if translate refuses to output it.
-  ;; Second result is overall width, if known.  An initial font change is
-  ;; allowed from translate.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type translate translate)
-	   (type (or null int32) width)
-	   (type index-size size)
-	   (clx-values boolean (or null int32))))
-
-(defun draw-image-glyphs (drawable gcontext x y sequence
-			  &key (start 0) end width translate (size :default))
-  ;; An initial font change is allowed from translate, but any subsequent font
-  ;; change or horizontal motion will cause termination (because the protocol
-  ;; doesn't support chaining).  [Alternatively, font changes could be accepted
-  ;; as long as they are accompanied with a width return value, or always
-  ;; accept font changes and call text-width as required.  However, horizontal
-  ;; motion can't really be accepted, due to semantics.]  First result is new
-  ;; start, if end was not reached.  Second result is overall width, if known.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type sequence sequence)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type (or null int32) width)
-	   (type translate translate)
-	   (type index-size size)
-	   (clx-values (or null array-index) (or null int32))))
-
-(defun create-colormap (visual window &optional alloc-p)
-  (declare (type visual-info visual)
-	   (type window window)
-	   (type boolean alloc-p)
-	   (clx-values colormap)))
-
-(defun free-colormap (colormap)
-  (declare (type colormap colormap)))
-
-(defun copy-colormap-and-free (colormap)
-  (declare (type colormap colormap)
-	   (clx-values colormap)))
-
-(defun install-colormap (colormap)
-  (declare (type colormap colormap)))
-
-(defun uninstall-colormap (colormap)
-  (declare (type colormap colormap)))
-
-(defun installed-colormaps (window &key (result-type 'list))
-  (declare (type window window)
-	   (type type result-type)
-	   (clx-values (clx-sequence colormap))))
-
-(defun alloc-color (colormap color)
-  (declare (type colormap colormap)
-	   (type (or stringable color) color)
-	   (clx-values pixel screen-color exact-color)))
-
-(defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list))
-  (declare (type colormap colormap)
-	   (type card16 colors planes)
-	   (type boolean contiguous-p)
-	   (type type result-type)
-	   (clx-values (clx-sequence pixel) (clx-sequence mask))))
-
-(defun alloc-color-planes (colormap colors
-			   &key (reds 0) (greens 0) (blues 0)
-				contiguous-p (result-type 'list))
-  (declare (type colormap colormap)
-	   (type card16 colors reds greens blues)
-	   (type boolean contiguous-p)
-	   (type type result-type)
-	   (clx-values (clx-sequence pixel) red-mask green-mask blue-mask)))
-
-(defun free-colors (colormap pixels &optional (plane-mask 0))
-  (declare (type colormap colormap)
-	   (type (clx-sequence pixel) pixels)
-	   (type pixel plane-mask)))
-
-(defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t))
-  (declare (type colormap colormap)
-	   (type pixel pixel)
-	   (type (or stringable color) spec)
-	   (type boolean red-p green-p blue-p)))
-
-(defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t))
-  ;; If stringables are specified for colors, it is unspecified whether all
-  ;; stringables are first resolved and then a single StoreColors protocol request is
-  ;; issued, or whether multiple StoreColors protocol requests are issued.
-  (declare (type colormap colormap)
-	   (type (repeat-seq (pixel pixel) ((or stringable color) color)) specs)
-	   (type boolean red-p green-p blue-p)))
-
-(defun query-colors (colormap pixels &key (result-type 'list))
-  (declare (type colormap colormap)
-	   (type (clx-sequence pixel) pixels)
-	   (type type result-type)
-	   (clx-values (clx-sequence color))))
-
-(defun lookup-color (colormap name)
-  (declare (type colormap colormap)
-	   (type stringable name)
-	   (clx-values screen-color true-color)))
-
-(defun create-cursor (&key source mask x y foreground background)
-  (declare (type pixmap source)
-	   (type (or null pixmap) mask)
-	   (type card16 x y)
-	   (type color foreground background)
-	   (clx-values cursor)))
-
-(defun create-glyph-cursor (&key source-font source-char mask-font mask-char
-				 foreground background)
-  (declare (type font source-font)
-	   (type card16 source-char)
-	   (type (or null font) mask-font)
-	   (type (or null card16) mask-char)
-	   (type color foreground background)
-	   (clx-values cursor)))
-
-(defun free-cursor (cursor)
-  (declare (type cursor cursor)))
-
-(defun recolor-cursor (cursor foreground background)
-  (declare (type cursor cursor)
-	   (type color foreground background)))
-
-(defun query-best-cursor (width height drawable)
-  (declare (type card16 width height)
-	   (type drawable display)
-	   (clx-values width height)))
-
-(defun query-best-tile (width height drawable)
-  (declare (type card16 width height)
-	   (type drawable drawable)
-	   (clx-values width height)))
-
-(defun query-best-stipple (width height drawable)
-  (declare (type card16 width height)
-	   (type drawable drawable)
-	   (clx-values width height)))
-
-(defun query-extension (display name)
-  (declare (type display display)
-	   (type stringable name)
-	   (clx-values major-opcode first-event first-error)))
-
-(defun list-extensions (display &key (result-type 'list))
-  (declare (type display display)
-	   (type type result-type)
-	   (clx-values (clx-sequence string))))
-
-;; Should pointer-mapping setf be changed to set-pointer-mapping?
-
-(defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5)
-  ;; Can signal device-busy.
-  ;; Setf ought to allow multiple values.
-  ;; Returns true for success, nil for failure
-  (declare (type display display)
-	   (type (clx-sequence card8) shift lock control mod1 mod2 mod3 mod4 mod5)
-	   (clx-values (member :success :busy :failed))))
-
-(defun modifier-mapping (display)
-  ;; each value is a list of card8s
-  (declare (type display display)
-	   (clx-values shift lock control mod1 mod2 mod3 mod4 mod5)))
-
-;; Either we will want lots of defconstants for well-known values, or perhaps
-;; an integer-to-keyword translation function for well-known values.
-
-(defun change-keyboard-mapping (display keysyms
-				&key (start 0) end (first-keycode start))
-  ;; start/end give subrange of keysyms
-  ;; first-keycode is the first-keycode to store at
-  (declare (type display display)
-	   (type (array * (* *)) keysyms)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type card8 first-keycode)))
-
-(defun keyboard-mapping (display &key first-keycode start end data)
-  ;; First-keycode specifies which keycode to start at (defaults to
-  ;; min-keycode).  Start specifies where (in result) to put first-keycode
-  ;; (defaults to first-keycode).  (- end start) is the number of keycodes to
-  ;; get (end defaults to (1+ max-keycode)).  If data is specified, the results
-  ;; are put there.
-  (declare (type display display)
-	   (type (or null card8) first-keycode)
-	   (type (or null array-index) start end)
-	   (type (or null (array * (* *))) data)
-	   (clx-values (array * (* *)))))
-
-(defun change-keyboard-control (display &key key-click-percent
-				bell-percent bell-pitch bell-duration
-				led led-mode key auto-repeat-mode)
-  (declare (type display display)
-	   (type (or null (member :default) int16) key-click-percent
-						   bell-percent bell-pitch bell-duration)
-	   (type (or null card8) led key)
-	   (type (or null (member :on :off)) led-mode)
-	   (type (or null (member :on :off :default)) auto-repeat-mode)))
-
-(defun keyboard-control (display)
-  (declare (type display display)
-	   (clx-values key-click-percent bell-percent bell-pitch bell-duration
-		   led-mask global-auto-repeat auto-repeats)))
-
-(defun bell (display &optional (percent-from-normal 0))
-  ;; It is assumed that an eventual audio extension to X will provide more complete
-  ;; control.
-  (declare (type display display)
-	   (type int8 percent-from-normal)))
-
-(defun pointer-mapping (display &key (result-type 'list))
-  (declare (type display display)
-	   (type type result-type)
-	   (clx-values (clx-sequence card8))))
-
-(defsetf pointer-mapping (display) (map)
-  ;; Can signal device-busy.
-  (declare (type display display)
-	   (type (clx-sequence card8) map)))
-
-(defun change-pointer-control (display &key acceleration threshold)
-  ;; Acceleration is rationalized if necessary.
-  (declare (type display display)
-	   (type (or null (member :default) number) acceleration)
-	   (type (or null (member :default) integer) threshold)))
-
-(defun pointer-control (display)
-  (declare (type display display)
-	   (clx-values acceleration threshold)))
-
-(defun set-screen-saver (display timeout interval blanking exposures)
-  ;; Setf ought to allow multiple values.
-  ;; Timeout and interval are in seconds, will be rounded to minutes.
-  (declare (type display display)
-	   (type (or (member :default) int16) timeout interval)
-	   (type (member :on :off :default) blanking exposures)))
-
-(defun screen-saver (display)
-  ;; Returns timeout and interval in seconds.
-  (declare (type display display)
-	   (clx-values timeout interval blanking exposures)))
-
-(defun activate-screen-saver (display)
-  (declare (type display display)))
-
-(defun reset-screen-saver (display)
-  (declare (type display display)))
-
-(defun add-access-host (display host)
-  ;; A string must be acceptable as a host, but otherwise the possible types for host
-  ;; are not constrained, and will likely be very system dependent.
-  (declare (type display display)))
-
-(defun remove-access-host (display host)
-  ;; A string must be acceptable as a host, but otherwise the possible types for host
-  ;; are not constrained, and will likely be very system dependent.
-  (declare (type display display)))
-
-(defun access-hosts (display &key (result-type 'list))
-  ;; The type of host objects returned is not constrained, except that the hosts must
-  ;; be acceptable to add-access-host and remove-access-host.
-  (declare (type display display)
-	   (type type result-type)
-	   (clx-values (clx-sequence host) enabled-p)))
-
-(defun access-control (display)
-  ;; setf'able
-  (declare (type display display)
-	   (clx-values boolean)))
-
-(defun close-down-mode (display)
-  ;; setf'able
-  ;; Cached locally in display object.
-  (declare (type display display)
-	   (clx-values (member :destroy :retain-permanent :retain-temporary))))
-
-(defun kill-client (display resource-id)
-  (declare (type display display)
-	   (type resource-id resource-id)))
-
-(defun kill-temporary-clients (display)
-  (declare (type display display)))
-
-(defun make-event-mask (&rest keys)
-  ;; This is only defined for core events.
-  ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
-  (declare (type (clx-list event-mask-class) keys)
-	   (clx-values mask32)))
-
-(defun make-event-keys (event-mask)
-  ;; This is only defined for core events.
-  (declare (type mask32 event-mask)
-	   (clx-values (clx-list event-mask-class))))
-
-(defun make-state-mask (&rest keys)
-  ;; Useful for constructing modifier-mask, state-mask.
-  (declare (type (clx-list state-mask-key) keys)
-	   (clx-values mask16)))
-
-(defun make-state-keys (state-mask)
-  (declare (type mask16 mask)
-	   (clx-values (clx-list state-mask-key))))
-
-(defmacro with-event-queue ((display) &body body)
-  ;; Grants exclusive access to event queue.
-  )
-
-(defun event-listen (display &optional (timeout 0))
-  (declare (type display display)
-	   (type (or null number) timeout)
-	   (clx-values (or null number) (or null (member :timeout) (not null))))
-  ;; Returns the number of events queued locally, if any, else nil.  Hangs
-  ;; waiting for events, forever if timeout is nil, else for the specified
-  ;; number of seconds.  The second value returned is :timeout if the
-  ;; operation timed out, and some other non-nil value if an EOF has been
-  ;; detected.
-  )
-
-(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t))
-  ;; If force-output-p is true, first invokes display-force-output.  Invokes
-  ;; handler on each queued event until handler returns non-nil, and that
-  ;; returned object is then returned by process-event.  If peek-p is true,
-  ;; then the event is not removed from the queue.  If discard-p is true, then
-  ;; events for which handler returns nil are removed from the queue,
-  ;; otherwise they are left in place.  Hangs until non-nil is generated for
-  ;; some event, or for the specified timeout (in seconds, if given); however,
-  ;; it is acceptable for an implementation to wait only once on network data,
-  ;; and therefore timeout prematurely.  Returns nil on timeout or EOF, with a
-  ;; second return value being :timeout for a timeout and some other non-nil
-  ;; value for EOF.  If handler is a sequence, it is expected to contain
-  ;; handler functions specific to each event class; the event code is used to
-  ;; index the sequence, fetching the appropriate handler.  The arguments to
-  ;; the handler are described further below using declare-event.  If
-  ;; process-event is invoked recursively, the nested invocation begins with
-  ;; the event after the one currently being processed.
-  (declare (type display display)
-	   (type (or (clx-sequence (function (&key &allow-other-keys) t))
-		     (function (&key &allow-other-keys) t))
-		 handler)
-	   (type (or null number) timeout)
-	   (type boolean peek-p)))
-
-(defun make-event-handlers (&key (type 'array) default)
-  (declare (type t type)			;Sequence type specifier
-	   (type function default)
-	   (clx-values sequence))			;Default handler for initial content
-  ;; Makes a handler sequence suitable for process-event
-  )
-   
-(defun event-handler (handlers event-key)
-  (declare (type sequence handlers)
-	   (type event-key event-key)
-	   (clx-values function))
-  ;; Accessor for a handler sequence
-  )
-
-(defsetf event-handler (handlers event-key) (handler)
-  (declare (type sequence handlers)
-	   (type event-key event-key)
-	   (type function handler)
-	   (clx-values function))
-  ;; Setf accessor for a handler sequence
-  )
-
-(defmacro event-case ((display &key timeout peek-p discard-p (force-output-p t))
-		      &body clauses)
-  (declare (arglist (display &key timeout peek-p discard-p force-output-p)
-		    (event-or-events ((&rest args) |...|) &body body) |...|))
-  ;; If force-output-p is true, first invokes display-force-output.  Executes
-  ;; the matching clause for each queued event until a clause returns non-nil,
-  ;; and that returned object is then returned by event-case.  If peek-p is
-  ;; true, then the event is not removed from the queue.  If discard-p is
-  ;; true, then events for which the clause returns nil are removed from the
-  ;; queue, otherwise they are left in place.  Hangs until non-nil is
-  ;; generated for some event, or for the specified timeout (in seconds, if
-  ;; given); however, it is acceptable for an implementation to wait only once
-  ;; on network data, and therefore timeout prematurely.  Returns nil on
-  ;; timeout or EOF with a second return value being :timeout for a timeout
-  ;; and some other non-nil value for EOF.  In each clause, event-or-events is
-  ;; an event-key or a list of event-keys (but they need not be typed as
-  ;; keywords) or the symbol t or otherwise (but only in the last clause).
-  ;; The keys are not evaluated, and it is an error for the same key to appear
-  ;; in more than one clause.  Args is the list of event components of
-  ;; interest; corresponding values (if any) are bound to variables with these
-  ;; names (i.e., the args are variable names, not keywords, the keywords are
-  ;; derived from the variable names).  An arg can also be a (keyword var)
-  ;; form, as for keyword args in a lambda lists.  If no t/otherwise clause
-  ;; appears, it is equivalent to having one that returns nil.  If
-  ;; process-event is invoked recursively, the nested invocation begins with
-  ;; the event after the one currently being processed.
-  )
-
-(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t))
-		      &body clauses)
-  ;; The clauses of event-cond are of the form:
-  ;; (event-or-events binding-list test-form . body-forms)
-  ;;
-  ;; EVENT-OR-EVENTS	event-key or a list of event-keys (but they
-  ;;			need not be typed as keywords) or the symbol t
-  ;;			or otherwise (but only in the last clause).  If
-  ;;			no t/otherwise clause appears, it is equivalent
-  ;;			to having one that returns nil.  The keys are
-  ;;			not evaluated, and it is an error for the same
-  ;;			key to appear in more than one clause.
-  ;;
-  ;; BINDING-LIST	The list of event components of interest.
-  ;;			corresponding values (if any) are bound to
-  ;;			variables with these names (i.e., the binding-list
-  ;;			has variable names, not keywords, the keywords are
-  ;;			derived from the variable names).  An arg can also
-  ;;			be a (keyword var) form, as for keyword args in a
-  ;;			lambda list.
-  ;;
-  ;; The matching TEST-FORM for each queued event is executed until a
-  ;; clause's test-form returns non-nil.  Then the BODY-FORMS are
-  ;; evaluated, returning the (possibly multiple) values of the last
-  ;; form from event-cond.  If there are no body-forms then, if the
-  ;; test-form is non-nil, the value of the test-form is returned as a
-  ;; single value.
-  ;;
-  ;; Options:
-  ;; FORCE-OUTPUT-P	When true, first invoke display-force-output if no
-  ;;		  	input is pending.
-  ;;
-  ;; PEEK-P		When true, then the event is not removed from the queue.
-  ;;
-  ;; DISCARD-P		When true, then events for which the clause returns nil
-  ;; 			are removed from the queue, otherwise they are left in place.
-  ;;
-  ;; TIMEOUT		If NIL, hang until non-nil is generated for some event's
-  ;;			test-form. Otherwise return NIL after TIMEOUT seconds have
-  ;;			elapsed.  NIL is also returned whenever EOF is read.
-  ;;			Whenever NIL is returned a second value is returned which
-  ;;			is either :TIMEOUT if a timeout occurred or some other
-  ;;			non-NIL value if an EOF is detected.
-  ;;
-  (declare (arglist (display &key timeout peek-p discard-p force-output-p)
-		   (event-or-events (&rest args) test-form &body body) |...|))
-  )
-
-(defun discard-current-event (display)
-  (declare (type display display)
-	   (clx-values boolean))
-  ;; Discard the current event for DISPLAY.
-  ;; Returns NIL when the event queue is empty, else T.
-  ;; To ensure events aren't ignored, application code should only call
-  ;; this when throwing out of event-case or process-next-event, or from
-  ;; inside even-case, event-cond or process-event when :peek-p is T and
-  ;; :discard-p is NIL.
- )
-
-(defmacro declare-event (event-codes &rest declares)
-  ;; Used to indicate the keyword arguments for handler functions in process-event
-  ;; and event-case.  In the declares, an argument listed as (name1 name2) indicates
-  ;; synonyms for the same argument.  All process-event handlers can have
-  ;; (display display), (event-key event-key), and (boolean send-event-p) as keyword
-  ;; arguments, and an event-case clause can also have event-key and send-event-p as
-  ;; arguments.
-  (declare (arglist event-key-or-keys &rest (type &rest keywords))))
-
-(declare-event (:key-press :key-release :button-press :button-release)
-  (card16 sequence)
-  (window (window event-window) root)
-  ((or null window) child)
-  (boolean same-screen-p)
-  (int16 x y root-x root-y)
-  (card16 state)
-  ((or null card32) time)
-  ;; for key-press and key-release, code is the keycode
-  ;; for button-press and button-release, code is the button number
-  (card8 code))
-
-(declare-event :motion-notify
-  (card16 sequence)
-  (window (window event-window) root)
-  ((or null window) child)
-  (boolean same-screen-p)
-  (int16 x y root-x root-y)
-  (card16 state)
-  ((or null card32) time)
-  (boolean hint-p))
-
-(declare-event (:enter-notify :leave-notify)
-  (card16 sequence)
-  (window (window event-window) root)
-  ((or null window) child)
-  (boolean same-screen-p)
-  (int16 x y root-x root-y)
-  (card16 state)
-  ((or null card32) time)
-  ((member :normal :grab :ungrab) mode)
-  ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual) kind)
-  (boolean focus-p))
-
-(declare-event (:focus-in :focus-out)
-  (card16 sequence)
-  (window (window event-window))
-  ((member :normal :while-grabbed :grab :ungrab) mode)
-  ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
-	   :pointer :pointer-root :none)
-   kind))
-
-(declare-event :keymap-notify
-  ((bit-vector 256) keymap))
-
-(declare-event :exposure
-  (card16 sequence)
-  (window (window event-window))
-  (card16 x y width height count))
-
-(declare-event :graphics-exposure
-  (card16 sequence)
-  (drawable (drawable event-window))
-  (card16 x y width height count)
-  (card8 major)
-  (card16 minor))
-
-(declare-event :no-exposure
-  (card16 sequence)
-  (drawable (drawable event-window))
-  (card8 major)
-  (card16 minor))
-
-(declare-event :visibility-notify
-  (card16 sequence)
-  (window (window event-window))
-  ((member :unobscured :partially-obscured :fully-obscured) state))
-
-(declare-event :create-notify
-  (card16 sequence)
-  (window window (parent event-window))
-  (int16 x y)
-  (card16 width height border-width)
-  (boolean override-redirect-p))
-
-(declare-event :destroy-notify
-  (card16 sequence)
-  (window event-window window))
-
-(declare-event :unmap-notify
-  (card16 sequence)
-  (window event-window window)
-  (boolean configure-p))
-
-(declare-event :map-notify
-  (card16 sequence)
-  (window event-window window)
-  (boolean override-redirect-p))
-
-(declare-event :map-request
-  (card16 sequence)
-  (window (parent event-window) window))
-
-(declare-event :reparent-notify
-  (card16 sequence)
-  (window event-window window parent)
-  (int16 x y)
-  (boolean override-redirect-p))
-
-(declare-event :configure-notify
-  (card16 sequence)
-  (window event-window window)
-  (int16 x y)
-  (card16 width height border-width)
-  ((or null window) above-sibling)
-  (boolean override-redirect-p))
-
-(declare-event :gravity-notify
-  (card16 sequence)
-  (window event-window window)
-  (int16 x y))
-
-(declare-event :resize-request
-  (card16 sequence)
-  (window (window event-window))
-  (card16 width height))
-
-(declare-event :configure-request
-  (card16 sequence)
-  (window (parent event-window) window)
-  (int16 x y)
-  (card16 width height border-width)
-  ((member :above :below :top-if :bottom-if :opposite) stack-mode)
-  ((or null window) above-sibling)
-  (mask16 value-mask))
-
-(declare-event :circulate-notify
-  (card16 sequence)
-  (window event-window window)
-  ((member :top :bottom) place))
-
-(declare-event :circulate-request
-  (card16 sequence)
-  (window (parent event-window) window)
-  ((member :top :bottom) place))
-
-(declare-event :property-notify
-  (card16 sequence)
-  (window (window event-window))
-  (keyword atom)
-  ((member :new-value :deleted) state)
-  ((or null card32) time))
-
-(declare-event :selection-clear
-  (card16 sequence)
-  (window (window event-window))
-  (keyword selection)
-  ((or null card32) time))
-
-(declare-event :selection-request
-  (card16 sequence)
-  (window (window event-window) requestor)
-  (keyword selection target)
-  ((or null keyword) property)
-  ((or null card32) time))
-
-(declare-event :selection-notify
-  (card16 sequence)
-  (window (window event-window))
-  (keyword selection target)
-  ((or null keyword) property)
-  ((or null card32) time))
-
-(declare-event :colormap-notify
-  (card16 sequence)
-  (window (window event-window))
-  ((or null colormap) colormap)
-  (boolean new-p installed-p))
-
-(declare-event :mapping-notify
-  (card16 sequence)
-  ((member :modifier :keyboard :pointer) request)
-  (card8 start count))
-
-(declare-event :client-message
-  (card16 sequence)
-  (window (window event-window))
-  ((member 8 16 32) format)
-  (sequence data))
-
-(defun queue-event (display event-key &rest args &key append-p &allow-other-keys)
-  ;; The event is put at the head of the queue if append-p is nil, else the tail.
-  ;; Additional arguments depend on event-key, and are as specified above with
-  ;; declare-event, except that both resource-ids and resource objects are accepted
-  ;; in the event components.
-  (declare (type display display)
-	   (type event-key event-key)
-	   (type boolean append-p)))
-
-
-
-;;; From here on, there has been less coherent review of the interface:
-
-;;;-----------------------------------------------------------------------------
-;;; Window Manager Property functions
-
-(defun wm-name (window)
-  (declare (type window window)
-	   (clx-values string)))
-
-(defsetf wm-name (window) (name))
-
-(defun wm-icon-name (window)
-  (declare (type window window)
-	   (clx-values string)))
-
-(defsetf wm-icon-name (window) (name))
-
-(defun get-wm-class (window)
-  (declare (type window window)
-	   (clx-values (or null name-string) (or null class-string))))
-
-(defun set-wm-class (window resource-name resource-class)
-  (declare (type window window)
-	   (type (or null stringable) resource-name resource-class)))
-
-(defun wm-command (window)
-  ;; Returns a list whose car is a command string and 
-  ;; whose cdr is the list of argument strings.
-  (declare (type window window)
-	   (clx-values (clx-list string))))
-
-(defsetf wm-command (window) (command)
-  ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or
-  ;; equivalent), with elements of command separated by NULL characters.  This
-  ;; enables 
-  ;;   (with-standard-io-syntax (mapcar #'read-from-string (wm-command window)))
-  ;; to recover a lisp command.
-  (declare (type window window)
-	   (type (clx-list stringable) command)))
-
-(defun wm-client-machine (window)
-  ;; Returns a list whose car is a command string and 
-  ;; whose cdr is the list of argument strings.
-  (declare (type window window)
-	   (clx-values string)))
-
-(defsetf wm-client-machine (window) (string)
-  (declare (type window window)
-	   (type stringable string)))
-
-(defstruct wm-hints
-  (input nil :type (or null (member :off :on)))
-  (initial-state nil :type (or null (member :normal :iconic)))
-  (icon-pixmap nil :type (or null pixmap))
-  (icon-window nil :type (or null window))
-  (icon-x nil :type (or null card16))
-  (icon-y nil :type (or null card16))
-  (icon-mask nil :type (or null pixmap))
-  (window-group nil :type (or null resource-id))
-  (flags 0 :type card32)    ;; Extension-hook.  Exclusive-Or'ed with the FLAGS field
-  ;; may be extended in the future
-  )
-
-(defun wm-hints (window)
-  (declare (type window window)
-	   (clx-values wm-hints)))
-
-(defsetf wm-hints (window) (wm-hints))
-
-
-(defstruct wm-size-hints
-  ;; Defaulted T to put the burden of remembering these on widget programmers.
-  (user-specified-position-p t :type boolean) ;; True when user specified x y
-  (user-specified-size-p t :type boolean)     ;; True when user specified width height
-  (x nil :type (or null int16))		      ;; Obsolete
-  (y nil :type (or null int16))		      ;; Obsolete
-  (width nil :type (or null card16))	      ;; Obsolete
-  (height nil :type (or null card16))	      ;; Obsolete
-  (min-width nil :type (or null card16))
-  (min-height nil :type (or null card16))
-  (max-width nil :type (or null card16))
-  (max-height nil :type (or null card16))
-  (width-inc nil :type (or null card16))
-  (height-inc nil :type (or null card16))
-  (min-aspect nil :type (or null number))
-  (max-aspect nil :type (or null number))
-  (base-width nil :type (or null card16))
-  (base-height nil :type (or null card16))
-  (win-gravity nil :type (or null win-gravity)))
-
-(defun wm-normal-hints (window)
-  (declare (type window window)
-	   (clx-values wm-size-hints)))
-
-(defsetf wm-normal-hints (window) (wm-size-hints))
-
-;; ICON-SIZES uses the SIZE-HINTS structure
-
-(defun icon-sizes (window)
-  (declare (type window window)
-	   (clx-values wm-size-hints)))
-  
-(defsetf icon-sizes (window) (wm-size-hints))
-
-(defun wm-protocols (window)
-  (declare (type window window)
-	   (clx-values protocols)))
-  
-(defsetf wm-protocols (window) (protocols)
-  (declare (type window window)
-	   (type (clx-list keyword) protocols)))
-
-(defun wm-colormap-windows (window)
-  (declare (type window window)
-	   (clx-values windows)))
-  
-(defsetf wm-colormap-windows (window) (windows)
-  (declare (type window window)
-	   (type (clx-list window) windows)))
-
-(defun transient-for (window)
-  (declare (type window window)
-	   (clx-values window)))
-
-(defsetf transient-for (window) (transient)
-  (declare (type window window transient)))
-
-(defun set-wm-properties (window &rest options &key 
-			  name icon-name resource-name resource-class command
-			  hints normal-hints
-			  ;; the following are used for wm-normal-hints
-			  user-specified-position-p user-specified-size-p
-			  program-specified-position-p program-specified-size-p
-			  min-width min-height max-width max-height
-			  width-inc height-inc min-aspect max-aspect
-			  base-width base-height win-gravity
-			  ;; the following are used for wm-hints
-			  input initial-state icon-pixmap icon-window
-			  icon-x icon-y icon-mask window-group)
-  ;; Set properties for WINDOW.
-  (declare (type window window)
-	   (type (or null stringable) name icoin-name resource-name resource-class)
-	   (type (or null list) command)
-	   (type (or null wm-hints) hints)
-	   (type (or null wm-size-hints) normal-hints)
-	   (type boolean user-specified-position-p user-specified-size-p)
-	   (type boolean program-specified-position-p program-specified-size-p)
-	   (type (or null card16) min-width min-height max-width max-height width-inc height-inc base-width base-height win-gravity)
-	   (type (or null number) min-aspect max-aspect)
-	   (type (or null (member :off :on)) input)
-	   (type (or null (member :normal :iconic)) initial-state)
-	   (type (or null pixmap) icon-pixmap icon-mask)
-	   (type (or null window) icon-window)
-	   (type (or null card16) icon-x icon-y)
-	   (type (or null resource-id) window-group)))
-
-(defun iconify-window (window)
-  (declare (type window window)))
-
-(defun withdraw-window (window)
-  (declare (type window window)))
- 
-(defstruct standard-colormap
-  (colormap nil :type (or null colormap))
-  (base-pixel 0 :type pixel)
-  (max-color nil :type (or null color))
-  (mult-color nil :type (or null color))
-  (visual nil :type (or null visual-info))
-  (kill nil :type (or (member nil :release-by-freeing-colormap)
-		      drawable gcontext cursor colormap font)))
-
-(defun rgb-colormaps (window property)
-  (declare (type window window)
-	   (type (member :rgb_default_map :rgb_best_map :rgb_red_map
-			 :rgb_green_map :rgb_blue_map) property)
-	   (clx-values (clx-list standard-colormap))))
-
-(defsetf rgb-colormaps (window property) (standard-colormaps)
-  (declare (type window window)
-	   (type (member :rgb_default_map :rgb_best_map :rgb_red_map
-			 :rgb_green_map :rgb_blue_map) property)
-	   (type (clx-list standard-colormap) standard-colormaps)))
-
-(defun cut-buffer (display &key (buffer 0) (type :string) (result-type 'string)
-		                (transform #'card8->char) (start 0) end)
-  ;; Return the contents of cut-buffer BUFFER
-  (declare (type display display)
-	   (type (integer 0 7) buffer)
-	   (type xatom type)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type t result-type)			;a sequence type
-	   (type (or null (function (integer) t)) transform)
-	   (clx-values sequence type format bytes-after)))
-
-(defsetf cut-buffer (display buffer &key (type :string) (format 8)
-			     (transform #'char->card8) (start 0) end) (data))
-
-(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t))
-  ;; Positive rotates left, negative rotates right (opposite of actual
-  ;; protocol request).  When careful-p, ensure all cut-buffer
-  ;; properties are defined, to prevent errors.
-  (declare (type display display)
-	   (type int16 delta)
-	   (type boolean careful-p)))
-
-;;;-----------------------------------------------------------------------------
-;;; Keycode mapping
-
-(defun define-keysym-set (set first-keysym last-keysym)
-  ;; Define all keysyms from first-keysym up to and including
-  ;; last-keysym to be in SET (returned from the keysym-set function).
-  ;; Signals an error if the keysym range overlaps an existing set.
- (declare (type keyword set)
-	  (type keysym first-keysym last-keysym)))
-
-(defun keysym-set (keysym)
-  ;; Return the character code set name of keysym
-  ;; Note that the keyboard set (255) has been broken up into its parts.
-  (declare (type keysym keysym)
-	   (clx-values keyword)))
-
-(defun define-keysym (object keysym &key lowercase translate modifiers mask display)	              
-  ;; Define the translation from keysym/modifiers to a (usually
-  ;; character) object.  ANy previous keysym definition with
-  ;; KEYSYM and MODIFIERS is deleted before adding the new definition.
-  ;;
-  ;; MODIFIERS is either a modifier-mask or list containing intermixed
-  ;; keysyms and state-mask-keys specifying when to use this
-  ;; keysym-translation.  The default is NIL.
-  ;;
-  ;; MASK is either a modifier-mask or list containing intermixed
-  ;; keysyms and state-mask-keys specifying which modifiers to look at
-  ;; (i.e.  modifiers not specified are don't-cares).
-  ;; If mask is :MODIFIERS then the mask is the same as the modifiers
-  ;; (i.e.  modifiers not specified by modifiers are don't cares)
-  ;; The default mask is *default-keysym-translate-mask*
-  ;;
-  ;; If DISPLAY is specified, the translation will be local to DISPLAY,
-  ;; otherwise it will be the default translation for all displays.
-  ;;
-  ;; LOWERCASE is used for uppercase alphabetic keysyms.  The value
-  ;; is the associated lowercase keysym.  This information is used
-  ;; by the keysym-both-case-p predicate (for caps-lock computations)
-  ;; and by the keysym-downcase function.
-  ;;
-  ;; TRANSLATE will be called with parameters (display state OBJECT)
-  ;; when translating KEYSYM and modifiers and mask are satisfied.
-  ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*))
-  ;;                     (or modifiers 0)))
-  ;;      when mask and modifiers aren't lists of keysyms]
-  ;; The default is #'default-keysym-translate
-  ;;
-  (declare (type (or base-char t) object)
-	   (type keysym keysym)
-	   (type (or null mask16 (clx-list (or keysym state-mask-key)))
-	         modifiers)
-	   (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key)))
-	         mask)
-	   (type (or null display) display)
-           (type (or null keysym) lowercase)
-	   (type (function (display card16 t) t) translate)))
-
-(defvar *default-keysym-translate-mask*
-	(the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key)))
-	     (logand #xff (lognot (make-state-mask :lock))))
-  "Default keysym state mask to use during keysym-translation.")
-
-(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys)	              
-  ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS.
-  ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists.
-  (declare (type (or base-char t) object)
-	   (type keysym keysym)
-	   (type (or null mask16 (clx-list (or keysym state-mask-key)))
-	         modifiers)
-	   (type (or null display) display)))
-
-(defun default-keysym-translate (display state object)
-  ;; If object is a character, char-bits are set from state.
-  ;; If object is a list, it is an alist with entries:
-  ;; (base-char [modifiers] [mask-modifiers)
-  ;; When MODIFIERS are specified, this character translation
-  ;; will only take effect when the specified modifiers are pressed.
-  ;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
-  ;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
-  ;; In ambiguous cases, the most specific translation is used.
-  (declare (type display display)
-	   (type card16 state)
-	   (type t object)
-	   (clx-values t))) ;; Object returned by keycode->character
-   
-(defmacro keysym (keysym &rest bytes)
-  ;; Build a keysym.
-  ;; If KEYSYM is an integer, it is used as the most significant bits of
-  ;; the keysym, and BYTES are used to specify low order bytes. The last
-  ;; parameter is always byte4 of the keysym.  If KEYSYM is not an
-  ;; integer, the keysym associated with KEYSYM is returned.
-  ;;
-  ;; This is a macro and not a function macro to promote compile-time
-  ;; lookup. All arguments are evaluated.
-  (declare (type t keysym)
-	   (type (clx-list card8) bytes)
-	   (clx-values keysym)))
-
-(defun character->keysyms (character &optional display)
-  ;; Given a character, return a list of all matching keysyms.
-  ;; If DISPLAY is given, translations specific to DISPLAY are used,
-  ;; otherwise only global translations are used.
-  ;; Implementation dependent function.
-  ;; May be slow [i.e. do a linear search over all known keysyms]
-  (declare (type t character)
-	   (type (or null display) display)
-	   (clx-values (clx-list keysym))))
-
-(defun keycode->keysym (display keycode keysym-index)
-  (declare (type display display)
-	   (type card8 code)
-	   (type card16 state)
-	   (type card8 keysym-index)
-	   (clx-values keysym)))
-
-(defun keysym->keycodes (display keysym)
-  ;; Return keycodes for keysym, as multiple values
-  (declare (type display display)
-	   (type keysym keysym)
-	   (clx-values (or null keycode) (or null keycode) (or null keycode)))
-  )
-
-(defun keysym->character (display keysym &optional state)
-  ;; Find the character associated with a keysym.
-  ;; STATE is used for adding char-bits to character as follows:
-  ;;    control -> char-control-bit
-  ;;    mod-1 -> char-meta-bit
-  ;;    mod-2 -> char-super-bit
-  ;;    mod-3 -> char-hyper-bit
-  ;; Implementation dependent function.
-  (declare (type display display)
-	   (type keysym keysym)
-	   (type (or null card16) state)
-	   (clx-values (or null character))))
-
-(defun keycode->character (display keycode state &key keysym-index
-	                   (keysym-index-function #'default-keysym-index))
-  ;; keysym-index defaults to the result of keysym-index-function which
-  ;; is called with the following parameters:
-  ;; (char0 state caps-lock-p keysyms-per-keycode)
-  ;; where char0 is the "character" object associated with keysym-index 0 and
-  ;; caps-lock-p is non-nil when the keysym associated with the lock
-  ;; modifier is for caps-lock.
-  ;; STATE is also used for setting char-bits:
-  ;;    control -> char-control-bit
-  ;;    mod-1 -> char-meta-bit
-  ;;    mod-2 -> char-super-bit
-  ;;    mod-3 -> char-hyper-bit
-  ;; Implementation dependent function.
-  (declare (type display display)
-	   (type card8 keycode)
-	   (type card16 state)
-	   (type (or null card8) keysym-index)
-	   (type (or null (function (char0 state caps-lock-p keysyms-per-keycode) card8))
-		 keysym-index-function)
-	   (clx-values (or null character))))
-
-(defun default-keysym-index (display keycode state)
-  ;; Returns a keysym-index for use with keycode->character
-  (declare (clx-values card8))
-)
-
-;;; default-keysym-index implements the following tables:
-;;;
-;;; control shift caps-lock character               character
-;;;   0       0       0       #\a                      #\8
-;;;   0       0       1       #\A                      #\8
-;;;   0       1       0       #\A                      #\*
-;;;   0       1       1       #\A                      #\*
-;;;   1       0       0       #\control-A              #\control-8
-;;;   1       0       1       #\control-A              #\control-8
-;;;   1       1       0       #\control-shift-a        #\control-*
-;;;   1       1       1       #\control-shift-a        #\control-*
-;;;
-;;; control shift shift-lock character               character
-;;;   0       0       0       #\a                      #\8
-;;;   0       0       1       #\A                      #\*
-;;;   0       1       0       #\A                      #\*
-;;;   0       1       1       #\A                      #\8
-;;;   1       0       0       #\control-A              #\control-8
-;;;   1       0       1       #\control-A              #\control-*
-;;;   1       1       0       #\control-shift-a        #\control-*
-;;;   1       1       1       #\control-shift-a        #\control-8
-
-(defun state-keysymp (display state keysym)
-  ;; Returns T when a modifier key associated with KEYSYM is on in STATE
-  (declare (type display display)
-	   (type card16 state)
-	   (type keysym keysym)
-	   (clx-values boolean)))
-
-(defun mapping-notify (display request start count)
-  ;; Called on a mapping-notify event to update
-  ;; the keyboard-mapping cache in DISPLAY
-  (declare (type display display)
-	   (type (member :modifier :keyboard :pointer) request)
-	   (type card8 start count)))
-
-(defun keysym-in-map-p (display keysym keymap)
-  ;; Returns T if keysym is found in keymap
-  (declare (type display display)
-	   (type keysym keysym)
-	   (type (bit-vector 256) keymap)
-	   (value boolean)))
-
-(defun character-in-map-p (display character keymap)
-  ;; Implementation dependent function.
-  ;; Returns T if character is found in keymap
-  (declare (type display display)
-	   (type t character)
-	   (type (bit-vector 256) keymap)
-	   (value boolean)))
-
-;;;-----------------------------------------------------------------------------
-;;; Extensions
-
-(defmacro define-extension (name &key events errors)
-  ;; Define extension NAME with EVENTS and ERRORS.
-  ;; Note: The case of NAME is important.
-  ;; To define the request, Use:
-  ;;     (with-buffer-request (display (extension-opcode ,name)) ,@body)
-  ;;     See the REQUESTS file for lots of examples.
-  ;; To define event handlers, use declare-event.
-  ;; To define error handlers, use declare-error and define-condition.
-  (declare (type stringable name)
-	   (type (clx-list symbol) events errors)))
-
-(defmacro extension-opcode (display name)
-  ;; Returns the major opcode for extension NAME.
-  ;; This is a macro to enable NAME to be interned for fast run-time
-  ;; retrieval. 
-  ;; Note: The case of NAME is important.
-  (declare (type display display)
-	   (type stringable name)
-	   (clx-values card8)))
-
-(defmacro define-error (error-key function)
-  ;; Associate a function with ERROR-KEY which will be called with
-  ;; parameters DISPLAY and REPLY-BUFFER and returns a plist of
-  ;; keyword/value pairs which will be passed on to the error handler.
-  ;; A compiler warning is printed when ERROR-KEY is not defined in a
-  ;; preceding DEFINE-EXTENSION.
-  ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type
-  ;;       macros for getting error fields. See DECODE-CORE-ERROR for
-  ;        an example.
-  (declare (type symbol error-key)
-	   (type function function)))
-
-;; All core errors use this, so we make it available to extensions.
-(defun decode-core-error (display event &optional arg)
-  ;; All core errors have the following keyword/argument pairs:
-  ;;    :major integer
-  ;;    :minor integer
-  ;;    :sequence integer
-  ;;    :current-sequence integer
-  ;; In addition, many have an additional argument that comes from the
-  ;; same place in the event, but is named differently.  When the ARG
-  ;; argument is specified, the keyword ARG with card32 value starting
-  ;; at byte 4 of the event is returned with the other keyword/argument
-  ;; pairs.
-  (declare (type display display)
-	   (type reply-buffer event)
-	   (type (or null keyword) arg)
-	   (clx-values keyword/arg-plist)))
-
-;; This isn't new, just extended.
-(defmacro declare-event (event-codes &body declares)
-  ;; Used to indicate the keyword arguments for handler functions in
-  ;; process-event and event-case.
-  ;; Generates functions used in SEND-EVENT.
-  ;; A compiler warning is printed when all of EVENT-CODES are not
-  ;; defined by a preceding DEFINE-EXTENSION.
-  ;; See the INPUT file for lots of examples.
-  (declare (type (or keyword (clx-list keywords)) event-codes)
-	   (type (alist (field-type symbol) (field-names (clx-list symbol)))
-                 declares)))
-
-(defmacro define-gcontext-accessor (name &key default set-function copy-function)
-  ;; This will define a new gcontext accessor called NAME.
-  ;; Defines the gcontext-NAME accessor function and its defsetf.
-  ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when
-  ;; gcontext-cache-p is true.  The NAME keyword will be allowed in
-  ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS.
-  ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE)
-  ;; from create-gcontext, and force-gcontext-changes.
-  ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value)
-  ;; from copy-gcontext and copy-gcontext-components.
-  ;; The copy-function defaults to:
-  ;; (lambda (ignore dst-gc value)
-  ;;    (if value
-  ;;	    (,set-function dst-gc value)
-  ;;	  (error "Can't copy unknown GContext component ~a" ',name)))
-  (declare (type symbol name)
-	   (type t default)
-	   (type symbol set-function) ;; required
-	   (type symbol copy-function)))
-
-
-;; To aid extension implementors in attaching additional information to
-;; clx data structures, the following accessors (with SETF's) are
-;; defined.  GETF can be used on these to extend the structures.
-
-display-plist
-screen-plist
-visual-info-plist
-gcontext-plist
-font-plist
-drawable-plist
-
-
-
-;;; These have had perhaps even less review.
-
-;;; Add some of the functionality provided by the C XLIB library.
-;;;
-;;; LaMott G. Oren, Texas Instruments  10/87
-;;; 
-;;; Design Contributors:
-;;;	Robert W. Scheifler, MIT
-
-;;;-----------------------------------------------------------------------------
-;;; Regions (not yet implemented)
-
-;;; Regions are arbitrary collections of pixels.  This is represented
-;;; in the region structure as either a list of rectangles or a bitmap.
-
-(defun make-region (&optional x y width height)
-  ;; With no parameters, returns an empty region
-  ;; If some parameters are given, all must be given.
-  (declare (type (or null int16) x y width height)
-	   (clx-values region)))
-
-(defun region-p (thing))
-
-(defun copy-region (region))
-
-(defun region-empty-p (region)
-  (declare (type region region)
-	   (clx-values boolean)))
-
-(defun region-clip-box (region)
-  ;; Returns a region which is the smallest enclosing rectangle
-  ;; enclosing REGION
-  (declare (type region region)
-	   (clx-values region)))
-
-;; Accessors that return the boundaries of a region
-(defun region-x (region))
-(defun region-y (region))
-(defun region-width (region))
-(defun region-height (region))
-
-(defsetf region-x (region) (x))
-(defsetf region-y (region) (y))
-;; Setting a region's X/Y translates the region
-
-(defun region-intersection (&rest regions)
-  "Returns a region which is the intersection of one or more REGIONS.
-Returns an empty region if the intersection is empty.
-If there are no regions given, return a very large region."
-  (declare (type (clx-list region) regions)
-	   (clx-values region)))
-
-(defun region-union (&rest regions)
-  "Returns a region which is the union of a number of REGIONS
- (i.e. the smallest region that can contain all the other regions)
- Returns the empty region if no regions are given."
-  (declare (type (clx-list region) regions)
-	   (clx-values region)))
-
-(defun region-subtract (region subtract)
-  "Returns a region containing the points that are in REGION but not in SUBTRACT"
-  (declare (type region region subtract)
-	   (clx-values region)))
-
-(defun point-in-region-p (region x y)
-  ;; Returns T when X/Y are a point within REGION.
-  (declare (type region region)
-	   (type int16 x y)
-	   (clx-values boolean)))
-
-(defun region-equal (a b)
-  ;; Returns T when regions a and b contain the same points.
-  ;; That is, return t when for every X/Y (point-in-region-p a x y)
-  ;; equals (point-in-region-p b x y)
-  (declare (type region a b)
-	   (clx-values boolean)))
-
-(defun subregion-p (large small)
-  "Returns T if SMALL is within LARGE.
- That is, return T when for every X/Y (point-in-region-p small X Y)
- implies (point-in-region-p large X Y)."
-  (declare (type region large small)
-	   (clx-values boolean)))
-
-(defun region-intersect-p (a b)
-  "Returns T if A intersects B.
- That is, return T when there is some point common to regions A and B."
-  (declare (type region a b)
-	   (clx-values boolean)))
-
-(defun map-region (region function &rest args)
-  ;; Calls function with arguments (x y . args) for every point in REGION.
-  (declare (type region region)
-	   (type (function x y &rest args) function)))
-
-;;   Why isn't it better to augment
-;;   gcontext-clip-mask to deal with
-;;   	(or null (member :none) pixmap rect-seq region)
-;;   and force conversions on the caller?
-;; Good idea.
-
-;;(defun gcontext-clip-region (gcontext)
-;;  ;; If the clip-mask of GCONTEXT is known, return it as a region.
-;;  (declare (type gcontext gcontext)
-;;	   (clx-values (or null region))))
-
-;;(defsetf gcontext-clip-region (gcontext) (region)
-;;  ;; Set the clip-rectangles or clip-mask for for GCONTEXT to include
-;;  ;; only the pixels within REGION.
-;;  (declare (type gcontext gcontext)
-;;	   (type region region)))
-
-(defun image->region (image)
-  ;; Returns a region containing the 1 bits of a depth-1 image
-  ;; Signals an error if image isn't of depth 1.
-  (declare (type image image)
-	   (clx-values region)))
-
-(defun region->image (region)
-  ;; Returns a depth-1 image containg 1 bits for every pixel in REGION.
-  (declare (type region region)
-	   (clx-values image)))
-
-(defun polygon-region (points &optional (fill-rule :even-odd))
-  (declare (type sequence points) ;(repeat-seq (integer x) (integer y))
-	   (type (member :even-odd :winding) fill-rule)
-	   (clx-values region)))
-
-;;;-----------------------------------------------------------------------------
-;;; IMAGE functions
-
-
-(deftype bitmap () '(array bit (* *)))
-(deftype pixarray () '(array pixel (* *)))
-
-(defconstant *lisp-byte-lsb-first-p* #+lispm t #-lispm nil
-	     "Byte order in pixel arrays")
-
-(defstruct image
-  ;; Public structure
-  (width 0 :type card16 :read-only t)
-  (height 0 :type card16 :read-only t)
-  (depth 1 :type card8 :read-only t)
-  (plist nil :type list))
-
-;; Image-Plist accessors:
-(defun image-name (image))
-(defun image-x-hot (image))
-(defun image-y-hot (image))
-(defun image-red-mask (image))
-(defun image-blue-mask (image))
-(defun image-green-mask (image))
-
-(defsetf image-name (image) (name))
-(defsetf image-x-hot (image) (x))
-(defsetf image-y-hot (image) (y))
-(defsetf image-red-mask (image) (mask))
-(defsetf image-blue-mask (image) (mask))
-(defsetf image-green-mask (image) (mask))
-
-(defstruct (image-x (:include image))
-  ;; Use this format for shoveling image data
-  ;; Private structure. Accessors for these NOT exported.
-  (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap))
-  (bytes-per-line 0 :type card16)
-  (scanline-pad 32 :type (member 8 16 32))
-  (bits-per-pixel 0 :type (member 1 4 8 16 24 32))
-  (bit-lsb-first-p nil :type boolean)		; Bit order
-  (byte-lsb-first-p nil :type boolean)		; Byte order
-  (data #() :type (array card8 (*))))		; row-major
-
-(defstruct (image-xy (:include image))
-  ;; Public structure
-  ;; Use this format for image processing
-  (bitmap-list nil :type (clx-list bitmap)))
-
-(defstruct (image-z (:include image))
-  ;; Public structure
-  ;; Use this format for image processing
-  (bits-per-pixel 0 :type (member 1 4 8 16 24 32))
-  (pixarray #() :type pixarray))
-
-(defun create-image (&key (width (required-arg width))
-		          (height (required-arg height))
-		     depth data plist name x-hot y-hot
-		     red-mask blue-mask green-mask
-		     bits-per-pixel format scanline-pad bytes-per-line
-		     byte-lsb-first-p bit-lsb-first-p )
-  ;; Returns an image-x image-xy or image-z structure, depending on the
-  ;; type of the :DATA parameter.
-  (declare
-    (type card16 width height)			; Required
-    (type (or null card8) depth)		; Defualts to 1
-    (type (or (array card8 (*))			;Returns image-x
-	      (clx-list bitmap)			;Returns image-xy
-	      pixarray) data)			;Returns image-z
-    (type list plist)
-    (type (or null stringable) name)
-    (type (or null card16) x-hot y-hot)
-    (type (or null pixel) red-mask blue-mask green-mask)
-    (type (or null (member 1 4 8 16 24 32)) bits-per-pixel)
-
-    ;; The following parameters are ignored for image-xy and image-z:
-    (type (or null (member :bitmap :xy-pixmap :z-pixmap))
-	  format)				; defaults to :z-pixmap
-    (type (or null (member 8 16 32)) scanline-pad)
-    (type (or null card16) bytes-per-line) ;default from width and scanline-pad
-    (type boolean byte-lsb-first-p bit-lsb-first-p)
-    (clx-values image)))
-
-(defun get-image (drawable &key 
-		  (x (required-arg x))
-		  (y (required-arg y))
-		  (width (required-arg width))
-		  (height (required-arg height))
-		  plane-mask format result-type)
-  ;; Get an image from the server.
-  ;; Format defaults to :z-pixmap.  Result-Type defaults from Format,
-  ;; image-z for :z-pixmap, and image-xy for :xy-pixmap.
-  ;; Plane-mask defaults to #xFFFFFFFF.
-  ;; Returns an image-x image-xy or image-z structure, depending on the
-  ;; result-type parameter.
-  (declare (type drawable drawable)
-	   (type int16 x y) ;; required
-	   (type card16 width height) ;; required
-	   (type (or null pixel) plane-mask)
-	   (type (or null (member :xy-pixmap :z-pixmap)) format)
-	   (type (or null (member image-x image-xy image-z)) result-type)
-	   (clx-values image)))
-
-(defun put-image (drawable gcontext image &key
-		  (src-x 0) (src-y 0)
-		  (x (required-arg x))
-		  (y (required-arg y))
-		  width height
-		  bitmap-p)
-  ;; When BITMAP-P, force format to be :bitmap when depth=1
-  ;; This causes gcontext to supply foreground & background pixels.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type image image)
-	   (type int16 x y) ;; required
-	   (type (or null card16) width height)
-	   (type boolean bitmap-p)))
-
-(defun copy-image (image &key (x 0) (y 0) width height result-type)
-  ;; Copy with optional sub-imaging and format conversion.
-  ;; result-type defaults to (type-of image)
-  (declare (type image image)
-	   (type card16 x y)
-	   (type (or null card16) width height) ;; Default from image
-	   (type (or null (member image-x image-xy image-z)) result-type)
-	   (clx-values image)))
-
-(defun read-bitmap-file (pathname)
-  ;; Creates an image from a C include file in standard X11 format
-  (declare (type (or pathname string stream) pathname)
-	   (clx-values image)))
-
-(defun write-bitmap-file (pathname image &optional name)
-  ;; Writes an image to a C include file in standard X11 format
-  ;; NAME argument used for variable prefixes.  Defaults to "image"
-  (declare (type (or pathname string stream) pathname)
-	   (type image image)
-	   (type (or null stringable) name)))
-
-;;;-----------------------------------------------------------------------------
-;;; Resource data-base
-
-
-(defun make-resource-database ()
-  ;; Returns an empty resource data-base
-  (declare (clx-values resource-database)))
-
-(defun get-resource (database value-name value-class full-name full-class)
-  ;; Return the value of the resource in DATABASE whose partial name
-  ;; most closely matches (append full-name (list value-name)) and
-  ;;                      (append full-class (list value-class)).
-  (declare (type resource-database database)
-	   (type stringable value-name value-class)
-	   (type (clx-list stringable) full-name full-class)
-	   (clx-values value)))
-
-(defun add-resource (database name-list value)
-  ;; name-list is a list of either strings or symbols. If a symbol, 
-  ;; case-insensitive comparisons will be used, if a string,
-  ;; case-sensitive comparisons will be used.  The symbol '* or
-  ;; string "*" are used as wildcards, matching anything or nothing.
-  (declare (type resource-database database)
-	   (type (clx-list stringable) name-list)
-	   (type t value)))
-
-(defun delete-resource (database name-list)
-  (declare (type resource-database database)
-	   (type (clx-list stringable) name-list)))
-
-(defun map-resource (database function &rest args)
-  ;; Call FUNCTION on each resource in DATABASE.
-  ;; FUNCTION is called with arguments (name-list value . args)
-  (declare (type resource-database database)
-	   (type (function ((clx-list stringable) t &rest t) t) function)
-	   (clx-values nil)))
-
-(defun merge-resources (database with-database)
-  (declare (type resource-database database with-database)
-	   (clx-values resource-database))
-  (map-resource #'add-resource database with-database)
-  with-database)
-
-;; Note: with-input-from-string can be used with read-resources to define
-;;       default resources in a program file.
-
-(defun read-resources (database pathname &key key test test-not)
-  ;; Merges resources from a file in standard X11 format with DATABASE.
-  ;; KEY is a function used for converting value-strings, the default is
-  ;; identity.  TEST and TEST-NOT are predicates used for filtering
-  ;; which resources to include in the database.  They are called with
-  ;; the name and results of the KEY function.
-  (declare (type resource-database database)
-	   (type (or pathname string stream) pathname)
-	   (type (or null (function (string) t)) key)
-	   (type (or null (function ((clx-list string) t) boolean))
-                 test test-not)
-	   (clx-values resource-database)))
-
-(defun write-resources (database pathname &key write test test-not)
-  ;; Write resources to PATHNAME in the standard X11 format.
-  ;; WRITE is a function used for writing values, the default is #'princ
-  ;; TEST and TEST-NOT are predicates used for filtering which resources
-  ;; to include in the database.  They are called with the name and value.
-  (declare (type resource-database database)
-	   (type (or pathname string stream) pathname)
-	   (type (or null (function (string stream) t)) write)
-	   (type (or null (function ((clx-list string) t) boolean))
-                 test test-not)))
-
-(defun root-resources (screen &key database key test test-not)
-  "Returns a resource database containing the contents of the root window
-   RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display,
-   then its default screen is used. If an existing DATABASE is given, then
-   resource values are merged with the DATABASE and the modified DATABASE is
-   returned.
-
-   TEST and TEST-NOT are predicates for selecting which resources are
-   read.  Arguments are a resource name list and a resource value. The KEY
-   function, if given, is called to convert a resource value string to the
-   value given to TEST or TEST-NOT."
-
-  (declare (type (or screen display) screen)
-	   (type (or null resource-database) database)
-	   (type (or null (function (string) t)) key)
-	   (type (or null (function list boolean)) test test-not)
-	   (clx-values resource-database)))
-
-(defsetf root-resources (screen &key test test-not (write 'princ)) (database)
-  "Changes the contents of the root window RESOURCE_MANAGER property for the
-   given SCREEN. If SCREEN is a display, then its default screen is used. 
-
-   TEST and TEST-NOT are predicates for selecting which resources from the
-   DATABASE are written.  Arguments are a resource name list and a resource
-   value.  The WRITE function is used to convert a resource value into a
-   string stored in the property."
-
-  (declare (type (or screen display) screen)
-	(type (or null resource-database) database)
-	(type (or null (function list boolean)) test test-not)
-	(type (or null (function (string stream) t)) write)
-	(clx-values resource-database)))
-
-;;;-----------------------------------------------------------------------------
-;;; Shared GContext's
-
-(defmacro using-gcontext ((var &rest options &key drawable
-			       function plane-mask foreground background
-			       line-width line-style cap-style
-			       join-style fill-style fill-rule arc-mode
-			       tile stipple ts-x ts-y font
-			       subwindow-mode exposures clip-x clip-y
-			       clip-mask clip-ordering dash-offset
-			       dashes)
-			  &body body)
-  ;; Equivalent to (let ((var (apply #'make-gcontext options))) ,@body)
-  ;; but more efficient because it uses a gcontext cache associated with
-  ;; drawable's display.
-  )
-
-
-
- X11 Request Name       CLX Function Name
------------------       -----------------
-AllocColor              ALLOC-COLOR
-AllocColorCells         ALLOC-COLOR-CELLS
-AllocColorPlanes        ALLOC-COLOR-PLANES
-AllocNamedColor         ALLOC-COLOR
-AllowEvents             ALLOW-EVENTS
-Bell                    BELL
-ChangeAccessControl     (setf (ACCESS-CONTROL display) boolean)
-ChangeActivePointerGrab CHANGE-ACTIVE-POINTER-GRAB
-ChangeCloseDownMode     (setf (CLOSE-DOWN-MODE display) mode)
-ChangeGC                FORCE-GCONTEXT-CHANGES
-     ;; See WITH-GCONTEXT
-     (setf (gcontext-function gc) boole-constant)
-     (setf (gcontext-plane-mask gc) card32)
-     (setf (gcontext-foreground gc) card32)
-     (setf (gcontext-background gc) card32)
-     (setf (gcontext-line-width gc) card16)
-     (setf (gcontext-line-style gc) keyword)
-     (setf (gcontext-cap-style gc) keyword)
-     (setf (gcontext-join-style gc) keyword)
-     (setf (gcontext-fill-style gc) keyword)
-     (setf (gcontext-fill-rule gc) keyword)
-     (setf (gcontext-tile gc) pixmap)
-     (setf (gcontext-stipple gc) pixmap)
-     (setf (gcontext-ts-x gc) int16) ;; Tile-Stipple-X-origin
-     (setf (gcontext-ts-y gc) int16) ;; Tile-Stipple-Y-origin
-     (setf (gcontext-font gc &optional metrics-p) font)
-     (setf (gcontext-subwindow-mode gc) keyword)
-     (setf (gcontext-exposures gc) (member :on :off))
-     (setf (gcontext-clip-x gc) int16)
-     (setf (gcontext-clip-y gc) int16)
-     (setf (gcontext-clip-mask gc &optional ordering)
-	   (or (member :none) pixmap rect-seq))
-     (setf (gcontext-dash-offset gc) card16)
-     (setf (gcontext-dashes gc) (or card8 sequence))
-     (setf (gcontext-arc-mode gc) (member :chord :pie-slice))
-     (setf (gcontext-clip-ordering gc) keyword)
-
-ChangeHosts             ADD-ACCESS-HOST
-ChangeHosts             REMOVE-ACCESS-HOST
-ChangeKeyboardControl   CHANGE-KEYBOARD-CONTROL
-ChangePointerControl    CHANGE-POINTER-CONTROL
-ChangeProperty          CHANGE-PROPERTY
-ChangeSaveSet           REMOVE-FROM-SAVE-SET
-ChangeSaveSet           ADD-TO-SAVE-SET
-ChangeWindowAttributes
-     ;; See WITH-STATE
-     (setf (window-background window) value)
-     (setf (window-border window) value)
-     (setf (window-bit-gravity window) value)
-     (setf (window-gravity window) value)
-     (setf (window-backing-store window) value)
-     (setf (window-backing-planes window) value)
-     (setf (window-backing-pixel window) value)
-     (setf (window-override-redirect window) value)
-     (setf (window-save-under window) value)
-     (setf (window-colormap window) value)
-     (setf (window-cursor window) value)
-     (setf (window-event-mask window) value)
-     (setf (window-do-not-propagate-mask window) value)
-
-CirculateWindow         CIRCULATE-WINDOW-DOWN
-CirculateWindow         CIRCULATE-WINDOW-UP
-ClearToBackground       CLEAR-AREA
-CloseFont               CLOSE-FONT
-ConfigureWindow
-     ;; See WITH-STATE
-     (setf (drawable-x drawable) integer)
-     (setf (drawable-y drawable) integer)
-     (setf (drawable-width drawable) integer)
-     (setf (drawable-height drawable) integer)
-     (setf (drawable-depth drawable) integer)
-     (setf (drawable-border-width drawable) integer)
-     (setf (window-priority window &optional sibling) integer)
-
-ConvertSelection        CONVERT-SELECTION
-CopyArea                COPY-AREA
-CopyColormapAndFree     COPY-COLORMAP-AND-FREE
-CopyGC                  COPY-GCONTEXT
-CopyGC                  COPY-GCONTEXT-COMPONENTS
-CopyPlane               COPY-PLANE
-CreateColormap          CREATE-COLORMAP
-CreateCursor            CREATE-CURSOR
-CreateGC                CREATE-GCONTEXT
-CreateGlyphCursor       CREATE-GLYPH-CURSOR
-CreatePixmap            CREATE-PIXMAP
-CreateWindow            CREATE-WINDOW
-DeleteProperty          DELETE-PROPERTY
-DestroySubwindows       DESTROY-SUBWINDOWS
-DestroyWindow           DESTROY-WINDOW
-FillPoly                DRAW-LINES
-ForceScreenSaver        RESET-SCREEN-SAVER
-ForceScreenSaver        ACTIVATE-SCREEN-SAVER
-FreeColormap            FREE-COLORMAP
-FreeColors              FREE-COLORS
-FreeCursor              FREE-CURSOR
-FreeGC                  FREE-GCONTEXT
-FreePixmap              FREE-PIXMAP
-GetAtomName             ATOM-NAME
-GetFontPath             FONT-PATH
-GetGeometry             ;; See WITH-STATE
-                        DRAWABLE-ROOT
-                        DRAWABLE-X
-                        DRAWABLE-Y
-                        DRAWABLE-WIDTH
-                        DRAWABLE-HEIGHT
-                        DRAWABLE-DEPTH
-                        DRAWABLE-BORDER-WIDTH
-
-GetImage                GET-RAW-IMAGE
-GetInputFocus           INPUT-FOCUS
-GetKeyboardControl      KEYBOARD-CONTROL
-GetKeyboardMapping      KEYBOARD-MAPPING
-GetModifierMapping      MODIFIER-MAPPING
-GetMotionEvents         MOTION-EVENTS
-GetPointerControl       POINTER-CONTROL
-GetPointerMapping       POINTER-MAPPING
-GetProperty             GET-PROPERTY
-GetScreenSaver          SCREEN-SAVER
-GetSelectionOwner       SELECTION-OWNER
-GetWindowAttributes     ;; See WITH-STATE
-                        WINDOW-VISUAL-INFO
-                        WINDOW-CLASS
-                        WINDOW-BIT-GRAVITY
-                        WINDOW-GRAVITY
-                        WINDOW-BACKING-STORE
-                        WINDOW-BACKING-PLANES
-                        WINDOW-BACKING-PIXEL
-                        WINDOW-SAVE-UNDER
-                        WINDOW-OVERRIDE-REDIRECT
-                        WINDOW-EVENT-MASK
-                        WINDOW-DO-NOT-PROPAGATE-MASK
-                        WINDOW-COLORMAP
-                        WINDOW-COLORMAP-INSTALLED-P
-                        WINDOW-ALL-EVENT-MASKS
-                        WINDOW-MAP-STATE
-
-GrabButton              GRAB-BUTTON
-GrabKey                 GRAB-KEY
-GrabKeyboard            GRAB-KEYBOARD
-GrabPointer             GRAB-POINTER
-GrabServer              GRAB-SERVER
-ImageText16             DRAW-IMAGE-GLYPHS
-ImageText16             DRAW-IMAGE-GLYPH
-ImageText8              DRAW-IMAGE-GLYPHS
-InstallColormap         INSTALL-COLORMAP
-InternAtom              FIND-ATOM
-InternAtom              INTERN-ATOM
-KillClient              KILL-TEMPORARY-CLIENTS
-KillClient              KILL-CLIENT
-ListExtensions          LIST-EXTENSIONS
-ListFonts               LIST-FONT-NAMES
-ListFontsWithInfo       LIST-FONTS
-ListHosts               ACCESS-CONTROL
-ListHosts               ACCESS-HOSTS
-ListInstalledColormaps  INSTALLED-COLORMAPS
-ListProperties          LIST-PROPERTIES
-LookupColor             LOOKUP-COLOR
-MapSubwindows           MAP-SUBWINDOWS
-MapWindow               MAP-WINDOW
-OpenFont                OPEN-FONT
-PolyArc                 DRAW-ARC
-PolyArc                 DRAW-ARCS
-PolyFillArc             DRAW-ARC
-PolyFillArc             DRAW-ARCS
-PolyFillRectangle       DRAW-RECTANGLE
-PolyFillRectangle       DRAW-RECTANGLES
-PolyLine                DRAW-LINE
-PolyLine                DRAW-LINES
-PolyPoint               DRAW-POINT
-PolyPoint               DRAW-POINTS
-PolyRectangle           DRAW-RECTANGLE
-PolyRectangle           DRAW-RECTANGLES
-PolySegment             DRAW-SEGMENTS
-PolyText16              DRAW-GLYPH
-PolyText16              DRAW-GLYPHS
-PolyText8               DRAW-GLYPHS
-PutImage                PUT-RAW-IMAGE
-QueryBestSize           QUERY-BEST-CURSOR
-QueryBestSize           QUERY-BEST-STIPPLE
-QueryBestSize           QUERY-BEST-TILE
-QueryColors             QUERY-COLORS
-QueryExtension          QUERY-EXTENSION
-QueryFont               FONT-NAME
-                        FONT-NAME
-                        FONT-DIRECTION
-                        FONT-MIN-CHAR
-                        FONT-MAX-CHAR
-                        FONT-MIN-BYTE1
-                        FONT-MAX-BYTE1
-                        FONT-MIN-BYTE2
-                        FONT-MAX-BYTE2
-                        FONT-ALL-CHARS-EXIST-P
-                        FONT-DEFAULT-CHAR
-                        FONT-ASCENT
-                        FONT-DESCENT
-                        FONT-PROPERTIES
-                        FONT-PROPERTY
-     
-                        CHAR-LEFT-BEARING
-                        CHAR-RIGHT-BEARING
-                        CHAR-WIDTH
-                        CHAR-ASCENT
-                        CHAR-DESCENT
-                        CHAR-ATTRIBUTES
-     
-                        MIN-CHAR-LEFT-BEARING
-                        MIN-CHAR-RIGHT-BEARING
-                        MIN-CHAR-WIDTH
-                        MIN-CHAR-ASCENT
-                        MIN-CHAR-DESCENT
-                        MIN-CHAR-ATTRIBUTES
-     
-                        MAX-CHAR-LEFT-BEARING
-                        MAX-CHAR-RIGHT-BEARING
-                        MAX-CHAR-WIDTH
-                        MAX-CHAR-ASCENT
-                        MAX-CHAR-DESCENT
-                        MAX-CHAR-ATTRIBUTES
-
-QueryKeymap             QUERY-KEYMAP
-QueryPointer            GLOBAL-POINTER-POSITION
-QueryPointer            POINTER-POSITION
-QueryPointer            QUERY-POINTER
-QueryTextExtents        TEXT-EXTENTS
-QueryTextExtents        TEXT-WIDTH
-QueryTree               QUERY-TREE
-RecolorCursor           RECOLOR-CURSOR
-ReparentWindow          REPARENT-WINDOW
-RotateProperties        ROTATE-PROPERTIES
-SendEvent               SEND-EVENT
-SetClipRectangles       FORCE-GCONTEXT-CHANGES
-     ;; See WITH-GCONTEXT
-     (setf (gcontext-clip-x gc) int16)
-     (setf (gcontext-clip-y gc) int16)
-     (setf (gcontext-clip-mask gc &optional ordering)
-	   (or (member :none) pixmap rect-seq))
-     (setf (gcontext-clip-ordering gc) keyword)
-
-SetDashes               FORCE-GCONTEXT-CHANGES
-     ;; See WITH-GCONTEXT
-     (setf (gcontext-dash-offset gc) card16)
-     (setf (gcontext-dashes gc) (or card8 sequence))
-
-SetFontPath
-     (setf (font-path font) paths)
-	Where paths is (type (clx-sequence (or string pathname)))
-
-SetInputFocus           SET-INPUT-FOCUS
-SetKeyboardMapping      CHANGE-KEYBOARD-MAPPING
-SetModifierMapping      SET-MODIFIER-MAPPING
-SetPointerMapping       SET-POINTER-MAPPING
-SetScreenSaver          SET-SCREEN-SAVER
-SetSelectionOwner       SET-SELECTION-OWNER
-StoreColors             STORE-COLOR
-StoreColors             STORE-COLORS
-StoreNamedColor         STORE-COLOR
-StoreNamedColor         STORE-COLORS
-TranslateCoords         TRANSLATE-COORDINATES
-UngrabButton            UNGRAB-BUTTON
-UngrabKey               UNGRAB-KEY
-UngrabKeyboard          UNGRAB-KEYBOARD
-UngrabPointer           UNGRAB-POINTER
-UngrabServer            UNGRAB-SERVER
-UninstallColormap       UNINSTALL-COLORMAP
-UnmapSubwindows         UNMAP-SUBWINDOWS
-UnmapWindow             UNMAP-WINDOW
-WarpPointer             WARP-POINTER
-WarpPointer             WARP-POINTER-IF-INSIDE
-WarpPointer             WARP-POINTER-RELATIVE
-WarpPointer             WARP-POINTER-RELATIVE-IF-INSIDE
-NoOperation             NO-OPERATION
-
-
-
- X11 Request Name       CLX Function Name
------------------       -----------------
-ListHosts               ACCESS-CONTROL
-ListHosts               ACCESS-HOSTS
-ForceScreenSaver        ACTIVATE-SCREEN-SAVER
-ChangeHosts             ADD-ACCESS-HOST
-ChangeSaveSet           ADD-TO-SAVE-SET
-AllocColor              ALLOC-COLOR
-AllocNamedColor         ALLOC-COLOR
-AllocColorCells         ALLOC-COLOR-CELLS
-AllocColorPlanes        ALLOC-COLOR-PLANES
-AllowEvents             ALLOW-EVENTS
-GetAtomName             ATOM-NAME
-Bell                    BELL
-ChangeActivePointerGrab CHANGE-ACTIVE-POINTER-GRAB
-ChangeKeyboardControl   CHANGE-KEYBOARD-CONTROL
-SetKeyboardMapping      CHANGE-KEYBOARD-MAPPING
-ChangePointerControl    CHANGE-POINTER-CONTROL
-ChangeProperty          CHANGE-PROPERTY
-QueryFont               CHAR-ASCENT
-QueryFont               CHAR-ATTRIBUTES
-QueryFont               CHAR-DESCENT
-QueryFont               CHAR-LEFT-BEARING
-QueryFont               CHAR-RIGHT-BEARING
-QueryFont               CHAR-WIDTH
-CirculateWindow         CIRCULATE-WINDOW-DOWN
-CirculateWindow         CIRCULATE-WINDOW-UP
-ClearToBackground       CLEAR-AREA
-CloseFont               CLOSE-FONT
-ConvertSelection        CONVERT-SELECTION
-CopyArea                COPY-AREA
-CopyColormapAndFree     COPY-COLORMAP-AND-FREE
-CopyGC                  COPY-GCONTEXT
-CopyGC                  COPY-GCONTEXT-COMPONENTS
-CopyPlane               COPY-PLANE
-CreateColormap          CREATE-COLORMAP
-CreateCursor            CREATE-CURSOR
-CreateGC                CREATE-GCONTEXT
-CreateGlyphCursor       CREATE-GLYPH-CURSOR
-CreatePixmap            CREATE-PIXMAP
-CreateWindow            CREATE-WINDOW
-DeleteProperty          DELETE-PROPERTY
-DestroySubwindows       DESTROY-SUBWINDOWS
-DestroyWindow           DESTROY-WINDOW
-PolyArc                 DRAW-ARC
-PolyArc                 DRAW-ARCS
-PolyText16              DRAW-GLYPH
-PolyText16              DRAW-GLYPHS
-PolyText8               DRAW-GLYPHS
-ImageText16             DRAW-IMAGE-GLYPH
-ImageText16             DRAW-IMAGE-GLYPHS
-ImageText8              DRAW-IMAGE-GLYPHS
-PolyLine                DRAW-LINE
-PolyLine                DRAW-LINES
-PolyPoint               DRAW-POINT
-PolyPoint               DRAW-POINTS
-PolyFillRectangle       DRAW-RECTANGLE
-PolyRectangle           DRAW-RECTANGLE
-PolyFillRectangle       DRAW-RECTANGLES
-PolyRectangle           DRAW-RECTANGLES
-PolySegment             DRAW-SEGMENTS
-GetGeometry             DRAWABLE-BORDER-WIDTH
-GetGeometry             DRAWABLE-DEPTH
-GetGeometry             DRAWABLE-HEIGHT
-GetGeometry             DRAWABLE-ROOT
-GetGeometry             DRAWABLE-WIDTH
-GetGeometry             DRAWABLE-X
-GetGeometry             DRAWABLE-Y
-FillPoly                FILL-POLYGON
-InternAtom              FIND-ATOM
-QueryFont               FONT-ALL-CHARS-EXIST-P
-QueryFont               FONT-ASCENT
-QueryFont               FONT-DEFAULT-CHAR
-QueryFont               FONT-DESCENT
-QueryFont               FONT-DIRECTION
-QueryFont               FONT-MAX-BYTE1
-QueryFont               FONT-MAX-BYTE2
-QueryFont               FONT-MAX-CHAR
-QueryFont               FONT-MIN-BYTE1
-QueryFont               FONT-MIN-BYTE2
-QueryFont               FONT-MIN-CHAR
-QueryFont               FONT-NAME
-QueryFont               FONT-NAME
-GetFontPath             FONT-PATH
-QueryFont               FONT-PROPERTIES
-QueryFont               FONT-PROPERTY
-ChangeGC                FORCE-GCONTEXT-CHANGES
-SetClipRectangles       FORCE-GCONTEXT-CHANGES
-SetDashes               FORCE-GCONTEXT-CHANGES
-FreeColormap            FREE-COLORMAP
-FreeColors              FREE-COLORS
-FreeCursor              FREE-CURSOR
-FreeGC                  FREE-GCONTEXT
-FreePixmap              FREE-PIXMAP
-GetProperty             GET-PROPERTY
-GetImage                GET-RAW-IMAGE
-QueryPointer            GLOBAL-POINTER-POSITION
-GrabButton              GRAB-BUTTON
-GrabKey                 GRAB-KEY
-GrabKeyboard            GRAB-KEYBOARD
-GrabPointer             GRAB-POINTER
-GrabServer              GRAB-SERVER
-GrabServer              WITH-SERVER-GRABBED
-GetInputFocus           INPUT-FOCUS
-InstallColormap         INSTALL-COLORMAP
-ListInstalledColormaps  INSTALLED-COLORMAPS
-InternAtom              INTERN-ATOM
-GetKeyboardControl      KEYBOARD-CONTROL
-GetKeyboardMapping      KEYBOARD-MAPPING
-KillClient              KILL-CLIENT
-KillClient              KILL-TEMPORARY-CLIENTS
-ListExtensions          LIST-EXTENSIONS
-ListFonts               LIST-FONT-NAMES
-ListFontsWithInfo       LIST-FONTS
-ListProperties          LIST-PROPERTIES
-LookupColor             LOOKUP-COLOR
-MapSubwindows           MAP-SUBWINDOWS
-MapWindow               MAP-WINDOW
-QueryFont               MAX-CHAR-ASCENT
-QueryFont               MAX-CHAR-ATTRIBUTES
-QueryFont               MAX-CHAR-DESCENT
-QueryFont               MAX-CHAR-LEFT-BEARING
-QueryFont               MAX-CHAR-RIGHT-BEARING
-QueryFont               MAX-CHAR-WIDTH
-QueryFont               MIN-CHAR-ASCENT
-QueryFont               MIN-CHAR-ATTRIBUTES
-QueryFont               MIN-CHAR-DESCENT
-QueryFont               MIN-CHAR-LEFT-BEARING
-QueryFont               MIN-CHAR-RIGHT-BEARING
-QueryFont               MIN-CHAR-WIDTH
-GetModifierMapping      MODIFIER-MAPPING
-GetMotionEvents         MOTION-EVENTS
-NoOperation             NO-OPERATION
-OpenFont                OPEN-FONT
-GetPointerControl       POINTER-CONTROL
-GetPointerMapping       POINTER-MAPPING
-QueryPointer            POINTER-POSITION
-PutImage                PUT-RAW-IMAGE
-QueryBestSize           QUERY-BEST-CURSOR
-QueryBestSize           QUERY-BEST-STIPPLE
-QueryBestSize           QUERY-BEST-TILE
-QueryColors             QUERY-COLORS
-QueryExtension          QUERY-EXTENSION
-QueryKeymap             QUERY-KEYMAP
-QueryPointer            QUERY-POINTER
-QueryTree               QUERY-TREE
-RecolorCursor           RECOLOR-CURSOR
-ChangeHosts             REMOVE-ACCESS-HOST
-ChangeSaveSet           REMOVE-FROM-SAVE-SET
-ReparentWindow          REPARENT-WINDOW
-ForceScreenSaver        RESET-SCREEN-SAVER
-RotateProperties        ROTATE-PROPERTIES
-GetScreenSaver          SCREEN-SAVER
-GetSelectionOwner       SELECTION-OWNER
-SendEvent               SEND-EVENT
-ChangeAccessControl     SET-ACCESS-CONTROL
-ChangeCloseDownMode     SET-CLOSE-DOWN-MODE
-SetInputFocus           SET-INPUT-FOCUS
-SetModifierMapping      SET-MODIFIER-MAPPING
-SetPointerMapping       SET-POINTER-MAPPING
-SetScreenSaver          SET-SCREEN-SAVER
-SetSelectionOwner       SET-SELECTION-OWNER
-StoreColors             STORE-COLOR
-StoreColors             STORE-COLORS
-StoreNamedColor         STORE-COLOR
-StoreNamedColor         STORE-COLORS
-QueryTextExtents        TEXT-EXTENTS
-QueryTextExtents        TEXT-WIDTH
-TranslateCoords         TRANSLATE-COORDINATES
-UngrabButton            UNGRAB-BUTTON
-UngrabKey               UNGRAB-KEY
-UngrabKeyboard          UNGRAB-KEYBOARD
-UngrabPointer           UNGRAB-POINTER
-UngrabServer            UNGRAB-SERVER
-UngrabServer            WITH-SERVER-GRABBED
-UninstallColormap       UNINSTALL-COLORMAP
-UnmapSubwindows         UNMAP-SUBWINDOWS
-UnmapWindow             UNMAP-WINDOW
-WarpPointer             WARP-POINTER
-WarpPointer             WARP-POINTER-IF-INSIDE
-WarpPointer             WARP-POINTER-RELATIVE
-WarpPointer             WARP-POINTER-RELATIVE-IF-INSIDE
-GetWindowAttributes     WINDOW-ALL-EVENT-MASKS
-GetWindowAttributes     WINDOW-BACKING-PIXEL
-GetWindowAttributes     WINDOW-BACKING-PLANES
-GetWindowAttributes     WINDOW-BACKING-STORE
-GetWindowAttributes     WINDOW-BIT-GRAVITY
-GetWindowAttributes     WINDOW-CLASS
-GetWindowAttributes     WINDOW-COLORMAP
-GetWindowAttributes     WINDOW-COLORMAP-INSTALLED-P
-GetWindowAttributes     WINDOW-DO-NOT-PROPAGATE-MASK
-GetWindowAttributes     WINDOW-EVENT-MASK
-GetWindowAttributes     WINDOW-GRAVITY
-GetWindowAttributes     WINDOW-MAP-STATE
-GetWindowAttributes     WINDOW-OVERRIDE-REDIRECT
-GetWindowAttributes     WINDOW-SAVE-UNDER
-GetWindowAttributes     WINDOW-VISUAL-INFO
-
-ConfigureWindow         (SETF (DRAWABLE-BORDER-WIDTH DRAWABLE) INTEGER)
-ConfigureWindow         (SETF (DRAWABLE-DEPTH DRAWABLE) INTEGER)
-ConfigureWindow         (SETF (DRAWABLE-HEIGHT DRAWABLE) INTEGER)
-ConfigureWindow         (SETF (DRAWABLE-WIDTH DRAWABLE) INTEGER)
-ConfigureWindow         (SETF (DRAWABLE-X DRAWABLE) INTEGER)
-ConfigureWindow         (SETF (DRAWABLE-Y DRAWABLE) INTEGER)
-SetFontPath             (SETF (FONT-PATH FONT) PATHS)
-ChangeGC                (SETF (GCONTEXT-ARC-MODE GC) (MEMBER CHORD PIE-SLICE))
-ChangeGC                (SETF (GCONTEXT-BACKGROUND GC) CARD32)
-ChangeGC                (SETF (GCONTEXT-CAP-STYLE GC) KEYWORD)
-SetClipRectangles       (SETF (GCONTEXT-CLIP-MASK GC &OPTIONAL ORDERING)
-	                      (OR (MEMBER NONE) PIXMAP RECT-SEQ))
-SetClipRectangles       (SETF (GCONTEXT-CLIP-ORDERING GC) KEYWORD)
-SetClipRectangles       (SETF (GCONTEXT-CLIP-X GC) INT16)
-SetClipRectangles       (SETF (GCONTEXT-CLIP-Y GC) INT16)
-SetDashes               (SETF (GCONTEXT-DASH-OFFSET GC) CARD16)
-SetDashes               (SETF (GCONTEXT-DASHES GC) (OR CARD8 SEQUENCE))
-ChangeGC                (SETF (GCONTEXT-EXPOSURES GC) (MEMBER ON OFF))
-ChangeGC                (SETF (GCONTEXT-FILL-RULE GC) KEYWORD)
-ChangeGC                (SETF (GCONTEXT-FILL-STYLE GC) KEYWORD)
-ChangeGC                (SETF (GCONTEXT-FONT GC &OPTIONAL METRICS-P) FONT)
-ChangeGC                (SETF (GCONTEXT-FOREGROUND GC) CARD32)
-ChangeGC                (SETF (GCONTEXT-FUNCTION GC) BOOLE-CONSTANT)
-ChangeGC                (SETF (GCONTEXT-JOIN-STYLE GC) KEYWORD)
-ChangeGC                (SETF (GCONTEXT-LINE-STYLE GC) KEYWORD)
-ChangeGC                (SETF (GCONTEXT-LINE-WIDTH GC) CARD16)
-ChangeGC                (SETF (GCONTEXT-PLANE-MASK GC) CARD32)
-ChangeGC                (SETF (GCONTEXT-STIPPLE GC) PIXMAP)
-ChangeGC                (SETF (GCONTEXT-SUBWINDOW-MODE GC) KEYWORD)
-ChangeGC                (SETF (GCONTEXT-TILE GC) PIXMAP)
-ChangeGC                (SETF (GCONTEXT-TS-X GC) INT16)
-ChangeGC                (SETF (GCONTEXT-TS-Y GC) INT16)
-ChangeWindowAttributes  (SETF (WINDOW-BACKGROUND WINDOW) VALUE)
-ChangeWindowAttributes  (SETF (WINDOW-BACKING-PIXEL WINDOW) VALUE)
-ChangeWindowAttributes  (SETF (WINDOW-BACKING-PLANES WINDOW) VALUE)
-ChangeWindowAttributes  (SETF (WINDOW-BACKING-STORE WINDOW) VALUE)
-ChangeWindowAttributes  (SETF (WINDOW-BIT-GRAVITY WINDOW) VALUE)
-ChangeWindowAttributes  (SETF (WINDOW-BORDER WINDOW) VALUE)
-ChangeWindowAttributes  (SETF (WINDOW-COLORMAP WINDOW) VALUE)
-ChangeWindowAttributes  (SETF (WINDOW-CURSOR WINDOW) VALUE)
-ChangeWindowAttributes  (SETF (WINDOW-DO-NOT-PROPAGATE-MASK WINDOW) VALUE)
-ChangeWindowAttributes  (SETF (WINDOW-EVENT-MASK WINDOW) VALUE)
-ChangeWindowAttributes  (SETF (WINDOW-GRAVITY WINDOW) VALUE)
-ChangeWindowAttributes  (SETF (WINDOW-OVERRIDE-REDIRECT WINDOW) VALUE)
-ConfigureWindow         (SETF (WINDOW-PRIORITY WINDOW &OPTIONAL SIBLING) INTEGER)
-ChangeWindowAttributes  (SETF (WINDOW-SAVE-UNDER WINDOW) VALUE)
-
-
-
-;; Here's a list of the CLX functions that don't directly correspond to 
-;; X Window System requests.  The've been categorized by function:
-
-					   ;Display Management
-CLOSE-DISPLAY
-CLOSE-DOWN-MODE
-DISPLAY-AFTER-FUNCTION ;; SETF'able
-DISPLAY-FINISH-OUTPUT
-DISPLAY-FORCE-OUTPUT
-DISPLAY-INVOKE-AFTER-FUNCTION
-OPEN-DISPLAY
-WITH-DISPLAY
-WITH-EVENT-QUEUE
-					   ;Extensions
-DECLARE-EVENT
-DECODE-CORE-ERROR
-DEFAULT-ERROR-HANDLER
-DEFINE-CONDITION
-DEFINE-ERROR
-DEFINE-EXTENSION
-DEFINE-GCONTEXT-ACCESSOR
-EXTENSION-OPCODE
-					   ;Events
-EVENT-CASE
-EVENT-LISTEN
-MAPPING-NOTIFY
-PROCESS-EVENT
-EVENT-HANDLER
-MAKE-EVENT-HANDLERS
-QUEUE-EVENT
-					   ;Image
-COPY-IMAGE
-CREATE-IMAGE
-GET-IMAGE
-IMAGE-BLUE-MASK
-IMAGE-DEPTH
-IMAGE-GREEN-MASK
-IMAGE-HEIGHT
-IMAGE-NAME
-IMAGE-PIXMAP
-IMAGE-PLIST
-IMAGE-RED-MASK
-IMAGE-WIDTH
-IMAGE-X-HOT
-IMAGE-Y-HOT
-PUT-IMAGE
-READ-BITMAP-FILE
-WRITE-BITMAP-FILE
-					   ;Keysyms
-CHARACTER->KEYSYMS
-CHARACTER-IN-MAP-P
-DEFAULT-KEYSYM-INDEX
-DEFAULT-KEYSYM-TRANSLATE
-DEFINE-KEYSYM
-DEFINE-KEYSYM-SET
-KEYCODE->CHARACTER
-KEYCODE->KEYSYM
-KEYSYM
-KEYSYM->CHARACTER
-KEYSYM-IN-MAP-P
-KEYSYM-SET
-UNDEFINE-KEYSYM
-					   ;Properties
-CUT-BUFFER
-GET-STANDARD-COLORMAP
-GET-WM-CLASS
-ICON-SIZES
-MAKE-WM-HINTS
-MAKE-WM-SIZE-HINTS
-ROTATE-CUT-BUFFERS
-SET-STANDARD-COLORMAP
-SET-WM-CLASS
-TRANSIENT-FOR
-WM-CLIENT-MACHINE
-WM-COMMAND
-WM-HINTS
-WM-HINTS-FLAGS
-WM-HINTS-ICON-MASK
-WM-HINTS-ICON-PIXMAP
-WM-HINTS-ICON-WINDOW
-WM-HINTS-ICON-X
-WM-HINTS-ICON-Y
-WM-HINTS-INITIAL-STATE
-WM-HINTS-INPUT
-WM-HINTS-P
-WM-HINTS-WINDOW-GROUP
-WM-ICON-NAME
-WM-NAME
-WM-NORMAL-HINTS
-WM-SIZE-HINTS-HEIGHT
-WM-SIZE-HINTS-HEIGHT-INC
-WM-SIZE-HINTS-MAX-ASPECT
-WM-SIZE-HINTS-MAX-HEIGHT
-WM-SIZE-HINTS-MAX-WIDTH
-WM-SIZE-HINTS-MIN-ASPECT
-WM-SIZE-HINTS-MIN-HEIGHT
-WM-SIZE-HINTS-MIN-WIDTH
-WM-SIZE-HINTS-P
-WM-SIZE-HINTS-USER-SPECIFIED-POSITION-P
-WM-SIZE-HINTS-USER-SPECIFIED-SIZE-P
-WM-SIZE-HINTS-WIDTH
-WM-SIZE-HINTS-WIDTH-INC
-WM-SIZE-HINTS-X
-WM-SIZE-HINTS-Y
-WM-ZOOM-HINTS
-					   ;Misc.
-MAKE-COLOR
-MAKE-EVENT-KEYS
-MAKE-EVENT-MASK
-MAKE-RESOURCE-DATABASE
-MAKE-STATE-KEYS
-MAKE-STATE-MASK
-DISCARD-FONT-INFO
-TRANSLATE-DEFAULT
-					   ;Structures
-BITMAP-FORMAT-LSB-FIRST-P
-BITMAP-FORMAT-P
-BITMAP-FORMAT-PAD
-BITMAP-FORMAT-UNIT
-BITMAP-IMAGE
-
-COLOR-BLUE
-COLOR-GREEN
-COLOR-P
-COLOR-RED
-COLOR-RGB
-COLORMAP-DISPLAY
-COLORMAP-EQUAL
-COLORMAP-ID
-COLORMAP-P
-COLORMAP-VISUAL-INFO
-
-CURSOR-DISPLAY
-CURSOR-EQUAL
-CURSOR-ID
-CURSOR-P
-
-DRAWABLE-DISPLAY
-DRAWABLE-EQUAL
-DRAWABLE-ID
-DRAWABLE-P
-
-FONT-DISPLAY
-FONT-EQUAL
-FONT-ID
-FONT-MAX-BOUNDS
-FONT-MIN-BOUNDS
-FONT-P
-FONT-PLIST
-
-GCONTEXT-DISPLAY
-GCONTEXT-EQUAL
-GCONTEXT-ID
-GCONTEXT-P
-GCONTEXT-PLIST
-
-DISPLAY-AUTHORIZATION-DATA
-DISPLAY-AUTHORIZATION-NAME
-DISPLAY-BITMAP-FORMAT
-DISPLAY-BYTE-ORDER
-DISPLAY-DEFAULT-SCREEN
-DISPLAY-DISPLAY
-DISPLAY-ERROR-HANDLER
-DISPLAY-IMAGE-LSB-FIRST-P
-DISPLAY-KEYCODE-RANGE
-DISPLAY-MAX-KEYCODE
-DISPLAY-MAX-REQUEST-LENGTH
-DISPLAY-MIN-KEYCODE
-DISPLAY-MOTION-BUFFER-SIZE
-DISPLAY-NSCREENS
-DISPLAY-P
-DISPLAY-PIXMAP-FORMATS
-DISPLAY-PLIST
-DISPLAY-PROTOCOL-MAJOR-VERSION
-DISPLAY-PROTOCOL-MINOR-VERSION
-DISPLAY-PROTOCOL-VERSION
-DISPLAY-RELEASE-NUMBER
-DISPLAY-RESOURCE-ID-BASE
-DISPLAY-RESOURCE-ID-MASK
-DISPLAY-ROOTS
-DISPLAY-SQUISH
-DISPLAY-VENDOR
-DISPLAY-VENDOR-NAME
-DISPLAY-VERSION-NUMBER
-DISPLAY-XDEFAULTS
-DISPLAY-XID
-
-PIXMAP-DISPLAY
-PIXMAP-EQUAL
-PIXMAP-FORMAT-BITS-PER-PIXEL
-PIXMAP-FORMAT-DEPTH
-PIXMAP-FORMAT-P
-PIXMAP-FORMAT-SCANLINE-PAD
-PIXMAP-ID
-PIXMAP-P
-PIXMAP-PLIST
-
-SCREEN-BACKING-STORES
-SCREEN-BLACK-PIXEL
-SCREEN-DEFAULT-COLORMAP
-SCREEN-DEPTHS
-SCREEN-EVENT-MASK-AT-OPEN
-SCREEN-HEIGHT
-SCREEN-HEIGHT-IN-MILLIMETERS
-SCREEN-MAX-INSTALLED-MAPS
-SCREEN-MIN-INSTALLED-MAPS
-SCREEN-P
-SCREEN-PLIST
-SCREEN-ROOT
-SCREEN-ROOT-DEPTH
-SCREEN-ROOT-VISUAL-INFO
-SCREEN-SAVE-UNDERS-P
-SCREEN-WHITE-PIXEL
-SCREEN-WIDTH
-SCREEN-WIDTH-IN-MILLIMETERS
-
-VISUAL-INFO
-VISUAL-INFO-BITS-PER-RGB
-VISUAL-INFO-BLUE-MASK
-VISUAL-INFO-CLASS
-VISUAL-INFO-COLORMAP-ENTRIES
-VISUAL-INFO-GREEN-MASK
-VISUAL-INFO-ID
-VISUAL-INFO-P
-VISUAL-INFO-PLIST
-VISUAL-INFO-RED-MASK
-
-WINDOW-DISPLAY
-WINDOW-EQUAL
-WINDOW-ID
-WINDOW-P
-WINDOW-PLIST
diff --git a/clx/exclMakefile b/clx/exclMakefile
deleted file mode 100644
index bd0c93671d47f99086d767b22529d714ae3847f9..0000000000000000000000000000000000000000
--- a/clx/exclMakefile
+++ /dev/null
@@ -1,168 +0,0 @@
-# 
-#  Makefile for CLX
-#  (X11 R4.4 release, Franz Allegro Common Lisp version)
-#
-
-# *************************************************************************
-# * Change the next line to point to where you have Common Lisp installed *
-# *        (make sure the Lisp doesn't already have CLX loaded in)        *
-# *************************************************************************
-CL	= /usr/local/bin/cl
-
-RM	= /bin/rm
-SHELL	= /bin/sh
-ECHO	= /bin/echo
-TAGS	= /usr/local/lib/emacs/etc/etags
-
-# Name of dumped lisp
-CLX	= CLX
-
-CLOPTS	= -qq
-
-# Use this one for Suns
-CFLAGS	= -O -DUNIXCONN
-# Use this one for Silicon Graphics & Mips Inc MIPS based machines
-# CFLAGS = -O -G 0 -I/usr/include/bsd
-# Use this one for DEC MIPS based machines
-# CFLAGS = -O -G 0 -DUNIXCONN
-# Use this one for HP machines
-# CFLAGS = -O -DSYSV -DUNIXCONN
-
-
-# Lisp optimization for compiling
-SPEED	= 3
-SAFETY	= 0
-
-
-C_SRC	= excldep.c socket.c
-C_OBJS	= excldep.o socket.o
-
-L_OBJS	= defsystem.fasl package.fasl excldep.fasl depdefs.fasl clx.fasl \
-	dependent.fasl exclcmac.fasl macros.fasl bufmac.fasl buffer.fasl \
-	display.fasl gcontext.fasl requests.fasl input.fasl fonts.fasl \
-	graphics.fasl text.fasl attributes.fasl translate.fasl keysyms.fasl \
-	manager.fasl image.fasl resource.fasl
-
-L_NOMACROS_OBJS	= package.fasl excldep.fasl depdefs.fasl clx.fasl \
-	dependent.fasl buffer.fasl display.fasl gcontext.fasl \
-	requests.fasl input.fasl fonts.fasl graphics.fasl text.fasl \
-	attributes.fasl translate.fasl keysyms.fasl manager.fasl image.fasl \
-	resource.fasl
-
-L_SRC	= defsystem.cl package.cl excldep.cl depdefs.cl clx.cl \
-	dependent.cl exclcmac.cl macros.cl bufmac.cl buffer.cl \
-	display.cl gcontext.cl requests.cl input.cl fonts.cl \
-	graphics.cl text.cl attributes.cl translate.cl keysyms.cl \
-	manager.cl image.cl resource.cl
-
-# default and aliases
-all:	no-clos
-# all:	partial-clos
-compile-CLX-for-CLUE:	compile-partial-clos-CLX
-clue:	partial-clos
-
-#
-# Three build rules are provided: no-clos, partial-clos, and full-clos.
-# The first is no-clos, which results in a CLX whose datastructures are
-# all defstructs.  partial-clos results in xlib:window, xlib:pixmap, and
-# xlib:drawable being CLOS instances, all others defstructs.  full-clos
-# makes all CLX complex datatypes into CLOS instances.
-#
-# (note that the :clos feature implies native CLOS *not* PCL).
-#
-
-no-clos:	$(C_OBJS) compile-no-clos-CLX cat
-
-#
-# This rule is used to compile CLX to be used with XCW version 2, or CLUE.
-#
-partial-clos:	$(C_OBJS) compile-partial-clos-CLX cat
-
-full-clos:	$(C_OBJS) compile-full-clos-CLX cat
-
-
-c:	$(C_OBJS)
-
-
-compile-no-clos-CLX:	$(C_OBJS)
-	$(ECHO) " \
-	(set-case-mode :case-sensitive-lower) \
-	(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
-	#+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \
-	(load \"defsystem\") \
-	#+allegro (compile-system :clx) \
-	#-allegro (compile-clx) \
-	#+allegro (compile-system :clx-debug)" \
-	| $(CL) $(CLOPTS) -batch
-
-compile-partial-clos-CLX:	$(C_OBJS)
-	$(ECHO) " \
-	#+clos (set-case-mode :case-sensitive-lower) \
-	#-clos (setq excl::*print-nickname* t) \
-	(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
-	(unless (or (find-package 'clos) (find-package 'pcl)) \
-	  (let ((spread (sys:gsgc-parameter :generation-spread))) \
-	    (setf (sys:gsgc-parameter :generation-spread) 1) \
-	    (require :pcl) \
-	    (provide :pcl) \
-	    (gc) (gc) \
-	    (setf (sys:gsgc-parameter :generation-spread) spread))) \
-	#+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \
-	(load \"defsystem\") \
-	(load \"package\") \
-	(setq xlib::*def-clx-class-use-defclass* '(xlib:window xlib:pixmap xlib:drawable)) \
-	#+allegro (compile-system :clx) \
-	#-allegro (compile-clx \"\" \"\" :for-clue t) \
-	#+allegro (compile-system :clx-debug)" \
-	| $(CL) $(CLOPTS) -batch
-
-compile-full-clos-CLX:	$(C_OBJS)
-	$(ECHO) " \
-	#+clos (set-case-mode :case-sensitive-lower) \
-	#-clos (setq excl::*print-nickname* t) \
-	(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
-	(unless (or (find-package 'clos) (find-package 'pcl)) \
-	  (let ((spread (sys:gsgc-parameter :generation-spread))) \
-	    (setf (sys:gsgc-parameter :generation-spread) 1) \
-	    (require :pcl) \
-	    (provide :pcl) \
-	    (gc) (gc) \
-	    (setf (sys:gsgc-parameter :generation-spread) spread))) \
-	#+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \
-	(load \"defsystem\") \
-	(load \"package\") \
-	(setq xlib::*def-clx-class-use-defclass* t) \
-	#+allegro (compile-system :clx) \
-	#-allegro (compile-clx \"\" \"\" :for-clue t) \
-	#+allegro (compile-system :clx-debug)" \
-	| $(CL) $(CLOPTS) -batch
-
-
-cat:
-	-cat $(L_NOMACROS_OBJS) > CLX.fasl
-
-
-load-CLX:
-	$(ECHO) " \
-	(let ((spread (sys:gsgc-parameter :generation-spread))) \
-	  (setf (sys:gsgc-parameter :generation-spread) 1) \
-	  (load \"defsystem\") \
-	  #+allegro (load-system :clx) \
-	  #-allegro (load-clx) \
-	  (gc :tenure) \
-	  (setf (sys:gsgc-parameter :generation-spread) spread)) \
-	(gc t)" \
-	'(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \
-	"(exit)" | $(CL) $(CLOPTS)
-
-clean:
-	$(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS) make.out
-
-
-install:
-	mv CLX.fasl $(DEST)/clx.fasl
-	mv *.o $(DEST)
-
-
-tags:
-	$(TAGS) $(L_SRC) $(C_SRC)
diff --git a/clx/exclREADME b/clx/exclREADME
deleted file mode 100644
index c99e388e0cb3d307ab282b1eac73fc74c99886b5..0000000000000000000000000000000000000000
--- a/clx/exclREADME
+++ /dev/null
@@ -1,56 +0,0 @@
-     This file contains instructions on how to make CLX work with Franz
-Common Lisp.  CLX should work on any machine that supports Allegro Common
-Lisp version 3.0.1 or greater.  It also works under ExCL version 2.0.10.
-However it has been tested extensively with only Allegro CL versions 3.0,
-3.1, and 4.0.
-
-     There are three steps to compile and install CLX.  The first is simply
-moving files around.  In this directory, execute (assuming you using csh):
-
-% foreach i (*.l */*.l)
-? mv $i $i:r.cl
-? end
-% mv exclMakefile Makefile
-
-     The second is compiling the source files into fasl files.  The fasl files
-will be combined into one big fasl file, CLX.fasl.  This file is then installed
-in your Common Lisp library directory in the next step.  You may need to edit
-the Makefile to select the proper CFLAGS for your machine -- look in Makefile
-for examples.  Then just:
-
-% make
-
-     Now you must move the CLX.fasl file into the standard CL library.
-This is normally "/usr/local/lib/cl/code", but you can find out for sure
-by typing:
-
-<cl> (directory-namestring excl::*library-code-pathname*)
-
-to a running Lisp.  If it prints something other than "/usr/local/lib/cl/code"
-substitute what it prints in the below instructions.
-
-% mv CLX.fasl /usr/local/lib/cl/code/clx.fasl
-% mv *.o /usr/local/lib/cl/code
-
-Now you can just start up Lisp and type:
-
-<cl> (load "clx")
-
-to load in CLX.  You may want to dump a lisp at this point since CLX is a large
-package and can take some time to load into Lisp.  You probably also want to
-set the :generation-spread to 1 while loading CLX.  Please see your Allegro CL
-User Guide for more information on :generation-spread.
-
-
-     Sophisticated users may wish to peruse the Makefile and defsystem.cl
-and note how things are set up.  For example we hardwire the compiler
-interrupt check switch on, so that CL can still be interrupted while it
-is reading from the X11 socket.  Please see chapter 7 of the CL User's
-guide for more information on compiler switches and their effects.
-
-
-Please report Franz specific CLX bugs to:
-
-	ucbvax!franz!bugs
-	       or
-	 bugs@Franz.COM
diff --git a/clx/exclcmac.lisp b/clx/exclcmac.lisp
deleted file mode 100644
index 04fd20af87020531a2341a6b0cf82dff28a9aad0..0000000000000000000000000000000000000000
--- a/clx/exclcmac.lisp
+++ /dev/null
@@ -1,260 +0,0 @@
-;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
-;;;
-;;; CLX -- exclcmac.cl
-;;;           This file provides for inline expansion of some functions.
-;;;
-;;; Copyright (c) 1989 Franz Inc, Berkeley, Ca.
-;;;
-;;; Permission is granted to any individual or institution to use, copy,
-;;; modify, and distribute this software, provided that this complete
-;;; copyright and permission notice is maintained, intact, in all copies and
-;;; supporting documentation.
-;;;
-;;; Franz Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-;;
-;; Type predicates
-;;
-(excl:defcmacro card8p (x)
-  (let ((xx (gensym)))
-    `(let ((,xx ,x))
-       (declare (optimize (speed 3) (safety 0))
-		(fixnum ,xx))
-       (and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0)))))
-
-(excl:defcmacro card16p (x)
-  (let ((xx (gensym)))
-    `(let ((,xx ,x))
-       (declare (optimize (speed 3) (safety 0))
-		(fixnum ,xx))
-       (and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0)))))
-
-(excl:defcmacro int8p (x)
-  (let ((xx (gensym)))
-    `(let ((,xx ,x))
-       (declare (optimize (speed 3) (safety 0))
-		(fixnum ,xx))
-       (and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7))))))
-
-(excl:defcmacro int16p (x)
-  (let ((xx (gensym)))
-    `(let ((,xx ,x))
-       (declare (optimize (speed 3) (safety 0))
-		(fixnum ,xx))
-       (and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15))))))
-
-;; Card29p, card32p, int32p are too large to expand inline
-
-
-;;
-;; Type transformers
-;;
-(excl:defcmacro card8->int8 (x)
-  (let ((xx (gensym)))
-    `(let ((,xx ,x))
-       ,(declare-bufmac)
-       (declare (type card8 ,xx))
-       (the int8 (if (logbitp 7 ,xx)
-		     (the int8 (- ,xx #x100))
-		   ,xx)))))
-(excl:defcmacro int8->card8 (x)
-  `(locally ,(declare-bufmac)
-     (the card8 (ldb (byte 8 0) (the int8 ,x)))))
-
-(excl:defcmacro card16->int16 (x)
-  (let ((xx (gensym)))
-    `(let ((,xx ,x))
-       ,(declare-bufmac)
-       (declare (type card16 ,xx))
-       (the int16 (if (logbitp 15 ,xx)
-		      (the int16 (- ,xx #x10000))
-		    ,xx)))))
-
-(excl:defcmacro int16->card16 (x)
-  `(locally ,(declare-bufmac)
-     (the card16 (ldb (byte 16 0) (the int16 ,x)))))
-
-(excl:defcmacro card32->int32 (x)
-  (let ((xx (gensym)))
-    `(let ((,xx ,x))
-       ,(declare-bufmac)
-       (declare (type card32 ,xx))
-       (the int32 (if (logbitp 31 ,xx)
-		      (the int32 (- ,xx #x100000000))
-		    ,xx)))))
-
-(excl:defcmacro int32->card32 (x)
-  `(locally ,(declare-bufmac)
-     (the card32 (ldb (byte 32 0) (the int32 ,x)))))
-
-(excl:defcmacro char->card8 (char)
-  `(locally ,(declare-bufmac)
-     (the card8 (char-code (the string-char ,char)))))
-
-(excl:defcmacro card8->char (card8)
-  `(locally ,(declare-bufmac)
-     (the string-char (code-char (the card8 ,card8)))))
-
-
-;;
-;; Array accessors and setters
-;;
-(excl:defcmacro aref-card8 (a i)
-  `(locally ,(declare-bufmac)
-     (the card8 (sys:memref (the buffer-bytes ,a)
-			    #.(comp::mdparam 'comp::md-svector-data0-adj)
-			    (the array-index ,i)
-			    :unsigned-byte))))
-  
-(excl:defcmacro aset-card8 (v a i)
-  `(locally ,(declare-bufmac)
-     (setf (sys:memref (the buffer-bytes ,a)
-		       #.(comp::mdparam 'comp::md-svector-data0-adj)
-		       (the array-index ,i)
-		       :unsigned-byte)
-	   (the card8 ,v))))
-  
-(excl:defcmacro aref-int8 (a i)
-  `(locally ,(declare-bufmac)
-     (the int8 (sys:memref (the buffer-bytes ,a)
-			   #.(comp::mdparam 'comp::md-svector-data0-adj)
-			   (the array-index ,i)
-			   :signed-byte))))
-  
-(excl:defcmacro aset-int8 (v a i)
-  `(locally ,(declare-bufmac)
-     (setf (sys:memref (the buffer-bytes ,a)
-		       #.(comp::mdparam 'comp::md-svector-data0-adj)
-		       (the array-index ,i)
-		       :signed-byte)
-       (the int8 ,v))))
-
-(excl:defcmacro aref-card16 (a i)
-  `(locally ,(declare-bufmac)
-     (the card16 (sys:memref (the buffer-bytes ,a)
-			     #.(comp::mdparam 'comp::md-svector-data0-adj)
-			     (the array-index ,i)
-			     :unsigned-word))))
-  
-(excl:defcmacro aset-card16 (v a i)
-  `(locally ,(declare-bufmac)
-     (setf (sys:memref (the buffer-bytes ,a)
-		       #.(comp::mdparam 'comp::md-svector-data0-adj)
-		       (the array-index ,i)
-		       :unsigned-word)
-	   (the card16 ,v))))
-  
-(excl:defcmacro aref-int16 (a i)
-  `(locally ,(declare-bufmac)
-     (the int16 (sys:memref (the buffer-bytes ,a)
-			    #.(comp::mdparam 'comp::md-svector-data0-adj)
-			    (the array-index ,i)
-			    :signed-word))))
-  
-(excl:defcmacro aset-int16 (v a i)
-  `(locally ,(declare-bufmac)
-     (setf (sys:memref (the buffer-bytes ,a)
-		       #.(comp::mdparam 'comp::md-svector-data0-adj)
-		       (the array-index ,i)
-		       :signed-word)
-       (the int16 ,v))))
-  
-(excl:defcmacro aref-card32 (a i)
-  `(locally ,(declare-bufmac)
-     (the card32 (sys:memref (the buffer-bytes ,a)
-			     #.(comp::mdparam 'comp::md-svector-data0-adj)
-			     (the array-index ,i)
-			     :unsigned-long))))
-    
-(excl:defcmacro aset-card32 (v a i)
-  `(locally ,(declare-bufmac)
-     (setf (sys:memref (the buffer-bytes ,a)
-		       #.(comp::mdparam 'comp::md-svector-data0-adj)
-		       (the array-index ,i)
-		       :unsigned-long)
-       (the card32 ,v))))
-
-(excl:defcmacro aref-int32 (a i)
-  `(locally ,(declare-bufmac)
-     (the int32 (sys:memref (the buffer-bytes ,a)
-			    #.(comp::mdparam 'comp::md-svector-data0-adj)
-			    (the array-index ,i)
-			    :signed-long))))
-    
-(excl:defcmacro aset-int32 (v a i)
-  `(locally ,(declare-bufmac)
-     (setf (sys:memref (the buffer-bytes ,a)
-		       #.(comp::mdparam 'comp::md-svector-data0-adj)
-		       (the array-index ,i)
-		       :signed-long)
-       (the int32 ,v))))
-
-(excl:defcmacro aref-card29 (a i)
-  ;; Don't need to mask bits here since X protocol guarantees top bits zero
-  `(locally ,(declare-bufmac)
-     (the card29 (sys:memref (the buffer-bytes ,a)
-			     #.(comp::mdparam 'comp::md-svector-data0-adj)
-			     (the array-index ,i)
-			     :unsigned-long))))
-
-(excl:defcmacro aset-card29 (v a i)
-  ;; I also assume here Lisp is passing a number that fits in 29 bits.
-  `(locally ,(declare-bufmac)
-     (setf (sys:memref (the buffer-bytes ,a)
-		       #.(comp::mdparam 'comp::md-svector-data0-adj)
-		       (the array-index ,i)
-		       :unsigned-long)
-       (the card29 ,v))))
-
-;;
-;; Font accessors
-;;
-(excl:defcmacro font-id (font)
-  ;; Get font-id, opening font if needed
-  (let ((f (gensym)))
-    `(let ((,f ,font))
-       (or (font-id-internal ,f)
-	   (open-font-internal ,f)))))
-
-(excl:defcmacro font-font-info (font)
-  (let ((f (gensym)))
-    `(let ((,f ,font))
-       (or (font-font-info-internal ,f)
-	   (query-font ,f)))))
-
-(excl:defcmacro font-char-infos (font)
-  (let ((f (gensym)))
-    `(let ((,f ,font))
-       (or (font-char-infos-internal ,f)
-	   (progn (query-font ,f)
-		  (font-char-infos-internal ,f))))))
-
-
-;;
-;; Miscellaneous
-;;
-(excl:defcmacro current-process ()
-  `(the (or mp::process null) (and mp::*scheduler-stack-group*
-				  mp::*current-process*)))
-
-(excl:defcmacro process-wakeup (process)
-  (let ((proc (gensym)))
-    `(let ((.pw-curproc. mp::*current-process*)
-	   (,proc ,process))
-       (when (and .pw-curproc. ,proc)
-	 (if (> (mp::process-priority ,proc)
-		(mp::process-priority .pw-curproc.))
-	     (mp::process-allow-schedule ,proc))))))
-
-(excl:defcmacro buffer-new-request-number (buffer)
-  (let ((buf (gensym)))
-    `(let ((,buf ,buffer))
-       (declare (type buffer ,buf))
-       (setf (buffer-request-number ,buf)
-	 (ldb (byte 16 0) (1+ (buffer-request-number ,buf)))))))
-
-
diff --git a/clx/excldefsys.lisp b/clx/excldefsys.lisp
deleted file mode 100644
index abbc5dc7135111047aee6bc8d6d918ed37389bac..0000000000000000000000000000000000000000
--- a/clx/excldefsys.lisp
+++ /dev/null
@@ -1,186 +0,0 @@
-;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
-;;;
-;;; Copyright (c) 1988, 1989 Franz Inc, Berkeley, Ca.
-;;;
-;;; Permission is granted to any individual or institution to use, copy,
-;;; modify, and distribute this software, provided that this complete
-;;; copyright and permission notice is maintained, intact, in all copies and
-;;; supporting documentation.
-;;;
-;;; Franz Incorporated provides this software "as is" without express or
-;;; implied warranty.
-;;;
-
-(in-package :xlib :use '(:foreign-functions :lisp :excl))
-
-#+allegro
-(require :defsystem "defsys")
-
-(eval-when (load)
-  (require :clxexcldep "excldep"))
-
-;;
-;; The following is a suggestion.  If you comment out this form be
-;; prepared for possible deadlock, since no interrupts will be recognized
-;; while reading from the X socket if the scheduler is not running.
-;;
-(setq compiler::generate-interrupt-checks-switch
-  (compile nil '(lambda (safety size speed)
-		   (declare (ignore size))
-		  (or (< speed 3) (> safety 0)))))
-
-
-#+allegro
-(excl:defsystem :clx
-    ()
-  |depdefs|
-  (|clx| :load-before-compile (|depdefs|)
-	 :recompile-on (|depdefs|))
-  (|dependent| :load-before-compile (|depdefs| |clx|)
-	       :recompile-on (|clx|))
-  (|exclcmac| :load-before-compile (|depdefs| |clx| |dependent|)
-	      :recompile-on (|dependent|))
-  (|macros| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|)
-	    :recompile-on (|exclcmac|))
-  (|bufmac| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					    |macros|)
-	    :recompile-on (|macros|))
-  (|buffer| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					    |macros| |bufmac|)
-	    :recompile-on (|bufmac|))
-  (|display| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					     |macros| |bufmac| |buffer|)
-	     :recompile-on (|buffer|))
-  (|gcontext| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					      |macros| |bufmac| |buffer|
-					      |display|)
-	      :recompile-on (|display|))
-  (|input| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					   |macros| |bufmac| |buffer| |display|
-					   )
-	   :recompile-on (|display|))
-  (|requests| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					      |macros| |bufmac| |buffer|
-					      |display| |input|)
-	      :recompile-on (|display|))
-  (|fonts| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					   |macros| |bufmac| |buffer| |display|
-					   )
-	   :recompile-on (|display|))
-  (|graphics| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					      |macros| |bufmac| |buffer|
-					      |display| |fonts|)
-	      :recompile-on (|fonts|))
-  (|text| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros|
-					  |bufmac| |buffer| |display|
-					  |gcontext| |fonts|)
-	  :recompile-on (|gcontext| |fonts|)
-	  :load-after (|translate|))
-  ;; The above line gets around a compiler macro expansion bug.
-  
-  (|attributes| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-						|macros| |bufmac| |buffer|
-						|display|)
-		:recompile-on (|display|))
-  (|translate| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					       |macros| |bufmac| |buffer|
-					       |display| |text|)
-	       :recompile-on (|display|))
-  (|keysyms| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					     |macros| |bufmac| |buffer|
-					     |display| |translate|)
-	     :recompile-on (|translate|))
-  (|manager| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					     |macros| |bufmac| |buffer|
-					     |display|)
-	     :recompile-on (|display|))
-  (|image| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					   |macros| |bufmac| |buffer| |display|
-					   )
-	   :recompile-on (|display|))
-  
-  ;; Don't know if l-b-c list is correct.  XX
-  (|resource| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
-					      |macros| |bufmac| |buffer|
-					      |display|)
-	      :recompile-on (|display|))
-  )
-
-#+allegro
-(excl:defsystem :clx-debug
-    (:default-pathname "debug/"
-     :needed-systems (:clx)
-     :load-before-compile (:clx))
-  |describe| |keytrans| |trace| |util|)
-
-
-(defun compile-clx (&optional pathname-defaults)
-  (let ((*default-pathname-defaults*
-	  (or pathname-defaults *default-pathname-defaults*)))
-    (declare (special *default-pathname-defaults*))
-    (compile-file "depdefs")
-    (load "depdefs")
-    (compile-file "clx")
-    (load "clx")
-    (compile-file "dependent")
-    (load "dependent")
-    (compile-file "macros")
-    (load "macros")
-    (compile-file "bufmac")
-    (load "bufmac")
-    (compile-file "buffer")
-    (load "buffer")
-    (compile-file "display")
-    (load "display")
-    (compile-file "gcontext")
-    (load "gcontext")
-    (compile-file "input")
-    (load "input")
-    (compile-file "requests")
-    (load "requests")
-    (compile-file "fonts")
-    (load "fonts")
-    (compile-file "graphics")
-    (load "graphics")
-    (compile-file "text")
-    (load "text")
-    (compile-file "attributes")
-    (load "attributes")
-    (load "translate")
-    (compile-file "translate")		; work-around bug in 2.0 and 2.2
-    (load "translate")
-    (compile-file "keysyms")
-    (load "keysyms")
-    (compile-file "manager")
-    (load "manager")
-    (compile-file "image")
-    (load "image")
-    (compile-file "resource")
-    (load "resource")
-    ))
-
-
-(defun load-clx (&optional pathname-defaults)
-  (let ((*default-pathname-defaults*
-	  (or pathname-defaults *default-pathname-defaults*)))
-    (declare (special *default-pathname-defaults*))
-    (load "depdefs")
-    (load "clx")
-    (load "dependent")
-    (load "macros")
-    (load "bufmac")
-    (load "buffer")
-    (load "display")
-    (load "gcontext")
-    (load "input")
-    (load "requests")
-    (load "fonts")
-    (load "graphics")
-    (load "text")
-    (load "attributes")
-    (load "translate")
-    (load "keysyms")
-    (load "manager")
-    (load "image")
-    (load "resource")
-    ))
diff --git a/clx/excldep.c b/clx/excldep.c
deleted file mode 100644
index c6fe25c6442a5f85b0dcf312c07046a8ead776d1..0000000000000000000000000000000000000000
--- a/clx/excldep.c
+++ /dev/null
@@ -1,73 +0,0 @@
-/*
- * Allegro CL dependent C helper routines for CLX
- */
-
-/*
- * This code requires select and interval timers.
- * This means you probably need BSD, or a version
- * of Unix with select and interval timers added.
- */
-
-#include <sys/types.h>
-#include <sys/errno.h>
-#include <sys/time.h>
-#include <stdio.h>
-
-#define ERROR -1
-#define INTERRUPT -2
-#define TIMEOUT 0
-#define SUCCESS 1
-
-#ifdef FD_SETSIZE
-#define NUMBER_OF_FDS FD_SETSIZE	/* Highest possible file descriptor */
-#else
-#define NUMBER_OF_FDS 32
-#endif
-
-/* Length of array needed to hold all file descriptor bits */
-#define CHECKLEN ((NUMBER_OF_FDS+8*sizeof(int)-1) / (8 * sizeof(int)))
-
-extern int errno;
-
-/*
- * This function waits for input to become available on 'fd'.  If timeout is
- * 0, wait forever.  Otherwise wait 'timeout' seconds.  If input becomes
- * available before the timer expires, return SUCCESS.  If the timer expires
- * return TIMEOUT.  If an error occurs, return ERROR.  If an interrupt occurs
- * while waiting, return INTERRUPT.
- */
-int fd_wait_for_input(fd, timeout)
-    register int fd;
-    register int timeout;
-{
-    struct timeval timer;
-    register int i;
-    int checkfds[CHECKLEN];
-
-    if (fd < 0 || fd >= NUMBER_OF_FDS) {
-	fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd);
-	fflush(stderr);
-    }
-
-    for (i = 0; i < CHECKLEN; i++)
-      checkfds[i] = 0;
-    checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int)));
-
-    if (timeout) {
-	timer.tv_sec = timeout;
-	timer.tv_usec = 0;
-	i = select(32, checkfds, (int *)0, (int *)0, &timer);
-    } else
-      i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0);
-
-    if (i < 0)
-      /* error condition */
-      if (errno == EINTR)
-	return (INTERRUPT);
-      else
-	return (ERROR);
-    else if (i == 0)
-      return (TIMEOUT);
-    else
-      return (SUCCESS);
-}
diff --git a/clx/excldep.lisp b/clx/excldep.lisp
deleted file mode 100644
index e6e59d2da147eb5217811bc578e8e277db4daa64..0000000000000000000000000000000000000000
--- a/clx/excldep.lisp
+++ /dev/null
@@ -1,449 +0,0 @@
-;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
-;;;
-;;; CLX -- excldep.cl
-;;;
-;;; Copyright (c) 1987, 1988, 1989 Franz Inc, Berkeley, Ca.
-;;;
-;;; Permission is granted to any individual or institution to use, copy,
-;;; modify, and distribute this software, provided that this complete
-;;; copyright and permission notice is maintained, intact, in all copies and
-;;; supporting documentation.
-;;;
-;;; Franz Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-(eval-when (compile load eval)
-  (require :foreign)
-  (require :process)			; Needed even if scheduler is not
-					; running.  (Must be able to make
-					; a process-lock.)
-  )
-
-(eval-when (load)
-  (provide :clx))
-
-
-#-(or little-endian big-endian)
-(eval-when (eval compile load)
-  (let ((x '#(1)))
-    (if (not (eq 0 (sys::memref x
-				#.(comp::mdparam 'comp::md-svector-data0-adj)
-				0 :unsigned-byte)))
-	(pushnew :little-endian *features*)
-      (pushnew :big-endian *features*))))
-
-
-(defmacro correct-case (string)
-  ;; This macro converts the given string to the 
-  ;; current preferred case, or leaves it alone in a case-sensitive mode.
-  (let ((str (gensym)))
-    `(let ((,str ,string))
-       (case excl::*current-case-mode*
-	 (:case-insensitive-lower
-	  (string-downcase ,str))
-	 (:case-insensitive-upper
-	  (string-upcase ,str))
-	 ((:case-sensitive-lower :case-sensitive-upper)
-	  ,str)))))
-
-
-(defconstant type-pred-alist
-    '(#-(version>= 4 1 devel 16)
-      (card8  . card8p)
-      #-(version>= 4 1 devel 16)
-      (card16 . card16p)
-      #-(version>= 4 1 devel 16)
-      (card29 . card29p)
-      #-(version>= 4 1 devel 16)
-      (card32 . card32p)
-      #-(version>= 4 1 devel 16)
-      (int8   . int8p)
-      #-(version>= 4 1 devel 16)
-      (int16  . int16p)
-      #-(version>= 4 1 devel 16)
-      (int32  . int32p)
-      #-(version>= 4 1 devel 16)
-      (mask16 . card16p)
-      #-(version>= 4 1 devel 16)
-      (mask32 . card32p)
-      #-(version>= 4 1 devel 16)
-      (pixel  . card32p)
-      #-(version>= 4 1 devel 16)
-      (resource-id . card29p)
-      #-(version>= 4 1 devel 16)
-      (keysym . card32p)
-      (angle  . anglep)
-      (color  . color-p)
-      (bitmap-format . bitmap-format-p)
-      (pixmap-format . pixmap-format-p)
-      (display  . display-p)
-      (drawable . drawable-p)
-      (window   . window-p)
-      (pixmap   . pixmap-p)
-      (visual-info . visual-info-p)
-      (colormap . colormap-p)
-      (cursor . cursor-p)
-      (gcontext .  gcontext-p)
-      (screen . screen-p)
-      (font . font-p)
-      (image-x . image-x-p)
-      (image-xy . image-xy-p)
-      (image-z . image-z-p)
-      (wm-hints . wm-hints-p)
-      (wm-size-hints . wm-size-hints-p)
-      ))
-
-;; This (if (and ...) t nil) stuff has a purpose -- it lets the old 
-;; sun4 compiler opencode the `and'.
-
-#-(version>= 4 1 devel 16)
-(defun card8p (x)
-  (declare (optimize (speed 3) (safety 0))
-	   (fixnum x))
-  (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0))
-      t
-    nil))
-
-#-(version>= 4 1 devel 16)
-(defun card16p (x)
-  (declare (optimize (speed 3) (safety 0))
-	   (fixnum x))
-  (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0))
-      t
-    nil))
-
-#-(version>= 4 1 devel 16)
-(defun card29p (x)
-  (declare (optimize (speed 3) (safety 0)))
-  (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
-	  (and (excl:bignump x) (> #.(expt 2 29) (the bignum x))
-	       (>= (the bignum x) 0)))
-      t
-    nil))
-
-#-(version>= 4 1 devel 16)
-(defun card32p (x)
-  (declare (optimize (speed 3) (safety 0)))
-  (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
-	  (and (excl:bignump x) (> #.(expt 2 32) (the bignum x))
-	       (>= (the bignum x) 0)))
-      t
-    nil))
-
-#-(version>= 4 1 devel 16)
-(defun int8p (x)
-  (declare (optimize (speed 3) (safety 0))
-	   (fixnum x))
-  (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7)))
-      t
-    nil))
-
-#-(version>= 4 1 devel 16)
-(defun int16p (x)
-  (declare (optimize (speed 3) (safety 0))
-	   (fixnum x))
-  (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15)))
-      t
-    nil))
-
-#-(version>= 4 1 devel 16)
-(defun int32p (x)
-  (declare (optimize (speed 3) (safety 0)))
-  (if (or (excl:fixnump x)
-	  (and (excl:bignump x) (> #.(expt 2 31) (the bignum x))
-	       (>= (the bignum x) #.(expt -2 31))))
-      t
-    nil))
-
-;; This one can be handled better by knowing a little about what we're
-;; testing for.  Plus this version can handle (single-float pi), which
-;; is otherwise larger than pi!
-(defun anglep (x)
-  (declare (optimize (speed 3) (safety 0)))
-  (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi)))
-	       (<= (the fixnum x) #.(truncate (* 2 pi))))
-	  (and (excl::single-float-p x)
-	       (>= (the single-float x) #.(float (* -2 pi) 0.0s0))
-	       (<= (the single-float x) #.(float (* 2 pi) 0.0s0)))
-	  (and (excl::double-float-p x)
-	       (>= (the double-float x) #.(float (* -2 pi) 0.0d0))
-	       (<= (the double-float x) #.(float (* 2 pi) 0.0d0))))
-      t
-    nil))
-
-(eval-when (load eval)
-  #+(version>= 4 1 devel 16)
-  (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt)))
-	  type-pred-alist)
-  #-(version>= 4 1 devel 16)
-  (nconc excl::type-pred-alist type-pred-alist))
-
-
-;; Return t if there is a character available for reading or on error,
-;; otherwise return nil.
-(defun fd-char-avail-p (fd)
-  (multiple-value-bind (available-p errcode)
-      (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)
-    (excl:if* errcode
-       then t
-       else available-p)))
-
-(defmacro with-interrupt-checking-on (&body body)
-  `(locally (declare (optimize (safety 1)))
-     ,@body))
-
-;; Read from the given fd into 'vector', which has element type card8.
-;; Start storing at index 'start-index' and read exactly 'length' bytes.
-;; Return t if an error or eof occurred, nil otherwise.
-(defun fd-read-bytes (fd vector start-index length)
-  (declare (fixnum fd start-index length)
-	   (type (simple-array (unsigned-byte 8) (*)) vector))
-  (with-interrupt-checking-on
-   (do ((rest length))
-       ((eq 0 rest) nil)
-     (declare (fixnum rest))
-     (multiple-value-bind (numread errcode)
-	 (comp::.primcall-sargs 'sys::filesys excl::fs-read-bytes fd vector
-				start-index rest)
-       (declare (fixnum numread))
-       (excl:if* errcode
-	  then (if (not (eq errcode
-			    excl::*error-code-interrupted-system-call*))
-		   (return t))
-	elseif (eq 0 numread)
-	  then (return t)
-	  else (decf rest numread)
-	       (incf start-index numread))))))
-
-
-(when (plusp (ff:get-entry-points
-	      (make-array 1 :initial-contents
-			  (list (ff:convert-to-lang "fd_wait_for_input")))
-	      (make-array 1 :element-type '(unsigned-byte 32))))
-  (ff:remove-entry-point (ff:convert-to-lang "fd_wait_for_input"))
-  (load "excldep.o"))
-
-(when (plusp (ff:get-entry-points
-	      (make-array 1 :initial-contents
-			  (list (ff:convert-to-lang "connect_to_server")))
-	      (make-array 1 :element-type '(unsigned-byte 32))))
-  (ff:remove-entry-point (ff:convert-to-lang "connect_to_server" :language :c))
-  (load "socket.o"))
-
-(ff:defforeign-list `((connect-to-server
-		       :entry-point
-		       ,(ff:convert-to-lang "connect_to_server")
-		       :return-type :fixnum
-		       :arg-checking nil
-		       :arguments (string fixnum))
-		      (fd-wait-for-input
-		       :entry-point ,(ff:convert-to-lang "fd_wait_for_input")
-		       :return-type :fixnum
-		       :arg-checking nil
-		       :call-direct t
-		       :callback nil
-		       :allow-other-keys t
-		       :arguments (fixnum fixnum))))
-
-
-;; special patch for CLX (various process fixes)
-;; patch1000.2
-
-(eval-when (compile load eval)
-  (unless (find-package :patch)
-    (make-package :patch :use '(:lisp :excl))))
-
-(in-package :patch)
-
-(defvar *patches* nil)
-
-#+allegro
-(eval-when (compile eval load)
-  (when (and (= excl::cl-major-version-number 3)
-	     (or (= excl::cl-minor-version-number 0)
-		 (and (= excl::cl-minor-version-number 1)
-		      excl::cl-generation-number
-		      (< excl::cl-generation-number 9))))
-    (push :clx-r4-process-patches *features*)))
-
-#+clx-r4-process-patches
-(push (cons 1000.2 "special patch for CLX (various process fixes)")
-      *patches*)
-
-
-(in-package :mp)
-
-#+clx-r4-process-patches
-(export 'wait-for-input-available)
-
-
-#+clx-r4-process-patches
-(defun with-timeout-event (seconds fnc args)
-  (unless *scheduler-stack-group* (start-scheduler)) ;[spr670]
-  (let ((clock-event (make-clock-event)))
-    (when (<= seconds 0) (setq seconds 0))
-    (multiple-value-bind (secs msecs) (truncate seconds)
-      ;; secs is now a nonegative integer, and msecs is either fixnum zero
-      ;; or else something interesting.
-      (unless (eq 0 msecs)
-	(setq msecs (truncate (* 1000.0 msecs))))
-      ;; Now msecs is also a nonnegative fixnum.
-      (multiple-value-bind (now mnow) (excl::cl-internal-real-time)
-	(incf secs now)
-	(incf msecs mnow)
-	(when (>= msecs 1000)
-	  (decf msecs 1000)
-	  (incf secs))
-	(unless (excl:fixnump secs) (setq secs most-positive-fixnum))
-	(setf (clock-event-secs clock-event) secs
-	      (clock-event-msecs clock-event) msecs
-	      (clock-event-function clock-event) fnc
-	      (clock-event-args clock-event) args)))
-    clock-event))
-
-
-#+clx-r4-process-patches
-(defmacro with-timeout ((seconds &body timeout-body) &body body)
-  `(let* ((clock-event (with-timeout-event ,seconds
-					   #'process-interrupt
-					   (cons *current-process*
-						 '(with-timeout-internal))))
-	  (excl::*without-interrupts* t)
-	  ret)
-     (unwind-protect
-	 ;; Warning: Branch tensioner better not reorder this code!
-	 (setq ret (catch 'with-timeout-internal
-		     (add-to-clock-queue clock-event)
-		     (let ((excl::*without-interrupts* nil))
-		       (multiple-value-list (progn ,@body)))))
-       (excl:if* (eq ret 'with-timeout-internal)
-	  then (let ((excl::*without-interrupts* nil))
-		 (setq ret (multiple-value-list (progn ,@timeout-body))))
-	  else (remove-from-clock-queue clock-event)))
-     (values-list ret)))
-
-
-#+clx-r4-process-patches
-(defun process-lock (lock &optional (lock-value *current-process*)
-				    (whostate "Lock") timeout)
-  (declare (optimize (speed 3)))
-  (unless (process-lock-p lock)
-    (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock))
-  (without-interrupts
-   (excl:if* (null (process-lock-locker lock))
-      then (setf (process-lock-locker lock) lock-value)
-      else (excl:if* timeout
-	      then (excl:if* (or (eq 0 timeout) ;for speed
-				 (zerop timeout))
-		      then nil
-		      else (with-timeout (timeout)
-			     (process-lock-1 lock lock-value whostate)))
-	      else (process-lock-1 lock lock-value whostate)))))
-
-
-#+clx-r4-process-patches
-(defun process-lock-1 (lock lock-value whostate)
-  (declare (type process-lock lock)
-	   (optimize (speed 3)))
-  (let ((process *current-process*))
-    (declare (type process process))
-    (unless process
-      (error
-       "PROCESS-LOCK may not be called on the scheduler's stack group."))
-    (loop (unless (process-lock-locker lock)
-	    (return (setf (process-lock-locker lock) lock-value)))
-      (push process (process-lock-waiting lock))
-      (let ((saved-whostate (process-whostate process)))
-	(unwind-protect
-	    (progn (setf (process-whostate process) whostate)
-		   (process-add-arrest-reason process lock))
-	  (setf (process-whostate process) saved-whostate))))))
-
-
-#+clx-r4-process-patches
-(defun process-wait (whostate function &rest args)
-  (declare (optimize (speed 3)))
-  ;; Run the wait function once here both for efficiency and as a
-  ;; first line check for errors in the function.
-  (unless (apply function args)
-    (process-wait-1 whostate function args)))
-
-
-#+clx-r4-process-patches
-(defun process-wait-1 (whostate function args)
-  (declare (optimize (speed 3)))
-  (let ((process *current-process*))
-    (declare (type process process))
-    (unless process
-      (error
-       "Process-wait may not be called within the scheduler's stack group."))
-    (let ((saved-whostate (process-whostate process)))
-      (unwind-protect
-	  (without-scheduling-internal
-	   (without-interrupts
-	    (setf (process-whostate process) whostate
-		  (process-wait-function process) function
-		  (process-wait-args process) args)
-	    (chain-rem-q process)
-	    (chain-ins-q process *waiting-processes*))
-	   (process-resume-scheduler nil))
-	(setf (process-whostate process) saved-whostate
-	      (process-wait-function process) nil
-	      (process-wait-args process) nil)))))
-
-
-#+clx-r4-process-patches
-(defun process-wait-with-timeout (whostate seconds function &rest args)
-  ;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh
-  ;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code.
-  ;;  -- 28Feb90 smh
-  ;; Run the wait function once here both for efficiency and as a
-  ;; first line check for errors in the function.
-  (excl:if* (apply function args)
-     then t
-     else (let ((ret (list nil)))
-            (without-interrupts
-             (let ((clock-event
-                    (with-timeout-event seconds #'identity '(nil))))
-               (add-to-clock-queue clock-event)
-               (process-wait-1 whostate
-                               #'(lambda (clock-event function args ret)
-                                   (or (null (chain-next clock-event))
-                                       (and (apply function args)
-                                            (setf (car ret) 't))))
-                               (list clock-event function args ret))))
-            (car ret))))
-
-
-;;
-;; Returns nil on timeout, otherwise t.
-;;
-#+clx-r4-process-patches
-(defun wait-for-input-available
-    (stream-or-fd &key (wait-function #'listen)
-		       (whostate "waiting for input")
-		       timeout)
-  (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd
-	     elseif (streamp stream-or-fd)
-	       then (excl::stream-input-fn stream-or-fd)
-	       else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd))))
-    ;; At this point fd could be nil, since stream-input-fn returns nil for
-    ;; streams that are output only, or for certain special purpose streams.
-    (if fd
-	(unwind-protect
-	    (progn
-	      (mp::mpwatchfor fd)
-	      (excl:if* timeout
-		 then (mp::process-wait-with-timeout
-		       whostate timeout wait-function stream-or-fd)
-		 else (mp::process-wait whostate wait-function stream-or-fd)
-		      t))
-	  (mp::mpunwatchfor fd))
-      (excl:if* timeout
-	 then (mp::process-wait-with-timeout
-	       whostate timeout wait-function stream-or-fd)
-	 else (mp::process-wait whostate wait-function stream-or-fd)
-	      t))))
diff --git a/clx/fonts.lisp b/clx/fonts.lisp
deleted file mode 100644
index fe3c995358b2b0a5e54b4f19f16494c5c96ad497..0000000000000000000000000000000000000000
--- a/clx/fonts.lisp
+++ /dev/null
@@ -1,365 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-;; The char-info stuff is here instead of CLX because of uses of int16->card16.
-
-; To allow efficient storage representations, the type char-info is not
-; required to be a structure.
-
-;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
-
-;(defun char-<metric> (font index)
-;  ;; Note: I have tentatively chosen to return nil for an out-of-bounds index
-;  ;; (or an in-bounds index on a pseudo font), although returning zero or
-;  ;; signalling might be better.
-;  (declare (type font font)
-;	   (type integer index)
-;	   (clx-values (or null integer))))
-
-;(defun max-char-<metric> (font)
-;  ;; Note: I have tentatively chosen separate accessors over allowing :min and
-;  ;; :max as an index above.
-;  (declare (type font font)
-;	   (clx-values integer)))
-
-;(defun min-char-<metric> (font)
-;  (declare (type font font)
-;	   (clx-values integer)))
-
-;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
-
-(deftype char-info-vec () '(simple-array int16 (6)))
-
-(macrolet ((def-char-info-accessors (useless-name &body fields)
-	    `(within-definition (,useless-name def-char-info-accessors)
-	       ,@(do ((field fields (cdr field))
-		      (n 0 (1+ n))
-		      (name) (type)
-		      (result nil))
-		     ((endp field) result)
-		   (setq name (xintern 'char- (caar field)))
-		   (setq type (cadar field))
-		   (flet ((from (form)
-			    (if (eq type 'int16)
-				form
-				`(,(xintern 'int16-> type) ,form))))
-		     (push
-		       `(defun ,name (font index)
-			  (declare (type font font)
-				   (type array-index index))
-			  (declare (clx-values (or null ,type)))
-			  (when (and (font-name font)
-				     (index>= (font-max-char font) index (font-min-char font)))
-			    (the ,type
-				 ,(from
-				    `(the int16
-					  (let ((char-info-vector (font-char-infos font)))
-					    (declare (type char-info-vec char-info-vector))
-					    (if (index-zerop (length char-info-vector))
-						;; Fixed width font
-						(aref (the char-info-vec
-							   (font-max-bounds font))
-						      ,n)
-						;; Variable width font
-						(aref char-info-vector
-						      (index+
-							(index*
-							  6
-							  (index-
-							    index
-							    (font-min-char font)))
-							,n)))))))))
-		       result)
-		     (setq name (xintern 'min-char- (caar field)))
-		     (push
-		       `(defun ,name (font)
-			  (declare (type font font))
-			  (declare (clx-values (or null ,type)))
-			  (when (font-name font)
-			    (the ,type
-				 ,(from
-				    `(the int16
-					  (aref (the char-info-vec (font-min-bounds font))
-						,n))))))
-		       result)
-		     (setq name (xintern 'max-char- (caar field)))
-		     (push
-		       `(defun ,name (font)
-			  (declare (type font font))
-			  (declare (clx-values (or null ,type)))
-			  (when (font-name font)
-			    (the ,type
-				 ,(from
-				    `(the int16
-					  (aref (the char-info-vec (font-max-bounds font))
-						,n))))))
-		       result)))
-	  
-	       (defun make-char-info
-		      (&key ,@(mapcar
-				#'(lambda (field)
-				    `(,(car field) (required-arg ,(car field))))
-				fields))
-		 (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields))
-		 (let ((result (make-array ,(length fields) :element-type 'int16)))
-		   (declare (type char-info-vec result))
-		   ,@(do* ((field fields (cdr field))
-			   (var (caar field) (caar field))
-			   (type (cadar field) (cadar field))
-			   (n 0 (1+ n))
-			   (result nil))
-			  ((endp field) (nreverse result))
-		       (push `(setf (aref result ,n)
-				    ,(if (eq type 'int16)
-					 var
-					 `(,(xintern type '->int16) ,var)))
-			     result))
-		   result)))))
-  (def-char-info-accessors ignore
-    (left-bearing int16)
-    (right-bearing int16)
-    (width int16)
-    (ascent int16)
-    (descent int16)
-    (attributes card16)))
-    
-(defun open-font (display name)
-  ;; Font objects may be cached and reference counted locally within the display
-  ;; object.  This function might not execute a with-display if the font is cached.
-  ;; The protocol QueryFont request happens on-demand under the covers.
-  (declare (type display display)
-	   (type stringable name))
-  (declare (clx-values font))
-  (let* ((name-string (string-downcase (string name)))
-	 (font (car (member name-string (display-font-cache display)
-			    :key 'font-name
-			    :test 'equal)))
-	 font-id)
-    (unless font
-      (setq font (make-font :display display :name name-string))
-      (setq font-id (allocate-resource-id display font 'font))
-      (setf (font-id-internal font) font-id)
-      (with-buffer-request (display *x-openfont*)
-	(resource-id font-id)
-	(card16 (length name-string))
-	(pad16 nil)
-	(string name-string))
-      (push font (display-font-cache display)))
-    (incf (font-reference-count font))
-    font))
-
-(defun open-font-internal (font)
-  ;; Called "under the covers" to open a font object
-  (declare (type font font))
-  (declare (clx-values resource-id))
-  (let* ((name-string (font-name font))
-	 (display (font-display font))
-	 (id (allocate-resource-id display font 'font)))
-    (setf (font-id-internal font) id)
-    (with-buffer-request (display *x-openfont*)
-      (resource-id id)
-      (card16 (length name-string))
-      (pad16 nil)
-      (string name-string))
-    (push font (display-font-cache display))
-    (incf (font-reference-count font))
-    id))
-
-(defun discard-font-info (font)
-  ;; Discards any state that can be re-obtained with QueryFont.  This is
-  ;; simply a performance hint for memory-limited systems.
-  (declare (type font font))
-  (setf (font-font-info-internal font) nil
-	(font-char-infos-internal font) nil))
-
-(defun query-font (font)
-  ;; Internal function called by font and char info accessors
-  (declare (type font font))
-  (declare (clx-values font-info))
-  (let ((display (font-display font))
-	font-id
-	font-info
-	props)
-    (setq font-id (font-id font)) ;; May issue an open-font request
-    (with-buffer-request-and-reply (display *x-queryfont* 60)
-	 ((resource-id font-id))
-      (let* ((min-byte2 (card16-get 40))
-	     (max-byte2 (card16-get 42))
-	     (min-byte1 (card8-get 49))
-	     (max-byte1 (card8-get 50))
-	     (min-char  min-byte2)
-	     (max-char  (index+ (index-ash max-byte1 8) max-byte2))
-	     (nfont-props (card16-get 46))
-	     (nchar-infos (index* (card32-get 56) 6))
-	     (char-info (make-array nchar-infos :element-type 'int16)))
-	(setq font-info
-	      (make-font-info
-		:direction (member8-get 48 :left-to-right :right-to-left)
-		:min-char min-char
-		:max-char max-char
-		:min-byte1 min-byte1
-		:max-byte1 max-byte1
-		:min-byte2 min-byte2
-		:max-byte2 max-byte2
-		:all-chars-exist-p (boolean-get 51)
-		:default-char (card16-get 44)
-		:ascent (int16-get 52)
-		:descent (int16-get 54)
-		:min-bounds (char-info-get 8)
-		:max-bounds (char-info-get 24)))
-	(setq props (sequence-get :length (index* 2 nfont-props) :format int32
-				  :result-type 'list :index 60))
-	(sequence-get :length nchar-infos :format int16 :data char-info
-		      :index (index+ 60 (index* 2 nfont-props 4)))
-	(setf (font-char-infos-internal font) char-info)
-	(setf (font-font-info-internal font) font-info)))
-    ;; Replace atom id's with keywords in the plist
-    (do ((p props (cddr p)))
-	((endp p))
-      (setf (car p) (atom-name display (car p))))
-    (setf (font-info-properties font-info) props)
-    font-info))
-
-(defun close-font (font)
-  ;; This might not generate a protocol request if the font is reference
-  ;; counted locally.
-  (declare (type font font))
-  (when (and (not (plusp (decf (font-reference-count font))))
-	     (font-id-internal font))
-    (let ((display (font-display font))
-	  (id (font-id-internal font)))
-      (declare (type display display))
-      ;; Remove font from cache
-      (setf (display-font-cache display) (delete font (display-font-cache display)))
-      ;; Close the font
-      (with-buffer-request (display *x-closefont*)
-	(resource-id id)))))
-
-(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
-  (declare (type display display)
-	   (type string pattern)
-	   (type card16 max-fonts)
-	   (type t result-type)) ;; CL type
-  (declare (clx-values (clx-sequence string)))
-  (let ((string (string pattern)))
-    (with-buffer-request-and-reply (display *x-listfonts* size :sizes (8 16))
-	 ((card16 max-fonts (length string))
-	  (string string))
-      (values
-	(read-sequence-string
-	  buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*)))))
-
-(defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
-  ;; Note: Was called list-fonts-with-info.
-  ;; Returns "pseudo" fonts that contain basic font metrics and properties, but
-  ;; no per-character metrics and no resource-ids.  These pseudo fonts will be
-  ;; converted (internally) to real fonts dynamically as needed, by issuing an
-  ;; OpenFont request.  However, the OpenFont might fail, in which case the
-  ;; invalid-font error can arise.
-  (declare (type display display)
-	   (type string pattern)
-	   (type card16 max-fonts)
-	   (type t result-type)) ;; CL type
-  (declare (clx-values (clx-sequence font)))
-  (let ((string (string pattern))
-	(result nil))
-    (with-buffer-request-and-reply (display *x-listfontswithinfo* 60
-					    :sizes (8 16) :multiple-reply t)
-	 ((card16 max-fonts (length string))
-	  (string string))
-      (cond ((zerop (card8-get 1)) t)
-	    (t
-	(let* ((name-len (card8-get 1))
-	       (min-byte2 (card16-get 40))
-	       (max-byte2 (card16-get 42))
-	       (min-byte1 (card8-get 49))
-	       (max-byte1 (card8-get 50))
-	       (min-char  min-byte2)
-	       (max-char  (index+ (index-ash max-byte1 8) max-byte2))
-	       (nfont-props (card16-get 46))
-	       (font
-		 (make-font
-		   :display display
-		   :name nil
-		   :font-info-internal
-		   (make-font-info
-		     :direction (member8-get 48 :left-to-right :right-to-left)
-		     :min-char min-char
-		     :max-char max-char
-		     :min-byte1 min-byte1
-		     :max-byte1 max-byte1
-		     :min-byte2 min-byte2
-		     :max-byte2 max-byte2
-		     :all-chars-exist-p (boolean-get 51)
-		     :default-char (card16-get 44)
-		     :ascent (int16-get 52)
-		     :descent (int16-get 54)
-		     :min-bounds (char-info-get 8)
-		     :max-bounds (char-info-get 24)
-		     :properties (sequence-get :length (index* 2 nfont-props)
-					       :format int32
-					       :result-type 'list
-					       :index 60)))))
-	  (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4))))
-	  (push font result))
-	nil)))
-    ;; Replace atom id's with keywords in the plist
-    (dolist (font result)
-      (do ((p (font-properties font) (cddr p)))
-	  ((endp p))
-	(setf (car p) (atom-name display (car p)))))
-    (coerce (nreverse result) result-type)))
-
-(defun font-path (display &key (result-type 'list))
-  (declare (type display display)
-	   (type t result-type)) ;; CL type
-  (declare (clx-values (clx-sequence (or string pathname))))
-  (with-buffer-request-and-reply (display *x-getfontpath* size :sizes (8 16))
-       ()
-    (values
-      (read-sequence-string
-	buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*))))
-
-(defun set-font-path (display paths)
-  (declare (type display display)
-	   (type (clx-sequence (or string pathname)) paths))
-  (let ((path-length (length paths))
-	(request-length 8))
-    ;; Find the request length
-    (dotimes (i path-length)
-      (let* ((string (string (elt paths i)))
-	     (len (length string)))
-	(incf request-length (1+ len))))
-    (with-buffer-request (display *x-setfontpath* :length request-length)
-      (length (ceiling request-length 4))
-      (card16 path-length)
-      (pad16 nil)
-      (progn
-	(incf buffer-boffset 8)
-	(dotimes (i path-length)
-	  (let* ((string (string (elt paths i)))
-		 (len (length string)))
-	    (card8-put 0 len)
-	    (string-put 1 string :appending t :header-length 1)
-	    (incf buffer-boffset (1+ len))))
-	(setf (buffer-boffset display) (lround buffer-boffset)))))
-  paths)
-
-(defsetf font-path set-font-path)
diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp
deleted file mode 100644
index 22150ab0743afe27f4e4ae05bf7999c35bd240b4..0000000000000000000000000000000000000000
--- a/clx/gcontext.lisp
+++ /dev/null
@@ -1,971 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;; GContext
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-;;;	GContext values are usually cached locally in the GContext object.
-;;;	This is required because the X.11 server doesn't have any requests
-;;;	for getting GContext values back.
-;;;
-;;;	GContext changes are cached until force-GContext-changes is called.
-;;;	All the requests that use GContext (including the GContext accessors,
-;;;	but not the SETF's) call force-GContext-changes.
-;;;	In addition, the macro WITH-GCONTEXT may be used to provide a 
-;;;	local view if a GContext.
-;;;
-;;;	Each GContext keeps a copy of the values the server has seen, and
-;;;	a copy altered by SETF, called the LOCAL-STATE (bad name...).
-;;;	The SETF accessors increment a timestamp in the GContext.
-;;;	When the timestamp in a GContext isn't equal to the timestamp in
-;;;	the local-state, changes have been made, and force-GContext-changes
-;;;	loops through the GContext and local-state, sending differences to
-;;;	the server, and updating GContext.
-;;;
-;;;	WITH-GCONTEXT works by BINDING the local-state slot in a GContext to
-;;;	a private copy.  This is easy (and fast) for lisp machines, but other
-;;;	lisps will have problems.  Fortunately, most other lisps don't care,
-;;;	because they don't run in a multi-processing shared-address space
-;;;	environment.
-
-(in-package :xlib)
-
-;; GContext state accessors
-;;	The state vector contains all card32s to speed server updating
-
-(eval-when (eval compile load)
-
-(defconstant *gcontext-fast-change-length* #.(length *gcontext-components*))
-
-(macrolet ((def-gc-internals (name &rest extras)
-	    (let ((macros nil)
-		  (indexes nil)
-		  (masks nil)
-		  (index 0))
-	      (dolist (name *gcontext-components*)
-		(push `(defmacro ,(xintern 'gcontext-internal- name) (state)
-			 `(svref ,state ,,index))
-		      macros)
-		(setf (getf indexes name) index)
-		(push (ash 1 index) masks)
-		(incf index))
-	      (dolist (extra extras)
-		(push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state)
-			 `(svref ,state ,,index))
-		      macros)
-		;; don't override already correct index entries
-		(unless (or (getf indexes (second extra)) (getf indexes (first extra)))
-		  (setf (getf indexes (or (second extra) (first extra))) index))
-		(push (logior (ash 1 index)
-			      (if (second extra)
-				  (ash 1 (position (second extra) *gcontext-components*))
-				  0))
-		      masks)
-		(incf index))
-	      `(within-definition (def-gc-internals ,name)
-		 ,@(nreverse macros)
-		 (eval-when (eval compile load)
-		   (defconstant *gcontext-data-length* ,index)
-		   (defconstant *gcontext-indexes* ',indexes)
-		   (defconstant *gcontext-masks*
-				',(coerce (nreverse masks) 'simple-vector)))))))
-  (def-gc-internals ignore
-    (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp)))
-
-) ;; end EVAL-WHEN
-
-(deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*))
-
-(deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*))
-
-(defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named
-  (name nil :type symbol :read-only t)
-  (default nil :type t :read-only t)
-  (set-function #'(lambda (gcontext value)
-		    (declare (ignore gcontext))
-		    value)
-		:type (function (gcontext t) t) :read-only t)
-  (copy-function #'(lambda (from-gc to-gc value)
-		     (declare (ignore from-gc to-gc))
-		     value)
-		 :type (function (gcontext gcontext t) t) :read-only t))
-
-(defvar *gcontext-extensions* nil) ;; list of gcontext-extension
-
-;; Gcontext state Resource
-(defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states
-
-(defmacro gcontext-state-next (state)
-  `(svref ,state 0))
-
-(defun allocate-gcontext-state ()
-  ;; Allocate a gcontext-state
-  ;; Loop until a local state is found that's large enough to hold
-  ;; any extensions that may exist.
-  (let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*))))
-    (declare (type array-index length))
-    (loop
-      (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache*
-					    gcontext-state-next gcontext-state)
-		       (make-array length :initial-element nil))))
-	(declare (type gcontext-state state))
-	(when (index>= (length state) length)
-	  (return state))))))
-
-(defun deallocate-gcontext-state (state)
-  (declare (type gcontext-state state))
-  (fill state nil)
-  (threaded-atomic-push state *gcontext-local-state-cache*
-			gcontext-state-next gcontext-state))
-
-;; Temp-Gcontext Resource
-(defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts
-
-(defun allocate-temp-gcontext ()
-  (or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext)
-      (make-gcontext :local-state '#() :server-state '#())))
-
-(defun deallocate-temp-gcontext (gc)
-  (declare (type gcontext gc))
-  (threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext))
-
-;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
-;; as (type <type> <name>), there is an accessor:
-
-;(defun gcontext-<name> (gcontext)
-;  ;; The value will be nil if the last value stored is unknown (e.g., the cache was
-;  ;; off, or the component was copied from a gcontext with unknown state).
-;  (declare (type gcontext gcontext)
-;	   (clx-values <type>)))
-
-;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
-;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor:
-
-;(defsetf gcontext-<name> (gcontext) (value)
-;  )
-
-;; Generate all the accessors and defsetf's for GContext
-
-(defmacro xgcmask->gcmask (mask)
-  `(the gcmask (logand ,mask #.(1- (ash 1 *gcontext-fast-change-length*)))))
-
-(defmacro access-gcontext ((gcontext local-state) &body body)
-  `(let ((,local-state (gcontext-local-state ,gcontext)))
-     (declare (type gcontext-state ,local-state))
-     ,@body))
-
-(defmacro modify-gcontext ((gcontext local-state) &body body)
-  ;; The timestamp must be altered after the modification
-  `(let ((,local-state (gcontext-local-state ,gcontext)))
-     (declare (type gcontext-state ,local-state))
-     (prog1
-	 (progn ,@body)
-       (setf (gcontext-internal-timestamp ,local-state) 0))))
-
-(defmacro def-gc-accessor (name type)
-  (let* ((gcontext-name (xintern 'gcontext- name))
-	 (internal-accessor (xintern 'gcontext-internal- name))
-	 (internal-setfer (xintern 'set- gcontext-name)))
-    `(within-definition (,name def-gc-accessor)
-
-       (defun ,gcontext-name (gcontext)
-	 (declare (type gcontext gcontext))
-	 (declare (clx-values (or null ,type)))
-	 (let ((value (,internal-accessor (gcontext-local-state gcontext))))
-	   (declare (type (or null card32) value))
-	   (when value ;; Don't do anything when value isn't known
-	     (let ((%buffer (gcontext-display gcontext)))
-	       (declare (type display %buffer))
-	       %buffer
-	       (decode-type ,type value)))))
-       
-       (defun ,internal-setfer (gcontext value)
-	 (declare (type gcontext gcontext)
-		  (type ,type value))
-	 (modify-gcontext (gcontext local-state)
-	   (setf (,internal-accessor local-state) (encode-type ,type value))
-	   ,@(when (eq type 'pixmap)
-	       ;; write-through pixmaps, because the protocol allows
-	       ;; the server to copy the pixmap contents at the time
-	       ;; of the store, rather than continuing to share with
-	       ;; the pixmap.
-	       `((let ((server-state (gcontext-server-state gcontext)))
-		   (setf (,internal-accessor server-state) nil))))
-	   value))
-       
-       (defsetf ,gcontext-name ,internal-setfer))))
-
-(defmacro incf-internal-timestamp (state)
-  (let ((ts (gensym)))
-    `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state))))
-       (declare (type fixnum ,ts))
-       ;; the probability seems low enough
-       (setq ,ts (if (= ,ts most-positive-fixnum)
-		     1
-		     (the fixnum (1+ ,ts))))
-       (setf (gcontext-internal-timestamp ,state) ,ts))))
-
-(def-gc-accessor function boole-constant)
-(def-gc-accessor plane-mask card32)
-(def-gc-accessor foreground card32)
-(def-gc-accessor background card32)
-(def-gc-accessor line-width card16)
-(def-gc-accessor line-style (member :solid :dash :double-dash))
-(def-gc-accessor cap-style (member :not-last :butt :round :projecting))
-(def-gc-accessor join-style (member :miter :round :bevel))
-(def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled))
-(def-gc-accessor fill-rule (member :even-odd :winding))
-(def-gc-accessor tile pixmap)
-(def-gc-accessor stipple pixmap)
-(def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin
-(def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin
-;; (def-GC-accessor font font) ;; See below
-(def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors))
-(def-gc-accessor exposures (member :off :on))
-(def-gc-accessor clip-x int16)
-(def-gc-accessor clip-y int16)
-;; (def-GC-accessor clip-mask) ;; see below
-(def-gc-accessor dash-offset card16)
-;; (def-GC-accessor dashes)  ;; see below
-(def-gc-accessor arc-mode (member :chord :pie-slice))
-
-
-(defun gcontext-clip-mask (gcontext)
-  (declare (type gcontext gcontext))
-  (declare (clx-values (or null (member :none) pixmap rect-seq)
-		   (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))))
-  (access-gcontext (gcontext local-state)
-    (multiple-value-bind (clip clip-mask)
-	(without-interrupts
-	  (values (gcontext-internal-clip local-state)
-		  (gcontext-internal-clip-mask local-state)))
-      (if (null clip)
-	  (values (let ((%buffer (gcontext-display gcontext)))
-		    (declare (type display %buffer))
-		    (decode-type (or (member :none) pixmap) clip-mask))
-		  nil)
-	(values (second clip)
-		(decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
-			     (first clip)))))))
-
-(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask)
-  ;; A bit strange, but retains setf form.
-  ;; a nil clip-mask is transformed to an empty vector
-  `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask))
-
-(defun set-gcontext-clip-mask (gcontext ordering clip-mask)
-  ;; a nil clip-mask is transformed to an empty vector
-  (declare (type gcontext gcontext)
-	   (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering)
-	   (type (or (member :none) pixmap rect-seq) clip-mask))
-  (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))
-  (multiple-value-bind (clip-mask clip)
-      (typecase clip-mask
-	(pixmap (values (pixmap-id clip-mask) nil))
-	((member :none) (values 0 nil))
-	(sequence
-	  (values nil
-		  (list (encode-type
-			  (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
-			  ordering)
-			(copy-seq clip-mask))))
-	(otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq))))
-    (modify-gcontext (gcontext local-state)
-      (let ((server-state (gcontext-server-state gcontext)))
-	(declare (type gcontext-state server-state))
-	(without-interrupts
-	  (setf (gcontext-internal-clip local-state) clip
-		(gcontext-internal-clip-mask local-state) clip-mask)
-	  (if (null clip)
-	      (setf (gcontext-internal-clip server-state) nil)
-	    (setf (gcontext-internal-clip-mask server-state) nil))
-	  (when (and clip-mask (not (zerop clip-mask)))
-	    ;; write-through clip-mask pixmap, because the protocol allows the
-	    ;; server to copy the pixmap contents at the time of the store,
-	    ;; rather than continuing to share with the pixmap.
-	    (setf (gcontext-internal-clip-mask server-state) nil))))))
-  clip-mask)
-
-(defun gcontext-dashes (gcontext)
-  (declare (type gcontext gcontext))
-  (declare (clx-values (or null card8 sequence)))
-  (access-gcontext (gcontext local-state)
-    (multiple-value-bind (dash dashes)
-	(without-interrupts 
-	  (values (gcontext-internal-dash local-state)
-		  (gcontext-internal-dashes local-state)))
-      (if (null dash)
-	  dashes
-	dash))))
-
-(defsetf gcontext-dashes set-gcontext-dashes)
-
-(defun set-gcontext-dashes (gcontext dashes)
-  (declare (type gcontext gcontext)
-	   (type (or card8 sequence) dashes))
-  (multiple-value-bind (dashes dash)
-      (if (type? dashes 'sequence)
-	  (if (zerop (length dashes))
-	      (x-type-error dashes '(or card8 sequence) "non-empty sequence")
-	    (values nil (or (copy-seq dashes) (vector))))
-	(values (encode-type card8 dashes) nil))
-    (modify-gcontext (gcontext local-state)
-      (let ((server-state (gcontext-server-state gcontext)))
-	(declare (type gcontext-state server-state))
-	(without-interrupts
-	  (setf (gcontext-internal-dash local-state) dash
-		(gcontext-internal-dashes local-state) dashes)
-	  (if (null dash)
-	      (setf (gcontext-internal-dash server-state) nil)
-	    (setf (gcontext-internal-dashes server-state) nil))))))
-  dashes)
-
-(defun gcontext-font (gcontext &optional metrics-p)
-  ;; If the stored font is known, it is returned.  If it is not known and
-  ;; metrics-p is false, then nil is returned.  If it is not known and
-  ;; metrics-p is true, then a pseudo font is returned.  Full metric and
-  ;; property information can be obtained, but the font does not have a name or
-  ;; a resource-id, and attempts to use it where a resource-id is required will
-  ;; result in an invalid-font error.
-  (declare (type gcontext gcontext)
-	   (type boolean metrics-p))
-  (declare (clx-values (or null font)))
-  (access-gcontext (gcontext local-state)
-    (let ((font (gcontext-internal-font-obj local-state)))
-      (or font
-	  (when metrics-p
-	    ;; XXX this isn't correct
-	    (make-font :display (gcontext-display gcontext)
-		       :id (gcontext-id gcontext)
-		       :name nil))))))
-
-(defsetf gcontext-font set-gcontext-font)
-
-(defun set-gcontext-font (gcontext font)
-  (declare (type gcontext gcontext)
-	   (type fontable font))
-  (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font)))
-	 (font (and font-object (font-id font-object))))
-    ;; XXX need to check font has id (and name?)
-    (modify-gcontext (gcontext local-state)
-      (let ((server-state (gcontext-server-state gcontext)))
-	(declare (type gcontext-state server-state))
-	(without-interrupts
-	  (setf (gcontext-internal-font-obj local-state) font-object
-		(gcontext-internal-font local-state) font)
-	  ;; check against font, not against font-obj
-	  (if (null font)
-	      (setf (gcontext-internal-font server-state) nil)
-	    (setf (gcontext-internal-font-obj server-state) font-object))))))
-  font)
-
-(defun force-gcontext-changes-internal (gcontext)
-  ;; Force any delayed changes.
-  (declare (type gcontext gcontext))
-  #.(declare-buffun)
-
-  (let ((display (gcontext-display gcontext))
-	(server-state (gcontext-server-state gcontext))
-	(local-state (gcontext-local-state gcontext)))
-    (declare (type display display)
-	     (type gcontext-state server-state local-state))
-
-    ;; Update server when timestamps don't match
-    (unless (= (the fixnum (gcontext-internal-timestamp local-state))
-	       (the fixnum (gcontext-internal-timestamp server-state)))
-
-      ;; The display is already locked.
-      (macrolet ((with-buffer ((buffer &key timeout) &body body)
-		   `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil)
-			   ,@body)))
-
-	;; Because there is no locking on the local state we have to
-	;; assume that state will change and set timestamps up front,
-	;; otherwise by the time we figured out there were no changes
-	;; and tried to store the server stamp as the local stamp, the
-	;; local stamp might have since been modified.
-	(setf (gcontext-internal-timestamp local-state)
-	      (incf-internal-timestamp server-state))
-
-	(block no-changes
-	  (let ((last-request (buffer-last-request display)))
-	    (with-buffer-request (display *x-changegc*)
-	      (gcontext gcontext)
-	      (progn
-		(do ((i 0 (index+ i 1))
-		     (bit 1 (the xgcmask (ash bit 1)))
-		     (nbyte 12)
-		     (mask 0)
-		     (local 0))
-		    ((index>= i *gcontext-fast-change-length*)
-		     (when (zerop mask)
-		       ;; If nothing changed, restore last-request and quit
-		       (setf (buffer-last-request display)
-			     (if (zerop (buffer-last-request display))
-				 nil
-			       last-request))
-		       (return-from no-changes nil))
-		     (card29-put 8 mask)
-		     (card16-put 2 (index-ash nbyte -2))
-		     (index-incf (buffer-boffset display) nbyte))
-		  (declare (type array-index i nbyte)
-			   (type xgcmask bit)
-			   (type gcmask mask)
-			   (type (or null card32) local))
-		  (unless (eql (the (or null card32) (svref server-state i))
-			       (setq local (the (or null card32) (svref local-state i))))
-		    (setf (svref server-state i) local)
-		    (card32-put nbyte local)
-		    (setq mask (the gcmask (logior mask bit)))
-		    (index-incf nbyte 4)))))))
-
-	;; Update GContext extensions
-	(do ((extension *gcontext-extensions* (cdr extension))
-	     (i *gcontext-data-length* (index+ i 1))
-	     (local))
-	    ((endp extension))
-	  (unless (eql (svref server-state i)
-		       (setq local (svref local-state i)))
-	    (setf (svref server-state i) local)
-	    (funcall (gcontext-extension-set-function (car extension)) gcontext local)))
-
-	;; Update clipping rectangles
-	(multiple-value-bind (local-clip server-clip)
-	    (without-interrupts 
-	      (values (gcontext-internal-clip local-state)
-		      (gcontext-internal-clip server-state)))
-	  (unless (equalp local-clip server-clip)
-	    (setf (gcontext-internal-clip server-state) nil)
-	    (unless (null local-clip)
-	      (with-buffer-request (display *x-setcliprectangles*)
-		(data (first local-clip))
-		(gcontext gcontext)
-		;; XXX treat nil correctly
-		(card16 (or (gcontext-internal-clip-x local-state) 0)
-			(or (gcontext-internal-clip-y local-state) 0))
-		;; XXX this has both int16 and card16 values
-		((sequence :format int16) (second local-clip)))
-	      (setf (gcontext-internal-clip server-state) local-clip))))
-
-	;; Update dashes
-	(multiple-value-bind (local-dash server-dash)
-	    (without-interrupts 
-	      (values (gcontext-internal-dash local-state)
-		      (gcontext-internal-dash server-state)))
-	  (unless (equalp local-dash server-dash)
-	    (setf (gcontext-internal-dash server-state) nil)
-	    (unless (null local-dash)
-	      (with-buffer-request (display *x-setdashes*)
-		(gcontext gcontext)
-		;; XXX treat nil correctly
-		(card16 (or (gcontext-internal-dash-offset local-state) 0)
-			(length local-dash))
-		((sequence :format card8) local-dash))
-	      (setf (gcontext-internal-dash server-state) local-dash))))))))
-
-(defun force-gcontext-changes (gcontext)
-  ;; Force any delayed changes.
-  (declare (type gcontext gcontext))
-  (let ((display (gcontext-display gcontext))
-	(server-state (gcontext-server-state gcontext))
-	(local-state (gcontext-local-state gcontext)))
-    (declare (type gcontext-state server-state local-state))
-    ;; Update server when timestamps don't match
-    (unless (= (the fixnum (gcontext-internal-timestamp local-state))
-	       (the fixnum (gcontext-internal-timestamp server-state)))
-      (with-display (display)
-	(force-gcontext-changes-internal gcontext)))))
-
-;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE
-;;;	     SET IN THE GCONTEXT ON ENTRY.  BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN
-;;;	     UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN
-;;;	     COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS
-;;;          BACK.
-
-(defmacro with-gcontext ((gcontext &rest options &key clip-ordering
-				   &allow-other-keys)
-			 &body body)
-  ;; "Binds" the gcontext components specified by options within the
-  ;; dynamic scope of the body (i.e., indefinite scope and dynamic
-  ;; extent), on a per-process basis in a multi-process environment.
-  ;; The body is not surrounded by a with-display.  If cache-p is nil or
-  ;; the some component states are unknown, this will implement
-  ;; save/restore by creating a temporary gcontext and doing
-  ;; copy-gcontext-components to and from it.
-
-  (declare (arglist (gcontext &rest options &key
-			     function plane-mask foreground background
-			     line-width line-style cap-style join-style
-			     fill-style fill-rule arc-mode tile stipple ts-x
-			     ts-y font subwindow-mode exposures clip-x clip-y
-			     clip-mask clip-ordering dash-offset dashes
-			     &allow-other-keys)
-		   &body body))
-  (remf options :clip-ordering)
-
-  (let ((gc (gensym))
-	(saved-state (gensym))
-	(temp-gc (gensym))
-	(temp-mask (gensym))
-	(temp-vars nil)
-	(setfs nil)
-	(indexes nil) ; List of gcontext field indices
-	(extension-indexes nil) ; List of gcontext extension field indices
-	(ts-index (getf *gcontext-indexes* :timestamp)))
-
-    (do* ((option options (cddr option))
-	  (name (car option) (car option))
-	  (value (cadr option) (cadr option)))
-	 ((endp option) (setq setfs (nreverse setfs)))
-      (let ((index (getf *gcontext-indexes* name)))
-	(if index
-	    (push index indexes)
-	  (let ((extension (find name *gcontext-extensions*
-				 :key #'gcontext-extension-name)))
-	    (if extension
-		(progn
-		  (push (xintern "Internal-" 'gcontext- name "-State-Index")
-			extension-indexes))
-	      (x-type-error name 'gcontext-key)))))
-      (let ((accessor `(,(xintern 'gcontext- name) ,gc
-			,@(when (eq name :clip-mask) `(,clip-ordering))))
-	    (temp-var (gensym)))
-	(when value
-	  (push `(,temp-var ,value) temp-vars)
-	  (push `(when ,temp-var (setf ,accessor ,temp-var)) setfs))))
-    (if setfs
-	`(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc)
-	     (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes)
-	   (declare (type gcontext ,gc)
-		    (type gcontext-state ,saved-state)
-		    (type xgcmask ,temp-mask)
-		    (type (or null resource-id) ,temp-gc))
-	   (with-gcontext-bindings (,gc ,saved-state
-					,(append indexes extension-indexes)
-				    ,ts-index ,temp-mask ,temp-gc)
-	     (let ,temp-vars
-	       ,@setfs)
-	     ,@body))
-      `(progn ,@body))))
-
-(defun copy-gcontext-local-state (gcontext indexes &rest extension-indices)
-  ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK
-  (declare (type gcontext gcontext)
-	   (type list indexes)
-	   (dynamic-extent extension-indices))
-  (let ((local-state (gcontext-local-state gcontext))
-	(saved-state (allocate-gcontext-state))
-	(cache-p (gcontext-cache-p gcontext)))
-    (declare (type gcontext-state local-state saved-state))
-    (setf (gcontext-internal-timestamp saved-state) 1)
-    (let ((temp-gc nil)
-	  (temp-mask 0)
-	  (extension-mask 0))
-      (declare (type xgcmask temp-mask)
-	       (type integer extension-mask))
-      (dolist (i indexes)
-	(when (or (not (setf (svref saved-state i) (svref local-state i)))
-		  (not cache-p))
-	  (setq temp-mask
-		(the xgcmask (logior temp-mask
-				     (the xgcmask (svref *gcontext-masks* i)))))))
-      (dolist (i extension-indices)
-	(when (or (not (setf (svref saved-state i) (svref local-state i)))
-		  (not cache-p))
-	  (setq extension-mask
-		(the xgcmask (logior extension-mask (ash 1 i))))))
-      (when (or (plusp temp-mask)
-		(plusp extension-mask))
-	;; Copy to temporary GC when field unknown or cache-p false
-	(let ((display (gcontext-display gcontext)))
-	  (declare (type display display))
-	  (with-display (display)
-	    (setq temp-gc (allocate-temp-gcontext))
-	    (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext)
-		  (gcontext-display temp-gc) display
-		  (gcontext-drawable temp-gc) (gcontext-drawable gcontext)
-		  (gcontext-server-state temp-gc) saved-state
-		  (gcontext-local-state temp-gc) saved-state)
-	    ;; Create a new (temporary) gcontext
-	    (with-buffer-request (display *x-creategc*)
-	      (gcontext temp-gc)
-	      (drawable (gcontext-drawable gcontext))
-	      (card29 0))
-	    ;; Copy changed components to the temporary gcontext
-	    (when (plusp temp-mask)
-	      (with-buffer-request (display *x-copygc*)
-		(gcontext gcontext)
-		(gcontext temp-gc)
-		(card29 (xgcmask->gcmask temp-mask))))
-	    ;; Copy extension fields to the new gcontext
-	    (when (plusp extension-mask)
-	      ;; Copy extension fields from temp back to gcontext
-	      (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1))
-		   (i 0 (index+ i 1)))
-		  ((zerop bit))
-		(let ((copy-function (gcontext-extension-copy-function
-				       (elt *gcontext-extensions* i))))
-		  (funcall copy-function gcontext temp-gc
-			   (svref local-state (index+ i *gcontext-data-length*))))))
-	    )))
-      (values gcontext saved-state (logior temp-mask extension-mask) temp-gc)))) 
-
-(defun restore-gcontext-temp-state (gcontext temp-mask temp-gc)
-  (declare (type gcontext gcontext temp-gc)
-	   (type xgcmask temp-mask))
-  (let ((display (gcontext-display gcontext)))
-    (declare (type display display))
-    (with-display (display)
-      (with-buffer-request (display *x-copygc*)
-	(gcontext temp-gc)
-	(gcontext gcontext)
-	(card29 (xgcmask->gcmask temp-mask)))
-      ;; Copy extension fields from temp back to gcontext
-      (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1))
-	   (extensions *gcontext-extensions* (cdr extensions))
-	   (i *gcontext-data-length* (index+ i 1))
-	   (local-state (gcontext-local-state temp-gc)))
-	  ((zerop bit))
-	(let ((copy-function (gcontext-extension-copy-function (car extensions))))
-	  (funcall copy-function temp-gc gcontext (svref local-state i))))
-      ;; free gcontext
-      (with-buffer-request (display *x-freegc*)
-	(gcontext temp-gc))
-      (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext)
-      (deallocate-temp-gcontext temp-gc)
-      ;; Copy saved state back to server state
-      (do ((server-state (gcontext-server-state gcontext))
-	   (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1)))
-	   (i 0 (index+ i 1)))
-	  ((zerop bit)
-	   (incf-internal-timestamp server-state))
-	(declare (type gcontext-state server-state)
-		 (type gcmask bit)
-		 (type array-index i))
-	(when (oddp bit)
-	  (setf (svref server-state i) nil))))))
-
-(defun create-gcontext (&rest options &key (drawable (required-arg drawable))
-			function plane-mask foreground background
-			line-width line-style cap-style join-style fill-style fill-rule
-			arc-mode tile stipple ts-x ts-y font subwindow-mode
-			exposures clip-x clip-y clip-mask clip-ordering
-			dash-offset dashes
-			(cache-p t)
-			&allow-other-keys)
-  ;; Only non-nil components are passed on in the request, but for effective caching
-  ;; assumptions have to be made about what the actual protocol defaults are.  For
-  ;; all gcontext components, a value of nil causes the default gcontext value to be
-  ;; used.  For clip-mask, this implies that an empty rect-seq cannot be represented
-  ;; as a list.  Note:  use of stringable as font will cause an implicit open-font.
-  ;; Note:  papers over protocol SetClipRectangles and SetDashes special cases.  If
-  ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext
-  ;; component will have no effect unless the new value differs from the cached
-  ;; value.  Component changes (setfs and with-gcontext) are always deferred
-  ;; regardless of the cache mode, and sent over the protocol only when required by a
-  ;; local operation or by an explicit call to force-gcontext-changes.
-  (declare (type drawable drawable) ; Required to be non-null
-	   (type (or null boole-constant) function)
-	   (type (or null pixel) plane-mask foreground background)
-	   (type (or null card16) line-width dash-offset)
-	   (type (or null int16) ts-x ts-y clip-x clip-y)
-	   (type (or null (member :solid :dash :double-dash)) line-style)
-	   (type (or null (member :not-last :butt :round :projecting)) cap-style)
-	   (type (or null (member :miter :round :bevel)) join-style)
-	   (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style)
-	   (type (or null (member :even-odd :winding)) fill-rule)
-	   (type (or null (member :chord :pie-slice)) arc-mode)
-	   (type (or null pixmap) tile stipple)
-	   (type (or null fontable) font)
-	   (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode)
-	   (type (or null (member :on :off)) exposures)
-	   (type (or null (member :none) pixmap rect-seq) clip-mask)
-	   (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
-	   (type (or null card8 sequence) dashes)
-	   (dynamic-extent options)
-	   (type boolean cache-p))
-  (declare (clx-values gcontext))
-  (let* ((display (drawable-display drawable))
-	 (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p))
-	 (local-state (gcontext-local-state gcontext))
-	 (server-state (gcontext-server-state gcontext))
-	 (gcontextid (allocate-resource-id display gcontext 'gcontext)))
-    (declare (type display display)
-	     (type gcontext gcontext)
-	     (type resource-id gcontextid)
-	     (type gcontext-state local-state server-state))
-    (setf (gcontext-id gcontext) gcontextid)
-
-    (unless function (setf (gcontext-function gcontext) boole-1))
-    ;; using the depth of the drawable would be better, but ...
-    (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff))
-    (unless foreground (setf (gcontext-foreground gcontext) 0))
-    (unless background (setf (gcontext-background gcontext) 1))
-    (unless line-width (setf (gcontext-line-width gcontext) 0))
-    (unless line-style (setf (gcontext-line-style gcontext) :solid))
-    (unless cap-style (setf (gcontext-cap-style gcontext) :butt))
-    (unless join-style (setf (gcontext-join-style gcontext) :miter))
-    (unless fill-style (setf (gcontext-fill-style gcontext) :solid))
-    (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd))
-    (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice))
-    (unless ts-x (setf (gcontext-ts-x gcontext) 0))
-    (unless ts-y (setf (gcontext-ts-y gcontext) 0))
-    (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext)
-				 :clip-by-children))
-    (unless exposures (setf (gcontext-exposures gcontext) :on))
-    (unless clip-mask (setf (gcontext-clip-mask gcontext) :none))
-    (unless clip-x (setf (gcontext-clip-x gcontext) 0))
-    (unless clip-y (setf (gcontext-clip-y gcontext) 0))
-    (unless dashes (setf (gcontext-dashes gcontext) 4))
-    (unless dash-offset (setf (gcontext-dash-offset gcontext) 0))
-    ;; a bit kludgy, but ...
-    (replace server-state local-state)
-
-    (when function (setf (gcontext-function gcontext) function))
-    (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask))
-    (when foreground (setf (gcontext-foreground gcontext) foreground))
-    (when background (setf (gcontext-background gcontext) background))
-    (when line-width (setf (gcontext-line-width gcontext) line-width))
-    (when line-style (setf (gcontext-line-style gcontext) line-style))
-    (when cap-style (setf (gcontext-cap-style gcontext) cap-style))
-    (when join-style (setf (gcontext-join-style gcontext) join-style))
-    (when fill-style (setf (gcontext-fill-style gcontext) fill-style))
-    (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule))
-    (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode))
-    (when tile (setf (gcontext-tile gcontext) tile))
-    (when stipple (setf (gcontext-stipple gcontext) stipple))
-    (when ts-x (setf (gcontext-ts-x gcontext) ts-x))
-    (when ts-y (setf (gcontext-ts-y gcontext) ts-y))
-    (when font (setf (gcontext-font gcontext) font))
-    (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode))
-    (when exposures (setf (gcontext-exposures gcontext) exposures))
-    (when clip-x (setf (gcontext-clip-x gcontext) clip-x))
-    (when clip-y (setf (gcontext-clip-y gcontext) clip-y))
-    (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask))
-    (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset))
-    (when dashes (setf (gcontext-dashes gcontext) dashes))
-    
-    (setf (gcontext-internal-timestamp server-state) 1)
-    (setf (gcontext-internal-timestamp local-state)
-	  ;; SetClipRectangles or SetDashes request need to be sent?
-	  (if (or (gcontext-internal-clip local-state)
-		  (gcontext-internal-dash local-state))
-	      ;; Yes, mark local state "modified" to ensure
-	      ;; force-gcontext-changes will occur.
-	      0
-	    ;; No, mark local state "unmodified"
-	    1))
-    
-    (with-buffer-request (display *x-creategc*)
-      (resource-id gcontextid)
-      (drawable drawable)
-      (progn (do* ((i 0 (index+ i 1))
-		   (bit 1 (the xgcmask (ash bit 1)))
-		   (nbyte 16)
-		   (mask 0)
-		   (local (svref local-state i) (svref local-state i)))
-		 ((index>= i *gcontext-fast-change-length*)
-		  (card29-put 12 mask)
-		  (card16-put 2 (index-ash nbyte -2))
-		  (index-incf (buffer-boffset display) nbyte))
-	       (declare (type array-index i nbyte)
-			(type xgcmask bit)
-			(type gcmask mask)
-			(type (or null card32) local))
-	       (unless (eql local (the (or null card32) (svref server-state i)))
-		 (setf (svref server-state i) local)
-		 (card32-put nbyte local)
-		 (setq mask (the gcmask (logior mask bit)))
-		 (index-incf nbyte 4)))))
-
-    ;; Initialize extensions
-    (do ((extensions *gcontext-extensions* (cdr extensions))
-	 (i *gcontext-data-length* (index+ i 1)))
-	((endp extensions))
-      (declare (type list extensions)
-	       (type array-index i))
-      (setf (svref server-state i)
-	    (setf (svref local-state i)
-		  (gcontext-extension-default (car extensions)))))
-
-    ;; Set extension values
-    (do* ((option-list options (cddr option-list))
-	  (option (car option-list) (car option-list))
-	  (extension))
-	 ((endp option-list))
-      (declare (type list option-list))
-      (cond ((getf *gcontext-indexes* option))	; Gcontext field
-	    ((member option '(:drawable :clip-ordering :cache-p)))	; Optional parameter
-	    ((setq extension (find option *gcontext-extensions*
-				   :key #'gcontext-extension-name))
-	     (funcall (gcontext-extension-set-function extension)
-		      gcontext (second option-list)))
-	    (t (x-type-error option 'gcontext-key))))
-    gcontext)) 
-
-(defun copy-gcontext-components (src dst &rest keys)
-  (declare (type gcontext src dst)
-	   (dynamic-extent keys))
-  ;; you might ask why this isn't just a bunch of
-  ;;   (setf (gcontext-<mumble> dst) (gcontext-<mumble> src))
-  ;; the answer is that you can do that yourself if you want, what we are
-  ;; providing here is access to the protocol request, which will generally
-  ;; be more efficient (particularly for things like clip and dash lists).
-  (when keys
-    (let ((display (gcontext-display src))
-	  (mask 0))
-      (declare (type xgcmask mask))
-      (with-display (display)
-	(force-gcontext-changes-internal src)
-	(force-gcontext-changes-internal dst)
-	
-	;; collect entire mask and handle extensions
-	(dolist (key keys)
-	  (let ((i (getf *gcontext-indexes* key)))
-	    (declare (type (or null array-index) i))
-	    (if i
-		(setq mask (the xgcmask (logior mask
-						(the xgcmask (svref *gcontext-masks* i)))))
-	      (multiple-value-bind (extension index)
-		  (find key *gcontext-extensions* :key #'gcontext-extension-name)
-		(if extension
-		    (funcall (gcontext-extension-copy-function extension)
-			     src dst (svref (gcontext-local-state src)
-					    (index+ index *gcontext-data-length*)))
-		  (x-type-error key 'gcontext-key))))))
-	
-	(when (plusp mask)
-	  (do ((src-server-state (gcontext-server-state src))
-	       (dst-server-state (gcontext-server-state dst))
-	       (dst-local-state (gcontext-local-state dst))
-	       (bit mask (the xgcmask (ash bit -1)))
-	       (i 0 (index+ i 1)))
-	      ((zerop bit)
-	       (incf-internal-timestamp dst-server-state)
-	       (setf (gcontext-internal-timestamp dst-local-state) 0))
-	    (declare (type gcontext-state src-server-state dst-server-state dst-local-state)
-		     (type xgcmask bit)
-		     (type array-index i))
-	    (when (oddp bit)
-	      (setf (svref dst-local-state i)
-		    (setf (svref dst-server-state i) (svref src-server-state i)))))
-	  (with-buffer-request (display *x-copygc*)
-	    (gcontext src dst)
-	    (card29 (xgcmask->gcmask mask))))))))
-
-(defun copy-gcontext (src dst)
-  (declare (type gcontext src dst))
-  ;; Copies all components.
-  (apply #'copy-gcontext-components src dst *gcontext-components*)
-  (do ((extensions *gcontext-extensions* (cdr extensions))
-       (i *gcontext-data-length* (index+ i 1)))
-      ((endp extensions))
-    (funcall (gcontext-extension-copy-function (car extensions))
-	     src dst (svref (gcontext-local-state src) i))))
-	   
-(defun free-gcontext (gcontext)
-  (declare (type gcontext gcontext))
-  (let ((display (gcontext-display gcontext)))
-    (with-buffer-request (display *x-freegc*)
-      (gcontext gcontext))
-    (deallocate-resource-id display (gcontext-id gcontext) 'gcontext)
-    (deallocate-gcontext-state (gcontext-server-state gcontext))
-    (deallocate-gcontext-state (gcontext-local-state gcontext))
-    nil))
-
-(defmacro define-gcontext-accessor (name &key default set-function copy-function)
-  ;; This will define a new gcontext accessor called NAME.
-  ;; Defines the gcontext-NAME accessor function and its defsetf.
-  ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when
-  ;; gcontext-cache-p is true.  The NAME keyword will be allowed in
-  ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS.
-  ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE)
-  ;; from create-gcontext, and force-gcontext-changes.
-  ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value)
-  ;; from copy-gcontext and copy-gcontext-components.
-  ;; The copy-function defaults to:
-  ;; (lambda (ignore dst-gc value)
-  ;;    (if value
-  ;;	    (,set-function dst-gc value)
-  ;;	  (error "Can't copy unknown GContext component ~a" ',name)))
-  (declare (type symbol name)
-	   (type t default)
-	   (type symbol set-function) ;; required
-	   (type symbol copy-function))
-  (let* ((gc-name (intern (concatenate 'string
-				       (string 'gcontext-)
-				       (string name)))) ;; in current package
-	 (key-name (kintern name))
-	 (setfer (xintern "Set-" gc-name))
-	 (internal-set-function (xintern "Internal-Set-" gc-name))
-	 (internal-copy-function (xintern "Internal-Copy-" gc-name))
-	 (internal-state-index (xintern "Internal-" gc-name "-State-Index")))
-    (unless copy-function
-      (setq copy-function
-	    `(lambda (src-gc dst-gc value)
-	       (declare (ignore src-gc))
-	       (if value
-		   (,set-function dst-gc value)
-		 (error "Can't copy unknown GContext component ~a" ',name)))))
-    `(progn
-       (eval-when (compile load eval)
-	 (defparameter ,internal-state-index
-		       (add-gcontext-extension ',key-name ,default ',internal-set-function
-					       ',internal-copy-function))
-	 ) ;; end eval-when
-       (defun ,gc-name (gcontext)
-	 (svref (gcontext-local-state gcontext) ,internal-state-index))
-       (defun ,setfer (gcontext new-value)
-	 (let ((local-state (gcontext-local-state gcontext)))
-	   (setf (gcontext-internal-timestamp local-state) 0)
-	   (setf (svref local-state ,internal-state-index) new-value)))
-       (defsetf ,gc-name ,setfer)
-       (defun ,internal-set-function (gcontext new-value)
-	 (,set-function gcontext new-value)
-	 (setf (svref (gcontext-server-state gcontext) ,internal-state-index)
-	       (setf (svref (gcontext-local-state gcontext) ,internal-state-index)
-		     new-value)))
-       (defun ,internal-copy-function (src-gc dst-gc new-value)
-	 (,copy-function src-gc dst-gc new-value)
-	 (setf (svref (gcontext-local-state dst-gc) ,internal-state-index)
-	       (setf (svref (gcontext-server-state dst-gc) ,internal-state-index)
-		     new-value)))
-       ',name)))
-
-;; GContext extension fields are treated in much the same way as normal GContext
-;; components.  The current value is stored in a slot of the gcontext-local-state,
-;; and the value known to the server is in a slot of the gcontext-server-state.
-;; The slot-number is defined by its position in the *gcontext-extensions* list.
-;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is 
-;; the extension component name) reflects this position.  The position within
-;; *gcontext-extensions* and the value of the special value are determined at
-;; LOAD time to facilitate merging of seperately compiled extension files.
-
-(defun add-gcontext-extension (name default-value set-function copy-function)
-  (declare (type symbol name)
-	   (type t default-value)
-	   (type (function (gcontext t) t) set-function)
-	   (type (function (gcontext gcontext t) t) copy-function))
-  (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name)
-		    (prog1 (length *gcontext-extensions*)
-			   (push nil *gcontext-extensions*)))))
-    (setf (nth number *gcontext-extensions*)
-	  (make-gcontext-extension :name name
-				   :default default-value
-				   :set-function set-function
-				   :copy-function copy-function))
-    (+ number *gcontext-data-length*)))
diff --git a/clx/generalock.lisp b/clx/generalock.lisp
deleted file mode 100644
index cbf95a38a5e5502053b658d8db6c6421455394ea..0000000000000000000000000000000000000000
--- a/clx/generalock.lisp
+++ /dev/null
@@ -1,72 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*-
-
-;;; Copyright (C) 1990 Symbolics, Inc.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Symbolics, Inc. provides this software "as is" without
-;;; express or implied warranty.
-
-(defflavor xlib::clx-lock () (simple-recursive-normal-lock)
-  (:init-keywords :flavor))
-
-(defwhopper (lock-internal xlib::clx-lock) (lock-argument)
-  (catch 'timeout
-    (continue-whopper lock-argument)))
-
-(defmethod (lock-block-internal xlib::clx-lock) (lock-argument)
-  (declare (dbg:locking-function describe-process-lock-for-debugger self))
-  (when (null waiter-queue)
-    (setf waiter-queue (make-scheduler-queue :name name))
-    (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name)))
-  (let ((process (lock-argument-process lock-argument)))
-    (unwind-protect
-	(progn
-	  (lock-map-over-conflicting-owners
-	    self lock-argument
-	    #'(lambda (other-lock-arg)
-		(add-promotion process lock-argument
-			       (lock-argument-process other-lock-arg) other-lock-arg)))
-	  (unless (timer-pending-p timer)
-	    (when (and (safe-to-use-timers %real-current-process)
-		       (not dbg:*debugger-might-have-system-problems*))
-	      (reset-timer-relative-timer-units timer *lock-timer-interval*)))
-	  (assert (store-conditional (locf latch) process nil))
-	  (sys:with-aborts-enabled (lock-latch)
-	    (let ((timeout (lock-argument-getf lock-argument :timeout nil)))
-	      (cond ((null timeout)
-		     (promotion-block waiter-queue name #'lock-lockable self lock-argument))
-		    ((and (plusp timeout)
-			  (using-resource (timer process-block-timers)
-			    ;; Yeah, we know about the internal representation
-			    ;; of timers here.
-			    (setf (car (timer-args timer)) %real-current-process)
-			    (with-scheduler-locked
-			      (reset-timer-relative timer timeout)
-			      (flet ((lock-lockable-or-timeout (timer lock lock-argument)
-				       (or (not (timer-pending-p timer))
-					   (lock-lockable lock lock-argument))))
-				(let ((priority (process-process-priority *current-process*)))
-				  (if (ldb-test %%scheduler-priority-preemption-field priority)
-				      (promotion-block waiter-queue name
-						       #'lock-lockable-or-timeout
-						       timer self lock-argument)
-				      ;; Change to preemptive priority so that when
-				      ;; unlock-internal wakes us up so we can have the lock,
-				      ;; we will really wake up right away
-				      (with-process-priority
-					  (dpb 1 %%scheduler-priority-preemption-field
-					       priority)
-					(promotion-block waiter-queue name
-						       #'lock-lockable-or-timeout
-						       timer self lock-argument)))))
-			      (lock-lockable self lock-argument)))))
-		    (t (throw 'timeout nil))))))
-      (unless (store-conditional (locf latch) nil process)
-	(lock-latch-wait-internal self))
-      (remove-promotions process lock-argument))))
-
-(compile-flavor-methods xlib::clx-lock)
diff --git a/clx/graphics.lisp b/clx/graphics.lisp
deleted file mode 100644
index 6e99140912e1a7262af8face09552b1ad47349d7..0000000000000000000000000000000000000000
--- a/clx/graphics.lisp
+++ /dev/null
@@ -1,447 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;; CLX drawing requests
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-(defvar *inhibit-appending* nil)
-
-(defun draw-point (drawable gcontext x y)
-  ;; Should be clever about appending to existing buffered protocol request.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y))
-  (let ((display (drawable-display drawable)))
-    (declare (type display display))
-    (with-display (display)
-      (force-gcontext-changes-internal gcontext)
-      (with-buffer-output (display :length *requestsize*)
-	(let* ((last-request-byte (display-last-request display))
-	       (current-boffset buffer-boffset))
-	  ;; To append or not append, that is the question
-	  (if (and (not *inhibit-appending*)
-		   last-request-byte
-		   ;; Same request?
-		   (= (aref-card8 buffer-bbuf last-request-byte) *x-polypoint*)
-		   (progn ;; Set buffer pointers to last request
-		     (set-buffer-offset last-request-byte)
-		     ;; same drawable and gcontext?
-		     (or (compare-request (4)
-			   (data 0)
-			   (drawable drawable)
-			   (gcontext gcontext))
-			 (progn ;; If failed, reset buffer pointers
-			   (set-buffer-offset current-boffset)
-			   nil))))
-	      ;; Append request
-	      (progn
-		;; Set new request length		
-		(card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte)
-						   -2)))
-		(set-buffer-offset current-boffset)
-		(put-items (0)			; Insert new point
-		  (int16 x y))
-		(setf (display-boffset display) (index+ buffer-boffset 4)))
-	    ;; New Request
-	    (progn
-	      (put-items (4)
-		(code *x-polypoint*)
-		(data 0) ;; Relative-p false
-		(length 4)
-		(drawable drawable)
-		(gcontext gcontext)
-		(int16 x y))
-	      (buffer-new-request-number display)
-	      (setf (buffer-last-request display) buffer-boffset)
-	      (setf (display-boffset display) (index+ buffer-boffset 16)))))))
-    (display-invoke-after-function display))) 
-
-
-(defun draw-points (drawable gcontext points &optional relative-p)
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type sequence points)		;(repeat-seq (integer x) (integer y))
-	   (type boolean relative-p))
-  (with-buffer-request ((drawable-display drawable) *x-polypoint* :gc-force gcontext)
-    ((data boolean) relative-p)
-    (drawable drawable)
-    (gcontext gcontext)
-    ((sequence :format int16) points)))
-
-(defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p)
-  ;; Should be clever about appending to existing buffered protocol request.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x1 y1 x2 y2)
-	   (type boolean relative-p))
-  (let ((display (drawable-display drawable)))
-    (declare (type display display))
-    (when relative-p
-      (incf x2 x1)
-      (incf y2 y1))
-    (with-display (display)
-      (force-gcontext-changes-internal gcontext)
-      (with-buffer-output (display :length *requestsize*)
-	(let* ((last-request-byte (display-last-request display))
-	       (current-boffset buffer-boffset))
-	  ;; To append or not append, that is the question
-	  (if (and (not *inhibit-appending*)
-		   last-request-byte
-		   ;; Same request?
-		   (= (aref-card8 buffer-bbuf last-request-byte) *x-polysegment*)
-		   (progn ;; Set buffer pointers to last request
-		     (set-buffer-offset last-request-byte)
-		     ;; same drawable and gcontext?
-		     (or (compare-request (4)
-			   (drawable drawable)
-			   (gcontext gcontext))
-			 (progn ;; If failed, reset buffer pointers
-			   (set-buffer-offset current-boffset)
-			   nil))))
-	      ;; Append request
-	      (progn
-		;; Set new request length
-		(card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
-						   -2)))
-		(set-buffer-offset current-boffset)
-		(put-items (0)			; Insert new point
-		  (int16 x1 y1 x2 y2))
-		(setf (display-boffset display) (index+ buffer-boffset 8)))
-	    ;; New Request
-	    (progn
-	      (put-items (4)
-		(code *x-polysegment*)
-		(length 5)
-		(drawable drawable)
-		(gcontext gcontext)
-		(int16 x1 y1 x2 y2))
-	      (buffer-new-request-number display)
-	      (setf (buffer-last-request display) buffer-boffset)
-	      (setf (display-boffset display) (index+ buffer-boffset 20)))))))
-    (display-invoke-after-function display))) 
-
-(defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex))
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type sequence points) ;(repeat-seq (integer x) (integer y))
-	   (type boolean relative-p fill-p)
-	   (type (member :complex :non-convex :convex) shape))
-  (if fill-p
-      (fill-polygon drawable gcontext points relative-p shape)
-    (with-buffer-request ((drawable-display drawable)  *x-polyline* :gc-force gcontext)
-      ((data boolean) relative-p)
-      (drawable drawable)
-      (gcontext gcontext)
-      ((sequence :format int16) points))))
-
-;; Internal function called from DRAW-LINES
-(defun fill-polygon (drawable gcontext points relative-p shape)
-  ;; This is clever about appending to previous requests.  Should it be?
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type sequence points)		;(repeat-seq (integer x) (integer y))
-	   (type boolean relative-p)
-	   (type (member :complex :non-convex :convex) shape))
-  (with-buffer-request ((drawable-display drawable)  *x-fillpoly* :gc-force gcontext)
-    (drawable drawable)
-    (gcontext gcontext)
-    ((member8 :complex :non-convex :convex) shape)
-    (boolean relative-p)
-    ((sequence :format int16) points)))
-
-(defun draw-segments (drawable gcontext segments)
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2)))
-	   (type sequence segments)) 
-  (with-buffer-request ((drawable-display drawable) *x-polysegment* :gc-force gcontext)
-    (drawable drawable)
-    (gcontext gcontext)
-    ((sequence :format int16) segments)))
-
-(defun draw-rectangle (drawable gcontext x y width height &optional fill-p)
-  ;; Should be clever about appending to existing buffered protocol request.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type boolean fill-p))
-  (let ((display (drawable-display drawable))
-	(request (if fill-p *x-polyfillrectangle* *x-polyrectangle*)))
-    (declare (type display display)
-	     (type card16 request))
-    (with-display (display)
-      (force-gcontext-changes-internal gcontext)
-      (with-buffer-output (display :length *requestsize*)
-	(let* ((last-request-byte (display-last-request display))
-	       (current-boffset buffer-boffset))
-	  ;; To append or not append, that is the question
-	  (if (and (not *inhibit-appending*)
-		   last-request-byte
-		   ;; Same request?
-		   (= (aref-card8 buffer-bbuf last-request-byte) request)
-		   (progn ;; Set buffer pointers to last request
-		     (set-buffer-offset last-request-byte)
-		     ;; same drawable and gcontext?
-		     (or (compare-request (4)
-			   (drawable drawable)
-			   (gcontext gcontext))
-			 (progn ;; If failed, reset buffer pointers
-			   (set-buffer-offset current-boffset)
-			   nil))))
-	      ;; Append request
-	      (progn
-		;; Set new request length
-		(card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
-						   -2)))
-		(set-buffer-offset current-boffset)
-		(put-items (0)			; Insert new point
-		  (int16 x y)
-		  (card16 width height))
-		(setf (display-boffset display) (index+ buffer-boffset 8)))
-	    ;; New Request
-	    (progn
-	      (put-items (4)
-		(code request)
-		(length 5)
-		(drawable drawable)
-		(gcontext gcontext)
-		(int16 x y)
-		(card16 width height))
-	      (buffer-new-request-number display)
-	      (setf (buffer-last-request display) buffer-boffset)
-	      (setf (display-boffset display) (index+ buffer-boffset 20)))))))
-    (display-invoke-after-function display))) 
-
-(defun draw-rectangles (drawable gcontext rectangles &optional fill-p)
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   ;; (repeat-seq (integer x) (integer y) (integer width) (integer height)))
-	   (type sequence rectangles)
-	   (type boolean fill-p))
-  (with-buffer-request ((drawable-display drawable)
-			(if fill-p *x-polyfillrectangle* *x-polyrectangle*)
-			:gc-force gcontext)
-    (drawable drawable)
-    (gcontext gcontext)
-    ((sequence :format int16) rectangles)))
-
-(defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p)
-  ;; Should be clever about appending to existing buffered protocol request.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type angle angle1 angle2)
-	   (type boolean fill-p))
-  (let ((display (drawable-display drawable))
-	(request (if fill-p *x-polyfillarc* *x-polyarc*)))
-    (declare (type display display)
-	     (type card16 request))
-    (with-display (display)
-      (force-gcontext-changes-internal gcontext)
-      (with-buffer-output (display :length *requestsize*)
-	(let* ((last-request-byte (display-last-request display))
-	       (current-boffset buffer-boffset))
-	  ;; To append or not append, that is the question
-	  (if (and (not *inhibit-appending*)
-		   last-request-byte
-		   ;; Same request?
-		   (= (aref-card8 buffer-bbuf last-request-byte) request)
-		   (progn ;; Set buffer pointers to last request
-		     (set-buffer-offset last-request-byte)
-		     ;; same drawable and gcontext?
-		     (or (compare-request (4)
-			   (drawable drawable)
-			   (gcontext gcontext))
-			 (progn ;; If failed, reset buffer pointers
-			   (set-buffer-offset current-boffset)
-			   nil))))
-	      ;; Append request
-	      (progn
-		;; Set new request length		
-		(card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte)
-						   -2)))
-		(set-buffer-offset current-boffset)
-		(put-items (0)			; Insert new point
-		  (int16 x y)
-		  (card16 width height)
-		  (angle angle1 angle2))
-		(setf (display-boffset display) (index+ buffer-boffset 12)))
-	    ;; New Request
-	    (progn
-	      (put-items (4)
-		(code request)
-		(length 6)
-		(drawable drawable)
-		(gcontext gcontext)
-		(int16 x y)
-		(card16 width height)
-		(angle angle1 angle2))
-	      (buffer-new-request-number display)
-	      (setf (buffer-last-request display) buffer-boffset)
-	      (setf (display-boffset display) (index+ buffer-boffset 24)))))))
-    (display-invoke-after-function display))) 
-
-(defun draw-arcs-list (drawable gcontext arcs &optional fill-p)
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type list arcs) 
-	   (type boolean fill-p))
-  (let* ((display (drawable-display drawable))
-	 (limit (index- (buffer-size display) 12))
-	 (length (length arcs))
-	 (request (if fill-p *x-polyfillarc* *x-polyarc*)))
-    (with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
-      (drawable drawable)
-      (gcontext gcontext)
-      (progn
-	(card16-put 2 (index+ (index-ash length -1) 3))	; Set request length (in words)
-	(set-buffer-offset (index+ buffer-boffset 12))  ; Position to start of data
-	(do ((arc arcs))
-	    ((endp arc)
-	     (setf (buffer-boffset display) buffer-boffset))
-	  ;; Make sure there's room
-	  (when (index>= buffer-boffset limit)
-	    (setf (buffer-boffset display) buffer-boffset)
-	    (buffer-flush display)
-	    (set-buffer-offset (buffer-boffset display)))
-	  (int16-put  0 (pop arc))
-	  (int16-put  2 (pop arc))
-	  (card16-put 4 (pop arc))
-	  (card16-put 6 (pop arc))
-	  (angle-put  8 (pop arc))
-	  (angle-put 10 (pop arc))
-	  (set-buffer-offset (index+ buffer-boffset 12)))))))
-
-(defun draw-arcs-vector (drawable gcontext arcs &optional fill-p)
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type vector arcs) 
-	   (type boolean fill-p))
-  (let* ((display (drawable-display drawable))
-	 (limit (index- (buffer-size display) 12))
-	 (length (length arcs))
-	 (request (if fill-p *x-polyfillarc* *x-polyarc*)))
-    (with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
-      (drawable drawable)
-      (gcontext gcontext)
-      (progn
-	(card16-put 2 (index+ (index-ash length -1) 3))	; Set request length (in words)
-	(set-buffer-offset (index+ buffer-boffset 12))  ; Position to start of data
-	(do ((n 0 (index+ n 6))
-	     (length (length arcs)))
-	    ((index>= n length)
-	     (setf (buffer-boffset display) buffer-boffset))
-	  ;; Make sure there's room
-	  (when (index>= buffer-boffset limit)
-	    (setf (buffer-boffset display) buffer-boffset)
-	    (buffer-flush display)
-	    (set-buffer-offset (buffer-boffset display)))
-	  (int16-put  0 (aref arcs (index+ n 0)))
-	  (int16-put  2 (aref arcs (index+ n 1)))
-	  (card16-put 4 (aref arcs (index+ n 2)))
-	  (card16-put 6 (aref arcs (index+ n 3)))
-	  (angle-put  8 (aref arcs (index+ n 4)))
-	  (angle-put 10 (aref arcs (index+ n 5)))
-	  (set-buffer-offset (index+ buffer-boffset 12)))))))
-
-(defun draw-arcs (drawable gcontext arcs &optional fill-p)
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type sequence arcs) 
-	   (type boolean fill-p))
-  (etypecase arcs
-    (list (draw-arcs-list drawable gcontext arcs fill-p))
-    (vector (draw-arcs-vector drawable gcontext arcs fill-p))))
-
-;; The following image routines are bare minimum.  It may be useful to define
-;; some form of "image" object to hide representation details and format
-;; conversions.  It also may be useful to provide stream-oriented interfaces
-;; for reading and writing the data.
-
-(defun put-raw-image (drawable gcontext data &key
-		      (start 0)
-		      (depth (required-arg depth))
-		      (x (required-arg x))
-		      (y (required-arg y))
-		      (width (required-arg width))
-		      (height (required-arg height))
-		      (left-pad 0)
-		      (format (required-arg format)))
-  ;; Data must be a sequence of 8-bit quantities, already in the appropriate format
-  ;; for transmission; the caller is responsible for all byte and bit swapping and
-  ;; compaction.  Start is the starting index in data; the end is computed from the
-  ;; other arguments.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type sequence data) ; Sequence of integers
-	   (type array-index start)
-	   (type card8 depth left-pad) ;; required
-	   (type int16 x y) ;; required
-	   (type card16 width height) ;; required
-	   (type (member :bitmap :xy-pixmap :z-pixmap) format))
-  (with-buffer-request ((drawable-display drawable) *x-putimage* :gc-force gcontext)
-    ((data (member :bitmap :xy-pixmap :z-pixmap)) format)
-    (drawable drawable)
-    (gcontext gcontext)
-    (card16 width height)
-    (int16 x y)
-    (card8 left-pad depth)
-    (pad16 nil)
-    ((sequence :format card8 :start start) data)))
-
-(defun get-raw-image (drawable &key
-		      data
-		      (start 0)
-		      (x (required-arg x))
-		      (y (required-arg y))
-		      (width (required-arg width))
-		      (height (required-arg height))
-		      (plane-mask #xffffffff)
-		      (format (required-arg format))
-		      (result-type '(vector card8)))
-  ;; If data is given, it is modified in place (and returned), otherwise a new sequence
-  ;; is created and returned, with a size computed from the other arguments and the
-  ;; returned depth.  The sequence is filled with 8-bit quantities, in transmission
-  ;; format; the caller is responsible for any byte and bit swapping and compaction
-  ;; required for further local use.
-  (declare (type drawable drawable)
-	   (type (or null sequence) data) ;; sequence of integers
-	   (type int16 x y) ;; required
-	   (type card16 width height) ;; required
-	   (type array-index start)
-	   (type pixel plane-mask)
-	   (type (member :xy-pixmap :z-pixmap) format))
-  (declare (clx-values (clx-sequence integer) depth visual-info))
-  (let ((display (drawable-display drawable)))
-    (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32))
-	 (((data (member error :xy-pixmap :z-pixmap)) format)
-	  (drawable drawable)
-	  (int16 x y)
-	  (card16 width height)
-	  (card32 plane-mask))
-      (let ((depth (card8-get 1))
-	    (length (* 4 (card32-get 4)))
-	    (visual (resource-id-get 8)))
-	(values (sequence-get :result-type result-type :format card8
-			      :length length :start start :data data
-			      :index *replysize*)
-		depth
-		(visual-info display visual))))))
diff --git a/clx/image.lisp b/clx/image.lisp
deleted file mode 100644
index be8099688a6acab9a8838c08abd67c05be0444f9..0000000000000000000000000000000000000000
--- a/clx/image.lisp
+++ /dev/null
@@ -1,2666 +0,0 @@
-;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
-
-;;; CLX Image functions
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-(defmacro with-image-data-buffer ((buffer size) &body body)
-  (declare (indentation 0 4 1 1))
-  `(let ((.reply-buffer. (allocate-reply-buffer ,size)))
-     (declare (type reply-buffer .reply-buffer.))
-     (unwind-protect
-	 (let ((,buffer (reply-ibuf8 .reply-buffer.)))
-	   (declare (type buffer-bytes ,buffer))
-	   (with-vector (,buffer buffer-bytes)
-	     ,@body))
-       (deallocate-reply-buffer .reply-buffer.))))
-
-(def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil))
-  ;; Public structure
-  (width 0 :type card16 :read-only t)
-  (height 0 :type card16 :read-only t)
-  (depth 1 :type card8 :read-only t)
-  (plist nil :type list))
-
-;; Image-Plist accessors:
-(defmacro image-name (image) `(getf (image-plist ,image) :name))
-(defmacro image-x-hot (image) `(getf (image-plist ,image) :x-hot))
-(defmacro image-y-hot (image) `(getf (image-plist ,image) :y-hot))
-(defmacro image-red-mask (image) `(getf (image-plist ,image) :red-mask))
-(defmacro image-blue-mask (image) `(getf (image-plist ,image) :blue-mask))
-(defmacro image-green-mask (image) `(getf (image-plist ,image) :green-mask))
-
-(defun print-image (image stream depth)
-  (declare (type image image)
-	   (ignore depth))
-  (print-unreadable-object (image stream :type t)
-    (when (image-name image)
-      (write-string (string (image-name image)) stream)
-      (write-string " " stream))
-    (prin1 (image-width image) stream)
-    (write-string "x" stream)
-    (prin1 (image-height image) stream)
-    (write-string "x" stream)
-    (prin1 (image-depth image) stream)))
-
-(defconstant *empty-data-x* '#.(make-sequence '(array card8 (*)) 0))
-
-(defconstant *empty-data-z*
-	     '#.(make-array '(0 0) :element-type 'pixarray-1-element-type))
-
-(def-clx-class (image-x (:include image) (:copier nil)
-			(:print-function print-image))
-  ;; Use this format for shoveling image data
-  ;; Private structure. Accessors for these NOT exported.
-  (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap))
-  (bytes-per-line 0 :type card16)
-  (bits-per-pixel 1 :type (member 1 4 8 16 24 32))
-  (bit-lsb-first-p *image-bit-lsb-first-p* :type boolean)	; Bit order
-  (byte-lsb-first-p *image-byte-lsb-first-p* :type boolean)	; Byte order
-  (data *empty-data-x* :type (array card8 (*)))			; row-major
-  (unit *image-unit* :type (member 8 16 32))			; Bitmap unit
-  (pad *image-pad* :type (member 8 16 32))			; Scanline pad
-  (left-pad 0 :type card8))					; Left pad
-
-(def-clx-class (image-xy (:include image) (:copier nil)
-			 (:print-function print-image))
-  ;; Public structure
-  ;; Use this format for image processing
-  (bitmap-list nil :type list)) ;; list of bitmaps
-
-(def-clx-class (image-z (:include image) (:copier nil)
-			(:print-function print-image))
-  ;; Public structure
-  ;; Use this format for image processing
-  (bits-per-pixel 1 :type (member 1 4 8 16 24 32))
-  (pixarray *empty-data-z* :type pixarray))
-
-(defun create-image (&key width height depth
-		     (data (required-arg data))
-		     plist name x-hot y-hot
-		     red-mask blue-mask green-mask
-		     bits-per-pixel format bytes-per-line
-		     (byte-lsb-first-p 
-		       #+clx-little-endian t
-		       #-clx-little-endian nil)
-		     (bit-lsb-first-p
-		       #+clx-little-endian t
-		       #-clx-little-endian nil)
-		     unit pad left-pad)
-  ;; Returns an image-x image-xy or image-z structure, depending on the
-  ;; type of the :DATA parameter.
-  (declare
-    (type (or null card16) width height)	; Required
-    (type (or null card8) depth)		; Defualts to 1
-    (type (or buffer-bytes			; Returns image-x
-	      list				; Returns image-xy
-	      pixarray) data)			; Returns image-z
-    (type list plist)
-    (type (or null stringable) name)
-    (type (or null card16) x-hot y-hot)
-    (type (or null pixel) red-mask blue-mask green-mask)
-    (type (or null (member 1 4 8 16 24 32)) bits-per-pixel)
-    
-    ;; The following parameters are ignored for image-xy and image-z:
-    (type (or null (member :bitmap :xy-pixmap :z-pixmap))
-	  format)				; defaults to :z-pixmap
-    (type (or null card16) bytes-per-line)
-    (type boolean byte-lsb-first-p bit-lsb-first-p)
-    (type (or null (member 8 16 32)) unit pad)
-    (type (or null card8) left-pad))
-  (declare (clx-values image))
-  (let ((image
-	  (etypecase data
-	    (buffer-bytes			; image-x
-	      (let ((data data))
-		(declare (type buffer-bytes data))
-		(unless depth (setq depth (or bits-per-pixel 1)))
-		(unless format
-		  (setq format (if (= depth 1) :xy-pixmap :z-pixmap)))
-		(unless bits-per-pixel
-		  (setq bits-per-pixel
-			(cond ((eq format :xy-pixmap) 1)
-			      ((index> depth 24) 32)
-			      ((index> depth 16) 24)
-			      ((index> depth 8)  16)
-			      ((index> depth 4)   8)
-			      ((index> depth 1)   4)
-			      (t                  1))))
-		(unless width (required-arg width))
-		(unless height (required-arg height))
-		(unless bytes-per-line
-		  (let* ((pad (or pad 8))
-			 (bits-per-line (index* width bits-per-pixel))
-			 (padded-bits-per-line
-			   (index* (index-ceiling bits-per-line pad) pad)))
-		    (declare (type array-index pad bits-per-line
-				   padded-bits-per-line))
-		    (setq bytes-per-line (index-ceiling padded-bits-per-line 8))))
-		(unless unit (setq unit *image-unit*))
-		(unless pad
-		  (setq pad
-			(dolist (pad '(32 16 8))
-			  (when (and (index<= pad *image-pad*)
-				     (zerop
-				       (index-mod
-					 (index* bytes-per-line 8) pad)))
-			    (return pad)))))
-		(unless left-pad (setq left-pad 0))
-		(make-image-x
-		  :width width :height height :depth depth :plist plist
-		  :format format :data data
-		  :bits-per-pixel bits-per-pixel 
-		  :bytes-per-line bytes-per-line
-		  :byte-lsb-first-p byte-lsb-first-p
-		  :bit-lsb-first-p bit-lsb-first-p
-		  :unit unit :pad pad :left-pad left-pad)))
-	    (list				; image-xy
-	      (let ((data data))
-		(declare (type list data))
-		(unless depth (setq depth (length data)))
-		(when data
-		  (unless width (setq width (array-dimension (car data) 1)))
-		  (unless height (setq height (array-dimension (car data) 0))))
-		(make-image-xy
-		  :width width :height height :plist plist :depth depth
-		  :bitmap-list data)))
-	    (pixarray				; image-z
-	      (let ((data data))
-		(declare (type pixarray data))
-		(unless width (setq width (array-dimension data 1)))
-		(unless height (setq height (array-dimension data 0)))
-		(unless bits-per-pixel
-		  (setq bits-per-pixel
-			(etypecase data
-			  (pixarray-32 32)
-			  (pixarray-24 24)
-			  (pixarray-16 16)
-			  (pixarray-8   8)
-			  (pixarray-4   4)
-			  (pixarray-1   1)))))
-	      (unless depth (setq depth bits-per-pixel))
-	      (make-image-z
-		:width width :height height :depth depth :plist plist
-		:bits-per-pixel bits-per-pixel :pixarray data)))))
-    (declare (type image image))
-    (when name (setf (image-name image) name))
-    (when x-hot (setf (image-x-hot image) x-hot))
-    (when y-hot (setf (image-y-hot image) y-hot))
-    (when red-mask (setf (image-red-mask image) red-mask))
-    (when blue-mask (setf (image-blue-mask image) blue-mask))
-    (when green-mask (setf (image-green-mask image) green-mask))
-    image))
-
-;;;-----------------------------------------------------------------------------
-;;; Swapping stuff
-
-(defun image-noswap
-       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
-  (declare (type buffer-bytes src dest)
-	   (type array-index srcoff destoff srclen srcinc destinc)
-	   (type card16 height)
-	   (type boolean lsb-first-p)
-	   (ignore lsb-first-p))
-  #.(declare-buffun)
-  (if (index= srcinc destinc)
-      (buffer-replace
-	dest src destoff
-	(index+ destoff (index* srcinc (index1- height)) srclen)
-	srcoff)
-    (do* ((h height (index1- h))
-	  (srcstart srcoff (index+ srcstart srcinc))
-	  (deststart destoff (index+ deststart destinc))
-	  (destend (index+ deststart srclen) (index+ deststart srclen)))
-	 ((index-zerop h))
-      (declare (type array-index srcstart deststart destend)
-	       (type card16 h))
-      (buffer-replace dest src deststart destend srcstart))))
-
-(defun image-swap-two-bytes
-       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
-  (declare (type buffer-bytes src dest)
-	   (type array-index srcoff destoff srclen srcinc destinc)
-	   (type card16 height)
-	   (type boolean lsb-first-p))
-  #.(declare-buffun)
-  (with-vector (src buffer-bytes)
-    (with-vector (dest buffer-bytes)
-      (do ((length (index* (index-ceiling srclen 2) 2))
-	   (h height (index1- h))
-	   (srcstart srcoff (index+ srcstart srcinc))
-	   (deststart destoff (index+ deststart destinc)))
-	  ((index-zerop h))
-	(declare (type array-index length srcstart deststart)
-		 (type card16 h))
-	(when (and (index= h 1) (not (index= srclen length)))
-	  (index-decf length 2)
-	  (if lsb-first-p
-	      (setf (aref dest (index1+ (index+ deststart length)))
-		    (the card8 (aref src (index+ srcstart length))))
-	    (setf (aref dest (index+ deststart length))
-		  (the card8 (aref src (index1+ (index+ srcstart length)))))))
-	(do ((i length (index- i 2))
-	     (srcidx srcstart (index+ srcidx 2))
-	     (destidx deststart (index+ destidx 2)))
-	    ((index-zerop i))
-	  (declare (type array-index i srcidx destidx))
-	  (setf (aref dest destidx)
-		(the card8 (aref src (index1+ srcidx))))
-	  (setf (aref dest (index1+ destidx))
-		(the card8 (aref src srcidx))))))))
-
-(defun image-swap-three-bytes
-       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
-  (declare (type buffer-bytes src dest)
-	   (type array-index srcoff destoff srclen srcinc destinc)
-	   (type card16 height)
-	   (type boolean lsb-first-p))
-  #.(declare-buffun)
-  (with-vector (src buffer-bytes)
-    (with-vector (dest buffer-bytes)
-      (do ((length (index* (index-ceiling srclen 3) 3))
-	   (h height (index1- h))
-	   (srcstart srcoff (index+ srcstart srcinc))
-	   (deststart destoff (index+ deststart destinc)))
-	  ((index-zerop h))
-	(declare (type array-index length srcstart deststart)
-		 (type card16 h))
-	(when (and (index= h 1) (not (index= srclen length)))
-	  (index-decf length 3)
-	  (when (index= (index- srclen length) 2)
-	    (setf (aref dest (index+ deststart length 1))
-		  (the card8 (aref src (index+ srcstart length 1)))))
-	  (if lsb-first-p
-	      (setf (aref dest (index+ deststart length 2))
-		    (the card8 (aref src (index+ srcstart length))))
-	    (setf (aref dest (index+ deststart length))
-		  (the card8 (aref src (index+ srcstart length 2))))))
-	(do ((i length (index- i 3))
-	     (srcidx srcstart (index+ srcidx 3))
-	     (destidx deststart (index+ destidx 3)))
-	    ((index-zerop i))
-	  (declare (type array-index i srcidx destidx))
-	  (setf (aref dest destidx)
-		(the card8 (aref src (index+ srcidx 2))))
-	  (setf (aref dest (index1+ destidx))
-		(the card8 (aref src (index1+ srcidx))))
-	  (setf (aref dest (index+ destidx 2))
-		(the card8 (aref src srcidx))))))))
-
-(defun image-swap-four-bytes
-       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
-  (declare (type buffer-bytes src dest)
-	   (type array-index srcoff destoff srclen srcinc destinc)
-	   (type card16 height)
-	   (type boolean lsb-first-p))
-  #.(declare-buffun)
-  (with-vector (src buffer-bytes)
-    (with-vector (dest buffer-bytes)
-      (do ((length (index* (index-ceiling srclen 4) 4))
-	   (h height (index1- h))
-	   (srcstart srcoff (index+ srcstart srcinc))
-	   (deststart destoff (index+ deststart destinc)))
-	  ((index-zerop h))
-	(declare (type array-index length srcstart deststart)
-		 (type card16 h))
-	(when (and (index= h 1) (not (index= srclen length)))
-	  (index-decf length 4)
-	  (unless lsb-first-p
-	    (setf (aref dest (index+ deststart length))
-		  (the card8 (aref src (index+ srcstart length 3)))))
-	  (when (if lsb-first-p
-		    (index= (index- srclen length) 3)
-		  (not (index-zerop (index-logand srclen 2))))
-	    (setf (aref dest (index+ deststart length 1))
-		  (the card8 (aref src (index+ srcstart length 2)))))
-	  (when (if (null lsb-first-p)
-		    (index= (index- srclen length) 3)
-		  (not (index-zerop (index-logand srclen 2))))
-	    (setf (aref dest (index+ deststart length 2))
-		  (the card8 (aref src (index+ srcstart length 1)))))
-	  (when lsb-first-p
-	    (setf (aref dest (index+ deststart length 3))
-		  (the card8 (aref src (index+ srcstart length))))))
-	(do ((i length (index- i 4))
-	     (srcidx srcstart (index+ srcidx 4))
-	     (destidx deststart (index+ destidx 4)))
-	    ((index-zerop i))
-	  (declare (type array-index i srcidx destidx))
-	  (setf (aref dest destidx)
-		(the card8 (aref src (index+ srcidx 3))))
-	  (setf (aref dest (index1+ destidx))
-		(the card8 (aref src (index+ srcidx 2))))
-	  (setf (aref dest (index+ destidx 2))
-		(the card8 (aref src (index1+ srcidx))))
-	  (setf (aref dest (index+ destidx 3))
-		(the card8 (aref src srcidx))))))))
-
-(defun image-swap-words
-       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
-  (declare (type buffer-bytes src dest)
-	   (type array-index srcoff destoff srclen srcinc destinc)
-	   (type card16 height)
-	   (type boolean lsb-first-p))
-  #.(declare-buffun)
-  (with-vector (src buffer-bytes)
-    (with-vector (dest buffer-bytes)
-      (do ((length (index* (index-ceiling srclen 4) 4))
-	   (h height (index1- h))
-	   (srcstart srcoff (index+ srcstart srcinc))
-	   (deststart destoff (index+ deststart destinc)))
-	  ((index-zerop h))
-	(declare (type array-index length srcstart deststart)
-		 (type card16 h))
-	(when (and (index= h 1) (not (index= srclen length)))
-	  (index-decf length 4)
-	  (unless lsb-first-p
-	    (setf (aref dest (index+ deststart length 1))
-		  (the card8 (aref src (index+ srcstart length 3)))))
-	  (when (if lsb-first-p
-		    (index= (index- srclen length) 3)
-		  (not (index-zerop (index-logand srclen 2))))
-	    (setf (aref dest (index+ deststart length))
-		  (the card8 (aref src (index+ srcstart length 2)))))
-	  (when (if (null lsb-first-p)
-		    (index= (index- srclen length) 3)
-		  (not (index-zerop (index-logand srclen 2))))
-	    (setf (aref dest (index+ deststart length 3))
-		  (the card8 (aref src (index+ srcstart length 1)))))
-	  (when lsb-first-p
-	    (setf (aref dest (index+ deststart length 2))
-		  (the card8 (aref src (index+ srcstart length))))))
-	(do ((i length (index- i 4))
-	     (srcidx srcstart (index+ srcidx 4))
-	     (destidx deststart (index+ destidx 4)))
-	    ((index-zerop i))
-	  (declare (type array-index i srcidx destidx))
-	  (setf (aref dest destidx)
-		(the card8 (aref src (index+ srcidx 2))))
-	  (setf (aref dest (index1+ destidx))
-		(the card8 (aref src (index+ srcidx 3))))
-	  (setf (aref dest (index+ destidx 2))
-		(the card8 (aref src srcidx)))
-	  (setf (aref dest (index+ destidx 3))
-		(the card8 (aref src (index1+ srcidx)))))))))
-
-(defun image-swap-nibbles
-       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
-  (declare (type buffer-bytes src dest)
-	   (type array-index srcoff destoff srclen srcinc destinc)
-	   (type card16 height)
-	   (type boolean lsb-first-p)
-	   (ignore lsb-first-p))
-  #.(declare-buffun)
-  (with-vector (src buffer-bytes)
-    (with-vector (dest buffer-bytes)
-      (do ((h height (index1- h))
-	   (srcstart srcoff (index+ srcstart srcinc))
-	   (deststart destoff (index+ deststart destinc)))
-	  ((index-zerop h))
-	(declare (type array-index srcstart deststart)
-		 (type card16 h))
-	(do ((i srclen (index1- i))
-	     (srcidx srcstart (index1+ srcidx))
-	     (destidx deststart (index1+ destidx)))
-	    ((index-zerop i))
-	  (declare (type array-index i srcidx destidx))
-	  (setf (aref dest destidx)
-		(the card8
-		     (let ((byte (aref src srcidx)))
-		       (declare (type card8 byte))
-		       (dpb (the card4 (ldb (byte 4 0) byte))
-			    (byte 4 4)
-			    (the card4 (ldb (byte 4 4) byte)))))))))))
-
-(defun image-swap-nibbles-left
-       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
-  (declare (type buffer-bytes src dest)
-	   (type array-index srcoff destoff srclen srcinc destinc)
-	   (type card16 height)
-	   (type boolean lsb-first-p)
-	   (ignore lsb-first-p))
-  #.(declare-buffun)
-  (with-vector (src buffer-bytes)
-    (with-vector (dest buffer-bytes)
-      (do ((h height (index1- h))
-	   (srcstart srcoff (index+ srcstart srcinc))
-	   (deststart destoff (index+ deststart destinc)))
-	  ((index-zerop h))
-	(declare (type array-index srcstart deststart)
-		 (type card16 h))
-	(do ((i srclen (index1- i))
-	     (srcidx srcstart (index1+ srcidx))
-	     (destidx deststart (index1+ destidx)))
-	    ((index= i 1)
-	     (setf (aref dest destidx)
-		   (the card8
-			(let ((byte1 (aref src srcidx)))
-			  (declare (type card8 byte1))
-			  (dpb (the card4 (ldb (byte 4 0) byte1))
-			       (byte 4 4)
-			       0)))))
-	  (declare (type array-index i srcidx destidx))
-	  (setf (aref dest destidx)
-		(the card8
-		     (let ((byte1 (aref src srcidx))
-			   (byte2 (aref src (index1+ srcidx))))
-		       (declare (type card8 byte1 byte2))
-		       (dpb (the card4 (ldb (byte 4 0) byte1))
-			    (byte 4 4)
-			    (the card4 (ldb (byte 4 4) byte2)))))))))))
-
-(defconstant
-  *image-byte-reverse*
-  '#.(coerce
-       '#(
-	  0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240
-	  8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248
-	  4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244
-	  12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252
-	  2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242
-	  10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250
-	  6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246
-	  14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254
-	  1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241
-	  9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249
-	  5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245
-	  13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253
-	  3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243
-	  11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251
-	  7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247
-	  15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255)
-       '(vector card8)))
-
-(defun image-swap-bits
-       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
-  (declare (type buffer-bytes src dest)
-	   (type array-index srcoff destoff srclen srcinc destinc)
-	   (type card16 height)
-	   (type boolean lsb-first-p)
-	   (ignore lsb-first-p))
-  #.(declare-buffun)
-  (with-vector (src buffer-bytes)
-    (with-vector (dest buffer-bytes)
-      (let ((byte-reverse *image-byte-reverse*))
-	(with-vector (byte-reverse (simple-array card8 (256)))
-	  (macrolet ((br (byte)
-		       `(the card8 (aref byte-reverse (the card8 ,byte)))))
-	    (do ((h height (index1- h))
-		 (srcstart srcoff (index+ srcstart srcinc))
-		 (deststart destoff (index+ deststart destinc)))
-		((index-zerop h))
-	      (declare (type array-index srcstart deststart)
-		       (type card16 h))
-	      (do ((i srclen (index1- i))
-		   (srcidx srcstart (index1+ srcidx))
-		   (destidx deststart (index1+ destidx)))
-		  ((index-zerop i))
-		(declare (type array-index i srcidx destidx))
-		(setf (aref dest destidx) (br (aref src srcidx)))))))))))
-
-(defun image-swap-bits-and-two-bytes
-       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
-  (declare (type buffer-bytes src dest)
-	   (type array-index srcoff destoff srclen srcinc destinc)
-	   (type card16 height)
-	   (type boolean lsb-first-p))
-  #.(declare-buffun)
-  (with-vector (src buffer-bytes)
-    (with-vector (dest buffer-bytes)
-      (let ((byte-reverse *image-byte-reverse*))
-	(with-vector (byte-reverse (simple-array card8 (256)))
-	  (macrolet ((br (byte)
-		       `(the card8 (aref byte-reverse (the card8 ,byte)))))
-	    (do ((length (index* (index-ceiling srclen 2) 2))
-		 (h height (index1- h))
-		 (srcstart srcoff (index+ srcstart srcinc))
-		 (deststart destoff (index+ deststart destinc)))
-		((index-zerop h))
-	      (declare (type array-index length srcstart deststart)
-		       (type card16 h))
-	      (when (and (index= h 1) (not (index= srclen length)))
-		(index-decf length 2)
-		(if lsb-first-p
-		    (setf (aref dest (index1+ (index+ deststart length)))
-			  (br (aref src (index+ srcstart length))))
-		  (setf (aref dest (index+ deststart length))
-			(br (aref src (index1+ (index+ srcstart length)))))))
-	      (do ((i length (index- i 2))
-		   (srcidx srcstart (index+ srcidx 2))
-		   (destidx deststart (index+ destidx 2)))
-		  ((index-zerop i))
-		(declare (type array-index i srcidx destidx))
-		(setf (aref dest destidx)
-		      (br (aref src (index1+ srcidx))))
-		(setf (aref dest (index1+ destidx))
-		      (br (aref src srcidx)))))))))))
-
-(defun image-swap-bits-and-four-bytes
-       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
-  (declare (type buffer-bytes src dest)
-	   (type array-index srcoff destoff srclen srcinc destinc)
-	   (type card16 height)
-	   (type boolean lsb-first-p))
-  #.(declare-buffun)
-  (with-vector (src buffer-bytes)
-    (with-vector (dest buffer-bytes)
-      (let ((byte-reverse *image-byte-reverse*))
-	(with-vector (byte-reverse (simple-array card8 (256)))
-	  (macrolet ((br (byte)
-		       `(the card8 (aref byte-reverse (the card8 ,byte)))))
-	    (do ((length (index* (index-ceiling srclen 4) 4))
-		 (h height (index1- h))
-		 (srcstart srcoff (index+ srcstart srcinc))
-		 (deststart destoff (index+ deststart destinc)))
-		((index-zerop h))
-	      (declare (type array-index length srcstart deststart)
-		       (type card16 h))
-	      (when (and (index= h 1) (not (index= srclen length)))
-		(index-decf length 4)
-		(unless lsb-first-p
-		  (setf (aref dest (index+ deststart length))
-			(br (aref src (index+ srcstart length 3)))))
-		(when (if lsb-first-p
-			  (index= (index- srclen length) 3)
-			(not (index-zerop (index-logand srclen 2))))
-		  (setf (aref dest (index+ deststart length 1))
-			(br (aref src (index+ srcstart length 2)))))
-		(when (if (null lsb-first-p)
-			  (index= (index- srclen length) 3)
-			(not (index-zerop (index-logand srclen 2))))
-		  (setf (aref dest (index+ deststart length 2))
-			(br (aref src (index+ srcstart length 1)))))
-		(when lsb-first-p
-		  (setf (aref dest (index+ deststart length 3))
-			(br (aref src (index+ srcstart length))))))
-	      (do ((i length (index- i 4))
-		   (srcidx srcstart (index+ srcidx 4))
-		   (destidx deststart (index+ destidx 4)))
-		  ((index-zerop i))
-		(declare (type array-index i srcidx destidx))
-		(setf (aref dest destidx)
-		      (br (aref src (index+ srcidx 3))))
-		(setf (aref dest (index1+ destidx))
-		      (br (aref src (index+ srcidx 2))))
-		(setf (aref dest (index+ destidx 2))
-		      (br (aref src (index1+ srcidx))))
-		(setf (aref dest (index+ destidx 3))
-		      (br (aref src srcidx)))))))))))
-
-(defun image-swap-bits-and-words
-       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
-  (declare (type buffer-bytes src dest)
-	   (type array-index srcoff destoff srclen srcinc destinc)
-	   (type card16 height)
-	   (type boolean lsb-first-p))
-  #.(declare-buffun)
-  (with-vector (src buffer-bytes)
-    (with-vector (dest buffer-bytes)
-      (let ((byte-reverse *image-byte-reverse*))
-	(with-vector (byte-reverse (simple-array card8 (256)))
-	  (macrolet ((br (byte)
-		       `(the card8 (aref byte-reverse (the card8 ,byte)))))
-	    (do ((length (index* (index-ceiling srclen 4) 4))
-		 (h height (index1- h))
-		 (srcstart srcoff (index+ srcstart srcinc))
-		 (deststart destoff (index+ deststart destinc)))
-		((index-zerop h))
-	      (declare (type array-index length srcstart deststart)
-		       (type card16 h))
-	      (when (and (index= h 1) (not (index= srclen length)))
-		(index-decf length 4)
-		(unless lsb-first-p
-		  (setf (aref dest (index+ deststart length 1))
-			(br (aref src (index+ srcstart length 3)))))
-		(when (if lsb-first-p
-			  (index= (index- srclen length) 3)
-			(not (index-zerop (index-logand srclen 2))))
-		  (setf (aref dest (index+ deststart length))
-			(br (aref src (index+ srcstart length 2)))))
-		(when (if (null lsb-first-p)
-			  (index= (index- srclen length) 3)
-			(not (index-zerop (index-logand srclen 2))))
-		  (setf (aref dest (index+ deststart length 3))
-			(br (aref src (index+ srcstart length 1)))))
-		(when lsb-first-p
-		  (setf (aref dest (index+ deststart length 2))
-			(br (aref src (index+ srcstart length))))))
-	      (do ((i length (index- i 4))
-		   (srcidx srcstart (index+ srcidx 4))
-		   (destidx deststart (index+ destidx 4)))
-		  ((index-zerop i))
-		(declare (type array-index i srcidx destidx))
-		(setf (aref dest destidx)
-		      (br (aref src (index+ srcidx 2))))
-		(setf (aref dest (index1+ destidx))
-		      (br (aref src (index+ srcidx 3))))
-		(setf (aref dest (index+ destidx 2))
-		      (br (aref src srcidx)))
-		(setf (aref dest (index+ destidx 3))
-		      (br (aref src (index1+ srcidx))))))))))))
-
-;;; The following table gives the bit ordering within bytes (when accessed
-;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to
-;;; 31, where bit 0 should be leftmost on the display.  For a given byte
-;;; labelled A-B, A is for the most significant bit of the byte, and B is
-;;; for the least significant bit.
-;;; 
-;;; legend:
-;;; 	1   scanline-unit = 8
-;;; 	2   scanline-unit = 16
-;;; 	4   scanline-unit = 32
-;;; 	M   byte-order = MostSignificant
-;;; 	L   byte-order = LeastSignificant
-;;; 	m   bit-order = MostSignificant
-;;; 	l   bit-order = LeastSignificant
-;;; 
-;;; 
-;;; format	ordering
-;;; 
-;;; 1Mm	00-07 08-15 16-23 24-31
-;;; 2Mm	00-07 08-15 16-23 24-31
-;;; 4Mm	00-07 08-15 16-23 24-31
-;;; 1Ml	07-00 15-08 23-16 31-24
-;;; 2Ml	15-08 07-00 31-24 23-16
-;;; 4Ml	31-24 23-16 15-08 07-00
-;;; 1Lm	00-07 08-15 16-23 24-31
-;;; 2Lm	08-15 00-07 24-31 16-23
-;;; 4Lm	24-31 16-23 08-15 00-07
-;;; 1Ll	07-00 15-08 23-16 31-24
-;;; 2Ll	07-00 15-08 23-16 31-24
-;;; 4Ll	07-00 15-08 23-16 31-24
-;;; 
-;;; 
-;;; The following table gives the required conversion between any two
-;;; formats.  It is based strictly on the table above.  If you believe one,
-;;; you should believe the other.
-;;; 
-;;; legend:
-;;; 	n   no changes
-;;; 	s   reverse 8-bit units within 16-bit units
-;;; 	l   reverse 8-bit units within 32-bit units
-;;; 	w   reverse 16-bit units within 32-bit units
-;;; 	r   reverse bits within 8-bit units
-;;; 	sr  s+R
-;;; 	lr  l+R
-;;; 	wr  w+R
-
-(defconstant 
-  *image-swap-function*
-  '#.(make-array
-       '(12 12) :initial-contents
-       (let ((n  'image-noswap)
-	     (s  'image-swap-two-bytes)
-	     (l  'image-swap-four-bytes)
-	     (w  'image-swap-words)
-	     (r  'image-swap-bits)
-	     (sr 'image-swap-bits-and-two-bytes)
-	     (lr 'image-swap-bits-and-four-bytes)
-	     (wr 'image-swap-bits-and-words))
-	 (list #|             1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll  |#
-	       (list #| 1Mm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
-	       (list #| 2Mm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
-	       (list #| 4Mm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
-	       (list #| 1Ml |# r   r   r   n   s   l   r   sr  lr  n   n   n )
-	       (list #| 2Ml |# sr  sr  sr  s   n   w   sr  r   wr  s   s   s )
-	       (list #| 4Ml |# lr  lr  lr  l   w   n   lr  wr  r   l   l   l )
-	       (list #| 1Lm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
-	       (list #| 2Lm |# s   s   s   sr  r   wr  s   n   w   sr  sr  sr)
-	       (list #| 4Lm |# l   l   l   lr  wr  r   l   w   n   lr  lr  lr)
-	       (list #| 1Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n )
-	       (list #| 2Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n )
-	       (list #| 4Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n )))))
-
-;;; Of course, the table above is a lie.  We also need to factor in the
-;;; order of the source data to cope with swapping half of a unit at the
-;;; end of a scanline, since we are trying to avoid de-ref'ing off the
-;;; end of the source.
-;;;
-;;; Defines whether the first half of a unit has the first half of the data
-
-(defconstant
-  *image-swap-lsb-first-p*
-  '#.(make-array
-       12 :initial-contents
-       (list t   #| 1mm |#
-	     t   #| 2mm |#
-	     t   #| 4mm |#
-	     t   #| 1ml |#
-	     nil #| 2ml |#
-	     nil #| 4ml |#
-	     t   #| 1lm |#
-	     nil #| 2lm |#
-	     nil #| 4lm |#
-	     t   #| 1ll |#
-	     t   #| 2ll |#
-	     t   #| 4ll |#
-	     )))
-
-(defun image-swap-function
-       (bits-per-pixel
-	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
-	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
-  (declare (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
-	   (type boolean from-byte-lsb-first-p from-bit-lsb-first-p
-		 to-byte-lsb-first-p to-bit-lsb-first-p)
-	   (clx-values function lsb-first-p))
-  (cond ((index= bits-per-pixel 1)
-	 (let ((from-index
-		 (index+
-		   (ecase from-bitmap-unit (32 2) (16 1) (8 0))
-		   (if from-bit-lsb-first-p 3 0)
-		   (if from-byte-lsb-first-p 6 0))))
-	   (values
-	     (aref *image-swap-function* from-index
-		   (index+
-		     (ecase to-bitmap-unit (32 2) (16 1) (8 0))
-		     (if to-bit-lsb-first-p 3 0)
-		     (if to-byte-lsb-first-p 6 0)))
-	     (aref *image-swap-lsb-first-p* from-index))))
-	(t
-	 (values 
-	   (if (if (index= bits-per-pixel 4)
-		   (eq from-bit-lsb-first-p to-bit-lsb-first-p)
-		 (eq from-byte-lsb-first-p to-byte-lsb-first-p))
-	       'image-noswap
-	     (ecase bits-per-pixel
-	       (4  'image-swap-nibbles)
-	       (8  'image-noswap)
-	       (16 'image-swap-two-bytes)
-	       (24 'image-swap-three-bytes)
-	       (32 'image-swap-four-bytes)))
-	   from-byte-lsb-first-p))))
-
-
-;;;-----------------------------------------------------------------------------
-;;; GET-IMAGE
-
-(defun read-pixarray-1 (buffer-bbuf index array x y width height  
-			padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-1 array)
-	   (type card16 x y width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (do* ((start (index+ index
-			 (index* y padded-bytes-per-line)
-			 (index-ceiling x 8))
-		 (index+ start padded-bytes-per-line))
-	  (y 0 (index1+ y))
-	  (left-bits (index-mod (index- x) 8))
-	  (right-bits (index-mod (index- width left-bits) 8))
-	  (middle-bits (index- width left-bits right-bits))
-	  (middle-bytes (index-floor middle-bits 8)))
-	 ((index>= y height))
-      (declare (type array-index start y
-		     left-bits right-bits middle-bits middle-bytes))
-      (cond ((index< middle-bits 0)
-	     (let ((byte (aref buffer-bbuf (index1- start)))
-		   (x left-bits))
-	       (declare (type card8 byte)
-			(type array-index x))
-	       (when (index> right-bits 6)
-		 (setf (aref array y (index- x 1))
-		       (read-image-load-byte 1 7 byte)))
-	       (when (and (index> left-bits 1)
-			  (index> right-bits 5))
-		 (setf (aref array y (index- x 2))
-		       (read-image-load-byte 1 6 byte)))
-	       (when (and (index> left-bits 2)
-			  (index> right-bits 4))
-		 (setf (aref array y (index- x 3))
-		       (read-image-load-byte 1 5 byte)))
-	       (when (and (index> left-bits 3)
-			  (index> right-bits 3))
-		 (setf (aref array y (index- x 4))
-		       (read-image-load-byte 1 4 byte)))
-	       (when (and (index> left-bits 4)
-			  (index> right-bits 2))
-		 (setf (aref array y (index- x 5))
-		       (read-image-load-byte 1 3 byte)))
-	       (when (and (index> left-bits 5)
-			  (index> right-bits 1))
-		 (setf (aref array y (index- x 6))
-		       (read-image-load-byte 1 2 byte)))
-	       (when (index> left-bits 6)
-		 (setf (aref array y (index- x 7))
-		       (read-image-load-byte 1 1 byte)))))
-	    (t
-	     (unless (index-zerop left-bits)
-	       (let ((byte (aref buffer-bbuf (index1- start)))
-		     (x left-bits))
-		 (declare (type card8 byte)
-			  (type array-index x))
-		 (setf (aref array y (index- x 1))
-		       (read-image-load-byte 1 7 byte))
-		 (when (index> left-bits 1)
-		   (setf (aref array y (index- x 2))
-			 (read-image-load-byte 1 6 byte))
-		   (when (index> left-bits 2)
-		     (setf (aref array y (index- x 3))
-			   (read-image-load-byte 1 5 byte))
-		     (when (index> left-bits 3)
-		       (setf (aref array y (index- x 4))
-			     (read-image-load-byte 1 4 byte))
-		       (when (index> left-bits 4)
-			 (setf (aref array y (index- x 5))
-			       (read-image-load-byte 1 3 byte))
-			 (when (index> left-bits 5)
-			   (setf (aref array y (index- x 6))
-				 (read-image-load-byte 1 2 byte))
-			   (when (index> left-bits 6)
-			     (setf (aref array y (index- x 7))
-				   (read-image-load-byte 1 1 byte))
-			     ))))))))
-	     (do* ((end (index+ start middle-bytes))
-		   (i start (index1+ i))
-		   (x left-bits (index+ x 8)))
-		  ((index>= i end)
-		   (unless (index-zerop right-bits)
-		     (let ((byte (aref buffer-bbuf end))
-			   (x (index+ left-bits middle-bits)))
-		       (declare (type card8 byte)
-				(type array-index x))
-		       (setf (aref array y (index+ x 0))
-			     (read-image-load-byte 1 0 byte))
-		       (when (index> right-bits 1)
-			 (setf (aref array y (index+ x 1))
-			       (read-image-load-byte 1 1 byte))
-			 (when (index> right-bits 2)
-			   (setf (aref array y (index+ x 2))
-				 (read-image-load-byte 1 2 byte))
-			   (when (index> right-bits 3)
-			     (setf (aref array y (index+ x 3))
-				   (read-image-load-byte 1 3 byte))
-			     (when (index> right-bits 4)
-			       (setf (aref array y (index+ x 4))
-				     (read-image-load-byte 1 4 byte))
-			       (when (index> right-bits 5)
-				 (setf (aref array y (index+ x 5))
-				       (read-image-load-byte 1 5 byte))
-				 (when (index> right-bits 6)
-				   (setf (aref array y (index+ x 6))
-					 (read-image-load-byte 1 6 byte))
-				   )))))))))
-	       (declare (type array-index end i x))
-	       (let ((byte (aref buffer-bbuf i)))
-		 (declare (type card8 byte))
-		 (setf (aref array y (index+ x 0))
-		       (read-image-load-byte 1 0 byte))
-		 (setf (aref array y (index+ x 1))
-		       (read-image-load-byte 1 1 byte))
-		 (setf (aref array y (index+ x 2))
-		       (read-image-load-byte 1 2 byte))
-		 (setf (aref array y (index+ x 3))
-		       (read-image-load-byte 1 3 byte))
-		 (setf (aref array y (index+ x 4))
-		       (read-image-load-byte 1 4 byte))
-		 (setf (aref array y (index+ x 5))
-		       (read-image-load-byte 1 5 byte))
-		 (setf (aref array y (index+ x 6))
-		       (read-image-load-byte 1 6 byte))
-		 (setf (aref array y (index+ x 7))
-		       (read-image-load-byte 1 7 byte))))
-	     )))))
-
-(defun read-pixarray-4 (buffer-bbuf index array x y width height 
-			padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-4 array)
-	   (type card16 x y width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (do* ((start (index+ index
-			 (index* y padded-bytes-per-line)
-			 (index-ceiling x 2))
-		 (index+ start padded-bytes-per-line))
-	  (y 0 (index1+ y))
-	  (left-nibbles (index-mod (index- x) 2))
-	  (right-nibbles (index-mod (index- width left-nibbles) 2))
-	  (middle-nibbles (index- width left-nibbles right-nibbles))
-	  (middle-bytes (index-floor middle-nibbles 2)))
-	 ((index>= y height))
-      (declare (type array-index start y
-		     left-nibbles right-nibbles middle-nibbles middle-bytes))
-      (unless (index-zerop left-nibbles)
-	(setf (aref array y 0)
-	      (read-image-load-byte
-		4 4 (aref buffer-bbuf (index1- start)))))
-      (do* ((end (index+ start middle-bytes))
-	    (i start (index1+ i))
-	    (x left-nibbles (index+ x 2)))
-	   ((index>= i end)
-	    (unless (index-zerop right-nibbles)
-	      (setf (aref array y (index+ left-nibbles middle-nibbles))
-		    (read-image-load-byte 4 0 (aref buffer-bbuf end)))))
-	(declare (type array-index end i x))
-	(let ((byte (aref buffer-bbuf i)))
-	  (declare (type card8 byte))
-	  (setf (aref array y (index+ x 0))
-		(read-image-load-byte 4 0 byte))
-	  (setf (aref array y (index+ x 1))
-		(read-image-load-byte 4 4 byte))))
-      )))
-
-(defun read-pixarray-8 (buffer-bbuf index array x y width height 
-			padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-8 array)
-	   (type card16 x y width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (do* ((start (index+ index
-			 (index* y padded-bytes-per-line)
-			 x)
-		 (index+ start padded-bytes-per-line))
-	  (y 0 (index1+ y)))
-	 ((index>= y height))
-      (declare (type array-index start y))
-      (do* ((end (index+ start width))
-	    (i start (index1+ i))
-	    (x 0 (index1+ x)))
-	   ((index>= i end))
-	(declare (type array-index end i x))
-	(setf (aref array y x)
-	      (the card8 (aref buffer-bbuf i)))))))
-
-(defun read-pixarray-16 (buffer-bbuf index array x y width height 
-			 padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-16 array)
-	   (type card16 width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (do* ((start (index+ index
-			 (index* y padded-bytes-per-line)
-			 (index* x 2))
-		 (index+ start padded-bytes-per-line))
-	  (y 0 (index1+ y)))
-	 ((index>= y height))
-      (declare (type array-index start y))
-      (do* ((end (index+ start (index* width 2)))
-	    (i start (index+ i 2))
-	    (x 0 (index1+ x)))
-	   ((index>= i end))
-	(declare (type array-index end i x))
-	(setf (aref array y x)
-	      (read-image-assemble-bytes
-		(aref buffer-bbuf (index+ i 0))
-		(aref buffer-bbuf (index+ i 1))))))))
-
-(defun read-pixarray-24 (buffer-bbuf index array x y width height 
-			 padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-24 array)
-	   (type card16 width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (do* ((start (index+ index
-			 (index* y padded-bytes-per-line)
-			 (index* x 3))
-		 (index+ start padded-bytes-per-line))
-	  (y 0 (index1+ y)))
-	 ((index>= y height))
-      (declare (type array-index start y))
-      (do* ((end (index+ start (index* width 3)))
-	    (i start (index+ i 3))
-	    (x 0 (index1+ x)))
-	   ((index>= i end))
-	(declare (type array-index end i x))
-	(setf (aref array y x)
-	      (read-image-assemble-bytes
-		(aref buffer-bbuf (index+ i 0))
-		(aref buffer-bbuf (index+ i 1))
-		(aref buffer-bbuf (index+ i 2))))))))
-
-(defun read-pixarray-32 (buffer-bbuf index array x y width height 
-			 padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-32 array)
-	   (type card16 width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (do* ((start (index+ index
-			 (index* y padded-bytes-per-line)
-			 (index* x 4))
-		 (index+ start padded-bytes-per-line))
-	  (y 0 (index1+ y)))
-	 ((index>= y height))
-      (declare (type array-index start y))
-      (do* ((end (index+ start (index* width 4)))
-	    (i start (index+ i 4))
-	    (x 0 (index1+ x)))
-	   ((index>= i end))
-	(declare (type array-index end i x))
-	(setf (aref array y x)
-	      (read-image-assemble-bytes
-		(aref buffer-bbuf (index+ i 0))
-		(aref buffer-bbuf (index+ i 1))
-		(aref buffer-bbuf (index+ i 2))
-		(aref buffer-bbuf (index+ i 3))))))))
-
-(defun read-pixarray-internal
-       (bbuf boffset pixarray x y width height padded-bytes-per-line
-	bits-per-pixel read-pixarray-function
-	from-unit from-byte-lsb-first-p from-bit-lsb-first-p
-	to-unit to-byte-lsb-first-p to-bit-lsb-first-p)
-  (declare (type buffer-bytes bbuf)
-	   (type array-index boffset padded-bytes-per-line)
-	   (type pixarray pixarray)
-	   (type card16 x y width height)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (type function read-pixarray-function)
-	   (type (member 8 16 32) from-unit to-unit)
-	   (type boolean from-byte-lsb-first-p from-bit-lsb-first-p
-		 to-byte-lsb-first-p to-bit-lsb-first-p))
-  (multiple-value-bind (image-swap-function image-swap-lsb-first-p)
-      (image-swap-function
-	bits-per-pixel
-	from-unit from-byte-lsb-first-p from-bit-lsb-first-p
-	to-unit to-byte-lsb-first-p to-bit-lsb-first-p)
-    (if (eq image-swap-function 'image-noswap)
-	(funcall
-	  read-pixarray-function
-	  bbuf boffset pixarray x y width height padded-bytes-per-line
-	  bits-per-pixel)
-      (with-image-data-buffer (buf (index* height padded-bytes-per-line))
-	(funcall
-	  (symbol-function image-swap-function) bbuf buf
-	  (index+ boffset (index* y padded-bytes-per-line)) 0
-	  (index-ceiling (index* (index+ x width) bits-per-pixel) 8)
-	  padded-bytes-per-line padded-bytes-per-line height
-	  image-swap-lsb-first-p)
-	(funcall
-	  read-pixarray-function 
-	  buf 0 pixarray x 0 width height padded-bytes-per-line
-	  bits-per-pixel)))))
-
-(defun read-pixarray
-       (bbuf boffset pixarray x y width height padded-bytes-per-line
-	bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
-  (declare (type buffer-bytes bbuf)
-	   (type array-index boffset padded-bytes-per-line)
-	   (type pixarray pixarray)
-	   (type card16 x y width height)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (type (member 8 16 32) unit)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p))
-  (unless (fast-read-pixarray
-	    bbuf boffset pixarray x y width height padded-bytes-per-line
-	    bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
-    (read-pixarray-internal
-      bbuf boffset pixarray x y width height padded-bytes-per-line
-      bits-per-pixel 
-      (ecase bits-per-pixel
-	( 1 #'read-pixarray-1 )
-	( 4 #'read-pixarray-4 )
-	( 8 #'read-pixarray-8 )
-	(16 #'read-pixarray-16)
-	(24 #'read-pixarray-24)
-	(32 #'read-pixarray-32))
-      unit byte-lsb-first-p bit-lsb-first-p
-      *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)))
-
-(defun read-xy-format-image-x
-       (buffer-bbuf index length data width height depth
-	padded-bytes-per-line padded-bytes-per-plane
-	unit byte-lsb-first-p bit-lsb-first-p pad)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type card16 width height)
-	   (type array-index index length padded-bytes-per-line
-		 padded-bytes-per-plane)
-	   (type image-depth depth)
-	   (type (member 8 16 32) unit pad)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p)
-	   (clx-values image-x))
-  (assert (index<= (index* depth padded-bytes-per-plane) length))
-  (let* ((bytes-per-line (index-ceiling width 8))
-	 (data-length (index* padded-bytes-per-plane depth)))
-    (declare (type array-index bytes-per-line data-length))
-    (cond (data
-	   (check-type data buffer-bytes)
-	   (assert (index>= (length data) data-length)))
-	  (t
-	   (setq data (make-array data-length :element-type 'card8))))
-    (do ((plane 0 (index1+ plane)))
-	((index>= plane depth))
-      (declare (type image-depth plane))
-      (image-noswap
-	buffer-bbuf data
-	(index+ index (index* plane padded-bytes-per-plane))
-	(index* plane padded-bytes-per-plane)
-	bytes-per-line padded-bytes-per-line padded-bytes-per-line
-	height byte-lsb-first-p))
-    (create-image 
-      :width width :height height :depth depth :data data
-      :bits-per-pixel 1 :format :xy-pixmap
-      :bytes-per-line padded-bytes-per-line
-      :unit unit :pad pad
-      :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p)))
-
-(defun read-z-format-image-x
-       (buffer-bbuf index length data width height depth
-	padded-bytes-per-line 
-	unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type card16 width height)
-	   (type array-index index length padded-bytes-per-line)
-	   (type image-depth depth)
-	   (type (member 8 16 32) unit pad)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (clx-values image-x))
-  (assert (index<= (index* height padded-bytes-per-line) length))
-  (let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8))
-	(data-length (index* padded-bytes-per-line height)))
-    (declare (type array-index bytes-per-line data-length))
-    (cond (data
-	   (check-type data buffer-bytes)
-	   (assert (index>= (length data) data-length)))
-	  (t
-	   (setq data (make-array data-length :element-type 'card8))))
-    (image-noswap
-      buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line
-      padded-bytes-per-line height byte-lsb-first-p)
-    (create-image 
-      :width width :height height :depth depth :data data
-      :bits-per-pixel bits-per-pixel :format :z-pixmap
-      :bytes-per-line padded-bytes-per-line
-      :unit unit :pad pad
-      :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p)))
-
-(defun read-image-xy (bbuf index length data x y width height depth
-		      padded-bytes-per-line padded-bytes-per-plane
-		      unit byte-lsb-first-p bit-lsb-first-p)
-  (declare (type buffer-bytes bbuf)
-	   (type card16 x y width height)
-	   (type array-index index length padded-bytes-per-line
-		 padded-bytes-per-plane)
-	   (type image-depth depth)
-	   (type (member 8 16 32) unit)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p)
-	   (clx-values image-xy))
-  (check-type data list)
-  (multiple-value-bind (dimensions element-type)
-      (if data
-	  (values (array-dimensions (first data))
-		  (array-element-type (first data)))
-	(values (list height
-		      (index* (index-ceiling width *image-pad*) *image-pad*))
-		'pixarray-1-element-type))
-    (do* ((arrays data)
-	  (result nil)
-	  (limit (index+ length index))
-	  (plane 0 (1+ plane))
-	  (index index (index+ index padded-bytes-per-plane)))
-	 ((or (>= plane depth)
-	      (index> (index+ index padded-bytes-per-plane) limit))
-	  (setq data (nreverse result) depth (length data)))
-      (declare (type array-index limit index)
-	       (type image-depth plane)
-	       (type list arrays result))
-      (let ((array (or (pop arrays)
-		       (make-array dimensions :element-type element-type))))
-	(declare (type pixarray-1 array))
-	(push array result)
-	(read-pixarray
-	  bbuf index array x y width height padded-bytes-per-line 1
-	  unit byte-lsb-first-p bit-lsb-first-p)))
-    (create-image 
-      :width width :height height :depth depth :data data)))
-
-(defun read-image-z (bbuf index length data x y width height depth
-		     padded-bytes-per-line bits-per-pixel
-		     unit byte-lsb-first-p bit-lsb-first-p)
-  (declare (type buffer-bytes bbuf)
-	   (type card16 x y width height)
-	   (type array-index index length padded-bytes-per-line)
-	   (type image-depth depth)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (type (member 8 16 32) unit)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p)
-	   (clx-values image-z))
-  (assert (index<= (index* (index+ y height) padded-bytes-per-line) length))
-  (let* ((image-bits-per-line (index* width bits-per-pixel))
-	 (image-pixels-per-line
-	   (index-ceiling
-	     (index* (index-ceiling image-bits-per-line *image-pad*)
-		     *image-pad*)
-	     bits-per-pixel)))
-    (declare (type array-index image-bits-per-line image-pixels-per-line))
-    (unless data
-      (setq data
-	    (make-array
-	      (list height image-pixels-per-line)
-	      :element-type (ecase bits-per-pixel
-			      (1  'pixarray-1-element-type)
-			      (4  'pixarray-4-element-type)
-			      (8  'pixarray-8-element-type)
-			      (16 'pixarray-16-element-type)
-			      (24 'pixarray-24-element-type)
-			      (32 'pixarray-32-element-type)))))
-    (read-pixarray
-      bbuf index data x y width height padded-bytes-per-line bits-per-pixel
-      unit byte-lsb-first-p bit-lsb-first-p)
-    (create-image 
-      :width width :height height :depth depth :data data
-      :bits-per-pixel bits-per-pixel)))
-
-(defun get-image (drawable &key
-		  data
-		  (x (required-arg x))
-		  (y (required-arg y))
-		  (width (required-arg width))
-		  (height (required-arg height))
-		  plane-mask format result-type)
-  (declare (type drawable drawable)
-	   (type (or buffer-bytes list pixarray) data)
-	   (type int16 x y) ;; required
-	   (type card16 width height) ;; required
-	   (type (or null pixel) plane-mask)
-	   (type (or null (member :xy-pixmap :z-pixmap)) format)
-	   (type (or null (member image-xy image-x image-z)) result-type)
-	   (clx-values image visual-info))
-  (unless result-type
-    (setq result-type (ecase format
-			(:xy-pixmap 'image-xy)
-			(:z-pixmap 'image-z)
-			((nil) 'image-x))))
-  (unless format
-    (setq format (case result-type
-		   (image-xy :xy-pixmap)
-		   ((image-z image-x) :z-pixmap))))
-  (unless (ecase result-type
-	    (image-xy (eq format :xy-pixmap))
-	    (image-z (eq format :z-pixmap))
-	    (image-x t))
-    (error "Result-type ~s is incompatable with format ~s"
-	   result-type format))
-  (unless plane-mask (setq plane-mask #xffffffff))
-  (let ((display (drawable-display drawable)))
-    (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32))
-	 (((data (member error :xy-pixmap :z-pixmap)) format)
-	  (drawable drawable)
-	  (int16 x y)
-	  (card16 width height)
-	  (card32 plane-mask))
-      (let* ((depth (card8-get 1))
-	     (length (index* 4 (card32-get 4)))
-	     (visual-info (visual-info display (resource-id-get 8)))
-	     (bitmap-format (display-bitmap-format display))
-	     (unit (bitmap-format-unit bitmap-format))
-	     (byte-lsb-first-p (display-image-lsb-first-p display))
-	     (bit-lsb-first-p  (bitmap-format-lsb-first-p bitmap-format)))
-	(declare (type image-depth depth)
-		 (type array-index length)
-		 (type (or null visual-info) visual-info)
-		 (type bitmap-format bitmap-format)
-		 (type (member 8 16 32) unit)
-		 (type boolean byte-lsb-first-p bit-lsb-first-p))
-	(multiple-value-bind (pad bits-per-pixel)
-	    (ecase format
-	      (:xy-pixmap
-		(values (bitmap-format-pad bitmap-format) 1))
-	      (:z-pixmap
-		(if (= depth 1)
-		    (values (bitmap-format-pad bitmap-format) 1)
-		  (let ((pixmap-format
-			  (find depth (display-pixmap-formats display)
-				:key #'pixmap-format-depth)))
-		    (declare (type pixmap-format pixmap-format))
-		    (values (pixmap-format-scanline-pad pixmap-format)
-			    (pixmap-format-bits-per-pixel pixmap-format))))))
-	  (declare (type (member 8 16 32) pad)
-		   (type (member 1 4 8 16 24 32) bits-per-pixel))
-	  (let* ((bits-per-line (index* bits-per-pixel width))
-		 (padded-bits-per-line
-		   (index* (index-ceiling bits-per-line pad) pad))
-		 (padded-bytes-per-line
-		   (index-ceiling padded-bits-per-line 8))
-		 (padded-bytes-per-plane
-		   (index* padded-bytes-per-line height))
-		 (image
-		   (ecase result-type
-		     (image-x
-		       (ecase format
-			 (:xy-pixmap
-			   (read-xy-format-image-x
-			     buffer-bbuf *replysize* length data
-			     width height depth
-			     padded-bytes-per-line padded-bytes-per-plane
-			     unit byte-lsb-first-p bit-lsb-first-p
-			     pad))
-			 (:z-pixmap
-			   (read-z-format-image-x
-			     buffer-bbuf *replysize* length data
-			     width height depth
-			     padded-bytes-per-line
-			     unit byte-lsb-first-p bit-lsb-first-p
-			     pad bits-per-pixel))))
-		     (image-xy
-		       (read-image-xy
-			 buffer-bbuf *replysize* length data
-			 0 0 width height depth
-			 padded-bytes-per-line padded-bytes-per-plane
-			 unit byte-lsb-first-p bit-lsb-first-p))
-		     (image-z
-		       (read-image-z
-			 buffer-bbuf *replysize* length data
-			 0 0 width height depth padded-bytes-per-line
-			 bits-per-pixel 
-			 unit byte-lsb-first-p bit-lsb-first-p)))))
-	    (declare (type image image)
-		     (type array-index bits-per-line 
-			   padded-bits-per-line padded-bytes-per-line))
-	    (when visual-info
-	      (unless (zerop (visual-info-red-mask visual-info))
-		(setf (image-red-mask image)
-		      (visual-info-red-mask visual-info)))
-	      (unless (zerop (visual-info-green-mask visual-info))
-		(setf (image-green-mask image)
-		      (visual-info-green-mask visual-info)))
-	      (unless (zerop (visual-info-blue-mask visual-info))
-		(setf (image-blue-mask image)
-		      (visual-info-blue-mask visual-info))))
-	    (values image visual-info)))))))
-
-
-;;;-----------------------------------------------------------------------------
-;;; PUT-IMAGE
-
-(defun write-pixarray-1 (buffer-bbuf index array x y width height
-			 padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-1 array)
-	   (type card16 x y width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (do* ((h 0 (index1+ h))
-	  (y y (index1+ y))
-	  (right-bits (index-mod width 8))
-	  (middle-bits (index- width right-bits))
-	  (middle-bytes (index-ceiling middle-bits 8))
-	  (start index (index+ start padded-bytes-per-line)))
-	 ((index>= h height))
-      (declare (type array-index h y right-bits middle-bits
-		     middle-bytes start))
-      (do* ((end (index+ start middle-bytes))
-	    (i start (index1+ i))
-	    (start-x x)
-	    (x start-x (index+ x 8)))
-	   ((index>= i end)
-	    (unless (index-zerop right-bits)
-	      (let ((x (index+ start-x middle-bits)))
-		(declare (type array-index x))
-		(setf (aref buffer-bbuf end)
-		      (write-image-assemble-bytes
-			(aref array y (index+ x 0))
-			(if (index> right-bits 1)
-			    (aref array y (index+ x 1))
-			  0)
-			(if (index> right-bits 2)
-			    (aref array y (index+ x 2))
-			  0)
-			(if (index> right-bits 3)
-			    (aref array y (index+ x 3))
-			  0)
-			(if (index> right-bits 4)
-			    (aref array y (index+ x 4))
-			  0)
-			(if (index> right-bits 5)
-			    (aref array y (index+ x 5))
-			  0)
-			(if (index> right-bits 6)
-			    (aref array y (index+ x 6))
-			  0)
-			0)))))
-	(declare (type array-index end i start-x x))
-	(setf (aref buffer-bbuf i)
-	      (write-image-assemble-bytes
-		(aref array y (index+ x 0))
-		(aref array y (index+ x 1))
-		(aref array y (index+ x 2))
-		(aref array y (index+ x 3))
-		(aref array y (index+ x 4))
-		(aref array y (index+ x 5))
-		(aref array y (index+ x 6))
-		(aref array y (index+ x 7))))))))
-
-(defun write-pixarray-4 (buffer-bbuf index array x y width height
-			 padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-4 array)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (do* ((h 0 (index1+ h))
-	  (y y (index1+ y))
-	  (right-nibbles (index-mod width 2))
-	  (middle-nibbles (index- width right-nibbles))
-	  (middle-bytes (index-ceiling middle-nibbles 2))
-	  (start index (index+ start padded-bytes-per-line)))
-	 ((index>= h height))
-      (declare (type array-index h y right-nibbles middle-nibbles
-		     middle-bytes start))
-      (do* ((end (index+ start middle-bytes))
-	    (i start (index1+ i))
-	    (start-x x)
-	    (x start-x (index+ x 2)))
-	   ((index>= i end)
-	    (unless (index-zerop right-nibbles)
-	      (setf (aref buffer-bbuf end)
-		    (write-image-assemble-bytes
-		      (aref array y (index+ start-x middle-nibbles))
-		      0))))
-	(declare (type array-index end i start-x x))
-	(setf (aref buffer-bbuf i)
-	      (write-image-assemble-bytes
-		(aref array y (index+ x 0))
-		(aref array y (index+ x 1))))))))
-
-(defun write-pixarray-8 (buffer-bbuf index array x y width height
-			 padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-8 array)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (do* ((h 0 (index1+ h))
-	  (y y (index1+ y))
-	  (start index (index+ start padded-bytes-per-line)))
-	 ((index>= h height))
-      (declare (type array-index h y start))
-      (do* ((end (index+ start width))
-	    (i start (index1+ i))
-	    (x x (index1+ x)))
-	   ((index>= i end))
-	(declare (type array-index end i x))
-	(setf (aref buffer-bbuf i) (the card8 (aref array y x)))))))
-
-(defun write-pixarray-16 (buffer-bbuf index array x y width height
-			  padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-16 array)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (do* ((h 0 (index1+ h))
-	  (y y (index1+ y))
-	  (start index (index+ start padded-bytes-per-line)))
-	 ((index>= h height))
-      (declare (type array-index h y start))
-      (do* ((end (index+ start (index* width 2)))
-	    (i start (index+ i 2))
-	    (x x (index1+ x)))
-	   ((index>= i end))
-	(declare (type array-index end i x))
-	(let ((pixel (aref array y x)))
-	  (declare (type pixarray-16-element-type pixel))
-	  (setf (aref buffer-bbuf (index+ i 0))
-		(write-image-load-byte 0 pixel 16))
-	  (setf (aref buffer-bbuf (index+ i 1))
-		(write-image-load-byte 8 pixel 16)))))))
-
-(defun write-pixarray-24 (buffer-bbuf index array x y width height
-			  padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-24 array)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (do* ((h 0 (index1+ h))
-	  (y y (index1+ y))
-	  (start index (index+ start padded-bytes-per-line)))
-	 ((index>= h height))
-      (declare (type array-index y start))
-      (do* ((end (index+ start (index* width 3)))
-	    (i start (index+ i 3))
-	    (x x (index1+ x)))
-	   ((index>= i end))
-	(declare (type array-index end i x))
-	(let ((pixel (aref array y x)))
-	  (declare (type pixarray-24-element-type pixel))
-	  (setf (aref buffer-bbuf (index+ i 0))
-		(write-image-load-byte 0 pixel 24))
-	  (setf (aref buffer-bbuf (index+ i 1))
-		(write-image-load-byte 8 pixel 24))
-	  (setf (aref buffer-bbuf (index+ i 2))
-		(write-image-load-byte 16 pixel 24)))))))
-
-(defun write-pixarray-32 (buffer-bbuf index array x y width height
-			  padded-bytes-per-line bits-per-pixel)
-  (declare (type buffer-bytes buffer-bbuf)
-	   (type pixarray-32 array)
-	   (type int16 x y)
-	   (type card16 width height)
-	   (type array-index index padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (ignore bits-per-pixel))
-  #.(declare-buffun)
-  (with-vector (buffer-bbuf buffer-bytes)
-    (do* ((h 0 (index1+ h))
-	  (y y (index1+ y))
-	  (start index (index+ start padded-bytes-per-line)))
-	 ((index>= h height))
-      (declare (type array-index h y start))
-      (do* ((end (index+ start (index* width 4)))
-	    (i start (index+ i 4))
-	    (x x (index1+ x)))
-	   ((index>= i end))
-	(declare (type array-index end i x))
-	(let ((pixel (aref array y x)))
-	  (declare (type pixarray-32-element-type pixel))
-	  (setf (aref buffer-bbuf (index+ i 0))
-		(write-image-load-byte 0 pixel 32))
-	  (setf (aref buffer-bbuf (index+ i 1))
-		(write-image-load-byte 8 pixel 32))
-	  (setf (aref buffer-bbuf (index+ i 2))
-		(write-image-load-byte 16 pixel 32))
-	  (setf (aref buffer-bbuf (index+ i 3))
-		(write-image-load-byte 24 pixel 32)))))))
-
-(defun write-pixarray-internal
-       (bbuf boffset pixarray x y width height padded-bytes-per-line
-	bits-per-pixel write-pixarray-function
-	from-unit from-byte-lsb-first-p from-bit-lsb-first-p
-	to-unit to-byte-lsb-first-p to-bit-lsb-first-p)
-  (declare (type buffer-bytes bbuf)
-	   (type pixarray pixarray)
-	   (type card16 x y width height)
-	   (type array-index boffset padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (type function write-pixarray-function)
-	   (type (member 8 16 32) from-unit to-unit)
-	   (type boolean from-byte-lsb-first-p from-bit-lsb-first-p
-		 to-byte-lsb-first-p to-bit-lsb-first-p))
-  (multiple-value-bind (image-swap-function image-swap-lsb-first-p)
-      (image-swap-function
-	bits-per-pixel
-	from-unit from-byte-lsb-first-p from-bit-lsb-first-p
-	to-unit to-byte-lsb-first-p to-bit-lsb-first-p)
-    (declare (type symbol image-swap-function)
-	     (type boolean image-swap-lsb-first-p))
-    (if (eq image-swap-function 'image-noswap)
-	(funcall
-	  write-pixarray-function
-	  bbuf boffset pixarray x y width height padded-bytes-per-line
-	  bits-per-pixel)
-      (with-image-data-buffer (buf (index* height padded-bytes-per-line))
-	(funcall
-	  write-pixarray-function 
-	  buf 0 pixarray x y width height padded-bytes-per-line
-	  bits-per-pixel)
-	(funcall
-	  (symbol-function image-swap-function) buf bbuf 0 boffset
-	  (index-ceiling (index* width bits-per-pixel) 8)
-	  padded-bytes-per-line padded-bytes-per-line height
-	  image-swap-lsb-first-p)))))
-
-(defun write-pixarray
-       (bbuf boffset pixarray x y width height padded-bytes-per-line
-	bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
-  (declare (type buffer-bytes bbuf)
-	   (type pixarray pixarray)
-	   (type card16 x y width height)
-	   (type array-index boffset padded-bytes-per-line)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (type (member 8 16 32) unit)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p))
-  (unless (fast-write-pixarray
-	    bbuf boffset pixarray x y width height padded-bytes-per-line
-	    bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
-    (write-pixarray-internal
-      bbuf boffset pixarray x y width height padded-bytes-per-line
-      bits-per-pixel
-      (ecase bits-per-pixel
-	( 1 #'write-pixarray-1 )
-	( 4 #'write-pixarray-4 )
-	( 8 #'write-pixarray-8 )
-	(16 #'write-pixarray-16)
-	(24 #'write-pixarray-24)
-	(32 #'write-pixarray-32))
-      *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*
-      unit byte-lsb-first-p bit-lsb-first-p)))
-
-(defun write-xy-format-image-x-data
-       (data obuf data-start obuf-start x y width height
-	from-padded-bytes-per-line to-padded-bytes-per-line
-	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
-	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
-  (declare (type buffer-bytes data obuf)
-	   (type array-index data-start obuf-start
-		 from-padded-bytes-per-line to-padded-bytes-per-line)
-	   (type card16 x y width height)
-	   (type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
-	   (type boolean from-byte-lsb-first-p from-bit-lsb-first-p
-		 to-byte-lsb-first-p to-bit-lsb-first-p))
-  (assert (index-zerop (index-mod x 8)))
-  (multiple-value-bind (image-swap-function image-swap-lsb-first-p)
-      (image-swap-function
-	1
-	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
-	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
-    (declare (type symbol image-swap-function)
-	     (type boolean image-swap-lsb-first-p))
-    (let ((x-mod-unit (index-mod x from-bitmap-unit)))
-      (declare (type card16 x-mod-unit))
-      (if (and (index-plusp x-mod-unit)
-	       (not (eq from-byte-lsb-first-p from-bit-lsb-first-p)))
-	  (let* ((temp-width (index+ width x-mod-unit))
-		 (temp-bytes-per-line (index-ceiling temp-width 8))
-		 (temp-padded-bits-per-line
-		   (index* (index-ceiling temp-width from-bitmap-unit)
-			   from-bitmap-unit))
-		 (temp-padded-bytes-per-line
-		   (index-ceiling temp-padded-bits-per-line 8)))
-	    (declare (type card16 temp-width temp-bytes-per-line
-			   temp-padded-bits-per-line temp-padded-bytes-per-line))
-	    (with-image-data-buffer
-		 (buf (index* height temp-padded-bytes-per-line))
-	      (funcall
-		(symbol-function image-swap-function) data buf
-		(index+ data-start
-			(index* y from-padded-bytes-per-line)
-			(index-floor (index- x x-mod-unit) 8))
-		0 temp-bytes-per-line from-padded-bytes-per-line
-		temp-padded-bytes-per-line height image-swap-lsb-first-p)
-	      (write-xy-format-image-x-data
-		buf obuf 0 obuf-start x-mod-unit 0 width height
-		temp-padded-bytes-per-line to-padded-bytes-per-line
-		from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p
-		to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)))
-	(funcall
-	  (symbol-function image-swap-function) data obuf 
-	  (index+ data-start
-		  (index* y from-padded-bytes-per-line)
-		  (index-floor x 8))
-	  obuf-start (index-ceiling width 8) from-padded-bytes-per-line
-	  to-padded-bytes-per-line height image-swap-lsb-first-p)))))
-
-(defun write-xy-format-image-x
-       (display image src-x src-y width height
-	padded-bytes-per-line
-	unit byte-lsb-first-p bit-lsb-first-p)
-  (declare (type display display)
-	   (type image-x image)
-	   (type int16 src-x src-y)
-	   (type card16 width height)
-	   (type array-index padded-bytes-per-line)
-	   (type (member 8 16 32) unit)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p))
-  (dotimes (plane (image-depth image))
-    (let ((data-start
-	    (index* (index* plane (image-height image))
-		    (image-x-bytes-per-line image)))
-	  (src-y src-y)
-	  (height height))
-      (declare (type int16 src-y)
-	       (type card16 height))
-      (loop 
-	(when (index-zerop height) (return))
-	(let ((nlines
-		(index-min (index-floor (index- (buffer-size display)
-						(buffer-boffset display))
-					padded-bytes-per-line)
-			   height)))
-	  (declare (type array-index nlines))
-	  (when (index-plusp nlines)
-	    (write-xy-format-image-x-data
-	      (image-x-data image) (buffer-obuf8 display)
-	      data-start (buffer-boffset display)
-	      src-x src-y width nlines 
-	      (image-x-bytes-per-line image) padded-bytes-per-line
-	      (image-x-unit image) (image-x-byte-lsb-first-p image)
-	      (image-x-bit-lsb-first-p image)
-	      unit byte-lsb-first-p bit-lsb-first-p)
-	    (index-incf (buffer-boffset display)
-			(index* nlines padded-bytes-per-line))
-	    (index-incf src-y nlines)
-	    (when (index-zerop (index-decf height nlines)) (return))))
-	(buffer-flush display)))))
-
-(defun write-z-format-image-x-data
-       (data obuf data-start obuf-start x y width height
-	from-padded-bytes-per-line to-padded-bytes-per-line
-	bits-per-pixel
-	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
-	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
-  (declare (type buffer-bytes data obuf)
-	   (type array-index data-start obuf-start
-		 from-padded-bytes-per-line to-padded-bytes-per-line)
-	   (type card16 x y width height)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel)
-	   (type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
-	   (type boolean from-byte-lsb-first-p from-bit-lsb-first-p
-		 to-byte-lsb-first-p to-bit-lsb-first-p))
-  (if (index= bits-per-pixel 1)
-      (write-xy-format-image-x-data
-	data obuf data-start obuf-start x y width height
-	from-padded-bytes-per-line to-padded-bytes-per-line
-	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
-	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
-    (let ((srcoff
-	    (index+ data-start
-		    (index* y from-padded-bytes-per-line)
-		    (index-floor (index* x bits-per-pixel) 8)))
-	  (srclen (index-ceiling (index* width bits-per-pixel) 8)))
-      (declare (type array-index srcoff srclen))
-      (if (and (index= bits-per-pixel 4) (index-oddp x))
-	  (with-image-data-buffer (buf (index* height to-padded-bytes-per-line))
-	    (image-swap-nibbles-left
-	      data buf srcoff 0 srclen
-	      from-padded-bytes-per-line to-padded-bytes-per-line height nil)
-	    (write-z-format-image-x-data
-	      buf obuf 0 obuf-start 0 0 width height
-	      to-padded-bytes-per-line to-padded-bytes-per-line
-	      bits-per-pixel
-	      from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
-	      to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))
-	(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
-	    (image-swap-function
-	      bits-per-pixel
-	      from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
-	      to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
-	  (declare (type symbol image-swap-function)
-		   (type boolean image-swap-lsb-first-p))
-	  (funcall
-	    (symbol-function image-swap-function) data obuf srcoff obuf-start
-	    srclen from-padded-bytes-per-line to-padded-bytes-per-line height
-	    image-swap-lsb-first-p))))))
-
-(defun write-z-format-image-x (display image src-x src-y width height
-			       padded-bytes-per-line
-			       unit byte-lsb-first-p bit-lsb-first-p)
-  (declare (type display display)
-	   (type image-x image)
-	   (type int16 src-x src-y)
-	   (type card16 width height)
-	   (type array-index padded-bytes-per-line)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p))
-  (loop 
-    (when (index-zerop height) (return))
-    (let ((nlines
-	    (index-min (index-floor (index- (buffer-size display)
-					    (buffer-boffset display))
-				    padded-bytes-per-line)
-		       height)))
-      (declare (type array-index nlines))
-      (when (index-plusp nlines)
-	(write-z-format-image-x-data 
-	  (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display)
-	  src-x src-y width nlines
-	  (image-x-bytes-per-line image) padded-bytes-per-line
-	  (image-x-bits-per-pixel image)
-	  (image-x-unit image) (image-x-byte-lsb-first-p image)
-	  (image-x-bit-lsb-first-p image)
-	  unit byte-lsb-first-p bit-lsb-first-p)
-	(index-incf (buffer-boffset display)
-		    (index* nlines padded-bytes-per-line))
-	(index-incf src-y nlines)
-	(when (index-zerop (index-decf height nlines)) (return))))
-    (buffer-flush display)))
-
-(defun write-image-xy (display image src-x src-y width height
-		       padded-bytes-per-line
-		       unit byte-lsb-first-p bit-lsb-first-p)
-  (declare (type display display)
-	   (type image-xy image)
-	   (type array-index padded-bytes-per-line)
-	   (type int16 src-x src-y)
-	   (type card16 width height)
-	   (type (member 8 16 32) unit)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p))
-  (dolist (bitmap (image-xy-bitmap-list image))
-    (declare (type pixarray-1 bitmap))
-    (let ((src-y src-y)
-	  (height height))
-      (declare (type int16 src-y)
-	       (type card16 height))
-      (loop 
-	(let ((nlines
-		(index-min (index-floor (index- (buffer-size display)
-						(buffer-boffset display))
-					padded-bytes-per-line)
-			   height)))
-	  (declare (type array-index nlines))
-	  (when (index-plusp nlines)
-	    (write-pixarray 
-	      (buffer-obuf8 display) (buffer-boffset display)
-	      bitmap src-x src-y width nlines
-	      padded-bytes-per-line 1
-	      unit byte-lsb-first-p bit-lsb-first-p)
-	    (index-incf (buffer-boffset display)
-			(index* nlines padded-bytes-per-line))
-	    (index-incf src-y nlines)
-	    (when (index-zerop (index-decf height nlines)) (return))))
-	(buffer-flush display)))))
-
-(defun write-image-z (display image src-x src-y width height
-		      padded-bytes-per-line
-		      unit byte-lsb-first-p bit-lsb-first-p)
-  (declare (type display display)
-	   (type image-z image)
-	   (type array-index padded-bytes-per-line)
-	   (type int16 src-x src-y)
-	   (type card16 width height)
-	   (type (member 8 16 32) unit)
-	   (type boolean byte-lsb-first-p bit-lsb-first-p))
-  (loop 
-    (let ((bits-per-pixel (image-z-bits-per-pixel image))
-	  (nlines
-	    (index-min (index-floor (index- (buffer-size display)
-					    (buffer-boffset display))
-				    padded-bytes-per-line)
-		       height)))
-      (declare (type (member 1 4 8 16 24 32) bits-per-pixel)
-	       (type array-index nlines))
-      (when (index-plusp nlines)
-	(write-pixarray
-	  (buffer-obuf8 display) (buffer-boffset display)
-	  (image-z-pixarray image) src-x src-y width nlines
-	  padded-bytes-per-line bits-per-pixel
-	  unit byte-lsb-first-p bit-lsb-first-p)
-	(index-incf (buffer-boffset display)
-		    (index* nlines padded-bytes-per-line))
-	(index-incf src-y nlines)
-	(when (index-zerop (index-decf height nlines)) (return))))
-    (buffer-flush display)))
-
-;;; Note:	The only difference between a format of :bitmap and :xy-pixmap
-;;;		of depth 1 is that when sending a :bitmap format the foreground 
-;;;		and background in the gcontext are used.
-
-(defun put-image (drawable gcontext image &key
-		  (src-x 0) (src-y 0)		;Position within image
-		  (x (required-arg x))		;Position within drawable
-		  (y (required-arg y))
-		  width height
-		  bitmap-p)
-  ;; Copy an image into a drawable.
-  ;; WIDTH and HEIGHT default from IMAGE.
-  ;; When BITMAP-P, force format to be :bitmap when depth=1.
-  ;; This causes gcontext to supply foreground & background pixels.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type image image)
-	   (type int16 x y) ;; required
-	   (type int16 src-x src-y)
-	   (type (or null card16) width height)
-	   (type boolean bitmap-p))
-  (let* ((format
-	   (etypecase image
-	     (image-x (image-x-format (the image-x image)))
-	     (image-xy :xy-pixmap)
-	     (image-z :z-pixmap)))
-	 (src-x
-	   (if (image-x-p image)
-	       (index+ src-x (image-x-left-pad (the image-x image)))
-	     src-x))
-	 (image-width (image-width image))
-	 (image-height (image-height image))
-	 (width (min (or width image-width) (index- image-width src-x)))
-	 (height (min (or height image-height) (index- image-height src-y)))
-	 (depth (image-depth image))
-	 (display (drawable-display drawable))
-	 (bitmap-format (display-bitmap-format display))
-	 (unit (bitmap-format-unit bitmap-format))
-	 (byte-lsb-first-p (display-image-lsb-first-p display))
-	 (bit-lsb-first-p  (bitmap-format-lsb-first-p bitmap-format)))
-    (declare (type (member :bitmap :xy-pixmap :z-pixmap) format)
-	     (type card16 src-x image-width image-height width height)
-	     (type image-depth depth)
-	     (type display display)
-	     (type bitmap-format bitmap-format)
-	     (type (member 8 16 32) unit)
-	     (type boolean byte-lsb-first-p bit-lsb-first-p))
-    (when (and bitmap-p (not (index= depth 1)))
-      (error "Bitmaps must have depth 1"))
-    (unless (index<= 0 src-x (index1- (image-width image)))
-      (error "src-x not inside image"))
-    (unless (index<= 0 src-y (index1- (image-height image)))
-      (error "src-y not inside image"))
-    (when (and (index> width 0) (index> height 0))
-      (multiple-value-bind (pad bits-per-pixel)
-	  (ecase format
-	    ((:bitmap :xy-pixmap)
-	      (values (bitmap-format-pad bitmap-format) 1))
-	    (:z-pixmap
-	      (if (= depth 1) 
-		  (values (bitmap-format-pad bitmap-format) 1)
-		(let ((pixmap-format
-			(find depth (display-pixmap-formats display)
-			      :key #'pixmap-format-depth)))
-		  (declare (type (or null pixmap-format) pixmap-format))
-		  (if (null pixmap-format)
-		      (error "The depth of the image ~s does not match any server pixmap format." image))
-		  (if (not (= (etypecase image
-				(image-z (image-z-bits-per-pixel image))
-				(image-x (image-x-bits-per-pixel image)))
-			      (pixmap-format-bits-per-pixel pixmap-format)))
-		      ;; We could try to use the "/* XXX slow, but works */"
-		      ;; code in XPutImage from X11R4 here.  However, that
-		      ;; would require considerable support code
-		      ;; (see XImUtil.c, etc).
-		      (error "The bits-per-pixel of the image ~s does not match any server pixmap format." image))
-		  (values (pixmap-format-scanline-pad pixmap-format)
-			  (pixmap-format-bits-per-pixel pixmap-format))))))
-	(declare (type (member 8 16 32) pad)
-		 (type (member 1 4 8 16 24 32) bits-per-pixel))
-	(let* ((left-pad
-		 (if (or (eq format :xy-pixmap) (= depth 1))
-		     (index-mod src-x (index-min pad *image-pad*))
-		   0))
-	       (left-padded-src-x (index- src-x left-pad))
-	       (left-padded-width (index+ width left-pad))
-	       (bits-per-line (index* left-padded-width bits-per-pixel))
-	       (padded-bits-per-line
-		 (index* (index-ceiling bits-per-line pad) pad))
-	       (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
-	       (request-bytes-per-line
-		 (ecase format
-		   ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth))
-		   (:z-pixmap padded-bytes-per-line)))
-	       (max-bytes-per-request
-		 (index* (index- (display-max-request-length display) 6) 4))
-	       (max-request-height
-		 (floor max-bytes-per-request request-bytes-per-line)))
-	  (declare (type card8 left-pad)
-		   (type int16 left-padded-src-x)
-		   (type card16 left-padded-width)
-		   (type array-index bits-per-line padded-bits-per-line
-			 padded-bytes-per-line request-bytes-per-line
-			 max-bytes-per-request max-request-height))
-	  ;; Be sure that a scanline can fit in a request
-	  (when (index-zerop max-request-height)
-	    (error "Can't even fit one image scanline in a request"))
-	  ;; Be sure a scanline can fit in a buffer
-	  (buffer-ensure-size display padded-bytes-per-line)
-	  ;; Send the image in multiple requests to avoid exceeding the
-	  ;; request limit
-	  (do* ((request-src-y src-y (index+ request-src-y request-height))
-		(request-y y (index+ request-y request-height))
-		(height-remaining
-		  height (index- height-remaining request-height))
-		(request-height
-		  (index-min height-remaining max-request-height)
-		  (index-min height-remaining max-request-height)))
-	       ((index<= height-remaining 0))
-	    (declare (type array-index request-src-y height-remaining
-			   request-height))
-	    (let* ((request-bytes (index* request-bytes-per-line request-height))
-		   (request-words (index-ceiling request-bytes 4))
-		   (request-length (index+ request-words 6)))
-	      (declare (type array-index request-bytes)
-		       (type card16 request-words request-length))
-	      (with-buffer-request (display *x-putimage* :gc-force gcontext)
-		((data (member :bitmap :xy-pixmap :z-pixmap))
-		 (cond ((or (eq format :bitmap) bitmap-p) :bitmap)
-		       ((plusp left-pad) :xy-pixmap)
-		       (t format)))
-		(drawable drawable)
-		(gcontext gcontext)
-		(card16 width request-height)
-		(int16 x request-y)
-		(card8 left-pad depth)
-		(pad16 nil)
-		(progn 
-		  (length-put 2 request-length)
-		  (setf (buffer-boffset display) (advance-buffer-offset 24))
-		  (etypecase image
-		    (image-x
-		      (ecase (image-x-format (the image-x image))
-			((:bitmap :xy-pixmap)
-			  (write-xy-format-image-x
-			    display image left-padded-src-x request-src-y
-			    left-padded-width request-height
-			    padded-bytes-per-line
-			    unit byte-lsb-first-p bit-lsb-first-p))
-			(:z-pixmap
-			  (write-z-format-image-x
-			    display image left-padded-src-x request-src-y
-			    left-padded-width request-height
-			    padded-bytes-per-line
-			    unit byte-lsb-first-p bit-lsb-first-p))))
-		    (image-xy
-		      (write-image-xy
-			display image left-padded-src-x request-src-y
-			left-padded-width request-height
-			padded-bytes-per-line
-			unit byte-lsb-first-p bit-lsb-first-p))
-		    (image-z
-		      (write-image-z
-			display image left-padded-src-x request-src-y
-			left-padded-width request-height
-			padded-bytes-per-line
-			unit byte-lsb-first-p bit-lsb-first-p)))
-		  ;; Be sure the request is padded to a multiple of 4 bytes
-		  (buffer-pad-request display (index- (index* request-words 4) request-bytes))
-		  )))))))))
-
-;;;-----------------------------------------------------------------------------
-;;; COPY-IMAGE
-
-(defun xy-format-image-x->image-x (image x y width height)
-  (declare (type image-x image)
-	   (type card16 x y width height)
-	   (clx-values image-x))
-  (let* ((padded-x (index+ x (image-x-left-pad image)))
-	 (left-pad (index-mod padded-x 8))
-	 (x (index- padded-x left-pad))
-	 (unit (image-x-unit image))
-	 (byte-lsb-first-p (image-x-byte-lsb-first-p image))
-	 (bit-lsb-first-p (image-x-bit-lsb-first-p image))
-	 (pad (image-x-pad image))
-	 (padded-width
-	   (index* (index-ceiling (index+ width left-pad) pad) pad))
-	 (padded-bytes-per-line (index-ceiling padded-width 8))
-	 (padded-bytes-per-plane (index* padded-bytes-per-line height))
-	 (length (index* padded-bytes-per-plane (image-depth image)))
-	 (obuf (make-array length :element-type 'card8)))
-    (declare (type card16 x)
-	     (type card8 left-pad)
-	     (type (member 8 16 32) unit pad)
-	     (type array-index padded-width padded-bytes-per-line
-		   padded-bytes-per-plane length)
-	     (type buffer-bytes obuf))
-    (dotimes (plane (image-depth image))
-      (let ((data-start
-	      (index* (image-x-bytes-per-line image)
-		      (image-height image)
-		      plane))
-	    (obuf-start
-	      (index* padded-bytes-per-plane
-		      plane)))
-	(declare (type array-index data-start obuf-start))
-	(write-xy-format-image-x-data
-	  (image-x-data image) obuf data-start obuf-start
-	  x y width height 
-	  (image-x-bytes-per-line image) padded-bytes-per-line
-	  unit byte-lsb-first-p bit-lsb-first-p
-	  unit byte-lsb-first-p bit-lsb-first-p)))
-    (create-image
-      :width width :height height :depth (image-depth image)
-      :data obuf :format (image-x-format image) :bits-per-pixel 1
-      :bytes-per-line padded-bytes-per-line
-      :unit unit :pad pad :left-pad left-pad
-      :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p)))
-
-(defun z-format-image-x->image-x (image x y width height)
-  (declare (type image-x image)
-	   (type card16 x y width height)
-	   (clx-values image-x))
-  (let* ((padded-x (index+ x (image-x-left-pad image)))
-	 (left-pad
-	   (if (index= (image-depth image) 1)
-	       (index-mod padded-x 8)
-	     0))
-	 (x (index- padded-x left-pad))
-	 (bits-per-pixel (image-x-bits-per-pixel image))
-	 (unit (image-x-unit image))
-	 (byte-lsb-first-p (image-x-byte-lsb-first-p image))
-	 (bit-lsb-first-p (image-x-bit-lsb-first-p image))
-	 (pad (image-x-pad image))
-	 (bits-per-line (index* (index+ width left-pad) bits-per-pixel))
-	 (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad))
-	 (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
-	 (padded-bytes-per-plane (index* padded-bytes-per-line height))
-	 (length (index* padded-bytes-per-plane (image-depth image)))
-	 (obuf (make-array length :element-type 'card8)))
-    (declare (type card16 x)
-	     (type card8 left-pad)
-	     (type (member 8 16 32) unit pad)
-	     (type array-index bits-per-pixel padded-bytes-per-line
-		   padded-bytes-per-plane length)
-	     (type buffer-bytes obuf))
-    (write-z-format-image-x-data
-      (image-x-data image) obuf 0 0
-      x y width height 
-      (image-x-bytes-per-line image) padded-bytes-per-line
-      bits-per-pixel
-      unit byte-lsb-first-p bit-lsb-first-p
-      unit byte-lsb-first-p bit-lsb-first-p)
-    (create-image
-      :width width :height height :depth (image-depth image)
-      :data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel
-      :bytes-per-line padded-bytes-per-line
-      :unit unit :pad pad :left-pad left-pad
-      :byte-lsb-first-p byte-lsb-first-p :bit-lsb-first-p bit-lsb-first-p)))
-
-(defun image-x->image-x  (image x y width height)
-  (declare (type image-x image)
-	   (type card16 x y width height)
-	   (clx-values image-x))
-  (ecase (image-x-format image)
-    ((:bitmap :xy-pixmap)
-      (xy-format-image-x->image-x image x y width height))
-    (:z-pixmap
-      (z-format-image-x->image-x image x y width height))))
-
-(defun image-x->image-xy (image x y width height)
-  (declare (type image-x image)
-	   (type card16 x y width height)
-	   (clx-values image-xy))
-  (unless (or (eq (image-x-format image) :bitmap)
-	      (eq (image-x-format image) :xy-pixmap)
-	      (and (eq (image-x-format image) :z-pixmap)
-		   (index= (image-depth image) 1)))
-    (error "Format conversion from ~S to ~S not supported"
-	   (image-x-format image) :xy-pixmap))
-  (read-image-xy
-    (image-x-data image) 0 (length (image-x-data image)) nil
-    (index+ x (image-x-left-pad image)) y width height
-    (image-depth image) (image-x-bytes-per-line image)
-    (index* (image-x-bytes-per-line image) (image-height image))
-    (image-x-unit image) (image-x-byte-lsb-first-p image)
-    (image-x-bit-lsb-first-p image)))
-
-(defun image-x->image-z  (image x y width height)
-  (declare (type image-x image)
-	   (type card16 x y width height)
-	   (clx-values image-z))
-  (unless (or (eq (image-x-format image) :z-pixmap)
-	      (eq (image-x-format image) :bitmap)
-	      (and (eq (image-x-format image) :xy-pixmap)
-		   (index= (image-depth image) 1)))
-    (error "Format conversion from ~S to ~S not supported"
-	   (image-x-format image) :z-pixmap))
-  (read-image-z
-    (image-x-data image) 0 (length (image-x-data image)) nil
-    (index+ x (image-x-left-pad image)) y width height
-    (image-depth image) (image-x-bytes-per-line image)
-    (image-x-bits-per-pixel image)
-    (image-x-unit image) (image-x-byte-lsb-first-p image)
-    (image-x-bit-lsb-first-p image)))
-
-(defun copy-pixarray (array x y width height bits-per-pixel)
-  (declare (type pixarray array)
-	   (type card16 x y width height)
-	   (type (member 1 4 8 16 24 32) bits-per-pixel))
-  (let* ((bits-per-line (index* bits-per-pixel width))
-	 (padded-bits-per-line
-	   (index* (index-ceiling bits-per-line *image-pad*) *image-pad*))
-	 (padded-width (index-ceiling padded-bits-per-line bits-per-pixel))
-	 (copy (make-array (list height padded-width)
-			   :element-type (array-element-type array))))
-    (declare (type array-index bits-per-line padded-bits-per-line padded-width)
-	     (type pixarray copy))
-    #.(declare-buffun)
-    (unless (fast-copy-pixarray array copy x y width height bits-per-pixel)
-      (macrolet
-	((copy (array-type element-type)
-	   `(let ((array array)
-		  (copy copy))
-	      (declare (type ,array-type array copy))
-	      (do* ((dst-y 0 (index1+ dst-y))
-		    (src-y y (index1+ src-y)))
-		   ((index>= dst-y height))
-		(declare (type card16 dst-y src-y))
-		(do* ((dst-x 0 (index1+ dst-x))
-		      (src-x x (index1+ src-x)))
-		     ((index>= dst-x width))
-		  (declare (type card16 dst-x src-x))
-		  (setf (aref copy dst-y dst-x)
-			(the ,element-type
-			     (aref array src-y src-x))))))))
-	(ecase bits-per-pixel
-	  (1  (copy pixarray-1  pixarray-1-element-type))
-	  (4  (copy pixarray-4  pixarray-4-element-type))
-	  (8  (copy pixarray-8  pixarray-8-element-type))
-	  (16 (copy pixarray-16 pixarray-16-element-type))
-	  (24 (copy pixarray-24 pixarray-24-element-type))
-	  (32 (copy pixarray-32 pixarray-32-element-type)))))
-    copy))
-
-(defun image-xy->image-x (image x y width height)
-  (declare (type image-xy image)
-	   (type card16 x y width height)
-	   (clx-values image-x))
-  (let* ((padded-bits-per-line
-	   (index* (index-ceiling width *image-pad*) *image-pad*))
-	 (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
-	 (padded-bytes-per-plane (index* padded-bytes-per-line height))
-	 (bytes-total (index* padded-bytes-per-plane (image-depth image)))
-	 (data (make-array bytes-total :element-type 'card8)))
-    (declare (type array-index padded-bits-per-line padded-bytes-per-line
-		   padded-bytes-per-plane bytes-total)
-	     (type buffer-bytes data))
-    (let ((index 0))
-      (declare (type array-index index))
-      (dolist (bitmap (image-xy-bitmap-list image))
-	(declare (type pixarray-1 bitmap))
-	(write-pixarray
-	  data index bitmap x y width height padded-bytes-per-line 1
-	  *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)
-	(index-incf index padded-bytes-per-plane)))
-    (create-image
-      :width width :height height :depth (image-depth image)
-      :data data :format :xy-pixmap :bits-per-pixel 1
-      :bytes-per-line padded-bytes-per-line
-      :unit *image-unit* :pad *image-pad*
-      :byte-lsb-first-p *image-byte-lsb-first-p*
-      :bit-lsb-first-p *image-bit-lsb-first-p*)))
-
-(defun image-xy->image-xy (image x y width height)
-  (declare (type image-xy image)
-	   (type card16 x y width height)
-	   (clx-values image-xy))
-  (create-image
-    :width width :height height :depth (image-depth image)
-    :data (mapcar
-	    #'(lambda (array)
-		(declare (type pixarray-1 array))
-		(copy-pixarray array x y width height 1))
-	    (image-xy-bitmap-list image))))
-
-(defun image-xy->image-z (image x y width height)
-  (declare (type image-z image)
-	   (type card16 x y width height)
-	   (ignore image x y width height))
-  (error "Format conversion from ~S to ~S not supported"
-	 :xy-pixmap :z-pixmap))
-
-(defun image-z->image-x (image x y width height)
-  (declare (type image-z image)
-	   (type card16 x y width height)
-	   (clx-values image-x))
-  (let* ((bits-per-line (index* width (image-z-bits-per-pixel image)))
-	 (padded-bits-per-line
-	   (index* (index-ceiling bits-per-line *image-pad*) *image-pad*))
-	 (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
-	 (bytes-total
-	   (index* padded-bytes-per-line height (image-depth image)))
-	 (data (make-array bytes-total :element-type 'card8))
-	 (bits-per-pixel (image-z-bits-per-pixel image)))
-    (declare (type array-index bits-per-line padded-bits-per-line
-		   padded-bytes-per-line bytes-total)
-	     (type buffer-bytes data)
-	     (type (member 1 4 8 16 24 32) bits-per-pixel))
-    (write-pixarray
-      data 0 (image-z-pixarray image) x y width height padded-bytes-per-line 
-      (image-z-bits-per-pixel image)
-      *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)
-    (create-image
-      :width width :height height :depth (image-depth image)
-      :data data :format :z-pixmap
-      :bits-per-pixel bits-per-pixel
-      :bytes-per-line padded-bytes-per-line
-      :unit *image-unit* :pad *image-pad*
-      :byte-lsb-first-p *image-byte-lsb-first-p*
-      :bit-lsb-first-p *image-bit-lsb-first-p*)))
-
-(defun image-z->image-xy (image x y width height)
-  (declare (type image-z image)
-	   (type card16 x y width height)
-	   (ignore image x y width height))
-  (error "Format conversion from ~S to ~S not supported"
-	 :z-pixmap :xy-pixmap))
-
-(defun image-z->image-z (image x y width height)
-  (declare (type image-z image)
-	   (type card16 x y width height)
-	   (clx-values image-z))
-  (create-image
-    :width width :height height :depth (image-depth image)
-    :data (copy-pixarray
-	    (image-z-pixarray image) x y width height
-	    (image-z-bits-per-pixel image))))
-
-(defun copy-image (image &key (x 0) (y 0) width height result-type)
-  ;; Copy with optional sub-imaging and format conversion.
-  ;; result-type defaults to (type-of image)
-  (declare (type image image)
-	   (type card16 x y)
-	   (type (or null card16) width height) ;; Default from image
-	   (type (or null (member image-x image-xy image-z)) result-type))
-  (declare (clx-values image))
-  (let* ((image-width (image-width image))
-	 (image-height (image-height image))
-	 (width (or width image-width))
-	 (height (or height image-height)))
-    (declare (type card16 image-width image-height width height))
-    (unless (index<= 0 x (index1- image-width)) (error "x not inside image"))
-    (unless (index<= 0 y (index1- image-height)) (error "y not inside image"))
-    (setq width (index-min width (index-max (index- image-width x) 0)))
-    (setq height (index-min height (index-max (index- image-height y) 0)))
-    (let ((copy
-	    (etypecase image
-	      (image-x
-		(ecase result-type
-		  ((nil image-x) (image-x->image-x image x y width height))
-		  (image-xy (image-x->image-xy image x y width height))
-		  (image-z  (image-x->image-z  image x y width height))))
-	      (image-xy
-		(ecase result-type
-		  (image-x (image-xy->image-x image x y width height))
-		  ((nil image-xy) (image-xy->image-xy image x y width height))
-		  (image-z  (image-xy->image-z image x y width height))))
-	      (image-z 
-		(ecase result-type
-		  (image-x (image-z->image-x image x y width height))
-		  (image-xy  (image-z->image-xy image x y width height))
-		  ((nil image-z) (image-z->image-z image x y width height)))))))
-      (declare (type image copy))
-      (setf (image-plist copy) (copy-list (image-plist image)))
-      (when (and (image-x-hot image) (not (index-zerop x)))
-	(setf (image-x-hot copy) (index- (image-x-hot image) x)))
-      (when (and (image-y-hot image) (not (index-zerop y)))
-	(setf (image-y-hot copy) (index- (image-y-hot image) y)))
-      copy)))
-
-
-;;;-----------------------------------------------------------------------------
-;;; Image I/O functions
-
-
-(defun read-bitmap-file (pathname)
-  ;; Creates an image from a C include file in standard X11 format
-  (declare (type (or pathname string stream) pathname))
-  (declare (clx-values image))
-  (with-open-file (fstream pathname :direction :input)
-    (let ((line "")
-	  (properties nil)
-	  (name nil)
-	  (name-end nil))
-      (declare (type string line)
-	       (type stringable name)
-	       (type list properties))
-      ;; Get properties
-      (loop
-	(setq line (read-line fstream))
-	(unless (char= (aref line 0) #\#) (return))
-	(flet ((read-keyword (line start end)
-		 (kintern
-		   (substitute
-		     #\- #\_
-		     (#-excl string-upcase
-		      #+excl correct-case
-		      (subseq line start end))
-		     :test #'char=))))
-	  (when (null name)
-	    (setq name-end (position #\_ line :test #'char= :from-end t)
-		  name (read-keyword line 8 name-end))
-	    (unless (eq name :image)
-	      (setf (getf properties :name) name)))
-	  (let* ((ind-start (index1+ name-end))
-		 (ind-end (position #\Space line :test #'char=
-				    :start ind-start))
-		 (ind (read-keyword line ind-start ind-end))
-		 (val-start (index1+ ind-end))
-		 (val (parse-integer line :start val-start)))
-	    (setf (getf properties ind) val))))
-      ;; Calculate sizes
-      (multiple-value-bind (width height depth left-pad)
-	  (flet ((extract-property (ind &rest default)
-		   (prog1 (apply #'getf properties ind default)
-			  (remf properties ind))))
-	    (values (extract-property :width)
-		    (extract-property :height)
-		    (extract-property :depth 1)
-		    (extract-property :left-pad 0)))
-	(declare (type (or null card16) width height)
-		 (type image-depth depth)
-		 (type card8 left-pad))
-	(unless (and width height) (error "Not a BITMAP file"))
-	(let* ((bits-per-pixel
-		 (cond ((index> depth 24) 32)
-		       ((index> depth 16) 24)
-		       ((index> depth 8)  16)
-		       ((index> depth 4)   8)
-		       ((index> depth 1)   4)
-		       (t                  1)))
-	       (bits-per-line (index* width bits-per-pixel))
-	       (bytes-per-line (index-ceiling bits-per-line 8))
-	       (padded-bits-per-line
-		 (index* (index-ceiling bits-per-line 32) 32))
-	       (padded-bytes-per-line
-		 (index-ceiling padded-bits-per-line 8))
-	       (data (make-array (* padded-bytes-per-line height)
-				 :element-type 'card8))
-	       (line-base 0)
-	       (byte 0))
-	  (declare (type array-index bits-per-line bytes-per-line
-			 padded-bits-per-line padded-bytes-per-line
-			 line-base byte)
-		   (type buffer-bytes data))
-	  (with-vector (data buffer-bytes)
-	    (flet ((parse-hex (char)
-		     (second
-		       (assoc char
-			      '((#\0  0) (#\1  1) (#\2  2) (#\3  3)
-				(#\4  4) (#\5  5) (#\6  6) (#\7  7)
-				(#\8  8) (#\9  9) (#\a 10) (#\b 11)
-				(#\c 12) (#\d 13) (#\e 14) (#\f 15))
-			      :test #'char-equal))))
-	      (declare (inline parse-hex))
-	      ;; Read data
-	      ;; Note: using read-line instead of read-char would be 20% faster,
-	      ;;       but would cons a lot of garbage...
-	      (dotimes (i height)
-		(dotimes (j bytes-per-line)
-		  (loop (when (eql (read-char fstream) #\x) (return)))
-		  (setf (aref data (index+ line-base byte))
-			(index+ (index-ash (parse-hex (read-char fstream)) 4)
-				(parse-hex (read-char fstream))))
-		  (incf byte))
-		(setq byte 0
-		      line-base (index+ line-base padded-bytes-per-line)))))
-	  ;; Compensate for left-pad in width and x-hot
-	  (index-decf width left-pad)
-	  (when (getf properties :x-hot)
-	    (index-decf (getf properties :x-hot) left-pad))
-	  (create-image
-	    :width width :height height
-	    :depth depth :bits-per-pixel bits-per-pixel
-	    :data data :plist properties :format :z-pixmap
-	    :bytes-per-line padded-bytes-per-line
-	    :unit 32 :pad 32 :left-pad left-pad
-	    :byte-lsb-first-p t :bit-lsb-first-p t))))))
-
-(defun write-bitmap-file (pathname image &optional name)
-  ;; Writes an image to a C include file in standard X11 format
-  ;; NAME argument used for variable prefixes.  Defaults to "image"
-  (declare (type (or pathname string stream) pathname)
-	   (type image image)
-	   (type (or null stringable) name))
-  (unless (typep image 'image-x)
-    (setq image (copy-image image :result-type 'image-x)))
-  (let* ((plist (image-plist image))
-	 (name (or name (image-name image) 'image))
-	 (left-pad (image-x-left-pad image))
-	 (width (index+ (image-width image) left-pad))
-	 (height (image-height image))
-	 (depth
-	   (if (eq (image-x-format image) :z-pixmap)
-	       (image-depth image)
-	     1))
-	 (bits-per-pixel (image-x-bits-per-pixel image))
-	 (bits-per-line (index* width bits-per-pixel))
-	 (bytes-per-line (index-ceiling bits-per-line 8))
-	 (last (index* bytes-per-line height))
-	 (count 0))
-    (declare (type list plist)
-	     (type stringable name)
-	     (type card8 left-pad)
-	     (type card16 width height)
-	     (type (member 1 4 8 16 24 32) bits-per-pixel)
-	     (type image-depth depth)
-	     (type array-index bits-per-line bytes-per-line count last))
-    ;; Move x-hot by left-pad, if there is an x-hot, so image readers that
-    ;; don't know about left pad get the hot spot in the right place.  We have
-    ;; already increased width by left-pad.
-    (when (getf plist :x-hot)
-      (setq plist (copy-list plist))
-      (index-incf (getf plist :x-hot) left-pad))
-    (with-image-data-buffer (data last)
-      (multiple-value-bind (image-swap-function image-swap-lsb-first-p)
-	  (image-swap-function
-	    bits-per-pixel
-	    (image-x-unit image) (image-x-byte-lsb-first-p image)
-	    (image-x-bit-lsb-first-p image) 32 t t)
-	(declare (type symbol image-swap-function)
-		 (type boolean image-swap-lsb-first-p))
-	(funcall
-	  (symbol-function image-swap-function) (image-x-data image)
-	  data 0 0 bytes-per-line (image-x-bytes-per-line image)
-	  bytes-per-line height image-swap-lsb-first-p))
-      (with-vector (data buffer-bytes)
-	(setq name (string-downcase (string name)))
-	(with-open-file (fstream pathname :direction :output)
-	  (format fstream "#define ~a_width ~d~%" name width)
-	  (format fstream "#define ~a_height ~d~%" name height)
-	  (unless (= depth 1)
-	    (format fstream "#define ~a_depth ~d~%" name depth))
-	  (unless (zerop left-pad)
-	    (format fstream "#define ~a_left_pad ~d~%" name left-pad))
-	  (do ((prop plist (cddr prop)))
-	      ((endp prop))
-	    (when (and (not (member (car prop) '(:width :height)))
-		       (numberp (cadr prop)))
-	      (format fstream "#define ~a_~a ~d~%"
-		      name
-		      (substitute
-			#\_ #\- (string-downcase (string (car prop)))
-			:test #'char=)
-		      (cadr prop))))
-	  (format fstream "static char ~a_bits[] = {" name)
-	  (dotimes (i height)
-	    (dotimes (j bytes-per-line)
-	      (when (zerop (index-mod count 15))
-		(terpri fstream)
-		(write-char #\space fstream))
-	      (write-string "0x" fstream)
-	      ;; Faster than (format fstream "0x~2,'0x," byte)
-	      (let ((byte (aref data count))
-		    (translate "0123456789abcdef"))
-		(declare (type card8 byte))
-		(write-char (char translate (ldb (byte 4 4) byte)) fstream)
-		(write-char (char translate (ldb (byte 4 0) byte)) fstream))
-	      (index-incf count)
-	      (unless (index= count last)
-		(write-char #\, fstream))))
-	  (format fstream "};~%" fstream))))))
-
-(defun bitmap-image (&optional plist &rest patterns)
-  ;; Create an image containg pattern
-  ;; PATTERNS are bit-vector constants (e.g. #*10101)
-  ;; If the first parameter is a list, its used as the image property-list.
-  (declare (type (or list bit-vector) plist)
-	   (type list patterns)) ;; list of bitvector
-  (declare (clx-values image))
-  (unless (listp plist)
-    (push plist patterns)
-    (setq plist nil))
-  (let* ((width (length (first patterns)))
-	 (height (length patterns))
-	 (bitarray (make-array (list height width) :element-type 'bit))
-	 (row 0))
-    (declare (type card16 width height row)
-	     (type pixarray-1 bitarray))
-    (dolist (pattern patterns)
-      (declare (type simple-bit-vector pattern))
-      (dotimes (col width)
-	(declare (type card16 col))
-	(setf (aref bitarray row col) (the bit (aref pattern col))))
-      (incf row))
-    (create-image :width width :height height :plist plist :data bitarray)))
-
-(defun image-pixmap (drawable image &key gcontext width height depth)
-  ;; Create a pixmap containing IMAGE. Size defaults from the image.
-  ;; DEPTH is the pixmap depth.
-  ;; GCONTEXT is used for putting the image into the pixmap.
-  ;; If none is supplied, then one is created, used then freed.
-  (declare (type drawable drawable)
-	   (type image image)
-	   (type (or null gcontext) gcontext)
-	   (type (or null card16) width height)
-	   (type (or null card8) depth))
-  (declare (clx-values pixmap))
-  (let* ((image-width (image-width image))
-	 (image-height (image-height image))
-	 (image-depth (image-depth image))
-	 (width (or width image-width))
-	 (height (or height image-height))
-	 (depth (or depth image-depth))
-	 (pixmap (create-pixmap :drawable drawable
-			       :width width
-			       :height height
-			       :depth depth))
-	 (gc (or gcontext (create-gcontext
-			    :drawable pixmap
-			    :foreground 1
-			    :background 0))))
-    (unless (= depth image-depth)
-      (if (= image-depth 1)
-	  (unless gcontext (xlib::required-arg gcontext))
-	(error "Pixmap depth ~d incompatable with image depth ~d"
-	       depth image-depth)))	       
-    (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1) gcontext))
-    ;; Tile when image-width is less than the pixmap width, or
-    ;; the image-height is less than the pixmap height.
-    ;; ??? Would it be better to create a temporary pixmap and 
-    ;; ??? let the server do the tileing?
-    (do ((x image-width (+ x image-width)))
-	((>= x width))
-      (copy-area pixmap gc 0 0 image-width image-height pixmap x 0)
-      (incf image-width image-width))
-    (do ((y image-height (+ y image-height)))
-	((>= y height))
-      (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y)
-      (incf image-height image-height))
-    (unless gcontext (free-gcontext gc))
-    pixmap))
-
diff --git a/clx/input.lisp b/clx/input.lisp
deleted file mode 100644
index ecf33ee29aa9288da5676052438d3b0d6c181c4f..0000000000000000000000000000000000000000
--- a/clx/input.lisp
+++ /dev/null
@@ -1,1887 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-;;;
-;;; Change history:
-;;;
-;;;  Date	Author	Description
-;;; -------------------------------------------------------------------------------------
-;;; 12/10/87	LGO	Created
-
-(in-package :xlib)
-
-;; Event Resource
-(defvar *event-free-list* nil) ;; List of unused (processed) events
-
-(eval-when (eval compile load)
-(defconstant *max-events* 64) ;; Maximum number of events supported (the X11 alpha release only has 34)
-(defvar *event-key-vector* (make-array *max-events* :initial-element nil)
-  "Vector of event keys - See define-event")
-)
-(defvar *event-macro-vector* (make-array *max-events* :initial-element nil)
-  "Vector of event handler functions - See declare-event")
-(defvar *event-handler-vector* (make-array *max-events* :initial-element nil)
-  "Vector of event handler functions - See declare-event")
-(defvar *event-send-vector* (make-array *max-events* :initial-element nil)
-  "Vector of event sending functions - See declare-event")
-
-(defun allocate-event ()
-  (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer)
-      (make-reply-buffer *replysize*)))
-
-(defun deallocate-event (reply-buffer)
-  (declare (type reply-buffer reply-buffer))
-  (setf (reply-size reply-buffer) *replysize*)
-  (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer))
-
-;; Extensions are handled as follows:
-;; DEFINITION:	Use DEFINE-EXTENSION
-;;
-;; CODE:	Use EXTENSION-CODE to get the X11 opcode for an extension.
-;;		This looks up the code on the display-extension-alist.
-;;
-;; EVENTS:	Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE
-;;		at LOAD time to define an internal event-code number
-;;		(stored in the 'event-code property of the event-name)
-;;		used to index the following vectors:
-;;		*event-key-vector* 	Used for getting the event-key
-;;		*event-macro-vector*	Used for getting the event-parameter getting macros
-;;
-;;		The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert
-;;		a server event-code into an internal event-code used to index the following
-;;		vectors:
-;;		*event-handler-vector*	Used for getting the event-handler function
-;;		*event-send-vector*	Used for getting the event-sending function
-;;
-;;		The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert
-;;		internal event-codes to external (server) codes.
-;;
-;; ERRORS:	Use DEFINE-ERROR to define new error decodings.
-;;
-
-
-;; Any event-code greater than 34 is for an extension
-(defparameter *first-extension-event-code* 35)
-
-(defvar *extensions* nil) ;; alist of (extension-name-symbol events errors)
-
-(defmacro define-extension (name &key events errors)
-  ;; Define extension NAME with EVENTS and ERRORS.
-  ;; Note: The case of NAME is important.
-  ;; To define the request, Use:
-  ;;     (with-buffer-request (display (extension-opcode ,name)) ,@body)
-  ;;     See the REQUESTS file for lots of examples.
-  ;; To define event handlers, use declare-event.
-  ;; To define error handlers, use declare-error and define-condition.
-  (declare (type stringable name)
-	   (type list events errors))
-  (let ((name-symbol (kintern name)) ;; Intern name in the keyword package
-	(event-list (mapcar #'canonicalize-event-name events)))
-    `(eval-when (compile load eval)
-       (setq *extensions* (cons (list ',name-symbol ',event-list ',errors)
-				(delete ',name-symbol *extensions* :key #'car))))))
-
-(eval-when (compile eval load)
-(defun canonicalize-event-name (event)
-  ;; Returns the event name keyword given an event name stringable
-  (declare (type stringable event))
-  (declare (clx-values event-key))
-  (kintern event))
-) ;; end eval-when
-
-(eval-when (compile eval load)
-(defun allocate-extension-event-code (name)
-  ;; Allocate an event-code for an extension
-  ;; This is executed at COMPILE and LOAD time from DECLARE-EVENT.
-  ;; The event-code is used at compile-time by macros to index the following vectors:
-  ;; *event-key-vector* *event-macro-vector* *event-handler-vector* *event-send-vector*
-  (let ((event-code (get name 'event-code)))
-    (declare (type (or null card8) event-code))
-    (unless event-code
-      ;; First ensure the name is for a declared extension
-      (unless (dolist (extension *extensions*)
-		(when (member name (second extension))
-		  (return t)))
-	(x-type-error name 'event-key))
-      (setq event-code (position nil *event-key-vector*
-				 :start *first-extension-event-code*))
-      (setf (svref *event-key-vector* event-code) name)
-      (setf (get name 'event-code) event-code))
-    event-code))
-) ;; end eval-when
-
-(defun get-internal-event-code (display code)
-  ;; Given an X11 event-code, return the internal event-code.
-  ;; The internal event-code is used for indexing into the following vectors:
-  ;; *event-key-vector* *event-handler-vector* *event-send-vector*
-  ;; Returns NIL when the event-code is for an extension that isn't handled.
-  (declare (type display display)
-	   (type card8 code))
-  (declare (clx-values (or null card8)))
-  (setq code (logand #x7f code))
-  (if (< code *first-extension-event-code*)
-      code
-    (let* ((code-offset (- code *first-extension-event-code*))
-	   (event-extensions (display-event-extensions display))
-	   (code (if (< code-offset (length event-extensions))
-		     (aref event-extensions code-offset)
-		   0)))
-      (declare (type card8 code-offset code))
-      (when (zerop code)
-	(x-cerror "Ignore the event"
-		  'unimplemented-event :event-code code :display display))
-      code)))
-
-(defun get-external-event-code (display event)
-  ;; Given an X11 event name, return the event-code
-  (declare (type display display)
-	   (type event-key event))
-  (declare (clx-values card8))
-  (let ((code (get-event-code event)))
-    (declare (type (or null card8) code))
-    (when (>= code *first-extension-event-code*)
-      (setq code (+ *first-extension-event-code*
-		    (or (position code (display-event-extensions display))
-			(x-error 'undefined-event :display display :event-name event)))))
-    code))
-
-(defmacro extension-opcode (display name)
-  ;; Returns the major opcode for extension NAME.
-  ;; This is a macro to enable NAME to be interned for fast run-time
-  ;; retrieval. 
-  ;; Note: The case of NAME is important.
-  (let ((name-symbol (kintern name))) ;; Intern name in the keyword package
-    `(or (second (assoc ',name-symbol (display-extension-alist ,display)))
-	 (x-error 'absent-extension :name ',name-symbol :display ,display))))
-
-(defun initialize-extensions (display)
-  ;; Initialize extensions for DISPLAY
-  (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0))
-	(extension-alist nil))
-    (declare (type vector event-extensions)
-	     (type list extension-alist))
-    (dolist (extension *extensions*)
-      (let ((name (first extension))
-	    (events (second extension)))
-	(declare (type keyword name)
-		 (type list events))
-	(multiple-value-bind (major-opcode first-event first-error)
-	    (query-extension display name)
-	  (declare (type (or null card8) major-opcode first-event first-error))
-	  (when (and major-opcode (plusp major-opcode))
-	    (push (list name major-opcode first-event first-error)
-		  extension-alist)
-	    (when (plusp first-event) ;; When there are extension events
-	      ;; Grow extension vector when needed
-	      (let ((max-event (- (+ first-event (length events))
-				  *first-extension-event-code*)))
-		(declare (type card8 max-event))
-		(when (>= max-event (length event-extensions))
-		  (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8
-						    :initial-element 0)))
-		    (declare (type vector new-extensions))
-		    (replace new-extensions event-extensions)
-		    (setq event-extensions new-extensions))))
-	      (dolist (event events)
-		(declare (type symbol event))
-		(setf (aref event-extensions (- first-event *first-extension-event-code*))
-		      (get-event-code event))
-		(incf first-event)))))))
-    (setf (display-event-extensions display) event-extensions)
-    (setf (display-extension-alist display) extension-alist)))
-
-;;
-;; Reply handlers
-;;
-
-(defvar *pending-command-free-list* nil)
-
-(defun start-pending-command (display)
-  (declare (type display display))
-  (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list*
-						  pending-command-next pending-command)
-			     (make-pending-command))))
-    (declare (type pending-command pending-command))
-    (setf (pending-command-reply-buffer pending-command) nil)
-    (setf (pending-command-process pending-command) (current-process))
-    (setf (pending-command-sequence pending-command)
-	  (ldb (byte 16 0) (1+ (buffer-request-number display))))
-    ;; Add the pending command to the end of the threaded list of pending
-    ;; commands for the display.
-    (with-event-queue-internal (display)
-      (threaded-nconc pending-command (display-pending-commands display)
-		      pending-command-next pending-command))
-    pending-command))
-
-(defun stop-pending-command (display pending-command)
-  (declare (type display display)
-	   (type pending-command pending-command))
-  (with-event-queue-internal (display)
-    ;; Remove the pending command from the threaded list of pending commands
-    ;; for the display.
-    (threaded-delete pending-command (display-pending-commands display)
-		     pending-command-next pending-command)
-    ;; Deallocate any reply buffers in this pending command
-    (loop
-      (let ((reply-buffer
-	      (threaded-pop (pending-command-reply-buffer pending-command)
-			    reply-next reply-buffer)))
-	(declare (type (or null reply-buffer) reply-buffer))
-	(if reply-buffer
-	    (deallocate-reply-buffer reply-buffer)
-	  (return nil)))))
-  ;; Clear pointers to help the Garbage Collector
-  (setf (pending-command-process pending-command) nil)
-  ;; Deallocate this pending-command
-  (threaded-atomic-push pending-command *pending-command-free-list*
-			pending-command-next pending-command)
-  nil)
-
-;;;
-
-(defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil))
-
-(defun allocate-reply-buffer (size)
-  (declare (type array-index size))
-  (if (index<= size *replysize*)
-      (allocate-event)
-    (let ((index (integer-length (index1- size))))
-      (declare (type array-index index))
-      (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index)
-			       reply-next reply-buffer)
-	  (make-reply-buffer (index-ash 1 index))))))
-
-(defun deallocate-reply-buffer (reply-buffer)
-  (declare (type reply-buffer reply-buffer))
-  (let ((size (reply-size reply-buffer)))
-    (declare (type array-index size))
-    (if (index<= size *replysize*)
-	(deallocate-event reply-buffer)
-      (let ((index (integer-length (index1- size))))
-	(declare (type array-index index))
-	(threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index)
-			      reply-next reply-buffer)))))
-
-;;;
-
-(defun read-error-input (display sequence reply-buffer token)
-  (declare (type display display)
-	   (type reply-buffer reply-buffer)
-	   (type card16 sequence))
-  (tagbody
-    start
-       (with-event-queue-internal (display)
-	 (let ((command 
-		 ;; Find any pending command with this sequence number.
-		 (threaded-dolist (pending-command (display-pending-commands display)
-						   pending-command-next pending-command)
-		   (when (= (pending-command-sequence pending-command) sequence)
-		     (return pending-command)))))
-	   (declare (type (or null pending-command) command))
-	   (cond ((not (null command))
-		  ;; Give this reply to the pending command
-		  (threaded-nconc reply-buffer (pending-command-reply-buffer command)
-				  reply-next reply-buffer)
-		  (process-wakeup (pending-command-process command)))
-		 ((member :immediately (display-report-asynchronous-errors display))
-		  ;; No pending command and we should report the error immediately
-		  (go report-error))
-		 (t
-		  ;; No pending command found, count this as an asynchronous error
-		  (threaded-nconc reply-buffer (display-asynchronous-errors display)
-				  reply-next reply-buffer)))))
-       (return-from read-error-input nil)
-    report-error
-       (note-input-complete display token)
-       (apply #'report-error display
-	      (prog1 (make-error display reply-buffer t)
-		     (deallocate-event reply-buffer)))))
-
-(defun read-reply-input (display sequence length reply-buffer)
-  (declare (type display display)
-	   (type (or null reply-buffer) reply-buffer)
-	   (type card16 sequence)
-	   (type array-index length))
-  (unwind-protect 
-      (progn
-	(when (index< *replysize* length)
-	  (let ((repbuf nil))
-	    (declare (type (or null reply-buffer) repbuf))
-	    (unwind-protect
-		(progn
-		  (setq repbuf (allocate-reply-buffer length))
-		  (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer)
-				  0 *replysize*)
-		  (deallocate-event (shiftf reply-buffer repbuf nil)))
-	      (when repbuf
-		(deallocate-reply-buffer repbuf))))
-	  (when (buffer-input display (reply-ibuf8 reply-buffer) *replysize* length)
-	    (return-from read-reply-input t))
-	  (setf (reply-data-size reply-buffer) length))
-	(with-event-queue-internal (display)
-	  ;; Find any pending command with this sequence number.
-	  (let ((command 
-		  (threaded-dolist (pending-command (display-pending-commands display)
-						    pending-command-next pending-command)
-		    (when (= (pending-command-sequence pending-command) sequence)
-		      (return pending-command)))))
-	    (declare (type (or null pending-command) command))
-	    (when command 
-	      ;; Give this reply to the pending command
-	      (threaded-nconc (shiftf reply-buffer nil)
-			      (pending-command-reply-buffer command)
-			      reply-next reply-buffer)
-	      (process-wakeup (pending-command-process command)))))
-	nil)
-    (when reply-buffer
-      (deallocate-reply-buffer reply-buffer))))
-
-(defun read-event-input (display code reply-buffer)
-  (declare (type display display)
-	   (type card8 code)
-	   (type reply-buffer reply-buffer))
-  ;; Push the event in the input buffer on the display's event queue
-  (setf (event-code reply-buffer)
-	(get-internal-event-code display code))
-  (enqueue-event reply-buffer display)
-  nil)
-
-(defun note-input-complete (display token)
-  (declare (type display display))
-  (when (eq (display-input-in-progress display) token)
-    ;; Indicate that input is no longer in progress
-    (setf (display-input-in-progress display) nil)
-    ;; Let the event process get the first chance to do input
-    (let ((process (display-event-process display)))
-      (when (not (null process))
-	(process-wakeup process)))
-    ;; Then give processes waiting for command responses a chance
-    (unless (display-input-in-progress display)
-      (with-event-queue-internal (display)
-	(threaded-dolist (command (display-pending-commands display)
-				  pending-command-next pending-command)
-	  (process-wakeup (pending-command-process command)))))))
-
-(defun read-input (display timeout force-output-p predicate &rest predicate-args)
-  (declare (type display display)
-	   (type (or null number) timeout)
-	   (type boolean force-output-p)
-	   (dynamic-extent predicate-args))
-  (declare (type function predicate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent predicate)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg predicate))
-  (let ((reply-buffer nil)
-	(token (or (current-process) (cons nil nil))))
-    (declare (type (or null reply-buffer) reply-buffer))
-    (unwind-protect 
-	(tagbody
-	  loop
-	     (when (display-dead display)
-	       (x-error 'closed-display :display display))
-	     (when (apply predicate predicate-args)
-	       (return-from read-input nil))
-	     ;; Check and see if we have to force output
-	     (when (and force-output-p
-			(or (and (not (eq (display-input-in-progress display) token))
-				 (not (conditional-store
-					(display-input-in-progress display) nil token)))
-			    (null (buffer-listen display))))
-	       (go force-output))
-	     ;; Ensure that ony one process is reading input.
-	     (unless (or (eq (display-input-in-progress display) token)
-			 (conditional-store (display-input-in-progress display) nil token))
-	       (if (eql timeout 0)
-		   (return-from read-input :timeout)
-		 (apply #'process-block "CLX Input Lock"
-			#'(lambda (display predicate &rest predicate-args)
-			    (declare (type display display)
-				     (dynamic-extent predicate-args)
-				     (type function predicate)
-				     #+clx-ansi-common-lisp
-				     (dynamic-extent predicate)
-				     #+(and lispm (not clx-ansi-common-lisp))
-				     (sys:downward-funarg predicate))
-			    (or (apply predicate predicate-args)
-				(null (display-input-in-progress display))
-				(not (null (display-dead display)))))
-			display predicate predicate-args))
-	       (go loop))
-	     ;; Now start gobbling.
-	     (setq reply-buffer (allocate-event))
-	     (with-buffer-input (reply-buffer :sizes (8 16 32))
-	       (let ((type 0))
-		 (declare (type card8 type))
-		 ;; Wait for input before we disallow aborts.
-		 (unless (eql timeout 0)
-		   (let ((eof-p (buffer-input-wait display timeout)))
-		     (when eof-p (return-from read-input eof-p))))
-		 (without-aborts
-		   (let ((eof-p (buffer-input display buffer-bbuf 0 *replysize*
-					      (if force-output-p 0 timeout))))
-		     (when eof-p
-		       (when (eq eof-p :timeout)
-			 (if force-output-p
-			     (go force-output)
-			   (return-from read-input :timeout)))
-		       (setf (display-dead display) t)
-		       (return-from read-input eof-p)))
-		   (setf (reply-data-size reply-buffer) *replysize*)
-		   (when (= (the card8 (setq type (read-card8 0))) 1)
-		     ;; Normal replies can be longer than *replysize*, so we
-		     ;; have to handle them while aborts are still disallowed.
-		     (let ((value
-			     (read-reply-input
-			       display (read-card16 2)
-			       (index+ *replysize* (index* (read-card32 4) 4))
-			       (shiftf reply-buffer nil))))
-		       (when value
-			 (return-from read-input value))
-		       (go loop))))
-		 (if (zerop type)
-		     (read-error-input
-		       display (read-card16 2) (shiftf reply-buffer nil) token)
-		   (read-event-input
-		     display (read-card8 0) (shiftf reply-buffer nil)))))
-	     (go loop)
-	  force-output 
-	     (note-input-complete display token)
-	     (display-force-output display)
-	     (setq force-output-p nil)
-	     (go loop))
-      (when (not (null reply-buffer))
-	(deallocate-reply-buffer reply-buffer))
-      (note-input-complete display token))))
-
-(defun report-asynchronous-errors (display mode)
-  (when (and (display-asynchronous-errors display)
-	     (member mode (display-report-asynchronous-errors display)))
-    (let ((aborted t))
-      (unwind-protect 
-	  (loop
-	    (let ((error
-		    (with-event-queue-internal (display)
-		      (threaded-pop (display-asynchronous-errors display)
-				    reply-next reply-buffer))))
-	      (declare (type (or null reply-buffer) error))
-	      (if error
-		  (apply #'report-error display
-			 (prog1 (make-error display error t)
-				(deallocate-event error)))
-		(return (setq aborted nil)))))
-	;; If we get aborted out of this, deallocate all outstanding asynchronous
-	;; errors.
-	(when aborted 
-	  (with-event-queue-internal (display)
-	    (loop
-	      (let ((reply-buffer
-		      (threaded-pop (display-asynchronous-errors display)
-				    reply-next reply-buffer)))
-		(declare (type (or null reply-buffer) reply-buffer))
-		(if reply-buffer
-		    (deallocate-event reply-buffer)
-		  (return nil))))))))))
-
-(defun wait-for-event (display timeout force-output-p)
-  (declare (type display display)
-	   (type (or null number) timeout)
-	   (type boolean force-output-p))
-  (let ((event-process-p (not (eql timeout 0))))
-    (declare (type boolean event-process-p))
-    (unwind-protect
-	(loop
-	  (when event-process-p
-	    (conditional-store (display-event-process display) nil (current-process)))
-	  (let ((eof (read-input
-		       display timeout force-output-p 
-		       #'(lambda (display)
-			   (declare (type display display))
-			   (or (not (null (display-new-events display)))
-			       (and (display-asynchronous-errors display)
-				    (member :before-event-handling
-					    (display-report-asynchronous-errors display))
-				    t)))
-		       display)))
-	    (when eof (return eof)))
-	  ;; Report asynchronous errors here if the user wants us to.
-	  (when event-process-p
-	    (report-asynchronous-errors display :before-event-handling))
-	  (when (not (null (display-new-events display)))
-	    (return nil)))
-      (when (and event-process-p
-		 (eq (display-event-process display) (current-process)))
-	(setf (display-event-process display) nil)))))
-
-(defun read-reply (display pending-command)
-  (declare (type display display)
-	   (type pending-command pending-command))
-  (loop
-    (when (read-input display nil nil
-		      #'(lambda (pending-command)
-			  (declare (type pending-command pending-command))
-			  (not (null (pending-command-reply-buffer pending-command))))
-		      pending-command)
-      (x-error 'closed-display :display display))
-    (let ((reply-buffer
-	    (with-event-queue-internal (display)
-	      (threaded-pop (pending-command-reply-buffer pending-command)
-			    reply-next reply-buffer))))
-      (declare (type reply-buffer reply-buffer))
-      ;; Check for error.
-      (with-buffer-input (reply-buffer)
-	(ecase (read-card8 0)
-	  (0 (apply #'report-error display
-		    (prog1 (make-error display reply-buffer nil)
-			   (deallocate-reply-buffer reply-buffer))))
-	  (1 (return reply-buffer)))))))
-
-;;;
-
-(defun event-listen (display &optional (timeout 0))
-  (declare (type display display)
-	   (type (or null number) timeout)
-	   (clx-values number-of-events-queued eof-or-timeout))
-  ;; Returns the number of events queued locally, if any, else nil.  Hangs
-  ;; waiting for events, forever if timeout is nil, else for the specified
-  ;; number of seconds.
-  (let* ((current-event-symbol (car (display-current-event-symbol display)))
-	 (current-event (and (boundp current-event-symbol)
-			     (symbol-value current-event-symbol)))
-	 (queue (if current-event
-		    (reply-next (the reply-buffer current-event))
-		  (display-event-queue-head display))))
-    (declare (type symbol current-event-symbol)
-	     (type (or null reply-buffer) current-event queue))
-    (if queue
-	(values
-	  (with-event-queue-internal (display :timeout timeout)
-	    (threaded-length queue reply-next reply-buffer))
-	  nil)
-      (with-event-queue (display :timeout timeout :inline t)
-	(let ((eof-or-timeout (wait-for-event display timeout nil)))
-	  (if eof-or-timeout
-	      (values nil eof-or-timeout)
-	    (values 
-	      (with-event-queue-internal (display :timeout timeout)
-		(threaded-length (display-new-events display)
-				 reply-next reply-buffer))
-	      nil)))))))
-
-(defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys)
-  ;; The event is put at the head of the queue if append-p is nil, else the tail.
-  ;; Additional arguments depend on event-key, and are as specified above with
-  ;; declare-event, except that both resource-ids and resource objects are accepted
-  ;; in the event components.
-  (declare (type display display)
-	   (type event-key event-key)
-	   (type boolean append-p send-event-p)
-	   (dynamic-extent args))
-  (unless (get event-key 'event-code)
-    (x-type-error event-key 'event-key))
-  (let* ((event (allocate-event))
-	 (buffer (reply-ibuf8 event))
-	 (event-code (get event-key 'event-code)))
-    (declare (type reply-buffer event)
-	     (type buffer-bytes buffer)
-	     (type (or null card8) event-code))
-    (unless event-code (x-type-error event-key 'event-key))
-    (setf (event-code event) event-code)
-    (with-display (display)
-      (apply (svref *event-send-vector* event-code) display args)
-      (buffer-replace buffer
-		      (display-obuf8 display)
-		      0
-		      *replysize*
-		      (index+ 12 (buffer-boffset display)))
-      (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code)
-	    (aref buffer 2) 0
-	    (aref buffer 3) 0))
-    (with-event-queue (display)
-      (if append-p
-	  (enqueue-event event display)
-	(with-event-queue-internal (display)
-	  (threaded-requeue event
-			    (display-event-queue-head display)
-			    (display-event-queue-tail display)
-			    reply-next reply-buffer))))))
-
-(defun enqueue-event (new-event display)
-  (declare (type reply-buffer new-event)
-	   (type display display))
-  ;; Place EVENT at the end of the event queue for DISPLAY
-  (let* ((event-code (event-code new-event))
-	 (event-key (and (index< event-code (length *event-key-vector*))
-			 (svref *event-key-vector* event-code))))
-    (declare (type array-index event-code)
-	     (type (or null keyword) event-key))
-    (if (null event-key)
-	(unwind-protect
-	    (cerror "Ignore this event" "No handler for ~s event" event-key)
-	  (deallocate-event new-event))
-      (with-event-queue-internal (display)
-	(threaded-enqueue new-event
-			  (display-event-queue-head display)
-			  (display-event-queue-tail display)
-			  reply-next reply-buffer)
-	(unless (display-new-events display)
-	  (setf (display-new-events display) new-event))))))
-
-
-(defmacro define-event (name code)
-  `(eval-when (eval compile load)
-     (setf (svref *event-key-vector* ,code) ',name)
-     (setf (get ',name 'event-code) ,code)))
-
-;; Event names.  Used in "type" field in XEvent structures.  Not to be
-;; confused with event masks above.  They start from 2 because 0 and 1
-;; are reserved in the protocol for errors and replies. */
-
-(define-event :key-press 2)
-(define-event :key-release 3)
-(define-event :button-press 4)
-(define-event :button-release 5)
-(define-event :motion-notify 6)
-(define-event :enter-notify 7)
-(define-event :leave-notify 8)
-(define-event :focus-in 9)
-(define-event :focus-out 10)
-(define-event :keymap-notify 11)
-(define-event :exposure 12)
-(define-event :graphics-exposure 13)
-(define-event :no-exposure 14)
-(define-event :visibility-notify 15)
-(define-event :create-notify 16)
-(define-event :destroy-notify 17)
-(define-event :unmap-notify 18)
-(define-event :map-notify 19)
-(define-event :map-request 20)
-(define-event :reparent-notify 21)
-(define-event :configure-notify 22)
-(define-event :configure-request 23)
-(define-event :gravity-notify 24)
-(define-event :resize-request 25)
-(define-event :circulate-notify 26)
-(define-event :circulate-request 27)
-(define-event :property-notify 28)
-(define-event :selection-clear 29)
-(define-event :selection-request 30)
-(define-event :selection-notify 31)
-(define-event :colormap-notify 32)
-(define-event :client-message 33)
-(define-event :mapping-notify 34)
-
-
-(defmacro declare-event (event-codes &body declares &environment env)
-  ;; Used to indicate the keyword arguments for handler functions in
-  ;; process-event and event-case.
-  ;; Generates the functions used in SEND-EVENT.
-  ;; A compiler warning is printed when all of EVENT-CODES are not
-  ;; defined by a preceding DEFINE-EXTENSION.
-  ;; The body is a list of declarations, each of which has the form:
-  ;; (type . items)  Where type is a data-type, and items is a list of
-  ;; symbol names.  The item order corresponds to the order of fields
-  ;; in the event sent by the server.  An item may be a list of items.
-  ;; In this case, each item is aliased to the same event field.
-  ;; This is used to give all events an EVENT-WINDOW item.
-  ;; See the INPUT file for lots of examples.
-  (declare (type (or keyword list) event-codes)
-	   (type (alist (field-type symbol) (field-names list))
-                 declares))
-  (when (atom event-codes) (setq event-codes (list event-codes)))
-  (setq event-codes (mapcar #'canonicalize-event-name event-codes))
-  (let* ((keywords nil)
-	 (name (first event-codes))
-	 (get-macro (xintern name '-event-get-macro))
-	 (get-function (xintern name '-event-get))
-	 (put-function (xintern name '-event-put)))
-    (multiple-value-bind (get-code get-index get-sizes)
-	(get-put-items
-	  2 declares nil
-	  #'(lambda (type index item args)
-	      (flet ((event-get (type index item args)
-		       (unless (member type '(pad8 pad16))
-			 `(,(kintern item)
-			   (,(getify type) ,index ,@args)))))
-		(if (atom item)
-		    (event-get type index item args)
-		  (mapcan #'(lambda (item)
-			      (event-get type index item args))
-			  item)))))
-      (declare (ignore get-index))
-      (multiple-value-bind (put-code put-index put-sizes)
-	  (get-put-items
-	    2 declares t
-	    #'(lambda (type index item args)
-		(unless (member type '(pad8 pad16))
-		  (if (atom item)
-		      (progn
-			(push item keywords)
-			`((,(putify type) ,index ,item ,@args)))
-		    (let ((names (mapcar #'(lambda (name) (kintern name))
-					 item)))
-		      (setq keywords (append item keywords))
-		      `((,(putify type) ,index
-			 (check-consistency ',names ,@item) ,@args)))))))
-	(declare (ignore put-index))
-	`(within-definition (,name declare-event)
-	   (defun ,get-macro (display event-key variable)
-	     ;; Note: we take pains to macroexpand the get-code here to enable application
-	     ;; code to be compiled without having the CLX macros file loaded.
-	     `(let ((%buffer ,display))
-		(declare (ignorable %buffer))
-		,(getf `(:display (the display ,display)
-			 :event-key (the keyword ,event-key)
-			 :event-code (the card8 (logand #x7f (read-card8 0)))
-			 :send-event-p (the boolean (logbitp 7 (read-card8 0)))
-			 ,@',(mapcar #'(lambda (form)
-					 (clx-macroexpand form env))
-				     get-code))
-		       variable)))
-
-	   (defun ,get-function (display event handler)
-	     (declare (type display display)
-		      (type reply-buffer event))
-	     (declare (type function handler)
-		      #+clx-ansi-common-lisp
-		      (dynamic-extent handler)
-		      #+(and lispm (not clx-ansi-common-lisp))
-		      (sys:downward-funarg handler))
-	     (reading-event (event :display display :sizes (8 16 ,@get-sizes))
-	       (funcall handler
-			:display display
-			:event-key (svref *event-key-vector* (event-code event))
-			:event-code (logand #x7f (card8-get 0))
-			:send-event-p (logbitp 7 (card8-get 0))
-			,@get-code)))
-
-	   (defun ,put-function (display &key ,@(setq keywords (nreverse keywords))
-				 &allow-other-keys)
-	     (declare (type display display))
-	     ,(when (member 'sequence keywords)
-		`(unless sequence (setq sequence (display-request-number display))))
-	     (with-buffer-output (display :sizes ,put-sizes
-					  :index (index+ (buffer-boffset display) 12))
-	       ,@put-code))
-       
-	   ,@(mapcar #'(lambda (name)
-			 (allocate-extension-event-code name)
-			 `(let ((event-code (or (get ',name 'event-code)
-						(allocate-extension-event-code ',name))))
-			    (setf (svref *event-macro-vector* event-code)
-				  (function ,get-macro))
-			    (setf (svref *event-handler-vector* event-code)
-				  (function ,get-function))
-			    (setf (svref *event-send-vector* event-code)
-				  (function ,put-function))))
-		     event-codes)
-	   ',name)))))
-
-(defun check-consistency (names &rest args)
-  ;; Ensure all args are nil or have the same value.
-  ;; Returns the consistent non-nil value.
-  (let ((value (car args)))
-    (dolist (arg (cdr args))
-      (if value
-	  (when (and arg (not (eq arg value)))
-	    (x-error 'inconsistent-parameters
-		     :parameters (mapcan #'list names args)))
-	(setq value arg)))
-    value))
-
-(declare-event (:key-press :key-release :button-press :button-release)
-  ;; for key-press and key-release, code is the keycode
-  ;; for button-press and button-release, code is the button number
-  (data code)
-  (card16 sequence)
-  ((or null card32) time)
-  (window root (window event-window))
-  ((or null window) child)
-  (int16 root-x root-y x y)
-  (card16 state)
-  (boolean same-screen-p)
-  )
-
-(declare-event :motion-notify
-  ((data boolean) hint-p)
-  (card16 sequence)
-  ((or null card32) time)
-  (window root (window event-window))
-  ((or null window) child)
-  (int16 root-x root-y x y)
-  (card16 state)
-  (boolean same-screen-p))
-
-(declare-event (:enter-notify :leave-notify)
-  ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind)
-  (card16 sequence)
-  ((or null card32) time)
-  (window root (window event-window))
-  ((or null window) child)
-  (int16 root-x root-y x y)
-  (card16 state)
-  ((member8 :normal :grab :ungrab) mode)
-  ((bit 0) focus-p)
-  ((bit 1) same-screen-p))
-
-(declare-event (:focus-in :focus-out)
-  ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
-		  :pointer :pointer-root :none))
-   kind)
-  (card16 sequence)
-  (window (window event-window))
-  ((member8 :normal :while-grabbed :grab :ungrab) mode))
-
-(declare-event :keymap-notify
-  ((bit-vector256 0) keymap))
-
-(declare-event :exposure
-  (card16 sequence)
-  (window (window event-window))
-  (card16 x y width height count))
-
-(declare-event :graphics-exposure
-  (card16 sequence)
-  (drawable (drawable event-window))
-  (card16 x y width height)
-  (card16 minor)  ;; Minor opcode
-  (card16 count)
-  (card8 major))
-
-(declare-event :no-exposure
-  (card16 sequence)
-  (drawable (drawable event-window))
-  (card16 minor)
-  (card8  major))
-
-(declare-event :visibility-notify
-  (card16 sequence)
-  (window (window event-window))
-  ((member8 :unobscured :partially-obscured :fully-obscured) state))
-
-(declare-event :create-notify
-  (card16 sequence)
-  (window (parent event-window) window)
-  (int16 x y)
-  (card16 width height border-width)
-  (boolean override-redirect-p))
-
-(declare-event :destroy-notify
-  (card16 sequence)
-  (window event-window window))
-
-(declare-event :unmap-notify
-  (card16 sequence)
-  (window event-window window)
-  (boolean configure-p))
-
-(declare-event :map-notify
-  (card16 sequence)
-  (window event-window window)
-  (boolean override-redirect-p))
-
-(declare-event :map-request
-  (card16 sequence)
-  (window (parent event-window) window))
-
-(declare-event :reparent-notify
-  (card16 sequence)
-  (window event-window window parent)
-  (int16 x y)
-  (boolean override-redirect-p))
-
-(declare-event :configure-notify
-  (card16 sequence)
-  (window event-window window)
-  ((or null window) above-sibling)
-  (int16 x y)
-  (card16 width height border-width)
-  (boolean override-redirect-p))
-
-(declare-event :configure-request
-  ((data (member :above :below :top-if :bottom-if :opposite)) stack-mode)
-  (card16 sequence)
-  (window (parent event-window) window)
-  ((or null window) above-sibling)
-  (int16 x y)
-  (card16 width height border-width value-mask))
-
-(declare-event :gravity-notify
-  (card16 sequence)
-  (window event-window window)
-  (int16 x y))
-
-(declare-event :resize-request
-  (card16 sequence)
-  (window (window event-window))
-  (card16 width height))
-
-(declare-event :circulate-notify
-  (card16 sequence)
-  (window event-window window parent)
-  ((member16 :top :bottom) place))
-
-(declare-event :circulate-request
-  (card16 sequence)
-  (window (parent event-window) window)
-  (pad16 1 2)
-  ((member16 :top :bottom) place))
-
-(declare-event :property-notify
-  (card16 sequence)
-  (window (window event-window))
-  (keyword atom) ;; keyword
-  ((or null card32) time)
-  ((member16 :new-value :deleted) state))
-
-(declare-event :selection-clear
-  (card16 sequence)
-  ((or null card32) time)
-  (window (window event-window)) 
-  (keyword selection) ;; keyword
-  )
-
-(declare-event :selection-request
-  (card16 sequence)
-  ((or null card32) time)
-  (window (window event-window) requestor)
-  (keyword selection target)
-  ((or null keyword) property)
-  )
-
-(declare-event :selection-notify
-  (card16 sequence)
-  ((or null card32) time)
-  (window (window event-window))
-  (keyword selection target)
-  ((or null keyword) property)
-  )
-
-(declare-event :colormap-notify
-  (card16 sequence)
-  (window (window event-window))
-  ((or null colormap) colormap)
-  (boolean new-p installed-p))
-
-(declare-event :client-message
-  (data format)
-  (card16 sequence)
-  (window (window event-window))
-  (keyword type)
-  ((client-message-sequence format) data))
-
-(declare-event :mapping-notify
-  (card16 sequence)
-  ((member8 :modifier :keyboard :pointer) request)
-  (card8 start) ;; first key-code
-  (card8 count))
-
-
-;;
-;; EVENT-LOOP
-;;
-
-(defun event-loop-setup (display)
-  (declare (type display display)
-	   (clx-values progv-vars progv-vals
-		   current-event-symbol current-event-discarded-p-symbol))
-  (let* ((progv-vars (display-current-event-symbol display))
-	 (current-event-symbol (first progv-vars))
-	 (current-event-discarded-p-symbol (second progv-vars)))
-    (declare (type list progv-vars)
-	     (type symbol current-event-symbol current-event-discarded-p-symbol))
-    (values
-      progv-vars 
-      (list (if (boundp current-event-symbol)
-		;; The current event is already bound, so bind it to the next
-		;; event.
-		(let ((event (symbol-value current-event-symbol)))
-		  (declare (type (or null reply-buffer) event))
-		  (and event (reply-next (the reply-buffer event))))
-	      ;; The current event isn't bound, so bind it to the head of the
-	      ;; event queue.
-	      (display-event-queue-head display))
-	    nil)
-      current-event-symbol
-      current-event-discarded-p-symbol)))
-
-(defun event-loop-step-before (display timeout force-output-p current-event-symbol)
-  (declare (type display display)
-	   (type (or null number) timeout)
-	   (type boolean force-output-p)
-	   (type symbol current-event-symbol)
-	   (clx-values event eof-or-timeout))
-  (unless (symbol-value current-event-symbol)
-    (let ((eof-or-timeout (wait-for-event display timeout force-output-p)))
-      (when eof-or-timeout
-	(return-from event-loop-step-before (values nil eof-or-timeout))))
-    (setf (symbol-value current-event-symbol) (display-new-events display)))
-  (let ((event (symbol-value current-event-symbol)))
-    (declare (type reply-buffer event))
-    (with-event-queue-internal (display)
-      (when (eq event (display-new-events display))
-	(setf (display-new-events display) (reply-next event))))
-    (values event nil)))
-
-(defun dequeue-event (display event)
-  (declare (type display display)
-	   (type reply-buffer event)
-	   (clx-values next))
-  ;; Remove the current event from the event queue
-  (with-event-queue-internal (display)
-    (let ((next (reply-next event))
-	  (head (display-event-queue-head display)))
-      (declare (type (or null reply-buffer) next head))
-      (when (eq event (display-new-events display))
-	(setf (display-new-events display) next))
-      (cond ((eq event head)
-	     (threaded-dequeue (display-event-queue-head display)
-			       (display-event-queue-tail display)
-			       reply-next reply-buffer))
-	    ((null head)
-	     (setq next nil))
-	    (t
-	     (do* ((previous head current)
-		   (current (reply-next previous) (reply-next previous)))
-		  ((or (null current) (eq event current))
-		   (when (eq event current)
-		     (when (eq current (display-event-queue-tail display))
-		       (setf (display-event-queue-tail display) previous))
-		     (setf (reply-next previous) next)))
-	       (declare (type reply-buffer previous)
-			(type (or null reply-buffer) current)))))
-      next)))
-
-(defun event-loop-step-after
-       (display event discard-p current-event-symbol current-event-discarded-p-symbol
-	&optional aborted)
-  (declare (type display display)
-	   (type reply-buffer event)
-	   (type boolean discard-p aborted)
-	   (type symbol current-event-symbol current-event-discarded-p-symbol))
-  (when (and discard-p
-	     (not aborted)
-	     (not (symbol-value current-event-discarded-p-symbol)))
-    (discard-current-event display))
-  (let ((next (reply-next event)))
-    (declare (type (or null reply-buffer) next))
-    (when (symbol-value current-event-discarded-p-symbol)
-      (setf (symbol-value current-event-discarded-p-symbol) nil)
-      (setq next (dequeue-event display event))
-      (deallocate-event event))
-    (setf (symbol-value current-event-symbol) next)))
-
-(defmacro event-loop ((display event timeout force-output-p discard-p) &body body)
-  ;; Bind EVENT to the events for DISPLAY.
-  ;; This is the "GUTS" of process-event and event-case.
-  `(let ((.display. ,display)
-	 (.timeout. ,timeout)
-	 (.force-output-p. ,force-output-p)
-	 (.discard-p. ,discard-p))
-     (declare (type display .display.)
-	      (type (or null number) .timeout.)
-	      (type boolean .force-output-p. .discard-p.))
-     (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.)))
-       (multiple-value-bind (.progv-vars. .progv-vals.
-			     .current-event-symbol. .current-event-discarded-p-symbol.)
-	   (event-loop-setup .display.)
-	 (declare (type list .progv-vars. .progv-vals.)
-		  (type symbol .current-event-symbol. .current-event-discarded-p-symbol.))
-	 (progv .progv-vars. .progv-vals.
-	   (loop
-	     (multiple-value-bind (.event. .eof-or-timeout.)
-		 (event-loop-step-before
-		   .display. .timeout. .force-output-p.
-		   .current-event-symbol.)
-	       (declare (type (or null reply-buffer) .event.))
-	       (when (null .event.) (return (values nil .eof-or-timeout.)))
-	       (let ((.aborted. t))
-		 (unwind-protect 
-		     (progn
-		       (let ((,event .event.))
-			 (declare (type reply-buffer ,event))
-			 ,@body)
-		       (setq .aborted. nil))
-		   (event-loop-step-after
-		     .display. .event. .discard-p.
-		     .current-event-symbol. .current-event-discarded-p-symbol.
-		     .aborted.))))))))))
-
-(defun discard-current-event (display)
-  ;; Discard the current event for DISPLAY.
-  ;; Returns NIL when the event queue is empty, else T.
-  ;; To ensure events aren't ignored, application code should only call
-  ;; this when throwing out of event-case or process-next-event, or from
-  ;; inside even-case, event-cond or process-event when :peek-p is T and
-  ;; :discard-p is NIL.
-  (declare (type display display)
-	   (clx-values boolean))
-  (let* ((symbols (display-current-event-symbol display))
-	 (event
-	   (let ((current-event-symbol (first symbols)))
-	     (declare (type symbol current-event-symbol))
-	     (when (boundp current-event-symbol)
-	       (symbol-value current-event-symbol)))))
-    (declare (type list symbols)
-	     (type (or null reply-buffer) event))
-    (unless (null event)
-      ;; Set the discarded-p flag
-      (let ((current-event-discarded-p-symbol (second symbols)))
-	(declare (type symbol current-event-discarded-p-symbol))
-	(when (boundp current-event-discarded-p-symbol)
-	  (setf (symbol-value current-event-discarded-p-symbol) t)))
-      ;; Return whether the event queue is empty
-      (not (null (reply-next (the reply-buffer event)))))))
-
-;;
-;; PROCESS-EVENT
-;;
-(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t))
-  ;; If force-output-p is true, first invokes display-force-output.  Invokes handler
-  ;; on each queued event until handler returns non-nil, and that returned object is
-  ;; then returned by process-event.  If peek-p is true, then the event is not
-  ;; removed from the queue.  If discard-p is true, then events for which handler
-  ;; returns nil are removed from the queue, otherwise they are left in place.  Hangs
-  ;; until non-nil is generated for some event, or for the specified timeout (in
-  ;; seconds, if given); however, it is acceptable for an implementation to wait only
-  ;; once on network data, and therefore timeout prematurely.  Returns nil on
-  ;; timeout.  If handler is a sequence, it is expected to contain handler functions
-  ;; specific to each event class; the event code is used to index the sequence,
-  ;; fetching the appropriate handler.  Handler is called with raw resource-ids, not
-  ;; with resource objects.  The arguments to the handler are described using declare-event.
-  ;;
-  ;; T for peek-p means the event (for which the handler returns non-nil) is not removed
-  ;; from the queue (it is left in place), NIL means the event is removed.
-  
-  (declare (type display display)
-	   (type (or null number) timeout)
-	   (type boolean peek-p discard-p force-output-p))
-  (declare (type t handler)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent handler)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg #+Genera * #-Genera handler))
-  (event-loop (display event timeout force-output-p discard-p)
-    (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT
-	   (event-decoder (and (index< event-code (length *event-handler-vector*))
-			       (svref *event-handler-vector* event-code))))
-      (declare (type array-index event-code)
-	       (type (or null function) event-decoder))
-      (if event-decoder
-	  (let ((event-handler (if (functionp handler)
-				   handler
-				   (and (type? handler 'sequence)
-					(< event-code (length handler))
-					(elt handler event-code)))))
-	    (if event-handler
-		(let ((result (funcall event-decoder display event event-handler)))
-		  (when result
-		    (unless peek-p
-		      (discard-current-event display))
-		    (return result)))
-	      (cerror "Ignore this event"
-		      "No handler for ~s event"
-		      (svref *event-key-vector* event-code))))
-	(cerror "Ignore this event"
-		"Server Error: event with unknown event code ~d received."
-		event-code)))))
-
-(defun make-event-handlers (&key (type 'array) default)
-  (declare (type t type)			;Sequence type specifier
-	   (type function default)
-	   (clx-values sequence))			;Default handler for initial content
-  ;; Makes a handler sequence suitable for process-event
-  (make-sequence type *max-events* :initial-element default))
-   
-(defun event-handler (handlers event-key)
-  (declare (type sequence handlers)
-	   (type event-key event-key)
-	   (clx-values function))
-  ;; Accessor for a handler sequence
-  (elt handlers (position event-key *event-key-vector* :test #'eq)))
-
-(defun set-event-handler (handlers event-key handler)
-  (declare (type sequence handlers)
-	   (type event-key event-key)
-	   (type function handler)
-	   (clx-values handler))
-  (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler))
-
-(defsetf event-handler set-event-handler)
-
-;;
-;; EVENT-CASE
-;; 
-
-(defmacro event-case ((&rest args) &body clauses)
-  ;; If force-output-p is true, first invokes display-force-output.  Executes the
-  ;; matching clause for each queued event until a clause returns non-nil, and that
-  ;; returned object is then returned by event-case.  If peek-p is true, then the
-  ;; event is not removed from the queue.  If discard-p is true, then events for
-  ;; which the clause returns nil are removed from the queue, otherwise they are left
-  ;; in place.  Hangs until non-nil is generated for some event, or for the specified
-  ;; timeout (in seconds, if given); however, it is acceptable for an implementation
-  ;; to wait only once on network data, and therefore timeout prematurely.  Returns
-  ;; nil on timeout.  In each clause, event-or-events is an event-key or a list of
-  ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise
-  ;; (but only in the last clause).  The keys are not evaluated, and it is an error
-  ;; for the same key to appear in more than one clause.  Args is the list of event
-  ;; components of interest; corresponding values (if any) are bound to variables
-  ;; with these names (i.e., the args are variable names, not keywords, the keywords
-  ;; are derived from the variable names).  An arg can also be a (keyword var) form,
-  ;; as for keyword args in a lambda lists.  If no t/otherwise clause appears, it is
-  ;; equivalent to having one that returns nil.
-  (declare (arglist (display &key timeout peek-p discard-p (force-output-p t))
-		   (event-or-events ((&rest args) |...|) &body body) |...|))
-  ;; Event-case is just event-cond with the whole body in the test-form
-  `(event-cond ,args
-	       ,@(mapcar
-		   #'(lambda (clause)
-		       `(,(car clause) ,(cadr clause) (progn ,@(cddr clause))))
-		   clauses)))
-
-;;
-;; EVENT-COND
-;; 
-
-(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t))
-		      &body clauses)
-  ;; The clauses of event-cond are of the form:
-  ;; (event-or-events binding-list test-form . body-forms)
-  ;;
-  ;; EVENT-OR-EVENTS	event-key or a list of event-keys (but they
-  ;;			need not be typed as keywords) or the symbol t
-  ;;			or otherwise (but only in the last clause).  If
-  ;;			no t/otherwise clause appears, it is equivalent
-  ;;			to having one that returns nil.  The keys are
-  ;;			not evaluated, and it is an error for the same
-  ;;			key to appear in more than one clause.
-  ;;
-  ;; BINDING-LIST	The list of event components of interest.
-  ;;			corresponding values (if any) are bound to
-  ;;			variables with these names (i.e., the binding-list
-  ;;			has variable names, not keywords, the keywords are
-  ;;			derived from the variable names).  An arg can also
-  ;;			be a (keyword var) form, as for keyword args in a
-  ;;			lambda list.
-  ;;
-  ;; The matching TEST-FORM for each queued event is executed until a
-  ;; clause's test-form returns non-nil.  Then the BODY-FORMS are
-  ;; evaluated, returning the (possibly multiple) values of the last
-  ;; form from event-cond.  If there are no body-forms then, if the
-  ;; test-form is non-nil, the value of the test-form is returned as a
-  ;; single value.
-  ;;
-  ;; Options:
-  ;; FORCE-OUTPUT-P	When true, first invoke display-force-output if no
-  ;;		  	input is pending.
-  ;;
-  ;; PEEK-P		When true, then the event is not removed from the queue.
-  ;;
-  ;; DISCARD-P		When true, then events for which the clause returns nil
-  ;; 			are removed from the queue, otherwise they are left in place.
-  ;;
-  ;; TIMEOUT		If NIL, hang until non-nil is generated for some event's
-  ;;			test-form. Otherwise return NIL after TIMEOUT seconds have
-  ;;			elapsed.
-  ;;
-  (declare (arglist (display &key timeout peek-p discard-p force-output-p)
-		   (event-or-events (&rest args) test-form &body body) |...|))
-  (let ((event (gensym))
-	(disp (gensym))
-	(peek (gensym)))
-    `(let ((,disp ,display)
-	   (,peek ,peek-p))
-       (declare (type display ,disp))
-       (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p)
-	 (event-dispatch (,disp ,event ,peek) ,@clauses)))))
-
-(defun get-event-code (event)
-  ;; Returns the event code given an event-key
-  (declare (type event-key event))
-  (declare (clx-values card8))
-  (or (get event 'event-code)
-      (x-type-error event 'event-key)))
-
-(defun universal-event-get-macro (display event-key variable)
-  (getf
-    `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code
-	       (the card8 (logand 127 (read-card8 0))) :send-event-p
-	       (the boolean (logbitp 7 (read-card8 0))))
-    variable))
-
-(defmacro event-dispatch ((display event peek-p) &body clauses)
-  ;; Helper macro for event-case
-  ;; CLAUSES are of the form:
-  ;; (event-or-events binding-list test-form . body-forms)
-  (let ((event-key (gensym))
-	(all-events (make-array *max-events* :element-type 'bit :initial-element 0)))
-    `(reading-event (,event)
-       (let ((,event-key (svref *event-key-vector* (event-code ,event))))
-	 (case ,event-key
-	   ,@(mapcar
-	       #'(lambda (clause)		; Translate event-cond clause to case clause
-		   (let* ((events (first clause))
-			  (arglist (second clause))
-			  (test-form (third clause))
-			  (body-forms (cdddr clause)))
-		     (flet ((event-clause (display peek-p first-form rest-of-forms)
-			      (if rest-of-forms
-				  `(when ,first-form
-				     (unless ,peek-p (discard-current-event ,display))
-				     (return (progn ,@rest-of-forms)))
-				;; No body forms, return the result of the test form
-				(let ((result (gensym)))
-				  `(let ((,result ,first-form))
-				     (when ,result
-				       (unless ,peek-p (discard-current-event ,display))
-				       (return ,result)))))))
-
-		       (if (member events '(otherwise t))
-			   ;; code for OTHERWISE clause.
-			   ;; Find all events NOT used by other clauses
-			   (let ((keys (do ((i 0 (1+ i))
-					    (key nil)
-					    (result nil))
-					   ((>= i *max-events*) result)
-					 (setq key (svref *event-key-vector* i))
-					 (when (and key (zerop (aref all-events i)))
-					   (push key result)))))
-			     `(otherwise
-				(binding-event-values
-				  (,display ,event-key ,(or keys :universal) ,@arglist)
-				  ,(event-clause display peek-p test-form body-forms))))
-
-			 ;; Code for normal clauses
-			 (let (true-events) ;; canonicalize event-names
-			   (if (consp events)
-			       (progn
-				 (setq true-events (mapcar #'canonicalize-event-name events))
-				 (dolist (event true-events)
-				   (setf (aref all-events (get-event-code event)) 1)))
-			     (setf true-events (canonicalize-event-name events)
-				   (aref all-events (get-event-code true-events)) 1))
-			   `(,true-events
-			     (binding-event-values
-			       (,display ,event-key ,true-events ,@arglist)
-			       ,(event-clause display peek-p test-form body-forms))))))))
-	       clauses))))))
-
-(defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body)
-  ;; Execute BODY with the variables in VALUE-LIST bound to components of the
-  ;; EVENT-KEYS events.
-  (unless (consp event-keys) (setq event-keys (list event-keys)))
-  (flet ((var-key (var) (kintern (if (consp var) (first var) var)))
-	 (var-symbol (var) (if (consp var) (second var) var)))
-    ;; VARS is an alist of:
-    ;;  (component-key ((event-key event-key ...) . extraction-code)
-    ;;		       ((event-key event-key ...) . extraction-code) ...)
-    ;; There should probably be accessor macros for this, instead of things like cdadr.
-    (let ((vars (mapcar #'list value-list))
-	  (multiple-p nil))
-      ;; Fill in the VARS alist with event-keys and extraction-code
-      (do ((keys event-keys (cdr keys))
-	   (temp nil))
-	  ((endp keys))
-	(let* ((key (car keys))
-	       (binder (case key
-			 (:universal #'universal-event-get-macro)
-			 (otherwise (svref *event-macro-vector* (get-event-code key))))))
-	  (dolist (var vars)
-	    (let ((code (funcall binder display event-key (var-key (car var)))))
-	      (unless code (warn "~a isn't a component of the ~s event"
-				 (var-key (car var)) key))
-	      (if (setq temp (member code (cdr var) :key #'cdr :test #'equal))
-		  (push key (caar temp))
-		(push `((,key) . ,code) (cdr var)))))))
-      ;; Bind all the values
-      `(let ,(mapcar #'(lambda (var)
-			 (if (cddr var) ;; if more than one binding form
-			     (progn (setq multiple-p t)
-				    (var-symbol (car var)))
-			   (list (var-symbol (car var)) (cdadr var))))
-		     vars)
-	 ;; When some values come from different places, generate code to set them
-	 ,(when multiple-p
-	    `(case ,event-key
-	       ,@(do ((keys event-keys (cdr keys))
-		      (clauses nil) ;; alist of (event-keys bindings)
-		      (clause nil nil)
-		      (temp))
-		     ((endp keys)
-		      (dolist (clause clauses)
-			(unless (cdar clause) ;; Atomize single element lists
-			  (setf (car clause) (caar clause))))
-		      clauses)
-		   ;; Gather up all the bindings associated with (car keys)
-		   (dolist (var vars)
-		     (when (cddr var) ;; when more than one binding form
-		       (dolist (events (cdr var))
-			 (when (member (car keys) (car events))
-			   ;; Optimize for event-window being the same as some other binding
-			   (if (setq temp (member (cdr events) clause
-						  :key #'caddr
-						  :test #'equal))
-			       (setq clause
-				     (nconc clause `((setq ,(car var) ,(second (car temp))))))
-			     (push `(setq ,(car var) ,(cdr events)) clause))))))
-		   ;; Merge bindings for (car keys) with other bindings
-		   (when clause
-		     (if (setq temp (member clause clauses :key #'cdr :test #'equal))
-			 (push (car keys) (caar temp))
-		       (push `((,(car keys)) . ,clause) clauses))))))
-	 ,@body))))
-
-
-;;;-----------------------------------------------------------------------------
-;;; Error Handling
-;;;-----------------------------------------------------------------------------
-
-(eval-when (eval compile load)
-(defparameter
-  *xerror-vector*
-  '#(unknown-error
-     request-error				; 1  bad request code
-     value-error				; 2  integer parameter out of range
-     window-error				; 3  parameter not a Window
-     pixmap-error				; 4  parameter not a Pixmap
-     atom-error					; 5  parameter not an Atom
-     cursor-error				; 6  parameter not a Cursor
-     font-error					; 7  parameter not a Font
-     match-error				; 8  parameter mismatch
-     drawable-error				; 9  parameter not a Pixmap or Window
-     access-error				; 10 attempt to access private resource"
-     alloc-error				; 11 insufficient resources
-     colormap-error				; 12 no such colormap
-     gcontext-error				; 13 parameter not a GContext
-     id-choice-error				; 14 invalid resource ID for this connection
-     name-error					; 15 font or color name does not exist
-     length-error				; 16 request length incorrect;
-						;    internal Xlib error
-     implementation-error			; 17 server is defective
-     ))
-)
-
-(defun make-error (display event asynchronous)
-  (declare (type display display)
-	   (type reply-buffer event)
-	   (type boolean asynchronous))
-  (reading-event (event)
-    (let* ((error-code (read-card8 1))
-	   (error-key (get-error-key display error-code))
-	   (error-decode-function (get error-key 'error-decode-function))
-	   (params (funcall error-decode-function display event)))
-      (list* error-code error-key
-	     :asynchronous asynchronous :current-sequence (display-request-number display)
-	     params))))
-
-(defun report-error (display error-code error-key &rest params)
-  (declare (type display display)
-	   (dynamic-extent params))
-  ;; All errors (synchronous and asynchronous) are processed by calling
-  ;; an error handler in the display.  The handler is called with the display
-  ;; as the first argument and the error-key as its second argument. If handler is
-  ;; an array it is expected to contain handler functions specific to
-  ;; each error; the error code is used to index the array, fetching the
-  ;; appropriate handler. Any results returned by the handler are ignored;;
-  ;; it is assumed the handler either takes care of the error completely,
-  ;; or else signals. For all core errors, additional keyword/value argument
-  ;; pairs are:
-  ;;    :major integer
-  ;;    :minor integer
-  ;;    :sequence integer
-  ;;    :current-sequence integer
-  ;;    :asynchronous (member t nil)
-  ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window
-  ;; errors another pair is:
-  ;;    :resource-id integer
-  ;; For :atom errors, another pair is:
-  ;;    :atom-id integer
-  ;; For :value errors, another pair is:
-  ;;    :value integer
-  (let* ((handler (display-error-handler display))
-	 (handler-function
-	   (if (type? handler 'sequence)
-	       (elt handler error-code)
-	     handler)))
-    (apply handler-function display error-key params)))
-
-(defun request-name (code &optional display)
-  (if (< code (length *request-names*))
-      (svref *request-names* code)
-    (dolist (extension (and display (display-extension-alist display)) "unknown")
-      (when (= code (second extension))
-	(return (first extension))))))
-
-#-(or clx-ansi-common-lisp excl lcl3.0 CMU)
-(define-condition request-error (x-error)
-  ((display :reader request-error-display)
-   (error-key :reader request-error-error-key)
-   (major :reader request-error-major)
-   (minor :reader request-error-minor)
-   (sequence :reader request-error-sequence)
-   (current-sequence :reader request-error-current-sequence)
-   (asynchronous :reader request-error-asynchronous))
-  (:report report-request-error))
-
-(defun report-request-error (condition stream)
-  (let ((error-key (request-error-error-key condition))
-	(asynchronous (request-error-asynchronous condition))
-	(major (request-error-major condition))
-	(minor (request-error-minor condition))
-	(sequence (request-error-sequence condition))
-	(current-sequence (request-error-current-sequence condition)))		   
-    (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]"
-	    asynchronous error-key (= sequence current-sequence)
-	    sequence current-sequence major minor
-	    (request-name major (request-error-display condition)))))
-
-;; Since the :report arg is evaluated as (function report-request-error) the
-;; define-condition must come after the function definition.
-#+(or clx-ansi-common-lisp excl lcl3.0 CMU)
-(define-condition request-error (x-error)
-  ((display :reader request-error-display :initarg :display)
-   (error-key :reader request-error-error-key :initarg :error-key)
-   (major :reader request-error-major :initarg :major)
-   (minor :reader request-error-minor :initarg :minor)
-   (sequence :reader request-error-sequence :initarg :sequence)
-   (current-sequence :reader request-error-current-sequence :initarg :current-sequence)
-   (asynchronous :reader request-error-asynchronous :initarg :asynchronous))
-  (:report report-request-error))
-
-(define-condition resource-error (request-error)
-  ((resource-id :reader resource-error-resource-id :initarg :resource-id))
-  (:report
-    (lambda (condition stream)
-      (report-request-error condition stream)
-      (format stream " ID #x~x" (resource-error-resource-id condition)))))  
-
-(define-condition unknown-error (request-error)
-  ((error-code :reader unknown-error-error-code :initarg :error-code))
-  (:report
-    (lambda (condition stream)
-      (report-request-error condition stream)
-      (format stream " Error Code ~d." (unknown-error-error-code condition)))))
-
-(define-condition access-error (request-error) ())
-
-(define-condition alloc-error (request-error) ())
-
-(define-condition atom-error (request-error)
-  ((atom-id :reader atom-error-atom-id :initarg :atom-id))
-  (:report
-    (lambda (condition stream)
-      (report-request-error condition stream)
-      (format stream " Atom-ID #x~x" (atom-error-atom-id condition)))))
-
-(define-condition colormap-error (resource-error) ())
-
-(define-condition cursor-error (resource-error) ())
-
-(define-condition drawable-error (resource-error) ())
-
-(define-condition font-error (resource-error) ())
-
-(define-condition gcontext-error (resource-error) ())
-
-(define-condition id-choice-error (resource-error) ())
-
-(define-condition illegal-request-error (request-error) ())
-
-(define-condition length-error (request-error) ())
-
-(define-condition match-error (request-error) ())
-
-(define-condition name-error (request-error) ())
-
-(define-condition pixmap-error (resource-error) ())
-
-(define-condition value-error (request-error)
-  ((value :reader value-error-value :initarg :value))
-  (:report
-    (lambda (condition stream)
-      (report-request-error condition stream)
-      (format stream " Value ~d." (value-error-value condition)))))
-
-(define-condition window-error (resource-error)())
-
-(define-condition implementation-error (request-error) ())
-
-;;-----------------------------------------------------------------------------
-;; Internal error conditions signaled by CLX
-
-(define-condition x-type-error (type-error x-error)
-  ((type-string :reader x-type-error-type-string :initarg :type-string))
-  (:report
-    (lambda (condition stream)
-      (format stream "~s isn't a ~a"
-	      (type-error-datum condition)
-	      (or (x-type-error-type-string condition)
-		  (type-error-expected-type condition))))))
-
-(define-condition closed-display (x-error)
-  ((display :reader closed-display-display :initarg :display))
-  (:report
-    (lambda (condition stream)
-      (format stream "Attempt to use closed display ~s"
-	      (closed-display-display condition)))))
-
-(define-condition lookup-error (x-error)
-  ((id :reader lookup-error-id :initarg :id)
-   (display :reader lookup-error-display :initarg :display)
-   (type :reader lookup-error-type :initarg :type)
-   (object :reader lookup-error-object :initarg :object))
-  (:report
-    (lambda (condition stream)
-      (format stream "ID ~d from display ~s should have been a ~s, but was ~s"
-	      (lookup-error-id condition)
-	      (lookup-error-display condition)
-	      (lookup-error-type condition)
-	      (lookup-error-object condition)))))  
-
-(define-condition connection-failure (x-error)
-  ((major-version :reader connection-failure-major-version :initarg :major-version)
-   (minor-version :reader connection-failure-minor-version :initarg :minor-version)
-   (host :reader connection-failure-host :initarg :host)
-   (display :reader connection-failure-display :initarg :display)
-   (reason :reader connection-failure-reason :initarg :reason))
-  (:report
-    (lambda (condition stream)
-      (format stream "Connection failure to X~d.~d server ~a display ~d: ~a"
-	      (connection-failure-major-version condition)
-	      (connection-failure-minor-version condition)
-	      (connection-failure-host condition)
-	      (connection-failure-display condition)
-	      (connection-failure-reason condition)))))
-  
-(define-condition reply-length-error (x-error)
-  ((reply-length :reader reply-length-error-reply-length :initarg :reply-length)
-   (expected-length :reader reply-length-error-expected-length :initarg :expected-length)
-   (display :reader reply-length-error-display :initarg :display))
-  (:report
-    (lambda (condition stream)
-      (format stream "Reply length was ~d when ~d words were expected for display ~s"
-	      (reply-length-error-reply-length condition)
-	      (reply-length-error-expected-length condition)
-	      (reply-length-error-display condition)))))  
-
-(define-condition reply-timeout (x-error)
-  ((timeout :reader reply-timeout-timeout :initarg :timeout)
-   (display :reader reply-timeout-display :initarg :display))
-  (:report
-    (lambda (condition stream)
-      (format stream "Timeout after waiting ~d seconds for a reply for display ~s"
-	      (reply-timeout-timeout condition)
-	      (reply-timeout-display condition)))))  
-
-(define-condition sequence-error (x-error)
-  ((display :reader sequence-error-display :initarg :display)
-   (req-sequence :reader sequence-error-req-sequence :initarg :req-sequence)
-   (msg-sequence :reader sequence-error-msg-sequence :initarg :msg-sequence))
-  (:report
-    (lambda (condition stream)
-      (format stream "Reply out of sequence for display ~s.~%  Expected ~d, Got ~d"
-	      (sequence-error-display condition)
-	      (sequence-error-req-sequence condition)
-	      (sequence-error-msg-sequence condition)))))  
-
-(define-condition unexpected-reply (x-error)
-  ((display :reader unexpected-reply-display :initarg :display)
-   (msg-sequence :reader unexpected-reply-msg-sequence :initarg :msg-sequence)
-   (req-sequence :reader unexpected-reply-req-sequence :initarg :req-sequence)
-   (length :reader unexpected-reply-length :initarg :length))
-  (:report
-    (lambda (condition stream)
-      (format stream "Display ~s received a server reply when none was expected.~@
-		      Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes."
-	      (unexpected-reply-display condition)
-	      (unexpected-reply-req-sequence condition)
-	      (unexpected-reply-msg-sequence condition)
-	      (unexpected-reply-length condition)))))
-
-(define-condition missing-parameter (x-error)
-  ((parameter :reader missing-parameter-parameter :initarg :parameter))
-  (:report
-    (lambda (condition stream)
-      (let ((parm (missing-parameter-parameter condition)))
-	(if (consp parm)
-	    (format stream "One or more of the required parameters ~a is missing."
-		    parm)
-	  (format stream "Required parameter ~a is missing or null." parm))))))
-
-;; This can be signalled anywhere a pseudo font access fails.
-(define-condition invalid-font (x-error)
-  ((font :reader invalid-font-font :initarg :font))
-  (:report
-    (lambda (condition stream)
-      (format stream "Can't access font ~s" (invalid-font-font condition)))))
-
-(define-condition device-busy (x-error)
-  ((display :reader device-busy-display :initarg :display))
-  (:report
-    (lambda (condition stream)
-      (format stream "Device busy for display ~s"
-	      (device-busy-display condition)))))
-
-(define-condition unimplemented-event (x-error)
-  ((display :reader unimplemented-event-display :initarg :display)
-   (event-code :reader unimplemented-event-event-code :initarg :event-code))
-  (:report
-    (lambda (condition stream)
-      (format stream "Event code ~d not implemented for display ~s"
-	      (unimplemented-event-event-code condition)
-	      (unimplemented-event-display condition)))))
-
-(define-condition undefined-event (x-error)
-  ((display :reader undefined-event-display :initarg :display)
-   (event-name :reader undefined-event-event-name :initarg :event-name))
-  (:report
-    (lambda (condition stream)
-      (format stream "Event code ~d undefined for display ~s"
-	      (undefined-event-event-name condition)
-	      (undefined-event-display condition)))))
-
-(define-condition absent-extension (x-error)
-  ((name :reader absent-extension-name :initarg :name)
-   (display :reader absent-extension-display :initarg :display))
-  (:report
-    (lambda (condition stream)
-      (format stream "Extension ~a isn't defined for display ~s"
-	      (absent-extension-name condition)
-	      (absent-extension-display condition)))))
-
-(define-condition inconsistent-parameters (x-error)
-  ((parameters :reader inconsistent-parameters-parameters :initarg :parameters))
-  (:report
-    (lambda (condition stream)
-      (format stream "inconsistent-parameters:~{ ~s~}"
-	      (inconsistent-parameters-parameters condition)))))
-
-(defun get-error-key (display error-code)
-  (declare (type display display)
-	   (type array-index error-code))
-  ;; Return the error-key associated with error-code
-  (if (< error-code (length *xerror-vector*))
-      (svref *xerror-vector* error-code)
-    ;; Search the extensions for the error
-    (dolist (entry (display-extension-alist display) 'unknown-error)
-      (let* ((event-name (first entry))
-	     (first-error (fourth entry))
-	     (errors (third (assoc event-name *extensions*))))
-	(declare (type keyword event-name)
-		 (type array-index first-error)
-		 (type list errors))
-	(when (and errors
-		   (index<= first-error error-code
-			    (index+ first-error (index- (length errors) 1))))
-	  (return (nth (index- error-code first-error) errors)))))))
-
-(defmacro define-error (error-key function)
-  ;; Associate a function with ERROR-KEY which will be called with
-  ;; parameters DISPLAY and REPLY-BUFFER and
-  ;; returns a plist of keyword/value pairs which will be passed on
-  ;; to the error handler.  A compiler warning is printed when
-  ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION.
-  ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type
-  ;;       macros for getting error fields. See DECODE-CORE-ERROR for
-  ;;       an example.
-  (declare (type symbol error-key)
-	   (type function function))
-  ;; First ensure the name is for a declared extension
-  (unless (or (find error-key *xerror-vector*)
-	      (dolist (extension *extensions*)
-		(when (member error-key (third extension))
-		  (return t))))
-    (x-type-error error-key 'error-key))
-  `(setf (get ',error-key 'error-decode-function) (function ,function)))
-
-;; All core errors use this, so we make it available to extensions.
-(defun decode-core-error (display event &optional arg)
-  ;; All core errors have the following keyword/argument pairs:
-  ;;    :major integer
-  ;;    :minor integer
-  ;;    :sequence integer
-  ;; In addition, many have an additional argument that comes from the
-  ;; same place in the event, but is named differently.  When the ARG
-  ;; argument is specified, the keyword ARG with card32 value starting
-  ;; at byte 4 of the event is returned with the other keyword/argument
-  ;; pairs.
-  (declare (type display display)
-	   (type reply-buffer event)
-	   (type (or null keyword) arg))
-  (declare (clx-values keyword/arg-plist))
-  display
-  (reading-event (event)
-    (let* ((sequence (read-card16 2))
-	   (minor-code (read-card16 8))
-	   (major-code (read-card8 10))
-	   (result (list :major major-code
-			 :minor minor-code
-			 :sequence sequence)))
-      (when arg
-	(setq result (list* arg (read-card32 4) result)))
-      result)))
-
-(defun decode-resource-error (display event)
-  (decode-core-error display event :resource-id))
-
-(define-error unknown-error
-  (lambda (display event)
-    (list* :error-code (aref (reply-ibuf8 event) 1)
-	   (decode-core-error display event))))
-
-(define-error request-error decode-core-error)		; 1  bad request code
-
-(define-error value-error				; 2  integer parameter out of range
-  (lambda (display event)
-    (decode-core-error display event :value)))
-
-(define-error window-error decode-resource-error)	; 3  parameter not a Window
-
-(define-error pixmap-error decode-resource-error)	; 4  parameter not a Pixmap
-
-(define-error atom-error				; 5  parameter not an Atom
-  (lambda (display event)
-    (decode-core-error display event :atom-id)))
-
-(define-error cursor-error decode-resource-error)	; 6  parameter not a Cursor
-
-(define-error font-error decode-resource-error)		; 7  parameter not a Font
-
-(define-error match-error decode-core-error)		; 8  parameter mismatch
-
-(define-error drawable-error decode-resource-error)	; 9  parameter not a Pixmap or Window
-
-(define-error access-error decode-core-error)		; 10 attempt to access private resource"
-
-(define-error alloc-error decode-core-error)		; 11 insufficient resources
-
-(define-error colormap-error decode-resource-error)	; 12 no such colormap
-
-(define-error gcontext-error decode-resource-error)	; 13 parameter not a GContext
-
-(define-error id-choice-error decode-resource-error)	; 14 invalid resource ID for this connection
-
-(define-error name-error decode-core-error)		; 15 font or color name does not exist
-
-(define-error length-error decode-core-error)		; 16 request length incorrect;
-							;    internal Xlib error
-
-(define-error implementation-error decode-core-error)	; 17 server is defective
diff --git a/clx/keysyms.lisp b/clx/keysyms.lisp
deleted file mode 100644
index 96d160b83c02959d110d5c747a114646226801ce..0000000000000000000000000000000000000000
--- a/clx/keysyms.lisp
+++ /dev/null
@@ -1,408 +0,0 @@
-;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*-
-
-;;; Define lisp character to keysym mappings
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-(define-keysym-set :latin-1	(keysym 0 0) (keysym 0 255))
-(define-keysym-set :latin-2	(keysym 1 0) (keysym 1 255))
-(define-keysym-set :latin-3	(keysym 2 0) (keysym 2 255))
-(define-keysym-set :latin-4	(keysym 3 0) (keysym 3 255))
-(define-keysym-set :kana	(keysym 4 0) (keysym 4 255))
-(define-keysym-set :arabic	(keysym 5 0) (keysym 5 255))
-(define-keysym-set :cryllic	(keysym 6 0) (keysym 6 255))
-(define-keysym-set :greek	(keysym 7 0) (keysym 7 255))
-(define-keysym-set :tech	(keysym 8 0) (keysym 8 255))
-(define-keysym-set :special	(keysym 9 0) (keysym 9 255))
-(define-keysym-set :publish	(keysym 10 0) (keysym 10 255))
-(define-keysym-set :apl		(keysym 11 0) (keysym 11 255))
-(define-keysym-set :hebrew	(keysym 12 0) (keysym 12 255))
-(define-keysym-set :keyboard	(keysym 255 0) (keysym 255 255))
-
-(define-keysym :character-set-switch character-set-switch-keysym)
-(define-keysym :left-shift left-shift-keysym)
-(define-keysym :right-shift right-shift-keysym)
-(define-keysym :left-control left-control-keysym)
-(define-keysym :right-control right-control-keysym)
-(define-keysym :caps-lock caps-lock-keysym)
-(define-keysym :shift-lock shift-lock-keysym)
-(define-keysym :left-meta left-meta-keysym)
-(define-keysym :right-meta right-meta-keysym)
-(define-keysym :left-alt left-alt-keysym)
-(define-keysym :right-alt right-alt-keysym)
-(define-keysym :left-super left-super-keysym)
-(define-keysym :right-super right-super-keysym)
-(define-keysym :left-hyper left-hyper-keysym)
-(define-keysym :right-hyper right-hyper-keysym)
-
-(define-keysym #\space 032)
-(define-keysym #\! 033)
-(define-keysym #\" 034)
-(define-keysym #\# 035)
-(define-keysym #\$ 036)
-(define-keysym #\% 037)
-(define-keysym #\& 038)
-(define-keysym #\' 039)
-(define-keysym #\( 040)
-(define-keysym #\) 041)
-(define-keysym #\* 042)
-(define-keysym #\+ 043)
-(define-keysym #\, 044)
-(define-keysym #\- 045)
-(define-keysym #\. 046)
-(define-keysym #\/ 047)
-(define-keysym #\0 048)
-(define-keysym #\1 049)
-(define-keysym #\2 050)
-(define-keysym #\3 051)
-(define-keysym #\4 052)
-(define-keysym #\5 053)
-(define-keysym #\6 054)
-(define-keysym #\7 055)
-(define-keysym #\8 056)
-(define-keysym #\9 057)
-(define-keysym #\: 058)
-(define-keysym #\; 059)
-(define-keysym #\< 060)
-(define-keysym #\= 061)
-(define-keysym #\> 062)
-(define-keysym #\? 063)
-(define-keysym #\@ 064)
-(define-keysym #\A 065 :lowercase 097)
-(define-keysym #\B 066 :lowercase 098)
-(define-keysym #\C 067 :lowercase 099)
-(define-keysym #\D 068 :lowercase 100)
-(define-keysym #\E 069 :lowercase 101)
-(define-keysym #\F 070 :lowercase 102)
-(define-keysym #\G 071 :lowercase 103)
-(define-keysym #\H 072 :lowercase 104)
-(define-keysym #\I 073 :lowercase 105)
-(define-keysym #\J 074 :lowercase 106)
-(define-keysym #\K 075 :lowercase 107)
-(define-keysym #\L 076 :lowercase 108)
-(define-keysym #\M 077 :lowercase 109)
-(define-keysym #\N 078 :lowercase 110)
-(define-keysym #\O 079 :lowercase 111)
-(define-keysym #\P 080 :lowercase 112)
-(define-keysym #\Q 081 :lowercase 113)
-(define-keysym #\R 082 :lowercase 114)
-(define-keysym #\S 083 :lowercase 115)
-(define-keysym #\T 084 :lowercase 116)
-(define-keysym #\U 085 :lowercase 117)
-(define-keysym #\V 086 :lowercase 118)
-(define-keysym #\W 087 :lowercase 119)
-(define-keysym #\X 088 :lowercase 120)
-(define-keysym #\Y 089 :lowercase 121)
-(define-keysym #\Z 090 :lowercase 122)
-(define-keysym #\[ 091)
-(define-keysym #\\ 092)
-(define-keysym #\] 093)
-(define-keysym #\^ 094)
-(define-keysym #\_ 095)
-(define-keysym #\` 096)
-(define-keysym #\a 097)
-(define-keysym #\b 098)
-(define-keysym #\c 099)
-(define-keysym #\d 100)
-(define-keysym #\e 101)
-(define-keysym #\f 102)
-(define-keysym #\g 103)
-(define-keysym #\h 104)
-(define-keysym #\i 105)
-(define-keysym #\j 106)
-(define-keysym #\k 107)
-(define-keysym #\l 108)
-(define-keysym #\m 109)
-(define-keysym #\n 110)
-(define-keysym #\o 111)
-(define-keysym #\p 112)
-(define-keysym #\q 113)
-(define-keysym #\r 114)
-(define-keysym #\s 115)
-(define-keysym #\t 116)
-(define-keysym #\u 117)
-(define-keysym #\v 118)
-(define-keysym #\w 119)
-(define-keysym #\x 120)
-(define-keysym #\y 121)
-(define-keysym #\z 122)
-(define-keysym #\{ 123)
-(define-keysym #\| 124)
-(define-keysym #\} 125)
-(define-keysym #\~ 126)
-
-(progn   ;; Semi-standard characters
-  (define-keysym #\rubout (keysym 255 255))	; :tty
-  (define-keysym #\tab (keysym 255 009))	; :tty
-  (define-keysym #\linefeed (keysym 255 010))	; :tty
-  (define-keysym #\page (keysym 009 227))	; :special
-  (define-keysym #\return (keysym 255 013))	; :tty
-  (define-keysym #\backspace (keysym 255 008))	; :tty
-  )
-
-#+(or lispm excl)
-(progn   ;; Nonstandard characters 
-  (define-keysym #\escape (keysym 255 027))	; :tty
-  )
-
-#+ti
-(progn
-  (define-keysym #\Inverted-exclamation-mark 161)
-  (define-keysym #\american-cent-sign 162)
-  (define-keysym #\british-pound-sign 163)
-  (define-keysym #\Currency-sign 164)
-  (define-keysym #\Japanese-yen-sign 165)
-  (define-keysym #\Yen 165)
-  (define-keysym #\Broken-bar 166)
-  (define-keysym #\Section-symbol 167)
-  (define-keysym #\Section 167)
-  (define-keysym #\Diaresis 168)
-  (define-keysym #\Umlaut 168)
-  (define-keysym #\Copyright-sign 169)
-  (define-keysym #\Copyright 169)
-  (define-keysym #\Feminine-ordinal-indicator 170)
-  (define-keysym #\Angle-quotation-left 171)
-  (define-keysym #\Soft-hyphen 173)
-  (define-keysym #\Shy 173)
-  (define-keysym #\Registered-trademark 174)
-  (define-keysym #\Macron 175)
-  (define-keysym #\Degree-sign 176)
-  (define-keysym #\Ring 176)
-  (define-keysym #\Plus-minus-sign 177)
-  (define-keysym #\Superscript-2 178)
-  (define-keysym #\Superscript-3 179)
-  (define-keysym #\Acute-accent 180)
-  (define-keysym #\Greek-mu 181)
-  (define-keysym #\Paragraph-symbol 182)
-  (define-keysym #\Paragraph 182)
-  (define-keysym #\Pilcrow-sign 182)
-  (define-keysym #\Middle-dot 183)
-  (define-keysym #\Cedilla 184)
-  (define-keysym #\Superscript-1 185)
-  (define-keysym #\Masculine-ordinal-indicator 186)
-  (define-keysym #\Angle-quotation-right 187)
-  (define-keysym #\Fraction-1/4 188)
-  (define-keysym #\One-quarter 188)
-  (define-keysym #\Fraction-1/2 189)
-  (define-keysym #\One-half 189)
-  (define-keysym #\Fraction-3/4 190)
-  (define-keysym #\Three-quarters 190)
-  (define-keysym #\Inverted-question-mark 191)
-  (define-keysym #\Multiplication-sign 215)
-  (define-keysym #\Eszet 223)
-  (define-keysym #\Division-sign 247)
-)
-
-#+ti
-(progn	;; There are no 7-bit ascii representations for the following
-        ;; European characters, so use int-char to create them to ensure
-        ;; nothing is lost while sending files through the mail.
-  (define-keysym (int-char 192) 192 :lowercase 224)
-  (define-keysym (int-char 193) 193 :lowercase 225)
-  (define-keysym (int-char 194) 194 :lowercase 226)
-  (define-keysym (int-char 195) 195 :lowercase 227)
-  (define-keysym (int-char 196) 196 :lowercase 228)
-  (define-keysym (int-char 197) 197 :lowercase 229)
-  (define-keysym (int-char 198) 198 :lowercase 230)
-  (define-keysym (int-char 199) 199 :lowercase 231)
-  (define-keysym (int-char 200) 200 :lowercase 232)
-  (define-keysym (int-char 201) 201 :lowercase 233)
-  (define-keysym (int-char 202) 202 :lowercase 234)
-  (define-keysym (int-char 203) 203 :lowercase 235)
-  (define-keysym (int-char 204) 204 :lowercase 236)
-  (define-keysym (int-char 205) 205 :lowercase 237)
-  (define-keysym (int-char 206) 206 :lowercase 238)
-  (define-keysym (int-char 207) 207 :lowercase 239)
-  (define-keysym (int-char 208) 208 :lowercase 240)
-  (define-keysym (int-char 209) 209 :lowercase 241)
-  (define-keysym (int-char 210) 210 :lowercase 242)
-  (define-keysym (int-char 211) 211 :lowercase 243)
-  (define-keysym (int-char 212) 212 :lowercase 244)
-  (define-keysym (int-char 213) 213 :lowercase 245)
-  (define-keysym (int-char 214) 214 :lowercase 246)
-  (define-keysym (int-char 215) 215)
-  (define-keysym (int-char 216) 216 :lowercase 248)
-  (define-keysym (int-char 217) 217 :lowercase 249)
-  (define-keysym (int-char 218) 218 :lowercase 250)
-  (define-keysym (int-char 219) 219 :lowercase 251)
-  (define-keysym (int-char 220) 220 :lowercase 252)
-  (define-keysym (int-char 221) 221 :lowercase 253)
-  (define-keysym (int-char 222) 222 :lowercase 254)
-  (define-keysym (int-char 223) 223)
-  (define-keysym (int-char 224) 224)
-  (define-keysym (int-char 225) 225)
-  (define-keysym (int-char 226) 226)
-  (define-keysym (int-char 227) 227)
-  (define-keysym (int-char 228) 228)
-  (define-keysym (int-char 229) 229)
-  (define-keysym (int-char 230) 230)
-  (define-keysym (int-char 231) 231)
-  (define-keysym (int-char 232) 232)
-  (define-keysym (int-char 233) 233)
-  (define-keysym (int-char 234) 234)
-  (define-keysym (int-char 235) 235)
-  (define-keysym (int-char 236) 236)
-  (define-keysym (int-char 237) 237)
-  (define-keysym (int-char 238) 238)
-  (define-keysym (int-char 239) 239)
-  (define-keysym (int-char 240) 240)
-  (define-keysym (int-char 241) 241)
-  (define-keysym (int-char 242) 242)
-  (define-keysym (int-char 243) 243)
-  (define-keysym (int-char 244) 244)
-  (define-keysym (int-char 245) 245)
-  (define-keysym (int-char 246) 246)
-  (define-keysym (int-char 247) 247)
-  (define-keysym (int-char 248) 248)
-  (define-keysym (int-char 249) 249)
-  (define-keysym (int-char 250) 250)
-  (define-keysym (int-char 251) 251)
-  (define-keysym (int-char 252) 252)
-  (define-keysym (int-char 253) 253)
-  (define-keysym (int-char 254) 254)
-  (define-keysym (int-char 255) 255)
-  )
-
-#+lispm  ;; Nonstandard characters
-(progn 
-  (define-keysym #\center-dot (keysym 183))	; :latin-1
-  (define-keysym #\down-arrow (keysym 008 254))	; :technical
-  (define-keysym #\alpha (keysym 007 225))	; :greek
-  (define-keysym #\beta (keysym 007 226))	; :greek
-  (define-keysym #\and-sign (keysym 008 222))	; :technical
-  (define-keysym #\not-sign (keysym 172))	; :latin-1
-  (define-keysym #\epsilon (keysym 007 229))	; :greek
-  (define-keysym #\pi (keysym 007 240))		; :greek
-  (define-keysym #\lambda (keysym 007 235))	; :greek
-  (define-keysym #\gamma (keysym 007 227))	; :greek
-  (define-keysym #\delta (keysym 007 228))	; :greek
-  (define-keysym #\up-arrow (keysym 008 252))	; :technical
-  (define-keysym #\plus-minus (keysym 177))	; :latin-1
-  (define-keysym #\infinity (keysym 008 194))	; :technical
-  (define-keysym #\partial-delta (keysym 008 239))	; :technical
-  (define-keysym #\left-horseshoe (keysym 011 218))	; :apl
-  (define-keysym #\right-horseshoe (keysym 011 216))	; :apl
-  (define-keysym #\up-horseshoe (keysym 011 195))	; :apl
-  (define-keysym #\down-horseshoe (keysym 011 214))	; :apl
-  (define-keysym #\double-arrow (keysym 008 205))	; :technical
-  (define-keysym #\left-arrow (keysym 008 251))	; :technical
-  (define-keysym #\right-arrow (keysym 008 253))	; :technical
-  (define-keysym #\not-equals (keysym 008 189))	; :technical
-  (define-keysym #\less-or-equal (keysym 008 188))	; :technical
-  (define-keysym #\greater-or-equal (keysym 008 190))	; :technical
-  (define-keysym #\equivalence (keysym 008 207))	; :technical
-  (define-keysym #\or-sign (keysym 008 223))	; :technical
-  (define-keysym #\integral (keysym 008 191))	; :technical
-;;  break isn't null
-;;  (define-keysym #\null (keysym 255 107))	; :function
-  (define-keysym #\clear-input (keysym 255 011))	; :tty
-  (define-keysym #\help (keysym 255 106))	; :function
-  (define-keysym #\refresh (keysym 255 097))	; :function
-  (define-keysym #\abort (keysym 255 105))	; :function
-  (define-keysym #\resume (keysym 255 098))	; :function
-  (define-keysym #\end (keysym 255 087))	; :cursor
-;;#\universal-quantifier
-;;#\existential-quantifier
-;;#\circle-plus
-;;#\circle-cross same as #\circle-x
-  )
-
-#+genera
-(progn
-;;#\network
-;;#\symbol-help
-  (define-keysym #\lozenge (keysym 009 224))	; :special
-  (define-keysym #\suspend (keysym 255 019))	; :tty
-  (define-keysym #\function (keysym 255 032))	; :function
-  (define-keysym #\square (keysym 010 231))	; :publishing
-  (define-keysym #\circle (keysym 010 230))	; :publishing
-  (define-keysym #\triangle (keysym 010 232))	; :publishing
-  (define-keysym #\scroll (keysym 255 086))	; :cursor
-  (define-keysym #\select (keysym 255 096))	; :function
-  (define-keysym #\complete (keysym 255 104))	; :function
-  )
-
-#+ti
-(progn
-  (define-keysym #\terminal (keysym 255 032))	; :function
-  (define-keysym #\system (keysym 255 096))	; :function
-  (define-keysym #\center-arrow (keysym 255 80))
-  (define-keysym #\left-arrow (keysym 255 081))	; :cursor
-  (define-keysym #\up-arrow (keysym 255 082))	; :cursor
-  (define-keysym #\right-arrow (keysym 255 083))	; :cursor
-  (define-keysym #\down-arrow (keysym 255 084))	; :cursor
-  (define-keysym #\end (keysym 255 087))	; :cursor
-  (define-keysym #\undo (keysym 255 101))	; :function
-  (define-keysym #\break (keysym 255 107))
-  (define-keysym #\keypad-space (keysym 255 128))	; :keypad
-  (define-keysym #\keypad-tab (keysym 255 137))	; :keypad
-  (define-keysym #\keypad-enter (keysym 255 141))	; :keypad
-  (define-keysym #\f1 (keysym 255 145))		; :keypad
-  (define-keysym #\f2 (keysym 255 146))		; :keypad
-  (define-keysym #\f3 (keysym 255 147))		; :keypad
-  (define-keysym #\f4 (keysym 255 148))		; :keypad
-  (define-keysym #\f1 (keysym 255 190))		; :keypad
-  (define-keysym #\f2 (keysym 255 191))		; :keypad
-  (define-keysym #\f3 (keysym 255 192))		; :keypad
-  (define-keysym #\f4 (keysym 255 193))		; :keypad
-  (define-keysym #\keypad-plus (keysym 255 171))	; :keypad
-  (define-keysym #\keypad-comma (keysym 255 172))	; :keypad
-  (define-keysym #\keypad-minus (keysym 255 173))	; :keypad
-  (define-keysym #\keypad-period (keysym 255 174))	; :keypad
-  (define-keysym #\keypad-0 (keysym 255 176))	; :keypad
-  (define-keysym #\keypad-1 (keysym 255 177))	; :keypad
-  (define-keysym #\keypad-2 (keysym 255 178))	; :keypad
-  (define-keysym #\keypad-3 (keysym 255 179))	; :keypad
-  (define-keysym #\keypad-4 (keysym 255 180))	; :keypad
-  (define-keysym #\keypad-5 (keysym 255 181))	; :keypad
-  (define-keysym #\keypad-6 (keysym 255 182))	; :keypad
-  (define-keysym #\keypad-7 (keysym 255 183))	; :keypad
-  (define-keysym #\keypad-8 (keysym 255 184))	; :keypad
-  (define-keysym #\keypad-9 (keysym 255 185))	; :keypad
-  (define-keysym #\keypad-equal (keysym 255 189))	; :keypad
-  (define-keysym #\f1 (keysym 255 192))		; :function
-  (define-keysym #\f2 (keysym 255 193))		; :function
-  (define-keysym #\f3 (keysym 255 194))		; :function
-  (define-keysym #\f4 (keysym 255 195))		; :function
-  (define-keysym #\network (keysym 255 214))
-  (define-keysym #\status (keysym 255 215))
-  (define-keysym #\clear-screen (keysym 255 217))
-  (define-keysym #\left (keysym 255 218))
-  (define-keysym #\middle (keysym 255 219))
-  (define-keysym #\right (keysym 255 220))
-  (define-keysym #\resume (keysym 255 221))
-  (define-keysym #\vt (keysym 009 233))		; :special ;; same as #\delete
-  )
-
-#+ti
-(progn  ;; Explorer specific characters
-  (define-keysym #\Call (keysym 131))		; :latin-1
-  (define-keysym #\Macro (keysym 133))		; :latin-1
-  (define-keysym #\Quote (keysym 142))		; :latin-1
-  (define-keysym #\Hold-output (keysym 143))	; :latin-1
-  (define-keysym #\Stop-output (keysym 144))	; :latin-1
-  (define-keysym #\Center (keysym 156))		; :latin-1
-  (define-keysym #\no-break-space (keysym 160))	; :latin-1
-
-  (define-keysym #\circle-plus (keysym 13))	; :latin-1
-  (define-keysym #\universal-quantifier (keysym 20))	; :latin-1
-  (define-keysym #\existential-quantifier (keysym 21))	; :latin-1
-  (define-keysym #\circle-cross (keysym 22))	; :latin-1
-  )
-
diff --git a/clx/macros.lisp b/clx/macros.lisp
deleted file mode 100644
index faf64da7b7ab8e48903ec11bd2442e821574aa4c..0000000000000000000000000000000000000000
--- a/clx/macros.lisp
+++ /dev/null
@@ -1,1090 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-;;; CLX basicly implements a very low overhead remote procedure call
-;;; to the server.  This file contains macros which generate the code
-;;; for both the client AND the server, given a specification of the
-;;; interface. This was done to eliminate errors that may occur because
-;;; the client and server code get/put bytes in different places, and
-;;; it makes it easier to extend the protocol.
-
-;;; This is built on top of BUFFER
-
-(in-package :xlib)
-
-;;; This variable is used by the required-arg macro just to satisfy compilers.
-(defvar *required-arg-dummy*)
-
-;;; An error signalling macro use to specify that keyword arguments are required.
-(defmacro required-arg (name)
-  `(progn (x-error 'missing-parameter :parameter ',name)
-	  *required-arg-dummy*))
-
-(defmacro lround (index)
-  ;; Round up to the next 32 bit boundary
-  `(the array-index (logand (index+ ,index 3) -4)))
-
-(defmacro wround (index)
-  ;; Round up to the next 16 bit boundary
-  `(the array-index (logand (index+ ,index 1) -2)))
-
-;;
-;; Data-type accessor functions
-;;
-;;   These functions translate between lisp data-types and the byte,
-;;   half-word or word that gets transmitted across the client/server
-;;   connection
-
-(defun index-increment (type)
-  ;; Given a type, return its field width in bytes
-  (let* ((name (if (consp type) (car type) type))
-	 (increment (get name 'byte-width :not-found)))
-    (when (eq increment :not-found)
-      ;; Check for TYPE in a different package
-      (when (not (eq (symbol-package name) *xlib-package*))
-	(setq name (xintern name))
-	(setq increment (get name 'byte-width :not-found)))
-      (when (eq increment :not-found)
-	(error "~s isn't a known field accessor" name)))
-    increment))
-
-(eval-when (eval compile load)
-(defun getify (name)
-  (xintern name '-get))
-
-(defun putify (name &optional predicate-p)
-  (xintern name '-put (if predicate-p '-predicating "")))
-
-					;; Use &body so zmacs indents properly
-(defmacro define-accessor (name (width) &body get-put-macros)
-  ;; The first body form defines the get macro
-  ;; The second body form defines the put macro
-  ;; The third body form is optional, and defines a put macro that does
-  ;; type checking and does a put when ok, else NIL when the type is incorrect.
-  ;; If no third body form is present, then these macros assume that
-  ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated.
-  ;; these predicating puts are used by the OR accessor.
-  (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro))
-  (when (cdddr get-put-macros)
-    (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros)))
-  (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name)))
-	(put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name))))
-    `(within-definition (,name define-accessor)
-       (setf (get ',name 'byte-width) ,(and width (floor width 8)))
-       (defmacro ,(getify name) ,(car get-macro)
-	 ,@(cdr get-macro))
-       (defmacro ,(putify name) ,(car put-macro)
-	 ,@(cdr put-macro))
-       ,@(when *type-check?*
-	   (let ((predicating-put (third get-put-macros)))
-	     (when predicating-put
-	       `((setf (get ',name 'predicating-put) t)
-		 (defmacro ,(putify name t) ,(car predicating-put)
-		   ,@(cdr predicating-put)))))))))
-) ;; End eval-when
-
-(define-accessor card32 (32)
-  ((index) `(read-card32 ,index))
-  ((index thing) `(write-card32 ,index ,thing)))
-
-(define-accessor card29 (32)
-  ((index) `(read-card29 ,index))
-  ((index thing) `(write-card29 ,index ,thing)))
-
-(define-accessor card16 (16)
-  ((index) `(read-card16 ,index))
-  ((index thing) `(write-card16 ,index ,thing)))
-
-(define-accessor card8 (8)
-  ((index) `(read-card8 ,index))
-  ((index thing) `(write-card8 ,index ,thing)))
-
-(define-accessor integer (32)
-  ((index) `(read-int32 ,index))
-  ((index thing) `(write-int32 ,index ,thing)))
-
-(define-accessor int16 (16)
-  ((index) `(read-int16 ,index))
-  ((index thing) `(write-int16 ,index ,thing)))
-
-(define-accessor rgb-val (16)
-  ;; Used for color's
-  ((index) `(card16->rgb-val (read-card16 ,index)))
-  ((index thing) `(write-card16 ,index (rgb-val->card16 ,thing))))
-
-(define-accessor angle (16)
-  ;; Used for drawing arcs
-  ((index) `(int16->radians (read-int16 ,index)))
-  ((index thing) `(write-int16 ,index (radians->int16 ,thing))))
-
-(define-accessor bit (0)
-  ;; Like BOOLEAN, but tests bits
-  ;; only used by declare-event (:enter-notify :leave-notify)
-  ((index bit)
-   `(logbitp ,bit (read-card8 ,index)))
-  ((index thing bit)
-   (if (zerop bit)
-       `(write-card8 ,index (if ,thing 1 0))
-     `(write-card8 ,index (dpb (if ,thing 1 0) (byte 1 ,bit) (read-card8 ,index))))))
-
-(define-accessor boolean (8)
-  ((index)
-   `(plusp (read-card8 ,index)))
-  ((index thing) `(write-card8 ,index (if ,thing 1 0))))
-
-(define-accessor drawable (32)
-  ((index &optional (buffer '%buffer))
-   `(lookup-drawable ,buffer (read-card29 ,index)))
-  ((index thing) `(write-card29 ,index (drawable-id ,thing))))
-
-(define-accessor window (32)
-  ((index &optional (buffer '%buffer))
-   `(lookup-window ,buffer (read-card29 ,index)))
-  ((index thing) `(write-card29 ,index (window-id ,thing))))
-
-(define-accessor pixmap (32)
-  ((index &optional (buffer '%buffer))
-   `(lookup-pixmap ,buffer (read-card29 ,index)))
-  ((index thing) `(write-card29 ,index (pixmap-id ,thing))))
-
-(define-accessor gcontext (32)
-  ((index &optional (buffer '%buffer))
-   `(lookup-gcontext ,buffer (read-card29 ,index)))
-  ((index thing) `(write-card29 ,index (gcontext-id ,thing))))
-
-(define-accessor cursor (32)
-  ((index &optional (buffer '%buffer))
-   `(lookup-cursor ,buffer (read-card29 ,index)))
-  ((index thing) `(write-card29 ,index (cursor-id ,thing))))
-
-(define-accessor colormap (32)
-  ((index &optional (buffer '%buffer))
-   `(lookup-colormap ,buffer (read-card29 ,index)))
-  ((index thing) `(write-card29 ,index (colormap-id ,thing))))
-
-(define-accessor font (32)
-  ((index &optional (buffer '%buffer))
-   `(lookup-font ,buffer (read-card29 ,index)))
-  ;; The FONT-ID accessor may make a OpenFont request.  Since we don't support recursive
-  ;; with-buffer-request, issue a compile time error, rather than barf at run-time.
-  ((index thing)
-   (declare (ignore index thing))
-   (error "FONT-ID must be called OUTSIDE with-buffer-request.  Use RESOURCE-ID instead.")))
-
-;; Needed to get and put xatom's in events
-(define-accessor keyword (32)
-  ((index &optional (buffer '%buffer))
-   `(atom-name ,buffer (read-card29 ,index)))
-  ((index thing &key (buffer '%buffer))
-   `(write-card29 ,index (or (atom-id ,thing ,buffer)
-			     (error "CLX implementation error in KEYWORD-PUT")))))
-
-(define-accessor resource-id (32)
-  ((index) `(read-card29 ,index))
-  ((index thing) `(write-card29 ,index ,thing)))
-
-(define-accessor resource-id-or-nil (32)
-  ((index) (let ((id (gensym)))
-	     `(let ((,id (read-card29 ,index)))
-		(and (plusp ,id) ,id))))
-  ((index thing) `(write-card29 ,index (or ,thing 0))))
-
-(defmacro char-info-get (index)
-  `(make-char-info
-     :left-bearing (int16-get ,index)
-     :right-bearing (int16-get ,(+ index 2))
-     :width	   (int16-get ,(+ index 4))
-     :ascent	   (int16-get ,(+ index 6))
-     :descent	   (int16-get ,(+ index 8))
-     :attributes   (card16-get ,(+ index 10))))
-
-(define-accessor member8 (8)
-  ((index &rest keywords)
-   (let ((value (gensym)))
-     `(let ((,value (read-card8 ,index)))
-	(declare (type (integer 0 (,(length keywords))) ,value))
-	(type-check ,value (integer 0 (,(length keywords))))
-	(svref ',(apply #'vector keywords) ,value))))
-  ((index thing &rest keywords)
-   `(write-card8 ,index (position ,thing
-				  #+lispm ',keywords ;; Lispm's prefer lists
-				  #-lispm (the simple-vector ',(apply #'vector keywords))
-				  :test #'eq)))
-  ((index thing &rest keywords)
-   (let ((value (gensym)))
-     `(let ((,value (position ,thing
-			      #+lispm ',keywords
-			      #-lispm (the simple-vector ',(apply #'vector keywords))
-			      :test #'eq)))
-	(and ,value (write-card8 ,index ,value))))))
-
-(define-accessor member16 (16)
-  ((index &rest keywords)
-   (let ((value (gensym)))
-     `(let ((,value (read-card16 ,index)))
-	(declare (type (integer 0 (,(length keywords))) ,value))
-	(type-check ,value (integer 0 (,(length keywords))))
-	(svref ',(apply #'vector keywords) ,value))))
-  ((index thing &rest keywords)
-   `(write-card16 ,index (position ,thing
-				   #+lispm ',keywords ;; Lispm's prefer lists
-				   #-lispm (the simple-vector ',(apply #'vector keywords))
-				   :test #'eq)))
-  ((index thing &rest keywords)
-   (let ((value (gensym)))
-     `(let ((,value (position ,thing
-			      #+lispm ',keywords
-			      #-lispm (the simple-vector ',(apply #'vector keywords))
-			      :test #'eq)))
-	(and ,value (write-card16 ,index ,value))))))
-
-(define-accessor member (32)
-  ((index &rest keywords)
-   (let ((value (gensym)))
-     `(let ((,value (read-card29 ,index)))
-	(declare (type (integer 0 (,(length keywords))) ,value))
-	(type-check ,value (integer 0 (,(length keywords))))
-	(svref ',(apply #'vector keywords) ,value))))
-  ((index thing &rest keywords)
-   `(write-card29 ,index (position ,thing
-				   #+lispm ',keywords ;; Lispm's prefer lists
-				   #-lispm (the simple-vector ',(apply #'vector keywords))
-				   :test #'eq)))
-  ((index thing &rest keywords)
-   (if (cdr keywords) ;; IF more than one
-       (let ((value (gensym)))
-	 `(let ((,value (position ,thing
-				  #+lispm ',keywords
-				  #-lispm (the simple-vector ',(apply #'vector keywords))
-				  :test #'eq)))
-	    (and ,value (write-card29 ,index ,value))))
-       `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0)))))
-
-(deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list)))
-
-(define-accessor member-vector (32)
-  ((index membership-vector)
-   `(member-get ,index ,@(coerce (eval membership-vector) 'list)))
-  ((index thing membership-vector)
-   `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
-  ((index thing membership-vector)
-   `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
-
-(define-accessor member16-vector (16)
-  ((index membership-vector)
-   `(member16-get ,index ,@(coerce (eval membership-vector) 'list)))
-  ((index thing membership-vector)
-   `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
-  ((index thing membership-vector)
-   `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
-
-(define-accessor member8-vector (8)
-  ((index membership-vector)
-   `(member8-get ,index ,@(coerce (eval membership-vector) 'list)))
-  ((index thing membership-vector)
-   `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
-  ((index thing membership-vector)
-   `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
-
-(define-accessor boole-constant (32)
-  ;; this isn't member-vector because we need eql instead of eq
-  ((index)
-   (let ((value (gensym)))
-     `(let ((,value (read-card29 ,index)))
-	(declare (type (integer 0 (,(length *boole-vector*))) ,value))
-	(type-check ,value (integer 0 (,(length *boole-vector*))))
-	(svref *boole-vector* ,value))))
-  ((index thing)
-   `(write-card29 ,index (position ,thing (the simple-vector *boole-vector*))))
-  ((index thing)
-   (let ((value (gensym)))
-     `(let ((,value (position ,thing (the simple-vector *boole-vector*))))
-	(and ,value (write-card29 ,index ,value))))))
-
-(define-accessor null (32)
-  ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index)))
-  ((index value) (declare (ignore value)) `(write-card32 ,index 0)))
-
-(define-accessor pad8 (8)
-  ((index) (declare (ignore index)) nil)
-  ((index value) (declare (ignore index value))  nil))
-
-(define-accessor pad16 (16)
-  ((index) (declare (ignore index)) nil)
-  ((index value) (declare (ignore index value)) nil))
-
-(define-accessor bit-vector256 (256)
-  ;; used for key-maps
-  ;; REAL-INDEX parameter provided so the default index can be over-ridden.
-  ;; This is needed for the :keymap-notify event where the keymap overlaps
-  ;; the window id.
-  ((index &optional (real-index index) data)
-   `(read-bitvector256 buffer-bbuf ,real-index ,data))
-  ((index map &optional (real-index index) (buffer '%buffer))
-   `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map)))
-   
-(define-accessor string (nil)
-  ((length index &key reply-buffer)
-   `(read-sequence-char
-      ,(or reply-buffer '%reply-buffer) 'string ,length nil nil 0 ,index))
-  ((index string &key buffer (start 0) end header-length appending)
-   (unless buffer (setq buffer '%buffer))
-   (unless header-length (setq header-length (lround index)))
-   (let* ((real-end (if appending (or end `(length ,string)) (gensym)))
-	  (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length)
-				      ,string ,start ,real-end)))
-     (if appending
-	 form
-       `(let ((,real-end ,(or end `(length ,string))))
-	  (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4))
-	  ,form)))))
-
-(define-accessor sequence (nil)
-  ((&key length (format 'card32) result-type transform reply-buffer data index start)
-   `(,(ecase format
-	(card8 'read-sequence-card8)
-	(int8 'read-sequence-int8)
-	(card16 'read-sequence-card16)
-	(int16 'read-sequence-int16)
-	(card32 'read-sequence-card32)
-	(int32 'read-sequence-int32))
-     ,(or reply-buffer '%reply-buffer)
-     ,result-type ,length ,transform ,data
-     ,@(when (or start index) `(,(or start 0)))
-     ,@(when index `(,index))))
-  ((index data &key (format 'card32) (start 0) end transform buffer appending)
-   (unless buffer (setq buffer '%buffer))
-   (let* ((real-end (if appending (or end `(length ,data)) (gensym)))
-	  (writer (xintern 'write-sequence- format))
-	  (form `(,writer ,buffer (index+ buffer-boffset ,(lround index))
-		  ,data ,start ,real-end ,transform)))
-     (flet ((maker (size)
-	      (if appending
-		  form
-		  (let ((idx `(index- ,real-end ,start)))
-		    (unless (= size 1)
-		      (setq idx `(index-ceiling ,idx ,size)))
-		    `(let ((,real-end ,(or end `(length ,data))))
-		       (write-card16 2 (index+ ,idx ,(index-ceiling index 4)))
-		       ,form)))))
-       (ecase format
-	 ((card8 int8)
-	  (maker 4))
-	 ((card16 int16 char2b)
-	  (maker 2))
-	 ((card32 int32)
-	  (maker 1)))))))
-
-(defmacro client-message-event-get-sequence ()
-  '(let* ((format (read-card8 1))
- 	  (sequence (make-array (ceiling 160 format)
-				:element-type `(unsigned-byte ,format))))
-     (declare (type (member 8 16 32) format))
-     (do ((i 12)
-	  (j 0 (index1+ j)))
-	 ((>= i 32))
-       (case format
-	 (8 (setf (aref sequence j) (read-card8 i))
-	    (index-incf i))
-	 (16 (setf (aref sequence j) (read-card16 i))
-	     (index-incf i 2))
-	 (32 (setf (aref sequence j) (read-card32 i))
-	     (index-incf i 4))))
-     sequence))
-
-(defmacro client-message-event-put-sequence (format sequence)
-  `(ecase ,format
-     (8  (sequence-put 12 ,sequence
-		       :format card8
-		       :end (min (length ,sequence) 20)
-		       :appending t))
-     (16 (sequence-put 12 ,sequence
-		       :format card16
-		       :end (min (length ,sequence) 10)
-		       :appending t))
-     (32 (sequence-put 12 ,sequence
-		       :format card32
-		       :end (min (length ,sequence) 5)
-		       :appending t))))
-
-;; Used only in declare-event
-(define-accessor client-message-sequence (160)
-  ((index format) (declare (ignore index format)) `(client-message-event-get-sequence))
-  ((index value format) (declare (ignore index))
-   `(client-message-event-put-sequence ,format ,value)))
-
-
-;;;
-;;; Compound accessors
-;;;    Accessors that take other accessors as parameters
-;;;
-(define-accessor code (0)
-  ((index) (declare (ignore index)) '(read-card8 0))
-  ((index value) (declare (ignore index)) `(write-card8 0 ,value))
-  ((index value) (declare (ignore index)) `(write-card8 0 ,value)))
-
-(define-accessor length (0)
-  ((index) (declare (ignore index)) '(read-card16 2))
-  ((index value) (declare (ignore index)) `(write-card16 2 ,value))
-  ((index value) (declare (ignore index)) `(write-card16 2 ,value)))
-
-(deftype data () 'card8)
-
-(define-accessor data (0)
-  ;; Put data in byte 1 of the reqeust
-  ((index &optional stuff) (declare (ignore index))
-   (if stuff
-       (if (consp stuff)
-	   `(,(getify (car stuff)) 1 ,@(cdr stuff))
-	 `(,(getify stuff) 1))
-     `(read-card8 1)))
-  ((index thing &optional stuff)
-   (if stuff
-       (if (consp stuff)
-	   `(macrolet ((write-card32 (index value) index value))
-	      (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff))))
-	 `(,(putify stuff) 1 ,thing))
-     `(write-card8 1 ,thing)))
-  ((index thing &optional stuff)
-   (if stuff
-       `(and (type? ,thing ',stuff)
-	     ,(if (consp stuff)
-		  `(macrolet ((write-card32 (index value) index value))
-		     (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff))))
-		`(,(putify stuff) 1 ,thing)))
-     `(and (type? ,thing 'card8) (write-card8 1 ,thing)))))
-
-;; Macroexpand the result of OR-GET to allow the macros file to not be loaded
-;; when using event-case.  This is pretty gross.
-
-(defmacro or-expand (&rest forms &environment environment)
-  `(cond ,@(mapcar #'(lambda (forms)
-		       (mapcar #'(lambda (form)
-				   (clx-macroexpand form environment))
-			       forms))
-		   forms)))
-
-;;
-;; the OR type
-;;
-(define-accessor or (32)
-  ;; Select from among several types (usually NULL and something else)
-  ((index &rest type-list &environment environment)
-   (do ((types type-list (cdr types))
-	(value (gensym))
-	(result))
-       ((endp types)
-	`(let ((,value (read-card32 ,index)))
-	   (macrolet ((read-card32 (index) index ',value)
-		      (read-card29 (index) index ',value))
-	     ,(clx-macroexpand `(or-expand ,@(nreverse result)) environment))))
-     (let ((item (car types))
-	   (args nil))
-       (when (consp item)
-	 (setq args (cdr item)
-	       item (car item)))
-       (if (eq item 'null)  ;; Special case for NULL
-	   (push `((zerop ,value) nil) result)
-	 (push
-	   `((,(getify item) ,index ,@args))
-	   result)))))
-
-  ((index value &rest type-list)
-   (do ((types type-list (cdr types))
-	(result))
-       ((endp types)
-	`(cond ,@(nreverse result)
-	       ,@(when *type-check?*
-		   `((t (x-type-error ,value '(or ,@type-list)))))))
-     (let* ((type (car types))
-	    (type-name type)
-	    (args nil))
-       (when (consp type)
-	 (setq args (cdr type)
-	       type-name (car type)))
-       (push
-	 `(,@(cond ((get type-name 'predicating-put) nil)
-		   ((or *type-check?* (cdr types)) `((type? ,value ',type)))
-		   (t '(t)))
-	   (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args))
-	 result)))))
-
-;;
-;; the MASK type...
-;;     is used to specify a subset of a collection of "optional" arguments.
-;;     A mask type consists of a 32 bit mask word followed by a word for each one-bit
-;;     in the mask.  The MASK type is ALWAYS the LAST item in a request.
-;;
-(setf (get 'mask 'byte-width) nil)
-
-(defun mask-get (index type-values body-function)
-  (declare (type function body-function)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent body-function)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg body-function))
-  ;; This is a function, because it must return more than one form (called by get-put-items)
-  ;; Functions that use this must have a binding for %MASK
-  (let* ((bit 0)
-	 (result
-	   (mapcar
-	     #'(lambda (form)
-		 (if (atom form)
-		     form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs
-		   (prog1
-		     `(when (logbitp ,bit %mask)
-			;; Execute form when bit is set
-			,form)
-		     (incf bit))))
-	     (get-put-items
-	       (+ index 4) type-values nil
-	       #'(lambda (type index item args)
-		   (declare (ignore index))
-		   (funcall body-function type '(* (incf %index) 4) item args))))))
-    ;; First form must load %MASK
-    `(,@(when (atom (car result))
-	  (list (pop result)))
-      (progn (setq %mask (read-card32 ,index))
-	     (setq %index ,(ceiling index 4))
-	     ,(car result))
-      ,@(cdr result))))
-
-;; MASK-PUT 
-
-(defun mask-put (index type-values body-function)
-  (declare (type function body-function)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent body-function)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg body-function))
-  ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES
-  ;; A 32 bit value follows for each non-nil value.
-  `((let ((%mask 0)
-	  (%index ,index))
-      ,@(let ((bit 1))
-	  (get-put-items
-	    index type-values t 
-	    #'(lambda (type index item args)
-		(declare (ignore index))
-		(if (or (symbolp item) (constantp item))
-		    `((unless (null ,item)
-			(setq %mask (logior %mask ,(shiftf bit (ash bit 1))))
-			,@(funcall body-function type
-				   `(index-incf %index 4) item args)))
-		  `((let ((.item. ,item))
-		      (unless (null .item.)
-			(setq %mask (logior %mask ,(shiftf bit (ash bit 1))))
-			,@(funcall body-function type
-				   `(index-incf %index 4) '.item. args))))))))
-      (write-card32 ,index %mask)
-      (write-card16 2 (index-ceiling (index-incf %index 4) 4))
-      (incf (buffer-boffset %buffer) %index))))
-
-(define-accessor progn (nil)
-  ;; Catch-all for inserting random code
-  ;; Note that code using this is then responsible for setting the request length
-  ((index statement) (declare (ignore index)) statement)
-  ((index statement) (declare (ignore index)) statement))
-
-
-;
-; Wrapper macros, for use around the above
-;
-(defmacro type-check (value type)
-  value type
-  (when *type-check?*
-    `(unless (type? ,value ,type)
-       (x-type-error ,value ,type))))
-
-(defmacro check-put (index value type &rest args &environment env)
-  (let* ((var (if (or (symbolp value) (constantp value)) value '.value.))
-	 (body
-	   (if (or (null (macroexpand `(type-check ,var ',type) env))
-		   (member type '(or progn pad8 pad16))
-		   (constantp value))
-	       `(,(putify type) ,index ,var ,@args)
-	     ;; Do type checking
-	     (if (get type 'predicating-put)
-		 `(or (,(putify type t) ,index ,var ,@args)
-		      (x-type-error ,var ',(if args `(,type ,@args) type)))
-	       `(if (type? ,var ',type)
-		    (,(putify type) ,index ,var ,@args)
-		  (x-type-error ,var ',(if args `(,type ,@args) type)))))))
-    (if (eq var value)
-	body
-      `(let ((,var ,value))
-	 ,body))))
-
-(defun get-put-items (index type-args putp &optional body-function)
-  (declare (type (or null function) body-function)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent body-function)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg body-function))
-  ;; Given a lists of the form (type item item ... item)
-  ;; Calls body-function with four arguments, a function name,
-  ;; index, item name, and optional arguments.
-  ;; The results are appended together and retured.
-  (unless body-function
-    (setq body-function
-	  #'(lambda (type index item args)
-	      `((check-put ,index ,item ,type ,@args)))))
-  (do* ((items type-args (cdr items))
-	(type (caar items) (caar items))
-	(args nil nil)
-	(result nil)
-	(sizes nil))
-       ((endp items) (values result index sizes))
-    (when (consp type)
-      (setq args (cdr type)
-	    type (car type)))
-    (cond ((member type '(return buffer)))
-	  ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values
-	   (setq result
-		 (append result (if putp
-				    (mask-put index (cdar items) body-function)
-				  (mask-get index (cdar items) body-function)))
-		 index nil))
-	  (t (do* ((item (cdar items) (cdr item))
-		   (increment (index-increment type)))
-		  ((endp item))
-	       (when (constantp index)
-		 (case increment		;Round up index when needed
-		   (2 (setq index (wround index)))
-		   (4 (setq index (lround index)))))
-	       (setq result
-		     (append result (funcall body-function type index (car item) args)))
-	       (when (constantp index)
-		 ;; Variable length requests have null length increment.
-		 ;; Variable length requests set the request size 
-		 ;; & maintain buffer pointers
-		 (if (null increment) 
-		     (setq index nil)
-		   (progn
-		     (incf index increment)
-		     (when (and increment (zerop increment)) (setq increment 1))
-		     (pushnew (* increment 8) sizes)))))))))
-
-(defmacro with-buffer-request-internal
-	  ((buffer opcode &key length sizes &allow-other-keys)
-	   &body type-args)
-  (multiple-value-bind (code index item-sizes)
-      (get-put-items 4 type-args t)
-    (let ((length (if length `(index+ ,length *requestsize*) '*requestsize*))
-	  (sizes (remove-duplicates (append '(8 16) item-sizes sizes))))
-      `(with-buffer-output (,buffer :length ,length :sizes ,sizes)
-	 (setf (buffer-last-request ,buffer) buffer-boffset)
-	 (write-card8 0 ,opcode)	   ;; Stick in the opcode
-	 ,@code
-	 ,@(when index
-	     (setq index (lround index))
-	     `((write-card16 2 ,(ceiling index 4))
-	       (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index))))
-	 (buffer-new-request-number ,buffer)))))
-
-(defmacro with-buffer-request
-	  ((buffer opcode &rest options &key inline gc-force &allow-other-keys)
-	   &body type-args &environment env)
-  (if (and (null inline) (macroexpand '(use-closures) env))
-      `(flet ((.request-body. (.display.)
-		(declare (type display .display.))
-		(with-buffer-request-internal (.display. ,opcode ,@options)
-		  ,@type-args)))
-	 #+clx-ansi-common-lisp
-	 (declare (dynamic-extent #'.request-body.))
-	 (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn)
-	       'with-buffer-request-function-nolock
-	     'with-buffer-request-function)
-	  ,buffer ,gc-force #'.request-body.))
-    `(let ((.display. ,buffer))
-       (declare (type display .display.))
-       (with-buffer (.display.)
-	 ,@(when gc-force `((force-gcontext-changes-internal ,gc-force)))
-	 (multiple-value-prog1
-	   (without-aborts 
-	     (with-buffer-request-internal (.display. ,opcode ,@options)
-	       ,@type-args))
-	   (display-invoke-after-function .display.))))))
-
-(defmacro with-buffer-request-and-reply
-	  ((buffer opcode reply-size &key sizes multiple-reply inline)
-	   type-args &body reply-forms &environment env)
-  (declare (indentation 0 4 1 4 2 1))
-  (let* ((inner-reply-body
-	   `(with-buffer-input (.reply-buffer. :display .display.
-					       ,@(and sizes (list :sizes sizes)))
-	      nil ,@reply-forms))
-	 (reply-body
-	   (if (or (not (symbolp reply-size)) (constantp reply-size))
-	       inner-reply-body
-	     `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.))))
-		(declare (type array-index ,reply-size))
-		,inner-reply-body))))
-    (if (and (null inline) (macroexpand '(use-closures) env))
-	`(flet ((.request-body. (.display.)
-		  (declare (type display .display.))
-		  (with-buffer-request-internal (.display. ,opcode)
-		    ,@type-args))
-		(.reply-body. (.display. .reply-buffer.)
-		  (declare (type display .display.)
-			   (type reply-buffer .reply-buffer.))
-		  (progn .display. .reply-buffer. nil)
-		  ,reply-body))
-	   #+clx-ansi-common-lisp
-	   (declare (dynamic-extent #'.request-body. #'.reply-body.))
-	   (with-buffer-request-and-reply-function
-	     ,buffer ,multiple-reply #'.request-body. #'.reply-body.))
-      `(let ((.display. ,buffer)
-	     (.pending-command. nil)
-	     (.reply-buffer. nil))
-	 (declare (type display .display.)
-		  (type (or null pending-command) .pending-command.)
-		  (type (or null reply-buffer) .reply-buffer.))
-	 (unwind-protect
-	     (progn 
-	       (with-buffer (.display.)
-		 (setq .pending-command. (start-pending-command .display.))
-		 (without-aborts
-		   (with-buffer-request-internal (.display. ,opcode)
-		     ,@type-args))
-		 (buffer-force-output .display.)
-		 (display-invoke-after-function .display.))
-	       ,@(if multiple-reply
-		     `((loop
-			 (setq .reply-buffer. (read-reply .display. .pending-command.))
-			 (when ,reply-body (return nil))
-			 (deallocate-reply-buffer (shiftf .reply-buffer. nil))))
-		   `((setq .reply-buffer. (read-reply .display. .pending-command.))
-		     ,reply-body)))
-	   (when .reply-buffer.
-	     (deallocate-reply-buffer .reply-buffer.))
-	   (when .pending-command.
-	     (stop-pending-command .display. .pending-command.)))))))
-
-(defmacro compare-request ((index) &body body)
-  `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index)))
-	      (write-int32 (index item) `(= ,item (read-int32 ,index)))
-	      (write-card29 (index item) `(= ,item (read-card29 ,index)))
-	      (write-int29 (index item) `(= ,item (read-int29 ,index)))
-	      (write-card16 (index item) `(= ,item (read-card16 ,index)))
-	      (write-int16 (index item) `(= ,item (read-int16 ,index)))
-	      (write-card8 (index item) `(= ,item (read-card8 ,index)))
-	      (write-int8 (index item) `(= ,item (read-int8 ,index))))
-     (macrolet ((type-check (value type) value type nil))
-       (and ,@(get-put-items index body t)))))
-
-(defmacro put-items ((index) &body body)
-  `(progn ,@(get-put-items index body t)))
-
-(defmacro decode-type (type value)
-  ;; Given an integer and type, return the value
-  (let ((args nil))
-    (when (consp type)
-      (setq args (cdr type)
-	    type (car type)))
-    `(macrolet ((read-card29 (value) value)
-		(read-card32 (value) value)
-		(read-int32 (value) `(card32->int32 ,value))
-		(read-card16 (value) value)
-		(read-int16 (value) `(card16->int16 ,value))
-		(read-card8 (value) value)
-		(read-int8 (value) `(int8->card8 ,value)))
-       (,(getify type) ,value ,@args))))
-
-(defmacro encode-type (type value)
-  ;; Given a value and type, return an integer
-  ;; When check-p, do type checking on value
-  (let ((args nil))
-    (when (consp type)
-      (setq args (cdr type)
-	    type (car type)))
-    `(macrolet ((write-card29 (index value) index value)
-		(write-card32 (index value) index value)
-		(write-int32 (index value) index `(int32->card32 ,value))
-		(write-card16 (index value) index value)
-		(write-int16 (index value) index `(int16->card16 ,value))
-		(write-card8 (index value) index value)
-		(write-int8 (index value) index `(int8->card8 ,value)))
-       (check-put 0 ,value ,type ,@args))))
-
-(defmacro set-decode-type (type accessor value)
-  `(setf ,accessor (encode-type ,type ,value)))
-(defsetf decode-type set-decode-type)
-
-
-;;;
-;;; Request codes
-;;; 
-
-(defconstant *x-createwindow*                  1)
-(defconstant *x-changewindowattributes*        2)
-(defconstant *x-getwindowattributes*           3)
-(defconstant *x-destroywindow*                 4)
-(defconstant *x-destroysubwindows*             5)  
-(defconstant *x-changesaveset*                 6)
-(defconstant *x-reparentwindow*                7)
-(defconstant *x-mapwindow*                     8)
-(defconstant *x-mapsubwindows*                 9)
-(defconstant *x-unmapwindow*                  10)
-(defconstant *x-unmapsubwindows*              11) 
-(defconstant *x-configurewindow*              12)
-(defconstant *x-circulatewindow*              13)
-(defconstant *x-getgeometry*                  14)
-(defconstant *x-querytree*                    15)
-(defconstant *x-internatom*                   16)
-(defconstant *x-getatomname*                  17)
-(defconstant *x-changeproperty*               18)
-(defconstant *x-deleteproperty*               19)
-(defconstant *x-getproperty*                  20)
-(defconstant *x-listproperties*               21)
-(defconstant *x-setselectionowner*            22)  
-(defconstant *x-getselectionowner*            23) 
-(defconstant *x-convertselection*             24)
-(defconstant *x-sendevent*                    25)
-(defconstant *x-grabpointer*                  26)
-(defconstant *x-ungrabpointer*                27)
-(defconstant *x-grabbutton*                   28)
-(defconstant *x-ungrabbutton*                 29)
-(defconstant *x-changeactivepointergrab*      30)         
-(defconstant *x-grabkeyboard*                 31)
-(defconstant *x-ungrabkeyboard*               32)
-(defconstant *x-grabkey*                      33)
-(defconstant *x-ungrabkey*                    34)
-(defconstant *x-allowevents*                  35)
-(defconstant *x-grabserver*                   36)     
-(defconstant *x-ungrabserver*                 37)       
-(defconstant *x-querypointer*                 38)       
-(defconstant *x-getmotionevents*              39)          
-(defconstant *x-translatecoords*              40)               
-(defconstant *x-warppointer*                  41)      
-(defconstant *x-setinputfocus*                42)        
-(defconstant *x-getinputfocus*                43)        
-(defconstant *x-querykeymap*                  44)      
-(defconstant *x-openfont*                     45)   
-(defconstant *x-closefont*                    46)    
-(defconstant *x-queryfont*                    47)
-(defconstant *x-querytextextents*             48)    
-(defconstant *x-listfonts*                    49) 
-(defconstant *x-listfontswithinfo*    	      50)
-(defconstant *x-setfontpath*                  51)
-(defconstant *x-getfontpath*                  52)
-(defconstant *x-createpixmap*                 53)      
-(defconstant *x-freepixmap*                   54)   
-(defconstant *x-creategc*                     55)
-(defconstant *x-changegc*                     56)
-(defconstant *x-copygc*                       57)
-(defconstant *x-setdashes*                    58)  
-(defconstant *x-setcliprectangles*            59)         
-(defconstant *x-freegc*                       60)
-(defconstant *x-cleartobackground*            61)          
-(defconstant *x-copyarea*                     62)
-(defconstant *x-copyplane*                    63)
-(defconstant *x-polypoint*                    64)
-(defconstant *x-polyline*                     65)
-(defconstant *x-polysegment*                  66)  
-(defconstant *x-polyrectangle*                67)   
-(defconstant *x-polyarc*                      68)
-(defconstant *x-fillpoly*                     69)
-(defconstant *x-polyfillrectangle*            70)        
-(defconstant *x-polyfillarc*                  71) 
-(defconstant *x-putimage*                     72)
-(defconstant *x-getimage*                     73)
-(defconstant *x-polytext8*                    74)   
-(defconstant *x-polytext16*                   75)   
-(defconstant *x-imagetext8*                   76)  
-(defconstant *x-imagetext16*                  77)  
-(defconstant *x-createcolormap*               78)    
-(defconstant *x-freecolormap*                 79) 
-(defconstant *x-copycolormapandfree*          80)       
-(defconstant *x-installcolormap*              81)  
-(defconstant *x-uninstallcolormap*            82)   
-(defconstant *x-listinstalledcolormaps*       83)       
-(defconstant *x-alloccolor*                   84)
-(defconstant *x-allocnamedcolor*              85)    
-(defconstant *x-alloccolorcells*              86)   
-(defconstant *x-alloccolorplanes*             87)   
-(defconstant *x-freecolors*                   88)
-(defconstant *x-storecolors*                  89)
-(defconstant *x-storenamedcolor*              90)   
-(defconstant *x-querycolors*                  91)
-(defconstant *x-lookupcolor*                  92)
-(defconstant *x-createcursor*                 93)
-(defconstant *x-createglyphcursor*            94)    
-(defconstant *x-freecursor*                   95)
-(defconstant *x-recolorcursor*                96)  
-(defconstant *x-querybestsize*                97) 
-(defconstant *x-queryextension*               98) 
-(defconstant *x-listextensions*               99)
-(defconstant *x-setkeyboardmapping*           100)
-(defconstant *x-getkeyboardmapping*           101)
-(defconstant *x-changekeyboardcontrol*        102)               
-(defconstant *x-getkeyboardcontrol*           103)           
-(defconstant *x-bell*                         104)
-(defconstant *x-changepointercontrol*         105)
-(defconstant *x-getpointercontrol*            106)
-(defconstant *x-setscreensaver*               107)         
-(defconstant *x-getscreensaver*               108)        
-(defconstant *x-changehosts*                  109)    
-(defconstant *x-listhosts*                    110) 
-(defconstant *x-changeaccesscontrol*          111)          
-(defconstant *x-changeclosedownmode*          112)
-(defconstant *x-killclient*                   113)
-(defconstant *x-rotateproperties*	      114)
-(defconstant *x-forcescreensaver*	      115)
-(defconstant *x-setpointermapping*            116)
-(defconstant *x-getpointermapping*            117)
-(defconstant *x-setmodifiermapping*	      118)
-(defconstant *x-getmodifiermapping*	      119)
-(defconstant *x-nooperation*                  127)
-
-;;; Some macros for threaded lists
-
-(defmacro threaded-atomic-push (item list next type)
-  (let ((x (gensym))
-	(y (gensym)))
-    `(let ((,x ,item))
-       (declare (type ,type ,x))
-       (loop
-	 (let ((,y ,list))
-	   (declare (type (or null ,type) ,y)
-		    (optimize (speed 3) (safety 0)))
-	   (setf (,next ,x) ,y)
-	   (when (conditional-store ,list ,y ,x)
-	     (return ,x)))))))
-
-(defmacro threaded-atomic-pop (list next type)
-  (let ((y (gensym)))
-    `(loop
-       (let ((,y ,list))
-	 (declare (type (or null ,type) ,y)
-		  (optimize (speed 3) (safety 0)))
-	 (if (null ,y)
-	     (return nil)
-	   (when (conditional-store ,list ,y (,next (the ,type ,y)))
-	     (setf (,next (the ,type ,y)) nil)
-	     (return ,y)))))))
-
-(defmacro threaded-nconc (item list next type)
-  (let ((first (gensym))
-	(x (gensym))
-	(y (gensym))
-	(z (gensym)))
-    `(let ((,z ,item)
-	   (,first ,list))
-       (declare (type ,type ,z)
-		(type (or null ,type) ,first)
-		(optimize (speed 3) (safety 0)))
-       (if (null ,first)
-	   (setf ,list ,z)
-	 (do* ((,x ,first ,y)
-	       (,y (,next ,x) (,next ,x)))
-	      ((null ,y)
-	       (setf (,next ,x) ,z)
-	       ,first)
-	   (declare (type ,type ,x)
-		    (type (or null ,type) ,y)))))))
-
-(defmacro threaded-push (item list next type)
-  (let ((x (gensym)))
-    `(let ((,x ,item))
-       (declare (type ,type ,x)
-		(optimize (speed 3) (safety 0)))
-       (shiftf (,next ,x) ,list ,x)
-       ,x)))
-
-(defmacro threaded-pop (list next type)
-  (let ((x (gensym)))
-    `(let ((,x ,list))
-       (declare (type (or null ,type) ,x)
-		(optimize (speed 3) (safety 0)))
-       (when ,x
-	 (shiftf ,list (,next (the ,type ,x)) nil))
-       ,x)))
-
-(defmacro threaded-enqueue (item head tail next type)
-  (let ((x (gensym)))
-    `(let ((,x ,item))
-       (declare (type ,type ,x)
-		(optimize (speed 3) (safety 0)))
-       (if (null ,tail)
-	   (threaded-nconc ,x ,head ,next ,type)
-	 (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type))
-       (setf ,tail ,x))))
-
-(defmacro threaded-dequeue (head tail next type)
-  (let ((x (gensym)))
-    `(let ((,x ,head))
-       (declare (type (or null ,type) ,x)
-		(optimize (speed 3) (safety 0)))
-       (when ,x
-	 (when (eq ,x ,tail)
-	   (setf ,tail (,next (the ,type ,x))))
-	 (setf ,head (,next (the ,type ,x))))
-       ,x)))
-
-(defmacro threaded-requeue (item head tail next type)
-  (let ((x (gensym)))
-    `(let ((,x ,item))
-       (declare (type ,type ,x)
-		(optimize (speed 3) (safety 0)))
-       (if (null ,tail)
-	   (setf ,tail (setf ,head ,x))
-	 (shiftf (,next ,x) ,head ,x))
-       ,x)))
-
-(defmacro threaded-dolist ((variable list next type) &body body)
-  `(block nil
-     (do* ((,variable ,list (,next (the ,type ,variable))))
-	  ((null ,variable))
-       (declare (type (or null ,type) ,variable))
-       ,@body)))
-
-(defmacro threaded-delete (item list next type)
-  (let ((x (gensym))
-	(y (gensym))
-	(z (gensym))
-	(first (gensym)))
-    `(let ((,x ,item)
-	   (,first ,list))
-       (declare (type ,type ,x)
-		(type (or null ,type) ,first)
-		(optimize (speed 3) (safety 0)))
-       (when ,first
-	 (if (eq ,first ,x)
-	     (setf ,first (setf ,list (,next ,x)))
-	   (do* ((,y ,first ,z)
-		 (,z (,next ,y) (,next ,y)))
-		((or (null ,z) (eq ,z ,x))
-		 (when (eq ,z ,x)
-		   (setf (,next ,y) (,next ,x))))
-	     (declare (type ,type ,y))
-	     (declare (type (or null ,type) ,z)))))
-       (setf (,next ,x) nil)
-       ,first)))
-
-(defmacro threaded-length (list next type)
-  (let ((x (gensym))
-	(count (gensym)))
-    `(do ((,x ,list (,next (the ,type ,x)))
-	  (,count 0 (index1+ ,count)))
-	 ((null ,x)
-	  ,count)
-       (declare (type (or null ,type) ,x)
-		(type array-index ,count)
-		(optimize (speed 3) (safety 0))))))
-
diff --git a/clx/manager.lisp b/clx/manager.lisp
deleted file mode 100644
index 5366cd18ee3e8541138932dc2858e42f7e6a244f..0000000000000000000000000000000000000000
--- a/clx/manager.lisp
+++ /dev/null
@@ -1,789 +0,0 @@
-;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
-
-;;; Window Manager Property functions
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-(defun wm-name (window)
-  (declare (type window window))
-  (declare (clx-values string))
-  (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char))
-
-(defsetf wm-name (window) (name)
-  `(set-string-property ,window :WM_NAME ,name))
-
-(defun set-string-property (window property string)
-  (declare (type window window)
-	   (type keyword property)
-	   (type stringable string))
-  (change-property window property (string string) :STRING 8 :transform #'char->card8)
-  string)
-
-(defun wm-icon-name (window)
-  (declare (type window window))
-  (declare (clx-values string))
-  (get-property window :WM_ICON_NAME :type :STRING
-		:result-type 'string :transform #'card8->char))
-
-(defsetf wm-icon-name (window) (name)
-  `(set-string-property ,window :WM_ICON_NAME ,name))
-
-(defun wm-client-machine (window)
-  (declare (type window window))
-  (declare (clx-values string))
-  (get-property window :WM_CLIENT_MACHINE :type :STRING
-		:result-type 'string :transform #'card8->char))
-
-(defsetf wm-client-machine (window) (name)
-  `(set-string-property ,window :WM_CLIENT_MACHINE ,name))
-
-(defun get-wm-class (window)
-  (declare (type window window))
-  (declare (clx-values (or null name-string) (or null class-string)))
-  (let ((value (get-property window :WM_CLASS :type :STRING :result-type '(vector card8))))
-    (declare (type (or null (vector card8)) value))
-    (when value
-      (let* ((name-len (position 0 (the (vector card8) value)))
-	     (name (subseq (the (vector card8) value) 0 name-len))
-	     (class (subseq (the (vector card8) value) (1+ name-len) (1- (length value)))))
-	(values (and (plusp (length name)) (map 'string #'card8->char name))
-		(and (plusp (length class)) (map 'string #'card8->char class)))))))
-
-(defun set-wm-class (window resource-name resource-class)
-  (declare (type window window)
-	   (type (or null stringable) resource-name resource-class))
-  (change-property window :WM_CLASS
-		   (concatenate '(vector card8)
-				(map '(vector card8) #'char->card8
-				     (string (or resource-name "")))
-				#(0)
-				(map '(vector card8) #'char->card8
-				     (string (or resource-class "")))
-				#(0))
-		   :string 8)
-  (values))
-
-(defun wm-command (window)
-  ;; Returns a list whose car is the command and 
-  ;; whose cdr is the list of arguments
-  (declare (type window window))
-  (declare (clx-values list))
-  (do* ((command-string (get-property window :WM_COMMAND :type :STRING
-				      :result-type '(vector card8)))
-	(command nil)
-	(start 0 (1+ end))
-	(end 0)
-	(len (length command-string)))
-       ((>= start len) (nreverse command))
-    (setq end (position 0 command-string :start start))
-    (push (map 'string #'card8->char (subseq command-string start end))
-	  command)))
-
-(defsetf wm-command set-wm-command)
-(defun set-wm-command (window command)
-  ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or
-  ;; equivalent), with elements of command separated by NULL characters.  This
-  ;; enables 
-  ;;   (with-standard-io-syntax (mapcar #'read-from-string (wm-command window)))
-  ;; to recover a lisp command.
-  (declare (type window window)
-	   (type list command))
-  (change-property window :WM_COMMAND
-		   (apply #'concatenate '(vector card8)
-			  (mapcan #'(lambda (c)
-				      (list (map '(vector card8) #'char->card8
-						 (with-output-to-string (stream)
-						   (with-standard-io-syntax 
-						     (prin1 c stream))))
-					    #(0)))
-				  command))
-		   :string 8)
-  command)
-
-;;-----------------------------------------------------------------------------
-;; WM_HINTS
-
-(def-clx-class (wm-hints)
-  (input nil :type (or null (member :off :on)))
-  (initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive)))
-  (icon-pixmap nil :type (or null pixmap))
-  (icon-window nil :type (or null window))
-  (icon-x nil :type (or null card16))
-  (icon-y nil :type (or null card16))
-  (icon-mask nil :type (or null pixmap))
-  (window-group nil :type (or null resource-id))
-  (flags 0 :type card32)    ;; Extension-hook.  Exclusive-Or'ed with the FLAGS field
-  ;; may be extended in the future
-  )
-
-(defun wm-hints (window)
-  (declare (type window window))
-  (declare (clx-values wm-hints))
-  (let ((prop (get-property window :WM_HINTS :type :WM_HINTS :result-type 'vector)))
-    (when prop
-      (decode-wm-hints prop (window-display window)))))
-
-(defsetf wm-hints set-wm-hints)
-(defun set-wm-hints (window wm-hints)
-  (declare (type window window)
-	   (type wm-hints wm-hints))
-  (declare (clx-values wm-hints))
-  (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32)
-  wm-hints)
-
-(defun decode-wm-hints (vector display)
-  (declare (type (simple-vector 9) vector)
-	   (type display display))
-  (declare (clx-values wm-hints))
-  (let ((input-hint 0)
-	(state-hint 1)
-	(icon-pixmap-hint 2)
-	(icon-window-hint 3)
-	(icon-position-hint 4)
-	(icon-mask-hint 5)
-	(window-group-hint 6))
-    (let ((flags (aref vector 0))
-	  (hints (make-wm-hints))
-	  (%buffer display))
-      (declare (type card32 flags)
-	       (type wm-hints hints)
-	       (type display %buffer))
-      (setf (wm-hints-flags hints) flags)
-      (when (logbitp input-hint flags)
-	(setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1))))
-      (when (logbitp state-hint flags)
-	(setf (wm-hints-initial-state hints)
-	      (decode-type (member :dont-care :normal :zoom :iconic :inactive)
-			   (aref vector 2))))
-      (when (logbitp icon-pixmap-hint flags)
-	(setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3))))
-      (when (logbitp icon-window-hint flags)
-	(setf (wm-hints-icon-window hints) (decode-type window (aref vector 4))))
-      (when (logbitp icon-position-hint flags)
-	(setf (wm-hints-icon-x hints) (aref vector 5)
-	      (wm-hints-icon-y hints) (aref vector 6)))
-      (when (logbitp icon-mask-hint flags)
-	(setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7))))
-      (when (and (logbitp window-group-hint flags) (> (length vector) 7))
-	(setf (wm-hints-window-group hints) (aref vector 8)))
-      hints)))
-
-
-(defun encode-wm-hints (wm-hints)
-  (declare (type wm-hints wm-hints))
-  (declare (clx-values simple-vector))
-  (let ((input-hint         #b1)
-	(state-hint         #b10)
-	(icon-pixmap-hint   #b100)
-	(icon-window-hint   #b1000)
-	(icon-position-hint #b10000)
-	(icon-mask-hint     #b100000)
-	(window-group-hint  #b1000000)
-	(mask               #b1111111)
-	)
-    (let ((vector (make-array 9 :initial-element 0))
-	  (flags 0))
-      (declare (type (simple-vector 9) vector)
-	       (type card16 flags))
-      (when (wm-hints-input wm-hints)
-	(setf flags input-hint
-	      (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints))))
-      (when (wm-hints-initial-state wm-hints)
-	(setf flags (logior flags state-hint)
-	      (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive)
-					   (wm-hints-initial-state wm-hints))))
-      (when (wm-hints-icon-pixmap wm-hints)
-	(setf flags (logior flags icon-pixmap-hint)
-	      (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints))))
-      (when (wm-hints-icon-window wm-hints)
-	(setf flags (logior flags icon-window-hint)
-	      (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints))))
-      (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints))
-	(setf flags (logior flags icon-position-hint)
-	      (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints))
-	      (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints))))
-      (when (wm-hints-icon-mask wm-hints)
-	(setf flags (logior flags icon-mask-hint)
-	      (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints))))
-      (when (wm-hints-window-group wm-hints)
-	(setf flags (logior flags window-group-hint)
-	      (aref vector 8) (wm-hints-window-group wm-hints)))
-      (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask)))
-      vector)))
-
-;;-----------------------------------------------------------------------------
-;; WM_SIZE_HINTS
-
-(def-clx-class (wm-size-hints)
-  (user-specified-position-p nil :type boolean) ;; True when user specified x y
-  (user-specified-size-p nil :type boolean)     ;; True when user specified width height
-  (x nil :type (or null int16))			;; Obsolete
-  (y nil :type (or null int16))			;; Obsolete
-  (width nil :type (or null card16))		;; Obsolete
-  (height nil :type (or null card16))		;; Obsolete
-  (min-width nil :type (or null card16))
-  (min-height nil :type (or null card16))
-  (max-width nil :type (or null card16))
-  (max-height nil :type (or null card16))
-  (width-inc nil :type (or null card16))
-  (height-inc nil :type (or null card16))
-  (min-aspect nil :type (or null number))
-  (max-aspect nil :type (or null number))
-  (base-width nil :type (or null card16))
-  (base-height nil :type (or null card16))
-  (win-gravity nil :type (or null win-gravity))
-  (program-specified-position-p nil :type boolean) ;; True when program specified x y
-  (program-specified-size-p nil :type boolean)     ;; True when program specified width height
-  )
-
-
-(defun wm-normal-hints (window)
-  (declare (type window window))
-  (declare (clx-values wm-size-hints))
-  (decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
-
-(defsetf wm-normal-hints set-wm-normal-hints)
-(defun set-wm-normal-hints (window hints)
-  (declare (type window window)
-	   (type wm-size-hints hints))
-  (declare (clx-values wm-size-hints))
-  (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
-  hints)
-
-;;; OBSOLETE
-(defun wm-zoom-hints (window)
-  (declare (type window window))
-  (declare (clx-values wm-size-hints))
-  (decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
-
-;;; OBSOLETE
-(defsetf wm-zoom-hints set-wm-zoom-hints)
-;;; OBSOLETE
-(defun set-wm-zoom-hints (window hints)
-  (declare (type window window)
-	   (type wm-size-hints hints))
-  (declare (clx-values wm-size-hints))
-  (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
-  hints)
-
-(defun decode-wm-size-hints (vector)
-  (declare (type (or null (simple-vector *)) vector))
-  (declare (clx-values (or null wm-size-hints)))
-  (when vector
-    (let ((flags (aref vector 0))
-	  (hints (make-wm-size-hints)))
-      (declare (type card16 flags)
-	       (type wm-size-hints hints))
-      (setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags))
-      (setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags))
-      (setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags))
-      (setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags))
-      (when (logbitp 4 flags)
-	(setf (wm-size-hints-min-width hints) (aref vector 5)
-	      (wm-size-hints-min-height hints) (aref vector 6)))
-      (when (logbitp 5 flags)
-	(setf (wm-size-hints-max-width hints) (aref vector 7)
-	      (wm-size-hints-max-height hints) (aref vector 8)))
-      (when (logbitp 6 flags)
-	(setf (wm-size-hints-width-inc hints) (aref vector 9)
-	      (wm-size-hints-height-inc hints) (aref vector 10)))
-      (when (logbitp 7 flags)
-	(setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12))
-	      (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14))))
-      (when (> (length vector) 15)
-	;; This test is for backwards compatibility since old Xlib programs
-	;; can set a size-hints structure that is too small.  See ICCCM.
-	(when (logbitp 8 flags)
-	  (setf (wm-size-hints-base-width hints) (aref vector 15)
-		(wm-size-hints-base-height hints) (aref vector 16)))
-	(when (logbitp 9 flags)
-	  (setf (wm-size-hints-win-gravity hints)
-		(decode-type (member-vector *win-gravity-vector*) (aref vector 17)))))
-      ;; Obsolete fields
-      (when (or (logbitp 0 flags) (logbitp 2 flags))
-	(setf (wm-size-hints-x hints) (aref vector 1)
-	      (wm-size-hints-y hints) (aref vector 2)))
-      (when (or (logbitp 1 flags) (logbitp 3 flags))
-	(setf (wm-size-hints-width hints) (aref vector 3)
-	      (wm-size-hints-height hints) (aref vector 4)))
-      hints)))
-
-(defun encode-wm-size-hints (hints)
-  (declare (type wm-size-hints hints))
-  (declare (clx-values simple-vector))
-  (let ((vector (make-array 18 :initial-element 0))
-	(flags 0))
-    (declare (type (simple-vector 18) vector)
-	     (type card16 flags)) 
-    (when (wm-size-hints-user-specified-position-p hints)
-      (setf (ldb (byte 1 0) flags) 1))
-    (when (wm-size-hints-user-specified-size-p hints)
-      (setf (ldb (byte 1 1) flags) 1))
-    (when (wm-size-hints-program-specified-position-p hints)
-      (setf (ldb (byte 1 2) flags) 1))
-    (when (wm-size-hints-program-specified-size-p hints)
-      (setf (ldb (byte 1 3) flags) 1))
-    (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints))
-      (setf (ldb (byte 1 4) flags) 1
-	    (aref vector 5) (wm-size-hints-min-width hints)
-	    (aref vector 6) (wm-size-hints-min-height hints)))
-    (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints))
-      (setf (ldb (byte 1 5) flags) 1
-	    (aref vector 7) (wm-size-hints-max-width hints)
-	    (aref vector 8) (wm-size-hints-max-height hints)))
-    (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints))
-      (setf (ldb (byte 1 6) flags) 1
-	    (aref vector 9) (wm-size-hints-width-inc hints)
-	    (aref vector 10) (wm-size-hints-height-inc hints)))
-    (let ((min-aspect (wm-size-hints-min-aspect hints))
-	  (max-aspect (wm-size-hints-max-aspect hints)))
-      (when (and min-aspect max-aspect)
-	(setf (ldb (byte 1 7) flags) 1
-	      min-aspect (rationalize min-aspect)
-	      max-aspect (rationalize max-aspect)
-	      (aref vector 11) (numerator min-aspect)
-	      (aref vector 12) (denominator min-aspect)
-	      (aref vector 13) (numerator max-aspect)
-	      (aref vector 14) (denominator max-aspect))))
-    (when (and (wm-size-hints-base-width hints)
-	       (wm-size-hints-base-height hints))
-      (setf (ldb (byte 1 8) flags) 1
-	    (aref vector 15) (wm-size-hints-base-width hints)
-	    (aref vector 16) (wm-size-hints-base-height hints)))
-    (when (wm-size-hints-win-gravity hints)
-      (setf (ldb (byte 1 9) flags) 1
-	    (aref vector 17) (encode-type
-			       (member-vector *win-gravity-vector*)
-			       (wm-size-hints-win-gravity hints))))
-    ;; Obsolete fields
-    (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) 
-      (unless (wm-size-hints-user-specified-position-p hints)
-	(setf (ldb (byte 1 2) flags) 1))
-      (setf (aref vector 1) (wm-size-hints-x hints)
-	    (aref vector 2) (wm-size-hints-y hints)))
-    (when (and (wm-size-hints-width hints) (wm-size-hints-height hints))
-      (unless (wm-size-hints-user-specified-size-p hints)
-	(setf (ldb (byte 1 3) flags) 1))
-      (setf (aref vector 3) (wm-size-hints-width hints)
-	    (aref vector 4) (wm-size-hints-height hints)))
-    (setf (aref vector 0) flags)
-    vector))
-
-;;-----------------------------------------------------------------------------
-;; Icon_Size
-
-;; Use the same intermediate structure as WM_SIZE_HINTS
-
-(defun icon-sizes (window)
-  (declare (type window window))
-  (declare (clx-values wm-size-hints))
-  (let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector)))
-    (declare (type (or null (simple-vector 6)) vector))
-    (when vector
-      (make-wm-size-hints
-	:min-width (aref vector 0)
-	:min-height (aref vector 1)
-	:max-width (aref vector 2)
-	:max-height (aref vector 3)
-	:width-inc (aref vector 4)
-	:height-inc (aref vector 5)))))
-  
-(defsetf icon-sizes set-icon-sizes)
-(defun set-icon-sizes (window wm-size-hints)
-  (declare (type window window)
-	   (type wm-size-hints wm-size-hints))
-  (let ((vector (vector (wm-size-hints-min-width wm-size-hints)
-			(wm-size-hints-min-height wm-size-hints)
-			(wm-size-hints-max-width wm-size-hints)
-			(wm-size-hints-max-height wm-size-hints)
-			(wm-size-hints-width-inc wm-size-hints)
-			(wm-size-hints-height-inc wm-size-hints))))
-    (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32)
-    wm-size-hints))
-
-;;-----------------------------------------------------------------------------
-;; WM-Protocols
-
-(defun wm-protocols (window)
-  (map 'list #'(lambda (id) (atom-name (window-display window) id))
-       (get-property window :WM_PROTOCOLS :type :ATOM)))
-
-(defsetf wm-protocols set-wm-protocols)
-(defun set-wm-protocols (window protocols)
-  (change-property window :WM_PROTOCOLS
-		   (map 'list #'(lambda (atom) (intern-atom (window-display window) atom))
-			protocols)
-		   :ATOM 32)
-  protocols)
-
-;;-----------------------------------------------------------------------------
-;; WM-Colormap-windows
-
-(defun wm-colormap-windows (window)
-  (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW
-			:transform #'(lambda (id)
-				       (lookup-window (window-display window) id)))))
-
-(defsetf wm-colormap-windows set-wm-colormap-windows)
-(defun set-wm-colormap-windows (window colormap-windows)
-  (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32
-		   :transform #'window-id)
-  colormap-windows)
-
-;;-----------------------------------------------------------------------------
-;; Transient-For
-
-(defun transient-for (window)
-  (let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list)))
-    (and prop (lookup-window (window-display window) (car prop)))))
-
-(defsetf transient-for set-transient-for)
-(defun set-transient-for (window transient)
-  (declare (type window window transient))
-  (change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32)
-  transient)
-
-;;-----------------------------------------------------------------------------
-;; Set-WM-Properties
-
-(defun set-wm-properties (window &rest options &key 
-			  name icon-name resource-name resource-class command
-			  client-machine hints normal-hints zoom-hints
-			  ;; the following are used for wm-normal-hints
-			  (user-specified-position-p nil usppp)
-			  (user-specified-size-p nil usspp)
-			  (program-specified-position-p nil psppp)
-			  (program-specified-size-p nil psspp)
-			  x y width height min-width min-height max-width max-height
-			  width-inc height-inc min-aspect max-aspect
-			  base-width base-height win-gravity
-			  ;; the following are used for wm-hints
-			  input initial-state icon-pixmap icon-window
-			  icon-x icon-y icon-mask window-group)
-  ;; Set properties for WINDOW.
-  (declare (arglist window &rest options &key 
-		   name icon-name resource-name resource-class command
-		   client-machine hints normal-hints
-		   ;; the following are used for wm-normal-hints
-		   user-specified-position-p user-specified-size-p
-		   program-specified-position-p program-specified-size-p
-		   min-width min-height max-width max-height
-		   width-inc height-inc min-aspect max-aspect
-		   base-width base-height win-gravity
-		   ;; the following are used for wm-hints
-		   input initial-state icon-pixmap icon-window
-		   icon-x icon-y icon-mask window-group))
-  (declare (type window window)
-	   (type (or null stringable) name icon-name resource-name resource-class client-machine)
-	   (type (or null list) command)
-	   (type (or null wm-hints) hints)
-	   (type (or null wm-size-hints) normal-hints zoom-hints)
-	   (type boolean user-specified-position-p user-specified-size-p)
-	   (type boolean program-specified-position-p program-specified-size-p)
-	   (type (or null int16) x y)
-	   (type (or null card16) width height min-width min-height max-width max-height width-inc height-inc base-width base-height)
-	   (type (or null win-gravity) win-gravity)
-	   (type (or null number) min-aspect max-aspect)
-	   (type (or null (member :off :on)) input)
-	   (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state)
-	   (type (or null pixmap) icon-pixmap icon-mask)
-	   (type (or null window) icon-window)
-	   (type (or null card16) icon-x icon-y)
-	   (type (or null resource-id) window-group)
-	   (dynamic-extent options))
-  (when name (setf (wm-name window) name))
-  (when icon-name (setf (wm-icon-name window) icon-name))
-  (when client-machine (setf (wm-client-machine window) client-machine))
-  (when (or resource-name resource-class)
-    (set-wm-class window resource-name resource-class))
-  (when command (setf (wm-command window) command))
-  ;; WM-HINTS
-  (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window
-			    :icon-x :icon-y :icon-mask :window-group))
-	(when (getf options arg) (return t)))
-      (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints))))
-	(when input (setf (wm-hints-input wm-hints) input))
-	(when initial-state (setf (wm-hints-initial-state wm-hints) initial-state))
-	(when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap))
-	(when icon-window (setf (wm-hints-icon-window wm-hints) icon-window))
-	(when icon-x (setf (wm-hints-icon-x wm-hints) icon-x))
-	(when icon-y (setf (wm-hints-icon-y wm-hints) icon-y))
-	(when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask))
-	(when window-group (setf (wm-hints-window-group wm-hints) window-group))
-	(setf (wm-hints window) wm-hints))
-      (when hints (setf (wm-hints window) hints)))
-  ;; WM-NORMAL-HINTS
-  (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height
-			:width-inc :height-inc :min-aspect :max-aspect
-			:user-specified-position-p :user-specified-size-p
-			:program-specified-position-p :program-specified-size-p
-			:base-width :base-height :win-gravity))
-	(when (getf options arg) (return t)))
-      (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints))))
-	(when x (setf (wm-size-hints-x size) x))
-	(when y (setf (wm-size-hints-y size) y))
-	(when width (setf (wm-size-hints-width size) width))
-	(when height (setf (wm-size-hints-height size) height))
-	(when min-width (setf (wm-size-hints-min-width size) min-width))
-	(when min-height (setf (wm-size-hints-min-height size) min-height))
-	(when max-width (setf (wm-size-hints-max-width size) max-width))
-	(when max-height (setf (wm-size-hints-max-height size) max-height))
-	(when width-inc (setf (wm-size-hints-width-inc size) width-inc))
-	(when height-inc (setf (wm-size-hints-height-inc size) height-inc))
-	(when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect))
-	(when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect))
-	(when base-width (setf (wm-size-hints-base-width size) base-width))
-	(when base-height (setf (wm-size-hints-base-height size) base-height))
-	(when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity))
-	(when usppp
-	  (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p))
-	(when usspp
-	  (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p))
-	(when psppp
-	  (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p))
-	(when psspp
-	  (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p))
-	(setf (wm-normal-hints window) size))
-      (when normal-hints (setf (wm-normal-hints window) normal-hints)))
-  (when zoom-hints (setf (wm-zoom-hints window) zoom-hints))
-  )
-
-;;; OBSOLETE
-(defun set-standard-properties (window &rest options)
-  (declare (dynamic-extent options))
-  (apply #'set-wm-properties window options))
-
-;;-----------------------------------------------------------------------------
-;; WM Control
-
-(defun iconify-window (window screen)
-  (declare (type window window)
-	   (type screen screen))
-  (let ((root (screen-root screen)))
-    (declare (type window root))
-    (send-event root :client-message '(:substructure-redirect :substructure-notify)
-		:window window :format 32 :type :WM_CHANGE_STATE :data (list 3))))
-
-(defun withdraw-window (window screen)
-  (declare (type window window)
-	   (type screen screen))
-  (unmap-window window)
-  (let ((root (screen-root screen)))
-    (declare (type window root))
-    (send-event root :unmap-notify '(:substructure-redirect :substructure-notify)
-		:window window :event-window root :configure-p nil)))
-
-
-;;-----------------------------------------------------------------------------
-;; Colormaps
-
-(def-clx-class (standard-colormap (:copier nil) (:predicate nil))
-  (colormap nil :type (or null colormap))
-  (base-pixel 0 :type pixel)
-  (max-color nil :type (or null color))
-  (mult-color nil :type (or null color))
-  (visual nil :type (or null visual-info))
-  (kill nil :type (or (member nil :release-by-freeing-colormap)
-		      drawable gcontext cursor colormap font)))
-
-(defun rgb-colormaps (window property)
-  (declare (type window window)
-	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
-			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property))
-  (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
-    (declare (type (or null simple-vector) prop))
-    (when prop
-      (list (make-standard-colormap
-	      :colormap (lookup-colormap (window-display window) (aref prop 0))
-	      :base-pixel (aref prop 7)
-	      :max-color (make-color :red   (card16->rgb-val (aref prop 1))
-				     :green (card16->rgb-val (aref prop 3))
-				     :blue  (card16->rgb-val (aref prop 5)))
-	      :mult-color (make-color :red   (card16->rgb-val (aref prop 2))
-				      :green (card16->rgb-val (aref prop 4))
-				      :blue  (card16->rgb-val (aref prop 6)))
-	      :visual (and (<= 9 (length prop))
-			   (visual-info (window-display window) (aref prop 8)))
-	      :kill (and (<= 10 (length prop))
-			 (let ((killid (aref prop 9)))
-			   (if (= killid 1)
-			       :release-by-freeing-colormap
-			       (lookup-resource-id (window-display window) killid)))))))))
-
-(defsetf rgb-colormaps set-rgb-colormaps)
-(defun set-rgb-colormaps (window property maps)
-  (declare (type window window)
-	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
-			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property)
-	   (type list maps))
-  (let ((prop (make-array (* 10 (length maps)) :element-type 'card32))
-	(index -1))
-    (dolist (map maps)
-      (setf (aref prop (incf index))
-	    (encode-type colormap (standard-colormap-colormap map)))
-      (setf (aref prop (incf index))
-	    (encode-type rgb-val (color-red (standard-colormap-max-color map))))
-      (setf (aref prop (incf index))
-	    (encode-type rgb-val (color-red (standard-colormap-mult-color map))))
-      (setf (aref prop (incf index))
-	    (encode-type rgb-val (color-green (standard-colormap-max-color map))))
-      (setf (aref prop (incf index))
-	    (encode-type rgb-val (color-green (standard-colormap-mult-color map))))
-      (setf (aref prop (incf index))
-	    (encode-type rgb-val (color-blue (standard-colormap-max-color map))))
-      (setf (aref prop (incf index))
-	    (encode-type rgb-val (color-blue (standard-colormap-mult-color map))))
-      (setf (aref prop (incf index))
-	    (standard-colormap-base-pixel map))
-      (setf (aref prop (incf index))
-	    (visual-info-id (standard-colormap-visual map)))
-      (setf (aref prop (incf index))
-	    (let ((kill (standard-colormap-kill map)))
-	      (etypecase kill
-		(symbol
-		  (ecase kill
-		    ((nil) 0)
-		    ((:release-by-freeing-colormap) 1)))
-		(drawable (drawable-id kill))
-		(gcontext (gcontext-id kill))
-		(cursor (cursor-id kill))
-		(colormap (colormap-id kill))
-		(font (font-id kill))))))
-    (change-property window property prop :RGB_COLOR_MAP 32)))
-
-;;; OBSOLETE
-(defun get-standard-colormap (window property)
-  (declare (type window window)
-	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
-			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property))
-  (declare (clx-values colormap base-pixel max-color mult-color))
-  (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
-    (declare (type (or null simple-vector) prop))
-    (when prop
-      (values (lookup-colormap (window-display window) (aref prop 0))
-	      (aref prop 7)			;Base Pixel
-	      (make-color :red   (card16->rgb-val (aref prop 1))	;Max Color
-			  :green (card16->rgb-val (aref prop 3))
-			  :blue  (card16->rgb-val (aref prop 5)))
-	      (make-color :red   (card16->rgb-val (aref prop 2))	;Mult color
-			  :green (card16->rgb-val (aref prop 4))
-			  :blue  (card16->rgb-val (aref prop 6)))))))
-
-;;; OBSOLETE
-(defun set-standard-colormap (window property colormap base-pixel max-color mult-color)
-  (declare (type window window)
-	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
-			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property)
-	   (type colormap colormap)
-	   (type pixel base-pixel)
-	   (type color max-color mult-color))
-  (let ((prop (vector (encode-type colormap colormap)
-		      (encode-type rgb-val (color-red max-color))
-		      (encode-type rgb-val (color-red mult-color))
-		      (encode-type rgb-val (color-green max-color))
-		      (encode-type rgb-val (color-green mult-color))
-		      (encode-type rgb-val (color-blue max-color))
-		      (encode-type rgb-val (color-blue mult-color))
-		      base-pixel)))
-    (change-property window property prop :RGB_COLOR_MAP 32)))
-
-;;-----------------------------------------------------------------------------
-;; Cut-Buffers
-
-(defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string)
-		   (transform #'card8->char) (start 0) end)
-  ;; Return the contents of cut-buffer BUFFER
-  (declare (type display display)
-	   (type (integer 0 7) buffer)
-	   (type xatom type)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type t result-type)			;a sequence type
-	   (type (or null (function (integer) t)) transform))
-  (declare (clx-values sequence type format bytes-after))
-  (let* ((root (screen-root (first (display-roots display))))
-	 (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
-			    :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
-			 buffer)))
-    (get-property root property :type type :result-type result-type
-		  :start start :end end :transform transform)))
-
-;; Implement the following:
-;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8)
-;;			        (transform #'char->card8) (start 0) end) (data)
-;; In order to avoid having to pass positional parameters to set-cut-buffer,
-;; We've got to do the following.  WHAT A PAIN...
-#-clx-ansi-common-lisp
-(define-setf-method cut-buffer (display &rest option-list)
-  (declare (dynamic-extent option-list))
-  (do* ((options (copy-list option-list))
-	(option options (cddr option))
-	(store (gensym))
-	(dtemp (gensym))
-	(temps (list dtemp))
-	(values (list display)))
-       ((endp option)
-	(values (nreverse temps)
-		(nreverse values)
-		(list store)
-		`(set-cut-buffer ,store ,dtemp ,@options)
-		`(cut-buffer ,@options)))
-    (unless (member (car option) '(:buffer :type :format :start :end :transform))
-      (error "Keyword arg ~s isn't recognized" (car option)))
-    (let ((x (gensym)))
-      (push x temps)
-      (push (cadr option) values)
-      (setf (cadr option) x))))
-
-(defun
-  #+clx-ansi-common-lisp (setf cut-buffer)
-  #-clx-ansi-common-lisp set-cut-buffer
-  (data display &key (buffer 0) (type :STRING) (format 8)
-	(start 0) end (transform #'char->card8))
-  (declare (type sequence data)
-	   (type display display)
-	   (type (integer 0 7) buffer)
-	   (type xatom type)
-	   (type (member 8 16 32) format)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type (or null (function (integer) t)) transform))
-  (let* ((root (screen-root (first (display-roots display))))
-	 (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
-					 :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
-			 buffer)))
-    (change-property root property data type format :transform transform :start start :end end)
-    data))
-
-(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t))
-  ;; Positive rotates left, negative rotates right (opposite of actual protocol request).
-  ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors.
-  (declare (type display display)
-	   (type int16 delta)
-	   (type boolean careful-p))
-  (let* ((root (screen-root (first (display-roots display))))
-	 (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3
-		     :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7)))
-    (when careful-p
-      (let ((props (list-properties root)))
-	(dotimes (i 8)
-	  (unless (member (aref buffers i) props)
-	    (setf (cut-buffer display :buffer i) "")))))
-    (rotate-properties root buffers delta)))
-
diff --git a/clx/ms-patch.uu b/clx/ms-patch.uu
deleted file mode 100644
index b84726c5ca763f5ef80b9d49dfdfa2934faa6490..0000000000000000000000000000000000000000
--- a/clx/ms-patch.uu
+++ /dev/null
@@ -1,57 +0,0 @@
-begin 666 make-sequence-patch.lbin
-M1D%33"!&24Q%.@I&05-,('9E<G-I;VX@,"XP,#4@*&]F(#@V,3$Q,BDL($Q/
-M5U1!1R V.# P,"X*1DE,12!)1#H@(B]M;V1S+W!A=&-H97,O8G5G+3(S-C@N
-M;&)I;B([('9E<G-I;VX@3D5715-4.PIA=71H;W(@<F]G97([(&-R96%T960@
-M.#<P.#(V(#$W.C(T.C W+@I4:&ES(&9I;&4@:7,@=&AE(&]U='!U="!O9B!T
-M:&4@3%5#240L($E.0RX@0V]M;6]N($QI<W @0V]M<&EL97(N"DEN=&5R;F%L
-M(&9A<VP@<F5L96%S92!D871E($IU;F4@,C4L(#$Y.#8N"E-/55)#15,Z"B(O
-M;6]D<R]P871C:&5S+V)U9RTR,S8X+FQI<W B.R!V97)S:6]N($Y%5T535#L*
-M875T:&]R(')O9V5R.R!W<FET=&5N(#@W,#@R-B Q-SHR,SHU,BX*1DQ/050@
-M4$%204U%5$524SH@4F%D:7@Z(#(@4')E8VES:6]N<SH@," P(# @." R,R Q
-M-C @," P(# @," P(# *1D5!5%5215,Z( I"24Y!4ED@1$%402!&3TQ,3U=3
-M.@H]* I)3BU004-+04=% 2@%3%5#240Z3"@A5D%,241!5$4M4T51545.0T4M
-M4D5354Q4+5194$534$5#.Q@\_0*'#$8  F<0#$8  6<()&P XTZJ  4O#"!N
-M__0B;0 18 0B:0 #( D"   '#    6<$)$Q@"+'I  =FYB1)N<IG$"U(  0J
-M;O_\3^[_^"973M-/[O_PL>T %682+6T &0 $*F[__$_N__@F5T[3L>T '6<&
-ML>T (682+6T )0 $*F[__$_N__@F5T[3L>T *682+6T +0 $*F[__$_N__@F
-M5T[3(&[_]+G(9PX@" (   <,   !9@ #^B!N__0O*  '0J<O#B\-2'H &B\(
-M? $D;0 Q*FH $]S\_^0@;0 !3N@ !4Y>)&T -;7N_^QF  &X("[_Z R     
-M#&<L0J<O#B\-2'H ("\M #DO+O_T? (D;0 ]*FH $]S\_^ @;0 !3N@ !4Y>
-M6(\@;O_T(F@  R1M $&UZ0 '9P  @B!N__0B:  #(FD  R1M $&UZ0 '9RQ"
-MIR\.+PU(>@ @+RT .2\N__1\ B1M #TJ:@ 3W/S_X"!M  %.Z  %3EY8CR)N
-M__0B:0 #(&D !R)N__0B:0 #(FD  R\I  <B;O_T(FD  R-N_^0 !R)N__0B
-M:0 #(FD  R-(  =/[O_H0J<O#B\-2'H +"!N__0B:  #(FD  R\I  <O+O_P
-M? (D;0!%*FH $]S\_^ @;0 !3N@ !4Y>(&[_Y")M $E@!")I  ,@"0(   <,
-M   !9P0O#& (L>D !V;F+PE/[O_@N>[_X&<"8%P@;O_DN<AG$" ( @  !PP 
-M  %G!"\,8!(D;0 UM>@ !R1,9P0D;  W+PJY[O_<9P)@*D*G+PXO#4AZ " O
-M+0 Y+R[_]'P")&T /2IJ !/<_/_4(&T  4[H  5.7D_N_^0@;O_T(F@  R)I
-M  ,C;O_D  <M2  $*F[__$_N__@F5T[3)&T 3;7N_^QF>B N_^@,@     1F
-M$BUM $T !"IN__Q/[O_X)E=.TR N_^@,@     AG*@R     #&<B+6[_]/_P
-M+6T .?_T? (D;0 ]*FH $R!M  %/[O_P3N@ !2!N__0B:  #(&D !RU(__1\
-M 21M %$J:@ 3(&T  4_N__1.Z  %(&[_[+'M %5G!K'M %EF7B N_^@,@   
-M  QG+$*G+PXO#4AZ " O+0 Y+R[_]'P")&T /2IJ !/<_/_@(&T  4[H  5.
-M7EB/(&[_]")H  ,@:0 '+4C_]'P!)&T 42IJ !,@;0 !3^[_]$[H  4O+0!)
-M(&[_[")N_^1@!")I  ,@"0(   <,   !9P0D3& (L>D !V;F)$FYRF<  (0@
-M+O_H#(     (9RQ"IR\.+PU(>@ @+RT .2\N__1\ B1M #TJ:@ 3W/S_W"!M
-M  %.Z  %3EY8CR!N_^RQ[0 59A(M;0 9  0J;O_\3^[_^"973M.Q[0 =9Q:Q
-M[0 A9Q M2  $*F[__$_N__@F5T[3+6T )0 $*F[__$_N__@F5T[33^[_Z+GN
-M__!G F X0J<O#B\-2'H '"\N__1\ 21M %TJ:@ 3W/S_X"!M  %.Z  %3EXM
-M7__T+6P -__P3^[_\&  ^XHM;O_T__ M;0 Y__1\ B1M #TJ:@ 3(&T  4_N
-M__!.Z  %N>[_\&<"8#1"IR\.+PU(>@ <+R[_]'P!)&T 72IJ !/<_/_H(&T 
-M 4[H  5.7BU?__0M;  W__!@ /LL+6[_]/_P+6T .?_T? (D;0 ]*FH $R!M
-M  %/[O_P3N@ !?X"!20N* A465!%4U!%0R@))D]05$E/3D%,* M.3U)-04Q)
-M6D5$4#A,* 1,25-4* 1.54Q,3"@&5D5#5$]23 $U#"@-4TE-4$Q%+59%0U1/
-M4DPH#5-)35!,12U35%))3D=,*!)324U03$4M,4))5"U614-43U(H$E-)35!,
-M12TR0DE4+59%0U1/4B@24TE-4$Q%+31"250M5D5#5$]2*!)324U03$4M.$))
-M5"U614-43U(H$U-)35!,12TQ-D))5"U614-43U(H$U-)35!,12TS,D))5"U6
-M14-43U(H&5-)35!,12U324=.140M.$))5"U614-43U(H&E-)35!,12U324=.
-M140M,39"250M5D5#5$]2*!I324U03$4M4TE'3D5$+3,R0DE4+59%0U1/4B@:
-M4TE-4$Q%+5-)3D=,12U&3$]!5"U614-43U),* 935%))3D?^"TPH"D))5"U6
-M14-43U),*!%324U03$4M0DE4+59%0U1/4OX,* A315%514Y#12Y,* )/4OX&
-M_@@H"TQ)4U0M3$5.1U1(_AHB.7Y3(&ES(&%N(&EN=F%L:60@;W(@=6YR97-O
-M;'9A8FQE(')E<W5L="!S97%U96YC92!T>7!E<W!E8R@%15)23U+^!OX".07^
-M"/X6_A?^&/X)_@@H'5-)35!,12U614-43U(M5%E012U&4D]-+45465!%* 5!
-M4E)!62@,4TE-4$Q%+4%24D%9* Y.3U)-04Q)6D4M5%E014$*14Y$($]&($9!
-(4TP@1$%400I-
- 
-end
diff --git a/clx/package.lisp b/clx/package.lisp
deleted file mode 100644
index cdfd8b166d745c078bbdfc376ca458633018dbde..0000000000000000000000000000000000000000
--- a/clx/package.lisp
+++ /dev/null
@@ -1,385 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes;  -*-
-
-;;; Copyright 1990 Massachusetts Institute of Technology, Cambridge,
-;;; Massachusetts.  All Rights Reserved.
-;;; 
-;;; Permission to use, copy, modify, and distribute this software and its
-;;; documentation for any purpose and without fee is hereby granted, provided
-;;; that the above copyright notice appear in all copies and that both that
-;;; copyright notice and this permission notice appear in supporting
-;;; documentation, and that the name MIT not be used in advertising or
-;;; publicity pertaining to distribution of the software without specific,
-;;; written prior permission.
-
-;;; The CLtL way
-
-#-clx-ansi-common-lisp 
-(lisp:in-package :xlib :use '(:lisp))
-
-#+(and (or kcl ibcl) (not clx-ansi-common-lisp))
-(shadow 
-  '(
-    rational
-    ))
-
-#+(and CMU (not clx-ansi-common-lisp))
-(shadow '(define-condition))
-
-#+(and lispm (not clx-ansi-common-lisp))
-(import
-  '(
-    sys:arglist
-    sys:with-stack-list
-    sys:with-stack-list*
-    ))
-
-#+(and Genera (not clx-ansi-common-lisp))
-(import
-  '(
-    future-common-lisp:print-unreadable-object
-    future-common-lisp:with-standard-io-syntax
-    zwei:indentation
-    ))
-
-#+(and lcl3.0 (not clx-ansi-common-lisp))
-(import
-  '(
-    lcl:arglist
-    lcl:dynamic-extent
-    lcl:type-error
-    lucid::type-error-datum
-    lucid::type-error-expected-type
-    ))
-
-#+(and excl (not clx-ansi-common-lisp)) 
-(import
-  '(
-    excl::arglist
-    excl::dynamic-extent
-    excl::type-error
-    excl::type-error-datum
-    excl::type-error-expected-type
-    ))
-
-#+(and allegro (not clx-ansi-common-lisp))
-(import
-  '(
-    excl::without-interrupts
-    ))
-
-#-clx-ansi-common-lisp
-(export
-  '(
-    *version* access-control access-error access-hosts
-    activate-screen-saver add-access-host add-resource add-to-save-set
-    alist alloc-color alloc-color-cells alloc-color-planes alloc-error
-    allow-events angle arc-seq array-index atom-error atom-name
-    bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p
-    bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image
-    boole-constant boolean card16 card29 card32 card8
-    card8->char change-active-pointer-grab change-keyboard-control
-    change-keyboard-mapping change-pointer-control change-property
-    char->card8 char-ascent char-attributes char-descent
-    char-left-bearing char-right-bearing char-width character->keysyms
-    character-in-map-p circulate-window-down circulate-window-up clear-area
-    close-display close-down-mode close-font closed-display color
-    color-blue color-green color-p color-red color-rgb colormap
-    colormap-display colormap-equal colormap-error colormap-id colormap-p
-    colormap-plist colormap-visual-info connection-failure convert-selection
-    copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components
-    copy-image copy-plane create-colormap create-cursor
-    create-gcontext create-glyph-cursor create-image create-pixmap
-    create-window cursor cursor-display cursor-equal cursor-error
-    cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error
-    default-error-handler default-keysym-index default-keysym-translate
-    define-error define-extension define-gcontext-accessor
-    define-keysym define-keysym-set delete-property delete-resource
-    destroy-subwindows destroy-window device-busy device-event-mask
-    device-event-mask-class discard-current-event discard-font-info display
-    display-after-function display-authorization-data display-authorization-name
-    display-bitmap-format display-byte-order display-default-screen
-    display-display display-error-handler display-finish-output
-    display-force-output display-host display-image-lsb-first-p
-    display-invoke-after-function display-keycode-range display-max-keycode
-    display-max-request-length display-min-keycode display-motion-buffer-size
-    display-nscreens display-p display-pixmap-formats display-plist
-    display-protocol-major-version display-protocol-minor-version
-    display-protocol-version display-release-number
-    display-report-asynchronous-errors display-resource-id-base
-    display-resource-id-mask display-roots display-vendor
-    display-vendor-name display-xdefaults display-xid draw-arc
-    draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph
-    draw-image-glyphs draw-line draw-lines draw-point draw-points
-    draw-rectangle draw-rectangles draw-segments drawable
-    drawable-border-width drawable-depth drawable-display drawable-equal
-    drawable-error drawable-height drawable-id drawable-p
-    drawable-plist drawable-root drawable-width drawable-x drawable-y
-    error-key event-case event-cond event-handler event-key
-    event-listen event-mask event-mask-class extension-opcode
-    find-atom font font-all-chars-exist-p font-ascent
-    font-default-char font-descent font-direction font-display
-    font-equal font-error font-id font-max-byte1 font-max-byte2
-    font-max-char font-min-byte1 font-min-byte2 font-min-char
-    font-name font-p font-path font-plist font-properties
-    font-property fontable force-gcontext-changes free-colormap
-    free-colors free-cursor free-gcontext free-pixmap gcontext
-    gcontext-arc-mode gcontext-background 
-    gcontext-cache-p gcontext-cap-style
-    gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x
-    gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display
-    gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule
-    gcontext-fill-style gcontext-font gcontext-foreground gcontext-function
-    gcontext-id gcontext-join-style gcontext-key gcontext-line-style
-    gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist
-    gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x
-    gcontext-ts-y get-external-event-code get-image get-property
-    get-raw-image get-resource get-search-resource get-search-table
-    get-standard-colormap get-wm-class global-pointer-position grab-button
-    grab-key grab-keyboard grab-pointer grab-server grab-status
-    icon-sizes iconify-window id-choice-error illegal-request-error
-    image image-blue-mask image-depth image-green-mask image-height
-    image-name image-pixmap image-plist image-red-mask image-width
-    image-x image-x-hot image-x-p image-xy image-xy-bitmap-list
-    image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p
-    image-z-pixarray implementation-error input-focus install-colormap
-    installed-colormaps int16 int32 int8 intern-atom invalid-font
-    keyboard-control keyboard-mapping keycode->character keycode->keysym
-    keysym keysym->character keysym->keycodes keysym-in-map-p
-    keysym-set kill-client kill-temporary-clients length-error
-    list-extensions list-font-names list-fonts list-properties
-    lookup-color lookup-error make-color make-event-handlers
-    make-event-keys make-event-mask make-resource-database make-state-keys
-    make-state-mask make-wm-hints make-wm-size-hints map-resource
-    map-subwindows map-window mapping-notify mask16 mask32
-    match-error max-char-ascent max-char-attributes max-char-descent
-    max-char-left-bearing max-char-right-bearing max-char-width
-    merge-resources min-char-ascent min-char-attributes min-char-descent
-    min-char-left-bearing min-char-right-bearing min-char-width
-    missing-parameter modifier-key modifier-mapping modifier-mask
-    motion-events name-error no-operation open-display open-font
-    pixarray pixel pixmap pixmap-display pixmap-equal
-    pixmap-error pixmap-format pixmap-format-bits-per-pixel
-    pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad
-    pixmap-id pixmap-p pixmap-plist point-seq pointer-control
-    pointer-event-mask pointer-event-mask-class pointer-mapping
-    pointer-position process-event put-image put-raw-image
-    query-best-cursor query-best-stipple query-best-tile query-colors
-    query-extension query-keymap query-pointer query-tree queue-event
-    read-bitmap-file read-resources recolor-cursor rect-seq
-    remove-access-host remove-from-save-set reparent-window repeat-seq
-    reply-length-error reply-timeout request-error reset-screen-saver
-    resource-database resource-database-timestamp resource-error
-    resource-id resource-key rgb-colormaps rgb-val root-resources
-    rotate-cut-buffers rotate-properties screen screen-backing-stores
-    screen-black-pixel screen-default-colormap screen-depths
-    screen-event-mask-at-open screen-height screen-height-in-millimeters
-    screen-max-installed-maps screen-min-installed-maps screen-p
-    screen-plist screen-root screen-root-depth screen-root-visual
-    screen-root-visual-info screen-save-unders-p screen-saver
-    screen-white-pixel screen-width screen-width-in-millimeters seg-seq
-    selection-owner send-event sequence-error set-access-control
-    set-close-down-mode set-input-focus set-modifier-mapping
-    set-pointer-mapping set-screen-saver set-selection-owner
-    set-standard-colormap set-standard-properties set-wm-class
-    set-wm-properties set-wm-resources state-keysym-p state-mask-key
-    store-color store-colors stringable text-extents text-width
-    timestamp transient-for translate-coordinates translate-default
-    translation-function type-error undefine-keysym unexpected-reply
-    ungrab-button ungrab-key ungrab-keyboard ungrab-pointer
-    ungrab-server uninstall-colormap unknown-error unmap-subwindows
-    unmap-window value-error visual-info visual-info-bits-per-rgb
-    visual-info-blue-mask visual-info-class visual-info-colormap-entries
-    visual-info-display visual-info-green-mask visual-info-id visual-info-p
-    visual-info-plist visual-info-red-mask warp-pointer
-    warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside
-    win-gravity window window-all-event-masks window-background
-    window-backing-pixel window-backing-planes window-backing-store
-    window-bit-gravity window-border window-class window-colormap
-    window-colormap-installed-p window-cursor window-display
-    window-do-not-propagate-mask window-equal window-error
-    window-event-mask window-gravity window-id window-map-state
-    window-override-redirect window-p window-plist window-priority
-    window-save-under window-visual window-visual-info with-display
-    with-event-queue with-gcontext with-server-grabbed with-state
-    withdraw-window wm-client-machine wm-colormap-windows wm-command
-    wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap
-    wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y
-    wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group
-    wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources
-    wm-size-hints wm-size-hints-base-height wm-size-hints-base-width
-    wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect
-    wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect
-    wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p
-    wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p
-    wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity
-    wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file
-    write-resources xatom
-    ))
-
-
-;;; The ANSI Common Lisp way
-
-#+(and Genera clx-ansi-common-lisp)
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (setf *readtable* si:*ansi-common-lisp-readtable*))
-
-#+clx-ansi-common-lisp
-(common-lisp:in-package :common-lisp-user)
-
-#+clx-ansi-common-lisp
-(defpackage xlib
-  (:use common-lisp)
-  (:size 3000)
-  #+(or kcl ibcl) (:shadow rational)
-  #+allegro (:use cltl1)
-  #+allegro (:import-from excl without-interrupts)
-  #+excl (:import-from excl arglist)
-  #+Genera (:import-from zwei indentation)
-  #+lcl3.0 (:import-from lcl arglist)
-  #+lispm (:import-from lisp char-bit)
-  #+lispm (:import-from sys arglist with-stack-list with-stack-list*)
-  (:export
-    *version* access-control access-error access-hosts
-    activate-screen-saver add-access-host add-resource add-to-save-set
-    alist alloc-color alloc-color-cells alloc-color-planes alloc-error
-    allow-events angle arc-seq array-index atom-error atom-name
-    bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p
-    bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image
-    boole-constant boolean card16 card29 card32 card8
-    card8->char change-active-pointer-grab change-keyboard-control
-    change-keyboard-mapping change-pointer-control change-property
-    char->card8 char-ascent char-attributes char-descent
-    char-left-bearing char-right-bearing char-width character->keysyms
-    character-in-map-p circulate-window-down circulate-window-up clear-area
-    close-display close-down-mode close-font closed-display color
-    color-blue color-green color-p color-red color-rgb colormap
-    colormap-display colormap-equal colormap-error colormap-id colormap-p
-    colormap-plist colormap-visual-info connection-failure convert-selection
-    copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components
-    copy-image copy-plane create-colormap create-cursor
-    create-gcontext create-glyph-cursor create-image create-pixmap
-    create-window cursor cursor-display cursor-equal cursor-error
-    cursor-id cursor-p cursor-plist cut-buffer declare-event decode-core-error
-    default-error-handler default-keysym-index default-keysym-translate
-    define-error define-extension define-gcontext-accessor
-    define-keysym define-keysym-set delete-property delete-resource
-    destroy-subwindows destroy-window device-busy device-event-mask
-    device-event-mask-class discard-current-event discard-font-info display
-    display-after-function display-authorization-data display-authorization-name
-    display-bitmap-format display-byte-order display-default-screen
-    display-display display-error-handler display-finish-output
-    display-force-output display-host display-image-lsb-first-p
-    display-invoke-after-function display-keycode-range display-max-keycode
-    display-max-request-length display-min-keycode display-motion-buffer-size
-    display-nscreens display-p display-pixmap-formats display-plist
-    display-protocol-major-version display-protocol-minor-version
-    display-protocol-version display-release-number
-    display-report-asynchronous-errors display-resource-id-base
-    display-resource-id-mask display-roots display-vendor
-    display-vendor-name display-xdefaults display-xid draw-arc
-    draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph
-    draw-image-glyphs draw-line draw-lines draw-point draw-points
-    draw-rectangle draw-rectangles draw-segments drawable
-    drawable-border-width drawable-depth drawable-display drawable-equal
-    drawable-error drawable-height drawable-id drawable-p
-    drawable-plist drawable-root drawable-width drawable-x drawable-y
-    error-key event-case event-cond event-handler event-key
-    event-listen event-mask event-mask-class extension-opcode
-    find-atom font font-all-chars-exist-p font-ascent
-    font-default-char font-descent font-direction font-display
-    font-equal font-error font-id font-max-byte1 font-max-byte2
-    font-max-char font-min-byte1 font-min-byte2 font-min-char
-    font-name font-p font-path font-plist font-properties
-    font-property fontable force-gcontext-changes free-colormap
-    free-colors free-cursor free-gcontext free-pixmap gcontext
-    gcontext-arc-mode gcontext-background
-    gcontext-cache-p gcontext-cap-style
-    gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x
-    gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display
-    gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule
-    gcontext-fill-style gcontext-font gcontext-foreground gcontext-function
-    gcontext-id gcontext-join-style gcontext-key gcontext-line-style
-    gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist
-    gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x
-    gcontext-ts-y get-external-event-code get-image get-property
-    get-raw-image get-resource get-search-resource get-search-table
-    get-standard-colormap get-wm-class global-pointer-position grab-button
-    grab-key grab-keyboard grab-pointer grab-server grab-status
-    icon-sizes iconify-window id-choice-error illegal-request-error
-    image image-blue-mask image-depth image-green-mask image-height
-    image-name image-pixmap image-plist image-red-mask image-width
-    image-x image-x-hot image-x-p image-xy image-xy-bitmap-list
-    image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p
-    image-z-pixarray implementation-error input-focus install-colormap
-    installed-colormaps int16 int32 int8 intern-atom invalid-font
-    keyboard-control keyboard-mapping keycode->character keycode->keysym
-    keysym keysym->character keysym->keycodes keysym-in-map-p
-    keysym-set kill-client kill-temporary-clients length-error
-    list-extensions list-font-names list-fonts list-properties
-    lookup-color lookup-error make-color make-event-handlers
-    make-event-keys make-event-mask make-resource-database make-state-keys
-    make-state-mask make-wm-hints make-wm-size-hints map-resource
-    map-subwindows map-window mapping-notify mask16 mask32
-    match-error max-char-ascent max-char-attributes max-char-descent
-    max-char-left-bearing max-char-right-bearing max-char-width
-    merge-resources min-char-ascent min-char-attributes min-char-descent
-    min-char-left-bearing min-char-right-bearing min-char-width
-    missing-parameter modifier-key modifier-mapping modifier-mask
-    motion-events name-error no-operation open-display open-font
-    pixarray pixel pixmap pixmap-display pixmap-equal
-    pixmap-error pixmap-format pixmap-format-bits-per-pixel
-    pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad
-    pixmap-id pixmap-p pixmap-plist point-seq pointer-control
-    pointer-event-mask pointer-event-mask-class pointer-mapping
-    pointer-position process-event put-image put-raw-image
-    query-best-cursor query-best-stipple query-best-tile query-colors
-    query-extension query-keymap query-pointer query-tree queue-event
-    read-bitmap-file read-resources recolor-cursor rect-seq
-    remove-access-host remove-from-save-set reparent-window repeat-seq
-    reply-length-error reply-timeout request-error reset-screen-saver
-    resource-database resource-database-timestamp resource-error
-    resource-id resource-key rgb-colormaps rgb-val root-resources
-    rotate-cut-buffers rotate-properties screen screen-backing-stores
-    screen-black-pixel screen-default-colormap screen-depths
-    screen-event-mask-at-open screen-height screen-height-in-millimeters
-    screen-max-installed-maps screen-min-installed-maps screen-p
-    screen-plist screen-root screen-root-depth screen-root-visual
-    screen-root-visual-info screen-save-unders-p screen-saver
-    screen-white-pixel screen-width screen-width-in-millimeters seg-seq
-    selection-owner send-event sequence-error set-access-control
-    set-close-down-mode set-input-focus set-modifier-mapping
-    set-pointer-mapping set-screen-saver set-selection-owner
-    set-standard-colormap set-standard-properties set-wm-class
-    set-wm-properties set-wm-resources state-keysym-p state-mask-key
-    store-color store-colors stringable text-extents text-width
-    timestamp transient-for translate-coordinates translate-default
-    translation-function undefine-keysym unexpected-reply
-    ungrab-button ungrab-key ungrab-keyboard ungrab-pointer
-    ungrab-server uninstall-colormap unknown-error unmap-subwindows
-    unmap-window value-error visual-info visual-info-bits-per-rgb
-    visual-info-blue-mask visual-info-class visual-info-colormap-entries
-    visual-info-display visual-info-green-mask visual-info-id visual-info-p
-    visual-info-plist visual-info-red-mask warp-pointer
-    warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside
-    win-gravity window window-all-event-masks window-background
-    window-backing-pixel window-backing-planes window-backing-store
-    window-bit-gravity window-border window-class window-colormap
-    window-colormap-installed-p window-cursor window-display
-    window-do-not-propagate-mask window-equal window-error
-    window-event-mask window-gravity window-id window-map-state
-    window-override-redirect window-p window-plist window-priority
-    window-save-under window-visual window-visual-info with-display
-    with-event-queue with-gcontext with-server-grabbed with-state
-    withdraw-window wm-client-machine wm-colormap-windows wm-command
-    wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap
-    wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y
-    wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group
-    wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources
-    wm-size-hints wm-size-hints-base-height wm-size-hints-base-width
-    wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect
-    wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect
-    wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p
-    wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p
-    wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity
-    wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file
-    write-resources xatom))
diff --git a/clx/provide.lisp b/clx/provide.lisp
deleted file mode 100644
index bf6f3c7a4e0dd3da20eae4ccf8c358d2bb5750fe..0000000000000000000000000000000000000000
--- a/clx/provide.lisp
+++ /dev/null
@@ -1,56 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; Package: USER;  -*-
-
-;;;; Module definition for CLX
-
-;;; This file is a Common Lisp Module description, but you will have to edit
-;;; it to meet the needs of your site.
-
-;;; Ideally, this file (or a file that loads this file) should be
-;;; located in the system directory that REQUIRE searches.  Thus a user
-;;; would say
-;;;			(require :clx)
-;;; to load CLX.  If there is no such registry, then the user must
-;;; put in a site specific
-;;;			(require :clx <pathname-of-this-file>)
-;;;
-
-#-clx-ansi-common-lisp 
-(in-package :user)
-
-#+clx-ansi-common-lisp
-(in-package :common-lisp-user)
-
-#-clx-ansi-common-lisp
-(provide :clx)
-
-(defvar *clx-source-pathname*
-	(pathname "/src/local/clx/*.l"))
-
-(defvar *clx-binary-pathname*
-	(let ((lisp
-		(or #+lucid "lucid"
-		    #+akcl  "akcl"
-		    #+kcl   "kcl"
-		    #+ibcl  "ibcl"
-		    (error "Can't provide CLX for this lisp.")))
-	      (architecture
-		(or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3"
-		    #+(or sun4 sparc) "sparc"
-		    #+(and hp (or mc68000 mc68020)) "hp9000s300"
-		    #+vax "vax"
-		    #+prime "prime"
-		    #+sunrise "sunrise"
-		    #+ibm-rt-pc "ibm-rt-pc"
-		    #+mips "mips"
-		    #+prism "prism"
-		    (error "Can't provide CLX for this architecture."))))
-	  (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture))))
-
-(defvar *compile-clx*
-	nil)
-
-(load (merge-pathnames "defsystem" *clx-source-pathname*))
-
-(if *compile-clx*
-    (compile-clx *clx-source-pathname* *clx-binary-pathname*)
-  (load-clx *clx-binary-pathname*))
diff --git a/clx/requests.lisp b/clx/requests.lisp
deleted file mode 100644
index d91ea8f0bb8ba00626ce54925cd3226d6be085c3..0000000000000000000000000000000000000000
--- a/clx/requests.lisp
+++ /dev/null
@@ -1,1491 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-(defun create-window (&key
-		      window
-		      (parent (required-arg parent))
-		      (x (required-arg x))
-		      (y (required-arg y))
-		      (width (required-arg width))
-		      (height (required-arg height))
-		      (depth 0) (border-width 0)
-		      (class :copy) (visual :copy)
-		      background border
-		      bit-gravity gravity
-		      backing-store backing-planes backing-pixel save-under
-		      event-mask do-not-propagate-mask override-redirect
-		      colormap cursor)
-  ;; Display is obtained from parent.  Only non-nil attributes are passed on in
-  ;; the request: the function makes no assumptions about what the actual protocol
-  ;; defaults are.  Width and height are the inside size, excluding border.
-  (declare (type (or null window) window)
-	   (type window parent)		; required
-	   (type int16 x y) ;required
-	   (type card16 width height) ;required
-	   (type card16 depth border-width)
-	   (type (member :copy :input-output :input-only) class)
-	   (type (or (member :copy) visual-info resource-id) visual)
-	   (type (or null (member :none :parent-relative) pixel pixmap) background)
-	   (type (or null (member :copy) pixel pixmap) border)
-	   (type (or null bit-gravity) bit-gravity)
-	   (type (or null win-gravity) gravity)
-	   (type (or null (member :not-useful :when-mapped :always)) backing-store)
-	   (type (or null pixel) backing-planes backing-pixel)
-	   (type (or null event-mask) event-mask)
-	   (type (or null device-event-mask) do-not-propagate-mask)
-	   (type (or null (member :on :off)) save-under override-redirect)
-	   (type (or null (member :copy) colormap) colormap)
-	   (type (or null (member :none) cursor) cursor))
-  (declare (clx-values window))
-  (let* ((display (window-display parent))
-	 (window (or window (make-window :display display)))
-	 (wid (allocate-resource-id display window 'window))
-	 back-pixmap back-pixel
-	 border-pixmap border-pixel)
-    (declare (type display display)
-	     (type window window)
-	     (type resource-id wid)
-	     (type (or null resource-id) back-pixmap border-pixmap)
-	     (type (or null pixel) back-pixel border-pixel))
-    (setf (window-id window) wid)
-    (case background
-      ((nil) nil)
-      (:none (setq back-pixmap 0))
-      (:parent-relative (setq back-pixmap 1))
-      (otherwise
-       (if (type? background 'pixmap)
-	   (setq back-pixmap (pixmap-id background))
-	 (if (integerp background)
-	     (setq back-pixel background)
-	   (x-type-error background
-			 '(or null (member :none :parent-relative) integer pixmap))))))
-    (case border
-      ((nil) nil)
-      (:copy (setq border-pixmap 0))
-      (otherwise
-       (if (type? border 'pixmap)
-	   (setq border-pixmap (pixmap-id border))
-	 (if (integerp border)
-	     (setq border-pixel border)
-	   (x-type-error border '(or null (member :copy) integer pixmap))))))
-    (when event-mask
-      (setq event-mask (encode-event-mask event-mask)))
-    (when do-not-propagate-mask
-      (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask)))
-
-						;Make the request
-    (with-buffer-request (display *x-createwindow*)
-      (data depth)
-      (resource-id wid)
-      (window parent)
-      (int16 x y)
-      (card16 width height border-width)
-      ((member16 :copy :input-output :input-only) class)
-      (resource-id (cond ((eq visual :copy)
-			  0)
-			 ((typep visual 'resource-id)
-			  visual)
-			 (t
-			  (visual-info-id visual))))
-      (mask (card32 back-pixmap back-pixel border-pixmap border-pixel)
-	    ((member-vector *bit-gravity-vector*) bit-gravity)
-	    ((member-vector *win-gravity-vector*) gravity)
-	    ((member :not-useful :when-mapped :always) backing-store)
-	    (card32  backing-planes backing-pixel)
-	    ((member :off :on) override-redirect save-under)
-	    (card32 event-mask do-not-propagate-mask)
-	    ((or (member :copy) colormap) colormap)
-	    ((or (member :none) cursor) cursor)))
-    window))
-
-(defun destroy-window (window)
-  (declare (type window window))
-  (with-buffer-request ((window-display window) *x-destroywindow*)
-    (window window)))
-
-(defun destroy-subwindows (window)
-  (declare (type window window))
-  (with-buffer-request ((window-display window) *x-destroysubwindows*)
-    (window window)))
-
-(defun add-to-save-set (window)
-  (declare (type window window))
-  (with-buffer-request ((window-display window) *x-changesaveset*)
-    (data 0)
-    (window window)))
-
-(defun remove-from-save-set (window)
-  (declare (type window window))
-  (with-buffer-request ((window-display window) *x-changesaveset*)
-    (data 1)
-    (window window)))
-
-(defun reparent-window (window parent x y)
-  (declare (type window window parent)
-	   (type int16 x y))
-  (with-buffer-request ((window-display window) *x-reparentwindow*)
-    (window window parent)
-    (int16 x y)))
-
-(defun map-window (window)
-  (declare (type window window))
-  (with-buffer-request ((window-display window) *x-mapwindow*)
-    (window window)))
-
-(defun map-subwindows (window)
-  (declare (type window window))
-  (with-buffer-request ((window-display window) *x-mapsubwindows*)
-    (window window)))
-
-(defun unmap-window (window)
-  (declare (type window window))
-  (with-buffer-request ((window-display window) *x-unmapwindow*)
-    (window window)))
-
-(defun unmap-subwindows (window)
-  (declare (type window window))
-  (with-buffer-request ((window-display window) *x-unmapsubwindows*)
-    (window window)))
-
-(defun circulate-window-up (window)
-  (declare (type window window))
-  (with-buffer-request ((window-display window) *x-circulatewindow*)
-    (data 0)
-    (window window)))
-
-(defun circulate-window-down (window)
-  (declare (type window window))
-  (with-buffer-request ((window-display window) *x-circulatewindow*)
-    (data 1)
-    (window window)))
-
-(defun query-tree (window &key (result-type 'list))
-  (declare (type window window)
-	   (type t result-type)) ;;type specifier
-  (declare (clx-values (clx-sequence window) parent root))
-  (let ((display (window-display window)))
-    (multiple-value-bind (root parent sequence)
-	(with-buffer-request-and-reply (display *x-querytree* nil :sizes (8 16 32))
-	     ((window window))
-	  (values
-	    (window-get 8)
-	    (resource-id-get 12)
-	    (sequence-get :length (card16-get 16) :result-type result-type
-			  :index *replysize*)))
-      ;; Parent is NIL for root window
-      (setq parent (and (plusp parent) (lookup-window display parent)))
-      (dotimes (i (length sequence))		; Convert ID's to window's
-	(setf (elt sequence i) (lookup-window display (elt sequence i))))
-      (values sequence parent root))))
-
-;; Although atom-ids are not visible in the normal user interface, atom-ids might
-;; appear in window properties and other user data, so conversion hooks are needed.
-
-(defun intern-atom (display name)
-  (declare (type display display)
-	   (type xatom name))
-  (declare (clx-values resource-id))
-  (let ((name (if (or (null name) (keywordp name))
-		  name
-		(kintern (string name)))))
-    (declare (type symbol name))
-    (or (atom-id name display)
-	(let ((string (symbol-name name)))
-	  (declare (type string string))
-	  (multiple-value-bind (id)
-	      (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32)
-		   ((data 0)
-		    (card16 (length string))
-		    (pad16 nil)
-		    (string string))
-		(values
-		  (resource-id-get 8)))
-	    (declare (type resource-id id))
-	    (setf (atom-id name display) id)
-	    id)))))
-
-(defun find-atom (display name)
-  ;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True
-  (declare (type display display)
-	   (type xatom name))
-  (declare (clx-values (or null resource-id)))
-  (let ((name (if (or (null name) (keywordp name))
-		  name
-		(kintern (string name)))))
-    (declare (type symbol name))
-    (or (atom-id name display)
-	(let ((string (symbol-name name)))
-	  (declare (type string string))
-	  (multiple-value-bind (id)
-	      (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32)
-		   ((data 1)
-		    (card16 (length string))
-		    (pad16 nil)
-		    (string string))
-		(values
-		  (or-get 8 null resource-id)))
-	    (declare (type (or null resource-id) id))
-	    (when id 
-	      (setf (atom-id name display) id))
-	    id)))))
-
-(defun atom-name (display atom-id)
-  (declare (type display display)
-	   (type resource-id atom-id))
-  (declare (clx-values keyword))
-  (if (zerop atom-id)
-      nil
-  (or (id-atom atom-id display)
-      (let ((keyword
-	      (kintern
-		  (with-buffer-request-and-reply
-		       (display *x-getatomname* nil :sizes (16))
-		     ((resource-id atom-id))
-		  (values
-		    (string-get (card16-get 8) *replysize*))))))
-	(declare (type keyword keyword))
-	(setf (atom-id keyword display) atom-id)
-	  keyword))))
-
-;;; For binary compatibility with older code
-(defun lookup-xatom (display atom-id)
-  (declare (type display display)
-	   (type resource-id atom-id))
-  (atom-name display atom-id))
-
-(defun change-property (window property data type format
-		       &key (mode :replace) (start 0) end transform)
-  ; Start and end affect sub-sequence extracted from data.
-  ; Transform is applied to each extracted element.
-  (declare (type window window)
-	   (type xatom property type)
-	   (type (member 8 16 32) format)
-	   (type sequence data)
-	   (type (member :replace :prepend :append) mode)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type (or null (function (t) integer)) transform))
-  (unless end (setq end (length data)))
-  (let* ((display (window-display window))
-	 (length (index- end start))
-	 (property-id (intern-atom display property))
-	 (type-id (intern-atom display type)))
-    (declare (type display display)
-	     (type array-index length)
-	     (type resource-id property-id type-id))
-    (with-buffer-request (display *x-changeproperty*)
-      ((data (member :replace :prepend :append)) mode)
-      (window window)
-      (resource-id property-id type-id)
-      (card8 format)
-      (card32 length)
-      (progn
-	(ecase format
-	  (8  (sequence-put 24 data :format card8
-			    :start start :end end :transform transform))
-	  (16 (sequence-put 24 data :format card16
-			    :start start :end end :transform transform))
-	  (32 (sequence-put 24 data :format card32
-			    :start start :end end :transform transform)))))))
-
-(defun delete-property (window property)
-  (declare (type window window)
-	   (type xatom property))
-  (let* ((display (window-display window))
-	 (property-id (intern-atom display property)))
-    (declare (type display display)
-	     (type resource-id property-id))
-    (with-buffer-request (display *x-deleteproperty*)
-      (window window)
-      (resource-id property-id))))
-
-(defun get-property (window property
-		     &key type (start 0) end delete-p (result-type 'list) transform)
-  ;; Transform is applied to each integer retrieved.
-  (declare (type window window)
-	   (type xatom property)
-	   (type (or null xatom) type)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type boolean delete-p)
-	   (type t result-type)			;a sequence type
-	   (type (or null (function (integer) t)) transform))
-  (declare (clx-values data (or null type) format bytes-after))
-  (let* ((display (window-display window))
-	 (property-id (intern-atom display property))
-	 (type-id (and type (intern-atom display type))))
-    (declare (type display display)
-	     (type resource-id property-id)
-	     (type (or null resource-id) type-id))
-    (multiple-value-bind (reply-format reply-type bytes-after data)
-	(with-buffer-request-and-reply (display *x-getproperty* nil :sizes (8 32))
-	     (((data boolean) delete-p)
-	      (window window)
-	      (resource-id property-id)
-	      ((or null resource-id) type-id)
-	      (card32 start)
-	      (card32 (index- (or end 64000) start)))
-	  (let ((reply-format (card8-get 1))
-		(reply-type (card32-get 8))
-		(bytes-after (card32-get 12))
-		(nitems (card32-get 16)))
-	    (values
-	      reply-format
-	      reply-type
-	      bytes-after
-	      (and (plusp nitems)
-		   (ecase reply-format
-		     (0  nil) ;; (make-sequence result-type 0) ;; Property not found.
-		     (8  (sequence-get :result-type result-type :format card8
-				       :length nitems :transform transform
-				       :index *replysize*))
-		     (16 (sequence-get :result-type result-type :format card16
-				       :length nitems :transform transform
-				       :index *replysize*))
-		     (32 (sequence-get :result-type result-type :format card32
-				       :length nitems :transform transform
-				       :index *replysize*)))))))
-      (values data
-	      (and (plusp reply-type) (atom-name display reply-type))
-	      reply-format
-	      bytes-after))))
-
-(defun rotate-properties (window properties &optional (delta 1))
-  ;; Positive rotates left, negative rotates right (opposite of actual protocol request).
-  (declare (type window window)
-	   (type sequence properties) ;; sequence of xatom
-	   (type int16 delta))
-  (let* ((display (window-display window))
-	 (length (length properties))
-	 (sequence (make-array length)))
-    (declare (type display display)
-	     (type array-index length))
-    (with-vector (sequence vector)
-      ;; Atoms must be interned before the RotateProperties request
-      ;; is started to allow InternAtom requests to be made.
-      (dotimes (i length)
-	(setf (aref sequence i) (intern-atom display (elt properties i))))
-      (with-buffer-request (display *x-rotateproperties*)
-	(window window)
-	(card16 length)
-	(int16 (- delta))
-	((sequence :end length) sequence))))
-  nil)
-
-(defun list-properties (window &key (result-type 'list))
-  (declare (type window window)
-	   (type t result-type)) ;; a sequence type
-  (declare (clx-values (clx-sequence keyword)))
-  (let ((display (window-display window)))
-    (multiple-value-bind (seq)
-	(with-buffer-request-and-reply (display *x-listproperties* nil :sizes 16)
-	     ((window window))
-	  (values
-	    (sequence-get :result-type result-type :length (card16-get 8)
-			  :index *replysize*)))
-      ;; lookup the atoms in the sequence
-      (if (listp seq)
-	  (do ((elt seq (cdr elt)))
-	      ((endp elt) seq)
-	    (setf (car elt) (atom-name display (car elt))))
-	(dotimes (i (length seq) seq)
-	  (setf (aref seq i) (atom-name display (aref seq i))))))))
-
-(defun selection-owner (display selection)
-  (declare (type display display)
-	   (type xatom selection))
-  (declare (clx-values (or null window)))
-  (let ((selection-id (intern-atom display selection)))
-    (declare (type resource-id selection-id))
-    (multiple-value-bind (window)
-	(with-buffer-request-and-reply (display *x-getselectionowner* 12 :sizes 32)
-	     ((resource-id selection-id))
-	  (values
-	    (resource-id-or-nil-get 8)))
-      (and window (lookup-window display window)))))
-
-(defun set-selection-owner (display selection owner &optional time)
-  (declare (type display display)
-	   (type xatom selection)
-	   (type (or null window) owner)
-	   (type timestamp time))
-  (let ((selection-id (intern-atom display selection)))
-    (declare (type resource-id selection-id))
-    (with-buffer-request (display *x-setselectionowner*)
-      ((or null window) owner)
-      (resource-id selection-id)
-      ((or null card32) time))
-    owner))
-
-(defsetf selection-owner (display selection &optional time) (owner)
-  ;; A bit strange, but retains setf form.
-  `(set-selection-owner ,display ,selection ,owner ,time))
-
-(defun convert-selection (selection type requestor &optional property time)
-  (declare (type xatom selection type)
-	   (type window requestor)
-	   (type (or null xatom) property)
-	   (type timestamp time))
-  (let* ((display (window-display requestor))
-	 (selection-id (intern-atom display selection))
-	 (type-id (intern-atom display type))
-	 (property-id (and property (intern-atom display property))))
-    (declare (type display display)
-	     (type resource-id selection-id type-id)
-	     (type (or null resource-id) property-id))
-    (with-buffer-request (display *x-convertselection*)
-      (window requestor)
-      (resource-id selection-id type-id)
-      ((or null resource-id) property-id)
-      ((or null card32) time))))
-
-(defun send-event (window event-key event-mask &rest args
-		   &key propagate-p display &allow-other-keys)
-  ;; Additional arguments depend on event-key, and are as specified further below
-  ;; with declare-event, except that both resource-ids and resource objects are
-  ;; accepted in the event components.  The display argument is only required if the
-  ;; window is :pointer-window or :input-focus.
-  (declare (type (or window (member :pointer-window :input-focus)) window)
-	   (type event-key event-key)
-	   (type (or null event-mask) event-mask)
-	   (type boolean propagate-p)
-	   (type (or null display) display)
-	   (dynamic-extent args))
-  (unless event-mask (setq event-mask 0))
-  (unless display (setq display (window-display window)))
-  (let ((internal-event-code (get-event-code event-key))
-	(external-event-code (get-external-event-code display event-key)))
-    (declare (type card8 internal-event-code external-event-code))
-    ;; Ensure keyword atom-id's are cached
-    (dolist (arg (cdr (assoc event-key '((:property-notify :atom)
-					 (:selection-clear :selection)
-					 (:selection-request :selection :target :property)
-					 (:selection-notify :selection :target :property)
-					 (:client-message :type))
-			     :test #'eq)))
-      (let ((keyword (getf args arg)))
-	(intern-atom display keyword)))
-    ;; Make the sendevent request
-    (with-buffer-request (display *x-sendevent*)
-      ((data boolean) propagate-p)
-      (length 11) ;; 3 word request + 8 words for event = 11
-      ((or (member :pointer-window :input-focus) window) window)
-      (card32 (encode-event-mask event-mask))
-      (card8 external-event-code)
-      (progn
-	(apply (svref *event-send-vector* internal-event-code) display args)
-	(setf (buffer-boffset display) (index+ buffer-boffset 44))))))
-
-(defun grab-pointer (window event-mask
-		     &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time)
-  (declare (type window window)
-	   (type pointer-event-mask event-mask)
-	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
-	   (type (or null window) confine-to)
-	   (type (or null cursor) cursor)
-	   (type timestamp time))
-  (declare (clx-values grab-status))
-  (let ((display (window-display window)))
-    (with-buffer-request-and-reply (display *x-grabpointer* nil :sizes 8)
-	 (((data boolean) owner-p)
-	  (window window)
-	  (card16 (encode-pointer-event-mask event-mask))
-	  (boolean (not sync-pointer-p) (not sync-keyboard-p))
-	  ((or null window) confine-to)
-	  ((or null cursor) cursor)
-	  ((or null card32) time))
-      (values
-	(member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen)))))
-
-(defun ungrab-pointer (display &key time)
-  (declare (type timestamp time))
-  (with-buffer-request (display *x-ungrabpointer*)
-    ((or null card32) time)))
-
-(defun grab-button (window button event-mask
-		    &key (modifiers 0)
-			 owner-p sync-pointer-p sync-keyboard-p confine-to cursor)
-  (declare (type window window)
-	   (type (or (member :any) card8) button)
-	   (type modifier-mask modifiers)
-	   (type pointer-event-mask event-mask)
-	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
-	   (type (or null window) confine-to)
-	   (type (or null cursor) cursor))
-  (with-buffer-request ((window-display window) *x-grabbutton*)
-    ((data boolean) owner-p)
-    (window window)
-    (card16 (encode-pointer-event-mask event-mask))
-    (boolean (not sync-pointer-p) (not sync-keyboard-p))
-    ((or null window) confine-to)
-    ((or null cursor) cursor)
-    (card8 (if (eq button :any) 0 button))
-    (pad8 1)
-    (card16 (encode-modifier-mask modifiers))))
-
-(defun ungrab-button (window button &key (modifiers 0))
-  (declare (type window window)
-	   (type (or (member :any) card8) button)
-	   (type modifier-mask modifiers))
-  (with-buffer-request ((window-display window) *x-ungrabbutton*)
-    (data (if (eq button :any) 0 button))
-    (window window)
-    (card16 (encode-modifier-mask modifiers))))
-
-(defun change-active-pointer-grab (display event-mask &optional cursor time)
-  (declare (type display display)
-	   (type pointer-event-mask event-mask)
-	   (type (or null cursor) cursor)
-	   (type timestamp time))
-  (with-buffer-request (display *x-changeactivepointergrab*)
-    ((or null cursor) cursor)
-    ((or null card32) time)
-    (card16 (encode-pointer-event-mask event-mask))))
-
-(defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time)
-  (declare (type window window)
-	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
-	   (type timestamp time))
-  (declare (clx-values grab-status))
-  (let ((display (window-display window)))
-    (with-buffer-request-and-reply (display *x-grabkeyboard* nil :sizes 8)
-	 (((data boolean) owner-p)
-	  (window window)
-	  ((or null card32) time)
-	  (boolean (not sync-pointer-p) (not sync-keyboard-p)))
-      (values
-	(member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen)))))
-
-(defun ungrab-keyboard (display &key time)
-  (declare (type display display)
-	   (type timestamp time))
-  (with-buffer-request (display *x-ungrabkeyboard*)
-    ((or null card32) time)))
-
-(defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p)
-  (declare (type window window)
-	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
-	   (type (or (member :any) card8) key)
-	   (type modifier-mask modifiers))
-  (with-buffer-request ((window-display window) *x-grabkey*)
-    ((data boolean) owner-p)
-    (window window)
-    (card16 (encode-modifier-mask modifiers))
-    (card8 (if (eq key :any) 0 key))
-    (boolean (not sync-pointer-p) (not sync-keyboard-p))))
-
-(defun ungrab-key (window key &key (modifiers 0))
-  (declare (type window window)
-	   (type (or (member :any) card8) key)
-	   (type modifier-mask modifiers))
-  (with-buffer-request ((window-display window) *x-ungrabkey*)
-    (data (if (eq key :any) 0 key))
-    (window window)
-    (card16 (encode-modifier-mask modifiers))))
-
-(defun allow-events (display mode &optional time)
-  (declare (type display display)
-	   (type (member :async-pointer :sync-pointer :replay-pointer
-			 :async-keyboard :sync-keyboard :replay-keyboard
-			 :async-both :sync-both)
-		 mode)
-	   (type timestamp time))
-  (with-buffer-request (display *x-allowevents*)
-    ((data (member :async-pointer :sync-pointer :replay-pointer
-		   :async-keyboard :sync-keyboard :replay-keyboard
-		   :async-both :sync-both))
-     mode)
-    ((or null card32) time)))
-
-(defun grab-server (display)
-  (declare (type display display))
-  (with-buffer-request (display *x-grabserver*)))
-
-(defun ungrab-server (display)
-  (with-buffer-request (display *x-ungrabserver*)))
-
-(defmacro with-server-grabbed ((display) &body body)
-  ;; The body is not surrounded by a with-display.
-  (let ((disp (if (symbolp display) display (gensym))))
-    `(let ((,disp ,display))
-       (declare (type display ,disp))
-       (unwind-protect
-	   (progn
-	     (grab-server ,disp)
-	     ,@body)
-	 (ungrab-server ,disp)))))
-
-(defun query-pointer (window)
-  (declare (type window window))
-  (declare (clx-values x y same-screen-p child mask root-x root-y root))
-  (let ((display (window-display window)))
-    (with-buffer-request-and-reply (display *x-querypointer* 26 :sizes (8 16 32))
-	 ((window window))
-      (values
-	(int16-get 20)
-	(int16-get 22)
-	(boolean-get 1)
-	(or-get 12 null window)
-	(card16-get 24)
-	(int16-get 16)
-	(int16-get 18)
-	(window-get 8)))))
-
-(defun pointer-position (window)
-  (declare (type window window))
-  (declare (clx-values x y same-screen-p))
-  (let ((display (window-display window)))
-    (with-buffer-request-and-reply (display *x-querypointer* 24 :sizes (8 16))
-	 ((window window))
-      (values
-	(int16-get 20)
-	(int16-get 22)
-	(boolean-get 1)))))
-
-(defun global-pointer-position (display)
-  (declare (type display display))
-  (declare (clx-values root-x root-y root))
-  (with-buffer-request-and-reply (display *x-querypointer* 20 :sizes (16 32))
-       ((window (screen-root (first (display-roots display)))))
-    (values
-      (int16-get 16)
-      (int16-get 18)
-      (window-get 8))))
-
-(defun motion-events (window &key start stop (result-type 'list))
-  (declare (type window window)
-	   (type timestamp start stop)
-	   (type t result-type)) ;; a type specifier
-  (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time))))
-  (let ((display (window-display window)))
-    (with-buffer-request-and-reply (display *x-getmotionevents* nil :sizes 32)
-	 ((window window)
-	  ((or null card32) start stop))
-      (values
-	(sequence-get :result-type result-type :length (index* (card32-get 8) 3)
-		      :index *replysize*)))))
-
-(defun translate-coordinates (src src-x src-y dst)
-  ;; Returns NIL when not on the same screen
-  (declare (type window src)
-	   (type int16 src-x src-y)
-	   (type window dst))
-  (declare (clx-values dst-x dst-y child))
-  (let ((display (window-display src)))
-    (with-buffer-request-and-reply (display *x-translatecoords* 16 :sizes (8 16 32))
-	 ((window src dst)
-	  (int16 src-x src-y))
-      (and (boolean-get 1)
-	   (values
-	     (int16-get 12)
-	     (int16-get 14)
-	     (or-get 8 null window))))))
-
-(defun warp-pointer (dst dst-x dst-y)
-  (declare (type window dst)
-	   (type int16 dst-x dst-y))
-  (with-buffer-request ((window-display dst) *x-warppointer*)
-    (resource-id 0) ;; None
-    (window dst)
-    (int16 0 0)
-    (card16 0 0)
-    (int16 dst-x dst-y)))
-
-(defun warp-pointer-relative (display x-off y-off)
-  (declare (type display display)
-	   (type int16 x-off y-off))
-  (with-buffer-request (display *x-warppointer*)
-    (resource-id 0) ;; None
-    (resource-id 0) ;; None
-    (int16 0 0)
-    (card16 0 0)
-    (int16 x-off y-off)))
-
-(defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y
-			       &optional src-width src-height)
-  ;; Passing in a zero src-width or src-height is a no-op.
-  ;; A null src-width or src-height translates into a zero value in the protocol request.
-  (declare (type window dst src)
-	   (type int16 dst-x dst-y src-x src-y)
-	   (type (or null card16) src-width src-height))
-  (unless (or (eql src-width 0) (eql src-height 0))
-    (with-buffer-request ((window-display dst) *x-warppointer*)
-      (window src dst)
-      (int16 src-x src-y)
-      (card16 (or src-width 0) (or src-height 0))
-      (int16 dst-x dst-y))))
-
-(defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y
-					&optional src-width src-height)
-  ;; Passing in a zero src-width or src-height is a no-op.
-  ;; A null src-width or src-height translates into a zero value in the protocol request.
-  (declare (type window src)
-	   (type int16 x-off y-off src-x src-y)
-	   (type (or null card16) src-width src-height))
-  (unless (or (eql src-width 0) (eql src-height 0))
-    (with-buffer-request ((window-display src) *x-warppointer*)
-      (window src)
-      (resource-id 0) ;; None
-      (int16 src-x src-y)
-      (card16 (or src-width 0) (or src-height 0))
-      (int16 x-off y-off))))
-
-(defun set-input-focus (display focus revert-to &optional time)
-  (declare (type display display)
-	   (type (or (member :none :pointer-root) window) focus)
-	   (type (member :none :pointer-root :parent) revert-to)
-	   (type timestamp time))
-  (with-buffer-request (display *x-setinputfocus*)
-    ((data (member :none :pointer-root :parent)) revert-to)
-    ((or window (member :none :pointer-root)) focus)
-    ((or null card32) time)))
-
-(defun input-focus (display)
-  (declare (type display display))
-  (declare (clx-values focus revert-to))
-  (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32))
-       ()
-    (values
-      (or-get 8 (member :none :pointer-root) window)
-      (member8-get 1 :none :pointer-root :parent))))
-
-(defun query-keymap (display &optional bit-vector)
-  (declare (type display display)
-	   (type (or null (bit-vector 256)) bit-vector))
-  (declare (clx-values (bit-vector 256)))
-  (with-buffer-request-and-reply (display *x-querykeymap* 40 :sizes 8)
-       ()
-    (values
-      (bit-vector256-get 8 8 bit-vector))))
-
-(defun create-pixmap (&key
-		      pixmap
-		      (width (required-arg width))
-		      (height (required-arg height))
-		      (depth (required-arg depth))
-		      (drawable (required-arg drawable)))
-  (declare (type (or null pixmap) pixmap)
-	   (type card8 depth) ;; required
-	   (type card16 width height) ;; required
-	   (type drawable drawable)) ;; required
-  (declare (clx-values pixmap))
-  (let* ((display (drawable-display drawable))
-	 (pixmap (or pixmap (make-pixmap :display display)))
-	 (pid (allocate-resource-id display pixmap 'pixmap)))
-    (setf (pixmap-id pixmap) pid)
-    (with-buffer-request (display *x-createpixmap*)
-      (data depth)
-      (resource-id pid)
-      (drawable drawable)
-      (card16 width height))
-    pixmap))
-
-(defun free-pixmap (pixmap)
-  (declare (type pixmap pixmap))
-  (let ((display (pixmap-display pixmap)))
-    (with-buffer-request (display *x-freepixmap*)
-      (pixmap pixmap))
-    (deallocate-resource-id display (pixmap-id pixmap) 'pixmap)))
-
-(defun clear-area (window &key (x 0) (y 0) width height exposures-p)
-  ;; Passing in a zero width or height is a no-op.
-  ;; A null width or height translates into a zero value in the protocol request.
-  (declare (type window window)
-	   (type int16 x y)
-	   (type (or null card16) width height)
-	   (type boolean exposures-p))
-  (unless (or (eql width 0) (eql height 0))
-    (with-buffer-request ((window-display window) *x-cleartobackground*)
-      ((data boolean) exposures-p)
-      (window window)
-      (int16 x y)
-      (card16 (or width 0) (or height 0)))))
-
-(defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y)
-  (declare (type drawable src dst)
-	   (type gcontext gcontext)
-	   (type int16 src-x src-y dst-x dst-y)
-	   (type card16 width height))
-  (with-buffer-request ((drawable-display src) *x-copyarea* :gc-force gcontext)
-    (drawable src dst)
-    (gcontext gcontext)
-    (int16 src-x src-y dst-x dst-y)
-    (card16 width height)))
-
-(defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y)
-  (declare (type drawable src dst)
-	   (type gcontext gcontext)
-	   (type pixel plane)
-	   (type int16 src-x src-y dst-x dst-y)
-	   (type card16 width height))
-  (with-buffer-request ((drawable-display src) *x-copyplane* :gc-force gcontext)
-    (drawable src dst)
-    (gcontext gcontext)
-    (int16 src-x src-y dst-x dst-y)
-    (card16 width height)
-    (card32 plane)))
-
-(defun create-colormap (visual-info window &optional alloc-p)
-  (declare (type (or visual-info resource-id) visual-info)
-	   (type window window)
-	   (type boolean alloc-p))
-  (declare (clx-values colormap))
-  (let ((display (window-display window)))
-    (when (typep visual-info 'resource-id)
-      (setf visual-info (visual-info display visual-info)))
-    (let* ((colormap (make-colormap :display display :visual-info visual-info))
-	   (id (allocate-resource-id display colormap 'colormap)))
-      (setf (colormap-id colormap) id)
-      (with-buffer-request (display *x-createcolormap*)
-	((data boolean) alloc-p)
-	(card29 id)
-	(window window)
-	(card29 (visual-info-id visual-info)))
-      colormap)))
-
-(defun free-colormap (colormap)
-  (declare (type colormap colormap))
-  (let ((display (colormap-display colormap)))
-    (with-buffer-request (display *x-freecolormap*)
-      (colormap colormap))
-    (deallocate-resource-id display (colormap-id colormap) 'colormap)))
-
-(defun copy-colormap-and-free (colormap)
-  (declare (type colormap colormap))
-  (declare (clx-values colormap))
-  (let* ((display (colormap-display colormap))
-	 (new-colormap (make-colormap :display display
-				      :visual-info (colormap-visual-info colormap)))
-	 (id (allocate-resource-id display new-colormap 'colormap)))
-    (setf (colormap-id new-colormap) id)
-    (with-buffer-request (display *x-copycolormapandfree*)
-      (resource-id id)
-      (colormap colormap))
-    new-colormap))
-
-(defun install-colormap (colormap)
-  (declare (type colormap colormap))
-  (with-buffer-request ((colormap-display colormap) *x-installcolormap*)
-    (colormap colormap)))
-
-(defun uninstall-colormap (colormap)
-  (declare (type colormap colormap))
-  (with-buffer-request ((colormap-display colormap) *x-uninstallcolormap*)
-    (colormap colormap)))
-
-(defun installed-colormaps (window &key (result-type 'list))
-  (declare (type window window)
-	   (type t result-type)) ;; CL type
-  (declare (clx-values (clx-sequence colormap)))
-  (let ((display (window-display window)))
-    (flet ((get-colormap (id)
-	     (lookup-colormap display id)))
-      (with-buffer-request-and-reply (display *x-listinstalledcolormaps* nil :sizes 16)
-	   ((window window))
-	(values
-	  (sequence-get :result-type result-type :length (card16-get 8)
-			:transform #'get-colormap :index *replysize*))))))
-
-(defun alloc-color (colormap color)
-  (declare (type colormap colormap)
-	   (type (or stringable color) color))
-  (declare (clx-values pixel screen-color exact-color))
-  (let ((display (colormap-display colormap)))
-    (etypecase color
-      (color
-	(with-buffer-request-and-reply (display *x-alloccolor* 20 :sizes (16 32))
-	     ((colormap colormap)
-	      (rgb-val (color-red color)
-		       (color-green color)
-		       (color-blue color))
-	      (pad16 nil))
-	  (values
-	    (card32-get 16)
-	    (make-color :red (rgb-val-get 8)
-			:green (rgb-val-get 10)
-			:blue (rgb-val-get 12))
-	    color)))
-      (stringable
-	(let* ((string (string color))
-	       (length (length string)))
-	  (with-buffer-request-and-reply (display *x-allocnamedcolor* 24 :sizes (16 32))
-	       ((colormap colormap)
-		(card16 length)
-		(pad16 nil)
-		(string string))
-	    (values
-	      (card32-get 8)
-	      (make-color :red (rgb-val-get 18)
-			  :green (rgb-val-get 20)
-			  :blue (rgb-val-get 22))
-	      (make-color :red (rgb-val-get 12)
-			  :green (rgb-val-get 14)
-			  :blue (rgb-val-get 16)))))))))
-
-(defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list))
-  (declare (type colormap colormap)
-	   (type card16 colors planes)
-	   (type boolean contiguous-p)
-	   (type t result-type)) ;; CL type
-  (declare (clx-values (clx-sequence pixel) (clx-sequence mask)))
-  (let ((display (colormap-display colormap)))
-    (with-buffer-request-and-reply (display *x-alloccolorcells* nil :sizes 16)
-	 (((data boolean) contiguous-p)
-	  (colormap colormap)
-	  (card16 colors planes))
-      (let ((pixel-length (card16-get 8))
-	    (mask-length (card16-get 10)))
-	(values
-	  (sequence-get :result-type result-type :length pixel-length :index *replysize*)
-	  (sequence-get :result-type result-type :length mask-length
-			:index (index+ *replysize* (index* pixel-length 4))))))))
-
-(defun alloc-color-planes (colormap colors
-			   &key (reds 0) (greens 0) (blues 0)
-			   contiguous-p (result-type 'list))
-  (declare (type colormap colormap)
-	   (type card16 colors reds greens blues)
-	   (type boolean contiguous-p)
-	   (type t result-type)) ;; CL type
-  (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask))
-  (let ((display (colormap-display colormap)))
-    (with-buffer-request-and-reply (display *x-alloccolorplanes* nil :sizes (16 32))
-	 (((data boolean) contiguous-p)
-	  (colormap colormap)
-	  (card16 colors reds greens blues))
-      (let ((red-mask (card32-get 12))
-	    (green-mask (card32-get 16))
-	    (blue-mask (card32-get 20)))
-	(values
-	  (sequence-get :result-type result-type :length (card16-get 8) :index *replysize*)
-	  red-mask green-mask blue-mask)))))
-
-(defun free-colors (colormap pixels &optional (plane-mask 0))
-  (declare (type colormap colormap)
-	   (type sequence pixels) ;; Sequence of integers
-	   (type pixel plane-mask))
-  (with-buffer-request ((colormap-display colormap) *x-freecolors*)
-    (colormap colormap)
-    (card32 plane-mask)
-    (sequence pixels)))
-
-(defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t))
-  (declare (type colormap colormap)
-	   (type pixel pixel)
-	   (type (or stringable color) spec)
-	   (type boolean red-p green-p blue-p))
-  (let ((display (colormap-display colormap))
-	(flags 0))
-    (declare (type display display)
-	     (type card8 flags))
-    (when red-p (setq flags 1))
-    (when green-p (incf flags 2))
-    (when blue-p (incf flags 4))
-    (etypecase spec
-      (color
-	(with-buffer-request (display *x-storecolors*)
-	  (colormap colormap)
-	  (card32 pixel)
-	  (rgb-val (color-red spec)
-		   (color-green spec)
-		   (color-blue spec))
-	  (card8 flags)
-	  (pad8 nil)))
-      (stringable
-	(let* ((string (string spec))
-	       (length (length string)))
-	  (with-buffer-request (display *x-storenamedcolor*)
-	    ((data card8) flags)
-	    (colormap colormap)
-	    (card32 pixel)
-	    (card16 length)
-	    (pad16 nil)
-	    (string string)))))))
-
-(defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t))
-  ;; If stringables are specified for colors, it is unspecified whether all
-  ;; stringables are first resolved and then a single StoreColors protocol request is
-  ;; issued, or whether multiple StoreColors protocol requests are issued.
-  (declare (type colormap colormap)
-	   (type sequence specs)
-	   (type boolean red-p green-p blue-p))
-  (etypecase specs
-    (list
-      (do ((spec specs (cddr spec)))
-	  ((endp spec))
-	(store-color colormap (car spec) (cadr spec) :red-p red-p :green-p green-p :blue-p blue-p)))
-    (vector
-      (do ((i 0 (+ i 2))
-	   (len (length specs)))
-	  ((>= i len))
-	(store-color colormap (aref specs i) (aref specs (1+ i)) :red-p red-p :green-p green-p :blue-p blue-p)))))
-
-(defun query-colors (colormap pixels &key (result-type 'list))
-  (declare (type colormap colormap)
-	   (type sequence pixels) ;; sequence of integer
-	   (type t result-type))   ;; a type specifier
-  (declare (clx-values (clx-sequence color)))
-  (let ((display (colormap-display colormap)))
-    (with-buffer-request-and-reply (display *x-querycolors* nil :sizes (8 16))
-	 ((colormap colormap)
-	  (sequence pixels))
-      (let ((sequence (make-sequence result-type (card16-get 8))))
-	(advance-buffer-offset *replysize*)
-	(dotimes (i (length sequence) sequence)
-	  (setf (elt sequence i)
-		(make-color :red (rgb-val-get 0)
-			    :green (rgb-val-get 2)
-			    :blue (rgb-val-get 4)))
-	  (advance-buffer-offset 8))))))
-
-(defun lookup-color (colormap name)
-  (declare (type colormap colormap)
-	   (type stringable name))
-  (declare (clx-values screen-color true-color))
-  (let* ((display (colormap-display colormap))
-	 (string (string name))
-	 (length (length string)))
-    (with-buffer-request-and-reply (display *x-lookupcolor* 20 :sizes 16)
-	 ((colormap colormap)
-	  (card16 length)
-	  (pad16 nil)
-	  (string string))
-      (values
-	(make-color :red (rgb-val-get 14)
-		    :green (rgb-val-get 16)
-		    :blue (rgb-val-get 18))
-	(make-color :red (rgb-val-get 8)
-		    :green (rgb-val-get 10)
-		    :blue (rgb-val-get 12))))))
-
-(defun create-cursor (&key
-		      (source (required-arg source))
-		      mask
-		      (x (required-arg x))
-		      (y (required-arg y))
-		      (foreground (required-arg foreground))
-		      (background (required-arg background)))
-  (declare (type pixmap source) ;; required
-	   (type (or null pixmap) mask)
-	   (type card16 x y) ;; required
-	   (type (or null color) foreground background)) ;; required
-  (declare (clx-values cursor))
-  (let* ((display (pixmap-display source))
-	 (cursor (make-cursor :display display))
-	 (cid (allocate-resource-id display cursor 'cursor)))
-    (setf (cursor-id cursor) cid)
-    (with-buffer-request (display *x-createcursor*)
-      (resource-id cid)
-      (pixmap source)
-      ((or null pixmap) mask)
-      (rgb-val (color-red foreground)
-	       (color-green foreground)
-	       (color-blue foreground))
-      (rgb-val (color-red background)
-	       (color-green background)
-	       (color-blue background))
-      (card16 x y))
-    cursor))
-
-(defun create-glyph-cursor (&key
-			    (source-font (required-arg source-font))
-			    (source-char (required-arg source-char))
-			    mask-font
-			    mask-char
-			    (foreground (required-arg foreground))
-			    (background (required-arg background)))
-  (declare (type font source-font) ;; Required
-	   (type card16 source-char) ;; Required
-	   (type (or null font) mask-font)
-	   (type (or null card16) mask-char)
-	   (type color foreground background)) ;; required
-  (declare (clx-values cursor))
-  (let* ((display (font-display source-font))
-	 (cursor (make-cursor :display display))
-	 (cid (allocate-resource-id display cursor 'cursor))
-	 (source-font-id (font-id source-font))
-	 (mask-font-id (if mask-font (font-id mask-font) 0)))
-    (setf (cursor-id cursor) cid)
-    (unless mask-char (setq mask-char 0))
-    (with-buffer-request (display *x-createglyphcursor*)
-      (resource-id cid source-font-id mask-font-id)
-      (card16 source-char)
-      (card16 mask-char)
-      (rgb-val (color-red foreground)
-	       (color-green foreground)
-	       (color-blue foreground))
-      (rgb-val (color-red background)
-	       (color-green background)
-	       (color-blue background)))
-    cursor))
-
-(defun free-cursor (cursor)
-  (declare (type cursor cursor))
-  (let ((display (cursor-display cursor)))
-    (with-buffer-request (display *x-freecursor*)
-      (cursor cursor))
-    (deallocate-resource-id display (cursor-id cursor) 'cursor)))
-
-(defun recolor-cursor (cursor foreground background)
-  (declare (type cursor cursor)
-	   (type color foreground background))
-  (with-buffer-request ((cursor-display cursor) *x-recolorcursor*)
-    (cursor cursor)
-    (rgb-val (color-red foreground)
-	     (color-green foreground)
-	     (color-blue foreground))
-    (rgb-val (color-red background)
-	     (color-green background)
-	     (color-blue background))
-    ))
-
-(defun query-best-cursor (width height drawable)
-  (declare (type card16 width height)
-	   (type (or drawable display) drawable))	
-  (declare (clx-values width height))
-  ;; Drawable can be a display for compatibility.
-  (multiple-value-bind (display drawable)
-      (if (type? drawable 'drawable)
-	  (values (drawable-display drawable) drawable)
-	(values drawable (screen-root (display-default-screen drawable))))
-    (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)
-	 ((data 0)
-	  (window drawable)
-	  (card16 width height))
-      (values
-	(card16-get 8)
-	(card16-get 10)))))
-
-(defun query-best-tile (width height drawable)
-  (declare (type card16 width height)
-	   (type drawable drawable))
-  (declare (clx-values width height))
-  (let ((display (drawable-display drawable)))
-    (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)
-	 ((data 1)
-	  (drawable drawable)
-	  (card16 width height))
-      (values
-	(card16-get 8)
-	(card16-get 10)))))
-
-(defun query-best-stipple (width height drawable)
-  (declare (type card16 width height)
-	   (type drawable drawable))
-  (declare (clx-values width height))
-  (let ((display (drawable-display drawable)))
-    (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)
-	 ((data 2)
-	  (drawable drawable)
-	  (card16 width height))
-      (values
-	(card16-get 8)
-	(card16-get 10)))))
-
-(defun query-extension (display name)
-  (declare (type display display)
-	   (type stringable name))
-  (declare (clx-values major-opcode first-event first-error))
-  (let ((string (string name)))
-    (with-buffer-request-and-reply (display *x-queryextension* 12 :sizes 8)
-	 ((card16 (length string))
-	  (pad16 nil)
-	  (string string))
-      (and (boolean-get 8)    ;; If present
-	   (values
-	     (card8-get 9)
-	     (card8-get 10)
-	     (card8-get 11))))))
-
-(defun list-extensions (display &key (result-type 'list))
-  (declare (type display display)
-	   (type t result-type)) ;; CL type
-  (declare (clx-values (clx-sequence string)))
-  (with-buffer-request-and-reply (display *x-listextensions* size :sizes 8)
-       ()
-    (values
-      (read-sequence-string
-	buffer-bbuf (index- size *replysize*) (card8-get 1) result-type *replysize*))))
-
-(defun change-keyboard-control (display &key key-click-percent
-				bell-percent bell-pitch bell-duration
-				led led-mode key auto-repeat-mode)
-  (declare (type display display)
-	   (type (or null (member :default) int16) key-click-percent
-						   bell-percent bell-pitch bell-duration)
-	   (type (or null card8) led key)
-	   (type (or null (member :on :off)) led-mode)
-	   (type (or null (member :on :off :default)) auto-repeat-mode))
-  (when (eq key-click-percent :default) (setq key-click-percent -1))
-  (when (eq bell-percent :default) (setq bell-percent -1))
-  (when (eq bell-pitch :default) (setq bell-pitch -1))
-  (when (eq bell-duration :default) (setq bell-duration -1))
-  (with-buffer-request (display *x-changekeyboardcontrol* :sizes (32))
-    (mask
-      (integer key-click-percent bell-percent bell-pitch bell-duration)
-      (card32 led)
-      ((member :off :on) led-mode)
-      (card32 key)
-      ((member :off :on :default) auto-repeat-mode))))
-
-(defun keyboard-control (display)
-  (declare (type display display))
-  (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration
-		  led-mask global-auto-repeat auto-repeats))
-  (with-buffer-request-and-reply (display *x-getkeyboardcontrol* 32 :sizes (8 16 32))
-       ()
-    (values
-      (card8-get 12)
-      (card8-get 13)
-      (card16-get 14)
-      (card16-get 16)
-      (card32-get 8)
-      (member8-get 1 :off :on)
-      (bit-vector256-get 32))))
-
-;;  The base volume should
-;; be considered to be the "desired" volume in the normal case; that is, a
-;; typical application should call XBell with 0 as the percent.  Rather
-;; than using a simple sum, the percent argument is instead used as the
-;; percentage of the remaining range to alter the base volume by.  That is,
-;; the actual volume is:
-;;	 if percent>=0:    base - [(base * percent) / 100] + percent
-;;	 if percent<0:     base + [(base * percent) / 100]
-
-(defun bell (display &optional (percent-from-normal 0))
-  ;; It is assumed that an eventual audio extension to X will provide more complete control.
-  (declare (type display display)
-	   (type int8 percent-from-normal))
-  (with-buffer-request (display *x-bell*)
-    (data (int8->card8 percent-from-normal))))
-
-(defun pointer-mapping (display &key (result-type 'list))
-  (declare (type display display)
-	   (type t result-type)) ;; CL type
-  (declare (clx-values sequence)) ;; Sequence of card
-  (with-buffer-request-and-reply (display *x-getpointermapping* nil :sizes 8)
-       ()
-    (values
-      (sequence-get :length (card8-get 1) :result-type result-type :format card8
-		    :index *replysize*))))
-
-(defun set-pointer-mapping (display map)
-  ;; Can signal device-busy.
-  (declare (type display display)
-	   (type sequence map)) ;; Sequence of card8
-  (when (with-buffer-request-and-reply (display *x-setpointermapping* 2 :sizes 8)
-	     ((data (length map))
-	      ((sequence :format card8) map))
-	  (values
-	    (boolean-get 1)))
-    (x-error 'device-busy :display display))
-  map)
-
-(defsetf pointer-mapping set-pointer-mapping)
-
-(defun change-pointer-control (display &key acceleration threshold)
-  ;; Acceleration is rationalized if necessary.
-  (declare (type display display)
-	   (type (or null (member :default) number) acceleration)
-	   (type (or null (member :default) integer) threshold))
-  (flet ((rationalize16 (number)
-	   ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers
-	   (declare (type number number))
-	   (declare (clx-values numerator denominator))
-	   (do* ((rational (rationalize number))
-		 (numerator (numerator rational) (ash numerator -1))
-		 (denominator (denominator rational) (ash denominator -1)))
-		((or (= numerator 1)
-		     (and (< (abs numerator) #x8000)
-			  (< denominator #x8000)))
-		 (values
-		   numerator (min denominator #x7fff))))))
-    (declare (inline rationalize16))
-    (let ((acceleration-p 1)
-	  (threshold-p 1)
-	  (numerator 0)
-	  (denominator 1))
-      (declare (type card8 acceleration-p threshold-p)
-	       (type int16 numerator denominator))
-      (cond ((eq acceleration :default) (setq numerator -1))
-	    (acceleration (multiple-value-setq (numerator denominator)
-			    (rationalize16 acceleration)))
-	    (t (setq acceleration-p 0)))
-      (cond ((eq threshold :default) (setq threshold -1))
-	    ((null threshold) (setq threshold -1
-				    threshold-p 0)))
-      (with-buffer-request (display *x-changepointercontrol*)
-	(int16 numerator denominator threshold)
-	(card8 acceleration-p threshold-p)))))
-
-(defun pointer-control (display)
-  (declare (type display display))
-  (declare (clx-values acceleration threshold))
-  (with-buffer-request-and-reply (display *x-getpointercontrol* 16 :sizes 16)
-       ()
-    (values
-      (/ (card16-get 8) (card16-get 10))	; Should we float this?
-      (card16-get 12))))
-
-(defun set-screen-saver (display timeout interval blanking exposures)
-  ;; Timeout and interval are in seconds, will be rounded to minutes.
-  (declare (type display display)
-	   (type (or (member :default) int16) timeout interval)
-	   (type (member :on :off :default :yes :no) blanking exposures))
-  (case blanking (:yes (setq blanking :on)) (:no (setq blanking :off)))
-  (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off)))
-  (when (eq timeout :default) (setq timeout -1))
-  (when (eq interval :default) (setq interval -1))
-  (with-buffer-request (display *x-setscreensaver*)
-    (int16 timeout interval)
-    ((member8 :on :off :default) blanking exposures)))
-
-(defun screen-saver (display)
-  ;; Returns timeout and interval in seconds.
-  (declare (type display display))
-  (declare (clx-values timeout interval blanking exposures))
-  (with-buffer-request-and-reply (display *x-getscreensaver* 14 :sizes (8 16))
-       ()
-    (values
-      (card16-get 8)
-      (card16-get 10)
-      (member8-get 12 :on :off :default)
-      (member8-get 13 :on :off :default))))
-
-(defun activate-screen-saver (display)
-  (declare (type display display))
-  (with-buffer-request (display *x-forcescreensaver*)
-    (data 1)))
-
-(defun reset-screen-saver (display)
-  (declare (type display display))
-  (with-buffer-request (display *x-forcescreensaver*)
-    (data 0)))
-
-(defun add-access-host (display host &optional (family :internet))
-  ;; A string must be acceptable as a host, but otherwise the possible types for
-  ;; host are not constrained, and will likely be very system dependent.
-  ;; This implementation uses a list whose car is the family keyword
-  ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
-  (declare (type display display)
-	   (type (or stringable list) host)
-	   (type (or null (member :internet :decnet :chaos) card8) family))
-  (change-access-host display host family nil))
-
-(defun remove-access-host (display host &optional (family :internet))
-  ;; A string must be acceptable as a host, but otherwise the possible types for
-  ;; host are not constrained, and will likely be very system dependent.
-  ;; This implementation uses a list whose car is the family keyword
-  ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
-  (declare (type display display)
-	   (type (or stringable list) host)
-	   (type (or null (member :internet :decnet :chaos) card8) family))
-  (change-access-host display host family t))
-
-(defun change-access-host (display host family remove-p)
-  (declare (type display display)
-	   (type (or stringable list) host)
-	   (type (or null (member :internet :decnet :chaos) card8) family))
-  (unless (consp host)
-    (setq host (host-address host family)))
-  (let ((family (car host))
-	(address (cdr host)))
-    (with-buffer-request (display *x-changehosts*)
-      ((data boolean) remove-p)
-      (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family))
-      (card16 (length address))
-      ((sequence :format card8) address))))
-
-(defun access-hosts (display &optional (result-type 'list))
-  ;; The type of host objects returned is not constrained, except that the hosts must
-  ;; be acceptable to add-access-host and remove-access-host.
-  ;; This implementation uses a list whose car is the family keyword
-  ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
-  (declare (type display display)
-	   (type t result-type)) ;; CL type
-  (declare (clx-values (clx-sequence host) enabled-p))
-  (with-buffer-request-and-reply (display *x-listhosts* nil :sizes (8 16))
-       ()
-    (let* ((enabled-p (boolean-get 1))
-	   (nhosts (card16-get 8))
-	   (sequence (make-sequence result-type nhosts)))
-      (advance-buffer-offset *replysize*)
-      (dotimes (i nhosts)
-	(let ((family (card8-get 0))
-	      (len (card16-get 2)))
-	  (setf (elt sequence i)
-		(cons (if (< family 3)
-			  (svref '#(:internet :decnet :chaos) family)
-			family)
-		      (sequence-get :length len :format card8 :result-type 'list
-				    :index (+ buffer-boffset 4))))
-	  (advance-buffer-offset (+ 4 (* 4 (ceiling len 4))))))
-      (values
-	sequence
-	enabled-p))))
-
-(defun access-control (display)
-  (declare (type display display))
-  (declare (clx-values boolean)) ;; True when access-control is ENABLED
-  (with-buffer-request-and-reply (display *x-listhosts* 2 :sizes 8)
-       ()
-    (boolean-get 1)))
-  
-(defun set-access-control (display enabled-p)
-  (declare (type display display)
-	   (type boolean enabled-p))
-  (with-buffer-request (display *x-changeaccesscontrol*)
-    ((data boolean) enabled-p))
-  enabled-p)
-
-(defsetf access-control set-access-control)
-
-(defun close-down-mode (display)
-  ;; setf'able
-  ;; Cached locally in display object.
-  (declare (type display display))
-  (declare (clx-values (member :destroy :retain-permanent :retain-temporary nil)))
-  (display-close-down-mode display))
-
-(defun set-close-down-mode (display mode)
-  ;; Cached locally in display object.
-  (declare (type display display)
-	   (type (member :destroy :retain-permanent :retain-temporary) mode))
-  (setf (display-close-down-mode display) mode)
-  (with-buffer-request (display *x-changeclosedownmode* :sizes (32))
-    ((data (member :destroy :retain-permanent :retain-temporary)) mode))
-  mode)
-
-(defsetf close-down-mode set-close-down-mode)
-
-(defun kill-client (display resource-id)
-  (declare (type display display)
-	   (type resource-id resource-id))
-  (with-buffer-request (display *x-killclient*)
-    (resource-id resource-id)))
-
-(defun kill-temporary-clients (display)
-  (declare (type display display))
-  (with-buffer-request (display *x-killclient*)
-    (resource-id 0)))
-
-(defun no-operation (display)
-  (declare (type display display))
-  (with-buffer-request (display *x-nooperation*)))
diff --git a/clx/resource.lisp b/clx/resource.lisp
deleted file mode 100644
index 3e7b74aab7e7e11278b8c158d9feceb9cdcd6894..0000000000000000000000000000000000000000
--- a/clx/resource.lisp
+++ /dev/null
@@ -1,696 +0,0 @@
-;;; -*- Mode:Common-Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
-
-;; RESOURCE - Lisp version of XLIB's Xrm resource manager
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-;; The C version of this uses a 64 entry hash table at each entry.
-;; Small hash tables lose in Lisp, so we do linear searches on lists.
-
-(defstruct (resource-database (:copier nil) (:predicate nil)
-			      (:print-function print-resource-database)
-			      (:constructor make-resource-database-internal)
-			      #+explorer (:callable-constructors nil)
-			      )
-  (name nil :type stringable :read-only t)
-  (value nil)
-  (tight nil :type list) ;; List of resource-database
-  (loose nil :type list) ;; List of resource-database
-  )
-
-(defun print-resource-database (database stream depth)
-  (declare (type resource-database database)
-	   (ignore depth))
-  (print-unreadable-object (database stream :type t)
-    (write-string (string (resource-database-name database)) stream)
-    (when (resource-database-value database)
-      (write-string " " stream)
-      (prin1 (resource-database-value database) stream))))
-
-;; The value slot of the top-level resource-database structure is used for a
-;; time-stamp.
-
-(defun make-resource-database ()
-  ;; Make a resource-database with initial timestamp of 0
-  (make-resource-database-internal :name "Top-Level" :value 0))
-
-(defun resource-database-timestamp (database)
-  (declare (type resource-database database))
-  (resource-database-value database))
-
-(defun incf-resource-database-timestamp (database)
-  ;; Increment the timestamp
-  (declare (type resource-database database))
-  (let ((timestamp (resource-database-value database)))
-    (setf (resource-database-value database)
-	  (if (= timestamp most-positive-fixnum)
-	      most-negative-fixnum
-	    (1+ timestamp)))))
-
-;; DEBUG FUNCTION  (not exported)
-(defun print-db (entry &optional (level 0) type)
-  ;; Debug function to print a resource database
-  (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]"
-	  level
-	  (resource-database-name entry)
-	  (eq type 'loose)
-	  (resource-database-value entry))
-  (when (resource-database-tight entry)
-    (dolist (tight (resource-database-tight entry))
-      (print-db tight (+ 2 level) 'tight)))
-  (when (resource-database-loose entry)
-    (dolist (loose (resource-database-loose entry))
-      (print-db loose (+ 2 level) 'loose))))
-
-;; DEBUG FUNCTION
-#+comment
-(defun print-search-table (table)
-  (terpri)
-  (dolist (dbase-list table)
-    (format t "~%~s" dbase-list)
-    (dolist (db dbase-list)
-      (print-db db)
-      (dolist (dblist table)
-	(unless (eq dblist dbase-list)
-	  (when (member db dblist)
-	    (format t "  duplicate at ~s" db))))
-      )))
-
-;;
-;; If this is true, resource symbols will be compared in a case-insensitive
-;; manner, and converting a resource string to a keyword will uppercaseify it.
-;;
-(defparameter *uppercase-resource-symbols* nil)
-
-(defun resource-key (stringable)
-  ;; Ensure STRINGABLE is a keyword.
-  (declare (type stringable stringable))
-  (etypecase stringable
-    (symbol
-      (if (keywordp (the symbol stringable))
-	  stringable
-	  (kintern (symbol-name (the symbol stringable)))))
-    (string
-      (if *uppercase-resource-symbols*
-	  (setq stringable (#-allegro string-upcase #+allegro correct-case
-			    (the string stringable))))
-      (kintern (the string stringable)))))
-
-(defun stringable-equal (a b)
-  ;; Compare two stringables.
-  ;; Ignore case when comparing to a symbol.
-  (declare (type stringable a b))
-  (declare (clx-values boolean))
-  (etypecase a
-    (string
-      (etypecase b
-	(string
-	  (string= (the string a) (the string b)))
-	(symbol
-	  (if *uppercase-resource-symbols*
-	      (string-equal (the string a)
-			    (the string (symbol-name (the symbol b))))
-	      (string= (the string a)
-		       (the string (symbol-name (the symbol b))))))))
-    (symbol
-      (etypecase b
-	(string
-	  (if *uppercase-resource-symbols*
-	      (string-equal (the string (symbol-name (the symbol a)))
-			    (the string b))
-	      (string= (the string (symbol-name (the symbol a)))
-		       (the string b))))
-	(symbol
-	  (string= (the string (symbol-name (the symbol a)))
-		   (the string (symbol-name (the symbol b)))))))))
-
-
-;;;-----------------------------------------------------------------------------
-;;; Add/delete resource
-
-(defun add-resource (database name-list value)
-  ;; name-list is a list of either strings or symbols. If a symbol, 
-  ;; case-insensitive comparisons will be used, if a string,
-  ;; case-sensitive comparisons will be used.  The symbol '* or
-  ;; string "*" are used as wildcards, matching anything or nothing.
-  (declare (type resource-database database)
-	   (type (clx-list stringable) name-list)
-	   (type t value))
-  (unless value (error "Null resource values are ignored"))
-  (incf-resource-database-timestamp database)
-  (do* ((list name-list (cdr list))
-	(name (car list) (car list))
-	(node database)
-	(loose-p nil))
-       ((endp list)
-	(setf (resource-database-value node) value))
-    ;; Key is the first name that isn't *
-    (if (stringable-equal name "*")
-	(setq loose-p t)
-      ;; find the entry associated with name
-      (progn
-	(do ((entry (if loose-p
-			(resource-database-loose node)
-		      (resource-database-tight node))
-		    (cdr entry)))
-	    ((endp entry)
-	     ;; Entry not found - create a new one
-	     (setq entry (make-resource-database-internal :name name))
-	     (if loose-p
-		 (push entry (resource-database-loose node))
-	       (push entry (resource-database-tight node)))
-	     (setq node entry))
-	  (when (stringable-equal name (resource-database-name (car entry)))
-	    ;; Found entry - use it
-	    (return (setq node (car entry)))))
-	(setq loose-p nil)))))
-
-
-(defun delete-resource (database name-list)
-  (declare (type resource-database database)
-	   (type list name-list))
-  (incf-resource-database-timestamp database)
-  (delete-resource-internal database name-list))
-
-(defun delete-resource-internal (database name-list)
-  (declare (type resource-database database)
-	   (type (clx-list stringable) name-list))
-  (do* ((list name-list (cdr list))
-	(string (car list) (car list))
-	(node database)
-	(loose-p nil))
-       ((endp list) nil)
-    ;; Key is the first name that isn't *
-    (if (stringable-equal string "*")
-	(setq loose-p t)
-      ;; find the entry associated with name
-      (progn 
-	(do* ((first-entry (if loose-p
-			       (resource-database-loose node)
-			     (resource-database-tight node)))
-	      (entry-list first-entry (cdr entry-list))
-	      (entry (car entry-list) (car entry-list)))
-	     ((endp entry-list)
-	      ;; Entry not found - exit
-	      (return-from delete-resource-internal nil))
-	  (when (stringable-equal string (resource-database-name entry))
-	    (when (cdr list) (delete-resource-internal entry (cdr list)))
-	    (when (and (null (resource-database-loose entry))
-		       (null (resource-database-tight entry)))
-	      (if loose-p
-		  (setf (resource-database-loose node)
-			(delete entry (resource-database-loose node)
-				:test #'eq :count 1))
-		(setf (resource-database-tight node)
-		      (delete entry (resource-database-tight node)
-			      :test #'eq :count 1))))
-	    (return-from delete-resource-internal t)))
-	(setq loose-p nil)))))
-
-;;;-----------------------------------------------------------------------------
-;;; Get Resource
-
-(defun get-resource (database value-name value-class full-name full-class)
-  ;; Return the value of the resource in DATABASE whose partial name
-  ;; most closely matches (append full-name (list value-name)) and
-  ;;                      (append full-class (list value-class)).
-  (declare (type resource-database database)
-	   (type stringable value-name value-class)
-	   (type (clx-list stringable) full-name full-class))
-  (declare (clx-values value))
-  (let ((names (append full-name (list value-name)))
-	(classes (append full-class (list value-class))))
-    (let* ((result (get-entry (resource-database-tight database)
-			      (resource-database-loose database)
-			      names classes)))
-      (when result
-	(resource-database-value result)))))
-
-(defun get-entry-lookup (table name names classes)
-  (declare (type list table names classes)
-	   (symbol name))
-  (dolist (entry table)
-    (declare (type resource-database entry))
-    (when (stringable-equal name (resource-database-name entry))
-      (if (null (cdr names))
-	  (return entry)
-	(let ((result (get-entry (resource-database-tight entry)
-				 (resource-database-loose entry)
-				 (cdr names) (cdr classes))))
-	  (declare (type (or null resource-database) result))
-	  (when result
-	    (return result)
-	    ))))))
-
-(defun get-entry (tight loose names classes &aux result)
-  (declare (type list tight loose names classes))
-  (let ((name (car names))
-	(class (car classes)))
-    (declare (type symbol name class))
-    (cond ((and tight
-		(get-entry-lookup tight name names classes)))
-	  ((and loose
-		(get-entry-lookup loose name names classes)))
-	  ((and tight
-		(not (stringable-equal name class))
-		(get-entry-lookup tight class names classes)))
-	  ((and loose
-		(not (stringable-equal name class))
-		(get-entry-lookup loose class names classes)))	
-	  (loose
-	   (loop
-	     (pop names) (pop classes)
-	     (unless (and names classes) (return nil))
-	     (setq name (car names)
-		   class (car classes))
-	     (when (setq result (get-entry-lookup loose name names classes))
-	       (return result))
-	     (when (and (not (stringable-equal name class))
-			(setq result
-			      (get-entry-lookup loose class names classes)))
-	       (return result))
-	     )))))
-
-
-;;;-----------------------------------------------------------------------------
-;;; Get-resource with search-table
-
-(defun get-search-resource (table name class)
-  ;; (get-search-resource (get-search-table database full-name full-class) 
-  ;;                      value-name value-class)
-  ;; is equivalent to 
-  ;; (get-resource database value-name value-class full-name full-class)
-  ;; But since most of the work is done by get-search-table,
-  ;; get-search-resource is MUCH faster when getting several resources with
-  ;; the same full-name/full-class
-  (declare (type list table)
-	   (type stringable name class))
-  (let ((do-class (and class (not (stringable-equal name class)))))
-    (dolist (dbase-list table)
-      (declare (type list dbase-list))
-      (dolist (dbase dbase-list)
-	(declare (type resource-database dbase))
-	(when (stringable-equal name (resource-database-name dbase))
-	  (return-from get-search-resource
-	    (resource-database-value dbase))))
-      (when do-class
-	(dolist (dbase dbase-list)
-	  (declare (type resource-database dbase))
-	  (when (stringable-equal class (resource-database-name dbase))
-	    (return-from get-search-resource
-	      (resource-database-value dbase))))))))
-
-(defvar *get-table-result*)
-
-(defun get-search-table (database full-name full-class)
-  ;; Return a search table for use with get-search-resource.
-  (declare (type resource-database database)
-	   (type (clx-list stringable) full-name full-class))
-  (declare (clx-values value))
-  (let* ((tight (resource-database-tight database))
-	 (loose (resource-database-loose database))
-	 (result (cons nil nil))
-	 (*get-table-result* result))
-    (declare (type list tight loose)
-	     (type cons result))
-    (when (or tight loose)
-      (when full-name
-	(get-tables tight loose full-name full-class))
-
-      ;; Pick up bindings of the form (* name). These are the elements of
-      ;; top-level loose without further tight/loose databases.
-      ;;
-      ;; (Hack: these bindings belong in ANY search table, so recomputing them
-      ;; is a drag.  True fix involves redesigning entire lookup
-      ;; data-structure/algorithm.)
-      ;;
-      (let ((universal-bindings
-	      (remove nil loose :test-not #'eq
-		      :key #'(lambda (database)
-			       (or (resource-database-tight database)
-				   (resource-database-loose database))))))
-	(when universal-bindings
-	  (setf (cdr *get-table-result*) (list universal-bindings)))))
-    (cdr result)))
-
-(defun get-tables-lookup (dbase name names classes)
-  (declare (type list dbase names classes)
-	   (type symbol name))
-  (declare (optimize speed))
-  (dolist (entry dbase)
-    (declare (type resource-database entry))
-    (when (stringable-equal name (resource-database-name entry))
-      (let ((tight (resource-database-tight entry))
-	    (loose (resource-database-loose entry)))
-	(declare (type list tight loose))
-	(when (or tight loose)
-	  (if (cdr names)
-	      (get-tables tight loose (cdr names) (cdr classes))
-	    (when tight
-	      (let ((result *get-table-result*))
-		;; Put tight at end of *get-table-result*
-		(setf (cdr result)
-		      (setq *get-table-result* (cons tight nil))))))
-	  (when loose
-	    (let ((result *get-table-result*))
-	      ;; Put loose at end of *get-table-result*
-	      (setf (cdr result)
-		    (setq *get-table-result* (cons loose nil))))))))))
-
-(defun get-tables (tight loose names classes)
-  (declare (type list tight loose names classes))
-  (let ((name (car names))
-	(class (car classes)))
-    (declare (type symbol name class))
-    (when tight
-      (get-tables-lookup tight name names classes))
-    (when loose
-      (get-tables-lookup loose name names classes))
-    (when (and tight (not (stringable-equal name class)))
-      (get-tables-lookup tight class names classes))
-    (when (and loose (not (stringable-equal name class)))
-      (get-tables-lookup loose class names classes))
-    (when loose
-      (loop
-	(pop names) (pop classes)
-	(unless (and names classes) (return nil))
-	(setq name (car names)
-	      class (car classes))
-	(get-tables-lookup loose name names classes)
-	(unless (stringable-equal name class)
-	  (get-tables-lookup loose class names classes))
-	))))
-
-
-;;;-----------------------------------------------------------------------------
-;;; Utility functions
-
-(defun map-resource (database function &rest args)
-  ;; Call FUNCTION on each resource in DATABASE.
-  ;; FUNCTION is called with arguments (name-list value . args)
-  (declare (type resource-database database)
-	   (type (function (list t &rest t) t) function)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent function)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg function)
-	   (dynamic-extent args))
-  (declare (clx-values nil))
-  (labels ((map-resource-internal (database function args name)
-	     (declare (type resource-database database)
-		      (type (function (list t &rest t) t) function)
-		      (type list name)
-		      #+clx-ansi-common-lisp
-		      (dynamic-extent function)
-		      #+(and lispm (not clx-ansi-common-lisp))
-		      (sys:downward-funarg function))		      
-	     (let ((tight (resource-database-tight database))
-		   (loose (resource-database-loose database)))
-	       (declare (type list tight loose))
-	       (dolist (resource tight)
-		 (declare (type resource-database resource))
-		 (let ((value (resource-database-value resource))
-		       (name (append
-			       name
-			       (list (resource-database-name resource)))))
-		   (if value
-		       (apply function name value args)
-		     (map-resource-internal resource function args name))))
-	       (dolist (resource loose)
-		 (declare (type resource-database resource))
-		 (let ((value (resource-database-value resource))
-		       (name (append
-			       name
-			       (list "*" (resource-database-name resource)))))
-		   (if value
-		       (apply function name value args)
-		     (map-resource-internal resource function args name)))))))
-    (map-resource-internal database function args nil)))
-
-(defun merge-resources (database with-database)
-  (declare (type resource-database database with-database))
-  (declare (clx-values resource-database))
-  (map-resource
-    database
-    #'(lambda (name value database)
-	(add-resource database name value))
-    with-database)
-  with-database)
-
-(defun char-memq (key char)
-  ;; Used as a test function for POSITION
-  (declare (type base-char char))
-  (member char key))
-
-(defmacro resource-with-open-file ((stream pathname &rest options) &body body)
-  ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the
-  ;; stream
-  (let ((abortp (gensym))
-	(streamp (gensym)))
-    `(let* ((,abortp t)
-	    (,streamp (streamp pathname))
-	    (,stream (if ,streamp pathname (open ,pathname ,@options))))
-       (unwind-protect
-	   (multiple-value-prog1
-	     (progn ,@body)
-	     (setq ,abortp nil))
-	 (unless ,streamp
-	   (close stream :abort ,abortp))))))
-
-(defun read-resources (database pathname &key key test test-not)
-  ;; Merges resources from a file in standard X11 format with DATABASE.
-  ;; KEY is a function used for converting value-strings, the default is
-  ;; identity.  TEST and TEST-NOT are predicates used for filtering
-  ;; which resources to include in the database.  They are called with
-  ;; the name and results of the KEY function.
-  (declare (type resource-database database)
-	   (type (or pathname string stream) pathname)
-	   (type (or null (function (string) t)) key)
-	   (type (or null (function (list t) boolean))
-                 test test-not))
-  (declare (clx-values resource-database))
-  (resource-with-open-file (stream pathname)
-    (loop
-      (let ((string (read-line stream nil :eof)))
-	(declare (type (or string keyword) string))
-	(when (eq string :eof) (return database))
-	(let* ((end (length string))
-	       (i (position '(#\tab #\space) string
-			    :test-not #'char-memq :end end))
-	       (term nil))
-	  (declare (type array-index end)
-		   (type (or null array-index) i term))
-	  (when i ;; else blank line
-	    (case (char string i)
-	      (#\! nil)  ;; Comment - skip
-	      ;;(#.(card8->char 0) nil) ;; terminator for C strings - skip
-	      (#\#       ;; Include
-	       (setq term (position '(#\tab #\space) string :test #'char-memq
-				    :start i :end end))
-	       (when (string-equal string "#INCLUDE" :start1 i :end1 term) 
-		 (let ((path (merge-pathnames
-			       (subseq string (1+ term)) (truename stream))))
-		   (read-resources database path
-				   :key key :test test :test-not test-not))))
-	      (otherwise
-	       (multiple-value-bind (name-list value)
-		   (parse-resource string i end)
-		 (when name-list 
-		   (when key (setq value (funcall key value)))
-		   (when
-		     (cond (test (funcall test name-list value))
-			   (test-not (not (funcall test-not name-list value)))
-			   (t t))
-		     (add-resource database name-list value))))))))))))
-
-(defun parse-resource (string &optional (start 0) end)
-  ;; Parse a resource specfication string into a list of names and a value
-  ;; string
-  (declare (type string string)
-	   (type array-index start)
-	   (type (or null array-index) end))
-  (declare (clx-values name-list value))
-  (do ((i start)
-       (end (or end (length string)))
-       (term)
-       (name-list))
-      ((>= i end))
-    (declare (type array-index end)
-	     (type (or null array-index) i term))
-    (setq term (position '(#\. #\* #\:) string
-			 :test #'char-memq :start i :end end))
-    (case (and term (char string term))
-      ;; Name seperator
-      (#\. (when (> term i)
-	     (push (subseq string i term) name-list)))
-      ;; Wildcard seperator
-      (#\* (when (> term i)
-	     (push (subseq string i term) name-list))
-	   (push '* name-list))
-      ;; Value separator
-      (#\:
-       (push (subseq string i term) name-list)
-       (return
-	 (values
-	   (nreverse name-list)
-	   (string-trim '(#\tab #\space) (subseq string (1+ term))))))
-      (otherwise
-	(return
-	  (values
-	    (nreverse name-list)
-	    (subseq string i term)))))
-    (setq i (1+ term))))
-
-(defun write-resources (database pathname &key write test test-not)
-  ;; Write resources to PATHNAME in the standard X11 format.
-  ;; WRITE is a function used for writing values, the default is #'princ
-  ;; TEST and TEST-NOT are predicates used for filtering which resources
-  ;; to include in the database.  They are called with the name and value.
-  (declare (type resource-database database)
-	   (type (or pathname string stream) pathname)
-	   (type (or null (function (string stream) t)) write)
-	   (type (or null (function (list t) boolean))
-                 test test-not))
-  (resource-with-open-file (stream pathname :direction :output)
-    (map-resource
-      database
-      #'(lambda (name-list value stream write test test-not)
-	  (when
-	    (cond (test (funcall test name-list value))
-		  (test-not (not (funcall test-not name-list value)))
-		  (t t))
-	    (let ((previous (car name-list)))
-	      (princ previous stream)
-	      (dolist (name (cdr name-list))
-		(unless (or (stringable-equal name "*")
-			    (stringable-equal previous "*"))
-		  (write-char #\. stream))
-		(setq previous name)
-		(princ name stream)))
-	    (write-string ":	" stream)
-	    (funcall write value stream)
-	    (terpri stream)))
-      stream (or write #'princ) test test-not))
-  database)
-
-(defun wm-resources (database window &key key test test-not)
-  ;; Takes the resources associated with the RESOURCE_MANAGER property
-  ;; of WINDOW (if any) and merges them with DATABASE.
-  ;; KEY is a function used for converting value-strings, the default is
-  ;; identity.  TEST and TEST-NOT are predicates used for filtering
-  ;; which resources to include in the database.  They are called with
-  ;; the name and results of the KEY function.
-  (declare (type resource-database database)
-	   (type window window)
-	   (type (or null (function (string) t)) key)
-	   (type (or null (function (list t) boolean))
-                 test test-not))
-  (declare (clx-values resource-database))
-  (let ((string (get-property window :RESOURCE_MANAGER :type :STRING
-			      :result-type 'string
-			      :transform #'xlib::card8->char)))
-    (when string
-      (with-input-from-string (stream string)
-	(read-resources database stream
-			:key key :test test :test-not test-not)))))
-
-(defun set-wm-resources (database window &key write test test-not)
-  ;; Sets the resources associated with the RESOURCE_MANAGER property
-  ;; of WINDOW.
-  ;; WRITE is a function used for writing values, the default is #'princ
-  ;; TEST and TEST-NOT are predicates used for filtering which resources
-  ;; to include in the database.  They are called with the name and value.
-  (declare (type resource-database database)
-	   (type window window)
-	   (type (or null (function (string stream) t)) write)
-	   (type (or null (function (list t) boolean))
-                 test test-not))
-  (xlib::set-string-property
-    window :RESOURCE_MANAGER
-    (with-output-to-string (stream)
-      (write-resources database stream :write write
-		       :test test :test-not test-not))))
-
-(defun root-resources (screen &key database key test test-not)
-  "Returns a resource database containing the contents of the root window
-   RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display,
-   then its default screen is used. If an existing DATABASE is given, then
-   resource values are merged with the DATABASE and the modified DATABASE is
-   returned.
-
-   TEST and TEST-NOT are predicates for selecting which resources are
-   read.  Arguments are a resource name list and a resource value. The KEY
-   function, if given, is called to convert a resource value string to the
-   value given to TEST or TEST-NOT."
-
-  (declare (type (or screen display) screen)
-	   (type (or null resource-database) database)
-	   (type (or null (function (string) t)) key)
-	   (type (or null (function (list t) boolean)) test test-not)
-	   (clx-values resource-database))
-  (let* ((screen (if (type? screen 'display)
-		     (display-default-screen screen)
-		   screen))
-	 (window (screen-root screen))
-	 (database (or database (make-resource-database))))
-    (wm-resources database window :key key :test test :test-not test-not)
-    database))
-
-(defun set-root-resources (screen &key test test-not (write #'princ) database)
-  "Changes the contents of the root window RESOURCE_MANAGER property for the
-   given SCREEN. If SCREEN is a display, then its default screen is used. 
-
-   TEST and TEST-NOT are predicates for selecting which resources from the
-   DATABASE are written.  Arguments are a resource name list and a resource
-   value.  The WRITE function is used to convert a resource value into a
-   string stored in the property."
-
-  (declare (type (or screen display) screen)
-	(type (or null resource-database) database)
-	(type (or null (function (list t) boolean)) test test-not)
-	(type (or null (function (string stream) t)) write)
-	(clx-values resource-database))
-  (let* ((screen (if (type? screen 'display)
-		     (display-default-screen screen)
-		   screen))
-	 (window (screen-root screen)))
-    (set-wm-resources database window
-		      :write write :test test :test-not test-not)
-    database))
-
-(defsetf root-resources set-root-resources)
-
-(defun initialize-resource-database (display)
-  ;; This function is (supposed to be) equivalent to the Xlib initialization
-  ;; code.
-  (declare (type display display))
-  (let ((rdb (make-resource-database))
-	(rootwin (screen-root (car (display-roots display)))))
-    ;; First read the server defaults if present, otherwise from the default
-    ;; resource file
-    (if (get-property rootwin :RESOURCE_MANAGER)
-	(xlib:wm-resources rdb rootwin)
-      (let ((path (default-resources-pathname)))
-	(when (and path (probe-file path))
-	  (read-resources rdb path))))
-    ;; Next read from the resources file 
-    (let ((path (resources-pathname)))
-      (when (and path (probe-file path))
-	(read-resources rdb path)))
-    (setf (display-xdefaults display) rdb)))
diff --git a/clx/sockcl.lisp b/clx/sockcl.lisp
deleted file mode 100644
index 26c0eda348242d4b888ca3d4efb1e610a922ae8b..0000000000000000000000000000000000000000
--- a/clx/sockcl.lisp
+++ /dev/null
@@ -1,163 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;;; Server Connection for kcl and ibcl
-
-;;; Copyright (C) 1987, 1989 Massachussetts Institute of Technology 
-;;;
-;;; Permission is granted to any individual or institution to use, copy,
-;;; modify, and distribute this software, provided that this complete
-;;; copyright and permission notice is maintained, intact, in all copies and
-;;; supporting documentation.
-;;;
-;;; Massachussetts Institute of Technology provides this software "as is"
-;;; without express or implied warranty.
-;;;
-
-;;; Adapted from code by Roman Budzianowski - Project Athena/MIT
-
-;;; make-two-way-stream is probably not a reasonable thing to do.
-;;; A close on a two way stream probably does not close the substreams.
-;;; I presume an :io will not work (maybe because it uses 1 buffer?).
-;;; There should be some fast io (writes and reads...).
-
-;;; Compile this file with compile-file.
-;;; Load it with (si:faslink "sockcl.o" "socket.o -lc")
-
-(in-package :xlib)
-
-;;; The cmpinclude.h file does not have this type definition from
-;;; <kcldistribution>/h/object.h.  We include it here so the
-;;; compile-file will work without figuring out where the distribution
-;;; directory is located.
-;;;
-(CLINES "
-enum smmode {			/*  stream mode  */
-	smm_input,		/*  input  */
-	smm_output,		/*  output  */
-	smm_io,			/*  input-output  */
-	smm_probe,		/*  probe  */
-	smm_synonym,		/*  synonym  */
-	smm_broadcast,		/*  broadcast  */
-	smm_concatenated,	/*  concatenated  */
-	smm_two_way,		/*  two way  */
-	smm_echo,		/*  echo  */
-	smm_string_input,	/*  string input  */
-	smm_string_output,	/*  string output  */
-	smm_user_defined        /*  for user defined */ 
-};
-")
-
-#-akcl
-(CLINES "
-struct stream {
-	short	t, m;
-	FILE	*sm_fp;		/*  file pointer  */
-	object	sm_object0;	/*  some object  */
-	object	sm_object1;	/*  some object */
-	int	sm_int0;	/*  some int  */
-	int	sm_int1;	/*  some int  */
-	short	sm_mode;	/*  stream mode  */
-				/*  of enum smmode  */
-};
-")
-
-
-;;;; Connect to the server.
-
-;;; A lisp string is not a reasonable type for C, so copy the characters
-;;; out and then call connect_to_server routine defined in socket.o
-
-(CLINES "
-int
-konnect_to_server(host,display)
-     object host;		/* host name */
-     int    display;		/* display number */
-{
-   int fd;			/* file descriptor */
-   int i;
-   char hname[BUFSIZ];
-   FILE *fout, *fin;
-
-   if (host->st.st_fillp > BUFSIZ - 1)
-     too_long_file_name(host);
-   for (i = 0;  i < host->st.st_fillp;  i++)
-     hname[i] = host->st.st_self[i];
-   hname[i] = '\\0';            /* doubled backslash for lisp */
-
-   fd = connect_to_server(hname,display);
-
-   return(fd);
-}
-")
-
-(defentry konnect-to-server (object int) (int "konnect_to_server"))
-
-
-;;;; Make a one-way stream from a file descriptor.
-
-(CLINES "
-object
-konnect_stream(host,fd,flag,elem)
-     object host;		/* not really used */
-     int fd;			/* file descriptor */
-     int flag;			/* 0 input, 1 output */
-     object elem;		/* 'string-char */
-{
-   struct stream *stream;
-   char *mode;			/* file open mode */
-   FILE *fp;			/* file pointer */
-   enum smmode smm;		/* lisp mode (a short) */
-   vs_mark;
-
-   switch(flag){
-    case 0:
-      smm = smm_input;
-      mode = \"r\";
-      break;
-    case 1:
-      smm = smm_output;
-      mode = \"w\";
-      break;
-    default:
-      FEerror(\"konnect_stream : wrong mode\");
-   }
-   
-   fp = fdopen(fd,mode);
-
-   if (fp == NULL) {
-     stream = Cnil;
-     vs_push(stream);
-   } else {
-     stream = alloc_object(t_stream);
-     stream->sm_mode = (short)smm;
-     stream->sm_fp = fp;
-     stream->sm_object0 = elem;
-     stream->sm_object1 = host;
-     stream->sm_int0 = stream->sm.sm_int1 = 0;
-     vs_push(stream);
-     setbuf(fp, alloc_contblock(BUFSIZ));
-   }
-   vs_reset;
-   return(stream);
-}
-")
-
-(defentry konnect-stream (object int int object) (object "konnect_stream"))
-
-
-;;;; Open an X stream
-
-(defun open-socket-stream (host display)
-  (when (not (and (typep host    'string)	; sanity check the arguments
-		  (typep display 'fixnum)))
-    (error "Host ~s or display ~s are bad." host display))
-
-  (let ((fd (konnect-to-server host display)))	; get a file discriptor
-    (if (< fd 0)
-	NIL
-	(let ((stream-in  (konnect-stream host fd 0 'string-char))	; input
-	      (stream-out (konnect-stream host fd 1 'string-char)))	; output
-	  (if (or (null stream-in) (null stream-out))
-	      (error "Could not make i/o streams for fd ~d." fd))
-	  (make-two-way-stream stream-in stream-out))
-	)))
diff --git a/clx/socket.c b/clx/socket.c
deleted file mode 100644
index b2eaf39d535a36267df9efec31d2dc60f1aa9b3e..0000000000000000000000000000000000000000
--- a/clx/socket.c
+++ /dev/null
@@ -1,153 +0,0 @@
-/* Copyright    Massachusetts Institute of Technology    1988	*/
-/*
- * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived
- * systems.  VMS and System V should plan to have their own version.
- *
- * This code was cribbed from lib/X/XConnDis.c.
- * Compile using   
- *                    % cc -c socket.c -DUNIXCONN
- */
-
-#include <stdio.h>
-#include <X11/Xos.h>
-#include <X11/Xproto.h>
-#include <errno.h>
-#include <netinet/in.h>
-#include <sys/ioctl.h>
-#include <netdb.h> 
-#include <sys/socket.h>
-#ifndef hpux
-#include <netinet/tcp.h>
-#endif
-
-extern int errno;		/* Certain (broken) OS's don't have this */
-				/* decl in errno.h */
-
-#ifdef UNIXCONN
-#include <sys/un.h>
-#ifndef X_UNIX_PATH
-#ifdef hpux
-#define X_UNIX_PATH "/usr/spool/sockets/X11/"
-#define OLD_UNIX_PATH "/tmp/.X11-unix/X"
-#else /* hpux */
-#define X_UNIX_PATH "/tmp/.X11-unix/X"
-#endif /* hpux */
-#endif /* X_UNIX_PATH */
-#endif /* UNIXCONN */
-
-#ifndef hpux
-void bcopy();
-#endif /* hpux */
-
-/* 
- * Attempts to connect to server, given host and display. Returns file 
- * descriptor (network socket) or 0 if connection fails.
- */
-
-int connect_to_server (host, display)
-     char *host;
-     int display;
-{
-  struct sockaddr_in inaddr;	/* INET socket address. */
-  struct sockaddr *addr;		/* address to connect to */
-  struct hostent *host_ptr;
-  int addrlen;			/* length of address */
-#ifdef UNIXCONN
-  struct sockaddr_un unaddr;	/* UNIX socket address. */
-#endif
-  extern char *getenv();
-  extern struct hostent *gethostbyname();
-  int fd;				/* Network socket */
-  {
-#ifdef UNIXCONN
-    if ((host[0] == '\0') || (strcmp("unix", host) == 0)) {
-	/* Connect locally using Unix domain. */
-	unaddr.sun_family = AF_UNIX;
-	(void) strcpy(unaddr.sun_path, X_UNIX_PATH);
-	(void) sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display);
-	addr = (struct sockaddr *) &unaddr;
-	addrlen = strlen(unaddr.sun_path) + 2;
-	/*
-	 * Open the network connection.
-	 */
-	if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) {
-#ifdef hpux /* this is disgusting */  /* cribbed from X11R4 xlib source */
-  	    if (errno == ENOENT) {  /* No such file or directory */
-	      (void) sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display);
-              addrlen = strlen(unaddr.sun_path) + 2;
-              if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0)
-                return(-1);     /* errno set by most recent system call. */
-	    } else 
-#endif /* hpux */
-	    return(-1);	    /* errno set by system call. */
-        }
-    } else 
-#endif /* UNIXCONN */
-    {
-      /* Get the statistics on the specified host. */
-      if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) 
-	{
-	  if ((host_ptr = gethostbyname(host)) == NULL) 
-	    {
-	      /* No such host! */
-	      errno = EINVAL;
-	      return(-1);
-	    }
-	  /* Check the address type for an internet host. */
-	  if (host_ptr->h_addrtype != AF_INET) 
-	    {
-	      /* Not an Internet host! */
-	      errno = EPROTOTYPE;
-	      return(-1);
-	    }
-	  /* Set up the socket data. */
-	  inaddr.sin_family = host_ptr->h_addrtype;
-#ifdef hpux
-	  (void) memcpy((char *)&inaddr.sin_addr, 
-			(char *)host_ptr->h_addr, 
-			sizeof(inaddr.sin_addr));
-#else /* hpux */
-	  (void) bcopy((char *)host_ptr->h_addr, 
-		       (char *)&inaddr.sin_addr, 
-		       sizeof(inaddr.sin_addr));
-#endif /* hpux */
-	} 
-      else 
-	{
-	  inaddr.sin_family = AF_INET;
-	}
-      addr = (struct sockaddr *) &inaddr;
-      addrlen = sizeof (struct sockaddr_in);
-      inaddr.sin_port = display + X_TCP_PORT;
-      inaddr.sin_port = htons(inaddr.sin_port);
-      /*
-       * Open the network connection.
-       */
-      if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){
-	return(-1);	    /* errno set by system call. */}
-      /* make sure to turn off TCP coalescence */
-#ifdef TCP_NODELAY
-      {
-	int mi = 1;
-	setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int));
-      }
-#endif
-    }
-
-    /*
-     * Changed 9/89 to retry connection if system call was interrupted.  This
-     * is necessary for multiprocessing implementations that use timers,
-     * since the timer results in a SIGALRM.	-- jdi
-     */
-    while (connect(fd, addr, addrlen) == -1) {
-	if (errno != EINTR) {
-  	    (void) close (fd);
-  	    return(-1); 	    /* errno set by system call. */
-	}
-      }
-  }
-  /*
-   * Return the id if the connection succeeded.
-   */
-  return(fd);
-}
diff --git a/clx/text.lisp b/clx/text.lisp
deleted file mode 100644
index f39bfc7d57646761165d2e69ca13ceb36b272148..0000000000000000000000000000000000000000
--- a/clx/text.lisp
+++ /dev/null
@@ -1,1084 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
-
-;;; CLX text keyboard and pointer requests
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-;; Strings are broken up into chunks of this size
-(defparameter *max-string-size* 254)
-
-;; In the functions below, the transform is used to convert an element of the
-;; sequence into a font index.  The transform is applied to each element of the
-;; (sub)sequence, until either the transform returns nil or the end of the
-;; (sub)sequence is reached.  If transform returns nil for an element, the
-;; index of that element in the sequence is returned, otherwise nil is
-;; returned.
-
-(deftype translation-function ()
-  #+explorer t
-  #-explorer
-  '(function (sequence array-index array-index (or null font) vector array-index)
-	     (values array-index (or null int16 font) (or null int32))))
-
-;; In the functions below, if width is specified, it is assumed to be the pixel
-;; width of whatever string of glyphs is actually drawn.  Specifying width will
-;; allow for appending the output of subsequent calls to the same protocol
-;; request, provided gcontext has not been modified in the interim.  If width
-;; is not specified, appending of subsequent output might not occur.
-;; Specifying width is simply a hint, for performance.  Note that specifying
-;; width may be difficult if transform can return nil.
-
-(defun translate-default (src src-start src-end font dst dst-start)
-  ;; dst is guaranteed to have room for (- src-end src-start) integer elements,
-  ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends
-  ;; on context.  font is the current font, if known.  The function should
-  ;; translate as many elements of src as possible into indexes in the current
-  ;; font, and store them into dst.
-  ;;
-  ;; The first return value should be the src index of the first untranslated
-  ;; element.  If no further elements need to be translated, the second return
-  ;; value should be nil.  If a horizontal motion is required before further
-  ;; translation, the second return value should be the delta in x coordinate.
-  ;; If a font change is required for further translation, the second return
-  ;; value should be the new font.  If known, the pixel width of the translated
-  ;; text can be returned as the third value; this can allow for appending of
-  ;; subsequent output to the same protocol request, if no overall width has
-  ;; been specified at the higher level.
-  ;; (returns values: ending-index
-  ;;                  (OR null horizontal-motion font)
-  ;;                  (OR null translated-width))
-  (declare (type sequence src)
-	   (type array-index src-start src-end dst-start)
-	   (type (or null font) font)
-	   (type vector dst)
-	   (inline graphic-char-p))
-  (declare (clx-values integer (or null integer font) (or null integer)))
-  font ;;not used
-  (if (stringp src)
-      (do ((i src-start (index+ i 1))
-	   (j dst-start (index+ j 1))
-	   (char))
-	  ((index>= i src-end)
-	   i)
-	(declare (type array-index i j))
-	(if (graphic-char-p (setq char (char src i)))
-	    (setf (aref dst j) (char->card8 char))
-	  (return i)))
-      (do ((i src-start (index+ i 1))
-	   (j dst-start (index+ j 1))
-	   (elt))
-	  ((index>= i src-end)
-	   i)
-	(declare (type array-index i j))
-	(setq elt (elt src i))
-	(cond ((and (characterp elt) (graphic-char-p elt))
-	       (setf (aref dst j) (char->card8 elt)))
-	      ((integerp elt)
-	       (setf (aref dst j) elt))
-	      (t
-	       (return i))))))
-
-;; There is a question below of whether translate should always be required, or
-;; if not, what the default should be or where it should come from.  For
-;; example, the default could be something that expected a string as src and
-;; translated the CL standard character set to ASCII indexes, and ignored fonts
-;; and bits.  Or the default could expect a string but otherwise be "system
-;; dependent".  Or the default could be something that expected a vector of
-;; integers and did no translation.  Or the default could come from the
-;; gcontext (but what about text-extents and text-width?).
-
-(defun text-extents (font sequence &key (start 0) end translate)
-  ;; If multiple fonts are involved, font-ascent and font-descent will be the
-  ;; maximums.  If multiple directions are involved, the direction will be nil.
-  ;; Translate will always be called with a 16-bit dst buffer.
-  (declare (type sequence sequence)
-	   (type (or font gcontext) font))
-  (declare (type (or null translation-function) translate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent translate)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg #+Genera * #-Genera translate))
-  (declare (clx-values width ascent descent left right
-		  font-ascent font-descent direction
-		  (or null array-index)))
-  (when (type? font 'gcontext)
-    (force-gcontext-changes font)
-    (setq font (gcontext-font font t)))
-  (check-type font font)
-  (let* ((left-bearing 0)
-	 (right-bearing 0)
-	 ;; Sum of widths
-	 (width 0)
-	 (ascent 0)
-	 (descent 0)
-	 (overall-ascent (font-ascent font))
-	 (overall-descent (font-descent font))
-	 (overall-direction (font-direction font))	 
-	 (next-start nil)
-	 (display (font-display font)))
-    (declare (type int16 ascent descent overall-ascent overall-descent)
-	     (type int32 left-bearing right-bearing width)
-	     (type (or null array-index) next-start)
-	     (type display display))
-    (with-display (display)
-      (do* ((wbuf (display-tbuf16 display))
-	    (src-end (or end (length sequence)))
-	    (src-start start (index+ src-start buf-end))
-	    (end (index-min src-end (index+ src-start *buffer-text16-size*))
-		 (index-min src-end (index+ src-start *buffer-text16-size*)))
-	    (buf-end 0)
-	    (new-font)
-	    (font-ascent 0)
-	    (font-descent 0)
-	    (font-direction)
-	    (stop-p nil))
-	   ((or stop-p (index>= src-start src-end))
-	    (when (index< src-start src-end)
-	      (setq next-start src-start)))
-	(declare (type buffer-text16 wbuf)
-		 (type array-index src-start src-end end buf-end)
-		 (type int16 font-ascent font-descent)
-		 (type boolean stop-p))
-	;; Translate the text
-	(multiple-value-setq (buf-end new-font)
-	  (funcall (or translate #'translate-default)
-		   sequence src-start end font wbuf 0))
-	(setq buf-end (- buf-end src-start))
-	(cond ((null new-font) (setq stop-p t))
-	      ((integerp new-font) (incf width (the int32 new-font))))
-	
-	(let (w a d l r)
-	  (if (or (font-char-infos-internal font) (font-local-only-p font))
-	      ;; Calculate text extents locally
-	      (progn
-		(multiple-value-setq (w a d l r)
-		  (text-extents-local font wbuf 0 buf-end nil))
-		(setq font-ascent (the int16 (font-ascent font))
-		      font-descent (the int16 (font-descent font))
-		      font-direction (font-direction font)))
-	    ;; Let the server calculate text extents
-	    (multiple-value-setq
-	      (w a d l r font-ascent font-descent font-direction)
-	      (text-extents-server font wbuf 0 buf-end)))
-	  (incf width (the int32 w))
-	  (cond ((index= src-start start)
-		 (setq left-bearing (the int32 l))
-		 (setq right-bearing (the int32 r))
-		 (setq ascent (the int16 a))
-		 (setq descent (the int16 d)))
-		(t
-		 (setq left-bearing (the int32 (min left-bearing (the int32 l))))
-		 (setq right-bearing (the int32 (max right-bearing (the int32 r))))
-		 (setq ascent (the int16 (max ascent (the int16 a))))
-		 (setq descent (the int16 (max descent (the int16 d)))))))
-
-	(when (type? new-font 'font)
-	  (setq font new-font))
-
-	(setq overall-ascent (the int16 (max overall-ascent font-ascent)))
-	(setq overall-descent (the int16 (max overall-descent font-descent)))
-	(case overall-direction
-	  (:unknown (setq overall-direction font-direction))
-	  (:left-to-right (unless (eq font-direction :left-to-right)
-			    (setq overall-direction nil)))
-	  (:right-to-left (unless (eq font-direction :right-to-left)
-			    (setq overall-direction nil))))))
-    
-    (values width
-	    ascent
-	    descent
-	    left-bearing
-	    right-bearing
-	    overall-ascent
-	    overall-descent
-	    overall-direction
-	    next-start)))
-
-(defun text-width (font sequence &key (start 0) end translate)
-  ;; Translate will always be called with a 16-bit dst buffer.
-  (declare (type sequence sequence)
-	   (type (or font gcontext) font)
-	   (type array-index start)
-	   (type (or null array-index) end))
-  (declare (type (or null translation-function) translate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent translate)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg #+Genera * #-Genera translate))
-  (declare (clx-values integer (or null integer)))
-  (when (type? font 'gcontext)
-    (force-gcontext-changes font)
-    (setq font (gcontext-font font t)))
-  (check-type font font)
-  (let* ((width 0)
-	 (next-start nil)
-	 (display (font-display font)))
-    (declare (type int32 width)
-	     (type (or null array-index) next-start)
-	     (type display display))
-    (with-display (display)
-      (do* ((wbuf (display-tbuf16 display))
-	    (src-end (or end (length sequence)))
-	    (src-start start (index+ src-start buf-end))
-	    (end (index-min src-end (index+ src-start *buffer-text16-size*))
-		 (index-min src-end (index+ src-start *buffer-text16-size*)))
-	    (buf-end 0)
-	    (new-font)
-	    (stop-p nil))
-	   ((or stop-p (index>= src-start src-end))
-	    (when (index< src-start src-end)
-	      (setq next-start src-start)))
-	(declare (type buffer-text16 wbuf)
-		 (type array-index src-start src-end end buf-end)
-		 (type boolean stop-p))
-	;; Translate the text
-	(multiple-value-setq (buf-end new-font)
-	  (funcall (or translate #'translate-default)
-		   sequence src-start end font wbuf 0))
-	(setq buf-end (- buf-end src-start))
-	(cond ((null new-font) (setq stop-p t))
-	      ((integerp new-font) (incf width (the int32 new-font))))
-	
-	(incf width
-	      (if (or (font-char-infos-internal font) (font-local-only-p font))
-		  (text-extents-local font wbuf 0 buf-end :width-only)
-		(text-width-server font wbuf 0 buf-end)))
-	(when (type? new-font 'font)
-	  (setq font new-font))))
-    (values width next-start)))
-
-(defun text-extents-server (font string start end)
-  (declare (type font font)
-	   (type string string)
-	   (type array-index start end))
-  (declare (clx-values width ascent descent left right font-ascent font-descent direction))
-  (let ((display (font-display font))
-	(length (index- end start))
-	(font-id (font-id font)))
-    (declare (type display display)
-	     (type array-index length)
-	     (type resource-id font-id))
-    (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes (8 16 32))
-	 (((data boolean) (oddp length))
-	  (length (index+ (index-ceiling length 2) 2))
-	  (resource-id font-id)
-	  ((sequence :format char2b :start start :end end :appending t)
-	   string))
-      (values
-	(integer-get 16)
-	(int16-get 12)
-	(int16-get 14)
-	(integer-get 20)
-	(integer-get 24)
-	(int16-get 8)
-	(int16-get 10)
-	(member8-get 1 :left-to-right :right-to-left)))))
-
-(defun text-width-server (font string start end)
-  (declare (type (or font gcontext) font)
-	   (type string string)
-	   (type array-index start end))
-  (declare (clx-values integer))
-  (let ((display (font-display font))
-	(length (index- end start))
-	(font-id (font-id font)))
-    (declare (type display display)
-	     (type array-index length)
-	     (type resource-id font-id))
-    (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes 32)
-	 (((data boolean) (oddp length))
-	  (length (index+ (index-ceiling length 2) 2))
-	  (resource-id font-id)
-	  ((sequence :format char2b :start start :end end :appending t)
-	   string))
-      (values (integer-get 16)))))
-
-(defun text-extents-local (font sequence start end width-only-p)
-  (declare (type font font)
-	   (type sequence sequence)
-	   (type integer start end)
-	   (type boolean width-only-p))
-  (declare (clx-values width ascent descent overall-left overall-right))
-  (let* ((char-infos (font-char-infos font))
-	 (font-info (font-font-info font)))
-    (declare (type font-info font-info))
-    (declare (type (simple-array int16 (*)) char-infos))
-    (if (zerop (length char-infos))
-	;; Fixed width font
-	(let* ((font-width (max-char-width font))
-	       (font-ascent (max-char-ascent font))
-	       (font-descent (max-char-descent font))
-	       (width (* (index- end start) font-width)))
-	  (declare (type int16 font-width font-ascent font-descent)
-		   (type int32 width))
-	  (if width-only-p
-	      width
-	    (values width
-		    font-ascent
-		    font-descent
-		    (max-char-left-bearing font)
-		    (+ width (- font-width) (max-char-right-bearing font)))))
-      
-      ;; Variable-width font
-      (let* ((first-col (font-info-min-byte2 font-info))
-	     (num-cols (1+ (- (font-info-max-byte2 font-info) first-col)))
-	     (first-row (font-info-min-byte1 font-info))
-	     (last-row (font-info-max-byte1 font-info))
-	     (num-rows (1+ (- last-row first-row))))
-	(declare (type card8 first-col first-row last-row)
-		 (type card16 num-cols num-rows))
-	(if (or (plusp first-row) (plusp last-row))
-	    
-	    ;; Matrix (16 bit) font
-	    (macrolet ((char-info-elt (sequence elt)
-			 `(let* ((char (the card16 (elt ,sequence ,elt)))
-				 (row (- (ash char -8) first-row))
-				 (col (- (logand char #xff) first-col)))
-			    (declare (type card16 char)
-				     (type int16 row col))
-			    (if (and (< -1 row num-rows) (< -1 col num-cols))
-				(index* 6 (index+ (index* row num-cols) col))
-			      -1))))
-	      (if width-only-p
-		  (do ((i start (index1+ i))
-		       (width 0))
-		      ((index>= i end) width)
-		    (declare (type array-index i)
-			     (type int32 width))
-		    (let ((n (char-info-elt sequence i)))
-		      (declare (type fixnum n))
-		      (unless (minusp n)  ;; Ignore characters not in the font
-			(incf width (the int16 (aref char-infos (index+ 2 n)))))))
-		;; extents
-		(do ((i start (index1+ i))
-		     (width 0)
-		     (ascent #x-7fff)
-		     (descent #x-7fff)
-		     (left #x7fff)
-		     (right #x-7fff))
-		    ((index>= i end)
-		     (values width ascent descent left right))
-		  (declare (type array-index i)
-			   (type int16 ascent descent)
-			   (type int32 width left right))
-		  (let ((n (char-info-elt sequence i)))
-		    (declare (type fixnum n))
-		    (unless (minusp n) ;; Ignore characters not in the font
-		      (setq left (min left (+ width (aref char-infos n))))
-		      (setq right (max right (+ width (aref char-infos (index1+ n)))))
-		      (incf width (aref char-infos (index+ 2 n)))
-		      (setq ascent (max ascent (aref char-infos (index+ 3 n))))
-		      (setq descent (max descent (aref char-infos (index+ 4 n)))))))))
-	  
-	  ;; Non-matrix (8 bit) font
-	  ;; The code here is identical to the above, except for the following macro:
-	  (macrolet ((char-info-elt (sequence elt)
-		       `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col)))
-			  (declare (type int16 col))
-			  (if (< -1 col num-cols)
-			      (index* 6 col)
-			    -1))))
-	    (if width-only-p
-		(do ((i start (index1+ i))
-		     (width 0))
-		    ((index>= i end) width)
-		  (declare (type array-index i)
-			   (type int32 width))
-		  (let ((n (char-info-elt sequence i)))
-		    (declare (type fixnum n))
-		    (unless (minusp n) ;; Ignore characters not in the font
-		      (incf width (the int16 (aref char-infos (index+ 2 n)))))))
-	      ;; extents
-	      (do ((i start (index1+ i))
-		   (width 0)
-		   (ascent #x-7fff)
-		   (descent #x-7fff)
-		   (left #x7fff)
-		   (right #x-7fff))
-		  ((index>= i end)
-		   (values width ascent descent left right))
-		(declare (type array-index i)
-			 (type int16 ascent descent)
-			 (type int32 width left right))
-		(let ((n (char-info-elt sequence i)))
-		  (declare (type fixnum n))
-		  (unless (minusp n) ;; Ignore characters not in the font
-		    (setq left (min left (+ width (aref char-infos n))))
-		    (setq right (max right (+ width (aref char-infos (index1+ n)))))
-		    (incf width (aref char-infos (index+ 2 n)))
-		    (setq ascent (max ascent (aref char-infos (index+ 3 n))))
-		    (setq descent (max descent (aref char-infos (index+ 4 n)))))
-		  ))))
-	  )))))
-
-;;-----------------------------------------------------------------------------
-
-;; This controls the element size of the dst buffer given to translate.  If
-;; :default is specified, the size will be based on the current font, if known,
-;; and otherwise 16 will be used.  [An alternative would be to pass the buffer
-;; size to translate, and allow it to return the desired size if it doesn't
-;; like the current size.  The problem is that the protocol doesn't allow
-;; switching within a single request, so to allow switching would require
-;; knowing the width of text, which isn't necessarily known.  We could call
-;; text-width to compute it, but perhaps that is doing too many favors?]  [An
-;; additional possibility is to allow an index-size of :two-byte, in which case
-;; translate would be given a double-length 8-bit array, and translate would be
-;; expected to store first-byte/second-byte instead of 16-bit integers.]
-
-(deftype index-size () '(member :default 8 16))
-
-;; In the functions below, if width is specified, it is assumed to be the total
-;; pixel width of whatever string of glyphs is actually drawn.  Specifying
-;; width will allow for appending the output of subsequent calls to the same
-;; protocol request, provided gcontext has not been modified in the interim.
-;; If width is not specified, appending of subsequent output might not occur
-;; (unless translate returns the width).  Specifying width is simply a hint,
-;; for performance.
-
-(defun draw-glyph (drawable gcontext x y elt
-		   &key translate width (size :default))
-  ;; Returns true if elt is output, nil if translate refuses to output it.
-  ;; Second result is width, if known.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type (or null int32) width)
-	   (type index-size size))
-  (declare (type (or null translation-function) translate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent translate)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg #+Genera * #-Genera translate))
-  (declare (clx-values boolean (or null int32)))
-  (let* ((display (gcontext-display gcontext))
-	 (result t)
-	 (opcode *x-polytext8*))
-    (declare (type display display))
-    (let ((vector (allocate-gcontext-state)))
-      (declare (type gcontext-state vector))
-      (setf (aref vector 0) elt)
-      (multiple-value-bind (new-start new-font translate-width)
-	  (funcall (or translate #'translate-default)
-		   vector 0 1 (gcontext-font gcontext t) vector 1)
-	;; Allow translate to set a new font
-	(when (type? new-font 'font) 
-	  (setf (gcontext-font gcontext) new-font)
-	  (multiple-value-setq (new-start new-font translate-width)
-	    (funcall translate vector 0 1 new-font vector 1)))
-	;; If new-start is zero, translate refuses to output it
-	(setq result (index-plusp new-start)
-	      elt (aref vector 1))
-	(deallocate-gcontext-state vector)
-	(when translate-width (setq width translate-width))))
-    (when result
-      (when (eql size 16)
-	(setq opcode *x-polytext16*)
-	(setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
-      (with-buffer-request (display opcode :gc-force gcontext)
-	(drawable drawable)
-	(gcontext gcontext)
-	(int16 x y)
-	(card8 1 0)
-	(card8 (ldb (byte 8 0) elt))
-	(card8 (ldb (byte 8 8) elt)))
-      (values t width))))
-  
-(defun draw-glyphs (drawable gcontext x y sequence
-		    &key (start 0) end translate width (size :default))
-  ;; First result is new start, if end was not reached.  Second result is
-  ;; overall width, if known.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type array-index start)
-	   (type sequence sequence)
-	   (type (or null array-index) end)
-	   (type (or null int32) width)
-	   (type index-size size))
-  (declare (type (or null translation-function) translate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent translate)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg #+Genera * #-Genera translate))
-  (declare (clx-values (or null array-index) (or null int32)))
-  (unless end (setq end (length sequence)))
-  (ecase size
-    ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end
-				(or translate #'translate-default) width))
-    (16 (draw-glyphs16 drawable gcontext x y sequence start end
-		       (or translate #'translate-default) width))))
-
-(defun draw-glyphs8 (drawable gcontext x y sequence start end translate width)
-  ;; First result is new start, if end was not reached.  Second result is
-  ;; overall width, if known.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type array-index start)
-	   (type sequence sequence)
-	   (type (or null array-index) end)
-	   (type (or null int32) width))
-  (declare (clx-values (or null array-index) (or null int32)))
-  (declare (type translation-function translate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent translate)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg translate)) 
-  (let* ((src-start start)
-	 (src-end (or end (length sequence)))
-	 (next-start nil)
-	 (length (index- src-end src-start))
-	 (request-length (* length 2))		; Leave lots of room for font shifts.
-	 (display (gcontext-display gcontext))
-	 ;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
-	 (font (gcontext-font gcontext t)))
-    (declare (type array-index src-start src-end length)
-	     (type (or null array-index) next-start)
-	     (type display display))
-    (with-buffer-request (display *x-polytext8* :gc-force gcontext :length request-length)
-      (drawable drawable)
-      (gcontext gcontext)
-      (int16 x y)
-      (progn
-	;; Don't let any flushes happen since we manually set the request
-	;; length when we're done.
-	(with-buffer-flush-inhibited (display)
-	  (do* ((boffset (index+ buffer-boffset 16))
-		(src-chunk 0)
-		(dst-chunk 0)
-		(offset 0)
-		(overall-width 0)
-		(stop-p nil))
-	       ((or stop-p (zerop length))
-		;; Ensure terminated with zero bytes
-		(do ((end (the array-index (lround boffset))))
-		    ((index>= boffset end))
-		  (setf (aref buffer-bbuf boffset) 0)
-		  (index-incf boffset))
-		(length-put 2 (index-ash (index- boffset buffer-boffset) -2))
-		(setf (buffer-boffset display) boffset)
-		(unless (index-zerop length) (setq next-start src-start))
-		(when overall-width (setq width overall-width)))
-
-	    (declare (type array-index src-chunk dst-chunk offset)
-		     (type (or null int32) overall-width)
-		     (type boolean stop-p))
-	    (setq src-chunk (index-min length *max-string-size*))
-	    (multiple-value-bind (new-start new-font translated-width)
-		(funcall translate
-			 sequence src-start (index+ src-start src-chunk)
-			 font buffer-bbuf (index+ boffset 2))
-	      (setq dst-chunk (index- new-start src-start)
-		    length (index- length dst-chunk)
-		    src-start new-start)
-	      (if translated-width
-		  (when overall-width (incf overall-width translated-width))
-		(setq overall-width nil))
-	      (when (index-plusp dst-chunk)
-		(setf (aref buffer-bbuf boffset) dst-chunk)
-		(setf (aref buffer-bbuf (index+ boffset 1)) offset)
-		(incf boffset (index+ dst-chunk 2)))
-	      (setq offset 0)
-	      (cond ((null new-font)
-		     ;; Don't stop if translate copied whole chunk
-		     (unless (index= src-chunk dst-chunk)
-		       (setq stop-p t)))
-		    ((integerp new-font) (setq offset new-font))
-		    ((type? new-font 'font)
-		     (setq font new-font)
-		     (let ((font-id (font-id font))
-			   (buffer-boffset boffset))
-		       (declare (type resource-id font-id)
-				(type array-index buffer-boffset))
-		       ;; This changes the gcontext font in the server
-		       ;; Update the gcontext cache (both local and server state)
-		       (let ((local-state (gcontext-local-state gcontext))
-			     (server-state (gcontext-server-state gcontext)))
-			 (declare (type gcontext-state local-state server-state))
-			 (setf (gcontext-internal-font-obj server-state) font
-			       (gcontext-internal-font server-state) font-id)
-			 (without-interrupts
-			   (setf (gcontext-internal-font-obj local-state) font
-				 (gcontext-internal-font local-state) font-id)))
-		       (card8-put 0 #xff)
-		       (card8-put 1 (ldb (byte 8 24) font-id))
-		       (card8-put 2 (ldb (byte 8 16) font-id))
-		       (card8-put 3 (ldb (byte 8 8) font-id))
-		       (card8-put 4 (ldb (byte 8 0) font-id)))
-		     (index-incf boffset 5)))
-	      )))))
-    (values next-start width)))
-
-;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer
-;;       on 16bit boundaries and this function garbles the bytes.
-(defun draw-glyphs16 (drawable gcontext x y sequence start end translate width)
-  ;; First result is new start, if end was not reached.  Second result is
-  ;; overall width, if known.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type array-index start)
-	   (type sequence sequence)
-	   (type (or null array-index) end)
-	   (type (or null int32) width))
-  (declare (clx-values (or null array-index) (or null int32)))
-  (declare (type translation-function translate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent translate)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg translate))
-  (let* ((src-start start)
-	 (src-end (or end (length sequence)))
-	 (next-start nil)
-	 (length (index- src-end src-start))
-	 (request-length (* length 3))		; Leave lots of room for font shifts.
-	 (display (gcontext-display gcontext))
-	 ;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
-	 (font (gcontext-font gcontext t))
-	 (buffer (display-tbuf16 display)))
-    (declare (type array-index src-start src-end length)
-	     (type (or null array-index) next-start)
-	     (type display display)
-	     (type buffer-text16 buffer))
-    (with-buffer-request (display *x-polytext16* :gc-force gcontext :length request-length)
-      (drawable drawable)
-      (gcontext gcontext)
-      (int16 x y)
-      (progn
-	;; Don't let any flushes happen since we manually set the request
-	;; length when we're done.
-	(with-buffer-flush-inhibited (display)
-	  (do* ((boffset (index+ buffer-boffset 16))
-		(src-chunk 0)
-		(dst-chunk 0)
-		(offset 0)
-		(overall-width 0)
-		(stop-p nil))
-	       ((or stop-p (zerop length))
-		;; Ensure terminated with zero bytes
-		(do ((end (lround boffset)))
-		    ((index>= boffset end))
-		  (setf (aref buffer-bbuf boffset) 0)
-		  (index-incf boffset))
-		(length-put 2 (index-ash (index- boffset buffer-boffset) -2))
-		(setf (buffer-boffset display) boffset)
-		(unless (zerop length) (setq next-start src-start))
-		(when overall-width (setq width overall-width)))
-
-	    (declare (type array-index boffset src-chunk dst-chunk offset)
-		     (type (or null int32) overall-width)
-		     (type boolean stop-p))
-	    (setq src-chunk (index-min length *max-string-size*))
-	    (multiple-value-bind (new-start new-font translated-width)
-		(funcall translate
-			 sequence src-start (index+ src-start src-chunk)
-			 font buffer 0)
-	      (setq dst-chunk (index- new-start src-start)
-		    length (index- length dst-chunk)
-		    src-start new-start)
-	      (write-sequence-char2b display (index+ boffset 2) buffer 0 dst-chunk)
-	      (if translated-width
-		  (when overall-width (incf overall-width translated-width))
-		(setq overall-width nil))
-	      (when (index-plusp dst-chunk)
-		(setf (aref buffer-bbuf boffset) dst-chunk)
-		(setf (aref buffer-bbuf (index+ boffset 1)) offset)
-		(index-incf boffset (index+ dst-chunk dst-chunk 2)))
-	      (setq offset 0)
-	      (cond ((null new-font)
-		     ;; Don't stop if translate copied whole chunk
-		     (unless (index= src-chunk dst-chunk) 
-		       (setq stop-p t)))
-		    ((integerp new-font) (setq offset new-font))
-		    ((type? new-font 'font)
-		     (setq font new-font)
-		     (let ((font-id (font-id font))
-			   (buffer-boffset boffset))
-		       (declare (type resource-id font-id)
-				(type array-index buffer-boffset))
-		       ;; This changes the gcontext font in the SERVER
-		       ;; Update the gcontext cache (both local and server state)
-		       (let ((local-state (gcontext-local-state gcontext))
-			     (server-state (gcontext-server-state gcontext)))
-			 (declare (type gcontext-state local-state server-state))
-			 (setf (gcontext-internal-font-obj server-state) font
-			       (gcontext-internal-font server-state) font-id)
-			 (without-interrupts
-			   (setf (gcontext-internal-font-obj local-state) font
-				 (gcontext-internal-font local-state) font-id)))
-		       (card8-put 0 #xff)
-		       (card8-put 1 (ldb (byte 8 24) font-id))
-		       (card8-put 2 (ldb (byte 8 16) font-id))
-		       (card8-put 3 (ldb (byte 8 8) font-id))
-		       (card8-put 4 (ldb (byte 8 0) font-id)))
-		     (index-incf boffset 5)))
-	      )))))
-    (values next-start width)))
-
-(defun draw-image-glyph (drawable gcontext x y elt
-			 &key translate width (size :default))
-  ;; Returns true if elt is output, nil if translate refuses to output it.
-  ;; Second result is overall width, if known.  An initial font change is
-  ;; allowed from translate.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type (or null int32) width)
-	   (type index-size size))
-  (declare (type (or null translation-function) translate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent translate)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg #+Genera * #-Genera translate))
-  (declare (clx-values boolean (or null int32)))
-  (let* ((display (gcontext-display gcontext))
-	 (result t)
-	 (opcode *x-imagetext8*))
-    (declare (type display display))
-    (let ((vector (allocate-gcontext-state)))
-      (declare (type gcontext-state vector))
-      (setf (aref vector 0) elt)
-      (multiple-value-bind (new-start new-font translate-width)
-	  (funcall (or translate #'translate-default)
-		   vector 0 1 (gcontext-font gcontext t) vector 1)
-	;; Allow translate to set a new font
-	(when (type? new-font 'font) 
-	  (setf (gcontext-font gcontext) new-font)
-	  (multiple-value-setq (new-start new-font translate-width)
-	    (funcall translate vector 0 1 new-font vector 1)))
-	;; If new-start is zero, translate refuses to output it
-	(setq result (index-plusp new-start)
-	      elt (aref vector 1))
-	(deallocate-gcontext-state vector)
-	(when translate-width (setq width translate-width))))
-    (when result
-      (when (eql size 16)
-	(setq opcode *x-imagetext16*)
-	(setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
-      (with-buffer-request (display opcode :gc-force gcontext)
-	(drawable drawable)
-	(gcontext gcontext)
-	(data 1) ;; 1 character
-	(int16 x y)
-	(card8 (ldb (byte 8 0) elt))
-	(card8 (ldb (byte 8 8) elt)))
-      (values t width))))
-
-(defun draw-image-glyphs (drawable gcontext x y sequence
-			  &key (start 0) end translate width (size :default))
-  ;; An initial font change is allowed from translate, but any subsequent font
-  ;; change or horizontal motion will cause termination (because the protocol
-  ;; doesn't support chaining).  [Alternatively, font changes could be accepted
-  ;; as long as they are accompanied with a width return value, or always
-  ;; accept font changes and call text-width as required.  However, horizontal
-  ;; motion can't really be accepted, due to semantics.]  First result is new
-  ;; start, if end was not reached.  Second result is overall width, if known.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type sequence sequence)
-	   (type (or null int32) width)
-	   (type index-size size))
-  (declare (type (or null translation-function) translate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent translate)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg #+Genera * #-Genera translate))
-  (declare (clx-values (or null array-index) (or null int32)))
-  (setf end (index-min (index+ start 255) (or end (length sequence))))
-  (ecase size
-    ((:default 8)
-     (draw-image-glyphs8 drawable gcontext x y sequence start end translate width))
-    (16
-     (draw-image-glyphs16 drawable gcontext x y sequence start end translate width))))
-
-(defun draw-image-glyphs8 (drawable gcontext x y sequence start end translate width)
-  ;; An initial font change is allowed from translate, but any subsequent font
-  ;; change or horizontal motion will cause termination (because the protocol
-  ;; doesn't support chaining).  [Alternatively, font changes could be accepted
-  ;; as long as they are accompanied with a width return value, or always
-  ;; accept font changes and call text-width as required.  However, horizontal
-  ;; motion can't really be accepted, due to semantics.]  First result is new
-  ;; start, if end was not reached.  Second result is overall width, if known.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type array-index start)
-	   (type sequence sequence)
-	   (type (or null array-index) end)
-	   (type (or null int32) width)) 
-  (declare (type (or null translation-function) translate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent translate)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg translate))
-  (declare (clx-values (or null array-index) (or null int32)))
-  (do* ((display (gcontext-display gcontext))
-	(length (index- end start))
-	;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
-	(font (gcontext-font gcontext t))
-	(font-change nil)
-	(new-start) (translated-width) (chunk))
-       (nil) ;; forever
-    (declare (type display display)
-	     (type array-index length)
-	     (type (or null array-index) new-start chunk))
-    
-    (when font-change
-      (setf (gcontext-font gcontext) font))
-    (block change-font
-      (with-buffer-request (display *x-imagetext8* :gc-force gcontext :length length)
-	(drawable drawable)
-	(gcontext gcontext)
-	(int16 x y)
-	(progn
-	  ;; Don't let any flushes happen since we manually set the request
-	  ;; length when we're done.
-	  (with-buffer-flush-inhibited (display)
-	    ;; Translate the sequence into the buffer
-	    (multiple-value-setq (new-start font translated-width)
-	      (funcall (or translate #'translate-default) sequence start end
-		       font buffer-bbuf (index+ buffer-boffset 16)))
-	    ;; Number of glyphs translated
-	    (setq chunk (index- new-start start))		
-	    ;; Check for initial font change
-	    (when (and (index-zerop chunk) (type? font 'font))
-	      (setq font-change t) ;; Loop around changing font
-	      (return-from change-font))
-	    ;; Quit when nothing translated
-	    (when (index-zerop chunk)
-	      (return-from draw-image-glyphs8 new-start))
-	    ;; Update buffer pointers
-	    (data-put 1 chunk)
-	    (let ((blen (lround (index+ 16 chunk))))
-	      (length-put 2 (index-ash blen -2))
-	      (setf (buffer-boffset display) (index+ buffer-boffset blen))))))
-      ;; Normal exit
-      (return-from draw-image-glyphs8
-	(values (if (index= chunk length) nil new-start)
-		(or translated-width width))))))
-
-(defun draw-image-glyphs16 (drawable gcontext x y sequence start end translate width)
-  ;; An initial font change is allowed from translate, but any subsequent font
-  ;; change or horizontal motion will cause termination (because the protocol
-  ;; doesn't support chaining).  [Alternatively, font changes could be accepted
-  ;; as long as they are accompanied with a width return value, or always
-  ;; accept font changes and call text-width as required.  However, horizontal
-  ;; motion can't really be accepted, due to semantics.]  First result is new
-  ;; start, if end was not reached.  Second result is overall width, if known.
-  (declare (type drawable drawable)
-	   (type gcontext gcontext)
-	   (type int16 x y)
-	   (type array-index start)
-	   (type sequence sequence)
-	   (type (or null array-index) end)
-	   (type (or null int32) width))
-  (declare (type (or null translation-function) translate)
-	   #+clx-ansi-common-lisp
-	   (dynamic-extent translate)
-	   #+(and lispm (not clx-ansi-common-lisp))
-	   (sys:downward-funarg translate))
-  (declare (clx-values (or null array-index) (or null int32)))
-  (do* ((display (gcontext-display gcontext))
-	(length (index- end start))
-	;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
-	(font (gcontext-font gcontext t)) 
-	(font-change nil)
-	(new-start) (translated-width) (chunk)
-	(buffer (buffer-tbuf16 display)))
-       (nil) ;; forever
-    
-    (declare (type display display)
-	     (type array-index length)
-	     (type (or null array-index) new-start chunk)
-	     (type buffer-text16 buffer))
-    (when font-change
-      (setf (gcontext-font gcontext) font))
-
-    (block change-font
-      (with-buffer-request (display *x-imagetext16* :gc-force gcontext :length length)
-	(drawable drawable)
-	(gcontext gcontext)
-	(int16 x y)
-	(progn
-	  ;; Don't let any flushes happen since we manually set the request
-	  ;; length when we're done.
-	  (with-buffer-flush-inhibited (display)
-	    ;; Translate the sequence into the buffer
-	    (multiple-value-setq (new-start font translated-width)
-	      (funcall (or translate #'translate-default) sequence start end
-		       font buffer 0))
-	    ;; Number of glyphs translated
-	    (setq chunk (index- new-start start))
-	    ;; Check for initial font change
-	    (when (and (index-zerop chunk) (type? font 'font))
-	      (setq font-change t) ;; Loop around changing font
-	      (return-from change-font))
-	    ;; Quit when nothing translated
-	    (when (index-zerop chunk)
-	      (return-from draw-image-glyphs16 new-start))
-	    (write-sequence-char2b display (index+ buffer-boffset 16) buffer 0 chunk)
-	    ;; Update buffer pointers
-	    (data-put 1 chunk)
-	    (let ((blen (lround (index+ 16 (index-ash chunk 1)))))
-	      (length-put 2 (index-ash blen -2))
-	      (setf (buffer-boffset display) (index+ buffer-boffset blen))))))
-      ;; Normal exit
-      (return-from draw-image-glyphs16
-	(values (if (index= chunk length) nil new-start)
-		(or translated-width width))))))
-
-
-;;-----------------------------------------------------------------------------
-
-(defun display-keycode-range (display)
-  (declare (type display display))
-  (declare (clx-values min max))
-  (values (display-min-keycode display)
-	  (display-max-keycode display)))
-
-;; Should this signal device-busy like the pointer-mapping setf, and return a
-;; boolean instead (true for success)?  Alternatively, should the
-;; pointer-mapping setf be changed to set-pointer-mapping with a (member
-;; :success :busy) result?
-
-(defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5)
-  ;; Setf ought to allow multiple values.
-  (declare (type display display)
-	   (type sequence shift lock control mod1 mod2 mod3 mod4 mod5))
-  (declare (clx-values (member :success :busy :failed)))
-  (let* ((keycodes-per-modifier (index-max (length shift)
-					   (length lock)
-					   (length control)
-					   (length mod1)
-					   (length mod2)
-					   (length mod3)
-					   (length mod4)
-					   (length mod5)))
-	 (data (make-array (index* 8 keycodes-per-modifier)
-			   :element-type 'card8
-			   :initial-element 0)))
-    (replace data shift)
-    (replace data lock :start1 keycodes-per-modifier)
-    (replace data control :start1 (index* 2 keycodes-per-modifier))
-    (replace data mod1 :start1 (index* 3 keycodes-per-modifier))
-    (replace data mod2 :start1 (index* 4 keycodes-per-modifier))
-    (replace data mod3 :start1 (index* 5 keycodes-per-modifier))
-    (replace data mod4 :start1 (index* 6 keycodes-per-modifier))
-    (replace data mod5 :start1 (index* 7 keycodes-per-modifier))
-    (with-buffer-request-and-reply (display *x-setmodifiermapping* 4 :sizes 8)
-	 ((data keycodes-per-modifier)
-	  ((sequence :format card8) data))
-      (values (member8-get 1 :success :busy :failed)))))
-
-(defun modifier-mapping (display)
-  ;; each value is a list of integers
-  (declare (type display display))
-  (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5))
-  (let ((lists nil))
-    (with-buffer-request-and-reply (display *x-getmodifiermapping* nil :sizes 8)
-	 ()
-      (do* ((keycodes-per-modifier (card8-get 1))
-	    (advance-by *replysize* keycodes-per-modifier)
-	    (keys nil nil)
-	    (i 0 (index+ i 1)))
-	   ((index= i 8))
-	(advance-buffer-offset advance-by)
-	(dotimes (j keycodes-per-modifier)
-	  (let ((key (read-card8 j)))
-	    (unless (zerop key)
-	      (push key keys))))
-	(push (nreverse keys) lists)))
-    (values-list (nreverse lists))))
-
-;; Either we will want lots of defconstants for well-known values, or perhaps
-;; an integer-to-keyword translation function for well-known values.
-
-(defun change-keyboard-mapping
-       (display keysyms &key (start 0) end (first-keycode start))
-  ;; start/end give subrange of keysyms
-  ;; first-keycode is the first-keycode to store at
-  (declare (type display display)
-	   (type array-index start)
-	   (type card8 first-keycode)
-	   (type (or null array-index) end)
-	   (type (array * (* *)) keysyms))
-  (let* ((keycode-end (or end (array-dimension keysyms 0)))
-	 (keysyms-per-keycode (array-dimension keysyms 1))
-	 (length (index- keycode-end start))
-	 (size (index* length keysyms-per-keycode))
-	 (request-length (index+ size 2)))
-    (declare (type array-index keycode-end keysyms-per-keycode length request-length))
-    (with-buffer-request (display *x-setkeyboardmapping*
-				  :length (index-ash request-length 2)
-				  :sizes (32))
-      (data length)
-      (length request-length)
-      (card8 first-keycode keysyms-per-keycode)
-      (progn
-	(do ((limit (index-ash (buffer-size display) -2))
-	     (w (index+ 2 (index-ash buffer-boffset -2)))
-	     (i start (index+ i 1)))
-	    ((index>= i keycode-end)
-	     (setf (buffer-boffset display) (index-ash w 2)))
-	  (declare (type array-index limit w i))
-	  (when (index> w limit)
-	    (buffer-flush display)
-	    (setq w (index-ash (buffer-boffset display) -2)))
-	  (do ((j 0 (index+ j 1)))
-	      ((index>= j keysyms-per-keycode))
-	    (declare (type array-index j))
-	    (card29-put (index* w 4) (aref keysyms i j))
-	    (index-incf w))))))) 
-
-(defun keyboard-mapping (display &key first-keycode start end data)
-  ;; First-keycode specifies which keycode to start at (defaults to min-keycode).
-  ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode)
-  ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)).
-  ;; If DATA is specified, the results are put there.
-  (declare (type display display)
-	   (type (or null card8) first-keycode)
-	   (type (or null array-index) start end)
-	   (type (or null (array * (* *))) data))
-  (declare (clx-values (array * (* *))))
-  (unless first-keycode (setq first-keycode (display-min-keycode display)))
-  (unless start (setq start first-keycode))
-  (unless end (setq end (1+ (display-max-keycode display))))
-  (with-buffer-request-and-reply (display *x-getkeyboardmapping* nil :sizes (8 32))
-       ((card8 first-keycode (index- end start)))
-    (do* ((keysyms-per-keycode (card8-get 1))
-	  (bytes-per-keycode (* keysyms-per-keycode 4))
-	  (advance-by *replysize* bytes-per-keycode)
-	  (keycode-count (floor (card32-get 4) keysyms-per-keycode)
-			 (index- keycode-count 1))
-	  (result (if (and (arrayp data)
-			   (= (array-rank data) 2)
-			   (>= (array-dimension data 0) (index+ start keycode-count))
-			   (>= (array-dimension data 1) keysyms-per-keycode))
-		      data
-		    (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode)
-				:element-type 'keysym :initial-element 0)))
-	  (i start (1+ i)))
-	 ((zerop keycode-count) (setq data result))
-      (advance-buffer-offset advance-by)
-      (dotimes (j keysyms-per-keycode)
-	(setf (aref result i j) (card29-get (* j 4))))))
-  data)
diff --git a/clx/translate.lisp b/clx/translate.lisp
deleted file mode 100644
index aa8ff5b2d0b160c1a4160bb3d4c50a36ffa256a0..0000000000000000000000000000000000000000
--- a/clx/translate.lisp
+++ /dev/null
@@ -1,563 +0,0 @@
-;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*-
-
-;;;
-;;;			 TEXAS INSTRUMENTS INCORPORATED
-;;;				  P.O. BOX 2909
-;;;			       AUSTIN, TEXAS 78769
-;;;
-;;; Copyright (C) 1987 Texas Instruments Incorporated.
-;;;
-;;; Permission is granted to any individual or institution to use, copy, modify,
-;;; and distribute this software, provided that this complete copyright and
-;;; permission notice is maintained, intact, in all copies and supporting
-;;; documentation.
-;;;
-;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.
-;;;
-
-(in-package :xlib)
-
-(defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym)
-
-(defun define-keysym-set (set first-keysym last-keysym)
-  ;; Define all keysyms from first-keysym up to and including
-  ;; last-keysym to be in SET (returned from the keysym-set function).
-  ;; Signals an error if the keysym range overlaps an existing set.
- (declare (type keyword set)
-	  (type keysym first-keysym last-keysym))
-  (when (> first-keysym last-keysym)
-    (rotatef first-keysym last-keysym))
-  (setq *keysym-sets* (delete set *keysym-sets* :key #'car))
-  (dolist (set *keysym-sets*)
-    (let ((first (second set))
-	  (last (third set)))
-      (when (or (<= first first-keysym last)
-		(<= first last-keysym last))
-	(error "Keysym range overlaps existing set ~s" set))))
-  (push (list set first-keysym last-keysym) *keysym-sets*)
-  set)
-
-(defun keysym-set (keysym)
-  ;; Return the character code set name of keysym
-  (declare (type keysym keysym)
-	   (clx-values keyword))
-  (dolist (set *keysym-sets*)
-    (let ((first (second set))
-	  (last (third set)))
-      (when (<= first keysym last)
-	(return (first set))))))
-
-(eval-when (compile eval load) ;; Required for Vaxlisp ...
-(defmacro keysym (keysym &rest bytes)
-  ;; Build a keysym.
-  ;; If KEYSYM is an integer, it is used as the most significant bits of
-  ;; the keysym, and BYTES are used to specify low order bytes. The last
-  ;; parameter is always byte4 of the keysym.  If KEYSYM is not an
-  ;; integer, the keysym associated with KEYSYM is returned.
-  ;;
-  ;; This is a macro and not a function macro to promote compile-time
-  ;; lookup. All arguments are evaluated.
-  (declare (type t keysym)
-	   (type list bytes)
-	   (clx-values keysym))
-  (typecase keysym
-    ((integer 0 *)
-     (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b))))
-    (otherwise
-     (or (car (character->keysyms keysym))
-	 (error "~s Isn't the name of a keysym" keysym)))))
-)
-
-(defvar *keysym->character-map*
-	(make-hash-table :test (keysym->character-map-test) :size 400))
-
-;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask)
-;; With the following accessor macros. Everything after OBJECT is optional.
-
-(defmacro keysym-mapping-object (keysym-mapping)
-  ;; Parameter to translate
-  `(first ,keysym-mapping))
-
-(defmacro keysym-mapping-translate (keysym-mapping)
-  ;; Function to be called with parameters (display state OBJECT)
-  ;; when translating KEYSYM and modifiers and mask are satisfied.
-  `(second ,keysym-mapping))
-
-(defmacro keysym-mapping-lowercase (keysym-mapping)
-  ;; LOWERCASE is used for uppercase alphabetic keysyms.  The value
-  ;; is the associated lowercase keysym.
-  `(third ,keysym-mapping))
-
-(defmacro keysym-mapping-modifiers (keysym-mapping)
-  ;; MODIFIERS is either a modifier-mask or list containing intermixed
-  ;; keysyms and state-mask-keys specifying when to use this
-  ;; keysym-translation.
-  `(fourth ,keysym-mapping))
-
-(defmacro keysym-mapping-mask (keysym-mapping)
-  ;; MASK is either a modifier-mask or list containing intermixed
-  ;; keysyms and state-mask-keys specifying which modifiers to look at
-  ;; (i.e.  modifiers not specified are don't-cares)
-  `(fifth ,keysym-mapping))
-
-(defvar *default-keysym-translate-mask*
-	(the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key)))
-	     (logand #xff (lognot (make-state-mask :lock))))
-  "Default keysym state mask to use during keysym-translation.")
-
-(defun define-keysym (object keysym &key lowercase translate modifiers mask display)	              
-  ;; Define the translation from keysym/modifiers to a (usually
-  ;; character) object.  ANy previous keysym definition with
-  ;; KEYSYM and MODIFIERS is deleted before adding the new definition.
-  ;;
-  ;; MODIFIERS is either a modifier-mask or list containing intermixed
-  ;; keysyms and state-mask-keys specifying when to use this
-  ;; keysym-translation.  The default is NIL.
-  ;;
-  ;; MASK is either a modifier-mask or list containing intermixed
-  ;; keysyms and state-mask-keys specifying which modifiers to look at
-  ;; (i.e.  modifiers not specified are don't-cares).
-  ;; If mask is :MODIFIERS then the mask is the same as the modifiers
-  ;; (i.e.  modifiers not specified by modifiers are don't cares)
-  ;; The default mask is *default-keysym-translate-mask*
-  ;;
-  ;; If DISPLAY is specified, the translation will be local to DISPLAY,
-  ;; otherwise it will be the default translation for all displays.
-  ;;
-  ;; LOWERCASE is used for uppercase alphabetic keysyms.  The value
-  ;; is the associated lowercase keysym.  This information is used
-  ;; by the keysym-both-case-p predicate (for caps-lock computations)
-  ;; and by the keysym-downcase function.
-  ;;
-  ;; TRANSLATE will be called with parameters (display state OBJECT)
-  ;; when translating KEYSYM and modifiers and mask are satisfied.
-  ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*))
-  ;;                     (or modifiers 0)))
-  ;;      when mask and modifiers aren't lists of keysyms]
-  ;; The default is #'default-keysym-translate
-  ;;
-  (declare (type (or base-char t) object)
-	   (type keysym keysym)
-	   (type (or null mask16 (clx-list (or keysym state-mask-key)))
-	         modifiers)
-	   (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key)))
-	         mask)
-	   (type (or null display) display)
-           (type (or null keysym) lowercase)
-	   (type (or null (function (display card16 t) t)) translate))
-  (flet ((merge-keysym-mappings (new old)
-	   ;; Merge new keysym-mapping with list of old mappings.
-	   ;; Ensure that the mapping with no modifiers or mask comes first.
-	   (let* ((key (keysym-mapping-modifiers new))
-		  (merge (delete key old :key #'cadddr :test #'equal)))
-	     (if key
-		 (nconc merge (list new))
-	       (cons new merge))))
-	 (mask-check (mask)
-	   (unless (or (numberp mask)
-		       (dolist (element mask t)
-			 (unless (or (find element *state-mask-vector*)
-				     (gethash element *keysym->character-map*))
-			   (return nil))))
-	     (x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym)))))))
-    (let ((entry
-	    ;; Create with a single LIST call, to ensure cdr-coding
-	    (cond
-	      (mask
-	       (unless (eq mask :modifiers)
-		 (mask-check mask))
-	       (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers)))
-		 (error "Mask with no modifiers"))
-	       (list object translate lowercase modifiers mask))
-	      (modifiers (mask-check modifiers)
-			 (list object translate lowercase modifiers))
-	      (lowercase	(list object translate lowercase))
-	      (translate	(list object translate))
-	      (t	(list object)))))
-      (if display
-	  (let ((previous (assoc keysym (display-keysym-translation display))))
-	    (if previous
-		(setf (cdr previous) (merge-keysym-mappings entry (cdr previous)))
-	      (push (list keysym entry) (display-keysym-translation display))))
-	(setf (gethash keysym *keysym->character-map*)
-	      (merge-keysym-mappings entry (gethash keysym *keysym->character-map*)))))
-    object))
-
-(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys)	              
-  ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS.
-  ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists.
-  (declare (type (or base-char t) object)
-	   (type keysym keysym)
-	   (type (or null mask16 (clx-list (or keysym state-mask-key)))
-	         modifiers)
-	   (type (or null display) display))
-  (flet ((match (key entry)
-	   (let ((object (car key))
-		 (modifiers (cdr key)))
-	     (or (eql object (keysym-mapping-object entry))
-		 (equal modifiers (keysym-mapping-modifiers entry))))))
-    (let* (entry
-	   (previous (if display
-			 (cdr (setq entry (assoc keysym (display-keysym-translation display))))
-		       (gethash keysym *keysym->character-map*)))
-	   (key (cons object modifiers)))
-      (when (and previous (find key previous :test #'match))
-	(setq previous (delete key previous :test #'match))
-	(if display
-	    (setf (cdr entry) previous)
-	  (setf (gethash keysym *keysym->character-map*) previous))))))
-
-(defun keysym-downcase (keysym)
-  ;; If keysym has a lower-case equivalent, return it, otherwise return keysym.
-  (declare (type keysym keysym))
-  (declare (clx-values keysym))
-  (let ((translations (gethash keysym *keysym->character-map*)))
-    (or (and translations (keysym-mapping-lowercase (first translations))) keysym)))
-
-(defun keysym-uppercase-alphabetic-p (keysym)
-  ;; Returns T if keysym is uppercase-alphabetic.
-  ;; I.E. If it has a lowercase equivalent.
-  (declare (type keysym keysym))
-  (declare (clx-values (or null keysym)))
-  (let ((translations (gethash keysym *keysym->character-map*)))
-    (and translations
-	 (keysym-mapping-lowercase (first translations)))))
-
-(defun character->keysyms (character &optional display)
-  ;; Given a character, return a list of all matching keysyms.
-  ;; If DISPLAY is given, translations specific to DISPLAY are used,
-  ;; otherwise only global translations are used.
-  ;; Implementation dependent function.
-  ;; May be slow [i.e. do a linear search over all known keysyms]
-  (declare (type t character)
-	   (type (or null display) display)
-	   (clx-values (clx-list keysym)))
-  (let ((result nil))
-    (when display
-      (dolist (mapping (display-keysym-translation display))
-	(when (eql character (second mapping))
-	  (push (first mapping) result))))
-    (maphash #'(lambda (keysym mappings)
-		 (dolist (mapping mappings)
-		   (when (eql (keysym-mapping-object mapping) character)
-		     (pushnew keysym result))))
-	     *keysym->character-map*)
-    result))
-
-(eval-when (compile eval load) ;; Required for Symbolics...
-(defconstant character-set-switch-keysym (keysym 255 126))
-(defconstant left-shift-keysym (keysym 255 225))
-(defconstant right-shift-keysym (keysym 255 226))
-(defconstant left-control-keysym (keysym 255 227))
-(defconstant right-control-keysym (keysym 255 228))
-(defconstant caps-lock-keysym (keysym 255 229))
-(defconstant shift-lock-keysym (keysym 255 230))
-(defconstant left-meta-keysym (keysym 255 231))
-(defconstant right-meta-keysym (keysym 255 232))
-(defconstant left-alt-keysym (keysym 255 233))
-(defconstant right-alt-keysym (keysym 255 234))
-(defconstant left-super-keysym (keysym 255 235))
-(defconstant right-super-keysym (keysym 255 236))
-(defconstant left-hyper-keysym (keysym 255 237))
-(defconstant right-hyper-keysym (keysym 255 238))
-) ;; end eval-when
-
-
-;;-----------------------------------------------------------------------------
-;; Keysym mapping functions
-
-(defun display-keyboard-mapping (display)
-  (declare (type display display))
-  (declare (clx-values (simple-array keysym (display-max-keycode keysyms-per-keycode))))
-  (or (display-keysym-mapping display)
-      (setf (display-keysym-mapping display) (keyboard-mapping display))))
-
-(defun keycode->keysym (display keycode keysym-index)
-  (declare (type display display)
-	   (type card8 keycode)
-	   (type card8 keysym-index)
-	   (clx-values keysym))
-  (let* ((mapping (display-keyboard-mapping display))
-	 (keysym (aref mapping keycode keysym-index)))
-    (declare (type (simple-array keysym (* *)) mapping)
-	     (type keysym keysym))
-    ;; The keysym-mapping is brain dammaged.
-    ;; Mappings for both-case alphabetic characters have the
-    ;; entry for keysym-index zero set to the uppercase keysym
-    ;; (this is normally where the lowercase keysym goes), and the
-    ;; entry for keysym-index one is zero.
-    (cond ((zerop keysym-index)			; Lowercase alphabetic keysyms
-	   (keysym-downcase keysym))
-	  ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym
-	   (aref mapping keycode 0))
-	  (t keysym))))
-
-(defun keysym->character (display keysym &optional (state 0))
-  ;; Find the character associated with a keysym.
-  ;; STATE can be used to set character attributes.
-  ;; Implementation dependent function.
-  (declare (type display display)
-	   (type keysym keysym)
-	   (type card16 state))
-  (declare (clx-values (or null character)))
-  (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display))))
-	 (mapping (or ;; Find the matching display mapping
-		      (dolist (mapping display-mappings)
-			(when (mapping-matches-p display state mapping)
-			  (return mapping)))
-		      ;; Find the matching static mapping
-		      (dolist (mapping (gethash keysym *keysym->character-map*))
-			(when (mapping-matches-p display state mapping)
-			  (return mapping))))))
-    (when mapping
-      (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate)
-	       display state (keysym-mapping-object mapping)))))
-
-(defun mapping-matches-p (display state mapping)
-  ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY
-  (declare (type display display)
-	   (type mask16 state)
-	   (type list mapping))
-  (declare (clx-values boolean))
-  (flet
-    ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0))
-       ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask.
-       ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified,
-       ;; otherwise ignore unknown modifiers.
-       (declare (type list display-mapping)	; Alist of (keysym . mask)
-		(type (or mask16 list) modifiers)
-		(type mask16 mask))
-       (declare (clx-values (or null mask16)))
-       (if (numberp modifiers)
-	   modifiers
-	 (dolist (modifier modifiers mask)
-	   (declare (type symbol modifier))
-	   (let ((bit (position modifier (the simple-vector *state-mask-vector*) :test #'eq)))
-	     (setq mask
-		   (logior mask
-			   (if bit
-			       (ash 1 bit)
-			     (or (cdr (assoc modifier display-mapping))
-				 ;; bad modifier
-				 (if errorp
-				     (return-from modifiers->mask nil)
-				   0))))))))))
-
-    (let* ((display-mapping (get-display-modifier-mapping display))
-	   (mapping-modifiers (keysym-mapping-modifiers mapping))
-	   (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t)
-			  (return-from mapping-matches-p nil)))
-	   (mapping-mask (or (keysym-mapping-mask mapping)	; If no mask, use the default.
-			     (if mapping-modifiers	        ; If no modifiers, match anything.
-				 *default-keysym-translate-mask*
-			       0)))
-	   (mask (if (eq mapping-mask :modifiers)
-		     modifiers
-		   (modifiers->mask display-mapping mapping-mask nil))))
-      (declare (type mask16 modifiers mask))
-      (= (logand state mask) modifiers))))
-
-(defun default-keysym-index (display keycode state)
-  ;; Returns a keysym-index for use with keycode->character
-  (declare (clx-values card8))
-  (macrolet ((keystate-p (state keyword)
-	       `(the boolean
-		     (logbitp ,(position keyword *state-mask-vector*)
-			      ,state))))
-    (let* ((mapping (display-keyboard-mapping display))
-	   (keysyms-per-keycode (array-dimension mapping 1))
-	   (symbolp (and (> keysyms-per-keycode 2)
-			 (state-keysymp display state character-set-switch-keysym)))
-	   (result (if symbolp 2 0)))
-      (declare (type (simple-array keysym (* *)) mapping)
-	       (type boolean symbolp)
-	       (type card8 keysyms-per-keycode result))
-      (when (and (< result keysyms-per-keycode)
-		 (keysym-shift-p display state (keysym-uppercase-alphabetic-p
-						 (aref mapping keycode 0))))
-	(incf result))
-      result)))
-
-(defun keysym-shift-p (display state uppercase-alphabetic-p &key
-		       shift-lock-xors
-		       (control-modifiers
-			 '#.(list left-meta-keysym left-super-keysym left-hyper-keysym)))
-  (declare (type display display)
-	   (type card16 state)
-	   (type boolean uppercase-alphabetic-p)
-	   (type boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same
-	                                  ;;; as neither if the character is alphabetic.
-  (declare (clx-values boolean))
-  (macrolet ((keystate-p (state keyword)
-	       `(the boolean
-		     (logbitp ,(position keyword *state-mask-vector*)
-			      ,state))))
-    (let* ((controlp (or (keystate-p state :control)
-			 (dolist (modifier control-modifiers)
-			   (when (state-keysymp display state modifier)
-			     (return t)))))
-	   (shiftp (keystate-p state :shift))
-	   (lockp  (keystate-p state :lock))
-	   (alphap (or uppercase-alphabetic-p
-		       (not (state-keysymp display #.(make-state-mask :lock)
-					   caps-lock-keysym)))))
-      (declare (type boolean controlp shiftp lockp alphap))
-      ;; Control keys aren't affected by lock
-      (unless controlp
-	;; Not a control character - check state of lock modifier
-	(when (and lockp
-		   alphap
-		   (or (not shiftp) shift-lock-xors))	; Lock doesn't unshift unless shift-lock-xors
-	  (setq shiftp (not shiftp))))
-      shiftp)))
-
-;;; default-keysym-index implements the following tables:
-;;;
-;;; control shift caps-lock character               character
-;;;   0       0       0       #\a                      #\8
-;;;   0       0       1       #\A                      #\8
-;;;   0       1       0       #\A                      #\*
-;;;   0       1       1       #\A                      #\*
-;;;   1       0       0       #\control-A              #\control-8
-;;;   1       0       1       #\control-A              #\control-8
-;;;   1       1       0       #\control-shift-a        #\control-*
-;;;   1       1       1       #\control-shift-a        #\control-*
-;;;
-;;; control shift shift-lock character               character
-;;;   0       0       0       #\a                      #\8
-;;;   0       0       1       #\A                      #\*
-;;;   0       1       0       #\A                      #\*
-;;;   0       1       1       #\A                      #\8
-;;;   1       0       0       #\control-A              #\control-8
-;;;   1       0       1       #\control-A              #\control-*
-;;;   1       1       0       #\control-shift-a        #\control-*
-;;;   1       1       1       #\control-shift-a        #\control-8
-
-(defun keycode->character (display keycode state &key keysym-index
-	                   (keysym-index-function #'default-keysym-index))
-  ;; keysym-index defaults to the result of keysym-index-function which
-  ;; is called with the following parameters:
-  ;; (char0 state caps-lock-p keysyms-per-keycode)
-  ;; where char0 is the "character" object associated with keysym-index 0 and
-  ;; caps-lock-p is non-nil when the keysym associated with the lock
-  ;; modifier is for caps-lock.
-  ;; STATE can also used for setting character attributes.
-  ;; Implementation dependent function.
-  (declare (type display display)
-	   (type card8 keycode)
-	   (type card16 state)
-	   (type (or null card8) keysym-index)
-	   (type (or null (function (base-char card16 boolean card8) card8))
-		 keysym-index-function))
-  (declare (clx-values (or null character)))
-  (let* ((index (or keysym-index
-		    (funcall keysym-index-function display keycode state)))
-	 (keysym (if index (keycode->keysym display keycode index) 0)))
-    (declare (type (or null card8) index)
-	     (type keysym keysym))
-    (when (plusp keysym)
-      (keysym->character display keysym state))))
-
-(defun get-display-modifier-mapping (display)
-  (labels ((keysym-replace (display modifiers mask &aux result)
-	     (dolist (modifier modifiers result)
-	       (push (cons (keycode->keysym display modifier 0) mask) result))))
-    (or (display-modifier-mapping display)
-	(multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5)
-	    (modifier-mapping display)
-	  (setf (display-modifier-mapping display)
-		(nconc (keysym-replace display shift #.(make-state-mask :shift))
-		       (keysym-replace display lock #.(make-state-mask :lock))
-		       (keysym-replace display control #.(make-state-mask :control))
-		       (keysym-replace display mod1 #.(make-state-mask :mod-1))
-		       (keysym-replace display mod2 #.(make-state-mask :mod-2))
-		       (keysym-replace display mod3 #.(make-state-mask :mod-3))
-		       (keysym-replace display mod4 #.(make-state-mask :mod-4))
-		       (keysym-replace display mod5 #.(make-state-mask :mod-5))))))))
-
-(defun state-keysymp (display state keysym)
-  ;; Returns T when a modifier key associated with KEYSYM is on in STATE
-  (declare (type display display)
-	   (type card16 state)
-	   (type keysym keysym))
-  (declare (clx-values boolean))
-  (let* ((mapping (get-display-modifier-mapping display))
-	 (mask (assoc keysym mapping)))
-    (and mask (plusp (logand state (cdr mask))))))
-
-(defun mapping-notify (display request start count)
-  ;; Called on a mapping-notify event to update
-  ;; the keyboard-mapping cache in DISPLAY
-  (declare (type display display)
-	   (type (member :modifier :keyboard :pointer) request)
-	   (type card8 start count)
-	   (ignore count start))
-  ;; Invalidate the keyboard mapping to force the next key translation to get it
-  (case request
-    (:modifier 
-     (setf (display-modifier-mapping display) nil))
-    (:keyboard
-     (setf (display-keysym-mapping display) nil))))
-
-(defun keysym-in-map-p (display keysym keymap)
-  ;; Returns T if keysym is found in keymap
-  (declare (type display display)
-	   (type keysym keysym)
-	   (type (bit-vector 256) keymap))
-  (declare (clx-values boolean))
-  ;; The keysym may appear in the keymap more than once,
-  ;; So we have to search the entire keysym map.
-  (do* ((min (display-min-keycode display))
-	(max (display-max-keycode display))
-	(map (display-keyboard-mapping display))
-	(jmax (min 2 (array-dimension map 1)))
-	(i min (1+ i)))
-      ((> i max))
-    (declare (type card8 min max jmax)
-	     (type (simple-array keysym (* *)) map))
-    (when (and (plusp (aref keymap i))
-	       (dotimes (j jmax)
-		 (when (= keysym (aref map i j)) (return t))))
-      (return t))))
-
-(defun character-in-map-p (display character keymap)
-  ;; Implementation dependent function.
-  ;; Returns T if character is found in keymap
-  (declare (type display display)
-	   (type character character)
-	   (type (bit-vector 256) keymap))
-  (declare (clx-values boolean))
-  ;; Check all one bits in keymap
-  (do* ((min (display-min-keycode display))
-	(max (display-max-keycode display))
-	(jmax (array-dimension (display-keyboard-mapping display) 1))
-	(i min (1+ i)))
-      ((> i max))
-    (declare (type card8 min max jmax))
-    (when (and (plusp (aref keymap i))
-	       ;; Match when character is in mapping for this keycode
-	       (dotimes (j jmax)
-		 (when (eql character (keycode->character display i 0 :keysym-index j))
-		   (return t))))
-      (return t))))
-
-(defun keysym->keycodes (display keysym)
-  ;; Return keycodes for keysym, as multiple values
-  (declare (type display display)
-	   (type keysym keysym))
-  (declare (clx-values (or null keycode) (or null keycode) (or null keycode)))
-  ;; The keysym may appear in the keymap more than once,
-  ;; So we have to search the entire keysym map.
-  (do* ((min (display-min-keycode display))
-	(max (display-max-keycode display))
-	(map (display-keyboard-mapping display))
-	(jmax (min 2 (array-dimension map 1)))
-	(i min (1+ i))
-	(result nil))
-      ((> i max) (values-list result))
-    (declare (type card8 min max jmax)
-	     (type (simple-array keysym (* *)) map))
-    (dotimes (j jmax)
-      (when (= keysym (aref map i j))
-	(push i result)))))
diff --git a/code/alieneval.lisp b/code/alieneval.lisp
deleted file mode 100644
index 8c85f14f7611be0862cc14118e76247be832cf77..0000000000000000000000000000000000000000
--- a/code/alieneval.lisp
+++ /dev/null
@@ -1,1950 +0,0 @@
-;;; -*- Package: ALIEN -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.27 1992/11/11 02:33:52 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains any the part of the Alien implementation that
-;;; is not part of the compiler.
-;;;
-(in-package "ALIEN")
-(use-package "EXT")
-(use-package "SYSTEM")
-
-(export '(alien * array struct union enum function integer signed unsigned
-	  boolean values single-float double-float system-area-pointer
-	  def-alien-type def-alien-variable sap-alien
-	  extern-alien with-alien slot deref addr cast alien-sap alien-size
-	  alien-funcall def-alien-routine make-alien free-alien
-	  null-alien))
-
-(in-package "ALIEN-INTERNALS")
-(in-package "ALIEN")
-
-(import '(alien alien-value alien-value-type parse-alien-type
-	  unparse-alien-type alien-type-= alien-subtype-p alien-typep
-
-	  def-alien-type-class def-alien-type-translator def-alien-type-method
-	  invoke-alien-type-method
-
-	  alien-type alien-type-p alien-type-bits alien-type-alignment
-	  alien-integer-type alien-integer-type-p alien-integer-type-signed
-	  alien-boolean-type alien-boolean-type-p
-	  alien-enum-type alien-enum-type-p
-	  alien-float-type alien-float-type-p
-	  alien-single-float-type alien-single-float-type-p
-	  alien-double-float-type alien-double-float-type-p
-	  alien-pointer-type alien-pointer-type-p alien-pointer-type-to
-	  make-alien-pointer-type
-	  alien-array-type alien-array-type-p alien-array-type-element-type
-	  alien-array-type-dimensions	  
-	  alien-record-type alien-record-type-p alien-record-type-fields
-	  alien-record-field alien-record-field-p alien-record-field-name
-	  alien-record-field-type alien-record-field-offset
-	  alien-function-type alien-function-type-p make-alien-function-type
-	  alien-function-type-result-type alien-function-type-arg-types
-	  alien-values-type alien-values-type-p alien-values-type-values
-	  *values-type-okay*
-
-	  %set-slot %slot-addr %set-deref %deref-addr
-
-	  %heap-alien %set-heap-alien %heap-alien-addr
-	  heap-alien-info heap-alien-info-p heap-alien-info-type
-	  heap-alien-info-sap-form
-
-	  local-alien %set-local-alien %local-alien-addr
-	  local-alien-info local-alien-info-p local-alien-info-type
-	  local-alien-info-force-to-memory-p
-	  %local-alien-forced-to-memory-p
-	  make-local-alien dispose-local-alien note-local-alien-type
-
-	  %cast %sap-alien align-offset
-
-	  extract-alien-value deposit-alien-value naturalize deport
-	  compute-lisp-rep-type compute-alien-rep-type
-	  compute-extract-lambda compute-deposit-lambda
-	  compute-naturalize-lambda compute-deport-lambda)
-	"ALIEN-INTERNALS")
-
-(export '(alien alien-value alien-value-type parse-alien-type
-	  unparse-alien-type alien-type-= alien-subtype-p alien-typep
-
-	  def-alien-type-class def-alien-type-translator def-alien-type-method
-	  invoke-alien-type-method
-
-	  alien-type alien-type-p alien-type-bits alien-type-alignment
-	  alien-integer-type alien-integer-type-p alien-integer-type-signed
-	  alien-boolean-type alien-boolean-type-p
-	  alien-enum-type alien-enum-type-p
-	  alien-float-type alien-float-type-p
-	  alien-single-float-type alien-single-float-type-p
-	  alien-double-float-type alien-double-float-type-p
-	  alien-pointer-type alien-pointer-type-p alien-pointer-type-to
-	  make-alien-pointer-type
-	  alien-array-type alien-array-type-p alien-array-type-element-type
-	  alien-array-type-dimensions	  
-	  alien-record-type alien-record-type-p alien-record-type-fields
-	  alien-record-field alien-record-field-p alien-record-field-name
-	  alien-record-field-type alien-record-field-offset
-	  alien-function-type alien-function-type-p make-alien-function-type
-	  alien-function-type-result-type alien-function-type-arg-types
-	  alien-values-type alien-values-type-p alien-values-type-values
-	  *values-type-okay*
-
-	  %set-slot %slot-addr %set-deref %deref-addr
-
-	  %heap-alien %set-heap-alien %heap-alien-addr
-	  heap-alien-info heap-alien-info-p heap-alien-info-type
-	  heap-alien-info-sap-form
-
-	  local-alien %set-local-alien %local-alien-addr
-	  local-alien-info local-alien-info-p local-alien-info-type
-	  local-alien-info-force-to-memory-p
-	  %local-alien-forced-to-memory-p
-	  make-local-alien dispose-local-alien note-local-alien-type
-
-	  %cast %sap-alien align-offset
-
-	  extract-alien-value deposit-alien-value naturalize deport
-	  compute-lisp-rep-type compute-alien-rep-type
-	  compute-extract-lambda compute-deposit-lambda
-	  compute-naturalize-lambda compute-deport-lambda)
-	"ALIEN-INTERNALS")
-
-
-
-;;;; Utility functions.
-
-(defun align-offset (offset alignment)
-  (let ((extra (rem offset alignment)))
-    (if (zerop extra) offset (+ offset (- alignment extra)))))
-
-(defun guess-alignment (bits)
-  (cond ((null bits) nil)
-	((> bits 16) 32)
-	((> bits 8) 16)
-	((> bits 1) 8)
-	(t 1)))
-
-
-;;;; Alien-type-info stuff.
-
-(eval-when (compile eval load)
-
-(defstruct (alien-type-class
-	    (:print-function %print-alien-type-class))
-  (name nil :type symbol)
-  (include nil :type (or null alien-type-class))
-  (unparse nil :type (or null function))
-  (type= nil :type (or null function))
-  (lisp-rep nil :type (or null function))
-  (alien-rep nil :type (or null function))
-  (extract-gen nil :type (or null function))
-  (deposit-gen nil :type (or null function))
-  (naturalize-gen nil :type (or null function))
-  (deport-gen nil :type (or null function))
-  ;; Cast?
-  (arg-tn nil :type (or null function))
-  (result-tn nil :type (or null function))
-  (subtypep nil :type (or null function)))
-
-(defun %print-alien-type-class (type-class stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (type-class stream :type t)
-    (prin1 (alien-type-class-name type-class) stream)))
-
-(defvar *alien-type-classes* (make-hash-table :test #'eq))
-
-(defun alien-type-class-or-lose (name)
-  (or (gethash name *alien-type-classes*)
-      (error "No alien type class ~S" name)))
-
-(defun create-alien-type-class-if-necessary (name include)
-  (let ((old (gethash name *alien-type-classes*))
-	(include (and include (alien-type-class-or-lose include))))
-    (if old
-	(setf (alien-type-class-include old) include)
-	(setf (gethash name *alien-type-classes*)
-	      (make-alien-type-class :name name :include include)))))
-
-(defconstant method-slot-alist
-  '((:unparse . alien-type-class-unparse)
-    (:type= . alien-type-class-type=)
-    (:subtypep . alien-type-class-subtypep)
-    (:lisp-rep . alien-type-class-lisp-rep)
-    (:alien-rep . alien-type-class-alien-rep)
-    (:extract-gen . alien-type-class-extract-gen)
-    (:deposit-gen . alien-type-class-deposit-gen)
-    (:naturalize-gen . alien-type-class-naturalize-gen)
-    (:deport-gen . alien-type-class-deport-gen)
-    ;; Cast?
-    (:arg-tn . alien-type-class-arg-tn)
-    (:result-tn . alien-type-class-result-tn)))
-
-(defun method-slot (method)
-  (cdr (or (assoc method method-slot-alist)
-	   (error "No method ~S" method))))
-
-); eval-when
-
-
-(defmacro def-alien-type-class ((name &key include) &rest slots)
-  (let ((defstruct-name
-	 (intern (concatenate 'string "ALIEN-" (symbol-name name) "-TYPE"))))
-    (multiple-value-bind
-	(include include-defstruct overrides)
-	(etypecase include
-	  (null
-	   (values nil 'alien-type nil))
-	  (symbol
-	   (values
-	    include
-	    (intern (concatenate 'string
-				 "ALIEN-" (symbol-name include) "-TYPE"))
-	    nil))
-	  (list
-	   (values
-	    (car include)
-	    (intern (concatenate 'string
-				 "ALIEN-" (symbol-name (car include)) "-TYPE"))
-	    (cdr include))))
-      `(progn
-	 (eval-when (compile load eval)
-	   (create-alien-type-class-if-necessary ',name ',(or include 'root)))
-	 (defstruct (,defstruct-name
-			(:include ,include-defstruct
-				  (:class ',name)
-				  ,@overrides))
-	   ,@slots)))))
-
-(defmacro def-alien-type-method ((class method) lambda-list &rest body)
-  (let ((defun-name (intern (concatenate 'string
-					 (symbol-name class)
-					 "-"
-					 (symbol-name method)
-					 "-METHOD"))))
-    `(progn
-       (defun ,defun-name ,lambda-list
-	 ,@body)
-       (setf (,(method-slot method) (alien-type-class-or-lose ',class))
-	     #',defun-name))))
-
-(defmacro invoke-alien-type-method (method type &rest args)
-  (let ((slot (method-slot method)))
-    (once-only ((type type))
-      `(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type))
-			    (alien-type-class-include class)))
-		    ((null class)
-		     (error "Method ~S not defined for ~S"
-			    ',method (alien-type-class ,type)))
-		  (let ((fn (,slot class)))
-		    (when fn
-		      (return fn))))
-		,type ,@args))))
-
-
-
-;;;; Alien-type defstruct.
-
-(eval-when (compile load eval)
-  (create-alien-type-class-if-necessary 'root nil))
-
-(defstruct (alien-type
-	    (:print-function %print-alien-type)
-	    (:make-load-form-fun :just-dump-it-normally))
-  (class 'root :type symbol)
-  (bits nil :type (or null unsigned-byte))
-  (alignment (guess-alignment bits) :type (or null unsigned-byte)))
-
-(defun %print-alien-type (type stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (type stream :type t)
-    (prin1 (unparse-alien-type type) stream)))
-
-
-;;;; Type parsing and unparsing.
-
-(defvar *auxiliary-type-definitions* nil)
-(defvar *new-auxiliary-types*)
-
-;;; WITH-AUXILIARY-ALIEN-TYPES -- internal.
-;;;
-;;; Process stuff in a new scope.
-;;;
-(defmacro with-auxiliary-alien-types (&body body)
-  `(let ((*auxiliary-type-definitions*
-	  (if (boundp '*new-auxiliary-types*)
-	      (append *new-auxiliary-types* *auxiliary-type-definitions*)
-	      *auxiliary-type-definitions*))
-	 (*new-auxiliary-types* nil))
-     ,@body))
-
-;;; PARSE-ALIEN-TYPE -- public
-;;;
-(defun parse-alien-type (type)
-  "Parse the list structure TYPE as an alien type specifier and return
-   the resultant alien-type structure."
-  (if (boundp '*new-auxiliary-types*)
-      (%parse-alien-type type)
-      (let ((*new-auxiliary-types* nil))
-	(%parse-alien-type type))))
-
-(defun %parse-alien-type (type)
-  (if (consp type)
-      (let ((translator (info alien-type translator (car type))))
-	(unless translator
-	  (error "Unknown alien type: ~S" type))
-	(funcall translator type))
-      (case (info alien-type kind type)
-	(:primitive
-	 (let ((translator (info alien-type translator type)))
-	   (unless translator
-	     (error "No translator for primitive alien type ~S?" type))
-	   (funcall translator (list type))))
-	(:defined
-	 (or (info alien-type definition type)
-	     (error "Definition missing for alien type ~S?" type)))
-	(:unknown
-	 (error "Unknown alien type: ~S" type)))))
-
-(defun auxiliary-alien-type (kind name)
-  (flet ((aux-defn-matches (x)
-	   (and (eq (first x) kind) (eq (second x) name))))
-    (let ((in-auxiliaries
-	   (or (find-if #'aux-defn-matches *new-auxiliary-types*)
-	       (find-if #'aux-defn-matches *auxiliary-type-definitions*))))
-      (if in-auxiliaries
-	  (values (third in-auxiliaries) t)
-	  (ecase kind
-	    (:struct
-	     (info alien-type struct name))
-	    (:union
-	     (info alien-type union name))
-	    (:enum
-	     (info alien-type enum name)))))))
-
-(defun %set-auxiliary-alien-type (kind name defn)
-  (flet ((aux-defn-matches (x)
-	   (and (eq (first x) kind) (eq (second x) name))))
-    (when (find-if #'aux-defn-matches *new-auxiliary-types*)
-      (error "Attempt to multiple define ~A ~S." kind name))
-    (when (find-if #'aux-defn-matches *auxiliary-type-definitions*)
-      (error "Attempt to shadow definition of ~A ~S." kind name)))
-  (push (list kind name defn) *new-auxiliary-types*)
-  defn)
-
-(defsetf auxiliary-alien-type %set-auxiliary-alien-type)
-
-(defun verify-local-auxiliaries-okay ()
-  (dolist (info *new-auxiliary-types*)
-    (destructuring-bind (kind name defn) info
-      (declare (ignore defn))
-      (when (ecase kind
-	      (:struct
-	       (info alien-type struct name))
-	      (:union
-	       (info alien-type union name))
-	      (:enum
-	       (info alien-type enum name)))
-	(error "Attempt to shadow definition of ~A ~S." kind name)))))
-
-;;; *record-type-already-unparsed* -- internal
-;;;
-;;; Holds the list of record types that have already been unparsed.  This is
-;;; used to keep from outputing the slots again if the same structure shows
-;;; up twice.
-;;; 
-(defvar *record-types-already-unparsed*)
-
-;;; UNPARSE-ALIEN-TYPE -- public.
-;;; 
-(defun unparse-alien-type (type)
-  "Convert the alien-type structure TYPE back into a list specification of
-   the type."
-  (declare (type alien-type type))
-  (let ((*record-types-already-unparsed* nil))
-    (%unparse-alien-type type)))
-
-;;; %UNPARSE-ALIEN-TYPE -- internal.
-;;;
-;;; Does all the work of UNPARSE-ALIEN-TYPE.  It's seperate because we need
-;;; to recurse inside the binding of *record-types-already-unparsed*.
-;;; 
-(defun %unparse-alien-type (type)
-  (invoke-alien-type-method :unparse type))
-
-
-
-
-;;;; Alien type defining stuff.
-
-(defmacro def-alien-type-translator (name lambda-list &body body)
-  (let ((whole (gensym))
-	(defun-name (intern (concatenate 'string
-					 "ALIEN-"
-					 (symbol-name name)
-					 "-TYPE-TRANSLATOR"))))
-    (multiple-value-bind
-	(body decls docs)
-	(lisp::parse-defmacro lambda-list whole body name
-			      'def-alien-type-translator)
-      `(progn
-	 (defun ,defun-name (,whole)
-	   ,decls
-	   (block ,name
-	     ,body))
-	 (%def-alien-type-translator ',name #',defun-name ,docs)))))
-
-(defun %def-alien-type-translator (name translator docs)
-  (declare (ignore docs))
-  (setf (info alien-type kind name) :primitive)
-  (setf (info alien-type translator name) translator)
-  (clear-info alien-type definition name)
-  #+nil
-  (setf (documentation name 'alien-type) docs)
-  name)
-
-
-(defmacro def-alien-type (name type)
-  "Define the alien type NAME to be equivalent to TYPE.  Name may be NIL for
-   STRUCT and UNION types, in which case the name is taken from the type
-   specifier."
-  (with-auxiliary-alien-types
-    (let ((alien-type (parse-alien-type type)))
-      `(eval-when (compile load eval)
-	 ,@(when *new-auxiliary-types*
-	     `((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
-	 ,@(when name
-	     `((%def-alien-type ',name ',alien-type)))))))
-
-(defun %def-auxiliary-alien-types (types)
-  (dolist (info types)
-    (destructuring-bind (kind name defn) info
-      (macrolet ((frob (kind)
-		   `(let ((old (info alien-type ,kind name)))
-		      (unless (or (null old) (alien-type-= old defn))
-			(warn "Redefining ~A ~S to be:~%  ~S,~%was:~%  ~S"
-			      kind name defn old))
-		      (setf (info alien-type ,kind name) defn))))
-	(ecase kind
-	  (:struct (frob struct))
-	  (:union (frob union))
-	  (:enum (frob enum)))))))
-
-(defun %def-alien-type (name new)
-  (ecase (info alien-type kind name)
-    (:primitive
-     (error "~S is a built-in alien type." name))
-    (:defined
-     (let ((old (info alien-type definition name)))
-       (unless (or (null old) (alien-type-= new old))
-	 (warn "Redefining ~S to be:~%  ~S,~%was~%  ~S" name
-	       (unparse-alien-type new) (unparse-alien-type old)))))
-    (:unknown))
-  (setf (info alien-type definition name) new)
-  (setf (info alien-type kind name) :defined)
-  name)
-
-
-
-;;;; Interfaces to the different methods
-
-(defun alien-type-= (type1 type2)
-  "Return T iff TYPE1 and TYPE2 describe equivalent alien types."
-  (or (eq type1 type2)
-      (and (eq (alien-type-class type1)
-	       (alien-type-class type2))
-	   (invoke-alien-type-method :type= type1 type2))))
-
-(defun alien-subtype-p (type1 type2)
-  "Return T iff the alien type TYPE1 is a subtype of TYPE2.  Currently, the
-   only supported subtype relationships are is that any pointer type is a
-   subtype of (* t), and any array type first dimension will match 
-   (array <eltype> nil ...).  Otherwise, the two types have to be
-   ALIEN-TYPE-=."
-  (or (eq type1 type2)
-      (invoke-alien-type-method :subtypep type1 type2)))
-
-(defun alien-typep (object type)
-  "Return T iff OBJECT is an alien of type TYPE."
-  (let ((lisp-rep-type (compute-lisp-rep-type type)))
-    (if lisp-rep-type
-	(typep object lisp-rep-type)
-	(and (alien-value-p object)
-	     (alien-subtype-p (alien-value-type object) type)))))
-
-
-(defun compute-naturalize-lambda (type)
-  `(lambda (alien ignore)
-     (declare (ignore ignore))
-     ,(invoke-alien-type-method :naturalize-gen type 'alien)))
-
-(defun compute-deport-lambda (type)
-  (declare (type alien-type type))
-  (multiple-value-bind
-      (form value-type)
-      (invoke-alien-type-method :deport-gen type 'value)
-    `(lambda (value ignore)
-       (declare (type ,(or value-type
-			   (compute-lisp-rep-type type)
-			   `(alien ,type))
-		      value)
-		(ignore ignore))
-       ,form)))
-
-(defun compute-extract-lambda (type)
-  `(lambda (sap offset ignore)
-     (declare (type system-area-pointer sap)
-	      (type unsigned-byte offset)
-	      (ignore ignore))
-     (naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset)
-		 ',type)))
-
-(defun compute-deposit-lambda (type)
-  (declare (type alien-type type))
-  `(lambda (sap offset ignore value)
-     (declare (type system-area-pointer sap)
-	      (type unsigned-byte offset)
-	      (ignore ignore))
-     (let ((value (deport value ',type)))
-       ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
-       ;; Note: the reason we don't just return the pre-deported value
-       ;; is because that would inhibit any (deport (naturalize ...))
-       ;; optimizations that might have otherwise happen.  Re-naturalizing
-       ;; the value might cause extra consing, but is flushable, so probably
-       ;; results in better code.
-       (naturalize value ',type))))
-
-(defun compute-lisp-rep-type (type)
-  (invoke-alien-type-method :lisp-rep type))
-
-(defun compute-alien-rep-type (type)
-  (invoke-alien-type-method :alien-rep type))
-
-
-
-
-
-;;;; Default methods.
-
-(def-alien-type-method (root :unparse) (type)
-  `(!!unknown-alien-type!! ,(type-of type)))
-
-(def-alien-type-method (root :type=) (type1 type2)
-  (declare (ignore type1 type2))
-  t)
-
-(def-alien-type-method (root :subtypep) (type1 type2)
-  (alien-type-= type1 type2))
-
-(def-alien-type-method (root :lisp-rep) (type)
-  (declare (ignore type))
-  nil)
-
-(def-alien-type-method (root :alien-rep) (type)
-  (declare (ignore type))
-  '*)
-
-(def-alien-type-method (root :naturalize-gen) (type alien)
-  (declare (ignore alien))
-  (error "Cannot represent ~S typed aliens." type))
-
-(def-alien-type-method (root :deport-gen) (type object)
-  (declare (ignore object))
-  (error "Cannot represent ~S typed aliens." type))
-
-(def-alien-type-method (root :extract-gen) (type sap offset)
-  (declare (ignore sap offset))
-  (error "Cannot represent ~S typed aliens." type))
-
-(def-alien-type-method (root :deposit-gen) (type sap offset value)
-  `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value))
-
-(def-alien-type-method (root :arg-tn) (type state)
-  (declare (ignore state))
-  (error "Cannot pass aliens of type ~S as arguments to call-out"
-	 (unparse-alien-type type)))
-
-(def-alien-type-method (root :result-tn) (type state)
-  (declare (ignore state))
-  (error "Cannot return aliens of type ~S from call-out"
-	 (unparse-alien-type type)))
-
-
-;;;; The INTEGER type.
-
-(def-alien-type-class (integer)
-  (signed t :type (member t nil)))
-
-(def-alien-type-translator signed (&optional (bits vm:word-bits))
-  (make-alien-integer-type :bits bits))
-
-(def-alien-type-translator integer (&optional (bits vm:word-bits))
-  (make-alien-integer-type :bits bits))
-
-(def-alien-type-translator unsigned (&optional (bits vm:word-bits))
-  (make-alien-integer-type :bits bits :signed nil))
-
-(def-alien-type-method (integer :unparse) (type)
-  (list (if (alien-integer-type-signed type) 'signed 'unsigned)
-	(alien-integer-type-bits type)))
-
-(def-alien-type-method (integer :type=) (type1 type2)
-  (and (eq (alien-integer-type-signed type1)
-	   (alien-integer-type-signed type2))
-       (= (alien-integer-type-bits type1)
-	  (alien-integer-type-bits type2))))
-
-(def-alien-type-method (integer :lisp-rep) (type)
-  (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
-	(alien-integer-type-bits type)))
-
-(def-alien-type-method (integer :alien-rep) (type)
-  (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
-	(alien-integer-type-bits type)))
-
-(def-alien-type-method (integer :naturalize-gen) (type alien)
-  (declare (ignore type))
-  alien)
-
-(def-alien-type-method (integer :deport-gen) (type value)
-  (declare (ignore type))
-  value)
-
-(def-alien-type-method (integer :extract-gen) (type sap offset)
-  (declare (type alien-integer-type type))
-  (let ((ref-fun
-	 (if (alien-integer-type-signed type)
-	  (case (alien-integer-type-bits type)
-	    (8 'signed-sap-ref-8)
-	    (16 'signed-sap-ref-16)
-	    (32 'signed-sap-ref-32))
-	  (case (alien-integer-type-bits type)
-	    (8 'sap-ref-8)
-	    (16 'sap-ref-16)
-	    (32 'sap-ref-32)))))
-    (if ref-fun
-	`(,ref-fun ,sap (/ ,offset vm:byte-bits))
-	(error "Cannot extract ~D bit integers."
-	       (alien-integer-type-bits type)))))
-
-
-
-;;;; The BOOLEAN type.
-
-(def-alien-type-class (boolean :include integer))
-
-(def-alien-type-translator boolean (&optional (bits vm:word-bits))
-  (make-alien-boolean-type :bits bits :signed nil))
-
-(def-alien-type-method (boolean :unparse) (type)
-  `(boolean ,(alien-boolean-type-bits type)))
-
-(def-alien-type-method (boolean :lisp-rep) (type)
-  (declare (ignore type))
-  `(member t nil))
-
-(def-alien-type-method (boolean :naturalize-gen) (type alien)
-  (declare (ignore type))
-  `(not (zerop ,alien)))
-
-(def-alien-type-method (boolean :deport-gen) (value type)
-  (declare (ignore type))
-  `(if ,value 1 0))
-
-
-;;;; The ENUM type.
-
-(def-alien-type-class (enum :include (integer (:bits 32)))
-  name		; name of this enum (if any)
-  from		; alist from keywords to integers.
-  to		; 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.
-
-(def-alien-type-translator enum (&whole type name &rest mappings)
-  (cond (mappings
-	 (let ((result (parse-enum name mappings)))
-	   (when name
-	     (multiple-value-bind
-		 (old old-p)
-		 (auxiliary-alien-type :enum name)
-	       (when old-p
-		 (unless (alien-type-= result old)
-		   (warn "Redefining alien enum ~S" name))))
-	     (setf (auxiliary-alien-type :enum name) result))
-	   result))
-	(name
-	 (multiple-value-bind
-	     (result found)
-	     (auxiliary-alien-type :enum name)
-	   (unless found
-	     (error "Unknown enum type: ~S" name))
-	   result))
-	(t
-	 (error "Empty enum type: ~S" type))))
-
-(defun parse-enum (name elements)
-  (when (null elements)
-    (error "An anumeration must contain at least one element."))
-  (let ((min nil)
-	(max nil)
-	(from-alist ())
-	(prev -1))
-    (declare (list from-alist))
-    (dolist (el elements)
-      (multiple-value-bind
-	  (sym val)
-	  (if (listp el)
-	      (values (first el) (second el))
-	      (values el (1+ prev)))
-	(setf prev val)
-	(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 from-alist)
-	  (error "Element value ~S used more than once." val))
-	(when (assoc sym from-alist :test #'eq)
-	  (error "Enumeration element ~S used more than once." sym))
-	(push (cons sym val) from-alist)))
-    (let* ((signed (minusp min))
-	   (min-bits (if signed
-			 (1+ (max (integer-length min)
-				  (integer-length max)))
-			 (integer-length max))))
-      (when (> min-bits 32)
-	(error "Can't represent enums needing more than 32 bits."))
-      (setf from-alist (sort from-alist #'< :key #'cdr))
-      (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))
-	(let ((to (make-array (1+ (- max min)))))
-	  (dolist (el from-alist)
-	    (setf (svref to (- (cdr el) min)) (car el)))
-	  (make-alien-enum-type :name name :signed signed
-				:from from-alist :to to :kind
-				:vector :offset (- min))))
-       (t
-	(make-alien-enum-type :name name :signed signed
-			      :from from-alist
-			      :to (mapcar #'(lambda (x) (cons (cdr x) (car x)))
-					  from-alist)
-			      :kind :alist))))))
-
-(def-alien-type-method (enum :unparse) (type)
-  `(enum ,(alien-enum-type-name type)
-	 ,@(let ((prev -1))
-	     (mapcar #'(lambda (mapping)
-			 (let ((sym (car mapping))
-			       (value (cdr mapping)))
-			   (prog1
-			       (if (= (1+ prev) value)
-				   sym
-				   `(,sym ,value))
-			     (setf prev value))))
-		     (alien-enum-type-from type)))))
-
-(def-alien-type-method (enum :type=) (type1 type2)
-  (and (eq (alien-enum-type-name type1)
-	   (alien-enum-type-name type2))
-       (equal (alien-enum-type-from type1)
-	      (alien-enum-type-from type2))))
-
-(def-alien-type-method (enum :lisp-rep) (type)
-  `(member ,@(mapcar #'car (alien-enum-type-from type))))
-
-(def-alien-type-method (enum :naturalize-gen) (type alien)
-  (ecase (alien-enum-type-kind type)
-    (:vector
-     `(svref ',(alien-enum-type-to type)
-	     (+ ,alien ,(alien-enum-type-offset type))))
-    (:alist
-     `(ecase ,alien
-	,@(mapcar #'(lambda (mapping)
-		      `(,(car mapping) ,(cdr mapping)))
-		  (alien-enum-type-to type))))))
-
-(def-alien-type-method (enum :deport-gen) (type value)
-  `(ecase ,value
-     ,@(mapcar #'(lambda (mapping)
-		   `(,(car mapping) ,(cdr mapping)))
-	       (alien-enum-type-from type))))
-
-
-
-;;;; the FLOAT types.
-
-(def-alien-type-class (float)
-  (type (required-argument) :type symbol))
-
-(def-alien-type-method (float :unparse) (type)
-  (alien-float-type-type type))
-
-(def-alien-type-method (float :lisp-rep) (type)
-  (alien-float-type-type type))
-
-(def-alien-type-method (float :alien-rep) (type)
-  (alien-float-type-type type))
-
-(def-alien-type-method (float :naturalize-gen) (type alien)
-  (declare (ignore type))
-  alien)
-
-(def-alien-type-method (float :deport-gen) (type value)
-  (declare (ignore type))
-  value)
-
-
-(def-alien-type-class (single-float :include (float (:bits 32))))
-
-(def-alien-type-translator single-float ()
-  (make-alien-single-float-type :type 'single-float))
-
-(def-alien-type-method (single-float :extract-gen) (type sap offset)
-  (declare (ignore type))
-  `(sap-ref-single ,sap (/ ,offset vm:byte-bits)))
-
-
-(def-alien-type-class (double-float :include (float (:bits 64))))
-
-(def-alien-type-translator double-float ()
-  (make-alien-double-float-type :type 'double-float))
-
-(def-alien-type-method (double-float :extract-gen) (type sap offset)
-  (declare (ignore type))
-  `(sap-ref-double ,sap (/ ,offset vm:byte-bits)))
-
-
-
-;;;; The SAP type
-
-(def-alien-type-class (system-area-pointer))
-
-(def-alien-type-translator system-area-pointer ()
-  (make-alien-system-area-pointer-type :bits vm:word-bits))
-
-(def-alien-type-method (system-area-pointer :unparse) (type)
-  (declare (ignore type))
-  'system-area-pointer)
-
-(def-alien-type-method (system-area-pointer :lisp-rep) (type)
-  (declare (ignore type))
-  'system-area-pointer)
-
-(def-alien-type-method (system-area-pointer :alien-rep) (type)
-  (declare (ignore type))
-  'system-area-pointer)
-
-(def-alien-type-method (system-area-pointer :naturalize-gen) (type alien)
-  (declare (ignore type))
-  alien)
-
-(def-alien-type-method (system-area-pointer :deport-gen) (type object)
-  (declare (ignore type))
-  object)
-
-(def-alien-type-method (system-area-pointer :extract-gen) (type sap offset)
-  (declare (ignore type))
-  `(sap-ref-sap ,sap (/ ,offset vm:byte-bits)))
-
-
-;;;; the ALIEN-VALUE type.
-
-(def-alien-type-class (alien-value :include system-area-pointer))
-
-(def-alien-type-method (alien-value :lisp-rep) (type)
-  (declare (ignore type))
-  nil)
-
-(def-alien-type-method (alien-value :naturalize-gen) (type alien)
-  `(%sap-alien ,alien ',type))
-
-(def-alien-type-method (alien-value :deport-gen) (type value)
-  (declare (ignore type))
-  `(alien-sap ,value))
-
-
-
-;;;; The POINTER type.
-
-(def-alien-type-class (pointer :include (alien-value (:bits vm:word-bits)))
-  (to nil :type (or alien-type null)))
-
-(def-alien-type-translator * (to)
-  (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to))))
-
-(def-alien-type-method (pointer :unparse) (type)
-  (let ((to (alien-pointer-type-to type)))
-    `(* ,(if to
-	     (%unparse-alien-type to)
-	     t))))
-
-(def-alien-type-method (pointer :type=) (type1 type2)
-  (let ((to1 (alien-pointer-type-to type1))
-	(to2 (alien-pointer-type-to type2)))
-    (if to1
-	(if to2
-	    (alien-type-= to1 to2)
-	    nil)
-	(null to2))))
-
-(def-alien-type-method (pointer :subtypep) (type1 type2)
-  (and (alien-pointer-type-p type2)
-       (let ((to1 (alien-pointer-type-to type1))
-	     (to2 (alien-pointer-type-to type2)))
-	 (if to1
-	     (if to2
-		 (alien-subtype-p to1 to2)
-		 t)
-	     nil))))
-
-(def-alien-type-method (pointer :deport-gen) (type value)
-  (values
-   `(etypecase ,value
-      (null
-       (int-sap 0))
-      (system-area-pointer
-       ,value)
-      ((alien ,type)
-       (alien-sap ,value)))
-   `(or null system-area-pointer (alien ,type))))
-
-
-;;;; The MEM-BLOCK type.
-
-(def-alien-type-class (mem-block :include alien-value))
-
-(def-alien-type-method (mem-block :extract-gen) (type sap offset)
-  (declare (ignore type))
-  `(sap+ ,sap (/ ,offset vm:byte-bits)))
-
-(def-alien-type-method (mem-block :deposit-gen) (type sap offset value)
-  (let ((bits (alien-mem-block-type-bits type)))
-    (unless bits
-      (error "Cannot deposit aliens of type ~S (unknown size)." type))
-    `(kernel:system-area-copy ,value 0 ,sap ,offset ',bits)))
-
-
-;;;; The ARRAY type.
-
-(def-alien-type-class (array :include mem-block)
-  (element-type (required-argument) :type alien-type)
-  (dimensions (required-argument) :type list))
-
-(def-alien-type-translator array (ele-type &rest dims)
-  (when dims
-    (unless (typep (first dims) '(or kernel:index null))
-      (error "First dimension is not a non-negative fixnum or NIL: ~S"
-	     (first dims)))
-    (let ((loser (find-if-not #'(lambda (x) (typep x 'kernel:index))
-			      (rest dims))))
-      (when loser
-	(error "Dimension is not a non-negative fixnum: ~S" loser))))
-	
-  (let ((type (parse-alien-type ele-type)))
-    (make-alien-array-type
-     :element-type type
-     :dimensions dims
-     :alignment (alien-type-alignment type)
-     :bits (if (and (alien-type-bits type)
-		    (every #'integerp dims))
-	       (* (align-offset (alien-type-bits type)
-				(alien-type-alignment type))
-		  (reduce #'* dims))))))
-
-(def-alien-type-method (array :unparse) (type)
-  `(array ,(%unparse-alien-type (alien-array-type-element-type type))
-	  ,@(alien-array-type-dimensions type)))
-
-(def-alien-type-method (array :type=) (type1 type2)
-  (and (equal (alien-array-type-dimensions type1)
-	      (alien-array-type-dimensions type2))
-       (alien-type-= (alien-array-type-element-type type1)
-		     (alien-array-type-element-type type2))))
-
-(def-alien-type-method (array :subtypep) (type1 type2)
-  (and (alien-array-type-p type2)
-       (let ((dim1 (alien-array-type-dimensions type1))
-	     (dim2 (alien-array-type-dimensions type2)))
-	 (and (= (length dim1) (length dim2))
-	      (or (and dim2
-		       (null (car dim2))
-		       (equal (cdr dim1) (cdr dim2)))
-		  (equal dim1 dim2))
-	      (alien-subtype-p (alien-array-type-element-type type1)
-			       (alien-array-type-element-type type2))))))
-
-
-;;;; The RECORD type.
-
-(defstruct (alien-record-field
-	    (:print-function %print-alien-field)
-	    (:make-load-form-fun :just-dump-it-normally))
-  (name (required-argument) :type symbol)
-  (type (required-argument) :type alien-type)
-  (bits nil :type (or unsigned-byte null))
-  (offset 0 :type unsigned-byte))
-
-(defun %print-alien-field (field stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (field stream :type t)
-    (funcall (formatter "~S ~S~@[:~D~]")
-	     stream
-	     (alien-record-field-type field)
-	     (alien-record-field-name field)
-	     (alien-record-field-bits field))))
-
-(def-alien-type-class (record :include mem-block)
-  (kind :struct :type (member :struct :union))
-  (name nil :type (or symbol null))
-  (fields nil :type list))
-
-(def-alien-type-translator struct (name &rest fields)
-  (parse-alien-record-type :struct name fields))
-
-(def-alien-type-translator union (name &rest fields)
-  (parse-alien-record-type :union name fields))
-
-(defun parse-alien-record-type (kind name fields)
-  (if fields
-      (let* ((old (and name (auxiliary-alien-type kind name)))
-	     (result (if (or (null old)
-			     (alien-record-type-fields old))
-			 (make-alien-record-type :name name :kind kind)
-			 old)))
-	(when (and name (not (eq old result)))
-	  (setf (auxiliary-alien-type kind name) result))
-	(parse-alien-record-fields result fields)
-	result)
-      (if name
-	  (or (auxiliary-alien-type kind name)
-	      (setf (auxiliary-alien-type kind name)
-		    (make-alien-record-type :name name :kind kind)))
-	  (make-alien-record-type :kind kind))))
-
-;;; PARSE-ALIEN-RECORD-FIELDS -- internal
-;;;
-;;; Used by parse-alien-type to parse the fields of struct and union
-;;; types.  RESULT holds the record type we are paring the fields of,
-;;; and FIELDS is the list of field specifications.
-;;; 
-(defun parse-alien-record-fields (result fields)
-  (declare (type alien-record-type result)
-	   (type list fields))
-  (let ((total-bits 0)
-	(overall-alignment 1)
-	(parsed-fields nil))
-    (dolist (field fields)
-      (destructuring-bind (var type &optional bits) field
-	(declare (ignore bits))
-	(let* ((field-type (parse-alien-type type))
-	       (bits (alien-type-bits field-type))
-	       (alignment (alien-type-alignment field-type))
-	       (parsed-field
-		(make-alien-record-field :type field-type
-					 :name var)))
-	  (push parsed-field parsed-fields)
-	  (when (null bits)
-	    (error "Unknown size: ~S"
-		   (unparse-alien-type field-type)))
-	  (when (null alignment)
-	    (error "Unknown alignment: ~S"
-		   (unparse-alien-type field-type)))
-	  (setf overall-alignment (max overall-alignment alignment))
-	  (ecase (alien-record-type-kind result)
-	    (:struct
-	     (let ((offset (align-offset total-bits alignment)))
-	       (setf (alien-record-field-offset parsed-field) offset)
-	       (setf total-bits (+ offset bits))))
-	    (:union
-	     (setf total-bits (max total-bits bits)))))))
-    (let ((new (nreverse parsed-fields)))
-      (setf (alien-record-type-fields result) new))
-    (setf (alien-record-type-alignment result) overall-alignment)
-    (setf (alien-record-type-bits result)
-	  (align-offset total-bits overall-alignment))))
-
-(def-alien-type-method (record :unparse) (type)
-  `(,(case (alien-record-type-kind type)
-       (:struct 'struct)
-       (:union 'union)
-       (t '???))
-    ,(alien-record-type-name type)
-    ,@(unless (member type *record-types-already-unparsed* :test #'eq)
-	(push type *record-types-already-unparsed*)
-	(mapcar #'(lambda (field)
-		    `(,(alien-record-field-name field)
-		      ,(%unparse-alien-type (alien-record-field-type field))
-		      ,@(if (alien-record-field-bits field)
-			    (list (alien-record-field-bits field)))))
-		(alien-record-type-fields type)))))
-
-(defun record-fields-match (fields1 fields2)
-  (declare (type list fields1 fields2))
-  (or (eq fields1 fields2)
-      (and fields1
-	   fields2
-	   (let ((field1 (car fields1))
-		 (field2 (car fields2)))
-	     (declare (type alien-record-field field1 field2))
-	     (and (eq (alien-record-field-name field1)
-		      (alien-record-field-name field2))
-		  (eql (alien-record-field-bits field1)
-		       (alien-record-field-bits field2))
-		  (eql (alien-record-field-offset field1)
-		       (alien-record-field-offset field2))
-		  (alien-type-= (alien-record-field-type field1)
-				(alien-record-field-type field2))))
-	   (record-fields-match (cdr fields1) (cdr fields2)))))
-
-(def-alien-type-method (record :type=) (type1 type2)
-  (and (eq (alien-record-type-name type1)
-	   (alien-record-type-name type2))
-       (eq (alien-record-type-kind type1)
-	   (alien-record-type-kind type2))
-       (= (length (alien-record-type-fields type1))
-	  (length (alien-record-type-fields type2)))
-       (record-fields-match (alien-record-type-fields type1)
-			    (alien-record-type-fields type2))))
-
-
-;;;; The FUNCTION and VALUES types.
-
-(defvar *values-type-okay* nil)
-
-(def-alien-type-class (function :include mem-block)
-  (result-type (required-argument) :type alien-type)
-  (arg-types (required-argument) :type list)
-  (stub nil :type (or null function)))
-
-(def-alien-type-translator function (result-type &rest arg-types)
-  (make-alien-function-type
-   :result-type (let ((*values-type-okay* t))
-		  (parse-alien-type result-type))
-   :arg-types (mapcar #'parse-alien-type arg-types)))
-
-(def-alien-type-method (function :unparse) (type)
-  `(function ,(%unparse-alien-type (alien-function-type-result-type type))
-	     ,@(mapcar #'%unparse-alien-type
-		       (alien-function-type-arg-types type))))
-
-(def-alien-type-method (function :type=) (type1 type2)
-  (and (alien-type-= (alien-function-type-result-type type1)
-		     (alien-function-type-result-type type2))
-       (= (length (alien-function-type-arg-types type1))
-	  (length (alien-function-type-arg-types type2)))
-       (every #'alien-type-p
-	      (alien-function-type-arg-types type1)
-	      (alien-function-type-arg-types type2))))
-
-
-(def-alien-type-class (values)
-  (values (required-argument) :type list))
-
-(def-alien-type-translator values (&rest values)
-  (unless *values-type-okay*
-    (error "Cannot use values types here."))
-  (let ((*values-type-okay* nil))
-    (make-alien-values-type
-     :values (mapcar #'parse-alien-type values))))
-
-(def-alien-type-method (values :unparse) (type)
-  `(values ,@(mapcar #'%unparse-alien-type
-		     (alien-values-type-values type))))
-
-(def-alien-type-method (values :type=) (type1 type2)
-  (and (= (length (alien-values-type-values type1))
-	  (length (alien-values-type-values type2)))
-       (every #'alien-type-=
-	      (alien-values-type-values type1)
-	      (alien-values-type-values type2))))
-
-
-
-;;;; Alien variables.
-
-;;; HEAP-ALIEN-INFO -- defstruct.
-;;;
-;;; Information describing a heap-allocated alien.
-;;; 
-(defstruct (heap-alien-info
-	    (:print-function %print-heap-alien-info)
-	    (:make-load-form-fun :just-dump-it-normally))
-  ;; The type of this alien.
-  (type (required-argument) :type alien-type)
-  ;; The form to evaluate to produce the SAP pointing to where in the heap
-  ;; it is.
-  (sap-form (required-argument)))
-;;;
-(defun %print-heap-alien-info (info stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (info stream :type t)
-    (funcall (formatter "~S ~S")
-	     stream
-	     (heap-alien-info-sap-form info)
-	     (unparse-alien-type (heap-alien-info-type info)))))
-
-;;; LOCAL-ALIEN-INFO -- public defstruct.
-;;;
-;;; Information about local aliens.  The WITH-ALIEN macro builds one of these
-;;; structures and local-alien and friends comunicate information about how
-;;; that local alien is represented.
-;;; 
-(defstruct (local-alien-info
-	    (:print-function %print-local-alien-info)
-	    (:make-load-form-fun :just-dump-it-normally))
-  ;; The type of the local alien.
-  (type (required-argument) :type alien-type)
-  ;; T if this local alien must be forced into memory.  Using the ADDR macro
-  ;; on a local alien will set this.
-  (force-to-memory-p (or (alien-array-type-p type) (alien-record-type-p type))
-		     :type (member t nil)))
-;;;
-(defun %print-local-alien-info (info stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (info stream :type t)
-    (funcall (formatter "~:[~;(forced to stack) ~]~S")
-	     stream
-	     (local-alien-info-force-to-memory-p info)
-	     (unparse-alien-type (local-alien-info-type info)))))
-
-;;; GUESS-ALIEN-NAME-FROM-LISP-NAME -- internal.
-;;;
-;;; Make a string out of the symbol, converting all uppercase letters to
-;;; lower case and hyphens into underscores.
-;;; 
-(defun guess-alien-name-from-lisp-name (lisp-name)
-  (declare (type symbol lisp-name))
-  (nsubstitute #\_ #\- (string-downcase (symbol-name lisp-name))))
-
-;;; GUESS-LISP-NAME-FROM-ALIEN-NAME -- internal.
-;;;
-;;; The opposite of GUESS-ALIEN-NAME-FROM-LISP-NAME.  Make a symbol out of the
-;;; string, converting all lowercase letters to uppercase and underscores into
-;;; hyphens.
-;;;
-(defun guess-lisp-name-from-alien-name (alien-name)
-  (declare (type simple-string alien-name))
-  (intern (nsubstitute #\- #\_ (string-upcase alien-name))))
-
-;;; PICK-LISP-AND-ALIEN-NAMES -- internal.
-;;;
-;;; Extract the lisp and alien names from NAME.  If only one is given, guess
-;;; the other.
-;;; 
-(defun pick-lisp-and-alien-names (name)
-  (etypecase name
-    (string
-     (values (guess-lisp-name-from-alien-name name) name))
-    (symbol
-     (values name (guess-alien-name-from-lisp-name name)))
-    (list
-     (unless (= (length name) 2)
-       (error "Badly formed alien name."))
-     (values (cadr name) (car name)))))
-
-;;; DEF-ALIEN-VARIABLE -- public
-;;;
-(defmacro def-alien-variable (name type)
-  "Define NAME as an external alien variable of type TYPE.  NAME should be
-   a list of a symbol to use as the Lisp name, and a string holding the alien
-   name.  If NAME is just a symbol or string, then the other name is guessed
-   from the one supplied."
-  (multiple-value-bind
-      (lisp-name alien-name)
-      (pick-lisp-and-alien-names name)
-    (with-auxiliary-alien-types
-      (let ((alien-type (parse-alien-type type)))
-	`(eval-when (compile load eval)
-	   ,@(when *new-auxiliary-types*
-	       `((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
-	   (%def-alien-variable ',lisp-name
-				',alien-name
-				',alien-type))))))
-
-;;; %DEF-ALIEN-VARIABLE -- internal
-;;;
-;;; Do the actual work of DEF-ALIEN-VARIABLE.
-;;; 
-(defun %def-alien-variable (lisp-name alien-name type)
-  (setf (info variable kind lisp-name) :alien)
-  (setf (info variable where-from lisp-name) :defined)
-  (clear-info variable constant-value lisp-name)
-  (setf (info variable alien-info lisp-name)
-	(make-heap-alien-info :type type
-			      :sap-form `(foreign-symbol-address
-					  ',alien-name))))
-
-;;; EXTERN-ALIEN -- public.
-;;; 
-(defmacro extern-alien (name type)
-  "Access the alien variable named NAME, assuming it is of type TYPE.  This
-   is setfable."
-  (let ((alien-name (etypecase name
-		      (symbol (guess-alien-name-from-lisp-name name))
-		      (string name))))
-    `(%heap-alien ',(make-heap-alien-info
-		     :type (parse-alien-type type)
-		     :sap-form `(foreign-symbol-address ',alien-name)))))
-
-;;; WITH-ALIEN -- public.
-;;;
-(defmacro with-alien (bindings &body body)
-  "Establish some local alien variables.  Each BINDING is of the form:
-     VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ]
-   ALLOCATION should be one of:
-     :LOCAL (the default)
-       The alien is allocated on the stack, and has dynamic extent.
-     :STATIC
-       The alien is allocated on the heap, and has infinate extent.  The alien
-       is allocated at load time, so the same piece of memory is used each time
-       this form executes.
-     :EXTERN
-       No alien is allocated, but VAR is established as a local name for
-       the external alien given by EXTERNAL-NAME."
-  (with-auxiliary-alien-types
-    (dolist (binding (reverse bindings))
-      (destructuring-bind
-	  (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
-	  binding
-	(let ((alien-type (parse-alien-type type)))
-	  (multiple-value-bind
-	      (allocation initial-value)
-	      (if opt2p
-		  (values opt1 opt2)
-		  (case opt1
-		    (:extern
-		     (values opt1 (guess-alien-name-from-lisp-name symbol)))
-		    (:static
-		     (values opt1 nil))
-		    (t
-		     (values :local opt1))))
-	    (setf body
-		  (ecase allocation
-		    #+nil
-		    (:static
-		     (let ((sap
-			    (make-symbol (concatenate 'string "SAP-FOR-"
-						      (symbol-name symbol)))))
-		       `((let ((,sap (load-time-value (%make-alien ...))))
-			   (declare (type system-area-pointer ,sap))
-			   (symbol-macrolet
-			    ((,symbol (sap-alien ,sap ,type)))
-			    ,@(when initial-value
-				`((setq ,symbol ,initial-value)))
-			    ,@body)))))
-		    (:extern
-		     (let ((info (make-heap-alien-info
-				  :type alien-type
-				  :sap-form `(foreign-symbol-address
-					      ',initial-value))))
-		       `((symbol-macrolet
-			  ((,symbol (%heap-alien ',info)))
-			  ,@body))))
-		    (:local
-		     (let ((var (gensym))
-			   (initval (if initial-value (gensym)))
-			   (info (make-local-alien-info
-				  :type alien-type)))
-		       `((let ((,var (make-local-alien ',info))
-			       ,@(when initial-value
-				   `((,initval ,initial-value))))
-			   (note-local-alien-type ',info ,var)
-			   (multiple-value-prog1
-			       (symbol-macrolet
-				((,symbol (local-alien ',info ,var)))
-				,@(when initial-value
-				    `((setq ,symbol ,initval)))
-				,@body)
-			     (dispose-local-alien ',info ,var))))))))))))
-    (verify-local-auxiliaries-okay)
-    `(compiler-let (*auxiliary-type-definitions*
-		    ',(append *new-auxiliary-types*
-			      *auxiliary-type-definitions*))
-       ,@body)))
-
-
-;;;; Runtime C values that don't correspond directly to Lisp types.
-
-;;; ALIEN-VALUE
-;;; 
-(defstruct (alien-value
-	    (:print-function %print-alien-value))
-  (sap (required-argument) :type system-area-pointer)
-  (type (required-argument) :type alien-type))
-;;;
-(defun %print-alien-value (value stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (value stream)
-    (funcall (formatter "Alien ~S at #x~8,'0X")
-	     stream 
-	     (unparse-alien-type (alien-value-type value))
-	     (sap-int (alien-value-sap value)))))
-
-(declaim (freeze-type alien-value))
-
-(declaim (inline null-alien))
-(defun null-alien (x)
-  "Return true if X (which must be an Alien pointer) is null, false otherwise."
-  (zerop (sap-int (alien-sap x))))
-
-  
-(defmacro sap-alien (sap type)
-  "Convert the System-Area-Pointer SAP to an Alien of the specified Type (not
-   evaluated.)  Type must be pointer-like."
-  (let ((alien-type (parse-alien-type type)))
-    (if (eq (compute-alien-rep-type alien-type) 'system-area-pointer)
-	`(%sap-alien ,sap ',alien-type)
-	(error "Cannot make aliens of type ~S out of SAPs" type))))
-
-(defun %sap-alien (sap type)
-  (declare (type system-area-pointer sap)
-	   (type alien-type type))
-  (make-alien-value :sap sap :type type))
-
-(defun alien-sap (alien)
-  "Return a System-Area-Pointer pointing to Alien's data."
-  (declare (type alien-value alien))
-  (alien-value-sap alien))
-
-
-
-;;;; Allocation/Deallocation of heap aliens.
-
-;;; MAKE-ALIEN -- public.
-;;; 
-(defmacro make-alien (type &optional size)
-  "Allocate an alien of type TYPE and return an alien pointer to it.  If SIZE
-   is supplied, how it is interpreted depends on TYPE.  If TYPE is an array
-   type, SIZE is used as the first dimension for the allocated array.  If TYPE
-   is not an array, then SIZE is the number of elements to allocate.  The
-   memory is allocated using ``malloc'', so it can be passed to foreign
-   functions which use ``free''."
-  (let ((alien-type (if (alien-type-p type) type (parse-alien-type type))))
-    (multiple-value-bind
-	(size-expr element-type)
-	(if (alien-array-type-p alien-type)
-	    (let ((dims (alien-array-type-dimensions alien-type)))
-	      (cond
-	       (size
-		(unless dims
-		  (error
-		   "Cannot override the size of zero-dimensional arrays."))
-		(when (constantp size)
-		  (setf alien-type (copy-alien-array-type alien-type))
-		  (setf (alien-array-type-dimensions alien-type)
-			(cons (eval size) (cdr dims)))))
-	       (dims
-		(setf size (car dims)))
-	       (t
-		(setf size 1)))
-	      (values `(* ,size ,@(cdr dims))
-		      (alien-array-type-element-type alien-type)))
-	    (values (or size 1) alien-type))
-      (let ((bits (alien-type-bits element-type))
-	    (alignment (alien-type-alignment element-type)))
-	(unless bits
-	  (error "Size of ~S unknown." (unparse-alien-type element-type)))
-	(unless alignment
-	  (error "Alignment of ~S unknown." (unparse-alien-type element-type)))
-	`(%sap-alien (%make-alien (* ,(align-offset bits alignment)
-				     ,size-expr))
-		     ',(make-alien-pointer-type :to alien-type))))))
-
-;;; %MAKE-ALIEN -- internal
-;;;
-;;; Allocate a block of memory at least BITS bits long and return a system
-;;; area pointer to it.
-;;;
-(declaim (inline %make-alien))
-(defun %make-alien (bits)
-  (declare (type kernel:index bits) (optimize-interface (safety 2)))
-  (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned))
-		 (ash (the kernel:index (+ bits 7)) -3)))
-
-;;; FREE-ALIEN -- public
-;;;
-(declaim (inline free-alien))
-(defun free-alien (alien)
-  "Dispose of the storage pointed to by ALIEN.  ALIEN must have been allocated
-   by MAKE-ALIEN or ``malloc''."
-  (alien-funcall (extern-alien "free" (function (values) system-area-pointer))
-		 (alien-sap alien))
-  nil)
-
-
-;;;; The SLOT operator
-
-;;; SLOT-OR-LOSE -- internal.
-;;;
-;;; Find the field named SLOT, or die trying.
-;;; 
-(defun slot-or-lose (type slot)
-  (declare (type alien-record-type type)
-	   (type symbol slot))
-  (or (find slot (alien-record-type-fields type)
-	    :key #'alien-record-field-name)
-      (error "No slot named ~S in ~S" slot type)))
-
-;;; SLOT -- public
-;;;
-;;; Extract the value from the named slot from the record alien.  If the
-;;; alien is actually a pointer, then deref it first.
-;;; 
-(defun slot (alien slot)
-  "Extract SLOT from the Alien STRUCT or UNION ALIEN.  May be set with SETF."
-  (declare (type alien-value alien)
-	   (type symbol slot)
-	   (optimize (inhibit-warnings 3)))
-  (let ((type (alien-value-type alien)))
-    (etypecase type
-      (alien-pointer-type
-       (slot (deref alien) slot))
-      (alien-record-type
-       (let ((field (slot-or-lose type slot)))
-	 (extract-alien-value (alien-value-sap alien)
-			      (alien-record-field-offset field)
-			      (alien-record-field-type field)))))))
-
-;;; %SET-SLOT -- public setf method
-;;;
-;;; Deposite the value in the specified slot of the record alien.  If the
-;;; alien is really a pointer, deref it first.  The compiler uses this
-;;; when it can't figure out anything better.
-;;; 
-(defun %set-slot (alien slot value)
-  (declare (type alien-value alien)
-	   (type symbol slot)
-	   (optimize (inhibit-warnings 3)))
-  (let ((type (alien-value-type alien)))
-    (etypecase type
-      (alien-pointer-type
-       (%set-slot (deref alien) slot value))
-      (alien-record-type
-       (let ((field (slot-or-lose type slot)))
-	 (deposit-alien-value (alien-value-sap alien)
-			      (alien-record-field-offset field)
-			      (alien-record-field-type field)
-			      value))))))
-;;;
-(defsetf slot %set-slot)
-
-;;; %SLOT-ADDR -- internal
-;;; 
-;;; Compute the address of the specified slot and return a pointer to it.
-;;; 
-(defun %slot-addr (alien slot)
-  (declare (type alien-value alien)
-	   (type symbol slot)
-	   (optimize (inhibit-warnings 3)))
-  (let ((type (alien-value-type alien)))
-    (etypecase type
-      (alien-pointer-type
-       (%slot-addr (deref alien) slot))
-      (alien-record-type
-       (let* ((field (slot-or-lose type slot))
-	      (offset (alien-record-field-offset field))
-	      (field-type (alien-record-field-type field)))
-	 (%sap-alien (sap+ (alien-sap alien) (/ offset vm:byte-bits))
-		     (make-alien-pointer-type :to field-type)))))))
-
-
-;;;; The DEREF operator.
-
-;;; DEREF-GUTS -- internal.
-;;;
-;;; Does most of the work of the different DEREF methods.  Returns two values:
-;;; the type and the offset (in bits) of the refered to alien.
-;;; 
-(defun deref-guts (alien indices)
-  (declare (type alien-value alien)
-	   (type list indices)
-	   (values alien-type integer))
-  (let ((type (alien-value-type alien)))
-    (etypecase type
-      (alien-pointer-type
-       (when (cdr indices)
-	 (error "Too many indices when derefing ~S: ~D"
-		type
-		(length indices)))
-       (let ((element-type (alien-pointer-type-to type)))
-	 (values element-type
-		 (if indices
-		     (* (align-offset (alien-type-bits element-type)
-				      (alien-type-alignment element-type))
-			(car indices))
-		     0))))
-      (alien-array-type
-       (unless (= (length indices) (length (alien-array-type-dimensions type)))
-	 (error "Incorrect number of indices when derefing ~S: ~D"
-		type (length indices)))
-       (labels ((frob (dims indices offset)
-		  (if (null dims)
-		      offset
-		      (frob (cdr dims) (cdr indices)
-			(+ (if (zerop offset)
-			       0
-			       (* offset (car dims)))
-			   (car indices))))))
-	 (let ((element-type (alien-array-type-element-type type)))
-	   (values element-type
-		   (* (align-offset (alien-type-bits element-type)
-				    (alien-type-alignment element-type))
-		      (frob (alien-array-type-dimensions type)
-			indices 0)))))))))
-
-;;; DEREF -- public
-;;;
-;;; Dereference the alien and return the results.
-;;; 
-(defun deref (alien &rest indices)
-  "De-reference an Alien pointer or array.  If an array, the indices are used
-   as the indices of the array element to access.  If a pointer, one index can
-   optionally be specified, giving the equivalent of C pointer arithmetic."
-  (declare (type alien-value alien)
-	   (type list indices)
-	   (optimize (inhibit-warnings 3)))
-  (multiple-value-bind
-      (target-type offset)
-      (deref-guts alien indices)
-    (extract-alien-value (alien-value-sap alien)
-			 offset
-			 target-type)))
-
-;;; %SET-DEREF -- public setf method
-;;; 
-(defun %set-deref (alien value &rest indices)
-  (declare (type alien-value alien)
-	   (type list indices)
-	   (optimize (inhibit-warnings 3)))
-  (multiple-value-bind
-      (target-type offset)
-      (deref-guts alien indices)
-    (deposit-alien-value (alien-value-sap alien)
-			 offset
-			 target-type
-			 value)))
-;;;
-(defsetf deref (alien &rest indices) (value)
-  `(%set-deref ,alien ,value ,@indices))
-
-;;; %DEREF-ADDR -- public
-;;;
-(defun %deref-addr (alien &rest indices)
-  (declare (type alien-value alien)
-	   (type list indices)
-	   (optimize (inhibit-warnings 3)))
-  (multiple-value-bind
-      (target-type offset)
-      (deref-guts alien indices)
-    (%sap-alien (sap+ (alien-value-sap alien) (/ offset vm:byte-bits))
-		(make-alien-pointer-type :to target-type))))
-
-
-;;;; Accessing heap alien variables.
-
-(defun %heap-alien (info)
-  (declare (type heap-alien-info info)
-	   (optimize (inhibit-warnings 3)))
-  (extract-alien-value (eval (heap-alien-info-sap-form info))
-		       0
-		       (heap-alien-info-type info)))
-
-(defun %set-heap-alien (info value)
-  (declare (type heap-alien-info info)
-	   (optimize (inhibit-warnings 3)))
-  (deposit-alien-value (eval (heap-alien-info-sap-form info))
-		       0
-		       (heap-alien-info-type info)
-		       value))
-;;;
-(defsetf %heap-alien %set-heap-alien)
-
-(defun %heap-alien-addr (info)
-  (declare (type heap-alien-info info)
-	   (optimize (inhibit-warnings 3)))
-  (%sap-alien (eval (heap-alien-info-sap-form info))
-	      (make-alien-pointer-type :to (heap-alien-info-type info))))
-
-
-
-;;;; Accessing local aliens.
-
-(defun make-local-alien (info)
-  (let ((alien (eval `(make-alien ,(local-alien-info-type info)))))
-    (finalize info #'(lambda () (free-alien alien)))
-    alien))
-
-(defun note-local-alien-type (info alien)
-  (declare (ignore info alien))
-  nil)
-
-(defun local-alien (info alien)
-  (declare (ignore info))
-  (deref alien))
-
-(defun %set-local-alien (info alien value)
-  (declare (ignore info))
-  (setf (deref alien) value))
-
-(define-setf-method local-alien (&whole whole info alien)
-  (let ((value (gensym))
-	(info (if (and (consp info)
-		       (eq (car info) 'quote))
-		  (second info)
-		  (error "Something is wrong; local-alien-info not found: ~S"
-			 whole))))
-    (values nil
-	    nil
-	    (list value)
-	    (if c:*converting-for-interpreter*
-		`(%set-local-alien ',info ,alien ,value)
-		`(if (%local-alien-forced-to-memory-p ',info)
-		     (%set-local-alien ',info ,alien ,value)
-		     (setf ,alien
-			   (deport ,value ',(local-alien-info-type info)))))
-	    whole)))
-
-(defun %local-alien-forced-to-memory-p (info)
-  (local-alien-info-force-to-memory-p info))
-
-(defun %local-alien-addr (info alien)
-  (declare (type local-alien-info info))
-  (unless (local-alien-info-force-to-memory-p info)
-    (error "~S isn't forced to memory.  Something went wrong." alien))
-  alien)
-
-(defun dispose-local-alien (info alien)
-  (declare (ignore info))
-  #+nil
-  (cancel-finalization info)
-  (free-alien alien))
-
-
-;;;; The ADDR macro.
-
-(defmacro addr (expr &environment env)
-  "Return an Alien pointer to the data addressed by Expr, which must be a call
-   to SLOT or DEREF, or a reference to an Alien variable."
-  (let ((form (macroexpand expr env)))
-    (or (typecase form
-	  (cons
-	   (case (car form)
-	     (slot
-	      (cons '%slot-addr (cdr form)))
-	     (deref
-	      (cons '%deref-addr (cdr form)))
-	     (%heap-alien
-	      (cons '%heap-alien-addr (cdr form)))
-	     (local-alien
-	      (let ((info
-		     (let ((info-arg (second form)))
-		       (and (consp info-arg)
-			    (eq (car info-arg) 'quote)
-			    (second info-arg)))))
-		(unless (local-alien-info-p info)
-		  (error "Something is wrong, local-alien-info not found: ~S"
-			 form))
-		(setf (local-alien-info-force-to-memory-p info) t))
-	      (cons '%local-alien-addr (cdr form)))))
-	  (symbol
-	   (let ((kind (info variable kind form)))
-	     (when (eq kind :alien)
-	       `(%heap-alien-addr ',(info variable alien-info form))))))
-	(error "~S is not a valid L-value" form))))
-
-
-;;;; The CAST macro.
-
-(defmacro cast (alien type)
-  "Convert ALIEN to an Alien of the specified TYPE (not evaluated.)  Both types
-   must be Alien array, pointer or function types."
-  `(%cast ,alien ',(parse-alien-type type)))
-
-(defun %cast (alien target-type)
-  (declare (type alien-value alien)
-	   (type alien-type target-type)
-	   (optimize-interface (safety 2))
-	   (optimize (inhibit-warnings 3)))
-  (if (or (alien-pointer-type-p target-type)
-	  (alien-array-type-p target-type)
-	  (alien-function-type-p target-type))
-      (let ((alien-type (alien-value-type alien)))
-	(if (or (alien-pointer-type-p alien-type)
-		(alien-array-type-p alien-type)
-		(alien-function-type-p alien-type))
-	    (naturalize (alien-value-sap alien) target-type)
-	    (error "~S cannot be casted." alien)))
-      (error "Cannot cast to alien type ~S" (unparse-alien-type target-type))))
-
-
-
-;;;; The ALIEN-SIZE macro.
-
-(defmacro alien-size (type &optional (units :bits))
-  "Return the size of the alien type TYPE.  UNITS specifies the units to
-   use and can be either :BITS, :BYTES, or :WORDS."
-  (let* ((alien-type (parse-alien-type type))
-	 (bits (alien-type-bits alien-type)))
-    (if bits
-	(values (ceiling bits
-			 (ecase units
-			   (:bits 1)
-			   (:bytes vm:byte-bits)
-			   (:words vm:word-bits))))
-	(error "Unknown size for alien type ~S."
-	       (unparse-alien-type alien-type)))))
-
-
-
-;;;; Naturalize, deport, extract-alien-value, deposit-alien-value
-
-(defun naturalize (alien type)
-  (declare (type alien-type type))
-  (funcall (coerce (compute-naturalize-lambda type) 'function)
-	   alien type))
-
-(defun deport (value type)
-  (declare (type alien-type type))
-  (funcall (coerce (compute-deport-lambda type) 'function)
-	   value type))
-
-(defun extract-alien-value (sap offset type)
-  (declare (type system-area-pointer sap)
-	   (type unsigned-byte offset)
-	   (type alien-type type))
-  (funcall (coerce (compute-extract-lambda type) 'function)
-	   sap offset type))
-
-(defun deposit-alien-value (sap offset type value)
-  (declare (type system-area-pointer sap)
-	   (type unsigned-byte offset)
-	   (type alien-type type))
-  (funcall (coerce (compute-deposit-lambda type) 'function)
-	   sap offset type value))
-
-
-
-;;;; alien-funcall, def-alien-function
-
-(defun alien-funcall (alien &rest args)
-  "Call the foreign function ALIEN with the specified arguments.  ALIEN's
-   type specifies the argument and result types."
-  (declare (type alien-value alien))
-  (let ((type (alien-value-type alien)))
-    (typecase type
-      (alien-pointer-type
-       (apply #'alien-funcall (deref alien) args))
-      (alien-function-type
-       (unless (= (length (alien-function-type-arg-types type))
-		  (length args))
-	 (error "Wrong number of arguments for ~S~%Expected ~D, got ~D."
-		type
-		(length (alien-function-type-arg-types type))
-		(length args)))
-       (let ((stub (alien-function-type-stub type)))
-	 (unless stub
-	   (setf stub
-		 (let ((fun (gensym))
-		       (parms (loop repeat (length args) collect (gensym))))
-		   (compile nil
-			    `(lambda (,fun ,@parms)
-			       (declare (type (alien ,type) ,fun))
-			       (alien-funcall ,fun ,@parms)))))
-	   (setf (alien-function-type-stub type) stub))
-	 (apply stub alien args)))
-      (t
-       (error "~S is not an alien function." alien)))))
-
-(defmacro def-alien-routine (name result-type &rest args)
-  "Def-C-Routine Name Result-Type
-                    {(Arg-Name Arg-Type [Style])}*
-
-  Define a foreign interface function for the routine with the specified Name,
-  which may be either a string, symbol or list of the form (symbol string).
-  Return-Type is the Alien fypte for the 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.  Style 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 being returned from
-        the interface function.  :OUT and :IN-OUT cannot be used with pointers
-        to arrays, records or functions.
-
-  :COPY
-        Similar to :IN, except that the argument values are stored in on
-        the stack, 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 the supplied argument and
-        the return value being determined by accessing the object on return."
-  (multiple-value-bind
-      (lisp-name alien-name)
-      (pick-lisp-and-alien-names name)
-    (collect ((docs) (lisp-args) (arg-types) (alien-vars)
-	      (alien-args) (results))
-      (dolist (arg args)
-	(if (stringp arg)
-	    (docs arg)
-	    (destructuring-bind (name type &optional (style :in)) arg
-	      (unless (member style '(:in :copy :out :in-out))
-		(error "Bogus argument style ~S in ~S." style arg))
-	      (unless (eq style :out)
-		(lisp-args name))
-	      (cond ((eq style :in)
-		     (arg-types type)
-		     (alien-args name))
-		    (t
-		     (arg-types `(* ,type))
-		     (if (eq style :out)
-			 (alien-vars `(,name ,type))
-			 (alien-vars `(,name ,type ,name)))
-		     (alien-args `(addr ,name))))
-	      (when (or (eq style :out) (eq style :in-out))
-		(results name)))))
-      `(defun ,lisp-name ,(lisp-args)
-	 ,@(docs)
-	 (with-alien
-	     ((,lisp-name (function ,result-type ,@(arg-types))
-			  :extern ,alien-name)
-	      ,@(alien-vars))
-	     ,(if (alien-values-type-p result-type)
-		  (let ((temps (loop
-				 repeat (length (alien-values-type-values
-						 result-type))
-				 collect (gensym))))
-		    `(multiple-value-bind
-			 ,temps
-			 (alien-funcall ,lisp-name ,@(alien-args))
-		       (values ,@temps ,@(results))))
-		  `(values (alien-funcall ,lisp-name ,@(alien-args))
-			   ,@(results))))))))
diff --git a/code/array.lisp b/code/array.lisp
deleted file mode 100644
index 9375b884f74dd52695e47e57211c0ce52e1c1a28..0000000000000000000000000000000000000000
--- a/code/array.lisp
+++ /dev/null
@@ -1,980 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.17 1992/12/10 00:35:16 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Functions to implement arrays for CMU Common Lisp.
-;;; Written by Skef Wholey.
-;;; Worked over for the MIPS port by William Lott.
-;;;
-(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 array-displacement))
-
-(in-package "KERNEL")
-(export '(%with-array-data))
-(in-package "LISP")
-
-(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 accessor functions.
-
-;;; These functions are needed by the interpreter, 'cause the compiler inlines
-;;; them.
-
-(macrolet ((frob (name)
-	     `(progn
-		(defun ,name (array)
-		  (,name array))
-		(defun (setf ,name) (value array)
-		  (setf (,name array) value)))))
-  (frob %array-fill-pointer)
-  (frob %array-fill-pointer-p)
-  (frob %array-available-elements)
-  (frob %array-data-vector)
-  (frob %array-displacement)
-  (frob %array-displaced-p))
-
-(defun %array-rank (array)
-  (%array-rank array))
-
-(defun %array-dimension (array axis)
-  (%array-dimension array axis))
-
-(defun %set-array-dimension (array axis value)
-  (%set-array-dimension array axis value))
-
-(defun %check-bound (array bound index)
-  (declare (type index bound)
-	   (fixnum index))
-  (%check-bound array bound index))
-
-;;; %WITH-ARRAY-DATA  --  Interface
-;;;
-;;;    The guts of the WITH-ARRAY-DATA macro (in sysmacs).  Note that this
-;;; function is only called if we have an array header or an error, so it
-;;; doesn't have to be too tense.
-;;;
-(defun %with-array-data (array start end)
-  (declare (array array) (type index start) (type (or index null) end)
-	   (values (simple-array * (*)) index index index))
-  (let* ((size (array-total-size array))
-	 (end (cond (end
-		     (unless (<= end size)
-		       (error "End ~D is greater than total size ~D."
-			      end size))
-		     end)
-		    (t size))))
-    (when (> start end)
-      (error "Start ~D is greater than end ~D." start end))
-    (do ((data array (%array-data-vector data))
-	 (cumulative-offset 0
-			    (+ cumulative-offset
-			       (%array-displacement data))))
-	((not (array-header-p data))
-	 (values data
-		 (+ cumulative-offset start)
-		 (+ cumulative-offset end)
-		 cumulative-offset))
-      (declare (type index cumulative-offset)))))
-
-
-;;;; MAKE-ARRAY
-
-(eval-when (compile eval)
-
-(defmacro pick-type (type &rest specs)
-  `(cond ,@(mapcar #'(lambda (spec)
-		       `(,(if (eq (car spec) t)
-			      t
-			      `(subtypep ,type ',(car spec)))
-			 ,@(cdr spec)))
-		   specs)))
-
-); eval-when
-
-
-(defun %vector-type-code (type)
-  (pick-type type
-    (base-char (values #.vm:simple-string-type #.vm:byte-bits))
-    (bit (values #.vm:simple-bit-vector-type 1))
-    ((unsigned-byte 2) (values #.vm:simple-array-unsigned-byte-2-type 2))
-    ((unsigned-byte 4) (values #.vm:simple-array-unsigned-byte-4-type 4))
-    ((unsigned-byte 8) (values #.vm:simple-array-unsigned-byte-8-type 8))
-    ((unsigned-byte 16) (values #.vm:simple-array-unsigned-byte-16-type 16))
-    ((unsigned-byte 32) (values #.vm:simple-array-unsigned-byte-32-type 32))
-    (single-float (values #.vm:simple-array-single-float-type 32))
-    (double-float (values #.vm:simple-array-double-float-type 64))
-    (t (values #.vm:simple-vector-type #.vm:word-bits))))
-
-(defun %complex-vector-type-code (type)
-  (pick-type type
-    (base-char #.vm:complex-string-type)
-    (bit #.vm:complex-bit-vector-type)
-    (t #.vm:complex-vector-type)))
-
-(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."
-  (let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
-	 (array-rank (length (the list dimensions)))
-	 (simple (and (null fill-pointer)
-		      (not adjustable)
-		      (null displaced-to))))
-    (declare (fixnum array-rank))
-    (when (and displaced-index-offset (null displaced-to))
-      (error "Can't specify :displaced-index-offset without :displaced-to"))
-    (if (and simple (= array-rank 1))
-	;; Its a (simple-array * (*))
-	(multiple-value-bind (type bits)
-			     (%vector-type-code element-type)
-	  (declare (type (unsigned-byte 8) type)
-		   (type (integer 1 64) bits))
-	  (let* ((length (car dimensions))
-		 (array (allocate-vector
-			 type
-			 length
-			 (ceiling (* (if (= type vm:simple-string-type)
-					 (1+ length)
-					 length)
-				     bits)
-				  vm:word-bits))))
-	    (declare (type index length))
-	    (when initial-element-p
-	      (fill array initial-element))
-	    (when initial-contents
-	      (when initial-element
-		(error "Cannot specify both :initial-element and ~
-		:initial-contents"))
-	      (unless (= length (length initial-contents))
-		(error "~D elements in the initial-contents, but the ~
-		vector length is ~D."
-		       (length initial-contents)
-		       length))
-	      (replace array initial-contents))
-	    array))
-	;; It's either a complex array or a multidimensional array.
-	(let* ((total-size (reduce #'* dimensions))
-	       (data (or displaced-to
-			 (data-vector-from-inits
-			  dimensions total-size element-type
-			  initial-contents initial-element initial-element-p)))
-	       (array (make-array-header
-		       (cond ((= array-rank 1)
-			      (%complex-vector-type-code element-type))
-			     (simple vm:simple-array-type)
-			     (t vm:complex-array-type))
-		       array-rank)))
-	  (cond (fill-pointer
-		 (unless (= array-rank 1)
-		   (error "Only vectors can have fill pointers."))
-		 (setf (%array-fill-pointer array)
-		       (if (eq fill-pointer t)
-			   (car dimensions)
-			   fill-pointer))
-		 (setf (%array-fill-pointer-p array) t))
-		(t
-		 (setf (%array-fill-pointer array) total-size)
-		 (setf (%array-fill-pointer-p array) nil)))
-	  (setf (%array-available-elements array) total-size)
-	  (setf (%array-data-vector array) data)
-	  (cond (displaced-to
-		 (when (or initial-element-p initial-contents)
-		   (error "Neither :initial-element nor :initial-contents ~
-		   can be specified along with :displaced-to"))
-		 (let ((offset (or displaced-index-offset 0)))
-		   (when (> (+ offset total-size)
-			    (array-total-size displaced-to))
-		     (error "~S doesn't have enough elements." displaced-to))
-		   (setf (%array-displacement array) offset)
-		   (setf (%array-displaced-p array) t)))
-		(t
-		 (setf (%array-displaced-p array) nil)))
-	  (let ((axis 0))
-	    (dolist (dim dimensions)
-	      (setf (%array-dimension array axis) dim)
-	      (incf axis)))
-	  array))))
-	
-;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array
-;;; characteristics.  Dimensions is only used to pass to FILL-DATA-VECTOR
-;;; for error checking on the structure of initial-contents.
-;;;
-(defun data-vector-from-inits (dimensions total-size element-type
-			       initial-contents initial-element
-			       initial-element-p)
-  (when (and initial-contents initial-element-p)
-    (error "Cannot supply both :initial-contents and :initial-element to
-            either make-array or adjust-array."))
-  (let ((data (if initial-element-p
-		  (make-array total-size
-			      :element-type element-type
-			      :initial-element initial-element)
-		  (make-array total-size
-			      :element-type element-type))))
-    (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
-	   (fill-data-vector data dimensions initial-contents)))
-    data))
-
-
-(defun fill-data-vector (vector dimensions initial-contents)
-  (let ((index 0))
-    (labels ((frob (axis dims contents)
-	       (cond ((null dims)
-		      (setf (aref vector index) contents)
-		      (incf index))
-		     (t
-		      (unless (typep contents 'sequence)
-			(error "Malformed :initial-contents.  ~S is not a ~
-			        sequence, but ~D more layer~:P needed."
-			       contents
-			       (- (length dimensions) axis)))
-		      (unless (= (length contents) (car dims))
-			(error "Malformed :initial-contents.  Dimension of ~
-			        axis ~D is ~D, but ~S is ~D long."
-			       axis (car dims) contents (length contents)))
-		      (if (listp contents)
-			  (dolist (content contents)
-			    (frob (1+ axis) (cdr dims) content))
-			  (dotimes (i (length contents))
-			    (frob (1+ axis) (cdr dims) (aref contents i))))))))
-      (frob 0 dimensions initial-contents))))
-
-
-;;; 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))
-
-
-
-;;;; Accessor/Setter functions.
-
-(defun data-vector-ref (array index)
-  (with-array-data ((vector array) (index index) (end))
-    (declare (ignore end) (optimize (safety 3)))
-    (macrolet ((dispatch (&rest stuff)
-		 `(etypecase vector
-		    ,@(mapcar #'(lambda (type)
-				  (let ((atype `(simple-array ,type (*))))
-				    `(,atype
-				      (data-vector-ref (the ,atype vector)
-						       index))))
-			      stuff))))
-      (dispatch
-       t
-       bit
-       character
-       (unsigned-byte 2)
-       (unsigned-byte 4)
-       (unsigned-byte 8)
-       (unsigned-byte 16)
-       (unsigned-byte 32)
-       single-float
-       double-float))))
-
-(defun data-vector-set (array index new-value)
-  (with-array-data ((vector array) (index index) (end))
-    (declare (ignore end) (optimize (safety 3)))
-    (macrolet ((dispatch (&rest stuff)
-		 `(etypecase vector
-		    ,@(mapcar #'(lambda (type)
-				  (let ((atype `(simple-array ,type (*))))
-				    `(,atype
-				      (data-vector-set (the ,atype vector)
-						       index
-						       (the ,type new-value)))))
-			      stuff))))
-      (dispatch
-       t
-       bit
-       character
-       (unsigned-byte 2)
-       (unsigned-byte 4)
-       (unsigned-byte 8)
-       (unsigned-byte 16)
-       (unsigned-byte 32)
-       single-float
-       double-float))))
-
-
-
-(defun %array-row-major-index (array subscripts
-				     &optional (invalid-index-error-p t))
-  (declare (array array)
-	   (list subscripts))
-  (let ((rank (array-rank array)))
-    (unless (= rank (length subscripts))
-      (error "Wrong number of subscripts, ~D, for array of rank ~D"
-	     (length subscripts) rank))
-    (if (array-header-p array)
-	(do ((subs (nreverse subscripts) (cdr subs))
-	     (axis (1- (array-rank array)) (1- axis))
-	     (chunk-size 1)
-	     (result 0))
-	    ((null subs) result)
-	  (declare (list subs) (fixnum axis chunk-size result))
-	  (let ((index (car subs))
-		(dim (%array-dimension array axis)))
-	    (declare (fixnum index dim))
-	    (unless (< -1 index dim)
-	      (if invalid-index-error-p
-		  (error "Invalid index ~D~[~;~:; on axis ~:*~D~] in ~S"
-			 index axis array)
-		  (return-from %array-row-major-index nil)))
-	    (incf result (* chunk-size index))
-	    (setf chunk-size (* chunk-size dim))))
-	(let ((index (first subscripts)))
-	  (unless (< -1 index (length (the (simple-array * (*)) array)))
-	    (if invalid-index-error-p
-		(error "Invalid index ~D in ~S" index array)
-		(return-from %array-row-major-index nil)))
-	  index))))
-
-(defun array-in-bounds-p (array &rest subscripts)
-  "Returns T if the Subscipts are in bounds for the Array, Nil otherwise."
-  (if (%array-row-major-index array subscripts nil)
-      t))
-
-(defun array-row-major-index (array &rest subscripts)
-  (%array-row-major-index array subscripts))
-
-(defun aref (array &rest subscripts)
-  "Returns the element of the Array specified by the Subscripts."
-  (row-major-aref array (%array-row-major-index array subscripts)))
-
-(defun %aset (array &rest stuff)
-  (let ((subscripts (butlast stuff))
-	(new-value (car (last stuff))))
-    (setf (row-major-aref array (%array-row-major-index array subscripts))
-	  new-value)))
-
-(declaim (inline (setf aref)))
-(defun (setf aref) (new-value array &rest subscripts)
-  (declare (type array array))
-  (setf (row-major-aref array (%array-row-major-index array subscripts))
-	new-value))
-
-(defun row-major-aref (array index)
-  "Returns the element of array corressponding to the row-major index.  This is
-   SETF'able."
-  (declare (optimize (safety 1)))
-  (row-major-aref array index))
-
-
-(defun %set-row-major-aref (array index new-value)
-  (declare (optimize (safety 1)))
-  (setf (row-major-aref array index) new-value))
-
-(defun svref (simple-vector index)
-  "Returns the Index'th element of the given Simple-Vector."
-  (declare (optimize (safety 1)))
-  (aref simple-vector index))
-
-(defun %svset (simple-vector index new)
-  (declare (optimize (safety 1)))
-  (setf (aref simple-vector index) new))
-
-
-(defun bit (bit-array &rest subscripts)
-  "Returns the bit from the Bit-Array at the specified Subscripts."
-  (declare (type (array bit) bit-array) (optimize (safety 1)))
-  (row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
-
-
-(defun %bitset (bit-array &rest stuff)
-  (declare (type (array bit) bit-array) (optimize (safety 1)))
-  (let ((subscripts (butlast stuff))
-	(new-value (car (last stuff))))
-    (setf (row-major-aref bit-array
-			  (%array-row-major-index bit-array subscripts))
-	  new-value)))
-
-(declaim (inline (setf bit)))
-(defun (setf bit) (new-value bit-array &rest subscripts)
-  (declare (type (array bit) bit-array) (optimize (safety 1)))
-  (setf (row-major-aref bit-array
-			(%array-row-major-index bit-array subscripts))
-	new-value))
-
-(defun sbit (simple-bit-array &rest subscripts)
-  "Returns the bit from the Simple-Bit-Array at the specified Subscripts."
-  (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
-  (row-major-aref simple-bit-array
-		  (%array-row-major-index simple-bit-array subscripts)))
-
-(defun %sbitset (simple-bit-array &rest stuff)
-  (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
-  (let ((subscripts (butlast stuff))
-	(new-value (car (last stuff))))
-    (setf (row-major-aref simple-bit-array
-			  (%array-row-major-index simple-bit-array subscripts))
-	  new-value)))
- 
-(declaim (inline (setf sbit)))
-(defun (setf sbit) (new-value bit-array &rest subscripts)
-  (declare (type (simple-array bit) bit-array) (optimize (safety 1)))
-  (setf (row-major-aref bit-array
-			(%array-row-major-index bit-array subscripts))
-	new-value))
-
-
-;;;; Random array properties.
-
-(defun array-element-type (array)
-  "Returns the type of the elements of the array"
-  (let ((type (get-type array)))
-    (macrolet ((pick-element-type (&rest stuff)
-		 `(cond ,@(mapcar #'(lambda (stuff)
-				      (cons
-				       (let ((item (car stuff)))
-					 (cond ((eq item t)
-						t)
-					       ((listp item)
-						(cons 'or
-						      (mapcar #'(lambda (x)
-								  `(= type ,x))
-							      item)))
-					       (t
-						`(= type ,item))))
-				       (cdr stuff)))
-						   stuff))))
-      (pick-element-type
-       ((vm:simple-string-type vm:complex-string-type) 'base-char)
-       ((vm:simple-bit-vector-type vm:complex-bit-vector-type) 'bit)
-       (vm:simple-vector-type t)
-       (vm:simple-array-unsigned-byte-2-type '(unsigned-byte 2))
-       (vm:simple-array-unsigned-byte-4-type '(unsigned-byte 4))
-       (vm:simple-array-unsigned-byte-8-type '(unsigned-byte 8))
-       (vm:simple-array-unsigned-byte-16-type '(unsigned-byte 16))
-       (vm:simple-array-unsigned-byte-32-type '(unsigned-byte 32))
-       (vm:simple-array-single-float-type 'single-float)
-       (vm:simple-array-double-float-type 'double-float)
-       ((vm:simple-array-type vm:complex-vector-type vm:complex-array-type)
-	(with-array-data ((array array) (start) (end))
-	  (declare (ignore start end))
-	  (array-element-type array)))
-       (t
-	(error "~S is not an array." array))))))
-
-
-(defun array-rank (array)
-  "Returns the number of dimensions of the Array."
-  (cond ((array-header-p array)
-	 (%array-rank array))
-	((vectorp array)
-	 1)
-	(t
-	 (error "~S is not an array." array))))
-
-(defun array-dimension (array axis-number)
-  "Returns length of dimension Axis-Number of the Array."
-  (declare (array array) (type index axis-number))
-  (when (>= axis-number (array-rank array))
-    (error "~D is too big; ~S only has ~D dimension~:P"
-	   axis-number array (array-rank array)))
-  (if (array-header-p array)
-      (%array-dimension array axis-number)
-      (length (the (simple-array * (*)) array))))
-
-(defun array-dimensions (array)
-  "Returns a list whose elements are the dimensions of the array"
-  (declare (array array))
-  (if (array-header-p array)
-      (do ((results nil (cons (array-dimension array index) results))
-	   (index (1- (array-rank array)) (1- index)))
-	  ((minusp index) results))
-      (list (array-dimension array 0))))
-
-(defun array-total-size (array)
-  "Returns the total number of elements in the Array."
-  (declare (array array))
-  (if (array-header-p array)
-      (%array-available-elements array)
-      (length (the vector array))))
-
-(defun array-displacement (array)
-  "Returns values of :displaced-to and :displaced-index-offset options to
-   make-array, or the defaults nil and 0 if not a displaced array."
-  (declare (array array))
-  (values (%array-data-vector array) (%array-displacement array)))
-
-(defun adjustable-array-p (array)
-  "Returns T if (adjust-array array...) would return an array identical
-   to the argument, this happens for complex arrays."
-  (declare (array array))
-  (not (typep array '(simple-array * (*)))))
-
-
-;;;; Fill pointer frobbing stuff.
-
-(defun array-has-fill-pointer-p (array)
-  "Returns T if the given Array has a fill pointer, or Nil otherwise."
-  (declare (array array))
-  (and (array-header-p array) (%array-fill-pointer-p array)))
-
-(defun fill-pointer (vector)
-  "Returns the Fill-Pointer of the given Vector."
-  (declare (vector vector))
-  (if (and (array-header-p vector) (%array-fill-pointer-p vector))
-      (%array-fill-pointer vector)
-      (error "~S is not an array with a fill-pointer." vector)))
-
-(defun %set-fill-pointer (vector new)
-  (declare (vector vector) (fixnum new))
-  (if (and (array-header-p vector) (%array-fill-pointer-p vector))
-      (if (> new (%array-available-elements vector))
-	(error "New fill pointer, ~S, is larger than the length of the vector."
-	       new)
-	(setf (%array-fill-pointer vector) 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 index of the pushed element is 
-   returned."
-  (declare (vector array))
-  (let ((fill-pointer (fill-pointer array)))
-    (declare (fixnum fill-pointer))
-    (cond ((= fill-pointer (%array-available-elements array))
-	   nil)
-	  (t
-	   (setf (aref array fill-pointer) new-el)
-	   (setf (%array-fill-pointer array) (1+ fill-pointer))
-	   fill-pointer))))
-
-(defun vector-push-extend (new-el array &optional
-				  (extension (if (zerop (length array))
-						 1
-						 (length array))))
-  "Like Vector-Push except that if the fill pointer gets too large, the
-   Array is extended rather than Nil being returned."
-  (declare (vector array) (fixnum extension))
-  (let ((fill-pointer (fill-pointer array)))
-    (declare (fixnum fill-pointer))
-    (when (= fill-pointer (%array-available-elements array))
-      (adjust-array array (+ fill-pointer extension)))
-    (setf (aref array fill-pointer) new-el)
-    (setf (%array-fill-pointer array) (1+ fill-pointer))
-    fill-pointer))
-
-(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 original value of the fill
-   pointer is 0, an error occurs."
-  (declare (vector array))
-  (let ((fill-pointer (fill-pointer array)))
-    (declare (fixnum fill-pointer))
-    (if (zerop fill-pointer)
-	(error "Nothing left to pop.")
-	(aref array
-	      (setf (%array-fill-pointer array)
-		    (1- fill-pointer))))))
-
-
-;;;; Adjust-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."
-  (let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
-    (cond ((/= (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
-	     ;; Array former contents replaced by 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 (apply #'* dimensions))
-		    (array-data (data-vector-from-inits
-				 dimensions array-size element-type
-				 initial-contents initial-element
-				 initial-element-p)))
-	       (if (adjustable-array-p array)
-		   (set-array-header array array-data array-size
-				 (get-new-fill-pointer array array-size
-						       fill-pointer)
-				 0 dimensions nil)
-		   (if (array-header-p array)
-		       ;; Simple multidimensional or single dimensional array.
-		       (make-array dimensions
-				   :element-type element-type
-				   :initial-contents initial-contents)
-		       array-data))))
-	    (displaced-to
-	     ;; No initial-contents supplied is already established.
-	     (when initial-element
-	       (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 (apply #'* 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."))
-	       (if (adjustable-array-p array)
-		   ;; None of the original contents appear in adjusted array.
-		   (set-array-header array displaced-to array-size
-				     (get-new-fill-pointer array array-size
-							   fill-pointer)
-				     displacement dimensions t)
-		   ;; Simple multidimensional or single dimensional array.
-		   (make-array dimensions
-			       :element-type element-type
-			       :displaced-to displaced-to
-			       :displaced-index-offset
-			       displaced-index-offset))))
-	    ((= array-rank 1)
-	     (let ((old-length (array-total-size array))
-		   (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 (%array-displaced-p array)
-			    (< old-length new-length))
-			(setf new-data
-			      (data-vector-from-inits
-			       dimensions new-length element-type
-			       initial-contents initial-element
-			       initial-element-p))
-			(replace new-data old-data
-				 :start2 old-start :end2 old-end))
-		       (t (setf new-data
-				(shrink-vector old-data new-length))))
-		 (if (adjustable-array-p array)
-		     (set-array-header array new-data new-length
-				       (get-new-fill-pointer array new-length
-							     fill-pointer)
-				       0 dimensions nil)
-		     new-data))))
-	    (t
-	     (let ((old-length (%array-available-elements array))
-		   (new-length (apply #'* 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 (%array-displaced-p array)
-					 (> new-length old-length))
-				     (data-vector-from-inits
-				      dimensions new-length
-				      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)))))))))
-
-(defun get-new-fill-pointer (old-array new-array-size fill-pointer)
-  (cond ((not fill-pointer)
-	 (when (array-has-fill-pointer-p old-array)
-	   (when (> (%array-fill-pointer old-array) new-array-size)
-	     (error "Cannot adjust-array an array (~S) to a size (~S) that is ~
-	            smaller than it's fill pointer (~S)."
-		    old-array new-array-size (fill-pointer old-array)))
-	   (%array-fill-pointer old-array)))
-	((not (array-has-fill-pointer-p old-array))
-	 (error "Cannot supply a non-NIL value (~S) for :fill-pointer ~
-		        in adjust-array unless the array (~S) was originally ~
- 			created with a fill pointer."
-		       fill-pointer
-		       old-array))
-	((numberp fill-pointer)
-	 (when (> fill-pointer new-array-size)
-	   (error "Cannot supply a value for :fill-pointer (~S) that is larger ~
-	          than the new length of the vector (~S)."
-		  fill-pointer new-array-size))
-	 fill-pointer)
-	((eq fill-pointer t)
-	 new-array-size)
-	(t
-	 (error "Bogus value for :fill-pointer in adjust-array: ~S"
-		fill-pointer))))
-
-(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."
-  (declare (vector vector))
-  (unless (array-header-p vector)
-    (macrolet ((frob (name &rest things)
-		 `(etypecase ,name
-		    ,@(mapcar #'(lambda (thing)
-				  `(,(car thing)
-				    (fill (truly-the ,(car thing) ,name)
-					  ,(cadr thing)
-					  :start new-size)))
-			      things))))
-      (frob vector
-	(simple-vector 0)
-	(simple-base-string (code-char 0))
-	(simple-bit-vector 0)
-	((simple-array (unsigned-byte 2) (*)) 0)
-	((simple-array (unsigned-byte 4) (*)) 0)
-	((simple-array (unsigned-byte 8) (*)) 0)
-	((simple-array (unsigned-byte 16) (*)) 0)
-	((simple-array (unsigned-byte 32) (*)) 0)
-	((simple-array single-float (*)) (coerce 0 'single-float))
-	((simple-array double-float (*)) (coerce 0 'double-float)))))
-  ;; Only arrays have fill-pointers, but vectors have their length parameter
-  ;; in the same place.
-  (setf (%array-fill-pointer vector) new-size)
-  vector)
-
-(defun set-array-header (array data length fill-pointer displacement dimensions
-			 &optional displacedp)
-  "Fills in array header with provided information.  Returns array."
-  (setf (%array-data-vector array) data)
-  (setf (%array-available-elements array) length)
-  (cond (fill-pointer
-	 (setf (%array-fill-pointer array) fill-pointer)
-	 (setf (%array-fill-pointer-p array) t))
-	(t
-	 (setf (%array-fill-pointer array) length)
-	 (setf (%array-fill-pointer-p array) nil)))
-  (setf (%array-displacement array) displacement)
-  (if (listp dimensions)
-      (dotimes (axis (array-rank array))
-	(declare (type index axis))
-	(setf (%array-dimension array axis) (pop dimensions)))
-      (setf (%array-dimension array 0) dimensions))
-  (setf (%array-displaced-p 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* (make-array 1000 :initial-element 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*
-	  (make-array length :initial-element 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-array-same-dimensions-p (array1 array2)
-  (declare (type (array bit) array1 array2))
-  (and (= (array-rank array1)
-	  (array-rank array2))
-       (dotimes (index (array-rank array1) t)
-	 (when (/= (array-dimension array1 index)
-		   (array-dimension array2 index))
-	   (return nil)))))
-
-(defun pick-result-array (result-bit-array bit-array-1)
-  (case result-bit-array
-    ((t) bit-array-1)
-    ((nil) (make-array (array-dimensions bit-array-1)
-		       :element-type 'bit
-		       :initial-element 0))
-    (t
-     (unless (bit-array-same-dimensions-p bit-array-1
-					  result-bit-array)
-       (error "~S and ~S do not have the same dimensions."
-	      bit-array-1 result-bit-array))
-     result-bit-array)))
-
-(defmacro def-bit-array-op (name function)
-  `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
-     ,(format nil
-	      "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
-	      BIT-ARRAY-2,~%  putting the results in RESULT-BIT-ARRAY.  ~
-	      If RESULT-BIT-ARRAY is T,~%  BIT-ARRAY-1 is used.  If ~
-	      RESULT-BIT-ARRAY is NIL or omitted, a new array is~%  created.  ~
-	      All the arrays must have the same rank and dimensions."
-	      (symbol-name function))
-     (declare (type (array bit) bit-array-1 bit-array-2)
-	      (type (or (array bit) (member t nil)) result-bit-array))
-     (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
-       (error "~S and ~S do not have the same dimensions."
-	      bit-array-1 bit-array-2))
-     (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
-       (if (and (simple-bit-vector-p bit-array-1)
-		(simple-bit-vector-p bit-array-2)
-		(simple-bit-vector-p result-bit-array))
-	   (locally (declare (optimize (speed 3) (safety 0)))
-	     (,name bit-array-1 bit-array-2 result-bit-array))
-	   (with-array-data ((data1 bit-array-1) (start1) (end1))
-	     (declare (ignore end1))
-	     (with-array-data ((data2 bit-array-2) (start2) (end2))
-	       (declare (ignore end2))
-	       (with-array-data ((data3 result-bit-array) (start3) (end3))
-		 (do ((index-1 start1 (1+ index-1))
-		      (index-2 start2 (1+ index-2))
-		      (index-3 start3 (1+ index-3)))
-		     ((>= index-3 end3) result-bit-array)
-		   (declare (type index index-1 index-2 index-3))
-		   (setf (sbit data3 index-3)
-			 (logand (,function (sbit data1 index-1)
-					    (sbit data2 index-2))
-				 1))))))))))
-
-(def-bit-array-op bit-and logand)
-(def-bit-array-op bit-ior logior)
-(def-bit-array-op bit-xor logxor)
-(def-bit-array-op bit-eqv logeqv)
-(def-bit-array-op bit-nand lognand)
-(def-bit-array-op bit-nor lognor)
-(def-bit-array-op bit-andc1 logandc1)
-(def-bit-array-op bit-andc2 logandc2)
-(def-bit-array-op bit-orc1 logorc1)
-(def-bit-array-op bit-orc2 logorc2)
-
-(defun bit-not (bit-array &optional result-bit-array)
-  "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
-  putting the results in RESULT-BIT-ARRAY.  If RESULT-BIT-ARRAY is T,
-  BIT-ARRAY is used.  If RESULT-BIT-ARRAY is NIL or omitted, a new array is
-  created.  Both arrays must have the same rank and dimensions."
-  (declare (type (array bit) bit-array)
-	   (type (or (array bit) (member t nil)) result-bit-array))
-  (let ((result-bit-array (pick-result-array result-bit-array bit-array)))
-    (if (and (simple-bit-vector-p bit-array)
-	     (simple-bit-vector-p result-bit-array))
-	(locally (declare (optimize (speed 3) (safety 0)))
-	  (bit-not bit-array result-bit-array))
-	(with-array-data ((src bit-array) (src-start) (src-end))
-	  (declare (ignore src-end))
-	  (with-array-data ((dst result-bit-array) (dst-start) (dst-end))
-	    (do ((src-index src-start (1+ src-index))
-		 (dst-index dst-start (1+ dst-index)))
-		((>= dst-index dst-end) result-bit-array)
-	      (declare (type index src-index dst-index))
-	      (setf (sbit dst dst-index)
-		    (logxor (sbit src src-index) 1))))))))
diff --git a/code/backq.lisp b/code/backq.lisp
deleted file mode 100644
index 3ada581b3908c0867cead413944a835475906546..0000000000000000000000000000000000000000
--- a/code/backq.lisp
+++ /dev/null
@@ -1,298 +0,0 @@
-;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/backq.lisp,v 1.6 1992/08/14 01:34:40 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    BACKQUOTE: Code Spice Lispified by Lee Schumacher.
-;;;   		  (unparsing by Miles Bader)
-;;;
-(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 stream (read stream t nil t))
-      (if (eq flag *bq-at-flag*)
-	  (%reader-error stream ",@ after backquote in ~S" thing))
-      (if (eq flag *bq-dot-flag*)
-	  (%reader-error stream ",. 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))
-    (%reader-error stream "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 (stream 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 stream (cdr code))
-	   (values 'vector (backquotify-1 dflag d))))
-	(t (multiple-value-bind (aflag a) (backquotify stream (car code))
-	     (multiple-value-bind (dflag d) (backquotify stream (cdr code))
-	       (if (eq dflag *bq-at-flag*)
-		   ;; get the errors later.
-		   (%reader-error stream ",@ after dot in ~S" code))
-	       (if (eq dflag *bq-dot-flag*)
-		   (%reader-error stream ",. 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 'backq-cons thing))
-	       (t
-		(cons 'backq-list* thing))))
-	((eq flag 'vector)
-	 (list 'backq-vector thing))
-	(t (cons (cdr
-		  (assq flag
-			'((cons . backq-cons)
-			  (list . backq-list)
-			  (append . backq-append)
-			  (nconc . backq-nconc))))
-		 thing))))
-
-
-;;;; Magic backq- versions of builtin functions.
-
-;;; Use synonyms for the lisp functions we use, so we can recognize backquoted
-;;; material when pretty-printing
-
-(defun backq-list (&rest args)
-  args)
-(defun backq-list* (&rest args)
-  (apply #'list* args))
-(defun backq-append (&rest args)
-  (apply #'append args))
-(defun backq-nconc (&rest args)
-  (apply #'nconc args))
-(defun backq-cons (x y)
-  (cons x y))
-
-(macrolet ((frob (b-name name)
-	     `(define-compiler-macro ,b-name (&rest args)
-		`(,',name ,@args))))
-  (frob backq-list list)
-  (frob backq-list* list*)
-  (frob backq-append append)
-  (frob backq-nconc nconc)
-  (frob backq-cons cons))
-
-(defun backq-vector (list)
-  (declare (list list))
-  (coerce list 'simple-vector))
-
-
-;;;; Unparsing
-
-(defun backq-unparse-expr (form splicing)
-  (ecase splicing
-    ((nil)
-     `(backq-comma ,form))
-    ((t)
-     `((backq-comma-at ,form)))
-    (:nconc
-     `((backq-comma-dot ,form)))
-    ))
-
-(defun backq-unparse (form &optional splicing)
-  "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*,
-  BACKQ-APPEND, etc. produced by the backquote reader macro, will return a
-  corresponding backquote input form.  In this form, `,' `,@' and `,.' are
-  represented by lists whose cars are BACKQ-COMMA, BACKQ-COMMA-AT, and
-  BACKQ-COMMA-DOT respectively, and whose cadrs are the form after the comma.
-  SPLICING indicates whether a comma-escape return should be modified for
-  splicing with other forms: a value of T or :NCONC meaning that an extra
-  level of parentheses should be added."
-  (if (atom form)
-      (backq-unparse-expr form splicing)
-      (case (car form)
-	(backq-list
-	 (mapcar #'backq-unparse (cdr form)))
-	(backq-list*
-	 (do ((tail (cdr form) (cdr tail))
-	      (accum nil))
-	     ((null (cdr tail))
-	      (nconc (nreverse accum)
-		     (backq-unparse (car tail) t)))
-	   (push (backq-unparse (car tail)) accum)))
-	(backq-append
-	 (mapcan #'(lambda (el) (backq-unparse el t))
-		 (cdr form)))
-	(backq-nconc
-	 (mapcan #'(lambda (el) (backq-unparse el :nconc))
-		 (cdr form)))
-	(backq-cons
-	 (cons (backq-unparse (cadr form) nil)
-	       (backq-unparse (caddr form) t)))
-	(backq-vector
-	 (coerce (backq-unparse (cadr form)) 'vector))
-	(quote
-	 (cadr form))
-	(t
-	 (backq-unparse-expr form splicing)))))
-
-(defun pprint-backquote (stream form &rest noise)
-  (declare (ignore noise))
-  (write-char #\` stream)
-  (write (backq-unparse form) :stream stream))
-
-(defun pprint-backq-comma (stream form &rest noise)
-  (declare (ignore noise))
-  (ecase (car form)
-    (backq-comma
-     (write-char #\, stream))
-    (backq-comma-at
-     (princ ",@" stream))
-    (backq-comma-dot
-     (princ ",." stream)))
-  (write (cadr form) :stream stream))
-
-
-;;;; BACKQ-INIT and BACKQ-PP-INIT
-
-;;; BACKQ-INIT -- interface.
-;;;
-;;; This is called by %INITIAL-FUNCTION.
-;;; 
-(defun backq-init ()
-  (let ((*readtable* std-lisp-readtable))
-    (set-macro-character #\` #'backquote-macro)
-    (set-macro-character #\, #'comma-macro)))
-
-;;; BACKQ-PP-INIT -- interface.
-;;;
-;;; This is called by PPRINT-INIT.  This must be seperate from BACKQ-INIT
-;;; because SET-PPRINT-DISPATCH doesn't work until the compiler is loaded.
-;;;
-(defun backq-pp-init ()
-  (set-pprint-dispatch '(cons (eql backq-list)) #'pprint-backquote)
-  (set-pprint-dispatch '(cons (eql backq-list*)) #'pprint-backquote)
-  (set-pprint-dispatch '(cons (eql backq-append)) #'pprint-backquote)
-  (set-pprint-dispatch '(cons (eql backq-nconc)) #'pprint-backquote)
-  (set-pprint-dispatch '(cons (eql backq-cons)) #'pprint-backquote)
-  (set-pprint-dispatch '(cons (eql backq-vector)) #'pprint-backquote)
-  
-  (set-pprint-dispatch '(cons (eql backq-comma)) #'pprint-backq-comma)
-  (set-pprint-dispatch '(cons (eql backq-comma-at)) #'pprint-backq-comma)
-  (set-pprint-dispatch '(cons (eql backq-comma-dot)) #'pprint-backq-comma))
diff --git a/code/bignum-test.lisp b/code/bignum-test.lisp
deleted file mode 100644
index 992361c9b622bc244a99a53f535f7f136ae645fa..0000000000000000000000000000000000000000
--- a/code/bignum-test.lisp
+++ /dev/null
@@ -1,104 +0,0 @@
-;;;; -*- Package: Bignum -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum-test.lisp,v 1.3 1991/05/24 19:35:48 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Some stuff to check that bignum operations are retuning the correct
-;;; results.
-;;; 
-(in-package "BIGNUM")
-
-(defvar *in-bignum-wrapper* nil)
-
-(defmacro def-bignum-wrapper (name lambda-list &body body)
-  (let ((var-name (ext:symbolicate "*OLD-" name "*"))
-	(wrap-name (ext:symbolicate "WRAP-" name))
-	(args (mapcar #'(lambda (x)
-			  (if (listp x) (car x) x))
-		      (remove-if #'(lambda (x)
-				     (member x lambda-list-keywords))
-				 lambda-list))))
-    `(progn
-       (defvar ,var-name (fdefinition ',name))
-       (defun ,wrap-name ,lambda-list
-	 (if *in-bignum-wrapper*
-	     (funcall ,var-name ,@args)
-	     (let ((*in-bignum-wrapper* t))
-	       ,@body)))
-       (setf (fdefinition ',name) #',wrap-name))))
-
-(defun big= (x y)
-  (= (if (typep x 'bignum)
-	 (%normalize-bignum x (%bignum-length x))
-	 x)
-     (if (typep y 'bignum)
-	 (%normalize-bignum y (%bignum-length y))
-	 y)))
-
-(def-bignum-wrapper add-bignums (x y)
-  (let ((res (funcall *old-add-bignums* x y)))
-    (assert (big= (- res y) x))
-    res))
-
-(def-bignum-wrapper multiply-bignums (x y)
-  (let ((res (funcall *old-multiply-bignums* x y)))
-    (if (zerop x)
-	(assert (zerop res))
-	(multiple-value-bind (q r) (truncate res x)
-	  (assert (and (zerop r) (big= q y)))))
-    res))
-
-(def-bignum-wrapper negate-bignum (x &optional (fully-normalized t))
-  (let ((res (funcall *old-negate-bignum* x fully-normalized)))
-    (assert (big= (- res) x))
-    res))
-
-(def-bignum-wrapper subtract-bignum (x y)
-  (let ((res (funcall *old-subtract-bignum* x y)))
-    (assert (big= (+ res y) x))
-    res))
-
-(def-bignum-wrapper multiply-bignum-and-fixnum (x y)
-  (let ((res (funcall *old-multiply-bignum-and-fixnum* x y)))
-    (if (zerop x)
-	(assert (zerop res))
-	(multiple-value-bind (q r) (truncate res x)
-	  (assert (and (zerop r) (big= q y)))))
-    res))
-
-(def-bignum-wrapper multiply-fixnums (x y)
-  (let ((res (funcall *old-multiply-fixnums* x y)))
-    (if (zerop x)
-	(assert (zerop res))
-	(multiple-value-bind (q r) (truncate res x)
-	  (assert (and (zerop r) (big= q y)))))
-    res))
-
-(def-bignum-wrapper bignum-ashift-right (x shift)
-  (let ((res (funcall *old-bignum-ashift-right* x shift)))
-    (assert (big= (ash res shift) (logand x (ash -1 shift))))
-    res))
-
-(def-bignum-wrapper bignum-ashift-left (x shift)
-  (let ((res (funcall *old-bignum-ashift-left* x shift)))
-    (assert (big= (ash res (- shift)) x))
-    res))
-
-(def-bignum-wrapper bignum-truncate (x y)
-  (multiple-value-bind (q r)
-		       (funcall *old-bignum-truncate* x y)
-    (assert (big= (+ (* q y) r) x))
-    (values q r)))
-
-(def-bignum-wrapper bignum-compare (x y)
-  (let ((res (funcall *old-bignum-compare* x y)))
-    (assert (big= (signum (- x y)) res))
-    res))
diff --git a/code/bignum.lisp b/code/bignum.lisp
deleted file mode 100644
index d051ae573dd6165db3cbdace6358f7856927ae98..0000000000000000000000000000000000000000
--- a/code/bignum.lisp
+++ /dev/null
@@ -1,2563 +0,0 @@
-;;; -*- Mode: completion; Log: code.log; Package: bignum -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.19 1991/06/12 17:24:18 chiles Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains code to implement bignum support.
-;;;
-
-(in-package "BIGNUM")
-(use-package "KERNEL")
-
-;;; These symbols define the interface to the number code.
-
-(export '(add-bignums multiply-bignums negate-bignum subtract-bignum
-	  multiply-bignum-and-fixnum multiply-fixnums
-	  bignum-ashift-right bignum-ashift-left bignum-gcd
-	  bignum-to-float float-bignum-ratio bignum-integer-length
-	  bignum-logical-and bignum-logical-ior bignum-logical-xor
-	  bignum-logical-not bignum-load-byte bignum-deposit-byte
-	  bignum-truncate bignum-plus-p bignum-compare make-small-bignum
-	  bignum-logcount))
-
-;;; These symbols define the interface to the compiler.
-
-(export '(bignum-type bignum-element-type bignum-index %allocate-bignum
-	  %bignum-length %bignum-set-length %bignum-ref %bignum-set
-	  %digit-0-or-plusp %add-with-carry %subtract-with-borrow
-	  %multiply-and-add %multiply %lognot %logand %logior %logxor
-	  %fixnum-to-digit %floor %fixnum-digit-with-correct-sign %ashl
-	  %ashr %digit-logical-shift-right))
-
-
-
-;;;; Notes.
-
-;;; The following interfaces will either be assembler routines or code sequences
-;;; expanded into the code as basic bignum operations:
-;;;    General:
-;;;       %BIGNUM-LENGTH
-;;;       %ALLOCATE-BIGNUM
-;;;       %BIGNUM-REF
-;;;       %NORMALIZE-BIGNUM
-;;;       %BIGNUM-SET-LENGTH
-;;;       %FIXNUM-DIGIT-WITH-CORRECT-SIGN
-;;;       %SIGN-DIGIT
-;;;	  %ASHR
-;;;       %ASHL
-;;;       %BIGNUM-0-OR-PLUSP
-;;;       %DIGIT-LOGICAL-SHIFT-RIGHT
-;;;    General (May not exist when done due to sole use in %-routines.)
-;;;       %DIGIT-0-OR-PLUSP
-;;;    Addition:
-;;;       %ADD-WITH-CARRY
-;;;    Subtraction:
-;;;       %SUBTRACT-WITH-BORROW
-;;;    Multiplication
-;;;       %MULTIPLY
-;;;    Negation
-;;;       %LOGNOT
-;;;    Shifting (in place)
-;;;       %NORMALIZE-BIGNUM-BUFFER
-;;;    GCD/Relational operators:
-;;;       %DIGIT-COMPARE
-;;;       %DIGIT-GREATER
-;;;    Relational operators:
-;;;       %LOGAND
-;;;       %LOGIOR
-;;;       %LOGXOR
-;;;    LDB
-;;;       %FIXNUM-TO-DIGIT
-;;;    TRUNCATE
-;;;       %FLOOR
-;;;
-;;;
-;;; Note: The floating routines know about the float representation.
-;;;
-;;; PROBLEM 1:
-;;; There might be a problem with various LET's and parameters that take a
-;;; digit value.  We need to write these so those things stay in 32-bit
-;;; registers and number stack slots.  I bind locals to these values, and I
-;;; use function on them -- ZEROP, ASH, etc.
-;;;
-;;; PROBLEM 2:
-;;; In shifting and byte operations, I use masks and logical operations that
-;;; could result in intermediate bignums.  This is hidden by the current system,
-;;; but I may need to write these in a way that keeps these masks and logical
-;;; operations from diving into the Lisp level bignum code.
-;;;
-;;; To do:
-;;;    fixnums
-;;;       logior, logxor, logand
-;;;       depending on relationals, < (twice) and <= (twice)
-;;;          or write compare thing (twice).
-;;;       LDB on fixnum with bignum result.
-;;;       DPB on fixnum with bignum result.
-;;;       TRUNCATE returns zero or one as one value and fixnum or minus fixnum
-;;;          for the other value when given (truncate fixnum bignum).
-;;;          Returns (truncate bignum fixnum) otherwise.
-;;;       addition
-;;;       subtraction (twice)
-;;;       multiply
-;;;       GCD
-;;;    write MASK-FIELD and DEPOSIT-FIELD in terms of logical operations.
-;;;    DIVIDE
-;;;       IF (/ x y) with bignums:
-;;;          do the truncate, and if rem is 0, return quotient.
-;;;          if rem is non-0
-;;;	     gcd of x and y.
-;;;	     "truncate" each by gcd, ignoring remainder 0.
-;;;	     form ratio of each result, bottom is positive.
-;;;
-
-
-
-;;;; What's a bignum?
-
-(eval-when (compile load eval) ;Necessary for DEFTYPE.
-
-(defconstant digit-size 32)
-
-(defconstant maximum-bignum-length (1- (ash 1 (- 32 vm:type-bits))))
-
-) ;eval-when
-
-
-
-;;;; Internal inline routines.
-
-;;; %ALLOCATE-BIGNUM must zero all elements.
-;;;
-(defun %allocate-bignum (length)
-  (declare (type bignum-index length))
-  (%allocate-bignum length))
-
-;;; Extract the length of the bignum.
-;;; 
-(defun %bignum-length (bignum)
-  (declare (type bignum-type bignum))
-  (%bignum-length bignum))
-
-;;; %BIGNUM-REF needs to access bignums as obviously as possible, and it needs
-;;; to be able to return 32 bits somewhere no one looks for real objects.
-;;;
-(defun %bignum-ref (bignum i)
-  (declare (type bignum-type bignum)
-	   (type bignum-index i))
-  (%bignum-ref bignum i))
-;;;
-(defun %bignum-set (bignum i value)
-  (declare (type bignum-type bignum)
-	   (type bignum-index i)
-	   (type bignum-element-type value))
-  (%bignum-set bignum i value))
-;;;
-(defsetf %bignum-ref %bignum-set)
-
-;;; Return T if digit is positive, or NIL if negative.
-;;;
-(defun %digit-0-or-plusp (digit)
-  (declare (type bignum-element-type digit))
-  (not (logbitp (1- digit-size) digit)))
-
-(proclaim '(inline %bignum-0-or-plusp))
-(defun %bignum-0-or-plusp (bignum len)
-  (declare (type bignum-type bignum)
-	   (type bignum-index len))
-  (%digit-0-or-plusp (%bignum-ref bignum (1- len))))
-
-;;; %ADD-WITH-CARRY -- Internal.
-;;;
-;;; This should be in assembler, and should not cons intermediate results.  It
-;;; returns a 32bit digit and a carry resulting from adding together a, b, and
-;;; an incoming carry.
-;;;
-(defun %add-with-carry (a b carry)
-  (declare (type bignum-element-type a b)
-	   (type (mod 2) carry))
-  (%add-with-carry a b carry))
-
-;;; %SUBTRACT-WITH-BORROW -- Internal.
-;;;
-;;; This should be in assembler, and should not cons intermediate results.  It
-;;; returns a 32bit digit and a borrow resulting from subtracting b from a, and
-;;; subtracting a possible incoming borrow.
-;;;
-;;; We really do:  a - b - 1 + borrow, where borrow is either 0 or 1.
-;;; 
-(defun %subtract-with-borrow (a b borrow)
-  (declare (type bignum-element-type a b)
-	   (type (mod 2) borrow))
-  (%subtract-with-borrow a b borrow))
-
-;;; %MULTIPLY -- Internal.
-;;;
-;;; This multiplies two digit-size (32-bit) numbers, returning a 64-bit result
-;;; split into two 32-bit quantities.
-;;;
-(defun %multiply (x y)
-  (declare (type bignum-element-type x y))
-  (%multiply x y))
-
-;;; %MULTIPLY-AND-ADD  --  Internal.
-;;;
-;;; This multiplies x-digit and y-digit, producing high and low digits
-;;; manifesting the result.  Then it adds the low digit, res-digit, and
-;;; carry-in-digit.  Any carries (note, you still have to add two digits at a
-;;; time possibly producing two carries) from adding these three digits get
-;;; added to the high digit from the multiply, producing the next carry digit.
-;;; Res-digit is optional since two uses of this primitive multiplies a single
-;;; digit bignum by a multiple digit bignum, and in this situation there is no
-;;; need for a result buffer accumulating partial results which is where the
-;;; res-digit comes from.
-;;;
-(defun %multiply-and-add (x-digit y-digit carry-in-digit &optional (res-digit 0))
-  (declare (type bignum-element-type x-digit y-digit res-digit carry-in-digit))
-  (%multiply-and-add x-digit y-digit carry-in-digit res-digit))
-
-;;; %LOGNOT -- Internal.
-;;;
-(defun %lognot (digit)
-  (declare (type bignum-element-type digit))
-  (%lognot digit))
-
-;;; %LOGAND -- Internal.
-;;; %LOGIOR -- Internal.
-;;; %LOGXOR -- Internal.
-;;;
-;;; Do the 32bit unsigned op.
-;;;
-(proclaim '(inline %logand %logior %logxor))
-(defun %logand (a b)
-  (declare (type bignum-element-type a b))
-  (logand a b))
-(defun %logior (a b)
-  (declare (type bignum-element-type a b))
-  (logior a b))
-(defun %logxor (a b)
-  (declare (type bignum-element-type a b))
-  (logxor a b))
-
-;;; %FIXNUM-TO-DIGIT -- Internal.
-;;;
-;;; This takes a fixnum and sets it up as an unsigned 32-bit quantity.  In
-;;; the new system this will mean shifting it right two bits.
-;;;
-(defun %fixnum-to-digit (x)
-  (declare (fixnum x))
-  (logand x (1- (ash 1 digit-size))))
-
-#-32x16-divide
-;;; %FLOOR -- Internal.
-;;;
-;;; This takes three digits and returns the FLOOR'ed result of dividing the
-;;; first two as a 64-bit integer by the third.
-;;;
-;;; DO WEIRD let AND setq STUFF TO SLIME THE COMPILER INTO ALLOWING THE %FLOOR
-;;; TRANSFORM TO EXPAND INTO PSEUDO-ASSEMBLER FOR WHICH THE COMPILER CAN LATER
-;;; CORRECTLY ALLOCATE REGISTERS.
-;;;
-(defun %floor (a b c)
-  (let ((a a) (b b) (c c))
-    (declare (type bignum-element-type a b c))
-    (setq a a b b c c)
-    (%floor a b c)))
-
-
-;;; %FIXNUM-DIGIT-WITH-CORRECT-SIGN -- Internal.
-;;;
-;;; Convert the digit to a regular integer assuming that the digit is signed.
-;;;
-(defun %fixnum-digit-with-correct-sign (digit)
-  (declare (type bignum-element-type digit))
-  (if (logbitp (1- digit-size) digit)
-      (logior digit (ash -1 digit-size))
-      digit))
-
-;;; %ASHR -- Internal.
-;;;
-;;; Do an arithmetic shift right of data even though bignum-element-type is
-;;; unsigned.
-;;;
-(defun %ashr (data count)
-  (declare (type bignum-element-type data)
-	   (type (mod 32) count))
-  (%ashr data count))
-
-;;; %ASHL -- Internal.
-;;;
-;;; This takes a 32-bit quantity and shifts it to the left, returning a 32-bit
-;;; quantity.
-(defun %ashl (data count)
-  (declare (type bignum-element-type data)
-	   (type (mod 32) count))
-  (%ashl data count))
-
-;;; %DIGIT-LOGICAL-SHIFT-RIGHT  --  Internal
-;;;
-;;;    Do an unsigned (logical) right shift of a digit by Count.
-;;;
-(defun %digit-logical-shift-right (data count)
-  (declare (type bignum-element-type data)
-	   (type (mod 32) count))
-  (%digit-logical-shift-right data count))
-
-
-;;; %BIGNUM-SET-LENGTH -- Internal.
-;;;
-;;; Change the length of bignum to be newlen.  Newlen must be the same or
-;;; smaller than the old length, and any elements beyond newlen must be zeroed.
-;;; 
-(defun %bignum-set-length (bignum newlen)
-  (declare (type bignum-type bignum)
-	   (type bignum-index newlen))
-  (%bignum-set-length bignum newlen))
-
-;;; %SIGN-DIGIT -- Internal.
-;;;
-;;; This returns 0 or "-1" depending on whether the bignum is positive.  This
-;;; is suitable for infinite sign extension to complete additions,
-;;; subtractions, negations, etc.  This cannot return a -1 represented as
-;;; a negative fixnum since it would then have to low zeros.
-;;;
-(proclaim '(inline %sign-digit))
-(defun %sign-digit (bignum len)
-  (declare (type bignum-type bignum)
-	   (type bignum-index len))
-  (%ashr (%bignum-ref bignum (1- len)) (1- digit-size)))
-
-
-
-;;; %DIGIT-COMPARE and %DIGIT-GREATER -- Internal.
-;;;
-;;; These take two 32 bit quantities and compare or contrast them without
-;;; wasting time with incorrect type checking.
-;;;
-(proclaim '(inline %digit-compare %digit-greater))
-(defun %digit-compare (x y)
-  (= x y))
-;;;
-(defun %digit-greater (x y)
-  (> x y))
-
-
-(proclaim '(optimize (speed 3) (safety 0)))
-
-
-;;;; Addition.
-
-(defun add-bignums (a b)
-  (declare (type bignum-type a b))
-  (let ((len-a (%bignum-length a))
-	(len-b (%bignum-length b)))
-    (declare (type bignum-index len-a len-b))
-    (multiple-value-bind (a len-a b len-b)
-			 (if (> len-a len-b)
-			     (values a len-a b len-b)
-			     (values b len-b a len-a))
-      (declare (type bignum-type a b)
-	       (type bignum-index len-a len-b))
-      (let* ((len-res (1+ len-a))
-	     (res (%allocate-bignum len-res))
-	     (carry 0))
-	(declare (type bignum-index len-res)
-		 (type bignum-type res)
-		 (type (mod 2) carry))
-	(dotimes (i len-b)
-	  (declare (type bignum-index i))
-	  (multiple-value-bind
-	      (v k)
-	      (%add-with-carry (%bignum-ref a i) (%bignum-ref b i) carry)
-	    (declare (type bignum-element-type v)
-		     (type (mod 2) k))
-	    (setf (%bignum-ref res i) v)
-	    (setf carry k)))
-	(if (/= len-a len-b)
-	    (finish-add a res carry (%sign-digit b len-b) len-b len-a)
-	    (setf (%bignum-ref res len-a)
-		  (%add-with-carry (%sign-digit a len-a)
-				   (%sign-digit b len-b)
-				   carry)))
-	(%normalize-bignum res len-res)))))
-
-;;; FINISH-ADD -- Internal.
-;;;
-;;; This takes the longer of two bignums and propagates the carry through its
-;;; remaining high order digits.
-;;;
-(defun finish-add (a res carry sign-digit-b start end)
-  (declare (type bignum-type a res)
-	   (type (mod 2) carry)
-	   (type bignum-element-type sign-digit-b)
-	   (type bignum-index start end))
-  (do ((i start (1+ i)))
-      ((= i end)
-       (setf (%bignum-ref res end)
-	     (%add-with-carry (%sign-digit a end) sign-digit-b carry)))
-    (declare (type bignum-index i))
-    (multiple-value-bind (v k)
-			 (%add-with-carry (%bignum-ref a i) sign-digit-b carry)
-      (setf (%bignum-ref res i) v)
-      (setf carry k)))
-  (ext:undefined-value))
-
-
-;;;; Subtraction.
-
-(eval-when (compile eval)
-
-;;; SUBTRACT-BIGNUM-LOOP -- Internal.
-;;;
-;;; This subtracts b from a plugging result into res.  Return-fun is the
-;;; function to call that fixes up the result returning any useful values, such
-;;; as the result.  This macro may evaluate its arguments more than once.
-;;;
-(defmacro subtract-bignum-loop (a len-a b len-b res len-res return-fun)
-  (let ((borrow (gensym))
-	(a-digit (gensym))
-	(a-sign (gensym))
-	(b-digit (gensym))
-	(b-sign (gensym))
-	(i (gensym))
-	(v (gensym))
-	(k (gensym)))
-    `(let* ((,borrow 1)
-	    (,a-sign (%sign-digit ,a ,len-a))
-	    (,b-sign (%sign-digit ,b ,len-b)))
-       (declare (type bignum-element-type ,a-sign ,b-sign))
-       (dotimes (,i ,len-res)
-	 (declare (type bignum-index ,i))
-	 (let ((,a-digit (if (< ,i ,len-a) (%bignum-ref ,a ,i) ,a-sign))
-	       (,b-digit (if (< ,i ,len-b) (%bignum-ref ,b ,i) ,b-sign)))
-	   (declare (type bignum-element-type ,a-digit ,b-digit))
-	   (multiple-value-bind
-	       (,v ,k)
-	       (%subtract-with-borrow ,a-digit ,b-digit ,borrow)
-	     (setf (%bignum-ref ,res ,i) ,v)
-	     (setf ,borrow ,k))))
-       (,return-fun ,res ,len-res))))
-
-) ;EVAL-WHEN
-
-(defun subtract-bignum (a b)
-  (declare (type bignum-type a b))
-  (let* ((len-a (%bignum-length a))
-	 (len-b (%bignum-length b))
-	 (len-res (1+ (max len-a len-b)))
-	 (res (%allocate-bignum len-res)))
-    (declare (type bignum-index len-a len-b len-res)) ;Test len-res for bounds?
-    (subtract-bignum-loop a len-a b len-b res len-res %normalize-bignum)))
-
-;;; SUBTRACT-BIGNUM-BUFFERS -- Internal.
-;;;
-;;; Operations requiring a subtraction without the overhead of intermediate
-;;; results, such as GCD, use this.  It assumes Result is big enough for the
-;;; result.
-;;;
-(defun subtract-bignum-buffers (a len-a b len-b result)
-  (declare (type bignum-type a b)
-	   (type bignum-index len-a len-b))
-  (let ((len-res (max len-a len-b)))
-    (subtract-bignum-loop a len-a b len-b result len-res
-			  %normalize-bignum-buffer)))
-
-
-
-;;;; Multiplication.
-
-(defun multiply-bignums (a b)
-  (declare (type bignum-type a b))
-  (let* ((a-plusp (%bignum-0-or-plusp a (%bignum-length a)))
-	 (b-plusp (%bignum-0-or-plusp b (%bignum-length b)))
-	 (a (if a-plusp a (negate-bignum a)))
-	 (b (if b-plusp b (negate-bignum b)))
-	 (len-a (%bignum-length a))
-	 (len-b (%bignum-length b))
-	 (len-res (+ len-a len-b))
-	 (res (%allocate-bignum len-res))
-	 (negate-res (not (eq a-plusp b-plusp))))
-    (declare (type bignum-index len-a len-b len-res))
-    (dotimes (i len-a)
-      (declare (type bignum-index i))
-      (let ((carry-digit 0)
-	    (x (%bignum-ref a i))
-	    (k i))
-	(declare (type bignum-index k)
-		 (type bignum-element-type carry-digit x))
-	(dotimes (j len-b)
-	  (multiple-value-bind (big-carry res-digit)
-			       (%multiply-and-add x (%bignum-ref b j)
-						  (%bignum-ref res k)
-						  carry-digit)
-	    (declare (type bignum-element-type big-carry res-digit))
-	    (setf (%bignum-ref res k) res-digit)
-	    (setf carry-digit big-carry)
-	    (incf k)))
-	(setf (%bignum-ref res k) carry-digit)))
-    (when negate-res (negate-bignum-in-place res))
-    (%normalize-bignum res len-res)))
-
-(defun multiply-bignum-and-fixnum (bignum fixnum)
-  (declare (type bignum-type bignum) (type fixnum fixnum))
-  (let* ((bignum-plus-p (%bignum-0-or-plusp bignum (%bignum-length bignum)))
-	 (fixnum-plus-p (not (minusp fixnum)))
-	 (bignum (if bignum-plus-p bignum (negate-bignum bignum)))
-	 (bignum-len (%bignum-length bignum))
-	 (fixnum (%fixnum-to-digit (if fixnum-plus-p fixnum (- fixnum))))
-	 (result (%allocate-bignum (1+ bignum-len)))
-	 (carry-digit 0))
-    (declare (type bignum-type bignum result)
-	     (type bignum-index bignum-len)
-	     (type bignum-element-type fixnum carry-digit))
-    (dotimes (index bignum-len)
-      (declare (type bignum-index index))
-      (multiple-value-bind
-	  (next-digit low)
-	  (%multiply-and-add (%bignum-ref bignum index) fixnum carry-digit)
-	(declare (type bignum-element-type next-digit low))
-	(setf carry-digit next-digit)
-	(setf (%bignum-ref result index) low)))
-    (setf (%bignum-ref result bignum-len) carry-digit)
-    (unless (eq bignum-plus-p fixnum-plus-p)
-      (negate-bignum-in-place result))
-    (%normalize-bignum result (1+ bignum-len))))
-
-(defun multiply-fixnums (a b)
-  (declare (fixnum a b))
-  (let* ((a-minusp (minusp a))
-	 (b-minusp (minusp b)))
-    (multiple-value-bind (high low)
-			 (%multiply (%fixnum-to-digit (if a-minusp (- a) a))
-				    (%fixnum-to-digit (if b-minusp (- b) b)))
-      (declare (type bignum-element-type high low))
-      (if (and (zerop high)
-	       (%digit-0-or-plusp low))
-	  (let ((low (ext:truly-the (unsigned-byte 31)
-				    (%fixnum-digit-with-correct-sign low))))
-	    (if (eq a-minusp b-minusp)
-		low
-		(- low)))
-	  (let ((res (%allocate-bignum 2)))
-	    (%bignum-set res 0 low)
-	    (%bignum-set res 1 high)
-	    (unless (eq a-minusp b-minusp) (negate-bignum-in-place res))
-	    (%normalize-bignum res 2))))))
-
-
-
-;;;; BIGNUM-REPLACE and WITH-BIGNUM-BUFFERS.
-
-(eval-when (compile eval)
-
-;;; BIGNUM-REPLACE -- Internal.
-;;;
-(defmacro bignum-replace (dest src &key (start1 '0) end1 (start2 '0) end2
-			       from-end)
-  (ext:once-only ((n-dest dest)
-		  (n-src src))
-    (let ((n-start1 (gensym))
-	  (n-end1 (gensym))
-	  (n-start2 (gensym))
-	  (n-end2 (gensym))
-	  (i1 (gensym))
-	  (i2 (gensym))
-	  (end1 (or end1 `(%bignum-length ,n-dest)))
-	  (end2 (or end2 `(%bignum-length ,n-src))))
-      (if from-end
-	  `(let ((,n-start1 ,start1)
-		 (,n-start2 ,start2))
-	     (do ((,i1 (1- ,end1) (1- ,i1))
-		  (,i2 (1- ,end2) (1- ,i2)))
-		 ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2)))
-	       (declare (fixnum ,i1 ,i2))
-	       (%bignum-set ,n-dest ,i1
-			    (%bignum-ref ,n-src ,i2))))
-	  `(let ((,n-end1 ,end1)
-		 (,n-end2 ,end2))
-	     (do ((,i1 ,start1 (1+ ,i1))
-		  (,i2 ,start2 (1+ ,i2)))
-		 ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2)))
-	       (declare (type bignum-index ,i1 ,i2))
-	       (%bignum-set ,n-dest ,i1
-			    (%bignum-ref ,n-src ,i2))))))))
-
-
-;;; WITH-BIGNUM-BUFFERS  --  Internal.
-;;;
-;;; Could do freelisting someday.
-;;;
-(defmacro with-bignum-buffers (specs &body body)
-  "WITH-BIGNUM-BUFFERS ({(var size [init])}*) Form*"
-  (ext:collect ((binds)
-		(inits))
-    (dolist (spec specs)
-      (let ((name (first spec))
-	    (size (second spec)))
-	(binds `(,name (%allocate-bignum ,size)))
-	(let ((init (third spec)))
-	  (when init
-	    (inits `(bignum-replace ,name ,init))))))
-    `(let* ,(binds)
-       ,@(inits)
-       ,@body)))
-
-) ;EVAL-WHEN
-
-
-
-;;;; GCD.
-
-(defun bignum-gcd (a b)
-  (declare (type bignum-type a b))
-  (let* ((a (if (%bignum-0-or-plusp a (%bignum-length a))
-		a
-		(negate-bignum a nil)))
-	 (b (if (%bignum-0-or-plusp b (%bignum-length b))
-		b
-		(negate-bignum b nil)))
-	 (len-a (%bignum-length a))
-	 (len-b (%bignum-length b)))
-      (declare (type bignum-index len-a len-b))
-    (with-bignum-buffers ((a-buffer len-a a)
-			  (b-buffer len-b b)
-			  (res-buffer (max len-a len-b)))
-      (let* ((factors-of-two
-	      (bignum-factors-of-two a-buffer len-a
-				     b-buffer len-b))
-	     (len-a (make-gcd-bignum-odd
-		     a-buffer
-		     (bignum-buffer-ashift-right a-buffer len-a
-						 factors-of-two)))
-	     (len-b (make-gcd-bignum-odd
-		     b-buffer
-		     (bignum-buffer-ashift-right b-buffer len-b
-						 factors-of-two))))
-	(declare (type bignum-index len-a len-b))
-	(let ((x a-buffer)
-	      (len-x len-a)
-	      (y b-buffer)
-	      (len-y len-b)
-	      (z res-buffer))
-	  (loop
-	    (multiple-value-bind
-		(u v len-v r len-r)
-		(bignum-gcd-order-and-subtract x len-x y len-y z)
-	      (declare (type bignum-index len-v len-r))
-	      (when (and (= len-r 1) (zerop (%bignum-ref r 0)))
-		(if (zerop factors-of-two)
-		    (let ((ret (%allocate-bignum len-v)))
-		      (dotimes (i len-v)
-			(setf (%bignum-ref ret i) (%bignum-ref v i)))
-		      (return (%normalize-bignum ret len-v)))
-		    (return (bignum-ashift-left v factors-of-two len-v))))
-	      (setf x v  len-x len-v)
-	      (setf y r  len-y (make-gcd-bignum-odd r len-r))
-	      (setf z u))))))))
-
-
-(defun bignum-gcd-order-and-subtract (a len-a b len-b res)
-  (declare (type bignum-index len-a len-b) (type bignum-type a b))
-  (cond ((= len-a len-b)
-	 (do ((i (1- len-a) (1- i)))
-	     ((= i -1)
-	      (setf (%bignum-ref res 0) 0)
-	      (values a b len-b res 1))
-	   (let ((a-digit (%bignum-ref a i))
-		 (b-digit (%bignum-ref b i)))
-	     (cond ((%digit-compare a-digit b-digit))
-		   ((%digit-greater a-digit b-digit)
-		    (return
-		     (values a b len-b res
-			     (subtract-bignum-buffers a len-a b len-b res))))
-		   (t
-		    (return
-		     (values b a len-a res
-			     (subtract-bignum-buffers b len-b a len-a res))))))))
-	((> len-a len-b)
-	 (values a b len-b res
-		 (subtract-bignum-buffers a len-a b len-b res)))
-	(t
-	 (values b a len-a res
-		 (subtract-bignum-buffers b len-b a len-a res)))))
-
-(defun make-gcd-bignum-odd (a len-a)
-  (declare (type bignum-type a) (type bignum-index len-a))
-  (dotimes (index len-a)
-    (declare (type bignum-index index))
-    (do ((digit (%bignum-ref a index) (%ashr digit 1))
-	 (increment 0 (1+ increment)))
-	((zerop digit))
-      (declare (type (mod 32) increment))
-      (when (oddp digit)
-	(return-from make-gcd-bignum-odd
-		     (bignum-buffer-ashift-right a len-a
-						 (+ (* index digit-size)
-						    increment)))))))
-
-(defun bignum-factors-of-two (a len-a b len-b)
-  (declare (type bignum-index len-a len-b) (type bignum-type a))
-  (do ((i 0 (1+ i))
-       (end (min len-a len-b)))
-      ((= i end) (error "Unexpected zero bignums?"))
-    (declare (type bignum-index i end))
-    (let ((or-digits (%logior (%bignum-ref a i) (%bignum-ref b i))))
-      (unless (zerop or-digits)
-	(return (do ((j 0 (1+ j))
-		     (or-digits or-digits (%ashr or-digits 1)))
-		    ((oddp or-digits) (+ (* i digit-size) j))
-		  (declare (type (mod 32) j))))))))
-
-
-;;;; Negation
-
-(eval-when (compile eval)
-
-;;; BIGNUM-NEGATE-LOOP -- Internal.
-;;;
-;;; This negates bignum-len digits of bignum, storing the resulting digits into
-;;; result (possibly EQ to bignum) and returning whatever end-carry there is.
-;;;
-(defmacro bignum-negate-loop (bignum bignum-len &optional (result nil resultp))
-  (let ((carry (gensym))
-	(end (gensym))
-	(value (gensym))
-	(last (gensym)))
-    `(let* (,@(if (not resultp) `(,last))
-	    (,carry 
-	     (multiple-value-bind (,value ,carry)
-				  (%add-with-carry
-				   (%lognot (%bignum-ref ,bignum 0)) 1 0)
-	       ,(if resultp
-		    `(setf (%bignum-ref ,result 0) ,value)
-		    `(setf ,last ,value))
-	       ,carry))
-	    (i 1)
-	    (,end ,bignum-len))
-       (declare (type bit ,carry)
-		(type bignum-index i ,end))
-       (loop
-	 (when (= i ,end) (return))
-	 (multiple-value-bind (,value temp)
-			      (%add-with-carry
-			       (%lognot (%bignum-ref ,bignum i)) 0 ,carry)
-	   ,(if resultp
-		`(setf (%bignum-ref ,result i) ,value)
-		`(setf ,last ,value))
-	   (setf ,carry temp))
-	 (incf i))
-       ,(if resultp carry `(values ,carry ,last)))))
-
-) ;EVAL-WHEN
-
-;;; NEGATE-BIGNUM -- Public.
-;;;
-;;; Fully-normalize is an internal optional.  It cause this to always return
-;;; a bignum, without any extraneous digits, and it never returns a fixnum.
-;;;
-(defun negate-bignum (x &optional (fully-normalize t))
-  (declare (type bignum-type x))
-  (let* ((len-x (%bignum-length x))
-	 (len-res (1+ len-x))
-	 (res (%allocate-bignum len-res)))
-    (declare (type bignum-index len-x len-res)) ;Test len-res for range?
-    (let ((carry (bignum-negate-loop x len-x res)))
-      (setf (%bignum-ref res len-x)
-	    (%add-with-carry (%lognot (%sign-digit x len-x)) 0 carry)))
-    (if fully-normalize
-	(%normalize-bignum res len-res)
-	(%mostly-normalize-bignum res len-res))))
-
-;;; NEGATE-BIGNUM-IN-PLACE -- Internal.
-;;;
-;;; This assumes bignum is positive; that is, the result of negating it will
-;;; stay in the provided allocated bignum.
-;;;
-(defun negate-bignum-in-place (bignum)
-  (bignum-negate-loop bignum (%bignum-length bignum) bignum)
-  bignum)
-
-
-
-;;;; Shifting.
-
-(defconstant all-ones-digit #xFFFFFFFF)
-
-(eval-when (compile eval)
-
-;;; SHIFT-RIGHT-UNALIGNED -- Internal.
-;;;
-;;; This macro is used by BIGNUM-ASHIFT-RIGHT, BIGNUM-BUFFER-ASHIFT-RIGHT, and
-;;; BIGNUM-LDB-BIGNUM-RES.  They supply a termination form that references
-;;; locals established by this form.  Source is the source bignum.  Start-digit
-;;; is the first digit in source from which we pull bits.  Start-pos is the
-;;; first bit we want.  Res-len-form is the form that computes the length of
-;;; the resulting bignum.  Termination is a DO termination form with a test and
-;;; body.  When result is supplied, it is the variable to which this binds a
-;;; newly allocated bignum.
-;;;
-;;; Given start-pos, 1-31 inclusively, of shift, we form the j'th resulting
-;;; digit from high bits of the i'th source digit and the start-pos number of
-;;; bits from the i+1'th source digit.
-;;;
-(defmacro shift-right-unaligned (source start-digit start-pos res-len-form
-				 termination
-				 &optional result)
-  `(let* ((high-bits-in-first-digit (- digit-size ,start-pos))
-	  (res-len ,res-len-form)
-	  (res-len-1 (1- res-len))
-	  ,@(if result `((,result (%allocate-bignum res-len)))))
-     (declare (type bignum-index res-len res-len-1))
-     (do ((i ,start-digit i+1)
-	  (i+1 (1+ ,start-digit) (1+ i+1))
-	  (j 0 (1+ j)))
-	 ,termination
-       (declare (type bignum-index i i+1 j))
-       (setf (%bignum-ref ,(if result result source) j)
-	     (%logior (%digit-logical-shift-right (%bignum-ref ,source i)
-						  ,start-pos)
-		      (%ashl (%bignum-ref ,source i+1)
-			     high-bits-in-first-digit))))))
-
-) ;EVAL-WHEN
-
-
-;;; BIGNUM-ASHIFT-RIGHT -- Public.
-;;;
-;;; First compute the number of whole digits to shift, shifting them by
-;;; skipping them when we start to pick up bits, and the number of bits to
-;;; shift the remaining digits into place.  If the number of digits is greater
-;;; than the length of the bignum, then the result is either 0 or -1.  If we
-;;; shift on a digit boundary (that is, n-bits is zero), then we just copy
-;;; digits.  The last branch handles the general case which uses a macro that a
-;;; couple other routines use.  The fifth argument to the macro references
-;;; locals established by the macro.
-;;;
-(defun bignum-ashift-right (bignum x)
-  (declare (type bignum-type bignum)
-	   (fixnum x))
-  (let ((bignum-len (%bignum-length bignum)))
-    (declare (type bignum-index bignum-len))
-    (multiple-value-bind (digits n-bits)
-			 (truncate x digit-size)
-      (declare (type bignum-index digits))
-      (cond
-       ((>= digits bignum-len)
-	(if (%bignum-0-or-plusp bignum bignum-len) 0 -1))
-       ((zerop n-bits)
-	(bignum-ashift-right-digits bignum digits))
-       (t
-	(shift-right-unaligned bignum digits n-bits (- bignum-len digits)
-			       ((= j res-len-1)
-				(setf (%bignum-ref res j)
-				      (%ashr (%bignum-ref bignum i) n-bits))
-				(%normalize-bignum res res-len))
-			       res))))))
-
-;;; BIGNUM-ASHIFT-RIGHT-DIGITS -- Internal.
-;;;
-(defun bignum-ashift-right-digits (bignum digits)
-  (declare (type bignum-type bignum)
-	   (type bignum-index digits))
-  (let* ((res-len (- (%bignum-length bignum) digits))
-	 (res (%allocate-bignum res-len)))
-    (declare (type bignum-index res-len)
-	     (type bignum-type res))
-    (bignum-replace res bignum :start2 digits)
-    (%normalize-bignum res res-len)))
-
-
-;;; BIGNUM-BUFFER-ASHIFT-RIGHT -- Internal.
-;;;
-;;; GCD uses this for an in-place shifting operation.  This is different enough
-;;; from BIGNUM-ASHIFT-RIGHT that it isn't worth folding the bodies into a
-;;; macro, but they share the basic algorithm.  This routine foregoes a first
-;;; test for digits being greater than or equal to bignum-len since that will
-;;; never happen for its uses in GCD.  We did fold the last branch into a macro
-;;; since it was duplicated a few times, and the fifth argument to it
-;;; references locals established by the macro.
-;;;
-(defun bignum-buffer-ashift-right (bignum bignum-len x)
-  (declare (type bignum-index bignum-len) (fixnum x))
-  (multiple-value-bind (digits n-bits)
-		       (truncate x digit-size)
-    (declare (type bignum-index digits))
-    (cond
-     ((zerop n-bits)
-      (let ((new-end (- bignum-len digits)))
-	(bignum-replace bignum bignum :end1 new-end :start2 digits
-			:end2 bignum-len)
-	(%normalize-bignum-buffer bignum new-end)))
-     (t
-      (shift-right-unaligned bignum digits n-bits (- bignum-len digits)
-			     ((= j res-len-1)
-			      (setf (%bignum-ref bignum j)
-				    (%ashr (%bignum-ref bignum i) n-bits))
-			      (%normalize-bignum-buffer bignum res-len)))))))
-
-
-
-;;; BIGNUM-ASHIFT-LEFT -- Public.
-;;;
-;;; This handles shifting a bignum buffer to provide fresh bignum data for some
-;;; internal routines.  We know bignum is safe when called with bignum-len.
-;;; First we compute the number of whole digits to shift, shifting them
-;;; starting to store farther along the result bignum.  If we shift on a digit
-;;; boundary (that is, n-bits is zero), then we just copy digits.  The last
-;;; branch handles the general case.
-;;;
-(defun bignum-ashift-left (bignum x &optional bignum-len)
-  (declare (type bignum-type bignum)
-	   (fixnum x)
-	   (type (or null bignum-index) bignum-len))
-  (multiple-value-bind (digits n-bits)
-		       (truncate x digit-size)
-    (let* ((bignum-len (or bignum-len (%bignum-length bignum)))
-	   (res-len (+ digits bignum-len 1)))
-      (when (> res-len maximum-bignum-length)
-	(error "Can't represent result of left shift."))
-      (if (zerop n-bits)
-	  (bignum-ashift-left-digits bignum bignum-len digits)
-	  (bignum-ashift-left-unaligned bignum digits n-bits res-len)))))
-
-;;; BIGNUM-ASHIFT-LEFT-DIGITS -- Internal.
-;;;
-(defun bignum-ashift-left-digits (bignum bignum-len digits)
-  (declare (type bignum-index bignum-len digits))
-  (let* ((res-len (+ bignum-len digits))
-	 (res (%allocate-bignum res-len)))
-    (declare (type bignum-index res-len))
-    (bignum-replace res bignum :start1 digits :end1 res-len :end2 bignum-len
-		    :from-end t)
-    res))
-
-;;; BIGNUM-ASHIFT-LEFT-UNALIGNED -- Internal.
-;;;
-;;; BIGNUM-TRUNCATE uses this to store into a bignum buffer by supplying res.
-;;; When res comes in non-nil, then this foregoes allocating a result, and it
-;;; normalizes the buffer instead of the would-be allocated result.
-;;;
-;;; We start storing into one digit higher than digits, storing a whole result
-;;; digit from parts of two contiguous digits from bignum.  When the loop
-;;; finishes, we store the remaining bits from bignum's first digit in the
-;;; first non-zero result digit, digits.  We also grab some left over high
-;;; bits from the last digit of bignum.
-;;; 
-(defun bignum-ashift-left-unaligned (bignum digits n-bits res-len
-				     &optional (res nil resp))
-  (declare (type bignum-index digits res-len)
-	   (type (mod #.digit-size) n-bits))
-  (let* ((remaining-bits (- digit-size n-bits))
-	 (res-len-1 (1- res-len))
-	 (res (or res (%allocate-bignum res-len))))
-    (declare (type bignum-index res-len res-len-1))
-    (do ((i 0 i+1)
-	 (i+1 1 (1+ i+1))
-	 (j (1+ digits) (1+ j)))
-	((= j res-len-1)
-	 (setf (%bignum-ref res digits)
-	       (%ashl (%bignum-ref bignum 0) n-bits))
-	 (setf (%bignum-ref res j)
-	       (%ashr (%bignum-ref bignum i) remaining-bits))
-	 (if resp
-	     (%normalize-bignum-buffer res res-len)
-	     (%normalize-bignum res res-len)))
-      (declare (type bignum-index i i+1 j))
-      (setf (%bignum-ref res j)
-	    (%logior (%digit-logical-shift-right (%bignum-ref bignum i)
-						 remaining-bits)
-		     (%ashl (%bignum-ref bignum i+1) n-bits))))))
-
-
-;;;; Relational operators.
-
-;;; BIGNUM-PLUS-P -- Public.
-;;;
-;;; Return T iff bignum is positive.
-;;; 
-(defun bignum-plus-p (bignum)
-  (declare (type bignum-type bignum))
-  (%bignum-0-or-plusp bignum (%bignum-length bignum)))
-
-;;; BIGNUM-COMPARE -- Public.
-;;;
-;;; This compares two bignums returning -1, 0, or 1, depending on whether a
-;;; is less than, equal to, or greater than b.
-;;;
-(proclaim '(function bignum-compare (bignum bignum) (integer -1 1)))
-(defun bignum-compare (a b)
-  (declare (type bignum-type a b))
-  (let* ((len-a (%bignum-length a))
-	 (len-b (%bignum-length b))
-	 (a-plusp (%bignum-0-or-plusp a len-a))
-	 (b-plusp (%bignum-0-or-plusp b len-b)))
-    (declare (type bignum-index len-a len-b))
-    (cond ((not (eq a-plusp b-plusp))
-	   (if a-plusp 1 -1))
-	  ((= len-a len-b)
-	   (do ((i (1- len-a) (1- i)))
-	       (())
-	     (declare (type bignum-index i))
-	     (let ((a-digit (%bignum-ref a i))
-		   (b-digit (%bignum-ref b i)))
-	       (declare (type bignum-element-type a-digit b-digit))
-	       (when (%digit-greater a-digit b-digit)
-		 (return 1))
-	       (when (%digit-greater b-digit a-digit)
-		 (return -1)))
-	     (when (zerop i) (return 0))))
-	  ((> len-a len-b)
-	   (if a-plusp 1 -1))
-	  (t (if a-plusp -1 1)))))
-
-
-;;;; Float conversion.
-
-;;; FLOAT-BIGNUM-RATIO  --  Internal
-;;;
-;;;    Given a Ratio with arbitrarily large numerator and denominator, convert
-;;; it to a float in the specified Format without causing spurious floating
-;;; overflows.  What we do is discard all of the numerator and denominator
-;;; except for the format's precision + guard bits.  We float these
-;;; integers, do the floating division, and then scaled the result accordingly.
-;;;
-;;;    The use of digit-size as the number of guard bits is relatively
-;;; arbitrary.  We want to keep around some extra bits so that we rarely do
-;;; round-to-even when there were low bits that could have caused us to round
-;;; up.  We really only need to discard enough bits to ensure that floating the
-;;; result doesn't overflow.
-;;;
-(defun float-bignum-ratio (ratio format)
-  (declare (optimize (ext:inhibit-warnings 3)))
-  (let* ((bits-to-keep (+ (float-format-digits format) digit-size))
-	 (num (numerator ratio))
-	 (num-len (integer-length num))
-	 (num-shift (min (- bits-to-keep num-len) 0))
-	 (den (denominator ratio))
-	 (den-len (integer-length den))
-	 (den-shift (min (- bits-to-keep den-len) 0)))
-    (multiple-value-bind
-	(decoded exp sign)
-	(decode-float (/ (coerce (ash num num-shift) format)
-			 (coerce (ash den den-shift) format)))
-     (* sign (scale-float decoded (+ exp (- num-shift) den-shift))))))
-
-
-;;; xxx-FLOAT-FROM-BITS  --  Internal
-;;;
-;;;    Make a single or double float with the specified significand, exponent
-;;; and sign.
-;;;
-(defun single-float-from-bits (bits exp plusp)
-  (declare (fixnum exp))
-  (declare (optimize (ext:inhibit-warnings 3)))
-  (let ((res (dpb exp
-		  vm:single-float-exponent-byte
-		  (logandc2 (ext:truly-the (unsigned-byte 31)
-					   (%bignum-ref bits 1))
-			    vm:single-float-hidden-bit))))
-    (make-single-float
-     (if plusp
-	 res
-	 (logior res (ash -1 vm:float-sign-shift))))))
-;;;
-(defun double-float-from-bits (bits exp plusp)
-  (declare (fixnum exp))
-  (declare (optimize (ext:inhibit-warnings 3)))
-  (let ((hi (dpb exp
-		 vm:double-float-exponent-byte
-		 (logandc2 (ext:truly-the (unsigned-byte 31)
-					  (%bignum-ref bits 2))
-			   vm:double-float-hidden-bit))))
-    (make-double-float
-     (if plusp
-	 hi
-	 (logior hi (ash -1 vm:float-sign-shift)))
-     (%bignum-ref bits 1))))
-
-
-;;; BIGNUM-TO-FLOAT   --  Interface
-;;;
-;;;    Convert Bignum to a float in the specified Format, rounding to the best
-;;; approximation.
-;;;
-(defun bignum-to-float (bignum format)
-  (let* ((plusp (bignum-plus-p bignum))
-	 (x (if plusp bignum (negate-bignum bignum)))
-	 (len (bignum-integer-length x))
-	 (digits (float-format-digits format))
-	 (keep (+ digits digit-size))
-	 (shift (- keep len))
-	 (shifted (if (minusp shift)
-		      (bignum-ashift-right x (- shift))
-		      (bignum-ashift-left x shift)))
-	 (low (%bignum-ref shifted 0))
-	 (round-bit (ash 1 (1- digit-size))))
-    (declare (type bignum-index len digits keep) (fixnum shift))
-    (labels ((round-up ()
-	       (let ((rounded (add-bignums shifted round-bit)))
-		 (if (> (integer-length rounded) keep)
-		     (float-from-bits (bignum-ashift-right rounded 1)
-				      (1+ len))
-		     (float-from-bits rounded len))))
-	     (float-from-bits (bits len)
-	       (declare (type bignum-index len))
-	       (ecase format
-		 (single-float
-		  (single-float-from-bits
-		   bits
-		   (check-exponent len vm:single-float-bias
-		                   vm:single-float-normal-exponent-max)
-		   plusp))
-		 (double-float
-		  (double-float-from-bits
-		   bits
-		   (check-exponent len vm:double-float-bias
-		                   vm:double-float-normal-exponent-max)
-		   plusp))))
-	     (check-exponent (exp bias max)
-	       (declare (type bignum-index len))
-	       (let ((exp (+ exp bias)))
-		 (when (> exp max)
-		   (error "Too large to be represented as a ~S:~%  ~S"
-			  format x))
-		 exp)))
-
-    (cond
-     ;;
-     ;; Round down if round bit is 0.
-     ((zerop (logand round-bit low))
-      (float-from-bits shifted len))
-     ;;
-     ;; If only round bit is set, then round to even.
-     ((and (= low round-bit)
-	   (dotimes (i (- (%bignum-length x) (ceiling keep digit-size))
-		       t)
-	     (unless (zerop (%bignum-ref x i)) (return nil))))
-      (let ((next (%bignum-ref shifted 1)))
-	(if (oddp next)
-	    (round-up)
-	    (float-from-bits shifted len))))
-     ;;
-     ;; Otherwise, round up.
-     (t
-      (round-up))))))
-
-
-;;;; Integer length and logcount
-
-(defun bignum-integer-length (bignum)
-  (declare (type bignum-type bignum))
-  (let* ((len (%bignum-length bignum))
-	 (len-1 (1- len))
-	 (digit (%bignum-ref bignum len-1)))
-    (declare (type bignum-index len len-1)
-	     (type bignum-element-type digit))
-    (+ (integer-length (%fixnum-digit-with-correct-sign digit))
-       (* len-1 digit-size))))
-
-(defun bignum-logcount (bignum)
-  (declare (type bignum-type bignum))
-  (let* ((length (%bignum-length bignum))
-	 (plusp (%bignum-0-or-plusp bignum length))
-	 (result 0))
-    (declare (type bignum-index length)
-	     (fixnum result))
-    (do ((index 0 (1+ index)))
-	((= index length) result)
-      (let ((digit (%bignum-ref bignum index)))
-	(declare (type bignum-element-type digit))
-	(incf result (logcount (if plusp digit (%lognot digit))))))))
-
-
-;;;; Logical operations.
-
-;;; NOT.
-;;;
-
-;;; BIGNUM-LOGICAL-NOT -- Public.
-;;;
-(defun bignum-logical-not (a)
-  (declare (type bignum-type a))
-  (let* ((len (%bignum-length a))
-	 (res (%allocate-bignum len)))
-    (declare (type bignum-index len))
-    (dotimes (i len res)
-      (declare (type bignum-index i))
-      (setf (%bignum-ref res i) (%lognot (%bignum-ref a i))))))
-
-
-;;; AND.
-;;;
-
-;;; BIGNUM-LOGICAL-AND -- Public.
-;;;
-(defun bignum-logical-and (a b)
-  (declare (type bignum-type a b))
-  (let* ((len-a (%bignum-length a))
-	 (len-b (%bignum-length b))
-	 (a-plusp (%bignum-0-or-plusp a len-a))
-	 (b-plusp (%bignum-0-or-plusp b len-b)))
-    (declare (type bignum-index len-a len-b))
-    (cond
-     ((< len-a len-b)
-      (if a-plusp
-	  (logand-shorter-positive a len-a b (%allocate-bignum len-a))
-	  (logand-shorter-negative a len-a b len-b (%allocate-bignum len-b))))
-     ((< len-b len-a)
-      (if b-plusp
-	  (logand-shorter-positive b len-b a (%allocate-bignum len-b))
-	  (logand-shorter-negative b len-b a len-a (%allocate-bignum len-a))))
-     (t (logand-shorter-positive a len-a b (%allocate-bignum len-a))))))
-
-;;; LOGAND-SHORTER-POSITIVE -- Internal.
-;;;
-;;; This takes a shorter bignum, a and len-a, that is positive.  Because this
-;;; is AND, we don't care about any bits longer than a's since its infinite 0
-;;; sign bits will mask the other bits out of b.  The result is len-a big.
-;;;
-(defun logand-shorter-positive (a len-a b res)
-  (declare (type bignum-type a b res)
-	   (type bignum-index len-a))
-  (dotimes (i len-a)
-    (declare (type bignum-index i))
-    (setf (%bignum-ref res i)
-	  (%logand (%bignum-ref a i) (%bignum-ref b i))))
-  (%normalize-bignum res len-a))
-
-;;; LOGAND-SHORTER-NEGATIVE -- Internal.
-;;;
-;;; This takes a shorter bignum, a and len-a, that is negative.  Because this
-;;; is AND, we just copy any bits longer than a's since its infinite 1 sign
-;;; bits will include any bits from b.  The result is len-b big.
-;;;
-(defun logand-shorter-negative (a len-a b len-b res)
-  (declare (type bignum-type a b res)
-	   (type bignum-index len-a len-b))
-  (dotimes (i len-a)
-    (declare (type bignum-index i))
-    (setf (%bignum-ref res i)
-	  (%logand (%bignum-ref a i) (%bignum-ref b i))))
-  (do ((i len-a (1+ i)))
-      ((= i len-b))
-    (declare (type bignum-index i))
-    (setf (%bignum-ref res i) (%bignum-ref b i)))
-  (%normalize-bignum res len-b))
-
-;;; IOR.
-;;;
-
-;;; BIGNUM-LOGICAL-IOR -- Public.
-;;;
-(defun bignum-logical-ior (a b)
-  (declare (type bignum-type a b))
-  (let* ((len-a (%bignum-length a))
-	 (len-b (%bignum-length b))
-	 (a-plusp (%bignum-0-or-plusp a len-a))
-	 (b-plusp (%bignum-0-or-plusp b len-b)))
-    (declare (type bignum-index len-a len-b))
-    (cond
-     ((< len-a len-b)
-      (if a-plusp
-	  (logior-shorter-positive a len-a b len-b (%allocate-bignum len-b))
-	  (logior-shorter-negative a len-a b len-b (%allocate-bignum len-b))))
-     ((< len-b len-a)
-      (if b-plusp
-	  (logior-shorter-positive b len-b a len-a (%allocate-bignum len-a))
-	  (logior-shorter-negative b len-b a len-a (%allocate-bignum len-a))))
-     (t (logior-shorter-positive a len-a b len-b (%allocate-bignum len-a))))))
-
-;;; LOGIOR-SHORTER-POSITIVE -- Internal.
-;;;
-;;; This takes a shorter bignum, a and len-a, that is positive.  Because this
-;;; is IOR, we don't care about any bits longer than a's since its infinite
-;;; 0 sign bits will mask the other bits out of b out to len-b.  The result
-;;; is len-b long.
-;;;
-(defun logior-shorter-positive (a len-a b len-b res)
-  (declare (type bignum-type a b res)
-	   (type bignum-index len-a len-b))
-  (dotimes (i len-a)
-    (declare (type bignum-index i))
-    (setf (%bignum-ref res i)
-	  (%logior (%bignum-ref a i) (%bignum-ref b i))))
-  (do ((i len-a (1+ i)))
-      ((= i len-b))
-    (declare (type bignum-index i))
-    (setf (%bignum-ref res i) (%bignum-ref b i)))
-  (%normalize-bignum res len-b))
-
-;;; LOGIOR-SHORTER-NEGATIVE -- Internal.
-;;;
-;;; This takes a shorter bignum, a and len-a, that is negative.  Because this
-;;; is IOR, we just copy any bits longer than a's since its infinite 1 sign
-;;; bits will include any bits from b.  The result is len-b long.
-;;;
-(defun logior-shorter-negative (a len-a b len-b res)
-  (declare (type bignum-type a b res)
-	   (type bignum-index len-a len-b))
-  (dotimes (i len-a)
-    (declare (type bignum-index i))
-    (setf (%bignum-ref res i)
-	  (%logior (%bignum-ref a i) (%bignum-ref b i))))
-  (do ((i len-a (1+ i))
-       (sign (%sign-digit a len-a)))
-      ((= i len-b))
-    (declare (type bignum-index i))
-    (setf (%bignum-ref res i) sign))
-  (%normalize-bignum res len-b))
-
-;;; XOR.
-;;;
-
-;;; BIGNUM-LOGICAL-XOR -- Public.
-;;;
-(defun bignum-logical-xor (a b)
-  (declare (type bignum-type a b))
-  (let ((len-a (%bignum-length a))
-	(len-b (%bignum-length b)))
-    (declare (type bignum-index len-a len-b))
-    (if (< len-a len-b)
-	(bignum-logical-xor-aux a len-a b len-b (%allocate-bignum len-b))
-	(bignum-logical-xor-aux b len-b a len-a (%allocate-bignum len-a)))))
-
-;;; BIGNUM-LOGICAL-XOR-AUX -- Internal.
-;;;
-;;; This takes the the shorter of two bignums in a and len-a.  Res is len-b
-;;; long.  Do the XOR.
-;;;
-(defun bignum-logical-xor-aux (a len-a b len-b res)
-  (declare (type bignum-type a b res)
-	   (type bignum-index len-a len-b))
-  (dotimes (i len-a)
-    (declare (type bignum-index i))
-    (setf (%bignum-ref res i)
-	  (%logxor (%bignum-ref a i) (%bignum-ref b i))))
-  (do ((i len-a (1+ i))
-       (sign (%sign-digit a len-a)))
-      ((= i len-b))
-    (declare (type bignum-index i))
-    (setf (%bignum-ref res i) (%logxor sign (%bignum-ref b i))))
-  (%normalize-bignum res len-b))
-
-
-
-;;;; LDB (load byte)
-
-#|
-FOR NOW WE DON'T USE LDB OR DPB.  WE USE SHIFTS AND MASKS IN NUMBERS.LISP WHICH
-IS LESS EFFICIENT BUT EASIER TO MAINTAIN.  BILL SAYS THIS CODE CERTAINLY WORKS!
-
-
-(defconstant maximum-fixnum-bits #+ibm-rt-pc 27 #-ibm-rt-pc 30)
-
-;;; BIGNUM-LOAD-BYTE -- Public.
-;;;
-(defun bignum-load-byte (byte bignum)
-  (declare (type bignum-type bignum))
-  (let ((byte-len (byte-size byte))
-	(byte-pos (byte-position byte)))
-    (if (< byte-len maximum-fixnum-bits)
-	(bignum-ldb-fixnum-res bignum byte-len byte-pos)
-	(bignum-ldb-bignum-res bignum byte-len byte-pos))))
-
-;;; BIGNUM-LDB-FIXNUM-RES -- Internal.
-;;;
-;;; This returns a fixnum result of loading a byte from a bignum.  In order, we
-;;; check for the following conditions:
-;;;    Insufficient bignum digits to start loading a byte --
-;;;       Return 0 or byte-len 1's depending on sign of bignum.
-;;;    One bignum digit containing the whole byte spec --
-;;;       Grab 'em, shift 'em, and mask out what we don't want.
-;;;    Insufficient bignum digits to cover crossing a digit boundary --
-;;;       Grab the available bits in the last digit, and or in whatever
-;;;       virtual sign bits we need to return a full byte spec.
-;;;    Else (we cross a digit boundary with all bits available) --
-;;;       Make a couple masks, grab what we want, shift it around, and
-;;;       LOGIOR it all together.
-;;; Because (< maximum-fixnum-bits digit-size) and
-;;;         (< byte-len maximum-fixnum-bits),
-;;; we only cross one digit boundary if any.
-;;;
-(defun bignum-ldb-fixnum-res (bignum byte-len byte-pos)
-  (multiple-value-bind (skipped-digits pos)
-		       (truncate byte-pos digit-size)
-    (let ((bignum-len (%bignum-length bignum))
-	  (s-digits+1 (1+ skipped-digits)))
-      (declare (type bignum-index bignum-len s-digits+1))
-      (if (>= skipped-digits bignum-len)
-	  (if (%bignum-0-or-plusp bignum bignum-len)
-	      0
-	      (%make-ones byte-len))
-	  (let ((end (+ pos byte-len)))
-	    (cond ((<= end digit-size)
-		   (logand (ash (%bignum-ref bignum skipped-digits) (- pos))
-			   ;; Must LOGAND after shift here.
-			   (%make-ones byte-len)))
-		  ((>= s-digits+1 bignum-len)
-		   (let* ((available-bits (- digit-size pos))
-			  (res (logand (ash (%bignum-ref bignum skipped-digits)
-					    (- pos))
-				       ;; LOGAND should be unnecessary here
-				       ;; with a logical right shift or a
-				       ;; correct unsigned-byte-32 one.
-				       (%make-ones available-bits))))
-		     (if (%bignum-0-or-plusp bignum bignum-len)
-			 res
-			 (logior (%ashl (%make-ones (- end digit-size))
-					available-bits)
-				 res))))
-		  (t
-		   (let* ((high-bits-in-first-digit (- digit-size pos))
-			  (high-mask (%make-ones high-bits-in-first-digit))
-			  (low-bits-in-next-digit (- end digit-size))
-			  (low-mask (%make-ones low-bits-in-next-digit)))
-		     (declare (type bignum-element-type high-mask low-mask))
-		     (logior (%ashl (logand (%bignum-ref bignum s-digits+1)
-					    low-mask)
-				    high-bits-in-first-digit)
-			     (logand (ash (%bignum-ref bignum skipped-digits)
-					  (- pos))
-				     ;; LOGAND should be unnecessary here with
-				     ;; a logical right shift or a correct
-				     ;; unsigned-byte-32 one.
-				     high-mask))))))))))
-
-;;; BIGNUM-LDB-BIGNUM-RES -- Internal.
-;;;
-;;; This returns a bignum result of loading a byte from a bignum.  In order, we
-;;; check for the following conditions:
-;;;    Insufficient bignum digits to start loading a byte --
-;;;    Byte-pos starting on a digit boundary --
-;;;    Byte spec contained in one bignum digit --
-;;;       Grab the bits we want and stick them in a single digit result.
-;;;       Since we know byte-pos is non-zero here, we know our single digit
-;;;       will have a zero high sign bit.
-;;;    Else (unaligned multiple digits) --
-;;;       This is like doing a shift right combined with either masking
-;;;       out unwanted high bits from bignum or filling in virtual sign
-;;;       bits if bignum had insufficient bits.  We use SHIFT-RIGHT-ALIGNED
-;;;       and reference lots of local variables this macro establishes.
-;;;
-(defun bignum-ldb-bignum-res (bignum byte-len byte-pos)
-  (multiple-value-bind (skipped-digits pos)
-		       (truncate byte-pos digit-size)
-    (let ((bignum-len (%bignum-length bignum)))
-      (declare (type bignum-index bignum-len))
-      (cond
-       ((>= skipped-digits bignum-len)
-	(make-bignum-virtual-ldb-bits bignum bignum-len byte-len))
-       ((zerop pos)
-	(make-aligned-ldb-bignum bignum bignum-len byte-len skipped-digits))
-       ((< (+ pos byte-len) digit-size)
-	(let ((res (%allocate-bignum 1)))
-	  (setf (%bignum-ref res 0)
-		(logand (%ashr (%bignum-ref bignum skipped-digits) pos)
-			(%make-ones byte-len)))
-	  res))
-       (t
-	(make-unaligned-ldb-bignum bignum bignum-len
-				   byte-len skipped-digits pos))))))
-
-;;; MAKE-BIGNUM-VIRTUAL-LDB-BITS -- Internal.
-;;;
-;;; This returns bits from bignum that don't physically exist.  These are
-;;; all zero or one depending on the sign of the bignum.
-;;;
-(defun make-bignum-virtual-ldb-bits (bignum bignum-len byte-len)
-  (if (%bignum-0-or-plusp bignum bignum-len)
-      0
-      (multiple-value-bind (res-len-1 extra)
-			   (truncate byte-len digit-size)
-	(declare (type bignum-index res-len-1))
-	(let* ((res-len (1+ res-len-1))
-	       (res (%allocate-bignum res-len)))
-	  (declare (type bignum-index res-len))
-	  (do ((j 0 (1+ j)))
-	      ((= j res-len-1)
-	       (setf (%bignum-ref res j) (%make-ones extra))
-	       (%normalize-bignum res res-len))
-	    (declare (type bignum-index j))
-	    (setf (%bignum-ref res j) all-ones-digit))))))
-
-;;; MAKE-ALIGNED-LDB-BIGNUM -- Internal.
-;;;
-;;; Since we are picking up aligned digits, we just copy the whole digits
-;;; we want and fill in extra bits.  We might have a byte-len that extends
-;;; off the end of the bignum, so we may have to fill in extra 1's if the
-;;; bignum is negative.
-;;;
-(defun make-aligned-ldb-bignum (bignum bignum-len byte-len skipped-digits)
-  (multiple-value-bind (res-len-1 extra)
-		       (truncate byte-len digit-size)
-    (declare (type bignum-index res-len-1))
-    (let* ((res-len (1+ res-len-1))
-	   (res (%allocate-bignum res-len)))
-      (declare (type bignum-index res-len))
-      (do ((i skipped-digits (1+ i))
-	   (j 0 (1+ j)))
-	  ((or (= j res-len-1) (= i bignum-len))
-	   (cond ((< i bignum-len)
-		  (setf (%bignum-ref res j)
-			(logand (%bignum-ref bignum i)
-				(the bignum-element-type (%make-ones extra)))))
-		 ((%bignum-0-or-plusp bignum bignum-len))
-		 (t
-		  (do ((j j (1+ j)))
-		      ((= j res-len-1)
-		       (setf (%bignum-ref res j) (%make-ones extra)))
-		    (setf (%bignum-ref res j) all-ones-digit))))
-	   (%normalize-bignum res res-len))
-      (declare (type bignum-index i j))
-      (setf (%bignum-ref res j) (%bignum-ref bignum i))))))
-
-;;; MAKE-UNALIGNED-LDB-BIGNUM -- Internal.
-;;;
-;;; This grabs unaligned bignum bits from bignum assuming byte-len causes at
-;;; least one digit boundary crossing.  We use SHIFT-RIGHT-UNALIGNED referencing
-;;; lots of local variables established by it.
-;;;
-(defun make-unaligned-ldb-bignum (bignum bignum-len byte-len skipped-digits pos)
-  (multiple-value-bind (res-len-1 extra)
-		       (truncate byte-len digit-size)
-    (shift-right-unaligned
-     bignum skipped-digits pos (1+ res-len-1)
-     ((or (= j res-len-1) (= i+1 bignum-len))
-      (cond ((= j res-len-1)
-	     (cond
-	      ((< extra high-bits-in-first-digit)
-	       (setf (%bignum-ref res j)
-		     (logand (ash (%bignum-ref bignum i) minus-start-pos)
-			     ;; Must LOGAND after shift here.
-			     (%make-ones extra))))
-	      (t
-	       (setf (%bignum-ref res j)
-		     (logand (ash (%bignum-ref bignum i) minus-start-pos)
-			     ;; LOGAND should be unnecessary here with a logical
-			     ;; right shift or a correct unsigned-byte-32 one.
-			     high-mask))
-	       (when (%bignum-0-or-plusp bignum bignum-len)
-		 (setf (%bignum-ref res j)
-		       (logior (%bignum-ref res j)
-			       (%ashl (%make-ones
-				       (- extra high-bits-in-first-digit))
-				      high-bits-in-first-digit)))))))
-	    (t
-	     (setf (%bignum-ref res j)
-		   (logand (ash (%bignum-ref bignum i) minus-start-pos)
-			   ;; LOGAND should be unnecessary here with a logical
-			   ;; right shift or a correct unsigned-byte-32 one.
-			   high-mask))
-	     (unless (%bignum-0-or-plusp bignum bignum-len)
-	       ;; Fill in upper half of this result digit with 1's.
-	       (setf (%bignum-ref res j)
-		     (logior (%bignum-ref res j)
-			     (%ashl low-mask high-bits-in-first-digit)))
-	       ;; Fill in any extra 1's we need to be byte-len long.
-	       (do ((j (1+ j) (1+ j)))
-		   ((>= j res-len-1)
-		    (setf (%bignum-ref res j) (%make-ones extra)))
-		 (setf (%bignum-ref res j) all-ones-digit)))))
-      (%normalize-bignum res res-len))
-     res)))
-
-
-
-;;;; DPB (deposit byte).  
-
-(defun bignum-deposit-byte (new-byte byte-spec bignum)
-  (declare (type bignum-type bignum))
-  (let* ((byte-len (byte-size byte-spec))
-	 (byte-pos (byte-position byte-spec))
-	 (bignum-len (%bignum-length bignum))
-	 (bignum-plusp (%bignum-0-or-plusp bignum bignum-len))
-	 (byte-end (+ byte-pos byte-len))
-	 (res-len (1+ (max (ceiling byte-end digit-size) bignum-len)))
-	 (res (%allocate-bignum res-len)))
-    (declare (type bignum-index bignum-len res-len))
-    ;;
-    ;; Fill in an extra sign digit in case we set what would otherwise be the
-    ;; last digit's last bit.  Normalize at the end in case this was
-    ;; unnecessary.
-    (unless bignum-plusp
-      (setf (%bignum-ref res (1- res-len)) all-ones-digit))
-    (multiple-value-bind (end-digit end-bits)
-			 (truncate byte-end digit-size)
-      (declare (type bignum-index end-digit))
-      ;;
-      ;; Fill in bits from bignum up to byte-pos.
-      (multiple-value-bind (pos-digit pos-bits)
-			   (truncate byte-pos digit-size)
-	(declare (type bignum-index pos-digit))
-	(do ((i 0 (1+ i))
-	     (end (min pos-digit bignum-len)))
-	    ((= i end)
-	     (cond ((< i bignum-len)
-		    (unless (zerop pos-bits)
-		      (setf (%bignum-ref res i)
-			    (logand (%bignum-ref bignum i)
-				    (%make-ones pos-bits)))))
-		   (bignum-plusp)
-		   (t
-		    (do ((i i (1+ i)))
-			((= i pos-digit)
-			 (unless (zerop pos-bits)
-			   (setf (%bignum-ref res i) (%make-ones pos-bits))))
-		      (setf (%bignum-ref res i) all-ones-digit)))))
-	  (setf (%bignum-ref res i) (%bignum-ref bignum i)))
-	;;
-	;; Fill in bits from new-byte.
-	(if (typep new-byte 'fixnum)
-	    (deposit-fixnum-bits new-byte byte-len pos-digit pos-bits
-				 end-digit end-bits res)
-	    (deposit-bignum-bits new-byte byte-len pos-digit pos-bits
-				 end-digit end-bits res)))
-      ;;
-      ;; Fill in remaining bits from bignum after byte-spec.
-      (when (< end-digit bignum-len)
-	(setf (%bignum-ref res end-digit)
-	      (logior (logand (%bignum-ref bignum end-digit)
-			      (%ashl (%make-ones (- digit-size end-bits))
-				     end-bits))
-		      ;; DEPOSIT-FIXNUM-BITS and DEPOSIT-BIGNUM-BITS only store
-		      ;; bits from new-byte into res's end-digit element, so
-		      ;; we don't need to mask out unwanted high bits.
-		      (%bignum-ref res end-digit)))
-	(do ((i (1+ end-digit) (1+ i)))
-	    ((= i bignum-len))
-	  (setf (%bignum-ref res i) (%bignum-ref bignum i)))))
-    (%normalize-bignum res res-len)))
-
-;;; DEPOSIT-FIXNUM-BITS -- Internal.
-;;;
-;;; This starts at result's pos-digit skipping pos-bits, and it stores bits
-;;; from new-byte, a fixnum, into result.  It effectively stores byte-len
-;;; number of bits, but never stores past end-digit and end-bits in result.
-;;; The first branch fires when all the bits we want from new-byte are present;
-;;; if byte-len crosses from the current result digit into the next, the last
-;;; argument to DEPOSIT-FIXNUM-DIGIT is a mask for those bits.  The second
-;;; branch handles the need to grab more bits than the fixnum new-byte has, but
-;;; new-byte is positive; therefore, any virtual bits are zero.  The mask for
-;;; bits that don't fit in the current result digit is simply the remaining
-;;; bits in the bignum digit containing new-byte; we don't care if we store
-;;; some extra in the next result digit since they will be zeros.  The last
-;;; branch handles the need to grab more bits than the fixnum new-byte has, but
-;;; new-byte is negative; therefore, any virtual bits must be explicitly filled
-;;; in as ones.  We call DEPOSIT-FIXNUM-DIGIT to grab what bits actually exist
-;;; and to fill in the current result digit.
-;;;
-(defun deposit-fixnum-bits (new-byte byte-len pos-digit pos-bits 
-			    end-digit end-bits result)
-  (declare (type bignum-index pos-digit end-digit))
-  (let ((other-bits (- digit-size pos-bits))
-	(new-byte-digit (%fixnum-to-digit new-byte)))
-    (declare (type bignum-element-type new-byte-digit))
-    (cond ((< byte-len maximum-fixnum-bits)
-	   (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits
-				 other-bits result
-				 (- byte-len other-bits)))
-	  ((or (plusp new-byte) (zerop new-byte))
-	   (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits
-				 other-bits result pos-bits))
-	  (t
-	   (multiple-value-bind
-	       (digit bits)
-	       (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits
-				     other-bits result
-				     (if (< (- byte-len other-bits) digit-size)
-					 (- byte-len other-bits)
-					 digit-size))
-	     (declare (type bignum-index digit))
-	     (cond ((< digit end-digit)
-		    (setf (%bignum-ref result digit)
-			  (logior (%bignum-ref result digit)
-				  (%ashl (%make-ones (- digit-size bits)) bits)))
-		    (do ((i (1+ digit) (1+ i)))
-			((= i end-digit)
-			 (setf (%bignum-ref result i) (%make-ones end-bits)))
-		      (setf (%bignum-ref result i) all-ones-digit)))
-		   ((> digit end-digit))
-		   ((< bits end-bits)
-		    (setf (%bignum-ref result digit)
-			  (logior (%bignum-ref result digit)
-				  (%ashl (%make-ones (- end-bits bits))
-					 bits))))))))))
-
-;;; DEPOSIT-FIXNUM-DIGIT -- Internal.
-;;;
-;;; This fills in the current result digit from new-byte-digit.  The first case
-;;; handles everything we want fitting in the current digit, and other-bits is
-;;; the number of bits remaining to be filled in result's current digit.  This
-;;; number is digit-size minus pos-bits.  The second branch handles filling in
-;;; result's current digit, and it shoves the unused bits of new-byte-digit
-;;; into the next result digit.  This is correct regardless of new-byte-digit's
-;;; sign.  It returns the new current result digit and how many bits already
-;;; filled in the result digit.
-;;;
-(defun deposit-fixnum-digit (new-byte-digit byte-len pos-digit pos-bits
-			     other-bits result next-digit-bits-needed)
-  (declare (type bignum-index pos-digit)
-	   (type bignum-element-type new-byte-digit next-digit-mask))
-  (cond ((<= byte-len other-bits)
-	 ;; Bits from new-byte fit in the current result digit.
-	 (setf (%bignum-ref result pos-digit)
-	       (logior (%bignum-ref result pos-digit)
-		       (%ashl (logand new-byte-digit (%make-ones byte-len))
-			      pos-bits)))
-	 (if (= byte-len other-bits)
-	     (values (1+ pos-digit) 0)
-	     (values pos-digit (+ byte-len pos-bits))))
-	(t
-	 ;; Some of new-byte's bits go in current result digit.
-	 (setf (%bignum-ref result pos-digit)
-	       (logior (%bignum-ref result pos-digit)
-		       (%ashl (logand new-byte-digit (%make-ones other-bits))
-			      pos-bits)))
-	 (let ((pos-digit+1 (1+ pos-digit)))
-	   ;; The rest of new-byte's bits go in the next result digit.
-	   (setf (%bignum-ref result pos-digit+1)
-		 (logand (ash new-byte-digit (- other-bits))
-			 ;; Must LOGAND after shift here.
-			 (%make-ones next-digit-bits-needed)))
-	   (if (= next-digit-bits-needed digit-size)
-	       (values (1+ pos-digit+1) 0)
-	       (values pos-digit+1 next-digit-bits-needed))))))
-
-;;; DEPOSIT-BIGNUM-BITS -- Internal.
-;;;
-;;; This starts at result's pos-digit skipping pos-bits, and it stores bits
-;;; from new-byte, a bignum, into result.  It effectively stores byte-len
-;;; number of bits, but never stores past end-digit and end-bits in result.
-;;; When handling a starting bit unaligned with a digit boundary, we check
-;;; in the second branch for the byte spec fitting into the pos-digit element
-;;; after after pos-bits; DEPOSIT-UNALIGNED-BIGNUM-BITS expects at least one
-;;; digit boundary crossing.
-;;;
-(defun deposit-bignum-bits (bignum-byte byte-len pos-digit pos-bits 
-			    end-digit end-bits result)
-  (declare (type bignum-index pos-digit end-digit))
-  (cond ((zerop pos-bits)
-	 (deposit-aligned-bignum-bits bignum-byte pos-digit end-digit end-bits
-				      result))
-	((or (= end-digit pos-digit)
-	     (and (= end-digit (1+ pos-digit))
-		  (zerop end-bits)))
-	 (setf (%bignum-ref result pos-digit)
-	       (logior (%bignum-ref result pos-digit)
-		       (%ashl (logand (%bignum-ref bignum-byte 0)
-				      (%make-ones byte-len))
-			      pos-bits))))
-	(t (deposit-unaligned-bignum-bits bignum-byte pos-digit pos-bits
-					  end-digit end-bits result))))
-
-;;; DEPOSIT-ALIGNED-BIGNUM-BITS -- Internal.
-;;;
-;;; This deposits bits from bignum-byte into result starting at pos-digit and
-;;; the zero'th bit.  It effectively only stores bits to end-bits in the
-;;; end-digit element of result.  The loop termination code takes care of
-;;; picking up the last digit's bits or filling in virtual negative sign bits.
-;;;
-(defun deposit-aligned-bignum-bits (bignum-byte pos-digit end-digit end-bits
-				    result)
-  (declare (type bignum-index pos-digit end-digit))
-  (let* ((bignum-len (%bignum-length bignum-byte))
-	 (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len)))
-    (declare (type bignum-index bignum-len))
-    (do ((i 0 (1+ i ))
-	 (j pos-digit (1+ j)))
-	((or (= j end-digit) (= i bignum-len))
-	 (cond ((= j end-digit)
-		(cond ((< i bignum-len)
-		       (setf (%bignum-ref result j)
-			     (logand (%bignum-ref bignum-byte i)
-				     (%make-ones end-bits))))
-		      (bignum-plusp)
-		      (t
-		       (setf (%bignum-ref result j) (%make-ones end-bits)))))
-	       (bignum-plusp)
-	       (t
-		(do ((j j (1+ j)))
-		    ((= j end-digit)
-		     (setf (%bignum-ref result j) (%make-ones end-bits)))
-		  (setf (%bignum-ref result j) all-ones-digit)))))
-      (setf (%bignum-ref result j) (%bignum-ref bignum-byte i)))))
-
-;;; DEPOSIT-UNALIGNED-BIGNUM-BITS -- Internal.
-;;;
-;;; This assumes at least one digit crossing.
-;;;
-(defun deposit-unaligned-bignum-bits (bignum-byte pos-digit pos-bits
-				      end-digit end-bits result)
-  (declare (type bignum-index pos-digit end-digit))
-  (let* ((bignum-len (%bignum-length bignum-byte))
-	 (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len))
-	 (low-mask (%make-ones pos-bits))
-	 (bits-past-pos-bits (- digit-size pos-bits))
-	 (high-mask (%make-ones bits-past-pos-bits))
-	 (minus-high-bits (- bits-past-pos-bits)))
-    (declare (type bignum-element-type low-mask high-mask)
-	     (type bignum-index bignum-len))
-    (do ((i 0 (1+ i))
-	 (j pos-digit j+1)
-	 (j+1 (1+ pos-digit) (1+ j+1)))
-	((or (= j end-digit) (= i bignum-len))
-	 (cond
-	  ((= j end-digit)
-	   (setf (%bignum-ref result j)
-		 (cond
-		  ((>= pos-bits end-bits)
-		   (logand (%bignum-ref result j) (%make-ones end-bits)))
-		  ((< i bignum-len)
-		   (logior (%bignum-ref result j)
-			   (%ashl (logand (%bignum-ref bignum-byte i)
-					  (%make-ones (- end-bits pos-bits)))
-				  pos-bits)))
-		  (bignum-plusp
-		   (logand (%bignum-ref result j)
-			   ;; 0's between pos-bits and end-bits positions.
-			   (logior (%ashl (%make-ones (- digit-size end-bits))
-					  end-bits)
-				   low-mask)))
-		  (t (logior (%bignum-ref result j)
-			     (%ashl (%make-ones (- end-bits pos-bits))
-				    pos-bits))))))
-	  (bignum-plusp)
-	  (t
-	   (setf (%bignum-ref result j)
-		 (%ashl (%make-ones bits-past-pos-bits) pos-bits))
-	   (do ((j j+1 (1+ j)))
-	       ((= j end-digit)
-		(setf (%bignum-ref result j) (%make-ones end-bits)))
-	     (declare (type bignum-index j))
-	     (setf (%bignum-ref result j) all-ones-digit)))))
-      (declare (type bignum-index i j j+1))
-      (let ((digit (%bignum-ref bignum-byte i)))
-	(declare (type bignum-element-type digit))
-	(setf (%bignum-ref result j)
-	      (logior (%bignum-ref result j)
-		      (%ashl (logand digit high-mask) pos-bits)))
-	(setf (%bignum-ref result j+1)
-	      (logand (ash digit minus-high-bits)
-		      ;; LOGAND should be unnecessary here with a logical right
-		      ;; shift or a correct unsigned-byte-32 one.
-		      low-mask))))))
-
-|#
-
-
-;;;; TRUNCATE.
-
-;;; This is the original sketch of the algorithm from which I implemented this
-;;; TRUNCATE, assuming both operands are bignums.  I should modify this to work
-;;; with the documentation on my functions, as a general introduction.  I've
-;;; left this here just in case someone needs it in the future.  Don't look
-;;; at this unless reading the functions' comments leaves you at a loss.
-;;; Remember this comes from Knuth, so the book might give you the right general
-;;; overview.
-;;; 
-;;;
-;;; (truncate x y):
-;;;
-;;; If X's magnitude is less than Y's, then result is 0 with remainder X.
-;;;
-;;; Make x and y positive, copying x if it is already positive.
-;;;
-;;; Shift y left until there's a 1 in the 30'th bit (most significant, non-sign
-;;;       digit)
-;;;    Just do most sig digit to determine how much to shift whole number.
-;;; Shift x this much too.
-;;; Remember this initial shift count.
-;;;
-;;; Allocate q to be len-x minus len-y quantity plus 1.
-;;;
-;;; i = last digit of x.
-;;; k = last digit of q.
-;;;
-;;; LOOP
-;;;
-;;; j = last digit of y.
-;;;
-;;; compute guess.
-;;; if x[i] = y[j] then g = #xFFFFFFFF
-;;; else g = x[i]x[i-1]/y[j].
-;;;
-;;; check guess.
-;;; %UNSIGNED-MULTIPLY returns b and c defined below.
-;;;    a = x[i-1] - (logand (* g y[j]) #xFFFFFFFF).
-;;;       Use %UNSIGNED-MULTIPLY taking low-order result.
-;;;    b = (logand (ash (* g y[j-1]) -32) #xFFFFFFFF).
-;;;    c = (logand (* g y[j-1]) #xFFFFFFFF).
-;;; if a < b, okay.
-;;; if a > b, guess is too high
-;;;    g = g - 1; go back to "check guess".
-;;; if a = b and c > x[i-2], guess is too high
-;;;    g = g - 1; go back to "check guess".
-;;; GUESS IS 32-BIT NUMBER, SO USE THING TO KEEP IN SPECIAL REGISTER
-;;; SAME FOR A, B, AND C.
-;;;
-;;; Subtract g * y from x[i - len-y+1]..x[i].  See paper for doing this in step.
-;;; If x[i] < 0, guess is fucked.
-;;;    negative g, then add 1
-;;;    zero or positive g, then subtract 1
-;;; AND add y back into x[len-y+1..i].
-;;;
-;;; q[k] = g.
-;;; i = i - 1.
-;;; k = k - 1.
-;;;
-;;; If k>=0, goto LOOP.
-;;;
-;;;
-;;; Now quotient is good, but remainder is not.
-;;; Shift x right by saved initial left shifting count.
-;;;
-;;; Check quotient and remainder signs.
-;;; x pos y pos --> q pos r pos
-;;; x pos y neg --> q neg r pos
-;;; x neg y pos --> q neg r neg
-;;; x neg y neg --> q pos r neg
-;;;
-;;; Normalize quotient and remainder.  Cons result if necessary.
-;;;
-
-
-
-;;; These are used by BIGNUM-TRUNCATE and friends in the general case.
-;;;
-(defvar *truncate-x*)
-(defvar *truncate-y*)
-
-;;; BIGNUM-TRUNCATE -- Public.
-;;;
-;;; This divides x by y returning the quotient and remainder.  In the general
-;;; case, we shift y to setup for the algorithm, and we use two buffers to save
-;;; consing intermediate values.  X gets destructively modified to become the
-;;; remainder, and we have to shift it to account for the initial Y shift.
-;;; After we multiple bind q and r, we first fix up the signs and then return
-;;; the normalized results.
-;;;
-(defun bignum-truncate (x y)
-  (declare (type bignum-type x y))
-  (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x)))
-	 (y-plusp (%bignum-0-or-plusp y (%bignum-length y)))
-	 (x (if x-plusp x (negate-bignum x nil)))
-	 (y (if y-plusp y (negate-bignum y nil)))
-	 (len-x (%bignum-length x))
-	 (len-y (%bignum-length y)))
-    (multiple-value-bind
-	(q r)
-	(cond ((< len-y 2)
-	       (bignum-truncate-single-digit x len-x y))
-	      ((plusp (bignum-compare y x))
-	       (let ((res (%allocate-bignum len-x)))
-		 (dotimes (i len-x)
-		   (setf (%bignum-ref res i) (%bignum-ref x i)))
-		 (values 0 res)))
-	      (t
-	       (let ((len-x+1 (1+ len-x)))
-		 (with-bignum-buffers ((*truncate-x* len-x+1)
-				       (*truncate-y* (1+ len-y)))
-		   (let ((y-shift (shift-y-for-truncate y)))
-		     (shift-and-store-truncate-buffers x len-x y len-y y-shift)
-		     (values (do-truncate len-x+1 len-y)
-			     ;; DO-TRUNCATE must execute first.
-			     (cond
-			      ((zerop y-shift)
-			       (let ((res (%allocate-bignum len-y)))
-				 (declare (type bignum-type res))
-				 (bignum-replace res *truncate-x* :end2 len-y)
-				 (%normalize-bignum res len-y)))
-			      (t
-			       (shift-right-unaligned
-				*truncate-x* 0 y-shift len-y
-				((= j res-len-1)
-				 (setf (%bignum-ref res j)
-				       (%ashr (%bignum-ref *truncate-x* i)
-					      y-shift))
-				 (%normalize-bignum res res-len))
-				res)))))))))
-      (let ((quotient (cond ((eq x-plusp y-plusp) q)
-			    ((typep q 'fixnum) (the fixnum (- q)))
-			    (t (negate-bignum-in-place q))))
-	    (rem (cond (x-plusp r)
-		       ((typep r 'fixnum) (the fixnum (- r)))
-		       (t (negate-bignum-in-place r)))))
-	(values (if (typep quotient 'fixnum)
-		    quotient
-		    (%normalize-bignum quotient (%bignum-length quotient)))
-		(if (typep rem 'fixnum)
-		    rem
-		    (%normalize-bignum rem (%bignum-length rem))))))))
-
-;;; BIGNUM-TRUNCATE-SINGLE-DIGIT -- Internal.
-;;;
-;;; This divides x by y when y is a single bignum digit.  BIGNUM-TRUNCATE fixes
-;;; up the quotient and remainder with respect to sign and normalization.
-;;;
-;;; We don't have to worry about shifting y to make its most significant digit
-;;; sufficiently large for %FLOOR to return 32-bit quantities for the q-digit
-;;; and r-digit.  If y is a single digit bignum, it is already large enough
-;;; for %FLOOR.  That is, it has some bits on pretty high in the digit.
-;;;
-(defun bignum-truncate-single-digit (x len-x y)
-  (declare (type bignum-index len-x))
-  (let ((q (%allocate-bignum len-x))
-	(r 0)
-	(y (%bignum-ref y 0)))
-    (declare (type bignum-element-type r y))
-    (do ((i (1- len-x) (1- i)))
-	((minusp i))
-      (multiple-value-bind (q-digit r-digit)
-			   (%floor r (%bignum-ref x i) y)
-	(declare (type bignum-element-type q-digit r-digit))
-	(setf (%bignum-ref q i) q-digit)
-	(setf r r-digit)))
-    (let ((rem (%allocate-bignum 1)))
-      (setf (%bignum-ref rem 0) r)
-      (values q rem))))
-
-;;; DO-TRUNCATE -- Internal.
-;;;
-;;; This divides *truncate-x* by *truncate-y*, and len-x and len-y tell us how
-;;; much of the buffers we care about.  TRY-BIGNUM-TRUNCATE-GUESS modifies
-;;; *truncate-x* on each interation, and this buffer becomes our remainder.
-;;;
-;;; *truncate-x* definitely has at least three digits, and it has one more than
-;;; *truncate-y*.  This keeps i, i-1, i-2, and low-x-digit happy.  Thanks to
-;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS.
-;;;
-(defun do-truncate (len-x len-y)
-  (declare (type bignum-index len-x len-y))
-  (let* ((len-q (- len-x len-y))
-	 ;; Add one for extra sign digit in case high bit is on.
-	 (q (%allocate-bignum (1+ len-q)))
-	 (k (1- len-q))
-	 (y1 (%bignum-ref *truncate-y* (1- len-y)))
-	 (y2 (%bignum-ref *truncate-y* (- len-y 2)))
-	 (i (1- len-x))
-	 (i-1 (1- i))
-	 (i-2 (1- i-1))
-	 (low-x-digit (- i len-y)))
-    (declare (type bignum-index len-q k i i-1 i-2 low-x-digit)
-	     (type bignum-element-type y1 y2))
-    (loop
-      (setf (%bignum-ref q k)
-	    (try-bignum-truncate-guess
-	     ;; This modifies *truncate-x*.  Must access elements each pass.
-	     (bignum-truncate-guess y1 y2
-				    (%bignum-ref *truncate-x* i)
-				    (%bignum-ref *truncate-x* i-1)
-				    (%bignum-ref *truncate-x* i-2))
-	     len-y low-x-digit))
-      (cond ((zerop k) (return))
-	    (t (decf k)
-	       (decf low-x-digit)
-	       (shiftf i i-1 i-2 (1- i-2)))))
-    q))
-
-;;; TRY-BIGNUM-TRUNCATE-GUESS -- Internal.
-;;;
-;;; This takes a digit guess, multiplies it by *truncate-y* for a result one
-;;; greater in length than len-y, and subtracts this result from *truncate-x*.
-;;; Low-x-digit is the first digit of x to start the subtraction, and we know x
-;;; is long enough to subtract a len-y plus one length bignum from it.  Next we
-;;; check the result of the subtraction, and if the high digit in x became
-;;; negative, then our guess was one too big.  In this case, return one less
-;;; than guess passed in, and add one value of y back into x to account for
-;;; subtracting one too many.  Knuth shows that the guess is wrong on the order
-;;; of 3/b, where b is the base (2 to the digit-size power) -- pretty rarely.
-;;;
-(defun try-bignum-truncate-guess (guess len-y low-x-digit)
-  (declare (type bignum-index low-x-digit len-y)
-	   (type bignum-element-type guess))
-  (let ((carry-digit 0)
-	(borrow 1)
-	(i low-x-digit))
-    (declare (type bignum-element-type carry-digit)
-	     (type bignum-index i)
-	     (fixnum borrow))
-    ;; Multiply guess and divisor, subtracting from dividend simultaneously.
-    (dotimes (j len-y)
-      (multiple-value-bind (high-digit low-digit)
-			   (%multiply-and-add guess (%bignum-ref *truncate-y* j)
-					      carry-digit)
-	(declare (type bignum-element-type high-digit low-digit))
-	(setf carry-digit high-digit)
-	(multiple-value-bind (x temp-borrow)
-			     (%subtract-with-borrow (%bignum-ref *truncate-x* i)
-						    low-digit borrow)
-	  (declare (type bignum-element-type x)
-		   (fixnum temp-borrow))
-	  (setf (%bignum-ref *truncate-x* i) x)
-	  (setf borrow temp-borrow)))
-      (incf i))
-    (setf (%bignum-ref *truncate-x* i)
-	  (%subtract-with-borrow (%bignum-ref *truncate-x* i)
-				 carry-digit borrow))
-    ;; See if guess is off by one, adding one Y back in if necessary.
-    (cond ((%digit-0-or-plusp (%bignum-ref *truncate-x* i))
-	   guess)
-	  (t
-	   ;; If subtraction has negative result, add one divisor value back
-	   ;; in.  The guess was one too large in magnitude.
-	   (let ((i low-x-digit)
-		 (carry 0))
-	     (dotimes (j len-y)
-	       (multiple-value-bind (v k)
-				    (%add-with-carry (%bignum-ref *truncate-y* j)
-						     (%bignum-ref *truncate-x* i)
-						     carry)
-		 (declare (type bignum-element-type v))
-		 (setf (%bignum-ref *truncate-x* i) v)
-		 (setf carry k))
-	       (incf i))
-	     (setf (%bignum-ref *truncate-x* i)
-		   (%add-with-carry (%bignum-ref *truncate-x* i) 0 carry)))
-	   (%subtract-with-borrow guess 1 1)))))
-
-;;; BIGNUM-TRUNCATE-GUESS -- Internal.
-;;;
-;;; This returns a guess for the next division step.  Y1 is the highest y
-;;; digit, and y2 is the second to highest y digit.  The x... variables are
-;;; the three highest x digits for the next division step.
-;;;
-;;; From Knuth, our guess is either all ones or x-i and x-i-1 divided by y1,
-;;; depending on whether x-i and y1 are the same.  We test this guess by
-;;; determining whether guess*y2 is greater than the three high digits of x
-;;; minus guess*y1 shifted left one digit:
-;;;    ------------------------------
-;;;   |    x-i    |   x-i-1  | x-i-2 |
-;;;    ------------------------------
-;;;    ------------------------------
-;;; - | g*y1 high | g*y1 low |   0   |
-;;;    ------------------------------
-;;;                ...                   <   guess*y2     ???
-;;; If guess*y2 is greater, then we decrement our guess by one and try again.
-;;; This returns a guess that is either correct or one too large.
-;;;
-(defun bignum-truncate-guess (y1 y2 x-i x-i-1 x-i-2)
-  (declare (type bignum-element-type y1 y2 x-i x-i-1 x-i-2))
-  (let ((guess (if (%digit-compare x-i y1)
-		   all-ones-digit
-		   (%floor x-i x-i-1 y1))))
-    (declare (type bignum-element-type guess))
-    (loop
-      (multiple-value-bind (high-guess*y1 low-guess*y1)
-			   (%multiply guess y1)
-	(declare (type bignum-element-type low-guess*y1 high-guess*y1))
-	(multiple-value-bind (high-guess*y2 low-guess*y2)
-			     (%multiply guess y2)
-	  (declare (type bignum-element-type high-guess*y2 low-guess*y2))
-	  (multiple-value-bind (middle-digit borrow)
-			       (%subtract-with-borrow x-i-1 low-guess*y1 1)
-	    (declare (type bignum-element-type middle-digit)
-		     (fixnum borrow))
-	    ;; Supplying borrow of 1 means there was no borrow, and we know
-	    ;; x-i-2 minus 0 requires no borrow.
-	    (let ((high-digit (%subtract-with-borrow x-i high-guess*y1 borrow)))
-	      (declare (type bignum-element-type high-digit))
-	      (if (and (%digit-compare high-digit 0)
-		       (or (%digit-greater high-guess*y2 middle-digit)
-			   (and (%digit-compare middle-digit high-guess*y2)
-				(%digit-greater low-guess*y2 x-i-2))))
-		  (setf guess (%subtract-with-borrow guess 1 1))
-		  (return guess)))))))))
-
-;;; SHIFT-Y-FOR-TRUNCATE -- Internal.
-;;;
-;;; This returns the amount to shift y to place a one in the second highest
-;;; bit.  Y must be positive.  If the last digit of y is zero, then y has a
-;;; one in the previous digit's sign bit, so we know it will take one less
-;;; than digit-size to get a one where we want.  Otherwise, we count how many
-;;; right shifts it takes to get zero; subtracting this value from digit-size
-;;; tells us how many high zeros there are which is one more than the shift
-;;; amount sought.
-;;;
-;;; Note: This is exactly the same as one less than the integer-length of the
-;;; last digit subtracted from the digit-size.
-;;; 
-;;; We shift y to make it sufficiently large that doing the 64-bit by 32-bit
-;;; %FLOOR calls ensures the quotient and remainder fit in 32-bits.
-;;;
-(defun shift-y-for-truncate (y)
-  (let* ((len (%bignum-length y))
-	 (last (%bignum-ref y (1- len))))
-    (declare (type bignum-index len)
-	     (type bignum-element-type last))
-    (- digit-size (integer-length last) 1)))
-
-;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS -- Internal.
-;;;
-;;; Stores two bignums into the truncation bignum buffers, shifting them on the
-;;; way in.  This assumes x and y are positive and at least two in length, and
-;;; it assumes *truncate-x* and *truncate-y* are one digit longer than x and y.
-;;;
-(defun shift-and-store-truncate-buffers (x len-x y len-y shift)
-  (declare (type bignum-index len-x len-y)
-	   (type (integer 0 (#.digit-size)) shift))
-  (cond ((zerop shift)
-	 (bignum-replace *truncate-x* x :end1 len-x)
-	 (bignum-replace *truncate-y* y :end1 len-y))
-	(t
-	 (bignum-ashift-left-unaligned x 0 shift (1+ len-x) *truncate-x*)
-	 (bignum-ashift-left-unaligned y 0 shift (1+ len-y) *truncate-y*))))
-
-
-
-;;;; %FLOOR primitive for BIGNUM-TRUNCATE.
-
-;;; When a machine leaves out a 64-bit by 32-bit divide instruction (that is,
-;;; two bignum-digits divided by one), we have to roll our own (the hard way).
-;;; Basically, we treat the operation as four 16-bit digits divided by two
-;;; 16-bit digits.  This means we have duplicated most of the code above to do
-;;; this nearly general 16-bit digit bignum divide, but we've unrolled loops
-;;; and made use of other properties of this specific divide situation.
-;;;
-
-
-;;;
-;;; %FLOOR for machines with a 32x32 divider.
-;;;
-
-(proclaim '(inline 32x16-subtract-with-borrow 32x16-add-with-carry
-		   32x16-divide 32x16-multiply 32x16-multiply-split))
-
-#+32x16-divide
-(defconstant 32x16-base-1 #xFFFF)
-
-;;; 32X16-SUBTRACT-WITH-BORROW -- Internal.	[optionally IN ASSEMBLER]
-;;;
-;;; This is similar to %SUBTRACT-WITH-BORROW.  It returns a 16-bit difference
-;;; and a borrow.  Returning a 1 for the borrow means there was no borrow, and
-;;; 0 means there was one.
-;;;
-#+32x16-divide
-(defun 32x16-subtract-with-borrow (a b borrow)
-  (declare (type (unsigned-byte 16) a b)
-	   (type (integer 0 1) borrow))
-  (let ((diff (+ (- a b) borrow 32x16-base-1)))
-    (declare (type (unsigned-byte 17) diff))
-    (values (logand diff #xFFFF)
-	    (ash diff -16))))
-
-;;; 32X16-ADD-WITH-CARRY -- Internal.		[optionally IN ASSEMBLER]
-;;;
-;;; This adds a and b, 16-bit quantities, with the carry k.  It returns a
-;;; 16-bit sum and a second value, 0 or 1, indicating whether there was a
-;;; carry.
-;;;
-#+32x16-divide
-(defun 32x16-add-with-carry (a b k)
-  (declare (type (unsigned-byte 16) a b)
-	   (type (integer 0 1) k))
-  (let ((res (the fixnum (+ a b k))))
-    (declare (type (unsigned-byte 17) res))
-    (if (zerop (the fixnum (logand #x10000 res)))
-	(values res 0)
-	(values (the (unsigned-byte 16) (logand #xFFFF res))
-		1))))
-
-;;; 32x16-DIVIDE  --  Internal		[IN ASSEMBLER]
-;;;
-;;; This is probably a 32-bit by 32-bit divide instruction.
-;;;
-#+32x16-divide
-(defun 32x16-divide (a b c)
-  (declare (type (unsigned-byte 16) a b c))
-  (floor (the bignum-element-type
-	      (logior (the bignum-element-type (ash a 16))
-		      b))
-	 c))
-
-;;; 32X16-MULTIPLY -- Internal.		[optionally IN ASSEMBLER]
-;;;
-;;; This basically exists since we know the answer won't overflow
-;;; bignum-element-type.  It's probably just a basic multiply instruction, but
-;;; it can't cons an intermediate bignum.  The result goes in a non-descriptor
-;;; register.
-;;;
-#+32x16-divide
-(defun 32x16-multiply (a b)
-  (declare (type (unsigned-byte 16) a b))
-  (the bignum-element-type (* a b)))
-
-;;; 32X16-MULTIPLY-SPLIT -- Internal.		[optionally IN ASSEMBLER]
-;;;
-;;; This multiplies a and b, 16-bit quantities, and returns the result as two
-;;; 16-bit quantities, high and low.
-;;;
-#+32x16-divide
-(defun 32x16-multiply-split (a b)
-  (let ((res (32x16-multiply a b)))
-    (declare (the bignum-element-type res))
-    (values (the (unsigned-byte 16) (logand #xFFFF (ash res -16)))
-	    (the (unsigned-byte 16) (logand #xFFFF res)))))
-
-
-
-;;; The %FLOOR below uses this buffer the same way BIGNUM-TRUNCATE uses
-;;; *truncate-x*.  There's no y buffer since we pass around the two 16-bit
-;;; digits and use them slightly differently than the general truncation
-;;; algorithm above.
-;;;
-#+32x16-divide
-(defvar *32x16-truncate-x* (make-array 4 :element-type '(unsigned-byte 16)
-				       :initial-element 0))
-
-;;; %FLOOR -- Internal.		LEFT IMPLEMENTED AT LISP LEVEL
-;;;
-;;; This does the same thing as the %FLOOR above, but it does it at Lisp level
-;;; when there is no 64x32-bit divide instruction on the machine.
-;;;
-;;; It implements the higher level tactics of BIGNUM-TRUNCATE, but it makes use
-;;; of special situation provided, four 16-bit digits divided by two 16-bit
-;;; digits.
-;;;
-#+32x16-divide
-(defun %floor (a b c)
-  (declare (type bignum-element-type a b c))
-  ;;
-  ;; Setup *32x16-truncate-x* buffer from a and b.
-  (setf (aref *32x16-truncate-x* 0)
-	(the (unsigned-byte 16) (logand #xFFFF b)))
-  (setf (aref *32x16-truncate-x* 1)
-	(the (unsigned-byte 16)
-	     (logand #xFFFF
-		     (the (unsigned-byte 16) (ash b -16)))))
-  (setf (aref *32x16-truncate-x* 2)
-	(the (unsigned-byte 16) (logand #xFFFF a)))
-  (setf (aref *32x16-truncate-x* 3)
-	(the (unsigned-byte 16)
-	     (logand #xFFFF
-		     (the (unsigned-byte 16) (ash a -16)))))
-  ;;
-  ;; From DO-TRUNCATE, but unroll the loop.
-  (let* ((y1 (logand #xFFFF (ash c -16)))
-	 (y2 (logand #xFFFF c))
-	 (q (the bignum-element-type
-		 (ash (32x16-try-bignum-truncate-guess
-		       (32x16-truncate-guess y1 y2
-					     (aref *32x16-truncate-x* 3)
-					     (aref *32x16-truncate-x* 2)
-					     (aref *32x16-truncate-x* 1))
-		       y1 y2 1)
-		      16))))
-    (declare (type bignum-element-type q)
-	     (type (unsigned-byte 16) y1 y2))
-    (values (the bignum-element-type
-		 (logior q
-			 (the (unsigned-byte 16)
-			      (32x16-try-bignum-truncate-guess
-			       (32x16-truncate-guess
-				y1 y2
-				(aref *32x16-truncate-x* 2)
-				(aref *32x16-truncate-x* 1)
-				(aref *32x16-truncate-x* 0))
-			       y1 y2 0))))
-	    (the bignum-element-type
-		 (logior (the bignum-element-type
-			      (ash (aref *32x16-truncate-x* 1) 16))
-			 (the (unsigned-byte 16)
-			      (aref *32x16-truncate-x* 0)))))))
-
-;;; 32X16-TRY-BIGNUM-TRUNCATE-GUESS  --  Internal.
-;;;
-;;; This is similar to TRY-BIGNUM-TRUNCATE-GUESS, but this unrolls the two
-;;; loops.  This also substitutes for %DIGIT-0-OR-PLUSP the equivalent
-;;; expression without any embellishment or pretense of abstraction.  The first
-;;; loop is unrolled, but we've put the body of the loop into the function
-;;; 32X16-TRY-GUESS-ONE-RESULT-DIGIT.
-;;;
-#+32x16-divide
-(defun 32x16-try-bignum-truncate-guess (guess y-high y-low low-x-digit)
-  (declare (type bignum-index low-x-digit)
-	   (type (unsigned-byte 16) guess y-high y-low))
-  (let ((high-x-digit (+ 2 low-x-digit)))
-    ;;
-    ;; Multiply guess and divisor, subtracting from dividend simultaneously.
-    (multiple-value-bind
-	(guess*y-hold carry borrow)
-	(32x16-try-guess-one-result-digit guess y-low 0 0 1 low-x-digit)
-      (declare (type (unsigned-byte 16) guess*y-hold)
-	       (fixnum carry borrow))
-      (multiple-value-bind
-	  (guess*y-hold carry borrow)
-	  (32x16-try-guess-one-result-digit guess y-high guess*y-hold
-					    carry borrow (1+ low-x-digit))
-	(declare (type (unsigned-byte 16) guess*y-hold)
-		 (fixnum borrow)
-		 (ignore carry))
-	(setf (aref *32x16-truncate-x* high-x-digit)
-	      (32x16-subtract-with-borrow (aref *32x16-truncate-x* high-x-digit)
-					  guess*y-hold borrow))))
-    ;;
-    ;; See if guess is off by one, adding one Y back in if necessary.
-    (cond ((zerop (logand #x8000 (aref *32x16-truncate-x* high-x-digit)))
-	   ;; The subtraction result is zero or positive.
-	   guess)
-	  (t
-	   ;; If subtraction has negative result, add one divisor value back in.
-	   ;; The guess was one two large in magnitude.
-	   (multiple-value-bind (v carry)
-				(32x16-add-with-carry y-low
-						      (aref *32x16-truncate-x*
-							    low-x-digit)
-						      0)
-	     (declare (type (unsigned-byte 16) v))
-	     (setf (aref *32x16-truncate-x* low-x-digit) v)
-	     (multiple-value-bind (v carry)
-				  (32x16-add-with-carry y-high
-							(aref *32x16-truncate-x*
-							      (1+ low-x-digit))
-							carry)
-	       (setf (aref *32x16-truncate-x* (1+ low-x-digit)) v)
-	       (setf (aref *32x16-truncate-x* high-x-digit)
-		     (32x16-add-with-carry (aref *32x16-truncate-x* high-x-digit)
-					   carry 0))))
-	   (if (zerop (logand #x8000 guess))
-	       (1- guess)
-	       (1+ guess))))))
-
-;;; 32X16-TRY-GUESS-ONE-RESULT-DIGIT -- Internal.
-;;;
-;;; This is similar to the body of the loop in TRY-BIGNUM-TRUNCATE-GUESS that
-;;; multiplies the guess by y and subtracts the result from x simultaneously.
-;;; This returns the digit remembered as part of the multiplication, the carry
-;;; from additions done on behalf of the multiplication, and the borrow from
-;;; doing the subtraction.
-;;;
-#+32x16-divide
-(defun 32x16-try-guess-one-result-digit (guess y-digit guess*y-hold
-					 carry borrow x-index)
-  (multiple-value-bind (high-digit low-digit)
-		       (32x16-multiply-split guess y-digit)
-    (declare (type (unsigned-byte 16) high-digit low-digit))
-    (multiple-value-bind (low-digit temp-carry)
-			 (32x16-add-with-carry low-digit guess*y-hold carry)
-      (declare (type (unsigned-byte 16) low-digit))
-      (multiple-value-bind (high-digit temp-carry)
-			   (32x16-add-with-carry high-digit temp-carry 0)
-	(declare (type (unsigned-byte 16) high-digit))
-	(multiple-value-bind (x temp-borrow)
-			     (32x16-subtract-with-borrow
-			      (aref *32x16-truncate-x* x-index)
-			      low-digit borrow)
-	  (declare (type (unsigned-byte 16) x))
-	  (setf (aref *32x16-truncate-x* x-index) x)
-	  (values high-digit temp-carry temp-borrow))))))
-
-;;; 32X16-TRUNCATE-GUESS -- Internal.
-;;;
-;;; This is similar to BIGNUM-TRUNCATE-GUESS, but instead of computing the
-;;; guess exactly as described in the its comments (digit by digit), this
-;;; massages the 16-bit quantities into 32-bit quantities and performs the
-;;; 
-#+32x16-divide
-(defun 32x16-truncate-guess (y1 y2 x-i x-i-1 x-i-2)
-  (declare (type (unsigned-byte 16) y1 y2 x-i x-i-1 x-i-2))
-  (let ((guess (if (= x-i y1)
-		   #xFFFF
-		   (32x16-divide x-i x-i-1 y1))))
-    (declare (type (unsigned-byte 16) guess))
-    (loop
-      (let* ((guess*y1 (the bignum-element-type
-			    (ash (logand #xFFFF
-					 (the bignum-element-type
-					      (32x16-multiply guess y1)))
-				 16)))
-	     (x-y (%subtract-with-borrow
-		   (the bignum-element-type
-			(logior (the bignum-element-type
-				     (ash x-i-1 16))
-				x-i-2))
-		   guess*y1
-		   1))
-	     (guess*y2 (the bignum-element-type (%multiply guess y2))))
-	(declare (type bignum-element-type guess*y1 x-y guess*y2))
-	(if (%digit-greater guess*y2 x-y)
-	    (decf guess)
-	    (return guess))))))
-
-
-;;;; General utilities.
-
-;;; MAKE-SMALL-BIGNUM -- Public.
-;;;
-;;; Allocate a single word bignum that holds fixnum.  This is useful when
-;;; we are trying to mix fixnum and bignum operands.
-;;; 
-(proclaim '(inline make-small-bignum))
-(defun make-small-bignum (fixnum)
-  (let ((res (%allocate-bignum 1)))
-    (setf (%bignum-ref res 0) (%fixnum-to-digit fixnum))
-    res))
-
-;;; %NORMALIZE-BIGNUM-BUFFER -- Internal.
-;;;
-;;; Internal in-place operations use this to fixup remaining digits in the
-;;; incoming data, such as in-place shifting.  This is basically the same as
-;;; the first form in %NORMALIZE-BIGNUM, but we return the length of the buffer
-;;; instead of shrinking the bignum.
-;;;
-#+nil(proclaim '(ext:maybe-inline %normalize-bignum-buffer))
-(defun %normalize-bignum-buffer (result len)
-  (declare (type bignum-type result)
-	   (type bignum-index len))
-  (unless (= len 1)
-    (do ((next-digit (%bignum-ref result (- len 2))
-		     (%bignum-ref result (- len 2)))
-	 (sign-digit (%bignum-ref result (1- len)) next-digit))
-	((not (zerop (logxor sign-digit (%ashr next-digit (1- digit-size))))))
-      (when (= (decf len) 1)
-	(return))
-      (setf (%bignum-ref result len) 0)))
-  len)
-
-;;; %NORMALIZE-BIGNUM -- Internal.
-;;;
-;;; This drops the last digit if it is unnecessary sign information.  It
-;;; repeats this as needed, possibly ending with a fixnum.  If the resulting
-;;; length from shrinking is one, see if our one word is a fixnum.  Shift the
-;;; possible fixnum bits completely out of the word, and compare this with
-;;; shifting the sign bit all the way through.  If the bits are all 1's or 0's
-;;; in both words, then there are just sign bits between the fixnum bits and
-;;; the sign bit.  If we do have a fixnum, shift it over for the two low-tag
-;;; bits.
-;;;
-(defun %normalize-bignum (result len)
-  (declare (type bignum-type result)
-	   (type bignum-index len)
-	   #+nil(inline %normalize-bignum-buffer))
-  (let ((newlen (%normalize-bignum-buffer result len)))
-    (declare (type bignum-index newlen))
-    (unless (= newlen len)
-      (%bignum-set-length result newlen))
-    (if (= newlen 1)
-	(let ((digit (%bignum-ref result 0)))
-	  (if (= (%ashr digit 29) (%ashr digit (1- digit-size)))
-	      (%fixnum-digit-with-correct-sign digit)
-	      result))
-	result)))
-
-;;; %MOSTLY-NORMALIZE-BIGNUM -- Internal.
-;;;
-;;; This drops the last digit if it is unnecessary sign information.  It
-;;; repeats this as needed, possibly ending with a fixnum magnitude but never
-;;; returning a fixnum.
-;;;
-(defun %mostly-normalize-bignum (result len)
-  (declare (type bignum-type result)
-	   (type bignum-index len)
-	   #+nil(inline %normalize-bignum-buffer))
-  (let ((newlen (%normalize-bignum-buffer result len)))
-    (declare (type bignum-index newlen))
-    (unless (= newlen len)
-      (%bignum-set-length result newlen))
-    result))
diff --git a/code/bit-bash.lisp b/code/bit-bash.lisp
deleted file mode 100644
index 868d37d424ebd01f0abfe71ec6e1d3ae5d7b8b5a..0000000000000000000000000000000000000000
--- a/code/bit-bash.lisp
+++ /dev/null
@@ -1,518 +0,0 @@
-;;; -*- Log: code.log; Package: VM -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bit-bash.lisp,v 1.16 1992/07/31 17:50:18 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Functions to implement bit bashing.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "VM")
-
-
-
-;;;; Constants and Types.
-
-
-(eval-when (compile load eval)
-
-(defconstant unit-bits vm:word-bits
-  "The number of bits to process at a time.")
-
-(defconstant max-bits (ash most-positive-fixnum -2)
-  "The maximum number of bits that can be delt with during a single call.")
-
-
-(deftype unit ()
-  `(unsigned-byte ,unit-bits))
-
-(deftype offset ()
-  `(integer 0 ,max-bits))
-
-(deftype bit-offset ()
-  `(integer 0 (,unit-bits)))
-
-(deftype bit-count ()
-  `(integer 1 (,unit-bits)))
-
-(deftype word-offset ()
-  `(integer 0 (,(ceiling max-bits unit-bits))))
-
-
-); eval-when
-
-
-
-;;;; Support routines.
-
-;;; A particular implementation must offer either VOPs to translate these, or
-;;; deftransforms to convert them into something supported by the architecture.
-;;;
-(macrolet ((frob (name &rest args)
-	     `(defun ,name ,args
-		(,name ,@args))))
-  (frob 32bit-logical-not x)
-  (frob 32bit-logical-and x y)
-  (frob 32bit-logical-or x y)
-  (frob 32bit-logical-xor x y)
-  (frob 32bit-logical-nor x y)
-  (frob 32bit-logical-eqv x y)
-  (frob 32bit-logical-nand x y)
-  (frob 32bit-logical-andc1 x y)
-  (frob 32bit-logical-andc2 x y)
-  (frob 32bit-logical-orc1 x y)
-  (frob 32bit-logical-orc2 x y))
-
-
-(eval-when (compile eval)
-  (defmacro byte-order-dispatch (big-endian little-endian)
-    (ecase (c:backend-byte-order c:*target-backend*)
-      (:big-endian big-endian)
-      (:little-endian little-endian))))
-
-(defun shift-towards-start (number count)
-  "Shift NUMBER by COUNT bits, adding zero bits at the ``end'' and removing
-  bits from the ``start.''  On big-endian machines this is a left-shift and
-  on little-endian machines this is a right-shift.  Note: only the low 5 bits
-  of count are significant."
-  (declare (type unit number) (fixnum count))
-  (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
-    (declare (type bit-offset count))
-    (if (zerop count)
-	number
-	(byte-order-dispatch
-	 (ash (ldb (byte (- unit-bits count) 0) number) count)
-	 (ash number (- count))))))
-
-(defun shift-towards-end (number count)
-  "Shift NUMBER by COUNT bits, adding zero bits at the ``start'' and removing
-  bits from the ``end.''  On big-endian machines this is a right-shift and
-  on little-endian machines this is a left-shift."
-  (declare (type unit number) (fixnum count))
-  (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
-    (declare (type bit-offset count))
-    (if (zerop count)
-	number
-	(byte-order-dispatch
-	 (ash number (- count))
-	 (ash (ldb (byte (- unit-bits count) 0) number) count)))))
-
-(proclaim '(inline start-mask end-mask fix-sap-and-offset))
-(defun start-mask (count)
-  "Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for
-  the remaining ``end'' bits.  Only the lower 5 bits of COUNT are significant."
-  (declare (fixnum count))
-  (shift-towards-start (1- (ash 1 unit-bits)) (- count)))
-
-(defun end-mask (count)
-  "Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for
-  the remaining ``start'' bits.  Only the lower 5 bits of COUNT are
-  significant."
-  (declare (fixnum count))
-  (shift-towards-end (1- (ash 1 unit-bits)) (- count)))
-
-(defun fix-sap-and-offset (sap offset)
-  "Align the SAP to a word boundry, and update the offset accordingly."
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (values system-area-pointer index))
-  (let ((address (sap-int sap)))
-    (values (int-sap (32bit-logical-andc2 address 3))
-	    (+ (* (logand address 3) byte-bits) offset))))
-
-(declaim (inline word-sap-ref %set-word-sap-ref))
-;;;
-(defun word-sap-ref (sap offset)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (values (unsigned-byte 32))
-	   (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
-  (sap-ref-32 sap (the index (ash offset 2))))
-;;;
-(defun %set-word-sap-ref (sap offset value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type (unsigned-byte 32) value)
-	   (values (unsigned-byte 32))
-	   (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
-  (setf (sap-ref-32 sap (the index (ash offset 2))) value))
-;;;
-(defsetf word-sap-ref %set-word-sap-ref)
-
-
-
-;;;; DO-CONSTANT-BIT-BASH
-
-(proclaim '(inline do-constant-bit-bash))
-(defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
-  "Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits."
-  (declare (type offset dst-offset) (type unit value)
-	   (type function dst-ref-fn dst-set-fn))
-  (multiple-value-bind (dst-word-offset dst-bit-offset)
-		       (floor dst-offset unit-bits)
-    (declare (type word-offset dst-word-offset)
-	     (type bit-offset dst-bit-offset))
-    (multiple-value-bind (words final-bits)
-			 (floor (+ dst-bit-offset length) unit-bits)
-      (declare (type word-offset words) (type bit-offset final-bits))
-      (if (zerop words)
-	  (unless (zerop length)
-	    (funcall dst-set-fn dst dst-word-offset
-		     (if (= length unit-bits)
-			 value
-			 (let ((mask (shift-towards-end (start-mask length)
-							dst-bit-offset)))
-			   (declare (type unit mask))
-			   (32bit-logical-or
-			    (32bit-logical-and value mask)
-			    (32bit-logical-andc2
-			     (funcall dst-ref-fn dst dst-word-offset)
-			     mask))))))
-	  (let ((interior (floor (- length final-bits) unit-bits)))
-	    (unless (zerop dst-bit-offset)
-	      (let ((mask (end-mask (- dst-bit-offset))))
-		(declare (type unit mask))
-		(funcall dst-set-fn dst dst-word-offset
-			 (32bit-logical-or
-			  (32bit-logical-and value mask)
-			  (32bit-logical-andc2
-			   (funcall dst-ref-fn dst dst-word-offset)
-			   mask))))
-	      (incf dst-word-offset))
-	    (dotimes (i interior)
-	      (funcall dst-set-fn dst dst-word-offset value)
-	      (incf dst-word-offset))
-	    (unless (zerop final-bits)
-	      (let ((mask (start-mask final-bits)))
-		(declare (type unit mask))
-		(funcall dst-set-fn dst dst-word-offset
-			 (32bit-logical-or
-			  (32bit-logical-and value mask)
-			  (32bit-logical-andc2
-			   (funcall dst-ref-fn dst dst-word-offset)
-			   mask)))))))))
-  (undefined-value))
-
-
-;;;; DO-UNARY-BIT-BASH
-
-(proclaim '(inline do-unary-bit-bash))
-(defun do-unary-bit-bash (src src-offset dst dst-offset length
-			      dst-ref-fn dst-set-fn src-ref-fn)
-  (declare (type offset src-offset dst-offset length)
-	   (type function dst-ref-fn dst-set-fn src-ref-fn))
-  (multiple-value-bind (dst-word-offset dst-bit-offset)
-		       (floor dst-offset unit-bits)
-    (declare (type word-offset dst-word-offset)
-	     (type bit-offset dst-bit-offset))
-    (multiple-value-bind (src-word-offset src-bit-offset)
-			 (floor src-offset unit-bits)
-      (declare (type word-offset src-word-offset)
-	       (type bit-offset src-bit-offset))
-      (cond
-       ((<= (+ dst-bit-offset length) unit-bits)
-	;; We are only writing one word, so it doesn't matter what order
-	;; we do it in.  But we might be reading from multiple words, so take
-	;; care.
-	(cond
-	 ((zerop length)
-	  ;; Actually, we arn't even writing one word.  This is real easy.
-	  )
-	 ((= length unit-bits)
-	  ;; dst-bit-offset must be equal to zero, or we would be writing
-	  ;; multiple words.  If src-bit-offset is also zero, then we
-	  ;; just transfer the single word.  Otherwise we have to extract bits
-	  ;; from two src words.
-	  (funcall dst-set-fn dst dst-word-offset
-		   (if (zerop src-bit-offset)
-		       (funcall src-ref-fn src src-word-offset)
-		       (32bit-logical-or
-			(shift-towards-start
-			 (funcall src-ref-fn src src-word-offset)
-			 src-bit-offset)
-			(shift-towards-end
-			 (funcall src-ref-fn src (1+ src-word-offset))
-			 (- src-bit-offset))))))
-	 (t
-	  ;; We are only writing some portion of the dst word, so we need to
-	  ;; preserve the extra bits.  Also, we still don't know if we need
-	  ;; one or two source words.
-	  (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
-		(orig (funcall dst-ref-fn dst dst-word-offset))
-		(value
-		 (if (> src-bit-offset dst-bit-offset)
-		     ;; The source starts further into the word than does
-		     ;; the dst, so the source could extend into the next
-		     ;; word.  If it does, we have to merge the two words,
-		     ;; and if not, we can just shift the first word.
-		     (let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
-		       (if (> (+ src-bit-offset length) unit-bits)
-			   (32bit-logical-or
-			    (shift-towards-start
-			     (funcall src-ref-fn src src-word-offset)
-			     src-bit-shift)
-			    (shift-towards-end
-			     (funcall src-ref-fn src (1+ src-word-offset))
-			     (- src-bit-shift)))
-			   (shift-towards-start
-			    (funcall src-ref-fn src src-word-offset)
-			    src-bit-shift)))
-		     ;; The dst starts further into the word than does the
-		     ;; source, so we know the source can not extend into
-		     ;; a second word (or else the dst would too, and we
-		     ;; wouldn't be in this branch.
-		     (shift-towards-end
-		      (funcall src-ref-fn src src-word-offset)
-		      (- dst-bit-offset src-bit-offset)))))
-	    (declare (type unit mask orig value))
-	    ;; Replace the dst word.
-	    (funcall dst-set-fn dst dst-word-offset
-		     (32bit-logical-or
-		      (32bit-logical-and value mask)
-		      (32bit-logical-andc2 orig mask)))))))
-       ((= src-bit-offset dst-bit-offset)
-	;; The source and dst are aligned, so we don't need to shift
-	;; anything.  But we have to pick the direction of the loop
-	;; in case the source and dst are really the same thing.
-	(multiple-value-bind (words final-bits)
-			     (floor (+ dst-bit-offset length) unit-bits)
-	  (declare (type word-offset words) (type bit-offset final-bits))
-	  (let ((interior (floor (- length final-bits) unit-bits)))
-	    (declare (type word-offset interior))
-	    (cond
-	     ((<= dst-offset src-offset)
-	      ;; We need to loop from left to right
-	      (unless (zerop dst-bit-offset)
-		;; We are only writing part of the first word, so mask off the
-		;; bits we want to preserve.
-		(let ((mask (end-mask (- dst-bit-offset)))
-		      (orig (funcall dst-ref-fn dst dst-word-offset))
-		      (value (funcall src-ref-fn src src-word-offset)))
-		  (declare (type unit mask orig value))
-		  (funcall dst-set-fn dst dst-word-offset
-			   (32bit-logical-or (32bit-logical-and value mask)
-					     (32bit-logical-andc2 orig mask))))
-		(incf src-word-offset)
-		(incf dst-word-offset))
-	      ;; Just copy the interior words.
-	      (dotimes (i interior)
-		(funcall dst-set-fn dst dst-word-offset
-			 (funcall src-ref-fn src src-word-offset))
-		(incf src-word-offset)
-		(incf dst-word-offset))
-	      (unless (zerop final-bits)
-		;; We are only writing part of the last word.
-		(let ((mask (start-mask final-bits))
-		      (orig (funcall dst-ref-fn dst dst-word-offset))
-		      (value (funcall src-ref-fn src src-word-offset)))
-		  (declare (type unit mask orig value))
-		  (funcall dst-set-fn dst dst-word-offset
-			   (32bit-logical-or
-			    (32bit-logical-and value mask)
-			    (32bit-logical-andc2 orig mask))))))
-	     (t
-	      ;; We need to loop from right to left.
-	      (incf dst-word-offset words)
-	      (incf src-word-offset words)
-	      (unless (zerop final-bits)
-		(let ((mask (start-mask final-bits))
-		      (orig (funcall dst-ref-fn dst dst-word-offset))
-		      (value (funcall src-ref-fn src src-word-offset)))
-		  (declare (type unit mask orig value))
-		  (funcall dst-set-fn dst dst-word-offset
-			   (32bit-logical-or
-			    (32bit-logical-and value mask)
-			    (32bit-logical-andc2 orig mask)))))
-	      (dotimes (i interior)
-		(decf src-word-offset)
-		(decf dst-word-offset)
-		(funcall dst-set-fn dst dst-word-offset
-			 (funcall src-ref-fn src src-word-offset)))
-	      (unless (zerop dst-bit-offset)
-		(decf src-word-offset)
-		(decf dst-word-offset)
-		(let ((mask (end-mask (- dst-bit-offset)))
-		      (orig (funcall dst-ref-fn dst dst-word-offset))
-		      (value (funcall src-ref-fn src src-word-offset)))
-		  (declare (type unit mask orig value))
-		  (funcall dst-set-fn dst dst-word-offset
-			   (32bit-logical-or
-			    (32bit-logical-and value mask)
-			    (32bit-logical-andc2 orig mask))))))))))
-       (t
-	;; They arn't aligned.
-	(multiple-value-bind (words final-bits)
-			     (floor (+ dst-bit-offset length) unit-bits)
-	  (declare (type word-offset words) (type bit-offset final-bits))
-	  (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits))
-		(interior (floor (- length final-bits) unit-bits)))
-	    (declare (type bit-offset src-shift)
-		     (type word-offset interior))
-	    (cond
-	     ((<= dst-offset src-offset)
-	      ;; We need to loop from left to right
-	      (let ((prev 0)
-		    (next (funcall src-ref-fn src src-word-offset)))
-		(declare (type unit prev next))
-		(flet ((get-next-src ()
-			 (setf prev next)
-			 (setf next (funcall src-ref-fn src
-					     (incf src-word-offset)))))
-		  (declare (inline get-next-src))
-		  (unless (zerop dst-bit-offset)
-		    (when (> src-bit-offset dst-bit-offset)
-		      (get-next-src))
-		    (let ((mask (end-mask (- dst-bit-offset)))
-			  (orig (funcall dst-ref-fn dst dst-word-offset))
-			  (value (32bit-logical-or
-				  (shift-towards-start prev src-shift)
-				  (shift-towards-end next (- src-shift)))))
-		      (declare (type unit mask orig value))
-		      (funcall dst-set-fn dst dst-word-offset
-			       (32bit-logical-or
-				(32bit-logical-and value mask)
-				(32bit-logical-andc2 orig mask)))
-		      (incf dst-word-offset)))
-		  (dotimes (i interior)
-		    (get-next-src)
-		    (let ((value (32bit-logical-or
-				  (shift-towards-end next (- src-shift))
-				  (shift-towards-start prev src-shift))))
-		      (declare (type unit value))
-		      (funcall dst-set-fn dst dst-word-offset value)
-		      (incf dst-word-offset)))
-		  (unless (zerop final-bits)
-		    (let ((value
-			   (if (> (+ final-bits src-shift) unit-bits)
-			       (progn
-				 (get-next-src)
-				 (32bit-logical-or
-				  (shift-towards-end next (- src-shift))
-				  (shift-towards-start prev src-shift)))
-			       (shift-towards-start next src-shift)))
-			  (mask (start-mask final-bits))
-			  (orig (funcall dst-ref-fn dst dst-word-offset)))
-		      (declare (type unit mask orig value))
-		      (funcall dst-set-fn dst dst-word-offset
-			       (32bit-logical-or
-				(32bit-logical-and value mask)
-				(32bit-logical-andc2 orig mask))))))))
-	     (t
-	      ;; We need to loop from right to left.
-	      (incf dst-word-offset words)
-	      (incf src-word-offset
-		    (1- (ceiling (+ src-bit-offset length) unit-bits)))
-	      (let ((next 0)
-		    (prev (funcall src-ref-fn src src-word-offset)))
-		(declare (type unit prev next))
-		(flet ((get-next-src ()
-		       (setf next prev)
-		       (setf prev (funcall src-ref-fn src
-					   (decf src-word-offset)))))
-		  (declare (inline get-next-src))
-		  (unless (zerop final-bits)
-		    (when (> final-bits (- unit-bits src-shift))
-		      (get-next-src))
-		    (let ((value (32bit-logical-or
-				  (shift-towards-end next (- src-shift))
-				  (shift-towards-start prev src-shift)))
-			  (mask (start-mask final-bits))
-			  (orig (funcall dst-ref-fn dst dst-word-offset)))
-		      (declare (type unit mask orig value))
-		      (funcall dst-set-fn dst dst-word-offset
-			       (32bit-logical-or
-				(32bit-logical-and value mask)
-				(32bit-logical-andc2 orig mask)))))
-		  (decf dst-word-offset)
-		  (dotimes (i interior)
-		    (get-next-src)
-		    (let ((value (32bit-logical-or
-				  (shift-towards-end next (- src-shift))
-				  (shift-towards-start prev src-shift))))
-		      (declare (type unit value))
-		      (funcall dst-set-fn dst dst-word-offset value)
-		      (decf dst-word-offset)))
-		  (unless (zerop dst-bit-offset)
-		    (if (> src-bit-offset dst-bit-offset)
-			(get-next-src)
-			(setf next prev prev 0))
-		    (let ((mask (end-mask (- dst-bit-offset)))
-			  (orig (funcall dst-ref-fn dst dst-word-offset))
-			  (value (32bit-logical-or
-				  (shift-towards-start prev src-shift)
-				  (shift-towards-end next (- src-shift)))))
-		      (declare (type unit mask orig value))
-		      (funcall dst-set-fn dst dst-word-offset
-			       (32bit-logical-or
-				(32bit-logical-and value mask)
-				(32bit-logical-andc2 orig mask)))))))))))))))
-  (undefined-value))
-
-
-;;;; The actual bashers.
-
-(defun bit-bash-fill (value dst dst-offset length)
-  (declare (type unit value) (type offset dst-offset length))
-  (locally
-   (declare (optimize (speed 3) (safety 0)))
-   (do-constant-bit-bash dst dst-offset length value
-			 #'%raw-bits #'%set-raw-bits)))
-
-(defun system-area-fill (value dst dst-offset length)
-  (declare (type unit value) (type offset dst-offset length))
-  (locally
-   (declare (optimize (speed 3) (safety 0)))
-   (multiple-value-bind (dst dst-offset)
-			(fix-sap-and-offset dst dst-offset)
-     (do-constant-bit-bash dst dst-offset length value
-			   #'word-sap-ref #'%set-word-sap-ref))))
-
-(defun bit-bash-copy (src src-offset dst dst-offset length)
-  (declare (type offset src-offset dst-offset length))
-  (locally
-   (declare (optimize (speed 3) (safety 0))
-	    (inline do-unary-bit-bash))
-   (do-unary-bit-bash src src-offset dst dst-offset length
-		      #'%raw-bits #'%set-raw-bits #'%raw-bits)))
-
-(defun system-area-copy (src src-offset dst dst-offset length)
-  (declare (type offset src-offset dst-offset length))
-  (locally
-   (declare (optimize (speed 3) (safety 0)))
-   (multiple-value-bind (src src-offset)
-			(fix-sap-and-offset src src-offset)
-     (declare (type system-area-pointer src))
-     (multiple-value-bind (dst dst-offset)
-			  (fix-sap-and-offset dst dst-offset)
-       (declare (type system-area-pointer dst))
-       (do-unary-bit-bash src src-offset dst dst-offset length
-			  #'word-sap-ref #'%set-word-sap-ref
-			  #'word-sap-ref)))))
-
-(defun copy-to-system-area (src src-offset dst dst-offset length)
-  (declare (type offset src-offset dst-offset length))
-  (locally
-   (declare (optimize (speed 3) (safety 0)))
-   (multiple-value-bind (dst dst-offset)
-			(fix-sap-and-offset dst dst-offset)
-     (do-unary-bit-bash src src-offset dst dst-offset length
-			#'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
-
-(defun copy-from-system-area (src src-offset dst dst-offset length)
-  (declare (type offset src-offset dst-offset length))
-  (locally
-   (declare (optimize (speed 3) (safety 0)))
-   (multiple-value-bind (src src-offset)
-			(fix-sap-and-offset src src-offset)
-     (do-unary-bit-bash src src-offset dst dst-offset length
-			#'%raw-bits #'%set-raw-bits #'word-sap-ref))))
-  
diff --git a/code/byte-interp.lisp b/code/byte-interp.lisp
deleted file mode 100644
index a53ce11b954a552bea71b14395dd432d848ab97f..0000000000000000000000000000000000000000
--- a/code/byte-interp.lisp
+++ /dev/null
@@ -1,1423 +0,0 @@
-;;; -*- Package: C -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.3 1992/09/07 16:10:36 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the noise to interpret byte-compiled stuff.
-;;;
-;;; Written by William Lott
-;;;
-
-(in-package "C")
-
-
-
-;;;; Types.
-
-(deftype stack-pointer ()
-  `(integer 0 ,(1- most-positive-fixnum)))
-
-(defconstant max-pc (1- (ash 1 24)))
-
-(deftype pc ()
-  `(integer 0 ,max-pc))
-
-(deftype return-pc ()
-  `(integer ,(- max-pc) ,max-pc))
-
-
-
-;;;; The stack.
-
-(declaim (inline current-stack-pointer))
-(defun current-stack-pointer ()
-  (declare (values stack-pointer))
-  *eval-stack-top*)
-
-(declaim (inline (setf current-stack-pointer)))
-(defun (setf current-stack-pointer) (new-value)
-  (declare (type stack-pointer new-value)
-	   (values stack-pointer))
-  (setf *eval-stack-top* new-value))
-
-(declaim (inline eval-stack-ref))
-(defun eval-stack-ref (offset)
-  (declare (type stack-pointer offset))
-  (svref eval::*eval-stack* offset))
-
-(declaim (inline (setf eval-stack-ref)))
-(defun (setf eval-stack-ref) (new-value offset)
-  (declare (type stack-pointer offset))
-  (setf (svref eval::*eval-stack* offset) new-value))
-
-(defun push-eval-stack (value)
-  (let ((len (length (the simple-vector eval::*eval-stack*)))
-	(sp (current-stack-pointer)))
-    (when (= len sp)
-      (let ((new-stack (make-array (ash len 1))))
-	(replace new-stack eval::*eval-stack* :end1 len :end2 len)
-	(setf eval::*eval-stack* new-stack)))
-    (setf (current-stack-pointer) (1+ sp))
-    (setf (eval-stack-ref sp) value)))
-
-(defun pop-eval-stack ()
-  (let* ((new-sp (1- (current-stack-pointer)))
-	 (value (eval-stack-ref new-sp)))
-    (setf (current-stack-pointer) new-sp)
-    value))
-
-(defmacro multiple-value-pop-eval-stack ((&rest vars) &body body)
-  (declare (optimize (inhibit-warnings 3)))
-  (let ((num-vars (length vars))
-	(index -1)
-	(new-sp-var (gensym "NEW-SP-"))
-	(decls nil))
-    (loop
-      (unless (and (consp body) (consp (car body)) (eq (caar body) 'declare))
-	(return))
-      (push (pop body) decls))
-    `(let ((,new-sp-var (- (current-stack-pointer) ,num-vars)))
-       (declare (type stack-pointer ,new-sp-var))
-       (let ,(mapcar #'(lambda (var)
-			 `(,var (eval-stack-ref
-				 (+ ,new-sp-var ,(incf index)))))
-		     vars)
-	 ,@(nreverse decls)
-	 (setf (current-stack-pointer) ,new-sp-var)
-	 ,@body))))
-
-(defun stack-copy (dest src count)
-  (declare (type stack-pointer dest src count))
-  (dotimes (i count)
-    (setf (eval-stack-ref dest) (eval-stack-ref src))
-    (incf dest)
-    (incf src)))
-
-
-
-;;;; Component access magic.
-
-(declaim (inline component-ref))
-(defun component-ref (component pc)
-  (declare (type code-component component)
-	   (type pc pc))
-  (system:sap-ref-8 (code-instructions component) pc))
-
-(declaim (inline (setf component-ref)))
-(defun (setf component-ref) (value component pc)
-  (declare (type (unsigned-byte 8) value)
-	   (type code-component component)
-	   (type pc pc))
-  (setf (system:sap-ref-8 (code-instructions component) pc) value))
-
-(declaim (inline component-ref-signed))
-(defun component-ref-signed (component pc)
-  (let ((byte (component-ref component pc)))
-    (if (logbitp 7 byte)
-	(logior (ash -1 8) byte)
-	byte)))
-
-(declaim (inline component-ref-24))
-(defun component-ref-24 (component pc)
-  (logior (ash (component-ref component pc) 16)
-	  (ash (component-ref component (1+ pc)) 8)
-	  (component-ref component (+ pc 2))))
-
-
-;;;; Debugging support.
-
-;;; WITH-DEBUGGER-INFO -- internal.
-;;;
-;;; This macro binds three magic variables.  When the debugger notices that
-;;; these three variables are bound, it makes a byte-code frame out of the
-;;; supplied information instead of a compiled frame.  We set each var in
-;;; addition to binding it so the compiler doens't optimize away the binding.
-;;;
-(defmacro with-debugger-info ((component pc fp) &body body)
-  `(let ((%byte-interp-component ,component)
-	 (%byte-interp-pc ,pc)
-	 (%byte-interp-fp ,fp))
-     (declare (optimize (debug 3)))
-     (setf %byte-interp-component %byte-interp-component)
-     (setf %byte-interp-pc %byte-interp-pc)
-     (setf %byte-interp-fp %byte-interp-fp)
-     ,@body))
-
-
-(defun byte-install-breakpoint (component pc)
-  (declare (type code-component component)
-	   (type pc pc)
-	   (values (unsigned-byte 8)))
-  (let ((orig (component-ref component pc)))
-    (setf (component-ref component pc)
-	  #.(logior byte-xop
-		    (xop-index-or-lose 'breakpoint)))
-    orig))
-
-(defun byte-remove-breakpoint (component pc orig)
-  (declare (type code-component component)
-	   (type pc pc)
-	   (type (unsigned-byte 8) orig)
-	   (values (unsigned-byte 8)))
-  (setf (component-ref component pc) orig))
-
-(defun byte-skip-breakpoint (component pc fp orig)
-  (declare (type code-component component)
-	   (type pc pc)
-	   (type stack-pointer fp)
-	   (type (unsigned-byte 8) orig))
-  (byte-interpret-byte component fp pc orig))
-
-
-
-
-;;;; System constants
-
-;;; We don't just use *system-constants* directly because we want to be
-;;; able to change it in the compiler without breaking the running
-;;; byte interpreter.
-;;;
-(defconstant system-constants #.*system-constants*)
-
-
-
-;;;; Byte compiled function constructors/extractors.
-
-(defun make-byte-compiled-function (xep)
-  (declare (type byte-xep xep))
-  (set-function-subtype
-   #'(lambda (&rest args)
-       (let ((old-sp (current-stack-pointer))
-	     (num-args (length args)))
-	 (declare (type stack-pointer old-sp))
-	 (dolist (arg args)
-	   (push-eval-stack arg))
-	 (invoke-xep nil 0 old-sp 0 num-args xep)))
-   vm:byte-code-function-type))
-
-(defun byte-compiled-function-xep (function)
-  (declare (type function function)
-	   (values byte-xep))
-  (or (system:find-if-in-closure #'byte-xep-p function)
-      (error "Couldn't find the XEP in ~S" function)))
-
-(defun make-byte-compiled-closure (xep closure-vars)
-  (declare (type byte-xep xep)
-	   (type simple-vector closure-vars))
-  (set-function-subtype
-   #'(lambda (&rest args)
-       (let ((old-sp (current-stack-pointer))
-	     (num-args (length args)))
-	 (declare (type stack-pointer old-sp))
-	 (dolist (arg args)
-	   (push-eval-stack arg))
-	 (invoke-xep nil 0 old-sp 0 num-args xep closure-vars)))
-   vm:byte-code-closure-type))
-
-(defun byte-compiled-closure-xep (closure)
-  (declare (type function closure)
-	   (values byte-xep))
-  (or (system:find-if-in-closure #'byte-xep-p closure)
-      (error "Couldn't find the XEP in ~S" closure)))
-
-(defun byte-compiled-closure-closure-vars (closure)
-  (declare (type function closure)
-	   (values simple-vector))
-  (or (system:find-if-in-closure #'simple-vector-p closure)
-      (error "Couldn't find the closure vars in ~S" closure)))
-
-(defun set-function-subtype (function subtype)
-  (setf (function-subtype function) subtype)
-  function)
-
-
-
-;;;; Inlines.
-
-(defmacro expand-into-inlines ()
-  (declare (optimize (inhibit-warnings 3)))
-  (labels ((build-dispatch (bit base)
-	     (if (minusp bit)
-		 (let ((info (nth base *inline-functions*)))
-		   (if info
-		       (let* ((spec (type-specifier
-				     (inline-function-info-type info)))
-			      (arg-types (second spec))
-			      (result-type (third spec))
-			      (args (mapcar #'(lambda (x)
-						(declare (ignore x))
-						(gensym))
-					    arg-types))
-			      (func
-			       `(the ,result-type
-				     (,(inline-function-info-function info)
-				      ,@args))))
-			 `(multiple-value-pop-eval-stack ,args
-			    (declare ,@(mapcar #'(lambda (type var)
-						   `(type ,type ,var))
-					       arg-types args))
-			    ,(if (and (consp result-type)
-				      (eq (car result-type) 'values))
-				 (let ((results
-					(mapcar #'(lambda (x)
-						    (declare (ignore x))
-						    (gensym))
-						(cdr result-type))))
-				   `(multiple-value-bind
-					,results ,func
-				      ,@(mapcar #'(lambda (res)
-						    `(push-eval-stack ,res))
-						results)))
-				 `(push-eval-stack ,func))))
-		       `(error "Unknown inline function, id=~D" ,base)))
-		 `(if (zerop (logand byte ,(ash 1 bit)))
-		      ,(build-dispatch (1- bit) base)
-		      ,(build-dispatch (1- bit) (+ base (ash 1 bit)))))))
-    (build-dispatch 4 0)))
-
-(declaim (inline value-cell-setf))
-(defun value-cell-setf (value cell)
-  (value-cell-set cell value)
-  value)
-
-(declaim (inline setf-symbol-value))
-(defun setf-symbol-value (value symbol)
-  (setf (symbol-value symbol) value))
-
-(declaim (inline %byte-special-bind))
-(defun %byte-special-bind (value symbol)
-  (system:%primitive bind value symbol)
-  (values))
-
-(declaim (inline %byte-special-unbind))
-(defun %byte-special-unbind ()
-  (system:%primitive unbind)
-  (values))
-
-(declaim (inline cons-unique-tag))
-(defun cons-unique-tag ()
-  (list '#:%unique-tag%))
-
-
-;;;; Two-arg function stubs:
-;;;
-;;; We have two-arg versions of some n-ary functions that are normally
-;;; open-coded.
-
-(defun two-arg-char= (x y) (char= x y))
-(defun two-arg-char< (x y) (char< x y))
-(defun two-arg-char> (x y) (char> x y))
-(defun two-arg-char-equal (x y) (char-equal x y))
-(defun two-arg-char-lessp (x y) (char-lessp x y))
-(defun two-arg-char-greaterp (x y) (char-greaterp x y))
-
-
-;;;; XOPs
-
-;;; Extension operations (XOPs) are random magic things that the byte
-;;; interpreter needs to do, but can't be represented as a function call.
-;;; When the byte interpreter encounters an XOP in the byte stream, it
-;;; tail-calls the corresponding XOP routine extracted from *byte-xops*.
-;;; The XOP routine can do whatever it wants, probably re-invoking the
-;;; byte interpreter.
-
-;;; UNDEFINED-XOP -- internal.
-;;;
-;;; If a real XOP hasn't been defined, this gets invoked and signals an
-;;; error.  This shouldn't happen in normal operation.
-;;;
-(defun undefined-xop (component old-pc pc fp)
-  (declare (ignore component old-pc pc fp))
-  (error "Undefined XOP."))
-
-;;; *BYTE-XOPS* -- Simple vector of the XOP functions.
-;;; 
-(declaim (type (simple-vector 256) *byte-xops*))
-(defvar *byte-xops*
-  (make-array 256 :initial-element #'undefined-xop))
-
-;;; DEFINE-XOP -- internal.
-;;;
-;;; Define a XOP function and install it in *BYTE-XOPS*.
-;;; 
-(eval-when (compile eval)
-  (defmacro define-xop (name lambda-list &body body)
-    (let ((defun-name (symbolicate "BYTE-" name "-XOP")))
-      `(progn
-	 (defun ,defun-name ,lambda-list
-	   ,@body)
-	 (setf (aref *byte-xops* ,(xop-index-or-lose name)) #',defun-name)
-	 ',defun-name))))
-
-;;; BREAKPOINT -- Xop.
-;;;
-;;; This is spliced in by the debugger in order to implement breakpoints.
-;;; 
-(define-xop breakpoint (component old-pc pc fp)
-  (declare (type code-component component)
-	   (type pc old-pc)
-	   (ignore pc)
-	   (type stack-pointer fp))
-  ;; Invoke the debugger.
-  (with-debugger-info (component old-pc fp)
-    (di::handle-breakpoint component old-pc fp))
-  ;; Retry the breakpoint XOP in case it was replaced with the original
-  ;; displaced byte-code.
-  (byte-interpret component old-pc fp))
-
-;;; DUP -- Xop.
-;;;
-;;; This just duplicates whatever is on the top of the stack.
-;;;
-(define-xop dup (component old-pc pc fp)
-  (declare (type code-component component)
-	   (ignore old-pc)
-	   (type pc pc)
-	   (type stack-pointer fp))
-  (let ((value (eval-stack-ref (1- (current-stack-pointer)))))
-    (push-eval-stack value))
-  (byte-interpret component pc fp))
-
-;;; MAKE-CLOSURE -- Xop.
-;;; 
-(define-xop make-closure (component old-pc pc fp)
-  (declare (type code-component component)
-	   (ignore old-pc)
-	   (type pc pc)
-	   (type stack-pointer fp))
-  (let* ((num-closure-vars (pop-eval-stack))
-	 (closure-vars (make-array num-closure-vars)))
-    (declare (type index num-closure-vars)
-	     (type simple-vector closure-vars))
-    (iterate frob ((index (1- num-closure-vars)))
-      (unless (minusp index)
-	(setf (svref closure-vars index) (pop-eval-stack))
-	(frob (1- index))))
-    (push-eval-stack (make-byte-compiled-closure (pop-eval-stack)
-						 closure-vars)))
-  (byte-interpret component pc fp))
-
-(define-xop merge-unknown-values (component old-pc pc fp)
-  (declare (type code-component component)
-	   (ignore old-pc)
-	   (type pc pc)
-	   (type stack-pointer fp))
-  (labels ((grovel (remaining-blocks block-count-ptr)
-	     (declare (type index remaining-blocks)
-		      (type stack-pointer block-count-ptr))
-	     (declare (values index stack-pointer))
-	     (let ((block-count (eval-stack-ref block-count-ptr)))
-	       (declare (type index block-count))
-	       (if (= remaining-blocks 1)
-		   (values block-count block-count-ptr)
-		   (let ((src (- block-count-ptr block-count)))
-		     (declare (type index src))
-		     (multiple-value-bind
-			 (values-above dst)
-			 (grovel (1- remaining-blocks) (1- src))
-		       (stack-copy dst src block-count)
-		       (values (+ values-above block-count)
-			       (+ dst block-count))))))))
-    (multiple-value-bind
-	(total-count end-ptr)
-	(grovel (pop-eval-stack) (1- (current-stack-pointer)))
-      (setf (eval-stack-ref end-ptr) total-count)
-      (setf (current-stack-pointer) (1+ end-ptr))))
-  (byte-interpret component pc fp))
-
-(define-xop default-unknown-values (component old-pc pc fp)
-  (declare (type code-component component)
-	   (ignore old-pc)
-	   (type pc pc)
-	   (type stack-pointer fp))
-  (let* ((desired (pop-eval-stack))
-	 (supplied (pop-eval-stack))
-	 (delta (- desired supplied)))
-    (declare (type index desired supplied)
-	     (type fixnum delta))
-    (cond ((minusp delta)
-	   (incf (current-stack-pointer) delta))
-	  ((plusp delta)
-	   (dotimes (i delta)
-	     (push-eval-stack nil)))))
-  (byte-interpret component pc fp))
-
-;;; THROW -- XOP
-;;;
-;;; %THROW is compiled down into this xop.  The stack contains the tag, the
-;;; values, and then a count of the values.  We special case various small
-;;; numbers of values to keep from consing if we can help it.
-;;;
-;;; Basically, we just extract the values and the tag and then do a throw.
-;;; The native compiler will convert this throw into whatever is necessary
-;;; to throw, so we don't have to duplicate all that cruft.
-;;;
-(define-xop throw (component old-pc pc fp)
-  (declare (type code-component component)
-	   (type pc old-pc)
-	   (ignore pc)
-	   (type stack-pointer fp))
-  (let ((num-results (pop-eval-stack)))
-    (declare (type index num-results))
-    (case num-results
-      (0
-       (let ((tag (pop-eval-stack)))
-	 (with-debugger-info (component old-pc fp)
-	   (throw tag (values)))))
-      (1
-       (multiple-value-pop-eval-stack
-	   (tag result)
-	 (with-debugger-info (component old-pc fp)
-	   (throw tag result))))
-      (2
-       (multiple-value-pop-eval-stack
-	   (tag result0 result1)
-	 (with-debugger-info (component old-pc fp)
-	   (throw tag (values result0 result1)))))
-      (t
-       (let ((results nil))
-	 (dotimes (i num-results)
-	   (push (pop-eval-stack) results))
-	 (let ((tag (pop-eval-stack)))
-	   (with-debugger-info (component old-pc fp)
-	     (throw tag (values-list results)))))))))
-
-;;; CATCH -- XOP
-;;;
-;;; This is used for both CATCHes and BLOCKs that are closed over.  We
-;;; establish a catcher for the supplied tag (from the stack top), and
-;;; recursivly enter the byte interpreter.  If the byte interpreter exits,
-;;; it must have been because of a BREAKUP (see below), so we branch (by
-;;; tail-calling the byte interpreter) to the pc returned by BREAKUP.
-;;; If we are thrown to, then we branch to the address encoded in the 3 bytes
-;;; following the catch XOP.
-;;; 
-(define-xop catch (component old-pc pc fp)
-  (declare (type code-component component)
-	   (ignore old-pc)
-	   (type pc pc)
-	   (type stack-pointer fp))
-  (let ((new-pc (block nil
-		  (let ((results
-			 (multiple-value-list
-			  (catch (pop-eval-stack)
-			    (return (byte-interpret component (+ pc 3) fp))))))
-		    (let ((num-results 0))
-		      (declare (type index num-results))
-		      (dolist (result results)
-			(push-eval-stack result)
-			(incf num-results))
-		      (push-eval-stack num-results))
-		    (component-ref-24 component pc)))))
-    (byte-interpret component new-pc fp)))
-
-;;; BREAKUP -- XOP
-;;;
-;;; Blow out of the dynamically nested CATCH or TAGBODY.  We just return the
-;;; pc following the BREAKUP XOP and the drop-through code in CATCH or
-;;; TAGBODY will do the correct thing.
-;;;
-(define-xop breakup (component old-pc pc fp)
-  (declare (ignore component old-pc fp)
-	   (type pc pc))
-  pc)
-
-;;; RETURN-FROM -- XOP
-;;;
-;;; This is exactly like THROW, except that the tag is the last thing on
-;;; the stack instead of the first.  This is used for RETURN-FROM (hence the
-;;; name).
-;;; 
-(define-xop return-from (component old-pc pc fp)
-  (declare (type code-component component)
-	   (type pc old-pc)
-	   (ignore pc)
-	   (type stack-pointer fp))
-  (let ((tag (pop-eval-stack))
-	(num-results (pop-eval-stack)))
-    (declare (type index num-results))
-    (case num-results
-      (0
-       (with-debugger-info (component old-pc fp)
-	 (throw tag (values))))
-      (1
-       (let ((value (pop-eval-stack)))
-	 (with-debugger-info (component old-pc fp)
-	   (throw tag value))))
-      (2
-       (multiple-value-pop-eval-stack
-	   (result0 result1)
-	 (with-debugger-info (component old-pc fp)
-	   (throw tag (values result0 result1)))))
-      (t
-       (let ((results nil))
-	 (dotimes (i num-results)
-	   (push (pop-eval-stack) results))
-	 (with-debugger-info (component old-pc fp)
-	   (throw tag (values-list results))))))))
-
-;;; TAGBODY -- XOP
-;;;
-;;; Similar to CATCH, except for TAGBODY.  One significant difference is that
-;;; when thrown to, we don't want to leave the dynamic extent of the tagbody
-;;; so we loop around and re-enter the catcher.  We keep looping until BREAKUP
-;;; is used to blow out.  When that happens, we just branch to the pc supplied
-;;; by BREAKUP.
-;;;
-(define-xop tagbody (component old-pc pc fp)
-  (declare (type code-component component)
-	   (ignore old-pc)
-	   (type pc pc)
-	   (type stack-pointer fp))
-  (let* ((tag (pop-eval-stack))
-	 (new-pc (block nil
-		   (loop
-		     (setf pc
-			   (catch tag
-			     (return (byte-interpret component pc fp))))))))
-    (byte-interpret component new-pc fp)))
-
-;;; GO -- XOP
-;;;
-;;; Yup, you guessed it.  This XOP implements GO.  There are no values to
-;;; pass, so we don't have to mess with them, and multiple exits can all be
-;;; using the same tag so we have to pass the pc we want to go to.
-;;;
-(define-xop go (component old-pc pc fp)
-  (declare (type code-component component)
-	   (type pc old-pc pc)
-	   (type stack-pointer fp))
-  (let ((tag (pop-eval-stack))
-	(new-pc (component-ref-24 component pc)))
-    (with-debugger-info (component old-pc fp)
-      (throw tag new-pc))))
-
-;;; UNWIND-PROTECT -- XOP
-;;;
-;;; Unwind-protects are handled significantly different in the byte compiler
-;;; and the native compiler.  Basically, we just use the native-compiler's
-;;; unwind-protect, and let it worry about continuing the unwind.
-;;; 
-(define-xop unwind-protect (component old-pc pc fp)
-  (declare (type code-component component)
-	   (ignore old-pc)
-	   (type pc pc)
-	   (type stack-pointer fp))
-  (let ((new-pc nil))
-    (unwind-protect
-	(setf new-pc (byte-interpret component (+ pc 3) fp))
-      (unless new-pc
-	;; The cleanup function expects 3 values to be one the stack, so
-	;; we have to put something there.
-	(push-eval-stack nil)
-	(push-eval-stack nil)
-	(push-eval-stack nil)
-	;; Now run the cleanup code.
-	(byte-interpret component (component-ref-24 component pc) fp)))
-    (byte-interpret component new-pc fp)))
-
-
-(define-xop fdefn-function-or-lose (component old-pc pc fp)
-  (let* ((fdefn (pop-eval-stack))
-	 (fun (fdefn-function fdefn)))
-    (declare (type fdefn fdefn))
-    (cond (fun
-	   (push-eval-stack fun)
-	   (byte-interpret component pc fp))
-	  (t
-	   (with-debugger-info (component old-pc fp)
-	     (error 'undefined-function :name (fdefn-name fdefn)))))))
-
-
-
-;;;; Type checking:
-
-;;;
-;;; These two hashtables map between type specifiers and type predicate
-;;; functions that test those types.  They are initialized according to the
-;;; standard type predicates of the target system.
-;;;
-(defvar *byte-type-predicates* (make-hash-table :test #'equal))
-(defvar *byte-predicate-types* (make-hash-table :test #'eq))
-
-(loop for (type predicate) in
-          '#.(loop for (type . predicate) in
-	           (backend-type-predicates *target-backend*)
-	       collect `(,(type-specifier type) ,predicate))
-      do
-  (let ((fun (fdefinition predicate)))
-    (setf (gethash type *byte-type-predicates*) fun)
-    (setf (gethash fun *byte-predicate-types*) type)))
-	    
-
-;;; LOAD-TYPE-PREDICATE  --  Internal
-;;;
-;;;    Called by the loader to convert a type specifier into a type predicate
-;;; (as used by the TYPE-CHECK XOP.)  If it is a structure type with a
-;;; predicate or has a predefined predicate, then return the predicate
-;;; function, otherwise return the CTYPE structure for the type.
-;;;
-(defun load-type-predicate (desc)
-  (or (gethash desc *byte-type-predicates*)
-      (let ((type (specifier-type desc)))
-	(if (structure-type-p type)
-	    (let ((info (info type defined-structure-info
-			      (structure-type-name type))))
-	      (if (and info (eq (dd-type info) 'structure))
-		  (let ((pred (dd-predicate info)))
-		    (if (and pred (fboundp pred))
-			(fdefinition pred)
-			type))
-		  type))
-	    type))))
-
-  
-;;; TYPE-CHECK -- Xop.
-;;;
-;;;    Check the type of the value on the top of the stack.  The type is
-;;; designated by an entry in the constants.  If the value is a function, then
-;;; it is called as a type predicate.  Otherwise, the value is a CTYPE object,
-;;; and we call %%TYPEP on it.
-;;;
-(define-xop type-check (component old-pc pc fp)
-  (declare (type code-component component)
-	   (type pc old-pc pc)
-	   (type stack-pointer fp))
-  (multiple-value-bind
-      (operand new-pc)
-      (let ((operand (component-ref component pc)))
-	(if (= operand #xff)
-	    (values (component-ref-24 component (1+ pc)) (+ pc 4))
-	    (values operand (1+ pc))))
-    (let ((value (eval-stack-ref (1- (current-stack-pointer))))
-	  (type (code-header-ref component
-				 (+ operand vm:code-constants-offset))))
-      (unless (if (functionp type)
-		  (funcall type value)
-		  (lisp::%%typep value type))
-	(with-debugger-info (component old-pc fp)
-	  (error 'type-error
-		 :datum value
-		 :expected-type (if (functionp type)
-				    (gethash type *byte-predicate-types*)
-				    (type-specifier type))))))
-    
-    (byte-interpret component new-pc fp)))
-
-
-;;;; The byte-interpreter.
-
-
-;;; The various operations are encoded as follows.
-;;;
-;;; 0000xxxx push-local op
-;;; 0001xxxx push-arg op   [push-local, but negative]
-;;; 0010xxxx push-constant op
-;;; 0011xxxx push-system-constant op
-;;; 0100xxxx push-int op
-;;; 0101xxxx push-neg-int op
-;;; 0110xxxx pop-local op
-;;; 0111xxxx pop-n op
-;;; 1000nxxx call op
-;;; 1001nxxx tail-call op
-;;; 1010nxxx multiple-call op
-;;; 10110xxx local-call
-;;; 10111xxx local-tail-call
-;;; 11000xxx local-multiple-call
-;;; 11001xxx return
-;;; 1101000r branch
-;;; 1101001r if-true
-;;; 1101010r if-false
-;;; 1101011r if-eq
-;;; 11011xxx Xop
-;;; 11100000
-;;;    to    various inline functions.
-;;; 11111111
-;;;
-;;; This encoding is rather hard wired into BYTE-INTERPRET due to the binary
-;;; dispatch tree.
-;;; 
-
-#+nil (declaim (start-block byte-interpret byte-interpret-byte
-			    invoke-xep invoke-local-entry-point))
-
-(defvar *byte-trace* nil)
-
-;;; BYTE-INTERPRET -- Internal Interface.
-;;;
-;;; Main entry point to the byte interpreter.
-;;; 
-(defun byte-interpret (component pc fp)
-  (declare (type code-component component)
-	   (type pc pc)
-	   (type stack-pointer fp))
-  (byte-interpret-byte component pc fp (component-ref component pc)))
-
-;;; BYTE-INTERPRET-BYTE -- Internal.
-;;;
-;;; This is seperated from BYTE-INTERPRET so we can continue from a breakpoint
-;;; without having to replace the breakpoint with the original instruction
-;;; and arrange to somehow put the breakpoint back after executing the
-;;; instruction.  We just leave the breakpoint there, and calls this function
-;;; with the byte the breakpoint displaced.
-;;;
-(defun byte-interpret-byte (component pc fp byte)
-  (declare (type code-component component)
-	   (type pc pc)
-	   (type stack-pointer fp)
-	   (type (unsigned-byte 8) byte))
-  (locally (declare (optimize (inhibit-warnings 3)))
-    (when *byte-trace*
-      (format *trace-output* "pc=~D, fp=~D, sp=~D, byte=#b~8,'0B, frame=~S~%"
-	      pc fp (current-stack-pointer) byte
-	      (subseq eval::*eval-stack* fp (current-stack-pointer)))))
-  (if (zerop (logand byte #x80))
-      ;; Some stack operation.  No matter what, we need the operand,
-      ;; so compute it.
-      (multiple-value-bind
-	  (operand new-pc)
-	  (let ((operand (logand byte #xf)))
-	    (if (= operand #xf)
-		(let ((operand (component-ref component (1+ pc))))
-		  (if (= operand #xff)
-		      (values (component-ref-24 component (+ pc 2))
-			      (+ pc 5))
-		      (values operand (+ pc 2))))
-		(values operand (1+ pc))))
-	(if (zerop (logand byte #x40))
-	    (push-eval-stack (if (zerop (logand byte #x20))
-				 (if (zerop (logand byte #x10))
-				     (eval-stack-ref (+ fp operand))
-				     (eval-stack-ref (- fp operand 5)))
-				 (if (zerop (logand byte #x10))
-				     (code-header-ref
-				      component
-				      (+ operand vm:code-constants-offset))
-				     (svref system-constants operand))))
-	    (if (zerop (logand byte #x20))
-		(push-eval-stack (if (zerop (logand byte #x10))
-				     operand
-				     (- (1+ operand))))
-		(if (zerop (logand byte #x10))
-		    (setf (eval-stack-ref (+ fp operand)) (pop-eval-stack))
-		    (if (zerop operand)
-			(let ((operand (pop-eval-stack)))
-			  (declare (type index operand))
-			  (decf (current-stack-pointer) operand))
-			(decf (current-stack-pointer) operand)))))
-	(byte-interpret component new-pc fp))
-      (if (zerop (logand byte #x40))
-	  ;; Some kind of call.
-	  (let ((args (let ((args (logand byte #x07)))
-			(if (= args #x07)
-			    (pop-eval-stack)
-			    args))))
-	    (if (zerop (logand byte #x20))
-		(let ((named (not (zerop (logand byte #x08)))))
-		  (if (zerop (logand byte #x10))
-		      ;; Call for single value.
-		      (do-call component pc (1+ pc) fp args named)
-		      ;; Tail call.
-		      (do-tail-call component pc fp args named)))
-		(if (zerop (logand byte #x10))
-		    ;; Call for multiple-values.
-		    (do-call component pc (- (1+ pc)) fp args
-			     (not (zerop (logand byte #x08))))
-		    (if (zerop (logand byte #x08))
-			;; Local call
-			(do-local-call component pc (+ pc 4) fp args)
-			;; Local tail-call
-			(do-tail-local-call component pc fp args)))))
-	  (if (zerop (logand byte #x20))
-	      ;; local-multiple-call, Return, branch, or Xop.
-	      (if (zerop (logand byte #x10))
-		  ;; local-multiple-call or return.
-		  (if (zerop (logand byte #x08))
-		      ;; Local-multiple-call.
-		      (do-local-call component pc (- (+ pc 4)) fp
-				     (let ((args (logand byte #x07)))
-				       (if (= args #x07)
-					   (pop-eval-stack)
-					   args)))
-		      ;; Return.
-		      (let ((num-results
-			     (let ((num-results (logand byte #x7)))
-			       (if (= num-results 7)
-				   (pop-eval-stack)
-				   num-results))))
-			(do-return fp num-results)))
-		  ;; Branch or Xop.
-		  (if (zerop (logand byte #x08))
-		      ;; Branch.
-		      (if (if (zerop (logand byte #x04))
-			      (if (zerop (logand byte #x02))
-				  t
-				  (pop-eval-stack))
-			      (if (zerop (logand byte #x02))
-				  (not (pop-eval-stack))
-				  (multiple-value-pop-eval-stack
-				   (val1 val2)
-				   (eq val1 val2))))
-			  ;; Branch taken.
-			  (byte-interpret
-			   component
-			   (if (zerop (logand byte #x01))
-			       (component-ref-24 component (1+ pc))
-			       (+ pc 2
-				  (component-ref-signed component (1+ pc))))
-			   fp)
-			  ;; Branch not taken.
-			  (byte-interpret component
-					  (if (zerop (logand byte #x01))
-					      (+ pc 4)
-					      (+ pc 2))
-					  fp))
-		      ;; Xop.
-		      (multiple-value-bind
-			  (sub-code new-pc)
-			  (let ((operand (logand byte #x7)))
-			    (if (= operand #x7)
-				(values (component-ref component (+ pc 1))
-					(+ pc 2))
-				(values operand (1+ pc))))
-			(funcall (the function (svref *byte-xops* sub-code))
-				 component pc new-pc fp))))
-	      ;; Random inline function.
-	      (progn
-		(expand-into-inlines)
-		(byte-interpret component (1+ pc) fp))))))
-
-(defun do-local-call (component pc old-pc old-fp num-args)
-  (declare (type pc pc)
-	   (type return-pc old-pc)
-	   (type stack-pointer old-fp)
-	   (type (integer 0 #.call-arguments-limit) num-args))
-  (invoke-local-entry-point component (component-ref-24 component (1+ pc))
-			    component old-pc
-			    (- (current-stack-pointer) num-args)
-			    old-fp))
-
-(defun do-tail-local-call (component pc fp num-args)
-  (declare (type code-component component) (type pc pc)
-	   (type stack-pointer fp)
-	   (type index num-args))
-  (let ((old-fp (eval-stack-ref (- fp 1)))
-	(old-sp (eval-stack-ref (- fp 2)))
-	(old-pc (eval-stack-ref (- fp 3)))
-	(old-component (eval-stack-ref (- fp 4)))
-	(start-of-args (- (current-stack-pointer) num-args)))
-    (stack-copy old-sp start-of-args num-args)
-    (setf (current-stack-pointer) (+ old-sp num-args))
-    (invoke-local-entry-point component (component-ref-24 component (1+ pc))
-			      old-component old-pc old-sp old-fp)))
-
-(defun invoke-local-entry-point (component target old-component old-pc old-sp
-					   old-fp &optional closure-vars)
-  (declare (type pc target)
-	   (type return-pc old-pc)
-	   (type stack-pointer old-sp old-fp)
-	   (type (or null simple-vector) closure-vars))
-  (when closure-vars
-    (iterate more ((index (1- (length closure-vars))))
-      (unless (minusp index)
-	(push-eval-stack (svref closure-vars index))
-	(more (1- index)))))
-  (push-eval-stack old-component)
-  (push-eval-stack old-pc)
-  (push-eval-stack old-sp)
-  (push-eval-stack old-fp)
-  (multiple-value-bind
-      (stack-frame-size entry-pc)
-      (let ((byte (component-ref component target)))
-	(if (= byte 255)
-	    (values (component-ref-24 component (1+ target)) (+ target 4))
-	    (values (* byte 2) (1+ target))))
-    (declare (type pc entry-pc))
-    (let ((fp (current-stack-pointer)))
-      (setf (current-stack-pointer) (+ fp stack-frame-size))
-      (byte-interpret component entry-pc fp))))
-
-
-;;; BYTE-APPLY  --  Internal
-;;;
-;;;    Call a function with some arguments popped off of the interpreter stack,
-;;; and restore the SP to the specifier value.
-;;;
-(defun byte-apply (function num-args restore-sp)
-  (declare (function function) (type index num-args))
-  (let ((start (- (current-stack-pointer) num-args)))
-    (declare (type stack-pointer start))
-    (macrolet ((frob ()
-		 `(case num-args
-		    ,@(loop for n below 8
-			collect `(,n (call-1 ,n)))
-		    (t
-		     (let ((args ())
-			   (end (+ start num-args)))
-		       (declare (type stack-pointer end))
-		       (do ((i start (1+ i)))
-			   ((= i end))
-			 (declare (type stack-pointer i))
-			 (push (eval-stack-ref i) args))
-		       (setf (current-stack-pointer) restore-sp)
-		       (apply function args)))))
-	       (call-1 (n)
-		 (collect ((binds)
-			   (args))
-		   (dotimes (i n)
-		     (let ((dum (gensym)))
-		       (binds `(,dum (eval-stack-ref (+ start ,i))))
-		       (args dum)))
-		   `(let ,(binds)
-		      (setf (current-stack-pointer) restore-sp)
-		      (funcall function ,@(args))))))
-      (frob))))
-
-
-(defun do-call (old-component call-pc ret-pc old-fp num-args named)
-  (declare (type code-component old-component)
-	   (type pc call-pc)
-	   (type return-pc ret-pc)
-	   (type stack-pointer old-fp)
-	   (type (integer 0 #.call-arguments-limit) num-args)
-	   (type (member t nil) named))
-  (let* ((old-sp (- (current-stack-pointer) num-args 1))
-	 (fun-or-fdefn (eval-stack-ref old-sp))
-	 (function (if named
-		       (or (fdefn-function fun-or-fdefn)
-			   (with-debugger-info (old-component call-pc old-fp)
-			     (error 'undefined-function
-				    :name (fdefn-name fun-or-fdefn))))
-		       fun-or-fdefn)))
-    (declare (type stack-pointer old-sp)
-	     (type (or function fdefn) fun-or-fdefn)
-	     (type function function))
-    (case (function-subtype function)
-      (#.vm:byte-code-function-type
-       (invoke-xep old-component ret-pc old-sp old-fp num-args
-		   (byte-compiled-function-xep function)))
-      (#.vm:byte-code-closure-type
-       (invoke-xep old-component ret-pc old-sp old-fp num-args
-		   (byte-compiled-closure-xep function)
-		   (byte-compiled-closure-closure-vars function)))
-      (t
-       (cond ((minusp ret-pc)
-	      (let* ((ret-pc (- ret-pc))
-		     (results
-		      (multiple-value-list
-		       (with-debugger-info
-			(old-component ret-pc old-fp)
-			(byte-apply function num-args old-sp)))))
-		(dolist (result results)
-		  (push-eval-stack result))
-		(push-eval-stack (length results))
-		(byte-interpret old-component ret-pc old-fp)))
-	     (t
-	      (push-eval-stack
-	       (with-debugger-info
-		(old-component ret-pc old-fp)
-		(byte-apply function num-args old-sp)))
-	      (byte-interpret old-component ret-pc old-fp)))))))
-
-
-(defun do-tail-call (component pc fp num-args named)
-  (declare (type code-component component)
-	   (type pc pc)
-	   (type stack-pointer fp)
-	   (type (integer 0 #.call-arguments-limit) num-args)
-	   (type (member t nil) named))
-  (let* ((start-of-args (- (current-stack-pointer) num-args))
-	 (fun-or-fdefn (eval-stack-ref (1- start-of-args)))
-	 (function (if named
-		       (or (fdefn-function fun-or-fdefn)
-			   (with-debugger-info (component pc fp)
-			     (error 'undefined-function
-				    :name (fdefn-name fun-or-fdefn))))
-		       fun-or-fdefn))
-	 (old-fp (eval-stack-ref (- fp 1)))
-	 (old-sp (eval-stack-ref (- fp 2)))
-	 (old-pc (eval-stack-ref (- fp 3)))
-	 (old-component (eval-stack-ref (- fp 4))))
-    (declare (type stack-pointer old-fp old-sp start-of-args)
-	     (type return-pc old-pc)
-	     (type (or fdefn function) fun-or-fdefn)
-	     (type function function))
-    (case (function-subtype function)
-      (#.vm:byte-code-function-type
-       (stack-copy old-sp start-of-args num-args)
-       (setf (current-stack-pointer) (+ old-sp num-args))
-       (invoke-xep old-component old-pc old-sp old-fp num-args
-		   (byte-compiled-function-xep function)))
-      (#.vm:byte-code-closure-type
-       (stack-copy old-sp start-of-args num-args)
-       (setf (current-stack-pointer) (+ old-sp num-args))
-       (invoke-xep old-component old-pc old-sp old-fp num-args
-		   (byte-compiled-closure-xep function)
-		   (byte-compiled-closure-closure-vars function)))
-      (t
-       ;; We are tail-calling native code.
-	 (cond ((null old-component)
-		;; We were called by native code.
-		(byte-apply function num-args old-sp))
-	       ((minusp old-pc)
-		;; We were called for multiple values.  So return multiple
-		;; values.
-		(let ((results
-		       (multiple-value-list
-			(with-debugger-info
-			    (old-component old-pc old-fp)
-			  (byte-apply function num-args old-sp)))))
-		  (dolist (result results)
-		    (push-eval-stack result))
-		  (push-eval-stack (length results)))
-		(byte-interpret old-component old-pc old-fp))
-	       (t
-		;; We were called for one value.  So return one value.
-		(push-eval-stack
-		 (with-debugger-info
-		     (old-component old-pc old-fp)
-		   (byte-apply function num-args old-sp)))
-		(byte-interpret old-component old-pc old-fp)))))))
-
-(defun invoke-xep (old-component ret-pc old-sp old-fp num-args xep
-				 &optional closure-vars)
-  (declare (type (or null code-component) old-component)
-	   (type index num-args)
-	   (type return-pc ret-pc)
-	   (type stack-pointer old-sp old-fp)
-	   (type byte-xep xep)
-	   (type (or null simple-vector) closure-vars))
-  (let ((entry-point
-	 (let ((min (byte-xep-min-args xep))
-	       (max (byte-xep-max-args xep)))
-	   (cond
-	    ((< num-args min)
-	     ;; ### Flame out point.
-	     (error "Not enough arguments."))
-	    ((<= num-args max)
-	     (nth (- num-args min) (byte-xep-entry-points xep)))
-	    ((null (byte-xep-more-args-entry-point xep))
-	     ;; ### Flame out point.
-	     (error "Too many arguments."))
-	    (t
-	     (let* ((more-args-supplied (- num-args max))
-		    (sp (current-stack-pointer))
-		    (more-args-start (- sp more-args-supplied))
-		    (restp (byte-xep-rest-arg-p xep))
-		    (rest (and restp
-			       (do ((index (1- sp) (1- index))
-				    (result nil
-					    (cons (eval-stack-ref index)
-						  result)))
-				   ((< index more-args-start) result)
-				 (declare (type index index))))))
-	       (declare (type index more-args-supplied)
-			(type stack-pointer more-args-start))
-	       (cond
-		((not (byte-xep-keywords-p xep))
-		 (assert restp)
-		 (setf (current-stack-pointer) (1+ more-args-start))
-		 (setf (eval-stack-ref more-args-start) rest))
-		(t
-		 (unless (evenp more-args-supplied)
-		   ;; ### Flame out.
-		   (error "Odd number of keyword arguments."))
-		 (let* ((num-more-args (byte-xep-num-more-args xep))
-			(new-sp (+ more-args-start num-more-args))
-			(temp (max sp new-sp))
-			(temp-sp (+ temp more-args-supplied))
-			(keywords (byte-xep-keywords xep)))
-		   (declare (type index temp)
-			    (type stack-pointer new-sp temp-sp))
-		   (setf (current-stack-pointer) temp-sp)
-		   (stack-copy temp more-args-start more-args-supplied)
-		   (when restp
-		     (setf (eval-stack-ref more-args-start) rest)
-		     (incf more-args-start))
-		   (let ((index more-args-start))
-		     (dolist (keyword keywords)
-		       (setf (eval-stack-ref index) (cadr keyword))
-		       (incf index)
-		       (when (caddr keyword)
-			 (setf (eval-stack-ref index) nil)
-			 (incf index))))
-		   (let ((index temp-sp)
-			 (allow (eq (byte-xep-keywords-p xep) :allow-others))
-			 (bogus-key nil)
-			 (bogus-key-p nil))
-		     (declare (type stack-pointer index))
-		     (loop
-		       (decf index 2)
-		       (when (< index more-args-start)
-			 (return))
-		       (let ((key (eval-stack-ref index))
-			     (value (eval-stack-ref (1+ index))))
-			 (if (eq key :allow-other-keys)
-			     (setf allow value)
-			     (let ((target more-args-start))
-			       (declare (type stack-pointer target))
-			       (dolist (keyword keywords
-						(setf bogus-key key
-						      bogus-key-p t))
-				 (cond ((eq (car keyword) key)
-					(setf (eval-stack-ref target) value)
-					(when (caddr keyword)
-					  (setf (eval-stack-ref (1+ target))
-						t))
-					(return))
-				       ((caddr keyword)
-					(incf target 2))
-				       (t
-					(incf target))))))))
-		     (when (and bogus-key-p (not allow))
-		       ;; ### Flame out.
-		       (error "Unknown keyword: ~S" bogus-key)))
-		   (setf (current-stack-pointer) new-sp)))))
-	     (byte-xep-more-args-entry-point xep))))))
-    (declare (type pc entry-point))
-    (invoke-local-entry-point (byte-xep-component xep) entry-point
-			      old-component ret-pc old-sp old-fp
-			      closure-vars)))
-
-(defun do-return (fp num-results)
-  (declare (type stack-pointer fp) (type index num-results))
-  (let ((old-component (eval-stack-ref (- fp 4))))
-    (typecase old-component
-      (code-component
-       ;; Returning to more byte-interpreted code.
-       (do-local-return old-component fp num-results))
-      (null
-       ;; Returning to native code.
-       (let ((old-sp (eval-stack-ref (- fp 2))))
-	 (case num-results
-	   (0
-	    (setf (current-stack-pointer) old-sp)
-	    (values))
-	   (1
-	    (let ((result (pop-eval-stack)))
-	      (setf (current-stack-pointer) old-sp)
-	      result))
-	   (t
-	    (let ((results nil))
-	      (dotimes (i num-results)
-		(push (pop-eval-stack) results))
-	      (setf (current-stack-pointer) old-sp)
-	      (values-list results))))))
-      (t
-       ;; ### Function end breakpoint?
-       (error "function-end breakpoints not supported.")))))
-
-(defun do-local-return (old-component fp num-results)
-  (declare (type stack-pointer fp) (type index num-results))
-  (let ((old-fp (eval-stack-ref (- fp 1)))
-	(old-sp (eval-stack-ref (- fp 2)))
-	(old-pc (eval-stack-ref (- fp 3))))
-    (declare (type (signed-byte 25) old-pc))
-    (if (plusp old-pc)
-	;; Wants single value.
-	(let ((result (if (zerop num-results)
-			  nil
-			  (eval-stack-ref (- (current-stack-pointer)
-					     num-results)))))
-	  (setf (current-stack-pointer) old-sp)
-	  (push-eval-stack result)
-	  (byte-interpret old-component old-pc old-fp))
-	;; Wants multiple values.
-	(progn
-	  (stack-copy old-sp (- (current-stack-pointer) num-results)
-		      num-results)
-	  (setf (current-stack-pointer) (+ old-sp num-results))
-	  (push-eval-stack num-results)
-	  (byte-interpret old-component (- old-pc) old-fp)))))
-
-;(declaim (end-block byte-interpret byte-interpret-byte invoke-xep))
-
-
-;;;; Random testing noise.
-
-(defun dump-byte-fun (fun)
-  (declare (optimize (inhibit-warnings 3)))
-  (let* ((xep (system:find-if-in-closure #'byte-xep-p fun))
-	 (component (byte-xep-component xep))
-	 (bytes (* (code-header-ref component vm:code-code-size-slot)
-		   vm:word-bytes)))
-    (dotimes (index bytes)
-      (format t "~3D: #b~8,'0B~%" index (component-ref component index)))))
-
-
-(defun disassem-byte-fun (fun)
-  (declare (optimize (inhibit-warnings 3)))
-  (let* ((xep (system:find-if-in-closure #'byte-xep-p fun))
-	 (component (byte-xep-component xep))
-	 (bytes (* (code-header-ref component vm:code-code-size-slot)
-		   vm:word-bytes))
-	 (index 0))
-    (labels ((newline ()
-	       (format t "~&~4D:" index))
-	     (next-byte ()
-	       (let ((byte (component-ref component index)))
-		 (format t " ~2,'0X" byte)
-		 (incf index)
-		 byte))
-	     (extract-24-bits ()
-	       (logior (ash (next-byte) 16)
-		       (ash (next-byte) 8)
-		       (next-byte)))
-	     (extract-extended-op ()
-	       (let ((byte (next-byte)))
-		 (if (= byte 255)
-		     (extract-24-bits)
-		     byte)))       
-	     (extract-4-bit-op (byte)
-	       (let ((4-bits (ldb (byte 4 0) byte)))
-		 (if (= 4-bits 15)
-		     (extract-extended-op)
-		     4-bits)))
-	     (extract-3-bit-op (byte)
-	       (let ((3-bits (ldb (byte 3 0) byte)))
-		 (if (= 3-bits 7)
-		     :var
-		     3-bits)))
-	     (extract-branch-target (byte)
-	       (if (logbitp 0 byte)
-		   (let ((disp (next-byte)))
-		     (if (logbitp 7 disp)
-			 (+ index disp -256)
-			 (+ index disp)))
-		   (extract-24-bits)))
-	     (note (string &rest noise)
-	       (format t "~12T~?" string noise))
-	     (get-constant (index)
-	       (let ((index (+ index vm:code-constants-offset)))
-		 (if (< (1- vm:code-constants-offset)
-			index
-			(get-header-data component))
-		     (code-header-ref component index)
-		     "<bogus index>"))))
-
-      (newline)
-      (let ((frame-size
-	     (let ((byte (next-byte)))
-	       (if (< byte 255)
-		   (* byte 2)
-		   (logior (ash (next-byte) 16)
-			   (ash (next-byte) 8)
-			   (next-byte))))))
-	(note "Entry point, frame-size=~D~%" frame-size))
-      (loop
-	(unless (< index bytes)
-	  (return))
-	(newline)
-	(let ((byte (next-byte)))
-	  (macrolet ((dispatch (&rest clauses)
-		       `(cond ,@(mapcar #'(lambda (clause)
-					    `((= (logand byte ,(caar clause))
-						 ,(cadar clause))
-					      ,@(cdr clause)))
-					clauses))))
-	    (dispatch
-	     ((#b11110000 #b00000000)
-	      (let ((op (extract-4-bit-op byte)))
-		(note "push-local ~D" op)))
-	     ((#b11110000 #b00010000)
-	      (let ((op (extract-4-bit-op byte)))
-		(note "push-arg ~D" op)))
-	     ((#b11110000 #b00100000)
-	      (let ((index (+ (extract-4-bit-op byte)
-			      vm:code-constants-offset))
-		    (*print-level* 3)
-		    (*print-lines* 2))
-		(note "push-const ~S"
-		      (if (< (1- vm:code-constants-offset)
-			     index
-			     (get-header-data component))
-			  (code-header-ref component index)
-			  "<bogus index>"))))
-	     ((#b11110000 #b00110000)
-	      (let ((op (extract-4-bit-op byte))
-		    (*print-level* 3)
-		    (*print-lines* 2))
-		(note "push-sys-const ~S"
-		      (svref system-constants op))))
-	     ((#b11110000 #b01000000)
-	      (let ((op (extract-4-bit-op byte)))
-		(note "push-int ~D" op)))
-	     ((#b11110000 #b01010000)
-	      (let ((op (extract-4-bit-op byte)))
-		(note "push-neg-int ~D" (- (1+ op)))))
-	     ((#b11110000 #b01100000)
-	      (let ((op (extract-4-bit-op byte)))
-		(note "pop-local ~D" op)))
-	     ((#b11110000 #b01110000)
-	      (let ((op (extract-4-bit-op byte)))
-		(note "pop-n ~D" op)))
-	     ((#b11110000 #b10000000)
-	      (let ((op (extract-3-bit-op byte)))
-		(note "~:[~;named-~]call, ~D args"
-		      (logbitp 3 byte) op)))
-	     ((#b11110000 #b10010000)
-	      (let ((op (extract-3-bit-op byte)))
-		(note "~:[~;named-~]tail-call, ~D args"
-		      (logbitp 3 byte) op)))
-	     ((#b11110000 #b10100000)
-	      (let ((op (extract-3-bit-op byte)))
-		(note "~:[~;named-~]multiple-call, ~D args"
-		      (logbitp 3 byte) op)))
-	     ((#b11111000 #b10110000)
-	      ;; local call
-	      (let ((op (extract-3-bit-op byte))
-		    (target (extract-24-bits)))
-		(note "local call ~D, ~D args" target op)))
-	     ((#b11111000 #b10111000)
-	      ;; local tail-call
-	      (let ((op (extract-3-bit-op byte))
-		    (target (extract-24-bits)))
-		(note "local tail-call ~D, ~D args" target op)))
-	     ((#b11111000 #b11000000)
-	      ;; local-multiple-call
-	      (let ((op (extract-3-bit-op byte))
-		    (target (extract-24-bits)))
-		(note "local multiple-call ~D, ~D args" target op)))
-	     ((#b11111000 #b11001000)
-	      ;; return
-	      (let ((op (extract-3-bit-op byte)))
-		(note "return, ~D vals" op)))
-	     ((#b11111110 #b11010000)
-	      ;; branch
-	      (note "branch ~D" (extract-branch-target byte)))
-	     ((#b11111110 #b11010010)
-	      ;; if-true
-	      (note "if-true ~D" (extract-branch-target byte)))
-	     ((#b11111110 #b11010100)
-	      ;; if-false
-	      (note "if-false ~D" (extract-branch-target byte)))
-	     ((#b11111110 #b11010110)
-	      ;; if-eq
-	      (note "if-eq ~D" (extract-branch-target byte)))
-	     ((#b11111000 #b11011000)
-	      ;; XOP
-	      (let* ((low-3-bits (extract-3-bit-op byte))
-		     (xop (nth (if (eq low-3-bits :var) (next-byte) low-3-bits)
-			       *xop-names*)))
-		(note "xop ~A~@[ ~D~]"
-		      xop
-		      (case xop
-			((catch go unwind-protect)
-			 (extract-24-bits))
-			(type-check
-			 (get-constant (extract-extended-op)))))))
-			 
-	     ((#b11100000 #b11100000)
-	      ;; inline
-	      (note "inline ~A"
-		    (inline-function-info-function
-		     (nth (ldb (byte 5 0) byte) *inline-functions*)))))))))))
-
diff --git a/code/c-call.lisp b/code/c-call.lisp
deleted file mode 100644
index 33bad1aac2b1367ef2db7bbe172a7b8b5af215be..0000000000000000000000000000000000000000
--- a/code/c-call.lisp
+++ /dev/null
@@ -1,88 +0,0 @@
-;;; -*- Package: C-CALL -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/c-call.lisp,v 1.12 1992/12/18 13:52:26 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains some extensions to the Alien facility to simplify
-;;; importing C interfaces.
-;;;
-(in-package "C-CALL")
-(use-package "ALIEN")
-(use-package "ALIEN-INTERNALS")
-(use-package "SYSTEM")
-
-(export '(char short int long unsigned-char unsigned-short unsigned-int
-	  unsigned-long float double c-string void))
-	       
-
-;;;; Extra types.
-
-(def-alien-type char (integer 8))
-(def-alien-type short (integer 16))
-(def-alien-type int (integer 32))
-(def-alien-type long (integer 32))
-
-(def-alien-type unsigned-char (unsigned 8))
-(def-alien-type unsigned-short (unsigned 16))
-(def-alien-type unsigned-int (unsigned 32))
-(def-alien-type unsigned-long (unsigned 32))
-
-(def-alien-type float single-float)
-(def-alien-type double double-float)
-
-(def-alien-type-translator void ()
-  (parse-alien-type '(values)))
-
-
-
-;;;; C string support.
-
-(def-alien-type-class (c-string :include pointer))
-
-(def-alien-type-translator c-string ()
-  (make-alien-c-string-type :to (parse-alien-type 'char)))
-
-(def-alien-type-method (c-string :unparse) (type)
-  (declare (ignore type))
-  'c-string)
-
-(def-alien-type-method (c-string :lisp-rep) (type)
-  (declare (ignore type))
-  '(or simple-base-string null (alien (* char))))
-
-(def-alien-type-method (c-string :naturalize-gen) (type alien)
-  (declare (ignore type))
-  `(if (zerop (sap-int ,alien))
-       nil
-       (%naturalize-c-string ,alien)))
-
-(def-alien-type-method (c-string :deport-gen) (type value)
-  (declare (ignore type))
-  `(etypecase ,value
-     (null (int-sap 0))
-     ((alien (* char)) (alien-sap ,value))
-     (simple-base-string (vector-sap ,value))))
-
-(defun %naturalize-c-string (sap)
-  (declare (type system-area-pointer sap))
-  (with-alien ((ptr (* char) sap))
-    (locally
-     (declare (optimize (speed 3) (safety 0)))
-     (let ((length (loop
-		     for offset of-type fixnum upfrom 0
-		     until (zerop (deref ptr offset))
-		     finally (return offset))))
-       (let ((result (make-string length)))
-	 (kernel:copy-from-system-area (alien-sap ptr) 0
-				       result (* vm:vector-data-offset
-						 vm:word-bits)
-				       (* length vm:byte-bits))
-	 result)))))
diff --git a/code/char.lisp b/code/char.lisp
deleted file mode 100644
index b769897ac5ad9c9ff4fb953e026aceb28b91f846..0000000000000000000000000000000000000000
--- a/code/char.lisp
+++ /dev/null
@@ -1,375 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/char.lisp,v 1.6 1991/11/09 02:47:07 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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 standard-char-p graphic-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 code-char char-upcase
-	  char-downcase digit-char char-int char-name name-char))
-
-
-;;; Compile some trivial character operations via inline expansion:
-;;;
-(proclaim '(inline standard-char-p graphic-char-p alpha-char-p
-		   upper-case-p lower-case-p both-case-p alphanumericp
-		   char-int))
-
-
-(defconstant char-code-limit 256
-  "The upper exclusive bound on values produced by CHAR-CODE.")
-
-(deftype char-code ()
-  `(integer 0 (,char-code-limit)))
-
-
-(defparameter char-name-alist
-	`(("NULL" . ,(code-char 0))
-	  ("BELL" . ,(code-char 7))
-	  ("BACKSPACE" . ,(code-char 8)) ("BS" . ,(code-char 8))
-	  ("TAB" . ,(code-char 9))
-	  ("NEWLINE" . ,(code-char 10)) ("NL" . ,(code-char 10))  
-	  ("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)) ("CR" . ,(code-char 13))
-	  ("ESCAPE" . ,(code-char 27)) ("ESC" . ,(code-char 27))
-	  ("ALTMODE" . ,(code-char 27)) ("ALT" . ,(code-char 27))
-	  ("SPACE" . ,(code-char 32)) ("SP" . ,(code-char 32))
-	  ("DELETE" . ,(code-char 127)) ("RUBOUT" . ,(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)
-  "Returns the integer code of CHAR."
-  (etypecase char
-    (base-char (char-code (truly-the base-char char)))))
-
-
-(defun char-int (char)
-  "Returns the integer code of CHAR.  This is the same as char-code, as
-   CMU Common Lisp does not implement character bits or fonts."
-  (char-code char))
-
-
-(defun code-char (code)
-  "Returns the character with the code CODE."
-  (declare (type char-code code))
-  (code-char code))
-
-
-(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)
-    (char-code (code-char object))
-    (string (if (= 1 (length (the string object)))
-		(char object 0)
-		(error "String is not of length one: ~S" object)))
-    (symbol (if (= 1 (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 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)))
-
-
-
-
-;;;; 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 'base-char)
-       (let ((n (char-code (the base-char char))))
-	 (or (< 31 n 127)
-	     (= n 10)))))
-
-(defun %standard-char-p (thing)
-  "Return T if and only if THING is a standard-char.  Differs from
-  standard-char-p in that THING doesn't have to be a character."
-  (and (characterp thing) (standard-char-p thing)))
-
-(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 'base-char)
-       (< 31
-	  (char-code (the base-char char))
-	  127)))
-
-
-(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 CHAR converted to upper-case if that is possible."
-  (declare (character char))
-  (if (lower-case-p char)
-      (code-char (- (char-code char) 32))
-      char))
-
-(defun char-downcase (char)
-  "Returns CHAR converted to lower-case if that is possible."
-  (declare (character char))
-  (if (upper-case-p char)
-      (code-char (+ (char-code char) 32))
-      char))
-
-(defun digit-char (weight &optional (radix 10))
-  "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)))))
diff --git a/code/clx-ext.lisp b/code/clx-ext.lisp
deleted file mode 100644
index 99726c189ea77cdf5790a6a939280efe44620469..0000000000000000000000000000000000000000
--- a/code/clx-ext.lisp
+++ /dev/null
@@ -1,593 +0,0 @@
-;;; -*- Package: Extensions; Log: code.log; Mode: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/clx-ext.lisp,v 1.9 1991/12/17 08:21:39 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains code to extend CLX in the CMU Common Lisp environment.
-;;;
-;;; Written by Bill Chiles and Chris Hoover.
-;;;
-
-(in-package "EXTENSIONS")
-
-(export '(open-clx-display with-clx-event-handling enable-clx-event-handling
-	  disable-clx-event-handling object-set-event-handler
-	  default-clx-event-handler
-	  flush-display-events carefully-add-font-paths
-
-	  serve-key-press serve-key-release serve-button-press
-	  serve-button-release serve-motion-notify serve-enter-notify
-	  serve-leave-notify serve-focus-in serve-focus-out 
-	  serve-exposure serve-graphics-exposure serve-no-exposure
-	  serve-visibility-notify serve-create-notify serve-destroy-notify
-	  serve-unmap-notify serve-map-notify serve-map-request
-	  serve-reparent-notify serve-configure-notify serve-gravity-notify
-	  serve-resize-request serve-configure-request serve-circulate-notify
-	  serve-circulate-request serve-property-notify serve-selection-clear
-	  serve-selection-request serve-selection-notify serve-colormap-notify
-	  serve-client-message))
-
-
-
-;;;; OPEN-CLX-DISPLAY.
-
-(defun open-clx-display (&optional (string (cdr (assoc :display
-						       *environment-list*
-						       :test #'eq))))
-  "Parses a display specification including display and screen numbers.
-   This returns nil when there is no DISPLAY environment variable.  If string
-   is non-nil, and any fields are missing in the specification, this signals an
-   error.  If you specify a screen, then this sets XLIB:DISPLAY-DEFAULT-SCREEN
-   to that screen since CLX initializes this form to the first of
-   XLIB:SCREEN-ROOTS.  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)))
-	(when 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))
-	    (setf (xlib:display-default-screen display)
-		  (elt screens screen-num))))
-	(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)
-      (enumerate-search-list (pathname elt)
-	(lisp::enumerate-matches (name pathname)
-	  (unless (member name font-path :test #'string=)
-	    (push name 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.")
-
-(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 (fd-stream-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)
-			     (fd-stream-fd
-			      (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 (fd-stream-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/cmu-site.lisp b/code/cmu-site.lisp
deleted file mode 100644
index 495fa84f906241e8798b4770fb47ce3deb2b4fec..0000000000000000000000000000000000000000
--- a/code/cmu-site.lisp
+++ /dev/null
@@ -1,20 +0,0 @@
-;;; -*- Mode: Lisp; Package: System -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/cmu-site.lisp,v 1.1 1991/08/30 17:43:33 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Site specific initialization for CMU.  This can be used as a template for
-;;; non-cmu "library:site-init" files.
-;;;
-(in-package "SYSTEM")
-
-(setq *short-site-name* "CMU-SCS")
-(setq *long-site-name* "Carnegie-Mellon University School of Computer Science")
diff --git a/code/commandline.lisp b/code/commandline.lisp
deleted file mode 100644
index 04513d404458afe3667c3258ee72e7d863739fc3..0000000000000000000000000000000000000000
--- a/code/commandline.lisp
+++ /dev/null
@@ -1,192 +0,0 @@
-;;; -*- Mode: Lisp; Package: Extensions; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/commandline.lisp,v 1.2 1991/02/08 13:31:31 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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-int.lisp b/code/debug-int.lisp
deleted file mode 100644
index f11cdfaec132422e6d7bb13b4f5e20648b80aab9..0000000000000000000000000000000000000000
--- a/code/debug-int.lisp
+++ /dev/null
@@ -1,3791 +0,0 @@
-;;; -*- Mode: completion; Log: code.log; Package: DI -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.54 1992/12/17 09:04:41 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the implementation of the programmer's interface
-;;; to writing debugging tools.
-;;;
-;;; Written by Bill Chiles and Rob Maclachlan.
-;;;
-
-(in-package "DEBUG-INTERNALS" :nicknames '("DI"))
-
-
-;;; The compiler's debug-source structure is almost exactly what we want, so
-;;; just get these symbols and export them.
-;;;
-(import '(c::debug-source-from c::debug-source-name c::debug-source-created
-	  c::debug-source-compiled c::debug-source-start-positions
-	  c::make-debug-source c::debug-source c::debug-source-p))
-
-(export '(debug-variable-name debug-variable-package debug-variable-symbol
-	  debug-variable-id debug-variable-value debug-variable-validity
-	  debug-variable-valid-value debug-variable debug-variable-p
-
-	  top-frame frame-down frame-up flush-frames-above frame-debug-function
-	  frame-code-location eval-in-frame return-from-frame frame-catches
-	  frame-number frame frame-p
-
-	  do-debug-function-blocks debug-function-lambda-list
-	  debug-variable-info-available do-debug-function-variables
-	  debug-function-symbol-variables ambiguous-debug-variables
-	  preprocess-for-eval function-debug-function debug-function-function
-	  debug-function-kind debug-function-name debug-function
-	  debug-function-p debug-function-start-location
-
-	  do-debug-block-locations debug-block-successors debug-block
-	  debug-block-p debug-block-elsewhere-p
-
-	  make-breakpoint activate-breakpoint deactivate-breakpoint
-	  breakpoint-active-p breakpoint-hook-function breakpoint-info
-	  breakpoint-kind breakpoint-what breakpoint breakpoint-p
-	  delete-breakpoint function-end-cookie-valid-p
-
-	  code-location-debug-function code-location-debug-block
-	  code-location-top-level-form-offset code-location-form-number
-	  code-location-debug-source code-location-kind
-	  code-location code-location-p code-location-unknown-p code-location=
-
-	  debug-source-from debug-source-name debug-source-created
-	  debug-source-compiled debug-source-root-number
-	  debug-source-start-positions form-number-translations
-	  source-path-context debug-source debug-source-p
-
-	  debug-condition no-debug-info no-debug-function-returns
-	  no-debug-blocks lambda-list-unavailable
-
-	  debug-error unhandled-condition invalid-control-stack-pointer
-	  unknown-code-location unknown-debug-variable invalid-value
-	  ambiguous-variable-name frame-function-mismatch
-
-	  set-breakpoint-for-editor set-location-breakpoint-for-editor
-	  delete-breakpoint-for-editor
-
-	  *debugging-interpreter*))
-
-
-
-;;;; Conditions.
-
-;;; The interface to building debugging tools signals conditions that prevent
-;;; it from adhering to its contract.  These are serious-conditions because the
-;;; program using the interface must handle them before it can correctly
-;;; continue execution.  These debugging conditions are not errors since it is
-;;; no fault of the programmers that the conditions occur.  The interface does
-;;; not provide for programs to detect these situations other than calling a
-;;; routine that detects them and signals a condition.  For example,
-;;; programmers call A which may fail to return successfully due to a lack of
-;;; debug information, and there is no B the they could have called to realize
-;;; A would fail.  It is not an error to have called A, but it is an error for
-;;; the program to then ignore the signal generated by A since it cannot
-;;; continue without A's correctly returning a value or performing some
-;;; operation.
-;;;
-;;; Use DEBUG-SIGNAL to signal these conditions.
-;;;
-
-(define-condition debug-condition (serious-condition)
-  ()
-  (:documentation
-   "All debug-conditions inherit from this type.  These are serious conditions
-    that must be handled, but they are not programmer errors."))
-
-(define-condition no-debug-info (debug-condition)
-  ()
-  (:documentation "There is absolutely no debugging information available.")
-  (:report (lambda (condition stream)
-	     (declare (ignore condition))
-	     (fresh-line stream)
-	     (write-line "No debugging information available." stream))))
-
-(define-condition no-debug-function-returns (debug-condition)
-  (debug-function)
-  (:documentation
-   "The system could not return values from a frame with debug-function since
-    it lacked information about returning values.")
-  (:report (lambda (condition stream)
-	     (let ((fun (debug-function-function
-			 (no-debug-function-returns-debug-function condition))))
-	       (format stream
-		       "~&Cannot return values from ~:[frame~;~:*~S~] since ~
-			the debug information lacks details about returning ~
-			values here."
-		       fun)))))
-
-(define-condition no-debug-blocks (debug-condition)
-  (debug-function)
-  (:documentation "The debug-function has no debug-block information.")
-  (:report (lambda (condition stream)
-	     (format stream "~&~S has no debug-block information."
-		     (no-debug-blocks-debug-function condition)))))
-
-(define-condition no-debug-variables (debug-condition)
-  (debug-function)
-  (:documentation "The debug-function has no debug-variable information.")
-  (:report (lambda (condition stream)
-	     (format stream "~&~S has no debug-variable information."
-		     (no-debug-variables-debug-function condition)))))
-
-(define-condition lambda-list-unavailable (debug-condition)
-  (debug-function)
-  (:documentation
-   "The debug-function has no lambda-list since argument debug-variables are
-    unavailable.")
-  (:report (lambda (condition stream)
-	     (format stream "~&~S has no lambda-list information available."
-		     (lambda-list-unavailable-debug-function condition)))))
-
-(define-condition invalid-value (debug-condition)
-  ((debug-variable)
-   (frame))
-  (:report (lambda (condition stream)
-	     (format stream "~&~S has :invalid or :unknown value in ~S."
-		     (invalid-value-debug-variable condition)
-		     (invalid-value-frame condition)))))
-
-(define-condition ambiguous-variable-name (debug-condition)
-  ((name)
-   (frame))
-  (:report (lambda (condition stream)
-	     (format stream "~&~S names more than one valid variable in ~S."
-		     (ambiguous-variable-name-name condition)
-		     (ambiguous-variable-name-frame condition)))))
-
-
-;;;; Errors and DEBUG-SIGNAL.
-
-;;; The debug-internals code tries to signal all programmer errors as subtypes
-;;; of debug-error.  There are calls to ERROR signalling simple-errors, but
-;;; these dummy checks in the code and shouldn't come up.
-;;;
-;;; While under development, this code also signals errors in code branches
-;;; that remain unimplemented.
-;;;
-
-(define-condition debug-error (error) ()
-  (:documentation
-   "All programmer errors from using the interface for building debugging
-    tools inherit from this type."))
-
-(define-condition unhandled-condition (debug-error)
-  ((condition))
-  (:report (lambda (condition stream)
-	     (format stream "~&Unhandled debug-condition:~%~A"
-		     (unhandled-condition-condition condition)))))
-
-(define-condition unknown-code-location (debug-error)
-  ((code-location))
-  (:report (lambda (condition stream)
-	     (format stream "~&Invalid use of an unknown code-location -- ~S."
-		     (unknown-code-location-code-location condition)))))
-
-(define-condition unknown-debug-variable (debug-error)
-  ((debug-variable)
-   (debug-function))
-  (:report (lambda (condition stream)
-	     (format stream "~&~S not in ~S."
-		     (unknown-debug-variable-debug-variable condition)
-		     (unknown-debug-variable-debug-function condition)))))
-
-(define-condition invalid-control-stack-pointer (debug-error)
-  ()
-  (:report (lambda (condition stream)
-	     (declare (ignore condition))
-	     (fresh-line stream)
-	     (write-string "Invalid control stack pointer." stream))))
-
-(define-condition frame-function-mismatch (debug-error)
-  ((code-location)
-   (frame)
-   (form))
-  (:report (lambda (condition stream)
-	     (format stream
-		     "~&Form was preprocessed for ~S,~% but called on ~S:~%  ~S"
-		     (frame-function-mismatch-code-location condition)
-		     (frame-function-mismatch-frame condition)
-		     (frame-function-mismatch-form condition)))))
-
-
-;;; DEBUG-SIGNAL -- Internal.
-;;;
-;;; This signals debug-conditions.  If they go unhandled, then signal an
-;;; unhandled-condition error.
-;;;
-;;; ??? Get SIGNAL in the right package!
-;;;
-(defmacro debug-signal (datum &rest arguments)
-  `(let ((condition (make-condition ,datum ,@arguments)))
-     (signal condition)
-     (error 'unhandled-condition :condition condition)))
-
-
-
-;;;; Structures.
-
-;;; Most of these structures model information stored in internal data
-;;; structures created by the compiler.  Whenever comments preface an object or
-;;; type with "compiler", they refer to the internal compiler thing, not to the
-;;; object or type with the same name in the "DI" package.
-;;;
-
-
-;;;
-;;; Debug-variables
-;;;
-
-;;; These exist for caching data stored in packed binary form in compiler
-;;; debug-functions.  Debug-functions store these.
-;;;
-(defstruct (debug-variable (:print-function print-debug-variable)
-			   (:constructor nil))
-  ;;
-  ;; String name of variable.
-  (name nil :type simple-string)
-  ;;
-  ;; String name of package.  Nil when variable's name is uninterned.
-  (package nil :type (or null simple-string))
-  ;;
-  ;; Unique integer identification relative to other variables with the same
-  ;; name and package.
-  (id 0 :type c::index)
-  ;;
-  ;; Whether the variable always has a valid value.
-  (alive-p nil :type c::boolean))
-
-(defun print-debug-variable (obj str n)
-  (declare (ignore n))
-  (format str "#<Debug-Variable ~A:~A:~A>"
-	  (debug-variable-package obj)
-	  (debug-variable-name obj)
-	  (debug-variable-id obj)))
-
-(setf (documentation 'debug-variable-name 'function)
-  "Returns the name of the debug-variable.  The name is the name of the symbol
-   used as an identifier when writing the code.")
-
-(setf (documentation 'debug-variable-package 'function)
-  "Returns the package name of the debug-variable.  This is the package name of
-   the symbol used as an identifier when writing the code.")
-
-(setf (documentation 'debug-variable-id 'function)
-  "Returns the integer that makes debug-variable's name and package name unique
-   with respect to other debug-variable's in the same function.")
-
-
-(defstruct (compiled-debug-variable
-	    (:include debug-variable)
-	    (:constructor make-compiled-debug-variable
-			  (name package id alive-p sc-offset save-sc-offset)))
-  ;;
-  ;; Storage class and offset.  (unexported).
-  (sc-offset nil :type c::sc-offset)
-  ;;
-  ;; Storage class and offset when saved somewhere.
-  (save-sc-offset nil :type (or c::sc-offset null)))
-
-(defstruct (interpreted-debug-variable
-	    (:include debug-variable
-		      (alive-p t))
-	    (:constructor make-interpreted-debug-variable
-			  (name package ir1-var)))
-  ;;
-  ;; This is the IR1 structure that holds information about interpreted vars.
-  (ir1-var nil :type c::lambda-var))
-
-;;;
-;;; Frames
-;;;
-
-;;; These represents call-frames on the stack.
-;;;
-(defstruct (frame (:constructor nil))
-  ;;
-  ;; Next frame up.  Null when top frame.
-  (up nil :type (or frame null))
-  ;;
-  ;; Previous frame down.  Nil when the bottom frame.  Before computing the
-  ;; next frame down, this slot holds the frame pointer to the control stack
-  ;; for the given frame.  This lets us get the next frame down and the
-  ;; return-pc for that frame.
-  (%down :unparsed :type (or frame (member nil :unparsed)))
-  ;;
-  ;; Debug-function for function whose call this frame represents.
-  (debug-function nil :type debug-function)
-  ;;
-  ;; Code-location to continue upon return to frame.
-  (code-location nil :type code-location)
-  ;;
-  ;; A-list of catch-tags to code-locations.
-  (%catches :unparsed :type (or list (member :unparsed)))
-  ;;
-  ;; Pointer to frame on control stack.  (unexported)
-  ;; When is an interpreted-frame, this is an index into the interpreter's stack.
-  pointer
-  ;;
-  ;; This is the frame's number for prompt printing.  Top is zero.
-  number)
-
-(setf (documentation 'frame-up 'function)
-  "Returns the frame immediately above frame on the stack.  When frame is
-   the top of the stack, this returns nil.")
-
-(setf (documentation 'frame-debug-function 'function)
-  "Returns the debug-function for the function whose call frame represents.")
-
-(setf (documentation 'frame-code-location 'function)
-  "Returns the code-location where the frame's debug-function will continue
-   running when program execution returns to this frame.  If someone
-   interrupted this frame, the result could be an unknown code-location.")
-
-
-(defstruct (compiled-frame
-	    (:include frame)
-	    (:print-function print-compiled-frame)
-	    (:constructor make-compiled-frame
-			  (pointer up debug-function code-location number
-			   &optional escaped)))
-  ;;
-  ;; Indicates whether someone interrupted frame.  (unexported).
-  ;; If escaped, this is a pointer to the escape frame on the control stack.
-  escaped)
-
-(defun print-compiled-frame (obj str n)
-  (declare (ignore n))
-  (format str "#<Compiled-Frame ~S~:[~;, interrupted~]>"
-	  (debug-function-name (frame-debug-function obj))
-	  (compiled-frame-escaped obj)))
-
-
-(defstruct (interpreted-frame
-	    (:include frame)
-	    (:print-function print-interpreted-frame)
-	    (:constructor make-interpreted-frame
-			  (pointer up debug-function code-location number
-			   real-frame closure)))
-  ;;
-  ;; This points to the compiled-frame for EVAL:INTERNAL-APPLY-LOOP.
-  (real-frame nil :type compiled-frame)
-  ;;
-  ;; This is the closed over data used by the interpreter.
-  (closure nil :type simple-vector))
-
-(defun print-interpreted-frame (obj str n)
-  (declare (ignore n))
-  (format str "#<Interpreted-Frame ~S>"
-	  (debug-function-name (frame-debug-function obj))))
-
-;;;
-;;; Debug-functions
-;;;
-
-;;; These exist for caching data stored in packed binary form in compiler
-;;; debug-functions.  *compiled-debug-functions* maps a c::debug-function to a
-;;; debug-function.  There should only be one debug-function in existence for
-;;; any function; that is, all code-locations and other objects that reference
-;;; debug-functions point to unique objects.  This is due to the overhead in
-;;; cached information.
-;;;
-(defstruct (debug-function (:print-function print-debug-function))
-  ;;
-  ;; Some representation of the function arguments.  See
-  ;; DEBUG-FUNCTION-LAMBDA-LIST.
-  ;; NOTE: must parse vars before parsing arg list stuff.
-  (%lambda-list :unparsed)
-  ;;
-  ;; Cached debug-variable information.  (unexported).
-  ;; These are sorted by their name.
-  (debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
-  ;;
-  ;; Cached debug-block information.  This is nil when we have tried to parse
-  ;; the packed binary info, but none is available.
-  (blocks :unparsed :type (or simple-vector null (member :unparsed)))
-  ;;
-  ;; The actual function if available.
-  (%function :unparsed :type (or null function (member :unparsed))))
-
-(defun print-debug-function (obj str n)
-  (declare (ignore n))
-  (format str "#<~A-Debug-Function ~S>"
-	  (etypecase obj
-	    (compiled-debug-function "Compiled")
-	    (interpreted-debug-function "Interpreted")
-	    (bogus-debug-function "Bogus"))
-	  (debug-function-name obj)))
-
-
-(defstruct (compiled-debug-function
-	    (:include debug-function)
-	    (:constructor %make-compiled-debug-function
-			  (compiler-debug-fun component)))
-  ;;
-  ;; Compiler's dumped debug-function information.  (unexported).
-  (compiler-debug-fun nil :type c::compiled-debug-function)
-  ;;
-  ;; Code object.  (unexported).
-  component
-  ;;
-  ;; The :function-start breakpoint (if any) used to facilitate function
-  ;; end breakpoints.
-  (end-starter nil :type (or null breakpoint)))
-
-;;; This maps c::compiled-debug-functions to compiled-debug-functions, so we
-;;; can get at cached stuff and not duplicate compiled-debug-function
-;;; structures.
-;;;
-(defvar *compiled-debug-functions* (make-hash-table :test #'eq))
-
-;;; MAKE-COMPILED-DEBUG-FUNCTION -- Internal.
-;;;
-;;; Makes a compiled-debug-function for a c::compiler-debug-function and its
-;;; component.  This maps the latter to the former in
-;;; *compiled-debug-functions*.  If there already is a compiled-debug-function,
-;;; then this returns it from *compiled-debug-functions*.
-;;;
-(defun make-compiled-debug-function (compiler-debug-fun component)
-  (or (gethash compiler-debug-fun *compiled-debug-functions*)
-      (setf (gethash compiler-debug-fun *compiled-debug-functions*)
-	    (%make-compiled-debug-function compiler-debug-fun component))))
-
-
-(defstruct (interpreted-debug-function
-	    (:include debug-function)
-	    (:constructor %make-interpreted-debug-function (ir1-lambda)))
-  ;;
-  ;; This is the ir1 lambda this debug-function represents.
-  (ir1-lambda nil :type c::clambda))
-
-(defstruct (bogus-debug-function
-	    (:include debug-function)
-	    (:constructor make-bogus-debug-function
-			  (%name &aux (%lambda-list nil) (debug-vars nil)
-				 (blocks nil) (%function nil))))
-  %name)
-
-(defvar *ir1-lambda-debug-function* (make-hash-table :test #'eq))
-
-(defun make-interpreted-debug-function (ir1-lambda)
-  (let ((home-lambda (c::lambda-home ir1-lambda)))
-    (or (gethash home-lambda *ir1-lambda-debug-function*)
-	(setf (gethash home-lambda *ir1-lambda-debug-function*)
-	      (%make-interpreted-debug-function home-lambda)))))
-
-;;;
-;;; Debug-blocks.
-;;;
-
-;;; These exist for caching data stored in packed binary form in compiler
-;;; debug-blocks.
-;;;
-(defstruct (debug-block (:print-function print-debug-block))
-  ;;
-  ;; Code-locations where execution continues after this block.
-  (successors nil :type list)
-  ;;
-  ;; This indicates whether the block is a special glob of code shared by
-  ;; various functions and tucked away elsewhere in a component.  This kind of
-  ;; block has no start code-location.  In an interpreted-debug-block, this is
-  ;; always nil.  This slot is in all debug-blocks since it is an exported
-  ;; interface.
-  (elsewhere-p nil :type c::boolean))
-
-(defun print-debug-block (obj str n)
-  (declare (ignore n))
-  (format str "#<~A-Debug-Block ~S>"
-	  (etypecase obj
-	    (compiled-debug-block "Compiled")
-	    (interpreted-debug-block "Interpreted"))
-	  (debug-block-function-name obj)))
-
-(setf (documentation 'debug-block-successors 'function)
-  "Returns the list of possible code-locations where execution may continue
-   when the basic-block represented by debug-block completes its execution.")
-
-(setf (documentation 'debug-block-elsewhere-p 'function)
-  "Returns whether debug-block represents elsewhere code.")
-
-
-(defstruct (compiled-debug-block (:include debug-block)
-				 (:constructor
-				  make-compiled-debug-block
-				  (code-locations successors elsewhere-p)))
-  ;;
-  ;; Code-location information for the block.
-  (code-locations nil :type simple-vector))
-
-(defstruct (interpreted-debug-block (:include debug-block
-					      (elsewhere-p nil))
-				    (:constructor %make-interpreted-debug-block
-						  (ir1-block)))
-  ;;
-  ;; This is the IR1 block this debug-block represents.
-  (ir1-block nil :type c::cblock)
-  ;;
-  ;; Code-location information for the block.
-  (locations :unparsed :type (or (member :unparsed) simple-vector)))
-
-(defvar *ir1-block-debug-block* (make-hash-table :test #'eq))
-
-;;; MAKE-INTERPRETED-DEBUG-BLOCK -- Internal.
-;;;
-;;; This makes a debug-block for the interpreter's ir1-block.  If we have it in
-;;; the cache, return it.  If we need to make it, then first make debug-blocks
-;;; for all the ir1-blocks in ir1-block's home lambda; this makes sure all the
-;;; successors of ir1-block have debug-blocks.  We need this to fill in the
-;;; resulting debug-block's successors list with debug-blocks, not ir1-blocks.
-;;; After making all the possible debug-blocks we'll need to reference, go back
-;;; over the list of new debug-blocks and fill in their successor slots with
-;;; lists of debug-blocks.  Then look up our argument ir1-block to find its
-;;; debug-block since we know we have it now.
-;;;
-(defun make-interpreted-debug-block (ir1-block)
-  (check-type ir1-block c::cblock)
-  (let ((res (gethash ir1-block *ir1-block-debug-block*)))
-    (or res
-	(let ((lambda (c::block-home-lambda ir1-block)))
-	  (c::do-blocks (block (c::block-component ir1-block))
-	    (when (eq lambda (c::block-home-lambda block))
-	      (push (setf (gethash block *ir1-block-debug-block*)
-			  (%make-interpreted-debug-block block))
-		    res)))
-	  (dolist (block res)
-	    (let* ((successors nil)
-		   (cblock (interpreted-debug-block-ir1-block block))
-		   (succ (c::block-succ cblock))
-		   (valid-succ
-		    (if (and succ
-			     (eq (car succ)
-				 (c::component-tail
-				  (c::block-component cblock))))
-			()
-			succ)))
-	      (dolist (sblock valid-succ)
-		(let ((dblock (gethash sblock *ir1-block-debug-block*)))
-		  (when dblock
-		    (push dblock successors))))
-	      (setf (debug-block-successors block) (nreverse successors))))
-	  (gethash ir1-block *ir1-block-debug-block*)))))
-
-;;;
-;;; Breakpoints.
-;;;
-
-;;; This is an internal structure that manages information about a breakpoint
-;;; locations.  See *component-breakpoint-offsets*.
-;;;
-(defstruct (breakpoint-data (:print-function print-breakpoint-data)
-			    (:constructor make-breakpoint-data
-					  (component offset)))
-  ;;
-  ;; This is the component in which the breakpoint lies.
-  component
-  ;;
-  ;; This is the byte offset into the component.
-  (offset nil :type c::index)
-  ;;
-  ;; The original instruction replaced by the breakpoint.
-  (instruction nil :type (or null (unsigned-byte 32)))
-  ;;
-  ;; A list of user breakpoints at this location.
-  (breakpoints nil :type list))
-;;;
-(defun print-breakpoint-data (obj str n)
-  (declare (ignore n))
-  (format str "#<Breakpoint-Data ~S at ~S>"
-	  (debug-function-name
-	   (debug-function-from-pc (breakpoint-data-component obj)
-				   (breakpoint-data-offset obj)))
-	  (breakpoint-data-offset obj)))
-  
-(defstruct (breakpoint (:print-function print-breakpoint)
-		       (:constructor %make-breakpoint
-				     (hook-function what kind %info)))
-  ;;
-  ;; This is the function invoked when execution encounters the breakpoint.  It
-  ;; takes a frame, the breakpoint, and optionally a list of values.  Values
-  ;; are supplied for :function-end breakpoints as values to return for the
-  ;; function containing the breakpoint.  :function-end breakpoint
-  ;; hook-functions also take a cookie argument.  See cookie-fun slot.
-  (hook-function nil :type function)
-  ;;
-  ;; Code-location or debug-function.
-  (what nil :type (or code-location debug-function))
-  ;;
-  ;; :code-location, :function-start, or :function-end for that kind of
-  ;; breakpoint.  :unknown-return-partner if this is the partner of a
-  ;; :code-location breakpoint at an :unknown-return code-location.
-  (kind nil :type (member :code-location :function-start :function-end
-			  :unknown-return-partner))
-  ;;
-  ;; Status helps the user and the implementation.
-  (status :inactive :type (member :active :inactive :deleted))
-  ;;
-  ;; This is a backpointer to a breakpoint-data.
-  (internal-data nil :type (or null breakpoint-data))
-  ;;
-  ;; With code-locations whose type is :unknown-return, there are really
-  ;; two breakpoints: one at the multiple-value entry point, and one at
-  ;; the single-value entry point.  This slot holds the breakpoint for the
-  ;; other one, or NIL if this isn't at an :unknown-return code location.
-  (unknown-return-partner nil :type (or null breakpoint))
-  ;;
-  ;; :function-end breakpoints use a breakpoint at the :function-start to
-  ;; establish the end breakpoint upon function entry.  We do this by frobbing
-  ;; the LRA to jump to a special piece of code that breaks and provides the
-  ;; return values for the returnee.  This slot points to the start breakpoint,
-  ;; so we can activate, deactivate, and delete it.
-  (start-helper nil :type (or null breakpoint))
-  ;;
-  ;; This is a hook users supply to get a dynamically unique cookie for
-  ;; identifying :function-end breakpoint executions.  That is, if there is one
-  ;; :function-end breakpoint, but there may be multiple pending calls of its
-  ;; function on the stack.  This function takes the cookie, and the
-  ;; hook-function takes the cookie too.
-  (cookie-fun nil :type (or null function))
-  ;;
-  ;; This slot users can set with whatever information they find useful.
-  %info)
-;;;
-(defun print-breakpoint (obj str n)
-  (declare (ignore n))
-  (let ((what (breakpoint-what obj)))
-    (format str "#<Breakpoint ~S~:[~;~:*~S~]>"
-	    (etypecase what
-	      (code-location what)
-	      (debug-function (debug-function-name what)))
-	    (etypecase what
-	      (code-location nil)
-	      (debug-function (breakpoint-kind obj))))))
-
-(setf (documentation 'breakpoint-hook-function 'function)
-  "Returns the breakpoint's function the system calls when execution encounters
-   the breakpoint, and it is active.  This is SETF'able.")
-
-(setf (documentation 'breakpoint-what 'function)
-  "Returns the breakpoint's what specification.")
-
-(setf (documentation 'breakpoint-kind 'function)
-  "Returns the breakpoint's kind specification.")
-
-;;;
-;;; Code-locations.
-;;;
-
-(defstruct (code-location (:print-function print-code-location)
-			  (:constructor nil))
-  ;;
-  ;; This is the debug-function containing code-location.
-  (debug-function nil :type debug-function)
-  ;;
-  ;; This is initially :unsure.  Upon first trying to access an :unparsed slot,
-  ;; if the data is unavailable, then this becomes t, and the code-location is
-  ;; unknown.  If the data is available, this becomes nil, a known location.
-  ;; We can't use a separate type code-location for this since we must return
-  ;; code-locations before we can tell whether they're known or unknown.  For
-  ;; example, when parsing the stack, we don't want to unpack all the variables
-  ;; and blocks just to make frames.
-  (%unknown-p :unsure :type (member t nil :unsure))
-  ;;
-  ;; This is the debug-block containing code-location.
-  ;; Possibly toss this out and just find it in the blocks cache in
-  ;; debug-function.
-  (%debug-block :unparsed :type (or debug-block (member :unparsed)))
-  ;;
-  ;; This is the number of forms processed by the compiler or loader before
-  ;; the top-level form containing this code-location.
-  (%tlf-offset :unparsed :type (or c::index (member :unparsed)))
-  ;;
-  ;; This is the depth-first number of the node that begins code-location
-  ;; within its top-level form.
-  (%form-number :unparsed :type (or c::index (member :unparsed))))
-
-(defun print-code-location (obj str n)
-  (declare (ignore n))
-  (format str "#<~A ~S>"
-	  (ecase (code-location-unknown-p obj)
-	    ((nil) (etypecase obj
-		     (compiled-code-location "Compiled-Code-Location")
-		     (interpreted-code-location "Interpreted-Code-Location")))
-	    ((t) "Unknown-Code-Location"))
-	  (debug-function-name (code-location-debug-function obj))))
-
-(setf (documentation 'code-location-debug-function 'function)
-  "Returns the debug-function representing information about the function
-   corresponding to the code-location.")
-
-
-(defstruct (compiled-code-location
-	    (:include code-location)
-	    (:constructor make-known-code-location
-			  (pc debug-function %tlf-offset %form-number
-			      %live-set kind &aux (%unknown-p nil)))
-	    (:constructor make-compiled-code-location (pc debug-function)))
-  ;;
-  ;; This is an index into debug-function's component slot.
-  (pc nil :type c::index)
-  ;;
-  ;; This is a bit-vector indexed by a variable's position in
-  ;; DEBUG-FUNCTION-DEBUG-VARS indicating whether the variable has a valid
-  ;; value at this code-location.  (unexported).
-  (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
-  ;;
-  ;; (unexported)
-  ;; To see c::location-kind, do "(kernel:type-expand 'c::location-kind)".
-  (kind :unparsed :type (or (member :unparsed) c::location-kind)))
-
-(defstruct (interpreted-code-location
-	    (:include code-location
-		      (%unknown-p nil))
-	    (:constructor make-interpreted-code-location
-			  (ir1-node debug-function)))
-  ;;
-  ;; This is an index into debug-function's component slot.
-  (ir1-node nil :type c::node))
-  
-
-;;;
-;;; Debug-sources
-;;;
-
-(proclaim '(inline debug-source-root-number))
-;;;
-(defun debug-source-root-number (debug-source)
-  "Returns the number of top-level forms processed by the compiler before
-   compiling this source.  If this source is uncompiled, this is zero.  This
-   may be zero even if the source is compiled since the first form in the first
-   file compiled in one compilation, for example, must have a root number of
-   zero -- the compiler saw no other top-level forms before it."
-  (c::debug-source-source-root debug-source))
-
-(setf (documentation 'c::debug-source-from 'function)
-  "Returns an indication of the type of source.  The following are the possible
-   values:
-      :file    from a file (obtained by COMPILE-FILE if compiled).
-      :lisp    from Lisp (obtained by COMPILE if compiled).
-      :stream  from a non-file stream.")
-
-(setf (documentation 'c::debug-source-name 'function)
-  "Returns the actual source in some sense represented by debug-source, which
-   is related to DEBUG-SOURCE-FROM:
-      :file    the pathname of the file.
-      :lisp    a lambda-expression.
-      :stream  some descriptive string that's otherwise useless.")
-
-(setf (documentation 'c::debug-source-created 'function)
-  "Returns the universal time someone created the source.  This may be nil if
-   it is unavailable.")
-
-(setf (documentation 'c::debug-source-compiled 'function)
-  "Returns the time someone compiled the source.  This is nil if the source
-   is uncompiled.")
-
-(setf (documentation 'c::debug-source-start-positions 'function)
-  "This function returns the file position of each top-level form as an array
-   if debug-source is from a :file.  If DEBUG-SOURCE-FROM is :lisp or :stream,
-   this returns nil.")
-
-(setf (documentation 'c::debug-source-p 'function)
-  "Returns whether object is a debug-source.")
-
-
-
-;;;; Frames.
-
-;;; This is used in FIND-ESCAPE-FRAME and with the bogus components and LRAs
-;;; used for :function-end breakpoints.  When a components debug-info slot is
-;;; :bogus-lra, then the real-lra-slot contains the real component to continue
-;;; executing, as opposed to the bogus component which appeared in some frame's
-;;; LRA location.
-;;;
-(defconstant real-lra-slot vm:code-constants-offset)
-
-;;; These are magically converted by the compiler.
-;;;
-(defun kernel:current-sp () (kernel:current-sp))
-(defun kernel:current-fp () (kernel:current-fp))
-(defun kernel:stack-ref (s n) (kernel:stack-ref s n))
-(defun kernel:%set-stack-ref (s n value) (kernel:%set-stack-ref s n value))
-(defun kernel:function-code-header (fun) (kernel:function-code-header fun))
-(defun kernel:lra-code-header (lra) (kernel:lra-code-header lra))
-(defun kernel:make-lisp-obj (value) (kernel:make-lisp-obj value))
-(defun kernel:get-lisp-obj-address (thing) (kernel:get-lisp-obj-address thing))
-(defun kernel:function-word-offset (fun) (kernel:function-word-offset fun))
-;;;
-(defsetf kernel:stack-ref kernel:%set-stack-ref)
-
-(proclaim '(inline cstack-pointer-valid-p))
-(defun cstack-pointer-valid-p (x)
-  (declare (type system:system-area-pointer x))
-  (and (system:sap< x (kernel:current-sp))
-       (system:sap<= (alien:alien-sap (alien:extern-alien "control_stack"
-							  (* t)))
-		     x)))
-
-;;; TOP-FRAME -- Public.
-;;;
-(defun top-frame ()
-  "Returns the top frame of the control stack as it was before calling this
-   function."
-  (multiple-value-bind (fp pc)
-		       (kernel:%caller-frame-and-pc)
-    (possibly-an-interpreted-frame
-     (compute-calling-frame (system:int-sap (* (ext:truly-the fixnum fp)
-					       vm:word-bytes))
-			    pc nil)
-     nil)))
-
-;;; FLUSH-FRAMES-ABOVE -- public.
-;;; 
-(defun flush-frames-above (frame)
-  "Flush all of the frames above FRAME, and renumber all the frames below
-   FRAME."
-  (setf (frame-up frame) nil)
-  (do ((number 0 (1+ number))
-       (frame frame (frame-%down frame)))
-      ((not (frame-p frame)))
-    (setf (frame-number frame) number)))
-
-;;; FRAME-DOWN -- Public.
-;;;
-;;; We have to access the old-fp and return-pc out of frame and pass them to
-;;; COMPUTE-CALLING-FRAME.
-;;;
-(defun frame-down (frame)
-  "Returns the frame immediately below frame on the stack.  When frame is
-   the bottom of the stack, this returns nil."
-  (let ((down (frame-%down frame)))
-    (if (eq down :unparsed)
-	(let* ((real (frame-real-frame frame))
-	       (debug-fun (frame-debug-function real)))
-	  (setf (frame-%down frame)
-		(etypecase debug-fun
-		  (compiled-debug-function
-		   (let ((c-d-f (compiled-debug-function-compiler-debug-fun
-				 debug-fun)))
-		     (possibly-an-interpreted-frame
-		      (compute-calling-frame
-		       (system:int-sap
-			(* (get-context-value
-			    real vm::ocfp-save-offset
-			    (c::compiled-debug-function-old-fp c-d-f))
-			   vm:word-bytes))
-		       (get-context-value
-			real vm::lra-save-offset
-			(c::compiled-debug-function-return-pc c-d-f))
-		       frame)
-		      frame)))
-		  (bogus-debug-function
-		   (let ((fp (frame-pointer real)))
-		     (compute-calling-frame
-		      (system:sap-ref-sap fp (* vm::ocfp-save-offset
-						vm:word-bytes))
-		      (kernel:stack-ref fp vm::lra-save-offset)
-		      frame))))))
-	down)))
-
-
-;;; GET-CONTEXT-VALUE  --  Internal.
-;;;
-;;; Get the old FP or return PC out of frame.  Stack-slot is the standard save
-;;; location offset on the stack.  Loc is the saved sc-offset describing the
-;;; main location.
-;;;
-(defun get-context-value (frame stack-slot loc)
-  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
-	   (type c::sc-offset loc))
-  (let ((pointer (frame-pointer frame))
-	(escaped (compiled-frame-escaped frame)))
-    (if escaped
-	(sub-access-debug-var-slot pointer loc escaped)
-	(kernel:stack-ref pointer stack-slot))))
-;;;
-(defun (setf get-context-value) (value frame stack-slot loc)
-  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
-	   (type c::sc-offset loc))
-  (let ((pointer (frame-pointer frame))
-	(escaped (compiled-frame-escaped frame)))
-    (if escaped
-	(sub-set-debug-var-slot pointer loc value escaped)
-	(setf (kernel:stack-ref pointer stack-slot) value))))
-
-
-(defvar *debugging-interpreter* nil
-  "When set, the debugger foregoes making interpreted-frames, so you can
-   debug the functions that manifest the interpreter.")
-
-;;; POSSIBLY-AN-INTERPRETED-FRAME -- Internal.
-;;;
-;;; This takes a newly computed frame, frame, and the frame above it on the
-;;; stack, up-frame, which is possibly nil.  Frame is nil when we hit the
-;;; bottom of the control stack.  When frame represents a call to
-;;; EVAL::INTERNAL-APPLY-LOOP, we make an interpreted frame to replace frame.
-;;; The interpreted frame points to frame.
-;;;
-(defun possibly-an-interpreted-frame (frame up-frame)
-  (if (or (not frame)
-	  (not (eq (debug-function-name (frame-debug-function frame))
-		   'eval::internal-apply-loop))
-	  *debugging-interpreter*
-	  (compiled-frame-escaped frame))
-      frame
-      (flet ((get-var (name location)
-	       (let ((vars (di:ambiguous-debug-variables
-			    (di:frame-debug-function frame) name)))
-		 (when (or (null vars) (> (length vars) 1))
-		   (error "Zero or more than one ~A variable in ~
-			   EVAL::INTERNAL-APPLY-LOOP?"
-			  (string-downcase name)))
-		 (if (eq (debug-variable-validity (car vars) location)
-			 :valid)
-		     (car vars)))))
-	(let* ((code-loc (frame-code-location frame))
-	       (ptr-var (get-var "FRAME-PTR" code-loc))
-	       (node-var (get-var "NODE" code-loc))
-	       (closure-var (get-var "CLOSURE" code-loc)))
-	  (if (and ptr-var node-var closure-var)
-	      (let* ((node (debug-variable-value node-var frame))
-		     (d-fun (make-interpreted-debug-function
-			     (c::block-home-lambda (c::node-block node)))))
-		(make-interpreted-frame
-		 (debug-variable-value ptr-var frame)
-		 up-frame
-		 d-fun
-		 (make-interpreted-code-location node d-fun)
-		 (frame-number frame)
-		 frame
-		 (debug-variable-value closure-var frame)))
-	      frame)))))
-
-
-;;; COMPUTE-CALLING-FRAME -- Internal.
-;;;
-;;; This returns a frame for the one existing in time immediately prior to the
-;;; frame referenced by current-fp.  This is current-fp's caller or the next
-;;; frame down the control stack.  If there is no down frame, this returns nil
-;;; for the bottom of the stack.  Up-frame is the up link for the resulting
-;;; frame object, and it is nil when we call this to get the top of the stack.
-;;;
-;;; The current frame contains the pointer to the temporally previous frame we
-;;; want, and the current frame contains the pc at which we will continue
-;;; executing upon returning to that previous frame.
-;;;
-;;; Note: Sometimes LRA is actually a fixnum.  This happens when lisp calls
-;;; into C.  In this case, the code object is stored on the stack after the
-;;; LRA, and the LRA is the word offset.
-;;; 
-(defun compute-calling-frame (caller lra up-frame)
-  (declare (type system:system-area-pointer caller))
-  (when (cstack-pointer-valid-p caller)
-    (multiple-value-bind
-	(code pc-offset escaped)
-	(if lra
-	    (multiple-value-bind
-		(word-offset code)
-		(if (ext:fixnump lra)
-		    (let ((fp (frame-pointer up-frame)))
-		      (values lra
-			      (kernel:stack-ref fp (1+ vm::lra-save-offset))))
-		    (values (kernel:get-header-data lra)
-			    (kernel:lra-code-header lra)))
-	      (if code
-		  (values code
-			  (* (1+ (- word-offset (kernel:get-header-data code)))
-			     vm:word-bytes)
-			  nil)
-		  (values :foreign-function
-			  0
-			  nil)))
-	    (find-escaped-frame caller))
-      (if (eq (kernel:%code-debug-info code) :bogus-lra)
-	  (let ((real-lra (kernel:code-header-ref code real-lra-slot)))
-	    (compute-calling-frame caller real-lra up-frame))
-	  (let ((d-fun (case code
-			 (:undefined-function
-			  (make-bogus-debug-function
-			   "The Undefined Function"))
-			 (:foreign-function
-			  (make-bogus-debug-function
-			   "Foreign function call land"))
-			 ((nil)
-			  (make-bogus-debug-function
-			   "Bogus stack frame"))
-			 (t
-			  (debug-function-from-pc code pc-offset)))))
-	    (make-compiled-frame caller up-frame d-fun
-				 (code-location-from-pc d-fun pc-offset
-							escaped)
-				 (if up-frame (1+ (frame-number up-frame)) 0)
-				 escaped))))))
-
-(defun find-escaped-frame (frame-pointer)
-  (declare (type system:system-area-pointer frame-pointer))
-  (dotimes (index lisp::*free-interrupt-context-index* (values nil 0 nil))
-    (alien:with-alien
-	((lisp-interrupt-contexts (array (* unix:sigcontext) nil) :extern))
-      (let ((scp (alien:deref lisp-interrupt-contexts index)))
-	(when (= (system:sap-int frame-pointer)
-		 (vm:sigcontext-register scp vm::cfp-offset))
-	  (system:without-gcing
-	   (let ((code (code-object-from-bits
-			(vm:sigcontext-register scp vm::code-offset))))
-	     (when (symbolp code)
-	       (return (values code 0 scp)))
-	     (let* ((code-header-len (* (kernel:get-header-data code)
-					vm:word-bytes))
-		    (pc-offset
-		     (- (system:sap-int
-			 (vm:sigcontext-program-counter scp))
-			(- (kernel:get-lisp-obj-address code)
-			   vm:other-pointer-type)
-			code-header-len)))
-	       ;; Check to see if we were executing in a branch delay slot.
-	       #+pmax  ; pmax only
-	       (when (logbitp 31 (alien:slot scp 'mips::sc-cause))
-		 (incf pc-offset vm:word-bytes))
-	       (unless (<= 0 pc-offset
-			   (* (kernel:code-header-ref code
-						      vm:code-code-size-slot)
-			      vm:word-bytes))
-		 ;; We were in an assembly routine.  Therefore, use the LRA as
-		 ;; the pc.
-		 (setf pc-offset
-		       (- (vm:sigcontext-register scp vm::lra-offset)
-			  (kernel:get-lisp-obj-address code)
-			  code-header-len)))
-	       (return
-		(if (eq (kernel:%code-debug-info code) :bogus-lra)
-		    (let ((real-lra (kernel:code-header-ref code
-							    real-lra-slot)))
-		      (values (kernel:lra-code-header real-lra)
-			      (kernel:get-header-data real-lra)
-			      nil))
-		    (values code pc-offset scp)))))))))))
-
-;;; CODE-OBJECT-FROM-BITS  --  internal.
-;;;
-;;; Find the code object corresponding to the object represented by bits and
-;;; return it.  We assume bogus functions correspond to the
-;;; undefined-function.
-;;; 
-(defun code-object-from-bits (bits)
-  (declare (type (unsigned-byte 32) bits))
-  (let ((object (kernel:make-lisp-obj bits)))
-    (if (functionp object)
-	(or (kernel:function-code-header object)
-	    :undefined-function)
-	(let ((lowtag (kernel:get-lowtag object)))
-	  (if (= lowtag vm:other-pointer-type)
-	      (let ((type (kernel:get-type object)))
-		(cond ((= type vm:code-header-type)
-		       object)
-		      ((= type vm:return-pc-header-type)
-		       (kernel:lra-code-header object))
-		      (t
-		       nil))))))))
-
-;;;
-;;; Frame utilities.
-;;;
-
-;;; DEBUG-FUNCTION-FROM-PC -- Internal.
-;;;
-;;; This returns a compiled-debug-function for code and pc.  We fetch the
-;;; c::debug-info and run down its function-map to get a
-;;; c::compiled-debug-function from the pc.  The result only needs to reference
-;;; the component, for function constants, and the c::compiled-debug-function.
-;;;
-(defun debug-function-from-pc (component pc)
-  (let ((info (kernel:%code-debug-info component)))
-    (cond
-     ((not info)
-      (debug-signal 'no-debug-info))
-     ((eq info :bogus-lra)
-      (make-bogus-debug-function "Function End Breakpoint"))
-     (t
-      (let* ((function-map (get-debug-info-function-map info))
-	     (len (length function-map)))
-	(declare (simple-vector function-map))
-	(if (= len 1)
-	    (make-compiled-debug-function (svref function-map 0) component)
-	    (let ((i 1)
-		  (elsewhere-p
-		   (>= pc (c::compiled-debug-function-elsewhere-pc
-			   (svref function-map 0)))))
-	      (declare (type c::index i))
-	      (loop
-		(when (or (= i len)
-			  (< pc (if elsewhere-p
-				    (c::compiled-debug-function-elsewhere-pc
-				     (svref function-map (1+ i)))
-				    (svref function-map i))))
-		  (return (make-compiled-debug-function
-			   (svref function-map (1- i))
-			   component)))
-		(incf i 2)))))))))
-
-;;; CODE-LOCATION-FROM-PC -- Internal.
-;;;
-;;; This returns a code-location for the compiled-debug-function, debug-fun,
-;;; and the pc into its code vector.  If we stopped at a breakpoint, find
-;;; the code-location for that breakpoint.  Otherwise, make an :unsure code
-;;; location, so it can be filled in when we figure out what is going on.
-;;;
-(defun code-location-from-pc (debug-fun pc escaped)
-  (or (and (compiled-debug-function-p debug-fun)
-	   escaped
-	   (let ((data (breakpoint-data
-			(compiled-debug-function-component debug-fun)
-			pc nil)))
-	     (when (and data (breakpoint-data-breakpoints data))
-	       (let ((what (breakpoint-what
-			    (first (breakpoint-data-breakpoints data)))))
-		 (when (compiled-code-location-p what)
-		   what)))))
-      (make-compiled-code-location pc debug-fun)))
-
-;;; FRAME-CATCHES -- Public.
-;;;
-(defun frame-catches (frame)
-  "Returns an a-list mapping catch tags to code-locations.  These are
-   code-locations at which execution would continue with frame as the top
-   frame if someone threw to the corresponding tag."
-  (let ((catch (system:int-sap (* lisp::*current-catch-block* vm:word-bytes)))
-	(res nil)
-	(fp (frame-pointer (frame-real-frame frame))))
-    (loop
-      (when (zerop (sap-int catch)) (return (nreverse res)))
-      (when (sap= fp
-		  (system:int-sap
-		   (* (kernel:stack-ref catch vm:catch-block-current-cont-slot)
-		      vm:word-bytes)))
-	(let* ((lra (kernel:stack-ref catch vm:catch-block-entry-pc-slot))
-	       (component
-		(kernel:stack-ref catch vm:catch-block-current-code-slot))
-	       (word-offset (- (1+ (kernel:get-header-data lra))
-			       (kernel:get-header-data component))))
-	  (push (cons (kernel:stack-ref catch vm:catch-block-tag-slot)
-		      (make-compiled-code-location
-		       (* word-offset vm:word-bytes)
-		       (frame-debug-function frame)))
-		res)))
-      (setf catch
-	    (system:sap-ref-sap catch
-				(* vm:catch-block-previous-catch-slot
-				   vm:word-bytes))))))
-
-;;; FRAME-REAL-FRAME -- Internal.
-;;;
-;;; If an interpreted frame, return the real frame, otherwise frame.
-;;;
-(defun frame-real-frame (frame)
-  (etypecase frame
-    (compiled-frame frame)
-    (interpreted-frame (interpreted-frame-real-frame frame))))
-
-
-
-;;;; Debug-functions.
-
-;;; DO-DEBUG-FUNCTION-BLOCKS -- Public.
-;;;
-(defmacro do-debug-function-blocks ((block-var debug-function &optional result)
-				    &body body)
-  "Executes the forms in a context with block-var bound to each debug-block in
-   debug-function successively.  Result is an optional form to execute for
-   return values, and DO-DEBUG-FUNCTION-BLOCKS returns nil if there is no
-   result form.  This signals a no-debug-blocks condition when the
-   debug-function lacks debug-block information."
-  (let ((blocks (gensym))
-	(i (gensym)))
-    `(let ((,blocks (debug-function-debug-blocks ,debug-function)))
-       (declare (simple-vector ,blocks))
-       (dotimes (,i (length ,blocks) ,result)
-	 (let ((,block-var (svref ,blocks ,i)))
-	   ,@body)))))
-
-;;; DO-DEBUG-FUNCTION-VARIABLES -- Public.
-;;;
-(defmacro do-debug-function-variables ((var debug-function &optional result)
-				       &body body)
-  "Executes body in a context with var bound to each debug-variable in
-   debug-function.  This returns the value of executing result (defaults to
-   nil).  This may iterate over only some of debug-function's variables or none
-   depending on debug policy; for example, possibly the compilation only
-   preserved argument information."
-  (let ((vars (gensym))
-	(i (gensym)))
-    `(let ((,vars (debug-function-debug-variables ,debug-function)))
-       (declare (type (or null simple-vector) ,vars))
-       (if ,vars
-	   (dotimes (,i (length ,vars) ,result)
-	     (let ((,var (svref ,vars ,i)))
-	       ,@body))
-	   ,result))))
-
-;;; DEBUG-FUNCTION-FUNCTION -- Public.
-;;;
-(defun debug-function-function (debug-function)
-  "Returns the Common Lisp function associated with the debug-function.  This
-   returns nil if the function is unavailable or is non-existent as a user
-   callable function object."
-  (let ((cached-value (debug-function-%function debug-function)))
-    (if (eq cached-value :unparsed)
-	(setf (debug-function-%function debug-function)
-	      (etypecase debug-function
-		(compiled-debug-function
-		 (let ((component
-			(compiled-debug-function-component debug-function))
-		       (start-pc
-			(c::compiled-debug-function-start-pc
-			 (compiled-debug-function-compiler-debug-fun
-			  debug-function))))
-		   (do ((entry (kernel:%code-entry-points component)
-			       (kernel:%function-next entry)))
-		       ((null entry) nil)
-		     (when (= start-pc
-			      (c::compiled-debug-function-start-pc
-			       (compiled-debug-function-compiler-debug-fun
-				(function-debug-function entry))))
-		       (return entry)))))
-		(interpreted-debug-function
-		 (c::lambda-eval-info-function
-		  (c::leaf-info
-		   (interpreted-debug-function-ir1-lambda debug-function))))
-		(bogus-debug-function nil)))
-	cached-value)))
-
-
-;;; DEBUG-FUNCTION-NAME -- Public.
-;;;
-(defun debug-function-name (debug-function)
-  "Returns the name of the function represented by debug-function.  This may
-   be a string or a cons; do not assume it is a symbol."
-  (etypecase debug-function
-    (compiled-debug-function
-     (c::compiled-debug-function-name
-      (compiled-debug-function-compiler-debug-fun debug-function)))
-    (interpreted-debug-function
-     (c::lambda-name (interpreted-debug-function-ir1-lambda debug-function)))
-    (bogus-debug-function
-     (bogus-debug-function-%name debug-function))))
-
-
-;;; FUNCTION-DEBUG-FUNCTION -- Public.
-;;;
-(defun function-debug-function (fun)
-  "Returns a debug-function that represents debug information for function."
-  (if (eval:interpreted-function-p fun)
-      (let ((eval-fun (eval::get-eval-function fun)))
-	(make-interpreted-debug-function
-	 (or (eval::eval-function-definition eval-fun)
-	     (eval::convert-eval-fun eval-fun))))
-      (let* ((name (kernel:%function-name fun))
-	     (component (kernel:function-code-header fun))
-	     (res (find-if
-		   #'(lambda (x)
-		       (and (c::compiled-debug-function-p x)
-			    (eq (c::compiled-debug-function-name x) name)
-			    (eq (c::compiled-debug-function-kind x) nil)))
-		   (get-debug-info-function-map
-		    (kernel:%code-debug-info component)))))
-	(if res
-	    (make-compiled-debug-function res component)
-	    ;; This used to be the non-interpreted branch, but William wrote it
-	    ;; to return the debug-fun of fun's XEP instead of fun's debug-fun.
-	    ;; The above code does this more correctly, but it doesn't get or
-	    ;; eliminate all appropriate cases.  It mostly works, and probably
-	    ;; works for all named functions anyway.
-	    (debug-function-from-pc component
-				    (* (- (kernel:function-word-offset fun)
-					  (kernel:get-header-data component))
-				       vm:word-bytes))))))
-
-
-;;; DEBUG-FUNCTION-KIND -- Public.
-;;;
-(defun debug-function-kind (debug-function)
-  "Returns the kind of the function which is one of :optional, :external,
-   :top-level, :cleanup, nil."
-  (etypecase debug-function
-    (compiled-debug-function
-     (c::compiled-debug-function-kind
-      (compiled-debug-function-compiler-debug-fun debug-function)))
-    (interpreted-debug-function
-     (c::lambda-kind (interpreted-debug-function-ir1-lambda debug-function)))
-    (bogus-debug-function
-     nil)))
-
-;;; DEBUG-VARIABLE-INFO-AVAILABLE -- Public.
-;;;
-(defun debug-variable-info-available (debug-function)
-  "Returns whether there is any variable information for debug-function."
-  (not (not (debug-function-debug-variables debug-function))))
-
-;;; DEBUG-FUNCTION-SYMBOL-VARIABLES -- Public.
-;;;
-(defun debug-function-symbol-variables (debug-function symbol)
-  "Returns a list of debug-variables in debug-function having the same name
-   and package as symbol.  If symbol is uninterned, then this returns a list of
-   debug-variables without package names and with the same name as symbol.  The
-   result of this function is limited to the availability of variable
-   information in debug-function; for example, possibly debug-function only
-   knows about its arguments."
-  (let ((vars (ambiguous-debug-variables debug-function (symbol-name symbol)))
-	(package (if (symbol-package symbol)
-		     (package-name (symbol-package symbol)))))
-    (delete-if (if (stringp package)
-		   #'(lambda (var)
-		       (let ((p (debug-variable-package var)))
-			 (or (not (stringp p))
-			     (string/= p package))))
-		   #'(lambda (var)
-		       (stringp (debug-variable-package var))))
-	       vars)))
-
-;;; AMBIGUOUS-DEBUG-VARIABLES -- Public.
-;;;
-(defun ambiguous-debug-variables (debug-function name-prefix-string)
-   "Returns a list of debug-variables in debug-function whose names contain
-    name-prefix-string as an intial substring.  The result of this function is
-    limited to the availability of variable information in debug-function; for
-    example, possibly debug-function only knows about its arguments."
-  (declare (simple-string name-prefix-string))
-  (let ((variables (debug-function-debug-variables debug-function)))
-    (declare (type (or null simple-vector) variables))
-    (if variables
-	(let* ((len (length variables))
-	       (prefix-len (length name-prefix-string))
-	       (pos (find-variable name-prefix-string variables len))
-	       (res nil))
-	  (when pos
-	    ;; Find names from pos to variable's len that contain prefix.
-	    (do ((i pos (1+ i)))
-		((= i len))
-	      (let* ((var (svref variables i))
-		     (name (debug-variable-name var))
-		     (name-len (length name)))
-		(declare (simple-string name))
-		(when (/= (or (string/= name-prefix-string name
-					:end1 prefix-len :end2 name-len)
-			      prefix-len)
-			  prefix-len)
-		  (return))
-		(push var res)))
-	    (setq res (nreverse res)))
-	  res))))
-
-;;; FIND-VARIABLE -- Internal.
-;;;
-;;; This returns a position in variables for one containing name as an initial
-;;; substring.  End is the length of variables if supplied.
-;;;
-(defun find-variable (name variables &optional end)
-  (declare (simple-vector variables)
-	   (simple-string name))
-  (let ((name-len (length name)))
-    (position name variables
-	      :test #'(lambda (x y)
-			(let* ((y (debug-variable-name y))
-			       (y-len (length y)))
-			  (declare (simple-string y))
-			  (and (>= y-len name-len)
-			       (string= x y :end1 name-len :end2 name-len))))
-	      :end (or end (length variables)))))
-
-;;; DEBUG-FUNCTION-LAMBDA-LIST -- Public.
-;;;
-(defun debug-function-lambda-list (debug-function)
-  "Returns a list representing the lambda-list for debug-function.  The list
-   has the following structure:
-      (required-var1 required-var2
-       ...
-       (:optional var3 suppliedp-var4)
-       (:optional var5)
-       ...
-       (:rest var6) (:rest var7)
-       ...
-       (:keyword keyword-symbol var8 suppliedp-var9)
-       (:keyword keyword-symbol var10)
-       ...
-      )
-   Each VARi is a debug-variable; however it may be the symbol :deleted it
-   is unreferenced in debug-function.  This signals a lambda-list-unavaliable
-   condition when there is no argument list information."
-  (etypecase debug-function
-    (compiled-debug-function
-     (compiled-debug-function-lambda-list debug-function))
-    (interpreted-debug-function
-     (interpreted-debug-function-lambda-list debug-function))
-    (bogus-debug-function
-     nil)))
-
-;;; INTERPRETED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal.
-;;; 
-;;; The hard part is when the lambda-list is unparsed.  If it is unparsed,
-;;; and all the arguments are required, this is still pretty easy; just
-;;; whip the appropriate debug-variables into a list.  Otherwise, we have
-;;; to pick out the funny arguments including any suppliedp variables.  In
-;;; this situation, the ir1-lambda is an external entry point that takes
-;;; arguments users really pass in.  It looks at those and computes defaults
-;;; and suppliedp variables, ultimately passing everything defined as a
-;;; a parameter to the real function as final arguments.  If this has to
-;;; compute the lambda list, it caches it in debug-function.
-;;;
-(defun interpreted-debug-function-lambda-list (debug-function)
-  (let ((lambda-list (debug-function-%lambda-list debug-function))
-	(debug-vars (debug-function-debug-variables debug-function))
-	(ir1-lambda (interpreted-debug-function-ir1-lambda debug-function))
-	(res nil))
-    (if (eq lambda-list :unparsed)
-	(flet ((frob (v debug-vars)
-		 (if (c::lambda-var-refs v)
-		     (find v debug-vars
-			   :key #'interpreted-debug-variable-ir1-var)
-		     :deleted)))
-	  (let ((xep-args (c::lambda-optional-dispatch ir1-lambda)))
-	    (if (and xep-args
-		     (eq (c::optional-dispatch-main-entry xep-args) ir1-lambda))
-		;;
-		;; There are rest, optional, keyword, and suppliedp vars.
-		(let ((final-args (c::lambda-vars ir1-lambda)))
-		  (dolist (xep-arg (c::optional-dispatch-arglist xep-args))
-		    (let ((info (c::lambda-var-arg-info xep-arg))
-			  (final-arg (pop final-args)))
-		      (cond (info
-			     (case (c::arg-info-kind info)
-			       (:required
-				(push (frob final-arg debug-vars) res))
-			       (:keyword
-				(push (list :keyword
-					    (c::arg-info-keyword info)
-					    (frob final-arg debug-vars))
-				      res))
-			       (:rest
-				(push (list :rest (frob final-arg debug-vars))
-				      res))
-			       (:optional
-				(push (list :optional
-					    (frob final-arg debug-vars))
-				      res)))
-			     (when (c::arg-info-supplied-p info)
-			       (nconc
-				(car res)
-				(list (frob (pop final-args) debug-vars)))))
-			    (t
-			     (push (frob final-arg debug-vars) res)))))
-		  (setf (debug-function-%lambda-list debug-function)
-			(nreverse res)))
-		;;
-		;; All required args, so return them in a list.
-		(dolist (v (c::lambda-vars ir1-lambda)
-			   (setf (debug-function-%lambda-list debug-function)
-				 (nreverse res)))
-		  (push (frob v debug-vars) res)))))
-	;;
-	;; Everything's unparsed and cached, so return it.
-	lambda-list)))
-
-;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal.
-;;;
-;;; If this has to compute the lambda list, it caches it in debug-function.
-;;;
-(defun compiled-debug-function-lambda-list (debug-function)
-  (let ((lambda-list (debug-function-%lambda-list debug-function)))
-    (cond ((eq lambda-list :unparsed)
-	   (multiple-value-bind
-	       (args argsp)
-	       (parse-compiled-debug-function-lambda-list debug-function)
-	     (setf (debug-function-%lambda-list debug-function) args)
-	     (if argsp
-		 args
-		 (debug-signal 'lambda-list-unavailable
-			       :debug-function debug-function))))
-	  (lambda-list)
-	  ((bogus-debug-function-p debug-function)
-	   nil)
-	  ((c::compiled-debug-function-arguments
-	    (compiled-debug-function-compiler-debug-fun
-	     debug-function))
-	   ;; If the packed information is there (whether empty or not) as
-	   ;; opposed to being nil, then returned our cached value (nil).
-	   nil)
-	  (t
-	   ;; Our cached value is nil, and the packed lambda-list information
-	   ;; is nil, so we don't have anything available.
-	   (debug-signal 'lambda-list-unavailable
-			 :debug-function debug-function)))))
-
-;;; PARSE-COMPILED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal.
-;;;
-;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST calls this when a
-;;; compiled-debug-function has no lambda-list information cached.  It returns
-;;; the lambda-list as the first value and whether there was any argument
-;;; information as the second value.  Therefore, nil and t means there were no
-;;; arguments, but nil and nil means there was no argument information.
-;;;
-(defun parse-compiled-debug-function-lambda-list (debug-function)
-  (let ((args (c::compiled-debug-function-arguments
-	       (compiled-debug-function-compiler-debug-fun
-		debug-function))))
-    (cond
-     ((not args)
-      (values nil nil))
-     ((eq args :minimal)
-      (values (coerce (debug-function-debug-variables debug-function) 'list)
-	      t))
-     (t
-      (let ((vars (debug-function-debug-variables debug-function))
-	    (i 0)
-	    (len (length args))
-	    (res nil)
-	    (optionalp nil))
-	(declare (type (or null simple-vector) vars))
-	(loop
-	  (when (>= i len) (return))
-	  (let ((ele (aref args i)))
-	    (cond
-	     ((symbolp ele)
-	      (case ele
-		(c::deleted
-		 ;; Deleted required arg at beginning of args array.
-		 (push :deleted res))
-		(c::optional-args
-		 (setf optionalp t))
-		(c::supplied-p
-		 ;; supplied-p var immediately following keyword or optional.
-		 ;; Stick the extra var in the result element representing
-		 ;; the keyword or optional, which is the previous one.
-		 (nconc (car res)
-			(list (compiled-debug-function-lambda-list-var
-			       args (incf i) vars))))
-		(c::rest-arg
-		 (push (list :rest
-			     (compiled-debug-function-lambda-list-var
-			      args (incf i) vars))
-		       res))
-		(c::more-arg
-		 (error "I thought I'd never see a more-arg?"))
-		(t
-		 ;; Keyword arg.
-		 (push (list :keyword
-			     ele
-			     (compiled-debug-function-lambda-list-var
-			      args (incf i) vars))
-		       res))))
-	     (optionalp
-	      ;; We saw an optional marker, so the following non-symbols are
-	      ;; indexes indicating optional variables.
-	      (push (list :optional (svref vars ele)) res))
-	     (t
-	      ;; Required arg at beginning of args array.
-	      (push (svref vars ele) res))))
-	  (incf i))
-	(values (nreverse res) t))))))
-
-;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST-VAR -- Internal
-;;;
-;;; Used in COMPILED-DEBUG-FUNCTION-LAMBDA-LIST.
-;;;
-(defun compiled-debug-function-lambda-list-var (args i vars)
-  (declare (type (simple-array * (*)) args)
-	   (simple-vector vars))
-  (let ((ele (aref args i)))
-    (cond ((not (symbolp ele)) (svref vars ele))
-	  ((eq ele 'c::deleted) :deleted)
-	  (t (error "Malformed arguments description.")))))
-
-;;; COMPILED-DEBUG-FUNCTION-DEBUG-INFO -- Internal.
-;;;
-(defun compiled-debug-function-debug-info (debug-fun)
-  (kernel:%code-debug-info (compiled-debug-function-component debug-fun)))
-
-
-
-;;;; Unpacking variable and basic block data.
-
-(defvar *parsing-buffer*
-  (make-array 20 :adjustable t :fill-pointer t))
-(defvar *other-parsing-buffer*
-  (make-array 20 :adjustable t :fill-pointer t))
-;;;
-;;; WITH-PARSING-BUFFER -- Internal.
-;;;
-;;; PARSE-DEBUG-BLOCKS, PARSE-DEBUG-VARIABLES and UNCOMPACT-FUNCTION-MAP use
-;;; this to unpack binary encoded information.  It returns the values returned
-;;; by the last form in body.
-;;;
-;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at element
-;;; zero, and makes sure if we unwind, we nil out any set elements for GC
-;;; purposes.
-;;;
-;;; This also binds other-var to *other-parsing-buffer* when it is supplied,
-;;; making sure it starts at element zero and that we nil out any elements if
-;;; we unwind.
-;;;
-;;; This defines the local macro RESULT that takes a buffer, copies its
-;;; elements to a resulting simple-vector, nil's out elements, and restarts
-;;; the buffer at element zero.  RESULT returns the simple-vector.
-;;;
-(eval-when (compile eval)
-(defmacro with-parsing-buffer ((buffer-var &optional other-var) &body body)
-  (let ((len (gensym))
-	(res (gensym)))
-    `(unwind-protect
-	 (let ((,buffer-var *parsing-buffer*)
-	       ,@(if other-var `((,other-var *other-parsing-buffer*))))
-	   (setf (fill-pointer ,buffer-var) 0)
-	   ,@(if other-var `((setf (fill-pointer ,other-var) 0)))
-	   (macrolet ((result (buf)
-			`(let* ((,',len (length ,buf))
-				(,',res (make-array ,',len)))
-			   (replace ,',res ,buf :end1 ,',len :end2 ,',len)
-			   (fill ,buf nil :end ,',len)
-			   (setf (fill-pointer ,buf) 0)
-			   ,',res)))
-	     ,@body))
-     (fill *parsing-buffer* nil)
-     ,@(if other-var `((fill *other-parsing-buffer* nil))))))
-) ;eval-when
-
-
-;;; DEBUG-FUNCTION-DEBUG-BLOCKS -- Internal.
-;;;
-;;; The argument is a debug internals structure.  This returns the debug-blocks
-;;; for debug-function, regardless of whether we have unpacked them yet.  It
-;;; signals a no-debug-blocks condition if it can't return the blocks.
-;;;
-(defun debug-function-debug-blocks (debug-function)
-  (let ((blocks (debug-function-blocks debug-function)))
-    (cond ((eq blocks :unparsed)
-	   (setf (debug-function-blocks debug-function)
-		 (parse-debug-blocks debug-function))
-	   (unless (debug-function-blocks debug-function)
-	     (debug-signal 'no-debug-blocks
-			   :debug-function debug-function))
-	   (debug-function-blocks debug-function))
-	  (blocks)
-	  (t
-	   (debug-signal 'no-debug-blocks
-			 :debug-function debug-function)))))
-
-;;; PARSE-DEBUG-BLOCKS -- Internal.
-;;;
-;;; This returns a simple-vector of debug-blocks or nil.  Nil indicates there
-;;; was no basic block information.
-;;;
-(defun parse-debug-blocks (debug-function)
-  (etypecase debug-function
-    (compiled-debug-function
-     (parse-compiled-debug-blocks debug-function))
-    (bogus-debug-function
-     (debug-signal 'no-debug-blocks :debug-function debug-function))
-    (interpreted-debug-function
-     (parse-interpreted-debug-blocks debug-function))))
-
-
-;;; PARSE-COMPILED-DEBUG-BLOCKS -- Internal.
-;;;
-;;; This does some of the work of PARSE-DEBUG-BLOCKS.
-;;;
-(defun parse-compiled-debug-blocks (debug-function)
-  (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function))
-	 (var-count (length (debug-function-debug-variables debug-function)))
-	 (blocks (c::compiled-debug-function-blocks debug-fun))
-	 ;; 8 is a hard-wired constant in the compiler for the element size of
-	 ;; the packed binary representation of the blocks data.
-	 (live-set-len (ceiling var-count 8))
-	 (tlf-number (c::compiled-debug-function-tlf-number debug-fun)))
-    (unless blocks (return-from parse-compiled-debug-blocks nil))
-    (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
-      (with-parsing-buffer (blocks-buffer locations-buffer)
-	(let ((i 0)
-	      (len (length blocks))
-	      (last-pc 0))
-	  (loop
-	    (when (>= i len) (return))
-	    (let ((succ-and-flags (aref+ blocks i))
-		  (successors nil))
-	      (declare (type (unsigned-byte 8) succ-and-flags)
-		       (list successors))
-	      (dotimes (k (ldb c::compiled-debug-block-nsucc-byte
-			       succ-and-flags))
-		(push (c::read-var-integer blocks i) successors))
-	      (let* ((locations
-		      (dotimes (k (c::read-var-integer blocks i)
-				  (result locations-buffer))
-			(let ((kind (svref c::compiled-code-location-kinds
-					   (aref+ blocks i)))
-			      (pc (+ last-pc (c::read-var-integer blocks i)))
-			      (tlf-offset (or tlf-number
-					      (c::read-var-integer blocks i)))
-			      (form-number (c::read-var-integer blocks i))
-			      (live-set (c::read-packed-bit-vector
-					 live-set-len blocks i)))
-			  (vector-push-extend (make-known-code-location
-					       pc debug-function tlf-offset
-					       form-number live-set kind)
-					      locations-buffer)
-			  (setf last-pc pc))))
-		     (block (make-compiled-debug-block
-			     locations successors
-			     (not (zerop (logand
-					  c::compiled-debug-block-elsewhere-p
-					  succ-and-flags))))))
-		(vector-push-extend block blocks-buffer)
-		(dotimes (k (length locations))
-		  (setf (code-location-%debug-block (svref locations k))
-			block))))))
-	(let ((res (result blocks-buffer)))
-	  (declare (simple-vector res))
-	  (dotimes (i (length res))
-	    (let* ((block (svref res i))
-		   (succs nil))
-	      (dolist (ele (debug-block-successors block))
-		(push (svref res ele) succs))
-	      (setf (debug-block-successors block) succs)))
-	  res)))))
-
-;;; PARSE-INTERPRETED-DEBUG-BLOCKS -- Internal.
-;;;
-;;; This does some of the work of PARSE-DEBUG-BLOCKS.
-;;;
-(defun parse-interpreted-debug-blocks (debug-function)
-  (let ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-function)))
-    (with-parsing-buffer (buffer)
-      (c::do-blocks (block (c::block-component
-			    (c::node-block (c::lambda-bind ir1-lambda))))
-	(when (eq ir1-lambda (c::block-home-lambda block))
-	  (vector-push-extend (make-interpreted-debug-block block) buffer)))
-      (result buffer))))
-
-
-;;; DEBUG-FUNCTION-DEBUG-VARIABLES -- Internal.
-;;;
-;;; The argument is a debug internals structure.  This returns nil if there is
-;;; no variable information.  It returns an empty simple-vector if there were
-;;; no locals in the function.  Otherwise it returns a simple-vector of
-;;; debug-variables.
-;;;
-(defun debug-function-debug-variables (debug-function)
-  (let ((vars (debug-function-debug-vars debug-function)))
-    (if (eq vars :unparsed)
-	(setf (debug-function-debug-vars debug-function)
-	      (etypecase debug-function
-		(compiled-debug-function
-		 (parse-compiled-debug-variables debug-function))
-		(bogus-debug-function nil)
-		(interpreted-debug-function
-		 (parse-interpreted-debug-variables debug-function))))
-	vars)))
-
-
-;;; PARSE-INTERPRETED-DEBUG-VARIABLES -- Internal.
-;;;
-;;; This grabs all the variables from debug-fun's ir1-lambda, from the IR1
-;;; lambda vars, and all of it's LET's.  Each LET is an IR1 lambda.  For each
-;;; variable, we make an interpreted-debug-variable.  We then SORT all the
-;;; variables by name.  Then we go through, and for any duplicated names we
-;;; distinguish the interpreted-debug-variables by setting their id slots to a
-;;; distinct number.
-;;;
-(defun parse-interpreted-debug-variables (debug-fun)
-  (let* ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-fun))
-	 (vars (flet ((frob (ir1-lambda buf)
-			(dolist (v (c::lambda-vars ir1-lambda))
-			  (vector-push-extend
-			   (let* ((id (c::leaf-name v))
-				  (pkg (symbol-package id)))
-			     (make-interpreted-debug-variable
-			      (symbol-name id)
-			      (when pkg (package-name pkg))
-			      v))
-			   buf))))
-		 (with-parsing-buffer (buf)
-		   (frob ir1-lambda buf)
-		   (dolist (let-lambda (c::lambda-lets ir1-lambda))
-		     (frob let-lambda buf))
-		   (result buf)))))
-    (declare (simple-vector vars))
-    (sort vars #'string< :key #'debug-variable-name)
-    (let ((len (length vars)))
-      (when (> len 1)
-	(let ((i 0)
-	      (j 1))
-	  (block PUNT
-	    (loop
-	      (let* ((var-i (svref vars i))
-		     (var-j (svref vars j))
-		     (name (debug-variable-name var-i)))
-		(when (string= name (debug-variable-name var-j))
-		  (let ((count 1))
-		    (loop 
-		      (setf (debug-variable-id var-j) count)
-		      (when (= (incf j) len) (return-from PUNT))
-		      (setf var-j (svref vars j))
-		      (when (string/= name (debug-variable-name var-j))
-			(return))
-		      (incf count))))
-		(setf i j)
-		(incf j)
-		(when (= j len) (return))))))))
-    vars))
-
-
-;;; ASSIGN-MINIMAL-VAR-NAMES -- Internal.
-;;;
-;;; Vars is the parsed variables for a minimal debug function.  We need to
-;;; assign names of the form ARG-NNN.  We must pad with leading zeros, since
-;;; the arguments must be in alphabetical order.
-;;;
-(defun assign-minimal-var-names (vars)
-  (declare (simple-vector vars))
-  (let* ((len (length vars))
-	 (width (length (format nil "~D" (1- len)))))
-    (dotimes (i len)
-      (setf (compiled-debug-variable-name (svref vars i))
-	    (format nil "ARG-~V,'0D" width i)))))
-
-  
-;;; PARSE-COMPILED-DEBUG-VARIABLES -- Internal.
-;;;
-;;; This parses the packed binary representation of debug-variables from
-;;; debug-function's c::compiled-debug-function.
-;;;
-(defun parse-compiled-debug-variables (debug-function)
-  (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function))
-	 (packed-vars (c::compiled-debug-function-variables debug-fun))
-	 (default-package (c::compiled-debug-info-package
-			   (compiled-debug-function-debug-info debug-function)))
-	 (args-minimal (eq (c::compiled-debug-function-arguments debug-fun)
-			   :minimal)))
-    (unless packed-vars
-      (return-from parse-compiled-debug-variables nil))
-    (when (zerop (length packed-vars))
-      ;; Return a simple-vector not whatever packed-vars may be.
-      (return-from parse-compiled-debug-variables '#()))
-    (let ((i 0)
-	  (len (length packed-vars)))
-      (with-parsing-buffer (buffer)
-	(loop
-	  ;; The routines in the "C" package are macros that advance the
-	  ;; index.
-	  (let* ((flags (prog1 (aref packed-vars i) (incf i)))
-		 (minimal (logtest c::compiled-debug-variable-minimal-p flags))
-		 (deleted (logtest c::compiled-debug-variable-deleted-p flags))
-		 (name (if minimal "" (c::read-var-string packed-vars i)))
-		 (package (cond
-			   (minimal default-package)
-			   ((logtest c::compiled-debug-variable-packaged
-				     flags)
-			    (c::read-var-string packed-vars i))
-			   ((logtest c::compiled-debug-variable-uninterned
-				     flags)
-			    nil)
-			   (t
-			    default-package)))
-		  (id (if (logtest c::compiled-debug-variable-id-p flags)
-			  (c::read-var-integer packed-vars i)
-			  0))
-		  (sc-offset
-		   (if deleted 0 (c::read-var-integer packed-vars i)))
-		  (save-sc-offset
-		   (if (logtest c::compiled-debug-variable-save-loc-p flags)
-		       (c::read-var-integer packed-vars i)
-		       nil)))
-	    (assert (not (and args-minimal (not minimal))))
-	    (vector-push-extend
-	     (make-compiled-debug-variable
-	      name package id
-	      (logtest c::compiled-debug-variable-environment-live flags)
-	      sc-offset save-sc-offset)
-	     buffer))
-	  (when (>= i len) (return)))
-	(let ((res (result buffer)))
-	  (when args-minimal
-	    (assign-minimal-var-names res))
-	  res)))))
-
-
-;;;; Unpacking minimal debug functions.
-
-(eval-when (compile eval)
-
-;;; MAKE-UNCOMPACTED-DEBUG-FUN -- Internal.
-;;;
-;;; Sleazoid "macro" to keep our indentation sane in UNCOMPACT-FUNCTION-MAP.
-;;;
-(defmacro make-uncompacted-debug-fun ()
-  '(c::make-compiled-debug-function
-    :name
-    (let ((base (ecase (ldb c::minimal-debug-function-name-style-byte
-			    options)
-		  (#.c::minimal-debug-function-name-symbol
-		   (intern (c::read-var-string map i)
-			   (c::compiled-debug-info-package info)))
-		  (#.c::minimal-debug-function-name-packaged
-		   (let ((pkg (c::read-var-string map i)))
-		     (intern (c::read-var-string map i) pkg)))
-		  (#.c::minimal-debug-function-name-uninterned
-		   (make-symbol (c::read-var-string map i)))
-		  (#.c::minimal-debug-function-name-component
-		   (c::compiled-debug-info-name info)))))
-      (if (logtest flags c::minimal-debug-function-setf-bit)
-	  `(setf ,base)
-	  base))
-    :kind (svref c::minimal-debug-function-kinds
-		 (ldb c::minimal-debug-function-kind-byte options))
-    :variables
-    (when vars-p
-      (let ((len (c::read-var-integer map i)))
-	(prog1 (subseq map i (+ i len))
-	  (incf i len))))
-    :arguments (when vars-p :minimal)
-    :returns
-    (ecase (ldb c::minimal-debug-function-returns-byte options)
-      (#.c::minimal-debug-function-returns-standard
-       :standard)
-      (#.c::minimal-debug-function-returns-fixed
-       :fixed)
-      (#.c::minimal-debug-function-returns-specified
-       (with-parsing-buffer (buf)
-	 (dotimes (idx (c::read-var-integer map i))
-	   (vector-push-extend (c::read-var-integer map i) buf))
-	 (result buf))))
-    :return-pc (c::read-var-integer map i)
-    :old-fp (c::read-var-integer map i)
-    :nfp (when (logtest flags c::minimal-debug-function-nfp-bit)
-	   (c::read-var-integer map i))
-    :start-pc
-    (progn
-      (setq code-start-pc (+ code-start-pc (c::read-var-integer map i)))
-      (+ code-start-pc (c::read-var-integer map i)))
-    :elsewhere-pc
-    (setq elsewhere-pc (+ elsewhere-pc (c::read-var-integer map i)))))
-
-) ;EVAL-WHEN (compile eval)
-
-;;; UNCOMPACT-FUNCTION-MAP  --  Internal
-;;;
-;;;    Return a normal function map derived from a minimal debug info function
-;;; map.  This involves looping parsing minimal-debug-functions and then
-;;; building a vector out of them.
-;;;
-(defun uncompact-function-map (info)
-  (declare (type c::compiled-debug-info info))
-  (let* ((map (c::compiled-debug-info-function-map info))
-	 (i 0)
-	 (len (length map))
-	 (code-start-pc 0)
-	 (elsewhere-pc 0))
-    (declare (type (simple-array (unsigned-byte 8) (*)) map))
-    (ext:collect ((res))
-      (loop
-	(when (= i len) (return))
-	(let* ((options (prog1 (aref map i) (incf i)))
-	       (flags (prog1 (aref map i) (incf i)))
-	       (vars-p (logtest flags c::minimal-debug-function-variables-bit))
-	       (dfun (make-uncompacted-debug-fun)))
-	  (res code-start-pc)
-	  (res dfun)))
-      
-      (coerce (cdr (res)) 'simple-vector))))
-
-    
-;;; This variable maps minimal debug-info function maps to an unpacked version
-;;; thereof.
-;;;
-(defvar *uncompacted-function-maps* (make-hash-table :test #'eq))
-
-;;; GET-DEBUG-INFO-FUNCTION-MAP  --  Internal
-;;;
-;;;    Return a function-map for a given compiled-debug-info object.  If the
-;;; info is minimal, and has not been parsed, then parse it.
-;;;
-(defun get-debug-info-function-map (info)
-  (declare (type c::compiled-debug-info info))
-  (let ((map (c::compiled-debug-info-function-map info)))
-    (if (simple-vector-p map)
-	map
-	(or (gethash map *uncompacted-function-maps*)
-	    (setf (gethash map *uncompacted-function-maps*)
-		  (uncompact-function-map info))))))
-
-
-;;;; Code-locations.
-
-;;; CODE-LOCATION-UNKNOWN-P -- Public.
-;;;
-;;; If we're sure of whether code-location is known, return t or nil.  If we're
-;;; :unsure, then try to fill in the code-location's slots.  This determines
-;;; whether there is any debug-block information, and if code-location is
-;;; known.
-;;;
-;;; ??? IF this conses closures every time it's called, then break off the
-;;; :unsure part to get the HANDLER-CASE into another function.
-;;;
-(defun code-location-unknown-p (basic-code-location)
-  "Returns whether basic-code-location is unknown.  It returns nil when the
-   code-location is known."
-  (ecase (code-location-%unknown-p basic-code-location)
-    ((t) t)
-    ((nil) nil)
-    (:unsure
-     (setf (code-location-%unknown-p basic-code-location)
-	   (handler-case (not (fill-in-code-location basic-code-location))
-	     (no-debug-blocks () t))))))
-
-;;; CODE-LOCATION-DEBUG-BLOCK -- Public.
-;;;
-(defun code-location-debug-block (basic-code-location)
-  "Returns the debug-block containing code-location if it is available.  Some
-   debug policies inhibit debug-block information, and if none is available,
-   then this signals a no-debug-blocks condition."
-  (let ((block (code-location-%debug-block basic-code-location)))
-    (if (eq block :unparsed)
-	(etypecase basic-code-location
-	  (compiled-code-location
-	   (compute-compiled-code-location-debug-block basic-code-location))
-	  (interpreted-code-location
-	   (setf (code-location-%debug-block basic-code-location)
-		 (make-interpreted-debug-block
-		  (c::node-block
-		   (interpreted-code-location-ir1-node basic-code-location))))))
-	block)))
-
-;;; COMPUTE-COMPILED-CODE-LOCATION-DEBUG-BLOCK -- Internal.
-;;;
-;;; This stores and returns basic-code-location's debug-block.  It determines
-;;; the correct one using the code-location's pc.  This uses
-;;; DEBUG-FUNCTION-DEBUG-BLOCKS to return the cached block information or
-;;; signal a 'no-debug-blocks condition.  The blocks are sorted by their first
-;;; code-location's pc, in ascending order.  Therefore, as soon as we find a
-;;; block that starts with a pc greater than basic-code-location's pc, we know
-;;; the previous block contains the pc.  If we get to the last block, then the
-;;; code-location is either in the second to last block or the last block, and
-;;; we have to be careful in determining this since the last block could be
-;;; random code at the end of the function.  We have to check for the last
-;;; block being random code first to see how to compare the code-location's pc.
-;;;
-(defun compute-compiled-code-location-debug-block (basic-code-location)
-  (let* ((pc (compiled-code-location-pc basic-code-location))
-	 (debug-function (code-location-debug-function
-			  basic-code-location))
-	 (blocks (debug-function-debug-blocks debug-function))
-	 (len (length blocks)))
-    (declare (simple-vector blocks))
-    (setf (code-location-%debug-block basic-code-location)
-	  (if (= len 1)
-	      (svref blocks 0)
-	      (do ((i 1 (1+ i))
-		   (end (1- len)))
-		  ((= i end)
-		   (let ((last (svref blocks end)))
-		     (cond
-		      ((debug-block-elsewhere-p last)
-		       (if (< pc
-			      (c::compiled-debug-function-elsewhere-pc
-			       (compiled-debug-function-compiler-debug-fun
-				debug-function)))
-			   (svref blocks (1- end))
-			   last))
-		      ((< pc
-			  (compiled-code-location-pc
-			   (svref (compiled-debug-block-code-locations last)
-				  0)))
-		       (svref blocks (1- end)))
-		      (t last))))
-		(declare (type c::index i end))
-		(when (< pc
-			 (compiled-code-location-pc
-			  (svref (compiled-debug-block-code-locations
-				  (svref blocks i))
-				 0)))
-		  (return (svref blocks (1- i)))))))))
-
-;;; CODE-LOCATION-DEBUG-SOURCE -- Public.
-;;;
-(defun code-location-debug-source (code-location)
-  "Returns the code-location's debug-source."
-  (etypecase code-location
-    (compiled-code-location
-     (let* ((info (compiled-debug-function-debug-info
-		   (code-location-debug-function code-location)))
-	    (sources (c::compiled-debug-info-source info))
-	    (len (length sources)))
-	 (declare (list sources))
-	 (if (= len 1)
-	     (car sources)
-	     (do ((prev sources src)
-		  (src (cdr sources) (cdr src))
-		  (offset (code-location-top-level-form-offset code-location)))
-		 ((null src) (car prev))
-	       (when (< offset (c::debug-source-source-root (car src)))
-		 (return (car prev)))))))
-    (interpreted-code-location
-     (first
-      (let ((c::*lexical-environment* (c::make-null-environment)))
-	(c::debug-source-for-info
-	 (c::component-source-info
-	  (c::block-component
-	   (c::node-block
-	    (interpreted-code-location-ir1-node code-location))))))))))
-
-
-;;; CODE-LOCATION-TOP-LEVEL-FORM-OFFSET -- Public.
-;;;
-(defun code-location-top-level-form-offset (code-location)
-  "Returns the number of top-level forms before the one containing
-   code-location as seen by the compiler in some compilation unit.  A
-   compilation unit is not necessarily a single file, see the section on
-   debug-sources."
-  (when (code-location-unknown-p code-location)
-    (error 'unknown-code-location :code-location code-location))
-  (let ((tlf-offset (code-location-%tlf-offset code-location)))
-    (cond ((eq tlf-offset :unparsed)
-	   (etypecase code-location
-	     (compiled-code-location
-	      (unless (fill-in-code-location code-location)
-		;; This check should be unnecessary.  We're missing debug info
-		;; the compiler should have dumped.
-		(error "Unknown code location?  It should be known."))
-	      (code-location-%tlf-offset code-location))
-	     (interpreted-code-location
-	      (setf (code-location-%tlf-offset code-location)
-		    (c::source-path-tlf-number
-		     (c::node-source-path
-		      (interpreted-code-location-ir1-node code-location)))))))
-	  (t tlf-offset))))
-
-;;; CODE-LOCATION-FORM-NUMBER -- Public.
-;;;
-(defun code-location-form-number (code-location)
-  "Returns the number of the form corresponding to code-location.  The form
-   number is derived by a walking the subforms of a top-level form in
-   depth-first order."
-  (when (code-location-unknown-p code-location)
-    (error 'unknown-code-location :code-location code-location))
-  (let ((form-num (code-location-%form-number code-location)))
-    (cond ((eq form-num :unparsed)
-	   (etypecase code-location
-	     (compiled-code-location
-	      (unless (fill-in-code-location code-location)
-		;; This check should be unnecessary.  We're missing debug info
-		;; the compiler should have dumped.
-		(error "Unknown code location?  It should be known."))
-	      (code-location-%form-number code-location))
-	     (interpreted-code-location
-	      (setf (code-location-%form-number code-location)
-		    (c::source-path-form-number
-		     (c::node-source-path
-		      (interpreted-code-location-ir1-node code-location)))))))
-	  (t form-num))))
-
-;;; CODE-LOCATION-KIND -- Public
-;;; 
-(defun code-location-kind (code-location)
-  "Return the kind of CODE-LOCATION, one of:
-     :interpreted, :unknown-return, :known-return, :internal-error,
-     :non-local-exit, :block-start, :call-site, :single-value-return,
-     :non-local-entry"
-  (when (code-location-unknown-p code-location)
-    (error 'unknown-code-location :code-location code-location))
-  (etypecase code-location
-    (compiled-code-location
-     (let ((kind (compiled-code-location-kind code-location)))
-       (cond ((not (eq kind :unparsed)) kind)
-             ((not (fill-in-code-location code-location))
-              ;; This check should be unnecessary.  We're missing
-              ;; debug info the compiler should have dumped.
-              (error "Unknown code location?  It should be known."))
-             (t
-              (compiled-code-location-kind code-location)))))
-    (interpreted-code-location
-     :interpreted)))
-
-
-;;; COMPILED-CODE-LOCATION-LIVE-SET -- Internal.
-;;;
-;;; This returns the code-location's live-set if it is available.  If there
-;;; is no debug-block information, this returns nil.
-;;;
-(defun compiled-code-location-live-set (code-location)
-  (if (code-location-unknown-p code-location)
-      nil
-      (let ((live-set (compiled-code-location-%live-set code-location)))
-	(cond ((eq live-set :unparsed)
-	       (unless (fill-in-code-location code-location)
-		 ;; This check should be unnecessary.  We're missing debug info
-		 ;; the compiler should have dumped.
-		 (error "Unknown code location?  It should be known."))
-	       (compiled-code-location-%live-set code-location))
-	      (t live-set)))))
-
-;;; CODE-LOCATION= -- Public.
-;;;
-(defun code-location= (obj1 obj2)
-  "Returns whether obj1 and obj2 are the same place in the code."
-  (etypecase obj1
-    (compiled-code-location
-     (etypecase obj2
-       (compiled-code-location
-	(and (eq (code-location-debug-function obj1)
-		 (code-location-debug-function obj2))
-	     (sub-compiled-code-location= obj1 obj2)))
-       (interpreted-code-location
-	nil)))
-    (interpreted-code-location
-     (etypecase obj2
-       (compiled-code-location
-	nil)
-       (interpreted-code-location
-	(eq (interpreted-code-location-ir1-node obj1)
-	    (interpreted-code-location-ir1-node obj2)))))))
-;;;
-(defun sub-compiled-code-location= (obj1 obj2)
-  (= (compiled-code-location-pc obj1)
-     (compiled-code-location-pc obj2)))
-
-;;; FILL-IN-CODE-LOCATION -- Internal.
-;;;
-;;; This fills in location's :unparsed slots.  It returns t or nil depending on
-;;; whether the code-location was known in its debug-function's debug-block
-;;; information.  This may signal a no-debug-blocks condition due to
-;;; DEBUG-FUNCTION-DEBUG-BLOCKS, and it assumes the %unknown-p slot is already
-;;; set or going to be set.
-;;;
-(defun fill-in-code-location (code-location)
-  (declare (type compiled-code-location code-location))
-  (let* ((debug-function (code-location-debug-function code-location))
-	 (blocks (debug-function-debug-blocks debug-function)))
-    (declare (simple-vector blocks))
-    (dotimes (i (length blocks) nil)
-      (let* ((block (svref blocks i))
-	     (locations (compiled-debug-block-code-locations block)))
-	(declare (simple-vector locations))
-	(dotimes (j (length locations))
-	  (let ((loc (svref locations j)))
-	    (when (sub-compiled-code-location= code-location loc)
-	      (setf (code-location-%debug-block code-location) block)
-	      (setf (code-location-%tlf-offset code-location)
-		    (code-location-%tlf-offset loc))
-	      (setf (code-location-%form-number code-location)
-		    (code-location-%form-number loc))
-	      (setf (compiled-code-location-%live-set code-location)
-		    (compiled-code-location-%live-set loc))
-	      (setf (compiled-code-location-kind code-location)
-		    (compiled-code-location-kind loc))
-	      (return-from fill-in-code-location t))))))))
-
-
-
-;;;; Debug-blocks.
-
-;;; DO-DEBUG-BLOCK-LOCATIONS -- Public.
-;;;
-(defmacro do-debug-block-locations ((code-var debug-block &optional return)
-				    &body body)
-  "Executes forms in a context with code-var bound to each code-location in
-   debug-block.  This returns the value of executing result (defaults to nil)."
-  (let ((code-locations (gensym))
-	(i (gensym)))
-    `(let ((,code-locations (debug-block-code-locations ,debug-block)))
-       (declare (simple-vector ,code-locations))
-       (dotimes (,i (length ,code-locations) ,return)
-	 (let ((,code-var (svref ,code-locations ,i)))
-	   ,@body)))))
-
-;;; DEBUG-BLOCK-FUNCTION-NAME -- Internal.
-;;;
-(defun debug-block-function-name (debug-block)
-  "Returns the name of the function represented by debug-function.  This may
-   be a string or a cons; do not assume it is a symbol."
-  (etypecase debug-block
-    (compiled-debug-block
-     (let ((code-locs (compiled-debug-block-code-locations debug-block)))
-       (declare (simple-vector code-locs))
-       (if (zerop (length code-locs))
-	   "??? Can't get name of debug-block's function."
-	   (debug-function-name
-	    (code-location-debug-function (svref code-locs 0))))))
-    (interpreted-debug-block
-     (c::lambda-name (c::block-home-lambda
-		      (interpreted-debug-block-ir1-block debug-block))))))
-
-
-;;; DEBUG-BLOCK-CODE-LOCATIONS -- Internal.
-;;;
-(defun debug-block-code-locations (debug-block)
-  (etypecase debug-block
-    (compiled-debug-block
-     (compiled-debug-block-code-locations debug-block))
-    (interpreted-debug-block
-     (interpreted-debug-block-code-locations debug-block))))
-
-;;; INTERPRETED-DEBUG-BLOCK-CODE-LOCATIONS -- Internal.
-;;;
-(defun interpreted-debug-block-code-locations (debug-block)
-  (let ((code-locs (interpreted-debug-block-locations debug-block)))
-    (if (eq code-locs :unparsed)
-	(with-parsing-buffer (buf)
-	  (c::do-nodes (node cont (interpreted-debug-block-ir1-block
-				   debug-block))
-	    (vector-push-extend (make-interpreted-code-location
-				 node
-				 (make-interpreted-debug-function
-				  (c::block-home-lambda (c::node-block node))))
-				buf))
-	  (setf (interpreted-debug-block-locations debug-block)
-		(result buf)))
-	code-locs)))
-
-
-
-;;;; Variables.
-
-;;; DEBUG-VARIABLE-SYMBOL -- Public.
-;;;
-(defun debug-variable-symbol (debug-var)
-  "Returns the symbol from interning DEBUG-VARIABLE-NAME in the package named
-   by DEBUG-VARIABLE-PACKAGE."
-  (let ((package (debug-variable-package debug-var)))
-    (if package
-	(intern (debug-variable-name debug-var) package)
-	(make-symbol (debug-variable-name debug-var)))))
-
-;;; DEBUG-VARIABLE-VALID-VALUE -- Public.
-;;;
-(defun debug-variable-valid-value (debug-var frame)
-  "Returns the value stored for debug-variable in frame.  If the value is not
-   :valid, then this signals an invalid-value error."
-  (unless (eq (debug-variable-validity debug-var (frame-code-location frame))
-	      :valid)
-    (error 'invalid-value :debug-variable debug-var :frame frame))
-  (debug-variable-value debug-var frame))
-
-;;; DEBUG-VARIABLE-VALUE -- Public.
-;;;
-(defun debug-variable-value (debug-var frame)
-  "Returns the value stored for debug-variable in frame.  The value may be
-   invalid.  This is SETF'able."
-  (etypecase debug-var
-    (compiled-debug-variable
-     (check-type frame compiled-frame)
-     (let ((res (access-compiled-debug-var-slot debug-var frame)))
-       (if (indirect-value-cell-p res)
-	   (c:value-cell-ref res)
-	   res)))
-    (interpreted-debug-variable
-     (check-type frame interpreted-frame)
-     (eval::leaf-value-lambda-var
-      (interpreted-code-location-ir1-node (frame-code-location frame))
-      (interpreted-debug-variable-ir1-var debug-var)
-      (frame-pointer frame)
-      (interpreted-frame-closure frame)))))
-
-
-;;; ACCESS-COMPILED-DEBUG-VAR-SLOT -- Internal.
-;;;
-;;; This returns what is stored for the variable represented by debug-var
-;;; relative to the frame.  This may be an indirect value cell if the
-;;; variable is both closed over and set.
-;;;
-(defun access-compiled-debug-var-slot (debug-var frame)
-  (let ((escaped (compiled-frame-escaped frame)))
-    (if escaped
-	(sub-access-debug-var-slot
-	 (frame-pointer frame)
-	 (compiled-debug-variable-sc-offset debug-var)
-	 escaped)
-	(sub-access-debug-var-slot
-	 (frame-pointer frame)
-	 (or (compiled-debug-variable-save-sc-offset debug-var)
-	     (compiled-debug-variable-sc-offset debug-var))))))
-
-;;; SUB-ACCESS-DEBUG-VAR-SLOT -- Internal.
-;;;
-(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
-  (macrolet ((with-escaped-value ((var) &body forms)
-	       `(if escaped
-		    (let ((,var (vm:sigcontext-register
-				 escaped
-				 (c::sc-offset-offset sc-offset))))
-		      ,@forms)
-		    :invalid-value-for-unescaped-register-storage))
-	     (escaped-float-value (format)
-	       `(if escaped
-		    (vm:sigcontext-float-register
-		     escaped
-		     (c::sc-offset-offset sc-offset)
-		     ',format)
-		    :invalid-value-for-unescaped-register-storage))
-	     (with-nfp ((var) &body body)
-	       `(let ((,var (if escaped
-				(system:int-sap
-				 (vm:sigcontext-register escaped
-							 vm::nfp-offset))
-				(system:sap-ref-sap fp (* vm::nfp-save-offset
-							  vm:word-bytes)))))
-		  ,@body)))
-    (ecase (c::sc-offset-scn sc-offset)
-      ((#.vm:any-reg-sc-number
-	#.vm:descriptor-reg-sc-number
-	#+rt #.vm:word-pointer-reg-sc-number)
-       (system:without-gcing
-	(with-escaped-value (val)
-	  (kernel:make-lisp-obj val))))
-      (#.vm:base-char-reg-sc-number
-       (with-escaped-value (val)
-	 (code-char val)))
-      (#.vm:sap-reg-sc-number
-       (with-escaped-value (val)
-	 (system:int-sap val)))
-      (#.vm:signed-reg-sc-number
-       (with-escaped-value (val)
-	 (if (logbitp (1- vm:word-bits) val)
-	     (logior val (ash -1 vm:word-bits))
-	     val)))
-      (#.vm:unsigned-reg-sc-number
-       (with-escaped-value (val)
-	 val))
-      (#.vm:non-descriptor-reg-sc-number
-       (error "Local non-descriptor register access?"))
-      (#.vm:interior-reg-sc-number
-       (error "Local interior register access?"))
-      (#.vm:single-reg-sc-number
-       (escaped-float-value single-float))
-      (#.vm:double-reg-sc-number
-       (escaped-float-value double-float))
-      (#.vm:single-stack-sc-number
-       (with-nfp (nfp)
-	 (system:sap-ref-single nfp (* (vm::sc-offset-offset sc-offset)
-				       vm:word-bytes))))
-      (#.vm:double-stack-sc-number
-       (with-nfp (nfp)
-	 (system:sap-ref-double nfp (* (c::sc-offset-offset sc-offset)
-				       vm:word-bytes))))
-      (#.vm:control-stack-sc-number
-       (kernel:stack-ref fp (c::sc-offset-offset sc-offset)))
-      (#.vm:base-char-stack-sc-number
-       (with-nfp (nfp)
-	 (code-char (system:sap-ref-32 nfp (* (c::sc-offset-offset sc-offset)
-					      vm:word-bytes)))))
-      (#.vm:unsigned-stack-sc-number
-       (with-nfp (nfp)
-	 (system:sap-ref-32 nfp (* (c::sc-offset-offset sc-offset)
-				   vm:word-bytes))))
-      (#.vm:signed-stack-sc-number
-       (with-nfp (nfp)
-	 (system:signed-sap-ref-32 nfp (* (c::sc-offset-offset sc-offset)
-					  vm:word-bytes))))
-      (#.vm:sap-stack-sc-number
-       (with-nfp (nfp)
-	 (system:sap-ref-sap nfp (* (c::sc-offset-offset sc-offset)
-				    vm:word-bytes)))))))
-
-
-;;; %SET-DEBUG-VARIABLE-VALUE -- Internal.
-;;;
-;;; This stores value as the value of debug-var in frame.  In the
-;;; compiled-debug-variable case, access the current value to determine if it
-;;; is an indirect value cell.  This occurs when the variable is both closed
-;;; over and set.  For interpreted-debug-variables just call
-;;; EVAL::SET-LEAF-VALUE-LAMBDA-VAR with the right interpreter objects.
-;;;
-(defun %set-debug-variable-value (debug-var frame value)
-  (etypecase debug-var
-    (compiled-debug-variable
-     (check-type frame compiled-frame)
-     (let ((current-value (access-compiled-debug-var-slot debug-var frame)))
-       (if (indirect-value-cell-p current-value)
-	   (c:value-cell-set current-value value)
-	   (set-compiled-debug-variable-slot debug-var frame value))))
-    (interpreted-debug-variable
-     (check-type frame interpreted-frame)
-     (eval::set-leaf-value-lambda-var
-      (interpreted-code-location-ir1-node (frame-code-location frame))
-      (interpreted-debug-variable-ir1-var debug-var)
-      (frame-pointer frame)
-      (interpreted-frame-closure frame)
-      value)))
-  value)
-;;;
-(defsetf debug-variable-value %set-debug-variable-value)
-
-;;; SET-COMPILED-DEBUG-VARIABLE-SLOT -- Internal.
-;;;
-;;; This stores value for the variable represented by debug-var relative to the
-;;; frame.  This assumes the location directly contains the variable's value;
-;;; that is, there is no indirect value cell currently there in case the
-;;; variable is both closed over and set.
-;;;
-(defun set-compiled-debug-variable-slot (debug-var frame value)
-  (let ((escaped (compiled-frame-escaped frame)))
-    (if escaped
-	(sub-set-debug-var-slot (frame-pointer frame)
-				(compiled-debug-variable-sc-offset debug-var)
-				value escaped)
-	(sub-set-debug-var-slot
-	 (frame-pointer frame)
-	 (or (compiled-debug-variable-save-sc-offset debug-var)
-	     (compiled-debug-variable-sc-offset debug-var))
-	 value))))
-
-;;; SUB-SET-DEBUG-VAR-SLOT -- Internal.
-;;;
-(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
-  (macrolet ((set-escaped-value (val)
-	       `(if escaped
-		    (setf (vm:sigcontext-register
-			   escaped
-			   (c::sc-offset-offset sc-offset))
-			  ,val)
-		    value))
-	     (set-escaped-float-value (format val)
-	       `(if escaped
-		    (setf (vm:sigcontext-float-register
-			   escaped
-			   (c::sc-offset-offset sc-offset)
-			   ',format)
-			  ,val)
-		    value))
-	     (with-nfp ((var) &body body)
-	       `(let ((,var (if escaped
-				(system:int-sap
-				 (vm:sigcontext-register escaped
-							 vm::nfp-offset))
-				(system:sap-ref-sap fp
-						    (* vm::nfp-save-offset
-						       vm:word-bytes)))))
-		  ,@body)))
-    (ecase (c::sc-offset-scn sc-offset)
-      ((#.vm:any-reg-sc-number
-	#.vm:descriptor-reg-sc-number
-	#+rt #.vm:word-pointer-reg-sc-number)
-       (system:without-gcing
-	(set-escaped-value
-	  (kernel:get-lisp-obj-address value))))
-      (#.vm:base-char-reg-sc-number
-       (set-escaped-value (char-code value)))
-      (#.vm:sap-reg-sc-number
-       (set-escaped-value (system:sap-int value)))
-      (#.vm:signed-reg-sc-number
-       (set-escaped-value (logand value (1- (ash 1 vm:word-bits)))))
-      (#.vm:unsigned-reg-sc-number
-       (set-escaped-value value))
-      (#.vm:non-descriptor-reg-sc-number
-       (error "Local non-descriptor register access?"))
-      (#.vm:interior-reg-sc-number
-       (error "Local interior register access?"))
-      (#.vm:single-reg-sc-number
-       (set-escaped-float-value single-float value))
-      (#.vm:double-reg-sc-number
-       (set-escaped-float-value double-float value))
-      (#.vm:single-stack-sc-number
-       (with-nfp (nfp)
-	 (setf (system:sap-ref-single nfp (* (c::sc-offset-offset sc-offset)
-					     vm:word-bytes))
-	       (the single-float value))))
-      (#.vm:double-stack-sc-number
-       (with-nfp (nfp)
-	 (setf (system:sap-ref-double nfp (* (c::sc-offset-offset sc-offset)
-					     vm:word-bytes))
-	       (the double-float value))))
-      (#.vm:control-stack-sc-number
-       (setf (kernel:stack-ref fp (c::sc-offset-offset sc-offset)) value))
-      (#.vm:base-char-stack-sc-number
-       (with-nfp (nfp)
-	 (setf (system:sap-ref-32 nfp (* (c::sc-offset-offset sc-offset)
-					 vm:word-bytes))
-	       (char-code (the character value)))))
-      (#.vm:unsigned-stack-sc-number
-       (with-nfp (nfp)
-	 (setf (system:sap-ref-32 nfp (* (c::sc-offset-offset sc-offset)
-					 vm:word-bytes))
-	       (the (unsigned-byte 32) value))))
-      (#.vm:signed-stack-sc-number
-       (with-nfp (nfp)
-	 (setf (system:signed-sap-ref-32 nfp (* (c::sc-offset-offset sc-offset)
-						vm:word-bytes))
-	       (the (signed-byte 32) value))))
-      (#.vm:sap-stack-sc-number
-       (with-nfp (nfp)
-	 (setf (system:sap-ref-sap nfp (* (c::sc-offset-offset sc-offset)
-					  vm:word-bytes))
-	       (the system:system-area-pointer value)))))))
-
-(defsetf debug-variable-value %set-debug-variable-value)
-
-
-;;; INDIRECT-VALUE-CELL-P -- Internal.
-;;;
-;;; The method for setting and accessing compiled-debug-variable values use
-;;; this to determine if the value stored is the actual value or an indirection
-;;; cell.
-;;;
-(defun indirect-value-cell-p (x)
-  (and (= (kernel:get-lowtag x) vm:other-pointer-type)
-       (= (kernel:get-type x) vm:value-cell-header-type)))
-
-
-;;; DEBUG-VARIABLE-VALIDITY -- Public.
-;;;
-;;; If the variable is always alive, then it is valid.  If the code-location is
-;;; unknown, then the variable's validity is :unknown.  Once we've called
-;;; CODE-LOCATION-UNKNOWN-P, we know the live-set information has been cached
-;;; in the code-location.
-;;;
-(defun debug-variable-validity (debug-var basic-code-loc)
-  "Returns three values reflecting the validity of debug-variable's value
-   at basic-code-location:
-      :valid    The value is known to be available.
-      :invalid  The value is known to be unavailable.
-      :unknown  The value's availability is unknown."
-  (etypecase debug-var
-    (compiled-debug-variable
-     (compiled-debug-variable-validity debug-var basic-code-loc))
-    (interpreted-debug-variable
-     (check-type basic-code-loc interpreted-code-location)
-     (let ((validp (rassoc (interpreted-debug-variable-ir1-var debug-var)
-			   (c::lexenv-variables
-			    (c::node-lexenv
-			     (interpreted-code-location-ir1-node
-			      basic-code-loc))))))
-       (if validp :valid :invalid)))))
-
-;;; COMPILED-DEBUG-VARIABLE-VALIDITY -- Internal.
-;;;
-;;; This is the method for DEBUG-VARIABLE-VALIDITY for compiled-debug-variables.
-;;; For safety, make sure basic-code-loc is what we think.
-;;;
-(defun compiled-debug-variable-validity (debug-var basic-code-loc)
-  (check-type basic-code-loc compiled-code-location)
-  (cond ((debug-variable-alive-p debug-var)
-	 (let ((debug-fun (code-location-debug-function basic-code-loc)))
-	   (if (>= (compiled-code-location-pc basic-code-loc)
-		   (c::compiled-debug-function-start-pc
-		    (compiled-debug-function-compiler-debug-fun debug-fun)))
-	       :valid
-	       :invalid)))
-	((code-location-unknown-p basic-code-loc) :unknown)
-	(t
-	 (let ((pos (position debug-var
-			      (debug-function-debug-variables
-			       (code-location-debug-function basic-code-loc)))))
-	   (unless pos
-	     (error 'unknown-debug-variable
-		    :debug-variable debug-var
-		    :debug-function
-		    (code-location-debug-function basic-code-loc)))
-	   ;; There must be live-set info since basic-code-loc is known.
-	   (if (zerop (sbit (compiled-code-location-live-set basic-code-loc)
-			    pos))
-	       :invalid
-	       :valid)))))
-
-
-
-;;;; Sources.
-
-;;; Written by Rob Maclachlan.
-;;; Documented by Bill Chiles.
-;;;
-;;; This code produces and uses what we call source-paths.  A source-path is a
-;;; list whose first element is a form number as returned by
-;;; CODE-LOCATION-FORM-NUMBER and whose last element is a top-level-form number
-;;; as returned by CODE-LOCATION-TOP-LEVEL-FORM-NUMBER.  The elements from the
-;;; last to the first, exclusively, are the numbered subforms into which to
-;;; descend.  For example:
-;;;    (defun foo (x)
-;;;      (let ((a (aref x 3)))
-;;;        (cons a 3)))
-;;; The call to AREF in this example is form number 5.  Assuming this DEFUN is
-;;; the 11'th top-level-form, the source-path for the AREF call is as follows:
-;;;    (5 1 0 1 3 11)
-;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0 gets the
-;;; first binding, and 1 gets the AREF form.
-;;;
-
-
-;;; Temporary buffer used to build form-number => source-path translation in
-;;; FORM-NUMBER-TRANSLATIONS.
-;;;
-(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
-
-;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS.
-;;;
-(defvar *form-number-circularity-table* (make-hash-table :test #'eq))
-
-;;; FORM-NUMBER-TRANSLATIONS  --  Public.
-;;;
-;;; The vector elements are in the same format as the compiler's
-;;; NODE-SOUCE-PATH; that is, the first element is the form number and the last
-;;; is the top-level-form number.
-;;;
-(defun form-number-translations (form tlf-number)
-  "This returns a table mapping form numbers to source-paths.  A source-path
-   indicates a descent into the top-level-form form, going directly to the
-   subform corressponding to the form number."
-  (clrhash *form-number-circularity-table*)
-  (setf (fill-pointer *form-number-temp*) 0)
-  (sub-translate-form-numbers form (list tlf-number))
-  (coerce *form-number-temp* 'simple-vector))
-;;;
-(defun sub-translate-form-numbers (form path)
-  (unless (gethash form *form-number-circularity-table*)
-    (setf (gethash form *form-number-circularity-table*) t)
-    (vector-push-extend (cons (fill-pointer *form-number-temp*) path)
-			*form-number-temp*)
-    (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-translate-form-numbers fm (cons pos path)))
-			(incf pos))
-		      (setq subform (cdr subform))
-		      (when (eq subform trail) (return)))))
-	(loop
-	  (frob)
-	  (frob)
-	  (setq trail (cdr trail)))))))
-
-
-;;; SOURCE-PATH-CONTEXT  --  Public.
-;;;
-(defun source-path-context (form path context)
-  "Form is a top-level form, and path is a source-path into it.  This returns
-   the form indicated by the source-path.  Context is the number of enclosing
-   forms to return instead of directly returning the source-path form.  When
-   context is non-zero, the form returned contains a marker, #:****HERE****,
-   immediately before the form indicated by path."
-  (declare (type unsigned-byte context))
-  ;;
-  ;; Get to the form indicated by path or the enclosing form indicated by
-  ;; context and path.
-  (let ((path (reverse (butlast (cdr path)))))
-    (dotimes (i (- (length path) context))
-      (setq form (elt form (first path)))
-      (setq path (rest path)))
-    ;;
-    ;; Recursively rebuild the source form resulting from the above descent,
-    ;; copying the beginning of each subform up to the next subform we descend
-    ;; into according to path.  At the bottom of the recursion, we return the
-    ;; form indicated by path preceded by our marker, and this gets spliced
-    ;; into the resulting list structure on the way back up.
-    (labels ((frob (form path level)
-	       (if (or (zerop level) (null path))
-		   (if (zerop context)
-		       form
-		       `(#:***here*** ,form))
-		   (let* ((n (first path))
-			  (res (frob (elt form n) (rest path) (1- level))))
-		     (nconc (subseq form 0 n)
-			    (cons res (nthcdr (1+ n) form)))))))
-      (frob form path context))))
-
-
-;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME.
-
-;;; PREPROCESS-FOR-EVAL  --  Public.
-;;;
-;;; Create a SYMBOL-MACROLET for each variable valid at the location which
-;;; accesses that variable from the frame argument.
-;;;
-(defun preprocess-for-eval (form loc)
-  "Return a function of one argument that evaluates form in the lexical
-   context of the basic-code-location loc.  PREPROCESS-FOR-EVAL signals a
-   no-debug-variables condition when the loc's debug-function has no
-   debug-variable information available.  The returned function takes the frame
-   to get values from as its argument, and it returns the values of form.
-   The returned function signals the following conditions: invalid-value,
-   ambiguous-variable-name, and frame-function-mismatch"
-  (declare (type code-location loc))
-  (let ((n-frame (gensym))
-	(fun (code-location-debug-function loc)))
-    (unless (debug-variable-info-available fun)
-      (debug-signal 'no-debug-variables :debug-function fun))
-    (ext:collect ((binds)
-		  (specs))
-      (do-debug-function-variables (var fun)
-	(let ((validity (debug-variable-validity var loc)))
-	  (unless (eq validity :invalid)
-	    (let* ((sym (debug-variable-symbol var))
-		   (found (assoc sym (binds))))
-	      (if found
-		  (setf (second found) :ambiguous)
-		  (binds (list sym validity var)))))))
-      (dolist (bind (binds))
-	(let ((name (first bind))
-	      (var (third bind)))
-	  (ecase (second bind)
-	    (:valid
-	     (specs `(,name (debug-variable-value ',var ,n-frame))))
-	    (:unknown
-	     (specs `(,name (debug-signal 'invalid-value :debug-variable ',var
-					  :frame ,n-frame))))
-	    (:ambiguous
-	     (specs `(,name (debug-signal 'ambiguous-variable-name :name ',name
-					  :frame ,n-frame)))))))
-      (let ((res (coerce `(lambda (,n-frame)
-			    (declare (ignorable ,n-frame))
-			    (symbol-macrolet ,(specs) ,form))
-			 'function)))
-	#'(lambda (frame)
-	    ;; This prevents these functions from use in any location other
-	    ;; than a function return location, so maybe this should only
-	    ;; check whether frame's debug-function is the same as loc's.
-	    (unless (code-location= (frame-code-location frame) loc)
-	      (debug-signal 'frame-function-mismatch
-			    :code-location loc :form form :frame frame))
-	    (funcall res frame))))))
-
-
-;;; EVAL-IN-FRAME  --  Public.
-;;;
-(defun eval-in-frame (frame form)
-  (declare (type frame frame))
-  "Evaluate Form in the lexical context of Frame's current code location,
-   returning the results of the evaluation."
-  (funcall (preprocess-for-eval form (frame-code-location frame)) frame))
-
-
-
-;;;; Breakpoints.
-
-;;;
-;;; User visible interface.
-;;;
-
-(defun make-breakpoint (hook-function what
-			&key (kind :code-location) info function-end-cookie)
-  "This creates and returns a breakpoint.  When program execution encounters
-   the breakpoint, the system calls hook-function.  Hook-function takes the
-   current frame for the function in which the program is running and the
-   breakpoint object.
-      What and kind determine where in a function the system invokes
-   hook-function.  What is either a code-location or a debug-function.  Kind is
-   one of :code-location, :function-start, or :function-end.  Since the starts
-   and ends of functions may not have code-locations representing them,
-   designate these places by supplying what as a debug-function and kind
-   indicating the :function-start or :function-end.  When what is a
-   debug-function and kind is :function-end, then hook-function must take two
-   additional arguments, a list of values returned by the function and a
-   function-end-cookie.
-      Info is information supplied by and used by the user.
-      Function-end-cookie is a function.  To implement :function-end breakpoints,
-   the system uses starter breakpoints to establish the :function-end breakpoint
-   for each invocation of the function.  Upon each entry, the system creates a
-   unique cookie to identify the invocation, and when the user supplies a
-   function for this argument, the system invokes it on the frame and the
-   cookie.  The system later invokes the :function-end breakpoint hook on the
-   same cookie.  The user may save the cookie for comparison in the hook
-   function.
-      This signals an error if what is an unknown code-location."
-  (etypecase what
-    (code-location
-     (when (code-location-unknown-p what)
-       (error "Cannot make a breakpoint at an unknown code location -- ~S."
-	      what))
-     (assert (eq kind :code-location))
-     (let ((bpt (%make-breakpoint hook-function what kind info)))
-       (etypecase what
-	 (interpreted-code-location
-	  (error "Breakpoints in interpreted code are currently unsupported."))
-	 (compiled-code-location
-	  ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
-	  (when (eq (compiled-code-location-kind what) :unknown-return)
-	    (let ((other-bpt (%make-breakpoint hook-function what
-					       :unknown-return-partner
-					       info)))
-	      (setf (breakpoint-unknown-return-partner bpt) other-bpt)
-	      (setf (breakpoint-unknown-return-partner other-bpt) bpt)))))
-       bpt))
-    (compiled-debug-function
-     (ecase kind
-       (:function-start
-	(%make-breakpoint hook-function what kind info))
-       (:function-end
-	(unless (eq (c::compiled-debug-function-returns
-		     (compiled-debug-function-compiler-debug-fun what))
-		    :standard)
-	  (error ":FUNCTION-END breakpoints are currently unsupported ~
-		  for the known return convention."))
-		  
-	(let* ((bpt (%make-breakpoint hook-function what kind info))
-	       (starter (compiled-debug-function-end-starter what)))
-	  (unless starter
-	    (setf starter (%make-breakpoint #'list what :function-start nil))
-	    (setf (breakpoint-hook-function starter)
-		  (function-end-starter-hook starter what))
-	    (setf (compiled-debug-function-end-starter what) starter))
-	  (setf (breakpoint-start-helper bpt) starter)
-	  (push bpt (breakpoint-%info starter))
-	  (setf (breakpoint-cookie-fun bpt) function-end-cookie)
-	  bpt))))
-    (interpreted-debug-function
-     (error ":function-end breakpoints are currently unsupported ~
-	     for interpreted-debug-functions."))))
-
-;;; These are unique objects created upon entry into a function by a
-;;; :function-end breakpoint's starter hook.  These are only created when users
-;;; supply :function-end-cookie to MAKE-BREAKPOINT.  Also, the :function-end
-;;; breakpoint's hook is called on the same cookie when it is created.
-;;;
-(defstruct (function-end-cookie
-	    (:print-function (lambda (obj str n)
-			       (declare (ignore obj n))
-			       (write-string "#<Function-End-Cookie>" str)))
-	    (:constructor make-function-end-cookie (bogus-lra debug-fun)))
-  ;; This is a pointer to the bogus-lra created for :function-end bpts.
-  bogus-lra
-  ;; This is the debug-function associated with the cookie.
-  debug-fun)
-
-;;; This maps bogus-lra-components to cookies, so
-;;; HANDLE-FUNCTION-END-BREAKPOINT can find the appropriate cookie for the
-;;; breakpoint hook.
-;;;
-(defvar *function-end-cookies* (make-hash-table :test #'eq))
-
-;;; FUNCTION-END-STARTER-HOOK -- Internal.
-;;;
-;;; This returns a hook function for the start helper breakpoint associated
-;;; with a :function-end breakpoint.  The returned function makes a fake LRA
-;;; that all returns go through, and this piece of fake code actually breaks.
-;;; Upon return from the break, the code provides the returnee with any values.
-;;; Since the returned function effectively activates fun-end-bpt on each entry
-;;; to debug-fun's function, we must establish breakpoint-data about
-;;; fun-end-bpt.
-;;;
-(defun function-end-starter-hook (starter-bpt debug-fun)
-  (declare (type breakpoint starter-bpt)
-	   (type compiled-debug-function debug-fun))
-  #'(lambda (frame breakpoint)
-      (declare (ignore breakpoint)
-	       (type frame frame))
-      (let ((lra-sc-offset
-	     (c::compiled-debug-function-return-pc
-	      (compiled-debug-function-compiler-debug-fun debug-fun))))
-	(multiple-value-bind (lra component offset)
-			     (make-bogus-lra
-			      (get-context-value frame vm::lra-save-offset
-						 lra-sc-offset))
-	  (setf (get-context-value frame vm::lra-save-offset lra-sc-offset)
-		lra)
-	  (let ((end-bpts (breakpoint-%info starter-bpt)))
-	    (let ((data (breakpoint-data component offset)))
-	      (setf (breakpoint-data-breakpoints data) end-bpts)
-	      (dolist (bpt end-bpts)
-		(setf (breakpoint-internal-data bpt) data)))
-	    (let ((cookie (make-function-end-cookie lra debug-fun)))
-	      (setf (gethash component *function-end-cookies*) cookie)
-	      (dolist (bpt end-bpts)
-		(let ((fun (breakpoint-cookie-fun bpt)))
-		  (when fun (funcall fun frame cookie))))))))))
-
-;;; FUNCTION-END-COOKIE-VALID-P -- Public.
-;;;
-(defun function-end-cookie-valid-p (frame cookie)
-  "This takes a function-end-cookie and a frame, and it returns whether the
-   cookie is still valid.  A cookie becomes invalid when the frame that
-   established the cookie has exited.  Sometimes cookie holders are unaware
-   of cookie invalidation because their :function-end breakpoint hooks didn't
-   run due to THROW'ing.  This takes a frame as an efficiency hack since the
-   user probably has a frame object in hand when using this routine, and it
-   saves repeated parsing of the stack and consing when asking whether a
-   series of cookies is valid."
-  (let ((lra (function-end-cookie-bogus-lra cookie))
-	(lra-sc-offset (c::compiled-debug-function-return-pc
-			(compiled-debug-function-compiler-debug-fun
-			 (function-end-cookie-debug-fun cookie)))))
-    (do ((frame frame (frame-down frame)))
-	((not frame) nil)
-      (when (and (compiled-frame-p frame)
-		 (eq lra
-		     (get-context-value frame
-					vm::lra-save-offset
-					lra-sc-offset)))
-	(return t)))))
-
-;;;
-;;; ACTIVATE-BREAKPOINT.
-;;;
-
-;;; ACTIVATE-BREAKPOINT -- Public.
-;;;
-(defun activate-breakpoint (breakpoint)
-  "This causes the system to invoke the breakpoint's hook-function until the
-   next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT.  The system invokes
-   breakpoint hook functions in the opposite order that you activate them."
-  (when (eq (breakpoint-status breakpoint) :deleted)
-    (error "Cannot activate a deleted breakpoint -- ~S." breakpoint))
-  (unless (eq (breakpoint-status breakpoint) :active)
-    (ecase (breakpoint-kind breakpoint)
-      (:code-location
-       (let ((loc (breakpoint-what breakpoint)))
-	 (etypecase loc
-	   (interpreted-code-location
-	    (error "Breakpoints in interpreted code are currently unsupported."))
-	   (compiled-code-location
-	    (activate-compiled-code-location-breakpoint breakpoint)
-	    (let ((other (breakpoint-unknown-return-partner breakpoint)))
-	      (when other
-		(activate-compiled-code-location-breakpoint other)))))))
-      (:function-start
-       (etypecase (breakpoint-what breakpoint)
-	 (compiled-debug-function
-	  (activate-compiled-function-start-breakpoint breakpoint))
-	 (interpreted-debug-function
-	  (error "I don't know how you made this, but they're unsupported -- ~S"
-		 (breakpoint-what breakpoint)))))
-      (:function-end
-       (etypecase (breakpoint-what breakpoint)
-	 (compiled-debug-function
-	  (let ((starter (breakpoint-start-helper breakpoint)))
-	    (unless (eq (breakpoint-status starter) :active)
-	      ;; May already be active by some other :function-end breakpoint.
-	      (activate-compiled-function-start-breakpoint starter)))
-	  (setf (breakpoint-status breakpoint) :active))
-	 (interpreted-debug-function
-	  (error "I don't know how you made this, but they're unsupported -- ~S"
-		 (breakpoint-what breakpoint)))))))
-  breakpoint)
-
-;;; ACTIVATE-COMPILED-CODE-LOCATION-BREAKPOINT -- Internal.
-;;;
-(defun activate-compiled-code-location-breakpoint (breakpoint)
-  (declare (type breakpoint breakpoint))
-  (let ((loc (breakpoint-what breakpoint)))
-    (declare (type compiled-code-location loc))
-    (sub-activate-breakpoint
-     breakpoint
-     (breakpoint-data (compiled-debug-function-component
-		       (code-location-debug-function loc))
-		      (+ (compiled-code-location-pc loc)
-			 (if (or (eq (breakpoint-kind breakpoint)
-				     :unknown-return-partner)
-				 (eq (compiled-code-location-kind loc)
-				     :single-value-return))
-			     vm:single-value-return-byte-offset
-			     0))))))
-
-;;; ACTIVATE-COMPILED-FUNCTION-START-BREAKPOINT -- Internal.
-;;;
-(defun activate-compiled-function-start-breakpoint (breakpoint)
-  (declare (type breakpoint breakpoint))
-  (let ((debug-fun (breakpoint-what breakpoint)))
-    (sub-activate-breakpoint
-     breakpoint
-     (breakpoint-data (compiled-debug-function-component debug-fun)
-		      (c::compiled-debug-function-start-pc
-		       (compiled-debug-function-compiler-debug-fun
-			debug-fun))))))
-
-;;; SUB-ACTIVATE-BREAKPOINT -- Internal.
-;;;
-(defun sub-activate-breakpoint (breakpoint data)
-  (declare (type breakpoint breakpoint)
-	   (type breakpoint-data data))
-  (setf (breakpoint-status breakpoint) :active)
-  (system:without-interrupts
-   (unless (breakpoint-data-breakpoints data)
-     (setf (breakpoint-data-instruction data)
-	   (system:without-gcing
-	    (breakpoint-install (kernel:get-lisp-obj-address
-				 (breakpoint-data-component data))
-				(breakpoint-data-offset data)))))
-   (setf (breakpoint-data-breakpoints data)
-	 (append (breakpoint-data-breakpoints data) (list breakpoint)))
-   (setf (breakpoint-internal-data breakpoint) data)))
-
-;;;
-;;; DEACTIVATE-BREAKPOINT.
-;;;
-
-;;; DEACTIVATE-BREAKPOINT -- Public.
-;;;
-(defun deactivate-breakpoint (breakpoint)
-  "This stops the system from invoking the breakpoint's hook-function."
-  (when (eq (breakpoint-status breakpoint) :active)
-    (system:without-interrupts
-     (let ((loc (breakpoint-what breakpoint)))
-       (etypecase loc
-	 ((or interpreted-code-location interpreted-debug-function)
-	  (error
-	   "Breakpoints in interpreted code are currently unsupported."))
-	 ((or compiled-code-location compiled-debug-function)
-	  (deactivate-compiled-breakpoint breakpoint)
-	  (let ((other (breakpoint-unknown-return-partner breakpoint)))
-	    (when other
-	      (deactivate-compiled-breakpoint other))))))))
-  breakpoint)
-
-(defun deactivate-compiled-breakpoint (breakpoint)
-  (if (eq (breakpoint-kind breakpoint) :function-end)
-      (let ((starter (breakpoint-start-helper breakpoint)))
-	(unless (find-if #'(lambda (bpt)
-			     (and (not (eq bpt breakpoint))
-				  (eq (breakpoint-status bpt) :active)))
-			 (breakpoint-%info starter))
-	  (deactivate-compiled-breakpoint starter)))
-      (let* ((data (breakpoint-internal-data breakpoint))
-	     (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
-	(setf (breakpoint-internal-data breakpoint) nil)
-	(setf (breakpoint-data-breakpoints data) bpts)
-	(unless bpts
-	  (system:without-gcing
-	   (breakpoint-remove (kernel:get-lisp-obj-address
-			       (breakpoint-data-component data))
-			      (breakpoint-data-offset data)
-			      (breakpoint-data-instruction data)))
-	  (delete-breakpoint-data data))))
-  (setf (breakpoint-status breakpoint) :inactive)
-  breakpoint)
-
-;;;
-;;; BREAKPOINT-INFO.
-;;;
-
-;;; BREAKPOINT-INFO -- Public.
-;;;
-(defun breakpoint-info (breakpoint)
-  "This returns the user maintained info associated with breakpoint.  This
-   is SETF'able."
-  (breakpoint-%info breakpoint))
-;;;
-(defun %set-breakpoint-info (breakpoint value)
-  (setf (breakpoint-%info breakpoint) value)
-  (let ((other (breakpoint-unknown-return-partner breakpoint)))
-    (when other
-      (setf (breakpoint-%info other) value))))
-;;;
-(defsetf breakpoint-info %set-breakpoint-info)
-
-;;;
-;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT.
-;;;
-
-;;; BREAKPOINT-ACTIVE-P -- Public.
-;;;
-(defun breakpoint-active-p (breakpoint)
-  "This returns whether breakpoint is currently active."
-  (ecase (breakpoint-status breakpoint)
-    (:active t)
-    ((:inactive :deleted) nil)))
-
-;;; DELETE-BREAKPOINT -- Public.
-;;;
-(defun delete-breakpoint (breakpoint)
-  "This frees system storage and removes computational overhead associated with
-   breakpoint.  After calling this, breakpoint is completely impotent and can
-   never become active again."
-  (let ((status (breakpoint-status breakpoint)))
-    (unless (eq status :deleted)
-      (when (eq status :active)
-	(deactivate-breakpoint breakpoint))
-      (setf (breakpoint-status breakpoint) :deleted)
-      (let ((other (breakpoint-unknown-return-partner breakpoint)))
-	(when other
-	  (setf (breakpoint-status other) :deleted)))
-      (when (eq (breakpoint-kind breakpoint) :function-end)
-	(let* ((starter (breakpoint-start-helper breakpoint))
-	       (breakpoints (delete breakpoint
-				    (the list (breakpoint-info starter)))))
-	  (setf (breakpoint-info starter) breakpoints)
-	  (unless breakpoints
-	    (delete-breakpoint starter)
-	    (setf (compiled-debug-function-end-starter
-		   (breakpoint-what breakpoint))
-		  nil))))))
-  breakpoint)
-
-;;;
-;;; C call out stubs.
-;;;
-
-;;; BREAKPOINT-INSTALL -- Internal.
-;;;
-;;; This actually installs the break instruction in the component.  It returns
-;;; the overwritten bits.  You must call this in a context in which GC is
-;;; disabled, so Lisp doesn't move objects around that C is pointing to.
-;;;
-(alien:def-alien-routine "breakpoint_install" c-call:unsigned-long
-  (code-obj c-call:unsigned-long)
-  (pc-offset c-call:int))
-
-;;; BREAKPOINT-REMOVE -- Internal.
-;;;
-;;; This removes the break instruction and replaces the original instruction.
-;;; You must call this in a context in which GC is disabled, so Lisp doesn't
-;;; move objects around that C is pointing to.
-;;;
-(alien:def-alien-routine "breakpoint_remove" c-call:void
-  (code-obj c-call:unsigned-long)
-  (pc-offset c-call:int)
-  (old-inst c-call:unsigned-long))
-
-(alien:def-alien-routine "breakpoint_do_displaced_inst" c-call:void
-  (scp (* unix:sigcontext))
-  (orig-inst c-call:unsigned-long))
-
-;;;
-;;; Breakpoint handlers (layer between C and exported interface).
-;;;
-
-;;; This maps components to a mapping of offsets to breakpoint-datas.
-;;;
-(defvar *component-breakpoint-offsets* (make-hash-table :test #'eq))
-
-;;; BREAKPOINT-DATA -- Internal.
-;;;
-;;; This returns the breakpoint-data associated with component cross offset.
-;;; If none exists, this makes one, installs it, and returns it.
-;;;
-(defun breakpoint-data (component offset &optional (create t))
-  (flet ((install-breakpoint-data ()
-	   (when create
-	     (let ((data (make-breakpoint-data component offset)))
-	       (push (cons offset data)
-		     (gethash component *component-breakpoint-offsets*))
-	       data))))
-    (let ((offsets (gethash component *component-breakpoint-offsets*)))
-      (if offsets
-	  (let ((data (assoc offset offsets)))
-	    (if data
-		(cdr data)
-		(install-breakpoint-data)))
-	  (install-breakpoint-data)))))
-
-;;; DELETE-BREAKPOINT-DATA -- Internal.
-;;;
-;;; We use this when there are no longer any active breakpoints corresponding
-;;; to data.
-;;;
-(defun delete-breakpoint-data (data)
-  (let* ((component (breakpoint-data-component data))
-	 (offsets (delete (breakpoint-data-offset data)
-			  (gethash component *component-breakpoint-offsets*)
-			  :key #'car)))
-    (if offsets
-	(setf (gethash component *component-breakpoint-offsets*) offsets)
-	(remhash component *component-breakpoint-offsets*)))
-  (ext:undefined-value))
-
-;;; HANDLE-BREAKPOINT -- Internal Interface.
-;;;
-;;; The C handler for interrupts calls this when it has a debugging-tool break
-;;; instruction.  This does NOT handle all breaks; for example, it does not
-;;; handle breaks for internal errors.
-;;;
-(defun handle-breakpoint (offset component signal-context)
-  (let ((data (breakpoint-data component offset nil)))
-    (unless data
-      (error "Unknown breakpoint in ~S at offset ~S."
-	      (debug-function-name (debug-function-from-pc component offset))
-	      offset))
-    (let ((breakpoints (breakpoint-data-breakpoints data)))
-      (unless breakpoints
-	(error "Breakpoint that nobody wants?"))
-      (if (eq (breakpoint-kind (car breakpoints)) :function-end)
-	  (handle-function-end-breakpoint-aux breakpoints data signal-context)
-	  (handle-breakpoint-aux breakpoints data
-				 offset component signal-context)))))
-
-;;; This holds breakpoint-datas while invoking the breakpoint hooks associated
-;;; with that particular component and location.  While they are executing, if
-;;; we hit the location again, we ignore the breakpoint to avoid infinite
-;;; recursion.  Function-end breakpoints must work differently since the
-;;; breakpoint-data is unique for each invocation.
-;;;
-(defvar *executing-breakpoint-hooks* nil)
-
-;;; HANDLE-BREAKPOINT-AUX -- Internal.
-;;;
-;;; This handles code-location and debug-function :function-start breakpoints.
-;;;
-(defun handle-breakpoint-aux (breakpoints data offset component signal-context)
-  (unless (member data *executing-breakpoint-hooks*)
-    (let ((*executing-breakpoint-hooks* (cons data
-					      *executing-breakpoint-hooks*)))
-      (invoke-breakpoint-hooks breakpoints component offset)))
-  ;; At this point breakpoints may not hold the same list as
-  ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed a
-  ;; breakpoint deactivation.  In fact, if all breakpoints were deactivated
-  ;; then data is invalid since it was deleted and so the correct one must be
-  ;; looked up if it is to be used.  If there are no more breakpoints active
-  ;; at this location, then the normal instruction has been put back, and we
-  ;; do not need to do-displaced-inst.
-  (let ((data (breakpoint-data component offset nil)))
-    (when (and data (breakpoint-data-breakpoints data))
-      ;; There breakpoint is still active, so we need to execute the displaced
-      ;; instruction and leave the breakpoint instruction behind.  The best
-      ;; way to do this is different on each machine, so we just leave it up
-      ;; to the C code.
-      (breakpoint-do-displaced-inst signal-context
-				    (breakpoint-data-instruction data))
-      (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
-
-(defun invoke-breakpoint-hooks (breakpoints component offset)
-  (let* ((debug-fun (debug-function-from-pc component offset))
-	 (frame (do ((f (top-frame) (frame-down f)))
-		    ((eq debug-fun (frame-debug-function f)) f)))) 
-    (dolist (bpt breakpoints)
-      (funcall (breakpoint-hook-function bpt)
-	       frame
-	       ;; If this is an :unknown-return-partner, then pass the
-	       ;; hook function the original breakpoint, so that users
-	       ;; arn't forced to confront the fact that some breakpoints
-	       ;; really are two.
-	       (if (eq (breakpoint-kind bpt) :unknown-return-partner)
-		   (breakpoint-unknown-return-partner bpt)
-		   bpt)))))
-
-;;; HANDLE-FUNCTION-END-BREAKPOINT -- Internal Interface
-;;; 
-(defun handle-function-end-breakpoint (offset component signal-context)
-  (let ((data (breakpoint-data component offset nil)))
-    (unless data
-      (error "Unknown breakpoint in ~S at offset ~S."
-	      (debug-function-name (debug-function-from-pc component offset))
-	      offset))
-    (let ((breakpoints (breakpoint-data-breakpoints data)))
-      (unless breakpoints
-	(error "Breakpoint that nobody wants?"))
-      (assert (eq (breakpoint-kind (car breakpoints)) :function-end))
-      (handle-function-end-breakpoint-aux breakpoints data signal-context))))
-
-;;; HANDLE-FUNCTION-END-BREAKPOINT-AUX -- Internal.
-;;;
-;;; Either HANDLE-BREAKPOINT calls this for :function-end breakpoints [old C
-;;; code] or HANDLE-FUNCTION-END-BREAKPOINT calls this directly [new C code].
-;;;
-(defun handle-function-end-breakpoint-aux (breakpoints data signal-context)
-  (delete-breakpoint-data data)
-  (let* ((scp (alien:sap-alien signal-context (* unix:sigcontext)))
-	 (frame (do ((cfp (vm:sigcontext-register scp vm::cfp-offset))
-		     (f (top-frame) (frame-down f)))
-		    ((= cfp (system:sap-int (frame-pointer f))) f)
-		  (declare (type (unsigned-byte #.vm:word-bits) cfp))))
-	 (component (breakpoint-data-component data))
-	 (cookie (gethash component *function-end-cookies*)))
-    (remhash component *function-end-cookies*)
-    (dolist (bpt breakpoints)
-      (funcall (breakpoint-hook-function bpt)
-	       frame bpt
-	       (get-function-end-breakpoint-values scp)
-	       cookie))))
-
-(defun get-function-end-breakpoint-values (scp)
-  (let ((ocfp (system:int-sap (vm:sigcontext-register scp vm::ocfp-offset)))
-	(nargs (kernel:make-lisp-obj
-		(vm:sigcontext-register scp vm::nargs-offset)))
-	(reg-arg-offsets '#.vm::register-arg-offsets)
-	(results nil))
-    (system:without-gcing
-     (dotimes (arg-num nargs)
-       (push (if reg-arg-offsets
-		 (kernel:make-lisp-obj
-		  (vm:sigcontext-register scp (pop reg-arg-offsets)))
-		 (kernel:stack-ref ocfp arg-num))
-	     results)))
-    (nreverse results)))
-
-;;;
-;;; MAKE-BOGUS-LRA (used for :function-end breakpoints)
-;;;
-
-(defconstant bogus-lra-constants 2)
-(defconstant known-return-p-slot (+ vm:code-constants-offset 1))
-
-;;; MAKE-BOGUS-LRA -- Interface.
-;;;
-(defun make-bogus-lra (real-lra &optional known-return-p)
-  "Make a bogus LRA object that signals a breakpoint trap when returned to.  If
-   the breakpoint trap handler returns, REAL-LRA is returned to.  Three values
-   are returned: the bogus LRA object, the code component it is part of, and
-   the PC offset for the trap instruction."
-  (system:without-gcing
-   (let* ((src-start (system:foreign-symbol-address
-		      "function_end_breakpoint_guts"))
-	  (src-end (system:foreign-symbol-address
-		    "function_end_breakpoint_end"))
-	  (trap-loc (system:foreign-symbol-address
-		     "function_end_breakpoint_trap"))
-	  (length (system:sap- src-end src-start))
-	  (code-object (system:%primitive c:allocate-code-object
-					  (1+ bogus-lra-constants)
-					  length))
-	  (dst-start (kernel:code-instructions code-object)))
-     (declare (type system:system-area-pointer
-		    src-start src-end dst-start trap-loc)
-	      (type kernel:index length))
-     (setf (kernel:%code-debug-info code-object) :bogus-lra)
-     (setf (kernel:code-header-ref code-object vm:code-trace-table-offset-slot)
-	   length)
-     (setf (kernel:code-header-ref code-object real-lra-slot) real-lra)
-     (setf (kernel:code-header-ref code-object known-return-p-slot)
-	   known-return-p)
-     (kernel:system-area-copy src-start 0 dst-start 0 (* length vm:byte-bits))
-     (let ((new-lra (kernel:make-lisp-obj (+ (system:sap-int dst-start)
-					     vm:other-pointer-type))))
-       (kernel:set-header-data
-	new-lra
-	(logandc2 (+ vm:code-constants-offset bogus-lra-constants 1)
-		  1))
-       (values new-lra code-object (system:sap- trap-loc src-start))))))
-
-
-
-;;;; Editor support.
-
-;;; This holds breakpoints in the slave set on behalf of the editor.
-;;;
-;(defvar *editor-breakpoints* (make-hash-table :test #'equal))
-
-;;;
-;;; Setting breakpoints.
-;;;
-
-;;; SET-BREAKPOINT-FOR-EDITOR -- Internal Interface.
-;;;
-(defun set-breakpoint-for-editor (package name-str path)
-  "The editor calls this remotely in the slave to set breakpoints.  Package is
-   the string name of a package or nil, and name-str is a string representing a
-   function name (for example, \"foo\" or \"(setf foo)\").  After finding
-   package, this READs name-str with *package* bound appropriately.  Path is
-   either a modified source-path or a symbol (:function-start or
-   :function-end).  If it is a modified source-path, it has no top-level-form
-   offset or form-number component, and it is in descent order from the root of
-   the top-level form."
-  (let* ((name (let ((*package* (if package
-				    (lisp::package-or-lose package)
-				    *package*)))
-		 (read-from-string name-str)))
-	 (debug-fun (function-debug-function (fdefinition name))))
-    (etypecase path
-      (symbol
-       (let* ((bpt (di:make-breakpoint
-		    #'(lambda (frame bpt)
-			(declare (ignore frame bpt))
-			(break "Editor installed breakpoint."))
-		    debug-fun :kind path))
-	      (remote-bpt (wire:make-remote-object bpt)))
-	 (activate-breakpoint bpt)
-	 ;;(push remote-bpt (gethash name *editor-breakpoints*))
-	 remote-bpt))
-      (cons
-       (etypecase debug-fun
-	 (compiled-debug-function
-	  (compiled-debug-function-set-breakpoint-for-editor
-	   debug-fun #|name|# path))
-	 (interpreted-debug-function
-	  (error
-	   "We don't currently support breakpoints in interpreted code.")))))))
-
-(defun compiled-debug-function-set-breakpoint-for-editor (debug-fun #|name|# path)
-  (let* ((source-paths (generate-component-source-paths
-			(compiled-debug-function-component debug-fun)))
-	 (matches nil)
-	 (matching-length 0))
-    (declare (simple-vector source-paths)
-	     (list matches)
-	     (fixnum matching-length))
-    ;; Build a list of paths that match path up to matching-length
-    ;; elements.
-    (macrolet ((maybe-store-match (path matched-len)
-		 `(cond ((> ,matched-len matching-length)
-			 (setf matches (list ,path))
-			 (setf matching-length ,matched-len))
-			((= ,matched-len matching-length)
-			 (cons ,path matches)))))
-      (dotimes (i (length source-paths))
-	(declare (fixnum i))
-	(let ((sp (svref source-paths i)))
-	  ;; Remember, first element of sp is a code-location.
-	  (do ((path-ptr path (cdr path-ptr))
-	       (sp-ptr (cdr sp) (cdr sp-ptr))
-	       (count 0 (1+ count)))
-	      ((or (null path-ptr) (null sp-ptr))
-	       (when (null sp-ptr)
-		 (maybe-store-match sp count)))
-	    (declare (list sp-ptr path-ptr)
-		     (fixnum count))
-	    (unless (= (the fixnum (car path-ptr)) (the fixnum (car sp-ptr)))
-	      (maybe-store-match sp count))))))
-    ;; If there's just one, set it; otherwise, return the conflict set.
-    (cond ((and (= (length matches) 1) (equal path (cdar matches)))
-	   (let* ((bpt (make-breakpoint
-			#'(lambda (frame bpt)
-			    (declare (ignore frame bpt))
-			    (break "Editor installed breakpoint."))
-			(wire:remote-object-value (caar matches))))
-		  (remote-bpt (wire:make-remote-object bpt)))
-	     (activate-breakpoint bpt)
-	     ;;(push remote-bpt (gethash name *editor-breakpoints*))
-	     remote-bpt))
-	  (t matches))))
-
-;;; This maps components to vectors of modified source-paths.  We assume users
-;;; will set multiple breakpoints in a given function which entails computing
-;;; this data repeatedly.  Possibly the GC hook should free this cache.  The
-;;; source-paths are modified in the following ways:
-;;;    1] The form number element (first) is clobbered with the code-location
-;;;       corresponding to the source-path.
-;;;    2] The top-level-form offset element (last) is thrown away.
-;;;    3] Everything after the first element is reversed, so the modified
-;;;       source-path actually portrays a descent into the form.
-;;;
-(defvar *component-source-locations* (make-hash-table :test #'eq))
-
-;;; GENERATE-COMPONENT-SOURCE-PATHS -- Internal.
-;;;
-;;; This returns a vector of modified source-paths, one for every code-location
-;;; in component.  The source-paths are modified as described for
-;;; *component-source-locations*.
-;;;
-(defun generate-component-source-paths (component)
-  (or (gethash component *component-source-locations*)
-      (setf (gethash component *component-source-locations*)
-	    (sub-generate-component-source-paths component))))
-
-;;; This maps source-infos to hashtables that map top-level-form offsets to
-;;; modified form-number translations (as returned by
-;;; FORM-NUMBER-TRANSLATIONS).  These are modified as described for
-;;; *component-source-locations*.
-;;;
-(defvar *source-info-offset-translations* (make-hash-table :test #'eq))
-
-;;; This is a hacking space for SUB-GENERATE-COMPONENT-SOURCE-PATHS.  We use
-;;; this because we throw away many source-paths we accumulate in this buffer
-;;; since they are not associated with code-locations.
-;;;
-(defvar *source-paths-buffer* (make-array 50 :fill-pointer t :adjustable t))
-
-;;; SUB-GENERATE-COMPONENT-SOURCE-PATHS -- Internal.
-;;;
-;;; We iterate over the code-locations in component, fetching their
-;;; source-infos and using the *source-info-offset-translations* cache.  This
-;;; computation often repeatedly sees the same source-info/tlf-offset pair, so
-;;; we see many source-paths from one form-number-translation table.  Because
-;;; of this, when we add a form-number-translations table to this cache, we add
-;;; all the source-paths in it to the result immediately.  Then later if we see
-;;; the same (not EQ though) source-info/tlf-offset form-number-translations,
-;;; we can simply check if one of the source-paths is already in the result,
-;;; and if it is, then all of them already are.  We keep the cache around
-;;; between invocations since we expect multiple breakpoints to be set in the
-;;; same function, and this is why we must check if a form-number-translations
-;;; has been added to the result; just its presence in the cache does not mean
-;;; it is in the result vector.
-;;;
-(defun sub-generate-component-source-paths (component)
-  (let ((info (kernel:%code-debug-info component)))
-    (unless info (debug-signal 'no-debug-info))
-    (let* ((function-map (get-debug-info-function-map info))
-	   (result *source-paths-buffer*))
-      (declare (simple-vector function-map)
-	       (vector result))
-      (setf (fill-pointer result) 0)
-      (flet ((copy-stuff (form-num-trans result)
-	       (declare (simple-vector form-num-trans)
-			(vector result))
-	       (dotimes (i (length form-num-trans))
-		 (declare (fixnum i))
-		 (vector-push-extend (svref form-num-trans i) result)))
-	     (convert-paths (form-num-trans)
-	       (declare (simple-vector form-num-trans))
-	       (dotimes (i (length form-num-trans) form-num-trans)
-		 (declare (fixnum i))
-		 (let* ((source-path (svref form-num-trans i)))
-		   (declare (list source-path))
-		   ;; Make the first cons point to the reversal of everything
-		   ;; else, but throw away what was the last element before the
-		   ;; reversal.
-		   (setf (cdr source-path)
-			 ;; Must copy the rest of the list, so REVERSE, but
-			 ;; the first cons cell of each list is unique.
-			 (cdr (reverse (cdr source-path))))))))
-	;; Get all possible source-paths, modifying any new additions to the
-	;; cache.
-	(do ((i 0 (+ i 2))
-	     (len (length function-map)))
-	    ((>= i len))
-	  (declare (type c::index i))
-	  (let ((d-fun (make-compiled-debug-function (svref function-map i)
-						     component)))
-	    (do-debug-function-blocks (d-block d-fun)
-	      (do-debug-block-locations (loc d-block)
-		(let* ((d-source (code-location-debug-source loc))
-		       (translations (gethash d-source
-					      *source-info-offset-translations*))
-		       (tlf-offset (code-location-top-level-form-offset loc))
-		       (loc-num (code-location-form-number loc)))
-		  (cond
-		   (translations
-		    (let ((form-num-trans (gethash tlf-offset translations)))
-		      (declare (type (or simple-vector null) form-num-trans))
-		      (cond
-		       ((not form-num-trans)
-			(let ((form-num-trans (get-form-number-translations
-					       d-source tlf-offset)))
-			  (declare (simple-vector form-num-trans))
-			  (setf (gethash tlf-offset translations) form-num-trans)
-			  (copy-stuff (convert-paths form-num-trans) result)
-			  (setf (car (svref form-num-trans loc-num))
-				(wire:make-remote-object loc))))
-		       ;; If one of these source-paths is in our result, then
-		       ;; they all are.
-		       ((find (svref form-num-trans 0) result :test #'eq)
-			(setf (car (svref form-num-trans loc-num))
-			      (wire:make-remote-object loc)))
-		       ;; Otherwise, store these source-paths in the result.
-		       (t
-			(copy-stuff form-num-trans result)
-			(setf (car (svref form-num-trans loc-num))
-			      (wire:make-remote-object loc))))))
-		   (t
-		    (let ((translations (make-hash-table :test #'eq))
-			  (form-num-trans (get-form-number-translations
-					   d-source tlf-offset)))
-		      (declare (simple-vector form-num-trans))
-		      (setf (gethash d-source *source-info-offset-translations*)
-			    translations)
-		      (setf (gethash tlf-offset translations) form-num-trans)
-		      (copy-stuff (convert-paths form-num-trans) result)
-		      (setf (car (svref form-num-trans loc-num))
-			    (wire:make-remote-object loc)))))))))))
-      ;; Copy source-paths with code-locations from the result buffer to a
-      ;; real result vector.
-      (let* ((count (count-if #'(lambda (x) (wire:remote-object-p (car x)))
-			      result))
-	     (the-real-thing (make-array count))
-	     (i -1))
-	(declare (simple-vector the-real-thing)
-		 (fixnum i count))
-	(dotimes (j count)
-	  (loop (when (wire:remote-object-p (car (aref result (incf i))))
-		  (return)))
-	  (setf (svref the-real-thing j) (aref result i)))
-	the-real-thing))))
-
-;;; GET-FORM-NUMBER-TRANSLATIONS -- Internal.
-;;;
-;;; This returns a vector of form-number translations to source-paths for
-;;; d-source and the top-level-form indicated by the top-level-form offset.
-;;;
-(defun get-form-number-translations (d-source tlf-offset)
-  (let ((name (debug-source-name d-source)))
-    (ecase (debug-source-from d-source)
-      (:file
-       (cond
-	((not (probe-file name))
-	 (format t "~%Cannot set breakpoints for editor when source file no ~
-		    longer exists:~%  ~A."
-		 (namestring name)))
-	(t
-	 (let* ((local-tlf-offset (- tlf-offset
-				     (debug-source-root-number d-source)))
-		(char-offset
-		 (aref (or (debug-source-start-positions d-source)
-			   (error "Cannot set breakpoints for editor when ~
-				   there is no start positions map."))
-		       local-tlf-offset)))
-	   (with-open-file (f name)
-	     (cond
-	      ((= (debug-source-created d-source) (file-write-date name))
-	       (file-position f char-offset))
-	      (t
-	       (format t
-		       "~%While setting a breakpoint for the editor, noticed ~
-			source file has been modified since compilation:~%  ~A~@
-			Using form offset instead of character position.~%"
-		       (namestring name))
-	       (dotimes (i local-tlf-offset) (read f))))
-	     (form-number-translations (read f) tlf-offset))))))
-      ((:lisp :stream)
-       (form-number-translations (svref name tlf-offset) tlf-offset)))))
-
-;;; SET-LOCATION-BREAKPOINT-FOR-EDITOR -- Internal Interface.
-;;;
-(defun set-location-breakpoint-for-editor (remote-obj-loc)
-  "The editor calls this in the slave with a remote-object representing a
-   code-location to set a breakpoint."
-  (let ((loc (wire:remote-object-value remote-obj-loc)))
-    (etypecase loc
-      (interpreted-code-location
-       (error "Breakpoints in interpreted code are currently unsupported."))
-      (compiled-code-location
-       (let* ((bpt (make-breakpoint #'(lambda (frame bpt)
-					(declare (ignore frame bpt))
-					(break "Editor installed breakpoint."))
-				    loc))
-	      (remote-bpt (wire:make-remote-object bpt)))
-	 (activate-breakpoint bpt)
-	 ;;(push remote-bpt (gethash name *editor-breakpoints*))
-	 remote-bpt)))))
-
-;;;
-;;; Deleting breakpoints.
-;;;
-
-;;; DELETE-BREAKPOINT-FOR-EDITOR -- Internal Interface.
-;;;
-(defun delete-breakpoint-for-editor (remote-obj-bpt)
-  "The editor calls this remotely in the slave to delete a breakpoint."
-  (delete-breakpoint (wire:remote-object-value remote-obj-bpt))
-  (wire:forget-remote-translation remote-obj-bpt))
-
-
-
-;;;; Miscellaneous
-
-;;; This appears here because it cannot go with the debug-function interface
-;;; since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after the debug-function
-;;; routines.
-;;;
-
-;;; DEBUG-FUNCTION-START-LOCATION -- Public.
-;;;
-(defun debug-function-start-location (debug-fun)
-  "This returns a code-location before the body of a function and after all
-   the arguments are in place.  If this cannot determine that location due to
-   a lack of debug information, it returns nil."
-  (etypecase debug-fun
-    (compiled-debug-function
-     (code-location-from-pc debug-fun
-			    (c::compiled-debug-function-start-pc
-			     (compiled-debug-function-compiler-debug-fun
-			      debug-fun))
-			    nil))
-    (interpreted-debug-function
-     ;; Return the first location if there are any, otherwise nil.
-     (handler-case (do-debug-function-blocks (block debug-fun nil)
-		     (do-debug-block-locations (loc block nil)
-		       (return-from debug-function-start-location loc)))
-       (no-debug-blocks (condx)
-	 (declare (ignore condx))
-	 nil)))))
-
-
-
-(defun print-code-locations (function)
-  (let ((debug-fun (function-debug-function function)))
-    (do-debug-function-blocks (block debug-fun)
-      (do-debug-block-locations (loc block)
-	(fill-in-code-location loc)
-	(format t "~S code location at ~D"
-		(compiled-code-location-kind loc)
-		(compiled-code-location-pc loc))
-	(debug::print-code-location-source-form loc 0)
-	(terpri)))))
diff --git a/code/debug-vm.lisp b/code/debug-vm.lisp
deleted file mode 100644
index b24d340ad1bc667408b86c02adc072bcc4d695f9..0000000000000000000000000000000000000000
--- a/code/debug-vm.lisp
+++ /dev/null
@@ -1,67 +0,0 @@
-;;; -*- Package: VM -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-vm.lisp,v 1.1 1991/08/12 08:12:18 chiles Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This is some very low-level support for the debugger :function-end
-;;; breakpoints.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "VM")
-
-(export '(make-bogus-lra))
-
-(defconstant bogus-lra-constants 2)
-(defconstant real-lra-slot (+ code-constants-offset 0))
-(defconstant known-return-p-slot (+ code-constants-offset 1))
-
-;;; MAKE-BOGUS-LRA -- Interface.
-;;;
-(defun make-bogus-lra (real-lra &optional known-return-p)
-  "Make a bogus LRA object that signals a breakpoint trap when returned to.  If
-   the breakpoint trap handler returns to the fake component, the fake code
-   template returns to real-lra.  This returns three values: the bogus LRA
-   object, the code component it points to, and the pc-offset for the trap
-   instruction."
-  (system:without-gcing
-   (let* ((src-start (truly-the system-area-pointer
-				(%primitive foreign-symbol-address
-					    "function_end_breakpoint_guts")))
-	  (src-end (truly-the system-area-pointer
-			      (%primitive foreign-symbol-address
-					  "function_end_breakpoint_end")))
-	  (trap-loc (truly-the system-area-pointer
-			       (%primitive foreign-symbol-address
-					   "function_end_breakpoint_trap")))
-	  (length (sap- src-end src-start))
-	  (code-object (%primitive allocate-code-object
-				   (1+ bogus-lra-constants)
-				   length))
-	  (dst-start (code-instructions code-object)))
-     (declare (type system-area-pointer src-start src-end dst-start trap-loc)
-	      (type index length))
-     (setf (code-header-ref code-object code-debug-info-slot) nil)
-     (setf (code-header-ref code-object code-trace-table-offset-slot) length)
-     (setf (code-header-ref code-object real-lra-slot) real-lra)
-     (setf (code-header-ref code-object known-return-p-slot) known-return-p)
-     (system-area-copy src-start 0 dst-start 0 (* length byte-bits))
-     (let ((new-lra
-	    (make-lisp-obj (+ (sap-int dst-start) other-pointer-type))))
-       (kernel:set-header-data new-lra
-			       (logandc2 (+ code-constants-offset
-					    bogus-lra-constants
-					    1)
-					 1))
-       (values new-lra
-	       code-object
-	       (sap- trap-loc src-start))))))
diff --git a/code/debug.lisp b/code/debug.lisp
deleted file mode 100644
index a8150a7a7ac17752f1c0eaab0d70f0735a156914..0000000000000000000000000000000000000000
--- a/code/debug.lisp
+++ /dev/null
@@ -1,1621 +0,0 @@
-;;; -*- Mode: Lisp; Package: Debug; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.33 1992/09/05 19:42:52 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; CMU Common Lisp Debugger.  This includes a basic command-line oriented
-;;; debugger interface as well as support for Hemlock to deliver debugger
-;;; commands to a slave Lisp.
-;;;
-;;; Written by Bill Chiles.
-;;;
-
-(in-package "DEBUG")
-
-(export '(internal-debug *in-the-debugger* backtrace *flush-debug-errors*
-	  *debug-print-level* *debug-print-length* *debug-prompt*
-	  *help-line-scroll-count* *stack-top-hint*
-
-	  *auto-eval-in-frame* var arg
-	  *only-block-start-locations* *print-location-kind*
-
-	  do-debug-command))
-
-(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))
-
-
-;;;; Variables, parameters, and constants.
-
-(defparameter *debug-print-level* 3
-  "*PRINT-LEVEL* is bound to this value when debug prints a function call.  If
-  null, use *PRINT-LEVEL*")
-
-(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
-  "This is T while in the debugger.")
-
-(defvar *debug-command-level* 0
-  "Pushes and pops/exits inside the debugger change this.")
-
-(defvar *stack-top-hint* nil
-  "If this is bound before the debugger is invoked, it is used as the stack
-   top by the debugger.")
-(defvar *stack-top* nil)
-(defvar *real-stack-top* nil)
-
-(defvar *current-frame* nil)
-
-;;; DEBUG-PROMPT -- Internal.
-;;;
-;;; This is the default for *debug-prompt*.
-;;;
-(defun debug-prompt ()
-  (let ((*standard-output* *debug-io*))
-    (terpri)
-    (prin1 (di:frame-number *current-frame*))
-    (dotimes (i *debug-command-level*) (princ "]"))
-    (princ " ")
-    (force-output)))
-
-(defparameter *debug-prompt* #'debug-prompt
-  "This is a function of no arguments that prints the debugger prompt
-   on *debug-io*.")
-
-(defconstant debug-help-string
-"
-The prompt is right square brackets, the number indicating how many
-  recursive command loops you are in.
-Debug commands do not affect * and friends, but evaluation in the debug loop
-  do affect these variables.
-Any command may be uniquely abbreviated.
-
-Getting in and out of DEBUG:
-  Q        throws to top level.
-  GO       calls CONTINUE which tries to proceed with the restart 'continue.
-  RESTART  invokes restart numbered as shown (prompt if not given).
-  ERROR    prints the error condition and restart cases.
-  FLUSH    toggles *flush-debug-errors*, which is initially t.
- 
-  The name of any restart, or its number, is a valid command, and is the same
-    as using RESTART to invoke that restart.
-
-Changing frames:
-  U  up frame        D  down frame       T  top frame       B  bottom frame
-
-  F n   goes to frame n.
-
-Inspecting frames:
-  BACKTRACE [n]  shows n frames going down the stack.
-  L              lists locals in current function.
-  P, PP          displays current function call.
-  SOURCE [n]     displays frame's source form with n levels of enclosing forms.
-  VSOURCE [n]    displays frame's source form without any ellipsis.
-
-Breakpoints and steps:
-  LIST-LOCATIONS [{function | :c}]  list the locations for breakpoints.
-    Specify :c for the current frame.  Abbreviation: LL
-  LIST-BREAKPOINTS                  list the active breakpoints.
-    Abbreviations: LB, LBP
-  DELETE-BREAKPOINT [n]             remove breakpoint n or all breakpoints.
-    Abbreviations: DEL, DBP    
-  BREAKPOINT {n | :end | :start} [:break form] [:function function]
-    [{:print form}*] [:condition form]    set a breakpoint.
-    Abbreviations: BR, BP
-  STEP [n]                          step to the next location or step n times.
-
-Function and macro commands:
- (DEBUG:DEBUG-RETURN expression)
-    returns expression's values from the current frame, exiting the debugger.
- (DEBUG:ARG n)
-    returns the n'th argument, remaining in the debugger.
- (DEBUG:VAR string-or-symbol [id])
-    returns the specified variable's value, remaining in the debugger.
-
-See the CMU Common Lisp User's Manual for more information.
-")
-
-
-;;;; Breakpoint state:
-
-(defvar *only-block-start-locations* nil
-  "When true, the LIST-LOCATIONS command only displays block start locations.
-   Otherwise, all locations are displayed.")
-
-(defvar *print-location-kind* nil
-  "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.
-;;;
-(defvar *bad-code-location-types* '(:call-site :internal-error))
-(declaim (type list *bad-code-location-types*))
-
-;;; Code locations of the possible breakpoints
-;;;
-(defvar *possible-breakpoints*)
-(declaim (type list *possible-breakpoints*))
-
-;;; A list of the made and active breakpoints, each is a breakpoint-info
-;;; structure.
-;;;
-(defvar *breakpoints* nil)
-(declaim (type list *breakpoints*))
-
-;;; A list of breakpoint-info structures of the made and active step
-;;; breakpoints.
-;;;
-(defvar *step-breakpoints* nil)  
-(declaim (type list *step-breakpoints*))
-
-;;; Number of times left to step.
-;;;
-(defvar *number-of-steps* 1)
-(declaim (type integer *number-of-steps*))
-
-;;; Used when listing and setting breakpoints.
-;;;
-(defvar *default-breakpoint-debug-function* nil)
-(declaim (type (or list di:debug-function) *default-breakpoint-debug-function*))
-
-
-;;;; Code location utilities:
-
-;;; FIRST-CODE-LOCATION -- Internal.
-;;;
-;;; Returns the first code-location in the passed debug block
-;;;
-(defun first-code-location (debug-block)
-  (let ((found nil)
-	(first-code-location nil))
-    (di:do-debug-block-locations (code-location debug-block)
-      (unless found 
-	(setf first-code-location code-location)
-	(setf found t)))
-    first-code-location))
-
-;;; NEXT-CODE-LOCATIONS -- Internal.
-;;;
-;;; 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)
-  (let ((debug-block (di:code-location-debug-block code-location))
-	(block-code-locations nil))
-    (di:do-debug-block-locations (block-code-location debug-block)
-      (unless (member (di:code-location-kind block-code-location)
-		      *bad-code-location-types*)
-	(push block-code-location block-code-locations)))
-    (setf block-code-locations (nreverse block-code-locations))
-    (let* ((code-loc-list (rest (member code-location block-code-locations
-					:test #'di:code-location=)))
-	   (next-list (cond (code-loc-list
-			     (list (first code-loc-list)))
-			    ((map 'list #'first-code-location
-				  (di:debug-block-successors debug-block)))
-			    (t nil))))
-      (when (and (= (length next-list) 1)
-		 (di:code-location= (first next-list) code-location))
-	(setf next-list (next-code-locations (first next-list))))
-      next-list)))
-
-;;; POSSIBLE-BREAKPOINTS -- Internal.
-;;;  
-;;; Returns a list of code-locations of the possible breakpoints of the 
-;;; debug-function passed.
-;;;
-(defun possible-breakpoints (debug-function)
-  (let ((possible-breakpoints nil))
-    (di:do-debug-function-blocks (debug-block debug-function)
-      (unless (di:debug-block-elsewhere-p debug-block)
-	(if *only-block-start-locations*
-	    (push (first-code-location debug-block) possible-breakpoints)
-	    (di:do-debug-block-locations (code-location debug-block)
-	      (when (not (member (di:code-location-kind code-location)
-				 *bad-code-location-types*))
-		(push code-location possible-breakpoints))))))
-    (nreverse possible-breakpoints)))
-
-;;; LOCATION-IN-LIST -- Internal.
-;;;
-;;; Searches the info-list for the item passed (code-location, debug-function,
-;;; or breakpoint-info).  If the item passed is a debug function then kind will
-;;; be compared if it was specified.  The kind if also compared if a
-;;; breakpoint-info is passed since it's in the breakpoint.  The info structure
-;;; is returned if found.
-;;;
-(defun location-in-list (place info-list &optional (kind nil)) 
-  (when (breakpoint-info-p place)
-    (setf kind (di:breakpoint-kind (breakpoint-info-breakpoint place)))
-    (setf place (breakpoint-info-place place)))
-  (cond ((di:code-location-p place)
-	 (find place info-list
-	       :key #'breakpoint-info-place
-	       :test #'(lambda (x y) (and (di:code-location-p y)
-					  (di:code-location= x y)))))
-	(t
-	 (find place info-list
-	       :test #'(lambda (x-debug-function y-info)
-			 (let ((y-place (breakpoint-info-place y-info))
-			       (y-breakpoint (breakpoint-info-breakpoint
-					      y-info)))
-			   (and (di:debug-function-p y-place)
-				(eq x-debug-function y-place)
-				(or (not kind)
-				    (eq kind (di:breakpoint-kind
-					      y-breakpoint))))))))))
-
-
-;;; MAYBE-BLOCK-START-LOCATION  --  Internal.
-;;;
-;;; If Loc is an unknown location, then try to find the block start location.
-;;; Used by source printing to some information instead of none for the user.
-;;;
-(defun maybe-block-start-location (loc)
-  (if (di:code-location-unknown-p loc)
-      (let* ((block (di:code-location-debug-block loc))
-	     (start (di:do-debug-block-locations (loc block)
-		      (return loc))))
-	(cond ((and (not (di:debug-block-elsewhere-p block))
-		    start)
-	       (format t "~%Unknown location: using block start.~%")
-	       start)
-	      (t
-	       loc)))
-      loc))
-
-
-;;;; The BREAKPOINT-INFO structure:
-
-;;; Hold info about made breakpoints
-;;;
-(defstruct breakpoint-info
-  ;;
-  ;; Where we are going to stop.
-  (place (required-argument) :type (or di:code-location di:debug-function)) 
-  ;;
-  ;; The breakpoint returned by di:make-breakpoint.
-  (breakpoint (required-argument) :type di:breakpoint)
-  ;;
-  ;; Function returned from di:preprocess-for-eval.  If result is non-nil,
-  ;; drop into the debugger.
-  (break #'identity :type function)
-  ;; 
-  ;; Function returned from di:preprocess-for-eval.  If result is non-nil,
-  ;; eval (each) print and print results.
-  (condition #'identity :type function)
-  ;;
-  ;; List of functions from di:preprocess-for-eval to evaluate, results are
-  ;; conditionally printed.  Car of each element is the function, cdr is the
-  ;; form it goes with.
-  (print nil :type list)
-  ;;
-  ;; The number used when listing the possible breakpoints within a function.
-  ;; Could also be a symbol such as start or end.
-  (code-location-number (required-argument) :type (or symbol integer))
-  ;;
-  ;; The number used when listing the breakpoints active and to delete
-  ;; breakpoints. 
-  (breakpoint-number (required-argument) :type integer))
-
-
-;;; CREATE-BREAKPOINT-INFO -- Internal.
-;;;
-;;; Returns a new breakpoint-info structure with the info passed.
-;;;
-(defun create-breakpoint-info (place breakpoint code-location-number
-				     &key (break #'identity)
-				     (condition #'identity) (print nil))
-  (setf *breakpoints*
-	(sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
-  (let ((breakpoint-number
-	 (do ((i 1 (incf i)) (breakpoints *breakpoints* (rest breakpoints)))
-	     ((or (> i (length *breakpoints*))
-		  (not (= i (breakpoint-info-breakpoint-number
-			     (first breakpoints)))))
-
-	      i))))
-    (make-breakpoint-info :place place :breakpoint breakpoint
-			  :code-location-number code-location-number
-			  :breakpoint-number breakpoint-number
-			  :break break :condition condition :print print)))
-
-;;; PRINT-BREAKPOINT-INFO -- Internal.
-;;;
-;;; Prints the breakpoint info for the breakpoint-info structure passed.
-;;;
-(defun print-breakpoint-info (breakpoint-info)
-  (let ((place (breakpoint-info-place breakpoint-info))
-	(bp-number (breakpoint-info-breakpoint-number breakpoint-info))
-	(loc-number (breakpoint-info-code-location-number breakpoint-info)))
-    (case (di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info))
-      (:code-location 
-       (print-code-location-source-form place 0)
-       (format t "~&~S: ~S in ~S"
-	       bp-number loc-number (di:debug-function-name
-				      (di:code-location-debug-function place))))
-      (:function-start
-       (format t "~&~S: FUNCTION-START in ~S" bp-number
-	       (di:debug-function-name place)))
-      (:function-end
-       (format t "~&~S: FUNCTION-END in ~S" bp-number
-	       (di:debug-function-name place))))))
-
-
-
-;;;; Main-hook-function for steps and breakpoints
-
-;;; MAIN-HOOK-FUNCTION -- Internal.
-;;;
-;;; Must be passed as the hook function.  Keeps track of where step 
-;;; breakpoints are.
-;;;
-(defun main-hook-function (current-frame breakpoint &optional return-vals
-					 function-end-cookie)
-  (setf *default-breakpoint-debug-function*
-	(di:frame-debug-function current-frame))
-  (dolist (step-info *step-breakpoints*)
-    (di:delete-breakpoint (breakpoint-info-breakpoint step-info))
-    (let ((bp-info (location-in-list step-info *breakpoints*)))
-      (when bp-info
-	(di:activate-breakpoint (breakpoint-info-breakpoint bp-info)))))
-  (let ((*stack-top-hint* current-frame)
-	(step-hit-info
-	 (location-in-list (di:breakpoint-what breakpoint)
-			   *step-breakpoints* (di:breakpoint-kind breakpoint)))
-	(bp-hit-info
-	 (location-in-list (di:breakpoint-what breakpoint)
-			   *breakpoints* (di:breakpoint-kind breakpoint)))
-	(break)
-	(condition)
-	(string ""))
-    (setf *step-breakpoints* nil)
-    (labels ((build-string (str)
-	       (setf string (concatenate 'string string str)))
-	     (print-common-info ()
-	       (build-string 
-		(with-output-to-string (*standard-output*)
-		  (when function-end-cookie 
-		    (format t "~%Return values: ~S" return-vals))
-		  (when condition
-		    (when (breakpoint-info-print bp-hit-info)
-		      (format t "~%")
-		      (print-frame-call current-frame))
-		    (dolist (print (breakpoint-info-print bp-hit-info))
-		      (format t "~& ~S = ~S" (rest print)
-			      (funcall (first print) current-frame))))))))
-      (when bp-hit-info
-	(setf break (funcall (breakpoint-info-break bp-hit-info)
-			     current-frame))
-	(setf condition (funcall (breakpoint-info-condition bp-hit-info)
-				 current-frame)))
-      (cond ((and bp-hit-info step-hit-info (= 1 *number-of-steps*))
-	     (build-string (format nil "~&*Step (to a breakpoint)*"))
-	     (print-common-info)
-	     (break string))
-	    ((and bp-hit-info step-hit-info break)
-	     (build-string (format nil "~&*Step (to a breakpoint)*"))
-	     (print-common-info)
-	     (break string))
-	    ((and bp-hit-info step-hit-info)
-	     (print-common-info)
-	     (format t "~A" string)
-	     (decf *number-of-steps*)
-	     (step current-frame))
-	    ((and step-hit-info (= 1 *number-of-steps*))
-	     (build-string "*Step*")
-	     (break (make-condition 'step-condition :format-string string)))
-	    (step-hit-info
-	     (decf *number-of-steps*)
-	     (step current-frame))
-	    (bp-hit-info
-	     (when break
-	       (build-string (format nil "~&*Breakpoint hit*")))
-	     (print-common-info)
-	     (if break
-		 (break string)
-		 (format t "~A" string)))
-	    (t
-	     (break "Error in main-hook-function: unknown breakpoint"))))))
-
-
-
-;;; STEP -- Internal.
-;;;
-;;; Sets breakpoints at the next possible code-locations.  After calling
-;;; this either (continue) if in the debugger or just let program flow
-;;; return if in a hook function.
-(defun step (frame)
-  (cond
-   ((di:debug-block-elsewhere-p (di:code-location-debug-block
-				 (di:frame-code-location frame)))
-    (format t "Cannot step, in elsewhere code~%"))
-   (t
-    (let* ((code-location (di:frame-code-location frame))
-	   (next-code-locations (next-code-locations code-location)))
-      (cond
-       (next-code-locations
-	(dolist (code-location next-code-locations)
-	  (let ((bp-info (location-in-list code-location *breakpoints*)))
-	    (when bp-info
-	      (di:deactivate-breakpoint (breakpoint-info-breakpoint bp-info))))
-	  (let ((bp (di:make-breakpoint #'main-hook-function code-location
-					:kind :code-location)))
-	    (di:activate-breakpoint bp)
-	    (push (create-breakpoint-info code-location bp 0)
-		  *step-breakpoints*))))
-       (t
-	(let* ((debug-function (di:frame-debug-function *current-frame*))
-	       (bp (di:make-breakpoint #'main-hook-function debug-function
-				       :kind :function-end)))
-	  (di:activate-breakpoint bp)
-	  (push (create-breakpoint-info debug-function bp 0)
-		*step-breakpoints*))))))))
-
-
-
-;;;; Backtrace:
-
-;;; BACKTRACE -- Public.
-;;;
-(defun backtrace (&optional (count most-positive-fixnum)
-			    (*standard-output* *debug-io*))
-  "Show a listing of the call stack going down from the current frame.  In the
-   debugger, the current frame is indicated by the prompt.  Count is how many
-   frames to show."
-  (let ((*print-length* (or *debug-print-length* *print-length*))
-	(*print-level* (or *debug-print-level* *print-level*)))
-    (fresh-line *standard-output*)
-    (do ((frame (if *in-the-debugger* *current-frame* (di:top-frame))
-		(di:frame-down frame))
-	 (count count (1- count)))
-	((or (null frame) (zerop count))
-	 (values))
-      (print-frame-call frame :number t))))
-
-
-;;;; Frame printing:
-
-(eval-when (compile eval)
-
-;;; LAMBDA-LIST-ELEMENT-DISPATCH -- Internal.
-;;;
-;;; This is a convenient way to express what to do for each type of lambda-list
-;;; element.
-;;;
-(defmacro lambda-list-element-dispatch (element &key required optional rest
-						keyword deleted)
-  `(etypecase ,element
-     (di:debug-variable
-      ,@required)
-     (cons
-      (ecase (car ,element)
-	(:optional ,@optional)
-	(:rest ,@rest)
-	(:keyword ,@keyword)))
-     (symbol
-      (assert (eq ,element :deleted))
-      ,@deleted)))
-
-(defmacro lambda-var-dispatch (variable location deleted valid other)
-  (let ((var (gensym)))
-    `(let ((,var ,variable))
-       (cond ((eq ,var :deleted) ,deleted)
-	     ((eq (di:debug-variable-validity ,var ,location) :valid) ,valid)
-	     (t ,other)))))
-
-) ;EVAL-WHEN
-
-
-;;; This is used in constructing arg lists for debugger printing when the arg
-;;; list is unavailable, some arg is unavailable or unused, etc.
-;;;
-(defstruct (unprintable-object
-	    (:constructor make-unprintable-object (string))
-	    (:print-function (lambda (x s d)
-			       (declare (ignore d))
-			       (format s "#<~A>"
-				       (unprintable-object-string x)))))
-  string)
-
-;;; PRINT-FRAME-CALL-1 -- Internal.
-;;;
-;;; This prints frame with verbosity level 1.  If we hit a rest-arg, 
-;;; then print as many of the values as possible,
-;;; punting the loop over lambda-list variables since any other arguments
-;;; will be in the rest-arg's list of values.
-;;;
-(defun print-frame-call-1 (frame)
-  (let* ((d-fun (di:frame-debug-function frame))
-	 (loc (di:frame-code-location frame))
-	 (results (list (di:debug-function-name d-fun))))
-    (handler-case
-	(dolist (ele (di:debug-function-lambda-list d-fun))
-	  (lambda-list-element-dispatch ele
-	    :required ((push (frame-call-arg ele loc frame) results))
-	    :optional ((push (frame-call-arg (second ele) loc frame) results))
-	    :keyword ((push (second ele) results)
-		      (push (frame-call-arg (third ele) loc frame) results))
-	    :deleted ((push (frame-call-arg ele loc frame) results))
-	    :rest ((lambda-var-dispatch (second ele) loc
-		     nil
-		     (progn
-		       (setf results
-			     (append (reverse (di:debug-variable-value
-					       (second ele) frame))
-				     results))
-		       (return))
-		     (push (make-unprintable-object "unavaliable-rest-arg")
-			   results)))))
-      (di:lambda-list-unavailable
-       ()
-       (push (make-unprintable-object "lambda-list-unavailable") results)))
-    (prin1 (nreverse results))
-    (when (di:debug-function-kind d-fun)
-      (write-char #\[)
-      (prin1 (di:debug-function-kind d-fun))
-      (write-char #\]))))
-;;;
-(defun frame-call-arg (var location frame)
-  (lambda-var-dispatch var location
-    (make-unprintable-object "unused-arg")
-    (di:debug-variable-value var frame)
-    (make-unprintable-object "unavailable-arg")))
-
-;;; 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
-;;; printing the debug-function's name, and one indicates displaying call-like,
-;;; one-liner format with argument values.
-;;;
-(defun print-frame-call (frame &key
-			       ((:print-length *print-length*)
-				(or *debug-print-length* *print-length*))
-			       ((:print-level *print-level*)
-				(or *debug-print-level* *print-level*))
-			       (verbosity 1)
-			       (number nil))
-  (cond
-   ((zerop verbosity)
-    (when number
-      (format t "~&~S: " (di:frame-number frame)))
-    (format t "~S" frame))
-   (t
-    (when number
-      (format t "~&~S: " (di:frame-number frame)))
-    (print-frame-call-1 frame)))
-  (when (>= verbosity 2)
-    (let ((loc (di:frame-code-location frame)))
-      (handler-case
-	  (progn
-	    (di:code-location-debug-block loc)
-	    (format t "~%Source: ")
-	    (print-code-location-source-form loc 0))
-	(di:debug-condition (ignore) ignore)
-	(error (cond) (format t "Error finding source: ~A" cond))))))
-
-
-;;;; Invoke-debugger.
-
-(defvar *debugger-hook* nil
-  "This is either nil or a function of two arguments, a condition and the value
-   of *debugger-hook*.  This function can either handle the condition or return
-   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.")
-
-;;; These are bound on each invocation of INVOKE-DEBUGGER.
-;;;
-(defvar *debug-restarts*)
-(defvar *debug-condition*)
-
-;;; INVOKE-DEBUGGER -- Public.
-;;;
-(defun invoke-debugger (condition)
-  "The CMU Common Lisp debugger.  Type h for help."
-  (when *debugger-hook*
-    (let ((hook *debugger-hook*)
-	  (*debugger-hook* nil))
-      (funcall hook condition hook)))
-  (unix:unix-sigsetmask 0)
-  (let* ((*debug-condition* condition)
-	 (*debug-restarts* (compute-restarts))
-	 (*standard-input* *debug-io*)		;in case of setq
-	 (*standard-output* *debug-io*)		;''  ''  ''  ''
-	 (*error-output* *debug-io*)
-	 ;; Rebind some printer control variables.
-	 (kernel:*current-level* 0)
-	 (*print-readably* nil)
-	 (*read-eval* t))
-    (format *error-output* "~2&~A~2&" *debug-condition*)
-    (unless (typep condition 'step-condition)
-      (show-restarts *debug-restarts* *error-output*))
-    (internal-debug)))
-
-;;; SHOW-RESTARTS -- Internal.
-;;;
-(defun show-restarts (restarts &optional (s *error-output*))
-  (when restarts
-    (format s "~&Restarts:~%")
-    (let ((count 0)
-	  (names-used '(nil))
-	  (max-name-len 0))
-      (dolist (restart restarts)
-	(let ((name (restart-name restart)))
-	  (when name
-	    (let ((len (length (princ-to-string name))))
-	      (when (> len max-name-len)
-		(setf max-name-len len))))))
-      (unless (zerop max-name-len)
-	(incf max-name-len 3))
-      (dolist (restart restarts)
-	(let ((name (restart-name restart)))
-	  (cond ((member name names-used)
-		 (format s "~& ~2D: ~@VT~A~%" count max-name-len restart))
-		(t
-		 (format s "~& ~2D: [~VA] ~A~%"
-			 count (- max-name-len 3) name restart)
-		 (push name names-used))))
-	(incf count)))))
-
-;;; INTERNAL-DEBUG -- Internal Interface.
-;;;
-;;; This calls DEBUG-LOOP, performing some simple initializations before doing
-;;; so.  INVOKE-DEBUGGER calls this to actually get into the debugger.
-;;; CONDITIONS::ERROR-ERROR calls this in emergencies to get into a debug
-;;; prompt as quickly as possible with as little risk as possible for stepping
-;;; on whatever is causing recursive errors.
-;;;
-(defun internal-debug ()
-  (let ((*in-the-debugger* t)
-	(*read-suppress* nil))
-    (unless (typep *debug-condition* 'step-condition)
-      (clear-input *debug-io*)
-      (format *debug-io* "~2&Debug  (type H for help)~2%"))
-    (debug-loop)))
-
-
-
-;;;; Debug-loop.
-
-(defvar *flush-debug-errors* t
-  "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
-   executing in the debugger.  The 'flush' command toggles this.")
-
-(defun debug-loop ()
-  (let* ((*debug-command-level* (1+ *debug-command-level*))
-	 (*real-stack-top* (di:top-frame))
-	 (*stack-top* (or *stack-top-hint* *real-stack-top*))
-	 (*stack-top-hint* nil)
-	 (*current-frame* *stack-top*))
-    (handler-bind ((di:debug-condition #'(lambda (condition)
-					   (princ condition *debug-io*)
-					   (throw 'debug-loop-catcher nil))))
-      (fresh-line)
-      (print-frame-call *current-frame* :verbosity 2)
-      (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)))))
-	    ;; Must bind level for restart function created by
-	    ;; WITH-SIMPLE-RESTART.
-	    (let ((level *debug-command-level*)
-		  (restart-commands (make-restart-commands)))
-	      (with-simple-restart (abort "Return to debug level ~D." level)
-		(funcall *debug-prompt*)
-		(let ((input (ext:get-stream-command *debug-io*)))
-		  (cond (input
-			 (let ((cmd-fun (debug-command-p
-					 (ext:stream-command-name input)
-					 restart-commands)))
-			   (cond
-			    ((not cmd-fun)
-			     (error "Unknown stream-command -- ~S." input))
-			    ((consp cmd-fun)
-			     (error "Ambiguous debugger command: ~S." cmd-fun))
-			    (t
-			     (apply cmd-fun (ext:stream-command-args input))))))
-			(t
-			 (let* ((exp (read))
-				(cmd-fun (debug-command-p exp restart-commands)))
-			   (cond ((not cmd-fun)
-				  (debug-eval-print exp))
-				 ((consp cmd-fun)
-				  (format t "~&Your command, ~S, is ambiguous:~%"
-					  exp)
-				  (dolist (ele cmd-fun)
-				    (format t "   ~A~%" ele)))
-				 (t
-				  (funcall cmd-fun)))))))))))))))
-
-(defvar *auto-eval-in-frame* t
-  "When set (the default), evaluations in the debugger's command loop occur
-   relative to the current frame's environment without the need of debugger
-   forms that explicitly control this kind of evaluation.")
-
-(defun debug-eval-print (exp)
-  (setq +++ ++ ++ + + - - exp)
-  (let* ((values (multiple-value-list
-		  (if (and (fboundp 'eval:internal-eval) *auto-eval-in-frame*)
-		      (di:eval-in-frame *current-frame* -)
-		      (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."))))
-
-
-
-;;;; Debug loop functions.
-
-;;; These commands are function, not really commands, so users can get their
-;;; hands on the values returned.
-;;;
-
-(eval-when (eval compile)
-
-(defmacro define-var-operation (ref-or-set &optional value-var)
-  `(let* ((temp (etypecase name
-		  (symbol (di:debug-function-symbol-variables
-			   (di:frame-debug-function *current-frame*)
-			   name))
-		  (simple-string (di:ambiguous-debug-variables
-				  (di:frame-debug-function *current-frame*)
-				  name))))
-	  (location (di:frame-code-location *current-frame*))
-	  ;; Let's only deal with valid variables.
-	  (vars (remove-if-not #'(lambda (v)
-				   (eq (di:debug-variable-validity v location)
-				       :valid))
-			       temp)))
-     (declare (list vars))
-     (cond ((null vars)
-	    (error "No known valid variables match ~S." name))
-	   ((= (length vars) 1)
-	    ,(ecase ref-or-set
-	       (:ref
-		'(di:debug-variable-value (car vars) *current-frame*))
-	       (:set
-		`(setf (di:debug-variable-value (car vars) *current-frame*)
-		       ,value-var))))
-	   (t
-	    ;; Since we have more than one, first see if we have any
-	    ;; variables that exactly match the specification.
-	    (let* ((name (etypecase name
-			   (symbol (symbol-name name))
-			   (simple-string name)))
-		   (exact (remove-if-not #'(lambda (v)
-					     (string= (di:debug-variable-name v)
-						      name))
-					 vars))
-		   (vars (or exact vars)))
-	      (declare (simple-string name)
-		       (list exact vars))
-	      (cond
-	       ;; Check now for only having one variable.
-	       ((= (length vars) 1)
-		,(ecase ref-or-set
-		   (:ref
-		    '(di:debug-variable-value (car vars) *current-frame*))
-		   (:set
-		    `(setf (di:debug-variable-value (car vars) *current-frame*)
-			   ,value-var))))
-	       ;; If there weren't any exact matches, flame about ambiguity
-	       ;; unless all the variables have the same name.
-	       ((and (not exact)
-		     (find-if-not
-		      #'(lambda (v)
-			  (string= (di:debug-variable-name v)
-				   (di:debug-variable-name (car vars))))
-		      (cdr vars)))
-		(error "Specification ambiguous:~%~{   ~A~%~}"
-		       (mapcar #'di:debug-variable-name
-			       (delete-duplicates
-				vars :test #'string=
-				:key #'di:debug-variable-name))))
-	       ;; All names are the same, so see if the user ID'ed one of them.
-	       (id-supplied
-		(let ((v (find id vars :key #'di:debug-variable-id)))
-		  (unless v
-		    (error "Invalid variable ID, ~D, should have been one of ~S."
-			   id (mapcar #'di:debug-variable-id vars)))
-		  ,(ecase ref-or-set
-		     (:ref
-		      '(di:debug-variable-value v *current-frame*))
-		     (:set
-		      `(setf (di:debug-variable-value v *current-frame*)
-			     ,value-var)))))
-	       (t
-		(error "Specify variable ID to disambiguate ~S.  Use one of ~S."
-		       name (mapcar #'di:debug-variable-id vars)))))))))
-
-) ;EVAL-WHEN
-
-;;; VAR -- Public.
-;;;
-(defun var (name &optional (id 0 id-supplied))
-  "Returns a variable's value if possible.  Name is a simple-string or symbol.
-   If it is a simple-string, it is an initial substring of the variable's name.
-   If name is a symbol, it has the same name and package as the variable whose
-   value this function returns.  If the symbol is uninterned, then the variable
-   has the same name as the symbol, but it has no package.
-
-   If name is the initial substring of variables with different names, then
-   this return no values after displaying the ambiguous names.  If name
-   determines multiple variables with the same name, then you must use the
-   optional id argument to specify which one you want.  If you left id
-   unspecified, then this returns no values after displaying the distinguishing
-   id values.
-
-   The result of this function is limited to the availability of variable
-   information.  This is SETF'able."
-  (define-var-operation :ref))
-;;;
-(defun (setf var) (value name &optional (id 0 id-supplied))
-  (define-var-operation :set value))
-
-
-
-;;; ARG -- Public.
-;;;
-(defun arg (n)
-  "Returns the n'th argument's value if possible.  Argument zero is the first
-   argument in a frame's default printed representation.  Count keyword/value
-   pairs as separate arguments."
-  (multiple-value-bind
-      (var lambda-var-p)
-      (nth-arg n (handler-case (di:debug-function-lambda-list
-				(di:frame-debug-function *current-frame*))
-		   (di:lambda-list-unavailable ()
-		     (error "No argument values are available."))))
-    (if lambda-var-p
-	(lambda-var-dispatch var (di:frame-code-location *current-frame*)
-	  (error "Unused arguments have no values.")
-	  (di:debug-variable-value var *current-frame*)
-	  (error "Invalid argument value."))
-	var)))
-
-;;; NTH-ARG -- Internal.
-;;;
-;;; This returns the n'th arg as the user sees it from args, the result of
-;;; DI:DEBUG-FUNCTION-LAMBDA-LIST.  If this returns a potential debug-variable
-;;; from the lambda-list, then the second value is t.  If this returns a
-;;; keyword symbol or a value from a rest arg, then the second value is nil.
-;;;
-(defun nth-arg (count args)
-  (let ((n count))
-    (dolist (ele args (error "Argument specification out of range -- ~S." n))
-      (lambda-list-element-dispatch ele
-	:required ((if (zerop n) (return (values ele t))))
-	:optional ((if (zerop n) (return (values (second ele) t))))
-	:keyword ((cond ((zerop n)
-			 (return (values (second ele) nil)))
-			((zerop (decf n))
-			 (return (values (third ele) t)))))
-	:deleted ((if (zerop n) (return (values ele t))))
-	:rest ((let ((var (second ele)))
-		 (lambda-var-dispatch var
-				      (di:frame-code-location *current-frame*)
-		   (error "Unused rest-arg before n'th argument.")
-		   (dolist (value
-			    (di:debug-variable-value var *current-frame*)
-			    (error "Argument specification out of range -- ~S."
-				   n))
-		     (if (zerop n)
-			 (return-from nth-arg (values value nil))
-			 (decf n)))
-		   (error "Invalid rest-arg before n'th argument.")))))
-      (decf n))))
-
-
-
-;;;; Debug loop command definition:
-
-(defvar *debug-commands* nil)
-
-;;; DEF-DEBUG-COMMAND -- Internal.
-;;;
-;;; Interface to *debug-commands*.  No required arguments in args are
-;;; permitted.
-;;;
-(defmacro def-debug-command (name args &rest body)
-  (let ((fun-name (intern (concatenate 'simple-string name "-DEBUG-COMMAND"))))
-    `(progn
-       (when (assoc ,name *debug-commands* :test #'string=)
-	 (warn "Redefining ~S debugger command." ,name)
-	 (setf *debug-commands*
-	       (remove ,name *debug-commands* :key #'car :test #'string=)))
-       (defun ,fun-name ,args
-	 (unless *in-the-debugger*
-	   (error "Invoking debugger command while outside the debugger."))
-	 ,@body)
-       (push (cons ,name #',fun-name) *debug-commands*)
-       ',fun-name)))
-
-;;; DEF-DEBUG-COMMAND-ALIAS -- Internal.
-;;;
-(defun def-debug-command-alias (new-name existing-name)
-  (let ((pair (assoc existing-name *debug-commands* :test #'string=)))
-    (unless pair (error "Unknown debug command name -- ~S" existing-name))
-    (push (cons new-name (cdr pair)) *debug-commands*))
-  new-name)
-
-;;; DEBUG-COMMAND-P -- Internal.
-;;;
-;;; This takes a symbol and uses its name to find a debugger command, using
-;;; initial substring matching.  It returns the command function if form
-;;; identifies only one command, but if form is ambiguous, this returns a list
-;;; of the command names.  If there are no matches, this returns nil.  Whenever
-;;; the loop that looks for a set of possibilities encounters an exact name
-;;; match, we return that command function immediately.
-;;;
-(defun debug-command-p (form &optional other-commands)
-  (if (or (symbolp form) (integerp form))
-      (let* ((name
-	      (if (symbolp form)
-		  (symbol-name form)
-		  (format nil "~d" form)))
-	     (len (length name))
-	     (res nil))
-	(declare (simple-string name)
-		 (fixnum len)
-		 (list res))
-	;;
-	;; Find matching commands, punting if exact match.
-	(flet ((match-command (ele)
-	         (let* ((str (car ele))
-			(str-len (length str)))
-		   (declare (simple-string str)
-			    (fixnum str-len))
-		   (cond ((< str-len len))
-			 ((= str-len len)
-			  (when (string= name str :end1 len :end2 len)
-			    (return-from debug-command-p (cdr ele))))
-			 ((string= name str :end1 len :end2 len)
-			  (push ele res))))))
-	  (mapc #'match-command *debug-commands*)
-	  (mapc #'match-command other-commands))
-	;;
-	;; Return the right value.
-	(cond ((not res) nil)
-	      ((= (length res) 1)
-	       (cdar res))
-	      (t ;Just return the names.
-	       (do ((cmds res (cdr cmds)))
-		   ((not cmds) res)
-		 (setf (car cmds) (caar cmds))))))))
-
-
-;;;
-;;; Returns a list of debug commands (in the same format as *debug-commands*)
-;;; that invoke each active restart.
-;;;
-;;; Two commands are made for each restart: one for the number, and one for
-;;; the restart name (unless it's been shadowed by an earlier restart of the
-;;; same name.
-;;;
-(defun make-restart-commands (&optional (restarts *debug-restarts*))
-  (let ((commands)
-	(num 0))			; better be the same as show-restarts!
-    (dolist (restart restarts)
-      (let ((name (string (restart-name restart))))
-	(unless (find name commands :key #'car :test #'string=)
-	  (let ((restart-fun
-		 #'(lambda ()
-		     (invoke-restart-interactively restart))))
-	    (push (cons name restart-fun) commands)
-	    (push (cons (format nil "~d" num) restart-fun) commands))))
-      (incf num))
-    commands))
-
-
-;;;
-;;; Frame changing commands.
-;;;
-
-(def-debug-command "UP" ()
-  (let ((next (di:frame-up *current-frame*)))
-    (cond (next
-	   (setf *current-frame* next)
-	   (print-frame-call next))
-	  (t
-	   (format t "~&Top of stack.")))))
-  
-(def-debug-command "DOWN" ()
-  (let ((next (di:frame-down *current-frame*)))
-    (cond (next
-	   (setf *current-frame* next)
-	   (print-frame-call next))
-	  (t
-	   (format t "~&Bottom of stack.")))))
-
-(def-debug-command-alias "D" "DOWN")
-
-(def-debug-command "TOP" ()
-  (do ((prev *current-frame* lead)
-       (lead (di:frame-up *current-frame*) (di:frame-up lead)))
-      ((null lead)
-       (setf *current-frame* prev)
-       (print-frame-call prev))))
-
-(def-debug-command "BOTTOM" ()
-  (do ((prev *current-frame* lead)
-       (lead (di:frame-down *current-frame*) (di:frame-down lead)))
-      ((null lead)
-       (setf *current-frame* prev)
-       (print-frame-call prev))))
-
-
-(def-debug-command-alias "B" "BOTTOM")
-
-(def-debug-command "FRAME" (&optional
-			    (n (read-prompting-maybe "Frame number: ")))
-  (let ((current (di:frame-number *current-frame*)))
-    (cond ((= n current)
-	   (princ "You are here."))
-	  ((> n current)
-	   (print-frame-call
-	    (setf *current-frame*
-		  (do ((prev *current-frame* lead)
-		       (lead (di:frame-down *current-frame*)
-			     (di:frame-down lead)))
-		      ((null lead)
-		       (princ "Bottom of stack encountered.")
-		       prev)
-		    (when (= n (di:frame-number prev))
-		      (return prev))))))
-	  (t
-	   (print-frame-call
-	    (setf *current-frame*
-		  (do ((prev *current-frame* lead)
-		       (lead (di:frame-up *current-frame*)
-			     (di:frame-up lead)))
-		      ((null lead)
-		       (princ "Top of stack encountered.")
-		       prev)
-		    (when (= n (di:frame-number prev))
-		      (return prev)))))))))
-
-(def-debug-command-alias "F" "FRAME")
-
-
-;;;
-;;; In and Out commands.
-;;;
-
-(def-debug-command "QUIT" ()
-  (throw 'lisp::top-level-catcher nil))
-
-(def-debug-command "GO" ()
-  (continue)
-  (error "No restart named continue."))
-
-(def-debug-command "RESTART" ()
-  (let ((num (read-if-available :prompt)))
-    (when (eq num :prompt)
-      (show-restarts *debug-restarts*)
-      (write-string "Restart: ")
-      (force-output)
-      (setf num (read *standard-input*)))
-    (let ((restart (typecase num
-		     (unsigned-byte
-		      (nth num *debug-restarts*))
-		     (symbol
-		      (find num *debug-restarts* :key #'restart-name
-			    :test #'(lambda (sym1 sym2)
-				      (string= (symbol-name sym1)
-					       (symbol-name sym2)))))
-		     (t
-		      (format t "~S is invalid as a restart name.~%" num)
-		      (return-from restart-debug-command nil)))))
-      (if restart
-	  (invoke-restart-interactively restart)
-	  (princ "No such restart.")))))
-
-
-;;;
-;;; Information commands.
-;;;
- 
-(defvar *help-line-scroll-count* 20
-  "This controls how many lines the debugger's help command prints before
-   printing a prompting line to continue with output.")
-
-(def-debug-command "HELP" ()
-  (let* ((end -1)
-	 (len (length debug-help-string))
-	 (len-1 (1- len)))
-    (loop
-      (let ((start (1+ end))
-	    (count *help-line-scroll-count*))
-	(loop
-	  (setf end (position #\newline debug-help-string :start (1+ end)))
-	  (cond ((or (not end) (= end len-1))
-		 (setf end len)
-		 (return))
-		((or (zerop (decf count)) (= end len))
-		 (return))))
-	(write-string debug-help-string *standard-output*
-		      :start start :end end))
-      (when (= end len) (return))
-      (format t "~%[RETURN FOR MORE, Q TO QUIT HELP TEXT]: ")
-      (force-output)
-      (let ((res (read-line)))
-	(when (or (string= res "q") (string= res "Q"))
-	  (return))))))
-
-(def-debug-command-alias "?" "HELP")
-
-(def-debug-command "ERROR" ()
-  (format t "~A~%" *debug-condition*)
-  (show-restarts *debug-restarts*))
-
-(def-debug-command "BACKTRACE" ()
-  (backtrace (read-if-available most-positive-fixnum)))
-
-(def-debug-command "PRINT" ()
-  (print-frame-call *current-frame*))
-
-(def-debug-command-alias "P" "PRINT")
-
-(def-debug-command "VPRINT" ()
-  (print-frame-call *current-frame* :print-level nil :print-length nil
-		    :verbosity (read-if-available 2)))
-
-(def-debug-command-alias "PP" "VPRINT")
-
-(def-debug-command "LIST-LOCALS" ()
-  (let ((d-fun (di:frame-debug-function *current-frame*)))
-    (if (di:debug-variable-info-available d-fun)
-	(let ((*print-level* (or *debug-print-level* *print-level*))
-	      (*print-length* (or *debug-print-length* *print-length*))
-	      (*standard-output* *debug-io*)
-	      (location (di:frame-code-location *current-frame*))
-	      (prefix (read-if-available nil))
-	      (any-p nil)
-	      (any-valid-p nil))
-	  (dolist (v (di:ambiguous-debug-variables
-			d-fun
-			(if prefix (string prefix) "")))
-	    (setf any-p t)
-	    (when (eq (di:debug-variable-validity v location) :valid)
-	      (setf any-valid-p t)
-	      (format t "~A~:[#~D~;~*~]  =  ~S~%"
-		      (di:debug-variable-name v)
-		      (zerop (di:debug-variable-id v))
-		      (di:debug-variable-id v)
-		      (di:debug-variable-value v *current-frame*))))
-
-	  (cond
-	   ((not any-p)
-	    (format t "No local variables ~@[starting with ~A ~]~
-	               in function."
-		    prefix))
-	   ((not any-valid-p)
-	    (format t "All variables ~@[starting with ~A ~]currently ~
-	               have invalid values."
-		    prefix))))
-	(write-line "No variable information available."))))
-
-(def-debug-command-alias "L" "LIST-LOCALS")
-
-(def-debug-command "SOURCE" ()
-  (fresh-line)
-  (print-code-location-source-form (di:frame-code-location *current-frame*)
-				   (read-if-available 0)))
-
-(def-debug-command "VSOURCE" ()
-  (fresh-line)
-  (print-code-location-source-form (di:frame-code-location *current-frame*)
-				   (read-if-available 0)
-				   t))
-
-
-;;;; Source location printing:
-
-;;; We cache a stream to the last valid file debug source so that we won't have
-;;; to repeatedly open the file.
-;;;
-(defvar *cached-debug-source* nil)
-(declaim (type (or di:debug-source null) *cached-debug-source*))
-(defvar *cached-source-stream* nil)
-(declaim (type (or stream null) *cached-source-stream*))
-
-(pushnew #'(lambda ()
-	     (setq *cached-debug-source* nil *cached-source-stream* nil))
-	 ext:*before-save-initializations*)
-
-
-;;; We also cache the last top-level form that we printed a source for so that
-;;; we don't have to do repeated reads and calls to FORM-NUMBER-TRANSLATIONS.
-;;;
-(defvar *cached-top-level-form-offset* nil)
-(declaim (type (or kernel:index null) *cached-top-level-form-offset*))
-(defvar *cached-top-level-form*)
-(defvar *cached-form-number-translations*)
-
-
-;;; GET-TOP-LEVEL-FORM  --  Internal
-;;;
-;;;    Given a code location, return the associated form-number translations
-;;; and the actual top-level form.  We check our cache --- if there is a miss,
-;;; we dispatch on the kind of the debug source.
-;;;
-(defun get-top-level-form (location)
-  (let ((d-source (di:code-location-debug-source location)))
-    (if (and (eq d-source *cached-debug-source*)
-	     (eql (di:code-location-top-level-form-offset location)
-		  *cached-top-level-form-offset*))
-	(values *cached-form-number-translations* *cached-top-level-form*)
-	(let* ((offset (di:code-location-top-level-form-offset location))
-	       (res
-		(ecase (di:debug-source-from d-source)
-		  (:file (get-file-top-level-form location))
-		  ((:lisp :stream)
-		   (svref (di:debug-source-name d-source) offset)))))
-	  (setq *cached-top-level-form-offset* offset)
-	  (values (setq *cached-form-number-translations*
-			(di:form-number-translations res offset))
-		  (setq *cached-top-level-form* res))))))
-
-
-;;; GET-FILE-TOP-LEVEL-FORM -- Internal.
-;;;
-;;; Locates the source file (if it still exists) and grabs the top-level form.
-;;; If the file is modified, we use the top-level-form offset instead of the
-;;; recorded character offset.
-;;;
-(defun get-file-top-level-form (location)
-  (let* ((d-source (di:code-location-debug-source location))
-	 (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))
-	 (name (di:debug-source-name d-source)))
-    (unless (eq d-source *cached-debug-source*)
-      (unless (and *cached-source-stream*
-		   (equal (pathname *cached-source-stream*)
-			  (pathname name)))
-	(when *cached-source-stream* (close *cached-source-stream*))
-	(setq *cached-source-stream* (open name :if-does-not-exist nil))
-	(unless *cached-source-stream*
-	  (error "Source file no longer exists:~%  ~A." (namestring name)))
-	(format t "~%; File: ~A~%" (namestring name)))
-
-	(setq *cached-debug-source*
-	      (if (= (di:debug-source-created d-source) (file-write-date name))
-		  d-source nil)))
-
-    (cond
-     ((eq *cached-debug-source* d-source)
-      (file-position *cached-source-stream* char-offset))
-     (t
-      (format t "~%; File has been modified since compilation:~%;   ~A~@
-		 ; Using form offset instead of character position.~%"
-	      (namestring name))
-      (file-position *cached-source-stream* 0)
-      (let ((*read-suppress* t))
-	(dotimes (i local-tlf-offset)
-	  (read *cached-source-stream*)))))
-    (read *cached-source-stream*)))
-
-
-;;; PRINT-CODE-LOCATION-SOURCE-FORM -- Internal.
-;;;
-(defun print-code-location-source-form (location context &optional verbose)
-  (let* ((location (maybe-block-start-location location))
-	 (*print-level* (if verbose
-			    nil
-			    (or *debug-print-level* *print-level*)))
-	 (*print-length* (if verbose
-			     nil
-			     (or *debug-print-length* *print-length*))))
-    (multiple-value-bind (translations form)
-			 (get-top-level-form location)
-      
-      (prin1 (di:source-path-context
-	      form
-	      (svref translations
-		     (di:code-location-form-number location))
-	      context)))))
-
-
-;;;
-;;; Breakpoint and step commands.
-;;;
-
-;;; Steps to the next code-location
-(def-debug-command "STEP" ()
-  (setf *number-of-steps* (read-if-available 1))
-  (step *current-frame*)
-  (continue)
-  (error "Couldn't continue."))
-  
-;;; Lists possible breakpoint locations, which are active, and where go will
-;;; continue.  Sets *possible-breakpoints* to the code-locations which can then
-;;; be used by sbreakpoint.  Takes a function as an optional argument.
-(def-debug-command "LIST-LOCATIONS" ()
-  (let ((df (read-if-available *default-breakpoint-debug-function*)))
-    (cond ((consp df)
-	   (setf df (di:function-debug-function (eval df)))
-	   (setf *default-breakpoint-debug-function* df))	  
-	  ((or (eq ':c df)
-	       (not *default-breakpoint-debug-function*))
-	   (setf df (di:frame-debug-function *current-frame*))
-	   (setf *default-breakpoint-debug-function* df)))
-    (setf *possible-breakpoints* (possible-breakpoints df)))
-  (let ((continue-at (di:frame-code-location *current-frame*)))
-    (let ((active (location-in-list *default-breakpoint-debug-function*
-				    *breakpoints* :function-start))
-	  (here (di:code-location=
-		 (di:debug-function-start-location
-		  *default-breakpoint-debug-function*) continue-at)))
-      (when (or active here)
-	(format t "::FUNCTION-START ")
-	(when active (format t " *Active*"))
-	(when here (format t " *Continue here*"))))
-    
-    (let ((prev-location nil)
-	  (prev-num 0)
-	  (this-num 0))
-      (flet ((flush ()
-	       (when prev-location
-		 (let ((this-num (1- this-num)))
-		   (if (= prev-num this-num)
-		       (format t "~&~D: " prev-num)
-		       (format t "~&~D-~D: " prev-num this-num)))
-		 (print-code-location-source-form prev-location 0)
-		 (when *print-location-kind*
-		   (format t "~S " (di:code-location-kind prev-location)))
-		 (when (location-in-list prev-location *breakpoints*)
-		   (format t " *Active*"))
-		 (when (di:code-location= prev-location continue-at)
-		   (format t " *Continue here*")))))
-	
-	(dolist (code-location *possible-breakpoints*)
-	  (when (or *print-location-kind*
-		    (location-in-list code-location *breakpoints*)
-		    (di:code-location= code-location continue-at)
-		    (not prev-location)
-		    (not (eq (di:code-location-debug-source code-location)
-			     (di:code-location-debug-source prev-location)))
-		    (not (eq (di:code-location-top-level-form-offset
-			      code-location)
-			     (di:code-location-top-level-form-offset
-			      prev-location)))
-		    (not (eq (di:code-location-form-number code-location)
-			     (di:code-location-form-number prev-location))))
-	    (flush)
-	    (setq prev-location code-location  prev-num this-num))
-	  
-	  (incf this-num))))
-
-    (when (location-in-list *default-breakpoint-debug-function* *breakpoints*
-			    :function-end)
-      (format t "~&::FUNCTION-END *Active* "))))
-
-(def-debug-command-alias "LL" "LIST-LOCATIONS")
-    
-;;; set breakpoint at # given
-(def-debug-command "BREAKPOINT" ()
-  (let ((index (read-prompting-maybe "Location number, :start, or :end: "))
-	(break t)
-	(condition t)
-	(print nil)
-	(print-functions nil)
-	(function nil)
-	(bp)
-	(place *default-breakpoint-debug-function*))
-    (flet ((get-command-line ()
-	     (let ((command-line nil)
-		   (unique '(nil)))
-	       (loop
-		 (let ((next-input (read-if-available unique)))
-		   (when (eq next-input unique) (return))
-		   (push next-input command-line)))
-	       (nreverse command-line)))
-	   (set-vars-from-command-line (command-line)
-	     (do ((arg (pop command-line) (pop command-line)))
-		 ((not arg))
-	       (ecase arg
-		 (:condition (setf condition (pop command-line)))
-		 (:print (push (pop command-line) print))
-		 (:break (setf break (pop command-line)))
-		 (:function
-		  (setf function (eval (pop command-line)))
-		  (setf *default-breakpoint-debug-function*
-			(di:function-debug-function function))
-		  (setf *possible-breakpoints*
-			(possible-breakpoints
-			 *default-breakpoint-debug-function*))))))
-	   (setup-function-start ()
-	     (let ((code-loc (di:debug-function-start-location place)))
-	       (setf bp (di:make-breakpoint #'main-hook-function place
-					    :kind :function-start))
-	       (setf break (di:preprocess-for-eval break code-loc))
-	       (setf condition (di:preprocess-for-eval condition code-loc))
-	       (dolist (form print)
-		 (push (cons (di:preprocess-for-eval form code-loc) form)
-		       print-functions))))
-	   (setup-function-end ()
-	     (setf bp
-		   (di:make-breakpoint #'main-hook-function place
-					  :kind :function-end))
-	     (setf break
-		   (coerce `(lambda (dummy)
-				    (declare (ignore dummy)) ,break)
-				 'function))
-	     (setf condition (coerce `(lambda (dummy)
-					(declare (ignore dummy)) ,condition)
-				     'function))
-	     (dolist (form print)
-	       (push (cons
-		      (coerce `(lambda (dummy)
-				 (declare (ignore dummy)) ,form) 'function)
-		      form)
-		     print-functions)))
-	   (setup-code-location ()
-	     (setf place (nth index *possible-breakpoints*))
-	     (setf bp (di:make-breakpoint #'main-hook-function place
-					  :kind :code-location))
-	     (dolist (form print)
-	       (push (cons
-		      (di:preprocess-for-eval form place)
-		      form)
-		     print-functions))
-	     (setf break (di:preprocess-for-eval break place))
-	     (setf condition (di:preprocess-for-eval condition place))))
-      (set-vars-from-command-line (get-command-line))
-      (cond
-       ((or (eq index :start) (eq index :s))
-	(setup-function-start))
-       ((or (eq index :end) (eq index :e))
-	(setup-function-end))
-       (t
-	(setup-code-location)))
-      (di:activate-breakpoint bp)
-      (let* ((new-bp-info (create-breakpoint-info place bp index
-						  :break break
-						  :print print-functions
-						  :condition condition))
-	     (old-bp-info (location-in-list new-bp-info *breakpoints*)))
-	(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*))
-      (format t "~&Added."))))
-
-(def-debug-command-alias "BP" "BREAKPOINT")
-
-;;; list all breakpoints set
-(def-debug-command "LIST-BREAKPOINTS" ()
-  (setf *breakpoints*
-	(sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
-  (dolist (info *breakpoints*)
-    (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 372e9b669f5b318e8028761d5d86f89f87eb0fd5..0000000000000000000000000000000000000000
--- a/code/defmacro.lisp
+++ /dev/null
@@ -1,417 +0,0 @@
-;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.13 1992/08/12 18:56:32 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Blaine Burks.
-;;;
-(in-package "LISP")
-
-
-;;;; Some variable definitions.
-
-;;; Variables for amassing the results of parsing a defmacro.  Declarations
-;;; in DEFMACRO are the reason this isn't as easy as it sounds.
-;;;
-(defvar *arg-tests* ()
-  "A list of tests that do argument counting at expansion time.")
-
-(defvar *system-lets* ()
-  "Let bindings that are done to make lambda-list parsing possible.")
-
-(defvar *user-lets* ()
-  "Let bindings that the user has explicitly supplied.")
-
-(defvar *default-default* nil
-  "Unsupplied optional and keyword arguments get this value defaultly.")
-
-
-;;;; Stuff to parse DEFMACRO, MACROLET, DEFINE-SETF-METHOD, and DEFTYPE.
-
-;;; PARSE-DEFMACRO returns, as multiple-values, a body, possibly a declare
-;;; form to put where this code is inserted, and the documentation for the
-;;; parsed body.
-;;;
-(defun parse-defmacro (lambda-list arg-list-name code name error-kind
-				   &key (annonymousp nil)
-				   (doc-string-allowed t)
-				   ((:environment env-arg-name))
-				   ((:default-default *default-default*))
-				   (error-fun 'error))
-  "Returns as multiple-values a parsed body, any local-declarations that
-   should be made where this body is inserted, and a doc-string if there is
-   one."
-  (multiple-value-bind (body declarations documentation)
-		       (parse-body code nil doc-string-allowed)
-    (let* ((*arg-tests* ())
-	   (*user-lets* ())
-	   (*system-lets* ()))
-      (multiple-value-bind
-	  (env-arg-used minimum maximum)
-	  (parse-defmacro-lambda-list lambda-list arg-list-name name
-				      error-kind error-fun (not annonymousp)
-				      nil env-arg-name)
-	(values
-	 `(let* ,(nreverse *system-lets*)
-	    ,@*arg-tests*
-	    (let* ,(nreverse *user-lets*)
-	      ,@declarations
-	      ,@body))
-	 (if (and env-arg-name (not env-arg-used))
-	     `((declare (ignore ,env-arg-name)))
-	     nil)
-	 documentation
-	 minimum
-	 maximum)))))
-
-
-(defun parse-defmacro-lambda-list
-       (lambda-list arg-list-name name error-kind error-fun
-		    &optional top-level env-illegal env-arg-name)
-  (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name))
-	(now-processing :required)
-	(maximum 0)
-	(minimum 0)
-	(keys ())
-	rest-name restp allow-other-keys-p env-arg-used)
-    ;; This really strange way to test for '&whole is neccessary because member
-    ;; does not have to work on dotted lists, and dotted lists are legal
-    ;; in lambda-lists.
-    (when (and (do ((list lambda-list (cdr list)))
-		   ((atom list) nil)
-		 (when (eq (car list) '&whole) (return t)))
-	       (not (eq (car lambda-list) '&whole)))
-      (error "&Whole must appear first in ~S lambda-list." error-kind))
-    (do ((rest-of-args lambda-list (cdr rest-of-args)))
-	((atom rest-of-args)
-	 (cond ((null rest-of-args) nil)
-	       ;; Varlist is dotted, treat as &rest arg and exit.
-	       (t (push-let-binding rest-of-args path nil)
-		  (setf restp t))))
-      (let ((var (car rest-of-args)))
-	(cond ((eq var '&whole)
-	       (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
-		      (setf rest-of-args (cdr rest-of-args))
-		      (push-let-binding (car rest-of-args) arg-list-name nil))
-		     (t
-		      (defmacro-error "&WHOLE" error-kind name))))
-	      ((eq var '&environment)
-	       (cond (env-illegal
-		      (error "&Environment not valid with ~S." error-kind))
-		     ((not top-level)
-		      (error "&Environment only valid at top level of ~
-		      lambda-list.")))
-	       (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
-		      (setf rest-of-args (cdr rest-of-args))
-		      (push-let-binding (car rest-of-args) env-arg-name nil)
-		      (setf env-arg-used t))
-		     (t
-		      (defmacro-error "&ENVIRONMENT" error-kind name))))
-	      ((or (eq var '&rest) (eq var '&body))
-	       (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
-		      (setf rest-of-args (cdr rest-of-args))
-		      (setf restp t)
-		      (push-let-binding (car rest-of-args) path nil))
-		     ;;
-		     ;; This branch implements an incompatible extension to
-		     ;; Common Lisp.  In place of a symbol following &body,
-		     ;; there may be a list of up to three elements which will
-		     ;; be bound to the body, declarations, and doc-string of
-		     ;; the body.
-		     ((and (cdr rest-of-args)
-			   (consp (cadr rest-of-args))
-			   (symbolp (caadr rest-of-args)))
-		      (setf rest-of-args (cdr rest-of-args))
-		      (setf restp t)
-		      (let ((body-name (caar rest-of-args))
-			    (declarations-name (cadar rest-of-args))
-			    (doc-string-name (caddar rest-of-args))
-			    (parse-body-values (gensym)))
-			(push-let-binding
-			 parse-body-values
-			 `(multiple-value-list
-			   (parse-body ,path ,env-arg-name
-				       ,(not (null doc-string-name))))
-			 t)
-			(setf env-arg-used t)
-			(when body-name
-			  (push-let-binding body-name
-					    `(car ,parse-body-values) nil))
-			(when declarations-name
-			  (push-let-binding declarations-name
-					    `(cadr ,parse-body-values) nil))
-			(when doc-string-name
-			  (push-let-binding doc-string-name
-					    `(caddr ,parse-body-values) nil))))
-		     (t
-		      (defmacro-error (symbol-name var) error-kind name))))
-	      ((eq var '&optional)
-	       (setf now-processing :optionals))
-	      ((eq var '&key)
-	       (setf now-processing :keywords)
-	       (setf rest-name (gensym "KEYWORDS-"))
-	       (setf restp t)
-	       (push-let-binding rest-name path t))
-	      ((eq var '&allow-other-keys)
-	       (setf allow-other-keys-p t))
-	      ((eq var '&aux)
-	       (setf now-processing :auxs))
-	      ((listp var)
-	       (case now-processing
-		 (:required
-		  (let ((sub-list-name (gensym "SUBLIST-")))
-		    (push-sub-list-binding sub-list-name `(car ,path) var
-					   name error-kind error-fun)
-		    (parse-defmacro-lambda-list var sub-list-name name
-						error-kind error-fun))
-		  (setf path `(cdr ,path))
-		  (incf minimum)
-		  (incf maximum))
-		 (:optionals
-		  (when (> (length var) 3)
-		    (cerror "Ignore extra noise."
-			    "More than variable, initform, and suppliedp ~
-			    in &optional binding - ~S"
-			    var))
-		  (push-optional-binding (car var) (cadr var) (caddr var)
-					 `(not (null ,path)) `(car ,path)
-					 name error-kind error-fun)
-		  (setf path `(cdr ,path))
-		  (incf maximum))
-		 (:keywords
-		  (let* ((keyword-given (consp (car var)))
-			 (variable (if keyword-given
-				       (cadar var)
-				       (car var)))
-			 (keyword (if keyword-given
-				      (caar var)
-				      (make-keyword variable)))
-			 (supplied-p (caddr var)))
-		    (push-optional-binding variable (cadr var) supplied-p
-					   `(keyword-supplied-p ',keyword
-								,rest-name)
-					   `(lookup-keyword ',keyword
-							    ,rest-name)
-					   name error-kind error-fun)
-		    (push keyword keys)))
-		 (:auxs (push-let-binding (car var) (cadr var) nil))))
-	      ((symbolp var)
-	       (case now-processing
-		 (:required
-		  (incf minimum)
-		  (incf maximum)
-		  (push-let-binding var `(car ,path) nil)
-		  (setf path `(cdr ,path)))
-		 (:optionals
-		  (incf maximum)
-		  (push-let-binding var `(car ,path) nil `(not (null ,path)))
-		  (setf path `(cdr ,path)))
-		 (:keywords
-		  (let ((key (make-keyword var)))
-		    (push-let-binding var `(lookup-keyword ,key ,rest-name)
-				      nil)
-		    (push key keys)))
-		 (:auxs
-		  (push-let-binding var nil nil))))
-	      (t
-	       (error "Non-symbol in lambda-list - ~S." var)))))
-    (push `(unless (<= ,minimum
-		       (length (the list ,(if top-level
-					      `(cdr ,arg-list-name)
-					      arg-list-name)))
-		       ,@(unless restp
-			   (list maximum)))
-	     (,error-fun 'defmacro-ll-arg-count-error
-			 :kind ',error-kind
-			 ,@(when name `(:name ',name))
-			 :argument ,(if top-level
-					`(cdr ,arg-list-name)
-					arg-list-name)
-			 :lambda-list ',lambda-list
-			 :minimum ,minimum
-			 ,@(unless restp `(:maximum ,maximum))))
-	  *arg-tests*)
-    (if keys
-	(let ((problem (gensym "KEY-PROBLEM-"))
-	      (info (gensym "INFO-")))
-	  (push `(multiple-value-bind
-		     (,problem ,info)
-		     (verify-keywords ,rest-name ',keys ',allow-other-keys-p)
-		   (when ,problem
-		     (,error-fun
-		      'defmacro-ll-broken-key-list-error
-		      :kind ',error-kind
-		      ,@(when name `(:name ',name))
-		      :problem ,problem
-		      :info ,info)))
-		*arg-tests*)))
-    (values env-arg-used minimum (if (null restp) maximum nil))))
-
-(defun push-sub-list-binding (variable path object name error-kind error-fun)
-  (let ((var (gensym "TEMP-")))
-    (push `(,variable
-	    (let ((,var ,path))
-	      (if (listp ,var)
-		  ,var
-		  (,error-fun 'defmacro-bogus-sublist-error
-			      :kind ',error-kind
-			      ,@(when name `(:name ',name))
-			      :object ,var
-			      :lambda-list ',object))))
-	  *system-lets*)))
-
-(defun push-let-binding (variable path systemp &optional condition
-				  (init-form *default-default*))
-  (let ((let-form (if condition
-		      `(,variable (if ,condition ,path ,init-form))
-		      `(,variable ,path))))
-    (if systemp
-	(push let-form *system-lets*)
-	(push let-form *user-lets*))))
-
-(defun push-optional-binding (value-var init-form supplied-var condition path
-					name error-kind error-fun)
-  (unless supplied-var
-    (setf supplied-var (gensym "SUPLIEDP-")))
-  (push-let-binding supplied-var condition t)
-  (cond ((consp value-var)
-	 (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
-	   (push-sub-list-binding whole-thing
-				  `(if ,supplied-var ,path ,init-form)
-				  value-var name error-kind error-fun)
-	   (parse-defmacro-lambda-list value-var whole-thing name
-				       error-kind error-fun)))
-	((symbolp value-var)
-	 (push-let-binding value-var path nil supplied-var init-form))
-	(t
-	 (error "Illegal optional variable name: ~S" value-var))))
-
-(defun make-keyword (symbol)
-  "Takes a non-keyword symbol, symbol, and returns the corresponding keyword."
-  (intern (symbol-name symbol) *keyword-package*))
-
-(defun defmacro-error (problem kind name)
-  (error "Illegal or ill-formed ~A argument in ~A~@[ ~S~]."
-	 problem kind name))
-
-
-
-;;;; Routines used at runtime by the resultant body.
-
-;;; VERIFY-KEYWORDS -- internal
-;;;
-;;; Determine if key-list is a valid list of keyword/value pairs.  Do not
-;;; signal the error directly, 'cause we don't know how it should be signaled.
-;;; 
-(defun verify-keywords (key-list valid-keys allow-other-keys)
-  (do ((already-processed nil)
-       (unknown-keyword nil)
-       (remaining key-list (cddr remaining)))
-      ((null remaining)
-       (if (and unknown-keyword
-		(not allow-other-keys)
-		(not (lookup-keyword :allow-other-keys key-list)))
-	   (values :unknown-keyword (list unknown-keyword valid-keys))
-	   (values nil nil)))
-    (cond ((not (and (consp remaining) (listp (cdr remaining))))
-	   (return (values :dotted-list key-list)))
-	  ((null (cdr remaining))
-	   (return (values :odd-length key-list)))
-	  ((member (car remaining) already-processed)
-	   (return (values :duplicate (car remaining))))
-	  ((or (eq (car remaining) :allow-other-keys)
-	       (member (car remaining) valid-keys))
-	   (push (car remaining) already-processed))
-	  (t
-	   (setf unknown-keyword (car remaining))))))
-
-(defun lookup-keyword (keyword key-list)
-  (do ((remaining key-list (cddr remaining)))
-      ((endp remaining))
-    (when (eq keyword (car remaining))
-      (return (cadr remaining)))))
-
-(defun keyword-supplied-p (keyword key-list)
-  (do ((remaining key-list (cddr remaining)))
-      ((endp remaining))
-    (when (eq keyword (car remaining))
-      (return t))))
-
-
-
-;;;; Conditions signaled at runtime by the resultant body.
-
-(define-condition defmacro-lambda-list-bind-error (error) (kind name))
-
-(defun print-defmacro-ll-bind-error-intro (condition stream)
-  (if (null (defmacro-lambda-list-bind-error-name condition))
-      (format stream
-	      "Error while parsing arguments to ~A in ~S:~%"
-	      (defmacro-lambda-list-bind-error-kind condition)
-	      (defmacro-lambda-list-bind-error-function-name condition))
-      (format stream
-	      "Error while parsing arguments to ~A ~S:~%"
-	      (defmacro-lambda-list-bind-error-kind condition)
-	      (defmacro-lambda-list-bind-error-name condition))))
-
-(define-condition defmacro-bogus-sublist-error
-		  (defmacro-lambda-list-bind-error)
-  (object lambda-list)
-  (:report
-   (lambda (condition stream)
-     (print-defmacro-ll-bind-error-intro condition stream)
-     (format stream
-	     "Bogus sublist:~%  ~S~%to satisfy lambda-list:~%  ~:S~%"
-	     (defmacro-bogus-sublist-error-object condition)
-	     (defmacro-bogus-sublist-error-lambda-list condition)))))
-
-(define-condition defmacro-ll-arg-count-error (defmacro-lambda-list-bind-error)
-  (argument lambda-list minimum maximum)
-  (:report
-   (lambda (condition stream)
-     (print-defmacro-ll-bind-error-intro condition stream)
-     (format stream
-	     "Invalid number of elements in:~%  ~:S~%~
-	     to satisfy lambda-list:~%  ~:S~%"
-	     (defmacro-ll-arg-count-error-argument condition)
-	     (defmacro-ll-arg-count-error-lambda-list condition))
-     (cond ((null (defmacro-ll-arg-count-error-maximum condition))
-	    (format stream "Expected at least ~D"
-		    (defmacro-ll-arg-count-error-minimum condition)))
-	   ((= (defmacro-ll-arg-count-error-minimum condition)
-	       (defmacro-ll-arg-count-error-maximum condition))
-	    (format stream "Expected exactly ~D"
-		    (defmacro-ll-arg-count-error-minimum condition)))
-	   (t
-	    (format stream "Expected between ~D and ~D"
-		    (defmacro-ll-arg-count-error-minimum condition)
-		    (defmacro-ll-arg-count-error-maximum condition))))
-     (format stream ", but got ~D."
-	     (length (defmacro-ll-arg-count-error-argument condition))))))
-
-
-(define-condition defmacro-ll-broken-key-list-error
-		  (defmacro-lambda-list-bind-error)
-  (problem info)
-  (:report (lambda (condition stream)
-	     (print-defmacro-ll-bind-error-intro condition stream)
-	     (format stream
-		     (ecase
-			 (defmacro-ll-broken-key-list-error-problem condition)
-		       (:dotted-list
-			"Keyword/value list is dotted: ~S")
-		       (:odd-length
-			"Odd number of elements in keyword/value list: ~S")
-		       (:duplicate
-			"Duplicate keyword: ~S")
-		       (:unknown-keyword
-			"~{Unknown keyword: ~S; expected one of ~{~S~^, ~}~}"))
-		     (defmacro-ll-broken-key-list-error-info condition)))))
diff --git a/code/dyncount.lisp b/code/dyncount.lisp
deleted file mode 100644
index b86430183f26385cb5ca01d0493c6b57af628f97..0000000000000000000000000000000000000000
--- a/code/dyncount.lisp
+++ /dev/null
@@ -1,674 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/dyncount.lisp,v 1.4 1992/12/31 13:36:44 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Runtime support for dynamic VOP statistics collection.
-;;; 
-(in-package "C")
-
-#|
-Put *count-adjustments* back into VOP costs, and verify them.
-Make sure multi-cycle instruction costs are plausible.
-VOP classification.
-  Make tables of %cost for benchmark X class.
-  Could be represented as a sort of bar chart.
-|#
-
-(eval-when (compile)
-  (when *collect-dynamic-statistics*
-    (error "Compiling this file with dynamic stat collection turn on would ~
-    be a very bad idea.")))
-
-;;;; Hash utilities:
-
-(defun make-hash-table-like (table)
-  "Make a hash-table with the same test as table."
-  (declare (type hash-table table))
-  (make-hash-table :test (lisp::hash-table-kind table)))
-
-(defun hash-difference (table1 table2)
-  "Return a hash-table containing only the entries in Table1 whose key is not
-   also a key in Table2." (declare (type hash-table table1 table2))
-  (let ((res (make-hash-table-like table1)))
-    (do-hash (k v table1)
-      (unless (nth-value 1 (gethash k table2))
-	(setf (gethash k res) v)))
-    res))
-
-(defun hash-list (table)
-  "Return a list of the values in Table."
-  (declare (type hash-table table))
-  (collect ((res))
-    (do-hash (k v table)
-      (declare (ignore k))
-      (res v))
-    (res)))
-
-;;; READ-HASH-TABLE, WRITE-HASH-TABLE  --  Public
-;;;
-;;;    Read (or write) a hashtable from (or to) a file.
-;;;
-(defun read-hash-table (file)
-  (with-open-file (s file :direction :input)
-    (dotimes (i 3)
-      (format t "~%; ~A" (read-line s)))
-    (let* ((eof '(nil))
-	   (test (read s))
-	   (reader (read s))
-	   (res (make-hash-table :test test)))
-      (read s); Discard writer...
-      (loop
-	(let ((key (read s nil eof)))
-	  (when (eq key eof) (return))
-	  (setf (gethash key res)
-		(funcall reader s key))))
-      res)))
-;;;
-(defun write-hash-table (table file &key
-			       (comment (format nil "Contents of ~S" table))
-			       (reader 'read) (writer 'prin1) (test 'equal))
-  (with-open-file (s file :direction :output :if-exists :new-version)
-    (with-standard-io-syntax
-      (let ((*print-readably* nil))
-	(format s "~A~%Version ~A on ~A~%"
-		comment (lisp-implementation-version)
-		(machine-instance))
-	(format-universal-time s (get-universal-time))
-	(terpri s)
-	(format s "~S ~S ~S~%" test reader writer)
-	(do-hash (k v table)
-	  (prin1 k s)
-	  (write-char #\space s)
-	  (funcall writer v s)
-	  (terpri s)))))
-  table)
-
-
-;;;; Info accumulation:
-
-;;; Used to accumulate info about the usage of a single VOP.  Cost and count
-;;; are kept as double-floats, which lets us get more bits and avoid annoying
-;;; overflows.
-;;;
-(deftype count-vector () '(simple-array double-float (2)))
-;;;
-(defstruct (vop-stats
-	    (:constructor %make-vop-stats (name))
-	    (:constructor make-vop-stats-key))
-  (name (required-argument) :type simple-string)
-  (data (make-array 2 :element-type 'double-float) :type count-vector))
-
-(defmacro vop-stats-count (x) `(aref (vop-stats-data ,x) 0))
-(defmacro vop-stats-cost (x) `(aref (vop-stats-data ,x) 1))
-
-(defun make-vop-stats (&key name count cost)
-  (let ((res (%make-vop-stats name)))
-    (setf (vop-stats-count res) count)
-    (setf (vop-stats-cost res) cost)
-    res))
-    
-(declaim (freeze-type dyncount-info vop-stats))
-
-
-;;; NOTE-DYNCOUNT-INFO  --  Internal
-;;;
-;;;    Add the Info into the cumulative result on the VOP name plist.  We use
-;;; plists so that we will touch minimal system code outside of this file
-;;; (which may be compiled with profiling on.)
-;;;
-(defun note-dyncount-info (info)
-  (declare (type dyncount-info info) (inline get %put)
-	   (optimize (speed 2)))
-  (let ((counts (dyncount-info-counts info))
-	(vops (dyncount-info-vops info)))
-    (dotimes (index (length counts))
-      (declare (type index index))
-      (let ((count (coerce (the (unsigned-byte 31)
-				(aref counts index))
-			   'double-float)))
-	(when (minusp count)
-	  (warn "Oops: overflow.")
-	  (return-from note-dyncount-info nil))
-	(unless (zerop count)
-	  (let* ((vop-info (svref vops index))
-		 (length (length vop-info)))
-	    (declare (simple-vector vop-info))
-	    (do ((i 0 (+ i 4)))
-		((>= i length))
-	      (declare (type index i))
-	      (let* ((name (svref vop-info i))
-		     (entry (or (get name 'vop-stats)
-				(setf (get name 'vop-stats)
-				      (%make-vop-stats (symbol-name name))))))
-		(incf (vop-stats-count entry)
-		      (* (coerce (the index (svref vop-info (1+ i)))
-				 'double-float)
-			 count))
-		(incf (vop-stats-cost entry)
-		      (* (coerce (the index (svref vop-info (+ i 2)))
-				 'double-float)
-			 count))))))))))
-
-(defun clear-dyncount-info (info)
-  (declare (type dyncount-info info))
-  (declare (optimize (speed 3) (safety 0)))
-  (let ((counts (dyncount-info-counts info)))
-    (dotimes (i (length counts))
-      (setf (aref counts i) 0))))
-
-
-;;; CLEAR-VOP-COUNTS  --  Public
-;;;
-;;;    Clear any VOP-COUNTS properties and the counts vectors for all code
-;;; objects.  The latter loop must not call any random functions.
-;;;
-(defun clear-vop-counts (&optional (spaces '(:dynamic)))
-  "Clear all dynamic VOP counts for code objects in the specified spaces."
-  (do-hash (k v (backend-template-names *backend*))
-    (declare (ignore v))
-    (remprop k 'vop-stats))
-  
-  (locally
-      (declare (optimize (speed 3) (safety 0))
-	       (inline vm::map-allocated-objects))
-    (without-gcing
-      (dolist (space spaces)
-	(vm::map-allocated-objects
-	 #'(lambda (object type-code size)
-	     (declare (ignore type-code size))
-	     (when (dyncount-info-p object)
-	       (clear-dyncount-info object)))
-	 space)))))
-
-
-;;; GET-VOP-COUNTS  --  Public
-;;;
-;;;    Call NOTE-DYNCOUNT-INFO on all DYNCOUNT-INFO structure allocated in the
-;;; specified spaces.  Return a hashtable describing the counts.  The initial
-;;; loop must avoid calling any functions outside this file to prevent adding
-;;; noise to the data, since other files may be compiled with profiling.
-;;;
-(defun get-vop-counts (&optional (spaces '(:dynamic)) &key (clear nil))
-  "Return a hash-table mapping string VOP names to VOP-STATS structures
-   describing the VOPs executed.  If clear is true, then reset all counts to
-   zero as a side-effect."
-  (locally
-      (declare (optimize (speed 3) (safety 0))
-	       (inline vm::map-allocated-objects))
-    (without-gcing
-      (dolist (space spaces)
-	(vm::map-allocated-objects
-	 #'(lambda (object type-code size)
-	     (declare (ignore type-code size))
-	     (when (dyncount-info-p object)
-	       (note-dyncount-info object)
-	       (when clear
-		 (clear-dyncount-info object))))
-	 space))))
-  
-  (let ((counts (make-hash-table :test #'equal)))
-    (do-hash (k v (backend-template-names *backend*))
-      (declare (ignore v))
-      (let ((stats (get k 'vop-stats)))
-	(when stats
-	  (setf (gethash (symbol-name k) counts) stats)
-	  (when clear
-	    (remprop k 'vop-stats)))))
-    counts))
-
-
-;;; FIND-INFO-FOR  --  Interface
-;;;
-;;;    Return the DYNCOUNT-INFO for FUNCTION.
-;;;
-(defun find-info-for (function)
-  (declare (type function function))
-  (let* ((function (%primitive closure-function function))
-	 (component (di::function-code-header function)))
-    (do ((end (get-header-data component))
-	 (i vm:code-constants-offset (1+ i)))
-	((= end i))
-      (let ((constant (code-header-ref component i)))
-	(when (dyncount-info-p constant)
-	  (return constant))))))
-
-
-(defun vop-counts-apply (function args &key (spaces '(:dynamic)) by-space)
-  "Apply Function to Args, collecting dynamic statistics on the running.
-   Spaces are the spaces to scan for counts.  If By-Space is true, we return a
-   list of result tables, instead of a single table.  In this case, specify
-   :READ-ONLY first."
-  (clear-vop-counts spaces)
-  (apply function args)
-  (if by-space
-      (mapcar #'(lambda (space)
-		  (get-vop-counts (list space) :clear t))
-	      spaces)
-      (get-vop-counts spaces)))
-
-;;;; Adjustments:
-
-#|
-(defparameter *count-adjustments*
-  '((return-multiple 152)
-    (tail-call-variable 88)
-    (unwind 92)
-    (throw 116)
-    (allocate-vector 72)
-    (sxhash-simple-string 248)
-    (sxhash-simple-substring 264)
-    (copy-to-system-area 1200)
-    (copy-from-system-area 1200)
-    (system-area-copy 1204)
-    (bit-bash-copy 1412)
-    (vm::generic-+ 72)
-    (vm::generic-- 72)
-    (vm::generic-* 184)
-    (vm::generic-< 68)
-    (vm::generic-> 68)
-    (vm::generic-eql 80)
-    (vm::generic-= 80)
-    (vm::generic-/= 104)
-    (%make-weak-pointer 60)
-    (make-value-cell 56)
-    (vm::make-funcallable-instance 76)
-    (make-closure 76)
-    (make-complex 60)
-    (make-ratio 60)
-    (%allocate-bignum 72)
-    (make-structure 72)
-    (cons 50)))
-|#
-
-;;; GET-VOP-COSTS  --  Public
-;;;
-(defun get-vop-costs ()
-  "Return a hash-table mapping string VOP names to the cost recorded in the
-   generator for all VOPs which are also the names of assembly routines."
-  (let ((res (make-hash-table :test #'equal)))
-     (do-hash (name v lisp::*assembler-routines*)
-       (declare (ignore v))
-       (let ((vop (gethash name (backend-template-names *backend*))))
-	 (when vop
-	   (setf (gethash (symbol-name name) res)
-		 (template-cost (template-or-lose name))))))
-    res))
-
-(defvar *native-costs* (get-vop-costs)
-  "Costs of assember routines on this machine.")
-
-
-;;;; Classification:
-
-(defparameter *basic-classes*
-  '(("Integer multiplication"
-     "*/FIXNUM" "*/SIGNED" "*/UNSIGNED" "SIGNED-*" "FIXNUM-*" "GENERIC-*")
-    ("Integer division" "TRUNCATE")
-    ("Generic arithmetic" "GENERIC" "TWO-ARG")
-    ("Inline EQL" "EQL")
-    ("Inline compare less/greater" "</" ">/" "<-C/" ">-C/")
-    ("Inline arith" "*/" "//" "+/" "-/" "NEGATE" "ABS" "+-C" "--C")
-    ("Inline logic" "-ASH" "$ASH" "LOG")
-    ("CAR/CDR" "CAR" "CDR")
-    ("Array type test" "ARRAYP" "VECTORP" "ARRAY-HEADER-P")
-    ("Simple type predicate" "STRUCTUREP" "LISTP" "FIXNUMP")
-    ("Simple type check" "CHECK-LIST" "CHECK-FIXNUM" "CHECK-STRUCTURE")
-    ("Array bounds check" "CHECK-BOUND")
-    ("Complex type check" "$CHECK-" "COERCE-TO-FUNCTION")
-    ("Special read" "SYMBOL-VALUE")
-    ("Special bind" "BIND$")
-    ("Tagging" "MOVE-FROM")
-    ("Untagging" "MOVE-TO" "MAKE-FIXNUM")
-    ("Move" "MOVE")
-    ("Non-local exit" "CATCH" "THROW" "DYNAMIC-STATE" "NLX" "UNWIND")
-    ("Array write" "DATA-VECTOR-SET" "$SET-RAW-BITS$")
-    ("Array read" "DATA-VECTOR-REF" "$RAW-BITS$" "VECTOR-LENGTH"
-     "LENGTH/SIMPLE" "ARRAY-HEADER")
-    ("List/string utility" "LENGTH/LIST" "SXHASH" "BIT-BASH" "$LENGTH$")
-    ("Alien operations" "SAP" "ALLOC-NUMBER-STACK" "$CALL-OUT$")
-    ("Function call/return" "CALL" "RETURN" "ALLOCATE-FRAME"
-     "COPY-MORE-ARG" "LISTIFY-REST-ARG" "VERIFY-ARGUMENT-COUNT")
-    ("Allocation" "MAKE-" "ALLOC" "$CONS$" "$LIST$" "$LIST*$")
-    ("Float conversion" "%SINGLE-FLOAT" "%DOUBLE-FLOAT" "-BITS$")
-    ("Complex type predicate" "P$")))
-
-
-;;; MATCHES-PATTERN  --  Internal
-;;;
-;;;    Return true if Name patches a specified pattern.  Pattern is a string
-;;; (or symbol) or a list of strings (or symbols).  If any specified string
-;;; appears as a substring of name, the pattern is matched.  #\$'s are wapped
-;;; around name, allowing the use of $ to force a match at the beginning or
-;;; end.
-;;;
-(defun matches-pattern (name pattern)
-  (declare (simple-string name))
-  (let ((name (concatenate 'string "$" name "$")))
-    (dolist (pat (if (listp pattern) pattern (list pattern)) nil)
-      (when (search (the simple-string (string pat))
-		    name :test #'char=)
-	(return t)))))
-
-
-;;; FIND-MATCHES, WHAT-CLASS  --  Interface
-;;;
-;;;    Utilities for debugging classification rules.  FIND-MATCHES returns a
-;;; list of all the VOP names in Table that match Pattern.   WHAT-CLASS returns
-;;; the class that NAME would be placed in.
-;;;
-(defun find-matches (table pattern)
-  (collect ((res))
-    (do-hash (key value table)
-      (declare (ignore value))
-      (when (matches-pattern key pattern) (res key)))
-    (res)))
-;;;
-(defun what-class (name classes)
-  (dolist (class classes nil)
-    (when (matches-pattern name (rest class)) (return (first class)))))
-
-    
-;;; CLASSIFY-COSTS  --  Interface
-;;;
-;;;    Given a VOP-STATS hash-table, return a new one with VOPs in the same
-;;; class merged into a single entry for that class.  The classes are
-;;; represented as a list of lists: (class-name pattern*).  Each pattern is a
-;;; string (or symbol) that can appear as a subsequence of the VOP name.  A VOP
-;;; is placed in the first class that it matches, or is left alone if it
-;;; matches no class.
-;;;
-(defun classify-costs (table classes)
-  (let ((res (make-hash-table-like table)))
-    (do-hash (key value table)
-      (let ((class (dolist (class classes nil)
-		     (when (matches-pattern key (rest class))
-		       (return (first class))))))
-	(if class
-	    (let ((found (or (gethash class res)
-			     (setf (gethash class res)
-				   (%make-vop-stats class)))))
-	      (incf (vop-stats-count found) (vop-stats-count value))
-	      (incf (vop-stats-cost found) (vop-stats-cost value)))
-	    (setf (gethash key res) value))))
-    res))
-
-
-;;;; Analysis:
-
-;;; COST-SUMMARY  --  Internal
-;;;
-;;;    Sum the count and costs.
-;;;
-(defun cost-summary (table)
-  (let ((total-count 0d0)
-	(total-cost 0d0))
-    (do-hash (k v table)
-      (declare (ignore k))
-      (incf total-count (vop-stats-count v))
-      (incf total-cost (vop-stats-cost v)))
-    (values total-count total-cost)))
-
-  
-;;; COMPENSATE-COSTS  --  Internal
-;;;
-;;;    Return a hashtable of DYNCOUNT-INFO structures, with cost adjustments
-;;; according to the Costs table.  Any VOPs in the list IGNORE are ignored.
-;;;
-(defun compensate-costs (table costs &optional ignore)
-  (let ((res (make-hash-table-like table)))
-    (do-hash (key value table)
-      (unless (or (string= key "COUNT-ME")
-		  (member key ignore :test #'string=))
-	(let ((cost (gethash key costs)))
-	  (if cost
-	      (let* ((count (vop-stats-count value))
-		     (sum (+ (* cost count)
-			     (vop-stats-cost value))))
-		(setf (gethash key res)
-		      (make-vop-stats :name key :count count :cost sum)))
-	      (setf (gethash key res) value)))))
-    res))
-
-
-;;; COMPARE-STATS  --  Internal
-;;;
-;;;    Take two tables of vop-stats and return a table of entries where the
-;;; entries have been compared.  The counts are normalized to Compared.  The
-;;; costs are the difference of the costs adjusted by the difference in counts:
-;;; the cost for Original is modified to correspond to the count in Compared.
-;;;
-(defun compare-stats (original compared)
-  (declare (type hash-table original compared))
-  (let ((res (make-hash-table-like original)))
-    (do-hash (k cv compared)
-      (let ((ov (gethash k original)))
-	(when ov
-	  (let ((norm-cnt (/ (vop-stats-count ov) (vop-stats-count cv))))
-	    (setf (gethash k res)
-		  (make-vop-stats
-		   :name k
-		   :count norm-cnt
-		   :cost (- (/ (vop-stats-cost ov) norm-cnt)
-			    (vop-stats-cost cv))))))))
-    res))
-
-
-;;; COMBINE-STATS  --  Public
-;;;
-(defun combine-stats (&rest tables)
-  "Sum the VOP stats for the specified tables, returning a new table with the
-   combined results."
-  (let ((res (make-hash-table-like (first tables))))
-    (dolist (table tables)
-      (do-hash (k v table)
-	(let ((found (or (gethash k res)
-			 (setf (gethash k res) (%make-vop-stats k)))))
-	  (incf (vop-stats-count found) (vop-stats-count v))
-	  (incf (vop-stats-cost found) (vop-stats-cost v)))))
-    res))
-
-
-;;;; Report generation:
-
-;;; SORT-RESULT  --  Internal
-;;;
-(defun sort-result (table by)
-  (sort (hash-list table) #'>
-	:key #'(lambda (x)
-		 (abs (ecase by
-			(:count (vop-stats-count x))
-			(:cost (vop-stats-cost x)))))))
-
-
-;;; ENTRY-REPORT  --  Internal
-;;;
-;;;    Report about VOPs in the list of stats structures.
-;;;
-(defun entry-report (entries cut-off compensated compare total-cost)
-  (let ((counter (if (and cut-off (> (length entries) cut-off))
-		     cut-off
-		     most-positive-fixnum)))
-  (dolist (entry entries)
-    (let* ((cost (vop-stats-cost entry))
-	   (name (vop-stats-name entry))
-	   (entry-count (vop-stats-count entry))
-	   (comp-entry (if compare (gethash name compare) entry))
-	   (count (vop-stats-count comp-entry)))
-      (format t "~30<~A~>: ~:[~13:D~;~13,2F~] ~9,2F  ~5,2,2F%~%"
-	      (vop-stats-name entry)
-	      compare
-	      (if compare entry-count (round entry-count))
-	      (/ cost count)
-	      (/ (if compare
-		     (- (vop-stats-cost (gethash name compensated))
-			(vop-stats-cost comp-entry))
-		     cost)
-		 total-cost))
-      (when (zerop (decf counter))
-	(format t "[End of top ~D]~%" cut-off))))))
-
-;;; FIND-CUT-OFF  --  Internal
-;;;
-;;;    Divide Sorted into two lists, the first cut-off elements long.  Any VOP
-;;; names that match one of the report strings are moved into the report list
-;;; even if they would otherwise fall below the cut-off.
-;;;
-(defun find-cut-off (sorted cut-off report)
-  (if (or (not cut-off) (<= (length sorted) cut-off))
-      (values sorted ())
-      (let ((not-cut (subseq sorted 0 cut-off)))
-	(collect ((select)
-		  (reject))
-	  (dolist (el (nthcdr cut-off sorted))
-	    (let ((name (vop-stats-name el)))
-	      (if (matches-pattern name report)
-		  (select el)
-		  (reject el))))
-	  (values (append not-cut (select)) (reject))))))
-		  
-
-;;; CUT-OFF-REPORT  --  Internal
-;;;
-;;;    Display information about entries that were not displayed due to the
-;;; cut-off.  Note: if compare, we find the total cost delta and the geometric
-;; mean of the normalized counts.
-;;
-(defun cut-off-report (other compare total-cost)
-  (let ((rest-cost 0d0)
-	(rest-count 0d0)
-	(rest-entry-count (if compare 1d0 0d0)))
-    (dolist (entry other)
-      (incf rest-cost (vop-stats-cost entry))
-      (incf rest-count
-	    (vop-stats-count
-	     (if compare
-		 (gethash (vop-stats-name entry) compare)
-		 entry)))
-      (if compare
-	  (setq rest-entry-count
-		(* rest-entry-count (vop-stats-count entry)))
-	  (incf rest-entry-count (vop-stats-count entry))))
-    
-    (let ((count (if compare
-		     (expt rest-entry-count
-			   (/ (coerce (length other) 'double-float)))
-		     (round rest-entry-count))))
-      (format t "~30<Other~>: ~:[~13:D~;~13,2F~] ~9,2F  ~@[~5,2,2F%~]~%"
-	      compare count
-	      (/ rest-cost rest-count)
-	      (unless compare
-		(/ rest-cost total-cost))))))
-
-
-;;; COMPARE-REPORT  --  Internal
-;;;
-;;;    Report summary information about the difference between the comparison
-;;; and base data sets.
-;;;
-(defun compare-report (total-count total-cost compare-total-count
-				   compare-total-cost compensated compare)
-  (format t "~30<Relative total~>: ~13,2F ~9,2F~%"
-	  (/ total-count compare-total-count)
-	  (/ total-cost compare-total-cost))
-  (flet ((frob (a b sign wot)
-	   (multiple-value-bind
-	       (cost count) (cost-summary (hash-difference a b))
-	     (unless (zerop count)
-	       (format t "~30<~A~>: ~13:D ~9,2F  ~5,2,2F%~%"
-		       wot (* sign (round count))
-		       (* sign (/ cost count))
-		       (* sign (/ cost compare-total-cost)))))))
-    (frob compensated compare 1 "Not in comparison")
-    (frob compare compensated -1 "Only in comparison"))
-  (format t "~30<Comparison total~>: ~13,2E ~9,2E~%"
-	  compare-total-count compare-total-cost))
-
-
-;;; The fraction of system time that we guess happened during GC.
-;;;
-(defparameter *gc-system-fraction* 2/3)
-
-;;; FIND-CPI  --  Interface
-;;;
-;;;    Estimate CPI from CPU time and cycles accounted in profiling
-;;; information.
-;;;
-(defun find-cpi (total-cost user system gc clock)
-  (let ((adj-time (if (zerop gc)
-		      user
-		      (- user (- gc (* system *gc-system-fraction*))))))
-    (/ (* adj-time clock) total-cost)))
-
-  
-;;; GENERATE-REPORT  --  Public
-;;;
-;;; Generate a report from the specified table.
-;;;
-(defun generate-report (table &key (cut-off 15) (sort-by :cost)
-			      (costs *native-costs*)
-			      ((:compare uncomp-compare))
-			      (compare-costs costs)
-			      ignore report
-			      (classes *basic-classes*)
-			      user (system 0d0) (gc 0d0)
-			      (clock 25d6))
-  (let* ((compensated
-	  (classify-costs
-	   (if costs
-	       (compensate-costs table costs ignore)
-	       table)
-	   classes))
-	 (compare
-	  (when uncomp-compare
-	    (classify-costs
-	     (if compare-costs
-		 (compensate-costs uncomp-compare compare-costs ignore)
-		 uncomp-compare)
-	     classes)))
-	 (compared (if compare
-		       (compare-stats compensated compare)
-		       compensated))
-	 (*gc-verbose* nil))
-    (multiple-value-bind (total-count total-cost)
-			 (cost-summary compensated)
-      (multiple-value-bind (compare-total-count compare-total-cost)
-			   (when compare (cost-summary compare))
-	(format t "~2&~30<Vop~>  ~13<Count~> ~9<Cost~>  ~6:@<Percent~>~%")
-	(let ((sorted (sort-result compared sort-by))
-	      (base-total (if compare compare-total-cost total-cost)))
-	  (multiple-value-bind
-	      (report other)
-	      (find-cut-off sorted cut-off report)
-	    (entry-report report cut-off compensated compare base-total)
-	    (when other
-	      (cut-off-report other compare base-total))))
-
-	(when compare
-	  (compare-report total-count total-cost compare-total-count
-			  compare-total-cost compensated compare))
-
-	(format t "~30<Total~>: ~13,2E ~9,2E~%" total-count total-cost)
-	(when user
-	  (format t "~%Cycles per instruction = ~,2F~%"
-		  (find-cpi total-cost user system gc clock))))))
-  (values))
-
-
-;;; STATS-{READER,WRITER}  --  Public
-;;;
-;;;    Read & write VOP stats using hash IO utility.
-;;;
-(defun stats-reader (stream key)
-  (make-vop-stats :name key :count (read stream) :cost (read stream)))
-;;;
-(defun stats-writer (object stream)
-  (format stream "~S ~S" (vop-stats-count object) (vop-stats-cost object)))
diff --git a/code/eval.lisp b/code/eval.lisp
deleted file mode 100644
index 18838b1480f0896f40725917b7e3f530a22f63fc..0000000000000000000000000000000000000000
--- a/code/eval.lisp
+++ /dev/null
@@ -1,450 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.21 1992/12/17 09:08:00 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-(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
-	  compiler-macroexpand compiler-macroexpand-1
-	  compiler-macro-function
-	  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 "EXTENSIONS")
-(export '(*top-level-auto-declare*))
-
-(in-package "KERNEL")
-(export '(invoke-macroexpand-hook))
-
-(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)
-
-(declaim (type (member :warn t nil) *top-level-auto-declare*))
-
-(defvar *top-level-auto-declare* :warn
-  "This variable controls whether assignments to unknown variables at top-level
-   (or in any other call to EVAL of SETQ) will implicitly declare the variable
-   SPECIAL.  These values are meaningful:
-     :WARN  -- Print a warning, but declare the variable special (the default.)
-      T     -- Quietly declare the variable special.
-      NIL   -- Never declare the variable, giving warnings on each use.")
-  
-
-;;; 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 (original-exp)
-  "Evaluates its single arg in a null lexical environment, returns the
-  result or results."
-  (declare (optimize (safety 1)))
-  (let ((exp (macroexpand original-exp)))
-    (typecase exp
-      (symbol
-       (ecase (info variable kind exp)
-	 (:constant
-	  (values (info variable constant-value exp)))
-	 ((:special :global)
-	  (symbol-value exp))
-	 (:alien
-	  (eval:internal-eval original-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))
-			;; We duplicate the call to SET so that the correct
-			;; value gets returned.
-			(set (first args) (eval (second args))))
-		     (set (first args) (eval (second args)))))
-		(let ((symbol (first name)))
-		  (case (info variable kind symbol)
-		    (:special)
-		    (:global
-		     (case *top-level-auto-declare*
-		       (:warn
-			(warn "Declaring ~S special." symbol))
-		       ((t))
-		       ((nil)
-			(return (eval:internal-eval original-exp))))
-		     (proclaim `(special ,symbol)))
-		    (t
-		     (return (eval:internal-eval original-exp))))))))
-	   ((progn)
-	    (when (> args 0)
-	      (dolist (x (butlast (rest exp)) (eval (car (last exp))))
-		(eval x))))
-	   ((eval-when)
-	    (if (and (> args 0) (member 'eval (second exp)))
-		(when (> args 1)
-		  (dolist (x (butlast (cddr exp)) (eval (car (last exp))))
-		    (eval x)))
-		(eval:internal-eval original-exp)))
-	   (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 original-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)
-       (= (get-type x) vm:closure-header-type)
-       (fboundp 'eval::leaf-value)
-       (let ((code-component (di::function-code-header (%closure-function x))))
-	 (or (eq (di::function-code-header #'eval::leaf-value)
-		 code-component)
-	     (eq (di::function-code-header #'eval:make-interpreted-function)
-		 code-component)))))
-
-
-;;; 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)
-      (let* ((fun (%function-self fun))
-	     (name (%function-name fun))
-	     (code (di::function-code-header fun))
-	     (info (kernel:%code-debug-info code)))
-	(if info
-	    (let ((source (first (c::compiled-debug-info-source info))))
-	      (cond ((and (eq (c::debug-source-from source) :lisp)
-			  (eq (c::debug-source-info source) fun))
-		     (values (second (svref (c::debug-source-name source) 0))
-			     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)
-  (dotimes (index (1- (get-closure-length fun)))
-    (let ((elt (%closure-index-ref fun index)))
-      (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.")
-
-;;; INVOKE-MACROEXPAND-HOOK -- public.
-;;;
-;;; The X3J13 cleanup FUNCTION-TYPE:X3J13-MARCH-88 specifies that:
-;;; 
-;;; "7. Clarify that the value of *MACROEXPAND-HOOK* is first coerced to a
-;;;     function before being called as the expansion interface hook by
-;;;     MACROEXPAND-1."
-;;;
-;;; This is a handy utility function that does just such a coercion.  It also
-;;; stores the result back in *macroexpand-hook* so we don't have to coerce
-;;; it again.
-;;; 
-(defun invoke-macroexpand-hook (fun form env)
-  "Invoke *MACROEXPAND-HOOK* on FUN, FORM, and ENV after coercing it to
-   a function."
-  (unless (functionp *macroexpand-hook*)
-    (setf *macroexpand-hook*
-	  (coerce *macroexpand-hook* 'function)))
-  (funcall *macroexpand-hook* fun form env))
-
-(defun macro-function (symbol &optional env)
-  "If SYMBOL names a macro in ENV, returns the expansion function,
-   else returns NIL.  If ENV is unspecified or NIL, use the global
-   environment only."
-  (declare (symbol symbol))
-  (let* ((fenv (when env (c::lexenv-functions env)))
-	 (local-def (cdr (assoc symbol fenv))))
-    (cond (local-def
-	   (if (and (consp local-def) (eq (car local-def) 'MACRO))
-	       (cdr local-def)
-	       nil))
-	  ((eq (info function kind symbol) :macro)
-	   (values (info function macro-function symbol)))
-	  (t
-	   nil))))
-
-(defun (setf macro-function) (function symbol)
-  (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)
-  (setf (symbol-function symbol)
-	#'(lambda (&rest args) (declare (ignore args))
-	    (error "Cannot funcall macro functions.")))
-  function)
-
-;;; Macroexpand-1  --  Public
-;;;
-;;;    The Env is a LEXENV or NIL (the null environment.)
-;;;
-(defun macroexpand-1 (form &optional env)
-  "If form is a macro (or symbol 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."
-  (cond ((and (consp form) (symbolp (car form)))
-	 (let ((def (macro-function (car form) env)))
-	   (if def
-	       (values (invoke-macroexpand-hook def form env) t)
-	       (values form nil))))
-	((symbolp form)
-	 (let* ((venv (when env (c::lexenv-variables env)))
-		(local-def (cdr (assoc form venv))))
-	   (if (and (consp local-def)
-		    (eq (car local-def) 'macro))
-	       (values (cdr local-def) t)
-	       (values form nil))))
-	(t
-	 (values form nil))))
-
-(defun macroexpand (form &optional env)
-  "Repetitively call MACROEXPAND-1 until the form can no longer be expanded.
-   Returns the final resultant form, and T if it was expanded.  ENV is the
-   lexical environment to expand in, or NIL (the default) for the null
-   environment."
-  (labels ((frob (form expanded)
-	     (multiple-value-bind
-		 (new-form newly-expanded)
-		 (macroexpand-1 form env)
-	       (if newly-expanded
-		   (frob new-form t)
-		   (values new-form expanded)))))
-    (frob form nil)))
-
-(defun compiler-macro-function (name &optional env)
-  "If NAME names a compiler-macro, returns the expansion function,
-   else returns NIL.  Note: if the name is shadowed in ENV by a local
-   definition, or declared NOTINLINE, NIL is returned.  Can be
-   set with SETF."
-  (let ((found (and env
-		    (cdr (assoc name (c::lexenv-functions env)
-				:test #'equal)))))
-    (unless (eq (cond ((c::defined-function-p found)
-		       (c::defined-function-inlinep found))
-		      (found :notinline)
-		      (t
-		       (info function inlinep name)))
-		:notinline)
-      (values (info function compiler-macro-function name)))))
-
-(defun (setf compiler-macro-function) (function name)
-  (declare (type (or symbol list) name)
-	   (type (or function null) function))
-  (when (eq (info function kind name) :special-form)
-    (error "~S names a special form." name))
-  (setf (info function compiler-macro-function name) function)
-  function)
-
-(defun compiler-macroexpand-1 (form &optional env)
-  "If FORM is a function call for which a compiler-macro has been defined,
-   invoke the expander function using *macroexpand-hook* and return the
-   results and T.  Otherwise, return the original form and NIL."
-  (let ((fun (and (consp form) (compiler-macro-function (car form) env))))
-    (if fun
-	(let ((result (invoke-macroexpand-hook fun form env)))
-	  (values result (not (eq result form))))
-	(values form nil))))
-
-(defun compiler-macroexpand (form &optional env)
-  "Repetitively call COMPILER-MACROEXPAND-1 until the form can no longer be
-   expanded.  ENV is the lexical environment to expand in, or NIL (the
-   default) for the null environment."
-  (labels ((frob (form expanded)
-	     (multiple-value-bind
-		 (new-form newly-expanded)
-		 (compiler-macroexpand-1 form env)
-	       (if newly-expanded
-		   (frob new-form t)
-		   (values new-form expanded)))))
-    (frob form env)))
-
-
-(defun constantp (object)
-  "True of any Lisp object that has a constant value: types that eval to
-  themselves, keywords, constants, and list whose car is QUOTE."
-  (typecase object
-    (number t)
-    (character t)
-    (array t)
-    (symbol
-     (eq (info variable kind object) :constant))
-    (list (eq (car object) 'quote))))
-
-
-;;; Function invocation:
-
-(defun apply (function arg &rest args)
-  "Applies FUNCTION to a list of arguments produced by evaluating ARGS in
-  the manner of LIST*.  That is, a list is made of the values of all but the
-  last argument, appended to the value of the last argument, which must be a
-  list."
-  (cond ((atom args)
-	 (apply function arg))
-	((atom (cdr args))
-	 (apply function (cons arg (car args))))
-	(t (do* ((a1 args a2)
-		 (a2 (cdr args) (cdr a2)))
-		((atom (cdr a2))
-		 (rplacd a1 (car a2))
-		 (apply function (cons arg args)))))))
-
-
-(defun funcall (function &rest arguments)
-  "Calls Function with the given Arguments."
-  (apply function arguments))
-
-
-
-;;; Multiple-Value forms:
-
-(defun values (&rest values)
-  "Returns all of its arguments, in order, as values."
-  (values-list values))
-
-(defun values-list (list)
-  "Returns all of the elements of List, in order, as values."
-  (values-list list))
diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp
deleted file mode 100644
index 2f065e02a59ab7edff8899a878a88b5ade5d3e31..0000000000000000000000000000000000000000
--- a/code/fd-stream.lisp
+++ /dev/null
@@ -1,1504 +0,0 @@
-;;; -*- Log: code.log; Package: LISP -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.22 1992/12/10 01:09:52 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Streams for UNIX file descriptors.
-;;;
-;;; Written by William Lott, July 1989 - January 1990.
-;;; Some tuning by Rob MacLachlan.
-;;; 
-;;; **********************************************************************
-
-
-(in-package "SYSTEM")
-
-(export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
-          io-timeout beep *beep-function* output-raw-bytes
-	  *tty* *stdin* *stdout* *stderr*))
-
-
-(in-package "EXTENSIONS")
-
-(export '(*backup-extension*))
-
-
-(in-package "LISP")
-
-(export '(file-stream))
-(deftype file-stream () 'fd-stream)
-
-
-;;;; Buffer manipulation routines.
-
-(defvar *available-buffers* ()
-  "List of available buffers.  Each buffer is an sap pointing to
-  bytes-per-buffer of memory.")
-
-(defconstant bytes-per-buffer (* 4 1024)
-  "Number of bytes per buffer.")
-
-;;; NEXT-AVAILABLE-BUFFER -- Internal.
-;;;
-;;; Returns the next available buffer, creating one if necessary.
-;;;
-(proclaim '(inline next-available-buffer))
-;;;
-(defun next-available-buffer ()
-  (if *available-buffers*
-      (pop *available-buffers*)
-      (allocate-system-memory bytes-per-buffer)))
-
-
-;;;; 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
-  ;;
-  ;;; Number of bytes per element.
-  (element-size 1 :type index)
-  (element-type 'base-char)   ; The type of element being transfered.
-  (fd -1 :type fixnum)	      ; The file descriptor
-  ;;
-  ;; Controls when the output buffer is flushed.
-  (buffering :full :type (member :full :line :none))
-  ;;
-  ;; Character position if known.
-  (char-pos nil :type (or index null))
-  ;;
-  ;; T if input is waiting on FD.  :EOF if we hit EOF.
-  (listen nil :type (member nil t :eof))
-  ;;
-  ;; The input buffer.
-  (unread nil)
-  (ibuf-sap nil :type (or system-area-pointer null))
-  (ibuf-length nil :type (or index null))
-  (ibuf-head 0 :type index)
-  (ibuf-tail 0 :type index)
-
-  ;; The output buffer.
-  (obuf-sap nil :type (or system-area-pointer null))
-  (obuf-length nil :type (or index null))
-  (obuf-tail 0 :type index)
-
-  ;; Output flushed, but not written due to non-blocking io.
-  (output-later nil)
-  (handler nil)
-  ;;
-  ;; Timeout specified for this stream, or NIL if none.
-  (timeout nil :type (or index null)))
-
-(defun %print-fd-stream (fd-stream stream depth)
-  (declare (ignore depth) (stream stream))
-  (format stream "#<Stream for ~A>"
-	  (fd-stream-name fd-stream)))
-
-
-(define-condition io-timeout (stream-error) (direction)
-  (:report
-   (lambda (condition stream)
-     (format stream "Timeout ~(~A~)ing ~S."
-	     (io-timeout-direction condition)
-	     (stream-error-stream condition)))))
-
-
-;;;; 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))
-	 (reuse-sap (cadddr stuff))
-	 (length (- end start)))
-    (declare (type index start end length))
-    (multiple-value-bind
-	(count errno)
-	(unix:unix-write (fd-stream-fd stream)
-			 base
-			 start
-			 length)
-      (cond ((not count)
-	     (if (= errno unix:ewouldblock)
-		 (error "Write would have blocked, but SERVER told us to go.")
-		 (error "While writing ~S: ~A"
-			stream (unix:get-unix-error-msg errno))))
-	    ((eql count length) ; Hot damn, it workded.
-	     (when reuse-sap
-	       (push base *available-buffers*)))
-	    ((not (null count)) ; Sorta worked.
-	     (push (list base
-			 (+ start count)
-			 end)
-		   (fd-stream-output-later stream))))))
-  (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 reuse-sap)
-  (cond ((null (fd-stream-output-later stream))
-	 (setf (fd-stream-output-later stream)
-	       (list (list base start end reuse-sap)))
-	 (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 reuse-sap)))))
-  (when reuse-sap
-    (let ((new-buffer (next-available-buffer)))
-      (setf (fd-stream-obuf-sap stream) new-buffer)
-      (setf (fd-stream-obuf-length stream) bytes-per-buffer)))) 
-
-;;; 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 reuse-sap)
-  (declare (type fd-stream stream)
-	   (type (or system-area-pointer (simple-array * (*))) base)
-	   (type index start end))
-  (if (not (null (fd-stream-output-later stream))) ; something buffered.
-      (progn
-	(output-later stream base start end reuse-sap)
-	;; ### check to see if any of this noise can be output
-	)
-      (let ((length (- end start)))
-	(multiple-value-bind
-	    (count errno)
-	    (unix:unix-write (fd-stream-fd stream) base start length)
-	  (cond ((not count)
-		 (if (= errno unix:ewouldblock)
-		     (output-later stream base start end reuse-sap)
-		     (error "While writing ~S: ~A"
-			    stream (unix:get-unix-error-msg errno))))
-		((not (eql count length))
-		 (output-later stream base (+ start count) end reuse-sap)))))))
-
-
-;;; 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 t)
-      (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-CHAR-~A-BUFFERED"
-		      1
-		      (:none character)
-		      (:line character)
-		      (:full character))
-  (if (eq (char-code byte)
-	  (char-code #\Newline))
-      (setf (fd-stream-char-pos stream) 0)
-      (incf (fd-stream-char-pos stream)))
-  (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
-	(char-code byte)))
-
-(def-output-routines ("OUTPUT-BYTE-~A-BUFFERED"
-		      1
-		      (:none (signed-byte 8) (unsigned-byte 8))
-		      (:full (signed-byte 8) (unsigned-byte 8)))
-  (when (characterp byte)
-    (if (eq (char-code byte)
-	    (char-code #\Newline))
-      (setf (fd-stream-char-pos stream) 0)
-      (incf (fd-stream-char-pos stream))))
-  (setf (sap-ref-8 (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)))
-  (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
-	byte))
-
-(def-output-routines ("OUTPUT-LONG-~A-BUFFERED"
-		      4
-		      (:none (signed-byte 32) (unsigned-byte 32))
-		      (:full (signed-byte 32) (unsigned-byte 32)))
-  (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
-	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 (the (simple-array * (*)) thing)))))
-    (declare (type index 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)
-	     (if (system-area-pointer-p thing)
-		 (system-area-copy thing
-				   (* start vm:byte-bits)
-				   (fd-stream-obuf-sap stream)
-				   (* tail vm:byte-bits)
-				   (* bytes vm:byte-bits))
-		 (copy-to-system-area thing
-				      (+ (* start vm:byte-bits)
-					 (* vm:vector-data-offset vm:word-bits))
-				      (fd-stream-obuf-sap stream)
-				      (* tail vm:byte-bits)
-				      (* bytes vm:byte-bits)))
-	     (setf (fd-stream-obuf-tail stream) newtail))
-	    ((<= bytes len)
-	     (flush-output-buffer stream)
-	     (if (system-area-pointer-p thing)
-		 (system-area-copy thing
-				   (* start vm:byte-bits)
-				   (fd-stream-obuf-sap stream)
-				   0
-				   (* bytes vm:byte-bits))
-		 (copy-to-system-area thing
-				      (+ (* start vm:byte-bits)
-					 (* vm:vector-data-offset vm:word-bits))
-				      (fd-stream-obuf-sap stream)
-				      0
-				      (* bytes vm:byte-bits)))
-	     (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 (the vector 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)))
-    (declare (type index head tail))
-    (unless (zerop head)
-      (cond ((eql 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)
-	     (system-area-copy ibuf-sap (* head vm:byte-bits)
-			       ibuf-sap 0 (* tail vm:byte-bits))
-	     (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)
-	(unix:unix-select (1+ fd) (ash 1 fd) 0 0 0)
-      (case count
-	(1)
-	(0
-	 (unless (system:wait-until-fd-usable
-		  fd :input (fd-stream-timeout stream))
-	   (error 'io-timeout :stream stream :direction :read)))
-	(t
-	 (error "Problem checking to see if ~S is readable: ~A"
-		stream
-		(unix:get-unix-error-msg errno)))))
-    (multiple-value-bind
-	(count errno)
-	(unix:unix-read fd
-			(system:int-sap (+ (system:sap-int ibuf-sap) tail))
-			(- buflen tail))
-      (cond ((null count)
-	     (if (eql errno unix:ewouldblock)
-		 (progn
-		   (unless (system:wait-until-fd-usable
-			    fd :input (fd-stream-timeout stream))
-		     (error 'io-timeout :stream stream :direction :read))
-		   (do-input stream))
-		 (error "Error reading ~S: ~A"
-			stream
-			(unix:get-unix-error-msg errno))))
-	    ((zerop count)
-	     (setf (fd-stream-listen stream) :eof)
-	     (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)
-	   (setf (fd-stream-listen ,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-CHARACTER -- internal
-;;;
-;;;   Routine to use in stream-in slot for reading string chars.
-;;;
-(def-input-routine input-character
-		   (character 1 sap head)
-  (code-char (sap-ref-8 sap head)))
-
-;;; 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)
-  (sap-ref-8 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)
-  (signed-sap-ref-8 sap head))
-
-;;; 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)
-  (sap-ref-16 sap head))
-
-;;; 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)
-  (signed-sap-ref-16 sap head))
-
-;;; 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)
-  (sap-ref-32 sap head))
-
-;;; 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)
-  (signed-sap-ref-32 sap head))
-
-;;; 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)
-  (declare (type index start end))
-  (let* ((length (- end start))
-	 (string (make-string length)))
-    (copy-from-system-area sap (* start vm:byte-bits)
-			   string (* vm:vector-data-offset vm:word-bits)
-			   (* length vm:byte-bits))
-    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 (when (fd-stream-unread stream)
-			  (prog1
-			      (list (string (fd-stream-unread stream)))
-			    (setf (fd-stream-unread stream) nil)
-			    (setf (fd-stream-listen 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 (do ((index head (1+ index)))
-				   ((= index tail) nil)
-				 (when (= (sap-ref-8 sap index)
-					  (char-code #\newline))
-				   (return index))))
-		      (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)))
-
-#|
-This version waits using server.  I changed to the non-server version because
-it allows this method to be used by CLX w/o confusing serve-event.  The
-non-server method is also significantly more efficient for large reads.
-  -- Ram
-
-;;; 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)))
-		(if (typep buffer 'system-area-pointer)
-		    (system-area-copy sap (* head vm:byte-bits)
-				      buffer (* offset vm:byte-bits)
-				      (* copy vm:byte-bits))
-		    (copy-from-system-area sap (* head vm:byte-bits)
-					   buffer (+ (* offset vm:byte-bits)
-						     (* vm:vector-data-offset
-							vm:word-bits))
-					   (* copy vm:byte-bits)))
-		(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)))))
-|#
-
-
-;;; FD-STREAM-READ-N-BYTES -- internal
-;;;
-;;;    The N-Bin method for FD-STREAMs.  This doesn't using SERVER; it blocks
-;;; in UNIX-READ.  This allows the method to be used to implementing reading
-;;; for CLX.  It is generally used where there is a definite amount of reading
-;;; to be done, so blocking isn't too problematical.
-;;;
-;;;    We copy buffered data into the buffer.  If there is enough, just return.
-;;; Otherwise, we see if the amount of additional data needed will fit in the
-;;; stream buffer.  If not, inhibit GCing (so we can have a SAP into the Buffer
-;;; argument), and read directly into the user supplied buffer.  Otherwise,
-;;; read a buffer-full into the stream buffer and then copy the amount we need
-;;; out.
-;;;
-;;;    We loop doing the reads until we either get enough bytes or hit EOF.  We
-;;; must loop because some streams (like pipes) may return a partial amount
-;;; without hitting EOF.
-;;; 
-(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
-  (declare (type stream stream) (type index start requested))
-  (let* ((sap (fd-stream-ibuf-sap stream))
-	 (elsize (fd-stream-element-size stream))
-	 (offset (* elsize start))
-	 (requested-bytes (* elsize requested))
-	 (head (fd-stream-ibuf-head stream))
-	 (tail (fd-stream-ibuf-tail stream))
-	 (available (- tail head))
-	 (copy (min requested-bytes available)))
-    (declare (type index elsize offset requested-bytes head tail available
-		   copy))
-    (unless (zerop copy)
-      (if (typep buffer 'system-area-pointer)
-	  (system-area-copy sap (* head vm:byte-bits)
-			    buffer (* offset vm:byte-bits)
-			    (* copy vm:byte-bits))
-	  (copy-from-system-area sap (* head vm:byte-bits)
-				 buffer (+ (* offset vm:byte-bits)
-					   (* vm:vector-data-offset
-					      vm:word-bits))
-				 (* copy vm:byte-bits)))
-      (incf (fd-stream-ibuf-head stream) copy))
-    (cond
-     ((> requested-bytes available)
-      (setf (fd-stream-ibuf-head stream) 0)
-      (setf (fd-stream-ibuf-tail stream) 0)
-      (setf (fd-stream-listen stream) nil)
-      (let ((now-needed (- requested-bytes copy))
-	    (len (fd-stream-ibuf-length stream)))
-	(declare (type index now-needed len))
-	(cond
-	 ((> now-needed len)
-	  (system:without-gcing
-	    (loop
-	      (multiple-value-bind
-		  (count err)
-		  (unix:unix-read (fd-stream-fd stream)
-				  (sap+ (if (typep buffer 'system-area-pointer)
-					    buffer
-					    (vector-sap buffer))
-					(+ offset copy))
-				  now-needed)
-		(declare (type (or index null) count))
-		(unless count
-		  (error "Error reading ~S: ~A" stream
-			 (unix:get-unix-error-msg err)))
-		(when (zerop count)
-		  (if eof-error-p
-		      (error "Unexpected eof on ~S." stream)
-		      (return (- requested (truncate now-needed elsize)))))
-		(decf now-needed count)
-		(when (zerop now-needed) (return requested))
-		(incf offset count)))))
-	 (t
-	  (loop
-	    (multiple-value-bind
-		(count err)
-		(unix:unix-read (fd-stream-fd stream) sap len)
-	      (declare (type (or index null) count))
-	      (unless count
-		(error "Error reading ~S: ~A" stream
-		       (unix:get-unix-error-msg err)))
-	      (incf (fd-stream-ibuf-tail stream) count)
-	      (when (zerop count)
-		(if eof-error-p
-		    (error "Unexpected eof on ~S." stream)
-		    (return (- requested (truncate now-needed elsize)))))
-	      (let* ((copy (min now-needed count))
-		     (copy-bits (* copy vm:byte-bits))
-		     (buffer-start-bits
-		      (* (+ offset available) vm:byte-bits)))
-		(declare (type index copy copy-bits buffer-start-bits))
-		(if (typep buffer 'system-area-pointer)
-		    (system-area-copy sap 0
-				      buffer buffer-start-bits
-				      copy-bits)
-		    (copy-from-system-area sap 0 
-					   buffer (+ buffer-start-bits
-						     (* vm:vector-data-offset
-							vm:word-bits))
-					   copy-bits))
-		(incf (fd-stream-ibuf-head stream) copy)
-		(decf now-needed copy)
-		(when (zerop now-needed) (return requested))
-		(incf offset copy))))))))
-     (t
-      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-sap stream)
-      (push (fd-stream-obuf-sap stream) *available-buffers*)
-      (setf (fd-stream-obuf-sap stream) nil))
-    (when (fd-stream-ibuf-sap stream)
-      (push (fd-stream-ibuf-sap stream) *available-buffers*)
-      (setf (fd-stream-ibuf-sap 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-sap stream) (next-available-buffer))
-	(setf (fd-stream-ibuf-length stream) bytes-per-buffer)
-	(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-sap stream) (next-available-buffer))
-	(setf (fd-stream-obuf-length stream) bytes-per-buffer)
-	(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 'base-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)
-		((or (null output-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)
-	       (eql (unix:unix-select (1+ (fd-stream-fd stream))
-				      (ash 1 (fd-stream-fd stream))
-				      0
-				      0
-				      0)
-		    1))))
-    (:unread
-     (setf (fd-stream-unread stream) arg1)
-     (setf (fd-stream-listen stream) t))
-    (:close
-     (cond (arg1
-	    ;; We got us an abort on our hands.
-	    (when (and (fd-stream-file stream)
-		       (fd-stream-obuf-sap 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)
-		      (unix: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)
-			      (unix:get-unix-error-msg err))))
-		  ;; Can't restore the orignal, so nuke that puppy.
-		  (multiple-value-bind
-		      (okay err)
-		      (unix: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)
-			      (unix: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)
-		  (unix: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
-			  (unix:get-unix-error-msg err)))))))
-     (when (fboundp 'cancel-finalization)
-       (cancel-finalization stream))
-     (unix:unix-close (fd-stream-fd stream))
-     (when (fd-stream-obuf-sap stream)
-       (push (fd-stream-obuf-sap stream) *available-buffers*)
-       (setf (fd-stream-obuf-sap stream) nil))
-     (when (fd-stream-ibuf-sap stream)
-       (push (fd-stream-ibuf-sap stream) *available-buffers*)
-       (setf (fd-stream-ibuf-sap stream) nil))
-     (lisp::set-closed-flame stream))
-    (:clear-input
-     (setf (fd-stream-ibuf-head stream) 0)
-     (setf (fd-stream-ibuf-tail stream) 0)
-     (loop
-       (let ((count (unix:unix-select (1+ (fd-stream-fd stream))
-				      (ash 1 (fd-stream-fd stream))
-				      0 0 0)))
-	 (cond ((eql count 1)
-		(do-input stream)
-		(setf (fd-stream-ibuf-head stream) 0)
-		(setf (fd-stream-ibuf-tail stream) 0))
-	       (t
-		(return))))))
-    (: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))
-    (:interactive-p
-     (unix:unix-isatty (fd-stream-fd 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)
-	 (unix: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
-		(unix:get-unix-error-msg dev)))
-       (if (zerop mode)
-	 nil
-	 (truncate 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)
-  (declare (type fd-stream stream)
-	   (type (or index (member nil :start :end)) newpos))
-  (if (null newpos)
-      (system:without-interrupts
-	;; First, find the position of the UNIX file descriptor in the
-	;; file.
-	(multiple-value-bind
-	    (posn errno)
-	    (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)
-	  (declare (type (or index null) posn))
-	  (cond ((fixnump 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 (- (the index (caddr later))
-				 (the index (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.
-		 (truncate posn (fd-stream-element-size stream)))
-		((eq errno unix:espipe)
-		 nil)
-		(t
-		 (system:with-interrupts
-		   (error "Error lseek'ing ~S: ~A"
-			  stream
-			  (unix: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))
-	;; Clear out any pending input to force the next read to go to the
-	;; disk.
-	(setf (fd-stream-unread stream) nil)
-	(setf (fd-stream-ibuf-head stream) 0)
-	(setf (fd-stream-ibuf-tail stream) 0)
-	;; Trash cashed value for listen, so that we check next time.
-	(setf (fd-stream-listen stream) nil)
-	;; Now move it.
-	(cond ((eq newpos :start)
-	       (setf offset 0 origin unix:l_set))
-	      ((eq newpos :end)
-	       (setf offset 0 origin unix:l_xtnd))
-	      ((typep newpos 'index)
-	       (setf offset (* newpos (fd-stream-element-size stream))
-		     origin unix:l_set))
-	      (t
-	       (error "Invalid position given to file-position: ~S" newpos)))
-	(multiple-value-bind
-	    (posn errno)
-	    (unix:unix-lseek (fd-stream-fd stream) offset origin)
-	  (cond ((typep posn 'fixnum)
-		 t)
-		((eq errno unix:espipe)
-		 nil)
-		(t
-		 (error "Error lseek'ing ~S: ~A"
-			stream
-			(unix: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 'base-char)
-		       (buffering :full)
-		       timeout
-		       file
-		       original
-		       delete-original
-		       (name (if file
-				 (format nil "file ~S" file)
-				 (format nil "descriptor ~D" fd)))
-		       auto-close)
-  (declare (type index fd) (type (or index null) timeout)
-	   (type (member :none :line :full) buffering))
-  "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.
-  Timeout (if true) is the number of seconds to wait for input.  If NIL (the
-    default), then wait forever.  When we time out, we signal IO-TIMEOUT.
-  File is the name of the file (will be returned by PATHNAME).
-  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
-				 :timeout timeout)))
-    (set-routines stream element-type input output)
-    (when (and auto-close (fboundp 'finalize))
-      (finalize stream
-		#'(lambda ()
-		    (unix:unix-close fd)
-		    (format *terminal-io* "** Closed file descriptor ~D~%"
-			    fd))))
-    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)
-  (declare (type simple-string name))
-  (let ((ext *backup-extension*))
-    (etypecase ext
-      (simple-string (concatenate 'simple-string name ext))
-      (function (funcall ext 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 (the stream *query-io*) "Enter new value for ~S: " what)
-      (force-output *query-io*)
-      (setf item (read *query-io*))
-      (when (member item list)
-	(return))))
-  item)
-
-;;; DO-OLD-RENAME  --  Internal
-;;;
-;;;    Rename Namestring to Original.  First, check if we have write access,
-;;; since we don't want to trash unwritable files even if we technically can.
-;;; We return true if we suceed in renaming.
-;;;
-(defun do-old-rename (namestring original)
-  (unless (unix:unix-access namestring unix:w_ok)
-    (cerror "Try to rename it anyway." "File ~S is not writable." namestring))
-  (multiple-value-bind
-      (okay err)
-      (unix:unix-rename namestring original)
-    (cond (okay t)
-	  (t
-	   (cerror "Use :SUPERSEDE instead."
-		   "Could not rename ~S to ~S: ~A."
-		   namestring
-		   original
-		   (unix:get-unix-error-msg err))
-	   nil))))
-
-
-;;; OPEN -- public
-;;;
-;;;   Open the given file.
-;;;
-(defun open (filename
-	     &key
-	     (direction :input)
-	     (element-type 'base-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 BASE-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 unix:o_rdonly))
-	(:output (values nil t unix:o_wronly))
-	(:io (values t t unix:o_rdwr))
-	(:probe (values t nil unix:o_rdonly)))
-    (declare (type index mask))
-    (let* ((pathname (pathname filename))
-	   (namestring (unix-namestring 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 unix:o_excl)))
-	       ((:rename :rename-and-delete)
-		(setf mask (logior mask unix:o_creat)))
-	       ((:new-version :supersede)
-		(setf mask (logior mask unix:o_trunc)))
-	       (:append
-		(setf mask (logior mask unix: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 unix: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
-		 (and namestring
-		      (multiple-value-bind
-			  (okay err/dev inode orig-mode)
-			  (unix:unix-stat namestring)
-			(declare (ignore inode)
-				 (type (or index null) orig-mode))
-			(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 unix:enoent)
-			  nil)
-			 (t
-			  (error "Cannot find ~S: ~A"
-				 namestring
-				 (unix:get-unix-error-msg err/dev))))))))
-	    (unless (and exists
-			 (do-old-rename namestring original))
-	      (setf original nil)
-	      (setf delete-original nil)
-	      ;; In order to use SUPERSEDE instead, we have
-	      ;; to make sure unix:o_creat corresponds to
-	      ;; if-does-not-exist.  unix:o_creat was set
-	      ;; before because of if-exists being :rename.
-	      (unless (eq if-does-not-exist :create)
-		(setf mask (logior (logandc2 mask unix:o_creat) unix:o_trunc)))
-	      (setf if-exists :supersede))))
-	
-	;; Okay, now we can try the actual open.
-	(loop
-	  (multiple-value-bind
-	      (fd errno)
-	      (if namestring
-		  (unix:unix-open namestring mask mode)
-		  (values nil unix:enoent))
-	    (cond ((numberp fd)
-		   (return
-		    (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
-				       :auto-close t))
-		      (:probe
-		       (let ((stream
-			      (%make-fd-stream :name namestring :fd fd
-					       :element-type element-type)))
-			 (close stream)
-			 stream)))))
-		  ((eql errno unix:enoent)
-		   (case if-does-not-exist
-		     (:error
-		      (cerror "Return NIL."
-			      "Error opening ~S, ~A."
-			      pathname
-			      (unix:get-unix-error-msg errno)))
-		     (:create
-		      (cerror "Return NIL."
-			      "Error creating ~S, path does not exist."
-			      pathname)))
-		   (return nil))
-		  ((eql errno unix:eexist)
-		   (unless (eq nil if-exists)
-		     (cerror "Return NIL."
-			     "Error opening ~S, ~A."
-			     pathname
-			     (unix:get-unix-error-msg errno)))
-		   (return nil))
-		  ((eql errno unix:eacces)
-		   (cerror "Try again."
-			  "Error opening ~S, ~A."
-			  pathname
-			  (unix:get-unix-error-msg errno)))
-		  (t
-		   (cerror "Return NIL."
-			   "Error opening ~S, ~A."
-			   pathname
-			   (unix:get-unix-error-msg errno))
-		   (return 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-output* (make-synonym-stream '*stdout*))
-  (setf *standard-input*
-	(make-two-way-stream (make-synonym-stream '*stdin*)
-			     *standard-output*))
-  (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 (unix:unix-open "/dev/tty" unix:o_rdwr #o666)))
-    (if tty
-	(setf *tty*
-	      (make-fd-stream tty :name "the Terminal" :input t :output t
-			      :buffering :line :auto-close t))
-	(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 5c9bccda79bf5d1773998d1fd619e99e6a955f18..0000000000000000000000000000000000000000
--- a/code/fdefinition.lisp
+++ /dev/null
@@ -1,299 +0,0 @@
-;;; -*- Package: Lisp; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.14 1992/12/13 16:04:28 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Functions that hack on the global function namespace (primarily
-;;; concerned with SETF functions here).  Also, function encapsulation
-;;; and routines that set and return definitions disregarding whether
-;;; they might be encapsulated.
-;;;
-;;; Written by Rob MacLachlan
-;;; Modified by Bill Chiles (wrote encapsulation stuff) 
-;;; Modified more by William Lott (added ``fdefn'' objects)
-;;;
-
-(in-package "EXTENSIONS")
-
-(export '(encapsulate unencapsulate encapsulated-p
-	  basic-definition argument-list *setf-fdefinition-hook*))
-
-
-(in-package "KERNEL")
-
-(export '(fdefn make-fdefn fdefn-p fdefn-name fdefn-function fdefn-makunbound
-	  %coerce-to-function raw-definition))
-
-
-(in-package "LISP")
-
-(export '(fdefinition fboundp fmakunbound))
-
-
-
-;;;; Fdefinition (fdefn) objects.
-
-(defun make-fdefn (name)
-  (make-fdefn name))
-
-(defun fdefn-name (fdefn)
-  (declare (type fdefn fdefn))
-  (fdefn-name fdefn))
-
-(defun fdefn-function (fdefn)
-  (declare (type fdefn fdefn)
-	   (values (or function null)))
-  (fdefn-function fdefn))
-
-(defun (setf fdefn-function) (fun fdefn)
-  (declare (type function fun)
-	   (type fdefn fdefn)
-	   (values function))
-  (setf (fdefn-function fdefn) fun))
-
-(defun fdefn-makunbound (fdefn)
-  (declare (type fdefn fdefn))
-  (fdefn-makunbound fdefn))
-
-
-;;; FDEFN-INIT -- internal interface.
-;;;
-;;; This function is called by %INITIAL-FUNCTION after the globaldb has been
-;;; initialized, but before anything else.  We need to install these fdefn
-;;; objects into the globaldb *before* any top level forms run, or we will
-;;; end up with two different fdefn objects being used for the same function
-;;; name.  *INITIAL-FDEFN-OBJECTS* is set up by GENESIS.
-;;;
-(defvar *initial-fdefn-objects*)
-;;;
-(defun fdefn-init ()
-  (dolist (fdefn *initial-fdefn-objects*)
-    (setf (info function definition (fdefn-name fdefn)) fdefn))
-  (makunbound '*initial-fdefn-objects*))
-
-;;; FDEFINITION-OBJECT -- internal interface.
-;;;
-(defun fdefinition-object (name create)
-  "Return the fdefn object for NAME.  If it doesn't already exist and CREATE
-   it non-NIL, create a new (unbound) one."
-  (declare (values (or fdefn null)))
-  (unless (or (symbolp name)
-	      (and (consp name)
-		   (eq (car name) 'setf)
-		   (let ((cdr (cdr name)))
-		     (and (consp cdr)
-			  (symbolp (car cdr))
-			  (null (cdr cdr))))))
-    (error "Invalid function name: ~S" name))
-  (let ((fdefn (info function definition name)))
-    (if (and (null fdefn) create)
-	(setf (info function definition name) (make-fdefn name))
-	fdefn)))
-
-;;; %COERCE-TO-FUNCTION -- public.
-;;;
-;;; The compiler emits calls to this when someone tries to funcall a symbol.
-;;;
-(defun %coerce-to-function (name)
-  "Returns the definition for name, including any encapsulations.  Settable
-   with SETF."
-  (let ((fdefn (fdefinition-object name nil)))
-    (or (and fdefn (fdefn-function fdefn))
-	(error 'undefined-function :name name))))
-
-;;; RAW-DEFINITION -- public.
-;;;
-;;; Just another name for %coerce-to-function.
-;;; 
-(declaim (inline raw-definition))
-(defun raw-definition (name)
-  (declare (optimize (inhibit-warnings 3)))
-  ;; We know that we are calling %coerce-to-function, so don't tell us about
-  ;; it.
-  (%coerce-to-function name))
-;;;
-(defun (setf raw-definition) (function name)
-  (let ((fdefn (fdefinition-object name t)))
-    (setf (fdefn-function fdefn) function)))
-
-
-
-;;;; Definition Encapsulation.
-
-(defstruct (encapsulation-info (:print-function print-encapsulation-info)
-			       (:constructor make-encapsulation-info
-					     (type definition)))
-  ;; This is definition's encapsulation type.  The encapsulated definition is
-  ;; in the previous encapsulation-info element or installed as the global
-  ;; definition of some function name.
-  type
-  ;; Previous definition.  This used to be installed as a global definition
-  ;; for some function name, but it was replaced by an encapsulation of type
-  ;; type.
-  (definition nil :type function))
-;;;
-(defun print-encapsulation-info (obj str n)
-  (declare (ignore n))
-  (format str "#<Encapsulation-Info  Definition: ~S  Type: ~S>"
-	  (%function-name (encapsulation-info-definition obj))
-	  (encapsulation-info-type obj)))
-
-
-;;; ENCAPSULATE -- Public.
-;;;
-;;; We must bind and close over info.  Consider the case where we encapsulate
-;;; (the second) an encapsulated (the first) definition, and later someone
-;;; unencapsulates the encapsulated (first) definition.  We don't want our
-;;; encapsulation (second) to bind basic-definition to the encapsulated (first)
-;;; definition when it no longer exists.  When unencapsulating, we make sure to
-;;; clobber the appropriate info structure to allow basic-definition to be
-;;; bound to the next definition instead of an encapsulation that no longer
-;;; exists.
-;;;
-(defun encapsulate (name type body)
-  "Replaces the definition of NAME with a function that binds name's arguments
-   a variable named argument-list, binds name's definition to a variable named
-   basic-definition, and evaluates BODY in that context.  TYPE is
-   whatever you would like to associate with this encapsulation for
-   identification in case you need multiple encapsuations of the same name."
-  (let ((fdefn (fdefinition-object name nil)))
-    (unless (and fdefn (fdefn-function fdefn))
-      (error 'undefined-function :name name))
-    (let ((info (make-encapsulation-info type (fdefn-function fdefn))))
-      (setf (fdefn-function fdefn)
-	    #'(lambda (&rest argument-list)
-		(declare (special argument-list))
-		(let ((basic-definition (encapsulation-info-definition info)))
-		  (declare (special basic-definition))
-		  (eval body)))))))
-
-;;; ENCAPSULATION-INFO -- internal.
-;;;
-;;; Finds the encapsulation info that has been closed over.
-;;; 
-(defun encapsulation-info (fun)
-  (and (functionp fun)
-       (= (get-type fun) vm:closure-header-type)
-       (find-if-in-closure #'encapsulation-info-p fun)))
-
-;;; UNENCAPSULATE -- Public.
-;;;
-;;; When removing an encapsulation, we must remember that encapsulating
-;;; definitions close over a reference to the encapsulation-info that describes
-;;; the encapsulating definition.  When you find an info with the target type,
-;;; the previous info in the chain has the ensulating definition of that type.
-;;; We take the encapsulated definition from the info with the target type, and
-;;; we store it in the previous info structure whose encapsulating definition
-;;; it describes looks to this previous info structure for a definition to
-;;; bind (see ENCAPSULATE).  When removing the first info structure, we do
-;;; something conceptually equal, but mechanically it is different.
-;;;
-(defun unencapsulate (name type)
-  "Removes name's most recent encapsulation of the specified type."
-  (let* ((fdefn (fdefinition-object name nil))
-	 (encap-info (encapsulation-info (fdefn-function fdefn))))
-    (declare (type (or encapsulation-info null) encap-info))
-    (cond ((not encap-info)
-	   ;; It disappeared on us, so don't worry about it.
-	   )
-	  ((eq (encapsulation-info-type encap-info) type)
-	   ;; It's the first one, so change the fdefn object.
-	   (setf (fdefn-function fdefn)
-		 (encapsulation-info-definition encap-info)))
-	  (t
-	   ;; It must be an interior one, so find it.
-	   (loop
-	     (let ((next-info (encapsulation-info
-			       (encapsulation-info-definition encap-info))))
-	       (unless next-info
-		 ;; Not there, so don't worry about it.
-		 (return))
-	       (when (eq (encapsulation-info-type next-info) type)
-		 ;; This is it, so unlink us.
-		 (setf (encapsulation-info-definition encap-info)
-		       (encapsulation-info-definition next-info))
-		 (return))
-	       (setf encap-info next-info))))))
-  t)
-
-;;; ENCAPSULATED-P -- Public.
-;;;
-(defun encapsulated-p (name type)
-  "Returns t if name has an encapsulation of the given type, otherwise nil."
-  (let ((fdefn (fdefinition-object name nil)))
-    (do ((encap-info (encapsulation-info (fdefn-function fdefn))
-		     (encapsulation-info
-		      (encapsulation-info-definition encap-info))))
-	((null encap-info) nil)
-      (declare (type (or encapsulation-info null) encap-info))
-      (when (eq (encapsulation-info-type encap-info) type)
-	(return t)))))
-
-
-;;;; FDEFINITION.
-
-(defun fdefinition (name)
-  "Return name's global function definition taking care to regard any
-   encapsulations and to return the innermost encapsulated definition.
-   This is SETF'able."
-  (let ((fun (raw-definition name)))
-    (loop
-      (let ((encap-info (encapsulation-info fun)))
-	(if encap-info
-	    (setf fun (encapsulation-info-definition encap-info))
-	    (return fun))))))
-
-(defvar *setf-fdefinition-hook* nil
-  "This holds functions that (SETF FDEFINITION) invokes before storing the
-   new value.  These functions take the function name and the new value.")
-
-(defun %set-fdefinition (name new-value)
-  "Set name's global function definition."
-  (declare (type function new-value) (optimize (safety 1)))
-  (let ((fdefn (fdefinition-object name t)))
-    ;; *setf-fdefinition-hook* won't be bound when
-    ;; initially running top-level forms in the kernel
-    ;; core startup.
-    (when (boundp '*setf-fdefinition-hook*)
-      (dolist (f *setf-fdefinition-hook*)
-	(funcall f name new-value)))
-
-    (let ((encap-info (encapsulation-info (fdefn-function fdefn))))
-      (cond (encap-info
-	     (loop
-	       (let ((more-info
-		      (encapsulation-info
-		       (encapsulation-info-definition encap-info))))
-		 (if more-info
-		     (setf encap-info more-info)
-		     (return
-		      (setf (encapsulation-info-definition encap-info)
-			    new-value))))))
-	    (t
-	     (setf (fdefn-function fdefn) new-value))))))
-;;;
-(defsetf fdefinition %set-fdefinition)
-
-
-
-;;;; FBOUNDP and FMAKUNBOUND.
-
-(defun fboundp (name)
-  "Return true if name has a global function definition."
-  (let ((fdefn (fdefinition-object name nil)))
-    (and fdefn (fdefn-function fdefn) t)))
-
-(defun fmakunbound (name)
-  "Make Name have no global function definition."
-  (let ((fdefn (fdefinition-object name nil)))
-    (when fdefn
-      (fdefn-makunbound fdefn)))
-  name)
diff --git a/code/filesys.lisp b/code/filesys.lisp
deleted file mode 100644
index 8d2ce85243aba56fc31b8269a13bda563f430276..0000000000000000000000000000000000000000
--- a/code/filesys.lisp
+++ /dev/null
@@ -1,1156 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.29 1992/09/04 15:22:16 phg Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; File system interface functions.  This file is pretty UNIX specific.
-;;;
-;;; Written by William Lott
-;;;
-;;; **********************************************************************
-
-(in-package "LISP")
-
-(export '(truename probe-file user-homedir-pathname directory
-          rename-file delete-file file-write-date file-author))
-
-(use-package "EXTENSIONS")
-
-(in-package "EXTENSIONS")
-(export '(print-directory complete-file ambiguous-files default-directory
-			  file-writable unix-namestring))
-(in-package "LISP")
-
-
-;;;; Unix pathname host support.
-
-;;; Unix namestrings have the following format:
-;;;
-;;; namestring := [ directory ] [ file [ type [ version ]]]
-;;; directory := [ "/" | search-list ] { file "/" }*
-;;; search-list := [^:/]*:
-;;; file := [^/]*
-;;; type := "." [^/.]*
-;;; version := "." ([0-9]+ | "*")
-;;;
-;;; Note: this grammer is ambiguous.  The string foo.bar.5 can be parsed
-;;; as either just the file specified or as specifying the file, type, and
-;;; version.  Therefore, we use the following rules when confronted with
-;;; an ambiguous file.type.version string:
-;;;
-;;; - If the first character is a dot, it's part of the file.  It is not
-;;; considered a dot in the following rules.
-;;;
-;;; - If there is only one dot, it seperates the file and the type.
-;;;
-;;; - If there are multiple dots and the stuff following the last dot
-;;; is a valid version, then that is the version and the stuff between
-;;; the second to last dot and the last dot is the type.
-;;;
-;;; Wildcard characters:
-;;;
-;;; If the directory, file, type components contain any of the following
-;;; characters, it is considered part of a wildcard pattern and has the
-;;; following meaning.
-;;;
-;;; ? - matches any character
-;;; * - matches any zero or more characters.
-;;; [abc] - matches any of a, b, or c.
-;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
-;;;
-;;; Any of these special characters can be preceeded by a backslash to
-;;; cause it to be treated as a regular character.
-;;;
-
-(defun remove-backslashes (namestr start end)
-  "Remove and occurences of \\ from the string because we've already
-   checked for whatever they may have been backslashed."
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (let* ((result (make-string (- end start)))
-	 (dst 0)
-	 (quoted nil))
-    (do ((src start (1+ src)))
-	((= src end))
-      (cond (quoted
-	     (setf (schar result dst) (schar namestr src))
-	     (setf quoted nil)
-	     (incf dst))
-	    (t
-	     (let ((char (schar namestr src)))
-	       (cond ((char= char #\\)
-		      (setq quoted t))
-		     (t
-		      (setf (schar result dst) char)
-		      (incf dst)))))))
-    (when quoted
-      (error 'namestring-parse-error
-	     :complaint "Backslash in bad place."
-	     :namestring namestr
-	     :offset (1- end)))
-    (shrink-vector result dst)))
-
-(defvar *ignore-wildcards* nil)
-
-(defun maybe-make-pattern (namestr start end)
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (if *ignore-wildcards*
-      (subseq namestr start end)
-      (collect ((pattern))
-	(let ((quoted nil)
-	      (any-quotes nil)
-	      (last-regular-char nil)
-	      (index start))
-	  (flet ((flush-pending-regulars ()
-		   (when last-regular-char
-		     (pattern (if any-quotes
-				  (remove-backslashes namestr
-						      last-regular-char
-						      index)
-				  (subseq namestr last-regular-char index)))
-		     (setf any-quotes nil)
-		     (setf last-regular-char nil))))
-	    (loop
-	      (when (>= index end)
-		(return))
-	      (let ((char (schar namestr index)))
-		(cond (quoted
-		       (incf index)
-		       (setf quoted nil))
-		      ((char= char #\\)
-		       (setf quoted t)
-		       (setf any-quotes t)
-		       (unless last-regular-char
-			 (setf last-regular-char index))
-		       (incf index))
-		      ((char= char #\?)
-		       (flush-pending-regulars)
-		       (pattern :single-char-wild)
-		       (incf index))
-		      ((char= char #\*)
-		       (flush-pending-regulars)
-		       (pattern :multi-char-wild)
-		       (incf index))
-		      ((char= char #\[)
-		       (flush-pending-regulars)
-		       (let ((close-bracket
-			      (position #\] namestr :start index :end end)))
-			 (unless close-bracket
-			   (error 'namestring-parse-error
-				  :complaint "``['' with no corresponding ``]''"
-				  :namestring namestr
-				  :offset index))
-			 (pattern (list :character-set
-					(subseq namestr
-						(1+ index)
-						close-bracket)))
-			 (setf index (1+ close-bracket))))
-		      (t
-		       (unless last-regular-char
-			 (setf last-regular-char index))
-		       (incf index)))))
-	    (flush-pending-regulars)))
-	(cond ((null (pattern))
-	       "")
-	      ((and (null (cdr (pattern)))
-		    (simple-string-p (car (pattern))))
-	       (car (pattern)))
-	      (t
-	       (make-pattern (pattern)))))))
-
-(defun extract-name-type-and-version (namestr start end)
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (let* ((last-dot (position #\. namestr :start (1+ start) :end end
-			     :from-end t))
-	 (second-to-last-dot (and last-dot
-				  (position #\. namestr :start (1+ start)
-					    :end last-dot :from-end t)))
-	 (version :newest))
-    ;; If there is a second-to-last dot, check to see if there is a valid
-    ;; version after the last dot.
-    (when second-to-last-dot
-      (cond ((and (= (+ last-dot 2) end)
-		  (char= (schar namestr (1+ last-dot)) #\*))
-	     (setf version :wild))
-	    ((and (< (1+ last-dot) end)
-		  (do ((index (1+ last-dot) (1+ index)))
-		      ((= index end) t)
-		    (unless (char<= #\0 (schar namestr index) #\9)
-		      (return nil))))
-	     (setf version
-		   (parse-integer namestr :start (1+ last-dot) :end end)))
-	    (t
-	     (setf second-to-last-dot nil))))
-    (cond (second-to-last-dot
-	   (values (maybe-make-pattern namestr start second-to-last-dot)
-		   (maybe-make-pattern namestr
-				       (1+ second-to-last-dot)
-				       last-dot)
-		   version))
-	  (last-dot
-	   (values (maybe-make-pattern namestr start last-dot)
-		   (maybe-make-pattern namestr (1+ last-dot) end)
-		   version))
-	  (t
-	   (values (maybe-make-pattern namestr start end)
-		   nil
-		   version)))))
-
-(defun split-at-slashes (namestr start end &optional (char #\/))
-  "Take a string and return a list of cons cells that mark the char
-   separated subseq. The first value t if absolute directories location."
-    (declare (type simple-base-string namestr)
-	   (type index start end))
-  (let ((absolute (and (/= start end)
-		       (char= (schar namestr start) char))))
-    (when absolute
-      (incf start))
-    ;; Next, split the remainder into ; separated chunks.
-    (collect ((pieces))
-      (loop
-	(let ((char-pos (position char namestr :start start :end end)))
-	  (pieces (cons start (or char-pos end)))
-	  (unless char-pos
-	    (return))
-	  (setf start (1+ char-pos))))
-      (values absolute (pieces)))))
-
-(defun maybe-extract-search-list (namestr start end)
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (let ((quoted nil))
-    (do ((index start (1+ index)))
-	((= index end)
-	 (values nil start))
-      (if quoted
-	  (setf quoted nil)
-	  (case (schar namestr index)
-	    (#\\
-	     (setf quoted t))
-	    (#\:
-	     (return (values (remove-backslashes namestr start index)
-			     (1+ index)))))))))
-
-(defun parse-unix-namestring (namestr start end)
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (multiple-value-bind
-      (absolute pieces)
-      (split-at-slashes namestr start end)
-    (let ((search-list
-	   (if absolute
-	       nil
-	       (let ((first (car pieces)))
-		 (multiple-value-bind
-		     (search-list new-start)
-		     (maybe-extract-search-list namestr
-						(car first) (cdr first))
-		   (when search-list
-		     (setf absolute t)
-		     (setf (car first) new-start))
-		   search-list)))))
-      (multiple-value-bind
-	  (name type version)
-	  (let* ((tail (car (last pieces)))
-		 (tail-start (car tail))
-		 (tail-end (cdr tail)))
-	    (unless (= tail-start tail-end)
-	      (setf pieces (butlast pieces))
-	      (extract-name-type-and-version namestr tail-start tail-end)))
-	;; Now we have everything we want.  So return it.
-	(values nil ; no host for unix namestrings.
-		nil ; no devices for unix namestrings.
-		(collect ((dirs))
-		  (when search-list
-		    (dirs (intern-search-list search-list)))
-		  (dolist (piece pieces)
-		    (let ((piece-start (car piece))
-			  (piece-end (cdr piece)))
-		      (unless (= piece-start piece-end)
-			(let ((dir (maybe-make-pattern namestr
-						       piece-start
-						       piece-end)))
-			  (if (and (simple-string-p dir)
-				   (string= dir ".."))
-			      (dirs :up)
-			      (dirs dir))))))
-		  (cond (absolute
-			 (cons :absolute (dirs)))
-			((dirs)
-			 (cons :relative (dirs)))
-			(t
-			 nil)))
-		name
-		type
-		version)))))
-
-(defun unparse-unix-host (pathname)
-  (declare (type pathname pathname)
-	   (ignore pathname))
-  "Unix")
-
-(defun unparse-unix-piece (thing)
-  (etypecase thing
-    (keyword
-     (cond ((eq thing ':wild) "*")
-	   ((eq thing ':wild-inferiors) "**")
-	   (t (error "Invalid keyword piece: ~S~%" thing))))
-    (simple-string
-     (let* ((srclen (length thing))
-	    (dstlen srclen))
-       (dotimes (i srclen)
-	 (case (schar thing i)
-	   ((#\* #\? #\[)
-	    (incf dstlen))))
-       (let ((result (make-string dstlen))
-	     (dst 0))
-	 (dotimes (src srclen)
-	   (let ((char (schar thing src)))
-	     (case char
-	       ((#\* #\? #\[)
-		(setf (schar result dst) #\\)
-		(incf dst)))
-	     (setf (schar result dst) char)
-	     (incf dst)))
-	 result)))
-    (pattern
-     (collect ((strings))
-       (dolist (piece (pattern-pieces thing))
-	 (etypecase piece
-	   (simple-string
-	    (strings piece))
-	   (symbol
-	    (case piece
-	      (:wild
-	       (strings "*"))
-	      (:multi-char-wild
-	       (strings "*"))
-	      (:single-char-wild
-	       (strings "?"))
-	      (t
-	       (error "Invalid pattern piece: ~S" piece))))
-	   (cons
-	    (case (car piece)
-	      (:character-set
-	       (strings "[")
-	       (strings (cdr piece))
-	       (strings "]"))
-	      (t
-	       (error "Invalid pattern piece: ~S" piece))))))
-       (apply #'concatenate
-	      'simple-string
-	      (strings))))))
-
-(defun unparse-unix-directory-list (directory)
-  (declare (type list directory))
-  (collect ((pieces))
-    (when directory
-      (ecase (pop directory)
-	(:absolute
-	 (cond ((search-list-p (car directory))
-		(pieces (search-list-name (pop directory)))
-		(pieces ":"))
-	       (t
-		(pieces "/"))))
-	(:relative
-	 ;; Nothing special.
-	 ))
-      (dolist (dir directory)
-	(typecase dir
-	  ((member :up)
-	   (pieces "../"))
-	  ((member :back)
-	   (error ":BACK cannot be represented in namestrings."))
-	  ((or simple-string pattern)
-	   (pieces (unparse-unix-piece dir))
-	   (pieces "/"))
-	  (t
-	   (error "Invalid directory component: ~S" dir)))))
-    (apply #'concatenate 'simple-string (pieces))))
-
-(defun unparse-unix-directory (pathname)
-  (declare (type pathname pathname))
-  (unparse-unix-directory-list (%pathname-directory pathname)))
-  
-(defun unparse-unix-file (pathname)
-  (declare (type pathname pathname))
-  (collect ((strings))
-    (let* ((name (%pathname-name pathname))
-	   (type (%pathname-type pathname))
-	   (type-supplied (not (or (null type) (eq type :unspecific))))
-	   (version (%pathname-version pathname))
-	   (version-supplied (not (or (null version) (eq version :newest)))))
-      (when name
-	(strings (unparse-unix-piece name)))
-      (when type-supplied
-	(unless name
-	  (error "Cannot specify the type without a file: ~S" pathname))
-	(strings ".")
-	(strings (unparse-unix-piece type)))
-      (when version-supplied
-	(unless type-supplied
-	  (error "Cannot specify the version without a type: ~S" pathname))
-	(strings (if (eq version :wild)
-		     ".*"
-		     (format nil ".~D" version)))))
-    (apply #'concatenate 'simple-string (strings))))
-
-(defun unparse-unix-namestring (pathname)
-  (declare (type pathname pathname))
-  (concatenate 'simple-string
-	       (unparse-unix-directory pathname)
-	       (unparse-unix-file pathname)))
-
-(defun unparse-unix-enough (pathname defaults)
-  (declare (type pathname pathname defaults))
-  (flet ((lose ()
-	   (error "~S cannot be represented relative to ~S"
-		  pathname defaults)))
-    (collect ((strings))
-      (let* ((pathname-directory (%pathname-directory pathname))
-	     (defaults-directory (%pathname-directory defaults))
-	     (prefix-len (length defaults-directory))
-	     (result-dir
-	      (cond ((and (> prefix-len 1)
-			  (>= (length pathname-directory) prefix-len)
-			  (compare-component (subseq pathname-directory
-						     0 prefix-len)
-					     defaults-directory))
-		     ;; Pathname starts with a prefix of default.  So just
-		     ;; use a relative directory from then on out.
-		     (cons :relative (nthcdr prefix-len pathname-directory)))
-		    ((eq (car pathname-directory) :absolute)
-		     ;; We are an absolute pathname, so we can just use it.
-		     pathname-directory)
-		    (t
-		     ;; We are a relative directory.  So we lose.
-		     (lose)))))
-	(strings (unparse-unix-directory-list result-dir)))
-      (let* ((pathname-version (%pathname-version pathname))
-	     (version-needed (and pathname-version
-				  (not (eq pathname-version :newest))))
-	     (pathname-type (%pathname-type pathname))
-	     (type-needed (or version-needed
-			      (and pathname-type
-				   (not (eq pathname-type :unspecific)))))
-	     (pathname-name (%pathname-name pathname))
-	     (name-needed (or type-needed
-			      (and pathname-name
-				   (not (compare-component pathname-name
-							   (%pathname-name
-							    defaults)))))))
-	(when name-needed
-	  (unless pathname-name (lose))
-	  (strings (unparse-unix-piece pathname-name)))
-	(when type-needed
-	  (when (or (null pathname-type) (eq pathname-type :unspecific))
-	    (lose))
-	  (strings ".")
-	  (strings (unparse-unix-piece pathname-type)))
-	(when version-needed
-	  (typecase pathname-version
-	    ((member :wild)
-	     (strings ".*"))
-	    (integer
-	     (strings (format nil ".~D" pathname-version)))
-	    (t
-	     (lose)))))
-      (apply #'concatenate 'simple-string (strings)))))
-
-
-(defstruct (unix-host
-	    (:include host
-		      (:parse #'parse-unix-namestring)
-		      (:unparse #'unparse-unix-namestring)
-		      (:unparse-host #'unparse-unix-host)
-		      (:unparse-directory #'unparse-unix-directory)
-		      (:unparse-file #'unparse-unix-file)
-		      (:unparse-enough #'unparse-unix-enough)
-		      (:customary-case :lower))
-	    (:make-load-form-fun make-unix-host-load-form))
-  )
-
-(defvar *unix-host* (make-unix-host))
-
-(defun make-unix-host-load-form (host)
-  (declare (ignore host))
-  '*unix-host*)
-
-
-;;;; Wildcard matching stuff.
-
-(defmacro enumerate-matches ((var pathname &optional result
-				  &key (verify-existance t))
-			     &body body)
-  (let ((body-name (gensym)))
-    `(block nil
-       (flet ((,body-name (,var)
-		,@body))
-	 (%enumerate-matches (pathname ,pathname)
-			     ,verify-existance
-			     #',body-name)
-	 ,result))))
-
-(defun %enumerate-matches (pathname verify-existance function)
-  (when (pathname-type pathname)
-    (unless (pathname-name pathname)
-      (error "Cannot supply a type without a name:~%  ~S" pathname)))
-  (when (and (integerp (pathname-version pathname))
-	     (member (pathname-type pathname) '(nil :unspecific)))
-    (error "Cannot supply a version without a type:~%  ~S" pathname))
-  (let ((directory (pathname-directory pathname)))
-    (if directory
-	(ecase (car directory)
-	  (:absolute
-	   (%enumerate-directories "/" (cdr directory) pathname
-				   verify-existance function))
-	  (:relative
-	   (%enumerate-directories "" (cdr directory) pathname
-				   verify-existance function)))
-	(%enumerate-files "" pathname verify-existance function))))
-
-(defun %enumerate-directories (head tail pathname verify-existance function)
-  (if tail
-      (let ((piece (car tail)))
-	(etypecase piece
-	  (simple-string
-	   (%enumerate-directories (concatenate 'string head piece "/")
-				   (cdr tail) pathname verify-existance
-				   function))
-	  (pattern
-	   (let ((dir (unix:open-dir head)))
-	     (when dir
-	       (unwind-protect
-		   (loop
-		     (let ((name (unix:read-dir dir)))
-		       (cond ((null name)
-			      (return))
-			     ((string= name "."))
-			     ((string= name ".."))
-			     ((pattern-matches piece name)
-			      (let ((subdir (concatenate 'string
-							 head name "/")))
-				(when (eq (unix:unix-file-kind subdir)
-					  :directory)
-				  (%enumerate-directories
-				   subdir (cdr tail) pathname verify-existance
-				   function)))))))
-		 (unix:close-dir dir)))))
-	  ((member :up)
-	   (%enumerate-directories (concatenate 'string head "../")
-				   (cdr tail) pathname verify-existance
-				   function))))
-      (%enumerate-files head pathname verify-existance function)))
-
-(defun %enumerate-files (directory pathname verify-existance function)
-  (let ((name (pathname-name pathname))
-	(type (pathname-type pathname))
-	(version (pathname-version pathname)))
-    (cond ((null name)
-	   (when (or (not verify-existance)
-		     (unix:unix-file-kind directory))
-	     (funcall function directory)))
-	  ((or (pattern-p name)
-	       (pattern-p type)
-	       (eq version :wild))
-	   (let ((dir (unix:open-dir directory)))
-	     (when dir
-	       (unwind-protect
-		   (loop
-		     (let ((file (unix:read-dir dir)))
-		       (if file
-			   (unless (or (string= file ".")
-				       (string= file ".."))
-			     (multiple-value-bind
-				 (file-name file-type file-version)
-				 (let ((*ignore-wildcards* t))
-				   (extract-name-type-and-version
-				    file 0 (length file)))
-			       (when (and (components-match file-name name)
-					  (components-match file-type type)
-					  (components-match file-version
-							    version))
-				 (funcall function
-					  (concatenate 'string
-						       directory
-						       file)))))
-			   (return))))
-		 (unix:close-dir dir)))))
-	  (t
-	   (let ((file (concatenate 'string directory name)))
-	     (unless (or (null type) (eq type :unspecific))
-	       (setf file (concatenate 'string file "." type)))
-	     (unless (member version '(nil  :newest :wild))
-	       (setf file (concatenate 'string file "."
-				       (quick-integer-to-string version))))
-	     (when (or (not verify-existance)
-		       (unix:unix-file-kind file))
-	       (funcall function file)))))))
-
-(defun quick-integer-to-string (n)
-  (declare (type integer 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)
-	       (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))))))
-
-
-;;;; UNIX-NAMESTRING -- public
-;;; 
-(defun unix-namestring (pathname &optional (for-input t))
-  "Convert PATHNAME into a string that can be used with UNIX system calls.
-   Search-lists and wild-cards are expanded."
-  (enumerate-search-list
-      (pathname pathname)
-    (collect ((names))
-      (enumerate-matches (name pathname nil :verify-existance for-input)
-	(names name))
-      (let ((names (names)))
-	(when names
-	  (when (cdr names)
-	    (error "~S is ambiguous:~{~%  ~A~}" pathname names))
-	  (return (car names)))))))
-
-
-;;;; TRUENAME and PROBE-FILE.
-
-;;; 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))
-
-;;; Probe-File  --  Public
-;;;
-;;; If PATHNAME exists, return it's truename, otherwise NIL.
-;;;
-(defun probe-file (pathname)
-  "Return a pathname which is the truename of the file if it exists, NIL
-  otherwise."
-  (let ((namestring (unix-namestring pathname t)))
-    (when (and namestring (unix:unix-file-kind namestring))
-      (let ((truename (unix:unix-resolve-links
-		       (unix:unix-maybe-prepend-current-directory
-			namestring))))
-	(when truename
-	  (let ((*ignore-wildcards* t))
-	    (pathname (unix:unix-simplify-pathname truename))))))))
-
-
-;;;; Other random operations.
-
-;;; Rename-File  --  Public
-;;;
-(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."
-  (let* ((original (truename file))
-	 (original-namestring (unix-namestring original t))
-	 (new-name (merge-pathnames new-name original))
-	 (new-namestring (unix-namestring new-name nil)))
-    (unless original-namestring
-      (error "~S doesn't exist." file))
-    (unless new-namestring
-      (error "~S can't be created." new-name))
-    (multiple-value-bind (res error)
-			 (unix:unix-rename original-namestring
-					   new-namestring)
-      (unless res
-	(error "Failed to rename ~A to ~A: ~A"
-	       original new-name (unix:get-unix-error-msg error)))
-      (when (streamp file)
-	(file-name file new-namestring))
-      (values new-name original (truename new-name)))))
-
-;;; Delete-File  --  Public
-;;;
-;;;    Delete the file, Man.
-;;;
-(defun delete-file (file)
-  "Delete the specified file."
-  (let ((namestring (unix-namestring file t)))
-    (when (streamp file)
-      (close file :abort t))
-    (unless namestring
-      (error "~S doesn't exist." file))
-
-    (multiple-value-bind (res err) (unix:unix-unlink namestring)
-      (unless res
-	(error "Could not delete ~A: ~A."
-	       namestring
-	       (unix:get-unix-error-msg err)))))
-  t)
-
-
-;;; User-Homedir-Pathname  --  Public
-;;;
-;;;    Return Home:, which is set up for us at initialization time.
-;;;
-(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:\"."
-  (declare (ignore host))
-  #p"home:")
-
-;;; File-Write-Date  --  Public
-;;;
-(defun file-write-date (file)
-  "Return file's creation date, or NIL if it doesn't exist."
-  (let ((name (unix-namestring file t)))
-    (when name
-      (multiple-value-bind
-	  (res dev ino mode nlink uid gid rdev size atime mtime)
-	  (unix:unix-stat name)
-	(declare (ignore dev ino mode nlink uid gid rdev size atime))
-	(when res
-	  (+ 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 ((name (unix-namestring (pathname file) t)))
-    (unless name
-      (error "~S doesn't exist." file))
-    (multiple-value-bind (winp dev ino mode nlink uid)
-			 (unix:unix-stat file)
-      (declare (ignore dev ino mode nlink))
-      (if winp (lookup-login-name uid)))))
-
-
-
-;;;; DIRECTORY.
-
-;;; DIRECTORY  --  public.
-;;; 
-(defun directory (pathname &key (all t) (check-for-subdirs t)
-			   (follow-links 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.  If :FOLLOW-LINKS is NIL,
-   then symblolic links in the result are not expanded.  This is not the
-   default because TRUENAME does follow links, and the result pathnames are
-   defined to be the TRUENAME of the pathname (the truename of a link may well
-   be in another directory.)"
-  (let ((results nil))
-    (enumerate-search-list
-	(pathname (merge-pathnames pathname
-				   (make-pathname :name :wild
-						  :type :wild
-						  :version :wild)))
-      (enumerate-matches (name pathname)
-	(when (or all
-		  (let ((slash (position #\/ name :from-end t)))
-		    (or (null slash)
-			(= (1+ slash) (length name))
-			(char/= (schar name (1+ slash)) #\.))))
-	  (push name results))))
-    (let ((*ignore-wildcards* t))
-      (mapcar #'(lambda (name)
-		  (let ((name (if (and check-for-subdirs
-				       (eq (unix:unix-file-kind name)
-					   :directory))
-				  (concatenate 'string name "/")
-				  name)))
-		    (if follow-links (truename name) (pathname name))))
-	      (sort (delete-duplicates results :test #'string=) #'string<)))))
-
-
-;;;; Printing directories.
-
-;;; 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."
-  (let ((*standard-output* (out-synonym-of stream))
-	(pathname pathname))
-    (if verbose
-	(print-directory-verbose pathname all return-list)
-	(print-directory-formatted pathname all return-list))))
-
-(defun print-directory-verbose (pathname all return-list)
-  (let ((contents (directory pathname :all all :check-for-subdirs nil
-			     :follow-links nil))
-	(result nil))
-    (format t "Directory of ~A :~%" (namestring pathname))
-    (dolist (file contents)
-      (let* ((namestring (unix-namestring file))
-	     (tail (subseq namestring
-			   (1+ (or (position #\/ namestring
-					     :from-end t
-					     :test #'char=)
-				   -1)))))
-	(multiple-value-bind 
-	    (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime)
-	    (unix:unix-stat namestring)
-	  (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)
-			   tail
-			   (= (logand mode unix:s-ifmt) unix:s-ifdir))))
-		(t (format t "Couldn't stat ~A -- ~A.~%"
-			   tail
-			   (unix:get-unix-error-msg dev-or-err))))
-	  (when return-list
-	    (push (if (= (logand mode unix:s-ifmt) unix:s-ifdir)
-		      (pathname (concatenate 'string namestring "/"))
-		      file)
-		  result)))))
-    (nreverse result)))
-
-(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 (directory pathname :all all :follow-links nil)))
-    (declare (list names) (fixnum max-len cnt))
-    ;;
-    ;; Get the data.
-    (dolist (file result)
-      (let* ((name (unix-namestring file))
-	     (length (length name))
-	     (end (if (and (plusp length)
-			   (char= (schar name (1- length)) #\/))
-		      (1- length)
-		      length))
-	     (slash-name (subseq name
-				 (1+ (or (position #\/ name
-						   :from-end t
-						   :end end
-						   :test #'char=)
-					 -1))))
-	     (len (length slash-name)))
-	(declare (simple-string slash-name)
-		 (fixnum len))
-	(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 :~%" (namestring pathname))
-      (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))
-		(dotimes (i (- col-width (length (the simple-string name))))
-		  (write-char #\space))))))
-	(terpri)))
-    (when return-list
-      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))))))))))))
-
-
-;;;; File completion.
-
-;;; COMPLETE-FILE -- Public
-;;;
-(defun complete-file (pathname &key (defaults *default-pathname-defaults*)
-			       ignore-types)
-  (let ((files (directory (complete-file-directory-arg pathname defaults)
-			  :check-for-subdirs nil
-			  :follow-links nil)))
-    (cond ((null files)
-	   (values nil nil))
-	  ((null (cdr files))
-	   (values (merge-pathnames (file-namestring (car files))
-				    pathname)
-		   t))
-	  (t
-	   (let ((good-files
-		  (delete-if #'(lambda (pathname)
-				 (and (simple-string-p
-				       (pathname-type pathname))
-				      (member (pathname-type pathname)
-					      ignore-types
-					      :test #'string=)))
-			     files)))
-	     (cond ((null good-files))
-		   ((null (cdr good-files))
-		    (return-from complete-file
-				 (values (merge-pathnames (file-namestring
-							   (car good-files))
-							  pathname)
-					 t)))
-		   (t
-		    (setf files good-files)))
-	     (let ((common (file-namestring (car files))))
-	       (dolist (file (cdr files))
-		 (let ((name (file-namestring file)))
-		   (dotimes (i (min (length common) (length name))
-			       (when (< (length name) (length common))
-				 (setf common name)))
-		     (unless (char= (schar common i) (schar name i))
-		       (setf common (subseq common 0 i))
-		       (return)))))
-	       (values (merge-pathnames common pathname)
-		       nil)))))))
-
-;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal.
-;;;
-(defun complete-file-directory-arg (pathname defaults)
-  (let* ((pathname (merge-pathnames pathname (directory-namestring defaults)))
-	 (type (pathname-type pathname)))
-    (flet ((append-multi-char-wild (thing)
-	     (etypecase thing
-	       (null :wild)
-	       (pattern
-		(make-pattern (append (pattern-pieces thing)
-				      (list :multi-char-wild))))
-	       (simple-string
-		(make-pattern (list thing :multi-char-wild))))))
-      (if (or (null type) (eq type :unspecific))
-	  ;; There is no type.
-	  (make-pathname :defaults pathname
-	    :name (append-multi-char-wild (pathname-name pathname))
-	    :type :wild)
-	  ;; There already is a type, so just extend it.
-	  (make-pathname :defaults pathname
-	    :name (pathname-name pathname)
-	    :type (append-multi-char-wild (pathname-type pathname)))))))
-
-;;; Ambiguous-Files  --  Public
-;;;
-(defun ambiguous-files (pathname
-			&optional (defaults *default-pathname-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."
-  (directory (complete-file-directory-arg pathname defaults)
-	     :follow-links nil
-	     :check-for-subdirs 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."
-  (let ((name (unix-namestring name nil)))
-    (cond ((null name)
-	   nil)
-	  ((unix:unix-file-kind name)
-	   (values (unix:unix-access name unix:w_ok)))
-	  (t
-	   (values
-	    (unix:unix-access (subseq name
-				      0
-				      (or (position #\/ name :from-end t)
-					  0))
-			      (logior unix:w_ok unix: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)))
-
-
-;;; Default-Directory  --  Public
-;;;
-(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)
-		       (unix:unix-current-directory)
-    (if gr
-	(let ((*ignore-wildcards* t))
-	  (pathname (concatenate 'simple-string dir-or-error "/")))
-	(error dir-or-error))))
-
-;;; %Set-Default-Directory  --  Internal
-;;; 
-(defun %set-default-directory (new-val)
-  (let ((namestring (unix-namestring new-val t)))
-    (unless namestring
-      (error "~S doesn't exist." new-val))
-    (multiple-value-bind (gr error)
-			 (unix:unix-chdir namestring)
-      (if gr
-	  (setf (search-list "default:") (default-directory))
-	  (error (unix:get-unix-error-msg error))))
-    new-val))
-;;;
-(defsetf default-directory %set-default-directory)
-
-(defun filesys-init ()
-  (setf *default-pathname-defaults*
-	(%make-pathname *unix-host* nil nil nil nil :newest))
-  (setf (search-list "default:") (default-directory))
-  nil)
diff --git a/code/final.lisp b/code/final.lisp
deleted file mode 100644
index aa3aeac4861eed585aec58bd7c023c0dfc9ec9da..0000000000000000000000000000000000000000
--- a/code/final.lisp
+++ /dev/null
@@ -1,60 +0,0 @@
-;;; -*- Package: EXTENSIONS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/final.lisp,v 1.1 1991/11/16 01:59:18 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Finalization based on weak pointers.  Written by William Lott, but
-;;; the idea really was Chris Hoover's.
-;;;
-
-(in-package "EXTENSIONS")
-
-(export '(finalize cancel-finalization))
-
-(defvar *objects-pending-finalization* nil)
-
-(defun finalize (object function)
-  "Arrage for FUNCTION to be called when there are no more references to
-   OBJECT."
-  (declare (type function function))
-  (system:without-gcing
-   (push (cons (make-weak-pointer object) function)
-	 *objects-pending-finalization*))
-  object)
-
-(defun cancel-finalization (object)
-  "Cancel any finalization registers for OBJECT."
-  (when object
-    ;; We check to make sure object isn't nil because if there are any
-    ;; broken weak pointers, their value will show up as nil.  Therefore,
-    ;; they would be deleted from the list, but not finalized.  Broken
-    ;; weak pointers shouldn't be left in the list, but why take chances?
-    (system:without-gcing
-     (setf *objects-pending-finalization*
-	   (delete object *objects-pending-finalization*
-		   :key #'(lambda (pair)
-			    (values (weak-pointer-value (car pair))))))))
-  nil)
-
-(defun finalize-corpses ()
-  (setf *objects-pending-finalization*
-	(delete-if #'(lambda (pair)
-		       (multiple-value-bind
-			   (object valid)
-			   (weak-pointer-value (car pair))
-			 (declare (ignore object))
-			 (unless valid
-			   (funcall (cdr pair))
-			   t)))
-		   *objects-pending-finalization*))
-  nil)
-
-(pushnew 'finalize-corpses *after-gc-hooks*)
diff --git a/code/float-trap.lisp b/code/float-trap.lisp
deleted file mode 100644
index 093f64ce58e5cdfc771a524389a87a540d2f06cc..0000000000000000000000000000000000000000
--- a/code/float-trap.lisp
+++ /dev/null
@@ -1,175 +0,0 @@
-;;; -*- Package: VM -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.7 1992/12/10 01:26:41 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains stuff for controlling floating point traps.  It is
-;;; IEEE float specific, but should work for pretty much any FPU where the
-;;; state fits in one word and exceptions are represented by bits being set.
-;;;
-;;; Author: Rob MacLachlan
-;;; 
-(in-package "VM")
-(export '(current-float-trap floating-point-modes sigfpe-handler))
-(in-package "EXTENSIONS")
-(export '(set-floating-point-modes get-floating-point-modes))
-(in-package "VM")
-
-(eval-when (compile load eval)
-
-(defconstant float-trap-alist
-  (list (cons :underflow float-underflow-trap-bit)
-	(cons :overflow float-overflow-trap-bit)
-	(cons :inexact float-inexact-trap-bit)
-	(cons :invalid float-invalid-trap-bit)
-	(cons :divide-by-zero float-divide-by-zero-trap-bit)))
-
-;;; FLOAT-TRAP-MASK  --  Internal
-;;;
-;;;    Return a mask with all the specified float trap bits set.
-;;;
-(defun float-trap-mask (names)
-  (reduce #'logior
-	  (mapcar #'(lambda (x)
-		      (or (cdr (assoc x float-trap-alist))
-			  (error "Unknown float trap kind: ~S." x)))
-		  names)))
-
-(defconstant rounding-mode-alist
-  (list (cons :nearest float-round-to-nearest)
-	(cons :zero float-round-to-zero)
-	(cons :positive-infinity float-round-to-positive)
-	(cons :negative-infinity float-round-to-negative)))
-  
-); Eval-When (Compile Load Eval)
-
-
-;;; Interpreter stubs.
-;;;
-(defun floating-point-modes () (floating-point-modes))
-(defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
-
-
-;;; SET-FLOATING-POINT-MODES  --  Public
-;;;
-(defun set-floating-point-modes (&key (traps nil traps-p)
-				      (rounding-mode nil round-p)
-				      (current-exceptions nil current-x-p)
-				      (accrued-exceptions nil accrued-x-p)
-				      (fast-mode nil fast-mode-p))
-  "This function sets options controlling the floating-point hardware.  If a
-  keyword is not supplied, then the current value is preserved.  Possible
-  keywords:
-
-   :TRAPS
-       A list of the exception conditions that should cause traps.  Possible
-       exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
-       :DIVIDE-BY-ZERO.  Initially all traps except :INEXACT are enabled.
-
-   :ROUNDING-MODE
-       The rounding mode to use when the result is not exact.  Possible values
-       are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and :ZERO.
-       Initially, the rounding mode is :NEAREST.
-
-   :CURRENT-EXCEPTIONS
-   :ACCRUED-EXCEPTIONS
-       These arguments allow setting of the exception flags.  The main use is
-       setting the accrued exceptions to NIL to clear them.
-
-   :FAST-MODE
-       Set the hardware's \"fast mode\" flag, if any.  When set, IEEE
-       conformance or debuggability may be impaired.  Some machines may not
-       have this feature, in which case the value is always NIL.
-
-   GET-FLOATING-POINT-MODES may be used to find the floating point modes
-   currently in effect."
-  (let ((modes (floating-point-modes)))
-    (when traps-p
-      (setf (ldb float-traps-byte modes) (float-trap-mask traps)))
-    (when round-p
-      (setf (ldb float-rounding-mode modes)
-	    (or (cdr (assoc rounding-mode rounding-mode-alist))
-		(error "Unknown rounding mode: ~S." rounding-mode))))
-    (when current-x-p
-      (setf (ldb float-exceptions-byte modes)
-	    (float-trap-mask current-exceptions)))
-    (when accrued-x-p
-      (setf (ldb float-sticky-bits modes)
-	    (float-trap-mask accrued-exceptions)))
-    (when fast-mode-p
-      (if fast-mode
-	  (setq modes (logior float-fast-bit modes))
-	  (setq modes (logand (lognot float-fast-bit) modes))))
-    (setf (floating-point-modes) modes))
-    
-  (values))
-
-
-;;; GET-FLOATING-POINT-MODES  --  Public
-;;;
-(defun get-floating-point-modes ()
-  "This function returns a list representing the state of the floating point
-  modes.  The list is in the same format as the keyword arguments to
-  SET-FLOATING-POINT-MODES, i.e. 
-      (apply #'set-floating-point-modes (get-floating-point-modes))
-
-  sets the floating point modes to their current values (and thus is a no-op)."
-  (flet ((exc-keys (bits)
-	   (macrolet ((frob ()
-			`(collect ((res))
-			   ,@(mapcar #'(lambda (x)
-					 `(when (logtest bits ,(cdr x))
-					    (res ',(car x))))
-				     float-trap-alist)
-			   (res))))
-	     (frob))))
-    (let ((modes (floating-point-modes))) 
-      `(:traps ,(exc-keys (ldb float-traps-byte modes))
-	:rounding-mode ,(car (rassoc (ldb float-rounding-mode modes)
-				     rounding-mode-alist))
-	:current-exceptions ,(exc-keys (ldb float-exceptions-byte modes))
-	:accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes))
-	:fast-mode ,(logtest float-fast-bit modes)))))
-
-  
-;;; CURRENT-FLOAT-TRAP  --  Interface
-;;;
-(defmacro current-float-trap (&rest traps)
-  "Current-Float-Trap Trap-Name*
-  Return true if any of the named traps are currently trapped, false
-  otherwise."
-  `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
-		       (floating-point-modes)))))
-
-
-;;; SIGFPE-HANDLER  --  Interface
-;;;
-;;;    Signal the appropriate condition when we get a floating-point error.
-;;;
-(defun sigfpe-handler (signal code scp)
-  (declare (ignore signal code)
-	   (type system-area-pointer scp))
-  (let* ((modes (sigcontext-floating-point-modes
-		 (alien:sap-alien scp (* unix:sigcontext))))
-	 (traps (logand (ldb float-exceptions-byte modes)
-			(ldb float-traps-byte modes))))
-    (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
-	   (error 'division-by-zero))
-	  ((not (zerop (logand float-invalid-trap-bit traps)))
-	   (error 'floating-point-invalid-operation))
-	  ((not (zerop (logand float-overflow-trap-bit traps)))
-	   (error 'floating-point-overflow))
-	  ((not (zerop (logand float-underflow-trap-bit traps)))
-	   (error 'floating-point-underflow))
-	  ((not (zerop (logand float-inexact-trap-bit traps)))
-	   (error 'ext:floating-point-inexact))
-	  (t
-	   (error "SIGFPE with no exceptions currently enabled?")))))
diff --git a/code/float.lisp b/code/float.lisp
deleted file mode 100644
index 69fd9298591879b58ca4c448019e00d1283eca0b..0000000000000000000000000000000000000000
--- a/code/float.lisp
+++ /dev/null
@@ -1,844 +0,0 @@
-;;; -*- Mode: Lisp; Package: KERNEL; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.10 1992/12/10 01:28:22 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the definitions of float specific number support
-;;; (other than irrational stuff, which is in irrat.)  There is code in here
-;;; that assumes there are only two float formats: IEEE single and double.
-;;;
-;;; Author: Rob MacLachlan
-;;; 
-(in-package "KERNEL")
-(export '(%unary-truncate %unary-round))
-
-(in-package "LISP")
-(export '(least-positive-normalized-short-float
-	  least-positive-normalized-single-float
-	  least-positive-normalized-double-float
-	  least-positive-normalized-long-float
-	  least-negative-normalized-short-float
-	  least-negative-normalized-single-float
-	  least-negative-normalized-double-float
-	  least-negative-normalized-long-float
-	  least-positive-single-float
-	  least-positive-short-float
-	  least-negative-single-float
-	  least-negative-short-float
-	  least-positive-double-float
-	  least-positive-long-float
-	  least-negative-double-float
-	  least-negative-long-float
-	  most-positive-single-float
-	  most-positive-short-float
-	  most-negative-single-float
-	  most-negative-short-float
-	  most-positive-double-float
-	  most-positive-long-float
-	  most-negative-double-float
-	  most-negative-long-float))
-
-(in-package "EXTENSIONS")
-(export '(single-float-positive-infinity short-float-positive-infinity
-	  double-float-positive-infinity long-float-positive-infinity
-	  single-float-negative-infinity short-float-negative-infinity
-	  double-float-negative-infinity long-float-negative-infinity
-	  set-floating-point-modes float-denormalized-p float-nan-p
-	  float-trapping-nan-p float-infinity-p))
-
-(in-package "KERNEL")
-
-
-;;;; Utilities:
-
-;;; SINGLE-FROM-BITS, DOUBLE-FROM-BITS  --  Internal
-;;;
-;;;    These functions let us create floats from bits with the significand
-;;; uniformly represented as an integer.  This is less efficient for double
-;;; floats, but is more convenient when making special values, etc.
-;;;
-(defun single-from-bits (sign exp sig)
-  (declare (type bit sign) (type (unsigned-byte 24) sig)
-	   (type (unsigned-byte 8) exp))
-  (make-single-float
-   (dpb exp vm:single-float-exponent-byte
-	(dpb sig vm:single-float-significand-byte
-	     (if (zerop sign) 0 -1)))))
-;;;
-(defun double-from-bits (sign exp sig)
-  (declare (type bit sign) (type (unsigned-byte 53) sig)
-	   (type (unsigned-byte 11) exp))
-  (make-double-float (dpb exp vm:double-float-exponent-byte
-			  (dpb (ash sig -32) vm:double-float-significand-byte
-			       (if (zerop sign) 0 -1)))
-		     (ldb (byte 32 0) sig)))
-					
-
-;;;; Float parameters:
-
-(defconstant least-positive-single-float (single-from-bits 0 0 1))
-(defconstant least-positive-short-float least-positive-single-float)
-(defconstant least-negative-single-float (single-from-bits 1 0 1))
-(defconstant least-negative-short-float least-negative-single-float)
-(defconstant least-positive-double-float (double-from-bits 0 0 1))
-(defconstant least-positive-long-float least-positive-double-float)
-(defconstant least-negative-double-float (double-from-bits 1 0 1))
-(defconstant least-negative-long-float least-negative-double-float)
-
-(defconstant least-positive-normalized-single-float
-  (single-from-bits 0 vm:single-float-normal-exponent-min 0))
-(defconstant least-positive-normalized-short-float
-  least-positive-normalized-single-float)
-(defconstant least-negative-normalized-single-float
-  (single-from-bits 1 vm:single-float-normal-exponent-min 0))
-(defconstant least-negative-normalized-short-float
-  least-negative-normalized-single-float)
-(defconstant least-positive-normalized-double-float
-  (double-from-bits 0 vm:double-float-normal-exponent-min 0))
-(defconstant least-positive-normalized-long-float
-  least-positive-normalized-double-float)
-(defconstant least-negative-normalized-double-float
-  (double-from-bits 1 vm:double-float-normal-exponent-min 0))
-(defconstant least-negative-normalized-long-float
-  least-negative-normalized-double-float)
-
-(defconstant most-positive-single-float
-  (single-from-bits 0 vm:single-float-normal-exponent-max
-		    (ldb vm:single-float-significand-byte -1)))
-(defconstant most-positive-short-float most-positive-single-float)
-(defconstant most-negative-single-float
-  (single-from-bits 1 vm:single-float-normal-exponent-max
-		    (ldb vm:single-float-significand-byte -1)))
-(defconstant most-negative-short-float most-negative-single-float)
-(defconstant most-positive-double-float
-  (double-from-bits 0 vm:double-float-normal-exponent-max
-		    (ldb vm:double-float-significand-byte -1)))
-(defconstant most-positive-long-float most-positive-double-float)
-(defconstant most-negative-double-float
-  (double-from-bits 1 vm:double-float-normal-exponent-max
-		    (ldb vm:double-float-significand-byte -1)))
-(defconstant most-negative-long-float most-negative-double-float)
-
-(defconstant single-float-positive-infinity
-  (single-from-bits 0 (1+ vm:single-float-normal-exponent-max) 0))
-(defconstant short-float-positive-infinity single-float-positive-infinity)
-(defconstant single-float-negative-infinity
-  (single-from-bits 1 (1+ vm:single-float-normal-exponent-max) 0))
-(defconstant short-float-negative-infinity single-float-negative-infinity)
-(defconstant double-float-positive-infinity
-  (double-from-bits 0 (1+ vm:double-float-normal-exponent-max) 0))
-(defconstant long-float-positive-infinity double-float-positive-infinity)
-(defconstant double-float-negative-infinity
-  (double-from-bits 1 (1+ vm:double-float-normal-exponent-max) 0))
-(defconstant long-float-negative-infinity double-float-negative-infinity)
-
-(defconstant single-float-epsilon
-  (single-from-bits 0 (- vm:single-float-bias (1- vm:single-float-digits)) 1))
-(defconstant short-float-epsilon single-float-epsilon)
-(defconstant single-float-negative-epsilon
-  (single-from-bits 0 (- vm:single-float-bias vm:single-float-digits) 1))
-(defconstant short-float-negative-epsilon single-float-negative-epsilon)
-(defconstant double-float-epsilon
-  (double-from-bits 0 (- vm:double-float-bias (1- vm:double-float-digits)) 1))
-(defconstant long-float-epsilon double-float-epsilon)
-(defconstant double-float-negative-epsilon
-  (double-from-bits 0 (- vm:double-float-bias vm:double-float-digits) 1))
-(defconstant long-float-negative-epsilon double-float-negative-epsilon)
-
-
-;;;; Float predicates and environment query:
-
-(proclaim '(maybe-inline float-denormalized-p float-infinity-p float-nan-p
-			 float-trapping-nan-p))
-
-;;; FLOAT-DENORMALIZED-P  --  Public
-;;;
-(defun float-denormalized-p (x)
-  "Return true if the float X is denormalized."
-  (number-dispatch ((x float))
-    ((single-float)
-     (and (zerop (ldb vm:single-float-exponent-byte (single-float-bits x)))
-	  (not (zerop x))))
-    ((double-float)
-     (and (zerop (ldb vm:double-float-exponent-byte
-		      (double-float-high-bits x)))
-	  (not (zerop x))))))
-
-(macrolet ((frob (name doc single double)
-	     `(defun ,name (x)
-		,doc
-		(number-dispatch ((x float))
-		  ((single-float)
-		   (let ((bits (single-float-bits x)))
-		     (and (> (ldb vm:single-float-exponent-byte bits)
-			     vm:single-float-normal-exponent-max)
-			  ,single)))
-		  ((double-float)
-		   (let ((hi (double-float-high-bits x))
-			 (lo (double-float-low-bits x)))
-		     (and (> (ldb vm:double-float-exponent-byte hi)
-			     vm:double-float-normal-exponent-max)
-			  ,double)))))))
-
-  (frob float-infinity-p "Return true if the float X is an infinity (+ or -)."
-    (zerop (ldb vm:single-float-significand-byte bits))
-    (and (zerop (ldb vm:double-float-significand-byte hi))
-	 (zerop lo)))
-
-  (frob float-nan-p "Return true if the float X is a NaN (Not a Number)."
-    (not (zerop (ldb vm:single-float-significand-byte bits)))
-    (or (not (zerop (ldb vm:double-float-significand-byte hi)))
-	(not (zerop lo))))
-
-  (frob float-trapping-nan-p
-    "Return true if the float X is a trapping NaN (Not a Number)."
-    (not (zerop (logand (ldb vm:single-float-significand-byte bits)
-			vm:single-float-trapping-nan-bit)))
-    (progn
-      lo; ignore
-      (not (zerop (logand (ldb vm:double-float-significand-byte hi)
-			  vm:double-float-trapping-nan-bit))))))
-
-
-;;; FLOAT-PRECISION  --  Public
-;;;
-;;;    If denormalized, use a subfunction from INTEGER-DECODE-FLOAT to find the
-;;; actual exponent (and hence how denormalized it is), otherwise we just
-;;; return the number of digits or 0.
-;;;
-(proclaim '(maybe-inline float-precision))
-(defun float-precision (f)
-  "Returns a non-negative number of significant digits in it's float argument.
-  Will be less than FLOAT-DIGITS if denormalized or zero."
-  (macrolet ((frob (digits bias decode)
-	       `(cond ((zerop f) 0)
-		      ((float-denormalized-p f)
-		       (multiple-value-bind (ignore exp)
-					    (,decode f)
-			 (declare (ignore ignore))
-			 (truly-the fixnum
-				    (+ ,digits (1- ,digits) ,bias exp))))
-		      (t
-		       ,digits))))
-    (number-dispatch ((f float))
-      ((single-float)
-       (frob vm:single-float-digits vm:single-float-bias
-	 integer-decode-single-denorm))
-      ((double-float)
-       (frob vm:double-float-digits vm:double-float-bias
-	 integer-decode-double-denorm)))))
-
-
-(defun float-sign (float1 &optional (float2 (float 1 float1)))
-  "Returns a floating-point number that has the same sign as
-   float1 and, if float2 is given, has the same absolute value
-   as float2."
-  (declare (float float1 float2))
-  (float-sign float1 float2))
-
-(defun float-format-digits (format)
-  (ecase format
-    ((short-float single-float) vm:single-float-digits)
-    ((double-float long-float) vm:double-float-digits)))
-
-(proclaim '(inline float-digits float-radix))
-
-(defun float-digits (f)
-  "Returns a non-negative number of radix-b digits used in the
-   representation of it's argument.  See Common Lisp: The Language
-   by Guy Steele for more details."
-  (number-dispatch ((f float))
-    ((single-float) vm:single-float-digits)
-    ((double-float) vm:double-float-digits)))
-
-(defun float-radix (f)
-  "Returns (as an integer) the radix b of its floating-point
-   argument."
-  (declare (ignore f))
-  2)
-
-
-
-;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT:
-
-(proclaim '(maybe-inline integer-decode-single-float
-			 integer-decode-double-float))
-
-;;; INTEGER-DECODE-SINGLE-DENORM  --  Internal
-;;;
-;;;    Handle the denormalized case of INTEGER-DECODE-FLOAT for SINGLE-FLOAT.
-;;;
-(defun integer-decode-single-denorm (x)
-  (declare (type single-float x))
-  (let* ((bits (single-float-bits (abs x)))
-	 (sig (ash (ldb vm:single-float-significand-byte bits) 1))
-	 (extra-bias 0))
-    (declare (type (unsigned-byte 24) sig)
-	     (type (integer 0 23) extra-bias))
-    (loop
-      (unless (zerop (logand sig vm:single-float-hidden-bit))
-	(return))
-      (setq sig (ash sig 1))
-      (incf extra-bias))
-    (values sig
-	    (- (- vm:single-float-bias) vm:single-float-digits extra-bias)
-	    (if (minusp (float-sign x)) -1 1))))
-
-
-;;; INTEGER-DECODE-SINGLE-FLOAT  --  Internal
-;;;
-;;;    Handle the single-float case of INTEGER-DECODE-FLOAT.  If an infinity or
-;;; NAN, error.  If a denorm, call i-d-s-DENORM to handle it.
-;;;
-(defun integer-decode-single-float (x)
-  (declare (single-float x))
-  (let* ((bits (single-float-bits (abs x)))
-	 (exp (ldb vm:single-float-exponent-byte bits))
-	 (sig (ldb vm:single-float-significand-byte bits))
-	 (sign (if (minusp (float-sign x)) -1 1))
-	 (biased (- exp vm:single-float-bias vm:single-float-digits)))
-    (declare (fixnum biased))
-    (unless (<= exp vm:single-float-normal-exponent-max)
-      (error "Can't decode NAN or infinity: ~S." x))
-    (cond ((and (zerop exp) (zerop sig))
-	   (values 0 biased sign))
-	  ((< exp vm:single-float-normal-exponent-min)
-	   (integer-decode-single-denorm x))
-	  (t
-	   (values (logior sig vm:single-float-hidden-bit) biased sign)))))
-
-
-;;; INTEGER-DECODE-DOUBLE-DENORM  --  Internal
-;;;
-;;;    Like INTEGER-DECODE-SINGLE-DENORM, only doubly so.
-;;;
-(defun integer-decode-double-denorm (x)
-  (declare (type double-float x))
-  (let* ((high-bits (double-float-high-bits (abs x)))
-	 (sig-high (ldb vm:double-float-significand-byte high-bits))
-	 (low-bits (double-float-low-bits x))
-	 (sign (if (minusp (float-sign x)) -1 1))
-	 (biased (- (- vm:double-float-bias) vm:double-float-digits)))
-    (if (zerop sig-high)
-	(let ((sig low-bits)
-	      (extra-bias (- vm:double-float-digits 33))
-	      (bit (ash 1 31)))
-	  (declare (type (unsigned-byte 32) sig) (fixnum extra-bias))
-	  (loop
-	    (unless (zerop (logand sig bit)) (return))
-	    (setq sig (ash sig 1))
-	    (incf extra-bias))
-	  (values (ash sig (- vm:double-float-digits 32))
-		  (truly-the fixnum (- biased extra-bias))
-		  sign))
-	(let ((sig (ash sig-high 1))
-	      (extra-bias 0))
-	  (declare (type (unsigned-byte 32) sig) (fixnum extra-bias))
-	  (loop
-	    (unless (zerop (logand sig vm:double-float-hidden-bit))
-	      (return))
-	    (setq sig (ash sig 1))
-	    (incf extra-bias))
-	  (values (logior (ash sig 32) (ash low-bits (1- extra-bias)))
-		  (truly-the fixnum (- biased extra-bias))
-		  sign)))))
-
-
-;;; INTEGER-DECODE-DOUBLE-FLOAT  --  Internal
-;;;
-;;;    Like INTEGER-DECODE-SINGLE-FLOAT, only doubly so.
-;;;
-(defun integer-decode-double-float (x)
-  (declare (double-float x))
-  (let* ((abs (abs x))
-	 (hi (double-float-high-bits abs))
-	 (lo (double-float-low-bits abs))
-	 (exp (ldb vm:double-float-exponent-byte hi))
-	 (sig (ldb vm:double-float-significand-byte hi))
-	 (sign (if (minusp (float-sign x)) -1 1))
-	 (biased (- exp vm:double-float-bias vm:double-float-digits)))
-    (declare (fixnum biased))
-    (unless (<= exp vm:double-float-normal-exponent-max)
-      (error "Can't decode NAN or infinity: ~S." x))
-    (cond ((and (zerop exp) (zerop sig) (zerop lo))
-	   (values 0 biased sign))
-	  ((< exp vm:double-float-normal-exponent-min)
-	   (integer-decode-double-denorm x))
-	  (t
-	   (values
-	    (logior (ash (logior (ldb vm:double-float-significand-byte hi)
-				 vm:double-float-hidden-bit)
-			 32)
-		    lo)
-	    biased sign)))))
-
-
-;;; INTEGER-DECODE-FLOAT  --  Public
-;;;
-;;;    Dispatch to the correct type-specific i-d-f function.
-;;;
-(defun integer-decode-float (x)
-  "Returns three values:
-   1) an integer representation of the significand.
-   2) the exponent for the power of 2 that the significand must be multiplied
-      by to get the actual value.  This differs from the DECODE-FLOAT exponent
-      by FLOAT-DIGITS, since the significand has been scaled to have all its
-      digits before the radix point.
-   3) -1 or 1 (i.e. the sign of the argument.)"
-  (number-dispatch ((x float))
-    ((single-float)
-     (integer-decode-single-float x))
-    ((double-float)
-     (integer-decode-double-float x))))
-
-
-(proclaim '(maybe-inline decode-single-float decode-double-float))
-
-;;; DECODE-SINGLE-DENORM  --  Internal
-;;;
-;;;    Handle the denormalized case of DECODE-SINGLE-FLOAT.  We call
-;;; INTEGER-DECODE-SINGLE-DENORM and then make the result into a float.
-;;;
-(defun decode-single-denorm (x)
-  (declare (type single-float x))
-  (multiple-value-bind (sig exp sign)
-		       (integer-decode-single-denorm x)
-    (values (make-single-float
-	     (dpb sig vm:single-float-significand-byte
-		  (dpb vm:single-float-bias vm:single-float-exponent-byte 0)))
-	    (truly-the fixnum (+ exp vm:single-float-digits))
-	    (float sign x))))
-
-
-;;; DECODE-SINGLE-FLOAT  --  Internal
-;;;
-;;;    Handle the single-float case of DECODE-FLOAT.  If an infinity or NAN,
-;;; error.  If a denorm, call d-s-DENORM to handle it.
-;;;
-(defun decode-single-float (x)
-  (declare (single-float x))
-  (let* ((bits (single-float-bits (abs x)))
-	 (exp (ldb vm:single-float-exponent-byte bits))
-	 (sign (float-sign x))
-	 (biased (truly-the single-float-exponent
-			    (- exp vm:single-float-bias))))
-    (unless (<= exp vm:single-float-normal-exponent-max) 
-      (error "Can't decode NAN or infinity: ~S." x))
-    (cond ((zerop x)
-	   (values 0.0f0 biased sign))
-	  ((< exp vm:single-float-normal-exponent-min)
-	   (decode-single-denorm x))
-	  (t
-	   (values (make-single-float
-		    (dpb vm:single-float-bias
-			 vm:single-float-exponent-byte
-			 bits))
-		   biased sign)))))
-
-
-;;; DECODE-DOUBLE-DENORM  --  Internal
-;;;
-;;;    Like DECODE-SINGLE-DENORM, only doubly so.
-;;; 
-(defun decode-double-denorm (x)
-  (declare (double-float x))
-  (multiple-value-bind (sig exp sign)
-		       (integer-decode-double-denorm x)
-    (values (make-double-float
-	     (dpb (logand (ash sig -32) (lognot vm:double-float-hidden-bit))
-		  vm:double-float-significand-byte
-		  (dpb vm:double-float-bias vm:double-float-exponent-byte 0))
-	     (ldb (byte 32 0) sig))
-	    (truly-the fixnum (+ exp vm:double-float-digits))
-	    (float sign x))))
-
-
-;;; DECODE-DOUBLE-FLOAT  --  Public
-;;;
-;;;    Like DECODE-SINGLE-FLOAT, only doubly so.
-;;;
-(defun decode-double-float (x)
-  (declare (double-float x))
-  (let* ((abs (abs x))
-	 (hi (double-float-high-bits abs))
-	 (lo (double-float-low-bits abs))
-	 (exp (ldb vm:double-float-exponent-byte hi))
-	 (sign (float-sign x))
-	 (biased (truly-the double-float-exponent
-			    (- exp vm:double-float-bias))))
-    (unless (<= exp vm:double-float-normal-exponent-max)
-      (error "Can't decode NAN or infinity: ~S." x))
-    (cond ((zerop x)
-	   (values 0.0d0 biased sign))
-	  ((< exp vm:double-float-normal-exponent-min)
-	   (decode-double-denorm x))
-	  (t
-	   (values (make-double-float
-		    (dpb vm:double-float-bias vm:double-float-exponent-byte hi)
-		    lo)
-		   biased sign)))))
-
-
-;;; DECODE-FLOAT  --  Public
-;;;
-;;;    Dispatch to the appropriate type-specific function.
-;;;
-(defun decode-float (f)
-  "Returns three values:
-   1) a floating-point number representing the significand.  This is always
-      between 0.5 (inclusive) and 1.0 (exclusive).
-   2) an integer representing the exponent.
-   3) -1.0 or 1.0 (i.e. the sign of the argument.)"
-  (number-dispatch ((f float))
-    ((single-float)
-     (decode-single-float f))
-    ((double-float)
-     (decode-double-float f))))
-
-
-;;;; SCALE-FLOAT:
-
-(proclaim '(maybe-inline scale-single-float scale-double-float))
-
-;;; SCALE-FLOAT-MAYBE-UNDERFLOW  --  Internal
-;;;
-;;;    Handle float scaling where the X is denormalized or the result is
-;;; denormalized or underflows to 0.
-;;;
-(defun scale-float-maybe-underflow (x exp)
-  (multiple-value-bind (sig old-exp)
-		       (integer-decode-float x)
-    (let* ((digits (float-digits x))
-	   (new-exp (+ exp old-exp digits
-		       (etypecase x
-			 (single-float vm:single-float-bias)
-			 (double-float vm:double-float-bias))))
-	   (sign (if (minusp (float-sign x)) 1 0)))
-      (cond
-       ((< new-exp
-	   (etypecase x
-	     (single-float vm:single-float-normal-exponent-min)
-	     (double-float vm:double-float-normal-exponent-min)))
-	(when (vm:current-float-trap :inexact)
-	  (error 'floating-point-inexact :operation 'scale-float
-		 :operands (list x exp)))
-	(when (vm:current-float-trap :underflow)
-	  (error 'floating-point-underflow :operation 'scale-float
-		 :operands (list x exp)))
-	(let ((shift (1- new-exp)))
-	  (if (< shift (- (1- digits)))
-	      (float-sign x 0.0)
-	      (etypecase x
-		(single-float (single-from-bits sign 0 (ash sig shift)))
-		(double-float (double-from-bits sign 0 (ash sig shift)))))))
-       (t
-	(etypecase x
-	  (single-float (single-from-bits sign new-exp sig))
-	  (double-float (double-from-bits sign new-exp sig))))))))
-
-
-;;; SCALE-FLOAT-MAYBE-OVERFLOW  --  Internal
-;;;
-;;;    Called when scaling a float overflows, or the oringinal float was a NaN
-;;; or infinity.  If overflow errors are trapped, then error, otherwise return
-;;; the appropriate infinity.  If a NaN, signal or not as appropriate.
-;;;
-(defun scale-float-maybe-overflow (x exp)
-  (cond
-   ((float-infinity-p x)
-    ;; Infinity is infinity, no matter how small...
-    x)
-   ((float-nan-p x)
-    (when (and (float-trapping-nan-p x)
-	       (vm:current-float-trap :invalid))
-      (error 'floating-point-invalid-operation :operation 'scale-float
-	     :operands (list x exp)))
-    x)
-   (t
-    (when (vm:current-float-trap :overflow)
-      (error 'floating-point-overflow :operation 'scale-float
-	     :operands (list x exp)))
-    (when (vm:current-float-trap :inexact)
-      (error 'floating-point-inexact :operation 'scale-float
-	     :operands (list x exp)))
-    (* (float-sign x)
-       (etypecase x
-	 (single-float single-float-positive-infinity)
-	 (double-float double-float-positive-infinity))))))
-
-
-;;; SCALE-SINGLE-FLOAT, SCALE-DOUBLE-FLOAT  --  Internal
-;;;
-;;;    Scale a single or double float, calling the correct over/underflow
-;;; functions.
-;;;
-(defun scale-single-float (x exp)
-  (declare (single-float x) (fixnum exp))
-  (let* ((bits (single-float-bits x))
-	 (old-exp (ldb vm:single-float-exponent-byte bits))
-	 (new-exp (+ old-exp exp)))
-    (cond
-     ((zerop x) x)
-     ((or (< old-exp vm:single-float-normal-exponent-min)
-	  (< new-exp vm:single-float-normal-exponent-min))
-      (scale-float-maybe-underflow x exp))
-     ((or (> old-exp vm:single-float-normal-exponent-max)
-	  (> new-exp vm:single-float-normal-exponent-max))
-      (scale-float-maybe-overflow x exp))
-     (t
-      (make-single-float (dpb new-exp vm:single-float-exponent-byte bits))))))
-;;;
-(defun scale-double-float (x exp)
-  (declare (double-float x) (fixnum exp))
-  (let* ((hi (double-float-high-bits x))
-	 (lo (double-float-low-bits x))
-	 (old-exp (ldb vm:double-float-exponent-byte hi))
-	 (new-exp (+ old-exp exp)))
-    (cond
-     ((zerop x) x)
-     ((or (< old-exp vm:double-float-normal-exponent-min)
-	  (< new-exp vm:double-float-normal-exponent-min))
-      (scale-float-maybe-underflow x exp))
-     ((or (> old-exp vm:double-float-normal-exponent-max)
-	  (> new-exp vm:double-float-normal-exponent-max))
-      (scale-float-maybe-overflow x exp))
-     (t
-      (make-double-float (dpb new-exp vm:double-float-exponent-byte hi)
-			 lo)))))
-
-
-;;; SCALE-FLOAT  --  Public
-;;;
-;;;    Dispatch to the correct type-specific scale-float function.
-;;;
-(defun scale-float (f ex)
-  "Returns the value (* f (expt (float 2 f) ex)), but with no unnecessary loss
-  of precision or overflow."
-  (number-dispatch ((f float))
-    ((single-float)
-     (scale-single-float f ex))
-    ((double-float)
-     (scale-double-float f ex))))
-
-
-;;;; Converting to/from floats:
-
-(defun float (number &optional (other () otherp))
-  "Converts any REAL to a float.  If OTHER is not provided, it returns a
-  SINGLE-FLOAT if NUMBER is not already a FLOAT.  If OTHER is provided, the
-  result is the same float format as OTHER."
-  (if otherp
-      (number-dispatch ((number real) (other float))
-	(((foreach rational single-float double-float)
-	  (foreach single-float double-float))
-	 (coerce number '(dispatch-type other))))
-      (if (floatp number)
-	  number
-	  (coerce number 'single-float))))
-
-
-(macrolet ((frob (name type)
-	     `(defun ,name (x)
-		(number-dispatch ((x real))
-		  (((foreach single-float double-float fixnum))
-		   (coerce x ',type))
-		  ((bignum)
-		   (bignum-to-float x ',type))
-		  ((ratio)
-		   (let ((num (numerator x))
-			 (den (denominator x)))
-		     (if (and (fixnump num) (fixnump den))
-			 (/ (coerce num ',type) (coerce den ',type))
-			 (float-bignum-ratio x ',type))))))))
-  (frob %single-float single-float)
-  (frob %double-float double-float))
-
-
-#|
-These might be useful if we ever have a machine w/o float/integer conversion
-hardware.  For now, we'll use special ops that uninterruptibly frob the
-rounding modes & do ieee round-to-integer.
-
-;;; %UNARY-TRUNCATE-SINGLE-FLOAT/FIXNUM  --  Interface
-;;;
-;;;    The compiler compiles a call to this when we are doing %UNARY-TRUNCATE
-;;; and the result is known to be a fixnum.  We can avoid some generic
-;;; arithmetic in this case.
-;;;
-(defun %unary-truncate-single-float/fixnum (x)
-  (declare (single-float x) (values fixnum))
-  (locally (declare (optimize (speed 3) (safety 0)))
-    (let* ((bits (single-float-bits x))
-	   (exp (ldb vm:single-float-exponent-byte bits))
-	   (frac (logior (ldb vm:single-float-significand-byte bits)
-			 vm:single-float-hidden-bit))
-	   (shift (- exp vm:single-float-digits vm:single-float-bias)))
-      (when (> exp vm:single-float-normal-exponent-max)
-	(error 'floating-point-invalid-operation :operator 'truncate
-	       :operands (list x)))
-      (if (<= shift (- vm:single-float-digits))
-	  0
-	  (let ((res (ash frac shift)))
-	    (declare (type (unsigned-byte 31) res)) 
-	    (if (minusp bits)
-		(- res)
-		res))))))
-
-
-;;; %UNARY-TRUNCATE-DOUBLE-FLOAT/FIXNUM  --  Interface
-;;;
-;;;    Double-float version of this operation (see above single op).
-;;;
-(defun %unary-truncate-double-float/fixnum (x)
-  (declare (double-float x) (values fixnum))
-  (locally (declare (optimize (speed 3) (safety 0)))
-    (let* ((hi-bits (double-float-high-bits x))
-	   (exp (ldb vm:double-float-exponent-byte hi-bits))
-	   (frac (logior (ldb vm:double-float-significand-byte hi-bits)
-			 vm:double-float-hidden-bit))
-	   (shift (- exp (- vm:double-float-digits vm:word-bits)
-		     vm:double-float-bias)))
-      (when (> exp vm:double-float-normal-exponent-max)
-	(error 'floating-point-invalid-operation :operator 'truncate
-	       :operands (list x)))
-      (if (<= shift (- vm:word-bits vm:double-float-digits))
-	  0
-	  (let* ((res-hi (ash frac shift))
-		 (res (if (plusp shift)
-			  (logior res-hi
-				  (the fixnum
-				       (ash (double-float-low-bits x)
-					    (- shift vm:word-bits))))
-			  res-hi)))
-	    (declare (type (unsigned-byte 31) res-hi res))
-	    (if (minusp hi-bits)
-		(- res)
-		res))))))
-|#
-
-  
-;;; %UNARY-TRUNCATE  --  Interface
-;;;
-;;;    This function is called when we are doing a truncate without any funky
-;;; divisor, i.e. converting a float or ratio to an integer.  Note that we do
-;;; *not* return the second value of truncate, so it must be computed by the
-;;; caller if needed.
-;;;
-;;;    In the float case, we pick off small arguments so that compiler can use
-;;; special-case operations.  We use an exclusive test, since (due to round-off
-;;; error), (float most-positive-fixnum) may be greater than
-;;; most-positive-fixnum.
-;;;
-(defun %unary-truncate (number)
-  (number-dispatch ((number real))
-    ((integer) number)
-    ((ratio) (values (truncate (numerator number) (denominator number))))
-    (((foreach single-float double-float))
-     (if (< (float most-negative-fixnum number)
-	    number
-	    (float most-positive-fixnum number))
-	 (truly-the fixnum (%unary-truncate number))
-	 (multiple-value-bind (bits exp)
-			      (integer-decode-float number)
-	   (let ((res (ash bits exp)))
-	     (if (minusp number)
-		 (- res)
-		 res)))))))
-
-
-;;; %UNARY-ROUND  --  Interface
-;;;
-;;;    Similar to %UNARY-TRUNCATE, but rounds to the nearest integer.  If we
-;;; can't use the round primitive, then we do our own round-to-nearest on the
-;;; result of i-d-f.  [Note that this rounding will really only happen with
-;;; double floats, since the whole single-float fraction will fit in a fixnum,
-;;; so all single-floats larger than most-positive-fixnum can be precisely
-;;; represented by an integer.]
-;;;
-(defun %unary-round (number)
-  (number-dispatch ((number real))
-    ((integer) number)
-    ((ratio) (values (round (numerator number) (denominator number))))
-    (((foreach single-float double-float))
-     (if (< (float most-negative-fixnum number)
-	    number
-	    (float most-positive-fixnum number))
-	 (truly-the fixnum (%unary-round number))
-	 (multiple-value-bind (bits exp)
-			      (integer-decode-float number)
-	   (let* ((shifted (ash bits exp))
-		  (rounded (if (and (minusp exp)
-				    (oddp shifted)
-				    (eql (logand bits
-						 (lognot (ash -1 (- exp))))
-					 (ash 1 (- -1 exp))))
-			       (1+ shifted)
-			       shifted)))
-	     (if (minusp number)
-		 (- rounded)
-		 rounded)))))))
-
-
-(defun rational (x)
-  "RATIONAL produces a rational number for any real numeric argument.  This is
-  more efficient than RATIONALIZE, but it assumes that floating-point is
-  completely accurate, giving a result that isn't as pretty."
-  (number-dispatch ((x real))
-    (((foreach single-float double-float))
-     (multiple-value-bind (bits exp)
-			  (integer-decode-float x)
-       (if (eql bits 0)
-	   0
-	   (let* ((int (if (minusp x) (- bits) bits))
-		  (digits (float-digits x))
-		  (ex (+ exp digits)))
-	     (if (minusp ex)
-		 (integer-/-integer int (ash 1 (+ digits (- ex))))
-		 (integer-/-integer (ash int ex) (ash 1 digits)))))))
-    ((rational) x)))
-
-
-(defun rationalize (x)
-  "Converts any REAL to a RATIONAL.  Floats are converted to a simple rational
-  representation exploiting the assumption that floats are only accurate to
-  their precision.  RATIONALIZE (and also RATIONAL) preserve the invariant:
-      (= x (float (rationalize x) x))"
-  (number-dispatch ((x real))
-    (((foreach single-float double-float))
-     ;; Thanks to Kim Fateman, who stole this function rationalize-float
-     ;; from macsyma's rational. Macsyma'a rationalize was written
-     ;; by the legendary Gosper (rwg). Gosper is now working for Symbolics.
-     ;; Guy Steele said about Gosper, "He has been called the
-     ;; only living 17th century mathematician and is also the best
-     ;; pdp-10 hacker I know." So, if you can understand or debug this
-     ;; code you win big.
-     (cond ((minusp x) (- (rationalize (- x))))
-	   ((zerop x) 0)
-	   (t
-	    (let ((eps (if (typep x 'single-float)
-			   single-float-epsilon
-			   double-float-epsilon))
-		  (y ())
-		  (a ()))
-	      (do ((xx x (setq y (/ (float 1.0 x) (- xx (float a x)))))
-		   (num (setq a (truncate x))
-			(+ (* (setq a (truncate y)) num) onum))
-		   (den 1 (+ (* a den) oden))
-		   (onum 1 num)
-		   (oden 0 den))
-		  ((and (not (zerop den))
-			(not (> (abs (/ (- x (/ (float num x)
-						(float den x)))
-					x))
-				eps)))
-		   (integer-/-integer num den))
-		(declare ((dispatch-type x) xx)))))))
-    ((rational) x)))
diff --git a/code/foreign.lisp b/code/foreign.lisp
deleted file mode 100644
index 57245c217af3a26d5c975819b2b686c1eed151e7..0000000000000000000000000000000000000000
--- a/code/foreign.lisp
+++ /dev/null
@@ -1,216 +0,0 @@
-;;; -*- Package: SYSTEM -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.12 1992/07/17 16:03:41 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-(in-package "SYSTEM")
-
-(in-package "ALIEN")
-(export '(load-foreign))
-(in-package "SYSTEM")
-(import 'alien:load-foreign)
-
-(defvar *previous-linked-object-file* nil)
-(defvar *foreign-segment-free-pointer* foreign-segment-start)
-
-(defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
-  (let ((code (char-code #\A)))
-    (loop
-      (let ((name (format nil base (unix:unix-getpid) (code-char code))))
-	(multiple-value-bind
-	    (fd errno)
-	    (unix:unix-open name
-			    (logior unix:o_wronly unix:o_creat unix:o_excl)
-			    #o666)
-	  (cond ((not (null fd))
-		 (unix:unix-close fd)
-		 (return name))
-		((not (= errno unix:eexist))
-		 (error "Could not create temporary file ~S: ~A"
-			name (unix:get-unix-error-msg errno)))
-		
-		((= code (char-code #\Z))
-		 (setf code (char-code #\a)))
-		((= code (char-code #\z))
-		 (return nil))
-		(t
-		 (incf code))))))))
-
-#+sparc
-(alien:def-alien-type exec
-  (alien:struct nil
-    (magic c-call:unsigned-long)
-    (text c-call:unsigned-long)
-    (data c-call:unsigned-long)
-    (bss c-call:unsigned-long)
-    (syms c-call:unsigned-long)
-    (entry c-call:unsigned-long)
-    (trsize c-call:unsigned-long)
-    (drsize c-call:unsigned-long)))
-
-(defun allocate-space-in-foreign-segment (bytes)
-  (let* ((pagesize-1 (1- (get-page-size)))
-	 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
-	 (addr (int-sap *foreign-segment-free-pointer*))
-	 (new-ptr (+ *foreign-segment-free-pointer* bytes)))
-    (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
-      (error "Not enough memory left."))
-    (setf *foreign-segment-free-pointer* new-ptr)
-    (allocate-system-memory-at addr memory-needed)
-    addr))
-
-#+sparc
-(defun load-object-file (name)
-  (format t ";;; Loading object file...~%")
-  (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
-    (unless fd
-      (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
-    (unwind-protect
-	(alien:with-alien ((header exec))
-	  (unix:unix-read fd
-			  (alien:alien-sap header)
-			  (alien:alien-size exec :bytes))
-	  (let* ((len-of-text-and-data
-		  (+ (alien:slot header 'text) (alien:slot header 'data)))
-		 (memory-needed
-		  (+ len-of-text-and-data (alien:slot header 'bss)))
-		 (addr (allocate-space-in-foreign-segment memory-needed)))
-	    (unix:unix-read fd addr len-of-text-and-data)))
-      (unix:unix-close fd))))
-
-#+pmax
-(alien:def-alien-type filehdr
-  (alien:struct nil
-    (magic c-call:unsigned-short)
-    (nscns c-call:unsigned-short)
-    (timdat c-call:long)
-    (symptr c-call:long)
-    (nsyms c-call:long)
-    (opthdr c-call:unsigned-short)
-    (flags c-call:unsigned-short)))
-
-#+pmax
-(alien:def-alien-type aouthdr
-  (alien:struct nil
-    (magic c-call:short)
-    (vstamp c-call:short)
-    (tsize c-call:long)
-    (dsize c-call:long)
-    (bsize c-call:long)
-    (entry c-call:long)
-    (text_start c-call:long)
-    (data_start c-call:long)))
-
-#+pmax
-(defconstant filhsz 20)
-#+pmax
-(defconstant aouthsz 56)
-#+pmax
-(defconstant scnhsz 40)
-
-#+pmax
-(defun load-object-file (name)
-  (format t ";;; Loading object file...~%")
-  (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
-    (unless fd
-      (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
-    (unwind-protect
-	(alien:with-alien ((filehdr filehdr)
-			   (aouthdr aouthdr))
-	  (unix:unix-read fd
-			  (alien:alien-sap filehdr)
-			  (alien:alien-size filehdr :bytes))
-	  (unix:unix-read fd
-			  (alien:alien-sap aouthdr)
-			  (alien:alien-size aouthdr :bytes))
-	  (let* ((len-of-text-and-data
-		  (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize)))
-		 (memory-needed
-		  (+ len-of-text-and-data (alien:slot aouthdr 'bsize)))
-		 (addr (allocate-space-in-foreign-segment memory-needed))
-		 (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15)))
-	    (unix:unix-lseek fd
-			     (logandc2 (+ filhsz aouthsz
-					  (* scnhsz
-					     (alien:slot filehdr 'nscns))
-					  pad-size-1)
-				       pad-size-1)
-			     unix:l_set)
-	    (unix:unix-read fd addr len-of-text-and-data)))
-      (unix:unix-close fd))))
-
-(defun parse-symbol-table (name)
-  (format t ";;; Parsing symbol table...~%")
-  (let ((symbol-table (make-hash-table :test #'equal)))
-    (with-open-file (file name)
-      (loop
-	(let ((line (read-line file nil nil)))
-	  (unless line
-	    (return))
-	  (let* ((symbol (subseq line 11))
-		 (address (parse-integer line :end 8 :radix 16))
-		 (old-address (gethash symbol lisp::*foreign-symbols*)))
-	    (unless (or (null old-address) (= address old-address))
-	      (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
-		    symbol old-address address))
-	    (setf (gethash symbol symbol-table) address)))))
-    (setf lisp::*foreign-symbols* symbol-table)))
-
-(defun load-foreign (files &key
-			   (libraries '("-lc"))
-			   (base-file
-			    (merge-pathnames *command-line-utility-name*
-					     "path:"))
-			   (env ext:*environment-list*))
-  "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
-  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."
-  (let ((output-file (pick-temporary-file-name))
-	(symbol-table-file (pick-temporary-file-name))
-	(error-output (make-string-output-stream)))
-
-    (format t ";;; Running library:load-foreign.csh...~%")
-    (force-output)
-    (let ((proc (ext:run-program "library:load-foreign.csh"
-				 (list* (or *previous-linked-object-file*
-					    (namestring (truename base-file)))
-					(format nil "~X"
-						*foreign-segment-free-pointer*)
-					output-file
-					symbol-table-file
-					(append (if (atom files)
-						    (list files)
-						    files)
-						libraries))
-				 :env env
-				 :input nil
-				 :output error-output
-				 :error :output)))
-      (unless proc
-	(error "Could not run library:load-foreign.csh"))
-      (unless (zerop (ext:process-exit-code proc))
-	(system:serve-all-events 0)
-	(error "library:load-foreign.csh failed:~%~A"
-	       (get-output-stream-string error-output)))
-      (load-object-file output-file)
-      (parse-symbol-table symbol-table-file)
-      (unix:unix-unlink symbol-table-file)
-      (let ((old-file *previous-linked-object-file*))
-	(setf *previous-linked-object-file* output-file)
-	(when old-file
-	  (unix:unix-unlink old-file)))))
-  (format t ";;; Done.~%"))
diff --git a/code/format-time.lisp b/code/format-time.lisp
deleted file mode 100644
index c3670fc497474b0457d01a204ee376d68f45b78c..0000000000000000000000000000000000000000
--- a/code/format-time.lisp
+++ /dev/null
@@ -1,194 +0,0 @@
-;;; -*- Mode: Lisp; Package: Extensions; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format-time.lisp,v 1.3 1991/02/08 13:32:55 ram Exp $")
-;;;
-;;; **********************************************************************
-
-;;; 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 (rationalp timezone) (<= -24 timezone 24))
-      (error "~A: Timezone should be a rational between -24 and 24." timezone))
-    (unless (zerop (rem timezone 1/3600))
-      (error "~A: Timezone is not a second (1/3600) multiple." timezone)))
-
-  (multiple-value-bind (secs mins hours day month year dow dst tz)
-		       (if timezone
-			   (decode-universal-time universal-time timezone)
-			   (decode-universal-time universal-time))
-    (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 1f9f272b03992f8b26bd9e64aa98e867135e9825..0000000000000000000000000000000000000000
--- a/code/format.lisp
+++ /dev/null
@@ -1,2371 +0,0 @@
-;;; -*- Package: FORMAT -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.25 1992/11/06 04:15:56 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Functions to implement FORMAT and FORMATTER for CMU Common Lisp.
-;;;
-;;; Written by William Lott, with lots of stuff stolen from the previous
-;;; version by David Adam and later rewritten by Bill Maddox.
-;;; 
-
-(in-package "FORMAT")
-(use-package "EXT")
-(use-package "KERNEL")
-
-(in-package "LISP")
-(export '(format formatter))
-
-(in-package "FORMAT")
-
-(defstruct (format-directive
-	    (:print-function %print-format-directive))
-  (string (required-argument) :type simple-string)
-  (start (required-argument) :type (and unsigned-byte fixnum))
-  (end (required-argument) :type (and unsigned-byte fixnum))
-  (character (required-argument) :type base-character)
-  (colonp nil :type (member t nil))
-  (atsignp nil :type (member t nil))
-  (params nil :type list))
-
-(defun %print-format-directive (struct stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (struct stream)
-    (write-string (format-directive-string struct) stream
-		  :start (format-directive-start struct)
-		  :end (format-directive-end struct))))
-
-(defvar *format-directive-expanders*
-  (make-array char-code-limit :initial-element nil))
-(defvar *format-directive-interpreters*
-  (make-array char-code-limit :initial-element nil))
-
-(defun %print-format-error (condition stream)
-  (cl:format stream
-	     "~:[~;Error in format: ~]~
-	      ~?~@[~%  ~A~%  ~V@T^~]"
-	     (format-error-print-banner condition)
-	     (format-error-complaint condition)
-	     (format-error-arguments condition)
-	     (format-error-control-string condition)
-	     (format-error-offset condition)))
-
-(defvar *default-format-error-control-string* nil)
-(defvar *default-format-error-offset* nil)
-
-(define-condition format-error (error)
-  ((complaint)
-   (arguments :init-form nil)
-   (control-string :init-form *default-format-error-control-string*)
-   (offset :init-form *default-format-error-offset*)
-   (print-banner :init-form t))
-  (:report %print-format-error))
-
-
-
-;;;; TOKENIZE-CONTROL-STRING
-
-(defun tokenize-control-string (string)
-  (declare (simple-string string))
-  (let ((index 0)
-	(end (length string))
-	(result nil))
-    (loop
-      (let ((next-directive (or (position #\~ string :start index) end)))
-	(when (> next-directive index)
-	  (push (subseq string index next-directive) result))
-	(when (= next-directive end)
-	  (return))
-	(let ((directive (parse-directive string next-directive)))
-	  (push directive result)
-	  (setf index (format-directive-end directive)))))
-    (nreverse result)))
-
-(defun parse-directive (string start)
-  (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil)
-	(end (length string)))
-    (flet ((get-char ()
-	     (if (= posn end)
-		 (error 'format-error
-			:complaint "String ended before directive was found."
-			:control-string string
-			:offset start)
-		 (schar string posn))))
-      (loop
-	(let ((char (get-char)))
-	  (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
-		 (multiple-value-bind
-		     (param new-posn)
-		     (parse-integer string :start posn :junk-allowed t)
-		   (push (cons posn param) params)
-		   (setf posn new-posn)
-		   (case (get-char)
-		     (#\,)
-		     ((#\: #\@)
-		      (decf posn))
-		     (t
-		      (return)))))
-		((or (char= char #\v) (char= char #\V))
-		 (push (cons posn :arg) params)
-		 (incf posn)
-		 (case (get-char)
-		   (#\,)
-		   ((#\: #\@)
-		    (decf posn))
-		   (t
-		    (return))))
-		((char= char #\#)
-		 (push (cons posn :remaining) params)
-		 (incf posn)
-		 (case (get-char)
-		   (#\,)
-		   ((#\: #\@)
-		    (decf posn))
-		   (t
-		    (return))))
-		((char= char #\')
-		 (incf posn)
-		 (push (cons posn (get-char)) params))
-		((char= char #\,)
-		 (push (cons (1- posn) nil) params))
-		((char= char #\:)
-		 (if colonp
-		     (error 'format-error
-			    :complaint "Too many colons supplied."
-			    :control-string string
-			    :offset posn)
-		     (setf colonp t)))
-		((char= char #\@)
-		 (if atsignp
-		     (error 'format-error
-			    :complaint "Too many at-signs supplied."
-			    :control-string string
-			    :offset posn)
-		     (setf atsignp t)))
-		(t
-		 (when (char= (schar string (1- posn)) #\,)
-		   (push (cons (1- posn) nil) params))
-		 (return))))
-	(incf posn))
-      (let ((char (get-char)))
-	(when (char= char #\/)
-	  (let ((closing-slash (position #\/ string :start (1+ posn))))
-	    (if closing-slash
-		(setf posn closing-slash)
-		(error 'format-error
-		       :complaint "No matching closing slash."
-		       :control-string string
-		       :offset posn))))
-	(make-format-directive
-	    :string string :start start :end (1+ posn)
-	    :character (char-upcase char)
-	    :colonp colonp :atsignp atsignp
-	    :params (nreverse params))))))
-
-
-;;;; Specials used to communicate information.
-
-;;; *UP-UP-AND-OUT-ALLOWED* -- internal.
-;;;
-;;; Used both by the expansion stuff and the interpreter stuff.  When it is
-;;; non-NIL, up-up-and-out (~:^) is allowed.  Otherwise, ~:^ isn't allowed.
-;;;
-(defvar *up-up-and-out-allowed* nil)
-
-;;; *LOGICAL-BLOCK-POPPER* -- internal.
-;;;
-;;; Used by the interpreter stuff.  When it non-NIL, its a function that will
-;;; invoke PPRINT-POP in the right lexical environemnt.
-;;;
-(defvar *logical-block-popper* nil)
-
-;;; *EXPANDER-NEXT-ARG-MACRO* -- internal.
-;;;
-;;; Used by the expander stuff.  This is bindable so that ~<...~:>
-;;; can change it.
-;;;
-(defvar *expander-next-arg-macro* 'expander-next-arg)
-
-;;; *ONLY-SIMPLE-ARGS* -- internal.
-;;;
-;;; Used by the expander stuff.  Initially starts as T, and gets set to NIL
-;;; if someone needs to do something strange with the arg list (like use
-;;; the rest, or something).
-;;; 
-(defvar *only-simple-args*)
-
-;;; *ORIG-ARGS-AVAILABLE* -- internal.
-;;;
-;;; Used by the expander stuff.  We do an initial pass with this as NIL.
-;;; If someone doesn't like this, they (throw 'need-orig-args nil) and we try
-;;; again with it bound to T.  If this is T, we don't try to do anything
-;;; fancy with args.
-;;; 
-(defvar *orig-args-available* nil)
-
-;;; *SIMPLE-ARGS* -- internal.
-;;;
-;;; Used by the expander stuff.  List of (symbol . offset) for simple args.
-;;; 
-(defvar *simple-args*)
-
-
-
-
-;;;; FORMAT
-
-(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."
-  (etypecase destination
-    (null
-     (with-output-to-string (stream)
-       (%format stream control-string format-arguments)))
-    (string
-     (with-output-to-string (stream destination)
-       (%format stream control-string format-arguments)))
-    ((member t)
-     (%format *standard-output* control-string format-arguments)
-     nil)
-    (stream
-     (%format destination control-string format-arguments)
-     nil)))
-
-(defun %format (stream string-or-fun orig-args &optional (args orig-args))
-  (if (functionp string-or-fun)
-      (apply string-or-fun stream args)
-      (catch 'up-and-out
-	(let* ((string (etypecase string-or-fun
-			 (simple-string
-			  string-or-fun)
-			 (string
-			  (coerce string-or-fun 'simple-string))))
-	       (*default-format-error-control-string* string)
-	       (*logical-block-popper* nil))
-	  (interpret-directive-list stream (tokenize-control-string string)
-				    orig-args args)))))
-
-(defun interpret-directive-list (stream directives orig-args args)
-  (if directives
-      (let ((directive (car directives)))
-	(etypecase directive
-	  (simple-string
-	   (write-string directive stream)
-	   (interpret-directive-list stream (cdr directives) orig-args args))
-	  (format-directive
-	   (multiple-value-bind
-	       (new-directives new-args)
-	       (let ((function
-		      (svref *format-directive-interpreters*
-			     (char-code (format-directive-character
-					 directive))))
-		     (*default-format-error-offset*
-		      (1- (format-directive-end directive))))
-		 (unless function
-		   (error 'format-error
-			  :complaint "Unknown format directive."))
-		 (multiple-value-bind
-		     (new-directives new-args)
-		     (funcall function stream directive
-			      (cdr directives) orig-args args)
-		   (values new-directives new-args)))
-	     (interpret-directive-list stream new-directives
-				       orig-args new-args)))))
-      args))
-
-
-;;;; FORMATTER
-
-(defmacro formatter (control-string)
-  `#',(%formatter control-string))
-
-(defun %formatter (control-string)
-  (block nil
-    (catch 'need-orig-args
-      (let* ((*simple-args* nil)
-	     (*only-simple-args* t)
-	     (guts (expand-control-string control-string))
-	     (args nil))
-	(dolist (arg *simple-args*)
-	  (push `(,(car arg)
-		  (error
-		   'format-error
-		   :complaint "Required argument missing"
-		   :control-string ,control-string
-		   :offset ,(cdr arg)))
-		args))
-	(return `(lambda (stream &optional ,@args &rest args)
-		   ,guts
-		   args))))
-    (let ((*orig-args-available* t)
-	  (*only-simple-args* nil))
-      `(lambda (stream &rest orig-args)
-	 (let ((args orig-args))
-	   ,(expand-control-string control-string)
-	   args)))))
-
-(defun expand-control-string (string)
-  (let* ((string (etypecase string
-		   (simple-string
-		    string)
-		   (string
-		    (coerce string 'simple-string))))
-	 (*default-format-error-control-string* string)
-	 (directives (tokenize-control-string string)))
-    `(block nil
-       ,@(expand-directive-list directives))))
-
-(defun expand-directive-list (directives)
-  (let ((results nil)
-	(remaining-directives directives))
-    (loop
-      (unless remaining-directives
-	(return))
-      (multiple-value-bind
-	  (form new-directives)
-	  (expand-directive (car remaining-directives)
-			    (cdr remaining-directives))
-	(push form results)
-	(setf remaining-directives new-directives)))
-    (reverse results)))
-
-(defun expand-directive (directive more-directives)
-  (etypecase directive
-    (format-directive
-     (let ((expander
-	    (aref *format-directive-expanders*
-		  (char-code (format-directive-character directive))))
-	   (*default-format-error-offset*
-	    (1- (format-directive-end directive))))
-       (if expander
-	   (funcall expander directive more-directives)
-	   (error 'format-error
-		  :complaint "Unknown directive."))))
-    (simple-string
-     (values `(write-string ,directive stream)
-	     more-directives))))
-
-(defun expand-next-arg (&optional offset)
-  (if (or *orig-args-available* (not *only-simple-args*))
-      `(,*expander-next-arg-macro*
-	,*default-format-error-control-string*
-	,(or offset *default-format-error-offset*))
-      (let ((symbol (gensym "FORMAT-ARG-")))
-	(push (cons symbol (or offset *default-format-error-offset*))
-	      *simple-args*)
-	symbol)))
-
-(defun need-hairy-args ()
-  (when *only-simple-args*
-    ))
-
-
-;;;; Format directive definition macros and runtime support.
-
-(defmacro expander-next-arg (string offset)
-  `(if args
-       (pop args)
-       (error 'format-error
-	      :complaint "No more arguments."
-	      :control-string ,string
-	      :offset ,offset)))
-
-(defmacro expander-pprint-next-arg (string offset)
-  `(progn
-     (when (null args)
-       (error 'format-error
-	      :complaint "No more arguments."
-	      :control-string ,string
-	      :offset ,offset))
-     (pprint-pop)
-     (pop args)))
-
-(eval-when (compile eval)
-
-;;; NEXT-ARG -- internal.
-;;;
-;;; This macro is used to extract the next argument from the current arg list.
-;;; This is the version used by format directive interpreters.
-;;; 
-(defmacro next-arg (&optional offset)
-  `(progn
-     (when (null args)
-       (error 'format-error
-	      :complaint "No more arguments."
-	      ,@(when offset
-		  `(:offset ,offset))))
-     (when *logical-block-popper*
-       (funcall *logical-block-popper*))
-     (pop args)))
-
-(defmacro def-complex-format-directive (char lambda-list &body body)
-  (let ((defun-name (intern (cl:format nil
-				       "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
-				       char)))
-	(directive (gensym))
-	(directives (if lambda-list (car (last lambda-list)) (gensym))))
-    `(progn
-       (defun ,defun-name (,directive ,directives)
-	 ,@(if lambda-list
-	       `((let ,(mapcar #'(lambda (var)
-				   `(,var
-				     (,(intern (concatenate
-						'string
-						"FORMAT-DIRECTIVE-"
-						(symbol-name var))
-					       (symbol-package 'foo))
-				      ,directive)))
-			       (butlast lambda-list))
-		   ,@body))
-	       `((declare (ignore ,directive ,directives))
-		 ,@body)))
-       (%set-format-directive-expander ,char #',defun-name))))
-
-(defmacro def-format-directive (char lambda-list &body body)
-  (let ((directives (gensym))
-	(declarations nil)
-	(body-without-decls body))
-    (loop
-      (let ((form (car body-without-decls)))
-	(unless (and (consp form) (eq (car form) 'declare))
-	  (return))
-	(push (pop body-without-decls) declarations)))
-    (setf declarations (reverse declarations))
-    `(def-complex-format-directive ,char (,@lambda-list ,directives)
-       ,@declarations
-       (values (progn ,@body-without-decls)
-	       ,directives))))
-
-(defmacro expand-bind-defaults (specs params &body body)
-  (once-only ((params params))
-    (if specs
-	(collect ((expander-bindings) (runtime-bindings))
-		 (dolist (spec specs)
-		   (destructuring-bind (var default) spec
-		     (let ((symbol (gensym)))
-		       (expander-bindings
-			`(,var ',symbol))
-		       (runtime-bindings
-			`(list ',symbol
-			       (let* ((param-and-offset (pop ,params))
-				      (offset (car param-and-offset))
-				      (param (cdr param-and-offset)))
-				 (case param
-				   (:arg `(or ,(expand-next-arg offset)
-					      ,,default))
-				   (:remaining
-				    (setf *only-simple-args* nil)
-				    '(length args))
-				   ((nil) ,default)
-				   (t param))))))))
-		 `(let ,(expander-bindings)
-		    `(let ,(list ,@(runtime-bindings))
-		       ,@(if ,params
-			     (error 'format-error
-				    :complaint
-			    "Too many parameters, expected no more than ~D"
-				    :arguments (list ,(length specs))
-				    :offset (caar ,params)))
-		       ,,@body)))
-	`(progn
-	   (when ,params
-	     (error 'format-error
-		    :complaint "Too many parameters, expected no more than 0"
-		    :offset (caar ,params)))
-	   ,@body))))
-
-(defmacro def-complex-format-interpreter (char lambda-list &body body)
-  (let ((defun-name
-	    (intern (cl:format nil "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER"
-			       char)))
-	(directive (gensym))
-	(directives (if lambda-list (car (last lambda-list)) (gensym))))
-    `(progn
-       (defun ,defun-name (stream ,directive ,directives orig-args args)
-	 (declare (ignorable stream orig-args args))
-	 ,@(if lambda-list
-	       `((let ,(mapcar #'(lambda (var)
-				   `(,var
-				     (,(intern (concatenate
-						'string
-						"FORMAT-DIRECTIVE-"
-						(symbol-name var))
-					       (symbol-package 'foo))
-				      ,directive)))
-			       (butlast lambda-list))
-		   (values (progn ,@body) args)))
-	       `((declare (ignore ,directive ,directives))
-		 ,@body)))
-       (%set-format-directive-interpreter ,char #',defun-name))))
-
-(defmacro def-format-interpreter (char lambda-list &body body)
-  (let ((directives (gensym)))
-    `(def-complex-format-interpreter ,char (,@lambda-list ,directives)
-       ,@body
-       ,directives)))
-
-(defmacro interpret-bind-defaults (specs params &body body)
-  (once-only ((params params))
-    (collect ((bindings))
-      (dolist (spec specs)
-	(destructuring-bind (var default) spec
-	  (bindings `(,var (let* ((param-and-offset (pop ,params))
-				  (offset (car param-and-offset))
-				  (param (cdr param-and-offset)))
-			     (case param
-			       (:arg (next-arg offset))
-			       (:remaining (length args))
-			       ((nil) ,default)
-			       (t param)))))))
-      `(let* ,(bindings)
-	 (when ,params
-	   (error 'format-error
-		  :complaint
-		  "Too many parameters, expected no more than ~D"
-		  :arguments (list ,(length specs))
-		  :offset (caar ,params)))
-	 ,@body))))
-
-); eval-when
-
-(defun %set-format-directive-expander (char fn)
-  (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn)
-  char)
-
-(defun %set-format-directive-interpreter (char fn)
-  (setf (aref *format-directive-interpreters*
-	      (char-code (char-upcase char)))
-	fn)
-  char)
-
-(defun find-directive (directives kind stop-at-semi)
-  (if directives
-      (let ((next (car directives)))
-	(if (format-directive-p next)
-	    (let ((char (format-directive-character next)))
-	      (if (or (char= kind char)
-		      (and stop-at-semi (char= char #\;)))
-		  (car directives)
-		  (find-directive
-		   (cdr (flet ((after (char)
-				 (member (find-directive (cdr directives)
-							 char
-							 nil)
-					 directives)))
-			  (case char
-			    (#\( (after #\)))
-			    (#\< (after #\>))
-			    (#\[ (after #\]))
-			    (#\{ (after #\}))
-			    (t directives))))
-		   kind stop-at-semi)))
-	    (find-directive (cdr directives) kind stop-at-semi)))))
-
-
-;;;; Simple outputting noise.
-
-(defun format-write-field (stream string mincol colinc minpad padchar padleft)
-  (unless padleft
-    (write-string string stream))
-  (dotimes (i minpad)
-    (write-char padchar stream))
-  (do ((chars (+ (length string) minpad) (+ chars colinc)))
-      ((>= chars mincol))
-    (dotimes (i colinc)
-      (write-char padchar stream)))
-  (when padleft
-    (write-string string stream)))
-
-(defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar)
-  (format-write-field stream
-		      (if (or arg (not colonp))
-			  (princ-to-string arg)
-			  "()")
-		      mincol colinc minpad padchar atsignp))
-
-(def-format-directive #\A (colonp atsignp params)
-  (if params
-      (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
-			     (padchar #\space))
-		     params
-	`(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
-		       ,mincol ,colinc ,minpad ,padchar))
-      `(princ ,(if colonp
-		   `(or ,(expand-next-arg) "()")
-		   (expand-next-arg))
-	      stream)))
-
-(def-format-interpreter #\A (colonp atsignp params)
-  (if params
-      (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
-				(padchar #\space))
-		     params
-	(format-princ stream (next-arg) colonp atsignp
-		      mincol colinc minpad padchar))
-      (princ (if colonp (or (next-arg) "()") (next-arg)) stream)))
-
-(defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar)
-  (format-write-field stream
-		      (if (or arg (not colonp))
-			  (prin1-to-string arg)
-			  "()")
-		      mincol colinc minpad padchar atsignp))
-
-(def-format-directive #\S (colonp atsignp params)
-  (cond (params
-	 (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
-				(padchar #\space))
-			params
-	   `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
-			  ,mincol ,colinc ,minpad ,padchar)))
-	(colonp
-	 `(let ((arg ,(expand-next-arg)))
-	    (if arg
-		(prin1 arg stream)
-		(princ "()" stream))))
-	(t
-	 `(prin1 ,(expand-next-arg) stream))))
-
-(def-format-interpreter #\S (colonp atsignp params)
-  (cond (params
-	 (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
-				   (padchar #\space))
-			params
-	   (format-prin1 stream (next-arg) colonp atsignp
-			 mincol colinc minpad padchar)))
-	(colonp
-	 (let ((arg (next-arg)))
-	   (if arg
-	       (prin1 arg stream)
-	       (princ "()" stream))))
-	(t
-	 (prin1 (next-arg) stream))))
-
-(def-format-directive #\C (colonp atsignp params)
-  (expand-bind-defaults () params
-    (if colonp
-	`(format-print-named-character ,(expand-next-arg) stream)
-	(if atsignp
-	    `(prin1 ,(expand-next-arg) stream)
-	    `(write-char ,(expand-next-arg) stream)))))
-
-(def-format-interpreter #\C (colonp atsignp params)
-  (interpret-bind-defaults () params
-    (if colonp
-	(format-print-named-character (next-arg) stream)
-	(if atsignp
-	    (prin1 (next-arg) stream)
-	    (write-char (next-arg) stream)))))
-
-(defun format-print-named-character (char stream)
-  (let* ((name (char-name char)))
-    (cond (name
-	   (write-string (string-capitalize name) stream))
-	  ((<= 0 (char-code char) 31)
-	   ;; Print control characters as "^"<char>
-	   (write-char #\^ stream)
-	   (write-char (code-char (+ 64 (char-code char))) stream))
-	  (t
-	   (write-char char stream)))))
-
-(def-format-directive #\W (colonp atsignp params)
-  (expand-bind-defaults () params
-    (if (or colonp atsignp)
-	`(let (,@(when colonp
-		   '((*print-pretty* t)))
-	       ,@(when atsignp
-		   '((*print-level* nil)
-		     (*print-length* nil))))
-	   (output-object ,(expand-next-arg) stream))
-	`(output-object ,(expand-next-arg) stream))))
-
-(def-format-interpreter #\W (colonp atsignp params)
-  (interpret-bind-defaults () params
-    (let ((*print-pretty* (or colonp *print-pretty*))
-	  (*print-level* (and atsignp *print-level*))
-	  (*print-length* (and atsignp *print-length*)))
-      (output-object (next-arg) stream))))
-
-
-;;;; Integer outputting.
-
-;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing
-;;; directives.  The parameters are interpreted as defined for ~D.
-;;;
-(defun format-print-integer (stream number print-commas-p print-sign-p
-			     radix mincol padchar commachar commainterval)
-  (let ((*print-base* radix)
-	(*print-radix* nil))
-    (if (integerp number)
-	(let* ((text (princ-to-string (abs number)))
-	       (commaed (if print-commas-p
-			    (format-add-commas text commachar commainterval)
-			    text))
-	       (signed (cond ((minusp number)
-			      (concatenate 'string "-" commaed))
-			     (print-sign-p
-			      (concatenate 'string "+" commaed))
-			     (t commaed))))
-	  ;; colinc = 1, minpad = 0, padleft = t
-	  (format-write-field stream signed mincol 1 0 padchar t))
-	(princ number))))
-
-(defun format-add-commas (string commachar commainterval)
-  (let ((length (length string)))
-    (multiple-value-bind (commas extra)
-			 (truncate (1- length) commainterval)
-      (let ((new-string (make-string (+ length commas)))
-	    (first-comma (1+ extra)))
-	(replace new-string string :end1 first-comma :end2 first-comma)
-	(do ((src first-comma (+ src commainterval))
-	     (dst first-comma (+ dst commainterval 1)))
-	    ((= src length))
-	  (setf (schar new-string dst) commachar)
-	  (replace new-string string :start1 (1+ dst)
-		   :start2 src :end2 (+ src commainterval)))
-	new-string))))
-
-(defun expand-format-integer (base colonp atsignp params)
-  (if (or colonp atsignp params)
-      (expand-bind-defaults
-	  ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
-	  params
-	`(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
-			       ,base ,mincol ,padchar ,commachar
-			       ,commainterval))
-      `(write ,(expand-next-arg) :stream stream :base ,base :radix nil
-	      :escape nil)))
-
-(defmacro interpret-format-integer (base)
-  `(if (or colonp atsignp params)
-       (interpret-bind-defaults
-	   ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
-	   params
-	 (format-print-integer stream (next-arg) colonp atsignp ,base mincol
-			       padchar commachar commainterval))
-       (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))
-
-(def-format-directive #\D (colonp atsignp params)
-  (expand-format-integer 10 colonp atsignp params))
-
-(def-format-interpreter #\D (colonp atsignp params)
-  (interpret-format-integer 10))
-
-(def-format-directive #\B (colonp atsignp params)
-  (expand-format-integer 2 colonp atsignp params))
-
-(def-format-interpreter #\B (colonp atsignp params)
-  (interpret-format-integer 2))
-
-(def-format-directive #\O (colonp atsignp params)
-  (expand-format-integer 8 colonp atsignp params))
-
-(def-format-interpreter #\O (colonp atsignp params)
-  (interpret-format-integer 8))
-
-(def-format-directive #\X (colonp atsignp params)
-  (expand-format-integer 16 colonp atsignp params))
-
-(def-format-interpreter #\X (colonp atsignp params)
-  (interpret-format-integer 16))
-
-(def-format-directive #\R (colonp atsignp params)
-  (if params
-      (expand-bind-defaults
-	  ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
-	   (commainterval 3))
-	  params
-	`(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
-			       ,base ,mincol
-			       ,padchar ,commachar ,commainterval))
-      (if atsignp
-	  (if colonp
-	      `(format-print-old-roman stream ,(expand-next-arg))
-	      `(format-print-roman stream ,(expand-next-arg)))
-	  (if colonp
-	      `(format-print-ordinal stream ,(expand-next-arg))
-	      `(format-print-cardinal stream ,(expand-next-arg))))))
-
-(def-format-interpreter #\R (colonp atsignp params)
-  (if params
-      (interpret-bind-defaults
-	  ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
-	   (commainterval 3))
-	  params
-	(format-print-integer stream (next-arg) colonp atsignp base mincol
-			      padchar commachar commainterval))
-      (if atsignp
-	  (if colonp
-	      (format-print-old-roman stream (next-arg))
-	      (format-print-roman stream (next-arg)))
-	  (if colonp
-	      (format-print-ordinal stream (next-arg))
-	      (format-print-cardinal stream (next-arg))))))
-
-
-(defconstant cardinal-ones
-  #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
-
-(defconstant cardinal-tens
-  #(nil nil "twenty" "thirty" "forty"
-	"fifty" "sixty" "seventy" "eighty" "ninety"))
-
-(defconstant cardinal-teens
-  #("ten" "eleven" "twelve" "thirteen" "fourteen"  ;;; RAD
-    "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
-
-(defconstant cardinal-periods
-  #("" " thousand" " million" " billion" " trillion" " quadrillion"
-    " quintillion" " sextillion" " septillion" " octillion" " nonillion"
-    " decillion"))
-
-(defconstant ordinal-ones
-  #(nil "first" "second" "third" "fourth"
-	"fifth" "sixth" "seventh" "eighth" "ninth")
-  "Table of ordinal ones-place digits in English")
-
-(defconstant ordinal-tens 
-  #(nil "tenth" "twentieth" "thirtieth" "fortieth"
-	"fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")
-  "Table of ordinal tens-place digits in English")
-
-(defun format-print-small-cardinal (stream n)
-  (multiple-value-bind 
-      (hundreds rem) (truncate n 100)
-    (when (plusp hundreds)
-      (write-string (svref cardinal-ones hundreds) stream)
-      (write-string " hundred" stream)
-      (when (plusp rem)
-	(write-char #\space stream)))
-    (when (plusp rem)
-      (multiple-value-bind (tens ones)
-			   (truncate rem 10)
-       (cond ((< 1 tens)
-	      (write-string (svref cardinal-tens tens) stream)
-	      (when (plusp ones)
-		(write-char #\- stream)
-		(write-string (svref cardinal-ones ones) stream)))
-	     ((= tens 1)
-	      (write-string (svref cardinal-teens ones) stream))
-	     ((plusp ones)
-	      (write-string (svref cardinal-ones ones) stream)))))))
-
-(defun format-print-cardinal (stream n)
-  (cond ((minusp n)
-	 (write-string "negative " stream)
-	 (format-print-cardinal-aux stream (- n) 0 n))
-	((zerop n)
-	 (write-string "zero" stream))
-	(t
-	 (format-print-cardinal-aux stream n 0 n))))
-
-(defun format-print-cardinal-aux (stream n period err)
-  (multiple-value-bind (beyond here) (truncate n 1000)
-    (unless (<= period 10)
-      (error "Number too large to print in English: ~:D" err))
-    (unless (zerop beyond)
-      (format-print-cardinal-aux stream beyond (1+ period) err))
-    (unless (zerop here)
-      (unless (zerop beyond)
-	(write-char #\space stream))
-      (format-print-small-cardinal stream here)
-      (write-string (svref cardinal-periods period) stream))))
-
-(defun format-print-ordinal (stream n)
-  (when (minusp n)
-    (write-string "negative " stream))
-  (let ((number (abs n)))
-    (multiple-value-bind
-	(top bot) (truncate number 100)
-      (unless (zerop top)
-	(format-print-cardinal stream (- number bot)))
-      (when (and (plusp top) (plusp bot))
-	(write-char #\space stream))
-      (multiple-value-bind
-	  (tens ones) (truncate bot 10)
-	(cond ((= bot 12) (write-string "twelfth" stream))
-	      ((= tens 1)
-	       (write-string (svref cardinal-teens ones) stream);;;RAD
-	       (write-string "th" stream))
-	      ((and (zerop tens) (plusp ones))
-	       (write-string (svref ordinal-ones ones) stream))
-	      ((and (zerop ones)(plusp tens))
-	       (write-string (svref ordinal-tens tens) stream))
-	      ((plusp bot)
-	       (write-string (svref cardinal-tens tens) stream)
-	       (write-char #\- stream)
-	       (write-string (svref ordinal-ones ones) stream))
-	      ((plusp number)
-	       (write-string "th" stream))
-	      (t
-	       (write-string "zeroeth" stream)))))))
-
-;;; Print Roman numerals
-
-(defun format-print-old-roman (stream n)
-  (unless (< 0 n 5000)
-    (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 stream)
-				(- i cur-val))))
-		    ((< i cur-val) i))))
-      ((zerop start))))
-
-(defun format-print-roman (stream n)
-  (unless (< 0 n 4000)
-    (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 stream)
-				(- i cur-val))))
-		    ((< i cur-val)
-		     (cond ((<= (- cur-val cur-sub-val) i)
-			    (write-char cur-sub-char stream)
-			    (write-char cur-char stream)
-			    (- i (- cur-val cur-sub-val)))
-			   (t i))))))
-	  ((zerop start))))
-
-
-;;;; Plural.
-
-(def-format-directive #\P (colonp atsignp params end)
-  (expand-bind-defaults () params
-    (let ((arg (cond
-		((not colonp)
-		 (expand-next-arg))
-		(*orig-args-available*
-		 `(if (eq orig-args args)
-		      (error 'format-error
-			     :complaint "No previous argument."
-			     :offset ,(1- end))
-		      (do ((arg-ptr orig-args (cdr arg-ptr)))
-			  ((eq (cdr arg-ptr) args)
-			   (car arg-ptr)))))
-		(*only-simple-args*
-		 (unless *simple-args*
-		   (error 'format-error
-			  :complaint "No previous argument."))
-		 (caar *simple-args*))
-		(t
-		 (throw 'need-orig-args nil)))))
-      (if atsignp
-	  `(write-string (if (eql ,arg 1) "y" "ies") stream)
-	  `(unless (eql ,arg 1) (write-char #\s stream))))))
-
-(def-format-interpreter #\P (colonp atsignp params)
-  (interpret-bind-defaults () params
-    (let ((arg (if colonp
-		   (if (eq orig-args args)
-		       (error 'format-error
-			      :complaint "No previous argument.")
-		       (do ((arg-ptr orig-args (cdr arg-ptr)))
-			   ((eq (cdr arg-ptr) args)
-			    (car arg-ptr))))
-		   (next-arg))))
-      (if atsignp
-	  (write-string (if (eql arg 1) "y" "ies") stream)
-	  (unless (eql arg 1) (write-char #\s stream))))))
-
-
-;;;; Floating point noise.
-
-(defun decimal-string (n)
-  (write-to-string n :base 10 :radix nil :escape nil))
-
-(def-format-directive #\F (colonp atsignp params)
-  (when colonp
-    (error 'format-error
-	   :complaint
-	   "Cannot specify the colon modifier with this directive."))
-  (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
-    `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
-
-(def-format-interpreter #\F (colonp atsignp params)
-  (when colonp
-    (error 'format-error
-	   :complaint
-	   "Cannot specify the colon modifier with this directive."))
-  (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
-			   params
-    (format-fixed stream (next-arg) w d k ovf pad atsignp)))
-
-(defun format-fixed (stream number w d k ovf pad atsign)
-  (if (floatp number)
-      (format-fixed-aux stream number w d k ovf pad atsign)
-      (if (rationalp number)
-	  (format-fixed-aux stream
-			    (coerce number 'single-float)
-			    w d k ovf pad atsign)
-	  (format-write-field stream
-			      (decimal-string number)
-			      w 1 0 #\space t))))
-
-;;; We return true if we overflowed, so that ~G can output the overflow char
-;;; instead of spaces.
-;;;
-(defun format-fixed-aux (stream number w d k ovf pad atsign)
-  (cond
-   ((not (or w d))
-    (prin1 number stream)
-    nil)
-   (t
-    (let ((spaceleft w))
-      (when (and w (or atsign (minusp number))) (decf spaceleft))
-      (multiple-value-bind 
-	  (str len lpoint tpoint)
-	  (lisp::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 stream))
-	       t)
-	      (t
-	       (when w (dotimes (i spaceleft) (write-char pad stream)))
-	       (if (minusp number)
-		   (write-char #\- stream)
-		   (if atsign (write-char #\+ stream)))
-	       (when lpoint (write-char #\0 stream))
-	       (write-string str stream)
-	       (when tpoint (write-char #\0 stream))
-	       nil)))))))
-
-(def-format-directive #\E (colonp atsignp params)
-  (when colonp
-    (error 'format-error
-	   :complaint
-	   "Cannot specify the colon modifier with this directive."))
-  (expand-bind-defaults
-      ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
-      params
-    `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
-			 ,atsignp)))
-
-(def-format-interpreter #\E (colonp atsignp params)
-  (when colonp
-    (error 'format-error
-	   :complaint
-	   "Cannot specify the colon modifier with this directive."))
-  (interpret-bind-defaults
-      ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
-      params
-    (format-exponential stream (next-arg) w d e k ovf pad mark atsignp)))
-
-(defun format-exponential (stream number w d e k ovf pad marker atsign)
-  (if (floatp number)
-      (format-exp-aux stream number w d e k ovf pad marker atsign)
-      (if (rationalp number)
-	  (format-exp-aux stream
-			  (coerce number 'single-float)
-			  w d e k ovf pad marker atsign)
-	  (format-write-field stream
-			      (decimal-string number)
-			      w 1 0 #\space t))))
-
-(defun format-exponent-marker (number)
-  (if (typep number *read-default-float-format*)
-      #\e
-      (typecase number
-	(single-float #\f)
-	(double-float #\d)
-	(short-float #\s)
-	(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 (stream number w d e k ovf pad marker atsign)
-  (if (not (or w d))
-      (prin1 number stream)
-      (multiple-value-bind (num expt)
-			   (lisp::scale-exponent (abs number))
-	(let* ((expt (- expt k))
-	       (estr (decimal-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 ovf e (> elen e)) ;exponent overflow
-	      (dotimes (i w) (write-char ovf stream))
-	      (multiple-value-bind
-		  (fstr flen lpoint)
-		  (lisp::flonum-to-string num spaceleft fdig k fmin)
-		(when w 
-		  (decf spaceleft flen)
-		  (when lpoint
-		    (if (> spaceleft 0)
-			(decf spaceleft)
-			(setq lpoint nil))))
-		(cond ((and w (< spaceleft 0) ovf)
-		       ;;significand overflow
-		       (dotimes (i w) (write-char ovf stream)))
-		      (t (when w
-			   (dotimes (i spaceleft) (write-char pad stream)))
-			 (if (minusp number)
-			     (write-char #\- stream)
-			     (if atsign (write-char #\+ stream)))
-			 (when lpoint (write-char #\0 stream))
-			 (write-string fstr stream)
-			 (write-char (if marker
-					 marker
-					 (format-exponent-marker number))
-				     stream)
-			 (write-char (if (minusp expt) #\- #\+) stream)
-			 (when e 
-			   ;;zero-fill before exponent if necessary
-			   (dotimes (i (- e (length estr)))
-			     (write-char #\0 stream)))
-			 (write-string estr stream)))))))))
-
-(def-format-directive #\G (colonp atsignp params)
-  (when colonp
-    (error 'format-error
-	   :complaint
-	   "Cannot specify the colon modifier with this directive."))
-  (expand-bind-defaults
-      ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
-      params
-    `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
-
-(def-format-interpreter #\G (colonp atsignp params)
-  (when colonp
-    (error 'format-error
-	   :complaint
-	   "Cannot specify the colon modifier with this directive."))
-  (interpret-bind-defaults
-      ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
-      params
-    (format-general stream (next-arg) w d e k ovf pad mark atsignp)))
-
-(defun format-general (stream number w d e k ovf pad marker atsign)
-  ;;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 stream number w d e k ovf pad marker atsign)
-      (if (rationalp number)
-	  (format-general-aux stream
-			      (coerce number 'single-float)
-			      w d e k ovf pad marker atsign)
-	  (format-write-field stream
-			      (decimal-string number)
-			      w 1 0 #\space t))))
-
-(defun format-general-aux (stream number w d e k ovf pad marker atsign)
-  (multiple-value-bind (ignore n) 
-		       (lisp::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) 
-			   (lisp::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)
-	     (let ((char (if (format-fixed-aux stream number ww dd nil
-					       ovf pad atsign)
-			     ovf
-			     #\space)))
-	       (dotimes (i ee) (write-char char stream))))
-	    (t
-	     (format-exp-aux stream number w d e (or k 1)
-			     ovf pad marker atsign))))))
-
-(def-format-directive #\$ (colonp atsignp params)
-  (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
-    `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
-		     ,atsignp)))
-
-(def-format-interpreter #\$ (colonp atsignp params)
-  (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
-    (format-dollars stream (next-arg) d n w pad colonp atsignp)))
-
-(defun format-dollars (stream number d n w pad colon atsign)
-  (if (rationalp number) (setq number (coerce number 'single-float)))
-  (if (floatp number)
-      (let* ((signstr (if (minusp number) "-" (if atsign "+" "")))
-	     (signlen (length signstr)))
-	(multiple-value-bind (str strlen ig2 ig3 pointplace)
-			     (lisp::flonum-to-string number nil d nil)
-	  (declare (ignore ig2 ig3))
-	  (when colon (write-string signstr stream))
-	  (dotimes (i (- w signlen (- n pointplace) strlen))
-	    (write-char pad stream))
-	  (unless colon (write-string signstr stream))
-	  (dotimes (i (- n pointplace)) (write-char #\0 stream))
-	  (write-string str stream)))
-      (format-write-field stream
-			  (decimal-string number)
-			  w 1 0 #\space t)))
-
-
-;;;; line/page breaks and other stuff like that.
-
-(def-format-directive #\% (colonp atsignp params)
-  (when (or colonp atsignp)
-    (error 'format-error
-	   :complaint
-	   "Cannot specify either colon or atsign for this directive."))
-  (if params
-      (expand-bind-defaults ((count 1)) params
-	`(dotimes (i ,count)
-	   (terpri stream)))
-      '(terpri stream)))
-
-(def-format-interpreter #\% (colonp atsignp params)
-  (when (or colonp atsignp)
-    (error 'format-error
-	   :complaint
-	   "Cannot specify either colon or atsign for this directive."))
-  (interpret-bind-defaults ((count 1)) params
-    (dotimes (i count)
-      (terpri stream))))
-
-(def-format-directive #\& (colonp atsignp params)
-  (when (or colonp atsignp)
-    (error 'format-error
-	   :complaint
-	   "Cannot specify either colon or atsign for this directive."))
-  (if params
-      (expand-bind-defaults ((count 1)) params
-	`(progn
-	   (fresh-line stream)
-	   (dotimes (i (1- ,count))
-	     (terpri stream))))
-      '(fresh-line stream)))
-
-(def-format-interpreter #\& (colonp atsignp params)
-  (when (or colonp atsignp)
-    (error 'format-error
-	   :complaint
-	   "Cannot specify either colon or atsign for this directive."))
-  (interpret-bind-defaults ((count 1)) params
-    (fresh-line stream)
-    (dotimes (i (1- count))
-      (terpri stream))))
-
-(def-format-directive #\| (colonp atsignp params)
-  (when (or colonp atsignp)
-    (error 'format-error
-	   :complaint
-	   "Cannot specify either colon or atsign for this directive."))
-  (if params
-      (expand-bind-defaults ((count 1)) params
-	`(dotimes (i ,count)
-	   (write-char #\page stream)))
-      '(write-char #\page stream)))
-
-(def-format-interpreter #\| (colonp atsignp params)
-  (when (or colonp atsignp)
-    (error 'format-error
-	   :complaint
-	   "Cannot specify either colon or atsign for this directive."))
-  (interpret-bind-defaults ((count 1)) params
-    (dotimes (i count)
-      (write-char #\page stream))))
-
-(def-format-directive #\~ (colonp atsignp params)
-  (when (or colonp atsignp)
-    (error 'format-error
-	   :complaint
-	   "Cannot specify either colon or atsign for this directive."))
-  (if params
-      (expand-bind-defaults ((count 1)) params
-	`(dotimes (i ,count)
-	   (write-char #\~ stream)))
-      '(write-char #\~ stream)))
-
-(def-format-interpreter #\~ (colonp atsignp params)
-  (when (or colonp atsignp)
-    (error 'format-error
-	   :complaint
-	   "Cannot specify either colon or atsign for this directive."))
-  (interpret-bind-defaults ((count 1)) params
-    (dotimes (i count)
-      (write-char #\~ stream))))
-
-(def-complex-format-directive #\newline (colonp atsignp params directives)
-  (when (and colonp atsignp)
-    (error 'format-error
-	   :complaint
-	   "Cannot specify both colon and atsign for this directive."))
-  (values (expand-bind-defaults () params
-	    (if atsignp
-		'(write-char #\newline stream)
-		nil))
-	  (if (and (not colonp)
-		   directives
-		   (simple-string-p (car directives)))
-	      (cons (string-left-trim '(#\space #\newline #\tab)
-				      (car directives))
-		    (cdr directives))
-	      directives)))
-
-(def-complex-format-interpreter #\newline (colonp atsignp params directives)
-  (when (and colonp atsignp)
-    (error 'format-error
-	   :complaint
-	   "Cannot specify both colon and atsign for this directive."))
-  (interpret-bind-defaults () params
-    (when atsignp
-      (write-char #\newline stream)))
-  (if (and (not colonp)
-	   directives
-	   (simple-string-p (car directives)))
-      (cons (string-left-trim '(#\space #\newline #\tab)
-			      (car directives))
-	    (cdr directives))
-      directives))
-
-
-;;;; Tab and simple pretty-printing noise.
-
-(def-format-directive #\T (colonp atsignp params)
-  (if colonp
-      (expand-bind-defaults ((n 1) (m 1)) params
-	`(pprint-tab ,(if atsignp :section-relative :section)
-		     ,n ,m stream))
-      (if atsignp
-	  (expand-bind-defaults ((colrel 1) (colinc 1)) params
-	    `(format-relative-tab stream ,colrel ,colinc))
-	  (expand-bind-defaults ((colnum 1) (colinc 1)) params
-	    `(format-absolute-tab stream ,colnum ,colinc)))))
-
-(def-format-interpreter #\T (colonp atsignp params)
-  (if colonp
-      (interpret-bind-defaults ((n 1) (m 1)) params
-	(pprint-tab (if atsignp :section-relative :section) n m stream))
-      (if atsignp
-	  (interpret-bind-defaults ((colrel 1) (colinc 1)) params
-	    (format-relative-tab stream colrel colinc))
-	  (interpret-bind-defaults ((colnum 1) (colinc 1)) params
-	    (format-absolute-tab stream colnum colinc)))))
-
-(defun output-spaces (stream n)
-  (let ((spaces #.(make-string 100 :initial-element #\space)))
-    (loop
-      (when (< n (length spaces))
-	(return))
-      (write-string spaces stream)
-      (decf n (length spaces)))
-    (write-string spaces stream :end n)))
-
-(defun format-relative-tab (stream colrel colinc)
-  (if (pp:pretty-stream-p stream)
-      (pprint-tab :line-relative colrel colinc stream)
-      (let* ((cur (lisp::charpos stream))
-	     (spaces (if (and cur (plusp colinc))
-			 (- (* (ceiling (+ cur colrel) colinc) colinc) cur)
-			 colrel)))
-	(output-spaces stream spaces))))
-
-(defun format-absolute-tab (stream colnum colinc)
-  (if (pp:pretty-stream-p stream)
-      (pprint-tab :line colnum colinc stream)
-      (let ((cur (lisp::charpos stream)))
-	(cond ((null cur)
-	       (write-string "  " stream))
-	      ((< cur colnum)
-	       (output-spaces stream (- colnum cur)))
-	      (t
-	       (unless (zerop colinc)
-		 (output-spaces stream (- colinc (rem cur colinc)))))))))
-
-(def-format-directive #\_ (colonp atsignp params)
-  (expand-bind-defaults () params
-    `(pprint-newline ,(if colonp
-			  (if atsignp
-			      :mandatory
-			      :fill)
-			  (if atsignp
-			      :miser
-			      :linear))
-		     stream)))
-
-(def-format-interpreter #\_ (colonp atsignp params)
-  (interpret-bind-defaults () params
-    (pprint-newline (if colonp
-			(if atsignp
-			    :mandatory
-			    :fill)
-			(if atsignp
-			    :miser
-			    :linear))
-		    stream)))
-
-(def-format-directive #\I (colonp atsignp params)
-  (when atsignp
-    (error 'format-error
-	   :complaint "Cannot specify the at-sign modifier."))
-  (expand-bind-defaults ((n 0)) params
-    `(pprint-indent ,(if colonp :current :block) ,n stream)))
-
-(def-format-interpreter #\I (colonp atsignp params)
-  (when atsignp
-    (error 'format-error
-	   :complaint "Cannot specify the at-sign modifier."))
-  (interpret-bind-defaults ((n 0)) params
-    (pprint-indent (if colonp :current :block) n stream)))
-
-
-;;;; *
-
-(def-format-directive #\* (colonp atsignp params end)
-  (if atsignp
-      (if colonp
-	  (error 'format-error
-		 :complaint "Cannot specify both colon and at-sign.")
-	  (expand-bind-defaults ((posn 0)) params
-	    (unless *orig-args-available*
-	      (throw 'need-orig-args nil))
-	    `(if (<= 0 ,posn (length orig-args))
-		 (setf args (nthcdr ,posn orig-args))
-		 (error 'format-error
-			:complaint "Index ~D out of bounds.  Should have been ~
-				    between 0 and ~D."
-			:arguments (list ,posn (length orig-args))
-			:offset ,(1- end)))))
-      (if colonp
-	  (expand-bind-defaults ((n 1)) params
-	    (unless *orig-args-available*
-	      (throw 'need-orig-args nil))
-	    `(do ((cur-posn 0 (1+ cur-posn))
-		  (arg-ptr orig-args (cdr arg-ptr)))
-		 ((eq arg-ptr args)
-		  (let ((new-posn (- cur-posn ,n)))
-		    (if (<= 0 new-posn (length orig-args))
-			(setf args (nthcdr new-posn orig-args))
-			(error 'format-error
-			       :complaint
-			       "Index ~D out of bounds.  Should have been ~
-				between 0 and ~D."
-			       :arguments
-			       (list new-posn (length orig-args))
-			       :offset ,(1- end)))))))
-	  (if params
-	      (expand-bind-defaults ((n 1)) params
-		(setf *only-simple-args* nil)
-		`(dotimes (i ,n)
-		   ,(expand-next-arg)))
-	      (expand-next-arg)))))
-
-(def-format-interpreter #\* (colonp atsignp params)
-  (if atsignp
-      (if colonp
-	  (error 'format-error
-		 :complaint "Cannot specify both colon and at-sign.")
-	  (interpret-bind-defaults ((posn 0)) params
-	    (if (<= 0 posn (length orig-args))
-		(setf args (nthcdr posn orig-args))
-		(error 'format-error
-		       :complaint "Index ~D out of bounds.  Should have been ~
-				   between 0 and ~D."
-		       :arguments (list posn (length orig-args))))))
-      (if colonp
-	  (interpret-bind-defaults ((n 1)) params
-	    (do ((cur-posn 0 (1+ cur-posn))
-		 (arg-ptr orig-args (cdr arg-ptr)))
-		((eq arg-ptr args)
-		 (let ((new-posn (- cur-posn n)))
-		   (if (<= 0 new-posn (length orig-args))
-		       (setf args (nthcdr new-posn orig-args))
-		       (error 'format-error
-			      :complaint
-			      "Index ~D out of bounds.  Should have been ~
-			       between 0 and ~D."
-			      :arguments
-			      (list new-posn (length orig-args))))))))
-	  (interpret-bind-defaults ((n 1)) params
-	    (dotimes (i n)
-	      (next-arg))))))
-
-
-;;;; Indirection.
-
-(def-format-directive #\? (colonp atsignp params string end)
-  (when colonp
-    (error 'format-error
-	   :complaint "Cannot specify the colon modifier."))
-  (expand-bind-defaults () params
-    `(handler-bind
-	 ((format-error
-	   #'(lambda (condition)
-	       (error 'format-error
-		      :complaint
-		      "~A~%while processing indirect format string:"
-		      :arguments (list condition)
-		      :print-banner nil
-		      :control-string ,string
-		      :offset ,(1- end)))))
-       ,(if atsignp
-	    (if *orig-args-available*
-		`(setf args (%format stream ,(expand-next-arg) orig-args args))
-		(throw 'need-orig-args nil))
-	    `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))
-
-(def-format-interpreter #\? (colonp atsignp params string end)
-  (when colonp
-    (error 'format-error
-	   :complaint "Cannot specify the colon modifier."))
-  (interpret-bind-defaults () params
-    (handler-bind
-	((format-error
-	  #'(lambda (condition)
-	      (error 'format-error
-		     :complaint
-		     "~A~%while processing indirect format string:"
-		     :arguments (list condition)
-		     :print-banner nil
-		     :control-string string
-		     :offset (1- end)))))
-      (if atsignp
-	  (setf args (%format stream (next-arg) orig-args args))
-	  (%format stream (next-arg) (next-arg))))))
-
-
-;;;; Capitalization.
-
-(def-complex-format-directive #\( (colonp atsignp params directives)
-  (let ((close (find-directive directives #\) nil)))
-    (unless close
-      (error 'format-error
-	     :complaint "No corresponding close paren."))
-    (let* ((posn (position close directives))
-	   (before (subseq directives 0 posn))
-	   (after (nthcdr (1+ posn) directives)))
-      (values
-       (expand-bind-defaults () params
-	 `(let ((stream (make-case-frob-stream stream
-					       ,(if colonp
-						    (if atsignp
-							:upcase
-							:capitalize)
-						    (if atsignp
-							:capitalize-first
-							:downcase)))))
-	    ,@(expand-directive-list before)))
-       after))))
-
-(def-complex-format-interpreter #\( (colonp atsignp params directives)
-  (let ((close (find-directive directives #\) nil)))
-    (unless close
-      (error 'format-error
-	     :complaint "No corresponding close paren."))
-    (interpret-bind-defaults () params
-      (let* ((posn (position close directives))
-	     (before (subseq directives 0 posn))
-	     (after (nthcdr (1+ posn) directives))
-	     (stream (make-case-frob-stream stream
-					    (if colonp
-						(if atsignp
-						    :upcase
-						    :capitalize)
-						(if atsignp
-						    :capitalize-first
-						    :downcase)))))
-	(setf args (interpret-directive-list stream before orig-args args))
-	after))))
-
-(def-complex-format-directive #\) ()
-  (error 'format-error
-	 :complaint "No corresponding open paren."))
-
-(def-complex-format-interpreter #\) ()
-  (error 'format-error
-	 :complaint "No corresponding open paren."))
-
-
-;;;; Conditionals
-
-(defun parse-conditional-directive (directives)
-  (let ((sublists nil)
-	(last-semi-with-colon-p nil)
-	(remaining directives))
-    (loop
-      (let ((close-or-semi (find-directive remaining #\] t)))
-	(unless close-or-semi
-	  (error 'format-error
-		 :complaint "No corresponding close bracket."))
-	(let ((posn (position close-or-semi remaining)))
-	  (push (subseq remaining 0 posn) sublists)
-	  (setf remaining (nthcdr (1+ posn) remaining))
-	  (when (char= (format-directive-character close-or-semi) #\])
-	    (return))
-	  (setf last-semi-with-colon-p
-		(format-directive-colonp close-or-semi)))))
-    (values sublists last-semi-with-colon-p remaining)))
-
-(def-complex-format-directive #\[ (colonp atsignp params directives)
-  (multiple-value-bind
-      (sublists last-semi-with-colon-p remaining)
-      (parse-conditional-directive directives)
-    (values
-     (if atsignp
-	 (if colonp
-	     (error 'format-error
-		    :complaint
-		    "Cannot specify both the colon and at-sign modifiers.")
-	     (if (cdr sublists)
-		 (error 'format-error
-			:complaint
-			"Can only specify one section")
-		 (expand-bind-defaults () params
-		   (expand-maybe-conditional (car sublists)))))
-	 (if colonp
-	     (if (= (length sublists) 2)
-		 (expand-bind-defaults () params
-		   (expand-true-false-conditional (car sublists)
-						  (cadr sublists)))
-		 (error 'format-error
-			:complaint
-			"Must specify exactly two sections."))
-	     (expand-bind-defaults ((index (expand-next-arg))) params
-	       (setf *only-simple-args* nil)
-	       (let ((clauses nil))
-		 (when last-semi-with-colon-p
-		   (push `(t ,@(expand-directive-list (pop sublists)))
-			 clauses))
-		 (let ((count (length sublists)))
-		   (dolist (sublist sublists)
-		     (push `(,(decf count)
-			     ,@(expand-directive-list sublist))
-			   clauses)))
-		 `(case ,index ,@clauses)))))
-     remaining)))
-
-(defun expand-maybe-conditional (sublist)
-  (flet ((hairy ()
-	   `(let ((prev-args args)
-		  (arg ,(expand-next-arg)))
-	      (when arg
-		(setf args prev-args)
-		,@(expand-directive-list sublist)))))
-    (if *only-simple-args*
-	(multiple-value-bind
-	    (guts new-args)
-	    (let ((*simple-args* *simple-args*))
-	      (values (expand-directive-list sublist)
-		      *simple-args*))
-	  (cond ((eq *simple-args* (cdr new-args))
-		 (setf *simple-args* new-args)
-		 `(when ,(caar new-args)
-		    ,@guts))
-		(t
-		 (setf *only-simple-args* nil)
-		 (hairy))))
-	(hairy))))
-
-(defun expand-true-false-conditional (true false)
-  (let ((arg (expand-next-arg)))
-    (flet ((hairy ()
-	     `(if ,arg
-		  (progn
-		    ,@(expand-directive-list true))
-		  (progn
-		    ,@(expand-directive-list false)))))
-      (if *only-simple-args*
-	  (multiple-value-bind
-	      (true-guts true-args true-simple)
-	      (let ((*simple-args* *simple-args*)
-		    (*only-simple-args* t))
-		(values (expand-directive-list true)
-			*simple-args*
-			*only-simple-args*))
-	    (multiple-value-bind
-		(false-guts false-args false-simple)
-		(let ((*simple-args* *simple-args*)
-		      (*only-simple-args* t))
-		  (values (expand-directive-list false)
-			  *simple-args*
-			  *only-simple-args*))
-	      (if (= (length true-args) (length false-args))
-		  `(if ,arg
-		       (progn
-			 ,@true-guts)
-		       ,(do ((false false-args (cdr false))
-			     (true true-args (cdr true))
-			     (bindings nil (cons `(,(caar false) ,(caar true))
-						 bindings)))
-			    ((eq true *simple-args*)
-			     (setf *simple-args* true-args)
-			     (setf *only-simple-args*
-				   (and true-simple false-simple))
-			     (if bindings
-				 `(let ,bindings
-				    ,@false-guts)
-				 `(progn
-				    ,@false-guts)))))
-		  (progn
-		    (setf *only-simple-args* nil)
-		    (hairy)))))
-	  (hairy)))))
-
-
-
-(def-complex-format-interpreter #\[ (colonp atsignp params directives)
-  (multiple-value-bind
-      (sublists last-semi-with-colon-p remaining)
-      (parse-conditional-directive directives)
-    (setf args
-	  (if atsignp
-	      (if colonp
-		  (error 'format-error
-			 :complaint
-		     "Cannot specify both the colon and at-sign modifiers.")
-		  (if (cdr sublists)
-		      (error 'format-error
-			     :complaint
-			     "Can only specify one section")
-		      (interpret-bind-defaults () params
-			(let ((prev-args args)
-			      (arg (next-arg)))
-			  (if arg
-			      (interpret-directive-list stream
-							(car sublists)
-							orig-args
-							prev-args)
-			      args)))))
-	      (if colonp
-		  (if (= (length sublists) 2)
-		      (interpret-bind-defaults () params
-			(if (next-arg)
-			    (interpret-directive-list stream (car sublists)
-						      orig-args args)
-			    (interpret-directive-list stream (cadr sublists)
-						      orig-args args)))
-		      (error 'format-error
-			     :complaint
-			     "Must specify exactly two sections."))
-		  (interpret-bind-defaults ((index (next-arg))) params
-		    (let* ((default (and last-semi-with-colon-p
-					 (pop sublists)))
-			   (last (1- (length sublists)))
-			   (sublist
-			    (if (<= 0 index last)
-				(nth (- last index) sublists)
-				default)))
-		      (interpret-directive-list stream sublist orig-args
-						args))))))
-    remaining))
-
-(def-complex-format-directive #\; ()
-  (error 'format-error
-	 :complaint
-	 "~~; not contained within either ~~[...~~] or ~~<...~~>."))
-
-(def-complex-format-interpreter #\; ()
-  (error 'format-error
-	 :complaint
-	 "~~; not contained within either ~~[...~~] or ~~<...~~>."))
-
-(def-complex-format-interpreter #\] ()
-  (error 'format-error
-	 :complaint
-	 "No corresponding open bracket."))
-
-(def-complex-format-directive #\] ()
-  (error 'format-error
-	 :complaint
-	 "No corresponding open bracket."))
-
-
-;;;; Up-and-out.
-
-(defvar *outside-args*)
-
-(def-format-directive #\^ (colonp atsignp params)
-  (when atsignp
-    (error 'format-error
-	   :complaint "Cannot specify the at-sign modifier."))
-  (when (and colonp (not *up-up-and-out-allowed*))
-    (error 'format-error
-	   :complaint "Attempt to use ~~:^ outside a ~~:{...~~} construct."))
-  `(when ,(case (length params)
-	    (0 (if colonp
-		   '(null outside-args)
-		   (progn
-		     (setf *only-simple-args* nil)
-		     '(null args))))
-	    (1 (expand-bind-defaults ((count 0)) params
-		 `(zerop ,count)))
-	    (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params
-		 `(= ,arg1 ,arg2)))
-	    (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
-		 `(<= ,arg1 ,arg2 ,arg3))))
-     ,(if colonp
-	  '(return-from outside-loop nil)
-	  '(return))))
-
-(def-format-interpreter #\^ (colonp atsignp params)
-  (when atsignp
-    (error 'format-error
-	   :complaint "Cannot specify the at-sign modifier."))
-  (when (and colonp (not *up-up-and-out-allowed*))
-    (error 'format-error
-	   :complaint "Attempt to use ~~:^ outside a ~~:{...~~} construct."))
-  (when (case (length params)
-	  (0 (if colonp
-		 (null *outside-args*)
-		 (null args)))
-	  (1 (interpret-bind-defaults ((count 0)) params
-	       (zerop count)))
-	  (2 (interpret-bind-defaults ((arg1 0) (arg2 0)) params
-	       (= arg1 arg2)))
-	  (t (interpret-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
-	       (<= arg1 arg2 arg3))))
-    (throw (if colonp 'up-up-and-out 'up-and-out)
-	   args)))
-
-
-;;;; Iteration.
-
-(def-complex-format-directive #\{ (colonp atsignp params string end directives)
-  (let ((close (find-directive directives #\} nil)))
-    (unless close
-      (error 'format-error
-	     :complaint
-	     "No corresponding close brace."))
-    (let* ((closed-with-colon (format-directive-colonp close))
-	   (posn (position close directives)))
-      (labels
-	  ((compute-insides ()
-	     (if (zerop posn)
-		 (if *orig-args-available*
-		     `((handler-bind
-			   ((format-error
-			     #'(lambda (condition)
-				 (error 'format-error
-					:complaint
-			"~A~%while processing indirect format string:"
-					:arguments (list condition)
-					:print-banner nil
-					:control-string ,string
-					:offset ,(1- end)))))
-			 (setf args
-			       (%format stream inside-string orig-args args))))
-		     (throw 'need-orig-args nil))
-		 (let ((*up-up-and-out-allowed* colonp))
-		   (expand-directive-list (subseq directives 0 posn)))))
-	   (compute-loop-aux (count)
-	     (when atsignp
-	       (setf *only-simple-args* nil))
-	     `(loop
-		,@(unless closed-with-colon
-		    '((when (null args)
-			(return))))
-		,@(when count
-		    `((when (and ,count (minusp (decf ,count)))
-			(return))))
-		,@(if colonp
-		      (let ((*expander-next-arg-macro* 'expander-next-arg)
-			    (*only-simple-args* nil)
-			    (*orig-args-available* t))
-			`((let* ((orig-args ,(expand-next-arg))
-				 (outside-args args)
-				 (args orig-args))
-			    (declare (ignorable orig-args outside-args args))
-			    (block nil
-			      ,@(compute-insides)))))
-		      (compute-insides))
-		,@(when closed-with-colon
-		    '((when (null args)
-			(return))))))
-	   (compute-loop ()
-	     (if params
-		 (expand-bind-defaults ((count nil)) params
-		   (compute-loop-aux count))
-		 (compute-loop-aux nil)))
-	   (compute-block ()
-	     (if colonp
-		 `(block outside-loop
-		    ,(compute-loop))
-		 (compute-loop)))
-	   (compute-bindings ()
-	     (if atsignp
-		 (compute-block)
-		 `(let* ((orig-args ,(expand-next-arg))
-			 (args orig-args))
-		    (declare (ignorable orig-args args))
-		    ,(let ((*expander-next-arg-macro* 'expander-next-arg)
-			   (*only-simple-args* nil)
-			   (*orig-args-available* t))
-		       (compute-block))))))
-	(values (if (zerop posn)
-		    `(let ((inside-string ,(expand-next-arg)))
-		       ,(compute-bindings))
-		    (compute-bindings))
-		(nthcdr (1+ posn) directives))))))
-
-(def-complex-format-interpreter #\{
-				(colonp atsignp params string end directives)
-  (let ((close (find-directive directives #\} nil)))
-    (unless close
-      (error 'format-error
-	     :complaint
-	     "No corresponding close brace."))
-    (interpret-bind-defaults ((max-count nil)) params
-      (let* ((closed-with-colon (format-directive-colonp close))
-	     (posn (position close directives))
-	     (insides (if (zerop posn)
-			  (next-arg)
-			  (subseq directives 0 posn)))
-	     (*up-up-and-out-allowed* colonp))
-	(labels
-	    ((do-guts (orig-args args)
-	       (if (zerop posn)
-		   (handler-bind
-		       ((format-error
-			 #'(lambda (condition)
-			     (error 'format-error
-				    :complaint
-			    "~A~%while processing indirect format string:"
-				    :arguments (list condition)
-				    :print-banner nil
-				    :control-string string
-				    :offset (1- end)))))
-		     (%format stream insides orig-args args))
-		   (interpret-directive-list stream insides
-					     orig-args args)))
-	     (bind-args (orig-args args)
-	       (if colonp
-		   (let* ((arg (next-arg))
-			  (*logical-block-popper* nil)
-			  (*outside-args* args))
-		     (catch 'up-and-out
-		       (do-guts arg arg)
-		       args))
-		   (do-guts orig-args args)))
-	     (do-loop (orig-args args)
-	       (catch (if colonp 'up-up-and-out 'up-and-out)
-		 (loop
-		   (when (and (not closed-with-colon) (null args))
-		     (return))
-		   (when (and max-count (minusp (decf max-count)))
-		     (return))
-		   (setf args (bind-args orig-args args))
-		   (when (and closed-with-colon (null args))
-		     (return)))
-		 args)))
-	  (if atsignp
-	      (setf args (do-loop orig-args args))
-	      (let ((arg (next-arg))
-		    (*logical-block-popper* nil))
-		(do-loop arg arg)))
-	  (nthcdr (1+ posn) directives))))))
-
-(def-complex-format-directive #\} ()
-  (error 'format-error
-	 :complaint "No corresponding open brace."))
-
-(def-complex-format-interpreter #\} ()
-  (error 'format-error
-	 :complaint "No corresponding open brace."))
-
-
-
-;;;; Justification.
-
-(def-complex-format-directive #\< (colonp atsignp params string end directives)
-  (multiple-value-bind
-      (segments first-semi close remaining)
-      (parse-format-justification directives)
-    (values
-     (if (format-directive-colonp close)
-	 (multiple-value-bind
-	     (prefix per-line-p insides suffix)
-	     (parse-format-logical-block segments colonp first-semi
-					 close params string end)
-	   (expand-format-logical-block prefix per-line-p insides
-					suffix atsignp))
-	 (expand-format-justification segments colonp atsignp
-				      first-semi params))
-     remaining)))
-
-(def-complex-format-interpreter #\<
-				(colonp atsignp params string end directives)
-  (multiple-value-bind
-      (segments first-semi close remaining)
-      (parse-format-justification directives)
-    (setf args
-	  (if (format-directive-colonp close)
-	      (multiple-value-bind
-		  (prefix per-line-p insides suffix)
-		  (parse-format-logical-block segments colonp first-semi
-					      close params string end)
-		(interpret-format-logical-block stream orig-args args
-						prefix per-line-p insides
-						suffix atsignp))
-	      (interpret-format-justification stream orig-args args
-					      segments colonp atsignp
-					      first-semi params)))
-    remaining))
-
-(defun parse-format-justification (directives)
-  (let ((first-semi nil)
-	(close nil)
-	(remaining directives))
-    (collect ((segments))
-      (loop
-	(let ((close-or-semi (find-directive remaining #\> t)))
-	  (unless close-or-semi
-	    (error 'format-error
-		   :complaint "No corresponding close bracket."))
-	  (let ((posn (position close-or-semi remaining)))
-	    (segments (subseq remaining 0 posn))
-	    (setf remaining (nthcdr (1+ posn) remaining)))
-	  (when (char= (format-directive-character close-or-semi)
-		       #\>)
-	    (setf close close-or-semi)
-	    (return))
-	  (unless first-semi
-	    (setf first-semi close-or-semi))))
-      (values (segments) first-semi close remaining))))
-
-(defun expand-format-justification (segments colonp atsignp first-semi params)
-  (let ((newline-segment-p
-	 (and first-semi
-	      (format-directive-colonp first-semi))))
-    (expand-bind-defaults
-	((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
-	params
-      `(let ((segments nil)
-	     ,@(when newline-segment-p
-		 '((newline-segment nil)
-		   (extra-space 0)
-		   (line-len 72))))
-	 (block nil
-	   ,@(when newline-segment-p
-	       `((setf newline-segment
-		       (with-output-to-string (stream)
-			 ,@(expand-directive-list (pop segments))))
-		 ,(expand-bind-defaults
-		      ((extra 0)
-		       (line-len '(or (lisp::line-length stream) 72)))
-		      (format-directive-params first-semi)
-		    `(setf extra-space ,extra line-len ,line-len))))
-	   ,@(mapcar #'(lambda (segment)
-			 `(push (with-output-to-string (stream)
-				  ,@(expand-directive-list segment))
-				segments))
-		     segments))
-	 (format-justification stream
-			       ,@(if newline-segment-p
-				     '(newline-segment extra-space line-len)
-				     '(nil 0 0))
-			       segments ,colonp ,atsignp
-			       ,mincol ,colinc ,minpad ,padchar)))))
-
-(defun interpret-format-justification
-       (stream orig-args args segments colonp atsignp first-semi params)
-  (interpret-bind-defaults
-      ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
-      params
-    (let ((newline-string nil)
-	  (strings nil)
-	  (extra-space 0)
-	  (line-len 0))
-      (setf args
-	    (catch 'up-and-out
-	      (when (and first-semi (format-directive-colonp first-semi))
-		(interpret-bind-defaults
-		    ((extra 0)
-		     (len (or (lisp::line-length stream) 72)))
-		    (format-directive-params first-semi)
-		  (setf newline-string
-			(with-output-to-string (stream)
-			  (setf args
-				(interpret-directive-list stream
-							  (pop segments)
-							  orig-args
-							  args))))
-		  (setf extra-space extra)
-		  (setf line-len len)))
-	      (dolist (segment segments)
-		(push (with-output-to-string (stream)
-			(setf args
-			      (interpret-directive-list stream segment
-							orig-args args)))
-		      strings))
-	      args))
-      (format-justification stream newline-string extra-space line-len strings
-			    colonp atsignp mincol colinc minpad padchar)))
-  args)
-
-(defun format-justification (stream newline-prefix extra-space line-len strings
-			     pad-left pad-right mincol colinc minpad padchar)
-  (setf strings (reverse strings))
-  (when (and (not pad-left) (not pad-right) (null (cdr strings)))
-    (setf pad-left t))
-  (let* ((num-gaps (+ (1- (length strings))
-		      (if pad-left 1 0)
-		      (if pad-right 1 0)))
-	 (chars (+ (* num-gaps minpad)
-		   (loop
-		     for string in strings
-		     summing (length string))))
-	 (length (if (> chars mincol)
-		     (+ mincol (* (ceiling (- chars mincol) colinc) colinc))
-		     mincol))
-	 (padding (- length chars)))
-    (when (and newline-prefix
-	       (> (+ (or (lisp::charpos stream) 0)
-		     length extra-space)
-		  line-len))
-      (write-string newline-prefix stream))
-    (flet ((do-padding ()
-	     (let ((pad-len (truncate padding num-gaps)))
-	       (decf padding pad-len)
-	       (decf num-gaps)
-	       (dotimes (i pad-len) (write-char padchar stream)))))
-      (when pad-left
-	(do-padding))
-      (when strings
-	(write-string (car strings) stream)
-	(dolist (string (cdr strings))
-	  (do-padding)
-	  (write-string string stream)))
-      (when pad-right
-	(do-padding)))))
-
-(defun parse-format-logical-block
-       (segments colonp first-semi close params string end)
-  (when params
-    (error 'format-error
-	   :complaint "No parameters can be supplied with ~~<...~~:>."
-	   :offset (caar params)))
-  (multiple-value-bind
-      (prefix insides suffix)
-      (multiple-value-bind (prefix-default suffix-default)
-			   (if colonp (values "(" ")") (values nil nil))
-	(flet ((extract-string (list prefix-p)
-		 (let ((directive (find-if #'format-directive-p list)))
-		   (if directive
-		       (error 'format-error
-			      :complaint
-			      "Cannot include format directives inside the ~
-			       ~:[suffix~;prefix~] segment of ~~<...~~:>"
-			      :arguments (list prefix-p)
-			      :offset (1- (format-directive-end directive)))
-		       (apply #'concatenate 'string list)))))
-	(case (length segments)
-	  (0 (values prefix-default nil suffix-default))
-	  (1 (values prefix-default (car segments) suffix-default))
-	  (2 (values (extract-string (car segments) t)
-		     (cadr segments) suffix-default))
-	  (3 (values (extract-string (car segments) t)
-		     (cadr segments)
-		     (extract-string (caddr segments) nil)))
-	  (t
-	   (error 'format-error
-		  :complaint "Too many segments for ~~<...~~:>.")))))
-    (when (format-directive-atsignp close)
-      (setf insides
-	    (add-fill-style-newlines insides
-				     string
-				     (if first-semi
-					 (format-directive-end first-semi)
-					 end))))
-    (values prefix
-	    (and first-semi (format-directive-atsignp first-semi))
-	    insides
-	    suffix)))
-
-(defun add-fill-style-newlines (list string offset)
-  (if list
-      (let ((directive (car list)))
-	(if (simple-string-p directive)
-	    (nconc (add-fill-style-newlines-aux directive string offset)
-		   (add-fill-style-newlines (cdr list)
-					    string
-					    (+ offset (length directive))))
-	    (cons directive
-		  (add-fill-style-newlines (cdr list)
-					   string
-					   (format-directive-end directive)))))
-      nil))
-
-(defun add-fill-style-newlines-aux (literal string offset)
-  (let ((end (length literal))
-	(posn 0))
-    (collect ((results))
-      (loop
-	(let ((blank (position #\space literal :start posn)))
-	  (when (null blank)
-	    (results (subseq literal posn))
-	    (return))
-	  (let ((non-blank (or (position #\space literal :start blank
-					 :test #'char/=)
-			       end)))
-	    (results (subseq literal posn non-blank))
-	    (results (make-format-directive
-		      :string string :character #\_
-		      :start (+ offset non-blank) :end (+ offset non-blank)
-		      :colonp t :atsignp nil :params nil))
-	    (setf posn non-blank))
-	  (when (= posn end)
-	    (return))))
-      (results))))
-
-(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp)
-  `(let ((arg ,(if atsignp 'args (expand-next-arg))))
-     ,@(when atsignp
-	 (setf *only-simple-args* nil)
-	 '((setf args nil)))
-     (pprint-logical-block
-	 (stream arg
-		 ,(if per-line-p :per-line-prefix :prefix) ,prefix
-		 :suffix ,suffix)
-       (let ((args arg)
-	     ,@(unless atsignp
-		 `((orig-args arg))))
-	 (declare (ignorable args ,@(unless atsignp '(orig-args))))
-	 (block nil
-	   ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
-		   (*only-simple-args* nil)
-		   (*orig-args-available* t))
-	       (expand-directive-list insides)))))))
-
-(defun interpret-format-logical-block
-       (stream orig-args args prefix per-line-p insides suffix atsignp)
-  (let ((arg (if atsignp args (next-arg))))
-    (if per-line-p
-	(pprint-logical-block
-	    (stream arg :per-line-prefix prefix :suffix suffix)
-	  (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
-	    (catch 'up-and-out
-	      (interpret-directive-list stream insides
-					(if atsignp orig-args arg)
-					arg))))
-	(pprint-logical-block (stream arg :prefix prefix :suffix suffix)
-	  (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
-	    (catch 'up-and-out
-	      (interpret-directive-list stream insides
-					(if atsignp orig-args arg)
-					arg))))))
-  (if atsignp nil args))
-
-(def-complex-format-directive #\> ()
-  (error 'format-error
-	 :complaint "No corresponding open bracket."))
-
-
-;;;; User-defined method.
-
-(def-format-directive #\/ (string start end colonp atsignp params)
-  (let ((symbol (extract-user-function-name string start end)))
-    (collect ((param-names) (bindings))
-      (dolist (param params)
-	(let ((param-name (gensym)))
-	  (param-names param-name)
-	  (bindings `(,param-name
-		      ,(case param
-			 (:arg (expand-next-arg))
-			 (:remaining '(length args))
-			 (t param))))))
-	     `(let ,(bindings)
-		(,symbol stream ,(expand-next-arg) ,colonp ,atsignp
-			 ,@(param-names))))))
-
-(def-format-interpreter #\/ (string start end colonp atsignp params)
-  (let ((symbol (extract-user-function-name string start end)))
-    (collect ((args))
-      (dolist (param params)
-	(case param
-	  (:arg (args (next-arg)))
-	  (:remaining (args (length args)))
-	  (t (args param))))
-      (apply (fdefinition symbol) stream (next-arg)
-	     colonp atsignp (args)))))
-
-(defun extract-user-function-name (string start end)
-  (let ((slash (position #\/ string :start start :end (1- end)
-			 :from-end t)))
-    (unless slash
-      (error 'format-error
-	     :complaint "Malformed ~~/ directive."))
-    (let* ((name (string-upcase (let ((foo string))
-				  ;; Hack alert: This is to keep the compiler
-				  ;; quit about deleting code inside the subseq
-				  ;; expansion.
-				  (subseq foo (1+ slash) (1- end)))))
-	   (first-colon (position #\: name))
-	   (last-colon (if first-colon (position #\: name :from-end t)))
-	   (package-name (if last-colon
-			     (subseq name 0 first-colon)
-			     "USER"))
-	   (package (find-package package-name)))
-      (unless package
-	(error 'format-error
-	       :complaint "No package named ``~A''."
-	       :arguments (list package-name)))
-      (intern (if first-colon
-		  (subseq name (1+ first-colon))
-		  name)
-	      package))))
-
diff --git a/code/generic-site.lisp b/code/generic-site.lisp
deleted file mode 100644
index 0aba116ed32d3ce21cd4d67313dfa379951518ce..0000000000000000000000000000000000000000
--- a/code/generic-site.lisp
+++ /dev/null
@@ -1,57 +0,0 @@
-;;; -*- Mode: Lisp; Package: System -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/generic-site.lisp,v 1.5 1992/05/30 12:56:53 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Generic site specific initialization for CMU CL.  This can be used as a
-;;; template for non-cmu "library:site-init" files.
-;;;
-(in-package "SYSTEM")
-
-;;; Put your site name here...
-(setq *short-site-name* "Unknown")
-(setq *long-site-name* "Site name not initialized")
-
-;;; We would appreciate it if each site establishes a local maintainer who can
-;;; filter bug reports from novice users to make sure that they really have
-;;; found a bug.  Fill in the maintainer's address here..
-(setf (getf *herald-items* :bugs)
-      '("Send bug reports and questions to your local CMU CL maintainer, or to
-cmucl-bugs@cs.cmu.edu.
-Loaded subsystems:"))
-
-;;; The following Hemlock initializations will error if run in a core without
-;;; hemlock.
-#+hemlock (progn
-;;; If you have sources installed on your system, un-comment the following form
-;;; and change it to point to the source location.  This will allow the Hemlock
-;;; "Edit Definition" command to find sources for functions in the core.  If
-;;; this doesn't work, check that first part of the translation really does
-;;; have the correct prefix.
-;;;
-#|
-(ed::add-definition-dir-translation
- "/afs/cs.cmu.edu/project/clisp-1/sun4c_41/15/"
- "<your source location here>")
-|#
-
-;;; Use standard X fonts for Hemlock, since the default ones may not work
-;;; everywhere.  By default, Hemlock used 8x13 and a non-standard underline
-;;; font, 8x13u (which is part of the distribution.)  Unfortunately, we don't
-;;; have source for this font, since it was created by hand-editing the
-;;; bitmaps.
-;;;
-(hi:setv ed::open-paren-highlighting-font "*-courier-bold-r-normal--*-120-*")
-(hi:setv ed::default-font "*-courier-medium-r-normal--*-120-*")
-(hi:setv ed::active-region-highlighting-font
-	 "*-courier-medium-o-normal--*-120-*")
-
-); #+hemlock
diff --git a/code/globals.lisp b/code/globals.lisp
deleted file mode 100644
index 8f7df7151082c710f8ee6f6ce4c80346fcb1a906..0000000000000000000000000000000000000000
--- a/code/globals.lisp
+++ /dev/null
@@ -1,53 +0,0 @@
-;;; -*- Package: Lisp; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/globals.lisp,v 1.6 1992/03/03 18:59:53 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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* *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*
-		    conditions::*handler-clusters*
-		    conditions::*restart-clusters* alloctable-address
-		    *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* char-name-alist
-		    *default-pathname-defaults* *beep-function*
-		    *gc-notify-before* *gc-notify-after*))
-
-
-(proclaim '(ftype (function (&rest t) *)
-		  c::%%defun c::%%defmacro c::%%defconstant c::%defstruct
-		  c::%%compiler-defstruct c::%proclaim 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/hppa-vm.lisp b/code/hppa-vm.lisp
deleted file mode 100644
index ce033fb51de6cbe209a8b96d03f06bfba97c4011..0000000000000000000000000000000000000000
--- a/code/hppa-vm.lisp
+++ /dev/null
@@ -1,232 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hppa-vm.lisp,v 1.5 1992/10/08 22:10:02 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the HPPA specific runtime stuff.
-;;;
-(in-package "HPPA")
-(use-package "SYSTEM")
-(use-package "ALIEN")
-(use-package "C-CALL")
-(use-package "UNIX")
-
-(export '(fixup-code-object internal-error-arguments
-	  sigcontext-program-counter sigcontext-register
-	  sigcontext-float-register sigcontext-floating-point-modes
-	  extern-alien-name sanctify-for-execution))
-
-
-;;;; The sigcontext structure.
-
-(def-alien-type save-state
-  (struct nil
-    (regs (array unsigned-long 32))
-    (filler (array unsigned-long 32))
-    (fpregs (array unsigned-long 32))))
-
-(def-alien-type sigcontext
-  (struct nil
-    (sc-onstack unsigned-long)
-    (sc-mask unsigned-long)
-    (sc-sp system-area-pointer)
-    (sc-fp system-area-pointer)
-    (sc-ap (* save-state))
-    (sc-pcsqh unsigned-long)
-    (sc-pcoqh unsigned-long)
-    (sc-pcsqt unsigned-long)
-    (sc-pcoqt unsigned-long)
-    (sc-ps unsigned-long)))
-
-
-;;;; Add machine specific features to *features*
-
-(pushnew :hppa *features*)
-
-
-
-;;;; MACHINE-TYPE and MACHINE-VERSION
-
-(defun machine-type ()
-  "Returns a string describing the type of the local machine."
-  "HPPA")
-
-(defun machine-version ()
-  "Returns a string describing the version of the local machine."
-  "HPPA")
-
-
-
-;;; FIXUP-CODE-OBJECT -- Interface
-;;;
-(defun fixup-code-object (code offset value kind)
-  (unless (zerop (rem offset word-bytes))
-    (error "Unaligned instruction?  offset=#x~X." offset))
-  (system:without-gcing
-   (let* ((sap (truly-the system-area-pointer
-			  (%primitive c::code-instructions code)))
-	  (inst (sap-ref-32 sap offset)))
-     (setf (sap-ref-32 sap offset)
-	   (ecase kind
-	     (:load
-	      (logior (ash (ldb (byte 11 0) value) 1)
-		      (logand inst #xffffc000)))
-	     (:load-short
-	      (let ((low-bits (ldb (byte 11 0) value)))
-		(assert (<= 0 low-bits (1- (ash 1 4))))
-		(logior (ash low-bits 17)
-			(logand inst #xffe0ffff))))
-	     (:hi
-	      (logior (ash (ldb (byte 5 13) value) 16)
-		      (ash (ldb (byte 2 18) value) 14)
-		      (ash (ldb (byte 2 11) value) 12)
-		      (ash (ldb (byte 11 20) value) 1)
-		      (ldb (byte 1 31) value)
-		      (logand inst #xffe00000)))
-	     (:branch
-	      (let ((bits (ldb (byte 9 2) value)))
-		(assert (zerop (ldb (byte 2 0) value)))
-		(logior (ash bits 3)
-			(logand inst #xffe0e002)))))))))
-
-
-
-;;;; Internal-error-arguments.
-
-;;; INTERNAL-ERROR-ARGUMENTS -- interface.
-;;;
-;;; Given the sigcontext, extract the internal error arguments from the
-;;; instruction stream.
-;;; 
-(defun internal-error-arguments (scp)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (let ((pc (sigcontext-program-counter scp)))
-      (declare (type system-area-pointer pc))
-      (let* ((length (sap-ref-8 pc 4))
-	     (vector (make-array length :element-type '(unsigned-byte 8))))
-	(declare (type (unsigned-byte 8) length)
-		 (type (simple-array (unsigned-byte 8) (*)) vector))
-	(copy-from-system-area pc (* byte-bits 5)
-			       vector (* word-bits
-					 vector-data-offset)
-			       (* length byte-bits))
-	(let* ((index 0)
-	       (error-number (c::read-var-integer vector index)))
-	  (collect ((sc-offsets))
-	    (loop
-	      (when (>= index length)
-		(return))
-	      (sc-offsets (c::read-var-integer vector index)))
-	    (values error-number (sc-offsets))))))))
-
-
-;;;; Sigcontext access functions.
-
-;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface
-;;;
-(defun sigcontext-program-counter (scp)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (int-sap (logandc2 (slot scp 'sc-pcoqh) 3))))
-
-;;; SIGCONTEXT-REGISTER -- Interface
-;;;
-;;; An escape register saves the value of a register for a frame that someone
-;;; interrupts.  
-;;;
-(defun sigcontext-register (scp index)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (deref (slot (slot scp 'sc-ap) 'regs) index)))
-
-(defun %set-sigcontext-register (scp index new)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (setf (deref (slot (slot scp 'sc-ap) 'regs) index) new)
-    new))
-
-(defsetf sigcontext-register %set-sigcontext-register)
-
-
-;;; SIGCONTEXT-FLOAT-REGISTER  --  Interface
-;;;
-;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
-;;; Format is the type of float to return.
-;;;
-(defun sigcontext-float-register (scp index format)
-  (declare (type (alien (* sigcontext)) scp))
-  (error "sigcontext-float-register not implimented." scp index format)
-  #+nil
-  (with-alien ((scp (* sigcontext) scp))
-    (let ((sap (alien-sap (slot scp 'sc-fpregs))))
-      (ecase format
-	(single-float (system:sap-ref-single sap (* index vm:word-bytes)))
-	(double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
-;;;
-(defun %set-sigcontext-float-register (scp index format new-value)
-  (declare (type (alien (* sigcontext)) scp))
-  (error "%set-sigcontext-float-register not implimented."
-	 scp index format new-value)
-  #+nil
-  (with-alien ((scp (* sigcontext) scp))
-    (let ((sap (alien-sap (slot scp 'sc-fpregs))))
-      (ecase format
-	(single-float
-	 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
-	(double-float
-	 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
-;;;
-(defsetf sigcontext-float-register %set-sigcontext-float-register)
-
-
-;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
-;;;
-;;;    Given a sigcontext pointer, return the floating point modes word in the
-;;; same format as returned by FLOATING-POINT-MODES.
-;;;
-(defun sigcontext-floating-point-modes (scp)
-  (declare (type (alien (* sigcontext)) scp))
-  (error "sigcontext-floating-point-modes not implimented." scp)
-  #+nil
-  (with-alien ((scp (* sigcontext) scp))
-    (slot scp 'sc-fpc-csr)))
-
-
-
-;;; EXTERN-ALIEN-NAME -- interface.
-;;;
-;;; The loader uses this to convert alien names to the form they occure in
-;;; the symbol table (for example, prepending an underscore).  On the HPPA
-;;; we just leave it alone.
-;;; 
-(defun extern-alien-name (name)
-  (declare (type simple-base-string name))
-  name)
-
-
-
-;;; SANCTIFY-FOR-EXECUTION -- Interface.
-;;;
-;;; Do whatever is necessary to make the given code component executable.
-;;; On the PA-RISC, this means flushing the data cache and purging the
-;;; inst cache.
-;;; 
-(defun sanctify-for-execution (component)
-  (without-gcing
-    (alien-funcall (extern-alien "sanctify_for_execution"
-				 (function void
-					   system-area-pointer
-					   unsigned-long))
-		   (code-instructions component)
-		   (* (code-header-ref component code-code-size-slot)
-		      word-bytes)))
-  nil)
diff --git a/code/internet.lisp b/code/internet.lisp
deleted file mode 100644
index 75ed417b3df0e5f73a28a823ef1fbaeff042bb44..0000000000000000000000000000000000000000
--- a/code/internet.lisp
+++ /dev/null
@@ -1,370 +0,0 @@
-;;; -*- Log: code.log; Package: extensions -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/internet.lisp,v 1.12 1992/12/18 19:02:13 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains an interface to internet domain sockets.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "EXTENSIONS")
-
-(use-package "ALIEN")
-(use-package "C-CALL")
-
-(export '(htonl ntohl htons ntohs lookup-host-entry host-entry host-entry-name
-	  host-entry-aliases host-entry-addr-list host-entry-addr
-	  create-unix-socket connect-to-unix-socket 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))
-
-
-(defconstant sock-stream 1)
-(defconstant sock-dgram 2)
-(defconstant sock-raw 3)
-
-(defconstant af-unix 1)
-(defconstant af-inet 2)
-
-(defconstant msg-oob 1)
-(defconstant msg-peek 2)
-(defconstant msg-dontroute 4)
-
-(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))))
-
-
-(defmacro maybe-byte-swap (var bytes)
-  (ecase (c:backend-byte-order c:*backend*)
-    (:big-endian
-     var)
-    (:little-endian
-     (let ((ldbs nil))
-       (dotimes (i bytes `(logior ,@ldbs))
-	 (push `(ash (ldb (byte 8 ,(* i 8)) ,var)
-		     ,(* (- bytes 1 i) 8))
-	       ldbs))))))
-
-(proclaim '(inline htonl ntohl htons ntohs))
-
-(defun htonl (x)
-  (maybe-byte-swap x 4))
-(defun ntohl (x)
-  (maybe-byte-swap x 4))
-(defun htons (x)
-  (maybe-byte-swap x 2))
-(defun ntohs (x)
-  (maybe-byte-swap x 2))
-
-
-;;;; Host entry operations.
-
-(defstruct host-entry
-  name
-  aliases
-  addr-type
-  addr-list)
-
-(defun host-entry-addr (host)
-  (declare (type host-entry host))
-  (car (host-entry-addr-list host)))
-
-(def-alien-type unix-sockaddr
-  (struct nil
-    (family short)
-    (path (array char 108))))
-
-(def-alien-type inet-sockaddr
-  (struct nil
-    (family short)
-    (port unsigned-short)
-    (addr unsigned-long)
-    (zero (array char 8))))
-
-(def-alien-type hostent
-  (struct nil
-    (name c-string)
-    (aliases (* c-string))
-    (addrtype int)
-    (length int)
-    (addr-list (* (* (unsigned 32))))))
-
-(def-alien-routine "gethostbyname" (* hostent)
-  (name c-string))
-
-(def-alien-routine "gethostbyaddr" (* hostent)
-  (addr unsigned-long :copy)
-  (len int)
-  (type int))
-
-(defun lookup-host-entry (host)
-  (if (typep host 'host-entry)
-      host
-      (with-alien
-	  ((hostent (* hostent) 
-		    (etypecase host
-		      (string
-		       (gethostbyname host))
-		      ((unsigned-byte 32)
-		       (gethostbyaddr host 4 af-inet)))))
-	(unless (zerop (sap-int (alien-sap hostent)))
-	  (make-host-entry
-	   :name (slot hostent 'name)
-	   :aliases
-	   (collect ((results))
-	     (iterate repeat ((index 0))
-	       (declare (type kernel:index index))
-	       (cond ((zerop (deref (cast (slot hostent 'aliases)
-					  (* (unsigned 32)))
-				    index))
-		      (results))
-		     (t
-		      (results (deref (slot hostent 'aliases) index))
-		      (repeat (1+ index))))))
-	   :addr-type (slot hostent 'addrtype)
-	   :addr-list
-	   (collect ((results))
-	     (iterate repeat ((index 0))
-	       (declare (type kernel:index index))
-	       (cond ((zerop (deref (cast (slot hostent 'addr-list)
-					  (* (unsigned 32)))
-				    index))
-		      (results))
-		     (t
-		      (results (deref (deref (slot hostent 'addr-list) index)))
-		      (repeat (1+ index)))))))))))
-
-(defun create-unix-socket (&optional (kind :stream))
-  (multiple-value-bind (proto type)
-		       (internet-protocol kind)
-    (declare (ignore proto))
-    (let ((socket (unix:unix-socket af-unix type 0)))
-      (when (minusp socket)
-	(error "Error creating socket: ~A" (unix:get-unix-error-msg)))
-      socket)))
-
-(defun connect-to-unix-socket (path &optional (kind :stream))
-  (declare (simple-string path))
-  (let ((socket (create-unix-socket kind)))
-    (with-alien ((sockaddr unix-sockaddr))
-      (setf (slot sockaddr 'family) af-unix)
-      (kernel:copy-to-system-area path
-				  (* vm:vector-data-offset vm:word-bits)
-				  (alien-sap (slot sockaddr 'path))
-				  0
-				  (* (1+ (length path)) vm:byte-bits))
-      (when (minusp (unix:unix-connect socket
-				       (alien-sap sockaddr)
-				       (alien-size unix-sockaddr :bytes)))
-	(unix:unix-close socket)
-	(error "Error connecting socket to [~A]: ~A"
-	       path (unix:get-unix-error-msg)))
-      socket)))
-
-(defun create-inet-socket (&optional (kind :stream))
-  (multiple-value-bind (proto type)
-		       (internet-protocol kind)
-    (let ((socket (unix:unix-socket af-inet type proto)))
-      (when (minusp socket)
-	(error "Error creating socket: ~A" (unix:get-unix-error-msg)))
-      socket)))
-
-(defun connect-to-inet-socket (host port &optional (kind :stream))
-  (let ((socket (create-inet-socket kind))
-	(hostent (or (lookup-host-entry host)
-		     (error "Unknown host: ~S." host))))
-    (with-alien ((sockaddr inet-sockaddr))
-      (setf (slot sockaddr 'family) af-inet)
-      (setf (slot sockaddr 'port) (htons port))
-      (setf (slot sockaddr 'addr) (host-entry-addr hostent))
-      (when (minusp (unix:unix-connect socket
-				       (alien-sap sockaddr)
-				       (alien-size inet-sockaddr :bytes)))
-	(unix:unix-close socket)
-	(error "Error connecting socket to [~A:~A]: ~A"
-	       (host-entry-name hostent)
-	       port
-	       (unix:get-unix-error-msg)))
-      socket)))
-
-(defun create-inet-listener (port &optional (kind :stream))
-  (let ((socket (create-inet-socket kind)))
-    (with-alien ((sockaddr inet-sockaddr))
-      (setf (slot sockaddr 'family) af-inet)
-      (setf (slot sockaddr 'port) (htons port))
-      (setf (slot sockaddr 'addr) 0)
-      (when (minusp (unix:unix-bind socket
-				    (alien-sap sockaddr)
-				    (alien-size inet-sockaddr :bytes)))
-	(unix:unix-close socket)
-	(error "Error binding socket to port ~a: ~a"
-	       port
-	       (unix:get-unix-error-msg))))
-    (when (eq kind :stream)
-      (when (minusp (unix:unix-listen socket 5))
-	(unix:unix-close socket)
-	(error "Error listening to socket: ~A" (unix:get-unix-error-msg))))
-    socket))
-
-(defun accept-tcp-connection (unconnected)
-  (declare (fixnum unconnected))
-  (with-alien ((sockaddr inet-sockaddr))
-    (let ((connected (unix:unix-accept unconnected
-				       (alien-sap sockaddr)
-				       (alien-size inet-sockaddr :bytes))))
-      (when (minusp connected)
-	(error "Error accepting a connection: ~A" (unix:get-unix-error-msg)))
-      (values connected (slot sockaddr 'addr)))))
-
-(defun close-socket (socket)
-  (multiple-value-bind (ok err)
-		       (unix:unix-close socket)
-    (unless ok
-      (error "Error closing socket: ~A" (unix:get-unix-error-msg err))))
-  (undefined-value))
-
-
-
-;;;; 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))
-      (cond ((minusp (unix:unix-recv (car handlers) buffer 1 msg-oob))
-	     (cerror "Ignore it"
-		     "Error recving oob data on ~A: ~A"
-		     (car handlers)
-		     (unix:get-unix-error-msg)))
-	    (t
-	     (setf handled t)
-	     (let ((char (schar buffer 0))
-		   (handled nil))
-	       (declare (base-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.")))
-  (undefined-value))
-
-;;; 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)
-	   (base-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 unix:sigurg #'sigurg-handler)
-	   (unix:unix-fcntl fd unix:f-setown (unix: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)
-	   (base-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)
-	   (base-char char))
-  (let ((buffer (make-string 1 :initial-element char)))
-    (declare (simple-string buffer))
-    (when (minusp (unix:unix-send fd buffer 1 msg-oob))
-      (error "Error sending ~S OOB to across ~A: ~A"
-	     char
-	     fd
-	     (unix:get-unix-error-msg)))))
diff --git a/code/irrat.lisp b/code/irrat.lisp
deleted file mode 100644
index 9cdf62582e6613e2fe89d7f30d5c879ceb00db9e..0000000000000000000000000000000000000000
--- a/code/irrat.lisp
+++ /dev/null
@@ -1,394 +0,0 @@
-;;; -*- Mode: Lisp; Package: KERNEL; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.10 1992/02/14 23:45:06 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains all the irrational functions.  Actually, most of the
-;;; work is done by calling out to C...
-;;;
-;;; Author: William Lott.
-;;; 
-
-(in-package "KERNEL")
-
-
-;;;; Random constants, utility functions, and macros.
-
-(defconstant pi 3.14159265358979323846264338327950288419716939937511L0)
-;(defconstant e 2.71828182845904523536028747135266249775724709369996L0)
-
-;;; Make these INLINE, since the call to C is at least as compact as a Lisp
-;;; call, and saves number consing to boot.
-;;;
-(defmacro def-math-rtn (name num-args)
-  (let ((function (intern (concatenate 'simple-string
-				       "%"
-				       (string-upcase name)))))
-    `(progn
-       (proclaim '(inline ,function))
-       (export ',function)
-       (alien:def-alien-routine (,name ,function) double-float
-	 ,@(let ((results nil))
-	     (dotimes (i num-args (nreverse results))
-	       (push (list (intern (format nil "ARG-~D" i))
-			   'double-float)
-		     results)))))))
-
-(eval-when (compile load eval)
-
-(defun handle-reals (function var)
-  `((((foreach fixnum single-float bignum ratio))
-     (coerce (,function (coerce ,var 'double-float)) 'single-float))
-    ((double-float)
-     (,function ,var))))
-
-); eval-when (compile load eval)
-
-
-;;;; Stubs for the Unix math library.
-
-;;; Please refer to the Unix man pages for details about these routines.
-
-;;; Trigonometric.
-(def-math-rtn "sin" 1)
-(def-math-rtn "cos" 1)
-(def-math-rtn "tan" 1)
-(def-math-rtn "asin" 1)
-(def-math-rtn "acos" 1)
-(def-math-rtn "atan" 1)
-(def-math-rtn "atan2" 2)
-(def-math-rtn "sinh" 1)
-(def-math-rtn "cosh" 1)
-(def-math-rtn "tanh" 1)
-(def-math-rtn "asinh" 1)
-(def-math-rtn "acosh" 1)
-(def-math-rtn "atanh" 1)
-
-;;; Exponential and Logarithmic.
-(def-math-rtn "exp" 1)
-(def-math-rtn "expm1" 1)
-(def-math-rtn "log" 1)
-(def-math-rtn "log10" 1)
-(def-math-rtn "log1p" 1)
-(def-math-rtn "pow" 2)
-(def-math-rtn "cbrt" 1)
-(def-math-rtn "sqrt" 1)
-(def-math-rtn "hypot" 2)
-
-
-;;;; Power functions.
-
-(defun exp (number)
-  "Return e raised to the power NUMBER."
-  (number-dispatch ((number number))
-    (handle-reals %exp number)
-    ((complex)
-     (* (exp (realpart number))
-	(cis (imagpart number))))))
-
-;;; INTEXP -- Handle the rational base, integer power case.
-
-(defparameter *intexp-maximum-exponent* 10000)
-
-;;; This function precisely calculates base raised to an integral power.  It
-;;; separates the cases by the sign of power, for efficiency reasons, as powers
-;;; can be calculated more efficiently if power is a positive integer.  Values
-;;; of power are calculated as positive integers, and inverted if negative.
-;;;
-(defun intexp (base power)
-  (when (> (abs power) *intexp-maximum-exponent*)
-    (cerror "Continue with calculation."
-	    "The absolute value of ~S exceeds ~S."
-	    power '*intexp-maximum-exponent* base power))
-  (cond ((minusp power)
-	 (/ (intexp base (- power))))
-	((eql base 2)
-	 (ash 1 power))
-	(t
-	 (do ((nextn (ash power -1) (ash power -1))
-	      (total (if (oddp power) base 1)
-		     (if (oddp power) (* base total) total)))
-	     ((zerop nextn) total)
-	   (setq base (* base base))
-	   (setq power nextn)))))
-
-
-;;; EXPT  --  Public
-;;;
-;;;    If an integer power of a rational, use INTEXP above.  Otherwise, do
-;;; floating point stuff.  If both args are real, we try %POW right off,
-;;; assuming it will return 0 if the result may be complex.  If so, we call
-;;; COMPLEX-POW which directly computes the complex result.  We also separate
-;;; the complex-real and real-complex cases from the general complex case.
-;;;
-(defun expt (base power)
-  "Returns BASE raised to the POWER."
-  (if (zerop power)
-      (1+ (* base power))
-      (labels ((real-expt (base power rtype)
-		 (let* ((fbase (coerce base 'double-float))
-			(fpower (coerce power 'double-float))
-			(res (coerce (%pow fbase fpower) rtype)))
-		   (if (and (zerop res) (minusp fbase))
-		       (multiple-value-bind (re im)
-					    (complex-pow fbase fpower)
-			 (%make-complex (coerce re rtype) (coerce im rtype)))
-		       res)))
-	       (complex-pow (fbase fpower)
-		 (let ((pow (%pow (- fbase) fpower))
-		       (fpower*pi (* fpower pi)))
-		   (values (* pow (%cos fpower*pi))
-			   (* pow (%sin fpower*pi))))))
-	(declare (inline real-expt))
-	(number-dispatch ((base number) (power number))
-	  (((foreach fixnum (or bignum ratio) (complex rational)) integer)
-	   (intexp base power))
-	  (((foreach single-float double-float) rational)
-	   (real-expt base power '(dispatch-type base)))
-	  (((foreach fixnum (or bignum ratio) single-float)
-	    (foreach ratio single-float))
-	   (real-expt base power 'single-float))
-	  (((foreach fixnum (or bignum ratio) single-float double-float)
-	    double-float)
-	   (real-expt base power 'double-float))
-	  ((double-float single-float)
-	   (real-expt base power 'double-float))
-	  (((foreach (complex rational) (complex float)) rational)
-	   (* (expt (abs base) power)
-	      (cis (* power (phase base)))))
-	  (((foreach fixnum (or bignum ratio) single-float double-float)
-	    complex)
-	   (if (minusp base)
-	       (/ (exp (* power (truly-the float (log (- base))))))
-	       (exp (* power (truly-the float (log base))))))
-	  (((foreach (complex float) (complex rational)) complex)
-	   (exp (* power (log base))))))))
-
-(defun log (number &optional (base nil base-p))
-  "Return the logarithm of NUMBER in the base BASE, which defaults to e."
-  (if base-p
-      (/ (log number) (log base))
-      (number-dispatch ((number number))
-	(((foreach fixnum bignum ratio single-float))
-	 (if (minusp number)
-	     (complex (log (- number)) (coerce pi 'single-float))
-	     (coerce (%log (coerce number 'double-float)) 'single-float)))
-	((double-float)
-	 (if (minusp number)
-	     (complex (log (- number)) (coerce pi 'double-float))
-	     (%log number)))
-	((complex) (complex (log (abs number)) (phase number))))))
-
-(defun sqrt (number)
-  "Return the square root of NUMBER."
-  (number-dispatch ((number number))
-    (((foreach fixnum bignum ratio single-float))
-     (if (minusp number)
-	 (exp (/ (log number) 2))
-	 (coerce (%sqrt (coerce number 'double-float)) 'single-float)))
-    ((double-float)
-     (if (minusp number)
-	 (exp (/ (log number) 2))
-	 (%sqrt number)))
-    ((complex) (exp (/ (log number) 2)))))
-
-;;; ISQRT:  Integer square root - isqrt(n)**2 <= n
-;;; Upper and lower bounds on the result are estimated using integer-length.
-;;; On each iteration, one of the bounds is replaced by their mean.
-;;; The lower bound is returned when the bounds meet or differ by only 1.
-;;; Initial bounds guarantee that lg(sqrt(n)) = lg(n)/2 iterations suffice.
-
-(defun isqrt (n)
-  "Returns the root of the nearest integer less than
-   n which is a perfect square."
-  (if (and (integerp n) (not (minusp n)))
-      (do* ((lg (integer-length n))
-	    (lo (ash 1 (ash (1- lg) -1)))
-	    (hi (+ lo (ash lo (if (oddp lg) -1 0))))) ;tighten by 3/4 if possible.
-	   ((<= (1- hi) lo) lo)
-	(let ((mid (ash (+ lo hi) -1)))
-	  (if (<= (* mid mid) n) (setq lo mid) (setq hi mid))))
-      (error "Isqrt: ~S argument must be a nonnegative integer" n)))
-
-
-
-;;;; Trigonometic and Related Functions
-
-(defun abs (number)
-  "Returns the absolute value of the number."
-  (number-dispatch ((number number))
-    (((foreach single-float double-float fixnum rational))
-     (abs number))
-    ((complex)
-     (let ((rx (realpart number))
-	   (ix (imagpart number)))
-       (etypecase rx
-	 (rational
-	  (sqrt (+ (* rx rx) (* ix ix))))
-	 (single-float
-	  (coerce (%hypot (coerce rx 'double-float)
-			  (coerce ix 'double-float))
-		  'single-float))
-	 (double-float
-	  (%hypot rx ix)))))))
-
-(defun phase (number)
-  "Returns the angle part of the polar representation of a complex number.
-  For complex numbers, this is (atan (imagpart number) (realpart number)).
-  For non-complex positive numbers, this is 0.  For non-complex negative
-  numbers this is PI."
-  (etypecase number
-    ((or rational single-float)
-     (if (minusp number)
-	 (coerce pi 'single-float)
-	 0.0f0))
-    (double-float
-     (if (minusp number)
-	 (coerce pi 'double-float)
-	 0.0d0))
-    (complex
-     (atan (imagpart number) (realpart number)))))
-
-
-(defun sin (number)  
-  "Return the sine of NUMBER."
-  (number-dispatch ((number number))
-    (handle-reals %sin number)
-    ((complex)
-     (let ((x (realpart number))
-	   (y (imagpart number)))
-       (complex (* (sin x) (cosh y)) (* (cos x) (sinh y)))))))
-
-(defun cos (number)
-  "Return the cosine of NUMBER."
-  (number-dispatch ((number number))
-    (handle-reals %cos number)
-    ((complex)
-     (let ((x (realpart number))
-	   (y (imagpart number)))
-       (complex (* (cos x) (cosh y)) (- (* (sin x) (sinh y))))))))
-
-(defun tan (number)
-  "Return the tangent of NUMBER."
-  (number-dispatch ((number number))
-    (handle-reals %tan number)
-    ((complex)
-     (let* ((num (sin number))
-	    (denom (cos number)))
-       (if (zerop denom) (error "~S undefined tangent." number)
-	   (/ num denom))))))
-
-(defun cis (theta)
-  "Return cos(Theta) + i sin(Theta), AKA exp(i Theta)."
-  (if (complexp theta)
-      (error "Argument to CIS is complex: ~S" theta)
-      (complex (cos theta) (sin theta))))
-
-(proclaim '(inline mult-by-i))
-(defun mult-by-i (number)
-  (complex (imagpart number)
-	   (- (realpart number))))
-
-(defun complex-asin (number)
-  (- (mult-by-i (log (+ (mult-by-i number) (sqrt (- 1 (* number number))))))))
-
-(defun asin (number)
-  "Return the arc sine of NUMBER."
-  (number-dispatch ((number number))
-    ((rational)
-     (if (or (> number 1) (< number -1))
-	 (complex-asin number)
-	 (coerce (%asin (coerce number 'double-float)) 'single-float)))
-    (((foreach single-float double-float))
-     (if (or (> number (coerce 1 '(dispatch-type number)))
-	     (< number (coerce -1 '(dispatch-type number))))
-	 (complex-asin number)
-	 (coerce (%asin (coerce number 'double-float))
-		 '(dispatch-type number))))
-    ((complex)
-     (complex-asin number))))
-
-(defun complex-acos (number)
-  (- (mult-by-i (log (+ number (mult-by-i (sqrt (- (* number number)))))))))
-
-(defun acos (number)
-  "Return the arc cosine of NUMBER."
-  (number-dispatch ((number number))
-    ((rational)
-     (if (or (> number 1) (< number -1))
-	 (complex-acos number)
-	 (coerce (%acos (coerce number 'double-float)) 'single-float)))
-    (((foreach single-float double-float))
-     (if (or (> number (coerce 1 '(dispatch-type number)))
-	     (< number (coerce -1 '(dispatch-type number))))
-	 (complex-acos number)
-	 (coerce (%acos (coerce number 'double-float))
-		 '(dispatch-type number))))
-    ((complex)
-     (complex-acos number))))
-
-
-(defun atan (y &optional (x nil xp))
-  "Return the arc tangent of Y if X is omitted or Y/X if X is supplied."
-  (if xp
-      (if (and (zerop x) (zerop y))
-	  (if (plusp (float-sign (float x)))
-	      y
-	      (if (minusp (float-sign (float y)))
-		  (- pi)
-		  pi))
-	  (number-dispatch ((y real) (x real))
-	    (((foreach fixnum bignum ratio single-float)
-	      (foreach fixnum bignum ratio single-float))
-	     (coerce (%atan2 (coerce y 'double-float)
-			     (coerce x 'double-float))
-		     'single-float))
-	    ((double-float (foreach fixnum bignum ratio single-float))
-	     (%atan2 y (coerce x 'double-float)))
-	    (((foreach fixnum bignum ratio single-float double-float)
-	      double-float)
-	     (%atan2 (coerce y 'double-float) x))))
-      (number-dispatch ((y number))
-	(handle-reals %atan y)
-	((complex)
-	 (let ((im (imagpart y))
-	       (re (realpart y)))
-	   (/ (- (log (complex (- 1 im) re))
-		 (log (complex (+ 1 im) (- re))))
-	      (complex 0 2)))))))
-
-
-(defun sinh (number)
-  "Return the hyperbolic sine of NUMBER."
-  (/ (- (exp number) (exp (- number))) 2))
-
-(defun cosh (number)
-  "Return the hyperbolic cosine of NUMBER."
-  (/ (+ (exp number) (exp (- number))) 2))
-
-(defun tanh (number)
-  "Return the hyperbolic tangent of NUMBER."
-  (/ (- (exp number) (exp (- number)))
-     (+ (exp number) (exp (- number)))))
-
-
-(defun asinh (number)
-  "Return the hyperbolic arc sine of NUMBER."
-  (log (+ number (sqrt (1+ (* number number))))))
-
-(defun acosh (number)
-  "Return the hyperbolic arc cosine of NUMBER."
-  (log (+ number (* (1+ number) (sqrt (/ (1- number) (1+ number)))))))
-
-(defun atanh (number)
-  "Return the hyperbolic arc tangent of NUMBER."
-  (log (* (1+ number) (sqrt (/ (- 1 (* number number)))))))
-
diff --git a/code/kernel.lisp b/code/kernel.lisp
deleted file mode 100644
index 5130b273a049f57cb204b779b5a3f1c0d8eb6bf9..0000000000000000000000000000000000000000
--- a/code/kernel.lisp
+++ /dev/null
@@ -1,140 +0,0 @@
-;;; -*- Log: code.log; Package: KERNEL -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/kernel.lisp,v 1.9 1992/12/13 16:04:30 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/kernel.lisp,v 1.9 1992/12/13 16:04:30 wlott Exp $
-;;;    
-(in-package "KERNEL")
-
-(export '(allocate-vector make-array-header function-subtype))
-
-
-(defun get-header-data (x)
-  "Return the 24 bits of data in the header of object X, which must be an
-  other-pointer object."
-  (get-header-data x))
-
-(defun set-header-data (x val)
-  "Sets the 24 bits of data in the header of object X (which must be an
-  other-pointer object) to VAL."
-  (set-header-data x val))
-
-(defun get-closure-length (x)
-  "Returns the length of the closure X.  This is one more than the number
-  of variables closed over."
-  (get-closure-length x))
-
-(defun get-lowtag (x)
-  "Returns the three-bit lowtag for the object X."
-  (get-lowtag x))
-
-(defun get-type (x)
-  "Returns the 8-bit header type for the object X."
-  (get-type x))
-
-(defun vector-sap (x)
-  "Return a System-Area-Pointer pointing to the data for the vector X, which
-  must be simple."
-  (declare (type (simple-unboxed-array (*)) x))
-  (vector-sap x))
-
-
-(defun c::binding-stack-pointer-sap ()
-  "Return a System-Area-Pointer pointing to the end of the binding stack."
-  (c::binding-stack-pointer-sap))
-
-(defun c::dynamic-space-free-pointer ()
-  "Returns a System-Area-Pointer pointing to the next free work of the current
-  dynamic space."
-  (c::dynamic-space-free-pointer))
-
-(defun c::control-stack-pointer-sap ()
-  "Return a System-Area-Pointer pointing to the end of the control stack."
-  (c::control-stack-pointer-sap))
-
-(defun function-subtype (function)
-  "Return the header typecode for FUNCTION.  Can be set with SETF."
-  (function-subtype function))
-
-(defun (setf function-subtype) (type function)
-  (setf (function-subtype function) type))
-
-(defun %function-arglist (func)
-  "Extracts the arglist from the function header FUNC."
-  (%function-arglist func))
-
-(defun %function-name (func)
-  "Extracts the name from the function header FUNC."
-  (%function-name func))
-
-(defun %function-type (func)
-  "Extracts the type from the function header FUNC."
-  (%function-type func))
-
-(defun %closure-function (closure)
-  "Extracts the function from CLOSURE."
-  (%closure-function closure))
-
-(defun c::vector-length (vector)
-  "Return the length of VECTOR.  There is no reason to use this, 'cause
-  (length (the vector foo)) is the same."
-  (c::vector-length vector))
-
-(defun %sxhash-simple-string (string)
-  "Return the SXHASH for the simple-string STRING."
-  (%sxhash-simple-string string))
-
-(defun %sxhash-simple-substrubg (string length)
-  "Return the SXHASH for the first LENGTH characters of the simple-string
-  STRING."
-  (%sxhash-simple-substring string length))
-
-(defun %closure-index-ref (closure index)
-  "Extract the INDEXth slot from CLOSURE."
-  (%closure-index-ref closure index))
-
-
-(defun allocate-vector (type length words)
-  "Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and
-  WORDS words long.  Note: it is your responsibility to assure that the
-  relation between LENGTH and WORDS is correct."
-  (allocate-vector type length words))
-
-(defun make-array-header (type rank)
-  "Allocate an array header with type code TYPE and rank RANK."
-  (make-array-header type rank))
-
-
-(defun code-instructions (code-obj)
-  "Return a SAP pointing to the instructions part of CODE-OBJ."
-  (code-instructions code-obj))
-
-(defun code-header-ref (code-obj index)
-  "Extract the INDEXth element from the header of CODE-OBJ.  Can be set with
-  setf."
-  (code-header-ref code-obj index))
-
-(defun code-header-set (code-obj index new)
-  (code-header-set code-obj index new))
-
-(defsetf code-header-ref code-header-set)
-
-
-(defun %raw-bits (object offset)
-  (declare (type index offset))
-  (kernel:%raw-bits object offset))
-
-(defun %set-raw-bits (object offset value)
-  (declare (type index offset) (type (unsigned-byte #.vm:word-bits) value))
-  (setf (kernel:%raw-bits object offset) value))
-
-(defsetf %raw-bits %set-raw-bits)
diff --git a/code/list.lisp b/code/list.lisp
deleted file mode 100644
index 8350bb6ec6c8039f7901d807eb4e91eacb6ce8f8..0000000000000000000000000000000000000000
--- a/code/list.lisp
+++ /dev/null
@@ -1,980 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/list.lisp,v 1.12 1992/05/15 19:25:46 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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
-	  complement constantly))
-
-(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))
-(proclaim '(inline assq memq))
-(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)))
-      (())
-    (declare (fixnum n) (list y 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 (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)
-  (declare (type index n))
-  "Performs the cdr function n times on a list."
-  (do ((i n (1- i))
-       (result list (cdr result)))
-      ((not (plusp i)) result)
-      (declare (type index i))))
-
-(defun last (list &optional (n 1))
-  "Returns the last N conses (not the last element!) of a list."
-  (declare (type index n))
-  (do ((checked-list list (cdr checked-list))
-       (returned-list list)
-       (index 0 (1+ index)))
-      ((atom checked-list) returned-list)
-    (declare (type index index))
-    (if (>= index n)
-	(pop returned-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)
-  "Constructs a list with size elements each set to value"
-  (declare (type index size))
-  (do ((count size (1- count))
-       (result '() (cons initial-element result)))
-      ((zerop count) result)
-    (declare (type index 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)
-      list
-      (let ((result (list (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)
-      alist
-      (let ((result
-	     (cons (if (atom (car alist))
-		       (car alist)
-		       (cons (caar alist) (cdar alist)) )
-		   nil)))
-	(do ((x (cdr alist) (cdr x))
-	     (splice result
-		     (cdr (rplacd splice
-				  (cons
-				   (if (atom (car x)) 
-				       (car x)
-				       (cons (caar x) (cdar x)))
-				   nil)))))
-	    ;; 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."
-  (if (consp object)
-      (cons (copy-tree (car object)) (copy-tree (cdr object)))
-      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
-	 (if (cdr top)
-	     (error "Argument is not a list -- ~S." top-of-top)
-	     (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."
-  (declare (list list) (type index n))
-  (let ((length (1- (length list))))
-    (declare (type index length))
-    (if (< length n)
-        ()
-        (do* ((top (cdr list) (cdr top))
-              (result (list (car list)))
-              (splice result)
-              (count length (1- count)))
-             ((= count n) result)
-          (declare (type index count))
-          (setq splice (cdr (rplacd splice (list (car top)))))))))
-
-(defun nbutlast (list &optional (n 1))
-  "Modifies List to remove the last N elements."
-  (declare (list list) (type index n))
-  (let ((length (1- (length list))))
-    (declare (type index length))
-    (if (< length n) ()
-        (do ((1st (cdr list) (cdr 1st))
-             (2nd list 1st)
-             (count length (1- count)))
-            ((= count n)
-             (rplacd 2nd ())
-             list)
-          (declare (type index count))))))
-
-(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 (type index n))
-  "Sets the Nth element of List (zero based) to Newval."
-  (do ((count n (1- count))
-       (list list (cdr list)))
-      ((endp list)
-       (error "~S is too large an index for SETF of NTH." n))
-    (declare (fixnum count))
-    (when (<= count 0)
-      (rplaca list newval)
-      (return newval))))
-
-
-;;;; 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."
-  (declare (inline assoc))
-  (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."
-  (declare (inline assoc))
-  (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)"
-  (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)"
-  (do ((list list (cdr list)))
-      ((endp list) ())
-    (if (not (funcall test (funcall key (car list))))
-	(return list))))
-
-(defun tailp (sublist list)
-  "Returns T if (EQL Sublist (NTHCDR <n> List)) for some value of <n>, NIL
-  otherwise."
-  (do ((list list (cdr list)))
-      ((atom list) (eql list sublist))
-    (if (eql sublist list)
-	(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"
-  (declare (inline 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."
-  (declare (inline member))
-  (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."
-  (declare (inline member))
-  (if (and testp notp)
-      (error "Test and test-not both supplied."))
-  (let ((res list2)
-	(list1 list1))
-    (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."
-  (declare (inline member))
-  (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."
-  (declare (inline member))
-  (if (and testp notp)
-      (error "Test and test-not both supplied."))
-  (let ((res nil)
-	(list1 list1))
-    (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."
-  (declare (inline member))
-  (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."
-  (declare (inline member))
-  (if (and testp notp)
-      (error "Test and test-not both supplied."))
-  (let ((res nil)
-	(list1 list1))
-    (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."
-  (declare (inline member))
-  (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 ((list1 list1)
-       (list2 list2)
-       (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."
-  (declare (inline member))
-  (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)
-
-
-(defun complement (function)
-  "Builds a new function that returns T whenever FUNCTION returns NIL and
-   NIL whenever FUNCTION returns T."
-  #'(lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p)
-		       &rest more-args)
-      (not (cond (more-args (apply function arg0 arg1 arg2 more-args))
-		 (arg2-p (funcall function arg0 arg1 arg2))
-		 (arg1-p (funcall function arg0 arg1))
-		 (arg0-p (funcall function arg0))
-		 (t (funcall function))))))
-
-
-(defun constantly (value &optional (val1 nil val1-p) (val2 nil val2-p)
-			 &rest more-values)
-  "Builds a function that always returns VALUE, and posisbly MORE-VALUES."
-  (cond (more-values
-	 (let ((list (list* value val1 val2 more-values)))
-	   #'(lambda ()
-	       (declare (optimize (speed 3) (safety 0)))
-	       (values-list list))))
-	(val2-p
-	 #'(lambda ()
-	     (declare (optimize (speed 3) (safety 0)))
-	     (values value val1 val2)))
-	(val1-p
-	 #'(lambda ()
-	     (declare (optimize (speed 3) (safety 0)))
-	     (values value val1)))
-	(t
-	 #'(lambda ()
-	     (declare (optimize (speed 3) (safety 0)))
-	     value))))
-
-
-;;; Functions that operate on association lists
-
-(defun acons (key datum alist)
-  "Construct a new alist by adding the pair (key . datum) to alist"
-  (cons (cons key datum) alist))
-
-(defun pairlis (keys data &optional (alist '()))
-  "Construct an association list from keys and data (adding to alist)"
-  (do ((x keys (cdr x))
-       (y data (cdr y)))
-      ((and (endp x) (endp y)) alist)
-    (if (or (endp x) (endp y)) 
-	(error "The lists of keys and data are of unequal length."))
-    (setq alist (acons (car x) (car y) alist))))
-
-;;; In run-time environment, since these guys can be inline expanded.
-(defmacro assoc-guts (test-guy)
-  `(do ((alist alist (cdr alist)))
-       ((endp alist))
-     (if (car alist)
-	 (if ,test-guy (return (car alist))))))
-
-(defun assoc (item alist &key key 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"
-  (member item list :test #'eq))
-
-(defun assq (item alist)
-  "Return the first pair of alist where item EQ the key of pair"
-  (assoc item alist :test #'eq))
-
-(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/mach-os.lisp b/code/mach-os.lisp
deleted file mode 100644
index c40f6bb923811f63ffeb88bfa10ff559f11011fe..0000000000000000000000000000000000000000
--- a/code/mach-os.lisp
+++ /dev/null
@@ -1,77 +0,0 @@
-;;; -*- Package: SYSTEM -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/mach-os.lisp,v 1.9 1992/07/03 00:09:31 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; OS interface functions for CMU CL under Mach.
-;;;
-;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan.
-;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too.
-;;;
-(in-package "SYSTEM")
-(use-package "EXTENSIONS")
-(export '(get-system-info get-page-size os-init))
-(export '(*task-self* *task-data* *task-notify*))
-
-(pushnew :mach *features*)
-(setq *software-type* "MACH/4.3BSD")
-
-(defconstant foreign-segment-start #x00C00000)
-(defconstant foreign-segment-size  #x00400000)
- 
-(defun software-version ()
-  "Returns a string describing version of the supporting software."
-  (string-trim '(#\newline)
-	       (with-output-to-string (stream)
-		 (run-program "/usr/cs/etc/version" ; Site dependent???
-			      nil :output stream))))
-
-
-;;; 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.
-
-(defvar *task-self*)
-
-(defun os-init ()
-  (setf *task-self* (mach:mach-task_self)))
-
-
-;;; GET-SYSTEM-INFO  --  Interface
-;;;
-;;;    Return system time, user time and number of page faults.  For
-;;; page-faults, we add pagein and pageout, since that is a somewhat more
-;;; interesting number than the total faults.
-;;;
-(defun get-system-info ()
-  (multiple-value-bind (err? utime stime maxrss ixrss idrss
-			     isrss minflt majflt)
-		       (unix:unix-getrusage unix:rusage_self)
-    (declare (ignore maxrss ixrss idrss isrss minflt majflt))
-    (unless err?
-      (error "Unix system call getrusage failed: ~A."
-	     (unix:get-unix-error-msg utime)))
-    
-    (multiple-value-bind (gr ps fc ac ic wc zf ra in ot)
-			 (mach:vm_statistics *task-self*)
-      (declare (ignore ps fc ac ic wc zf ra))
-      (mach:gr-error 'mach:vm_statistics gr)
-      
-      (values utime stime (+ in ot)))))
-
-
-;;; GET-PAGE-SIZE  --  Interface
-;;;
-;;;    Return the system page size.
-;;;
-(defun get-page-size ()
-  (mach:gr-call* mach:vm_statistics *task-self*))
-
diff --git a/code/mach.lisp b/code/mach.lisp
deleted file mode 100644
index ae722d7915e49812b2fbfd5793b7841f1bf85627..0000000000000000000000000000000000000000
--- a/code/mach.lisp
+++ /dev/null
@@ -1,168 +0,0 @@
-;;; -*- Package: MACH -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/mach.lisp,v 1.3 1992/02/15 13:00:05 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the low-level support for MACH features not found
-;;; in UNIX.
-;;;
-
-(in-package "MACH")
-(use-package "ALIEN")
-(use-package "C-CALL")
-(use-package "SYSTEM")
-
-(export '(port mach-task_self mach-task_data mach-task_notify
-	  kern-success get-mach-error-msg
-	  gr-error gr-call gr-call* gr-bind
-	  vm_allocate vm_copy vm_deallocate vm_statistics))
-
-
-;;;; Standard ports.
-
-(def-alien-type port int)
-
-(def-alien-routine ("task_self" mach-task_self) port)
-(def-alien-routine ("thread_reply" mach-task_data) port)
-(def-alien-routine ("task_notify" mach-task_notify) port)
-
-
-
-;;;; Return codes.
-
-(def-alien-type kern-return int)
-
-(defconstant kern-success 0)
-(defconstant kern-invalid-address 1)
-(defconstant kern-protection-failure 2)
-(defconstant kern-no-space 3)
-(defconstant kern-invalid-argument 4)
-(defconstant kern-failure 5)
-(defconstant kern-resource-shortage 6)
-(defconstant kern-not-receiver 7)
-(defconstant kern-no-access 8)
-(defconstant kern-memory-failure 9)
-(defconstant kern-memory-error 10)
-(defconstant kern-already-in-set 11)
-(defconstant kern-not-in-set 12)
-(defconstant kern-name-exists 13)
-(defconstant kern-aborted 14)
-(defconstant kern-memory-present 23)
-
-(def-alien-routine ("mach_error_string" get-mach-error-msg) c-string
-  (errno kern-return))
-
-;;; GR-Error  --  Public
-;;;
-(defun gr-error (function gr &optional context)
-  "Signal an error indicating that Function returned code GR.  If the code
-  is success, then do nothing."
-  (unless (eql gr kern-success)
-    (error "~S~@[ ~A~], ~(~A~)." function context (get-mach-error-msg gr))))
-
-;;; GR-Call  --  Public
-;;;
-(defmacro gr-call (fun &rest args)
-  "GR-Call Function {Arg}*
-  Call the function with the specified Args and signal an error if the
-  first value returned is not mach:kern-success.  Nil is returned."
-  (let ((n-gr (gensym)))
-    `(let ((,n-gr (,fun ,@args)))
-       (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr)))))
-
-;;; GR-Call*  --  Public
-;;;
-(defmacro gr-call* (fun &rest args)
-  "GR-Call* Function {Arg}*
-  Call the function with the specified Args and signal an error if the
-  first value returned is not mach:kern-success.  The second value is
-  returned."
-  (let ((n-gr (gensym))
-	(n-res (gensym)))
-    `(multiple-value-bind (,n-gr ,n-res) (,fun ,@args)
-       (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr))
-       ,n-res)))
-
-;;; GR-Bind  --  Public
-;;;
-(defmacro gr-bind (vars (fun . args) &body (body decls))
-  "GR-Bind ({Var}*) (Function {Arg}*) {Form}*
-  Call the function with the specified Args and signal an error if the
-  first value returned is not mach:Kern-Success.  If the call succeeds,
-  the Forms are evaluated with remaining return values bound to the
-  Vars."
-  (let ((n-gr (gensym)))
-    `(multiple-value-bind (,n-gr ,@vars) (,fun ,@args)
-       ,@decls
-       (unless (eql ,n-gr kern-success) (gr-error ',fun ,n-gr))
-       ,@body)))
-
-
-
-;;;; VM routines.
-
-(export '(vm_allocate vm_copy vm_deallocate vm_statistics))
-
-(def-alien-routine ("vm_allocate" vm_allocate) int
-  (task port)
-  (address system-area-pointer :in-out)
-  (size unsigned-long)
-  (anywhere boolean))
-
-(def-alien-routine ("vm_copy" vm_copy) int
-  (task port)
-  (source system-area-pointer)
-  (count unsigned-long)
-  (dest system-area-pointer))
-
-(def-alien-routine ("vm_deallocate" vm_deallocate) int
-  (task port)
-  (address system-area-pointer)
-  (size unsigned-long))
-
-
-(def-alien-type nil
-  (struct vm_statistics
-    (pagesize long)
-    (free_count long)
-    (active_count long)
-    (inactive_count long)
-    (wire_count long)
-    (zero_fill_count long)
-    (reactivations long)
-    (pageins long)
-    (pageouts long)
-    (faults long)
-    (cow_faults long)
-    (lookups long)
-    (hits long)))
-
-(defun vm_statistics (task)
-  (with-alien ((vm_stats (struct vm_statistics)))
-    (values
-     (alien-funcall (extern-alien "vm_statistics"
-				  (function int
-					    port
-					    (* (struct vm_statistics))))
-		    task (alien-sap vm_stats))
-     (slot vm_stats 'pagesize)
-     (slot vm_stats 'free_count)
-     (slot vm_stats 'active_count)
-     (slot vm_stats 'inactive_count)
-     (slot vm_stats 'wire_count)
-     (slot vm_stats 'zero_fill_count)
-     (slot vm_stats 'reactivations)
-     (slot vm_stats 'pageins)
-     (slot vm_stats 'pageouts)
-     (slot vm_stats 'faults)
-     (slot vm_stats 'cow_faults)
-     (slot vm_stats 'lookups)
-     (slot vm_stats 'hits))))
diff --git a/code/machdef.lisp b/code/machdef.lisp
deleted file mode 100644
index 9f8766ff615ff96a1364984ec073835304179f35..0000000000000000000000000000000000000000
--- a/code/machdef.lisp
+++ /dev/null
@@ -1,80 +0,0 @@
-;;; -*- Log: code.log; Package: Mach -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/machdef.lisp,v 1.5 1991/02/08 13:34:05 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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))
-
-(export '(int-array int-array-ref))
-
-(def-c-type c-string (pointer simple-base-string))
-
-(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)))
-
-(defrecord timezone
-  (minuteswest (signed-byte 32) (long-words 1))
-  (dsttime (signed-byte 32) (long-words 1)))
-
-(def-c-array int-array unsigned-long 32)
-
-(eval-when (compile load eval)
-
-(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)))
-
-(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)))
-
-); eval-when (compile load eval)
-
-
-(defmacro with-trap-arg-block (type var &body forms)
-  `(with-stack-alien (,var ,type (record-size ',type))
-     ,@forms))
-
-;;; SIGMASK -- Public
-;;;
-(defmacro sigmask (&rest signals)
-  "Returns a mask given a set of signals."
-  (apply #'logior
-	 (mapcar #'(lambda (signal)
-		     (ash 1 (1- (unix-signal-number signal))))
-		 signals)))
-
diff --git a/code/mipsstrops.lisp b/code/mipsstrops.lisp
deleted file mode 100644
index ca01eeaaf1df0ead06e6c5b92e3bddabfcded727..0000000000000000000000000000000000000000
--- a/code/mipsstrops.lisp
+++ /dev/null
@@ -1,219 +0,0 @@
-;;; -*- Log: Code.Log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/mipsstrops.lisp,v 1.7 1992/03/14 02:18:07 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    String hacking functions that are stubs for things that might
-;;; be microcoded someday.
-;;;
-;;;    Written by Rob MacLachlan and Skef Wholey
-;;;
-(in-package "SYSTEM")
-(export '(%sp-reverse-find-character-with-attribute))
-
-(in-package "LISP")
-
-;(defun %sp-byte-blt (src-string src-start dst-string dst-start dst-end)
-;  "Moves bytes from Src-String into Dst-String between Dst-Start (inclusive)
-;and Dst-End (exclusive) (Dst-Start - Dst-End bytes are moved).  Overlap of the
-;strings does not affect the result.  This would be done on the Vax
-;with MOVC3. The arguments do not need to be strings: 8-bit U-Vectors
-;are also acceptable."
-;  (%primitive byte-blt src-string src-start dst-string dst-start dst-end))
-
-(defun %sp-string-compare (string1 start1 end1 string2 start2 end2)
-  (declare (simple-string string1 string2))
-  (declare (fixnum start1 end1 start2 end2))
-  "Compares the substrings specified by String1 and String2 and returns
-NIL if the strings are String=, or the lowest index of String1 in
-which the two differ. If one string is longer than the other and the
-shorter is a prefix of the longer, the length of the shorter + start1 is
-returned. This would be done on the Vax with CMPC3. The arguments must
-be simple strings."
-  (let ((len1 (- end1 start1))
-	(len2 (- end2 start2)))
-    (declare (fixnum len1 len2))
-    (cond
-     ((= len1 len2)
-      (do ((index1 start1 (1+ index1))
-	   (index2 start2 (1+ index2)))
-	  ((= index1 end1) nil)
-	(declare (fixnum index1 index2))
-	(if (char/= (schar string1 index1) (schar string2 index2))
-	    (return index1))))
-     ((> len1 len2)
-      (do ((index1 start1 (1+ index1))
-	   (index2 start2 (1+ index2)))
-	  ((= index2 end2) index1)
-	(declare (fixnum index1 index2))
-	(if (char/= (schar string1 index1) (schar string2 index2))
-	    (return index1))))
-     (t
-      (do ((index1 start1 (1+ index1))
-	   (index2 start2 (1+ index2)))
-	  ((= index1 end1) index1)
-	(declare (fixnum index1 index2))
-	(if (char/= (schar string1 index1) (schar string2 index2))
-	    (return index1)))))))
-
-(defun %sp-reverse-string-compare (string1 start1 end1 string2 start2 end2)
-  (declare (simple-string string1 string2))
-  (declare (fixnum start1 end1 start2 end2))
-  "Like %sp-string-compare, only backwards."
-  (let ((len1 (- end1 start1))
-	(len2 (- end2 start2)))
-    (declare (fixnum len1 len2))
-    (cond
-     ((= len1 len2)
-      (do ((index1 (1- end1) (1- index1))
-	   (index2 (1- end2) (1- index2)))
-	  ((< index1 start1) nil)
-	(declare (fixnum index1 index2))
-	(if (char/= (schar string1 index1) (schar string2 index2))
-	    (return index1))))
-     ((> len1 len2)
-      (do ((index1 (1- end1) (1- index1))
-	   (index2 (1- end2) (1- index2)))
-	  ((< index2 start2) index1)
-	(declare (fixnum index1 index2))
-	(if (char/= (schar string1 index1) (schar string2 index2))
-	    (return index1))))
-     (t
-      (do ((index1 (1- end1) (1- index1))
-	   (index2 (1- end2) (1- index2)))
-	  ((< index1 start1) index1)
-	(declare (fixnum index1 index2))
-	(if (char/= (schar string1 index1) (schar string2 index2))
-	    (return index1)))))))
-
-(defmacro maybe-sap-maybe-string ((var) &body body)
-  `(etypecase ,var
-     (system-area-pointer
-      (macrolet ((byte-ref (index)
-		   `(sap-ref-8 ,',var ,index))
-		 (char-ref (index)
-		   `(code-char (byte-ref ,index))))
-	,@body))
-     (simple-string
-      (macrolet ((char-ref (index)
-		   `(schar ,',var ,index))
-		 (byte-ref (index)
-		   `(char-code (char-ref ,index))))
-	,@body))))
-
-(defun %sp-find-character-with-attribute (string start end table mask)
-  (declare (type (simple-array (unsigned-byte 8) (256)) table)
-	   (type (or simple-string system-area-pointer) string)
-	   (fixnum start end mask))
-  "%SP-Find-Character-With-Attribute  String, Start, End, Table, Mask
-  The codes of the characters of String from Start to End are used as indices
-  into the Table, which is a U-Vector of 8-bit bytes. When the number picked
-  up from the table bitwise ANDed with Mask is non-zero, the current
-  index into the String is returned. The corresponds to SCANC on the Vax."
-  (maybe-sap-maybe-string (string)
-    (do ((index start (1+ index)))
-	((>= index end) nil)
-      (declare (fixnum index))
-      (unless (zerop (logand (aref table (byte-ref index)) mask))
-	(return index)))))
-
-(defun %sp-reverse-find-character-with-attribute (string start end table mask)
-  "Like %SP-Find-Character-With-Attribute, only sdrawkcaB."
-  (declare (type (or simple-string system-area-pointer) string)
-	   (fixnum start end mask)
-	   (type (array (unsigned-byte 8) (256)) table))
-  (maybe-sap-maybe-string (string)
-    (do ((index (1- end) (1- index)))
-	((< index start) nil)
-      (declare (fixnum index))
-      (unless (zerop (logand (aref table (byte-ref index)) mask))
-	(return index)))))
-
-(defun %sp-find-character (string start end character)
-  "%SP-Find-Character  String, Start, End, Character
-  Searches String for the Character from Start to End.  If the character is
-  found, the corresponding index into String is returned, otherwise NIL is
-  returned."
-  (declare (fixnum start end)
-	   (type (or simple-string system-area-pointer) string)
-	   (base-char character))
-  (maybe-sap-maybe-string (string)
-    (do ((index start (1+ index)))
-	((>= index end) nil)
-      (declare (fixnum index))
-      (when (char= (char-ref index) character)
-	(return index)))))
-
-(defun %sp-reverse-find-character (string start end character)
-  (declare (type (or simple-string system-area-pointer) string)
-	   (fixnum start end)
-	   (base-char character))
-  "%SP-Reverse-Find-Character  String, Start, End, Character
-  Searches String for Character from End to Start.  If the character is
-  found, the corresponding index into String is returned, otherwise NIL is
-  returned."
-  (maybe-sap-maybe-string (string)
-    (do ((index (1- end) (1- index))
-	 (terminus (1- start)))
-	((= index terminus) nil)
-      (declare (fixnum terminus index))
-      (if (char= (char-ref index) character)
-	  (return index)))))
-
-(defun %sp-skip-character (string start end character)
-  (declare (type (or simple-string system-area-pointer) string)
-	   (fixnum start end)
-	   (base-char character))
-  "%SP-Skip-Character  String, Start, End, Character
-  Returns the index of the first character between Start and End which
-  is not Char=  to Character, or NIL if there is no such character."
-  (maybe-sap-maybe-string (string)
-    (do ((index start (1+ index)))
-	((= index end) nil)
-      (declare (fixnum index))
-      (if (char/= (char-ref index) character)
-	  (return index)))))
-
-(defun %sp-reverse-skip-character (string start end character)
-  (declare (type (or simple-string system-area-pointer) string)
-	   (fixnum start end)
-	   (base-char character))
-  "%SP-Skip-Character  String, Start, End, Character
-  Returns the index of the last character between Start and End which
-  is not Char=  to Character, or NIL if there is no such character."
-  (maybe-sap-maybe-string (string)
-    (do ((index (1- end) (1- index))
-	 (terminus (1- start)))
-	((= index terminus) nil)
-      (declare (fixnum terminus index))
-      (if (char/= (char-ref index) character)
-	  (return index)))))
-
-(defun %sp-string-search (string1 start1 end1 string2 start2 end2)
-  "%SP-String-Search  String1, Start1, End1, String2, Start2, End2
-   Searches for the substring of String1 specified in String2.
-   Returns an index into String2 or NIL if the substring wasn't
-   found."
-  (declare (simple-string string1 string2))
-  (do ((index2 start2 (1+ index2)))
-      ((= index2 end2) nil)
-    (declare (fixnum index2))
-    (when (do ((index1 start1 (1+ index1))
-	       (index2 index2 (1+ index2)))
-	      ((= index1 end1) t)
-	    (declare (fixnum index1 index2))
-	    (when (= index2 end2)
-	      (return-from %sp-string-search nil))
-	    (when (char/= (char string1 index1) (char string2 index2))
-	      (return nil)))
-      (return index2))))
-
-
diff --git a/code/misc.lisp b/code/misc.lisp
deleted file mode 100644
index 5d0eeaf012bc557373d68b60a10a68828be33421..0000000000000000000000000000000000000000
--- a/code/misc.lisp
+++ /dev/null
@@ -1,169 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/misc.lisp,v 1.17 1993/01/13 17:33:21 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Environment query functions, documentation and dribble.
-;;;
-;;; 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))
-
-(in-package "SYSTEM")
-(export '(*software-type* *short-site-name* *long-site-name*))
-
-(in-package "EXT")
-(export 'featurep)
-
-(in-package "LISP")
-
-
-(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."
-  (values
-   (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 :cmu17 :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."
-  (if (consp x)
-      (case (car x)
-	((:not not) (not (featurep (cadr x))))
-	((:and and) (every #'featurep (cdr x)))
-	((:or or) (some #'featurep (cdr x)))
-	(t
-	 (error "Unknown operator in feature expression: ~S." x)))
-      (not (null (memq x *features*)))))
-
-
-;;; 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-instance ()
-  "Returns a string giving the name of the local machine."
-  (unix:unix-gethostname))
-
-(defvar *software-type* "Unix"
-  "The value of SOFTWARE-TYPE.  Set in FOO-os.lisp.")
-
-(defun software-type ()
-  "Returns a string describing the supporting software."
-  *software-type*)
-
-(defvar *short-site-name* "Unknown"
-  "The value of SHORT-SITE-NAME.  Set in library:site-init.lisp.")
-
-(defun short-site-name ()
-  "Returns a string with the abbreviated site name."
-  *short-site-name*)
-
-(defvar *long-site-name* "Site name not initialized"
-  "The value of LONG-SITE-NAME.  Set in library:site-init.lisp.")
-
-(defun long-site-name ()
-  "Returns a string with the long form of the site name."
-  *long-site-name*)
-
-
-;;;; Dribble stuff:
-
-;;; Each time we start dribbling to a new stream, we put it in
-;;; *dribble-stream*, and push a list of *dribble-stream*, *standard-input*,
-;;; *standard-output* and *error-output* in *previous-streams*.
-;;; *standard-output* and *error-output* is changed to a broadcast stream that
-;;; broadcasts to *dribble-stream* and to the old values of the variables.
-;;; *standard-input* is changed to an echo stream that echos input from the old
-;;; value of standard input to *dribble-stream*.
-;;;
-;;; When dribble is called with no arguments, *dribble-stream* is closed,
-;;; and the values of *dribble-stream*, *standard-input*, and
-;;; *standard-output* are poped from *previous-streams*.
-
-(defvar *previous-streams* nil)
-(defvar *dribble-stream* nil)
-
-(defun dribble (&optional pathname &key (if-exists :append))
-  "With a file name as an argument, dribble opens the file and
-   sends a record of further I/O to that file.  Without an
-   argument, it closes the dribble file, and quits logging."
-  (cond (pathname
-	 (let* ((new-dribble-stream
-		 (open pathname :direction :output :if-exists if-exists
-		       :if-does-not-exist :create))
-		(new-standard-output
-		 (make-broadcast-stream *standard-output* new-dribble-stream))
-		(new-error-output
-		 (make-broadcast-stream *error-output* new-dribble-stream))
-		(new-standard-input
-		 (make-echo-stream *standard-input* new-dribble-stream)))
-	   (push (list *dribble-stream* *standard-input* *standard-output*
-		       *error-output*)
-		 *previous-streams*)
-	   (setf *dribble-stream* new-dribble-stream)
-	   (setf *standard-input* new-standard-input)
-	   (setf *standard-output* new-standard-output)
-	   (setf *error-output* new-error-output)))
-	((null *dribble-stream*)
-	 (error "Not currently dribbling."))
-	(t
-	 (let ((old-streams (pop *previous-streams*)))
-	   (close *dribble-stream*)
-	   (setf *dribble-stream* (first old-streams))
-	   (setf *standard-input* (second old-streams))
-	   (setf *standard-output* (third old-streams))
-	   (setf *error-output* (fourth old-streams)))))
-  (values))
diff --git a/code/module.lisp b/code/module.lisp
deleted file mode 100644
index 52fd1e86c6a3455687602c939735b7b6d160c5ee..0000000000000000000000000000000000000000
--- a/code/module.lisp
+++ /dev/null
@@ -1,99 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/module.lisp,v 1.2 1992/12/16 12:32:10 ram Exp $")
-;;;
-;;; **********************************************************************
-
-;;; Code written by Jim Muller.
-;;; Rewritten by Bill Chiles.
-;;;
-;;; Note that this module file is based on the old system, and is being
-;;; spliced into the current sources to reflect the last minute deprecated
-;;; addition of modules to the X3J13 ANSI standard.
-;;;
-(in-package 'lisp)
-
-(export '(*modules* provide require))
-
-
-(in-package "EXTENSIONS")
-(export '(*require-verbose* defmodule))
-(in-package 'lisp)
-
-
-
-;;;; Exported specials.
-
-(defvar *modules* ()
-  "This is a list of module names that have been loaded into Lisp so far.
-   It is used by PROVIDE and REQUIRE.")
-
-(defvar *require-verbose* t
-  "*load-verbose* is bound to this before loading files.")
-
-;;;; Defmodule.
-
-(defvar *module-file-translations* (make-hash-table :test #'equal))
-(defmacro defmodule (name &rest files)
-  "Defines a module by registering the files that need to be loaded when
-   the module is required.  If name is a symbol, its print name is used
-   after downcasing it."
-  `(%define-module ,name ',files))
-
-(defun %define-module (name files)
-  (setf (gethash (module-name-string name) *module-file-translations*)
-        files))
-
-(defun module-files (name)
-  (gethash name *module-file-translations*))
-
-
-
-;;;; Provide and Require.
-
-(defun provide (module-name)
-  "Adds a new module name to *modules* indicating that it has been loaded.
-   Module-name may be either a case-sensitive string or a symbol; if it is
-   a symbol, its print name is downcased and used."
-  (pushnew (module-name-string module-name) *modules* :test #'string=)
-  t)
-
-(defun require (module-name &optional pathname)
-  "Loads a module when it has not been already.  Pathname, if supplied,
-   is a single pathname or list of pathnames to be loaded if the module
-   needs to be.  If pathname is not supplied, then a list of files are
-   looked for that were registered by a EXT:DEFMODULE form.  If the module
-   has not been defined, then a file will be loaded whose name is formed
-   by merging \"modules:\" and module-name (downcased if it is a symbol).
-   This merged name will be probed with both a .lisp and .fasl extensions,
-   calling LOAD
-   if it exists.  While loading any files, *load-verbose* is bound to
-   *require-verbose* which defaults to nil."
- (setf module-name (module-name-string module-name))
-  (unless (member module-name *modules* :test #'string=)
-    (if pathname
-        (unless (listp pathname) (setf pathname (list pathname)))
-        (let ((files (module-files module-name)))
-          (if files
-              (setf pathname files)
-              (setf pathname (list (merge-pathnames "modules:" module-name))))))    (let ((*load-verbose* *require-verbose*))
-      (dolist (ele pathname t)
-        (load ele)))))
-
-
-
-;;;; Misc.
-
-(defun module-name-string (name)
-  (typecase name
-    (string name)
-    (symbol (string-downcase (symbol-name name)))
-    (t (error "Module name must be a string or symbol -- ~S."
-              name))))
diff --git a/code/ntrace.lisp b/code/ntrace.lisp
deleted file mode 100644
index 75cb55628217273212590d6402cc64305842cf68..0000000000000000000000000000000000000000
--- a/code/ntrace.lisp
+++ /dev/null
@@ -1,674 +0,0 @@
-;;; -*- Package: debug -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.10 1992/12/08 20:10:16 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This is a tracing facility based on breakpoints.
-;;;
-;;; Written by Rob MacLachlan and Bill Chiles.
-;;;
-;;; **********************************************************************
-;;;
-(in-package "LISP")
-
-(export '(trace untrace))
-
-(in-package "DEBUG")
-
-(export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*))
-
-(defvar *trace-values* nil
-  "This is bound to the returned values when evaluating :BREAK-AFTER and
-   :PRINT-AFTER forms.")
-
-(defvar *max-trace-indentation* 40
-  "If the trace indentation exceeds this value, then indentation restarts at
-   0.")
-
-(defvar *trace-encapsulate-default* :default
-  "The default value for the :ENCAPSULATE option to trace.")
-
-
-;;;; Internal state:
-
-;;; A hash-table that maps each traced function to the TRACE-INFO.  The entry
-;;; for a closure is the shared function-entry object.
-;;;
-(defvar *traced-functions* (make-hash-table :test #'eq))
-
-;;; The TRACE-INFO structure represents all the information we need to trace a
-;;; given function.
-;;;
-(defstruct (trace-info
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (print-unreadable-object (s stream)
-		 (format stream "Trace-Info ~S" (trace-info-what s)))))
-	    (:make-load-form-fun :just-dump-it-normally))
-  ;;
-  ;; The original representation of the thing traced.
-  (what nil :type (or function cons symbol))
-  ;;
-  ;; True if What is a function name whose definition we should track.
-  (named nil)
-  ;;
-  ;; True if tracing is to be done by encapsulation rather than breakpoints.
-  ;; T implies Named.
-  (encapsulated *trace-encapsulate-default*)
-  ;;
-  ;; True if this trace has been untraced.
-  (untraced nil)
-  ;;
-  ;; Breakpoints we set up to trigger tracing.
-  (start-breakpoint nil :type (or di:breakpoint null))
-  (end-breakpoint nil :type (or di:breakpoint null))
-  ;;
-  ;; The list of function names for wherein.  NIL means unspecified.
-  (wherein nil :type list)
-  ;;
-  ;; The following slots represent the forms that we are supposed to evaluate
-  ;; on each iteration.  Each form is represented by a cons (Form . Function),
-  ;; where the Function is the cached result of coercing Form to a function.
-  ;; Forms which use the current environment are converted with
-  ;; PREPROCESS-FOR-EVAL, which gives us a one-arg function.  
-  ;; Null environment forms also have one-arg functions, but the argument is
-  ;; ignored.  NIL means unspecified (the default.)
-  ;;
-  ;; Current environment forms:
-  (condition nil)
-  (break nil)
-  ;;
-  ;; List of current environment forms:
-  (print () :type list)
-  ;;
-  ;; Null environment forms.
-  (condition-after nil)
-  (break-after nil)
-  ;;
-  ;; List of null environment forms
-  (print-after () :type list))
-
-;;; This is a list of conses (function-end-cookie . condition-satisfied),
-;;; which we use to note distinct dynamic entries into functions.  When we
-;;; enter a traced function, we add a entry to this list holding the new
-;;; end-cookie and whether the trace condition was statisfied.  We must save
-;;; the trace condition so that the after breakpoint knows whether to print.
-;;; The length of this list tells us the indentation to use for printing TRACE
-;;; messages.
-;;;
-;;; This list also helps us synchronize the TRACE facility dynamically for
-;;; detecting non-local flow of control.  Whenever execution hits a
-;;; :function-end breakpoint used for TRACE'ing, we look for the
-;;; function-end-cookie at the top of *traced-entries*.  If it is not there, we
-;;; discard any entries that come before our cookie.
-;;;
-;;; When we trace using encapsulation, we bind this variable and add
-;;; (nil . condition-satisfied), so a NIL "cookie" marks an encapsulated
-;;; tracing.
-;;;
-(defvar *traced-entries* ())
-(declaim (list *traced-entries*))
-
-;;; This variable is used to discourage infinite recursions when some trace
-;;; action invokes a function that is itself traced.  In this case, we quietly
-;;; ignore the inner tracing.
-;;;
-(defvar *in-trace* nil)
-
-
-;;;; Utilities:
-
-;;; TRACE-FDEFINITION  --  Internal
-;;;
-;;;    Given a function name, a function or a macro name, return the raw
-;;; definition and some information.  "Raw"  means that if the result is a
-;;; closure, we strip off the closure and return the bare code.  The second
-;;; value is T if the argument was a function name.  The third value is one of
-;;; :COMPILED, :COMPILED-CLOSURE, :INTERPRETED, :INTERPRETED-CLOSURE and
-;;; :FUNCALLABLE-INSTANCE.
-;;;
-(defun trace-fdefinition (x)
-  (multiple-value-bind
-      (res named-p)
-      (typecase x
-	(symbol
-	 (cond ((special-form-p x)
-		(error "Can't trace special form ~S." x))
-	       ((macro-function x))
-	       (t
-		(values (fdefinition x) t))))
-	(function x)
-	(t (values (fdefinition x) t)))
-    (if (eval:interpreted-function-p res)
-	(values res named-p (if (eval:interpreted-function-closure res)
-				:interpreted-closure :interpreted))
-	(case (kernel:get-type res)
-	  (#.vm:closure-header-type
-	   (values (kernel:%closure-function res) named-p :compiled-closure))
-	  (#.vm:funcallable-instance-header-type
-	   (values res named-p :funcallable-instance))
-	  (t (values res named-p :compiled))))))
-
-
-;;; TRACE-REDEFINED-UPDATE  --  Internal
-;;;
-;;;    When a function name is redefined, and we were tracing that name, then
-;;; untrace the old definition and trace the new one.
-;;;
-(defun trace-redefined-update (fname new-value)
-  (when (fboundp fname)
-    (let* ((fun (trace-fdefinition fname))
-	   (info (gethash fun *traced-functions*)))
-      (when (and info (trace-info-named info))
-	(untrace-1 fname)
-	(trace-1 fname info new-value)))))
-;;;
-(push #'trace-redefined-update ext:*setf-fdefinition-hook*)
-
-
-;;; COERCE-FORM, COERCE-FORM-LIST  --  Internal
-;;;
-;;;    Annotate some forms to evaluate with pre-converted functions.  Each form
-;;; is really a cons (exp . function).  Loc is the code location to use for
-;;; the lexical environment.  If Loc is NIL, evaluate in the null environment.
-;;; If Form is NIL, just return NIL.
-;;;
-(defun coerce-form (form loc)
-  (when form
-    (let ((exp (car form)))
-      (if (di:code-location-p loc)
-	  (let ((fun (di:preprocess-for-eval exp loc)))
-	    (cons exp
-		  #'(lambda (frame)
-		      (let ((*current-frame* frame))
-			(funcall fun frame)))))
-	  (let* ((bod (ecase loc
-			((nil) exp)
-			(:encapsulated
-			 `(flet ((debug:arg (n)
-				   (declare (special argument-list))
-				   (elt argument-list n)))
-			    (declare (ignorable #'debug:arg))
-			    ,exp))))
-		 (fun (coerce `(lambda () ,bod) 'function)))
-	    (cons exp
-		  #'(lambda (frame)
-		      (declare (ignore frame))
-		      (let ((*current-frame* nil))
-			(funcall fun)))))))))
-;;;
-(defun coerce-form-list (forms loc)
-  (mapcar #'(lambda (x) (coerce-form x loc)) forms))
-
-	      
-;;; PRINT-TRACE-INDENTATION  --  Internal
-;;;
-;;;    Print indentation according to the number of trace entries.  Entries
-;;; whose condition was false don't count.
-;;;
-(defun print-trace-indentation ()
-  (let ((depth 0))
-    (dolist (entry *traced-entries*)
-      (when (cdr entry) (incf depth)))
-    (format t "~@V,0T~D: "
-	    (+ (mod (* depth 2) (- *max-trace-indentation* 2)) 2)
-	    depth)))
-
-
-;;; TRACE-WHEREIN-P -- Internal.
-;;;
-;;;    Return true if one of the Names appears on the stack below Frame.
-;;;
-(defun trace-wherein-p (frame names)
-  (do ((frame (di:frame-down frame) (di:frame-down frame)))
-      ((not frame) nil)
-    (when (member (di:debug-function-name (di:frame-debug-function frame))
-		  names :test #'equal)
-      (return t))))
-
-;;; TRACE-PRINT  --  Internal
-;;;
-;;;    Handle print and print-after options.
-;;;
-(defun trace-print (frame forms)
-  (dolist (ele forms)
-    (fresh-line)
-    (print-trace-indentation)
-    (format t "~S = ~S" (car ele) (funcall (cdr ele) frame))))
-
-;;; TRACE-MAYBE-BREAK  --  Internal
-;;;
-;;;    Test a break option, and break if true.
-;;;
-(defun trace-maybe-break (info break where frame)
-  (when (and break (funcall (cdr break) frame))
-    (di:flush-frames-above frame)
-    (let ((*stack-top-hint* frame))
-      (break "Breaking ~A traced call to ~S:" where
-	     (trace-info-what info)))))
-
-;;; DISCARD-INVALID-ENTRIES  --  Internal
-;;;
-;;;    This function discards any invalid cookies on our simulated stack.
-;;; Encapsulated entries are always valid, since we bind *traced-entries* in
-;;; the encapsulation.
-;;;
-(defun discard-invalid-entries (frame)
-  (loop
-    (when (or (null *traced-entries*)
-	      (let ((cookie (caar *traced-entries*)))
-		(or (not cookie)
-		    (di:function-end-cookie-valid-p frame cookie))))
-      (return))
-    (pop *traced-entries*)))
-
-
-;;;; Hook functions:
-
-;;; TRACE-START-BREAKPOINT-FUN -- Internal.
-;;;
-;;;    Return a closure that can be used for a function start breakpoint hook
-;;; function and a closure that can be used as the FUNCTION-END-COOKIE
-;;; function.  The first communicates the sense of the Condition to the second
-;;; via a closure variable.
-;;;
-(defun trace-start-breakpoint-fun (info)
-  (let (conditionp)
-    (values
-     #'(lambda (frame bpt)
-	 (declare (ignore bpt))
-	 (discard-invalid-entries frame)
-	 (let ((condition (trace-info-condition info))
-	       (wherein (trace-info-wherein info)))
-	   (setq conditionp
-		 (and (not *in-trace*)
-		      (or (not condition)
-			  (funcall (cdr condition) frame))
-		      (or (not wherein)
-			  (trace-wherein-p frame wherein)))))
-	 
-	 (when conditionp
-	   (let ((*print-length* (or *debug-print-length* *print-length*))
-		 (*print-level* (or *debug-print-level* *print-level*))
-		 (kernel:*current-level* 0)
-		 (*standard-output* *trace-output*)
-		 (*in-trace* t))
-	     (fresh-line)
-	     (print-trace-indentation)
-	     (if (trace-info-encapsulated info)
-		 (locally (declare (special basic-definition argument-list))
-		   (prin1 `(,(trace-info-what info) ,@argument-list)))
-		 (print-frame-call frame))
-	     (terpri)
-	     (trace-print frame (trace-info-print info)))
-	   (trace-maybe-break info (trace-info-break info) "before" frame)))
-
-     #'(lambda (frame cookie)
-	 (declare (ignore frame))
-	 (push (cons cookie conditionp) *traced-entries*)))))
-
-
-;;; TRACE-END-BREAKPOINT-FUN  --  Internal
-;;; 
-;;;    This prints a representation of the return values delivered.  First,
-;;; this checks to see that cookie is at the top of *traced-entries*; if it is
-;;; not, then we need to adjust this list to determine the correct indentation
-;;; for output.  We then check to see if the function is still traced and that
-;;; the condition succeeded before printing anything.
-;;;
-(defun trace-end-breakpoint-fun (info)
-  #'(lambda (frame bpt *trace-values* cookie)
-      (declare (ignore bpt))
-      (unless (eq cookie (caar *traced-entries*))
-	(setf *traced-entries*
-	      (member cookie *traced-entries* :key #'car)))
-      
-      (let ((entry (pop *traced-entries*)))
-	(when (and (not (trace-info-untraced info))
-		   (or (cdr entry)
-		       (let ((cond (trace-info-condition-after info)))
-			 (and cond (funcall (cdr cond) frame)))))
-	  (let ((*print-length* (or *debug-print-length* *print-length*))
-		(*print-level* (or *debug-print-level* *print-level*))
-		(kernel:*current-level* 0)
-		(*standard-output* *trace-output*)
-		(*in-trace* t))
-	    (fresh-line)
-	    (pprint-logical-block (*standard-output* nil)
-	      (print-trace-indentation)
-	      (pprint-indent :current 2)
-	      (format t "~S returned" (trace-info-what info))
-	      (dolist (v *trace-values*)
-		(write-char #\space)
-		(pprint-newline :linear)
-		(prin1 v)))
-	    (terpri)
-	    (trace-print frame (trace-info-print-after info)))
-	  (trace-maybe-break info (trace-info-break-after info)
-			     "after" frame)))))
-
-
-;;; TRACE-CALL  --  Internal
-;;;
-;;;    This function is called by the trace encapsulation.  It calls the
-;;; breakpoint hook functions with NIL for the breakpoint and cookie, which
-;;; we have cleverly contrived to work for our hook functions.
-;;;
-(defun trace-call (info)
-  (multiple-value-bind
-      (start cookie)
-      (trace-start-breakpoint-fun info)
-    (let ((frame (di:frame-down (di:top-frame))))
-      (funcall start frame nil)
-      (let ((*traced-entries* *traced-entries*))
-	(declare (special basic-definition argument-list))
-	(funcall cookie frame nil)
-	(let ((vals
-	       (multiple-value-list
-		(apply basic-definition argument-list))))
-	  (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
-	  (values-list vals))))))
-
-
-;;; TRACE-1 -- Internal.
-;;;
-;;;    Trace one function according to the specified options.  We copy the
-;;; trace info (it was a quoted constant), fill in the functions, and then
-;;; install the breakpoints or encapsulation.
-;;;
-;;;    If non-null, Definition is the new definition of a function that we are
-;;; automatically retracing; this 
-;;;
-(defun trace-1 (function-or-name info &optional definition)
-  (multiple-value-bind
-      (fun named kind)
-      (if definition
-	  (values definition t
-		  (nth-value 2 (trace-fdefinition definition)))
-	  (trace-fdefinition function-or-name))
-    (when (gethash fun *traced-functions*)
-      (warn "Function ~S already TRACE'd, retracing it." function-or-name)
-      (untrace-1 fun))
-    
-    (let* ((debug-fun (di:function-debug-function fun))
-	   (encapsulated 
-	    (if (eq (trace-info-encapsulated info) :default)
-		(ecase kind
-		  (:compiled nil)
-		  (:compiled-closure
-		   (unless (functionp function-or-name)
-		     (warn "Tracing shared code for ~S:~%  ~S"
-			   function-or-name fun))
-		   nil)
-		  ((:interpreted :interpreted-closure :funcallable-instance)
-		   t))
-		(trace-info-encapsulated info)))
-	   (loc (if encapsulated
-		    :encapsulated
-		    (di:debug-function-start-location debug-fun)))
-	   (info (make-trace-info
-		  :what function-or-name
-		  :named named
-		  :encapsulated encapsulated
-		  :wherein (trace-info-wherein info)
-		  :condition (coerce-form (trace-info-condition info) loc)
-		  :break (coerce-form (trace-info-break info) loc)
-		  :print (coerce-form-list (trace-info-print info) loc)
-		  :break-after (coerce-form (trace-info-break-after info) nil)
-		  :condition-after
-		  (coerce-form (trace-info-condition-after info) nil)
-		  :print-after
-		  (coerce-form-list (trace-info-print-after info) nil))))
-
-      (dolist (wherein (trace-info-wherein info))
-	(unless (or (stringp wherein)
-		    (fboundp wherein))
-	  (warn ":WHEREIN name is not a defined global function: ~S"
-		wherein)))
-
-      (cond
-       (encapsulated
-	(unless named
-	  (error "Can't use encapsulation to trace anonymous function ~S."
-		 fun))
-	(ext:encapsulate function-or-name 'trace `(trace-call ',info)))
-       (t
-	(multiple-value-bind
-	    (start-fun cookie-fun)
-	    (trace-start-breakpoint-fun info)
-	  (let ((start (di:make-breakpoint start-fun debug-fun
-					   :kind :function-start))
-		(end (di:make-breakpoint
-		      (trace-end-breakpoint-fun info)
-		      debug-fun :kind :function-end
-		      :function-end-cookie cookie-fun)))
-	    (setf (trace-info-start-breakpoint info) start)
-	    (setf (trace-info-end-breakpoint info) end)
-	    ;;
-	    ;; The next two forms must be in the order in which they appear,
-	    ;; since the start breakpoint must run before the function-end
-	    ;; breakpoint's start helper (which calls the cookie function.)
-	    ;; One reason is that cookie function requires that the CONDITIONP
-	    ;; shared closure variable be initialized.
-	    (di:activate-breakpoint start)
-	    (di:activate-breakpoint end)))))
-
-      (setf (gethash fun *traced-functions*) info)))
-
-  function-or-name)
-
-
-;;;; The TRACE macro:
-
-;;;  PARSE-TRACE-OPTIONS  --  Internal
-;;;
-;;;    Parse leading trace options off of Specs, modifying Info accordingly.
-;;; The remaining portion of the list is returned when we encounter a plausible
-;;; function name.
-;;;
-(defun parse-trace-options (specs info)
-  (let ((current specs))
-    (loop
-      (when (endp current) (return))
-      (let ((option (first current))
-	    (value (cons (second current) nil)))
-	(case option
-	  (:condition (setf (trace-info-condition info) value))
-	  (:condition-after
-	   (setf (trace-info-condition info) (cons nil nil))
-	   (setf (trace-info-condition-after info) value))
-	  (:condition-all
-	   (setf (trace-info-condition info) value)
-	   (setf (trace-info-condition-after info) value))
-	  (:wherein
-	   (setf (trace-info-wherein info)
-		 (if (listp (car value)) (car value) value)))
-	  (:encapsulate
-	   (setf (trace-info-encapsulated info) (car value)))
-	  (:break (setf (trace-info-break info) value))
-	  (:break-after (setf (trace-info-break-after info) value))
-	  (:break-all
-	   (setf (trace-info-break info) value)
-	   (setf (trace-info-break-after info) value))
-	  (:print
-	   (setf (trace-info-print info)
-		 (append (trace-info-print info) (list value))))
-	  (:print-after
-	   (setf (trace-info-print-after info)
-		 (append (trace-info-print-after info) (list value))))
-	  (:print-all
-	   (setf (trace-info-print info)
-		 (append (trace-info-print info) (list value)))
-	   (setf (trace-info-print-after info)
-		 (append (trace-info-print-after info) (list value))))
-	  (t (return)))
-	(pop current)
-	(unless current
-	  (error "Missing argument to ~S TRACE option." option))
-	(pop current)))
-    current))
-
-
-;;; EXPAND-TRACE  --  Internal
-;;;
-;;;    Compute the expansion of TRACE in the non-trivial case (arguments
-;;; specified.)  If there are no :FUNCTION specs, then don't use a LET.  This
-;;; allows TRACE to be used without the full interpreter.
-;;;
-(defun expand-trace (specs)
-  (collect ((binds)
-	    (forms))
-    (let* ((global-options (make-trace-info))
-	   (current (parse-trace-options specs global-options)))
-      (loop
-	(when (endp current) (return))
-	(let ((name (pop current))
-	      (options (copy-trace-info global-options)))
-	  (cond
-	   ((eq name :function)
-	    (let ((temp (gensym)))
-	      (binds `(,temp ,(pop current)))
-	      (forms `(trace-1 ,temp ',options))))
-	   ((and (keywordp name)
-		 (not (or (fboundp name) (macro-function name))))
-	    (error "Unknown TRACE option: ~S" name))
-	   (t
-	    (forms `(trace-1 ',name ',options))))
-	  (setq current (parse-trace-options current options)))))
-
-    (if (binds)
-	`(let ,(binds) (list ,@(forms)))
-	`(list ,@(forms)))))
-
-
-;;; %LIST-TRACED-FUNCTIONS  --  Internal
-;;;
-(defun %list-traced-functions ()
-  (loop for x being each hash-value in *traced-functions*
-        collect (trace-info-what x)))
-
-
-;;; TRACE -- Public.
-;;;
-(defmacro trace (&rest specs)
-  "TRACE {Option Global-Value}* {Name {Option Value}*}*
-   TRACE is a debugging tool that prints information when specified functions
-   are called.  In its simplest form:
-       (trace Name-1 Name-2 ...)
-
-   TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named
-   functions is entered or returns (the Names are not evaluated.)  The output
-   is indented according to the number of pending traced calls, and this trace
-   depth is printed at the beginning of each line of output.
-
-   Options allow modification of the default behavior.  Each option is a pair
-   of an option keyword and a value form.  Options may be interspersed with
-   function names.  Options only affect tracing of the function whose name they
-   appear immediately after.  Global options are specified before the first
-   name, and affect all functions traced by a given use of TRACE.
-
-   The following options are defined:
-
-   :CONDITION Form
-   :CONDITION-AFTER Form
-   :CONDITION-ALL Form
-       If :CONDITION is specified, then TRACE does nothing unless Form
-       evaluates to true at the time of the call.  :CONDITION-AFTER is
-       similar, but suppresses the initial printout, and is tested when the
-       function returns.  :CONDITION-ALL tries both before and after.
-
-   :WHEREIN Names
-       If specified, Names is a function name or list of names.  TRACE does
-       nothing unless a call to one of those functions encloses the call to
-       this function (i.e. it would appear in a backtrace.)  Anonymous
-       functions have string names like \"DEFUN FOO\".
-
-   :BREAK Form
-   :BREAK-AFTER Form
-   :BREAK-ALL Form
-       If specified, and Form evaluates to true, then the debugger is invoked
-       at the start of the function, at the end of the function, or both,
-       according to the respective option.
-
-   :PRINT Form
-   :PRINT-AFTER Form
-   :PRINT-ALL Form
-       In addition to the usual prinout, he result of evaluating Form is
-       printed at the start of the function, at the end of the function, or
-       both, according to the respective option.  Multiple print options cause
-       multiple values to be printed.
-
-   :FUNCTION Function-Form
-       This is a not really an option, but rather another way of specifying
-       what function to trace.  The Function-Form is evaluated immediately,
-       and the resulting function is traced.
-
-   :ENCAPSULATE {:DEFAULT | T | NIL}
-       If T, the tracing is done via encapsulation (redefining the function
-       name) rather than by modifying the function.  :DEFAULT is the default,
-       and means to use encapsulation for interpreted functions and funcallable
-       instances, breakpoints otherwise.  When encapsulation is used, forms are
-       *not* evaluated in the function's lexical environment, but DEBUG:ARG can
-       still be used.
-
-   :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment
-   of the called function; DEBUG:VAR and DEBUG:ARG can be used.  The -AFTER and
-   -ALL forms are evaluated in the null environment."
-  (if specs
-      (expand-trace specs)
-      '(%list-traced-functions)))
-
-
-;;;; Untracing:
-
-;;; UNTRACE-1  --  Internal
-;;;
-;;;    Untrace one function.
-;;;
-(defun untrace-1 (function-or-name)
-  (let* ((fun (trace-fdefinition function-or-name))
-	 (info (gethash fun *traced-functions*)))
-    (cond
-     ((not info) (warn "Function is not TRACE'd -- ~S." function-or-name))
-     (t
-      (cond
-       ((trace-info-encapsulated info)
-	(ext:unencapsulate (trace-info-what info) 'trace))
-       (t
-	(di:delete-breakpoint (trace-info-start-breakpoint info))
-	(di:delete-breakpoint (trace-info-end-breakpoint info))))
-      (setf (trace-info-untraced info) t)
-      (remhash fun *traced-functions*)))))
-
-;;; UNTRACE-ALL  --  Internal
-;;;
-;;;    Untrace all traced functions.
-;;;
-(defun untrace-all ()
-  (dolist (fun (%list-traced-functions))
-    (untrace-1 fun))
-  t)
-
-(defmacro untrace (&rest specs)
-  "Removes tracing from the specified functions.  With no args, untraces all
-   functions."
-  (if specs
-      (collect ((res))
-	(let ((current specs))
-	  (loop
-	    (unless current (return))
-	    (let ((name (pop current)))
-	      (res (if (eq name :function)
-		       `(untrace-1 ,(pop current))
-		       `(untrace-1 ',name)))))
-	  `(progn ,@(res) t)))
-      '(untrace-all)))
diff --git a/code/numbers.lisp b/code/numbers.lisp
deleted file mode 100644
index d075e3e7456a6862961bc5235a97780f82d514a8..0000000000000000000000000000000000000000
--- a/code/numbers.lisp
+++ /dev/null
@@ -1,1226 +0,0 @@
-;;; -*- Mode: Lisp; Package: KERNEL; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.20 1992/02/07 11:33:23 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.20 1992/02/07 11:33:23 ram Exp $
-;;;
-;;; This file contains the definitions of most number functions.
-;;;
-;;; Author: Rob MacLachlan
-;;; 
-;;; Much code in this file was derived from code written by William Lott, Dave
-;;; Mcdonald, Jim Large, Scott Fahlman, etc.
-;;;
-(in-package "LISP")
-
-(export '(zerop plusp minusp oddp evenp = /= < > <= >= max min + - * / 1+ 1- 
-	  conjugate abs phase signum float floor ceiling truncate cis round mod
-          rem ffloor fceiling fround ftruncate complex realpart imagpart
-	  logior logxor logand logeqv lognand lognor logandc1 logandc2 logorc1
-	  logorc2 boole boole-clr boole-set boole-1 boole-2 boole-c1 boole-c2
-	  boole-and boole-ior boole-xor boole-eqv boole-nand boole-nor
-	  boole-andc1 boole-andc2 boole-orc1 boole-orc2 lognot logtest
-	  logbitp ash integer-length byte byte-size byte-position
-	  ldb ldb-test mask-field dpb deposit-field
-	  upgraded-complex-part-type)) 
-
-(in-package "KERNEL")
-
-
-;;;; Number dispatch macro:
-
-(eval-when (compile load eval)
-
-;;; PARSE-NUMBER-DISPATCH  --  Internal
-;;;
-;;;    Grovel an individual case to NUMBER-DISPATCH, augmenting Result with the
-;;; type dispatches and bodies.  Result is a tree built of alists representing
-;;; the dispatching off each arg (in order).  The leaf is the body to be
-;;; executed in that case.
-;;;
-(defun parse-number-dispatch (vars result types var-types body)
-  (cond ((null vars)
-	 (unless (null types) (error "More types than vars."))
-	 (when (cdr result)
-	   (error "Duplicate case: ~S." body))
-	 (setf (cdr result)
-	       (sublis var-types body :test #'equal)))
-	((null types)
-	 (error "More vars than types."))
-	(t
-	 (flet ((frob (var type)
-		  (parse-number-dispatch
-		   (rest vars)
-		   (or (assoc type (cdr result) :test #'equal)
-		       (car (setf (cdr result)
-				  (acons type nil (cdr result)))))
-		   (rest types)
-		   (acons `(dispatch-type ,var) type var-types)
-		   body)))
-	   (let ((type (first types))
-		 (var (first vars)))
-	     (if (and (consp type) (eq (first type) 'foreach))
-		 (dolist (type (rest type))
-		   (frob var type))
-		 (frob var type)))))))
-
-
-;;; Our guess for the preferred order to do type tests in (cheaper and/or more
-;;; probable first.)
-;;;
-(defconstant type-test-ordering
-  '(fixnum single-float double-float integer bignum complex ratio))
-
-;;; Type-Test-Order  --  Internal
-;;;
-;;;    Return true if Type1 should be tested before Type2.
-;;;
-(defun type-test-order (type1 type2)
-  (let ((o1 (position type1 type-test-ordering))
-	(o2 (position type2 type-test-ordering)))
-    (cond ((not o1) nil)
-	  ((not o2) t)
-	  (t
-	   (< o1 o2)))))
-
-
-;;; GENERATE-NUMBER-DISPATCH  --  Internal
-;;;
-;;;    Return an ETYPECASE form that does the type dispatch, ordering the cases
-;;; for efficiency.
-;;;
-(defun generate-number-dispatch (vars error-tags cases)
-  (if vars
-      (let ((var (first vars))
-	    (cases (sort cases #'type-test-order :key #'car)))
-	`((typecase ,var
-	    ,@(mapcar #'(lambda (case)
-			  `(,(first case)
-			    ,@(generate-number-dispatch (rest vars)
-							(rest error-tags)
-							(cdr case))))
-		      cases)
-	    (t (go ,(first error-tags))))))
-      cases))
-
-); Eval-When (Compile Load Eval)
-
-
-;;; NUMBER-DISPATCH  --  Interface
-;;;
-(defmacro number-dispatch (var-specs &body cases)
-  "NUMBER-DISPATCH ({(Var Type)}*) {((Type*) Form*) | (Symbol Arg*)}*
-  A vaguely case-like macro that does number cross-product dispatches.  The
-  Vars are the variables we are dispatching off of.  The Type paired with each
-  Var is used in the error message when no case matches.  Each case specifies a
-  Type for each var, and is executed when that signature holds.  A type may be
-  a list (FOREACH Each-Type*), causing that case to be repeatedly instantiated
-  for every Each-Type.  In the body of each case, any list of the form
-  (DISPATCH-TYPE Var-Name) is substituted with the type of that var in that
-  instance of the case.
-
-  As an alternate to a case spec, there may be a form whose CAR is a symbol.
-  In this case, we apply the CAR of the form to the CDR and treat the result of
-  the call as a list of cases.  This process is not applied recursively."
-  (let ((res (list nil))
-	(vars (mapcar #'car var-specs))
-	(block (gensym)))
-    (dolist (case cases)
-      (if (symbolp (first case))
-	  (let ((cases (apply (symbol-function (first case)) (rest case))))
-	    (dolist (case cases)
-	      (parse-number-dispatch vars res (first case) nil (rest case))))
-	  (parse-number-dispatch vars res (first case) nil (rest case))))
-
-    (collect ((errors)
-	      (error-tags))
-      (dolist (spec var-specs)
-	(let ((var (first spec))
-	      (type (second spec))
-	      (tag (gensym)))
-	  (error-tags tag)
-	  (errors tag)
-	  (errors `(return-from
-		    ,block
-		    (error 'simple-type-error :datum ,var
-			   :expected-type ',type
-			   :format-string
-			   "Argument ~A is not a ~S: ~S."
-			   :format-arguments
-			   (list ',var ',type ,var))))))
-      
-      `(block ,block
-	 (tagbody
-	   (return-from ,block
-			,@(generate-number-dispatch vars (error-tags)
-						    (cdr res)))
-	   ,@(errors))))))
-
-
-;;;; Binary operation dispatching utilities:
-
-(eval-when (compile eval)
-
-;;; FLOAT-CONTAGION  --  Internal
-;;;
-;;;    Return NUMBER-DISPATCH forms for rational X float.
-;;;
-(defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio)))
-  `(((single-float single-float) (,op ,x ,y))
-    (((foreach ,@rat-types) (foreach single-float double-float))
-     (,op (coerce ,x '(dispatch-type ,y)) ,y))
-    (((foreach single-float double-float) (foreach ,@rat-types))
-     (,op ,x (coerce ,y '(dispatch-type ,x))))
-    (((foreach single-float double-float) double-float)
-     (,op (coerce ,x 'double-float) ,y))
-    ((double-float single-float)
-     (,op ,x (coerce ,y 'double-float)))))
-
-
-;;; BIGNUM-CROSS-FIXNUM  --  Internal
-;;;
-;;;    Return NUMBER-DISPATCH forms for bignum X fixnum.
-;;;
-(defun bignum-cross-fixnum (fix-op big-op)
-  `(((fixnum fixnum) (,fix-op x y))
-    ((fixnum bignum)
-     (,big-op (make-small-bignum x) y))
-    ((bignum fixnum)
-     (,big-op x (make-small-bignum y)))
-    ((bignum bignum)
-     (,big-op x y))))
-
-); Eval-When (Compile Eval)
-
-
-;;;; Canonicalization utilities:
-
-;;; CANONICAL-COMPLEX  --  Internal
-;;;
-;;;    If imagpart is 0, return realpart, otherwise make a complex.  This is
-;;; used when we know that realpart and imagpart are the same type, but
-;;; rational canonicalization might still need to be done.
-;;;
-(proclaim '(inline canonical-complex))
-(defun canonical-complex (realpart imagpart)
-  (if (eql imagpart 0)
-      realpart
-      (%make-complex realpart imagpart)))
-
-
-;;; BUILD-RATIO  --  Internal
-;;;
-;;;    Given a numerator and denominator with the GCD already divided out, make
-;;; a canonical rational.  We make the denominator positive, and check whether
-;;; it is 1.
-;;;
-(proclaim '(inline build-ratio))
-(defun build-ratio (num den)
-  (multiple-value-bind (num den)
-		       (if (minusp den)
-			   (values (- num) (- den))
-			   (values num den))
-    (if (eql den 1)
-	num
-	(%make-ratio num den))))
-
-
-;;; MAYBE-TRUNCATE  --  Internal
-;;;
-;;;    Truncate X and Y, but bum the case where Y is 1.
-;;;
-(proclaim '(inline maybe-truncate))
-(defun maybe-truncate (x y)
-  (if (eql y 1)
-      x
-      (truncate x y)))
-
-
-;;;; Complexes:
-
-(defun upgraded-complex-part-type (spec)
-  "Returns the element type of the most specialized COMPLEX number type that
-   can hold parts of type Spec.  This is currently always T."
-  (declare (ignore spec))
-  t)
-
-(defun complex (realpart &optional (imagpart 0))
-  "Builds a complex number from the specified components."
-  (number-dispatch ((realpart real) (imagpart real))
-    ((rational rational)
-     (canonical-complex realpart imagpart))
-    (float-contagion %make-complex realpart imagpart (rational))))
-
-(defun realpart (number)
-  "Extracts the real part of a number."
-  (realpart number))
-
-(defun imagpart (number)
-  "Extracts the imaginary part of a number."
-  (imagpart number))
-
-(defun conjugate (number)
-  "Returns the complex conjugate of NUMBER.  For non-complex numbers, this is
-  an identity."
-  (if (complexp number)
-      (complex (realpart number) (- (imagpart number)))
-      number))
-
-(defun signum (number)
-  "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))."
-  (if (zerop number)
-      number
-      (if (rationalp number)
-	  (if (plusp number) 1 -1)
-	  (/ number (abs number)))))
-
-
-;;;; Ratios.
-
-(defun numerator (number)
-  "Return the numerator of NUMBER, which must be rational."
-  (numerator number))
-
-(defun denominator (number)
-  "Return the denominator of NUMBER, which must be rational."
-  (denominator number))
-
-
-
-;;;; Arithmetic Operations
-
-
-(defmacro define-arith (op init doc)
-  `(defun ,op (&rest args)
-     ,doc
-     (if (null args) ,init
-	 (do ((args (cdr args) (cdr args))
-	      (res (car args) (,op res (car args))))
-	     ((null args) res)))))
-
-(define-arith + 0
-  "Returns the sum of its arguments.  With no args, returns 0.")
-(define-arith * 1
-  "Returns the product of its arguments.  With no args, returns 1.")
-
-(defun - (number &rest more-numbers)
-  "Subtracts the second and all subsequent arguments from the first.
-  With one arg, negates it."
-  (if more-numbers
-      (do ((nlist more-numbers (cdr nlist))
-	   (result number))
-	  ((atom nlist) result)
-         (declare (list nlist))
-	 (setq result (- result (car nlist))))
-      (- number)))
-
-(defun / (number &rest more-numbers)
-  "Divides the first arg by each of the following arguments, in turn.
-  With one arg, returns reciprocal."
-  (if more-numbers
-      (do ((nlist more-numbers (cdr nlist))
-	   (result number))
-	  ((atom nlist) result)
-         (declare (list nlist))
-	 (setq result (/ result (car nlist))))
-      (/ number)))
-
-(defun 1+ (number)
-  "Returns NUMBER + 1."
-  (1+ number))
-
-(defun 1- (number)
-  "Returns NUMBER - 1."
-  (1- number))
-
-
-(eval-when (compile)
-
-(defmacro two-arg-+/- (name op big-op)
-  `(defun ,name (x y)
-     (number-dispatch ((x number) (y number))
-       (bignum-cross-fixnum ,op ,big-op)
-       (float-contagion ,op x y)
-       
-       ((complex complex)
-	(canonical-complex (,op (realpart x) (realpart y))
-			   (,op (imagpart x) (imagpart y))))
-       (((foreach bignum fixnum ratio single-float double-float) complex)
-	(complex (,op x (realpart y)) (imagpart y)))
-       ((complex (or rational float))
-	(complex (,op (realpart x) y) (imagpart x)))
-       
-       (((foreach fixnum bignum) ratio)
-	(let* ((dy (denominator y))
-	       (n (,op (* x dy) (numerator y))))
-	  (%make-ratio n dy)))
-       ((ratio integer)
-	(let* ((dx (denominator x))
-	       (n (,op (numerator x) (* y dx))))
-	  (%make-ratio n dx)))
-       ((ratio ratio)
-	(let* ((nx (numerator x))
-	       (dx (denominator x))
-	       (ny (numerator y))
-	       (dy (denominator y))
-	       (g1 (gcd dx dy)))
-	  (if (eql g1 1)
-	      (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy))
-	      (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny)))
-		     (g2 (gcd t1 g1))
-		     (t2 (truncate dx g1)))
-		(cond ((eql t1 0) 0)
-		      ((eql g2 1)
-		       (%make-ratio t1 (* t2 dy)))
-		      (T (let* ((nn (truncate t1 g2))
-				(t3 (truncate dy g2))
-				(nd (if (eql t2 1) t3 (* t2 t3))))
-			   (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
-  
-); Eval-When (Compile)
-
-
-(two-arg-+/- two-arg-+ + add-bignums)
-(two-arg-+/- two-arg-- - subtract-bignum)
-
-
-
-(defun two-arg-* (x y)
-  (flet ((integer*ratio (x y)
-	   (if (eql x 0) 0
-	       (let* ((ny (numerator y))
-		      (dy (denominator y))
-		      (gcd (gcd x dy)))
-		 (if (eql gcd 1)
-		     (%make-ratio (* x ny) dy)
-		     (let ((nn (* (truncate x gcd) ny))
-			   (nd (truncate dy gcd)))
-		       (if (eql nd 1)
-			   nn
-			   (%make-ratio nn nd)))))))
-	 (complex*real (x y)
-	   (canonical-complex (* (realpart x) y) (* (imagpart x) y))))
-    (number-dispatch ((x number) (y number))
-      (float-contagion * x y)
-
-      ((fixnum fixnum) (multiply-fixnums x y))
-      ((bignum fixnum) (multiply-bignum-and-fixnum x y))
-      ((fixnum bignum) (multiply-bignum-and-fixnum y x))
-      ((bignum bignum) (multiply-bignums x y))
-      
-      ((complex complex)
-       (let* ((rx (realpart x))
-	      (ix (imagpart x))
-	      (ry (realpart y))
-	      (iy (imagpart y)))
-	 (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
-      (((foreach bignum fixnum ratio single-float double-float) complex)
-       (complex*real y x))
-      ((complex (or rational float))
-       (complex*real x y))
-      
-      (((foreach bignum fixnum) ratio) (integer*ratio x y))
-      ((ratio integer) (integer*ratio y x))
-      ((ratio ratio)
-       (let* ((nx (numerator x))
-	      (dx (denominator x))
-	      (ny (numerator y))
-	      (dy (denominator y))
-	      (g1 (gcd nx dy))
-	      (g2 (gcd dx ny)))
-	 (build-ratio (* (maybe-truncate nx g1)
-			 (maybe-truncate ny g2))
-		      (* (maybe-truncate dx g2)
-			 (maybe-truncate dy g1))))))))
-
-
-
-;;; INTEGER-/-INTEGER  --  Internal
-;;;
-;;;    Divide two integers, producing a canonical rational.  If a fixnum, we
-;;; see if they divide evenly before trying the GCD.  In the bignum case, we
-;;; don't bother, since bignum division is expensive, and the test is not very
-;;; likely to suceed.
-;;;
-(defun integer-/-integer (x y)
-  (if (and (typep x 'fixnum) (typep y 'fixnum))
-      (multiple-value-bind
-	  (quo rem)
-	  (truncate x y)
-	(if (zerop rem)
-	    quo
-	    (let ((gcd (gcd x y)))
-	      (declare (fixnum gcd))
-	      (if (eql gcd 1)
-		  (build-ratio x y)
-		  (build-ratio (truncate x gcd) (truncate y gcd))))))
-      (let ((gcd (gcd x y)))
-	(if (eql gcd 1)
-	    (build-ratio x y)
-	    (build-ratio (truncate x gcd) (truncate y gcd))))))
-
-
-(defun two-arg-/ (x y)
-  (number-dispatch ((x number) (y number))
-    (float-contagion / x y (ratio integer))
-     
-    ((complex complex)
-     (let* ((rx (realpart x))
-	    (ix (imagpart x))
-	    (ry (realpart y))
-	    (iy (imagpart y))
-	    (dn (+ (* ry ry) (* iy iy))))
-       (canonical-complex (/ (+ (* rx ry) (* ix iy)) dn)
-			  (/ (- (* ix ry) (* rx iy)) dn))))
-    (((foreach integer ratio single-float double-float) complex)
-     (let* ((ry (realpart y))
-	    (iy (imagpart y))
-	    (dn (+ (* ry ry) (* iy iy))))
-       (canonical-complex (/ (* x ry) dn)
-			  (/ (- (* x iy)) dn))))
-    ((complex (or rational float))
-     (canonical-complex (/ (realpart x) y)
-			(/ (imagpart x) y)))
-    
-    ((ratio ratio)
-     (let* ((nx (numerator x))
-	    (dx (denominator x))
-	    (ny (numerator y))
-	    (dy (denominator y))
-	    (g1 (gcd nx ny))
-	    (g2 (gcd dx dy)))
-       (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2))
-		    (* (maybe-truncate dx g2) (maybe-truncate ny g1)))))
-    
-    ((integer integer)
-     (integer-/-integer x y))
-    
-    ((integer ratio)
-     (if (zerop x)
-	 0
-	 (let* ((ny (numerator y))
-		(dy (denominator y))
-		(gcd (gcd x ny)))
-	   (build-ratio (* (maybe-truncate x gcd) dy)
-			(maybe-truncate ny gcd)))))
-    
-    ((ratio integer)
-     (let* ((nx (numerator x))
-	    (gcd (gcd nx y)))
-       (build-ratio (maybe-truncate nx gcd)
-		    (* (maybe-truncate y gcd) (denominator x)))))))
-
-
-(defun %negate (n)
-  (number-dispatch ((n number))
-    (((foreach fixnum single-float double-float))
-     (%negate n))
-    ((bignum)
-     (negate-bignum n))
-    ((ratio)
-     (%make-ratio (- (numerator n)) (denominator n)))
-    ((complex)
-     (%make-complex (- (realpart n)) (- (imagpart n))))))
-
-
-;;;; Truncate & friends.
-
-(defun truncate (number &optional (divisor 1))
-  "Returns number (or number/divisor) as an integer, rounded toward 0.
-  The second returned value is the remainder."
-  (macrolet ((truncate-float (rtype)
-	       `(let* ((float-div (coerce divisor ',rtype))
-		       (res (%unary-truncate (/ number float-div))))
-		  (values res
-			  (- number
-			     (* (coerce res ',rtype) float-div))))))
-    (number-dispatch ((number real) (divisor real))
-      ((fixnum fixnum) (truncate number divisor))
-      (((foreach fixnum bignum) ratio)
-       (truncate (* number (denominator divisor))
-		 (numerator divisor)))
-      ((fixnum bignum)
-       (values 0 number))
-      ((ratio (or float rational))
-       (let ((q (truncate (numerator number)
-			  (* (denominator number) divisor))))
-	 (values q (- number (* q divisor)))))
-      ((bignum fixnum)
-       (bignum-truncate number (make-small-bignum divisor)))
-      ((bignum bignum)
-       (bignum-truncate number divisor))
-      
-      (((foreach single-float double-float) (or rational single-float))
-       (if (eql divisor 1)
-	   (let ((res (%unary-truncate number)))
-	     (values res (- number (coerce res '(dispatch-type number)))))
-	   (truncate-float (dispatch-type number))))
-      ((double-float (or single-float double-float))
-       (truncate-float double-float))
-      ((single-float double-float)
-       (truncate-float double-float))
-      (((foreach fixnum bignum ratio) (foreach single-float double-float))
-       (truncate-float (dispatch-type divisor))))))
-
-
-;;; Declare these guys inline to let them get optimized a little.  Round and
-;;; Fround are not declared inline since they seem too obscure and too
-;;; big to inline-expand by default.  Also, this gives the compiler a chance to
-;;; pick off the unary float case.  Simlarly, ceiling and floor are only
-;;; maybe-inline for now, so that the power-of-2 ceiling and floor transforms
-;;; get a chance.
-;;;
-(declaim (inline rem mod fceiling ffloor ftruncate))
-(declaim (maybe-inline ceiling floor))
-
-;;; If the numbers do not divide exactly and the result of (/ number divisor)
-;;; would be negative then decrement the quotient and augment the remainder by
-;;; the divisor.
-;;;
-(defun floor (number &optional (divisor 1))
-  "Returns the greatest integer not greater than number, or number/divisor.
-  The second returned value is (mod number divisor)."
-  (multiple-value-bind (tru rem) (truncate number divisor)
-    (if (and (not (zerop rem))
-	     (if (minusp divisor)
-		 (plusp number)
-		 (minusp number)))
-	(values (1- tru) (+ rem divisor))
-	(values tru rem))))
-
-
-;;; If the numbers do not divide exactly and the result of (/ number divisor)
-;;; would be positive then increment the quotient and decrement the remainder by
-;;; the divisor.
-;;;
-(defun ceiling (number &optional (divisor 1))
-  "Returns the smallest integer not less than number, or number/divisor.
-  The second returned value is the remainder."
-  (multiple-value-bind (tru rem) (truncate number divisor)
-    (if (and (not (zerop rem))
-	     (if (minusp divisor)
-		 (minusp number)
-		 (plusp number)))
-	(values (+ tru 1) (- rem divisor))
-	(values tru rem))))
-
-
-(defun round (number &optional (divisor 1))
-  "Rounds number (or number/divisor) to nearest integer.
-  The second returned value is the remainder."
-  (if (eql divisor 1)
-      (round number)
-      (multiple-value-bind (tru rem) (truncate number divisor)
-	(let ((thresh (/ (abs divisor) 2)))
-	  (cond ((or (> rem thresh)
-		     (and (= rem thresh) (oddp tru)))
-		 (if (minusp divisor)
-		     (values (- tru 1) (+ rem divisor))
-		     (values (+ tru 1) (- rem divisor))))
-		((let ((-thresh (- thresh)))
-		   (or (< rem -thresh)
-		       (and (= rem -thresh) (oddp tru))))
-		 (if (minusp divisor)
-		     (values (+ tru 1) (- rem divisor))
-		     (values (- tru 1) (+ rem divisor))))
-		(t (values tru rem)))))))
-
-
-(defun rem (number divisor)
-  "Returns second result of TRUNCATE."
-  (multiple-value-bind (tru rem) (truncate number divisor)
-    (declare (ignore tru))
-    rem))
-
-(defun mod (number divisor)
-  "Returns second result of FLOOR."
-  (let ((rem (rem number divisor)))
-    (if (and (not (zerop rem))
-	     (if (minusp divisor)
-		 (plusp number)
-		 (minusp number)))
-	(+ rem divisor)
-	rem)))
-
-
-(macrolet ((frob (name op doc)
-	     `(defun ,name (number &optional (divisor 1))
-		,doc
-		(multiple-value-bind (res rem) (,op number divisor)
-		  (values (float res (if (floatp rem) rem 1.0)) rem)))))
-  (frob ffloor floor
-    "Same as FLOOR, but returns first value as a float.")
-  (frob fceiling ceiling
-    "Same as CEILING, but returns first value as a float." )
-  (frob ftruncate truncate
-    "Same as TRUNCATE, but returns first value as a float.")
-  (frob fround round
-    "Same as ROUND, but returns first value as a float."))
-
-
-;;;; Comparisons:
-
-(defun = (number &rest more-numbers)
-  "Returns T if all of its arguments are numerically equal, NIL otherwise."
-  (do ((nlist more-numbers (cdr nlist)))
-      ((atom nlist) T)
-     (declare (list nlist))
-     (if (not (= (car nlist) number)) (return nil))))
-
-(defun /= (number &rest more-numbers)
-  "Returns T if no two of its arguments are numerically equal, NIL otherwise."
-  (do* ((head number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (unless (do* ((nl nlist (cdr nl)))
-		  ((atom nl) T)
-	       (declare (list nl))
-	       (if (= head (car nl)) (return nil)))
-       (return nil))))
-
-(defun < (number &rest more-numbers)
-  "Returns T if its arguments are in strictly increasing order, NIL otherwise."
-  (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (< n (car nlist))) (return nil))))
-
-(defun > (number &rest more-numbers)
-  "Returns T if its arguments are in strictly decreasing order, NIL otherwise."
-  (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (> n (car nlist))) (return nil))))
-
-(defun <= (number &rest more-numbers)
-  "Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
-  (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (<= n (car nlist))) (return nil))))
-
-(defun >= (number &rest more-numbers)
-  "Returns T if arguments are in strictly non-increasing order, NIL otherwise."
-  (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (>= n (car nlist))) (return nil))))
-
-(defun max (number &rest more-numbers)
-  "Returns the greatest of its arguments."
-  (do ((nlist more-numbers (cdr nlist))
-       (result number))
-      ((null nlist) (return result))
-     (declare (list nlist))
-     (if (> (car nlist) result) (setq result (car nlist)))))
-
-(defun min (number &rest more-numbers)
-  "Returns the least of its arguments."
-  (do ((nlist more-numbers (cdr nlist))
-       (result number))
-      ((null nlist) (return result))
-     (declare (list nlist))
-     (if (< (car nlist) result) (setq result (car nlist)))))
-
-(eval-when (compile eval)
-
-(defun basic-compare (op)
-  `(((fixnum fixnum) (,op x y))
-
-    ((single-float single-float) (,op x y))
-    (((foreach single-float double-float) double-float)
-     (,op (coerce x 'double-float) y))
-    ((double-float single-float)
-     (,op x (coerce y 'double-float)))
-    (((foreach single-float double-float) rational)
-     (if (eql y 0)
-	 (,op x (coerce 0 '(dispatch-type x)))
-	 (,op (rational x) y)))
-    (((foreach bignum fixnum ratio) float)
-     (,op x (rational y)))))
-
-
-(defmacro two-arg-</> (name op ratio-arg1 ratio-arg2 &rest cases)
-  `(defun ,name (x y)
-     (number-dispatch ((x real) (y real))
-       (basic-compare ,op)
-
-       (((foreach fixnum bignum) ratio)
-	(,op x (,ratio-arg2 (numerator y) (denominator y))))
-       ((ratio integer)
-	(,op (,ratio-arg1 (numerator x) (denominator x)) y))
-       ((ratio ratio)
-	(,op (* (numerator (truly-the ratio x))
-		(denominator (truly-the ratio y)))
-	     (* (numerator (truly-the ratio y))
-		(denominator (truly-the ratio x)))))
-       ,@cases)))
-
-); Eval-When (Compile Eval)
-
-(two-arg-</> two-arg-< < floor ceiling
-	     ((fixnum bignum)
-	      (bignum-plus-p y))
-	     ((bignum fixnum)
-	      (not (bignum-plus-p x)))
-	     ((bignum bignum)
-	      (minusp (bignum-compare x y))))
-
-(two-arg-</> two-arg-> > ceiling floor
-	     ((fixnum bignum)
-	      (not (bignum-plus-p y)))
-	     ((bignum fixnum)
-	      (bignum-plus-p x))
-	     ((bignum bignum)
-	      (plusp (bignum-compare x y))))
-
-
-(defun two-arg-= (x y)
-  (number-dispatch ((x number) (y number))
-    (basic-compare eql)
-
-    ((fixnum (or bignum ratio)) nil)
-
-    ((bignum (or fixnum ratio)) nil)
-    ((bignum bignum)
-     (zerop (bignum-compare x y)))
-
-    ((ratio integer) nil)
-    ((ratio ratio)
-     (and (eql (numerator x) (numerator y))
-	  (eql (denominator x) (denominator y))))
-
-    ((complex complex)
-     (and (= (realpart x) (realpart y))
-	  (= (imagpart x) (imagpart y))))
-    (((foreach fixnum bignum ratio single-float double-float) complex)
-     (and (= x (realpart y))
-	  (zerop (imagpart y))))
-    ((complex (or float rational))
-     (and (= (realpart x) y)
-	  (zerop (imagpart x))))))
-
-
-;;; EQL -- Public
-;;;
-(defun eql (obj1 obj2)
-  "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
-  (or (eq obj1 obj2)
-      (if (or (typep obj2 'fixnum)
-	      (not (typep obj2 'number)))
-	  nil
-	  (macrolet ((foo (&rest stuff)
-		       `(typecase obj2
-			  ,@(mapcar #'(lambda (foo)
-					(let ((type (car foo))
-					      (fn (cadr foo)))
-					  `(,type
-					    (and (typep obj1 ',type)
-						 (,fn obj1 obj2)))))
-				    stuff))))
-	    (foo
-	      (single-float eql)
-	      (double-float eql)
-	      (bignum
-	       (lambda (x y)
-		 (zerop (bignum-compare x y))))
-	      (ratio
-	       (lambda (x y)
-		 (and (eql (numerator x) (numerator y))
-		      (eql (denominator x) (denominator y)))))
-	      (complex
-	       (lambda (x y)
-		 (and (eql (realpart x) (realpart y))
-		      (eql (imagpart x) (imagpart y))))))))))
-
-
-;;;; Logicals:
-
-(defun logior (&rest integers)
-  "Returns the bit-wise or of its arguments.  Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logior result (pop integers))))
-	  ((null integers) result))
-      0))
-
-(defun logxor (&rest integers)
-  "Returns the bit-wise exclusive or of its arguments.  Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logxor result (pop integers))))
-	  ((null integers) result))
-      0))
-
-(defun logand (&rest integers)
-  "Returns the bit-wise and of its arguments.  Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logand result (pop integers))))
-	  ((null integers) result))
-      -1))
-
-(defun logeqv (&rest integers)
-  "Returns the bit-wise equivalence of its arguments.  Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logeqv result (pop integers))))
-	  ((null integers) result))
-      -1))
-
-(defun lognand (integer1 integer2)
-  "Returns the complement of the logical AND of integer1 and integer2."
-  (lognand integer1 integer2))
-
-(defun lognor (integer1 integer2)
-  "Returns the complement of the logical OR of integer1 and integer2."
-  (lognor integer1 integer2))
-
-(defun logandc1 (integer1 integer2)
-  "Returns the logical AND of (LOGNOT integer1) and integer2."
-  (logandc1 integer1 integer2))
-
-(defun logandc2 (integer1 integer2)
-  "Returns the logical AND of integer1 and (LOGNOT integer2)."
-  (logandc2 integer1 integer2))
-
-(defun logorc1 (integer1 integer2)
-  "Returns the logical OR of (LOGNOT integer1) and integer2."
-  (logorc1 integer1 integer2))
-
-(defun logorc2 (integer1 integer2)
-  "Returns the logical OR of integer1 and (LOGNOT integer2)."
-  (logorc2 integer1 integer2))
-
-(defun lognot (number)
-  "Returns the bit-wise logical not of integer."
-  (etypecase number
-    (fixnum (lognot (truly-the fixnum number)))
-    (bignum (bignum-logical-not number))))
-
-
-(macrolet ((frob (name op big-op)
-	     `(defun ,name (x y)
-	       (number-dispatch ((x integer) (y integer))
-		 (bignum-cross-fixnum ,op ,big-op)))))
-  (frob two-arg-and logand bignum-logical-and)
-  (frob two-arg-ior logior bignum-logical-ior)
-  (frob two-arg-xor logxor bignum-logical-xor))
-
-
-(defun logcount (integer)
-  "Count the number of 1 bits if INTEGER is positive, and the number of 0 bits
-  if INTEGER is negative."
-  (etypecase integer
-    (fixnum
-     (logcount (truly-the (integer 0 #.(max most-positive-fixnum
-					    (lognot most-negative-fixnum)))
-			  (if (minusp (truly-the fixnum integer))
-			      (lognot (truly-the fixnum integer))
-			      integer))))
-    (bignum
-     (bignum-logcount integer))))
-
-(defun logtest (integer1 integer2)
-  "Predicate which returns T if logand of integer1 and integer2 is not zero."
-  (logtest integer1 integer2))
-
-(defun logbitp (index integer)
-  "Predicate returns T if bit index of integer is a 1."
-  (logbitp index integer))
-
-(defun ash (integer count)
-  "Shifts integer left by count places preserving sign.  - count shifts right."
-  (declare (integer integer count))
-  (etypecase integer
-    (fixnum
-     (cond ((zerop integer)
-	    0)
-	   ((fixnump count)
-	    (let ((length (integer-length (truly-the fixnum integer)))
-		  (count (truly-the fixnum count)))
-	      (declare (fixnum length count))
-	      (cond ((and (plusp count)
-			  (> (+ length count)
-			     (integer-length most-positive-fixnum)))
-		     (bignum-ashift-left (make-small-bignum integer) count))
-		    (t
-		     (truly-the fixnum
-				(ash (truly-the fixnum integer) count))))))
-	   ((minusp count)
-	    (if (minusp integer) -1 0))
-	   (t
-	    (bignum-ashift-left (make-small-bignum integer) count))))
-    (bignum
-     (if (plusp count)
-	 (bignum-ashift-left integer count)
-	 (bignum-ashift-right integer (- count))))))
-
-(defun integer-length (integer)
-  "Returns the number of significant bits in the absolute value of integer."
-  (etypecase integer
-    (fixnum
-     (integer-length (truly-the fixnum integer)))
-    (bignum
-     (bignum-integer-length integer))))
-
-
-;;;; Byte operations:
-
-(defun byte (size position)
-  "Returns a byte specifier which may be used by other byte functions."
-  (byte size position))
-
-(defun byte-size (bytespec)
-  "Returns the size part of the byte specifier bytespec."
-  (byte-size bytespec))
-
-(defun byte-position (bytespec)
-  "Returns the position part of the byte specifier bytespec."
-  (byte-position bytespec))
-
-(defun ldb (bytespec integer)
-  "Extract the specified byte from integer, and right justify result."
-  (ldb bytespec integer))
-
-(defun ldb-test (bytespec integer)
-  "Returns T if any of the specified bits in integer are 1's."
-  (ldb-test bytespec integer))
-
-(defun mask-field (bytespec integer)
-  "Extract the specified byte from integer,  but do not right justify result."
-  (mask-field bytespec integer))
-
-(defun dpb (newbyte bytespec integer)
-  "Returns new integer with newbyte in specified position, newbyte is right justified."
-  (dpb newbyte bytespec integer))
-
-(defun deposit-field (newbyte bytespec integer)
-  "Returns new integer with newbyte in specified position, newbyte is not right justified."
-  (deposit-field newbyte bytespec integer))
-
-
-(defun %ldb (size posn integer)
-  (logand (ash integer (- posn))
-	  (1- (ash 1 size))))
-
-(defun %mask-field (size posn integer)
-  (logand integer (ash (1- (ash 1 size)) posn)))
-
-(defun %dpb (newbyte size posn integer)
-  (let ((mask (1- (ash 1 size))))
-    (logior (logand integer (lognot (ash mask posn)))
-	    (ash (logand newbyte mask) posn))))
-
-(defun %deposit-field (newbyte size posn integer)
-  (let ((mask (ash (ldb (byte size 0) -1) posn)))
-    (logior (logand newbyte mask)
-	    (logand integer (lognot mask)))))
-
-
-;;;; Boole:
-
-;;; The boole function dispaches to any logic operation depending on
-;;;     the value of a variable.  Presently, legal selector values are [0..15].
-;;;     boole is open coded for calls with a constant selector. or with calls
-;;;     using any of the constants declared below.
-
-(defconstant boole-clr 0
-  "Boole function op, makes BOOLE return 0.")
-
-(defconstant boole-set 1
-  "Boole function op, makes BOOLE return -1.")
-
-(defconstant boole-1   2
-  "Boole function op, makes BOOLE return integer1.")
-
-(defconstant boole-2   3
-  "Boole function op, makes BOOLE return integer2.")
-
-(defconstant boole-c1  4
-  "Boole function op, makes BOOLE return complement of integer1.")
-
-(defconstant boole-c2  5
-  "Boole function op, makes BOOLE return complement of integer2.")
-
-(defconstant boole-and 6
-  "Boole function op, makes BOOLE return logand of integer1 and integer2.")
-
-(defconstant boole-ior 7
-  "Boole function op, makes BOOLE return logior of integer1 and integer2.")
-
-(defconstant boole-xor 8
-  "Boole function op, makes BOOLE return logxor of integer1 and integer2.")
-
-(defconstant boole-eqv 9
-  "Boole function op, makes BOOLE return logeqv of integer1 and integer2.")
-
-(defconstant boole-nand  10
-  "Boole function op, makes BOOLE return log nand of integer1 and integer2.")
-
-(defconstant boole-nor   11
-  "Boole function op, makes BOOLE return lognor of integer1 and integer2.")
-
-(defconstant boole-andc1 12
-  "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.")
-
-(defconstant boole-andc2 13
-  "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.")
-
-(defconstant boole-orc1  14
-  "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.")
-
-(defconstant boole-orc2  15
-  "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.")
-
-
-(defun boole (op integer1 integer2)
-  "Bit-wise boolean function on two integers.  Function chosen by OP:
-	0	BOOLE-CLR
-	1	BOOLE-SET
-	2	BOOLE-1
-  	3	BOOLE-2
-	4	BOOLE-C1
-	5	BOOLE-C2
-	6	BOOLE-AND
-	7	BOOLE-IOR
- 	8	BOOLE-XOR
-	9	BOOLE-EQV
-	10	BOOLE-NAND
-	11	BOOLE-NOR
-	12	BOOLE-ANDC1
-	13	BOOLE-ANDC2
-	14	BOOLE-ORC1
-	15	BOOLE-ORC2"
-  (case op
-    (0 (boole 0 integer1 integer2))
-    (1 (boole 1 integer1 integer2))
-    (2 (boole 2 integer1 integer2))
-    (3 (boole 3 integer1 integer2))
-    (4 (boole 4 integer1 integer2))
-    (5 (boole 5 integer1 integer2))
-    (6 (boole 6 integer1 integer2))
-    (7 (boole 7 integer1 integer2))
-    (8 (boole 8 integer1 integer2))
-    (9 (boole 9 integer1 integer2))
-    (10 (boole 10 integer1 integer2))
-    (11 (boole 11 integer1 integer2))
-    (12 (boole 12 integer1 integer2))
-    (13 (boole 13 integer1 integer2))
-    (14 (boole 14 integer1 integer2))
-    (15 (boole 15 integer1 integer2))
-    (t (error "~S is not of type (mod 16)." op))))
-
-
-;;;; GCD, LCM:
-
-(defun gcd (&rest numbers)
-  "Returns the greatest common divisor of the arguments, which must be
-  integers.  Gcd with no arguments is defined to be 0."
-  (cond ((null numbers) 0)
-	((null (cdr numbers)) (abs (the integer (car numbers))))
-	(t
-	 (do ((gcd (the integer (car numbers))
-		   (gcd gcd (the integer (car rest))))
-	      (rest (cdr numbers) (cdr rest)))
-	     ((null rest) gcd)
-	   (declare (integer gcd)
-		    (list rest))))))
-
-(defun lcm (&rest numbers)
-  "Returns the least common multiple of one or more integers.  LCM of no
-  arguments is defined to be 1."
-  (cond ((null numbers) 1)
-	((null (cdr numbers)) (abs (the integer (car numbers))))
-	(t
-	 (do ((lcm (the integer (car numbers))
-		   (lcm lcm (the integer (car rest))))
-	      (rest (cdr numbers) (cdr rest)))
-	     ((null rest) lcm)
-	   (declare (integer lcm) (list rest))))))
-
-
-(defun two-arg-lcm (n m)
-  (declare (integer n m))
-  (* (truncate (max n m) (gcd n m)) (min n m)))
-
-
-;;; TWO-ARG-GCD  --  Internal
-;;;
-;;;    Do the GCD of two integer arguments.  With fixnum arguments, we use the
-;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly
-;;; structurified), otherwise we call BIGNUM-GCD.  We pick off the special case
-;;; of 0 before the dispatch so that the bignum code doesn't have to worry
-;;; about "small bignum" zeros.
-;;;
-(defun two-arg-gcd (u v)
-  (cond ((eql u 0) v)
-	((eql v 0) u)
-	(t
-	 (number-dispatch ((u integer) (v integer))
-	   ((fixnum fixnum)
-	    (do ((k 0 (1+ k))
-		 (u (abs u) (ash u -1))
-		 (v (abs v) (ash v -1)))
-		((oddp (logior u v))
-		 (do ((temp (if (oddp u) (- v) (ash u -1))
-			    (ash temp -1)))
-		     (nil)
-		   (declare (fixnum temp))
-		   (when (oddp temp)
-		     (if (plusp temp)
-			 (setq u temp)
-			 (setq v (- temp)))
-		     (setq temp (- u v))
-		     (when (zerop temp)
-		       (return (the fixnum (ash u k)))))))
-	      (declare (fixnum k u v))))
-	   ((bignum bignum)
-	    (bignum-gcd u v))
-	   ((bignum fixnum)
-	    (bignum-gcd u (make-small-bignum v)))
-	   ((fixnum bignum)
-	    (bignum-gcd (make-small-bignum u) v))))))
-
-
-;;; Primep  --  Public
-;;;
-(defun primep (x)
-  "Returns T iff X is a positive prime integer."
-  (declare (integer x))
-  (if (<= x 5)
-      (and (>= x 2) (/= x 4))
-      (and (not (evenp x))
-	   (not (zerop (rem x 3)))
-	   (do ((q 6)
-		(r 1)
-		(inc 2 (logxor inc 6)) ;; 2,4,2,4...
-		(d 5 (+ d inc)))
-	       ((or (= r 0) (> d q)) (/= r 0))
-	     (declare (fixnum inc))
-	     (multiple-value-setq (q r) (truncate x d))))))
-
-
-;;;; Random number predicates:
-
-(macrolet ((frob (name doc)
-	     `(defun ,name (number) ,doc (,name number))))
-  (frob zerop "Returns T if number = 0, NIL otherwise.")
-  (frob plusp "Returns T if number > 0, NIL otherwise.")
-  (frob minusp "Returns T if number < 0, NIL otherwise.")
-  (frob oddp "Returns T if number is odd, NIL otherwise.")
-  (frob evenp "Returns T if number is even, NIL otherwise."))
diff --git a/code/old-loop.lisp b/code/old-loop.lisp
deleted file mode 100644
index 620ed46f6b5e07ce26bc8eb2285eaa9655be87cf..0000000000000000000000000000000000000000
--- a/code/old-loop.lisp
+++ /dev/null
@@ -1,825 +0,0 @@
-;;; -*- Package: LOOP -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/old-loop.lisp,v 1.8 1991/05/24 19:37:33 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/old-loop.lisp,v 1.8 1991/05/24 19:37:33 wlott Exp $
-;;;
-;;; Loop facility, written by William Lott.
-;;; 
-(in-package "LOOP")
-
-(in-package "LISP")
-(export '(loop loop-finish))
-
-(in-package "LOOP")
-
-
-;;;; Specials used during the parse.
-
-;;; These specials hold the different parts of the result as we are generating
-;;; them.
-;;; 
-(defvar *loop-name*)
-(defvar *outside-bindings*)
-(defvar *prologue*)
-(defvar *inside-bindings*)
-(defvar *body-forms*)
-(defvar *iteration-forms*)
-(defvar *epilogue*)
-(defvar *result-var*)
-(defvar *return-value*)
-(defvar *default-return-value*)
-(defvar *accumulation-variables*)
-
-;;; This special holds the remaining stuff we need to parse.
-;;; 
-(defvar *remaining-stuff*)
-
-;;; This special holds a value that is EQ only to itself.
-;;; 
-(defvar *magic-cookie* (list '<magic-cookie>))
-
-
-;;;; Utility functions/macros used by the parser.
-
-(proclaim '(inline maybe-car maybe-cdr))
-
-(defun maybe-car (thing)
-  (if (consp thing) (car thing) thing))
-
-(defun maybe-cdr (thing)
-  (if (consp thing) (cdr thing) thing))
-
-
-(defmacro loop-keyword-p (thing keyword &rest more-keywords)
-  `(let ((thing ,thing))
-     (and (symbolp thing)
-	  (let ((name (symbol-name thing)))
-	    (or ,@(mapcar #'(lambda (keyword)
-			      `(string= name ,keyword))
-			  (cons keyword more-keywords)))))))
-
-(defun preposition-p (prep)
-  (when (loop-keyword-p (car *remaining-stuff*) prep)
-    (pop *remaining-stuff*)
-    t))
-
-
-(defun splice-in-subform (form subform)
-  (if (eq form *magic-cookie*)
-      subform
-      (labels ((sub-splice-in-subform (form path)
-		 (cond ((atom form)
-			nil)
-		       ((member form path)
-			nil)
-		       ((eq (car form) *magic-cookie*)
-			(setf (car form) subform)
-			t)
-		       (t
-			(let ((new-path (cons form path)))
-			  (or (sub-splice-in-subform (car form) new-path)
-			      (sub-splice-in-subform (cdr form) new-path)))))))
-	(if (sub-splice-in-subform form nil)
-	    form
-	    (error "Couldn't find the magic cookie in:~% ~S~%Loop is broken."
-		   form)))))
-
-(defmacro queue-var (where name type &key
-			   (initer nil initer-p) (stepper nil stepper-p))
-  `(push (list ,name ,type ,initer-p ,initer ,stepper-p ,stepper)
-	 ,where))
-
-(defvar *default-values* '(nil 0 0.0)
-  "The different possible default values.  When we need a default value, we
-  use the first value in this list that is typep the desired type.")
-
-(defun pick-default-value (var type)
-  (if (consp var)
-      (cons (pick-default-value (car var) (maybe-car type))
-	    (pick-default-value (cdr var) (maybe-cdr type)))
-      (dolist (default *default-values*
-		       (error "Cannot default variables of type ~S ~
-		               (for variable ~S)."
-			      type var))
-	(when (typep default type)
-	  (return default)))))
-
-(defun only-simple-types (type-spec)
-  (if (atom type-spec)
-      (member type-spec '(fixnum float t nil))
-      (and (only-simple-types (car type-spec))
-	   (only-simple-types (cdr type-spec)))))
-
-
-(defun build-let-expression (vars)
-  (if (null vars)
-      (values *magic-cookie* *magic-cookie*)
-      (let ((inside nil)
-	    (outside nil)
-	    (steppers nil)
-	    (sub-lets nil))
-	(dolist (var vars)
-	  (labels
-	      ((process (name type initial-p initial stepper-p stepper)
-	         (cond ((atom name)
-			(cond ((not stepper-p)
-			       (push (list type name initial) outside))
-			      ((not initial-p)
-			       (push (list type name stepper) inside))
-			      (t
-			       (push (list type name initial) outside)
-			       (setf steppers
-				     (nconc steppers (list name stepper))))))
-		       ((and (car name) (cdr name))
-			(let ((temp (gensym (format nil "TEMP-FOR-~A-" name))))
-			  (process temp 'list initial-p initial
-				   stepper-p stepper)
-			  (push (if stepper-p
-				    (list (car name)
-					  (maybe-car type)
-					  nil nil
-					  t `(car ,temp))
-				    (list (car name)
-					  (maybe-car type)
-					  t `(car ,temp)
-					  nil nil))
-				sub-lets)
-			  (push (if stepper-p
-				    (list (cdr name)
-					  (maybe-cdr type)
-					  nil nil
-					  t `(cdr ,temp))
-				    (list (car name)
-					  (maybe-cdr type)
-					  t `(cdr ,temp)
-					  nil nil))
-				sub-lets)))
-		       ((car name)
-			(process (car name)
-				 (maybe-car type)
-				 initial-p `(car ,initial)
-				 stepper-p `(car ,stepper)))
-		       ((cdr name)
-			(process (cdr name)
-				 (maybe-cdr type)
-				 initial-p `(cdr ,initial)
-				 stepper-p `(cdr ,stepper))))))
-	    (process (first var) (second var) (third var)
-		     (fourth var) (fifth var) (sixth var))))
-	(when steppers
-	  (push (cons 'psetq steppers)
-		*iteration-forms*))
-	(multiple-value-bind
-	    (sub-outside sub-inside)
-	    (build-let-expression sub-lets)
-	  (values (build-bindings outside sub-outside)
-		  (build-bindings inside sub-inside))))))
-
-(defun build-bindings (vars guts)
-  (if (null vars)
-      guts
-      `(let ,(mapcar #'cdr vars)
-	 (declare ,@(mapcar #'build-declare vars))
-	 ,guts)))
-
-(defun build-declare (var)
-  `(type ,(car var) ,(cadr var)))
-
-
-
-;;;; LOOP itself.
-
-(defmacro loop (&rest stuff)
-  "General iteration facility.  See the manual for details, 'cause it's
-  very confusing."
-  (if (some #'atom stuff)
-      (parse-loop stuff)
-      (let ((repeat (gensym "REPEAT-"))
-	    (out-of-here (gensym "OUT-OF-HERE-")))
-	`(block nil
-	   (tagbody
-	    ,repeat
-	    (macrolet ((loop-finish () `(go ,out-of-here)))
-	      ,@stuff)
-	    (go ,repeat)
-	    ,out-of-here)))))
-
-
-
-;;;; The parser.
-
-;;; Top level parser.  Bind the specials, and call the other parsers.
-;;; 
-(defun parse-loop (stuff)
-  (let* ((*prologue* nil)
-	 (*outside-bindings* *magic-cookie*)
-	 (*inside-bindings* *magic-cookie*)
-	 (*body-forms* nil)
-	 (*iteration-forms* nil)
-	 (*epilogue* nil)
-	 (*result-var* nil)
-	 (*return-value* nil)
-	 (*default-return-value* nil)
-	 (*accumulation-variables* nil)
-	 (*remaining-stuff* stuff)
-	 (name (parse-named)))
-    (loop
-      (when (null *remaining-stuff*)
-	(return))
-      (let ((clause (pop *remaining-stuff*)))
-	(cond ((not (symbolp clause))
-	       (error "Invalid clause, ~S, must be a symbol." clause))
-	      ((loop-keyword-p clause "INITIALLY")
-	       (setf *prologue* (nconc *prologue* (parse-expr-list))))
-	      ((loop-keyword-p clause "FINALLY")
-	       (parse-finally))
-	      ((loop-keyword-p clause "WITH")
-	       (parse-with))
-	      ((loop-keyword-p clause "FOR" "AS")
-	       (parse-for-as))
-	      ((loop-keyword-p clause "REPEAT")
-	       (parse-repeat))
-	      (t
-	       (push clause *remaining-stuff*)
-	       (return)))))
-    (loop
-      (when (null *remaining-stuff*)
-	(return))
-      (let ((clause (pop *remaining-stuff*)))
-	(cond ((not (symbolp clause))
-	       (error "Invalid clause, ~S, must be a symbol." clause))
-	      ((loop-keyword-p clause "INITIALLY")
-	       (setf *prologue* (nconc *prologue* (parse-expr-list))))
-	      ((loop-keyword-p clause "FINALLY")
-	       (parse-finally))
-	      ((loop-keyword-p clause "WHILE")
-	       (setf *body-forms*
-		     (nconc *body-forms*
-			    `((unless ,(pop *remaining-stuff*)
-				(loop-finish))))))
-	      ((loop-keyword-p clause "UNTIL")
-	       (setf *body-forms*
-		     (nconc *body-forms*
-			    `((when ,(pop *remaining-stuff*) (loop-finish))))))
-	      ((loop-keyword-p clause "ALWAYS")
-	       (setf *body-forms*
-		     (nconc *body-forms*
-			    `((unless ,(pop *remaining-stuff*)
-				(return-from ,name nil)))))
-	       (setf *default-return-value* t))
-	      ((loop-keyword-p clause "NEVER")
-	       (setf *body-forms*
-		     (nconc *body-forms*
-			    `((when ,(pop *remaining-stuff*)
-				(return-from ,name nil)))))
-	       (setf *default-return-value* t))
-	      ((loop-keyword-p clause "THEREIS")
-	       (setf *body-forms*
-		     (nconc *body-forms*
-			    (let ((temp (gensym "THEREIS-")))
-			      `((let ((,temp ,(pop *remaining-stuff*)))
-				  (when ,temp
-				    (return-from ,name ,temp))))))))
-	      (t
-	       (push clause *remaining-stuff*)
-	       (or (maybe-parse-unconditional)
-		   (maybe-parse-conditional)
-		   (maybe-parse-accumulation)
-		   (error "Unknown clause, ~S" clause))))))
-    (let ((again-tag (gensym "AGAIN-"))
-	  (end-tag (gensym "THIS-IS-THE-END-")))
-      `(block ,name
-	 ,(splice-in-subform
-	   *outside-bindings*
-	   `(macrolet ((loop-finish () '(go ,end-tag)))
-	      (tagbody
-	       ,@*prologue*
-	       ,again-tag
-	       ,(splice-in-subform
-		 *inside-bindings*
-		 `(progn
-		    ,@*body-forms*
-		    ,@(nreverse *iteration-forms*)))
-	       (go ,again-tag)
-	       ,end-tag
-	       ,@*epilogue*
-	       (return-from ,name
-			    ,(or *return-value*
-				 *default-return-value*
-				 *result-var*)))))))))
-
-(defun parse-named ()
-  (when (loop-keyword-p (car *remaining-stuff*) "NAMED")
-    (pop *remaining-stuff*)
-    (if (symbolp (car *remaining-stuff*))
-	(pop *remaining-stuff*)
-	(error "Loop name ~S is not a symbol." (car *remaining-stuff*)))))
-
-
-(defun parse-expr-list ()
-  (let ((results nil))
-    (loop
-      (when (atom (car *remaining-stuff*))
-	(return (nreverse results)))
-      (push (pop *remaining-stuff*) results))))
-
-(defun parse-finally ()
-  (let ((sub-clause (pop *remaining-stuff*)))
-    (if (loop-keyword-p sub-clause "RETURN")
-	(cond ((not (null *return-value*))
-	       (error "Cannot specify two FINALLY RETURN clauses."))
-	      ((null *remaining-stuff*)
-	       (error "FINALLY RETURN must be followed with an expression."))
-	      (t
-	       (setf *return-value* (pop *remaining-stuff*))))
-	(progn
-	  (unless (loop-keyword-p sub-clause "DO" "DOING")
-	    (push sub-clause *remaining-stuff*))
-	  (setf *epilogue* (nconc *epilogue* (parse-expr-list)))))))
-
-(defun parse-with ()
-  (let ((vars nil))
-    (loop
-      (multiple-value-bind (var type) (parse-var-and-type-spec)
-	(let ((initial
-	       (if (loop-keyword-p (car *remaining-stuff*) "=")
-		   (progn
-		     (pop *remaining-stuff*)
-		     (pop *remaining-stuff*))
-		   (list 'quote
-			 (pick-default-value var type)))))
-	  (queue-var vars var type :initer initial)))
-      (if (loop-keyword-p (car *remaining-stuff*) "AND")
-	  (pop *remaining-stuff*)
-	  (return)))
-    (multiple-value-bind
-	(outside inside)
-	(build-let-expression vars)
-      (setf *outside-bindings*
-	    (splice-in-subform *outside-bindings* outside))
-      (setf *inside-bindings*
-	    (splice-in-subform *inside-bindings* inside)))))
-
-(defun parse-var-and-type-spec ()
-  (values (pop *remaining-stuff*)
-	  (parse-type-spec t)))
-
-(defun parse-type-spec (default)
-  (cond ((preposition-p "OF-TYPE")
-	 (pop *remaining-stuff*))
-	((and *remaining-stuff*
-	      (only-simple-types (car *remaining-stuff*)))
-	 (pop *remaining-stuff*))
-	(t
-	 default)))
-
-
-
-;;;; FOR/AS stuff.
-
-;;; These specials hold the vars that need to be bound for this FOR/AS clause
-;;; and all of the FOR/AS clauses connected with AND.  All the *for-as-vars*
-;;; are bound in parallel followed by the *for-as-sub-vars*.
-;;; 
-(defvar *for-as-vars*)
-(defvar *for-as-sub-vars*)
-
-;;; These specials hold any extra termination tests.  *for-as-term-tests* are
-;;; processed after the *for-as-vars* are bound, but before the
-;;; *for-as-sub-vars*.  *for-as-sub-term-tests* are processed after the
-;;; *for-as-sub-vars*.
-
-(defvar *for-as-term-tests*)
-(defvar *for-as-sub-term-tests*)
-
-
-(defun parse-for-as ()
-  (let ((*for-as-vars* nil)
-	(*for-as-term-tests* nil)
-	(*for-as-sub-vars* nil)
-	(*for-as-sub-term-tests* nil))
-    (loop
-      (multiple-value-bind (name type) (parse-var-and-type-spec)
-	(let ((sub-clause (pop *remaining-stuff*)))
-	  (cond ((loop-keyword-p sub-clause "FROM" "DOWNFROM" "UPFROM"
-				 "TO" "DOWNTO" "UPTO" "BELOW" "ABOVE")
-		 (parse-arithmetic-for-as sub-clause name type))
-		((loop-keyword-p sub-clause "IN")
-		 (parse-in-for-as name type))
-		((loop-keyword-p sub-clause "ON")
-		 (parse-on-for-as name type))
-		((loop-keyword-p sub-clause "=")
-		 (parse-equals-for-as name type))
-		((loop-keyword-p sub-clause "ACROSS")
-		 (parse-across-for-as name type))
-		((loop-keyword-p sub-clause "BEING")
-		 (parse-being-for-as name type))
-		(t
-		 (error "Invalid FOR/AS subclause: ~S" sub-clause)))))
-      (if (loop-keyword-p (car *remaining-stuff*) "AND")
-	  (pop *remaining-stuff*)
-	  (return)))
-    (multiple-value-bind
-	(outside inside)
-	(build-let-expression *for-as-vars*)
-      (multiple-value-bind
-	  (sub-outside sub-inside)
-	  (build-let-expression *for-as-sub-vars*)
-	(setf *outside-bindings*
-	      (splice-in-subform *outside-bindings*
-				 (splice-in-subform outside sub-outside)))
-	(let ((inside-body
-	       (if *for-as-term-tests*
-		   `(if (or ,@(nreverse *for-as-term-tests*))
-			(loop-finish)
-			,*magic-cookie*)
-		   *magic-cookie*))
-	      (sub-inside-body
-	       (if *for-as-sub-term-tests*
-		   `(if (or ,@(nreverse *for-as-sub-term-tests*))
-			(loop-finish)
-			,*magic-cookie*)
-		   *magic-cookie*)))
-	  (setf *inside-bindings*
-		(splice-in-subform
-		 *inside-bindings*
-		 (splice-in-subform
-		  inside
-		  (splice-in-subform
-		   inside-body
-		   (splice-in-subform
-		    sub-inside
-		    sub-inside-body))))))))))
-
-(defun parse-arithmetic-for-as (sub-clause name type)
-  (unless (atom name)
-    (error "Cannot destructure arithmetic FOR/AS variables: ~S" name))
-  (let (start stop (inc 1) dir exclusive-p)
-    (cond ((loop-keyword-p sub-clause "FROM")
-	   (setf start (pop *remaining-stuff*)))
-	  ((loop-keyword-p sub-clause "DOWNFROM")
-	   (setf start (pop *remaining-stuff*))
-	   (setf dir :down))
-	  ((loop-keyword-p sub-clause "UPFROM")
-	   (setf start (pop *remaining-stuff*))
-	   (setf dir :up))
-	  (t
-	   (push sub-clause *remaining-stuff*)))
-    (cond ((preposition-p "TO")
-	   (setf stop (pop *remaining-stuff*)))
-	  ((preposition-p "DOWNTO")
-	   (setf stop (pop *remaining-stuff*))
-	   (if (eq dir :up)
-	       (error "Can't mix UPFROM and DOWNTO in ~S." name)
-	       (setf dir :down)))
-	  ((preposition-p "UPTO")
-	   (setf stop (pop *remaining-stuff*))
-	   (if (eq dir :down)
-	       (error "Can't mix DOWNFROM and UPTO in ~S." name)
-	       (setf dir :up)))
-	  ((preposition-p "ABOVE")
-	   (setf stop (pop *remaining-stuff*))
-	   (setf exclusive-p t)
-	   (if (eq dir :up)
-	       (error "Can't mix UPFROM and ABOVE in ~S." name)
-	       (setf dir :down)))
-	  ((preposition-p "BELOW")
-	   (setf stop (pop *remaining-stuff*))
-	   (setf exclusive-p t)
-	   (if (eq dir :down)
-	       (error "Can't mix DOWNFROM and BELOW in ~S." name)
-	       (setf dir :up))))
-    (when (preposition-p "BY")
-      (setf inc (pop *remaining-stuff*)))
-    (when (and (eq dir :down) (null start))
-      (error "No default starting value for decremental stepping."))
-    (let ((temp (gensym "TEMP-AMOUNT-")))
-      (queue-var *for-as-sub-vars* temp type :initer inc)
-      (queue-var *for-as-sub-vars* name type
-		 :initer (or start 0)
-		 :stepper `(,(if (eq dir :down) '- '+) ,name ,temp))
-      (when stop
-	(let ((stop-var (gensym "STOP-VAR-")))
-	  (queue-var *for-as-sub-vars* stop-var type :initer stop)
-	  (push (list (if (eq dir :down)
-			  (if exclusive-p '<= '<)
-			  (if exclusive-p '>= '>))
-		      name stop-var)
-		*for-as-sub-term-tests*))))))
-
-(defun parse-in-for-as (name type)
-  (let* ((temp (gensym "LIST-"))
-	 (initer (pop *remaining-stuff*))
-	 (stepper (if (preposition-p "BY")
-		      `(funcall ,(pop *remaining-stuff*) ,temp)
-		      `(cdr ,temp))))
-    (queue-var *for-as-vars* temp 'list :initer initer :stepper stepper)
-    (queue-var *for-as-sub-vars* name type :stepper `(car ,temp))
-    (push `(null ,temp) *for-as-sub-term-tests*)))
-
-(defun parse-on-for-as (name type)
-  (let* ((temp (if (atom name) name (gensym "LIST-")))
-	 (initer (pop *remaining-stuff*))
-	 (stepper (if (preposition-p "BY")
-		      `(funcall ,(pop *remaining-stuff*) ,temp)
-		      `(cdr ,temp))))
-    (cond ((atom name)
-	   (queue-var *for-as-sub-vars* name type
-		      :initer initer :stepper stepper)
-	   (push `(endp ,name) *for-as-sub-term-tests*))
-	  (t
-	   (queue-var *for-as-vars* temp type
-		      :initer initer :stepper stepper)
-	   (queue-var *for-as-sub-vars* name type :stepper temp)
-	   (push `(endp ,temp) *for-as-term-tests*)))))
-
-(defun parse-equals-for-as (name type)
-  (let ((initer (pop *remaining-stuff*)))
-    (if (preposition-p "THEN")
-	(queue-var *for-as-sub-vars* name type
-		   :initer initer :stepper (pop *remaining-stuff*))
-	(queue-var *for-as-vars* name type :stepper initer))))
-
-(defun parse-across-for-as (name type)
-  (let* ((temp (gensym "VECTOR-"))
-	 (length (gensym "LENGTH-"))
-	 (index (gensym "INDEX-")))
-    (queue-var *for-as-vars* temp `(vector ,type)
-	       :initer (pop *remaining-stuff*))
-    (queue-var *for-as-sub-vars* length 'fixnum
-	       :initer `(length ,temp))
-    (queue-var *for-as-vars* index 'fixnum :initer 0 :stepper `(1+ ,index))
-    (queue-var *for-as-sub-vars* name type :stepper `(aref ,temp ,index))
-    (push `(>= ,index ,length) *for-as-term-tests*)))
-
-(defun parse-being-for-as (name type)
-  (let ((clause (pop *remaining-stuff*)))
-    (unless (loop-keyword-p clause "EACH" "THE")
-      (error "BEING must be followed by either EACH or THE, not ~S"
-	     clause)))
-  (let ((clause (pop *remaining-stuff*)))
-    (cond ((loop-keyword-p clause "HASH-KEY" "HASH-KEYS"
- 			   "HASH-VALUE" "HASH-VALUES")
-	   (let ((prep (pop *remaining-stuff*)))
-	     (unless (loop-keyword-p prep "IN" "OF")
-	       (error "~A must be followed by either IN or OF, not ~S"
-		      (symbol-name clause) prep)))
-	   (let ((table (pop *remaining-stuff*))
-		 (iterator (gensym (format nil "~A-ITERATOR-" name)))
-		 (exists-temp (gensym (format nil "~A-EXISTS-TEMP-" name)))
-		 (key-temp (gensym (format nil "~A-KEY-TEMP-" name)))
-		 (value-temp (gensym (format nil "~A-VALUE-TEMP-" name))))
-	     (setf *outside-bindings*
-		   (splice-in-subform
-		    *outside-bindings*
-		    `(with-hash-table-iterator (,iterator ,table)
-					       ,*magic-cookie*)))
-	     (multiple-value-bind
-		 (using using-type)
-		 (when (preposition-p "USING")
-		   ;; ### This is wrong.
-		   (parse-var-and-type-spec))
-	       (multiple-value-bind
-		   (key-var key-type value-var value-type)
-		   (if (loop-keyword-p clause "HASH-KEY" "HASH-KEYS")
-		       (values name type using using-type)
-		       (values using using-type name type))
-		 (setf *inside-bindings*
-		       (splice-in-subform
-			*inside-bindings*
-			`(multiple-value-bind
-			     (,exists-temp ,key-temp ,value-temp)
-			     (,iterator)
-			   ,@(unless (and key-var value-var)
-			       `((declare (ignore ,@(if (null key-var)
-							(list key-temp))
-						  ,@(if (null value-var)
-							(list value-temp))))))
-			   ,*magic-cookie*)))
-		 (push `(not ,exists-temp) *for-as-term-tests*)
-		 (when key-var
-		   (queue-var *for-as-sub-vars* key-var key-type
-			      :stepper key-temp))
-		 (when value-var
-		   (queue-var *for-as-sub-vars* value-var value-type
-			      :stepper value-temp))))))
-	  ((loop-keyword-p clause "SYMBOL" "PRESENT-SYMBOL" "EXTERNAL-SYMBOL"
-			   "SYMBOLS" "PRESENT-SYMBOLS" "EXTERNAL-SYMBOLS")
-	   (let ((package
-		  (if (or (preposition-p "IN")
-			  (preposition-p "OF"))
-		      (pop *remaining-stuff*)
-		      '*package*))
-		 (iterator (gensym (format nil "~A-ITERATOR-" name)))
-		 (exists-temp (gensym (format nil "~A-EXISTS-TEMP-" name)))
-		 (symbol-temp (gensym (format nil "~A-SYMBOL-TEMP-" name))))
-	     (setf *outside-bindings*
-		   (splice-in-subform
-		    *outside-bindings*
-		    `(with-package-iterator
-			 (,iterator
-			  ,package
-			  ,@(cond ((loop-keyword-p clause "SYMBOL" "SYMBOLS")
-				   '(:internal :external :inherited))
-				  ((loop-keyword-p clause "PRESENT-SYMBOL"
-						   "PRESENT-SYMBOLS")
-				   '(:internal))
-				  ((loop-keyword-p clause "EXTERNAL-SYMBOL"
-						   "EXTERNAL-SYMBOLS")
-				   '(:external))
-				  (t
-				   (error "Don't know how to deal with ~A?  ~
-				           Bug in LOOP?" clause))))
-		       ,*magic-cookie*)))
-	     (setf *inside-bindings*
-		   (splice-in-subform
-		    *inside-bindings*
-		    `(multiple-value-bind
-			 (,exists-temp ,symbol-temp)
-			 (,iterator)
-		       ,*magic-cookie*)))
-	     (push `(not ,exists-temp) *for-as-term-tests*)
-	     (queue-var *for-as-sub-vars* name type :stepper symbol-temp)))
-	  (t
-	   (error
-	    "Unknown sub-clause, ~A, for BEING.  Must be one of:~%  ~
-	     HASH-KEY HASH-KEYS HASH-VALUE HASH-VALUES SYMBOL SYMBOLS~%  ~
-	     PRESENT-SYMBOL PRESENT-SYMBOLS EXTERNAL-SYMBOL EXTERNAL-SYMBOLS"
-	    (symbol-name clause))))))
-
-
-
-;;;;
-
-(defun parse-repeat ()
-  (let ((temp (gensym "REPEAT-")))
-    (setf *outside-bindings*
-	  (splice-in-subform *outside-bindings*
-			     `(let ((,temp ,(pop *remaining-stuff*)))
-				,*magic-cookie*)))
-    (setf *inside-bindings*
-	  (splice-in-subform *inside-bindings*
-			     `(if (minusp (decf ,temp))
-				  (loop-finish)
-				  ,*magic-cookie*)))))
-
-
-(defun maybe-parse-unconditional ()
-  (when (loop-keyword-p (car *remaining-stuff*) "DO" "DOING")
-    (pop *remaining-stuff*)
-    (setf *body-forms* (nconc *body-forms* (parse-expr-list)))
-    t))
-
-(defun maybe-parse-conditional ()
-  (let ((clause (pop *remaining-stuff*)))
-    (cond ((loop-keyword-p clause "IF" "WHEN")
-	   (parse-conditional (pop *remaining-stuff*))
-	   t)
-	  ((loop-keyword-p clause "UNLESS")
-	   (parse-conditional `(not ,(pop *remaining-stuff*)))
-	   t)
-	  (t
-	   (push clause *remaining-stuff*)
-	   nil))))
-
-(defun parse-conditional (condition)
-  (let ((clauses (parse-and-clauses))
-	(else-clauses (when (preposition-p "ELSE")
-			(parse-and-clauses))))
-    (setf *body-forms*
-	  (nconc *body-forms*
-		 `((if ,condition
-		       (progn
-			 ,@clauses)
-		       (progn
-			 ,@else-clauses)))))
-    (preposition-p "END")))
-
-(defun parse-and-clauses ()
-  (let ((*body-forms* nil))
-    (loop
-      (or (maybe-parse-unconditional)
-	  (maybe-parse-conditional)
-	  (maybe-parse-accumulation)
-	  (error "Invalid clause for inside a conditional: ~S"
-		 (car *remaining-stuff*)))
-      (unless (preposition-p "AND")
-	(return *body-forms*)))))
-
-
-;;;; Assumulation stuff
-
-(defun maybe-parse-accumulation ()
-  (when (loop-keyword-p (car *remaining-stuff*)
-		       "COLLECT" "COLLECTING"
-		       "APPEND" "APPENDING" "NCONC" "NCONCING"
-		       "COUNT" "COUNTING" "SUM" "SUMMING"
-		       "MAXIMIZE" "MAXIMIZING" "MINIMIZE" "MINIMIZING")
-    (parse-accumulation)
-    t))
-
-(defun parse-accumulation ()
-  (let* ((clause (pop *remaining-stuff*))
-	 (expr (pop *remaining-stuff*))
-	 (var (if (preposition-p "INTO")
-		  (pop *remaining-stuff*)
-		  (or *result-var*
-		      (setf *result-var*
-			    (gensym (concatenate 'simple-string
-						 (string clause)
-						 "-"))))))
-	 (info (assoc var *accumulation-variables*))
-	 (type nil)
-	 (initial nil))
-    (cond ((loop-keyword-p clause "COLLECT" "COLLECTING" "APPEND" "APPENDING"
-			   "NCONC" "NCONCING")
-	   (setf initial nil)
-	   (setf type 'list)
-	   (let ((aux-var
-		  (or (caddr info)
-		      (let ((aux-var (gensym "LAST-")))
-			(setf *outside-bindings*
-			      (splice-in-subform *outside-bindings*
-						 `(let ((,var nil)
-							(,aux-var nil))
-						    (declare (type list
-								   ,var
-								   ,aux-var))
-						    ,*magic-cookie*)))
-			(if (null info)
-			    (push (setf info (list var 'list aux-var))
-				  *accumulation-variables*)
-			    (setf (cddr info) (list aux-var)))
-			aux-var)))
-		 (value
-		  (cond ((loop-keyword-p clause "COLLECT" "COLLECTING")
-			 `(list ,expr))
-			((loop-keyword-p clause "APPEND" "APPENDING")
-			 `(copy-list ,expr))
-			((loop-keyword-p clause "NCONC" "NCONCING")
-			 expr)
-			(t
-			 (error "Bug in loop?")))))
-	     (setf *body-forms*
-		   (nconc *body-forms*
-			  `((cond ((null ,var)
-				   (setf ,var ,value)
-				   (setf ,aux-var (last ,var)))
-				  (t
-				   (nconc ,aux-var ,value)
-				   (setf ,aux-var (last ,aux-var)))))))))
-	  ((loop-keyword-p clause "COUNT" "COUNTING")
-	   (setf type (parse-type-spec 'unsigned-byte))
-	   (setf initial 0)
-	   (setf *body-forms*
-		 (nconc *body-forms*
-			`((when ,expr (incf ,var))))))
-	  ((loop-keyword-p clause "SUM" "SUMMING")
-	   (setf type (parse-type-spec 'number))
-	   (setf initial 0)
-	   (setf *body-forms*
-		 (nconc *body-forms*
-			`((incf ,var ,expr)))))
-	  ((loop-keyword-p clause "MAXIMIZE" "MAXIMIZING")
-	   (setf type `(or null ,(parse-type-spec 'number)))
-	   (setf initial nil)
-	   (setf *body-forms*
-		 (nconc *body-forms*
-			(let ((temp (gensym "MAX-TEMP-")))
-			  `((let ((,temp ,expr))
-			      (when (or (null ,var)
-					(> ,temp ,var))
-				(setf ,var ,temp))))))))
-	  ((loop-keyword-p clause "MINIMIZE" "MINIMIZING")
-	   (setf type `(or null ,(parse-type-spec 'number)))
-	   (setf initial nil)
-	   (setf *body-forms*
-		 (nconc *body-forms*
-			(let ((temp (gensym "MIN-TEMP-")))
-			  `((let ((,temp ,expr))
-			      (when (or (null ,var)
-					(< ,temp ,var))
-				(setf ,var ,temp))))))))
-	  (t
-	   (error "Invalid accumulation clause: ~S" clause)))
-    (cond (info
-	   (unless (equal type (cadr info))
-	     (error "Attempt to use ~S for both types ~S and ~S."
-		    var type (cadr info))))
-	  (t
-	   (push (list var type) *accumulation-variables*)
-	   (setf *outside-bindings*
-		 (splice-in-subform *outside-bindings*
-				    `(let ((,var ,initial))
-				       (declare (type ,type ,var))
-				       ,*magic-cookie*)))))))
diff --git a/code/package.lisp b/code/package.lisp
deleted file mode 100644
index 116fdb15166c13591bfb8fa56e105ac1084e6e83..0000000000000000000000000000000000000000
--- a/code/package.lisp
+++ /dev/null
@@ -1,1455 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.27 1992/11/30 16:41:45 phg Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;     Package stuff and stuff like that.
-;;;
-;;; Re-Written by Rob MacLachlan.  Earlier version written by
-;;; Lee Schumacher.  Apropos & iteration macros courtesy of Skef Wholey.
-;;; Defpackage by Dan Zigmond.  With-Package-Iterator by Blaine Burks. 
-;;; Defpackage and do-mumble-symbols macros re-written by William Lott.
-;;;
-(in-package 'lisp)
-(export '(package packagep *package* make-package in-package find-package
-	  package-name package-nicknames rename-package delete-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 with-package-iterator
-	  do-external-symbols do-all-symbols apropos apropos-list defpackage))
-
-(in-package "EXTENSIONS")
-(export '(*keyword-package* *lisp-package* *default-package-use-list*))
-
-(in-package "KERNEL")
-(export '(%in-package old-in-package))
-
-(in-package 'lisp)
-
-(defvar *default-package-use-list* '("COMMON-LISP")
-  "The list of packages to use by default of no :USE argument is supplied
-   to MAKE-PACKAGE or other package creation forms.")
-
-
-(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)))))
-	    (:make-load-form-fun
-	     (lambda (package)
-	       (values `(package-or-lose ',(package-name package))
-		       nil))))
-  "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.
-
-(macrolet ((frob (ext real)
-	     `(defun ,ext (x) (,real (package-or-lose x)))))
-  (frob package-name package-%name)
-  (frob package-nicknames package-%nicknames)
-  (frob package-use-list package-%use-list)
-  (frob package-used-by-list package-%used-by-list)
-  (frob package-shadowing-symbols package-%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 (%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 (+ ,index-var ,h2))
-	 (when (>= ,index-var ,len)
-	   (setq ,index-var (- ,index-var ,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 (%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.
-
-(defmacro do-symbols ((var &optional (package '*package*) result-form)
-		      &body body)
-  "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
-   Executes the FORMs at least once for each symbol accessible in the given
-   PACKAGE with VAR bound to the current symbol."
-  (let ((flet-name (gensym "DO-SYMBOLS-")))
-    `(block nil
-       (flet ((,flet-name (,var) ,@body))
-	 (let* ((package (package-or-lose ,package))
-		(shadows (package-%shadowing-symbols package)))
-	   (flet ((iterate-over-hash-table (table ignore)
-		    (let ((hash-vec (package-hashtable-hash table))
-			  (sym-vec (package-hashtable-table table)))
-		      (declare (type (simple-array (unsigned-byte 8) (*))
-				     hash-vec)
-			       (type simple-vector sym-vec))
-		      (dotimes (i (length sym-vec))
-			(when (>= (aref hash-vec i) 2)
-			  (let ((sym (aref sym-vec i)))
-			    (unless (member sym ignore)
-			      (,flet-name sym))))))))
-	     (iterate-over-hash-table (package-internal-symbols package) nil)
-	     (iterate-over-hash-table (package-external-symbols package) nil)
-	     (dolist (table (cdr (package-tables package)))
-	       (iterate-over-hash-table table shadows)))))
-       (let ((,var nil))
-	 (declare (ignorable ,var))
-	 ,result-form))))
-
-(defmacro do-external-symbols ((var &optional (package '*package*) result-form)
-			       &body body)
-  "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
-   Executes the FORMs once for each external symbol in the given PACKAGE with
-   VAR bound to the current symbol."
-  (let ((flet-name (gensym "DO-SYMBOLS-")))
-    `(block nil
-       (flet ((,flet-name (,var)
-		,@body))
-	 (let* ((package (package-or-lose ,package))
-		(table (package-external-symbols package))
-		(hash-vec (package-hashtable-hash table))
-		(sym-vec (package-hashtable-table table)))
-	   (declare (type (simple-array (unsigned-byte 8) (*))
-			  hash-vec)
-		    (type simple-vector sym-vec))
-	   (dotimes (i (length sym-vec))
-	     (when (>= (aref hash-vec i) 2)
-	       (,flet-name (aref sym-vec i))))))
-       (let ((,var nil))
-	 (declare (ignorable ,var))
-	 ,result-form))))
-
-(defmacro do-all-symbols ((var &optional result-form) &body body)
-  "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
-   Executes the FORMs once for each symbol in every package with VAR bound
-   to the current symbol."
-  (let ((flet-name (gensym "DO-SYMBOLS-")))
-    `(block nil
-       (flet ((,flet-name (,var)
-		,@body))
-	 (dolist (package (list-all-packages))
-	   (flet ((iterate-over-hash-table (table)
-		    (let ((hash-vec (package-hashtable-hash table))
-			  (sym-vec (package-hashtable-table table)))
-		      (declare (type (simple-array (unsigned-byte 8) (*))
-				     hash-vec)
-			       (type simple-vector sym-vec))
-		      (dotimes (i (length sym-vec))
-			(when (>= (aref hash-vec i) 2)
-			  (,flet-name (aref sym-vec i)))))))
-	     (iterate-over-hash-table (package-internal-symbols package))
-	     (iterate-over-hash-table (package-external-symbols package)))))
-       (let ((,var nil))
-	 (declare (ignorable ,var))
-	 ,result-form))))
-
-
-;;;; WITH-PACKAGE-ITERATOR
-
-(defmacro with-package-iterator ((mname package-list &rest symbol-types)
-				 &body body)
-  (let* ((packages (gensym))
-	 (these-packages (gensym))
-	 (ordered-types (let ((res nil))
-			  (dolist (kind '(:inherited :external :internal)
-					res)
-			    (when (member kind symbol-types)
-			      (push kind res)))))  ; Order symbol-types.
-	 (counter (gensym))
-	 (kind (gensym))
-	 (hash-vector (gensym))
-	 (vector (gensym))
-	 (package-use-list (gensym))
-	 (init-macro (gensym))
-	 (end-test-macro (gensym))
-	 (real-symbol-p (gensym))
-	 (BLOCK (gensym)))
-    `(let* ((,these-packages ,package-list)
-	    (,packages `,(mapcar #'(lambda (package)
-				     (if (packagep package)
-					 package
-					 (find-package package)))
-				 (if (consp ,these-packages)
-				     ,these-packages
-				     (list ,these-packages))))
-	    (,counter nil)
-	    (,kind (car ,packages))
-	    (,hash-vector nil)
-	    (,vector nil)
-	    (,package-use-list nil))
-       ,(if (member :inherited ordered-types)
-	    `(setf ,package-use-list (package-%use-list (car ,packages)))
-	    `(declare (ignore ,package-use-list)))
-       (macrolet ((,init-macro (next-kind)
- 	 (let ((symbols (gensym)))
-	   `(progn
-	      (setf ,',kind ,next-kind)
-	      (setf ,',counter nil)
-	      ,(case next-kind
-		 (:internal
-		  `(let ((,symbols (package-internal-symbols
-				    (car ,',packages))))
-		     (setf ,',vector (package-hashtable-table ,symbols))
-		     (setf ,',hash-vector (package-hashtable-hash ,symbols))))
-		 (:external
-		  `(let ((,symbols (package-external-symbols
-				    (car ,',packages))))
-		     (setf ,',vector (package-hashtable-table ,symbols))
-		     (setf ,',hash-vector (package-hashtable-hash ,symbols))))
-		 (:inherited
-		  `(let ((,symbols (package-external-symbols
-				    (car ,',package-use-list))))
-		     (setf ,',vector (package-hashtable-table ,symbols))
-		     (setf ,',hash-vector (package-hashtable-hash ,symbols))))))))
-		  (,end-test-macro (this-kind)
-		     `,(let ((next-kind (cadr (member this-kind
-						      ',ordered-types))))
-			 (if next-kind
-			     `(,',init-macro ,next-kind)
-			     `(if (endp (setf ,',packages (cdr ,',packages)))
-				  (return-from ,',BLOCK)
-				  (,',init-macro ,(car ',ordered-types)))))))
-	 (when ,packages
-	   ,(when (null symbol-types)
-	      (error "Must supply at least one of :internal, :external, or ~
-	      :inherited."))
-	   ,(dolist (symbol symbol-types)
-	      (unless (member symbol '(:internal :external :inherited))
-		(error "~S is not one of :internal, :external, or :inherited."
-		       symbol)))
-	   (,init-macro ,(car ordered-types))
-	   (flet ((,real-symbol-p (number)
-		    (> number 1)))
-	     (macrolet ((,mname ()
-	      `(block ,',BLOCK
-		 (loop
-		   (case ,',kind
-		     ,@(when (member :internal ',ordered-types)
-			 `((:internal
-			    (setf ,',counter
-				  (position-if #',',real-symbol-p ,',hash-vector
-					       :start (if ,',counter
-							  (1+ ,',counter)
-							  0)))
-			    (if ,',counter
-				(return-from ,',BLOCK
-				 (values t (svref ,',vector ,',counter)
-					 ,',kind (car ,',packages)))
-				(,',end-test-macro :internal)))))
-		     ,@(when (member :external ',ordered-types)
-			 `((:external
-			    (setf ,',counter
-				  (position-if #',',real-symbol-p ,',hash-vector
-					       :start (if ,',counter
-							  (1+ ,',counter)
-							  0)))
-			    (if ,',counter
-				(return-from ,',BLOCK
-				 (values t (svref ,',vector ,',counter)
-					 ,',kind (car ,',packages)))
-				(,',end-test-macro :external)))))
-		     ,@(when (member :inherited ',ordered-types)
-			 `((:inherited
-			    (setf ,',counter
-				  (position-if #',',real-symbol-p ,',hash-vector
-					       :start (if ,',counter
-							  (1+ ,',counter)
-							  0)))
-			    (cond (,',counter
-				   (return-from
-				    ,',BLOCK
-				    (values t (svref ,',vector ,',counter)
-					    ,',kind (car ,',packages))))
-				  (t
-				   (setf ,',package-use-list
-					 (cdr ,',package-use-list))
-				   (cond ((endp ,',package-use-list)
-					  (setf ,',packages (cdr ,',packages))
-					  (when (endp ,',packages)
-					    (return-from ,',BLOCK))
-					  (setf ,',package-use-list
-						(package-%use-list
-						 (car ,',packages)))
-					  (,',init-macro ,(car ',ordered-types)))
-					 (t (,',init-macro :inherited)
-					    (setf ,',counter nil)))))))))))))
-	       ,@body)))))))
-
-
-;;;; DEFPACKAGE:
-
-(defmacro defpackage (package &rest options)
-  "Defines a new package called PACKAGE.  Each of OPTIONS should be one of the
-   following:
-     (:NICKNAMES {package-name}*)
-     (:SIZE <integer>)
-     (:SHADOW {symbol-name}*)
-     (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
-     (:USE {package-name}*)
-     (:IMPORT-FROM <package-name> {symbol-name}*)
-     (:INTERN {symbol-name}*)
-     (:EXPORT {symbol-name}*)
-   All options except :SIZE can be used multiple times."
-  (let ((nicknames nil)
-	(size nil)
-	(shadows nil)
-	(shadowing-imports nil)
-	(use nil)
-	(use-p nil)
-	(imports nil)
-	(interns nil)
-	(exports nil)
-	(incomming nil)
-	(outgoing nil))
-    (dolist (option options)
-      (unless (consp option)
-	(error "Bogus DEFPACKAGE option: ~S" option))
-      (case (car option)
-	(:nicknames
-	 (let ((new (stringify-names (cdr option) "package")))
-	   (setf nicknames (append-unique new nicknames :nicknames))))
-	(:size
-	 (cond (size
-		(error "Can't specify :SIZE twice."))
-	       ((and (consp (cdr option))
-		     (typep (second option) 'unsigned-byte))
-		(setf size (second option)))
-	       (t
-		(error "Bogus :SIZE, must be a positive integer: ~S"
-		       (second option)))))
-	(:shadow
-	 (let ((new (stringify-names (cdr option) "symbol")))
-	   (setf incomming (append-unique new incomming :shadow))
-	   (setf shadows (append shadows new))))
-	(:shadowing-import-from
-	 (let ((package-name (stringify-name (second option) "package"))
-	       (names (stringify-names (cddr option) "symbol")))
-	   (setf incomming (append-unique names incomming :shadowing-import))
-	   (let ((assoc (assoc package-name shadowing-imports
-			       :test #'string=)))
-	     (if assoc
-		 (setf (cdr assoc) (append (cdr assoc) names))
-		 (setf shadowing-imports
-		       (acons package-name names shadowing-imports))))))
-	(:use
-	 (let ((new (stringify-names (cdr option) "package")))
-	   (setf use (append-unique new nicknames :use))
-	   (setf use-p t)))
-	(:import-from
-	 (let ((package-name (stringify-name (second option) "package"))
-	       (names (stringify-names (cddr option) "symbol")))
-	   (setf incomming (append-unique names incomming :import-from))
-	   (let ((assoc (assoc package-name imports
-			       :test #'string=)))
-	     (if assoc
-		 (setf (cdr assoc) (append (cdr assoc) names))
-		 (setf imports (acons package-name names imports))))))
-	(:intern
-	 (let ((new (stringify-names (cdr option) "symbol")))
-	   (setf incomming (append-unique new incomming :intern))
-	   (setf outgoing (append-unique new incomming :intern))
-	   (setf interns (append interns new))))
-	(:export
-	 (let ((new (stringify-names (cdr option) "symbol")))
-	   (setf outgoing (append-unique new incomming :export))
-	   (setf exports (append exports new))))
-	(t
-	 (error "Bogus DEFPACKAGE option: ~S" option))))
-    `(eval-when (compile load eval)
-       (%defpackage ,(stringify-name package "package") ',nicknames ',size
-		    ',shadows ',shadowing-imports ',(if use-p use :default)
-		    ',imports ',interns ',exports))))
-
-(defun stringify-name (name kind)
-  (typecase name
-    (simple-string name)
-    (string (coerce name 'simple-string))
-    (symbol (symbol-name name))
-    (t
-     (error "Bogus ~A name: ~S" kind name))))
-
-(defun stringify-names (names kind)
-  (mapcar #'(lambda (name)
-	      (stringify-name name kind))
-	  names))
-
-(defun append-unique (new old list)
-  (dolist (name new)
-    (if (member name old)
-	(cerror "Ignore it."
-		"Duplicate name in the ~S list: ~A" list name)
-	(push name old)))
-  old)
-
-(defun %defpackage (name nicknames size shadows shadowing-imports
-			 use imports interns exports)
-  (declare (type simple-base-string name)
-	   (type list nicknames shadows shadowing-imports
-		 imports interns exports)
-	   (type (or list (member :default)) use))
-  (let ((package (or (find-package name)
-		     (progn
-		       (when (eq use :default)
-			 (setf use *default-package-use-list*))
-		       (make-package name
-				     :use nil
-				     :internal-symbols (or size 10)
-				     :external-symbols (length exports))))))
-    (unless (string= (package-name name) name)
-      (error "~A is a nick-name for the package ~A"
-	     name (package-name name)))
-    (enter-new-nicknames package nicknames)
-    ;; Shadows and Shadowing-imports.
-    (let ((old-shadows (package-%shadowing-symbols package)))
-      (shadow shadows package)
-      (dolist (sym-name shadows)
-	(setf old-shadows (remove (find-symbol sym-name package) old-shadows)))
-      (dolist (simports-from shadowing-imports)
-	(let ((other-package (package-or-lose (car simports-from))))
-	  (dolist (sym-name (cdr simports-from))
-	    (let ((sym (find-or-make-symbol sym-name other-package)))
-	      (shadowing-import sym package)
-	      (setf old-shadows (remove sym old-shadows))))))
-      (when old-shadows
-	(warn "~A also shadows the following symbols:~%  ~S"
-	      name old-shadows)))
-    ;; Use
-    (unless (eq use :default)
-      (let ((old-use-list (package-use-list package))
-	    (new-use-list (mapcar #'package-or-lose use)))
-	(use-package (set-difference new-use-list old-use-list) package)
-	(let ((laterize (set-difference old-use-list new-use-list)))
-	  (when laterize
-	    (unuse-package laterize package)
-	    (warn "~A used to use the following packages:~%  ~S" laterize)))))
-    ;; Import and Intern.
-    (dolist (sym-name interns)
-      (intern sym-name package))
-    (dolist (imports-from imports)
-      (let ((other-package (package-or-lose (car imports-from))))
-	(dolist (sym-name (cdr imports-from))
-	  (import (find-or-make-symbol sym-name other-package) package))))
-    ;; Exports.
-    (let ((old-exports nil))
-      (do-external-symbols (sym package)
-	(push sym old-exports))
-      (dolist (sym-name exports)
-	(let ((sym (intern sym-name package)))
-	  (export sym package)
-	  (setf old-exports (delete sym old-exports :test #'eq))))
-      (when old-exports
-	(warn "~A also exports the following symbols:~%  ~S"
-	      name old-exports)))
-    package))
-
-(defun find-or-make-symbol (name package)
-  (multiple-value-bind
-      (symbol how)
-      (find-symbol name package)
-    (cond (how
-	   symbol)
-	  (t
-	   (cerror "INTERN it."
-		   "~A does not contain a symbol ~A"
-		   (package-name package)
-		   name)
-	   (intern name package)))))
-
-
-;;; 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 *default-package-use-list*) 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)))
-
-;;; Old-In-Package  --  Sorta Public.
-;;;
-;;;    Like Make-Package, only different.  Should go away someday.
-;;;
-(defun old-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))))))
-
-;;; IN-PACKAGE -- public.
-;;; 
-(defmacro in-package (package &rest noise)
-  (cond ((or noise
-	     (not (or (stringp package) (symbolp package))))
-	 (warn "Old-style IN-PACKAGE.")
-	 `(old-in-package ,package ,@noise))
-	(t
-	 `(%in-package ',(stringify-name package "package")))))
-;;;
-(defun %in-package (name)
-  (setf *package* (package-or-lose name)))
-
-;;; 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."
-  (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*)
-    (dolist (n (package-%nicknames package))
-      (remhash n *package-names*))
-     (setf (package-%name package) name)
-    (setf (gethash name *package-names*) package)
-    (setf (package-%nicknames package) ())
-    (enter-new-nicknames package nicknames)
-    package))
-
-;;; Delete-Package -- Public
-;;;
-;;; Delete the package (string or package) from the package system data
-;;; structures.
-;;;
-(defun delete-package (package)
-  (let ((pack-struc nil)
-	(pack-name nil)
-	(use-list nil))
-    (cond ((packagep package) ; Package argument is a package-object.
-	   (setf pack-name (package-name package)
-		 pack-struc package
-		 use-list (package-used-by-list package)))
-	  ((stringp package) ; Package argument is a name.
-	   (setf pack-struc (find-package package))
-	   (if pack-struc
-	       (setf pack-name (package-name pack-struc)))
-	   (unless pack-struc
-	     ;; Package argument is a name, but there is no package-object
-	     ;; of that name.
-	     (cerror "Return NIL" "No package of name ~S." package)
-	     (return-from delete-package nil))
-	  (setf use-list (package-used-by-list pack-struc))))
-    (when (and pack-struc (not pack-name)) ; Package already deleted.
-      (return-from delete-package nil))
-    (when use-list ; The package is used by other packages.
-      ;; Correctable error, if continued, then unuse-package on all.
-      (cerror "Remove dependency in other packages."
-	      "~S is used by package(s) ~S" package use-list)
-      (dolist (p use-list)
-	(unuse-package pack-name p)))
-    ;; Delete package slot for all symbols in the package by uninterning them.
-    (loop for s being each present-symbol of pack-struc
-      do (unintern s pack-struc))
-    (setf (package-%name pack-struc) nil
-	  (package-%nicknames pack-struc) nil)
-    (return-from delete-package t)))
-
-;;; 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 (make-symbol (subseq name 0 length))))
-	  (%set-symbol-package symbol package)
-	  (cond ((eq package *keyword-package*)
-		 (add-symbol (package-external-symbols package) symbol)
-		 (%set-symbol-value 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 (%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 (%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)
-	    (remove 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)
-		 (%set-symbol-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) (%set-symbol-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)
-		  (remove 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 (name (mapcar #'string
-			  (if (listp symbols) symbols (list symbols))))
-      (multiple-value-bind (s w) (find-symbol name package)
-	(when (or (not w) (eq w :inherited))
-	  (setq s (make-symbol name))
-	  (%set-symbol-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)
-	    (remove 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)
-	    (remove 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)
-	  (%set-symbol-package symbol pkg))
-	;;
-	;; External symbols same, only go in external table.
-	(dolist (symbol (third spec))
-	  (add-symbol external symbol)
-	  (%set-symbol-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:
-    (make-package "COMMON-LISP-USER" :nicknames '("CL-USER" "USER"))
-
-    ;; 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 37b1b8f60866c2fff5911bda8a7a777b1818a7b8..0000000000000000000000000000000000000000
--- a/code/parse-time.lisp
+++ /dev/null
@@ -1,607 +0,0 @@
-;;;  -*- Mode: Lisp; Package: Extensions; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/parse-time.lisp,v 1.3 1991/07/26 11:35:16 chiles Exp $")
-;;;
-;;; **********************************************************************
-
-;;; 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 23)
-(defparameter month-table-size 31)
-(defparameter zone-table-size 11)
-(defparameter special-table-size 11)
-
-(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" . 4) ("cst" . 6)
-	    ("cdt" . 5) ("mst" . 7)
-	    ("mdt" . 6)	("pst" . 8)
-	    ("pdt" . 7)) 
-	  *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.
-;;; If zone is in numerical form, tweeks it appropriately.
-
-(defun convert-to-unitime (parsed-values)
-  (let ((zone (decoded-time-zone 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)
-			   (if (or (> zone 23) (< zone -23))
-			       (let ((new-zone (/ zone 100)))
-				 (cond ((minusp new-zone) (- new-zone))
-				       ((plusp new-zone) (- 24 new-zone))
-				       ;; must be zero (GMT)
-				       (t new-zone)))
-			       zone))))
-
-;;; 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 (thing)
-  (or (and (simple-string-p thing) (gethash thing *zone-strings*))
-      (if (integerp thing)
-	  (let ((zone (/ thing 100)))
-	    (and (integerp zone) (<= -23 zone 23))))))
-
-(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)
-       (next-negative nil)
-       (parts-list nil))
-      ((eq string-index end) (nreverse parts-list))
-    (let ((next-char (char string string-index))
-	  (prev-char (if (= string-index start)
-			 nil
-			 (char string (1- 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)))
-		  ;; If next-negative is t, set the numeric value to it's
-		  ;; opposite and reset next-negative to nil.
-		  (when next-negative
-		    (setf next-negative nil)
-		    (setf numeric-value (- numeric-value)))
-		  (push numeric-value parts-list)
-		  (setf string-index scan-index))))
-	    ((and (char= next-char #\-)
-		  (or (not prev-char)
-		      (member prev-char whitespace-chars :test #'char=)))
-	     ;; If we see a minus sign before a number, but not after one,
-	     ;; it is not a date divider, but a negative offset from GMT, so
-	     ;; set next-negative to t and continue.
-	     (setf next-negative t)
-	     (incf string-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 (start 0) (end (length time-string))
-			       (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 :start start :end end))
-	 (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/pathname.lisp b/code/pathname.lisp
deleted file mode 100644
index 6a24dbbc8cec2d740c1c3eff73507ce7f69e3b53..0000000000000000000000000000000000000000
--- a/code/pathname.lisp
+++ /dev/null
@@ -1,2006 +0,0 @@
-;;; -*- Package: LISP -*-
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.15 1992/09/04 15:17:24 phg Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Machine/filesystem independent pathname functions for CMU Common Lisp.
-;;;
-;;; Written by William Lott, enhancements for logical-pathnames
-;;; written by Paul Gleichauf.
-;;; Earlier version written by Jim Large and Rob MacLachlan
-;;;
-;;; **********************************************************************
-
-(in-package "LISP")
-
-(export '(pathname pathnamep logical-pathname logical-pathname-p
-	  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
-	  wild-pathname-p pathname-match-p translate-pathname
-	  translate-logical-pathname logical-pathname-translations
-	  load-logical-pathname-translations *default-pathname-defaults*))
-
-(in-package "EXTENSIONS")
-(export '(search-list search-list-defined-p clear-search-list
-		      enumerate-search-list))
-
-(in-package "LISP")
-
-
-;;;; Structures and types.
-
-;;; Pathname structure holds the essential properties of the parsed path.
-
-(defstruct (pathname
-	    (:conc-name %pathname-)
-	    (:print-function %print-pathname)
-	    (:constructor
-	     %make-pathname (host device directory name type version))
-	    (:predicate pathnamep)
-	    (:make-load-form-fun :just-dump-it-normally))
-  ;; Slot holds the host, at present either a UNIX or logical host.
-  (host nil :type (or host null))
-  ;; Device is the name of a logical or physical device holding files.
-  (device nil :type (member nil :unspecific))
-  ;; A list of strings that are the component subdirectory components.
-  (directory nil :type list)
-  ;; The filename.
-  (name nil :type (or simple-string pattern null))
-  ;; The type extension of the file.
-  (type nil :type (or simple-string pattern null (member :unspecific)))
-  ;; The version number of the file, a positive integer, but not supported
-  ;; on standard UNIX filesystems.
-  (version nil :type (or integer null (member :newest :wild))))
-
-;;; %PRINT-PATHNAME -- Internal
-;;;
-;;;   The printed representation of the pathname structure.
-;;;
-(defun %print-pathname (pathname stream depth)
-  (declare (ignore depth))
-  (let ((namestring (handler-case (namestring pathname)
-		      (error nil))))
-    (cond (namestring
-	   (format stream "#p~S" namestring))
-	  (*print-readably*
-	   (error "~S Cannot be printed readably." pathname))
-	  (*print-pretty*
-	   (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
-	     (funcall (formatter
-		       "~2IUnprintable pathname: ~_Host=~S, ~_Device=~S, ~_~
-			Directory=~:/LISP:PPRINT-FILL/, ~_Name=~S, ~_~
-			Type=~S, ~_Version=~S")
-		      stream
-		      (%pathname-host pathname)
-		      (%pathname-device pathname)
-		      (%pathname-directory pathname)
-		      (%pathname-name pathname)
-		      (%pathname-type pathname)
-		      (%pathname-version pathname))))
-	  (t
-	   (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~
-				Directory=~S, File=~S, Name=~S, Version=~S>")
-		    stream
-		    (%pathname-host pathname)
-		    (%pathname-device pathname)
-		    (%pathname-directory pathname)
-		    (%pathname-name pathname)
-		    (%pathname-type pathname)
-		    (%pathname-version pathname))))))
-
-;;;; HOST structure
-
-;;;   The host structure holds the functions that both parse the pathname
-;;; information into sturcture slot entries, and after translation the inverse
-;;; (unparse) functions.
-;;;
-(defstruct (host
-	    (:print-function %print-host))
-  (parse (required-argument) :type function)
-  (unparse (required-argument) :type function)
-  (unparse-host (required-argument) :type function)
-  (unparse-directory (required-argument) :type function)
-  (unparse-file (required-argument) :type function)
-  (unparse-enough (required-argument) :type function)
-  (customary-case (required-argument) :type (member :upper :lower)))
-
-;;; %PRINT-HOST -- Internal
-;;;
-(defun %print-host (host stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (host stream :type t :identity t)))
-
-
-;;;; Patterns
-
-;;;   Patterns are a list of entries and wildcards used for pattern matches
-;;; of translations.
-
-(defstruct (pattern
-	    (:print-function %print-pattern)
-	    (:make-load-form-fun :just-dump-it-normally)
-	    (:constructor make-pattern (pieces)))
-  (pieces nil :type list))
-
-;;; %PRINT-PATTERN -- Internal
-;;;
-(defun %print-pattern (pattern stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (pattern stream :type t)
-    (if *print-pretty*
-	(let ((*print-escape* t))
-	  (pprint-fill stream (pattern-pieces pattern) nil))
-	(prin1 (pattern-pieces pattern) stream))))
-
-;;; PATTERN= -- Internal
-;;;
-(defun pattern= (pattern1 pattern2)
-  (declare (type pattern pattern1 pattern2))
-  (let ((pieces1 (pattern-pieces pattern1))
-	(pieces2 (pattern-pieces pattern2)))
-    (and (= (length pieces1) (length pieces2))
-	 (every #'(lambda (piece1 piece2)
-		    (typecase piece1
-		      (simple-string
-		       (and (simple-string-p piece2)
-			    (string= piece1 piece2)))
-		      (cons
-		       (and (consp piece2)
-			    (eq (car piece1) (car piece2))
-			    (string= (cdr piece1) (cdr piece2))))
-		      (t
-		       (eq piece1 piece2))))
-		pieces1
-		pieces2))))
-
-;;; PATTERN-MATCHES -- Internal
-;;;
-(defun pattern-matches (pattern string)
-  (declare (type pattern pattern)
-	   (type simple-string string))
-  (let ((len (length string)))
-    (labels ((maybe-prepend (subs cur-sub chars)
-	       (if cur-sub
-		   (let* ((len (length chars))
-			  (new (make-string len))
-			  (index len))
-		     (dolist (char chars)
-		       (setf (schar new (decf index)) char))
-		     (cons new subs))
-		   subs))
-	     (matches (pieces start subs cur-sub chars)
-	       (if (null pieces)
-		   (if (= start len)
-		       (values t (maybe-prepend subs cur-sub chars))
-		       (values nil nil))
-		   (let ((piece (car pieces)))
-		     (etypecase piece
-		       (simple-string
-			(let ((end (+ start (length piece))))
-			  (and (<= end len)
-			       (string= piece string
-					:start2 start :end2 end)
-			       (matches (cdr pieces) end
-					(maybe-prepend subs cur-sub chars)
-					nil nil))))
-		       (list
-			(ecase (car piece)
-			  (:character-set
-			   (and (< start len)
-				(let ((char (schar string start)))
-				  (if (find char (cdr piece) :test #'char=)
-				      (matches (cdr pieces) (1+ start) subs t
-					       (cons char chars))))))))
-		       ((member :single-char-wild)
-			(and (< start len)
-			     (matches (cdr pieces) (1+ start) subs t
-				      (cons (schar string start) chars))))
-		       ((member :multi-char-wild)
-			(multiple-value-bind
-			    (won new-subs)
-			    (matches (cdr pieces) start subs t chars)
-			  (if won
-			      (values t new-subs)
-			      (and (< start len)
-				   (matches pieces (1+ start) subs t
-					    (cons (schar string start)
-						  chars)))))))))))
-      (multiple-value-bind
-	  (won subs)
-	  (matches (pattern-pieces pattern) 0 nil nil nil)
-	(values won (reverse subs))))))
-
-;;; COMPONENTS-MATCH -- Internal
-;;;
-;;;   Wilds in to are matched against from where both are either lists
-;;; containing :wild and :wild-inferiors, patterns or strings.
-;;; FROM = :WILD-INFERIORS or :WILD handled separately for directory
-;;; component. Not communative.
-;;;
-(defun components-match (from to)
-  (or (eq from to)
-      (typecase from
-	(simple-base-string
-	 (typecase to
-	   (pattern
-	    (values (pattern-matches to from)))
-	   (simple-base-string
-	    (string-equal from to))))
-	(pattern
-	 (and (pattern-p to) (pattern= from to)))
-	((member :wild) ; :WILD component matches any string, or pattern or NIL.
-	 (or (stringp to)
-	     (logical-host-p to)
-	     (pattern-p to)
-	     (member to '(nil :unspecific :newest :wild :wild-inferiors))))
-	((member :newest)
-	 (member to '(:wild)))
-	(cons ; Watch for wildcards.
-	 (and (consp from)
-	      (let ((from1 (first from))
-		    (from2 nil)
-		    (to1 (first to)))
-		(typecase from1
-		  ((member :wild)
-		   (or (stringp to1)
-		       (pattern-p to1)
-		       (not to1)
-		       (eq to1 :unspecific)))
-		  ((member :wild-inferiors)
-		   (setf from2 (second from))
-		   (cond ((not from2)
-			  ;; Nothing left of from, hence anything else in to
-			  ;; matches :wild-inferiors. 
-			  t)
-			 ((components-match
-			   (rest (rest from))
-			   (rest (member from2 to :test #'equal))))))
-		  (keyword ; :unspecific, :up, :back
-		   (and (keywordp to1)
-			(eq from1 to1)
-			(components-match (rest from) (rest to))))
-		  (string
-		   (and (stringp to1)
-			(string-equal from1 to1)
-			(components-match (rest from) (rest to))))))))
-	((member :back :up :unspecific nil)
-	 (and (pattern-p from)
-	      (equal (pattern-pieces from) '(:multi-char-wild)))))))
-
-
-;;;; Utilities.
-
-;;; COMPARE-COMPONENT  -- Internal
-;;;
-;;; A predicate for comparing two pathname slot component sub-entries.
-;;;
-(defun compare-component (this that)
-  (or (eql this that)
-      (typecase this
-	(simple-string
-	 (and (simple-string-p that)
-	      (string= this that)))
-	(pattern
-	 (and (pattern-p that)
-	      (pattern= this that)))
-	(cons
-	 (and (consp that)
-	      (compare-component (car this) (car that))
-	      (compare-component (cdr this) (cdr that)))))))
-
-
-;;;; Pathname functions.
-
-;;;   Implementation determined defaults to pathname slots.
-
-(defvar *default-pathname-defaults*)
-
-;;; PATHNAME= -- Internal
-;;;
-(defun pathname= (pathname1 pathname2)
-  (and (eq (%pathname-host pathname1)
-	   (%pathname-host pathname2))
-       (compare-component (%pathname-device pathname1)
-			  (%pathname-device pathname2))
-       (compare-component (%pathname-directory pathname1)
-			  (%pathname-directory pathname2))
-       (compare-component (%pathname-name pathname1)
-			  (%pathname-name pathname2))
-       (compare-component (%pathname-type pathname1)
-			  (%pathname-type pathname2))
-       (compare-component (%pathname-version pathname1)
-			  (%pathname-version pathname2))))
-
-;;; WITH-PATHNAME -- Internal
-;;;   Converts the var, a pathname designator (a pathname, or string, or 
-;;; stream), into a pathname.
-;;;
-(defmacro with-pathname ((var expr) &body body)
-  `(let ((,var (let ((,var ,expr))
-		 (etypecase ,var
-		   (pathname ,var)
-		   (string (parse-namestring ,var))
-		   (stream (parse-namestring (file-name ,var)))))))
-     ,@body))
-
-
-;;; PATHNAME -- Interface
-;;;
-(defun pathname (thing)
-  "Convert thing (a pathname, string or stream) into a pathname."
-  (declare (type pathnamelike thing))
-  (with-pathname (pathname thing)
-    pathname))
-
-;;; MAYBE-DIDDLE-CASE  -- Internal
-;;;
-;;;   Change the case of thing if diddle-p T.
-;;;
-(defun maybe-diddle-case (thing diddle-p)
-  (declare (type (or list pattern simple-base-string (member :unspecific))
-		 thing)
-	   (values (or list pattern simple-base-string (member :unspecific))))
-  (if diddle-p
-      (labels ((check-for (pred in)
-		 (etypecase in
-		   (pattern
-		    (dolist (piece (pattern-pieces in))
-		      (when (typecase piece
-			      (simple-string
-			       (check-for pred piece))
-			      (cons
-			       (case (car in)
-				 (:character-set
-				  (check-for pred (cdr in))))))
-			(return t))))
-		   (list
-		    (dolist (x in)
-		      (when (check-for pred x)
-			(return t))))
-		   (simple-base-string
-		    (dotimes (i (length in))
-		      (when (funcall pred (schar in i))
-			(return t))))
-		   ((member :unspecific :up :absolute :relative)
-		    nil)))
-	       (diddle-with (fun thing)
-		 (etypecase thing
-		   (pattern
-		    (make-pattern
-		     (mapcar #'(lambda (piece)
-				 (typecase piece
-				   (simple-base-string
-				    (funcall fun thing))
-				   (cons
-				    (case (car piece)
-				      (:character-set
-				       (cons :character-set
-					     (funcall fun (cdr piece))))
-				      (t
-				       piece)))
-				   (t
-				    piece)))
-			     (pattern-pieces thing))))
-		   (list
-		    (mapcar fun thing))
-		   (simple-base-string 
-		    (funcall fun thing))
-		   ((member :unspecific :up :absolute :relative)
-		    thing))))
-	(let ((any-uppers (check-for #'upper-case-p thing))
-	      (any-lowers (check-for #'lower-case-p thing)))
-	  (cond ((and any-uppers any-lowers)
-		 ;; Mixed case, stays the same.
-		 thing)
-		(any-uppers
-		 ;; All uppercase, becomes all lower case.
-		 (diddle-with #'(lambda (x) (if (stringp x)
-						(string-downcase x)
-						x)) thing))
-		(any-lowers
-		 ;; All lowercase, becomes all upper case.
-		 (diddle-with #'(lambda (x) (if (stringp x)
-						(string-upcase x)
-						x)) thing))
-		(t
-		 ;; No letters?  I guess just leave it.
-		 thing))))
-      thing))
-
-;;; MERGE-DIRECTORIES -- Internal
-;;;
-(defun merge-directories (dir1 dir2 diddle-case)
-  (if (or (eq (car dir1) :absolute)
-	  (null dir2))
-      dir1
-      (let ((results nil))
-	(flet ((add (dir)
-		 (if (and (eq dir :back)
-			  results
-			  (not (eq (car results) :back)))
-		     (pop results)
-		     (push dir results))))
-	  (dolist (dir (maybe-diddle-case dir2 diddle-case))
-	    (add dir))
-	  (dolist (dir (cdr dir1))
-	    (add dir)))
-	(reverse results))))
-
-;;; MERGE-PATHNAMES -- Interface
-;;;
-(defun merge-pathnames (pathname
-			&optional
-			(defaults *default-pathname-defaults*)
-			(default-version :newest))
-  "Construct a filled in pathname by completing the unspecified components
-   from the defaults."
-  (with-pathname (defaults defaults)
-    (let ((pathname (let ((*default-pathname-defaults* defaults))
-		      (pathname pathname))))
-      (let* ((default-host (%pathname-host defaults))
-	     (pathname-host (%pathname-host pathname))
-	     (diddle-case
-	      (and default-host pathname-host
-		   (not (eq (host-customary-case default-host)
-			    (host-customary-case pathname-host))))))
-	(%make-pathname (or pathname-host default-host)
-			(or (%pathname-device pathname)
-			    (maybe-diddle-case (%pathname-device defaults)
-					       diddle-case))
-			(merge-directories (%pathname-directory pathname)
-					   (%pathname-directory defaults)
-					   diddle-case)
-			(or (%pathname-name pathname)
-			    (maybe-diddle-case (%pathname-name defaults)
-					       diddle-case))
-			(or (%pathname-type pathname)
-			    (maybe-diddle-case (%pathname-type defaults)
-					       diddle-case))
-			(or (%pathname-version pathname)
-			    default-version))))))
-
-;;; IMPORT-DIRECTORY -- Internal
-;;;
-(defun import-directory (directory diddle-case)
-  (etypecase directory
-    (null nil)
-    (list
-     (collect ((results))
-       (ecase (pop directory)
-	 (:absolute
-	  (results :absolute)
-	  (when (search-list-p (car directory))
-	    (results (pop directory))))
-	 (:relative
-	  (results :relative)))
-       (dolist (piece directory)
-	 (cond ((eq piece :wild)
-		(results (make-pattern (list :multi-char-wild))))
-	       ((eq piece :wild-inferiors)
-		(results piece))
-	       ((member piece '(:up :back))
-		(results piece))
-	       ((or (simple-string-p piece) (pattern-p piece))
-		(results (maybe-diddle-case piece diddle-case)))
-	       ((stringp piece)
-		(results (maybe-diddle-case (coerce piece 'simple-string)
-					    diddle-case)))
-	       (t
-		(error "~S is not allowed as a directory component." piece))))
-       (results)))
-    (simple-string
-     `(:absolute
-       ,(maybe-diddle-case directory diddle-case)))
-    (string
-     `(:absolute
-       ,(maybe-diddle-case (coerce directory 'simple-string)
-			   diddle-case)))))
-
-;;; MAKE-PATHNAME -- Interface
-;;;
-(defun make-pathname (&key (host nil hostp)
-			   (device nil devp)
-			   (directory nil dirp)
-			   (name nil namep)
-			   (type nil typep)
-			   (version nil versionp)
-			   defaults (case :local))
-  "Makes a new pathname from the component arguments.  Note that host is a host-
-   structure."
-  (declare (type (or host null) host)
-	   (type (member nil :unspecific) device)
-	   (type (or list string pattern (member :wild)) directory)
-	   (type (or null string pattern (member :wild)) name)
-	   (type (or null string pattern (member :unspecific :wild)) type)
-	   (type (or null integer (member :unspecific :wild :newest)) version)
-	   (type (or pathnamelike null) defaults)
-	   (type (member :common :local) case))
-  (let* ((defaults (if defaults
-		       (with-pathname (defaults defaults) defaults)))
-	 (default-host (if defaults
-			   (%pathname-host defaults)
-			   (pathname-host *default-pathname-defaults*)))
-	 (host (if hostp host default-host))
-	 (diddle-args (and (eq case :common)
-			   (eq (host-customary-case host) :lower)))
-	 (diddle-defaults
-	  (not (eq (host-customary-case host)
-		   (host-customary-case default-host)))))
-    (macrolet ((pick (var varp field)
-		 `(cond ((eq ,var :wild)
-			 (make-pattern (list :multi-char-wild)))
-			((or (simple-string-p ,var)
-			     (pattern-p ,var))
-			 (maybe-diddle-case ,var diddle-args))
-			((stringp ,var)
-			 (maybe-diddle-case (coerce ,var 'simple-string)
-					    diddle-args))
-			(,varp
-			 (maybe-diddle-case ,var diddle-args))
-			(defaults
-			 (maybe-diddle-case (,field defaults)
-					    diddle-defaults))
-			(t
-			 nil))))
-      (%make-pathname
-       host
-       (if devp device (if defaults (%pathname-device defaults)))
-       (let ((dir (import-directory directory diddle-args)))
-	 (if (and defaults (not dirp))
-	     (merge-directories dir
-				(%pathname-directory defaults)
-				diddle-defaults)
-	     dir))
-       (pick name namep %pathname-name)
-       (pick type typep %pathname-type)
-       (cond
-	 (versionp version)
-	 (defaults (%pathname-version defaults))
-	 (t nil))))))
-
-;;; PATHNAME-HOST -- Interface
-;;;
-(defun pathname-host (pathname &key (case :local))
-  "Accessor for the pathname's host."
-  (declare (type pathnamelike pathname)
-	   (type (member :local :common) case)
-	   (ignore case))
-  (with-pathname (pathname pathname)
-    (%pathname-host pathname)))
-
-;;; PATHNAME-DEVICE -- Interface
-;;;
-(defun pathname-device (pathname &key (case :local))
-  "Accessor for pathname's device."
-  (declare (type pathnamelike pathname)
-	   (type (member :local :common) case))
-  (with-pathname (pathname pathname)
-    (maybe-diddle-case (%pathname-device pathname)
-		       (and (eq case :common)
-			    (eq (host-customary-case
-				 (%pathname-host pathname))
-				:lower)))))
-
-;;; PATHNAME-DIRECTORY -- Interface
-;;;
-(defun pathname-directory (pathname &key (case :local))
-  "Accessor for the pathname's directory list."
-  (declare (type pathnamelike pathname)
-	   (type (member :local :common) case))
-  (with-pathname (pathname pathname)
-    (maybe-diddle-case (%pathname-directory pathname)
-		       (and (eq case :common)
-			    (eq (host-customary-case
-				 (%pathname-host pathname))
-				:lower)))))
-;;; PATHNAME-NAME -- Interface
-;;;
-(defun pathname-name (pathname &key (case :local))
-  "Accessor for the pathname's name."
-  (declare (type pathnamelike pathname)
-	   (type (member :local :common) case))
-  (with-pathname (pathname pathname)
-    (maybe-diddle-case (%pathname-name pathname)
-		       (and (eq case :common)
-			    (eq (host-customary-case
-				 (%pathname-host pathname))
-				:lower)))))
-
-;;; PATHNAME-TYPE
-;;;
-(defun pathname-type (pathname &key (case :local))
-  "Accessor for the pathname's name."
-  (declare (type pathnamelike pathname)
-	   (type (member :local :common) case))
-  (with-pathname (pathname pathname)
-    (maybe-diddle-case (%pathname-type pathname)
-		       (and (eq case :common)
-			    (eq (host-customary-case
-				 (%pathname-host pathname))
-				:lower)))))
-;;; PATHNAME-VERSION
-;;;
-(defun pathname-version (pathname)
-  "Accessor for the pathname's version."
-  (declare (type pathnamelike pathname))
-  (with-pathname (pathname pathname)
-    (%pathname-version pathname)))
-
-
-;;;; Namestrings
-
-;;; %PRINT-NAMESTRING-PARSE-ERROR -- Internal
-;;;
-(defun %print-namestring-parse-error (condition stream)
-  (format stream "Parse error in namestring: ~?~%  ~A~%  ~V@T^"
-	  (namestring-parse-error-complaint condition)
-	  (namestring-parse-error-arguments condition)
-	  (namestring-parse-error-namestring condition)
-	  (namestring-parse-error-offset condition)))
-
-(define-condition namestring-parse-error (error)
-  ((complaint :init-form (required-argument))
-   (arguments :init-form nil)
-   (namestring :init-form (required-argument))
-   (offset :init-form (required-argument)))
-  (:report %print-namestring-parse-error))
-
-;;; %PARSE-NAMESTRING -- Internal
-;;;
-(defun %parse-namestring (namestr start end host junk-allowed)
-  (declare (type string namestr)
-	   (type index start end)
-	   (type host host)
-	   (values (or null pathname) index))
-  (cond (junk-allowed
-	 (handler-case (%parse-namestring namestr start end host nil)
-	   (namestring-parse-error (condition)
-	       (values nil (namestring-parse-error-offset condition)))))
-	((simple-string-p namestr)
-	 (multiple-value-bind
-	     (new-host device directory file type version)
-	     (funcall (host-parse host) namestr start end)
-	   (values (%make-pathname (or new-host host)
-				   device
-				   directory
-				   file
-				   type
-				   version)
-		   end)))
-	(t
-	 (%parse-namestring (coerce namestr 'simple-string)
-			    start end host nil))))
-
-;;; PARSE-NAMESTRING -- Interface
-;;;
-(defun parse-namestring (thing
-			 &optional host (defaults *default-pathname-defaults*)
-			 &key (start 0) end junk-allowed)
-  "Converts thing, a pathname designator, into a pathname structure, returns
-   the printed representation."
-  (declare (type (or simple-base-string stream pathname) thing)
-	   (type (or null host) host)
-	   (type pathnamelike defaults)
-	   (type index start)
-	   (type (or index null) end)
-	   (type (or null (not null)) junk-allowed)
-	   (values (or null pathname) index))
-  (cond ((stringp thing)
-	 (let* ((end1 (or end (length thing)))
-		(things-host nil)
-		(hosts-name (when host
-			      (funcall (host-parse host) thing start end1))))
-	   (setf things-host
-		 (maybe-extract-logical-host thing start end1))
-	   (when (and host things-host) ; A logical host and host are defined.
-	     (unless (string= things-host hosts-name)
-	       (error "Hosts do not match: ~S in ~S and ~S."
-		      things-host thing host)))
-	   (if things-host
-	       (unless (gethash (string-downcase things-host) *search-lists*)
-		 ;; Not a search-list name, make it a logical-host name.
-		 (setf host (intern-logical-host things-host))))
-	   (%parse-namestring thing start end1
-			      (or host
-				  (with-pathname (defaults defaults)
-						 (%pathname-host defaults)))
-			      junk-allowed)))
-	((pathnamep thing)
-	 (when host
-	   (unless (eq host (%pathname-host thing))
-	     (error "Hosts do not match: ~S and ~S."
-		    host
-		    (%pathname-host thing))))
-	 (values thing start))
-	((streamp thing)
-	 (let ((host-name (funcall (host-unparse-host host) host))
-	       (stream-type (type-of thing))
-	       (stream-host-name (host-namestring thing)))
-	   (unless (or (eq stream-type 'fd-stream)
-		       ;;********Change fd-stream to file-stream in sources too.
-		       (eq stream-type 'synonym-stream))
-	     (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~
-		     or MAKE-SYNONYM-FILE." thing))
-	   (unless (string-equal stream-host-name host-name)
-	     (error "Hosts do not match: ~S and ~S."
-		    host
-		    host-name)))
-	 (values thing start))))
-
-;;; NAMESTRING -- Interface
-;;;
-(defun namestring (pathname)
-  "Construct the full (name)string form of the pathname."
-  (declare (type pathnamelike pathname))
-  (with-pathname (pathname pathname)
-    (let ((host (%pathname-host pathname)))
-      (cond ((logical-host-p host)
-	     (funcall (logical-host-unparse host) pathname))
-	    ((host-p host)
-	     (funcall (host-unparse host) pathname))
-	    (t
-	     (error
-	      "Cannot determine the namestring for pathnames with no ~
-	       host:~%  ~S" pathname))))))
-
-;;; HOST-NAMESTRING -- Interface
-;;;
-(defun host-namestring (pathname)
-  "Returns a string representation of the name of the host in the pathname."
-  (declare (type pathnamelike pathname))
-  (with-pathname (pathname pathname)
-    (let ((host (%pathname-host pathname)))
-      (if host
-	  (funcall (host-unparse-host host) pathname)
-	  (error
-	   "Cannot determine the namestring for pathnames with no host:~%  ~S"
-	   pathname)))))
-
-;;; DIRECTORY-NAMESTRING -- Interface
-;;;
-(defun directory-namestring (pathname)
-  "Returns a string representation of the directories used in the pathname."
-  (declare (type pathnamelike pathname))
-  (with-pathname (pathname pathname)
-    (let ((host (%pathname-host pathname)))
-      (if host
-	  (funcall (host-unparse-directory host) pathname)
-	  (error
-	   "Cannot determine the namestring for pathnames with no host:~%  ~S"
-	   pathname)))))
-
-;;; FILE-NAMESTRING -- Interface
-;;;
-(defun file-namestring (pathname)
-  "Returns a string representation of the name used in the pathname."
-  (declare (type pathnamelike pathname))
-  (with-pathname (pathname pathname)
-    (let ((host (%pathname-host pathname)))
-      (if host
-	  (funcall (host-unparse-file host) pathname)
-	  (error
-	   "Cannot determine the namestring for pathnames with no host:~%  ~S"
-	   pathname)))))
-
-;;; ENOUGH-NAMESTRING -- Interface
-;;;
-(defun enough-namestring (pathname
-			  &optional (defaults *default-pathname-defaults*))
-  "Returns an abbreviated pathname sufficent to identify the pathname relative
-   to the defaults."
-  (declare (type pathnamelike pathname))
-  (with-pathname (pathname pathname)
-    (let ((host (%pathname-host pathname)))
-      (if host
-	  (with-pathname (defaults defaults)
-	    (funcall (host-unparse-enough host) pathname defaults))
-	  (error
-	   "Cannot determine the namestring for pathnames with no host:~%  ~S"
-	   pathname)))))
-
-
-;;;; Wild pathnames.
-
-;;; WILD-PATHNAME-P -- Interface
-;;;
-(defun wild-pathname-p (pathname &optional field-key)
-  "Predicate for determining whether pathname contains any wildcards."
-  (declare (type pathnamelike pathname)
-	   (type (member nil :host :device :directory :name :type :version)
-		 field-key))
-  (with-pathname (pathname pathname)
-    (ecase field-key
-      ((nil)
-       (or (wild-pathname-p pathname :host)
-	   (wild-pathname-p pathname :device)
-	   (wild-pathname-p pathname :directory)
-	   (wild-pathname-p pathname :name)
-	   (wild-pathname-p pathname :type)
-	   (wild-pathname-p pathname :version)))
-      (:host
-       (pattern-p (%pathname-host pathname)))
-      (:device
-       (pattern-p (%pathname-host pathname)))
-      (:directory
-       (some #'pattern-p (%pathname-directory pathname)))
-      (:name
-       (pattern-p (%pathname-name pathname)))
-      (:type
-       (pattern-p (%pathname-type pathname)))
-      (:version
-       (eq (%pathname-version pathname) :wild)))))
-
-;;; PATHNAME-MATCH -- Interface
-;;;
-(defun pathname-match-p (pathname wildname)
-  "Pathname matches the wildname template?"
-  (with-pathname (pathname pathname)
-    (with-pathname (wildname wildname)
-      (macrolet ((frob (field)
-		   `(or (null (,field wildname))
-			(components-match (,field wildname)
-					  (,field pathname)))))
-	(and (frob %pathname-host)
-	     (frob %pathname-device)
-	     (frob %pathname-directory)
-	     (frob %pathname-name)
-	     (frob %pathname-type)
-	     (or (null (%pathname-version wildname))
-		 (eq (%pathname-version wildname) :wild)
-		 (eql (%pathname-version pathname)
-		      (%pathname-version wildname))))))))
-
-;;; SUBSTITUTE-INTO -- Internal
-;;;
-(defun substitute-into (pattern subs)
-  (declare (type pattern pattern)
-	   (type list subs))
-  (let ((in-wildcard nil)
-	(pieces nil)
-	(strings nil))
-    (dolist (piece (pattern-pieces pattern))
-      (cond ((simple-string-p piece)
-	     (push piece strings)
-	     (setf in-wildcard nil))
-	    (in-wildcard)
-	    ((null subs))
-	    (t
-	     (let ((sub (pop subs)))
-	       (etypecase sub
-		 (pattern
-		  (when strings
-		    (push (apply #'concatenate 'simple-string
-				 (nreverse strings))
-			  pieces))
-		  (dolist (piece (pattern-pieces sub))
-		    (push piece pieces)))
-		 (simple-string
-		  (push sub strings))))
-	     (setf in-wildcard t))))
-    (when strings
-      (push (apply #'concatenate 'simple-string
-		   (nreverse strings))
-	    pieces))
-    (if (and pieces
-	     (simple-string-p (car pieces))
-	     (null (cdr pieces)))
-	(car pieces)
-	(make-pattern (nreverse pieces)))))
-
-;;; TRANSLATE-COMPONENT -- Internal
-;;;
-;;;   Use the source as a pattern to fill the from path and form the to path.
-;;;
-(defun translate-component (source from to) 
-  (typecase to
-    (pattern
-     (if (pattern-p from)
-	 (typecase source
-	   (pattern
-	    (if (pattern= from source)
-		source
-		:error))
-	   (simple-string
-	    (multiple-value-bind
-		(won subs)
-		(pattern-matches from source)
-	      (if won
-		  (values (substitute-into to subs))
-		  :error)))
-	   (t
-	    :error))
-	 source))
-    ((member nil :wild)
-     source)
-    (t
-     (if (components-match source from)
-	 to
-	 :error))))
-
-;;; TRANSLATE-DIRECTORIES -- Internal
-;;;
-(defun translate-directories (source from to)
-  (if (null to)
-      source
-      (let ((subs nil))
-	(loop
-	  for from-part in from
-	  for source-part in source
-	  do (when (pattern-p from-part)
-	       (typecase source-part
-		 (pattern
-		  (if (pattern= from-part source-part)
-		      (setf subs (append subs (list source-part)))
-		      (return-from translate-directories :error)))
-		 (simple-string
-		  (multiple-value-bind
-		      (won new-subs)
-		      (pattern-matches from-part source-part)
-		    (if won
-			(setf subs (append subs new-subs))
-			(return-from translate-directories :error))))
-		 ((member :back :up)
-		  (if (equal (pattern-pieces from-part)
-			     '(:multi-char-wild))
-		      (setf subs (append subs (list source-part)))
-		      (return-from translate-directories :error)))
-		 (t
-		  (return-from translate-directories :error)))))
-	(mapcar #'(lambda (to-part)
-		    (if (pattern-p to-part)
-			(if (or (eq (car subs) :up) (eq (car subs) :back))
-			    (if (equal (pattern-pieces to-part)
-				       '(:multi-char-wild))
-				(pop subs)
-				(error "Can't splice ~S into the middle of a ~
-					wildcard pattern."
-				       (car subs)))
-			    (multiple-value-bind
-				(new new-subs)
-				(substitute-into to-part subs)
-			      (setf subs new-subs)
-			      new))
-			to-part))
-		to))))
-
-;;; TRANSLATE-PATHNAME -- Interface
-;;;
-(defun translate-pathname (source from-wildname to-wildname &key)
-  "Use the source pathname to translate the from-wildname's wild and
-   unspecified elements into a completed to-pathname based on the to-wildname."
-  (declare (type pathnamelike source from-wildname to-wildname))
-  (with-pathname (source source)
-    (with-pathname (from from-wildname)
-      (with-pathname (to to-wildname)
-	(macrolet ((frob (field)
-		     `(let ((result (translate-component (,field source)
-							 (,field from)
-							 (,field to))))
-			(if (eq result :error)
-			    (error "~S doesn't match ~S" source from)
-			    result))))
-	  (%make-pathname (frob %pathname-host)
-			  (frob %pathname-device)
-			  (let ((result (translate-directories
-					 (%pathname-directory source)
-					 (%pathname-directory from)
-					 (%pathname-directory to))))
-			    (if (eq result :error)
-				(error "~S doesn't match ~S" source from)
-				result))
-			  (frob %pathname-name)
-			  (frob %pathname-type)
-			  (frob %pathname-version)))))))
-
-
-;;;; Search lists.
-
-;;; The SEARCH-LIST structure.
-;;; 
-(defstruct (search-list
-	    (:print-function %print-search-list)
-	    (:make-load-form-fun
-	     (lambda (search-list)
-	       (values `(intern-search-list ',(search-list-name search-list))
-		       nil))))
-  ;;
-  ;; The name of this search-list.  Always stored in lowercase.
-  (name (required-argument) :type simple-string)
-  ;;
-  ;; T if this search-list has been defined.  Otherwise NIL.
-  (defined nil :type (member t nil))
-  ;;
-  ;; The list of expansions for this search-list.  Each expansion is the list
-  ;; of directory components to use in place of this search-list.
-  (%expansions (%primitive c:make-value-cell nil)));  :type list))
-
-(defun search-list-expansions (x)
-  (%primitive c:value-cell-ref (search-list-%expansions x)))
-
-(defun (setf search-list-expansions) (val x)
-  (%primitive c:value-cell-set (search-list-%expansions x) val))
-
-(defun %print-search-list (sl stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (sl stream :type t)
-    (write-string (search-list-name sl) stream)))
-
-;;; *SEARCH-LISTS* -- internal.
-;;;
-;;; Hash table mapping search-list names to search-list structures.
-;;; 
-(defvar *search-lists* (make-hash-table :test #'equal))
-
-;;; INTERN-SEARCH-LIST -- internal interface.
-;;;
-;;; When search-lists are encountered in namestrings, they are converted to
-;;; search-list structures right then, instead of waiting until the search
-;;; list used.  This allows us to verify ahead of time that there are no
-;;; circularities and makes expansion much quicker.
-;;; 
-(defun intern-search-list (name)
-  (let ((name (string-downcase name)))
-    (or (gethash name *search-lists*)
-	(let ((new (make-search-list :name name)))
-	  (setf (gethash name *search-lists*) new)
-	  new))))
-
-;;; CLEAR-SEARCH-LIST -- public.
-;;;
-;;; Clear the definition.  Note: we can't remove it from the hash-table
-;;; because there may be pathnames still refering to it.  So we just clear
-;;; out the expansions and ste defined to NIL.
-;;; 
-(defun clear-search-list (name)
-  "Clear the current definition for the search-list NAME.  Returns T if such
-   a definition existed, and NIL if not."
-  (let* ((name (string-downcase name))
-	 (search-list (gethash name *search-lists*)))
-    (when (and search-list (search-list-defined search-list))
-      (setf (search-list-defined search-list) nil)
-      (setf (search-list-expansions search-list) nil)
-      t)))
-
-;;; CLEAR-ALL-SEARCH-LISTS -- sorta public.
-;;;
-;;; Again, we can't actually remove the entries from the hash-table, so we
-;;; just mark them as being undefined.
-;;;
-(defun clear-all-search-lists ()
-  "Clear the definition for all search-lists.  Only use this if you know
-   what you are doing."
-  (maphash #'(lambda (name search-list)
-	       (declare (ignore name))
-	       (setf (search-list-defined search-list) nil)
-	       (setf (search-list-expansions search-list) nil))
-	   *search-lists*)
-  nil)
-
-;;; EXTRACT-SEARCH-LIST -- internal.
-;;;
-;;; Extract the search-list from PATHNAME and return it.  If PATHNAME
-;;; doesn't start with a search-list, then either error (if FLAME-IF-NONE
-;;; is true) or return NIL (if FLAME-IF-NONE is false).
-;;; 
-(defun extract-search-list (pathname flame-if-none)
-  (with-pathname (pathname pathname)
-    (let* ((directory (%pathname-directory pathname))
-	   (search-list (cadr directory)))
-      (cond ((search-list-p search-list)
-	     search-list)
-	    (flame-if-none
-	     (error "~S doesn't start with a search-list." pathname))
-	    (t
-	     nil)))))
-
-;;; SEARCH-LIST -- public.
-;;;
-;;; We have to convert the internal form of the search-list back into a
-;;; bunch of pathnames.
-;;; 
-(defun search-list (pathname)
-  "Return the expansions for the search-list starting PATHNAME.  If PATHNAME
-   does not start with a search-list, then an error is signaled.  If
-   the search-list has not been defined yet, then an error is signaled.
-   The expansion for a search-list can be set with SETF."
-  (with-pathname (pathname pathname)
-    (let ((search-list (extract-search-list pathname t))
-	  (host (pathname-host pathname)))
-      (if (search-list-defined search-list)
-	  (mapcar #'(lambda (directory)
-		      (make-pathname :host host
-				     :directory (cons :absolute directory)))
-		  (search-list-expansions search-list))
-	  (error "Search list ~S has not been defined yet." pathname)))))
-
-;;; SEARCH-LIST-DEFINED-P -- public.
-;;; 
-(defun search-list-defined-p (pathname)
-  "Returns T if the search-list starting PATHNAME is currently defined, and
-   NIL otherwise.  An error is signaled if PATHNAME does not start with a
-   search-list."
-  (with-pathname (pathname pathname)
-    (search-list-defined (extract-search-list pathname t))))
-
-;;; %SET-SEARCH-LIST -- public setf method
-;;;
-;;; Set the expansion for the search-list in PATHNAME.  If this would result
-;;; in any circularities, we flame out.  If anything goes wrong, we leave the
-;;; old defintion intact.
-;;; 
-(defun %set-search-list (pathname values)
-  (let ((search-list (extract-search-list pathname t)))
-    (labels
-	((check (target-list path)
-	   (when (eq search-list target-list)
-	     (error "That would result in a circularity:~%  ~
-		     ~A~{ -> ~A~} -> ~A"
-		    (search-list-name search-list)
-		    (reverse path)
-		    (search-list-name target-list)))
-	   (when (search-list-p target-list)
-	     (push (search-list-name target-list) path)
-	     (dolist (expansion (search-list-expansions target-list))
-	       (check (car expansion) path))))
-	 (convert (pathname)
-	   (with-pathname (pathname pathname)
-	     (when (or (pathname-name pathname)
-		       (pathname-type pathname)
-		       (pathname-version pathname))
-	       (error "Search-lists cannot expand into pathnames that have ~
-		       a name, type, or ~%version specified:~%  ~S"
-		      pathname))
-	     (let ((directory (pathname-directory pathname)))
-	       (let ((expansion
-		      (if directory
-			  (ecase (car directory)
-			    (:absolute (cdr directory))
-			    (:relative (cons (intern-search-list "default")
-					     (cdr directory))))
-			  (list (intern-search-list "default")))))
-		 (check (car expansion) nil)
-		 expansion)))))
-      (setf (search-list-expansions search-list)
-	    (if (listp values)
-	      (mapcar #'convert values)
-	      (list (convert values)))))
-    (setf (search-list-defined search-list) t))
-  values)
-
-;;; ENUMERATE-SEARCH-LIST -- public.
-;;; 
-(defmacro enumerate-search-list ((var pathname &optional result) &body body)
-  "Execute BODY with VAR bound to each successive possible expansion for
-   PATHNAME and then return RESULT.  Note: if PATHNAME does not contain a
-   search-list, then BODY is executed exactly once.  Everything is wrapped
-   in a block named NIL, so RETURN can be used to terminate early.  Note:
-   VAR is *not* bound inside of RESULT."
-  (let ((body-name (gensym)))
-    `(block nil
-       (flet ((,body-name (,var)
-		,@body))
-	 (%enumerate-search-list ,pathname #',body-name)
-	 ,result))))
-
-(defun %enumerate-search-list (pathname function)
-  (let ((search-list (extract-search-list pathname nil)))
-    (cond
-     ((not search-list)
-      (funcall function pathname))
-     ((not (search-list-defined search-list))
-      (error "Undefined search list: ~A"
-	     (search-list-name search-list)))
-     (t
-      (let ((tail (cddr (pathname-directory pathname))))
-	(dolist (expansion
-		 (search-list-expansions search-list))
-	  (%enumerate-search-list (make-pathname :defaults pathname
-						 :directory
-						 (cons :absolute
-						       (append expansion
-							       tail)))
-				  function)))))))
-
-
-;;;;  Logical pathname support. ANSI 92-102 specification.
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Logical pathnames have the following format:
-;;;
-;;; logical-namestring ::=
-;;;         [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]]
-;;;
-;;; host ::= word
-;;; directory ::= word | wildcard-word | **
-;;; name ::= word | wildcard-word
-;;; type ::= word | wildcard-word
-;;; version ::= pos-int | newest | NEWEST | *
-;;; word ::= {uppercase-letter | digit | -}+
-;;; wildcard-word ::= [word] '* {word '*}* [word]
-;;; pos-int ::= integer > 0
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; Logical pathnames are a subclass of pathnames and can use the same
-;; data structures with the device slot necessarily nil.  The current lack of
-;; an integrated efficient CLOS means that the classes are mimiced using
-;; structures.  They follow the pattern set by search-lists, a CMUCL specific
-;; extension.
-
-(defstruct (logical-host
-	    (:include host
-		      (:parse #'parse-logical-namestring)
-		      (:unparse #'unparse-logical-namestring)
-		      (:unparse-host #'unparse-logical-host)
-		      (:unparse-directory #'unparse-logical-directory)
-		      (:unparse-file #'unparse-logical-file)
-		      (:unparse-enough #'identity)
-		      (:customary-case :upper)))
-  (name "" :type simple-string)
-  (translations nil :type list)
-  (canon-transls nil :type list))
-
-(deftype logical-pathname ()
-  '(satisfies logical-pathname-p))
-
-;;; LOGICAL-PATHNAME-P -- Public
-;;;
-(defun logical-pathname-p (thing)
-  "Return T if THING is a LOGICAL-PATHNAME object."
-  (and (pathnamep thing)
-       (logical-host-p (%pathname-host thing))))
-
-;;; *LOGICAL-PATHNAMES* --internal.
-;;;
-;;; Hash table searching maps a logical-pathname's host to their physical
-;;; pathname translation.
-
-(defvar *logical-pathnames* (make-hash-table :test #'equal))
-
-(define-condition logical-namestring-parse-error (error)
-  ((complaint :init-form (required-argument))
-   (arguments :init-form nil)
-   (namestring :init-form (required-argument))
-   (offset :init-form (required-argument)))
-  (:report %print-namestring-parse-error))
-
-;;; MAYBE-MAKE-LOGICAL-PATTERN -- Internal
-;;;
-(defun maybe-make-logical-pattern (namestr start end)
-  "Take the ; reduced strings and break them into words and wildcard-words."
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (collect ((pattern))
-    (let ((last-regular-char nil)
-	  (look-ahead+1 nil)
-	  (index start)
-	  (char nil))
-      (flet ((flush-pending-regulars ()
-	       (when last-regular-char
-		 (pattern (subseq namestr last-regular-char index))
-		 (setf last-regular-char nil))))
-	(loop
-	  (when (>= index end)
-		(return)) 
-	  (setf char (schar namestr index))
-	  (cond ((or (char= #\. char) (char= #\; char)) ; End of pattern piece.
-		 (flush-pending-regulars))
-		((or (char= #\- char) ; Hyphen is a legal word character.
-		     (alphanumericp char))    ; Building a word.
-		 (unless last-regular-char
-		   (setf last-regular-char index)))
-		((char= #\* char) ; Wildcard word, :wild or wildcard-inferior.
-		 (if (<= end index)
-		     (setf look-ahead+1 nil)
-		     (setf look-ahead+1 (schar namestr (1+ index))))
-		 (cond ((or (char= #\. look-ahead+1)
-			    (char= #\; look-ahead+1))
-			(flush-pending-regulars)
-			(pattern :wild)
-			(incf index)) ; skip * and ;
-		       ((and (char= #\* look-ahead+1)
-			     (char= #\; (schar namestr (+ 2 index))))
-			(pattern :wild-inferiors)
-			(setq last-regular-char nil)
-			(incf index 2)) ; skip ** and ;
-		       (t ; wildcard-word, keep going
-			(flush-pending-regulars)
-			(pattern :wild)
-			(incf index)
-			(unless last-regular-char
-			  (setf last-regular-char index))
-			)))
-		(t (error "Incorrect logical pathname syntax.")))
-	  (incf index))
-	(flush-pending-regulars))
-    (cond ((null (pattern))
-	   "")
-	  ((and (null (cdr (pattern)))
-		(simple-string-p (car (pattern))))
-	   (car (pattern)))
-	  ((= 1 (length (pattern)))
-	   (let ((elmt (first (pattern))))
-	     (if (or (eq elmt :wild) (eq elmt :wild-inferiors))
-		 elmt)))
-	  (t
-	   (make-pattern (pattern)))))))
-
-;;; INTERN-LOGICAL-HOST
-;;;
-(defun intern-logical-host (name)
-  (declare (simple-string name)
-	   (values logical-host))
-  (let ((name (string-upcase name)))
-    (or (gethash name *logical-pathnames*)
-	(let ((new (make-logical-host :name name)))
-	  (setf (gethash name *logical-pathnames*) new)
-	  new))))
-
-;;; EXTRACT-LOGICAL-NAME-TYPE-AND-VERSION
-;;;
-(defun extract-logical-name-type-and-version (namestr start end)
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (let* ((last-dot (position #\. namestr :start (1+ start) :end end
-			     :from-end t))
-	 (second-to-last-dot (and last-dot
-				  (position #\. namestr :start (1+ start)
-					    :end last-dot :from-end t)))
-	 (version :newest))
-    ;; If there is a second-to-last dot, check to see if there is a valid
-    ;; version after the last dot.
-    (when second-to-last-dot
-      (cond ((and (= (+ last-dot 2) end)
-		  (char= (schar namestr (1+ last-dot)) #\*))
-	     (setf version :wild))
-	    ((and (< (1+ last-dot) end)
-		  (do ((index (1+ last-dot) (1+ index)))
-		      ((= index end) t)
-		    (unless (char<= #\0 (schar namestr index) #\9)
-		      (return nil))))
-	     (setf version
-		   (parse-integer namestr :start (1+ last-dot) :end end)))
-	    (t
-	     (setf second-to-last-dot nil))))
-    (cond (second-to-last-dot
-	   (values (maybe-make-logical-pattern
-		    namestr start second-to-last-dot)
-		   (maybe-make-logical-pattern
-		    namestr (1+ second-to-last-dot) last-dot)
-		   version))
-	  (last-dot
-	   (values (maybe-make-logical-pattern namestr start last-dot)
-		   (maybe-make-logical-pattern namestr (1+ last-dot) end)
-		   version))
-	  (t
-	   (values (maybe-make-logical-pattern namestr start end)
-		   nil
-		   version)))))
-
-;;; LOGICAL-WORD-P -- Internal
-;;;
-;;;    Predicate for testing whether the syntax of the word is consistent
-;;; with the form of a logical host.
-;;;
-(defun logical-word-p (word)
-  (declare (type simple-base-string word)
-	   (values boolean))
-  (let ((ch nil))
-    (dotimes (i (length word))
-      (setf ch (schar word i))
-      (unless (or (alphanumericp ch) (eq ch #\-))
-	(return-from logical-word-p nil))))
-  t)
-
-;;; MAYBE-EXTRACT-LOGICAL-HOST -- Internal
-;;;    Verify whether there is a logical host prefix in the namestr. If one is
-;;; found return its name and the index of the remainder of the namestring.
-;;; If not return nil.
-;;;
-(defun maybe-extract-logical-host (namestr start end)
-  (declare (type simple-base-string namestr)
-	   (type index start)
-	   (type index start end)
-	   (values (or (member :wild) simple-base-string null) (or null index)))
-  (let ((colon-pos (position #\: namestr :start start :end end)))
-    (if colon-pos
-	(let ((host (subseq namestr start colon-pos)))
-	  (cond ((logical-word-p host)
-		 (return-from maybe-extract-logical-host
-			      (values (string-upcase host) (1+ colon-pos))))
-		((string= host "*")
-		 (return-from maybe-extract-logical-host
-			      (values :wild (1+ colon-pos))))))
-	;; Implied host
-	(values nil 0))))
-
-;;; PARSE-LOGICAL-NAMESTRING  -- Internal
-;;;
-;;;   Break up a logical-namestring into its constituent parts.
-;;;
-(defun parse-logical-namestring (namestr start end)
-
-  (declare (type simple-base-string namestr)
-	   (type index start end)
-	   (values (or logical-host null)
-		   (or (member nil :unspecific) simple-base-string)
-		   list
-		   (or simple-base-string list pattern (member :wild))
-		   (or simple-string pattern null (member :unspecific :wild))
-		   (or integer null (member :newest :wild))))
-  (multiple-value-bind ; Parse for :
-      (host place)
-      (maybe-extract-logical-host namestr start end)
-    (typecase host
-      (keyword t) ; :wild for example.
-      (simple-string ; Already a search-list element?
-       (unless (gethash (string-downcase host) *search-lists*)
-	  (setf host (intern-logical-host host))))
-      (null nil))
-    (multiple-value-bind
-	(absolute pieces) 
-	(split-at-slashes namestr place end #\;)
-      ;; Logical paths follow opposite convention of physical pathnames.
-      (setf absolute (not absolute)) 
-      (multiple-value-bind (name type version)
-			   (let* ((tail (car (last pieces)))
-				  (tail-start (car tail))
-				  (tail-end (cdr tail)))
-			     (unless (= tail-start tail-end)
-			       (setf pieces (butlast pieces))
-			       (extract-logical-name-type-and-version
-				namestr tail-start tail-end)))
-	;; Now we have everything we want.  So return it.
-	(values host
-		:unspecific
-		(collect ((dirs))
-		  (dolist (piece pieces)
-		    (let ((piece-start (car piece))
-			  (piece-end (cdr piece)))
-		      (unless (= piece-start piece-end)
-			(let ((dir (maybe-make-logical-pattern namestr
-							       piece-start
-							       piece-end)))
-			  (if (and (simple-string-p dir)
-				   (string= dir ".."))
-			      (dirs :up)
-			      (dirs dir))))))
-		  (cond (absolute
-			 (cons :absolute (dirs)))
-			((dirs)
-			 (cons :relative (dirs)))
-			(t
-			 nil)))
-		name
-		type
-		version)))))
-
-;;; UNPARSE-LOGICAL-DIRECTORY-LIST -- Internal
-;;;
-(defun unparse-logical-directory-list (directory)
-  (declare (type list directory))
-  (collect ((pieces))
-	   (when directory
-	     (ecase (pop directory)
-	       (:absolute
-		;; Nothing special.
-		)
-	       (:relative
-		(pieces ";")
-		))
-	     (dolist (dir directory)
-	       (cond ((or (stringp dir) (pattern-p dir))
-		      (pieces (unparse-logical-piece dir))
-		      (pieces ";"))
-		     ((eq dir :wild)
-		      (pieces "*;"))
-		     ((eq dir :wild-inferiors)
-		      (pieces "**;"))
-		     (t
-		      (error "Invalid directory component: ~S" dir)))))
-	   (apply #'concatenate 'simple-string (pieces))))
-
-;;; UNPARSE-LOGICAL-DIRECTORY -- Internal
-;;;
-(defun unparse-logical-directory (pathname)
-  (declare (type pathname pathname))
-  (unparse-logical-directory-list (%pathname-directory pathname)))
-
-;;; UNPARSE-LOGICAL-PIECE -- Internal
-;;;
-(defun unparse-logical-piece (thing)
-  (etypecase thing
-    (simple-string
-     (let* ((srclen (length thing))
-	    (dstlen srclen))
-       (dotimes (i srclen)
-	 (case (schar thing i)
-	   (#\*
-	    (incf dstlen))))
-       (let ((result (make-string dstlen))
-	     (dst 0))
-	 (dotimes (src srclen)
-	   (let ((char (schar thing src)))
-	     (case char
-	       (#\*
-		(setf (schar result dst) #\\)
-		(incf dst)))
-	     (setf (schar result dst) char)
-	     (incf dst)))
-	 result)))
-    (pattern
-     (collect ((strings))
-	      (dolist (piece (pattern-pieces thing))
-		(typecase piece
-		  (simple-string
-		   (strings piece))
-		  (keyword
-		   (cond ((eq piece :wild-inferiors)
-			  (strings "**"))
-			 ((eq piece :wild)
-			  (strings "*"))
-			 (t (error "Invalid keyword: ~S" piece))))
-		  (t
-		   (error "Invalid pattern piece: ~S" piece))))
-	      (apply #'concatenate
-		     'simple-string
-		     (strings))))))
-
-;;; UNPARSE-LOGICAL-FILE -- Internal
-;;;
-(defun unparse-logical-file (pathname)
-  (declare (type pathname pathname))
-  (declare (type pathname pathname))
-  (unparse-unix-file pathname))
-
-;;; UNPARSE-LOGICAL-HOST -- Internal
-;;;
-(defun unparse-logical-host (pathname)
-  (declare (type logical-pathname pathname))
-  (logical-host-name (%pathname-host pathname)))
-
-;;; UNPARSE-LOGICAL-NAMESTRING -- Internal
-;;;
-(defun unparse-logical-namestring (pathname)
-  (declare (type logical-pathname pathname))
-  (concatenate 'simple-string
-	       (unparse-logical-host pathname) ":"
-	       (unparse-logical-directory pathname)
-	       (unparse-logical-file pathname)))
-
-;;; LOGICAL-PATHNAME -- Public
-;;;
-;;; Logical-pathname must signal a type error of type type-error.
-;;;
-(defun logical-pathname (pathspec)
-  "Converts the pathspec argument to a logical-pathname and returns it."
-  (declare (type (or logical-pathname string stream) pathspec)
-	   (values logical-pathname))
-  ;; Decide whether to typedef logical-pathname, logical-pathname-string,
-  ;; or streams for which the pathname function returns a logical-pathname.
-  (cond ((logical-pathname-p pathspec) pathspec)
-	((stringp pathspec)
-	 (if (maybe-extract-logical-host pathspec 0 (length pathspec))
-	     (pathname pathspec)
-	     (error "Pathspec is not a logical pathname prefaced by <host>:.")))
-	((streamp pathspec)
-	 (if (logical-pathname-p pathspec)
-	     (pathname pathspec)
-	     (error "Stream ~S is not a logical-pathname." pathspec)))
-	(t
-	 (error "~S is not either ~%
-		 a logical-pathname object, or~%
-		 a logical pathname namestring, or~%
-		 a stream named by a logical pathname." pathspec))))
-
-;;; TRANSLATIONS-TEST-P
-;;;
-;;;   Verify that the list of translations consists of lists and prepare
-;;; canonical translations from the pathnames.
-;;;
-(defun translations-test-p (transl-list host)
-  (declare (type logical-host host)
-	   (type list transl-list)
-	   (values boolean))
-  (let ((can-transls nil))
-    (setf can-transls (make-list (length transl-list))
-	  (logical-host-canon-transls host) can-transls)
-    (do* ((i 0 (1+ i))
-	  (tr (nth i transl-list) (nth i transl-list))
-	  (from-path (first tr) (first tr))
-	  (to-path (second tr) (second tr))
-	  (c-tr (nth i can-transls) (nth i can-transls)))
-	 ((<= (length transl-list) i))
-      (setf c-tr (make-list 2))
-      (if (logical-pathname-p from-path)
-	(setf (first c-tr) from-path)
-	(setf (first c-tr) (parse-namestring from-path host)))
-      (if (pathnamep to-path)
-	  (setf (second c-tr) to-path)
-	  (setf (second c-tr) (parse-namestring to-path)))
-      ;; Verify form of translations.
-      (unless (and (or (logical-pathname-p from-path)
-		       (first c-tr))
-		   (second c-tr))
-	(return-from translations-test-p nil))		       
-      (setf (nth i can-transls) c-tr)))
-  (setf (logical-host-translations host) transl-list)
-  t)
-
-;;; LOGICAL-PATHNAME-TRANSLATIONS -- Public
-;;;
-(defun logical-pathname-translations (host)
-  "Return the (logical) host object argument's list of translations."
-  (declare (type (or simple-base-string logical-host) host)
-	   (values list))
-  (etypecase host
-    (simple-string
-     (setf host (string-upcase host))
-     (let ((host-struc (gethash host *logical-pathnames*)))
-       (if host-struc
-	   (logical-host-translations host-struc)
-	   (error "HOST ~S is not defined." host))))
-    (logical-host
-     (logical-host-translations host))))
-
-;;; (SETF LOGICAL-PATHNAME-TRANSLATIONS) -- Public
-;;;
-(defun (setf logical-pathname-translations) (translations host)
-  "Set the translations list for the logical host argument.
-   Return translations."
-  (declare (type (or simple-base-string logical-host) host)
-	   (type list translations)
-	   (values list))
-  (typecase host 
-    (simple-base-string
-     (setf host (string-upcase host))
-     (multiple-value-bind
-	 (hash-host xst?)
-	 (gethash host *logical-pathnames*)
-       (unless xst?
-	 (intern-logical-host host)
-	 (setf hash-host (gethash host *logical-pathnames*)))
-       (unless (translations-test-p translations hash-host)
-	 (error "Translations ~S is not a list of pairs of from-, ~
-		 to-pathnames." translations)))
-     translations)
-    (t
-     (unless (translations-test-p translations host)
-       (error "Translations ~S is not a list of pairs of from-, ~
-	       to-pathnames." translations))
-     translations)))
-
-;;; The search mechanism for loading pathname translations uses the CMUCL
-;;; extension of search-lists.  The user can add to the library: search-list
-;;; using setf.  The file for translations should have the name defined by
-;;; the hostname (a string) and with type component "translations".
-
-;;; SAVE-LOGICAL-PATHNAME-TRANSLATIONS -- Public
-;;;
-(defun save-logical-pathname-translations (host directory)
-  "Save the translations for host in the file named host in
-   the directory argument. This is an internal convenience function and
-   not part of the ANSI standard."
-  (declare (type simple-base-string host directory))
-  (setf host (string-upcase host))
-  (let* ((p-name (make-pathname :directory (%pathname-directory
-					    (pathname directory))
-				:name host
-				:type "translations"
-				:version :newest))
-	 (new-stuff (gethash host *logical-pathnames*))
-	 (new-transl (logical-host-translations new-stuff)))
-	(with-open-file (out-str p-name
-				 :direction :output
-				 :if-exists :new-version
-				 :if-does-not-exist :create)
-	  (write new-transl :stream out-str)
-	  (format t "Created a new version of the file:~%   ~
-		     ~S~% ~
-		     containing logical-pathname translations:~%   ~
-		     ~S~% ~
-		     for the host:~%   ~
-		     ~S.~%" p-name new-transl host))))
-
-;;; Define a SYS area for system dependent logical translations, should we
-;;; ever want to use them. ########### Decision still need to made whether
-;;; to take advantage of this area.
-
-#|
-(progn
-  (intern-logical-host "SYS")
-  (save-logical-pathname-translations "SYS" "library:"))
-|#
-;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS -- Public
-;;;
-(defun load-logical-pathname-translations (host)
-  "Search for a logical pathname named host, if not already defined. If already
-   defined no attempt to find or load a definition is attempted and NIL is
-   returned. If host is not already defined, but definition is found and loaded
-   successfully, T is returned, else error."
-  (declare (type simple-base-string host)
-	   (values boolean))
-  (setf host (string-upcase host))
-  (let ((p-name nil)
-	(p-trans nil))
-    (multiple-value-bind
-	(log-host xst?)
-	(gethash host *logical-pathnames*)
-      (if xst?
-	  ;; host already has a set of defined translations.
-	  (return-from load-logical-pathname-translations nil)
-	  (enumerate-search-list (p "library:")
- 	     (setf p-name (make-pathname :host (%pathname-host p)
-					 :directory (%pathname-directory p)
-					 :device (%pathname-device p)
-					 :name host
-					 :type "translations"
-					 :version :newest))
-	     (if (member p-name (directory p) :test #'pathname=)
-		 (with-open-file (in-str p-name
-					 :direction :input
-					 :if-does-not-exist :error)
-		   (setf p-trans (read in-str))
-		   (setf log-host (intern-logical-host host))
-		   (format t ";; Loading ~S~%" p-name)
-		   (unless (translations-test-p p-trans log-host)
-		     (error "Translations ~S is not a list of pairs of from-, ~
-			     to-pathnames." p-trans))
-		   (format t ";; Loading done.~%")
-		   (return-from load-logical-pathname-translations t))))))))
-
-;;; COMPILE-FILE-PATHNAME -- Public
-;;;
-(defun compile-file-pathname (file-path &key output-file)
-  (declare (type (or string stream pathname logical-pathname) file-path)
-	   (type (or string stream pathname logical-pathname) output-file)
-	   (values pathname))
-  (with-pathname (path file-path)
-     (cond ((and (logical-pathname-p path) (not output-file))
-	    (make-pathname :host (%pathname-host path)
-			   :directory (%pathname-directory path)
-			   :device (%pathname-device path)
-			   :name (%pathname-name path)
-			   :type (c:backend-fasl-file-type c:*backend*)))
-	   ((logical-pathname-p path)
-	    (translate-logical-pathname path))
-	   (t file-path))))
-
-;;; TRANSLATE-WILD-P -- Internal
-;;;
-(defmacro translate-wild-p (to-obj)
-  "Translate :wild?"
-  (declare (type keyword to-obj))
-  `(etypecase ,to-obj
-     ((or (member :wild :unspecific nil :up :back)
-	  string
-	  pattern)
-      t)))
-
-;;; INTERMEDIATE-REP -- Internal
-;;;
-(defun intermediate-rep (from to)
-  "A logical component transition function that translates from one argument
-   to the other. This function is specific to the CMUCL implementation."
-  (declare (type (or logical-host host simple-base-string pattern symbol list)
-		 from)
-	   (type (or logical-host host simple-base-string pattern symbol list)
-		 to)
-	   (values
-	    (or logical-host host simple-base-string pattern list symbol)))
-  (etypecase from
-    (logical-host
-     (if (or (host-p to) (logical-host-p to))
-	 to))
-    (host
-     (if (host-p to)
-	 to))
-    (simple-base-string 
-     (etypecase to
-       (pattern
-	(multiple-value-bind
-	    (won subs)
-	    (pattern-matches to from)
-	  (if won
-	      (values (substitute-into to subs))
-	      (error "String ~S failed to match pattern ~S" from to))))
-       (simple-base-string to)
-       ((member nil :wild :wild-inferiors) from)))
-    (pattern
-     (etypecase to
-       (pattern
-	(if (pattern= to from)
-	    to
-	    (error "Patterns ~S and ~S do not match.")))))
-    ((member :absolute :relative)
-     (if (eq to from)
-	 to
-	 (error "The directory bases (FROM = ~S, TO = ~S) for the logical ~%~
-		 pathname translation are not consistently relative or absolute." from to)))
-    ((member :wild)
-     (etypecase to
-       ((or string
-	    pattern
-	    (member nil :unspecific :newest :wild :wild-inferiors))
-	to)))
-    ((member :wild-inferiors) ; Only when single directory component.
-     (etypecase to
-       ((or string pattern cons (member nil :unspecific :wild :wild-inferiors))
-	to)))
-    ((member :unspecific nil)
-     from)
-    ((member :newest)
-     (case to
-       (:wild from)
-       (:unspecific :unspecific)
-       (:newest to)
-       ((member nil) from)))))
-    
-(proclaim '(inline translate-logical-component))
-
-;;; TRANSLATE-LOGICAL-COMPONENT -- Internal
-;;;
-(defun translate-logical-component (source from to)
-  (intermediate-rep (intermediate-rep source from) to))
-
-;;; TRANSLATE-LOGICAL-DIRECTORY  -- Internal
-;;;
-;;;   Translate logical directories within the UNIX heirarchical file system.
-;;;
-(defun translate-logical-directory (source from to)
-  ;; Handle unfilled components.
-  (if (or (eql source :UNSPECIFIC)
-	  (eql from :UNSPECIFIC)
-	  (eql to :UNSPECIFIC))
-      (return-from translate-logical-directory :UNSPECIFIC))
-  (if (or (not source) (not from) (not to))
-      (return-from translate-logical-directory nil))
-  ;; Handle directory component abbreviated as a wildcard.
-  (if (member source '(:WILD :WILD-INFERIORS))
-      (setf source '(:ABSOLUTE :WILD-INFERIORS)))
-  (if (member source '(:WILD :WILD-INFERIORS))
-      (setf source '(:ABSOLUTE :WILD-INFERIORS)))
-  (if (member source '(:WILD :WILD-INFERIORS))
-      (setf to '(:ABSOLUTE :WILD-INFERIORS)))
-  ;; Make two stage translation, storing the intermediate results in ires
-  ;; and finally returned in the list rres.
-  (let ((ires nil)
-	(rres nil)
-	(dummy nil)
-	(slen (length source))
-	(flen (length from))
-	(tlen (length to)))
-    (do* ((i 0 (1+ i))
-	  (j 0 (1+ j))
-	  (k 0)
-	  (s-el (nth i source) (nth i source))
-	  (s-next-el nil)
-	  (f-el (nth j from) (nth j from)))
-	 ((<= slen i))
-      (cond ((eq s-el :wild-inferiors)
-	     (setf s-next-el (nth (+ 1 i) source)) ; NIL if beyond end.
-	     (cond ((setf k (position s-next-el from :start (1+ j)))
-		    ;; Found it, splice this portion into ires.
-		    (setf ires
-			  (append ires
-				  (subseq from j (1- k)))
-			  j (1- k)))
-		   (t
-		    ;; Either did not find next source element in from,
-		    ;; or was nil.
-		    (setf ires
-			  (append ires
-				  (subseq from j flen)))
-		    (unless (= i (1- slen))
-		      (error "Source ~S inconsistent with from translation ~
-			      ~S~%." source from)))))
-	    (t 
-	     (setf ires (append ires (list (intermediate-rep s-el f-el)))))))
-    ;; Remember to add leftover elements of from.
-    (if (< slen flen)
-	(setf ires (append ires (last from (- flen slen)))))
-    (do* ((i 0 (1+ i))
-	  (j 0 (1+ j))
-	  (k 0)
-	  (irlen (length ires))
-	  (ir-el (nth i ires) (nth i ires))
-	  (ir-next-el nil)
-	  (t-el (nth j to) (nth j to)))
-	 ((<= tlen i))
-      ;; Remember to add leftover elements of to.
-      (cond ((eq ir-el :wild-inferiors)
-	     (setf ir-next-el (nth (+ 1 i) ires)) ; NIL if beyond end.
-	     (cond ((setf k (position ir-next-el from :start (1+ j)))
-		    ;; Found it, splice this portion into rres.
-		    (setf rres
-			  (append rres
-				  (subseq from j (1- k)))
-		       j (1- k)))
-		   (t
-		    ;; Either did not find next source element in from,
-		    ;; or was nil.
-		    (setf rres
-			  (append rres
-				  (subseq from j tlen)))
-		    (unless (= i (1- irlen))
-		      (error "Intermediate path ~S inconsistent with to~
-			      translation ~S~%." ires to)))))
-	    (t (if (setf dummy (intermediate-rep ir-el t-el))
-		   (setf rres (append rres (list dummy)))))))
-    (if (< flen tlen)
-	(setf rres (append rres (last to (- tlen flen)))))
-    rres))
-
-;;; A physical-pathname is a pathname that does not contain any wildcards,
-;;; but is not a logical-pathname. 
-
-(deftype physical-pathname ()
-  '(and (satisfies pathnamep)
-	(not (or (satisfies wild-pathname-p)
-		 (satisfies logical-pathname-p)))))
-
-;;; TRANSLATE-LOGICAL-PATHNAME  -- Public
-;;;
-(defun translate-logical-pathname (pathname &key)
-  "Translates pathname to a physical pathname, which is returned."
-  (declare (type logical-pathname pathname))
-  (with-pathname (source pathname)
-    (etypecase source
-      (physical-pathname source)
-      (logical-pathname 
-       (let ((source-host (%pathname-host source))
-	     (result-path nil))
-	 (unless (gethash
-		  (funcall (logical-host-unparse-host source-host) source)
-		  *logical-pathnames*)
-	   (error "The logical host ~S is not defined.~%"
-				    (logical-host-name source-host)))
-	 (dolist (src-transl (logical-host-canon-transls source-host)
-			     (error "~S has no matching translation for ~
-				     logical host ~S.~%"
-				    pathname (logical-host-name source-host)))
-	   (when (pathname-match-p source (first src-transl))
-	     (macrolet ((frob (field)
-			  `(let* ((from (first src-transl))
-				  (to (second src-transl))
-				  (result (translate-logical-component
-					   (,field source)
-					   (,field from)
-					   (,field to))))
-				 result)))
-	       (setf result-path
-		     (%make-pathname (frob %pathname-host)
-				     :unspecific
-				     (let* ((from (first src-transl))
-					    (to (second src-transl))
-					    (result
-					     (translate-logical-directory
-					      (%pathname-directory source)
-					      (%pathname-directory from)
-					      (%pathname-directory to))))
-				       (if (eq result :error)
-					   (error "~S doesn't match ~S"
-						  source from)
-					   result))
-				     (frob %pathname-name)
-				     (frob %pathname-type)
-				     (frob %pathname-version))))
-	     (etypecase result-path
-	       (logical-pathname 
-		(translate-logical-pathname result-path))
-	       (physical-pathname
-		(return-from translate-logical-pathname result-path))))))))))
-
-
-
-
diff --git a/code/pmax-disassem.lisp b/code/pmax-disassem.lisp
deleted file mode 100644
index 02c5701c07ebbd64efc5dca4f958a351c0c2d2f0..0000000000000000000000000000000000000000
--- a/code/pmax-disassem.lisp
+++ /dev/null
@@ -1,517 +0,0 @@
-;;; -*- Mode: Lisp; Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-disassem.lisp,v 1.17 1991/02/08 13:34:36 ram 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
-
-(defun register-name (register-number)
-  (unless (<= 0 register-number 31)
-    (error "Illegal register number!"))
-  (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 null-offset) (string= name "ADDI"))
-	   ;; 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) :initial-element nil))
-(proclaim '(type simple-vector *mips-instructions*))
-
-(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) :initial-element nil))
-(proclaim '(type simple-vector *mips-special-instructions*))
-
-(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) :initial-element nil))
-(proclaim '(type simple-vector *mips-bcond-instructions*))
-
-(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))))))
-
-
-
-;;;; Disassemble-code-sap
-
-(defun disassemble-code-sap (sap length &optional (stream t))
-  (do ((*current-instruction-number* 0 (1+ *current-instruction-number*))
-       (instruction-in-delay-slot-p nil))
-      ((>= *current-instruction-number* length))
-    (unless instruction-in-delay-slot-p
-      (format stream "~6D:" *current-instruction-number*))
-    (multiple-value-bind
-	(name type)
-	(disassemble-instruction (system:sap-ref-32
-				  sap
-				  *current-instruction-number*)
-				 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))))))
-
-
-;;;; Disassemble
-
-(defun compile-function-lambda-expr (function)
-  (multiple-value-bind
-      (lambda closurep name)
-      (function-lambda-expression function)
-    (declare (ignore name))
-    (when closurep
-      (error "Cannot compile lexical closure."))
-    (compile nil lambda)))
-
-(defun disassemble (object &optional (stream *standard-output*))
-  (let* ((function (cond ((or (symbolp object)
-			      (and (listp object)
-				   (eq (car object) 'lisp:setf)))
-			  (let ((temp (fdefinition object)))
-			    (if (eval:interpreted-function-p temp)
-				(compile-function-lambda-expr temp)
-				temp)))
-			 ((eval:interpreted-function-p object)
-			  (compile-function-lambda-expr object))
-			 ((functionp object)
-			  object)
-			 ((and (listp object)
-			       (eq (car object) 'lisp::lambda))
-			  (compile nil object))
-			 (t
-			  (error "Invalid argument to disassemble - ~S"
-				 object))))
-	 (self (system:%primitive function-self function))
-	 (code (di::function-code-header self)))
-    (disassemble-code-sap (truly-the system:system-area-pointer
-				     (system:%primitive code-instructions
-							code))
-			  (system:%primitive code-code-size code)
-			  stream)))
diff --git a/code/pmax-machdef.lisp b/code/pmax-machdef.lisp
deleted file mode 100644
index 1e9536445049c425c5851dc478466c70703aa404..0000000000000000000000000000000000000000
--- a/code/pmax-machdef.lisp
+++ /dev/null
@@ -1,39 +0,0 @@
-;;; -*- Log: code.log; Package: Mach -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-machdef.lisp,v 1.2 1991/02/08 13:34:41 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Record definitions needed for the interface to Mach.
-;;;
-(in-package "MACH")
-
-
-(export '(sigcontext-onstack sigcontext-mask sigcontext-pc sigcontext-regs
-	  sigcontext-mdlo sigcontext-mdhi sigcontext-ownedfp sigcontext-fpregs
-	  sigcontext-fpc_csr sigcontext-fpc_eir sigcontext-cause
-	  sigcontext-badvaddr sigcontext-badpaddr sigcontext *sigcontext
-	  indirect-*sigcontext))
-
-
-(def-c-record sigcontext
-  (onstack unsigned-long)
-  (mask unsigned-long)
-  (pc system-area-pointer)
-  (regs int-array)
-  (mdlo unsigned-long)
-  (mdhi unsigned-long)
-  (ownedfp unsigned-long)
-  (fpregs int-array)
-  (fpc_csr unsigned-long)
-  (fpc_eir unsigned-long)
-  (cause unsigned-long)
-  (badvaddr system-area-pointer)
-  (badpaddr system-area-pointer))
diff --git a/code/pmax-vm.lisp b/code/pmax-vm.lisp
deleted file mode 100644
index aec8bc20226bb58a7272f7248cbda6dd17d1629d..0000000000000000000000000000000000000000
--- a/code/pmax-vm.lisp
+++ /dev/null
@@ -1,209 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.12 1992/10/08 22:10:34 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-vm.lisp,v 1.12 1992/10/08 22:10:34 wlott Exp $
-;;;
-;;; This file contains the PMAX specific runtime stuff.
-;;;
-(in-package "MIPS")
-(use-package "SYSTEM")
-(use-package "ALIEN")
-(use-package "C-CALL")
-(use-package "UNIX")
-
-(export '(fixup-code-object internal-error-arguments
-	  sigcontext-program-counter sigcontext-register
-	  sigcontext-float-register sigcontext-floating-point-modes
-	  extern-alien-name sanctify-for-execution))
-
-
-;;;; The sigcontext structure.
-
-(def-alien-type sigcontext
-  (struct nil
-    (sc-onstack unsigned-long)
-    (sc-mask unsigned-long)
-    (sc-pc system-area-pointer)
-    (sc-regs (array unsigned-long 32))
-    (sc-mdlo unsigned-long)
-    (sc-mdhi unsigned-long)
-    (sc-ownedfp unsigned-long)
-    (sc-fpregs (array unsigned-long 32))
-    (sc-fpc-csr unsigned-long)
-    (sc-fpc-eir unsigned-long)
-    (sc-cause unsigned-long)
-    (sc-badvaddr system-area-pointer)
-    (sc-badpaddr system-area-pointer)))
-
-
-
-;;;; Add machine specific features to *features*
-
-(pushnew :decstation-3100 *features*)
-(pushnew :pmax *features*)
-
-
-
-;;;; MACHINE-TYPE and MACHINE-VERSION
-
-(defun machine-type ()
-  "Returns a string describing the type of the local machine."
-  "DECstation")
-
-(defun machine-version ()
-  "Returns a string describing the version of the local machine."
-  "DECstation")
-
-
-
-;;; FIXUP-CODE-OBJECT -- Interface
-;;;
-(defun fixup-code-object (code offset fixup kind)
-  (unless (zerop (rem offset word-bytes))
-    (error "Unaligned instruction?  offset=#x~X." offset))
-  (system:without-gcing
-   (let ((sap (truly-the system-area-pointer
-			 (%primitive c::code-instructions code))))
-     (ecase kind
-       (:jump
-	(assert (zerop (ash fixup -26)))
-	(setf (ldb (byte 26 0) (system:sap-ref-32 sap offset))
-	      (ash fixup -2)))
-       (:lui
-	(setf (sap-ref-16 sap offset)
-	      (+ (ash fixup -16)
-		 (if (logbitp 15 fixup) 1 0))))
-       (:addi
-	(setf (sap-ref-16 sap offset)
-	      (ldb (byte 16 0) fixup)))))))
-
-
-;;;; Internal-error-arguments.
-
-;;; INTERNAL-ERROR-ARGUMENTS -- interface.
-;;;
-;;; Given the sigcontext, extract the internal error arguments from the
-;;; instruction stream.
-;;; 
-(defun internal-error-arguments (scp)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (let ((pc (slot scp 'sc-pc)))
-      (declare (type system-area-pointer pc))
-      (when (logbitp 31 (slot scp 'sc-cause))
-	(setf pc (sap+ pc 4)))
-      (when (= (sap-ref-8 pc 4) 255)
-	(setf pc (sap+ pc 1)))
-      (let* ((length (sap-ref-8 pc 4))
-	     (vector (make-array length :element-type '(unsigned-byte 8))))
-	(declare (type (unsigned-byte 8) length)
-		 (type (simple-array (unsigned-byte 8) (*)) vector))
-	(copy-from-system-area pc (* vm:byte-bits 5)
-			       vector (* vm:word-bits
-					 vm:vector-data-offset)
-			       (* length vm:byte-bits))
-	(let* ((index 0)
-	       (error-number (c::read-var-integer vector index)))
-	  (collect ((sc-offsets))
-	    (loop
-	      (when (>= index length)
-		(return))
-	      (sc-offsets (c::read-var-integer vector index)))
-	    (values error-number (sc-offsets))))))))
-
-
-;;;; Sigcontext access functions.
-
-;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
-;;;
-(defun sigcontext-program-counter (scp)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (slot scp 'sc-pc)))
-
-;;; SIGCONTEXT-REGISTER -- Interface.
-;;;
-;;; An escape register saves the value of a register for a frame that someone
-;;; interrupts.  
-;;;
-(defun sigcontext-register (scp index)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (deref (slot scp 'sc-regs) index)))
-
-(defun %set-sigcontext-register (scp index new)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (setf (deref (slot scp 'sc-regs) index) new)
-    new))
-
-(defsetf sigcontext-register %set-sigcontext-register)
-
-
-;;; SIGCONTEXT-FLOAT-REGISTER  --  Interface.
-;;;
-;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
-;;; Format is the type of float to return.
-;;;
-(defun sigcontext-float-register (scp index format)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (let ((sap (alien-sap (slot scp 'sc-fpregs))))
-      (ecase format
-	(single-float (system:sap-ref-single sap (* index vm:word-bytes)))
-	(double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
-;;;
-(defun %set-sigcontext-float-register (scp index format new-value)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (let ((sap (alien-sap (slot scp 'sc-fpregs))))
-      (ecase format
-	(single-float
-	 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
-	(double-float
-	 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
-;;;
-(defsetf sigcontext-float-register %set-sigcontext-float-register)
-
-
-;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
-;;;
-;;;    Given a sigcontext pointer, return the floating point modes word in the
-;;; same format as returned by FLOATING-POINT-MODES.
-;;;
-(defun sigcontext-floating-point-modes (scp)
-  (declare (type (alien (* sigcontext)) scp))
-   (with-alien ((scp (* sigcontext) scp))
-    (slot scp 'sc-fpc-csr)))
-
-
-
-;;; EXTERN-ALIEN-NAME -- interface.
-;;;
-;;; The loader uses this to convert alien names to the form they occure in
-;;; the symbol table (for example, prepending an underscore).  On the MIPS,
-;;; we don't do anything.
-;;; 
-(defun extern-alien-name (name)
-  (declare (type simple-base-string name))
-  name)
-
-
-
-;;; SANCTIFY-FOR-EXECUTION -- Interface.
-;;;
-;;; Do whatever is necessary to make the given code component executable.
-;;; 
-(defun sanctify-for-execution (component)
-  (declare (ignore component))
-  nil)
diff --git a/code/pprint.lisp b/code/pprint.lisp
deleted file mode 100644
index 798cd73136befb730482d1f267f80ecae6963c4d..0000000000000000000000000000000000000000
--- a/code/pprint.lisp
+++ /dev/null
@@ -1,1474 +0,0 @@
-;;; -*- Package: PRETTY-PRINT -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.13 1992/12/08 20:01:11 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; CMU Common Lisp pretty printer.
-;;; Written by William Lott.  Algorithm stolen from Richard Waters' XP.
-;;;
-(in-package "PRETTY-PRINT" :nicknames '("PP"))
-(use-package "EXT")
-(use-package "KERNEL")
-
-(export '(pretty-stream pretty-stream-p))
-
-(in-package "LISP")
-(export '(pprint-logical-block pprint-pop pprint-exit-if-list-exhausted
-	  pprint-newline pprint-indent pprint-tab
-	  pprint-fill pprint-linear pprint-tabular
-	  copy-pprint-dispatch pprint-dispatch set-pprint-dispatch))
-(in-package "PP")
-
-
-;;;; Pretty streams
-
-;;; There are three different units for measuring character positions:
-;;;  COLUMN - offset (if characters) from the start of the current line.
-;;;  INDEX - index into the output buffer.
-;;;  POSITION - some position in the stream of characters cycling through
-;;;             the output buffer.
-;;; 
-(deftype column ()
-  '(and fixnum unsigned-byte))
-;;; The INDEX type is picked up from the kernel package.
-(deftype position ()
-  'fixnum)
-
-(defconstant initial-buffer-size 128)
-
-(defconstant default-line-length 80)
-
-(defstruct (pretty-stream
-	    (:include stream
-		      (:out #'pretty-out)
-		      (:sout #'pretty-sout)
-		      (:misc #'pretty-misc))
-	    (:constructor make-pretty-stream (target))
-	    (:print-function %print-pretty-stream))
-  ;;
-  ;; Where the output is going to finally go.
-  ;; 
-  (target (required-argument) :type stream)
-  ;;
-  ;; Line length we should format to.  Cached here so we don't have to keep
-  ;; extracting it from the target stream.
-  (line-length (or *print-right-margin*
-		   (lisp::line-length target)
-		   default-line-length)
-	       :type column)
-  ;;
-  ;; A simple string holding all the text that has been output but not yet
-  ;; printed.
-  (buffer (make-string initial-buffer-size) :type simple-string)
-  ;;
-  ;; The index into BUFFER where more text should be put.
-  (buffer-fill-pointer 0 :type index)
-  ;;
-  ;; Whenever we output stuff from the buffer, we shift the remaining noise
-  ;; over.  This makes it difficult to keep references to locations in
-  ;; the buffer.  Therefore, we have to keep track of the total amount of
-  ;; stuff that has been shifted out of the buffer.
-  (buffer-offset 0 :type position)
-  ;;
-  ;; The column the first character in the buffer will appear in.  Normally
-  ;; zero, but if we end up with a very long line with no breaks in it we
-  ;; might have to output part of it.  Then this will no longer be zero.
-  (buffer-start-column (or (lisp::charpos target) 0) :type column)
-  ;;
-  ;; The line number we are currently on.  Used for *print-lines* abrevs and
-  ;; to tell when sections have been split across multiple lines.
-  (line-number 0 :type index)
-  ;;
-  ;; Stack of logical blocks in effect at the buffer start.
-  (blocks (list (make-logical-block)) :type list)
-  ;;
-  ;; Buffer holding the per-line prefix active at the buffer start.
-  ;; Indentation is included in this.  The length of this is stored
-  ;; in the logical block stack.
-  (prefix (make-string initial-buffer-size) :type simple-string)
-  ;;
-  ;; Buffer holding the total remaining suffix active at the buffer start.
-  ;; The characters are right-justified in the buffer to make it easier
-  ;; to output the buffer.  The length is stored in the logical block
-  ;; stack.
-  (suffix (make-string initial-buffer-size) :type simple-string)
-  ;;
-  ;; Queue of pending operations.  When empty, HEAD=TAIL=NIL.  Otherwise,
-  ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
-  ;; cons.  Adding things to the queue is basically (setf (cdr head) (list
-  ;; new)) and removing them is basically (pop tail) [except that care must
-  ;; be taken to handle the empty queue case correctly.]
-  (queue-tail nil :type list)
-  (queue-head nil :type list)
-  ;;
-  ;; Block-start queue entries in effect at the queue head.
-  (pending-blocks nil :type list)
-  )
-
-(defun %print-pretty-stream (pstream stream depth)
-  (declare (ignore depth))
-  #+nil
-  (print-unreadable-object (pstream stream :type t :identity t))
-  (format stream "#<pretty stream {~8,'0X}>"
-	  (kernel:get-lisp-obj-address pstream)))
-
-
-(declaim (inline index-position position-index position-column))
-(defun index-position (index stream)
-  (declare (type index index) (type pretty-stream stream)
-	   (values position))
-  (+ index (pretty-stream-buffer-offset stream)))
-(defun position-index (position stream)
-  (declare (type position position) (type pretty-stream stream)
-	   (values index))
-  (- position (pretty-stream-buffer-offset stream)))
-(defun position-column (position stream)
-  (declare (type position position) (type pretty-stream stream)
-	   (values position))
-  (index-column (position-index position stream) stream))
-
-
-;;;; Stream interface routines.
-
-(defun pretty-out (stream char)
-  (declare (type pretty-stream stream)
-	   (type base-character char))
-  (cond ((char= char #\newline)
-	 (enqueue-newline stream :literal))
-	(t
-	 (assure-space-in-buffer stream 1)
-	 (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream)))
-	   (setf (schar (pretty-stream-buffer stream) fill-pointer) char)
-	   (setf (pretty-stream-buffer-fill-pointer stream)
-		 (1+ fill-pointer))))))
-
-(defun pretty-sout (stream string start end)
-  (declare (type pretty-stream stream)
-	   (type simple-string string)
-	   (type index start)
-	   (type (or index null) end))
-  (let ((end (or end (length string))))
-    (unless (= start end)
-      (let ((newline (position #\newline string :start start :end end)))
-	(cond
-	 (newline
-	  (pretty-sout stream string start newline)
-	  (enqueue-newline stream :literal)
-	  (pretty-sout stream string (1+ newline) end))
-	 (t
-	  (let ((chars (- end start)))
-	    (loop
-	      (let* ((available (assure-space-in-buffer stream chars))
-		     (count (min available chars))
-		     (fill-pointer (pretty-stream-buffer-fill-pointer stream))
-		     (new-fill-ptr (+ fill-pointer count)))
-		(replace (pretty-stream-buffer stream)
-			 string
-			 :start1 fill-pointer :end1 new-fill-ptr
-			 :start2 start)
-		(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
-		(decf chars count)
-		(when (zerop count)
-		  (return))
-		(incf start count))))))))))
-
-(defun pretty-misc (stream op &optional arg1 arg2)
-  (declare (ignore stream op arg1 arg2)))
-
-
-
-;;;; Logical blocks.
-
-(defstruct logical-block
-  ;;
-  ;; The column this logical block started in.
-  (start-column 0 :type column)
-  ;;
-  ;; The column the current section started in.
-  (section-column 0 :type column)
-  ;;
-  ;; The length of the per-line prefix.  We can't move the indentation
-  ;; left of this.
-  (per-line-prefix-end 0 :type index)
-  ;;
-  ;; The overall length of the prefix, including any indentation.
-  (prefix-length 0 :type index)
-  ;;
-  ;; The overall length of the suffix.
-  (suffix-length 0 :type index)
-  ;; 
-  ;; The line number 
-  (section-start-line 0 :type index))
-
-(defun really-start-logical-block (stream column prefix suffix)
-  (let* ((blocks (pretty-stream-blocks stream))
-	 (prev-block (car blocks))
-	 (per-line-end (logical-block-per-line-prefix-end prev-block))
-	 (prefix-length (logical-block-prefix-length prev-block))
-	 (suffix-length (logical-block-suffix-length prev-block))
-	 (block (make-logical-block
-		 :start-column column
-		 :section-column column
-		 :per-line-prefix-end per-line-end
-		 :prefix-length prefix-length
-		 :suffix-length suffix-length
-		 :section-start-line (pretty-stream-line-number stream))))
-    (setf (pretty-stream-blocks stream) (cons block blocks))
-    (set-indentation stream column)
-    (when prefix
-      (setf (logical-block-per-line-prefix-end block) column)
-      (replace (pretty-stream-prefix stream) prefix
-	       :start1 (- column (length prefix)) :end1 column))
-    (when suffix
-      (let* ((total-suffix (pretty-stream-suffix stream))
-	     (total-suffix-len (length total-suffix))
-	     (additional (length suffix))
-	     (new-suffix-len (+ suffix-length additional)))
-	(when (> new-suffix-len total-suffix-len)
-	  (let ((new-total-suffix-len
-		 (max (* total-suffix-len 2)
-		      (+ suffix-length
-			 (floor (* additional 5) 4)))))
-	    (setf total-suffix
-		  (replace (make-string new-total-suffix-len) total-suffix
-			   :start1 (- new-total-suffix-len suffix-length)
-			   :start2 (- total-suffix-len suffix-length)))
-	    (setf total-suffix-len new-total-suffix-len)
-	    (setf (pretty-stream-suffix stream) total-suffix)))
-	(replace total-suffix suffix
-		 :start1 (- total-suffix-len new-suffix-len)
-		 :end1 (- total-suffix-len suffix-length))
-	(setf (logical-block-suffix-length block) new-suffix-len))))
-  nil)
-
-(defun set-indentation (stream column)
-  (let* ((prefix (pretty-stream-prefix stream))
-	 (prefix-len (length prefix))
-	 (block (car (pretty-stream-blocks stream)))
-	 (current (logical-block-prefix-length block))
-	 (minimum (logical-block-per-line-prefix-end block))
-	 (column (max minimum column)))
-    (when (> column prefix-len)
-      (setf prefix
-	    (replace (make-string (max (* prefix-len 2)
-				       (+ prefix-len
-					  (floor (* (- column prefix-len) 5)
-						 4))))
-		     prefix
-		     :end1 current))
-      (setf (pretty-stream-prefix stream) prefix))
-    (when (> column current)
-      (fill prefix #\space :start current :end column))
-    (setf (logical-block-prefix-length block) column)))
-
-(defun really-end-logical-block (stream)
-  (let* ((old (pop (pretty-stream-blocks stream)))
-	 (old-indent (logical-block-prefix-length old))
-	 (new (car (pretty-stream-blocks stream)))
-	 (new-indent (logical-block-prefix-length new)))
-    (when (> new-indent old-indent)
-      (fill (pretty-stream-prefix stream) #\space
-	    :start old-indent :end new-indent)))
-  nil)
-
-
-
-;;;; The pending operation queue.
-
-(defstruct queued-op
-  (position 0 :type position))
-
-(defmacro enqueue (stream type &rest args)
-  (let ((constructor (intern (concatenate 'string
-					  "MAKE-"
-					  (symbol-name type)))))
-    (once-only ((stream stream)
-		(entry `(,constructor :position
-				      (index-position
-				       (pretty-stream-buffer-fill-pointer
-					,stream)
-				       ,stream)
-				      ,@args))
-		(op `(list ,entry))
-		(head `(pretty-stream-queue-head ,stream)))
-      `(progn
-	 (if ,head
-	     (setf (cdr ,head) ,op)
-	     (setf (pretty-stream-queue-tail ,stream) ,op))
-	 (setf (pretty-stream-queue-head ,stream) ,op)
-	 ,entry))))
-
-(defstruct (section-start
-	    (:include queued-op))
-  (depth 0 :type index)
-  (section-end nil :type (or null newline block-end)))
-
-(defstruct (newline
-	    (:include section-start))
-  (kind (required-argument)
-	:type (member :linear :fill :miser :literal :mandatory)))
-
-(defun enqueue-newline (stream kind)
-  (let* ((depth (length (pretty-stream-pending-blocks stream)))
-	 (newline (enqueue stream newline :kind kind :depth depth)))
-    (dolist (entry (pretty-stream-queue-tail stream))
-      (when (and (not (eq newline entry))
-		 (section-start-p entry)
-		 (null (section-start-section-end entry))
-		 (<= depth (section-start-depth entry)))
-	(setf (section-start-section-end entry) newline))))
-  (maybe-output stream (or (eq kind :literal) (eq kind :mandatory))))
-
-(defstruct (indentation
-	    (:include queued-op))
-  (kind (required-argument) :type (member :block :current))
-  (amount 0 :type fixnum))
-
-(defun enqueue-indent (stream kind amount)
-  (enqueue stream indentation :kind kind :amount amount))
-
-(defstruct (block-start
-	    (:include section-start))
-  (block-end nil :type (or null block-end))
-  (prefix nil :type (or null simple-string))
-  (suffix nil :type (or null simple-string)))
-
-(defun start-logical-block (stream prefix per-line-p suffix)
-  (when prefix
-    (pretty-sout stream prefix 0 (length prefix)))
-  (let* ((pending-blocks (pretty-stream-pending-blocks stream))
-	 (start (enqueue stream block-start
-			 :prefix (and per-line-p prefix)
-			 :suffix suffix
-			 :depth (length pending-blocks))))
-    (setf (pretty-stream-pending-blocks stream)
-	  (cons start pending-blocks))))
-
-(defstruct (block-end
-	    (:include queued-op))
-  (suffix nil :type (or null simple-string)))
-
-(defun end-logical-block (stream)
-  (let* ((start (pop (pretty-stream-pending-blocks stream)))
-	 (suffix (block-start-suffix start))
-	 (end (enqueue stream block-end :suffix suffix)))
-    (when suffix
-      (pretty-sout stream suffix 0 (length suffix)))
-    (setf (block-start-block-end start) end)))
-
-(defstruct (tab
-	    (:include queued-op))
-  (sectionp nil :type (member t nil))
-  (relativep nil :type (member t nil))
-  (colnum 0 :type column)
-  (colinc 0 :type column))
-
-(defun enqueue-tab (stream kind colnum colinc)
-  (multiple-value-bind
-      (sectionp relativep)
-      (ecase kind
-	(:line (values nil nil))
-	(:line-relative (values nil t))
-	(:section (values t nil))
-	(:section-relative (values t t)))
-    (enqueue stream tab :sectionp sectionp :relativep relativep
-	     :colnum colnum :colinc colinc)))
-
-
-;;;; Tab support.
-
-(defun compute-tab-size (tab section-start column)
-  (let ((origin (if (tab-sectionp tab) section-start 0))
-	(colnum (tab-colnum tab))
-	(colinc (tab-colinc tab)))
-    (cond ((tab-relativep tab)
-	   (unless (<= colinc 1)
-	     (let ((newposn (+ column colnum)))
-	       (let ((rem (rem newposn colinc)))
-		 (unless (zerop rem)
-		   (incf colnum (- colinc rem))))))
-	   colnum)
-	  ((<= column (+ colnum origin))
-	   (- (+ colnum origin) column))
-	  (t
-	   (- colinc
-	      (rem (- column origin) colinc))))))
-
-(defun index-column (index stream)
-  (let ((column (pretty-stream-buffer-start-column stream))
-	(section-start (logical-block-section-column
-			(first (pretty-stream-blocks stream))))
-	(end-position (index-position index stream)))
-    (dolist (op (pretty-stream-queue-tail stream))
-      (when (>= (queued-op-position op) end-position)
-	(return))
-      (typecase op
-	(tab
-	 (incf column
-	       (compute-tab-size op
-				 section-start
-				 (+ column
-				    (position-index (tab-position op)
-						    stream)))))
-	((or newline block-start)
-	 (setf section-start
-	       (+ column (position-index (queued-op-position op)
-					 stream))))))
-    (+ column index)))
-
-(defun expand-tabs (stream through)
-  (let ((insertions nil)
-	(additional 0)
-	(column (pretty-stream-buffer-start-column stream))
-	(section-start (logical-block-section-column
-			(first (pretty-stream-blocks stream)))))
-    (dolist (op (pretty-stream-queue-tail stream))
-      (typecase op
-	(tab
-	 (let* ((index (position-index (tab-position op) stream))
-		(tabsize (compute-tab-size op
-					   section-start
-					   (+ column index))))
-	   (unless (zerop tabsize)
-	     (push (cons index tabsize) insertions)
-	     (incf additional tabsize)
-	     (incf column tabsize))))
-	((or newline block-start)
-	 (setf section-start
-	       (+ column (position-index (queued-op-position op) stream)))))
-      (when (eq op through)
-	(return)))
-    (when insertions
-      (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
-	     (new-fill-ptr (+ fill-ptr additional))
-	     (buffer (pretty-stream-buffer stream))
-	     (new-buffer buffer)
-	     (length (length buffer))
-	     (end fill-ptr))
-	(when (> new-fill-ptr length)
-	  (let ((new-length (max (* length 2)
-				 (+ fill-ptr
-				    (floor (* additional 5) 4)))))
-	    (setf new-buffer (make-string new-length))
-	    (setf (pretty-stream-buffer stream) new-buffer)))
-	(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
-	(decf (pretty-stream-buffer-offset stream) additional)
-	(dolist (insertion insertions)
-	  (let* ((srcpos (car insertion))
-		 (amount (cdr insertion))
-		 (dstpos (+ srcpos additional)))
-	    (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end)
-	    (fill new-buffer #\space :start srcpos :end dstpos)
-	    (decf additional amount)
-	    (setf end srcpos)))
-	(unless (eq new-buffer buffer)
-	  (replace new-buffer buffer :end1 end :end2 end))))))
-
-
-;;;; Stuff to do the actual outputting.
-
-(defun assure-space-in-buffer (stream want)
-  (declare (type pretty-stream stream)
-	   (type index want))
-  (let* ((buffer (pretty-stream-buffer stream))
-	 (length (length buffer))
-	 (fill-ptr (pretty-stream-buffer-fill-pointer stream))
-	 (available (- length fill-ptr)))
-    (cond ((plusp available)
-	   available)
-	  ((> fill-ptr (pretty-stream-line-length stream))
-	   (unless (maybe-output stream nil)
-	     (output-partial-line stream))
-	   (assure-space-in-buffer stream want))
-	  (t
-	   (let* ((new-length (max (* length 2)
-				   (+ length
-				      (floor (* want 5) 4))))
-		  (new-buffer (make-string new-length)))
-	     (setf (pretty-stream-buffer stream) new-buffer)
-	     (replace new-buffer buffer :end1 fill-ptr)
-	     (- new-length fill-ptr))))))
-
-(defun maybe-output (stream force-newlines-p)
-  (declare (type pretty-stream stream))
-  (let ((tail (pretty-stream-queue-tail stream))
-	(output-anything nil))
-    (loop
-      (unless tail
-	(setf (pretty-stream-queue-head stream) nil)
-	(return))
-      (let ((next (pop tail)))
-	(etypecase next
-	  (newline
-	   (when (ecase (newline-kind next)
-		   ((:literal :mandatory :linear) t)
-		   (:miser (misering-p stream))
-		   (:fill
-		    (or (misering-p stream)
-			(> (pretty-stream-line-number stream)
-			   (logical-block-section-start-line
-			    (first (pretty-stream-blocks stream))))
-			(ecase (fits-on-line-p stream
-					       (newline-section-end next)
-					       force-newlines-p)
-			  ((t) nil)
-			  ((nil) t)
-			  (:dont-know
-			   (return))))))
-	     (setf output-anything t)
-	     (output-line stream next)))
-	  (indentation
-	   (unless (misering-p stream)
-	     (set-indentation stream
-			      (+ (ecase (indentation-kind next)
-				   (:block
-				    (logical-block-start-column
-				     (car (pretty-stream-blocks stream))))
-				   (:current
-				    (position-column
-				     (indentation-position next)
-				     stream)))
-				 (indentation-amount next)))))
-	  (block-start
-	   (ecase (fits-on-line-p stream (block-start-section-end next)
-				  force-newlines-p)
-	     ((t)
-	      ;; Just nuke the whole logical block and make it look like one
-	      ;; nice long literal.
-	      (let ((end (block-start-block-end next)))
-		(expand-tabs stream end)
-		(setf tail (cdr (member end tail)))))
-	     ((nil)
-	      (really-start-logical-block
-	       stream
-	       (position-column (block-start-position next) stream)
-	       (block-start-prefix next)
-	       (block-start-suffix next)))
-	     (:dont-know
-	      (return))))
-	  (block-end
-	   (really-end-logical-block stream))
-	  (tab
-	   (expand-tabs stream next))))
-      (setf (pretty-stream-queue-tail stream) tail))
-    output-anything))
-
-(defun misering-p (stream)
-  (declare (type pretty-stream stream))
-  (and *print-miser-width*
-       (<= (- (pretty-stream-line-length stream)
-	      (logical-block-start-column (car (pretty-stream-blocks stream))))
-	   *print-miser-width*)))
-
-(defun fits-on-line-p (stream until force-newlines-p)
-  (let ((available (pretty-stream-line-length stream)))
-    (when (and *print-lines*
-	       (= *print-lines* (pretty-stream-line-number stream)))
-      (decf available 3) ; for the `` ..''
-      (decf available (logical-block-suffix-length
-		       (car (pretty-stream-blocks stream)))))
-    (cond (until
-	   (<= (position-column (queued-op-position until) stream) available))
-	  (force-newlines-p nil)
-	  ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream)
-	      available)
-	   nil)
-	  (t
-	   :dont-know))))
-
-(defun output-line (stream until)
-  (declare (type pretty-stream stream)
-	   (type newline until))
-  (let* ((target (pretty-stream-target stream))
-	 (buffer (pretty-stream-buffer stream))
-	 (kind (newline-kind until))
-	 (literal-p (eq kind :literal))
-	 (amount-to-consume (position-index (newline-position until) stream))
-	 (amount-to-print
-	  (if literal-p
-	      amount-to-consume
-	      (let ((last-non-blank
-		     (position #\space buffer :end amount-to-consume
-			       :from-end t :test #'char/=)))
-		(if last-non-blank
-		    (1+ last-non-blank)
-		    0)))))
-    (write-string buffer target :end amount-to-print)
-    (let ((line-number (pretty-stream-line-number stream)))
-      (incf line-number)
-      (when (and *print-lines* (>= line-number *print-lines*))
-	(write-string " .." target)
-	(let ((suffix-length (logical-block-suffix-length
-			      (car (pretty-stream-blocks stream)))))
-	  (unless (zerop suffix-length)
-	    (let* ((suffix (pretty-stream-suffix stream))
-		   (len (length suffix)))
-	      (write-string suffix target
-			    :start (- len suffix-length)
-			    :end len))))
-	(throw 'line-limit-abbreviation-happened t))
-      (setf (pretty-stream-line-number stream) line-number)
-      (write-char #\newline target)
-      (setf (pretty-stream-buffer-start-column stream) 0)
-      (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
-	     (block (first (pretty-stream-blocks stream)))
-	     (prefix-len
-	      (if literal-p
-		  (logical-block-per-line-prefix-end block)
-		  (logical-block-prefix-length block)))
-	     (shift (- amount-to-consume prefix-len))
-	     (new-fill-ptr (- fill-ptr shift))
-	     (new-buffer buffer)
-	     (buffer-length (length buffer)))
-	(when (> new-fill-ptr buffer-length)
-	  (setf new-buffer
-		(make-string (max (* buffer-length 2)
-				  (+ buffer-length
-				     (floor (* (- new-fill-ptr buffer-length)
-					       5)
-					    4)))))
-	  (setf (pretty-stream-buffer stream) new-buffer))
-	(replace new-buffer buffer
-		 :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
-	(replace new-buffer (pretty-stream-prefix stream)
-		 :end1 prefix-len)
-	(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
-	(incf (pretty-stream-buffer-offset stream) shift)
-	(unless literal-p
-	  (setf (logical-block-section-column block) prefix-len)
-	  (setf (logical-block-section-start-line block) line-number))))))
-
-(defun output-partial-line (stream)
-  (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
-	 (tail (pretty-stream-queue-tail stream))
-	 (count
-	  (if tail
-	      (position-index (queued-op-position (car tail)) stream)
-	      fill-ptr))
-	 (new-fill-ptr (- fill-ptr count))
-	 (buffer (pretty-stream-buffer stream)))
-    (when (zerop count)
-      (error "Output-partial-line called when nothing can be output."))
-    (write-string buffer (pretty-stream-target stream)
-		  :start 0 :end count)
-    (incf (pretty-stream-buffer-start-column stream) count)
-    (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
-    (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
-    (incf (pretty-stream-buffer-offset stream) count)))
-
-(defun force-pretty-output (stream)
-  (maybe-output stream nil)
-  (expand-tabs stream nil)
-  (write-string (pretty-stream-buffer stream)
-		(pretty-stream-target stream)
-		:end (pretty-stream-buffer-fill-pointer stream)))
-
-
-;;;; Utilities.
-
-;;; WITH-PRETTY-STREAM -- internal.
-;;;
-(defmacro with-pretty-stream
-	  ((stream-var &optional (stream-expression stream-var)) &body body)
-  (let ((flet-name (gensym "WITH-PRETTY-STREAM-")))
-    `(flet ((,flet-name (,stream-var)
-	      ,@body))
-       (let ((stream ,stream-expression))
-	 (if (pretty-stream-p stream)
-	     (,flet-name stream)
-	     (catch 'line-limit-abbreviation-happened
-	       (let ((stream (make-pretty-stream stream)))
-		 (,flet-name stream)
-		 (force-pretty-output stream)))))
-       nil)))
-
-
-;;;; User interface to the pretty printer.
-
-(defmacro pprint-logical-block
-	  ((stream-symbol object &key prefix per-line-prefix suffix)
-	   &body body)
-  "Group some output into a logical block.  STREAM-SYMBOL should be either a
-   stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*).  The printer
-   control variable *PRINT-LEVEL* is automatically handled."
-  (when (and prefix per-line-prefix)
-    (error "Cannot specify both a prefix and a per-line-perfix."))
-  (multiple-value-bind
-      (stream-var stream-expression)
-      (case stream-symbol
-	((nil)
-	 (values '*standard-output* '*standard-output*))
-	((t)
-	 (values '*terminal-io* '*terminal-io*))
-	(t
-	 (values stream-symbol
-		 (once-only ((stream stream-symbol))
-		   `(case ,stream
-		      ((nil) *standard-output*)
-		      ((t) *terminal-io*)
-		      (t ,stream))))))
-    (let* ((object-var (if object (gensym) nil))
-	   (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
-	   (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
-	   (pp-pop-name (gensym "PPRINT-POP-"))
-	   (body
-	    `(descend-into (,stream-var)
-	       (let ((,count-name 0))
-		 (declare (type index ,count-name) (ignorable ,count-name))
-		 (start-logical-block ,stream-var ,(or prefix per-line-prefix)
-				      ,(if per-line-prefix t nil) ,suffix)
-		 (block ,block-name
-		   (flet ((,pp-pop-name ()
-			    ,@(when object
-				`((unless (listp ,object-var)
-				    (write-string ". " ,stream-var)
-				    (output-object ,object-var ,stream-var)
-				    (return-from ,block-name nil))))
-			    (when (eql ,count-name *print-length*)
-			      (write-string "..." ,stream-var)
-			      (return-from ,block-name nil))
-			    ,@(when object
-				`((when (and ,object-var
-					     (plusp ,count-name)
-					     (check-for-circularity
-					      ,object-var))
-				    (write-string ". " ,stream-var)
-				    (output-object ,object-var ,stream-var)
-				    (return-from ,block-name nil))))
-			    (incf ,count-name)
-			    ,@(when object
-				`((pop ,object-var)))))
-		     (declare (ignorable #',pp-pop-name))
-		     (macrolet ((pprint-pop ()
-				  '(,pp-pop-name))
-				(pprint-exit-if-list-exhausted ()
-				  ,(if object
-				       `'(when (null ,object-var)
-					   (return-from ,block-name nil))
-				       `'(return-from ,block-name nil))))
-		       ,@body)))
-		 (end-logical-block ,stream-var)))))
-      (when object
-	(setf body
-	      `(let ((,object-var ,object))
-		 (if (listp ,object-var)
-		     ,body
-		     (output-object ,object-var ,stream-var)))))
-      `(with-pretty-stream (,stream-var ,stream-expression)
-	 ,body))))
-
-(defmacro pprint-exit-if-list-exhausted ()
-  "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
-   if it's list argument is exhausted.  Can only be used inside
-   PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
-   PPRINT-LOGICAL-BLOCK is supplied."
-  (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
-	  PPRINT-LOGICAL-BLOCK."))
-
-(defmacro pprint-pop ()
-  "Return the next element from LIST argument to the closest enclosing
-   use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
-   and *PRINT-CIRCLE*.  Can only be used inside PPRINT-LOGICAL-BLOCK.
-   If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
-   is poped, but the *PRINT-LENGTH* testing still happens."
-  (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))
-  
-(defun pprint-newline (kind &optional stream)
-  "Output a conditional newline to STREAM (which defaults to
-   *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
-   nothing if not.  KIND can be one of:
-     :LINEAR - A line break is inserted if and only if the immediatly
-        containing section cannot be printed on one line.
-     :MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
-        (See *PRINT-MISER-WIDTH*.)
-     :FILL - A line break is inserted if and only if either:
-       (a) the following section cannot be printed on the end of the
-           current line,
-       (b) the preceding section was not printed on a single line, or
-       (c) the immediately containing section cannot be printed on one
-           line and miser-style is in effect.
-     :MANDATORY - A line break is always inserted.
-   When a line break is inserted by any type of conditional newline, any
-   blanks that immediately precede the conditional newline are ommitted
-   from the output and indentation is introduced at the beginning of the
-   next line.  (See PPRINT-INDENT.)"
-  (declare (type (member :linear :miser :fill :mandatory) kind)
-	   (type (or stream (member t nil)) stream)
-	   (values null))
-  (let ((stream (case stream
-		  ((t) *terminal-io*)
-		  ((nil) *standard-output*)
-		  (t stream))))
-    (when (pretty-stream-p stream)
-      (enqueue-newline stream kind)))
-  nil)
-
-(defun pprint-indent (relative-to n &optional stream)
-  "Specify the indentation to use in the current logical block if STREAM
-   (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream
-   and do nothing if not.  (See PPRINT-LOGICAL-BLOCK.)  N is the indention
-   to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
-     :BLOCK - Indent relative to the column the current logical block
-        started on.
-     :CURRENT - Indent relative to the current column.
-   The new indention value does not take effect until the following line
-   break."
-  (declare (type (member :block :current) relative-to)
-	   (type integer n)
-	   (type (or stream (member t nil)) stream)
-	   (values null))
-  (let ((stream (case stream
-		  ((t) *terminal-io*)
-		  ((nil) *standard-output*)
-		  (t stream))))
-    (when (pretty-stream-p stream)
-      (enqueue-indent stream relative-to n)))
-  nil)
-
-(defun pprint-tab (kind colnum colinc &optional stream)
-  "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing
-   stream, perform tabbing based on KIND, otherwise do nothing.  KIND can
-   be one of:
-     :LINE - Tab to column COLNUM.  If already past COLNUM tab to the next
-       multiple of COLINC.
-     :SECTION - Same as :LINE, but count from the start of the current
-       section, not the start of the line.
-     :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of
-       COLINC.
-     :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start
-       of the current section, not the start of the line."
-  (declare (type (member :line :section :line-relative :section-relative) kind)
-	   (type unsigned-byte colnum colinc)
-	   (type (or stream (member t nil)) stream)
-	   (values null))
-  (let ((stream (case stream
-		  ((t) *terminal-io*)
-		  ((nil) *standard-output*)
-		  (t stream))))
-    (when (pretty-stream-p stream)
-      (enqueue-tab stream kind colnum colinc)))
-  nil)
-
-(defun pprint-fill (stream list &optional (colon? t) atsign?)
-  "Output LIST to STREAM putting :FILL conditional newlines between each
-   element.  If COLON? is NIL (defaults to T), then no parens are printed
-   around the output.  ATSIGN? is ignored (but allowed so that PPRINT-FILL
-   can be used with the ~/.../ format directive."
-  (declare (ignore atsign?))
-  (pprint-logical-block (stream list
-				:prefix (if colon? "(")
-				:suffix (if colon? ")"))
-    (pprint-exit-if-list-exhausted)
-    (loop
-      (output-object (pprint-pop) stream)
-      (pprint-exit-if-list-exhausted)
-      (write-char #\space stream)
-      (pprint-newline :fill stream))))
-
-(defun pprint-linear (stream list &optional (colon? t) atsign?)
-  "Output LIST to STREAM putting :LINEAR conditional newlines between each
-   element.  If COLON? is NIL (defaults to T), then no parens are printed
-   around the output.  ATSIGN? is ignored (but allowed so that PPRINT-LINEAR
-   can be used with the ~/.../ format directive."
-  (declare (ignore atsign?))
-  (pprint-logical-block (stream list
-				:prefix (if colon? "(")
-				:suffix (if colon? ")"))
-    (pprint-exit-if-list-exhausted)
-    (loop
-      (output-object (pprint-pop) stream)
-      (pprint-exit-if-list-exhausted)
-      (write-char #\space stream)
-      (pprint-newline :linear stream))))
-
-(defun pprint-tabular (stream list &optional (colon? t) atsign? tabsize)
-  "Output LIST to STREAM tabbing to the next column that is an even multiple
-   of TABSIZE (which defaults to 16) between each element.  :FILL style
-   conditional newlines are also output between each element.  If COLON? is
-   NIL (defaults to T), then no parens are printed around the output.
-   ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with
-   the ~/.../ format directive."
-  (declare (ignore atsign?))
-  (pprint-logical-block (stream list
-				:prefix (if colon? "(")
-				:suffix (if colon? ")"))
-    (pprint-exit-if-list-exhausted)
-    (loop
-      (output-object (pprint-pop) stream)
-      (pprint-exit-if-list-exhausted)
-      (write-char #\space stream)
-      (pprint-tab :section-relative 0 (or tabsize 16) stream)
-      (pprint-newline :fill stream))))
-
-
-;;;; Pprint-dispatch tables.
-
-(defvar *initial-pprint-dispatch*)
-(defvar *building-initial-table* nil)
-
-(defstruct (pprint-dispatch-entry
-	    (:print-function %print-pprint-dispatch-entry))
-  ;;
-  ;; The type specifier for this entry.
-  (type (required-argument) :type t)
-  ;;
-  ;; A function to test to see if an object is of this time.  Pretty must
-  ;; just (lambda (obj) (typep object type)) except that we handle the
-  ;; CONS type specially so that (cons (member foo)) works.  We don't
-  ;; bother computing this for entries in the CONS hash table, because
-  ;; we don't need it.
-  (test-fn nil :type (or function null))
-  ;;
-  ;; The priority for this guy.
-  (priority 0 :type real)
-  ;;
-  ;; T iff one of the original entries.
-  (initial-p *building-initial-table* :type (member t nil))
-  ;;
-  ;; And the associated function.
-  (function (required-argument) :type function))
-
-(defun %print-pprint-dispatch-entry (entry stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (entry stream :type t)
-    (format stream "Type=~S, priority=~S~@[ [Initial]~]"
-	    (pprint-dispatch-entry-type entry)
-	    (pprint-dispatch-entry-priority entry)
-	    (pprint-dispatch-entry-initial-p entry))))
-
-(defstruct (pprint-dispatch-table
-	    (:print-function %print-pprint-dispatch-table))
-  ;;
-  ;; A list of all the entries (except for CONS entries below) in highest
-  ;; to lowest priority.
-  (entries nil :type list)
-  ;;
-  ;; A hash table mapping things to entries for type specifiers of the
-  ;; form (CONS (MEMBER <thing>)).  If the type specifier is of this form,
-  ;; we put it in this hash table instead of the regular entries table.
-  (cons-entries (make-hash-table :test #'eql)))
-
-(defun %print-pprint-dispatch-table (table stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (table stream :type t :identity t)))
-
-(defun cons-type-specifier-p (spec)
-  (and (consp spec)
-       (eq (car spec) 'cons)
-       (cdr spec)
-       (null (cddr spec))
-       (let ((car (cadr spec)))
-	 (and (consp car)
-	      (let ((carcar (car car)))
-		(or (eq carcar 'member)
-		    (eq carcar 'eql)))
-	      (cdr car)
-	      (null (cddr car))))))
-
-(defun entry< (e1 e2)
-  (declare (type pprint-dispatch-entry e1 e2))
-  (if (pprint-dispatch-entry-initial-p e1)
-      (if (pprint-dispatch-entry-initial-p e2)
-	  (< (pprint-dispatch-entry-priority e1)
-	     (pprint-dispatch-entry-priority e2))
-	  t)
-      (if (pprint-dispatch-entry-initial-p e2)
-	  nil
-	  (< (pprint-dispatch-entry-priority e1)
-	     (pprint-dispatch-entry-priority e2)))))
-
-(defun compute-test-fn (type)
-  (labels ((compute-test-expr (type object)
-	     (if (listp type)
-		 (case (car type)
-		   (cons
-		    (destructuring-bind
-			(&optional (car nil car-p) (cdr nil cdr-p))
-			(cdr type)
-		      `(and (consp ,object)
-			    ,@(when car-p
-				`(,(compute-test-expr car `(car ,object))))
-			    ,@(when cdr-p
-				`(,(compute-test-expr cdr `(cdr ,object)))))))
-		   (not
-		    (destructuring-bind (type) (cdr type)
-		      `(not ,(compute-test-expr type object))))
-		   (and
-		    `(and ,@(mapcar #'(lambda (type)
-					(compute-test-expr type object))
-				    (cdr type))))
-		   (or
-		    `(or ,@(mapcar #'(lambda (type)
-				       (compute-test-expr type object))
-				   (cdr type))))
-		   (t
-		    `(typep ,object ',type)))
-		 `(typep ,object ',type))))
-    (compile nil `(lambda (object) ,(compute-test-expr type 'object)))))
-
-(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
-  (declare (type (or pprint-dispatch-table null) table))
-  (let* ((orig (or table *initial-pprint-dispatch*))
-	 (new (make-pprint-dispatch-table
-	       :entries (copy-list (pprint-dispatch-table-entries orig))))
-	 (new-cons-entries (pprint-dispatch-table-cons-entries new)))
-    (maphash #'(lambda (key value)
-		 (setf (gethash key new-cons-entries) value))
-	     (pprint-dispatch-table-cons-entries orig))
-    new))
-
-(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
-  (declare (type (or pprint-dispatch-table null) table))
-  (let* ((table (or table *initial-pprint-dispatch*))
-	 (cons-entry
-	  (and (consp object)
-	       (gethash (car object)
-			(pprint-dispatch-table-cons-entries table))))
-	 (entry
-	  (dolist (entry (pprint-dispatch-table-entries table) cons-entry)
-	    (when (and cons-entry
-		       (entry< entry cons-entry))
-	      (return cons-entry))
-	    (when (funcall (pprint-dispatch-entry-test-fn entry) object)
-	      (return entry)))))
-    (if entry
-	(values (pprint-dispatch-entry-function entry) t)
-	(values #'(lambda (stream object)
-		    (output-ugly-object object stream))
-		nil))))
-
-(defun set-pprint-dispatch (type function &optional
-			    (priority 0) (table *print-pprint-dispatch*))
-  (declare (type (or null function) function)
-	   (type real priority)
-	   (type pprint-dispatch-table table))
-  (if function
-      (if (cons-type-specifier-p type)
-	  (setf (gethash (second (second type))
-			 (pprint-dispatch-table-cons-entries table))
-		(make-pprint-dispatch-entry :type type :priority priority
-					    :function function))
-	  (let ((list (delete type (pprint-dispatch-table-entries table)
-			      :key #'pprint-dispatch-entry-type
-			      :test #'equal))
-		(entry (make-pprint-dispatch-entry
-			:type type :test-fn (compute-test-fn type)
-			:priority priority :function function)))
-	    (do ((prev nil next)
-		 (next list (cdr next)))
-		((null next)
-		 (if prev
-		     (setf (cdr prev) (list entry))
-		     (setf list (list entry))))
-	      (when (entry< (car next) entry)
-		(if prev
-		    (setf (cdr prev) (cons entry next))
-		    (setf list (cons entry next)))
-		(return)))
-	    (setf (pprint-dispatch-table-entries table) list)))
-      (if (cons-type-specifier-p type)
-	  (remhash (second (second type))
-		   (pprint-dispatch-table-cons-entries table))
-	  (setf (pprint-dispatch-table-entries table)
-		(delete type (pprint-dispatch-table-entries table)
-			:key #'pprint-dispatch-entry-type
-			:test #'equal))))
-  nil)
-
-
-;;;; Standard pretty-printing routines.
-
-(defun pprint-array (stream array)
-  (cond ((or (and (null *print-array*) (null *print-readably*))
-	     (stringp array)
-	     (bit-vector-p array))
-	 (output-ugly-object array stream))
-	((and *print-readably* (not (eq (array-element-type array) 't)))
-	 (let ((*print-readably* nil))
-	   (error "~S cannot be printed readably.")))
-	((vectorp array)
-	 (pprint-vector stream array))
-	(t
-	 (pprint-multi-dim-array stream array))))
-
-(defun pprint-vector (stream vector)
-  (pprint-logical-block (stream nil :prefix "#(" :suffix ")")
-    (dotimes (i (length vector))
-      (pprint-pop)
-      (unless (zerop i)
-	(write-char #\space stream)
-	(pprint-newline :fill stream))
-      (output-object (aref vector i) stream))))
-
-(defun pprint-multi-dim-array (stream array)
-  (funcall (formatter "#~DA") stream (array-rank array))
-  (lisp::with-array-data ((data array) (start) (end))
-    (declare (ignore end))
-    (labels ((output-guts (stream index dimensions)
-	       (if (null dimensions)
-		   (output-object (aref data index) stream)
-		   (pprint-logical-block
-		       (stream nil :prefix "(" :suffix ")")
-		     (let ((dim (car dimensions)))
-		       (unless (zerop dim)
-			 (let* ((dims (cdr dimensions))
-				(index index)
-				(step (reduce #'* dims))
-				(count 0))
-			   (loop				
-			     (pprint-pop)
-			     (output-guts stream index dims)
-			     (when (= (incf count) dim)
-			       (return))
-			     (write-char #\space stream)
-			     (pprint-newline (if dims :linear :fill)
-					     stream)
-			     (incf index step)))))))))
-      (output-guts stream start (array-dimensions array)))))
-
-(defun pprint-lambda-list (stream lambda-list &rest noise)
-  (declare (ignore noise))
-  (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")")
-    (let ((state :required)
-	  (first t))
-      (loop
-	(pprint-exit-if-list-exhausted)
-	(unless first
-	  (write-char #\space stream))
-	(let ((arg (pprint-pop)))
-	  (unless first
-	    (case arg
-	      (&optional
-	       (setf state :optional)
-	       (pprint-newline :linear stream))
-	      ((&rest &body)
-	       (setf state :required)
-	       (pprint-newline :linear stream))
-	      (&key
-	       (setf state :key)
-	       (pprint-newline :linear stream))
-	      (&aux
-	       (setf state :optional)
-	       (pprint-newline :linear stream))
-	      (t
-	       (pprint-newline :fill stream))))
-	  (ecase state
-	    (:required
-	     (pprint-lambda-list stream arg))
-	    ((:optional :key)
-	     (pprint-logical-block
-		 (stream arg :prefix "(" :suffix ")")
-	       (pprint-exit-if-list-exhausted)
-	       (if (eq state :key)
-		   (pprint-logical-block
-		       (stream (pprint-pop) :prefix "(" :suffix ")")
-		     (pprint-exit-if-list-exhausted)
-		     (output-object (pprint-pop) stream)
-		     (pprint-exit-if-list-exhausted)
-		     (write-char #\space stream)
-		     (pprint-newline :fill stream)
-		     (pprint-lambda-list stream (pprint-pop))
-		     (loop
-		       (pprint-exit-if-list-exhausted)
-		       (write-char #\space stream)
-		       (pprint-newline :fill stream)
-		       (output-object (pprint-pop) stream)))
-		   (pprint-lambda-list stream (pprint-pop)))
-	       (loop
-		 (pprint-exit-if-list-exhausted)
-		 (write-char #\space stream)
-		 (pprint-newline :linear stream)
-		 (output-object (pprint-pop) stream))))))
-	(setf first nil)))))
-
-(defun pprint-lambda (stream list &rest noise)
-  (declare (ignore noise))
-  (funcall (formatter
-	    "~:<~^~W~^~3I ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
-	   stream list))
-
-(defun pprint-block (stream list &rest noise)
-  (declare (ignore noise))
-  (funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list))
-
-(defun pprint-flet (stream list &rest noise)
-  (declare (ignore noise))
-  (funcall (formatter
-	    "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
-	   stream
-	   list))
-
-(defun pprint-let (stream list &rest noise)
-  (declare (ignore noise))
-  (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
-	   stream
-	   list))
-
-(defun pprint-progn (stream list &rest noise)
-  (declare (ignore noise))
-  (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list))
-
-(defun pprint-progv (stream list &rest noise)
-  (declare (ignore noise))
-  (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
-	   stream list))
-
-(defun pprint-quote (stream list &rest noise)
-  (declare (ignore noise))
-  (if (and (consp list)
-	   (consp (cdr list))
-	   (null (cddr list)))
-      (case (car list)
-	(function
-	 (write-string "#'" stream)
-	 (output-object (cadr list) stream))
-	(quote
-	 (write-char #\' stream)
-	 (output-object (cadr list) stream))
-	(t
-	 (pprint-fill stream list)))
-      (pprint-fill stream list)))
-
-(defun pprint-setq (stream list &rest noise)
-  (declare (ignore noise))
-  (pprint-logical-block (stream list :prefix "(" :suffix ")")
-    (pprint-exit-if-list-exhausted)
-    (output-object (pprint-pop) stream)
-    (pprint-exit-if-list-exhausted)
-    (write-char #\space stream)
-    (pprint-newline :miser stream)
-    (if (> (length list) 3)
-	(loop
-	  (pprint-indent :current 2 stream)
-	  (output-object (pprint-pop) stream)
-	  (pprint-exit-if-list-exhausted)
-	  (write-char #\space stream)
-	  (pprint-newline :linear stream)
-	  (pprint-indent :current -2 stream)
-	  (output-object (pprint-pop) stream)
-	  (pprint-exit-if-list-exhausted)
-	  (write-char #\space stream)
-	  (pprint-newline :linear stream))
-	(progn
-	  (pprint-indent :current 0 stream)
-	  (output-object (pprint-pop) stream)
-	  (pprint-exit-if-list-exhausted)
-	  (write-char #\space stream)
-	  (pprint-newline :linear stream)
-	  (output-object (pprint-pop) stream)))))
-	  
-(defmacro pprint-tagbody-guts (stream)
-  `(loop
-     (pprint-exit-if-list-exhausted)
-     (write-char #\space ,stream)
-     (let ((form-or-tag (pprint-pop)))
-       (pprint-indent :block 
-		      (if (atom form-or-tag) 0 1)
-		      ,stream)
-       (pprint-newline :linear ,stream)
-       (output-object form-or-tag ,stream))))
-
-(defun pprint-tagbody (stream list &rest noise)
-  (declare (ignore noise))
-  (pprint-logical-block (stream list :prefix "(" :suffix ")")
-    (pprint-exit-if-list-exhausted)
-    (output-object (pprint-pop) stream)
-    (pprint-tagbody-guts stream)))
-
-(defun pprint-case (stream list &rest noise)
-  (declare (ignore noise))
-  (funcall (formatter
-	    "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/PP:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>")
-	   stream
-	   list))
-
-(defun pprint-defun (stream list &rest noise)
-  (declare (ignore noise))
-  (funcall (formatter
-	    "~:<~^~W~^ ~@_~:I~W~^ ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
-	   stream
-	   list))
-
-(defun pprint-destructuring-bind (stream list &rest noise)
-  (declare (ignore noise))
-  (funcall (formatter
-	"~:<~^~W~^~3I ~_~:/PP:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>")
-	   stream list))
-
-(defun pprint-do (stream list &rest noise)
-  (declare (ignore noise))
-  (pprint-logical-block (stream list :prefix "(" :suffix ")")
-    (pprint-exit-if-list-exhausted)
-    (output-object (pprint-pop) stream)
-    (pprint-exit-if-list-exhausted)
-    (write-char #\space stream)
-    (pprint-indent :current 0 stream)
-    (funcall (formatter "~:<~@{~:<~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>")
-	     stream
-	     (pprint-pop))
-    (pprint-exit-if-list-exhausted)
-    (write-char #\space stream)
-    (pprint-newline :linear stream)
-    (pprint-linear stream (pprint-pop))
-    (pprint-tagbody-guts stream)))
-
-(defun pprint-dolist (stream list &rest noise)
-  (declare (ignore noise))
-  (pprint-logical-block (stream list :prefix "(" :suffix ")")
-    (pprint-exit-if-list-exhausted)
-    (output-object (pprint-pop) stream)
-    (pprint-exit-if-list-exhausted)
-    (pprint-indent :block 3 stream)
-    (write-char #\space stream)
-    (pprint-newline :fill stream)
-    (funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>")
-	     stream
-	     (pprint-pop))
-    (pprint-tagbody-guts stream)))
-
-(defun pprint-typecase (stream list &rest noise)
-  (declare (ignore noise))
-  (funcall (formatter
-	    "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>")
-	   stream
-	   list))
-
-(defun pprint-prog (stream list &rest noise)
-  (declare (ignore noise))
-  (pprint-logical-block (stream list :prefix "(" :suffix ")")
-    (pprint-exit-if-list-exhausted)
-    (output-object (pprint-pop) stream)
-    (pprint-exit-if-list-exhausted)
-    (write-char #\space stream)
-    (pprint-newline :miser stream)
-    (pprint-fill stream (pprint-pop))
-    (pprint-tagbody-guts stream)))
-
-(defun pprint-function-call (stream list &rest noise)
-  (declare (ignore noise))
-  (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
-	   stream
-	   list))
-
-
-;;;; Interface seen by regular (ugly) printer and initialization routines.
-
-;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when *PRINT-PRETTY* is
-;;; bound to T.
-;;;
-(defun output-pretty-object (object stream)
-  (with-pretty-stream (stream)
-    (funcall (pprint-dispatch object) stream object)))
-
-(defparameter magic-forms
-  '((lambda pprint-lambda)
-    ;; Special forms.
-    (block pprint-block)
-    (catch pprint-block)
-    (compiler-let pprint-let)
-    (eval-when pprint-block)
-    (flet pprint-flet)
-    (function pprint-quote)
-    (generic-flet pprint-flet)
-    (generic-labels pprint-flet)
-    (labels pprint-flet)
-    (let pprint-let)
-    (let* pprint-let)
-    (locally pprint-progn)
-    (macrolet pprint-flet)
-    (multiple-value-call pprint-block)
-    (multiple-value-prog1 pprint-block)
-    (progn pprint-progn)
-    (progv pprint-progv)
-    (quote pprint-quote)
-    (return-from pprint-block)
-    (setq pprint-setq)
-    (symbol-macrolet pprint-let)
-    (tagbody pprint-tagbody)
-    (throw pprint-block)
-    (unwind-protect pprint-block)
-    (with-added-methods pprint-flet)
-    
-    ;; Macros.
-    (case pprint-case)
-    (ccase pprint-case)
-    (ctypecase pprint-typecase)
-    (defconstant pprint-block)
-    (define-modify-macro pprint-defun)
-    (define-setf-method pprint-defun)
-    (defmacro pprint-defun)
-    (defparameter pprint-block)
-    (defsetf pprint-defun)
-    (defstruct pprint-block)
-    (deftype pprint-defun)
-    (defun pprint-defun)
-    (defvar pprint-block)
-    (destructuring-bind pprint-destructuring-bind)
-    (do pprint-do)
-    (do* pprint-do)
-    (do-all-symbols pprint-dolist)
-    (do-external-symbols pprint-dolist)
-    (do-symbols pprint-dolist)
-    (dolist pprint-dolist)
-    (dotimes pprint-dolist)
-    (ecase pprint-case)
-    (etypecase pprint-typecase)
-    #+nil (handler-bind ...)
-    #+nil (handler-case ...)
-    #+nil (loop ...)
-    (multiple-value-bind pprint-progv)
-    (multiple-value-setq pprint-block)
-    (pprint-logical-block pprint-block)
-    (print-unreadable-object pprint-block)
-    (prog pprint-prog)
-    (prog* pprint-prog)
-    (prog1 pprint-block)
-    (prog2 pprint-progv)
-    (psetf pprint-setq)
-    (psetq pprint-setq)
-    #+nil (restart-bind ...)
-    #+nil (restart-case ...)
-    (setf pprint-setq)
-    (step pprint-progn)
-    (time pprint-progn)
-    (typecase pprint-typecase)
-    (unless pprint-block)
-    (when pprint-block)
-    (with-compilation-unit pprint-block)
-    #+nil (with-condition-restarts ...)
-    (with-hash-table-iterator pprint-block)
-    (with-input-from-string pprint-block)
-    (with-open-file pprint-block)
-    (with-open-stream pprint-block)
-    (with-output-to-string pprint-block)
-    (with-package-iterator pprint-block)
-    (with-simple-restart pprint-block)
-    (with-standard-io-syntax pprint-progn)))
-
-(defun pprint-init ()
-  (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
-  (let ((*print-pprint-dispatch* *initial-pprint-dispatch*)
-	(*building-initial-table* t))
-    ;; Printers for regular types.
-    (set-pprint-dispatch 'array #'pprint-array)
-    (set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
-			 #'pprint-function-call -1)
-    (set-pprint-dispatch 'cons #'pprint-fill -2)
-    ;; Cons cells with interesting things for the car.
-    (dolist (magic-form magic-forms)
-      (set-pprint-dispatch `(cons (eql ,(first magic-form)))
-			   (symbol-function (second magic-form))))
-    ;; Other pretty-print init forms.
-    (lisp::backq-pp-init))
-
-  (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
-  (setf *pretty-printer* #'output-pretty-object)
-  (setf *print-pretty* t))
diff --git a/code/profile.lisp b/code/profile.lisp
deleted file mode 100644
index 9dac381816ad5d12b757f672c7123d386b0e50e4..0000000000000000000000000000000000000000
--- a/code/profile.lisp
+++ /dev/null
@@ -1,502 +0,0 @@
-;;; -*- Package: Profile -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.7 1992/09/07 16:11:12 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Description: Simple profiling facility.
-;;;
-;;; Author: Skef Wholey, Rob MacLachlan
-;;;
-;;; Compatibility: Runs in any valid Common Lisp.  Three small implementation-
-;;;   dependent changes can be made to improve performance and prettiness.
-;;;
-;;; Dependencies: The macro Quickly-Get-Time and the function
-;;;   Required-Arguments should probably be tailored to the implementation for
-;;;   the best results.  They will default to working, albeit inefficent, forms
-;;;   in non-CMU implementations.  The Total-Consing macro is used to profile
-;;;   consing: in unknown implementations 0 will be used.
-;;;   See the "Implementation Parameters" section.
-;;;
-;;; Note: a timing overhead factor is computed when REPORT-TIME is first
-;;; called.  This will be incorrect if profiling code is run in a different
-;;; environment than the first call to REPORT-TIME.  For example, saving a core
-;;; image on a high performance machine and running it on a low performance one
-;;; will result in use of an erroneously small timing overhead factor.  In CMU
-;;; CL, this cache is invalidated when a core is saved.
-;;;
-(in-package "PROFILE")
-
-(export '(*timed-functions* profile unprofile report-time reset-time))
-
-
-;;;; Implementation dependent interfaces:
-
-
-(progn
-  #-cmu
-  (eval-when (compile eval)
-    (warn
-     "You may want to supply an implementation-specific ~
-     Quickly-Get-Time function."))
-
-  (defconstant quick-time-units-per-second internal-time-units-per-second)
-  
-  (defmacro quickly-get-time ()
-    `(the time-type (get-internal-run-time))))
-
-
-;;; The type of the result from quickly-get-time.
-#+cmu
-(deftype time-type () '(unsigned-byte 29))
-#-cmu
-(deftype time-type () 'unsigned-byte)
-
-
-;;; To avoid unnecessary consing in the "encapsulation" code, we find out the
-;;; number of required arguments, and use &rest to capture only non-required
-;;; arguments.  The function Required-Arguments returns two values: the first
-;;; is the number of required arguments, and the second is T iff there are any
-;;; non-required arguments (e.g. &optional, &rest, &key).
-
-#+cmu 
-(defun required-arguments (name)
-  (let ((type (ext:info function type name)))
-    (cond ((not (kernel:function-type-p type))
-	   (warn "No argument count information available for:~%  ~S~@
-		  Allow for &rest arg consing."
-		 name)
-	   (values 0 t))
-	  (t
-	   (values (length (kernel:function-type-required type))
-		   (if (or (kernel:function-type-optional type)
-			   (kernel:function-type-keyp type)
-			   (kernel:function-type-rest type))
-		       t nil))))))
-
-#-cmu
-(progn
- (eval-when (compile eval)
-   (warn
-    "You may want to add an implementation-specific Required-Arguments function."))
- (eval-when (load eval)
-   (defun required-arguments (name)
-     (declare (ignore name))
-     (values 0 t))))
-
-
-
-;;; The Total-Consing macro is called to find the total number of bytes consed
-;;; since the beginning of time.
-
-#+cmu
-(defmacro total-consing () '(the consing-type (ext:get-bytes-consed)))
-
-#-cmu
-(progn
-  (eval-when (compile eval)
-    (warn "No consing will be reported unless a Total-Consing function is ~
-           defined."))
-
-  (defmacro total-consing () '0))
-
-
-;;; The type of the result of TOTAL-CONSING.
-#+cmu
-(deftype consing-type () '(unsigned-byte 29))
-#-cmu
-(deftype consing-type () 'unsigned-byte)
-
-
-;;;; Global data structures:
-
-(defvar *timed-functions* ()
-  "List of functions that are currently being timed.")
-
-;;; We associate a PROFILE-INFO structure with each profiled function name.
-;;; This holds the functions that we call to manipulate the closure which
-;;; implements the encapsulation.
-;;;
-(defvar *profile-info* (make-hash-table :test #'equal))
-(defstruct profile-info
-  (name nil)
-  (old-definition (error "Required keyword arg not supplied.") :type function)
-  (new-definition (error "Required keyword arg not supplied.") :type function)
-  (read-time (error "Required keyword arg not supplied.") :type function)
-  (reset-time (error "Required keyword arg not supplied.") :type function))
-
-;;; PROFILE-INFO-OR-LOSE  --  Internal
-;;;
-(defun profile-info-or-lose (name)
-  (or (gethash name *profile-info*)
-      (error "~S is not a profiled function." name)))
-
-
-;;; We keep around a bunch of functions that make encapsulations, one of each
-;;; (min-args . optional-p) signature we have encountered so far.  We also
-;;; precompute a bunch of encapsulation functions.
-;;;
-(defvar *existing-encapsulations* (make-hash-table :test #'equal))
-
-
-;;; These variables are used to subtract out the time and consing for recursive
-;;; and other dynamically nested profiled calls.  The total resource consumed
-;;; for each nested call is added into the appropriate variable.  When the
-;;; outer function returns, these amounts are subtracted from the total.
-;;;
-(defvar *enclosed-time* 0)
-(defvar *enclosed-consing* 0)
-(defvar *enclosed-profilings* 0)
-(proclaim '(type time-type *enclosed-time*))
-(proclaim '(type consing-type *enclosed-consing*))
-(proclaim '(fixnum *enclosed-profilings*))
-
-
-;;; The number of seconds a bare function call takes.  Factored into the other
-;;; overheads, but not used for itself.
-;;;
-(defvar *call-overhead*)
-
-;;; The number of seconds that will be charged to a profiled function due to
-;;; the profiling code.
-(defvar *internal-profile-overhead*)
-
-;;; The number of seconds of overhead for profiling that a single profiled call
-;;; adds to the total runtime for the program.
-;;;
-(defvar *total-profile-overhead*)
-
-(proclaim '(single-float *call-overhead* *internal-profile-overhead*
-			 *total-profile-overhead*))
-
-
-;;;; Profile encapsulations:
-
-(eval-when (compile load eval)
-
-;;; MAKE-PROFILE-ENCAPSULATION  --  Internal
-;;;
-;;;    Return a lambda expression for a function that (when called with the
-;;; function name) will set up that function for profiling.
-;;;
-;;; A function is profiled by replacing its definition with a closure created
-;;; by the following function.  The closure records the starting time, calls
-;;; the original function, and records finishing time.  Other closures are used
-;;; to perform various operations on the encapsulated function.
-;;;
-(defun make-profile-encapsulation (min-args optionals-p)
-  (let ((required-args ()))
-    (dotimes (i min-args)
-      (push (gensym) required-args))
-    `(lambda (name)
-       (let* ((time 0)
-	      (count 0)
-	      (consed 0)
-	      (profile 0)
-	      (old-definition (fdefinition name)))
-	 (declare (type time-type time) (type consing-type consed)
-		  (fixnum count))
-	 (pushnew name *timed-functions*)
-
-	 (setf (fdefinition name)
-	       #'(lambda (,@required-args
-			  ,@(if optionals-p
-				`(&rest optional-args)))
-		   (incf count)
-		   (let ((time-inc 0) (cons-inc 0) (profile-inc 0))
-		     (declare (type time-type time-inc)
-			      (type consing-type cons-inc)
-			      (fixnum profile-inc))
-		     (multiple-value-prog1
-			 (let ((start-time (quickly-get-time))
-			       (start-consed (total-consing))
-			       (*enclosed-time* 0)
-			       (*enclosed-consing* 0)
-			       (*enclosed-profilings* 0))
-			   (multiple-value-prog1
-			       ,(if optionals-p
-				    `(apply old-definition
-					    ,@required-args optional-args)
-				    `(funcall old-definition ,@required-args))
-			     (setq time-inc (- (quickly-get-time) start-time))
-			     (setq cons-inc (- (total-consing) start-consed))
-			     (setq profile-inc *enclosed-profilings*)
-			     (incf time
-				   (the time-type
-					(- time-inc *enclosed-time*)))
-			     (incf consed
-				   (the consing-type
-					(- cons-inc *enclosed-consing*)))
-			     (incf profile profile-inc)))
-		       (incf *enclosed-time* time-inc)
-		       (incf *enclosed-consing* cons-inc)
-		       (incf *enclosed-profilings*
-			     (the fixnum (1+ profile-inc)))))))
-	 
-	 (setf (gethash name *profile-info*)
-	       (make-profile-info
-		:name name
-		:old-definition old-definition
-		:new-definition (fdefinition name)
-		:read-time
-		#'(lambda ()
-		    (values count time consed profile))
-		:reset-time
-		#'(lambda ()
-		    (setq count 0)
-		    (setq time 0)
-		    (setq consed 0)
-		    (setq profile 0)
-		    t)))))))
-
-); EVAL-WHEN (COMPILE LOAD EVAL)
-
-
-;;; Precompute some encapsulation functions:
-;;;
-(eval-when (compile eval)
-  (defconstant precomputed-encapsulations 8))
-;;;
-(macrolet ((frob ()
-	     (let ((res ()))
-	       (dotimes (i precomputed-encapsulations)
-		 (push `(setf (gethash '(,i . nil) *existing-encapsulations*)
-			      #',(make-profile-encapsulation i nil))
-		       res)
-		 (push `(setf (gethash '(,i . t) *existing-encapsulations*)
-			      #',(make-profile-encapsulation i t))
-		       res))
-	       `(progn ,@res))))
-  (frob))
-
-
-
-;;; Interfaces:
-
-;;; PROFILE-1-FUNCTION  --  Internal
-;;;
-;;;    Profile the function Name.  If already profiled, unprofile first.
-;;;
-(defun profile-1-function (name)
-  (cond ((fboundp name)
-	 (when (gethash name *profile-info*)
-	   (warn "~S already profiled, so unprofiling it first." name)
-	   (unprofile-1-function name))
-	 (multiple-value-bind (min-args optionals-p)
-			      (required-arguments name)
-	   (funcall (or (gethash (cons min-args optionals-p)
-				 *existing-encapsulations*)
-			(setf (gethash (cons min-args optionals-p)
-				       *existing-encapsulations*)
-			      (compile nil (make-profile-encapsulation
-					    min-args optionals-p))))
-		    name)))
-	(t
-	 (warn "Ignoring undefined function ~S." name))))
-
-
-;;; PROFILE  --  Public
-;;;
-(defmacro profile (&rest names)
-  "PROFILE Name*
-  Wraps profiling code around the named functions.  As in TRACE, the names are
-  not evaluated.  If a function is already profiled, then unprofile and
-  reprofile (useful to notice function redefinition.)  If a name is undefined,
-  then we give a warning and ignore it.  See also UNPROFILE, REPORT-TIME and
-  RESET-TIME."
-  `(progn
-     ,@(mapcar #'(lambda (name)
-		   `(profile-1-function ',name))
-	       names)
-     (values)))
-
-
-;;; UNPROFILE  --  Public
-;;;
-(defmacro unprofile (&rest names)
-  "Unwraps the profiling code around the named functions.  Names defaults to
-  the list of all currently profiled functions."
-  `(dolist (name ,(if names `',names '*timed-functions*) (values))
-     (unprofile-1-function name)))
-
-
-;;; UNPROFILE-1-FUNCTION  --  Internal
-;;;
-(defun unprofile-1-function (name)
-  (let ((info (profile-info-or-lose name)))
-    (remhash name *profile-info*)
-    (setq *timed-functions*
-	  (delete name *timed-functions*
-		  :test #'equal))
-    (if (eq (fdefinition name) (profile-info-new-definition info))
-	(setf (fdefinition name) (profile-info-old-definition info))
-	(warn "Preserving current definition of redefined function ~S."
-	      name))))
-
-
-(defmacro report-time (&rest names)
-  "Reports the time spent in the named functions.  Names defaults to the list of
-  all currently profiled functions."
-  `(%report-times ,(if names `',names '*timed-functions*)))
-
-
-(defstruct (time-info
-	    (:constructor make-time-info (name calls time consing)))
-  name
-  calls
-  time
-  consing)
-
-
-;;; COMPENSATE-TIME  --  Internal
-;;;
-;;;    Return our best guess for the run time in a function, subtracting out
-;;; factors for profiling overhead.  We subtract out the internal overhead for
-;;; each call to this function, since the internal overhead is the part of the
-;;; profiling overhead for a function that is charged to that function.
-;;;
-;;;    We also subtract out a factor for each call to a profiled function
-;;; within this profiled function.  This factor is the total profiling overhead
-;;; *minus the internal overhead*.  We don't subtract out the internal
-;;; overhead, since it was already subtracted when the nested profiled
-;;; functions subtracted their running time from the time for the enclosing
-;;; function.
-;;;
-(defun compensate-time (calls time profile)
-  (let ((compensated
-	 (- (/ (float time) (float quick-time-units-per-second))
-	    (* *internal-profile-overhead* (float calls))
-	    (* (- *total-profile-overhead* *internal-profile-overhead*)
-	       (float profile)))))
-    (if (minusp compensated) 0.0 compensated)))
-
-
-(defun %report-times (names)
-  (unless (boundp '*call-overhead*)
-    (compute-time-overhead))
-  (let ((info ())
-	(no-call ()))
-    (dolist (name names)
-      (let ((pinfo (profile-info-or-lose name)))
-	(unless (eq (fdefinition name)
-		    (profile-info-new-definition pinfo))
-	  (warn "Function ~S has been redefined, so times may be inaccurate.~@
-	         PROFILE it again to record calls to the new definition."
-		name))
-	(multiple-value-bind
-	    (calls time consing profile)
-	    (funcall (profile-info-read-time pinfo))
-	  (if (zerop calls)
-	      (push name no-call)
-	      (push (make-time-info name calls
-				    (compensate-time calls time profile)
-				    consing)
-		    info)))))
-    
-    (setq info (sort info #'>= :key #'time-info-time))
-
-    (format *trace-output*
-	    "~&  Seconds  |  Consed   |  Calls  |  Sec/Call  |  Name:~@
-	       ------------------------------------------------------~%")
-
-    (let ((total-time 0.0)
-	  (total-consed 0)
-	  (total-calls 0))
-      (dolist (time info)
-	(incf total-time (time-info-time time))
-	(incf total-calls (time-info-calls time))
-	(incf total-consed (time-info-consing time))
-	(format *trace-output*
-		"~10,3F | ~9:D | ~7:D | ~10,5F | ~S~%"
-		(time-info-time time)
-		(time-info-consing time)
-		(time-info-calls time)
-		(/ (time-info-time time) (float (time-info-calls time)))
-		(time-info-name time)))
-      (format *trace-output*
-	      "------------------------------------------------------~@
-	      ~10,3F | ~9:D | ~7:D |            | Total~%"
-	      total-time total-consed total-calls)
-
-      (format *trace-output*
-	      "~%Estimated total profiling overhead: ~4,2F seconds~%"
-	      (* *total-profile-overhead* (float total-calls))))
-
-    (when no-call
-      (format *trace-output*
-	      "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
-	      (sort no-call #'string< :key #'symbol-name)))
-    (values)))
-
-
-(defmacro reset-time (&rest names)
-  "Resets the time counter for the named functions.  Names defaults to the list
-  of all currently profiled functions."
-  `(%reset-time ,(if names `',names '*timed-functions*)))
-
-(defun %reset-time (names)
-  (dolist (name names)
-    (funcall (profile-info-reset-time (profile-info-or-lose name))))
-  (values))
-
-
-;;;; Overhead computation.
-
-;;; We average the timing overhead over this many iterations.
-;;;
-(defconstant timer-overhead-iterations 5000)
-
-
-;;; COMPUTE-TIME-OVERHEAD-AUX  --  Internal
-;;;
-;;;    Dummy function we profile to find profiling overhead.  Declare
-;;; debug-info to make sure we have arglist info.
-;;;
-(proclaim '(notinline compute-time-overhead-aux))
-(defun compute-time-overhead-aux (x)
-  (declare (ext:optimize-interface (debug-info 2)))
-  (declare (ignore x)))
-
-
-;;; COMPUTE-TIME-OVERHEAD  --  Internal
-;;;
-;;;    Initialize the profiling overhead variables.
-;;;
-(defun compute-time-overhead ()
-  (macrolet ((frob (var)
-	       `(let ((start (quickly-get-time))
-		      (fun (symbol-function 'compute-time-overhead-aux)))
-		  (dotimes (i timer-overhead-iterations)
-		    (funcall fun fun))
-		  (setq ,var
-			(/ (float (- (quickly-get-time) start))
-			   (float quick-time-units-per-second)
-			   (float timer-overhead-iterations))))))
-    (frob *call-overhead*)
-    
-    (unwind-protect
-	(progn
-	  (profile compute-time-overhead-aux)
-	  (frob *total-profile-overhead*)
-	  (decf *total-profile-overhead* *call-overhead*)
-	  (let ((pinfo (profile-info-or-lose 'compute-time-overhead-aux)))
-	    (multiple-value-bind (calls time)
-				 (funcall (profile-info-read-time pinfo))
-	      (declare (ignore calls))
-	      (setq *internal-profile-overhead*
-		    (/ (float time)
-		       (float quick-time-units-per-second)
-		       (float timer-overhead-iterations))))))
-      (unprofile compute-time-overhead-aux))))
-
-#+cmu
-(pushnew #'(lambda ()
-	     (makunbound '*call-overhead*))
-	 ext:*before-save-initializations*)
diff --git a/code/purify.lisp b/code/purify.lisp
deleted file mode 100644
index 1ced80ba23d4b198f98583784c5f5973caba05d1..0000000000000000000000000000000000000000
--- a/code/purify.lisp
+++ /dev/null
@@ -1,41 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/purify.lisp,v 1.13 1992/03/26 03:18:51 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Storage purifier for Spice Lisp.
-;;; Written by Rob MacLachlan and Skef Wholey.
-;;;
-;;; Rewritten in C by William Lott.
-;;;
-(in-package 'lisp)
-
-(alien:def-alien-routine ("purify" %purify) c-call:void
-  (static-roots c-call:unsigned-long)
-  (read-only-roots c-call:unsigned-long))
-
-(defun purify (&key root-structures constants)
-  (let ((*gc-notify-before*
-	 #'(lambda (bytes-in-use)
-	     (declare (ignore bytes-in-use))
-	     (write-string "[Doing purification: ")
-	     (force-output)))
-	(*internal-gc*
-	 #'(lambda ()
-	     (%purify (get-lisp-obj-address root-structures)
-		      (get-lisp-obj-address constants))))
-	(*gc-notify-after*
-	 #'(lambda (&rest ignore)
-	     (declare (ignore ignore))
-	     (write-line "Done.]"))))
-    (gc t))
-  nil)
-
diff --git a/code/query.lisp b/code/query.lisp
deleted file mode 100644
index 2a5efca2fd645d730488aae75972eecbd5bff46b..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 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/query.lisp,v 1.3 1991/02/14 19:03:24 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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.
-;;;
-(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 the user enters y or Y as an affirmative, or either n or N as a
-   negative answer.  It ignores preceding whitespace and asks again if you
-   enter any other characters."
-  (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 "")
-		    #\? ;Force CASE below to issue instruction.
-		    (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 306279f2dfe91fa4eceb33ba07517d2922c80fce..0000000000000000000000000000000000000000
--- a/code/rand.lisp
+++ /dev/null
@@ -1,119 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rand.lisp,v 1.4 1991/12/14 09:01:01 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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 (1- most-positive-fixnum))
-(defconstant random-max 54)
-(defconstant %fixnum-length (integer-length most-positive-fixnum))
-(defvar rand-seed 0)
-
-(defstruct (random-state
-	    (:constructor make-random-object)
-	    (:make-load-form-fun :just-dump-it-normally))
-  (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))))
-
-
-(defvar *random-state* (make-random-object))
-
-
-;;; 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 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 (float-digits arg)))
-       (* 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 714ba23bdf3ae2fe1df49eacdaef5670037306a8..0000000000000000000000000000000000000000
--- a/code/reader.lisp
+++ /dev/null
@@ -1,1417 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.16 1992/06/04 17:03:51 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Spice Lisp Reader 
-;;; Written by David Dill
-;;; Package system interface by Lee Schumacher.
-;;; Runs in the standard Spice Lisp environment.
-;;;
-
-(in-package "EXTENSIONS")
-(export '*ignore-extra-close-parentheses*)
-
-(in-package "LISP")
-(export '(readtable readtable-case 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*
-	  reader-error))
-
-
-;;;Random global variables
-
-(defvar *read-default-float-format* 'single-float "Float format for 1.0E1")
-
-(defvar *readtable* () "Variable bound to current readtable.")
-
-
-;;;; Reader errors:
-
-(define-condition reader-error (stream-error)
-  (format-control
-   (format-arguments :init-form ()))
-  (:report
-   (lambda (condition stream)
-     (let ((error-stream (stream-error-stream condition)))
-       (format stream "Reader error ~@[at ~D ~]on ~S:~%~?"
-	       (file-position error-stream) error-stream
-	       (reader-error-format-control condition)
-	       (reader-error-format-arguments condition))))))
-
-(define-condition reader-package-error (reader-error))
-
-;;; %READ-ERROR  --  Interface
-;;;
-;;;    Like, signal a READ-ERROR, man...
-;;;
-(defun %reader-error (stream control &rest args)
-  (error 'reader-error :stream stream  :format-control control
-	 :format-arguments args))
-
-(define-condition reader-eof-error (end-of-file)
-  (context)
-  (:report
-   (lambda (condition stream)
-     (format stream "Unexpected EOF on ~S ~A."
-	     (stream-error-stream condition)
-	     (reader-eof-error-context condition)))))
-
-(defun reader-eof-error (stream context)
-  (error 'reader-eof-error :stream stream  :context context))
-  
-
-;;;; Readtable implementation.
-
-
-(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)
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (print-unreadable-object (s stream :identity t)
-		 (prin1 'readtable stream)))))
-  "Readtable is a data structure that maps characters into syntax
-   types for the Common Lisp expression reader."
-  ;; The CHARACTER-ATTRIBUTE-TABLE is a vector of CHAR-CODE-LIMIT integers for
-  ;; describing the character type.  Conceptually, there are 4 distinct
-  ;; "primary" character attributes: WHITESPACE, TERMINATING-MACRO, ESCAPE, and
-  ;; CONSTITUENT.  Non-terminating macros (such as the symbol reader) have the
-  ;; attribute CONSTITUENT.
-  ;;
-  ;; In order to make the READ-TOKEN fast, all this information is
-  ;; stored in the character attribute table by having different varieties of
-  ;; constituents.
-  (character-attribute-table (make-character-attribute-table)
-			     :type simple-vector)
-  ;;
-  ;; The CHARACTER-MACRO-TABLE is a vector of CHAR-CODE-LIMIT 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.
-  (character-macro-table (make-character-macro-table) :type simple-vector)
-  ;;
-  ;; DISPATCH-TABLES entry, which is an alist from dispatch characters to
-  ;; vectors of CHAR-CODE-LIMIT functions, for use in defining dispatching
-  ;; macros (like #-macro).
-  (dispatch-tables () :type list)
-  (readtable-case :upcase :type (member :upcase :downcase :preserve :invert)))
-
-
-;;;; 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)
-  ; 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-code ,char)))
-
-(defun set-cat-entry (char newvalue &optional (rt *readtable*))
-  (setf (elt (the simple-vector (character-attribute-table rt))
-	     (char-code char))
-	newvalue))
-
-(defmacro get-cmt-entry (char rt)
-  `(elt (the simple-vector (character-macro-table ,rt))
-	(char-code ,char)))
-
-(defun set-cmt-entry (char newvalue &optional (rt *readtable*))
-  (setf (elt (the simple-vector (character-macro-table rt))
-	     (char-code char))
-	newvalue))
-
-(defun make-character-attribute-table ()
-  (make-array char-code-limit :element-type t :initial-element #.constituent))
-
-(defun make-character-macro-table ()
-  (make-array char-code-limit :element-type t
-	      :initial-element #'undefined-macro-char))
-
-(defun undefined-macro-char (stream char)
-  (unless *read-suppress*
-    (%reader-error stream "Undefined read-macro character ~S" char)))
-
-;;; The character attribute table is a CHAR-CODE-LIMIT 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.
-
-;;; There are a number of "secondary" attributes which are constant properties
-;;; of characters characters (as long as they are constituents).
-
-(defvar secondary-attribute-table ())
-
-(defun set-secondary-attribute (char attribute)
-  (setf (elt (the simple-vector secondary-attribute-table) (char-code char))
-	attribute))
-
-
-(defun init-secondary-attribute-table ()
-  (setq secondary-attribute-table
-	(make-array char-code-limit :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-code #\0) (1+ i)))
-      ((> i (char-code #\9)))
-    (set-secondary-attribute (code-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-code ,char)))
-
-
-
-;;;; Readtable operations.
-
-(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
-  "A copy is made of from-readtable and place into to-readtable."
-  (let ((from-readtable (or from-readtable std-lisp-readtable))
-	(to-readtable (or 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."
-  (let ((from-readtable (or 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)))
-  t)
-
-(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)
-  "Returns the function associated with the specified char which is a macro
-  character.  The optional readtable argument defaults to the current
-  readtable."
-  (let ((rt (or 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-code 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 (code-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 *ignore-extra-close-parentheses* t
-  "If true, only warn when there is an extra close paren, otherwise error.")
-
-;; Alist for #=. Used to keep track of objects with labels assigned that have
-;; been completly read.  Entry is (integer-tag gensym-tag value).
-;;
-(defvar *sharp-equal-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 nil)
-					     (recursivep nil))
-  "Reads from stream and returns the object read, preserving the whitespace
-   that followed the object."
-  (cond
-   (recursivep
-    ;; Loop for repeating when a macro returns nothing.
-    (loop
-      (let ((char (read-char stream eof-errorp eof-object)))
-	(cond ((eofp char) (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)))))))))
-   (t
-    (let ((*sharp-equal-alist* nil))
-      (read-preserving-whitespace stream eof-errorp eof-value t)))))
-
-
-(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 nil 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)
-			    (%reader-error stream "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 #\) )
-	 (%reader-error stream "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)
-	  (%reader-error stream "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 (stream ignore)
-  (declare (ignore ignore))
-    (cond (*ignore-extra-close-parentheses*
-	   (warn "Ignoring unmatched close parenthesis~
-		  ~@[ at file position ~D~]."
-		 (file-position stream))
-	   (values))
-	  (t
-	   (%reader-error stream "Unmatched close parenthesis."))))
-
-;;; INTERNAL-READ-EXTENDED-TOKEN  --  Internal
-;;;
-;;; Read from the stream up to the next delimiter.  Leaves resulting token in
-;;; read-buffer, returns two values:
-;;; -- a list of the escaped character positions, and
-;;; -- The position of the first package delimiter (or NIL).
-;;;
-(defun internal-read-extended-token (stream firstchar)
-  (reset-read-buffer)
-  (do ((char firstchar (read-char stream nil eof-object))
-       (escapes ())
-       (colon nil))
-      ((cond ((eofp char) t)
-	     ((token-delimiterp char)
-	      (unread-char char stream)
-	      t)
-	     (t nil))
-       (values escapes colon))
-    (cond ((escapep char)
-	   ;;it can't be a number, even if it's 1\23.
-	   ;;read next char here, so it won't be casified.
-	   (push ouch-ptr escapes)
-	   (let ((nextchar (read-char stream nil eof-object)))
-	     (if (eofp nextchar)
-		 (reader-eof-error stream "after escape character")
-		 (ouch-read-buffer nextchar))))
-	  ((multiple-escape-p char)
-	   ;; read to next multiple-escape, escaping single chars along
-	   ;; the way
-	   (loop
-	     (let ((ch (read-char stream nil eof-object)))
-	       (cond
-		((eofp ch)
-		 (reader-eof-error stream "inside extended token"))
-		((multiple-escape-p ch) (return))
-		((escapep ch)
-		 (let ((nextchar (read-char stream nil eof-object)))
-		   (if (eofp nextchar)
-		       (reader-eof-error stream "after escape character")
-		       (ouch-read-buffer nextchar))))
-		(t
-		 (push ouch-ptr escapes)
-		 (ouch-read-buffer ch))))))
-	  (t
-	   (when (and (constituentp char)
-		      (eql (get-secondary-attribute char) #.package-delimiter)
-		      (not colon))
-	     (setq colon ouch-ptr))
-	   (ouch-read-buffer char)))))
-
-
-;;;; Character classes.
-
-;;; return the character class for a char
-;;;
-(defmacro char-class (char attable)
-  `(let ((att (svref ,attable (char-code ,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-code ,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-code ,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.
-
-(defvar *read-suppress* nil 
-  "Suppresses most interpreting of the reader when T")
-
-(defvar *read-base* 10
-  "The radix that Lisp reads numbers in.")
-
-
-;;; CASIFY-READ-BUFFER  --  Internal
-;;;
-;;;    Modify the read-buffer according to READTABLE-CASE, ignoring escapes.
-;;; ESCAPES is a list of the escaped indices, in reverse order. 
-;;;
-(defun casify-read-buffer (escapes)
-  (let ((case (readtable-case *readtable*)))
-    (cond
-     ((and (null escapes) (eq case :upcase))
-      (dotimes (i ouch-ptr)
-	(setf (schar read-buffer i) (char-upcase (schar read-buffer i)))))
-     ((eq case :preserve))
-     (t
-      (macrolet ((skip-esc (&body body)
-		   `(do ((i (1- ouch-ptr) (1- i))
-			 (escapes escapes))
-			((minusp i))
-		      (declare (fixnum i))
-		      (when (or (null escapes)
-				(let ((esc (first escapes)))
-				  (declare (fixnum esc))
-				  (cond ((< esc i) t)
-					(t
-					 (assert (= esc i))
-					 (pop escapes)
-					 nil))))
-			(let ((ch (schar read-buffer i)))
-			  ,@body)))))
-	(flet ((lower-em ()
-		 (skip-esc (setf (schar read-buffer i) (char-downcase ch))))
-	       (raise-em ()
-		 (skip-esc (setf (schar read-buffer i) (char-upcase ch)))))
-	  (ecase case
-	    (:upcase (raise-em))
-	    (:downcase (lower-em))
-	    (:invert
-	     (let ((all-upper t)
-		   (all-lower t))
-	       (skip-esc
-		 (when (both-case-p ch)
-		   (if (upper-case-p ch)
-		       (setq all-lower nil)
-		       (setq all-upper nil))))
-	       (cond (all-lower (raise-em))
-		     (all-upper (lower-em))))))))))))
-  
-(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).
-  (when *read-suppress*
-    (internal-read-extended-token stream firstchar)
-    (return-from read-token nil))
-  (let ((attribute-table (character-attribute-table *readtable*))
-	(package nil)
-	(colons 0)
-	(possibly-rational t)
-	(possibly-float t)
-	(escapes ()))
-    (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)
-      (setq char (read-char stream nil nil))
-      (unless char (return (make-integer stream)))
-      (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 stream)))
-	(#.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 stream))))
-      (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 stream))))
-	(#.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 (%reader-error stream "Dot context error."))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go RIGHTDIGIT))
-	(#.constituent-dot (go DOTS))
-	(#.delimiter  (%reader-error stream "Dot context error."))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-     EXPONENT
-      (ouch-read-buffer 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)
-      (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 (%reader-error stream "Too many dots."))
-      (case (char-class char attribute-table)
-	(#.constituent-dot (go DOTS))
-	(#.delimiter
-	 (unread-char char stream)
-	 (%reader-error stream "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)
-	  (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)))
-	(unless nextchar
-	  (reader-eof-error stream "after escape character"))
-	(push ouch-ptr escapes)
-	(ouch-read-buffer nextchar))
-      (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)))
-	(push ouch-ptr escapes)
-	(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
-      (casify-read-buffer escapes)
-      (unless (zerop colons)
-	(%reader-error stream "Too many colons in ~S"
-		      (read-buffer-to-string)))
-      (setq colons 1)
-      (setq package (read-buffer-to-string))
-
-      (reset-read-buffer)
-      (setq escapes ())
-      (setq char (read-char stream nil nil))
-      (unless char (reader-eof-error stream "after reading a colon"))
-      (case (char-class char attribute-table)
-	(#.delimiter
-	 (unread-char char stream)
-	 (%reader-error stream "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
-	(reader-eof-error stream "after reading a colon"))
-      (case (char-class char attribute-table)
-	(#.delimiter
-	 (unread-char char stream)
-	 (%reader-error stream "Illegal terminating character after a colon, ~S"
-		       char))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter
-	 (%reader-error stream "To many colons after ~S:" package))
-	(t (go SYMBOL)))
-      RETURN-SYMBOL
-      (casify-read-buffer escapes)
-      (let ((found (if package (find-package package) *package*)))
-	(unless found
-	  (error 'reader-package-error :stream stream
-		 :format-arguments (list package)
-		 :format-control "Package ~S not found."))
-
-	(if (or (zerop colons) (= colons 2) (eq found *keyword-package*))
-	    (return (intern* read-buffer ouch-ptr found))
-	    (multiple-value-bind (symbol test)
-				 (find-symbol* read-buffer ouch-ptr found)
-	      (when (eq test :external) (return symbol))
-	      (let ((name (read-buffer-to-string)))
-		(with-simple-restart (continue "Use symbol anyway.")
-		  (error 'reader-package-error :stream stream
-			 :format-arguments (list name (package-name found))
-			 :format-control
-			 (if test
-			     "The symbol ~S is not external in the ~A package."
-			     "Symbol ~S not found in the ~A package.")))
-		(return (intern name found)))))))))
-
-
-(defun read-extended-token (stream &optional (*readtable* *readtable*))
-  "For semi-external use: returns 3 values: the string for the token,
-   a flag for whether there was an escape char, and the position of any
-   package delimiter."
-  (let ((firstch (read-char stream nil nil t)))
-    (cond (firstch
-	   (multiple-value-bind (escapes colon)
-				(internal-read-extended-token stream firstch)
-	     (casify-read-buffer escapes)
-	     (values (read-buffer-to-string) (not (null escapes)) colon)))
-	  (t
-	   (values "" nil 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 (stream)
-  "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*
-		      (%reader-error stream "~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 (char-upcase 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)
-  (coerce (/ number divisor) 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 char-code-limit :initial-element #'dispatch-char-error))
-
-(defun dispatch-char-error (stream sub-char ignore)
-  (declare (ignore ignore))
-  (if *read-suppress*
-      (values)
-      (%reader-error stream "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.
-  (when (digit-char-p sub-char)
-    (error "Sub-Char must not be a decibal digit: ~S" sub-char))
-  (let* ((sub-char (char-upcase sub-char))
-	 (dpair (find disp-char (dispatch-tables rt)
-		      :test #'char= :key #'car)))
-    (if dpair
-	(setf (elt (the simple-vector (cdr dpair))
-		   (char-code sub-char))
-	      function)
-	(error "~S is not a dispatch char." disp-char))))
-
-(defun get-dispatch-macro-character (disp-char sub-char &optional rt)
-  "Returns the macro character function for sub-char under disp-char
-   or nil if there is no associated function."
-  (unless (digit-char-p sub-char)
-    (let* ((sub-char (char-upcase sub-char))
-	   (rt (or rt *readtable*))
-	   (dpair (find disp-char (dispatch-tables rt)
-			:test #'char= :key #'car)))
-      (if dpair
-	  (elt (the simple-vector (cdr dpair))
-	       (char-code 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)
-	      (reader-eof-error stream "inside dispatch character")
-	      (setq sub-char (char-upcase 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-code sub-char))
-		   stream sub-char (if numargp numarg nil))
-	  (%reader-error stream "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
-				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))
-  (with-array-data ((string string)
-		    (start start)
-		    (end (or 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) 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 (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."
-  (with-array-data ((string string)
-		    (start start)
-		    (end (or 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 8cbcdb4390cd3ddca2eba6fb03a64ec0b95e0e47..0000000000000000000000000000000000000000
--- a/code/remote.lisp
+++ /dev/null
@@ -1,367 +0,0 @@
-;;; -*- Log: code.log; Package: wire -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/remote.lisp,v 1.4 1992/12/08 20:05:17 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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))
-		     (unix: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))
-  (print-unreadable-object (rs stream :type t)
-    (format stream "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/rt-machdef.lisp b/code/rt-machdef.lisp
deleted file mode 100644
index f858194598871df137b33bd67d3b637df78d2c90..0000000000000000000000000000000000000000
--- a/code/rt-machdef.lisp
+++ /dev/null
@@ -1,36 +0,0 @@
-;;; -*- Log: code.log; Package: Mach -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rt-machdef.lisp,v 1.3 1991/07/22 23:54:55 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Record definitions needed for the interface to Mach.
-;;;
-(in-package "MACH")
-
-(export '(sigcontext-onstack sigcontext-mask sigcontext-sp sigcontext-fp
-	  sigcontext-ap sigcontext-iar sigcontext-icscs sigcontext-saveiar
-	  sigcontext-regs sigcontext *sigcontext indirect-*sigcontext
-	  sigcontext-pc))
-
-(def-c-record sigcontext
-  (onstack unsigned-long)
-  (mask unsigned-long)
-  (floatsave system-area-pointer)
-  (sp system-area-pointer)
-  (fp system-area-pointer)
-  (ap system-area-pointer)
-  (iar system-area-pointer)
-  (icscs unsigned-long)
-  (saveiar system-area-pointer)
-  (regs int-array))
-
-(defoperator (sigcontext-pc system-area-pointer) ((x sigcontext))
-  `(sigcontext-iar (alien-value ,x)))
diff --git a/code/rt-vm.lisp b/code/rt-vm.lisp
deleted file mode 100644
index a69caa9cfedb1f71164530d8eb39683a66d48e9a..0000000000000000000000000000000000000000
--- a/code/rt-vm.lisp
+++ /dev/null
@@ -1,183 +0,0 @@
-;;; -*- Package: RT -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rt-vm.lisp,v 1.6 1992/03/10 10:21:34 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the RT specific runtime stuff.
-;;;
-(in-package "RT")
-(use-package "SYSTEM")
-(use-package "ALIEN")
-(use-package "C-CALL")
-(use-package "UNIX")
-
-(export '(fixup-code-object internal-error-arguments
-	  sigcontext-register sigcontext-float-register
-	  sigcontext-floating-point-modes extern-alien-name))
-
-
-;;;; The sigcontext structure.
-
-(def-alien-type sigcontext
-  (struct nil
-    (sc-onstack unsigned-long)
-    (sc-mask unsigned-long)
-    (sc-floatsave system-area-pointer)
-    (sc-sp system-area-pointer)
-    (sc-fp system-area-pointer)
-    (sc-ap system-area-pointer)
-    (sc-pc system-area-pointer) ; IBM calls it the iar.
-    (sc-icscs unsigned-long)
-    (sc-saveiar system-area-pointer)
-    (sc-regs (array unsigned-long 16))))
-
-
-
-;;;; Add machine specific features to *features*
-
-(pushnew :ibm-pc-rt *features*)
-(pushnew :ibmrt *features*)
-(pushnew :rt *features*)
-
-
-
-;;;; MACHINE-TYPE and MACHINE-VERSION
-
-(defun machine-type ()
-  "Returns a string describing the type of the local machine."
-  "IBM PC/RT")
-
-(defun machine-version ()
-  "Returns a string describing the version of the local machine."
-  "IBM PC/RT")
-
-
-
-;;; FIXUP-CODE-OBJECT -- Interface
-;;;
-(defun fixup-code-object (code offset fixup kind)
-  (declare (type index offset) (type (unsigned-byte 32) fixup))
-  (system:without-gcing
-   (let ((sap (sap+ (kernel:code-instructions code) offset)))
-     (ecase kind
-       (:cal
-	(setf (sap-ref-16 sap 2)
-	      (ldb (byte 16 0) fixup)))
-       (:cau
-	(let ((high (ldb (byte 16 16) fixup)))
-	  (setf (sap-ref-16 sap 2)
-		(if (logbitp 15 fixup) (1+ high) high))))
-       (:ba
-	(unless (zerop (ash fixup -24))
-	  (warn "#x~8,'0X out of range for branch-absolute." fixup))
-	(setf (sap-ref-8 sap 1)
-	      (ldb (byte 8 16) fixup))
-	(setf (sap-ref-16 sap 2)
-	      (ldb (byte 16 0) fixup)))))))
-
-
-
-;;;; Internal-error-arguments.
-
-;;; INTERNAL-ERROR-ARGUMENTS -- interface.
-;;;
-;;; Given the sigcontext, extract the internal error arguments from the
-;;; instruction stream.
-;;; 
-(defun internal-error-arguments (scp)
-  (with-alien ((scp (* sigcontext) scp))
-    (let ((pc (slot scp 'sc-pc)))
-      (declare (type system-area-pointer pc))
-      (let* ((length (sap-ref-8 pc 4))
-	     (vector (make-array length :element-type '(unsigned-byte 8))))
-	(declare (type (unsigned-byte 8) length)
-		 (type (simple-array (unsigned-byte 8) (*)) vector))
-	(copy-from-system-area pc (* vm:byte-bits 5)
-			       vector (* vm:word-bits
-					 vm:vector-data-offset)
-			       (* length vm:byte-bits))
-	(let* ((index 0)
-	       (error-number (c::read-var-integer vector index)))
-	  (collect ((sc-offsets))
-	    (loop
-	      (when (>= index length)
-		(return))
-	      (sc-offsets (c::read-var-integer vector index)))
-	    (values error-number (sc-offsets))))))))
-
-
-
-;;;; Sigcontext accessing stuff.
-
-;;; SIGCONTEXT-REGISTER -- Internal.
-;;;
-;;; An escape register saves the value of a register for a frame that someone
-;;; interrupts.  
-;;;
-(defun sigcontext-register (scp index)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (deref (slot scp 'sc-regs) index)))
-
-(defun %set-sigcontext-register (scp index new)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (setf (deref (slot scp 'sc-regs) index) new)
-    new))
-
-(defsetf sigcontext-register %set-sigcontext-register)
-
-
-;;; SIGCONTEXT-FLOAT-REGISTER  --  Internal
-;;;
-;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
-;;; Format is the type of float to return.
-;;;
-(defun sigcontext-float-register (scp index format)
-  (declare (type (alien (* sigcontext)) scp)
-	   (ignore scp index))
-  ;; ### Some day we should figure out how to do this right.
-  (ecase format
-    (single-float 0.0s0)
-    (double-float 0.0d0)))
-;;;
-(defun %set-sigcontext-float-register (scp index format new-value)
-  (declare (type (alien (* sigcontext)) scp)
-	   (ignore scp index format))
-  ;; ### Some day we should figure out how to do this right.
-  new-value)
-;;;
-(defsetf sigcontext-float-register %set-sigcontext-float-register)
-
-
-;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
-;;;
-;;;    Given a sigcontext pointer, return the floating point modes word in the
-;;; same format as returned by FLOATING-POINT-MODES.
-;;;
-(defun sigcontext-floating-point-modes (scp)
-  (declare (ignore scp))
-  ;; ### Some day we should figure out how to do this right.
-  0)
-
-
-
-
-;;; EXTERN-ALIEN-NAME -- interface.
-;;;
-;;; The loader uses this to convert alien names to the form they occure in
-;;; the symbol table (for example, prepending an underscore).  On the RT,
-;;; we prepend an underscore.
-;;; 
-(defun extern-alien-name (name)
-  (declare (type simple-base-string name))
-  (concatenate 'string "_" name))
-
diff --git a/code/run-program.lisp b/code/run-program.lisp
deleted file mode 100644
index c5caaba9a82f90e0d52eabb017b778f9a77dc484..0000000000000000000000000000000000000000
--- a/code/run-program.lisp
+++ /dev/null
@@ -1,668 +0,0 @@
-;;; -*- Package: Extensions; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/run-program.lisp,v 1.12 1992/07/28 00:22:58 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; RUN-PROGRAM and friends.  Facility 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.
-
-(alien:def-alien-routine ("wait3" c-wait3) c-call:int
-  (status c-call:int :out)
-  (options c-call:int)
-  (rusage c-call: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 unix:sigstop)
-			     (eql signal unix:sigtstp)
-			     (eql signal unix:sigttin)
-			     (eql signal unix: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.
-  cookie		    ; List of the number of pipes from the subproc.
-  )
-
-(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
-    (case (process-status proc)
-      (:running)
-      (:stopped
-       (when check-for-stopped
-	 (return)))
-      (t
-       (when (zerop (car (process-cookie proc)))
-	 (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)
-  (alien:with-alien ((result c-call:int))
-    (multiple-value-bind
-	(wonp error)
-	(unix:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))
-			 unix:TIOCGPGRP
-			 (alien:alien-sap (alien:addr result)))
-      (unless wonp
-	(error "TIOCPGRP ioctl failed: ~S"
-	       (unix:get-unix-error-msg error)))
-      result)))
-
-;;; 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)
-			   (unix:unix-killpg pid signal)
-			   (unix:unix-kill pid signal))
-      (cond ((not okay)
-	     (values nil errno))
-	    ((and (eql pid (process-pid proc))
-		  (= (unix:unix-signal-number signal) unix: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 is the handler for sigchld signals that RUN-PROGRAM establishes.
-;;;
-(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 (unix:unix-open master-name
-					unix:o_rdwr
-					#o666)))
-	(when master-fd
-	  (let* ((slave-name (format nil "/dev/tty~C~X" char digit))
-		 (slave-fd (unix:unix-open slave-name
-					   unix:o_rdwr
-					   #o666)))
-	    (when slave-fd
-	      ; Maybe put a vhangup here?
-	      (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
-		(let ((sap (alien:alien-sap stuff)))
-		  (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
-		  (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
-		  (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
-		  (unix:unix-ioctl master-fd unix:TIOCGETP sap)
-		  (setf (alien:slot stuff 'unix:sg-flags)
-			(logand (alien:slot stuff 'unix:sg-flags)
-				(lognot 8))) ; ~ECHO
-		  (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
-	      (return-from find-a-pty
-			   (values master-fd
-				   slave-fd
-				   slave-name)))
-	  (unix:unix-close master-fd))))))
-  (error "Could not find a pty."))
-
-;;; OPEN-PTY -- internal
-;;;
-(defun open-pty (pty cookie)
-  (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 (new-fd errno) (unix:unix-dup master)
-	  (unless new-fd
-	    (error "Could not UNIX:UNIX-DUP ~D: ~A"
-		   master (unix:get-unix-error-msg errno)))
-	  (push new-fd *close-on-error*)
-	  (copy-descriptor-to-stream new-fd pty cookie)))
-      (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))
-				(unix:unix-exit 2))))
-	;; Put us in our own pgrp.
-	(unix:unix-setpgrp 0 (unix:unix-getpid))
-	;; If we want a pty, set it up.
-	(when pty-name
-	  (let ((old-tty (unix:unix-open "/dev/tty" unix:o_rdwr 0)))
-	    (when old-tty
-	      (unix:unix-ioctl old-tty unix:TIOCNOTTY nil)
-	      (unix:unix-close old-tty)))
-	  (let ((new-tty (unix:unix-open pty-name unix:o_rdwr 0)))
-	    (when new-tty
-	      (unix:unix-dup2 new-tty 0)
-	      (unix:unix-dup2 new-tty 1)
-	      (unix:unix-dup2 new-tty 2))))
-	;; Setup the three standard descriptors.
-	(when stdin
-	  (unix:unix-dup2 stdin 0))
-	(when stdout
-	  (unix:unix-dup2 stdout 1))
-	(when stderr
-	  (unix:unix-dup2 stderr 2))
-	;; Arange for all the unused FD's to be closed.
-	(do ((fd (1- (unix:unix-getdtablesize))
-		 (1- fd)))
-	    ((= fd 3))
-	  (unix:unix-fcntl fd unix:f-setfd 1))
-	;; Do the before-execve
-	(when before-execve
-	  (funcall before-execve))
-	;; Exec the program
-	(multiple-value-bind
-	    (okay errno)
-	    (unix:unix-execve pfile args env)
-	  (declare (ignore okay))
-	  ;; If the magic number if bogus, try just a shell script.
-	  (when (eql errno unix:ENOEXEC)
-	    (unix:unix-execve "/bin/sh" (cons pfile args) env))))
-    ;; If exec returns, we lose.
-    (unix: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 specified 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 specified 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
-	specified 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 unix: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:"))))
-	      (cookie (list 0)))
-	  (multiple-value-bind
-	      (stdin input-stream)
-	      (get-descriptor-for input cookie :direction :input
-				  :if-does-not-exist if-input-does-not-exist)
-	    (multiple-value-bind
-		(stdout output-stream)
-		(get-descriptor-for output cookie :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 cookie :direction :output
-					  :if-exists if-error-exists))
-		(multiple-value-bind (pty-name pty-stream)
-				     (open-pty pty cookie)
-		  ;; 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)
-			(unix:unix-fork)
-		      (cond ((null child-pid)
-			     ;; This should only happen if the bozo has too
-			     ;; many running procs.
-			     (error "Could not fork child process: ~A"
-				    (unix:get-unix-error-msg errno)))
-			    ((zerop child-pid)
-			     ;; We are the child. Note: setup-child NEVER
-			     ;; returns
-			     (setup-child pfile args env stdin stdout stderr
-					  pty-name before-execve))
-			    (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
-						      :cookie cookie))
-			     (push proc *active-processes*))))))))))
-      (dolist (fd *close-in-parent*)
-	(unix:unix-close fd))
-      (unless proc
-	(dolist (fd *close-on-error*)
-	  (unix: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 cookie)
-  (incf (car cookie))
-  (let ((string (make-string 256))
-	handler)
-    (setf handler
-	  (system:add-fd-handler descriptor :input
-	    #'(lambda (fd)
-		(declare (ignore fd))
-		(loop
-		  (unless handler
-		    (return))
-		  (multiple-value-bind
-		      (result readable/errno)
-		      (unix:unix-select (1+ descriptor) (ash 1 descriptor)
-					0 0 0)
-		    (cond ((null result)
-			   (error "Could not select on sub-process: ~A"
-				  (unix:get-unix-error-msg readable/errno)))
-			  ((zerop result)
-			   (return))))
-		  (alien:with-alien ((buf (alien:array c-call:char 256)))
-		    (multiple-value-bind
-			(count errno)
-			(unix:unix-read descriptor (alien-sap buf) 256)
-		      (cond ((or (and (null count)
-				      (eql errno unix:eio))
-				 (eql count 0))
-			     (system:remove-fd-handler handler)
-			     (setf handler nil)
-			     (decf (car cookie))
-			     (unix:unix-close descriptor)
-			     (return))
-			    ((null count)
-			     (system:remove-fd-handler handler)
-			     (setf handler nil)
-			     (decf (car cookie))
-			     (error "Could not read input from sub-process: ~A"
-				    (unix:get-unix-error-msg errno)))
-			    (t
-			     (kernel:copy-from-system-area
-			      (alien-sap buf) 0
-			      string (* vm:vector-data-offset vm:word-bits)
-			      (* count vm:byte-bits))
-			     (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 cookie &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)
-	     (unix:unix-open "/dev/null"
-			     (case direction
-			       (:input unix:o_rdonly)
-			       (:output unix:o_wronly)
-			       (t unix:o_rdwr))
-			     #o666)
-	   (unless fd
-	     (error "Could not open \"/dev/null\": ~A"
-		    (unix:get-unix-error-msg errno)))
-	   (push fd *close-in-parent*)
-	   (values fd nil)))
-	((eq object :stream)
-	 (multiple-value-bind
-	     (read-fd write-fd)
-	     (unix:unix-pipe)
-	   (unless read-fd
-	     (error "Could not create pipe: ~A"
-		    (unix: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
-	      (unix:unix-close read-fd)
-	      (unix:unix-close write-fd)
-	      (error "Direction must be either :INPUT or :OUTPUT, not ~S"
-		     direction)))))
-	((or (pathnamep object) (stringp object))
-	 (with-open-stream (file (apply #'open object keys))
-	   (multiple-value-bind
-	       (fd errno)
-	       (unix:unix-dup (system:fd-stream-fd file))
-	     (cond (fd
-		    (push fd *close-in-parent*)
-		    (values fd nil))
-		   (t
-		    (error "Could not duplicate file descriptor: ~A"
-			   (unix:get-unix-error-msg errno)))))))
-	((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 (unix:unix-open name
-					 (logior unix:o_rdwr
-						 unix:o_creat
-						 unix:o_excl)
-					 #o666)))
-		(unix:unix-unlink name)
-		(when fd
-		  (let ((newline (string #\Newline)))
-		    (loop
-		      (multiple-value-bind
-			  (line no-cr)
-			  (read-line object nil nil)
-			(unless line
-			  (return))
-			(unix:unix-write fd line 0 (length line))
-			(if no-cr
-			  (return)
-			  (unix:unix-write fd newline 0 1)))))
-		  (unix:unix-lseek fd 0 unix:l_set)
-		  (push fd *close-in-parent*)
-		  (return (values fd nil))))))
-	   (:output
-	    (multiple-value-bind (read-fd write-fd)
-				 (unix:unix-pipe)
-	      (unless read-fd
-		(error "Cound not create pipe: ~A"
-		       (unix:get-unix-error-msg write-fd)))
-	      (copy-descriptor-to-stream read-fd object cookie)
-	      (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/sap.lisp b/code/sap.lisp
deleted file mode 100644
index 2884874632612e4bd76b3712a022f6bcbc5373a4..0000000000000000000000000000000000000000
--- a/code/sap.lisp
+++ /dev/null
@@ -1,214 +0,0 @@
-;;; -*- Package: SYSTEM -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sap.lisp,v 1.9 1992/03/02 02:23:17 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file holds the support for System Area Pointers (saps).
-;;;
-(in-package "SYSTEM")
-
-(export '(system-area-pointer sap-ref-8 sap-ref-16 sap-ref-32 sap-ref-sap
-	  signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32
-	  sap+ sap- sap< sap<= sap= sap>= sap>
-	  allocate-system-memory allocate-system-memory-at
-	  reallocate-system-memory deallocate-system-memory))
-
-(in-package "KERNEL")
-(export '(%set-sap-ref-sap %set-sap-ref-single %set-sap-ref-double
-	  %set-sap-ref-8 %set-signed-sap-ref-8
-	  %set-sap-ref-16 %set-signed-sap-ref-16
-	  %set-sap-ref-32 %set-signed-sap-ref-32))
-(in-package "SYSTEM")
-
-(use-package "KERNEL")
-
-
-
-;;;; Primitive SAP operations.
-
-(defun sap< (x y)
-  "Return T iff the SAP X points to a smaller address then the SAP Y."
-  (declare (type system-area-pointer x y))
-  (sap< x y))
-
-(defun sap<= (x y)
-  "Return T iff the SAP X points to a smaller or the same address as
-   the SAP Y."
-  (declare (type system-area-pointer x y))
-  (sap<= x y))
-
-(defun sap= (x y)
-  "Return T iff the SAP X points to the same address as the SAP Y."
-  (declare (type system-area-pointer x y))
-  (sap= x y))
-
-(defun sap>= (x y)
-  "Return T iff the SAP X points to a larger or the same address as
-   the SAP Y."
-  (declare (type system-area-pointer x y))
-  (sap>= x y))
-
-(defun sap> (x y)
-  "Return T iff the SAP X points to a larger address then the SAP Y."
-  (declare (type system-area-pointer x y))
-  (sap> x y))
-
-(defun sap+ (sap offset)
-  "Return a new sap OFFSET bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (fixnum offset))
-  (sap+ sap offset))
-
-(defun sap- (sap1 sap2)
-  "Return the byte offset between SAP1 and SAP2."
-  (declare (type system-area-pointer sap1 sap2))
-  (sap- sap1 sap2))
-
-(defun sap-int (sap)
-  "Converts a System Area Pointer into an integer."
-  (declare (type system-area-pointer sap))
-  (sap-int sap))
-
-(defun int-sap (int)
-  "Converts an integer into a System Area Pointer."
-  (declare (type (unsigned-byte #.vm:word-bits) int))
-  (int-sap int))
-
-(defun sap-ref-8 (sap offset)
-  "Returns the 8-bit byte at OFFSET bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (sap-ref-8 sap offset))
-
-(defun sap-ref-16 (sap offset)
-  "Returns the 16-bit word at OFFSET bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (sap-ref-16 sap offset))
-
-(defun sap-ref-32 (sap offset)
-  "Returns the 32-bit dualword at OFFSET bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (sap-ref-32 sap offset))
-
-(defun sap-ref-sap (sap offset)
-  "Returns the 32-bit system-area-pointer at OFFSET bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (sap-ref-sap sap offset))
-
-(defun sap-ref-single (sap offset)
-  "Returns the 32-bit single-float at OFFSET bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (sap-ref-single sap offset))
-
-(defun sap-ref-double (sap offset)
-  "Returns the 64-bit double-float at OFFSET bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (sap-ref-double sap offset))
-
-(defun signed-sap-ref-8 (sap offset)
-  "Returns the signed 8-bit byte at OFFSET bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (signed-sap-ref-8 sap offset))
-
-(defun signed-sap-ref-16 (sap offset)
-  "Returns the signed 16-bit word at OFFSET bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (signed-sap-ref-16 sap offset))
-
-(defun signed-sap-ref-32 (sap offset)
-  "Returns the signed 32-bit dualword at OFFSET bytes from SAP."
-  (declare (type system-area-pointer sap)
-	   (type index offset))
-  (signed-sap-ref-32 sap offset))
-
-(defun %set-sap-ref-8 (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type (unsigned-byte 8) new-value))
-  (setf (sap-ref-8 sap offset) new-value))
-
-(defun %set-sap-ref-16 (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type (unsigned-byte 16) new-value))
-  (setf (sap-ref-16 sap offset) new-value))
-
-(defun %set-sap-ref-32 (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type (unsigned-byte 32) new-value))
-  (setf (sap-ref-32 sap offset) new-value))
-
-(defun %set-signed-sap-ref-8 (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type (signed-byte 8) new-value))
-  (setf (signed-sap-ref-8 sap offset) new-value))
-
-(defun %set-signed-sap-ref-16 (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type (signed-byte 16) new-value))
-  (setf (signed-sap-ref-16 sap offset) new-value))
-
-(defun %set-signed-sap-ref-32 (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type (signed-byte 32) new-value))
-  (setf (signed-sap-ref-32 sap offset) new-value))
-
-(defun %set-sap-ref-sap (sap offset new-value)
-  (declare (type system-area-pointer sap new-value)
-	   (type index offset))
-  (setf (sap-ref-sap sap offset) new-value))
-
-(defun %set-sap-ref-single (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type single-float new-value))
-  (setf (sap-ref-single sap offset) new-value))
-
-(defun %set-sap-ref-double (sap offset new-value)
-  (declare (type system-area-pointer sap)
-	   (type index offset)
-	   (type double-float new-value))
-  (setf (sap-ref-double sap offset) new-value))
-
-
-
-;;;; System memory allocation.
-
-(alien:def-alien-routine ("os_allocate" allocate-system-memory)
-			 system-area-pointer
-  (bytes c-call:unsigned-long))
-
-(alien:def-alien-routine ("os_allocate_at" allocate-system-memory-at)
-			 system-area-pointer
-  (address system-area-pointer)
-  (bytes c-call:unsigned-long))
-
-(alien:def-alien-routine ("os_reallocate" reallocate-system-memory)
-			 system-area-pointer
-  (old system-area-pointer)
-  (old-size c-call:unsigned-long)
-  (new-size c-call:unsigned-long))
-
-(alien:def-alien-routine ("os_deallocate" deallocate-system-memory)
-			 c-call:void
-  (addr system-area-pointer)
-  (bytes c-call:unsigned-long))
diff --git a/code/save.lisp b/code/save.lisp
deleted file mode 100644
index b77807accee8cc35692f91b696257487fe645cba..0000000000000000000000000000000000000000
--- a/code/save.lisp
+++ /dev/null
@@ -1,237 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.16 1992/08/06 01:44:17 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Dump the current lisp image into a core file.  All the real work is done
-;;; be C.  Also contains various high-level initialization stuff: loading init
-;;; files and parsing environment variables.
-;;;
-;;; Written by William Lott.
-;;; 
-;;;
-(in-package "LISP")
-
-(in-package "EXTENSIONS")
-(export '(print-herald *herald-items* save-lisp *before-save-initializations*
-	  *after-save-initializations* *environment-list* *editor-lisp-p*))
-(in-package "LISP")
-
-(defvar *before-save-initializations* nil
-  "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* nil
-  "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.")
-
-(defvar *environment-list* nil
-  "An alist mapping environment variables (as keywords) to either values")
-
-(defvar *editor-lisp-p* nil
-  "This is true if and only if the lisp was started with the -edit switch.")
-
-
-
-;;; Filled in by the startup code.
-(defvar lisp-environment-list)
-
-
-(alien:def-alien-routine "save" (alien:boolean)
-  (file c-call:c-string))
-
-
-;;; PARSE-UNIX-SEARCH-LIST  --  Internal
-;;;
-;;; Returns a list of the directories that are in the specified Unix
-;;; environment variable.  Return NIL if the variable is undefined.
-;;;
-(defun parse-unix-search-list (var)
-  (let ((path (cdr (assoc var 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)))))))
-
-
-;;; ENVIRONMENT-INIT  --  Internal
-;;;
-;;;    Parse the LISP-ENVIRONMENT-LIST into a keyword alist.  Set up default
-;;; search lists.
-;;;
-(defun environment-init ()
-  (setq *environment-list* ())
-  (dolist (ele lisp-environment-list)
-    (let ((=pos (position #\= (the simple-string ele))))
-      (when =pos
-	(push (cons (intern (string-upcase (subseq ele 0 =pos))
-			    *keyword-package*)
-		    (subseq ele (1+ =pos)))
-	      *environment-list*))))
-  (setf (search-list "default:") (list (default-directory)))
-  (setf (search-list "path:") (parse-unix-search-list :path))
-  (setf (search-list "home:")
-	(or (parse-unix-search-list :home)
-	    (list (default-directory))))
-
-  (setf (search-list "library:")
-	(or (parse-unix-search-list :cmucllib)
-	    '("/usr/misc/.cmucl/lib/"))))
-
-(defun save-lisp (core-file-name &key
-				 (purify t)
-				 (root-structures ())
-				 (constants nil)
-				 (init-function
-				  #'(lambda ()
-				      (throw 'top-level-catcher nil)))
-				 (load-init-file t)
-				 (site-init "library:site-init")
-				 (print-herald t)
-				 (process-command-line t))
-  "Saves a CMU Common 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
-  :constants
-      These should be a list of the main entry points in any newly loaded
-  systems and a list of any large data structures that will never again
-  be changed.  These need not be supplied, but locality and/or GC performance
-  will be better if they are.  They are 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.
-
-  :site-init
-      If true, then the name of the site init file to load.  The default is
-      library:site-init.  No error if this does not exist.
-
-  :print-herald
-      If true, print out the lisp system herald when starting."
-
-  (when (fboundp 'eval:flush-interpreted-function-cache)
-    (eval:flush-interpreted-function-cache))
-  (if purify
-      (purify :root-structures root-structures :constants constants)
-      (gc))
-  (unless (save (unix-namestring core-file-name nil))
-    (reinit)
-    (dolist (f *before-save-initializations*) (funcall f))
-    (dolist (f *after-save-initializations*) (funcall f))
-    (environment-init)
-    (when site-init (load site-init :if-does-not-exist nil :verbose nil))
-    (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 (and cl-switch
-			  (or (cmd-switch-value cl-switch)
-			      (car (cmd-switch-words cl-switch))))))
-	  (if name
-	      (load (merge-pathnames name #p"home:") :if-does-not-exist nil)
-	      (or (load "home:init" :if-does-not-exist nil)
-		  (load "home:.cmucl-init" :if-does-not-exist nil))))))
-    (when process-command-line
-      (ext::invoke-switch-demons *command-line-switches*
-				 *command-switch-demons*))
-    (when print-herald
-      (print-herald))
-    (funcall init-function)))
-
-
-(defvar *herald-items* ()
-  "Determines what PRINT-HERALD prints (the system startup banner.)  This is a
-   database which can be augmented by each loaded system.  The format is a
-   property list which maps from subsystem names to the banner information for
-   that system.  This list can be manipulated with GETF -- entries are printed
-   in, reverse order, so the newest entry is printed last.  Usually the system
-   feature keyword is used as the system name.  A given banner is a list of
-   strings and functions (or function names).  Strings are printed, and
-   functions are called with an output stream argument.")
-
-(setf (getf *herald-items* :common-lisp)
-      `("CMU Common Lisp "
-	,#'(lambda (stream)
-	     (write-string (lisp-implementation-version) stream))
-	", running on "
-	,#'(lambda (stream) (write-string (machine-instance) stream))))
-
-(setf (getf *herald-items* :bugs)
-      '("Send bug reports and questions to cmucl-bugs@cs.cmu.edu."
-	terpri
-	"Loaded subsystems:"))
-
-;;; PRINT-HERALD  --  Public
-;;;
-(defun print-herald (&optional (stream *standard-output*))
-  "Print some descriptive information about the Lisp system version and
-   configuration."
-  (let ((res ()))
-    (do ((item *herald-items* (cddr item)))
-	((null item))
-      (push (second item) res))
-
-    (fresh-line stream)
-    (dolist (item res)
-      (dolist (thing item)
-	(typecase thing
-	  (string
-	   (write-string thing stream))
-	  (function (funcall thing stream))
-	  ((or symbol cons)
-	   (funcall (fdefinition thing) stream))
-	  (t
-	   (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing))))
-      (fresh-line stream)))
-
-  (values))
-
-
-;;;; Random functions used by worldload.
-
-(defun assert-user-package ()
-  (unless (eq *package* (find-package "USER"))
-    (error "Change *PACKAGE* to the USER package and try again.")))
diff --git a/code/scavhook.lisp b/code/scavhook.lisp
deleted file mode 100644
index 78851b0518b9fea7527585ce7e18d277f744746e..0000000000000000000000000000000000000000
--- a/code/scavhook.lisp
+++ /dev/null
@@ -1,55 +0,0 @@
-;;; -*- Package: EXT -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/scavhook.lisp,v 1.1 1991/07/30 00:40:04 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file implements the ``Scavenger Hook'' extension.
-;;;
-;;; Written by William Lott
-;;;
-
-(in-package "EXT")
-
-(export '(scavenger-hook scavenger-hook-p make-scavenger-hook
-	  scavenger-hook-value scavenger-hook-function))
-
-(defun scavenger-hook-p (object)
-  "Returns T if OBJECT is a scavenger-hook, and NIL if not."
-  (scavenger-hook-p object))
-
-(defun make-scavenger-hook (&key value (function (required-argument)))
-  "Create a new scavenger-hook with the specified VALUE and FUNCTION.  For
-   as long as the scavenger-hook is alive, the scavenger in the garbage
-   collector will note whenever VALUE is moved, and arrange for FUNCTION
-   to be funcalled."
-  (declare (type function function))
-  (c::%make-scavenger-hook value function))
-
-(defun scavenger-hook-value (scavhook)
-  "Returns the VALUE being monitored by SCAVHOOK.  Can be setf."
-  (declare (type scavenger-hook scavhook))
-  (scavenger-hook-value scavhook))
-
-(defun (setf scavenger-hook-value) (value scavhook)
-  (declare (type scavenger-hook scavhook))
-  (setf (scavenger-hook-value scavhook) value))
-
-(defun scavenger-hook-function (scavhook)
-  "Returns the FUNCTION invoked when the monitored value is moved.  Can be
-   setf."
-  (declare (type scavenger-hook scavhook))
-  (scavenger-hook-function scavhook))
-
-(defun (setf scavenger-hook-function) (function scavhook)
-  (declare (type function function)
-	   (type scavenger-hook scavhook))
-  (setf (scavenger-hook-function scavhook) function))
-
diff --git a/code/search-list.lisp b/code/search-list.lisp
deleted file mode 100644
index 8c6ccdf8071919dee07ad1edb70aa87c90df9eef..0000000000000000000000000000000000000000
--- a/code/search-list.lisp
+++ /dev/null
@@ -1,159 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/search-list.lisp,v 1.3 1991/02/08 13:35:25 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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)
-		      (let ((x (if (pathnamep x) (namestring x) 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 4f52d5fa37c04c0263c7167051237d2d81c5cab0..0000000000000000000000000000000000000000
--- a/code/seq.lisp
+++ /dev/null
@@ -1,2314 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.12 1992/05/15 19:25:14 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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-atom (type)
-  "Returns the broad class of which TYPE is a specific subclass."
-  `(if (atom ,type) ,type (car ,type)))
-
-) ; eval-when
-
-
-
-
-;;; RESULT-TYPE-OR-LOSE  --  Internal
-;;;
-;;;    Given an arbitrary type specifier, return a sane sequence type specifier
-;;; that we can directly match.
-;;;
-(defun result-type-or-lose (type &optional nil-ok)
-  (cond
-   ((subtypep type 'nil)
-    (if nil-ok
-	nil
-	(error "NIL output type invalid for this sequence function.")))
-   ((dolist (seq-type '(list bit-vector string vector) nil)
-      (when (subtypep type seq-type)
-	(return seq-type))))
-   (t
-    (error "~S is a bad type specifier for sequence functions." type))))
-
-  
-(defun make-sequence-of-type (type length)
-  "Returns a sequence of the given TYPE and LENGTH."
-  (declare (fixnum length))
-  (case (type-specifier-atom type)
-    (list (make-list length))
-    ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2)))
-    ((string simple-string base-string simple-base-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)))
-    (t
-     (make-sequence-of-type (result-type-or-lose type) length))))
-  
-(defun elt (sequence index)
-  "Returns the element of SEQUENCE specified by INDEX."
-  (etypecase sequence
-    (list
-     (do ((count index (1- count))
-	  (list sequence (cdr list)))
-	 ((= count 0) (car list))
-       (declare (fixnum count))
-       (when (endp list)
-	 (error "~S: index too large." index))))
-    (vector
-     (when (>= index (length sequence))
-       (error "~S: index too large." index))
-     (aref sequence index))))
-
-(defun %setelt (sequence index newval)
-  "Store NEWVAL as the component of SEQUENCE specified by INDEX."
-  (etypecase sequence
-    (list
-     (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)))))
-    (vector
-     (when (>= index (length sequence))
-       (error "~S: index too large." index))
-     (setf (aref sequence index) newval))))
-
-
-(defun length (sequence)
-  "Returns an integer that is the length of SEQUENCE."
-  (etypecase sequence
-    (vector (length (truly-the vector sequence)))
-    (list (length (truly-the list 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 (kernel::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."
-  (let ((target-end (or target-end (length target-sequence)))
-	(source-end (or 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-atom output-type-spec)
-    ((simple-vector simple-string vector string array simple-array
-		    bit-vector simple-bit-vector base-string
-		    simple-base-string)
-     (apply #'concat-to-simple* output-type-spec sequences))
-    (list (apply #'concat-to-list* sequences))
-    (t
-     (apply #'concatenate (result-type-or-lose output-type-spec) sequences))))
-
-;;; 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-atom 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 base-string simple-base-string)
-       (map-to-simple output-type-spec function sequences))
-      (t
-       (apply #'map (result-type-or-lose output-type-spec t)
-	      function sequences)))))
-
-
-;;; 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 key 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
-			  (apply-key ,key (,ref ,sequence index))))))
-
-(defmacro mumble-reduce-from-end (function sequence key 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
-			  (apply-key ,key (,ref ,sequence index))
-			  value))))
-
-(defmacro list-reduce (function sequence key 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 (apply-key ,key (car sequence)))
-		 (funcall ,function value (apply-key ,key (car sequence)))))
-	 ((= count (the fixnum ,end)) value)
-       (declare (fixnum count)))))
-
-(defmacro list-reduce-from-end (function sequence key 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 (apply-key ,key (car sequence)))
-		 (funcall ,function (apply-key ,key (car sequence)) value)))
-	 ((= count (the fixnum ,end)) value)
-       (declare (fixnum count)))))
-
-)
-
-(defun reduce (function sequence &key key from-end (start 0)
-			end (initial-value nil ivp))
-  "The specified Sequence is ``reduced'' using the given Function.
-  See manual for details."
-  (declare (type index start))
-  (let ((start start)
-	(end (or end (length sequence))))
-    (declare (type index start end))
-    (cond ((= end start)
-	   (if ivp initial-value (funcall function)))
-	  ((listp sequence)
-	   (if from-end
-	       (list-reduce-from-end function sequence key start end
-				     initial-value ivp)
-	       (list-reduce function sequence key start end
-			    initial-value ivp)))
-	  (from-end
-	   (when (not ivp)
-	     (setq end (1- (the fixnum end)))
-	     (setq initial-value (apply-key key (aref sequence end))))
-	   (mumble-reduce-from-end function sequence key start end
-				   initial-value aref))
-	  (t
-	   (when (not ivp)
-	     (setq initial-value (apply-key key (aref sequence start)))
-	     (setq start (1+ start)))
-	   (mumble-reduce function sequence key 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 single-float float)
-       (%single-float object))
-      ((double-float long-float)
-       (%double-float 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-atom output-type-spec)
-	 ((simple-string string simple-base-string base-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-atom 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-atom 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-atom output-type-spec)
-	 (list (vector-to-list* object))
-	 ((simple-string string simple-base-string base-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-atom output-type-spec)
-	 (list (vector-to-list* object))
-	 ((simple-string simple-base-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-atom 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-atom output-type-spec)
-	 (list (vector-to-list* object))
-	 ((simple-string string base-string simple-base-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 (length (the ,(case src-type
-						  (:list 'list)
-						  (:vector 'vector))
-					       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 (length object)))
-	(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 (length object)))
-	(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))
-  (let* ((length (length sequence))
-	 (end (or end length )))
-    (declare (type index length end))
-    (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))
-  (let* ((length (length sequence))
-	 (end (or end length)))
-    (declare (type index length end))
-    (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))
-  (let* ((length (length sequence))
-	 (end (or end length)))
-    (declare (type index length end))
-    (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* ((sequence ,(if reverse?
-			 '(reverse (the list sequence))
-			 '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))
-  (let* ((length (length sequence))
-	 (end (or end length)))
-    (declare (type index length end))
-    (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))
-  (let* ((length (length sequence))
-	 (end (or end length)))
-    (declare (type index length end))
-    (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))
-  (let* ((length (length sequence))
-	 (end (or end length)))
-    (declare (type index length end))
-    (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 (1+ 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 old (apply-key key elt)))
-					(funcall test old (apply-key key elt))))
-				   (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 old (apply-key key elt)))
-				(funcall test old (apply-key key elt))))
-			  (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))
-  (let* ((length (length sequence))
-	 (end (or end length)))
-    (declare (type index length end))
-    (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))
-  (let* ((length (length sequence))
-	 (end (or end length))
-	 test-not
-	 old)
-    (declare (type index length end))
-    (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))
-  (let* ((length (length sequence))
-	 (end (or end length))
-	 test-not
-	 old)
-    (declare (type index length end))
-    (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))
-  (let ((end (or end (length sequence))))
-    (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))
-	(if from-end
-	    (nvector-substitute* new old sequence -1
-				 test test-not (1- end) (1- start) count key)
-	    (nvector-substitute* new old sequence 1
-				 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 old (apply-key key (car list))))
-	      (funcall test old (apply-key key (car list))))
-      (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 old (apply-key key (aref sequence index))))
-	      (funcall test old (apply-key key (aref sequence index))))
-      (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))
-  (let ((end (or end (length sequence))))
-    (declare (fixnum end))
-    (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))
-	(if from-end
-	    (nvector-substitute-if* new test sequence -1
-				    (1- end) (1- start) count key)
-	    (nvector-substitute-if* new test sequence 1
-				    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 count))
-  (let ((end (or end (length sequence))))
-    (declare (fixnum end))
-    (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))
-	(if from-end
-	    (nvector-substitute-if-not* new test sequence -1
-					(1- end) (1- start) count key)
-	    (nvector-substitute-if-not* new test sequence 1
-					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))
-  (let ((end (or end (length sequence))))
-    (declare (type index end))
-    (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))
-  (let ((end (or end (length sequence))))
-    (declare (type index end))
-    (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))
-  (let ((end (or end (length sequence))))
-    (declare (type index end))
-    (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))
-  (let ((end (or end (length sequence))))
-    (declare (type index end))
-    (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))
-  (let ((end (or end (length sequence))))
-    (declare (type index end))
-    (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))
-  (let ((end (or end (length sequence))))
-    (declare (type index end))
-    (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))
-  (let ((end (or end (length sequence))))
-    (declare (type index end))
-    (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) &body body)
-  (declare (ignore end)) ;; ### Should END be used below?
-  `(let ((,sequence (if from-end
-			(nthcdr (- (the fixnum ,length) (the fixnum ,start) 1)
-				(reverse (the list ,sequence)))
-			(nthcdr ,start ,sequence))))
-     (declare (type list ,sequence))
-     ,@body))
-
-)
-
-;;; 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 ((sequence1 sequence1)
-	(sequence2 sequence2)
-	(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))
-  (let* ((length1 (length sequence1))
-	 (end1 (or end1 length1))
-	 (length2 (length sequence2))
-	 (end2 (or end2 length2)))
-    (declare (type index length1 end1 length2 end2))
-    (match-vars
-     (seq-dispatch sequence1
-       (matchify-list (sequence1 start1 length1 end1)
-	 (seq-dispatch sequence2
-	   (matchify-list (sequence2 start2 length2 end2)
-	     (list-list-mismatch))
-	   (list-mumble-mismatch)))
-       (seq-dispatch sequence2
-	 (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))
-  (let ((end1 (or end1 (length sequence1)))
-	(end2 (or end2 (length sequence2))))
-    (seq-dispatch sequence2
-		  (list-search sequence2 sequence1)
-		  (vector-search sequence2 sequence1))))
diff --git a/code/setf-funs.lisp b/code/setf-funs.lisp
deleted file mode 100644
index dae863f225fa9de44d8f51dc5dd6de90c900b4e7..0000000000000000000000000000000000000000
--- a/code/setf-funs.lisp
+++ /dev/null
@@ -1,64 +0,0 @@
-;;; -*- Package: Kernel -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/setf-funs.lisp,v 1.2 1991/05/08 15:57:49 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Stuff to automatically generate SETF functions for all the standard
-;;; functions that are currently implemented with setf macros.
-;;;
-(in-package "KERNEL")
-
-(eval-when (compile eval)
-
-(defun compute-one-setter (name type)
-  (let* ((args (second type))
-	 (res (type-specifier
-	       (single-value-type
-		(values-specifier-type (third type)))))
-	 (arglist (loop repeat (1+ (length args)) collect (gensym))))
-    (cond
-     ((null (intersection args lambda-list-keywords))
-      `(defun (setf ,name) ,arglist
-	 (declare ,@(mapcar #'(lambda (arg type)
-				`(type ,type ,arg))
-			    arglist
-			    (cons res args)))
-	 (setf (,name ,@(rest arglist)) ,(first arglist))))
-     ((ignore-errors (get-setf-method `(apply #',name args)))
-      `(defun (setf ,name) (newval &rest args)
-	 (setf (apply #',name args) newval)))
-     (t
-      (warn "Hairy setf expander for function ~S." name)
-      nil))))
-       
-
-(defmacro define-setters (packages &rest ignore)
-  (collect ((res))
-    (dolist (pkg packages)
-      (do-external-symbols (sym pkg)
-	(when (and (fboundp sym)
-		   (eq (info function kind sym) :function)
-		   (or (info setf inverse sym)
-		       (info setf expander sym))
-		   (not (member sym ignore)))
-	  (let ((type (type-specifier (info function type sym))))
-	    (assert (consp type))
-	    (res `(declaim (inline (setf ,sym))))
-	    (res (compute-one-setter sym type))))))
-    `(progn ,@(res))))
-
-); eval-when (compile eval)
-
-(define-setters ("LISP")
-  ;; Have explicit definitions...
-  aref bit sbit
-  ;; Semantically silly...
-  getf apply ldb mask-field logbitp)
diff --git a/code/signal.lisp b/code/signal.lisp
deleted file mode 100644
index 1ba22cb09c0a12e9c0d9ba413493ef682e252c62..0000000000000000000000000000000000000000
--- a/code/signal.lisp
+++ /dev/null
@@ -1,359 +0,0 @@
-;;; -*- Package: UNIX -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.17 1992/07/09 19:27:05 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.17 1992/07/09 19:27:05 wlott Exp $
-;;;
-;;; Code for handling UNIX signals.
-;;; 
-;;; Written by William Lott.
-;;;
-
-(in-package "UNIX")
-(use-package "KERNEL")
-(export '(unix-signal-name unix-signal-description unix-signal-number
-	  sigmask unix-sigblock unix-sigpause unix-sigsetmask unix-kill
-	  unix-killpg))
-
-(in-package "KERNEL")
-(export '(signal-init))
-
-(in-package "SYSTEM")
-(export '(without-interrupts with-interrupts with-enabled-interrupts
-	  enable-interrupt ignore-interrupt default-interrupt))
-
-(in-package "UNIX")
-
-;;; These should probably be somewhere, but I don't know where.
-;;; 
-(defconstant sig_dfl 0)
-(defconstant sig_ign 1)
-
-(proclaim '(special lisp::lisp-command-line-list))
-
-
-
-;;;; Utilities for dealing with signal names and numbers.
-
-(defstruct (unix-signal
-	    (:constructor make-unix-signal (%name %number %description)))
-  %name				; Signal keyword
-  (%number nil :type integer)       ; UNIX signal number
-  (%description nil :type string))  ; Documentation
-
-(defvar *unix-signals* nil
-  "A list of unix signal structures.")
-
-(eval-when (compile eval)
-(defmacro def-unix-signal (name number description)
-  (let ((symbol (intern (symbol-name name))))
-    `(progn
-       (push (make-unix-signal ,name ,number ,description) *unix-signals*)
-       ;; 
-       ;; This is to make the new signal lookup stuff compatible with
-       ;; old code which expects the symbol with the same print name as
-       ;; our keywords to be a constant with a value equal to the signal
-       ;; number.
-       (defconstant ,symbol ,number ,description)
-       (export ',symbol))))
-) ;eval-when
-
-(defun unix-signal-or-lose (arg)
-  (let ((signal (find arg *unix-signals*
-		      :key (etypecase arg
-			     (symbol #'unix-signal-%name)
-			     (number #'unix-signal-%number)))))
-    (unless signal
-      (error "~S is not a valid signal name or number." arg))
-    signal))
-
-(defun unix-signal-name (signal)
-  "Return the name of the signal as a string.  Signal should be a valid
-  signal number or a keyword of the standard UNIX signal name."
-  (symbol-name (unix-signal-%name (unix-signal-or-lose signal))))
-
-(defun unix-signal-description (signal)
-  "Return a string describing signal.  Signal should be a valid signal
-  number or a keyword of the standard UNIX signal name."
-  (unix-signal-%description (unix-signal-or-lose signal)))
-
-(defun unix-signal-number (signal)
-  "Return the number of the given signal.  Signal should be a valid
-  signal number or a keyword of the standard UNIX signal name."
-  (unix-signal-%number (unix-signal-or-lose signal)))
-
-;;; Known signals
-;;; 
-(def-unix-signal :CHECK 0 "Check")
-(def-unix-signal :SIGHUP 1 "Hangup")
-(def-unix-signal :SIGINT 2 "Interrupt")
-(def-unix-signal :SIGQUIT 3 "Quit")
-(def-unix-signal :SIGILL 4 "Illegal instruction")
-(def-unix-signal :SIGTRAP 5 "Trace trap")
-(def-unix-signal :SIGIOT 6 "Iot instruction")
-(def-unix-signal :SIGEMT 7 "Emt instruction")
-(def-unix-signal :SIGFPE 8 "Floating point exception")
-(def-unix-signal :SIGKILL 9 "Kill")
-(def-unix-signal :SIGBUS 10 "Bus error")
-(def-unix-signal :SIGSEGV 11 "Segmentation violation")
-(def-unix-signal :SIGSYS 12 "Bad argument to system call")
-(def-unix-signal :SIGPIPE 13 "Write on a pipe with no one to read it")
-(def-unix-signal :SIGALRM 14 "Alarm clock")
-(def-unix-signal :SIGTERM 15 "Software termination signal")
-(def-unix-signal :SIGURG 16 "Urgent condition present on socket")
-(def-unix-signal :SIGSTOP 17 "Stop")
-(def-unix-signal :SIGTSTP 18 "Stop signal generated from keyboard")
-(def-unix-signal :SIGCONT 19 "Continue after stop")
-(def-unix-signal :SIGCHLD 20 "Child status has changed")
-(def-unix-signal :SIGTTIN 21 "Background read attempted from control terminal")
-(def-unix-signal :SIGTTOU 22 "Background write attempted to control terminal")
-(def-unix-signal :SIGIO 23 "I/O is possible on a descriptor")
-(def-unix-signal :SIGXCPU 24 "Cpu time limit exceeded")
-(def-unix-signal :SIGXFSZ 25 "File size limit exceeded")
-(def-unix-signal :SIGVTALRM 26 "Virtual time alarm")
-(def-unix-signal :SIGPROF 27 "Profiling timer alarm")
-(def-unix-signal :SIGWINCH 28 "Window size change")
-(def-unix-signal :SIGUSR1 30 "User defined signal 1")
-(def-unix-signal :SIGUSR2 31 "User defined signal 2")
-;;; 
-;;; These are Mach Specific
-(def-unix-signal :SIGEMSG 30 "Mach Emergency message")
-(def-unix-signal :SIGMSG 31 "Mach message")
-
-;;; SIGMASK -- Public
-;;;
-(defmacro sigmask (&rest signals)
-  "Returns a mask given a set of signals."
-  (apply #'logior
-	 (mapcar #'(lambda (signal)
-		     (ash 1 (1- (unix-signal-number signal))))
-		 signals)))
-
-
-;;;; System calls that deal with signals.
-
-(proclaim '(inline real-unix-kill))
-
-(alien:def-alien-routine ("kill" real-unix-kill) c-call:int
-  (pid c-call:int)
-  (signal c-call:int))
-
-(defun unix-kill (pid signal)
-  "Unix-kill sends the signal signal to the process with process 
-   id pid.  Signal should be a valid signal number or a keyword of the
-   standard UNIX signal name."
-  (real-unix-kill pid (unix-signal-number signal)))
-
-
-(proclaim '(inline real-unix-killpg))
-
-(alien:def-alien-routine ("killpg" real-unix-killpg) c-call:int
-  (pgrp c-call:int)
-  (signal c-call:int))
-
-(defun unix-killpg (pgrp signal)
-  "Unix-killpg sends the signal signal to the all the process in process
-  group PGRP.  Signal should be a valid signal number or a keyword of
-  the standard UNIX signal name."
-  (real-unix-killpg pgrp (unix-signal-number signal)))
-
-
-(alien:def-alien-routine ("sigblock" unix-sigblock) c-call:unsigned-long
-  "Unix-sigblock cause the signals specified in mask to be
-   added to the set of signals currently being blocked from
-   delivery.  The macro sigmask is provided to create masks."
-  (mask c-call:unsigned-long))
-
-
-(alien:def-alien-routine ("sigpause" unix-sigpause) c-call:void
-  "Unix-sigpause sets the set of masked signals to its argument
-   and then waits for a signal to arrive, restoring the previous
-   mask upon its return."
-  (mask c-call:unsigned-long))
-
-
-(alien:def-alien-routine ("sigsetmask" unix-sigsetmask) c-call:unsigned-long
-  "Unix-sigsetmask sets the current set of masked signals (those
-   begin blocked from delivery) to the argument.  The macro sigmask
-   can be used to create the mask.  The previous value of the signal
-   mask is returned."
-  (mask c-call:unsigned-long))
-
-
-
-;;;; C routines that actually do all the work of establishing signal handlers.
-
-(alien:def-alien-routine ("install_handler" install-handler)
-			 c-call:unsigned-long
-  (signal c-call:int)
-  (handler c-call:unsigned-long))
-
-
-
-;;;; Interface to enabling and disabling signal handlers.
-
-(defun enable-interrupt (signal handler)
-  (declare (type (or function (member :default :ignore)) handler))
-  (without-gcing
-   (let ((result (install-handler (unix-signal-number signal)
-				  (case handler
-				    (:default sig_dfl)
-				    (:ignore sig_ign)
-				    (t
-				     (kernel:get-lisp-obj-address handler))))))
-     (cond ((= result sig_dfl) :default)
-	   ((= result sig_ign) :ignore)
-	   (t (the function (kernel:make-lisp-obj result)))))))
-
-(defun default-interrupt (signal)
-  (enable-interrupt signal :default))
-
-(defun ignore-interrupt (signal)
-  (enable-interrupt signal :ignore))
-
-
-
-;;;; Default LISP signal handlers.
-
-;;; Most of these just call ERROR to report the presence of the signal.
-
-(defmacro define-signal-handler (name what &optional (function 'error))
-  `(defun ,name (signal code scp)
-     (declare (ignore signal code)
-	      (type system-area-pointer scp))
-     (system:without-hemlock
-      (,function ,(concatenate 'simple-string what " at #x~x.")
-		 (with-alien ((scp (* sigcontext) scp))
-		   (sap-int (vm:sigcontext-program-counter scp)))))))
-
-(define-signal-handler sigint-handler "Interrupted" break)
-(define-signal-handler sigill-handler "Illegal Instruction")
-(define-signal-handler sigtrap-handler "Breakpoint/Trap")
-(define-signal-handler sigiot-handler "SIGIOT")
-(define-signal-handler sigemt-handler "SIGEMT")
-(define-signal-handler sigbus-handler "Bus Error")
-(define-signal-handler sigsegv-handler "Segmentation Violation")
-(define-signal-handler sigsys-handler "Bad Argument to a System Call")
-(define-signal-handler sigpipe-handler "SIGPIPE")
-(define-signal-handler sigalrm-handler "SIGALRM")
-
-(defun sigquit-handler (signal code scp)
-  (declare (ignore signal code scp))
-  (throw 'lisp::top-level-catcher nil))
-
-(defun signal-init ()
-  "Enable all the default signals that Lisp knows how to deal with."
-  (unless (member "-monitor" lisp::lisp-command-line-list :test #'string=)
-    (enable-interrupt :sigint #'sigint-handler))
-  (enable-interrupt :sigquit #'sigquit-handler)
-  (enable-interrupt :sigill #'sigill-handler)
-  (enable-interrupt :sigtrap #'sigtrap-handler)
-  (enable-interrupt :sigiot #'sigiot-handler)
-  (enable-interrupt :sigemt #'sigemt-handler)
-  (enable-interrupt :sigfpe #'vm:sigfpe-handler)
-  (enable-interrupt :sigbus #'sigbus-handler)
-  (enable-interrupt :sigsegv #'sigsegv-handler)
-  (enable-interrupt :sigsys #'sigsys-handler)
-  (enable-interrupt :sigpipe #'sigpipe-handler)
-  (enable-interrupt :sigalrm #'sigalrm-handler)
-  nil)
-
-
-
-;;;; Macros for dynamically enabling and disabling signal handling.
-
-;;; Notes on how the without-interrupts/with-interrupts stuff works.
-;;;
-;;; Before invoking the supplied handler for any of the signals that can be
-;;; blocked, the C interrupt support code checks to see if *interrupts-enabled*
-;;; has been bound to NIL.  If so, it saves the signal number and the value of
-;;; the signal mask (from the sigcontext), sets the signal mask to block all
-;;; blockable signals, sets *interrupt-pending* and returns without handling
-;;; the signal.
-;;;
-;;; When we drop out the without interrupts, we check to see if
-;;; *interrupt-pending* has been set.  If so, we call do-pending-interrupt,
-;;; which generates a SIGTRAP.  The C code invokes the handler for the saved
-;;; signal instead of the SIGTRAP after replacing the signal mask in the
-;;; sigcontext with the saved value.  When that hander returns, the original
-;;; signal mask is installed, allowing any other pending signals to be handled.
-;;;
-;;; This means that the cost of without-interrupts is just a special binding in
-;;; the case when no signals are delivered (the normal case).  It's only when
-;;; a signal is actually delivered that we use any system calls, and by then
-;;; the cost of the extra system calls are lost in the noise when compared
-;;; with the cost of delivering the signal in the first place.
-;;;
-
-(defvar *interrupts-enabled* t)
-(defvar *interrupt-pending* nil)
-
-;;; DO-PENDING-INTERRUPT  --  internal
-;;;
-;;; Magically converted by the compiler into a break instruction.
-;;; 
-(defun do-pending-interrupt ()
-  (do-pending-interrupt))
-
-;;; WITHOUT-INTERRUPTS  --  puiblic
-;;; 
-(defmacro without-interrupts (&body body)
-  "Execute BODY in a context impervious to interrupts."
-  (let ((name (gensym)))
-    `(flet ((,name () ,@body))
-       (if *interrupts-enabled*
-	   (unwind-protect
-	       (let ((*interrupts-enabled* nil))
-		 (,name))
-	     (when *interrupt-pending*
-	       (do-pending-interrupt)))
-	   (,name)))))
-
-;;; WITH-INTERRUPTS  --  puiblic
-;;;
-(defmacro with-interrupts (&body body)
-  "Allow interrupts while executing BODY.  As interrupts are normally allowed,
-  this is only useful inside a WITHOUT-INTERRUPTS."
-  (let ((name (gensym)))
-    `(flet ((,name () ,@body))
-       (if *interrupts-enabled*
-	   (,name)
-	   (let ((*interrupts-enabled* t))
-	     (when *interrupt-pending*
-	       (do-pending-interrupt))
-	     (,name))))))
-
-
-;;;; WITH-ENABLED-INTERRUPTS
-
-(defmacro with-enabled-interrupts (interrupt-list &body body)
-  "With-enabled-interrupts ({(interrupt function)}*) {form}*
-   Establish function as a handler for the Unix signal interrupt which
-   should be a number between 1 and 31 inclusive."
-  (let ((il (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))
-		     (forms NIL))
-		    ((null item) (nreverse forms))
-		 (when (symbolp intr)
-		   (setq intr (symbol-value intr)))
-		 (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il)
-		       forms))
-	     ,@body)
-	 (dolist (,it (nreverse ,il))
-	   (enable-interrupt (car ,it) (cadr ,it)))))))
-
diff --git a/code/sort.lisp b/code/sort.lisp
deleted file mode 100644
index 10c9e55bf8ff1777e9db78bb486b7b25c3439622..0000000000000000000000000000000000000000
--- a/code/sort.lisp
+++ /dev/null
@@ -1,446 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sort.lisp,v 1.2 1991/02/08 13:35:46 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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/sparc-machdef.lisp b/code/sparc-machdef.lisp
deleted file mode 100644
index 5baee104cc36a704575350b1034e59440561a0c7..0000000000000000000000000000000000000000
--- a/code/sparc-machdef.lisp
+++ /dev/null
@@ -1,35 +0,0 @@
-;;; -*- Log: code.log; Package: Mach -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-machdef.lisp,v 1.2 1991/02/08 13:35:49 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Record definitions needed for the interface to Mach.
-;;;
-(in-package "MACH")
-
-(export '(sigcontext-onstack sigcontext-mask sigcontext-sp sigcontext-pc
-	  sigcontext-npc sigcontext-psr sigcontext-g1 sigcontext-o0
-	  sigcontext-regs sigcontext-fpregs sigcontext-y sigcontext-fsr
-	  sigcontext *sigcontext indirect-*sigcontext))
-
-(def-c-record sigcontext
-  (onstack unsigned-long)
-  (mask unsigned-long)
-  (sp system-area-pointer)
-  (pc system-area-pointer)
-  (npc system-area-pointer)
-  (psr unsigned-long)
-  (g1 unsigned-long)
-  (o0 unsigned-long)
-  (regs int-array)
-  (fpregs int-array)
-  (y unsigned-long)
-  (fsr unsigned-long))
diff --git a/code/sparc-vm.lisp b/code/sparc-vm.lisp
deleted file mode 100644
index 8029e14858849178d534a30b8980e09eb66ff29e..0000000000000000000000000000000000000000
--- a/code/sparc-vm.lisp
+++ /dev/null
@@ -1,253 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-vm.lisp,v 1.15 1992/10/08 22:10:21 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the SPARC specific runtime stuff.
-;;;
-(in-package "SPARC")
-(use-package "SYSTEM")
-(use-package "UNIX")
-
-(export '(fixup-code-object internal-error-arguments
-	  sigcontext-program-counter sigcontext-register
-	  sigcontext-float-register sigcontext-floating-point-modes
-	  extern-alien-name sanctify-for-execution))
-
-
-;;;; The sigcontext structure.
-
-(def-alien-type sigcontext-regs
-  (struct nil
-    (regs (array unsigned-long 32))
-    (fpregs (array unsigned-long 32))
-    (y unsigned-long)
-    (fsr unsigned-long)))
-
-(def-alien-type sigcontext
-  (struct nil
-    (sc-onstack unsigned-long)
-    (sc-mask unsigned-long)
-    (sc-sp system-area-pointer)
-    (sc-pc system-area-pointer)
-    (sc-npc system-area-pointer)
-    (sc-psr unsigned-long)
-    (sc-g1 (* sigcontext-regs))
-    (sc-o0 unsigned-long)))
-
-
-;;;; Add machine specific features to *features*
-
-(pushnew :SPARCstation *features*)
-(pushnew :sparc *features*)
-(pushnew :sun4 *features*)
-
-
-
-;;;; MACHINE-TYPE and MACHINE-VERSION
-
-(defun machine-type ()
-  "Returns a string describing the type of the local machine."
-  "SPARCstation")
-
-(defun machine-version ()
-  "Returns a string describing the version of the local machine."
-  "SPARCstation")
-
-
-
-;;; FIXUP-CODE-OBJECT -- Interface
-;;;
-(defun fixup-code-object (code offset fixup kind)
-  (declare (type index offset))
-  (unless (zerop (rem offset vm:word-bytes))
-    (error "Unaligned instruction?  offset=#x~X." offset))
-  (system:without-gcing
-   (let ((sap (truly-the system-area-pointer
-			 (%primitive c::code-instructions code))))
-     (ecase kind
-       (:call
-	(error "Can't deal with CALL fixups, yet."))
-       (:sethi
-	(setf (ldb (byte 22 0) (sap-ref-32 sap offset))
-	      (ldb (byte 22 10) fixup)))
-       (:add
-	(setf (ldb (byte 10 0) (sap-ref-32 sap offset))
-	      (ldb (byte 10 0) fixup)))))))
-
-
-
-;;;; Internal-error-arguments.
-
-;;; INTERNAL-ERROR-ARGUMENTS -- interface.
-;;;
-;;; Given the sigcontext, extract the internal error arguments from the
-;;; instruction stream.
-;;; 
-(defun internal-error-arguments (scp)
-  (declare (type (alien (* sigcontext)) scp))
-  (let* ((pc (with-alien ((scp (* sigcontext) scp))
-	       (slot scp 'sc-pc)))
-	 (bad-inst (sap-ref-32 pc 0))
-	 (op (ldb (byte 2 30) bad-inst))
-	 (op2 (ldb (byte 3 22) bad-inst))
-	 (op3 (ldb (byte 6 19) bad-inst)))
-    (declare (type system-area-pointer pc))
-    (cond ((and (= op #b00) (= op2 #b000))
-	   (args-for-unimp-inst scp))
-	  ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000))
-	   (args-for-tagged-add-inst scp bad-inst))
-	  ((and (= op #b10) (= op3 #b111010))
-	   (args-for-tcc-inst bad-inst))
-	  (t
-	   (values #.(error-number-or-lose 'unknown-error) nil)))))
-
-(defun args-for-unimp-inst (scp)
-  (declare (type (alien (* sigcontext)) scp))
-  (let* ((pc (with-alien ((scp (* sigcontext) scp))
-	       (slot scp 'sc-pc)))
-	 (length (sap-ref-8 pc 4))
-	 (vector (make-array length :element-type '(unsigned-byte 8))))
-    (declare (type system-area-pointer pc)
-	     (type (unsigned-byte 8) length)
-	     (type (simple-array (unsigned-byte 8) (*)) vector))
-    (copy-from-system-area pc (* sparc:byte-bits 5)
-			   vector (* sparc:word-bits
-				     sparc:vector-data-offset)
-			   (* length sparc:byte-bits))
-    (let* ((index 0)
-	   (error-number (c::read-var-integer vector index)))
-      (collect ((sc-offsets))
-	       (loop
-		 (when (>= index length)
-		   (return))
-		 (sc-offsets (c::read-var-integer vector index)))
-	       (values error-number (sc-offsets))))))
-
-(defun args-for-tagged-add-inst (scp bad-inst)
-  (declare (type (alien (* sigcontext)) scp))
-  (let* ((rs1 (ldb (byte 5 14) bad-inst))
-	 (op1 (di::make-lisp-obj (sigcontext-register scp rs1))))
-    (if (fixnump op1)
-	(if (zerop (ldb (byte 1 13) bad-inst))
-	    (let* ((rs2 (ldb (byte 5 0) bad-inst))
-		   (op2 (di::make-lisp-obj (sigcontext-register scp rs2))))
-	      (if (fixnump op2)
-		  (values #.(error-number-or-lose 'unknown-error) nil)
-		  (values #.(error-number-or-lose 'object-not-fixnum-error)
-			  (list (c::make-sc-offset
-				 sparc:descriptor-reg-sc-number
-				 rs2)))))
-	    (values #.(error-number-or-lose 'unknown-error) nil))
-	(values #.(error-number-or-lose 'object-not-fixnum-error)
-		(list (c::make-sc-offset sparc:descriptor-reg-sc-number
-					 rs1))))))
-
-(defun args-for-tcc-inst (bad-inst)
-  (let* ((trap-number (ldb (byte 8 0) bad-inst))
-	 (reg (ldb (byte 5 8) bad-inst)))
-    (values (case trap-number
-	      (#.sparc:object-not-list-trap
-	       #.(error-number-or-lose 'object-not-list-error))
-	      (#.sparc:object-not-structure-trap
-	       #.(error-number-or-lose 'object-not-structure-error))
-	      (t
-	       #.(error-number-or-lose 'unknown-error)))
-	    (list (c::make-sc-offset sparc:descriptor-reg-sc-number reg)))))
-
-
-;;;; Sigcontext access functions.
-
-;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
-;;;
-(defun sigcontext-program-counter (scp)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (slot scp 'sc-pc)))
-
-;;; SIGCONTEXT-REGISTER -- Interface.
-;;;
-;;; An escape register saves the value of a register for a frame that someone
-;;; interrupts.  
-;;;
-(defun sigcontext-register (scp index)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (deref (slot (slot scp 'sc-g1) 'regs) index)))
-
-(defun %set-sigcontext-register (scp index new)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (setf (deref (slot (slot scp 'sc-g1) 'regs) index) new)
-    new))
-
-(defsetf sigcontext-register %set-sigcontext-register)
-
-
-;;; SIGCONTEXT-FLOAT-REGISTER  --  Interface
-;;;
-;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
-;;; Format is the type of float to return.
-;;;
-(defun sigcontext-float-register (scp index format)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
-      (ecase format
-	(single-float (system:sap-ref-single sap (* index vm:word-bytes)))
-	(double-float (system:sap-ref-double sap (* index vm:word-bytes)))))))
-;;;
-(defun %set-sigcontext-float-register (scp index format new-value)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (let ((sap (alien-sap (slot (slot scp 'sc-g1) 'fpregs))))
-      (ecase format
-	(single-float
-	 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
-	(double-float
-	 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
-;;;
-(defsetf sigcontext-float-register %set-sigcontext-float-register)
-
-
-;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
-;;;
-;;;    Given a sigcontext pointer, return the floating point modes word in the
-;;; same format as returned by FLOATING-POINT-MODES.
-;;;
-(defun sigcontext-floating-point-modes (scp)
-  (declare (type (alien (* sigcontext)) scp))
-  (with-alien ((scp (* sigcontext) scp))
-    (slot (slot scp 'sc-g1) 'fsr)))
-
-
-
-;;; EXTERN-ALIEN-NAME -- interface.
-;;;
-;;; The loader uses this to convert alien names to the form they occure in
-;;; the symbol table (for example, prepending an underscore).  On the SPARC,
-;;; we prepend an underscore.
-;;; 
-(defun extern-alien-name (name)
-  (declare (type simple-base-string name))
-  (concatenate 'string "_" name))
-
-
-
-;;; SANCTIFY-FOR-EXECUTION -- Interface.
-;;;
-;;; Do whatever is necessary to make the given code component executable.
-;;; On the sparc, we don't need to do anything, because the i and d caches
-;;; are unified.
-;;; 
-(defun sanctify-for-execution (component)
-  (declare (ignore component))
-  nil)
diff --git a/code/stream.lisp b/code/stream.lisp
deleted file mode 100644
index 5f7e4c506dd23926f995bb059374d25cff332b7e..0000000000000000000000000000000000000000
--- a/code/stream.lisp
+++ /dev/null
@@ -1,1380 +0,0 @@
-;;; -*- Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.15 1992/12/11 15:56:52 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Stream functions for Spice Lisp.
-;;; Written by Skef Wholey and Rob MacLachlan.
-;;;
-;;; This file contains the OS-independent stream functions.
-;;;
-(in-package "LISP")
-
-(export '(broadcast-stream make-broadcast-stream broadcast-stream-streams 
-	  synonym-stream make-synonym-stream synonym-stream-symbol
-	  concatenated-stream make-concatenated-stream
-	  concatenated-stream-streams
-	  two-way-stream make-two-way-stream two-way-stream-input-stream
-	  two-way-stream-output-stream
-	  echo-stream make-echo-stream echo-stream-input-stream
-	  echo-stream-output-stream
-	  make-string-input-stream make-string-output-stream
-	  get-output-stream-string stream-element-type input-stream-p
-	  output-stream-p open-stream-p interactive-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 string-stream
-	  *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)
-
-(deftype string-stream ()
-  '(or string-input-stream string-output-stream
-       fill-pointer-output-stream))
-
-;;;; 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 the following values:
-;;; 			     t if any input waiting.
-;;; 			     :eof if at eof.
-;;; 			     nil if no input is available and not at eof.
-;;;  :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.
-;;;  :interactive-p     - Is this an interactive device?
-;;;
-;;;    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 open-stream-p (stream)
-  "Return true if Stream is not closed."
-  (declare (type stream stream))
-  (not (eq (stream-in stream) #'closed-flame)))
-
-(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 interactive-stream-p (stream)
-  "Return true if Stream does I/O on a terminal or other interactive device."
-  (declare (type stream stream))
-  (funcall (stream-misc stream) stream :interactive-p))
-
-(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 (%sp-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)
-		(if (= index in-buffer-length)
-		    (values str eofp)
-		    (let ((first (subseq buffer index in-buffer-length)))
-		      (setf (stream-in-index stream) in-buffer-length)
-		      (if (eq str eof-value)
-			  (values first t)
-			  (values (concatenate 'simple-string first
-					       (the simple-string str))
-				  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)
-	;; Test for t explicitly since misc methods return :eof sometimes.
-	(eq (funcall (stream-misc stream) stream :listen) t))))
-
-(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))
-  (let ((stream (in-synonym-of stream)))
-    (if (funcall (stream-misc stream) stream :listen)
-	;; On t or :eof get READ-CHAR to do the work.
-	(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 (typep in-buffer
-		  '(or simple-string (simple-array (unsigned-byte 8) (*)))))
-      (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 () :type list :read-only t))
-
-(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 nil :type symbol :read-only t))
-
-(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)
-		(declare (optimize (safety 1)))
-		(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)
-		(declare (optimize (safety 1)))
-		(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)
-  (declare (optimize (safety 1)))
-  (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 (required-argument) :type stream :read-only t)
-  ;; And write to this one
-  (output-stream (required-argument) :type stream :read-only t))
-
-(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)
-		(force-output (two-way-stream-output-stream stream))
-		(,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
-       (force-output out)
-       (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 nil :type list :read-only t))
-
-(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 :eof)
-	(declare (type (or simple-string (member :eof)) 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.
-	(unless (eq result :eof)
-	  (do ((current (cdr current) (cdr current))
-	       (new ""))
-	      ((or (not eofp) (null current))
-	       (return-from concatenated-readline (values result eofp)))
-	    (declare (type (or simple-string (member :eof)) new))
-	    (setf (concatenated-stream-current stream) current)
-	    (let ((this (car current)))
-	      (multiple-value-setq (new eofp)
-		(read-line this nil :eof))
-	      (if (eq new :eof)
-		  (setq eofp t)
-		  (setq result (concatenate 'simple-string result new))))))))))
-
-(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
-	       (loop
-		 (let ((stuff (funcall misc current :listen)))
-		   (cond ((eq stuff :eof)
-			  ;; Advance current, and try again.
-			  (pop (concatenated-stream-current stream))
-			  (setf current
-				(car (concatenated-stream-current stream)))
-			  (unless current
-			    ;; No further streams.  EOF.
-			    (return :eof))
-			  (setf misc (stream-misc current)))
-			 (stuff
-			  ;; Stuff's available.
-			  (return t))
-			 (t
-			  ;; Nothing available yet.
-			  (return nil))))))
-	      (: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)))
-  unread-stuff)
-
-
-(macrolet ((in-fun (name fun out-slot &rest args)
-	     `(defun ,name (stream ,@args)
-		(or (pop (echo-stream-unread-stuff stream))
-		    (let* ((in (echo-stream-input-stream stream))
-			   (out (echo-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 (not (null (echo-stream-unread-stuff stream)))
-		   (/= (the fixnum (stream-in-index in)) in-buffer-length)
-		   (funcall in-method in :listen)))
-      (:unread (push arg1 (echo-stream-unread-stuff stream)))
-      (:read-line
-       (let* ((stuff (echo-stream-unread-stuff stream))
-	      (newline-pos (position #\newline stuff)))
-	 (if newline-pos
-	     (progn
-	       (setf (echo-stream-unread-stuff stream)
-		     (subseq stuff (1+ newline-pos)))
-	       (values (coerce (subseq stuff 0 newline-pos) 'simple-string)
-		       nil))
-	     (multiple-value-bind (result eofp)
-				  (read-line in arg1 arg2)
-	       (if eofp
-		   (write-string result out)
-		   (write-line result out))
-	       (setf (echo-stream-unread-stuff stream) nil)
-	       (values (if stuff
-			   (concatenate 'simple-string stuff result)
-			   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 arg1
-	 (setf (string-input-stream-current stream) arg1)
-	 (string-input-stream-current stream)))
-    (:file-length (length (string-input-stream-string 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 (position #\newline string :start current :end end)))
-	     (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 (or (/= (the fixnum (string-input-stream-current stream))
-		     (the fixnum (string-input-stream-end stream)))
-		 :eof))
-    (: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 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 (fill-pointer buffer))
-	 (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))
-	    (setf (fill-pointer buffer) 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 (fill-pointer buffer))
-	 (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))
-	    (setf (fill-pointer buffer) 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 (fill-pointer buffer)))
-       (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 '(maybe-inline read-char unread-char read-byte listen))
-
-
-
-;;;; Case frobbing streams, used by format ~(...~).
-
-(in-package "EXT")
-(export '(make-case-frob-stream))
-(in-package "LISP")
-
-(defstruct (case-frob-stream
-	    (:include stream
-		      (:misc #'case-frob-misc))
-	    (:constructor %make-case-frob-stream (target out sout)))
-  (target (required-argument) :type stream))
-
-(defun make-case-frob-stream (target kind)
-  "Returns a stream that sends all output to the stream TARGET, but modifies
-   the case of letters, depending on KIND, which should be one of:
-     :upcase - convert to upper case.
-     :downcase - convert to lower case.
-     :capitalize - convert the first letter of words to upper case and the
-        rest of the word to lower case.
-     :capitalize-first - convert the first letter of the first word to upper
-        case and everything else to lower case."
-  (declare (type stream target)
-	   (type (member :upcase :downcase :capitalize :capitalize-first)
-		 kind)
-	   (values stream))
-  (if (case-frob-stream-p target)
-      ;; If we are going to be writing to a stream that already does case
-      ;; frobbing, why bother frobbing the case just so it can frob it
-      ;; again?
-      target
-      (multiple-value-bind
-	  (out sout)
-	  (ecase kind
-	    (:upcase
-	     (values #'case-frob-upcase-out
-		     #'case-frob-upcase-sout))
-	    (:downcase
-	     (values #'case-frob-downcase-out
-		     #'case-frob-downcase-sout))
-	    (:capitalize
-	     (values #'case-frob-capitalize-out
-		     #'case-frob-capitalize-sout))
-	    (:capitalize-first
-	     (values #'case-frob-capitalize-first-out
-		     #'case-frob-capitalize-first-sout)))
-	(%make-case-frob-stream target out sout))))
-
-(defun case-frob-misc (stream op &optional arg1 arg2)
-  (declare (type case-frob-stream stream))
-  (case op
-    (:close)
-    (t
-     (let ((target (case-frob-stream-target stream)))
-       (funcall (stream-misc target) target op arg1 arg2)))))
-
-
-(defun case-frob-upcase-out (stream char)
-  (declare (type case-frob-stream stream)
-	   (type base-character char))
-  (let ((target (case-frob-stream-target stream)))
-    (funcall (stream-out target) target (char-upcase char))))
-
-(defun case-frob-upcase-sout (stream str start end)
-  (declare (type case-frob-stream stream)
-	   (type simple-base-string str)
-	   (type index start)
-	   (type (or index null) end))
-  (let* ((target (case-frob-stream-target stream))
-	 (len (length str))
-	 (end (or end len)))
-    (funcall (stream-sout target) target
-	     (if (and (zerop start) (= len end))
-		 (string-upcase str)
-		 (nstring-upcase (subseq str start end)))
-	     0
-	     (- end start))))
-
-(defun case-frob-downcase-out (stream char)
-  (declare (type case-frob-stream stream)
-	   (type base-character char))
-  (let ((target (case-frob-stream-target stream)))
-    (funcall (stream-out target) target (char-downcase char))))
-
-(defun case-frob-downcase-sout (stream str start end)
-  (declare (type case-frob-stream stream)
-	   (type simple-base-string str)
-	   (type index start)
-	   (type (or index null) end))
-  (let* ((target (case-frob-stream-target stream))
-	 (len (length str))
-	 (end (or end len)))
-    (funcall (stream-sout target) target
-	     (if (and (zerop start) (= len end))
-		 (string-downcase str)
-		 (nstring-downcase (subseq str start end)))
-	     0
-	     (- end start))))
-
-(defun case-frob-capitalize-out (stream char)
-  (declare (type case-frob-stream stream)
-	   (type base-character char))
-  (let ((target (case-frob-stream-target stream)))
-    (cond ((alphanumericp char)
-	   (funcall (stream-out target) target (char-upcase char))
-	   (setf (case-frob-stream-out stream)
-		 #'case-frob-capitalize-aux-out)
-	   (setf (case-frob-stream-sout stream)
-		 #'case-frob-capitalize-aux-sout))
-	  (t
-	   (funcall (stream-out target) target char)))))
-
-(defun case-frob-capitalize-sout (stream str start end)
-  (declare (type case-frob-stream stream)
-	   (type simple-base-string str)
-	   (type index start)
-	   (type (or index null) end))
-  (let* ((target (case-frob-stream-target stream))
-	 (str (subseq str start end))
-	 (len (length str))
-	 (inside-word nil))
-    (dotimes (i len)
-      (let ((char (schar str i)))
-	(cond ((not (alphanumericp char))
-	       (setf inside-word nil))
-	      (inside-word
-	       (setf (schar str i) (char-downcase char)))
-	      (t
-	       (setf inside-word t)
-	       (setf (schar str i) (char-upcase char))))))
-    (when inside-word
-      (setf (case-frob-stream-out stream)
-	    #'case-frob-capitalize-aux-out)
-      (setf (case-frob-stream-sout stream)
-	    #'case-frob-capitalize-aux-sout))
-    (funcall (stream-sout target) target str 0 len)))
-
-(defun case-frob-capitalize-aux-out (stream char)
-  (declare (type case-frob-stream stream)
-	   (type base-character char))
-  (let ((target (case-frob-stream-target stream)))
-    (cond ((alphanumericp char)
-	   (funcall (stream-out target) target (char-downcase char)))
-	  (t
-	   (funcall (stream-out target) target char)
-	   (setf (case-frob-stream-out stream)
-		 #'case-frob-capitalize-out)
-	   (setf (case-frob-stream-sout stream)
-		 #'case-frob-capitalize-sout)))))
-
-(defun case-frob-capitalize-aux-sout (stream str start end)
-  (declare (type case-frob-stream stream)
-	   (type simple-base-string str)
-	   (type index start)
-	   (type (or index null) end))
-  (let* ((target (case-frob-stream-target stream))
-	 (str (subseq str start end))
-	 (len (length str))
-	 (inside-word t))
-    (dotimes (i len)
-      (let ((char (schar str i)))
-	(cond ((not (alphanumericp char))
-	       (setf inside-word nil))
-	      (inside-word
-	       (setf (schar str i) (char-downcase char)))
-	      (t
-	       (setf inside-word t)
-	       (setf (schar str i) (char-upcase char))))))
-    (unless inside-word
-      (setf (case-frob-stream-out stream)
-	    #'case-frob-capitalize-out)
-      (setf (case-frob-stream-sout stream)
-	    #'case-frob-capitalize-sout))
-    (funcall (stream-sout target) target str 0 len)))
-
-(defun case-frob-capitalize-first-out (stream char)
-  (declare (type case-frob-stream stream)
-	   (type base-character char))
-  (let ((target (case-frob-stream-target stream)))
-    (cond ((alphanumericp char)
-	   (funcall (stream-out target) target (char-upcase char))
-	   (setf (case-frob-stream-out stream)
-		 #'case-frob-downcase-out)
-	   (setf (case-frob-stream-sout stream)
-		 #'case-frob-downcase-sout))
-	  (t
-	   (funcall (stream-out target) target char)))))
-
-(defun case-frob-capitalize-first-sout (stream str start end)
-  (declare (type case-frob-stream stream)
-	   (type simple-base-string str)
-	   (type index start)
-	   (type (or index null) end))
-  (let* ((target (case-frob-stream-target stream))
-	 (str (subseq str start end))
-	 (len (length str)))
-    (dotimes (i len)
-      (let ((char (schar str i)))
-	(when (alphanumericp char)
-	  (setf (schar str i) (char-upcase char))
-	  (do ((i (1+ i) (1+ i)))
-	      ((= i len))
-	    (setf (schar str i) (char-downcase (schar str i))))
-	  (setf (case-frob-stream-out stream)
-		#'case-frob-downcase-out)
-	  (setf (case-frob-stream-sout stream)
-		#'case-frob-downcase-sout)
-	  (return))))
-    (funcall (stream-sout target) target str 0 len)))
-
-
-
-;;;; Public interface from "EXTENSIONS" package.
-
-(in-package "EXT")
-
-(export '(get-stream-command stream-command stream-command-p stream-command-name
-	  stream-command-args make-stream-command))
-
-(defstruct (stream-command (:print-function print-stream-command)
-			   (:constructor make-stream-command
-					 (name &optional args)))
-  (name nil :type symbol)
-  (args nil :type list))
-
-(defun print-stream-command (obj str n)
-  (declare (ignore n))
-  (format str "#<Stream-Cmd ~S>" (stream-command-name obj)))
-
-
-;;; GET-STREAM-COMMAND -- Public.
-;;;
-;;; We can't simply call the stream's misc method because because nil is an
-;;; ambiguous return value: does it mean text arrived, or does it mean the
-;;; stream's misc method had no :get-command implementation.  We can't return
-;;; nil until there is text input.  We don't need to loop because any stream
-;;; implementing :get-command would wait until it had some input.  If the
-;;; LISTEN fails, then we have some random stream we must wait on.
-;;;
-(defun get-stream-command (stream)
-  "This takes a stream and waits for text or a command to appear on it.  If
-   text appears before a command, this returns nil, and otherwise it returns
-   a command."
-  (let ((cmdp (funcall (lisp::stream-misc stream) stream :get-command)))
-    (cond (cmdp)
-	  ((listen stream)
-	   nil)
-	  (t
-	   ;; This waits for input and returns nil when it arrives.
-	   (unread-char (read-char stream) stream)))))
diff --git a/code/string.lisp b/code/string.lisp
deleted file mode 100644
index 03f3284c02ae00230fcbf1bab8328b33acf84aca..0000000000000000000000000000000000000000
--- a/code/string.lisp
+++ /dev/null
@@ -1,554 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/string.lisp,v 1.6 1992/05/15 17:50:40 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Functions to implement strings for Spice Lisp
-;;; Written by David Dill
-;;; Rewritten by Skef Wholey, Bill Chiles and Rob MacLachlan.
-;;;
-;;; 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))
-
-
-(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 ((,string (if (stringp ,string) ,string (string ,string))))
-     (with-array-data ((,string ,string :offset-var ,cum-offset)
-		       (,start ,start)
-		       (,end (or ,end (length (the vector ,string)))))
-       ,@forms)))
-
-)
-
-;;; With-String is like With-One-String, but doesn't parse keywords.
-
-(eval-when (compile)
-
-(defmacro with-string (string &rest forms)
-  `(let ((,string (if (stringp ,string) ,string (string ,string))))
-     (with-array-data ((,string ,string)
-		       (start)
-		       (end (length (the vector ,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 ((,string1 (if (stringp ,string1) ,string1 (string ,string1)))
-	 (,string2 (if (stringp ,string2) ,string2 (string ,string2))))
-     (with-array-data ((,string1 ,string1 :offset-var ,cum-offset-1)
-		       (,start1 ,start1)
-		       (,end1 (or ,end1 (length (the vector ,string1)))))
-       (with-array-data ((,string2 ,string2)
-			 (,start2 ,start2)
-			 (,end2 (or ,end2 (length (the vector ,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."
-  (declare (optimize (safety 1)))
-  (char string index))
-
-(defun %charset (string index new-el)
-  (declare (optimize (safety 1)))
-  (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."
-  (declare (optimize (safety 1)))
-  (schar string index))
-
-(defun %scharset (string index new-el)
-  (declare (optimize (safety 1)))
-  (setf (schar string index) new-el))
-
-(defun string=* (string1 string2 start1 end1 start2 end2)
-  (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)
-  (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)))
-    `(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))
-  (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 ()."
-  (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)
-    `(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))
-  (let* ((string (if (stringp string) string (string string)))
-	 (slen (length string)))
-    (declare (fixnum slen))
-    (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))
-  (let* ((string (if (stringp string) string (string string)))
-	 (slen (length string)))
-    (declare (fixnum slen))
-    (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))
-  (let* ((string (if (stringp string) string (string string)))
-	 (slen (length string)))
-    (declare (fixnum slen))
-    (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))
-    (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))
-    (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))
-    (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/sunos-os.lisp b/code/sunos-os.lisp
deleted file mode 100644
index 6aa1901bf10dc117abffeb05145ac4d903dd27dc..0000000000000000000000000000000000000000
--- a/code/sunos-os.lisp
+++ /dev/null
@@ -1,82 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sunos-os.lisp,v 1.6 1992/05/15 17:52:00 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; OS interface functions for CMU CL under Mach.  From Miles Bader and David
-;;; Axmark.
-;;;
-(in-package "SYSTEM")
-(use-package "EXTENSIONS")
-(export '(get-system-info get-page-size os-init))
-
-(pushnew :sunos *features*)
-(setq *software-type* "SunOS")
-
-(defconstant foreign-segment-start #x00C00000) ; ### Not right???
-(defconstant foreign-segment-size  #x00400000)
-
-(defvar *software-version* nil "Version string for supporting software")
-(defun software-version ()
-  "Returns a string describing version of the supporting software."
-  (unless *software-version*
-    (setf *software-version*
-	  (let ((version-line
-		 (with-output-to-string (stream)
-		   (run-program
-		    "/bin/sh"
-		    '("-c" "strings /vmunix|grep -i 'sunos release'")
-		    :output stream
-		    :pty nil
-		    :error nil))))
-	    (let* ((first-space (position #\Space version-line))
-		   (second-space (position #\Space version-line
-					   :start (1+ first-space)))
-		   (third-space (position #\Space version-line
-					  :start (1+ second-space))))
-	      (subseq version-line (1+ second-space) third-space)))))
-  *software-version*)
-
-
-;;; OS-INIT -- interface.
-;;;
-;;; Other OS dependent initializations.
-;;; 
-(defun os-init ()
-  ;; Decache version on save, because it might not be the same when we restart.
-  (setq *software-version* nil))
-
-;;; GET-SYSTEM-INFO  --  Interface
-;;;
-;;;    Return system time, user time and number of page faults.
-;;;
-(defun get-system-info ()
-  (multiple-value-bind
-      (err? utime stime maxrss ixrss idrss isrss minflt majflt)
-      (unix:unix-getrusage unix:rusage_self)
-    (declare (ignore maxrss ixrss idrss isrss minflt))
-    (cond ((null err?)
-	   (error "Unix system call getrusage failed: ~A."
-		  (unix:get-unix-error-msg utime)))
-	  (T
-	   (values utime stime majflt)))))
-
-
-;;; GET-PAGE-SIZE  --  Interface
-;;;
-;;;    Return the system page size.
-;;;
-(defun get-page-size ()
-  (multiple-value-bind (val err)
-		       (unix:unix-getpagesize)
-    (unless val
-      (error "Getpagesize failed: ~A" (unix:get-unix-error-msg err)))
-    val))
diff --git a/code/symbol.lisp b/code/symbol.lisp
deleted file mode 100644
index 47021277f60b8b67c86344533a26e4aacc95a165..0000000000000000000000000000000000000000
--- a/code/symbol.lisp
+++ /dev/null
@@ -1,228 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/symbol.lisp,v 1.13 1992/12/11 17:16:00 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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))
-
-(in-package "KERNEL")
-(export '(%set-symbol-value %set-symbol-plist %set-symbol-package fset))
-
-(in-package "LISP")
-
-(declaim (maybe-inline get %put getf remprop %putf get-properties keywordp))
-
-(defun symbol-value (variable)
-  "VARIABLE must evaluate to a symbol.  This symbol's current special
-  value is returned."
-  (declare (optimize (safety 1)))
-  (symbol-value variable))
-
-(defun boundp (variable)
-  "VARIABLE must evaluate to a symbol.  Return NIL if this symbol is
-  unbound, T if it has a value."
-  (boundp variable))
-
-(defun set (variable new-value)
-  "VARIABLE must evaluate to a symbol.  This symbol's special value cell is
-  set to the specified new value."
-  (declare (type symbol variable))
-  (cond ((null variable)
-	 (error "Nihil ex nihil, can't set NIL."))
-	((eq variable t)
-	 (error "Veritas aeterna, can't set T."))
-	((and (boundp '*keyword-package*)
-	      (keywordp variable))
-	 (error "Can't set keywords."))
-	(t
-	 (%set-symbol-value variable new-value))))
-
-(defun %set-symbol-value (symbol new-value)
-  (%set-symbol-value symbol new-value))
-
-(defun makunbound (variable)
-  "VARIABLE must evaluate to a symbol.  This symbol is made unbound,
-  removing any value it may currently have."
-  (set variable
-       (%primitive make-other-immediate-type 0 vm:unbound-marker-type))
-  variable)
-
-(defun symbol-function (variable)
-  "VARIABLE must evaluate to a symbol.  This symbol's current definition
-   is returned.  Settable with SETF."
-  (raw-definition variable))
-
-(defun fset (symbol new-value)
-  (declare (type symbol symbol) (type function new-value))
-  (setf (raw-definition symbol) new-value))
-
-
-(defun symbol-plist (variable)
-  "VARIABLE must evaluate to a symbol.  Return its property list."
-  (symbol-plist variable))
-
-(defun %set-symbol-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 %set-symbol-package (symbol package)
-  (declare (type symbol symbol))
-  (%set-symbol-package symbol package))
-
-(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."
-  (do ((pl (symbol-plist symbol) (cddr pl)))
-      ((endp pl)
-       (setf (symbol-plist symbol)
-	     (list* indicator value (symbol-plist symbol)))
-       value)
-    (cond ((endp (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 %putf (place property new-value)
-  (declare (type list place))
-  (do ((plist place (cddr plist)))
-      ((endp plist) (list* property new-value place))
-    (declare (type list plist))
-    (when (eq (car plist) property)
-      (setf (cadr plist) new-value)
-      (return place))))
-
-
-(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."
-  (make-symbol
-   (concatenate 'simple-string
-		(if (stringp string) string "G")
-		(quick-integer-to-string
-		 (if (integerp string) string (incf *gensym-counter*))))))
-
-(defvar *gentemp-counter* 0)
-(declaim (type index *gentemp-counter*))
-
-(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 *gentemp-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/time.lisp b/code/time.lisp
deleted file mode 100644
index c7c8b2d0fdcabb99749fb6102c83173d9cae4ed7..0000000000000000000000000000000000000000
--- a/code/time.lisp
+++ /dev/null
@@ -1,387 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/time.lisp,v 1.13 1992/08/05 20:08:28 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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.")
-
-(defconstant micro-seconds-per-internal-time-unit
-  (/ 1000000 internal-time-units-per-second))
-
-
-(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)))))
-
-
-;;; The base number of seconds for our internal "epoch".  We initialize this to
-;;; the time of the first call to G-I-R-T, and then subtract this out of the
-;;; result.
-;;;
-(defvar *internal-real-time-base-seconds* nil)
-(declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*))
-
-;;; 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."
-  (locally (declare (optimize (speed 3) (safety 0)))
-    (multiple-value-bind (ignore seconds useconds) (unix:unix-gettimeofday)
-      (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
-      (let ((base *internal-real-time-base-seconds*)
-	    (uint (truncate useconds
-			    micro-seconds-per-internal-time-unit)))
-	(declare (type (unsigned-byte 32) uint))
-	(cond (base
-	       (truly-the (unsigned-byte 32)
-		    (+ (the (unsigned-byte 32)
-			    (* (the (unsigned-byte 32) (- seconds base))
-			       internal-time-units-per-second))
-		       uint)))
-	      (t
-	       (setq *internal-real-time-base-seconds* seconds)
-	       uint))))))
-
-
-;;; Get-Internal-Run-Time  --  Public
-;;;
-(defun get-internal-run-time ()
-  "Return the run time in the internal time format.  This is useful for
-  finding CPU usage."
-  (declare (values (unsigned-byte 32)))
-  (locally (declare (optimize (speed 3) (safety 0)))
-    (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
-			 (unix:unix-fast-getrusage unix:rusage_self)
-      (declare (ignore ignore)
-	       (type (unsigned-byte 31) utime-sec stime-sec)
-	       (type (mod 1000000) utime-usec stime-usec))
-      (+ (the (unsigned-byte 32)
-	      (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
-		 internal-time-units-per-second))
-	 (truncate (+ utime-usec stime-usec)
-		   micro-seconds-per-internal-time-unit)))))
-
-
-;;; 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) (unix: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)
-					     (unix: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) (unix: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))))
-
-;;;; Time:
-
-(defmacro time (form)
-  "Evaluates the Form and prints timing information on *Trace-Output*."
-  `(%time #'(lambda () ,form)))
-
-;;; MASSAGE-TIME-FUNCTION  --  Internal
-;;;
-;;;    Try to compile the closure arg to %TIME if it is interpreted.
-;;;
-(defun massage-time-function (fun)
-  (cond
-   ((eval:interpreted-function-p fun)
-    (multiple-value-bind (def env-p)
-			 (function-lambda-expression fun)
-      (declare (ignore def))
-      (cond
-       (env-p
-	(warn "TIME form in a non-null environment, forced to interpret.~@
-	       Compiling entire form will produce more accurate times.")
-	fun)
-       (t
-	(compile nil fun)))))
-   (t fun)))
-
-;;; TIME-GET-SYS-INFO  --  Internal
-;;;
-;;;    Return all the files that we want time to report.
-;;;
-(defun time-get-sys-info ()
-  (multiple-value-bind (user sys faults)
-		       (system:get-system-info)
-    (values user sys faults (get-bytes-consed))))
-
-;;; %TIME  --  Internal
-;;;
-;;;    The guts of the TIME macro.  Compute overheads, run the (compiled)
-;;; function, report the times.
-;;;
-(defun %time (fun)
-  (let ((fun (massage-time-function fun))
-	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-setq
-        (old-run-utime old-run-stime old-page-faults old-bytes-consed)
-      (time-get-sys-info))
-    ;; Do it a second time to make sure everything is faulted in.
-    (multiple-value-setq
-        (old-run-utime old-run-stime old-page-faults old-bytes-consed)
-      (time-get-sys-info))
-    (multiple-value-setq
-        (new-run-utime new-run-stime new-page-faults new-bytes-consed)
-      (time-get-sys-info))
-    (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-setq
-        (old-run-utime old-run-stime old-page-faults old-bytes-consed)
-      (time-get-sys-info))
-    (setq old-real-time (get-internal-real-time))
-    (let ((start-gc-run-time *gc-run-time*))
-    (multiple-value-prog1
-        ;; Execute the form and return its values.
-        (funcall fun)
-      (multiple-value-setq
-	  (new-run-utime new-run-stime new-page-faults new-bytes-consed)
-	(time-get-sys-info))
-      (setq new-real-time (- (get-internal-real-time) real-time-overhead))
-      (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
-	(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~%  ~
-		 ~@[[Run times include ~S second~:P GC 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)
-		(unless (zerop gc-run-time)
-		  (/ (float gc-run-time)
-		     (float internal-time-units-per-second)))
-		(max (- new-page-faults old-page-faults) 0)
-		(max (- new-bytes-consed old-bytes-consed) 0)))))))
diff --git a/code/vm.lisp b/code/vm.lisp
deleted file mode 100644
index b424e782b627fe1394b970d5d540a8d6aad1e5cf..0000000000000000000000000000000000000000
--- a/code/vm.lisp
+++ /dev/null
@@ -1,83 +0,0 @@
-;;; -*- Log: code.log; Package: MACH -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/vm.lisp,v 1.2 1991/02/08 13:36:37 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/vm.lisp,v 1.2 1991/02/08 13:36:37 ram Exp $
-;;;
-;;; This file contains stubs for interfacing MACH's vm primitives.
-;;;
-(in-package "MACH")
-
-(export '(vm_allocate vm_copy vm_deallocate vm_statistics))
-
-(def-c-pointer *sap system-area-pointer)
-
-
-(def-c-routine ("vm_allocate" vm_allocate) (int)
-  (task port)
-  (address *sap :in-out)
-  (size unsigned-long)
-  (anywhere boolean))
-
-(def-c-routine ("vm_copy" vm_copy) (int)
-  (task port)
-  (source system-area-pointer)
-  (count unsigned-long)
-  (dest system-area-pointer))
-
-(def-c-routine ("vm_deallocate" vm_deallocate) (int)
-  (task port)
-  (address system-area-pointer)
-  (size unsigned-long))
-
-
-
-
-;;;; vm_statistics
-
-(def-c-record vm_statistics
-  (pagesize long)
-  (free_count long)
-  (active_count long)
-  (inactive_count long)
-  (wire_count long)
-  (zero_fill_count long)
-  (reactivations long)
-  (pageins long)
-  (pageouts long)
-  (faults long)
-  (cow_faults long)
-  (lookups long)
-  (hits long))
-
-(def-c-routine ("vm_statistics" %vm_statistics) (int)
-  (task port)
-  (vm_stats system-area-pointer))
-
-(defun vm_statistics (task)
-  (with-stack-alien (vm_stats vm_statistics (c-sizeof 'vm_statistics))
-    (values
-     (%vm_statistics task (alien-sap (alien-value vm_stats)))
-     (alien-access (vm_statistics-pagesize (alien-value vm_stats)))
-     (alien-access (vm_statistics-free_count (alien-value vm_stats)))
-     (alien-access (vm_statistics-active_count (alien-value vm_stats)))
-     (alien-access (vm_statistics-inactive_count (alien-value vm_stats)))
-     (alien-access (vm_statistics-wire_count (alien-value vm_stats)))
-     (alien-access (vm_statistics-zero_fill_count (alien-value vm_stats)))
-     (alien-access (vm_statistics-reactivations (alien-value vm_stats)))
-     (alien-access (vm_statistics-pageins (alien-value vm_stats)))
-     (alien-access (vm_statistics-pageouts (alien-value vm_stats)))
-     (alien-access (vm_statistics-faults (alien-value vm_stats)))
-     (alien-access (vm_statistics-cow_faults (alien-value vm_stats)))
-     (alien-access (vm_statistics-lookups (alien-value vm_stats)))
-     (alien-access (vm_statistics-hits (alien-value vm_stats))))))
-
diff --git a/code/weak.lisp b/code/weak.lisp
deleted file mode 100644
index 67e86647ee0e52954c68d3935a5c6072b16bd96d..0000000000000000000000000000000000000000
--- a/code/weak.lisp
+++ /dev/null
@@ -1,46 +0,0 @@
-;;; -*- Mode: Lisp; Package: EXTENSIONS; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/weak.lisp,v 1.2 1991/02/08 13:36:39 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/weak.lisp,v 1.2 1991/02/08 13:36:39 ram Exp $
-;;;
-;;; Weak Pointer Support.
-;;;
-;;; Written by Christopher Hoover.
-;;; 
-
-(in-package "EXTENSIONS")
-
-(export '(weak-pointer weak-pointer-p make-weak-pointer weak-pointer-value))
-
-(defun make-weak-pointer (object)
-  "Allocates and returns a weak pointer which points to OBJECT."
-  (c::%make-weak-pointer object nil))
-
-(defun weak-pointer-value (weak-pointer)
-  "If WEAK-POINTER is valid, returns the value of WEAK-POINTER and T.
-  If the referent of WEAK-POINTER has been garbage collected, returns
-  the values NIL and NIL.  The value may be set with SETF."
-  (declare (type weak-pointer weak-pointer))
-  (without-gcing
-    (let ((value (c::%weak-pointer-value weak-pointer))
-	  (broken (c::%weak-pointer-broken weak-pointer)))
-      (values value (not broken)))))
-
-(defun set-weak-pointer-value (weak-pointer new-value)
-  (declare (type weak-pointer weak-pointer))
-  (without-gcing
-    (setf (c::%weak-pointer-value weak-pointer) new-value)
-    (setf (c::%weak-pointer-broken weak-pointer) nil)
-    new-value))
-
-(defsetf weak-pointer-value set-weak-pointer-value)
diff --git a/code/wire.lisp b/code/wire.lisp
deleted file mode 100644
index d7daa7512f78e24d0fab05007e9e62c13d325300..0000000000000000000000000000000000000000
--- a/code/wire.lisp
+++ /dev/null
@@ -1,668 +0,0 @@
-;;; -*- Log: code.log; Package: wire -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/wire.lisp,v 1.9 1992/05/15 17:51:43 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains an interface to internet domain sockets.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "WIRE")
-
-(export '(remote-object-p remote-object
-	  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* wire-get-bignum wire-output-bignum))
-
-
-(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)
-(defconstant bignum-op 14)
-
-) ;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 :init-form "using")
-   (msg :init-form "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* (unix:unix-gethostid))
-    (setf *this-pid* (unix: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* (unix:unix-gethostid))
-    (setf *this-pid* (unix: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)
-	  (unix: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 (unix: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)
-	(system:without-gcing
-	 (unix:unix-read fd (system:vector-sap ibuf) buffer-size))
-      (cond ((null bytes)
-	     (error 'wire-io-error
-		    :wire wire
-		    :when "reading"
-		    :msg (unix: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))
-	(logior (ash -1 32) unsigned)
-	unsigned)))
-
-;;; WIRE-GET-BIGNUM -- public
-;;;
-;;; Extracts a number, which might be a bignum.
-;;;
-(defun wire-get-bignum (wire)
-  "Reads an arbitrary integer sent by WIRE-OUTPUT-BIGNUM from the wire and
-   return it."
-  (let ((count-and-sign (wire-get-number wire)))
-    (do ((count (abs count-and-sign) (1- count))
-	 (result 0 (+ (ash result 32) (wire-get-number wire nil))))
-	((not (plusp count))
-	 (if (minusp count-and-sign)
-	     (- result)
-	     result)))))
-
-;;; 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 bignum-op)
-	   (wire-get-bignum 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 unix: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)
-	   (unix:unix-write ,fd ,string 0 ,(or end length))
-	 (cond ((null ,result)
-		(error 'wire-io-error
-		       :wire wire
-		       :when "writing"
-		       :msg (unix: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)
-	  (code-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-BIGNUM -- public
-;;;
-;;; Output an arbitrary integer.
-;;; 
-(defun wire-output-bignum (wire number)
-  "Outputs an arbitrary integer, but less effeciently than WIRE-OUTPUT-NUMBER."
-  (do ((digits 0 (1+ digits))
-       (remaining (abs number) (ash remaining -32))
-       (words nil (cons (ldb (byte 32 0) remaining) words)))
-      ((zerop remaining)
-       (wire-output-number wire
-			   (if (minusp number)
-			       (- digits)
-			       digits))
-       (dolist (word words)
-	 (wire-output-number wire word)))))
-
-;;; 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
-	 (cond ((typep object '(signed-byte 32))
-		(wire-output-byte wire number-op)
-		(wire-output-number wire object))
-	       (t
-		(wire-output-byte wire bignum-op)
-		(wire-output-bignum 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 8bd0360c6a82d5b6373a03b95e348276d405a0c8..0000000000000000000000000000000000000000
--- a/compiler/aliencomp.lisp
+++ /dev/null
@@ -1,701 +0,0 @@
-;;; -*- Log: C.Log; Package: C -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/aliencomp.lisp,v 1.21 1992/03/22 23:47:05 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains transforms and other stuff used to compile Alien
-;;; operations.
-;;;
-;;; Rewritten once again, this time by William Lott and Rob MacLachlan.
-;;;
-(in-package "C")
-(use-package "ALIEN")
-(use-package "SYSTEM")
-
-(export '(%alien-funcall))
-
-
-;;;; defknowns
-
-(defknown %sap-alien (system-area-pointer alien-type) alien-value
-  (flushable movable))
-(defknown alien-sap (alien-value) system-area-pointer
-  (flushable movable))
-
-(defknown slot (alien-value symbol) t
-  (flushable recursive))
-(defknown %set-slot (alien-value symbol t) t
-  (recursive))
-(defknown %slot-addr (alien-value symbol) (alien (* t))
-  (flushable movable recursive))
-
-(defknown deref (alien-value &rest index) t
-  (flushable))
-(defknown %set-deref (alien-value t &rest index) t
-  ())
-(defknown %deref-addr (alien-value &rest index) (alien (* t))
-  (flushable movable))
-
-(defknown %heap-alien (heap-alien-info) t
-  (flushable))
-(defknown %set-heap-alien (heap-alien-info t) t
-  ())
-(defknown %heap-alien-addr (heap-alien-info) (alien (* t))
-  (flushable movable))
-
-(defknown make-local-alien (local-alien-info) t
-  ())
-(defknown note-local-alien-type (local-alien-info t) null
-  ())
-(defknown local-alien (local-alien-info t) t
-  (flushable))
-(defknown %local-alien-forced-to-memory-p (local-alien-info) (member t nil)
-  (movable))
-(defknown %set-local-alien (local-alien-info t t) t
-  ())
-(defknown %local-alien-addr (local-alien-info t) (alien (* t))
-  (flushable movable))
-(defknown dispose-local-alien (local-alien-info t) t
-  ())
-
-(defknown %cast (alien-value alien-type) alien
-  (flushable movable))
-
-(defknown naturalize (t alien-type) alien
-  (flushable movable))
-(defknown deport (alien alien-type) t
-  (flushable movable))
-(defknown extract-alien-value (system-area-pointer index alien-type) t
-  (flushable))
-(defknown deposit-alien-value (system-area-pointer index alien-type t) t
-  ())
-
-(defknown alien-funcall (alien-value &rest *) *
-  (any recursive))
-(defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
-
-
-;;;; Cosmetic transforms.
-
-(deftransform slot ((object slot)
-		    ((alien (* t)) symbol))
-  '(slot (deref object) slot))
-
-(deftransform %set-slot ((object slot value)
-			 ((alien (* t)) symbol t))
-  '(%set-slot (deref object) slot value))
-
-(deftransform %slot-addr ((object slot)
-			  ((alien (* t)) symbol))
-  '(%slot-addr (deref object) slot))
-
-
-;;;; SLOT support
-
-(defun find-slot-offset-and-type (alien slot)
-  (unless (constant-continuation-p slot)
-    (give-up "Slot is not constant, so cannot open code access."))
-  (let ((type (continuation-type alien)))
-    (unless (alien-type-type-p type)
-      (give-up))
-    (let ((alien-type (alien-type-type-alien-type type)))
-      (unless (alien-record-type-p alien-type)
-	(give-up))
-      (let* ((slot-name (continuation-value slot))
-	     (field (find slot-name (alien-record-type-fields alien-type)
-			  :key #'alien-record-field-name)))
-	(unless field
-	  (abort-transform "~S doesn't have a slot named ~S" alien slot-name))
-	(values (alien-record-field-offset field)
-		(alien-record-field-type field))))))
-
-#+nil ;; Shouldn't be necessary.
-(defoptimizer (slot derive-type) ((alien slot))
-  (block nil
-    (catch 'give-up
-      (multiple-value-bind (slot-offset slot-type)
-			   (find-slot-offset-and-type alien slot)
-	(declare (ignore slot-offset))
-	(return (make-alien-type-type slot-type))))
-    *wild-type*))
-
-(deftransform slot ((alien slot) * * :important t)
-  (multiple-value-bind (slot-offset slot-type)
-		       (find-slot-offset-and-type alien slot)
-    `(extract-alien-value (alien-sap alien)
-			  ,slot-offset
-			  ',slot-type)))
-
-#+nil ;; ### But what about coersions?
-(defoptimizer (%set-slot derive-type) ((alien slot value))
-  (block nil
-    (catch 'give-up
-      (multiple-value-bind (slot-offset slot-type)
-			   (find-slot-offset-and-type alien slot)
-	(declare (ignore slot-offset))
-	(let ((type (make-alien-type-type slot-type)))
-	  (assert-continuation-type value type)
-	  (return type))))
-    *wild-type*))
-
-(deftransform %set-slot ((alien slot value) * * :important t)
-  (multiple-value-bind (slot-offset slot-type)
-		       (find-slot-offset-and-type alien slot)
-    `(deposit-alien-value (alien-sap alien)
-			  ,slot-offset
-			  ',slot-type
-			  value)))
-
-(defoptimizer (%slot-addr derive-type) ((alien slot))
-  (block nil
-    (catch 'give-up
-      (multiple-value-bind (slot-offset slot-type)
-			   (find-slot-offset-and-type alien slot)
-	(declare (ignore slot-offset))
-	(return (make-alien-type-type
-		 (make-alien-pointer-type :to slot-type)))))
-    *wild-type*))
-
-(deftransform %slot-addr ((alien slot) * * :important t)
-  (multiple-value-bind (slot-offset slot-type)
-		       (find-slot-offset-and-type alien slot)
-    `(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset vm:byte-bits))
-		 ',(make-alien-pointer-type :to slot-type))))
-
-
-
-;;;; DEREF support.
-
-(defun find-deref-alien-type (alien)
-  (let ((alien-type (continuation-type alien)))
-    (unless (alien-type-type-p alien-type)
-      (give-up))
-    (let ((alien-type (alien-type-type-alien-type alien-type)))
-      (if (alien-type-p alien-type)
-	  alien-type
-	  (give-up)))))
-
-(defun find-deref-element-type (alien)
-  (let ((alien-type (find-deref-alien-type alien)))
-    (typecase alien-type
-      (alien-pointer-type
-       (alien-pointer-type-to alien-type))
-      (alien-array-type
-       (alien-array-type-element-type alien-type))
-      (t
-       (give-up)))))
-
-(defun compute-deref-guts (alien indices)
-  (let ((alien-type (find-deref-alien-type alien)))
-    (typecase alien-type
-      (alien-pointer-type
-       (when (cdr indices)
-	 (abort-transform "Too many indices for pointer deref: ~D"
-			  (length indices)))
-       (let ((element-type (alien-pointer-type-to alien-type)))
-	 (if indices
-	     (let ((bits (alien-type-bits element-type))
-		   (alignment (alien-type-alignment element-type)))
-	       (unless bits
-		 (abort-transform "Unknown element size."))
-	       (unless alignment
-		 (abort-transform "Unknown element alignment."))
-	       (values '(offset)
-		       `(* offset
-			   ,(align-offset bits alignment))
-		       element-type))
-	     (values nil 0 element-type))))
-      (alien-array-type
-       (let* ((element-type (alien-array-type-element-type alien-type))
-	      (bits (alien-type-bits element-type))
-	      (alignment (alien-type-alignment element-type))
-	      (dims (alien-array-type-dimensions alien-type)))
-	 (unless (= (length indices) (length dims))
-	   (give-up "Incorrect number of indices."))
-	 (unless bits
-	   (give-up "Element size unknown."))
-	 (unless alignment
-	   (give-up "Element alignment unknown."))
-	 (if (null dims)
-	     (values nil 0 element-type)
-	     (let* ((arg (gensym))
-		    (args (list arg))
-		    (offsetexpr arg))
-	       (dolist (dim (cdr dims))
-		 (let ((arg (gensym)))
-		   (push arg args)
-		   (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
-	       (values (reverse args)
-		       `(* ,offsetexpr
-			   ,(align-offset bits alignment))
-		       element-type)))))
-      (t
-       (abort-transform "~S not either a pointer or array type."
-			alien-type)))))
-
-
-#+nil ;; Shouldn't be necessary.
-(defoptimizer (deref derive-type) ((alien &rest noise))
-  (declare (ignore noise))
-  (block nil
-    (catch 'give-up
-      (return (make-alien-type-type (find-deref-element-type alien))))
-    *wild-type*))
-
-(deftransform deref ((alien &rest indices) * * :important t)
-  (multiple-value-bind
-      (indices-args offset-expr element-type)
-      (compute-deref-guts alien indices)
-    `(lambda (alien ,@indices-args)
-       (extract-alien-value (alien-sap alien)
-			    ,offset-expr
-			    ',element-type))))
-
-#+nil ;; ### Again, the value might be coerced.
-(defoptimizer (%set-deref derive-type) ((alien value &rest noise))
-  (declare (ignore noise))
-  (block nil
-    (catch 'give-up
-      (let ((type (make-alien-type-type
-		   (make-alien-pointer-type
-		    :to (find-deref-element-type alien)))))
-	(assert-continuation-type value type)
-	(return type)))
-    *wild-type*))
-
-(deftransform %set-deref ((alien value &rest indices) * * :important t)
-  (multiple-value-bind
-      (indices-args offset-expr element-type)
-      (compute-deref-guts alien indices)
-    `(lambda (alien value ,@indices-args)
-       (deposit-alien-value (alien-sap alien)
-			    ,offset-expr
-			    ',element-type
-			    value))))
-  
-(defoptimizer (%deref-addr derive-type) ((alien &rest noise))
-  (declare (ignore noise))
-  (block nil
-    (catch 'give-up
-      (return (make-alien-type-type
-	       (make-alien-pointer-type
-		:to (find-deref-element-type alien)))))
-    *wild-type*))
-
-(deftransform %deref-addr ((alien &rest indices) * * :important t)
-  (multiple-value-bind
-      (indices-args offset-expr element-type)
-      (compute-deref-guts alien indices)
-    `(lambda (alien ,@indices-args)
-       (%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr vm:byte-bits))
-		   ',(make-alien-pointer-type :to element-type)))))
-
-
-
-;;;; Heap Alien Support.
-
-(defun heap-alien-sap-and-type (info)
-  (unless (constant-continuation-p info)
-    (give-up "Info not constant; can't open code."))
-  (let ((info (continuation-value info)))
-    (values (heap-alien-info-sap-form info)
-	    (heap-alien-info-type info))))
-
-#+nil ;; Shouldn't be necessary.
-(defoptimizer (%heap-alien derive-type) ((info))
-  (block nil
-    (catch 'give-up
-      (multiple-value-bind (sap type)
-			   (heap-alien-sap-and-type info)
-	(declare (ignore sap))
-	(return (make-alien-type-type type))))
-    *wild-type*))
-
-(deftransform %heap-alien ((info) * * :important t)
-  (multiple-value-bind (sap type)
-		       (heap-alien-sap-and-type info)
-    `(extract-alien-value ,sap 0 ',type)))
-
-#+nil ;; ### Again, deposit value might change the type.
-(defoptimizer (%set-heap-alien derive-type) ((info value))
-  (block nil
-    (catch 'give-up
-      (multiple-value-bind (sap type)
-			   (heap-alien-sap-and-type info)
-	(declare (ignore sap))
-	(let ((type (make-alien-type-type type)))
-	  (assert-continuation-type value type)
-	  (return type))))
-    *wild-type*))
-
-(deftransform %set-heap-alien ((info value) (heap-alien-info *) * :important t)
-  (multiple-value-bind (sap type)
-		       (heap-alien-sap-and-type info)
-    `(deposit-alien-value ,sap 0 ',type value)))
-
-(defoptimizer (%heap-alien-addr derive-type) ((info))
-  (block nil
-    (catch 'give-up
-      (multiple-value-bind (sap type)
-			   (heap-alien-sap-and-type info)
-	(declare (ignore sap))
-	(return (make-alien-type-type (make-alien-pointer-type :to type)))))
-    *wild-type*))
-
-(deftransform %heap-alien-addr ((info) * * :important t)
-  (multiple-value-bind (sap type)
-		       (heap-alien-sap-and-type info)
-    `(%sap-alien ,sap ',type)))
-
-
-;;;; Local (stack or register) alien support.
-
-(deftransform make-local-alien ((info) * * :important t)
-  (unless (constant-continuation-p info)
-    (abort-transform "Local Alien Info isn't constant?"))
-  (let* ((info (continuation-value info))
-	 (alien-type (local-alien-info-type info))
-	 (bits (alien-type-bits alien-type)))
-    (unless bits
-      (abort-transform "Unknown size: ~S" (unparse-alien-type alien-type)))
-    (if (local-alien-info-force-to-memory-p info)
-	`(truly-the system-area-pointer
-		    (%primitive alloc-number-stack-space
-				,(ceiling (alien-type-bits alien-type)
-					  vm:byte-bits)))
-	(let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
-	       (alien-rep-type (specifier-type alien-rep-type-spec)))
-	  (cond ((csubtypep (specifier-type 'system-area-pointer)
-			    alien-rep-type)
-		 '(int-sap 0))
-		((ctypep 0 alien-rep-type) 0)
-		((ctypep 0.0f0 alien-rep-type) 0.0f0)
-		((ctypep 0.0d0 alien-rep-type) 0.0d0)
-		(t
-		 (compiler-error
-		  "Aliens of type ~S cannot be represented immediately."
-		  (unparse-alien-type alien-type))))))))
-
-(deftransform note-local-alien-type ((info var) * * :important t)
-  (unless (constant-continuation-p info)
-    (abort-transform "Local Alien Info isn't constant?"))
-  (let ((info (continuation-value info)))
-    (unless (local-alien-info-force-to-memory-p info)
-      (let ((var-node (continuation-use var)))
-	(when (ref-p var-node)
-	  (propagate-to-refs (ref-leaf var-node)
-			     (specifier-type
-			      (compute-alien-rep-type
-			       (local-alien-info-type info))))))))
-  'nil)
-
-(deftransform local-alien ((info var) * * :important t)
-  (unless (constant-continuation-p info)
-    (abort-transform "Local Alien Info isn't constant?"))
-  (let* ((info (continuation-value info))
-	 (alien-type (local-alien-info-type info)))
-    (if (local-alien-info-force-to-memory-p info)
-	`(extract-alien-value var 0 ',alien-type)
-	`(naturalize var ',alien-type))))
-
-(deftransform %local-alien-forced-to-memory-p ((info) * * :important t)
-  (unless (constant-continuation-p info)
-    (abort-transform "Local Alien Info isn't constant?"))
-  (let ((info (continuation-value info)))
-    (local-alien-info-force-to-memory-p info)))
-
-(deftransform %set-local-alien ((info var value) * * :important t)
-  (unless (constant-continuation-p info)
-    (abort-transform "Local Alien Info isn't constant?"))
-  (let* ((info (continuation-value info))
-	 (alien-type (local-alien-info-type info)))
-    (if (local-alien-info-force-to-memory-p info)
-	`(deposit-alien-value var 0 ',alien-type value)
-	'(error "This should be dead-code eleminated."))))
-
-(defoptimizer (%local-alien-addr derive-type) ((info var))
-  (if (constant-continuation-p info)
-      (let* ((info (continuation-value info))
-	     (alien-type (local-alien-info-type info)))
-	(make-alien-type-type (make-alien-pointer-type :to alien-type)))
-      *wild-type*))
-
-(deftransform %local-alien-addr ((info var) * * :important t)
-  (unless (constant-continuation-p info)
-    (abort-transform "Local Alien Info isn't constant?"))
-  (let* ((info (continuation-value info))
-	 (alien-type (local-alien-info-type info)))
-    (if (local-alien-info-force-to-memory-p info)
-	`(%sap-alien var ',(make-alien-pointer-type :to alien-type))
-	(error "This shouldn't happen."))))
-
-(deftransform dispose-local-alien ((info var) * * :important t)
-  (unless (constant-continuation-p info)
-    (abort-transform "Local Alien Info isn't constant?"))
-  (let* ((info (continuation-value info))
-	 (alien-type (local-alien-info-type info)))
-    (if (local-alien-info-force-to-memory-p info)
-	`(%primitive dealloc-number-stack-space
-		     ,(ceiling (alien-type-bits alien-type)
-			       vm:byte-bits))
-	nil)))
-
-
-;;;; %CAST
-
-(defoptimizer (%cast derive-type) ((alien type))
-  (or (when (constant-continuation-p type)
-	(let ((alien-type (continuation-value type)))
-	  (when (alien-type-p alien-type)
-	    (make-alien-type-type alien-type))))
-      *wild-type*))
-
-(deftransform %cast ((alien target-type) * * :important t)
-  (unless (constant-continuation-p target-type)
-    (give-up "Alien type not constant; cannot open code."))
-  (let ((target-type (continuation-value target-type)))
-    (cond ((or (alien-pointer-type-p target-type)
-	       (alien-array-type-p target-type)
-	       (alien-function-type-p target-type))
-	   `(naturalize (alien-sap alien) ',target-type))
-	  (t
-	   (abort-transform "Cannot cast to alien type ~S" target-type)))))
-
-
-;;;; alien-sap, %sap-alien, %addr, etc
-
-(deftransform alien-sap ((alien) * * :important t)
-  (let ((alien-node (continuation-use alien)))
-    (typecase alien-node
-      (combination
-       (extract-function-args alien '%sap-alien 2)
-       '(lambda (sap type)
-	  (declare (ignore type))
-	  sap))
-      (t
-       (give-up)))))
-
-(defoptimizer (%sap-alien derive-type) ((sap type))
-  (declare (ignore sap))
-  (if (constant-continuation-p type)
-      (make-alien-type-type (continuation-value type))
-      *wild-type*))
-
-(deftransform %sap-alien ((sap type) * * :important t)
-  (give-up "Could not optimize away %SAP-ALIEN: forced to do runtime ~@
-	    allocation of alien-value structure."))
-
-
-
-;;;; Extract/deposit magic
-
-(eval-when (compile eval)
-  (defmacro compiler-error-if-loses (form)
-    `(handler-case
-	 ,form
-       (error (condition)
-	 (compiler-error "~A" condition)))))
-
-(deftransform naturalize ((object type) * * :important t)
-  (unless (constant-continuation-p type)
-    (give-up "Type not constant at compile time; can't open code."))
-  (compiler-error-if-loses
-   (compute-naturalize-lambda (continuation-value type))))
-
-(deftransform deport ((alien type) * * :important t)
-  (unless (constant-continuation-p type)
-    (give-up "Type not constant at compile time; can't open code."))
-  (compiler-error-if-loses
-   (compute-deport-lambda (continuation-value type))))
-
-(deftransform extract-alien-value ((sap offset type) * * :important t)
-  (unless (constant-continuation-p type)
-    (give-up "Type not constant at compile time; can't open code."))
-  (compiler-error-if-loses
-   (compute-extract-lambda (continuation-value type))))
-
-(deftransform deposit-alien-value ((sap offset type value) * * :important t)
-  (unless (constant-continuation-p type)
-    (give-up "Type not constant at compile time; can't open code."))
-  (compiler-error-if-loses
-   (compute-deposit-lambda (continuation-value type))))
-
-
-;;;; Hack to clean up divisions.
-
-(defun count-low-order-zeros (thing)
-  (typecase thing
-    (continuation
-     (if (constant-continuation-p thing)
-	 (count-low-order-zeros (continuation-value thing))
-	 (count-low-order-zeros (continuation-use thing))))
-    (combination
-     (case (continuation-function-name (combination-fun thing))
-       ((+ -)
-	(let ((min most-positive-fixnum)
-	      (itype (specifier-type 'integer)))
-	  (dolist (arg (combination-args thing) min)
-	    (if (csubtypep (continuation-type arg) itype)
-		(setf min (min min (count-low-order-zeros arg)))
-		(return 0)))))
-       (*
-	(let ((result 0)
-	      (itype (specifier-type 'integer)))
-	  (dolist (arg (combination-args thing) result)
-	    (if (csubtypep (continuation-type arg) itype)
-		(setf result (+ result (count-low-order-zeros arg)))
-		(return 0)))))
-       (ash
-	(let ((args (combination-args thing)))
-	  (if (= (length args) 2)
-	      (let ((amount (second args)))
-		(if (constant-continuation-p amount)
-		    (max (+ (count-low-order-zeros (first args))
-			    (continuation-value amount))
-			 0)
-		    0))
-	      0)))
-       (t
-	0)))
-    (integer
-     (if (zerop thing)
-	 most-positive-fixnum
-	 (do ((result 0 (1+ result))
-	      (num thing (ash num -1)))
-	     ((logbitp 0 num) result))))
-    (t
-     0)))
-
-(deftransform / ((numerator denominator) (integer integer))
-  (unless (constant-continuation-p denominator)
-    (give-up))
-  (let* ((denominator (continuation-value denominator))
-	 (bits (1- (integer-length denominator))))
-    (unless (= (ash 1 bits) denominator)
-      (give-up))
-    (let ((alignment (count-low-order-zeros numerator)))
-      (unless (>= alignment bits)
-	(give-up))
-      `(ash numerator ,(- bits)))))
-
-(deftransform ash ((value amount))
-  (let ((value-node (continuation-use value)))
-    (unless (and (combination-p value-node)
-		 (eq (continuation-function-name (combination-fun value-node))
-		     'ash))
-      (give-up))
-    (let ((inside-args (combination-args value-node)))
-      (unless (= (length inside-args) 2)
-	(give-up))
-      (let ((inside-amount (second inside-args)))
-	(unless (and (constant-continuation-p inside-amount)
-		     (not (minusp (continuation-value inside-amount))))
-	  (give-up)))))
-  (extract-function-args value 'ash 2)
-  '(lambda (value amount1 amount2)
-     (ash value (+ amount1 amount2))))
-
-
-;;;; ALIEN-FUNCALL support.
-
-(deftransform alien-funcall ((function &rest args)
-			     ((alien (* t)) &rest *) *
-			     :important t)
-  (let ((names (loop repeat (length args) collect (gensym))))
-    `(lambda (function ,@names)
-       (alien-funcall (deref function) ,@names))))
-
-(deftransform alien-funcall ((function &rest args) * * :important t)
-  (let ((type (continuation-type function)))
-    (unless (alien-type-type-p type)
-      (give-up "Can't tell function type at compile time."))
-    (let ((alien-type (alien-type-type-alien-type type)))
-      (unless (alien-function-type-p alien-type)
-	(give-up))
-      (let ((arg-types (alien-function-type-arg-types alien-type)))
-	(unless (= (length args) (length arg-types))
-	  (abort-transform "Wrong number of arguments.  Expected ~D, got ~D."
-			   (length arg-types) (length args)))
-	(collect ((params) (deports))
-	  (dolist (arg-type arg-types)
-	    (let ((param (gensym)))
-	      (params param)
-	      (deports `(deport ,param ',arg-type))))
-	  (let ((return-type (alien-function-type-result-type alien-type))
-		(body `(%alien-funcall (deport function ',alien-type)
-				       ',alien-type
-				       ,@(deports))))
-	    (if (alien-values-type-p return-type)
-		(collect ((temps) (results))
-		  (dolist (type (alien-values-type-values return-type))
-		    (let ((temp (gensym)))
-		      (temps temp)
-		      (results `(naturalize ,temp ',type))))
-		  (setf body
-			`(multiple-value-bind
-			     ,(temps)
-			     ,body
-			   (values ,@(results)))))
-		(setf body `(naturalize ,body ',return-type)))
-	    `(lambda (function ,@(params))
-	       ,body)))))))
-
-(defoptimizer (%alien-funcall derive-type) ((function type &rest args))
-  (declare (ignore function args))
-  (unless (constant-continuation-p type)
-    (error "Something is broken."))
-  (let ((type (continuation-value type)))
-    (unless (alien-function-type-p type)
-      (error "Something is broken."))
-    (specifier-type
-     (compute-alien-rep-type
-      (alien-function-type-result-type type)))))
-
-(defoptimizer (%alien-funcall ltn-annotate)
-	      ((function type &rest args) node policy)
-  (setf (basic-combination-info node) :funny)
-  (setf (node-tail-p node) nil)
-  (annotate-ordinary-continuation function policy)
-  (dolist (arg args)
-    (annotate-ordinary-continuation arg policy)))
-
-(defoptimizer (%alien-funcall ir2-convert)
-	      ((function type &rest args) call block)
-  (let ((type (if (constant-continuation-p type)
-		  (continuation-value type)
-		  (error "Something is broken.")))
-	(cont (node-cont call))
-	(args args))
-    (multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
-			 (make-call-out-tns type)
-      (vop alloc-number-stack-space call block stack-frame-size nsp)
-      (dolist (tn arg-tns)
-	(let* ((arg (pop args))
-	       (sc (tn-sc tn))
-	       (scn (sc-number sc))
-	       (temp-tn (make-representation-tn (tn-primitive-type tn) scn))
-	       (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
-	  (assert arg)
-	  (assert (= (length move-arg-vops) 1) ()
-		  "No unique move-arg-vop for moves in SC ~S."
-		  (sc-name sc))
-	  (emit-move call block (continuation-tn call block arg) temp-tn)
-	  (emit-move-arg-template call block (first move-arg-vops)
-				  temp-tn nsp tn)))
-      (assert (null args))
-      (unless (listp result-tns)
-	(setf result-tns (list result-tns)))
-      (vop* call-out call block
-	    ((continuation-tn call block function)
-	     (reference-tn-list arg-tns nil))
-	    ((reference-tn-list result-tns t)))
-      (vop dealloc-number-stack-space call block stack-frame-size)
-      (move-continuation-result call block result-tns cont))))
diff --git a/compiler/alloc.lisp b/compiler/alloc.lisp
deleted file mode 100644
index 77d3408fb2c8036bb6519c8358b347644c77ea16..0000000000000000000000000000000000000000
--- a/compiler/alloc.lisp
+++ /dev/null
@@ -1,343 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alloc.lisp,v 1.10 1992/09/07 15:33:08 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Some storage allocation hacks for the compiler.
-;;; 
-;;; Written by Rob MacLachlan
-;;;
-(in-package "C")
-
-
-;;; A hack we we to defeat compile-time type checking in deinitializing slots
-;;; where there isn't any convenient legal value.
-;;;
-(defvar *undefined* '**undefined**)
-
-
-;;; ZAP-IN  --  Internal
-;;;
-;;;    A convenient macro for iterating over linked lists when we are
-;;; clobbering the next link as we go.
-;;;
-(defmacro zap-in ((var in slot) &body body)
-  (let ((next (gensym)))
-    `(let ((,var ,in) ,next)
-       (when ,var
-	 (loop
-	   (setq ,next (,slot ,var))
-	   ,@body
-	   (unless ,next (return))
-	   (setq ,var ,next))))))
-
-
-;;; DEFALLOCATERS  --  Internal
-;;;
-;;;    Define some structure freelisting operations.
-;;;
-(defmacro defallocators (&rest specs)
-  "defallocators {((name lambda-list [real-lambda-list]) thread-slot
-                   (deinit-form*)
-		   (reinit-form*))}*"
-  (collect ((hook-forms)
-	    (forms))
-    (dolist (spec specs)
-      (let* ((names (first spec))
-	     (name (first names))
-	     (lambda-list (second names))
-	     (real-lambda-list (or (third names) lambda-list))
-	     (fun-name (symbolicate "MAKE-" name))
-	     (unfun-name (symbolicate "UNMAKE-" name))
-	     (real-fun-name (symbolicate "REALLY-MAKE-" name))
-	     (var-name (symbolicate "*" name "-FREE-LIST*"))
-	     (slot (second spec)))
-	(forms `(proclaim '(inline ,fun-name ,unfun-name)))
-	(forms `(defvar ,var-name nil))
-	(forms `(defun ,fun-name ,lambda-list
-		  (declare (optimize (safety 0)))
-		  (let ((structure ,var-name))
-		    (cond (structure
-			   (setq ,var-name (,slot structure))
-			   ,@(fourth spec)
-			   structure)
-			  (t
-			   (,real-fun-name ,@real-lambda-list))))))
-	
-	(forms `(defun ,unfun-name (structure)
-		  (declare (optimize (safety 0)))
-		  ,@(third spec)
-		  #+nil
-		  (when (find-in #',slot structure ,var-name)
-		    (error "~S already deallocated!" structure))
-		  (setf (,slot structure) ,var-name)
-		  (setq ,var-name structure)))
-
-	(hook-forms
-	 `(progn
-	    (zap-in (structure ,var-name ,slot)
-	      (setf (,slot structure) nil))
-	    (setq ,var-name nil)))))
-
-    `(progn
-       ,@(forms)
-       (defun defallocator-deallocation-hook ()
-	 (declare (optimize (safety 0)))
-	 ,@(hook-forms))
-       (pushnew 'defallocator-deallocation-hook ext:*before-gc-hooks*))))
-
-
-(defmacro node-deinits ()
-  '(progn
-     (setf (node-derived-type structure) *wild-type*)
-     (setf (node-lexenv structure) *undefined*)
-     (setf (node-source-path structure) nil)
-     (setf (node-reoptimize structure) t)
-     (setf (node-cont structure) nil)
-     (setf (node-prev structure) nil)
-     (setf (node-tail-p structure) nil)))
-
-(defmacro node-inits ()
-  '(progn
-     (setf (node-lexenv structure) *lexical-environment*)
-     (setf (node-source-path structure) *current-path*)))
-
-
-(defallocators
-  ((continuation (&optional dest) (dest)) continuation-info
-   ((setf (continuation-kind structure) :unused)
-    (setf (continuation-dest structure) nil)
-    (setf (continuation-next structure) nil)
-    (setf (continuation-asserted-type structure) *wild-type*)
-    (setf (continuation-%derived-type structure) nil)
-    (setf (continuation-use structure) nil)
-    (setf (continuation-block structure) nil)
-    (setf (continuation-reoptimize structure) t)
-    (setf (continuation-%type-check structure) t))
-   ((setf (continuation-info structure) nil)
-    (setf (continuation-dest structure) dest)))
-  
-  ((block (start)) block-next
-   ((setf (block-pred structure) nil)
-    (setf (block-succ structure) nil)
-    (setf (block-start structure) nil)
-    (setf (block-start-uses structure) nil)
-    (setf (block-last structure) nil)
-    (setf (block-next structure) nil)
-    (setf (block-prev structure) nil)
-    (setf (block-flags structure)
-	  (block-attributes reoptimize flush-p type-check type-asserted
-			    test-modified))
-    (setf (block-kill structure) nil)
-    (setf (block-gen structure) nil)
-    (setf (block-in structure) nil)
-    (setf (block-out structure) nil)
-    (setf (block-flag structure) nil)
-    (setf (block-info structure) nil)
-    (setf (block-test-constraint structure) nil))
-   ((setf (block-component structure) *current-component*)
-    (setf (block-start structure) start)))
-  
-  ((ref (derived-type leaf)) node-source-path
-   ((node-deinits)
-    (setf (ref-leaf structure) *undefined*))
-   ((node-inits)
-    (setf (node-derived-type structure) derived-type)
-    (setf (ref-leaf structure) leaf)))
-  
-  ((combination (fun)) node-source-path
-   ((node-deinits)
-    (setf (basic-combination-fun structure) *undefined*)
-    (setf (basic-combination-args structure) nil)
-    (setf (basic-combination-kind structure) :full)
-    (setf (basic-combination-info structure) nil))
-   ((node-inits)
-    (setf (basic-combination-fun structure) fun)))
-  
-  ((ir2-block (block)) ir2-block-next
-   ((setf (ir2-block-number structure) nil)
-    (setf (ir2-block-block structure) *undefined*)
-    (setf (ir2-block-prev structure) nil)
-    (setf (ir2-block-pushed structure) nil)
-    (setf (ir2-block-popped structure) nil)
-    (setf (ir2-block-start-stack structure) nil)
-    (setf (ir2-block-end-stack structure) nil)
-    (setf (ir2-block-start-vop structure) nil)
-    (setf (ir2-block-last-vop structure) nil)
-    (setf (ir2-block-local-tn-count structure) 0)
-    (let ((ltns (ir2-block-local-tns structure)))
-      (dotimes (i local-tn-limit)
-	(setf (svref ltns i) nil)))
-    (clear-bit-vector (ir2-block-written structure))
-    (clear-bit-vector (ir2-block-live-in structure))
-    (setf (ir2-block-global-tns structure) nil)
-    (setf (ir2-block-%label structure) nil)
-    (setf (ir2-block-locations structure) nil))
-   ((setf (ir2-block-next structure) nil)
-    (setf (ir2-block-block structure) block)))
-  
-  ((vop (block node info args results)) vop-next
-   ((setf (vop-block structure) *undefined*)
-    (setf (vop-prev structure) nil)
-    (setf (vop-args structure) nil)
-    (setf (vop-results structure) nil)
-    (setf (vop-temps structure) nil)
-    (setf (vop-refs structure) nil)
-    (setf (vop-codegen-info structure) nil)
-    (setf (vop-node structure) nil)
-    (setf (vop-save-set structure) nil))
-   ((setf (vop-next structure) nil)
-    (setf (vop-block structure) block)
-    (setf (vop-node structure) node)
-    (setf (vop-info structure) info)
-    (setf (vop-args structure) args)
-    (setf (vop-results structure) results)))
-  
-  ((tn-ref (tn write-p)) tn-ref-next
-   ((setf (tn-ref-tn structure) *undefined*)
-    (setf (tn-ref-vop structure) nil)
-    (setf (tn-ref-next-ref structure) nil)
-    (setf (tn-ref-across structure) nil)
-    (setf (tn-ref-target structure) nil)
-    (setf (tn-ref-load-tn structure) nil))
-   ((setf (tn-ref-next structure) nil)
-    (setf (tn-ref-tn structure) tn)
-    (setf (tn-ref-write-p structure) write-p)))
-  
-  ((tn (number kind primitive-type sc)) tn-next
-   ((setf (tn-leaf structure) nil)
-    (setf (tn-reads structure) nil)
-    (setf (tn-writes structure) nil)
-    (setf (tn-next* structure) nil)
-    (setf (tn-local structure) nil)
-    (setf (tn-local-number structure) nil)
-    ;;
-    ;; Has been clobbered in global TNs...
-    (if (tn-global-conflicts structure)
-	(setf (tn-local-conflicts structure)
-	      (make-array local-tn-limit :element-type 'bit
-			  :initial-element 0))
-	(clear-bit-vector (tn-local-conflicts structure)))
-    
-    (setf (tn-global-conflicts structure) nil)
-    (setf (tn-current-conflict structure) nil)
-    (setf (tn-save-tn structure) nil)
-    (setf (tn-offset structure) nil)
-    (setf (tn-environment structure) nil)
-    (setf (tn-cost structure) 0))
-   ((setf (tn-next structure) nil)
-    (setf (tn-number structure) number)
-    (setf (tn-kind structure) kind)
-    (setf (tn-primitive-type structure) primitive-type)
-    (setf (tn-sc structure) sc)))
-  
-  ((global-conflicts (kind tn block number)) global-conflicts-next
-   ((setf (global-conflicts-block structure) *undefined*)
-    (clear-bit-vector (global-conflicts-conflicts structure))
-    (setf (global-conflicts-tn structure) *undefined*)
-    (setf (global-conflicts-tn-next structure) nil))
-   ((setf (global-conflicts-next structure) nil)
-    (setf (global-conflicts-kind structure) kind)
-    (setf (global-conflicts-tn structure) tn)
-    (setf (global-conflicts-block structure) block)
-    (setf (global-conflicts-number structure) number))))
-
-
-;;; NUKE-IR2-COMPONENT  --  Interface
-;;;
-;;;    Destroy the connectivity of the IR2 as much as possible in an attempt to
-;;; reduce GC lossage.
-;;;
-(defun nuke-ir2-component (component)
-  (declare (type component component))
-  (zap-in (block (block-info (component-head component)) ir2-block-next)
-    (zap-in (conf (ir2-block-global-tns block) global-conflicts-next)
-      (unmake-global-conflicts conf))
-
-    (zap-in (vop (ir2-block-start-vop block) vop-next)
-      (zap-in (ref (vop-refs vop) tn-ref-next-ref)
-	(let ((ltn (tn-ref-load-tn ref)))
-	  (when ltn
-	    (unmake-tn ltn)))
-	(unmake-tn-ref ref))
-      (unmake-vop vop))
-    (unmake-ir2-block block))
-    
-  (let ((2comp (component-info component)))
-    (macrolet ((blast (slot)
-		 `(progn
-		    (zap-in (tn (,slot 2comp) tn-next)
-		      (unmake-tn tn))
-		    (setf (,slot 2comp) nil))))
-      (blast ir2-component-normal-tns)
-      (blast ir2-component-restricted-tns)
-      (blast ir2-component-wired-tns)
-      (blast ir2-component-constant-tns))
-    (setf (ir2-component-component-tns 2comp) nil)
-    (setf (ir2-component-nfp 2comp) nil)
-    (setf (ir2-component-values-receivers 2comp) nil)
-    (setf (ir2-component-constants 2comp) '#())
-    (setf (ir2-component-format 2comp) nil)
-    (setf (ir2-component-entries 2comp) nil))
-
-  (undefined-value))
-
-
-;;; MACERATE-IR1-COMPONENT  --  Interface
-;;;
-(defun macerate-ir1-component (component)
-  (declare (type component component) (optimize (safety 0)))
-  (zap-in (block (component-head component) block-next)
-    (when (block-start block)
-      (let ((cont (block-start block))
-	    (last-cont (node-cont (block-last block)))
-	    next-cont
-	    node)
-	(loop
-	  (setq node (continuation-next cont))
-	  (setq next-cont (node-cont node))
-	  (typecase node
-	    (ref (unmake-ref node))
-	    (combination (unmake-combination node))
-	    (t
-	     (let ((structure node))
-	       (node-deinits))))
-	  (unmake-continuation cont)
-	  (when (eq next-cont last-cont)
-	    (when (eq (continuation-block next-cont) block)
-	      (unmake-continuation next-cont))
-	    (return))
-	  (setq cont next-cont))))
-    (unmake-block block))
-
-  (dolist (fun (component-lambdas component))
-    (setf (leaf-refs fun) nil)
-    (let ((tails (lambda-tail-set fun)))
-      (when tails
-	(setf (tail-set-info tails) nil)))
-    (let ((env (lambda-environment fun)))
-      (setf (environment-info env) nil)
-      (setf (environment-function env) *undefined*)
-      (dolist (nlx (environment-nlx-info env))
-	(setf (nlx-info-info nlx) nil)))
-    (macrolet ((frob (fun)
-		 `(progn
-		    (dolist (var (lambda-vars ,fun))
-		      (setf (leaf-refs var) nil)
-		      (setf (basic-var-sets var) nil)
-		      (setf (leaf-info var) nil))
-		    (setf (lambda-vars ,fun) nil)
-		    (setf (lambda-environment ,fun) nil))))
-      (frob fun)
-      (dolist (let (lambda-lets fun))
-	(frob let)
-	(setf (lambda-home let) nil))
-      (setf (lambda-lets fun) nil))))
diff --git a/compiler/array-tran.lisp b/compiler/array-tran.lisp
deleted file mode 100644
index 28ea744e454485d4cdba15dd7d23d9fce877a459..0000000000000000000000000000000000000000
--- a/compiler/array-tran.lisp
+++ /dev/null
@@ -1,571 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.14 1991/11/12 14:14:14 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains array specific optimizers and transforms.
-;;; 
-;;; Extracted from srctran and extended by William Lott.
-;;;
-(in-package "C")
-
-
-;;;; Derive-Type Optimizers
-
-;;; ASSERT-ARRAY-RANK  -- internal
-;;;
-;;; Array operations that use a specific number of indices implicitly assert
-;;; that the array is of that rank.
-;;; 
-(defun assert-array-rank (array rank)
-  (assert-continuation-type
-   array
-   (specifier-type `(array * ,(make-list rank :initial-element '*)))))
-  
-;;; EXTRACT-ELEMENT-TYPE  -- internal
-;;;
-;;; Array access functions return an object from the array, hence it's type
-;;; is going to be the array element type.
-;;;
-(defun extract-element-type (array)
-  (let ((type (continuation-type array)))
-    (if (array-type-p type)
-	(array-type-element-type type)
-	*universal-type*)))
-
-;;; ASSERT-NEW-VALUE-TYPE  --  internal
-;;;
-;;; The ``new-value'' for array setters must fit in the array, and the
-;;; return type is going to be the same as the new-value for setf functions.
-;;; 
-(defun assert-new-value-type (new-value array)
-  (let ((type (continuation-type array)))
-    (when (array-type-p type)
-      (assert-continuation-type new-value (array-type-element-type type))))
-  (continuation-type new-value))
-
-;;; 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)))))
-
-
-;;; ARRAY-IN-BOUNDS-P  --  derive-type optimizer.
-;;;
-(defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
-  (assert-array-rank array (length indices))
-  *universal-type*)
-
-;;; AREF  --  derive-type optimizer.
-;;;
-(defoptimizer (aref derive-type) ((array &rest indices))
-  (assert-array-rank array (length indices))
-  (extract-element-type array))
-
-;;; %ASET  --  derive-type optimizer.
-;;;
-(defoptimizer (%aset derive-type) ((array &rest stuff))
-  (assert-array-rank array (1- (length stuff)))
-  (assert-new-value-type (car (last stuff)) array))
-
-;;; DATA-VECTOR-REF  --  derive-type optimizer.
-;;;
-(defoptimizer (data-vector-ref derive-type) ((array index))
-  (extract-element-type array))
-
-;;; DATA-VECTOR-SET  --  derive-type optimizer.
-;;;
-(defoptimizer (data-vector-set derive-type) ((array index new-value))
-  (assert-new-value-type new-value array))
-
-;;; %WITH-ARRAY-DATA  --  derive-type optimizer.
-;;;
-;;;    Figure out the type of the data vector if we know the argument element
-;;; type.
-;;;
-(defoptimizer (%with-array-data derive-type) ((array start end))
-  (let ((atype (continuation-type array)))
-    (when (array-type-p atype)
-      (values-specifier-type
-       `(values (simple-array ,(type-specifier
-				(array-type-element-type atype))
-			      (*))
-		index index index)))))
-
-
-;;; ARRAY-ROW-MAJOR-INDEX  --  derive-type optimizer.
-;;;
-(defoptimizer (array-row-major-index derive-type) ((array &rest indices))
-  (assert-array-rank array (length indices))
-  *universal-type*)
-
-;;; ROW-MAJOR-AREF  --  derive-type optimizer.
-;;;
-(defoptimizer (row-major-aref derive-type) ((array index))
-  (extract-element-type array))
-  
-;;; %SET-ROW-MAJOR-AREF  --  derive-type optimizer.
-;;;
-(defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
-  (assert-new-value-type new-value array))
-
-;;; MAKE-ARRAY  --  derive-type optimizer.
-;;; 
-(defoptimizer (make-array derive-type)
-	      ((dims &key initial-element element-type initial-contents
-		adjustable fill-pointer displaced-index-offset displaced-to))
-  (let ((simple (and (unsupplied-or-nil adjustable)
-		     (unsupplied-or-nil displaced-to)
-		     (unsupplied-or-nil fill-pointer))))
-    (specifier-type
-     `(,(if simple 'simple-array 'array)
-       ,(cond ((not element-type) 't)
-	      ((constant-continuation-p element-type)
-	       (continuation-value element-type))
-	      (t
-	       '*))
-       ,(cond ((not simple)
-	       '*)
-	      ((constant-continuation-p dims)
-	       (let ((val (continuation-value dims)))
-		 (if (listp val) val (list val))))
-	      ((csubtypep (continuation-type dims)
-			  (specifier-type 'integer))
-	       '(*))
-	      (t
-	       '*))))))
-
-
-;;;; Constructors.
-
-;;; VECTOR  --  source-transform.
-;;;
-;;; Convert VECTOR into a make-array followed by setfs of all the elements.
-;;;
-(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))))
-
-
-;;; MAKE-STRING  --  source-transform.
-;;; 
-;;; Just convert it into a make-array.
-;;;
-(def-source-transform make-string (length &key (initial-element #\NULL))
-  `(make-array (the index ,length)
-	       :element-type 'base-char
-	       :initial-element ,initial-element))
-
-(defconstant array-info
-  '((base-char #\NULL 8 vm:simple-string-type)
-    (single-float 0.0s0 32 vm:simple-array-single-float-type)
-    (double-float 0.0d0 64 vm:simple-array-double-float-type)
-    (bit 0 1 vm:simple-bit-vector-type)
-    ((unsigned-byte 2) 0 2 vm:simple-array-unsigned-byte-2-type)
-    ((unsigned-byte 4) 0 4 vm:simple-array-unsigned-byte-4-type)
-    ((unsigned-byte 8) 0 8 vm:simple-array-unsigned-byte-8-type)
-    ((unsigned-byte 16) 0 16 vm:simple-array-unsigned-byte-16-type)
-    ((unsigned-byte 32) 0 32 vm:simple-array-unsigned-byte-32-type)
-    (t 0 32 vm:simple-vector-type)))
-
-;;; MAKE-ARRAY  --  source-transform.
-;;;
-;;; The integer type restriction on the length assures that it will be a
-;;; vector.  The lack of adjustable, fill-pointer, and displaced-to keywords
-;;; assures that it will be simple.
-;;;
-(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)))
-	 (eltype-type (specifier-type eltype)))
-    (multiple-value-bind
-	(default-initial-element element-size typecode)
-	(dolist (info array-info
-		      (give-up "Cannot open-code creation of ~S" spec))
-	  (when (csubtypep eltype-type (specifier-type (car info)))
-	    (return (values-list (cdr info)))))
-      (let* ((nwords-form
-	      (if (>= element-size vm:word-bits)
-		  `(* length ,(/ element-size vm:word-bits))
-		  (let ((elements-per-word (/ 32 element-size)))
-		    `(truncate (+ length
-				  ,(if (eq 'vm:simple-string-type typecode)
-				       elements-per-word
-				       (1- elements-per-word)))
-			       ,elements-per-word))))
-	     (constructor
-	      `(truly-the ,spec
-			  (allocate-vector ,typecode length ,nwords-form))))
-	(values
-	 (if (and default-initial-element
-		  (or (null initial-element)
-		      (and (constant-continuation-p initial-element)
-			   (eql (continuation-value initial-element)
-				default-initial-element))))
-	     constructor
-	     `(truly-the ,spec (fill ,constructor initial-element)))
-	 '((declare (type index length))))))))
-
-;;; MAKE-ARRAY  --  transform.
-;;;
-;;; The list type restriction does not assure that the result will be a
-;;; multi-dimensional array.  But the lack of 
-;;; 
-(deftransform make-array ((dims &key initial-element element-type)
-			  (list &rest *))
-  (unless (or (null element-type) (constant-continuation-p element-type))
-    (give-up "Element-type not constant; cannot open code array creation")) 
-  (unless (constant-continuation-p dims)
-    (give-up "Dimension list not constant; cannot open code array creation"))
-  (let ((dims (continuation-value dims)))
-    (unless (every #'integerp dims)
-      (give-up "Dimension list contains something other than an integer: ~S"
-	       dims))
-    (if (= (length dims) 1)
-	`(make-array ',(car dims)
-		     ,@(when initial-element
-			 '(:initial-element initial-element))
-		     ,@(when element-type
-			 '(:element-type element-type)))
-	(let* ((total-size (reduce #'* dims))
-	       (rank (length dims))
-	       (spec `(simple-array
-		       ,(cond ((null element-type) t)
-			      ((constant-continuation-p element-type)
-			       (continuation-value element-type))
-			      (t '*))
-			   ,(make-list rank :initial-element '*))))
-	  `(let ((header (make-array-header vm:simple-array-type ,rank)))
-	     (setf (%array-fill-pointer header) ,total-size)
-	     (setf (%array-fill-pointer-p header) nil)
-	     (setf (%array-available-elements header) ,total-size)
-	     (setf (%array-data-vector header)
-		   (make-array ,total-size
-			       ,@(when element-type
-				   '(:element-type element-type))
-			       ,@(when initial-element
-				   '(:initial-element initial-element))))
-	     (setf (%array-displaced-p header) nil)
-	     ,@(let ((axis -1))
-		 (mapcar #'(lambda (dim)
-			     `(setf (%array-dimension header ,(incf axis))
-				    ,dim))
-			 dims))
-	     (truly-the ,spec header))))))
-
-
-;;;; Random properties of arrays.
-
-;;; Transforms for various random array properties.  If the property is know
-;;; at compile time because of a type spec, use that constant value.
-
-;;; ARRAY-RANK  --  transform.
-;;;
-;;; If we can tell the rank from the type info, use it instead.
-;;;
-(deftransform array-rank ((array))
-  (let ((array-type (continuation-type array)))
-    (unless (array-type-p array-type)
-      (give-up))
-    (let ((dims (array-type-dimensions array-type)))
-      (if (not (listp dims))
-	  (give-up "Array rank not known at compile time: ~S" dims)
-	  (length dims)))))
-
-;;; ARRAY-DIMENSION  --  transform.
-;;;
-;;; If we know the dimensions at compile time, just use it.  Otherwise, if
-;;; we can tell that the axis is in bounds, convert to %array-dimension
-;;; (which just indirects the array header) or length (if it's simple and a
-;;; vector).
-;;;
-(deftransform array-dimension ((array axis)
-			       (array index))
-  (unless (constant-continuation-p axis)
-    (give-up "Axis not constant."))
-  (let ((array-type (continuation-type array))
-	(axis (continuation-value axis)))
-    (unless (array-type-p array-type)
-      (give-up))
-    (let ((dims (array-type-dimensions array-type)))
-      (unless (listp dims)
-	(give-up
-	 "Array dimensions unknown, must call array-dimension at runtime."))
-      (unless (> (length dims) axis)
-	(abort-transform "Array has dimensions ~S, ~D is too large."
-			 dims axis))
-      (let ((dim (nth axis dims)))
-	(cond ((integerp dim)
-	       dim)
-	      ((= (length dims) 1)
-	       (ecase (array-type-complexp array-type)
-		 ((t)
-		  '(%array-dimension array 0))
-		 ((nil)
-		  '(length array))
-		 (*
-		  (give-up "Can't tell if array is simple."))))
-	      (t
-	       '(%array-dimension array axis)))))))
-
-;;; LENGTH  --  transform.
-;;;
-;;; If the length has been declared and it's simple, just return it.
-;;;
-(deftransform length ((vector)
-		      ((simple-array * (*))))
-  (let ((type (continuation-type vector)))
-    (unless (array-type-p type)
-      (give-up))
-    (let ((dims (array-type-dimensions type)))
-      (unless (and (listp dims) (integerp (car dims)))
-	(give-up "Vector length unknown, must call length at runtime."))
-      (car dims))))
-
-;;; LENGTH  --  transform.
-;;;
-;;; All vectors can get their length by using vector-length.  If it's simple,
-;;; it will extract the length slot from the vector.  It it's complex, it will
-;;; extract the fill pointer slot from the array header.
-;;;
-(deftransform length ((vector) (vector))
-  '(vector-length vector))
-
-
-;;; If a simple array with known dimensions, then vector-length is a
-;;; compile-time constant.
-;;;
-(deftransform vector-length ((vector) ((simple-array * (*))))
-  (let ((vtype (continuation-type vector)))
-    (if (array-type-p vtype)
-	(let ((dim (first (array-type-dimensions vtype))))
-	  (when (eq dim '*) (give-up))
-	  dim)
-	(give-up))))
-
-
-;;; ARRAY-TOTAL-SIZE  --  transform.
-;;;
-;;; Again, if we can tell the results from the type, just use it.  Otherwise,
-;;; if we know the rank, convert into a computation based on array-dimension.
-;;; We can wrap a truly-the index around the multiplications because we know
-;;; that the total size must be an index.
-;;; 
-(deftransform array-total-size ((array)
-				(array))
-  (let ((array-type (continuation-type array)))
-    (unless (array-type-p array-type)
-      (give-up))
-    (let ((dims (array-type-dimensions array-type)))
-      (unless (listp dims)
-	(give-up "Can't tell the rank at compile time."))
-      (if (member '* dims)
-	  (do ((form 1 `(truly-the index
-				   (* (array-dimension array ,i) ,form)))
-	       (i 0 (1+ i)))
-	      ((= i (length dims)) form))
-	  (reduce #'* dims)))))
-
-;;; ARRAY-HAS-FILL-POINTER-P  --  transform.
-;;;
-;;; Only complex vectors have fill pointers.
-;;;
-(deftransform array-has-fill-pointer-p ((array))
-  (let ((array-type (continuation-type array)))
-    (unless (array-type-p array-type)
-      (give-up))
-    (let ((dims (array-type-dimensions array-type)))
-      (if (and (listp dims) (not (= (length dims) 1)))
-	  nil
-	  (ecase (array-type-complexp array-type)
-	    ((t)
-	     t)
-	    ((nil)
-	     nil)
-	    (*
-	     (give-up "Array type ambiguous; must call ~
-	              array-has-fill-pointer-p at runtime.")))))))
-
-;;; %CHECK-BOUND  --  transform.
-;;; 
-;;; Primitive used to verify indicies into arrays.  If we can tell at
-;;; compile-time or we are generating unsafe code, don't bother with the VOP.
-;;;
-(deftransform %check-bound ((array dimension index))
-  (unless (constant-continuation-p dimension)
-    (give-up))
-  (let ((dim (continuation-value dimension)))
-    `(the (integer 0 ,dim) index)))
-;;;
-(deftransform %check-bound ((array dimension index) * *
-			    :policy (and (> speed safety) (= safety 0)))
-  'index)
-
-
-;;; WITH-ROW-MAJOR-INDEX  --  internal.
-;;;
-;;; Handy macro for computing the row-major index given a set of indices.  We
-;;; wrap each index with a call to %check-bound to assure that everything
-;;; works out correctly.  We can wrap all the interior arith with truly-the
-;;; index because we know the the resultant row-major index must be an index.
-;;; 
-(eval-when (compile eval)
-;;;
-(defmacro with-row-major-index ((array indices index &optional new-value)
-				&rest body)
-  `(let (n-indices dims)
-     (dotimes (i (length ,indices))
-       (push (make-symbol (format nil "INDEX-~D" i)) n-indices)
-       (push (make-symbol (format nil "DIM-~D" i)) dims))
-     (setf n-indices (nreverse n-indices))
-     (setf dims (nreverse dims))
-     `(lambda (,',array ,@n-indices ,@',(when new-value (list new-value)))
-	(let* (,@(let ((,index -1))
-		   (mapcar #'(lambda (name)
-			       `(,name (array-dimension ,',array
-							,(incf ,index))))
-			   dims))
-	       (,',index
-		,(if (null dims)
-		     0
-		     (do* ((dims dims (cdr dims))
-			   (indices n-indices (cdr indices))
-			   (last-dim nil (car dims))
-			   (form `(%check-bound ,',array
-						,(car dims)
-						,(car indices))
-				 `(truly-the index
-					     (+ (truly-the index
-							   (* ,form
-							      ,last-dim))
-						(%check-bound
-						 ,',array
-						 ,(car dims)
-						 ,(car indices))))))
-			  ((null (cdr dims)) form)))))
-	  ,',@body))))
-;;;
-); eval-when
-
-;;; ARRAY-ROW-MAJOR-INDEX  --  transform.
-;;;
-;;; Just return the index after computing it.
-;;;
-(deftransform array-row-major-index ((array &rest indices))
-  (with-row-major-index (array indices index)
-    index))
-
-
-
-;;;; Array accessors:
-
-;;; SVREF, %SVSET, SCHAR, %SCHARSET, CHAR,
-;;; %CHARSET, SBIT, %SBITSET, BIT, %BITSET
-;;;   --  source transforms.
-;;;
-;;; We convert all typed array accessors into aref and %aset with type
-;;; assertions on the array.
-;;;
-(macrolet ((frob (reffer setter type)
-	     `(progn
-		(def-source-transform ,reffer (a &rest i)
-		  `(aref (the ,',type ,a) ,@i))
-		(def-source-transform ,setter (a &rest i)
-		  `(%aset (the ,',type ,a) ,@i)))))
-  (frob svref %svset simple-vector)
-  (frob schar %scharset simple-string)
-  (frob char %charset string)
-  (frob sbit %sbitset (simple-array bit))
-  (frob bit %bitset (array bit)))
-
-;;; AREF, %ASET  --  transform.
-;;; 
-;;; Convert into a data-vector-ref (or set) with the set of indices replaced
-;;; with the an expression for the row major index.
-;;; 
-(deftransform aref ((array &rest indices))
-  (with-row-major-index (array indices index)
-    (data-vector-ref array index)))
-;;; 
-(deftransform %aset ((array &rest stuff))
-  (let ((indices (butlast stuff)))
-    (with-row-major-index (array indices index new-value)
-      (data-vector-set array index new-value))))
-
-;;; ROW-MAJOR-AREF, %SET-ROW-MAJOR-AREF  --  transform.
-;;;
-;;; Just convert into a data-vector-ref (or set) after checking that the
-;;; index is inside the array total size.
-;;;
-(deftransform row-major-aref ((array index))
-  `(data-vector-ref array (%check-bound array (array-total-size array) index)))
-;;; 
-(deftransform %set-row-major-aref ((array index new-value))
-  `(data-vector-set array
-		    (%check-bound array (array-total-size array) index)
-		    new-value))
-
-
-;;;; Bit-vector array operation canonicalization:
-;;;
-;;;    We convert all bit-vector operations to have the result array specified.
-;;; This allows any result allocation to be open-coded, and eliminates the need
-;;; for any VM-dependent transforms to handle these cases.
-
-(dolist (fun '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1
-		       bit-andc2 bit-orc1 bit-orc2))
-  ;;
-  ;; Make a result array if result is NIL or unsupplied.
-  (deftransform fun ((bit-array-1 bit-array-2 &optional result-bit-array)
-		     '(bit-vector bit-vector &optional null) '*
-		     :eval-name t  :policy (>= speed space))
-    `(,fun bit-array-1 bit-array-2
-	   (make-array (length bit-array-1) :element-type 'bit)))
-  ;;
-  ;; If result its T, make it the first arg.
-  (deftransform fun ((bit-array-1 bit-array-2 result-bit-array)
-		     '(bit-vector bit-vector (member t)) '*
-		     :eval-name t)
-    `(,fun bit-array-1 bit-array-2 bit-array-1)))
-
-;;; Similar for BIT-NOT, but there is only one arg...
-;;;
-(deftransform bit-not ((bit-array-1 &optional result-bit-array)
-		       (bit-vector &optional null) *
-		       :policy (>= speed space))
-  '(bit-not bit-array-1 
-	    (make-array (length bit-array-1) :element-type 'bit)))
-;;;
-(deftransform bit-not ((bit-array-1 result-bit-array)
-		       (bit-vector (constant-argument t)))
-  '(bit-not bit-array-1 bit-array-1)))
diff --git a/compiler/backend.lisp b/compiler/backend.lisp
deleted file mode 100644
index 1e5daeeb2ca70bcdd1538ba2c85f1d8b57c9b371..0000000000000000000000000000000000000000
--- a/compiler/backend.lisp
+++ /dev/null
@@ -1,318 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/backend.lisp,v 1.26 1992/08/04 08:31:33 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file isolates all the backend specific data so that we can compile
-;;; and use different backends.
-;;; 
-;;; Written by William Lott.
-;;;
-(in-package "C")
-
-(export '(*backend* *target-backend* *native-backend* backend
-	  backend-name backend-version backend-fasl-file-type
-	  backend-fasl-file-implementation backend-fasl-file-version
-	  backend-register-save-penalty backend-byte-order
-	  backend-any-primitive-type backend-info-environment
-	  backend-instruction-formats backend-instruction-flavors
-	  backend-assembler-resources backend-special-arg-types
-	  backend-disassem-params backend-internal-errors
-	  backend-assembler-params backend-page-size
-	  
-	  ;; The various backends need to call these support routines
-	  def-vm-support-routine make-stack-pointer-tn primitive-type
-	  primitive-type-of emit-nop location-number))
-
-
-;;;; VM support routine stuff.
-
-(eval-when (compile eval)
-
-(defmacro def-vm-support-routines (&rest routines)
-  `(progn
-     (eval-when (compile load eval)
-       (defparameter vm-support-routines ',routines))
-     (defstruct (vm-support-routines
-		 (:print-function %print-vm-support-routines))
-       ,@(mapcar #'(lambda (routine)
-		     `(,routine nil :type (or function null)))
-		 routines))
-     ,@(mapcar
-	#'(lambda (name)
-	    `(defun ,name (&rest args)
-	       (apply (or (,(symbolicate "VM-SUPPORT-ROUTINES-" name)
-			   (backend-support-routines *backend*))
-			  (error "Machine specific support routine ~S ~
-				  undefined for ~S"
-				 ',name *backend*))
-		      args)))
-	routines)))
-
-); eval-when
-
-(def-vm-support-routines
-  ;; From VM.LISP
-  immediate-constant-sc
-  location-print-name
-  
-  ;; From PRIMTYPE.LISP
-  primitive-type-of
-  primitive-type
-  
-  ;; From C-CALL.LISP
-  make-call-out-tns
-  
-  ;; From CALL.LISP
-  standard-argument-location
-  make-return-pc-passing-location
-  make-old-fp-passing-location
-  make-old-fp-save-location
-  make-return-pc-save-location
-  make-argument-count-location
-  make-nfp-tn
-  make-stack-pointer-tn
-  make-number-stack-pointer-tn
-  make-unknown-values-locations
-  select-component-format
-  
-  ;; From NLX.LISP
-  make-nlx-sp-tn
-  make-dynamic-state-tns
-  
-  ;; From SUPPORT.LISP
-  generate-call-sequence
-  generate-return-sequence
-
-  ;; For use with scheduler.
-  emit-nop
-  location-number)
-
-(defprinter vm-support-routines)
-
-(defmacro def-vm-support-routine (name ll &body body)
-  (unless (member (intern (string name) (find-package "C"))
-		  vm-support-routines)
-    (warn "Unknown VM support routine: ~A" name))
-  (let ((local-name (symbolicate (backend-name *target-backend*) "-" name)))
-    `(progn
-       (defun ,local-name ,ll ,@body)
-       (setf (,(intern (concatenate 'simple-string
-				    "VM-SUPPORT-ROUTINES-"
-				    (string name))
-		       (find-package "C"))
-	      (backend-support-routines *target-backend*))
-	     #',local-name))))
-
-
-
-;;;; The backend structure.
-
-(defstruct (backend
-	    (:print-function %print-backend))
-  ;; The name of this backend.  Something like ``PMAX''
-  (name nil)
-
-  ;; The version string for this backend.
-  ;; Something like ``DECstation 3100/Mach 0.0''
-  (version nil)
-
-  ;; Information about fasl files for this backend.
-  (fasl-file-type nil)
-  (fasl-file-implementation nil)
-  (fasl-file-version nil)
-
-  ;; The VM support routines.
-  (support-routines (make-vm-support-routines) :type vm-support-routines)
-
-  ;; The number of references that a TN must have to offset the overhead of
-  ;; saving the TN across a call.
-  (register-save-penalty 0)
-
-  ;; 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).
-  (byte-order nil :type (or null (member :little-endian :big-endian)))
-
-  ;; 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.
-  (sc-numbers (make-array sc-number-limit :initial-element nil)
-	      :type sc-vector)
-
-  ;; A list of all the SBs defined, so that we can easily iterate over them.
-  (sb-list () :type list)
-
-  ;; Translates from template names to template structures.
-  (template-names (make-hash-table :test #'eq) :type hash-table)
-
-  ;; Hashtable from SC and SB names the corresponding structures.  The META
-  ;; versions are only used at meta-compile and load times, so the defining
-  ;; macros can change these at meta-compile time without breaking the
-  ;; compiler.
-  (sc-names (make-hash-table :test #'eq) :type hash-table)
-  (sb-names (make-hash-table :test #'eq) :type hash-table)
-  (meta-sc-names (make-hash-table :test #'eq) :type hash-table)
-  (meta-sb-names (make-hash-table :test #'eq) :type hash-table)
-
-  ;; Like *SC-Numbers*, but is updated at meta-compile time.
-  (meta-sc-numbers (make-array sc-number-limit :initial-element nil)
-		   :type sc-vector)
-
-  ;; Translates from primitive type names to the corresponding primitive-type
-  ;; structure.
-  (primitive-type-names (make-hash-table :test #'eq) :type hash-table)
-
-  ;; Establishes a convenient handle on primitive type unions, or whatever.
-  ;; These names can only be used as the :arg-types or :result-types for VOPs
-  ;; and can map to anything else that can be used as :arg-types or
-  ;; :result-types (e.g. :or, :constant).
-  (primitive-type-aliases (make-hash-table :test #'eq) :type hash-table)
-
-  ;; Meta-compile time translation from names to primitive types.
-  (meta-primitive-type-names (make-hash-table :test #'eq) :type hash-table)
-
-  ;; 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.
-  (any-primitive-type nil :type (or null primitive-type))
-
-  ;; Hashtable translating from VOP names to the corresponding VOP-Parse
-  ;; structures.  This information is only used at meta-compile time.
-  (parsed-vops (make-hash-table :test #'eq) :type hash-table)
-
-  ;; The backend specific aspects of the info environment.
-  (info-environment nil :type list)
-
-  ;; Support for the assembler.
-  (instruction-formats (make-hash-table :test #'eq) :type hash-table)
-  (instruction-flavors (make-hash-table :test #'equal) :type hash-table)
-  (special-arg-types (make-hash-table :test #'eq) :type hash-table)
-  (assembler-resources nil :type list)
-
-  ;; The backend specific features list, if any.  During a compilation,
-  ;; *features* is bound to *features* - misfeatures + features.
-  (%features nil :type list)
-  (misfeatures nil :type list)
-
-  ;; Disassembler information.
-  (disassem-params nil :type t)
-
-  ;; Mappings between CTYPE structures and the corresponding predicate.
-  ;; The type->predicate mapping hash is an alist because there is no
-  ;; such thing as a type= hash table.
-  (predicate-types (make-hash-table :test #'eq) :type hash-table)
-  (type-predicates nil :type list)
-
-  ;; Vector of the internal errors defined for this backend, or NIL if
-  ;; they haven't been installed yet.
-  (internal-errors nil :type (or simple-vector null))
-
-  ;; Assembler parameters.
-  (assembler-params nil :type t)
-
-  ;; The maximum number of bytes per page on this system.  Used by genesis.
-  (page-size 0 :type index))
-
-
-(defprinter backend
-  name)
-
-
-(defvar *native-backend* (make-backend)
-  "The backend for the machine we are running on. Do not change this.")
-(defvar *target-backend* *native-backend*
-  "The backend we are attempting to compile.")
-(defvar *backend* *native-backend*
-  "The backend we are using to compile with.")
-
-
-
-;;;; Other utility functions for fiddling with the backend.
-
-(export '(backend-features target-featurep backend-featurep native-featurep))
-
-(defun backend-features (backend)
-  "Compute the *FEATURES* list to use with BACKEND."
-  (union (backend-%features backend)
-	 (set-difference *features*
-			 (backend-misfeatures backend))))
-
-(defun target-featurep (feature)
-  "Same as EXT:FEATUREP, except use the features found in *TARGET-BACKEND*."
-  (let ((*features* (backend-features *target-backend*)))
-    (featurep feature)))
-
-(defun backend-featurep (feature)
-  "Same as EXT:FEATUREP, except use the features found in *BACKEND*."
-  (let ((*features* (backend-features *backend*)))
-    (featurep feature)))
-
-(defun native-featurep (feature)
-  "Same as EXT:FEATUREP, except use the features found in *NATIVE-BACKEND*."
-  (let ((*features* (backend-features *native-backend*)))
-    (featurep feature)))
-
-
-;;; NEW-BACKEND
-;;;
-;;; Utility for creating a new backend structure for use with cross
-;;; compilers.
-;;;
-(defun new-backend (name features misfeatures)
-  ;; If VM names a different package, rename that package so that VM doesn't
-  ;; name it.  
-  (let ((pkg (find-package "VM")))
-    (when pkg
-      (let ((pkg-name (package-name pkg)))
-	(unless (string= pkg-name name)
-	  (rename-package pkg pkg-name
-			  (remove "VM" (package-nicknames pkg)
-				  :test #'string=))
-	  (unuse-package pkg "C")))))
-  ;; Make sure VM names our package, creating it if necessary.
-  (let* ((pkg (or (find-package name)
-		  (make-package name :nicknames '("VM"))))
-	 (nicknames (package-nicknames pkg)))
-    (unless (member "VM" nicknames :test #'string=)
-      (rename-package pkg name (cons "VM" nicknames)))
-    ;; And make sure we are using the necessary packages.
-    (use-package '("C-CALL" "ALIEN-INTERNALS" "ALIEN" "BIGNUM" "UNIX"
-		   "LISP" "KERNEL" "EXTENSIONS" "SYSTEM" "C")
-		 pkg))
-  ;; Make sure the native info env list is stored in *native-backend*
-  (unless (backend-info-environment *native-backend*)
-    (setf (backend-info-environment *native-backend*) *info-environment*))
-  ;; Cons up a backend structure, filling in the info-env and features slots.
-  (let ((backend (make-backend
-		  :name name
-		  :info-environment
-		  (cons (make-info-environment
-			 :name
-			 (concatenate 'string name " backend"))
-			(remove-if #'(lambda (name)
-				       (let ((len (length name)))
-					 (and (> len 8)
-					      (string= name " backend"
-						       :start1 (- len 8)))))
-				   *info-environment*
-				   :key #'info-env-name))
-		  :%features features
-		  :misfeatures misfeatures)))
-    (setf *target-backend* backend)
-    (define-standard-type-predicates)
-    backend))
diff --git a/compiler/bit-util.lisp b/compiler/bit-util.lisp
deleted file mode 100644
index 1536c9715300c3a4ac0166dcf12414192d9e2265..0000000000000000000000000000000000000000
--- a/compiler/bit-util.lisp
+++ /dev/null
@@ -1,57 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/bit-util.lisp,v 1.4 1991/02/20 14:56:42 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Bit-vector hacking utilities, potentially implementation-dependent for
-;;; speed.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(declaim (inline clear-bit-vector set-bit-vector bit-vector-replace
-		 bit-vector-copy))
-
-;;; 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 (make-array (length vec) :element-type 'bit)))
diff --git a/compiler/byte-comp.lisp b/compiler/byte-comp.lisp
deleted file mode 100644
index 8fcbea1da4a8549d4b3f63711eba4499c2169a13..0000000000000000000000000000000000000000
--- a/compiler/byte-comp.lisp
+++ /dev/null
@@ -1,1804 +0,0 @@
-;;; -*- Package: C -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/byte-comp.lisp,v 1.4 1992/09/07 15:33:39 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the noise to byte-compile stuff.  It uses the
-;;; same front end as the real compiler, but generates a byte-code instead
-;;; of native code.
-;;;
-;;; Written by William Lott
-;;;
-
-(in-package "C")
-
-;;; ### Remaining work:
-;;;
-;;; - add more inline operations & calls to two-arg functions.  structure slots
-;;; - Breakpoints/debugging info.
-;;; - The XEP needs to have the name, arglist, etc. in it. (?)
-;;;   compact small integer XEP slots into fixnum sub-fields.
-;;;
-
-
-;;;; Stuff to emit noise.
-
-;;; Note: we use the regular assembler, but we don't use any ``instructions''
-;;; because there is no way to keep our byte-code instructions seperate from
-;;; the instructions used by the native backend.  Besides, we don't want to do
-;;; any scheduling or anything like that, anyway.
-
-(declaim (inline output-byte))
-(defun output-byte (segment byte)
-  (declare (type new-assem:segment segment)
-	   (type (unsigned-byte 8) byte))
-  (new-assem:emit-byte segment byte))
-
-
-;;; OUTPUT-EXTENDED-OPERAND  --  Internal
-;;;
-;;;    Output Operand as 1 or 4 bytes, using #xFF as the extend code.
-;;;
-(defun output-extended-operand (segment operand)
-  (declare (type (unsigned-byte 24) operand))
-  (cond ((<= operand 254)
-	 (output-byte segment operand))
-	(t
-	 (output-byte segment #xFF)
-	 (output-byte segment (ldb (byte 8 16) operand))
-	 (output-byte segment (ldb (byte 8 8) operand))
-	 (output-byte segment (ldb (byte 8 0) operand)))))
-
-
-;;; OUTPUT-BYTE-WITH-OPERAND -- internal.
-;;;
-;;; Output a byte, logior'ing in a 4 bit immediate constant.  If that
-;;; immediate won't fit, then emit it as the next 1-4 bytes.
-;;; 
-(defun output-byte-with-operand (segment byte operand)
-  (declare (type new-assem:segment segment)
-	   (type (unsigned-byte 8) byte)
-	   (type (unsigned-byte 24) operand))
-  (cond ((<= operand 14)
-	 (output-byte segment (logior byte operand)))
-	(t
-	 (output-byte segment (logior byte 15))
-	 (output-extended-operand segment operand)))
-  (undefined-value))
-
-
-;;; OUTPUT-LABEL -- internal.
-;;;
-(defun output-label (segment label)
-  (declare (type new-assem:segment segment)
-	   (type new-assem:label label))
-  (new-assem:assemble (segment)
-    (new-assem:emit-label label)))
-
-;;; OUTPUT-REFERENCE -- internal.
-;;;
-;;; Output a reference to LABEL.  If RELATIVE is NIL, then this reference
-;;; can never be relative.
-;;;
-(defun output-reference (segment label)
-  (declare (type new-assem:segment segment)
-	   (type new-assem:label label))
-  (new-assem:emit-back-patch
-   segment
-   3
-   #'(lambda (segment posn)
-       (declare (type new-assem:segment segment)
-		(ignore posn))
-       (let ((target (new-assem:label-position label)))
-	 (assert (<= 0 target (1- (ash 1 24))))
-	 (output-byte segment (ldb (byte 8 16) target))
-	 (output-byte segment (ldb (byte 8 8) target))
-	 (output-byte segment (ldb (byte 8 0) target))))))
-
-;;; OUTPUT-BRANCH -- internal.
-;;;
-;;; Output some branch byte-sequence.
-;;; 
-(defun output-branch (segment kind label)
-  (declare (type new-assem:segment segment)
-	   (type (unsigned-byte 8) kind)
-	   (type new-assem:label label))
-  (new-assem:emit-chooser
-   segment 4 1
-   #'(lambda (segment posn delta)
-       (when (<= (- (ash 1 7))
-		 (- (new-assem:label-position label posn delta) posn 2)
-		 (1- (ash 1 7)))
-	 (new-assem:emit-chooser
-	  segment 2 1
-	  #'(lambda (segment posn delta)
-	      (declare (ignore segment) (type index posn delta))
-	      (when (zerop (- (new-assem:label-position label posn delta)
-			      posn 2))
-		;; Don't emit anything, because the branch is to the following
-		;; instruction.
-		t))
-	  #'(lambda (segment posn)
-	      ;; We know we fit in one byte.
-	      (declare (type new-assem:segment segment)
-		       (type index posn))
-	      (output-byte segment (logior kind 1))
-	      (output-byte segment
-			   (ldb (byte 8 0)
-				(- (new-assem:label-position label) posn 2)))))
-	 t))
-   #'(lambda (segment posn)
-       (declare (type new-assem:segment segment)
-		(ignore posn))
-       (let ((target (new-assem:label-position label)))
-	 (assert (<= 0 target (1- (ash 1 24))))
-	 (output-byte segment kind)
-	 (output-byte segment (ldb (byte 8 16) target))
-	 (output-byte segment (ldb (byte 8 8) target))
-	 (output-byte segment (ldb (byte 8 0) target))))))
-
-;;; BYTE-OUTPUT-LENGTH -- internal interface.
-;;;
-;;; Called by the dumping stuff to find out exactly how much noise it needs
-;;; to dump.
-;;;
-(defun byte-output-length (segment)
-  (declare (type new-assem:segment segment))
-  (new-assem:finalize-segment segment))
-
-
-
-;;;; System constants, Xops, and inline functions.
-
-(defvar *system-constants* (make-array 256))
-(defvar *system-constant-codes* (make-hash-table :test #'eq))
-
-(eval-when (compile eval)
-  (defmacro def-system-constant (index form)
-    `(let ((val ,form))
-       (setf (svref *system-constants* ,index) val)
-       (setf (gethash val *system-constant-codes*) ,index))))
-
-(def-system-constant 0 nil)
-(def-system-constant 1 t)
-(def-system-constant 2 :start)
-(def-system-constant 3 :end)
-(def-system-constant 4 :test)
-(def-system-constant 5 :count)
-(def-system-constant 6 :test-not)
-(def-system-constant 7 :key)
-(def-system-constant 8 :from-end)
-(def-system-constant 9 :type)
-
-(defparameter *xop-names*
-  '(breakpoint; 0
-    dup; 1
-    type-check; 2
-    fdefn-function-or-lose; 3
-    default-unknown-values; 4
-    xop5
-    xop6
-    xop7
-    merge-unknown-values
-    make-closure
-    throw
-    catch
-    breakup
-    return-from
-    tagbody
-    go
-    unwind-protect))
-
-(defun xop-index-or-lose (name)
-  (or (position name *xop-names* :test #'eq)
-      (error "Unknown XOP ~S" name)))
-
-
-(defstruct inline-function-info
-  function
-  number
-  type)
-
-(defparameter *inline-functions*
-  (let ((number -1))
-    (mapcar #'(lambda (stuff)
-		(destructuring-bind (name arg-types result-type) stuff
-		  (make-inline-function-info
-		   :function name
-		   :number (incf number)
-		   :type (specifier-type
-			  `(function ,arg-types ,result-type)))))
-	    '((+ (fixnum fixnum) fixnum)
-	      (- (fixnum fixnum) fixnum)
-	      (make-value-cell (t) t)
-	      (value-cell-ref (t) t)
-	      (value-cell-setf (t t) t)
-	      (symbol-value (symbol) t)
-	      (setf-symbol-value (t symbol) t)
-	      (%byte-special-bind (t symbol) (values))
-	      (%byte-special-unbind () (values))
-	      (cons-unique-tag () t)))))
-
-(defun inline-function-number-or-lose (function)
-  (let ((info (find function *inline-functions*
-		    :key #'inline-function-info-function)))
-    (if info
-	(inline-function-info-number info)
-	(error "Unknown inline function: ~S" function))))
-
-
-
-;;;; Annotations hung off the IR1 while compiling.
-
-
-(defstruct byte-component-info
-  (constants (make-array 10 :adjustable t :fill-pointer 0)))
-
-
-(defstruct byte-lambda-info
-  (label nil :type (or null label))
-  (stack-size 0 :type index)
-  (interesting t :type (member t nil)))
-
-(defun block-interesting (block)
-  (byte-lambda-info-interesting (lambda-info (block-home-lambda block))))
-
-(defstruct byte-lambda-var-info
-  (argp nil :type (member t nil))
-  (offset 0 :type index))
-
-(defstruct byte-nlx-info
-  (stack-slot nil :type (or null index))
-  (label (new-assem:gen-label) :type new-assem:label)
-  (duplicate nil :type (member t nil)))
-
-(defstruct (byte-block-info
-	    (:include block-annotation)
-	    (:print-function %print-byte-block-info)
-	    (:constructor make-byte-block-info
-			  (block &key produces produces-sset consumes
-			    total-consumes nlx-entries nlx-entry-p)))
-  (label (new-assem:gen-label) :type new-assem:label)
-  ;;
-  ;; A list of the continuations that this block pushes onto the stack.
-  (produces nil :type list)
-  ;;
-  ;; An SSET of the produces for faster set manipulations.
-  (produces-sset (make-sset) :type sset)
-  ;;
-  ;; A list of the continuations that this block pops from the stack.
-  (consumes nil :type list)
-  ;;
-  ;; The transitive closure of what this block and all its successors
-  ;; consume.  After stack-analysis, that is.
-  (total-consumes (make-sset) :type sset)
-  ;;
-  ;; Set to T whenever the consumes lists of a successor changes and the
-  ;; block is queued for re-analysis so we can easily avoid queueing the same
-  ;; block several times.
-  (already-queued nil :type (member t nil))
-  ;;
-  ;; The continuations on the stack (in order) when this block starts.
-  (start-stack :unknown :type (or (member :unknown) list))
-  ;;
-  ;; The continuations on the stack (in order) when this block ends.
-  (end-stack nil :type list)
-  ;;
-  ;; List of (nlx-infos . extra-stack-cruft) for each entry point in this
-  ;; block.
-  (nlx-entries nil :type list)
-  ;;
-  ;; T if this is an %nlx-entry point, and we shouldn't just assume we know
-  ;; what is going to be on the stack.
-  (nlx-entry-p nil :type (member t nil)))
-
-(defprinter byte-block-info
-  block)
-
-(defstruct (byte-continuation-info
-	    (:include sset-element)
-	    (:print-function %print-byte-continuation-info)
-	    (:constructor make-byte-continuation-info (continuation results)))
-  (continuation (required-argument) :type continuation)
-  (results (required-argument)
-	   :type (or (member :fdefinition :eq-test :unknown) unsigned-byte)))
-
-(defprinter byte-continuation-info
-  continuation
-  results)
-
-
-
-;;;; Annotate the IR1
-
-(defun annotate-continuation (cont results)
-  ;; For some reason, do-nodes does the same return node multiple times,
-  ;; which causes annotate-continuation to be called multiple times on the
-  ;; same continuation.  So we can't assert that we haven't done it.
-  #+nil
-  (assert (null (continuation-info cont)))
-  (setf (continuation-info cont)
-	(make-byte-continuation-info cont results))
-  (undefined-value))
-
-(defun annotate-set (set)
-  ;; Annotate the value for one value.
-  (annotate-continuation (set-value set) 1))
-
-(defun annotate-basic-combination-args (call)
-  (declare (type basic-combination call))
-  (etypecase call
-    (combination
-     (dolist (arg (combination-args call))
-       (when arg
-	 (annotate-continuation arg 1))))
-    (mv-combination
-     ;; Annoate the args.  We allow initial args to supply a fixed number of
-     ;; values, but everything after the first :unknown arg must also be
-     ;; unknown.  This picks off most of the standard uses (i.e. calls to
-     ;; apply), but still is easy to implement.
-     (labels
-	 ((allow-fixed (remaining)
-	    (when remaining
-	      (let* ((cont (car remaining))
-		     (values (nth-value 1
-					(values-types
-					 (continuation-derived-type cont)))))
-		(cond ((eq values :unknown)
-		       (force-to-unknown remaining))
-		      (t
-		       (annotate-continuation cont values)
-		       (allow-fixed (cdr remaining)))))))
-	  (force-to-unknown (remaining)
-	    (when remaining
-	      (let ((cont (car remaining)))
-		(when cont
-		  (annotate-continuation cont :unknown)))
-	      (force-to-unknown (cdr remaining)))))
-       (allow-fixed (mv-combination-args call)))))
-  (undefined-value))
-
-(defun annotate-local-call (call)
-  (annotate-basic-combination-args call)
-  (annotate-continuation (basic-combination-fun call) 0))
-
-;;; ANNOTATE-FULL-CALL  --  Internal
-;;;
-;;;    Annotate the values for any :full combination.  This includes inline
-;;; functions, multiple value calls & throw.  If a real full call, clear any
-;;; type-check annotations.
-;;;
-(defun annotate-full-call (call)
-  (let* ((fun (basic-combination-fun call))
-	 (name (continuation-function-name fun))
-	 (info (find name *inline-functions*
-		     :key #'inline-function-info-function)))
-    (cond ((and info
-		(valid-function-use call (inline-function-info-type info)))
-	   (annotate-basic-combination-args call)
-	   (setf (node-tail-p call) nil)
-	   (setf (basic-combination-info call) info)
-	   (annotate-continuation fun 0))
-	  ((and (mv-combination-p call) (eq name '%throw))
-	   (let ((args (basic-combination-args call)))
-	     (assert (= (length args) 2))
-	     (annotate-continuation (first args) 1)
-	     (annotate-continuation (second args) :unknown))
-	   (setf (node-tail-p call) nil)
-	   (annotate-continuation fun 0))
-	  (t
-	   (annotate-basic-combination-args call)
-	   (dolist (arg (basic-combination-args call))
-	     (when (continuation-type-check arg)
-	       (setf (continuation-%type-check arg) :deleted)))
-	   (annotate-continuation
-	    fun
-	    (if (continuation-function-name fun) :fdefinition 1)))))
-  (undefined-value))
-
-(defun annotate-known-call (call)
-  (annotate-basic-combination-args call)
-  (setf (node-tail-p call) nil)
-  (annotate-continuation (basic-combination-fun call) 0)
-  t)
-
-(defun annotate-basic-combination (call)
-  ;; Annotate the function.
-  (let ((kind (basic-combination-kind call)))
-    (case kind
-      (:local
-       (annotate-local-call call))
-      (:full
-       (annotate-full-call call))
-      (:error
-       (setf (basic-combination-kind call) :full)
-       (annotate-full-call call))
-      (t
-       (unless (and (function-info-byte-compile kind)
-		    (funcall (or (function-info-byte-annotate kind)
-				 #'annotate-known-call)
-			     call))
-	 (setf (basic-combination-kind call) :full)
-	 (annotate-full-call call)))))
-
-  ;; If this is (still) a tail-call, then blow away the return.
-  (when (node-tail-p call)
-    (node-ends-block call)
-    (let ((block (node-block call)))
-      (unlink-blocks block (first (block-succ block)))
-      (link-blocks block (component-tail (block-component block)))))
-  (undefined-value))
-
-(defun annotate-if (if)
-  ;; Annotate the test.
-  (let* ((cont (if-test if))
-	 (use (continuation-use cont)))
-    (annotate-continuation
-     cont
-     (if (and (combination-p use)
-	      (eq (continuation-function-name (combination-fun use)) 'eq)
-	      (= (length (combination-args use)) 2))
-	 ;; If the test is a call to EQ, then we can use branch-if-eq
-	 ;; so don't need to actually funcall the test.
-	 :eq-test
-	 ;; Otherwise, funcall the test for 1 value.
-	 1))))
-
-(defun annotate-return (return)
-  (let ((cont (return-result return)))
-    (annotate-continuation
-     cont
-     (nth-value 1 (values-types (continuation-derived-type cont))))))
-
-(defun annotate-exit (exit)
-  (let ((cont (exit-value exit)))
-    (when cont
-      (annotate-continuation cont :unknown))))
-
-(defun annotate-block (block)
-  (do-nodes (node cont block)
-    (etypecase node
-      (bind)
-      (ref)
-      (cset (annotate-set node))
-      (basic-combination (annotate-basic-combination node))
-      (cif (annotate-if node))
-      (creturn (annotate-return node))
-      (entry)
-      (exit (annotate-exit node))))
-  (undefined-value))
-
-(defun annotate-ir1 (component)
-  (do-blocks (block component)
-    (when (block-interesting block)
-      (annotate-block block)))
-  (undefined-value))
-
-
-
-;;;; Stack analysis.
-
-(defun compute-produces-and-consumes (block)
-  (let ((stack nil)
-	(consumes nil)
-	(total-consumes (make-sset))
-	(nlx-entries nil)
-	(nlx-entry-p nil)
-	(counter 0))
-    (labels ((interesting (cont)
-	       (and cont
-		    (let ((info (continuation-info cont)))
-		      (and info
-			   (not (member (byte-continuation-info-results info)
-					'(0 :eq-test)))))))
-	     (consume (cont)
-	       (cond ((not (interesting cont)))
-		     (stack
-		      (assert (eq (car stack) cont))
-		      (pop stack))
-		     (t
-		      (let ((info (continuation-info cont)))
-			(unless (byte-continuation-info-number info)
-			  (setf (byte-continuation-info-number info)
-				(incf counter)))
-			(sset-adjoin info total-consumes))
-		      (push cont consumes)))))
-      (do-nodes (node cont block)
-	(etypecase node
-	  (bind)
-	  (ref)
-	  (cset
-	   (consume (set-value node)))
-	  (basic-combination
-	   (dolist (arg (reverse (basic-combination-args node)))
-	     (when arg
-	       (consume arg)))
-	   (consume (basic-combination-fun node))
-	   (when (eq (continuation-function-name
-		      (basic-combination-fun node))
-		     '%nlx-entry)
-	     (let ((nlx-info (continuation-value
-			      (first (basic-combination-args node)))))
-	       (when (eq (cleanup-kind (nlx-info-cleanup nlx-info)) :block)
-		 (push (nlx-info-continuation nlx-info) stack)))
-	     (setf nlx-entry-p t)))
-	  (cif
-	   (consume (if-test node)))
-	  (creturn
-	   (consume (return-result node)))
-	  (entry
-	   (let ((nlx-info (cleanup-nlx-info (entry-cleanup node))))
-	     (when nlx-info
-	       (push (list nlx-info stack (reverse consumes)) nlx-entries))))
-	  (exit
-	   (when (exit-value node)
-	     (consume (exit-value node)))))
-	(when (and (not (exit-p node)) (interesting cont))
-	  (push cont stack))))
-      (setf (block-info block)
-	    (make-byte-block-info block
-				  :produces stack
-				  :produces-sset
-				  (let ((result (make-sset)))
-				    (dolist (product stack)
-				      (sset-adjoin (continuation-info product)
-						   result))
-				    result)
-				  :consumes (reverse consumes)
-				  :total-consumes total-consumes
-				  :nlx-entries nlx-entries
-				  :nlx-entry-p nlx-entry-p)))
-  (undefined-value))
-
-(defun walk-successors (block stack)
-  (let ((tail (component-tail (block-component block))))
-    (dolist (succ (block-succ block))
-      (unless (or (eq succ tail)
-		  (not (block-interesting succ))
-		  (byte-block-info-nlx-entry-p (block-info succ)))
-	(walk-block succ block stack)))))
-
-(defun walk-nlx-entry (nlx-infos stack produce consume)
-  (dolist (cont consume)
-    (assert (eq (car stack) cont))
-    (pop stack))
-  (setf stack (append produce stack))
-  (dolist (nlx-info nlx-infos)
-    (walk-block (nlx-info-target nlx-info) nil stack)))
-
-(defun walk-block (block pred stack)
-  ;; Pop everything off of stack that isn't live.
-  (let* ((info (block-info block))
-	 (live (byte-block-info-total-consumes info)))
-    (collect ((pops))
-      (let ((fixed 0))
-	(flet ((flush-fixed ()
-		 (unless (zerop fixed)
-		   (pops `(%byte-pop-stack ,fixed))
-		   (setf fixed 0))))
-	  (loop
-	    (unless stack
-	      (return))
-	    (let* ((cont (car stack))
-		   (info (continuation-info cont)))
-	      (when (sset-member info live)
-		(return))
-	      (pop stack)
-	      (let ((results (byte-continuation-info-results info)))
-		(case results
-		  (:unknown
-		   (flush-fixed)
-		   (pops `(%byte-pop-stack 0)))
-		  (:fdefinition
-		   (incf fixed))
-		  (t
-		   (incf fixed results))))))
-	  (flush-fixed)))
-      (when (pops)
-	(assert pred)
-	(let ((cleanup-block
-	       (insert-cleanup-code pred block
-				    (continuation-next (block-start block))
-				    `(progn ,@(pops)))))
-	  (annotate-block cleanup-block))))
-    (cond ((eq (byte-block-info-start-stack info) :unknown)
-	   ;; Record what the stack looked like at the start of this block.
-	   (setf (byte-block-info-start-stack info) stack)
-	   ;; Process any nlx entries that build off of our stack.
-	   (dolist (stuff (byte-block-info-nlx-entries info))
-	     (walk-nlx-entry (first stuff) stack (second stuff) (third stuff)))
-	   ;; Remove whatever we consume.
-	   (dolist (cont (byte-block-info-consumes info))
-	     (assert (eq (car stack) cont))
-	     (pop stack))
-	   ;; Add whatever we produce.
-	   (setf stack (append (byte-block-info-produces info) stack))
-	   (setf (byte-block-info-end-stack info) stack)
-	   ;; Pass that on to all our successors.
-	   (walk-successors block stack))
-	  (t
-	   ;; We have already processed the successors of this block.  Just
-	   ;; make sure we thing the stack is the same now as before.
-	   (assert (equal (byte-block-info-start-stack info) stack)))))
-  (undefined-value))
-
-(defun byte-stack-analyze (component)
-  (let ((head nil))
-    (do-blocks (block component)
-      (when (block-interesting block)
-	(compute-produces-and-consumes block)
-	(push block head)
-	(setf (byte-block-info-already-queued (block-info block)) t)))
-    (let ((tail (last head)))
-      (labels ((maybe-enqueue (block)
-		 (when (block-interesting block)
-		   (let ((info (block-info block)))
-		     (unless (byte-block-info-already-queued info)
-		       (setf (byte-block-info-already-queued info) t)
-		       (let ((new (list block)))
-			 (if head
-			     (setf (cdr tail) new)
-			     (setf head new))
-			 (setf tail new))))))
-	       (maybe-enqueue-predecessors (block)
-		 (dolist (pred (block-pred block))
-		   (unless (eq pred (component-head (block-component block)))
-		     (maybe-enqueue pred)))))
-	(loop
-	  (unless head
-	    (return))
-	  (let* ((block (pop head))
-		 (info (block-info block))
-		 (total-consumes (byte-block-info-total-consumes info))
-		 (did-anything nil))
-	    (setf (byte-block-info-already-queued info) nil)
-	    (dolist (succ (block-succ block))
-	      (unless (eq succ (component-tail component))
-		(let ((succ-info (block-info succ)))
-		  (when (sset-union-of-difference
-			 total-consumes
-			 (byte-block-info-total-consumes succ-info)
-			 (byte-block-info-produces-sset succ-info))
-		    (setf did-anything t)))))
-	    (when did-anything
-	      (maybe-enqueue-predecessors block)))))))
-  (walk-successors (component-head component) nil)
-  (undefined-value))
-
-
-
-;;;; Actually generate the byte-code
-
-(defvar *byte-component-info*)
-
-(defconstant byte-push-local		#b00000000)
-(defconstant byte-push-arg		#b00010000)
-(defconstant byte-push-constant		#b00100000)
-(defconstant byte-push-system-constant	#b00110000)
-(defconstant byte-push-int		#b01000000)
-(defconstant byte-push-neg-int		#b01010000)
-(defconstant byte-pop-local		#b01100000)
-(defconstant byte-pop-n			#b01110000)
-(defconstant byte-call			#b10000000)
-(defconstant byte-tail-call		#b10010000)
-(defconstant byte-multiple-call		#b10100000)
-(defconstant byte-named			#b00001000)
-(defconstant byte-local-call		#b10110000)
-(defconstant byte-local-tail-call	#b10111000)
-(defconstant byte-local-multiple-call	#b11000000)
-(defconstant byte-return		#b11001000)
-(defconstant byte-branch-always		#b11010000)
-(defconstant byte-branch-if-true	#b11010010)
-(defconstant byte-branch-if-false	#b11010100)
-(defconstant byte-branch-if-eq		#b11010110)
-(defconstant byte-xop			#b11011000)
-(defconstant byte-inline-function	#b11100000)
-
-
-(defun output-push-int (segment int)
-  (declare (type new-assem:segment segment)
-	   (type (integer #.(- (ash 1 24)) #.(1- (ash 1 24)))))
-  (if (minusp int)
-      (output-byte-with-operand segment byte-push-neg-int (- (1+ int)))
-      (output-byte-with-operand segment byte-push-int int)))
-
-(defun output-push-constant-leaf (segment constant)
-  (declare (type new-assem:segment segment)
-	   (type constant constant))
-  (let ((info (constant-info constant)))
-    (if info
-	(output-byte-with-operand segment
-				  (ecase (car info)
-				    (:system-constant
-				     byte-push-system-constant)
-				    (:local-constant
-				     byte-push-constant))
-				  (cdr info))
-	(let ((const (constant-value constant)))
-	  (if (and (integerp const) (< (- (ash 1 24)) const (ash 1 24)))
-	      ;; It can be represented as an immediate.
-	      (output-push-int segment const)
-	      ;; We need to store it in the constants pool.
-	      (let* ((posn (gethash const *system-constant-codes*))
-		     (new-info (if posn
-				   (cons :system-constant posn)
-				   (cons :local-constant
-					 (vector-push-extend
-					  constant
-					  (byte-component-info-constants
-					   *byte-component-info*))))))
-		(setf (constant-info constant) new-info)
-		(output-push-constant-leaf segment constant)))))))
-
-(defun output-push-constant (segment value)
-  (if (and (integerp value)
-	   (< (- (ash 1 24)) value (ash 1 24)))
-      (output-push-int segment value)
-      (output-push-constant-leaf segment (find-constant value))))
-
-
-;;; BYTE-LOAD-TIME-CONSTANT-INDEX  --  Internal
-;;;
-;;;    Return the offset of a load-time constant in the constant pool, adding
-;;; it if absent.
-;;;
-(defun byte-load-time-constant-index (kind datum)
-  (let ((constants (byte-component-info-constants *byte-component-info*)))
-    (or (position-if #'(lambda (x)
-			 (and (consp x)
-			      (eq (car x) kind)
-			      (typecase datum
-				(cons (equal (cdr x) datum))
-				(ctype (type= (cdr x) datum))
-				(t
-				 (eq (cdr x) datum)))))
-		     constants)
-	(vector-push-extend (cons kind datum) constants))))
-
-
-(defun output-push-load-time-constant (segment kind datum)
-  (output-byte-with-operand segment byte-push-constant
-			    (byte-load-time-constant-index kind datum))
-  (undefined-value))
-
-(defun output-do-inline-function (segment function)
-  ;; Note: we don't annotate this as a call site, because it is used for
-  ;; internal stuff.  Random functions that get inlined have code locations
-  ;; added byte generate-byte-code-for-full-call below.
-  (output-byte segment
-	       (logior byte-inline-function
-		       (inline-function-number-or-lose function))))
-
-(defun output-do-xop (segment xop)
-  (let ((index (xop-index-or-lose xop)))
-    (cond ((< index 7)
-	   (output-byte segment (logior byte-xop index)))
-	  (t
-	   (output-byte segment (logior byte-xop 7))
-	   (output-byte segment index)))))
-
-(defun output-ref-lambda-var (segment var env
-				     &optional (indirect-value-cells t))
-  (declare (type new-assem:segment segment)
-	   (type lambda-var var)
-	   (type environment env))
-  (if (eq (lambda-environment (lambda-var-home var)) env)
-      (let ((info (leaf-info var)))
-	(output-byte-with-operand segment
-				  (if (byte-lambda-var-info-argp info)
-				      byte-push-arg
-				      byte-push-local)
-				  (byte-lambda-var-info-offset info)))
-      (output-byte-with-operand segment
-				byte-push-arg
-				(position var (environment-closure env))))
-  (when (and indirect-value-cells (lambda-var-indirect var))
-    (output-do-inline-function segment 'value-cell-ref)))
-
-(defun output-ref-nlx-info (segment info env)
-  (if (eq (node-environment (cleanup-mess-up (nlx-info-cleanup info))) env)
-      (output-byte-with-operand segment
-				byte-push-local
-				(byte-nlx-info-stack-slot
-				 (nlx-info-info info)))
-      (output-byte-with-operand segment
-				byte-push-arg
-				(position info (environment-closure env)))))
-
-(defun output-set-lambda-var (segment var env &optional make-value-cells)
-  (declare (type new-assem:segment segment)
-	   (type lambda-var var)
-	   (type environment env))
-  (let ((indirect (lambda-var-indirect var)))
-    (cond ((not (eq (lambda-environment (lambda-var-home var)) env))
-	   ;; This is not this guys home environment.  So we need to get it
-	   ;; the value cell out of the closure, and fill it in.
-	   (assert indirect)
-	   (assert (not make-value-cells))
-	   (output-byte-with-operand segment byte-push-arg
-				     (position var (environment-closure env)))
-	   (output-do-inline-function segment 'value-cell-setf))
-	  (t
-	   (let* ((pushp (and indirect (not make-value-cells)))
-		  (byte-code (if pushp byte-push-local byte-pop-local))
-		  (info (leaf-info var)))
-	     (assert (not (byte-lambda-var-info-argp info)))
-	     (when (and indirect make-value-cells)
-	       ;; Replace the stack top with a value cell holding the
-	       ;; stack top.
-	       (output-do-inline-function segment 'make-value-cell))
-	     (output-byte-with-operand segment byte-code
-				       (byte-lambda-var-info-offset info))
-	     (when pushp
-	       (output-do-inline-function segment 'value-cell-setf)))))))
-
-;;; CANONICALIZE-VALUES -- internal.
-;;;
-;;; Output whatever noise is necessary to canonicalize the values on the
-;;; top of the stack.  Desired is the number we want, and supplied is the
-;;; number we have.  Either push NIL or pop-n to make them balanced.
-;;; Note: either desired or supplied can be :unknown, in which case it means
-;;; use the ``unknown-values'' convention (which is the stack values followed
-;;; by the number of values).
-;;; 
-(defun canonicalize-values (segment desired supplied)
-  (declare (type new-assem:segment segment)
-	   (type (or (member :unknown) index) desired supplied))
-  (cond ((eq desired :unknown)
-	 (unless (eq supplied :unknown)
-	   (output-byte-with-operand segment byte-push-int supplied)))
-	((eq supplied :unknown)
-	 (unless (eq desired :unknown)
-	   (output-push-int segment desired)
-	   (output-do-xop segment 'default-unknown-values)))
-	((< supplied desired)
-	 (dotimes (i (- desired supplied))
-	   (output-push-constant segment nil)))
-	((> supplied desired)
-	 (output-byte-with-operand segment byte-pop-n (- supplied desired))))
-  (undefined-value))
-
-
-(defparameter *byte-type-weakenings*
-  (mapcar #'specifier-type
-	  '(fixnum single-float double-float simple-vector simple-bit-vector
-		   bit-vector)))
-
-;;; BYTE-GENERATE-TYPE-CHECK  --  Internal
-;;;
-;;;    Emit byte code to check that the value on TOS is of the specified Type.
-;;; Node is used for policy information.  We weaken or entirely omit the type
-;;; check if speed is more important than safety.
-;;;
-(defun byte-generate-type-check (segment type node)
-  (declare (type ctype type) (type node node))
-  (unless (or (policy node (zerop safety))
-	      (csubtypep *universal-type* type))
-    (let ((type (if (policy node (> speed safety))
-		    (dolist (super *byte-type-weakenings* type)
-		      (when (csubtypep type super) (return super)))
-		    type)))
-      (output-do-xop segment 'type-check)
-      (output-extended-operand
-       segment
-       (byte-load-time-constant-index :type-predicate type)))))
-
-
-;;; CHECKED-CANONICALIZE-VALUES  --  Internal
-;;;
-;;;    This function is used when we are generating code which delivers values
-;;; to a continuation.  If this continuation needs a type check, and has a
-;;; single value, then we do a type check.  We also CANONICALIZE-VALUES for the
-;;; continuation's desired number of values.
-;;;
-(defun checked-canonicalize-values (segment cont supplied)
-  (let ((info (continuation-info cont)))
-    (if info
-	(let ((desired (byte-continuation-info-results info)))
-	  (flet ((do-check ()
-		   (byte-generate-type-check
-		    segment
-		    (single-value-type (continuation-asserted-type cont))
-		    (continuation-dest cont))))
-	    (cond
-	     ((member (continuation-type-check cont) '(nil :deleted))
-	      (canonicalize-values segment desired supplied))
-	     ((eql supplied 1)
-	      (do-check)
-	      (canonicalize-values segment desired supplied))
-	     ((eql desired 1)
-	      (canonicalize-values segment desired supplied)
-	      (do-check))
-	     (t
-	      (canonicalize-values segment desired supplied)))))
-	(canonicalize-values segment 0 supplied))))
-
-
-(defun generate-byte-code-for-bind (segment bind cont)
-  (declare (type new-assem:segment segment) (type bind bind)
-	   (ignore cont))
-  (let ((lambda (bind-lambda bind))
-	(env (node-environment bind)))
-    (ecase (lambda-kind lambda)
-      ((nil :top-level :escape :cleanup :optional)
-       (let* ((info (lambda-info lambda))
-	      (frame-size (byte-lambda-info-stack-size info)))
-	 (cond ((< frame-size (* 255 2))
-		(output-byte segment (ceiling frame-size 2)))
-	       (t
-		(output-byte segment 255)
-		(output-byte segment (ldb (byte 8 16) frame-size))
-		(output-byte segment (ldb (byte 8 8) frame-size))
-		(output-byte segment (ldb (byte 8 0) frame-size))))
-	 (loop
-	   for argnum upfrom 0
-	   for var in (lambda-vars lambda)
-	   for info = (lambda-var-info var)
-	   do (unless (or (null info) (byte-lambda-var-info-argp info))
-		(output-byte-with-operand segment byte-push-arg argnum)
-		(output-set-lambda-var segment var env t)))))
-      ((:let :mv-let :assignment)
-       ;; Everything has been taken care of in the combination node.
-       )))
-  (undefined-value))
-
-
-;;; This hashtable translates from n-ary function names to the two-arg specific
-;;; versions which we call to avoid rest-arg consing.
-;;;
-(defvar *two-arg-functions* (make-hash-table :test #'eq))
-
-(dolist (fun '((KERNEL:TWO-ARG-IOR  LOGIOR)
-	       (KERNEL:TWO-ARG-*  *)
-	       (KERNEL:TWO-ARG-+  +)
-	       (KERNEL:TWO-ARG-/  /)
-	       (KERNEL:TWO-ARG--  -)
-	       (KERNEL:TWO-ARG->  >)
-	       (KERNEL:TWO-ARG-<  <)
-	       (KERNEL:TWO-ARG-=  =)
-	       (KERNEL:TWO-ARG-LCM  LCM)
-	       (KERNEL:TWO-ARG-AND  LOGAND)
-	       (KERNEL:TWO-ARG-GCD  GCD)
-	       (KERNEL:TWO-ARG-XOR  LOGXOR)
-
-	       (two-arg-char= char=)
-	       (two-arg-char< char<)
-	       (two-arg-char> char>)
-	       (two-arg-char-equal char-equal)
-	       (two-arg-char-lessp char-lessp)
-	       (two-arg-char-greaterp char-greaterp)))
-
-  (setf (gethash (second fun) *two-arg-functions*) (first fun)))
-
-
-(defun generate-byte-code-for-ref (segment ref cont)
-  (declare (type new-assem:segment segment) (type ref ref)
-	   (type continuation cont))
-  (let ((info (continuation-info cont)))
-    ;; If there is no info, then nobody wants the result.
-    (when info
-      (let ((values (byte-continuation-info-results info))
-	    (leaf (ref-leaf ref)))
-	(cond
-	 ((eq values :fdefinition)
-	  (assert (and (global-var-p leaf)
-		       (eq (global-var-kind leaf)
-			   :global-function)))
-	  (let* ((name (global-var-name leaf))
-		 (found (gethash name *two-arg-functions*)))
-	    (output-push-load-time-constant
-	     segment :fdefinition
-	     (if (and found
-		      (= (length (combination-args (continuation-dest cont)))
-			 2))
-		 found
-		 name))))
-	 ((eql values 0)
-	  ;; Real easy!
-	  nil)
-	 (t
-	  (etypecase leaf
-	    (constant
-	     (output-push-constant-leaf segment leaf))
-	    (clambda
-	     (let* ((refered-env (lambda-environment leaf))
-		    (closure (environment-closure refered-env)))
-	       (if (null closure)
-		   (output-push-load-time-constant segment :entry leaf)
-		   (let ((my-env (node-environment ref)))
-		     (output-push-load-time-constant segment :xep leaf)
-		     (dolist (thing closure)
-		       (etypecase thing
-			 (lambda-var
-			  (output-ref-lambda-var segment thing my-env nil))
-			 (nlx-info
-			  (output-ref-nlx-info segment thing my-env))))
-		     (output-push-int segment (length closure))
-		     (output-do-xop segment 'make-closure)))))
-	    (functional
-	     (output-push-load-time-constant segment :entry leaf))
-	    (lambda-var
-	     (output-ref-lambda-var segment leaf (node-environment ref)))
-	    (global-var
-	     (ecase (global-var-kind leaf)
-	       ((:special :global :constant)
-		(output-push-constant segment (global-var-name leaf))
-		(output-do-inline-function segment 'symbol-value))
-	       (:global-function
-		(output-push-load-time-constant segment
-						:fdefinition
-						(global-var-name leaf))
-		(output-do-xop segment 'fdefn-function-or-lose)))))
-	  (checked-canonicalize-values segment cont 1))))))
-  (undefined-value))
-
-(defun generate-byte-code-for-set (segment set cont)
-  (declare (type new-assem:segment segment) (type cset set)
-	   (type continuation cont))
-  (let* ((leaf (set-var set))
-	 (info (continuation-info cont))
-	 (values (if info
-		     (byte-continuation-info-results info)
-		     0)))
-    (unless (eql values 0)
-      ;; Someone wants the value, so copy it.
-      (output-do-xop segment 'dup))
-    (etypecase leaf
-      (global-var
-       (ecase (global-var-kind leaf)
-	 ((:special :global)
-	  (output-push-constant segment (global-var-name leaf))
-	  (output-do-inline-function segment 'setf-symbol-value))))
-      (lambda-var
-       (output-set-lambda-var segment leaf (node-environment set))))
-    (unless (eql values 0)
-      (checked-canonicalize-values segment cont 1)))
-  (undefined-value))
-
-(defun generate-byte-code-for-local-call (segment call cont num-args)
-  (let* ((lambda (combination-lambda call))
-	 (vars (lambda-vars lambda))
-	 (env (lambda-environment lambda)))
-    (ecase (functional-kind lambda)
-      ((:let :assignment)
-       (dolist (var (reverse vars))
-	 (when (lambda-var-refs var)
-	   (output-set-lambda-var segment var env t))))
-      (:mv-let
-       (let ((do-check (member (continuation-type-check
-				(first (basic-combination-args call)))
-			       '(t :error))))
-	 (dolist (var (reverse vars))
-	   (when do-check
-	     (byte-generate-type-check segment (leaf-type var) call))
-	   (output-set-lambda-var segment var env t))))
-      ((nil :optional :cleanup)
-       ;; We got us a local call.  
-       (assert (not (eq num-args :unknown)))
-       ;; First push closure vars.
-       (let ((closure (environment-closure env)))
-	 (when closure
-	   (let ((my-env (node-environment call)))
-	     (dolist (thing (reverse closure))
-	       (etypecase thing
-		 (lambda-var
-		  (output-ref-lambda-var segment thing my-env nil))
-		 (nlx-info
-		  (output-ref-nlx-info segment thing my-env)))))
-	   (incf num-args (length closure))))
-       (let ((results
-	      (let ((info (continuation-info cont)))
-		(if info
-		    (byte-continuation-info-results info)
-		    0))))
-	 ;; Emit the op for whatever flavor of call we are using.
-	 (let ((operand
-		(cond ((> num-args 6)
-		       (output-push-int segment num-args)
-		       7)
-		      (t
-		       num-args))))
-	   ;; ### :call-site
-	   (output-byte segment
-			(logior (cond ((node-tail-p call)
-				       byte-local-tail-call)
-				      ((member results '(0 1))
-				       byte-local-call)
-				      (t
-				       byte-local-multiple-call))
-				operand)))
-	 ;; Emit a reference to the label.
-	 (output-reference segment
-			   (byte-lambda-info-label (lambda-info lambda)))
-	 ;; ### :unknown-return
-	 ;; Fix up the results.
-	 (unless (node-tail-p call)
-	   (checked-canonicalize-values segment cont
-					(if (eql results 0) 1 results)))))))
-  (undefined-value))
-
-(defun generate-byte-code-for-full-call (segment call cont num-args)
-  (let ((info (basic-combination-info call))
-	(results
-	 (let ((info (continuation-info cont)))
-	   (if info
-	       (byte-continuation-info-results info)
-	       0))))
-    (cond
-     (info
-      ;; It's an inline function.
-      (assert (not (node-tail-p call)))
-      (let* ((type (inline-function-info-type info))
-	     (desired-args (function-type-nargs type))
-	     (supplied-results
-	      (nth-value 1
-			 (values-types (function-type-returns type)))))
-	(canonicalize-values segment desired-args num-args)
-	;; ### :call-site
-	(output-byte segment (logior byte-inline-function
-				     (inline-function-info-number info)))
-	;; ### :known-return
-	(checked-canonicalize-values segment cont supplied-results)))
-     (t
-      (let ((operand
-	     (cond ((eq num-args :unknown)
-		    7)
-		   ((> num-args 6)
-		    (output-push-int segment num-args)
-		    7)
-		   (t
-		    num-args))))
-	(when (eq (byte-continuation-info-results
-		   (continuation-info
-		    (basic-combination-fun call)))
-		  :fdefinition)
-	  (setf operand (logior operand byte-named)))
-	;; ### :call-site
-	(cond
-	 ((node-tail-p call)
-	  (output-byte segment (logior byte-tail-call operand)))
-	 (t
-	  (output-byte segment
-		       (logior
-			(case results
-			  (:unknown byte-multiple-call)
-			  ((0 1) byte-call)
-			  (t byte-multiple-call))
-			operand))
-	  ;; ### :unknown-return
-	  (checked-canonicalize-values segment cont
-				       (if (eql results 0) 1 results)))))))))
-
-
-(defun generate-byte-code-for-known-call (segment call cont num-args)
-  (block nil
-    (catch 'give-up
-      (funcall (function-info-byte-compile (basic-combination-kind call)) call
-	       (let ((info (continuation-info cont)))
-		 (if info
-		     (byte-continuation-info-results info)
-		     0))
-	       num-args segment)
-      (return))
-    (assert (member (byte-continuation-info-results
-		     (continuation-info
-		      (basic-combination-fun call)))
-		    '(1 :fdefinition)))
-    (generate-byte-code-for-full-call segment call cont num-args))
-  (undefined-value))
-
-(defun generate-byte-code-for-generic-combination (segment call cont)
-  (declare (type new-assem:segment segment) (type basic-combination call)
-	   (type continuation cont))
-  (let ((num-args
-	 (labels
-	     ((examine (args num-fixed)
-		(cond
-		 ((null args)
-		  ;; None of the arugments supply :unknown values, so
-		  ;; we know exactly how many there are.
-		  num-fixed)
-		 ((null (car args))
-		  ;; This arg has been deleted.  Ignore it.
-		  (examine (cdr args) num-fixed))
-		 (t
-		  (let* ((vals
-			  (byte-continuation-info-results
-			   (continuation-info (car args)))))
-		    (cond
-		     ((eq vals :unknown)
-		      (unless (null (cdr args))
-			;; There are (length args) :unknown value blocks on
-			;; the top of the stack.  We need to combine them.
-			(output-push-int segment (length args))
-			(output-do-xop segment 'merge-unknown-values))
-		      (unless (zerop num-fixed)
-			;; There are num-fixed fixed args above the unknown
-			;; values block that want in on the action also.
-			;; So add num-fixed to the count.
-			(output-push-int segment num-fixed)
-			(output-do-inline-function segment '+))
-		      :unknown)
-		     (t
-		      (examine (cdr args) (+ num-fixed vals)))))))))
-	   (examine (basic-combination-args call) 0))))
-    (case (basic-combination-kind call)
-      (:local
-       (generate-byte-code-for-local-call segment call cont num-args))
-      (:full
-       (generate-byte-code-for-full-call segment call cont num-args))
-      (t
-       (generate-byte-code-for-known-call segment call cont num-args)))))
-
-(defun generate-byte-code-for-basic-combination (segment call cont)
-  (cond ((and (mv-combination-p call)
-	      (eq (continuation-function-name (basic-combination-fun call))
-		  '%throw))
-	 ;; ### :internal-error
-	 (output-do-xop segment 'throw))
-	(t
-	 (generate-byte-code-for-generic-combination segment call cont))))
-
-(defun generate-byte-code-for-if (segment if cont)
-  (declare (type new-assem:segment segment) (type cif if)
-	   (ignore cont))
-  (let* ((next-info (byte-block-info-next (block-info (node-block if))))
-	 (consequent-info (block-info (if-consequent if)))
-	 (alternate-info (block-info (if-alternative if))))
-    (cond ((eq (byte-continuation-info-results
-		(continuation-info (if-test if)))
-	       :eq-test)
-	   (output-branch segment
-			  byte-branch-if-eq
-			  (byte-block-info-label consequent-info))
-	   (unless (eq next-info alternate-info)
-	     (output-branch segment
-			    byte-branch-always
-			    (byte-block-info-label alternate-info))))
-	  ((eq next-info consequent-info)
-	   (output-branch segment
-			  byte-branch-if-false
-			  (byte-block-info-label alternate-info)))
-	  (t
-	   (output-branch segment
-			  byte-branch-if-true
-			  (byte-block-info-label consequent-info))
-	   (unless (eq next-info alternate-info)
-	     (output-branch segment
-			    byte-branch-always
-			    (byte-block-info-label alternate-info)))))))
-
-(defun generate-byte-code-for-return (segment return cont)
-  (declare (type new-assem:segment segment) (type creturn return)
-	   (ignore cont))
-  (let* ((result (return-result return))
-	 (info (continuation-info result))
-	 (results (byte-continuation-info-results info)))
-    (cond ((eq results :unknown)
-	   (setf results 7))
-	  ((> results 6)
-	   (output-byte-with-operand segment byte-push-int results)
-	   (setf results 7)))
-    (output-byte segment (logior byte-return results)))
-  (undefined-value))
-
-(defun generate-byte-code-for-entry (segment entry cont)
-  (declare (type new-assem:segment segment) (type entry entry)
-	   (ignore cont))
-  (dolist (exit (entry-exits entry))
-    (let ((nlx-info (find-nlx-info entry (node-cont exit))))
-      (when nlx-info
-	(let ((kind (cleanup-kind (nlx-info-cleanup nlx-info))))
-	  (when (member kind '(:block :tagbody))
-	    ;; Generate a unique tag.
-	    (output-do-inline-function segment 'cons-unique-tag)
-	    ;; Save it so people can close over it.
-	    (output-do-xop segment 'dup)
-	    (output-byte-with-operand segment
-				      byte-pop-local
-				      (byte-nlx-info-stack-slot
-				       (nlx-info-info nlx-info)))
-	    ;; Now do the actual XOP.
-	    (ecase kind
-	      (:block
-	       (output-do-xop segment 'catch)
-	       (output-reference segment
-				 (byte-nlx-info-label
-				  (nlx-info-info nlx-info))))
-	      (:tagbody
-	       (output-do-xop segment 'tagbody)))
-	    (return))))))
-  (undefined-value))
-
-(defun generate-byte-code-for-exit (segment exit cont)
-  (declare (ignore cont))
-  (let ((nlx-info (find-nlx-info (exit-entry exit) (node-cont exit))))
-    (output-byte-with-operand segment
-			      byte-push-arg
-			      (position nlx-info
-					(environment-closure
-					 (node-environment exit))))
-    (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
-      (:block
-       ;; ### :internal-error
-       (output-do-xop segment 'return-from))
-      (:tagbody
-       ;; ### :internal-error
-       (output-do-xop segment 'go)
-       (output-reference segment
-			 (byte-nlx-info-label (nlx-info-info nlx-info)))))))
-
-(defun generate-byte-code (segment component)
-  (let ((*byte-component-info* (component-info component)))
-    (do* ((info (byte-block-info-next (block-info (component-head component)))
-		next)
-	  (block (byte-block-info-block info) (byte-block-info-block info))
-	  (next (byte-block-info-next info) (byte-block-info-next info)))
-	 ((eq block (component-tail component)))
-      (when (block-interesting block)
-	(output-label segment (byte-block-info-label info))
-	(do-nodes (node cont block)
-	  (etypecase node
-	    (bind (generate-byte-code-for-bind segment node cont))
-	    (ref (generate-byte-code-for-ref segment node cont))
-	    (cset (generate-byte-code-for-set segment node cont))
-	    (basic-combination
-	     (generate-byte-code-for-basic-combination
-	      segment node cont))
-	    (cif (generate-byte-code-for-if segment node cont))
-	    (creturn (generate-byte-code-for-return segment node cont))
-	    (entry (generate-byte-code-for-entry segment node cont))
-	    (exit
-	     (when (exit-entry node)
-	       (generate-byte-code-for-exit segment node cont)))))
-	(let* ((succ (block-succ block))
-	       (first-succ (car succ)))
-	  (unless (or (cdr succ)
-		      (eq (byte-block-info-block next) first-succ)
-		      (eq (component-tail component) first-succ))
-	    (output-branch segment
-			   byte-branch-always
-			   (byte-block-info-label
-			    (block-info first-succ))))))))
-  (undefined-value))
-
-
-;;;; Special purpose annotate/compile optimizers.
-
-(defoptimizer (eq byte-annotate) ((this that) node)
-  (declare (ignore this that))
-  (when (if-p (continuation-dest (node-cont node)))
-    (annotate-known-call node)
-    t))
-
-(defoptimizer (eq byte-compile) ((this that) call results num-args segment)
-  (progn segment) ; ignorable.
-  ;; We don't have to do anything, because everything is handled by the
-  ;; IF byte-generator.
-  (assert (eq results :eq-test))
-  (assert (eql num-args 2))
-  (undefined-value))
-
-
-(defoptimizer (values byte-compile)
-	      ((&rest values) node results num-args segment)
-  (canonicalize-values segment results num-args))
-
-
-(defknown %byte-pop-stack (index) (values))
-
-(defoptimizer (%byte-pop-stack byte-annotate) ((count) node)
-  (assert (constant-continuation-p count))
-  (annotate-continuation count 0)
-  (annotate-continuation (basic-combination-fun node) 0)
-  (setf (node-tail-p node) nil)
-  t)
-
-(defoptimizer (%byte-pop-stack byte-compile)
-	      ((count) node results num-args segment)
-  (assert (and (zerop num-args) (zerop results)))
-  (output-byte-with-operand segment byte-pop-n (continuation-value count)))
-
-(defoptimizer (%special-bind byte-annotate) ((var value) node)
-  (annotate-continuation var 0)
-  (annotate-continuation value 1)
-  (annotate-continuation (basic-combination-fun node) 0)
-  (setf (node-tail-p node) nil)
-  t)
-
-(defoptimizer (%special-bind byte-compile)
-	      ((var value) node results num-args segment)
-  (assert (and (eql num-args 1) (zerop results)))
-  (output-push-constant segment (leaf-name (continuation-value var)))
-  (output-do-inline-function segment '%byte-special-bind))
-
-(defoptimizer (%special-unbind byte-annotate) ((var) node)
-  (annotate-continuation var 0)
-  (annotate-continuation (basic-combination-fun node) 0)
-  (setf (node-tail-p node) nil)
-  t)
-  
-(defoptimizer (%special-unbind byte-compile)
-	      ((var) node results num-args segment)
-  (assert (and (zerop num-args) (zerop results)))
-  (output-do-inline-function segment '%byte-special-unbind))
-
-(defoptimizer (%catch byte-annotate) ((nlx-info tag) node)
-  (annotate-continuation nlx-info 0)
-  (annotate-continuation tag 1)
-  (annotate-continuation (basic-combination-fun node) 0)
-  (setf (node-tail-p node) nil)
-  t)
-
-(defoptimizer (%catch byte-compile)
-	      ((nlx-info tag) node results num-args segment)
-  (progn node) ; ignore
-  (assert (and (= num-args 1) (zerop results)))
-  (output-do-xop segment 'catch)
-  (let ((info (nlx-info-info (continuation-value nlx-info))))
-    (output-reference segment (byte-nlx-info-label info))))
-
-(defoptimizer (%cleanup-point byte-compile) (() node results num-args segment)
-  (progn node segment) ; ignore
-  (assert (and (zerop num-args) (zerop results))))
-
-
-(defoptimizer (%catch-breakup byte-compile) (() node results num-args segment)
-  (progn node) ; ignore
-  (assert (and (zerop num-args) (zerop results)))
-  (output-do-xop segment 'breakup))
-
-
-(defoptimizer (%lexical-exit-breakup byte-annotate) ((nlx-info) node)
-  (annotate-continuation nlx-info 0)
-  (annotate-continuation (basic-combination-fun node) 0)
-  (setf (node-tail-p node) nil)
-  t)
-
-(defoptimizer (%lexical-exit-breakup byte-compile)
-	      ((nlx-info) node results num-args segment)
-  (assert (and (zerop num-args) (zerop results)))
-  (let ((nlx-info (continuation-value nlx-info)))
-    (when (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
-	    (:catch t)
-	    (:block
-	     ;; We only want to do this for the fall-though case.
-	     (not (eq (car (block-pred (node-block node)))
-		      (nlx-info-target nlx-info))))
-	    (:tagbody
-	     ;; Only want to do it once per tagbody.
-	     (not (byte-nlx-info-duplicate (nlx-info-info nlx-info)))))
-      (output-do-xop segment 'breakup))))
-
-
-(defoptimizer (%nlx-entry byte-annotate) ((nlx-info) node)
-  (annotate-continuation nlx-info 0)
-  (annotate-continuation (basic-combination-fun node) 0)
-  (setf (node-tail-p node) nil)
-  t)
-
-(defoptimizer (%nlx-entry byte-compile)
-	      ((nlx-info) node results num-args segment)
-  (progn node results) ; ignore
-  (assert (eql num-args 0))
-  (let* ((info (continuation-value nlx-info))
-	 (byte-info (nlx-info-info info)))
-    (output-label segment (byte-nlx-info-label byte-info))
-    ;; ### :non-local-entry
-    (ecase (cleanup-kind (nlx-info-cleanup info))
-      ((:catch :block)
-       (checked-canonicalize-values segment
-				    (nlx-info-continuation info)
-				    :unknown))
-      ((:tagbody :unwind-protect)))))
-
-
-(defoptimizer (%unwind-protect byte-annotate)
-	      ((nlx-info cleanup-fun) node)
-  (annotate-continuation nlx-info 0)
-  (annotate-continuation cleanup-fun 0)
-  (annotate-continuation (basic-combination-fun node) 0)
-  (setf (node-tail-p node) nil)
-  t)
-  
-(defoptimizer (%unwind-protect byte-compile)
-	      ((nlx-info cleanup-fun) node results num-args segment)
-  (assert (and (zerop num-args) (zerop results)))
-  (output-do-xop segment 'unwind-protect)
-  (output-reference segment
-		    (byte-nlx-info-label
-		     (nlx-info-info
-		      (continuation-value nlx-info)))))
-
-(defoptimizer (%unwind-protect-breakup byte-compile)
-	      (() node results num-args segment)
-  (progn node) ; ignore
-  (assert (and (zerop num-args) (zerop results)))
-  (output-do-xop segment 'breakup))
-
-(defoptimizer (%continue-unwind byte-annotate) ((a b c) node)
-  (annotate-continuation a 0)
-  (annotate-continuation b 0)
-  (annotate-continuation c 0)
-  (annotate-continuation (basic-combination-fun node) 0)
-  (setf (node-tail-p node) nil)
-  t)
-  
-(defoptimizer (%continue-unwind byte-compile)
-	      ((a b c) node results num-args segment)
-  (progn node) ; ignore
-  (assert (member results '(0 nil)))
-  (assert (eql num-args 0))
-  (output-do-xop segment 'breakup))
-
-
-;;;; XEP descriptions.
-
-(defstruct (byte-xep
-	    (:print-function %print-byte-xep))
-  ;;
-  ;; The component that this XEP is an entry point into.  NIL until
-  ;; LOAD or MAKE-CORE-BYTE-COMPONENT fills it in.  We also allow
-  ;; cons so that the dumper can stick in a unique cons cell to
-  ;; identify what component it is trying to dump.  What a hack.
-  (component nil :type (or null kernel:code-component cons))
-  ;;
-  ;; The minimum and maximum number of args, ignoring &rest and &key.
-  (min-args 0 :type (integer 0 #.call-arguments-limit))
-  (max-args 0 :type (integer 0 #.call-arguments-limit))
-  ;;
-  ;; List of the entry points for min-args, min-args+1, ... max-args.
-  (entry-points nil :type list)
-  ;;
-  ;; The entry point to use when there are more than max-args.  Only filled
-  ;; in where okay.  In other words, only when &rest or &key is specified.
-  (more-args-entry-point nil :type (or null (unsigned-byte 24)))
-  ;;
-  ;; The number of ``more-arg'' args.
-  (num-more-args 0 :type (integer 0 #.call-arguments-limit))
-  ;;
-  ;; True if there is a rest-arg.
-  (rest-arg-p nil :type (member t nil))
-  ;;
-  ;; True if there are keywords.  Note: keywords might still be NIL because
-  ;; having &key with no keywords is valid and should result in
-  ;; allow-other-keys processing.  If :allow-others, then allow other keys.
-  (keywords-p nil :type (member t nil :allow-others))
-  ;;
-  ;; List of keyword arguments.  Each element is a list of:
-  ;;   key, default, supplied-p.
-  (keywords nil :type list))
-
-(defprinter byte-xep)
-
-
-;;; MAKE-XEP-FOR -- internal
-;;;
-;;; Make a byte-xep for LAMBDA.
-;;; 
-(defun make-xep-for (lambda)
-  (flet ((entry-point-for (entry)
-	   (let ((info (lambda-info entry)))
-	     (assert (byte-lambda-info-interesting info))
-	     (new-assem:label-position (byte-lambda-info-label info)))))
-    (let ((entry (lambda-entry-function lambda)))
-      (etypecase entry
-	(optional-dispatch
-	 (let ((rest-arg-p nil))
-	   (collect ((keywords))
-	     (dolist (var (nthcdr (optional-dispatch-max-args entry)
-				  (optional-dispatch-arglist entry)))
-	       (let ((arg-info (lambda-var-arg-info var)))
-		 (assert arg-info)
-		 (ecase (arg-info-kind arg-info)
-		   (:rest
-		    (assert (not rest-arg-p))
-		    (setf rest-arg-p t))
-		   (:keyword
-		    (keywords (list (arg-info-keyword arg-info)
-				    (arg-info-default arg-info)
-				    (if (arg-info-supplied-p arg-info) t)))))))
-	     (make-byte-xep
-	      :min-args (optional-dispatch-min-args entry)
-	      :max-args (optional-dispatch-max-args entry)
-	      :entry-points
-	      ;; ### Some of these entry points are :Deleted.  This needs to
-	      ;; be fixed somehow.
-	      (mapcar #'entry-point-for (optional-dispatch-entry-points entry))
-	      :more-args-entry-point
-	      (entry-point-for (optional-dispatch-main-entry entry))
-	      :rest-arg-p rest-arg-p
-	      :keywords-p
-	      (if (optional-dispatch-keyp entry)
-		  (if (optional-dispatch-allowp entry)
-		      :allow-others t))
-	      :keywords (keywords)))))
-	(clambda
-	 (let ((args (length (lambda-vars entry))))
-	   (make-byte-xep
-	    :min-args args
-	    :max-args args
-	    :entry-points (list (entry-point-for entry)))))))))
-
-(defun generate-xeps (component)
-  (let ((xeps nil))
-    (dolist (lambda (component-lambdas component))
-      (when (member (lambda-kind lambda) '(:external :top-level))
-	(push (cons lambda (make-xep-for lambda)) xeps)))
-    xeps))
-
-
-
-;;;; Noise to actually do the compile.
-
-(defun assign-locals (component)
-  ;;
-  ;; Process all of the lambdas in component, and assign stack frame
-  ;; locations for all the locals.
-  (dolist (lambda (component-lambdas component))
-    ;; We don't generate any code for :external lambdas, so we don't need
-    ;; to allocate stack space.  Also, we don't use the ``more'' entry,
-    ;; so we don't need code for it.
-    (cond
-     ((or (eq (lambda-kind lambda) :external)
-	  (and (eq (lambda-kind lambda) :optional)
-	       (eq (optional-dispatch-more-entry
-		    (lambda-optional-dispatch lambda))
-		   lambda)))
-      (setf (lambda-info lambda)
-	    (make-byte-lambda-info :interesting nil)))
-     (t
-      (let ((num-locals 0))
-	(let* ((vars (lambda-vars lambda))
-	       (arg-num (+ (length vars)
-			   (length (environment-closure
-				    (lambda-environment lambda))))))
-	  (dolist (var vars)
-	    (decf arg-num)
-	    (cond ((or (lambda-var-sets var) (lambda-var-indirect var))
-		   (setf (leaf-info var)
-			 (make-byte-lambda-var-info :offset num-locals))
-		   (incf num-locals))
-		  ((leaf-refs var)
-		   (setf (leaf-info var) 
-			 (make-byte-lambda-var-info :argp t
-						    :offset arg-num))))))
-	(dolist (let (lambda-lets lambda))
-	  (dolist (var (lambda-vars let))
-	    (setf (leaf-info var)
-		  (make-byte-lambda-var-info :offset num-locals))
-	    (incf num-locals)))
-	(let ((entry-nodes-already-done nil))
-	  (dolist (nlx-info (environment-nlx-info (lambda-environment lambda)))
-	    (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
-	      (:block
-	       (setf (nlx-info-info nlx-info)
-		     (make-byte-nlx-info :stack-slot num-locals))
-	       (incf num-locals))
-	      (:tagbody
-	       (let* ((entry (cleanup-mess-up (nlx-info-cleanup nlx-info)))
-		      (cruft (assoc entry entry-nodes-already-done)))
-		 (cond (cruft
-			(setf (nlx-info-info nlx-info)
-			      (make-byte-nlx-info :stack-slot (cdr cruft)
-						  :duplicate t)))
-		       (t
-			(push (cons entry num-locals) entry-nodes-already-done)
-			(setf (nlx-info-info nlx-info)
-			      (make-byte-nlx-info :stack-slot num-locals))
-			(incf num-locals)))))
-	      ((:catch :unwind-protect)
-	       (setf (nlx-info-info nlx-info) (make-byte-nlx-info))))))
-	(setf (lambda-info lambda)
-	      (make-byte-lambda-info :stack-size num-locals))))))
-
-  (undefined-value))
-
-
-;;; BYTE-COMPILE-COMPONENT -- internal interface.
-;;; 
-(defun byte-compile-component (component)
-  (setf (component-info component) (make-byte-component-info))
-
-  ;; Assign offsets for all the locals, and figure out which args can
-  ;; stay in the argument area and which need to be moved into locals.
-  (assign-locals component)
-
-  ;; Annotate every continuation with information about how we want the
-  ;; values.
-  (annotate-ir1 component)
-
-  ;; Determine what stack values are dead, and emit cleanup code to pop
-  ;; them.
-  (byte-stack-analyze component)
-
-  ;; Assign an ordering of the blocks.
-  (control-analyze component #'make-byte-block-info)
-
-  ;; Find the start labels for the lambdas.
-  (dolist (lambda (component-lambdas component))
-    (let ((info (lambda-info lambda)))
-      (when (byte-lambda-info-interesting info)
-	(setf (byte-lambda-info-label info)
-	      (byte-block-info-label
-	       (block-info (node-block (lambda-bind lambda))))))))
-
-  ;; Delete any blocks that we are not going to emit from the emit order.
-  (do-blocks (block component)
-    (unless (block-interesting block)
-      (let* ((info (block-info block))
-	     (prev (byte-block-info-prev info))
-	     (next (byte-block-info-next info)))
-	(setf (byte-block-info-next prev) next)
-	(setf (byte-block-info-prev next) prev))))
-
-  (let ((segment nil))
-    (unwind-protect
-	(progn
-	  (setf segment (new-assem:make-segment :name "Byte Output"))
-	  (generate-byte-code segment component)
-	  (let ((xeps (generate-xeps component))
-		(constants (byte-component-info-constants
-			    (component-info component))))
-	    (when *compiler-trace-output*
-	      (describe-component component *compiler-trace-output*))
-	    (etypecase *compile-object*
-	      (fasl-file
-	       (maybe-mumble "FASL")
-	       (fasl-dump-byte-component segment constants xeps
-					 *compile-object*))
-	      (core-object
-	       (maybe-mumble "Core")
-	       (make-core-byte-component segment constants xeps
-					 *compile-object*))
-	      (null))))
-      (when segment
-	(new-assem:release-segment segment))))
-  (undefined-value))
-
-
-
-;;;; Extra stuff for debugging.
-
-(defun dump-stack-info (component)
-  (do-blocks (block component)
-     (when (block-interesting block)
-       (print-nodes block)
-       (let ((info (block-info block)))
-	 (cond
-	  (info
-	   (format t
-	   "start-stack ~S~%consume ~S~%produce ~S~%end-stack ~S~%~
-	    total-consume ~S~%~@[nlx-entries ~S~%~]~@[nlx-entry-p ~S~%~]"
-	   (byte-block-info-start-stack info)
-	   (byte-block-info-consumes info)
-	   (byte-block-info-produces info)
-	   (byte-block-info-end-stack info)
-	   (byte-block-info-total-consumes info)
-	   (byte-block-info-nlx-entries info)
-	   (byte-block-info-nlx-entry-p info)))
-	  (t
-	   (format t "no info~%")))))))
-
-
-
-;;;; Hacks until we want to recompile everything.
-
-#+nil
-(defun block-label (block)
-  (declare (type cblock block))
-  (let ((info (block-info block)))
-    (etypecase info
-      (ir2-block
-       (or (ir2-block-%label info)
-	   (setf (ir2-block-%label info) (gen-label))))
-      (byte-block-info
-       (byte-block-info-label info)))))
diff --git a/compiler/c.log b/compiler/c.log
deleted file mode 100644
index a304fda24db21e7d8e32f82ca11663309c3bfe99..0000000000000000000000000000000000000000
--- a/compiler/c.log
+++ /dev/null
@@ -1,2048 +0,0 @@
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
-05-Feb-90 20:45:20, Edit by Ram.
-  Fixed MAKE-INTERPRETED-FUNCTION to specify the LAMBDA slot when creating the
-  function so that it is avaliable to INTERPRETED-FUNCTION-LAMBDA-EXPRESSION.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/sset.lisp
-05-Feb-90 12:07:12, Edit by Ram.
-  Fixed a problem in SSET-UNION-OF-DIFFERENCE.  It was using (>= num2 num3) in
-  two places where it should have been using <=.  Probably due to incorrect
-  modification of the original SSET-DIFFERENCE code into this function.  The
-  original function had the inner loop over the second arg, rather than the
-  first.  This effectively resulted in the difference aspect usually not
-  happening, so the KILL set in constraint propagation never took effect,
-  resulting in some over-zealous type propagation.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-04-Feb-90 10:11:51, Edit by Ram.
-  Oops...  Fixed * transform so that multiplication by 8 doesn't really
-  multiply by 256, etc.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-04-Feb-90 09:48:09, Edit by Ram.
-  Wrote CLOSE-SOURCE-INFO, and made COMPILE-FILE, ADVANCE-SOURCE-FILE and
-  COMPILE-FROM-STREAM call it.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp
-04-Feb-90 08:09:06, Edit by Ram.
-  Added definition for %SP-STRING-COMPARE.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/seqtran.lisp
-04-Feb-90 08:01:21, Edit by Ram.
-  Fixed STRING<>=-BODY a bit.  In addition to some query replace lossage, there
-  was also a genuine ancestral bug in computation of the result in the = case
-  of = ops.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ctype.lisp
-03-Feb-90 20:44:39, Edit by Ram.
-  Made VALID-FUNCTION-USE and VALID-APPROXIMATE-TYPE return NIL, NIL when
-  uncertainty is encountered, rather than T, NIL.  Everybody was expecting this
-  to be a conservative test (and only looking at the first value.)  This caused
-  spurious transforms to happen.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-02-Feb-90 14:08:09, Edit by Ram.
-  Added NTH, NTHCDR transforms for the constant index case.  Added * transform
-  for the power-of-2 case.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/seqtran.lisp
-02-Feb-90 13:00:15, Edit by Ram.
-  Added string transforms, derived from CLC sources.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-02-Feb-90 13:25:40, Edit by Ram.
-  Added FORMAT transform derived from CLC sources.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
-02-Feb-90 11:23:26, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-02-Feb-90 11:23:15, Edit by Ram.
-  Defined TYPE/= and made the "anything changed" tests use it instead of TYPE=
-  so as to be conservative in the presence of hairy types.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-02-Feb-90 10:29:54, Edit by Ram.
-  Changed REOPTIMIZE-CONTINUATION to set BLOCK-TYPE-CHECK in the use blocks so
-  that new derived-type information will also cause type checking to be redone.
-  This mainly handles the case where new type information causes us to want to
-  negate a check that was previously simple.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-02-Feb-90 10:12:24, Edit by Ram.
-  Fixed CONTINUATION-%DERIVED-TYPE to call CONTINUATION-%TYPE-CHECK instead of
-  CONTINUATION-TYPE-CHECK so that it won't recurse indefinitely.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
-01-Feb-90 14:46:13, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-01-Feb-90 14:43:26, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/knownfun.lisp
-01-Feb-90 14:40:22, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-01-Feb-90 14:42:19, Edit by Ram.
-  Flushed *FUNCTION-INFO* in favor of (INFO FUNCTION INFO ...).  Added
-  FUNCTION-INFO-PREDICATE-TYPE slot.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-01-Feb-90 14:09:42, Edit by Ram.
-  Changed ASSERT-CONTINUATION-TYPE to set BLOCK-TYPE-ASSERTED in the use
-  blocks.  Also, moved fixed the setting of BLOCK-TYPE-CHECK to be on the use
-  blocks rather than the CONTINUATION-BLOCK, since type check generation uses
-  DO-NODES, and thus ignores the BLOCK-START.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
-01-Feb-90 13:37:14, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp
-01-Feb-90 13:41:46, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-01-Feb-90 13:41:48, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-01-Feb-90 13:42:05, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-01-Feb-90 13:42:29, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
-01-Feb-90 13:43:07, Edit by Ram.
-  Renamed the CONTINUATION TYPE-CHECK slot to %TYPE-CHECK, which is filtered by
-  the new CONTINUATION-TYPE-CHECK function to make sure that it has been
-  computed recently.  Changed setters of TYPE-CHECK to %TYPE-CHECK, and flushed
-  the now unnecessary calls to CONTINUATION-DERIVED-TYPE (which explicitly did
-  the recomputation.)
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-01-Feb-90 12:56:50, Edit by Ram.
-  Changed %CONTINUATION-DERIVED-TYPE to not set TYPE-CHECK when the assertion
-  is T or there is no DEST.  In the first case, this just avoids waste motion.
-  In the second case, this prevents constraint analysis from being tricked into
-  believing such a check will be done, when in fact no checks are done on
-  unused values.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-01-Feb-90 12:51:41, Edit by Ram.
-  Made DELETE-CONTINUATION, FLUSH-DEST, NODE-ENDS-BLOCK and UNLINK-NODE set the
-  BLOCK-TYPE-ASSERTED and BLOCK-TEST-CHANGED flags.  At least for the former,
-  this has to be done in more places than I thought, and also must be done for
-  correctness, rather than just to ensure new assertions are seen.  This is
-  because if a block is split, or code needing an assertion is deleted, then we
-  must recompute the block's set of constraints or it will contain incorrect
-  constraints.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/sset.lisp
-01-Feb-90 11:33:28, Edit by Ram.
-  Fixed SSET-INTERSECTION to blow away any extra elements in SET1 that are
-  larger than the greatest element in SET2.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
-01-Feb-90 10:34:17, Edit by Ram.
-  Changed initial values for TYPE-ASSERTED and TEST-MODIFIED to be T rather
-  than NIL.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vop.lisp
-30-Jan-90 16:10:06, Edit by Ram.
-  Added IR2-ENVIRONMENT-KEEP-AROUND-TNS and IR2-COMPONENT-PRE-PACKED-SAVE-TNS
-  so that we won't have to recompile to add these features later on.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
-30-Jan-90 14:54:58, Edit by Ram.
-  Added the MAKE-INTERPRETED-FUNCTION interface which allows lazy conversion of
-  functions and features bounded IR1 memory usage through a LRU cache that is
-  partially flushed on GC.  Added INTERPRETED-FUNCTION-NAME,
-  INTERPRETED-FUNCTION-ARGLIST and setf functions.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-30-Jan-90 10:08:19, Edit by Ram.
-  Now that %DEFMACRO is passed #'(lambda ... for benefit for the interpreter,
-  we don't want to unquote the definition using EVAL.  Use SECOND instead.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-29-Jan-90 14:17:06, Edit by Ram.
-  Changed FIND-COMPONENT-NAME to bind *PRINT-LEVEL* and *PRINT-PRETTY* so as to
-  prevent huge component names.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/life.lisp
-29-Jan-90 13:43:23, Edit by Ram.
-  Fixed CONFLICT-ANALYZE-BLOCK in the dead read case to do FROB-MORE-TNS on
-  NOTE-CONFLICTS as well as the addition to the live set.  This was the fix to
-  the long-procrastinated-about :MORE TN bug (first noticed in fall 88.)  Also,
-  changed FROB-MORE-TNS to return whether it did anything, rather than sleazily
-  hacking on the loop variable to get the loop to exit.  I must have been
-  having a Pascal flashback when I wrote that code...
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
-29-Jan-90 13:24:23, Edit by Ram.
-  Fixed LEAF-VALUE to use FDEFINITION rather than SYMBOL-FUNCTION when the name
-  isn't a symbol.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-29-Jan-90 10:46:23, Edit by Ram.
-  Changed COMPILE-FIX-FUNCTION-NAME to substitute for old uses of the name so
-  that recursive calls get converted.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-29-Jan-90 10:13:18, Edit by Ram.
-  But for the want of a single character...  So that's why no functions were
-  being inline expanded!  In %DEFUN the ir1 translator, I was looking at the
-  INLINEP value for the NAME in the same LET that was eval'ing the name to
-  unquote it.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/debug-dump.lisp
-27-Jan-90 18:05:15, Edit by Ram.
-  Made DEBUG-SOURCE-FOR-INFO handle the incremental compilation cases.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-27-Jan-90 17:46:09, Edit by Ram.
-  Wrote COMPILE and UNCOMPILE.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
-27-Jan-90 17:07:17, Edit by Ram.
-  Added the interfaces INTERPRETED-FUNCTION-LAMBDA-EXPRESSION and
-  INTERPRETED-FUNCTION-CLOSURE.  These use the new FIND-IF-IN-CLOSURE operation
-  pick apart the closure that is an interpreted function.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-26-Jan-90 16:35:51, Edit by Ram.
-  Moved a bunch of stuff from COMPILE-FILE to SUB-COMPILE-FILE.  Wrote
-  MAKE-LISP-SOURCE-INFO and MAKE-STREAM-SOURCE-INFO.  Wrote
-  COMPILE-FROM-STREAM, and added appropriate uses of the in-core compilation
-  interface to various functions.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
-26-Jan-90 16:09:30, Edit by Ram.
-  Made the CACHE-NAME slot be duplicated in both kinds of environment rather
-  than inherited from INFO-ENV so that the inline type checks for the slot
-  access will win, allowing bootstrapping to work.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval-comp.lisp
-26-Jan-90 13:12:09, Edit by Ram.
-  Changed COMPILE-FOR-EVAL to call the new MAKE-LISP-SOURCE-INFO, rather than
-  rolling its own.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
-26-Jan-90 11:59:58, Edit by Ram.
-  Added code to cache the last name looked up, since we commonly consecutively
-  look up several types of info for the same name.  [Maybe even some types more
-  than once!]
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-26-Jan-90 09:30:59, Edit by Ram.
-  Fixed PROCESS-TYPE-PROCLAMATION to not try to call TYPES-INTERSECT on
-  function types so that we don't flame out.  This was probably what I was
-  really trying to fix in the last change to PROCESS-TYPE-DECLARATION.  Really
-  both were broken.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-25-Jan-90 10:58:43, Edit by Ram.
-  Added transform for ARRAY-DIMENSION that converts to LENGTH when possible.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/typetran.lisp
-25-Jan-90 10:46:00, Edit by Ram.
-  Moved array typep code here from vm-type-tran, since it turned out not to be
-  VM dependent after all.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/typetran.lisp
-23-Jan-90 15:31:32, Edit by Ram.
-  Transformed array type tests to %ARRAY-TYPEP so that clever
-  implementation-dependent things can be done.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-23-Jan-90 18:45:14, Edit by Ram.
-  Fixed up some messed up backquote stuff in DO-MACROLET-STUFF where it was
-  trying to coerce the lambda to a function.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/envanal.lisp
-23-Jan-90 13:06:41, Edit by Ram.
-  Don't annotate as TAIL-P nodes whose DERIVED-TYPE is NIL, so that we don't
-  tail-call functions such as ERROR.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-23-Jan-90 12:44:28, Edit by Ram.
-  Fixed %DEFUN translator to record an inline expansion when the INLINEP value
-  is :MAYBE-INLINE as well as :INLINE.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-23-Jan-90 08:49:50, Edit by Ram.
-  Changed PUSH-IN and DELETEF-IN to only call FOO-GET-SETF-METHOD when
-  CLC::*IN-THE-COMPILER* is true, so that we can still use these macros in the
-  old compiler.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/seqtran.lisp
-22-Jan-90 16:11:28, Edit by Ram.
-  Added a transform for MEMBER where the list is a constant argument (primarily
-  to help MEMBER type tests.)
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
-22-Jan-90 15:20:27, Edit by Ram.
-  Replaced all uses of COMBINATION- accessors with BASIC-COMBINATION- accessors
-  so that MV combinations will work.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
-22-Jan-90 15:08:07, Edit by Ram.
-  Put a couple of macros in EVAL-WHEN (COMPILE LOAD EVAL) so that they are
-  avaliable to SETF in the bootstrap environment.  Also, changed %SP-[UN]BIND
-  to the appropriate %PRIMITIVE calls.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp
-20-Jan-90 20:21:34, Edit by Ram.
-  Fixed up FBOUNDP & stuff to correspond to the FUNCTION-NAME cleanup.  Now
-  FBOUNDP can take a list as well as a symbol.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-20-Jan-90 09:56:43, Edit by Ram.
-  In #+NEW-COMPILER, made DO-MACROLET-STUFF coerce the lambda expression to a
-  function.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval-comp.lisp
-20-Jan-90 09:52:20, Edit by Ram.
-  Added bind of *FENV* to () in COMPILE-FOR-EVAL.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-20-Jan-90 09:50:59, Edit by Ram.
-  And made IR1-TOP-LEVEL *not* bind *FENV* to () so that top-level MACROLETs
-  will be recognized...
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-20-Jan-90 09:47:19, Edit by Ram.
-  Added binding of *FENV* to () in SUB-COMPILE-FILE so that MACROLET processing
-  won't flame out.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp
-19-Jan-90 22:25:15, Edit by Ram.
-  Made WITH-IR1-ENVIRONMENT bind a bunch more variables.  *fenv*, etc.  Wrote
-  WITH-IR1-NAMESPACE, which allocates the gloabal namespace hashtables.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval-comp.lisp
-19-Jan-90 22:35:44, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-19-Jan-90 22:34:20, Edit by Ram.
-  Flushed IR1-TOP-LEVEL-FOR-EVAL and changed IR1-TOP-LEVEL to take a FOR-VALUE
-  flag so that it can do the same thing.  Added use of WITH-IR1-NAMESPACE.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-19-Jan-90 21:43:20, Edit by Ram.
-  Made SUB-COMPILE-FILE bind *CURRENT-COOKIE* so that people can randomly call
-  (POLICY NIL ...) to get at the current policy, and will never see any
-  leftover local policy from a dynamically enclosing IR1 conversion.
-  ### Maybe this should really be bound somewhere else, like COMPILE-COMPONENT.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-19-Jan-90 22:00:35, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
-19-Jan-90 22:01:47, Edit by Ram.
-  Added a keyword constructor for CBLOCK, and changed all MAKE-BLOCK calls
-  outside of IR1 conversion to use this new constructor, specifying all the
-  values that would otherwise be defaulted from specials.  This is necessary to
-  make stuff properly reentrant.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-19-Jan-90 17:26:17, Edit by Ram.
-  In FIND-FREE-VARIABLE, flushed the assertion that non-constant variables
-  never have constant values.  This isn't really right, but it is better.
-  ### Really, the implementation of "constant but value unknown" variables
-  should be either flushed or redone.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval-comp.lisp
-19-Jan-90 15:31:33, Edit by Ram.
-  New file from Chiles.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
-19-Jan-90 15:30:03, Edit by Ram.
-  New file from chiles.  Changed MY-EVAL to INTERNAL-EVAL and made it frob
-  *ALREADY-EVALED-THIS*.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-19-Jan-90 14:53:28, Edit by Ram.
-  Made IR1 conversion reentrant by having IR1-TOP-LEVEL bind all of the state
-  variables.  Removed DEFVAR initial values for variables that should never be
-  referenced outside of IR1 conversion.  Rather than always making four new
-  hashtables every time, I kept around the global values, allowing them to be
-  used on the outermost call.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-19-Jan-90 11:06:50, Edit by Ram.
-  Changed PROPAGATE-TO-REFS to do nothing when the variable type is a function
-  type so that we don't lose specific function type information, and also so
-  that TYPE-INTERSECTION doesn't gag.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-19-Jan-90 11:24:07, Edit by Ram.
-  Changed PROCESS-TYPE-DECLARATION to quietly set the var type when either the
-  old or new type is a function type, rather than losing trying to do
-  TYPE-INTERSECTION.
-  ### Someday when we have a incompatible-redefinition detection capability, we
-  might want to hook it in here.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-18-Jan-90 16:45:20, Edit by Ram.
-  In %DEFMACRO IR1 convert, when #+NEW-COMPILER, coerce the expander to a
-  function before sticking it in the MACRO-FUNCTION.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-18-Jan-90 14:11:44, Edit by Ram.
-  Changed %DEFUN translator to dump an inline expanion when appropriate.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp
-18-Jan-90 12:33:17, Edit by Ram.
-  Added %STANDARD-CHAR-P and %STRING-CHAR-P to the imports list. 
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
-18-Jan-90 12:24:34, Edit by Ram.
-  In #+NEW-COMPILER, added info type defaults that get information from the
-  environment.  This only affected functions and constant values, since
-  everything else is already stored in the global database.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-18-Jan-90 11:51:45, Edit by Ram.
-  In COMPILE-FILE, fixed FROB to always pathnamify the thing so that
-  OPEN-FASL-FILE won't choke.  Also, this way any syntax error always happens
-  in COMPILE-FILE.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/life.lisp
-18-Jan-90 10:44:11, Edit by Ram.
-  And also in NOTE-CONFLICTS, fixed the declaration for Live-List to be
-  (OR TN NULL) rather than TN.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/life.lisp
-18-Jan-90 10:39:41, Edit by Ram.
-  In NOTE-CONFLICTS, fixed the type for Live-Bits to be LOCAL-TN-BIT-VECTOR,
-  not SC-BIT-VECTOR.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-17-Jan-90 20:47:37, Edit by Ram.
-  Fixed IR2-CONVERT-NORMAL-LOCAL-CALL to set up the argument pointer.  It
-  seems this was only happening in tail calls, so stack arguments did not in
-  general work in local calls.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
-17-Jan-90 16:20:28, Edit by Ram.
-  Changed FIND-TEMPLATE to guard the unsafe policy "trusting" result test by a
-  check for any non-null value of TYPE-CHECK, rather than just T or :ERROR.
-  This since the value might have also been :NO-CHECK, this was usually
-  preventing us from believing the assertion.
-
-  This was resulting in the rather baffling efficiency note that output type
-  assertions can't be trusted in a safe policy, when the policy wasn't safe...
-  I added an assertion that the policy really is safe when we emit that note.
-  Although it should always be the case, lossage in either VALID-FUNCTION-USE
-  or template selection could cause us to end up in that branch.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
-16-Jan-90 21:25:42, Edit by Ram.
-  Renamed the types ENTRY-INFO and ENTRIES-INDEX to be COMPACT-INFO-ENTRY and
-  COMPACT-INFO-ENTRIES-INDEX.  We already had a structure called ENTRY-INFO.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/proclaim.lisp
-16-Jan-90 11:23:51, Edit by Ram.
-  Set the symbol-function of PROCLAIM to the definition of %PROCLAIM.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-16-Jan-90 11:15:56, Edit by Ram.
-  Fixed DEFMACRO ir1 convert to unquote the original arglist before setting the
-  FUNCTIONAL-ARG-DOCUMENTATION.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/codegen.lisp
-15-Jan-90 13:04:59, Edit by Ram.
-  Oops...  I seem to have broken codegen when I changed to it give each block a
-  label, sometimes emitting a label more than once.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-13-Jan-90 13:09:05, Edit by Ram.
-  Changed DELETEF-IN and PUSH-IN to use FOO-GET-SETF-METHOD rather than
-  GET-SETF-METHOD so that they will expand correctly in the bootstrapping
-  environment.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-13-Jan-90 12:27:12, Edit by Ram.
-  Fixed a CDR circularity detection in FIND-SOURCE-PATHS a bit.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
-13-Jan-90 11:49:48, Edit by Ram.
-  In addition to initializing *INFO-CLASSES* in GLOBALDB-INIT for benefit of
-  bootstrapping, we must also init *TYPE-COUNTER* and *TYPE-NUMBERS*.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
-12-Jan-90 16:15:25, Edit by Ram.
-  Changed to use a special FIND-TYPE-INFO function instead of FIND, since the
-  slot accessor TYPE-INFO-NAME isn't avaliable for use as a funarg before
-  top-level forms run.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
-11-Jan-90 11:14:44, Edit by Ram.
-  I'm sooo embarrassed...  I got the rehashing algorithm wrong in compact
-  environments.  The second hash could be 0, resulting in infinite looping.
-  [b.t.w., this is a new largely rewritten version of globaldb that uses
-  special hashtables instead of standard hashtables.  There are two kinds of
-  environments: volatile and compact.  Volatile environments can be modified,
-  but are not especially compact (comparable to the old hashtable
-  implementation, but faster.)  Compact environments are not modifiable, but
-  reduce memory usage by at least half.]
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-10-Jan-90 12:04:33, Edit by Ram.
-  Rather than asserting that (INFO FUNCTION WHERE-FROM <name>) is :ASSUMED
-  whenever the LEAF-WHERE-FROM is assumed, we just quietly skip the unknown
-  function warning code when the name no longer names an assumed function.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-10-Jan-90 11:27:03, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-10-Jan-90 11:24:07, Edit by Ram.
-  Added special-case top-level form processing of EVAL-WHEN, PROGN and MACROLET
-  so that we don't get huge compilations when these forms enclose lots of code
-  at top-level.  To do this, I split off the environment manipulation code in
-  EVAL-WHEN and MACROLET.
-  ### Probably should expand macros to see if they turn into a magic form
-  ### before just compiling the thing.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-09-Jan-90 13:23:41, Edit by Ram.
-  Wrote a version of PROGV.  This IR1 translator is in IR2tran because it goes
-  directly from syntax to shallow-binding primitives.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-08-Jan-90 14:39:46, Edit by Ram.
-  Made FIND-SOURCE-PATHS hack circular source code.  CAR circularities are
-  detected by noticing that the cons is already in the source paths hashtable.
-  CDR circularities are detected using the two-phase trailing pointer hack.
-  This support is necessary as long as circular constants are allowed (which is
-  strongly implied by the presence of the #=/## read syntax.)  Of course if
-  there is circular evaluated code, bad things will still happen...
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-08-Jan-90 13:36:03, Edit by Ram.
-  Made PRINT-SUMMARY print information about compilation units that were
-  aborted, and inhibited printing of unknown function warnings when the warning
-  compilation unit is unwound.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-08-Jan-90 10:58:02, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-08-Jan-90 10:49:04, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
-08-Jan-90 10:28:23, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp
-08-Jan-90 10:40:20, Edit by Ram.
-  Changed *UNKNOWN-FUNCTIONS* a bit.  Now it is a list of UNKNOWN-FUNCTION
-  structures.  This was done primarily to allow the number of warnings to be
-  limited in IR1-CONVERT-OK-COMBINATION-FER-SHER rather than in PRINT-SUMMARY.
-  It turns out that recording hundreds of error locations for tents of
-  functions can suck down a large amount of memory.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-05-Jan-90 16:24:40, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-05-Jan-90 15:58:34, Edit by Ram.
-  Changed *UNKNOWN-FUNCTIONS* to be an alist with one entry for each name, with
-  the value being a list of all the error contexts for the calls.  Made
-  PRINT-SUMMARY print the undefined function warnings sorted by name, limiting
-  the number of warnings per function to *UNKNOWN-FUNCTION-WARNING-LIMIT*.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-05-Jan-90 15:51:31, Edit by Ram.
-  Changed PRINT-SUMMARY to print a warning for each unknown function.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-05-Jan-90 15:46:02, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp
-05-Jan-90 15:45:49, Edit by Ram.
-  Moved detection of unknown function calls to
-  IR1-CONVERT-OK-COMBINATION-FER-SHER so that we can conveniently note the
-  error context each time around.  *UNKNOWN-FUNCTIONS* is now a list of conses
-  (Name . Compiler-Error-Context), with entries for each call to an unknown
-  function.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-05-Jan-90 15:22:04, Edit by Ram.
-  Split off error context determination from error printing by introducing the
-  COMPILER-ERROR-CONTEXT structure.  The current error context can now be saved
-  for future use by calling FIND-ERROR-CONTEXT.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/debug-dump.lisp
-04-Jan-90 10:56:42, Edit by Ram.
-  New file.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-04-Jan-90 10:39:31, Edit by Ram.
-  Put in hooks for dumping debug info.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/entry.lisp
-03-Jan-90 15:04:07, Edit by Ram.
-  Added code to dump the arg documentation.  For now, we do pretty much what
-  the old compiler did, i.e. printing it to a string.
-  ### Eventually, we may want to put in code to flush package qualifiers on the
-  variable names and omit complex default forms.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
-03-Jan-90 14:44:54, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-03-Jan-90 14:50:15, Edit by Ram.
-  Added FUNCTIONAL-ARG-DOCUMENTATION slot and made IR1 conversion set it.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
-03-Jan-90 14:34:44, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-03-Jan-90 14:34:27, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/debug.lisp
-03-Jan-90 14:40:06, Edit by Ram.
-  Added LAMBDA-OPTIONAL-DISPATCH and made IR1 conversion set it in :OPTIONAL
-  lambdas.  Made consistency checker allow this.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-03-Jan-90 14:07:30, Edit by Ram.
-  In DELETE-OPTIONAL-DISPATCH, don't clear the ENTRY-FUNCTION in the :OPTIONAL
-  lambdas.  This info is now kept in the LAMBDA-OPTIONAL-DISPATCH slot, and is
-  not cleared when the lambda stops being an entry point.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/dfo.lisp
-03-Jan-90 10:35:50, Edit by Ram.
-  But we still want to compute the component name in such components...
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/dfo.lisp
-03-Jan-90 09:27:51, Edit by Ram.
-  Changed FIND-INITIAL-DFO to move all components containing a top-level lambda
-  to the end of the compilation order, even if there are XEPs.  This does a
-  better job of ensuring that environment analysis is done before we compile
-  the top-level component which does cross-component references.
-  ### This probably still loses in some pathological case.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-02-Jan-90 17:01:46, Edit by Ram.
-  Fixed CLEAR-IR2-INFO to check whether there is a tail set before attempting
-  to clear its INFO.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-02-Jan-90 14:51:46, Edit by Ram.
-  Changed IR2-CONVERT-CLOSURE to not use the IR2-ENVIRONMENT-ENVIRONMENT, since
-  this is now blown away after the component is compiled.  Instead we use the
-  ENVIRONMENT-CLOSURE, which is just as good.  Actually, this should only
-  happen with references in XEPs, since that is the only kind of function that
-  can reference functions across component boundaries.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-17-Dec-89 15:30:10, Edit by Ram.
-  Wrote CLEAR-IR2-INFO and made COMPILE-TOP-LEVEL call it after it was done
-  with the IR2 for each component.  This should allow the IR2 data structures
-  to be reclaimed after each component is compiled, even in a multi-component
-  compilation.
-
-  ### Eventually it should be possible for the IR1 to be reclaimed after the
-  component is compiled, but there currently cross-component links that inhibit
-  this.  It would also cause problems with IR1 consistency checking, since we
-  currently need to check all components together.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-15-Dec-89 13:33:44, Edit by Ram.
-  In IR1-CONVERT-VARIABLE, when we find a CT-A-VAL, we convert an ALIEN-VALUE
-  form rather than referencing the CT-A-VAL as a leaf.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp
-13-Dec-89 13:38:51, Edit by Ram.
-  In NOTE-FAILED-OPTIMIZATION, also inhibit any attempt to give a note if the
-  combination is no longer a known call.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/gtn.lisp
-12-Dec-89 12:25:57, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-12-Dec-89 12:36:38, Edit by Ram.
-  To avoid having to fix this right right now, changed all passing locations to
-  be *ANY-PRIMITIVE-TYPE* and added code to do necessary coercions to/from the
-  actual variable representation.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
-12-Dec-89 10:21:15, Edit by Ram.
-  Fixed a bunch of declarations that were calling things TYPEs instead of
-  CTYPEs.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-11-Dec-89 10:11:31, Edit by Ram.
-  Changed default fasl file extension from "fasl" to "nfasl", at least for now.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp
-11-Dec-89 08:15:47, Edit by Ram.
-  Changed most uses of the FUNCTION type to CALLABLE, now that FUNCTION doesn't
-  encompass SYMBOL but we can still call them.  Also fixed some lossage where
-  someone believed that the SUBSTITUTE/NSUBSTITUTE family of functions had the
-  same arguments as the DELETE/REMOVE family.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-10-Dec-89 20:33:05, Edit by Ram.
-  Oops...  (fifth x) /==> (nth 5 x), is really (nth 4 x).  So that's why
-  PACKAGE-INIT was losing...
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp
-10-Dec-89 09:23:47, Edit by Ram.
-  Fixed DO-NODES-BACKWARDS to work when the current node is deleted now that
-  UNLINK-NODE blasts the PREV.  Also fixed two bugs in this macro that seem not
-  to have affected the sole use in FLUSH-DEAD-CODE.  One was that it randomly
-  referenced the variable CONT in one place, rather than commaing in the
-  appropriate argument.  The other was that it did an extra iteration binding
-  CONT to the block start and NODE to whatever its USE was (often NIL.)
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-09-Dec-89 13:31:24, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp
-09-Dec-89 13:30:52, Edit by Ram.
-  Wrote NODE-DELETED and made NOTE-FAILED-OPTIMIZATION call it so that we won't
-  gag trying to look at deleted code.  This also prevents bogus efficiency
-  notes about code that was actually optimized away.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-09-Dec-89 13:22:39, Edit by Ram.
-  Made UNLINK-NODE set the NODE-PREV of the deleted node to NIL so that we can
-  recognize deleted nodes.  Also, fixed the degenerate exit branch to add a use
-  by EXIT rather than NODE.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp
-08-Dec-89 11:28:54, Edit by Ram.
-  Changed CONVERT-TYPE-CHECK to call LOCAL-CALL-ANALYZE now that this is not
-  being done in COMPILE-COMPONENT.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-08-Dec-89 11:24:13, Edit by Ram.
-  Fixed PROPAGATE-FUNCTION-CHANGE to call MAYBE-LET-CONVERT in addition to
-  COMVERT-CALL-IF-POSSIBLE so that IR1 optimize will let convert calls that it
-  discovers can be local.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vop.lisp
-08-Dec-89 10:58:23, Edit by Ram.
-  Looks like when I made OLD-CONT and RETURN-PC environment TNs (and requiring
-  the IR2-ENVIRONMENT-SLOTS to be initialized after the environment was
-  created), I modified the wrong slots to allow NIL.  Only detected now because
-  I was running with safe defstruct accessors.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/debug.lisp
-08-Dec-89 09:58:33, Edit by Ram.
-  IR1 invariants now a bit different: :DELETED continuations can only be
-  received by blocks with DELETE-P set, and blocks with DELETE-P set can have
-  no successors. 
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/locall.lisp
-08-Dec-89 09:51:24, Edit by Ram.
-  Don't attempt to let-convert when the REF is in a block with DELETE-P set
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-08-Dec-89 09:50:13, Edit by Ram.
-  Don't attempt to do IR1 optimizations when the block has DELETE-P set, just
-  delete it instead.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-08-Dec-89 09:46:20, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
-08-Dec-89 09:51:26, Edit by Ram.
-  Added BLOCK-DELETE-P and made DELETE-CONTINUATION set it in the DEST block
-  and its predecessors.  Changed most uses of DELETE-CONTINUATION to assert
-  that there isn't a DEST.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-07-Dec-89 22:08:35, Edit by Ram.
-  In IR1-OPTIMIZE-IF, set COMPONENT-REANALYZE before UNLINK-NODE so that there
-  is still a component in the block.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-07-Dec-89 21:17:43, Edit by Ram.
-  In IR1-CONVERT-OK-COMBINATION-FER-SHER, set the CONTINUATION-%DERIVED-TYPE
-  and CONTINUATION-TYPE-CHECK of the fun cont in addition to setting
-  CONTINUATION-REOPTIMIZE.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-07-Dec-89 21:08:09, Edit by Ram.
-  Moved definitions of the arithmetic & logic functions %LDB et al. here from
-  eval.lisp, since we need them in the bootstrapping environment.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-07-Dec-89 19:17:48, Edit by Ram.
-  Changed USE-CONTINUATION not to set the CONTINUATION-%DERIVED-TYPE, as this
-  inhibits CONTINUATION-DERIVED-TYPE from seeing whether the assertion needs to
-  be intersected, etc.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-07-Dec-89 18:55:32, Edit by Ram.
-  Changed IR1-OPTIMIZE to more explicitly ignore a block when it is directly
-  deleted due to :DELETED kind or no predecessors.  The old code should have
-  realized not to optimize a deleted block, but in a rather obscure way.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-07-Dec-89 13:25:38, Edit by Ram.
-  Changed IR1-OPTIMIZE-UNTIL-DONE to count the number of iterations that didn't
-  introduce any new code (set COMPONENT-REANALYZE) rather than just the total
-  number of iterations.  Reduced MAX-OPTIMIZE-ITERATIONS to 3, since we now
-  don't have to worry so much about the results of transforms being adequately
-  optimized.  Changed IR1-PHASES to call GENERATE-TYPE-CHECKS where it was
-  calling CHECK-TYPES.  Flushed old call to GENERATE-TYPE-CHECKS in
-  COMPILE-COMPONENT.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-07-Dec-89 13:24:20, Edit by Ram.
-  Changed IR1-OPTIMIZE-IF to set COMPONENT-REANALYZE if it does anything.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp
-07-Dec-89 12:56:18, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-07-Dec-89 12:28:19, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
-07-Dec-89 13:01:31, Edit by Ram.
-  Changed type checking around a bunch, fixing some bugs and inefficiencies.
-  The old CHECK-TYPES phase is gone.  The determination of
-  CONTINUATION-TYPE-CHECK is now done on the fly by CONTINUATION-DERIVED-TYPE.
-  The compile-time type error detection has been moved into type check
-  generation.  Type check generation is now driven by BLOCK-TYPE-CHECK, so it
-  doesn't have to look at everything on repeat iterations.  Made
-  ASSERT-CONTINUATION-TYPE set BLOCK-TYPE-CHECK when there is a new assertion.
-
-  There are two new values of TYPE-CHECK: :ERROR and :NO-CHECK.  These are used
-  by check generation to comminicate with itself and the back end.  :ERROR
-  indicates a compile-time type error, which always causes a type check to be
-  emitted, regardless of policy.  :NO-CHECK indicates that a check is needed,
-  but expected not to be generated due to policy or a safe implementation.
-  This inhibits LTN from choosing an unsafe implementation based on results of
-  new type information from the post-type-check optimization pass.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
-07-Dec-89 10:01:23, Edit by Ram.
-  Yep, that combined with a bug in how I hooked CTYPEP into TYPES-INTERSECT.
-  That function should return (VALUES T NIL) in the uncertain case, not
-  (VALUES NIL NIL).
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
-07-Dec-89 09:54:44, Edit by Ram.
-  Fixed CTYPEP to return the second value T when it calls TYPEP.  Is this what
-  is causing all hell to break loose?  It shouldn't, since it should just
-  result in increased type uncertainty.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/proclaim.lisp
-06-Dec-89 21:24:00, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp
-06-Dec-89 21:26:24, Edit by Ram.
-  Added support for the DEBUG-INFO optimization quality (DEBUG for short).
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
-06-Dec-89 11:25:36, Edit by Ram.
-  Made CTYPEP return a second value indicating whether it was able to determine
-  the relationship.  Made all callers look at the second value and propagate
-  the uncertainty.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/proclaim.lisp
-06-Dec-89 11:11:06, Edit by Ram.
-  Moved the actual establishing of the type definition to %%COMPILER-DEFSTRUCT
-  from %DEFSTRUCT.  Part of this was actually duplicated both places.  Now it
-  is only here.  Hopefully this won't cause any initialization problems.  Also,
-  made structure redefinition preserve the INCLUDED-BY list so that existing
-  structures won't suddenly be broken when the supertype is compiled.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-06-Dec-89 10:43:21, Edit by Ram.
-  Changed PROCESS-TYPE-PROCLAMATION to call SINGLE-VALUE-TYPE so that we don't
-  try to call TYPE-INTERSECTION on a hairy function type (or make the type of a
-  variable, for all that matter.)
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-05-Dec-89 13:42:19, Edit by Ram.
-  Made NCOMPILE-FILE frob *DEFAULT-COOKIE* so as to make optimize proclamations
-  affect only the file that they appear in (and any compilations dynamically
-  enclosed in that file.)
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-04-Dec-89 09:38:18, Edit by Ram.
-  Flushed :SEMI-INLINE and :ALWAYS-INLINE values for INLINEP.  Added
-  :MAYBE-INLINE, which is interpreted in a more advisory manner.  Changed 
-  IR1-CONVERT-GLOBAL-INLINE so that it does something like the old
-  :SEMI-INLINE case for all inline calls so that recursive functions can be
-  INLINE.
-
-  Fixed this code so that you really can have recursive inline functions.  This
-  was supposedly supported for :SEMI-INLINE functions, but did not in fact
-  work.  We do a hack similar to LABELS: we enter a dummy FUNCTIONAL in the
-  *FREE-FUNCTIONS* to prevent repeated attempts to convert the expansion.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-03-Dec-89 15:03:48, Edit by Ram.
-  Defined SAME-LEAF-REF-P and made transforms for EQ, EQL, < and > use it to
-  see if both args are references to the same variable or functional or
-  whatever.  Also use the EQ transform for CHAR= and EQUAL.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-02-Dec-89 09:26:12, Edit by Ram.
-  Made MAX-OPTIMIZE-ITERATIONS be a ceiling on the number of times that
-  IR1-OPTIMIZE-UNTIL-DONE will iterate.  If exceeded, we clear a bunch of
-  REOPTIMIZE flags and punt.  This was made necessary by the addition of type
-  inference on set variables, which may take arbitrarily long to converge.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-01-Dec-89 14:05:10, Edit by Ram.
-  Added code to compute the type of set LET variables as the union of the types
-  of the initial value and the set values.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp
-01-Dec-89 12:11:57, Edit by Ram.
-  Added code to check to see if it is cheaper to check against the difference
-  between the proven type and the assertion.  If so, emit a check against the
-  negation of this difference.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-01-Dec-89 09:04:37, Edit by Ram.
-  Wrote IR1 transforms for < and > that attempt to statically determine the
-  relationship using type information.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
-01-Dec-89 10:06:56, Edit by Ram.
-  Wrote TYPE-DIFFERENCE.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-30-Nov-89 12:04:24, Edit by Ram.
-  Marked the error signalling funny functions as not returning by using
-  TRULY-THE NIL.  Formerly this was subverting type inference, since the
-  primitive was considered to return *.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-30-Nov-89 11:52:27, Edit by Ram.
-  Made SUBSTITUTE-CONTINUATION-USES do a REOPTIMIZE-CONTINUATION on the New
-  continuation so that we realize we need to recompute its type, etc.  This was
-  seriously crippling type inference.  It probably came unglued in let
-  conversion when we changed over to using the general substitute function.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-30-Nov-89 11:31:00, Edit by Ram.
-  Changed FIND-FREE-VARIABLE to find the type of constants having values with
-  CTYPE-OF, rather than using INFO VARIABLE TYPE.  This way we find a good type
-  for all constants, without interacting with the vagaries of environment query.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-30-Nov-89 10:50:37, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/locall.lisp
-29-Nov-89 13:14:40, Edit by Ram.
-  Moved merging of tail sets from CONVERT-CALL to IR1-OPTIMIZE-RETURN.  The old
-  code wasn't working because IR1 optimizations (such as deleting local EXITs)
-  could cause a local call to be tail-recursive yet the function would never
-  get added to the tail set because it had already been converted.
-
-  Inaccurate computation of the tail sets resulted in bad code problems, since
-  functions were returning in ways not expected by their callers.
-
-  ### This code still isn't quite right, since IR1 optimization is supposed to
-  be optional.  One possible fix would be to do tail annotation in IR1
-  optimization, but then you would have to run IR1 optimize to get proper tail
-  recursion.  This might not be much of an issue, since we will probably always
-  want to do at least some IR1 optimization. 
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-27-Nov-89 12:35:17, Edit by Ram.
-  Fixed a braino in mask computation in the %DPB, %MASK-FIELD and
-  %DEPOSIT-FIELD transforms.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp
-26-Nov-89 15:28:27, Edit by Ram.
-  Fixed MACRO-FUNCTION def to specify a result type of (OR FUNCTION NULL),
-  rather than just FUNCTION.  This was disabling the use of this function as a
-  predicate to test whether a symbol names a macro.  Also fixed the argument
-  order to REPLACE.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-25-Nov-89 22:44:32, Edit by Ram.
-  Fixed RPLACx transforms to return the right value.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
-22-Nov-89 19:27:58, Edit by Ram.
-  Fixed the definition of STRING-CHAR so that it wouldn't seem to be a subtype
-  of STANDARD-CHAR.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/seqtran.lisp
-22-Nov-89 14:31:40, Edit by Ram.
-  In MAPPER-TRANSFORM, I seem to have inverted the sense of the exit test when
-  converting from CONSP to ENDP.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-21-Nov-89 16:51:31, Edit by Ram.
-  Moved GTN before control analysis so that the IR2-Environment is allocated by
-  the time that control analysis runs.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/control.lisp
-21-Nov-89 16:38:24, Edit by Ram.
-  Moved to ADD-TO-EMIT-ORDER the adding of IR2-Blocks to the
-  IR2-ENVIRONMENT-BLOCKS.  This way, overflow blocks created by conflict
-  analysis will appear in this list.  TNs only live in overflow blocks were
-  being considered not to conflict with :ENVIRONMENT TNs.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/stack.lisp
-21-Nov-89 16:34:05, Edit by Ram.
-  Made DISCARD-UNUSED-VALUES make an IR2 block for the cleanup block and call
-  ADD-TO-EMIT-ORDER on it.  I think that if this code ever ran, it would have
-  died.  This code was tested at one point, so it was probably broken by the
-  move of control analysis to before all the other IR2 pre-passes.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/tn.lisp
-21-Nov-89 14:43:29, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/gtn.lisp
-21-Nov-89 14:51:36, Edit by Ram.
-  Wrote MAKE-WIRED-ENVIRONMENT-TN so that the save TNs for old-cont and
-  return-pc could be made environment-live.  Made ASSIGN-IR2-ENVIRONMENT pass
-  the environment to MAKE-xxx-SAVE-TN so that they could make environment-live
-  TNs.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/assembler.lisp
-20-Nov-89 08:58:31, Edit by Ram.
-  In NEW-LOGIOR-ARGUMENT, added code to check that the SB for :REGISTER
-  operands is really REGISTERS.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-20-Nov-89 08:29:42, Edit by Ram.
-  In EMIT-MOVE, added code to emit a type error when moving between
-  incompatible TNs.  It seems that this can happen with functions (especially
-  funny functions) that don't return.  This seems like a good fix until we can
-  figure out how to hack the flow graph when there is a non-returning function.
-  [Incompatible moves may also happen if there is a compile-time type error and
-  the check is deleted due to unsafe policy, etc.]
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp
-17-Nov-89 15:06:51, Edit by Ram.
-  Changed %PUT's IR1 attributes from (FLUSHABLE) to (UNSAFE).
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-17-Nov-89 10:12:48, Edit by Ram.
-  Fixed some missing commas in SOURCE-TRANSFORM-TRANSITIVE that only affected
-  LOGEQV.  Good thing nobody uses it...
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vmdef.lisp
-16-Nov-89 09:42:37, Edit by Ram.
-  Fixed previous fix to work when there is a more result.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vmdef.lisp
-15-Nov-89 13:57:36, Edit by Ram.
-  In TEMPLATE-TYPE-SPECIFIER, if we use a values type for the result, make it
-  &REST T to represent the vagueness of values count matching.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-15-Nov-89 09:57:48, Edit by Ram.
-  Added missing source transform for LOGEQV, which was missed in the previous
-  pass.  This required changing SOURCE-TRANSFORM-TRANSTIVE, since that was
-  already a source transform for LOGEQV.  It's a good thing I left in *both*
-  checks for broken interpreter stubs.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-14-Nov-89 10:41:51, Edit by Ram.
-  Added source transforms for zillions of trivial logic operations that were
-  missing.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-14-Nov-89 10:43:24, Edit by Ram.
-  In %DEFUN, added the presence of an IR2-CONVERT methods to the list of things
-  that inhibits substitution of the actual definition for existing references.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
-13-Nov-89 12:21:52, Edit by Ram.
-  Added source transforms for RPLACA, RPLACD.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-13-Nov-89 12:17:32, Edit by Ram.
-  Moved the test of NODE-REOPTIMIZE out of FIND-RESULT-TYPE and into
-  IR1-OPTIMIZE-RETURN.  This fixes a bug that was introduced when the clearing
-  of NODE-REOPTIMIZE was moved to the start of the loop in IR1-OPTIMIZE-BLOCK.
-  We were never recomputing the RETURN-RESULT-TYPE, since REOPTIMIZE was never
-  set when we got to IR1-OPTIMIZE-RETURN.  With this fix, the previous change
-  should detect broken interpreter stubs.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp
-12-Nov-89 13:05:49, Edit by Ram.
-  Made CHECK-FREE-FUNCTION give a note when it sees a function that doesn't
-  return (return type is NIL.)  I thought that this would detect broken
-  interpreter stubs.  It turns out not to, but still seems like a useful
-  feature.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
-13-Nov-89 11:47:30, Edit by Ram.
-  Made LTN-ANALYZE-KNOWN-CALL give a warning when we are unable to find a
-  template for a known call where there call is to the current function.  This
-  should tell result in a warning when we compile an interpreter stub for a
-  function that the code sources assume is implemented primitively, but the
-  compiler doesn't recognize.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-12-Nov-89 10:54:25, Edit by Ram.
-  Oops...  When doing unsafe global function references, use
-  FAST-SYMBOL-FUNCTION, not FAST-SYMBOL-VALUE.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
-10-Nov-89 13:37:15, Edit by Ram.
-  Oops...  Have to dump package frobbing forms specially for cold load.  This
-  might want to be on a switch someday.  Instead of actually compiling them, we
-  dump them as lists so that Genesis can eval them.  The normal top-level form
-  compilation must be suppressed, since the package system isn't initialized at
-  the time that top-level forms run.
-  
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/dfo.lisp
-05-Nov-89 13:45:11, Edit by Ram.
-  Changed FIND-INITIAL-DFO to return top-level components at the end of the
-  list so that in a block compilation all the functions will be compiled before
-  we compile any of the top-level references to them.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/envanal.lisp
-01-Nov-89 11:57:58, Edit by Ram.
-  Changed Find-Non-Local-Exits back to a loop over all the blocks in the
-  component, rather than trying to find the exits from the Lambda-Entries.
-  Unfortunately, the latter is not possible, since the exit continuation may
-  become deleted if it isn't used.  A possible way to avoid this search would
-  be to make the Entry node have a list of all the Exit nodes, rather than the
-  continuations.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vop.lisp
-31-Oct-89 12:45:20, Edit by Ram.
-  Allow (SETF xxx) for the Entry-Info-Name, in addition to strings and symbols.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-31-Oct-89 12:53:37, Edit by Ram.
-  In Find-Source-Context, only take the car of list first args to DEFxxx forms
-  when the form name is in a special list.  This list initially only contains
-  DEFSTRUCT.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-31-Oct-89 12:23:57, Edit by Ram.
-  In Convert-More-Entry, made the temporaries for the keyword and value
-  ignorable so that we don't get "defined but never read" warnings when there
-  aren't any keywords specified.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-31-Oct-89 12:11:24, Edit by Ram.
-  Fixed Process-Declarations to correctly deal with pervasive special
-  declarations.  Previously, a warning would be given if the varible was only
-  locally declared, and not globally known.  Also an assertion failure would
-  have resulted (rather than a Compiler-Error) when a constant was declared
-  pervasively special.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-31-Oct-89 11:39:54, Edit by Ram.
-  Changed Reference-Constant so that it doesn't call Reference-Leaf anymore,
-  and made the source be an explicit argument.  Changed Reference-Leaf to just
-  use the Leaf-Name as source, rather than (sometime incorrectly) inferring the
-  source for constants.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-20-Oct-89 15:56:56, Edit by Ram.
-  In the :UNKNOWN and :UNUSED cases of CONTINUATION-RESULT-TNS, always return
-  TNs of the specified result types, rather than sometimes returing T TNs.
-  This is some sort of compensation for our new belief that VOPS returining
-  non-T results need not be prepared to accept T TNs.  How many other places
-  does this need to be fixed?
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/stack.lisp
-17-Oct-89 12:36:38, Edit by Ram.
-  In FIND-PUSHED-CONTINUATIONS, fix the check for pushes coming before pops.
-  You can compare nodes and continuations all day without finding any that are
-  EQ.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp
-17-Oct-89 11:44:40, Edit by Ram.
-  Flushed the code in DEFTRANSFORM that was creating a THE out of the CONT's
-  asserted type.  This should be unnecessary, and was made incorrect by the
-  continuation representation change.  If the node was the last in a block and
-  the value wasn't used, then the value would be asserted to be of the NIL
-  type, resulting in a warning. 
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-17-Oct-89 10:51:27, Edit by Ram.
-  Changed Compiler-Mumble to tell whether an error message precedes from
-  *last-format-string*, rather than *last-source-context*, since the last
-  message might not have had a source context.  Made *compiler-error-output* be
-  globally bound to a synonym stream for *error-output* so that calls to
-  Compiler-Error outside of the compiler will more or less work.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp
-16-Oct-89 15:23:13, Edit by Ram.
-  In Convert-Type-Check, set the start & end cleanups of the new block to the
-  *start* cleanup of the Dest's block, and not the end cleanup.  Not sure this
-  is really more correct, but it fixes one case.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/pack.lisp
-12-Oct-89 14:05:43, Edit by Ram.
-  Added a before-GC hook that flushes the per-SB conflict data structure
-  whenever they aren't being used.  This should prevent megabyte-plus conflicts
-  information from persisting after it is needed, and also reduce the cost of
-  Init-SB-Vectors, since the vectors will stay smaller.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-11-Oct-89 11:37:16, Edit by Ram.
-  Made Propagate-Function-Change ignore references that are :Notinline.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-10-Oct-89 23:28:33, Edit by Ram.
-  In Print-Error-Message, use the *Current-Form* as the source form whenever if
-  is non-NIL, even if there is a node in *Compiler-Error-Context*.  This way,
-  messages during IR1 conversion of a transform will be more useful.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-10-Oct-89 22:47:56, Edit by Ram.
-  Now Delete-Optional-Dispatch must be prepared for the main entry to be a let
-  rather than just being deleted or a normal function, since let conversion is
-  being triggered here.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/locall.lisp
-09-Oct-89 17:56:35, Edit by Ram.
-  Fixed Convert-Call to change the combination kind before changing the ref
-  leaf so that the call will appear local at that time.  This allows let
-  conversion to happen when we replace a optional dispatch with one of its EPs.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-09-Oct-89 17:34:42, Edit by Ram.
-  Fixed Delete-Optional-Dispatch to call Maybe-Let-Convert if we notice that a
-  former EP lambda has exactly one reference.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-04-Oct-89 19:05:16, Edit by Ram.
-  In IR1-Optimize-Combination, we must be prepared for the derive-type method
-  to return NIL.  This will happen if the arglist is incompatible with the
-  call (and if the optimizer explicitly returns NIL.)
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp
-04-Oct-89 19:22:17, Edit by Ram.
-  Check-Transform-Keys and Check-Keywords-Constant were checking the second
-  (value) part of the key/value pair, so optimizers would never run if any
-  keywords were supplied.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-04-Oct-89 15:39:27, Edit by Ram.
-  When I changed Propagate-Local-Call-Args to clear the Continuation-Reoptimize
-  flags, I forgot that a local call continuation can be NIL (for an unused
-  argument.) 
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-04-Oct-89 11:05:48, Edit by Ram.
-  Oops...  In Propagate-Function-Change, we have to use
-  Continuation-Derived-Type rather than Continuation-Type now that the latter
-  changes function types to FUNCTION.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
-27-Sep-89 14:24:04, Edit by Ram.
-  Exported basic interface (but not environment vars, pending some abstract
-  interface to environment manipulation.)  Changed class and type names to be
-  represented as strings at run time to avoid package lossage.  Changed names
-  to be arbitrary equal objects (to allow setf functions).
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-21-Sep-89 10:12:38, Edit by Ram.
-  Changed OK-Result-TN to indicate need for a coercion if the result is unboxed
-  and the TN is boxed.  This prevents load-TN packing from getting confused due
-  to there being no intersection between the SC restriction and the types
-  allowed by the SC.  This would happen when the result was restricted to a
-  non-descriptor SC.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
-21-Sep-89 10:39:04, Edit by Ram.
-  Changed Restrict-Descriptor-Args to restrict the argument only when a
-  coercion was required.  This allows immediate objects to be passed to
-  templates in unboxed registers.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-30-Aug-89 14:37:36, Edit by Ram.
-  Changed Change-Leaf-Ref (and hence Substitute-Leaf) to use Derive-Node-Type
-  on the Ref with the Leaf-Type so that substituting a variable causes the new
-  type to be noticed. 
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-30-Aug-89 14:30:44, Edit by Ram.
-  Changed IR1-Optimize-Block and all the combination optimization code to clear
-  optimize flags *before* optimizing rather than after, so that a node will be
-  reoptimized if necessary.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vmdef.lisp
-29-Aug-89 09:20:18, Edit by Ram.
-  Made Template-Type-Specifier hack *'s in operand type restrictions.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
-24-Aug-89 13:55:04, Edit by Ram.
-  In LTN-Analyze-MV-Call, have to annotate the continuations in reverse order,
-  now that the IR2-Block-Popped isn't built in reverse order.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
-24-Aug-89 13:25:14, Edit by Ram.
-  In LTN-Analyze, eliminated assertion that the block containing the use of a
-  unknown-values continuation is not already in the
-  IR2-Component-Values-Generators.  It is possible for a single block to
-  contain uses of several MV continuations that have their DEST in a different
-  block.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/dfo.lisp
-22-Aug-89 12:12:49, Edit by Ram.
-  Made Find-Initial-DFO-Aux call Walk-Home-Call-Graph on each block before
-  walking the successors.  Walk-Home-Call-Graph is a new function that looks at
-  the current block's home lambda's bind block to see if it is in a different
-  component.  We need to do this to ensure that all code in a given environment
-  ends up in the same component, since any successor might be a non-local exit
-  (into a different environment.)  
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-18-Aug-89 15:46:51, Edit by Ram.
-  Flushed the (locally (declare (optimize (safety 0))) ...) around the body of
-  Unwind-Protect's expansion.  I think that this was trying to suppress some
-  type checking of the MV-Bind, but it was also causing unsafe compilation of
-  the protected form.  If we really need this, it must be but back some other
-  way.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-18-Aug-89 15:11:13, Edit by Ram.
-  Oops...  We can't use Label-Offset in the generators for Make-Catch-Block,
-  &c.  Instead, we use a :Label load-time constant.  The target argument to the
-  VOPs is now a normal integer argument, rather than a label in the
-  codegen-info.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
-18-Aug-89 14:13:51, Edit by Ram.
-  In LTN-Analyze-Return, don't annotate NLX continuations as :Unused so that
-  the NLX entry code doesn't have to worry about this case.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-18-Aug-89 13:45:19, Edit by Ram.
-  In Reoptimize-Continuation, don't do anything if the continuation is deleted.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
-17-Aug-89 11:17:13, Edit by Ram.
-  Oops...  In Node-Ends-Block, have to set the Block-Start-Uses, now that it is
-  always supposed to hold the uses of block starts.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
-10-Aug-89 10:49:01, Edit by Ram.
-  Changed Find-Template to intersect the Node-Derived-Type with the
-  Continuation-Asserted-Type rather than using the Continuation-Derived-Type in
-  the case where we are allowed to use the result type assertion.  This works
-  better when the continuation has multiple uses. 
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/typetran.lisp
-24-Jul-89 14:25:09, Edit by Ram.
-  Fixed Source-Transform-Union-Typep to check that there really is a MEMBER
-  type in the union, instead of assuming there is whenever LIST is a subtype.
-  This was losing on (OR SYMBOL CONS).
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/assembler.lisp
-19-Jul-89 14:36:10, Edit by Ram.
-  Made Init-Assembler nil out the Info slots in all the fixups so that the
-  fixup freelist doesn't hold onto the entire IR.  More storage allocation
-  lossage has been caused by the explicit freelists in the assembler than
-  anything else.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp
-12-Jul-89 15:34:09, Edit by Ram.
-  Changed defining macros to stick the actual function object into the
-  Function-Info &c to be compatible with the new definition of the Function
-  type.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-12-Jul-89 12:57:24, Edit by Ram.
-  Fixed goof in IR2-Convert-Local-Unknown call, where it was converting the
-  result TN list to TN-refs twice.  For some reason, this was dying with a
-  highly mysterious error in Reference-TN-List.  Perhaps this file was last
-  compiled with an unsafe policy? 
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/life.lisp
-11-Jul-89 19:29:05, Edit by Ram.
-  In Propagate-Live-TNs, when we convert a :Read-Only conflict to :Live, we
-  null the entry in the local TNs to represent the elimination of local
-  conflict information.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-11-Jul-89 18:46:17, Edit by Ram.
-  Changed %Defun to only substitute the functional when it isn't notinline and
-  isn't known to have any templates or transforms.  The latter constraint fixes
-  big problems with interpreter stubs.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
-05-Jul-89 22:11:10, Edit by Ram.
-  In Return-From, put back code that made Cont start a block so that Cont will
-  have a block assigned before IR1-Convert.  So that's why that was there.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
-05-Jul-89 18:07:48, Edit by Ram.
-  In Annotate-Unknown-Values-Continuation, make a safety note when we delete a
-  check and the policy is safe.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
-05-Jul-89 17:43:18, Edit by Ram.
-  In IR1-Optimize-Exit, don't propagate Cont's type to the Value, since this
-  moves checking of the assertion to the Exit, which is a bad place.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-05-Jul-89 15:10:34, Edit by Ram.
-  In Emit-Return-For-Locs, changed the test for when to use known return
-  convention from External-Entry-Point-P to *not* External-Entry-Point-P.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
-05-Jul-89 14:41:55, Edit by Ram.
-  Oops...  We need a UWP-Entry VOP for Unwind-Protect entries to force random
-  live TNs onto the stack.  It doesn't actually do anything, but specifies the
-  passing locations as results so that they aren't forced to the stack.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
-03-Jul-89 16:46:09, Edit by Ram.
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/stack.lisp
-03-Jul-89 16:39:53, Edit by Ram.
-  Changed unknown values hackery to ignore non-local exits.  We don't record
-  NLX uses of unknown-values continuations as generators, and we stop
-  our graph walk when we hit the component root.  These changes were
-  necessitated by the decision to make %NLX-Entry no longer use the values
-  continuation. 
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/pack.lisp
-03-Jul-89 11:31:36, Edit by Ram.
-  Fixed one-off error in Pack-Wired-TN's determination of when we have to grow
-  the SB, and fixed it to handle SC-Element-Size /= 1 while I was at it.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/locall.lisp
-29-Jun-89 12:02:16, Edit by Ram.
-  In Local-Call-Analyze-1, moved the test for the reference being by the
-  Basic-Combination-Fun to around the entire branch that attempts to convert,
-  rather than immediately around the call to Convert-Call-If-Possible.  Before,
-  a closure arg to a local function wouldn't get an XEP.
-
-  Also, changed Reference-Entry-Point to ignore references to :Cleanup and
-  :Escape functions.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/envanal.lisp
-28-Jun-89 16:57:12, Edit by Ram.
-  In Emit-Cleanups, if we find there is no cleanup code, then do nothing,
-  instead of inserting a cleanup block holding NIL.  This was causing blocks
-  with no non-local uses to inhibit tail-recursion.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp
-28-Jun-89 14:03:45, Edit by Ram.
-  It finally happened.  A paren error that resulted in mysterious lossage.  In
-  this case, the body of the loop in Make-Type-Check-Form was moved out of the
-  loop, and always executed once.  The meant that only one value would ever be
-  checked or propagated on to the original receiver.
-
-/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/pack.lisp
-28-Jun-89 13:20:59, Edit by Ram.
-  Oops...  I introduced a bug in the previously correct argument case of
-  Load-TN-Conflicts-In-SB.  We terminate the loop when we reach the first
-  reference, not the first argument.  This caused conflicts with temporaries
-  with lives beginning at :Load to be ignored.
-
-/usr1/lisp/compiler/pack.lisp, 23-Jun-89 15:54:32, Edit by Ram.
-  Fixed logic in Load-TN-Conflicts-In-SB.  We weren't recognizing conflicts
-  with other argument/result TNs that had already been packed.  This bug would
-  only show up with multiple result load TNs.  The argument case was actually
-  correct, but was asymmetrical with the result case, and only worked becase
-  argument load TNs were packed in evaluation order.
-
-/usr1/lisp/compiler/locall.lisp, 20-Jun-89 14:53:51, Edit by Ram.
-  In Merge-Tail-Sets, quietly do nothing if the called function has no tail set
-  (doesn't return), rather than dying.
-
-/usr1/lisp/compiler/globaldb.lisp, 14-Jun-89 10:14:04, Edit by Ram.
-  Flushed Top-Level-P attribute.
-
-/usr1/lisp/compiler/macros.lisp, 14-Jun-89 10:14:03, Edit by Ram.
-  Allow a doc string in Def-IR1-Translator (made the FUNCTION documentation).
-  Removed support for Top-Level-P attribute.
-
-/usr1/lisp/compiler/ir1opt.lisp, 22-May-89 15:30:59, Edit by Ram.
-/usr1/lisp/compiler/ir1util.lisp, 22-May-89 15:22:17, Edit by Ram.
-  Undid last change to Node-Ends-Block and Join-Blocks.  This was fucking up
-  big time, since it messed with the continuation even when it was a block
-  start.
-
-/usr1/lisp/compiler/locall.lisp, 22-May-89 13:24:48, Edit by Ram.
-  Changed Local-Call-Analyze to maintain the Component-New-Functions exactly up
-  to date, only popping a function off exactly as it analyzes it.  This way, a
-  lambda is always referenced either in the Lambdas or New-Functions (except
-  during a brief window), so we can do consistency checking during local call
-  analysis.
-
-/usr1/lisp/compiler/ir1util.lisp, 19-May-89 10:05:28, Edit by Ram.
-/usr1/lisp/compiler/ir1opt.lisp, 19-May-89 10:05:27, Edit by Ram.
-  In Flush-Dest and Reoptimize-Continuation, take care not to assume that the
-  Continuation-Block is an undeleted block.  Instead, we pick up the component
-  to reoptimize from the uses or Dest.
-  
-/usr1/lisp/compiler/ir2tran.lisp, 17-May-89 12:48:35, Edit by Ram.
-  In Move-Results-Coerced and Move-Results-Checked, subtract Nsrc from Ndest,
-  rather than the other way around.
-
-/usr1/lisp/compiler/control.lisp, 15-May-89 11:53:36, Edit by Ram.
-  Made Control-Analyze walk XEPs first to eliminate the idiocy of never getting
-  the drop-through in components with only one EP.
-
-/usr1/lisp/compiler/ir1util.lisp, 13-May-89 15:23:28, Edit by Ram.
-  And similarly, in Node-Ends-Block, move the last continuation to the new
-  block when its block is the old block.
-
-/usr1/lisp/compiler/ir1opt.lisp, 13-May-89 15:02:31, Edit by Ram.
-  In Join-Blocks, move the Cont of the Last to Block1 when it's block is
-  currently Block2.  This way, the continuation isn't left pointing at some
-  random deleted block.
-
-/usr1/lisp/compiler/ir1util.lisp, 14-Mar-89 10:12:04, Edit by Ram.
-  Also, in Delete-Block, when we delete a bind, call Delete-Lambda, rather
-  than trying to roll our own.
-
-/usr1/lisp/compiler/ir1util.lisp, 14-Mar-89 10:07:01, Edit by Ram.
-  In Delete-Lambda, we must remove a let from its home's lets.
-
-/usr1/lisp/compiler/ir1util.lisp, 14-Mar-89 09:34:54, Edit by Ram.
-  In Unlink-Node, the assertion that the start and end cleanups are the same
-  must use Find-Enclosing-Cleanup, rather than just comparing the values
-  directly.
-
-/usr1/lisp/compiler/ir2tran.lisp, 14-Mar-89 08:26:04, Edit by Ram.
-  Wrote Flush-Tail-Transfer and made people who do TR stuff use it.  This
-  function deletes the link between the blocks for a TR node and the block
-  containing the return node.  We have to do this so that lifetime analysis
-  doesn't get confused when there are TNs live at the return node, but some
-  predecessors of the return don't write the TNs because the return some other
-  way.
-
-/usr1/lisp/compiler/srctran.lisp, 10-Mar-89 19:11:51, Edit by Ram.
-  Made the transforms into %typep always pass until we do type predicates for
-  real.
-
-/usr1/lisp/compiler/assembler.lisp, 10-Mar-89 18:56:45, Edit by Ram.
-  Fixed Macrolet of Emit-Label in Def-Branch to have a paren in the right
-  place.  As written, it expanded into its argument, and didn't enclose any
-  code anyway.  But I think this would only affect instructions that both were
-  a branch and had a load-time fixup.
-
-/usr1/lisp/compiler/assembler.lisp, 10-Mar-89 18:47:50, Edit by Ram.
-  Added code to Def-Branch in the choose function that calls
-  Undefined-Label-Error when the the label isn't defined.  This function uses
-  the *assembler-nodes* source info and the branch instruction location to
-  print the source node responsible for generating the bogus branch.
-
-/usr1/lisp/compiler/assembler.lisp, 10-Mar-89 17:59:51, Edit by Ram.
-  Made Gen-Label initalize the Elsewhere-P slot to :Undecided.  Also made
-  Merge-Code-Vectors ignore labels whose Elsewhere-P is undecided.  The theory
-  is that it should be o.k. to make labels that aren't emitted as long as you
-  don't reference them.  Of course, I will probably find that the losing labels
-  are referenced.  Renamed the Location slot in Label to %Location, and defined
-  Label-Location to filter out undefined labels.
-
-/usr1/lisp/compiler/ltn.lisp, 10-Mar-89 17:43:39, Edit by Ram.
-  In LTN-Analyze-Return, we must check for the Return-Info-Count being :Unknown
-  rather than null when we want to know if a fixed number of values are
-  returned.
-
-/usr1/lisp/compiler/ir2tran.lisp, 07-Mar-89 18:13:12, Edit by Ram.
-  In the Values-List IR2 convert method, we must also handle :Unused
-  continuations, only punting when the continuation is :Fixed.  When called
-  with a TR result continuation, we have to emit the unknown-values return
-  ourself.  Otherwise, there isn't any way to write the Values-List function.
-
-/usr1/lisp/compiler/ir2tran.lisp, 06-Mar-89 21:25:12, Edit by Ram.
-  Make-Closure takes the number of closure vars and the function-entry, rather
-  than the other way around.
-
-/usr1/lisp/compiler/ir2tran.lisp, 06-Mar-89 20:48:29, Edit by Ram.
-  And always pass 1 as the number of symbols to Unbind, rather than 0.
-
-/usr1/lisp/compiler/ir2tran.lisp, 06-Mar-89 20:43:47, Edit by Ram.
-  Args to the Bind miscop are (Value, Symbol), and not the other way around.
-
-/usr1/lisp/compiler/ir2tran.lisp, 06-Mar-89 19:09:16, Edit by Ram.
-  In IR2-Convert-IF, we have to negate the sense of the test when using an EQ
-  NIL check.  Made IR2-Convert-Conditional take an additional not-p argument.
-
-/usr1/lisp/compiler/ctype.lisp, 06-Mar-89 17:22:40, Edit by Ram.
-  In Definition-Type, when we make the Function-Type, include the list of
-  keyword info that we have built.
-
-/usr1/lisp/compiler/ir2tran.lisp, 02-Mar-89 18:16:40, Edit by Ram.
-  In Init-XEP-Environment, when we are checking for whether there is a more
-  arg, look at the entry-function rather than the XEP.
-
-/usr1/lisp/compiler/main.lisp, 01-Mar-89 15:58:32, Edit by Ram.
-  Made Clear-Stuff clear the Finite-SB-Live-TNs in all SBs.  Maybe this will
-  nuke some garbage.
-
-/usr1/lisp/compiler/pack.lisp, 01-Mar-89 15:50:41, Edit by Ram.
-  In Grow-SC, fill the Finite-SB-Live-TNs vector with NILs before we lose it so
-  that if it is statically allocated, it won't hold onto garbage.  But this
-  shouldn't make any difference, since we never use the Live-TNs in unbounded
-  SBs.
-
-/usr1/lisp/compiler/locall.lisp, 01-Mar-89 01:15:22, Edit by Ram.
-  In Make-XEP-Lambda, in the lambda case, we now include an ignore declaration
-  for the nargs var when policy suppresses the argument count check.
-
-/usr1/lisp/compiler/ir1util.lisp, 28-Feb-89 19:39:56, Edit by Ram.
-  Also clear :Optional kind for the Main-Entry in Delete-Optional-Dispatch.
-
-/usr1/lisp/compiler/locall.lisp, 28-Feb-89 19:31:07, Edit by Ram.
-  Changed Local-Call-Analyze so that it pushes new lambdas on the
-  Component-Lambdas before it does any call analysis or let conversion.  This
-  gets the normal consistency maintenance code to handle removal of deleted
-  and let lambdas.  Before, there was a local list of new lambdas that could
-  become inconsistent.
-
-/usr1/lisp/compiler/ir1tran.lisp, 28-Feb-89 18:12:15, Edit by Ram.
-  Instead of trying to set the :Optional kind everywhere that hairy lambda
-  conversion creates a lambda, we wait until we are done and set the kind only
-  the lambdas that are actually e-ps.  This was causing internal lambdas that
-  weren't e-ps to be marked as optional.  The fix is also clearer, and causes
-  less complication in the already-hairy code.
-
-/usr1/lisp/compiler/ir1tran.lisp, 24-Feb-89 15:26:29, Edit by Ram.
-  Changed Optional-Dispatch stuff to set the Functional-Entry-Function of the
-  :Optional lambdas to the result Optional-Dispatch structure.
-
-/usr1/lisp/compiler/ir1opt.lisp, 24-Feb-89 14:46:57, Edit by Ram.
-  In IR1-Optimize, changed test for being in a deleted lambda to just look at
-  the block-lambda, rather than at it's home.  The result should be the same.
-
-/usr1/lisp/compiler/entry.lisp, 24-Feb-89 14:30:37, Edit by Ram.
-  Changed Compute-Entry-Info to use the XEP's environment to determine whether
-  the function is a closure.  The result should be the same, but is more easily
-  obtained.
-
-/usr1/lisp/compiler/ir1util.lisp, 24-Feb-89 14:26:58, Edit by Ram.
-  Deleted definition of Find-XEP-Call, since this doesn't make sense anymore.
-
-/usr1/lisp/compiler/debug.lisp, 24-Feb-89 14:21:09, Edit by Ram.
-  Flushed permission of random wired live TNs at the start of an XEP.
-
-/usr1/lisp/compiler/debug.lisp, 24-Feb-89 14:18:01, Edit by Ram.
-  In Check-Block-Successors, flushed permission of random successor count in
-  XEPs.
-
-/usr1/lisp/compiler/ir2tran.lisp, 24-Feb-89 14:14:12, Edit by Ram.
-  Flushed check for being the bind block for an XEP that inhibited emission of
-  a block-finishing branch in Finish-IR2-Block.  Control flow is now normal in
-  XEPs, so we don't want to randomly flush branches.
-
-/usr1/lisp/compiler/ir1opt.lisp, 24-Feb-89 14:07:52, Edit by Ram.
-  Flushed check for being in an XEP in Join-Successor-If-Possible.  Now that
-  argument count dispatching is done explicitly, there is no need to force the
-  call to a block boundry (for easy location).  Also, we are getting more
-  complex code in the XEP, making block merging a desirable optimization.
-
-/usr1/lisp/compiler/ir1util.lisp, 24-Feb-89 14:03:35, Edit by Ram.
-  Fixed code in Delete-Lambda that was trying to notice when we are deleting
-  the the XEP for an optional dispatch.  The test was right, but the action was
-  wrong: it was setting the Functional-Entry-Function for all the e-p's to NIL,
-  yet they were already NIL.  Instead, we call Delete-Optional-Dispatch, which
-  deletes the unreferenced e-p's.
-
-/usr1/lisp/compiler/ir1tran.lisp, 23-Feb-89 20:17:21, Edit by Ram.
-  Wrapped a (locally (declare (optimize (safety 0))) ...) around the body of
-  the loop created in Convert-More-Entry so that no type checking is done on
-  the fixnum arithmetic.
-
-/usr1/lisp/compiler/ir2tran.lisp, 23-Feb-89 14:34:49, Edit by Ram.
-  Flushed most of the hair associated with the %Function-Entry funny function.
-  What remains is now in Init-XEP-Environment, which is called by
-  IR2-Convert-Bind when the lambda is an XEP.
-
-/usr1/lisp/compiler/gtn.lisp, 23-Feb-89 14:24:20, Edit by Ram.
-  Flushed some special-casing of XEPs that is no longer needed now that XEP's
-  have args.  Also, allocation of argument passing locations in XEPs is now
-  more similar to the non-XEP case: we don't allocate passing locations for
-  unused arguments.
-
-/usr1/lisp/compiler/locall.lisp, 22-Feb-89 15:26:50, Edit by Ram.
-  Change handling of XEPs.  Most of the action in XEPs is now represented by
-  explicit IR1 in the XEP: argument dispatching is done by a COND, etc.
-  Instead of using funny functions such as %XEP-ARG to access the passed
-  arguments, NARGS and all the positional arguments are passed as arguments to
-  the XEP (with garbage defaults for unsupplied args).  The code in the XEP
-  just references these variables.
-
-  This simplifies creation of the XEP, since we can just cons up a lambda form
-  and convert it, instead of creating each XEP call by hand.  It also moves
-  complexity out of IR2 conversion, since argument dispatching has already been
-  implemented.
-
-/usr1/lisp/compiler/ir2tran.lisp, 16-Feb-89 15:12:17, Edit by Ram.
-  Fixed %XEP-Arg to use Move-Argument rather than just Move.
-
-/usr1/lisp/compiler/node.lisp, 15-Feb-89 00:36:30, Edit by Ram.
-  Made Functional specify :Defined and Function as the defaults for the
-  Where-From and Type slots so that we know defined functions are in fact
-  functions.
-
-/usr1/lisp/compiler/ir1tran.lisp, 14-Feb-89 23:48:37, Edit by Ram.
-  In %Defun translator, fixed the test for being at top level (and thus o.k. to
-  substitute).  The sense was negated, but it was also broken so that it was
-  always false, so the normal top-level thing happened anyway.
-
-/usr1/lisp/compiler/ir1tran.lisp, 14-Feb-89 15:02:14, Edit by Ram.
-  Wrote Leaf-Inlinep and changed uses to (cdr (assoc leaf *inlines*)) with the
-  new function.  This means that global declarations will now affect function
-  references.
-
-/usr1/lisp/compiler/main.lisp, 13-Feb-89 12:19:39, Edit by Ram.
-  Call Init-Assembler *before* Entry-Analyze so that we don't emit labels when
-  the assembler isn't initialized.
-
-/usr1/lisp/compiler/ltn.lisp, 02-Feb-89 15:41:40, Edit by Ram.
-  Changed Annotate-Function-Continuation not to clear Type-Check unless the
-  policy is unsafe.  Changed LTN-Default-Call to take a policy argument and
-  pass it through.
-
-/usr1/lisp/compiler/ir1tran.lisp, 02-Feb-89 15:16:32, Edit by Ram.
-  Changed IR1-Convert-Combination-Args and the translator for
-  Multiple-Value-Call to assert that the function continuation yeilds a value
-  of type Function.
-
-/usr1/lisp/compiler/assembler.lisp, 31-Jan-89 14:13:54, Edit by Ram.
-/usr1/lisp/compiler/codegen.lisp, 31-Jan-89 14:13:53, Edit by Ram.
-  Added a function version of Emit-Label that can be called outside of
-  Assemble.  Used this in Generate-Code so that we don't have to worry about
-  faking the current node for Assemble, when we aren't emitting any code
-  anyway.
-
-/usr1/lisp/compiler/assembler.lisp, 31-Jan-89 13:56:08, Edit by Ram.
-  In Init-Assembler, Null out the Assembler-Node-Names in *Assembler-Nodes* so
-  that we don't hold onto old garbage.  Also zero the code vectors so that
-  unitialized bytes always come up zero.
-
-/usr1/lisp/compiler/ir2tran.lisp, 31-Jan-89 12:37:21, Edit by Ram.
-  Fixed IR2-Convert-Local-Unknown-Call to use Standard-Value-TNs to get the
-  result TNs, rather than calling incorrectly calling Make-Standard-Value-TNs
-  on a continuation.
-
-/usr1/lisp/compiler/ir1opt.lisp, 30-Jan-89 23:28:08, Edit by Ram.
-  Changed Check-Types to not set Type-Check when the asserted type is T and the
-  derived type is *.
-
-/usr1/lisp/compiler/ir1util.lisp, 30-Jan-89 19:36:09, Edit by Ram.
-  Changed Delete-Ref not to call Delete-Lambda or Delete-Optional-Dispatch when
-  the functional is already deleted.
-
-/usr1/lisp/compiler/locall.lisp, 30-Jan-89 19:23:26, Edit by Ram.
-  Convert-MV-Call must add the ep to the Lambda-Calls for the home lambda (as
-  in Convert-Call) so that DFO can detect the control transfer implicit in
-  local call.
-
-/usr1/lisp/compiler/ir1util.lisp, 30-Jan-89 18:30:27, Edit by Ram.
-  Changed Delete-Optional-Dispatch to call Delete-Lambda on all entry points
-  with no references.
-
-/usr1/lisp/compiler/ir1util.lisp, 30-Jan-89 17:04:33, Edit by Ram.
-  Changed Delete-Lambda to mark the Lambda's lets as :Deleted as well,
-  guaranteeing that all code in the environment of a deleted lambda is deleted
-  (without having to do flow analysis).
-
-/usr1/lisp/compiler/locall.lisp, 30-Jan-89 16:37:31, Edit by Ram.
-  Changed Convert-MV-Call not to call Let-Convert, since the last entry may
-  have spurious references due to optional defaulting code that hasn't been
-  deleted yet.  Changed Maybe-Let-Convert to set the Functional-Kind of the
-  lambda to :Let or :MV-Let, depending on the combination type.
-
-/usr1/lisp/compiler/locall.lisp, 30-Jan-89 15:35:52, Edit by Ram.
-  Changed Merge-Cleanups-And-Lets to use Find-Enclosing-Cleanup to determine
-  whether there is any cleanup in effect at the call site, rather than directly
-  using the Block-End-Cleanup.
-
-/usr1/lisp/compiler/ir1util.lisp, 30-Jan-89 15:12:51, Edit by Ram.
-  Changed Node-Ends-Block to set the start and end cleanups of the *new* block
-  (not the old) to the ending cleanup of the old block.  This is clearly more
-  right, but may not be totally right.
- 
-/usr1/lisp/compiler/life.lisp, 27-Jan-89 17:09:01, Edit by Ram.
-  Make Clear-Lifetime-Info always set the TN-Local slot for local TNs, using
-  some other referencing block when there there are global conflicts.
-
-/usr1/lisp/compiler/pack.lisp, 10-Jan-89 15:27:21, Edit by Ram.
-  Fixed Select-Location not to infinite loop when Finite-Sb-Last-Offset is 0.
-
-/usr0/ram/compiler/ir2tran.lisp, 30-Jun-88 13:57:12, Edit by Ram.
-  Fixed IR2-Convert-Bind to ignore vars with no Refs.
-
-/usr0/ram/compiler/gtn.lisp, 30-Jun-88 13:54:51, Edit by Ram.
-  Fixed Assign-Lambda-Var-TNs and Assign-IR2-Environment to ignore vars with no
-  Refs.
-
-/usr0/ram/compiler/life.lisp, 02-Mar-88 17:06:18, Edit by Ram.
-  Aaaargh!  When clearing the Packed-TN-Local in Clear-Lifetime-Info, iterate
-  up to Local-TN-Limit, not SC-Number-Limit.
-
-/usr0/ram/compiler/ir1util.lisp, 20-Feb-88 22:00:37, Edit by Ram.
-  Made Substitute-Leaf and Change-Ref-Leaf do an Up-Tick-Node on the changed
-  Refs.
-
-/usr0/ram/compiler/ltn.lisp, 20-Feb-88 16:25:11, Edit by Ram.
-  Changed Find-Template to deal with output assertions correctly once again.
-  Instead of assuming that the Node-Derived-Type is true, we look at the
-  Type-Check flag in the continuation.  If the continuation type is being
-  checked, then we only use a template when it doesn't have an output
-  restriction.
-
-  In Find-Template-For-Policy, use safe templates as a last resort, even when
-  policy is :Small or :Fast.  A safe template is surely faster and smaller than
-  a full call.
-
-  In Ltn-Analyze, clear the Type-Check flags on all continuations when our
-  policy is unsafe.
-
-/usr0/ram/compiler/debug.lisp, 18-Feb-88 17:17:19, Edit by Ram.
-  And fixed Check-VOP-Refs to ensure that the temporary write comes before
-  (which is after in the reversed VOP-Refs) the read, rather than vice-versa...
-
-/usr0/ram/compiler/vmdef.lisp, 18-Feb-88 17:10:35, Edit by Ram.
-  Fixed Compute-Reference-Order to begin temporary lifetimes with the write
-  rather than the read.
-
-/usr0/ram/compiler/gtn.lisp, 18-Feb-88 16:06:41, Edit by Ram.
-  Have to fetch the Equated-Returns inside the loop in Find-Equivalence
-  classes, since Equate-Return-Info will change the returns for the current
-  environment.  This used to work, since Equate-Return-Info used to be
-  destructive.
-
-/usr0/ram/compiler/ir1opt.lisp, 14-Feb-88 14:30:47, Edit by Ram.
-  Oops.  Fixed the test in Propagate-From-Calls for being a call to the
-  function concerned.  Now that this optimization can actually happen, who
-  knows?
-
-/usr0/ram/compiler/ltn.lisp, 11-Feb-88 18:01:38, Edit by Ram.
-  Made Annotate-1-Value-Continuation delay global function references to
-  functions that aren't notinline.  Made LTN-Default-Call,
-  LTN-Analyze-Full-Call and LTN-Analyze-MV-Call annotate their function
-  continuation. 
-
-/usr0/ram/compiler/flowsimp.lisp, 11-Feb-88 16:44:48, Edit by Ram.
-  Now that returns aren't being picked off in flow-graph-simplify, we have to
-  fix join-block-if-possible not to attempt to join the XEP return to the
-  component tail...
-
-/usr0/ram/compiler/ir1util.lisp, 11-Feb-88 16:14:52, Edit by Ram.
-  Made Delete-Ref call Maybe-Let-Convert when deleting the second-to-last
-  reference to a lambda.
-
-/usr0/ram/compiler/flowsimp.lisp, 10-Feb-88 16:46:56, Edit by Ram.
-/usr0/ram/compiler/locall.lisp, 11-Feb-88 13:24:04, Edit by Ram.
-  Moved let-conversion to locall from flowsimp, and made it be triggered by
-  Maybe-Let-Convert.  This is called on each new lambda after local call
-  analysis, and can also be called whenever there is some reason to believe
-  that a lambda might be eligible for let-conversion.  We clear any :Optional
-  function kinds since the entry functions can be treated as normal functions
-  after local call analysis.
-
-  This change was made to solve problems with lambdas not being let-converted
-  when the return node was deleted due to being unreachable.  This is important
-  now that being a let has major environment significance.  Originally let
-  conversion was regarded as a way to delete a return, and thus made some kind
-  of sense to have it be a flow graph optimization.  Now that a let can have
-  only one reference, we can trigger let conversion by noticing when references
-  are deleted.
-
-/usr0/ram/compiler/node.lisp, 11-Feb-88 13:12:38, Edit by Ram.
-/usr0/ram/compiler/ir1tran.lisp, 11-Feb-88 13:12:47, Edit by Ram.
-  Added :Optional Functional-Kind that is initially specified for the
-  entry-point lambdas in optional-dispatches so that we know there may be
-  references to the function through the optional dispatch. 
-
-/usr0/ram/compiler/ir1util.lisp, 11-Feb-88 12:23:11, Edit by Ram.
-  Changed assertion in Control-Equate to allow an existing value-equate to the
-  same continuation.
-
-/usr0/ram/compiler/ir1tran.lisp, 25-Jan-88 19:27:57, Edit by Ram.
-  Changed the default policy to be all 1's, and modified calls to Policy in all
-  files so that they do "the right thing" when compared qualities are equal.
-  The default action should be chosen so as to minimize mystification and
-  annoyance to non-wizards.  In general, the default should be chosen according
-  to the ordering: safety > brevity > speed > space > cspeed.  Checks for 0 and
-  3 meaning "totally unimportant" and "ultimately important" are also o.k.
-
-/usr0/ram/compiler/gtn.lisp, 24-Jan-88 11:20:37, Edit by Ram.
-  Changed Equate-Return-Info so that it effectively ignores the Count and Types
-  in :Unused continuations, yet still combines the Entry-P and Tail-P values.
-
-/usr0/ram/compiler/locall.lisp, 23-Jan-88 21:41:28, Edit by Ram.
-  Make Convert-XEP-Call set the Return-Point too...
-
-/usr0/ram/compiler/ir1util.lisp, 22-Jan-88 16:17:38, Edit by Ram.
-  Made Immediately-Used-P special-case local calls by using
-  Basic-Combination-Return-Point.
-
-/usr0/ram/compiler/locall.lisp, 22-Jan-88 16:13:32, Edit by Ram.
-/usr0/ram/compiler/node.lisp, 22-Jan-88 16:12:03, Edit by Ram.
-  Added a Basic-Combination-Return-Point slot so that local calls can rebember
-  where they are supposed to return to.
-
-/usr0/ram/compiler/gtn.lisp, 22-Jan-88 10:03:37, Edit by Ram.
-  Fixed Assign-Lambda-Vars to set the TN-Leaf.
-
-/usr0/ram/compiler/flowsimp.lisp, 22-Jan-88 10:22:53, Edit by Ram.
-  Made Convert-To-Let do an Intersect-Continuation-Asserted-Type on the actual
-  continuation with the dummy's assertion when the let call is the only use of
-  the actual continuation.
-
-/usr0/ram/compiler/ir1tran.lisp, 22-Jan-88 09:42:49, Edit by Ram.
-  Tack NIL on the end of the forms that we convert so that no top-level form is
-  in a for-value context.
-
-/usr0/ram/compiler/ir1opt.lisp, 21-Jan-88 17:50:52, Edit by Ram.
-  Made Check-Types intersect the new type with the Node-Derived-Type for all
-  the continuation uses so that IR1Opt doesn't go and change the type right
-  back. 
-
-/usr0/ram/compiler/main.lisp, 21-Jan-88 17:31:57, Edit by Ram.
-/usr0/ram/compiler/ir1opt.lisp, 21-Jan-88 17:30:31, Edit by Ram.
-  Type checking was being done wrong.  We need to check types even if IR1Opt
-  doesn't do anything, and we need to give IR1Opt a second chance if type check
-  does anything.  Made Check-Types return whether it did anything.
-
-/usr0/ram/compiler/ir1tran.lisp, 21-Jan-88 17:14:13, Edit by Ram.
-  Fixed IR1 translator for THE to use Find-Uses to find whether the
-  continuation is used, rather than incorrectly doing it itself (using an old
-  interpretation of Continuation-Use).
-
-/usr0/ram/compiler/ir1tran.lisp, 16-Nov-87 15:58:39, Edit by Ram.
-  Made %proclaim (and hence proclaim) return (undefined-value) rather than
-  arbitrary randomness.
-
-/usr1/ram/compiler/flowsimp.lisp, 23-Aug-87 22:00:39, Edit by Ram
-  Changed Flow-Graph-Simplify not to merge blocks unless the cleanups for the
-  two blocks are identical.  The is a sub-optimal (but conservative) way to
-  ensure that cleanups are only done on block boundaries.
-
-/usr1/ram/compiler/ir1opt.lisp, 23-Aug-87 21:26:53, Edit by Ram
-  Just look for the :Let functional kind in Top-Down-Optimize, instead of
-  figuring out from first principles.
-
-/usr1/ram/compiler/ir1util.lisp, 20-Aug-87 22:12:45, Edit by Ram
-  The only worthwhile use for the functional nesting was in Delete-Ref, where
-  it would walk all the inferiors, marking them as deleted as well.  But I
-  think that just marking the outer function as deleted will eventually cause
-  all the inner functions to be deleted.  As it stands, Delete-Ref is a lot
-  simpler.  If there are problems with deleted-but-somehow-undeletable
-  references holding onto functions, we may want to look at all references in
-  Delete-Ref and see if some enclosing function is deleted.
-
-/usr1/ram/compiler/ir1tran.lisp, 22-Aug-87 15:38:50, Edit by Ram
-  Changed stuff to use the new Functional and Cleanup structures.  Mostly
-  involves flushing stuff.
-
-/usr1/ram/compiler/locall.lisp, 21-Aug-87 14:24:32, Edit by Ram
-/usr1/ram/compiler/ir1opt.lisp, 20-Aug-87 22:05:33, Edit by Ram
-  Changed Local-Call-Analyze to just take a component and analyze the
-  New-Functions.  This simplifies (and optimizes) the late uses in IR1
-  optimize.  Also changed convert-call-if-possible to know to try to convert
-  the call to the real function rather than the XEP.
-
-/usr1/ram/compiler/node.lisp, 23-Aug-87 20:12:58, Edit by Ram
-  Flushed bogus hierarchical information in the Functional, Environment and
-  Cleanup structures.  Now that I've taken a stab at implementing the IR2
-  conversion passes, it is obvious that this information is useless and
-  difficult to maintain.
-
-  We do need a way to iterate over all the functions in a component, but doing
-  a tree walk is bogus.  Instead, we have a list of all the lambdas in each
-  component.  When functions are initially converted, they are placed on the
-  component New-Functions list.  Local call analysis moves analyzed lambdas
-  into the Lambdas list.  We don't bother to remove lambdas from this list when
-  they are deleted.
-
-  A change needed in the cleanup stuff to make it work is to have continuations
-  with no immediately enclosing cleanup point have their lambda as the cleanup.
-  Then when we convert the lambda to a let, we set the Cleanup slot in the
-  lambda to any cleanup enclosing the call so that we realize stuff needs to be
-  cleaned up.
-
-/usr1/ram/compiler/flowsimp.lisp, 23-Aug-87 20:49:36, Edit by Ram
-  Changed Find-Initial-DFO to build the Lambdas lists for the components.  At
-  the same time, we also use XEP references to (correctly) merge components
-  with potential environment inter-dependencies, rather than attempting to use
-  the lambda nesting.  Changed Join-Components to combine the Lambdas and
-  New-Functions lists.
-
-  Changed Delete-Return to convert to a let only when there is a single call,
-  and also to mark the lambda with the :Let functional kind.  This makes
-  let-calls exactly correspond to the functions that IR1 optimize can
-  substitute for.  This also solves problems with cleanups, since it is
-  trivially true that all calls are in the same dynamic environment.
-
-/usr1/ram/compiler/ir1tran.lisp, 18-Aug-87 15:25:18, Edit by Ram
-  In IR1-Convert, if the function is not a symbol, but doesn't look even
-  vaguely like a lambda, then complain about an illegal function call,
-  rather than having IR1-Convert-Lambda say it is an illegal lambda.
-
-/usr1/ram/compiler/numacs.lisp, 16-Aug-87 13:48:11, Edit by Ram
-  Added a Defvar that doesn't use OR (and create a LET and freak out IR1
-  conversion.)
-
-/usr1/ram/compiler/ir1util.lisp, 16-Aug-87 18:14:10, Edit by Ram
-/usr1/ram/compiler/debug.lisp, 16-Aug-87 15:19:47, Edit by Ram
-/usr1/ram/compiler/flowsimp.lisp, 16-Aug-87 15:19:13, Edit by Ram
-/usr1/ram/compiler/ir1opt.lisp, 16-Aug-87 15:18:47, Edit by Ram
-/usr1/ram/compiler/node.lisp, 16-Aug-87 19:58:30, Edit by Ram
-/usr1/ram/compiler/ir1tran.lisp, 16-Aug-87 20:29:36, Edit by Ram
-/usr1/ram/compiler/locall.lisp, 16-Aug-87 20:22:28, Edit by Ram
-  Changed stuff for new explicit external entry point concept.  The external
-  entry point is now a real function containing local calls to the entry
-  points.  This represents reality better, making lots of things previously
-  special-cased automatically happen in our favor.  We really needed this for
-  environment analysis and IR2 conversion to work.
-  
-  Functional-Entry-Kind is replaced by Functional-Kind and
-  Functional-Entry-Function.  The Kind is kind of like the old Entry-Kind.  The
-  Entry-Function is the XEP (or a back-pointer in an XEP).  Uses of Entry-Kind
-  were replaced with Kind or Entry-Function or flushed, as appropriate.
-
-  Note-Entry-Point has been flushed.  %Defun doesn't need to do anything to
-  cause the function to be an entry point.  The top-level lambda is no longer
-  a real entry-point: instead we just directly link it to the component head
-  and tail.
-
-  The more-arg XEP creates a more-arg cleanup.  The local-call case still needs
-  to be fixed.
-
-/usr1/ram/compiler/fndb.lisp, 16-Aug-87 20:37:28, Edit by Ram
-  Added some definitions for %mumble magic compiler functions.
-
-/usr1/ram/compiler/ir1tran.lisp, 16-Aug-87 20:29:36, Edit by Ram
-  Changed uses of the two-arg Arg for more-arg hackery into %More-Arg, since
-  this isn't the user-level functionality we will ultimately want for
-  more-args.
-
-/usr1/ram/compiler/main.lisp, 16-Aug-87 18:35:29, Edit by Ram
-  Changed Compile-Component not to do any IR1 passes on the top-level component
-  except for Type-Check.  These optimizations are unlikely to have any useful
-  effect on top-level code, and they might want to inject illegal stuff into
-  the top-level component.
-
-/usr1/ram/compiler/macros.lisp, 16-Aug-87 18:26:19, Edit by Ram
-  Changed With-IR1-Environment to bind *Converting-Top-Level*.  Currently you'd
-  better not use this on top-level code unless you are sure you won't emit
-  anything that can't go in top-level, since IR1-Convert-Lambda will bogue out
-  because there is no *Initial-Component* to switch to.
-
-/usr1/ram/compiler/macros.lisp, 13-Aug-87 20:16:47, Edit by Ram
-/usr1/ram/compiler/node.lisp, 13-Aug-87 22:24:30, Edit by Ram
-/usr1/ram/compiler/main.lisp, 13-Aug-87 22:35:11, Edit by Ram
-/usr1/ram/compiler/globaldb.lisp, 13-Aug-87 20:21:12, Edit by Ram
-/usr1/ram/compiler/locall.lisp, 13-Aug-87 22:57:54, Edit by Ram
-/usr1/ram/compiler/flowsimp.lisp, 13-Aug-87 22:52:01, Edit by Ram
-/usr1/ram/compiler/ir1opt.lisp, 13-Aug-87 22:59:11, Edit by Ram
-/usr1/ram/compiler/ir1tran.lisp, 13-Aug-87 23:06:03, Edit by Ram
-  Changed stuff to support having separate top-level and initial components.
-  Whenver we see a lambda or anything hairy, we switch over to the initial
-  component.  Hairyness of special-forms is determined by the :Top-Level-P
-  keyword to Def-IR1-Translator.
-
-  We make appropriate special forms hairy to guarantee that the top-level
-  component doesn't contain any stuff that would make life hard for IR2
-  conversion.  In particular, it contains no variables, no functions other than
-  the top-level lambda and no non-local exit targets.
-
-  Local call analysis refuses to convert calls appearing in the top-level
-  component.  In other files, stuff related to Functional-Top-Level-P was
-  ripped out.
-
-/usr1/ram/compiler/ir1opt.lisp, 13-Aug-87 17:58:37, Edit by Ram
-  Changed propagate-from-calls to punt if any use is a mv-combination.  Changed
-  Top-Down-Optimize not to Substitute-Let-Vars unless the only use is not a
-  MV-Combination.  Un-commented-out the substituion of functionals for non-set
-  let vars. 
-
-/usr1/ram/compiler/locall.lisp, 13-Aug-87 18:31:24, Edit by Ram
-  Frobbed Find-Top-Level-Code to recognize DEFUNs with no calls as
-  non-top-level.  The entire concept is probably wrong, though.
-
-/usr1/ram/compiler/ir1tran.lisp, 13-Aug-87 19:07:22, Edit by Ram
-  Changed IR1-Convert-OK-Combination to look at the leaf-type of the leaf
-  rather than the derived type for the function continuation.  This allows
-  known calls to be recognized again (I'm sure that worked at one point.
-  Perhaps before they were becoming known later on somehow?).  This is all not
-  really right anyway, given the broken interpretation of function types
-  currently used in IR1. 
-
-/usr/ram/compiler/ir1tran.slisp, 12-Jan-87 11:48:32, Edit by Ram
-  Fixed Find-Source-Paths to use a DO with ATOM test rather than a dolist, so
-  that it won't blow up on dotted lists.
-
-/usr/ram/compiler/ir1util.slisp, 12-Jan-87 10:28:07, Edit by Ram
-  Fixed Delete-Block to null out the DEST for the continuations belonging to
-  each node as we delete the node, so we don't try to deliver a result to a
-  node that doesn't exist anymore.
diff --git a/compiler/checkgen.lisp b/compiler/checkgen.lisp
deleted file mode 100644
index 4c8bf836c70e8ec2436d99d038dcb02b64230cb1..0000000000000000000000000000000000000000
--- a/compiler/checkgen.lisp
+++ /dev/null
@@ -1,533 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/checkgen.lisp,v 1.22 1992/09/07 15:34:20 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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 *backend*))))
-    (if info
-	(let ((templates (function-info-templates info)))
-	  (if templates
-	      (template-cost (first templates))
-	      (case name
-		(null (template-cost (template-or-lose 'if-eq *backend*)))
-		(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 (backend-type-predicates *backend*)
-				     :test #'type=))))
-	      (if found
-		  (+ (function-cost found) (function-cost 'eq))
-		  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-WEAKEN-CHECK  --  Internal
-;;;
-;;;    Return the type we should test for when we really want to check for
-;;; Type.   If speed, space or compilation speed is more important than safety,
-;;; then we return a weaker type if it is easier to check.  First we try the
-;;; defined type weakenings, then look for any predicate that is cheaper.
-;;;
-;;;    If the supertype is equal in cost to the type, we prefer the supertype.
-;;; This produces a closer approximation of the right thing in the presence of
-;;; poor cost info.
-;;;
-(defun maybe-weaken-check (type cont)
-  (declare (type ctype type) (type continuation cont))
-  (cond ((policy (continuation-dest cont)
-		 (<= speed safety) (<= space safety) (<= cspeed safety))
-	 type)
-	(t
-	 (let ((min-cost (type-test-cost type))
-	       (min-type type)
-	       (found-super nil))
-	   (dolist (x (backend-type-predicates *backend*))
-	     (let ((stype (car x)))
-	       (when (and (csubtypep type stype)
-			  (not (union-type-p stype))) ;Not #!% COMMON type.
-		 (let ((stype-cost (type-test-cost stype)))
-		   (when (or (< stype-cost min-cost)
-			     (type= stype type))
-		     (setq found-super t)
-		     (setq min-type stype  min-cost stype-cost))))))
-	   (if found-super
-	       min-type
-	       *universal-type*)))))
-
-
-;;; NO-FUNCTION-VALUES-TYPES  --  Internal
-;;;
-;;;    Like VALUES-TYPES, only mash any complex function types to FUNCTION.
-;;;
-(defun no-function-values-types (type)
-  (declare (type ctype type))
-  (multiple-value-bind (res count)
-		       (values-types type)
-    (values (mapcar #'(lambda (type)
-			(if (function-type-p type)
-			    (specifier-type 'function)
-			    type))
-		    res)
-	    count)))
-
-
-;;; Switch to disable check complementing, for evaluation.
-;;;
-(defvar *complement-type-checks* t)
-
-;;; 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.  If true,
-;;; Force-Hairy forces a hairy type check.
-;;;
-;;;    When doing a non-negated check, we call MAYBE-WEAKEN-CHECK to weaken the
-;;; test to a convenient supertype (conditional on policy.)  If debug-info is
-;;; not particularly important (debug <= 1) or speed is 3, then we allow
-;;; weakened checks to be simple, resulting in less informative error messages,
-;;; but saving space and possibly time.
-;;;
-(defun maybe-negate-check (cont types force-hairy)
-  (declare (type continuation cont) (list types))
-  (multiple-value-bind
-      (ptypes count)
-      (no-function-values-types (continuation-proven-type cont))
-    (if (eq count :unknown)
-	(if (and (every #'type-check-template types) (not force-hairy))
-	    (values :simple types)
-	    (values :hairy
-		    (mapcar #'(lambda (x)
-				(list nil (maybe-weaken-check x cont) x))
-			    types)))
-	(let ((res (mapcar #'(lambda (p c)
-			       (let ((diff (type-difference p c))
-				     (weak (maybe-weaken-check c cont)))
-				 (if (and diff
-					  (< (type-test-cost diff)
-					     (type-test-cost weak))
-					  *complement-type-checks*)
-				     (list t diff c)
-				     (list nil weak c))))
-			   ptypes types)))
-	  (cond ((or force-hairy (find-if #'first res))
-		 (values :hairy res))
-		((every #'type-check-template types)
-		 (values :simple types))
-		((policy (continuation-dest cont)
-			 (or (<= debug 1) (and (= speed 3) (/= debug 3))))
-		 (let ((weakened (mapcar #'second res)))
-		   (if (every #'type-check-template weakened)
-		       (values :simple weakened)
-		       (values :hairy res))))
-		(t
-		 (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.
-;;;
-;;; We force a check to be hairy even when there are fixed values if we are in
-;;; a context where we may be forced to use the unknown values convention
-;;; anyway.  This is because IR2tran can't generate type checks for unknown
-;;; values continuations but people could still be depending on the check being
-;;; done.  We only care about EXIT and RETURN (not MV-COMBINATION) since these
-;;; are the only contexts where the ultimate values receiver 
-;;;
-;;; 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)
-			 (no-function-values-types type)
-      (cond ((not (eq count :unknown))
-	     (if (or (exit-p dest)
-		     (and (return-p dest)
-			  (multiple-value-bind
-			      (ignore count)
-			      (values-types (return-result-type dest))
-			    (declare (ignore ignore))
-			    (eq count :unknown))))
-		 (maybe-negate-check cont types t)
-		 (maybe-negate-check cont types nil)))
-	    ((and (mv-combination-p dest)
-		  (eq (basic-combination-kind dest) :local))
-	     (assert (values-type-p type))
-	     (maybe-negate-check cont (args-type-optional type) nil))
-	    (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
-;;;  -- Safety is totally unimportant, 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.
-;;;
-;;; If there is a compile-time type error, then we always return true unless
-;;; the DEST is a full call.  With a full call, the theory is that the type
-;;; error is probably from a declaration in (or on) the callee, so the callee
-;;; should be able to do the check.  We want to let the callee do the check,
-;;; because it is possible that the error is really in the callee, not the
-;;; caller.  We don't want to make people recompile all calls to a function
-;;; when they were originally compiled with a bad declaration (or an old type
-;;; assertion derived from a definition appearing after the call.)
-;;;
-(defun probable-type-check-p (cont)
-  (declare (type continuation cont))
-  (let ((dest (continuation-dest cont)))
-    (cond ((eq (continuation-type-check cont) :error)
-	   (if (and (combination-p dest) (eq (combination-kind dest) :error))
-	       nil
-	       t))
-	  ((or (not dest)
-	       (policy dest (zerop safety)))
-	   nil)
-	  ((basic-combination-p dest)
-	   (let ((kind (basic-combination-kind dest)))
-	     (cond ((eq cont (basic-combination-fun dest)) t)
-		   ((eq kind :local) t)
-		   ((member kind '(:full :error)) nil)
-		   ((function-info-ir2-convert kind) t)
-		   (t
-		    (dolist (template (function-info-templates kind) nil)
-		      (when (eq (template-policy template) :fast-safe)
-			(multiple-value-bind
-			    (val win)
-			    (valid-function-use dest (template-type template))
-			  (when (or val (not win)) (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))
-      (temps (gensym)))
-
-    `(multiple-value-bind ,(temps)
-			  'dummy
-       ,@(mapcar #'(lambda (temp type)
-		     (let* ((spec
-			     (let ((*unparse-function-type-simplify* t))
-			       (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))
-	     (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))
-
-	(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))
-
-
-;;; DO-TYPE-WARNING  --  Internal
-;;;
-;;;    Emit a type warning for Node.  If the value of node is being used for a
-;;; variable binding, we figure out which one for source context.  If the value
-;;; is a constant, we print it specially.  We ignore nodes whose type is NIL,
-;;; since they are supposed to never return.
-;;;
-(defun do-type-warning (node)
-  (declare (type node node))
-  (let* ((*compiler-error-context* node)
-	 (cont (node-cont node))
-	 (atype-spec (type-specifier (continuation-asserted-type cont)))
-	 (dtype (node-derived-type node))
-	 (dest (continuation-dest cont))
-	 (what (when (and (combination-p dest)
-			  (eq (combination-kind dest) :local))
-		 (let ((lambda (combination-lambda dest))
-		       (pos (position cont (combination-args dest))))
-		   (format nil "~:[A possible~;The~] binding of ~S"
-			   (and (continuation-use cont)
-				(eq (functional-kind lambda) :let))
-			   (leaf-name (elt (lambda-vars lambda) pos)))))))
-    (cond ((eq dtype *empty-type*))
-	  ((and (ref-p node) (constant-p (ref-leaf node)))
-	   (compiler-warning "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~%  ~S"
-			     what atype-spec (constant-value (ref-leaf node))))
-	  (t
-	   (compiler-warning
-	    "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
-	    what (type-specifier dtype) atype-spec))))
-  (undefined-value))
-
-
-;;; MARK-ERROR-CONTINUATION  --  Internal
-;;;
-;;;    Mark Cont as being a continuation with a manifest type error.  We set
-;;; the kind to :ERROR, and clear any FUNCTION-INFO if the continuation is an
-;;; argument to a known call.  The last is done so that the back end doesn't
-;;; have to worry about type errors in arguments to known functions.  This
-;;; clearing is inhibited for things with IR2-CONVERT methods, since we can't
-;;; do a full call to funny functions.
-;;;
-(defun mark-error-continuation (cont)
-  (declare (type continuation cont))
-  (setf (continuation-%type-check cont) :error)
-  (let ((dest (continuation-dest cont)))
-    (when (and (combination-p dest)
-	       (let ((kind (basic-combination-kind dest)))
-		 (or (eq kind :full) 
-		     (and (function-info-p kind)
-			  (not (function-info-ir2-convert kind))))))
-      (setf (basic-combination-kind dest) :error)))
-  (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 there is a compile-time type error, then we mark the continuation and
-;;; emit a warning if appropriate.  This part loops over all the uses of the
-;;; continuation, since after we convert the check, the :DELETED kind will
-;;; inhibit warnings about the types of other uses.
-;;;
-;;;    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)
-	(let ((type-check (continuation-type-check cont)))
-	  (unless (member type-check '(nil :error :deleted))
-	    (let ((atype (continuation-asserted-type cont)))
-	      (do-uses (use cont)
-		(unless (values-types-intersect (node-derived-type use)
-						atype)
-		  (mark-error-continuation cont)
-		  (unless (policy node (= brevity 3))
-		    (do-type-warning use))))))
-
-	  (when (and (eq type-check t)
-		     (not *byte-compiling*))
-	    (if (probable-type-check-p cont)
-		(multiple-value-bind (check types)
-				     (continuation-check-types cont)
-		  (ecase check
-		    (:simple)
-		    (:hairy
-		     (convert-type-check cont types))
-		    (: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 (continuation-%type-check cont) :no-check)))))
-      
-      (setf (block-type-check block) nil)))
-  
-  (undefined-value))
diff --git a/compiler/codegen.lisp b/compiler/codegen.lisp
deleted file mode 100644
index f18eb36e31d81c93cf5ccb85aa64dfbc7eac27dc..0000000000000000000000000000000000000000
--- a/compiler/codegen.lisp
+++ /dev/null
@@ -1,289 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/codegen.lisp,v 1.18 1992/08/03 12:36:01 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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)
-
-(in-package :new-assem)
-(import '(label gen-label emit-label label-position) :c)
-
-(in-package :c)
-(export '(component-header-length sb-allocated-size current-nfp-tn
-	  callee-nfp-tn callee-return-pc-tn *code-segment* *elsewhere*
-	  trace-table-entry pack-trace-table note-fixup
-	  fixup fixup-p make-fixup fixup-name fixup-flavor fixup-offset))
-
-
-;;;; Utilities used during code generation.
-
-;;; Component-Header-Length   --  Interface
-;;; 
-(defun component-header-length (&optional (component *compile-component*))
-  "Returns the number of bytes used by the code object header."
-  (let* ((2comp (component-info component))
-	 (constants (ir2-component-constants 2comp))
-	 (num-consts (length constants)))
-    (ash (logandc2 (1+ num-consts) 1) vm:word-shift)))
-
-;;; SB-Allocated-Size  --  Interface
-;;;
-(defun sb-allocated-size (name)
-  "The size of the Name'd SB in the currently compiled component.  Useful
-  mainly for finding the size for allocating stack frames."
-  (finite-sb-current-size (sb-or-lose name *backend*)))
-
-
-;;; Current-NFP-TN  --  Interface
-;;;
-(defun current-nfp-tn (vop)
-  "Return the TN that is used to hold the number stack frame-pointer in VOP's
-  function.  Returns NIL if no number stack frame was allocated."
-  (unless (zerop (sb-allocated-size 'non-descriptor-stack))
-    (let ((block (ir2-block-block (vop-block vop))))
-    (when (ir2-environment-number-stack-p
-	   (environment-info
-	    (block-environment block)))
-      (ir2-component-nfp (component-info (block-component block)))))))
-
-;;; CALLEE-NFP-TN  --  Interface
-;;;
-(defun callee-nfp-tn (2env)
-  "Return the TN that is used to hold the number stack frame-pointer in the
-  function designated by 2env.  Returns NIL if no number stack frame was
-  allocated."
-  (unless (zerop (sb-allocated-size 'non-descriptor-stack))
-    (when (ir2-environment-number-stack-p 2env)
-      (ir2-component-nfp (component-info *compile-component*)))))
-
-
-;;; CALLEE-RETURN-PC-TN  --  Interface
-;;;
-(defun callee-return-pc-tn (2env)
-  "Return the TN used for passing the return PC in a local call to the function
-  designated by 2env."
-  (ir2-environment-return-pc-pass 2env))
-
-
-
-;;;; Fixups
-
-;;; FIXUP -- A fixup of some kind.
-;;;
-(defstruct (fixup
-	    (:constructor make-fixup (name flavor &optional offset)))
-  ;; The name and flavor of the fixup.  The assembler makes no assumptions
-  ;; about the contents of these fields; their semantics are imposed by the
-  ;; dumper.
-  name
-  flavor
-  ;; An optional offset from whatever external label this fixup refers to.
-  offset)
-
-(defun %print-fixup (fixup stream depth)
-  (declare (ignore depth))
-  (format stream "#<~S fixup ~S~@[ offset=~S~]>"
-	  (fixup-flavor fixup)
-	  (fixup-name fixup)
-	  (fixup-offset fixup)))
-
-(defvar *fixups*)
-
-;;; NOTE-FIXUP -- interface.
-;;;
-;;; This function is called by the (new-assembler) instruction emitters that
-;;; find themselves trying to deal with a fixup.
-;;; 
-(defun note-fixup (segment kind fixup)
-  (new-assem:emit-back-patch
-   segment 0
-   #'(lambda (segment posn)
-       (declare (ignore segment))
-       (push (list kind fixup posn) *fixups*)))
-  (undefined-value))
-
-
-
-;;;; Specials used during code generation.
-
-(defvar *trace-table-info*)
-(defvar *code-segment* nil)
-(defvar *elsewhere* nil)
-(defvar *elsewhere-label* nil)
-
-(defvar *assembly-optimize* nil
-  "Set to NIL to inhibit assembly-level optimization.  For compiler debugging,
-  rather than policy control.")
-
-
-;;;; Noise to emit an instruction trace.
-
-(defvar *prev-segment*)
-(defvar *prev-vop*)
-
-(defun trace-instruction (segment vop inst args)
-  (let ((*standard-output* *compiler-trace-output*))
-    (unless (eq *prev-segment* segment)
-      (format t "In the ~A segment:~%" (new-assem:segment-name segment))
-      (setf *prev-segment* segment))
-    (unless (eq *prev-vop* vop)
-      (when vop
-	(format t "~%VOP ")
-	(if (vop-p vop)
-	    (print-vop vop)
-	    (format *compiler-trace-output* "~S~%" vop)))
-      (terpri)
-      (setf *prev-vop* vop))
-    (case inst
-      (:label
-       (format t "~A:~%" args))
-      (:align
-       (format t "~0,8T.align~0,8T~A~%" args))
-      (t
-       (format t "~0,8T~A~@[~0,8T~{~A~^, ~}~]~%" inst args))))
-  (undefined-value))
-
-
-
-;;;; Generate-code and support routines.
-
-(defun make-segment (&optional name)
-  (new-assem:make-segment
-   :name name
-   :run-scheduler
-   (and *assembly-optimize*
-	(policy (lambda-bind
-		 (block-home-lambda
-		  (block-next (component-head *compile-component*))))
-		(or (>= speed cspeed) (>= space cspeed))))
-   :inst-hook (if *compiler-trace-output* #'trace-instruction)))
-
-;;; Init-Assembler  --  Interface
-;;; 
-(defun init-assembler ()
-  (setf *code-segment* (make-segment "Regular"))
-  (setf *elsewhere* (make-segment "Elsewhere"))
-  (undefined-value))
-
-;;; Generate-Code  --  Interface
-;;;
-(defun generate-code (component)
-  (when *compiler-trace-output*
-    (format *compiler-trace-output*
-	    "~|~%Assembly code for ~S~2%"
-	    component))
-  (let ((prev-env nil)
-	(*trace-table-info* nil)
-	(*prev-segment* nil)
-	(*prev-vop* nil)
-	(*fixups* nil))
-    (let ((label (new-assem:gen-label)))
-      (setf *elsewhere-label* label)
-      (new-assem:assemble (*elsewhere*)
-	(new-assem:emit-label label)))
-    (do-ir2-blocks (block component)
-      (let ((1block (ir2-block-block block)))
-	(when (and (eq (block-info 1block) block)
-		   (block-start 1block))
-	  (new-assem:assemble (*code-segment*)
-	    (new-assem:emit-label (block-label 1block)))
-	  (let ((env (block-environment 1block)))
-	    (unless (eq env prev-env)
-	      (let ((lab (gen-label)))
-		(setf (ir2-environment-elsewhere-start (environment-info env))
-		      lab)
-		(emit-label-elsewhere lab))
-	      (setq prev-env env)))))
-
-      (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)))))))
-    
-    (new-assem:append-segment *code-segment* *elsewhere*)
-    (setf *elsewhere* nil)
-    (values (new-assem:finalize-segment *code-segment*)
-	    (nreverse *trace-table-info*)
-	    *fixups*)))
-
-(defun emit-label-elsewhere (label)
-  (new-assem:assemble (*elsewhere*)
-    (new-assem:emit-label label)))
-
-(defun label-elsewhere-p (label-or-posn)
-  (<= (label-position *elsewhere-label*)
-      (etypecase label-or-posn
-	(label
-	 (label-position label-or-posn))
-	(index
-	 label-or-posn))))
-
-(defun trace-table-entry (state)
-  (let ((label (gen-label)))
-    (emit-label label)
-    (push (cons label state) *trace-table-info*))
-  (undefined-value))
-
-;;; COMPUTE-TRACE-TABLE -- interface.
-;;;
-;;; Convert the list of (label . state) entries into an ivector.
-;;; 
-(eval-when (compile load eval)
-  (defconstant bits-per-state 3)
-  (defconstant bits-per-entry 16)
-  (defconstant bits-per-offset (- bits-per-entry bits-per-state))
-  (defconstant max-offset (ash 1 bits-per-offset)))
-;;;
-(defun pack-trace-table (table)
-  (declare (list table))
-  #+nil
-  (let ((last-posn 0)
-	(last-state 0)
-	(result (make-array (length table)
-			    :element-type '(unsigned-byte #.bits-per-entry)))
-	(index 0))
-    (dolist (entry table)
-      (let* ((posn (label-position (car entry)))
-	     (state (cdr entry)))
-	(flet ((push-entry (offset state)
-		 (when (>= index (length result))
-		   (setf result
-			 (replace (make-array
-				   (truncate (* (length result) 5) 4)
-				   :element-type
-				   '(unsigned-byte #.bits-per-entry))
-				  result)))
-		 (setf (aref result index)
-		       (logior (ash offset bits-per-state)
-			       state))
-		 (incf index)))
-	  (do ((offset (- posn last-posn) (- offset max-offset)))
-	      ((< offset max-offset)
-	       (push-entry offset state))
-	    (push-entry 0 last-state)))
-	(setf last-posn posn)
-	(setf last-state state)))
-    (if (eql (length result) index)
-	result
-	(subseq result 0 index)))
-  ;; ### Hack 'cause this stuff doesn't work.
-  (declare (ignore table))
-  (make-array 0 :element-type '(unsigned-byte #.bits-per-entry)))
diff --git a/compiler/constraint.lisp b/compiler/constraint.lisp
deleted file mode 100644
index ace86bad1bd07aa410ef87d0860bf5055496251e..0000000000000000000000000000000000000000
--- a/compiler/constraint.lisp
+++ /dev/null
@@ -1,518 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/constraint.lisp,v 1.13 1992/06/03 20:03:37 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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.
-  ;;
-  ;; >, <
-  ;;     X is a lambda-var and Y is a CTYPE.  The relation holds between X and
-  ;;     some object of type Y.
-  ;;
-  ;; EQL
-  ;;     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))
-  ;;
-  ;; 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 constraint.  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)))
-
-
-;;; OK-REF-LAMBDA-VAR  --  Internal
-;;;
-;;;    If Ref is to a Lambda-Var with Constraints (i.e. we can do flow analysis
-;;; on it), then return the Lambda-Var, otherwise NIL.
-;;;
-(proclaim '(inline ok-ref-lambda-var))
-(defun ok-ref-lambda-var (ref)
-  (declare (type ref ref))
-  (let ((leaf (ref-leaf ref)))
-    (when (and (lambda-var-p leaf)
-	       (lambda-var-constraints leaf))
-      leaf)))
-
-
-;;; OK-CONT-LAMBDA-VAR  --  Internal
-;;;
-;;;    If Cont's Use is a Ref, then return OK-REF-LAMBDA-VAR of the Use,
-;;; otherwise NIL.
-;;;
-(proclaim '(inline ok-cont-lambda-var))
-(defun ok-cont-lambda-var (cont)
-  (declare (type continuation cont))
-  (let ((use (continuation-use cont)))
-    (when (ref-p use)
-      (ok-ref-lambda-var use))))
-
-
-;;; ADD-TEST-CONSTRAINT  --  Internal
-;;;
-;;;    Add the indicated test constraint to Block, marking the block as having
-;;; a new assertion when the constriant was not already present.  We don't add
-;;; the constraint if the block has multiple predecessors, since it only holds
-;;; on this particular path.
-;;;
-(defun add-test-constraint (block fun x y not-p)
-  (unless (rest (block-pred block))
-    (let ((con (find-constraint fun x y not-p))
-	  (old (or (block-test-constraint block)
-		   (setf (block-test-constraint block) (make-sset)))))
-      (when (sset-adjoin con old)
-	(setf (block-type-asserted block) t))))
-  (undefined-value))
-
-
-;;; ADD-COMPLEMENT-CONSTRAINTS  --  Internal
-;;;
-;;;    Add complementary constraints to the consequent and alternative blocks
-;;; of If.  We do nothing if X is NIL.
-;;;
-(proclaim '(inline add-complement-constraints))
-(defun add-complement-constraints (if fun x y not-p)
-  (when x
-    (add-test-constraint (if-consequent if) fun x y not-p)
-    (add-test-constraint (if-alternative if) fun x y (not not-p)))
-  (undefined-value))
-
-
-;;; ADD-TEST-CONSTRAINTS  --  Internal
-;;;
-;;;    Add test constraints to the consequent and alternative blocks of the
-;;; test represented by Use.
-;;;
-(defun add-test-constraints (use if)
-  (declare (type node use) (type cif if))
-  (typecase use
-    (ref
-     (add-complement-constraints if 'typep (ok-ref-lambda-var use)
-				 *null-type* t))
-    (combination
-     (let ((name (continuation-function-name
-		  (basic-combination-fun use)))
-	   (args (basic-combination-args use)))
-       (case name
-	 (%typep
-	  (let ((type (second args)))
-	    (when (constant-continuation-p type)
-	      (let ((val (continuation-value type)))
-	      (add-complement-constraints if 'typep
-					  (ok-cont-lambda-var (first args))
-					  (if (ctype-p val)
-					      val
-					      (specifier-type val))
-					  nil)))))
-	 ((eq eql)
-	  (let* ((var1 (ok-cont-lambda-var (first args)))
-		 (arg2 (second args))
-		 (var2 (ok-cont-lambda-var arg2)))
-	    (cond ((not var1))
-		  (var2
-		   (add-complement-constraints if 'eql var1 var2 nil))
-		  ((constant-continuation-p arg2)
-		   (add-complement-constraints if 'eql var1
-					       (ref-leaf
-						(continuation-use arg2))
-					       nil)))))
-	 ((< >)
-	  (let* ((arg1 (first args))
-		 (var1 (ok-cont-lambda-var arg1))
-		 (arg2 (second args))
-		 (var2 (ok-cont-lambda-var arg2)))
-	    (when var1
-	      (add-complement-constraints if name var1 (continuation-type arg2)
-					  nil))
-	    (when var2
-	      (add-complement-constraints if (if (eq name '<) '> '<)
-					  var2 (continuation-type arg1)
-					  nil))))
-	 (t
-	  (let ((ptype (gethash name (backend-predicate-types *backend*))))
-	    (when ptype
-	      (add-complement-constraints if 'typep
-					  (ok-cont-lambda-var (first args))
-					  ptype nil))))))))
-  (undefined-value))
-
-	      
-
-;;; FIND-TEST-CONSTRAINTS  --  Internal
-;;;
-;;;    Set the Test-Constraint in the successors of Block according to the
-;;; condition it tests.
-;;;
-(defun find-test-constraints (block)
-  (declare (type cblock block))
-  (let ((last (block-last block)))
-    (when (if-p last)
-      (let ((use (continuation-use (if-test last))))
-	(when use
-	  (add-test-constraints use last)))))
-
-  (setf (block-test-modified block) nil)
-  (undefined-value))
-
-
-;;; 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)
-  (declare (type cblock block))
-  (let ((gen (make-sset)))
-    (collect ((kill nil adjoin))
-
-      (let ((test (block-test-constraint block)))
-	(when test
-	  (sset-union gen test)))
-      
-      (do-nodes (node cont block)
-	(typecase node
-	  (ref
-	   (when (continuation-type-check cont)
-	     (let ((var (ok-ref-lambda-var node)))
-	       (when var
-		 (let* ((atype (continuation-derived-type cont))
-			(con (find-constraint 'typep var atype nil)))
-		   (sset-adjoin con gen))))))
-	  (cset
-	   (let ((var (set-var node)))
-	     (when (lambda-var-p var)
-	       (kill var)
-	       (let ((cons (lambda-var-constraints var)))
-		 (when cons
-		   (sset-difference gen cons))))))))
-      
-      (setf (block-in block) nil)
-      (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))))
-
-
-;;; INTEGER-TYPE-P  --  Internal
-;;;
-;;;    Return true if X is an integer NUMERIC-TYPE.
-;;;
-(defun integer-type-p (x)
-  (declare (type ctype x))
-  (and (numeric-type-p x)
-       (eq (numeric-type-class x) 'integer)
-       (eq (numeric-type-complexp x) :real)))
-
-
-;;; CONSTRAIN-INTEGER-TYPE  --  Internal
-;;;
-;;;    Given that an inequality holds on values of type X any Y, return a new
-;;; type for X.  If Greater is true, then X was greater than Y, otherwise less.
-;;; If Or-Equal is true, then the inequality was inclusive, i.e. >=.
-;;;
-;;; If Greater (or not), then we max (or min) in Y's lower (or upper) bound
-;;; into X and return that result.  If not Or-Equal, we can go one greater
-;;; (less) than Y's bound.
-;;;
-(defun constrain-integer-type (x y greater or-equal)
-  (declare (type numeric-type x y))
-  (flet ((exclude (x)
-	   (cond ((not x) nil)
-		 (or-equal x)
-		 (greater (1+ x))
-		 (t (1- x))))
-	 (bound (x)
-	   (if greater (numeric-type-low x) (numeric-type-high x))))
-    (let* ((x-bound (bound x))
-	   (y-bound (exclude (bound y)))
-	   (new-bound (cond ((not x-bound) y-bound)
-			    ((not y-bound) x-bound)
-			    (greater (max x-bound y-bound))
-			    (t (min x-bound y-bound))))
-	   (res (copy-numeric-type x)))
-      (if greater
-	  (setf (numeric-type-low res) new-bound)
-	  (setf (numeric-type-high res) new-bound))
-      res)))
-
-  
-;;; CONSTRAIN-REF-TYPE  --  Internal
-;;;
-;;;    Given the set of Constraints for a variable and the current set of
-;;; restrictions from flow analysis In, set the type for Ref accordingly.
-;;;
-(defun constrain-ref-type (ref constraints in)
-  (declare (type ref ref) (type sset constraints in))
-  (let ((var-cons (copy-sset constraints)))
-    (sset-intersection var-cons in)
-    (let ((res (single-value-type (node-derived-type ref)))
-	  (not-res *empty-type*)
-	  (leaf (ref-leaf ref)))
-      (do-elements (con var-cons)
-	(let* ((x (constraint-x con))
-	       (y (constraint-y con))
-	       (not-p (constraint-not-p con))
-	       (other (if (eq x leaf) y x))
-	       (kind (constraint-kind con)))
-	  (case kind
-	    (typep
-	     (if not-p
-		 (setq not-res (type-union not-res other))
-		 (setq res (type-intersection res other))))
-	    (eql
-	     (let ((other-type (leaf-type other)))
-	       (if not-p
-		   (when (and (constant-p other)
-			      (member-type-p other-type))
-		     (setq not-res (type-union not-res other-type)))
-		   (let ((leaf-type (leaf-type leaf)))
-		     (when (or (constant-p other)
-			       (and (csubtypep other-type leaf-type)
-				    (not (type= other-type leaf-type))))
-		       (change-ref-leaf ref other)
-		       (when (constant-p other) (return)))))))
-	    ((< >)
-	     (when (and (integer-type-p res) (integer-type-p y))
-	       (let ((greater (eq kind '>)))
-		 (let ((greater (if not-p (not greater) greater)))
-		   (setq res
-			 (constrain-integer-type res y greater not-p)))))))))
-      
-      (let* ((cont (node-cont ref))
-	     (dest (continuation-dest cont)))
-	(cond ((and (if-p dest)
-		    (csubtypep *null-type* not-res)
-		    (eq (continuation-asserted-type cont) *wild-type*))
-	       (setf (node-derived-type ref) *wild-type*)
-	       (change-ref-leaf ref (find-constant 't)))
-	      (t
-	       (derive-node-type ref (or (type-difference res not-res)
-					 res)))))))
-
-  (undefined-value))
-
-		 
-;;; 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)))
-
-    (let ((test (block-test-constraint block)))
-      (when test
-	(sset-union in test)))
-
-    (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
-		 (constrain-ref-type node 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 (node-home-lambda 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
-;;;
-;;;    BLOCK-IN becomes the intersection of the OUT of the prececessors.  Our
-;;; OUT is:
-;;;     out U (in - kill)
-;;;
-;;;    BLOCK-KILL is just a list of the lambda-vars killed, so we must compute
-;;; the kill set when there are any vars killed.  We bum this a bit by
-;;; special-casing when only one var is killed, and just using that var's
-;;; constraints as the kill set.  This set could possibly be precomputed, but
-;;; it would have to be invalidated whenever any constraint is added, which
-;;; would be a pain.
-;;;
-(defun flow-propagate-constraints (block)
-  (let* ((pred (block-pred block))
-	 (in (cond (pred
-		    (let ((res (copy-sset (block-out (first pred)))))
-		      (dolist (b (rest pred))
-			(sset-intersection res (block-out b)))
-		      res))
-		   (t
-		    (when *check-consistency*
-		      (let ((*compiler-error-context* (block-last block)))
-			(compiler-warning
-			 "*** Unreachable code in constraint ~
-			  propagation...  Bug?")))
-		    (make-sset))))
-	 (kill (block-kill block))
-	 (out (block-out block)))
-
-    (setf (block-in block) in)
-    (cond ((null kill)
-	   (sset-union (block-out block) in))
-	  ((null (rest kill))
-	   (let ((con (lambda-var-constraints (first kill))))
-	     (if con
-		 (sset-union-of-difference out in con)
-		 (sset-union out in))))
-	  (t
-	   (let ((kill-set (make-sset)))
-	     (dolist (var kill)
-	       (let ((con (lambda-var-constraints var)))
-		 (when con
-		   (sset-union kill-set con))))
-	     (sset-union-of-difference (block-out block) in kill-set))))))
-
-
-;;; CONSTRAINT-PROPAGATE  --  Interface
-;;;
-(defun constraint-propagate (component)
-  (declare (type component component))
-  (init-var-constraints component)
-
-  (do-blocks (block component)
-    (when (block-test-modified block)
-      (find-test-constraints block)))
-
-  (do-blocks (block component)
-    (cond ((block-type-asserted block)
-	   (find-block-type-constraints block))
-	  (t
-	   (setf (block-in block) nil)
-	   (setf (block-out block) (copy-sset (block-gen 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 e6023f15fcff5f6c7099762a8ceb3fa6a806ebf8..0000000000000000000000000000000000000000
--- a/compiler/control.lisp
+++ /dev/null
@@ -1,228 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/control.lisp,v 1.11 1992/04/21 04:16:55 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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.
-;;;
-(defun add-to-emit-order (block after)
-  (declare (type block-annotation block after))
-  (let ((next (block-annotation-next after)))
-    (setf (block-annotation-next after) block)
-    (setf (block-annotation-prev block) after)
-    (setf (block-annotation-next block) next)
-    (setf (block-annotation-prev next) block))
-  (undefined-value))
-
-
-;;; FIND-ROTATED-LOOP-HEAD  --  Internal
-;;;
-;;;    If Block looks like the head of a loop, then attempt to rotate it.  A
-;;; block looks like a loop head if the number of some predecessor is less than
-;;; the block's number.  Since blocks are numbered in reverse DFN, this will
-;;; identify loop heads in a reducible flow graph.
-;;;
-;;;    When we find a suspected loop head, we scan back from the tail to find
-;;; an alternate loop head.  This substitution preserves the correctness of the
-;;; walk, since the old head can be reached from the new head.  We determine
-;;; the new head by scanning as far back as we can find increasing block
-;;; numbers.  Beats me if this is in general optimal, but it works in simple
-;;; cases.
-;;;
-;;; This optimization is inhibited in functions with NLX EPs, since it is hard
-;;; to do this without possibly messing up the special-case walking from NLX
-;;; EPs described in CONTROL-ANALYZE-1-FUN.  We also suppress rotation of loop
-;;; heads which are the start of a function (i.e. tail calls), as the debugger
-;;; wants functions to start at the start.
-;;;
-(defun find-rotated-loop-head (block)
-  (declare (type cblock block))
-  (let* ((num (block-number block))
-	 (env (block-environment block))
-	 (pred (dolist (pred (block-pred block) nil)
-		 (when (and (not (block-flag pred))
-			    (eq (block-environment pred) env)
-			    (< (block-number pred) num))
-		   (return pred)))))
-    (cond
-     ((and pred
-	   (not (environment-nlx-info env))
-	   (not (eq (node-block (lambda-bind (block-home-lambda block)))
-		    block)))
-      (let ((current pred)
-	    (current-num (block-number pred)))
-	(block DONE
-	  (loop
-	    (dolist (pred (block-pred current) (return-from DONE))
-	      (when (eq pred block)
-		(return-from DONE))
-	      (when (and (not (block-flag pred))
-			 (eq (block-environment pred) env)
-			 (> (block-number pred) current-num))
-		(setq current pred   current-num (block-number pred))
-		(return)))))
-	(assert (not (block-flag current)))
-	current))
-     (t
-      block))))
-	  
-
-;;; Control-Analyze-Block  --  Internal
-;;;
-;;;    Do a graph walk linking blocks into the emit order as we go.  We call
-;;; FIND-ROTATED-LOOP-HEAD to do while-loop optimization.
-;;;
-;;;    We treat blocks ending in tail local calls to other environments
-;;; specially.  We can't walked the called function immediately, since it is in
-;;; a different function and we must keep the code for a function contiguous.
-;;; Instead, we return the function that we want to call so that it can be
-;;; walked as soon as possible, which is hopefully immediately.
-;;;
-;;;    If any of the recursive calls ends in a tail local call, then we return
-;;; the last such function, since it is the only one we can possibly drop
-;;; through to.  (But it doesn't have to be from the last block walked, since
-;;; that call might not have added anything.)
-;;;
-;;;    We defer walking successors whose successor is the component tail (end
-;;; in an error, NLX or tail full call.)  This is to discourage making error
-;;; code the drop-through.
-;;;
-(defun control-analyze-block (block tail block-info-constructor)
-  (declare (type cblock block) (type block-annotation tail))
-  (unless (block-flag block)
-    (let ((block (find-rotated-loop-head 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)
-				   (funcall block-info-constructor block)))
-			 (block-annotation-prev tail))
-      
-      (let ((last (block-last block)))
-	(cond ((and (combination-p last) (node-tail-p last)
-		    (eq (basic-combination-kind last) :local)
-		    (not (eq (node-environment last)
-			     (lambda-environment (combination-lambda last)))))
-	       (combination-lambda last))
-	      (t
-	       (let ((component-tail (component-tail (block-component block)))
-		     (block-succ (block-succ block))
-		     (fun nil))
-		 (dolist (succ block-succ)
-		   (unless (eq (first (block-succ succ)) component-tail)
-		     (let ((res (control-analyze-block
-				 succ tail block-info-constructor)))
-		       (when res (setq fun res)))))
-		 (dolist (succ block-succ)
-		   (control-analyze-block succ tail block-info-constructor))
-		 fun)))))))
-
-
-;;; 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.  If the walks from NLX
-;;; EPs reach the bind block, then we just move it to the beginning.
-;;;
-;;;    If the walk from the bind node encountered a tail local call, then we
-;;; start over again there to help the call drop through.  Of course, it will
-;;; never get a drop-through if either function has NLX code.
-;;;
-(defun control-analyze-1-fun (fun component block-info-constructor)
-  (declare (type clambda fun) (type component component))
-  (let* ((tail-block (block-info (component-tail component)))
-	 (prev-block (block-annotation-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
-			       block-info-constructor))
-      (cond
-       ((block-flag bind-block)
-	(let* ((block-note (block-info bind-block))
-	       (prev (block-annotation-prev block-note))
-	       (next (block-annotation-next block-note)))
-	  (setf (block-annotation-prev next) prev)
-	  (setf (block-annotation-next prev) next)
-	  (add-to-emit-order block-note prev-block)))
-       (t
-	(let ((new-fun (control-analyze-block bind-block
-					      (block-annotation-next
-					       prev-block)
-					      block-info-constructor)))
-	  (when new-fun
-	    (control-analyze-1-fun new-fun component
-				   block-info-constructor)))))))
-  (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 blocks that weren't reached by the walk.
-;;; Some return blocks are made unreachable by LTN without setting
-;;; COMPONENT-REANALYZE.  We remove all deleted blocks from the IR2-COMPONENT
-;;; VALUES-RECEIVERS to keep stack analysis from getting confused.
-;;;
-(defun control-analyze (component block-info-constructor)
-  (declare (type component component)
-	   (type function block-info-constructor))
-  (let* ((head (component-head component))
-	 (head-block (funcall block-info-constructor head))
-	 (tail (component-tail component))
-	 (tail-block (funcall block-info-constructor tail)))
-    (setf (block-info head) head-block)
-    (setf (block-info tail) tail-block)
-    (setf (block-annotation-prev tail-block) head-block)
-    (setf (block-annotation-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 block-info-constructor)))
-
-    (dolist (fun (component-lambdas component))
-      (control-analyze-1-fun fun component block-info-constructor))
-
-    (do-blocks (block component)
-      (unless (block-flag block)
-	(delete-block block))))
-
-  (let ((2comp (component-info component)))
-    (when (ir2-component-p 2comp)
-      ;; If it's not an ir2-component, don't worry about it.
-      (setf (ir2-component-values-receivers 2comp)
-	    (delete-if-not #'block-component
-			   (ir2-component-values-receivers 2comp)))))
-
-  (undefined-value))
diff --git a/compiler/copyprop.lisp b/compiler/copyprop.lisp
deleted file mode 100644
index fa7d2705540ae5105766e8a40f1426a858f793e7..0000000000000000000000000000000000000000
--- a/compiler/copyprop.lisp
+++ /dev/null
@@ -1,269 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/copyprop.lisp,v 1.6 1991/02/20 14:56:55 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file implements the copy propagation phase of the compiler,
-;;; which uses global flow analysis to eliminate unnecessary copying of
-;;; variables.
-;;; 
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;; In copy propagation, we manipulate sets of TNs.  We only consider TNs whose
-;;; sole write is by a MOVE VOP.  This allows us to use a degenerate version of
-;;; reaching definitions: since each such TN has only one definition, the TN
-;;; can stand for the definition.  We can get away with this simplification,
-;;; since the TNs that would be subject to copy propagation are nearly always
-;;; single-writer (mostly temps allocated to ensure evaluation order is
-;;; perserved).  Only TNs written by MOVEs are interesting, since all we do
-;;; with this information is delete spurious MOVEs.
-;;;
-;;; There are additional semantic constraints on whether a TN can be considered
-;;; to be a copy.  See TN-IS-A-COPY-OF.
-;;;
-;;; If a TN is in the IN set for a block, that TN is a copy of a TN which still
-;;; has the same value it had at the time the move was done.  Any reference
-;;; to a TN in the IN set can be replaced with a reference to the TN moved
-;;; from.  When we delete all reads of such a TN, we can delete the MOVE VOP.
-;;; IN is computed as the intersection of OUT for all the predecessor blocks.
-;;;
-;;; In this flow analysis scheme, the KILL set is the set of all interesting
-;;; TNs where the copied TN is modified by the block (in any way.)
-;;;
-;;; GEN is the set of all interesting TNs that are copied in the block (whose
-;;; write appears in the block.)
-;;;
-;;; OUT is (union (difference IN KILL) GEN)
-;;;
-
-
-;;; TN-IS-COPY-OF  --  Internal
-;;;
-;;;    If TN is subject to copy propagation, then return the TN it is a copy
-;;; of, otherwise NIL.
-;;;
-;;; We also only consider TNs where neither the TN nor the copied TN are wired
-;;; or restricted.  If we extended the life of a wired or restricted TN,
-;;; register allocation might fail, and we can't substitute arbitrary things
-;;; for references to wired or restricted TNs, since the reader may be
-;;; expencting the argument to be in a particular place (as in a passing
-;;; location.)
-;;;
-;;; The TN must be a :NORMAL TN.  Other TNs might have hidden references or be
-;;; otherwise bizzare.
-;;;
-;;; A TN is also inelegible if it has interned name, policy is such that we
-;;; would dump it in the debug vars, and speed is not 3.
-;;;
-;;; The SCs of the TN's primitive types is a subset of the SCs of the copied
-;;; TN.  Moves between TNs of different primitive type SCs may need to be
-;;; changed into coercions, so we can't squeeze them out.  The reason for
-;;; testing for subset of the SCs instead of the same primitive type is
-;;; that this test lets T be substituted for LIST, POSITIVE-FIXNUM for FIXNUM,
-;;; etc.  Note that more SCs implies fewer possible values, or a subtype
-;;; relationship, since more SCs implies more possible representations.
-;;;
-(defun tn-is-copy-of (tn)
-  (declare (type tn tn) (inline subsetp))
-  (let ((writes (tn-writes tn)))
-    (and (eq (tn-kind tn) :normal)
-	 (not (tn-sc tn))		; Not wired or restricted. 
-	 (and writes (null (tn-ref-next writes)))
-	 (let ((vop (tn-ref-vop writes)))
-	   (and (eq (vop-info-name (vop-info vop)) 'move)
-		(let ((arg-tn (tn-ref-tn (vop-args vop))))
-		  (and (or (not (tn-sc arg-tn))
-			   (eq (tn-kind arg-tn) :constant))
-		       (subsetp (primitive-type-scs
-				 (tn-primitive-type tn))
-				(primitive-type-scs
-				 (tn-primitive-type arg-tn)))
-		       (let ((leaf (tn-leaf tn)))
-			 (or (not leaf)
-			     (not (symbol-package (leaf-name leaf)))
-			     (policy (vop-node vop)
-				     (or (= speed 3) (< debug 2)))))
-		       arg-tn)))))))
-
-
-;;; INIT-COPY-SETS  --  Internal
-;;;
-;;;    Init the sets in Block for copy propagation.  To find Gen, we just look
-;;; for MOVE vops, and then see if the result is a eligible copy TN.  To find
-;;; Kill, we must look at all VOP results, seeing if any of the reads of the
-;;; written TN are copies for eligible TNs.
-;;;
-(defun init-copy-sets (block)
-  (declare (type cblock block))
-  (let ((kill (make-sset))
-	(gen (make-sset)))
-    (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
-	((null vop))
-      (unless (and (eq (vop-info-name (vop-info vop)) 'move)
-		   (let ((y (tn-ref-tn (vop-results vop))))
-		     (when (tn-is-copy-of y)
-		       (sset-adjoin y gen)
-		       t)))
-	(do ((res (vop-results vop) (tn-ref-across res)))
-	    ((null res))
-	  (let ((res-tn (tn-ref-tn res)))
-	    (do ((read (tn-reads res-tn) (tn-ref-next read)))
-		((null read))
-	      (let ((read-vop (tn-ref-vop read)))
-		(when (eq (vop-info-name (vop-info read-vop)) 'move)
-		  (let ((y (tn-ref-tn (vop-results read-vop))))
-		    (when (tn-is-copy-of y)
-		      (sset-delete y gen)
-		      (sset-adjoin y kill))))))))))
-
-    (setf (block-out block) (copy-sset gen))
-    (setf (block-kill block) kill)
-    (setf (block-gen block) gen))
-  (undefined-value))
-
-
-;;; COPY-FLOW-ANALYSIS  --  Internal
-;;;
-;;;    Do the flow analysis step for copy propagation on Block.  We rely on OUT
-;;; being initilized to GEN, and use SSET-UNION-OF-DIFFERENCE to incrementally
-;;; build the union in OUT, rather than replacing OUT each time.
-;;;
-(defun copy-flow-analysis (block)
-  (declare (type cblock block))
-  (let* ((pred (block-pred block))
-	 (in (copy-sset (block-out (first pred)))))
-    (dolist (pred-block (rest pred))
-      (sset-intersection in (block-out pred-block)))
-    (setf (block-in block) in)
-    (sset-union-of-difference (block-out block) in (block-kill block))))
-
-
-(defevent copy-deleted-move "Copy propagation deleted a move.")
-
-;;; OK-COPY-REF  --  Internal
-;;;
-;;;    Return true if Arg is a reference to a TN that we can copy propagate to.
-;;; In addition to dealing with copy chains (as discussed below), we also throw
-;;; out references that are arguments to a local call, since IR2tran introduces
-;;; tempes in that context to preserve parallel assignment semantics.
-;;;
-(defun ok-copy-ref (vop arg in original-copy-of)
-  (declare (type vop vop) (type tn arg) (type sset in)
-	   (type hash-table original-copy-of))
-  (and (sset-member arg in)
-       (do ((original (gethash arg original-copy-of)
-		      (gethash original original-copy-of)))
-	   ((not original) t)
-	 (unless (sset-member original in)
-	   (return nil)))
-       (let ((info (vop-info vop)))
-	 (not (and (eq (vop-info-move-args info) :local-call)
-		   (>= (or (position-in #'tn-ref-across arg (vop-args vop)
-					:key #'tn-ref-tn)
-			   (error "Couldn't find REF?"))
-		       (length (template-arg-types info))))))))
-
-
-;;; PROPAGATE-COPIES  --  Internal
-;;;
-;;;    Make use of the result of flow analysis to eliminate copies.  We scan
-;;; the VOPs in block, propagating copies and keeping our IN set in sync.
-;;;
-;;;    Original-Copy-Of is an EQ hash table that we use to keep track of
-;;; renamings when there are copy chains, i.e. copies of copies.  When we see
-;;; copy of a copy, we enter the first copy in the table with the second copy
-;;; as a key.  When we see a reference to a TN in a copy chain, we can only
-;;; substitute the first copied TN for the reference when all intervening
-;;; copies in the copy chain are also avaliable.  Otherwise, we just leave the
-;;; reference alone.  It is possible that we might have been able to reference
-;;; one of the intermediate copies instead, but that copy might have already
-;;; been deleted, since we delete the move immediately when the references go
-;;; to zero.
-;;;
-;;;    To understand why we always can to the substitution when the copy chain
-;;; recorded in the Original-Copy-Of table hits NIL, note that we make an entry
-;;; in the table iff we change the arg of a copy.  If an entry is not in the
-;;; table, it must be that we hit a move which *originally* referenced our
-;;; Copy-Of TN.  If all the intervening copies reach our reference, then
-;;; Copy-Of must reach the reference.
-;;;
-;;;    Note that due to our restricting copies to single-writer TNs, it will
-;;; always be the case that when the first copy in a chain reaches the
-;;; reference, all intervening copies reach also reach the reference.  We
-;;; don't exploit this, since we have to work backward from the last copy.
-;;;
-;;;    In this discussion, we are really only playing with the tail of the true
-;;; copy chain for which all of the copies have already had PROPAGATE-COPIES
-;;; done on them.  But, because we do this pass in DFO, it is virtually always
-;;; the case that we will process earlier copies before later ones.  In
-;;; perverse cases (non-reducible flow graphs), we just miss some optimization
-;;; opportinities.
-;;;
-(defun propagate-copies (block original-copy-of)
-  (declare (type cblock block) (type hash-table original-copy-of))
-  (let ((in (block-in block)))
-    (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
-	((null vop))
-      (let ((this-copy (and (eq (vop-info-name (vop-info vop)) 'move)
-			    (let ((y (tn-ref-tn (vop-results vop))))
-			      (when (tn-is-copy-of y) y)))))
-	;;
-	;; Substitute copied TN for copy when we find a reference to a copy.
-	;; If the copy is left with no reads, delete the move to the copy.
-	(do ((arg-ref (vop-args vop) (tn-ref-across arg-ref)))
-	    ((null arg-ref))
-	  (let* ((arg (tn-ref-tn arg-ref))
-		 (copy-of (tn-is-copy-of arg)))
-	    (when (and copy-of (ok-copy-ref vop arg in original-copy-of))
-	      (when this-copy
-		(setf (gethash this-copy original-copy-of) arg))
-	      (change-tn-ref-tn arg-ref copy-of)
-	      (when (null (tn-reads arg))
-		(event copy-deleted-move)
-		(delete-vop (tn-ref-vop (tn-writes arg)))))))
-	;;
-	;; Kill any elements in IN that are copies of a TN we are clobbering.
-	(do ((res-ref (vop-results vop) (tn-ref-across res-ref)))
-	    ((null res-ref))
-	  (do-elements (tn in)
-	    (when (eq (tn-is-copy-of tn) (tn-ref-tn res-ref))
-	      (sset-delete tn in))))
-	;;
-	;; If this VOP is a copy, add the copy TN to IN.
-	(when this-copy (sset-adjoin this-copy in)))))
-
-  (undefined-value))
-
-
-;;; COPY-PROPAGATE  --  Interface
-;;;
-;;;    Do copy propgation on Component by initilizing the flow analysis sets,
-;;; doing flow analysis, and then propagating copies using the results.
-;;;
-(defun copy-propagate (component)
-  (setf (block-out (component-head component)) (make-sset))
-  (do-blocks (block component)
-    (init-copy-sets block))
-
-  (loop
-    (let ((did-something nil))
-      (do-blocks (block component)
-	(when (copy-flow-analysis block)
-	  (setq did-something t)))
-      (unless did-something (return))))
-
-  (let ((original-copies (make-hash-table :test #'eq)))
-    (do-blocks (block component)
-      (propagate-copies block original-copies)))
-
-  (undefined-value))
diff --git a/compiler/ctype.lisp b/compiler/ctype.lisp
deleted file mode 100644
index 31d94e24eb53d555aed07ad4ce7c94cabd81306d..0000000000000000000000000000000000000000
--- a/compiler/ctype.lisp
+++ /dev/null
@@ -1,782 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ctype.lisp,v 1.25 1991/12/11 23:49:53 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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.
-
-;;; ALWAYS-SUBTYPEP  --  Interface
-;;;
-;;;    A dummy version of SUBTYPEP useful when we want a functional like
-;;; subtypep that always returns true.
-;;;
-(defun always-subtypep (type1 type2)
-  (declare (ignore type1 type2))
-  (values t t))
-
-
-;;; Valid-Function-Use  --  Interface
-;;;
-;;;    Determine whether a use of a function is consistent with its type.
-;;; These values are returned:
-;;;    T, T: the call is definitely valid.
-;;;    NIL, T: the call is definitely invalid.
-;;;    NIL, NIL: unable to determine if the call is valid.
-;;;
-;;; 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 and safety is non-zero, then the
-;;; Node-Derived-Type is always used.  Otherwise, if 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 (type 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
-     ((function-type-wild-args type)
-      (do ((i 1 (1+ i))
-	   (arg args (cdr arg)))
-	  ((null arg))
-	(check-arg-type (car arg) *wild-type* i)))
-     ((not (or optional keyp rest))
-      (if (/= nargs min-args)
-	  (note-lossage
-	   "Function called with ~R argument~:P, but wants exactly ~R."
-	   nargs min-args)
-	  (check-fixed-and-rest args required nil)))
-     ((< 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 (not (continuation-type-check cont))
-		    (and strict-result (policy call (/= safety 0))))
-		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 t)))))
-
-
-;;; 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.  If the type is a magic CONSTANT-TYPE, then we check
-;;; for the argument being a constant value of the specified type.  If there is
-;;; a manfest type error (DERIVED-TYPE = NIL), then we flame about the asserted
-;;; type even when our type is satisfied under the test.
-;;;
-(defun check-arg-type (cont type n)
-  (declare (type continuation cont) (type ctype type) (type index n))
-  (cond
-   ((not (constant-type-p type))
-    (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)
-	      ((eq ctype *empty-type*)
-	       (note-slime "The ~:R argument never returns a value." n)
-	       nil)
-	      (t t)))))
-    ((not (constant-continuation-p cont))
-     (note-slime "The ~:R argument is not a constant." n)
-     nil)
-    (t
-     (let ((val (continuation-value cont))
-	   (type (constant-type-type type)))
-       (multiple-value-bind (res win)
-			    (ctypep val type)
-	 (cond ((not win)
-		(note-slime "Can't tell whether the ~:R argument is a ~
-		             constant ~S:~%  ~S"
-			    n (type-specifier type) val)
-		nil)
-	       ((not res)
-		(note-lossage "The ~:R argument is not a constant ~S:~%  ~S"
-			      n (type-specifier type) val)
-		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 ctype 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 (1+ pre-key) (+ n 2)))
-      ((null key))
-    (declare (fixnum n))
-    (let ((k (car key)))
-      (cond
-       ((not (check-arg-type k (specifier-type 'symbol) n)))
-       ((not (constant-continuation-p k))
-	(note-slime "The ~:R argument (in keyword position) 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)
-				 (1+ n))))))))))
-
-
-;;; 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 (tail-set-type (lambda-tail-set 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 (tail-set-type
-		     (lambda-tail-set
-		      (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.  Although keyword names don't have to
-  ;; be keywords, we only match on keywords when figuring an approximate type.
-  (name (required-argument) :type keyword)
-  ;;
-  ;; The position at which this keyword appeared.  0 if it appeared as the
-  ;; first argument, etc.
-  (position (required-argument) :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 (some #'(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)))
-
-    (when (function-type-wild-args type)
-      (return-from valid-approximate-type (values t t)))
-
-    (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 ctype 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 ctype 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)))))))
-
-
-;;;; ASSERT-DEFINITION-TYPE
-
-;;; TRY-TYPE-INTERSECTIONS  --  Internal
-;;;
-;;;    Intersect Lambda's var types with Types, giving a warning if there is a
-;;; mismatch.  If all intersections are non-null, we return lists of the
-;;; variables and intersections, otherwise we return NIL, NIL.
-;;;
-(defun try-type-intersections (vars types where)
-  (declare (list vars types) (string where))
-  (collect ((res))
-    (mapc #'(lambda (var type)
-	      (let* ((vtype (leaf-type var))
-		     (int (type-intersection vtype type)))
-		(cond
-		 ((eq int *empty-type*)
-		  (note-lossage
-		   "Definition's declared type for variable ~A:~%  ~S~@
-		   conflicts with this type from ~A:~%  ~S"
-		   (leaf-name var) (type-specifier vtype)
-		   where (type-specifier type))
-		  (return-from try-type-intersections (values nil nil)))
-		 (t
-		  (res int)))))
-	  vars types)
-    (values vars (res))))
-
-
-;;; FIND-OPTIONAL-DISPATCH-TYPES  --  Internal
-;;;
-;;;    Check that the optional-dispatch OD conforms to Type.  We return the
-;;; values of TRY-TYPE-INTERSECTIONS if there are no syntax problems, otherwise
-;;; NIL, NIL.
-;;;
-;;;    Note that the variables in the returned list are the actual original
-;;; variables (extracted from the optional dispatch arglist), rather than the
-;;; variables that are arguments to the main entry.  This difference is
-;;; significant only for keyword args with hairy defaults.  Returning the
-;;; actual vars allows us to use the right variable name in warnings.
-;;;
-;;;    A slightly subtle point: with keywords and optionals, the type in the
-;;; function type is only an assertion on calls --- it doesn't constrain the
-;;; type of default values.  So we have to union in the type of the default.
-;;; With optionals, we can't do any assertion unless the default is constant.
-;;;
-;;;    With keywords, we exploit our knowledge about how hairy keyword
-;;; defaulting is done when computing the type assertion to put on the
-;;; main-entry argument.  In the case of hairy keywords, the default has been
-;;; clobbered with NIL, which is the value of the main-entry arg in the
-;;; unsupplied case, whatever the actual default value is.  So we can just
-;;; assume the default is constant, effectively unioning in NULL, and not
-;;; totally blow off doing any type assertion.
-;;;
-(defun find-optional-dispatch-types (od type where)
-  (declare (type optional-dispatch od) (type function-type type)
-	   (string where))
-  (let* ((min (optional-dispatch-min-args od))
-	 (req (function-type-required type))
-	 (opt (function-type-optional type)))
-    (flet ((frob (x y what)
-	     (unless (= x y)
-	       (note-lossage
-		"Definition has ~R ~A arg~P, but ~A has ~R."
-		x what x where y))))
-      (frob min (length req) "fixed")
-      (frob (- (optional-dispatch-max-args od) min) (length opt) "optional"))
-    (flet ((frob (x y what)
-	     (unless (eq x y)
-	       (note-lossage
-		"Definition ~:[doesn't have~;has~] ~A, but ~
-		~A ~:[doesn't~;does~]."
-		x what where y))))
-      (frob (optional-dispatch-keyp od) (function-type-keyp type)
-	    "keyword args")
-      (unless (optional-dispatch-keyp od)
-	(frob (not (null (optional-dispatch-more-entry od)))
-	      (not (null (function-type-rest type)))
-	      "rest args"))
-      (frob (optional-dispatch-allowp od) (function-type-allowp type)
-	    "&allow-other-keys"))
-
-    (when *lossage-detected*
-      (return-from find-optional-dispatch-types (values nil nil)))
-
-    (collect ((res)
-	      (vars))
-      (let ((keys (function-type-keywords type))
-	    (arglist (optional-dispatch-arglist od)))
-	(dolist (arg arglist)
-	  (cond
-	   ((lambda-var-arg-info arg)
-	    (let* ((info (lambda-var-arg-info arg))
-		   (default (arg-info-default info))
-		   (def-type (when (constantp default)
-			       (ctype-of (eval default)))))
-	      (ecase (arg-info-kind info)
-		(:keyword
-		 (let* ((key (arg-info-keyword info))
-			(kinfo (find key keys :key #'key-info-name)))
-		   (cond
-		    (kinfo
-		     (res (type-union (key-info-type kinfo) def-type)))
-		    (t
-		     (note-lossage
-		      "Defining a ~S keyword not present in ~A."
-		      key where)
-		     (res *universal-type*)))))
-		(:required (res (pop req)))
-		(:optional
-		 (res (type-union (pop opt)
-				  (or def-type *universal-type*))))
-		(:rest
-		 (when (function-type-rest type)
-		   (res (specifier-type 'list)))))
-	      (vars arg)
-	      (when (arg-info-supplied-p info)
-		(res *universal-type*)
-		(vars (arg-info-supplied-p info)))))
-	   (t
-	    (res (pop req))
-	    (vars arg))))
-
-	(dolist (key keys)
-	  (unless (find (key-info-name key) arglist
-			:key #'(lambda (x)
-				 (let ((info (lambda-var-arg-info x)))
-				   (when info
-				     (arg-info-keyword info)))))
-	    (note-lossage
-	     "Definition lacks the ~S keyword present in ~A."
-	     (key-info-name key) where))))
-
-      (try-type-intersections (vars) (res) where))))
-
-
-;;; FIND-LAMBDA-TYPES  --  Internal
-;;;
-;;;    Check that Type doesn't specify any funny args, and do the intersection.
-;;; 
-(defun find-lambda-types (lambda type where)
-  (declare (type clambda lambda) (type function-type type) (string where))
-  (flet ((frob (x what)
-	   (when x
-	     (note-lossage
-	      "Definition has no ~A, but the ~A did."
-	      what where))))
-    (frob (function-type-optional type) "optional args")
-    (frob (function-type-keyp type) "keyword args")
-    (frob (function-type-rest type) "rest arg"))
-  (let* ((vars (lambda-vars lambda))
-	 (nvars (length vars))
-	 (req (function-type-required type))
-	 (nreq (length req)))
-    (unless (= nvars nreq)
-      (note-lossage "Definition has ~R arg~:P, but the ~A has ~R."
-		    nvars where nreq))
-    (if *lossage-detected*
-	(values nil nil)
-	(try-type-intersections vars req where))))
-
-
-;;; ASSERT-DEFINITION-TYPE  --  Interface
-;;;
-;;;    Check for syntactic and type conformance between the definition
-;;; Functional and the specified Function-Type.  If they are compatible and
-;;; Really-Assert is T, then add type assertions to the defintion from the
-;;; Function-Type.
-;;;
-;;;    If there is a syntactic or type problem, then we call Error-Function
-;;; with an error message using Where as context describing where Function-Type
-;;; came from.
-;;;
-;;;    If there is no problem, we return T (even if Really-Assert was false).
-;;; If there was a problem, we return NIL.
-;;;
-(defun assert-definition-type
-       (functional type &key (really-assert t)
-		   ((:error-function *error-function*) #'compiler-warning)
-		   warning-function
-		   (where "previous declaration"))
-  (declare (type functional functional) (type function *error-function*)
-	   (string where))
-  (let ((*lossage-detected* nil))
-    (multiple-value-bind
-	(vars types)
-	(if (function-type-wild-args type)
-	    (values nil nil)
-	    (etypecase functional
-	      (optional-dispatch
-	       (find-optional-dispatch-types functional type where))
-	      (clambda
-	       (find-lambda-types functional type where))))
-      (let* ((type-returns (function-type-returns type))
-	     (return (lambda-return (main-entry functional)))
-	     (atype (when return
-		      (continuation-asserted-type (return-result return)))))
-	(cond
-	 ((and atype (not (values-types-intersect atype type-returns)))
-	  (note-lossage
-	   "The result type from ~A:~%  ~S~@
-	   conflicts with the definition's result type assertion:~%  ~S"
-	   where (type-specifier type-returns) (type-specifier atype))
-	  nil)
-	 (*lossage-detected* nil)
-	 ((not really-assert) t)
-	 (t
-	  (when atype
-	    (assert-continuation-type (return-result return) atype))
-	  (loop for var in vars and type in types do
-	    (cond ((basic-var-sets var)
-		   (when (and warning-function
-			      (not (csubtypep (leaf-type var) type)))
-		     (funcall warning-function
-			      "Assignment to argument: ~S~%  ~
-			       prevents use of assertion from function ~
-			       type ~A:~%  ~S~%"
-			      (leaf-name var) where (type-specifier type))))
-		  (t
-		   (setf (leaf-type var) type)
-		   (dolist (ref (leaf-refs var))
-		     (derive-node-type ref type)))))
-	  t))))))
diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp
deleted file mode 100644
index 3049a8d1bbf556945d309668acfc6f6e51d5f7af..0000000000000000000000000000000000000000
--- a/compiler/debug-dump.lisp
+++ /dev/null
@@ -1,774 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.31 1992/08/03 19:03:35 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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*)
-(declaim (type (vector (unsigned-byte 8)) *byte-buffer*))
-
-
-;;;; Debug blocks:
-
-(deftype location-kind ()
-  '(member :unknown-return :known-return :internal-error :non-local-exit
-	   :block-start :call-site :single-value-return :non-local-entry))
-
-
-;;; 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 (or label index null))
-  ;;
-  ;; 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 (or label null) label)
-	   (type location-kind kind))
-  (let ((location (make-location-info kind label vop)))
-    (setf (ir2-block-locations (vop-block vop))
-	  (nconc (ir2-block-locations (vop-block vop))
-		 (list location)))
-    location))
-
-
-;;; IR2-BLOCK-ENVIRONMENT  --  Interface
-;;;
-(proclaim '(inline ir2-block-environment))
-(defun ir2-block-environment (2block)
-  (declare (type ir2-block 2block))
-  (block-environment (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 hash-table representing the variables dumped,
-;;; compute a bit-vector representing the set of live variables.  If the TN is
-;;; environment-live, we only mark it as live when it is in scope at Node.
-;;;
-(defun compute-live-vars (live node block var-locs vop)
-  (declare (type ir2-block block) (type local-tn-bit-vector live)
-	   (type hash-table var-locs) (type node node)
-	   (type (or vop null) vop))
-  (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
-			 :element-type 'bit
-			 :initial-element 0))
-	(spilled (gethash vop
-			  (ir2-component-spilled-vops
-			   (component-info *compile-component*)))))
-    (do-live-tns (tn live block)
-      (let ((leaf (tn-leaf tn)))
-	(when (and (lambda-var-p leaf)
-		   (or (not (member (tn-kind tn)
-				    '(:environment :debug-environment)))
-		       (rassoc leaf (lexenv-variables (node-lexenv node))))
-		   (or (null spilled)
-		       (not (member tn spilled))))
-	  (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*)
-(proclaim '(type index *previous-location*))
-
-;;; DUMP-1-LOCATION  --  Internal
-;;;
-;;;    Dump a compiled debug-location into *BYTE-BUFFER* that describes the
-;;; code/source map and live info.  If true, VOP is the VOP associated with
-;;; this location, for use in determining whether TNs are spilled.
-;;;
-(defun dump-1-location (node block kind tlf-num label live var-locs vop)
-  (declare (type node node) (type ir2-block block)
-	   (type local-tn-bit-vector live)
-	   (type (or label index) label)
-	   (type location-kind kind) (type (or index null) tlf-num)
-	   (type hash-table var-locs) (type (or vop null) vop))
-  
-  (vector-push-extend
-   (dpb (position kind compiled-code-location-kinds)
-	compiled-code-location-kind-byte
-	0)
-   *byte-buffer*)
-  
-  (let ((loc (if (fixnump label) label (label-position label))))
-    (write-var-integer (- loc *previous-location*) *byte-buffer*)
-    (setq *previous-location* loc))
-
-  (let ((path (node-source-path node)))
-    (unless tlf-num
-      (write-var-integer (source-path-tlf-number path) *byte-buffer*))
-    (write-var-integer (source-path-form-number path) *byte-buffer*))
-  
-  (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
-			   *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
-		     vop))
-  (undefined-value))
-
-
-;;; FIND-TLF-AND-BLOCK-NUMBERS  --  Internal
-;;;
-;;;    Scan all the blocks, caching the block numbering in the BLOCK-FLAG and
-;;; determining if all locations are in the same TLF.
-;;;
-(defun find-tlf-and-block-numbers (fun)
-  (declare (type clambda fun))
-  (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun))))
-	(num 0))
-    (declare (type index num) (type (or index null) res))
-    (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 (source-path-tlf-number
-			(node-source-path
-			 (continuation-next
-			  (block-start block))))
-		       res)
-	    (setq res nil)))
-	
-	(dolist (loc (ir2-block-locations 2block))
-	  (unless (eql (source-path-tlf-number
-			(node-source-path
-			 (vop-node (location-info-vop loc))))
-		       res)
-	    (setq res nil)))))
-    res))
-
-
-;;; DUMP-BLOCK-LOCATIONS  --  Internal
-;;;
-;;;    Dump out the number of locations and the locations for Block.
-;;;
-(defun dump-block-locations (block locations tlf-num var-locs)
-  (declare (type cblock block) (list locations))
-  (if (and locations
-	   (eq (location-info-kind (first locations))
-	       :non-local-entry))
-      (write-var-integer (length locations) *byte-buffer*)
-      (let ((2block (block-info block)))
-	(write-var-integer (+ (length locations) 1) *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
-			 nil)))
-  (dolist (loc locations)
-    (dump-location-from-info loc tlf-num var-locs))
-  (undefined-value))
-
-
-;;; DUMP-BLOCK-SUCCESSORS  --  Internal
-;;;
-;;;    Dump the successors of Block, being careful not to fly into space on
-;;; weird successors.
-;;;
-(defun dump-block-successors (block env)
-  (declare (type cblock block) (type environment env))
-  (let* ((tail (component-tail (block-component block)))
-	 (succ (block-succ block))
-	 (valid-succ
-	  (if (and succ
-		   (or (eq (car succ) tail)
-		       (not (eq (block-environment (car succ)) env))))
-	      ()
-	      succ)))
-    (vector-push-extend
-     (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
-     *byte-buffer*)
-    (dolist (b valid-succ)
-      (write-var-integer (block-flag b) *byte-buffer*)))
-  (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 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 (find-tlf-and-block-numbers fun))
-	(env (lambda-environment fun))
-	(prev-locs nil)
-	(prev-block nil))
-    (collect ((elsewhere))
-      (do-environment-ir2-blocks (2block env)
-	(let ((block (ir2-block-block 2block)))
-	  (when (eq (block-info block) 2block)
-	    (when prev-block
-	      (dump-block-locations prev-block prev-locs tlf-num var-locs))
-	    (setq prev-block block  prev-locs ())
-	    (dump-block-successors block env)))
-	
-	(collect ((here prev-locs))
-	  (dolist (loc (ir2-block-locations 2block))
-	    (if (label-elsewhere-p (location-info-label loc))
-		(elsewhere loc)
-		(here loc)))
-	  (setq prev-locs (here))))
-
-      (dump-block-locations prev-block prev-locs 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.  We always dump the Start-Positions, since it is too hard
-;;; figure out whether we need them or not.
-;;;
-(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
-			  :comment (file-info-comment x)
-			  :created (file-info-write-date x)
-			  :compiled (source-info-start-time info)
-			  :source-root (file-info-source-root x)
-			  :start-positions
-			  (coerce-to-smallest-eltype
-			   (file-info-positions x)))))
-		(cond ((simple-string-p name)
-		       (setf (debug-source-name res) name))
-		      (t
-		       (setf (debug-source-from res) name)
-		       (setf (debug-source-name res)
-			     (coerce (file-info-forms x) 'simple-vector))))
-		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)
-  (declare (type sequence seq))
-  (let ((max 0))
-    (declare (type (or index null) max))
-    (macrolet ((frob ()
-		 '(if (and (typep val 'index) 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 `(simple-array (integer 0 ,max)))
-	(coerce seq 'simple-vector))))
-
-
-;;;; Variables:
-
-;;; 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.  If Minimal is true, we suppress name dumping, and set the
-;;; minimal flag.
-;;;
-;;;    The debug-variable is only marked as always-live if the TN is
-;;; environment live and is an argument.  If a :debug-environment TN, then we
-;;; also exclude set variables, since the variable is not guranteed to be live
-;;; everywhere in that case.
-;;;
-(defun dump-1-variable (fun var tn id minimal buffer)
-  (declare (type lambda-var var) (type (or tn null) tn) (type index id)
-	   (type clambda fun))
-  (let* ((name (leaf-name var))
-	 (package (symbol-package name))
-	 (package-p (and package (not (eq package *package*))))
-	 (save-tn (and tn (tn-save-tn tn)))
-	 (kind (and tn (tn-kind tn)))
-	 (flags 0))
-    (declare (type index flags))
-    (cond (minimal
-	   (setq flags (logior flags compiled-debug-variable-minimal-p))
-	   (unless tn
-	     (setq flags (logior flags compiled-debug-variable-deleted-p))))
-	  (t
-	   (unless package
-	     (setq flags (logior flags compiled-debug-variable-uninterned)))
-	   (when package-p
-	     (setq flags (logior flags compiled-debug-variable-packaged)))))
-    (when (and (or (eq kind :environment)
-		   (and (eq kind :debug-environment)
-			(null (basic-var-sets var))))
-	       (not (gethash tn (ir2-component-spilled-tns
-				 (component-info *compile-component*))))
-	       (eq (lambda-var-home var) fun))
-      (setq flags (logior flags compiled-debug-variable-environment-live)))
-    (when save-tn
-      (setq flags (logior flags compiled-debug-variable-save-loc-p)))
-    (unless (or (zerop id) minimal)
-      (setq flags (logior flags compiled-debug-variable-id-p)))
-    (vector-push-extend flags buffer)
-    (unless minimal
-      (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)))
-    (if tn
-	(write-var-integer (tn-sc-offset tn) buffer)
-	(assert minimal))
-    (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) (tn-offset tn)
-			    (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)
-	       (type index id i))
-      (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 fun var (cdr x) id nil *byte-buffer*)
-	  (setf (gethash var var-locs) i))
-	(incf i)))
-
-    (copy-seq *byte-buffer*)))
-
-
-;;; COMPUTE-MINIMAL-VARIABLES  --  Internal
-;;;
-;;;    Dump out the arguments to Fun in the minimal variable format.
-;;;
-(defun compute-minimal-variables (fun)
-  (declare (type clambda fun))
-  (setf (fill-pointer *byte-buffer*) 0)
-  (dolist (var (lambda-vars fun))
-    (dump-1-variable fun var (leaf-info var) 0 t *byte-buffer*))
-  (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 (or (null (leaf-refs var))
-		       (not (tn-offset (leaf-info 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))
-		(saw-optional nil))
-	    (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))
-			 (:optional
-			  (unless saw-optional
-			    (res 'optional-args)
-			    (setq saw-optional t))))
-		       (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 functions:
-
-;;; DFUN-FROM-FUN  --  Internal
-;;;
-;;;    Return a C-D-F structure with all the mandatory slots filled in.
-;;;
-(defun dfun-from-fun (fun)
-  (declare (type clambda fun))
-  (let* ((2env (environment-info (lambda-environment fun)))
-	 (dispatch (lambda-optional-dispatch fun))
-	 (main-p (and dispatch
-		      (eq fun (optional-dispatch-main-entry dispatch)))))
-    (make-compiled-debug-function
-     :name (cond ((leaf-name fun))
-		 ((let ((ef (functional-entry-function
-			     fun)))
-		    (and ef (leaf-name ef))))
-		 ((and main-p (leaf-name dispatch)))
-		 (t
-		  (component-name
-		   (block-component (node-block (lambda-bind fun))))))
-     :kind (if main-p nil (functional-kind fun))
-     :return-pc (tn-sc-offset (ir2-environment-return-pc 2env))
-     :old-fp (tn-sc-offset (ir2-environment-old-fp 2env))
-     :start-pc (label-position (ir2-environment-environment-start 2env))
-     :elsewhere-pc (label-position (ir2-environment-elsewhere-start 2env)))))
-
-
-;;; COMPUTE-1-DEBUG-FUNCTION  --  Internal
-;;;
-;;;    Return a complete C-D-F structure for Fun.  This involves determining
-;;; the DEBUG-INFO level and filling in optional slots as appropriate.
-;;;
-(defun compute-1-debug-function (fun var-locs)
-  (declare (type clambda fun) (type hash-table var-locs))
-  (let* ((dfun (dfun-from-fun fun))
-	 (level (cookie-debug
-		 (lexenv-cookie (node-lexenv (lambda-bind fun))))))
-
-    (cond ((zerop level))
-	  ((and (<= level 1)
-		(let ((od (lambda-optional-dispatch fun)))
-		  (or (not od)
-		      (not (eq (optional-dispatch-main-entry od) fun)))))
-	   (setf (compiled-debug-function-variables dfun)
-		 (compute-minimal-variables fun))
-	   (setf (compiled-debug-function-arguments dfun) :minimal))
-	  (t
-	   (setf (compiled-debug-function-variables dfun)
-		 (compute-variables fun level var-locs))
-	   (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)))
-
-    (if (external-entry-point-p fun)
-	(setf (compiled-debug-function-returns dfun) :standard)
-	(let ((info (tail-set-info (lambda-tail-set fun))))
-	  (when info
-	    (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)))))))
-    dfun))
-
-
-;;;; Minimal debug functions:
-
-;;; DEBUG-FUNCTION-MINIMAL-P  --  Internal
-;;;
-;;;    Return true if Dfun can be represented as a minimal debug function.
-;;; Dfun is a cons (<start offset> . C-D-F).
-;;;
-(defun debug-function-minimal-p (dfun)
-  (declare (type cons dfun))
-  (let ((dfun (cdr dfun)))
-    (and (member (compiled-debug-function-arguments dfun) '(:minimal nil))
-	 (null (compiled-debug-function-blocks dfun)))))
-
-
-;;; DUMP-1-MINIMAL-DFUN  --  Internal
-;;;
-;;;    Dump a packed binary representation of a Dfun into *byte-buffer*.
-;;; Prev-Start and Start are the byte offsets in the code where the previous
-;;; function started and where this one starts.  Prev-Elsewhere is the previous
-;;; function's elsewhere PC.
-;;;
-(defun dump-1-minimal-dfun (dfun prev-start start prev-elsewhere)
-  (declare (type compiled-debug-function dfun)
-	   (type index prev-start start prev-elsewhere))
-  (let* ((name (compiled-debug-function-name dfun))
-	 (setf-p (and (consp name) (eq (car name) 'setf)
-		      (consp (cdr name)) (symbolp (cadr name))))
-	 (base-name (if setf-p (cadr name) name))
-	 (pkg (when (symbolp base-name)
-		(symbol-package base-name)))
-	 (name-rep
-	  (cond ((stringp base-name)
-		 minimal-debug-function-name-component)
-		((not pkg)
-		 minimal-debug-function-name-uninterned)
-		((eq pkg *package*)
-		 minimal-debug-function-name-symbol)
-		(t
-		 minimal-debug-function-name-packaged))))
-    (assert (or (atom name) setf-p))
-    (let ((options 0))
-      (setf (ldb minimal-debug-function-name-style-byte options) name-rep)
-      (setf (ldb minimal-debug-function-kind-byte options)
-	    (position (compiled-debug-function-kind dfun)
-		      minimal-debug-function-kinds))
-      (setf (ldb minimal-debug-function-returns-byte options)
-	    (etypecase (compiled-debug-function-returns dfun)
-	      ((member :standard) minimal-debug-function-returns-standard)
-	      ((member :fixed) minimal-debug-function-returns-fixed)
-	      (vector minimal-debug-function-returns-specified)))
-      (vector-push-extend options *byte-buffer*))
-
-    (let ((flags 0))
-      (when setf-p
-	(setq flags (logior flags minimal-debug-function-setf-bit)))
-      (when (compiled-debug-function-nfp dfun)
-	(setq flags (logior flags minimal-debug-function-nfp-bit)))
-      (when (compiled-debug-function-variables dfun)
-	(setq flags (logior flags minimal-debug-function-variables-bit)))
-      (vector-push-extend flags *byte-buffer*))
-
-    (when (eql name-rep minimal-debug-function-name-packaged)
-      (write-var-string (package-name pkg) *byte-buffer*))
-    (unless (stringp base-name)
-      (write-var-string (symbol-name base-name) *byte-buffer*))
-
-    (let ((vars (compiled-debug-function-variables dfun)))
-      (when vars
-	(let ((len (length vars)))
-	  (write-var-integer len *byte-buffer*)
-	  (dotimes (i len)
-	    (vector-push-extend (aref vars i) *byte-buffer*)))))
-
-    (let ((returns (compiled-debug-function-returns dfun)))
-      (when (vectorp returns)
-	(let ((len (length returns)))
-	  (write-var-integer len *byte-buffer*)
-	  (dotimes (i len)
-	    (write-var-integer (aref returns i) *byte-buffer*)))))
-
-    (write-var-integer (compiled-debug-function-return-pc dfun)
-		       *byte-buffer*)
-    (write-var-integer (compiled-debug-function-old-fp dfun)
-		       *byte-buffer*)
-    (when (compiled-debug-function-nfp dfun)
-      (write-var-integer (compiled-debug-function-nfp dfun)
-			 *byte-buffer*))
-    (write-var-integer (- start prev-start) *byte-buffer*)
-    (write-var-integer (- (compiled-debug-function-start-pc dfun) start)
-		       *byte-buffer*)
-    (write-var-integer (- (compiled-debug-function-elsewhere-pc dfun)
-			  prev-elsewhere)
-		       *byte-buffer*)))
-
-
-;;; COMPUTE-MINIMAL-DEBUG-FUNCTIONS  --  Internal
-;;;
-;;;    Return a byte-vector holding all the debug functions for a component in
-;;; the packed binary minimal-debug-function format.
-;;;
-(defun compute-minimal-debug-functions (dfuns)
-  (declare (list dfuns))
-  (setf (fill-pointer *byte-buffer*) 0)
-  (let ((prev-start 0)
-	(prev-elsewhere 0))
-    (dolist (dfun dfuns)
-      (let ((start (car dfun))
-	    (elsewhere (compiled-debug-function-elsewhere-pc (cdr dfun))))
-	(dump-1-minimal-dfun (cdr dfun) prev-start start prev-elsewhere)
-	(setq prev-start start  prev-elsewhere elsewhere))))
-  (copy-seq *byte-buffer*))
-
-
-;;;; Full component dumping:
-
-;;; COMPUTE-DEBUG-FUNCTION-MAP  --  Internal
-;;;
-;;;    Compute the full form (simple-vector) function map.
-;;;
-(defun compute-debug-function-map (sorted)
-  (declare (list sorted))
-  (let* ((len (1- (* (length sorted) 2)))
-	 (funs-vec (make-array len)))
-    (do ((i -1 (+ i 2))
-	 (sorted sorted (cdr sorted)))
-	((= i len))
-      (declare (fixnum i))
-      (let ((dfun (car sorted)))
-	(unless (minusp i)
-	  (setf (svref funs-vec i) (car dfun)))
-	(setf (svref funs-vec (1+ i)) (cdr dfun))))
-    funs-vec))
-
-
-;;; DEBUG-INFO-FOR-COMPONENT  --  Interface
-;;;
-;;;    Return a debug-info structure describing component.  This has to be
-;;; called after assembly so that source map information is available.
-;;;
-(defun debug-info-for-component (component)
-  (declare (type component component))
-  (let ((res (make-compiled-debug-info :name (component-name component)
-				       :package (package-name *package*))))
-    (collect ((dfuns))
-      (let ((var-locs (make-hash-table :test #'eq))
-	    (*byte-buffer* 
-	     (make-array 10 :element-type '(unsigned-byte 8)
-			 :fill-pointer 0  :adjustable t)))
-	(dolist (fun (component-lambdas component))
-	  (clrhash var-locs)
-	  (dfuns (cons (label-position
-			(block-label (node-block (lambda-bind fun))))
-		       (compute-1-debug-function fun var-locs))))
-	
-	(let ((sorted (sort (dfuns) #'< :key #'car)))
-	  (setf (compiled-debug-info-function-map res)
-		(if (every #'debug-function-minimal-p sorted)
-		    (compute-minimal-debug-functions sorted)
-		    (compute-debug-function-map sorted))))))
-
-    res))
diff --git a/compiler/debug.lisp b/compiler/debug.lisp
deleted file mode 100644
index d7ca48a6e4d2ecf6627fdeecdf36e2977ace909c..0000000000000000000000000000000000000000
--- a/compiler/debug.lisp
+++ /dev/null
@@ -1,1362 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug.lisp,v 1.23 1992/07/21 17:38:54 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Utilities for debugging the compiler.  Currently contains only stuff for
-;;; checking the consistency of the IR1.
-;;; 
-;;; Written by Rob MacLachlan
-;;;
-(in-package "C")
-
-(export '(label-id))
-
-
-(defvar *args* ()
-  "This variable is bound to the format arguments when an error is signalled
-  by Barf or Burp.")
-
-(defvar *ignored-errors* (make-hash-table :test #'equal))
-
-;;; 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) void))
-(defun barf (string &rest *args*)
-  (unless (gethash string *ignored-errors*)
-    (restart-case
-	(apply #'error string *args*)
-      (continue ()
-	:report "Ignore this error.")
-      (ignore-all ()
-	:report "Ignore this and all future occurrences of this error."
-	(setf (gethash string *ignored-errors*) t)))))
-
-(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) void))
-(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 :assignment)
-     (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))
-     (unless (eq (functional-kind functional) :assignment)
-       (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))
-       (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-home-lambda block))
-	 (fun-deleted (eq (functional-kind fun) :deleted))
-	 (this-cont (block-start block))
-	 (last (block-last block)))
-    (unless fun-deleted
-      (check-function-reached fun 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))
-
-	(unless fun-deleted
-	  (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))
-	   (tail (component-tail comp)))
-      (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))
-	(unless (or (not (eq b tail))
-		    (typep last '(or creturn exit))
-		    (and (basic-combination-p last)
-			 (or (node-tail-p last)
-			     (eq (node-derived-type last) *empty-type*)
-			     (eq (continuation-asserted-type (node-cont last))
-				 *empty-type*))))
-	  (barf "Component tail is successor of ~S when it shouldn't be."
-		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 (if (eq (functional-kind (return-lambda last)) :deleted)
-		   (null succ)
-		   (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))
-  (etypecase node
-    (ref
-     (let ((leaf (ref-leaf node)))
-       (when (functional-p leaf)
-	 (if (eq (functional-kind leaf) :top-level-xep)
-	     (unless (eq (component-kind (block-component (node-block node)))
-			 :top-level)
-	       (barf ":TOP-LEVEL-XEP ref in non-top-level component: ~S."
-		     node))
-	     (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))))))
-
-     (let ((dest (continuation-dest (node-cont node))))
-       (when (and (return-p dest)
-		  (eq (basic-combination-kind node) :local)
-		  (not (eq (lambda-tail-set (combination-lambda node))
-			   (lambda-tail-set (return-lambda dest)))))
-	 (barf "Tail local call to function with different tail set:~%  ~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 (node-home-lambda node)))
-       (barf "~S not in Entries for its home lambda." node))
-     (dolist (exit (entry-exits node))
-       (unless (node-deleted exit)
-	 (check-node-reached node))))
-    (exit
-     (let ((entry (exit-entry node))
-	   (value (exit-value node)))
-       (cond (entry
-	      (check-node-reached entry)
-	      (unless (member node (entry-exits entry))
-		(barf "~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))
-  (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
-      ((null ref))
-    (cond
-     ((find-in #'tn-ref-across ref (vop-args vop)))
-     ((find-in #'tn-ref-across ref (vop-results 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
-		     (count-if-not #'(lambda (x)
-				       (and (consp x)
-					    (eq (car x) :constant)))
-				   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)
-	(comp 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) :component)
-	     (incf comp))
-	    ((tn-global-conflicts tn)
-	     (case (tn-kind tn)
-	       ((:environment :debug-environment) (incf environment))
-	       (t (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 env, ~D comp, ~D global.~@
-       Wired: ~D, Unused: ~D.  ~D block~:P, ~D global conflict~:P.~%"
-       local temps const environment comp global wired unused
-       (ir2-block-count 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 (not (eq (tn-kind tn) :normal))
-		(tn-reads tn)
-		(tn-writes tn))
-      (barf "No references to ~S." tn))
-
-    (unless (tn-sc tn) (barf "~S has no SC." tn))
-
-    (let ((conf (tn-global-conflicts tn))
-	  (kind (tn-kind tn)))
-      (cond
-       ((eq kind :component)
-	(unless (member tn (ir2-component-component-tns
-			    (component-info component)))
-	  (barf "~S not in Component-TNs for ~S." tn component)))
-       (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)))))
-       ((member (tn-kind tn) '(:constant :specified-save)))
-       (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))
-	   (vars (lambda-vars fun))
-	   (closure (ir2-environment-environment 2env))
-	   (pc (ir2-environment-return-pc-pass 2env))
-	   (fp (ir2-environment-old-fp 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 pc)
-		      (eq tn fp)
-		      (and (external-entry-point-p fun)
-			   (tn-offset tn))
-		      (member (tn-kind tn) '(:environment :debug-environment))
-		      (member tn vars :key #'leaf-info)
-		      (member tn closure :key #'cdr))
-	    (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))
-
-
-;;;; Pack consistency checking:
-
-;;; CHECK-PACK-CONSISTENCY  --  Interface
-;;;
-(defun check-pack-consistency (component)
-  (flet ((check (scs ops)
-	   (do ((scs scs (cdr scs))
-		(op ops (tn-ref-across op)))
-	       ((null scs))
-	     (let ((load-tn (tn-ref-load-tn op)))
-	       (unless (eq (svref (car scs)
-				  (sc-number
-				   (tn-sc
-				    (or load-tn (tn-ref-tn op)))))
-			   t)
-		 (barf "Operand restriction not satisfied: ~S." op))))))
-    (do-ir2-blocks (block component)
-      (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
-	  ((null vop))
-	(let ((info (vop-info vop)))
-	  (check (vop-info-result-load-scs info) (vop-results vop))
-	  (check (vop-info-arg-load-scs info) (vop-args vop))))))
-  (undefined-value))
-
-
-;;;; 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)))
-    (functional
-     (assert (eq (functional-kind leaf) :top-level-xep))
-     (format stream "TL-XEP ~S"
-	     (let ((info (leaf-info leaf)))
-	       (etypecase info
-		 (entry-info (entry-info-name info))
-		 (byte-lambda-info :byte-compiled-entry)))))))
-
-;;; Block-Or-Lose  --  Interface
-;;;
-;;;    Attempt to find a block given some thing that has to do with it.
-;;;
-(proclaim '(function block-or-lose (t) cblock))
-(defun block-or-lose (thing)
-  (ctypecase thing
-    (cblock thing)
-    (ir2-block (ir2-block-block thing))
-    (vop (block-or-lose (vop-block thing)))
-    (tn-ref (block-or-lose (tn-ref-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 ~S" (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))
-      (format stream "[~A]" (location-print-name 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))
-  (pprint-logical-block (*standard-output* nil)
-    (do ((ref refs (tn-ref-across ref)))
-	((null ref))
-      (let ((tn (tn-ref-tn ref))
-	    (ltn (tn-ref-load-tn ref)))
-	(cond ((not ltn)
-	       (print-tn tn))
-	      (t
-	       (print-tn tn)
-	       (princ (if (tn-ref-write-p ref) #\< #\>))
-	       (print-tn ltn)))
-	(princ #\space)
-	(pprint-newline :fill)))))
-
-
-;;; Print-Vop -- internal
-;;;
-;;; Print the vop, putting args, info and results on separate lines, if
-;;; necessary.
-;;;
-(defun print-vop (vop)
-  (pprint-logical-block (*standard-output* nil)
-    (princ (vop-info-name (vop-info vop)))
-    (princ #\space)
-    (pprint-indent :current 0)
-    (print-operands (vop-args vop))
-    (pprint-newline :linear)
-    (when (vop-codegen-info vop)
-      (princ (with-output-to-string (stream)
-	       (let ((*print-level* 1)
-		     (*print-length* 3))
-		 (format stream "{~{~S~^ ~}} " (vop-codegen-info vop)))))
-      (pprint-newline :linear))
-    (when (vop-results vop)
-      (princ "=> ")
-      (print-operands (vop-results vop))))
-  (terpri))
-
-;;; Print-IR2-Block  --  Internal
-;;;
-;;;    Print the VOPs in the specified IR2 block.
-;;;
-(defun print-ir2-block (block)
-  (declare (type ir2-block block))
-  (cond
-   ((eq (block-info (ir2-block-block block)) block)
-    (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: " number)
-    (print-vop vop)))
-
-
-;;; 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)
-    (do ((b (ir2-block-next 2block) (ir2-block-next b)))
-	((not (eq (ir2-block-block b) block)))
-      (print-ir2-block b)))
-  (values))
-
-
-;;; Print-IR2-Blocks  --  Interface
-;;;
-;;;    Scan the IR2 blocks in emission order.
-;;;
-(defun print-ir2-blocks (thing)
-  (do-ir2-blocks (block (block-component (block-or-lose thing)))
-    (print-ir2-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)))
-    (handler-case (print-nodes block)
-      (error (condition)
-        (format t "~&~A...~%" condition))))
-  (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
-;;;
-(defun list-conflicts (tn)
-  "Return a list of a the TNs that conflict with TN.  Sort of, kind of.  For
-  debugging use only.  Probably doesn't work on :COMPONENT TNs."
-  (assert (member (tn-kind tn) '(:normal :environment :debug-environment)))
-  (let ((confs (tn-global-conflicts tn)))
-    (cond (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 c9668b0a4e151501c4e705dbd3b982ba690340d8..0000000000000000000000000000000000000000
--- a/compiler/dfo.lisp
+++ /dev/null
@@ -1,490 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dfo.lisp,v 1.24 1992/09/29 17:58:48 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;     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)
-  (setf (component-reanalyze component) nil)
-  (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))
-	  (setf (block-delete-p block) t)))
-    (do-blocks (block component)
-      (unless (block-flag block)
-	(delete-block block)))))
-
-
-;;; Join-Components  --  Interface
-;;;
-;;;    Move all the code and entry points from Old to New.  The code in Old is
-;;; inserted at the head of New.  This is also called during let conversion
-;;; when we are about in insert the body of a let in a different component.  [A
-;;; local call can be to a different component before FIND-INITIAL-DFO runs.]
-;;;
-(proclaim '(function join-components (component component) void))
-(defun join-components (new old)
-  (assert (eq (component-kind new) (component-kind 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 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.
-;;; -- If the home function is deleted, do nothing.  Block must eventually be
-;;;    discovered to be unreachable as well.  This can happen when we have a
-;;;    NLX into a function with no references.  The escape function still has
-;;;    refs (in the deleted function).
-;;;
-;;; 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 (block-home-lambda block)))
-    (if (eq (functional-kind home) :deleted)
-	component
-	(let* ((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 functions which local call analysis could not (or were
-;;; chosen not) to local call convert will appear as references to XEP lambdas.
-;;; We can ignore references to XEPs that appear in :TOP-LEVEL components,
-;;; since environment analysis goes to special effort to allow closing over of
-;;; values from a separate top-level component.  All other references must
-;;; cause components to be joined. 
-;;;
-;;;   References in deleted functions are also ignored, since this code will be
-;;; deleted eventually.
-;;;
-(defun find-reference-functions (fun)
-  (collect ((res))
-    (dolist (ref (leaf-refs fun))
-      (let* ((home (node-home-lambda ref))
-	     (home-kind (functional-kind home)))
-	(unless (or (and (eq home-kind :top-level)
-			 (eq (functional-kind fun) :external))
-		    (eq home-kind :deleted))
-	  (res home))))
-    (res)))
-
-
-;;; DFO-Walk-Call-Graph  --  Internal
-;;;
-;;;    Move the code for Fun and all functions called by it into Component.  If
-;;; Fun is already in Component, then we just return that 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.  It is harmless to
-;;; move the tail (even though the return might be unreachable) because if the
-;;; return is unreachable it (and its successor link) will be deleted in the
-;;; post-deletion pass.
-;;;
-;;;    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 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 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.
-;;;
-(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))
-      (setf (component-lambdas this)
-	    (delete fun (component-lambdas this)))
-      (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))))))))
-
-
-;;; HAS-XEP-OR-NLX  --  Internal
-;;;
-;;;    Return true if Fun is either an XEP or has EXITS to some of its ENTRIES.
-;;;
-(defun has-xep-or-nlx (fun)
-  (declare (type clambda fun))
-  (or (eq (functional-kind fun) :external)
-      (let ((entries (lambda-entries fun)))
-	(and entries
-	     (find-if #'entry-exits entries)))))
-
-
-;;; FIND-TOP-LEVEL-COMPONENTS  --  Internal
-;;;
-;;;    Compute the result of FIND-INITIAL-DFO given the list of all resulting
-;;; components.  Components with a :TOP-LEVEL lambda, but no normal XEPs or
-;;; potential non-local exits are marked as :TOP-LEVEL.  If there is a
-;;; :TOP-LEVEL lambda, and also a normal XEP, then we treat the component as
-;;; normal, but also return such components in a list as the third value.
-;;; Components with no entry of any sort are deleted.
-;;;
-(defun find-top-level-components (components)
-  (declare (list components))
-  (collect ((real)
-	    (top)
-	    (real-top))
-    (dolist (com components)
-      (unless (eq (block-next (component-head com)) (component-tail com))
-	(let* ((funs (component-lambdas com))
-	       (has-top (find :top-level funs :key #'functional-kind)))
-	  (cond ((or (find-if #'has-xep-or-nlx funs)
-		     (and has-top (rest funs)))
-		 (setf (component-name com) (find-component-name com))
-		 (real com)
-		 (when has-top
-		   (setf (component-kind com) :complex-top-level)
-		   (real-top com)))
-		(has-top 
-		 (setf (component-kind com) :top-level)
-		 (setf (component-name com) "Top-Level Form")
-		 (top com))
-		(t
-		 (delete-component com))))))
-
-    (values (real) (top) (real-top))))
-
-
-;;; Find-Initial-DFO  --  Interface
-;;;
-;;;    Given a list of top-level lambdas, return three lists of components
-;;; representing the actual component division:
-;;;  1] the non-top-level components,
-;;;  2] and the second is the top-level components, and
-;;;  3] Components in [1] that also have a top-level lambda.
-;;;
-;;; 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.  Any code that is left
-;;; in an initial component must be unreachable, so we can delete it.  Stray
-;;; links to the initial component tail (due NIL function terminated blocks)
-;;; are moved to the appropriate newc component tail.
-;;;
-;;;    When we are done, we assign DFNs and call FIND-TOP-LEVEL-COMPONENTS to
-;;; pull out top-level code.
-;;;
-(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)))))
-	  (when (eq (component-kind component) :initial)
-	    (assert (null (component-lambdas component)))
-	    (let ((tail (component-tail component)))
-	      (dolist (pred (block-pred tail))
-		(let ((pred-component (block-component pred)))
-		  (unless (eq pred-component component)
-		    (unlink-blocks pred tail)
-		    (link-blocks pred (component-tail pred-component))))))
-	    (delete-component component)))))
-
-    (dolist (com (components))
-      (let ((num 0))
-	(declare (fixnum num))
-	(do-blocks-backwards (block com :both)
-	  (setf (block-number block) (incf num)))))
-
-    (find-top-level-components (components))))
-
-
-;;; MERGE-1-TL-LAMBDA  --  Internal
-;;;
-;;;    Insert the code in LAMBDA at the end of RESULT-LAMBDA.
-;;;
-(defun merge-1-tl-lambda (result-lambda lambda)
-  (declare (type clambda result-lambda lambda))
-  ;;
-  ;; Delete the lambda, and combine the lets and entries.
-  (setf (functional-kind lambda) :deleted)
-  (dolist (let (lambda-lets lambda))
-    (setf (lambda-home let) result-lambda)
-    (setf (lambda-environment let) (lambda-environment result-lambda))
-    (push let (lambda-lets result-lambda)))
-  (setf (lambda-entries result-lambda)
-	(nconc (lambda-entries result-lambda)
-	       (lambda-entries lambda)))
-  
-  (let* ((bind (lambda-bind lambda))
-	 (bind-block (node-block bind))
-	 (component (block-component bind-block))
-	 (result-component
-	  (block-component (node-block (lambda-bind result-lambda))))
-	 (result-return-block (node-block (lambda-return result-lambda))))
-    ;;
-    ;; Move blocks into the new component, and move any nodes directly in
-    ;; the old lambda into the new one (lets implicitly moved by changing
-    ;; their home.) 
-    (do-blocks (block component)
-      (do-nodes (node cont block)
-	(let ((lexenv (node-lexenv node)))
-	  (when (eq (lexenv-lambda lexenv) lambda)
-	    (setf (lexenv-lambda lexenv) result-lambda))))
-      (setf (block-component block) result-component))
-    ;;
-    ;; Splice the blocks into the new DFO, and unlink them from the old
-    ;; component head and tail.  Non-return blocks that jump to the tail
-    ;; (NIL returning calls) are switched to go to the new tail.
-    (let* ((head (component-head component))
-	   (first (block-next head))
-	   (tail (component-tail component))
-	   (last (block-prev tail))
-	   (prev (block-prev result-return-block)))
-      (setf (block-next prev) first)
-      (setf (block-prev first) prev)
-      (setf (block-next last) result-return-block)
-      (setf (block-prev result-return-block) last)
-      (dolist (succ (block-succ head))
-	(unlink-blocks head succ))
-      (dolist (pred (block-pred tail))
-	(unlink-blocks pred tail)
-	(let ((last (block-last pred)))
-	  (unless (return-p last)
-	    (assert (basic-combination-p last))
-	    (link-blocks pred (component-tail result-component))))))
-    
-    (let ((lambdas (component-lambdas component)))
-      (assert (and (null (rest lambdas))
-		   (eq (first lambdas) lambda))))
-    ;;
-    ;; Switch the end of the code from the return block to the start of
-    ;; the next chunk.
-    (dolist (pred (block-pred result-return-block))
-      (unlink-blocks pred result-return-block)
-      (link-blocks pred bind-block))
-    (unlink-node bind)
-    ;;
-    ;; If there is a return, then delete it (making the preceding node the
-    ;; last node) and link the block to the result return.  There is always a
-    ;; preceding REF NIL node in top-level lambdas.
-    (let ((return (lambda-return lambda)))
-      (when return
-	(let ((return-block (node-block return))
-	      (result (return-result return)))
-	  (setf (block-last return-block) (continuation-use result))
-	  (flush-dest result)
-	  (delete-continuation result)
-	  (link-blocks return-block result-return-block))))))
-
-
-;;; MERGE-TOP-LEVEL-LAMBDAS  --  Interface
-;;;
-;;;    Given a non-empty list of top-level lambdas, smash them into a top-level
-;;; lambda and component, returning these as values.  We use the first lambda
-;;; and its component, putting the other code in that component and deleting
-;;; the other lambdas.
-;;;
-(defun merge-top-level-lambdas (lambdas)
-  (declare (cons lambdas))
-  (let* ((result-lambda (first lambdas))
-	 (result-return (lambda-return result-lambda)))
-    (cond
-     (result-return
-      ;;
-      ;; Make sure the result's return node starts a block so that we can
-      ;; splice code in before it.
-      (let ((prev (node-prev
-		   (continuation-use
-		    (return-result result-return)))))
-	(when (continuation-use prev)
-	  (node-ends-block (continuation-use prev)))
-	(do-uses (use prev)
-	  (let ((new (make-continuation)))
-	    (delete-continuation-use use)
-	    (add-continuation-use use new))))
-      
-      (dolist (lambda (rest lambdas))
-	(merge-1-tl-lambda result-lambda lambda)))
-     (t
-      (dolist (lambda (rest lambdas))
-	(setf (functional-entry-function lambda) nil)
-	(delete-component
-	 (block-component
-	  (node-block (lambda-bind lambda)))))))
-      
-    (values (block-component (node-block (lambda-bind result-lambda)))
-	    result-lambda)))
diff --git a/compiler/disassem.lisp b/compiler/disassem.lisp
deleted file mode 100644
index a5650711e829edf188c756dd096712bd70b85237..0000000000000000000000000000000000000000
--- a/compiler/disassem.lisp
+++ /dev/null
@@ -1,3724 +0,0 @@
-;;; -*- Package: DISASSEM -*-
-;;;
-;;; **********************************************************************
-;;; This code was written for the use 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.19 1992/12/17 11:24:37 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Machine independent disassembler for CMU Common Lisp
-;;;
-;;; Written by Miles Bader <miles@cogsci.ed.ac.uk>
-;;;
-
-(in-package :disassem)
-
-(use-package :extensions)
-
-(export '(;; for defining the instruction set
-	  set-disassem-params
-	  define-argument-type
-	  define-instruction-format
-	  install-inst-flavors
-
-	  ;; macroexpanders
-	  gen-preamble-form gen-clear-info-form
-	  gen-arg-type-def-form gen-format-def-form
-	  gen-printer-def-forms-def-form
-
-	  ;; main user entry-points
-	  disassemble
-	  disassemble-memory
-	  disassemble-function
-	  disassemble-code-component
-	  disassemble-assem-segment
-
-	  ;; some variables to set
-	  *opcode-column-width*
-	  *note-column*
-
-	  ;; slightly lower level entry-points
-	  make-dstate
-	  get-function-segments get-code-segments
-	  label-segments disassemble-segments disassemble-segment
-	  map-segment-instructions
-	  segment-overflow
-	  set-location-printing-range
-	  add-offs-hook add-offs-note-hook add-offs-comment-hook
-	  *default-dstate-hooks*
-	  make-segment make-code-segment make-vector-segment make-memory-segment
-	  make-offs-hook
-
-	  ;; segment type
-	  segment seg-sap-maker seg-length seg-virtual-location
-
-	  ;; decoding a bit-pattern
-	  sap-ref-dchunk
-	  get-inst-space
-	  find-inst
-	  make-decoded-inst
-
-	  ;; getting at the dstate (usually from mach-dep code)
-	  disassem-state dstate-cur-offs dstate-next-offs
-	  dstate-segment dstate-segment-sap
-	  dstate-get-prop
-	  dstate-cur-addr dstate-next-addr
-
-	  ;; random types
-	  dchunk params instruction
-
-	  ;; 
-	  read-suffix read-signed-suffix
-	  sign-extend
-
-	  ;; useful for printers
-	  princ16
-
-	  ;; making handy margin notes
-	  note
-	  note-code-constant
-	  maybe-note-nil-indexed-symbol-slot-ref
-	  maybe-note-nil-indexed-object
-	  maybe-note-assembler-routine
-	  maybe-note-single-storage-ref
-	  maybe-note-associated-storage-ref
-	  handle-break-args
-
-	  ;; taking over and printing...
-	  print-notes-and-newline
-	  print-current-address
-	  print-bytes print-words
-	  prin1-short
-	  prin1-quoted-short
-	  ))
-
-;;; ----------------------------------------------------------------
-
-(defvar *opcode-column-width* nil
-  "The width of the column in which instruction-names are printed.
-  NIL means use the default.  A value of zero gives the effect of not
-  aligning the arguments at all.")
-(defvar *note-column* 45
-  "The column in which end-of-line comments for notes are started.")
-
-(defconstant default-opcode-column-width 6)
-(defconstant default-location-column-width 8)
-(defconstant label-column-width 7)
-
-(deftype address () '(unsigned-byte 32))
-(deftype alignment () '(integer 0 64))
-(deftype offset () '(signed-byte 24))
-(deftype length () '(unsigned-byte 24))
-
-(deftype column () '(integer 0 1000))
-(deftype text-width () '(integer 0 1000))
-
-(defconstant max-filtered-value-index 32)
-(deftype filtered-value-index ()
-  `(integer 0 ,max-filtered-value-index))
-(deftype filtered-value-vector ()
-  `(simple-array t (,max-filtered-value-index)))
-
-;;; ----------------------------------------------------------------
-
-(defmacro set-disassem-params (&rest args)
-  "Specify global disassembler params for C:*TARGET-BACKEND*.
-  Keyword arguments include:
-      
-  :INSTRUCTION-ALIGNMENT number
-      Minimum alignment of instructions, in bits.
-      
-  :ADDRESS-SIZE number
-      Size of a machine address, in bits.
-      
-  :OPCODE-COLUMN-WIDTH
-      Width of the column used for printing the opcode portion of the
-      instruction, or NIL to use the default."
-  (gen-preamble-form args))
-
-(defmacro define-argument-type (name &rest args)
-  "DEFINE-ARGUMENT-TYPE Name {Key Value}*
-  Define a disassembler argument type NAME (which can then be referenced in
-  another argument definition using the :TYPE keyword argument).  Keyword
-  arguments are:
-
-  :SIGN-EXTEND boolean
-      If non-NIL, the raw value of this argument is sign-extended.
-
-  :TYPE arg-type-name
-      Inherit any properties of given argument-type.
-
-  :PREFILTER function
-      A function which is called (along with all other prefilters, in the
-      order that their arguments appear in the instruction- format) before
-      any printing is done, to filter the raw value.  Any uses of READ-SUFFIX
-      must be done inside a prefilter.
-      
-  :PRINTER function-string-or-vector
-      A function, string, or vector which is used to print an argument of
-      this type.
-      
-  :USE-LABEL 
-      If non-NIL, the value of an argument of this type is used as an
-      address, and if that address occurs inside the disassembled code, it is
-      replaced by a label.  If this is a function, it is called to filter the
-      value."
-  (gen-arg-type-def-form name args))
-
-(defmacro define-instruction-format (header &rest fields)
-  "DEFINE-INSTRUCTION-FORMAT (Name Length {Format-Key Value}*) Arg-Def*
-  Define an instruction format NAME for the disassembler's use.  LENGTH is
-  the length of the format in bits.
-  Possible FORMAT-KEYs:
-
-  :INCLUDE other-format-name
-      Inherit all arguments and properties of the given format.  Any
-      arguments defined in the current format definition will either modify
-      the copy of an existing argument (keeping in the same order with
-      respect to when pre-filter's are called), if it has the same name as
-      one, or be added to the end.
-  :DEFAULT-PRINTER printer-list
-      Use the given PRINTER-LIST as a format to print any instructions of
-      this format when they don't specify something else.
-
-  Each ARG-DEF defines one argument in the format, and is of the form
-    (Arg-Name {Arg-Key Value}*)
-
-  Possible ARG-KEYs (the values are evaulated unless otherwise specified):
-  
-  :FIELDS byte-spec-list
-      The argument takes values from these fields in the instruction.  If
-      the list is of length one, then the corresponding value is supplied by
-      itself; otherwise it is a list of the values.  The list may be NIL.
-  :FIELD byte-spec
-      The same as :FIELDS (list byte-spec).
-
-  :VALUE value
-      If the argument only has one field, this is the value it should have,
-      otherwise it's a list of the values of the individual fields.  This can
-      be overridden in an instruction-definition or a format definition
-      including this one by specifying another, or NIL to indicate that it's
-      variable.
-
-  :SIGN-EXTEND boolean
-      If non-NIL, the raw value of this argument is sign-extended,
-      immediately after being extracted from the instruction (before any
-      prefilters are run, for instance).  If the argument has multiple
-      fields, they are all sign-extended.
-
-  :TYPE arg-type-name
-      Inherit any properties of the given argument-type.
-
-  :PREFILTER function
-      A function which is called (along with all other prefilters, in the
-      order that their arguments appear in the instruction-format) before
-      any printing is done, to filter the raw value.  Any uses of READ-SUFFIX
-      must be done inside a prefilter.
-
-  :PRINTER function-string-or-vector
-      A function, string, or vector which is used to print this argument.
-      
-  :USE-LABEL 
-      If non-NIL, the value of this argument is used as an address, and if
-      that address occurs inside the disassembled code, it is replaced by a
-      label.  If this is a function, it is called to filter the value."
-  (gen-format-def-form header fields))
-
-;;; ----------------------------------------------------------------
-
-(declaim (inline bytes-to-bits)
-	 (maybe-inline sign-extend aligned-p align tab tab0))
-
-(defun bytes-to-bits (bytes)
-  (declare (type length bytes))
-  (* bytes vm:byte-bits))
-
-(defun bits-to-bytes (bits)
-  (declare (type length bits))
-  (multiple-value-bind (bytes rbits)
-      (truncate bits vm:byte-bits)
-    (when (not (zerop rbits))
-      (error "~d bits is not a byte-multiple" bits))
-    bytes))
-
-(defun sign-extend (int size)
-  (declare (type integer int)
-	   (type (integer 0 128) size))
-  (if (logbitp (1- size) int)
-      (dpb int (byte size 0) -1)
-      int))
-
-(defun aligned-p (address size)
-  "Returns non-NIL if ADDRESS is aligned on a SIZE byte boundary."
-  (declare (type address address)
-	   (type alignment size))
-  (zerop (logand (1- size) address)))
-
-(defun align (address size)
-  "Return ADDRESS aligned *upward* to a SIZE byte boundary."
-  (declare (type address address)
-	   (type alignment size))
-  (logandc1 (1- size) (+ (1- size) address)))
-
-(defun tab (column stream)
-  (funcall (formatter "~v,1t") stream column)
-  nil)
-(defun tab0 (column stream)
-  (funcall (formatter "~v,0t") stream column)
-  nil)
-
-(defun princ16 (value stream)
-  (write value :stream stream :radix t :base 16 :escape nil))
-
-;;; ----------------------------------------------------------------
-
-(defun self-evaluating-p (x)
-  (typecase x
-    (null t)
-    (keyword t)
-    (symbol (eq x t))
-    (cons nil)
-    (t t)))
-
-;;; ----------------------------------------------------------------
-;;; Some simple functions that help avoid consing when we're just
-;;; recursively filtering things that usually don't change.
-
-(defun sharing-cons (old-cons car cdr)
-  "If CAR is eq to the car of OLD-CONS and CDR is eq to the CDR, return
-  OLD-CONS, otherwise return (cons CAR CDR)."
-  (if (and (eq car (car old-cons)) (eq cdr (cdr old-cons)))
-      old-cons
-      (cons car cdr)))
-
-(defun sharing-mapcar (fun list)
-  "A simple (one list arg) mapcar that avoids consing up a new list
-  as long as the results of calling FUN on the elements of LIST are
-  eq to the original."
-  (and list
-       (sharing-cons list
-		     (funcall fun (car list))
-		     (sharing-mapcar fun (cdr list)))))
-
-;;; ----------------------------------------------------------------
-;;; A Dchunk contains the bits we look at to decode an
-;;; instruction.
-;;; I tried to keep this abstract so that if using integers > the machine
-;;; word size conses too much, it can be changed to use bit-vectors or
-;;; something.
-
-(declaim (inline dchunk-or dchunk-and dchunk-clear dchunk-not
-		 dchunk-make-mask dchunk-make-field
-		 sap-ref-dchunk
-		 dchunk-extract
-		 dchunk=
-		 dchunk-count-bits))
-
-(defconstant dchunk-bits 32)
-
-(deftype dchunk ()
-  `(unsigned-byte ,dchunk-bits))
-(deftype dchunk-index ()
-  `(integer 0 ,dchunk-bits))
-
-(defconstant dchunk-zero 0)
-(defconstant dchunk-one #xFFFFFFFF)
-
-(defmacro dchunk-copy (x)
-  `(the dchunk ,x))
-
-(defun dchunk-or (to from)
-  (declare (type dchunk to from))
-  (the dchunk (logior to from)))
-(defun dchunk-and (to from)
-  (declare (type dchunk to from))
-  (the dchunk (logand to from)))
-(defun dchunk-clear (to from)
-  (declare (type dchunk to from))
-  (the dchunk (logandc2 to from)))
-(defun dchunk-not (from)
-  (declare (type dchunk from))
-  (the dchunk (logand dchunk-one (lognot from))))
-
-(defmacro dchunk-andf (to from)
-  `(setf ,to (dchunk-and ,to ,from)))
-(defmacro dchunk-orf (to from)
-  `(setf ,to (dchunk-or ,to ,from)))
-(defmacro dchunk-clearf (to from)
-  `(setf ,to (dchunk-clear ,to ,from)))
-
-(defun dchunk-make-mask (pos)
-  (the dchunk (mask-field pos -1)))
-(defun dchunk-make-field (pos value)
-  (the dchunk (dpb value pos 0)))
-
-(defmacro make-dchunk (value)
-  `(the dchunk ,value))
-
-(defun sap-ref-dchunk (sap byte-offset byte-order)
-  (declare (type system:system-area-pointer sap)
-	   (type offset byte-offset)
-	   (optimize (speed 3) (safety 0)))
-  (the dchunk
-       (if (eq byte-order :big-endian)
-	   (+ (ash (system:sap-ref-8 sap byte-offset) 24)
-	      (ash (system:sap-ref-8 sap (+ 1 byte-offset)) 16)
-	      (ash (system:sap-ref-8 sap (+ 2 byte-offset)) 8)
-	      (system:sap-ref-8 sap (+ 3 byte-offset)))
-	   (+ (system:sap-ref-8 sap byte-offset)
-	      (ash (system:sap-ref-8 sap (+ 1 byte-offset)) 8)
-	      (ash (system:sap-ref-8 sap (+ 2 byte-offset)) 16)
-	      (ash (system:sap-ref-8 sap (+ 3 byte-offset)) 24)))))
-
-(defun correct-dchunk-bytespec-for-endianness (bs unit-bits byte-order)
-  (if (eq byte-order :big-endian)
-      (byte (byte-size bs) (+ (byte-position bs) (- dchunk-bits unit-bits)))
-      bs))
-
-(defun dchunk-extract (from pos)
-  (declare (type dchunk from))
-  (the dchunk (ldb pos (the dchunk from))))
-
-(defun dchunk-corrected-extract (from pos unit-bits byte-order)
-  (declare (type dchunk from))
-  (if (eq byte-order :big-endian)
-      (ldb (byte (byte-size pos)
-		 (+ (byte-position pos) (- dchunk-bits unit-bits)))
-	   (the dchunk from))
-      (ldb pos (the dchunk from))))
-
-(defmacro dchunk-insertf (place pos value)
-  `(setf ,place (the dchunk (dpb ,value ,pos (the dchunk,place)))))
-
-(defun dchunk= (x y)
-  (declare (type dchunk x y))
-  (= x y))
-(defmacro dchunk-zerop (x)
-  `(dchunk= ,x dchunk-zero))
-
-(defun dchunk-strict-superset-p (sup sub)
-  (and (zerop (logandc2 sub sup))
-       (not (zerop (logandc2 sup sub)))))
-
-(defun dchunk-count-bits (x)
-  (declare (type dchunk x))
-  (logcount x))
-
-;;; ----------------------------------------------------------------
-
-(defstruct (params (:print-function %print-params))
-  (instructions (make-hash-table :test #'eq) :type hash-table)
-  (inst-space nil :type (or null inst-space))
-  (instruction-alignment vm:word-bytes :type alignment)
-  (location-column-width default-location-column-width :type text-width)
-  (opcode-column-width default-opcode-column-width :type (or null text-width))
-  (backend (required-argument) :type c::backend) ; for convenience
-  )
-
-(defun %print-params (params stream level)
-  (declare (ignore level))
-  (print-unreadable-object (params stream :type t)
-    (when (params-backend params)
-      (prin1 (c:backend-name (params-backend params)) stream))))
-
-;;; ----------------------------------------------------------------
-;;; Only used during compilation of the instructions for a backend
-
-(defstruct (argument (:conc-name arg-))
-  (name nil :type symbol)
-  (fields nil :type list)
-
-  (value nil :type (or list integer))
-  (sign-extend-p nil :type (member t nil))
-
-  ;; position in a vector of prefiltered values
-  (position 0 :type fixnum)
-
-  ;; functions to use
-  (printer nil)
-  (prefilter nil)
-  (use-label nil)
-  )
-
-(defstruct (instruction-format (:conc-name format-))
-  (name nil)
-  (args nil :type list)
-
-  (length 0 :type length)		; in bytes
-
-  (default-printer nil :type list)
-  )
-
-;;; ----------------------------------------------------------------
-;;; 
-
-(defstruct (instruction (:conc-name inst-)
-			(:print-function %print-instruction)
-			(:constructor
-			 make-instruction (name
-					   format-name
-					   print-name
-					   length
-					   mask id
-					   printer
-					   labeller prefilter control)))
-  (name nil :type (or symbol string))
-  (format-name nil :type (or symbol string))
-
-  (mask dchunk-zero :type dchunk)	; bits in the inst that are constant
-  (id dchunk-zero :type dchunk)		; value of those constant bits
-
-  (length 0 :type length)		; in bytes
-
-  (print-name nil :type symbol)
-
-  ;; disassembly functions
-  (prefilter nil :type (or null function))
-  (labeller nil :type (or null function))
-  (printer (required-argument) :type (or null function))
-  (control nil :type (or null function))
-
-  ;; instructions that are the same as this instruction but with more
-  ;; constraints
-  (specializers nil :type list)
-  )
-
-(defun %print-instruction (inst stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (inst stream :type t :identity t)
-    (format stream "~a(~a)" (inst-name inst) (inst-format-name inst))))
-
-;;; ----------------------------------------------------------------
-;;; provide more meaningful error messages during compilation
-
-(defvar *current-instruction-flavor* nil)
-
-(defun pd-error (fmt &rest args)
-  (if *current-instruction-flavor*
-      (error "~@<In printer-definition for ~s(~s):  ~3i~:_~?~:>"
-	     (car *current-instruction-flavor*)
-	     (cdr *current-instruction-flavor*)
-	     fmt args)
-      (apply #'error fmt args)))
-
-;;; ----------------------------------------------------------------
-;;; Since we can't include some values in compiled output as they are
-;;; (notably functions), we sometimes use a valsrc structure to keep track of
-;;; the source from which they were derived.
-
-(defstruct (valsrc (:constructor %make-valsrc))
-  (value nil)
-  (source nil))
-
-;;; Returns a version of THING suitable for including in an evaluable
-;;; position in some form.
-(defun source-form (thing)
-  (cond ((valsrc-p thing)
-	 (valsrc-source thing))
-	((functionp thing)
-	 (pd-error
-	  "Can't dump functions, so function ref form must be quoted: ~s"
-	  thing))
-	((self-evaluating-p thing)
-	 thing)
-	((eq (car thing) 'function)
-	 thing)
-	(t
-	 `',thing)))
-
-;;; Returns anything but a valsrc structure.
-(defun value-or-source (thing)
-  (if (valsrc-p thing)
-      (valsrc-value thing)
-      thing))
-
-(defun make-valsrc (value source)
-  (cond ((equal value source)
-	 source)
-	((and (listp value) (eq (car value) 'function))
-	 value)
-	(t
-	 (%make-valsrc :value value :source source))))
-
-;;; ----------------------------------------------------------------
-;;; A funstate holds the state of any arguments used in a disassembly
-;;; function.
-
-(defstruct (funstate (:conc-name funstate-) (:constructor %make-funstate))
-  (args nil :type list)
-  (arg-temps nil :type list)		; see below
-  )
-
-(defun make-funstate (args)
-  ;; give the args a position
-  (let ((i 0))
-    (dolist (arg args)
-      (setf (arg-position arg) i)
-      (incf i)))
-  (%make-funstate :args args))
-
-(defun arg-or-lose (name funstate)
-  (let ((arg (find name (funstate-args funstate) :key #'arg-name)))
-    (when (null arg)
-      (pd-error "Unknown argument ~s" name))
-    arg))
-
-(defun get-arg-temp (arg kind funstate)
-  (let ((this-arg-temps (assoc arg (funstate-arg-temps funstate))))
-    (if this-arg-temps
-	(let ((this-kind-temps
-	       (assoc (canonicalize-arg-form-kind kind)
-		      (cdr this-arg-temps))))
-	  (values (cadr this-kind-temps) (cddr this-kind-temps)))
-	(values nil nil))))
-
-(defun make-arg-temp-bindings (funstate)
-  ;; Everything is in reverse order, so we just use push, which results in
-  ;; everything being in the right order at the end.
-  (let ((bindings nil))
-    (dolist (ats (funstate-arg-temps funstate))
-      (dolist (atk (cdr ats))
-	(cond ((null (cadr atk)))
-	      ((atom (cadr atk))
-	       (push `(,(cadr atk) ,(cddr atk)) bindings))
-	      (t
-	       (mapc #'(lambda (var form)
-			 (push `(,var ,form) bindings))
-		     (cadr atk)
-		     (cddr atk))))))
-    bindings))
-
-(defun set-arg-temps (vars forms arg kind funstate)
-  (let ((this-arg-temps
-	 (or (assoc arg (funstate-arg-temps funstate))
-	     (car (push (cons arg nil) (funstate-arg-temps funstate)))))
-	(kind (canonicalize-arg-form-kind kind)))
-    (let ((this-kind-temps
-	   (or (assoc kind (cdr this-arg-temps))
-	       (car (push (cons kind nil) (cdr this-arg-temps))))))
-      (setf (cdr this-kind-temps) (cons vars forms)))))
-
-(defun gen-arg-forms (arg kind funstate)
-  (multiple-value-bind (vars forms)
-      (get-arg-temp arg kind funstate)
-    (when (null forms)
-      (multiple-value-bind (new-forms single-value-p)
-	  (funcall (find-arg-form-producer kind) arg funstate)
-	(setq forms new-forms)
-	(cond ((or single-value-p (atom forms))
-	       (unless (symbolp forms)
-		 (setq vars (gensym))))
-	      ((every #'symbolp forms)
-	       ;; just use the same as the forms
-	       (setq vars nil))
-	      (t
-	       (setq vars nil)
-	       (dotimes (i (length forms))
-		 (push (gensym) vars))))
-	(set-arg-temps vars forms arg kind funstate)))
-    (or vars forms)))
-
-(defun funstate-compatible-p (funstate args)
-  (every #'(lambda (this-arg-temps)
-	     (let* ((old-arg (car this-arg-temps))
-		    (new-arg (find (arg-name old-arg) args :key #'arg-name)))
-	       (and new-arg
-		    (every #'(lambda (this-kind-temps)
-			       (funcall (find-arg-form-checker
-					 (car this-kind-temps))
-					new-arg
-					old-arg))
-			   (cdr this-arg-temps)))))
-	 (funstate-arg-temps funstate)))
-
-(defun maybe-listify (forms)
-  (cond ((atom forms)
-	 forms)
-	((/= (length forms) 1)
-	 `(list ,@forms))
-	(t
-	 (car forms))))
-
-(defun arg-value-form (arg funstate
-		       &optional
-		       (kind :final)
-		       (allow-multiple-p (not (eq kind :numeric))))
-  (let ((forms (gen-arg-forms arg kind funstate)))
-    (when (and (not allow-multiple-p)
-	       (listp forms)
-	       (/= (length forms) 1))
-      (pd-error "~s must not have multiple values" arg))
-    (maybe-listify forms)))
-
-;;; ----------------------------------------------------------------
-;;; These are the kind of values we can compute for an argument, and
-;;; how to compute them.  The :checker functions make sure that a given
-;;; argument is compatible with another argument for a given use.
-
-(defvar *arg-form-kinds* nil)
-
-(defstruct arg-form-kind
-  (names nil :type list)
-  (producer (required-argument) :type function)
-  (checker (required-argument) :type function)
-  )
-
-(defun arg-form-kind-or-lose (kind)
-  (or (getf *arg-form-kinds* kind)
-      (pd-error "Unknown arg-form kind ~s" kind)))
-
-(defun find-arg-form-producer (kind)
-  (arg-form-kind-producer (arg-form-kind-or-lose kind)))
-(defun find-arg-form-checker (kind)
-  (arg-form-kind-checker (arg-form-kind-or-lose kind)))
-
-(defun canonicalize-arg-form-kind (kind)
-  (car (arg-form-kind-names (arg-form-kind-or-lose kind))))
-
-(defmacro def-arg-form-kind ((&rest names) &rest inits)
-  `(let ((kind (make-arg-form-kind :names ',names ,@inits)))
-     ,@(mapcar #'(lambda (name)
-		   `(setf (getf *arg-form-kinds* ',name) kind))
-	       names)))
-
-(def-arg-form-kind (:raw)
-  :producer #'(lambda (arg funstate)
-		(declare (ignore funstate))
-		(mapcar #'(lambda (bytespec)
-			    `(the (unsigned-byte ,(byte-size bytespec))
-				  (local-extract ',bytespec)))
-			(arg-fields arg)))
-  :checker #'(lambda (new-arg old-arg)
-	       (equal (arg-fields new-arg)
-		      (arg-fields old-arg))))
-
-(def-arg-form-kind (:sign-extended :unfiltered)
-  :producer #'(lambda (arg funstate)
-		(let ((raw-forms (gen-arg-forms arg :raw funstate)))
-		  (if (and (arg-sign-extend-p arg) (listp raw-forms))
-		      (mapcar #'(lambda (form field)
-				  `(the (signed-byte ,(byte-size field))
-					(sign-extend ,form
-						     ,(byte-size field))))
-			      raw-forms
-			      (arg-fields arg))
-		      raw-forms)))
-  :checker #'(lambda (new-arg old-arg)
-	       (equal (arg-sign-extend-p new-arg)
-		      (arg-sign-extend-p old-arg))))
-
-(defun valsrc-equal (f1 f2)
-  (if (null f1)
-      (null f2)
-      (equal (value-or-source f1)
-	     (value-or-source f2))))
-
-(def-arg-form-kind (:filtering)
-  :producer #'(lambda (arg funstate)
-		(let ((sign-extended-forms
-		       (gen-arg-forms arg :sign-extended funstate))
-		      (pf (arg-prefilter arg)))
-		  (if pf
-		      (values
-		       `(local-filter ,(maybe-listify sign-extended-forms)
-				      ,(source-form pf))
-		       t)
-		      (values sign-extended-forms nil))))
-  :checker #'(lambda (new-arg old-arg)
-	       (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg))))
-
-(def-arg-form-kind (:filtered :unadjusted)
-  :producer #'(lambda (arg funstate)
-		(let ((pf (arg-prefilter arg)))
-		  (if pf
-		      (values `(local-filtered-value ,(arg-position arg)) t)
-		      (gen-arg-forms arg :sign-extended funstate))))
-  :checker #'(lambda (new-arg old-arg)
-	       (let ((pf1 (arg-prefilter new-arg))
-		     (pf2 (arg-prefilter old-arg)))
-		 (if (null pf1)
-		     (null pf2)
-		     (= (arg-position new-arg)
-			(arg-position old-arg))))))
-
-(def-arg-form-kind (:adjusted :numeric :unlabelled)
-  :producer #'(lambda (arg funstate)
-		(let ((filtered-forms (gen-arg-forms arg :filtered funstate))
-		      (use-label (arg-use-label arg)))
-		  (if (and use-label (not (eq use-label t)))
-		      (list
-		       `(adjust-label ,(maybe-listify filtered-forms)
-				      ,(source-form use-label)))
-		      filtered-forms)))
-  :checker #'(lambda (new-arg old-arg)
-	       (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg))))
-
-(def-arg-form-kind (:labelled :final)
-  :producer #'(lambda (arg funstate)
-		(let ((adjusted-forms
-		       (gen-arg-forms arg :adjusted funstate))
-		      (use-label (arg-use-label arg)))
-		  (if use-label
-		      (let ((form (maybe-listify adjusted-forms)))
-			(if (and (not (eq use-label t))
-				 (not (atom adjusted-forms))
-				 (/= (Length adjusted-forms) 1))
-			    (pd-error
-			     "Cannot label a multiple-field argument ~
-			      unless using a function: ~s" arg)
-			    `((lookup-label ,form))))
-		      adjusted-forms)))
-  :checker #'(lambda (new-arg old-arg)
-	       (let ((lf1 (arg-use-label new-arg))
-		     (lf2 (arg-use-label old-arg)))
-		 (if (null lf1) (null lf2) t))))
-
-;;; This is a bogus kind that's just used to ensure that printers are
-;;; compatible...
-(def-arg-form-kind (:printed)
-  :producer #'(lambda (&rest noise)
-		(declare (ignore noise))
-		(pd-error "Bogus!  Can't use the :printed value of an arg!"))
-  :checker #'(lambda (new-arg old-arg)
-	       (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
-
-(defun remember-printer-use (arg funstate)
-  (set-arg-temps nil nil arg :printed funstate))
-
-;;; ----------------------------------------------------------------
-
-(defun compare-fields-form (val-form-1 val-form-2)
-  (flet ((listify-fields (fields)
-	   (cond ((symbolp fields) fields)
-		 ((every #'constantp fields) `',fields)
-		 (t `(list ,@fields)))))
-    (cond ((or (symbolp val-form-1) (symbolp val-form-2))
-	   `(equal ,(listify-fields val-form-1)
-		   ,(listify-fields val-form-2)))
-	  (t
-	   `(and ,@(mapcar #'(lambda (v1 v2) `(= ,v1 ,v2))
-			   val-form-1 val-form-2))))))
-
-(defun compile-test (subj test funstate)
-  (when (and (consp test) (symbolp (car test)) (not (keywordp (car test))))
-    (setf subj (car test)
-	  test (cdr test)))
-  (let ((key (if (consp test) (car test) test))
-	(body (if (consp test) (cdr test) nil)))
-    (cond ((null key)
-	   nil)
-	  ((eq key t)
-	   t)
-	  ((eq key :constant)
-	   (let* ((arg (arg-or-lose subj funstate))
-		  (fields (arg-fields arg))
-		  (consts body))
-	     (when (not (= (length fields) (length consts)))
-	       (pd-error "number of constants doesn't match number of fields ~
-			  in: (~s :constant~{ ~s~})"
-			 subj body))
-	     (compare-fields-form (gen-arg-forms arg :numeric funstate)
-				  consts)))
-	  ((eq key :positive)
-	   `(> ,(arg-value-form (arg-or-lose subj funstate) funstate :numeric)
-	       0))
-	  ((eq key :negative)
-	   `(< ,(arg-value-form (arg-or-lose subj funstate) funstate :numeric)
-	       0))
-	  ((eq key :same-as)
-	   (let ((arg1 (arg-or-lose subj funstate))
-		 (arg2 (arg-or-lose (car body) funstate)))
-	     (unless (and (= (length (arg-fields arg1))
-			     (length (arg-fields arg2)))
-			  (every #'(lambda (bs1 bs2)
-				     (= (byte-size bs1) (byte-size bs2)))
-				 (arg-fields arg1)
-				 (arg-fields arg2)))
-	       (pd-error "Can't compare differently sized fields: ~
-		          (~s :same-as ~s)" subj (car body)))
-	     (compare-fields-form (gen-arg-forms arg1 :numeric funstate)
-				  (gen-arg-forms arg2 :numeric funstate))))
-	  ((eq key :or)
-	   `(or ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate))
-			  body)))
-	  ((eq key :and)
-	   `(and ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate))
-			   body)))
-	  ((eq key :not)
-	   `(not ,(compile-test subj (car body) funstate)))
-	  ((and (consp key) (null body))
-	   (compile-test subj key funstate))
-	  (t
-	   (pd-error "Bogus test-form: ~s" test)))))
-
-;;; ----------------------------------------------------------------
-
-(defun find-first-field-name (tree)
-  "Returns the first non-keyword symbol in a depth-first search of TREE."
-  (cond ((null tree)
-	 nil)
-	((and (symbolp tree) (not (keywordp tree)))
-	 tree)
-	((atom tree)
-	 nil)
-	((eq (car tree) 'quote)
-	 nil)
-	(t
-	 (or (find-first-field-name (car tree))
-	     (find-first-field-name (cdr tree))))))
-
-(defun string-or-qsym-p (thing)
-  (or (stringp thing)
-      (and (consp thing)
-	   (eq (car thing) 'quote)
-	   (or (stringp (cadr thing))
-	       (symbolp (cadr thing))))))
-
-(defun strip-quote (thing)
-  (if (and (consp thing) (eq (car thing) 'quote))
-      (cadr thing)
-      thing))
-
-(defun compile-printer-list (sources funstate)
-  (unless (null sources)
-    ;; Coalesce adjacent symbols/strings, and convert to strings if possible,
-    ;; since they require less consing to write.
-    (do ((el (car sources) (car sources))
-	 (names nil (cons (strip-quote el) names)))
-	((not (string-or-qsym-p el))
-	 (when names
-	   ;; concatenate adjacent strings and symbols
-	   (let ((string
-		  (apply #'concatenate
-			 'string
-			 (mapcar #'string (nreverse names)))))
-	     (push (if (some #'alpha-char-p string)
-		       `',(make-symbol string) ; preserve casifying output
-		       string)
-		   sources))))
-      (pop sources))
-    (cons (compile-printer-body (car sources) funstate)
-	  (compile-printer-list (cdr sources) funstate))))
-
-(defun compile-print (arg-name funstate &optional printer)
-  (let* ((arg (arg-or-lose arg-name funstate))
-	 (printer (or printer (arg-printer arg)))
-	 (printer-val (value-or-source printer))
-	 (printer-src (source-form printer)))
-    (remember-printer-use arg funstate)
-    (cond ((stringp printer-val)
-	   `(local-format-arg ,(arg-value-form arg funstate) ,printer-val))
-	  ((vectorp printer-val)
-	   `(local-princ
-	     (aref ,printer-src
-		   ,(arg-value-form arg funstate :numeric))))
-	  ((or (functionp printer-val)
-	       (and (consp printer-val) (eq (car printer-val) 'function)))
-	   `(local-call-arg-printer ,(arg-value-form arg funstate)
-				    ,printer-src))
-	  ((or (null printer-val) (eq printer-val t))
-	   `(,(if (arg-use-label arg) 'local-princ16 'local-princ)
-	     ,(arg-value-form arg funstate)))
-	  (t
-	   (pd-error "Illegal printer: ~s" printer-src)))))
-
-(defun compile-printer-body (source funstate)
-  (cond ((null source)
-	 nil)
-	((eq source :name)
-	 `(local-print-name))
-	((eq source :tab)
-	 `(local-tab-to-arg-column))
-	((keywordp source)
-	 (pd-error "Unknown printer element: ~s" source))
-	((symbolp source)
-	 (compile-print source funstate))
-	((atom source)
-	 `(local-princ ',source))
-	((eq (car source) :using)
-	 (unless (or (stringp (cadr source))
-		     (and (listp (cadr source))
-			  (eq (caadr source) 'function)))
-	   (pd-error "First arg to :USING must be a string or #'function"))
-	 (compile-print (caddr source) funstate
-			(cons (eval (cadr source)) (cadr source))))
-	((eq (car source) :plus-integer)
-	 ;; prints the given field proceed with a + or a -
-	 (let ((form
-		(arg-value-form (arg-or-lose (cadr source) funstate)
-				funstate
-				:numeric)))
-	   `(progn
-	      (when (>= ,form 0)
-		(local-write-char #\+))
-	      (local-princ ,form))))
-	((eq (car source) 'quote)
-	 `(local-princ ,source))
-	((eq (car source) 'function)
-	 `(local-call-global-printer ,source))
-	((eq (car source) :cond)
-	 `(cond ,@(mapcar #'(lambda (clause)
-			      `(,(compile-test (find-first-field-name
-						(cdr clause))
-					       (car clause)
-					       funstate)
-				,@(compile-printer-list (cdr clause)
-							funstate)))
-			  (cdr source))))
-	;; :if, :unless, and :when are replaced by :cond during preprocessing
-	(t
-	 `(progn ,@(compile-printer-list source funstate)))))
-
-;;; ----------------------------------------------------------------
-;;; Note that these things are compiled with (speed 3) (safety 0) more
-;;; for the resulting size of the code than for actual speed (compiling
-;;; with space>speed usually increases the size of the code!)...
-
-(defun make-printer-defun (source funstate function-name)
-  (let ((printer-form (compile-printer-list source funstate))
-	(bindings (make-arg-temp-bindings funstate)))
-    `(defun ,function-name (chunk inst stream dstate)
-       (declare (type dchunk chunk)
-		(type instruction inst)
-		(type stream stream)
-		(type disassem-state dstate)
-		(optimize (speed 3) (safety 0) (debug 0)))
-       (macrolet ((local-format-arg (arg fmt)
-		    `(funcall (formatter ,fmt) stream ,arg)))
-	 (flet ((local-tab-to-arg-column ()
-		  (tab (dstate-argument-column dstate) stream))
-		(local-print-name ()
-		  (princ (inst-print-name inst) stream))
-		(local-write-char (ch)
-		  (write-char ch stream))
-		(local-princ (thing)
-		  (princ thing stream))
-		(local-princ16 (thing)
-		  (princ16 thing stream))
-		(local-call-arg-printer (arg printer)
-		  (funcall printer arg stream dstate))
-		(local-call-global-printer (fun)
-		  (funcall fun chunk inst stream dstate))
-		(local-filtered-value (offset)
-		  (declare (type filtered-value-index offset))
-		  (aref (dstate-filtered-values dstate) offset))
-		(local-extract (bytespec)
-		  (dchunk-extract chunk bytespec))
-		(lookup-label (lab)
-		  (or (gethash lab (dstate-label-hash dstate))
-		      lab))
-		(adjust-label (val adjust-fun)
-		  (funcall adjust-fun val dstate)))
-	   (declare (ignorable #'local-tab-to-arg-column
-			       #'local-print-name
-			       #'local-princ #'local-princ16
-			       #'local-write-char
-			       #'local-call-arg-printer
-			       #'local-call-global-printer
-			       #'local-extract
-			       #'local-filtered-value
-			       #'lookup-label #'adjust-label)
-		    (inline local-tab-to-arg-column
-			    local-princ local-princ16
-			    local-call-arg-printer local-call-global-printer
-			    local-filtered-value local-extract
-			    lookup-label adjust-label))
-	   (let* ,bindings
-	     ,@printer-form))))))
-
-;;; ----------------------------------------------------------------
-
-(defun all-arg-refs-relevent-p (printer args)
-  (cond ((or (null printer) (keywordp printer) (eq printer t))
-	 t)
-	((symbolp printer)
-	 (find printer args :key #'arg-name))
-	((listp printer)
-	 (every #'(lambda (x) (all-arg-refs-relevent-p x args))
-		printer))
-	(t t)))
-
-(defun pick-printer-choice (choices args)
-  (dolist (choice choices
-	   (pd-error "No suitable choice found in ~s" choices))
-    (when (all-arg-refs-relevent-p choice args)
-      (return choice))))
-
-(defun preprocess-chooses (printer args)
-  (cond ((atom printer)
-	 printer)
-	((eq (car printer) :choose)
-	 (pick-printer-choice (cdr printer) args))
-	(t
-	 (sharing-mapcar #'(lambda (sub) (preprocess-chooses sub args))
-			 printer))))
-
-;;; ----------------------------------------------------------------
-
-(defun preprocess-test (subj form args)
-  (multiple-value-bind (subj test)
-      (if (and (consp form) (symbolp (car form)) (not (keywordp (car form))))
-	  (values (car form) (cdr form))
-	  (values subj form))
-    (let ((key (if (consp test) (car test) test))
-	  (body (if (consp test) (cdr test) nil)))
-      (case key
-	(:constant
-	 (if (null body)
-	     ;; if no supplied constant values, just any constant is ok, just
-	     ;; see if there's some constant value in the arg.
-	     (not
-	      (null
-	       (arg-value
-		(or (find subj args :key #'arg-name)
-		    (pd-error "Unknown argument ~s" subj)))))
-	     ;; otherwise, defer to run-time
-	     form))
-	((:or :and :not)
-	 (sharing-cons
-	  form
-	  subj
-	  (sharing-cons
-	   test
-	   key
-	   (sharing-mapcar
-	    #'(lambda (sub-test)
-		(preprocess-test subj sub-test args))
-	    body))))
-	(t form)))))
-
-(defun preprocess-conditionals (printer args)
-  (if (atom printer)
-      printer
-      (case (car printer)
-	(:unless
-	 (preprocess-conditionals
-	  `(:cond ((:not ,(nth 1 printer)) ,@(nthcdr 2 printer)))
-	  args))
-	(:when
-	 (preprocess-conditionals `(:cond (,(cdr printer))) args))
-	(:if
-	 (preprocess-conditionals
-	  `(:cond (,(nth 1 printer) ,(nth 2 printer))
-		  (t ,(nth 3 printer)))
-	  args))
-	(:cond
-	 (sharing-cons
-	  printer
-	  :cond
-	  (sharing-mapcar
-	   #'(lambda (clause)
-	       (let ((filtered-body
-		      (sharing-mapcar
-		       #'(lambda (sub-printer)
-			   (preprocess-conditionals sub-printer args))
-		       (cdr clause))))
-		 (sharing-cons
-		  clause
-		  (preprocess-test (find-first-field-name filtered-body)
-				   (car clause)
-				   args)
-		  filtered-body)))
-	   (cdr printer))))
-	(quote printer)
-	(t
-	 (sharing-mapcar
-	  #'(lambda (sub-printer)
-	      (preprocess-conditionals sub-printer args))
-	  printer)))))
-
-(defun preprocess-printer (printer args)
-  "Returns a version of the disassembly-template PRINTER with compile-time
-  tests (e.g. :constant without a value), and any :CHOOSE operators resolved
-  properly for the args ARGS.  (:CHOOSE Sub*) simply returns the first Sub in
-  which every field reference refers to a valid arg."
-  (preprocess-conditionals (preprocess-chooses printer args) args))
-
-;;; ----------------------------------------------------------------
-
-(defstruct (cached-function (:conc-name cached-fun-))
-  (funstate nil :type (or null funstate))
-  (constraint nil :type list)
-  (name nil :type (or null symbol)))
-
-(defun find-cached-function (cached-funs args constraint)
-  (dolist (cached-fun cached-funs nil)
-    (let ((funstate (cached-fun-funstate cached-fun)))
-      (when (and (equal constraint (cached-fun-constraint cached-fun))
-		 (or (null funstate)
-		     (funstate-compatible-p funstate args)))
-	(return cached-fun)))))
-
-(defmacro with-cached-function ((name-var funstate-var cache cache-slot
-					  args &key constraint prefix)
-				&body defun-maker-forms)
-  (let ((cache-var (gensym))
-	(constraint-var (gensym)))
-    `(let* ((,constraint-var ,constraint)
-	    (,cache-var (find-cached-function (,cache-slot ,cache)
-					      ,args ,constraint-var)))
-       (cond (,cache-var
-	      #+nil
-	      (Format t "~&; Using cached function ~s~%"
-		      (cached-fun-name ,cache-var))
-	      (values (cached-fun-name ,cache-var) nil))
-	     (t
-	      (let* ((,name-var (gensym ,prefix))
-		     (,funstate-var (make-funstate ,args))
-		     (,cache-var
-		      (make-cached-function :name ,name-var
-					    :funstate ,funstate-var
-					    :constraint ,constraint-var)))
-		#+nil
-		(format t "~&; Making new function ~s~%"
-			(cached-fun-name ,cache-var))
-		(values ,name-var
-			`(progn
-			   ,(progn ,@defun-maker-forms)
-			   (eval-when (compile eval)
-			     (push ,,cache-var
-				   (,',cache-slot ',,cache)))))))))))
-
-;;; ----------------------------------------------------------------
-
-(defstruct function-cache
-  (printers nil :type list)
-  (labellers nil :type list)
-  (prefilters nil :type list))
-
-(defun find-printer-fun (printer-source args cache)
-  (if (null printer-source)
-      (values nil nil)
-      (let ((printer-source (preprocess-printer printer-source args)))
-	(with-cached-function
-	    (name funstate cache function-cache-printers args
-		  :constraint printer-source
-		  :prefix "PRINTER")
-	  (make-printer-defun printer-source funstate name)))))
-
-(defun find-labeller-fun (args cache)
-  (let ((labelled-fields
-	 (mapcar #'arg-name (remove-if-not #'arg-use-label args))))
-    (if (null labelled-fields)
-	(values nil nil)
-	(with-cached-function
-	    (name funstate cache function-cache-labellers args
-	     :prefix "LABELLER"
-	     :constraint labelled-fields)
-	  (let ((labels-form 'labels))
-	    (dolist (arg args)
-	      (when (arg-use-label arg)
-		(setf labels-form
-		      `(let ((labels ,labels-form)
-			     (addr
-			      ,(arg-value-form arg funstate :adjusted nil)))
-			 (if (assoc addr labels :test #'eq)
-			     labels
-			     (cons (cons addr nil) labels))))))
-	    `(defun ,name (chunk labels dstate)
-	       (declare (type list labels)
-			(type dchunk chunk)
-			(type disassem-state dstate)
-			(optimize (speed 3) (safety 0) (debug 0)))
-	       (flet ((local-filtered-value (offset)
-			(declare (type filtered-value-index offset))
-			(aref (dstate-filtered-values dstate) offset))
-		      (local-extract (bytespec)
-			(dchunk-extract chunk bytespec))
-		      (adjust-label (val adjust-fun)
-			(funcall adjust-fun val dstate)))
-		 (declare (ignorable #'local-filtered-value #'local-extract
-				     #'adjust-label)
-			  (inline local-filtered-value local-extract
-				  adjust-label))
-		 (let* ,(make-arg-temp-bindings funstate)
-		   ,labels-form))))))))
-
-(defun find-prefilter-fun (args cache)
-  (let ((filtered-args
-	 (mapcar #'arg-name (remove-if-not #'arg-prefilter args))))
-    (if (null filtered-args)
-	(values nil nil)
-	(with-cached-function
-	    (name funstate cache function-cache-prefilters args
-	     :prefix "PREFILTER"
-	     :constraint filtered-args)
-	  (collect ((forms))
-	    (dolist (arg args)
-	      (let ((pf (arg-prefilter arg)))
-		(when pf
-		  (forms
-		   `(setf (local-filtered-value ,(arg-position arg))
-			  ,(maybe-listify
-			    (gen-arg-forms arg :filtering funstate)))))
-		))
-	    `(defun ,name (chunk dstate)
-	       (declare (type dchunk chunk)
-			(type disassem-state dstate)
-			(optimize (speed 3) (safety 0) (debug 0)))
-		 (flet (((setf local-filtered-value) (value offset)
-			  (declare (type filtered-value-index offset))
-			  (setf (aref (dstate-filtered-values dstate) offset)
-				value))
-			(local-filter (value filter)
-			  (funcall filter value dstate))
-			(local-extract (bytespec)
-			  (dchunk-extract chunk bytespec)))
-		   (declare (ignorable #'local-filter #'local-extract)
-			    (inline (setf local-filtered-value)
-				    local-filter local-extract))
-		   ;; use them for side-effects only
-		   (let* ,(make-arg-temp-bindings funstate)
-		     ,@(forms)))))))))
-
-;;; ----------------------------------------------------------------
-
-(defun set-arg-from-type (arg type-name table)
-  (let ((type-arg (find type-name table :key #'arg-name)))
-    (when (null type-arg)
-      (pd-error "Unknown argument type: ~s" type-name))
-    (setf (arg-printer arg) (arg-printer type-arg))
-    (setf (arg-prefilter arg) (arg-prefilter type-arg))
-    (setf (arg-sign-extend-p arg) (arg-sign-extend-p type-arg))
-    (setf (arg-use-label arg) (arg-use-label type-arg))))
-
-(defun modify-or-add-arg (arg-name
-			  args
-			  type-table
-			  &key
-			  (value nil value-p)
-			  (type nil type-p)
-			  (prefilter nil prefilter-p)
-			  (printer nil printer-p)
-			  (sign-extend nil sign-extend-p)
-			  (use-label nil use-label-p)
-			  (field nil field-p)
-			  (fields nil fields-p)
-			  format-length)
-  (let* ((arg-pos (position arg-name args :key #'arg-name))
-	 (arg
-	  (if (null arg-pos)
-	      (let ((arg (make-argument :name arg-name)))
-		(if (null args)
-		    (setf args (list arg))
-		    (push arg (cdr (last args))))
-		arg)
-	      (setf (nth arg-pos args) (copy-argument (nth arg-pos args))))))
-    (when (and field-p (not fields-p))
-      (setf fields (list field))
-      (setf fields-p t))
-    (when type-p
-      (set-arg-from-type arg type type-table))
-    (when value-p
-      (setf (arg-value arg) value))
-    (when prefilter-p
-      (setf (arg-prefilter arg) prefilter))
-    (when sign-extend-p
-      (setf (arg-sign-extend-p arg) sign-extend))
-    (when printer-p
-      (setf (arg-printer arg) printer))
-    (when use-label-p
-      (setf (arg-use-label arg) use-label))
-    (when fields-p
-      (when (null format-length)
-	(error
-	 "~@<In arg ~s:  ~3i~:_~
-          Can't specify fields except using DEFINE-INSTRUCTION-FORMAT.~:>"
-	 arg-name))
-      (setf (arg-fields arg)
-	    (mapcar #'(lambda (bytespec)
-			(when (> (+ (byte-position bytespec)
-				    (byte-size bytespec))
-				 format-length)
-			  (error "~@<In arg ~s:  ~3i~:_~
-				     Field ~s doesn't fit in an ~
-				     instruction-format ~d bits wide.~:>"
-				 arg-name
-				 bytespec
-				 format-length))
-			(correct-dchunk-bytespec-for-endianness
-			 bytespec
-			 format-length
-			 (c:backend-byte-order c:*target-backend*)))
-		    fields))
-      )
-    args))
-
-;;; ----------------------------------------------------------------
-;;; Compile time info that we stash in the package of the machine backend
-
-(defun format-table-name ()
-  (intern "*DISASSEMBLER-INSTRUCTION-FORMATS*"))
-(defun arg-type-table-name ()
-  (intern "*DISASSEMBLER-ARG-TYPES*"))
-(defun function-cache-name ()
-  (intern "*DISASSEMBLER-CACHED-FUNCTIONS*"))
-
-;;; ----------------------------------------------------------------
-
-(defparameter *arg-function-params*
-  '((:printer . (value stream dstate))
-    (:use-label . (value dstate))
-    (:prefilter . (value dstate))))
-
-;;; detect things that obviously don't need wrapping, like variable-refs &
-;;; #'function
-(defun doesnt-need-wrapping-p (form)
-  (or (symbolp form)
-      (and (listp form)
-	   (eq (car form) 'function)
-	   (symbolp (cadr form)))))
-
-(defun make-wrapper (form arg-name funargs prefix)
-  (if (and (listp form)
-	   (eq (car form) 'function))
-      ;; a function def
-      (let ((wrapper-name (symbolicate prefix "-" arg-name "-WRAPPER"))
-	    (wrapper-args nil))
-	(dotimes (i (length funargs))
-	  (push (gensym) wrapper-args))
-	(values `#',wrapper-name
-		`(defun ,wrapper-name ,wrapper-args
-		   (funcall ,form ,@wrapper-args))))
-      ;; something else
-      (let ((wrapper-name (symbolicate "*" prefix "-" arg-name "-WRAPPER*")))
-	(values wrapper-name `(defparameter ,wrapper-name ,form)))))
-
-(defun munge-fun-refs (params evalp &optional wrap-defs-p (prefix ""))
-  (let ((params (copy-list params)))
-    (do ((tail params (cdr tail))
-	 (wrapper-defs nil))
-	((null tail)
-	 (values params (nreverse wrapper-defs)))
-      (let ((fun-arg (assoc (car tail) *arg-function-params*)))
-	(when fun-arg
-	  (let* ((fun-form (cadr tail))
-		 (quoted-fun-form `',fun-form))
-	    (when (and wrap-defs-p (not (doesnt-need-wrapping-p fun-form)))
-	      (multiple-value-bind (access-form wrapper-def-form)
-		  (make-wrapper fun-form (car fun-arg) (cdr fun-arg) prefix)
-		(setf quoted-fun-form `',access-form)
-		(push wrapper-def-form wrapper-defs)))
-	    (if evalp
-		(setf (cadr tail)
-		      `(make-valsrc ,fun-form ,quoted-fun-form))
-		(setf (cadr tail)
-		      fun-form))))))))
-
-;;; ----------------------------------------------------------------
-
-(defun gen-preamble-form (args)
-  "Generate a form to specify global disassembler params.  See the
-  documentation for SET-DISASSEM-PARAMS for more info."
-  (destructuring-bind
-	(&key instruction-alignment
-	      address-size
-	      (opcode-column-width nil opcode-column-width-p))
-      args
-    `(progn
-       (eval-when (compile eval)
-	 ;; these are not in the params because they only exist at compile time
-	 (defparameter ,(format-table-name) (make-hash-table))
-	 (defparameter ,(arg-type-table-name) nil)
-	 (defparameter ,(function-cache-name) (make-function-cache)))
-       (let ((params
-	      (or (c:backend-disassem-params c:*target-backend*)
-		  (setf (c:backend-disassem-params c:*target-backend*)
-			(make-params :backend c::*target-backend*)))))
-	 (declare (ignorable params))
-	 ,(when instruction-alignment
-	    `(setf (params-instruction-alignment params)
-		   (bits-to-bytes ,instruction-alignment)))
-	 ,(when address-size
-	    `(setf (params-location-column-width params)
-		   (* 2 ,address-size)))
-	 ,(when opcode-column-width-p
-	    `(setf (params-opcode-column-width params) ,opcode-column-width))
-	 'disassem-params))))
-
-(defun gen-clear-info-form ()
-  `(eval-when (compile eval)
-     (setf ,(format-table-name) nil)
-     (setf ,(arg-type-table-name) nil)))
-
-(defun update-args-form (var name-form descrip-forms evalp
-			     &optional format-length-form)
-  `(setf ,var
-	 ,(if evalp
-	      `(modify-or-add-arg ,name-form
-				  ,var
-				  ,(arg-type-table-name)
-				  ,@(and format-length-form
-					 `(:format-length
-					    ,format-length-form))
-				  ,@descrip-forms)
-	      `(apply #'modify-or-add-arg
-		      ,name-form
-		      ,var
-		      ,(arg-type-table-name);
-		      ,@(and format-length-form
-			     `(:format-length ,format-length-form))
-		      ',descrip-forms))))
-
-(defun gen-arg-type-def-form (name args &optional (evalp t))
-  "Generate a form to define a disassembler argument type.  See
-  DEFINE-ARGUMENT-TYPE for more info."
-  (multiple-value-bind (args wrapper-defs)
-      (munge-fun-refs args evalp t name)
-    `(progn
-       ,@wrapper-defs
-       (eval-when (compile eval)
-	 ,(update-args-form (arg-type-table-name) `',name args evalp))
-       ',name)))
-
-(defun maybe-quote (evalp form)
-  (if (or evalp (self-evaluating-p form)) form `',form))
-
-(defun maybe-quote-list (evalp list)
-  (if evalp
-      list
-      (mapcar #'(lambda (el) (maybe-quote nil el)) list)))
-
-(defun gen-arg-access-macro-def-form (arg args format-name)
-  (let* ((funstate (make-funstate args))
-	 (arg-val-form (arg-value-form arg funstate :adjusted))
-	 (bindings (make-arg-temp-bindings funstate)))
-    `(defmacro ,(symbolicate format-name "-" (arg-name arg)) (chunk dstate)
-       `(let ((chunk ,chunk) (dstate ,dstate))
-	  (declare (ignorable chunk dstate))
-	  (flet ((local-filtered-value (offset)
-		   (declare (type filtered-value-index offset))
-		   (aref (dstate-filtered-values dstate) offset))
-		 (local-extract (bytespec)
-		   (dchunk-extract chunk bytespec)))
-	    (declare (ignorable #'local-filtered-value #'local-extract)
-		     (inline local-filtered-value local-extract))
-	    (let* ,',bindings
-	      ,',arg-val-form))))))
-
-(defun gen-format-def-form (header descrips &optional (evalp t))
-  "Generate a form to define an instruction format.  See
-  DEFINE-INSTRUCTION-FORMAT for more info."
-  (when (atom header)
-    (setf header (list header)))
-  (destructuring-bind (name length &key default-printer include)
-      header
-    (let ((args-var (gensym))
-	  (length-var (gensym))
-	  (all-wrapper-defs nil)
-	  (arg-count 0))
-      (collect ((arg-def-forms))
-	(dolist (descrip descrips)
-	  (let ((name (pop descrip))) 
-	    (multiple-value-bind (descrip wrapper-defs)
-		(munge-fun-refs
-		 descrip evalp t (format nil "~:@(~a~)-~d" name arg-count))
-	      (arg-def-forms
-	       (update-args-form args-var `',name descrip evalp length-var))
-	      (setf all-wrapper-defs
-		    (nconc wrapper-defs all-wrapper-defs)))
-	    (incf arg-count)))
-	`(progn
-	   ,@all-wrapper-defs
-	   (eval-when (compile eval)
-	     (let ((,length-var ,length)
-		   (,args-var
-		    ,(and include
-			  `(copy-list
-			    (format-args
-			     (format-or-lose ,include
-					     ,(format-table-name)))))))
-	       ,@(arg-def-forms)
-	       (setf (gethash ',name ,(format-table-name))
-		     (make-instruction-format
-		      :name ',name
-		      :length (bits-to-bytes ,length-var)
-		      :default-printer ,(maybe-quote evalp default-printer)
-		      :args ,args-var))
-	       (eval
-		`(progn
-		   ,@(mapcar #'(lambda (arg)
-				 (when (arg-fields arg)
-				   (gen-arg-access-macro-def-form
-				    arg ,args-var ',name)))
-			     ,args-var)))
-	       )))))))
-
-;;; ----------------------------------------------------------------
-
-(defun compute-mask-id (args)
-  (let ((mask dchunk-zero)
-	(id dchunk-zero))
-    (dolist (arg args (values mask id))
-      (let ((av (arg-value arg)))
-	(when av
-	  (do ((fields (arg-fields arg) (cdr fields))
-	       (values (if (atom av) (list av) av) (cdr values)))
-	      ((null fields))
-	    (let ((field-mask (dchunk-make-mask (car fields))))
-	      (when (/= (dchunk-and mask field-mask) dchunk-zero)
-		(pd-error "Field ~s in arg ~s overlaps some other field"
-			  (car fields)
-			  (arg-name arg)))
-	      (dchunk-insertf id (car fields) (car values))
-	      (dchunk-orf mask field-mask))))))))
-
-(defun install-inst-flavors (name flavors)
-  (setf (gethash name
-		 (params-instructions
-		  (c:backend-disassem-params c:*target-backend*)))
-	flavors))
-			  
-(defun format-or-lose (name table)
-  (or (gethash name table)
-      (pd-error "Unknown instruction format ~s" name)))
-
-(defun filter-overrides (overrides evalp)
-  (mapcar #'(lambda (override)
-	      (list* (car override) (cadr override)
-		     (munge-fun-refs (cddr override) evalp)))
-	  overrides))
-
-(defun gen-args-def-form (overrides format-form &optional (evalp t))
-  (let ((args-var (gensym)))
-    `(let ((,args-var (copy-list (format-args ,format-form))))
-       ,@(mapcar #'(lambda (override)
-		     (update-args-form args-var
-				       `',(car override)
-				       (and (cdr override)
-					    (cons :value (cdr override)))
-				       evalp))
-		 overrides)
-       ,args-var)))
-
-(defun gen-printer-def-forms-def-form (name def &optional (evalp t))
-  (destructuring-bind (format-name (&rest field-defs)
-				   &optional (printer-form :default)
-				   &key
-				   ((:print-name print-name-form) `',name)
-				   control)
-      def
-    (let ((format-var (gensym))
-	  (field-defs (filter-overrides field-defs evalp)))
-      `(let* ((*current-instruction-flavor* ',(cons name format-name))
-	      (,format-var (format-or-lose ',format-name ,(format-table-name)))
-	      (args ,(gen-args-def-form field-defs format-var evalp))
-	      (funcache ,(function-cache-name)))
-	 (multiple-value-bind (printer-fun printer-defun)
-	     (find-printer-fun ,(if (eq printer-form :default)
-				     `(format-default-printer ,format-var)
-				     (maybe-quote evalp printer-form))
-			       args funcache)
-	   (multiple-value-bind (labeller-fun labeller-defun)
-	       (find-labeller-fun args funcache)
-	     (multiple-value-bind (prefilter-fun prefilter-defun)
-		 (find-prefilter-fun args funcache)
-	       (multiple-value-bind (mask id)
-		   (compute-mask-id args)
-		 (values
-		  `(make-instruction ',',name
-				     ',',format-name
-				     ,',print-name-form
-				     ,(format-length ,format-var)
-				     ,mask
-				     ,id
-				     ,(and printer-fun `#',printer-fun)
-				     ,(and labeller-fun `#',labeller-fun)
-				     ,(and prefilter-fun `#',prefilter-fun)
-				     ,',control)
-		  `(progn
-		     ,@(and printer-defun (list printer-defun))
-		     ,@(and labeller-defun (list labeller-defun))
-		     ,@(and prefilter-defun (list prefilter-defun))))
-		 ))))))))
-
-
-;;; ----------------------------------------------------------------
-;;; combining instructions where one specializes another
-
-(defun inst-specializes-p (special general)
-  "Returns non-NIL if the instruction SPECIAL is a more specific version of
-  GENERAL (i.e., the same instruction, but with more constraints)."
-  (declare (type instruction special general))
-  (let ((smask (inst-mask special))
-	(gmask (inst-mask general)))
-    (and (dchunk= (inst-id general)
-		  (dchunk-and (inst-id special) gmask))
-	 (dchunk-strict-superset-p smask gmask))))
-
-;;; a bit arbitrary, but should work ok...
-(defun specializer-rank (inst)
-  "Returns an integer corresponding to the specifivity of the instruction INST."
-  (declare (type instruction inst))
-  (* (dchunk-count-bits (inst-mask inst)) 4))
-
-(defun order-specializers (insts)
-  "Order the list of instructions INSTS with more specific (more constant
-  bits, or same-as argument constains) ones first.  Returns the ordered list."
-  (declare (type list insts))
-  (sort insts
-	#'(lambda (i1 i2)
-	    (> (specializer-rank i1) (specializer-rank i2)))))
-
-(defun specialization-error (insts)
-  (error "Instructions either aren't related or conflict in some way:~% ~s" insts))
-
-(defun try-specializing (insts)
-  "Given a list of instructions INSTS, Sees if one of these instructions is a
-  more general form of all the others, in which case they are put into its
-  specializers list, and it is returned.  Otherwise an error is signaled."
-  (declare (type list insts))
-  (let ((masters (copy-list insts)))
-    (dolist (possible-master insts)
-      (dolist (possible-specializer insts)
-	(unless (or (eq possible-specializer possible-master)
-		    (inst-specializes-p possible-specializer possible-master))
-	  (setf masters (delete possible-master masters))
-	  (return)			; exit the inner loop
-	  )))
-    (cond ((null masters)
-	   (specialization-error insts))
-	  ((cdr masters)
-	   (error "Multiple specializing masters: ~s" masters))
-	  (t
-	   (let ((master (car masters)))
-	     (setf (inst-specializers master)
-		   (order-specializers (remove master insts)))
-	     master)))))
-
-;;; ----------------------------------------------------------------
-;;; choosing an instruction
-
-(declaim (inline inst-matches-p choose-inst-specialization))
-
-(defun inst-matches-p (inst chunk)
-  "Returns non-NIL if all constant-bits in INST match CHUNK."
-  (declare (type instruction inst)
-	   (type dchunk chunk))
-  (dchunk= (dchunk-and (inst-mask inst) chunk) (inst-id inst)))
-
-(defun choose-inst-specialization (inst chunk)
-  "Given an instruction object, INST, and a bit-pattern, CHUNK, picks the
-  most specific instruction on INST's specializer list who's constraints are
-  met by CHUNK.  If none do, then INST is returned."
-  (declare (type instruction inst)
-	   (type dchunk chunk))
-  (or (dolist (spec (inst-specializers inst) nil)
-	(declare (type instruction spec))
-	(when (inst-matches-p spec chunk)
-	  (return spec)))
-      inst))
-
-;;; ----------------------------------------------------------------
-;;; an instruction space holds all known machine instructions in a form that
-;;; can be easily searched
-
-(defstruct (inst-space (:conc-name ispace-) (:print-function %print-ispace))
-  (valid-mask dchunk-zero :type dchunk)	; applies to *children*
-  (choices nil :type list)
-  )
-
-(defun %print-ispace (ispace stream level)
-  (declare (ignore level))
-  (print-unreadable-object (ispace stream :type t :identity t)))
-
-(defstruct (inst-space-choice (:conc-name ischoice-))
-  (common-id dchunk-zero :type dchunk)	; applies to *parent's* mask
-  (subspace (required-argument) :type (or inst-space instruction))
-  )
-
-;;; ----------------------------------------------------------------
-;;; searching for an instruction in instruction space
-
-(defun find-inst (chunk inst-space)
-  "Returns the instruction object within INST-SPACE corresponding to the
-  bit-pattern CHUNK, or NIL if there isn't one."
-  (declare (type dchunk chunk)
-	   (type (or null inst-space instruction) inst-space))
-  (etypecase inst-space
-    (null nil)
-    (instruction
-     (if (inst-matches-p inst-space chunk)
-	 (choose-inst-specialization inst-space chunk)
-	 nil))
-    (inst-space
-     (let* ((mask (ispace-valid-mask inst-space))
-	    (id (dchunk-and mask chunk)))
-       (declare (type dchunk id mask))
-       (dolist (choice (ispace-choices inst-space))
-	 (declare (type inst-space-choice choice))
-	 (when (dchunk= id (ischoice-common-id choice))
-	   (return (find-inst chunk (ischoice-subspace choice)))))))))
-
-;;; ----------------------------------------------------------------
-;;; building the instruction space
-
-(defun build-inst-space (insts &optional (initial-mask dchunk-one))
-  "Returns an instruction-space object corresponding to the list of
-  instructions INSTS.  If the optional parameter INITIAL-MASK is supplied, only
-  bits it has set are used."
-  ;; This is done by finding any set of bits that's common to
-  ;; all instructions, building an instruction-space node that selects on those
-  ;; bits, and recursively handle sets of instructions with a common value for
-  ;; these bits (which, since there should be fewer instructions than in INSTS,
-  ;; should have some additional set of bits to select on, etc).  If there
-  ;; are no common bits, or all instructions have the same value within those
-  ;; bits, TRY-SPECIALIZING is called, which handles the cases of many
-  ;; variations on a single instruction.
-  (declare (type list insts)
-	   (type dchunk initial-mask))
-  (cond ((null insts)
-	 nil)
-	((null (cdr insts))
-	 (car insts))
-	(t
-	 (let ((vmask (dchunk-copy initial-mask)))
-	   (dolist (inst insts)
-	     (dchunk-andf vmask (inst-mask inst)))
-	   (if (dchunk-zerop vmask)
-	       (try-specializing insts)
-	       (let ((buckets nil))
-		 (dolist (inst insts)
-		   (let* ((common-id (dchunk-and (inst-id inst) vmask))
-			  (bucket (assoc common-id buckets :test #'dchunk=)))
-		     (cond ((null bucket)
-			    (push (list common-id inst) buckets))
-			   (t
-			    (push inst (cdr bucket))))))
-		 (let ((submask (dchunk-clear initial-mask vmask)))
-		   (if (= (length buckets) 1)
-		       (try-specializing insts)
-		       (make-inst-space
-			:valid-mask vmask
-			:choices (mapcar #'(lambda (bucket)
-					     (make-inst-space-choice
-					      :subspace (build-inst-space
-							 (cdr bucket)
-							 submask)
-					      :common-id (car bucket)))
-					 buckets))))))))))
-
-;;; ----------------------------------------------------------------
-;;; an inst-space printer for debugging purposes
-
-(defun print-masked-binary (num mask word-size &optional (show word-size))
-  (do ((bit (1- word-size) (1- bit)))
-      ((< bit 0))
-    (write-char (cond ((logbitp bit mask)
-		       (if (logbitp bit num) #\1 #\0))
-		      ((< bit show) #\x)
-		      (t #\space)))))
-
-(defun print-inst-bits (inst)
-  (print-masked-binary (inst-id inst)
-		       (inst-mask inst)
-		       dchunk-bits
-		       (bytes-to-bits (inst-length inst))))
-
-(defun print-inst-space (inst-space &optional (indent 0))
-  "Prints a nicely formatted version of INST-SPACE."
-  (etypecase inst-space
-    (null)
-    (instruction
-     (format t "~vt[~a(~a)~40t" indent
-	     (inst-name inst-space)
-	     (inst-format-name inst-space))
-     (print-inst-bits inst-space)
-     (dolist (inst (inst-specializers inst-space))
-       (format t "~%~vt:~a~40t" indent (inst-name inst))
-       (print-inst-bits inst))
-     (write-char #\])
-     (terpri))
-    (inst-space
-     (format t "~vt---- ~8,'0x ----~%"
-	     indent
-	     (ispace-valid-mask inst-space))
-     (map nil
-	  #'(lambda (choice)
-	      (format t "~vt~8,'0x ==>~%"
-		      (+ 2 indent)
-		      (ischoice-common-id choice))
-	      (print-inst-space (ischoice-subspace choice)
-				(+ 4 indent)))
-	  (ispace-choices inst-space)))))
-
-;;;; ----------------------------------------------------------------
-;;;; the actual disassembly part
-;;;; ----------------------------------------------------------------
-
-;;; Code object layout:
-;;;	header-word
-;;;	code-size (starting from first inst, in words)
-;;;	entry-points (points to first function header)
-;;;	debug-info
-;;;	trace-table-offset (starting from first inst, in bytes)
-;;;	constant1
-;;;	constant2
-;;;	...
-;;;	<padding to dual-word boundry>
-;;;	start of instructions
-;;;	...
-;;;	function-headers and lra's buried in here randomly
-;;;	...
-;;;	start of trace-table
-;;;	<padding to dual-word boundry>
-;;;
-;;; Function header layout (dual word aligned):
-;;;	header-word
-;;;	self pointer
-;;;	next pointer (next function header)
-;;;	name
-;;;	arglist
-;;;	type
-;;;
-;;; LRA layout (dual word aligned):
-;;;	header-word
-
-(declaim (inline words-to-bytes bytes-to-words))
-
-(eval-when (eval load compile)		; used in a defconstant
-  (defun words-to-bytes (num)
-    "Converts a word-offset NUM to a byte-offset."
-    (declare (type offset num))
-    (ash num vm:word-shift))
-  )
-
-(defun bytes-to-words (num)
-  "Converts a byte-offset NUM to a word-offset."
-  (declare (type offset num))
-  (ash num (- vm:word-shift)))
-
-(defconstant lra-size (words-to-bytes 1))
-
-;;; ----------------------------------------------------------------
-;;;
-
-(defstruct offs-hook
-  (offset 0 :type offset)
-  (function (required-argument) :type function)
-  (before-address nil :type (member t nil)))
-
-(defstruct (segment (:conc-name seg-)
-		    (:print-function %print-segment)
-		    (:constructor %make-segment))
-  (sap-maker (required-argument) :type (function () system:system-area-pointer))
-  (length 0 :type length)
-  (virtual-location 0 :type address)
-  (storage-info nil :type (or null storage-info))
-  (code nil :type (or null kernel:code-component))
-  (hooks nil :type list)
-  )
-
-(defun %print-segment (seg stream level)
-  (declare (ignore level))
-  (print-unreadable-object (seg stream :type t)
-    (let ((addr (system:sap-int (funcall (seg-sap-maker seg)))))
-      (format stream "#x~x[~d]~:[ (#x~x)~;~*~]~@[ in ~s~]"
-	      addr
-	      (seg-length seg)
-	      (= (seg-virtual-location seg) addr)
-	      (seg-virtual-location seg)
-	      (seg-code seg)))))
-
-;;; ----------------------------------------------------------------
-
-;;; All state during disassembly.  We store some seemingly redundant
-;;; information so that we can allow garbage collect during disassembly and
-;;; not get tripped up by a code block being moved...
-(defstruct (disassem-state (:conc-name dstate-)
-			   (:print-function %print-dstate)
-			   (:constructor %make-dstate))
-  (cur-offs 0 :type offset)		; offset of current pos in segment
-  (next-offs 0 :type offset)		; offset of next position
-
-  (segment-sap (required-argument) :type system:system-area-pointer)
-					; a sap pointing to our segment
-  (segment nil :type (or null segment))	; the current segment
-
-  (alignment vm:word-bytes :type alignment) ; what to align to in most cases
-  (byte-order :little-endian
-	      :type (member :big-endian :little-endian))
-
-  (properties nil :type list)		; for user code to hang stuff off of
-  (filtered-values (make-array max-filtered-value-index)
-		   :type filtered-value-vector)
-
-  (addr-print-len nil :type		; used for prettifying printing
-		  (or null (integer 0 20)))
-  (argument-column 0 :type column)
-  (output-state :beginning		; to make output look nicer
-		  :type (member :beginning
-				:block-boundary
-				nil))
-
-  (labels nil :type list)		; alist of (address . label-number)
-  (label-hash (make-hash-table)		; same thing in a different form
-	      :type hash-table)
-
-  (fun-hooks nil :type list) 		; list of function
-
-  ;; these next two are popped as they are used
-  (cur-labels nil :type list)		; alist of (address . label-number)
-  (cur-offs-hooks nil :type list) 	; list of offs-hook
-
-  (notes nil :type list)		; for the current location
-
-  (current-valid-locations nil		; currently active source variables
-			   :type (or null (vector bit)))
-
-  (params (required-argument) :type params) ; a handy pointer ...
-  )
-
-(defun %print-dstate (dstate stream level)
-  (declare (ignore level))
-  (print-unreadable-object (dstate stream :type t)
-    (format stream "+~d~@[ in ~s~]" (dstate-cur-offs dstate) (dstate-segment dstate))))
-
-(defmacro dstate-get-prop (dstate name)
-  "Get the value of the property called NAME in DSTATE.  Also setf'able."
-  `(getf (dstate-properties ,dstate) ,name))
-
-(defun dstate-cur-addr (dstate)
-  "Returns the absolute address of the current instruction in DSTATE."
-  (the address (+ (seg-virtual-location (dstate-segment dstate))
-		  (dstate-cur-offs dstate))))
-
-(defun dstate-next-addr (dstate)
-  "Returns the absolute address of the next instruction in DSTATE."
-  (the address (+ (seg-virtual-location (dstate-segment dstate))
-		  (dstate-next-offs dstate))))
-
-;;; ----------------------------------------------------------------
-;;; function ops
-
-(defun fun-self (fun)
-  (declare (type compiled-function fun))
-  (kernel:%function-self fun))
-
-(defun fun-code (fun)
-  (declare (type compiled-function fun))
-  (kernel:function-code-header (fun-self fun)))
-
-(defun fun-next (fun)
-  (declare (type compiled-function fun))
-  (kernel:%function-next fun))
-
-(defun fun-address (function)
-  (declare (type compiled-function function))
-  (- (kernel:get-lisp-obj-address function) vm:function-pointer-type))
-
-(defun fun-insts-offset (function)
-  "Offset of FUNCTION from the start of its code-component's instruction area."
-  (declare (type compiled-function function))
-  (- (fun-address function)
-     (system:sap-int (kernel:code-instructions (fun-code function)))))
-
-(defun fun-offset (function)
-  "Offset of FUNCTION from the start of its code-component."
-  (declare (type compiled-function function))
-  (words-to-bytes (kernel:get-closure-length function)))
-
-;;; ----------------------------------------------------------------
-;;; Operations on code-components (which hold the instructions for
-;;; one or more functions).
-
-(defun code-inst-area-length (code-component)
-  "Returns the length of the instruction area in CODE-COMPONENT."
-  (declare (type kernel:code-component code-component))
-  (kernel:code-header-ref code-component vm:code-trace-table-offset-slot))
-
-(defun code-inst-area-address (code-component)
-  "Returns the address of the instruction area in CODE-COMPONENT."
-  (declare (type kernel:code-component code-component))
-  (system:sap-int (kernel:code-instructions code-component)))
-
-(defun code-first-function (code-component)
-  "Returns the first function in CODE-COMPONENT."
-  (declare (type kernel:code-component code-component))
-  (kernel:code-header-ref code-component vm:code-trace-table-offset-slot))
-
-(defun segment-offs-to-code-offs (offset segment)
-  (system:without-gcing
-   (let* ((seg-base-addr (system:sap-int (funcall (seg-sap-maker segment))))
-	  (code-addr
-	   (logandc1 vm:lowtag-mask
-		     (kernel:get-lisp-obj-address (seg-code segment))))
-	  (addr (+ offset seg-base-addr)))
-     (declare (type address seg-base-addr code-addr addr))
-     (- addr code-addr))))
-
-(defun code-offs-to-segment-offs (offset segment)
-  (system:without-gcing
-   (let* ((seg-base-addr (system:sap-int (funcall (seg-sap-maker segment))))
-	  (code-addr
-	   (logandc1 vm:lowtag-mask
-		     (kernel:get-lisp-obj-address (seg-code segment))))
-	  (addr (+ offset code-addr)))
-     (declare (type address seg-base-addr code-addr addr))
-     (- addr seg-base-addr))))
-
-(defun code-insts-offs-to-segment-offs (offset segment)
-  (system:without-gcing
-   (let* ((seg-base-addr (system:sap-int (funcall (seg-sap-maker segment))))
-	  (code-insts-addr
-	   (system:sap-int (kernel:code-instructions (seg-code segment))))
-	  (addr (+ offset code-insts-addr)))
-     (declare (type address seg-base-addr code-insts-addr addr))
-     (- addr seg-base-addr))))
-
-;;; ----------------------------------------------------------------
-
-(defun lra-hook (chunk stream dstate)
-  (declare (type dchunk chunk)
-	   (ignore chunk)
-	   (type (or null stream) stream)
-	   (type disassem-state dstate))
-  (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate))
-			   (dstate-cur-offs dstate))
-			(* 2 vm:word-bytes))
-	     ;; check type
-	     (= (system:sap-ref-8 (dstate-segment-sap dstate)
-				  (if (eq (dstate-byte-order dstate)
-					  :little-endian)
-				      (dstate-cur-offs dstate)
-				      (+ (dstate-cur-offs dstate)
-					 (1- lra-size))))
-		vm:return-pc-header-type))
-    (unless (null stream)
-      (princ '.lra stream))
-    (incf (dstate-next-offs dstate) lra-size))
-  nil)
-
-(defun fun-header-hook (stream dstate)
-  "Print the function-header (entry-point) pseudo-instruction at the current
-  location in DSTATE to STREAM."
-  (declare (type (or null stream) stream)
-	   (type disassem-state dstate))
-  (unless (null stream)
-    (let* ((seg (dstate-segment dstate))
-	   (code (seg-code seg))
-	   (woffs
-	    (bytes-to-words
-	     (segment-offs-to-code-offs (dstate-cur-offs dstate) seg)))
-	   (name
-	    (kernel:code-header-ref code (+ woffs vm:function-name-slot)))
-	   (args
-	    (kernel:code-header-ref code (+ woffs vm:function-arglist-slot)))
-	   (type
-	    (kernel:code-header-ref code (+ woffs vm:function-type-slot))))
-      (format stream ".~a ~s~:a" 'entry name args)
-      (note #'(lambda (stream)
-		(format stream "~:s" type)) ; use format to print NIL as ()
-	    dstate)))
-  (incf (dstate-next-offs dstate)
-	(words-to-bytes vm:function-code-offset)))
-
-;;; ----------------------------------------------------------------
-
-(defun alignment-hook (chunk stream dstate)
-  (declare (type dchunk chunk)
-	   (ignore chunk)
-	   (type (or null stream) stream)
-	   (type disassem-state dstate))
-  (let ((location
-	 (+ (seg-virtual-location (dstate-segment dstate))
-	    (dstate-cur-offs dstate)))
-	(alignment (dstate-alignment dstate)))
-    (unless (aligned-p location alignment)
-      (when stream
-	(format stream "~a~vt~d~%" '.align
-		(dstate-argument-column dstate)
-		alignment))
-      (incf(dstate-next-offs dstate)
-	   (- (align location alignment) location)))
-    nil))
-
-(defun rewind-current-segment (dstate segment)
-  (declare (type disassem-state dstate)
-	   (type segment segment))
-  (setf (dstate-segment dstate) segment)
-  (setf (dstate-cur-offs-hooks dstate)
-	(stable-sort (nreverse (copy-list (seg-hooks segment)))
-		     #'(lambda (oh1 oh2)
-			 (or (< (offs-hook-offset oh1) (offs-hook-offset oh2))
-			     (and (= (offs-hook-offset oh1)
-				     (offs-hook-offset oh2))
-				  (offs-hook-before-address oh1)
-				  (not (offs-hook-before-address oh2)))))))
-  (setf (dstate-cur-offs dstate) 0)
-  (setf (dstate-cur-labels dstate) (dstate-labels dstate)))
-
-(defun do-offs-hooks (before-address stream dstate)
-  (declare (type (or null stream) stream)
-	   (type disassem-state dstate))
-  (let ((cur-offs (dstate-cur-offs dstate)))
-    (setf (dstate-next-offs dstate) cur-offs)
-    (loop
-      (let ((next-hook (car (dstate-cur-offs-hooks dstate))))
-	(when (null next-hook)
-	  (return))
-	(let ((hook-offs (offs-hook-offset next-hook)))
-	  (when (or (> hook-offs cur-offs)
-		    (and (= hook-offs cur-offs)
-			 before-address
-			 (not (offs-hook-before-address next-hook))))
-	    (return))
-	  (unless (< hook-offs cur-offs)
-	    (funcall (offs-hook-function next-hook) stream dstate))
-	  (pop (dstate-cur-offs-hooks dstate))
-	  (unless (= (dstate-next-offs dstate) cur-offs)
-	    (return)))))))
-
-(defun do-fun-hooks (chunk stream dstate)
-  (let ((hooks (dstate-fun-hooks dstate))
-	(cur-offs (dstate-cur-offs dstate)))
-    (setf (dstate-next-offs dstate) cur-offs)
-    (dolist (hook hooks nil)
-      (let ((prefix-p (funcall hook chunk stream dstate)))
-	(unless (= (dstate-next-offs dstate) cur-offs)
-	  (return prefix-p))))))
-
-(defun handle-bogus-instruction (stream dstate)
-  (let ((alignment (dstate-alignment dstate)))
-    (unless (null stream)
-      (multiple-value-bind (words bytes)
-	  (truncate alignment vm:word-bytes)
-	(when (> words 0)
-	  (print-words words stream dstate))
-	(when (> bytes 0)
-	  (print-bytes bytes stream dstate))))
-    (incf (dstate-next-offs dstate) alignment)))
-
-(defun map-segment-instructions (function segment dstate &optional stream)
-  "Iterate through the instructions in SEGMENT, calling FUNCTION
-  for each instruction, with arguments of CHUNK, STREAM, and DSTATE."
-  (declare (type function function)
-	   (type segment segment)
-	   (type disassem-state dstate)
-	   (type (or null stream) stream))
-  
-  (let ((ispace (get-inst-space (dstate-params dstate)))
-	(prefix-p nil))	; just processed a prefix inst
-
-    (rewind-current-segment dstate segment)
-
-    (loop
-      (when (>= (dstate-cur-offs dstate)
-		(seg-length (dstate-segment dstate)))
-	;; done!
-	(return))
-
-      (setf (dstate-next-offs dstate) (dstate-cur-offs dstate))
-
-      (do-offs-hooks t stream dstate)
-      (unless (or prefix-p (null stream))
-	(print-current-address stream dstate))
-      (do-offs-hooks nil stream dstate)
-
-      (unless (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
-	(system:without-gcing
-	 (setf (dstate-segment-sap dstate) (funcall (seg-sap-maker segment)))
-
-	 (let ((chunk
-		(sap-ref-dchunk (dstate-segment-sap dstate)
-				(dstate-cur-offs dstate)
-				(dstate-byte-order dstate))))
-	   (let ((fun-prefix-p (do-fun-hooks chunk stream dstate)))
-	     (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
-		 (setf prefix-p fun-prefix-p)
-		 (let ((inst (find-inst chunk ispace)))
-		   (cond ((null inst)
-			  (handle-bogus-instruction stream dstate))
-			 (t
-			  (setf (dstate-next-offs dstate)
-				(+ (dstate-cur-offs dstate)
-				   (inst-length inst)))
-
-			  (let ((prefilter (inst-prefilter inst))
-				(control (inst-control inst)))
-			    (when prefilter
-			      (funcall prefilter chunk dstate))
-
-			    (funcall function chunk inst)
-
-			    (setf prefix-p (null (inst-printer inst)))
-
-			    (when control
-			      (funcall control chunk inst stream dstate))))))
-		 )))))
-
-      (setf (dstate-cur-offs dstate) (dstate-next-offs dstate))
-
-      (unless (null stream)
-	(unless prefix-p
-	  (print-notes-and-newline stream dstate))
-	(setf (dstate-output-state dstate) nil)))))
-
-;;; ----------------------------------------------------------------
-
-(defun add-segment-labels (segment dstate)
-  "Make an initial non-printing disassembly pass through DSTATE, noting any
-  addresses that are referenced by instructions in this segment."
-  ;; add labels at the beginning with a label-number of nil; we'll notice
-  ;; later and fill them in (and sort them)
-  (declare (type disassem-state dstate))
-  (let ((labels (dstate-labels dstate)))
-    (map-segment-instructions
-     #'(lambda (chunk inst)
-	 (declare (type dchunk chunk) (type instruction inst))
-	 (let ((labeller (inst-labeller inst)))
-	   (when labeller
-	     (setf labels (funcall labeller chunk labels dstate)))))
-     segment
-     dstate)
-    (setf (dstate-labels dstate) labels)
-    ;; erase any notes that got there by accident
-    (setf (dstate-notes dstate) nil)))
-
-(defun number-labels (dstate)
-  "If any labels in DSTATE have been added since the last call to this
-  function, give them label-numbers, enter them in the hash-table, and make
-  sure the label list is in sorted order."
-  (let ((labels (dstate-labels dstate)))
-    (when (and labels (null (cdar labels)))
-      ;; at least one label left un-numbered
-      (setf labels (sort labels #'< :key #'car))
-      (let ((max -1)
-	    (label-hash (dstate-label-hash dstate)))
-	(dolist (label labels)
-	  (when (not (null (cdr label)))
-	    (setf max (max max (cdr label)))))
-	(dolist (label labels)
-	  (when (null (cdr label))
-	    (incf max)
-	    (setf (cdr label) max)
-	    (setf (gethash (car label) label-hash)
-		  (format nil "L~d" max)))))
-      (setf (dstate-labels dstate) labels))))
-
-;;; ----------------------------------------------------------------
-
-(defun get-inst-space (params)
-  "Get the instruction-space from PARAMS, creating it if necessary."
-  (declare (type params params))
-  (let ((ispace (params-inst-space params)))
-    (when (null ispace)
-      (let ((insts nil))
-	(maphash #'(lambda (name inst-flavs)
-		     (declare (ignore name))
-		     (dolist (flav inst-flavs)
-		       (push flav insts)))
-		 (params-instructions params))
-	(setf ispace (build-inst-space insts)))
-      (setf (params-inst-space params) ispace))
-    ispace))
-
-;;; ----------------------------------------------------------------
-;;; add global hooks
-
-(defun add-offs-hook (segment addr hook)
-  (let ((entry (cons addr hook)))
-    (if (null (seg-hooks segment))
-	(setf (seg-hooks segment) (list entry))
-	(push entry (cdr (last (seg-hooks segment)))))))
-
-(defun add-offs-note-hook (segment addr note)
-  (add-offs-hook segment
-		 addr
-		 #'(lambda (stream dstate)
-		     (declare (type (or null stream) stream)
-			      (type disassem-state dstate))
-		     (when stream
-		       (note note dstate)))))
-
-(defun add-offs-comment-hook (segment addr comment)
-  (add-offs-hook segment
-		 addr
-		 #'(lambda (stream dstate)
-		     (declare (type (or null stream) stream)
-			      (ignore dstate))
-		     (when stream
-		       (write-string ";;; " stream)
-		       (etypecase comment
-			 (string
-			  (write-string comment stream))
-			 (function
-			  (funcall comment stream)))
-		       (terpri stream)))))
-
-(defun add-fun-hook (dstate function)
-  (push function (dstate-fun-hooks dstate)))
-
-;;; ----------------------------------------------------------------
-
-(defun set-location-printing-range (dstate from length)
-  (setf (dstate-addr-print-len dstate)
-	;; 4 bits per hex digit
-	(ceiling (integer-length (logxor from (+ from length))) 4)))
-
-(defun print-current-address (stream dstate)
-  "Print the current address in DSTATE to STREAM, plus any labels that
-  correspond to it, and leave the cursor in the instruction column."
-  (declare (type stream stream)
-	   (type disassem-state dstate))
-  (let* ((location
-	  (+ (seg-virtual-location (dstate-segment dstate))
-	     (dstate-cur-offs dstate)))
-	 (location-column-width
-	  (params-location-column-width (dstate-params dstate)))
-	 (plen (dstate-addr-print-len dstate)))
-
-    (when (null plen)
-      (setf plen location-column-width)
-      (set-location-printing-range dstate
-				  (seg-virtual-location (dstate-segment dstate))
-				  (seg-length (dstate-segment dstate))))
-    (when (eq (dstate-output-state dstate) :beginning)
-      (setf plen location-column-width))
-
-    (fresh-line stream)
-
-    ;; print the location
-    ;; [this is equivalent to (format stream "~v,'0x:" plen printed-value), but
-    ;;  usually avoids any consing]
-    (tab0 (- location-column-width plen) stream)
-    (let* ((printed-bits (* 4 plen))
-	   (printed-value (ldb (byte printed-bits 0) location))
-	   (leading-zeros
-	    (truncate (- printed-bits (integer-length printed-value)) 4)))
-      (dotimes (i leading-zeros)
-	(write-char #\0 stream))
-      (unless (zerop printed-value)
-	(write printed-value :stream stream :base 16 :radix nil))
-      (write-char #\: stream))
-
-    ;; print any labels
-    (loop
-      (let* ((next-label (car (dstate-cur-labels dstate)))
-	     (label-location (car next-label)))
-	(when (or (null label-location) (> label-location location))
-	  (return))
-	(unless (< label-location location)
-	  (format stream " L~d:" (cdr next-label)))
-	(pop (dstate-cur-labels dstate))))
-
-    ;; move to the instruction column
-    (tab0 (+ location-column-width 1 label-column-width) stream)
-    ))
-
-;;; ----------------------------------------------------------------
-
-(defmacro with-print-restrictions (&rest body)
-  `(let ((*print-pretty* t)
-	 (*print-lines* 2)
-	 (*print-length* 4)
-	 (*print-level* 3))
-     ,@body))
-
-(defun print-notes-and-newline (stream dstate)
-  "Print a newline to STREAM, inserting any pending notes in DSTATE as
-  end-of-line comments.  If there is more than one note, a separate line
-  will be used for each one."
-  (declare (type stream stream)
-	   (type disassem-state dstate))
-  (with-print-restrictions
-    (dolist (note (dstate-notes dstate))
-      (format stream "~vt; " *note-column*)
-      (etypecase note
-	(string
-	 (write-string note stream))
-	(function
-	 (funcall note stream)))
-      (terpri stream))
-    (fresh-line stream)
-    (setf (dstate-notes dstate) nil)))
-
-(defun print-bytes (num stream dstate)
-  "Disassemble NUM bytes to STREAM as simple `BYTE' instructions"
-  (declare (type offset num)
-	   (type stream stream)
-	   (type disassem-state dstate))
-  (format stream "~a~vt" 'BYTE (dstate-argument-column dstate))
-  (let ((sap (dstate-segment-sap dstate))
-	(start-offs (dstate-cur-offs dstate)))
-    (dotimes (offs num)
-      (unless (zerop offs)
-	(write-string ", " stream))
-      (format stream "#x~2,'0x" (system:sap-ref-8 sap (+ offs start-offs))))))
-
-(defun print-words (num stream dstate)
-  "Disassemble NUM machine-words to STREAM as simple `WORD' instructions"
-  (declare (type offset num)
-	   (type stream stream)
-	   (type disassem-state dstate))
-  (format stream "~a~vt" 'WORD (dstate-argument-column dstate))
-  (let ((sap (dstate-segment-sap dstate))
-	(start-offs (dstate-cur-offs dstate))
-	(byte-order (dstate-byte-order dstate)))
-    (dotimes (word-offs num)
-      (unless (zerop word-offs)
-	(write-string ", " stream))
-      (let ((word 0) (bit-shift 0))
-	(dotimes (byte-offs vm:word-bytes)
-	  (let ((byte
-		 (system:sap-ref-8
-			sap
-			(+ start-offs (* word-offs vm:word-bytes) byte-offs))))
-	    (setf word
-		  (if (eq byte-order :big-endian)
-		      (+ (ash word vm:byte-bits) byte)
-		      (+ word (ash byte bit-shift))))
-	    (incf bit-shift vm:byte-bits)))
-	(format stream "#x~v,'0x" (ash vm:word-bits -2) word)))))
-
-;;; ----------------------------------------------------------------
-
-(defvar *default-dstate-hooks* (list #'lra-hook))
-
-(defun make-dstate (params &optional (fun-hooks *default-dstate-hooks*))
-  "Make a disassembler-state object."
-  (declare (type params params))
-  (let ((sap
-	 ;; a random address
-	 (system:vector-sap (coerce #() '(vector (unsigned-byte 8)))))
-	(alignment
-	 (params-instruction-alignment params))
-	(arg-column
-	 (+ (or *opcode-column-width* (params-opcode-column-width params) 0)
-	    (params-location-column-width params)
-	    1
-	    label-column-width)))
-
-    (when (> alignment 1)
-      (push #'alignment-hook fun-hooks))
-
-    (%make-dstate :segment-sap sap
-		  :params params
-		  :fun-hooks fun-hooks
-		  :argument-column arg-column
-		  :alignment alignment 
-		  :byte-order (c:backend-byte-order (params-backend params)))))
-
-(defun add-fun-header-hooks (segment)
-  (declare (type segment segment))
-  (do ((fun (kernel:code-header-ref (seg-code segment)
-				    vm:code-entry-points-slot)
-	    (fun-next fun))
-       (length (seg-length segment)))
-      ((null fun)) 
-    (let ((offset (code-offs-to-segment-offs (fun-offset fun) segment)))
-      (when (<= 0 offset length)
-	(push (make-offs-hook :offset offset :function #'fun-header-hook)
-	      (seg-hooks segment))))))
-
-;;; ----------------------------------------------------------------
-;;; A sap-maker is a no-argument function that returns a sap.
-
-(declaim (inline sap-maker))
-
-(defun sap-maker (function input offset)
-  (declare (optimize (speed 3))
-	   (type (function (t) system:system-area-pointer) function)
-	   (type offset offset))
-  (let ((old-sap (system:sap+ (funcall function input) offset)))
-    (declare (type system:system-area-pointer old-sap))
-    #'(lambda ()
-	(let ((new-addr
-	       (+ (system:sap-int (funcall function input)) offset)))
-	  ;; Saving the sap like this avoids consing except when the sap
-	  ;; changes (because the sap-int, arith, etc., get inlined).
-	  (declare (type address new-addr))
-	  (if (= (system:sap-int old-sap) new-addr)
-	      old-sap
-	      (setf old-sap (system:int-sap new-addr)))))))
-
-(defun vector-sap-maker (vector offset)
-  (declare (optimize (speed 3))
-	   (type offset offset))
-  (sap-maker #'system:vector-sap vector offset))
-
-(defun code-sap-maker (code offset)
-  (declare (optimize (speed 3))
-	   (type kernel:code-component code)
-	   (type offset offset))
-  (sap-maker #'kernel:code-instructions code offset))
-
-(defun memory-sap-maker (address)
-  (declare (optimize (speed 3))
-	   (type address address))
-  (let ((sap (system:int-sap address)))
-    #'(lambda () sap)))
-
-;;; ----------------------------------------------------------------
-
-(defun make-segment (sap-maker length
-		     &key
-		     code virtual-location
-		     debug-function source-form-cache
-		     hooks)
-  "Return a memory segment located at the system-area-pointer returned by
-  SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
-  Optional keyword arguments include :VIRTUAL-LOCATION (by default the same as
-  the address), :DEBUG-FUNCTION, :SOURCE-FORM-CACHE (a source-form-cache
-  object), and :HOOKS (a list of offs-hook objects)."
-  (declare (type (function () system:system-area-pointer) sap-maker)
-	   (type length length)
-	   (type (or null address) virtual-location)
-	   (type (or null di:debug-function) debug-function)
-	   (type (or null source-form-cache) source-form-cache))
-  (let* ((segment
-	  (%make-segment
-	   :sap-maker sap-maker
-	   :length length
-	   :virtual-location (or virtual-location
-				 (system:sap-int (funcall sap-maker)))
-	   :hooks hooks
-	   :code code)))
-    (add-debugging-hooks segment debug-function source-form-cache)
-    (add-fun-header-hooks segment)
-    segment))
-
-(defun make-vector-segment (vector offset &rest args)
-  (declare (type vector vector)
-	   (type offset offset)
-	   (inline make-segment))
-  (apply #'make-segment (vector-sap-maker vector offset) args))
-
-(defun make-code-segment (code offset length &rest args)
-  (declare (type kernel:code-component code)
-	   (type offset offset)
-	   (inline make-segment))
-  (apply #'make-segment (code-sap-maker code offset) length :code code args))
-
-(defun make-memory-segment (address &rest args)
-  (declare (type address address)
-	   (inline make-segment))
-  (apply #'make-segment (memory-sap-maker address) args))
-
-;;; ----------------------------------------------------------------
-
-;;; just for fun
-(defun print-fun-headers (function)
-  (declare (type compiled-function function))
-  (let* ((self (fun-self function))
-	 (code (kernel:function-code-header self)))
-    (format t "Code-header ~s: size: ~s, trace-table-offset: ~s~%"
-	    code
-	    (kernel:code-header-ref code vm:code-code-size-slot)
-	    (kernel:code-header-ref code vm:code-trace-table-offset-slot))
-    (do ((fun (kernel:code-header-ref code vm:code-entry-points-slot)
-	      (fun-next fun)))
-	((null fun))
-      (let ((fun-offset (kernel:get-closure-length fun)))
-	;; There is function header fun-offset words from the
-	;; code header.
-	(format t "Fun-header ~s at offset ~d (words): ~s~a => ~s~%"
-		fun
-		fun-offset
-		(kernel:code-header-ref
-		 code (+ fun-offset vm:function-name-slot))
-		(kernel:code-header-ref
-		 code (+ fun-offset vm:function-arglist-slot))
-		(kernel:code-header-ref
-		 code (+ fun-offset vm:function-type-slot)))))))
-
-;;; ----------------------------------------------------------------
-;;; getting at the source code...
-
-(defstruct (source-form-cache (:conc-name sfcache-))
-  (debug-source nil :type (or null di:debug-source))
-  (top-level-form-index -1 :type fixnum)
-  (top-level-form nil :type list)
-  (form-number-mapping-table nil :type (or null (vector list)))
-  (last-location-retrieved nil :type (or null di:code-location))
-  (last-form-retrieved -1 :type fixnum)
-  )
-
-(defun get-top-level-form (debug-source tlf-index)
-  (let ((name (di:debug-source-name debug-source)))
-    (ecase (di:debug-source-from debug-source)
-      (:file
-       (cond ((not (probe-file name))
-	      (warn "The source file ~s no longer seems to exist" name)
-	      nil)
-	     (t
-	      (let ((start-positions
-		     (di:debug-source-start-positions debug-source)))
-		(cond ((null start-positions)
-		       (warn "No start positions map")
-		       nil)
-		      (t
-		       (let* ((local-tlf-index
-			       (- tlf-index
-				  (di:debug-source-root-number debug-source)))
-			      (char-offset
-			       (aref start-positions local-tlf-index)))
-			 (with-open-file (f name)
-			   (cond ((= (di:debug-source-created debug-source)
-				     (file-write-date name))
-				  (file-position f char-offset))
-				 (t
-				  (warn "Source file ~s has been modified; ~@
-					 Using form offset instead of file index"
-					name)
-				  (dotimes (i local-tlf-index) (read f))))
-			   (read f)
-			   ))))))))
-      ((:lisp :stream)
-       (aref name tlf-index)))))
-
-(defun cache-valid (loc cache)
-  (and cache
-       (and (eq (di:code-location-debug-source loc)
-		(sfcache-debug-source cache))
-	    (eq (di:code-location-top-level-form-offset loc)
-		(sfcache-top-level-form-index cache)))))
-
-(defun get-source-form (loc context &optional cache)
-  (let* ((cache-valid (cache-valid loc cache))
-	 (tlf-index (di:code-location-top-level-form-offset loc))
-	 (form-number (di:code-location-form-number loc))
-	 (top-level-form
-	  (if cache-valid
-	      (sfcache-top-level-form cache)
-	      (get-top-level-form (di:code-location-debug-source loc)
-				  tlf-index)))
-	 (mapping-table
-	  (if cache-valid
-	      (sfcache-form-number-mapping-table cache)
-	      (di:form-number-translations top-level-form tlf-index))))
-    (when (and (not cache-valid) cache)
-      (setf (sfcache-debug-source cache) (di:code-location-debug-source loc)
-	    (sfcache-top-level-form-index cache) tlf-index
-	    (sfcache-top-level-form cache) top-level-form
-	    (sfcache-form-number-mapping-table cache) mapping-table))
-    (cond ((null top-level-form)
-	   nil)
-	  ((> form-number (length mapping-table))
-	   (warn "Bogus form-number in form!  The source file has probably ~@
-		  been changed too much to cope with")
-	   (when cache
-	     ;; disable future warnings
-	     (setf (sfcache-top-level-form cache) nil))
-	   nil)
-	  (t
-	   (when cache
-	     (setf (sfcache-last-location-retrieved cache) loc)
-	     (setf (sfcache-last-form-retrieved cache) form-number))
-	   (di:source-path-context top-level-form
-				   (aref mapping-table form-number)
-				   context)))))
-
-(defun get-different-source-form (loc context &optional cache)
-  (if (and (cache-valid loc cache)
-	   (or (= (di:code-location-form-number loc)
-		  (sfcache-last-form-retrieved cache))
-	       (and (sfcache-last-location-retrieved cache)
-		    (di:code-location=
-		     loc
-		     (sfcache-last-location-retrieved cache)))))
-      (values nil nil)
-      (values (get-source-form loc context cache) t)))
-
-;;; ----------------------------------------------------------------
-;;; stuff to use debugging-info to augment the disassembly
-
-(defun code-function-map (code)
-  (declare (type kernel:code-component code))
-  (di::get-debug-info-function-map (kernel:%code-debug-info code)))
-
-(defstruct location-group
-  (locations #() :type (vector (or list fixnum)))
-  )
-
-(defstruct storage-info
-  (groups nil :type list)		; alist of (name . location-group)
-  (debug-variables #() :type vector)
-  )
-
-(defun dstate-debug-variables (dstate)
-  "Return the vector of debug-variables currently associated with DSTATE."
-  (declare (type disassem-state dstate))
-  (storage-info-debug-variables (seg-storage-info (dstate-segment dstate))))
-
-(defun find-valid-storage-location (offset lg-name dstate)
-  "Given the OFFSET of a location within the location-group called LG-NAME,
-  see if there's a current mapping to a source variable in DSTATE, and if so,
-  return the offset of that variable in the current debug-variable vector."
-  (declare (type offset offset)
-	   (type symbol lg-name)
-	   (type disassem-state dstate))
-  (let* ((storage-info
-	  (seg-storage-info (dstate-segment dstate)))
-	 (location-group
-	  (and storage-info
-	       (cdr (assoc lg-name (storage-info-groups storage-info)))))
-	 (currently-valid
-	  (dstate-current-valid-locations dstate)))
-    (and location-group
-	 (not (null currently-valid))
-	 (let ((locations (location-group-locations location-group)))
-	   (and (< offset (length locations))
-		(let ((used-by (aref locations offset)))
-		  (and used-by
-		       (let ((debug-var-num
-			      (typecase used-by
-				(fixnum
-				 (and (not
-				       (zerop (bit currently-valid used-by)))
-				      used-by))
-				(list
-				 (some #'(lambda (num)
-					   (and (not
-						 (zerop
-						  (bit currently-valid num)))
-						num))
-				       used-by)))))
-			 (and debug-var-num
-			      (progn
-				;; Found a valid storage reference!
-				;; can't use it again until it's revalidated...
-				(setf (bit (dstate-current-valid-locations
-					    dstate)
-					   debug-var-num)
-				      0)
-				debug-var-num))
-			 ))))))))
-
-(defun grow-vector (vec new-len &optional initial-element)
-  "Return a new vector which has the same contents as the old one VEC, plus
-  new cells (for a total size of NEW-LEN).  The additional elements are
-  initailized to INITIAL-ELEMENT."
-  (declare (type vector vec)
-	   (type fixnum new-len)) 
-  (let ((new
-	 (make-sequence `(vector ,(array-element-type vec) ,new-len)
-			new-len
-			:initial-element initial-element)))
-    (dotimes (i (length vec))
-      (setf (aref new i) (aref vec i)))
-    new))
-
-(defun storage-info-for-debug-function (debug-function)
-  "Returns a STORAGE-INFO struction describing the object-to-source
-  variable mappings from DEBUG-FUNCTION."
-  (declare (type di:debug-function debug-function))
-  (let ((sc-vec (c::backend-sc-numbers c:*native-backend*))
-	(groups nil)
-	(debug-variables (di::debug-function-debug-variables debug-function)))
-    (and debug-variables
-	 (dotimes (debug-var-offset
-		   (length debug-variables)
-		   (make-storage-info :groups groups
-				      :debug-variables debug-variables))
-	   (let ((debug-var (aref debug-variables debug-var-offset)))
-	     #+nil
-	     (format t ";;; At offset ~d: ~s~%" debug-var-offset debug-var)
-	     (let* ((sc-offset
-		     (di::compiled-debug-variable-sc-offset debug-var))
-		    (sb-name
-		     (c:sb-name
-		      (c:sc-sb (aref sc-vec (c:sc-offset-scn sc-offset))))))
-	       #+nil
-	       (format t ";;; SET: ~s[~d]~%"
-		       sb-name (c:sc-offset-offset sc-offset))
-	       (unless (null sb-name)
-		 (let ((group (cdr (assoc sb-name groups))))
-		   (when (null group)
-		     (setf group (make-location-group))
-		     (push `(,sb-name . ,group) groups))
-		   (let* ((locations (location-group-locations group))
-			  (length (length locations))
-			  (offset (c:sc-offset-offset sc-offset)))
-		     (when (>= offset length)
-		       (setf locations
-			     (grow-vector locations
-					  (max (* 2 length)
-					       (1+ offset))
-					  nil)
-			     (location-group-locations group)
-			     locations))
-		     (let ((already-there (aref locations offset)))
-		       (cond ((null already-there)
-			      (setf (aref locations offset) debug-var-offset))
-			     ((eql already-there debug-var-offset))
-			     (t
-			      (if (listp already-there)
-				  (pushnew debug-var-offset
-					   (aref locations offset))
-				  (setf (aref locations offset)
-					(list debug-var-offset
-					      already-there)))))
-		       )))))))
-	 )))
-
-(defun source-available-p (debug-function)
-  (handler-case
-      (di:do-debug-function-blocks (block debug-function)
-	(declare (ignore block))
-	(return t))
-    (di:no-debug-blocks () nil)))
-
-(defun print-block-boundary (stream dstate)
-  (let ((os (dstate-output-state dstate)))
-    (when (not (eq os :beginning))
-      (when (not (eq os :block-boundary))
-	(terpri stream))
-      (setf (dstate-output-state dstate)
-	    :block-boundary))))
-
-(defun add-source-tracking-hooks (segment debug-function &optional sfcache)
-  "Add hooks to track to track the source code in SEGMENT during
-  disassembly.  SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE
-  structure, in which case it is used to cache forms from files."
-  (declare (type segment segment)
-	   (type (or null di:debug-function) debug-function)
-	   (type (or null source-form-cache) sfcache))
-  (let ((last-block-pc -1))
-    (flet ((add-hook (pc fun &optional before-address)
-	     (push (make-offs-hook
-		    :offset pc ;; ##### FIX to account for non-zero offs in code
-		    :function fun
-		    :before-address before-address)
-		   (seg-hooks segment))))
-      (handler-case
-	  (di:do-debug-function-blocks (block debug-function)
-	    (let ((first-location-in-block-p t))
-	      (di:do-debug-block-locations (loc block)
-		(let ((pc (di::compiled-code-location-pc loc)))
-
-		  ;; Put blank lines in at block boundaries
-		  (when (and first-location-in-block-p
-			     (/= pc last-block-pc))
-		    (setf first-location-in-block-p nil)
-		    (add-hook pc
-			      #'(lambda (stream dstate)
-				  (print-block-boundary stream dstate))
-			      t)
-		    (setf last-block-pc pc))
-
-		  ;; Print out corresponding source; this information is not
-		  ;; all that accurate, but it's better than nothing
-		  (unless (zerop (di:code-location-form-number loc))
-		    (multiple-value-bind (form new)
-			(get-different-source-form loc 0 sfcache)
-		      (when new
-			 (let ((at-block-begin (= pc last-block-pc)))
-			   (add-hook
-			    pc
-			    #'(lambda (stream dstate)
-				(declare (ignore dstate))
-				(when stream
-				  (unless at-block-begin
-				    (terpri stream))
-				  (format stream ";;; [~d] "
-					  (di:code-location-form-number loc))
-				  (prin1-short form stream)
-				  (terpri stream)
-				  (terpri stream)))
-			    t)))))
-
-		  ;; Keep track of variable live-ness as best we can
-		  (let ((live-set
-			 (copy-seq (di::compiled-code-location-live-set loc))))
-		    (add-hook
-		     pc
-		     #'(lambda (stream dstate)
-			 (declare (ignore stream))
-			 (setf (dstate-current-valid-locations dstate)
-			       live-set)
-			 #+nil
-			 (note #'(lambda (stream)
-				   (let ((*print-length* nil))
-				     (format stream "Live set: ~s"
-					     live-set)))
-			       dstate))))
-		  ))))
-	(di:no-debug-blocks () nil)))))
-
-(defun add-debugging-hooks (segment debug-function &optional sfcache)
-  (when debug-function
-    (setf (seg-storage-info segment)
-	  (storage-info-for-debug-function debug-function))
-    (add-source-tracking-hooks segment debug-function sfcache)
-    (let ((kind (di:debug-function-kind debug-function)))
-      (flet ((anh (n)
-	       (push (make-offs-hook
-		      :offset 0
-		      :function #'(lambda (stream dstate)
-				    (declare (ignore stream))
-				    (note n dstate)))
-		     (seg-hooks segment))))
-	(case kind
-	  (:external)
-	  ((nil)
-	   (anh "No-arg-parsing entry point"))
-	  (t
-	   (anh #'(lambda (stream)
-		    (format stream "~s entry point" kind)))))))))
-
-;;; ----------------------------------------------------------------
-
-(defun get-function-segments (function)
-  "Returns a list of the segments of memory containing machine code
-  instructions for FUNCTION."
-  (declare (type compiled-function function))
-  (let* ((code (fun-code function))
-	 (function-map (code-function-map code))
-	 (fname (kernel:%function-name function))
-	 (sfcache (make-source-form-cache)))
-    (let ((first-block-seen-p nil)
-	  (nil-block-seen-p nil)
-	  (last-offset 0)
-	  (last-debug-function nil)
-	  (segments nil))
-      (flet ((add-seg (offs len df)
-	       (when (> len 0)
-		 (push (make-code-segment code offs len
-					  :debug-function df
-					  :source-form-cache sfcache)
-		       segments))))
-	(dotimes (fmap-index (length function-map))
-	  (let ((fmap-entry (aref function-map fmap-index)))
-	    (etypecase fmap-entry
-	      (integer
-	       (when first-block-seen-p
-		 (add-seg last-offset
-			  (- fmap-entry last-offset)
-			  last-debug-function)
-		 (setf last-debug-function nil))
-	       (setf last-offset fmap-entry))
-	      (c::compiled-debug-function
-	       (let ((name (c::compiled-debug-function-name fmap-entry))
-		     (kind (c::compiled-debug-function-kind fmap-entry)))
-		 #+nil
-		 (format t ";;; SAW ~s ~s ~s,~s ~d,~d~%"
-			 name kind first-block-seen-p nil-block-seen-p
-			 last-offset
-			 (c::compiled-debug-function-start-pc fmap-entry))
-		 (cond (#+nil (eq last-offset fun-offset)
-			      (and (equal name fname) (not first-block-seen-p))
-			      (setf first-block-seen-p t))
-		       ((eq kind :external)
-			(when first-block-seen-p
-			  (return)))
-		       ((eq kind nil)
-			(when nil-block-seen-p
-			  (return))
-			(when first-block-seen-p
-			  (setf nil-block-seen-p t))))
-		 (setf last-debug-function
-		       (di::make-compiled-debug-function fmap-entry code))
-		 )))))
-	(let ((max-offset (code-inst-area-length code)))
-	  (when (and first-block-seen-p last-debug-function)
-	    (add-seg last-offset
-		     (- max-offset last-offset)
-		     last-debug-function))
-	  (if (null segments)
-	      (let ((offs (fun-insts-offset function)))
-		(make-code-segment code offs (- max-offset offs)))
-	      (nreverse segments)))))))
-
-(defun get-code-segments (code
-			  &optional
-			  (start-offs 0)
-			  (length (code-inst-area-length code)))
-  "Returns a list of the segments of memory containing machine code
-  instructions for the code-component CODE.  If START-OFFS and/or LENGTH is
-  supplied, only that part of the code-segment is used (but these are
-  constrained to lie within the code-segment)."
-  (declare (type kernel:code-component code)
-	   (type offset start-offs)
-	   (type length length))
-  (let ((segments nil))
-    (when code
-      (let ((function-map (code-function-map code))
-	    (sfcache (make-source-form-cache)))
-	(let ((last-offset 0)
-	      (last-debug-function nil))
-	  (flet ((add-seg (offs len df)
-		   (let* ((restricted-offs
-			   (min (max start-offs offs) (+ start-offs length)))
-			  (restricted-len
-			   (- (min (max start-offs (+ offs len))
-				   (+ start-offs length))
-			      restricted-offs)))
-		     (when (> restricted-len 0)
-		       (push (make-code-segment code
-						restricted-offs restricted-len
-						:debug-function df
-						:source-form-cache sfcache)
-			     segments)))))
-	    (dotimes (fmap-index (length function-map))
-	      (let ((fmap-entry (aref function-map fmap-index)))
-		(etypecase fmap-entry
-		  (integer
-		   (add-seg last-offset (- fmap-entry last-offset)
-			    last-debug-function)
-		   (setf last-debug-function nil)
-		   (setf last-offset fmap-entry))
-		  (c::compiled-debug-function
-		   (setf last-debug-function
-			 (di::make-compiled-debug-function fmap-entry code)))
-		  )))
-	    (when last-debug-function
-	      (add-seg last-offset
-		       (- (code-inst-area-length code) last-offset)
-		       last-debug-function))))))
-    (if (null segments)
-	(make-code-segment code start-offs length)
-	(nreverse segments))))
-
-;;; ----------------------------------------------------------------
-
-#+nil
-(defun find-function-segment (fun)
-  "Return the address of the instructions for function and its length.
-  The length is computed using a heuristic, and so may not be accurate."
-  (declare (type compiled-function fun))
-  (let* ((code
-	  (fun-code fun))
-	 (fun-addr
-	  (- (kernel:get-lisp-obj-address fun) vm:function-pointer-type))
-	 (max-length
-	  (code-inst-area-length code))
-	 (upper-bound
-	  (+ (code-inst-area-address code) max-length)))
-    (do ((some-fun (code-first-function code)
-		   (fun-next some-fun)))
-	((null some-fun)
-	 (values fun-addr (- upper-bound fun-addr)))
-      (let ((some-addr (fun-address some-fun)))
-	(when (and (> some-addr fun-addr)
-		   (< some-addr upper-bound))
-	  (setf upper-bound some-addr))))))
-
-;;; ----------------------------------------------------------------
-
-(defun segment-overflow (segment dstate)
-  "Returns two values:  the amount by which the last instruction in the
-  segment goes past the end of the segment, and the offset of the end of the
-  segment from the beginning of that instruction.  If all instructions fit
-  perfectly, this will return 0 and 0."
-  (declare (type segment segment)
-	   (type disassem-state dstate))
-  (let ((seglen (seg-length segment))
-	(last-start 0))
-    (map-segment-instructions #'(lambda (chunk inst)
-				  (declare (ignore chunk inst))
-				  (setf last-start (dstate-cur-offs dstate)))
-			      segment
-			      dstate)
-    (values (- (dstate-cur-offs dstate) seglen)
-	    (- seglen last-start))))
-  
-(defun label-segments (seglist dstate)
-  "Computes labels for all the memory segments in SEGLIST and adds them to
-  DSTATE.  It's important to call this function with all the segments you're
-  interested in, so it can find references from one to another."
-  (declare (type list seglist)
-	   (type disassem-state dstate))
-  (dolist (seg seglist)
-    (add-segment-labels seg dstate))
-  ;; now remove any labels that don't point anywhere in the segments we have
-  (setf (dstate-labels dstate)
-	(remove-if #'(lambda (lab)
-		       (not
-			(some #'(lambda (seg)
-				  (let ((start (seg-virtual-location seg)))
-				    (<= start
-					(car lab)
-					(+ start (seg-length seg)))))
-			      seglist)))
-		   (dstate-labels dstate))))
-
-(defun disassemble-segment (segment stream dstate)
-  "Disassemble the machine code instructions in SEGMENT to STREAM."
-  (declare (type segment segment)
-	   (type stream stream)
-	   (type disassem-state dstate))
-  (let ((*print-pretty* nil)) ; otherwise the pp conses hugely
-    (number-labels dstate)
-    (map-segment-instructions
-     #'(lambda (chunk inst)
-	 (declare (type dchunk chunk) (type instruction inst))
-	 (let ((printer (inst-printer inst)))
-	   (when printer
-	     (funcall printer chunk inst stream dstate))))
-     segment
-     dstate
-     stream)))
-
-(defun disassemble-segments (segments stream dstate)
-  "Disassemble the machine code instructions in each memory segment in
-  SEGMENTS in turn to STREAM."
-  (declare (type list segments)
-	   (type stream stream)
-	   (type disassem-state dstate))
-  (unless (null segments)
-    (let ((first (car segments))
-	  (last (car (last segments))))
-      (set-location-printing-range dstate
-				  (seg-virtual-location first)
-				  (- (+ (seg-virtual-location last)
-					(seg-length last))
-				     (seg-virtual-location first)))
-      (setf (dstate-output-state dstate) :beginning)
-      (dolist (seg segments)
-	(disassemble-segment seg stream dstate)))))
-
-;;; ----------------------------------------------------------------
-;;; top-level functions
-
-(defun disassemble-function (function &key (stream *standard-output*)
-				      (use-labels t)
-				      (backend c:*native-backend*))
-  "Disassemble the machine code instructions for FUNCTION."
-  (declare (type compiled-function function)
-	   (type stream stream)
-	   (type (member t nil) use-labels)
-	   (type c::backend backend))
-  (let* ((dstate (make-dstate (c:backend-disassem-params backend)))
-	 (segments (get-function-segments function)))
-    (when use-labels
-      (label-segments segments dstate))
-    (disassemble-segments segments stream dstate)))
-
-(defun compile-function-lambda-expr (function)
-  (declare (type function function))
-  (multiple-value-bind
-      (lambda closurep name)
-      (function-lambda-expression function)
-    (declare (ignore name))
-    (when closurep
-      (error "Cannot compile a lexical closure"))
-    (compile nil lambda)))
-
-(defun compiled-function-or-lose (thing &optional (name thing))
-  (cond ((or (symbolp thing)
-	     (and (listp thing)
-		  (eq (car thing) 'lisp:setf)))
-	 (compiled-function-or-lose (fdefinition thing) thing))
-	((eval:interpreted-function-p thing)
-	 (compile-function-lambda-expr thing))
-	((functionp thing)
-	 thing)
-	((and (listp thing)
-	      (eq (car thing) 'lisp::lambda))
-	 (compile nil thing))
-	(t
-	 (error "Can't make a compiled function from ~S" name))))
-
-(defun disassemble (object &optional (stream *standard-output*)
-			   &key (use-labels t)
-			   (backend c:*native-backend*))
-  "Disassemble the machine code associated with OBJECT, which can be a
-  function, a lambda expression, or a symbol with a function definition.  If
-  it is not already compiled, the compiler is called to produce something to
-  disassemble.  If STREAM is T, *STANDARD-OUTPUT* is used (so you can 
-  use the keywords without having to type it!)."
-  (declare (type (or function symbol cons) object)
-	   (type (or (member t) stream) stream)
-	   (type (member t nil) use-labels)
-	   (type c::backend backend))
-  (disassemble-function (fun-self	; we can't detect closures, so
-					; be careful
-			 (compiled-function-or-lose object))
-			:stream (if (eq stream t)
-				    *standard-output*
-				    stream)
-			:use-labels use-labels
-			:backend backend))
-
-(defun disassemble-memory (address
-			   length
-			   &key
-			   (stream *standard-output*)
-			   code-component
-			   (use-labels t)
-			   (backend c:*backend*))
-  "Disassembles the given area of memory starting at ADDRESS and LENGTH long.
-  Note that if CODE-COMPONENT is NIL and this memory could move during a GC,
-  you'd better disable it around the call to this function."
-  (declare (type (or address system:system-area-pointer) address)
-	   (type length length)
-	   (type stream stream)
-	   (type (or null kernel:code-component) code-component)
-	   (type (member t nil) use-labels)
-	   (type c::backend backend))
-  (let*	((address
-	  (if (system:system-area-pointer-p address)
-	      (system:sap-int address)
-	      address))
-	 (dstate (make-dstate (c:backend-disassem-params backend)))
-	 (segments
-	  (if code-component
-	      (let ((code-offs
-		     (- address
-			(system:sap-int
-			 (kernel:code-instructions code-component)))))
-		(when (or (< code-offs 0)
-			  (> code-offs (code-inst-area-length code-component)))
-		  (error "Address ~x not in the code component ~s."
-			 address code-component))
-		(get-code-segments code-component code-offs length))
-	      (list (make-memory-segment address length)))))
-    (when use-labels
-      (label-segments segments dstate))
-    (disassemble-segments segments stream dstate)))
-
-(defun disassemble-code-component (code-component &key
-						  (stream *standard-output*)
-						  (use-labels t)
-						  (backend c:*native-backend*))
-  "Disassemble the machine code instructions associated with
-  CODE-COMPONENT (this may include multiple entry points)."
-  (declare (type (or null kernel:code-component compiled-function)
-		 code-component)
-	   (type stream stream)
-	   (type (member t nil) use-labels)
-	   (type c::backend backend))
-  (let*	((code-component
-	  (if (functionp code-component)
-	      (fun-code code-component)
-	      code-component))
-	 (dstate (make-dstate (c:backend-disassem-params backend)))
-	 (segments (get-code-segments code-component)))
-    (when use-labels
-      (label-segments segments dstate))
-    (disassemble-segments segments stream dstate)))
-
-;;; ----------------------------------------------------------------
-;;; Code for making useful segments from arbitrary lists of code-blocks
-
-;;; The maximum size of an instruction -- this includes pseudo-instructions
-;;; like error traps with their associated operands, so it should be big enough
-;;; to include them (i.e. it's not just 4 on a risc machine!).
-(defconstant max-instruction-size 16)
-
-(defun sap-to-vector (sap start end)
-    (let* ((length (- end start))
-	   (result (make-array length :element-type '(unsigned-byte 8)))
-	   (sap (system:sap+ sap start)))
-      (dotimes (i length)
-	(setf (aref result i) (system:sap-ref-8 sap i)))
-      result))
-
-(defun add-block-segments (sap amount seglist location connecting-vec dstate)
-  (declare (type list seglist)
-	   (type integer location)
-	   (type (or null (vector (unsigned-byte 8))) connecting-vec)
-	   (type disassem-state dstate))
-  (flet ((addit (seg overflow)
-	   (let ((length (+ (seg-length seg) overflow)))
-	     (when (> length 0)
-	       (setf (seg-length seg) length)
-	       (incf location length)
-	       (push seg seglist)))))
-    (let ((connecting-overflow 0))
-      (when connecting-vec
-	;; tack on some of the new block to the old overflow vector
-	(let* ((beginning-of-block-amount
-		(if sap (min max-instruction-size amount) 0))
-	       (connecting-vec
-		(if sap
-		    (concatenate
-		     '(vector (unsigned-byte 8))
-		     connecting-vec
-		     (sap-to-vector sap 0 beginning-of-block-amount))
-		    connecting-vec)))
-	  (when (and (< (length connecting-vec) max-instruction-size)
-		     (not (null sap)))
-	    (return-from add-block-segments
-	      ;; We want connecting vectors to be large enough to hold
-	      ;; any instruction, and since the current sap wasn't large
-	      ;; enough to do this (and is now entirely on the end of the
-	      ;; overflow-vector), just save it for next time.
-	      (values seglist location connecting-vec)))
-	  (when (> (length connecting-vec) 0)
-	    (let ((seg
-		   (make-vector-segment connecting-vec
-					0
-					(- (length connecting-vec)
-					   beginning-of-block-amount)
-					:virtual-location location)))
-	      (setf connecting-overflow (segment-overflow seg dstate))
-	      (addit seg connecting-overflow)))))
-      (cond ((null sap)
-	     ;; Nothing more to add.
-	     (values seglist location nil))
-	    ((< (- amount connecting-overflow) max-instruction-size)
-	     ;; We can't create a segment with the minimum size
-	     ;; required for an instruction, so just keep on accumulating
-	     ;; in the overflow vector for the time-being.
-	     (values seglist
-		     location
-		     (sap-to-vector sap connecting-overflow amount)))
-	    (t
-	     ;; Put as much as we can into a new segment, and the rest
-	     ;; into the overflow-vector.
-	     (let* ((initial-length
-		     (- amount connecting-overflow max-instruction-size))
-		    (seg
-		     (make-segment #'(lambda ()
-				       (system:sap+ sap connecting-overflow))
-				   initial-length
-				   :virtual-location location))
-		    (overflow
-		     (segment-overflow seg dstate)))
-	       (addit seg overflow)
-	       (values seglist
-		       location
-		       (sap-to-vector sap
-				      (+ connecting-overflow (seg-length seg))
-				      amount))))))))
-
-;;; ----------------------------------------------------------------
-;;; Code to disassemble assembler segments.
-
-(defun assem-segment-to-disassem-segments (assem-segment dstate)
-  (declare (type new-assem:segment assem-segment)
-	   (type disassem-state dstate))
-  (let ((location 0)
-	(disassem-segments nil)
-	(connecting-vec nil))
-    (new-assem:segment-map-output
-     assem-segment
-     #'(lambda (sap amount)
-	 (multiple-value-setq (disassem-segments location connecting-vec)
-	   (add-block-segments sap amount
-			       disassem-segments location
-			       connecting-vec
-			       dstate))))
-    (when connecting-vec
-      (setf disassem-segments
-	    (add-block-segments nil nil
-				disassem-segments location
-				connecting-vec
-				dstate)))
-    (sort disassem-segments #'< :key #'seg-virtual-location))) 
-
-(defun disassemble-assem-segment (assem-segment stream backend)
-  "Disassemble the machine code instructions associated with
-  ASSEM-SEGMENT (of type new-assem:segment)."
-  (declare (type new-assem:segment assem-segment)
-	   (type stream stream)
-	   (type c::backend backend))
-  (let* ((dstate (make-dstate (c:backend-disassem-params backend)))
-	 (disassem-segments
-	  (assem-segment-to-disassem-segments assem-segment dstate)))
-    (label-segments disassem-segments dstate)
-    (disassemble-segments disassem-segments stream dstate)))
-
-;;; ----------------------------------------------------------------
-;;; Routines to find things in the lisp environment.  Obviously highly
-;;; implementation specific!
-
-(defconstant groked-symbol-slots
-  (sort `((,vm:symbol-value-slot . symbol-value)
-	  (,vm:symbol-plist-slot . symbol-plist)
-	  (,vm:symbol-name-slot . symbol-name)
-	  (,vm:symbol-package-slot . symbol-package))
-	#'<
-	:key #'car)
-  "An alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots in a
-symbol object that we know about.")
-
-(defun grok-symbol-slot-ref (address)
-  "Given ADDRESS, try and figure out if which slot of which symbol is being
-  refered to.  Of course we can just give up, so it's not a big deal...
-  Returns two values, the symbol and the name of the access function of the
-  slot."
-  (declare (type address address))
-  (if (not (aligned-p address vm:word-bytes))
-      (values nil nil)
-      (do ((slots-tail groked-symbol-slots (cdr slots-tail)))
-	  ((null slots-tail)
-	   (values nil nil))
-	(let* ((field (car slots-tail))
-	       (slot-offset (words-to-bytes (car field)))
-	       (maybe-symbol-addr (- address slot-offset))
-	       (maybe-symbol
-		(kernel:make-lisp-obj
-		 (+ maybe-symbol-addr vm:other-pointer-type))))
-	  (when (symbolp maybe-symbol)
-	    (return (values maybe-symbol (cdr field))))))))
-
-(defconstant nil-addr (kernel:get-lisp-obj-address nil))
-
-(defun grok-nil-indexed-symbol-slot-ref (byte-offset)
-  "Given a BYTE-OFFSET from NIL, try and figure out if which slot of which
-  symbol is being refered to.  Of course we can just give up, so it's not a big
-  deal...  Returns two values, the symbol and the access function."
-  (declare (type offset byte-offset))
-  (grok-symbol-slot-ref (+ nil-addr byte-offset)))
-
-(defun get-nil-indexed-object (byte-offset)
-  "Returns the lisp object located BYTE-OFFSET from NIL."
-  (declare (type offset byte-offset))
-  (kernel:make-lisp-obj (+ nil-addr byte-offset)))
-
-(defun get-code-constant (byte-offset dstate)
-  "Returns two values; the lisp-object located at BYTE-OFFSET in the constant
-  area of the code-object in the current segment and T, or NIL and NIL if
-  there is no code-object in the current segment."
-  (declare (type offset byte-offset)
-	   (type disassem-state dstate))
-  (let ((code (seg-code (dstate-segment dstate))))
-    (if code
-	(values
-	 (kernel:code-header-ref code
-				 (ash (+ byte-offset vm:other-pointer-type)
-				      (- vm:word-shift)))
-	 t)
-	(values nil nil))))
-
-(defvar *assembler-routines-by-addr* nil)
-
-(defun find-assembler-routine (address)
-  "Returns the name of the primitive lisp assembler routine located at
-  ADDRESS, or NIL if there isn't one."
-  (declare (type address address))
-  (when (null *assembler-routines-by-addr*)
-    (setf *assembler-routines-by-addr* (make-hash-table))
-    (maphash #'(lambda (name address)
-		 (setf (gethash address *assembler-routines-by-addr*) name))
-	     lisp::*assembler-routines*))
-  (gethash address *assembler-routines-by-addr*))
-
-;;; ----------------------------------------------------------------
-;;; some handy function for machine-dependent code to use...
-
-(declaim (maybe-inline sap-ref-int read-suffix))
-
-(defun sap-ref-int (sap offset length byte-order)
-  (declare (type system:system-area-pointer sap)
-	   (type (unsigned-byte 16) offset)
-	   (type (member 1 2 4) length)
-	   (type (member :little-endian :big-endian) byte-order)
-	   (optimize (speed 3) (safety 0)))
-  (ecase length
-    (1 (system:sap-ref-8 sap offset))
-    (2 (if (eq byte-order :big-endian)
-	   (+ (ash (system:sap-ref-8 sap offset) 8)
-	      (system:sap-ref-8 sap (+ offset 1)))
-	   (+ (ash (system:sap-ref-8 sap (+ offset 1)) 8)
-	      (system:sap-ref-8 sap offset))))
-    (4 (if (eq byte-order :big-endian)
-	   (+ (ash (system:sap-ref-8 sap offset) 24)
-	      (ash (system:sap-ref-8 sap (+ 1 offset)) 16)
-	      (ash (system:sap-ref-8 sap (+ 2 offset)) 8)
-	      (system:sap-ref-8 sap (+ 3 offset)))
-	   (+ (system:sap-ref-8 sap offset)
-	      (ash (system:sap-ref-8 sap (+ 1 offset)) 8)
-	      (ash (system:sap-ref-8 sap (+ 2 offset)) 16)
-	      (ash (system:sap-ref-8 sap (+ 3 offset)) 24))))))
-
-(defun read-suffix (length dstate)
-  (declare (type (member 8 16 32) length)
-	   (type disassem-state dstate)
-	   (optimize (speed 3) (safety 0)))
-  (let ((length (ecase length (8 1) (16 2) (32 4))))
-    (declare (type (unsigned-byte 3) length))
-    (prog1
-      (sap-ref-int (dstate-segment-sap dstate)
-		   (dstate-next-offs dstate)
-		   length
-		   (dstate-byte-order dstate))
-      (incf (dstate-next-offs dstate) length))))
-
-(defun read-signed-suffix (length dstate)
-  (declare (type (member 8 16 32) length)
-	   (type disassem-state dstate)
-	   (optimize (speed 3) (safety 0)))
-  (sign-extend (read-suffix length dstate) length))
-
-;;; ----------------------------------------------------------------
-;;; optional routines to make notes about code
-
-(defun note (note dstate)
-  "Store NOTE (which can be either a string or a function with a single
-  stream argument) to be printed as an end-of-line comment after the current
-  instruction is disassembled."
-  (declare (type (or string function) note)
-	   (type disassem-state dstate))
-  (push note (dstate-notes dstate)))
-
-(defun prin1-short (thing stream)
-  (with-print-restrictions
-    (prin1 thing stream)))
-
-(defun prin1-quoted-short (thing stream)
-  (if (self-evaluating-p thing)
-      (prin1-short thing stream)
-      (prin1-short `',thing stream)))
-
-(defun note-code-constant (byte-offset dstate)
-  "Store a note about the lisp constant located BYTE-OFFSET bytes from the
-  current code-component, to be printed as an end-of-line comment after the
-  current instruction is disassembled."
-  (declare (type offset byte-offset)
-	   (type disassem-state dstate))
-  (multiple-value-bind (const valid)
-      (get-code-constant byte-offset dstate)
-    (when valid
-      (note #'(lambda (stream)
-		(prin1-quoted-short const stream))
-	    dstate))
-    const))
-
-(defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate)
-  "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL
-  is a valid slot in a symbol, store a note describing which symbol and slot,
-  to be printed as an end-of-line comment after the current instruction is
-  disassembled.  Returns non-NIL iff a note was recorded."
-  (declare (type offset nil-byte-offset)
-	   (type disassem-state dstate))
-  (multiple-value-bind (symbol access-fun)
-      (grok-nil-indexed-symbol-slot-ref nil-byte-offset)
-    (when access-fun
-      (note #'(lambda (stream)
-		(prin1 (if (eq access-fun 'symbol-value)
-			   symbol
-			   `(,access-fun ',symbol))
-		       stream))
-	    dstate))
-    access-fun))
-
-(defun maybe-note-nil-indexed-object (nil-byte-offset dstate)
-  "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL
-  is a valid lisp object, store a note describing which symbol and slot, to
-  be printed as an end-of-line comment after the current instruction is
-  disassembled.  Returns non-NIL iff a note was recorded."
-  (declare (type offset nil-byte-offset)
-	   (type disassem-state dstate))
-  (let ((obj (get-nil-indexed-object nil-byte-offset)))
-    (note #'(lambda (stream)
-	      (prin1-quoted-short obj stream))
-	  dstate)
-    t))
-
-(defun maybe-note-assembler-routine (address note-address-p dstate)
-  "If ADDRESS is the address of a primitive assembler routine, store a note
-  describing which one, to be printed as an end-of-line comment after the
-  current instruction is disassembled.  Returns non-NIL iff a note was
-  recorded.  If NOTE-ADDRESS-P is non-NIL, a note of the address is also made."
-  (declare (type address address)
-	   (type disassem-state dstate))
-  (let ((name (find-assembler-routine address)))
-    (unless (null name)
-      (note #'(lambda (stream)
-		(if NOTE-ADDRESS-P
-		    (format stream "#x~8,'0x: ~s" address name)
-		    (prin1 name stream)))
-	    dstate))
-    name))
-
-(defun maybe-note-single-storage-ref (offset sc-name dstate)
-  "If there's a valid mapping from OFFSET in the storage class SC-NAME to a
-  source variable, make a note of the source-variable name, to be printed as
-  an end-of-line comment after the current instruction is disassembled.
-  Returns non-NIL iff a note was recorded."
-  (declare (type offset offset)
-	   (type symbol sc-name)
-	   (type disassem-state dstate))
-  (let ((storage-location
-	 (find-valid-storage-location offset sc-name dstate)))
-    (when storage-location
-      (note #'(lambda (stream)
-		(princ (di:debug-variable-symbol
-			(aref (storage-info-debug-variables
-			       (seg-storage-info (dstate-segment dstate)))
-			      storage-location))
-		       stream))
-	    dstate)
-      t)))
-
-(defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate)
-  "If there's a valid mapping from OFFSET in the storage-base called SB-NAME
-  to a source variable, make a note equating ASSOC-WITH with the
-  source-variable name, to be printed as an end-of-line comment after the
-  current instruction is disassembled.  Returns non-NIL iff a note was
-  recorded."
-  (declare (type offset offset)
-	   (type symbol sb-name)
-	   (type (or symbol string) assoc-with)
-	   (type disassem-state dstate))
-  (let ((storage-location
-	 (find-valid-storage-location offset sb-name dstate)))
-    (when storage-location
-      (note #'(lambda (stream)
-		(format stream "~a = ~s"
-			assoc-with
-			(di:debug-variable-symbol
-			 (aref (dstate-debug-variables dstate)
-			       storage-location))
-		       stream))
-	    dstate)
-      t)))
-
-;;; ----------------------------------------------------------------
-;;; these should be somewhere else...
-
-(defun get-error-name (errnum backend)
-  (car (svref (c:backend-internal-errors backend) errnum)))
-
-(defun get-sc-name (sc-offs backend)
-  (c::location-print-name
-   (c::make-random-tn :kind :normal
-		      :sc (svref (c::backend-sc-numbers backend)
-				 (c:sc-offset-scn sc-offs))
-		      :offset (c:sc-offset-offset sc-offs))))
-
-;;; ----------------------------------------------------------------
-
-(defun handle-break-args (error-parse-fun stream dstate)
-  "When called from an error break instruction's :DISASSEM-CONTROL (or
-  :DISASSEM-PRINTER) function, will correctly deal with printing the
-  arguments to the break.
-
-  ERROR-PARSE-FUN should be a function that accepts:
-    1) a SYSTEM-AREA-POINTER
-    2) a BYTE-OFFSET from the SAP to begin at
-    3) optionally, LENGTH-ONLY, which if non-NIL, means to only return
-       the byte length of the arguments (to avoid unnecessary consing)
-  It should read information from the SAP starting at BYTE-OFFSET, and return
-  four values:
-    1) the error number
-    2) the total length, in bytes, of the information
-    3) a list of SC-OFFSETs of the locations of the error parameters
-    4) a list of the length (as read from the SAP), in bytes, of each of the
-       return-values." 
-  (declare (type function error-parse-fun)
-	   (type (or null stream) stream)
-	   (type disassem-state dstate))
-  (multiple-value-bind (errnum adjust sc-offsets lengths)
-      (funcall error-parse-fun
-	       (dstate-segment-sap dstate)
-	       (dstate-next-offs dstate)
-	       (null stream))
-    (when stream
-      (setf (dstate-cur-offs dstate)
-	    (dstate-next-offs dstate))
-      (flet ((emit-err-arg (note)
-	       (let ((num (pop lengths)))
-		 (print-notes-and-newline stream dstate)
-		 (print-current-address stream dstate)
-		 (print-bytes num stream dstate)
-		 (incf (dstate-cur-offs dstate) num)
-		 (when note
-		   (note note dstate)))))
-	(let ((backend (params-backend (dstate-params dstate))))
-	  (emit-err-arg nil)
-	  (emit-err-arg (symbol-name (get-error-name errnum backend)))
-	  (dolist (sc-offs sc-offsets)
-	    (emit-err-arg (get-sc-name sc-offs backend)))))
-      )
-    (incf (dstate-next-offs dstate) adjust)
-    ))
diff --git a/compiler/dyncount.lisp b/compiler/dyncount.lisp
deleted file mode 100644
index 4f31496de7dcffb01da7f4523459f15dda46700f..0000000000000000000000000000000000000000
--- a/compiler/dyncount.lisp
+++ /dev/null
@@ -1,90 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dyncount.lisp,v 1.6 1992/08/04 08:24:49 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains support for collecting dynamic vop statistics.
-;;; 
-(in-package "C")
-
-(export '(*collect-dynamic-statistics*))
-
-(export '(count-me))
-
-
-(defvar *collect-dynamic-statistics* nil
-  "When T, emit extra code to collect dynamic statistics about vop usages.")
-
-(defvar *dynamic-counts-tn* nil
-  "Holds the TN for the counts vector.")
-
-
-(defstruct (dyncount-info
-	    (:print-function %print-dyncount-info)
-	    (:make-load-form-fun :just-dump-it-normally))
-  for
-  (counts (required-argument) :type (simple-array (unsigned-byte 32) (*)))
-  (vops (required-argument) :type simple-vector))
-
-
-(defprinter dyncount-info
-  for
-  counts
-  vops)
-
-(defun setup-dynamic-count-info (component)
-  (declare (ignore component))
-  (error "Dynamic statistic collection not implemented for the new-assembler.")
-  #+nil
-  (let* ((info (ir2-component-dyncount-info (component-info component)))
-	 (vops (dyncount-info-vops info)))
-    (when (producing-fasl-file)
-      (fasl-validate-structure info *compile-object*))
-    (do-ir2-blocks (block component)
-      (let* ((start-vop (ir2-block-start-vop block))
-	     (1block (ir2-block-block block))
-	     (block-number (block-number 1block)))
-	(when (and start-vop block-number)
-	  (let* ((index (1- block-number))
-		 (counts (svref vops index))
-		 (length (length counts)))
-	    (do ((vop start-vop (vop-next vop)))
-		((null vop))
-	      (let ((vop-name (vop-info-name (vop-info vop))))
-		(do ((i 0 (+ i 4)))
-		    ((or (>= i length) (eq (svref counts i) vop-name))
-		     (when (>= i length)
-		       (incf length 4)
-		       (let ((new-counts
-			      (make-array length :initial-element 0)))
-			 (when counts
-			   (replace new-counts counts))
-			 (setf counts new-counts))
-		       (setf (svref counts i) vop-name))
-		     (incf (svref counts (1+ i)))))))
-	    (setf (svref vops index) counts)))))
-    (assem:count-instructions
-     #'(lambda (vop bytes elsewherep)
-	 (let ((block-number (block-number (ir2-block-block (vop-block vop)))))
-	   (when block-number
-	     (let* ((name (vop-info-name (vop-info vop)))
-		    (counts (svref vops (1- block-number)))
-		    (length (length counts)))
-	       (do ((i 0 (+ i 4)))
-		   ((>= i length)
-		    (error "VOP ~S didn't exist earlier!~%  counts=~S"
-			   name counts))
-		 (when (eq (svref counts i) name)
-		   (incf (svref counts (+ i (if elsewherep 3 2))) bytes)
-		   (return)))))))
-     *code-segment*
-     *elsewhere*))
-  (undefined-value))
diff --git a/compiler/entry.lisp b/compiler/entry.lisp
deleted file mode 100644
index f750d93967e10beceed38f2b6be167c82345af06..0000000000000000000000000000000000000000
--- a/compiler/entry.lisp
+++ /dev/null
@@ -1,126 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/entry.lisp,v 1.9 1991/05/16 00:24:38 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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, initializing each XEP's
-;;; 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.  If there was a forward reference to a
-;;; function, then the ENTRY-INFO will already exist, but will be
-;;; uninitialized.
-;;;
-(defun entry-analyze (component)
-  (let ((2comp (component-info component)))
-    (dolist (fun (component-lambdas component))
-      (when (external-entry-point-p fun)
-	(let ((info (or (leaf-info fun)
-			(setf (leaf-info fun) (make-entry-info)))))
-	  (compute-entry-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
-;;;
-;;;    Initialize Info structure to correspond to the XEP lambda Fun.
-;;;
-(defun compute-entry-info (fun info)
-  (declare (type clambda fun) (type entry-info info))
-  (let ((bind (lambda-bind fun))
-	(internal-fun (functional-entry-function fun)))
-    (setf (entry-info-closure-p info)
-	  (not (null (environment-closure (lambda-environment fun)))))
-    (setf (entry-info-offset info) (gen-label))
-    (setf (entry-info-name info)
-	  (let ((name (leaf-name internal-fun)))
-	    (or name
-		(component-name (block-component (node-block bind))))))
-    (when (policy bind (>= debug 1))
-      (setf (entry-info-arguments info) (make-arg-names internal-fun))
-      (setf (entry-info-type info) (type-specifier (leaf-type internal-fun)))))
-  (undefined-value))
-
-
-;;; REPLACE-TOP-LEVEL-XEPS  --  Interface
-;;;
-;;;    Replace all references to Component's non-closure XEPS that appear in
-;;; top-level components, changing to :TOP-LEVEL-XEP functionals.  If the
-;;; cross-component ref is not in a :TOP-LEVEL component, or is to a closure,
-;;; then substitution is suppressed.
-;;;
-;;; When a cross-component ref is not substituted, we return T to indicate that
-;;; early deletion of this component's IR1 should not be done.  We also return
-;;; T if this component contains :TOP-LEVEL lambdas (though it is not a
-;;; :TOP-LEVEL component.)
-;;;
-;;; We deliberately don't use the normal reference deletion, since we don't
-;;; want to trigger deletion of the XEP (although it shouldn't hurt, since this
-;;; is called after Component is compiled.)  Instead, we just clobber the
-;;; REF-LEAF.
-;;;
-(defun replace-top-level-xeps (component)
-  (let ((res nil))
-    (dolist (lambda (component-lambdas component))
-      (case (functional-kind lambda)
-	(:external
-	 (let* ((ef (functional-entry-function lambda))
-		(new (make-functional :kind :top-level-xep
-				      :info (leaf-info lambda)
-				      :name (leaf-name ef)
-				      :lexenv (make-null-environment)))
-		(closure (environment-closure
-			  (lambda-environment (main-entry ef)))))
-	   (dolist (ref (leaf-refs lambda))
-	     (let ((ref-component (block-component (node-block ref))))
-	       (cond ((eq ref-component component))
-		     ((or (not (eq (component-kind ref-component) :top-level))
-			  closure)
-		      (setq res t))
-		     (t
-		      (setf (ref-leaf ref) new)
-		      (push ref (leaf-refs new))))))))
-	(:top-level
-	 (setq res t))))
-    res))
diff --git a/compiler/envanal.lisp b/compiler/envanal.lisp
deleted file mode 100644
index 5c91803e973c12ef6651a78b1009ce64181785d4..0000000000000000000000000000000000000000
--- a/compiler/envanal.lisp
+++ /dev/null
@@ -1,394 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/envanal.lisp,v 1.22 1992/09/15 17:46:41 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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] Scan the blocks in the component closing over non-local-exit
-;;;     continuations.
-;;;  4] Delete all non-top-level functions with no references.  This should
-;;;     only get functions with non-NULL kinds, since normal functions are
-;;;     deleted when their references go to zero.  If *byte-compiling*, then
-;;;     don't delete optional entries with no references, since the byte
-;;;     interpreter wants to call entries that the XEP doesn't.
-;;;
-(defun environment-analyze (component)
-  (declare (type component component))
-  (assert (not (component-new-functions component)))
-  (dolist (fun (component-lambdas component))
-    (reinit-lambda-environment fun))
-  (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)
-
-  (dolist (fun (component-lambdas component))
-    (when (null (leaf-refs fun))
-      (let ((kind (functional-kind fun)))
-	(unless (or (eq kind :top-level)
-		    (and *byte-compiling* (eq kind :optional)))
-	  (assert (member kind '(:optional :cleanup :escape)))
-	  (setf (functional-kind fun) nil)
-	  (delete-functional fun)))))
-
-  (undefined-value))
-
-
-;;; PRE-ENVIRONMENT-ANALYZE-TOP-LEVEL  --  Interface
-;;;
-;;;    Called on component with top-level lambdas before the compilation of the
-;;; associated non-top-level code to detect closed over top-level variables.
-;;; We just do COMPUTE-CLOSURE on all the lambdas.  This will pre-allocate
-;;; environments for all the functions with closed-over top-level variables.
-;;; The post-pass will use the existing structure, rather than allocating a new
-;;; one.
-;;;
-(defun pre-environment-analyze-top-level (component)
-  (declare (type component component))
-  (dolist (lambda (component-lambdas component))
-    (compute-closure lambda)
-    (dolist (let (lambda-lets lambda))
-      (compute-closure let)))
-  (undefined-value))
-
-
-;;; GET-LAMBDA-ENVIRONMENT  --  Internal
-;;;
-;;;    If Fun has an environment, return it, otherwise assign one.
-;;;
-(defun get-lambda-environment (fun)
-  (declare (type clambda fun))
-  (let* ((fun (lambda-home fun))
-	 (env (lambda-environment fun)))
-    (or env
-	(let ((res (make-environment :function fun)))
-	  (setf (lambda-environment fun) res)
-	  (dolist (lambda (lambda-lets fun))
-	    (setf (lambda-environment lambda) res))
-	  res))))
-
-
-;;; REINIT-LAMBDA-ENVIRONMENT  --  Internal
-;;;
-;;;    If Fun has no environment, assign one, otherwise clean up variables that
-;;; have no sets or refs.  If a var has no references, we remove it from the
-;;; closure.  If it has no sets, we clear the INDIRECT flag.  This is
-;;; necessary because pre-analysis is done before optimization.
-;;;
-(defun reinit-lambda-environment (fun)
-  (let ((old (lambda-environment (lambda-home fun))))
-    (cond (old
-	   (setf (environment-closure old)
-		 (delete-if #'(lambda (x)
-				(and (lambda-var-p x)
-				     (null (leaf-refs x))))
-			    (environment-closure old)))
-	   (flet ((clear (fun)
-		    (dolist (var (lambda-vars fun))
-		      (unless (lambda-var-sets var)
-			(setf (lambda-var-indirect var) nil)))))
-	     (clear fun)
-	     (dolist (let (lambda-lets fun))
-	       (clear let))))
-	  (t
-	   (get-lambda-environment fun))))
-  (undefined-value))
-
-
-;;; GET-NODE-ENVIRONMENT  --  Internal
-;;;
-;;;    Get node's environment, assigning one if necessary.
-;;; 
-(defun get-node-environment (node)
-  (declare (type node node))
-  (get-lambda-environment (node-home-lambda node)))
-
-
-;;; 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 (get-lambda-environment fun)))
-    (note-unreferenced-vars fun)
-    (dolist (var (lambda-vars fun))
-      (dolist (ref (leaf-refs var))
-	(let ((ref-env (get-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 (get-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 (get-node-environment call) home-env))))
-  (undefined-value))
-
-
-;;;; Non-local exit:
-
-
-;;; 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 link to
-;;; the component head.  Similarly, the Exit block is linked to the component
-;;; tail.  This leaves the entry stub reachable, but makes the flow graph less
-;;; confusing to flow analysis.
-;;;
-;;; If a catch or an unwind-protect, then we set the Lexenv for the last node
-;;; in the cleanup code to be the enclosing environment, to represent the fact
-;;; that the binding was undone as a side-effect of the exit.  This will cause
-;;; a lexical exit to be broken up if we are actually exiting the scope (i.e.
-;;; a BLOCK), and will also do any other cleanups that may have to be done on
-;;; the way.
-;;;
-(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 (entry-cleanup (exit-entry exit)))
-	 (info (make-nlx-info :cleanup cleanup
-			      :continuation (node-cont exit)))
-	 (entry (exit-entry exit))
-	 (new-block (insert-cleanup-code exit-block next-block
-					 entry
-					 `(%nlx-entry ',info)
-					 (entry-cleanup entry)))
-	 (component (block-component new-block)))
-    (unlink-blocks exit-block new-block)
-    (link-blocks exit-block (component-tail component))
-    (link-blocks (component-head component) new-block)
-    
-    (setf (nlx-info-target info) new-block)
-    (push info (environment-nlx-info env))
-    (push info (cleanup-nlx-info cleanup))
-    (when (member (cleanup-kind cleanup) '(:catch :unwind-protect))
-      (setf (node-lexenv (block-last new-block))
-	    (node-lexenv entry))))
-  
-  (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 move the exit block link to the component tail.
-;;; -- 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.  We then also change the %NLX-ENTRY call to use
-;;;    the NLX continuation so that there will be a use to represent the NLX
-;;;    use.
-;;;
-(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 (node-home-lambda 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)))
-	  (link-blocks block (component-tail (block-component 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)
-	(mapc #'(lambda (x)
-		  (setf (node-derived-type x) *wild-type*))
-	      (leaf-refs exit-fun))
-	(substitute-leaf (find-constant info) exit-fun)
-	(let ((node (block-last (nlx-info-target info))))
-	  (delete-continuation-use node)
-	  (add-continuation-use node (nlx-info-continuation info))))))
-
-  (undefined-value))
-
-
-;;; Find-Non-Local-Exits  --  Internal
-;;;
-;;;    Iterate over the Exits 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))
-  (dolist (lambda (component-lambdas component))
-    (dolist (entry (lambda-entries lambda))
-      (dolist (exit (entry-exits entry))
-	(let ((target-env (node-environment entry)))
-	  (if (eq (node-environment exit) target-env)
-	      (unless *converting-for-interpreter*
-		(maybe-delete-exit exit))
-	      (note-non-local-exit target-env exit))))))
-
-  (undefined-value))
-
-
-;;;; Cleanup emission:
-
-;;; Emit-Cleanups  --  Internal
-;;;
-;;;    Zoom up the cleanup nesting 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.
-;;;
-;;; If we do insert cleanup code, we check that Block1 doesn't end in a "tail"
-;;; local call.
-;;;
-;;;    We don't need to adjust the ending cleanup of the cleanup block, since
-;;; the cleanup blocks are inserted at the start of the DFO, and are thus never
-;;; scanned.
-;;;
-(defun emit-cleanups (block1 block2)
-  (declare (type cblock block1 block2))
-  (collect ((code)
-	    (reanalyze-funs))
-    (let ((cleanup2 (block-start-cleanup block2)))
-      (do ((cleanup (block-end-cleanup block1)
-		    (node-enclosing-cleanup (cleanup-mess-up cleanup))))
-	  ((eq cleanup cleanup2))
-	(let* ((node (cleanup-mess-up 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))))
-	    ((:block :tagbody)
-	     (dolist (nlx (cleanup-nlx-info cleanup))
-	       (code `(%lexical-exit-breakup ',nlx)))))))
-
-      (when (code)
-	(assert (not (node-tail-p (block-last block1))))
-	(insert-cleanup-code block1 block2
-			     (block-last block1)
-			     `(progn ,@(code)))
-	(dolist (fun (reanalyze-funs))
-	  (local-call-analyze-1 fun)))))
-
-  (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.  We ignore the
-;;; cleanup transition if it is to a cleanup enclosed by the current cleanup,
-;;; since in that case we are just messing up the environment, hence this is
-;;; not the place to clean it.
-;;;
-(defun find-cleanup-points (component)
-  (declare (type component component))
-  (do-blocks (block1 component)
-    (let ((env1 (block-environment block1))
-	  (cleanup1 (block-end-cleanup block1)))
-      (dolist (block2 (block-succ block1))
-	(when (block-start block2)
-	  (let ((env2 (block-environment block2))
-		(cleanup2 (block-start-cleanup block2)))
-	    (unless (or (not (eq env2 env1))
-			(eq cleanup1 cleanup2)
-			(and cleanup2
-			     (eq (node-enclosing-cleanup
-				  (cleanup-mess-up cleanup2))
-				 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 in order 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)))
-	  (do-uses (use result)
-	    (when (and (immediately-used-p result use)
-		     (or (not (eq (node-derived-type use) *empty-type*))
-			 (not (basic-combination-p use))
-			 (eq (basic-combination-kind use) :local)))
-		(setf (node-tail-p use) t)))))))
-  (undefined-value))
diff --git a/compiler/eval-comp.lisp b/compiler/eval-comp.lisp
deleted file mode 100644
index e7c505c80023d156960d5875eb6c766ef7e30b50..0000000000000000000000000000000000000000
--- a/compiler/eval-comp.lisp
+++ /dev/null
@@ -1,308 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/eval-comp.lisp,v 1.22 1992/11/25 10:32:12 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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*
-		    *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* *lexical-environment*))
-
-(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)
-	   (*lexical-environment* (make-null-environment))
-	   ;;
-	   (*compiler-error-output*
-	    (if quietly
-		(make-broadcast-stream)
-		*error-output*))
-	   (*compiler-trace-output* nil)
-	   (*compiler-error-bailout*
-	    #'(lambda () (error "Fatal error, aborting evaluation.")))
-	   ;;
-	   (*current-path* 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)
-	   ;;
-	   (*compiler-error-count* 0)
-	   (*compiler-warning-count* 0)
-	   (*compiler-note-count* 0)
-	   (*source-info* (make-lisp-source-info form))
-	   (*converting-for-interpreter* t)
-	   (*gensym-counter* 0))
-
-      (clear-stuff nil)
-      (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.
-      (with-compilation-unit ()
-	(let ((lambdas (list (ir1-top-level form '(original-source-start 0 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)))
-	  (multiple-value-bind (components top-components)
-			       (find-initial-dfo lambdas)
-	    (let ((*all-components* (append components top-components)))
-	      (when *check-consistency*
-		(check-ir1-consistency *all-components*))
-	      ;;
-	      ;; This DOLIST body comes from the beginning of
-	      ;; COMPILE-COMPONENT.
-	      (dolist (component *all-components*)
-		(ir1-finalize component)
-		(let ((*compile-component* component))
-		  (environment-analyze component))
-		(annotate-component-for-eval component))
-	    (when *check-consistency*
-	      (check-ir1-consistency *all-components*))))
-	  (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)
-  (let ((entry-cleanup (entry-cleanup entry)))
-    (dolist (nlx (environment-nlx-info (node-environment entry))
-		 :local-lexical-exit)
-      (let ((cleanup (nlx-info-cleanup nlx)))
-	(when (eq entry-cleanup cleanup)
-	  (ecase (cleanup-kind cleanup)
-	    ((:block :tagbody)
-	     (return :non-local-lexical-exit))
-	    ((:catch :unwind-protect)
-	     (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)))
-
-;;; Use (SETF SYMBOL-FUNCTION) insetad of DEFUN so that the compiler
-;;; doesn't try to compile the hidden %THROW MV-CALL in the throw below as
-;;; a local recursive call.
-;;;
-(setf (symbol-function '%throw)
-      #'(lambda (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)))
-
-(defun %cleanup-point ())
-
-(defun value-cell-ref (x) (value-cell-ref x))
diff --git a/compiler/eval.lisp b/compiler/eval.lisp
deleted file mode 100644
index 557f2668d92ceaa68848a347751aca50be7e292e..0000000000000000000000000000000000000000
--- a/compiler/eval.lisp
+++ /dev/null
@@ -1,1291 +0,0 @@
-;;; -*- Package: eval; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/eval.lisp,v 1.20 1992/09/07 15:37:19 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the interpreter.  We first convert to the compiler's
-;;; IR1 and interpret that.
-;;;
-;;; Written by Rob MacLachlan and Bill Chiles.
-;;;
-
-(in-package "EVAL")
-
-(export '(internal-eval *eval-stack-trace* *internal-apply-node-trace*
-			*interpreted-function-cache-minimum-size*
-			*interpreted-function-cache-threshold*
-			flush-interpreted-function-cache
-			trace-eval interpreted-function-p
-			interpreted-function-lambda-expression
-			interpreted-function-closure
-			interpreted-function-name
-			interpreted-function-arglist
-			interpreted-function-type
-			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
-				      :arglist (second 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)
-    (let ((name (eval-function-name eval-fun)))
-      (setf (c::leaf-name new) name)
-      (setf (c::leaf-name (c::main-entry (c::functional-entry-function new)))
-	    name))
-    (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 (let ((env (c::functional-lexenv fun)))
-			(or (c::lexenv-functions env)
-			    (c::lexenv-variables env)
-			    (c::lexenv-blocks env)
-			    (c::lexenv-tags env)))
-		      t nil)
-		  (or (eval-function-name eval-fun)
-		      (c::component-name
-		       (c::block-component
-			(c::node-block (c::lambda-bind fun))))))))))
-
-
-;;; INTERPRETED-FUNCTION-TYPE  --  Interface
-;;;
-;;;    Return a FUNCTION-TYPE describing an eval function.  We just grab the
-;;; LEAF-TYPE of the definition, converting the definition if not currently
-;;; cached.
-;;;
-(defvar *already-looking-for-type-of* nil)
-;;;
-(defun interpreted-function-type (fun)
-  (if (member fun *already-looking-for-type-of*)
-      (specifier-type 'function)
-      (let* ((*already-looking-for-type-of*
-	      (cons fun *already-looking-for-type-of*))
-	     (eval-fun (get-eval-function fun))
-	     (def (or (eval-function-definition eval-fun)
-		      (system:without-gcing
-		       (convert-eval-fun eval-fun)
-		       (eval-function-definition eval-fun)))))
-	(c::leaf-type (c::functional-entry-function def)))))
-
-
-;;; 
-;;; 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) (val x)
-  (let* ((eval-fun (get-eval-function x))
-	 (def (eval-function-definition eval-fun)))
-    (when def
-      (setf (c::leaf-name def) val)
-      (setf (c::leaf-name (c::main-entry (c::functional-entry-function def)))
-	    val))
-    (setf (eval-function-name eval-fun) val)))
-;;;
-(defun interpreted-function-arglist (x)
-  (eval-function-arglist (get-eval-function x)))
-;;;
-(defun (setf interpreted-function-arglist) (val x)
-  (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*)
-
-
-;;; FLUSH-INTERPRETED-FUNCTION-CACHE  --  Interface
-;;;
-(defun flush-interpreted-function-cache ()
-  "Clear all entries in the eval function cache.  This allows the internal
-  representation of the functions to be reclaimed, and also lazily forces
-  macroexpansions to be recomputed."
-  (dolist (fun *interpreted-function-cache*)
-    (setf (eval-function-definition fun) nil))
-  (setq *interpreted-function-cache* ()))
-
-
-;;;; 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)
-				nil))))
-	 (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
-					nil)))))))
-    `(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))
-	 (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)
-	  ;;
-	  ;; Discard the NLX-INFO arg...
-	  (eval-stack-pop)
-	  (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 ((member ,kind '(:full :error))
-	      (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 '#()))
-	(internal-apply res 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.
-;;;
-;;; Args is the list of arguments to apply to.  If IGNORE-UNUSED is true, then
-;;; values for un-read variables are present in the argument list, and must be
-;;; discarded (always true except in a local call.)  Args may run out of values
-;;; before vars runs out of variables (in the case of an XEP with optionals);
-;;; we just do CAR of nil and store nil.  This is not the proper defaulting
-;;; (which is done by explicit code in the XEP.)
-;;;
-(defun internal-apply (lambda args closure &optional (ignore-unused t))
-  (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))
-	((null vars))
-      (let ((var (car vars)))
-	(cond ((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 (pop args))
-			 (pop args))))
-	      (ignore-unused (pop 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)
-  (declare (optimize (debug-info 2)))
-  (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))
-			   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)))
-			 
-			 (when (eq values :fell-through)
-			   ;; We hit a %LEXICAL-EXIT-BREAKUP.
-			   ;; Interpreting state is set with MV-SETQ above.
-			   ;; Just get out of this branch and go on.
-			   (return))
-			 
-			 (unless (eq values :non-local-go)
-			   ;; We know we're non-locally exiting from a
-			   ;; BLOCK with values (saw a RETURN-FROM).
-			   (ecase (c::continuation-info cont)
-			     (:single
-			      (eval-stack-push (car values)))
-			     ((:multiple :return)
-			      (eval-stack-push values))
-			     (:unused)))
-			 ;;
-			 ;; Start interpreting again at the target, skipping
-			 ;; the %NLX-ENTRY block.
-			 (setf node
-			       (c::continuation-next
-				(c::block-start
-				 (car (c::block-succ block))))))))))))
-	    (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::block-environment (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)))
-	  ;; See function doc below.
-	  (reference-this-var-to-keep-it-alive node)
-	  (reference-this-var-to-keep-it-alive frame-ptr)
-	  (reference-this-var-to-keep-it-alive closure)
-	  (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)))))))))
-
-;;; REFERENCE-THIS-VAR-TO-KEEP-IT-ALIVE -- Internal.
-;;;
-;;; This function allows a reference to a variable that the compiler cannot
-;;; easily eliminate as unnecessary.  We use this at the end of the node
-;;; dispatch in INTERNAL-APPLY-LOOP to make sure the node variable has a
-;;; valid value.  Each node branch tends to reference it at the beginning,
-;;; and then there is no reference but a set at the end; the compiler then
-;;; kills the variable between the reference in the dispatch branch and when
-;;; we set it at the end.  The problem is that most error will occur in the
-;;; interpreter within one of these node dispatch branches.
-;;;
-(defun reference-this-var-to-keep-it-alive (node)
-  node)
-
-
-;;; 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
-       (set-leaf-value-lambda-var node var frame-ptr closure value)))))
-
-;;; SET-LEAF-VALUE-LAMBDA-VAR -- Internal Interface.
-;;;
-;;; This does SET-LEAF-VALUE for a lambda-var leaf.  The debugger tools'
-;;; internals uses this also to set interpreted local variables.
-;;;
-(defun set-leaf-value-lambda-var (node var frame-ptr closure value)
-  (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
-       (locally (declare (optimize (safety 1)))
-	 (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
-       (leaf-value-lambda-var node leaf frame-ptr closure))
-      (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::lexenv-functions
-			    (c::functional-lexenv 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))))))))))
-
-;;; LEAF-VALUE-LAMBDA-VAR -- Internal Interface.
-;;;
-;;; This does LEAF-VALUE for a lambda-var leaf.  The debugger tools' internals
-;;; uses this also to reference interpreted local variables.
-;;;
-(defun leaf-value-lambda-var (node leaf frame-ptr closure)
-  (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)))
-
-;;; 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::block-environment (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::cleanup-mess-up (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)
-      (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/float-tran.lisp b/compiler/float-tran.lisp
deleted file mode 100644
index 8f4cbd29f75ea11e5f7bee055464a4db063cd2c2..0000000000000000000000000000000000000000
--- a/compiler/float-tran.lisp
+++ /dev/null
@@ -1,291 +0,0 @@
-;;; -*- Mode: Lisp; Package: C; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.14 1992/08/13 18:03:59 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains floating-point specific transforms, and may be somewhat
-;;; implementation dependent in its assumptions of what the formats are.
-;;;
-;;; Author: Rob MacLachlan
-;;; 
-(in-package "C")
-
-
-;;;; Coercions:
-
-#-new-compiler
-(progn
-  (defun %single-float (x) (coerce x 'single-float))
-  (defun %double-float (x) (coerce x 'double-float)))
-
-(defknown %single-float (real) single-float (movable foldable flushable))
-(defknown %double-float (real) double-float (movable foldable flushable))
-
-(deftransform float ((n &optional f) (* &optional single-float))
-  '(%single-float n))
-
-(deftransform float ((n f) (* double-float))
-  '(%double-float n))
-
-(deftransform %single-float ((n) (single-float))
-  'n)
-
-(deftransform %double-float ((n) (double-float))
-  'n)
-
-(deftransform coerce ((n type)
-		      (* (constant-argument
-			  (member float short-float single-float))))
-  '(%single-float n))
-
-(deftransform coerce ((n type)
-		      (* (constant-argument
-			  (member double-float long-float))))
-  '(%double-float n))
-
-;;; Not strictly float functions, but primarily useful on floats:
-;;;
-(macrolet ((frob (fun ufun)
-	     `(progn
-		(defknown ,ufun (real) integer (movable foldable flushable))
-		(deftransform ,fun ((x &optional by)
-				    (* &optional
-				       (constant-argument (member 1))))
-		  '(let ((res (,ufun x)))
-		     (values res (- x res)))))))
-  (frob truncate %unary-truncate)
-  (frob round %unary-round))
-
-
-;;;; Float accessors:
-
-(defknown make-single-float ((signed-byte 32)) single-float
-  (movable foldable flushable))
-
-(defknown make-double-float ((signed-byte 32) (unsigned-byte 32)) double-float
-  (movable foldable flushable))
-
-(defknown single-float-bits (single-float) (signed-byte 32)
-  (movable foldable flushable))
-
-(defknown double-float-high-bits (double-float) (signed-byte 32)
-  (movable foldable flushable))
-
-(defknown double-float-low-bits (double-float) (unsigned-byte 32)
-  (movable foldable flushable))
-
-
-(defun make-single-float (x) (make-single-float x))
-(defun make-double-float (hi lo) (make-double-float hi lo))
-(defun single-float-bits (x) (single-float-bits x))
-(defun double-float-high-bits (x) (double-float-high-bits x))
-(defun double-float-low-bits (x) (double-float-low-bits x))
-
-(def-source-transform float-sign (float1 &optional (float2 nil f2-p))
-  (let ((n-f1 (gensym)))
-    (if f2-p
-	`(* (float-sign ,float1) (abs ,float2))
-	`(let ((,n-f1 ,float1))
-	   (declare (float ,n-f1))
-	   (if (minusp (if (typep ,n-f1 'single-float)
-			   (single-float-bits ,n-f1)
-			   (double-float-high-bits ,n-f1)))
-	       (float -1 ,n-f1)
-	       (float 1 ,n-f1))))))
-
-
-;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, SCALE-FLOAT:
-;;;
-;;;    Convert these operations to format specific versions when the format is
-;;; known.
-;;;
-
-(deftype single-float-exponent ()
-  `(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias
-		vm:single-float-digits)
-	    ,(- vm:single-float-normal-exponent-max vm:single-float-bias)))
-
-(deftype double-float-exponent ()
-  `(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias
-		vm:double-float-digits)
-	    ,(- vm:double-float-normal-exponent-max vm:double-float-bias)))
-
-
-(deftype single-float-int-exponent ()
-  `(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias
-		(* vm:single-float-digits 2))
-	    ,(- vm:single-float-normal-exponent-max vm:single-float-bias
-		vm:single-float-digits)))
-
-(deftype double-float-int-exponent ()
-  `(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias
-		(* vm:double-float-digits 2))
-	    ,(- vm:double-float-normal-exponent-max vm:double-float-bias
-		vm:double-float-digits)))
-
-(deftype single-float-significand ()
-  `(integer 0 (,(ash 1 vm:single-float-digits))))
-
-(deftype double-float-significand ()
-  `(integer 0 (,(ash 1 vm:double-float-digits))))
-
-(defknown decode-single-float (single-float)
-  (values single-float single-float-exponent (single-float -1f0 1f0))
-  (movable foldable flushable))
-
-(defknown decode-double-float (double-float)
-  (values double-float double-float-exponent (double-float -1d0 1d0))
-  (movable foldable flushable))
-
-(defknown integer-decode-single-float (single-float)
-  (values single-float-significand single-float-int-exponent (integer -1 1))
-  (movable foldable flushable))
-
-(defknown integer-decode-double-float (double-float)
-  (values double-float-significand double-float-int-exponent (integer -1 1))
-  (movable foldable flushable)))
-
-(defknown scale-single-float (single-float fixnum) single-float
-  (movable foldable flushable))
-
-(defknown scale-double-float (double-float fixnum) double-float
-  (movable foldable flushable))
-
-(deftransform decode-float ((x) (single-float))
-  '(decode-single-float x))
-
-(deftransform decode-float ((x) (double-float))
-  '(decode-double-float x))
-
-(deftransform integer-decode-float ((x) (single-float))
-  '(integer-decode-single-float x))
-
-(deftransform integer-decode-float ((x) (double-float))
-  '(integer-decode-double-float x))
-
-(deftransform scale-float ((f ex) (single-float *))
-  '(scale-single-float f ex))
-
-(deftransform scale-float ((f ex) (double-float *))
-  '(scale-double-float f ex))
-
-
-;;;; Float contagion:
-
-;;; FLOAT-CONTAGION-ARG1, ARG2  --  Internal
-;;;
-;;;    Do some stuff to recognize when the luser is doing mixed float and
-;;; rational arithmetic, or different float types, and fix it up.  If we don't,
-;;; he won't even get so much as an efficency note.
-;;;
-(deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node)
-  `(,(continuation-function-name (basic-combination-fun node))
-    (float x y) y))
-;;;
-(deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node)
-  `(,(continuation-function-name (basic-combination-fun node))
-    x (float y x)))
-
-(dolist (x '(+ * / -))
-  (%deftransform x '(function (rational float) *) #'float-contagion-arg1)
-  (%deftransform x '(function (float rational) *) #'float-contagion-arg2))
-
-(dolist (x '(= < > + * / -))
-  (%deftransform x '(function (single-float double-float) *)
-		 #'float-contagion-arg1)
-  (%deftransform x '(function (double-float single-float) *)
-		 #'float-contagion-arg2))
-
-
-;;; Prevent zerop, plusp, minusp from losing horribly.  We can't in general
-;;; float rational args to comparison, since Common Lisp semantics says we are
-;;; supposed to compare as rationals, but we can do it for any rational that
-;;; has a precise representation as a float (such as 0).
-;;;
-(macrolet ((frob (op)
-	     `(deftransform ,op ((x y) (float rational))
-		(unless (constant-continuation-p y)
-		  (give-up "Can't open-code float to rational comparison."))
-		(let ((val (continuation-value y)))
-		  (unless (eql (rational (float val)) val)
-		    (give-up "~S doesn't have a precise float representation."
-			     val)))
-		`(,',op x (float y x)))))
-  (frob <)
-  (frob >)
-  (frob =))
-
-
-;;;; Irrational derive-type methods:
-
-;;; Derive the result to be float for argument types in the appropriate domain.
-;;;
-(dolist (stuff '((asin (real (-1.0) (1.0)))
-		 (acos (real (-1.0) (1.0)))
-		 (acosh (real 1.0))
-		 (atanh (real (-1.0) (1.0)))
-		 (sqrt (real 0.0))))
-  (destructuring-bind (name type) stuff
-    (let ((type (specifier-type type)))
-      (setf (function-info-derive-type (function-info-or-lose name))
-	    #'(lambda (call)
-		(declare (type combination call))
-		(when (csubtypep (continuation-type
-				  (first (combination-args call)))
-				 type)
-		  (specifier-type 'float)))))))
-
-
-;;;; Irrational transforms:
-
-(defknown (%sin %cos %tan %asin %acos %atan %sinh %cosh %tanh %asinh
-		%acosh %atanh %exp %expm1 %log %log10 %log1p %cbrt %sqrt)
-	  (double-float) double-float
-  (movable foldable flushable))
-
-(defknown (%atan2 %pow %hypot)
-	  (double-float double-float) double-float
-  (movable foldable flushable))
-
-(dolist (stuff '((exp %exp *)
-		 (log %log float)
-		 (sqrt %sqrt float)
-		 (sin %sin *)
-		 (cos %cos *)
-		 (tan %tan *)
-		 (asin %asin float)
-		 (acos %acos float)
-		 (atan %atan *)
-		 (sinh %sinh *)
-		 (cosh %cosh *)
-		 (tanh %tanh *)
-		 (asinh %asinh *)
-		 (acosh %acosh float)
-		 (atanh %atanh float)))
-  (destructuring-bind (name prim rtype) stuff
-    (deftransform name ((x) '(single-float) rtype :eval-name t)
-      `(coerce (,prim (coerce x 'double-float)) 'single-float))
-    (deftransform name ((x) '(double-float) rtype :eval-name t)
-      `(,prim x))))
-
-(dolist (stuff '((expt %pow t)
-		 (atan %atan2 t)))
-  (destructuring-bind (name prim rtype) stuff
-    (deftransform name ((x y) '(single-float) rtype :eval-name t)
-      `(coerce (,prim (coerce x 'double-float)
-		      (coerce y 'double-float))
-	       'single-float))
-    (deftransform name ((x y) '(double-float) rtype :eval-name t)
-      `(,prim x y))))
-
-(deftransform log ((x y) (float float) float)
-  '(/ (log x) (log y)))
-
diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp
deleted file mode 100644
index 8320ff95c4801e8d31ded21e13ae078477d8cac5..0000000000000000000000000000000000000000
--- a/compiler/fndb.lisp
+++ /dev/null
@@ -1,1163 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.52 1992/12/17 14:35:07 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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
-	  %puthash
-	  %rplaca
-	  %rplacd
-	  %sbitset
-	  %scharset
-	  %set-documentation
-	  %set-fdefinition
-	  %set-fill-pointer
-	  %set-row-major-aref
-	  %setelt
-	  %setnth
-	  %standard-char-p
-	  %svset
-	  %typep
-	  array-header-p
-	  base-char-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 "KERNEL")
-
-(export '(%caller-frame-and-pc %with-array-data))
-
-(in-package 'c)
-
-
-;;;; Information for known functions:
-
-(defknown coerce (t type-specifier) t
-	  (movable foldable)			  ; Is defined to signal errors. 
-  :derive-type (result-type-specifier-nth-arg 2))
-
-(defknown type-of (t) t (foldable flushable))
-
-;;; Can be affected by type definitions...
-(defknown (upgraded-complex-part-type upgraded-array-element-type)
-	  (type-specifier) type-specifier
-  (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 not)
-  (t) boolean (movable foldable flushable))
-
-
-(defknown (eq eql) (t t) boolean (movable foldable flushable))
-(defknown (equal equalp) (t t) boolean (foldable flushable recursive))
-
-
-;;;; 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 explicit-check))
-(defknown special-form-p (symbol) t (movable foldable flushable)) ; They never change...
-(defknown set (symbol t) t (unsafe)
-  :derive-type #'result-type-last-arg)
-(defknown fdefinition ((or symbol cons)) function (unsafe explicit-check))
-(defknown %set-fdefinition ((or symbol cons) function) function
-  (unsafe explicit-check))
-(defknown makunbound (symbol) symbol)
-(defknown fmakunbound ((or symbol cons)) (or symbol cons)
-  (unsafe explicit-check))
-(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))
-
-;;; We let values-list be foldable, since constant-folding will turn it into
-;;; VALUES.  VALUES is not foldable, since MV constants are represented by a
-;;; call to VALUES.
-;;; 
-(defknown values (&rest t) * (movable flushable unsafe))
-(defknown values-list (list) * (movable foldable flushable))
-
-
-;;;; In the "Macros" chapter:
-
-(defknown macro-function (symbol &optional lexical-environment)
-  (or function null)
-  (flushable))
-(defknown (macroexpand macroexpand-1) (t &optional lexical-environment)
-  (values form &optional boolean))
-
-(defknown compiler-macro-function (t &optional lexical-environment)
-  (or function null)
-  (flushable))
-(defknown (compiler-macroexpand compiler-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 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))
-
-;;; Should allow a package name, I think, tho CLtL II doesn't say so...
-(defknown gentemp (&optional string packagelike) symbol)
-
-(defknown make-package (stringlike &key (:use list) (:nicknames list)
-				   ;; ### Extensions...
-				   (:internal-symbols index) (:external-symbols index))
-	  package)
-(defknown find-package (stringlike) (or package null) (flushable))
-(defknown package-name (packagelike) (or simple-string null) (flushable))
-(defknown package-nicknames (packagelike) list (flushable))
-(defknown rename-package (packagelike stringlike &optional list) package)
-(defknown package-use-list (packagelike) list (flushable))
-(defknown package-used-by-list (packagelike) list (flushable))
-(defknown package-shadowing-symbols (packagelike) list (flushable))
-(defknown list-all-packages () list (flushable))
-(defknown intern (string &optional packagelike)
-  (values symbol (member :internal :external :inherited nil))
-  ())
-(defknown find-symbol (string &optional packagelike)
-	  (values symbol (member :internal :external :inherited nil))
-	  (flushable))
-(defknown (export import) (symbols &optional packagelike) truth)
-(defknown unintern (symbol &optional packagelike) boolean)
-(defknown unexport (symbols &optional packagelike) truth)
-(defknown shadowing-import (symbols &optional packagelike) truth)
-(defknown shadow ((or symbol string list) &optional packagelike) truth)
-(defknown (use-package unuse-package) ((or list packagelike) &optional packagelike) truth)
-(defknown find-all-symbols (stringlike) list (flushable))
-
-
-;;;; In the "Numbers" chapter:
-
-(defknown zerop (number) boolean (movable foldable flushable explicit-check))
-(defknown (plusp minusp) (real) boolean
-  (movable foldable flushable explicit-check))
-(defknown (oddp evenp) (integer) boolean
-  (movable foldable flushable explicit-check))
-(defknown (= /=) (number &rest number) boolean
-  (movable foldable flushable explicit-check))
-(defknown (< > <= >=) (real &rest real) boolean
-  (movable foldable flushable explicit-check))
-(defknown (max min) (real &rest real) real
-  (movable foldable flushable explicit-check))
-
-(defknown + (&rest number) number
-  (movable foldable flushable explicit-check))
-(defknown - (number &rest number) number
-  (movable foldable flushable explicit-check))
-(defknown * (&rest number) number
-  (movable foldable flushable explicit-check))
-(defknown / (number &rest number) number
-  (movable foldable flushable explicit-check))
-(defknown (1+ 1-) (number) number
-  (movable foldable flushable explicit-check))
-
-(defknown conjugate (number) number
-  (movable foldable flushable explicit-check))
-
-(defknown gcd (&rest integer) unsigned-byte
-  (movable foldable flushable explicit-check)
-  #|:derive-type 'boolean-result-type|#)
-(defknown lcm (&rest integer) unsigned-byte
-  (movable foldable flushable explicit-check))
-
-(defknown exp (number) irrational
-  (movable foldable flushable explicit-check recursive)
-  :derive-type #'result-type-float-contagion)
-
-(defknown expt (number number) number
-  (movable foldable flushable explicit-check recursive))
-(defknown log (number &optional real) irrational
-  (movable foldable flushable explicit-check))
-(defknown sqrt (number) irrational
-  (movable foldable flushable explicit-check))
-(defknown isqrt (unsigned-byte) unsigned-byte
-  (movable foldable flushable explicit-check))
-
-(defknown (abs phase signum) (number) number
-  (movable foldable flushable explicit-check))
-(defknown cis (real) (complex float)
-  (movable foldable flushable explicit-check))
-
-(defknown (sin cos) (number)
-  (or (float -1.0 1.0) (complex (float -1.0 1.0)))
-  (movable foldable flushable explicit-check recursive)
-  :derive-type #'result-type-float-contagion)
-
-(defknown atan
-  (number &optional real) irrational
-  (movable foldable flushable explicit-check recursive)
-  :derive-type #'result-type-float-contagion)
-
-(defknown (tan sinh cosh tanh asinh)
-  (number) irrational (movable foldable flushable explicit-check recursive)
-  :derive-type #'result-type-float-contagion)
-
-(defknown (asin acos acosh atanh)
-  (number) irrational
-  (movable foldable flushable explicit-check recursive))
-
-(defknown float (real &optional float) float
-  (movable foldable flushable explicit-check))
-
-(defknown (rational rationalize) (real) rational
-  (movable foldable flushable explicit-check))
-
-(defknown (numerator denominator) (rational) integer
-  (movable foldable flushable))
-
-(defknown (floor ceiling truncate round)
-  (real &optional real) (values integer real)
-  (movable foldable flushable explicit-check))
-
-(defknown (mod rem) (real real) real
-  (movable foldable flushable explicit-check))
-
-(defknown (ffloor fceiling fround ftruncate)
-  (real &optional real) (values float float)
-  (movable foldable flushable explicit-check))
-
-(defknown decode-float (float) (values float float-exponent float)
-  (movable foldable flushable explicit-check))
-(defknown scale-float (float float-exponent) float
-  (movable foldable flushable explicit-check))
-(defknown float-radix (float) float-radix
-  (movable foldable flushable explicit-check))
-(defknown float-sign (float &optional float) float
-  (movable foldable flushable explicit-check))
-(defknown (float-digits float-precision) (float) float-digits
-  (movable foldable flushable explicit-check))
-(defknown integer-decode-float (float)
-	  (values integer float-exponent (member -1 1))
-	  (movable foldable flushable explicit-check))
-
-(defknown complex (real &optional real) number
-  (movable foldable flushable explicit-check))
-
-(defknown (realpart imagpart) (number) real (movable foldable flushable))
-
-(defknown (logior logxor logand logeqv) (&rest integer) integer
-  (movable foldable flushable explicit-check))
-
-(defknown (lognand lognor logandc1 logandc2 logorc1 logorc2)
-	  (integer integer) integer
-  (movable foldable flushable explicit-check))
-
-(defknown boole (boole-code integer integer) integer
-  (movable foldable flushable))
-
-(defknown lognot (integer) integer (movable foldable flushable explicit-check))
-(defknown logtest (integer integer) boolean (movable foldable flushable))
-(defknown logbitp (bit-index integer) boolean (movable foldable flushable))
-(defknown ash (integer ash-index) integer (movable foldable flushable explicit-check))
-(defknown (logcount integer-length) (integer) bit-index
-  (movable foldable flushable explicit-check))
-(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 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 code-char (char-code) base-char (movable foldable flushable))
-(defknown (char-upcase char-downcase) (character) character
-  (movable foldable flushable))
-(defknown digit-char (integer &optional integer)
-  (or character null) (movable foldable flushable))
-(defknown char-int (character) char-code (movable foldable flushable))
-(defknown char-name (character) (or simple-string null)
-  (movable foldable flushable))
-(defknown name-char (stringable) (or character null)
-  (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 (sequence-result-nth-arg 1))
-
-(defknown copy-seq (sequence) consed-sequence (foldable flushable)
-  :derive-type #'result-type-first-arg)
-
-
-(defknown length (sequence) index (foldable flushable))
-
-(defknown reverse (sequence) consed-sequence (foldable flushable)
-  :derive-type #'result-type-first-arg)
-
-(defknown nreverse (sequence) sequence ()
-  :derive-type #'result-type-first-arg)
-
-(defknown make-sequence (type-specifier index &key (:initial-element t)) consed-sequence
-  (movable flushable unsafe)
-  :derive-type (result-type-specifier-nth-arg 1))
-
-(defknown concatenate (type-specifier &rest sequence) consed-sequence
-  (foldable flushable)
-  :derive-type (result-type-specifier-nth-arg 1))
-
-(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) (:key callable))
-  t
-  (foldable flushable call unsafe))
-
-(defknown fill (sequence t &key (:start index) (:end sequence-end)) sequence
-  (unsafe)
-  :derive-type #'result-type-first-arg)
-
-(defknown replace (sequence sequence &key (:start1 index) (:end1 sequence-end)
-			    (:start2 index) (:end2 sequence-end))
-  consed-sequence ()
-  :derive-type #'result-type-first-arg)
-
-(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 (sequence-result-nth-arg 2))
-
-(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 (sequence-result-nth-arg 3))
-
-(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 (sequence-result-nth-arg 2))
-
-(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 (sequence-result-nth-arg 3))
-
-(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)
-  :derive-type (sequence-result-nth-arg 2))
-
-(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)
-  :derive-type (sequence-result-nth-arg 3))
-
-(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)
-  :derive-type (sequence-result-nth-arg 2))
-
-(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)
-  :derive-type (sequence-result-nth-arg 3))
-
-(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 (sequence-result-nth-arg 1))
-
-(defknown delete-duplicates
-  (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t)
-	    (:end sequence-end) (:key callable))
-  sequence
-  (flushable call)
-  :derive-type (sequence-result-nth-arg 1))
-
-(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 (sequence-result-nth-arg 1))
-
-(defknown merge (type-specifier sequence sequence callable
-				&key (:key callable))
-  sequence
-  (flushable call)
-  :derive-type (result-type-specifier-nth-arg 1))
-
-
-;;;; 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 (movable 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))
-(defknown last (list &optional index) list (foldable flushable))
-(defknown list (&rest t) list (movable flushable unsafe))
-(defknown list* (t &rest t) t (movable flushable unsafe))
-(defknown make-list (index &key (:initial-element t)) list
-  (movable 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))
-(defknown nconc (&rest list) list ())
-(defknown nreconc (list list) list ())
-(defknown butlast (list &optional index) list (flushable))
-(defknown nbutlast (list &optional index) list ())
-(defknown ldiff (list list) list (flushable))
-(defknown (rplaca rplacd) (cons t) list (unsafe))
-
-(defknown (nsubst subst) (t t t &key (:key callable) (:test callable)
-			    (:test-not callable))
-  list (flushable unsafe call))
-
-(defknown (subst-if subst-if-not nsubst-if nsubst-if-not)
-	  (t t t &key (:key callable))
-  list (flushable unsafe call))
-
-(defknown (sublis nsublis) (list t &key (:key callable) (:test callable)
-				 (:test-not callable))
-  list (flushable unsafe call))
-
-(defknown member (t list &key (:key callable) (:test callable)
-		    (:test-not callable))
-  list (foldable flushable call))
-(defknown (member-if member-if-not) (callable list &key (:key callable))
-  list (foldable flushable call))
-
-(defknown tailp (list list) boolean (foldable flushable))
-
-(defknown adjoin (t list &key (:key callable) (:test callable)
-		    (:test-not callable))
-  list (foldable flushable unsafe call))
-
-(defknown (union intersection set-difference set-exclusive-or)
-	  (list list &key (:key callable) (:test callable) (:test-not callable))
-  list
-  (foldable flushable call))
-
-(defknown (nunion nintersection nset-difference nset-exclusive-or)
-	  (list list &key (:key callable) (:test callable) (:test-not callable))
-  list
-  (foldable flushable call))
-
-(defknown subsetp 
-	  (list list &key (:key callable) (:test callable) (:test-not callable))
-  boolean
-  (foldable flushable call))
-
-(defknown acons (t t t) list (movable flushable unsafe))
-(defknown pairlis (t t &optional t) list (flushable unsafe))
-
-(defknown (rassoc assoc)
-	  (t list &key (:key callable) (:test callable) (:test-not callable))
-  list (foldable flushable call))
-(defknown (assoc-if-not assoc-if rassoc-if rassoc-if-not)
-	  (callable list &key (:key callable)) list (foldable flushable call))
-
-
-;;;; In the "Hash Tables" chapter:
-
-(defknown make-hash-table
-  (&key (:test callable) (:size index)
-	(:rehash-size (or (integer 1) (float (1.0))))
-	(:rehash-threshold (real 0 1)))
-  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 %puthash (t hash-table t) t (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) index (foldable flushable))
-(defknown hash-table-rehash-size (hash-table) (or (integer 1) (float (1.0)))
-  (foldable flushable))
-(defknown hash-table-rehash-threshold (hash-table) (real 0 1)
-  (foldable flushable))
-(defknown hash-table-size (hash-table) index (foldable flushable))
-(defknown hash-table-test (hash-table) symbol (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 t)
-		      (: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 row-major-aref (array 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-last-arg|#)
-
-(defknown bit-not ((array bit) &optional (or (array bit) (member t)))
-  (array bit)
-  (foldable)
-  #|:derive-type #'result-type-last-arg|#)
-
-(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)
-	 (: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) character (foldable flushable))
-(defknown schar (simple-string index) character (foldable flushable))
-
-(deftype stringable () '(or character string symbol))
-
-(defknown (string= string-equal)
-  (stringable stringable &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)
-  (stringable stringable &key (:start1 index) (:end1 sequence-end)
-	      (:start2 index) (:end2 sequence-end))
-  (or index null)
-  (foldable flushable))
-
-(defknown make-string (index &key (:initial-element character))
-  simple-string (flushable))
-
-(defknown (string-trim string-left-trim string-right-trim)
-  (sequence stringable) simple-string (flushable))
-
-(defknown (string-upcase string-downcase string-capitalize)
-  (stringable &key (:start index) (:end sequence-end))
-  simple-string (flushable))
-
-(defknown (nstring-upcase nstring-downcase nstring-capitalize)
-  (string &key (:start index) (:end sequence-end))
-  string ())
-
-(defknown string (stringable) string
-  (flushable explicit-check))
-
-
-;;; Internal non-keyword versions of string predicates:
-
-(defknown (string<* string>* string<=* string>=* string/=*)
-  (stringable stringable index sequence-end index sequence-end)
-  (or index null)
-  (foldable flushable))
-
-(defknown string=*
-  (stringable stringable index sequence-end index sequence-end)
-  boolean
-  (foldable flushable))
-
-
-;;;; In the "Eval" chapter:
-
-(defknown eval (t) *)
-(defknown constantp (t) boolean (foldable flushable))
-
-
-;;;; In the "Streams" chapter:
-
-(defknown make-synonym-stream (symbol) stream (flushable))
-(defknown make-broadcast-stream (&rest stream) stream (flushable))
-(defknown make-concatenated-stream (&rest stream) stream (flushable))
-(defknown make-two-way-stream (stream stream) stream (flushable))
-(defknown make-echo-stream (stream stream) stream (flushable))
-(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
-  ())
-(defknown readtablep (t) boolean (movable foldable flushable))
-
-(defknown set-syntax-from-char
-  (character character &optional (or readtable null) readtable) void
-  ())
-
-(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 ())
-(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-no-hang read-char)
-  (&optional streamlike t t t) t  (explicit-check))
-
-(defknown read-delimited-list (character &optional streamlike t) t
-  (explicit-check))
-(defknown read-line (&optional streamlike t t t) (values t boolean)
-  (explicit-check))
-(defknown unread-char (character &optional streamlike) t
-  (explicit-check))
-(defknown peek-char (&optional (or character (member nil t)) streamlike t t t)
-  t
-  (explicit-check))
-(defknown listen (&optional streamlike) boolean (flushable explicit-check))
-
-(defknown clear-input (&optional stream) null (explicit-check))
-
-(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 (explicit-check))
-
-(defknown write
-  (t &key (:stream streamlike) (:escape t) (:radix t) (:base (integer 2 36))
-     (:circle t) (:pretty t) (:level (or unsigned-byte null)) (:readably t)
-     (:length (or unsigned-byte null)) (:case t) (:array t) (:gensym t)
-     (:lines (or unsigned-byte null)) (:right-margin (or unsigned-byte null))
-     (:miser-width (or unsigned-byte null)) (:pprint-dispatch t))
-  t
-  (any explicit-check)
-  :derive-type #'result-type-first-arg)
-
-(defknown (prin1 print princ) (t &optional streamlike) t (any explicit-check)
-  :derive-type #'result-type-first-arg)
-
-;;; xxx-TO-STRING not foldable because they depend on the dynamic environment. 
-(defknown write-to-string
-  (t &key (:escape t) (:radix t) (:base (integer 2 36)) (:readably t)
-     (:circle t) (:pretty t) (:level (or unsigned-byte null))
-     (:length (or unsigned-byte null)) (:case t) (:array t) (:gensym t)
-     (:lines (or unsigned-byte null)) (:right-margin (or unsigned-byte null))
-     (:miser-width (or unsigned-byte null)) (:pprint-dispatch t))
-  simple-string
-  (foldable flushable explicit-check))
-
-(defknown (prin1-to-string princ-to-string) (t) simple-string (flushable))
-
-(defknown write-char (character &optional streamlike) character
-  (explicit-check))
-(defknown (write-string write-line)
-  (string &optional streamlike &key (:start index) (:end sequence-end))
-  string
-  (explicit-check))
-
-(defknown (terpri finish-output force-output clear-output)
-  (&optional streamlike) null
-  (explicit-check))
-
-(defknown fresh-line (&optional streamlike) boolean
-  (explicit-check))
-
-(defknown write-byte (integer stream) integer
-  (explicit-check))
-
-(defknown format ((or streamlike string) (or string function) &rest t)
-  (or string null)
-  (explicit-check))
-
-(defknown (y-or-n-p yes-or-no-p) (&optional string &rest t) boolean
-  (explicit-check))
-
-
-;;;; In the "File System Interface" chapter:
-
-(defknown wild-pathname-p (pathnamelike &optional (member nil :host :device
-							  :directory :name
-							  :type :version))
-  boolean
-  (foldable flushable))
-(defknown pathname-match-p (pathnamelike pathnamelike) boolean
-  (foldable flushable))
-(defknown translate-pathname (pathnamelike pathnamelike pathnamelike &key)
-  pathname
-  (foldable flushable))
-
-;;; Need to add the logical pathname stuff here.
-
-(defknown pathname (pathnamelike) pathname (foldable flushable))
-(defknown truename (pathnamelike) pathname ())
-
-(defknown parse-namestring
-  (pathnamelike &optional pathname-host pathnamelike
-		&key (:start index) (:end sequence-end) (:junk-allowed t))
-  (values (or pathname null) index)
-  ())
-
-(defknown merge-pathnames
-  (pathnamelike &optional pathnamelike pathname-version)
-  pathname
-  (foldable flushable))
-
-(defknown make-pathname
- (&key (:defaults pathnamelike) (:host pathname-host) (:device pathname-device)
-       (:directory (or pathname-directory string (member :wild)))
-       (:name (or pathname-name string (member :wild)))
-       (:type (or pathname-type string (member :wild)))
-       (:version pathname-version) (:case (member :local :common)))
-  pathname (foldable flushable))
-
-(defknown pathnamep (t) boolean (movable foldable flushable))
-
-(defknown pathname-host (pathnamelike &key (:case (member :local :common)))
-  pathname-host (foldable flushable))
-(defknown pathname-device (pathnamelike &key (:case (member :local :common)))
-  pathname-device (foldable flushable))
-(defknown pathname-directory (pathnamelike &key (:case (member :local :common)))
-  pathname-directory (foldable flushable))
-(defknown pathname-name (pathnamelike &key (:case (member :local :common)))
-  pathname-name (foldable flushable))
-(defknown pathname-type (pathnamelike &key (:case (member :local :common)))
-  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))
-
-(defknown file-position (stream &optional
-				(or unsigned-byte (member :start :end)))
-  (or unsigned-byte (member t nil)))
-(defknown file-length (stream) (or unsigned-byte null) (flushable))
-
-(defknown load
-  ((or filename stream)
-   &key (:verbose t) (:print t) (:if-does-not-exist (member :error :create nil))
-   (:if-source-newer (member :load-source :load-object :query :compile))
-   (:contents (or null (member :source :binary))))
-  t)
-
-(defknown directory (pathnamelike &key (:check-for-subdirs t) (:all t)
-				  (:follow-links t))
-  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 (or list function null))
-  (values (or function symbol) boolean boolean))
-
-(deftype optional-filename () '(or filename (member t nil)))
-
-(defknown compile-file
-  ((or optional-filename list) &key (:output-file optional-filename) (:error-file optional-filename)
-   (:trace-file optional-filename) (:error-output t) (:load t) (:verbose t)
-   (:print t) (:progress t) (:block-compile t) (:entry-points list))
-  (values (or pathname null) boolean boolean))
-(defknown disassemble (callable &optional stream) void)
-
-(defknown documentation ((or symbol cons) symbol)
-  (or string null)
-  (flushable))
-
-(defknown describe (t &optional stream) (values))
-(defknown inspect (t) (values))
-
-(defknown room (&optional (member t nil :default)) void)
-(defknown ed (&optional (or symbol cons filename) &key (:init t) (:display t))
-  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-first-arg)
-
-(defknown constantly (t &rest t) function (movable flushable))
-(defknown complement (function) function (movable flushable))
-
-
-;;;; Magical compiler frobs:
-
-;;; Can't fold in general because of SATISFIES.  There is a special optimizer
-;;; anyway.
-(defknown %typep (t (or type-specifier ctype)) boolean
-  (movable flushable explicit-check))
-
-(defknown %cleanup-point () void)
-(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) *)
-(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 explicit-check))
-(defknown (%dpb %deposit-field) (integer bit-index bit-index integer) integer
-  (movable foldable flushable explicit-check))
-(defknown %negate (number) number (movable foldable flushable explicit-check))
-(defknown %check-bound (array index fixnum) index (movable foldable flushable))
-(defknown data-vector-ref (array index) t (foldable flushable explicit-check))
-(defknown data-vector-set (array index t) t (unsafe explicit-check))
-(defknown kernel:%caller-frame-and-pc () (values t t) (flushable))
-(defknown kernel:%with-array-data (array index (or index null))
-  (values (simple-array * (*)) index index index)
-  (foldable flushable))
-(defknown %set-symbol-package (symbol t) t (unsafe))
-(defknown %coerce-to-function (t) function (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))
-(defknown %slot-setter (t t) t (unsafe))
-
-
-;;;; Setf inverses:
-
-(defknown %aset (array &rest t) t (unsafe))
-(defknown %set-row-major-aref (array index 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 &rest index) bit (unsafe))
-(defknown %sbitset (simple-bit-vector &rest index) bit (unsafe))
-(defknown %charset (string index character) character (unsafe))
-(defknown %scharset (simple-string index character) character (unsafe))
-(defknown %set-symbol-value (symbol t) t (unsafe))
-(defknown fset (symbol function) function (unsafe))
-(defknown %set-symbol-plist (symbol t) t (unsafe))
-(defknown %set-documentation ((or symbol cons) symbol (or string null))
-  (or string null)
-  ())
-(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 base-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/core.lisp b/compiler/generic/core.lisp
deleted file mode 100644
index 9169d5c26da81d6df29fd31254fb6adb74a2f3a2..0000000000000000000000000000000000000000
--- a/compiler/generic/core.lisp
+++ /dev/null
@@ -1,337 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/core.lisp,v 1.21 1992/12/17 09:27:11 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;
-;;;    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 hashtable translating ENTRY-INFO structures to a list of pairs
-  ;; (<code object> . <offset>) describing the places that need to be
-  ;; backpatched to point to the function for ENTRY-INFO.
-  (patch-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))
-
-
-;;; NOTE-FUNCTION -- Internal.
-;;;
-;;; Note the existance of FUNCTION.
-;;; 
-(defun note-function (info function object)
-  (declare (type function function)
-	   (type core-object object))
-  (let ((patch-table (core-object-patch-table object)))
-    (dolist (patch (gethash info patch-table))
-      (setf (code-header-ref (car patch) (the index (cdr patch))) function))
-    (remhash info patch-table))
-  (setf (gethash info (core-object-entry-table object)) function)
-  (undefined-value))
-
-
-;;; MAKE-FUNCTION-ENTRY  --  Internal
-;;;
-;;;    Make a function entry, filling in slots from the ENTRY-INFO.
-;;;
-(defun make-function-entry (entry code-obj object)
-  (declare (type entry-info entry) (type core-object object))
-  (let ((offset (label-position (entry-info-offset entry))))
-    (declare (type index offset))
-    (unless (zerop (logand offset vm:lowtag-mask))
-      (error "Unaligned function object, offset = #x~X." offset))
-    (let ((res (%primitive compute-function code-obj offset)))
-      (setf (%function-self res) res)
-      (setf (%function-next res) (%code-entry-points code-obj))
-      (setf (%code-entry-points code-obj) res)
-      (setf (%function-name res) (entry-info-name entry))
-      (setf (%function-arglist res) (entry-info-arguments entry))
-      (setf (%function-type res) (entry-info-type entry))
-
-      (note-function entry res object))))
-
-;;; DO-CORE-FIXUPS  --  Internal
-;;;
-;;;    Do "load-time" fixups on the code vector.
-;;;
-(defun do-core-fixups (code fixups)
-  (declare (list fixups))
-  (dolist (info fixups)
-    (let* ((kind (first info))
-	   (fixup (second info))
-	   (name (fixup-name fixup))
-	   (flavor (fixup-flavor fixup))
-	   (offset (third info)))
-      (multiple-value-bind
-	  (value found)
-	  (ecase flavor
-	    (:assembly-routine
-	     (assert (symbolp name))
-	     (gethash name lisp::*assembler-routines*))
-	    (:foreign
-	     (assert (stringp name))
-	     (gethash name lisp::*foreign-symbols*)))
-	(unless found
-	  (error (ecase flavor
-		   (:assembly-routine "Undefined assembler routine: ~S")
-		   (:foreign "Unknown foreign symbol: ~S"))
-		 name))
-	(vm:fixup-code-object code offset value kind)))))
-
-
-;;; REFERENCE-CORE-FUNCTION  --  Internal
-;;;
-;;;    Stick a reference to the function Fun in Code-Object at index I.  If the
-;;; function hasn't been compiled yet, make a note in the Patch-Table.
-;;;
-(defun reference-core-function (code-obj i fun object)
-  (declare (type core-object object) (type functional fun)
-	   (type index i))
-  (let* ((info (leaf-info fun))
-	 (found (gethash info (core-object-entry-table object))))
-    (if found
-	(setf (code-header-ref code-obj i) found)
-	(push (cons code-obj i)
-	      (gethash info (core-object-patch-table object)))))
-  (undefined-value))
-
-
-;;; 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 segment length trace-table fixups object)
-  (declare (type component component)
-	   (type new-assem:segment segment)
-	   (type index length)
-	   (list trace-table fixups)
-	   (type core-object object))
-  (without-gcing
-    (let* ((2comp (component-info component))
-	   (constants (ir2-component-constants 2comp))
-	   (trace-table (pack-trace-table trace-table))
-	   (trace-table-len (length trace-table))
-	   (trace-table-bits (* trace-table-len bits-per-entry))
-	   (total-length (+ length (ceiling trace-table-bits vm:byte-bits)))
-	   (box-num (- (length constants) vm:code-trace-table-offset-slot))
-	   (code-obj (%primitive allocate-code-object box-num total-length))
-	   (fill-ptr (code-instructions code-obj)))
-      (declare (type index box-num total-length))
-
-      (new-assem:segment-map-output
-       segment
-       #'(lambda (sap amount)
-	   (declare (type system-area-pointer sap)
-		    (type index amount))
-	   (system-area-copy sap 0 fill-ptr 0
-			     (* amount vm:byte-bits))
-	   (setf fill-ptr (sap+ fill-ptr amount))))
-      (do-core-fixups code-obj fixups)
-      
-      (dolist (entry (ir2-component-entries 2comp))
-	(make-function-entry entry code-obj object))
-      
-      (vm:sanctify-for-execution code-obj)
-
-      (let ((info (debug-info-for-component component)))
-	(push info (core-object-debug-info object))
-	(setf (%code-debug-info code-obj) info))
-      
-      (setf (code-header-ref code-obj vm:code-trace-table-offset-slot) length)
-      (copy-to-system-area trace-table (* vm:vector-data-offset vm:word-bits)
-			   fill-ptr 0 trace-table-bits)
-
-      (do ((index vm:code-constants-offset (1+ index)))
-	  ((>= index (length constants)))
-	(let ((const (aref constants index)))
-	  (etypecase const
-	    (null)
-	    (constant
-	     (setf (code-header-ref code-obj index)
-		   (constant-value const)))
-	    (list
-	     (ecase (car const)
-	       (:entry
-		(reference-core-function code-obj index
-					 (cdr const) object))
-	       (:fdefinition
-		(setf (code-header-ref code-obj index)
-		      (lisp::fdefinition-object (cdr const) t))))))))))
-  (undefined-value))
-
-
-;;; MAKE-CORE-BYTE-COMPONENT -- Interface.
-;;;
-(defun make-core-byte-component (segment constants xeps object)
-  (declare (type new-assem:segment segment)
-	   (type vector constants)
-	   (type list xeps)
-	   (type core-object object))
-  (without-gcing
-    (let* ((num-constants (length constants))
-	   (length (byte-output-length segment))
-	   (code-obj (%primitive allocate-code-object
-				 (the index (1+ num-constants))
-				 length))
-	   (fill-ptr (code-instructions code-obj)))
-      (declare (type index length)
-	       (type system-area-pointer fill-ptr))
-
-      (new-assem:segment-map-output
-       segment
-       #'(lambda (sap amount)
-	   (declare (type system-area-pointer sap)
-		    (type index amount))
-	   (system-area-copy sap 0 fill-ptr 0
-			     (* amount vm:byte-bits))
-	   (setf fill-ptr (sap+ fill-ptr amount))))
-
-      (dolist (noise xeps)
-	(let ((xep (cdr noise)))
-	  (setf (byte-xep-component xep) code-obj)
-	  (note-function (lambda-info (car noise))
-			 (make-byte-compiled-function xep)
-			 object)))
-
-      (dotimes (index num-constants)
-	(let ((const (aref constants index))
-	      (code-obj-index (+ index vm:code-constants-offset)))
-	  (etypecase const
-	    (null)
-	    (constant
-	     (setf (code-header-ref code-obj code-obj-index)
-		   (constant-value const)))
-	    (list
-	     (ecase (car const)
-	       (:entry
-		(reference-core-function code-obj code-obj-index (cdr const)
-					 object))
-	       (:fdefinition
-		(setf (code-header-ref code-obj code-obj-index)
-		      (lisp::fdefinition-object (cdr const) t)))
-	       (:type-predicate
-		(setf (code-header-ref code-obj code-obj-index)
-		      (load-type-predicate (type-specifier (cdr const)))))
-	       (:xep
-		(let ((xep (cdr (assoc (cdr const) xeps :test #'eq))))
-		  (assert xep)
-		  (setf (code-header-ref code-obj code-obj-index) xep))))))))))
-
-  (undefined-value))
-
-
-;;; CORE-CALL-TOP-LEVEL-LAMBDA  --  Interface
-;;;
-;;;    Call the top-level lambda function dumped for Entry, returning the
-;;; values.  Entry may be a :TOP-LEVEL-XEP functional.
-;;;
-(defun core-call-top-level-lambda (entry object)
-  (declare (type functional entry) (type core-object object))
-  (funcall (or (gethash (leaf-info entry)
-			(core-object-entry-table object))
-	       (error "Unresolved forward reference."))))
-
-
-;;; FIX-CORE-SOURCE-INFO  --  Interface
-;;;
-;;;    Backpatch all the DEBUG-INFOs dumped so far with the specified
-;;; SOURCE-INFO list.  We also check that there are no outstanding forward
-;;; references to functions.
-;;;
-(defun fix-core-source-info (info object source-info)
-  (declare (type source-info info) (type core-object object))
-  (assert (zerop (hash-table-count (core-object-patch-table object))))
-  (let ((res (debug-source-for-info info)))
-    (dolist (sinfo res)
-      (setf (debug-source-info sinfo) source-info))
-    (dolist (info (core-object-debug-info object))
-      (setf (compiled-debug-info-source info) res))
-    (setf (core-object-debug-info object) ()))
-  (undefined-value))
-
-
-;;;; Code-instruction-streams
-
-(defstruct (code-instruction-stream
-	    (:print-function %print-code-inst-stream)
-	    (:include stream
-		      (lisp::sout #'code-inst-stream-sout)
-		      (lisp::bout #'code-inst-stream-bout)
-		      (lisp::misc #'code-inst-stream-misc))
-	    (:constructor make-code-instruction-stream
-			  (code-object
-			   &aux
-			   (current (code-instructions code-object))
-			   (end (sap+ current
-				      (* (%code-code-size code-object)
-					 vm:word-bytes))))))
-  code-object
-  current
-  end)
-
-(defun %print-code-inst-stream (code-inst-stream stream depth)
-  (declare (ignore depth))
-  (format stream "#<Code Instruction Stream for ~S>"
-	  (code-instruction-stream-code-object code-inst-stream)))
-
-(defun code-inst-stream-sout (stream string start end)
-  (let* ((start (or start 0))
-	 (end (or end (length string)))
-	 (length (- end start))
-	 (current (code-instruction-stream-current stream))
-	 (new (sap+ current length)))
-    (when (sap> new (code-instruction-stream-end stream))
-      (error "Writing ~D bytes to ~S would cause it to overflow."
-	     length stream))
-    (copy-to-system-area string (+ (* start vm:byte-bits)
-				   (* vm:vector-data-offset vm:word-bits))
-			 current 0
-			 (* length vm:byte-bits))
-    (setf (code-instruction-stream-current stream) new)))
-
-(defun code-inst-stream-bout (stream byte)
-  (declare (type code-instruction-stream stream)
-	   (type (unsigned-byte 8) byte))
-  (let* ((current (code-instruction-stream-current stream))
-	 (new (sap+ current 1)))
-    (when (sap> new (code-instruction-stream-end stream))
-      (error "Writing another byte to ~S would cause it to overflow."
-	     stream))
-    (setf (sap-ref-8 current 0) byte)
-    (setf (code-instruction-stream-current stream) new)))
-
-(defun code-inst-stream-misc (stream method &optional arg1 arg2)
-  (declare (ignore arg1 arg2))
-  (case method
-    (:close
-     (lisp::set-closed-flame stream))
-    (t
-     nil)))
diff --git a/compiler/generic/utils.lisp b/compiler/generic/utils.lisp
deleted file mode 100644
index 37191e48b9ec19bdda1fe92430b0e629ca691c26..0000000000000000000000000000000000000000
--- a/compiler/generic/utils.lisp
+++ /dev/null
@@ -1,77 +0,0 @@
-;;; -*- Package: VM; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/utils.lisp,v 1.4 1992/07/13 01:45:12 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Utility functions needed by the back end to generate code.
-;;;
-;;; Written by William Lott.
-;;; 
-
-(in-package "VM")
-
-(export '(fixnum static-symbol-p static-symbol-offset offset-static-symbol
-		 static-function-offset))
-
-
-
-;;;; 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)))
-
-
-
-;;;; Routines for dealing with static symbols.
-
-(defun static-symbol-p (symbol)
-  (or (null symbol)
-      (and (member symbol static-symbols) t)))
-
-(defun static-symbol-offset (symbol)
-  "Returns the byte offset of the static symbol Symbol."
-  (if 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)))
-      0))
-
-(defun offset-static-symbol (offset)
-  "Given a byte offset, Offset, returns the appropriate static symbol."
-  (if (zerop offset)
-      nil
-      (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))))
-
-(defun static-function-offset (name)
-  "Return the (byte) offset from NIL to the start of the fdefn object
-   for the static function NAME."
-  (let ((static-syms (length static-symbols))
-	(static-function-index (position name static-functions)))
-    (unless static-function-index
-      (error "~S isn't a static function." name))
-    (+ (* static-syms (pad-data-block symbol-size))
-       (pad-data-block (1- symbol-size))
-       (- list-pointer-type)
-       (* static-function-index (pad-data-block fdefn-size))
-       (* fdefn-raw-addr-slot word-bytes))))
diff --git a/compiler/generic/vm-ir2tran.lisp b/compiler/generic/vm-ir2tran.lisp
deleted file mode 100644
index 25112780241ca051c742f4b04e33f5176ecaf7b0..0000000000000000000000000000000000000000
--- a/compiler/generic/vm-ir2tran.lisp
+++ /dev/null
@@ -1,153 +0,0 @@
-;;; -*- Package: C -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.5 1992/12/18 11:19:50 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file
-;;; 
-(in-package :c)
-
-(export '(slot set-slot make-unbound-marker fixed-alloc var-alloc))
-
-(defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
-  (let* ((cont (node-cont node))
-	 (locs (continuation-result-tns
-		cont (list (backend-any-primitive-type *backend*))))
-	 (res (first locs)))
-    (vop slot node block (continuation-tn node block object)
-	 name offset lowtag res)
-    (move-continuation-result node block locs cont)))
-
-#+gengc
-(defun needs-remembering (cont)
-  (if (csubtypep (continuation-type cont)
-		 (load-time-value (specifier-type '(or fixnum character
-						       (member t nil)))))
-      nil
-      t))
-
-(defoptimizer ir2-convert-setter ((object value) node block name offset lowtag)
-  (let ((value-tn (continuation-tn node block value)))
-    (vop set-slot node block (continuation-tn node block object) value-tn
-	 name offset lowtag #+gengc (needs-remembering value))
-    (move-continuation-result node block (list value-tn) (node-cont node))))
-
-(defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag)
-  (let ((value-tn (continuation-tn node block value)))
-    (vop set-slot node block (continuation-tn node block object) value-tn
-	 name offset lowtag #+gengc (needs-remembering value))
-    (move-continuation-result node block (list value-tn) (node-cont node))))
-
-(defun do-inits (node block name result lowtag inits args)
-  (let ((unbound-marker-tn nil))
-    (dolist (init inits)
-      (let ((kind (car init))
-	    (slot (cdr init)))
-	(vop set-slot node block result
-	     (ecase kind
-	       (:arg
-		(assert args)
-		(continuation-tn node block (pop args)))
-	       (:unbound
-		(or unbound-marker-tn
-		    (setf unbound-marker-tn
-			  (let ((tn (make-restricted-tn
-				     nil
-				     (sc-number-or-lose 'vm::any-reg
-							*backend*))))
-			    (vop make-unbound-marker node block tn)
-			    tn))))
-	       (:null
-		(emit-constant nil)))
-	     name slot lowtag #+gengc nil))))
-  (assert (null args)))
-
-(defoptimizer ir2-convert-fixed-allocation
-	      ((&rest args) node block name words type lowtag inits)
-  (let* ((cont (node-cont node))
-	 (locs (continuation-result-tns
-		cont (list (backend-any-primitive-type *backend*))))
-	 (result (first locs)))
-    (vop fixed-alloc node block name words type lowtag result)
-    (do-inits node block name result lowtag inits args)
-    (move-continuation-result node block locs cont)))
-
-(defoptimizer ir2-convert-variable-allocation
-	      ((extra &rest args) node block name words type lowtag inits)
-  (let* ((cont (node-cont node))
-	 (locs (continuation-result-tns
-		cont (list (backend-any-primitive-type *backend*))))
-	 (result (first locs)))
-    (if (constant-continuation-p extra)
-	(let ((words (+ (continuation-value extra) words)))
-	  (vop fixed-alloc node block name words type lowtag result))
-	(vop var-alloc node block (continuation-tn node block extra) name words
-	     type lowtag result))
-    (do-inits node block name result lowtag inits args)
-    (move-continuation-result node block locs cont)))
-
-
-
-;;;; Replacements for stuff in ir2tran to make gengc work.
-
-#+gengc
-(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
-		    (needs-remembering 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
-	       (needs-remembering val))))))
-
-    (when locs
-      (emit-move node block val (first locs))
-      (move-continuation-result node block locs cont)))
-  (undefined-value))
-
-
-#+gengc
-(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)
-       nil))
-
-
-#+gengc
-(defoptimizer (%slot-setter ir2-convert) ((value str) 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)))))
-	 (needs-remembering value))
-  
-    (move-continuation-result node block (list val) (node-cont node))))
diff --git a/compiler/generic/vm-macs.lisp b/compiler/generic/vm-macs.lisp
deleted file mode 100644
index 9cef0bc3910b727e4b148d96ab4a28de64e3531f..0000000000000000000000000000000000000000
--- a/compiler/generic/vm-macs.lisp
+++ /dev/null
@@ -1,254 +0,0 @@
-;;; -*- Package: VM -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-macs.lisp,v 1.11 1992/12/16 21:35:52 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains some macros and constants that are object-format
-;;; specific or are used for defining the object format.
-;;;
-;;; Written by William Lott and Christopher Hoover.
-;;; 
-(in-package "VM")
-
-
-
-;;;; Other random stuff.
-
-;;; PAD-DATA-BLOCK -- Internal Interface.
-;;;
-;;; This returns a form that returns a dual-word aligned number of bytes when
-;;; given a number of words.
-;;;
-(defmacro pad-data-block (words)
-  `(logandc2 (+ (ash ,words word-shift) lowtag-mask) lowtag-mask))
-
-;;; DEFENUM -- Internal Interface.
-;;;
-(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))))
-
-
-;;;; Primitive object definition stuff.
-
-(export '(primitive-object primitive-object-p
-	  primitive-object-name primitive-object-header
-	  primitive-object-lowtag primitive-object-options
-	  primitive-object-slots primitive-object-size
-	  primitive-object-variable-length slot-name slot-docs slot-rest-p
-	  slot-offset slot-length slot-options *primitive-objects*
-	  define-for-each-primitive-object))
-
-
-(defun remove-keywords (options keywords)
-  (cond ((null options) nil)
-	((member (car options) keywords)
-	 (remove-keywords (cddr options) keywords))
-	(t
-	 (list* (car options) (cadr options)
-		(remove-keywords (cddr options) keywords)))))
-
-(defstruct (prim-object-slot
-	    (:conc-name slot-)
-	    (:constructor make-slot (name docs rest-p offset length options))
-	    (:make-load-form-fun :just-dump-it-normally))
-  (name nil :type symbol)
-  (docs nil :type (or null simple-string))
-  (rest-p nil :type (member t nil))
-  (offset 0 :type fixnum)
-  (length 1 :type fixnum)
-  (options nil :type list))
-
-(defstruct (primitive-object
-	    (:make-load-form-fun :just-dump-it-normally))
-  (name nil :type symbol)
-  (header nil :type symbol)
-  (lowtag nil :type symbol)
-  (options nil :type list)
-  (slots nil :type list)
-  (size 0 :type fixnum)
-  (variable-length nil :type (member t nil)))
-
-
-(defvar *primitive-objects* nil)
-
-(defun %define-primitive-object (primobj)
-  (let ((name (primitive-object-name primobj)))
-    (setf *primitive-objects*
-	  (cons primobj
-		(remove name *primitive-objects*
-			:key #'primitive-object-name :test #'eq)))
-    name))
-
-
-(defmacro define-primitive-object
-	  ((name &key header lowtag alloc-trans (type t))
-	   &rest slot-specs)
-  (collect ((slots) (exports) (constants) (forms) (inits))
-    (let ((offset (if header 1 0))
-	  (variable-length nil))
-      (dolist (spec slot-specs)
-	(when variable-length
-	  (error "No more slots can follow a :rest-p slott."))
-	(destructuring-bind
-	    (slot-name &rest options
-		       &key docs rest-p (length (if rest-p 0 1))
-		       ((:type slot-type) t) init
-		       (ref-known nil ref-known-p) ref-trans
-		       (set-known nil set-known-p) set-trans
-		       &allow-other-keys)
-	    (if (atom spec) (list spec) spec)
-	  (slots (make-slot slot-name docs rest-p offset length
-			    (remove-keywords options
-					     '(:docs :rest-p :length))))
-	  (let ((offset-sym (symbolicate name "-" slot-name
-					 (if rest-p "-OFFSET" "-SLOT"))))
-	    (constants `(defconstant ,offset-sym ,offset
-			  ,@(when docs (list docs))))
-	    (exports offset-sym))
-	  (when ref-trans
-	    (when ref-known-p
-	      (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known)))
-	    (forms `(def-reffer ,ref-trans ,offset ,lowtag)))
-	  (when set-trans
-	    (when set-known-p
-	      (forms `(defknown ,set-trans
-				,(if (listp set-trans)
-				     (list slot-type type)
-				     (list type slot-type))
-				,slot-type
-			,set-known)))
-	    (forms `(def-setter ,set-trans ,offset ,lowtag)))
-	  (when init
-	    (inits (cons init offset)))
-	  (when rest-p
-	    (setf variable-length t))
-	  (incf offset length)))
-      (unless variable-length
-	(let ((size (symbolicate name "-SIZE")))
-	  (constants `(defconstant ,size ,offset
-			,(format nil
-				 "Number of slots used by each ~S~
-				  ~@[~* including the header~]."
-				 name header)))
-	  (exports size)))
-      (when alloc-trans
-	(forms `(def-alloc ,alloc-trans ,offset ,variable-length ,header
-			   ,lowtag ',(inits))))
-      `(progn
-	 (export ',(exports))
-	 (eval-when (compile load eval)
-	   (%define-primitive-object
-	    ',(make-primitive-object :name name
-				     :header header
-				     :lowtag lowtag
-				     :slots (slots)
-				     :size offset
-				     :variable-length variable-length))
-	   ,@(constants))
-	 ,@(forms)))))
-
-
-
-;;;; reffer and setter definition stuff.
-
-(in-package :c)
-
-(export '(def-reffer def-setter def-alloc))
-
-(defun %def-reffer (name offset lowtag)
-  (let ((info (function-info-or-lose name)))
-    (setf (function-info-ir2-convert info)
-	  #'(lambda (node block)
-	      (ir2-convert-reffer node block name offset lowtag)))
-    (setf (function-info-ltn-annotate info) #'annotate-funny-call))
-  name)
-
-(defmacro def-reffer (name offset lowtag)
-  `(%def-reffer ',name ,offset ,lowtag))
-
-(defun %def-setter (name offset lowtag)
-  (let ((info (function-info-or-lose name)))
-    (setf (function-info-ir2-convert info)
-	  (if (listp name)
-	      #'(lambda (node block)
-		  (ir2-convert-setfer node block name offset lowtag))
-	      #'(lambda (node block)
-		  (ir2-convert-setter node block name offset lowtag))))
-    (setf (function-info-ltn-annotate info) #'annotate-funny-call))
-  name)
-
-(defmacro def-setter (name offset lowtag)
-  `(%def-setter ',name ,offset ,lowtag))
-
-(defun %def-alloc (name words variable-length header lowtag inits)
-  (let ((info (function-info-or-lose name)))
-    (setf (function-info-ir2-convert info)
-	  (if variable-length
-	      #'(lambda (node block)
-		  (ir2-convert-variable-allocation node block name words header
-						   lowtag inits))
-	      #'(lambda (node block)
-		  (ir2-convert-fixed-allocation node block name words header
-						lowtag inits))))
-    (setf (function-info-ltn-annotate info) #'annotate-funny-call))
-  name)
-
-(defmacro def-alloc (name words variable-length header lowtag inits)
-  `(%def-alloc ',name ,words ,variable-length ,header ,lowtag ,inits))
-
-
-;;;; Some general constant definitions:
-
-(in-package "C")
-
-(export '(fasl-file-implementations
-	  pmax-fasl-file-implementation
-	  sparc-fasl-file-implementation
-	  rt-fasl-file-implementation
-	  rt-afpa-fasl-file-implementation
-	  x86-fasl-file-implementation
-	  hppa-fasl-file-implementation))
-
-;;; Constants for the different implementations.  These are all defined in
-;;; one place to make sure they are all unique.
-
-(defparameter fasl-file-implementations
-  '(nil "Pmax" "Sparc" "RT" "RT/AFPA" "x86" "HPPA"))
-(defconstant pmax-fasl-file-implementation 1)
-(defconstant sparc-fasl-file-implementation 2)
-(defconstant rt-fasl-file-implementation 3)
-(defconstant rt-afpa-fasl-file-implementation 4)
-(defconstant x86-fasl-file-implementation 5)
-(defconstant hppa-fasl-file-implementation 6)
-
-;;; The maximum number of SCs in any implementation.
-(defconstant sc-number-limit 32)
diff --git a/compiler/generic/vm-typetran.lisp b/compiler/generic/vm-typetran.lisp
deleted file mode 100644
index 8a13aacbd3d6038d35ef0100450553a7320c2d3d..0000000000000000000000000000000000000000
--- a/compiler/generic/vm-typetran.lisp
+++ /dev/null
@@ -1,67 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-typetran.lisp,v 1.10 1992/03/07 17:15:05 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-typetran.lisp,v 1.10 1992/03/07 17:15:05 wlott Exp $
-;;;
-;;; This file contains the implimentation specific type transformation magic.
-;;; Basically, the various non-standard predicates that can be used in typep
-;;; transformations.
-;;; 
-;;; Written by William Lott.
-;;;
-
-(in-package "C")
-
-
-;;;; Internal predicates:
-;;;
-;;;    These type predicates are used to implement simple cases of typep.  They
-;;; shouldn't be used explicitly.
-
-(define-type-predicate base-char-p base-char)
-(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)
-(define-type-predicate simple-array-p simple-array)
-(define-type-predicate simple-array-unsigned-byte-2-p
-		       (simple-array (unsigned-byte 2) (*)))
-(define-type-predicate simple-array-unsigned-byte-4-p
-		       (simple-array (unsigned-byte 4) (*)))
-(define-type-predicate simple-array-unsigned-byte-8-p
-		       (simple-array (unsigned-byte 8) (*)))
-(define-type-predicate simple-array-unsigned-byte-16-p
-		       (simple-array (unsigned-byte 16) (*)))
-(define-type-predicate simple-array-unsigned-byte-32-p
-		       (simple-array (unsigned-byte 32) (*)))
-(define-type-predicate simple-array-single-float-p
-		       (simple-array single-float (*)))
-(define-type-predicate simple-array-double-float-p
-		       (simple-array double-float (*)))
-(define-type-predicate system-area-pointer-p system-area-pointer)
-(define-type-predicate unsigned-byte-32-p (unsigned-byte 32))
-(define-type-predicate signed-byte-32-p (signed-byte 32))
-(define-type-predicate weak-pointer-p weak-pointer)
-(define-type-predicate scavenger-hook-p scavenger-hook)
-(define-type-predicate code-component-p code-component)
-(define-type-predicate lra-p lra)
-(define-type-predicate fdefn-p fdefn)
-
-;;; 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)
diff --git a/compiler/globals.lisp b/compiler/globals.lisp
deleted file mode 100644
index f4a4858c28a2f9bc448d13ce7ef80956d4a84bee..0000000000000000000000000000000000000000
--- a/compiler/globals.lisp
+++ /dev/null
@@ -1,10 +0,0 @@
-
-(in-package "C")
-(proclaim '(special
-	    *defprint-pretty* *event-info* *event-note-threshold*
-	    *compiler-error-context*
-	    *converting-for-interpreter*
-	    *undefined-warnings*
-	    *code-segment* *elsewhere*
-	    *collect-dynamic-statistics* *count-vop-usages* *dynamic-counts-tn*
-	    *source-info*))
diff --git a/compiler/gtn.lisp b/compiler/gtn.lisp
deleted file mode 100644
index 1f33eda625f1a94e5ea64a23f024a49cd4a1033c..0000000000000000000000000000000000000000
--- a/compiler/gtn.lisp
+++ /dev/null
@@ -1,246 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/gtn.lisp,v 1.13 1992/04/01 15:30:08 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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.
-;;;
-;;; 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.  Here we evaluate the DEBUG-INFO/SPEED
-;;; tradeoff to determine how variables are allocated.  If SPEED is 3, then all
-;;; variables are subject to lifetime analysis.  Otherwise, only Let-P
-;;; variables are allocated normally, and that can be inhibited by
-;;; DEBUG-INFO = 3.
-;;;
-(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)
-		       (backend-any-primitive-type *backend*)
-		       (primitive-type (leaf-type var))))
-	     (temp (make-normal-tn type))
-	     (node (lambda-bind fun))
-	     (res (if (or (and let-p (policy node (< debug 3)))
-			  (policy node (= speed 3)))
-		      temp
-		      (environment-debug-live-tn temp
-						 (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 make the TNs which hold
-;;; environment values and the old-FP/return-PC.
-;;;
-(defun assign-ir2-environment (fun)
-  (declare (type clambda fun))
-  (let ((env (lambda-environment fun)))
-    (collect ((env))
-      (dolist (thing (environment-closure env))
-	(let ((ptype (etypecase thing
-		       (lambda-var
-			(if (lambda-var-indirect thing)
-			    (backend-any-primitive-type *backend*)
-			    (primitive-type (leaf-type thing))))
-		       (nlx-info (backend-any-primitive-type *backend*)))))
-	  (env (cons thing (make-normal-tn ptype)))))
-
-      (let ((res (make-ir2-environment
-		  :environment (env)
-		  :return-pc-pass (make-return-pc-passing-location
-				   (external-entry-point-p fun)))))
-	(setf (environment-info env) res)
-	(setf (ir2-environment-old-fp res)
-	      (make-old-fp-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))
-  (let ((return (lambda-return fun)))
-    (and return
-	 (do-uses (use (return-result return) 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-VALUE-EFFICENCY-NOTE  --  Internal
-;;;
-;;;    If policy indicates, give an efficency note about our inability to use
-;;; the known return convention.  We try to find a function in the tail set
-;;; with non-constant return values to use as context.  If there is no such
-;;; function, then be more vague.
-;;;
-(defun return-value-efficency-note (tails)
-  (declare (type tail-set tails))
-  (let ((funs (tail-set-functions tails)))
-    (when (policy (lambda-bind (first funs)) (> (max speed space) brevity))
-      (dolist (fun funs
-		   (let ((*compiler-error-context* (lambda-bind (first funs))))
-		     (compiler-note
-		      "Return value count mismatch prevents known return ~
-		       from these functions:~
-		       ~{~%  ~A~}"
-		      (remove nil (mapcar #'leaf-name funs)))))
-	(let ((ret (lambda-return fun)))
-	  (when ret
-	    (let ((rtype (return-result-type ret)))
-	      (multiple-value-bind (ignore count)
-				   (values-types rtype)
-		(declare (ignore ignore))
-		(when (eq count :unknown)
-		  (let ((*compiler-error-context* (lambda-bind fun)))
-		    (compiler-note
-		     "Return type not fixed values, so can't use known return ~
-		      convention:~%  ~S"
-		     (type-specifier rtype)))
-		  (return)))))))))
-  (undefined-value))
-
-
-;;; 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))
-	  (use-standard (use-standard-returns tails)))
-      (when (and (eq count :unknown) (not use-standard))
-	(return-value-efficency-note tails))
-      (if (or (eq count :unknown) use-standard)
-	  (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 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 returning from an XEP.
-;;;
-(defun assign-return-locations (fun)
-  (declare (type clambda fun))
-  (let* ((tails (lambda-tail-set fun))
-	 (returns (or (tail-set-info tails)
-		      (setf (tail-set-info tails)
-			    (return-info-for-set tails))))
-	 (return (lambda-return fun)))
-    (when (and return
-	       (not (eq (return-info-kind returns) :unknown))
-	       (external-entry-point-p fun))
-      (do-uses (use (return-result return))
-	(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
-;;; call a VM supplied function to make the Save-SP restricted on the stack.
-;;; 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))
-      (setf (nlx-info-info nlx)
-	    (make-ir2-nlx-info
-	     :home (when (member (cleanup-kind (nlx-info-cleanup nlx))
-				 '(:block :tagbody))
-		     (make-normal-tn (backend-any-primitive-type *backend*)))
-	     :save-sp (make-nlx-sp-tn env)))))
-  (undefined-value))
diff --git a/compiler/hppa/alloc.lisp b/compiler/hppa/alloc.lisp
deleted file mode 100644
index 95b58f1b380f4ac5bf3dc29e37083b0082525c1b..0000000000000000000000000000000000000000
--- a/compiler/hppa/alloc.lisp
+++ /dev/null
@@ -1,197 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/alloc.lisp,v 1.1 1992/07/13 03:48:14 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Allocation VOPs for the HPPA port.
-;;;
-;;; Written by William Lott.
-;;; 
-
-(in-package "HPPA")
-
-
-;;;; LIST and LIST*
-
-(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)
-  (:info num)
-  (:results (result :scs (descriptor-reg)))
-  (:variant-vars star)
-  (:policy :safe)
-  (:generator 0
-    (cond
-     ((zerop num)
-      (move null-tn result))
-     ((and star (= num 1))
-      (move (tn-ref-tn things) result))
-     (t
-      (macrolet
-	  ((maybe-load (tn)
-	     (once-only ((tn tn))
-	       `(sc-case ,tn
-		  ((any-reg descriptor-reg zero null)
-		   ,tn)
-		  (control-stack
-		   (load-stack-tn temp ,tn)
-		   temp)))))
-	(let* ((cons-cells (if star (1- num) num))
-	       (alloc (* (pad-data-block cons-size) cons-cells)))
-	  (pseudo-atomic (:extra alloc)
-	    (move alloc-tn res)
-	    (inst dep list-pointer-type 31 3 res)
-	    (move res ptr)
-	    (dotimes (i (1- cons-cells))
-	      (storew (maybe-load (tn-ref-tn things)) ptr
-		      cons-car-slot list-pointer-type)
-	      (setf things (tn-ref-across things))
-	      (inst addi (pad-data-block cons-size) ptr ptr)
-	      (storew ptr ptr
-		      (- cons-cdr-slot cons-size)
-		      list-pointer-type))
-	    (storew (maybe-load (tn-ref-tn things)) ptr
-		    cons-car-slot list-pointer-type)
-	    (storew (if star
-			(maybe-load (tn-ref-tn (tn-ref-across things)))
-			null-tn)
-		    ptr cons-cdr-slot list-pointer-type))
-	  (move res result)))))))
-
-
-(define-vop (list list-or-list*)
-  (:variant nil))
-
-(define-vop (list* list-or-list*)
-  (:variant t))
-
-
-;;;; Special purpose inline allocators.
-
-(define-vop (allocate-code-object)
-  (:args (boxed-arg :scs (any-reg))
-	 (unboxed-arg :scs (any-reg)))
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
-  (:generator 100
-    (inst addi (fixnum (1+ code-trace-table-offset-slot)) boxed-arg boxed)
-    (inst dep 0 31 3 boxed)
-    (inst srl unboxed-arg word-shift unboxed)
-    (inst addi lowtag-mask unboxed unboxed)
-    (inst dep 0 31 3 unboxed)
-    (pseudo-atomic ()
-      ;; Note: we don't have to subtract off the 4 that was added by
-      ;; pseudo-atomic, because depositing other-pointer-type just adds
-      ;; it right back.
-      (inst move alloc-tn result)
-      (inst dep other-pointer-type 31 3 result)
-      (inst add alloc-tn boxed alloc-tn)
-      (inst add alloc-tn unboxed alloc-tn)
-      (inst sll boxed (- type-bits word-shift) ndescr)
-      (inst addi code-header-type ndescr ndescr)
-      (storew ndescr result 0 other-pointer-type)
-      (storew unboxed result code-code-size-slot other-pointer-type)
-      (storew null-tn result code-entry-points-slot other-pointer-type)
-      (storew null-tn result code-debug-info-slot other-pointer-type))))
-
-(define-vop (make-fdefn)
-  (:args (name :scs (descriptor-reg) :to :eval))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:results (result :scs (descriptor-reg) :from :argument))
-  (:policy :fast-safe)
-  (:translate make-fdefn)
-  (:generator 37
-    (with-fixed-allocation (result temp fdefn-type fdefn-size)
-      (inst li (make-fixup "undefined_tramp" :foreign) temp)
-      (storew name result fdefn-name-slot other-pointer-type)
-      (storew null-tn result fdefn-function-slot other-pointer-type)
-      (storew temp result fdefn-raw-addr-slot other-pointer-type))))
-
-
-;;;; Automatic allocators for primitive objects.
-
-(define-for-each-primitive-object (obj)
-  (collect ((forms))
-    (let* ((options (primitive-object-options obj))
-	   (alloc-trans (getf options :alloc-trans))
-	   (alloc-vop (getf options :alloc-vop alloc-trans))
-	   (header (primitive-object-header obj))
-	   (lowtag (primitive-object-lowtag obj))
-	   (size (primitive-object-size obj))
-	   (variable-length (primitive-object-variable-length obj))
-	   (need-unbound-marker nil))
-      (collect ((args) (init-forms))
-	(when (and alloc-vop variable-length)
-	  (args 'extra-words))
-	(dolist (slot (primitive-object-slots obj))
-	  (let* ((name (slot-name slot))
-		 (offset (slot-offset slot)))
-	    (ecase (getf (slot-options slot) :init :zero)
-	      (:zero)
-	      (:null
-	       (init-forms `(storew null-tn result ,offset ,lowtag)))
-	      (:unbound
-	       (setf need-unbound-marker t)
-	       (init-forms `(storew temp result ,offset ,lowtag)))
-	      (:arg
-	       (args name)
-	       (init-forms `(storew ,name result ,offset ,lowtag))))))
-	(when (and (null alloc-vop) (args))
-	  (error "Slots ~S want to be initialized, but there is no alloc vop ~
-	          defined for ~S."
-		 (args) (primitive-object-name obj)))
-	(when alloc-vop
-	  (forms
-	   `(define-vop (,alloc-vop)
-	      (:args ,@(mapcar #'(lambda (name)
-				   `(,name :scs (any-reg descriptor-reg)))
-			       (args)))
-	      ,@(when (or need-unbound-marker header variable-length)
-		  `((:temporary (:scs (non-descriptor-reg)) temp)))
-	      (:results (result :scs (descriptor-reg) :from :load))
-	      (:policy :fast-safe)
-	      ,@(when alloc-trans
-		  `((:translate ,alloc-trans)))
-	      (:generator 37
-		(pseudo-atomic (,@(unless variable-length
-				    `(:extra (pad-data-block ,size))))
-		  (move alloc-tn result)
-		  (inst dep ,lowtag 31 3 result)
-		  ,@(cond
-		     ((and header variable-length)
-		      `((inst addi (* (1+ ,size) word-bytes) extra-words temp)
-			(inst dep 0 31 3 temp)
-			(inst add temp alloc-tn alloc-tn)
-			(inst sll extra-words (- type-bits word-shift) temp)
-			(inst addi (+ (ash (1- ,size) type-bits) ,header)
-			      temp temp)
-			(storew temp result 0 ,lowtag)))
-		     (variable-length
-		      (error ":REST-P T with no header in ~S?"
-			     (primitive-object-name obj)))
-		     (header
-		      `((inst li ,(logior (ash (1- size) type-bits)
-					  (symbol-value header))
-			      temp)
-			(storew temp result 0 ,lowtag)))
-		     (t
-		      nil))
-		  ,@(when need-unbound-marker
-		      `((inst li unbound-marker-type temp)))
-		  ,@(init-forms))))))))
-    (when (forms)
-      `(progn
-	 ,@(forms)))))
diff --git a/compiler/hppa/arith.lisp b/compiler/hppa/arith.lisp
deleted file mode 100644
index 4fd1bbb0053293a4f8ff9ecfdb0a84c308b0c2e3..0000000000000000000000000000000000000000
--- a/compiler/hppa/arith.lisp
+++ /dev/null
@@ -1,853 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/arith.lisp,v 1.2 1992/08/04 14:14:12 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the VM definition arithmetic VOPs for the HP-PA.
-;;;
-;;; Written by William Lott.
-;;; 
-
-(in-package "HPPA")
-
-
-
-;;;; Unary operations.
-
-(define-vop (fixnum-unop)
-  (:args (x :scs (any-reg)))
-  (:results (res :scs (any-reg)))
-  (:note "inline fixnum arithmetic")
-  (:arg-types tagged-num)
-  (:result-types tagged-num)
-  (:policy :fast-safe))
-
-(define-vop (signed-unop)
-  (:args (x :scs (signed-reg)))
-  (:results (res :scs (signed-reg)))
-  (:note "inline (signed-byte 32) arithmetic")
-  (:arg-types signed-num)
-  (:result-types signed-num)
-  (:policy :fast-safe))
-
-(define-vop (fast-negate/fixnum fixnum-unop)
-  (:translate %negate)
-  (:generator 1
-    (inst sub zero-tn x res)))
-
-(define-vop (fast-negate/signed signed-unop)
-  (:translate %negate)
-  (:generator 2
-    (inst sub zero-tn x res)))
-
-(define-vop (fast-lognot/fixnum fixnum-unop)
-  (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
-	      temp)
-  (:translate lognot)
-  (:generator 2
-    (inst li (fixnum -1) temp)
-    (inst xor x temp res)))
-
-(define-vop (fast-lognot/signed signed-unop)
-  (:translate lognot)
-  (:generator 1
-    (inst uaddcm zero-tn x res)))
-
-
-
-;;;; Binary fixnum operations.
-
-;;; Assume that any constant operand is the second arg...
-
-(define-vop (fast-fixnum-binop)
-  (:args (x :target r :scs (any-reg))
-	 (y :target r :scs (any-reg)))
-  (:arg-types tagged-num tagged-num)
-  (:results (r :scs (any-reg)))
-  (:result-types tagged-num)
-  (:note "inline fixnum arithmetic")
-  (:effects)
-  (:affected)
-  (:policy :fast-safe))
-
-(define-vop (fast-unsigned-binop)
-  (:args (x :target r :scs (unsigned-reg))
-	 (y :target r :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:note "inline (unsigned-byte 32) arithmetic")
-  (:effects)
-  (:affected)
-  (:policy :fast-safe))
-
-(define-vop (fast-signed-binop)
-  (:args (x :target r :scs (signed-reg))
-	 (y :target r :scs (signed-reg)))
-  (:arg-types signed-num signed-num)
-  (:results (r :scs (signed-reg)))
-  (:result-types signed-num)
-  (:note "inline (signed-byte 32) arithmetic")
-  (:effects)
-  (:affected)
-  (:policy :fast-safe))
-
-(defmacro define-binop (translate cost untagged-cost op)
-  `(progn
-     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
-		  fast-fixnum-binop)
-       (:args (x :target r :scs (any-reg))
-	      (y :target r :scs (any-reg)))
-       (:translate ,translate)
-       (:generator ,cost
-	 (inst ,op x y r)))
-     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
-		  fast-signed-binop)
-       (:args (x :target r :scs (signed-reg))
-	      (y :target r :scs (signed-reg)))
-       (:translate ,translate)
-       (:generator ,untagged-cost
-	 (inst ,op x y r)))
-     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
-		  fast-unsigned-binop)
-       (:args (x :target r :scs (unsigned-reg))
-	      (y :target r :scs (unsigned-reg)))
-       (:translate ,translate)
-       (:generator ,untagged-cost
-	 (inst ,op x y r)))))
-
-(define-binop + 2 6 add)
-(define-binop - 2 6 sub)
-(define-binop logior 1 2 or)
-(define-binop logand 1 2 and)
-(define-binop logandc2 1 2 andcm)
-(define-binop logxor 1 2 xor)
-
-(define-vop (fast-fixnum-c-binop fast-fixnum-binop)
-  (:args (x :target r :scs (any-reg)))
-  (:info y)
-  (:arg-types tagged-num (:constant integer)))
-
-(define-vop (fast-signed-c-binop fast-signed-binop)
-  (:args (x :target r :scs (signed-reg)))
-  (:info y)
-  (:arg-types tagged-num (:constant integer)))
-
-(define-vop (fast-unsigned-c-binop fast-unsigned-binop)
-  (:args (x :target r :scs (unsigned-reg)))
-  (:info y)
-  (:arg-types tagged-num (:constant integer)))
-
-(defmacro define-c-binop (translate cost untagged-cost tagged-type
-				    untagged-type inst)
-  `(progn
-     (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
-		  fast-fixnum-c-binop)
-       (:arg-types tagged-num (:constant ,tagged-type))
-       (:translate ,translate)
-       (:generator ,cost
-	 (let ((y (fixnum y)))
-	   ,inst)))
-     (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
-		  fast-signed-c-binop)
-       (:arg-types signed-num (:constant ,untagged-type))
-       (:translate ,translate)
-       (:generator ,untagged-cost
-	 ,inst))
-     (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED")
-		  fast-unsigned-c-binop)
-       (:arg-types unsigned-num (:constant ,untagged-type))
-       (:translate ,translate)
-       (:generator ,untagged-cost
-	 ,inst))))
-
-(define-c-binop + 1 3 (signed-byte 9) (signed-byte 11)
-  (inst addi y x r))
-(define-c-binop - 1 3
-  (integer #.(- (1- (ash 1 9))) #.(ash 1 9))
-  (integer #.(- (1- (ash 1 11))) #.(ash 1 11))
-  (inst addi (- y) x r))
-
-;;; Special case fixnum + and - that trap on overflow.  Useful when we don't
-;;; know that the result is going to be a fixnum.
-
-(define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:note nil)
-  (:generator 4
-    (inst addo x y r)))
-
-(define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:note nil)
-  (:generator 3
-    (inst addio (fixnum y) x r)))
-
-(define-vop (fast--/fixnum fast--/fixnum=>fixnum)
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:note nil)
-  (:generator 4
-    (inst subo x y r)))
-
-(define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:note nil)
-  (:generator 3
-    (inst addio (- (fixnum y)) x r)))
-
-;;; Shifting
-
-(define-vop (fast-ash)
-  (:policy :fast-safe)
-  (:translate ash)
-  (:note "inline word ASH")
-  (:args (number :scs (signed-reg unsigned-reg))
-	 (count :scs (signed-reg)))
-  (:arg-types (:or signed-num unsigned-num) tagged-num)
-  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
-  (:results (result :scs (signed-reg unsigned-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:generator 8
-    (inst comb :>= count zero-tn positive :nullify t)
-    (inst sub zero-tn count temp)
-    (inst comiclr 31 temp zero-tn :>=)
-    (inst li 31 temp)
-    (inst mtctl temp :sar)
-    (inst extrs number 0 1 temp)
-    (inst b done)
-    (inst shd temp number :variable result)
-    POSITIVE
-    (inst subi 31 count temp)
-    (inst mtctl temp :sar)
-    (inst zdep number :variable 32 result)
-    DONE))
-
-(define-vop (fast-ash-c)
-  (:policy :fast-safe)
-  (:translate ash)
-  (:note nil)
-  (:args (number :scs (signed-reg unsigned-reg)))
-  (:info count)
-  (:arg-types (:or signed-num unsigned-num) (:constant integer))
-  (:results (result :scs (signed-reg unsigned-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:generator 1
-    (cond ((< count 0)
-	   ;; It is a right shift.
-	   (sc-case number
-	     (signed-reg (inst sra number (min (- count) 31) result))
-	     (unsigned-reg (inst srl number (min (- count) 31) result))))
-	  ((> count 0)
-	   ;; It is a left shift.
-	   (inst sll number (min count 31) result))
-	  (t
-	   ;; Count=0?  Shouldn't happen, but it's easy:
-	   (move number result)))))
-
-
-(define-vop (signed-byte-32-len)
-  (:translate integer-length)
-  (:note "inline (signed-byte 32) integer-length")
-  (:policy :fast-safe)
-  (:args (arg :scs (signed-reg) :target shift))
-  (:arg-types signed-num)
-  (:results (res :scs (any-reg)))
-  (:result-types positive-fixnum)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
-  (:generator 30
-    (inst move arg shift :>=)
-    (inst uaddcm zero-tn shift shift)
-    (inst comb := shift zero-tn done)
-    (inst li 0 res)
-    LOOP
-    (inst srl shift 1 shift)
-    (inst comb :<> shift zero-tn loop)
-    (inst addi (fixnum 1) res res)
-    DONE))
-
-(define-vop (unsigned-byte-32-count)
-  (:translate logcount)
-  (:note "inline (unsigned-byte 32) logcount")
-  (:policy :fast-safe)
-  (:args (arg :scs (unsigned-reg) :target num))
-  (:arg-types unsigned-num)
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
-		    :target res) num)
-  (:temporary (:scs (non-descriptor-reg)) mask temp)
-  (:generator 30
-    (inst li #x55555555 mask)
-    (inst srl arg 1 temp)
-    (inst and arg mask num)
-    (inst and temp mask temp)
-    (inst add num temp num)
-    (inst li #x33333333 mask)
-    (inst srl num 2 temp)
-    (inst and num mask num)
-    (inst and temp mask temp)
-    (inst add num temp num)
-    (inst li #x0f0f0f0f mask)
-    (inst srl num 4 temp)
-    (inst and num mask num)
-    (inst and temp mask temp)
-    (inst add num temp num)
-    (inst li #x00ff00ff mask)
-    (inst srl num 8 temp)
-    (inst and num mask num)
-    (inst and temp mask temp)
-    (inst add num temp num)
-    (inst li #x0000ffff mask)
-    (inst srl num 16 temp)
-    (inst and num mask num)
-    (inst and temp mask temp)
-    (inst add num temp res)))
-
-;;; Multiply and Divide.
-
-(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
-  (:args (x :scs (any-reg) :target x-pass)
-	 (y :scs (any-reg) :target y-pass))
-  (:temporary (:sc signed-reg :offset nl0-offset
-		   :from (:argument 0) :to (:result 0)) x-pass)
-  (:temporary (:sc signed-reg :offset nl1-offset
-		   :from (:argument 1) :to (:result 0)) y-pass)
-  (:temporary (:sc signed-reg :offset nl2-offset :target r
-		   :from (:argument 1) :to (:result 0)) res-pass)
-  (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
-  (:temporary (:sc signed-reg :offset nl4-offset
-		   :from (:argument 1) :to (:result 0)) sign)
-  (:temporary (:sc interior-reg :offset lip-offset) lip)
-  (:ignore lip sign)
-  (:translate *)
-  (:generator 30
-    (unless (location= y y-pass)
-      (inst sra x 2 x-pass))
-    (let ((fixup (make-fixup 'multiply :assembly-routine)))
-      (inst ldil fixup tmp)
-      (inst ble fixup lisp-heap-space tmp))
-    (if (location= y y-pass)
-	(inst sra x 2 x-pass)
-	(inst move y y-pass))
-    (move res-pass r)))
-
-(define-vop (fast-*/signed=>signed fast-signed-binop)
-  (:translate *)
-  (:args (x :scs (signed-reg) :target x-pass)
-	 (y :scs (signed-reg) :target y-pass))
-  (:temporary (:sc signed-reg :offset nl0-offset
-		   :from (:argument 0) :to (:result 0)) x-pass)
-  (:temporary (:sc signed-reg :offset nl1-offset
-		   :from (:argument 1) :to (:result 0)) y-pass)
-  (:temporary (:sc signed-reg :offset nl2-offset :target r
-		   :from (:argument 1) :to (:result 0)) res-pass)
-  (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
-  (:temporary (:sc signed-reg :offset nl4-offset
-		   :from (:argument 1) :to (:result 0)) sign)
-  (:temporary (:sc interior-reg :offset lip-offset) lip)
-  (:ignore lip sign)
-  (:translate *)
-  (:generator 31
-    (let ((fixup (make-fixup 'multiply :assembly-routine)))
-      (move x x-pass)
-      (move y y-pass)
-      (inst ldil fixup tmp)
-      (inst ble fixup lisp-heap-space tmp :nullify t)
-      (inst nop)
-      (move res-pass r))))
-
-(define-vop (fast-truncate/fixnum fast-fixnum-binop)
-  (:translate truncate)
-  (:args (x :scs (any-reg) :target x-pass)
-	 (y :scs (any-reg) :target y-pass))
-  (:temporary (:sc signed-reg :offset nl0-offset
-		   :from (:argument 0) :to (:result 0)) x-pass)
-  (:temporary (:sc signed-reg :offset nl1-offset
-		   :from (:argument 1) :to (:result 0)) y-pass)
-  (:temporary (:sc signed-reg :offset nl2-offset :target q
-		   :from (:argument 1) :to (:result 0)) q-pass)
-  (:temporary (:sc signed-reg :offset nl3-offset :target r
-		   :from (:argument 1) :to (:result 1)) r-pass)
-  (:results (q :scs (signed-reg))
-	    (r :scs (any-reg)))
-  (:result-types tagged-num tagged-num)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 30
-    (let ((zero (generate-error-code vop division-by-zero-error x y)))
-      (inst bc := nil y zero-tn zero))
-    (move x x-pass)
-    (move y y-pass)
-    (let ((fixup (make-fixup 'truncate :assembly-routine)))
-      (inst ldil fixup q-pass)
-      (inst ble fixup lisp-heap-space q-pass :nullify t))
-    (inst nop)
-    (move q-pass q)
-    (move r-pass r)))
-
-(define-vop (fast-truncate/signed fast-signed-binop)
-  (:translate truncate)
-  (:args (x :scs (signed-reg) :target x-pass)
-	 (y :scs (signed-reg) :target y-pass))
-  (:temporary (:sc signed-reg :offset nl0-offset
-		   :from (:argument 0) :to (:result 0)) x-pass)
-  (:temporary (:sc signed-reg :offset nl1-offset
-		   :from (:argument 1) :to (:result 0)) y-pass)
-  (:temporary (:sc signed-reg :offset nl2-offset :target q
-		   :from (:argument 1) :to (:result 0)) q-pass)
-  (:temporary (:sc signed-reg :offset nl3-offset :target r
-		   :from (:argument 1) :to (:result 1)) r-pass)
-  (:results (q :scs (signed-reg))
-	    (r :scs (signed-reg)))
-  (:result-types signed-num signed-num)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 35
-    (let ((zero (generate-error-code vop division-by-zero-error x y)))
-      (inst bc := nil y zero-tn zero))
-    (move x x-pass)
-    (move y y-pass)
-    (let ((fixup (make-fixup 'truncate :assembly-routine)))
-      (inst ldil fixup q-pass)
-      (inst ble fixup lisp-heap-space q-pass :nullify t))
-    (inst nop)
-    (move q-pass q)
-    (move r-pass r)))
-
-
-;;;; Binary conditional VOPs:
-
-(define-vop (fast-conditional)
-  (:conditional)
-  (:info target not-p)
-  (:effects)
-  (:affected)
-  (:policy :fast-safe))
-
-(define-vop (fast-conditional/fixnum fast-conditional)
-  (:args (x :scs (any-reg))
-	 (y :scs (any-reg)))
-  (:arg-types tagged-num tagged-num)
-  (:note "inline fixnum comparison"))
-
-(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
-  (:args (x :scs (any-reg)))
-  (:arg-types tagged-num (:constant (signed-byte 9)))
-  (:info target not-p y))
-
-(define-vop (fast-conditional/signed fast-conditional)
-  (:args (x :scs (signed-reg))
-	 (y :scs (signed-reg)))
-  (:arg-types signed-num signed-num)
-  (:note "inline (signed-byte 32) comparison"))
-
-(define-vop (fast-conditional-c/signed fast-conditional/signed)
-  (:args (x :scs (signed-reg)))
-  (:arg-types signed-num (:constant (signed-byte 11)))
-  (:info target not-p y))
-
-(define-vop (fast-conditional/unsigned fast-conditional)
-  (:args (x :scs (unsigned-reg))
-	 (y :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num)
-  (:note "inline (unsigned-byte 32) comparison"))
-
-(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
-  (:args (x :scs (unsigned-reg)))
-  (:arg-types unsigned-num (:constant (signed-byte 11)))
-  (:info target not-p y))
-
-
-(defmacro define-conditional-vop (translate signed-cond unsigned-cond)
-  `(progn
-     ,@(mapcar #'(lambda (suffix cost signed imm)
-		   (unless (and (member suffix '(/fixnum -c/fixnum))
-				(eq translate 'eql))
-		     `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
-						    translate suffix))
-				   ,(intern
-				     (format nil "~:@(FAST-CONDITIONAL~A~)"
-					     suffix)))
-			(:translate ,translate)
-			(:generator ,cost
-			  (inst ,(if imm 'bci 'bc)
-				,(if signed signed-cond unsigned-cond)
-				not-p
-				,(if (eq suffix '-c/fixnum)
-				     '(fixnum y)
-				     'y)
-				x
-				target)))))
-	       '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
-	       '(3 2 5 4 5 4)
-	       '(t t t t nil nil)
-	       '(nil t nil t nil t))))
-
-;; We switch < and > because the immediate has to come first.
-
-(define-conditional-vop < :> :>>)
-(define-conditional-vop > :< :<<)
-
-;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
-;;; known fixnum.
-;;;
-(define-conditional-vop eql := :=)
-
-;;; These versions specify a fixnum restriction on their first arg.  We have
-;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
-;;; the first arg and a higher cost.  The reason for doing this is to prevent
-;;; fixnum specific operations from being used on word integers, spuriously
-;;; consing the argument.
-;;;
-(define-vop (fast-eql/fixnum fast-conditional)
-  (:args (x :scs (any-reg descriptor-reg))
-	 (y :scs (any-reg)))
-  (:arg-types tagged-num tagged-num)
-  (:note "inline fixnum comparison")
-  (:translate eql)
-  (:generator 3
-    (inst bc := not-p x y target)))
-;;;
-(define-vop (generic-eql/fixnum fast-eql/fixnum)
-  (:arg-types * tagged-num)
-  (:variant-cost 7))
-
-(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:arg-types tagged-num (:constant (signed-byte 9)))
-  (:info target not-p y)
-  (:translate eql)
-  (:generator 2
-    (inst bci := not-p (fixnum y) x target)))
-;;;
-(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
-  (:arg-types * (:constant (signed-byte 14)))
-  (:variant-cost 6))
-  
-
-;;;; 32-bit logical operations
-
-(define-vop (32bit-logical)
-  (:args (x :scs (unsigned-reg))
-	 (y :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:policy :fast-safe))
-
-(define-vop (32bit-logical-not 32bit-logical)
-  (:translate 32bit-logical-not)
-  (:args (x :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:generator 1
-    (inst uaddcm zero-tn x r)))
-
-(define-vop (32bit-logical-and 32bit-logical)
-  (:translate 32bit-logical-and)
-  (:generator 1
-    (inst and x y r)))
-
-(deftransform 32bit-logical-nand ((x y) (* *))
-  '(32bit-logical-not (32bit-logical-and x y)))
-
-(define-vop (32bit-logical-or 32bit-logical)
-  (:translate 32bit-logical-or)
-  (:generator 1
-    (inst or x y r)))
-
-(deftransform 32bit-logical-nor ((x y) (* *))
-  '(32bit-logical-not (32bit-logical-or x y)))
-
-(define-vop (32bit-logical-xor 32bit-logical)
-  (:translate 32bit-logical-xor)
-  (:generator 1
-    (inst xor x y r)))
-
-(deftransform 32bit-logical-eqv ((x y) (* *))
-  '(32bit-logical-not (32bit-logical-xor x y)))
-
-(deftransform 32bit-logical-andc1 ((x y) (* *))
-  '(32bit-logical-and (32bit-logical-not x) y))
-
-(define-vop (32bit-logical-andc2 32bit-logical)
-  (:translate 32bit-logical-andc2)
-  (:generator 1
-    (inst andcm x y r)))
-
-(deftransform 32bit-logical-orc1 ((x y) (* *))
-  '(32bit-logical-or (32bit-logical-not x) y))
-
-(deftransform 32bit-logical-orc2 ((x y) (* *))
-  '(32bit-logical-or x (32bit-logical-not y)))
-
-
-(define-vop (shift-towards-someplace)
-  (:policy :fast-safe)
-  (:args (num :scs (unsigned-reg))
-	 (amount :scs (signed-reg)))
-  (:arg-types unsigned-num tagged-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num))
-
-(define-vop (shift-towards-start shift-towards-someplace)
-  (:translate shift-towards-start)
-  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
-  (:note "SHIFT-TOWARDS-START")
-  (:generator 1
-    (inst subi 31 amount temp)
-    (inst mtctl temp :sar)
-    (inst zdep num :variable 32 r)))
-
-(define-vop (shift-towards-end shift-towards-someplace)
-  (:translate shift-towards-end)
-  (:note "SHIFT-TOWARDS-END")
-  (:generator 1
-    (inst mtctl amount :sar)
-    (inst shd zero-tn num :variable r)))
-
-
-
-;;;; Bignum stuff.
-
-(define-vop (bignum-length get-header-data)
-  (:translate bignum::%bignum-length)
-  (:policy :fast-safe))
-
-(define-vop (bignum-set-length set-header-data)
-  (:translate bignum::%bignum-set-length)
-  (:policy :fast-safe))
-
-(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
-  (unsigned-reg) unsigned-num bignum::%bignum-ref)
-
-(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
-  (unsigned-reg) unsigned-num bignum::%bignum-set)
-
-(define-vop (digit-0-or-plus)
-  (:translate bignum::%digit-0-or-plusp)
-  (:policy :fast-safe)
-  (:args (digit :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:conditional)
-  (:info target not-p)
-  (:effects)
-  (:affected)
-  (:generator 1
-    (inst bc :>= not-p digit zero-tn target)))
-
-(define-vop (add-w/carry)
-  (:translate bignum::%add-with-carry)
-  (:policy :fast-safe)
-  (:args (a :scs (unsigned-reg))
-	 (b :scs (unsigned-reg))
-	 (c :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num positive-fixnum)
-  (:results (result :scs (unsigned-reg))
-	    (carry :scs (unsigned-reg)))
-  (:result-types unsigned-num positive-fixnum)
-  (:generator 3
-    (inst addi -1 c zero-tn)
-    (inst addc a b result)
-    (inst addc zero-tn zero-tn carry)))
-
-(define-vop (sub-w/borrow)
-  (:translate bignum::%subtract-with-borrow)
-  (:policy :fast-safe)
-  (:args (a :scs (unsigned-reg))
-	 (b :scs (unsigned-reg))
-	 (c :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num positive-fixnum)
-  (:results (result :scs (unsigned-reg))
-	    (borrow :scs (unsigned-reg)))
-  (:result-types unsigned-num positive-fixnum)
-  (:generator 4
-    (inst addi -1 c zero-tn)
-    (inst subb a b result)
-    (inst addc zero-tn zero-tn borrow)))
-
-(define-vop (bignum-mult)
-  (:translate bignum::%multiply)
-  (:policy :fast-safe)
-  (:args (x-arg :scs (unsigned-reg) :target x)
-	 (y-arg :scs (unsigned-reg) :target y))
-  (:arg-types unsigned-num unsigned-num)
-  (:temporary (:scs (signed-reg) :from (:argument 0)) x)
-  (:temporary (:scs (signed-reg) :from (:argument 1)) y)
-  (:temporary (:scs (signed-reg)) tmp)
-  (:results (hi :scs (unsigned-reg))
-	    (lo :scs (unsigned-reg)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 3
-    ;; Make sure X is less then Y.
-    (inst comclr x-arg y-arg tmp :<<)
-    (inst xor x-arg y-arg tmp)
-    (inst xor x-arg tmp x)
-    (inst xor y-arg tmp y)
-
-    ;; Blow out of here if the result is zero.
-    (inst li 0 hi)
-    (inst comb := x zero-tn done)
-    (inst li 0 lo)
-    (inst li 0 tmp)
-
-    LOOP
-    (inst comb :ev x zero-tn next-bit)
-    (inst srl x 1 x)
-    (inst add lo y lo)
-    (inst addc hi tmp hi)
-    NEXT-BIT
-    (inst add y y y)
-    (inst comb :<> x zero-tn loop)
-    (inst addc tmp tmp tmp)
-
-    DONE))
-
-(def-source-transform bignum:%multiply-and-add (x y carry &optional (extra 0))
-  #+nil ;; This would be greate if it worked, but it doesn't.
-  (if (eql extra 0)
-      `(multiple-value-call #'bignum::%dual-word-add
-	 (bignum:%multiply ,x ,y)
-	 (values ,carry))
-      `(multiple-value-call #'bignum::%dual-word-add
-	 (multiple-value-call #'bignum::%dual-word-add
-	   (bignum:%multiply ,x ,y)
-	   (values ,carry))
-	 (values ,extra)))
-  (let ((hi (gensym "HI-"))
-	(lo (gensym "LO-")))
-    (if (eql extra 0)
-	`(multiple-value-bind (,hi ,lo) (bignum:%multiply ,x ,y)
-	   (bignum::%dual-word-add ,hi ,lo ,carry))
-	`(multiple-value-bind (,hi ,lo) (bignum:%multiply ,x ,y)
-	   (multiple-value-bind
-	       (,hi ,lo)
-	       (bignum::%dual-word-add ,hi ,lo ,carry)
-	     (bignum::%dual-word-add ,hi ,lo ,extra))))))
-
-(defknown bignum::%dual-word-add
-	  (bignum-element-type bignum-element-type bignum-element-type)
-  (values bignum-element-type bignum-element-type)
-  (flushable movable))
-
-(define-vop (dual-word-add)
-  (:policy :fast-safe)
-  (:translate bignum::%dual-word-add)
-  (:args (hi :scs (unsigned-reg) :to (:result 1))
-	 (lo :scs (unsigned-reg))
-	 (extra :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num unsigned-num)
-  (:results (hi-res :scs (unsigned-reg) :from (:result 1))
-	    (lo-res :scs (unsigned-reg) :from (:result 0)))
-  (:result-types unsigned-num unsigned-num)
-  (:affected)
-  (:effects)
-  (:generator 3
-    (inst add lo extra lo-res)
-    (inst addc hi zero-tn hi-res)))
-
-(define-vop (bignum-lognot)
-  (:translate bignum::%lognot)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (inst uaddcm zero-tn x r)))
-
-(define-vop (fixnum-to-digit)
-  (:translate bignum::%fixnum-to-digit)
-  (:policy :fast-safe)
-  (:args (fixnum :scs (signed-reg)))
-  (:arg-types tagged-num)
-  (:results (digit :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (move fixnum digit)))
-
-(define-vop (bignum-floor)
-  (:translate bignum::%floor)
-  (:policy :fast-safe)
-  (:args (hi :scs (unsigned-reg) :to (:argument 1))
-	 (lo :scs (unsigned-reg) :to (:argument 0))
-	 (divisor :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num unsigned-num)
-  (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
-  (:results (quo :scs (unsigned-reg) :from (:argument 0))
-	    (rem :scs (unsigned-reg) :from (:argument 1)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 65
-    (inst sub zero-tn divisor temp)
-    (inst ds zero-tn temp zero-tn)
-    (inst add lo lo quo)
-    (inst ds hi divisor rem)
-    (inst addc quo quo quo)
-    (dotimes (i 31)
-      (inst ds rem divisor rem)
-      (inst addc quo quo quo))
-    (inst comclr rem zero-tn zero-tn :>=)
-    (inst add divisor rem rem)))
-
-(define-vop (signify-digit)
-  (:translate bignum::%fixnum-digit-with-correct-sign)
-  (:policy :fast-safe)
-  (:args (digit :scs (unsigned-reg) :target res))
-  (:arg-types unsigned-num)
-  (:results (res :scs (signed-reg)))
-  (:result-types signed-num)
-  (:generator 1
-    (move digit res)))
-
-(define-vop (digit-lshr)
-  (:translate bignum::%digit-logical-shift-right)
-  (:policy :fast-safe)
-  (:args (digit :scs (unsigned-reg))
-	 (count :scs (unsigned-reg)))
-  (:arg-types unsigned-num positive-fixnum)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 2
-    (inst mtctl count :sar)
-    (inst shd zero-tn digit :variable result)))
-
-(define-vop (digit-ashr digit-lshr)
-  (:translate bignum::%ashr)
-  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
-  (:generator 1
-    (inst extrs digit 0 1 temp)
-    (inst mtctl count :sar)
-    (inst shd temp digit :variable result)))
-
-(define-vop (digit-ashl digit-ashr)
-  (:translate bignum::%ashl)
-  (:generator 1
-    (inst subi 31 count temp)
-    (inst mtctl temp :sar)
-    (inst zdep digit :variable 32 result)))
-
-
-;;;; Static functions.
-
-(define-static-function two-arg-gcd (x y) :translate gcd)
-(define-static-function two-arg-lcm (x y) :translate lcm)
-
-(define-static-function two-arg-* (x y) :translate *)
-(define-static-function two-arg-/ (x y) :translate /)
-
-(define-static-function %negate (x) :translate %negate)
-
-(define-static-function two-arg-and (x y) :translate logand)
-(define-static-function two-arg-ior (x y) :translate logior)
-(define-static-function two-arg-xor (x y) :translate logxor)
diff --git a/compiler/hppa/array.lisp b/compiler/hppa/array.lisp
deleted file mode 100644
index 412038b4f8a6429f725fe5fb31e4f3edcdb453b6..0000000000000000000000000000000000000000
--- a/compiler/hppa/array.lisp
+++ /dev/null
@@ -1,347 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/array.lisp,v 1.3 1992/10/13 13:14:47 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the SPARC definitions for array operations.
-;;;
-;;; Written by William Lott
-;;;
-(in-package "HPPA")
-
-
-;;;; Allocator for the array header.
-
-(define-vop (make-array-header)
-  (:translate make-array-header)
-  (:policy :fast-safe)
-  (:args (type :scs (any-reg))
-	 (rank :scs (any-reg)))
-  (:arg-types tagged-num tagged-num)
-  (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
-  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 0
-    (pseudo-atomic ()
-      (inst move alloc-tn header)
-      (inst dep other-pointer-type 31 3 header)
-      (inst addi (* (1+ array-dimensions-offset) word-bytes) rank ndescr)
-      (inst dep 0 31 3 ndescr)
-      (inst add alloc-tn ndescr alloc-tn)
-      (inst addi (fixnum (1- array-dimensions-offset)) rank ndescr)
-      (inst sll ndescr type-bits ndescr)
-      (inst or ndescr type ndescr)
-      (inst srl ndescr 2 ndescr)
-      (storew ndescr header 0 vm:other-pointer-type))
-    (move header result)))
-
-
-;;;; Additional accessors and setters for the array header.
-
-(defknown lisp::%array-dimension (t index) index
-  (flushable))
-(defknown lisp::%set-array-dimension (t index index) index
-  ())
-
-(define-full-reffer %array-dimension *
-  array-dimensions-offset other-pointer-type
-  (any-reg) positive-fixnum lisp::%array-dimension)
-
-(define-full-setter %set-array-dimension *
-  array-dimensions-offset other-pointer-type
-  (any-reg) positive-fixnum lisp::%set-array-dimension)
-
-
-(defknown lisp::%array-rank (t) index (flushable))
-
-(define-vop (array-rank-vop)
-  (:translate lisp::%array-rank)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (loadw res x 0 vm:other-pointer-type)
-    (inst srl res type-bits res)
-    (inst addi (- (1- vm:array-dimensions-offset)) res res)))
-
-
-
-;;;; Bounds checking routine.
-
-
-(define-vop (check-bound)
-  (:translate %check-bound)
-  (:policy :fast-safe)
-  (:args (array :scs (descriptor-reg))
-	 (bound :scs (any-reg descriptor-reg))
-	 (index :scs (any-reg descriptor-reg) :target result))
-  (:results (result :scs (any-reg descriptor-reg)))
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 5
-    (let ((error (generate-error-code vop invalid-array-index-error
-				      array bound index)))
-      (inst bc :>= nil index bound error))
-    (move index result)))
-
-
-;;;; Accessors/Setters
-
-;;; Variants built on top of word-index-ref, etc.  I.e. those vectors whos
-;;; elements are represented in integer registers and are built out of
-;;; 8, 16, or 32 bit elements.
-
-(eval-when (compile eval)
-
-(defmacro def-full-data-vector-frobs (type element-type &rest scs)
-  `(progn
-     (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
-       vector-data-offset other-pointer-type ,scs ,element-type
-       data-vector-ref)
-     (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
-       vector-data-offset other-pointer-type ,scs ,element-type
-       data-vector-set)))
-
-(defmacro def-partial-data-vector-frobs
-	  (type element-type size signed &rest scs)
-  `(progn
-     (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
-       ,size ,signed vector-data-offset other-pointer-type ,scs
-       ,element-type data-vector-ref)
-     (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
-       ,size vector-data-offset other-pointer-type ,scs
-       ,element-type data-vector-set)))
-
-); eval-when (compile eval)
-
-(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
-
-(def-partial-data-vector-frobs simple-string base-char :byte nil base-char-reg)
-
-(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
-  :byte nil unsigned-reg signed-reg)
-
-(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
-  :short nil unsigned-reg signed-reg)
-
-(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
-  unsigned-reg)
-
-
-;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
-;;; and 4-bit vectors.
-;;; 
-
-(eval-when (compile eval)
-
-(defmacro def-small-data-vector-frobs (type bits)
-  (let* ((elements-per-word (floor vm:word-bits bits))
-	 (bit-shift (1- (integer-length elements-per-word))))
-    `(progn
-       (define-vop (,(symbolicate 'data-vector-ref/ type))
-	 (:note "inline array access")
-	 (:translate data-vector-ref)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(index :scs (unsigned-reg)))
-	 (:arg-types ,type positive-fixnum)
-	 (:results (result :scs (unsigned-reg) :from (:argument 0)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (non-descriptor-reg)) temp)
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:generator 20
-	   (inst srl index ,bit-shift temp)
-	   (inst sh2add temp object lip)
-	   (loadw result lip vector-data-offset other-pointer-type)
-	   (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
-	   ,@(unless (= bits 1)
-	       `((inst addi ,(1- bits) temp temp)))
-	   (inst mtctl temp :sar)
-	   (inst extru result :variable ,bits result)))
-       (define-vop (,(symbolicate 'data-vector-ref-c/ type))
-	 (:translate data-vector-ref)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg)))
-	 (:arg-types ,type (:constant index))
-	 (:info index)
-	 (:results (result :scs (unsigned-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (non-descriptor-reg)) temp)
-	 (:generator 15
-	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
-	     (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
-			      vm:other-pointer-type)))
-	       (cond ((typep offset '(signed-byte 14))
-		      (inst ldw offset object result))
-		     (t
-		      (inst ldil (ldb (byte 21 11) offset) temp)
-		      (inst ldw (ldb (byte 11 0) offset) temp result))))
-	     (inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result))))
-       (define-vop (,(symbolicate 'data-vector-set/ type))
-	 (:note "inline array store")
-	 (:translate data-vector-set)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(index :scs (unsigned-reg))
-		(value :scs (unsigned-reg zero immediate) :target result))
-	 (:arg-types ,type positive-fixnum positive-fixnum)
-	 (:results (result :scs (unsigned-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (non-descriptor-reg)) temp old)
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:generator 25
-	   (inst srl index ,bit-shift temp)
-	   (inst sh2add temp object lip)
-	   (loadw old lip vector-data-offset other-pointer-type)
-	   (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
-	   ,@(unless (= bits 1)
-	       `((inst addi ,(1- bits) temp temp)))
-	   (inst mtctl temp :sar)
-	   (inst dep (sc-case value (immediate (tn-value value)) (t value))
-		 :variable ,bits old)
-	   (storew old lip vector-data-offset other-pointer-type)
-	   (sc-case value
-	     (immediate
-	      (inst li (tn-value value) result))
-	     (t
-	      (move value result)))))
-       (define-vop (,(symbolicate 'data-vector-set-c/ type))
-	 (:translate data-vector-set)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(value :scs (unsigned-reg zero immediate) :target result))
-	 (:arg-types ,type
-		     (:constant index)
-		     positive-fixnum)
-	 (:info index)
-	 (:results (result :scs (unsigned-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (non-descriptor-reg)) old)
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:generator 20
-	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
-	     (let ((offset (- (* (+ word vector-data-offset) word-bytes)
-			      other-pointer-type)))
-	       (cond ((typep offset '(signed-byte 14))
-		      (inst ldw offset object old))
-		     (t
-		      (inst move object lip)
-		      (inst addil (ldb (byte 21 11) offset) lip)
-		      (inst ldw (ldb (byte 11 0) offset) lip old)))
-	       (inst dep (sc-case value
-			   (immediate (tn-value value))
-			   (t value))
-		     (+ (* extra ,bits) ,(1- bits))
-		     ,bits
-		     old)
-	       (if (typep offset '(signed-byte 14))
-		   (inst stw old offset object)
-		   (inst stw old (ldb (byte 11 0) offset) lip)))
-	     (sc-case value
-	       (immediate
-		(inst li (tn-value value) result))
-	       (t
-		(move value result)))))))))
-
-); eval-when (compile eval)
-
-(def-small-data-vector-frobs simple-bit-vector 1)
-(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
-(def-small-data-vector-frobs simple-array-unsigned-byte-4 4)
-
-;;; And the float variants.
-;;; 
-
-(define-vop (data-vector-ref/simple-array-single-float)
-  (:note "inline array access")
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:argument 1))
-	 (index :scs (any-reg) :to (:argument 0) :target offset))
-  (:arg-types simple-array-single-float positive-fixnum)
-  (:results (value :scs (single-reg)))
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
-  (:result-types single-float)
-  (:generator 5
-    (inst addi (- (* vector-data-offset word-bytes) other-pointer-type)
-	  index offset)
-    (inst fldx offset object value)))
-
-(define-vop (data-vector-set/simple-array-single-float)
-  (:note "inline array store")
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:argument 1))
-	 (index :scs (any-reg) :to (:argument 0) :target offset)
-	 (value :scs (single-reg) :target result))
-  (:arg-types simple-array-single-float positive-fixnum single-float)
-  (:results (result :scs (single-reg)))
-  (:result-types single-float)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
-  (:generator 5
-    (inst addi (- (* vector-data-offset word-bytes) other-pointer-type)
-	  index offset)
-    (inst fstx value offset object)
-    (unless (location= result value)
-      (inst funop :copy value result))))
-
-(define-vop (data-vector-ref/simple-array-double-float)
-  (:note "inline array access")
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:argument 1))
-	 (index :scs (any-reg) :to (:argument 0) :target offset))
-  (:arg-types simple-array-double-float positive-fixnum)
-  (:results (value :scs (double-reg)))
-  (:result-types double-float)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
-  (:generator 7
-    (inst sll index 1 offset)
-    (inst addi (- (* vector-data-offset word-bytes) other-pointer-type)
-	  offset offset)
-    (inst fldx offset object value)))
-
-(define-vop (data-vector-set/simple-array-double-float)
-  (:note "inline array store")
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:argument 1))
-	 (index :scs (any-reg) :to (:argument 0) :target offset)
-	 (value :scs (double-reg) :target result))
-  (:arg-types simple-array-double-float positive-fixnum double-float)
-  (:results (result :scs (double-reg)))
-  (:result-types double-float)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
-  (:generator 20
-    (inst sll index 1 offset)
-    (inst addi (- (* vector-data-offset word-bytes) other-pointer-type)
-	  offset offset)
-    (inst fstx value offset object)
-    (unless (location= result value)
-      (inst funop :copy value result))))
-
-;;; These vops are useful for accessing the bits of a vector irrespective of
-;;; what type of vector it is.
-;;; 
-
-(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num
-  %raw-bits)
-(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
-  unsigned-num %set-raw-bits)
-
-
-
-;;;; Misc. Array VOPs.
-
-(define-vop (get-vector-subtype get-header-data))
-(define-vop (set-vector-subtype set-header-data))
-
diff --git a/compiler/hppa/c-call.lisp b/compiler/hppa/c-call.lisp
deleted file mode 100644
index 314babac66d3a4247713386fc0a8db0f434c3e78..0000000000000000000000000000000000000000
--- a/compiler/hppa/c-call.lisp
+++ /dev/null
@@ -1,185 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/c-call.lisp,v 1.1 1992/07/13 03:48:17 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the VOPs and other necessary machine specific support
-;;; routines for call-out to C.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "HPPA")
-(use-package "ALIEN")
-(use-package "ALIEN-INTERNALS")
-
-(defun my-make-wired-tn (prim-type-name sc-name offset)
-  (make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
-		 (sc-number-or-lose sc-name *backend*)
-		 offset))
-
-(defstruct arg-state
-  (args 0))
-
-(defstruct (arg-info
-	    (:constructor make-arg-info (offset prim-type reg-sc stack-sc)))
-  offset
-  prim-type
-  reg-sc
-  stack-sc)
-
-(def-alien-type-method (integer :arg-tn) (type state)
-  (let ((args (arg-state-args state)))
-    (setf (arg-state-args state) (1+ args))
-    (if (alien-integer-type-signed type)
-	(make-arg-info args 'signed-byte-32 'signed-reg 'signed-stack)
-	(make-arg-info args 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))))
-
-(def-alien-type-method (system-area-pointer :arg-tn) (type state)
-  (declare (ignore type))
-  (let ((args (arg-state-args state)))
-    (setf (arg-state-args state) (1+ args))
-    (make-arg-info args 'system-area-pointer 'sap-reg 'sap-stack)))
-
-(def-alien-type-method (single-float :arg-tn) (type state)
-  (declare (ignore type))
-  (let ((args (arg-state-args state)))
-    (setf (arg-state-args state) (1+ args))
-    (make-arg-info args 'single-float 'single-reg 'single-stack)))
-
-(def-alien-type-method (double-float :arg-tn) (type state)
-  (declare (ignore type))
-  (let ((args (logior (1+ (arg-state-args state)) 1)))
-    (setf (arg-state-args state) (1+ args))
-    (make-arg-info args 'double-float 'double-reg 'double-stack)))
-
-(def-alien-type-method (integer :result-tn) (type)
-  (if (alien-integer-type-signed type)
-      (my-make-wired-tn 'signed-byte-32 'signed-reg nl4-offset)
-      (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl4-offset)))
-  
-(def-alien-type-method (system-area-pointer :result-tn) (type)
-  (declare (ignore type))
-  (my-make-wired-tn 'system-area-pointer 'sap-reg nl4-offset))
-
-(def-alien-type-method (single-float :result-tn) (type)
-  (declare (ignore type))
-  (my-make-wired-tn 'single-float 'single-reg 4))
-
-(def-alien-type-method (double-float :result-tn) (type)
-  (declare (ignore type))
-  (my-make-wired-tn 'double-float 'double-reg 4))
-
-(def-alien-type-method (values :result-tn) (type)
-  (let ((values (alien-values-type-values type)))
-    (when values
-      (assert (null (cdr values)))
-      (invoke-alien-type-method :result-tn (car values)))))
-
-(defun make-argument-tns (type)
-  (let* ((state (make-arg-state))
-	 (args (mapcar #'(lambda (arg-type)
-			   (invoke-alien-type-method :arg-tn arg-type state))
-		       (alien-function-type-arg-types type)))
-	 ;; We need 8 words of cruft, and we need to round up to a multiple
-	 ;; of 16 words.
-	 (frame-size (logandc2 (+ (arg-state-args state) 8 15) 15)))
-    (values
-     (mapcar #'(lambda (arg)
-		 (declare (type arg-info arg))
-		 (let ((offset (arg-info-offset arg))
-		       (prim-type (arg-info-prim-type arg)))
-		   (cond ((>= offset 4)
-			  (my-make-wired-tn prim-type (arg-info-stack-sc arg)
-					    (- frame-size offset 8 1)))
-			 ((or (eq prim-type 'single-float)
-			      (eq prim-type 'double-float))
-			  (my-make-wired-tn prim-type (arg-info-reg-sc arg)
-					    (+ offset 4)))
-			 (t
-			  (my-make-wired-tn prim-type (arg-info-reg-sc arg)
-					    (- nl0-offset offset))))))
-	     args)
-     (* frame-size word-bytes))))
-
-(def-vm-support-routine make-call-out-tns (type)
-  (declare (type alien-function-type type))
-  (multiple-value-bind
-      (arg-tns stack-size)
-      (make-argument-tns type)
-    (values (make-normal-tn *fixnum-primitive-type*)
-	    stack-size
-	    arg-tns
-	    (invoke-alien-type-method
-	     :result-tn
-	     (alien-function-type-result-type type)))))
-
-
-(define-vop (foreign-symbol-address)
-  (:translate foreign-symbol-address)
-  (:policy :fast-safe)
-  (:args)
-  (:arg-types (:constant simple-string))
-  (:info foreign-symbol)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 2
-    (inst li (make-fixup foreign-symbol :foreign) res)))
-
-(define-vop (call-out)
-  (:args (function :scs (sap-reg) :target cfunc)
-	 (args :more t))
-  (:results (results :more t))
-  (:ignore args results)
-  (:save-p t)
-  (:temporary (:sc any-reg :offset cfunc-offset
-		   :from (:argument 0) :to (:result 0)) cfunc)
-  (:temporary (:scs (any-reg) :to (:result 0)) temp)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:vop-var vop)
-  (:generator 0
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn nfp-save cur-nfp))
-      (move function cfunc)
-      (let ((fixup (make-fixup "call_into_c" :foreign)))
-	(inst ldil fixup temp)
-	(inst ble fixup c-text-space temp :nullify t))
-      (inst nop)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save)))))
-
-
-(define-vop (alloc-number-stack-space)
-  (:info amount)
-  (:results (result :scs (sap-reg any-reg)))
-  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
-  (:generator 0
-    (move nsp-tn result)
-    (unless (zerop amount)
-      (let ((delta (logandc2 (+ amount 63) 63)))
-	(cond ((< delta (ash 1 10))
-	       (inst addi delta nsp-tn nsp-tn))
-	      (t
-	       (inst li delta temp)
-	       (inst add temp nsp-tn nsp-tn)))))))
-
-(define-vop (dealloc-number-stack-space)
-  (:info amount)
-  (:policy :fast-safe)
-  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
-  (:generator 0
-    (unless (zerop amount)
-      (let ((delta (- (logandc2 (+ amount 63) 63))))
-	(cond ((<= (- (ash 1 10)) delta)
-	       (inst addi delta nsp-tn nsp-tn))
-	      (t
-	       (inst li delta temp)
-	       (inst add temp nsp-tn nsp-tn)))))))
diff --git a/compiler/hppa/call.lisp b/compiler/hppa/call.lisp
deleted file mode 100644
index bdecd70b99e783122006c2900f86b7a67f5d39d8..0000000000000000000000000000000000000000
--- a/compiler/hppa/call.lisp
+++ /dev/null
@@ -1,1224 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/call.lisp,v 1.3 1992/10/16 16:35:29 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the VM definition of function call for the HPPA.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "HPPA")
-
-
-;;;; Interfaces to IR2 conversion:
-
-;;; Standard-Argument-Location  --  Interface
-;;;
-;;;    Return a wired TN describing the N'th full call argument passing
-;;; location.
-;;;
-(def-vm-support-routine 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*
-		     control-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.
-;;;
-(def-vm-support-routine make-return-pc-passing-location (standard)
-  (if standard
-      (make-wired-tn *any-primitive-type* register-arg-scn lra-offset)
-      (make-restricted-tn *any-primitive-type* register-arg-scn)))
-
-;;; Make-Old-FP-Passing-Location  --  Interface
-;;;
-;;;    Similar to Make-Return-PC-Passing-Location, but makes a location to pass
-;;; Old-FP 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.
-;;;
-(def-vm-support-routine make-old-fp-passing-location (standard)
-  (if standard
-      (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)
-      (make-normal-tn *fixnum-primitive-type*)))
-
-;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location  --  Interface
-;;;
-;;;    Make the TNs used to hold Old-FP and Return-PC within the current
-;;; function.  We treat these specially so that the debugger can find them at a
-;;; known location.
-;;;
-(def-vm-support-routine make-old-fp-save-location (env)
-  (specify-save-tn
-   (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
-   (make-wired-tn *fixnum-primitive-type*
-		  control-stack-arg-scn
-		  ocfp-save-offset)))
-;;;
-(def-vm-support-routine make-return-pc-save-location (env)
-  (specify-save-tn
-   (environment-debug-live-tn (make-normal-tn *any-primitive-type*) env)
-   (make-wired-tn *any-primitive-type*
-		  control-stack-arg-scn
-		  lra-save-offset)))
-
-;;; 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.
-;;;
-(def-vm-support-routine make-argument-count-location ()
-  (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset))
-
-
-;;; MAKE-NFP-TN  --  Interface
-;;;
-;;;    Make a TN to hold the number-stack frame pointer.  This is allocated
-;;; once per component, and is component-live.
-;;;
-(def-vm-support-routine make-nfp-tn ()
-  (component-live-tn
-   (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset)))
-
-;;; MAKE-STACK-POINTER-TN ()
-;;; 
-(def-vm-support-routine make-stack-pointer-tn ()
-  (make-normal-tn *fixnum-primitive-type*))
-
-;;; MAKE-NUMBER-STACK-POINTER-TN ()
-;;; 
-(def-vm-support-routine make-number-stack-pointer-tn ()
-  (make-normal-tn *fixnum-primitive-type*))
-
-;;; Make-Unknown-Values-Locations  --  Interface
-;;;
-;;;    Return a list of TNs that can be used to represent an unknown-values
-;;; continuation within a function.
-;;;
-(def-vm-support-routine make-unknown-values-locations ()
-  (list (make-stack-pointer-tn)
-	(make-normal-tn *fixnum-primitive-type*)))
-
-
-;;; 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 additional
-;;; noise in the code object header.
-;;;
-(def-vm-support-routine select-component-format (component)
-  (declare (type component component))
-  (dotimes (i code-constants-offset)
-    (vector-push-extend nil
-			(ir2-component-constants (component-info component))))
-  (undefined-value))
-
-
-;;;; Frame hackery:
-
-;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal
-;;;
-;;; Return the number of bytes needed for the current non-descriptor stack.
-;;; We have to allocate multiples of 64 bytes.
-;;; 
-(defun bytes-needed-for-non-descriptor-stack-frame ()
-  (logandc2 (+ (* (sb-allocated-size 'non-descriptor-stack) word-bytes) 63)
-	    63))
-
-;;; Used for setting up the Old-FP in local call.
-;;;
-(define-vop (current-fp)
-  (:results (val :scs (any-reg)))
-  (:generator 1
-    (move cfp-tn val)))
-
-;;; Used for computing the caller's NFP for use in known-values return.  Only
-;;; works assuming there is no variable size stuff on the nstack.
-;;;
-(define-vop (compute-old-nfp)
-  (:results (val :scs (any-reg)))
-  (:vop-var vop)
-  (:generator 1
-    (let ((nfp (current-nfp-tn vop)))
-      (when nfp
-	(inst addi (- (bytes-needed-for-non-descriptor-stack-frame))
-	      nfp val)))))
-
-(define-vop (xep-allocate-frame)
-  (:info start-lab)
-  (:vop-var vop)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 1
-    ;; Make sure the function is aligned, and drop a label pointing to this
-    ;; function header.
-    (align lowtag-bits)
-    (trace-table-entry trace-table-function-prologue)
-    (emit-label start-lab)
-    ;; Allocate function header.
-    (inst function-header-word)
-    (dotimes (i (1- function-header-code-offset))
-      (inst word 0))
-    ;; The start of the actual code.
-    ;; Fix CODE, cause the function object was passed in.
-    (let ((entry-point (gen-label)))
-      (emit-label entry-point)
-      (inst compute-code-from-fn lip-tn entry-point temp code-tn))
-    ;; Build our stack frames.
-    (inst addi (* vm:word-bytes (sb-allocated-size 'control-stack))
-	  cfp-tn csp-tn)
-    (let ((nfp (current-nfp-tn vop)))
-      (when nfp
-	(move nsp-tn nfp)
-	(inst addi (bytes-needed-for-non-descriptor-stack-frame)
-	      nsp-tn nsp-tn)))
-    (trace-table-entry trace-table-normal)))
-
-(define-vop (allocate-frame)
-  (:results (res :scs (any-reg))
-	    (nfp :scs (any-reg)))
-  (:info callee)
-  (:generator 2
-    (move csp-tn res)
-    (inst addi (* vm:word-bytes (sb-allocated-size 'control-stack))
-	  csp-tn csp-tn)
-    (when (ir2-environment-number-stack-p callee)
-      (move nsp-tn nfp)
-      (inst addi (bytes-needed-for-non-descriptor-stack-frame)
-	    nsp-tn nsp-tn))))
-
-;;; Allocate a partial frame for passing stack arguments in a full call.  Nargs
-;;; is the number of arguments passed.  If no stack arguments are passed, then
-;;; we don't have to do anything.
-;;;
-(define-vop (allocate-full-call-frame)
-  (:info nargs)
-  (:results (res :scs (any-reg)))
-  (:generator 2
-    (when (> nargs register-arg-count)
-      (move csp-tn res)
-      (inst addi (* nargs vm:word-bytes) csp-tn csp-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).
-;;;
-;;;    Move-Temp is a Descriptor-Reg TN used as a temporary.
-;;;
-;;;    This code exploits the fact that in the unknown-values convention, a
-;;; single value return returns at the return PC + 8, 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:
-#|
-	b regs-defaulted		; Skip if MVs
-	nop
-
-	move a1 null-tn			; Default register values
-	...
-	loadi nargs 1			; Force defaulting of stack values
-	move old-fp csp			; Set up args for SP resetting
-
-regs-defaulted
-	subu temp nargs register-arg-count
-
-	bltz temp default-value-7	; jump to default code
-        addu temp temp -1
-	loadw move-temp old-fp-tn 6	; Move value to correct location.
-	store-stack-tn val4-tn move-temp
-
-	bltz temp default-value-8
-        addu temp temp -1
-	loadw move-temp old-fp-tn 7
-	store-stack-tn val5-tn move-temp
-
-	...
-
-defaulting-done
-	move sp old-fp			; Reset SP.
-<end of code>
-
-<elsewhere>
-default-value-7
-	store-stack-tn val4-tn null-tn	; Nil out 7'th value. (first on stack)
-
-default-value-8
-	store-stack-tn val5-tn null-tn	; Nil out 8'th value.
-
-	...
-
-	br defaulting-done
-        nop
-|#
-;;;
-(defun default-unknown-values (vop values nvals move-temp temp lra-label)
-  (declare (type (or tn-ref null) values)
-	   (type unsigned-byte nvals) (type tn move-temp temp))
-  (cond
-   ((<= nvals 1)
-    (assemble ()
-      ;; Note that this is a single-value return point.  This is actually
-      ;; the multiple-value entry point for a single desired value, but
-      ;; the code location has to be here, or the debugger backtrace
-      ;; gets confused.
-      (note-this-location vop :single-value-return)
-      (move ocfp-tn csp-tn)
-      (inst compute-code-from-lra code-tn lra-label temp code-tn)))
-   ((<= nvals register-arg-count)
-    (assemble ()
-      ;; Note that this is an unknown-values return point.
-      (note-this-location vop :unknown-return)
-      ;; Branch off to the MV case.
-      (inst b regs-defaulted :nullify t)
-	
-      ;; Default any unsupplied values.
-      (do ((val (tn-ref-across values) (tn-ref-across val)))
-	  ((null val))
-	(inst move null-tn (tn-ref-tn val)
-	      (if (tn-ref-across val)
-		  :never
-		  :tr)))
-
-      REGS-DEFAULTED
-
-      ;; Clear the stack.  Note: the last move in the single value reg
-      ;; defaulting nullifies this, so this only happens in the mv case.
-      (move ocfp-tn csp-tn)
-
-      ;; Fix CODE.
-      (inst compute-code-from-lra code-tn lra-label temp code-tn)))
-   (t
-    (collect ((defaults))
-      (assemble (nil nil :labels (default-stack-vals))
-	;; Note that this is an unknown-values return point.
-	(note-this-location vop :unknown-return)
-	;; Branch off to the MV case.
-	(inst b regs-defaulted :nullify t)
-	
-	;; Default any unsupplied register values.
-	(do ((i 1 (1+ i))
-	     (val (tn-ref-across values) (tn-ref-across val)))
-	    ((= i register-arg-count))
-	  (inst move null-tn (tn-ref-tn val)))
-	(inst b default-stack-vals)
-	(move ocfp-tn csp-tn)
-	
-	REGS-DEFAULTED
-	
-	(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))
-	    (inst bci :> nil (fixnum i) nargs-tn default-lab)
-	    (loadw move-temp ocfp-tn i)
-	    (store-stack-tn tn move-temp)))
-	
-	DEFAULTING-DONE
-	(move ocfp-tn csp-tn)
-	(inst compute-code-from-lra code-tn lra-label temp code-tn)
-	
-	(let ((defaults (defaults)))
-	  (assert defaults)
-	  (assemble (*elsewhere*)
-	    (trace-table-entry trace-table-call-site)
-	    DEFAULT-STACK-VALS
-	    (do ((remaining defaults (cdr remaining)))
-		((null remaining))
-	      (let ((def (car remaining)))
-		(emit-label (car def))
-		(when (null (cdr remaining))
-		  (inst b defaulting-done))
-		(store-stack-tn (cdr def) null-tn)))
-	    (trace-table-entry trace-table-normal)))))))
-  (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 (args nargs start count lra-label temp)
-  (declare (type tn args nargs start count temp))
-  (assemble (nil nil :labels (variable-values))
-    (inst b variable-values :nullify t)
-      
-    (inst compute-code-from-lra code-tn lra-label temp code-tn)
-    (inst move csp-tn start)
-    (inst stwm (first register-arg-tns) word-bytes csp-tn)
-    (inst li (fixnum 1) count)
-    
-    DONE
-    
-    (assemble (*elsewhere*)
-      (trace-table-entry trace-table-call-site)
-      VARIABLE-VALUES
-      (inst compute-code-from-lra code-tn lra-label temp code-tn)
-      (do ((arg register-arg-tns (rest arg))
-	   (i 0 (1+ i)))
-	  ((null arg))
-	(storew (first arg) args i))
-      (move args start)
-      (move nargs count)
-      (inst b done :nullify t)
-      (trace-table-entry trace-table-normal)))
-  (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 (any-reg))
-	    (count :scs (any-reg)))
-  (:temporary (:sc descriptor-reg :offset ocfp-offset
-		   :from :eval :to (:result 0))
-	      values-start)
-  (:temporary (:sc any-reg :offset nargs-offset
-	       :from :eval :to (:result 1))
-	      nvals)
-  (:temporary (:scs (non-descriptor-reg)) temp))
-
-
-
-;;;; 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.
-;;;
-;;; Note: we can't use normal load-tn allocation for the fixed args, since all
-;;; registers may be tied up by the more operand.  Instead, we use
-;;; MAYBE-LOAD-STACK-TN.
-;;;
-(define-vop (call-local)
-  (:args (cfp)
-	 (nfp)
-	 (args :more t))
-  (:results (values :more t))
-  (:save-p t)
-  (:move-args :local-call)
-  (:info arg-locs callee target nvals)
-  (:vop-var vop)
-  (:temporary (:scs (descriptor-reg) :from :eval) move-temp)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:temporary (:sc any-reg :offset ocfp-offset :from :eval) ocfp)
-  (:ignore arg-locs args ocfp)
-  (:generator 5
-    (trace-table-entry trace-table-call-site)
-    (let ((label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn nfp-save cur-nfp))
-      (let ((callee-nfp (callee-nfp-tn callee)))
-	(when callee-nfp
-	  (move nfp callee-nfp)))
-      (maybe-load-stack-tn cfp-tn cfp)
-      (inst compute-lra-from-code code-tn label temp
-	    (callee-return-pc-tn callee))
-      (note-this-location vop :call-site)
-      (inst b target :nullify t)
-      (emit-return-pc label)
-      (default-unknown-values vop values nvals move-temp temp label)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save)))
-    (trace-table-entry trace-table-normal)))
-
-;;; 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.
-;;;
-;;; Note: we can't use normal load-tn allocation for the fixed args, since all
-;;; registers may be tied up by the more operand.  Instead, we use
-;;; MAYBE-LOAD-STACK-TN.
-;;;
-(define-vop (multiple-call-local unknown-values-receiver)
-  (:args (cfp)
-	 (nfp)
-	 (args :more t))
-  (:save-p t)
-  (:move-args :local-call)
-  (:info save callee target)
-  (:ignore args save)
-  (:vop-var vop)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:generator 20
-    (trace-table-entry trace-table-call-site)
-    (let ((label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn nfp-save cur-nfp))
-      (let ((callee-nfp (callee-nfp-tn callee)))
-	(when callee-nfp
-	  (move nfp callee-nfp)))
-      (maybe-load-stack-tn cfp-tn cfp)
-      (inst compute-lra-from-code code-tn label temp
-	    (callee-return-pc-tn callee))
-      (note-this-location vop :call-site)
-      (inst b target :nullify t)
-      (emit-return-pc label)
-      (note-this-location vop :unknown-return)
-      (receive-unknown-values values-start nvals start count label temp)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save)))
-    (trace-table-entry trace-table-normal)))
-
-
-;;;; 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.
-;;;
-;;; Note: we can't use normal load-tn allocation for the fixed args, since all
-;;; registers may be tied up by the more operand.  Instead, we use
-;;; MAYBE-LOAD-STACK-TN.
-;;;
-(define-vop (known-call-local)
-  (:args (cfp)
-	 (nfp)
-	 (args :more t))
-  (:results (res :more t))
-  (:move-args :local-call)
-  (:save-p t)
-  (:info save callee target)
-  (:ignore args res save)
-  (:vop-var vop)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 5
-    (trace-table-entry trace-table-call-site)
-    (let ((label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn nfp-save cur-nfp))
-      (let ((callee-nfp (callee-nfp-tn callee)))
-	(when callee-nfp
-	  (move nfp callee-nfp)))
-      (maybe-load-stack-tn cfp-tn cfp)
-      (inst compute-lra-from-code code-tn label temp
-	    (callee-return-pc-tn callee))
-      (note-this-location vop :call-site)
-      (inst b target :nullify t)
-      (emit-return-pc label)
-      (note-this-location vop :known-return)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save)))
-    (trace-table-entry trace-table-normal)))
-
-;;; Return from known values call.  We receive the return locations as
-;;; arguments to terminate their lifetimes in the returning function.  We
-;;; restore FP and CSP and jump to the Return-PC.
-;;;
-;;; Note: we can't use normal load-tn allocation for the fixed args, since all
-;;; registers may be tied up by the more operand.  Instead, we use
-;;; MAYBE-LOAD-STACK-TN.
-;;;
-(define-vop (known-return)
-  (:args (old-fp :target old-fp-temp)
-	 (return-pc :target return-pc-temp)
-	 (vals :more t))
-  (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp)
-  (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp)
-  (:temporary (:scs (interior-reg)) lip)
-  (:move-args :known-return)
-  (:info val-locs)
-  (:ignore val-locs vals)
-  (:vop-var vop)
-  (:generator 6
-    (trace-table-entry trace-table-function-epilogue)
-    (maybe-load-stack-tn old-fp-temp old-fp)
-    (maybe-load-stack-tn return-pc-temp return-pc)
-    (move cfp-tn csp-tn)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(move cur-nfp nsp-tn)))
-    (inst addi (- word-bytes other-pointer-type) return-pc-temp lip)
-    (inst bv lip)
-    (move old-fp-temp cfp-tn)
-    (trace-table-entry trace-table-normal)))
-
-
-;;;; 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 creating a partial frame on the
-;;; stack top and storing stack arguments into that frame.  On entry to the
-;;; callee, this partial frame is pointed to by FP.  If there are no stack
-;;; arguments, we don't bother allocating a partial frame, and instead set FP
-;;; to SP just before the call.
-
-;;; 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-Fp and Return-PC are passed as the second and third arguments.
-;;;
-;;; In non-tail calls, the pointer to the stack arguments is passed as the last
-;;; fixed argument.  If Variable is false, then the passing locations are
-;;; passed as a more arg.  Variable is true if there are a variable number of
-;;; arguments passed on the stack.  Variable cannot be specified with :Tail
-;;; return.  TR variable argument call is implemented separately.
-;;;
-;;; In tail call with fixed arguments, the passing locations are passed as a
-;;; more arg, but there is no new-FP, since the arguments have been set up in
-;;; the current frame.
-;;;
-(eval-when (compile eval)
-(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
-      ,@(unless (eq return :tail)
-	  '((new-fp :scs (any-reg) :to :eval)))
-
-      ,(if named
-	   '(fdefn :target fdefn-pass)
-	   '(arg-fun :target lexenv))
-      
-      ,@(when (eq return :tail)
-	  '((ocfp :target ocfp-pass)
-	    (lra :target lra-pass)))
-      
-      ,@(unless variable '((args :more t :scs (descriptor-reg)))))
-
-     ,@(when (eq return :fixed)
-	 '((:results (values :more t))))
-   
-     (:save-p ,(if (eq return :tail) :compute-only t))
-
-     ,@(unless (or (eq return :tail) variable)
-	 '((:move-args :full-call)))
-
-     (:vop-var vop)
-     (:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
-	    ,@(unless variable '(nargs))
-	    ,@(when (eq return :fixed) '(nvals)))
-
-     (:ignore
-      ,@(unless (or variable (eq return :tail)) '(arg-locs))
-      ,@(unless variable '(args)))
-
-     (:temporary (:sc descriptor-reg
-		  :offset ocfp-offset
-		  ,@(when (eq return :tail)
-		      '(:from (:argument 1)))
-		  ,@(unless (eq return :fixed)
-		      '(:to :eval)))
-		 ocfp-pass)
-
-     (:temporary (:sc descriptor-reg
-		  :offset lra-offset
-		  ,@(when (eq return :tail)
-		      '(:from (:argument 2)))
-		  :to :eval)
-		 lra-pass)
-
-     ,@(if named
-	 `((:temporary (:sc descriptor-reg :offset fdefn-offset
-			:from (:argument ,(if (eq return :tail) 0 1))
-			:to :eval)
-		       fdefn-pass))
-
-	 `((:temporary (:sc descriptor-reg :offset lexenv-offset
-			:from (:argument ,(if (eq return :tail) 0 1))
-			:to :eval)
-		       lexenv)
-	   (:temporary (:scs (descriptor-reg)
-			     :from (:argument ,(if (eq return :tail) 2 1))
-			     :to :eval)
-		       function)))
-
-     (:temporary (:sc any-reg :offset nargs-offset :to :eval)
-		 nargs-pass)
-
-     ,@(when variable
-	 (mapcar #'(lambda (name offset)
-		     `(:temporary (:sc descriptor-reg
-				   :offset ,offset
-				   :to :eval)
-			 ,name))
-		 register-arg-names register-arg-offsets))
-     ,@(when (eq return :fixed)
-	 '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
-
-     ,@(unless (eq return :tail)
-	 '((:temporary (:scs (non-descriptor-reg)) temp)
-	   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
-
-     (:temporary (:scs (interior-reg) :type interior) lip)
-
-     (:generator ,(+ (if named 5 0)
-		     (if variable 19 1)
-		     (if (eq return :tail) 0 10)
-		     15
-		     (if (eq return :unknown) 25 0))
-       (trace-table-entry trace-table-call-site)
-       (let* ((cur-nfp (current-nfp-tn vop))
-	      ,@(unless (eq return :tail)
-		  '((lra-label (gen-label))))
-	      (filler
-	       (list :load-nargs
-		     ,@(if (eq return :tail)
-			   '((unless (location= ocfp ocfp-pass)
-			       :load-ocfp)
-			     (unless (location= lra lra-pass)
-			       :load-lra)
-			     (when cur-nfp
-			       :frob-nfp))
-			   '((when cur-nfp
-			       :frob-nfp)
-			     :comp-lra
-			     :save-fp
-			     :load-fp)))))
-	 (labels
-	     ((do-next-filler ()
-		(when filler
-		  (ecase (pop filler)
-		    ((nil) (do-next-filler))
-		    (:load-nargs
-		     ,@(if variable
-			   `((inst sub csp-tn new-fp nargs-pass)
-			     ,@(let ((index -1))
-				 (mapcar #'(lambda (name)
-					     `(loadw ,name new-fp
-						     ,(incf index)))
-					 register-arg-names)))
-			   '((inst li (fixnum nargs) nargs-pass))))
-		    ,@(if (eq return :tail)
-			  '((:load-ocfp
-			     (sc-case ocfp
-			       (any-reg
-				(inst move ocfp ocfp-pass))
-			       (control-stack
-				(loadw ocfp-pass cfp-tn (tn-offset ocfp)))))
-			    (:load-lra
-			     (sc-case lra
-			       (descriptor-reg
-				(inst move lra lra-pass))
-			       (control-stack
-				(loadw lra-pass cfp-tn (tn-offset lra)))))
-			    (:frob-nfp
-			     (inst move cur-nfp nsp-tn)))
-			  `((:frob-nfp
-			     (store-stack-tn nfp-save cur-nfp))
-			    (:comp-lra
-			     (inst compute-lra-from-code
-				   code-tn lra-label temp lra-pass))
-			    (:save-fp
-			     (inst move cfp-tn ocfp-pass))
-			    (:load-fp
-			     ,(if variable
-				  '(move new-fp cfp-tn)
-				  '(if (> nargs register-arg-count)
-				       (move new-fp cfp-tn)
-				       (move csp-tn cfp-tn))))))))))
-
-	   ,@(if named
-		 `((sc-case fdefn
-		     (descriptor-reg (move fdefn fdefn-pass))
-		     (control-stack
-		      (loadw fdefn-pass cfp-tn (tn-offset fdefn))
-		      (do-next-filler))
-		     (constant
-		      (loadw fdefn-pass code-tn (tn-offset fdefn)
-			     other-pointer-type)
-		      (do-next-filler)))
-		   (loadw lip fdefn-pass fdefn-raw-addr-slot
-			  other-pointer-type)
-		   (do-next-filler))
-		 `((sc-case arg-fun
-		     (descriptor-reg (move arg-fun lexenv))
-		     (control-stack
-		      (loadw lexenv cfp-tn (tn-offset arg-fun))
-		      (do-next-filler))
-		     (constant
-		      (loadw lexenv code-tn (tn-offset arg-fun)
-			     other-pointer-type)
-		      (do-next-filler)))
-		   (loadw function lexenv closure-function-slot
-			  function-pointer-type)
-		   (do-next-filler)
-		   (inst addi (- (ash function-header-code-offset word-shift)
-				 function-pointer-type)
-			 function lip)))
-	   (loop
-	     (cond ((null filler)
-		    (return))
-		   ((null (car filler))
-		    (pop filler))
-		   ((null (cdr filler))
-		    (return))
-		   (t
-		    (do-next-filler))))
-	   
-	   (note-this-location vop :call-site)
-	   (inst bv lip :nullify (null filler))
-	   (do-next-filler))
-
-	 ,@(ecase return
-	     (:fixed
-	      '((emit-return-pc lra-label)
-		(default-unknown-values vop values nvals
-					move-temp temp lra-label)
-		(when cur-nfp
-		  (load-stack-tn cur-nfp nfp-save))))
-	     (:unknown
-	      '((emit-return-pc lra-label)
-		(note-this-location vop :unknown-return)
-		(receive-unknown-values values-start nvals start count
-					lra-label temp)
-		(when cur-nfp
-		  (load-stack-tn cur-nfp nfp-save))))
-	     (:tail)))
-       (trace-table-entry trace-table-normal))))
-);eval-when
-
-(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 special code that BLT's the arguments
-;;; down.
-;;;
-(define-vop (tail-call-variable)
-  (:args (args-arg :scs (any-reg) :target args)
-	 (function-arg :scs (descriptor-reg) :target lexenv)
-	 (old-fp-arg :scs (any-reg) :target old-fp)
-	 (lra-arg :scs (descriptor-reg) :target lra))
-
-  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args)
-  (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv)
-  (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) old-fp)
-  (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra)
-  (:temporary (:scs (any-reg) :from (:argument 3)) tmp)
-
-  (:vop-var vop)
-
-  (:generator 75
-
-    ;; Move these into the passing locations if they are not already there.
-    (move args-arg args)
-    (move function-arg lexenv)
-    (move old-fp-arg old-fp)
-    (move lra-arg lra)
-
-    ;; Clear the number stack if anything is there.
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(inst move cur-nfp nsp-tn)))
-
-    ;; And jump to the assembly-routine that does the bliting.
-    (let ((fixup (make-fixup 'tail-call-variable :assembly-routine)))
-      (inst ldil fixup tmp)
-      (inst be fixup lisp-heap-space tmp :nullify t))))
-
-
-;;;; Unknown values return:
-
-;;; Return a single value using the unknown-values convention.
-;;; 
-(define-vop (return-single)
-  (:args (old-fp :scs (any-reg))
-	 (return-pc :scs (descriptor-reg))
-	 (value))
-  (:ignore value)
-  (:vop-var vop)
-  (:generator 6
-    ;; Clear the number stack.
-    (trace-table-entry trace-table-function-epilogue)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(inst move cur-nfp nsp-tn)))
-    ;; Clear the control stack, and restore the frame pointer.
-    (move cfp-tn csp-tn)
-    (move old-fp cfp-tn)
-    ;; Out of here.
-    (lisp-return return-pc :offset 1)
-    (trace-table-entry trace-table-normal)))
-
-;;; 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
-;;; FP and jump to the single-value entry at Return-PC + 8.
-;;;
-;;; If returning other than one value, then load the number of values returned,
-;;; NIL out unsupplied values registers, restore FP 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-fp :scs (any-reg))
-   (return-pc :scs (descriptor-reg) :to (:eval 1))
-   (values :more t))
-  (:ignore values)
-  (:info nvals)
-  (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0)
-  (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1)
-  (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2)
-  (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3)
-  (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4)
-  (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5)
-  (:temporary (:sc any-reg :offset nargs-offset) nargs)
-  (:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
-  (:vop-var vop)
-  (:generator 6
-    ;; Clear the number stack.
-    (trace-table-entry trace-table-function-epilogue)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(inst move cur-nfp nsp-tn)))
-    ;; Establish the values pointer and values count.
-    (move cfp-tn val-ptr)
-    (inst li (fixnum nvals) nargs)
-    ;; restore the frame pointer and clear as much of the control
-    ;; stack as possible.
-    (move old-fp cfp-tn)
-    (inst addi (* nvals word-bytes) val-ptr csp-tn)
-    ;; pre-default any argument register that need it.
-    (when (< nvals register-arg-count)
-      (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
-	(move null-tn reg)))
-    ;; And away we go.
-    (lisp-return return-pc)
-    (trace-table-entry trace-table-normal)))
-
-;;; 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 an assembly-routine.
-;;;
-(define-vop (return-multiple)
-  (:args
-   (old-fp-arg :scs (any-reg) :to (:eval 1))
-   (lra-arg :scs (descriptor-reg) :to (:eval 1))
-   (vals-arg :scs (any-reg) :target vals)
-   (nvals-arg :scs (any-reg) :target nvals))
-
-  (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp)
-  (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
-  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals)
-  (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals)
-  (:temporary (:sc descriptor-reg :offset a0-offset) a0)
-  (:temporary (:scs (any-reg) :from (:eval 0)) tmp)
-
-  (:vop-var vop)
-  (:node-var node)
-
-  (:generator 13
-    (trace-table-entry trace-table-function-epilogue)
-    ;; Clear the number stack.
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(inst move cur-nfp nsp-tn)))
-
-    (unless (policy node (> space speed))
-      ;; Check for the single case.
-      (inst comib :<> (fixnum 1) nvals-arg not-single)
-      (loadw a0 vals-arg)
-
-      ;; Return with one value.
-      (move cfp-tn csp-tn)
-      (move old-fp-arg cfp-tn)
-      (lisp-return lra-arg :offset 1))
-		
-    ;; Nope, not the single case.
-    NOT-SINGLE
-    (move old-fp-arg old-fp)
-    (move lra-arg lra)
-    (move vals-arg vals)
-    (move nvals-arg nvals)
-    (let ((fixup (make-fixup 'return-multiple :assembly-routine)))
-      (inst ldil fixup tmp)
-      (inst be fixup lisp-heap-space tmp :nullify t))
-    (trace-table-entry trace-table-normal)))
-
-
-
-;;;; XEP hackery:
-
-;;; We don't need to do anything special for regular functions.
-;;;
-(define-vop (setup-environment)
-  (:info label)
-  (:ignore label)
-  (:generator 0
-    ;; Don't bother doing anything.
-    ))
-
-;;; Get the lexical environment from it's passing location.
-;;;
-(define-vop (setup-closure-environment)
-  (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
-	       :to (:result 0))
-	      lexenv)
-  (:results (closure :scs (descriptor-reg)))
-  (:info label)
-  (:ignore label)
-  (:generator 6
-    ;; Get result.
-    (move lexenv closure)))
-
-;;; Copy a more arg from the argument area to the end of the current frame.
-;;; Fixed is the number of non-more arguments. 
-;;;
-(define-vop (copy-more-arg)
-  (:temporary (:sc any-reg :offset nl0-offset) result)
-  (:temporary (:sc any-reg :offset nl1-offset) count)
-  (:temporary (:sc any-reg :offset nl2-offset) src)
-  (:temporary (:sc any-reg :offset nl3-offset) dst)
-  (:temporary (:sc descriptor-reg :offset l0-offset) temp)
-  (:info fixed)
-  (:generator 20
-    ;; Figure out how many things we are going to copy.
-    (unless (zerop fixed)
-      (inst addi (- (fixnum fixed)) nargs-tn count))
-
-    ;; Blow out of here if is nothing to copy.
-    (inst comb :<= (if (zerop fixed) nargs-tn count) zero-tn done :nullify t)
-
-    (when (< fixed register-arg-count)
-      ;; Save a pointer to the results so we can fill in register args.
-      ;; We don't need this if there are more fixed args than reg args.
-      (move csp-tn result))
-
-    ;; Allocate the space on the stack.
-    (inst add csp-tn (if (zerop fixed) nargs-tn count) csp-tn)
-
-    (when (< fixed register-arg-count)
-      ;; We must stop when we run out of stack args, not when we run out of
-      ;; args in general.
-      (inst addi (fixnum (- register-arg-count)) nargs-tn count)
-      ;; Everything of interest in registers.
-      (inst comb :<= count zero-tn do-regs))
-    ;; Initialize dst to be end of stack.
-    (move csp-tn dst)
-
-    ;; Initialize src to be end of args.
-    (inst add cfp-tn nargs-tn src)
-
-    LOOP
-    ;; *--dst = *--src, --count
-    (inst ldwm (- word-bytes) src temp)
-    (inst addib :> (fixnum -1) count loop)
-    (inst stwm temp (- word-bytes) dst)
-
-    DO-REGS
-    (when (< fixed register-arg-count)
-      ;; Now we have to deposit any more args that showed up in registers.
-      ;; We know there is at least one more arg, otherwise we would have
-      ;; branched to done up at the top.
-      (inst addi (fixnum (- fixed)) nargs-tn count)
-      (do ((i fixed (1+ i)))
-	  ((>= i register-arg-count))
-	;; Is this the last one?
-	(inst addib :<= (fixnum -1) count done)
-	;; Store it relative to the pointer saved at the start.
-	(storew (nth i register-arg-tns) result (- i fixed))))
-    DONE))
-
-;;; More args are stored consequtively on the stack, starting immediately at
-;;; the context pointer.  The context pointer is not typed, so the lowtag is 0.
-;;;
-(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg)
-
-
-;;; Turn more arg (context, count) into a list.
-;;;
-(define-vop (listify-rest-args)
-  (:args (context-arg :target context :scs (descriptor-reg))
-	 (count-arg :target count :scs (any-reg)))
-  (:arg-types * tagged-num)
-  (:temporary (:scs (any-reg) :from (:argument 0)) context)
-  (:temporary (:scs (any-reg) :from (:argument 1)) count)
-  (:temporary (:scs (descriptor-reg) :from :eval) temp)
-  (:temporary (:scs (non-descriptor-reg) :from :eval) dst)
-  (:results (result :scs (descriptor-reg)))
-  (:translate %listify-rest-args)
-  (:policy :safe)
-  (:generator 20
-    (let ((loop (gen-label))
-	  (done (gen-label)))
-      (move context-arg context)
-      (move count-arg count)
-      ;; Check to see if there are any arguments.
-      (inst comb := count zero-tn done)
-      (move null-tn result)
-
-      ;; We need to do this atomically.
-      (pseudo-atomic ()
-	;; Allocate a cons (2 words) for each item.
-	(inst move alloc-tn result)
-	(inst dep list-pointer-type 31 3 result)
-	(move result dst)
-	(inst sll count 1 temp)
-	(inst add alloc-tn temp alloc-tn)
-
-	(emit-label loop)
-	;; Grab one value and stash it in the car of this cons.
-	(inst ldwm word-bytes context temp)
-	(storew temp dst 0 vm:list-pointer-type)
-
-	;; Dec count, and if != zero, go back for more.
-	(inst addi (* 2 vm:word-bytes) dst dst)
-	(inst addib :> (fixnum -1) count loop :nullify t)
-	(storew dst dst -1 list-pointer-type)
-
-	;; NIL out the last cons.
-	(storew null-tn dst -1 list-pointer-type))
-      (emit-label done))))
-
-;;; 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.
-;;;
-(setf (info function source-transform 'c::%more-arg-context) nil)
-;;;
-(define-vop (more-arg-context)
-  (:policy :fast-safe)
-  (:translate c::%more-arg-context)
-  (:args (supplied :scs (any-reg)))
-  (:arg-types tagged-num (:constant fixnum))
-  (:info fixed)
-  (:results (context :scs (descriptor-reg))
-	    (count :scs (any-reg)))
-  (:result-types t tagged-num)
-  (:note "more-arg-context")
-  (:generator 5
-    (inst addi (fixnum (- fixed)) supplied count)
-    (inst sub csp-tn count context)))
-
-
-;;; Signal wrong argument count error if Nargs isn't = to Count.
-;;;
-(define-vop (verify-argument-count)
-  (:args (nargs :scs (any-reg)))
-  (:arg-types positive-fixnum)
-  (:info count)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 3
-    (let ((err-lab
-	   (generate-error-code vop invalid-argument-count-error nargs)))
-      (cond ((zerop count)
-	     (inst bc :<> nil nargs zero-tn err-lab))
-	    (t
-	     (inst bci :<> nil (fixnum count) nargs err-lab))))))
-
-;;; Signal an argument count error.
-;;;
-(macrolet ((frob (name error &rest args)
-	     `(define-vop (,name)
-		(:args ,@(mapcar #'(lambda (arg)
-				     `(,arg :scs (any-reg descriptor-reg)))
-				 args))
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 1000
-		  (error-call vop ,error ,@args)))))
-  (frob argument-count-error invalid-argument-count-error nargs)
-  (frob type-check-error object-not-type-error object type)
-  (frob odd-keyword-arguments-error odd-keyword-arguments-error)
-  (frob unknown-keyword-argument-error unknown-keyword-argument-error key)
-  (frob nil-function-returned-error nil-function-returned-error fun))
diff --git a/compiler/hppa/cell.lisp b/compiler/hppa/cell.lisp
deleted file mode 100644
index bb5fd8c6a06ad8e3ddeae2cd6903e0750df4886f..0000000000000000000000000000000000000000
--- a/compiler/hppa/cell.lisp
+++ /dev/null
@@ -1,273 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/cell.lisp,v 1.2 1992/10/28 00:32:43 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the VM definition of various primitive memory access
-;;; VOPs for the HPPA
-;;;
-;;; Written by William Lott.
-;;; 
-
-(in-package "HPPA")
-
-
-;;;; Data object definition macros.
-
-(define-for-each-primitive-object (obj)
-  (collect ((forms))
-    (let ((lowtag (primitive-object-lowtag obj)))
-      (dolist (slot (primitive-object-slots obj))
-	(let* ((name (slot-name slot))
-	       (offset (slot-offset slot))
-	       (rest-p (slot-rest-p slot))
-	       (slot-opts (slot-options slot))
-	       (ref-trans (getf slot-opts :ref-trans))
-	       (ref-vop (getf slot-opts :ref-vop ref-trans))
-	       (set-trans (getf slot-opts :set-trans))
-	       (setf-function-p (and (listp set-trans)
-				     (= (length set-trans) 2)
-				     (eq (car set-trans) 'setf)))
-	       (setf-vop (getf slot-opts :setf-vop
-			       (when setf-function-p
-				 (intern (concatenate
-					  'simple-string
-					  "SET-"
-					  (string (cadr set-trans)))))))
-	       (set-vop (getf slot-opts :set-vop
-			      (if setf-vop nil set-trans))))
-	  (when ref-vop
-	    (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref))
-				(:variant ,offset ,lowtag)
-		      ,@(when ref-trans
-			  `((:translate ,ref-trans))))))
-	  (when (or set-vop setf-vop)
-	    (forms `(define-vop ,(cond ((and rest-p setf-vop)
-					(error "Can't automatically generate ~
-					a setf VOP for :rest-p ~
-					slots: ~S in ~S"
-					       name
-					       (primitive-object-name obj)))
-				       (rest-p `(,set-vop slot-set))
-				       ((and set-vop setf-function-p)
-					(error "Setf functions (list ~S) must ~
-					use :setf-vops."
-					       set-trans))
-				       (set-vop `(,set-vop cell-set))
-				       (setf-function-p
-					`(,setf-vop cell-setf-function))
-				       (t
-					`(,setf-vop cell-setf)))
-		      (:variant ,offset ,lowtag)
-		      ,@(when set-trans
-			  `((:translate ,set-trans)))))))))
-    (when (forms)
-      `(progn
-	 ,@(forms)))))
-
-
-
-;;;; 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) :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 object obj-temp)
-    (loadw value obj-temp symbol-value-slot other-pointer-type)
-    (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
-      (inst li unbound-marker-type temp)
-      (inst bc := nil value temp err-lab))))
-
-;;; 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 symbol-value-slot other-pointer-type)
-    (inst li unbound-marker-type temp)
-    (inst bc :<> not-p value temp target)))
-
-(define-vop (fast-symbol-value cell-ref)
-  (:variant symbol-value-slot other-pointer-type)
-  (:policy :fast)
-  (:translate symbol-value))
-
-
-
-;;;; Fdefinition (fdefn) objects.
-
-(define-vop (safe-fdefn-function)
-  (:args (object :scs (descriptor-reg) :target obj-temp))
-  (:results (value :scs (descriptor-reg any-reg)))
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
-  (:generator 10
-    (move obj-temp object)
-    (loadw value obj-temp fdefn-function-slot other-pointer-type)
-    (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
-      (inst bc := nil value null-tn err-lab))))
-
-(define-vop (set-fdefn-function)
-  (:policy :fast-safe)
-  (:translate (setf fdefn-function))
-  (:args (function :scs (descriptor-reg) :target result)
-	 (fdefn :scs (descriptor-reg)))
-  (:temporary (:scs (interior-reg)) lip)
-  (:temporary (:scs (non-descriptor-reg)) type)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 38
-    (load-type type function (- function-pointer-type))
-    (inst addi (- function-header-type) type type)
-    (inst comb := type zero-tn normal-fn)
-    (inst addi (- (ash function-header-code-offset word-shift)
-		  function-pointer-type)
-	  function lip)
-    (inst li (make-fixup "closure_tramp" :foreign) lip)
-    NORMAL-FN
-    (storew function fdefn fdefn-function-slot other-pointer-type)
-    (storew lip fdefn fdefn-raw-addr-slot other-pointer-type)
-    (move function result)))
-
-(define-vop (fdefn-makunbound)
-  (:policy :fast-safe)
-  (:translate fdefn-makunbound)
-  (:args (fdefn :scs (descriptor-reg) :target result))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 38
-    (storew null-tn fdefn fdefn-function-slot other-pointer-type)
-    (inst li (make-fixup "undefined_tramp" :foreign) temp)
-    (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)
-    (move fdefn result)))
-
-
-
-;;;; 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 symbol-value-slot other-pointer-type)
-    (inst addi (* binding-size word-bytes) bsp-tn bsp-tn)
-    (storew temp bsp-tn (- binding-value-slot binding-size))
-    (storew symbol bsp-tn (- binding-symbol-slot binding-size))
-    (storew val symbol symbol-value-slot other-pointer-type)))
-
-(define-vop (unbind)
-  (:temporary (:scs (descriptor-reg)) symbol value)
-  (:generator 0
-    (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
-    (loadw value bsp-tn (- binding-value-slot binding-size))
-    (storew value symbol symbol-value-slot other-pointer-type)
-    (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
-    (inst addi (- (* binding-size word-bytes)) bsp-tn bsp-tn)))
-
-(define-vop (unbind-to-here)
-  (:args (where :scs (descriptor-reg any-reg)))
-  (:temporary (:scs (descriptor-reg)) symbol value)
-  (:generator 0
-    (inst comb := where bsp-tn done :nullify t)
-    (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
-
-    LOOP
-    (inst comb := symbol zero-tn skip)
-    (loadw value bsp-tn (- binding-value-slot binding-size))
-    (storew value symbol symbol-value-slot other-pointer-type)
-    (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
-
-    SKIP
-    (inst addi (* -2 word-bytes) bsp-tn bsp-tn)
-    (inst comb :<> where bsp-tn loop :nullify t)
-    (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
-
-    DONE))
-
-
-
-;;;; Closure indexing.
-
-(define-full-reffer closure-index-ref *
-  closure-info-offset function-pointer-type
-  (descriptor-reg any-reg) * %closure-index-ref)
-
-(define-full-setter set-funcallable-instance-info *
-  funcallable-instance-info-offset function-pointer-type
-  (descriptor-reg any-reg) * %set-funcallable-instance-info)
-
-
-
-;;;; Structure hackery:
-
-(define-vop (structure-length)
-  (:policy :fast-safe)
-  (:translate structure-length)
-  (:args (struct :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 4
-    (loadw res struct 0 structure-pointer-type)
-    (inst srl res type-bits res)))
-
-(define-vop (structure-ref slot-ref)
-  (:variant structure-slots-offset structure-pointer-type)
-  (:policy :fast-safe)
-  (:translate structure-ref)
-  (:arg-types structure (:constant index)))
-
-(define-vop (structure-set slot-set)
-  (:policy :fast-safe)
-  (:translate structure-set)
-  (:variant structure-slots-offset structure-pointer-type)
-  (:arg-types structure (:constant index) *))
-
-(define-full-reffer structure-index-ref * structure-slots-offset
-  structure-pointer-type (descriptor-reg any-reg) * structure-ref)
-
-(define-full-setter structure-index-set * structure-slots-offset
-  structure-pointer-type (descriptor-reg any-reg) * structure-set)
-
-
-
-;;;; Code object frobbing.
-
-(define-full-reffer code-header-ref * 0 other-pointer-type
-  (descriptor-reg any-reg) * code-header-ref)
-
-(define-full-setter code-header-set * 0 other-pointer-type
-  (descriptor-reg any-reg) * code-header-set)
diff --git a/compiler/hppa/char.lisp b/compiler/hppa/char.lisp
deleted file mode 100644
index 537b4d6d24d171c480de8db31618953c3bf1fee6..0000000000000000000000000000000000000000
--- a/compiler/hppa/char.lisp
+++ /dev/null
@@ -1,137 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/char.lisp,v 1.1 1992/07/13 03:48:20 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;; 
-;;; This file contains the HPPA VM definition of character operations.
-;;;
-;;; Written by William Lott
-;;;
-(in-package "HPPA")
-
-
-;;;; Moves and coercions:
-
-;;; Move a tagged char to an untagged representation.
-;;;
-(define-vop (move-to-base-char)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (y :scs (base-char-reg)))
-  (:generator 1
-    (inst srl x type-bits y)))
-;;;
-(define-move-vop move-to-base-char :move
-  (any-reg descriptor-reg) (base-char-reg))
-
-;;; Move an untagged char to a tagged representation.
-;;;
-(define-vop (move-from-base-char)
-  (:args (x :scs (base-char-reg)))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (inst sll x type-bits y)
-    (inst addi base-char-type y y)))
-;;;
-(define-move-vop move-from-base-char :move
-  (base-char-reg) (any-reg descriptor-reg))
-
-;;; Move untagged base-char values.
-;;;
-(define-vop (base-char-move)
-  (:args (x :target y
-	    :scs (base-char-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (base-char-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:generator 0
-    (move x y)))
-;;;
-(define-move-vop base-char-move :move
-  (base-char-reg) (base-char-reg))
-
-
-;;; Move untagged base-char arguments/return-values.
-;;;
-(define-vop (move-base-char-argument)
-  (:args (x :target y
-	    :scs (base-char-reg))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y base-char-reg))))
-  (:results (y))
-  (:generator 0
-    (sc-case y
-      (base-char-reg
-       (move x y))
-      (base-char-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-base-char-argument :move-argument
-  (any-reg base-char-reg) (base-char-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
-;;; to a descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (base-char-reg) (any-reg descriptor-reg))
-
-
-
-;;;; Other operations:
-
-(define-vop (char-code)
-  (:translate char-code)
-  (:policy :fast-safe)
-  (:args (ch :scs (base-char-reg) :target res))
-  (:arg-types base-char)
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 1
-    (move ch res)))
-
-(define-vop (code-char)
-  (:translate code-char)
-  (:policy :fast-safe)
-  (:args (code :scs (unsigned-reg) :target res))
-  (:arg-types positive-fixnum)
-  (:results (res :scs (base-char-reg)))
-  (:result-types base-char)
-  (:generator 1
-    (move code res)))
-
-
-;;; Comparison of base-chars.
-;;;
-(define-vop (base-char-compare)
-  (:args (x :scs (base-char-reg))
-	 (y :scs (base-char-reg)))
-  (:arg-types base-char base-char)
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:note "inline comparison")
-  (:variant-vars cond)
-  (:generator 3
-    (inst bc cond not-p x y target)))
-
-(define-vop (fast-char=/base-char base-char-compare)
-  (:translate char=)
-  (:variant :=))
-
-(define-vop (fast-char</base-char base-char-compare)
-  (:translate char<)
-  (:variant :<<))
-
-(define-vop (fast-char>/base-char base-char-compare)
-  (:translate char>)
-  (:variant :>>))
diff --git a/compiler/hppa/debug.lisp b/compiler/hppa/debug.lisp
deleted file mode 100644
index 22eaaa9ebde86b973f21bd9b7f8eeef677bcfc5f..0000000000000000000000000000000000000000
--- a/compiler/hppa/debug.lisp
+++ /dev/null
@@ -1,138 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/debug.lisp,v 1.1 1992/07/13 03:48:21 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Compiler support for the new whizzy debugger.
-;;;
-;;; Written by William Lott.
-;;; 
-(in-package "HPPA")
-
-
-(define-vop (debug-cur-sp)
-  (:translate current-sp)
-  (:policy :fast-safe)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 1
-    (move csp-tn res)))
-
-(define-vop (debug-cur-fp)
-  (:translate current-fp)
-  (:policy :fast-safe)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 1
-    (move cfp-tn res)))
-
-(define-vop (read-control-stack)
-  (:translate stack-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (sap-reg))
-	 (offset :scs (any-reg)))
-  (:arg-types system-area-pointer positive-fixnum)
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:generator 5
-    (inst ldwx offset object result)))
-
-(define-vop (read-control-stack-c)
-  (:translate stack-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (sap-reg)))
-  (:info offset)
-  (:arg-types system-area-pointer (:constant (signed-byte 12)))
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:generator 4
-    (inst ldw (* offset word-bytes) object result)))
-
-(define-vop (write-control-stack)
-  (:translate %set-stack-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (sap-reg) :target sap)
-	 (offset :scs (any-reg))
-	 (value :scs (descriptor-reg) :target result))
-  (:arg-types system-area-pointer positive-fixnum *)
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
-  (:generator 2
-    (inst add object offset sap)
-    (inst stw value 0 sap)
-    (move value result)))
-
-(define-vop (write-control-stack-c)
-  (:translate %set-stack-ref)
-  (:policy :fast-safe)
-  (:args (sap :scs (sap-reg))
-	 (value :scs (descriptor-reg) :target result))
-  (:info offset)
-  (:arg-types system-area-pointer (:constant (signed-byte 12)) *)
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:generator 1
-    (inst stw value (* offset word-bytes) sap)
-    (move value result)))
-
-(define-vop (code-from-mumble)
-  (:policy :fast-safe)
-  (:args (thing :scs (descriptor-reg) :to :save))
-  (:results (code :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:variant-vars lowtag)
-  (:generator 5
-    (loadw temp thing 0 lowtag)
-    (inst srl temp type-bits temp)
-    (inst comb := zero-tn temp done)
-    (move null-tn code)
-    (inst sll temp (1- (integer-length word-bytes)) temp)
-    (unless (= lowtag other-pointer-type)
-      (inst addi (- lowtag vm:other-pointer-type) temp temp))
-    (inst sub thing temp code)
-    DONE))
-
-(define-vop (code-from-lra code-from-mumble)
-  (:translate lra-code-header)
-  (:variant other-pointer-type))
-
-(define-vop (code-from-function code-from-mumble)
-  (:translate function-code-header)
-  (:variant function-pointer-type))
-
-(define-vop (make-lisp-obj)
-  (:policy :fast-safe)
-  (:translate make-lisp-obj)
-  (:args (value :scs (unsigned-reg) :target result))
-  (:arg-types unsigned-num)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 1
-    (move value result)))
-
-(define-vop (get-lisp-obj-address)
-  (:policy :fast-safe)
-  (:translate get-lisp-obj-address)
-  (:args (thing :scs (descriptor-reg) :target result))
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (move thing result)))
-
-(define-vop (function-word-offset)
-  (:policy :fast-safe)
-  (:translate function-word-offset)
-  (:args (fun :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 5
-    (loadw res fun 0 function-pointer-type)
-    (inst srl res type-bits res)))
diff --git a/compiler/hppa/float.lisp b/compiler/hppa/float.lisp
deleted file mode 100644
index 5be45a69540c712a8044352f09fcb690993921d1..0000000000000000000000000000000000000000
--- a/compiler/hppa/float.lisp
+++ /dev/null
@@ -1,601 +0,0 @@
-;;; -*- Package: hppa -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/float.lisp,v 1.2 1992/07/14 03:45:04 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the floating point support for the HP-PA.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "HPPA")
-
-
-;;;; Move functions.
-
-(define-move-function (load-fp-zero 1) (vop x y)
-  ((fp-single-zero) (single-reg)
-   (fp-double-zero) (double-reg))
-  (inst funop :copy x y))
-
-
-(define-move-function (load-float 1) (vop x y)
-  ((single-stack) (single-reg)
-   (double-stack) (double-reg))
-  (let ((offset (* (tn-offset x) word-bytes)))
-    (cond ((< offset (ash 1 4))
-	   (inst flds offset (current-nfp-tn vop) y))
-	  (t
-	   (inst ldo offset zero-tn lip-tn)
-	   (inst fldx lip-tn (current-nfp-tn vop) y)))))
-
-(define-move-function (store-float 1) (vop x y)
-  ((single-reg) (single-stack)
-   (double-reg) (double-stack))
-  (let ((offset (* (tn-offset y) word-bytes)))
-    (cond ((< offset (ash 1 4))
-	   (inst fsts x offset (current-nfp-tn vop)))
-	  (t
-	   (inst ldo offset zero-tn lip-tn)
-	   (inst fstx x lip-tn (current-nfp-tn vop))))))
-
-
-
-;;;; Move VOPs
-
-(define-vop (move-float)
-  (:args (x :scs (single-reg double-reg)
-	    :target y
-	    :load-if (not (location= x y))))
-  (:results (y :scs (single-reg double-reg)
-	       :load-if (not (location= x y))))
-  (:note "float move")
-  (:generator 0
-    (unless (location= y x)
-      (inst funop :copy x y))))
-
-(define-move-vop move-float :move (single-reg) (single-reg))
-(define-move-vop move-float :move (double-reg) (double-reg))
-
-
-(define-vop (move-from-float)
-  (:args (x :to :save))
-  (:results (y :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:variant-vars size type data)
-  (:note "float to pointer coercion")
-  (:generator 13
-    (with-fixed-allocation (y ndescr type size))
-    (inst fsts x (- (* data word-bytes) other-pointer-type) y)))
-
-(macrolet ((frob (name sc &rest args)
-	     `(progn
-		(define-vop (,name move-from-float)
-		  (:args (x :scs (,sc) :to :save))
-		  (:variant ,@args))
-		(define-move-vop ,name :move (,sc) (descriptor-reg)))))
-  (frob move-from-single single-reg
-    single-float-size single-float-type single-float-value-slot)
-  (frob move-from-double double-reg
-    double-float-size double-float-type double-float-value-slot))
-
-(define-vop (move-from-float)
-  (:args (x :scs (descriptor-reg)))
-  (:results (y))
-  (:variant-vars offset)
-  (:note "pointer to float coercion")
-  (:generator 2
-    (inst flds (- (* offset word-bytes) other-pointer-type) x y)))
-
-(macrolet ((frob (name sc offset)
-	     `(progn
-		(define-vop (,name move-from-float)
-		  (:results (y :scs (,sc)))
-		  (:variant ,offset))
-		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
-  (frob move-to-single single-reg single-float-value-slot)
-  (frob move-to-double double-reg double-float-value-slot))
-
-
-(define-vop (move-float-argument)
-  (:args (x :scs (single-reg double-reg) :target y)
-	 (nfp :scs (any-reg)
-	      :load-if (not (sc-is y single-reg double-reg))))
-  (:results (y))
-  (:note "float argument move")
-  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
-  (:generator 1
-    (sc-case y
-      ((single-reg double-reg)
-       (unless (location= x y)
-	 (inst funop :copy x y)))
-      ((single-stack double-stack)
-       (let ((offset (* (tn-offset y) word-bytes)))
-	 (cond ((< offset (ash 1 4))
-		(inst fsts x offset nfp))
-	       (t
-		(inst ldo offset zero-tn index)
-		(inst fstx x index nfp))))))))
-
-(define-move-vop move-float-argument :move-argument
-  (single-reg descriptor-reg) (single-reg))
-(define-move-vop move-float-argument :move-argument
-  (double-reg descriptor-reg) (double-reg))
-
-
-(define-move-vop move-argument :move-argument
-  (single-reg double-reg) (descriptor-reg))
-
-
-
-;;;; Arithmetic VOPs.
-
-(define-vop (float-op)
-  (:args (x) (y))
-  (:results (r))
-  (:variant-vars operation)
-  (:policy :fast-safe)
-  (:note "inline float arithmetic")
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:node-var node)
-  (:generator 0
-    (inst fbinop operation x y r)
-    (when (policy node (or (= debug 3) (> safety speed)))
-      (note-next-instruction vop :internal-error)
-      (inst fsts fp-single-zero-tn 0 csp-tn))))
-
-(macrolet ((frob (name sc zero-sc ptype)
-	     `(define-vop (,name float-op)
-		(:args (x :scs (,sc ,zero-sc))
-		       (y :scs (,sc ,zero-sc)))
-		(:results (r :scs (,sc)))
-		(:arg-types ,ptype ,ptype)
-		(:result-types ,ptype))))
-  (frob single-float-op single-reg fp-single-zero single-float)
-  (frob double-float-op double-reg fp-double-zero double-float))
-
-(macrolet ((frob (translate op sname scost dname dcost)
-	     `(progn
-		(define-vop (,sname single-float-op)
-		  (:translate ,translate)
-		  (:variant ,op)
-		  (:variant-cost ,scost))
-		(define-vop (,dname double-float-op)
-		  (:translate ,translate)
-		  (:variant ,op)
-		  (:variant-cost ,dcost)))))
-  (frob + :add +/single-float 2 +/double-float 2)
-  (frob - :sub -/single-float 2 -/double-float 2)
-  (frob * :mpy */single-float 4 */double-float 5)
-  (frob / :div //single-float 12 //double-float 19))
-
-
-(macrolet ((frob (name translate sc type inst)
-	     `(define-vop (,name)
-		(:args (x :scs (,sc)))
-		(:results (y :scs (,sc)))
-		(:translate ,translate)
-		(:policy :fast-safe)
-		(:arg-types ,type)
-		(:result-types ,type)
-		(:note "inline float arithmetic")
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:node-var node)
-		(:generator 1
-		  ,inst
-		  (when (policy node (or (= debug 3) (> safety speed)))
-		    (note-next-instruction vop :internal-error)
-		    (inst fsts fp-single-zero-tn 0 csp-tn))))))
-  (frob abs/single-float abs single-reg single-float
-    (inst funop :abs x y))
-  (frob abs/double-float abs double-reg double-float
-    (inst funop :abs x y))
-  (frob %negate/single-float %negate single-reg single-float
-    (inst fbinop :sub fp-single-zero-tn x y))
-  (frob %negate/double-float %negate double-reg double-float
-    (inst fbinop :sub fp-double-zero-tn x y)))
-
-
-;;;; Comparison:
-
-(define-vop (float-compare)
-  (:args (x) (y))
-  (:conditional)
-  (:info target not-p)
-  (:variant-vars condition complement)
-  (:policy :fast-safe)
-  (:note "inline float comparison")
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 3
-    ;; This is the condition to nullify the branch, so it is inverted.
-    (inst fcmp (if not-p condition complement) x y)
-    (note-next-instruction vop :internal-error)
-    (inst ftest)
-    (inst b target :nullify t)))
-
-(macrolet ((frob (name sc zero-sc ptype)
-	     `(define-vop (,name float-compare)
-		(:args (x :scs (,sc ,zero-sc))
-		       (y :scs (,sc ,zero-sc)))
-		(:arg-types ,ptype ,ptype))))
-  (frob single-float-compare single-reg fp-single-zero single-float)
-  (frob double-float-compare double-reg fp-double-zero double-float))
-
-(macrolet ((frob (translate condition complement sname dname)
-	     `(progn
-		(define-vop (,sname single-float-compare)
-		  (:translate ,translate)
-		  (:variant ,condition ,complement))
-		(define-vop (,dname double-float-compare)
-		  (:translate ,translate)
-		  (:variant ,condition ,complement)))))
-  (frob < #b01001 #b10101 </single-float </double-float)
-  (frob > #b10001 #b01101 >/single-float >/double-float)
-  (frob eql #b00101 #b11001 eql/single-float eql/double-float))
-
-
-;;;; Conversion:
-
-(macrolet ((frob (name translate from-sc from-type to-sc to-type)
-	     `(define-vop (,name)
-		(:args (x :scs (,from-sc)))
-		(:results (y :scs (,to-sc)))
-		(:arg-types ,from-type)
-		(:result-types ,to-type)
-		(:policy :fast-safe)
-		(:note "inline float coercion")
-		(:translate ,translate)
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:node-var node)
-		(:generator 2
-		  (inst fcnvff x y)
-		  (when (policy node (or (= debug 3) (> safety speed)))
-		    (note-next-instruction vop :internal-error)
-		    (inst fsts fp-single-zero-tn 0 csp-tn))))))
-  (frob %single-float/double-float %single-float
-    double-reg double-float
-    single-reg single-float)
-  (frob %double-float/single-float %double-float
-    single-reg single-float
-    double-reg double-float))
-
-(macrolet ((frob (name translate to-sc to-type)
-	     `(define-vop (,name)
-		(:args (x :scs (signed-reg)
-			  :load-if (not (sc-is x signed-stack))
-			  :target stack-temp))
-		(:arg-types signed-num)
-		(:results (y :scs (,to-sc)))
-		(:result-types ,to-type)
-		(:policy :fast-safe)
-		(:note "inline float coercion")
-		(:translate ,translate)
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:node-var node)
-		(:temporary (:scs (signed-stack) :from (:argument 0))
-			    stack-temp)
-		(:temporary (:scs (single-reg) :to (:result 0) :target y)
-			    fp-temp)
-		(:temporary (:scs (any-reg) :from (:argument 0)
-				  :to (:result 0)) index)
-		(:generator 5
-		  (let* ((nfp (current-nfp-tn vop))
-			 (stack-tn
-			  (sc-case x
-			    (signed-stack
-			     x)
-			    (signed-reg
-			     (storew x nfp (tn-offset stack-temp))
-			     stack-temp)))
-			 (offset (* (tn-offset stack-tn) word-bytes)))
-		    (cond ((< offset (ash 1 4))
-			   (inst flds offset nfp fp-temp))
-			  (t
-			   (inst ldo offset zero-tn index)
-			   (inst fldx index nfp fp-temp)))
-		    (inst fcnvxf fp-temp y)
-		    (when (policy node (or (= debug 3) (> safety speed)))
-		      (note-next-instruction vop :internal-error)
-		      (inst fsts fp-single-zero-tn 0 csp-tn)))))))
-  (frob %single-float/signed %single-float
-    single-reg single-float)
-  (frob %double-float/signed %double-float
-    double-reg double-float))
-
-
-(macrolet ((frob (trans from-sc from-type inst note)
-	     `(define-vop (,(symbolicate trans "/" from-type))
-		(:args (x :scs (,from-sc)
-			  :target fp-temp))
-		(:results (y :scs (signed-reg)
-			     :load-if (not (sc-is y signed-stack))))
-		(:arg-types ,from-type)
-		(:result-types signed-num)
-		(:translate ,trans)
-		(:policy :fast-safe)
-		(:note ,note)
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:temporary (:scs (single-reg) :from (:argument 0)) fp-temp)
-		(:temporary (:scs (signed-stack) :to (:result 0) :target y)
-			    stack-temp)
-		(:temporary (:scs (any-reg) :from (:argument 0)
-				  :to (:result 0)) index)
-		(:generator 3
-		  (let* ((nfp (current-nfp-tn vop))
-			 (stack-tn
-			  (sc-case y
-			    (signed-stack y)
-			    (signed-reg stack-temp)))
-			 (offset (* (tn-offset stack-tn) word-bytes)))
-		    (inst ,inst x fp-temp)
-		    (cond ((< offset (ash 1 4))
-			   (note-next-instruction vop :internal-error)
-			   (inst fsts fp-temp offset nfp))
-			  (t
-			   (inst ldo offset zero-tn index)
-			   (note-next-instruction vop :internal-error)
-			   (inst fstx fp-temp index nfp)))
-		    (unless (eq y stack-tn)
-		      (loadw y nfp (tn-offset stack-tn))))))))
-  (frob %unary-round single-reg single-float fcnvfx "inline float round")
-  (frob %unary-round double-reg double-float fcnvfx "inline float round")
-  (frob %unary-truncate single-reg single-float fcnvfxt
-    "inline float truncate")
-  (frob %unary-truncate double-reg double-float fcnvfxt
-    "inline float truncate"))
-
-
-(define-vop (make-single-float)
-  (:args (bits :scs (signed-reg)
-	       :load-if (or (not (sc-is bits signed-stack))
-			    (sc-is res single-stack))
-	       :target res))
-  (:results (res :scs (single-reg)
-		 :load-if (not (sc-is bits single-stack))))
-  (:arg-types signed-num)
-  (:result-types single-float)
-  (:translate make-single-float)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:temporary (:scs (single-stack) :from (:argument 0) :to (:result 0)) temp)
-  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
-  (:generator 2
-    (let ((nfp (current-nfp-tn vop)))
-      (sc-case bits
-	(signed-reg
-	 (sc-case res
-	   (single-reg
-	    (let ((offset (* (tn-offset temp) word-bytes)))
-	      (inst stw bits offset nfp)
-	      (cond ((< offset (ash 1 4))
-		     (inst flds offset nfp res))
-		    (t
-		     (inst ldo offset zero-tn index)
-		     (inst fldx index nfp res)))))
-	   (single-stack
-	    (inst stw bits (* (tn-offset res) word-bytes) nfp))))
-	(signed-stack
-	 (sc-case res
-	   (single-reg
-	    (let ((offset (* (tn-offset bits) word-bytes)))
-	      (cond ((< offset (ash 1 4))
-		     (inst flds offset nfp res))
-		    (t
-		     (inst ldo offset zero-tn index)
-		     (inst fldx index nfp res)))))))))))
-
-(define-vop (make-double-float)
-  (:args (hi-bits :scs (signed-reg))
-	 (lo-bits :scs (unsigned-reg)))
-  (:results (res :scs (double-reg)
-		 :load-if (not (sc-is res double-stack))))
-  (:arg-types signed-num unsigned-num)
-  (:result-types double-float)
-  (:translate make-double-float)
-  (:policy :fast-safe)
-  (:temporary (:scs (double-stack) :to (:result 0)) temp)
-  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
-  (:vop-var vop)
-  (:generator 2
-    (let* ((nfp (current-nfp-tn vop))
-	   (stack-tn (sc-case res
-		       (double-stack res)
-		       (double-reg temp)))
-	   (offset (* (tn-offset stack-tn) word-bytes)))
-      (inst stw hi-bits offset nfp)
-      (inst stw lo-bits (+ offset word-bytes) nfp)
-      (cond ((eq stack-tn res))
-	    ((< offset (ash 1 4))
-	     (inst flds offset nfp res))
-	    (t
-	     (inst ldo offset zero-tn index)
-	     (inst fldx index nfp res))))))
-
-
-(define-vop (single-float-bits)
-  (:args (float :scs (single-reg)
-		:load-if (not (sc-is float single-stack))))
-  (:results (bits :scs (signed-reg)
-		  :load-if (or (not (sc-is bits signed-stack))
-			       (sc-is float single-stack))))
-  (:arg-types single-float)
-  (:result-types signed-num)
-  (:translate single-float-bits)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
-  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
-  (:generator 2
-    (let ((nfp (current-nfp-tn vop)))
-      (sc-case float
-	(single-reg
-	 (sc-case bits
-	   (signed-reg
-	    (let ((offset (* (tn-offset temp) word-bytes)))
-	      (cond ((< offset (ash 1 4))
-		     (inst fsts float offset nfp))
-		    (t
-		     (inst ldo offset zero-tn index)
-		     (inst fstx float index nfp)))
-	      (inst ldw offset nfp bits)))
-	   (signed-stack
-	    (let ((offset (* (tn-offset bits) word-bytes)))
-	      (cond ((< offset (ash 1 4))
-		     (inst fsts float offset nfp))
-		    (t
-		     (inst ldo offset zero-tn index)
-		     (inst fstx float index nfp)))))))
-	(single-stack
-	 (sc-case bits
-	   (signed-reg
-	    (inst ldw (* (tn-offset float) word-bytes) nfp bits))))))))
-
-(define-vop (double-float-high-bits)
-  (:args (float :scs (double-reg)
-		:load-if (not (sc-is float double-stack))))
-  (:results (hi-bits :scs (signed-reg)
-		     :load-if (or (not (sc-is hi-bits signed-stack))
-				  (sc-is float double-stack))))
-  (:arg-types double-float)
-  (:result-types signed-num)
-  (:translate double-float-high-bits)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
-  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
-  (:generator 2
-    (let ((nfp (current-nfp-tn vop)))
-      (sc-case float
-	(double-reg
-	 (sc-case hi-bits
-	   (signed-reg
-	    (let ((offset (* (tn-offset temp) word-bytes)))
-	      (cond ((< offset (ash 1 4))
-		     (inst fsts float offset nfp :side 0))
-		    (t
-		     (inst ldo offset zero-tn index)
-		     (inst fstx float index nfp :side 0)))
-	      (inst ldw offset nfp hi-bits)))
-	   (signed-stack
-	    (let ((offset (* (tn-offset hi-bits) word-bytes)))
-	      (cond ((< offset (ash 1 4))
-		     (inst fsts float offset nfp :side 0))
-		    (t
-		     (inst ldo offset zero-tn index)
-		     (inst fstx float index nfp :side 0)))))))
-	(double-stack
-	 (sc-case hi-bits
-	   (signed-reg
-	    (let ((offset (* (tn-offset float) word-bytes)))
-	      (inst ldw offset nfp hi-bits)))))))))
-
-(define-vop (double-float-low-bits)
-  (:args (float :scs (double-reg)
-		:load-if (not (sc-is float double-stack))))
-  (:results (lo-bits :scs (unsigned-reg)
-		     :load-if (or (not (sc-is lo-bits unsigned-stack))
-				  (sc-is float double-stack))))
-  (:arg-types double-float)
-  (:result-types unsigned-num)
-  (:translate double-float-low-bits)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
-  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
-  (:generator 2
-    (let ((nfp (current-nfp-tn vop)))
-      (sc-case float
-	(double-reg
-	 (sc-case lo-bits
-	   (unsigned-reg
-	    (let ((offset (* (tn-offset temp) word-bytes)))
-	      (cond ((< offset (ash 1 4))
-		     (inst fsts float offset nfp :side 1))
-		    (t
-		     (inst ldo offset zero-tn index)
-		     (inst fstx float index nfp :side 1)))
-	      (inst ldw offset nfp lo-bits)))
-	   (unsigned-stack
-	    (let ((offset (* (tn-offset lo-bits) word-bytes)))
-	      (cond ((< offset (ash 1 4))
-		     (inst fsts float offset nfp :side 1))
-		    (t
-		     (inst ldo offset zero-tn index)
-		     (inst fstx float index nfp :side 1)))))))
-	(double-stack
-	 (sc-case lo-bits
-	   (unsigned-reg
-	    (let ((offset (* (1+ (tn-offset float)) word-bytes)))
-	      (inst ldw offset nfp lo-bits)))))))))
-
-
-
-;;;; Float mode hackery:
-
-(deftype float-modes () '(unsigned-byte 32))
-(defknown floating-point-modes () float-modes (flushable))
-(defknown ((setf floating-point-modes)) (float-modes)
-  float-modes)
-
-(define-vop (floating-point-modes)
-  (:results (res :scs (unsigned-reg)
-		 :load-if (not (sc-is res unsigned-stack))))
-  (:result-types unsigned-num)
-  (:translate floating-point-modes)
-  (:policy :fast-safe)
-  (:temporary (:scs (unsigned-stack) :to (:result 0)) temp)
-  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
-  (:vop-var vop)
-  (:generator 3
-    (let* ((nfp (current-nfp-tn vop))
-	   (stack-tn (sc-case res
-		       (unsigned-stack res)
-		       (unsigned-reg temp)))
-	   (offset (* (tn-offset stack-tn) word-bytes)))
-      (cond ((< offset (ash 1 4))
-	     (inst fsts fp-single-zero-tn offset nfp))
-	    (t
-	     (inst ldo offset zero-tn index)
-	     (inst fstx fp-single-zero-tn index nfp)))
-      (unless (eq stack-tn res)
-	(inst ldw offset nfp res)))))
-
-(define-vop (set-floating-point-modes)
-  (:args (new :scs (unsigned-reg)
-	      :load-if (not (sc-is new unsigned-stack))))
-  (:results (res :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:result-types unsigned-num)
-  (:translate (setf floating-point-modes))
-  (:policy :fast-safe)
-  (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
-  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
-  (:vop-var vop)
-  (:generator 3
-    (let* ((nfp (current-nfp-tn vop))
-	   (stack-tn (sc-case new
-		       (unsigned-stack new)
-		       (unsigned-reg temp)))
-	   (offset (* (tn-offset stack-tn) word-bytes)))
-      (unless (eq new stack-tn)
-	(inst stw new offset nfp))
-      (cond ((< offset (ash 1 4))
-	     (inst flds offset nfp fp-single-zero-tn))
-	    (t
-	     (inst ldo offset zero-tn index)
-	     (inst fldx index nfp fp-single-zero-tn)))
-      (inst ldw offset nfp res))))
diff --git a/compiler/hppa/insts.lisp b/compiler/hppa/insts.lisp
deleted file mode 100644
index e27ec83097123dda14876a6313d6a11e0a7e4851..0000000000000000000000000000000000000000
--- a/compiler/hppa/insts.lisp
+++ /dev/null
@@ -1,1544 +0,0 @@
-;;; -*- Package: hppa -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/insts.lisp,v 1.4 1992/10/23 19:26:30 hallgren Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the instruction set definition for the HP-PA.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package :hppa)
-
-(use-package :new-assem)
-
-(def-assembler-params
-  :scheduler-p nil)
-
-
-;;;; Utility functions.
-
-(defun reg-tn-encoding (tn)
-  (declare (type tn tn)
-	   (values (unsigned-byte 5)))
-  (sc-case tn
-    (null null-offset)
-    (zero zero-offset)
-    (t
-     (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
-     (tn-offset tn))))
-
-(defun fp-reg-tn-encoding (tn)
-  (declare (type tn tn)
-	   (values (unsigned-byte 5) (member t nil)))
-  (sc-case tn
-    (fp-single-zero (values 0 nil))
-    (single-reg (values (tn-offset tn) nil))
-    (fp-double-zero (values 0 t))
-    (double-reg (values (tn-offset tn) t))))
-
-(defconstant compare-conditions
-  '(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev))
-
-(deftype compare-condition ()
-  `(member nil ,@compare-conditions))
-
-(defun compare-condition (cond)
-  (declare (type compare-condition cond)
-	   (values (unsigned-byte 3) (member t nil)))
-  (if cond
-      (let ((result (or (position cond compare-conditions :test #'eq)
-			(error "Bogus Compare/Subtract condition: ~S" cond))))
-	(values (ldb (byte 3 0) result)
-		(logbitp 3 result)))
-      (values 0 nil)))
-
-(defconstant add-conditions
-  '(:never := :< :<= :nuv :znv :sv :od :tr :<> :>= :> :uv :vnz :nsv :ev))
-
-(deftype add-condition ()
-  `(member nil ,@add-conditions))
-
-(defun add-condition (cond)
-  (declare (type add-condition cond)
-	   (values (unsigned-byte 3) (member t nil)))
-  (if cond
-      (let ((result (or (position cond add-conditions :test #'eq)
-			(error "Bogus Add condition: ~S" cond))))
-	(values (ldb (byte 3 0) result)
-		(logbitp 3 result)))
-      (values 0 nil)))
-
-(defconstant logical-conditions
-  '(:never := :< :<= nil nil nil :od :tr :<> :>= :> nil nil nil :ev))
-
-(deftype logical-condition ()
-  `(member nil ,@(remove nil logical-conditions)))
-
-(defun logical-condition (cond)
-  (declare (type logical-condition cond)
-	   (values (unsigned-byte 3) (member t nil)))
-  (if cond
-      (let ((result (or (position cond logical-conditions :test #'eq)
-			(error "Bogus Logical condition: ~S" cond))))
-	(values (ldb (byte 3 0) result)
-		(logbitp 3 result)))
-      (values 0 nil)))
-
-(defconstant unit-conditions
-  '(:never nil :sbz :shz :sdc :sbc :shc :tr nil :nbz :nhz :ndc :nbc :nhc))
-
-(deftype unit-condition ()
-  `(member nil ,@(remove nil unit-conditions)))
-
-(defun unit-condition (cond)
-  (declare (type unit-condition cond)
-	   (values (unsigned-byte 3) (member t nil)))
-  (if cond
-      (let ((result (or (position cond unit-conditions :test #'eq)
-			(error "Bogus Unit condition: ~S" cond))))
-	(values (ldb (byte 3 0) result)
-		(logbitp 3 result)))
-      (values 0 nil)))
-
-(defconstant extract/deposit-conditions
-  '(:never := :< :od :tr :<> :>= :ev))
-
-(deftype extract/deposit-condition ()
-  `(member nil ,@extract/deposit-conditions))
-
-(defun extract/deposit-condition (cond)
-  (declare (type extract/deposit-condition cond)
-	   (values (unsigned-byte 3) (member t nil)))
-  (if cond
-      (or (position cond extract/deposit-conditions :test #'eq)
-	  (error "Bogus Extract/Deposit condition: ~S" cond))
-      0))
-
-
-(defun space-encoding (space)
-  (declare (type (unsigned-byte 3) space)
-	   (values (unsigned-byte 3)))
-  (dpb (ldb (byte 2 0) space)
-       (byte 2 1)
-       (ldb (byte 1 2) space)))
-
-
-;;;; Initial disassembler setup.
-
-(disassem:set-disassem-params :instruction-alignment 32)
-
-(defvar *disassem-use-lisp-reg-names* t)
-
-(defparameter reg-symbols
-  (map 'vector
-       #'(lambda (name)
-	   (cond ((null name) nil)
-		 (t (make-symbol (concatenate 'string "$" name)))))
-       *register-names*))
-
-(disassem:define-argument-type reg
-  :printer #'(lambda (value stream dstate)
-	       (declare (stream stream) (fixnum value))
-	       (let ((regname (aref reg-symbols value)))
-		 (princ regname stream)
-		 (disassem:maybe-note-associated-storage-ref
-		  value
-		  'registers
-		  regname
-		  dstate))))
-
-(defparameter float-reg-symbols
-  (coerce
-   (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
-   'vector))
-
-(disassem:define-argument-type fp-reg
-  :printer #'(lambda (value stream dstate)
-               (declare (stream stream) (fixnum value))
-               (let ((regname (aref float-reg-symbols value)))
-                 (princ regname stream)
-                 (disassem:maybe-note-associated-storage-ref
-                  value
-                  'float-registers
-                  regname
-                  dstate))))
-
-(disassem:define-argument-type fp-fmt-0c
-  :printer #'(lambda (value stream dstate)
-	       (declare (ignore dstate) (stream stream) (fixnum value))
-	       (ecase value
-		 (0 (format stream "~A" '\,SGL))
-		 (1 (format stream "~A" '\,DBL))
-		 (3 (format stream "~A" '\,QUAD)))))
-
-(defun low-sign-extend (x n)
-  (let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x))))
-    (if (logbitp 0 x)
-	(logior (ash -1 (1- n)) normal)
-	normal)))
-
-(defun sign-extend (x n)
-  (if (logbitp (1- n) x)
-      (logior (ash -1 (1- n)) x)
-      x))
-
-(defun assemble-bits (x list)
-  (let ((result 0)
-	(offset 0))
-    (dolist (e (reverse list))
-      (setf result (logior result (ash (ldb e x) offset)))
-      (incf offset (byte-size e)))
-    result))
-
-(defmacro define-imx-decode (name bits)
-  `(disassem:define-argument-type ,name
-     :printer #'(lambda (value stream dstate)
-		  (declare (ignore dstate) (stream stream) (fixnum value))
-		  (format stream "~S" (low-sign-extend value ,bits)))))
-
-(define-imx-decode im5 5)
-(define-imx-decode im11 11)
-(define-imx-decode im14 14)
-
-(disassem:define-argument-type im3
-  :printer #'(lambda (value stream dstate)
-	       (declare (ignore dstate) (stream stream) (fixnum value))
-	       (format stream "~S" (assemble-bits value `(,(byte 1 0)
-							  ,(byte 2 1))))))
-
-(disassem:define-argument-type im21
-  :printer #'(lambda (value stream dstate)
-	       (declare (ignore dstate) (stream stream) (fixnum value))
-	       (format stream "~S"
-		       (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
-					      ,(byte 2 14) ,(byte 5 16)
-					      ,(byte 2 12))))))
-
-(disassem:define-argument-type cp
-  :printer #'(lambda (value stream dstate)
-	       (declare (ignore dstate) (stream stream) (fixnum value))
-	       (format stream "~S" (- 31 value))))
-
-(disassem:define-argument-type clen
-  :printer #'(lambda (value stream dstate)
-	       (declare (ignore dstate) (stream stream) (fixnum value))
-	       (format stream "~S" (- 32 value))))
-
-(disassem:define-argument-type compare-condition
-  :printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>=
-	     \,> \,>>= \,>> \,NSV \,EV))
-
-(disassem:define-argument-type compare-condition-false
-  :printer #(\,TR \,<> \,>= \,> \,>>= \,>> \,NSV \,EV
-	     "" \,= \,< \,<= \,<< \,<<= \,SV \,OD))
-
-(disassem:define-argument-type add-condition
-  :printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV
-	     \,VNZ \,NSV \,EV))
-
-(disassem:define-argument-type add-condition-false
-  :printer #(\,TR \,<> \,>= \,> \,UV \,VNZ \,NSV \,EV
-	     "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD))
-
-(disassem:define-argument-type logical-condition
-  :printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV))
-
-(disassem:define-argument-type unit-condition
-  :printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC
-	     \,NBC \,NHC))
-
-(disassem:define-argument-type extract/deposit-condition
-  :printer #("" \,= \,< \,OD \,TR \,<> \,>= \,EV))
-
-(disassem:define-argument-type extract/deposit-condition-false
-  :printer #(\,TR \,<> \,>= \,EV "" \,= \,< \,OD))
-
-(disassem:define-argument-type nullify
-  :printer #("" \,N))
-
-(disassem:define-argument-type fcmp-cond
-  :printer #(\FALSE? \FALSE \? \!<=> \= \=T \?= \!<> \!?>= \< \?<
-		     \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>=
-		     \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE))
-
-(disassem:define-argument-type integer
-  :printer #'(lambda (value stream dstate)
-	       (declare (ignore dstate) (stream stream) (fixnum value))
-	       (format stream "~S" value)))
-
-(disassem:define-argument-type space
-  :printer #("" |1,| |2,| |3,|))
-
-
-;;;; Define-instruction-formats for disassembler.
-
-(disassem:define-instruction-format
-    (load/store 32)
-  (op   :field (byte 6 26))
-  (b    :field (byte 5 21) :type 'reg)
-  (t/r  :field (byte 5 16) :type 'reg)
-  (s    :field (byte 2 14) :type 'space)
-  (im14 :field (byte 14 0) :type 'im14))
-
-(defconstant cmplt-index-print '((:cond ((u :constant 1) '\,S))
-				 (:cond ((m :constant 1) '\,M))))
-
-(defconstant cmplt-disp-print '((:cond ((m :constant 1)
-				  (:cond ((s :constant 0) '\,MA)
-					 (t '\,MB))))))
-
-(defconstant cmplt-store-print '((:cond ((s :constant 0) '\,B)
-					 (t '\,E))
-				  (:cond ((m :constant 1) '\,M))))
-
-(disassem:define-instruction-format
-    (extended-load/store 32)
-  (op1     :field (byte 6 26) :value 3)
-  (b       :field (byte 5 21) :type 'reg)
-  (x/im5/r :field (byte 5 16) :type 'reg)
-  (s       :field (byte 2 14) :type 'space)
-  (u       :field (byte 1 13))
-  (op2     :field (byte 3 10))
-  (ext4/c  :field (byte 4 6))
-  (m       :field (byte 1 5))
-  (t/im5   :field (byte 5 0) :type 'reg))
-
-(disassem:define-instruction-format
-    (ldil 32 :default-printer '(:name :tab im21 "," t))
-  (op    :field (byte 6 26))
-  (t   :field (byte 5 21) :type 'reg)
-  (im21 :field (byte 21 0) :type 'im21))
-
-(disassem:define-instruction-format
-    (branch17 32)
-  (op1 :field (byte 6 26))
-  (t   :field (byte 5 21) :type 'reg)
-  (w   :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
-       :use-label
-       #'(lambda (value dstate)
-	   (declare (type disassem:disassem-state dstate) (list value))
-	   (let ((x (logior (ash (first value) 12) (ash (second value) 1)
-			    (third value))))
-	     (+ (ash (sign-extend
-		      (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
-					 ,(byte 10 2))) 17) 2)
-		(disassem:dstate-cur-addr dstate) 8))))
-  (op2 :field (byte 3 13))
-  (n   :field (byte 1 1) :type 'nullify))
-
-(disassem:define-instruction-format
-    (branch12 32)
-  (op1 :field (byte 6 26))
-  (r2  :field (byte 5 21) :type 'reg)
-  (r1  :field (byte 5 16) :type 'reg)
-  (w   :fields `(,(byte 11 2) ,(byte 1 0))
-       :use-label
-       #'(lambda (value dstate)
-	   (declare (type disassem:disassem-state dstate) (list value))
-	   (let ((x (logior (ash (first value) 1) (second value))))
-	     (+ (ash (sign-extend
-		      (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
-		      12) 2)
-		(disassem:dstate-cur-addr dstate) 8))))
-  (c   :field (byte 3 13))
-  (n   :field (byte 1 1) :type 'nullify))
-
-(disassem:define-instruction-format
-    (branch 32)
-  (op1 :field (byte 6 26))
-  (t   :field (byte 5 21) :type 'reg)
-  (x   :field (byte 5 16) :type 'reg)
-  (op2 :field (byte 3 13))
-  (x1  :field (byte 11 2))
-  (n   :field (byte 1 1) :type 'nullify)
-  (x2  :field (byte 1 0)))
-
-(disassem:define-instruction-format
-     (r3-inst 32 :default-printer '(:name c :tab r1 "," r2 "," t))
-  (r3 :field (byte 6 26) :value 2)
-  (r2 :field (byte 5 21) :type 'reg)
-  (r1 :field (byte 5 16) :type 'reg)
-  (c  :field (byte 3 13))
-  (f  :field (byte 1 12))
-  (op :field (byte 7 5))
-  (t  :field (byte 5 0) :type 'reg))
-
-(disassem:define-instruction-format
-    (imm-inst 32 :default-printer '(:name c :tab im11 "," r "," t))
-  (op   :field (byte 6 26))
-  (r    :field (byte 5 21) :type 'reg)
-  (t    :field (byte 5 16) :type 'reg)
-  (c    :field (byte 3 13))
-  (f    :field (byte 1 12))
-  (o    :field (byte 1 11))
-  (im11 :field (byte 11 0) :type 'im11))
-
-(disassem:define-instruction-format
-    (extract/deposit-inst 32)
-  (op1    :field (byte 6 26))
-  (r2     :field (byte 5 21) :type 'reg)
-  (r1     :field (byte 5 16) :type 'reg)
-  (c      :field (byte 3 13) :type 'extract/deposit-condition)
-  (op2    :field (byte 3 10))
-  (cp     :field (byte 5 5) :type 'cp)
-  (t/clen :field (byte 5 0) :type 'clen))
-
-(disassem:define-instruction-format
-    (break 32 :default-printer '(:name :tab im13 "," im5))
-  (op1  :field (byte 6 26) :value 0)
-  (im13 :field (byte 13 13))
-  (q2   :field (byte 8 5) :value 0)
-  (im5  :field (byte 5 0)))
-
-(defun snarf-error-junk (sap offset &optional length-only)
-  (let* ((length (system:sap-ref-8 sap offset))
-         (vector (make-array length :element-type '(unsigned-byte 8))))
-    (declare (type system:system-area-pointer sap)
-             (type (unsigned-byte 8) length)
-             (type (simple-array (unsigned-byte 8) (*)) vector))
-    (cond (length-only
-           (values 0 (1+ length) nil nil))
-          (t
-           (kernel:copy-from-system-area sap (* hppa:byte-bits (1+ offset))
-                                         vector (* hppa:word-bits
-                                                   hppa:vector-data-offset)
-                                         (* length hppa:byte-bits))
-           (collect ((sc-offsets)
-                     (lengths))
-             (lengths 1)                ; the length byte
-             (let* ((index 0)
-                    (error-number (c::read-var-integer vector index)))
-               (lengths index)
-               (loop
-                 (when (>= index length)
-                   (return))
-                 (let ((old-index index))
-                   (sc-offsets (c::read-var-integer vector index))
-                   (lengths (- index old-index))))
-               (values error-number
-                       (1+ length)
-                       (sc-offsets)
-                       (lengths))))))))
-
-(defun break-control (chunk inst stream dstate)
-  (declare (ignore inst))
-  (flet ((nt (x) (if stream (disassem:note x dstate))))
-    (case (break-im5 chunk dstate)
-      (#.vm:error-trap
-       (nt "Error trap")
-       (disassem:handle-break-args #'snarf-error-junk stream dstate))
-      (#.vm:cerror-trap
-       (nt "Cerror trap")
-       (disassem:handle-break-args #'snarf-error-junk stream dstate))
-      (#.vm:breakpoint-trap
-       (nt "Breakpoint trap"))
-      (#.vm:pending-interrupt-trap
-       (nt "Pending interrupt trap"))
-      (#.vm:halt-trap
-       (nt "Halt trap"))
-      (#.vm:function-end-breakpoint-trap
-       (nt "Function end breakpoint trap"))
-    )))
-
-(disassem:define-instruction-format
-    (system-inst 32)
-  (op1 :field (byte 6 26) :value 0)
-  (r1  :field (byte 5 21) :type 'reg)
-  (r2  :field (byte 5 16) :type 'reg)
-  (s   :field (byte 3 13))
-  (op2 :field (byte 8 5))
-  (r3  :field (byte 5 0) :type 'reg))
-
-(disassem:define-instruction-format
-    (fp-load/store 32)
-  (op :field (byte 6 26))
-  (b  :field (byte 5 21) :type 'reg)
-  (x  :field (byte 5 16) :type 'reg)
-  (s  :field (byte 2 14) :type 'space)
-  (u  :field (byte 1 13))
-  (x1 :field (byte 1 12))
-  (x2 :field (byte 2 10))
-  (x3 :field (byte 1 9))
-  (x4 :field (byte 3 6))
-  (m  :field (byte 1 5))
-  (t  :field (byte 5 0) :type 'fp-reg))
-
-(disassem:define-instruction-format
-    (fp-class-0-inst 32)
-  (op1 :field (byte 6 26))
-  (r   :field (byte 5 21) :type 'fp-reg)
-  (x1  :field (byte 5 16) :type 'fp-reg)
-  (op2 :field (byte 3 13))
-  (fmt :field (byte 2 11) :type 'fp-fmt-0c)
-  (x2  :field (byte 2 9))
-  (x3  :field (byte 3 6))
-  (x4  :field (byte 1 5))
-  (t   :field (byte 5 0) :type 'fp-reg))
-
-(disassem:define-instruction-format
-    (fp-class-1-inst 32)
-  (op1 :field (byte 6 26))
-  (r   :field (byte 5 21) :type 'fp-reg)
-  (x1  :field (byte 4 17) :value 0)
-  (x2  :field (byte 2 15))
-  (df  :field (byte 2 13) :type 'fp-fmt-0c)
-  (sf  :field (byte 2 11) :type 'fp-fmt-0c)
-  (x3  :field (byte 2 9) :value 1)
-  (x4  :field (byte 3 6) :value 0)
-  (x5  :field (byte 1 5) :value 0)
-  (t   :field (byte 5 0) :type 'fp-reg))
-
-
-
-;;;; Load and Store stuff.
-
-(define-emitter emit-load/store 32
-  (byte 6 26)
-  (byte 5 21)
-  (byte 5 16)
-  (byte 2 14)
-  (byte 14 0))
-
-
-(defun im14-encoding (segment disp)
-  (declare (type (or fixup (signed-byte 14))))
-  (cond ((fixup-p disp)
-	 (note-fixup segment :load disp)
-	 (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
-	 0)
-	(t
-	 (dpb (ldb (byte 13 0) disp)
-	      (byte 13 1)
-	      (ldb (byte 1 13) disp)))))
-
-(eval-when (compile eval)
-  (defmacro define-load-inst (name opcode)
-    `(define-instruction ,name (segment disp base reg)
-       (:declare (type tn reg base)
-		 (type (or fixup (signed-byte 14)) disp))
-       (:printer load/store ((op ,opcode) (s 0))
-		 '(:name :tab im14 "(" s b ")," t/r))
-       (:emitter
-	(emit-load/store segment ,opcode
-			 (reg-tn-encoding base) (reg-tn-encoding reg) 0
-			 (im14-encoding segment disp)))))  
-  (defmacro define-store-inst (name opcode)
-    `(define-instruction ,name (segment reg disp base)
-       (:declare (type tn reg base)
-		 (type (or fixup (signed-byte 14)) disp))
-       (:printer load/store ((op ,opcode) (s 0))
-		 '(:name :tab t/r "," im14 "(" s b ")"))
-       (:emitter
-	(emit-load/store segment ,opcode
-			 (reg-tn-encoding base) (reg-tn-encoding reg) 0
-			 (im14-encoding segment disp))))))
-
-(define-load-inst ldw #x12)
-(define-load-inst ldh #x11)
-(define-load-inst ldb #x10)
-(define-load-inst ldwm #x13)
-
-(define-store-inst stw #x1A)
-(define-store-inst sth #x19)
-(define-store-inst stb #x18)
-(define-store-inst stwm #x1B)
-
-(define-emitter emit-extended-load/store 32
-  (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
-  (byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))
-
-(eval-when (compile eval)
-  (defmacro define-load-indexed-inst (name opcode)
-    `(define-instruction ,name (segment index base reg &key modify scale)
-       (:declare (type tn reg base index)
-		 (type (member t nil) modify scale))
-       (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
-				      (op2 0))
-				      `(:name ,@cmplt-index-print :tab x/im5/r
-					      "(" s b ")" t/im5))
-       (:emitter
-	(emit-extended-load/store
-	 segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
-	 0 (if scale 1 0) 0 ,opcode (if modify 1 0)
-	 (reg-tn-encoding reg))))))
-
-(define-load-indexed-inst ldwx 2)
-(define-load-indexed-inst ldhx 1)
-(define-load-indexed-inst ldbx 0)
-(define-load-indexed-inst ldcwx 7)
-
-(defun short-disp-encoding (segment disp)
-  (declare (type (or fixup (signed-byte 5)) disp)
-	   (values (unsigned-byte 5)))
-  (cond ((fixup-p disp)
-	 (note-fixup segment :load-short disp)
-	 (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
-	 0)
-	(t
-	 (dpb (ldb (byte 4 0) disp)
-	      (byte 4 1)
-	      (ldb (byte 1 4) disp)))))
-
-(eval-when (compile eval)
-  (defmacro define-load-short-inst (name opcode)
-    `(define-instruction ,name (segment base disp reg &key modify)
-       (:declare (type tn base reg)
-		 (type (or fixup (signed-byte 5)) disp)
-		 (type (member :before :after nil) modify))
-       (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
-				      (op2 4))
-				      `(:name ,@cmplt-disp-print :tab x/im5/r
-					      "(" s b ")" t/im5))
-       (:emitter
-	(multiple-value-bind
-	    (m a)
-	    (ecase modify
-	      ((nil) (values 0 0))
-	      (:after (values 1 0))
-	      (:before (values 1 1)))
-	  (emit-extended-load/store segment #x03 (reg-tn-encoding base)
-				    (short-disp-encoding segment disp)
-				    0 a 4 ,opcode m
-				    (reg-tn-encoding reg))))))
-  (defmacro define-store-short-inst (name opcode)
-    `(define-instruction ,name (segment reg base disp &key modify)
-       (:declare (type tn reg base)
-		 (type (or fixup (signed-byte 5)) disp)
-		 (type (member :before :after nil) modify))
-       (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
-				      (op2 4))
-				      `(:name ,@cmplt-disp-print :tab x/im5/r
-					      "," t/im5 "(" s b ")"))
-       (:emitter
-	(multiple-value-bind
-	    (m a)
-	    (ecase modify
-	      ((nil) (values 0 0))
-	      (:after (values 1 0))
-	      (:before (values 1 1)))
-	  (emit-extended-load/store segment #x03 (reg-tn-encoding base)
-				    (short-disp-encoding segment disp)
-				    0 a 4 ,opcode m
-				    (reg-tn-encoding reg)))))))
-
-(define-load-short-inst ldws 2)
-(define-load-short-inst ldhs 1)
-(define-load-short-inst ldbs 0)
-(define-load-short-inst ldcws 7)
-
-(define-store-short-inst stws 10)
-(define-store-short-inst sths 9)
-(define-store-short-inst stbs 8)
-
-(define-instruction stbys (segment reg base disp where &key modify)
-  (:declare (type tn reg base)
-	    (type (signed-byte 5) disp)
-	    (type (member :begin :end) where)
-	    (type (member t nil) modify))
-  (:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4))
-	    `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")"))
-  (:emitter
-   (emit-extended-load/store segment #x03 (reg-tn-encoding base)
-			     (reg-tn-encoding reg) 0
-			     (ecase where (:begin 0) (:end 1))
-			     4 #xC (if modify 1 0)
-			     (short-disp-encoding segment disp))))
-
-
-;;;; Immediate Instructions.
-
-(define-load-inst ldo #x0D)
-
-(define-emitter emit-ldil 32
-  (byte 6 26)
-  (byte 5 21)
-  (byte 21 0))
-
-(defun immed-21-encoding (segment value)
-  (declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value)
-	   (values (unsigned-byte 21)))
-  (cond ((fixup-p value)
-	 (note-fixup segment :hi value)
-	 (assert (or (null (fixup-offset value)) (zerop (fixup-offset value))))
-	 0)
-	(t
-	 (logior (ash (ldb (byte 5 2) value) 16)
-		 (ash (ldb (byte 2 7) value) 14)
-		 (ash (ldb (byte 2 0) value) 12)
-		 (ash (ldb (byte 11 9) value) 1)
-		 (ldb (byte 1 20) value)))))
-
-(define-instruction ldil (segment value reg)
-  (:declare (type tn reg)
-	    (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
-  (:printer ldil ((op #x08)))
-  (:emitter
-   (emit-ldil segment #x08 (reg-tn-encoding reg)
-	      (immed-21-encoding segment value))))
-
-(define-instruction addil (segment value reg)
-  (:declare (type tn reg)
-	    (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
-  (:printer ldil ((op #x0A)))
-  (:emitter
-   (emit-ldil segment #x0A (reg-tn-encoding reg)
-	      (immed-21-encoding segment value))))
-
-
-;;;; Branch instructions.
-
-(define-emitter emit-branch 32
-  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
-  (byte 11 2) (byte 1 1) (byte 1 0))
-
-(defun label-relative-displacement (label posn &optional delta-if-after)
-  (declare (type label label) (type index posn)
-	   (values integer))
-  (ash (- (if delta-if-after
-	      (label-position label posn delta-if-after)
-	      (label-position label))
-	  (+ posn 8)) -2))
-
-(defun decompose-branch-disp (segment disp)
-  (declare (type (or fixup (signed-byte 17)) disp))
-  (cond ((fixup-p disp)
-	 (note-fixup segment :branch disp)
-	 (assert (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
-	 (values 0 0 0))
-	(t
-	 (values (ldb (byte 5 11) disp)
-		 (dpb (ldb (byte 10 0) disp)
-		      (byte 10 1)
-		      (ldb (byte 1 10) disp))
-		 (ldb (byte 1 16) disp)))))
-
-(defun emit-relative-branch (segment opcode link sub-opcode target nullify)
-  (declare (type (unsigned-byte 6) opcode)
-	   (type (unsigned-byte 5) link)
-	   (type (unsigned-byte 1) sub-opcode)
-	   (type label target)
-	   (type (member t nil) nullify))
-  (emit-back-patch segment 4
-    #'(lambda (segment posn)
-	(let ((disp (label-relative-displacement target posn)))
-	  (assert (<= (- (ash 1 16)) disp (1- (ash 1 16))))
-	  (multiple-value-bind
-	      (w1 w2 w)
-	      (decompose-branch-disp segment disp)
-	    (emit-branch segment opcode link w1 sub-opcode w2
-			 (if nullify 1 0) w))))))
-
-(define-instruction b (segment target &key nullify)
-  (:declare (type label target) (type (member t nil) nullify))
-  (:emitter
-   (emit-relative-branch segment #x3A 0 0 target nullify)))
-
-(define-instruction bl (segment target reg &key nullify)
-  (:declare (type tn reg) (type label target) (type (member t nil) nullify))
-  (:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t))
-  (:emitter
-   (emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify)))
-
-(define-instruction gateway (segment target reg &key nullify)
-  (:declare (type tn reg) (type label target) (type (member t nil) nullify))
-  (:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t))
-  (:emitter
-   (emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))
-
-;;; BLR is useless because we have no way to generate the offset.
-
-(define-instruction bv (segment base &key nullify offset)
-  (:declare (type tn base)
-	    (type (member t nil) nullify)
-	    (type (or tn null) offset))
-  (:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")"))
-  (:emitter
-   (emit-branch segment #x3A (reg-tn-encoding base)
-		(if offset (reg-tn-encoding offset) 0)
-		6 0 (if nullify 1 0) 0)))
-
-(define-instruction be (segment disp space base &key nullify)
-  (:declare (type (or fixup (signed-byte 17)) disp)
-	    (type tn base)
-	    (type (unsigned-byte 3) space)
-	    (type (member t nil) nullify))
-  (:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
-	    '(:name n :tab w "(" op2 "," t ")"))
-  (:emitter
-   (multiple-value-bind
-       (w1 w2 w)
-       (decompose-branch-disp segment disp)
-     (emit-branch segment #x38 (reg-tn-encoding base) w1
-		  (space-encoding space) w2 (if nullify 1 0) w))))
-
-(define-instruction ble (segment disp space base &key nullify)
-  (:declare (type (or fixup (signed-byte 17)) disp)
-	    (type tn base)
-	    (type (unsigned-byte 3) space)
-	    (type (member t nil) nullify))
-  (:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
-	    '(:name n :tab w "(" op2 "," t ")"))
-  (:emitter
-   (multiple-value-bind
-       (w1 w2 w)
-       (decompose-branch-disp segment disp)
-     (emit-branch segment #x39 (reg-tn-encoding base) w1
-		  (space-encoding space) w2 (if nullify 1 0) w))))
-
-(defun emit-conditional-branch (segment opcode r2 r1 cond target nullify)
-  (emit-back-patch segment 4
-    #'(lambda (segment posn)
-	(let ((disp (label-relative-displacement target posn)))
-	  (assert (<= (- (ash 1 11)) disp (1- (ash 1 11))))
-	  (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
-			    (ldb (byte 1 10) disp)))
-		(w (ldb (byte 1 11) disp)))
-	    (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
-
-(defun im5-encoding (value)
-  (declare (type (signed-byte 5) value)
-	   (values (unsigned-byte 5)))
-  (dpb (ldb (byte 4 0) value)
-       (byte 4 1)
-       (ldb (byte 1 4) value)))
-
-(eval-when (compile eval)
-  (defmacro define-branch-inst (r-name r-opcode i-name i-opcode cond-kind)
-    (let* ((conditional (symbolicate cond-kind "-CONDITION"))
-	   (false-conditional (symbolicate conditional "-FALSE")))
-      `(progn
-	 (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
-	   (:declare (type ,conditional cond)
-		     (type tn r1 r2)
-		     (type label target)
-		     (type (member t nil) nullify))
-	   (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
-		     '(:name c n :tab r1 "," r2 "," w))
-	   ,@(unless (= r-opcode #x32)
-	       `((:printer branch12 ((op1 ,(+ 2 r-opcode))
-				     (c nil :type ',false-conditional))
-			 '(:name c n :tab r1 "," r2 "," w))))
-	   (:emitter
-	    (multiple-value-bind
-		(cond-encoding false)
-		(,conditional cond)
-	      (emit-conditional-branch
-	       segment (if false ,(+ r-opcode 2) ,r-opcode)
-	       (reg-tn-encoding r2) (reg-tn-encoding r1)
-	       cond-encoding target nullify))))
-	 (define-instruction ,i-name (segment cond imm reg target &key nullify)
-	   (:declare (type ,conditional cond)
-		     (type (signed-byte 5) imm)
-		     (type tn reg)
-		     (type (member t nil) nullify))
-	   (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
-			       (c nil :type ',conditional))
-		     '(:name c n :tab r1 "," r2 w))
-	   ,@(unless (= r-opcode #x32)
-	       `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
-				     (c nil :type ',false-conditional))
-			 '(:name c n :tab r1 "," r2 "," w))))
-	   (:emitter
-	    (multiple-value-bind
-		(cond-encoding false)
-		(,conditional cond)
-	      (emit-conditional-branch
-	       segment (if false (+ ,i-opcode 2) ,i-opcode)
-	       (reg-tn-encoding reg) (im5-encoding imm)
-	       cond-encoding target nullify))))))))
-
-(define-branch-inst movb #x32 movib #x33 extract/deposit)
-(define-branch-inst comb #x20 comib #x21 compare)
-(define-branch-inst addb #x28 addib #x29 add)
-
-(define-instruction bb (segment cond reg posn target &key nullify)
-  (:declare (type (member t nil) cond nullify)
-	    (type tn reg)
-	    (type (or (member :variable) (unsigned-byte 5)) posn))
-  (:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
-		      '('BVB c n :tab r1 "," w))
-  (:emitter
-   (multiple-value-bind
-       (opcode posn-encoding)
-       (if (eq posn :variable)
-	   (values #x30 0)
-	   (values #x31 posn))
-     (emit-conditional-branch segment opcode posn-encoding
-			      (reg-tn-encoding reg)
-			      (if cond 2 6) target nullify))))
-
-
-;;;; Computation Instructions
-
-(define-emitter emit-r3-inst 32
-  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
-  (byte 1 12) (byte 7 5) (byte 5 0))
-
-(eval-when (compile eval)
-  (defmacro define-r3-inst (name cond-kind opcode)
-    `(define-instruction ,name (segment r1 r2 res &optional cond)
-       (:declare (type tn res r1 r2))
-       (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
-						       cond-kind 
-						       "-CONDITION"))))
-       ,@(when (= opcode #x12)
-	   `((:printer r3-inst ((op ,opcode) (r2 0)
-				(c nil :type ',(symbolicate cond-kind
-							    "-CONDITION")))
-		       `('COPY :tab r1 "," t))))
-       (:emitter
-	(multiple-value-bind
-	    (cond false)
-	    (,(symbolicate cond-kind "-CONDITION") cond)
-	  (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
-			cond (if false 1 0) ,opcode
-			(reg-tn-encoding res)))))))
-  
-(define-r3-inst add add #x30)
-(define-r3-inst addl add #x50)
-(define-r3-inst addo add #x70)
-(define-r3-inst addc add #x38)
-(define-r3-inst addco add #x78)
-(define-r3-inst sh1add add #x32)
-(define-r3-inst sh1addl add #x52)
-(define-r3-inst sh1addo add #x72)
-(define-r3-inst sh2add add #x34)
-(define-r3-inst sh2addl add #x54)
-(define-r3-inst sh2addo add #x74)
-(define-r3-inst sh3add add #x36)
-(define-r3-inst sh3addl add #x56)
-(define-r3-inst sh3addo add #x76)
-(define-r3-inst sub compare #x20)
-(define-r3-inst subo compare #x60)
-(define-r3-inst subb compare #x28)
-(define-r3-inst subbo compare #x68)
-(define-r3-inst subt compare #x26)
-(define-r3-inst subto compare #x66)
-(define-r3-inst ds compare #x22)
-(define-r3-inst comclr compare #x44)
-(define-r3-inst or logical #x12)
-(define-r3-inst xor logical #x14)
-(define-r3-inst and logical #x10)
-(define-r3-inst andcm logical #x00)
-(define-r3-inst uxor unit #x1C)
-(define-r3-inst uaddcm unit #x4C)
-(define-r3-inst uaddcmt unit #x4E)
-(define-r3-inst dcor unit #x5C)
-(define-r3-inst idcor unit #x5E)
-
-(define-emitter emit-imm-inst 32
-  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
-  (byte 1 12) (byte 1 11) (byte 11 0))
-
-(defun im11-encoding (value)
-  (declare (type (signed-byte 11) value)
-	   (values (unsigned-byte 11)))
-  (dpb (ldb (byte 10 0) value)
-       (byte 10 1)
-       (ldb (byte 1 10) value)))
-
-(eval-when (compile eval)
-  (defmacro define-imm-inst (name cond-kind opcode subcode)
-    `(define-instruction ,name (segment imm src dst &optional cond)
-       (:declare (type tn dst src)
-		 (type (signed-byte 11) imm))
-       (:printer imm-inst ((op ,opcode) (o ,subcode)
-			   (c nil :type 
-			      ',(symbolicate cond-kind "-CONDITION"))))
-       (:emitter
-	(multiple-value-bind
-	    (cond false)
-	    (,(symbolicate cond-kind "-CONDITION") cond)
-	  (emit-imm-inst segment ,opcode (reg-tn-encoding src)
-			 (reg-tn-encoding dst) cond
-			 (if false 1 0) ,subcode
-			 (im11-encoding imm)))))))
-
-(define-imm-inst addi add #x2D 0)
-(define-imm-inst addio add #x2D 1)
-(define-imm-inst addit add #x2C 0)
-(define-imm-inst addito add #x2C 1)
-(define-imm-inst subi compare #x25 0)
-(define-imm-inst subio compare #x25 1)
-(define-imm-inst comiclr compare #x24 0)
-
-(define-emitter emit-extract/deposit-inst 32
-  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
-  (byte 3 10) (byte 5 5) (byte 5 0))
-
-(define-instruction shd (segment r1 r2 count res &optional cond)
-  (:declare (type tn res r1 r2)
-	    (type (or (member :variable) (integer 0 31)) count))
-  (:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
-	    '(:name c :tab r1 "," r2 "," cp "," t/clen))
-  (:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
-	    '('VSHD c :tab r1 "," r2 "," t/clen))
-  (:emitter
-   (etypecase count
-     ((member :variable)
-      (emit-extract/deposit-inst segment #x34
-				 (reg-tn-encoding r2) (reg-tn-encoding r1)
-				 (extract/deposit-condition cond)
-				 0 0 (reg-tn-encoding res)))
-     ((integer 0 31)
-      (emit-extract/deposit-inst segment #x34
-				 (reg-tn-encoding r2) (reg-tn-encoding r1)
-				 (extract/deposit-condition cond)
-				 2 (- 31 count)
-				 (reg-tn-encoding res))))))
-
-(eval-when (compile eval)
-  (defmacro define-extract-inst (name opcode)
-    `(define-instruction ,name (segment src posn len res &optional cond)
-       (:declare (type tn res src)
-		 (type (or (member :variable) (integer 0 31)) posn)
-		 (type (integer 1 32) len))
-       (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
-				       (op2 ,opcode))
-		 '(:name c :tab r2 "," cp "," t/clen "," r1))
-       (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
-		 '('V :name c :tab r2 "," t/clen "," r1))
-       (:emitter
-	(etypecase posn
-	  ((member :variable)
-	   (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
-				      (reg-tn-encoding res)
-				      (extract/deposit-condition cond)
-				      ,(- opcode 2) 0 (- 32 len)))
-	  ((integer 0 31)
-	   (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
-				      (reg-tn-encoding res)
-				      (extract/deposit-condition cond)
-				      ,opcode posn (- 32 len))))))))
-
-(define-extract-inst extru 6)
-(define-extract-inst extrs 7)
-
-(eval-when (compile eval)
-  (defmacro define-deposit-inst (name opcode)
-    `(define-instruction ,name (segment src posn len res &optional cond)
-       (:declare (type tn res)
-		 (type (or tn (signed-byte 5)) src)
-		 (type (or (member :variable) (integer 0 31)) posn)
-		 (type (integer 1 32) len))
-       (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
-		 ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
-		     (if (= opcode 0) (cons ''Z base) base)))
-       (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
-		 ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
-		     (if (= opcode 0) (cons ''Z base) base)))
-       (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
-				       (op2 ,(+ 4 opcode)))
-		 ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
-		     (if (= opcode 0) (cons ''Z base) base)))
-       (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
-				       (op2 ,(+ 6 opcode)))
-		 ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
-		     (if (= opcode 0) (cons ''Z base) base)))
-       (:emitter
-	(multiple-value-bind
-	    (opcode src-encoding)
-	    (etypecase src
-	      (tn
-	       (values ,opcode (reg-tn-encoding src)))
-	      ((signed-byte 5)
-	       (values ,(+ opcode 4) (im5-encoding src))))
-	  (multiple-value-bind
-	      (opcode posn-encoding)
-	      (etypecase posn
-		((member :variable)
-		 (values opcode 0))
-		((integer 0 31)
-		 (values (+ opcode 2) (- 31 posn))))
-	    (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
-				       src-encoding
-				       (extract/deposit-condition cond)
-				       opcode posn-encoding (- 32 len))))))))
-
-(define-deposit-inst dep 1)
-(define-deposit-inst zdep 0)
-
-
-
-;;;; System Control Instructions.
-
-(define-emitter emit-break 32
-  (byte 6 26) (byte 13 13) (byte 8 5) (byte 5 0))
-
-(define-instruction break (segment &optional (im5 0) (im13 0))
-  (:declare (type (unsigned-byte 13) im13)
-	    (type (unsigned-byte 5) im5))
-  (:printer break () :default :control #'break-control)
-  (:emitter
-   (emit-break segment 0 im13 0 im5)))
-
-(define-emitter emit-system-inst 32
-  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 8 5) (byte 5 0))
-
-(define-instruction ldsid (segment res base &optional (space 0))
-  (:declare (type tn res base)
-	    (type (integer 0 3) space))
-  (:printer system-inst ((op2 #x85) (c nil :type 'space)
-			 (s nil  :printer #(0 0 1 1 2 2 3 3)))
-	    `(:name :tab "(" s r1 ")," r3))
-  (:emitter
-   (emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
-		     (reg-tn-encoding res))))
-
-(define-instruction mtsp (segment reg space)
-  (:declare (type tn reg) (type (integer 0 7) space))
-  (:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
-  (:emitter
-   (emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
-		     #xC1 0)))
-
-(define-instruction mfsp (segment space reg)
-  (:declare (type tn reg) (type (integer 0 7) space))
-  (:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
-  (:emitter
-   (emit-system-inst segment 0 0 0 (space-encoding space) #x25
-		     (reg-tn-encoding reg))))
-
-(deftype control-reg ()
-  '(or (unsigned-byte 5) (member :sar)))
-
-(defun control-reg (reg)
-  (declare (type control-reg reg)
-	   (values (unsigned-byte 32)))
-  (if (typep reg '(unsigned-byte 5))
-      reg
-      (ecase reg
-	(:sar 11))))
-
-(define-instruction mtctl (segment reg ctrl-reg)
-  (:declare (type tn reg) (type control-reg ctrl-reg))
-  (:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
-  (:emitter
-   (emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
-		     0 #xC2 0)))
-
-(define-instruction mfctl (segment ctrl-reg reg)
-  (:declare (type tn reg) (type control-reg ctrl-reg))
-  (:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
-  (:emitter
-   (emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
-		     (reg-tn-encoding reg))))
-
-
-
-;;;; Floating point instructions.
-
-(define-emitter emit-fp-load/store 32
-  (byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13) (byte 1 12)
-  (byte 2 10) (byte 1 9) (byte 3 6) (byte 1 5) (byte 5 0))
-
-(define-instruction fldx (segment index base result &key modify scale side)
-  (:declare (type tn index base result)
-	    (type (member t nil) modify scale)
-	    (type (member nil 0 1) side))
-  (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
-	    `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t))
-  (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
-	    `('FLDWX ,@cmplt-index-print :tab x "(" s b ")" "," t))
-  (:emitter
-   (multiple-value-bind
-       (result-encoding double-p)
-       (fp-reg-tn-encoding result)
-     (when side
-       (assert double-p)
-       (setf double-p nil))
-     (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
-			 (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
-			 (or side 0) (if modify 1 0) result-encoding))))
-
-(define-instruction fstx (segment value index base &key modify scale side)
-  (:declare (type tn index base value)
-	    (type (member t nil) modify scale)
-	    (type (member nil 0 1) side))
-  (:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
-	    `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")"))
-  (:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
-	    `('FSTWX ,@cmplt-index-print :tab t "," x "(" s b ")"))
-  (:emitter
-   (multiple-value-bind
-       (value-encoding double-p)
-       (fp-reg-tn-encoding value)
-     (when side
-       (assert double-p)
-       (setf double-p nil))
-     (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
-			 (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
-			 (or side 0) (if modify 1 0) value-encoding))))
-  
-(define-instruction flds (segment disp base result &key modify side)
-  (:declare (type tn base result)
-	    (type (signed-byte 5) disp)
-	    (type (member :before :after nil) modify)
-	    (type (member nil 0 1) side))
-  (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
-	    `('FLDDS ,@cmplt-disp-print :tab x "(" s b ")," t))
-  (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
-	    `('FLDWS ,@cmplt-disp-print :tab x "(" s b ")," t))
-  (:emitter
-   (multiple-value-bind
-       (result-encoding double-p)
-       (fp-reg-tn-encoding result)
-     (when side
-       (assert double-p)
-       (setf double-p nil))
-     (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
-			 (short-disp-encoding segment disp) 0
-			 (if (eq modify :before) 1 0) 1 0 0
-			 (or side 0) (if modify 1 0) result-encoding))))
-
-(define-instruction fsts (segment value disp base &key modify side)
-  (:declare (type tn base value)
-	    (type (signed-byte 5) disp)
-	    (type (member :before :after nil) modify)
-	    (type (member nil 0 1) side))
-  (:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
-	    `('FSTDS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
-  (:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
-	    `('FSTWS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
-  (:emitter
-   (multiple-value-bind
-       (value-encoding double-p)
-       (fp-reg-tn-encoding value)
-     (when side
-       (assert double-p)
-       (setf double-p nil))
-     (emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
-			 (short-disp-encoding segment disp) 0
-			 (if (eq modify :before) 1 0) 1 0 1
-			 (or side 0) (if modify 1 0) value-encoding))))
-
-
-(define-emitter emit-fp-class-0-inst 32
-  (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 2 11) (byte 2 9)
-  (byte 3 6) (byte 1 5) (byte 5 0))
-
-(define-emitter emit-fp-class-1-inst 32
-  (byte 6 26) (byte 5 21) (byte 4 17) (byte 2 15) (byte 2 13) (byte 2 11)
-  (byte 2 9) (byte 3 6) (byte 1 5) (byte 5 0))
-
-;;; Note: classes 2 and 3 are similar enough to class 0 that we don't need
-;;; seperate emitters.
-
-(defconstant funops '(:copy :abs :sqrt :rnd))
-
-(deftype funop ()
-  `(member ,@funops))
-
-(define-instruction funop (segment op from to)
-  (:declare (type funop op)
-	    (type tn from to))
-  (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
-	    '('FCPY fmt :tab r "," t))
-  (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
-	    '('FABS fmt  :tab r "," t))
-  (:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
-	    '('FSQRT fmt :tab r "," t))
-  (:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
-	    '('FRND fmt :tab r "," t))
-  (:emitter
-   (multiple-value-bind
-       (from-encoding from-double-p)
-       (fp-reg-tn-encoding from)
-     (multiple-value-bind
-	 (to-encoding to-double-p)
-	 (fp-reg-tn-encoding to)
-       (assert (eq from-double-p to-double-p))
-       (emit-fp-class-0-inst segment #x0C from-encoding 0
-			     (+ 2 (position op funops))
-			     (if to-double-p 1 0) 0 0 0 to-encoding)))))
-
-(eval-when (compile eval)
-  (defmacro define-class-1-fp-inst (name subcode)
-    `(define-instruction ,name (segment from to)
-       (:declare (type tn from to))
-       (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
-		 '(:name sf df :tab r "," t))
-       (:emitter
-	(multiple-value-bind
-	    (from-encoding from-double-p)
-	    (fp-reg-tn-encoding from)
-	  (multiple-value-bind
-	      (to-encoding to-double-p)
-	      (fp-reg-tn-encoding to)
-	    (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
-				  (if to-double-p 1 0) (if from-double-p 1 0)
-				  1 0 0 to-encoding)))))))
-
-(define-class-1-fp-inst fcnvff 0)
-(define-class-1-fp-inst fcnvxf 1)
-(define-class-1-fp-inst fcnvfx 2)
-(define-class-1-fp-inst fcnvfxt 3)
-
-(define-instruction fcmp (segment cond r1 r2)
-  (:declare (type (unsigned-byte 5) cond)
-	    (type tn r1 r2))
-  (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
-	    '(:name fmt t :tab r "," x1))
-  (:emitter
-   (multiple-value-bind
-       (r1-encoding r1-double-p)
-       (fp-reg-tn-encoding r1)
-     (multiple-value-bind
-	 (r2-encoding r2-double-p)
-	 (fp-reg-tn-encoding r2)
-       (assert (eq r1-double-p r2-double-p))
-       (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
-			     (if r1-double-p 1 0) 2 0 0 cond)))))
-
-(define-instruction ftest (segment)
-  (:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
-  (:emitter
-   (emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
-
-(defconstant fbinops '(:add :sub :mpy :div))
-
-(deftype fbinop ()
-  `(member ,@fbinops))
-
-(define-instruction fbinop (segment op r1 r2 result)
-  (:declare (type fbinop op)
-	    (type tn r1 r2 result))
-  (:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
-	    '('FADD fmt :tab r "," x1 "," t))
-  (:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
-	    '('FSUB fmt :tab r "," x1 "," t))
-  (:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
-	    '('FMPY fmt :tab r "," x1 "," t))
-  (:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
-	    '('FDIV fmt :tab r "," x1 "," t))
-  (:emitter
-   (multiple-value-bind
-       (r1-encoding r1-double-p)
-       (fp-reg-tn-encoding r1)
-     (multiple-value-bind
-	 (r2-encoding r2-double-p)
-	 (fp-reg-tn-encoding r2)
-       (assert (eq r1-double-p r2-double-p))
-       (multiple-value-bind
-	   (result-encoding result-double-p)
-	   (fp-reg-tn-encoding result)
-	 (assert (eq r1-double-p result-double-p))
-	 (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
-			       (position op fbinops)
-			       (if r1-double-p 1 0) 3 0 0
-			       result-encoding))))))
-
-
-
-;;;; Instructions built out of other insts.
-
-(define-instruction-macro move (src dst &optional cond)
-  `(inst or ,src zero-tn ,dst ,cond))
-
-(define-instruction-macro nop (&optional cond)
-  `(inst or zero-tn zero-tn zero-tn ,cond))
-
-(define-instruction li (segment value reg)
-  (:declare (type tn reg)
-	    (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
-  (:vop-var vop)
-  (:emitter
-   (assemble (segment vop)
-     (etypecase value
-       (fixup
-	(inst ldil value reg)
-	(inst ldo value reg reg))
-       ((signed-byte 14)
-	(inst ldo value zero-tn reg))
-       ((or (signed-byte 32) (unsigned-byte 32))
-	(let ((hi (ldb (byte 21 11) value))
-	      (lo (ldb (byte 11 0) value)))
-	  (inst ldil hi reg)
-	  (unless (zerop lo)
-	    (inst ldo lo reg reg))))))))
-
-(define-instruction-macro sll (src count result &optional cond)
-  (once-only ((result result) (src src) (count count) (cond cond))
-    `(inst zdep ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
-
-(define-instruction-macro sra (src count result &optional cond)
-  (once-only ((result result) (src src) (count count) (cond cond))
-    `(inst extrs ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
-
-(define-instruction-macro srl (src count result &optional cond)
-  (once-only ((result result) (src src) (count count) (cond cond))
-    `(inst extru ,src (- 31 ,count) (- 32 ,count) ,result ,cond)))
-
-(defun maybe-negate-cond (cond negate)
-  (if negate
-      (multiple-value-bind
-	  (value negate)
-	  (compare-condition cond)
-	(if negate
-	    (nth value compare-conditions)
-	    (nth (+ value 8) compare-conditions)))
-      cond))
-
-(define-instruction bc (segment cond not-p r1 r2 target)
-  (:declare (type compare-condition cond)
-	    (type (member t nil) not-p)
-	    (type tn r1 r2)
-	    (type label target))
-  (:vop-var vop)
-  (:emitter
-   (emit-chooser segment 8 2
-     #'(lambda (segment posn delta)
-	 (let ((disp (label-relative-displacement target posn delta)))
-	   (when (<= 0 disp (1- (ash 1 11)))
-	     (assemble (segment vop)
-	       (inst comb (maybe-negate-cond cond not-p) r1 r2 target
-		     :nullify t))
-	     t)))
-     #'(lambda (segment posn)
-	 (let ((disp (label-relative-displacement target posn)))
-	   (assemble (segment vop)
-	     (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
-		    (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
-		    (inst nop))
-		   (t
-		    (inst comclr r1 r2 zero-tn
-			  (maybe-negate-cond cond (not not-p)))
-		    (inst b target :nullify t)))))))))
-
-(define-instruction bci (segment cond not-p imm reg target)
-  (:declare (type compare-condition cond)
-	    (type (member t nil) not-p)
-	    (type (signed-byte 11) imm)
-	    (type tn reg)
-	    (type label target))
-  (:vop-var vop)
-  (:emitter
-   (emit-chooser segment 8 2
-     #'(lambda (segment posn delta-if-after)
-	 (let ((disp (label-relative-displacement target posn delta-if-after)))
-	   (when (and (<= 0 disp (1- (ash 1 11)))
-		      (<= (- (ash 1 4)) imm (1- (ash 1 4))))
-	     (assemble (segment vop)
-	       (inst comib (maybe-negate-cond cond not-p) imm reg target
-		     :nullify t))
-	     t)))
-     #'(lambda (segment posn)
-	 (let ((disp (label-relative-displacement target posn)))
-	   (assemble (segment vop)
-	     (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
-			 (<= (- (ash 1 4)) imm (1- (ash 1 4))))
-		    (inst comib (maybe-negate-cond cond not-p) imm reg target)
-		    (inst nop))
-		   (t
-		    (inst comiclr imm reg zero-tn
-			  (maybe-negate-cond cond (not not-p)))
-		    (inst b target :nullify t)))))))))
-
-
-;;;; Instructions to convert between code ptrs, functions, and lras.
-
-(defun emit-compute-inst (segment vop src label temp dst calc)
-  (emit-chooser
-      ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
-      segment 12 3
-    #'(lambda (segment posn delta-if-after)
-	(let ((delta (funcall calc label posn delta-if-after)))
-	  (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
-	    (emit-back-patch segment 4
-			     #'(lambda (segment posn)
-				 (assemble (segment vop)
-				   (inst addi (funcall calc label posn 0) src
-					 dst))))
-	    t)))
-    #'(lambda (segment posn)
-	(let ((delta (funcall calc label posn 0)))
-	  ;; Note: if we used addil/ldo to do this in 2 instructions then the
-	  ;; intermediate value would be tagged but pointing into space.
-	  (assemble (segment vop)
-	    (inst ldil (ldb (byte 21 11) delta) temp)
-	    (inst ldo (ldb (byte 11 0) delta) temp temp)
-	    (inst add src temp dst))))))
-
-;; code = fn - header - label-offset + other-pointer-tag
-(define-instruction compute-code-from-fn (segment src label temp dst)
-  (:declare (type tn src dst temp)
-	    (type label label))
-  (:vop-var vop)
-  (:emitter
-   (emit-compute-inst segment vop src label temp dst
-		      #'(lambda (label posn delta-if-after)
-			  (- other-pointer-type
-			     (label-position label posn delta-if-after)
-			     (component-header-length))))))
-
-;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
-(define-instruction compute-code-from-lra (segment src label temp dst)
-  (:declare (type tn src dst temp)
-	    (type label label))
-  (:vop-var vop)
-  (:emitter
-   (emit-compute-inst segment vop src label temp dst
-		      #'(lambda (label posn delta-if-after)
-			  (- (+ (label-position label posn delta-if-after)
-				(component-header-length)))))))
-
-;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
-(define-instruction compute-lra-from-code (segment src label temp dst)
-  (:declare (type tn src dst temp)
-	    (type label label))
-  (:vop-var vop)
-  (:emitter
-   (emit-compute-inst segment vop src label temp dst
-		      #'(lambda (label posn delta-if-after)
-			  (+ (label-position label posn delta-if-after)
-			     (component-header-length))))))
-
-
-;;;; Data instructions.
-
-(define-instruction byte (segment byte)
-  (:emitter
-   (emit-byte segment byte)))
-
-(define-emitter emit-halfword 16
-  (byte 16 0))
-
-(define-instruction halfword (segment halfword)
-  (:emitter
-   (emit-halfword segment halfword)))
-
-(define-emitter emit-word 32
-  (byte 32 0))
-
-(define-instruction word (segment word)
-  (:emitter
-   (emit-word segment word)))
-
-(define-instruction function-header-word (segment)
-  (:emitter
-   (emit-back-patch
-    segment 4
-    #'(lambda (segment posn)
-	(emit-word segment
-		   (logior function-header-type
-			   (ash (+ posn (component-header-length))
-				(- type-bits word-shift))))))))
-
-(define-instruction lra-header-word (segment)
-  (:emitter
-   (emit-back-patch
-    segment 4
-    #'(lambda (segment posn)
-	(emit-word segment
-		   (logior return-pc-header-type
-			   (ash (+ posn (component-header-length))
-				(- type-bits word-shift))))))))
diff --git a/compiler/hppa/macros.lisp b/compiler/hppa/macros.lisp
deleted file mode 100644
index ad0a2dfbb6e05cdcfa6582ac85467b38c0d9bdb7..0000000000000000000000000000000000000000
--- a/compiler/hppa/macros.lisp
+++ /dev/null
@@ -1,401 +0,0 @@
-;;; -*- Package: hppa -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/macros.lisp,v 1.2 1992/10/13 13:18:20 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains various useful macros for generating HP-PA code.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package :hppa)
-
-
-;;; Instruction-like macros.
-
-(defmacro move (src dst)
-  "Move SRC into DST unless they are location=."
-  (once-only ((src src) (dst dst))
-    `(unless (location= ,src ,dst)
-       (inst move ,src ,dst))))
-
-(defmacro loadw (result base &optional (offset 0) (lowtag 0))
-  (once-only ((result result) (base base))
-    `(inst ldw (- (ash ,offset word-shift) ,lowtag) ,base ,result)))
-
-(defmacro storew (value base &optional (offset 0) (lowtag 0))
-  (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
-    `(inst stw ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
-
-(defmacro load-symbol (reg symbol)
-  (once-only ((reg reg) (symbol symbol))
-    `(inst addi (static-symbol-offset ,symbol) null-tn ,reg)))
-
-(defmacro load-symbol-value (reg symbol)
-  `(inst ldw
-	 (+ (static-symbol-offset ',symbol)
-	    (ash symbol-value-slot word-shift)
-	    (- other-pointer-type))
-	 null-tn
-	 ,reg))
-
-(defmacro store-symbol-value (reg symbol)
-  `(inst stw ,reg (+ (static-symbol-offset ',symbol)
-		     (ash symbol-value-slot word-shift)
-		     (- other-pointer-type))
-	 null-tn))
-
-(defmacro load-type (target source &optional (offset 0))
-  "Loads the type bits of a pointer into target independent of
-   byte-ordering issues."
-  (ecase (backend-byte-order *target-backend*)
-    (:little-endian
-     `(inst ldb ,offset ,source ,target))
-    (:big-endian
-     `(inst ldb (+ ,offset 3) ,source ,target))))
-
-;;; Macros to handle the fact that we cannot use the machine native call and
-;;; return instructions. 
-
-(defmacro lisp-jump (function)
-  "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
-  `(progn
-     (inst addi
-	   (- (ash function-header-code-offset word-shift)
-	      function-pointer-type)
-	   ,function
-	   lip-tn)
-     (inst bv lip-tn)
-     (move ,function code-tn)))
-
-(defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
-  "Return to RETURN-PC."
-  `(progn
-     (inst addi (- (* (1+ ,offset) word-bytes) other-pointer-type)
-	   ,return-pc lip-tn)
-     (inst bv lip-tn ,@(unless frob-code '(:nullify t)))
-     ,@(when frob-code
-	 `((move ,return-pc code-tn)))))
-
-(defmacro emit-return-pc (label)
-  "Emit a return-pc header word.  LABEL is the label to use for this
-   return-pc."
-  `(progn
-     (align 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)
-  `(let ((reg ,reg)
-	 (stack ,stack))
-     (let ((offset (tn-offset stack)))
-       (sc-case stack
-	 ((control-stack)
-	  (loadw reg cfp-tn offset))))))
-
-(defmacro store-stack-tn (stack reg)
-  `(let ((stack ,stack)
-	 (reg ,reg))
-     (let ((offset (tn-offset stack)))
-       (sc-case stack
-	 ((control-stack)
-	  (storew reg cfp-tn offset))))))
-
-
-;;; MAYBE-LOAD-STACK-TN  --  Interface
-;;;
-(defmacro maybe-load-stack-tn (reg reg-or-stack)
-  "Move the TN Reg-Or-Stack into Reg if it isn't already there."
-  (once-only ((n-reg reg)
-	      (n-stack reg-or-stack))
-    `(sc-case ,n-reg
-       ((any-reg descriptor-reg)
-	(sc-case ,n-stack
-	  ((any-reg descriptor-reg)
-	   (move ,n-stack ,n-reg))
-	  ((control-stack)
-	   (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
-
-
-;;;; Storage allocation:
-
-(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
-				 &body body)
-  "Do stuff to allocate an other-pointer object of fixed Size with a single
-  word header having the specified Type-Code.  The result is placed in
-  Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
-  by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
-  initializes the object."
-  (once-only ((result-tn result-tn) (temp-tn temp-tn)
-	      (type-code type-code) (size size))
-    `(pseudo-atomic (:extra (pad-data-block ,size))
-       (inst move alloc-tn ,result-tn)
-       (inst dep other-pointer-type 31 3 ,result-tn)
-       (inst li (logior (ash (1- ,size) type-bits) ,type-code) ,temp-tn)
-       (storew ,temp-tn ,result-tn 0 other-pointer-type)
-       ,@body)))
-
-
-;;;; Error Code
-
-(defvar *adjustable-vectors* nil)
-
-(defmacro with-adjustable-vector ((var) &rest body)
-  `(let ((,var (or (pop *adjustable-vectors*)
-		   (make-array 16
-			       :element-type '(unsigned-byte 8)
-			       :fill-pointer 0
-			       :adjustable t))))
-     (setf (fill-pointer ,var) 0)
-     (unwind-protect
-	 (progn
-	   ,@body)
-       (push ,var *adjustable-vectors*))))
-
-(eval-when (compile load eval)
-  (defun emit-error-break (vop kind code values)
-    (let ((vector (gensym)))
-      `((let ((vop ,vop))
-	  (when vop
-	    (note-this-location vop :internal-error)))
-	(inst break ,kind)
-	(with-adjustable-vector (,vector)
-	  (write-var-integer (error-number-or-lose ',code) ,vector)
-	  ,@(mapcar #'(lambda (tn)
-			`(let ((tn ,tn))
-			   (write-var-integer (make-sc-offset (sc-number
-							       (tn-sc tn))
-							      (tn-offset tn))
-					      ,vector)))
-		    values)
-	  (inst byte (length ,vector))
-	  (dotimes (i (length ,vector))
-	    (inst byte (aref ,vector i))))
-	(align word-shift)))))
-
-(defmacro error-call (vop error-code &rest values)
-  "Cause an error.  ERROR-CODE is the error to cause."
-  (cons 'progn
-	(emit-error-break vop error-trap error-code values)))
-
-
-(defmacro cerror-call (vop label error-code &rest values)
-  "Cause a continuable error.  If the error is continued, execution resumes at
-  LABEL."
-  `(progn
-     (inst b ,label)
-     ,@(emit-error-break vop cerror-trap error-code values)))
-
-(defmacro generate-error-code (vop error-code &rest values)
-  "Generate-Error-Code Error-code Value*
-  Emit code for an error with the specified Error-Code and context Values."
-  `(assemble (*elsewhere*)
-     (let ((start-lab (gen-label)))
-       (emit-label start-lab)
-       (error-call ,vop ,error-code ,@values)
-       start-lab)))
-
-(defmacro generate-cerror-code (vop error-code &rest values)
-  "Generate-CError-Code Error-code Value*
-  Emit code for a continuable error with the specified Error-Code and
-  context Values.  If the error is continued, execution resumes after
-  the GENERATE-CERROR-CODE form."
-  (let ((continue (gensym "CONTINUE-LABEL-"))
-	(error (gensym "ERROR-LABEL-")))
-    `(let ((,continue (gen-label)))
-       (emit-label ,continue)
-       (assemble (*elsewhere*)
-	 (let ((,error (gen-label)))
-	   (emit-label ,error)
-	   (cerror-call ,vop ,continue ,error-code ,@values)
-	   ,error)))))
-
-
-
-;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
-;;;
-(defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
-  (let ((n-extra (gensym)))
-    `(let ((,n-extra ,extra))
-       (inst addi 4 alloc-tn alloc-tn)
-       ,@forms
-       (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od))))
-
-
-
-;;;; Indexed references:
-
-(deftype load/store-index (scale lowtag min-offset
-				 &optional (max-offset min-offset))
-  `(integer ,(- (truncate (+ (ash 1 14)
-			     (* min-offset word-bytes)
-			     (- lowtag))
-			  scale))
-	    ,(truncate (- (+ (1- (ash 1 14)) lowtag)
-			  (* max-offset word-bytes))
-		       scale)))
-
-(defmacro define-full-reffer (name type offset lowtag scs el-type
-				   &optional translate)
-  `(progn
-     (define-vop (,name)
-       ,@(when translate
-	   `((:translate ,translate)))
-       (:policy :fast-safe)
-       (:args (object :scs (descriptor-reg) :to (:eval 0))
-	      (index :scs (any-reg) :target temp))
-       (:arg-types ,type tagged-num)
-       (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
-       (:results (value :scs ,scs))
-       (:result-types ,el-type)
-       (:generator 5
-	 (inst addi (- (* ,offset word-bytes) ,lowtag) index temp)
-	 (inst ldwx temp object value)))
-     (define-vop (,(symbolicate name "-C"))
-       ,@(when translate
-	   `((:translate ,translate)))
-       (:policy :fast-safe)
-       (:args (object :scs (descriptor-reg)))
-       (:info index)
-       (:arg-types ,type
-		   (:constant (load/store-index ,word-bytes ,(eval lowtag)
-						,(eval offset))))
-       (:results (value :scs ,scs))
-       (:result-types ,el-type)
-       (:generator 4
-	 (inst ldw (- (* (+ ,offset index) word-bytes) ,lowtag)
-	       object value)))))
-
-(defmacro define-full-setter (name type offset lowtag scs el-type
-				   &optional translate)
-  `(progn
-     (define-vop (,name)
-       ,@(when translate
-	   `((:translate ,translate)))
-       (:policy :fast-safe)
-       (:args (object :scs (descriptor-reg))
-	      (index :scs (any-reg))
-	      (value :scs ,scs :target result))
-       (:arg-types ,type tagged-num ,el-type)
-       (:temporary (:scs (interior-reg)) lip)
-       (:results (result :scs ,scs))
-       (:result-types ,el-type)
-       (:generator 2
-	 (inst add object index lip)
-	 (inst stw value (- (* ,offset word-bytes) ,lowtag) lip)
-	 (move value result)))
-     (define-vop (,(symbolicate name "-C"))
-       ,@(when translate
-	   `((:translate ,translate)))
-       (:policy :fast-safe)
-       (:args (object :scs (descriptor-reg))
-	      (value :scs ,scs))
-       (:info index)
-       (:arg-types ,type
-		   (:constant (load/store-index ,word-bytes ,(eval lowtag)
-						,(eval offset)))
-		   ,el-type)
-       (:results (result :scs ,scs))
-       (:result-types ,el-type)
-       (:generator 1
-	 (inst stw value (- (* (+ ,offset index) word-bytes) ,lowtag) object)
-	 (move value result)))))
-
-
-(defmacro define-partial-reffer (name type size signed offset lowtag scs
-				      el-type &optional translate)
-  (let ((scale (ecase size (:byte 1) (:short 2))))
-    `(progn
-       (define-vop (,name)
-	 ,@(when translate
-	     `((:translate ,translate)))
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg) :to (:eval 0))
-		(index :scs (unsigned-reg)))
-	 (:arg-types ,type positive-fixnum)
-	 (:results (value :scs ,scs))
-	 (:result-types ,el-type)
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:generator 5
-	   (inst ,(ecase size (:byte 'add) (:short 'sh1add))
-		 index object lip)
-	   (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
-		 (- (* ,offset word-bytes) ,lowtag) lip value)
-	   ,@(when signed
-	       `((inst extrs value 31 ,(* scale byte-bits) value)))))
-       (define-vop (,(symbolicate name "-C"))
-	 ,@(when translate
-	     `((:translate ,translate)))
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg)))
-	 (:info index)
-	 (:arg-types ,type
-		     (:constant (load/store-index ,scale
-						  ,(eval lowtag)
-						  ,(eval offset))))
-	 (:results (value :scs ,scs))
-	 (:result-types ,el-type)
-	 (:generator 5
-	   (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
-		 (- (+ (* ,offset word-bytes) (* index ,scale)) ,lowtag)
-		 object value)
-	   ,@(when signed
-	       `((inst extrs value 31 ,(* scale byte-bits) value))))))))
-
-(defmacro define-partial-setter (name type size offset lowtag scs el-type
-				      &optional translate)
-  (let ((scale (ecase size (:byte 1) (:short 2))))
-    `(progn
-       (define-vop (,name)
-	 ,@(when translate
-	     `((:translate ,translate)))
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(index :scs (unsigned-reg))
-		(value :scs ,scs :target result))
-	 (:arg-types ,type positive-fixnum ,el-type)
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:results (result :scs ,scs))
-	 (:result-types ,el-type)
-	 (:generator 5
-	   (inst ,(ecase size (:byte 'add) (:short 'sh1add))
-		 index object lip)
-	   (inst ,(ecase size (:byte 'stb) (:short 'sth))
-		 value (- (* ,offset word-bytes) ,lowtag) lip)
-	   (move value result)))
-       (define-vop (,(symbolicate name "-C"))
-	 ,@(when translate
-	     `((:translate ,translate)))
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(value :scs ,scs :target result))
-	 (:info index)
-	 (:arg-types ,type
-		     (:constant (load/store-index ,scale
-						  ,(eval lowtag)
-						  ,(eval offset)))
-		     ,el-type)
-	 (:results (result :scs ,scs))
-	 (:result-types ,el-type)
-	 (:generator 5
-	   (inst ,(ecase size (:byte 'stb) (:short 'sth))
-		 value
-		 (- (+ (* ,offset word-bytes) (* index ,scale)) ,lowtag)
-		 object)
-	   (move value result))))))
-
diff --git a/compiler/hppa/memory.lisp b/compiler/hppa/memory.lisp
deleted file mode 100644
index de1eadf77b36762c2b91d7db60a8ca8c6be3d154..0000000000000000000000000000000000000000
--- a/compiler/hppa/memory.lisp
+++ /dev/null
@@ -1,106 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/memory.lisp,v 1.1 1992/07/13 03:48:26 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the HPPA definitions of some general purpose memory
-;;; reference VOPs inherited by basic memory reference operations.
-;;;
-;;; Written by William Lott.
-;;; 
-
-(in-package "HPPA")
-
-;;; 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.  Cell-Setf-Function
-;;; takes its arguments as if it were a setf function (new value first, as
-;;; apposed to a setf macro, which takes the new value last).
-;;;
-(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 1
-    (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 1
-    (storew value object offset lowtag)
-    (move value result)))
-;;;
-(define-vop (cell-setf-function)
-  (:args (value :scs (descriptor-reg any-reg)
-		:target result)
-	 (object :scs (descriptor-reg)))
-  (:results (result :scs (descriptor-reg any-reg)))
-  (:variant-vars offset lowtag)
-  (:policy :fast-safe)
-  (:generator 1
-    (storew value object offset lowtag)
-    (move value result)))
-
-;;; 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 1
-    (storew value object (+ base offset) lowtag)))
-
diff --git a/compiler/hppa/move.lisp b/compiler/hppa/move.lisp
deleted file mode 100644
index a6cb098f0f209e3dcda3ddae32f50c81a2372cd9..0000000000000000000000000000000000000000
--- a/compiler/hppa/move.lisp
+++ /dev/null
@@ -1,309 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/move.lisp,v 1.1 1992/07/13 03:48:27 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the HPPA VM definition of operand loading/saving and
-;;; the Move VOP.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "HPPA")
-
-
-(define-move-function (load-immediate 1) (vop x y)
-  ((null zero immediate)
-   (any-reg descriptor-reg))
-  (let ((val (tn-value x)))
-    (etypecase val
-      (integer
-       (inst li (fixnum val) y))
-      (null
-       (move null-tn y))
-      (symbol
-       (load-symbol y val))
-      (character
-       (inst li (logior (ash (char-code val) type-bits)
-			base-char-type)
-	     y)))))
-
-(define-move-function (load-number 1) (vop x y)
-  ((immediate zero)
-   (signed-reg unsigned-reg))
-  (let ((x (tn-value x)))
-    (inst li (if (>= x (ash 1 31)) (logior (ash -1 32) x) x) y)))
-
-(define-move-function (load-base-char 1) (vop x y)
-  ((immediate) (base-char-reg))
-  (inst li (char-code (tn-value x)) y))
-
-(define-move-function (load-system-area-pointer 1) (vop x y)
-  ((immediate) (sap-reg))
-  (inst li (sap-int (tn-value x)) y))
-
-(define-move-function (load-constant 5) (vop x y)
-  ((constant) (descriptor-reg))
-  (loadw y code-tn (tn-offset x) other-pointer-type))
-
-(define-move-function (load-stack 5) (vop x y)
-  ((control-stack) (any-reg descriptor-reg))
-  (load-stack-tn y x))
-
-(define-move-function (load-number-stack 5) (vop x y)
-  ((base-char-stack) (base-char-reg)
-   (sap-stack) (sap-reg)
-   (signed-stack) (signed-reg)
-   (unsigned-stack) (unsigned-reg))
-  (let ((nfp (current-nfp-tn vop)))
-    (loadw y nfp (tn-offset x))))
-
-(define-move-function (store-stack 5) (vop x y)
-  ((any-reg descriptor-reg) (control-stack))
-  (store-stack-tn y x))
-
-(define-move-function (store-number-stack 5) (vop x y)
-  ((base-char-reg) (base-char-stack)
-   (sap-reg) (sap-stack)
-   (signed-reg) (signed-stack)
-   (unsigned-reg) (unsigned-stack))
-  (let ((nfp (current-nfp-tn vop)))
-    (storew x nfp (tn-offset y))))
-
-
-;;;; The Move VOP:
-;;;
-(define-vop (move)
-  (:args (x :target y
-	    :scs (any-reg descriptor-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (any-reg descriptor-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:generator 0
-    (move x y)))
-
-(define-move-vop move :move
-  (any-reg descriptor-reg)
-  (any-reg descriptor-reg))
-
-;;; 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)
-
-;;;    The Move-Argument VOP is used for moving descriptor values into another
-;;; frame for argument or known value passing.
-;;;
-(define-vop (move-argument)
-  (:args (x :target y
-	    :scs (any-reg descriptor-reg))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y any-reg descriptor-reg))))
-  (:results (y))
-  (:generator 0
-    (sc-case y
-      ((any-reg descriptor-reg)
-       (move x y))
-      (control-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-argument :move-argument
-  (any-reg descriptor-reg)
-  (any-reg descriptor-reg))
-
-
-
-;;;; 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)
-  (:args (x) (type))
-  (:results (y))
-  (:ignore y)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 666
-    (error-call vop object-not-type-error x type)))
-
-
-
-;;;; Moves and coercions:
-
-;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
-;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
-;;; to a tagged bignum or fixnum.
-
-;;; Arg is a fixnum, so just shift it.  We need a type restriction because some
-;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
-;;;
-(define-vop (move-to-word/fixnum)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (y :scs (signed-reg unsigned-reg)))
-  (:arg-types tagged-num)
-  (:note "fixnum untagging")
-  (:generator 1
-    (inst sra x 2 y)))
-;;;
-(define-move-vop move-to-word/fixnum :move
-  (any-reg descriptor-reg) (signed-reg unsigned-reg))
-
-;;; Arg is a non-immediate constant, load it.
-(define-vop (move-to-word-c)
-  (:args (x :scs (constant)))
-  (:results (y :scs (signed-reg unsigned-reg)))
-  (:note "constant load")
-  (:generator 1
-    (inst li (tn-value x) y)))
-;;;
-(define-move-vop move-to-word-c :move
-  (constant) (signed-reg unsigned-reg))
-
-;;; Arg is a fixnum or bignum, figure out which and load if necessary.
-(define-vop (move-to-word/integer)
-  (:args (x :scs (descriptor-reg)))
-  (:results (y :scs (signed-reg unsigned-reg)))
-  (:note "integer to untagged word coercion")
-  (:generator 3
-    (inst extru x 31 2 zero-tn :<>)
-    (inst sra x 2 y :tr)
-    (loadw y x vm:bignum-digits-offset vm:other-pointer-type)))
-;;;
-(define-move-vop move-to-word/integer :move
-  (descriptor-reg) (signed-reg unsigned-reg))
-
-;;; Result is a fixnum, so we can just shift.  We need the result type
-;;; restriction because of the control-stack ambiguity noted above.
-;;;
-(define-vop (move-from-word/fixnum)
-  (:args (x :scs (signed-reg unsigned-reg)))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:result-types tagged-num)
-  (:note "fixnum tagging")
-  (:generator 1
-    (inst sll x 2 y)))
-;;;
-(define-move-vop move-from-word/fixnum :move
-  (signed-reg unsigned-reg) (any-reg descriptor-reg))
-
-;;; Result may be a bignum, so we have to check.  Use a worst-case cost to make
-;;; sure people know they may be number consing.
-;;;
-(define-vop (move-from-signed)
-  (:args (x :scs (signed-reg unsigned-reg) :to (:eval 1)))
-  (:results (y :scs (any-reg descriptor-reg) :from (:eval 0)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:note "signed word to integer coercion")
-  (:generator 18
-    ;; Extract the top three bits.
-    (inst extrs x 2 3 temp :=)
-    ;; Invert them (unless they are already zero).
-    (inst uaddcm zero-tn temp temp)
-    ;; If we are left with zero, it will fit in a fixnum.  So branch around
-    ;; the bignum-construction, doing the shift in the delay slot.
-    (inst comb := temp zero-tn done)
-    (inst sll x 2 y)
-    ;; Make a single-digit bignum.
-    (with-fixed-allocation (y temp bignum-type (1+ bignum-digits-offset))
-      (storew x y bignum-digits-offset other-pointer-type))
-    DONE))
-;;;
-(define-move-vop move-from-signed :move
-  (signed-reg) (descriptor-reg))
-
-
-;;; Check for fixnum, and possibly allocate one or two word bignum result.  Use
-;;; a worst-case cost to make sure people know they may be number consing.
-;;;
-(define-vop (move-from-unsigned)
-  (:args (x :scs (signed-reg unsigned-reg) :to (:eval 1)))
-  (:results (y :scs (any-reg descriptor-reg) :from (:eval 0)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:note "unsigned word to integer coercion")
-  (:generator 20
-    ;; Grab the top three bits.
-    (inst extrs x 2 3 temp)
-    ;; If zero, it will fit as a fixnum.
-    (inst comib := 0 temp done)
-    (inst sll x 2 y)
-    ;; Make a bignum.
-    (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
-      ;; Create the result pointer.
-      (inst move alloc-tn y)
-      (inst dep other-pointer-type 31 3 y)
-      ;; Check the high bit, and skip the next instruction it it's 0.
-      (inst comclr x zero-tn zero-tn :>=)
-      ;; The high bit is set, so allocate enough space for a two-word bignum.
-      ;; We always skip the following instruction, so it is only executed
-      ;; when we want one word.
-      (inst addi (pad-data-block 1) alloc-tn alloc-tn :tr)
-      ;; Set up the header for one word.  Use addi instead of li so we can
-      ;; skip the next instruction.
-      (inst addi (logior (ash 1 type-bits) bignum-type) zero-tn temp :tr)
-      ;; Set up the header for two words.
-      (inst li (logior (ash 2 type-bits) bignum-type) temp)
-      ;; Store the header and the data.
-      (storew temp y 0 other-pointer-type)
-      (storew x y bignum-digits-offset other-pointer-type))
-    DONE))
-;;;
-(define-move-vop move-from-unsigned :move
-  (unsigned-reg) (descriptor-reg))
-
-
-;;; Move untagged numbers.
-;;;
-(define-vop (word-move)
-  (:args (x :target y
-	    :scs (signed-reg unsigned-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (signed-reg unsigned-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:note "word integer move")
-  (:generator 0
-    (move x y)))
-;;;
-(define-move-vop word-move :move
-  (signed-reg unsigned-reg) (signed-reg unsigned-reg))
-
-
-;;; Move untagged number arguments/return-values.
-;;;
-(define-vop (move-word-argument)
-  (:args (x :target y
-	    :scs (signed-reg unsigned-reg))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y sap-reg))))
-  (:results (y))
-  (:note "word integer argument move")
-  (:generator 0
-    (sc-case y
-      ((signed-reg unsigned-reg)
-       (move x y))
-      ((signed-stack unsigned-stack)
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-word-argument :move-argument
-  (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a
-;;; descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (signed-reg unsigned-reg) (any-reg descriptor-reg))
diff --git a/compiler/hppa/nlx.lisp b/compiler/hppa/nlx.lisp
deleted file mode 100644
index 608c0af637be377b5f68777a516a44182f539a71..0000000000000000000000000000000000000000
--- a/compiler/hppa/nlx.lisp
+++ /dev/null
@@ -1,273 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/nlx.lisp,v 1.2 1992/07/13 16:08:16 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the definitions of VOPs used for non-local exit
-;;; (throw, lexical exit, etc.)
-;;;
-;;; Written by William Lott
-;;;
-(in-package "HPPA")
-
-;;; MAKE-NLX-SP-TN  --  Interface
-;;;
-;;;    Make an environment-live stack TN for saving the SP for NLX entry.
-;;;
-(def-vm-support-routine make-nlx-sp-tn (env)
-  (environment-live-tn
-   (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
-   env))
-
-
-
-;;; 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.
-;;;
-(def-vm-support-routine make-dynamic-state-tns ()
-  (make-n-tns 4 *any-primitive-type*))
-
-(define-vop (save-dynamic-state)
-  (:results (catch :scs (descriptor-reg))
-	    (nfp :scs (descriptor-reg))
-	    (nsp :scs (descriptor-reg))
-	    (eval :scs (descriptor-reg)))
-  (:vop-var vop)
-  (:generator 13
-    (load-symbol-value catch lisp::*current-catch-block*)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(move cur-nfp nfp)))
-    (move nsp-tn nsp)
-    (load-symbol-value eval lisp::*eval-stack-top*)))
-
-(define-vop (restore-dynamic-state)
-  (:args (catch :scs (descriptor-reg))
-	 (nfp :scs (descriptor-reg))
-	 (nsp :scs (descriptor-reg))
-	 (eval :scs (descriptor-reg)))
-  (:vop-var vop)
-  (:generator 10
-    (store-symbol-value catch lisp::*current-catch-block*)
-    (store-symbol-value eval lisp::*eval-stack-top*)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(move nfp cur-nfp)))
-    (move nsp nsp-tn)))
-
-(define-vop (current-stack-pointer)
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (move csp-tn res)))
-
-(define-vop (current-binding-pointer)
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (move bsp-tn res)))
-
-
-;;;; Unwind block hackery:
-
-;;; Compute the address of the catch block from its TN, then store into the
-;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
-;;;
-(define-vop (make-unwind-block)
-  (:args (tn))
-  (:info entry-label)
-  (:results (block :scs (any-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:generator 22
-    (inst addi (* (tn-offset tn) word-bytes) cfp-tn block)
-    (load-symbol-value temp lisp::*current-unwind-protect-block*)
-    (storew temp block unwind-block-current-uwp-slot)
-    (storew cfp-tn block unwind-block-current-cont-slot)
-    (storew code-tn block unwind-block-current-code-slot)
-    (inst compute-lra-from-code code-tn entry-label ndescr temp)
-    (storew temp block catch-block-entry-pc-slot)))
-
-;;; 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 (descriptor-reg)))
-  (:info entry-label)
-  (:results (block :scs (any-reg) :from (:argument 0)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:generator 44
-    (inst addi (* (tn-offset tn) word-bytes) cfp-tn block)
-    (load-symbol-value temp lisp::*current-unwind-protect-block*)
-    (storew temp block catch-block-current-uwp-slot)
-    (storew cfp-tn block catch-block-current-cont-slot)
-    (storew code-tn block catch-block-current-code-slot)
-    (inst compute-lra-from-code code-tn entry-label ndescr temp)
-    (storew temp block catch-block-entry-pc-slot)
-
-    (storew tag block catch-block-tag-slot)
-    (load-symbol-value temp lisp::*current-catch-block*)
-    (storew temp block catch-block-previous-catch-slot)
-    (store-symbol-value block lisp::*current-catch-block*)))
-
-
-;;; 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 addi (* (tn-offset tn) word-bytes) cfp-tn new-uwp)
-    (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
-
-
-(define-vop (unlink-catch-block)
-  (:temporary (:scs (any-reg)) block)
-  (:policy :fast-safe)
-  (:translate %catch-breakup)
-  (:generator 17
-    (load-symbol-value block lisp::*current-catch-block*)
-    (loadw block block catch-block-previous-catch-slot)
-    (store-symbol-value block lisp::*current-catch-block*)))
-
-(define-vop (unlink-unwind-protect)
-  (:temporary (:scs (any-reg)) block)
-  (:policy :fast-safe)
-  (:translate %unwind-protect-breakup)
-  (:generator 17
-    (load-symbol-value block lisp::*current-unwind-protect-block*)
-    (loadw block block unwind-block-current-uwp-slot)
-    (store-symbol-value block lisp::*current-unwind-protect-block*)))
-
-
-;;;; NLX entry VOPs:
-
-
-(define-vop (nlx-entry)
-  (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
-	      ; would be inserted before the LRA.
-	 (start)
-	 (count))
-  (:results (values :more t))
-  (:temporary (:scs (descriptor-reg)) move-temp)
-  (:info label nvals)
-  (:save-p :force-to-stack)
-  (:vop-var vop)
-  (:generator 30
-    (emit-return-pc label)
-    (note-this-location vop :non-local-entry)
-    (cond ((zerop nvals))
-	  ((= nvals 1)
-	   (inst comclr count zero-tn zero-tn :<>)
-	   (inst move null-tn (tn-ref-tn values) :tr)
-	   (loadw (tn-ref-tn values) start))
-	  (t
-	   (collect ((defaults))
-	     (do ((i 0 (1+ i))
-		  (tn-ref values (tn-ref-across tn-ref)))
-		 ((null tn-ref))
-	       (let ((default-lab (gen-label))
-		     (tn (tn-ref-tn tn-ref)))
-		 (defaults (cons default-lab tn))
-
-		 (inst bci := nil (fixnum i) count default-lab)
-		 (sc-case tn
-		   ((descriptor-reg any-reg)
-		    (loadw tn start i))
-		   (control-stack
-		    (loadw move-temp start i)
-		    (store-stack-tn tn move-temp)))))
-	     
-	     (let ((defaulting-done (gen-label)))
-	       (emit-label defaulting-done)
-	       
-	       (assemble (*elsewhere*)
-		 (do ((defs (defaults) (cdr defs)))
-		     ((null defs))
-		   (let ((def (car defs)))
-		     (emit-label (car def))
-		     (unless (cdr defs)
-		       (inst b defaulting-done))
-		     (let ((tn (cdr def)))
-		       (sc-case tn
-			 ((descriptor-reg any-reg)
-			  (move null-tn tn))
-			 (control-stack
-			  (store-stack-tn tn null-tn)))))))))))
-    (load-stack-tn csp-tn sp)))
-
-
-(define-vop (nlx-entry-multiple)
-  (:args (top :target dst) (start :target src) (count :target num))
-  ;; Again, no SC restrictions for the args, 'cause the loading would
-  ;; happen before the entry label.
-  (:info label)
-  (:temporary (:scs (any-reg) :from (:argument 0)) dst)
-  (:temporary (:scs (any-reg) :from (:argument 1)) src)
-  (:temporary (:scs (any-reg) :from (:argument 2)) num)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:results (new-start) (new-count))
-  (:save-p :force-to-stack)
-  (:vop-var vop)
-  (:generator 30
-    (emit-return-pc label)
-    (note-this-location vop :non-local-entry)
-
-    ;; Copy args.
-    (load-stack-tn dst top)
-    (move start src)
-    (move count num)
-
-    ;; Establish results.
-    (sc-case new-start
-      (any-reg (move dst new-start))
-      (control-stack (store-stack-tn new-start dst)))
-    (inst comb := num zero-tn done)
-    (sc-case new-count
-      (any-reg (inst move num new-count))
-      (control-stack (store-stack-tn new-count num)))
-    ;; Load the first word.
-    (inst ldwm word-bytes src temp)
-
-    ;; Copy stuff on stack.
-    LOOP
-    (inst stwm temp word-bytes dst)
-    (inst addib :<> (fixnum -1) num loop :nullify t)
-    (inst ldwm word-bytes src temp)
-
-    DONE
-    (inst move dst csp-tn)))
-
-
-;;; This VOP is just to force the TNs used in the cleanup onto the stack.
-;;;
-(define-vop (uwp-entry)
-  (:info label)
-  (:save-p :force-to-stack)
-  (:results (block) (start) (count))
-  (:ignore block start count)
-  (:vop-var vop)
-  (:generator 0
-    (emit-return-pc label)
-    (note-this-location vop :non-local-entry)))
diff --git a/compiler/hppa/parms.lisp b/compiler/hppa/parms.lisp
deleted file mode 100644
index 27c95b920c506fd42745c7366580630f60fd64ac..0000000000000000000000000000000000000000
--- a/compiler/hppa/parms.lisp
+++ /dev/null
@@ -1,213 +0,0 @@
-;;; -*- Package: hppa -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/parms.lisp,v 1.2 1992/10/13 13:17:01 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains some parameterizations of various VM
-;;; attributes for the HP-PA.  This file is separate from other stuff so 
-;;; that it can be compiled and loaded earlier. 
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package :hppa)
-(use-package :c)
-
-
-;;;; Compiler constants.
-
-(eval-when (compile eval load)
-
-(setf (backend-name *target-backend*) "HPPA")
-(setf (backend-version *target-backend*) "HP-PA 1.1")
-(setf (backend-fasl-file-type *target-backend*) "hpf")
-(setf (backend-fasl-file-implementation *target-backend*)
-      hppa-fasl-file-implementation)
-(setf (backend-fasl-file-version *target-backend*) 1)
-(setf (backend-register-save-penalty *target-backend*) 3)
-(setf (backend-byte-order *target-backend*) :big-endian)
-(setf (backend-page-size *target-backend*) 4096)
-
-); eval-when
-
-
-;;;; Machine Architecture parameters:
-
-(export '(word-bits byte-bits word-shift word-bytes float-sign-shift
-
-	  single-float-bias single-float-exponent-byte
-	  single-float-significand-byte single-float-normal-exponent-min
-	  single-float-normal-exponent-max single-float-hidden-bit
-	  single-float-trapping-nan-bit single-float-digits
-
-	  double-float-bias double-float-exponent-byte
-	  double-float-significand-byte double-float-normal-exponent-min
-	  double-float-normal-exponent-max double-float-hidden-bit
-	  double-float-trapping-nan-bit double-float-digits
-
-	  float-underflow-trap-bit float-overflow-trap-bit
-	  float-imprecise-trap-bit float-invalid-trap-bit
-	  float-divide-by-zero-trap-bit))
-
-	  
-
-(eval-when (compile load eval)
-
-(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 float-sign-shift 31)
-
-(defconstant single-float-bias 126)
-(defconstant single-float-exponent-byte (byte 8 23))
-(defconstant single-float-significand-byte (byte 23 0))
-(defconstant single-float-normal-exponent-min 1)
-(defconstant single-float-normal-exponent-max 254)
-(defconstant single-float-hidden-bit (ash 1 23))
-(defconstant single-float-trapping-nan-bit (ash 1 22))
-
-(defconstant double-float-bias 1022)
-(defconstant double-float-exponent-byte (byte 11 20))
-(defconstant double-float-significand-byte (byte 20 0))
-(defconstant double-float-normal-exponent-min 1)
-(defconstant double-float-normal-exponent-max #x7FE)
-(defconstant double-float-hidden-bit (ash 1 20))
-(defconstant double-float-trapping-nan-bit (ash 1 19))
-
-(defconstant single-float-digits
-  (+ (byte-size single-float-significand-byte) 1))
-
-(defconstant double-float-digits
-  (+ (byte-size double-float-significand-byte) word-bits 1))
-
-(defconstant float-inexact-trap-bit (ash 1 0))
-(defconstant float-underflow-trap-bit (ash 1 1))
-(defconstant float-overflow-trap-bit (ash 1 2))
-(defconstant float-divide-by-zero-trap-bit (ash 1 3))
-(defconstant float-invalid-trap-bit (ash 1 4))
-
-(defconstant float-round-to-nearest 0)
-(defconstant float-round-to-zero 1)
-(defconstant float-round-to-positive 2)
-(defconstant float-round-to-negative 3)
-
-(defconstant float-rounding-mode (byte 2 7))
-(defconstant float-sticky-bits (byte 5 27))
-(defconstant float-traps-byte (byte 5 0))
-(defconstant float-exceptions-byte (byte 5 27))
-(defconstant float-condition-bit (ash 1 26))
-(defconstant float-fast-bit 0)			  ; No fast mode on HPPA.
-
-); eval-when
-
-
-
-;;;; Description of the target address space.
-
-(export '(target-read-only-space-start
-	  target-static-space-start
-	  target-dynamic-space-start))
-
-;;; Where to put the different spaces.
-;;; 
-(defparameter target-read-only-space-start #x20000000)
-(defparameter target-static-space-start    #x28000000)
-(defparameter target-dynamic-space-start   #x30000000)
-
-;; The space-register holding the lisp heap.
-(defconstant lisp-heap-space 4)
-
-;; The space-register holding the C text segment.
-(defconstant c-text-space 4)
-
-
-;;;; Other random constants.
-
-(export '(halt-trap pending-interrupt-trap error-trap cerror-trap
-	  breakpoint-trap function-end-breakpoint-trap single-step-breakpoint
-	  trace-table-normal trace-table-call-site
-	  trace-table-function-prologue trace-table-function-epilogue))
-
-(defenum (:suffix -trap :start 8)
-  halt
-  pending-interrupt
-  error
-  cerror
-  breakpoint
-  function-end-breakpoint
-  single-step-breakpoint)
-
-(defenum (:prefix trace-table-)
-  normal
-  call-site
-  function-prologue
-  function-epilogue)
-
-
-
-;;;; Static symbols.
-
-(export '(static-symbols static-functions))
-
-;;; 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.
-;;;
-;;; The fdefn objects for the static functions are loaded into static
-;;; space directly after the static symbols.  That way, the raw-addr
-;;; can be loaded directly out of them by indirecting relative to NIL.
-;;;
-(defparameter static-symbols
-  '(t
-
-    ;; The C startup code must fill these in.
-    lisp::lisp-environment-list
-    lisp::lisp-command-line-list
-    lisp::*initial-fdefn-objects*
-
-    ;; Functions that the C code needs to call
-    lisp::%initial-function
-    lisp::maybe-gc
-    kernel::internal-error
-    di::handle-breakpoint
-    di::handle-function-end-breakpoint
-    lisp::fdefinition-object
-
-    ;; Free Pointers.
-    lisp::*read-only-space-free-pointer*
-    lisp::*static-space-free-pointer*
-    lisp::*initial-dynamic-space-free-pointer*
-
-    ;; Things needed for non-local-exit.
-    lisp::*current-catch-block*
-    lisp::*current-unwind-protect-block*
-    *eval-stack-top*
-
-    ;; Interrupt Handling
-    lisp::*free-interrupt-context-index*
-    unix::*interrupts-enabled*
-    unix::*interrupt-pending*
-    ))
-
-(defparameter static-functions
-  '(length
-    two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= eql
-    %negate two-arg-and two-arg-ior two-arg-xor two-arg-gcd two-arg-lcm
-    ))
diff --git a/compiler/hppa/pred.lisp b/compiler/hppa/pred.lisp
deleted file mode 100644
index 8c87d7eebefc178de90ed3b6f1ae7c5125cce9bb..0000000000000000000000000000000000000000
--- a/compiler/hppa/pred.lisp
+++ /dev/null
@@ -1,43 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/pred.lisp,v 1.1 1992/07/13 03:48:30 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the VM definition of predicate VOPs for the HPPA
-;;;
-;;; Written by William Lott.
-;;; 
-
-(in-package "HPPA")
-
-
-;;;; 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 b dest :nullify t)))
-
-
-;;;; Conditional VOPs:
-
-(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
-    (inst bc := not-p x y target)))
diff --git a/compiler/hppa/print.lisp b/compiler/hppa/print.lisp
deleted file mode 100644
index 1701c8c5979eb1ea1f32661e638d98b25e127c96..0000000000000000000000000000000000000000
--- a/compiler/hppa/print.lisp
+++ /dev/null
@@ -1,48 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/print.lisp,v 1.1 1992/07/13 03:48:31 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains temporary printing utilities and similar noise.
-;;;
-;;; Written by William Lott.
-
-(in-package "HPPA")
-
-
-(define-vop (print)
-  (:args (object :scs (descriptor-reg) :target arg))
-  (:results (result :scs (descriptor-reg)))
-  (:save-p t)
-  (:temporary (:sc non-descriptor-reg :offset cfunc-offset) cfunc)
-  (:temporary (:sc non-descriptor-reg :offset nl0-offset :from (:argument 0))
-	      arg)
-  (:temporary (:sc non-descriptor-reg :offset nl4-offset :to (:result 0))
-	      res)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:vop-var vop)
-  (:generator 0
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (move object arg)
-      (when cur-nfp
-	(store-stack-tn nfp-save cur-nfp))
-      ;; Allocate 64 bytes, the minimum stack size.
-      (inst addi 64 nsp-tn nsp-tn)
-      (inst li (make-fixup "debug_print" :foreign) cfunc)
-      (let ((fixup (make-fixup "call_into_c" :foreign)))
-	(inst ldil fixup temp)
-	(inst ble fixup c-text-space temp :nullify t)
-	(inst nop))
-      (inst addi -64 nsp-tn nsp-tn)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save))
-      (move res result))))
diff --git a/compiler/hppa/sap.lisp b/compiler/hppa/sap.lisp
deleted file mode 100644
index 07458041af5a37250c4b82a07591bc319e138aae..0000000000000000000000000000000000000000
--- a/compiler/hppa/sap.lisp
+++ /dev/null
@@ -1,286 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/sap.lisp,v 1.1 1992/07/13 03:48:33 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the HP-PA VM definition of SAP operations.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "HPPA")
-
-
-;;;; Moves and coercions:
-
-;;; Move a tagged SAP to an untagged representation.
-;;;
-(define-vop (move-to-sap)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (y :scs (sap-reg)))
-  (:note "system area pointer indirection")
-  (:generator 1
-    (loadw y x sap-pointer-slot other-pointer-type)))
-
-;;;
-(define-move-vop move-to-sap :move
-  (descriptor-reg) (sap-reg))
-
-
-;;; Move an untagged SAP to a tagged representation.
-;;;
-(define-vop (move-from-sap)
-  (:args (x :scs (sap-reg) :to (:eval 1)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:results (y :scs (descriptor-reg) :from (:eval 0)))
-  (:note "system area pointer allocation")
-  (:generator 20
-    (with-fixed-allocation (y ndescr sap-type sap-size)
-      (storew x y sap-pointer-slot other-pointer-type))))
-;;;
-(define-move-vop move-from-sap :move
-  (sap-reg) (descriptor-reg))
-
-
-;;; Move untagged sap values.
-;;;
-(define-vop (sap-move)
-  (:args (x :target y
-	    :scs (sap-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (sap-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:generator 0
-    (move x y)))
-;;;
-(define-move-vop sap-move :move
-  (sap-reg) (sap-reg))
-
-
-;;; Move untagged sap arguments/return-values.
-;;;
-(define-vop (move-sap-argument)
-  (:args (x :target y
-	    :scs (sap-reg))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y sap-reg))))
-  (:results (y))
-  (:generator 0
-    (sc-case y
-      (sap-reg
-       (move x y))
-      (sap-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-sap-argument :move-argument
-  (descriptor-reg sap-reg) (sap-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
-;;; descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (sap-reg) (descriptor-reg))
-
-
-
-;;;; SAP-INT and INT-SAP
-
-(define-vop (sap-int)
-  (:args (sap :scs (sap-reg) :target int))
-  (:arg-types system-area-pointer)
-  (:results (int :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:translate sap-int)
-  (:policy :fast-safe)
-  (:generator 1
-    (move sap int)))
-
-(define-vop (int-sap)
-  (:args (int :scs (unsigned-reg) :target sap))
-  (:arg-types unsigned-num)
-  (:results (sap :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate int-sap)
-  (:policy :fast-safe)
-  (:generator 1
-    (move int sap)))
-
-
-
-;;;; POINTER+ and POINTER-
-
-(define-vop (pointer+)
-  (:translate sap+)
-  (:args (ptr :scs (sap-reg) :target res)
-	 (offset :scs (signed-reg)))
-  (:arg-types system-area-pointer signed-num)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:policy :fast-safe)
-  (:generator 1
-    (inst add ptr offset res)))
-
-(define-vop (pointer+-c)
-  (:translate sap+)
-  (:args (ptr :scs (sap-reg)))
-  (:info offset)
-  (:arg-types system-area-pointer (:constant (signed-byte 11)))
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:policy :fast-safe)
-  (:generator 1
-    (inst addi offset ptr res)))
-
-(define-vop (pointer-)
-  (:translate sap-)
-  (:args (ptr1 :scs (sap-reg))
-	 (ptr2 :scs (sap-reg)))
-  (:arg-types system-area-pointer system-area-pointer)
-  (:policy :fast-safe)
-  (:results (res :scs (signed-reg)))
-  (:result-types signed-num)
-  (:generator 1
-    (inst sub ptr1 ptr2 res)))
-
-
-
-;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
-
-(eval-when (compile eval)
-
-(defmacro def-system-ref-and-set
-	  (ref-name set-name sc type size &optional signed)
-  (let ((ref-name-c (symbolicate ref-name "-C"))
-	(set-name-c (symbolicate set-name "-C")))
-    `(progn
-       (define-vop (,ref-name)
-	 (:translate ,ref-name)
-	 (:policy :fast-safe)
-	 (:args (object :scs (sap-reg))
-		(offset :scs (unsigned-reg)))
-	 (:arg-types system-area-pointer unsigned-num)
-	 (:results (result :scs (,sc)))
-	 (:result-types ,type)
-	 (:generator 5
-	   (inst ,(ecase size
-		    (:byte 'ldbx)
-		    (:short 'ldhx)
-		    (:long 'ldwx)
-		    (:float 'fldx))
-		 offset object result)
-	   ,@(when (and signed (not (eq size :long)))
-	       `((inst extrs result 31 ,(ecase size
-			  (:byte 8)
-			  (:short 16))
-		       result)))))
-       (define-vop (,ref-name-c)
-	 (:translate ,ref-name)
-	 (:policy :fast-safe)
-	 (:args (object :scs (sap-reg)))
-	 (:arg-types system-area-pointer
-		     (:constant ,(if (eq size :float)
-				     '(signed-byte 5)
-				     '(signed-byte 14))))
-	 (:info offset)
-	 (:results (result :scs (,sc)))
-	 (:result-types ,type)
-	 (:generator 4
-	   (inst ,(ecase size
-		    (:byte 'ldb)
-		    (:short 'ldh)
-		    (:long 'ldw)
-		    (:float 'flds))
-		 offset object result)
-	   ,@(when (and signed (not (eq size :long)))
-	       `((inst extrs result 31 ,(ecase size
-			  (:byte 8)
-			  (:short 16))
-		       result)))))
-       (define-vop (,set-name)
-	 (:translate ,set-name)
-	 (:policy :fast-safe)
-	 (:args (object :scs (sap-reg)
-			,@(unless (eq size :float) '(:target sap)))
-		(offset :scs (unsigned-reg))
-		(value :scs (,sc) :target result))
-	 (:arg-types system-area-pointer unsigned-num ,type)
-	 (:results (result :scs (,sc)))
-	 (:result-types ,type)
-	 ,@(unless (eq size :float)
-	     '((:temporary (:scs (sap-reg) :from (:argument 0)) sap)))
-	 (:generator 5
-	   ,@(if (eq size :float)
-		 `((inst fstx value offset object)
-		   (unless (location= value result)
-		     (inst funop :copy value result)))
-		 `((inst add object offset sap)
-		   (inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw))
-			 value 0 sap)
-		   (move value result)))))
-       (define-vop (,set-name-c)
-	 (:translate ,set-name)
-	 (:policy :fast-safe)
-	 (:args (object :scs (sap-reg))
-		(value :scs (,sc) :target result))
-	 (:arg-types system-area-pointer
-		     (:constant ,(if (eq size :float)
-				     '(signed-byte 5)
-				     '(signed-byte 14)))
-		     ,type)
-	 (:info offset)
-	 (:results (result :scs (,sc)))
-	 (:result-types ,type)
-	 (:generator 5
-	   ,@(if (eq size :float)
-		 `((inst fsts value offset object)
-		   (unless (location= value result)
-		     (inst funop :copy value result)))
-		 `((inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw))
-			 value offset object)
-		   (move value result))))))))
-
-); eval-when (compile eval)
-
-(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
-  unsigned-reg positive-fixnum :byte nil)
-(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
-  signed-reg tagged-num :byte t)
-(def-system-ref-and-set sap-ref-16 %set-sap-ref-16
-  unsigned-reg positive-fixnum :short nil)
-(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
-  signed-reg tagged-num :short t)
-(def-system-ref-and-set sap-ref-32 %set-sap-ref-32
-  unsigned-reg unsigned-num :long nil)
-(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
-  signed-reg signed-num :long t)
-(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
-  sap-reg system-area-pointer :long)
-(def-system-ref-and-set sap-ref-single %set-sap-ref-single
-  single-reg single-float :float)
-(def-system-ref-and-set sap-ref-double %set-sap-ref-double
-  double-reg double-float :float)
-
-
-;;; Noise to convert normal lisp data objects into SAPs.
-
-(define-vop (vector-sap)
-  (:translate vector-sap)
-  (:policy :fast-safe)
-  (:args (vector :scs (descriptor-reg)))
-  (:results (sap :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 2
-    (inst addi
-	  (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type)
-	  vector
-	  sap)))
diff --git a/compiler/hppa/static-fn.lisp b/compiler/hppa/static-fn.lisp
deleted file mode 100644
index 0d2d1cc386c985661b70046f62e0b810af7737dd..0000000000000000000000000000000000000000
--- a/compiler/hppa/static-fn.lisp
+++ /dev/null
@@ -1,144 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/static-fn.lisp,v 1.1 1992/07/13 03:48:35 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the VOPs and macro magic necessary to call static
-;;; functions.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "HPPA")
-
-
-(define-vop (static-function-template)
-  (:save-p t)
-  (:policy :safe)
-  (:variant-vars symbol)
-  (:vop-var vop)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg)) move-temp)
-  (:temporary (:sc descriptor-reg :offset lra-offset) lra)
-  (:temporary (:scs (interior-reg)) lip)
-  (:temporary (:sc any-reg :offset nargs-offset) nargs)
-  (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
-
-
-(eval-when (compile load eval)
-
-(defun static-function-template-name (num-args num-results)
-  (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
-		  num-args num-results)))
-
-
-(defun moves (src dst)
-  (collect ((moves))
-    (do ((src src (cdr src))
-	 (dst dst (cdr dst)))
-	((or (null src) (null dst)))
-      (moves `(move ,(car src) ,(car dst))))
-    (moves)))
-
-(defun static-function-template-vop (num-args num-results)
-  (assert (and (<= num-args register-arg-count)
-	       (<= num-results register-arg-count))
-	  (num-args num-results)
-	  "Either too many args (~D) or too many results (~D).  Max = ~D"
-	  num-args num-results register-arg-count)
-  (let ((num-temps (max num-args num-results)))
-    (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
-      (dotimes (i num-results)
-	(let ((result-name (intern (format nil "RESULT-~D" i))))
-	  (result-names result-name)
-	  (results `(,result-name :scs (any-reg descriptor-reg)))))
-      (dotimes (i num-temps)
-	(let ((temp-name (intern (format nil "TEMP-~D" i))))
-	  (temp-names temp-name)
-	  (temps `(:temporary (:sc descriptor-reg
-			       :offset ,(nth i register-arg-offsets)
-			       ,@(when (< i num-args)
-				   `(:from (:argument ,i)))
-			       ,@(when (< i num-results)
-				   `(:to (:result ,i)
-				     :target ,(nth i (result-names)))))
-			      ,temp-name))))
-      (dotimes (i num-args)
-	(let ((arg-name (intern (format nil "ARG-~D" i))))
-	  (arg-names arg-name)
-	  (args `(,arg-name
-		  :scs (any-reg descriptor-reg)
-		  :target ,(nth i (temp-names))))))
-      `(define-vop (,(static-function-template-name num-args num-results)
-		    static-function-template)
-	 (:args ,@(args))
-	 ,@(temps)
-	 (:results ,@(results))
-	 (:generator ,(+ 50 num-args num-results)
-	   (let ((lra-label (gen-label))
-		 (cur-nfp (current-nfp-tn vop)))
-	     ,@(moves (arg-names) (temp-names))
-	     (inst li (fixnum ,num-args) nargs)
-	     (inst ldw (static-function-offset symbol) null-tn lip)
-	     (when cur-nfp
-	       (store-stack-tn nfp-save cur-nfp))
-	     (inst move cfp-tn old-fp)
-	     (inst compute-lra-from-code code-tn lra-label temp lra)
-	     (note-this-location vop :call-site)
-	     (inst bv lip)
-	     (inst move csp-tn cfp-tn)
-	     (emit-return-pc lra-label)
-	     ,(collect ((bindings) (links))
-		(do ((temp (temp-names) (cdr temp))
-		     (name 'values (gensym))
-		     (prev nil name)
-		     (i 0 (1+ i)))
-		    ((= i num-results))
-		  (bindings `(,name
-			      (make-tn-ref ,(car temp) nil)))
-		  (when prev
-		    (links `(setf (tn-ref-across ,prev) ,name))))
-		`(let ,(bindings)
-		   ,@(links)
-		   (default-unknown-values vop
-		       ,(if (zerop num-results) nil 'values)
-		       ,num-results move-temp temp lra-label)))
-	     (when cur-nfp
-	       (load-stack-tn cur-nfp nfp-save))
-	     ,@(moves (temp-names) (result-names))))))))
-
-) ; eval-when (compile load eval)
-
-(macrolet
-    ((foo ()
-       (collect ((templates (list 'progn)))
-	 (dotimes (i register-arg-count)
-	   (templates (static-function-template-vop i 1)))
-	 (templates))))
-  (foo))
-
-(defmacro define-static-function (name args &key (results '(x)) translate
-				       policy cost arg-types result-types)
-  `(define-vop (,name
-		,(static-function-template-name (length args)
-						(length results)))
-     (:variant ',name)
-     (:note ,(format nil "static-function ~@(~S~)" name))
-     ,@(when translate
-	 `((:translate ,translate)))
-     ,@(when policy
-	 `((:policy ,policy)))
-     ,@(when cost
-	 `((:generator-cost ,cost)))
-     ,@(when arg-types
-	 `((:arg-types ,@arg-types)))
-     ,@(when result-types
-	 `((:result-types ,@result-types)))))
diff --git a/compiler/hppa/subprim.lisp b/compiler/hppa/subprim.lisp
deleted file mode 100644
index 09379f233604d8bfcdd11f52755738c813309706..0000000000000000000000000000000000000000
--- a/compiler/hppa/subprim.lisp
+++ /dev/null
@@ -1,58 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/subprim.lisp,v 1.1 1992/07/13 03:48:35 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Linkage information for standard static functions, and random vops.
-;;;
-;;; Written by William Lott.
-;;; 
-(in-package "HPPA")
-
-
-
-;;;; Length
-
-(define-vop (length/list)
-  (:translate length)
-  (:args (object :scs (descriptor-reg) :target ptr))
-  (:arg-types list)
-  (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr)
-  (:temporary (:scs (non-descriptor-reg) :type random) temp)
-  (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result)
-	      count)
-  (:results (result :scs (any-reg descriptor-reg)))
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 50
-    (move object ptr)
-    (inst comb := ptr null-tn done)
-    (inst li 0 count)
-
-    (inst extru ptr 31 3 temp)
-    (inst comib :<> list-pointer-type temp loose :nullify t)
-    (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type)
-
-    LOOP
-    (inst addi (fixnum 1) count count)
-    (inst comb := ptr null-tn done :nullify t)
-    (inst extru ptr 31 3 temp)
-    (inst comib := list-pointer-type temp loop :nullify t)
-    (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type)
-
-    LOOSE
-    (cerror-call vop done object-not-list-error ptr)
-
-    DONE
-    (move count result)))
-
-(define-static-function length (object) :translate length)
diff --git a/compiler/hppa/system.lisp b/compiler/hppa/system.lisp
deleted file mode 100644
index 1f3fb929eaa0e9e36ea774e76c616635a5dcc7b6..0000000000000000000000000000000000000000
--- a/compiler/hppa/system.lisp
+++ /dev/null
@@ -1,230 +0,0 @@
-;;; -*- Package: hppa -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/system.lisp,v 1.1 1992/07/13 03:48:36 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; HPPA VM definitions of various system hacking operations.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "HPPA")
-
-
-;;;; Type frobbing VOPs
-
-(define-vop (get-lowtag)
-  (:translate get-lowtag)
-  (:policy :fast-safe)
-  (:args (object :scs (any-reg descriptor-reg) :target result))
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 1
-    (inst extru object 31 3 result)))
-
-(define-vop (get-type)
-  (:translate get-type)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:eval 1)))
-  (:results (result :scs (unsigned-reg) :from (:eval 0)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (inst extru object 31 3 result)
-    (inst comib := other-pointer-type result other-ptr :nullify t)
-    (inst comib := function-pointer-type result function-ptr :nullify t)
-    (inst bb t object 31 done :nullify t)
-    (inst extru object 31 2 result :<>)
-    (inst extru object 31 8 result)
-    (inst nop :tr)
-
-    FUNCTION-PTR
-    (load-type result object (- function-pointer-type))
-    (inst nop :tr)
-    
-    OTHER-PTR
-    (load-type result object (- other-pointer-type))
-    
-    DONE))
-
-(define-vop (function-subtype)
-  (:translate function-subtype)
-  (:policy :fast-safe)
-  (:args (function :scs (descriptor-reg)))
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (load-type result function (- function-pointer-type))))
-
-(define-vop (set-function-subtype)
-  (:translate (setf function-subtype))
-  (:policy :fast-safe)
-  (:args (type :scs (unsigned-reg) :target result)
-	 (function :scs (descriptor-reg)))
-  (:arg-types positive-fixnum *)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (inst stb type (- 3 function-pointer-type) function)
-    (move type result)))
-
-(define-vop (get-header-data)
-  (:translate get-header-data)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (loadw res x 0 other-pointer-type)
-    (inst srl res 8 res)))
-
-(define-vop (get-closure-length)
-  (:translate get-closure-length)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (loadw res x 0 function-pointer-type)
-    (inst srl res 8 res)))
-
-(define-vop (set-header-data)
-  (:translate set-header-data)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg) :target res)
-	 (data :scs (unsigned-reg)))
-  (:arg-types * positive-fixnum)
-  (:results (res :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 6
-    (loadw temp x 0 vm:other-pointer-type)
-    (inst dep data 23 24 temp)
-    (storew temp x 0 vm:other-pointer-type)
-    (move x res)))
-
-(define-vop (set-header-data-c)
-  (:translate set-header-data)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg) :target res))
-  (:arg-types * (:constant (signed-byte 5)))
-  (:info data)
-  (:results (res :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 5
-    (loadw temp x 0 vm:other-pointer-type)
-    (inst dep data 23 24 temp)
-    (storew temp x 0 vm:other-pointer-type)
-    (move x res)))
-
-(define-vop (c::make-fixnum)
-  (:args (ptr :scs (any-reg descriptor-reg)))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 1
-    ;;
-    ;; Some code (the hash table code) depends on this returning a
-    ;; positive number so make sure it does.
-    (inst zdep ptr 29 29 res)))
-
-(define-vop (c::make-other-immediate-type)
-  (:args (val :scs (any-reg descriptor-reg))
-	 (type :scs (any-reg descriptor-reg) :target temp))
-  (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 2
-    (inst sll val (- type-bits 2) res)
-    (inst sra type 2 temp)
-    (inst or res temp res)))
-
-
-;;;; Allocation
-
-(define-vop (dynamic-space-free-pointer)
-  (:results (int :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate dynamic-space-free-pointer)
-  (:policy :fast-safe)
-  (:generator 1
-    (move alloc-tn int)))
-
-(define-vop (binding-stack-pointer-sap)
-  (:results (int :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate binding-stack-pointer-sap)
-  (:policy :fast-safe)
-  (:generator 1
-    (move bsp-tn int)))
-
-(define-vop (control-stack-pointer-sap)
-  (:results (int :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate control-stack-pointer-sap)
-  (:policy :fast-safe)
-  (:generator 1
-    (move csp-tn int)))
-
-
-;;;; Code object frobbing.
-
-(define-vop (code-instructions)
-  (:translate code-instructions)
-  (:policy :fast-safe)
-  (:args (code :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:results (sap :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 10
-    (loadw ndescr code 0 other-pointer-type)
-    (inst srl ndescr 8 ndescr)
-    (inst sll ndescr 2 ndescr)
-    (inst addi (- other-pointer-type) ndescr ndescr)
-    (inst add code ndescr sap)))
-
-(define-vop (compute-function)
-  (:args (code :scs (descriptor-reg))
-	 (offset :scs (signed-reg unsigned-reg)))
-  (:arg-types * positive-fixnum)
-  (:results (func :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:generator 10
-    (loadw ndescr code 0 vm:other-pointer-type)
-    (inst srl ndescr 8 ndescr)
-    (inst sll ndescr 2 ndescr)
-    (inst add ndescr offset ndescr)
-    (inst addi (- function-pointer-type other-pointer-type) ndescr ndescr)
-    (inst add ndescr code func)))
-
-
-;;;; Other random VOPs.
-
-
-(defknown unix::do-pending-interrupt () (values))
-(define-vop (unix::do-pending-interrupt)
-  (:policy :fast-safe)
-  (:translate unix::do-pending-interrupt)
-  (:generator 1
-    (inst break pending-interrupt-trap)))
-
-
-(define-vop (halt)
-  (:generator 1
-    (inst break halt-trap)))
-
-
-;;;; Dynamic vop count collection support
-
-(define-vop (count-me)
-  (:args (count-vector :scs (descriptor-reg)))
-  (:info index)
-  (:temporary (:scs (non-descriptor-reg)) count)
-  (:generator 1
-    (let ((offset
-	   (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
-      (inst ldw offset count-vector count)
-      (inst addi 1 count count)
-      (inst stw count offset count-vector))))
diff --git a/compiler/hppa/type-vops.lisp b/compiler/hppa/type-vops.lisp
deleted file mode 100644
index 2cd18272a2ee6fe1534275887a6129f7b874e854..0000000000000000000000000000000000000000
--- a/compiler/hppa/type-vops.lisp
+++ /dev/null
@@ -1,492 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/type-vops.lisp,v 1.2 1992/10/28 16:13:11 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;; 
-;;; This file contains the VM definition of type testing and checking VOPs
-;;; for the HPPA
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "HPPA")
-
-
-
-;;;; Test generation utilities.
-
-(eval-when (compile eval)
-
-(defparameter immediate-types
-  (list unbound-marker-type base-char-type))
-
-(defparameter function-header-types
-  (list funcallable-instance-header-type closure-header-type
-	byte-code-function-type byte-code-closure-type
-	function-header-type closure-function-header-type))
-
-(defun canonicalize-headers (headers)
-  (collect ((results))
-    (let ((start nil)
-	  (prev nil)
-	  (delta (- other-immediate-1-type other-immediate-0-type)))
-      (flet ((emit-test ()
-	       (results (if (= start prev)
-			    start
-			    (cons start prev)))))
-	(dolist (header (sort headers #'<))
-	  (cond ((null start)
-		 (setf start header)
-		 (setf prev header))
-		((= header (+ prev delta))
-		 (setf prev header))
-		(t
-		 (emit-test)
-		 (setf start header)
-		 (setf prev header))))
-	(emit-test)))
-    (results)))
-
-(defmacro test-type (value temp target not-p &rest type-codes)
-  ;; Determine what interesting combinations we need to test for.
-  (let* ((type-codes (mapcar #'eval type-codes))
-	 (fixnump (and (member even-fixnum-type type-codes)
-		       (member odd-fixnum-type type-codes)
-		       t))
-	 (lowtags (remove lowtag-limit type-codes :test #'<))
-	 (extended (remove lowtag-limit type-codes :test #'>))
-	 (immediates (intersection extended immediate-types :test #'eql))
-	 (headers (set-difference extended immediate-types :test #'eql))
-	 (function-p (if (intersection headers function-header-types)
-			 (if (subsetp headers function-header-types)
-			     t
-			     (error "Can't test for mix of function subtypes ~
-				     and normal header types."))
-			 nil)))
-    (unless type-codes
-      (error "Must supply at least on type for test-type."))
-    (cond
-     (fixnump
-      (when (remove-if #'(lambda (x)
-			   (or (= x even-fixnum-type)
-			       (= x odd-fixnum-type)))
-		       lowtags)
-	(error "Can't mix fixnum testing with other lowtags."))
-      (when function-p
-	(error "Can't mix fixnum testing with function subtype testing."))
-      (when immediates
-	(error "Can't mix fixnum testing with other immediates."))
-      (if headers
-	  `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
-				     ',(canonicalize-headers headers))
-	  `(%test-fixnum ,value ,temp ,target ,not-p)))
-     (immediates
-      (when headers
-	(error "Can't mix testing of immediates with testing of headers."))
-      (when lowtags
-	(error "Can't mix testing of immediates with testing of lowtags."))
-      (when (cdr immediates)
-	(error "Can't test multiple immediates at the same time."))
-      `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))
-     (lowtags
-      (when (cdr lowtags)
-	(error "Can't test multiple lowtags at the same time."))
-      (if headers
-	  `(%test-lowtag-and-headers
-	    ,value ,temp ,target ,not-p ,(car lowtags)
-	    ,function-p ',(canonicalize-headers headers))
-	  `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
-     (headers
-      `(%test-headers ,value ,temp ,target ,not-p ,function-p
-		      ',(canonicalize-headers headers)))
-     (t
-      (error "Nothing to test?")))))
-
-); eval-when (compile eval)
-
-(defun %test-fixnum (value temp target not-p)
-  (declare (ignore temp))
-  (assemble ()
-    (inst extru value 31 2 zero-tn (if not-p := :<>))
-    (inst b target :nullify t)))
-
-(defun %test-fixnum-and-headers (value temp target not-p headers)
-  (let ((drop-through (gen-label)))
-    (assemble ()
-      (inst extru value 31 2 zero-tn :<>)
-      (inst b (if not-p drop-through target) :nullify t))
-    (%test-headers value temp target not-p nil headers drop-through)))
-
-(defun %test-immediate (value temp target not-p immediate)
-  (assemble ()
-    (inst extru value 31 8 temp)
-    (inst bci := not-p immediate temp target)))
-
-(defun %test-lowtag (value temp target not-p lowtag &optional temp-loaded)
-  (assemble ()
-    (unless temp-loaded
-      (inst extru value 31 3 temp))
-    (inst bci := not-p lowtag temp target)))
-
-(defun %test-lowtag-and-headers (value temp target not-p lowtag
-				       function-p headers)
-  (let ((drop-through (gen-label)))
-    (%test-lowtag value temp (if not-p drop-through target) nil lowtag)
-    (%test-headers value temp target not-p function-p headers drop-through t)))
-
-(defun %test-headers (value temp target not-p function-p headers
-			    &optional (drop-through (gen-label)) temp-loaded)
-  (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
-    (multiple-value-bind
-	(equal greater-or-equal when-true when-false)
-	;; EQUAL and GREATER-OR-EQUAL are the conditions for branching to
-	;; TARGET.  WHEN-TRUE and WHEN-FALSE are the labels to branch to when
-	;; we know it's true and when we know it's false respectively.
-	(if not-p
-	    (values :<> :< drop-through target)
-	    (values := :>= target drop-through))
-      (assemble ()
-	(%test-lowtag value temp when-false t lowtag temp-loaded)
-	(inst ldb (- 3 lowtag) value temp)
-	(do ((remaining headers (cdr remaining)))
-	    ((null remaining))
-	  (let ((header (car remaining))
-		(last (null (cdr remaining))))
-	    (cond
-	     ((atom header)
-	      (if last
-		  (inst bci equal nil header temp target)
-		  (inst bci := nil header temp when-true)))
-	     (t
-	      (let ((start (car header))
-		    (end (cdr header)))
-		(unless (= start bignum-type)
-		  (inst bci :> nil start temp when-false))
-		(if last
-		    (inst bci greater-or-equal nil end temp target)
-		    (inst bci :>= nil end temp when-true)))))))
-	(emit-label drop-through)))))
-
-
-;;;; Type checking and testing:
-
-(define-vop (check-type)
-  (:args (value :target result :scs (any-reg descriptor-reg)))
-  (:results (result :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
-  (:vop-var vop)
-  (:save-p :compute-only))
-
-(define-vop (type-predicate)
-  (:args (value :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe))
-
-(eval-when (compile eval)
-
-(defun cost-to-test-types (type-codes)
-  (+ (* 2 (length type-codes))
-     (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
-
-(defmacro def-type-vops (pred-name check-name ptype error-code
-				   &rest type-codes)
-  (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
-    `(progn
-       ,@(when pred-name
-	   `((define-vop (,pred-name type-predicate)
-	       (:translate ,pred-name)
-	       (:generator ,cost
-		 (test-type value temp target not-p ,@type-codes)))))
-       ,@(when check-name
-	   `((define-vop (,check-name check-type)
-	       (:generator ,cost
-		 (let ((err-lab
-			(generate-error-code vop ,error-code value)))
-		   (test-type value temp err-lab t ,@type-codes)
-		   (move value result))))))
-       ,@(when ptype
-	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
-
-); eval-when (compile eval)
-
-(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
-  even-fixnum-type odd-fixnum-type)
-
-(def-type-vops functionp check-function function
-  object-not-function-error function-pointer-type)
-
-(def-type-vops listp check-list list object-not-list-error
-  list-pointer-type)
-
-(def-type-vops structurep check-structure structure object-not-structure-error
-  structure-pointer-type)
-
-(def-type-vops bignump check-bigunm bignum
-  object-not-bignum-error bignum-type)
-
-(def-type-vops ratiop check-ratio ratio
-  object-not-ratio-error ratio-type)
-
-(def-type-vops complexp check-complex complex
-  object-not-complex-error complex-type)
-
-(def-type-vops single-float-p check-single-float single-float
-  object-not-single-float-error single-float-type)
-
-(def-type-vops double-float-p check-double-float double-float
-  object-not-double-float-error double-float-type)
-
-(def-type-vops simple-string-p check-simple-string simple-string
-  object-not-simple-string-error simple-string-type)
-
-(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
-  object-not-simple-bit-vector-error simple-bit-vector-type)
-
-(def-type-vops simple-vector-p check-simple-vector simple-vector
-  object-not-simple-vector-error simple-vector-type)
-
-(def-type-vops simple-array-unsigned-byte-2-p
-  check-simple-array-unsigned-byte-2
-  simple-array-unsigned-byte-2
-  object-not-simple-array-unsigned-byte-2-error
-  simple-array-unsigned-byte-2-type)
-
-(def-type-vops simple-array-unsigned-byte-4-p
-  check-simple-array-unsigned-byte-4
-  simple-array-unsigned-byte-4
-  object-not-simple-array-unsigned-byte-4-error
-  simple-array-unsigned-byte-4-type)
-
-(def-type-vops simple-array-unsigned-byte-8-p
-  check-simple-array-unsigned-byte-8
-  simple-array-unsigned-byte-8
-  object-not-simple-array-unsigned-byte-8-error
-  simple-array-unsigned-byte-8-type)
-
-(def-type-vops simple-array-unsigned-byte-16-p
-  check-simple-array-unsigned-byte-16
-  simple-array-unsigned-byte-16
-  object-not-simple-array-unsigned-byte-16-error
-  simple-array-unsigned-byte-16-type)
-
-(def-type-vops simple-array-unsigned-byte-32-p
-  check-simple-array-unsigned-byte-32
-  simple-array-unsigned-byte-32
-  object-not-simple-array-unsigned-byte-32-error
-  simple-array-unsigned-byte-32-type)
-
-(def-type-vops simple-array-single-float-p check-simple-array-single-float
-  simple-array-single-float object-not-simple-array-single-float-error
-  simple-array-single-float-type)
-
-(def-type-vops simple-array-double-float-p check-simple-array-double-float
-  simple-array-double-float object-not-simple-array-double-float-error
-  simple-array-double-float-type)
-
-(def-type-vops base-char-p check-base-char base-char
-  object-not-base-char-error base-char-type)
-
-(def-type-vops system-area-pointer-p check-system-area-pointer
-  system-area-pointer object-not-sap-error sap-type)
-
-(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
-  object-not-weak-pointer-error weak-pointer-type)
-
-(def-type-vops scavenger-hook-p nil nil nil
-  0)
-
-(def-type-vops code-component-p nil nil nil
-  code-header-type)
-
-(def-type-vops lra-p nil nil nil
-  return-pc-header-type)
-
-(def-type-vops fdefn-p nil nil nil
-  fdefn-type)
-
-(def-type-vops funcallable-instance-p nil nil nil
-  funcallable-instance-header-type)
-
-(def-type-vops array-header-p nil nil nil
-  simple-array-type complex-string-type complex-bit-vector-type
-  complex-vector-type complex-array-type)
-
-(def-type-vops nil check-function-or-symbol nil
-  object-not-function-or-symbol-error
-  function-pointer-type symbol-header-type)
-
-(def-type-vops stringp check-string nil object-not-string-error
-  simple-string-type complex-string-type)
-
-(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
-  simple-bit-vector-type complex-bit-vector-type)
-
-(def-type-vops vectorp check-vector nil object-not-vector-error
-  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)
-
-(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
-  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)
-
-(def-type-vops arrayp check-array nil object-not-array-error
-  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)
-
-(def-type-vops numberp check-number nil object-not-number-error
-  even-fixnum-type odd-fixnum-type bignum-type ratio-type
-  single-float-type double-float-type complex-type)
-
-(def-type-vops rationalp check-rational nil object-not-rational-error
-  even-fixnum-type odd-fixnum-type ratio-type bignum-type)
-
-(def-type-vops integerp check-integer nil object-not-integer-error
-  even-fixnum-type odd-fixnum-type bignum-type)
-
-(def-type-vops floatp check-float nil object-not-float-error
-  single-float-type double-float-type)
-
-(def-type-vops realp check-real nil object-not-real-error
-  even-fixnum-type odd-fixnum-type ratio-type bignum-type
-  single-float-type double-float-type)
-
-
-;;;; Other integer ranges.
-
-;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
-;;; exactly one digit.
-
-(defun signed-byte-32-test (value temp not-p target not-target)
-  (multiple-value-bind
-      (yep nope)
-      (if not-p
-	  (values not-target target)
-	  (values target not-target))
-    (assemble ()
-      (inst extru value 31 2 zero-tn :<>)
-      (inst b yep :nullify t)
-      (inst extru value 31 3 temp)
-      (inst bci :<> nil other-pointer-type temp nope)
-      (loadw temp value 0 other-pointer-type)
-      (inst bci := not-p (+ (ash 1 type-bits) bignum-type) temp target)))
-  (undefined-value))
-
-(define-vop (signed-byte-32-p type-predicate)
-  (:translate signed-byte-32-p)
-  (:generator 45
-    (signed-byte-32-test value temp not-p target not-target)
-    NOT-TARGET))
-
-(define-vop (check-signed-byte-32 check-type)
-  (:generator 45
-    (let ((loose (generate-error-code vop object-not-signed-byte-32-error
-				      value)))
-      (signed-byte-32-test value temp t loose okay))
-    OKAY
-    (move value result)))
-
-;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
-;;; bignum with exactly one positive digit, or a bignum with exactly two digits
-;;; and the second digit all zeros.
-
-(defun unsigned-byte-32-test (value temp not-p target not-target)
-  (let ((nope (if not-p target not-target)))
-    (assemble ()
-      ;; Is it a fixnum?
-      (inst extru value 31 2 zero-tn :<>)
-      (inst b fixnum)
-      (inst move value temp)
-
-      ;; If not, is it an other pointer?
-      (inst extru value 31 3 temp)
-      (inst bci :<> nil other-pointer-type temp nope)
-      ;; Get the header.
-      (loadw temp value 0 other-pointer-type)
-      ;; Is it one?
-      (inst bci := nil (+ (ash 1 type-bits) bignum-type) temp single-word)
-      ;; If it's other than two, we can't be an (unsigned-byte 32)
-      (inst bci :<> nil (+ (ash 2 type-bits) bignum-type) temp nope)
-      ;; Get the second digit.
-      (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
-      ;; All zeros, its an (unsigned-byte 32).
-      (inst comb (if not-p := :<>) temp zero-tn not-target :nullify t)
-      (inst b target :nullify t)
-	
-      SINGLE-WORD
-      ;; Get the single digit.
-      (loadw temp value bignum-digits-offset other-pointer-type)
-
-      ;; positive implies (unsigned-byte 32).
-      FIXNUM
-      (inst bc :>= not-p temp zero-tn target)))
-  (undefined-value))
-
-(define-vop (unsigned-byte-32-p type-predicate)
-  (:translate unsigned-byte-32-p)
-  (:generator 45
-    (unsigned-byte-32-test value temp not-p target not-target)
-    NOT-TARGET))
-
-(define-vop (check-unsigned-byte-32 check-type)
-  (:generator 45
-    (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
-				      value)))
-      (unsigned-byte-32-test value temp t loose okay))
-    OKAY
-    (move value result)))
-
-
-;;;; List/symbol types:
-;;; 
-;;; symbolp (or symbol (eq nil))
-;;; consp (and list (not (eq nil)))
-
-(define-vop (symbolp type-predicate)
-  (:translate symbolp)
-  (:generator 12
-    (inst bc := nil value null-tn (if not-p drop-thru target))
-    (test-type value temp target not-p symbol-header-type)
-    DROP-THRU))
-
-(define-vop (check-symbol check-type)
-  (:generator 12
-    (inst comb := value null-tn drop-thru)
-    (let ((error (generate-error-code vop object-not-symbol-error value)))
-      (test-type value temp error t symbol-header-type))
-    DROP-THRU
-    (move value result)))
-  
-(define-vop (consp type-predicate)
-  (:translate consp)
-  (:generator 8
-    (inst bc := nil value null-tn (if not-p target drop-thru))
-    (test-type value temp target not-p list-pointer-type)
-    DROP-THRU))
-
-(define-vop (check-cons check-type)
-  (:generator 8
-    (let ((error (generate-error-code vop object-not-cons-error value)))
-      (inst bc := nil value null-tn error)
-      (test-type value temp error t list-pointer-type))
-    (move value result)))
diff --git a/compiler/hppa/values.lisp b/compiler/hppa/values.lisp
deleted file mode 100644
index 76ff19a0804f1109737a462af46e457f8ee3d6c5..0000000000000000000000000000000000000000
--- a/compiler/hppa/values.lisp
+++ /dev/null
@@ -1,89 +0,0 @@
-;;; -*- Package: HPPA -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/values.lisp,v 1.1 1992/07/13 03:48:39 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the implementation of unknown-values VOPs.
-;;;
-;;; Written by William Lott.
-;;; 
-
-(in-package "HPPA")
-
-(define-vop (reset-stack-pointer)
-  (:args (ptr :scs (any-reg)))
-  (:generator 1
-    (move ptr csp-tn)))
-
-
-;;; 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 (any-reg) :from :load)
-	    (count :scs (any-reg)))
-  (:info nvals)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:generator 20
-    (move csp-tn start)
-    (inst addi (* nvals word-bytes) csp-tn csp-tn)
-    (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 i))
-	  (control-stack
-	   (load-stack-tn temp tn)
-	   (storew temp start i)))))
-    (inst li (fixnum nvals) count)))
-
-
-;;; 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))
-	    (count :scs (any-reg)))
-  (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 0
-    (move arg list)
-    (inst comb := list null-tn done)
-    (move csp-tn start)
-
-    LOOP
-    (loadw temp list cons-car-slot list-pointer-type)
-    (loadw list list cons-cdr-slot list-pointer-type)
-    (inst addi word-bytes csp-tn csp-tn)
-    (storew temp csp-tn -1)
-    (inst extru list 31 lowtag-bits ndescr)
-    (inst comib := list-pointer-type ndescr loop)
-    (inst comb := list null-tn done :nullify t)
-    (error-call vop bogus-argument-to-values-list-error list)
-
-    DONE
-    (inst sub csp-tn start count)))
-
diff --git a/compiler/hppa/vm.lisp b/compiler/hppa/vm.lisp
deleted file mode 100644
index 96ceb958cfbd827f8c39a10d86cd14083ab7e931..0000000000000000000000000000000000000000
--- a/compiler/hppa/vm.lisp
+++ /dev/null
@@ -1,359 +0,0 @@
-;;; -*- Package: hppa -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/vm.lisp,v 1.1 1992/07/13 03:48:39 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the VM definition for the HP-PA.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "HPPA")
-
-
-;;;; Define the registers
-
-(eval-when (compile eval)
-
-(defmacro defreg (name offset)
-  (let ((offset-sym (symbolicate name "-OFFSET")))
-    `(eval-when (compile eval load)
-       (defconstant ,offset-sym ,offset)
-       (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
-
-(defmacro defregset (name &rest regs)
-  `(eval-when (compile eval load)
-     (defconstant ,name
-       (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))
-
-); eval-when (compile eval)
-
-
-(eval-when (compile load eval)
-
-(defvar *register-names* (make-array 32 :initial-element nil))
-
-); eval-when (compile load eval)
-
-
-;; Wired-zero
-(defreg zero 0)
-;; This gets trashed by the C call convention.
-(defreg nfp 1)
-(defreg cfunc 2)
-;; These are the callee saves, so these registers are stay live
-;; over call-out.
-(defreg csp 3)
-(defreg cfp 4)
-(defreg bsp 5)
-(defreg null 6)
-(defreg alloc 7)
-(defreg code 8)
-(defreg fdefn 9)
-(defreg lexenv 10)
-(defreg nargs 11)
-(defreg ocfp 12)
-(defreg lra 13)
-(defreg a0 14)
-(defreg a1 15)
-(defreg a2 16)
-(defreg a3 17)
-(defreg a4 18)
-;; This is where the caller-saves registers start, but we don't really care
-;; because we need to clear the above after call-out to make sure no pointers
-;; into oldspace are kept around.
-(defreg a5 19)
-(defreg l0 20)
-(defreg l1 21)
-(defreg l2 22)
-;; These are the 4 C argument registers.
-(defreg nl3 23)
-(defreg nl2 24)
-(defreg nl1 25)
-(defreg nl0 26)
-;; The global Data Pointer.  We just leave it alone, because we don't need it.
-(defreg dp 27)
-;; These two are use for C return values.
-(defreg nl4 28)
-(defreg nl5 29)
-(defreg nsp 30)
-(defreg lip 31)
-
-(defregset non-descriptor-regs
-  nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc)
-
-(defregset descriptor-regs
-  fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2)
-
-(defregset register-arg-offsets
-  a0 a1 a2 a3 a4 a5)
-
-
-(define-storage-base registers :finite :size 32)
-(define-storage-base float-registers :finite :size 64)
-(define-storage-base control-stack :unbounded :size 8)
-(define-storage-base non-descriptor-stack :unbounded :size 0)
-(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)
-  (do ((forms (list 'progn)
-	      (let* ((class (car classes))
-		     (sc-name (car class))
-		     (constant-name (intern (concatenate 'simple-string
-							 (string sc-name)
-							 "-SC-NUMBER"))))
-		(list* `(define-storage-class ,sc-name ,index
-			  ,@(cdr class))
-		       `(defconstant ,constant-name ,index)
-		       `(export ',constant-name)
-		       forms)))
-       (index 0 (1+ index))
-       (classes classes (cdr classes)))
-      ((null classes)
-       (nreverse forms))))
-
-(define-storage-classes
-
-  ;; Non-immediate contstants in the constant pool
-  (constant constant)
-
-  ;; ZERO and NULL are in registers.
-  (zero immediate-constant)
-  (null immediate-constant)
-  (fp-single-zero immediate-constant)
-  (fp-double-zero immediate-constant)
-
-  ;; Anything else that can be an immediate.
-  (immediate immediate-constant)
-
-
-  ;; **** The stacks.
-
-  ;; The control stack.  (Scanned by GC)
-  (control-stack control-stack)
-
-  ;; The non-descriptor stacks.
-  (signed-stack non-descriptor-stack) ; (signed-byte 32)
-  (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
-  (base-char-stack non-descriptor-stack) ; non-descriptor characters.
-  (sap-stack non-descriptor-stack) ; System area pointers.
-  (single-stack non-descriptor-stack) ; single-floats
-  (double-stack non-descriptor-stack
-		:element-size 2 :alignment 2) ; double floats.
-
-
-  ;; **** Things that can go in the integer registers.
-
-  ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
-  ;; bad will happen if they are.  (fixnums, characters, header values, etc).
-  (any-reg
-   registers
-   :locations #.(append non-descriptor-regs descriptor-regs)
-   :constant-scs (zero immediate)
-   :save-p t
-   :alternate-scs (control-stack))
-
-  ;; Pointer descriptor objects.  Must be seen by GC.
-  (descriptor-reg registers
-   :locations #.descriptor-regs
-   :constant-scs (constant null immediate)
-   :save-p t
-   :alternate-scs (control-stack))
-
-  ;; Non-Descriptor characters
-  (base-char-reg registers
-   :locations #.non-descriptor-regs
-   :constant-scs (immediate)
-   :save-p t
-   :alternate-scs (base-char-stack))
-
-  ;; Non-Descriptor SAP's (arbitrary pointers into address space)
-  (sap-reg registers
-   :locations #.non-descriptor-regs
-   :constant-scs (immediate)
-   :save-p t
-   :alternate-scs (sap-stack))
-
-  ;; Non-Descriptor (signed or unsigned) numbers.
-  (signed-reg registers
-   :locations #.non-descriptor-regs
-   :constant-scs (zero immediate)
-   :save-p t
-   :alternate-scs (signed-stack))
-  (unsigned-reg registers
-   :locations #.non-descriptor-regs
-   :constant-scs (zero immediate)
-   :save-p t
-   :alternate-scs (unsigned-stack))
-
-  ;; Random objects that must not be seen by GC.  Used only as temporaries.
-  (non-descriptor-reg registers
-   :locations #.non-descriptor-regs)
-
-  ;; Pointers to the interior of objects.  Used only as an temporary.
-  (interior-reg registers
-   :locations (#.lip-offset))
-
-
-  ;; **** Things that can go in the floating point registers.
-
-  ;; Non-Descriptor single-floats.
-  (single-reg float-registers
-   :locations #.(loop for i from 4 to 31 collect i)
-   :constant-scs (fp-single-zero)
-   :save-p t
-   :alternate-scs (single-stack))
-
-  ;; Non-Descriptor double-floats.
-  (double-reg float-registers
-   :locations #.(loop for i from 4 to 31 collect i)
-   :constant-scs (fp-double-zero)
-   :save-p t
-   :alternate-scs (double-stack))
-
-  ;; A catch or unwind block.
-  (catch-block control-stack :element-size vm:catch-block-size))
-
-
-;;;; Make some random tns for important registers.
-
-(eval-when (compile eval)
-
-(defmacro defregtn (name sc)
-  (let ((offset-sym (symbolicate name "-OFFSET"))
-	(tn-sym (symbolicate name "-TN")))
-    `(defparameter ,tn-sym
-       (make-random-tn :kind :normal
-		       :sc (sc-or-lose ',sc)
-		       :offset ,offset-sym))))
-
-); eval-when (compile eval)
-
-;; These, we access by foo-TN only
-
-(defregtn zero any-reg)
-(defregtn null descriptor-reg)
-(defregtn code descriptor-reg)
-(defregtn alloc any-reg)
-(defregtn bsp any-reg)
-(defregtn csp any-reg)
-(defregtn cfp any-reg)
-(defregtn nsp any-reg)
-
-;; These alias regular locations, so we have to make sure we don't bypass
-;; the register allocator when using them.
-(defregtn nargs any-reg)
-(defregtn ocfp any-reg)
-(defregtn lip interior-reg)
-
-;; And some floating point values.
-(defparameter fp-single-zero-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'single-reg)
-		  :offset 0))
-(defparameter fp-double-zero-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'double-reg)
-		  :offset 0))
-
-
-;;; Immediate-Constant-SC  --  Interface
-;;;
-;;; If value can be represented as an immediate constant, then return the
-;;; appropriate SC number, otherwise return NIL.
-;;;
-(def-vm-support-routine immediate-constant-sc (value)
-  (typecase value
-    ((integer 0 0)
-     (sc-number-or-lose 'zero *backend*))
-    (null
-     (sc-number-or-lose 'null *backend*))
-    ((or fixnum system-area-pointer character)
-     (sc-number-or-lose 'immediate *backend*))
-    (symbol
-     (if (static-symbol-p value)
-	 (sc-number-or-lose 'immediate *backend*)
-	 nil))
-    (single-float
-     (if (zerop value)
-	 (sc-number-or-lose 'fp-single-zero)
-	 nil))
-    (double-float
-     (if (zerop value)
-	 (sc-number-or-lose 'fp-double-zero)
-	 nil))))
-
-
-;;;; Function Call Parameters
-
-;;; The SC numbers for register and stack arguments/return values.
-;;;
-(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
-(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
-(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
-
-(eval-when (compile load eval)
-
-;;; Offsets of special stack frame locations
-(defconstant ocfp-save-offset 0)
-(defconstant lra-save-offset 1)
-(defconstant nfp-save-offset 2)
-
-;;; The number of arguments/return values passed in registers.
-;;;
-(defconstant register-arg-count 6)
-
-;;; 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))
-
-;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
-;;;
-;;; This is used by the debugger.
-;;;
-(export 'single-value-return-byte-offset)
-(defconstant single-value-return-byte-offset 4)
-
-
-;;; LOCATION-PRINT-NAME  --  Interface
-;;;
-;;;    This function is called by debug output routines that want a pretty name
-;;; for a TN's location.  It returns a thing that can be printed with PRINC.
-;;;
-(def-vm-support-routine location-print-name (tn)
-  (declare (type tn tn))
-  (let ((sb (sb-name (sc-sb (tn-sc tn))))
-	(offset (tn-offset tn)))
-    (ecase sb
-      (registers (or (svref *register-names* offset)
-		     (format nil "R~D" offset)))
-      (float-registers (format nil "F~D" offset))
-      (control-stack (format nil "CS~D" offset))
-      (non-descriptor-stack (format nil "NS~D" offset))
-      (constant (format nil "Const~D" offset))
-      (immediate-constant "Immed"))))
diff --git a/compiler/ir1final.lisp b/compiler/ir1final.lisp
deleted file mode 100644
index 93a5d1d3fe87de5a117b22dfaf889872e88991fc..0000000000000000000000000000000000000000
--- a/compiler/ir1final.lisp
+++ /dev/null
@@ -1,139 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1final.lisp,v 1.17 1992/12/09 00:10:25 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file implements the IR1 finalize phase, which checks for various
-;;; semantic errors.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package "C")
-
-
-;;; 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.
-;;;
-(defun note-failed-optimization (node failures)
-  (declare (type combination node) (list failures))
-  (unless (or (node-deleted node)
-	      (not (function-info-p (combination-kind node))))
-    (let ((*compiler-error-context* node))
-      (dolist (failure failures)
-	(let ((what (cdr failure))
-	      (note (transform-note (car failure))))
-	  (cond
-	   ((consp what)
-	    (compiler-note "Unable to ~A because:~%~6T~?"
-			   note (first what) (rest what)))
-	   ((valid-function-use node what
-				:argument-test #'types-intersect
-				:result-test #'values-types-intersect)
-	    (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 ~A due to type uncertainty:~@
-	                      ~{~6T~?~^~&~}"
-			     note (messages))))))))))
-
-
-;;; FINALIZE-XEP-DEFINITION  --  Internal
-;;;
-;;; For each named function with an XEP, note the definition of that name, and
-;;; add derived type information to the info environment.  We also delete the
-;;; FUNCTIONAL from *FREE-FUNCTIONS* to eliminate the possibility that new
-;;; references might be converted to it.
-;;;
-(defun finalize-xep-definition (fun)
-  (let* ((leaf (functional-entry-function fun))
-	 (name (leaf-name leaf))
-	 (dtype (definition-type leaf)))
-    (setf (leaf-type leaf) dtype)
-    (when (or (and name (symbolp name))
-	      (and (consp name) (eq (car name) 'setf)))
-      (let* ((where (info function where-from name))
-	     (*compiler-error-context* (lambda-bind (main-entry leaf)))
-	     (global-def (gethash name *free-functions*))
-	     (global-p
-	      (and (defined-function-p global-def)
-		   (eq (defined-function-functional global-def) leaf))))
-	(note-name-defined name :function)
-	(when global-p
-	  (remhash name *free-functions*))
-	(ecase where
-	  (:assumed
-	   (let ((approx-type (info function assumed-type name)))
-	     (when (and approx-type (function-type-p dtype))
-	       (valid-approximate-type approx-type dtype))
-	     (setf (info function type name) dtype)
-	     (setf (info function assumed-type name) nil))
-	   (setf (info function where-from name) :defined))
-	  (:declared); Just keep declared type.
-	  (:defined
-	   (when global-p
-	     (setf (info function type name) dtype)))))))
-  (undefined-value))
-
-
-;;; NOTE-ASSUMED-TYPES  --  Internal
-;;;
-;;;    Find all calls in Component to assumed functions and update the assumed
-;;; type information.  This is delayed until now so that we have the best
-;;; possible information about the actual argument types.
-;;;
-(defun note-assumed-types (component name var)
-  (when (eq (leaf-where-from var) :assumed)
-    (assert  (and (eq (info function where-from name) :assumed)
-		  (eq (info function kind name) :function)))
-    (let ((atype (info function assumed-type name)))
-      (dolist (ref (leaf-refs var))
-	(let ((dest (continuation-dest (node-cont ref))))
-	  (when (and (eq (block-component (node-block ref)) component)
-		     (combination-p dest)
-		     (eq (continuation-use (basic-combination-fun dest)) ref))
-	    (setq atype (note-function-use dest atype)))))
-      (setf (info function assumed-type name) atype))))
-
-
-;;; IR1-FINALIZE  --  Interface
-;;;
-;;;    Do miscellaneous things that we want to do once all optimization has
-;;; been done:
-;;;  -- Record the derived result type before the back-end trashes the
-;;;     flow graph.
-;;;  -- Note definition of any entry points.
-;;;  -- Note any failed optimizations.
-;;; 
-(defun ir1-finalize (component)
-  (declare (type component component))
-  (dolist (fun (component-lambdas component))
-    (case (functional-kind fun)
-      (:external
-       (finalize-xep-definition fun))
-      ((nil)
-       (setf (leaf-type fun) (definition-type fun)))))
-  
-  (maphash #'note-failed-optimization
-	   (component-failed-optimizations component))
-  
-  (maphash #'(lambda (k v)
-	       (note-assumed-types component k v))
-	   *free-functions*)
-  (undefined-value))
diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp
deleted file mode 100644
index 7ecabf4b53e02e5f69a5b6730ab6e742683c3550..0000000000000000000000000000000000000000
--- a/compiler/ir1opt.lisp
+++ /dev/null
@@ -1,1658 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.56 1992/11/03 07:04:29 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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)
-
-
-;;;; 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)
-  (assert (constant-continuation-p 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) ctype))
-(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 (member (continuation-kind cont) '(:deleted :unused))
-    (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)))
-	      (when (typep dest 'cif)
-		(setf (block-test-modified block) t))
-	      (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)
-	  (when (and *check-consistency*
-		     (eq int *empty-type*)
-		     (not (eq rtype *empty-type*)))
-	    (let ((*compiler-error-context* node))
-	      (compiler-warning
-	       "New inferred type ~S conflicts with old type:~
-		~%  ~S~%*** Bug?"
-	       (type-specifier rtype) (type-specifier node-type))))
-	  (setf (node-derived-type node) int)
-	  (reoptimize-continuation (node-cont node))))))
-  (undefined-value))
-
-(declaim (start-block assert-continuation-type assert-call-type))
-
-;;; 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
-;;; TYPE-CHECK and TYPE-ASSERTED 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)
-	    (setf (block-attributep (block-flags (node-block node))
-				    type-check type-asserted)
-		  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:
-
-(declaim (start-block ir1-optimize))
-
-;;; 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 the
-;;; Reoptimize flag 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-home-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 going 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 :restart-p t)
-    (when (node-reoptimize node)
-      (setf (node-reoptimize node) nil)
-      (typecase node
-	(ref)
-	(combination
-	 (ir1-optimize-combination node))
-	(cif 
-	 (ir1-optimize-if node))
-	(creturn
-	 (setf (node-reoptimize node) t)
-	 (ir1-optimize-return node))
-	(mv-combination
-	 (ir1-optimize-mv-combination 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-start next)
-      (let* ((last (block-last block))
-	     (last-cont (node-cont last))
-	     (next-cont (block-start next)))
-	(cond ((or (rest (block-pred next))
-		   (not (eq (continuation-use last-cont) last))
-		   (eq next block)
-		   (not (eq (block-end-cleanup block)
-			    (block-start-cleanup next)))
-		   (not (eq (block-home-lambda block)
-			    (block-home-lambda next))))
-	       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)))
-		 ;;
-		 ;; If next-cont does have a dest, it must be unreachable,
-		 ;; since there are no uses.  DELETE-CONTINUATION will mark the
-		 ;; dest block as delete-p [and also this block, unless it is
-		 ;; no longer backward reachable from the dest block.]
-		 (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.  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-flags block1)
-	(attributes-union (block-flags block1)
-			  (block-flags block2)
-			  (block-attributes type-asserted test-modified)))
-  
-  (let ((next (block-next block2))
-	(prev (block-prev block2)))
-    (setf (block-next prev) next)
-    (setf (block-prev next) prev))
-
-  (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))))))
-	(mv-combination
-	 (when (eq (basic-combination-kind node) :local)
-	   (let ((fun (combination-lambda node)))
-	     (when (dolist (var (lambda-vars fun) t)
-		     (when (or (leaf-refs var)
-			       (lambda-var-sets var))
-		       (return nil)))
-	       (flush-dest (first (basic-combination-args node)))
-	       (delete-let fun)))))
-	(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))
-
-(declaim (end-block))
-
-
-;;;; 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 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.)
-;;;
-;;;    We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV combination,
-;;; which may change the succesor of the call to be the called function, and if
-;;; so, checks if the call can become an assignment.   If we convert to an
-;;; assignment, we abort, since the RETURN has been deleted.
-;;;
-(defun find-result-type (node)
-  (declare (type creturn node))
-  (let ((result (return-result node)))
-    (collect ((use-union *empty-type* values-type-union))
-      (do-uses (use result)
-	(cond ((and (basic-combination-p use)
-		    (eq (basic-combination-kind use) :local))
-	       (assert (eq (lambda-tail-set (node-home-lambda use))
-			   (lambda-tail-set (combination-lambda use))))
-	       (when (combination-p use)
-		 (when (nth-value 1 (maybe-convert-tail-local-call use))
-		   (return-from find-result-type (undefined-value)))))
-	      (t
-	       (use-union (node-derived-type use)))))
-      (let ((int (values-type-intersection
-		  (continuation-asserted-type result)
-		  (use-union))))
-	(setf (return-result-type node) int))))
-  (undefined-value))
-
-
-;;; 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.)
-;;;
-;;;    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)))
-	 (funs (tail-set-functions tails)))
-    (collect ((res *empty-type* values-type-union))
-      (dolist (fun funs)
-	(let ((return (lambda-return fun)))
-	  (when return
-	    (when (node-reoptimize return)
-	      (setf (node-reoptimize node) nil)
-	      (find-result-type return))
-	    (res (return-result-type 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))
-
-
-;;; IF optimization:
-
-(declaim (start-block ir1-optimize-if))
-
-;;; 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))
-;;;
-;;;    We clobber the NODE-SOURCE-PATH of both the original and the new node so
-;;; that dead code deletion notes will definitely not consider either node to
-;;; be part of the original source.  One node might become unreachable,
-;;; resulting in a spurious note.
-;;;
-(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
-			      :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)
-
-      (push "<IF Duplication>" (node-source-path node))
-      (push "<IF Duplication>" (node-source-path new-node))
-
-      (reoptimize-continuation test)
-      (reoptimize-continuation new-cont)
-      (setf (component-reanalyze *current-component*) t)))
-  (undefined-value))
-
-(declaim (end-block))
-
-
-;;;; 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 the exit is to a TR context, then we must do MERGE-TAIL-SETS
-;;;    on any local calls which delivered their value to this exit.
-;;; -- 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 (node-home-lambda node) (node-home-lambda entry)))
-      (setf (entry-exits entry) (delete node (entry-exits entry)))
-      (prog1
-	  (unlink-node node)
-	(when value
-	  (collect ((merges))
-	    (when (return-p (continuation-dest cont))
-	      (do-uses (use value)
-		(when (and (basic-combination-p use)
-			   (eq (basic-combination-kind use) :local))
-		  (merges use))))
-	    (substitute-continuation-uses cont value)
-	    (dolist (merge (merges))
-	      (merge-tail-sets merge))))))))
-
-
-;;;; Combination IR1 optimization:
-
-(declaim (start-block ir1-optimize-combination maybe-terminate-block
-		      validate-call-type))
-
-;;; Ir1-Optimize-Combination  --  Internal
-;;;
-;;;    Do IR1 optimizations on a Combination node.
-;;;
-(proclaim '(function ir1-optimize-combination (combination) void))
-(defun ir1-optimize-combination (node)
-  (when (continuation-reoptimize (basic-combination-fun node))
-    (propagate-function-change 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 :error)
-       (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)
-	       (maybe-terminate-block node nil)))))
-
-       (let ((fun (function-info-optimizer kind)))
-	 (unless (and fun (funcall fun node))
-	   (dolist (x (function-info-transforms kind))
-	     (unless (ir1-transform node x)
-	       (return))))))))
-
-  (undefined-value))
-
-
-;;; MAYBE-TERMINATE-BLOCK  --  Interface
-;;;
-;;;    If Call is to a function that doesn't return (type NIL), then terminate
-;;; the block there, and link it to the component tail.  We also change the
-;;; call's CONT to be a dummy continuation to prevent the use from confusing
-;;; things.
-;;;
-;;; Except when called during IR1, we delete the continuation if it has no
-;;; other uses.  (If it does have other uses, we reoptimize.)
-;;;
-;;; Termination on the basis of a continuation type assertion is inhibited
-;;; when:
-;;; -- The continuation is deleted (hence the assertion is spurious), or
-;;; -- We are in IR1 conversion (where THE assertions are subject to
-;;;    weakening.)
-;;;
-(defun maybe-terminate-block (call ir1-p)
-  (declare (type basic-combination call))
-  (let* ((block (node-block call))
-	 (cont (node-cont call))
-	 (tail (component-tail (block-component block)))
-	 (succ (first (block-succ block))))
-    (unless (or (and (eq call (block-last block)) (eq succ tail))
-		(block-delete-p block)
-		*converting-for-interpreter*)
-      (when (or (and (eq (continuation-asserted-type cont) *empty-type*)
-		     (not (or ir1-p (eq (continuation-kind cont) :deleted))))
-		(eq (node-derived-type call) *empty-type*))
-	(cond (ir1-p
-	       (delete-continuation-use call)
-	       (cond
-		((block-last block)
-		 (assert (and (eq (block-last block) call)
-			      (eq (continuation-kind cont) :block-start))))
-		(t
-		 (setf (block-last block) call)
-		 (link-blocks block (continuation-starts-block cont)))))
-	      (t
-	       (node-ends-block call)
-	       (delete-continuation-use call)
-	       (if (eq (continuation-kind cont) :unused)
-		   (delete-continuation cont)
-		   (reoptimize-continuation cont))))
-	
-	(unlink-blocks block (first (block-succ block)))
-	(setf (component-reanalyze (block-component block)) t)
-	(assert (not (block-succ block)))
-	(link-blocks block tail)
-	(add-continuation-use call (make-continuation))
-	t))))
-
-
-;;; Recognize-Known-Call  --  Interface
-;;;
-;;;    Called both by IR1 conversion and IR1 optimization when they have
-;;; verified the type signature for the call, and are wondering if something
-;;; should be done to special-case the call.  If Call is a call to a global
-;;; function, then see if it defined or known:
-;;; -- If a DEFINED-FUNCTION should be inline expanded, then convert the
-;;;    expansion and change the call to call it.  Expansion is enabled if
-;;;    :INLINE or if space=0.  If the FUNCTIONAL slot is true, we never expand,
-;;;    since this function has already been converted.  Local call analysis
-;;;    will duplicate the definition if necessary.  We claim that the parent
-;;;    form is LABELS for context declarations, since we don't want it to be
-;;;    considered a real global function.
-;;; -- 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.
-;;; -- If it is a known function, mark it as such by setting the Kind.
-;;;
-;;; We return the leaf referenced (NIL if not a leaf) and the function-info
-;;; assigned.
-;;;
-(defun recognize-known-call (call ir1-p)
-  (declare (type combination call))
-  (let* ((ref (continuation-use (basic-combination-fun call)))
-	 (leaf (when (ref-p ref) (ref-leaf ref)))
-	 (inlinep (if (defined-function-p leaf)
-		      (defined-function-inlinep leaf)
-		      :no-chance)))
-    (cond
-     ((eq inlinep :notinline) (values nil nil))
-     ((not (and (global-var-p leaf)
-		(eq (global-var-kind leaf) :global-function)))
-      (values leaf nil))
-     ((and (ecase inlinep
-	     (:inline t)
-	     (:no-chance nil)
-	     ((nil :maybe-inline) (policy call (zerop space))))
-	   (defined-function-inline-expansion leaf)
-	   (let ((fun (defined-function-functional leaf)))
-	     (or (not fun)
-		 (and (eq inlinep :inline) (functional-kind fun))))
-	   (inline-expansion-ok call))
-      (flet ((frob ()
-	       (let ((res (ir1-convert-lambda-for-defun
-			   (defined-function-inline-expansion leaf)
-			   leaf t
-			   #'ir1-convert-inline-lambda
-			   'labels)))
-		 (setf (defined-function-functional leaf) res)
-		 (change-ref-leaf ref res))))
-	(if ir1-p
-	    (frob)
-	    (with-ir1-environment call
-	      (frob)
-	      (local-call-analyze *current-component*))))
-				  
-      (values (ref-leaf (continuation-use (basic-combination-fun call)))
-	      nil))
-     (t
-      (let* ((name (leaf-name leaf))
-	     (info (info function info
-			 (if (slot-accessor-p leaf)
-			     (if (consp name) '%slot-setter '%slot-accessor)
-			     name))))
-	(if info
-	    (values leaf (setf (basic-combination-kind call) info))
-	    (values leaf nil)))))))
-
-
-;;; VALIDATE-CALL-TYPE  --  Internal
-;;;
-;;;    Check if Call satisfies Type.  If so, apply the type to the call, and do
-;;; MAYBE-TERMINATE-BLOCK and return the values of RECOGNIZE-KNOWN-CALL.  If an
-;;; error, set the combination kind and return NIL, NIL.
-;;;
-(defun validate-call-type (call type ir1-p)
-  (declare (type combination call) (type ctype type))
-  (cond ((not (function-type-p type)) (values nil nil))
-	((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)
-	 (maybe-terminate-block call ir1-p)
-	 (recognize-known-call call ir1-p))
-	(t
-	 (setf (combination-kind call) :error)
-	 (values nil nil))))
-
-
-;;; Propagate-Function-Change  --  Internal
-;;;
-;;;    Called by Ir1-Optimize when the function for a call has changed.
-;;; If the call is local, we try to let-convert it, and derive the result type.
-;;; If it is a :FULL call, we validate it against the type, which recognizes
-;;; known calls, does inline expansion, etc.  If a call to a predicate in a
-;;; non-conditional position or to a function with a source transform, then we
-;;; reconvert the form to give IR1 another chance.
-;;;
-(defun propagate-function-change (call)
-  (declare (type combination call))
-  (let ((*compiler-error-context* call)
-	(fun-cont (basic-combination-fun call)))
-    (setf (continuation-reoptimize fun-cont) nil)
-    (case (combination-kind call)
-      (:local
-       (let ((fun (combination-lambda call)))
-	 (maybe-let-convert fun)
-	 (unless (member (functional-kind fun) '(:let :assignment :deleted))
-	   (derive-node-type call (tail-set-type (lambda-tail-set fun))))))
-      (:full
-       (multiple-value-bind
-	   (leaf info)
-	   (validate-call-type call (continuation-derived-type fun-cont) nil)
-	 (cond ((functional-p leaf)
-		(convert-call-if-possible
-		 (continuation-use (basic-combination-fun call))
-		 call))
-	       ((not leaf))
-	       ((or (info function source-transform (leaf-name leaf))
-		    (and info
-			 (ir1-attributep (function-info-attributes info)
-					 predicate)
-			 (let ((dest (continuation-dest (node-cont call))))
-			   (and dest (not (if-p dest))))))
-		(let ((name (leaf-name leaf)))
-		  (when (symbolp name)
-		    (let ((dums (loop repeat (length (combination-args call))
-				      collect (gensym))))
-		      (transform-call call
-				      `(lambda ,dums
-					 (,name ,@dums))))))))))))
-  (undefined-value))
-
-
-;;;; Known function optimization:
-
-
-;;; RECORD-OPTIMIZATION-FAILURE  --  Internal
-;;;
-;;;    Add a failed optimization note to FAILED-OPTIMZATIONS for Node, Fun
-;;; and Args.  If there is already a note for Node and Transform, replace it,
-;;; otherwise add a new one.
-;;;
-(defun record-optimization-failure (node transform args)
-  (declare (type combination node) (type transform transform)
-	   (type (or function-type list) args))
-  (let* ((table (component-failed-optimizations *compile-component*))
-	 (found (assoc transform (gethash node table))))
-    (if found
-	(setf (cdr found) args)
-	(push (cons transform args) (gethash node table))))
-  (undefined-value))
-
-
-;;; 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.  We return true if
-;;; the transform failed, and thus further transformation should be
-;;; attempted.  We return false if either the transform suceeded or was
-;;; aborted.
-;;;
-(defun ir1-transform (node transform)
-  (declare (type combination node) (type transform transform))
-  (let* ((type (transform-type transform))
-	 (fun (transform-function transform))
-	 (constrained (function-type-p type))
-	 (table (component-failed-optimizations *compile-component*))
-	 (flame
-	  (if (transform-important transform)
-	      (policy node (>= speed brevity))
-	      (policy node (> speed brevity))))
-	 (*compiler-error-context* node))
-    (cond ((or (not constrained)
-	       (valid-function-use node type :strict-result t))
-	   (multiple-value-bind
-	       (severity args)
-	       (catch 'give-up
-		 (transform-call node (funcall fun node))
-		 (values :none nil))
-	     (ecase severity
-	       (:none
-		(remhash node table)
-		nil)
-	       (:aborted
-		(setf (combination-kind node) :error)
-		(when args
-		  (apply #'compiler-warning args))
-		(remhash node table)
-		nil)
-	       (:failure 
-		(if args
-		    (when flame
-		      (record-optimization-failure node transform args))
-		    (setf (gethash node table)
-			  (remove transform (gethash node table) :key #'car)))
-		t))))
-	  ((and flame
-		(valid-function-use node type
-				    :argument-test #'types-intersect
-				    :result-test #'values-types-intersect))
-	   (record-optimization-failure node transform type)
-	   t)
-	  (t
-	   t))))
-
-(declaim (end-block))
-
-;;; 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.
-;;;
-(defun transform-call (node res)
-  (declare (type combination node) (list res))
-  (with-ir1-environment node
-    (let ((new-fun (ir1-convert-inline-lambda res))
-	  (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 :ERROR call.
-;;;
-;;;    If there is more than one value, then we transform the call into a
-;;; values form.
-;;;
-(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 (combination-kind call) :error))
-       ((= (length values) 1)
-	(with-ir1-environment call
-	  (when (producing-fasl-file)
-	    (maybe-emit-make-load-forms (first values)))
-	  (let* ((leaf (find-constant (first values)))
-		 (node (make-ref (leaf-type leaf) leaf))
-		 (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))))
-       (t
-	(let ((dummies (loop repeat (length args)
-			     collect (gensym))))
-	  (transform-call
-	   call
-	   `(lambda ,dummies
-	      (declare (ignore ,@dummies))
-	      (values ,@(mapcar #'(lambda (x) `',x) values)))))))))
-  
-  (undefined-value))
-
-
-;;;; Local call optimization:
-
-(declaim (start-block ir1-optimize-set constant-reference-p delete-let
-		      propagate-let-args propagate-local-call-args
-		      propagate-to-refs propagate-from-sets
-		      ir1-optimize-mv-combination))
-
-;;; 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 type type-union))
-    (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))
-
-
-;;; CONSTANT-REFERENCE-P  --  Interface
-;;;
-;;;    Return true if the value of Ref will always be the same (and is thus
-;;; legal to substitute.)
-;;;
-(defun constant-reference-p (ref)
-  (declare (type ref ref))
-  (let ((leaf (ref-leaf ref)))
-    (typecase leaf
-      ((or constant functional) t)
-      (lambda-var
-       (null (lambda-var-sets leaf)))
-      (defined-function
-       (not (eq (defined-function-inlinep leaf) :notinline)))
-      (global-var
-       (case (global-var-kind leaf)
-	 (:global-function t)
-	 (:constant t))))))
-
-
-;;; SUBSTITUTE-SINGLE-USE-CONTINUATION  --  Internal
-;;;
-;;;    If we have a non-set let var with a single use, then (if possible)
-;;; replace the variable reference's CONT with the arg continuation.  This is
-;;; inhibited when:
-;;; -- CONT has other uses, or
-;;; -- CONT receives multiple values, or
-;;; -- the reference is in a different environment from the variable, or
-;;; -- either continuation has a funky TYPE-CHECK annotation.
-;;; -- the continuations have incompatible assertions, so the new asserted type
-;;;    would be NIL.
-;;; -- the var's DEST has a different policy than the ARG's (think safety).
-;;;
-;;;    We change the Ref to be a reference to NIL with unused value, and let it
-;;; be flushed as dead code.  A side-effect of this substitution is to delete
-;;; the variable.
-;;;
-(defun substitute-single-use-continuation (arg var)
-  (declare (type continuation arg) (type lambda-var var))
-  (let* ((ref (first (leaf-refs var)))
-	 (cont (node-cont ref))
-	 (cont-atype (continuation-asserted-type cont))
-	 (dest (continuation-dest cont)))
-    (when (and (eq (continuation-use cont) ref)
-	       dest
-	       (not (typep dest '(or creturn exit mv-combination)))
-	       (eq (node-home-lambda ref)
-		   (lambda-home (lambda-var-home var)))
-	       (member (continuation-type-check arg) '(t nil))
-	       (member (continuation-type-check cont) '(t nil))
-	       (not (eq (values-type-intersection
-			 cont-atype
-			 (continuation-asserted-type arg))
-			*empty-type*))
-	       (eq (lexenv-cookie (node-lexenv dest))
-		   (lexenv-cookie (node-lexenv (continuation-dest arg)))))
-      (assert (member (continuation-kind arg)
-		      '(:block-start :deleted-block-start :inside-block)))
-      (assert-continuation-type arg cont-atype)
-      (setf (node-derived-type ref) *wild-type*)
-      (change-ref-leaf ref (find-constant nil))
-      (substitute-continuation arg cont)
-      (reoptimize-continuation arg)
-      t)))
-
-
-;;; DELETE-LET  --  Interface
-;;;
-;;;    Delete a Let, removing the call and bind nodes, and warning about any
-;;; unreferenced variables.  Note that FLUSH-DEAD-CODE will come along right
-;;; away and delete the REF and then the lambda, since we flush the FUN
-;;; continuation. 
-;;;
-(defun delete-let (fun)
-  (declare (type clambda fun))
-  (assert (member (functional-kind fun) '(:let :mv-let)))
-  (note-unreferenced-vars fun)
-  (let ((call (let-combination fun)))
-    (flush-dest (basic-combination-fun call))
-    (unlink-node call)
-    (unlink-node (lambda-bind fun))
-    (setf (lambda-bind fun) nil))
-  (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 arg leaf'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.
-;;;
-;;;     Substitution of individual references is inhibited if the reference is
-;;; in a different component from the home.  This can only happen with closures
-;;; over top-level lambda vars.  In such cases, the references may have already
-;;; been compiled, and thus can't be retroactively modified.
-;;;
-;;;    If all of the variables are deleted (have no references) when we are
-;;; done, then we delete the let.
-;;;
-;;;    Note that we are responsible for clearing the Continuation-Reoptimize
-;;; flags.
-;;;
-(defun propagate-let-args (call fun)
-  (declare (type combination call) (type clambda fun))
-  (loop for arg in (combination-args call)
-        and var in (lambda-vars fun) do
-    (when (and arg (continuation-reoptimize arg))
-      (setf (continuation-reoptimize arg) nil)
-      (cond
-       ((lambda-var-sets var)
-	(propagate-from-sets var (continuation-type arg)))
-       ((let ((use (continuation-use arg)))
-	  (when (ref-p use)
-	    (let ((leaf (ref-leaf use)))
-	      (when (and (constant-reference-p use)
-			 (values-subtypep (leaf-type leaf)
-					  (continuation-asserted-type arg)))
-		(propagate-to-refs var (continuation-type arg))
-		(let ((this-comp (block-component (node-block use))))
-		  (substitute-leaf-if
-		   #'(lambda (ref)
-		       (cond ((eq (block-component (node-block ref))
-				  this-comp)
-			      t)
-			     (t
-			      (assert (eq (functional-kind (lambda-home fun))
-					  :top-level))
-			      nil)))
-		   leaf var))
-		t)))))
-       ((and (null (rest (leaf-refs var)))
-	     (not *byte-compiling*)
-	     (substitute-single-use-continuation arg var)))
-       (t
-	(propagate-to-refs var (continuation-type arg))))))
-  
-  (when (every #'null (combination-args call))
-    (delete-let 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))
-
-(declaim (end-block))
-
-
-;;;; Multiple values optimization:
-
-;;; IR1-OPTIMIZE-MV-COMBINATION  --  Internal
-;;;
-;;;    Do stuff to notice a change to a MV combination node.  There are two
-;;; main branches here:
-;;;  -- If the call is local, then it is already a MV let, or should become one.
-;;;     Note that although all :LOCAL MV calls must eventually be converted to
-;;;     :MV-LETs, there can be a window when the call is local, but has not
-;;;     been let converted yet.  This is because the entry-point lambdas may
-;;;     have stray references (in other entry points) that have not been
-;;;     deleted yet.
-;;;  -- The call is full.  This case is somewhat similar to the non-MV
-;;;     combination optimization: we propagate return type information and
-;;;     notice non-returning calls.  We also have an optimization
-;;;     which tries to convert MV-CALLs into MV-binds.
-;;;
-(defun ir1-optimize-mv-combination (node)
-  (ecase (basic-combination-kind node)
-    (:local
-     (let ((fun-cont (basic-combination-fun node)))
-       (when (continuation-reoptimize fun-cont)
-	 (setf (continuation-reoptimize fun-cont) nil)
-	 (maybe-let-convert (combination-lambda node))))
-     (setf (continuation-reoptimize (first (basic-combination-args node))) nil)
-     (when (eq (functional-kind (combination-lambda node)) :mv-let)
-       (unless (convert-mv-bind-to-let node)
-	 (ir1-optimize-mv-bind node))))
-    (:full
-     (let* ((fun (basic-combination-fun node))
-	    (fun-changed (continuation-reoptimize fun))
-	    (args (basic-combination-args node)))
-       (when fun-changed
-	 (setf (continuation-reoptimize fun) nil)
-	 (let ((type (continuation-type fun)))
-	   (when (function-type-p type)
-	     (derive-node-type node (function-type-returns type))))
-	 (maybe-terminate-block node nil)
-	 (let ((use (continuation-use fun)))
-	   (when (and (ref-p use) (functional-p (ref-leaf use)))
-	     (convert-call-if-possible use node)
-	     (when (eq (basic-combination-kind node) :local)
-	       (maybe-let-convert (ref-leaf use))))))
-       (unless (or (eq (basic-combination-kind node) :local)
-		   (eq (continuation-function-name fun) '%throw))
-	 (ir1-optimize-mv-call node))
-       (dolist (arg args)
-	 (setf (continuation-reoptimize arg) nil))))
-    (:error))
-  (undefined-value))
-
-  
-;;; IR1-OPTIMIZE-MV-BIND  --  Internal
-;;;
-;;;    Propagate derived type info from the values continuation to the vars.
-;;;
-(defun ir1-optimize-mv-bind (node)
-  (declare (type mv-combination node))
-  (let ((arg (first (basic-combination-args node)))
-	(vars (lambda-vars (combination-lambda node))))
-    (multiple-value-bind (types nvals)
-			 (values-types (continuation-derived-type arg))
-      (unless (eq nvals :unknown)
-	(mapc #'(lambda (var type)
-		  (if (basic-var-sets var)
-		      (propagate-from-sets var type)
-		      (propagate-to-refs var type)))
-		vars
-		(append types
-			(make-list (max (- (length vars) nvals) 0)
-				   :initial-element *null-type*)))))
-
-    (setf (continuation-reoptimize arg) nil))
-  (undefined-value))
-
-
-;;; IR1-OPTIMIZE-MV-CALL  --  Internal
-;;;
-;;;    If possible, convert a general MV call to an MV-BIND.  We can do this
-;;; if:
-;;; -- The call has only one argument, and
-;;; -- The function has a known fixed number of arguments, or
-;;; -- The argument yields a known fixed number of values.
-;;;
-;;; What we do is change the function in the MV-CALL to be a lambda that "looks
-;;; like an MV bind", which allows IR1-OPTIMIZE-MV-COMBINATION to notice that
-;;; this call can be converted (the next time around.)  This new lambda just
-;;; calls the actual function with the MV-BIND variables as arguments.  Note
-;;; that this new MV bind is not let-converted immediately, as there are going
-;;; to be stray references from the entry-point functions until they get
-;;; deleted.
-;;;
-;;; In order to avoid loss of argument count checking, we only do the
-;;; transformation according to a known number of expected argument if safety
-;;; is unimportant.  We can always convert if we know the number of actual
-;;; values, since the normal call that we build will still do any appropriate
-;;; argument count checking.
-;;;
-;;; We only attempt the transformation if the called function is a constant
-;;; reference.  This allows us to just splice the leaf into the new function,
-;;; instead of trying to somehow bind the function expression.  The leaf must
-;;; be constant because we are evaluating it again in a different place.  This
-;;; also has the effect of squelching multiple warnings when there is an
-;;; argument count error.
-;;;
-(defun ir1-optimize-mv-call (node)
-  (let ((fun (basic-combination-fun node))
-	(*compiler-error-context* node)
-	(ref (continuation-use (basic-combination-fun node)))
-	(args (basic-combination-args node)))
-
-    (unless (and (ref-p ref) (constant-reference-p ref)
-		 args (null (rest args)))
-      (return-from ir1-optimize-mv-call))
-
-    (multiple-value-bind (min max)
-			 (function-type-nargs (continuation-type fun))
-      (let ((total-nvals 
-	     (multiple-value-bind
-		 (types nvals)
-		 (values-types (continuation-derived-type (first args)))
-	       (declare (ignore types))
-	       (if (eq nvals :unknown) nil nvals))))
-
-	(when total-nvals
-	  (when (and min (< total-nvals min))
-	    (compiler-warning
-	     "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
-	     at least ~R."
-	     total-nvals min)
-	    (setf (basic-combination-kind node) :error)
-	    (return-from ir1-optimize-mv-call))
-	  (when (and max (> total-nvals max))
-	    (compiler-warning
-	     "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
-	     at most ~R."
-	     total-nvals max)
-	    (setf (basic-combination-kind node) :error)
-	    (return-from ir1-optimize-mv-call)))
-
-	(let ((count (cond (total-nvals)
-			   ((and (policy node (zerop safety)) (eql min max))
-			    min)
-			   (t nil))))
-	  (when count
-	    (with-ir1-environment node
-	      (let* ((dums (loop repeat count collect (gensym)))
-		     (ignore (gensym))
-		     (fun (ir1-convert-lambda
-			   `(lambda (&optional ,@dums &rest ,ignore)
-			      (declare (ignore ,ignore))
-			      (funcall ,(ref-leaf ref) ,@dums)))))
-		(change-ref-leaf ref fun)
-		(assert (eq (basic-combination-kind node) :full))
-		(local-call-analyze *current-component*)
-		(assert (eq (basic-combination-kind node) :local)))))))))
-  (undefined-value))
-
-
-;;; CONVERT-MV-BIND-TO-LET  --  Internal
-;;;
-;;; If we see:
-;;;    (multiple-value-bind (x y)
-;;;                         (values xx yy)
-;;;      ...)
-;;; Convert to:
-;;;    (let ((x xx)
-;;;          (y yy))
-;;;      ...)
-;;;
-;;; What we actually do is convert the VALUES combination into a normal let
-;;; combination calling the original :MV-LET lambda.  If there are extra args to
-;;; VALUES, discard the corresponding continuations.  If there are insufficient
-;;; args, insert references to NIL.
-;;;
-(defun convert-mv-bind-to-let (call)
-  (declare (type mv-combination call))
-  (let* ((arg (first (basic-combination-args call)))
-	 (use (continuation-use arg)))
-    (when (and (combination-p use)
-	       (eq (continuation-function-name (combination-fun use))
-		   'values))
-      (let* ((fun (combination-lambda call))
-	     (vars (lambda-vars fun))
-	     (vals (combination-args use))
-	     (nvars (length vars))
-	     (nvals (length vals)))
-	(cond ((> nvals nvars)
-	       (mapc #'flush-dest (subseq vals nvars))
-	       (setq vals (subseq vals 0 nvars)))
-	      ((< nvals nvars)
-	       (with-ir1-environment use
-		 (let ((node-prev (node-prev use)))
-		   (setf (node-prev use) nil)
-		   (setf (continuation-next node-prev) nil)
-		   (collect ((res vals))
-		     (loop as cont = (make-continuation use)
-			   and prev = node-prev then cont
-			   repeat (- nvars nvals)
-			   do (reference-constant prev cont nil)
-			      (res cont))
-		     (setq vals (res)))
-		   (prev-link use (car (last vals)))))))
-	(setf (combination-args use) vals)
-	(flush-dest (combination-fun use))
-	(let ((fun-cont (basic-combination-fun call)))
-	  (setf (continuation-dest fun-cont) use)
-	  (setf (combination-fun use) fun-cont))
-	(setf (combination-kind use) :local)
-	(setf (functional-kind fun) :let)
-	(flush-dest (first (basic-combination-args call)))
-	(unlink-node call)
-	(when vals
-	  (reoptimize-continuation (first vals)))
-	(propagate-to-args use fun))
-      t)))
-
-
-;;; VALUES-LIST IR1 optimizer  --  Internal
-;;;
-;;; If we see:
-;;;    (values-list (list x y z))
-;;;
-;;; Convert to:
-;;;    (values x y z)
-;;;
-;;; In implementation, this is somewhat similar to CONVERT-MV-BIND-TO-LET.  We
-;;; grab the args of LIST and make them args of the VALUES-LIST call, flushing
-;;; the old argument continuation (allowing the LIST to be flushed.)
-;;;
-(defoptimizer (values-list optimizer) ((list) node)
-  (let ((use (continuation-use list)))
-    (when (and (combination-p use)
-	       (eq (continuation-function-name (combination-fun use))
-		   'list))
-      (change-ref-leaf (continuation-use (combination-fun node))
-		       (find-free-function 'values "in a strange place"))
-      (setf (combination-kind node) :full)
-      (let ((args (combination-args use)))
-	(dolist (arg args)
-	  (setf (continuation-dest arg) node))
-	(setf (combination-args use) nil)
-	(flush-dest list)
-	(setf (combination-args node) args))
-      t)))
-
-
-;;; VALUES IR1 transform  --  Internal
-;;;
-;;;    If VALUES appears in a non-MV context, then effectively convert it to a
-;;; PROG1.  This allows the computation of the additional values to become dead
-;;; code.
-;;;
-(deftransform values ((&rest vals) * * :node node)
-  (when (typep (continuation-dest (node-cont node))
-	       '(or creturn exit mv-combination))
-    (give-up))
-  (setf (node-derived-type node) *wild-type*)
-  (if vals
-      (let ((dummies (loop repeat (1- (length vals))
-		       collect (gensym))))
-	`(lambda (val ,@dummies)
-	   (declare (ignore ,@dummies))
-	   val))
-      'nil))
diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp
deleted file mode 100644
index 759a5502b18e2fc51589625d71dd273347fd8635..0000000000000000000000000000000000000000
--- a/compiler/ir1util.lisp
+++ /dev/null
@@ -1,2145 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.60 1992/09/22 00:05:23 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains random utilities used for manipulating the IR1
-;;; representation.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package "C")
-(export '(*compiler-notification-function*))
-(in-package "EXTENSIONS")
-(export '(*error-print-level* *error-print-length* *error-print-lines*
-	  def-source-context *undefined-warning-limit*
-	  *enclosing-source-cutoff* *inline-expansion-limit*))
-
-(in-package "C")
-
-
-;;;; Cleanup hackery:
-
-
-;;; Node-Enclosing-Cleanup  --  Interface
-;;;
-;;;    Return the innermost cleanup enclosing Node, or NIL if there is none in
-;;; its function.  If Node has no cleanup, but is in a let, then we must still
-;;; check the environment that the call is in.
-;;;
-(defun node-enclosing-cleanup (node)
-  (declare (type node node))
-  (do ((lexenv (node-lexenv node)
-	       (lambda-call-lexenv (lexenv-lambda lexenv))))
-      ((null lexenv) nil)
-    (let ((cup (lexenv-cleanup lexenv)))
-      (when cup (return cup)))))
-
-
-;;; 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.  If Cleanup is
-;;; supplied, then convert with that cleanup.
-;;;
-(defun insert-cleanup-code (block1 block2 node form &optional cleanup)
-  (declare (type cblock block1 block2) (type node node)
-	   (type (or cleanup null) cleanup))
-  (setf (component-reanalyze (block-component block1)) t)
-  (with-ir1-environment node
-    (let* ((start (make-continuation))
-	   (block (continuation-starts-block start))
-	   (cont (make-continuation))
-	   (*lexical-environment*
-	   (if cleanup
-	       (make-lexenv :cleanup cleanup)
-	       *lexical-environment*)))
-      (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))
-
-;;; Substitute-Continuation-Uses  --  Interface
-;;;
-;;;    Replace all uses of Old with uses of New, where New has an arbitary
-;;; number of uses.  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)
-    (delete-continuation-use node)
-    (add-continuation-use node new))
-
-  (reoptimize-continuation new)
-  (undefined-value))
-
-
-;;;; Block starting/creation:
-
-;;; Continuation-Starts-Block  --  Interface
-;;;
-;;;    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.
-;;; 
-;;;    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))))
-
-;;; 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  :component nil
-				      :start-uses (find-uses cont)))
-		(setf (continuation-kind cont) :deleted-block-start))
-	       (t
-		(node-ends-block (continuation-use cont))))))))
-  (undefined-value))
-
-
-;;;; Misc shortand functions:
-
-;;; NODE-HOME-LAMBDA  --  Interface
-;;;
-;;;    Return the home (i.e. enclosing non-let) lambda for Node.  Since the
-;;; LEXENV-LAMBDA may be deleted, we must chain up the LAMBDA-CALL-LEXENV
-;;; thread until we find a lambda that isn't deleted, and then return its home.
-;;;
-(declaim (maybe-inline node-home-lambda))
-(defun node-home-lambda (node)
-  (declare (type node node))
-  (do ((fun (lexenv-lambda (node-lexenv node))
-	    (lexenv-lambda (lambda-call-lexenv fun))))
-      ((not (eq (functional-kind fun) :deleted))
-       (lambda-home fun))
-    (when (eq (lambda-home fun) fun)
-      (return fun))))
-
-;;; NODE-xxx  --  Interface
-;;;
-(declaim (inline node-block node-tlf-number))
-(declaim (maybe-inline node-environment))
-(defun node-block (node)
-  (declare (type node node))
-  (the cblock (continuation-block (node-prev node))))
-;;;
-(defun node-environment (node)
-  (declare (type node node) (inline node-home-lambda))
-  (the environment (lambda-environment (node-home-lambda node))))
-
-
-;;; BLOCK-xxx-CLEANUP  --  Interface
-;;;
-;;;    Return the enclosing cleanup for environment of the first or last node
-;;; in Block.
-;;;
-(defun block-start-cleanup (block)
-  (declare (type cblock block))
-  (node-enclosing-cleanup (continuation-next (block-start block))))
-;;;
-(defun block-end-cleanup (block)
-  (declare (type cblock block))
-  (node-enclosing-cleanup (block-last block)))
-
-
-;;; BLOCK-HOME-LAMBDA  --  Interface
-;;;
-;;;    Return the non-let lambda that holds Block's code.
-;;;
-(defun block-home-lambda (block)
-  (declare (type cblock block) (inline node-home-lambda))
-  (node-home-lambda (block-last block)))
-
-
-;;; BLOCK-ENVIRONMENT  --  Interface
-;;;
-;;;    Return the IR1 environment for Block.
-;;;
-(defun block-environment (block)
-  (declare (type cblock block) (inline node-home-lambda))
-  (lambda-environment (node-home-lambda (block-last block))))
-
-
-;;; SOURCE-PATH-TLF-NUMBER  --  Interface
-;;;
-;;;    Return the Top Level Form number of path, i.e. the ordinal number of
-;;; its orignal source's top-level form in its compilation unit.
-;;;
-(defun source-path-tlf-number (path)
-  (declare (list path))
-  (car (last path)))
-
-
-;;; SOURCE-PATH-ORIGINAL-SOURCE  --  Interface
-;;;
-;;;    Return the (reversed) list for the path in the orignal source (with the
-;;; TLF number last.)
-;;; 
-(defun source-path-original-source (path)
-  (declare (list path) (inline member))
-  (cddr (member 'original-source-start path :test #'eq)))
-
-
-;;; SOURCE-PATH-FORM-NUMBER  --  Interface
-;;;
-;;;    Return the Form Number of Path's orignal source inside the Top Level
-;;; Form that contains it.  This is determined by the order that we walk the
-;;; subforms of the top level source form.
-;;;
-(defun source-path-form-number (path)
-  (declare (list path) (inline member))
-  (cadr (member 'original-source-start path :test #'eq)))
-
-
-;;; SOURCE-PATH-FORMS  --  Interface
-;;;
-;;;    Return a list of all the enclosing forms not in the original source that
-;;; converted to get to this form, with the immediate source for node at the
-;;; start of the list.
-;;;
-(defun source-path-forms (path)
-  (subseq path 0 (position 'original-source-start path)))
-
-
-;;; NODE-SOURCE-FORM  --  Interface
-;;;
-;;;    Return the innermost source form for Node.
-;;;
-(defun node-source-form (node)
-  (declare (type node node))
-  (let* ((path (node-source-path node))
-	 (forms (source-path-forms path)))
-    (if forms
-	(first forms)
-	(values (find-original-source path)))))
-
-
-;;; CONTINUATION-SOURCE-FORM  --  Interface
-;;;
-;;;    Return NODE-SOURCE-FORM, T if continuation has a single use, otherwise
-;;; NIL, NIL.
-;;;
-(defun continuation-source (cont)
-  (let ((use (continuation-use cont)))
-    (if use
-	(values (node-source-form use) t)
-	(values nil nil))))
-
-
-;;; MAKE-LEXENV  --  Interface
-;;;
-;;;    Return a new LEXENV just like Default except for the specified slot
-;;; values.  Values for the alist slots are NCONC'ed to the beginning of the
-;;; current value, rather than replacing it entirely.
-;;; 
-(defun make-lexenv (&key (default *lexical-environment*)
-			 functions variables blocks tags type-restrictions
-			 options
-			 (lambda (lexenv-lambda default))
-			 (cleanup (lexenv-cleanup default))
-			 (cookie (lexenv-cookie default))
-			 (interface-cookie (lexenv-interface-cookie default)))
-  (macrolet ((frob (var slot)
-	       `(let ((old (,slot default)))
-		  (if ,var
-		      (nconc ,var old)
-		      old))))
-    (internal-make-lexenv
-     (frob functions lexenv-functions)
-     (frob variables lexenv-variables)
-     (frob blocks lexenv-blocks)
-     (frob tags lexenv-tags)
-     (frob type-restrictions lexenv-type-restrictions)
-     lambda cleanup cookie interface-cookie
-     (frob options lexenv-options))))
-
-
-;;; MAKE-INTERFACE-COOKIE  --  Interface
-;;;
-;;;    Return a cookie that defaults any unsupplied optimize qualities in the
-;;; Interface-Cookie with the corresponding ones from the Cookie.
-;;;
-(defun make-interface-cookie (lexenv)
-  (declare (type lexenv lexenv))
-  (let ((icookie (lexenv-interface-cookie lexenv))
-	(cookie (lexenv-cookie lexenv)))
-    (make-cookie
-     :speed (or (cookie-speed icookie) (cookie-speed cookie))
-     :space (or (cookie-space icookie) (cookie-space cookie))
-     :safety (or (cookie-safety icookie) (cookie-safety cookie))
-     :cspeed (or (cookie-cspeed icookie) (cookie-cspeed cookie))
-     :brevity (or (cookie-brevity icookie) (cookie-brevity cookie))
-     :debug (or (cookie-debug icookie) (cookie-debug cookie)))))
-			   
-
-;;;; Flow/DFO/Component hackery:
-
-;;; Link-Blocks  --  Interface
-;;;
-;;;    Join Block1 and Block2.
-;;;
-(declaim (inline link-blocks))
-(defun link-blocks (block1 block2)
-  (declare (type cblock block1 block2))
-  (setf (block-succ block1)
-	(if (block-succ block1)
-	    (%link-blocks block1 block2)
-	    (list block2)))
-  (push block1 (block-pred block2))
-  (undefined-value))
-;;;
-(defun %link-blocks (block1 block2)
-  (declare (type cblock block1 block2) (inline member))
-  (let ((succ1 (block-succ block1)))
-    (assert (not (member block2 succ1 :test #'eq)))
-    (cons block2 succ1)))
-
-
-;;; UNLINK-BLOCKS  --  Interface
-;;;
-;;;    Like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2.  If this leaves a
-;;; successor with a single predecessor that ends in an IF, then set
-;;; BLOCK-TEST-MODIFIED so that any test constraint will now be able to be
-;;; propagated to the successor.
-;;;
-(defun unlink-blocks (block1 block2)
-  (declare (type cblock block1 block2))
-  (let ((succ1 (block-succ block1)))
-    (if (eq block2 (car succ1))
-	(setf (block-succ block1) (cdr succ1))
-	(do ((succ (cdr succ1) (cdr succ))
-	     (prev succ1 succ))
-	    ((eq (car succ) block2)
-	     (setf (cdr prev) (cdr succ)))
-	  (assert succ))))
-
-  (let ((new-pred (delq block1 (block-pred block2))))
-    (setf (block-pred block2) new-pred)
-    (when (and new-pred (null (rest new-pred)))
-      (let ((pred-block (first new-pred)))
-	(when (if-p (block-last pred-block))
-	  (setf (block-test-modified pred-block) t)))))
-  (undefined-value))
-
-
-;;; 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.  We also set
-;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to the new
-;;; successor.
-;;;
-(defun change-block-successor (block old new)
-  (declare (type cblock new old block) (inline member))
-  (unlink-blocks block old)
-  (setf (component-reanalyze (block-component block)) t)
-  (unless (member new (block-succ block) :test #'eq)
-    (link-blocks block new))
-  
-  (let ((last (block-last block)))
-    (when (if-p last)
-      (setf (block-test-modified block) t)
-      (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))
-(declaim (inline remove-from-dfo))
-(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.
-;;;
-(declaim (inline add-to-dfo))
-(defun add-to-dfo (block after)
-  (declare (type cblock block after))
-  (let ((next (block-next after))
-	(comp (block-component after)))
-    (assert (not (eq (component-kind comp) :deleted)))
-    (setf (block-component block) comp)
-    (setf (block-next after) block)
-    (setf (block-prev block) after)
-    (setf (block-next block) next)
-    (setf (block-prev next) block))
-  (undefined-value))
-
-
-;;; 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 :component nil))
-	 (tail (make-block-key :start 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.
-;;; The new block is added to the DFO immediately following Node's block.
-;;;
-(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 (and (eq (continuation-kind start) :inside-block)
-		   (not (block-delete-p block))))
-      (let* ((succ (block-succ block))
-	     (new-block
-	      (make-block-key :start start
-			      :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)
-	(setf (component-reanalyze (block-component block)) t)
-	
-	(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))
-
-	(setf (block-type-asserted block) t)
-	(setf (block-test-modified block) t))))
-
-  (undefined-value))
-
-
-;;;; Deleting stuff:
-
-(declaim (start-block delete-ref delete-functional flush-dest
-		      delete-continuation delete-block))
-
-;;; 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.  We also mark the let for
-;;; reoptimization, since it may be that we have deleted the last variable.
-;;;
-;;;    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))
-		 (arg (elt args n)))
-	    (reoptimize-continuation arg)
-	    (flush-dest arg)
-	    (setf (elt args n) nil))))))
-
-  (dolist (set (lambda-var-sets leaf))
-    (setf (block-flush-p (node-block set)) t))
-
-  (undefined-value))
-
-
-;;; REOPTIMIZE-LAMBDA-VAR  --  Internal
-;;;
-;;;    Note that something interesting has happened to Var.  We only deal with
-;;; LET variables, marking the corresponding initial value arg as needing to be
-;;; reoptimized.
-;;;
-(defun reoptimize-lambda-var (var)
-  (declare (type lambda-var var))
-  (let ((fun (lambda-var-home var)))
-    (when (and (eq (functional-kind fun) :let)
-	       (leaf-refs var))
-      (reoptimize-continuation
-       (elt (basic-combination-args
-	     (continuation-dest
-	      (node-cont
-	       (first (leaf-refs fun)))))
-	    (position var (lambda-vars fun))))))
-  (undefined-value))
-
-
-;;; DELETE-FUNCTIONAL  --  Interface
-;;;
-;;;    This function deletes functions that have no references.  This need only
-;;; be called on functions that never had any references, since otherwise
-;;; DELETE-REF will handle the deletion. 
-;;;
-(defun delete-functional (fun)
-  (assert (and (null (leaf-refs fun))
-	       (not (functional-entry-function fun))))
-  (etypecase fun
-    (optional-dispatch (delete-optional-dispatch fun))
-    (clambda (delete-lambda fun)))
-  (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 from Component-Lambdas (it won't be there before
-;;; local call analysis, but no matter.)  If the lambda was never referenced,
-;;; we give a note.
-;;;
-;;;    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))
-	(bind (lambda-bind leaf)))
-    (assert (not (member kind '(:deleted :optional :top-level))))
-    (setf (functional-kind leaf) :deleted)
-    (setf (lambda-bind leaf) nil)
-    (dolist (let (lambda-lets leaf))
-      (setf (lambda-bind let) nil)
-      (setf (functional-kind let) :deleted))
-
-    (if (member kind '(:let :mv-let :assignment))
-	(let ((home (lambda-home leaf)))
-	  (setf (lambda-lets home) (delete leaf (lambda-lets home))))
-	(let* ((bind-block (node-block bind))
-	       (component (block-component bind-block))
-	       (return (lambda-return leaf)))
-	  (assert (null (leaf-refs leaf)))
-	  (unless (leaf-ever-used leaf)
-	    (let ((*compiler-error-context* bind))
-	      (compiler-note "Deleting unused function~:[.~;~:*~%  ~S~]"
-			     (leaf-name leaf))))
-	  (unlink-blocks (component-head component) bind-block)
-	  (when return
-	    (unlink-blocks (node-block return) (component-tail component)))
-	  (setf (component-reanalyze component) t)
-	  (let ((tails (lambda-tail-set leaf)))
-	    (setf (tail-set-functions tails)
-		  (delete leaf (tail-set-functions tails)))
-	    (setf (lambda-tail-set leaf) nil))
-	  (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))
-			  (or (maybe-let-convert fun)
-			      (maybe-convert-to-assignment fun)))
-			 (t
-			  (maybe-convert-to-assignment 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 :let :mv-let :assignment :escape :cleanup)
-		 (assert (not (functional-entry-function leaf)))
-		 (delete-lambda leaf))
-		(:external
-		 (delete-lambda leaf))
-		((:deleted :optional))))
-	     (optional-dispatch
-	      (unless (eq (functional-kind leaf) :deleted)
-		(delete-optional-dispatch leaf)))))
-	  ((null (rest refs))
-	   (typecase leaf
-	     (clambda (or (maybe-let-convert leaf)
-			  (maybe-convert-to-assignment leaf)))
-	     (lambda-var (reoptimize-lambda-var leaf))))
-	  (t
-	   (typecase leaf
-	     (clambda (maybe-convert-to-assignment leaf))))))
-
-  (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 Flush-P in the blocks containing uses of Cont
-;;; and set Component-Reoptimize.  If the Prev of the use is deleted, then we
-;;; blow off reoptimization.
-;;;
-;;;    If the continuation is :Deleted, then we don't do anything, since all
-;;; semantics have already been flushed.  :Deleted-Block-Start start
-;;; continuations are treated just like :Block-Start; it is possible that the
-;;; continuation may be given a new dest (e.g. by SUBSTITUTE-CONTINUATION), so
-;;; we don't want to delete it.
-;;;
-(defun flush-dest (cont)
-  (declare (type continuation cont))
-  
-  (unless (eq (continuation-kind cont) :deleted)
-    (assert (continuation-dest cont))
-    (setf (continuation-dest cont) nil)
-    (do-uses (use cont)
-      (let ((prev (node-prev use)))
-	(unless (eq (continuation-kind prev) :deleted)
-	  (let ((block (continuation-block prev)))
-	    (setf (component-reoptimize (block-component block)) t)
-	    (setf (block-attributep (block-flags block) flush-p type-asserted)
-		  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)
-    (setf (component-reanalyze (block-component 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-attributep (block-flags block) flush-p type-asserted) t)
-	  (setf (component-reoptimize (block-component block)) t)))))
-
-  (let ((dest (continuation-dest cont)))
-    (when dest
-      (let ((prev (node-prev dest)))
-	(when (and prev
-		   (not (eq (continuation-kind prev) :deleted)))
-	  (let ((block (continuation-block prev)))
-	    (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.")
-  (note-block-deletion block)
-  (setf (block-delete-p block) t)
-
-  (let* ((last (block-last block))
-	 (cont (node-cont last)))
-    (delete-continuation-use last)
-    (if (eq (continuation-kind cont) :unused)
-	(delete-continuation cont)
-	(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))
-      (cif
-       (flush-dest (if-test node)))
-      ;;
-      ;; The next two cases serve to maintain the invariant that a LET always
-      ;; has a well-formed COMBINATION, REF and BIND.  We delete the lambda
-      ;; whenever we delete any of these, but we must be careful that this LET
-      ;; has not already been partially deleted.
-      (basic-combination
-       (when (and (eq (basic-combination-kind node) :local)
-		  ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
-		  (continuation-use (basic-combination-fun node)))
-	 (let ((fun (combination-lambda node)))
-	   ;; If our REF was the 2'nd to last ref, and has been deleted, then
-	   ;; Fun may be a LET for some other combination.
-	   (when (and (member (functional-kind fun) '(:let :mv-let))
-		      (eq (let-combination fun) node))
-	     (delete-lambda fun))))
-       (flush-dest (basic-combination-fun node))
-       (dolist (arg (basic-combination-args node))
-	 (when arg (flush-dest arg))))
-      (bind
-       (let ((lambda (bind-lambda node)))
-	 (unless (eq (functional-kind lambda) :deleted)
-	   (assert (member (functional-kind lambda)
-			   '(:let :mv-let :assignment)))
-	   (delete-lambda lambda))))
-      (exit
-       (let ((value (exit-value node))
-	     (entry (exit-entry node)))
-	 (when value
-	   (flush-dest value))
-	 (when entry
-	   (setf (entry-exits entry)
-		 (delete node (entry-exits entry))))))
-      (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))
-
-(declaim (end-block))
-
-
-;;; Delete-Return  --  Interface
-;;;
-;;;    Do stuff to indicate that the return node Node is being deleted.  We set
-;;; the RETURN to NIL.
-;;;
-(defun delete-return (node)
-  (declare (type creturn node))
-  (let ((fun (return-lambda node)))
-    (assert (lambda-return fun))
-    (setf (lambda-return fun) nil))
-  (undefined-value))
-
-
-;;; NOTE-UNREFERENCED-VARS  --  Interface
-;;;
-;;;    If any of the Vars in fun were never referenced and was not declared
-;;; IGNORE, then complain.
-;;;
-(defun note-unreferenced-vars (fun)
-  (declare (type clambda fun))
-  (dolist (var (lambda-vars fun))
-    (unless (or (leaf-ever-used var)
-		(lambda-var-ignorep var))
-      (let ((*compiler-error-context* (lambda-bind fun)))
-	(unless (policy *compiler-error-context* (= brevity 3))
-	  (compiler-warning "Variable ~S defined but never used."
-			    (leaf-name var)))
-	(setf (leaf-ever-used var) t))))
-  (undefined-value))
-
-
-(defvar *deletion-ignored-objects* '(t nil))
-
-;;; PRESENT-IN-FORM  --  Internal
-;;;
-;;;    Return true if we can find Obj in Form, NIL otherwise.  We bound our
-;;; recursion so that we don't get lost in circular structures.  We ignore the
-;;; car of forms if they are a symbol (to prevent confusing function
-;;; referencess with variables), and we also ignore anything inside ' or #'.
-;;;
-(defun present-in-form (obj form depth)
-  (declare (type (integer 0 20) depth))
-  (cond ((= depth 20) nil)
-	((eq obj form) t)
-	((atom form) nil)
-	(t
-	 (let ((first (car form))
-	       (depth (1+ depth)))
-	   (if (member first '(quote function))
-	       nil
-	       (or (and (not (symbolp first))
-			(present-in-form obj first depth))
-		   (do ((l (cdr form) (cdr l))
-			(n 0 (1+ n)))
-		       ((or (atom l) (> n 100))
-			nil)
-		     (declare (fixnum n))
-		     (when (present-in-form obj (car l) depth)
-		       (return t)))))))))
-
-
-;;; NOTE-BLOCK-DELETION  --  Internal
-;;;
-;;;    This function is called on a block immediately before we delete it.  We
-;;; check to see if any of the code about to die appeared in the original
-;;; source, and emit a note if so.
-;;;
-;;;    If the block was in a lambda is now deleted, then we ignore the whole
-;;; block, since this case is picked off in DELETE-LAMBDA.  We also ignore
-;;; the deletion of CRETURN nodes, since it is somewhat reasonable for a
-;;; function to not return, and there is a different note for that case anyway.
-;;;
-;;;    If the actual source is an atom, then we use a bunch of heuristics to
-;;; guess whether this reference really appeared in the original source:
-;;; -- If a symbol, it must be interned and not a keyword.
-;;; -- It must not be an easily introduced constant (T or NIL, a fixnum or a
-;;;    character.)
-;;; -- The atom must be "present" in the original source form, and present in
-;;;    all intervening actual source forms.
-;;;
-(defun note-block-deletion (block)
-  (let ((home (block-home-lambda block)))
-    (unless (eq (functional-kind home) :deleted)
-      (do-nodes (node cont block)
-	(let* ((path (node-source-path node))
-	       (first (first path)))
-	  (when (or (eq first 'original-source-start)
-		    (and (atom first)
-			 (or (not (symbolp first))
-			     (let ((pkg (symbol-package first)))
-			       (and pkg
-				    (not (eq pkg (symbol-package :end))))))
-			 (not (member first *deletion-ignored-objects*))
-			 (not (typep first '(or fixnum character)))
-			 (every #'(lambda (x)
-				    (present-in-form first x 0))
-				(source-path-forms path))
-			 (present-in-form first (find-original-source path)
-					  0)))
-	    (unless (return-p node)
-	      (let ((*compiler-error-context* node))
-		(compiler-note "Deleting unreachable code.")))
-	    (return))))))
-  (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))
-		       (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 (block-start-cleanup block)
-			   (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)))
-    (not (and prev
-	      (not (eq (continuation-kind prev) :deleted))
-	      (let ((block (continuation-block prev)))
-		(and (block-component block)
-		     (not (block-delete-p block))))))))
-
-
-;;; DELETE-COMPONENT  --  Interface
-;;;
-;;;    Delete all the blocks and functions in Component.  We scan first marking
-;;; the blocks as delete-p to prevent weird stuff from being triggered by
-;;; deletion.
-;;;
-(defun delete-component (component)
-  (declare (type component component))
-  (assert (null (component-new-functions component)))
-  (setf (component-kind component) :deleted)
-  (do-blocks (block component)
-    (setf (block-delete-p block) t))
-  (dolist (fun (component-lambdas component))
-    (setf (functional-kind fun) nil)
-    (setf (leaf-refs fun) nil)
-    (delete-functional fun))
-  (do-blocks (block component)
-    (delete-block block))
-  (undefined-value))
-  
-
-;;; EXTRACT-FUNCTION-ARGS -- interface
-;;;
-;;; Convert code of the form (foo ... (fun ...) ...) to (foo ... ... ...).
-;;; In other words, replace the function combination fun by it's arguments.
-;;; If there are any problems with doing this, use GIVE-UP to blow out of
-;;; whatever transform called this.  Note, as the number of arguments changes,
-;;; the transform must be prepared to return a lambda with a new lambda-list
-;;; with the correct number of arguments.
-;;; 
-(defun extract-function-args (cont fun num-args)
-  "If CONT is a call to FUN with NUM-ARGS args, change those arguments
-   to feed directly to the continuation-dest of CONT, which must be
-   a combination."
-  (declare (type continuation cont)
-	   (type symbol fun)
-	   (type index num-args))
-  (let ((outside (continuation-dest cont))
-	(inside (continuation-use cont)))
-    (assert (combination-p outside))
-    (unless (combination-p inside)
-      (give-up))
-    (let ((inside-fun (combination-fun inside)))
-      (unless (eq (continuation-function-name inside-fun) fun)
-	(give-up))
-      (let ((inside-args (combination-args inside)))
-	(unless (= (length inside-args) num-args)
-	  (give-up))
-	(let* ((outside-args (combination-args outside))
-	       (arg-position (position cont outside-args))
-	       (before-args (subseq outside-args 0 arg-position))
-	       (after-args (subseq outside-args (1+ arg-position))))
-	  (dolist (arg inside-args)
-	    (setf (continuation-dest arg) outside))
-	  (setf (combination-args inside) nil)
-	  (setf (combination-args outside)
-		(append before-args inside-args after-args))
-	  (change-ref-leaf (continuation-use inside-fun)
-			   (find-free-function 'list "???"))
-	  (setf (combination-kind inside) :full)
-	  (setf (node-derived-type inside) *wild-type*)
-	  (flush-dest cont)
-	  (setf (continuation-asserted-type cont) *wild-type*)
-	  (undefined-value))))))
-
-
-
-;;;; 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)
-    (let ((ltype (leaf-type leaf)))
-      (if (function-type-p ltype)
-	  (setf (node-derived-type ref) ltype)
-	  (derive-node-type ref ltype)))
-    (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))
-
-;;; SUBSTITUTE-LEAF-IF  --  Interface
-;;;
-;;;    Like SUBSITIUTE-LEAF, only there is a predicate on the Ref to tell
-;;; whether to substitute.
-;;;
-(defun substitute-leaf-if (test new-leaf old-leaf)
-  (declare (type leaf new-leaf old-leaf) (type function test))
-  (dolist (ref (leaf-refs old-leaf))
-    (when (funcall test ref)
-      (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.
-;;;
-(declaim (maybe-inline find-constant))
-(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))
-  (let ((entry-cleanup (entry-cleanup entry)))
-    (dolist (nlx (environment-nlx-info (node-environment entry)) nil)
-      (when (and (eq (nlx-info-continuation nlx) cont)
-		 (eq (nlx-info-cleanup nlx) entry-cleanup))
-	(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) clambda))
-(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.)
-;;;
-(declaim (inline external-entry-point-p))
-(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 non-notinline global function reference, then
-;;; return the referenced symbol, otherwise NIL.  If Notinline-OK is true, then
-;;; we don't care if the leaf is notinline.
-;;;
-(defun continuation-function-name (cont &optional notinline-ok)
-  (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)
-		   (or (not (defined-function-p leaf))
-		       (not (eq (defined-function-inlinep leaf) :notinline))
-		       notinline-ok))
-	      (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 (member (functional-kind fun) '(:let :mv-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.
-;;;
-(declaim (inline combination-lambda))
-(defun combination-lambda (call)
-  (declare (type basic-combination call))
-  (assert (eq (basic-combination-kind call) :local))
-  (ref-leaf (continuation-use (basic-combination-fun call))))
-
-
-(defvar *inline-expansion-limit* 50
-  "An upper limit on the number of inline function calls that will be expanded
-   in any given code object (single function or block compilation.)")
-
-
-;;; INLINE-EXPANSION-OK  --  Interface
-;;;
-;;;    Check if Node's component has exceeded its inline expansion limit, and
-;;; warn if so, returning NIL.
-;;;
-(defun inline-expansion-ok (node)
-  (let ((expanded (incf (component-inline-expansions
-			 (block-component
-			  (node-block node))))))
-    (cond ((> expanded *inline-expansion-limit*) nil)
-	  ((= expanded *inline-expansion-limit*)
-	   (let ((*compiler-error-context* node))
-	     (compiler-warning "*Inline-Expansion-Limit* (~D) exceeded, ~
-				probably trying to~%  ~
-				inline a recursive function."
-			       *inline-expansion-limit*))
-	   nil)
-	  (t t))))
-
-
-;;;; Compiler error context determination:
-
-(proclaim '(special *current-path*))
-
-
-;;; 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* *error-print-lines*))
-
-(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.")
-(defvar *error-print-lines* 5
-  "The value for *Print-Lines* when printing compiler error messages.")
-
-(defvar *enclosing-source-cutoff* 1
-  "The maximum number of enclosing non-original source forms (i.e. from
-  macroexpansion) that we print in full.  For additional enclosing forms, we
-  print only the CAR.")
-(proclaim '(type unsigned-byte *enclosing-source-cutoff*))
-
-
-;;; 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.  To this end, we
-;;; convert source forms to strings so that source forms that contain IR1
-;;; references (e.g. %DEFUN) don't hold onto the IR.
-;;;
-(defstruct (compiler-error-context
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore s d))
-	       (format stream "#<Compiler-Error-Context>"))))
-  ;;
-  ;; A list of the stringified CARs of the enclosing non-original source forms
-  ;; exceeding the *enclosing-source-cutoff*.
-  (enclosing-source nil :type list)
-  ;;
-  ;; A list of stringified enclosing non-original source forms.
-  (source nil :type list)
-  ;;
-  ;; The stringified form in the original source that expanded into Source.
-  (original-source (required-argument) :type simple-string)
-  ;;
-  ;; A list of prefixes of "interesting" forms that enclose original-source.
-  (context nil :type list)
-  ;;
-  ;; The FILE-INFO-NAME for the relevant FILE-INFO.
-  (file-name (required-argument)
-	     :type (or simple-string (member :lisp :stream)))
-  ;;
-  ;; The file position at which the top-level form starts, if applicable.
-  (file-position nil :type (or index null))
-  ;;
-  ;; The original source part of the source path.
-  (original-source-path nil :type list))
-  
-  
-;;; 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)
-
-
-;;; Hashtable mapping macro names to source context parsers.  Each parser
-;;; function returns the source-context list for that form.
-;;; 
-(defvar *source-context-methods* (make-hash-table))
-
-;;; DEF-SOURCE-CONTEXT  --  Public
-;;;
-(defmacro def-source-context (name ll &body body)
-  "DEF-SOURCE-CONTEXT Name Lambda-List Form*
-   This macro defines how to extract an abbreviated source context from the
-   Named form when it appears in the compiler input.  Lambda-List is a DEFMACRO
-   style lambda-list used to parse the arguments.  The Body should return a
-   list of subforms suitable for a \"~{~S ~}\" format string."
-  (let ((n-whole (gensym)))
-    `(setf (gethash ',name *source-context-methods*)
-	   #'(lambda (,n-whole)
-	       (destructuring-bind ,ll ,n-whole ,@body)))))
-
-(def-source-context defstruct (name-or-options &rest slots)
-  (declare (ignore slots))
-  `(defstruct ,(if (consp name-or-options)
-		   (car name-or-options)
-		   name-or-options)))
-
-(def-source-context function (thing)
-  (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
-      `(lambda ,(second thing))
-      `(function ,thing)))
-
-#+pcl
-(def-source-context pcl::defmethod (name &rest stuff)
-  (let ((arg-pos (position-if #'listp stuff)))
-    (if arg-pos
-	`(pcl::defmethod ,name ,@(subseq stuff 0 arg-pos)
-	   ,@(nth-value 2 (pcl::parse-specialized-lambda-list
-			   (elt stuff arg-pos))))
-	`(pcl::defmethod ,name "<illegal syntax>"))))
-
-
-;;; SOURCE-FORM-CONTEXT  --  Internal
-;;;
-;;;    Return the first two elements of Form if Form is a list.  Take the car
-;;; of the second form if appropriate.
-;;;
-(defun source-form-context (form)
-  (cond ((atom form) nil)
-	((>= (length form) 2)
-	 (funcall (gethash (first form) *source-context-methods*
-			   #'(lambda (x)
-			       (declare (ignore x))
-			       (list (first form) (second form))))
-		  (rest form)))
-	(t
-	 form)))
-
-
-;;; 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))
-  (let* ((rpath (reverse (source-path-original-source path)))
-	 (tlf (first rpath))
-	 (root (find-source-root tlf *source-info*)))
-    (collect ((context))
-      (let ((form root)
-	    (current (rest rpath)))
-	(loop
-	  (when (atom form)
-	    (assert (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))
-		  (context (source-form-context form))))))
-	  (when (null current) (return))
-	  (setq form (nth (pop current) form)))
-	
-	(cond ((context)
-	       (values form (context)))
-	      ((and path root)
-	       (let ((c (source-form-context root)))
-		 (values form (if c (list c) nil))))
-	      (t
-	       (values '(unable to locate source)
-		       '((some strange place)))))))))
-
-
-;;; STRINGIFY-FORM  --  Internal
-;;;
-;;;    Convert a source form to a string, formatted suitably for use in
-;;; compiler warnings.
-;;;
-(defun stringify-form (form &optional (pretty t))
-  (let ((*print-level* (or *error-print-level* *print-level*))
-	(*print-length* (or *error-print-length* *print-length*))
-	(*print-lines* (or *error-print-lines* *print-lines*))
-	(*print-pretty* pretty))
-    (if pretty
-	(format nil "  ~S~%" form)
-	(prin1-to-string form))))
-
-	  
-;;; FIND-ERROR-CONTEXT  --  Interface
-;;;
-;;;    Return a COMPILER-ERROR-CONTEXT structure describing the current error
-;;; context, or NIL if we can't figure anything out.  Args is a list of things
-;;; that are going to be printed out in the error message, and can thus be
-;;; blown off when they appear in the source context.
-;;;
-(defun find-error-context (args)
-  (let ((context *compiler-error-context*))
-    (if (compiler-error-context-p context)
-	context
-	(let ((path (or *current-path*
-			(if context
-			    (node-source-path context)
-			    nil))))
-	  (when (and *source-info* path)
-	    (multiple-value-bind (form src-context)
-				 (find-original-source path)
-	      (collect ((full nil cons)
-			(short nil cons))
-		(let ((forms (source-path-forms path))
-		      (n 0))
-		  (dolist (src (if (member (first forms) args)
-				   (rest forms)
-				   forms))
-		    (if (>= n *enclosing-source-cutoff*)
-			(short (stringify-form (if (consp src)
-						   (car src)
-						   src)
-					       nil))
-			(full (stringify-form src)))
-		    (incf n)))
-
-		(let* ((tlf (source-path-tlf-number path))
-		       (file (find-file-info tlf *source-info*)))
-		  (make-compiler-error-context
-		   :enclosing-source (short)
-		   :source (full)
-		   :original-source (stringify-form form)
-		   :context src-context
-		   :file-name (file-info-name file)
-		   :file-position
-		   (multiple-value-bind (ignore pos)
-					(find-source-root tlf *source-info*)
-		     (declare (ignore ignore))
-		     pos)
-		   :original-source-path
-		   (source-path-original-source path))))))))))
-
-
-;;;; 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.")))
-
-;;; The stream that compiler error output is directed to.
-;;;
-(defvar *compiler-error-output* (make-synonym-stream '*error-output*))
-(proclaim '(type stream *compiler-error-output*))
-
-;;; We save the context information that we printed out most recently so that
-;;; we don't print it out redundantly.
-
-;;; The last COMPILER-ERROR-CONTEXT that we printed.
-;;;
-(defvar *last-error-context* nil)
-(proclaim '(type (or compiler-error-context null) *last-error-context*))
-
-;;; The format string and args for the last error we printed.
-;;;
-(defvar *last-format-string* nil)
-(defvar *last-format-args* nil)
-(proclaim '(type (or string null) *last-format-string*))
-(proclaim '(type list *last-format-args*))
-
-;;; The number of times that the last error message has been emitted, so that
-;;; we can compress duplicate error messages.
-(defvar *last-message-count* 0)
-(proclaim '(type index *last-message-count*))
-
-(defvar *compiler-notification-function* nil
-  "This is the function called by the compiler to specially note a warning,
-   comment, or error.  The function must take four arguments, the severity
-   a string for context, the file namestring, and the file position.  The
-   severity is one of :note, :warning, or :error.  Except for the severity, all
-   of these can be NIL if unavailable or inapplicable.")
-
-
-;;; COMPILER-NOTIFICATION  --  Internal
-;;;
-;;;    Call any defined notification function.
-;;;
-(defun compiler-notification (severity context)
-  (declare (type (member :note :warning :error) severity)
-	   (type (or compiler-error-context null) context))
-  (when *compiler-notification-function*
-    (if context
-	(let ((*print-level* 2)
-	      (*print-pretty* nil)
-	      (name (compiler-error-context-file-name context)))
-	  (funcall *compiler-notification-function* severity 
-		   (format nil "~{~{~S~^ ~}~^ => ~}"
-			   (compiler-error-context-context context))
-		   (when (stringp name) name)
-		   (compiler-error-context-file-position context)))
-	(funcall *compiler-notification-function* severity nil nil nil)))
-  (undefined-value))
-
-
-;;; 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 (&optional (terpri t))
-  (cond ((= *last-message-count* 1)
-	 (when terpri (terpri *compiler-error-output*)))
-	((> *last-message-count* 1)
-	 (format *compiler-error-output* "[Last message occurs ~D times]~2%"
-		 *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 (type (member :error :warning :note) what) (string format-string)
-	   (list format-args))
-  (let* ((*print-level* (or *error-print-level* *print-level*))
-	 (*print-length* (or *error-print-length* *print-length*))
-	 (*print-lines* (or *error-print-lines* *print-lines*))
-	 (stream *compiler-error-output*)
-	 (context (find-error-context format-args)))
-    (cond
-     (context
-      (let ((file (compiler-error-context-file-name context))
-	    (in (compiler-error-context-context context))
-	    (form (compiler-error-context-original-source context))
-	    (enclosing (compiler-error-context-enclosing-source context))
-	    (source (compiler-error-context-source context))
-	    (last *last-error-context*))
-	(compiler-notification what context)
-
-	(unless (and last
-		     (equal file (compiler-error-context-file-name last)))
-	  (when (stringp file)
-	    (note-message-repeats)
-	    (setq last nil)
-	    (format stream "~2&File: ~A~%" file)))
-	
-	(unless (and last
-		     (equal in (compiler-error-context-context last)))
-	  (note-message-repeats)
-	  (setq last nil)
-	  (format stream "~2&In:~{~<~%   ~4:;~{ ~S~}~>~^ =>~}~%" in))
-	
-	(unless (and last
-		     (string= form
-			      (compiler-error-context-original-source last)))
-	  (note-message-repeats)
-	  (setq last nil)
-	  (write-string form stream))
-	
-	(unless (and last
-		     (equal enclosing
-			    (compiler-error-context-enclosing-source last)))
-	  (when enclosing
-	    (note-message-repeats)
-	    (setq last nil)
-	    (format stream "--> ~{~<~%--> ~1:;~A~> ~}~%" enclosing)))
-	
-	(unless (and last
-		     (equal source (compiler-error-context-source last)))
-	  (setq *last-format-string* nil)
-	  (when source
-	    (note-message-repeats)
-	    (dolist (src source)
-	      (write-line "==>" stream)
-	      (write-string src stream))))))
-     (t
-      (compiler-notification what nil)
-      (note-message-repeats)
-      (setq *last-format-string* nil)
-      (format stream "~2&")))
-
-    (setq *last-error-context* context)
-    
-    (unless (and (equal format-string *last-format-string*)
-		 (tree-equal format-args *last-format-args*))
-      (note-message-repeats nil)
-      (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 index *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)
-  (unless (if *compiler-error-context*
-	      (policy *compiler-error-context* (= brevity 3))
-	      (policy nil (= brevity 3)))
-    (incf *compiler-note-count*)
-    (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)
-  (note-message-repeats)
-  (setq *last-error-context* nil)
-  (apply #'format *compiler-error-output* format-string format-args)
-  (force-output *compiler-error-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)))))
-
-
-;;;; Undefined warnings:
-
-
-(defvar *undefined-warning-limit* 3
-  "If non-null, then an upper limit on the number of unknown function or type
-  warnings that the compiler will print for any given name in a single
-  compilation.  This prevents excessive amounts of output when there really is
-  a missing definition (as opposed to a typo in the use.)")
-
-
-;;; NOTE-UNDEFINED-REFERENCE  --  Interface
-;;;
-;;;    Make an entry in the *UNDEFINED-WARNINGS* describing a reference to Name
-;;; of the specified Kind.  If we have exceeded the warning limit, then just
-;;; increment the count, otherwise note the current error context.
-;;;
-(defun note-undefined-reference (name kind)
-  (unless (policy nil (= brevity 3))
-    (let* ((found (dolist (warn *undefined-warnings* nil)
-		    (when (and (equal (undefined-warning-name warn) name)
-			       (eq (undefined-warning-kind warn) kind))
-		      (return warn))))
-	   (res (or found
-		    (make-undefined-warning :name name :kind kind))))
-      (unless found (push res *undefined-warnings*))
-      (when (or (not *undefined-warning-limit*)
-		(< (undefined-warning-count res) *undefined-warning-limit*))
-	(push (find-error-context (list name))
-	      (undefined-warning-warnings res)))
-      (incf (undefined-warning-count res))))
-  (undefined-value))
-
-
-;;;; 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 ((or symbol 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:
-
-(proclaim '(inline find-in position-in map-in))
-
-;;; 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)
-      (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)
-      (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/life.lisp b/compiler/life.lisp
deleted file mode 100644
index 9ad097ccfd7397642918ef3a91bf27244592d394..0000000000000000000000000000000000000000
--- a/compiler/life.lisp
+++ /dev/null
@@ -1,1132 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/life.lisp,v 1.21 1992/08/14 15:20:19 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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)
-
-    (insert-block-global-conflict new block))
-  (undefined-value))
-
-
-;;; INSERT-BLOCK-GLOBAL-CONFLICT  --  Internal
-;;;
-;;;    Do the actual insertion of the conflict New into Block's global
-;;; conflicts.
-;;; 
-(defun insert-block-global-conflict (new block)
-  (let ((global-num (tn-number (global-conflicts-tn new))))
-    (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 (member kind '(:component :environment :constant))
-	      (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.  Similarly,
-;;; FIND-LOCAL-REFERENCES will set the local conflict bit corresponding to this
-;;; call.
-;;;
-;;;     We also set the Local and Local-Number slots in each TN.  It is
-;;; possible that there are no operands in any given call to this function, but
-;;; there had better be either some more args or more results.
-;;;
-(defun coalesce-more-ltn-numbers (block ops fixed)
-  (declare (type ir2-block block) (type (or tn-ref null) 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)
-	       (declare (type index i)))
-	     (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))
-    (declare (type fixnum counter))
-    (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))
-	      (let ((lose (find-local-references new)))
-		(assert (not lose)))
-	      (init-global-conflict-kind new))))))))
-		     
-  (undefined-value))
-
-
-;;;; Environment TN stuff:
-
-
-;;; SETUP-ENVIRONMENT-TN-CONFLICT  --  Internal
-;;;
-;;;    Add a :LIVE global conflict for TN in 2block if there is none present.
-;;; If Debug-P is false (a :ENVIRONMENT TN), then modify any existing conflict
-;;; to be :LIVE.
-;;;
-(defun setup-environment-tn-conflict (tn 2block debug-p)
-  (declare (type tn tn) (type ir2-block 2block))
-  (let ((block-num (ir2-block-number 2block)))
-    (do ((conf (tn-current-conflict tn) (global-conflicts-tn-next conf))
-	 (prev nil conf))
-	((or (null conf)
-	     (> (ir2-block-number (global-conflicts-block conf)) block-num))
-	 (setf (tn-current-conflict tn) prev)
-	 (add-global-conflict :live tn 2block nil))
-      (when (eq (global-conflicts-block conf) 2block)
-	(unless (or debug-p
-		    (eq (global-conflicts-kind conf) :live))
-	  (setf (global-conflicts-kind conf) :live)
-	  (setf (svref (ir2-block-local-tns 2block)
-		       (global-conflicts-number conf))
-		nil)
-	  (setf (global-conflicts-number conf) nil))
-	(setf (tn-current-conflict tn) conf)
-	(return))))
-  (undefined-value))
-
-
-;;; SETUP-ENVIRONMENT-TN-CONFLICTS  --  Internal
-;;;
-;;;    Iterate over all the blocks in Env, setting up :LIVE conflicts for TN.
-;;; We make the TN global if it isn't already.  The TN must have at least one
-;;; reference.
-;;;
-(defun setup-environment-tn-conflicts (component tn env debug-p)
-  (declare (type component component) (type tn tn) (type environment env))
-  (when (and debug-p
-	     (not (tn-global-conflicts tn))
-	     (tn-local tn))
-    (convert-to-global tn))
-  (setf (tn-current-conflict tn) (tn-global-conflicts tn))
-  (do-blocks-backwards (block component)
-    (when (eq (block-environment block) env)
-      (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))))
-	(do ((b last (ir2-block-prev b)))
-	    ((not (eq (ir2-block-block b) block)))
-	  (setup-environment-tn-conflict tn b debug-p)))))
-  (undefined-value))
-
-  
-;;; SETUP-ENVIRONMENT-LIVE-CONFLICTS  --  Internal
-;;;
-;;;    Iterate over all the environment TNs, adding always-live conflicts as
-;;; appropriate.
-;;;
-(defun setup-environment-live-conflicts (component)
-  (declare (type component component))
-  (dolist (fun (component-lambdas component))
-    (let* ((env (lambda-environment fun))
-	   (2env (environment-info env)))
-      (dolist (tn (ir2-environment-live-tns 2env))
-	(setup-environment-tn-conflicts component tn env nil))
-      (dolist (tn (ir2-environment-debug-live-tns 2env))
-	(setup-environment-tn-conflicts component tn env t))))
-  (undefined-value))
-
-
-;;; Convert-To-Environment-TN  --  Internal
-;;;
-;;;    Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN.  This
-;;; requires adding :LIVE conflicts to all blocks in TN-ENV.
-;;;
-(defun convert-to-environment-tn (tn tn-env)
-  (declare (type tn tn) (type environment tn-env))
-  (assert (member (tn-kind tn) '(:normal :debug-environment)))
-  (when (eq (tn-kind tn) :debug-environment)
-    (assert (eq (tn-environment tn) tn-env))
-    (let ((2env (environment-info tn-env)))
-      (setf (ir2-environment-debug-live-tns 2env)
-	    (delete tn (ir2-environment-debug-live-tns 2env)))))
-  (setup-environment-tn-conflicts *compile-component* tn tn-env nil)
-  (setf (tn-local tn) nil)
-  (setf (tn-local-number tn) nil)
-  (setf (tn-kind tn) :environment)
-  (setf (tn-environment tn) tn-env)
-  (push tn (ir2-environment-live-tns (environment-info tn-env)))
-  (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-start 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:
-
-;;; 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 live-bits)
-  (declare (type vop vop) (type local-tn-bit-vector live-bits))
-  (let ((live (bit-vector-copy live-bits)))
-    (do ((r (vop-results vop) (tn-ref-across r)))
-	((null r))
-      (let ((tn (tn-ref-tn r)))
-	(ecase (tn-kind tn)
-	  ((:normal :debug-environment)
-	   (setf (sbit live (tn-local-number tn)) 0))
-	  (:environment :component))))
-    live))
-
-
-;;; SAVED-AFTER-READ  --  Internal
-;;;
-;;;    Used to determine whether a :DEBUG-ENVIRONMENT TN should be considered
-;;; live at block end.  We return true if a VOP with non-null SAVE-P appears
-;;; before the first read of TN (hence is seen first in our backward scan.)
-;;; 
-(defun saved-after-read (tn block)
-  (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
-      ((null vop) t)
-    (when (vop-info-save-p (vop-info vop)) (return t))
-    (when (find-in #'tn-ref-across tn (vop-args vop) :key #'tn-ref-tn)
-      (return nil))))
-
-;;; MAKE-DEBUG-ENVIRONMENT-TNS-LIVE  --  Internal
-;;;
-;;; If the block has no successors, or its successor is the component tail,
-;;; then all :DEBUG-ENVIRONMENT TNs are always added, regardless of whether
-;;; they appeared to be live.  This ensures that these TNs are considered to be
-;;; live throughout blocks that read them, but don't have any interesting
-;;; successors (such as a return or tail call.)  In this case, we set the
-;;; corresponding bit in LIVE-IN as well.
-;;;
-(defun make-debug-environment-tns-live (block live-bits live-list)
-  (let* ((1block (ir2-block-block block))
-	 (live-in (ir2-block-live-in block))
-	 (succ (block-succ 1block))
-	 (next (ir2-block-next block)))
-    (when (and next
-	       (not (eq (ir2-block-block next) 1block))
-	       (or (null succ)
-		   (eq (first succ)
-		       (component-tail (block-component 1block)))))
-      (do ((conf (ir2-block-global-tns block)
-		 (global-conflicts-next conf)))
-	  ((null conf))
-	(let* ((tn (global-conflicts-tn conf))
-	       (num (global-conflicts-number conf)))
-	  (when (and num (zerop (sbit live-bits num))
-		     (eq (tn-kind tn) :debug-environment)
-		     (eq (tn-environment tn) (block-environment 1block))
-		     (saved-after-read tn block))
-	    (note-conflicts live-bits live-list tn num)
-	    (setf (sbit live-bits num) 1)
-	    (push-in tn-next* tn live-list)
-	    (setf (sbit live-in num) 1))))))
-  
-  (values live-bits live-list))
-
-
-;;; 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.
-;;;
-;;; If a :MORE result is not live, we effectively fake a read to it.  This is
-;;; part of the action described in ENSURE-RESULTS-LIVE.
-;;;
-;;; At the end, we call MAKE-DEBUG-ENVIRONEMNT-TNS-LIVE to make debug
-;;; environment TNs appear live when appropriate, even when they aren't.
-;;;
-;;; ### 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-in (ir2-block-live-in block))
-	 (ltns (ir2-block-local-tns block))
-	 (live-bits (bit-vector-copy live-in))
-	 (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))
-	    (kind (global-conflicts-kind conf)))
-	(setf (tn-local-number tn) num)
-	(unless (eq kind :live)
-	  (cond ((not (zerop (sbit live-bits num)))
-		 (bit-vector-replace bits live-bits)
-		 (setf (sbit bits num) 0)
-		 (push-in tn-next* tn live-list))
-		((and (eq (svref ltns num) :more)
-		      (eq kind :write))
-		 (note-conflicts live-bits live-list tn num)
-		 (setf (sbit live-bits num) 1)
-		 (push-in tn-next* tn live-list)
-		 (setf (sbit live-in num) 1)))
-
-	  (setf (tn-local-conflicts tn) bits))))
-
-    (make-debug-environment-tns-live block live-bits live-list)))
-
-
-;;; DO-SAVE-P-STUFF  --  Internal
-;;;
-;;;    A function called in Conflict-Analyze-1-Block when we have a VOP with
-;;; SAVE-P true.  We compute the save-set, and if :FORCE-TO-STACK, force all
-;;; the live TNs to be stack environment TNs.
-;;;
-(defun do-save-p-stuff (vop block live-bits)
-  (declare (type vop vop) (type ir2-block block)
-	   (type local-tn-bit-vector live-bits))
-  (let ((ss (compute-save-set vop live-bits)))
-    (setf (vop-save-set vop) ss)
-    (when (eq (vop-info-save-p (vop-info vop)) :force-to-stack)
-      (do-live-tns (tn ss block)
-	(unless (eq (tn-kind tn) :component)
-	  (force-tn-to-stack tn)
-	  (unless (eq (tn-kind tn) :environment)
-	    (convert-to-environment-tn
-	     tn
-	     (block-environment (ir2-block-block block))))))))
-  (undefined-value))
-
-
-(eval-when (compile eval)
-
-;;; Frob-More-TNs  --  Internal
-;;;
-;;;    Used in SCAN-VOP-REFS 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 update Ref to be
-;;; the last :more ref we scanned, so that the main loop will step to the next
-;;; non-more ref.
-;;;
-(defmacro frob-more-tns (action)
-  `(when (eq (svref ltns num) :more)
-     (let ((prev ref))
-       (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)
-	 (setq prev mref))
-       (setq ref prev))))
-
-
-;;; SCAN-VOP-REFS  --  Internal
-;;;
-;;;    	Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs for the
-;;; current VOP.  This macro shamelessly references free variables in C-A-1-B.
-;;;
-(defmacro scan-vop-refs ()
-  '(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)
-	   (frob-more-tns (deletef-in tn-next* live-list mtn))))
-	(t
-	 (assert (not (tn-ref-write-p ref)))
-	 (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)
-	 (frob-more-tns (push-in tn-next* mtn live-list)))))))
-
-
-;;; ENSURE-RESULTS-LIVE  --  Internal
-;;;
-;;;    This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the current
-;;; VOP's results, and make any dead ones live.  This is necessary, since even
-;;; though a result is dead after the VOP, it may be in use for an extended
-;;; period within the VOP (especially if it has :FROM specified.)  During this
-;;; interval, temporaries must be noted to conflict with the result.  More
-;;; results are finessed in COMPUTE-INITIAL-CONFLICTS, so we ignore them here.
-;;;
-(defmacro ensure-results-live ()
-  '(do ((res (vop-results vop) (tn-ref-across res)))
-       ((null res))
-     (let* ((tn (tn-ref-tn res))
-	    (num (tn-local-number tn)))
-       (when (and num (zerop (sbit live-bits num)))
-	 (unless (eq (svref ltns num) :more)
-	   (note-conflicts live-bits live-list tn num)
-	   (setf (sbit live-bits num) 1)
-	   (push-in tn-next* tn live-list))))))
-
-); 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))
-	(when (vop-info-save-p (vop-info vop))
-	  (do-save-p-stuff vop block live-bits))
-	(ensure-results-live)
-	(scan-vop-refs)))))
-
-
-;;; 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)))
-
-
-;;;; Alias TN stuff:
-
-;;; MERGE-ALIAS-BLOCK-CONFLICTS  --  Internal
-;;;
-;;;    Destructively modify Oconf to include the conflict information in Conf.
-;;; 
-(defun merge-alias-block-conflicts (conf oconf)
-  (declare (type global-conflicts conf oconf))
-  (let* ((kind (global-conflicts-kind conf))
-	 (num (global-conflicts-number conf))
-	 (okind (global-conflicts-kind oconf))
-	 (onum (global-conflicts-number oconf))
-	 (block (global-conflicts-block oconf))
-	 (ltns (ir2-block-local-tns block)))
-    (cond
-     ((eq okind :live))
-     ((eq kind :live)
-      (setf (global-conflicts-kind oconf) :live)
-      (setf (svref ltns onum) nil)
-      (setf (global-conflicts-number oconf) nil))
-     (t
-      (unless (eq kind okind)
-	(setf (global-conflicts-kind oconf) :read))
-      ;;
-      ;; Make original conflict with all the local TNs the alias conflicted
-      ;; with.
-      (bit-ior (global-conflicts-conflicts oconf)
-	       (global-conflicts-conflicts conf)
-	       t)
-      (flet ((frob (x)
-	       (unless (zerop (sbit x num))
-		 (setf (sbit x onum) 1))))
-	;;
-	;; Make all the local TNs that conflicted with the alias conflict
-	;; with the original.
-	(dotimes (i (ir2-block-local-tn-count block))
-	  (let ((tn (svref ltns i)))
-	    (when (and tn (not (eq tn :more))
-		       (null (tn-global-conflicts tn)))
-	      (frob (tn-local-conflicts tn)))))
-	;;
-	;; Same for global TNs...
-	(do ((current (ir2-block-global-tns block)
-		      (global-conflicts-next current)))
-	    ((null current))
-	  (unless (eq (global-conflicts-kind current) :live)
-	    (frob (global-conflicts-conflicts current))))
-	;;
-	;; Make the original TN live everywhere that the alias was live.
-	(frob (ir2-block-written block))
-	(frob (ir2-block-live-in block))
-	(frob (ir2-block-live-out block))
-	(do ((vop (ir2-block-start-vop block)
-		  (vop-next vop)))
-	    ((null vop))
-	  (let ((sset (vop-save-set vop)))
-	    (when sset (frob sset)))))))
-    ;;
-    ;; Delete the alias's conflict info.
-    (when num
-      (setf (svref ltns num) nil))
-    (deletef-in global-conflicts-next (ir2-block-global-tns block) conf))
-
-  (undefined-value))
-
-
-;;; CHANGE-GLOBAL-CONFLICTS-TN  --  Internal
-;;;
-;;;    Co-opt Conf to be a conflict for TN.
-;;;
-(defun change-global-conflicts-tn (conf new)
-  (declare (type global-conflicts conf) (type tn new))
-  (setf (global-conflicts-tn conf) new)
-  (let ((ltn-num (global-conflicts-number conf))
-	(block (global-conflicts-block conf)))
-    (deletef-in global-conflicts-next (ir2-block-global-tns block) conf)
-    (setf (global-conflicts-next conf) nil)
-    (insert-block-global-conflict conf block)
-    (when ltn-num
-      (setf (svref (ir2-block-local-tns block) ltn-num) new)))
-  (undefined-value))
-
-
-;;; ENSURE-GLOBAL-TN  --  Internal
-;;;
-;;;    Do CONVERT-TO-GLOBAL on TN if it has no global conflicts.  Copy the
-;;; local conflicts into the global bit vector.
-;;;
-(defun ensure-global-tn (tn)
-  (declare (type tn tn))
-  (cond ((tn-global-conflicts tn))
-	((tn-local tn)
-	 (convert-to-global tn)
-	 (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn))
-		  (tn-local-conflicts tn)
-		  t))
-	(t
-	 (assert (and (null (tn-reads tn)) (null (tn-writes tn))))))
-  (undefined-value))
-
-  
-;;; MERGE-ALIAS-CONFLICTS  --  Internal
-;;;
-;;;    For each :ALIAS TN, destructively merge the conflict info into the
-;;; original TN and replace the uses of the alias.
-;;;
-;;; For any block that uses only the alias TN, just insert that conflict into
-;;; the conflicts for the original TN, changing the LTN map to refer to the
-;;; original TN.  This gives a result indistinguishable from the what there
-;;; would have been if the original TN had always been referenced.  This leaves
-;;; no sign that an alias TN was ever involved.
-;;;
-;;; If a block has references to both the alias and the original TN, then we
-;;; call MERGE-ALIAS-BLOCK-CONFLICTS to combine the conflicts into the original
-;;; conflict.
-;;; 
-(defun merge-alias-conflicts (component)
-  (declare (type component component))
-  (do ((tn (ir2-component-alias-tns (component-info component))
-	   (tn-next tn)))
-      ((null tn))
-    (let ((original (tn-save-tn tn)))
-      (ensure-global-tn tn)
-      (ensure-global-tn original)
-      (let ((conf (tn-global-conflicts tn))
-	    (oconf (tn-global-conflicts original))
-	    (oprev nil))
-	(loop
-	  (unless oconf
-	    (if oprev
-		(setf (global-conflicts-tn-next oprev) conf)
-		(setf (tn-global-conflicts original) conf))
-	    (do ((current conf (global-conflicts-tn-next current)))
-		((null current))
-	      (change-global-conflicts-tn current original))
-	    (return))
-	  (let* ((block (global-conflicts-block conf))
-		 (num (ir2-block-number block))
-		 (onum (ir2-block-number (global-conflicts-block oconf))))
-
-	    (cond ((< onum num)
-		   (shiftf oprev oconf (global-conflicts-tn-next oconf)))
-		  ((> onum num)
-		   (if oprev
-		       (setf (global-conflicts-tn-next oprev) conf)
-		       (setf (tn-global-conflicts original) conf))
-		   (change-global-conflicts-tn conf original)
-		   (shiftf oprev conf (global-conflicts-tn-next conf) oconf))
-		  (t
-		   (merge-alias-block-conflicts conf oconf)
-		   (shiftf oprev oconf (global-conflicts-tn-next oconf))
-		   (setf conf (global-conflicts-tn-next conf)))))
-	  (unless conf (return))))
-
-      (flet ((frob (refs)
-	       (let ((ref refs)
-		     (next nil))
-		 (loop
-		   (unless ref (return))
-		   (setq next (tn-ref-next ref))
-		   (change-tn-ref-tn ref original)
-		   (setq ref next)))))
-	(frob (tn-reads tn))
-	(frob (tn-writes tn)))
-      (setf (tn-global-conflicts tn) nil)))
-
-  (undefined-value))
-
-
-;;; Lifetime-Analyze  --  Interface
-;;;
-;;;
-(defun lifetime-analyze (component)
-  (lifetime-pre-pass component)
-  (setup-environment-live-conflicts component)
-  (lifetime-flow-analysis component)
-  (lifetime-post-pass component)
-  (merge-alias-conflicts 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  --  Interface
-;;;
-;;;    Return true if X and Y are distinct and the lifetimes of X and Y overlap
-;;; at any point.
-;;;
-(defun tns-conflict (x y)
-  (declare (type tn x y))
-  (let ((x-kind (tn-kind x))
-	(y-kind (tn-kind y)))
-    (cond ((eq x y) nil)
-	  ((or (eq x-kind :component) (eq y-kind :component)) t)
-	  ((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/loadbackend.lisp b/compiler/loadbackend.lisp
deleted file mode 100644
index 72d777fca1c4751b0cd9b05883db54d0a9864dc4..0000000000000000000000000000000000000000
--- a/compiler/loadbackend.lisp
+++ /dev/null
@@ -1,70 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/loadbackend.lisp,v 1.7 1992/06/08 21:09:18 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Load the backend of the compiler.
-;;;
-
-(in-package "C")
-
-(load "vm:vm-macs")
-(if (target-featurep :rt)
-    (load "vm:params")
-    (load "vm:parms"))
-(load "vm:objdef")
-(load "vm:interr")
-(load "assem:support")
-(load "vm:macros")
-(when (target-featurep :gengc)
-  (load "vm:vm-utils"))
-(load "vm:utils")
-
-(load "vm:vm")
-(load "vm:insts")
-(unless (target-featurep :rt)
-  (load "vm:primtype"))
-(load "vm:move")
-(load "vm:sap")
-(load "vm:system")
-(load "vm:char")
-(if (target-featurep :rt)
-    (if (target-featurep :afpa)
-	(load "vm:afpa")
-	(load "vm:mc68881"))
-    (load "vm:float"))
-
-(load "vm:memory")
-(load "vm:static-fn")
-(load "vm:arith")
-(load "vm:cell")
-(load "vm:subprim")
-(load "vm:debug")
-(load "vm:c-call")
-(load "vm:print")
-(load "vm:alloc")
-(load "vm:call")
-(load "vm:nlx")
-(load "vm:values")
-(load "vm:array")
-(load "vm:pred")
-(load "vm:type-vops")
-
-(load "assem:assem-rtns")
-
-(load "assem:array")
-(load "assem:arith")
-(unless (target-featurep :gengc)
-  (load "assem:alloc"))
-
-(load "c:pseudo-vops")
-
-(check-move-function-consistency)
diff --git a/compiler/loadcom.lisp b/compiler/loadcom.lisp
deleted file mode 100644
index a159615385b62a6ecbd8f2d44779ae2753135e02..0000000000000000000000000000000000000000
--- a/compiler/loadcom.lisp
+++ /dev/null
@@ -1,78 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/loadcom.lisp,v 1.44 1992/12/13 15:29:59 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Load up the compiler.
-;;;
-(in-package "C")
-
-(load "c:backend")
-(load "c:macros")
-(load "c:sset")
-(load "c:node")
-(load "c:alloc")
-(load "c:ctype")
-(load "c:knownfun")
-(load "c:fndb")
-(load "vm:vm-fndb")
-(load "c:ir1util")
-(load "c:ir1tran")
-(load "c:ir1final")
-(load "c:srctran")
-(load "c:array-tran")
-(load "c:seqtran")
-(load "c:typetran")
-(load "vm:vm-typetran")
-(load "vm:vm-tran")
-(load "c:float-tran")
-(load "c:saptran")
-(load "c:locall")
-(load "c:dfo")
-(load "c:ir1opt")
-;(load "c:loop")
-(load "c:checkgen")
-(load "c:constraint")
-(load "c:envanal")
-(load "c:vop")
-(load "c:tn")
-(load "c:bit-util")
-(load "c:life")
-(load "c:vmdef")
-(load "c:meta-vmdef")
-(load "c:gtn")
-(load "c:ltn")
-(load "c:stack")
-(load "c:control")
-(load "c:entry")
-(load "c:ir2tran")
-(load "vm:vm-ir2tran")
-(load "c:pack")
-(load "c:dyncount")
-(load "c:statcount")
-(load "c:codegen")
-(load "c:main")
-(load "c:disassem")
-(load "c:new-assem")
-(load "assem:assemfile")
-(load "c:aliencomp")
-(load "c:ltv")
-(load "c:debug-dump")
-
-(load "c:dump")
-(load "c:debug")
-(load "c:copyprop")
-(load "c:represent")
-
-(load "c:eval-comp")
-(load "c:eval")
-
-(load "vm:core")
diff --git a/compiler/locall.lisp b/compiler/locall.lisp
deleted file mode 100644
index 56b2f5ed392c353abe997733d34408413d16c217..0000000000000000000000000000000000000000
--- a/compiler/locall.lisp
+++ /dev/null
@@ -1,1058 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/locall.lisp,v 1.39 1992/11/03 07:06:03 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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 change the combination
-;;; to call the correct lambda, mark it as local, and add this link to our call
-;;; graph.  Once a call is local, it is then eligible for let conversion, which
-;;; places the body of the function inline.
-;;;
-;;;    We cannot always do a local call even when we do have the function being
-;;; called.  Calls that cannot be shown to have legal arg counts are not
-;;; converted.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package :c)
-
-
-;;; Propagate-To-Args  --  Interface
-;;;
-;;;    This function propagates information from the variables in the function
-;;; Fun to the actual arguments in Call.  This is also called by the VALUES IR1
-;;; optimizer when it sleazily converts MV-BINDs to LETs.
-;;;
-;;;    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))
-
-
-;;; Merge-Tail-Sets  --  Interface
-;;;
-;;;    This function handles merging the tail sets if Call is potentially
-;;; tail-recursive, and is a call to a function with a different TAIL-SET than
-;;; Call's Fun.  This must be called whenever we alter IR1 so as to place a
-;;; local call in what might be a TR context.  Note that any call which returns
-;;; its value to a RETURN is considered potentially TR, since any implicit
-;;; MV-PROG1 might be optimized away.
-;;;
-;;; We destructively modify the set for the calling function to represent both,
-;;; and then change all the functions in callee's set to reference the first.
-;;; If we do merge, we reoptimize the RETURN-RESULT continuation to cause
-;;; IR1-OPTIMIZE-RETURN to recompute the tail set type.
-;;;
-(defun merge-tail-sets (call &optional (new-fun (combination-lambda call)))
-  (declare (type basic-combination call) (type clambda new-fun))
-  (let ((return (continuation-dest (node-cont call))))
-    (when (return-p return)
-      (let ((call-set (lambda-tail-set (node-home-lambda call)))
-	    (fun-set (lambda-tail-set new-fun)))
-	(unless (eq call-set fun-set)
-	  (let ((funs (tail-set-functions fun-set)))
-	    (dolist (fun funs)
-	      (setf (lambda-tail-set fun) call-set))
-	    (setf (tail-set-functions call-set)
-		  (nconc (tail-set-functions call-set) funs)))
-	  (reoptimize-continuation (return-result return))
-	  t)))))
-
-
-;;; 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, call MERGE-TAIL-SETS, 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.
-;;; Note that the replacement may trigger let conversion or other changes in
-;;; IR1.  We must call MERGE-TAIL-SETS with NEW-FUN before the substitution,
-;;; since after the substitution (and let conversion), the call may no longer
-;;; be recognizable as tail-recursive.
-;;;
-(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 (node-home-lambda call)))
-  (merge-tail-sets call fun)
-  (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 nil (zerop 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 also bind *lexical-environment* to change the
-;;; compilation policy over to the interface policy.
-;;;
-;;;    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* ((*lexical-environment*
-	    (make-lexenv :cookie
-			 (make-interface-cookie *lexical-environment*)))
-	   (res (ir1-convert-lambda (make-xep-lambda fun))))
-      (setf (functional-kind res) :external)
-      (setf (leaf-ever-used res) t)
-      (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
-;;; must be the function for a call, and 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.  We don't try to
-;;; convert calls that are in error (:ERROR kind.)
-;;;
-;;;    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))
-  (let ((refs (leaf-refs fun))
-	(first-time t))
-    (dolist (ref refs)
-      (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))
-
-	       (convert-call-if-possible ref dest)
-	       
-	       (unless (eq (basic-combination-kind dest) :local)
-		 (reference-entry-point ref)))
-	      (t
-	       (reference-entry-point ref))))
-      (setq first-time nil)))
-
-  (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.
-;;; Also, the COMPONENT-NEW-FUNCTIONS may contain all sorts of drivel, since it
-;;; is not updated when we delete functions, etc.  Only COMPONENT-LAMBDAS is
-;;; updated.
-;;;
-;;; COMPONENT-REANALYZE-FUNCTIONS is treated similarly to NEW-FUNCTIONS, but we
-;;; don't add lambdas to the LAMBDAS.
-;;;
-(defun local-call-analyze (component)
-  (declare (type component component))
-  (loop
-    (let* ((new (pop (component-new-functions component)))
-	   (fun (or new (pop (component-reanalyze-functions component)))))
-      (unless fun (return))
-      (let ((kind (functional-kind fun)))
-	(cond ((member kind '(:deleted :let :mv-let :assignment)))
-	      ((and (null (leaf-refs fun)) (eq kind nil)
-		    (not (functional-entry-function fun)))
-	       (delete-functional fun))
-	      (t
-	       (when (and new (lambda-p fun))
-		 (push fun (component-lambdas component)))
-	       (local-call-analyze-1 fun)
-	       (when (lambda-p fun)
-		 (maybe-let-convert fun)))))))
-  
-  (undefined-value))
-
-
-;;; MAYBE-EXPAND-LOCAL-INLINE  --  Internal
-;;;
-;;;    If policy is auspicious, Call is not in an XEP, and we don't seem to be
-;;; in an infinite recursive loop, then change the reference to reference a
-;;; fresh copy.  We return whichever function we decide to reference.
-;;;
-(defun maybe-expand-local-inline (fun ref call)
-  (if (and (policy call (>= speed space) (>= speed cspeed))
-	   (not (eq (functional-kind (node-home-lambda call)) :external))
-	   (inline-expansion-ok call))
-      (with-ir1-environment call
-	(let* ((*lexical-environment* (functional-lexenv fun))
-	       (won nil)
-	       (res (catch 'local-call-lossage
-		      (prog1
-			  (ir1-convert-lambda (functional-inline-expansion fun))
-			(setq won t)))))
-	  (cond (won
-		 (change-ref-leaf ref res)
-		 res)
-		(t
-		 (let ((*compiler-error-context* call))
-		   (compiler-note "Couldn't inline expand because expansion ~
-				   calls this let-converted local function:~
-				   ~%  ~S"
-				  (leaf-name res)))
-		 fun))))
-      fun))
-
-
-;;; 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 is already :Local, we do nothing.  If the call is already scheduled for
-;;; deletion, also do nothing (in addition to saving time, this also avoids
-;;; some problems with optimizing collections of functions that are partially
-;;; deleted.)
-;;;
-;;;    This is called both before and after FIND-INITIAL-DFO runs.  When called
-;;; on a :INITIAL component, we don't care whether the caller and callee are in
-;;; the same component.  Afterward, we must stick with whatever component
-;;; division we have chosen.
-;;;
-;;;    Before attempting to convert a call, we see if the function is supposed
-;;; to be inline expanded.  Call conversion proceeds as before after any
-;;; expansion.
-;;;
-;;;    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* ((block (node-block call))
-	 (component (block-component block))
-	 (original-fun (ref-leaf ref)))
-    (unless (or (member (basic-combination-kind call) '(:local :error))
-		(block-delete-p block)
-		(eq (functional-kind (block-home-lambda block)) :deleted)
-		(not (or (eq (component-kind component) :initial)
-			 (eq (block-component
-			      (node-block
-			       (lambda-bind (main-entry original-fun))))
-			     component))))
-      (let ((fun (if (external-entry-point-p original-fun)
-		     (functional-entry-function original-fun)
-		     original-fun))
-	    (*compiler-error-context* call))
-	
-	(when (and (eq (functional-inlinep fun) :inline)
-		   (rest (leaf-refs original-fun)))
-	  (setq fun (maybe-expand-local-inline fun ref call)))
-	
-	(assert (member (functional-kind fun)
-			'(nil :escape :cleanup :optional)))
-	(cond ((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.
-;;;
-;;; See CONVERT-CALL for additional notes on MERGE-TAIL-SETS, etc.
-;;;
-(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)))))
-      (setf (basic-combination-kind call) :local)
-      (pushnew ep (lambda-calls (node-home-lambda call)))
-      (merge-tail-sets call ep)
-      (change-ref-leaf ref ep)
-      
-      (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 call as :ERROR to remove it from future
-;;; consideration.  If the argcount is O.K. then we just convert it.
-;;;
-(defun convert-lambda-call (ref call fun)
-  (declare (type ref ref) (type combination call) (type clambda 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 (basic-combination-kind call) :error)))))
-
-
-
-;;;; 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 (basic-combination-kind call) :error))
-	  ((<= call-args max-args)
-	   (convert-call ref call
-			 (elt (optional-dispatch-entry-points fun)
-			      (- call-args min-args))))
-	  ((optional-dispatch-more-entry fun)
-	   (convert-more-call ref call fun))
-	  (t
-	   (compiler-warning "Function called with ~R argument~:P, but wants at most ~R."
-			     call-args max-args)
-	   (setf (basic-combination-kind call) :error))))
-  (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.
-;;;
-(defun convert-hairy-fun-entry (ref call entry vars ignores args)
-  (declare (list vars ignores args) (type ref ref) (type combination call)
-	   (type clambda entry))
-  (let ((new-fun
-	 (with-ir1-environment call
-	   (ir1-convert-lambda
-	    `(lambda ,vars
-	       (declare (ignorable . ,ignores))
-	       (%funcall ,entry . ,args))))))
-    (convert-call ref call new-fun)
-    (dolist (ref (leaf-refs entry))
-      (convert-call-if-possible ref (continuation-dest (node-cont ref))))))
-
-
-;;; Convert-More-Call  --  Internal
-;;;
-;;;    Use Convert-Hairy-Fun-Entry to convert a more-arg call to a known
-;;; function 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.
-;;;
-;;;    If there is a rest arg, then we bundle up the args and pass them to
-;;; LIST.
-;;;
-(defun convert-more-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))
-	 (more (nthcdr max args))
-	 (flame (policy call (or (> speed brevity) (> space brevity))))
-	 (loser nil))
-    (collect ((temps)
-	      (more-temps)
-	      (ignores)
-	      (supplied)
-	      (key-vars))
-
-      (dolist (var arglist)
-	(let ((info (lambda-var-arg-info var)))
-	  (when info
-	    (ecase (arg-info-kind info)
-	      (:keyword
-	       (key-vars var))
-	      ((:rest :optional))))))
-
-      (dotimes (i max)
-	(temps (gensym "FIXED-ARG-TEMP-")))
-
-      (dotimes (i (length more))
-	(more-temps (gensym "MORE-ARG-TEMP-")))
-
-      (when (optional-dispatch-keyp fun)
-	(when (oddp (length more))
-	  (compiler-warning "Function called with odd number of ~
-	  		     arguments in keyword portion.")
-
-	  (setf (basic-combination-kind call) :error)
-	  (return-from convert-more-call))
-
-	(do ((key more (cddr key))
-	     (temp (more-temps) (cddr temp)))
-	    ((null key))
-	  (let ((cont (first key)))
-	    (unless (constant-continuation-p cont)
-	      (when flame
-		(compiler-note "Non-constant keyword in keyword call."))
-	      (setf (basic-combination-kind call) :error)
-	      (return-from convert-more-call))
-	    
-	    (let ((name (continuation-value cont))
-		  (dummy (first temp))
-		  (val (second temp)))
-	      (dolist (var (key-vars)
-			   (progn
-			     (ignores dummy val)
-			     (setq loser name)))
-		(let ((info (lambda-var-arg-info var)))
-		  (when (eq (arg-info-keyword info) name)
-		    (ignores dummy)
-		    (supplied (cons var val))
-		    (return)))))))
-	
-	(when (and loser (not (optional-dispatch-allowp fun)))
-	  (compiler-warning "Function called with unknown argument keyword ~S."
-			    loser)
-	  (setf (basic-combination-kind call) :error)
-	  (return-from convert-more-call)))
-
-      (collect ((call-args))
-	(do ((var arglist (cdr var))
-	     (temp (temps) (cdr temp)))
-	    (())
-	  (let ((info (lambda-var-arg-info (car var))))
-	    (if info
-		(ecase (arg-info-kind info)
-		  (:optional
-		   (call-args (car temp))
-		   (when (arg-info-supplied-p info)
-		     (call-args t)))
-		  (:rest
-		   (call-args `(list ,@(more-temps)))
-		   (return))
-		  (:keyword
-		   (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)
-				 (append (temps) (more-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.
-
-
-;;; Insert-Let-Body  --  Internal
-;;;
-;;;    Set up the control transfer to the called lambda.  We split the call
-;;; block immediately after the call, and link the head of Fun to the call
-;;; block.  The successor block after splitting (where we return to) is
-;;; returned.
-;;;
-;;;    If the lambda is is a different component than the call, then we call
-;;; JOIN-COMPONENTS.  This only happens in block compilation before
-;;; FIND-INITIAL-DFO.
-;;;
-(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 ((fun-component (block-component bind-block)))
-      (unless (eq fun-component component)
-	(assert (eq (component-kind component) :initial))
-	(join-components component fun-component)))
-
-    (let ((*current-component* component))
-      (node-ends-block call))
-    (assert (= (length (block-succ call-block)) 1))
-    (let ((next-block (first (block-succ call-block))))
-      (unlink-blocks call-block next-block)
-      (link-blocks call-block bind-block)
-      next-block)))
-
-
-;;; Merge-Lets  --  Internal
-;;;
-;;;    Handle the environment semantics of let conversion.  We add the lambda
-;;; and its lets to lets for the Call's 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.
-;;;
-;;;   We also unlink the function head from the component head and set
-;;; Component-Reanalyze to true to indicate that the DFO should be recomputed.
-;;;
-(defun merge-lets (fun call)
-  (declare (type clambda fun) (type basic-combination call))
-  (let ((component (block-component (node-block call))))
-    (unlink-blocks (component-head component) (node-block (lambda-bind fun)))
-    (setf (component-lambdas component)
-	  (delete fun (component-lambdas component)))
-    (setf (component-reanalyze component) t))
-  (setf (lambda-call-lexenv fun) (node-lexenv call))
-  (let ((tails (lambda-tail-set fun)))
-    (setf (tail-set-functions tails)
-	  (delete fun (tail-set-functions tails))))
-  (setf (lambda-tail-set fun) nil)
-  (let* ((home (node-home-lambda call))
-	 (home-env (lambda-environment home)))
-    (push fun (lambda-lets home))
-    (setf (lambda-home fun) home)
-    (setf (lambda-environment fun) home-env)
-    
-    (let ((lets (lambda-lets fun)))
-      (dolist (let lets)
-	(setf (lambda-home let) home)
-	(setf (lambda-environment let) home-env))
-
-      (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))
-
-
-;;; Move-Return-Uses  --  Internal
-;;;
-;;;    Handle the value semantics of let conversion.  Delete Fun's return node,
-;;; and change the control flow to transfer to Next-Block instead.  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.
-;;;
-;;;    We also intersect the derived type of the call with the derived type of
-;;; all the dummy continuation's uses.  This serves mainly to propagate
-;;; TRULY-THE through lets.
-;;;
-(defun move-return-uses (fun call next-block)
-  (declare (type clambda fun) (type basic-combination call)
-	   (type cblock next-block))
-  (let* ((return (lambda-return fun))
-	 (return-block (node-block return)))
-    (unlink-blocks return-block
-		   (component-tail (block-component return-block)))
-    (link-blocks return-block next-block)
-    (unlink-node return)
-    (delete-return return)
-    (let ((result (return-result return))
-	  (cont (node-cont call))
-	  (call-type (node-derived-type call)))
-      (when (eq (continuation-use cont) call)
-	(assert-continuation-type cont (continuation-asserted-type result)))
-      (unless (eq call-type *wild-type*)
-	(do-uses (use result)
-	  (derive-node-type use call-type)))
-      (substitute-continuation-uses cont result)))
-  (undefined-value))
-
-
-
-;;; MOVE-LET-CALL-CONT  --  Internal
-;;;
-;;;    Change all Cont for all the calls to Fun to be the start continuation
-;;; for the bind node.  This allows the blocks to be joined if the caller count
-;;; ever goes to one.
-;;;
-(defun move-let-call-cont (fun)
-  (declare (type clambda fun))
-  (let ((new-cont (node-prev (lambda-bind fun))))
-    (dolist (ref (leaf-refs fun))
-      (let ((dest (continuation-dest (node-cont ref))))
-	(delete-continuation-use dest)
-	(add-continuation-use dest new-cont))))
-  (undefined-value))
-
-
-;;; Unconvert-Tail-Calls  --  Internal
-;;;
-;;;    We are converting Fun to be a let when the call is in a non-tail
-;;; position.  Any previously tail calls in Fun are no longer tail calls, and
-;;; must be restored to normal calls which transfer to Next-Block (Fun's
-;;; return point.)  We can't do this by DO-USES on the RETURN-RESULT, because
-;;; the return might have been deleted (if all calls were TR.)
-;;;
-;;;    The called function might be an assignment in the case where we are
-;;; currently converting that function.  In steady-state, assignments never
-;;; appear in the lambda-calls.
-;;;
-(defun unconvert-tail-calls (fun call next-block)
-  (dolist (called (lambda-calls fun))
-    (dolist (ref (leaf-refs called))
-      (let ((this-call (continuation-dest (node-cont ref))))
-	(when (and (node-tail-p this-call)
-		   (eq (node-home-lambda this-call) fun))
-	  (setf (node-tail-p this-call) nil)
-	  (ecase (functional-kind called)
-	    ((nil :cleanup :optional)
-	     (let ((block (node-block this-call)))
-	       (unlink-blocks block (first (block-succ block)))
-	       (link-blocks block next-block)
-	       (delete-continuation-use this-call)
-	       (add-continuation-use this-call (node-cont call))))
-	    (:assignment
-	     (assert (eq called fun))))))))
-  (undefined-value))
-
-
-;;; MOVE-RETURN-STUFF  --  Internal
-;;;
-;;;    Deal with returning from a let or assignment that we are converting.
-;;; FUN is the function we are calling, CALL is a call to FUN, and NEXT-BLOCK
-;;; is the return point for a non-tail call, or NULL if call is a tail call.
-;;;
-;;; If the call is not a tail call, then we must do UNCONVERT-TAIL-CALLS, since
-;;; a tail call is a call which returns its value out of the enclosing non-let
-;;; function.  When call is non-TR, we must convert it back to an ordinary
-;;; local call, since the value must be delivered to the receiver of CALL's
-;;; value.
-;;;
-;;; We do different things depending on whether the caller and callee have
-;;; returns left:
-;;; -- If the callee has no return we just do MOVE-LET-CALL-CONT.  Either the
-;;;    function doesn't return, or all returns are via tail-recursive local
-;;;    calls.
-;;; -- If CALL is a non-tail call, or if both have returns, then we
-;;;    delete the callee's return, move its uses to the call's result
-;;;    continuation, and transfer control to the appropriate return point.
-;;; -- If the callee has a return, but the caller doesn't, then we move the
-;;;    return to the caller.
-;;;
-(defun move-return-stuff (fun call next-block)
-  (declare (type clambda fun) (type basic-combination call)
-	   (type (or cblock null) next-block))
-  (when next-block
-    (unconvert-tail-calls fun call next-block))
-  (let* ((return (lambda-return fun))
-	 (call-fun (node-home-lambda call))
-	 (call-return (lambda-return call-fun)))
-    (cond ((not return))
-	  ((or next-block call-return)
-	   (unless (block-delete-p (node-block return))
-	     (move-return-uses fun call
-			       (or next-block (node-block call-return)))))
-	  (t
-	   (assert (node-tail-p call))
-	   (setf (lambda-return call-fun) return)
-	   (setf (return-lambda return) call-fun))))
-  (move-let-call-cont fun)
-  (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.  We blow away any entry for
-;;; the function in *free-functions* so that nobody will create new reference
-;;; to it.
-;;;
-(defun let-convert (fun call)
-  (declare (type clambda fun) (type basic-combination call))
-  (let ((next-block (if (node-tail-p call)
-			nil
-			(insert-let-body fun call))))
-    (move-return-stuff fun call next-block)
-    (merge-lets fun call)))
-
-
-;;; REOPTIMIZE-CALL  --  Internal
-;;;
-;;;    Reoptimize all of Call's args and its result.
-;;;
-(defun reoptimize-call (call)
-  (declare (type basic-combination call))
-  (dolist (arg (basic-combination-args call))
-    (when arg
-      (reoptimize-continuation arg)))
-  (reoptimize-continuation (node-cont call))
-  (undefined-value))
-
-;;;  OK-INITIAL-CONVERT-P  --  Internal
-;;;
-;;; We also don't convert calls to named functions which appear in the initial
-;;; component, delaying this until optimization.  This minimizes the likelyhood
-;;; that we well let-convert a function which may have references added due to
-;;; later local inline expansion
-;;;
-(defun ok-initial-convert-p (fun)
-  (not (and (leaf-name fun)
-	    (eq (component-kind
-		 (block-component
-		  (node-block (lambda-bind fun))))
-		:initial))))
-
-
-;;; 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.  We return true if we
-;;; converted.
-;;;
-;;;    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.  The
-;;; :ASSIGNMENT function kind provides another way to optimize calls to
-;;; single-return/multiple call functions.
-;;;
-;;;    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.  Also, see OK-INITIAL-CONVERT-P.
-;;;
-(defun maybe-let-convert (fun)
-  (declare (type clambda fun))
-  (let ((refs (leaf-refs fun)))
-    (when (and refs (null (rest refs))
-	       (member (functional-kind fun) '(nil :assignment))
-	       (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)
-		   (not (block-delete-p (node-block dest)))
-		   (cond ((ok-initial-convert-p fun) t)
-			 (t
-			  (reoptimize-continuation ref-cont)
-			  nil)))
-	  (unless (eq (functional-kind fun) :assignment)
-	    (let-convert fun dest))
-	  (reoptimize-call dest)
-	  (setf (functional-kind fun)
-		(if (mv-combination-p dest) :mv-let :let))))
-      t)))
-
-
-;;;; Tail local calls and assignments:
-
-;;; ONLY-HARMLESS-CLEANUPS  --  Internal
-;;;
-;;;    Return T if there are no cleanups between Block1 and Block2, or if they
-;;; definitely won't generate any cleanup code.  Currently we recognize lexical
-;;; entry points that are only used locally (if at all).
-;;;
-(defun only-harmless-cleanups (block1 block2)
-  (declare (type cblock block1 block2))
-  (or (eq block1 block2)
-      (let ((cleanup2 (block-start-cleanup block2)))
-	(do ((cleanup (block-end-cleanup block1)
-		      (node-enclosing-cleanup (cleanup-mess-up cleanup))))
-	    ((eq cleanup cleanup2) t)
-	  (case (cleanup-kind cleanup)
-	    ((:block :tagbody)
-	     (unless (null (entry-exits (cleanup-mess-up cleanup)))
-	       (return nil)))
-	    (t (return nil)))))))
-
-
-;;; MAYBE-CONVERT-TAIL-LOCAL-CALL  --  Interface
-;;;
-;;;    If a potentially TR local call really is TR, then convert it to jump
-;;; directly to the called function.  We also call MAYBE-CONVERT-TO-ASSIGNMENT.
-;;; The first value is true if we tail-convert.  The second is the value of
-;;; M-C-T-A.  We can switch the succesor (potentially deleting the RETURN node)
-;;; unless:
-;;; -- The call has already been converted.
-;;; -- The call isn't TR (random implicit MV PROG1.)
-;;; -- The call is in an XEP (thus we might decide to make it non-tail so that
-;;;    we can use known return inside the component.)
-;;; -- There is a change in the cleanup between the call in the return, so we
-;;;    might need to introduce cleanup code.
-;;;
-(defun maybe-convert-tail-local-call (call)
-  (declare (type combination call))
-  (let ((return (continuation-dest (node-cont call))))
-    (assert (return-p return))
-    (when (and (not (node-tail-p call))
-	       (immediately-used-p (return-result return) call)
-	       (not (eq (functional-kind (node-home-lambda call))
-			:external))
-	       (only-harmless-cleanups (node-block call)
-				       (node-block return)))
-      (node-ends-block call)
-      (let ((block (node-block call))
-	    (fun (combination-lambda call)))
-	(setf (node-tail-p call) t)
-	(unlink-blocks block (first (block-succ block)))
-	(link-blocks block (node-block (lambda-bind fun)))
-	(values t (maybe-convert-to-assignment fun))))))
-
-
-;;; MAYBE-CONVERT-TO-ASSIGNMENT  --  Interface
-;;;
-;;;    Called when we believe it might make sense to convert Fun to an
-;;; assignment.  All this function really does is determine when a function
-;;; with more than one call can still be combined with the calling function's
-;;; environment.  We can convert when:
-;;; -- The function is a normal, non-entry function, and
-;;; -- Except for one call, all calls must be tail recursive calls in the
-;;;    called function (i.e. are self-recursive tail calls)
-;;; -- OK-INITIAL-CONVERT-P is true.
-;;;
-;;;    There may be one outside call, and it need not be tail-recursive.  Since
-;;; all tail local calls have already been converted to direct transfers, the
-;;; only control semantics needed are to splice in the body at the non-tail
-;;; call.  If there is no non-tail call, then we need only merge the
-;;; environments.  Both cases are handled by LET-CONVERT.
-;;;
-;;; ### It would actually be possible to allow any number of outside calls as
-;;; long as they all return to the same place (i.e. have the same conceptual
-;;; continuation.)  A special case of this would be when all of the outside
-;;; calls are tail recursive.
-;;;
-(defun maybe-convert-to-assignment (fun)
-  (declare (type clambda fun))
-  (when (and (not (functional-kind fun))
-	     (not (functional-entry-function fun)))
-    (let ((non-tail nil)
-	  (call-fun nil))
-      (when (and (dolist (ref (leaf-refs fun) t)
-		   (let ((dest (continuation-dest (node-cont ref))))
-		     (when (block-delete-p (node-block dest)) (return nil))
-		     (let ((home (node-home-lambda ref)))
-		       (unless (eq home fun)
-			 (when call-fun (return nil))
-			 (setq call-fun home))
-		       (unless (node-tail-p dest)
-			 (when (or non-tail (eq home fun)) (return nil))
-			 (setq non-tail dest)))))
-		 (ok-initial-convert-p fun))
-	(setf (functional-kind fun) :assignment)
-	(let-convert fun (or non-tail
-			     (continuation-dest
-			      (node-cont (first (leaf-refs fun))))))
-	(when non-tail (reoptimize-call non-tail))
-	t))))
diff --git a/compiler/ltn.lisp b/compiler/ltn.lisp
deleted file mode 100644
index 2515ab672f4367177182412fb1904f7f0b8b0376..0000000000000000000000000000000000000000
--- a/compiler/ltn.lisp
+++ /dev/null
@@ -1,1105 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ltn.lisp,v 1.34 1992/12/16 13:32:33 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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")
-(in-package "EXTENSIONS")
-(export '(*efficiency-note-limit* *efficiency-note-cost-threshold*))
-(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 (lexenv-cookie (node-lexenv node)))
-	 (safety (cookie-safety cookie))
-	 (space (max (cookie-space cookie)
-		     (cookie-cspeed cookie)))
-	 (speed (cookie-speed cookie)))
-    (if (zerop safety)
-	(if (>= speed space) :fast :small)
-	(if (>= speed space) :fast-safe :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)))
-
-
-;;; LEGAL-IMMEDIATE-CONSTANT-P  --  Interface
-;;;
-;;;    Return true if a constant Leaf is of a type which we can legally
-;;; directly reference in code.  Named constants with arbitrary pointer values
-;;; cannot, since we must preserve EQLness.
-;;;
-(defun legal-immediate-constant-p (leaf)
-  (declare (type constant leaf))
-  (or (null (leaf-name leaf))
-      (typecase (constant-value leaf)
-	((or number character) t)
-	(symbol (symbol-package (constant-value leaf)))
-	(t nil))))
-
-
-;;; 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.
-;;;
-(defun continuation-delayed-leaf (cont)
-  (declare (type continuation cont)) 
-  (let ((use (continuation-use cont)))
-    (and (ref-p use)
-	 (let ((leaf (ref-leaf use)))
-	   (etypecase leaf
-	     (lambda-var (if (null (lambda-var-sets leaf)) leaf nil))
-	     (constant (if (legal-immediate-constant-p leaf) leaf nil))
-	     ((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.  If the continuation has a type check, we make the TN
-;;; according to the proven type to ensure that the possibly erroneous value
-;;; can be represented.
-;;;
-(defun annotate-1-value-continuation (cont)
-  (declare (type continuation cont))
-  (let ((info (continuation-info cont)))
-    (assert (eq (ir2-continuation-kind info) :fixed))
-    (cond
-     ((continuation-delayed-leaf cont)
-      (setf (ir2-continuation-kind info) :delayed))
-     ((member (continuation-type-check cont) '(:deleted nil))
-      (setf (ir2-continuation-locs info)
-	    (list (make-normal-tn (ir2-continuation-primitive-type info)))))
-     (t
-      (setf (ir2-continuation-locs info)
-	    (list (make-normal-tn
-		   (primitive-type
-		    (single-value-type (continuation-proven-type cont)))))))))
-  (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)
-    (unless (policy-safe-p policy) (flush-type-check cont))
-    (annotate-1-value-continuation cont))
-  (undefined-value))
-
-
-;;; Annotate-Function-Continuation  --  Internal
-;;;
-;;;    Annotate the function continuation for a full call.  If the only
-;;; reference is to a global 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.
-;;;
-(defun annotate-function-continuation (cont policy &optional (delay t))
-  (declare (type continuation cont) (type policies policy))
-  (unless (policy-safe-p policy) (flush-type-check cont))
-  (let* ((ptype (primitive-type (continuation-type cont)))
-	 (tn-ptype (if (member (continuation-type-check cont) '(:deleted nil))
-		       ptype
-		       (primitive-type
-			(single-value-type
-			 (continuation-proven-type cont)))))
-	 (info (make-ir2-continuation ptype)))
-    (setf (continuation-info cont) info)
-    (let ((name (continuation-function-name cont t)))
-      (if (and delay name)
-	  (setf (ir2-continuation-kind info) :delayed)
-	  (setf (ir2-continuation-locs info)
-		(list (make-normal-tn tn-ptype))))))
-  (undefined-value))
-
-
-;;; FLUSH-FULL-CALL-TAIL-TRANSFER  --  Internal
-;;;
-;;;    If TAIL-P is true, then we check to see if the call can really be a tail
-;;; call by seeing if this function's return convention is :UNKNOWN.  If so, we
-;;; move the call block succssor link from the return block to the component
-;;; tail (after ensuring that they are in separate blocks.)  This allows the
-;;; return to be deleted when there are no non-tail uses.
-;;;
-(defun flush-full-call-tail-transfer (call)
-  (declare (type basic-combination call))
-  (let ((tails (and (node-tail-p call)
-		    (lambda-tail-set (node-home-lambda call)))))
-    (when tails
-      (cond ((eq (return-info-kind (tail-set-info tails)) :unknown)
-	     (node-ends-block call)
-	     (let ((block (node-block call)))
-	       (unlink-blocks block (first (block-succ block)))
-	       (link-blocks block (component-tail (block-component block)))))
-	    (t
-	     (setf (node-tail-p call) nil)))))
-  (undefined-value))
-
-
-;;; LTN-Default-Call  --  Internal
-;;;
-;;;    Set up stuff to do a full call for Call.  We always flush arg type
-;;; checks, but do it after annotation when the policy is safe, since we don't
-;;; want to choose the TNs according to a type assertions that may not hold.
-;;;
-;;;    We set the kind to :FULL or :FUNNY, depending on whether there is an
-;;; IR2-CONVERT method.  If a funny function, then we inhibit tail recursion,
-;;; since the IR2 convert method is going to want to deliver values normally.
-;;;
-(defun ltn-default-call (call policy)
-  (declare (type combination call) (type policies policy))
-  (annotate-function-continuation (basic-combination-fun call) policy)
-
-  (let ((safe-p (policy-safe-p policy)))
-    (dolist (arg (basic-combination-args call))
-      (unless safe-p (flush-type-check arg))
-      (unless (continuation-info arg)
-	(setf (continuation-info arg)
-	      (make-ir2-continuation
-	       (primitive-type
-		(continuation-type arg)))))
-      (annotate-1-value-continuation arg)
-      (when safe-p (flush-type-check arg))))
-
-  (let ((kind (basic-combination-kind call)))
-    (cond ((and (function-info-p kind)
-		(function-info-ir2-convert kind))
-	   (setf (basic-combination-info call) :funny)
-	   (setf (node-tail-p call) nil))
-	  (t
-	   (when (eq kind :error)
-	     (setf (basic-combination-kind call) :full))
-	   (setf (basic-combination-info call) :full)
-	   (flush-full-call-tail-transfer call))))
-  
-  (undefined-value))
-
-;;; Annotate-Funny-Call -- Internal.
-;;;
-;;; Annotate the call as ``funny.''  In other words, mark it as funny,
-;;; flush tail-call-ness, and mark all arg continuations as ordinary.
-;;;
-(defun annotate-funny-call (call policy)
-  (setf (basic-combination-info call) :funny)
-  (setf (node-tail-p call) nil)
-  (dolist (arg (basic-combination-args call))
-    (annotate-ordinary-continuation arg policy)))
-
-;;; 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, of the
-;;; specified primitive Types.  If the continuation has a type check, we
-;;; annotate for the number of values indicated by Types, but only use proven
-;;; type information.
-;;;
-(defun annotate-fixed-values-continuation (cont policy types)
-  (declare (type continuation cont) (type policies policy) (list types))
-  (unless (policy-safe-p policy) (flush-type-check cont))
-
-  (let ((res (make-ir2-continuation nil)))
-    (if (member (continuation-type-check cont) '(:deleted nil))
-	(setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
-	(let* ((proven (mapcar #'(lambda (x)
-				   (make-normal-tn (primitive-type x)))
-			       (values-types
-				(continuation-proven-type cont))))
-	       (num-proven (length proven))
-	       (num-types (length types)))
-	  (setf (ir2-continuation-locs res)
-		(cond
-		 ((< num-proven num-types)
-		  (append proven
-			  (make-n-tns (- num-types num-proven)
-				      (backend-any-primitive-type *backend*))))
-		 ((> num-proven num-types)
-		  (subseq proven 0 num-types))
-		 (t
-		  proven)))))
-    (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 the tail-set has a fixed values count, then use that many values.
-;;; -- If the actual uses of the result continuation in this function have a
-;;;    fixed number of values (after intersection with the assertion), then use
-;;;    that number.  We throw out TAIL-P :FULL and :LOCAL calls, since we know
-;;;    they will truly end up as TR calls.  We can use the
-;;;    BASIC-COMBINATION-INFO even though it is assigned by this phase, since
-;;;    the initial value NIL doesn't look like a TR call.
-;;;
-;;;    If there are *no* non-tail-call uses, then it falls out that we annotate
-;;;    for one value (type is NIL), but the return will end up being deleted.
-;;;
-;;;    In non-perverse code, the DFO walk will reach all uses of the result
-;;;    continuation before it reaches the RETURN.  In perverse code, we may
-;;;    annotate for unknown values when we didn't have to. 
-;;; -- Otherwise, we must annotate the continuation for unknown values.
-;;;
-(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)))
-    (if (eq (return-info-count returns) :unknown)
-	(collect ((res *empty-type* values-type-union))
-	  (do-uses (use (return-result node))
-	    (unless (and (node-tail-p use)
-			 (basic-combination-p use)
-			 (member (basic-combination-info use) '(:local :full)))
-	      (res (node-derived-type use))))
-	  
-	  (let ((int (values-type-intersection
-		      (res)
-		      (continuation-asserted-type cont))))
-	    (multiple-value-bind
-		(types kind)
-		(values-types (if (eq int *empty-type*) (res) int))
-	      (if (eq kind :unknown)
-		  (annotate-unknown-values-continuation cont policy)
-		  (annotate-fixed-values-continuation
-		   cont policy
-		   (mapcar #'primitive-type types))))))
-	(annotate-fixed-values-continuation cont policy types)))
-
-  (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))
-  (setf (basic-combination-kind call) :local)
-  (setf (node-tail-p call) nil)
-  (annotate-fixed-values-continuation
-   (first (basic-combination-args call)) policy
-   (mapcar #'(lambda (var)
-	       (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)
-	   (setf (basic-combination-info call) :funny)
-	   (annotate-ordinary-continuation (first args) policy)
-	   (annotate-unknown-values-continuation (second args) policy)
-	   (setf (node-tail-p call) nil))
-	  (t
-	   (setf (basic-combination-info call) :full)
-	   (annotate-function-continuation (basic-combination-fun call)
-					   policy nil)
-	   (dolist (arg (reverse args))
-	     (annotate-unknown-values-continuation arg policy))
-	   (flush-full-call-tail-transfer call))))
-
-  (undefined-value))
-
-
-;;; LTN-Analyze-Local-Call  --  Internal
-;;;
-;;;    Annotate the arguments as ordinary single-value continuations.  If the
-;;; call is a tail call, make sure that is linked directly to the bind node.
-;;; Usually it will be, but calls from XEPs and calls that might have needed a
-;;; cleanup after them won't have been swung over yet, since we weren't sure
-;;; they would really be TR until now.
-;;;
-(defun ltn-analyze-local-call (call policy)
-  (declare (type combination call)
-	   (type policies policy))
-  (setf (basic-combination-info call) :local)
-
-  (dolist (arg (basic-combination-args call))
-    (when arg
-      (annotate-ordinary-continuation arg policy)))
-
-  (when (node-tail-p call)
-    (let ((caller (node-home-lambda call))
-	  (callee (combination-lambda call)))
-      (assert (eq (lambda-tail-set caller)
-		  (lambda-tail-set (lambda-home callee))))
-      (node-ends-block call)
-      (let ((block (node-block call)))
-	(unlink-blocks block (first (block-succ block)))
-	(link-blocks block (node-block (lambda-bind callee))))))
-  (undefined-value))
-
-
-;;; LTN-Analyze-Set  --  Internal
-;;;
-;;;    Annotate the value continuation.
-;;;
-(defun ltn-analyze-set (node policy)
-  (declare (type cset node) (type policies policy))
-  (setf (node-tail-p node) nil)
-  (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))
-  (setf (node-tail-p node) nil)
-  (let* ((test (if-test node))
-	 (use (continuation-use test)))
-    (unless (and (combination-p use)
-		 (let ((info (basic-combination-info use)))
-		   (and (template-p 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)
-  (setf (node-tail-p node) nil)
-  (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...
-  (setf (basic-combination-info node) :funny)
-  (setf (node-tail-p node) nil)
-  )
-
-
-;;; 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 we 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)
-  (setf (basic-combination-info node) :funny)
-  (setf (node-tail-p node) nil)
-  (annotate-ordinary-continuation struct policy))
-;;;
-(defoptimizer (%slot-setter ltn-annotate) ((struct value) node policy)
-  (setf (basic-combination-info node) :funny)
-  (setf (node-tail-p node) nil)
-  (annotate-ordinary-continuation struct policy)
-  (annotate-ordinary-continuation value policy))
-
-
-;;;; Known call annotation:
-
-;;; OPERAND-RESTRICTION-OK  --  Interface
-;;;
-;;;    Return true if Restr is satisfied by Type.  If T-OK is true, then a T
-;;; restriction allows any operand type.  This is also called by IR2tran when
-;;; it determines whether a result temporary needs to be made, and by
-;;; representation selection when it is deciding which move VOP to use.
-;;; Cont and TN are used to test for constant arguments.
-;;;
-(proclaim '(inline operand-restriction-ok))
-(defun operand-restriction-ok (restr type &key cont tn (t-ok t))
-  (declare (type (or (member *) cons) restr)
-	   (type primitive-type type)
-	   (type (or continuation null) cont)
-	   (type (or tn null) tn))
-  (if (eq restr '*)
-      t
-      (ecase (first restr)
-	(:or
-	 (dolist (mem (rest restr) nil)
-	   (when (or (and t-ok (eq mem (backend-any-primitive-type *backend*)))
-		     (eq mem type))
-	     (return t))))
-	(:constant
-	 (cond (cont
-		(and (constant-continuation-p cont)
-		     (funcall (second restr) (continuation-value cont))))
-	       (tn
-		(and (eq (tn-kind tn) :constant)
-		     (funcall (second restr) (tn-value tn))))
-	       (t
-		(error "Neither CONT nor TN supplied.")))))))
-
-  
-;;; 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)
-	       (t
-		(dolist (arg args t)
-		  (unless (operand-restriction-ok mtype
-						  (continuation-ptype arg))
-		    (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 (operand-restriction-ok type (continuation-ptype arg)
-					:cont arg)
-	  (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 succeed 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 *.  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))
-  (when (template-more-results-type template)
-    (error "~S has :MORE results with :TRANSLATE." (template-name template)))
-  (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 (eq type '*)
-	       (return nil))))
-	(when (null types) (return t))
-	(let ((type (first types)))
-	  (unless (operand-restriction-ok type
-					  (primitive-type (first ltypes)))
-	    (return nil)))))
-     (types
-      (operand-restriction-ok (first types) (primitive-type result-type)))
-     (t t))))
-
-
-;;; IS-OK-TEMPLATE-USE  --  Internal
-;;;
-;;; Return true if Call is an ok use of Template according to Safe-P.  
-;;; -- 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.
-;;; -- If either the template is safe or the policy is unsafe (i.e. we can
-;;;    believe output assertions), then we test against the intersection of the
-;;;    node derived type and the continuation asserted type.  Otherwise, we
-;;;    just use the node type.  If TYPE-CHECK is null, there is no point in
-;;;    doing the intersection, since the node type must be a subtype of the
-;;;    assertion.
-;;;
-;;; If the template is *not* ok, then the second value is a keyword indicating
-;;; which aspect failed.
-;;;
-(defun is-ok-template-use (template call safe-p)
-  (declare (type template template) (type combination call))
-  (let* ((guard (template-guard template))
-	 (cont (node-cont call))
-	 (atype (continuation-asserted-type cont))
-	 (dtype (node-derived-type call)))
-    (cond ((and guard (not (funcall guard)))
-	   (values nil :guard))
-	  ((not (template-args-ok template call safe-p))
-	   (values nil
-		   (if (and safe-p (template-args-ok template call nil))
-		       :arg-check
-		       :arg-types)))
-	  ((eq (template-result-types template) :conditional)
-	   (let ((dest (continuation-dest cont)))
-	     (if (and (if-p dest)
-		      (immediately-used-p (if-test dest) call))
-		 (values t nil)
-		 (values nil :conditional))))
-	  ((template-results-ok
-	    template
-	    (if (and (or (eq (template-policy template) :safe)
-			 (not safe-p))
-		     (continuation-type-check cont))
-		(values-type-intersection dtype atype)
-		dtype))
-	   (values t nil))
-	  (t
-	   (values nil :result-types)))))
-
-
-;;; 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.
-;;;
-;;; We just call IS-OK-TEMPLATE-USE until it returns true.
-;;;
-(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)))
-      (when (is-ok-template-use template call safe-p)
-	(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 find a template with :SAFE policy, then we return it, or any cheaper
-;;; fallback template.  The theory behind this is that if it is cheapest, small
-;;; and safe, we can't lose.  If it is not cheapest, then we use the fallback,
-;;; which won't have the desired policy, but :SAFE isn't desired either, so we
-;;; might as well go with the cheaper one.  The main reason for doing this is
-;;; to make sure that cheap safe templates are used when they apply and the
-;;; current policy is something else.  This is useful because :SAFE has the
-;;; additional semantics of implicit argument type checking, so we may be
-;;; forced to define a template with :SAFE policy when it is really small and
-;;; fast as well.
-;;;
-(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)))
-		  ((eq tpolicy :safe)
-		   (return (values (or fallback template) rejected)))
-		  ((or (not safe-p) (eq tpolicy :fast-safe))
-		   (unless fallback
-		     (setq fallback template))))))))))
-
-
-(defvar *efficiency-note-limit* 2
-  "This is the maximum number of possible optimization alternatives will be
-  mentioned in a particular efficiency note.  NIL means no limit.")
-(proclaim '(type (or index null) *efficiency-note-limit*))
-
-(defvar *efficiency-note-cost-threshold* 5
-  "This is the minumum cost difference between the chosen implementation and
-  the next alternative that justifies an efficiency note.")
-(proclaim '(type index *efficiency-note-cost-threshold*))
-
-
-;;; STRANGE-TEMPLATE-FAILURE  --  Internal
-;;;
-;;;    This function is called by NOTE-REJECTED-TEMPLATES when it can't figure
-;;; out any reason why Template was rejected.  Users should never see these
-;;; messages, but they can happen in situations where the VM definition is
-;;; messed up somehow.
-;;;
-(defun strange-template-failure (template call policy frob)
-  (declare (type template template) (type combination call)
-	   (type policies policy) (type function frob))
-  (funcall frob "This shouldn't happen!  Bug?")
-  (multiple-value-bind (win why)
-		       (is-ok-template-use template call
-					   (policy-safe-p policy))
-    (assert (not win))
-    (ecase why
-      (:guard
-       (funcall frob "Template guard failed."))
-      (:arg-check
-       (funcall frob "Template is not safe, yet we were counting on it."))
-      (:arg-types
-       (funcall frob "Argument types invalid.")
-       (funcall frob "Argument primitive types:~%  ~S"
-		(mapcar #'(lambda (x)
-			    (primitive-type-name
-			     (continuation-ptype x)))
-			(combination-args call)))
-       (funcall frob "Argument type assertions:~%  ~S"
-		(mapcar #'(lambda (x)
-			    (if (atom x)
-				x
-				(ecase (car x)
-				  (:or `(:or .,(mapcar #'primitive-type-name
-						       (cdr x))))
-				  (:constant `(:constant ,(third x))))))
-			(template-arg-types template))))
-      (:conditional
-       (funcall frob "Conditional in a non-conditional context."))
-      (:result-types
-       (funcall frob "Result types invalid.")))))
-
-
-;;; 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))
-	  (verbose-p (policy call (= brevity 0)))
-	  (max-cost (- (template-cost
-			(or template
-			    (template-or-lose 'call-named *backend*)))
-		       *efficiency-note-cost-threshold*)))
-      (dolist (try (function-info-templates (basic-combination-kind call)))
-	(when (> (template-cost try) max-cost) (return))
-	(let ((guard (template-guard try)))
-	  (when (and (or (not guard) (funcall guard))
-		     (or (not safe-p)
-			 (policy-safe-p (template-policy try)))
-		     (or verbose-p
-			 (and (template-note try)
-			      (valid-function-use
-			       call (template-type try)
-			       :argument-test #'types-intersect
-			       :result-test #'values-types-intersect))))
-	    (losers try)))))
-
-    (when (losers)
-      (collect ((messages)
-		(count 0 +))
-	(flet ((frob (string &rest stuff)
-		 (messages string)
-		 (messages stuff)))
-	  (dolist (loser (losers))
-	    (when (and *efficiency-note-limit*
-		       (>= (count) *efficiency-note-limit*))
-	      (frob "etc.")
-	      (return))
-	    (let* ((type (template-type loser))
-		   (valid (valid-function-use call type))
-		   (strict-valid (valid-function-use call type
-						     :strict-result t)))
-	      (frob "Unable to do ~A (cost ~D) because:"
-		    (or (template-note loser) (template-name loser))
-		    (template-cost loser))
-	      (cond
-	       ((and valid strict-valid)
-		(strange-template-failure loser call policy #'frob))
-	       ((not valid)
-		(assert (not (valid-function-use call type
-						 :error-function #'frob
-						 :warning-function #'frob))))
-	       (t
-		(assert (policy-safe-p policy))
-		(frob "Can't trust output type assertion under safe ~
-		       policy.")))
-	      (count 1))))
-
-	(let ((*compiler-error-context* call))
-	  (compiler-note "~{~?~^~&~6T~}"
-			 (if template
-			     `("Forced to do ~A (cost ~D)."
-			       (,(or (template-note template)
-				     (template-name template))
-				,(template-cost template))
-			       . ,(messages))
-			     `("Forced to do full call."
-			       nil
-			       . ,(messages))))))))
-  (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 and result type checks.  Result type
-;;; checks are only flushed when the continuation as a single use.
-;;;
-(defun flush-type-checks-according-to-policy (call policy template)
-  (declare (type combination call) (type policies policy)
-	   (type template template))
-  (let ((safe-op (eq (template-policy template) :safe)))
-    (when (or (not (policy-safe-p policy)) safe-op)
-      (dolist (arg (basic-combination-args call))
-	(flush-type-check arg)))
-    (when safe-op
-      (let ((cont (node-cont call)))
-	(when (eq (continuation-use cont) call)
-	  (flush-type-check cont)))))
-
-  (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))))
-		   (let ((info (basic-combination-kind call)))
-		     (not (or (function-info-ir2-convert info)
-			      (ir1-attributep (function-info-attributes info)
-					      recursive)))))
-	  (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)
-      (setf (node-tail-p call) nil)
-      
-      (flush-type-checks-according-to-policy call policy 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.
-;;;
-;;; Note: we deliberately don't use the DO-NODES macro, since the block can be
-;;; split out from underneath us, and DO-NODES scans past the block end in this
-;;; case.
-;;;
-(defmacro ltn-analyze-block-macro ()
-  '(do* ((node (continuation-next (block-start block))
-	       (continuation-next cont))
-	 (cont (node-cont node) (node-cont node)))
-	(())
-     (unless (eq (node-lexenv node) lexenv)
-       (setq policy (translation-policy node))
-       (setq lexenv (node-lexenv node)))
-	     
-     (etypecase node
-       (ref)
-       (combination
-	(case (basic-combination-kind node)
-	  (:local (ltn-analyze-local-call node policy))
-	  ((:full :error) (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 :error) (ltn-analyze-mv-call node policy)))))
-
-     (when (eq node (block-last block)) (return))))
-
-); 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.
-;;;
-;;;    This is where we allocate IR2 blocks because it is the first place we
-;;; need them.
-;;;
-(defun ltn-analyze (component)
-  (declare (type component component))
-  (let ((2comp (component-info component))
-	(lexenv nil)
-	policy)
-    (do-blocks (block component)
-      (assert (not (block-info block)))
-      (let ((2block (make-ir2-block block)))
-	(setf (block-info block) 2block)
-	(ltn-analyze-block-macro)
-	(let ((popped (ir2-block-popped 2block)))
-	  (when popped
-	    (push block (ir2-component-values-receivers 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 ((lexenv nil)
-	policy)
-    (ltn-analyze-block-macro))
-
-  (assert (not (ir2-block-popped (block-info block))))
-  (undefined-value))
diff --git a/compiler/ltv.lisp b/compiler/ltv.lisp
deleted file mode 100644
index e57d5923ce53cd68e9e4c6c5bd2b6c7760139b86..0000000000000000000000000000000000000000
--- a/compiler/ltv.lisp
+++ /dev/null
@@ -1,60 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ltv.lisp,v 1.1 1991/11/25 12:09:36 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file implements LOAD-TIME-VALUE.
-;;;
-;;; Written by William Lott
-;;;
-(in-package "C")
-
-(in-package "LISP")
-(export 'load-time-value)
-
-(in-package "C")
-
-(defknown %load-time-value (t) t (flushable movable))
-
-(def-ir1-translator load-time-value ((form &optional read-only-p) start cont)
-  "Arrange for FORM to be evaluated at load-time and use the value produced
-   as if it were a constant.  If READ-ONLY-P is non-NIL, then the resultant
-   object is guaranteed to never be modified, so it can be put in read-only
-   storage."
-  (if (producing-fasl-file)
-      (multiple-value-bind
-	  (handle type)
-	  (compile-load-time-value (if read-only-p
-				       form
-				       `(make-value-cell ,form)))
-	(declare (ignore type))
-	(ir1-convert start cont
-		     (if read-only-p
-			 `(%load-time-value ',handle)
-			 `(value-cell-ref (%load-time-value ',handle)))))
-      (let ((value
-	     (handler-case (eval form)
-	       (error (condition)
-		 (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
-				 condition)))))
-	(ir1-convert start cont
-		     (if read-only-p
-			 `',value
-			 `(value-cell-ref ',(make-value-cell value)))))))
-
-
-(defoptimizer (%load-time-value ir2-convert) ((handle) node block)
-  (assert (constant-continuation-p handle))
-  (let ((cont (node-cont node))
-	(tn (make-load-time-value-tn (continuation-value handle)
-				     *universal-type*)))
-    (move-continuation-result node block (list tn) cont)))
-	       
diff --git a/compiler/macros.lisp b/compiler/macros.lisp
deleted file mode 100644
index 3ac4ad2dca58add6e70c81266961d7ed7ccb07f9..0000000000000000000000000000000000000000
--- a/compiler/macros.lisp
+++ /dev/null
@@ -1,1155 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/macros.lisp,v 1.32 1992/09/07 16:04:55 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Random types and macros used in writing the compiler.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package "C")
-
-(export '(lisp::with-compilation-unit) "LISP")
-
-(export '(policy symbolicate def-ir1-translator def-source-transform
-	  def-primitive-translator deftransform defknown defoptimizer
-	  derive-type optimizer ltn-annotate ir2-convert attributes
-	  def-boolean-attribute attributes-union attributes-intersection
-	  attributes=))
-
-(proclaim '(special *wild-type* *universal-type* *compiler-error-context*))
-
-;;;; 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 *lexical-environment*))
-
-(eval-when (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-cookie (gensym))
-	 (binds (mapcar
-		 #'(lambda (name)
-		     (let ((slot (cdr (assoc name policy-parameter-slots))))
-		       `(,name (,slot ,n-cookie))))
-		 (find-used-parameters form))))
-    `(let* ((,n-cookie (lexenv-cookie
-			,(if node
-			     `(node-lexenv ,node)
-			     '*lexical-environment*)))
-	    ,@binds)
-       ,form)))
-
-
-;;;; Source-hacking defining forms:
-
-(eval-when (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)
-
-;;; SPECIAL-FORM-FUNCTION  --  Internal
-;;;
-;;;    This function is stored in the SYMBOL-FUNCTION of special form names so
-;;; that they are FBOUND.
-;;;
-(defun special-form-function (&rest stuff)
-  (declare (ignore stuff))
-  (error "Can't funcall the SYMBOL-FUNCTION of special forms."))
-
-;;; CONVERT-CONDITION-INTO-COMPILER-ERROR  --  Internal
-;;;
-;;; Passed to parse-defmacro when we want compiler errors instead of real
-;;; errors.
-;;;
-(proclaim '(inline convert-condition-into-compiler-error))
-(defun convert-condition-into-compiler-error (datum &rest stuff)
-  (if (stringp datum)
-      (apply #'compiler-error datum stuff)
-      (compiler-error "~A"
-		      (if (symbolp datum)
-			  (apply #'make-condition datum stuff)
-			  datum))))
-
-;;; 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 "special form"
-			      :doc-string-allowed t
-			      :environment n-env
-			      :error-fun 'convert-condition-into-compiler-error)
-      `(progn
-	 (proclaim '(function ,fn-name (continuation continuation t) void))
-	 (defun ,fn-name (,start-var ,cont-var ,n-form)
-	   (let ((,n-env *lexical-environment*))
-	     ,@decls
-	     ,body))
-	 ,@(when doc
-	     `((setf (documentation ',name 'function) ,doc)))
-	 (setf (info function ir1-convert ',name) #',fn-name)
-	 (setf (info function kind ',name) ,kind)
-	 #+new-compiler
-	 ,@(when (eq kind :special-form)
-	     `((setf (symbol-function ',name) #'special-form-function)))))))
-
-
-;;; 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 "form"
-			      :environment n-env
-			      :error-fun `(lambda (&rest stuff)
-					    (declare (ignore stuff))
-					    (return-from ,fn-name
-							 (values nil t))))
-      `(progn
-	 (defun ,fn-name (,n-form)
-	   (let ((,n-env *lexical-environment*))
-	     ,@decls
-	     ,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 "%primitive"
-			      :environment n-env
-			      :error-fun 'convert-condition-into-compiler-error)
-      `(progn
-	 (defun ,fn-name (,n-form)
-	   (let ((,n-env *lexical-environment*))
-	     ,@decls
-	     ,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 (compile load eval)
-
-;;; 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
-					  eval-name important)
-			     &body (body decls doc))
-  "Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*)
-               Declaration* [Doc-String] 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.  The Doc-String is used when printing efficiency notes
-  about the defined transform.
-
-  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.
-    :Eval-Name
-    	    - The name and argument/result types are actually forms to be
-              evaluated.  Useful for getting closures that transform similar
-              functions.
-    :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.
-    :Important
-            - If supplied and non-NIL, note this transform as ``important,''
-              which means effeciency notes will be generated when this
-              transform fails even if brevity=speed (but not if brevity>speed)"
-
-  (when (and eval-name defun-only)
-    (error "Can't specify both DEFUN-ONLY and EVAL-NAME."))
-  (let ((n-args (gensym))
-	(n-node (or node (gensym)))
-	(n-decls (gensym))
-	(n-lambda (gensym))
-	(body `(,@decls ,@body)))
-    (multiple-value-bind (parsed-form vars)
-			 (parse-deftransform
-			  lambda-list
-			  (if policy
-			      `((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 ,@(when doc `(,doc)) ,@stuff)
-	    `(%deftransform
-	      ,(if eval-name name `',name)
-	      ,(if eval-name
-		   ``(function ,,arg-types ,,result-type)
-		   `'(function ,arg-types ,result-type))
-	      #'(lambda ,@stuff)
-	      ,doc
-	      ,(if important t nil)))))))
-
-;;;; 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.
-;;;
-;;; When Restart-P is supplied to DO-NODES, we start iterating over again at
-;;; the beginning of the block when we run into a continuation whose block
-;;; differs from the one we are trying to iterate over, either beacuse the
-;;; block was split, or because a node was deleted out from under us (hence its
-;;; block is NIL.)  If the block start is deleted, we just punt.  With
-;;; Restart-P, we are also more careful about termination, re-indirecting the
-;;; BLOCK-LAST each time.
-;;;
-(defmacro do-nodes ((node-var cont-var block &key restart-p) &body body)
-  "Do-Nodes (Node-Var Cont-Var Block {Key Value}*) {Declaration}* {Form}*
-  Iterate over the nodes in Block, binding Node-Var to the each node and
-  Cont-Var to the node's Cont.  The only keyword option is Restart-P, which
-  causes iteration to be restarted when a node is deleted out from under us (if
-  not supplied, this is an error.)"
-  (let ((n-block (gensym))
-	(n-last-cont (gensym)))
-    `(let* ((,n-block ,block)
-	    ,@(unless restart-p
-		`((,n-last-cont (node-cont (block-last ,n-block))))))
-       (do* ((,node-var (continuation-next (block-start ,n-block))
-			,(if restart-p
-			     `(cond
-			       ((eq (continuation-block ,cont-var) ,n-block)
-				(assert (continuation-next ,cont-var))
-				(continuation-next ,cont-var))
-			       (t
-				(let ((start (block-start ,n-block)))
-				  (unless (eq (continuation-kind start)
-					      :block-start)
-				    (return nil))
-				  (continuation-next start))))
-			     `(continuation-next ,cont-var)))
-	     (,cont-var (node-cont ,node-var) (node-cont ,node-var)))
-	    (())
-	 ,@body
-	 (when ,(if restart-p
-		    `(eq ,node-var (block-last ,n-block))
-		    `(eq ,cont-var ,n-last-cont))
-	   (return nil))))))
-;;;
-(defmacro do-nodes-backwards ((node-var cont-var block) &body body)
-  "Do-Nodes-Backwards (Node-Var Cont-Var Block) {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 nil))))))
-
-
-;;; 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."
-  (let ((n-node (gensym)))
-    `(let* ((,n-node ,node)
-	    (*current-component* (block-component (node-block ,n-node)))
-	    (*lexical-environment* (node-lexenv ,n-node))
-	    (*current-path* (node-source-path ,n-node)))
-       ,@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))
-
-
-;;; LEXENV-FIND  --  Interface
-;;;
-(defmacro lexenv-find (name slot &key test)
-  "LEXENV-FIND Name Slot {Key Value}*
-  Look up Name in the lexical environment namespace designated by Slot,
-  returning the <value, T>, or <NIL, NIL> if no entry.  The :TEST keyword
-  may be used to determine the name equality predicate."
-  (once-only ((n-res `(assoc ,name (,(symbolicate "LEXENV-" slot)
-				    *lexical-environment*)
-			     ,@(when test `(:test ,test)))))
-    `(if ,n-res
-	 (values (cdr ,n-res) t)
-	 (values nil nil))))
-
-
-;;;; 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 &optional t) void)
-		  defprinter-prin1 defprinter-princ))
-(defun defprinter-prin1 (name value stream &optional indent)
-  (declare (ignore indent))
-  (write-string "  " stream)
-  (when *print-pretty*
-    (pprint-newline :linear stream))
-  (princ name stream)
-  (write-string "= " stream)
-  (prin1 value stream))
-;;;
-(defun defprinter-princ (name value stream &optional indent)
-  (declare (ignore indent))
-  (write-string "  " stream)
-  (when *print-pretty*
-    (pprint-newline :linear stream))
-  (princ name stream)
-  (write-string "= " stream)
-  (princ value 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."
-  
-  (flet ((sref (slot) `(,(symbolicate name "-" slot) structure)))
-    (collect ((prints))
-      (dolist (slot slots)
-	(if (atom slot)
-	    (prints `(defprinter-prin1 ',slot ,(sref slot) stream))
-	    (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)))))))
-		  (case (first option)
-		    (:prin1
-		     (stuff `(defprinter-prin1 ',sname ,(second option)
-			       stream)))
-		    (:princ
-		     (stuff `(defprinter-princ ',sname ,(second option)
-			       stream)))
-		    (:test (setq test (second option)))
-		    (t
-		     (error "Losing Defprinter option: ~S."
-			    (first option)))))))))
-	     
-      `(defun ,(symbolicate "%PRINT-" name) (structure stream depth)
-	 (flet ((do-prints (stream)
-		  (declare (ignorable stream))
-		  ,@(prints)))
-	   (cond (*print-readably*
-		  (error "~S cannot be printed readably." structure))
-		 ((and *print-level* (>= depth *print-level*))
-		  (format stream "#<~S ~X>"
-			  ',name
-			  (get-lisp-obj-address structure)))
-		 (*print-pretty*
-		  (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
-		    (pprint-indent :current 2 stream)
-		    (prin1 ',name stream)
-		    (write-char #\space stream)
-		    (let ((*print-base* 16)
-			  (*print-radix* t))
-		      (prin1 (get-lisp-obj-address structure) stream))
-		    (do-prints stream)))
-		 (t
-		  (descend-into (stream)
-		    (format stream "#<~S ~X"
-			    ',name
-			    (get-lisp-obj-address structure))
-		    (do-prints stream)
-		    (format stream ">")))))
-	 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 (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.
-      When set with SETF, updates the place Attributes setting or clearing the
-      specified attributes.
-
-    NAME-attributes attribute-name*
-      Return a set of the named attributes."
-
-  (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS"))
-	(test-name (symbolicate name "-ATTRIBUTEP")))
-    (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 ,test-name (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)))
-
-	 (define-setf-method ,test-name (place &rest attributes
-					       &environment env)
-	   
-	   "Automagically generated boolean attribute setter.  See
-	    Def-Boolean-Attribute."
-	   (multiple-value-bind (temps values stores set get)
-				(get-setf-method place env)
-	     (let ((newval (gensym))
-		   (n-place (gensym))
-		   (mask (compute-attribute-mask attributes ,const-name)))
-	       (values `(,@temps ,n-place)
-		       `(,@values ,get)
-		       `(,newval)
-		       `(let ((,(first stores)
-			       (if ,newval
-				   (logior ,n-place ,mask)
-				   (logand ,n-place ,(lognot mask)))))
-			  ,set
-			  ,newval)
-		       `(,',test-name ,n-place ,@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 (compile load eval)
-
-(defstruct event-info
-  ;;
-  ;; The name of this event.
-  (name (required-argument) :type symbol)
-  ;;
-  ;; The string rescribing this event.
-  (description (required-argument) :type string)
-  ;;
-  ;; The name of the variable we stash this in.
-  (var (required-argument) :type symbol)
-  ;;
-  ;; The number of times this event has happened.
-  (count 0 :type fixnum)
-  ;;
-  ;; The level of significance of this event.
-  (level (required-argument) :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/mips/alloc.lisp b/compiler/mips/alloc.lisp
deleted file mode 100644
index 37c3b12ff8c33ce9f0485c1f81308b7328b8e4a2..0000000000000000000000000000000000000000
--- a/compiler/mips/alloc.lisp
+++ /dev/null
@@ -1,234 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.22 1992/12/16 19:41:18 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Allocation VOPs for the MIPS port.
-;;;
-;;; Written by William Lott.
-;;; 
-
-(in-package "MIPS")
-
-
-;;;; LIST and LIST*
-
-#-gengc
-(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 (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
-  (: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 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 list-pointer-type))))
-	     (let ((cons-cells (if star (1- num) num)))
-	       (pseudo-atomic (pa-flag
-			       :extra (* (pad-data-block cons-size)
-					 cons-cells))
-		 (inst or res alloc-tn list-pointer-type)
-		 (move ptr res)
-		 (dotimes (i (1- cons-cells))
-		   (store-car (tn-ref-tn things) ptr)
-		   (setf things (tn-ref-across things))
-		   (inst addu ptr ptr (pad-data-block cons-size))
-		   (storew ptr ptr
-			   (- cons-cdr-slot cons-size)
-			   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 cons-cdr-slot))
-		       (t
-			(storew null-tn ptr
-				cons-cdr-slot list-pointer-type)))
-		 (assert (null (tn-ref-across things)))
-		 (move result res))))))))
-
-#-gengc
-(define-vop (list list-or-list*)
-  (:variant nil))
-
-#-gengc
-(define-vop (list* list-or-list*)
-  (:variant t))
-
-
-;;;; Special purpose inline allocators.
-
-(define-vop (allocate-code-object)
-  (:args (boxed-arg :scs (any-reg))
-	 (unboxed-arg :scs (any-reg)))
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
-  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
-  (:generator 100
-    (inst li ndescr (lognot lowtag-mask))
-    (inst addu boxed boxed-arg
-	  (fixnum (1+ #-gengc code-trace-table-offset-slot
-		      #+gengc code-debug-info-slot)))
-    (inst and boxed ndescr)
-    (inst srl unboxed unboxed-arg word-shift)
-    (inst addu unboxed unboxed lowtag-mask)
-    (inst and unboxed ndescr)
-    (inst sll ndescr boxed (- type-bits word-shift))
-    (inst or ndescr code-header-type)
-    
-    #-gengc
-    (pseudo-atomic (pa-flag)
-      (inst or result alloc-tn other-pointer-type)
-      (storew ndescr result 0 other-pointer-type)
-      (storew unboxed result code-code-size-slot other-pointer-type)
-      (storew null-tn result code-entry-points-slot other-pointer-type)
-      (inst addu alloc-tn boxed)
-      (inst addu alloc-tn unboxed))
-    #+gengc
-    (without-scheduling ()
-      (inst or result alloc-tn other-pointer-type)
-      (storew ndescr alloc-tn 0)
-      (storew unboxed alloc-tn code-code-size-slot)
-      (storew null-tn alloc-tn code-entry-points-slot)
-      (inst addu alloc-tn boxed)
-      (inst addu alloc-tn unboxed))
-
-    (storew null-tn result code-debug-info-slot other-pointer-type)))
-
-(define-vop (make-fdefn)
-  (:policy :fast-safe)
-  (:translate make-fdefn)
-  (:args (name :scs (descriptor-reg) :to :eval))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
-  (:results (result :scs (descriptor-reg) :from :argument))
-  (:generator 37
-    (with-fixed-allocation (result pa-flag temp fdefn-type fdefn-size)
-      (storew name result fdefn-name-slot other-pointer-type)
-      (storew null-tn result fdefn-function-slot other-pointer-type)
-      (inst li temp (make-fixup "undefined_tramp" :foreign))
-      (storew temp result fdefn-raw-addr-slot other-pointer-type))))
-
-(define-vop (make-closure)
-  (:args (function :to :save :scs (descriptor-reg)))
-  (:info length)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 10
-    #-gengc
-    (let ((size (+ length closure-info-offset)))
-      (inst li temp (logior (ash (1- size) type-bits) closure-header-type))
-      (pseudo-atomic (pa-flag :extra (pad-data-block size))
-	(inst or result alloc-tn function-pointer-type)
-	(storew temp result 0 function-pointer-type))
-      (storew function result closure-function-slot function-pointer-type))
-    #+gengc
-    (let ((size (+ length closure-info-offset)))
-      (inst li temp (logior (ash (1- size) type-bits) closure-header-type))
-      (without-scheduling ()
-	(inst or result alloc-tn function-pointer-type)
-	(storew temp alloc-tn)
-	(inst addu alloc-tn (pad-data-block size)))
-      (inst addu temp function
-	    (- (* function-code-offset word-bytes) function-pointer-type))
-      (storew temp result closure-entry-point-slot function-pointer-type))))
-
-;;; The compiler likes to be able to directly make value cells.
-;;; 
-(define-vop (make-value-cell)
-  (:args (value :to :save :scs (descriptor-reg any-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 10
-    (with-fixed-allocation
-	(result pa-flag temp value-cell-header-type value-cell-size))
-    (storew value result value-cell-value-slot other-pointer-type)))
-
-
-;;;; Automatic allocators for primitive objects.
-
-(define-vop (make-unbound-marker)
-  (:args)
-  (:results (result :scs (any-reg)))
-  (:generator 1
-    (inst li result unbound-marker-type)))
-
-(define-vop (fixed-alloc)
-  (:args)
-  (:info name words type lowtag)
-  (:ignore name)
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
-  (:generator 4
-    #-gengc
-    (pseudo-atomic (pa-flag :extra (pad-data-block words))
-      (inst or result alloc-tn lowtag)
-      (when type
-	(inst li temp (logior (ash (1- words) type-bits) type))
-	(storew temp result 0 lowtag)))
-    #+gengc
-    (progn
-      (when type
-	(inst li temp (logior (ash (1- words) type-bits) type)))
-      (without-scheduling ()
-	(inst or result alloc-tn lowtag)
-	(when type
-	  (storew temp alloc-tn))
-	(inst addu alloc-tn (pad-data-block words))))))
-
-(define-vop (var-alloc)
-  (:args (extra :scs (any-reg)))
-  (:arg-types positive-fixnum)
-  (:info name words type lowtag)
-  (:ignore name)
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:scs (any-reg)) header)
-  (:temporary (:scs (non-descriptor-reg)) bytes)
-  #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
-  (:generator 6
-    (inst addu bytes extra (* (1+ words) word-bytes))
-    (inst sll header bytes (- type-bits 2))
-    (inst addu header header (+ (ash -2 type-bits) type))
-    (inst srl bytes bytes lowtag-bits)
-    (inst sll bytes bytes lowtag-bits)
-    #-gengc
-    (pseudo-atomic (pa-flag)
-      (inst or result alloc-tn lowtag)
-      (storew header result 0 lowtag)
-      (inst addu alloc-tn alloc-tn bytes))
-    #+gengc
-    (without-scheduling ()
-      (inst or result alloc-tn lowtag)
-      (storew header result 0 lowtag)
-      (inst addu alloc-tn alloc-tn bytes))))
diff --git a/compiler/mips/arith.lisp b/compiler/mips/arith.lisp
deleted file mode 100644
index 0ded0c196d4dd6d242f161ac3370a9cdf7459c44..0000000000000000000000000000000000000000
--- a/compiler/mips/arith.lisp
+++ /dev/null
@@ -1,926 +0,0 @@
-;;; -*- Package: MIPS; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.49 1993/01/13 15:51:36 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/arith.lisp,v 1.49 1993/01/13 15:51:36 wlott Exp $
-;;;
-;;;    This file contains the VM definition arithmetic VOPs for the MIPS.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by William Lott.
-;;; 
-
-(in-package "MIPS")
-
-
-
-;;;; Unary operations.
-
-(define-vop (fixnum-unop)
-  (:args (x :scs (any-reg)))
-  (:results (res :scs (any-reg)))
-  (:note "inline fixnum arithmetic")
-  (:arg-types tagged-num)
-  (:result-types tagged-num)
-  (:policy :fast-safe))
-
-(define-vop (signed-unop)
-  (:args (x :scs (signed-reg)))
-  (:results (res :scs (signed-reg)))
-  (:note "inline (signed-byte 32) arithmetic")
-  (:arg-types signed-num)
-  (:result-types signed-num)
-  (:policy :fast-safe))
-
-(define-vop (fast-negate/fixnum fixnum-unop)
-  (:translate %negate)
-  (:generator 1
-    (inst subu res zero-tn x)))
-
-(define-vop (fast-negate/signed signed-unop)
-  (:translate %negate)
-  (:generator 2
-    (inst subu res zero-tn x)))
-
-(define-vop (fast-lognot/fixnum fixnum-unop)
-  (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
-	      temp)
-  (:translate lognot)
-  (:generator 2
-    (inst li temp (fixnum -1))
-    (inst xor res x temp)))
-
-(define-vop (fast-lognot/signed signed-unop)
-  (:translate lognot)
-  (:generator 1
-    (inst nor res x zero-tn)))
-
-
-
-;;;; Binary fixnum operations.
-
-;;; Assume that any constant operand is the second arg...
-
-(define-vop (fast-fixnum-binop)
-  (:args (x :target r :scs (any-reg))
-	 (y :target r :scs (any-reg)))
-  (:arg-types tagged-num tagged-num)
-  (:results (r :scs (any-reg)))
-  (:result-types tagged-num)
-  (:note "inline fixnum arithmetic")
-  (:effects)
-  (:affected)
-  (:policy :fast-safe))
-
-(define-vop (fast-unsigned-binop)
-  (:args (x :target r :scs (unsigned-reg))
-	 (y :target r :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:note "inline (unsigned-byte 32) arithmetic")
-  (:effects)
-  (:affected)
-  (:policy :fast-safe))
-
-(define-vop (fast-signed-binop)
-  (:args (x :target r :scs (signed-reg))
-	 (y :target r :scs (signed-reg)))
-  (:arg-types signed-num signed-num)
-  (:results (r :scs (signed-reg)))
-  (:result-types signed-num)
-  (:note "inline (signed-byte 32) arithmetic")
-  (:effects)
-  (:affected)
-  (:policy :fast-safe))
-
-(define-vop (fast-fixnum-c-binop fast-fixnum-binop)
-  (:args (x :target r :scs (any-reg)))
-  (:info y)
-  (:arg-types tagged-num (:constant integer)))
-
-(define-vop (fast-signed-c-binop fast-signed-binop)
-  (:args (x :target r :scs (signed-reg)))
-  (:info y)
-  (:arg-types tagged-num (:constant integer)))
-
-(define-vop (fast-unsigned-c-binop fast-unsigned-binop)
-  (:args (x :target r :scs (unsigned-reg)))
-  (:info y)
-  (:arg-types tagged-num (:constant integer)))
-
-(defmacro define-binop (translate cost untagged-cost op
-				  tagged-type untagged-type)
-  `(progn
-     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
-		  fast-fixnum-binop)
-       (:args (x :target r :scs (any-reg))
-	      (y :target r :scs (any-reg)))
-       (:translate ,translate)
-       (:generator ,(1+ cost)
-	 (inst ,op r x y)))
-     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
-		  fast-signed-binop)
-       (:args (x :target r :scs (signed-reg))
-	      (y :target r :scs (signed-reg)))
-       (:translate ,translate)
-       (:generator ,(1+ untagged-cost)
-	 (inst ,op r x y)))
-     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
-		  fast-unsigned-binop)
-       (:args (x :target r :scs (unsigned-reg))
-	      (y :target r :scs (unsigned-reg)))
-       (:translate ,translate)
-       (:generator ,(1+ untagged-cost)
-	 (inst ,op r x y)))
-     (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
-		  fast-fixnum-c-binop)
-       (:arg-types tagged-num (:constant ,tagged-type))
-       (:translate ,translate)
-       (:generator ,cost
-	 (inst ,op r x (fixnum y))))
-     (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
-		  fast-signed-c-binop)
-       (:arg-types signed-num (:constant ,untagged-type))
-       (:translate ,translate)
-       (:generator ,untagged-cost
-	 (inst ,op r x y)))
-     (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED")
-		  fast-unsigned-c-binop)
-       (:arg-types unsigned-num (:constant ,untagged-type))
-       (:translate ,translate)
-       (:generator ,untagged-cost
-	 (inst ,op r x y)))))
-
-(define-binop + 1 5 addu (signed-byte 14) (signed-byte 16))
-(define-binop - 1 5 subu
-  (integer #.(- (1- (ash 1 14))) #.(ash 1 14))
-  (integer #.(- (1- (ash 1 16))) #.(ash 1 16)))
-(define-binop logior 1 3 or (unsigned-byte 14) (unsigned-byte 16))
-(define-binop lognor 1 3 nor (unsigned-byte 14) (unsigned-byte 16))
-(define-binop logand 1 3 and (unsigned-byte 14) (unsigned-byte 16))
-(define-binop logxor 1 3 xor (unsigned-byte 14) (unsigned-byte 16))
-
-;;; Special case fixnum + and - that trap on overflow.  Useful when we don't
-;;; know that the result is going to be a fixnum.
-
-(define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:note nil)
-  (:generator 4
-    (inst add r x y)))
-
-(define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:note nil)
-  (:generator 3
-    (inst add r x (fixnum y))))
-
-(define-vop (fast--/fixnum fast--/fixnum=>fixnum)
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:note nil)
-  (:generator 4
-    (inst sub r x y)))
-
-(define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:note nil)
-  (:generator 3
-    (inst sub r x (fixnum y))))
-
-
-;;; Shifting
-
-
-(define-vop (fast-ash)
-  (:note "inline ASH")
-  (:args (number :scs (signed-reg unsigned-reg) :to :save)
-	 (amount :scs (signed-reg)))
-  (:arg-types (:or signed-num unsigned-num) signed-num)
-  (:results (result :scs (signed-reg unsigned-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:translate ash)
-  (:policy :fast-safe)
-  (:temporary (:sc non-descriptor-reg) ndesc)
-  (:temporary (:sc non-descriptor-reg :to :eval) temp)
-  (:generator 3
-    (inst bgez amount positive)
-    (inst subu ndesc zero-tn amount)
-    (inst slt temp ndesc 31)
-    (inst bne temp zero-tn done)
-    (sc-case number
-      (signed-reg (inst sra result number ndesc))
-      (unsigned-reg (inst srl result number ndesc)))
-    (inst b done)
-    (sc-case number
-      (signed-reg (inst sra result number 31))
-      (unsigned-reg (inst srl result number 31)))
-      
-    POSITIVE
-    ;; The result-type assures us that this shift will not overflow.
-    (inst sll result number amount)
-      
-    DONE))
-
-(define-vop (fast-ash-c)
-  (:policy :fast-safe)
-  (:translate ash)
-  (:note nil)
-  (:args (number :scs (signed-reg unsigned-reg)))
-  (:info count)
-  (:arg-types (:or signed-num unsigned-num) (:constant integer))
-  (:results (result :scs (signed-reg unsigned-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:generator 1
-    (cond ((< count 0)
-	   ;; It is a right shift.
-	   (sc-case number
-	     (signed-reg (inst sra result number (min (- count) 31)))
-	     (unsigned-reg (inst srl result number (min (- count) 31)))))
-	  ((> count 0)
-	   ;; It is a left shift.
-	   (inst sll result number (min count 31)))
-	  (t
-	   ;; Count=0?  Shouldn't happen, but it's easy:
-	   (move result number)))))
-
-(define-vop (signed-byte-32-len)
-  (:translate integer-length)
-  (:note "inline (signed-byte 32) integer-length")
-  (:policy :fast-safe)
-  (:args (arg :scs (signed-reg) :target shift))
-  (:arg-types signed-num)
-  (:results (res :scs (any-reg)))
-  (:result-types positive-fixnum)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
-  (:generator 30
-    (let ((loop (gen-label))
-	  (test (gen-label)))
-      (move shift arg)
-      (inst bgez shift test)
-      (move res zero-tn)
-      (inst b test)
-      (inst nor shift shift)
-
-      (emit-label loop)
-      (inst add res (fixnum 1))
-      
-      (emit-label test)
-      (inst bne shift loop)
-      (inst srl shift 1))))
-
-(define-vop (unsigned-byte-32-count)
-  (:translate logcount)
-  (:note "inline (unsigned-byte 32) logcount")
-  (:policy :fast-safe)
-  (:args (arg :scs (unsigned-reg) :target num))
-  (:arg-types unsigned-num)
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
-		    :target res) num)
-  (:temporary (:scs (non-descriptor-reg)) mask temp)
-  (:generator 30
-    (inst li mask #x55555555)
-    (inst srl temp arg 1)
-    (inst and num arg mask)
-    (inst and temp mask)
-    (inst addu num temp)
-    (inst li mask #x33333333)
-    (inst srl temp num 2)
-    (inst and num mask)
-    (inst and temp mask)
-    (inst addu num temp)
-    (inst li mask #x0f0f0f0f)
-    (inst srl temp num 4)
-    (inst and num mask)
-    (inst and temp mask)
-    (inst addu num temp)
-    (inst li mask #x00ff00ff)
-    (inst srl temp num 8)
-    (inst and num mask)
-    (inst and temp mask)
-    (inst addu num temp)
-    (inst li mask #x0000ffff)
-    (inst srl temp num 16)
-    (inst and num mask)
-    (inst and temp mask)
-    (inst addu res num temp)))
-
-
-;;; Multiply and Divide.
-
-(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:translate *)
-  (:generator 4
-    (inst sra temp y 2)
-    (inst mult x temp)
-    (inst mflo r)))
-
-(define-vop (fast-*/signed=>signed fast-signed-binop)
-  (:translate *)
-  (:generator 3
-    (inst mult x y)
-    (inst mflo r)))
-
-(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
-  (:translate *)
-  (:generator 3
-    (inst multu x y)
-    (inst mflo r)))
-
-
-
-(define-vop (fast-truncate/fixnum fast-fixnum-binop)
-  (:translate truncate)
-  (:results (q :scs (any-reg))
-	    (r :scs (any-reg)))
-  (:result-types tagged-num tagged-num)
-  (:temporary (:scs (non-descriptor-reg) :to :eval) temp)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 11
-    (let ((zero (generate-error-code vop division-by-zero-error x y)))
-      (inst beq y zero-tn zero))
-    (inst div x y)
-    (inst mflo temp)
-    (inst sll q temp 2)
-    (inst mfhi r)))
-
-(define-vop (fast-truncate/unsigned fast-unsigned-binop)
-  (:translate truncate)
-  (:results (q :scs (unsigned-reg))
-	    (r :scs (unsigned-reg)))
-  (:result-types unsigned-num unsigned-num)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 12
-    (let ((zero (generate-error-code vop division-by-zero-error x y)))
-      (inst beq y zero-tn zero))
-    (inst divu x y)
-    (inst mflo q)
-    (inst mfhi r)))
-
-(define-vop (fast-truncate/signed fast-signed-binop)
-  (:translate truncate)
-  (:results (q :scs (signed-reg))
-	    (r :scs (signed-reg)))
-  (:result-types signed-num signed-num)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 12
-    (let ((zero (generate-error-code vop division-by-zero-error x y)))
-      (inst beq y zero-tn zero))
-    (inst div x y)
-    (inst mflo q)
-    (inst mfhi r)))
-
-
-
-;;;; Binary conditional VOPs:
-
-(define-vop (fast-conditional)
-  (:conditional)
-  (:info target not-p)
-  (:effects)
-  (:affected)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:policy :fast-safe))
-
-(deftype integer-with-a-bite-out (s bite)
-  (cond ((eq s '*) 'integer)
-	((and (integerp s) (> s 1))
-	 (let ((bound (ash 1 (1- s))))
-	   `(integer ,(- bound) ,(- bound bite 1))))
-	(t
-	 (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
-
-(define-vop (fast-conditional/fixnum fast-conditional)
-  (:args (x :scs (any-reg))
-	 (y :scs (any-reg)))
-  (:arg-types tagged-num tagged-num)
-  (:note "inline fixnum comparison"))
-
-(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
-  (:args (x :scs (any-reg)))
-  (:arg-types tagged-num (:constant (integer-with-a-bite-out 14 #.(fixnum 1))))
-  (:info target not-p y))
-
-(define-vop (fast-conditional/signed fast-conditional)
-  (:args (x :scs (signed-reg))
-	 (y :scs (signed-reg)))
-  (:arg-types signed-num signed-num)
-  (:note "inline (signed-byte 32) comparison"))
-
-(define-vop (fast-conditional-c/signed fast-conditional/signed)
-  (:args (x :scs (signed-reg)))
-  (:arg-types signed-num (:constant (integer-with-a-bite-out 16 1)))
-  (:info target not-p y))
-
-(define-vop (fast-conditional/unsigned fast-conditional)
-  (:args (x :scs (unsigned-reg))
-	 (y :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num)
-  (:note "inline (unsigned-byte 32) comparison"))
-
-(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
-  (:args (x :scs (unsigned-reg)))
-  (:arg-types unsigned-num (:constant (and (integer-with-a-bite-out 16 1)
-					   unsigned-byte)))
-  (:info target not-p y))
-
-
-(defmacro define-conditional-vop (translate &rest generator)
-  `(progn
-     ,@(mapcar #'(lambda (suffix cost signed)
-		   (unless (and (member suffix '(/fixnum -c/fixnum))
-				(eq translate 'eql))
-		     `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
-						    translate suffix))
-				   ,(intern
-				     (format nil "~:@(FAST-CONDITIONAL~A~)"
-					     suffix)))
-			(:translate ,translate)
-			(:generator ,cost
-			  (let* ((signed ,signed)
-				 (-c/fixnum ,(eq suffix '-c/fixnum))
-				 (y (if -c/fixnum (fixnum y) y)))
-			    (declare (optimize (inhibit-warnings 3)))
-			    ,@generator)))))
-	       '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
-	       '(3 2 5 4 5 4)
-	       '(t t t t nil nil))))
-
-(define-conditional-vop <
-  (cond ((and signed (eql y 0))
-	 (if not-p
-	     (inst bgez x target)
-	     (inst bltz x target)))
-	(t
-	 (if signed
-	     (inst slt temp x y)
-	     (inst sltu temp x y))
-	 (if not-p
-	     (inst beq temp zero-tn target)
-	     (inst bne temp zero-tn target))))
-  (inst nop))
-
-(define-conditional-vop >
-  (cond ((and signed (eql y 0))
-	 (if not-p
-	     (inst blez x target)
-	     (inst bgtz x target)))
-	((integerp y)
-	 (let ((y (+ y (if -c/fixnum (fixnum 1) 1))))
-	   (if signed
-	       (inst slt temp x y)
-	       (inst sltu temp x y))
-	   (if not-p
-	       (inst bne temp zero-tn target)
-	       (inst beq temp zero-tn target))))
-	(t
-	 (if signed
-	     (inst slt temp y x)
-	     (inst sltu temp y x))
-	 (if not-p
-	     (inst beq temp zero-tn target)
-	     (inst bne temp zero-tn target))))
-  (inst nop))
-
-;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
-;;; known fixnum.
-
-(define-conditional-vop eql
-  (declare (ignore signed))
-  (when (integerp y)
-    (inst li temp y)
-    (setf y temp))
-  (if not-p
-      (inst bne x y target)
-      (inst beq x y target))
-  (inst nop))
-
-;;; These versions specify a fixnum restriction on their first arg.  We have
-;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
-;;; the first arg and a higher cost.  The reason for doing this is to prevent
-;;; fixnum specific operations from being used on word integers, spuriously
-;;; consing the argument.
-;;;
-(define-vop (fast-eql/fixnum fast-conditional)
-  (:args (x :scs (any-reg))
-	 (y :scs (any-reg)))
-  (:arg-types tagged-num tagged-num)
-  (:note "inline fixnum comparison")
-  (:translate eql)
-  (:ignore temp)
-  (:generator 3
-    (if not-p
-	(inst bne x y target)
-	(inst beq x y target))
-    (inst nop)))
-;;;
-(define-vop (generic-eql/fixnum fast-eql/fixnum)
-  (:args (x :scs (any-reg descriptor-reg))
-	 (y :scs (any-reg)))
-  (:arg-types * tagged-num)
-  (:variant-cost 7))
-
-(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
-  (:args (x :scs (any-reg)))
-  (:arg-types tagged-num (:constant (signed-byte 14)))
-  (:info target not-p y)
-  (:translate eql)
-  (:generator 2
-    (let ((y (cond ((eql y 0) zero-tn)
-		   (t
-		    (inst li temp (fixnum y))
-		    temp))))
-      (if not-p
-	  (inst bne x y target)
-	  (inst beq x y target))
-      (inst nop))))
-;;;
-(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:arg-types * (:constant (signed-byte 14)))
-  (:variant-cost 6))
-  
-
-;;;; 32-bit logical operations
-
-(define-vop (merge-bits)
-  (:translate merge-bits)
-  (:args (shift :scs (signed-reg unsigned-reg))
-	 (prev :scs (unsigned-reg))
-	 (next :scs (unsigned-reg)))
-  (:arg-types tagged-num unsigned-num unsigned-num)
-  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
-  (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:policy :fast-safe)
-  (:generator 4
-    (let ((done (gen-label)))
-      (inst beq shift done)
-      (inst srl res next shift)
-      (inst subu temp zero-tn shift)
-      (inst sll temp prev temp)
-      (inst or res res temp)
-      (emit-label done)
-      (move result res))))
-
-
-(define-vop (32bit-logical)
-  (:args (x :scs (unsigned-reg))
-	 (y :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:policy :fast-safe))
-
-(define-vop (32bit-logical-not 32bit-logical)
-  (:translate 32bit-logical-not)
-  (:args (x :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:generator 1
-    (inst nor r x zero-tn)))
-
-(define-vop (32bit-logical-and 32bit-logical)
-  (:translate 32bit-logical-and)
-  (:generator 1
-    (inst and r x y)))
-
-(deftransform 32bit-logical-nand ((x y) (* *))
-  '(32bit-logical-not (32bit-logical-and x y)))
-
-(define-vop (32bit-logical-or 32bit-logical)
-  (:translate 32bit-logical-or)
-  (:generator 1
-    (inst or r x y)))
-
-(define-vop (32bit-logical-nor 32bit-logical)
-  (:translate 32bit-logical-nor)
-  (:generator 1
-    (inst nor r x y)))
-
-(define-vop (32bit-logical-xor 32bit-logical)
-  (:translate 32bit-logical-xor)
-  (:generator 1
-    (inst xor r x y)))
-
-(deftransform 32bit-logical-eqv ((x y) (* *))
-  '(32bit-logical-not (32bit-logical-xor x y)))
-
-(deftransform 32bit-logical-andc1 ((x y) (* *))
-  '(32bit-logical-and (32bit-logical-not x) y))
-
-(deftransform 32bit-logical-andc2 ((x y) (* *))
-  '(32bit-logical-and x (32bit-logical-not y)))
-
-(deftransform 32bit-logical-orc1 ((x y) (* *))
-  '(32bit-logical-or (32bit-logical-not x) y))
-
-(deftransform 32bit-logical-orc2 ((x y) (* *))
-  '(32bit-logical-or x (32bit-logical-not y)))
-
-
-(define-vop (shift-towards-someplace)
-  (:policy :fast-safe)
-  (:args (num :scs (unsigned-reg))
-	 (amount :scs (signed-reg)))
-  (:arg-types unsigned-num tagged-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num))
-
-(define-vop (shift-towards-start shift-towards-someplace)
-  (:translate shift-towards-start)
-  (:note "SHIFT-TOWARDS-START")
-  (:generator 1
-    (ecase (backend-byte-order *backend*)
-      (:big-endian
-       (inst sll r num amount))
-      (:little-endian
-       (inst srl r num amount)))))
-
-(define-vop (shift-towards-end shift-towards-someplace)
-  (:translate shift-towards-end)
-  (:note "SHIFT-TOWARDS-END")
-  (:generator 1
-    (ecase (backend-byte-order *backend*)
-      (:big-endian
-       (inst srl r num amount))
-      (:little-endian
-       (inst sll r num amount)))))
-
-
-
-;;;; Bignum stuff.
-
-(define-vop (bignum-length get-header-data)
-  (:translate bignum::%bignum-length)
-  (:policy :fast-safe))
-
-(define-vop (bignum-set-length set-header-data)
-  (:translate bignum::%bignum-set-length)
-  (:policy :fast-safe))
-
-(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
-  (unsigned-reg) unsigned-num bignum::%bignum-ref)
-
-(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
-  (unsigned-reg) unsigned-num bignum::%bignum-set #+gengc nil)
-
-(define-vop (digit-0-or-plus)
-  (:translate bignum::%digit-0-or-plusp)
-  (:policy :fast-safe)
-  (:args (digit :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:conditional)
-  (:info target not-p)
-  (:generator 2
-    (if not-p
-	(inst bltz digit target)
-	(inst bgez digit target))
-    (inst nop)))
-
-(define-vop (add-w/carry)
-  (:translate bignum::%add-with-carry)
-  (:policy :fast-safe)
-  (:args (a :scs (unsigned-reg))
-	 (b :scs (unsigned-reg))
-	 (c :scs (any-reg)))
-  (:arg-types unsigned-num unsigned-num positive-fixnum)
-  (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
-  (:results (result :scs (unsigned-reg))
-	    (carry :scs (unsigned-reg) :from :eval))
-  (:result-types unsigned-num positive-fixnum)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 5
-    (let ((carry-in (gen-label))
-	  (done (gen-label)))
-      (inst bne c carry-in)
-      (inst addu res a b)
-
-      (inst b done)
-      (inst sltu carry res b)
-
-      (emit-label carry-in)
-      (inst addu res 1)
-      (inst nor temp a zero-tn)
-      (inst sltu carry b temp)
-      (inst xor carry 1)
-
-      (emit-label done)
-      (move result res))))
-
-(define-vop (sub-w/borrow)
-  (:translate bignum::%subtract-with-borrow)
-  (:policy :fast-safe)
-  (:args (a :scs (unsigned-reg))
-	 (b :scs (unsigned-reg))
-	 (c :scs (any-reg)))
-  (:arg-types unsigned-num unsigned-num positive-fixnum)
-  (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
-  (:results (result :scs (unsigned-reg))
-	    (borrow :scs (unsigned-reg) :from :eval))
-  (:result-types unsigned-num positive-fixnum)
-  (:generator 4
-    (let ((no-borrow-in (gen-label))
-	  (done (gen-label)))
-
-      (inst bne c no-borrow-in)
-      (inst subu res a b)
-
-      (inst subu res 1)
-      (inst b done)
-      (inst sltu borrow b a)
-
-      (emit-label no-borrow-in)
-      (inst sltu borrow a b)
-      (inst xor borrow 1)
-
-      (emit-label done)
-      (move result res))))
-
-(define-vop (bignum-mult-and-add-3-arg)
-  (:translate bignum::%multiply-and-add)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg))
-	 (y :scs (unsigned-reg))
-	 (carry-in :scs (unsigned-reg) :to :save))
-  (:arg-types unsigned-num unsigned-num unsigned-num)
-  (:temporary (:scs (unsigned-reg) :from (:argument 1)) temp)
-  (:results (hi :scs (unsigned-reg))
-	    (lo :scs (unsigned-reg)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 6
-    (inst multu x y)
-    (inst mflo temp)
-    (inst addu lo temp carry-in)
-    (inst sltu temp lo carry-in)
-    (inst mfhi hi)
-    (inst addu hi temp)))
-
-(define-vop (bignum-mult-and-add-4-arg)
-  (:translate bignum::%multiply-and-add)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg))
-	 (y :scs (unsigned-reg))
-	 (prev :scs (unsigned-reg))
-	 (carry-in :scs (unsigned-reg) :to :save))
-  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
-  (:temporary (:scs (unsigned-reg) :from (:argument 2)) temp)
-  (:results (hi :scs (unsigned-reg))
-	    (lo :scs (unsigned-reg)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 9
-    (inst multu x y)
-    (inst addu lo prev carry-in)
-    (inst sltu temp lo carry-in)
-    (inst mfhi hi)
-    (inst addu hi temp)
-    (inst mflo temp)
-    (inst addu lo temp)
-    (inst sltu temp lo temp)
-    (inst addu hi temp)))
-
-(define-vop (bignum-mult)
-  (:translate bignum::%multiply)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg))
-	 (y :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num)
-  (:results (hi :scs (unsigned-reg))
-	    (lo :scs (unsigned-reg)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 3
-    (inst multu x y)
-    (inst mflo lo)
-    (inst mfhi hi)))
-
-(define-vop (bignum-lognot)
-  (:translate bignum::%lognot)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (inst nor r x zero-tn)))
-
-(define-vop (fixnum-to-digit)
-  (:translate bignum::%fixnum-to-digit)
-  (:policy :fast-safe)
-  (:args (fixnum :scs (any-reg)))
-  (:arg-types tagged-num)
-  (:results (digit :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (inst sra digit fixnum 2)))
-
-(define-vop (bignum-floor)
-  (:translate bignum::%floor)
-  (:policy :fast-safe)
-  (:args (num-high :scs (unsigned-reg) :target rem)
-	 (num-low :scs (unsigned-reg) :target rem-low)
-	 (denom :scs (unsigned-reg) :to (:eval 1)))
-  (:arg-types unsigned-num unsigned-num unsigned-num)
-  (:temporary (:scs (unsigned-reg) :from (:argument 1)) rem-low)
-  (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
-  (:results (quo :scs (unsigned-reg) :from (:eval 0))
-	    (rem :scs (unsigned-reg) :from (:argument 0)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 325 ; number of inst assuming targeting works.
-    (move rem num-high)
-    (move rem-low num-low)
-    (flet ((maybe-subtract (&optional (guess temp))
-	     (inst subu temp guess 1)
-	     (inst and temp denom)
-	     (inst subu rem temp)))
-      (inst sltu quo rem denom)
-      (maybe-subtract quo)
-      (dotimes (i 32)
-	(inst sll rem 1)
-	(inst srl temp rem-low 31)
-	(inst or rem temp)
-	(inst sll rem-low 1)
-	(inst sltu temp rem denom)
-	(inst sll quo 1)
-	(inst or quo temp)
-	(maybe-subtract)))
-    (inst nor quo zero-tn)))
-
-(define-vop (signify-digit)
-  (:translate bignum::%fixnum-digit-with-correct-sign)
-  (:policy :fast-safe)
-  (:args (digit :scs (unsigned-reg) :target res))
-  (:arg-types unsigned-num)
-  (:results (res :scs (any-reg signed-reg)))
-  (:result-types signed-num)
-  (:generator 1
-    (sc-case res
-      (any-reg
-       (inst sll res digit 2))
-      (signed-reg
-       (move res digit)))))
-
-
-(define-vop (digit-ashr)
-  (:translate bignum::%ashr)
-  (:policy :fast-safe)
-  (:args (digit :scs (unsigned-reg))
-	 (count :scs (unsigned-reg)))
-  (:arg-types unsigned-num positive-fixnum)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (inst sra result digit count)))
-
-(define-vop (digit-lshr digit-ashr)
-  (:translate bignum::%digit-logical-shift-right)
-  (:generator 1
-    (inst srl result digit count)))
-
-(define-vop (digit-ashl digit-ashr)
-  (:translate bignum::%ashl)
-  (:generator 1
-    (inst sll result digit count)))
-
-
-;;;; Static functions.
-
-(define-static-function two-arg-gcd (x y) :translate gcd)
-(define-static-function two-arg-lcm (x y) :translate lcm)
-
-(define-static-function two-arg-+ (x y) :translate +)
-(define-static-function two-arg-- (x y) :translate -)
-(define-static-function two-arg-* (x y) :translate *)
-(define-static-function two-arg-/ (x y) :translate /)
-
-(define-static-function two-arg-< (x y) :translate <)
-(define-static-function two-arg-<= (x y) :translate <=)
-(define-static-function two-arg-> (x y) :translate >)
-(define-static-function two-arg->= (x y) :translate >=)
-(define-static-function two-arg-= (x y) :translate =)
-(define-static-function two-arg-/= (x y) :translate /=)
-
-(define-static-function %negate (x) :translate %negate)
-
-(define-static-function two-arg-and (x y) :translate logand)
-(define-static-function two-arg-ior (x y) :translate logior)
-(define-static-function two-arg-xor (x y) :translate logxor)
diff --git a/compiler/mips/array.lisp b/compiler/mips/array.lisp
deleted file mode 100644
index d74af077a0032d2994eabf8937ffb8ba46e6fc7f..0000000000000000000000000000000000000000
--- a/compiler/mips/array.lisp
+++ /dev/null
@@ -1,445 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/array.lisp,v 1.37 1993/01/13 15:55:23 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the MIPS definitions for array operations.
-;;;
-;;; Written by William Lott
-;;;
-(in-package "MIPS")
-
-
-;;;; Allocator for the array header.
-
-#-gengc
-(define-vop (make-array-header)
-  (:policy :fast-safe)
-  (:translate make-array-header)
-  (:args (type :scs (any-reg))
-	 (rank :scs (any-reg)))
-  (:arg-types positive-fixnum positive-fixnum)
-  (:temporary (:scs (any-reg)) bytes)
-  (:temporary (:scs (non-descriptor-reg)) header)
-  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 13
-    (inst addu bytes rank (+ (* array-dimensions-offset word-bytes)
-			     lowtag-mask))
-    (inst li header (lognot lowtag-mask))
-    (inst and bytes header)
-    (inst addu header rank (fixnum (1- array-dimensions-offset)))
-    (inst sll header type-bits)
-    (inst or header header type)
-    (inst srl header 2)
-    (pseudo-atomic (pa-flag)
-      (inst or result alloc-tn other-pointer-type)
-      (storew header alloc-tn)
-      (inst addu alloc-tn bytes))))
-
-#+gengc
-(define-vop (make-array-header)
-  (:args (type :scs (any-reg))
-	 (rank :scs (any-reg)))
-  (:arg-types positive-fixnum positive-fixnum)
-  (:temporary (:sc non-descriptor-reg :offset nl0-offset) nl0)
-  (:temporary (:sc non-descriptor-reg :offset nl1-offset) nl1)
-  (:temporary (:sc non-descriptor-reg :offset nl2-offset) nl2)
-  (:temporary (:sc descriptor-reg :offset a0-offset :target result
-	       :from (:argument 0) :to (:result 0))
-	      a0)
-  (:results (result :scs (descriptor-reg)))
-  (:ignore nl2)
-  (:generator 13
-    (inst addu a0 rank (fixnum (1+ array-dimensions-offset)))
-    (inst addu nl1 rank (fixnum (1- array-dimensions-offset)))
-    (inst sll nl1 (- type-bits 2))
-    (inst or nl1 type)
-    (inst jal (make-fixup 'var-alloc :assembly-routine))
-    (inst li nl0 other-pointer-type)
-    (move result a0)))
-
-
-
-;;;; Additional accessors and setters for the array header.
-
-(defknown lisp::%array-dimension (t index) index
-  (flushable))
-(defknown lisp::%set-array-dimension (t index index) index
-  ())
-
-(define-full-reffer %array-dimension *
-  array-dimensions-offset other-pointer-type
-  (any-reg) positive-fixnum lisp::%array-dimension)
-
-(define-full-setter %set-array-dimension *
-  array-dimensions-offset other-pointer-type
-  (any-reg) positive-fixnum lisp::%set-array-dimension nil)
-
-
-(defknown lisp::%array-rank (t) index (flushable))
-
-(define-vop (array-rank-vop)
-  (:translate lisp::%array-rank)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 6
-    (loadw temp x 0 other-pointer-type)
-    (inst sra temp type-bits)
-    (inst subu temp (1- array-dimensions-offset))
-    (inst sll res temp 2)))
-
-
-
-;;;; Bounds checking routine.
-
-
-(define-vop (check-bound)
-  (:translate %check-bound)
-  (:policy :fast-safe)
-  (:args (array :scs (descriptor-reg))
-	 (bound :scs (any-reg descriptor-reg))
-	 (index :scs (any-reg descriptor-reg) :target result))
-  (:results (result :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 5
-    (let ((error (generate-error-code vop invalid-array-index-error
-				      array bound index)))
-      (inst sltu temp index bound)
-      (inst beq temp zero-tn error)
-      (inst nop)
-      (move result index))))
-
-
-
-;;;; Accessors/Setters
-
-;;; Variants built on top of word-index-ref, etc.  I.e. those vectors whos
-;;; elements are represented in integer registers and are built out of
-;;; 8, 16, or 32 bit elements.
-
-(eval-when (compile eval)
-
-(defmacro def-full-data-vector-frobs (type element-type &rest scs)
-  `(progn
-     (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
-       vector-data-offset other-pointer-type ,scs ,element-type
-       data-vector-ref)
-     (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
-       vector-data-offset other-pointer-type ,scs ,element-type
-       data-vector-set #+gengc ,(if (member 'descriptor-reg scs) t nil))))
-
-(defmacro def-partial-data-vector-frobs
-	  (type element-type size signed &rest scs)
-  `(progn
-     (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
-       ,size ,signed vector-data-offset other-pointer-type ,scs
-       ,element-type data-vector-ref)
-     (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
-       ,size vector-data-offset other-pointer-type ,scs
-       ,element-type data-vector-set)))
-
-); eval-when (compile eval)
-
-(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
-
-(def-partial-data-vector-frobs simple-string base-char :byte nil
-  base-char-reg)
-
-(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
-  :byte nil unsigned-reg signed-reg)
-
-(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
-  :short nil unsigned-reg signed-reg)
-
-(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
-  unsigned-reg)
-
-
-
-;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
-;;; and 4-bit vectors.
-;;; 
-
-(defmacro def-small-data-vector-frobs (type bits)
-  (let* ((elements-per-word (floor word-bits bits))
-	 (bit-shift (1- (integer-length elements-per-word))))
-    `(progn
-       (define-vop (,(symbolicate 'data-vector-ref/ type))
-	 (:note "inline array access")
-	 (:translate data-vector-ref)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(index :scs (unsigned-reg)))
-	 (:arg-types ,type positive-fixnum)
-	 (:results (value :scs (any-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
-	 (:generator 20
-	   (inst srl temp index ,bit-shift)
-	   (inst sll temp 2)
-	   (inst addu lip object temp)
-	   (inst lw result lip
-		 (- (* vector-data-offset word-bytes)
-		    other-pointer-type))
-	   (inst and temp index ,(1- elements-per-word))
-	   ,@(when (eq (backend-byte-order *backend*) :big-endian)
-	       `((inst xor temp ,(1- elements-per-word))))
-	   ,@(unless (= bits 1)
-	       `((inst sll temp ,(1- (integer-length bits)))))
-	   (inst srl result temp)
-	   (inst and result ,(1- (ash 1 bits)))
-	   (inst sll value result 2)))
-       (define-vop (,(symbolicate 'data-vector-ref-c/ type))
-	 (:translate data-vector-ref)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg)))
-	 (:arg-types ,type
-		     (:constant
-		      (integer 0
-			       ,(1- (* (1+ (- (floor (+ #x7fff
-							other-pointer-type)
-						     word-bytes)
-					      vector-data-offset))
-				       elements-per-word)))))
-	 (:info index)
-	 (:results (result :scs (unsigned-reg)))
-	 (:result-types positive-fixnum)
-	 (:generator 15
-	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
-	     ,@(when (eq (backend-byte-order *backend*) :big-endian)
-		 `((setf extra (logxor extra (1- ,elements-per-word)))))
-	     (loadw result object (+ word vector-data-offset) 
-		    other-pointer-type)
-	     (unless (zerop extra)
-	       (inst srl result (* extra ,bits)))
-	     (unless (= extra ,(1- elements-per-word))
-	       (inst and result ,(1- (ash 1 bits)))))))
-       (define-vop (,(symbolicate 'data-vector-set/ type))
-	 (:note "inline array store")
-	 (:translate data-vector-set)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(index :scs (unsigned-reg) :target shift)
-		(value :scs (unsigned-reg zero immediate) :target result))
-	 (:arg-types ,type positive-fixnum positive-fixnum)
-	 (:results (result :scs (unsigned-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:temporary (:scs (non-descriptor-reg)) temp old)
-	 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
-	 (:generator 25
-	   (inst srl temp index ,bit-shift)
-	   (inst sll temp 2)
-	   (inst addu lip object temp)
-	   (inst lw old lip
-		 (- (* vector-data-offset word-bytes)
-		    other-pointer-type))
-	   (inst and shift index ,(1- elements-per-word))
-	   ,@(when (eq (backend-byte-order *backend*) :big-endian)
-	       `((inst xor shift ,(1- elements-per-word))))
-	   ,@(unless (= bits 1)
-	       `((inst sll shift ,(1- (integer-length bits)))))
-	   (unless (and (sc-is value immediate)
-			(= (tn-value value) ,(1- (ash 1 bits))))
-	     (inst li temp ,(1- (ash 1 bits)))
-	     (inst sll temp shift)
-	     (inst nor temp temp zero-tn)
-	     (inst and old temp))
-	   (unless (sc-is value zero)
-	     (sc-case value
-	       (immediate
-		(inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
-	       (unsigned-reg
-		(inst and temp value ,(1- (ash 1 bits)))))
-	     (inst sll temp shift)
-	     (inst or old temp))
-	   (inst sw old lip
-		 (- (* vector-data-offset word-bytes)
-		    other-pointer-type))
-	   (sc-case value
-	     (immediate
-	      (inst li result (tn-value value)))
-	     (zero
-	      (move result zero-tn))
-	     (unsigned-reg
-	      (move result value)))))
-       (define-vop (,(symbolicate 'data-vector-set-c/ type))
-	 (:translate data-vector-set)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(value :scs (unsigned-reg zero immediate) :target result))
-	 (:arg-types ,type
-		     (:constant
-		      (integer 0
-			       ,(1- (* (1+ (- (floor (+ #x7fff
-							other-pointer-type)
-						     word-bytes)
-					      vector-data-offset))
-				       elements-per-word))))
-		     positive-fixnum)
-	 (:info index)
-	 (:results (result :scs (unsigned-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (non-descriptor-reg)) temp old)
-	 (:generator 20
-	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
-	     ,@(when (eq (backend-byte-order *backend*) :big-endian)
-		 `((setf extra (logxor extra (1- ,elements-per-word)))))
-	     (inst lw old object
-		   (- (* (+ word vector-data-offset) word-bytes)
-		      other-pointer-type))
-	     (unless (and (sc-is value immediate)
-			  (= (tn-value value) ,(1- (ash 1 bits))))
-	       (cond ((= extra ,(1- elements-per-word))
-		      (inst sll old ,bits)
-		      (inst srl old ,bits))
-		     (t
-		      (inst li temp
-			    (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits))))
-		      (inst and old temp))))
-	     (sc-case value
-	       (zero)
-	       (immediate
-		(let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
-				  (* extra ,bits))))
-		  (cond ((< value #x10000)
-			 (inst or old value))
-			(t
-			 (inst li temp value)
-			 (inst or old temp)))))
-	       (unsigned-reg
-		(inst sll temp value (* extra ,bits))
-		(inst or old temp)))
-	     (inst sw old object
-		   (- (* (+ word vector-data-offset) word-bytes)
-		      other-pointer-type))
-	     (sc-case value
-	       (immediate
-		(inst li result (tn-value value)))
-	       (zero
-		(move result zero-tn))
-	       (unsigned-reg
-		(move result value)))))))))
-
-(def-small-data-vector-frobs simple-bit-vector 1)
-(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
-(def-small-data-vector-frobs simple-array-unsigned-byte-4 4)
-
-
-;;; And the float variants.
-;;; 
-
-(define-vop (data-vector-ref/simple-array-single-float)
-  (:note "inline array access")
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg)))
-  (:arg-types simple-array-single-float positive-fixnum)
-  (:results (value :scs (single-reg)))
-  (:result-types single-float)
-  (:temporary (:scs (interior-reg)) lip)
-  (:generator 20
-    (inst addu lip object index)
-    (inst lwc1 value lip
-	  (- (* vector-data-offset word-bytes)
-	     other-pointer-type))
-    (inst nop)))
-
-(define-vop (data-vector-set/simple-array-single-float)
-  (:note "inline array store")
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg))
-	 (value :scs (single-reg) :target result))
-  (:arg-types simple-array-single-float positive-fixnum single-float)
-  (:results (result :scs (single-reg)))
-  (:result-types single-float)
-  (:temporary (:scs (interior-reg)) lip)
-  (:generator 20
-    (inst addu lip object index)
-    (inst swc1 value lip
-	  (- (* vector-data-offset word-bytes)
-	     other-pointer-type))
-    (unless (location= result value)
-      (inst fmove :single result value))))
-
-(define-vop (data-vector-ref/simple-array-double-float)
-  (:note "inline array access")
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg)))
-  (:arg-types simple-array-double-float positive-fixnum)
-  (:results (value :scs (double-reg)))
-  (:result-types double-float)
-  (:temporary (:scs (interior-reg)) lip)
-  (:generator 20
-    (inst addu lip object index)
-    (inst addu lip index)
-    (inst lwc1 value lip
-	  (- (* vector-data-offset word-bytes)
-	     other-pointer-type))
-    (inst lwc1-odd value lip
-	  (+ (- (* vector-data-offset word-bytes)
-		other-pointer-type)
-	     word-bytes))
-    (inst nop)))
-
-(define-vop (data-vector-set/simple-array-double-float)
-  (:note "inline array store")
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg))
-	 (value :scs (double-reg) :target result))
-  (:arg-types simple-array-double-float positive-fixnum double-float)
-  (:results (result :scs (double-reg)))
-  (:result-types double-float)
-  (:temporary (:scs (interior-reg)) lip)
-  (:generator 20
-    (inst addu lip object index)
-    (inst addu lip index)
-    (inst swc1 value lip
-	  (- (* vector-data-offset word-bytes)
-	     other-pointer-type))
-    (inst swc1-odd value lip
-	  (+ (- (* vector-data-offset word-bytes)
-		other-pointer-type)
-	     word-bytes))
-    (unless (location= result value)
-      (inst fmove :double result value))))
-
-
-
-;;; These vops are useful for accessing the bits of a vector irrespective of
-;;; what type of vector it is.
-;;; 
-
-(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num
-  %raw-bits)
-(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
-  unsigned-num %set-raw-bits #+gengc nil)
-
-
-
-;;;; Misc. Array VOPs.
-
-(define-vop (get-vector-subtype get-header-data))
-(define-vop (set-vector-subtype set-header-data))
-
diff --git a/compiler/mips/c-call.lisp b/compiler/mips/c-call.lisp
deleted file mode 100644
index 93e1aef92ed466f03a8151347e9e75edd7caa95d..0000000000000000000000000000000000000000
--- a/compiler/mips/c-call.lisp
+++ /dev/null
@@ -1,201 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/c-call.lisp,v 1.12 1992/07/28 20:37:17 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the VOPs and other necessary machine specific support
-;;; routines for call-out to C.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "MIPS")
-(use-package "ALIEN")
-(use-package "ALIEN-INTERNALS")
-
-(defun my-make-wired-tn (prim-type-name sc-name offset)
-  (make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
-		 (sc-number-or-lose sc-name *backend*)
-		 offset))
-
-(defstruct arg-state
-  (stack-frame-size 0)
-  (did-int-arg nil)
-  (float-args 0))
-
-(def-alien-type-method (integer :arg-tn) (type state)
-  (let ((stack-frame-size (arg-state-stack-frame-size state)))
-    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
-    (setf (arg-state-did-int-arg state) t)
-    (multiple-value-bind
-	(ptype reg-sc stack-sc)
-	(if (alien-integer-type-signed type)
-	    (values 'signed-byte-32 'signed-reg 'signed-stack)
-	    (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
-      (if (< stack-frame-size 4)
-	  (my-make-wired-tn ptype reg-sc (+ stack-frame-size 4))
-	  (my-make-wired-tn ptype stack-sc stack-frame-size)))))
-
-(def-alien-type-method (system-area-pointer :arg-tn) (type state)
-  (declare (ignore type))
-  (let ((stack-frame-size (arg-state-stack-frame-size state)))
-    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
-    (setf (arg-state-did-int-arg state) t)
-    (if (< stack-frame-size 4)
-	(my-make-wired-tn 'system-area-pointer
-			  'sap-reg
-			  (+ stack-frame-size 4))
-	(my-make-wired-tn 'system-area-pointer
-			  'sap-stack
-			  stack-frame-size))))
-
-(def-alien-type-method (double-float :arg-tn) (type state)
-  (declare (ignore type))
-  (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1))
-	(float-args (arg-state-float-args state)))
-    (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
-    (setf (arg-state-float-args state) (1+ float-args))
-    (cond ((>= stack-frame-size 4)
-	   (my-make-wired-tn 'double-float
-			     'double-stack
-			     stack-frame-size))
-	  ((and (not (arg-state-did-int-arg state))
-		(< float-args 2))
-	   (my-make-wired-tn 'double-float
-			     'double-reg
-			     (+ (* float-args 2) 12)))
-	  (t
-	   (error "Can't put floats in int regs yet.")))))
-
-(def-alien-type-method (single-float :arg-tn) (type state)
-  (declare (ignore type))
-  (let ((stack-frame-size (arg-state-stack-frame-size state))
-	(float-args (arg-state-float-args state)))
-    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
-    (setf (arg-state-float-args state) (1+ float-args))
-    (cond ((>= stack-frame-size 4)
-	   (my-make-wired-tn 'single-float
-			     'single-stack
-			     stack-frame-size))
-	  ((and (not (arg-state-did-int-arg state))
-		(< float-args 2))
-	   (my-make-wired-tn 'single-float
-			     'single-reg
-			     (+ (* float-args 2) 12)))
-	  (t
-	   (error "Can't put floats in int regs yet.")))))
-
-
-(defstruct result-state
-  (num-results 0))
-
-(def-alien-type-method (integer :result-tn) (type state)
-  (let ((num-results (result-state-num-results state)))
-    (setf (result-state-num-results state) (1+ num-results))
-    (multiple-value-bind
-	(ptype reg-sc)
-	(if (alien-integer-type-signed type)
-	    (values 'signed-byte-32 'signed-reg)
-	    (values 'unsigned-byte-32 'unsigned-reg))
-      (my-make-wired-tn ptype reg-sc (+ num-results 2)))))
-
-(def-alien-type-method (system-area-pointer :result-tn) (type state)
-  (declare (ignore type))
-  (let ((num-results (result-state-num-results state)))
-    (setf (result-state-num-results state) (1+ num-results))
-    (my-make-wired-tn 'system-area-pointer 'sap-reg (+ num-results 2))))
-    
-(def-alien-type-method (double-float :result-tn) (type state)
-  (declare (ignore type))
-  (let ((num-results (result-state-num-results state)))
-    (setf (result-state-num-results state) (1+ num-results))
-    (my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
-
-(def-alien-type-method (single-float :result-tn) (type state)
-  (declare (ignore type))
-  (let ((num-results (result-state-num-results state)))
-    (setf (result-state-num-results state) (1+ num-results))
-    (my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
-
-(def-alien-type-method (values :result-tn) (type state)
-  (mapcar #'(lambda (type)
-	      (invoke-alien-type-method :result-tn type state))
-	  (alien-values-type-values type)))
-
-(def-vm-support-routine make-call-out-tns (type)
-  (let ((arg-state (make-arg-state)))
-    (collect ((arg-tns))
-      (dolist (arg-type (alien-function-type-arg-types type))
-	(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
-      (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
-	      (* (max (arg-state-stack-frame-size arg-state) 4) word-bytes)
-	      (arg-tns)
-	      (invoke-alien-type-method :result-tn
-					(alien-function-type-result-type type)
-					(make-result-state))))))
-
-
-(define-vop (foreign-symbol-address)
-  (:translate foreign-symbol-address)
-  (:policy :fast-safe)
-  (:args)
-  (:arg-types (:constant simple-string))
-  (:info foreign-symbol)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 2
-    (inst li res (make-fixup foreign-symbol :foreign))))
-
-(define-vop (call-out)
-  (:args (function :scs (sap-reg) :target cfunc)
-	 (args :more t))
-  (:results (results :more t))
-  (:ignore args results)
-  (:save-p t)
-  (:temporary (:sc any-reg :offset cfunc-offset
-		   :from (:argument 0) :to (:result 0)) cfunc)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:vop-var vop)
-  (:generator 0
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn nfp-save cur-nfp))
-      (move cfunc function)
-      (inst jal (make-fixup "call_into_c" :foreign))
-      (inst nop)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save)))))
-
-(define-vop (alloc-number-stack-space)
-  (:info amount)
-  (:results (result :scs (sap-reg any-reg)))
-  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
-  (:generator 0
-    (unless (zerop amount)
-      (let ((delta (logandc2 (+ amount 7) 7)))
-	(cond ((< delta (ash 1 15))
-	       (inst subu nsp-tn delta))
-	      (t
-	       (inst li temp delta)
-	       (inst subu nsp-tn temp)))))
-    (move result nsp-tn)))
-
-(define-vop (dealloc-number-stack-space)
-  (:info amount)
-  (:policy :fast-safe)
-  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
-  (:generator 0
-    (unless (zerop amount)
-      (let ((delta (logandc2 (+ amount 7) 7)))
-	(cond ((< delta (ash 1 15))
-	       (inst addu nsp-tn delta))
-	      (t
-	       (inst li temp delta)
-	       (inst addu nsp-tn temp)))))))
diff --git a/compiler/mips/char.lisp b/compiler/mips/char.lisp
deleted file mode 100644
index 13e2341d64184df2feed649e9a1bd617d46231ac..0000000000000000000000000000000000000000
--- a/compiler/mips/char.lisp
+++ /dev/null
@@ -1,136 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/char.lisp,v 1.13 1991/11/09 02:37:38 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/char.lisp,v 1.13 1991/11/09 02:37:38 wlott Exp $
-;;; 
-;;; This file contains the RT VM definition of character operations.
-;;;
-;;; Written by Rob MacLachlan
-;;; Converted for the MIPS R2000 by Christopher Hoover.
-;;;
-(in-package "MIPS")
-
-
-
-;;;; Moves and coercions:
-
-;;; Move a tagged char to an untagged representation.
-;;;
-(define-vop (move-to-base-char)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (y :scs (base-char-reg)))
-  (:generator 1
-    (inst srl y x vm:type-bits)))
-;;;
-(define-move-vop move-to-base-char :move
-  (any-reg descriptor-reg) (base-char-reg))
-
-
-;;; Move an untagged char to a tagged representation.
-;;;
-(define-vop (move-from-base-char)
-  (:args (x :scs (base-char-reg)))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (inst sll y x vm:type-bits)
-    (inst or y y vm:base-char-type)))
-;;;
-(define-move-vop move-from-base-char :move
-  (base-char-reg) (any-reg descriptor-reg))
-
-;;; Move untagged base-char values.
-;;;
-(define-vop (base-char-move)
-  (:args (x :target y
-	    :scs (base-char-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (base-char-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:generator 0
-    (move y x)))
-;;;
-(define-move-vop base-char-move :move
-  (base-char-reg) (base-char-reg))
-
-
-;;; Move untagged base-char arguments/return-values.
-;;;
-(define-vop (move-base-char-argument)
-  (:args (x :target y
-	    :scs (base-char-reg))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y base-char-reg))))
-  (:results (y))
-  (:generator 0
-    (sc-case y
-      (base-char-reg
-       (move y x))
-      (base-char-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-base-char-argument :move-argument
-  (any-reg base-char-reg) (base-char-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
-;;; to a descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (base-char-reg) (any-reg descriptor-reg))
-
-
-
-;;;; Other operations:
-
-(define-vop (char-code)
-  (:translate char-code)
-  (:policy :fast-safe)
-  (:args (ch :scs (base-char-reg) :target res))
-  (:arg-types base-char)
-  (:results (res :scs (any-reg)))
-  (:result-types positive-fixnum)
-  (:generator 1
-    (inst sll res ch 2)))
-
-(define-vop (code-char)
-  (:translate code-char)
-  (:policy :fast-safe)
-  (:args (code :scs (any-reg) :target res))
-  (:arg-types positive-fixnum)
-  (:results (res :scs (base-char-reg)))
-  (:result-types base-char)
-  (:generator 1
-    (inst srl res code 2)))
-
-
-;;; Comparison of base-chars.
-;;;
-(define-vop (base-char-compare pointer-compare)
-  (:args (x :scs (base-char-reg))
-	 (y :scs (base-char-reg)))
-  (:arg-types base-char base-char))
-
-(define-vop (fast-char=/base-char base-char-compare)
-  (:translate char=)
-  (:variant :eq))
-
-(define-vop (fast-char</base-char base-char-compare)
-  (:translate char<)
-  (:variant :lt))
-
-(define-vop (fast-char>/base-char base-char-compare)
-  (:translate char>)
-  (:variant :gt))
-
diff --git a/compiler/mips/debug.lisp b/compiler/mips/debug.lisp
deleted file mode 100644
index 79d049c828bf02bf9d10b5aa23b927173c1222f2..0000000000000000000000000000000000000000
--- a/compiler/mips/debug.lisp
+++ /dev/null
@@ -1,149 +0,0 @@
-;;; -*- Package: MIPS; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/debug.lisp,v 1.15 1993/01/13 15:57:11 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Compiler support for the new whizzy debugger.
-;;;
-;;; Written by William Lott.
-;;; 
-(in-package "MIPS")
-
-
-(define-vop (debug-cur-sp)
-  (:translate current-sp)
-  (:policy :fast-safe)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 1
-    (move res csp-tn)))
-
-(define-vop (debug-cur-fp)
-  (:translate current-fp)
-  (:policy :fast-safe)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 1
-    (move res cfp-tn)))
-
-(define-vop (read-control-stack)
-  (:translate stack-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (sap-reg) :target sap)
-	 (offset :scs (any-reg)))
-  (:arg-types system-area-pointer positive-fixnum)
-  (:temporary (:scs (sap-reg) :from :eval) sap)
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:generator 5
-    (inst add sap object offset)
-    (inst lw result sap 0)
-    (inst nop)))
-
-(define-vop (read-control-stack-c)
-  (:translate stack-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (sap-reg)))
-  (:info offset)
-  (:arg-types system-area-pointer (:constant (signed-byte 14)))
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:generator 4
-    (inst lw result object (* offset word-bytes))
-    (inst nop)))
-
-(define-vop (write-control-stack)
-  (:translate %set-stack-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (sap-reg) :target sap)
-	 (offset :scs (any-reg))
-	 (value :scs (descriptor-reg) :target result))
-  (:arg-types system-area-pointer positive-fixnum *)
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
-  (:generator 2
-    (inst add sap object offset)
-    (inst sw value sap 0)
-    (move result value)))
-
-(define-vop (write-control-stack-c)
-  (:translate %set-stack-ref)
-  (:policy :fast-safe)
-  (:args (sap :scs (sap-reg))
-	 (value :scs (descriptor-reg) :target result))
-  (:info offset)
-  (:arg-types system-area-pointer (:constant (signed-byte 14)) *)
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:generator 1
-    (inst sw value sap (* offset word-bytes))
-    (move result value)))
-
-
-(define-vop (code-from-mumble)
-  (:policy :fast-safe)
-  (:args (thing :scs (descriptor-reg)))
-  (:results (code :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:variant-vars lowtag)
-  (:generator 5
-    (let ((bogus (gen-label))
-	  (done (gen-label)))
-      (loadw temp thing 0 lowtag)
-      (inst srl temp vm:type-bits)
-      (inst beq temp bogus)
-      (inst sll temp (1- (integer-length vm:word-bytes)))
-      (unless (= lowtag vm:other-pointer-type)
-	(inst addu temp (- lowtag vm:other-pointer-type)))
-      (inst subu code thing temp)
-      (emit-label done)
-      (assemble (*elsewhere*)
-	(emit-label bogus)
-	(inst b done)
-	(move code null-tn)))))
-
-#-gengc
-(define-vop (code-from-lra code-from-mumble)
-  (:translate lra-code-header)
-  (:variant vm:other-pointer-type))
-
-(define-vop (code-from-function code-from-mumble)
-  (:translate function-code-header)
-  (:variant vm:function-pointer-type))
-
-(define-vop (make-lisp-obj)
-  (:policy :fast-safe)
-  (:translate make-lisp-obj)
-  (:args (value :scs (unsigned-reg) :target result))
-  (:arg-types unsigned-num)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 1
-    (move result value)))
-
-(define-vop (get-lisp-obj-address)
-  (:policy :fast-safe)
-  (:translate get-lisp-obj-address)
-  (:args (thing :scs (descriptor-reg) :target result))
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (move result thing)))
-
-(define-vop (function-word-offset)
-  (:policy :fast-safe)
-  (:translate function-word-offset)
-  (:args (fun :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 5
-    (loadw res fun 0 function-pointer-type)
-    (inst srl res vm:type-bits)))
diff --git a/compiler/mips/float.lisp b/compiler/mips/float.lisp
deleted file mode 100644
index 84e4deab3929a25ecba00b63791f0f3ca9e047ce..0000000000000000000000000000000000000000
--- a/compiler/mips/float.lisp
+++ /dev/null
@@ -1,424 +0,0 @@
-;;; -*- Package: MIPS; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/float.lisp,v 1.17 1993/01/13 15:58:21 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains floating point support for the MIPS.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package "MIPS")
-
-
-;;;; Move functions:
-
-(define-move-function (load-single 1) (vop x y)
-  ((single-stack) (single-reg))
-  (inst lwc1 y (current-nfp-tn vop) (* (tn-offset x) word-bytes))
-  (inst nop))
-
-(define-move-function (store-single 1) (vop x y)
-  ((single-reg) (single-stack))
-  (inst swc1 x (current-nfp-tn vop) (* (tn-offset y) word-bytes)))
-
-
-(define-move-function (load-double 2) (vop x y)
-  ((double-stack) (double-reg))
-  (let ((nfp (current-nfp-tn vop))
-	(offset (* (tn-offset x) word-bytes)))
-    (inst lwc1 y nfp offset)
-    (inst lwc1-odd y nfp (+ offset word-bytes)))
-  (inst nop))
-
-(define-move-function (store-double 2) (vop x y)
-  ((double-reg) (double-stack))
-  (let ((nfp (current-nfp-tn vop))
-	(offset (* (tn-offset y) word-bytes)))
-    (inst swc1 x nfp offset)
-    (inst swc1-odd x nfp (+ offset word-bytes))))
-
-
-
-;;;; Move VOPs:
-
-(macrolet ((frob (vop sc format)
-	     `(progn
-		(define-vop (,vop)
-		  (:args (x :scs (,sc)
-			    :target y
-			    :load-if (not (location= x y))))
-		  (:results (y :scs (,sc)
-			       :load-if (not (location= x y))))
-		  (:note "float move")
-		  (:generator 0
-		    (unless (location= y x)
-		      (inst fmove ,format y x))))
-		(define-move-vop ,vop :move (,sc) (,sc)))))
-  (frob single-move single-reg :single)
-  (frob double-move double-reg :double))
-
-
-(define-vop (move-from-float)
-  (:args (x :to :save))
-  (:results (y))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
-  (:variant-vars double-p size type data)
-  (:note "float to pointer coercion")
-  (:generator 13
-    (with-fixed-allocation (y pa-flag ndescr type size)
-      (inst swc1 x y (- (* data word-bytes) other-pointer-type))
-      (when double-p
-	(inst swc1-odd x y (- (* (1+ data) word-bytes)
-			      other-pointer-type))))))
-
-(macrolet ((frob (name sc &rest args)
-	     `(progn
-		(define-vop (,name move-from-float)
-		  (:args (x :scs (,sc) :to :save))
-		  (:results (y :scs (descriptor-reg)))
-		  (:variant ,@args))
-		(define-move-vop ,name :move (,sc) (descriptor-reg)))))
-  (frob move-from-single single-reg
-    nil single-float-size single-float-type single-float-value-slot)
-  (frob move-from-double double-reg
-    t double-float-size double-float-type double-float-value-slot))
-
-(macrolet ((frob (name sc double-p value)
-	     `(progn
-		(define-vop (,name)
-		  (:args (x :scs (descriptor-reg)))
-		  (:results (y :scs (,sc)))
-		  (:note "pointer to float coercion")
-		  (:generator 2
-		    (inst lwc1 y x (- (* ,value word-bytes)
-				      other-pointer-type))
-		    ,@(when double-p
-			`((inst lwc1-odd y x (- (* (1+ ,value) word-bytes)
-						other-pointer-type))))
-		    (inst nop)))
-		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
-  (frob move-to-single single-reg nil single-float-value-slot)
-  (frob move-to-double double-reg t double-float-value-slot))
-
-
-(macrolet ((frob (name sc stack-sc format double-p)
-	     `(progn
-		(define-vop (,name)
-		  (:args (x :scs (,sc) :target y)
-			 (nfp :scs (any-reg)
-			      :load-if (not (sc-is y ,sc))))
-		  (:results (y))
-		  (:note "float argument move")
-		  (:generator ,(if double-p 2 1)
-		    (sc-case y
-		      (,sc
-		       (unless (location= x y)
-			 (inst fmove ,format y x)))
-		      (,stack-sc
-		       (let ((offset (* (tn-offset y) word-bytes)))
-			 (inst swc1 x nfp offset)
-			 ,@(when double-p
-			     '((inst swc1-odd x nfp
-				     (+ offset word-bytes)))))))))
-		(define-move-vop ,name :move-argument
-		  (,sc descriptor-reg) (,sc)))))
-  (frob move-single-float-argument single-reg single-stack :single nil)
-  (frob move-double-float-argument double-reg double-stack :double t))
-
-
-(define-move-vop move-argument :move-argument
-  (single-reg double-reg) (descriptor-reg))
-
-
-;;;; Arithmetic VOPs:
-
-(define-vop (float-op)
-  (:args (x) (y))
-  (:results (r))
-  (:variant-vars format operation)
-  (:policy :fast-safe)
-  (:note "inline float arithmetic")
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 0
-    (note-this-location vop :internal-error)
-    (inst float-op operation format r x y)))
-
-(macrolet ((frob (name sc ptype)
-	     `(define-vop (,name float-op)
-		(:args (x :scs (,sc))
-		       (y :scs (,sc)))
-		(:results (r :scs (,sc)))
-		(:arg-types ,ptype ,ptype)
-		(:result-types ,ptype))))
-  (frob single-float-op single-reg single-float)
-  (frob double-float-op double-reg double-float))
-
-(macrolet ((frob (op sname scost dname dcost)
-	     `(progn
-		(define-vop (,sname single-float-op)
-		  (:translate ,op)
-		  (:variant :single ',op)
-		  (:variant-cost ,scost))
-		(define-vop (,dname double-float-op)
-		  (:translate ,op)
-		  (:variant :double ',op)
-		  (:variant-cost ,dcost)))))
-  (frob + +/single-float 2 +/double-float 2)
-  (frob - -/single-float 2 -/double-float 2)
-  (frob * */single-float 4 */double-float 5)
-  (frob / //single-float 12 //double-float 19))
-
-(macrolet ((frob (name inst translate format sc type)
-	     `(define-vop (,name)
-		(:args (x :scs (,sc)))
-		(:results (y :scs (,sc)))
-		(:translate ,translate)
-		(:policy :fast-safe)
-		(:arg-types ,type)
-		(:result-types ,type)
-		(:note "inline float arithmetic")
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 1
-		  (note-this-location vop :internal-error)
-		  (inst ,inst ,format y x)))))
-  (frob abs/single-float fabs abs :single single-reg single-float)
-  (frob abs/double-float fabs abs :double double-reg double-float)
-  (frob %negate/single-float fneg %negate :single single-reg single-float)
-  (frob %negate/double-float fneg %negate :double double-reg double-float))
-
-
-;;;; Comparison:
-
-(define-vop (float-compare)
-  (:args (x) (y))
-  (:conditional)
-  (:info target not-p)
-  (:variant-vars format operation complement)
-  (:policy :fast-safe)
-  (:note "inline float comparison")
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 3
-    (note-this-location vop :internal-error)
-    (inst fcmp operation format x y)
-    (inst nop)
-    (if (if complement (not not-p) not-p)
-	(inst bc1f target)
-	(inst bc1t target))
-    (inst nop)))
-
-(macrolet ((frob (name sc ptype)
-	     `(define-vop (,name float-compare)
-		(:args (x :scs (,sc))
-		       (y :scs (,sc)))
-		(:arg-types ,ptype ,ptype))))
-  (frob single-float-compare single-reg single-float)
-  (frob double-float-compare double-reg double-float))
-
-(macrolet ((frob (translate op complement sname dname)
-	     `(progn
-		(define-vop (,sname single-float-compare)
-		  (:translate ,translate)
-		  (:variant :single ,op ,complement))
-		(define-vop (,dname double-float-compare)
-		  (:translate ,translate)
-		  (:variant :double ,op ,complement)))))
-  (frob < :lt nil </single-float </double-float)
-  (frob > :ngt t >/single-float >/double-float)
-  (frob eql :seq nil eql/single-float eql/double-float))
-
-
-;;;; Conversion:
-
-(macrolet ((frob (name translate
-		       from-sc from-type from-format
-		       to-sc to-type to-format)
-	     (let ((word-p (eq from-format :word)))
-	       `(define-vop (,name)
-		  (:args (x :scs (,from-sc)))
-		  (:results (y :scs (,to-sc)))
-		  (:arg-types ,from-type)
-		  (:result-types ,to-type)
-		  (:policy :fast-safe)
-		  (:note "inline float coercion")
-		  (:translate ,translate)
-		  (:vop-var vop)
-		  (:save-p :compute-only)
-		  (:generator ,(if word-p 3 2)
-		    ,@(if word-p
-			  `((inst mtc1 y x)
-			    (inst nop)
-			    (note-this-location vop :internal-error)
-			    (inst fcvt ,to-format :word y y))
-			  `((note-this-location vop :internal-error)
-			    (inst fcvt ,to-format ,from-format y x))))))))
-  (frob %single-float/signed %single-float
-    signed-reg signed-num :word
-    single-reg single-float :single)
-  (frob %double-float/signed %double-float
-    signed-reg signed-num :word
-    double-reg double-float :double)
-  (frob %single-float/double-float %single-float
-    double-reg double-float :double
-    single-reg single-float :single)
-  (frob %double-float/single-float %double-float
-    single-reg single-float :single
-    double-reg double-float :double))
-
-
-(macrolet ((frob (name from-sc from-type from-format)
-	     `(define-vop (,name)
-		(:args (x :scs (,from-sc)))
-		(:results (y :scs (signed-reg)))
-		(:temporary (:from (:argument 0) :sc ,from-sc) temp)
-		(:arg-types ,from-type)
-		(:result-types signed-num)
-		(:translate %unary-round)
-		(:policy :fast-safe)
-		(:note "inline float round")
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 3
-		  (note-this-location vop :internal-error)
-		  (inst fcvt :word ,from-format temp x)
-		  (inst mfc1 y temp)
-		  (inst nop)))))
-  (frob %unary-round/single-float single-reg single-float :single)
-  (frob %unary-round/double-float double-reg double-float :double))
-
-
-;;; These VOPs have to uninterruptibly frob the rounding mode in order to get
-;;; the desired round-to-zero behavior.
-;;;
-(macrolet ((frob (name from-sc from-type from-format)
-	     `(define-vop (,name)
-		(:args (x :scs (,from-sc)))
-		(:results (y :scs (signed-reg)))
-		(:temporary (:from (:argument 0) :sc ,from-sc) temp)
-		(:temporary (:sc non-descriptor-reg) status-save new-status)
-		(:temporary (:sc non-descriptor-reg :offset nl4-offset)
-			    pa-flag)
-		(:arg-types ,from-type)
-		(:result-types signed-num)
-		(:translate %unary-truncate)
-		(:policy :fast-safe)
-		(:note "inline float truncate")
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 16
-		  (pseudo-atomic (pa-flag)
-		    (inst cfc1 status-save 31)
-		    (inst li new-status (lognot 3))
-		    (inst and new-status status-save)
-		    (inst or new-status float-round-to-zero)
-		    (inst ctc1 new-status 31)
-
-		    ;; These instructions seem to be necessary to ensure that
-		    ;; the new modes affect the fcvt instruction.
-		    (inst nop)
-		    (inst cfc1 new-status 31)
-
-		    (note-this-location vop :internal-error)
-		    (inst fcvt :word ,from-format temp x)
-		    (inst mfc1 y temp)
-		    (inst nop)
-		    (inst ctc1 status-save 31))))))
-  (frob %unary-truncate/single-float single-reg single-float :single)
-  (frob %unary-truncate/double-float double-reg double-float :double))
-
-
-(define-vop (make-single-float)
-  (:args (bits :scs (signed-reg)))
-  (:results (res :scs (single-reg)))
-  (:arg-types signed-num)
-  (:result-types single-float)
-  (:translate make-single-float)
-  (:policy :fast-safe)
-  (:generator 2
-    (inst mtc1 res bits)
-    (inst nop)))
-
-(define-vop (make-double-float)
-  (:args (hi-bits :scs (signed-reg))
-	 (lo-bits :scs (unsigned-reg)))
-  (:results (res :scs (double-reg)))
-  (:arg-types signed-num unsigned-num)
-  (:result-types double-float)
-  (:translate make-double-float)
-  (:policy :fast-safe)
-  (:generator 2
-    (inst mtc1 res lo-bits)
-    (inst mtc1-odd res hi-bits)
-    (inst nop)))
-
-(define-vop (single-float-bits)
-  (:args (float :scs (single-reg)))
-  (:results (bits :scs (signed-reg)))
-  (:arg-types single-float)
-  (:result-types signed-num)
-  (:translate single-float-bits)
-  (:policy :fast-safe)
-  (:generator 2
-    (inst mfc1 bits float)
-    (inst nop)))
-
-(define-vop (double-float-high-bits)
-  (:args (float :scs (double-reg)))
-  (:results (hi-bits :scs (signed-reg)))
-  (:arg-types double-float)
-  (:result-types signed-num)
-  (:translate double-float-high-bits)
-  (:policy :fast-safe)
-  (:generator 2
-    (inst mfc1-odd hi-bits float)
-    (inst nop)))
-
-(define-vop (double-float-low-bits)
-  (:args (float :scs (double-reg)))
-  (:results (lo-bits :scs (unsigned-reg)))
-  (:arg-types double-float)
-  (:result-types unsigned-num)
-  (:translate double-float-low-bits)
-  (:policy :fast-safe)
-  (:generator 2
-    (inst mfc1 lo-bits float)
-    (inst nop)))
-
-
-;;;; Float mode hackery:
-
-(deftype float-modes () '(unsigned-byte 24))
-(defknown floating-point-modes () float-modes (flushable))
-(defknown ((setf floating-point-modes)) (float-modes)
-  float-modes)
-
-(define-vop (floating-point-modes)
-  (:results (res :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:translate floating-point-modes)
-  (:policy :fast-safe)
-  (:generator 3
-    (inst cfc1 res 31)
-    (inst nop)))
-
-(define-vop (set-floating-point-modes)
-  (:args (new :scs (unsigned-reg) :target res))
-  (:results (res :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:result-types unsigned-num)
-  (:translate (setf floating-point-modes))
-  (:policy :fast-safe)
-  (:generator 3
-    (inst ctc1 res 31)
-    (move res new)))
diff --git a/compiler/mips/insts.lisp b/compiler/mips/insts.lisp
deleted file mode 100644
index 89dde81a81d54757d2e5b0bbc1a7851368482c2e..0000000000000000000000000000000000000000
--- a/compiler/mips/insts.lisp
+++ /dev/null
@@ -1,1273 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/insts.lisp,v 1.43 1992/07/23 16:25:22 hallgren Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Description of the MIPS architecture.
-;;;
-;;; Written by William Lott
-;;;
-(in-package "MIPS")
-
-(use-package "NEW-ASSEM")
-(use-package "EXT")
-(use-package "C")
-
-(def-assembler-params
-    :scheduler-p nil)
-
-
-;;;; Constants, types, conversion functions, some disassembler stuff.
-
-(defun reg-tn-encoding (tn)
-  (declare (type tn tn))
-  (sc-case tn
-    (zero zero-offset)
-    (null null-offset)
-    (t
-     (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
-	 (tn-offset tn)
-	 (error "~S isn't a register." tn)))))
-
-(defun fp-reg-tn-encoding (tn)
-  (declare (type tn tn))
-  (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
-    (error "~S isn't a floating-point register." tn))
-  (tn-offset tn))
-
-(disassem:set-disassem-params :instruction-alignment 32)
-
-(defvar *disassem-use-lisp-reg-names* t)
-
-(defconstant reg-symbols
-  (map 'vector
-       #'(lambda (name)
-	   (cond ((null name) nil)
-		 (t (make-symbol (concatenate 'string "$" name)))))
-       *register-names*))
-
-(disassem:define-argument-type reg
-  :printer #'(lambda (value stream dstate)
-	       (declare (stream stream) (fixnum value))
-	       (let ((regname (aref reg-symbols value)))
-		 (princ regname stream)
-		 (disassem:maybe-note-associated-storage-ref
-		  value
-		  'registers
-		  regname
-		  dstate))))
-
-(defconstant float-reg-symbols
-  (coerce 
-   (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
-   'vector))
-
-(disassem:define-argument-type fp-reg
-  :printer #'(lambda (value stream dstate)
-	       (declare (stream stream) (fixnum value))
-	       (let ((regname (aref float-reg-symbols value)))
-		 (princ regname stream)
-		 (disassem:maybe-note-associated-storage-ref
-		  value
-		  'float-registers
-		  regname
-		  dstate))))
-
-(disassem:define-argument-type control-reg
-  :printer "(CR:#x~X)")
-
-(disassem:define-argument-type relative-label
-  :sign-extend t
-  :use-label #'(lambda (value dstate)
-		 (declare (type (signed-byte 16) value)
-			  (type disassem:disassem-state dstate))
-		 (+ (ash (1+ value) 2) (disassem:dstate-cur-addr dstate))))
-
-(deftype float-format ()
-  '(member :s :single :d :double :w :word))
-
-(defun float-format-value (format)
-  (ecase format
-    ((:s :single) 0)
-    ((:d :double) 1)
-    ((:w :word) 4)))
-
-(disassem:define-argument-type float-format
-  :printer #'(lambda (value stream dstate)
-	       (declare (ignore dstate)
-			(stream stream)
-			(fixnum value))
-	       (princ (case value
-			(0 's)
-			(1 'd)
-			(4 'w)
-			(t '?))
-		      stream)))
-
-(defconstant compare-kinds
-  '(:f :un :eq :ueq :olt :ult :ole :ule :sf :ngle :seq :ngl :lt :nge :le :ngt))
-
-(defconstant compare-kinds-vec
-  (apply #'vector compare-kinds))
-
-(deftype compare-kind ()
-  `(member ,@compare-kinds))
-
-(defun compare-kind (kind)
-  (or (position kind compare-kinds)
-      (error "Unknown floating point compare kind: ~S~%Must be one of: ~S"
-	     kind
-	     compare-kinds)))
-
-(disassem:define-argument-type compare-kind
-  :printer compare-kinds-vec)
-
-(defconstant float-operations '(+ - * /))
-
-(deftype float-operation ()
-  `(member ,@float-operations))
-
-(defconstant float-operation-names
-  ;; this gets used for output only
-  #(add sub mul div))
-
-(defun float-operation (op)
-  (or (position op float-operations)
-      (error "Unknown floating point operation: ~S~%Must be one of: ~S"
-	     op
-	     float-operations)))
-
-(disassem:define-argument-type float-operation
-  :printer float-operation-names)
-
-
-
-;;;; Constants used by instruction emitters.
-
-(defconstant special-op #b000000)
-(defconstant bcond-op #b000001)
-(defconstant cop0-op #b010000)
-(defconstant cop1-op #b010001)
-(defconstant cop2-op #b010010)
-(defconstant cop3-op #b010011)
-
-
-
-;;;; dissassem:define-instruction-formats
-
-(defconstant immed-printer
-  '(:name :tab rt (:unless (:same-as rt) ", " rs) ", " immediate))
-
-;;; for things that use rt=0 as a nop
-(defconstant immed-zero-printer
-  '(:name :tab rt (:unless (:constant 0) ", " rs) ", " immediate))
-
-(disassem:define-instruction-format
-    (immediate 32 :default-printer immed-printer)
-  (op :field (byte 6 26))
-  (rs :field (byte 5 21) :type 'reg)
-  (rt :field (byte 5 16) :type 'reg)
-  (immediate :field (byte 16 0) :sign-extend t))
-
-(defconstant jump-printer
-  #'(lambda (value stream dstate)
-      (let ((addr (ash value 2)))
-	(disassem:maybe-note-assembler-routine addr dstate)
-	(write addr :base 16 :radix t :stream stream))))
-
-(disassem:define-instruction-format
-    (jump 32 :default-printer '(:name :tab target))
-  (op :field (byte 6 26))
-  (target :field (byte 26 0) :printer jump-printer))
-
-(defconstant reg-printer
-  '(:name :tab rd (:unless (:same-as rd) ", " rs) ", " rt))
-
-(disassem:define-instruction-format
-    (register 32 :default-printer reg-printer)
-  (op :field (byte 6 26))
-  (rs :field (byte 5 21) :type 'reg)
-  (rt :field (byte 5 16) :type 'reg)
-  (rd :field (byte 5 11) :type 'reg)
-  (shamt :field (byte 5 6) :value 0)
-  (funct :field (byte 6 0)))
-
-(disassem:define-instruction-format
-    (break 32 :default-printer
-	   '(:name :tab code (:unless (:constant 0) subcode)))
-  (op :field (byte 6 26) :value special-op)
-  (code :field (byte 10 16))
-  (subcode :field (byte 10 6) :value 0)
-  (funct :field (byte 6 0) :value #b001101))
-
-(disassem:define-instruction-format
-    (coproc-branch 32 :default-printer '(:name :tab offset))
-  (op :field (byte 6 26))
-  (funct :field (byte 10 16))
-  (offset :field (byte 16 0)))
-
-(defconstant float-fmt-printer
-  '((:unless :constant funct)
-    (:choose (:unless :constant sub-funct) nil)
-    "." format))
-
-(defconstant float-printer
-  `(:name ,@float-fmt-printer
-	  :tab
-	  fd
-	  (:unless (:same-as fd) ", " fs)
-	  ", " ft))
-
-(disassem:define-instruction-format
-    (float 32 :default-printer float-printer)
-  (op :field (byte 6 26) :value cop1-op)
-  (filler :field (byte 1 25) :value 1)
-  (format :field (byte 4 21) :type 'float-format)
-  (ft :field (byte 5 16) :value 0)
-  (fs :field (byte 5 11) :type 'fp-reg)
-  (fd :field (byte 5 6) :type 'fp-reg)
-  (funct :field (byte 6 0)))
-
-(disassem:define-instruction-format
-    (float-aux 32 :default-printer float-printer)
-  (op :field (byte 6 26) :value cop1-op)
-  (filler-1 :field (byte 1 25) :value 1)
-  (format :field (byte 4 21) :type 'float-format)
-  (ft :field (byte 5 16) :type 'fp-reg)
-  (fs :field (byte 5 11) :type 'fp-reg)
-  (fd :field (byte 5 6) :type 'fp-reg)
-  (funct :field (byte 2 4))
-  (sub-funct :field (byte 4 0)))
-
-
-
-;;;; Primitive emitters.
-
-(define-emitter emit-word 32
-  (byte 32 0))
-
-(define-emitter emit-short 16
-  (byte 16 0))
-
-(define-emitter emit-immediate-inst 32
-  (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))
-
-(define-emitter emit-jump-inst 32
-  (byte 6 26) (byte 26 0))
-
-(define-emitter emit-register-inst 32
-  (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 5 6) (byte 6 0))
-
-(define-emitter emit-break-inst 32
-  (byte 6 26) (byte 10 16) (byte 10 6) (byte 6 0))
-
-(define-emitter emit-float-inst 32
-  (byte 6 26) (byte 1 25) (byte 4 21) (byte 5 16)
-  (byte 5 11) (byte 5 6) (byte 6 0))
-
-
-
-;;;; Math instructions.
-
-(defun emit-math-inst (segment dst src1 src2 reg-opcode immed-opcode
-			       &optional allow-fixups)
-  (unless src2
-    (setf src2 src1)
-    (setf src1 dst))
-  (etypecase src2
-    (tn
-     (emit-register-inst segment special-op (reg-tn-encoding src1)
-			 (reg-tn-encoding src2) (reg-tn-encoding dst)
-			 0 reg-opcode))
-    (integer
-     (emit-immediate-inst segment immed-opcode (reg-tn-encoding src1)
-			  (reg-tn-encoding dst) src2))
-    (fixup
-     (unless allow-fixups
-       (error "Fixups aren't allowed."))
-     (note-fixup segment :addi src2)
-     (emit-immediate-inst segment immed-opcode (reg-tn-encoding src1)
-			  (reg-tn-encoding dst) 0))))
-
-(define-instruction add (segment dst src1 &optional src2)
-  (:declare (type tn dst)
-	    (type (or tn (signed-byte 16) null) src1 src2))
-  (:printer register ((op special-op) (funct #b100000)))
-  (:printer immediate ((op #b001000)))
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (emit-math-inst segment dst src1 src2 #b100000 #b001000)))
-
-(define-instruction addu (segment dst src1 &optional src2)
-  (:declare (type tn dst)
-	    (type (or tn (signed-byte 16) fixup null) src1 src2))
-  (:printer register ((op special-op) (funct #b100001)))
-  (:printer immediate ((op #b001001)))
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (emit-math-inst segment dst src1 src2 #b100001 #b001001 t)))
-
-(define-instruction sub (segment dst src1 &optional src2)
-  (:declare
-   (type tn dst)
-   (type (or tn (integer #.(- 1 (ash 1 15)) #.(ash 1 15)) null) src1 src2))
-  (:printer register ((op special-op) (funct #b100010)))
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (unless src2
-     (setf src2 src1)
-     (setf src1 dst))
-   (emit-math-inst segment dst src1
-		   (if (integerp src2) (- src2) src2)
-		   #b100010 #b001000)))
-
-(define-instruction subu (segment dst src1 &optional src2)
-  (:declare
-   (type tn dst)
-   (type
-    (or tn (integer #.(- 1 (ash 1 15)) #.(ash 1 15)) fixup null) src1 src2))
-  (:printer register ((op special-op) (funct #b100011)))
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (unless src2
-     (setf src2 src1)
-     (setf src1 dst))
-   (emit-math-inst segment dst src1
-		   (if (integerp src2) (- src2) src2)
-		   #b100011 #b001001 t)))
-
-(define-instruction and (segment dst src1 &optional src2)
-  (:declare (type tn dst)
-	    (type (or tn (unsigned-byte 16) null) src1 src2))
-  (:printer register ((op special-op) (funct #b100100)))
-  (:printer immediate ((op #b001100) (immediate nil :sign-extend nil)))
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (emit-math-inst segment dst src1 src2 #b100100 #b001100)))
-
-(define-instruction or (segment dst src1 &optional src2)
-  (:declare (type tn dst)
-	    (type (or tn (unsigned-byte 16) null) src1 src2))
-  (:printer register ((op special-op) (funct #b100101)))
-  (:printer immediate ((op #b001101)))
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (emit-math-inst segment dst src1 src2 #b100101 #b001101)))
-
-(define-instruction xor (segment dst src1 &optional src2)
-  (:declare (type tn dst)
-	    (type (or tn (unsigned-byte 16) null) src1 src2))
-  (:printer register ((op special-op) (funct #b100110)))
-  (:printer immediate ((op #b001110)))
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (emit-math-inst segment dst src1 src2 #b100110 #b001110)))
-
-(define-instruction nor (segment dst src1 &optional src2)
-  (:declare (type tn dst src1) (type (or tn null) src2))
-  (:printer register ((op special-op) (funct #b100111)))
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (emit-math-inst segment dst src1 src2 #b100111 #b000000)))
-
-(define-instruction slt (segment dst src1 &optional src2)
-  (:declare (type tn dst)
-	    (type (or tn (signed-byte 16) null) src1 src2))
-  (:printer register ((op special-op) (funct #b101010)))
-  (:printer immediate ((op #b001010)))
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (emit-math-inst segment dst src1 src2 #b101010 #b001010)))
-
-(define-instruction sltu (segment dst src1 &optional src2)
-  (:declare (type tn dst)
-	    (type (or tn (signed-byte 16) null) src1 src2))
-  (:printer register ((op special-op) (funct #b101011)))
-  (:printer immediate ((op #b001011)))
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (emit-math-inst segment dst src1 src2 #b101011 #b001011)))
-
-(defconstant divmul-printer '(:name :tab rs ", " rt))
-
-(define-instruction div (segment src1 src2)
-  (:declare (type tn src1 src2))
-  (:printer register ((op special-op) (rd 0) (funct #b011010)) divmul-printer)
-  (:reads (list src1 src2))
-  (:writes (list :hi-reg :low-reg))
-  (:delay 1)
-  (:emitter
-   (emit-register-inst segment special-op (reg-tn-encoding src1)
-		       (reg-tn-encoding src2) 0 0 #b011010)))
-
-(define-instruction divu (segment src1 src2)
-  (:declare (type tn src1 src2))
-  (:printer register ((op special-op) (rd 0) (funct #b011011))
-	    divmul-printer)
-  (:reads (list src1 src2))
-  (:writes (list :hi-reg :low-reg))
-  (:delay 1)
-  (:emitter
-   (emit-register-inst segment special-op (reg-tn-encoding src1)
-		       (reg-tn-encoding src2) 0 0 #b011011)))
-
-(define-instruction mult (segment src1 src2)
-  (:declare (type tn src1 src2))
-  (:printer register ((op special-op) (rd 0) (funct #b011000)) divmul-printer)
-  (:reads (list src1 src2))
-  (:writes (list :hi-reg :low-reg))
-  (:delay 1)
-  (:emitter
-   (emit-register-inst segment special-op (reg-tn-encoding src1)
-		       (reg-tn-encoding src2) 0 0 #b011000)))
-
-(define-instruction multu (segment src1 src2)
-  (:declare (type tn src1 src2))
-  (:printer register ((op special-op) (rd 0) (funct #b011001)))
-  (:reads (list src1 src2))
-  (:writes :hi-reg :low-reg)
-  (:delay 1)
-  (:emitter
-   (emit-register-inst segment special-op (reg-tn-encoding src1)
-		       (reg-tn-encoding src2) 0 0 #b011001)))
-
-(defun emit-shift-inst (segment opcode dst src1 src2)
-  (unless src2
-    (setf src2 src1)
-    (setf src1 dst))
-  (etypecase src2
-    (tn
-     (emit-register-inst segment special-op (reg-tn-encoding src2)
-			 (reg-tn-encoding src1) (reg-tn-encoding dst)
-			 0 (logior #b000100 opcode)))
-    ((unsigned-byte 5)
-     (emit-register-inst segment special-op 0 (reg-tn-encoding src1)
-			 (reg-tn-encoding dst) src2 opcode))))
-
-(defconstant shift-printer
-  '(:name :tab
-          rd
-          (:unless (:same-as rd) ", " rt)
-          ", " (:cond ((rs :constant 0) shamt)
-                      (t rs))))
-
-(define-instruction sll (segment dst src1 &optional src2)
-  (:declare (type tn dst)
-	    (type (or tn (unsigned-byte 5) null) src1 src2))
-  (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000000))
-	    shift-printer)
-  (:printer register ((op special-op) (funct #b000100)) shift-printer)
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (emit-shift-inst segment #b00 dst src1 src2)))
-
-(define-instruction sra (segment dst src1 &optional src2)
-  (:declare (type tn dst)
-	    (type (or tn (unsigned-byte 5) null) src1 src2))
-  (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000011))
-	    shift-printer)
-  (:printer register ((op special-op) (funct #b000111)) shift-printer)
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (emit-shift-inst segment #b11 dst src1 src2)))
-
-(define-instruction srl (segment dst src1 &optional src2)
-  (:declare (type tn dst)
-	    (type (or tn (unsigned-byte 5) null) src1 src2))
-  (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000010))
-	    shift-printer)
-  (:printer register ((op special-op) (funct #b000110)) shift-printer)
-  (:reads (if src2 (list src1 src2) (list dst src1)))
-  (:writes dst)
-  (:emitter
-   (emit-shift-inst segment #b10 dst src1 src2)))
-
-
-;;;; Floating point math.
-
-(define-instruction float-op (segment operation format dst src1 src2)
-  (:declare (type float-operation operation)
-	    (type float-format format)
-	    (type tn dst src1 src2))
-  (:reads (list src1 src2))
-  (:writes dst)
-  (:emitter
-   (emit-float-inst segment cop1-op 1 (float-format-value format)
-		    (fp-reg-tn-encoding src2) (fp-reg-tn-encoding src1)
-		    (fp-reg-tn-encoding dst) (float-operation operation))))
-
-(defconstant float-unop-printer
-  `(:name ,@float-fmt-printer :tab fd (:unless (:same-as fd) ", " fs)))
-
-(define-instruction fabs (segment format dst &optional (src dst))
-  (:declare (type float-format format) (type tn dst src))
-;  (:printer float ((funct #b000101)) float-unop-printer)
-  (:reads src)
-  (:writes dst)
-  (:emitter
-   (emit-float-inst segment cop1-op 1 (float-format-value format)
-		    0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
-		    #b000101)))
-
-(define-instruction fneg (segment format dst &optional (src dst))
-  (:declare (type float-format format) (type tn dst src))
-;  (:printer float ((funct #b000111)) float-unop-printer)
-  (:reads src)
-  (:writes dst)
-  (:emitter
-   (emit-float-inst segment cop1-op 1 (float-format-value format)
-		    0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
-		    #b000111)))
-  
-(define-instruction fcvt (segment format1 format2 dst src)
-  (:declare (type float-format format1 format2) (type tn dst src))
-  (:printer float-aux ((funct #b10) (sub-funct nil :type 'float-format))
-	   `(:name "." sub-funct "." format :tab fd ", " fs))
-  (:reads src)
-  (:writes dst)
-  (:emitter
-   (emit-float-inst segment cop1-op 1 (float-format-value format2) 0
-		    (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
-		    (logior #b100000 (float-format-value format1)))))
-
-(define-instruction fcmp (segment operation format fs ft)
-  (:declare (type compare-kind operation)
-	    (type float-format format)
-	    (type tn fs ft))
-  (:printer float-aux ((fd 0) (funct #b11) (sub-funct nil :type 'compare-kind))
-	    `(:name "-" sub-funct "." format :tab fs ", " ft))
-  (:reads (list fs ft))
-  (:writes :float-status)
-  (:delay 1)
-  (:emitter
-   (emit-float-inst segment cop1-op 1 (float-format-value format) 
-		    (fp-reg-tn-encoding ft) (fp-reg-tn-encoding fs) 0
-		    (logior #b110000 (compare-kind operation)))))
-
-
-;;;; Branch/Jump instructions.
-
-(defun emit-relative-branch (segment opcode r1 r2 target)
-  (emit-back-patch segment 4
-		   #'(lambda (segment posn)
-		       (emit-immediate-inst segment
-					    opcode
-					    (if (fixnump r1)
-						r1
-						(reg-tn-encoding r1))
-					    (if (fixnump r2)
-						r2
-						(reg-tn-encoding r2))
-					    (ash (- (label-position target)
-						    (+ posn 4))
-						 -2)))))
-
-(define-instruction b (segment target)
-  (:declare (type label target))
-  (:printer immediate ((op #b000100) (rs 0) (rt 0)
-		       (immediate nil :type 'relative-label))
-	    '(:name :tab immediate))
-  (:attributes branch)
-  (:delay 1)
-  (:emitter
-   (emit-relative-branch segment #b000100 0 0 target)))
-
-
-(define-instruction beq (segment r1 r2-or-target &optional target)
-  (:declare (type tn r1)
-	    (type (or tn fixnum label) r2-or-target)
-	    (type (or label null) target))
-  (:printer immediate ((op #b000100) (immediate nil :type 'relative-label)))
-  (:attributes branch)
-  (:delay 1)
-  (:reads (list r1 r2-or-target))
-  (:emitter
-   (unless target
-     (setf target r2-or-target)
-     (setf r2-or-target 0))
-   (emit-relative-branch segment #b000100 r1 r2-or-target target)))
-
-(define-instruction bne (segment r1 r2-or-target &optional target)
-  (:declare (type tn r1)
-	    (type (or tn fixnum label) r2-or-target)
-	    (type (or label null) target))
-  (:printer immediate ((op #b000101) (immediate nil :type 'relative-label)))
-  (:attributes branch)
-  (:delay 1)
-  (:reads (list r1 r2-or-target))
-  (:emitter
-   (unless target
-     (setf target r2-or-target)
-     (setf r2-or-target 0))
-   (emit-relative-branch segment #b000101 r1 r2-or-target target)))
-
-(defconstant cond-branch-printer
-  '(:name :tab rs ", " immediate))
-
-(define-instruction blez (segment reg target)
-  (:declare (type label target) (type tn reg))
-  (:printer
-   immediate ((op #b000110) (rt 0) (immediate nil :type 'relative-label))
-	    cond-branch-printer)
-  (:attributes branch)
-  (:delay 1)
-  (:reads reg)
-  (:emitter
-   (emit-relative-branch segment #b000110 reg 0 target)))
-
-(define-instruction bgtz (segment reg target)
-  (:declare (type label target) (type tn reg))
-  (:printer
-   immediate ((op #b000111) (rt 0) (immediate nil :type 'relative-label))
-	    cond-branch-printer)
-  (:attributes branch)
-  (:delay 1)
-  (:reads reg)
-  (:emitter
-   (emit-relative-branch segment #b000111 reg 0 target)))
-
-(define-instruction bltz (segment reg target)
-  (:declare (type label target) (type tn reg))
-  (:printer
-   immediate ((op bcond-op) (rt 0) (immediate nil :type 'relative-label))
-	    cond-branch-printer)
-  (:attributes branch)
-  (:delay 1)
-  (:reads reg)
-  (:emitter
-   (emit-relative-branch segment bcond-op reg #b00000 target)))
-
-(define-instruction bgez (segment reg target)
-  (:declare (type label target) (type tn reg))
-  (:printer
-   immediate ((op bcond-op) (rt 1) (immediate nil :type 'relative-label))
-	    cond-branch-printer)
-  (:attributes branch)
-  (:delay 1)
-  (:reads reg)
-  (:emitter
-   (emit-relative-branch segment bcond-op reg #b00001 target)))
-
-(define-instruction bltzal (segment reg target)
-  (:declare (type label target) (type tn reg))
-  (:printer
-   immediate ((op bcond-op) (rt #b01000) (immediate nil :type 'relative-label))
-	    cond-branch-printer)
-  (:attributes branch)
-  (:delay 1)
-  (:reads reg)
-  (:writes :r31)
-  (:emitter
-   (emit-relative-branch segment bcond-op reg #b01000 target)))
-
-(define-instruction bgezal (segment reg target)
-  (:declare (type label target) (type tn reg))
-  (:printer
-   immediate ((op bcond-op) (rt #b01001) (immediate nil :type 'relative-label))
-	    cond-branch-printer)
-  (:attributes branch)
-  (:delay 1)
-  (:reads reg)
-  (:writes :r31)
-  (:emitter
-   (emit-relative-branch segment bcond-op reg #b01001 target)))
-
-(defconstant j-printer
- '(:name :tab (:choose rs target)))
-
-(define-instruction j (segment target)
-  (:declare (type (or tn fixup) target))
-  (:printer register ((op special-op) (rt 0) (rd 0) (funct #b001000)) j-printer)
-  (:printer jump ((op #b000010)) j-printer)
-  (:attributes branch)
-  (:delay 1)
-  (:emitter
-   (etypecase target
-     (tn
-      (emit-register-inst segment special-op (reg-tn-encoding target)
-			  0 0 0 #b001000))
-     (fixup
-      (note-fixup segment :jump target)
-      (emit-jump-inst segment #b000010 0)))))
-
-(define-instruction jal (segment reg-or-target &optional target)
-  (:declare (type (or null tn fixup) target)
-	    (type (or tn fixup (integer -16 31)) reg-or-target))
-  (:printer register ((op special-op) (rt 0) (funct #b001001)) j-printer)
-  (:printer jump ((op #b000011)) j-printer)
-  (:attributes branch)
-  (:delay 1)
-  (:writes (if target reg-or-target :r31))  ; ### fix this
-  (:emitter
-   (unless target
-     (setf target reg-or-target)
-     (setf reg-or-target 31))
-   (etypecase target
-     (tn
-      (emit-register-inst segment special-op (reg-tn-encoding target) 0
-			  reg-or-target 0 #b001001))
-     (fixup
-      (note-fixup segment :jump target)
-      (emit-jump-inst segment #b000011 0)))))
-
-(define-instruction bc1f (segment target)
-  (:declare (type label target))
-  (:printer coproc-branch ((op cop1-op) (funct #x100)
-			   (offset nil :type 'relative-label)))
-  (:reads :float-status)
-  (:attributes branch)
-  (:delay 1)
-  (:emitter
-   (emit-relative-branch segment cop1-op #b01000 #b00000 target)))
-
-(define-instruction bc1t (segment target)
-  (:declare (type label target))
-  (:printer coproc-branch ((op cop1-op) (funct #x101)
-			   (offset nil :type 'relative-label)))
-  (:reads :float-status)
-  (:attributes branch)
-  (:delay 1)
-  (:emitter
-   (emit-relative-branch segment cop1-op #b01000 #b00001 target)))
-
-
-
-;;;; Random movement instructions.
-
-(eval-when (compile load eval)
-  (defun lui-arg-printer (value stream dstate)
-    (declare (ignore dstate))
-    (format stream "#x~4,'0X" value)))
-
-(define-instruction lui (segment reg value)
-  (:declare (type tn reg)
-	    (type (or fixup (signed-byte 16) (unsigned-byte 16)) value))
-  (:printer immediate ((op #b001111) (immed nil :printer #'lui-arg-printer)))
-  (:writes reg)
-  (:emitter
-   (when (fixup-p value)
-     (note-fixup segment :lui value)
-     (setf value 0))
-   (emit-immediate-inst segment #b001111 0 (reg-tn-encoding reg) value)))
-
-(defconstant mvsreg-printer '(:name :tab rd))
-
-(define-instruction mfhi (segment reg)
-  (:declare (type tn reg))
-  (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010000))
-	    mvsreg-printer)
-  (:reads :hi-reg)
-  (:writes reg)
-  (:delay 2)
-  (:emitter
-   (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
-			#b010000)))
-
-(define-instruction mthi (segment reg)
-  (:declare (type tn reg))
-  (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010001))
-	    mvsreg-printer)
-  (:reads reg)
-  (:writes :hi-reg)
-  (:emitter
-   (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
-			#b010001)))
-
-(define-instruction mflo (segment reg)
-  (:declare (type tn reg))
-  (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010010))
-	    mvsreg-printer)
-  (:reads :low-reg)
-  (:writes reg)
-  (:delay 2)
-  (:emitter
-   (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
-			#b010010)))
-
-(define-instruction mtlo (segment reg)
-  (:declare (type tn reg))
-  (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010011))
-	    mvsreg-printer)
-  (:reads reg)
-  (:writes :low-reg)
-  (:emitter
-   (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
-			#b010011)))
-
-(define-instruction move (segment dst src)
-  (:declare (type tn dst src))
-  (:printer register ((op special-op) (rt 0) (funct #b100001))
-	    '(:name :tab rd ", " rs))
-  (:reads src)
-  (:writes dst)
-  (:attributes flushable)
-  (:emitter
-   (emit-register-inst segment special-op (reg-tn-encoding src) 0
-		       (reg-tn-encoding dst) 0 #b100001)))
-
-(define-instruction fmove (segment format dst src)
-  (:declare (type float-format format) (type tn dst src))
-  (:printer float ((funct #b000110)) '(:name :tab fd ", " fs))
-  (:reads src)
-  (:writes dst)
-  (:attributes flushable)
-  (:emitter
-   (emit-float-inst segment cop1-op 1 (float-format-value format) 0
-		    (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
-		    #b000110)))
-
-(defun %li (reg value)
-  (etypecase value
-    ((unsigned-byte 16)
-     (inst or reg zero-tn value))
-    ((signed-byte 16)
-     (inst addu reg zero-tn value))
-    ((or (signed-byte 32) (unsigned-byte 32))
-     (inst lui reg (ldb (byte 16 16) value))
-     (inst or reg (ldb (byte 16 0) value)))
-    (fixup
-     (inst lui reg value)
-     (inst addu reg value))))
-  
-(define-instruction-macro li (reg value)
-  `(%li ,reg ,value))
-
-(defconstant sub-op-printer '(:name :tab rd ", " rt))
-
-(define-instruction mtc1 (segment to from)
-  (:declare (type tn to from))
-  (:printer register ((op cop1-op) (rs #b00100) (funct 0)) sub-op-printer)
-  (:reads from)
-  (:writes to)
-  (:delay 1)
-  (:emitter
-   (emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from)
-		       (fp-reg-tn-encoding to) 0 0)))
-
-(define-instruction mtc1-odd (segment to from)
-  (:declare (type tn to from))
-  (:reads from)
-  (:writes to)
-  (:delay 1)
-  (:emitter
-   (emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from)
-		       (1+ (fp-reg-tn-encoding to)) 0 0)))
-
-(define-instruction mfc1 (segment to from)
-  (:declare (type tn to from))
-  (:printer register ((op cop1-op) (rs 0) (rd nil :type 'fp-reg) (funct 0))
-	    sub-op-printer)
-  (:reads from)
-  (:writes to)
-  (:emitter
-   (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to)
-		       (fp-reg-tn-encoding from) 0 0)))
-
-(define-instruction mfc1-odd (segment to from)
-  (:declare (type tn to from))
-  (:reads from)
-  (:writes to)
-  (:emitter
-   (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to)
-		       (1+ (fp-reg-tn-encoding from)) 0 0)))
-
-(define-instruction cfc1 (segment reg cr)
-  (:declare (type tn reg) (type (unsigned-byte 5) cr))
-  (:printer register ((op cop1-op) (rs #b00010) (rd nil :type 'control-reg)
-		      (funct 0)) sub-op-printer)
-  (:reads nil) ;; ### fix this
-  (:writes reg)
-  (:emitter
-   (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding reg)
-		       cr 0 0)))
-
-(define-instruction ctc1 (segment reg cr)
-  (:declare (type tn reg) (type (unsigned-byte 5) cr))
-  (:printer register ((op cop1-op) (rs #b00110) (rd nil :type 'control-reg)
-		      (funct 0)) sub-op-printer)
-  (:reads reg)
-  (:writes nil) ;; ### fix this
-  (:emitter
-   (emit-register-inst segment cop1-op #b00110 (reg-tn-encoding reg)
-		       cr 0 0)))
-
-
-
-;;;; Random system hackery and other noise
-
-(define-instruction-macro entry-point ()
-  nil)
-
-(define-emitter emit-break-inst 32
-  (byte 6 26) (byte 10 16) (byte 10 6) (byte 6 0))
-
-(defun snarf-error-junk (sap offset &optional length-only)
-  (let* ((length (system:sap-ref-8 sap offset))
-         (vector (make-array length :element-type '(unsigned-byte 8))))
-    (declare (type system:system-area-pointer sap)
-             (type (unsigned-byte 8) length)
-             (type (simple-array (unsigned-byte 8) (*)) vector))
-    (cond (length-only
-           (values 0 (1+ length) nil nil))
-          (t
-           (kernel:copy-from-system-area sap (* mips:byte-bits (1+ offset))
-                                         vector (* mips:word-bits
-                                                   mips:vector-data-offset)
-                                         (* length mips:byte-bits))
-           (collect ((sc-offsets)
-                     (lengths))
-             (lengths 1)                ; the length byte
-             (let* ((index 0)
-                    (error-number (c::read-var-integer vector index)))
-               (lengths index)
-               (loop
-                 (when (>= index length)
-                   (return))
-                 (let ((old-index index))
-                   (sc-offsets (c::read-var-integer vector index))
-                   (lengths (- index old-index))))
-               (values error-number
-                       (1+ length)
-                       (sc-offsets)
-                       (lengths))))))))
-
-(defmacro break-cases (breaknum &body cases)
-  (let ((bn-temp (gensym)))
-    (collect ((clauses))
-      (dolist (case cases)
-        (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
-      `(let ((,bn-temp ,breaknum))
-         (cond ,@(clauses))))))
-
-(defun break-control (chunk inst stream dstate)
-  (declare (ignore inst))
-  (flet ((nt (x) (if stream (disassem:note x dstate))))
-    (case (break-code chunk dstate)
-      (#.vm:error-trap
-       (nt "Error trap")
-       (disassem:handle-break-args #'snarf-error-junk stream dstate))
-      (#.vm:cerror-trap
-       (nt "Cerror trap")
-       (disassem:handle-break-args #'snarf-error-junk stream dstate))
-      (#.vm:breakpoint-trap
-       (nt "Breakpoint trap"))
-      (#.vm:pending-interrupt-trap
-       (nt "Pending interrupt trap"))
-      (#.vm:halt-trap
-       (nt "Halt trap"))
-      (#.vm:function-end-breakpoint-trap
-       (nt "Function end breakpoint trap"))
-    )))
-
-(define-instruction break (segment code &optional (subcode 0))
-  (:declare (type (unsigned-byte 10) code subcode))
-  (:printer break ((op special-op) (funct #b001101))
-	    '(:name :tab code (:unless (:constant 0) subcode))
-	    :control #'break-control )
-  :pinned
-  (:emitter
-   (emit-break-inst segment special-op code subcode #b001101)))
-
-(define-instruction syscall (segment)
-  :pinned
-  (:printer register ((op special-op) (rd 0) (rt 0) (rs 0) (funct #b001100))
-	    '(:name))
-  (:emitter
-   (emit-register-inst segment special-op 0 0 0 0 #b001100)))
-
-(define-instruction nop (segment)
-  (:attributes flushable)
-  (:printer register ((op 0) (rd 0) (rd 0) (rs 0) (funct 0)) '(:name))
-  (:emitter
-   (emit-word segment 0)))
-
-(define-instruction word (segment word)
-  (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
-  :pinned
-  (:emitter
-   (emit-word segment word)))
-
-(define-instruction short (segment short)
-  (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
-  :pinned
-  (:emitter
-   (emit-short segment short)))
-
-(define-instruction byte (segment byte)
-  (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
-  :pinned
-  (:emitter
-   (emit-byte segment byte)))
-
-
-(defun emit-header-data (segment type)
-  (emit-back-patch
-   segment 4
-   #'(lambda (segment posn)
-       (emit-word segment
-		  (logior type
-			  (ash (+ posn (component-header-length))
-			       (- type-bits word-shift)))))))
-
-(define-instruction function-header-word (segment)
-  :pinned
-  (:emitter
-   (emit-header-data segment function-header-type)))
-
-(define-instruction lra-header-word (segment)
-  :pinned
-  (:emitter
-   (emit-header-data segment return-pc-header-type)))
-
-
-(defun emit-compute-inst (segment vop dst src label temp calc)
-  (emit-chooser
-   ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
-   segment 12 3
-   #'(lambda (segment posn delta-if-after)
-       (let ((delta (funcall calc label posn delta-if-after)))
-	  (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
-	    (emit-back-patch segment 4
-			     #'(lambda (segment posn)
-				 (assemble (segment vop)
-					   (inst addu dst src
-						 (funcall calc label posn 0)))))
-	    t)))
-   #'(lambda (segment posn)
-       (let ((delta (funcall calc label posn 0)))
-	 (assemble (segment vop)
-		   (inst lui temp (ldb (byte 16 16) delta))
-		   (inst or temp (ldb (byte 16 0) delta))
-		   (inst addu dst src temp))))))
-
-;; code = fn - header - label-offset + other-pointer-tag
-(define-instruction compute-code-from-fn (segment dst src label temp)
-  (:declare (type tn dst src temp) (type label label))
-  (:reads src)
-  (:writes (list dst temp))
-  (:vop-var vop)
-  (:emitter
-   (emit-compute-inst segment vop dst src label temp
-		      #'(lambda (label posn delta-if-after)
-			  (- other-pointer-type
-			     (label-position label posn delta-if-after)
-			     (component-header-length))))))
-
-;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
-(define-instruction compute-code-from-lra (segment dst src label temp)
-  (:declare (type tn dst src temp) (type label label))
-  (:reads src)
-  (:writes (list dst temp))
-  (:vop-var vop)
-  (:emitter
-   (emit-compute-inst segment vop dst src label temp
-		      #'(lambda (label posn delta-if-after)
-			  (- (+ (label-position label posn delta-if-after)
-				(component-header-length)))))))
-
-;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
-(define-instruction compute-lra-from-code (segment dst src label temp)
-  (:declare (type tn dst src temp) (type label label))
-  (:reads src)
-  (:writes (list dst temp))
-  (:vop-var vop)
-  (:emitter
-   (emit-compute-inst segment vop dst src label temp
-		      #'(lambda (label posn delta-if-after)
-			  (+ (label-position label posn delta-if-after)
-			     (component-header-length))))))
-
-
-;;;; Loads and Stores
-
-(defun emit-load/store-inst (segment opcode reg base index)
-  (when (fixup-p index)
-    (note-fixup segment :addi index)
-    (setf index 0))
-  (emit-immediate-inst segment opcode (reg-tn-encoding reg)
-		       (reg-tn-encoding base) index))
-
-(defconstant load-store-printer
-  '(:name :tab
-          rt ", "
-          rs
-          (:unless (:constant 0) "[" immediate "]")))
-
-(define-instruction lb (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b100000)) load-store-printer)
-  (:reads (list base :memory))
-  (:writes reg)
-  (:delay 1)
-  (:emitter
-   (emit-load/store-inst segment #b100000 base reg index)))
-
-(define-instruction lh (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b100001)) load-store-printer)
-  (:reads (list base :memory))
-  (:writes reg)
-  (:delay 1)
-  (:emitter
-   (emit-load/store-inst segment #b100001 base reg index)))
-
-(define-instruction lwl (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b100010)) load-store-printer)
-  (:reads (list base :memory))
-  (:writes reg)
-  (:delay 1)
-  (:emitter
-   (emit-load/store-inst segment #b100010 base reg index)))
-
-(define-instruction lw (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b100011)) load-store-printer)
-  (:reads (list base :memory))
-  (:writes reg)
-  (:delay 1)
-  (:emitter
-   (emit-load/store-inst segment #b100011 base reg index)))
-
-(define-instruction lbu (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b100100)) load-store-printer)
-  (:reads (list base :memory))
-  (:writes reg)
-  (:delay 1)
-  (:emitter
-   (emit-load/store-inst segment #b100100 base reg index)))
-
-(define-instruction lhu (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b100101)) load-store-printer)
-  (:reads (list base :memory))
-  (:writes reg)
-  (:delay 1)
-  (:emitter
-   (emit-load/store-inst segment #b100101 base reg index)))
-
-(define-instruction lwr (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b100110)) load-store-printer)
-  (:reads (list base :memory))
-  (:writes reg)
-  (:delay 1)
-  (:emitter
-   (emit-load/store-inst segment #b100110 base reg index)))
-
-(define-instruction sb (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b101000)) load-store-printer)
-  (:reads base reg)
-  (:writes :memory)
-  (:emitter
-   (emit-load/store-inst segment #b101000 base reg index)))
-
-(define-instruction sh (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b101001)) load-store-printer)
-  (:reads base reg)
-  (:writes :memory)
-  (:emitter
-   (emit-load/store-inst segment #b101001 base reg index)))
-
-(define-instruction swl (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b101010)) load-store-printer)
-  (:reads base reg)
-  (:writes :memory)
-  (:emitter
-   (emit-load/store-inst segment #b101010 base reg index)))
-
-(define-instruction sw (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b101011)) load-store-printer)
-  (:reads base reg)
-  (:writes :memory)
-  (:emitter
-   (emit-load/store-inst segment #b101011 base reg index)))
-
-(define-instruction swr (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b101110)) load-store-printer)
-  (:reads base reg)
-  (:writes :memory)
-  (:emitter
-   (emit-load/store-inst segment #b101110 base reg index)))
-
-
-(defun emit-fp-load/store-inst (segment opcode reg odd base index)
-  (when (fixup-p index)
-    (note-fixup segment :addi index)
-    (setf index 0))
-  (emit-immediate-inst segment opcode (reg-tn-encoding base)
-		       (+ (fp-reg-tn-encoding reg) odd) index))
-
-(define-instruction lwc1 (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b110001) (rt nil :type 'fp-reg)) load-store-printer)
-  (:reads base :memory)
-  (:writes reg)
-  (:delay 1)
-  (:emitter
-   (emit-fp-load/store-inst segment #b110001 reg 0 base index)))
-
-(define-instruction lwc1-odd (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:reads base :memory)
-  (:writes reg)
-  (:delay 1)
-  (:emitter
-   (emit-fp-load/store-inst segment #b110001 reg 1 base index)))
-
-(define-instruction swc1 (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:printer immediate ((op #b111001) (rt nil :type 'fp-reg)) load-store-printer)
-  (:reads base reg)
-  (:writes :memory)
-  (:emitter
-   (emit-fp-load/store-inst segment #b111001 reg 0 base index)))
-
-(define-instruction swc1-odd (segment reg base &optional (index 0))
-  (:declare (type tn reg base)
-	    (type (or (signed-byte 16) fixup) index))
-  (:reads base reg)
-  (:writes :memory)
-  (:emitter
-   (emit-fp-load/store-inst segment #b111001 reg 1 base index)))
diff --git a/compiler/mips/macros.lisp b/compiler/mips/macros.lisp
deleted file mode 100644
index 57bb6e300b8e6cc74121a2d0577c2d61ad8aab16..0000000000000000000000000000000000000000
--- a/compiler/mips/macros.lisp
+++ /dev/null
@@ -1,485 +0,0 @@
-;;; -*- Package: MIPS; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.48 1993/01/13 16:08:25 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains various useful macros for generating MIPS code.
-;;;
-;;; Written by William Lott and Christopher Hoover.
-;;; 
-
-(in-package "MIPS")
-
-;;; 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 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 move ,n-dst ,n-src)
-	`(unless (location= ,n-dst ,n-src)
-	   (inst move ,n-dst ,n-src)))))
-
-(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 '('(inst nop))))))
-;;; 
-(def-mem-op loadw lw word-shift t)
-(def-mem-op storew sw word-shift nil)
-#+gengc
-(def-mem-op storew-and-remember-slot sw-and-remember-slot word-shift nil)
-#+gengc
-(def-mem-op storew-and-remember-object sw-and-remember-object word-shift nil)
-
-(defmacro load-symbol (reg symbol)
-  `(inst addu ,reg null-tn (static-symbol-offset ,symbol)))
-
-#-gengc
-(defmacro load-symbol-value (reg symbol)
-  `(progn
-     (inst lw ,reg null-tn
-	   (+ (static-symbol-offset ',symbol)
-	      (ash symbol-value-slot word-shift)
-	      (- other-pointer-type)))
-     (inst nop)))
-#-gengc
-(defmacro store-symbol-value (reg symbol)
-  `(inst sw ,reg null-tn
-	 (+ (static-symbol-offset ',symbol)
-	    (ash symbol-value-slot word-shift)
-	    (- other-pointer-type))))
-
-(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 (backend-byte-order *backend*)
-      (:little-endian
-       `(inst lbu ,n-target ,n-source ,n-offset ))
-      (:big-endian
-       `(inst lbu ,n-target ,n-source (+ ,n-offset 3))))))
-
-
-;;; Macros to handle the fact that we cannot use the machine native call and
-;;; return instructions. 
-
-#-gengc
-(defmacro lisp-jump (function lip)
-  "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
-  `(progn
-     (inst addu ,lip ,function (- (ash vm:function-header-code-offset
-					vm:word-shift)
-				   vm:function-pointer-type))
-     (inst j ,lip)
-     (move code-tn ,function)))
-
-#-gengc
-(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
-  "Return to RETURN-PC.  LIP is an interior-reg temporary."
-  `(progn
-     (inst addu ,lip ,return-pc
-	   (- (* (1+ ,offset) word-bytes) other-pointer-type))
-     (inst j ,lip)
-     ,(if frob-code
-	  `(move code-tn ,return-pc)
-	  '(inst nop))))
-
-
-(defmacro emit-return-pc (label)
-  "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
-  `(progn
-     #-gengc
-     (align lowtag-bits)
-     (emit-label ,label)
-     #-gengc
-     (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)
-  `(let ((reg ,reg)
-	 (stack ,stack))
-     (let ((offset (tn-offset stack)))
-       (sc-case stack
-	 ((control-stack)
-	  (loadw reg cfp-tn offset))))))
-
-(defmacro store-stack-tn (stack reg)
-  `(let ((stack ,stack)
-	 (reg ,reg))
-     (let ((offset (tn-offset stack)))
-       (sc-case stack
-	 ((control-stack)
-	  (storew reg cfp-tn offset))))))
-
-
-;;; MAYBE-LOAD-STACK-TN  --  Interface
-;;;
-(defmacro maybe-load-stack-tn (reg reg-or-stack)
-  "Move the TN Reg-Or-Stack into Reg if it isn't already there."
-  (once-only ((n-reg reg)
-	      (n-stack reg-or-stack))
-    `(sc-case ,n-reg
-       ((any-reg descriptor-reg)
-	(sc-case ,n-stack
-	  ((any-reg descriptor-reg)
-	   (move ,n-reg ,n-stack))
-	  ((control-stack)
-	   (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
-
-
-;;;; Storage allocation:
-
-#-gengc
-(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
-				 &body body)
-  "Do stuff to allocate an other-pointer object of fixed Size with a single
-   word header having the specified Type-Code.  The result is placed in
-   Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non-
-   descriptor temp (which may be randomly used by the body.)  The body is
-   placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
-  `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
-     (inst or ,result-tn alloc-tn other-pointer-type)
-     (inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code))
-     (storew ,temp-tn ,result-tn 0 other-pointer-type)
-     ,@body))
-
-#+gengc
-(defun fixed-allocate (result temp type-code size)
-  (assemble ()
-    (without-scheduling ()
-      (inst li temp (logior (ash (1- size) type-bits) type-code))
-      (inst or result alloc-tn other-pointer-type)
-      (inst sw temp alloc-tn)
-      (inst addu alloc-tn alloc-tn (pad-data-block size)))))
-
-#+gengc
-(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
-				 &body body)
-  (declare (ignore flag-tn))
-  `(progn
-     (fixed-allocate ,result-tn ,temp-tn ,type-code ,size)
-     ,@body))
-
-
-;;;; Three Way Comparison
-
-(defun three-way-comparison (x y condition flavor not-p target temp)
-  (ecase condition
-    (:eq
-     (if not-p
-	 (inst bne x y target)
-	 (inst beq x y target)))
-    (:lt
-     (ecase flavor
-       (:unsigned
-	(inst sltu temp x y))
-       (:signed
-	(inst slt temp x y)))
-     (if not-p
-	 (inst beq temp zero-tn target)
-	 (inst bne temp zero-tn target)))
-    (:gt
-     (ecase flavor
-       (:unsigned
-	(inst sltu temp y x))
-       (:signed
-	(inst slt temp y x)))
-     (if not-p
-	 (inst beq temp zero-tn target)
-	 (inst bne temp zero-tn target))))
-  (inst nop))
-
-
-
-;;;; Error Code
-
-
-(defvar *adjustable-vectors* nil)
-
-(defmacro with-adjustable-vector ((var) &rest body)
-  `(let ((,var (or (pop *adjustable-vectors*)
-		   (make-array 16
-			       :element-type '(unsigned-byte 8)
-			       :fill-pointer 0
-			       :adjustable t))))
-     (setf (fill-pointer ,var) 0)
-     (unwind-protect
-	 (progn
-	   ,@body)
-       (push ,var *adjustable-vectors*))))
-
-(eval-when (compile load eval)
-  (defun emit-error-break (vop kind code values)
-    (let ((vector (gensym)))
-      `((let ((vop ,vop))
-	  (when vop
-	    (note-this-location vop :internal-error)))
-	(inst break ,kind)
-	(with-adjustable-vector (,vector)
-	  (write-var-integer (error-number-or-lose ',code) ,vector)
-	  ,@(mapcar #'(lambda (tn)
-			`(let ((tn ,tn))
-			   (write-var-integer (make-sc-offset (sc-number
-							       (tn-sc tn))
-							      (tn-offset tn))
-					      ,vector)))
-		    values)
-	  (inst byte (length ,vector))
-	  (dotimes (i (length ,vector))
-	    (inst byte (aref ,vector i))))
-	(align word-shift)))))
-
-(defmacro error-call (vop error-code &rest values)
-  "Cause an error.  ERROR-CODE is the error to cause."
-  (cons 'progn
-	(emit-error-break vop error-trap error-code values)))
-
-
-(defmacro cerror-call (vop label error-code &rest values)
-  "Cause a continuable error.  If the error is continued, execution resumes at
-  LABEL."
-  `(progn
-     (inst b ,label)
-     ,@(emit-error-break vop cerror-trap error-code values)))
-
-(defmacro generate-error-code (vop error-code &rest values)
-  "Generate-Error-Code Error-code Value*
-  Emit code for an error with the specified Error-Code and context Values."
-  `(assemble (*elsewhere*)
-     (let ((start-lab (gen-label)))
-       (emit-label start-lab)
-       (error-call ,vop ,error-code ,@values)
-       start-lab)))
-
-(defmacro generate-cerror-code (vop error-code &rest values)
-  "Generate-CError-Code Error-code Value*
-  Emit code for a continuable error with the specified Error-Code and
-  context Values.  If the error is continued, execution resumes after
-  the GENERATE-CERROR-CODE form."
-  (let ((continue (gensym "CONTINUE-LABEL-"))
-	(error (gensym "ERROR-LABEL-")))
-    `(let ((,continue (gen-label)))
-       (emit-label ,continue)
-       (assemble (*elsewhere*)
-	 (let ((,error (gen-label)))
-	   (emit-label ,error)
-	   (cerror-call ,vop ,continue ,error-code ,@values)
-	   ,error)))))
-
-
-;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
-;;;
-(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
-  #+gengc
-  (unless (eql extra 0)
-    (error "Can't allocate any extra with pseudo-atomic in the gengc system."))
-  `(progn
-     (assert (= (tn-offset ,flag-tn) nl4-offset))
-     (without-scheduling ()
-       (inst li ,flag-tn #-gengc (1- ,extra) #+gengc -1)
-       (inst addu alloc-tn 1))
-     ,@forms
-     (without-scheduling ()
-       (inst add alloc-tn ,flag-tn))))
-
-
-
-;;;; Memory accessor vop generators
-
-(deftype load/store-index (scale lowtag min-offset
-				 &optional (max-offset min-offset))
-  `(integer ,(- (truncate (+ (ash 1 16)
-			     (* min-offset word-bytes)
-			     (- lowtag))
-			  scale))
-	    ,(truncate (- (+ (1- (ash 1 16)) lowtag)
-			  (* max-offset word-bytes))
-		       scale)))
-
-(defmacro define-full-reffer (name type offset lowtag scs el-type
-				   &optional translate)
-  `(progn
-     (define-vop (,name)
-       ,@(when translate
-	   `((:translate ,translate)))
-       (:policy :fast-safe)
-       (:args (object :scs (descriptor-reg))
-	      (index :scs (any-reg)))
-       (:arg-types ,type tagged-num)
-       (:temporary (:scs (interior-reg)) lip)
-       (:results (value :scs ,scs))
-       (:result-types ,el-type)
-       (:generator 5
-	 (inst add lip object index)
-	 (inst lw value lip (- (* ,offset word-bytes) ,lowtag))
-	 (inst nop)))
-     (define-vop (,(symbolicate name "-C"))
-       ,@(when translate
-	   `((:translate ,translate)))
-       (:policy :fast-safe)
-       (:args (object :scs (descriptor-reg)))
-       (:info index)
-       (:arg-types ,type
-		   (:constant (load/store-index ,word-bytes ,(eval lowtag)
-						,(eval offset))))
-       (:results (value :scs ,scs))
-       (:result-types ,el-type)
-       (:generator 4
-	 (inst lw value object (- (* (+ ,offset index) word-bytes) ,lowtag))
-	 (inst nop)))))
-
-(defmacro define-full-setter (name type offset lowtag scs el-type
-				   &optional translate #+gengc (remember t))
-  `(progn
-     (define-vop (,name)
-       ,@(when translate
-	   `((:translate ,translate)))
-       (:policy :fast-safe)
-       (:args (object :scs (descriptor-reg))
-	      (index :scs (any-reg))
-	      (value :scs ,scs :target result))
-       (:arg-types ,type tagged-num ,el-type)
-       (:temporary (:scs (interior-reg)) lip)
-       (:results (result :scs ,scs))
-       (:result-types ,el-type)
-       (:generator 2
-	 (inst add lip object index)
-	 (inst #+gengc ,(if remember 'sw-and-remember-slot 'sw) #-gengc sw
-	       value lip (- (* ,offset word-bytes) ,lowtag))
-	 (move result value)))
-     (define-vop (,(symbolicate name "-C"))
-       ,@(when translate
-	   `((:translate ,translate)))
-       (:policy :fast-safe)
-       (:args (object :scs (descriptor-reg))
-	      (value :scs ,scs))
-       (:info index)
-       (:arg-types ,type
-		   (:constant (load/store-index ,word-bytes ,(eval lowtag)
-						,(eval offset)))
-		   ,el-type)
-       (:results (result :scs ,scs))
-       (:result-types ,el-type)
-       (:generator 1
-	 (inst #+gengc ,(if remember 'sw-and-remember-slot 'sw) #-gengc sw
-	       value object (- (* (+ ,offset index) word-bytes) ,lowtag))
-	 (move result value)))))
-
-
-(defmacro define-partial-reffer (name type size signed offset lowtag scs
-				      el-type &optional translate)
-  (let ((scale (ecase size (:byte 1) (:short 2))))
-    `(progn
-       (define-vop (,name)
-	 ,@(when translate
-	     `((:translate ,translate)))
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(index :scs (unsigned-reg)))
-	 (:arg-types ,type positive-fixnum)
-	 (:results (value :scs ,scs))
-	 (:result-types ,el-type)
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:generator 5
-	   (inst addu lip object index)
-	   ,@(when (eq size :short)
-	       '((inst addu lip index)))
-	   (inst ,(ecase size
-		    (:byte (if signed 'lb 'lbu))
-		    (:short (if signed 'lh 'lhu)))
-		 value lip (- (* ,offset word-bytes) ,lowtag))
-	   (inst nop)))
-       (define-vop (,(symbolicate name "-C"))
-	 ,@(when translate
-	     `((:translate ,translate)))
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg)))
-	 (:info index)
-	 (:arg-types ,type
-		     (:constant (load/store-index ,scale
-						  ,(eval lowtag)
-						  ,(eval offset))))
-	 (:results (value :scs ,scs))
-	 (:result-types ,el-type)
-	 (:generator 5
-	   (inst ,(ecase size
-		    (:byte (if signed 'lb 'lbu))
-		    (:short (if signed 'lh 'lhu)))
-		 value object
-		 (- (+ (* ,offset word-bytes) (* index ,scale)) ,lowtag))
-	   (inst nop))))))
-
-(defmacro define-partial-setter (name type size offset lowtag scs el-type
-				      &optional translate)
-  (let ((scale (ecase size (:byte 1) (:short 2))))
-    `(progn
-       (define-vop (,name)
-	 ,@(when translate
-	     `((:translate ,translate)))
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(index :scs (unsigned-reg))
-		(value :scs ,scs :target result))
-	 (:arg-types ,type positive-fixnum ,el-type)
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:results (result :scs ,scs))
-	 (:result-types ,el-type)
-	 (:generator 5
-	   (inst addu lip object index)
-	   ,@(when (eq size :short)
-	       '((inst addu lip index)))
-	   (inst ,(ecase size (:byte 'sb) (:short 'sh))
-		 value lip (- (* ,offset word-bytes) ,lowtag))
-	   (move result value)))
-       (define-vop (,(symbolicate name "-C"))
-	 ,@(when translate
-	     `((:translate ,translate)))
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(value :scs ,scs :target result))
-	 (:info index)
-	 (:arg-types ,type
-		     (:constant (load/store-index ,scale
-						  ,(eval lowtag)
-						  ,(eval offset)))
-		     ,el-type)
-	 (:results (result :scs ,scs))
-	 (:result-types ,el-type)
-	 (:generator 5
-	   (inst ,(ecase size (:byte 'sb) (:short 'sh))
-		 value object
-		 (- (* ,offset word-bytes) (* index ,scale) ,lowtag))
-	   (move result value))))))
-
diff --git a/compiler/mips/memory.lisp b/compiler/mips/memory.lisp
deleted file mode 100644
index 04b98b6cffbf81031bc4c3241ce7b742b3727168..0000000000000000000000000000000000000000
--- a/compiler/mips/memory.lisp
+++ /dev/null
@@ -1,73 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/memory.lisp,v 1.14 1993/01/13 16:06:43 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 "MIPS")
-
-
-;;; 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.
-;;;
-(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)
-  #+gengc (:info remember)
-  (:policy :fast-safe)
-  (:generator 4
-    #+gengc
-    (if remember
-	(storew-and-remember-slot value object offset lowtag)
-	(storew value object offset lowtag))
-    #-gengc
-    (storew value object offset lowtag)))
-
-;;; 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 #+gengc remember)
-  (:generator 4
-    #+gengc
-    (if remember
-	(storew-and-remember-slot value object (+ base offset) lowtag)
-	(storew value object (+ base offset) lowtag))
-    #-gengc
-    (storew value object (+ base offset) lowtag)))
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 15cc0c2d1ef1f3022f3f732bfa2fa2aac5882643..0000000000000000000000000000000000000000
--- a/compiler/mips/move.lisp
+++ /dev/null
@@ -1,323 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.33 1993/01/13 16:05:52 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the MIPS VM definition of operand loading/saving and
-;;; the Move VOP.
-;;;
-;;; Written by Rob MacLachlan.
-;;; MIPS conversion by William Lott.
-;;;
-(in-package "MIPS")
-
-
-(define-move-function (load-immediate 1) (vop x y)
-  ((null zero immediate)
-   (any-reg descriptor-reg))
-  (let ((val (tn-value x)))
-    (etypecase val
-      (integer
-       (inst li y (fixnum val)))
-      (null
-       (move y null-tn))
-      (symbol
-       (load-symbol y val))
-      (character
-       (inst li y (logior (ash (char-code val) type-bits)
-			  base-char-type))))))
-
-(define-move-function (load-number 1) (vop x y)
-  ((zero immediate)
-   (signed-reg unsigned-reg))
-  (inst li y (tn-value x)))
-
-(define-move-function (load-base-char 1) (vop x y)
-  ((immediate) (base-char-reg))
-  (inst li y (char-code (tn-value x))))
-
-(define-move-function (load-system-area-pointer 1) (vop x y)
-  ((immediate) (sap-reg))
-  (inst li y (sap-int (tn-value x))))
-
-(define-move-function (load-constant 5) (vop x y)
-  ((constant) (descriptor-reg any-reg))
-  (loadw y code-tn (tn-offset x) other-pointer-type))
-
-(define-move-function (load-stack 5) (vop x y)
-  ((control-stack) (any-reg descriptor-reg))
-  (load-stack-tn y x))
-
-(define-move-function (load-number-stack 5) (vop x y)
-  ((base-char-stack) (base-char-reg)
-   (sap-stack) (sap-reg)
-   (signed-stack) (signed-reg)
-   (unsigned-stack) (unsigned-reg))
-  (let ((nfp (current-nfp-tn vop)))
-    (loadw y nfp (tn-offset x))))
-
-(define-move-function (store-stack 5) (vop x y)
-  ((any-reg descriptor-reg) (control-stack))
-  (store-stack-tn y x))
-
-(define-move-function (store-number-stack 5) (vop x y)
-  ((base-char-reg) (base-char-stack)
-   (sap-reg) (sap-stack)
-   (signed-reg) (signed-stack)
-   (unsigned-reg) (unsigned-stack))
-  (let ((nfp (current-nfp-tn vop)))
-    (storew x nfp (tn-offset y))))
-
-
-;;;; The Move VOP:
-;;;
-(define-vop (move)
-  (:args (x :target y
-	    :scs (any-reg descriptor-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (any-reg descriptor-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:generator 0
-    (move y x)))
-
-(define-move-vop move :move
-  (any-reg descriptor-reg)
-  (any-reg descriptor-reg))
-
-;;; 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)
-
-;;;    The Move-Argument VOP is used for moving descriptor values into another
-;;; frame for argument or known value passing.
-;;;
-(define-vop (move-argument)
-  (:args (x :target y
-	    :scs (any-reg descriptor-reg))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y any-reg descriptor-reg))))
-  (:results (y))
-  (:generator 0
-    (sc-case y
-      ((any-reg descriptor-reg)
-       (move y x))
-      (control-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-argument :move-argument
-  (any-reg descriptor-reg)
-  (any-reg descriptor-reg))
-
-
-
-;;;; 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)
-  (:args (x) (type))
-  (:results (y))
-  (:ignore y)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 666
-    (error-call vop object-not-type-error x type)))
-
-
-
-;;;; Moves and coercions:
-
-;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
-;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
-;;; to a tagged bignum or fixnum.
-
-;;; Arg is a fixnum, so just shift it.  We need a type restriction because some
-;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
-;;;
-(define-vop (move-to-word/fixnum)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (y :scs (signed-reg unsigned-reg)))
-  (:arg-types tagged-num)
-  (:note "fixnum untagging")
-  (:generator 1
-    (inst sra y x 2)))
-;;;
-(define-move-vop move-to-word/fixnum :move
-  (any-reg descriptor-reg) (signed-reg unsigned-reg))
-
-;;; Arg is a non-immediate constant, load it.
-(define-vop (move-to-word-c)
-  (:args (x :scs (constant)))
-  (:results (y :scs (signed-reg unsigned-reg)))
-  (:note "constant load")
-  (:generator 1
-    (inst li y (tn-value x))))
-;;;
-(define-move-vop move-to-word-c :move
-  (constant) (signed-reg unsigned-reg))
-
-;;; Arg is a fixnum or bignum, figure out which and load if necessary.
-(define-vop (move-to-word/integer)
-  (:args (x :scs (descriptor-reg)))
-  (:results (y :scs (signed-reg unsigned-reg)))
-  (:note "integer to untagged word coercion")
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 3
-    (let ((done (gen-label)))
-      (inst and temp x 3)
-      (inst beq temp done)
-      (inst sra y x 2)
-
-      (loadw y x bignum-digits-offset other-pointer-type)
-      (emit-label done))))
-;;;
-(define-move-vop move-to-word/integer :move
-  (descriptor-reg) (signed-reg unsigned-reg))
-
-
-;;; Result is a fixnum, so we can just shift.  We need the result type
-;;; restriction because of the control-stack ambiguity noted above.
-;;;
-(define-vop (move-from-word/fixnum)
-  (:args (x :scs (signed-reg unsigned-reg)))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:result-types tagged-num)
-  (:note "fixnum tagging")
-  (:generator 1
-    (inst sll y x 2)))
-;;;
-(define-move-vop move-from-word/fixnum :move
-  (signed-reg unsigned-reg) (any-reg descriptor-reg))
-
-;;; Result may be a bignum, so we have to check.  Use a worst-case cost to make
-;;; sure people know they may be number consing.
-;;;
-(define-vop (move-from-signed)
-  (:args (arg :scs (signed-reg unsigned-reg) :target x))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
-  #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
-  (:note "signed word to integer coercion")
-  (:generator 18
-    (move x arg)
-    (let ((fixnum (gen-label))
-	  (done (gen-label)))
-      (inst sra temp x 29)
-      (inst beq temp fixnum)
-      (inst nor temp zero-tn)
-      (inst beq temp done)
-      (inst sll y x 2)
-      
-      (with-fixed-allocation
-	  (y pa-flag temp bignum-type (1+ bignum-digits-offset))
-	(storew x y bignum-digits-offset other-pointer-type))
-      (inst b done)
-      (inst nop)
-      
-      (emit-label fixnum)
-      (inst sll y x 2)
-      (emit-label done))))
-;;;
-(define-move-vop move-from-signed :move
-  (signed-reg) (descriptor-reg))
-
-
-;;; Check for fixnum, and possibly allocate one or two word bignum result.  Use
-;;; a worst-case cost to make sure people know they may be number consing.
-;;;
-(define-vop (move-from-unsigned)
-  (:args (arg :scs (signed-reg unsigned-reg) :target x))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
-  #-gengc
-  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
-  (:note "unsigned word to integer coercion")
-  (:generator 20
-    (move x arg)
-    (inst srl temp x 29)
-    (inst beq temp done)
-    (inst sll y x 2)
-      
-    #-gengc
-    (pseudo-atomic
-	(pa-flag :extra (pad-data-block (+ bignum-digits-offset 2)))
-      (inst or y alloc-tn other-pointer-type)
-      (inst slt temp x zero-tn)
-      (inst sll temp type-bits)
-      (inst addu temp (logior (ash 1 type-bits) bignum-type))
-      (storew temp y 0 other-pointer-type))
-
-    #+gengc
-    (progn
-      (inst slt temp x zero-tn)
-      (inst sll temp type-bits)
-      (inst addu temp (logior (ash 1 type-bits) bignum-type))
-      (inst or y alloc-tn other-pointer-type)
-      (storew temp alloc-tn)
-      (inst addu alloc-tn (pad-data-block (+ bignum-digits-offset 2))))
-
-     (storew x y bignum-digits-offset other-pointer-type)
-     DONE))
-;;;
-(define-move-vop move-from-unsigned :move
-  (unsigned-reg) (descriptor-reg))
-
-
-;;; Move untagged numbers.
-;;;
-(define-vop (word-move)
-  (:args (x :target y
-	    :scs (signed-reg unsigned-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (signed-reg unsigned-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:note "word integer move")
-  (:generator 0
-    (move y x)))
-;;;
-(define-move-vop word-move :move
-  (signed-reg unsigned-reg) (signed-reg unsigned-reg))
-
-
-;;; Move untagged number arguments/return-values.
-;;;
-(define-vop (move-word-argument)
-  (:args (x :target y
-	    :scs (signed-reg unsigned-reg))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y sap-reg))))
-  (:results (y))
-  (:note "word integer argument move")
-  (:generator 0
-    (sc-case y
-      ((signed-reg unsigned-reg)
-       (move y x))
-      ((signed-stack unsigned-stack)
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-word-argument :move-argument
-  (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a
-;;; descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (signed-reg unsigned-reg) (any-reg descriptor-reg))
diff --git a/compiler/mips/nlx.lisp b/compiler/mips/nlx.lisp
deleted file mode 100644
index 09ad59456d4461e9eb66adf094a6fb4599f2e889..0000000000000000000000000000000000000000
--- a/compiler/mips/nlx.lisp
+++ /dev/null
@@ -1,328 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.19 1993/01/13 16:05:00 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the definitions of VOPs used for non-local exit
-;;; (throw, lexical exit, etc.)
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package "MIPS")
-
-;;; MAKE-NLX-SP-TN  --  Interface
-;;;
-;;;    Make an environment-live stack TN for saving the SP for NLX entry.
-;;;
-(def-vm-support-routine make-nlx-sp-tn (env)
-  (environment-live-tn
-   (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
-   env))
-
-
-
-;;; 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.
-;;;
-(def-vm-support-routine make-dynamic-state-tns ()
-  (make-n-tns 4 *any-primitive-type*))
-
-(define-vop (save-dynamic-state)
-  (:results (catch :scs (descriptor-reg))
-	    (nfp :scs (descriptor-reg))
-	    (nsp :scs (descriptor-reg))
-	    (eval :scs (descriptor-reg)))
-  (:vop-var vop)
-  (:generator 13
-    #-gengc
-    (load-symbol-value catch lisp::*current-catch-block*)
-    #+gengc
-    (loadw catch mutator-tn mutator-current-catch-block-slot)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(move nfp cur-nfp)))
-    (move nsp nsp-tn)
-    #-gengc
-    (load-symbol-value eval lisp::*eval-stack-top*)
-    #+gengc
-    (loadw eval mutator-tn mutator-eval-stack-top-slot)))
-
-(define-vop (restore-dynamic-state)
-  (:args (catch :scs (descriptor-reg))
-	 (nfp :scs (descriptor-reg))
-	 (nsp :scs (descriptor-reg))
-	 (eval :scs (descriptor-reg)))
-  (:vop-var vop)
-  (:generator 10
-    #-gengc
-    (store-symbol-value catch lisp::*current-catch-block*)
-    #+gengc
-    (storew catch mutator-tn mutator-current-catch-block-slot)
-    #-gengc
-    (store-symbol-value eval lisp::*eval-stack-top*)
-    #+gengc
-    (storew eval mutator-tn mutator-eval-stack-top-slot)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(move cur-nfp nfp)))
-    (move nsp-tn nsp)))
-
-(define-vop (current-stack-pointer)
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (move res csp-tn)))
-
-(define-vop (current-binding-pointer)
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (move res bsp-tn)))
-
-
-
-;;;; Unwind block hackery:
-
-;;; Compute the address of the catch block from its TN, then store into the
-;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
-;;;
-(define-vop (make-unwind-block)
-  (:args (tn))
-  (:info entry-label)
-  (:results (block :scs (any-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:generator 22
-    (inst addu block cfp-tn (* (tn-offset tn) vm:word-bytes))
-    #-gengc
-    (load-symbol-value temp lisp::*current-unwind-protect-block*)
-    #+gengc
-    (loadw temp mutator-tn mutator-current-unwind-protect-slot)
-    (storew temp block vm:unwind-block-current-uwp-slot)
-    (storew cfp-tn block vm:unwind-block-current-cont-slot)
-    (storew code-tn block vm:unwind-block-current-code-slot)
-    #-gengc
-    (inst compute-lra-from-code temp code-tn entry-label ndescr)
-    #+gengc
-    (inst compute-ra-from-code temp code-tn entry-label ndescr)
-    (storew temp block vm:catch-block-entry-pc-slot)))
-
-
-;;; 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 (descriptor-reg)))
-  (:info entry-label)
-  (:results (block :scs (any-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:generator 44
-    (inst addu result cfp-tn (* (tn-offset tn) vm:word-bytes))
-    #-gengc
-    (load-symbol-value temp lisp::*current-unwind-protect-block*)
-    #+gengc
-    (loadw temp mutator-tn mutator-current-unwind-protect-slot)
-    (storew temp result vm:catch-block-current-uwp-slot)
-    (storew cfp-tn result vm:catch-block-current-cont-slot)
-    (storew code-tn result vm:catch-block-current-code-slot)
-    #-gengc
-    (inst compute-lra-from-code temp code-tn entry-label ndescr)
-    #+gengc
-    (inst compute-ra-from-code temp code-tn entry-label ndescr)
-    (storew temp result vm:catch-block-entry-pc-slot)
-
-    (storew tag result vm:catch-block-tag-slot)
-    #-gengc
-    (load-symbol-value temp lisp::*current-catch-block*)
-    #+gengc
-    (loadw temp mutator-tn mutator-current-catch-block-slot)
-    (storew temp result vm:catch-block-previous-catch-slot)
-    #-gengc
-    (store-symbol-value result lisp::*current-catch-block*)
-    #+gengc
-    (storew result mutator-tn mutator-current-catch-block-slot)
-
-    (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 addu new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes))
-    #-gengc
-    (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)
-    #+gengc
-    (storew new-uwp mutator-tn mutator-current-unwind-protect-slot)))
-
-
-(define-vop (unlink-catch-block)
-  (:temporary (:scs (any-reg)) block)
-  (:policy :fast-safe)
-  (:translate %catch-breakup)
-  (:generator 17
-    #-gengc
-    (load-symbol-value block lisp::*current-catch-block*)
-    #+gengc
-    (loadw block mutator-tn mutator-current-catch-block-slot)
-    (loadw block block vm:catch-block-previous-catch-slot)
-    #-gengc
-    (store-symbol-value block lisp::*current-catch-block*)
-    #+gengc
-    (storew block mutator-tn mutator-current-catch-block-slot)))
-
-(define-vop (unlink-unwind-protect)
-  (:temporary (:scs (any-reg)) block)
-  (:policy :fast-safe)
-  (:translate %unwind-protect-breakup)
-  (:generator 17
-    #-gengc
-    (load-symbol-value block lisp::*current-unwind-protect-block*)
-    #+gengc
-    (loadw block mutator-tn mutator-current-unwind-protect-slot)
-    (loadw block block vm:unwind-block-current-uwp-slot)
-    #-gengc
-    (store-symbol-value block lisp::*current-unwind-protect-block*)
-    #+gengc
-    (storew block mutator-tn mutator-current-unwind-protect-slot)))
-
-
-;;;; NLX entry VOPs:
-
-
-(define-vop (nlx-entry)
-  (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
-	      ; would be inserted before the LRA.
-	 (start)
-	 (count))
-  (:results (values :more t))
-  (:temporary (:scs (descriptor-reg)) move-temp)
-  (:info label nvals)
-  (:save-p :force-to-stack)
-  (:vop-var vop)
-  (:generator 30
-    (emit-return-pc label)
-    (note-this-location vop :non-local-entry)
-    (cond ((zerop nvals))
-	  ((= nvals 1)
-	   (let ((no-values (gen-label)))
-	     (inst beq count zero-tn no-values)
-	     (move (tn-ref-tn values) null-tn)
-	     (loadw (tn-ref-tn values) start)
-	     (emit-label no-values)))
-	  (t
-	   (collect ((defaults))
-	     (do ((i 0 (1+ i))
-		  (tn-ref values (tn-ref-across tn-ref)))
-		 ((null tn-ref))
-	       (let ((default-lab (gen-label))
-		     (tn (tn-ref-tn tn-ref)))
-		 (defaults (cons default-lab tn))
-		 
-		 (inst beq count zero-tn default-lab)
-		 (inst addu count count (fixnum -1))
-		 (sc-case tn
-			  ((descriptor-reg any-reg)
-			   (loadw tn start i))
-			  (control-stack
-			   (loadw move-temp start i)
-			   (store-stack-tn tn move-temp)))))
-	     
-	     (let ((defaulting-done (gen-label)))
-	       
-	       (emit-label defaulting-done)
-	       
-	       (assemble (*elsewhere*)
-		 (dolist (def (defaults))
-		   (emit-label (car def))
-		   (let ((tn (cdr def)))
-		     (sc-case tn
-			      ((descriptor-reg any-reg)
-			       (move tn null-tn))
-			      (control-stack
-			       (store-stack-tn tn null-tn)))))
-		 (inst b defaulting-done)
-		 (inst nop))))))
-    (load-stack-tn csp-tn sp)))
-
-
-(define-vop (nlx-entry-multiple)
-  (:args (top :target dst) (start :target src) (count :target num))
-  ;; Again, no SC restrictions for the args, 'cause the loading would
-  ;; happen before the entry label.
-  (:info label)
-  (:temporary (:scs (any-reg) :from (:argument 0)) dst)
-  (:temporary (:scs (any-reg) :from (:argument 1)) src)
-  (:temporary (:scs (any-reg) :from (:argument 2)) num)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:results (new-start) (new-count))
-  (:save-p :force-to-stack)
-  (:vop-var vop)
-  (:generator 30
-    (emit-return-pc label)
-    (note-this-location vop :non-local-entry)
-    (let ((loop (gen-label))
-	  (done (gen-label)))
-
-      ;; Copy args.
-      (load-stack-tn dst top)
-      (move src start)
-      (move num count)
-
-      ;; Establish results.
-      (sc-case new-start
-	(any-reg (move new-start dst))
-	(control-stack (store-stack-tn new-start dst)))
-      (inst beq num zero-tn done)
-      (sc-case new-count
-	(any-reg (inst move new-count num))
-	(control-stack (store-stack-tn new-count num)))
-
-      ;; Copy stuff on stack.
-      (emit-label loop)
-      (loadw temp src)
-      (inst addu src src vm:word-bytes)
-      (storew temp dst)
-      (inst addu num num (fixnum -1))
-      (inst bne num zero-tn loop)
-      (inst addu dst dst vm:word-bytes)
-
-      (emit-label done)
-      (inst move csp-tn dst))))
-
-
-;;; This VOP is just to force the TNs used in the cleanup onto the stack.
-;;;
-(define-vop (uwp-entry)
-  (:info label)
-  (:save-p :force-to-stack)
-  (:results (block) (start) (count))
-  (:ignore block start count)
-  (:vop-var vop)
-  (:generator 0
-    (emit-return-pc label)
-    (note-this-location vop :non-local-entry)))
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/pred.lisp b/compiler/mips/pred.lisp
deleted file mode 100644
index 8e5fd56c424a4d1318bfd14236331306ceee5150..0000000000000000000000000000000000000000
--- a/compiler/mips/pred.lisp
+++ /dev/null
@@ -1,63 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/pred.lisp,v 1.6 1991/02/20 15:15:00 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/pred.lisp,v 1.6 1991/02/20 15:15:00 ram Exp $
-;;;
-;;;    This file contains the VM definition of predicate VOPs for the MIPS.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by William Lott.
-;;; 
-
-(in-package "MIPS")
-
-
-;;;; 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 b dest)
-    (inst 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)))
-    (inst nop)))
-
-
diff --git a/compiler/mips/print.lisp b/compiler/mips/print.lisp
deleted file mode 100644
index 66772e0491fa424bc48dedc9fdd8bedd0a601978..0000000000000000000000000000000000000000
--- a/compiler/mips/print.lisp
+++ /dev/null
@@ -1,41 +0,0 @@
-;;; -*- Package: C -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/print.lisp,v 1.9 1992/07/28 20:37:46 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains temporary printing utilities and similar noise.
-;;;
-;;; Written by William Lott.
-
-(in-package "MIPS")
-
-
-(define-vop (print)
-  (:args (object :scs (descriptor-reg) :target a0))
-  (:results (result :scs (descriptor-reg)))
-  (:save-p t)
-  (:temporary (:sc any-reg :offset cfunc-offset :target result :to (:result 0))
-	      cfunc)
-  (:temporary (:sc descriptor-reg :offset 4 :from (:argument 0)) a0)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:vop-var vop)
-  (:generator 0
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (move a0 object)
-      (when cur-nfp
-	(store-stack-tn nfp-save cur-nfp))
-      (inst li cfunc (make-fixup "debug_print" :foreign))
-      (inst jal (make-fixup "call_into_c" :foreign))
-      (inst addu nsp-tn nsp-tn -16)
-      (inst addu nsp-tn nsp-tn 16)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save))
-      (move result cfunc))))
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/sap.lisp b/compiler/mips/sap.lisp
deleted file mode 100644
index efbf2b6f5b1c50cf57de561f4c22daf88ef9c411..0000000000000000000000000000000000000000
--- a/compiler/mips/sap.lisp
+++ /dev/null
@@ -1,321 +0,0 @@
-;;; -*- Package: VM; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/sap.lisp,v 1.27 1993/01/13 15:58:41 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the MIPS VM definition of SAP operations.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "MIPS")
-
-
-;;;; Moves and coercions:
-
-;;; Move a tagged SAP to an untagged representation.
-;;;
-(define-vop (move-to-sap)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (y :scs (sap-reg)))
-  (:note "system area pointer indirection")
-  (:generator 1
-    (loadw y x sap-pointer-slot other-pointer-type)))
-
-;;;
-(define-move-vop move-to-sap :move
-  (descriptor-reg) (sap-reg))
-
-
-;;; Move an untagged SAP to a tagged representation.
-;;;
-(define-vop (move-from-sap)
-  (:args (x :scs (sap-reg) :target sap))
-  (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
-  (:results (y :scs (descriptor-reg)))
-  (:note "system area pointer allocation")
-  (:generator 20
-    (move sap x)
-    (with-fixed-allocation (y pa-flag ndescr sap-type sap-size)
-      (storew sap y sap-pointer-slot other-pointer-type))))
-;;;
-(define-move-vop move-from-sap :move
-  (sap-reg) (descriptor-reg))
-
-
-;;; Move untagged sap values.
-;;;
-(define-vop (sap-move)
-  (:args (x :target y
-	    :scs (sap-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (sap-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:generator 0
-    (move y x)))
-;;;
-(define-move-vop sap-move :move
-  (sap-reg) (sap-reg))
-
-
-;;; Move untagged sap arguments/return-values.
-;;;
-(define-vop (move-sap-argument)
-  (:args (x :target y
-	    :scs (sap-reg))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y sap-reg))))
-  (:results (y))
-  (:generator 0
-    (sc-case y
-      (sap-reg
-       (move y x))
-      (sap-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-sap-argument :move-argument
-  (descriptor-reg sap-reg) (sap-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
-;;; descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (sap-reg) (descriptor-reg))
-
-
-
-;;;; SAP-INT and INT-SAP
-
-(define-vop (sap-int)
-  (:args (sap :scs (sap-reg) :target int))
-  (:arg-types system-area-pointer)
-  (:results (int :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:translate sap-int)
-  (:policy :fast-safe)
-  (:generator 1
-    (move int sap)))
-
-(define-vop (int-sap)
-  (:args (int :scs (unsigned-reg) :target sap))
-  (:arg-types unsigned-num)
-  (:results (sap :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate int-sap)
-  (:policy :fast-safe)
-  (:generator 1
-    (move sap int)))
-
-
-
-;;;; POINTER+ and POINTER-
-
-(define-vop (pointer+)
-  (:translate sap+)
-  (:args (ptr :scs (sap-reg))
-	 (offset :scs (signed-reg immediate)))
-  (:arg-types system-area-pointer signed-num)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:policy :fast-safe)
-  (:generator 1
-    (sc-case offset
-      (signed-reg
-       (inst addu res ptr offset))
-      (immediate
-       (inst addu res ptr (tn-value offset))))))
-
-(define-vop (pointer-)
-  (:translate sap-)
-  (:args (ptr1 :scs (sap-reg))
-	 (ptr2 :scs (sap-reg)))
-  (:arg-types system-area-pointer system-area-pointer)
-  (:policy :fast-safe)
-  (:results (res :scs (signed-reg)))
-  (:result-types signed-num)
-  (:generator 1
-    (inst subu res ptr1 ptr2)))
-
-
-
-;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
-
-(eval-when (compile eval)
-
-(defmacro def-system-ref-and-set
-	  (ref-name set-name sc type size &optional signed)
-  (let ((ref-name-c (symbolicate ref-name "-C"))
-	(set-name-c (symbolicate set-name "-C")))
-    `(progn
-       (define-vop (,ref-name)
-	 (:translate ,ref-name)
-	 (:policy :fast-safe)
-	 (:args (object :scs (sap-reg) :target sap)
-		(offset :scs (unsigned-reg)))
-	 (:arg-types system-area-pointer unsigned-num)
-	 (:results (result :scs (,sc)))
-	 (:result-types ,type)
-	 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
-	 (:generator 5
-	   (inst addu sap object offset)
-	   ,@(ecase size
-	       (:byte
-		(if signed
-		    '((inst lb result sap 0))
-		    '((inst lbu result sap 0))))
-		 (:short
-		  (if signed
-		      '((inst lh result sap 0))
-		      '((inst lhu result sap 0))))
-		 (:long
-		  '((inst lw result sap 0)))
-		 (:single
-		  '((inst lwc1 result sap 0)))
-		 (:double
-		  '((inst lwc1 result sap 0)
-		    (inst lwc1-odd result sap word-bytes))))
-	   (inst nop)))
-       (define-vop (,ref-name-c)
-	 (:translate ,ref-name)
-	 (:policy :fast-safe)
-	 (:args (object :scs (sap-reg)))
-	 (:arg-types system-area-pointer
-		     (:constant ,(if (eq size :double)
-				     ;; We need to be able to add 4.
-				     `(integer ,(- (ash 1 16))
-					       ,(- (ash 1 16) 5))
-				     '(signed-byte 16))))
-	 (:info offset)
-	 (:results (result :scs (,sc)))
-	 (:result-types ,type)
-	 (:generator 4
-	   ,@(ecase size
-	       (:byte
-		(if signed
-		    '((inst lb result object offset))
-		    '((inst lbu result object offset))))
-	       (:short
-		(if signed
-		    '((inst lh result object offset))
-		    '((inst lhu result object offset))))
-	       (:long
-		'((inst lw result object offset)))
-	       (:single
-		'((inst lwc1 result object offset)))
-	       (:double
-		'((inst lwc1 result object offset)
-		  (inst lwc1-odd result object (+ offset word-bytes)))))
-	   (inst nop)))
-       (define-vop (,set-name)
-	 (:translate ,set-name)
-	 (:policy :fast-safe)
-	 (:args (object :scs (sap-reg) :target sap)
-		(offset :scs (unsigned-reg))
-		(value :scs (,sc) :target result))
-	 (:arg-types system-area-pointer unsigned-num ,type)
-	 (:results (result :scs (,sc)))
-	 (:result-types ,type)
-	 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
-	 (:generator 5
-	   (inst addu sap object offset)
-	   ,@(ecase size
-	       (:byte
-		'((inst sb value sap 0)
-		  (move result value)))
-	       (:short
-		'((inst sh value sap 0)
-		  (move result value)))
-	       (:long
-		'((inst sw value sap 0)
-		  (move result value)))
-	       (:single
-		'((inst swc1 value sap 0)
-		  (unless (location= result value)
-		    (inst fmove :single result value))))
-	       (:double
-		'((inst swc1 value sap 0)
-		  (inst swc1-odd value sap word-bytes)
-		  (unless (location= result value)
-		    (inst fmove :double result value)))))))
-       (define-vop (,set-name-c)
-	 (:translate ,set-name)
-	 (:policy :fast-safe)
-	 (:args (object :scs (sap-reg))
-		(value :scs (,sc) :target result))
-	 (:arg-types system-area-pointer
-		     (:constant ,(if (eq size :double)
-				     ;; We need to be able to add 4.
-				     `(integer ,(- (ash 1 16))
-					       ,(- (ash 1 16) 5))
-				     '(signed-byte 16)))
-		     ,type)
-	 (:info offset)
-	 (:results (result :scs (,sc)))
-	 (:result-types ,type)
-	 (:generator 5
-	   ,@(ecase size
-	       (:byte
-		'((inst sb value object offset)
-		  (move result value)))
-	       (:short
-		'((inst sh value object offset)
-		  (move result value)))
-	       (:long
-		'((inst sw value object offset)
-		  (move result value)))
-	       (:single
-		'((inst swc1 value object offset)
-		  (unless (location= result value)
-		    (inst fmove :single result value))))
-	       (:double
-		'((inst swc1 value object offset)
-		  (inst swc1-odd value object (+ offset word-bytes))
-		  (unless (location= result value)
-		    (inst fmove :double result value))))))))))
-
-); eval-when (compile eval)
-
-(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
-  unsigned-reg positive-fixnum :byte nil)
-(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
-  signed-reg tagged-num :byte t)
-(def-system-ref-and-set sap-ref-16 %set-sap-ref-16
-  unsigned-reg positive-fixnum :short nil)
-(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
-  signed-reg tagged-num :short t)
-(def-system-ref-and-set sap-ref-32 %set-sap-ref-32
-  unsigned-reg unsigned-num :long nil)
-(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
-  signed-reg signed-num :long t)
-(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
-  sap-reg system-area-pointer :long)
-(def-system-ref-and-set sap-ref-single %set-sap-ref-single
-  single-reg single-float :single)
-(def-system-ref-and-set sap-ref-double %set-sap-ref-double
-  double-reg double-float :double)
-
-
-;;; Noise to convert normal lisp data objects into SAPs.
-
-(define-vop (vector-sap)
-  (:translate vector-sap)
-  (:policy :fast-safe)
-  (:args (vector :scs (descriptor-reg)))
-  (:results (sap :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 2
-    (inst addu sap vector
-	  (- (* vector-data-offset word-bytes) other-pointer-type))))
-
diff --git a/compiler/mips/static-fn.lisp b/compiler/mips/static-fn.lisp
deleted file mode 100644
index f00057c8f59ff7be6d559cc16e086b2f4caf4e2d..0000000000000000000000000000000000000000
--- a/compiler/mips/static-fn.lisp
+++ /dev/null
@@ -1,147 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.19 1993/01/13 16:03:23 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the VOPs and macro magic necessary to call static
-;;; functions.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "MIPS")
-
-
-
-(define-vop (static-function-template)
-  (:save-p t)
-  (:policy :safe)
-  (:variant-vars symbol)
-  (:vop-var vop)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg)) move-temp)
-  #-gengc (:temporary (:sc descriptor-reg :offset lra-offset) lra)
-  (:temporary (:sc interior-reg :offset lip-offset) entry-point)
-  (:temporary (:sc any-reg :offset nargs-offset) nargs)
-  (:temporary (:sc any-reg :offset ocfp-offset) ocfp)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
-
-
-(eval-when (compile load eval)
-
-
-(defun static-function-template-name (num-args num-results)
-  (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
-		  num-args num-results)))
-
-
-(defun moves (dst src)
-  (collect ((moves))
-    (do ((dst dst (cdr dst))
-	 (src src (cdr src)))
-	((or (null dst) (null src)))
-      (moves `(move ,(car dst) ,(car src))))
-    (moves)))
-
-(defun static-function-template-vop (num-args num-results)
-  (assert (and (<= num-args register-arg-count)
-	       (<= num-results register-arg-count))
-	  (num-args num-results)
-	  "Either too many args (~D) or too many results (~D).  Max = ~D"
-	  num-args num-results register-arg-count)
-  (let ((num-temps (max num-args num-results)))
-    (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
-      (dotimes (i num-results)
-	(let ((result-name (intern (format nil "RESULT-~D" i))))
-	  (result-names result-name)
-	  (results `(,result-name :scs (any-reg descriptor-reg)))))
-      (dotimes (i num-temps)
-	(let ((temp-name (intern (format nil "TEMP-~D" i))))
-	  (temp-names temp-name)
-	  (temps `(:temporary (:sc descriptor-reg
-			       :offset ,(nth i register-arg-offsets)
-			       ,@(when (< i num-args)
-				   `(:from (:argument ,i)))
-			       ,@(when (< i num-results)
-				   `(:to (:result ,i)
-				     :target ,(nth i (result-names)))))
-			      ,temp-name))))
-      (dotimes (i num-args)
-	(let ((arg-name (intern (format nil "ARG-~D" i))))
-	  (arg-names arg-name)
-	  (args `(,arg-name
-		  :scs (any-reg descriptor-reg)
-		  :target ,(nth i (temp-names))))))
-      `(define-vop (,(static-function-template-name num-args num-results)
-		    static-function-template)
-	 (:args ,@(args))
-	 ,@(temps)
-	 (:results ,@(results))
-	 (:generator ,(+ 50 num-args num-results)
-	   (let ((lra-label (gen-label))
-		 (cur-nfp (current-nfp-tn vop)))
-	     ,@(moves (temp-names) (arg-names))
-	     (inst li nargs (fixnum ,num-args))
-	     (inst lw entry-point null-tn (static-function-offset symbol))
-	     (when cur-nfp
-	       (store-stack-tn nfp-save cur-nfp))
-	     (inst move ocfp cfp-tn)
-	     #-gengc (inst compute-lra-from-code lra code-tn lra-label temp)
-	     (note-this-location vop :call-site)
-	     (inst #-gengc j #+gengc jal entry-point)
-	     (inst move cfp-tn csp-tn)
-	     (emit-return-pc lra-label)
-	     ,(collect ((bindings) (links))
-		(do ((temp (temp-names) (cdr temp))
-		     (name 'values (gensym))
-		     (prev nil name)
-		     (i 0 (1+ i)))
-		    ((= i num-results))
-		  (bindings `(,name
-			      (make-tn-ref ,(car temp) nil)))
-		  (when prev
-		    (links `(setf (tn-ref-across ,prev) ,name))))
-		`(let ,(bindings)
-		   ,@(links)
-		   (default-unknown-values vop
-		       ,(if (zerop num-results) nil 'values)
-		       ,num-results move-temp temp lra-label)))
-	     (when cur-nfp
-	       (load-stack-tn cur-nfp nfp-save))
-	     ,@(moves (result-names) (temp-names))))))))
-
-
-) ; eval-when (compile load eval)
-
-
-(expand
- (collect ((templates (list 'progn)))
-   (dotimes (i register-arg-count)
-     (templates (static-function-template-vop i 1)))
-   (templates)))
-
-
-(defmacro define-static-function (name args &key (results '(x)) translate
-				       policy cost arg-types result-types)
-  `(define-vop (,name
-		,(static-function-template-name (length args)
-						(length results)))
-     (:variant ',name)
-     (:note ,(format nil "static-function ~@(~S~)" name))
-     ,@(when translate
-	 `((:translate ,translate)))
-     ,@(when policy
-	 `((:policy ,policy)))
-     ,@(when cost
-	 `((:generator-cost ,cost)))
-     ,@(when arg-types
-	 `((:arg-types ,@arg-types)))
-     ,@(when result-types
-	 `((:result-types ,@result-types)))))
diff --git a/compiler/mips/subprim.lisp b/compiler/mips/subprim.lisp
deleted file mode 100644
index 5b0449e5815af291a35af25216f3920450aabf4f..0000000000000000000000000000000000000000
--- a/compiler/mips/subprim.lisp
+++ /dev/null
@@ -1,64 +0,0 @@
-;;; -*- Package: MIPS; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/subprim.lisp,v 1.21 1992/07/28 20:37:52 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Linkage information for standard static functions, and random vops.
-;;;
-;;; Written by William Lott.
-;;; 
-(in-package "MIPS")
-
-
-
-;;;; Length
-
-(define-vop (length/list)
-  (:translate length)
-  (:args (object :scs (descriptor-reg) :target ptr))
-  (:arg-types list)
-  (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result)
-	      count)
-  (:results (result :scs (any-reg descriptor-reg)))
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 50
-    (move ptr object)
-    (move count zero-tn)
-    
-    LOOP
-    
-    (inst beq ptr null-tn done)
-    (inst nop)
-    
-    (inst and temp ptr lowtag-mask)
-    (inst xor temp list-pointer-type)
-    (inst bne temp zero-tn not-list)
-    (inst nop)
-    
-    (loadw ptr ptr cons-cdr-slot list-pointer-type)
-    (inst b loop)
-    (inst addu count count (fixnum 1))
-    
-    NOT-LIST
-    (cerror-call vop done object-not-list-error ptr)
-    
-    DONE
-    (move result count)))
-       
-
-(define-static-function length (object) :translate length)
-
-
-
diff --git a/compiler/mips/system.lisp b/compiler/mips/system.lisp
deleted file mode 100644
index d695f2f9c4ea94566cc9128f76dec8918dd7b8dc..0000000000000000000000000000000000000000
--- a/compiler/mips/system.lisp
+++ /dev/null
@@ -1,323 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/system.lisp,v 1.47 1993/01/13 16:02:06 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    MIPS VM definitions of various system hacking operations.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Mips conversion by William Lott and Christopher Hoover.
-;;;
-(in-package "MIPS")
-
-
-;;;; Random pointer comparison VOPs
-
-(define-vop (pointer-compare)
-  (:args (x :scs (sap-reg))
-	 (y :scs (sap-reg)))
-  (:arg-types system-area-pointer system-area-pointer)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:note "inline comparison")
-  (:variant-vars condition)
-  (:generator 3
-    (three-way-comparison x y condition :unsigned not-p target temp)))
-
-(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))
-
-
-
-;;;; Type frobbing VOPs
-
-(define-vop (get-lowtag)
-  (:translate get-lowtag)
-  (:policy :fast-safe)
-  (:args (object :scs (any-reg descriptor-reg)))
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 1
-    (inst and result object lowtag-mask)))
-
-(define-vop (get-type)
-  (:translate get-type)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    ;; Pick off objects with headers.
-    (inst and ndescr object lowtag-mask)
-    (inst xor ndescr other-pointer-type)
-    (inst beq ndescr other-ptr)
-    (inst xor ndescr (logxor other-pointer-type function-pointer-type))
-    (inst beq ndescr function-ptr)
-
-    ;; Pick off fixnums.
-    (inst and result object 3)
-    (inst beq result done)
-
-    ;; Pick off structure and list pointers.
-    (inst and result object 1)
-    (inst bne result lowtag-only)
-    (inst nop)
-
-      ;; Must be an other immediate.
-    (inst b done)
-    (inst and result object type-mask)
-
-    FUNCTION-PTR
-    (load-type result object (- function-pointer-type))
-    (inst b done)
-    (inst nop)
-
-    LOWTAG-ONLY
-    (inst b done)
-    (inst and result object lowtag-mask)
-
-    OTHER-PTR
-    (load-type result object (- other-pointer-type))
-    (inst nop)
-      
-    DONE))
-
-(define-vop (function-subtype)
-  (:translate function-subtype)
-  (:policy :fast-safe)
-  (:args (function :scs (descriptor-reg)))
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (load-type result function (- function-pointer-type))
-    (inst nop)))
-
-(define-vop (set-function-subtype)
-  (:translate (setf function-subtype))
-  (:policy :fast-safe)
-  (:args (type :scs (unsigned-reg) :target result)
-	 (function :scs (descriptor-reg)))
-  (:arg-types positive-fixnum *)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (inst sb type function (- function-pointer-type))
-    (move result type)))
-
-
-(define-vop (get-header-data)
-  (:translate get-header-data)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (loadw res x 0 other-pointer-type)
-    (inst srl res res type-bits)))
-
-(define-vop (get-closure-length)
-  (:translate get-closure-length)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (loadw res x 0 function-pointer-type)
-    (inst srl res res type-bits)))
-
-(define-vop (set-header-data)
-  (:translate set-header-data)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg) :target res)
-	 (data :scs (any-reg immediate zero)))
-  (:arg-types * positive-fixnum)
-  (:results (res :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) t1 t2)
-  (:generator 6
-    (loadw t1 x 0 other-pointer-type)
-    (inst and t1 type-mask)
-    (sc-case data
-      (any-reg
-       (inst sll t2 data (- type-bits 2))
-       (inst or t1 t2))
-      (immediate
-       (inst or t1 (ash (tn-value data) type-bits)))
-      (zero))
-    (storew t1 x 0 other-pointer-type)
-    (move res x)))
-
-(define-vop (c::make-fixnum)
-  (:args (ptr :scs (any-reg descriptor-reg)))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 1
-    ;;
-    ;; Some code (the hash table code) depends on this returning a
-    ;; positive number so make sure it does.
-    (inst sll res ptr 3)
-    (inst srl res res 1)))
-
-(define-vop (c::make-other-immediate-type)
-  (:args (val :scs (any-reg descriptor-reg))
-	 (type :scs (any-reg descriptor-reg immediate)
-	       :target temp))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 2
-    (sc-case type
-      ((immediate)
-       (inst sll temp val type-bits)
-       (inst or res temp (tn-value type)))
-      (t
-       (inst sra temp type 2)
-       (inst sll res val (- type-bits 2))
-       (inst or res res temp)))))
-
-
-;;;; Allocation
-
-(define-vop (dynamic-space-free-pointer)
-  (:results (int :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate dynamic-space-free-pointer)
-  (:policy :fast-safe)
-  (:generator 1
-    (move int alloc-tn)))
-
-(define-vop (binding-stack-pointer-sap)
-  (:results (int :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate binding-stack-pointer-sap)
-  (:policy :fast-safe)
-  (:generator 1
-    (move int bsp-tn)))
-
-(define-vop (control-stack-pointer-sap)
-  (:results (int :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate control-stack-pointer-sap)
-  (:policy :fast-safe)
-  (:generator 1
-    (move int csp-tn)))
-
-
-;;;; Code object frobbing.
-
-(define-vop (code-instructions)
-  (:translate code-instructions)
-  (:policy :fast-safe)
-  (:args (code :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:results (sap :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 10
-    (loadw ndescr code 0 other-pointer-type)
-    (inst srl ndescr type-bits)
-    (inst sll ndescr word-shift)
-    (inst subu ndescr other-pointer-type)
-    (inst addu sap code ndescr)))
-
-(define-vop (compute-function)
-  (:args (code :scs (descriptor-reg))
-	 (offset :scs (signed-reg unsigned-reg)))
-  (:arg-types * positive-fixnum)
-  (:results (func :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:generator 10
-    (loadw ndescr code 0 other-pointer-type)
-    (inst srl ndescr type-bits)
-    (inst sll ndescr word-shift)
-    (inst addu ndescr offset)
-    (inst addu ndescr (- function-pointer-type other-pointer-type))
-    (inst addu func code ndescr)))
-
-#+gengc
-(progn
-
-(define-vop (%function-self)
-  (:policy :fast-safe)
-  (:translate (setf %function-self))
-  (:args (function :scs (descriptor-reg)))
-  (:temporary (:scs (any-reg)) temp)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 3
-    (loadw temp function function-entry-point-slot function-pointer-type)
-    (inst addu result temp
-	  (- function-pointer-type (* function-code-offset word-bytes)))))
-
-(defknown %set-function-self (function function) (values) (unsafe))
-
-(define-vop (%set-function-self)
-  (:policy :fast-safe)
-  (:translate %set-function-self)
-  (:args (function :scs (descriptor-reg))
-	 (new-self :scs (descriptor-reg)))
-  (:temporary (:scs (any-reg)) temp)
-  (:generator 3
-    (inst addu temp new-self
-	  (- (* function-code-offset word-bytes) function-pointer-type))
-    (storew temp function function-entry-point-slot function-pointer-type)))
-
-(def-source-transform %closure-function (closure)
-  `(%function-self ,closure))
-
-(def-source-transform (setf %function-self) (new-self fun)
-  `(let ((new-self ,new-self) (fun ,fun))
-     (%set-function-self fun new-self)
-     new-self))
-
-(def-source-transform %set-funcallable-instance-function (fin fun)
-  `(let ((fin ,fin) (fun ,fun))
-     (%set-function-self fin fun)
-     fun))
-
-); #+gengc progn
-
-
-;;;; Other random VOPs.
-
-
-(defknown unix::do-pending-interrupt () (values))
-(define-vop (unix::do-pending-interrupt)
-  (:policy :fast-safe)
-  (:translate unix::do-pending-interrupt)
-  (:generator 1
-    (inst break pending-interrupt-trap)))
-
-
-(define-vop (halt)
-  (:generator 1
-    (inst break halt-trap)))
-
-
-;;;; Dynamic vop count collection support
-
-(define-vop (count-me)
-  (:args (count-vector :scs (descriptor-reg)))
-  (:info index)
-  (:temporary (:scs (non-descriptor-reg)) count)
-  (:generator 1
-    (let ((offset
-	   (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
-      (inst lw count count-vector offset)
-      (inst nop)
-      (inst addu count 1)
-      (inst sw count count-vector offset))))
diff --git a/compiler/mips/utils.lisp b/compiler/mips/utils.lisp
deleted file mode 100644
index b413d600b19f9b3712ddd4fcdf639c25bbd0051b..0000000000000000000000000000000000000000
--- a/compiler/mips/utils.lisp
+++ /dev/null
@@ -1,80 +0,0 @@
-;;; -*- Package: MIPS; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/utils.lisp,v 1.1 1991/07/26 01:44:45 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains various useful utilities for generating MIPS code.
-;;;
-;;; Written by William Lott and Christopher Hoover.
-;;; 
-
-(in-package "MIPS")
-
-
-
-;;;; Three Way Comparison
-
-(defun three-way-comparison (x y condition flavor not-p target temp)
-  (ecase condition
-    (:eq
-     (if not-p
-	 (inst bne x y target)
-	 (inst beq x y target)))
-    (:lt
-     (ecase flavor
-       (:unsigned
-	(inst sltu temp x y))
-       (:signed
-	(inst slt temp x y)))
-     (if not-p
-	 (inst beq temp zero-tn target)
-	 (inst bne temp zero-tn target)))
-    (:gt
-     (ecase flavor
-       (:unsigned
-	(inst sltu temp y x))
-       (:signed
-	(inst slt temp y x)))
-     (if not-p
-	 (inst beq temp zero-tn target)
-	 (inst bne temp zero-tn target))))
-  (inst nop))
-
-
-;;;; Pseudo-atomic support.
-
-(defun start-pseudo-atomic ()
-  ;; I don't think that we need to clear the interrupted slot.  It should
-  ;; be clear already.
-  ;(storew zero-tn mutator-tn mutator-pseudo-atomic-interrupted-slot)
-  (storew csp-tn mutator-tn mutator-pseudo-atomic-atomic-slot))
-
-(defun end-pseudo-atomic (ndescr)
-  (let ((label (gen-label)))
-    (storew zero-tn mutator-tn mutator-pseudo-atomic-atomic-slot)
-    (loadw ndescr mutator-tn mutator-pseudo-atomic-interrupted-slot)
-    (inst beq ndescr label)
-    (inst nop)
-    (inst break pending-interrupt-trap)
-    (emit-label label)))
-
-
-
-;;;; write-list support.
-
-(defun check-pointer-ages-p (vop value)
-  (and (sc-is value descriptor-reg)
-       (let ((option (assoc :check-pointer-ages
-			    (c::lexenv-options
-			     (c::node-lexenv
-			      (c::vop-node vop))))))
-	 (or (null option)
-	     (cdr option)))))
diff --git a/compiler/mips/values.lisp b/compiler/mips/values.lisp
deleted file mode 100644
index 4e16808ebeb996886dc5cadd7cd3840b07190df2..0000000000000000000000000000000000000000
--- a/compiler/mips/values.lisp
+++ /dev/null
@@ -1,98 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/values.lisp,v 1.13 1992/07/28 20:38:01 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the implementation of unknown-values VOPs.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted for MIPS by William Lott.
-;;; 
-
-(in-package "MIPS")
-
-(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 (any-reg))
-   (count :scs (any-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 addu csp-tn csp-tn (* nvals 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)
-    (inst li count (fixnum 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))
-	    (count :scs (any-reg)))
-  (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 0
-    (move list arg)
-    (move start csp-tn)
-    
-    LOOP
-    (inst beq list null-tn done)
-    (loadw temp list cons-car-slot list-pointer-type)
-    (loadw list list cons-cdr-slot list-pointer-type)
-    (inst addu csp-tn csp-tn word-bytes)
-    (storew temp csp-tn -1)
-    (inst and ndescr list lowtag-mask)
-    (inst xor ndescr list-pointer-type)
-    (inst beq ndescr zero-tn loop)
-    (inst nop)
-    (error-call vop bogus-argument-to-values-list-error list)
-    
-    DONE
-    (inst subu count csp-tn start)))
-
diff --git a/compiler/mips/vm.lisp b/compiler/mips/vm.lisp
deleted file mode 100644
index 6803cd96fff75e24771e84e16cc3dd948c8940a2..0000000000000000000000000000000000000000
--- a/compiler/mips/vm.lisp
+++ /dev/null
@@ -1,363 +0,0 @@
-;;; -*- Package: MIPS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.47 1993/01/13 15:59:31 wlott 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 "MIPS")
-
-
-;;;; Registers
-
-(eval-when (compile eval)
-
-(defmacro defreg (name offset)
-  (let ((offset-sym (symbolicate name "-OFFSET")))
-    `(eval-when (compile eval load)
-       (defconstant ,offset-sym ,offset)
-       (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
-
-(defmacro defregset (name &rest regs)
-  `(eval-when (compile eval load)
-     (defconstant ,name
-       (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))
-
-)
-
-(eval-when (compile eval load)
-
-(defvar *register-names* (make-array 32 :initial-element nil))
-
-); eval-when
-
-(defreg zero 0)
-#-gengc (defreg nl3 1)
-#+gengc (defreg lip 1)
-(defreg cfunc 2)
-(defreg nl4 3)
-(defreg nl0 4) ; First C argument reg.
-(defreg nl1 5)
-(defreg nl2 6)
-(defreg nargs 7)
-(defreg a0 8)
-(defreg a1 9)
-(defreg a2 10)
-(defreg a3 11)
-(defreg a4 12)
-(defreg a5 13)
-(defreg fdefn 14)
-(defreg lexenv 15)
-;; First saved reg
-(defreg nfp 16)
-(defreg ocfp 17)
-#-gengc (defreg lra 18)
-#+gengc (defreg mutator 18)
-(defreg l0 19)
-(defreg null 20)
-(defreg bsp 21)
-(defreg cfp 22)
-(defreg csp 23)
-#-gengc (defreg l1 24)
-#+gengc (defreg ssb 24)
-(defreg alloc 25)
-(defreg nsp 29)
-(defreg code 30)
-#-gengc
-(defreg lip 31)
-#+gengc
-(defreg ra 31)
-
-(defregset non-descriptor-regs
-  nl0 nl1 nl2 ra nl4 cfunc nargs)
-
-(defregset descriptor-regs
-  a0 a1 a2 a3 a4 a5 fdefn lexenv nfp ocfp #-gengc lra l0 #-gengc l1)
-
-(defregset register-arg-offsets
-  a0 a1 a2 a3 a4 a5)
-
-(defregset reserve-descriptor-regs
-  fdefn lexenv)
-
-(defregset reserve-non-descriptor-regs
-  nl4 cfunc)
-
-
-;;;; SB and SC definition:
-
-(define-storage-base registers :finite :size 32)
-(define-storage-base float-registers :finite :size 32)
-(define-storage-base control-stack :unbounded :size 8)
-(define-storage-base non-descriptor-stack :unbounded :size 0)
-(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)
-  (do ((forms (list 'progn)
-	      (let* ((class (car classes))
-		     (sc-name (car class))
-		     (constant-name (intern (concatenate 'simple-string
-							 (string sc-name)
-							 "-SC-NUMBER"))))
-		(list* `(define-storage-class ,sc-name ,index
-			  ,@(cdr class))
-		       `(defconstant ,constant-name ,index)
-		       `(export ',constant-name)
-		       forms)))
-       (index 0 (1+ index))
-       (classes classes (cdr classes)))
-      ((null classes)
-       (nreverse forms))))
-
-(define-storage-classes
-
-  ;; Non-immediate constants in the constant pool
-  (constant constant)
-
-  ;; Immediate constant.
-  (null immediate-constant)
-  (zero immediate-constant)
-  (immediate immediate-constant)
-
-  ;; **** The stacks.
-
-  ;; The control stack.  (Scanned by GC)
-  (control-stack control-stack)
-
-  ;; The non-descriptor stacks.
-  (signed-stack non-descriptor-stack) ; (signed-byte 32)
-  (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
-  (base-char-stack non-descriptor-stack) ; non-descriptor characters.
-  (sap-stack non-descriptor-stack) ; System area pointers.
-  (single-stack non-descriptor-stack) ; single-floats
-  (double-stack non-descriptor-stack :element-size 2) ; double floats.
-
-
-  ;; **** Things that can go in the integer registers.
-
-  ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
-  ;; bad will happen if they are.  (fixnums, characters, header values, etc).
-  (any-reg
-   registers
-   :locations #.(append non-descriptor-regs descriptor-regs)
-   :reserve-locations #.(append reserve-non-descriptor-regs
-				reserve-descriptor-regs)
-   :constant-scs (constant zero immediate)
-   :save-p t
-   :alternate-scs (control-stack))
-
-  ;; Pointer descriptor objects.  Must be seen by GC.
-  (descriptor-reg registers
-   :locations #.descriptor-regs
-   :reserve-locations #.reserve-descriptor-regs
-   :constant-scs (constant null immediate)
-   :save-p t
-   :alternate-scs (control-stack))
-
-  ;; Non-Descriptor characters
-  (base-char-reg registers
-   :locations #.non-descriptor-regs
-   :reserve-locations #.reserve-non-descriptor-regs
-   :constant-scs (immediate)
-   :save-p t
-   :alternate-scs (base-char-stack))
-
-  ;; Non-Descriptor SAP's (arbitrary pointers into address space)
-  (sap-reg registers
-   :locations #.non-descriptor-regs
-   :reserve-locations #.reserve-non-descriptor-regs
-   :constant-scs (immediate)
-   :save-p t
-   :alternate-scs (sap-stack))
-
-  ;; Non-Descriptor (signed or unsigned) numbers.
-  (signed-reg registers
-   :locations #.non-descriptor-regs
-   :reserve-locations #.reserve-non-descriptor-regs
-   :constant-scs (zero immediate)
-   :save-p t
-   :alternate-scs (signed-stack))
-  (unsigned-reg registers
-   :locations #.non-descriptor-regs
-   :reserve-locations #.reserve-non-descriptor-regs
-   :constant-scs (zero immediate)
-   :save-p t
-   :alternate-scs (unsigned-stack))
-
-  ;; Random objects that must not be seen by GC.  Used only as temporaries.
-  (non-descriptor-reg registers
-   :locations #.non-descriptor-regs)
-
-  ;; Pointers to the interior of objects.  Used only as an temporary.
-  (interior-reg registers
-   :locations (#.lip-offset))
-
-
-  ;; **** Things that can go in the floating point registers.
-
-  ;; Non-Descriptor single-floats.
-  (single-reg float-registers
-   :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
-   :reserve-locations (26 28 30)
-   :constant-scs ()
-   :save-p t
-   :alternate-scs (single-stack))
-
-  ;; Non-Descriptor double-floats.
-  (double-reg float-registers
-   :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
-   :reserve-locations (26 28 30)
-   ;; Note: we don't bother with the element size, 'cause nothing can be
-   ;; allocated in the odd fp regs anyway.
-   :constant-scs ()
-   :save-p t
-   :alternate-scs (double-stack))
-
-  ;; A catch or unwind block.
-  (catch-block control-stack :element-size vm:catch-block-size))
-
-
-
-
-;;;; Random TNs for interesting registers
-
-(eval-when (compile eval)
-
-(defmacro defregtn (name sc)
-  (let ((offset-sym (symbolicate name "-OFFSET"))
-	(tn-sym (symbolicate name "-TN")))
-    `(defparameter ,tn-sym
-       (make-random-tn :kind :normal
-		       :sc (sc-or-lose ',sc)
-		       :offset ,offset-sym))))
-
-)
-
-(defregtn zero any-reg)
-(defregtn lip interior-reg)
-(defregtn code descriptor-reg)
-(defregtn alloc any-reg)
-(defregtn null descriptor-reg)
-#+gengc (defregtn mutator sap-reg)
-#+gengc (defregtn ssb sap-reg)
-
-(defregtn nargs any-reg)
-(defregtn fdefn descriptor-reg)
-(defregtn lexenv descriptor-reg)
-
-(defregtn bsp any-reg)
-(defregtn csp any-reg)
-(defregtn cfp any-reg)
-(defregtn ocfp any-reg)
-(defregtn nsp any-reg)
-(defregtn nfp any-reg)
-#+gengc (defregtn ra any-reg)
-
-
-;;;
-;;; Immediate-Constant-SC  --  Interface
-;;;
-;;; If value can be represented as an immediate constant, then return the
-;;; appropriate SC number, otherwise return NIL.
-;;;
-(def-vm-support-routine immediate-constant-sc (value)
-  (typecase value
-    ((integer 0 0)
-     (sc-number-or-lose 'zero *backend*))
-    (null
-     (sc-number-or-lose 'null *backend*))
-    (symbol
-     (if (vm:static-symbol-p value)
-	 (sc-number-or-lose 'immediate *backend*)
-	 nil))
-    ((signed-byte 30)
-     (sc-number-or-lose 'immediate *backend*))
-    (system-area-pointer
-     (sc-number-or-lose 'immediate *backend*))
-    (character
-     (sc-number-or-lose 'immediate *backend*))))
-
-
-;;;; Function Call Parameters
-
-;;; The SC numbers for register and stack arguments/return values.
-;;;
-(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
-(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
-(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
-
-(eval-when (compile load eval)
-
-;;; Offsets of special stack frame locations
-(defconstant ocfp-save-offset 0)
-#-gengc (defconstant lra-save-offset 1)
-#+gengc (defconstant ra-save-offset 1)
-(defconstant nfp-save-offset 2)
-#+gengc (defconstant code-save-offset 3)
-
-
-;;; 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.
-;;;
-
-;;; 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))
-
-;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
-;;;
-;;; This is used by the debugger.
-;;;
-(export 'single-value-return-byte-offset)
-(defconstant single-value-return-byte-offset 8)
-
-
-;;; LOCATION-PRINT-NAME  --  Interface
-;;;
-;;;    This function is called by debug output routines that want a pretty name
-;;; for a TN's location.  It returns a thing that can be printed with PRINC.
-;;;
-(def-vm-support-routine location-print-name (tn)
-  (declare (type tn tn))
-  (let ((sb (sb-name (sc-sb (tn-sc tn))))
-	(offset (tn-offset tn)))
-    (ecase sb
-      (registers (or (svref *register-names* offset)
-		     (format nil "R~D" offset)))
-      (float-registers (format nil "F~D" offset))
-      (control-stack (format nil "CS~D" offset))
-      (non-descriptor-stack (format nil "NS~D" offset))
-      (constant (format nil "Const~D" offset))
-      (immediate-constant "Immed"))))
diff --git a/compiler/new-assem.lisp b/compiler/new-assem.lisp
deleted file mode 100644
index b8f47b953bb3e2b8a5abaebbafdf8ab065c02cce..0000000000000000000000000000000000000000
--- a/compiler/new-assem.lisp
+++ /dev/null
@@ -1,1778 +0,0 @@
-;;; -*- Package: NEW-ASSEM -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.21 1992/11/23 13:42:36 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Effecient retargetable scheduling assembler.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package :new-assem)
-
-(in-package :c)
-(import '(branch flushable) :new-assem)
-(import '(sset-element sset make-sset do-elements
-	  sset-adjoin sset-delete sset-empty)
-	:new-assem)
-
-(in-package :new-assem)
-(export '(emit-byte emit-skip emit-back-patch emit-chooser emit-postit
-	  define-emitter define-instruction define-instruction-macro
-	  def-assembler-params branch flushable variable-length reads writes
-
-	  segment make-segment segment-name
-	  assemble align inst without-scheduling 
-	  label label-p gen-label emit-label label-position
-	  append-segment finalize-segment
-	  segment-map-output release-segment))
-
-
-;;;; Assembly control parameters.
-
-(defstruct (assem-params
-	    (:print-function %print-assem-params))
-  (backend (ext:required-argument) :type c::backend)
-  (scheduler-p nil :type (member t nil))
-  (instructions (make-hash-table :test #'equal) :type hash-table)
-  (max-locations 0 :type index))
-;;;
-(c::defprinter assem-params
-  (backend :prin1 (c:backend-name backend)))
-
-;;; DEF-ASSEMBLER-PARAMS -- Interface.
-;;;
-(defmacro def-assembler-params (&rest options)
-  "Set up the assembler."
-  `(eval-when (compile load eval)
-     (setf (c:backend-assembler-params c:*target-backend*)
-	   (make-assem-params :backend c:*target-backend*
-			      ,@options))))
-
-
-;;;; Constants.
-
-;;; ASSEMBLY-UNIT-BITS -- Number of bits in the minimum assembly unit,
-;;; (also refered to as a ``byte'').  Hopefully, different instruction
-;;; sets won't require chainging this.
-;;; 
-(defconstant assembly-unit-bits 8)
-
-(deftype assembly-unit ()
-  `(unsigned-byte ,assembly-unit-bits))
-
-;;; OUTPUT-BLOCK-SIZE -- The size (in bytes) to use per output block.  Each
-;;; output block is a chunk of raw memory, pointed to by a sap.
-;;;
-(defconstant output-block-size (* 8 1024))
-
-(deftype output-block-index ()
-  `(integer 0 ,output-block-size))
-
-;;; MAX-ALIGNMENT -- The maximum alignment we can guarentee given the object
-;;; format.  If the loader only loads objects 8-byte aligned, we can't do
-;;; any better then that ourselves.
-;;;
-(defconstant max-alignment 3)
-
-(deftype alignment ()
-  `(integer 0 ,max-alignment))
-
-;;; MAX-INDEX -- The maximum an index will ever become.  Well, actually,
-;;; just a bound on it so we can define a type.  There is no real hard
-;;; limit on indexes, but we will run out of memory sometime.
-;;; 
-(defconstant max-index (1- most-positive-fixnum))
-
-(deftype index ()
-  `(integer 0 ,max-index))
-
-;;; MAX-POSN -- Like MAX-INDEX, except for positions.
-;;; 
-(defconstant max-posn (1- most-positive-fixnum))
-
-(deftype posn ()
-  `(integer 0 ,max-posn))
-
-
-
-;;;; The SEGMENT structure.
-
-;;; SEGMENT -- This structure holds the state of the assembler.
-;;; 
-(defstruct (segment
-	    (:print-function %print-segment)
-	    (:constructor make-segment (&key name run-scheduler inst-hook)))
-  ;;
-  ;; The name of this segment.  Only using in trace files.
-  (name "Unnamed" :type simple-base-string)
-  ;;
-  ;; Wether or not run the scheduler.  Note: if the instruction defintions
-  ;; were not compiled with the scheduler turned on, this has no effect.
-  (run-scheduler nil)
-  ;;
-  ;; If a function, then it is funcalled for each inst emitted with the
-  ;; segment, the VOP, the name of the inst (as a string), and the inst
-  ;; arguments.
-  (inst-hook nil :type (or function null))
-  ;;
-  ;; Where to deposit the next byte.
-  (fill-pointer (system:int-sap 0) :type system:system-area-pointer)
-  ;;
-  ;; Where the current output block ends.  If fill-pointer is ever sap= to
-  ;; this, don't deposit a byte.  Move the fill pointer into a new block.
-  (block-end (system:int-sap 0) :type system:system-area-pointer)
-  ;;
-  ;; What position does this correspond to.  Initially, positions and indexes
-  ;; are the same, but after we start collapsing choosers, positions can change
-  ;; while indexes stay the same.
-  (current-posn 0 :type posn)
-  ;;
-  ;; Were in the output blocks are we currently outputing.
-  (current-index 0 :type index)
-  ;;
-  ;; A vector of the output blocks.
-  (output-blocks (make-array 4 :initial-element nil) :type simple-vector)
-  ;;
-  ;; A list of all the annotations that have been output to this segment.
-  (annotations nil :type list)
-  ;;
-  ;; A pointer to the last cons cell in the annotations list.  This is
-  ;; so we can quickly add things to the end of the annotations list.
-  (last-annotation nil :type list)
-  ;;
-  ;; The number of bits of alignment at the last time we synchronized.
-  (alignment max-alignment :type alignment)
-  ;;
-  ;; The position the last time we synchronized.
-  (sync-posn 0 :type posn)
-  ;;
-  ;; The posn and index everything ends at.  This is not maintained while the
-  ;; data is being generated, but is filled in after.  Basically, we copy
-  ;; current-posn and current-index so that we can trash them while processing
-  ;; choosers and back-patches.
-  (final-posn 0 :type posn)
-  (final-index 0 :type index)
-  ;;
-  ;; *** State used by the scheduler during instruction queueing.
-  ;;
-  ;; List of postit's.  These are accumulated between instructions.
-  (postits nil :type list)
-  ;;
-  ;; ``Number'' for last instruction queued.  Used only to supply insts
-  ;; with unique sset-element-number's.
-  (inst-number 0 :type index)
-  ;;
-  ;; Simple-Vectors mapping locations to the instruction that reads them and
-  ;; instructions that write them.
-  (readers (make-array (assem-params-max-locations
-			(c:backend-assembler-params c:*backend*))
-		       :initial-element nil)
-	   :type simple-vector)
-  (writers (make-array (assem-params-max-locations
-			(c:backend-assembler-params c:*backend*))
-		       :initial-element nil)
-	   :type simple-vector)
-  ;;
-  ;; The number of additional cycles before the next control transfer, or NIL
-  ;; if a control transfer hasn't been queued.  When a delayed branch is
-  ;; queued, this slot is set to the delay count.
-  (branch-countdown nil :type (or null (and fixnum unsigned-byte)))
-  ;;
-  ;; *** These two slots are used both by the queuing noise and the
-  ;; scheduling noise.
-  ;;
-  ;; All the instructions that are pending and don't have any unresolved
-  ;; dependents.  We don't list branches here even if they would otherwise
-  ;; qualify.  They are listed above.
-  ;;
-  (emittable-insts-sset (make-sset) :type sset)
-  ;;
-  ;; List of queued branches.  We handle these specially, because they have to
-  ;; be emitted at a specific place (e.g. one slot before the end of the
-  ;; block).
-  (queued-branches nil :type list)
-  ;;
-  ;; *** State used by the scheduler duing instruction scheduling.
-  ;;
-  ;; The instructions who would have had a read dependent removed if it were
-  ;; not for a delay slot.  This is a list of lists.  Each element in the
-  ;; top level list corresponds to yet another cycle of delay.  Each element
-  ;; in the second level lists is a dotted pair, holding the dependency
-  ;; instruction and the dependent to remove.
-  (delayed nil :type list)
-  ;;
-  ;; The emittable insts again, except this time as a list sorted by depth.
-  (emittable-insts-queue nil :type list))
-
-(c::defprinter segment name)
-
-
-;;;; Structures/types used by the scheduler.
-
-(c:def-boolean-attribute instruction
-  ;;
-  ;; This attribute is set if the scheduler can freely flush this instruction
-  ;; if it thinks it is not needed.  Examples are NOP and instructions that
-  ;; have no side effect not described by the writes.
-  flushable
-  ;;
-  ;; This attribute is set when an instruction can cause a control transfer.
-  ;; For test instructions, the delay is used to determine how many
-  ;; instructions follow the branch.
-  branch
-  ;;
-  ;; This attribute indicates that this ``instruction'' can be variable length,
-  ;; and therefore better never be used in a branch delay slot.
-  variable-length
-  )
-
-(defstruct (instruction
-	    (:include sset-element)
-	    (:print-function %print-instruction)
-	    (:conc-name inst-)
-	    (:constructor make-instruction (number emitter attributes delay)))
-  ;;
-  ;; The function to envoke to actually emit this instruction.  Gets called
-  ;; with the segment as its one argument.
-  (emitter (required-argument) :type (or null function))
-  ;;
-  ;; The attributes of this instruction.
-  (attributes (instruction-attributes) :type c:attributes)
-  ;;
-  ;; Number of instructions or cycles of delay before additional instructions
-  ;; can read our writes.
-  (delay 0 :type (and fixnum unsigned-byte))
-  ;;
-  ;; The maximum number of instructions in the longest dependency chain from
-  ;; this instruction to one of the independent instructions.  This is used
-  ;; as a heuristic at to which instructions should be scheduled first.
-  (depth nil :type (or null (and fixnum unsigned-byte)))
-  ;;
-  ;; ** When trying remember which of the next four is which, note that the
-  ;; ``read'' or ``write'' always referes to the dependent (second)
-  ;; instruction.
-  ;;
-  ;; Instructions whos writes this instruction tries to read.
-  (read-dependencies (make-sset) :type sset)
-  ;;
-  ;; Instructions whos writes or reads are overwritten by this instruction.
-  (write-dependencies (make-sset) :type sset)
-  ;;
-  ;; Instructions who write what we read or write.
-  (write-dependents (make-sset) :type sset)
-  ;;
-  ;; Instructions who read what we write.
-  (read-dependents (make-sset) :type sset))
-;;;
-#+debug (defvar *inst-ids* (make-hash-table :test #'eq))
-#+debug (defvar *next-inst-id* 0)
-(defun %print-instruction (inst stream depth)
-  (declare (ignore depth))
-  (print-unreadable-object (inst stream :type t :identity t)
-    #+debug
-    (princ (or (gethash inst *inst-ids*)
-	       (setf (gethash inst *inst-ids*)
-		     (incf *next-inst-id*)))
-	   stream)
-    (format stream #+debug " emitter=~S" #-debug "emitter=~S"
-	    (let ((emitter (inst-emitter inst)))
-	      (if emitter
-		  (multiple-value-bind
-		      (lambda lexenv-p name)
-		      (function-lambda-expression emitter)
-		    (declare (ignore lambda lexenv-p))
-		    name)
-		  '<flushed>)))
-    (when (inst-depth inst)
-      (format stream ", depth=~D" (inst-depth inst)))))
-
-#+debug
-(defun reset-inst-ids ()
-  (clrhash *inst-ids*)
-  (setf *next-inst-id* 0))
-
-
-;;;; The scheduler itself.
-
-;;; WITHOUT-SCHEDULING -- interface.
-;;;
-(defmacro without-scheduling ((&optional (segment '*current-segment*))
-			      &body body)
-  "Execute BODY (as a progn) without scheduling any of the instructions
-   generated inside it.  DO NOT throw or return-from out of it."
-  (let ((var (gensym))
-	(seg (gensym)))
-    `(let* ((,seg ,segment)
-	    (,var (segment-run-scheduler ,seg)))
-       (when ,var
-	 (schedule-pending-instructions ,seg)
-	 (setf (segment-run-scheduler ,seg) nil))
-       ,@body
-       (setf (segment-run-scheduler ,seg) ,var))))
-
-(defmacro note-dependencies ((segment inst) &body body)
-  (ext:once-only ((segment segment) (inst inst))
-    `(macrolet ((reads (loc) `(note-read-dependency ,',segment ,',inst ,loc))
-		(writes (loc &rest keys)
-		  `(note-write-dependency ,',segment ,',inst ,loc ,@keys)))
-       ,@body)))
-
-(defun note-read-dependency (segment inst read)
-  (let ((index (c:location-number read)))
-    #+debug (format *trace-output* "~&~S reads ~S[~D]~%" inst read index)
-    (when index
-      (let ((writers (svref (segment-writers segment) index)))
-	(when writers
-	  ;; The inst that wrote the value we want to read must have completed.
-	  (let ((writer (car writers)))
-	    (sset-adjoin writer (inst-read-dependencies inst))
-	    (sset-adjoin inst (inst-read-dependents writer))
-	    (sset-delete writer (segment-emittable-insts-sset segment))
-	    ;; And it must have been completed *after* all other writes to that
-	    ;; location.  Actually, that isn't quite true.  Each of the earlier
-	    ;; writes could be done either before this last write, or after the
-	    ;; read, but we have no way of representing that.
-	    (dolist (other-writer (cdr writers))
-	      (sset-adjoin other-writer (inst-write-dependencies writer))
-	      (sset-adjoin writer (inst-write-dependents other-writer))
-	      (sset-delete other-writer
-			   (segment-emittable-insts-sset segment))))
-	  ;; And we don't need to remember about earlier writes any more.
-	  ;; Shortening the writers list means that we won't bother generating
-	  ;; as many explicit arcs in the graph.
-	  (setf (cdr writers) nil)))
-      (push inst (svref (segment-readers segment) index))))
-  (ext:undefined-value))
-
-(defun note-write-dependency (segment inst write &key partially)
-  (let ((index (c:location-number write)))
-    #+debug (format *trace-output* "~&~S writes ~S[~D]~%" inst write index)
-    (when index
-      ;; All previous reads of this location must have completed.
-      (dolist (prev-inst (svref (segment-readers segment) index))
-	(unless (eq prev-inst inst)
-	  (sset-adjoin prev-inst (inst-write-dependencies inst))
-	  (sset-adjoin inst (inst-write-dependents prev-inst))
-	  (sset-delete prev-inst (segment-emittable-insts-sset segment))))
-      (when partially
-	;; All previous writes to the location must have completed.
-	(dolist (prev-inst (svref (segment-writers segment) index))
-	  (sset-adjoin prev-inst (inst-write-dependencies inst))
-	  (sset-adjoin inst (inst-write-dependents prev-inst))
-	  (sset-delete prev-inst (segment-emittable-insts-sset segment)))
-	;; And we can forget about remembering them, because depending on us
-	;; is as good as depending on them.
-	(setf (svref (segment-writers segment) index) nil))
-      (push inst (svref (segment-writers segment) index))))
-  (ext:undefined-value))
-
-;;; QUEUE-INST -- internal.
-;;;
-;;; This routine is called by due to uses of the INST macro when the scheduler
-;;; is turned on.  The change to the dependency graph has already been
-;;; computed, so we just have to check to see if the basic block is terminated.
-;;; 
-(defun queue-inst (segment inst)
-  #+debug (format *trace-output* "~&Queuing ~S~%" inst)
-  (assert (segment-run-scheduler segment))
-  (let ((countdown (segment-branch-countdown segment)))
-    (when countdown
-      (decf countdown)
-      (assert (not (instruction-attributep (inst-attributes inst)
-					   variable-length))))
-    (cond ((instruction-attributep (inst-attributes inst) branch)
-	   (unless countdown
-	     (setf countdown (inst-delay inst)))
-	   (push (cons countdown inst)
-		 (segment-queued-branches segment)))
-	  (t
-	   (sset-adjoin inst (segment-emittable-insts-sset segment))))
-    (when countdown
-      (setf (segment-branch-countdown segment) countdown)
-      (when (zerop countdown)
-	(schedule-pending-instructions segment))))
-  #+debug
-  (format *trace-output* "  reads ~S~%  writes ~S~%"
-	  (ext:collect ((reads))
-	    (do-elements (read (inst-read-dependencies inst))
-	      (reads read))
-	    (reads))
-	  (ext:collect ((writes))
-	    (do-elements (write (inst-write-dependencies inst))
-	      (writes write))
-	    (writes)))
-  (ext:undefined-value))
-
-;;; SCHEDULE-PENDING-INSTRUCTIONS -- internal.
-;;;
-;;; Emit all the pending instructions, and reset any state.  This is called
-;;; whenever we hit a label (i.e. an entry point of some kind) and when the
-;;; user turns the scheduler off (otherwise, the queued instructions would
-;;; sit there until the scheduler was turned back on, and emitted in the
-;;; wrong place).
-;;; 
-(defun schedule-pending-instructions (segment)
-  (assert (segment-run-scheduler segment))
-  ;;
-  ;; Quick blow-out if nothing to do.
-  (when (and (sset-empty (segment-emittable-insts-sset segment))
-	     (null (segment-queued-branches segment)))
-    (return-from schedule-pending-instructions
-		 (ext:undefined-value)))
-  ;;
-  ;; Note that any values live at the end of the block have to be computed
-  ;; last.
-  (let ((emittable-insts (segment-emittable-insts-sset segment))
-	(writers (segment-writers segment)))
-    (dotimes (index (length writers))
-      (let* ((writer (svref writers index))
-	     (inst (car writer))
-	     (overwritten (cdr writer)))
-	(when writer
-	  (when overwritten
-	    (let ((write-dependencies (inst-write-dependencies inst)))
-	      (dolist (other-inst overwritten)
-		(sset-adjoin inst (inst-write-dependents other-inst))
-		(sset-adjoin other-inst write-dependencies)
-		(sset-delete other-inst emittable-insts))))
-	  ;; If the value is live at the end of the block, we can't flush it.
-	  (setf (instruction-attributep (inst-attributes inst) flushable)
-		nil)))))
-  ;;
-  ;; Grovel through the entire graph in the forward direction finding all
-  ;; the leaf instructions.
-  (labels ((grovel-inst (inst)
-	     (let ((max 0))
-	       (do-elements (dep (inst-write-dependencies inst))
-		 (let ((dep-depth (or (inst-depth dep) (grovel-inst dep))))
-		   (when (> dep-depth max)
-		     (setf max dep-depth))))
-	       (do-elements (dep (inst-read-dependencies inst))
-		 (let ((dep-depth
-			(+ (or (inst-depth dep) (grovel-inst dep))
-			   (inst-delay dep))))
-		   (when (> dep-depth max)
-		     (setf max dep-depth))))
-	       (cond ((and (sset-empty (inst-read-dependents inst))
-			   (instruction-attributep (inst-attributes inst)
-						   flushable))
-		      #+debug
-		      (format *trace-output* "Flushing ~S~%" inst)
-		      (setf (inst-emitter inst) nil)
-		      (setf (inst-depth inst) max))
-		     (t
-		      (setf (inst-depth inst) max))))))
-    (let ((emittable-insts nil)
-	  (delayed nil))
-      (do-elements (inst (segment-emittable-insts-sset segment))
-	(grovel-inst inst)
-	(if (zerop (inst-delay inst))
-	    (push inst emittable-insts)
-	    (setf delayed
-		  (add-to-nth-list delayed inst (1- (inst-delay inst))))))
-      (setf (segment-emittable-insts-queue segment)
-	    (sort emittable-insts #'> :key #'inst-depth))
-      (setf (segment-delayed segment) delayed))
-    (dolist (branch (segment-queued-branches segment))
-      (grovel-inst (cdr branch))))
-  #+debug
-  (format *trace-output* "Queued branches: ~S~%"
-	  (segment-queued-branches segment))
-  #+debug
-  (format *trace-output* "Initially emittable: ~S~%"
-	  (segment-emittable-insts-queue segment))
-  #+debug
-  (format *trace-output* "Initially delayed: ~S~%"
-	  (segment-delayed segment))
-  ;;
-  ;; Accumulate the results in reverse order.  Well, actually, this list will
-  ;; be in forward order, because we are generating the reverse order in
-  ;; reverse.
-  (let ((results nil))
-    ;;
-    ;; Schedule all the branches in their exact locations.
-    (let ((insts-from-end (segment-branch-countdown segment)))
-      (dolist (branch (segment-queued-branches segment))
-	(let ((inst (cdr branch)))
-	  (dotimes (i (- (car branch) insts-from-end))
-	    #+debug
-	    (format *trace-output* "Filling branch delay slot...~%")
-	    (flet ((maybe-schedule-dependent (dependents)
-		     (do-elements (inst dependents)
-		       (note-resolved-dependencies segment inst)
-		       (setf (segment-emittable-insts-queue segment)
-			     (delete inst
-				     (segment-emittable-insts-queue segment)
-				     :test #'eq))
-		       (return inst))))
-	      (push (or (maybe-schedule-dependent (inst-read-dependents inst))
-			(maybe-schedule-dependent (inst-write-dependents inst))
-			(schedule-one-inst segment t)
-			:nop)
-		    results))
-	    (advance-one-inst segment)
-	    (incf insts-from-end))
-	  (note-resolved-dependencies segment inst)
-	  (push inst results)
-	  #+debug
-	  (format *trace-output* "Emitting ~S~%" inst)
-	  (advance-one-inst segment))))
-    ;;
-    ;; Keep scheduling stuff until we run out.
-    (loop
-      (let ((inst (schedule-one-inst segment nil)))
-	(unless inst
-	  (return))
-	(push inst results)
-	(advance-one-inst segment)))
-    ;;
-    ;; Now call the emitters, but turn the scheduler off for the duration.
-    (setf (segment-run-scheduler segment) nil)
-    (dolist (inst results)
-      (if (eq inst :nop)
-	  (c:emit-nop segment)
-	  (funcall (inst-emitter inst) segment)))
-    (setf (segment-run-scheduler segment) t))
-  ;;
-  ;; Clear out any residue left over.
-  (setf (segment-inst-number segment) 0)
-  (setf (segment-queued-branches segment) nil)
-  (setf (segment-branch-countdown segment) nil)
-  (setf (segment-emittable-insts-sset segment) (make-sset))
-  (fill (segment-readers segment) nil)
-  (fill (segment-writers segment) nil)
-  ;;
-  ;; That's all folks.
-  (ext:undefined-value))
-
-;;; ADD-TO-NTH-LIST -- internal.
-;;;
-;;; Utility for maintaining the segment-delayed list.  We cdr down list
-;;; n times (extending it if necessary) and then push thing on into the car
-;;; of that cons cell.
-;;; 
-(defun add-to-nth-list (list thing n)
-  (do ((cell (or list (setf list (list nil)))
-	     (or (cdr cell) (setf (cdr cell) (list nil))))
-       (i n (1- i)))
-      ((zerop i)
-       (push thing (car cell))
-       list)))
-
-;;; SCHEDULE-ONE-INST -- internal.
-;;;
-;;; Find the next instruction to schedule and return it after updating
-;;; any dependency information.  If we can't do anything useful right
-;;; now, but there is more work to be done, return :NOP to indicate that
-;;; a nop must be emitted.  If we are all done, return NIL.
-;;; 
-(defun schedule-one-inst (segment delay-slot-p)
-  (do ((prev nil remaining)
-       (remaining (segment-emittable-insts-queue segment) (cdr remaining)))
-      ((null remaining))
-    (let ((inst (car remaining)))
-      (unless (and delay-slot-p
-		   (instruction-attributep (inst-attributes inst)
-					   variable-length))
-	;; We've got us a live one here.  Go for it.
-	#+debug
-	(format *Trace-output* "Emitting ~S~%" inst)
-	;; Delete it from the list of insts.
-	(if prev
-	    (setf (cdr prev) (cdr remaining))
-	    (setf (segment-emittable-insts-queue segment)
-		  (cdr remaining)))
-	;; Note that this inst has been emitted.
-	(note-resolved-dependencies segment inst)
-	;; And return.
-	(return-from schedule-one-inst
-		     ;; Are we wanting to flush this instruction?
-		     (if (inst-emitter inst)
-			 ;; Nope, it's still a go.  So return it.
-			 inst
-			 ;; Yes, so pick a new one.  We have to start over,
-			 ;; because note-resolved-dependencies might have
-			 ;; changed the emittable-insts-queue.
-			 (schedule-one-inst segment delay-slot-p))))))
-  ;; Nothing to do, so make something up.
-  (cond ((segment-delayed segment)
-	 ;; No emittable instructions, but we have more work to do.  Emit
-	 ;; a NOP to fill in a delay slot.
-	 #+debug (format *trace-output* "Emitting a NOP.~%")
-	 :nop)
-	(t
-	 ;; All done.
-	 nil)))
-
-;;; NOTE-RESOLVED-DEPENDENCIES -- internal.
-;;;
-;;; This function is called whenever an instruction has been scheduled, and we
-;;; want to know what possibilities that opens up.  So look at all the
-;;; instructions that this one depends on, and remove this instruction from
-;;; their dependents list.  If we were the last dependent, then that
-;;; dependency can be emitted now.
-;;;
-(defun note-resolved-dependencies (segment inst)
-  (assert (sset-empty (inst-read-dependents inst)))
-  (assert (sset-empty (inst-write-dependents inst)))
-  (do-elements (dep (inst-write-dependencies inst))
-    ;; These are the instructions who have to be completed before our
-    ;; write fires.  Doesn't matter how far before, just before.
-    (let ((dependents (inst-write-dependents dep)))
-      (sset-delete inst dependents)
-      (when (and (sset-empty dependents)
-		 (sset-empty (inst-read-dependents dep)))
-	(insert-emittable-inst segment dep))))
-  (do-elements (dep (inst-read-dependencies inst))
-    ;; These are the instructions who write values we read.  If there
-    ;; is no delay, then just remove us from the dependent list.
-    ;; Otherwise, record the fact that in n cycles, we should be
-    ;; removed.
-    (if (zerop (inst-delay dep))
-	(let ((dependents (inst-read-dependents dep)))
-	  (sset-delete inst dependents)
-	  (when (and (sset-empty dependents)
-		     (sset-empty (inst-write-dependents dep)))
-	    (insert-emittable-inst segment dep)))
-	(setf (segment-delayed segment)
-	      (add-to-nth-list (segment-delayed segment)
-			       (cons dep inst)
-			       (inst-delay dep)))))
-  (ext:undefined-value))
-
-;;; ADVANCE-ONE-INST -- internal.
-;;;
-;;; Process the next entry in segment-delayed.  This is called whenever anyone
-;;; emits an instruction.
-;;;
-(defun advance-one-inst (segment)
-  (let ((delayed-stuff (pop (segment-delayed segment))))
-    (dolist (stuff delayed-stuff)
-      (if (consp stuff)
-	  (let* ((dependency (car stuff))
-		 (dependent (cdr stuff))
-		 (dependents (inst-read-dependents dependency)))
-	    (sset-delete dependent dependents)
-	    (when (and (sset-empty dependents)
-		       (sset-empty (inst-write-dependents dependency)))
-	      (insert-emittable-inst segment dependency)))
-	  (insert-emittable-inst segment stuff)))))
-
-;;; INSERT-EMITTABLE-INST -- internal.
-;;;
-;;; Note that inst is emittable by sticking it in the SEGMENT-EMITTABLE-INSTS-
-;;; QUEUE list.  We keep the emittable-insts sorted with the largest ``depths''
-;;; first.  Except that if INST is a branch, don't bother.  It will be handled
-;;; correctly by the branch emitting code in SCHEDULE-PENDING-INSTRUCTIONS.
-;;;
-(defun insert-emittable-inst (segment inst)
-  (unless (instruction-attributep (inst-attributes inst) branch)
-    #+debug
-    (format *Trace-output* "Now emittable: ~S~%" inst)
-    (do ((my-depth (inst-depth inst))
-	 (remaining (segment-emittable-insts-queue segment) (cdr remaining))
-	 (prev nil remaining))
-	((or (null remaining) (> my-depth (inst-depth (car remaining))))
-	 (if prev
-	     (setf (cdr prev) (cons inst remaining))
-	     (setf (segment-emittable-insts-queue segment)
-		   (cons inst remaining))))))
-  (ext:undefined-value))
-
-
-;;;; Structure used during output emission.
-
-;;; ANNOTATION -- Common supertype for all the different kinds of annotations.
-;;; 
-(defstruct (annotation
-	    (:constructor nil))
-  ;;
-  ;; Where in the raw output stream was this annotation emitted.
-  (index 0 :type index)
-  ;;
-  ;; What position does that correspond to.
-  (posn nil :type (or index null)))
-
-;;; LABEL -- Doesn't need any additional information beyond what is in the
-;;; annotation structure.
-;;; 
-(defstruct (label
-	    (:include annotation)
-	    (:constructor gen-label ())
-	    (:print-function %print-label))
-  )
-;;;
-(defun %print-label (label stream depth)
-  (declare (ignore depth))
-  (if (or *print-escape* *print-readably*)
-      (print-unreadable-object (label stream :type t)
-	(prin1 (c:label-id label) stream))
-      (format stream "L~D" (c:label-id label))))
-
-;;; ALIGNMENT-NOTE -- A constraint on how the output stream must be aligned.
-;;; 
-(defstruct (alignment-note
-	    (:include annotation)
-	    (:conc-name alignment-)
-	    (:predicate alignment-p)
-	    (:constructor make-alignment (bits size)))
-  ;;
-  ;; The minimum number of low-order bits that must be zero.
-  (bits 0 :type alignment)
-  ;;
-  ;; The amount of filler we are assuming this alignment op will take.
-  (size 0 :type (integer 0 #.(1- (ash 1 max-alignment)))))
-
-;;; BACK-PATCH -- a reference to someplace that needs to be back-patched when
-;;; we actually know what label positions, etc. are.
-;;; 
-(defstruct (back-patch
-	    (:include annotation)
-	    (:constructor make-back-patch (size function)))
-  ;;
-  ;; The area effected by this back-patch.
-  (size 0 :type index)
-  ;;
-  ;; The function to use to generate the real data
-  (function nil :type function))
-
-;;; CHOOSER -- Similar to a back-patch, but also an indication that the amount
-;;; of stuff output depends on label-positions, etc.  Back-patches can't change
-;;; their mind about how much stuff to emit, but choosers can.
-;;; 
-(defstruct (chooser
-	    (:include annotation)
-	    (:constructor make-chooser
-			  (size alignment maybe-shrink worst-case-fun)))
-  ;;
-  ;; The worst case size for this chooser.  There is this much space allocated
-  ;; in the output buffer.
-  (size 0 :type index)
-  ;;
-  ;; The worst case alignment this chooser is guarenteed to preserve.
-  (alignment 0 :type alignment)
-  ;;
-  ;; The function to call to determine of we can use a shorter sequence.  It
-  ;; returns NIL if nothing shorter can be used, or emits that sequence and
-  ;; returns T.
-  (maybe-shrink nil :type function)
-  ;;
-  ;; The function to call to generate the worst case sequence.  This is used
-  ;; when nothing else can be condensed.
-  (worst-case-fun nil :type function))
-
-;;; FILLER -- Used internally when we figure out a chooser or alignment doesn't
-;;; really need as much space as we initially gave it.
-;;;
-(defstruct (filler
-	    (:include annotation)
-	    (:constructor make-filler (bytes)))
-  ;;
-  ;; The number of bytes of filler here.
-  (bytes 0 :type index))
-
-
-
-;;;; Output buffer utility functions.
-
-;;; A list of all the output-blocks we have allocated but aren't using.
-;;; We free-list them because allocation more is slow and the garbage collector
-;;; doesn't know about them, so it can't be slowed down by use keep ahold of
-;;; them.
-;;; 
-(defvar *available-output-blocks* nil)
-
-;;; A list of all the output-blocks we have ever allocated.  We don't really
-;;; need to keep tract of this if RELEASE-OUTPUT-BLOCK were always called,
-;;; but...
-;;;
-(defvar *all-output-blocks* nil)
-
-;;; NEW-OUTPUT-BLOCK -- internal.
-;;;
-;;; Return a new output block, allocating one if necessary.
-;;;
-(defun new-output-block ()
-  (if *available-output-blocks*
-      (pop *available-output-blocks*)
-      (let ((block (system:allocate-system-memory output-block-size)))
-	(push block *all-output-blocks*)
-	block)))
-
-;;; RELEASE-OUTPUT-BLOCK -- internal.
-;;;
-;;; Return block to the list of avaiable blocks.
-;;;
-(defun release-output-block (block)
-  (push block *available-output-blocks*))
-
-;;; FORGET-OUTPUT-BLOCKS -- internal.
-;;;
-;;; We call this whenever a core starts up, because system-memory isn't
-;;; saves with the core.  If we didn't, we would find our hands full of
-;;; bogus SAPs, which would make all sorts of things unhappy.
-;;;
-(defun forget-output-blocks ()
-  (setf *all-output-blocks* nil)
-  (setf *available-output-blocks* nil))
-;;;
-(pushnew 'forget-output-blocks ext:*after-save-initializations*)
-
-
-
-;;;; Output functions.
-
-;;; FIND-NEW-FILL-POINTER -- internal.
-;;;
-;;; Find us a new fill pointer for the current index in segment.  Allocate
-;;; any additional storage as necessary.
-;;; 
-(defun find-new-fill-pointer (segment)
-  (declare (type segment segment))
-  (let* ((index (segment-current-index segment))
-	 (blocks (segment-output-blocks segment))
-	 (num-blocks (length blocks)))
-    (multiple-value-bind
-	(block-num offset)
-	(truncate index output-block-size)
-      (when (>= block-num num-blocks)
-	(setf blocks
-	      (adjust-array blocks (+ block-num 3) :initial-element nil))
-	(setf (segment-output-blocks segment) blocks))
-      (let ((block (or (aref blocks block-num)
-		       (setf (aref blocks block-num) (new-output-block)))))
-	(setf (segment-block-end segment)
-	      (system:sap+ block output-block-size))
-	(setf (segment-fill-pointer segment) (system:sap+ block offset))))))
-
-;;; EMIT-BYTE -- interface.
-;;;
-;;; Emit the supplied BYTE to SEGMENT, growing it if necessary.
-;;; 
-(declaim (inline emit-byte))
-(defun emit-byte (segment byte)
-  "Emit BYTE to SEGMENT."
-  (declare (type segment segment)
-	   (type (or assembly-unit (signed-byte #.assembly-unit-bits)) byte))
-  (let* ((orig-ptr (segment-fill-pointer segment))
-	 (ptr (if (system:sap= orig-ptr (segment-block-end segment))
-		  (find-new-fill-pointer segment)
-		  orig-ptr)))
-    (setf (system:sap-ref-8 ptr 0) (ldb (byte assembly-unit-bits 0) byte))
-    (setf (segment-fill-pointer segment) (system:sap+ ptr 1)))
-  (incf (segment-current-posn segment))
-  (incf (segment-current-index segment))
-  (ext:undefined-value))
-
-;;; EMIT-SKIP -- interface.
-;;; 
-(defun emit-skip (segment amount)
-  "Output AMOUNT zeros (in bytes) to SEGMENT."
-  (declare (type segment segment)
-	   (type index amount))
-  (dotimes (i amount)
-    (emit-byte segment 0))
-  (ext:undefined-value))
-
-;;; EMIT-ANNOTATION -- internal.
-;;;
-;;; Used to handle the common parts of annotation emision.  We just
-;;; assign the posn and index of the note and tack it on to the end
-;;; of the segment's annotations list.
-;;; 
-(defun emit-annotation (segment note)
-  (declare (type segment segment)
-	   (type annotation note))
-  (when (annotation-posn note)
-    (error "Attempt to emit ~S for the second time."))
-  (setf (annotation-posn note) (segment-current-posn segment))
-  (setf (annotation-index note) (segment-current-index segment))
-  (let ((last (segment-last-annotation segment))
-	(new (list note)))
-    (setf (segment-last-annotation segment)
-	  (if last 
-	      (setf (cdr last) new)
-	      (setf (segment-annotations segment) new))))
-  (ext:undefined-value))
-
-;;; EMIT-BACK-PATCH -- interface.
-;;; 
-(defun emit-back-patch (segment size function)
-  "Note that the instruction stream has to be back-patched when label positions
-   are finally known.  SIZE bytes are reserved in SEGMENT, and function will
-   be called with two arguments: the segment and the position.  The function
-   should look at the position and the position of any labels it wants to
-   and emit the correct sequence.  (And it better be the same size as SIZE).
-   SIZE can be zero, which is useful if you just want to find out where things
-   ended up."
-  (emit-annotation segment (make-back-patch size function))
-  (emit-skip segment size))
-
-;;; EMIT-CHOOSER -- interface.
-;;; 
-(defun emit-chooser (segment size alignment maybe-shrink worst-case-fun)
-  "Note that the instruction stream here depends on the actual positions of
-   various labels, so can't be output until label positions are known.  Space
-   is made in SEGMENT for at least SIZE bytes.  When all output has been
-   generated, the MAYBE-SHRINK functions for all choosers are called with
-   three arguments: the segment, the position, and a magic value.  The MAYBE-
-   SHRINK decides if it can use a shorter sequence, and if so, emits that
-   sequence to the segment and returns T.  If it can't do better than the
-   worst case, it should return NIL (without emitting anything).  When calling
-   LABEL-POSITION, it should pass it the position and the magic-value it was
-   passed so that LABEL-POSITION can return the correct result.  If the chooser
-   never decides to use a shorter sequence, the WORST-CASE-FUN will be called,
-   just like a BACK-PATCH.  (See EMIT-BACK-PATCH.)"
-  (declare (type segment segment) (type index size) (type alignment alignment)
-	   (type function maybe-shrink worst-case-fun))
-  (let ((chooser (make-chooser size alignment maybe-shrink worst-case-fun)))
-    (emit-annotation segment chooser)
-    (emit-skip segment size)
-    (adjust-alignment-after-chooser segment chooser)))
-
-;;; ADJUST-ALIGNMENT-AFTER-CHOOSER -- internal.
-;;;
-;;; Called in EMIT-CHOOSER and COMPRESS-SEGMENT in order to recompute the
-;;; current alignment information in light of this chooser.  If the alignment
-;;; guarenteed byte the chooser is less then the segments current alignment,
-;;; we have to adjust the segments notion of the current alignment.
-;;;
-;;; The hard part is recomputing the sync posn, because it's not just the
-;;; choosers posn.  Consider a chooser that emits either one or three words.
-;;; It preserves 8-byte (3 bit) alignments, because the difference between
-;;; the two choices is 8 bytes.
-;;;
-(defun adjust-alignment-after-chooser (segment chooser)
-  (declare (type segment segment) (type chooser chooser))
-  (let ((alignment (chooser-alignment chooser))
-	(seg-alignment (segment-alignment segment)))
-    (when (< alignment seg-alignment)
-      ;; The chooser might change the alignment of the output.  So we have
-      ;; to figure out what the worst case alignment could be.
-      (setf (segment-alignment segment) alignment)
-      (let* ((posn (chooser-posn chooser))
-	     (sync-posn (segment-sync-posn segment))
-	     (offset (- posn sync-posn))
-	     (delta (logand offset (1- (ash 1 alignment)))))
-	(setf (segment-sync-posn segment) (- posn delta)))))
-  (ext:undefined-value))
-
-;;; EMIT-FILLER -- internal.
-;;;
-;;; Used internally whenever a chooser or alignment decides it doesn't need
-;;; as much space as it originally though.
-;;;
-(defun emit-filler (segment bytes)
-  (let ((last (segment-last-annotation segment)))
-    (cond ((and last (filler-p (car last)))
-	   (incf (filler-bytes (car last)) bytes))
-	  (t
-	   (emit-annotation segment (make-filler bytes)))))
-  (incf (segment-current-index segment) bytes)
-  (setf (segment-fill-pointer segment) (system:int-sap 0))
-  (setf (segment-block-end segment) (system:int-sap 0))
-  (ext:undefined-value))
-
-;;; %EMIT-LABEL -- internal.
-;;;
-;;; EMIT-LABEL (the interface) basically just expands into this, supplying
-;;; the segment and vop.
-;;; 
-(defun %emit-label (segment vop label)
-  (when (segment-run-scheduler segment)
-    (schedule-pending-instructions segment))
-  (let ((postits (segment-postits segment)))
-    (setf (segment-postits segment) nil)
-    (dolist (postit postits)
-      (emit-back-patch segment 0 postit)))
-  (let ((hook (segment-inst-hook segment)))
-    (when hook
-      (funcall hook segment vop :label label)))
-  (emit-annotation segment label))
-
-;;; EMIT-ALIGNMENT -- internal.
-;;;
-;;; Called by the ALIGN macro to emit an alignment note.  We check to see
-;;; if we can guarentee the alignment restriction by just outputing a fixed
-;;; number of bytes.  If so, we do so.  Otherwise, we create and emit
-;;; an alignment note.
-;;; 
-(defun emit-alignment (segment vop bits)
-  (when (segment-run-scheduler segment)
-    (schedule-pending-instructions segment))
-  (let ((hook (segment-inst-hook segment)))
-    (when hook
-      (funcall hook segment vop :align bits)))
-  (let ((alignment (segment-alignment segment))
-	(offset (- (segment-current-posn segment)
-		   (segment-sync-posn segment))))
-    (cond ((> bits alignment)
-	   ;; We need more bits of alignment.  First emit enough noise
-	   ;; to get back in sync with alignment, and then emit an alignment
-	   ;; note to cover the rest.
-	   (let ((slop (logand offset (1- (ash 1 alignment)))))
-	     (unless (zerop slop)
-	       (emit-skip segment (- (ash 1 alignment) slop))))
-	   (let ((size (logand (1- (ash 1 bits))
-			       (lognot (1- (ash 1 alignment))))))
-	     (assert (> size 0))
-	     (emit-annotation segment (make-alignment bits size))
-	     (emit-skip segment size))
-	   (setf (segment-alignment segment) bits)
-	   (setf (segment-sync-posn segment) (segment-current-posn segment)))
-	  (t
-	   ;; The last alignment was more restrictive then this one.
-	   ;; So we can just figure out how much noise to emit assuming
-	   ;; the last alignment was met.
-	   (let* ((mask (1- (ash 1 bits)))
-		  (new-offset (logand (+ offset mask) (lognot mask))))
-	     (emit-skip segment (- new-offset offset)))
-	   ;; But we emit an alignment with size=0 so we can verify
-	   ;; that everything works.
-	   (emit-annotation segment (make-alignment bits 0)))))
-  (ext:undefined-value))
-
-
-;;; FIND-ALIGNMENT -- internal.
-;;;
-;;; Used to find how ``aligned'' different offsets are.  Returns the number
-;;; of low-order 0 bits, up to MAX-ALIGNMENT.
-;;; 
-(defun find-alignment (offset)
-  (dotimes (i max-alignment max-alignment)
-    (when (logbitp i offset)
-      (return i))))
-
-;;; EMIT-POSTIT -- Internal.
-;;;
-;;; Emit a postit.  The function will be called as a back-patch with the
-;;; position the following instruction is finally emitted.  Postits do not
-;;; interfere at all with scheduling.
-;;;
-(defun %emit-postit (segment function)
-  (push function (segment-postits segment))
-  (ext:undefined-value))
-
-
-
-;;;; Output compression/position assignment stuff
-
-;;; COMPRESS-OUTPUT -- internal.
-;;;
-;;; Grovel though all the annotations looking for choosers.  When we find
-;;; a chooser, invoke the maybe-shrink function.  If it returns T, it output
-;;; some other byte sequence.
-;;; 
-(defun compress-output (segment)
-  (dotimes (i 5) ; it better not take more than one or two passes.
-    (let ((delta 0))
-      (setf (segment-alignment segment) max-alignment)
-      (setf (segment-sync-posn segment) 0)
-      (do* ((prev nil)
-	    (remaining (segment-annotations segment) next)
-	    (next (cdr remaining) (cdr remaining)))
-	   ((null remaining))
-	(let* ((note (car remaining))
-	       (posn (annotation-posn note)))
-	  (unless (zerop delta)
-	    (decf posn delta)
-	    (setf (annotation-posn note) posn))
-	  (cond
-	   ((chooser-p note)
-	    (setf (segment-current-index segment) (chooser-index note))
-	    (setf (segment-current-posn segment) posn)
-	    (setf (segment-fill-pointer segment) (system:int-sap 0))
-	    (setf (segment-block-end segment) (system:int-sap 0))
-	    (setf (segment-last-annotation segment) prev)
-	    (cond
-	     ((funcall (chooser-maybe-shrink note) segment posn delta)
-	      ;; It emitted some replacement.
-	      (let ((new-size (- (segment-current-index segment)
-				 (chooser-index note)))
-		    (old-size (chooser-size note)))
-		(when (> new-size old-size)
-		  (error "~S emitted ~D bytes, but claimed it's max was ~D"
-			 note new-size old-size))
-		(let ((additional-delta (- old-size new-size)))
-		  (when (< (find-alignment additional-delta)
-			   (chooser-alignment note))
-		    (error "~S shrunk by ~D bytes, but claimed that it ~
-			    preserve ~D bits of alignment."
-			   note additional-delta (chooser-alignment note)))
-		  (incf delta additional-delta)
-		  (emit-filler segment additional-delta))
-		(setf prev (segment-last-annotation segment))
-		(if prev
-		    (setf (cdr prev) (cdr remaining))
-		    (setf (segment-annotations segment)
-			  (cdr remaining)))))
-	     (t
-	      ;; The chooser passed on shrinking.  Make sure it didn't emit
-	      ;; anything.
-	      (unless (= (segment-current-index segment) (chooser-index note))
-		(error "Chooser ~S passed, but not before emitting ~D bytes."
-		       note
-		       (- (segment-current-index segment)
-			  (chooser-index note))))
-	      ;; Act like we just emitted this chooser.
-	      (let ((size (chooser-size note)))
-		(incf (segment-current-index segment) size)
-		(incf (segment-current-posn segment) size))
-	      ;; Adjust the alignment accordingly.
-	      (adjust-alignment-after-chooser segment note)
-	      ;; And keep this chooser for next time around.
-	      (setf prev remaining))))
-	   ((alignment-p note)
-	    (unless (zerop (alignment-size note))
-	      ;; Re-emit the alignment, letting it collapse if we know anything
-	      ;; more about the alignment guarentees of the segment.
-	      (let ((index (alignment-index note)))
-		(setf (segment-current-index segment) index)
-		(setf (segment-current-posn segment) posn)
-		(setf (segment-fill-pointer segment) (system:int-sap 0))
-		(setf (segment-block-end segment) (system:int-sap 0))
-		(setf (segment-last-annotation segment) prev)
-		(emit-alignment segment nil (alignment-bits note))
-		(let* ((new-index (segment-current-index segment))
-		       (size (- new-index index))
-		       (old-size (alignment-size note))
-		       (additional-delta (- old-size size)))
-		  (when (minusp additional-delta)
-		    (error "Alignment ~S needs more space now?  It was ~D, ~
-			    and is ~D now."
-			   note old-size size))
-		  (when (plusp additional-delta)
-		    (emit-filler segment additional-delta)
-		    (incf delta additional-delta)))
-		(setf prev (segment-last-annotation segment))
-		(if prev
-		    (setf (cdr prev) (cdr remaining))
-		    (setf (segment-annotations segment)
-			  (cdr remaining))))))
-	   (t
-	    (setf prev remaining)))))
-      (when (zerop delta)
-	(return))
-      (decf (segment-final-posn segment) delta)))
-  (ext:undefined-value))
-
-;;; FINALIZE-POSITIONS -- internal.
-;;;
-;;; We have run all the choosers we can, so now we have to figure out exactly
-;;; how much space each alignment note needs.
-;;; 
-(defun finalize-positions (segment)
-  (let ((delta 0))
-    (do* ((prev nil)
-	  (remaining (segment-annotations segment) next)
-	  (next (cdr remaining) (cdr remaining)))
-	 ((null remaining))
-      (let* ((note (car remaining))
-	     (posn (- (annotation-posn note) delta)))
-	(cond
-	 ((alignment-p note)
-	  (let* ((bits (alignment-bits note))
-		 (mask (1- (ash 1 bits)))
-		 (new-posn (logand (+ posn mask) (lognot mask)))
-		 (size (- new-posn posn))
-		 (old-size (alignment-size note))
-		 (additional-delta (- old-size size)))
-	    (assert (<= 0 size old-size))
-	    (unless (zerop additional-delta)
-	      (setf (segment-last-annotation segment) prev)
-	      (incf delta additional-delta)
-	      (setf (segment-current-index segment) (alignment-index note))
-	      (setf (segment-current-posn segment) posn)
-	      (emit-filler segment additional-delta)
-	      (setf prev (segment-last-annotation segment)))
-	    (if prev
-		(setf (cdr prev) next)
-		(setf (segment-annotations segment) next))))
-	 (t
-	  (setf (annotation-posn note) posn)
-	  (setf prev remaining)
-	  (setf next (cdr remaining))))))
-    (unless (zerop delta)
-      (decf (segment-final-posn segment) delta)))
-  (ext:undefined-value))
-
-;;; PROCESS-BACK-PATCHES -- internal.
-;;;
-;;; Grovel over segment, filling in any backpatches.  If any choosers are left
-;;; over, we need to emit their worst case varient.
-;;;
-(defun process-back-patches (segment)
-  (do* ((prev nil)
-	(remaining (segment-annotations segment) next)
-	(next (cdr remaining) (cdr remaining)))
-      ((null remaining))
-    (let ((note (car remaining)))
-      (flet ((fill-in (function old-size)
-	       (let ((index (annotation-index note))
-		     (posn (annotation-posn note)))
-		 (setf (segment-current-index segment) index)
-		 (setf (segment-current-posn segment) posn)
-		 (setf (segment-fill-pointer segment) (system:int-sap 0))
-		 (setf (segment-block-end segment) (system:int-sap 0))
-		 (setf (segment-last-annotation segment) prev)
-		 (funcall function segment posn)
-		 (let ((new-size (- (segment-current-index segment) index)))
-		   (unless (= new-size old-size)
-		     (error "~S emitted ~D bytes, but claimed it's was ~D"
-			    note new-size old-size)))
-		 (let ((tail (segment-last-annotation segment)))
-		   (if tail
-		       (setf (cdr tail) next)
-		       (setf (segment-annotations segment) next)))
-		 (setf next (cdr prev)))))
-	(cond ((back-patch-p note)
-	       (fill-in (back-patch-function note)
-			(back-patch-size note)))
-	      ((chooser-p note)
-	       (fill-in (chooser-worst-case-fun note)
-			(chooser-size note)))
-	      (t
-	       (setf prev remaining)))))))
-
-
-;;;; Interface to the rest of the compiler.
-
-;;; *CURRENT-SEGMENT* -- internal.
-;;;
-;;; The holds the current segment while assembling.  Use ASSEMBLE to change
-;;; it.
-;;; 
-(defvar *current-segment*)
-
-;;; *CURRENT-VOP* -- internal.
-;;;
-;;; Just like *CURRENT-SEGMENT*, but holds the current vop.  Used only to keep
-;;; track of which vops emit which insts.
-;;; 
-(defvar *current-vop* nil)
-
-;;; ASSEMBLE -- interface.
-;;;
-;;; We also symbol-macrolet *current-segment* to a local holding the segment
-;;; so uses of *current-segment* inside the body don't have to keep
-;;; dereferencing the symbol.  Given that ASSEMBLE is the only interface to
-;;; *current-segment*, we don't have to worry about the special value becomming
-;;; out of sync with the lexical value.  Unless some bozo closes over it,
-;;; but nobody does anything like that...
-;;;
-(defmacro assemble ((&optional segment vop &key labels) &body body
-		    &environment env)
-  "Execute BODY (as a progn) with SEGMENT as the current segment."
-  (flet ((label-name-p (thing)
-	   (and thing (symbolp thing))))
-    (let* ((seg-var (gensym "SEGMENT-"))
-	   (vop-var (gensym "VOP-"))
-	   (visable-labels (remove-if-not #'label-name-p body))
-	   (inherited-labels
-	    (multiple-value-bind
-		(expansion expanded)
-		(macroexpand '..inherited-labels.. env)
-	      (if expanded expansion nil)))
-	   (new-labels (append labels
-			       (set-difference visable-labels
-					       inherited-labels)))
-	   (nested-labels (set-difference (append inherited-labels new-labels)
-					  visable-labels)))
-      (when (intersection labels inherited-labels)
-	(error "Duplicate nested labels: ~S"
-	       (intersection labels inherited-labels)))
-      `(let* ((,seg-var ,(or segment '*current-segment*))
-	      (,vop-var ,(or vop '*current-vop*))
-	      ,@(when segment
-		  `((*current-segment* ,seg-var)))
-	      ,@(when vop
-		  `((*current-vop* ,vop-var)))
-	      ,@(mapcar #'(lambda (name)
-			    `(,name (gen-label)))
-			new-labels))
-	 (symbol-macrolet ((*current-segment* ,seg-var)
-			   (*current-vop* ,vop-var)
-			   ,@(when (or inherited-labels nested-labels)
-			       `((..inherited-labels.. ,nested-labels))))
-	   ,@(mapcar #'(lambda (form)
-			 (if (label-name-p form)
-			     `(emit-label ,form)
-			     form))
-		     body))))))
-
-;;; INST -- interface.
-;;; 
-(defmacro inst (&whole whole instruction &rest args &environment env)
-  "Emit the specified instruction to the current segment."
-  (let ((inst (gethash (symbol-name instruction)
-		       (assem-params-instructions
-			(c:backend-assembler-params c:*target-backend*)))))
-    (cond ((null inst)
-	   (error "Unknown instruction: ~S" instruction))
-	  ((functionp inst)
-	   (funcall inst (cdr whole) env))
-	  (t
-	   `(,inst *current-segment* *current-vop* ,@args)))))
-
-;;; EMIT-LABEL -- interface.
-;;; 
-(defmacro emit-label (label)
-  "Emit LABEL at this location in the current segment."
-  `(%emit-label *current-segment* *current-vop* ,label))
-
-;;; EMIT-POSTIT -- interface.
-;;;
-(defmacro emit-postit (function)
-  `(%emit-postit *current-segment* ,function))
-
-;;; ALIGN -- interface.
-;;; 
-(defmacro align (bits)
-  "Emit an alignment restriction to the current segment."
-  `(emit-alignment *current-segment* *current-vop* ,bits))
-
-;;; LABEL-POSITION -- interface.
-;;; 
-(defun label-position (label &optional if-after delta)
-  "Return the current position for LABEL.  Chooser maybe-shrink functions
-   should supply IF-AFTER and DELTA to assure correct results."
-  (let ((posn (label-posn label)))
-    (if (and if-after (> posn if-after))
-	(- posn delta)
-	posn)))
-
-;;; APPEND-SEGMENT -- interface.
-;;; 
-(defun append-segment (segment other-segment)
-  "Append OTHER-SEGMENT to the end of SEGMENT.  Don't use OTHER-SEGMENT
-   for anything after this."
-  (when (segment-run-scheduler segment)
-    (schedule-pending-instructions segment))
-  (let ((postits (segment-postits segment)))
-    (setf (segment-postits segment) (segment-postits other-segment))
-    (dolist (postit postits)
-      (emit-back-patch segment 0 postit)))
-  (emit-alignment segment nil max-alignment)
-  (let ((offset-in-last-block (rem (segment-current-index segment)
-				   output-block-size)))
-    (unless (zerop offset-in-last-block)
-      (emit-filler segment (- output-block-size offset-in-last-block))))
-  (let* ((blocks (segment-output-blocks segment))
-	 (next-block-num (floor (segment-current-index segment)
-				output-block-size))
-	 (other-blocks (segment-output-blocks other-segment)))
-    (setf blocks
-	  (adjust-array blocks (+ next-block-num (length other-blocks))))
-    (setf (segment-output-blocks segment) blocks)
-    (replace blocks other-blocks :start1 next-block-num))
-  (let ((index-delta (segment-current-index segment))
-	(posn-delta (segment-current-posn segment))
-	(other-annotations (segment-annotations other-segment)))
-    (setf (segment-current-index segment)
-	  (+ index-delta (segment-current-index other-segment)))
-    (setf (segment-current-posn segment)
-	  (+ posn-delta (segment-current-posn other-segment)))
-    (setf (segment-fill-pointer segment) (system:int-sap 0))
-    (setf (segment-block-end segment) (system:int-sap 0))
-    (when other-annotations
-      (dolist (note other-annotations)
-	(incf (annotation-index note) index-delta)
-	(incf (annotation-posn note) posn-delta))
-      (let ((last (segment-last-annotation segment)))
-	(if last
-	    (setf (cdr last) other-annotations)
-	    (setf (segment-annotations segment) other-annotations))
-	(setf (segment-last-annotation segment)
-	      (segment-last-annotation other-segment)))))
-  (ext:undefined-value))
-
-;;; FINALIZE-SEGMENT -- interface.
-;;; 
-(defun finalize-segment (segment)
-  "Does any final processing of SEGMENT and returns the total number of bytes
-   covered by this segment."
-  (when (segment-run-scheduler segment)
-    (schedule-pending-instructions segment))
-  (setf (segment-run-scheduler segment) nil)
-  (let ((postits (segment-postits segment)))
-    (setf (segment-postits segment) nil)
-    (dolist (postit postits)
-      (emit-back-patch segment 0 postit)))
-  (setf (segment-final-index segment) (segment-current-index segment))
-  (setf (segment-final-posn segment) (segment-current-posn segment))
-  (setf (segment-inst-hook segment) nil)
-  (compress-output segment)
-  (finalize-positions segment)
-  (process-back-patches segment)
-  (segment-final-posn segment))
-
-;;; SEGMENT-MAP-OUTPUT -- interface.
-;;;
-(defun segment-map-output (segment function)
-  "Call FUNCTION on all the output accumulated in SEGMENT.  FUNCTION is called
-   zero or more times with two arguments: a SAP and a number of bytes."
-  (let ((old-index 0)
-	(blocks (segment-output-blocks segment))
-	(sap (system:int-sap 0))
-	(end (system:int-sap 0)))
-    (labels ((map-until (index)
-	       (unless (system:sap< sap end)
-		 (multiple-value-bind
-		     (block-num block-offset)
-		     (floor old-index output-block-size)
-		   (let ((block (aref blocks block-num)))
-		     (setf sap (system:sap+ block block-offset))
-		     (setf end (system:sap+ block output-block-size)))))
-	       (let* ((desired (- index old-index))
-		      (available (system:sap- end sap))
-		      (amount (min desired available)))
-		 (funcall function sap amount)
-		 (incf old-index amount)
-		 (setf sap (system:sap+ sap amount))
-		 (when (< amount desired)
-		   (map-until index)))))
-      (dolist (note (segment-annotations segment))
-	(when (filler-p note)
-	  (let ((index (filler-index note)))
-	    (when (< old-index index)
-	      (map-until index)))
-	  (let ((bytes (filler-bytes note)))
-	    (incf old-index bytes)
-	    (setf sap (system:sap+ sap bytes)))))
-      (let ((index (segment-final-index segment)))
-	(when (< old-index index)
-	  (map-until index))))))
-
-;;; RELEASE-SEGMENT -- interface.
-;;; 
-(defun release-segment (segment)
-  "Releases any output buffers held on to by segment."
-  (let ((blocks (segment-output-blocks segment)))
-    (loop
-      for block across blocks
-      do (when block
-	   (release-output-block block))))
-  (ext:undefined-value))
-
-
-;;;; Interface to the instruction set definition.
-
-;;; DEFINE-EMITTER -- Interface.
-;;;
-;;; Define a function named NAME that merges it's arguments into a single
-;;; integer and then emits the bytes of that integer in the correct order
-;;; based on the endianness of the target-backend.
-;;;
-(defmacro define-emitter (name total-bits &rest byte-specs)
-  (ext:collect ((arg-names) (arg-types))
-    (let* ((total-bits (eval total-bits))
-	   (overall-mask (ash -1 total-bits))
-	   (num-bytes (multiple-value-bind
-			  (quo rem)
-			  (truncate total-bits assembly-unit-bits)
-			(unless (zerop rem)
-			  (error "~D isn't an even multiple of ~D"
-				 total-bits assembly-unit-bits))
-			quo))
-	   (bytes (make-array num-bytes :initial-element nil))
-	   (segment-arg (gensym "SEGMENT-")))
-      (dolist (byte-spec-expr byte-specs)
-	(let* ((byte-spec (eval byte-spec-expr))
-	       (byte-size (byte-size byte-spec))
-	       (byte-posn (byte-position byte-spec))
-	       (arg (gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr))))
-	  (when (ldb-test (byte byte-size byte-posn) overall-mask)
-	    (error "Byte spec ~S either overlaps another byte spec, or ~
-		    extends past the end."
-		   byte-spec-expr))
-	  (setf (ldb byte-spec overall-mask) -1)
-	  (arg-names arg)
-	  (arg-types `(type (integer ,(ash -1 (1- byte-size))
-				     ,(1- (ash 1 byte-size)))
-			    ,arg))
-	  (multiple-value-bind
-	      (start-byte offset)
-	      (floor byte-posn assembly-unit-bits)
-	    (let ((end-byte (floor (1- (+ byte-posn byte-size))
-				   assembly-unit-bits)))
-	      (flet ((maybe-ash (expr offset)
-		       (if (zerop offset)
-			   expr
-			   `(ash ,expr ,offset))))
-		(declare (inline maybe-ash))
-		(cond ((zerop byte-size))
-		      ((= start-byte end-byte)
-		       (push (maybe-ash `(ldb (byte ,byte-size 0) ,arg)
-					offset)
-			     (svref bytes start-byte)))
-		      (t
-		       (push (maybe-ash
-			      `(ldb (byte ,(- assembly-unit-bits offset) 0)
-				    ,arg)
-			      offset)
-			     (svref bytes start-byte))
-		       (do ((index (1+ start-byte) (1+ index)))
-			   ((>= index end-byte))
-			 (push
-			  `(ldb (byte ,assembly-unit-bits
-				      ,(- (* assembly-unit-bits
-					     (- index start-byte))
-					  offset))
-				,arg)
-			  (svref bytes index)))
-		       (let ((len (rem (+ byte-size offset)
-				       assembly-unit-bits)))
-			 (push
-			  `(ldb (byte ,(if (zerop len)
-					   assembly-unit-bits
-					   len)
-				      ,(- (* assembly-unit-bits
-					     (- end-byte start-byte))
-					  offset))
-				,arg)
-			  (svref bytes end-byte))))))))))
-      (unless (= overall-mask -1)
-	(error "There are holes."))
-      (let ((forms nil))
-	(dotimes (i num-bytes)
-	  (let ((pieces (svref bytes i)))
-	    (assert pieces)
-	    (push `(emit-byte ,segment-arg
-			      ,(if (cdr pieces)
-				   `(logior ,@pieces)
-				   (car pieces)))
-		  forms)))
-	`(defun ,name (,segment-arg ,@(arg-names))
-	   (declare (type segment ,segment-arg) ,@(arg-types))
-	   ,@(ecase (c:backend-byte-order c:*target-backend*)
-	       (:little-endian (nreverse forms))
-	       (:big-endian forms))
-	   ',name)))))
-
-(defun grovel-lambda-list (lambda-list vop-var)
-  (let ((segment-name (car lambda-list))
-	(vop-var (or vop-var (gensym "VOP-"))))
-    (ext:collect ((new-lambda-list))
-      (new-lambda-list segment-name)
-      (new-lambda-list vop-var)
-      (labels
-	  ((grovel (state lambda-list)
-	     (when lambda-list
-	       (let ((param (car lambda-list)))
-		 (cond
-		  ((member param lambda-list-keywords)
-		   (new-lambda-list param)
-		   (grovel param (cdr lambda-list)))
-		  (t
-		   (ecase state
-		     ((nil)
-		      (new-lambda-list param)
-		      `(cons ,param ,(grovel state (cdr lambda-list))))
-		     (&optional
-		      (multiple-value-bind
-			  (name default supplied-p)
-			  (if (consp param)
-			      (values (first param)
-				      (second param)
-				      (or (third param)
-					  (gensym "SUPPLIED-P-")))
-			      (values param nil (gensym "SUPPLIED-P-")))
-			(new-lambda-list (list name default supplied-p))
-			`(and ,supplied-p
-			      (cons ,(if (consp name)
-					 (second name)
-					 name)
-				    ,(grovel state (cdr lambda-list))))))
-		     (&key
-		      (multiple-value-bind
-			  (name default supplied-p)
-			  (if (consp param)
-			      (values (first param)
-				      (second param)
-				      (or (third param)
-					  (gensym "SUPPLIED-P-")))
-			      (values param nil (gensym "SUPPLIED-P-")))
-			(new-lambda-list (list name default supplied-p))
-			(multiple-value-bind
-			    (key var)
-			    (if (consp name)
-				(values (first name) (second name))
-				(values (intern (symbol-name name) :keyword)
-					name))
-			  `(append (and ,supplied-p (list ',key ,var))
-				   ,(grovel state (cdr lambda-list))))))
-		     (&rest
-		      (new-lambda-list param)
-		      (grovel state (cdr lambda-list))
-		      param))))))))
-	(let ((reconstructor (grovel nil (cdr lambda-list))))
-	  (values (new-lambda-list)
-		  segment-name
-		  vop-var
-		  reconstructor))))))
-
-(defun extract-nths (index glue list-of-lists-of-lists)
-  (mapcar #'(lambda (list-of-lists)
-	      (cons glue
-		    (mapcar #'(lambda (list)
-				(nth index list))
-			    list-of-lists)))
-	  list-of-lists-of-lists))
-
-;;; DEFINE-INSTRUCTION -- interface.
-;;; 
-(defmacro define-instruction (name lambda-list &rest options)
-  (let* ((sym-name (symbol-name name))
-	 (defun-name (ext:symbolicate sym-name "-INST-EMITTER"))
-	 (vop-var nil)
-	 (postits (gensym "POSTITS-"))
-	 (emitter nil)
-	 (decls nil)
-	 (attributes nil)
-	 (dependencies nil)
-	 (delay nil)
-	 (pinned nil)
-	 (pdefs nil))
-    (dolist (option-spec options)
-      (multiple-value-bind
-	  (option args)
-	  (if (consp option-spec)
-	      (values (car option-spec) (cdr option-spec))
-	      (values option-spec nil))
-	(case option
-	  (:emitter
-	   (when emitter
-	     (error "Can only specify one emitter per instruction."))
-	   (setf emitter args))
-	  (:declare
-	   (setf decls (append decls args)))
-	  (:attributes
-	   (setf attributes (append attributes args)))
-	  (:dependencies
-	   (setf dependencies (append dependencies args)))
-	  (:delay
-	   (when delay
-	     (error "Can only specify delay once per instruction."))
-	   (setf delay args))
-	  ((:reads :writes)
-	   ;; ### Ignore them for now.
-	   nil)
-	  (:pinned
-	   (setf pinned t))
-	  (:vop-var
-	   (if vop-var
-	       (error "Can only specify :vop-var once.")
-	       (setf vop-var (car args))))
-	  (:printer
-	   (push
-	    (eval
-	     `(list
-	       (multiple-value-list
-		,(disassem:gen-printer-def-forms-def-form name
-							  (cdr option-spec)))))
-	    pdefs))
-	  (:printer-list
-	   ;; same as :printer, but is evaled first, and is a list of printers
-	   (push
-	    (eval
-	     `(eval
-	       `(list ,@(mapcar #'(lambda (printer)
-				    `(multiple-value-list
-				      ,(disassem:gen-printer-def-forms-def-form
-					',name printer nil)))
-				,(cadr option-spec)))))
-	    pdefs))
-	  (t
-	   (error "Unknown option: ~S" option)))))
-    (setf pdefs (nreverse pdefs))
-    (multiple-value-bind
-	(new-lambda-list segment-name vop-name arg-reconstructor)
-	(grovel-lambda-list lambda-list vop-var)
-      (push `(let ((hook (segment-inst-hook ,segment-name)))
-	       (when hook
-		 (funcall hook ,segment-name ,vop-name ,sym-name
-			  ,arg-reconstructor)))
-	    emitter)
-      (push `(dolist (postit ,postits)
-	       (emit-back-patch ,segment-name 0 postit))
-	    emitter)
-      (when (assem-params-scheduler-p
-	     (c:backend-assembler-params c:*target-backend*))
-	(if pinned
-	    (setf emitter
-		  `((when (segment-run-scheduler ,segment-name)
-		      (schedule-pending-instructions ,segment-name))
-		    ,@emitter))
-	    (let ((flet-name
-		   (gensym (concatenate 'string "EMIT-" sym-name "-INST-")))
-		  (inst-name (gensym "INST-")))
-	      (setf emitter `((flet ((,flet-name (,segment-name)
-				       ,@emitter))
-				(if (segment-run-scheduler ,segment-name)
-				    (let ((,inst-name
-					   (make-instruction
-					    (incf (segment-inst-number
-						   ,segment-name))
-					    #',flet-name
-					    (instruction-attributes
-					     ,@attributes)
-					    (progn ,@delay))))
-				      ,@(when dependencies
-					  `((note-dependencies
-						(,segment-name ,inst-name)
-					      ,@dependencies)))
-				      (queue-inst ,segment-name ,inst-name))
-				    (,flet-name ,segment-name))))))))
-      `(progn
-	 (defun ,defun-name ,new-lambda-list
-	   ,@(when decls
-	       `((declare ,@decls)))
-	   (let ((,postits (segment-postits ,segment-name)))
-	     (setf (segment-postits ,segment-name) nil)
-	     (symbol-macrolet
-		 ((*current-segment*
-		   (macrolet ((lose ()
-				(error "Can't use INST without an ASSEMBLE ~
-					inside emitters.")))
-		     (lose))))
-	       ,@emitter))
-	   (ext:undefined-value))
-	 (eval-when (compile load eval)
-	   (%define-instruction ,sym-name ',defun-name))
-	 ,@(extract-nths 1 'progn pdefs)
-	 ,@(when pdefs
-	     `((disassem:install-inst-flavors
-		',name
-		(append ,@(extract-nths 0 'list pdefs)))))))))
-
-;;; DEFINE-INSTRUCTION-MACRO -- interface.
-;;;
-(defmacro define-instruction-macro (name lambda-list &body body)
-  (let ((whole (gensym "WHOLE-"))
-	(env (gensym "ENV-")))
-    (multiple-value-bind
-	(body local-defs)
-	(lisp::parse-defmacro lambda-list whole body name 'instruction-macro
-			      :environment env)
-      `(eval-when (compile load eval)
-	 (%define-instruction ,(symbol-name name)
-			      #'(lambda (,whole ,env)
-				  ,@local-defs
-				  (block ,name
-				    ,body)))))))
-
-(defun %define-instruction (name defun)
-  (setf (gethash name
-		 (assem-params-instructions
-		  (c:backend-assembler-params c:*target-backend*)))
-	defun)
-  name)
-
diff --git a/compiler/old-rt/arith.lisp b/compiler/old-rt/arith.lisp
deleted file mode 100644
index 5a8ab236297e3318d31f4f7dd781d3964b784a08..0000000000000000000000000000000000000000
--- a/compiler/old-rt/arith.lisp
+++ /dev/null
@@ -1,196 +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)
-	  (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))
-	 (y :target r
-	    :scs (any-reg short-immediate unsigned-immediate immediate)))
-  (:results (r :scs (any-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)))
-  (:results (res :scs (any-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))
-	 (y :target r
-	    :scs (any-reg short-immediate unsigned-immediate))))
-
-(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)
-  (:args (i :scs (any-reg)
-	    :target r))
-  (:arg-types fixnum (:constant (integer -31 31)))
-  (:info n)
-  (:translate ash)
-  (:generator 1
-    (unless (location= i r)
-      (inst lr r i))
-
-    (cond ((plusp n)
-	   (if (> n 15)
-	       (inst sli16 r (- n 16))
-	       (inst sli r n)))
-	  ((minusp n)
-	   (let ((n (- n)))
-	     (if (> n 15)
-		 (inst sari16 r (- n 16))
-		 (inst sari r n)))))))
-
-
-(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))
-	 (y :scs (any-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
-       (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/array.lisp b/compiler/old-rt/array.lisp
deleted file mode 100644
index 9cf7282104a7fcb0ec815f4da78e936cb584ed95..0000000000000000000000000000000000000000
--- a/compiler/old-rt/array.lisp
+++ /dev/null
@@ -1,106 +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)
-  (: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)))
-  (: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)))
-  (: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/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/assem-macs.lisp b/compiler/old-rt/assem-macs.lisp
deleted file mode 100644
index f1f728fc5735e6c1390bf3ac9df264c3659cabf0..0000000000000000000000000000000000000000
--- a/compiler/old-rt/assem-macs.lisp
+++ /dev/null
@@ -1,296 +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). 
-;;; **********************************************************************
-;;;
-;;;    Some macros and stuff to make emitting RT assembler easier.
-;;;
-(in-package 'c)
-
-#-new-compiler
-(setq lisp::*bootstrap-defmacro* :both)
-
-(defmacro no-op ()
-  "A 2 byte no-op."
-  '(inst lr zero-tn zero-tn))
-
-
-;;; Loadi loads the specified Constant into the given Register.
-
-(defmacro loadi (register constant)
-  (once-only ((n-constant constant))
-    `(cond ((<= 0 ,n-constant 15)
-	    (inst lis ,register ,n-constant))
-	   ((<= -32768 ,n-constant 32767)
-	    (inst cal ,register zero-tn ,n-constant))
-	   ((= (logand ,n-constant 65535) 0)
-	    (inst cau ,register zero-tn (logand (ash ,n-constant -16) #xFFFF)))
-	   (t
-	    (inst cau ,register zero-tn (logand (ash ,n-constant -16) #xFFFF))
-	    (inst oil ,register ,register (logand ,n-constant 65535))))))
-
-
-(defmacro cmpi (register constant)
-  (once-only ((n-constant constant))
-    `(cond ((<= 0 ,n-constant 15)
-	    (inst cis ,register ,n-constant))
-	   ((<= -32768 ,n-constant 32767)
-	    (inst ci ,register ,n-constant))
-	   (T
-	    (error "~A is to big for a compare immediate instruction."
-		   ,n-constant)))))
-
-
-;;; Memory reference macros that take a scaled immediate offset and use a short
-;;; form instruction when possible.
-;;;
-(defmacro defmemref (name ds d shift)
-  `(defmacro ,name (register index-register &optional (offset 0))
-     (once-only ((n-offset offset))
-       `(if (<= 0 ,n-offset ,,15)
-	    (inst ,',ds ,n-offset ,register ,index-register)
-	    (inst ,',d ,register ,index-register (ash ,n-offset ,,shift))))))
-
-
-(defmacro loadh (register index-register &optional (offset 0))
-  (once-only ((n-offset offset))
-    `(if (zerop ,n-offset)
-	 (inst lhs ,register ,index-register)
-	 (inst lh ,register ,index-register (ash ,n-offset 1)))))
-
-
-(defmemref loadc lcs lc 0)		; loads a character or byte
-(defmemref loadha lhas lha 1)		; loads a halfword, sign-extending
-(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
-
-
-;;; Load-Global, Store-Global  --  Public
-;;;
-;;;    Load or store a word in the assember global data area.  Base is a
-;;; temporary register used to compute the base of the assembler data area, and
-;;; must not be NL0 (i.e. should be Descriptor-Reg.)  In Load-Global, if base
-;;; it omitted, we default it to the result Register.  Offset is a byte offset,
-;;; but must be word-aligned.
-;;;
-(defmacro load-global (register offset &optional (base register))
-  `(progn
-     (inst cau ,base zero-tn clc::romp-data-base)
-     (loadw ,register ,base (/ ,offset 4))))
-;;;
-(defmacro store-global (register offset base)
-  `(progn
-     (inst cau ,base zero-tn clc::romp-data-base)
-     (storew ,register ,base (/ ,offset 4))))
-
-
-;;; Load-Slot, Store-Slot  --  Public
-;;;
-;;;    Load or store a slot in a g-vector-like object.  We just add in the
-;;; g-vector header size and do the load/store.
-;;;
-(defmacro load-slot (register object index)
-  `(loadw ,register ,object
-	  (+ ,index clc::g-vector-header-size-in-words)))
-;;;
-(defmacro store-slot (register object index)
-  `(storew ,register ,object
-	   (+ ,index clc::g-vector-header-size-in-words)))
-
-
-;;; 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 string-char-reg)
-	(sc-case ,n-stack
-	  ((stack string-char-stack)
-	   (loadw ,n-reg fp-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 string-char-reg)
-	(sc-case ,n-stack
-	  ((stack string-char-stack)
-	   (storew ,n-reg fp-tn (tn-offset ,n-stack))))))))
-
-
-;;; MAYBE-LOAD-STACK-TN  --  Interface
-;;;
-(defmacro maybe-load-stack-tn (reg reg-or-stack)
-  "Move the TN Reg-Or-Stack into Reg if it isn't already there."
-  (once-only ((n-reg reg)
-	      (n-stack reg-or-stack))
-    `(sc-case ,n-reg
-       ((any-reg descriptor-reg string-char-reg)
-	(sc-case ,n-stack
-	  ((any-reg descriptor-reg string-char-reg)
-	   (unless (location= ,n-reg ,n-stack)
-	     (inst lr ,n-reg ,n-stack)))
-	  ((stack string-char-stack)
-	   (loadw ,n-reg fp-tn (tn-offset ,n-stack))))))))
-
-
-(defmacro test-simple-type (register temp target not-p type-code)
-  "Emit conditional code that tests whether Register holds an object with the
-  specified Type-Code.  Temp is an unboxed temporary."
-  (once-only ((n-register register)
-	      (n-temp temp)
-	      (n-target target)
-	      (n-not-p not-p)
-	      (n-type-code type-code))
-    `(progn
-       (inst niuz ,n-temp ,n-register clc::type-mask-16)
-       (inst xiu ,n-temp ,n-temp (ash ,n-type-code clc::type-shift-16))
-       (if ,n-not-p
-	   (inst bnb :eq ,n-target)
-	   (inst bb :eq ,n-target)))))
-
-
-
-(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.  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 may be any register."
-  (once-only ((n-register register)
-	      (n-temp temp)
-	      (n-target target)
-	      (n-not-p not-p))
-    (assert types)
-    (let ((codes
-	   (sort (mapcar #'(lambda (x)
-			     (if (listp x)
-				 (cons (eval (first x)) (eval (second x)))
-				 (eval x)))
-			 types)
-		 #'<
-		 :key #'(lambda (x)
-			  (if (consp x) (car x) x))))
-	  (n-drop-thru (gensym)) (n-in-lab (gensym)) (n-out-lab (gensym)))
-
-      (collect ((tests))
-	(do ((codes codes (cdr codes)))
-	    ((null codes))
-	  (let ((code (car codes))
-		(last (null (cdr codes))))
-	    (cond
-	     ((consp code)
-	      (tests
-	       `(progn
-		  (cmpi ,n-temp ,(car code))
-		  (inst bb :lt ,n-out-lab)
-		  (cmpi ,n-temp ,(cdr code))))
-
-	      (if last
-		  (tests `(if ,n-not-p
-			      (inst bb :gt ,n-target)
-			      (inst bnb :gt ,n-target)))
-		  (tests `(inst bnb :gt ,n-in-lab))))
-	     (t
-	      (tests `(cmpi ,n-temp ,code))
-	      (if last
-		  (tests `(if ,n-not-p
-			      (inst bnb :eq ,n-target)
-			      (inst bb :eq ,n-target)))
-		  (tests `(inst bb :eq ,n-in-lab)))))))
-		
-		
-	`(let* ((,n-drop-thru (gen-label))
-		(,n-in-lab (if ,n-not-p ,n-drop-thru ,n-target))
-		(,n-out-lab (if ,n-not-p ,n-target ,n-drop-thru)))
-	   ,n-out-lab
-	   (unless (location= ,n-temp ,n-register)
-	     (inst lr ,n-temp ,n-register))
-	   (inst sri16 ,n-temp clc::type-shift-16)
-	   
-	   ,@(tests)
-	   
-	   (emit-label ,n-drop-thru))))))
-
-
-(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)))))
-
-
-(defmacro pushm (reg)
-  `(progn
-     (inst inc sp-tn 4)
-     (storew ,reg sp-tn 0)))
-
-(defmacro popm (reg)
-  `(progn
-     (loadw ,reg sp-tn 0)
-     (inst dec sp-tn 4)))
-
-
-;;; ### Note sleazy use of the argument registers without allocating them.
-;;; This allows expressions to be targeted to the argument registers when error
-;;; checking is going on, but causes problems with parallel assignment
-;;; semantics.  For error2, we have to start using the stack as a temporary.
-;;;
-(defmacro error-call (error-code &rest values)
-  (once-only ((n-error-code error-code))
-    `(progn
-       ,@(case (length values)
-	   (0
-	    '((inst miscopx 'clc::error0)))
-	   (1
-	    `((inst lr (second register-argument-tns) ,(first values))
-	      (inst miscopx 'clc::error1)))
-	   (2
-	    `((pushm ,(second values))
-	      (inst lr (second register-argument-tns) ,(first values))
-	      (popm (third register-argument-tns))
-	      (inst miscopx 'clc::error2)))
-	   (t
-	    (error "Can't use Error-Call with ~D values." (length values))))
-       ;; Always do a 32bit load so that we can NOTE-THIS-LOCATION.
-       (inst cal (first register-argument-tns) zero-tn ,n-error-code))))
-
-
-(defmacro generate-error-code (vop error-code &rest values)
-  "Generate-Error-Code VOP Error-code Value*
-  Emit code for an error with the specified Error-Code and context Values.
-  VOP is used for source context and lifetime information."
-  (once-only ((n-vop vop))
-    `(unassemble
-       (assemble-elsewhere (vop-node ,n-vop)
-	 (let ((start-lab (gen-label)))
-	   (emit-label start-lab)
-	   (error-call ,error-code ,@values)
-	   (note-this-location ,n-vop :internal-error)
-	   start-lab)))))
\ No newline at end of file
diff --git a/compiler/old-rt/call.lisp b/compiler/old-rt/call.lisp
deleted file mode 100644
index 5a696d5d242a18c378b9de884bddca8ae91e09e5..0000000000000000000000000000000000000000
--- a/compiler/old-rt/call.lisp
+++ /dev/null
@@ -1,985 +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* register-arg-scn)))
-
-
-;;; Make-Old-Fp-Passing-Location  --  Interface
-;;;
-;;;    Similar to Make-Return-PC-Passing-Location, but makes a location to pass
-;;; Old-Fp 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-fp-passing-location (standard)
-  (if standard
-      (make-wired-tn *any-primitive-type* register-arg-scn old-fp-offset)
-      (make-normal-tn *any-primitive-type*)))
-
-
-;;; Make-Old-Fp-Save-Location, Make-Return-PC-Save-Location  --  Interface
-;;;
-;;;    Make the TNs used to hold Old-Fp 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-fp-save-location (env)
-  (specify-save-tn
-   (environment-debug-live-tn (make-normal-tn *any-primitive-type*)
-			      env)
-   (make-wired-tn *any-primitive-type* stack-arg-scn old-fp-save-offset)))
-;;;
-(defun make-return-pc-save-location (env)
-  (specify-save-tn
-   (environment-debug-live-tn (make-normal-tn *any-primitive-type*)
-			      env)
-   (make-wired-tn *any-primitive-type* stack-arg-scn return-pc-save-offset)))
-
-
-;;; 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))
-
-
-;;; MAKE-NFP-TN  --  Interface
-;;;
-;;;    Make a TN to hold the number-stack frame pointer.  This is allocated
-;;; once per component, and is component-live.
-;;;
-(defun make-nfp-tn ()
-  (component-live-tn
-   (make-restricted-tn *any-primitive-type* register-arg-scn)))
-
-
-;;; MAKE-STACK-POINTER-TN ()
-;;; 
-(defun make-stack-pointer-tn ()
-  (make-normal-tn *any-primitive-type*))
-
-
-;;; MAKE-NUMBER-STACK-POINTER-TN ()
-;;; 
-(defun make-number-stack-pointer-tn ()
-  (make-normal-tn *any-primitive-type*))
-
-
-;;; 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 ()
-  (list (make-stack-pointer-tn)
-	(make-normal-tn *any-primitive-type*)))
-
-
-;;; 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))
-
-
-;;;; Frame hackery:
-
-;;; Used for setting up the Old-Fp in local call.
-;;;
-(define-vop (current-fp)
-  (:results (val :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (inst lr val fp-tn)))
-
-
-#| Since we don't have a number stack yet, shouldn't be emitted.
-
-;;; Used for computing the caller's NFP for use in known-values return.  Only
-;;; works assuming there is no variable size stuff on the nstack.
-;;;
-(define-vop (compute-old-nfp)
-  (:results (val :scs (any-reg descriptor-reg)))
-  (:vop-var vop)
-  (:generator 1
-    (let ((nfp (current-nfp-tn vop)))
-      (when nfp
-	(inst cal val nfp (- (* 4 (sb-allocated-size 'number-stack))))))))
-|#
-
-
-;;; In an XEP, allocate frames for this function on the control stack (and
-;;; number stack if any).  We get to emit the start label, since we might need
-;;; to emit variable cruft to align it, etc.
-;;;
-(define-vop (xep-allocate-frame)
-  (:info start-lab)
-  (:generator 1
-    (emit-label start-lab)
-    (inst cal sp-tn fp-tn (* 4 (sb-allocated-size 'stack)))))
-
-
-;;; Allocate the frame for the function we are about to call, returning the
-;;; frame pointer(s).
-;;;
-(define-vop (allocate-frame)
-  (:results (res :scs (any-reg descriptor-reg)) (nfp))
-  (:info callee)
-  (:ignore nfp callee)
-  (:generator 2
-    (inst lr res sp-tn)
-    (inst cal sp-tn sp-tn (* 4 (sb-allocated-size 'stack)))))
-
-
-;;; Allocate a partial frame for passing stack arguments in a full call.  Nargs
-;;; is the number of arguments passed.  If no stack arguments are passed, then
-;;; we don't have to do anything.
-;;;
-(define-vop (allocate-full-call-frame)
-  (:info nargs)
-  (:results (res :scs (any-reg descriptor-reg)
-		 :load-if (> nargs register-arg-count)))
-  (:generator 2
-    (when (> nargs register-arg-count)
-      (inst lr res sp-tn)
-      (inst cal sp-tn sp-tn (* 4 nargs)))))
-
-
-;;; 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 old-fp-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 old-fp-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 old-fp-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 old-fp-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 old-fp-tn i)
-		  (store-stack-tn tn move-temp)))
-
-	      (emit-label defaulting-done)
-	      (inst lr sp-tn old-fp-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 Old-Fp and Nargs.
-;;;
-;;;    Old-Fp 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 old-fp nargs start count)
-  (declare (type node node) (type tn old-fp 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) old-fp i))
-	  (unless (location= start old-fp)
-	    (inst lr start old-fp))
-	  (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 old-fp-offset
-	       :from :eval  :to (:result 0))
-	      values-start)
-  (:temporary (:sc any-reg
-	       :offset argument-count-offset
-	       :from :eval  :to (:result 1))
-	      nvals))
-
-
-;;;; Local call with unknown values convention return:
-
-;;; Non-TR local call for a fixed number of values passed according to the
-;;; unknown values convention.
-;;;
-;;; When initially emitted, Args reference the values to be passed.
-;;; Representation selection changes the Args to reference the passing
-;;; locations when it inserts the move-argument VOPs.  Arg-Locs is the list of
-;;; passing locations used by representation selection.
-;;;
-;;; 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.
-;;;
-;;; Note: we can't use normal load-tn allocation for the fixed args, since all
-;;; registers may be tied up by the more operand.  Instead, we use
-;;; MAYBE-LOAD-STACK-TN.
-;;;
-(define-vop (call-local)
-  (:args (fp)
-	 (nfp)
-	 (args :more t))
-  (:results (values :more t))
-  (:save-p t)
-  (:move-args :local-call)
-  (:info arg-locs callee target nvals)
-  (:ignore arg-locs args nfp)
-  (: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)
-    (maybe-load-stack-tn fp-tn fp)
-    (inst bali (callee-return-pc-tn callee) target)
-    (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 (fp)
-	 (nfp)
-	 (args :more t))
-  (:save-p t)
-  (:move-args :local-call)
-  (:info arg-locs callee target)
-  (:ignore arg-locs args nfp)
-  (:vop-var vop)
-  (:temporary (:sc stack
-	       :offset env-save-offset)
-	      env-save)
-  (:generator 20
-    (store-stack-tn env-save env-tn)
-    (maybe-load-stack-tn fp-tn fp)
-    (inst bali (callee-return-pc-tn callee) target)
-    (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 (fp)
-	 (nfp)
-	 (args :more t))
-  (:results
-   (res :more t))
-  (:move-args :local-call)
-  (:save-p t)
-  (:info arg-locs callee target)
-  (:ignore arg-locs args res nfp)
-  (:vop-var vop)
-  (:generator 5
-    (maybe-load-stack-tn fp-tn fp)
-    (inst bali (callee-return-pc-tn callee) target)
-    (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 FP and SP and jump to the Return-PC.
-;;;
-;;; Note: we can't use normal load-tn allocation for the fixed args, since all
-;;; registers could get tied up by the more operand.  Instead, we use
-;;; MAYBE-LOAD-STACK-TN into preallocated temporaries.
-;;;
-(define-vop (known-return)
-  (:args
-   (old-fp :target old-fp-temp)
-   (return-pc :target return-pc-temp)
-   (vals :more t))
-  (:temporary (:sc descriptor-reg :from (:argument 0)) old-fp-temp)
-  (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp)
-  (:move-args :known-return)
-  (:info val-locs)
-  (:ignore val-locs vals)
-  (:generator 6
-    (maybe-load-stack-tn old-fp-temp old-fp)
-    (maybe-load-stack-tn return-pc-temp return-pc)
-    (inst lr sp-tn fp-tn)
-    (inst bnbrx :pz return-pc-temp)
-    (inst lr fp-tn old-fp-temp)))
-
-
-;;;; 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 creating a partial frame on the
-;;; stack top and storing stack arguments into that frame.  On entry to the
-;;; callee, this partial frame is pointed to by FP.  If there are no stack
-;;; arguments, we don't bother allocating a partial frame, and instead set FP
-;;; to SP just before the call.
-
-
-;;; 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-Fp and Return-PC are passed as the second and third arguments.
-;;;
-;;; In non-tail calls, the pointer to the stack arguments is passed as the last
-;;; fixed argument.  If Variable is false, then the passing locations are
-;;; passed as a more arg.  Variable is true if there are a variable number of
-;;; arguments passed on the stack.  Variable cannot be specified with :Tail
-;;; return.  TR variable argument call is implemented separately.
-;;;
-;;; In tail call with fixed arguments, the passing locations are passed as a
-;;; more arg, but there is no new-FP, since the arguments have been set up in
-;;; the current frame.
-;;;
-(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
-      ,@(unless (eq return :tail)
-	  `((new-fp :scs (descriptor-reg) :to :eval
-		    ,@(unless variable
-			`(:load-if (> nargs register-arg-count))))))
-
-      ,(if named
-	   '(name :scs (descriptor-reg)
-		  :target name-pass)
-	   '(function :scs (descriptor-reg) :to :eval))
-      
-      ,@(when (eq return :tail)
-	  '((old-fp :scs (descriptor-reg)
-		    :target old-fp-pass)
-	    (return-pc :scs (descriptor-reg)
-		       :target return-pc-pass)))
-      
-      ,@(unless variable '((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)
-	   ,@(unless variable
-	       '((:move-args :full-call)))))
-
-     (:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
-	    ,@(unless variable '(nargs))
-	    ,@(when (eq return :fixed) '(nvals)))
-
-     (:ignore ,@(unless (or variable (eq return :tail)) '(arg-locs))
-	      ,@(unless variable '(args)))
-
-     (:temporary (:sc descriptor-reg
-		  :offset old-fp-offset
-		  :from (:argument 1)
-		  :to :eval)
-		 old-fp-pass)
-
-     (:temporary (:sc descriptor-reg
-		  :offset return-pc-offset
-		  :from (:argument ,(if (eq return :tail) 2 1))
-		  :to :eval)
-		 return-pc-pass)
-
-     ,@(when named 
-	 `((:temporary (:sc descriptor-reg
-			:offset call-name-offset
-			:from (:argument ,(if (eq return :tail) 0 1))
-			:to :eval)
-		       name-pass)
-	   (:temporary (:scs (descriptor-reg)
-			     :from (:argument ,(if (eq return :tail) 0 1))
-			     :to :eval)
-		       function)))
-
-     (: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))
-       
-       ,@(when named
-	   `((unless (location= name name-pass)
-	       (inst lr name-pass name))
-	     (loadw function name-pass (/ clc::symbol-definition 4))))
-       
-       ,@(if variable
-	     `((inst lr nargs-pass sp-tn)
-	       (inst s nargs-pass new-fp)
-	       (inst sari nargs-pass 2)
-	       (loadw a0 new-fp 0)
-	       (loadw a1 new-fp 1)
-	       (loadw a2 new-fp 2))
-	     `((loadi nargs-pass nargs)))
-       
-       (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-fp old-fp-pass)
-		 (inst lr old-fp-pass old-fp))
-	       (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-fp-pass fp-tn)
-	       ,(if variable
-		    '(inst lr fp-tn new-fp)
-		    '(if (> nargs register-arg-count)
-			 (inst lr fp-tn new-fp)
-			 (inst lr fp-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-Fp and the function
-;;; are passed in the registers that they will ultimately go in: OLD-FP and
-;;; ENV.  Args is a pointer to the start of the arguments on the stack, and is
-;;; passed in the special ARGS passing location.  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
-   (args :scs (descriptor-reg) :target args-pass)
-   (function :scs (descriptor-reg))
-   (old-fp :scs (descriptor-reg) :target old-fp-pass)
-   (return-pc :scs (descriptor-reg) :target a3))
-  (:temporary (:sc descriptor-reg
-	       :offset old-fp-offset
-	       :from (:argument 2))
-	      old-fp-pass)
-  (:temporary (:sc descriptor-reg
-	       :offset a3-offset
-	       :from (:argument 3))
-	      a3)
-  (:temporary (:sc descriptor-reg
-	       :offset argument-pointer-offset
-	       :from (:argument 0))
-	      args-pass)
-  (:generator 75
-    (inst lr env-tn function)
-    (unless (location= args args-pass)
-      (inst lr args-pass args))
-    (unless (location= old-fp old-fp-pass)
-      (inst lr old-fp-pass old-fp))
-    (unless (location= return-pc a3)
-      (inst lr a3 return-pc))
-    (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
-;;; FP 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 FP 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-fp :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 old-fp-offset)
-	      vals-loc)
-  (:generator 6
-    (cond ((= nvals 1)
-	   (inst lr sp-tn fp-tn)
-	   (inst inc return-pc 4)
-	   (inst bnbrx :pz return-pc)
-	   (inst lr fp-tn old-fp))
-	  (t
-	   (loadi nvals-loc nvals)
-	   (inst lr vals-loc fp-tn)
-	   (inst cal sp-tn vals-loc (* nvals 4))
-	   (inst lr fp-tn old-fp)
-
-	   (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-Fp and Count in the normal locations for these values.  The
-;;; pointer to the start of the return values is passed in the special ARGS
-;;; location.  Return-PC is passed in A3 since PC is trashed by the BALA.
-;;;
-(define-vop (return-multiple)
-  (:args
-   (old-fp :scs (descriptor-reg) :target old-fp-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-fp-offset
-	       :from (:argument 0))
-	      old-fp-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 fp-tn)
-      (inst inc return-pc 4)
-      (inst bnbrx :pz return-pc)
-      (inst lr fp-tn old-fp)
-
-      (unassemble
-	(assemble-elsewhere node
-	  (emit-label non-single)
-	  (unless (location= old-fp-pass old-fp)
-	    (inst lr old-fp-pass old-fp))
-	  (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:
-
-;;; 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.
-;;;
-(define-miscop listify-rest-args (context count)
-  :translate %listify-rest-args)
-
-
-;;; 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/char.lisp b/compiler/old-rt/char.lisp
deleted file mode 100644
index 37cd02e9a1ec082385c740505bd77164db015691..0000000000000000000000000000000000000000
--- a/compiler/old-rt/char.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 RT VM definition of character operations.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Moves and coercions:
-
-;;; Move untagged string-char values.
-;;;
-(define-vop (string-char-move)
-  (:args (x :target y
-	    :scs (string-char-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (string-char-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:generator 0
-    (unless (location= x y)
-      (inst lr y x))))
-;;;
-(define-move-vop string-char-move :move
-  (string-char-reg) (string-char-reg))
-
-
-;;; Move untagged string-char arguments/return-values.
-;;;
-(define-vop (move-string-char-argument)
-  (:args (x :target y
-	    :scs (string-char-reg))
-	 (fp :scs (descriptor-reg)
-	     :load-if (not (sc-is y string-char-reg))))
-  (:results (y))
-  (:generator 0
-    (sc-case y
-      (string-char-reg
-       (unless (location= x y)
-	 (inst lr y x)))
-      (string-char-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-string-char-argument :move-argument
-  (string-char-reg) (string-char-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged string-char to a
-;;; descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (string-char-reg) (any-reg descriptor-reg))
-
-
-;;; Move a tagged string char to an untagged representation.
-;;;
-(define-vop (move-to-string-char)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (y :scs (string-char-reg)))
-  (:generator 1
-    (inst nilz y x system:%character-code-mask)))
-;;;
-(define-move-vop move-to-string-char :move
-  (any-reg descriptor-reg) (string-char-reg))
-
-
-;;; Move an untagged string char to a tagged representation.
-;;;
-(define-vop (move-from-string-char)
-  (:args (x :scs (string-char-reg)))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (inst oiu y x (ash system:%string-char-type clc::type-shift-16))))
-;;;
-(define-move-vop move-from-string-char :move
-  (string-char-reg) (any-reg descriptor-reg))
-
-
-;;;; Other operations:
-
-(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)
-  (: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)
-  (:generator 0
-    (unless (location= code res)
-      (inst lr res code))))
-
-
-(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)
-  (:generator 3
-    (inst cl x y)
-    (if not-p
-	(inst bnb condition target)
-	(inst bb condition target))))
-
-
-;;; 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/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 9f9f75f414b421937f9b680660ab2075be57f88a..0000000000000000000000000000000000000000
--- a/compiler/old-rt/dump.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 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 32))
-		     (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
-;;;
-;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts.  Size
-;;; must be a directly supported I-vector element size, with no extra bits.
-;;;
-;;; If a byte vector, or if the native and target byte orderings are the same,
-;;; then just write the bits.  Otherwise, dispatch off of the target byte order
-;;; and write the vector one element at a time.
-;;;
-(defun dump-i-vector (vec file)
-  (let* ((vec (if #+new-compiler (array-header-p vec)
-		  #-new-compiler (%primitive complex-array-p vec)
-		  (coerce vec 'simple-array)
-		  vec))
-	 (ac (%primitive get-vector-access-code vec))
-	 (len (length vec))
-	 (size (ash 1 ac))
-	 (bytes (ash (+ (ash len ac) 7) -3)))
-		    
-    (dump-fop 'lisp::fop-int-vector file)
-    (quick-dump-number len 4 file)
-    (dump-byte size file)
-    (cond ((or (eq target-byte-order native-byte-order)
-	       (= size 8))
-	   (dotimes (i bytes)
-	     (dump-byte (%primitive typed-vref 3 vec i) file)))
-	  ((> size 8)
-	   (ecase target-byte-order
-	     (:little-endian
-	      (dotimes (i len)
-		(let ((int (aref vec i)))
-		  (quick-dump-number int (ash size -3) file))))
-	     (:big-endian
-	      (dotimes (i len)
-		(let ((int (aref vec i)))
-		  (do ((shift (- 8 size) (+ shift 8)))
-		      ((plusp shift))
-		    (dump-byte (logand (ash int shift) #xFF) file)))))))
-	  (t
-	   (macrolet ((frob (initial step done)
-			`(let ((shift ,initial)
-			       (byte 0))
-			   (dotimes (i len)
-			     (let ((int (aref vec i)))
-			       (setq byte (logior byte (ash int shift)))
-			       (,step shift size))
-			     (when ,done
-			       (dump-byte byte file)
-			       (setq shift ,initial  byte 0)))
-			   (unless (= shift ,initial) (dump-byte byte file)))))
-	   (ecase target-byte-order
-	     (:little-endian
-	      (frob 0 incf (= shift 8)))
-	     (:big-endian
-	      (let ((initial-shift (- 8 size)))
-		(frob initial-shift decf (minusp shift))))))))))
-
-
-;;; 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 cff8a12d8735722309eb5633272065ba3cf0c6f3..0000000000000000000000000000000000000000
--- a/compiler/old-rt/genesis.lisp
+++ /dev/null
@@ -1,1574 +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)
-  (prepare-for-fast-read-byte *fasl-file*
-    (let* ((len (fast-read-u-integer 4))
-	   (size (fast-read-byte))
-	   (ac (1- (integer-length size)))
-	   (res (%primitive alloc-i-vector len ac)))
-      (done-with-fast-read-byte)
-      (unless (and (<= ac 5) (= size (ash 1 ac)))
-	(error "Losing element size ~S." size))
-      (read-n-bytes *fasl-file* res 0 (ash (+ (ash len ac) 7) -3))
-      (i-vector-to-core (if (typep res 'simple-bit-vector)
-			    (dynamic bit-vector-ltype)
-			    (dynamic integer-vector-ltype))
-			size len 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 0ae46651270fe85c5a2fead46e02d175a2df15f4..0000000000000000000000000000000000000000
--- a/compiler/old-rt/miscop.lisp
+++ /dev/null
@@ -1,197 +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)
-  (:info nargs)
-  (:generator 40
-    (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)
-  (:info nargs)
-  (:generator 40
-    (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))))
-
-
-;;;; ILLEGAL-MOVE
-
-;;; This VOP is emitted when we attempt to do a move between incompatible
-;;; primitive types.  We signal an error, and ignore the result (which is
-;;; specified only to terminate its lifetime.)
-;;;
-(define-vop (illegal-move three-arg-miscop)
-  (:args (x :scs (any-reg descriptor-reg) :target a1)
-	 (y-type :scs (any-reg descriptor-reg) :target a2))
-  (:variant-vars)
-  (:ignore r a3 nl0 nl1 misc-pc)
-  (:generator 666
-    (loadi a0 clc::error-object-not-type)
-    (unless (location= x a1)
-      (inst lr a1 x))
-    (unless (location= y-type a2)
-      (inst lr a2 y-type))
-    (inst miscop 'clc::error2)
-    (note-this-location vop :internal-error)))
diff --git a/compiler/old-rt/move.lisp b/compiler/old-rt/move.lisp
deleted file mode 100644
index a57106bd69fe63ef265c743fa0e09abdef6e2170..0000000000000000000000000000000000000000
--- a/compiler/old-rt/move.lisp
+++ /dev/null
@@ -1,101 +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 operand loading/saving and
-;;; the Move VOP.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Move functions:
-
-(define-move-function (load-immediate 1) (node x y)
-  ((short-immediate unsigned-immediate immediate random-immediate)
-   (any-reg descriptor-reg))
-  (let ((val (tn-value x)))
-    (etypecase val
-      (integer
-       (loadi y val))
-      (null
-       (inst cau y zero-tn clc::nil-16))
-      ((member t)
-       (inst cau y zero-tn clc::t-16)))))
-
-(define-move-function (load-string-char 1) (node x y)
-  ((immediate-string-char) (string-char-reg))
-  (loadi y (char-code (tn-value x))))
-
-(define-move-function (load-tagged-string-char 2) (node x y)
-  ((immediate-string-char) (any-reg descriptor-reg))
-  (loadi y (char-code (tn-value x)))
-  (inst oiu y y (ash system:%string-char-type clc::type-shift-16)))
-
-(define-move-function (load-constant 5) (node x y)
-  ((constant) (any-reg descriptor-reg))
-  (load-slot y env-tn (tn-offset x)))
-
-(define-move-function (load-stack 5) (node x y)
-  ((stack) (any-reg descriptor-reg)
-   (string-char-stack) (string-char-reg))
-  (load-stack-tn y x))
-
-(define-move-function (store-stack 5) (node x y)
-  ((any-reg descriptor-reg) (stack)
-   (string-char-reg) (string-char-stack))
-  (store-stack-tn y x))
-
-
-;;;; Move and Move-Argument VOPs:
-
-
-;;;    The Move VOP is used for doing arbitrary moves when there is no
-;;; type-specific move/coerce operation.
-;;;
-(define-vop (move)
-  (:args (x :target y
-	    :scs (any-reg descriptor-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (any-reg descriptor-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:generator 0
-    (unless (location= x y)
-      (inst lr y x))))
-
-
-;;; 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)
-
-
-;;;    The Move-Argument VOP is used for moving descriptor values into another
-;;; frame for argument or known value passing.
-;;;
-(define-vop (move-argument)
-  (:args (x :target y
-	    :scs (any-reg descriptor-reg))
-	 (fp :scs (descriptor-reg)
-	     :load-if (not (sc-is y any-reg descriptor-reg))))
-  (:results (y))
-  (:generator 0
-    (sc-case y
-      ((any-reg descriptor-reg)
-       (unless (location= x y)
-	 (inst lr y x)))
-      (stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-argument :move-argument
-  (any-reg descriptor-reg)
-  (any-reg descriptor-reg))
diff --git a/compiler/old-rt/nlx.lisp b/compiler/old-rt/nlx.lisp
deleted file mode 100644
index 93dacbfe2810cb06042364cc7df7acfac272ab8d..0000000000000000000000000000000000000000
--- a/compiler/old-rt/nlx.lisp
+++ /dev/null
@@ -1,221 +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)
-
-
-;;; MAKE-NLX-SP-TN  --  Interface
-;;;
-;;;    Make an environment-live stack TN for saving the SP for NLX entry.
-;;;
-(defun make-nlx-sp-tn (env)
-  (environment-live-tn
-   (make-representation-tn *any-primitive-type* stack-arg-scn)
-   env))
-  
-
-;;; 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 Fp, 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 fp-tn (* (tn-offset tn) 4))
-    (load-global temp clc::current-unwind-protect-block)
-    (storew temp result system:%unwind-block-current-uwp)
-    (storew fp-tn result system:%unwind-block-current-fp)
-    (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 fp-tn (* (tn-offset tn) 4))
-    (load-global temp clc::current-unwind-protect-block)
-    (storew temp result system:%unwind-block-current-uwp)
-    (storew fp-tn result system:%unwind-block-current-fp)
-    (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 fp-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/parms.lisp b/compiler/old-rt/parms.lisp
deleted file mode 100644
index 1cd2889a54507679553fdf05b92fe955bf5df149..0000000000000000000000000000000000000000
--- a/compiler/old-rt/parms.lisp
+++ /dev/null
@@ -1,80 +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 some parameterizations of various VM attributes for
-;;; the RT.  This file is separate from other stuff so that it can be compiled
-;;; and loaded earlier.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(eval-when (compile load eval)
-
-;;; Maximum number of SCs allowed.
-;;;
-(defconstant sc-number-limit 32)
-
-;;; The number of references that a TN must have to offset the overhead of
-;;; saving the TN across a call.
-;;;
-(defconstant register-save-penalty 3)
-
-
-;;;; Assembler parameters:
-
-;;; The length of the smallest addressable unit on the target
-;;; machine.
-;;;
-(defparameter *word-length* 8)
-
-;;; Convert-Byte-List  --  Internal
-;;; 
-;;; Convert-Byte-List take a list of byte specifiers that define a field
-;;; and returns a list of byte specifiers that can be used to take apart
-;;; the value to be placed in that field.  This is somewhat architecture
-;;; dependent because of differences in byte ordering conventions.
-
-(defun convert-byte-list (byte-list)
-  (let ((offset (byte-position (first byte-list))))
-    (mapcar #'(lambda (byte)
-		(byte (byte-size byte) (- (byte-position byte) offset)))
-	    byte-list)))
-
-
-;;;; Other parameters:
-
-;;; The number representing the fasl-code format emit code in.
-;;;
-(defparameter target-fasl-code-format 6)
-
-;;; The version string for the implementation dependent code.
-;;;
-(defparameter vm-version "IBM RT PC/Mach 0.0")
-
-
-;;; The byte ordering of the target implementation.
-;;;
-(defparameter target-byte-order :big-endian)
-
-;;;
-;;; The native byte ordering (should come from somewhere else once
-;;; bootstrapped.)
-(defconstant native-byte-order :big-endian)
-
-;;; The byte ordering of the target implementation.
-;;;
-(defparameter target-byte-order :big-endian)
-
-;;;
-;;; The native byte ordering (should come from somewhere else once
-;;; bootstrapped.)
-(defconstant native-byte-order :big-endian)
-
-); Eval-When (Compile Load Eval)
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 84d015b6f729d70dceea40487b4c5d24f85caef5..0000000000000000000000000000000000000000
--- a/compiler/old-rt/subprim.lisp
+++ /dev/null
@@ -1,164 +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 putf (x y z))
-(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/system.lisp b/compiler/old-rt/system.lisp
deleted file mode 100644
index bf4dd20b4df1636bcaa7fc56b78b2170b7300d16..0000000000000000000000000000000000000000
--- a/compiler/old-rt/system.lisp
+++ /dev/null
@@ -1,172 +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)
-  (: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 (:sc any-reg
-	       :from (:argument 0)
-	       :to (:result 0)
-	       :target res)
-	      temp)
-  (: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)))
-  (: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)
-  (: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))))
-
-
-(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)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:policy :fast-safe)
-  (:generator 3
-    (inst c x y)
-    (let ((target (generate-error-code vop 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)
-  (: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)))
-  (: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)
-  (: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/old-rt/type-vops.lisp b/compiler/old-rt/type-vops.lisp
deleted file mode 100644
index 85bb1ed1454bd9369bad3858ccbf65f602645145..0000000000000000000000000000000000000000
--- a/compiler/old-rt/type-vops.lisp
+++ /dev/null
@@ -1,287 +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 (fast-safe-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))))))
-
-
-(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))
-	  (not-sym-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)
-	  (test-simple-type thing temp not-sym-lab t system:%symbol-type)
-	  (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)
-
-	  (emit-label not-sym-lab)
-	  (error-call clc::error-object-not-function-or-symbol thing))))))
diff --git a/compiler/old-rt/values.lisp b/compiler/old-rt/values.lisp
deleted file mode 100644
index 0e857351621dac1dd82e7f8f9a1e15b6b73a8931..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 descriptor-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 507223e7404f907b33960008e76c61361efe85f3..0000000000000000000000000000000000000000
--- a/compiler/old-rt/vm-tran.lisp
+++ /dev/null
@@ -1,103 +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, IR2 convert
-;;; methods, etc.
-;;;
-;;; 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))
-
-
-;;; Some hacks to let us implement structures as simple-vectors without
-;;; confusing type inference too much.
-;;;
-(def-builtin-type 'structure-vector
-  (make-named-type :name 'structure-vector
-		   :supertypes '(structure-vector t)
-		   :subclasses '(structure)))
-
-(defknown structure-vector-p (t) boolean)
-
-(define-type-predicate structure-vector-p structure-vector)
-
-(def-source-transform structurep (x)
-  (once-only ((n-x x))
-    `(and (structure-vector-p ,n-x)
-	  (eql (%primitive get-vector-subtype ,n-x)
-	       system:%g-vector-structure-subtype))))
-
-(define-vop (structure-vector-p simple-vector-p)
-  (:translate structure-vector-p))
-
-#-new-compiler
-(set 'lisp::type-pred-alist
-     (adjoin (cons 'structure-vector 'simple-vector-p)
-	     (symbol-value 'lisp::type-pred-alist)
-	     :key #'car))
-
-(def-source-transform compiled-function-p (x)
-  `(functionp ,x))
-
-(def-source-transform char-int (x)
-  `(truly-the char-int (%primitive make-fixnum ,x)))
-
-
-;;;; Funny function implementations:
-
-;;; Convert these funny functions into a %Primitive use, letting %Primitive
-;;; deal with evaluating the "Fixed" codegen-info arguments.
-;;;
-(def-source-transform %more-arg-context (&rest foo)
-  `(%primitive more-arg-context ,@foo))
-;;;
-(def-source-transform %verify-argument-count (&rest foo)
-  `(%primitive verify-argument-count ,@foo))
-
-
-;;; Error funny functions:
-;;;
-;;; Mark these as as not returning by using TRULY-THE NIL.
-
-(def-source-transform %type-check-error (obj type)
-  `(truly-the nil (%primitive error2 clc::error-object-not-type ,obj ,type)))
-
-(def-source-transform %odd-keyword-arguments-error ()
-  '(truly-the nil (%primitive error0 clc::error-odd-keyword-arguments)))
-
-(def-source-transform %unknown-keyword-argument-error (key)
-  `(truly-the nil (%primitive error1 clc::error-unknown-keyword-argument ,key)))
-
-(def-source-transform %argument-count-error (&rest foo)
-  `(truly-the nil (%primitive argument-count-error ,@foo)))
-
-
-;;;; Syscall:
-
-(def-primitive-translator syscall (&rest args) `(%syscall ,@args))
-(defknown %syscall (&rest t) *)
-
-(defoptimizer (%syscall ir2-convert) ((&rest args) node block)
-  (let* ((refs (move-tail-full-call-args node block))
-	 (cont (node-cont node))
-	 (res (continuation-result-tns
-	       cont
-	       (list *any-primitive-type* *any-primitive-type*))))
-    (vop* syscall node block
-	  (refs)
-	  ((first res) (second res) nil)
-	  (length args))
-    (move-continuation-result node block res cont)))  
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/old-rt/vm.lisp b/compiler/old-rt/vm.lisp
deleted file mode 100644
index 963bce79d916a73c2d7152d6921f80faeb5432b7..0000000000000000000000000000000000000000
--- a/compiler/old-rt/vm.lisp
+++ /dev/null
@@ -1,386 +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 for the RT.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; SB and SC definition:
-
-(define-storage-base registers :finite :size 16)
-(define-storage-base stack :unbounded :size 8)
-(define-storage-base constant :non-packed)
-(define-storage-base immediate-constant :non-packed)
-
-;;;
-;;; Non-immediate constants in the constant pool.
-(define-storage-class constant 6 constant)
-
-;;; Immediate numeric constants.  A constant TN will be created in the
-;;; most restrictive SC possible:
-;;;
-;;;    short-immediate = (unsigned-byte 4)
-;;;        Self-explanatory: short-immediate operands on the RT are unsigned.
-;;;
-;;;    unsigned-immediate = (unsigned-byte 15)
-;;;        Used for unsigned immediate operands.  15 instead of 16 so that this
-;;;        is a subtype of Immediate.
-;;;
-;;;    immediate = (integer #x7FFF #x-7FFF)
-;;;        The funny lower bound guarantees that the negation of an immediate
-;;;        is still an immediate.
-;;;
-(define-storage-class short-immediate 7 immediate-constant)
-(define-storage-class unsigned-immediate 8 immediate-constant)
-(define-storage-class immediate 9 immediate-constant)
-
-;;; Allows simple loading of unboxed string-chars.
-;;;
-(define-storage-class immediate-string-char 10 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.
-;;;
-(define-storage-class random-immediate 11 immediate-constant)
-
-;;;
-;;; Descriptor objects stored on the stack.
-(define-storage-class stack 4 stack)
-
-;;;
-;;; Untagged string-chars stored on the stack.
-(define-storage-class string-char-stack 5 stack)
-
-;;;
-;;; Objects that can be stored in any register (immediate objects).
-(define-storage-class any-reg 0 registers
-  :locations (0 1 2 3 4 5 7 8 9 10 11 15)
-  :constant-scs (constant short-immediate unsigned-immediate immediate
-			  immediate-string-char random-immediate)
-  :save-p t
-  :alternate-scs (stack))
-
-;;;
-;;; Pointer objects that must be seen by GC.
-(define-storage-class descriptor-reg 1 registers
-  :locations (1 3 4 5 7 8 9 10 11 15)
-  :constant-scs (constant short-immediate unsigned-immediate immediate
-			  immediate-string-char random-immediate)
-  :save-p t
-  :alternate-scs (stack))
-
-;;;
-;;; Objects that must not be seen by GC (unboxed numbers).
-(define-storage-class non-descriptor-reg 2 registers
-  :locations (0 2))
-
-;;;
-;;; String-chars represented without tag bits (looks like a fixnum).
-(define-storage-class string-char-reg 3 registers
-  :locations (0 1 2 3 4 5 7 8 9 10 11 15)
-  :constant-scs (immediate-string-char)
-  :save-p t
-  :alternate-scs (string-char-stack))
-
-;;; A catch or unwind block.
-;;;
-(define-storage-class catch-block 12 stack
-  :element-size system:%catch-block-size)
-
-
-;;;; Primitive type definition:
-;;;
-;;;    For now, the primitive types we support are primarily for discrimination
-;;; rather than representation selection.
-
-(def-primitive-type t (descriptor-reg))
-(defvar *any-primitive-type* (primitive-type-or-lose 't))
-
-(def-primitive-type simple-string (descriptor-reg))
-(def-primitive-type simple-vector (descriptor-reg))
-(def-primitive-type simple-bit-vector (descriptor-reg))
-
-(def-primitive-type string-char (string-char-reg any-reg))
-(def-primitive-type fixnum (any-reg))
-(def-primitive-type short-float (any-reg))
-(def-primitive-type long-float (descriptor-reg))
-(def-primitive-type bignum (descriptor-reg))
-(def-primitive-type ratio (descriptor-reg))
-(def-primitive-type complex (descriptor-reg))
-(def-primitive-type function (descriptor-reg))
-
-;;; We make List a primitive type, since it is useful for discrimination of
-;;; generic sequence function arguments.  This means that Cons and Symbol can't
-;;; be primitive types.
-(def-primitive-type list (descriptor-reg))
-
-;;; Dummy primitive type for catch block TNs.
-(def-primitive-type catch-block (catch-block) :type nil)
-
-
-;;; 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*))))
-
-
-;;; PRIMITIVE-TYPE  --  Interface
-;;;
-;;;    Return the primitive type corresponding to a type descriptor structure.
-;;; If a fixnum or an interesting simple vector, then return the appropriate
-;;; type, otherwise return *any-primitive-type*.  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.
-;;;
-;;; Note: DEFUN-CACHED caches this translation; If the primitive type
-;;; translation is ever changed (due to hardware configuration switches, etc.),
-;;; then PRIMITIVE-TYPE-CACHE-CLEAR must be called to clear old cached
-;;; information.
-;;;
-(defun-cached (primitive-type
-	       :hash-function (lambda (x)
-				(logand (cache-hash-eq x) #x1FF))
-	       :hash-bits 9
-	       :values 2
-	       :default (values nil :empty))
-	      ((type eq))
-  (declare (type ctype type))
-  (etypecase type
-    (named-type
-     (case (named-type-name type)
-       ((t bignum ratio string-char function)
-	(values (primitive-type-or-lose (named-type-name type)) t))
-       (cons
-	(values (primitive-type-or-lose 'list) nil))
-       (standard-char
-	(values (primitive-type-or-lose 'string-char) nil))
-       (t
-	(values *any-primitive-type* nil))))
-    (member-type
-     (let* ((members (member-type-members type))
-	    (res (primitive-type-of (first members))))
-       (dolist (mem (rest members) (values res nil))
-	 (unless (eq (primitive-type-of mem) res)
-	   (return (values *any-primitive-type* nil))))))
-    (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)))
-	   (if (and (consp dims) (null (rest dims)))
-	       (let ((len-wild (eq (first dims) '*)))
-		 (case (type-specifier etype)
-		   (string-char
-		    (values (primitive-type-or-lose 'simple-string)
-			    len-wild))
-		   (bit
-		    (values (primitive-type-or-lose 'simple-bit-vector)
-			    len-wild))
-		   ((t)
-		    (values (primitive-type-or-lose 'simple-vector)
-			    len-wild))
-		   (t
-		    (values *any-primitive-type* nil))))
-	       (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) (values res exact))
-	       (multiple-value-bind (ptype ptype-exact)
-				    (primitive-type type)
-		 (unless ptype-exact (setq exact nil))
-		 (unless (eq ptype res)
-		   (return (values *any-primitive-type* nil)))))))))
-    (function-type (values (primitive-type-or-lose 'function) t))
-    (ctype
-     (values *any-primitive-type* nil))))
-
-
-;;;; Totally magical registers:
-
-;;; Pointer to the current frame: 
-(defparameter fp-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset 13))
-
-;;; Pointer to the current constant pool:
-(defparameter env-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset 14))
-
-;;; Pointer to the stack top:
-(defparameter sp-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset 6))
-
-;;; Binding stack pointer:
-(defparameter bs-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset 12))
-
-;;; TN with 0 offset, used for 0/reg args when we want 0.
-(defparameter zero-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset 0))
-
-
-;;;; Side-effect classes:
-
-(def-boolean-attribute vop
-  ;;
-  ;; Nothing for now...
-  any
-  )
-
-
-;;;; Constant creation:
-
-;;; 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
-    ((unsigned-byte 4)
-     (sc-number-or-lose 'short-immediate))
-    ((unsigned-byte 15)
-     (sc-number-or-lose 'unsigned-immediate))
-    ((integer #x-7FFF #x7FFF)
-     (sc-number-or-lose 'immediate))
-    ((or fixnum (member nil t))
-     (sc-number-or-lose 'random-immediate))
-    (t
-     ;;
-     ;; ### hack around bug in (typep x 'string-char)
-     (if (and (characterp value) (string-char-p value))
-	 (sc-number-or-lose 'immediate-string-char)
-	 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 stack-arg-scn (sc-number-or-lose 'stack))
-
-;;; Offsets of special registers...
-;;;
-(eval-when (compile load eval)
-  (defconstant return-pc-offset 15)
-  (defconstant env-offset 14)
-  (defconstant argument-count-offset 0)
-  (defconstant argument-pointer-offset 11)
-  (defconstant old-fp-offset 10)
-  (defconstant sp-offset 6)
-  (defconstant call-name-offset 9))
-
-;;; Offsets of special stack frame locations...
-;;;
-(eval-when (compile load eval)
-  (defconstant old-fp-save-offset 0)
-  (defconstant return-pc-save-offset 1)
-  (defconstant env-save-offset 2))
-
-
-(defparameter nargs-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset argument-count-offset))
-
-(defparameter old-fp-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset old-fp-offset))
-  
-(defparameter pc-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset return-pc-offset))
-
-
-(eval-when (compile load eval)
-
-;;; The offsets within the register-arg SC that we pass values in, first
-;;; value first.
-;;;
-(defconstant register-arg-offsets '(1 3 5))
-
-;;; The number of arguments/return values passed in registers.
-;;;
-(defconstant register-arg-count 3)
-
-;;; The fourth register argument (used only in miscop calls).
-;;;
-(defconstant a3-offset 4)
-
-); Eval-When (Compile Load Eval)
-
-
-;;; A list of TNs describing the register arguments.
-;;;
-(defparameter register-argument-tns
-  (mapcar #'(lambda (n)
-	      (make-random-tn :kind :normal
-			      :sc (sc-or-lose 'descriptor-reg)
-			      :offset n))
-	  register-arg-offsets))
-
-
-;;; LOCATION-PRINT-NAME  --  Interface
-;;;
-;;;    This function is called by debug output routines that want a pretty name
-;;; for a TN's location.  It returns a thing that can be printed with PRINC.
-;;;
-(defun location-print-name (tn)
-  (declare (type tn tn))
-  (let ((sb (sb-name (sc-sb (tn-sc tn)))))
-    (if (eq sb 'registers)
-	(svref '#(NL0 A0 NL1 A1 A3 A2 SP L0 L1 L2 L3 L4
-		      BS CONT ENV PC)
-	       (tn-offset tn))
-	(format nil "~A~D" (char (string sb) 0) (tn-offset tn)))))
diff --git a/compiler/pack.lisp b/compiler/pack.lisp
deleted file mode 100644
index 87a0c985c68d65f6ff0a72c2595ddc581b55a446..0000000000000000000000000000000000000000
--- a/compiler/pack.lisp
+++ /dev/null
@@ -1,1555 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/pack.lisp,v 1.45 1992/05/03 21:45:55 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the implementation independent code for Pack phase in
-;;; the compiler.  Pack is responsible for assigning TNs to storage allocations
-;;; or "register allocation".
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;; Some parameters controlling which optimizations we attempt (for debugging.)
-;;;
-(defparameter pack-assign-costs t)
-(defparameter pack-optimize-saves t)
-(defparameter pack-save-once t)
-
-
-;;;; 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 component-live TN (:component kind), then iterate over all the
-;;;    blocks.  If the element at Offset is used anywhere in any of the
-;;;    component'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 index offset))
-  (let ((confs (tn-global-conflicts tn))
-	(kind (tn-kind tn)))
-    (cond
-     ((eq kind :component)
-      (let ((loc-live (svref (finite-sb-always-live sb) offset)))
-	(dotimes (i (ir2-block-count *compile-component*) nil)
-	  (when (/= (sbit loc-live i) 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 index 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 :Component TN, then iterate over all the blocks, 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 index offset))
-  (let ((confs (tn-global-conflicts tn))
-	(sb (sc-sb sc))
-	(kind (tn-kind tn)))
-    (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 kind :component)
-	  (dotimes (num (ir2-block-count *compile-component*) nil)
-	    (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)))
-	      (declare (type local-tn-bit-vector local-confs))
-	      (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 (the local-tn-bit-vector (svref loc-confs num))
-		     (tn-local-conflicts tn) t))))))))
-
-
-;;; IR2-BLOCK-COUNT  --  Internal
-;;;
-;;;    Return the total number of IR2 blocks in Component.
-;;;
-(defun ir2-block-count (component)
-  (declare (type component component))
-  (do ((2block (block-info (block-next (component-head component)))
-	       (ir2-block-next 2block)))
-      ((null 2block)
-       (error "What?  No ir2 blocks have a non-nil number?"))
-    (when (ir2-block-number 2block)
-      (return (1+ (ir2-block-number 2block))))))
-
-
-;;; 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 (ir2-block-count component)))
-    (dolist (sb (backend-sb-list *backend*))
-      (unless (eq (sb-kind sb) :non-packed)
-	(let* ((conflicts (finite-sb-conflicts sb))
-	       (always-live (finite-sb-always-live sb))
-	       (max-locs (length conflicts)))
-	  (unless (zerop max-locs)
-	    (let ((current-size (length (the simple-vector
-					     (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)
-		      (- (* (ceiling size (sc-alignment sc))
-			    (sc-alignment sc))
-			 size))
-		   (- needed-size size)))
-	 (new-size (+ size inc))
-	 (conflicts (finite-sb-conflicts sb))
-	 (block-size (if (zerop (length conflicts))
-			 (ir2-block-count *compile-component*)
-			 (length (the simple-vector (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 (backend-sb-list *backend*))
-      (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*)
-
-
-;;;; Internal errors:
-
-;;; NO-LOAD-FUNCTION-ERROR  --  Internal
-;;;
-;;;    Give someone a hard time because there isn't any load function defined
-;;; to move from Src to Dest.
-;;;
-(defun no-load-function-error (src dest)
-  (let* ((src-sc (tn-sc src))
-	 (src-name (sc-name src-sc))
-	 (dest-sc (tn-sc dest))
-	 (dest-name (sc-name dest-sc)))
-    (cond ((eq (sb-kind (sc-sb src-sc)) :non-packed)
-	   (unless (member src-sc (sc-constant-scs dest-sc))
-	     (error "Loading from an invalid constant SC?~@
-	             VM definition inconsistent, try recompiling."))
-	   (error "No load function defined to load SC ~S ~
-	           from its constant SC ~S."
-		  dest-name src-name))
-	  ((member src-sc (sc-alternate-scs dest-sc))
-	   (error "No load function defined to load SC ~S from its ~
-	           alternate SC ~S."
-		  dest-name src-name))
-	  ((member dest-sc (sc-alternate-scs src-sc))
-	   (error "No load function defined to save SC ~S in its ~
-	           alternate SC ~S."
-		  src-name dest-name))
-	  (t
-	   (error "Loading to/from SCs that aren't alternates?~@
-	           VM definition inconsistent, try recompiling.")))))
-
-
-;;; FAILED-TO-PACK-ERROR  --  Internal
-;;;
-;;;    Called when we failed to pack TN.  If Restricted is true, then we we
-;;; restricted to pack TN in its SC. 
-;;;
-(defun failed-to-pack-error (tn restricted)
-  (declare (type tn tn))
-  (let* ((sc (tn-sc tn))
-	 (scs (cons sc (sc-alternate-scs sc))))
-    (cond
-     (restricted
-      (error "Failed to pack restricted TN ~S in its SC ~S."
-	     tn (sc-name sc)))
-     (t
-      (assert (not (find :unbounded scs
-			 :key #'(lambda (x) (sb-kind (sc-sb x))))))
-      (let ((ptype (tn-primitive-type tn)))
-	(cond
-	 (ptype
-	  (assert (member (sc-number sc) (primitive-type-scs ptype)))
-	  (error "SC ~S doesn't have any :Unbounded alternate SCs, but is~@
-	          a SC for primitive-type ~S."
-		 (sc-name sc) (primitive-type-name ptype)))
-	 (t
-	  (error "SC ~S doesn't have any :Unbounded alternate SCs."
-		 (sc-name sc))))))))
-  (undefined-value))
-
-
-;;; DESCRIBE-TN-USE  --  Internal
-;;;
-;;;    Return a list of format arguments describing how TN is used in Op's VOP.
-;;;
-(defun describe-tn-use (loc tn op)
-  (let* ((vop (tn-ref-vop op))
-	 (args (vop-args vop))
-	 (results (vop-results vop))
-	 (name (with-output-to-string (stream)
-		 (print-tn tn stream)))
-	 temp)
-    (cond
-     ((setq temp (position-in #'tn-ref-across tn args :key #'tn-ref-tn))
-      `("~2D: ~A (~:R argument)" ,loc ,name ,(1+ temp)))
-     ((setq temp (position-in #'tn-ref-across tn results :key #'tn-ref-tn))
-      `("~2D: ~A (~:R result)" ,loc ,name ,(1+ temp)))
-     ((setq temp (position-in #'tn-ref-across tn args :key #'tn-ref-load-tn))
-      `("~2D: ~A (~:R argument load TN)" ,loc ,name ,(1+ temp)))
-     ((setq temp (position-in #'tn-ref-across tn results :key
-			      #'tn-ref-load-tn))
-      `("~2D: ~A (~:R result load TN)" ,loc ,name ,(1+ temp)))
-     ((setq temp (position-in #'tn-ref-across tn (vop-temps vop)
-			      :key #'tn-ref-tn))
-      `("~2D: ~A (temporary ~A)" ,loc ,name
-	,(operand-parse-name (elt (vop-parse-temps
-				   (vop-parse-or-lose
-				    (vop-info-name  (vop-info vop))))
-				  temp))))
-     ((eq (tn-kind tn) :component)
-      `("~2D: ~A (component live)" ,loc ,name))
-     (t
-      `("~2D: not referenced?" ,loc)))))
-
-
-;;; FAILED-TO-PACK-LOAD-TN-ERROR  --  Internal
-;;;
-;;;    If load TN packing fails, try to give a helpful error message.  We find
-;;; a TN in each location that conflicts, and print it.
-;;;
-(defun failed-to-pack-load-tn-error (scs op)
-  (declare (list scs) (type tn-ref op))
-  (collect ((used)
-	    (unused))
-    (dolist (sc scs)
-      (let* ((sb (sc-sb sc))
-	     (confs (finite-sb-live-tns sb)))
-	(assert (eq (sb-kind sb) :finite))
-	(dolist (el (sc-locations sc))
-	  (let ((conf (load-tn-conflicts-in-sc op sc el t)))
-	    (if conf
-		(used (describe-tn-use el conf op))
-		(loop for i from el
-		      as victim = (svref confs i)
-		      repeat (sc-element-size sc) do
-		  (when (and victim (eq (tn-kind victim) :component))
-		    (used (describe-tn-use el victim op))
-		    (return t))
-		  finally (unused el)))))))
-      
-    (multiple-value-bind (arg-p n more-p costs load-scs incon)
-			 (get-operand-info op)
-	(declare (ignore costs load-scs))
-	(assert (not more-p))
-	(error "Unable to pack a Load-TN in SC ~{~A~#[~^~;, or ~:;,~]~} ~
-		for the ~:R ~:[result~;argument~] to~@
-		the ~S VOP,~@
-		~:[since all SC elements are in use:~:{~%~@?~}~%~;~
-		~:*but these SC elements are not in use:~%  ~S~%Bug?~*~]~
-		~:[~;~@
-		Current cost info inconsistent with that in effect at compile ~
-		time.  Recompile.~%Compilation order may be incorrect.~]"
-	       (mapcar #'sc-name scs)
-	       n arg-p
-	       (vop-info-name (vop-info (tn-ref-vop op)))
-	       (unused) (used)
-	       incon)))
-  (undefined-value))
-
-
-;;; NO-LOAD-SCS-ALLOWED-BY-PRIMITIVE-TYPE-ERROR  --  Internal
-;;;
-;;;    Called when none of the SCs that we can load Op into are allowed by Op's
-;;; primitive-type.
-;;;
-(defun no-load-scs-allowed-by-primitive-type-error (ref)
-  (declare (type tn-ref ref))
-  (let* ((tn (tn-ref-tn ref))
-	 (ptype (tn-primitive-type tn)))
-    (multiple-value-bind (arg-p pos more-p costs load-scs incon)
-			 (get-operand-info ref)
-      (declare (ignore costs))
-      (assert (not more-p))
-      (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~
-              ~%  ~S,~@
-	      since the TN's primitive type ~S doesn't allow any of the SCs~@
-	      allowed by the operand restriction:~%  ~S~
-	      ~:[~;~@
-	      Current cost info inconsistent with that in effect at compile ~
-	      time.  Recompile.~%Compilation order may be incorrect.~]"
-	     tn pos arg-p
-	     (template-name (vop-info (tn-ref-vop ref)))
-	     (primitive-type-name ptype)
-	     (mapcar #'sc-name (listify-restrictions load-scs))
-	     incon)))
-  (undefined-value))
-
-
-;;;; Register saving:
-
-;;; Original-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 :specified-save))
-      (tn-save-tn tn)
-      tn))
-
-
-;;; Note-Spilled-TN  --  Internal
-;;;
-;;;    Do stuff to note that TN is spilled at VOP for the debugger's benefit.
-;;;
-(defun note-spilled-tn (tn vop)
-  (when (and (tn-leaf tn) (vop-save-set vop))
-    (let ((2comp (component-info *compile-component*)))
-      (setf (gethash tn (ir2-component-spilled-tns 2comp)) t)
-      (pushnew tn (gethash vop (ir2-component-spilled-vops 2comp)))))
-  (undefined-value))
-
-
-;;; 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 nil nil)))
-    (dolist (alt (sc-alternate-scs (tn-sc tn))
-		 (error "No unbounded alternate for SC ~S."
-			(sc-name (tn-sc tn))))
-      (when (eq (sb-kind (sc-sb alt)) :unbounded)
-	(setf (tn-save-tn tn) res)
-	(setf (tn-save-tn res) tn)
-	(setf (tn-sc res) alt)
-	(pack-tn res t)
-	(return res)))))
-
-
-;;; EMIT-OPERAND-LOAD  --  Internal
-;;;
-;;;    Find the load function for moving from Src to Dest and emit a
-;;; MOVE-OPERAND VOP with that function as its info arg.
-;;;
-(defun emit-operand-load (node block src dest before)
-  (declare (type node node) (type ir2-block block)
-	   (type tn src dest) (type (or vop null) before))
-  (emit-load-template node block
-		      (template-or-lose 'move-operand *backend*)
-		      src dest
-		      (list (or (svref (sc-move-functions (tn-sc dest))
-				       (sc-number (tn-sc src)))
-				(no-load-function-error src dest)))
-		      before)
-  (undefined-value))
-
-
-;;; REVERSE-FIND-VOP  --  Internal
-;;;
-;;;    Find the preceding use of the VOP NAME in the emit order, starting with
-;;; VOP.  We must find the VOP in the same IR1 block.
-;;;
-(defun reverse-find-vop (name vop)
-  (do* ((block (vop-block vop) (ir2-block-prev block))
-	(last vop (ir2-block-last-vop block)))
-       (nil)
-    (assert (eq (ir2-block-block block) (ir2-block-block (vop-block vop))))
-    (do ((current last (vop-prev current)))
-	((null current))
-      (when (eq (vop-info-name (vop-info current)) name)
-	(return-from reverse-find-vop current)))))
-
-
-;;; Save-Complex-Writer-TN  --  Internal
-;;;
-;;;    For TNs that have other than one writer, we save the TN before each
-;;; call.  If a local call (MOVE-ARGS is :LOCAL-CALL), then we scan back for
-;;; the ALLOCATE-FRAME VOP, and emit the save there.  This is necessary because
-;;; in a self-recursive local call, the registers holding the current arguments
-;;; may get trashed by setting up the call arguments.  The ALLOCATE-FRAME VOP
-;;; marks a place at which the values are known to be good.
-;;;
-(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)))
-    (when (eq (tn-kind save) :specified-save)
-      (setf (tn-kind save) :save))
-    (assert (eq (tn-kind save) :save))
-    (emit-operand-load node block tn save
-		       (if (eq (vop-info-move-args (vop-info vop))
-			       :local-call)
-			   (reverse-find-vop 'allocate-frame vop)
-			   vop))
-    (emit-operand-load node block save tn next)))
-
-
-;;; FIND-SINGLE-WRITER  --  Internal
-;;;
-;;;    Return a VOP after which is an o.k. place to save the value of TN.  For
-;;; correctness, it is only required that this location be after any possible
-;;; write and before any possible restore location.
-;;;
-;;;    In practice, we return the unique writer VOP, but give up if the TN is
-;;; ever read by a VOP with MOVE-ARGS :LOCAL-CALL.  This prevents us from being
-;;; confused by non-tail local calls.
-;;;
-;;; When looking for writes, we have to ignore uses of MOVE-OPERAND, since they
-;;; will correspond to restores that we have already done.
-;;;
-(defun find-single-writer (tn)
-  (declare (type tn tn))
-  (do ((write (tn-writes tn) (tn-ref-next write))
-       (res nil))
-      ((null write)
-       (when (and res
-		  (loop for read = (tn-reads tn) then (tn-ref-next read)
-		        while read
-		        never (eq (vop-info-move-args
-				   (vop-info
-				    (tn-ref-vop read)))
-				  :local-call)))
-	 (tn-ref-vop res)))
-
-    (unless (eq (vop-info-name (vop-info (tn-ref-vop write)))
-		'move-operand)
-      (when res (return nil))
-      (setq res write))))
-
-
-;;; Save-Single-Writer-TN  --  Internal
-;;;
-;;;    Try to save TN at a single location.  If we succeed, return T, otherwise
-;;; NIL.
-;;;
-(defun save-single-writer-tn (tn)
-  (declare (type tn tn))
-  (let* ((old-save (tn-save-tn tn))
-	 (save (or old-save (pack-save-tn tn)))
-	 (writer (find-single-writer tn)))
-    (when (and writer
-	       (or (not old-save)
-		   (eq (tn-kind old-save) :specified-save)))
-      (emit-operand-load (vop-node writer) (vop-block writer)
-			 tn save (vop-next writer))
-      (setf (tn-kind save) :save-once)
-      t)))
-
-
-;;; RESTORE-SINGLE-WRITER-TN  --  Internal
-;;;
-;;;    Restore a TN with a :SAVE-ONCE save TN.
-;;;
-(defun restore-single-writer-tn (tn vop)
-  (declare (type tn) (type vop vop))
-  (let ((save (tn-save-tn tn)))
-    (assert (eq (tn-kind save) :save-once))
-    (emit-operand-load (vop-node vop) (vop-block vop) save tn (vop-next vop)))
-  (undefined-value))
-
-
-;;; BASIC-SAVE-TN  --  Internal
-;;;
-;;;    Save a single TN that needs to be saved, choosing save-once if
-;;; appropriate.  This is also called by SPILL-AND-PACK-LOAD-TN.
-;;;
-(defun basic-save-tn (tn vop)
-  (declare (type tn tn) (type vop vop))
-  (let ((save (tn-save-tn tn)))
-    (cond ((and save (eq (tn-kind save) :save-once))
-	   (restore-single-writer-tn tn vop))
-	  ((save-single-writer-tn tn)
-	   (restore-single-writer-tn tn vop))
-	  (t
-	   (save-complex-writer-tn tn 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 (and (sc-save-p (tn-sc tn))
-		   (not (eq (tn-kind tn) :component)))
-	  (basic-save-tn tn vop)))))
-
-  (undefined-value))
-
-
-;;;; Optimized saving:
-
-
-;;; SAVE-IF-NECESSARY  --  Internal
-;;;
-;;;    Save TN if it isn't a single-writer TN that has already been saved.  If
-;;; multi-write, we insert the save Before the specified VOP.  Context is a VOP
-;;; used to tell which node/block to use for the new VOP.
-;;;
-(defun save-if-necessary (tn before context)
-  (declare (type tn tn) (type (or vop null) before) (type vop context))
-  (let ((save (tn-save-tn tn)))
-    (when (eq (tn-kind save) :specified-save)
-      (setf (tn-kind save) :save))
-    (assert (member (tn-kind save) '(:save :save-once)))
-    (unless (eq (tn-kind save) :save-once)
-      (or (save-single-writer-tn tn)
-	  (emit-operand-load (vop-node context) (vop-block context)
-			     tn save before))))
-  (undefined-value))
-
-
-;;; RESTORE-TN  --  Internal
-;;;
-;;;    Load the TN from its save location, allocating one if necessary.  The
-;;; load is inserted Before the specifier VOP.  Context is a VOP used to tell
-;;; which node/block to use for the new VOP.
-;;;
-(defun restore-tn (tn before context)
-  (declare (type tn tn) (type (or vop null) before) (type vop context))
-  (let ((save (or (tn-save-tn tn) (pack-save-tn tn))))
-    (emit-operand-load (vop-node context) (vop-block context)
-		       save tn before))
-  (undefined-value))
-
-
-(eval-when (compile eval)
-
-;;; SAVE-NOTE-READ  --  Internal
-;;;
-;;;    Do stuff to note a read of TN, for OPTIMIZED-EMIT-SAVES-BLOCK.
-;;;
-(defmacro save-note-read (tn)
-  `(let* ((tn ,tn)
-	  (num (tn-number tn)))
-     (when (and (sc-save-p (tn-sc tn))
-		(zerop (sbit restores num))
-		(not (eq (tn-kind tn) :component)))
-       (setf (sbit restores num) 1)
-       (push tn restores-list))))
-
-); Eval-When (Compile Eval)
-
-;;; OPTIMIZED-EMIT-SAVES-BLOCK  --  Internal
-;;;
-;;;    Start scanning backward at the end of Block, looking which TNs are live
-;;; and looking for places where we have to save.  We manipulate two sets:
-;;; SAVES and RESTORES.
-;;;
-;;;    SAVES is a set of all the TNs that have to be saved because they are
-;;; restored after some call.  We normally delay saving until the beginning of
-;;; the block, but we must save immediately if we see a write of the saved TN.
-;;; We also immediately save all TNs and exit when we see a
-;;; NOTE-ENVIRONMENT-START VOP, since saves can't be done before the
-;;; environment is properly initialized.
-;;;
-;;;    RESTORES is a set of all the TNs read (and not written) between here and
-;;; the next call, i.e. the set of TNs that must be restored when we reach the
-;;; next (earlier) call VOP.   Unlike SAVES, this set is cleared when we do
-;;; the restoring after a call.  Any TNs that were in RESTORES are moved into
-;;; SAVES to ensure that they are saved at some point.
-;;;
-;;;    SAVES and RESTORES are represented using both a list and a bit-vector so
-;;; that we can quickly iterate and test for membership.  The incoming Saves
-;;; and Restores args are used for computing these sets (the initial contents
-;;; are ignored.)
-;;;
-;;;    When we hit a VOP with :COMPUTE-ONLY Save-P (an internal error
-;;; location), we pretend that all live TNs were read, unless (= speed 3), in
-;;; which case we mark all the TNs that are live but not restored as spilled.
-;;;
-(defun optimized-emit-saves-block (block saves restores)
-  (declare (type ir2-block block) (type simple-bit-vector saves restores))
-  (let ((1block (ir2-block-block block))
-	(saves-list ())
-	(restores-list ())
-	(skipping nil))
-    (clear-bit-vector saves)
-    (clear-bit-vector restores)
-    (do-live-tns (tn (ir2-block-live-in block) block)
-      (when (and (sc-save-p (tn-sc tn))
-		 (not (eq (tn-kind tn) :component)))
-	(let ((num (tn-number tn)))
-	  (setf (sbit restores num) 1)
-	  (push tn restores-list))))
-
-    (do ((block block (ir2-block-prev block))
-	 (prev nil block))
-	((not (eq (ir2-block-block block) 1block))
-	 (assert (not skipping))
-	 (dolist (save saves-list)
-	   (let ((start (ir2-block-start-vop prev)))
-	     (save-if-necessary save start start)))
-	 prev)
-      (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
-	  ((null vop))
-	(let ((info (vop-info vop)))
-	  (case (vop-info-name info)
-	    (allocate-frame
-	     (assert skipping)
-	     (setq skipping nil))
-	    (note-environment-start
-	     (assert (not skipping))
-	     (dolist (save saves-list)
-	       (save-if-necessary save (vop-next vop) vop))
-	     (return-from optimized-emit-saves-block block)))
-	  
-	  (unless skipping
-	    (do ((write (vop-results vop) (tn-ref-across write)))
-		((null write))
-	      (let* ((tn (tn-ref-tn write))
-		     (num (tn-number tn)))
-		(unless (zerop (sbit restores num))
-		  (setf (sbit restores num) 0)
-		  (setq restores-list (delete tn restores-list)))
-		(unless (zerop (sbit saves num))
-		  (setf (sbit saves num) 0)
-		  (save-if-necessary tn (vop-next vop) vop)
-		  (setq saves-list (delete tn saves-list))))))
-
-	  (case (vop-info-save-p info)
-	    ((t)
-	     (dolist (tn restores-list)
-	       (restore-tn tn (vop-next vop) vop)
-	       (let ((num (tn-number tn)))
-		 (when (zerop (sbit saves num))
-		   (push tn saves-list)
-		   (setf (sbit saves num) 1))))
-	     (setq restores-list nil)
-	     (clear-bit-vector restores))
-	    (:compute-only
-	     (cond ((policy (vop-node vop) (= speed 3))
-		    (do-live-tns (tn (vop-save-set vop) block)
-		      (when (zerop (sbit restores (tn-number tn)))
-			(note-spilled-tn tn vop))))
-		   (t
-		    (do-live-tns (tn (vop-save-set vop) block)
-		      (save-note-read tn))))))
-	  
-	  (if (eq (vop-info-move-args info) :local-call)
-	      (setq skipping t)
-	      (do ((read (vop-args vop) (tn-ref-across read)))
-		  ((null read))
-		(save-note-read (tn-ref-tn read)))))))))
-	
-
-;;; OPTIMIZED-EMIT-SAVES  --  Internal
-;;;
-;;;    Like EMIT-SAVES, only different.  We avoid redundant saving within the
-;;; block, and don't restore values that aren't used before the next call.
-;;; This function is just the top-level loop over the blocks in the component,
-;;; which locates blocks that need saving done.
-;;;
-(defun optimized-emit-saves (component)
-  (declare (type component component))
-  (let* ((gtn-count (1+ (ir2-component-global-tn-counter
-			 (component-info component))))
-	 (saves (make-array gtn-count :element-type 'bit))
-	 (restores (make-array gtn-count :element-type 'bit))
-	 (block (ir2-block-prev (block-info (component-tail component))))
-	 (head (block-info (component-head component))))
-    (loop
-      (when (eq block head) (return))
-      (when (do ((vop (ir2-block-start-vop block) (vop-next vop)))
-		((null vop) nil)
-	      (when (eq (vop-info-save-p (vop-info vop)) t)
-		(return t)))
-	(setq block (optimized-emit-saves-block block saves restores)))
-      (setq block (ir2-block-prev block)))))
-
-
-;;; ASSIGN-TN-COSTS  --  Internal
-;;;
-;;;    Iterate over the normal TNs, finding the cost of packing on the stack in
-;;; units of the number of references.  We count all references as +1, and
-;;; subtract out REGISTER-SAVE-PENALTY for each place where we would have to
-;;; save a register.
-;;;
-(defun assign-tn-costs (component)
-  (do-ir2-blocks (block component)
-    (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)
-	  (decf (tn-cost tn) (backend-register-save-penalty *backend*))))))
-  
-  (do ((tn (ir2-component-normal-tns (component-info component))
-	   (tn-next tn)))
-      ((null tn))
-    (let ((cost (tn-cost tn)))
-      (declare (fixnum cost))
-      (do ((ref (tn-reads tn) (tn-ref-next ref)))
-	  ((null ref))
-	(incf cost))
-      (do ((ref (tn-writes tn) (tn-ref-next ref)))
-	  ((null ref))
-	(incf cost))
-      (setf (tn-cost tn) cost))))
-
-
-;;;; 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.  Currently we always do, as this increases the
-;;; sucess of load-TN targeting.
-;;;
-(defun target-if-desirable (read write)
-  (declare (type tn-ref read write))
-  (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) (inline member))
-  (let* ((loc (tn-offset target))
-	 (target-sc (tn-sc target))
-	 (target-sb (sc-sb target-sc)))
-    (declare (type index loc))
-    (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))
-	     (zerop (mod loc (sc-alignment sc))))
-	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))
-		(declare (type index count))
-		(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.
-;;;
-;;; We also give up without bothering to wrap if the current size isn't large
-;;; enough to hold a single element of element-size without bothering to wrap.
-;;; If it doesn't fit this iteration, it won't fit next.
-;;; 
-;;; ### 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 &optional use-reserved-locs)
-  (declare (type tn tn) (type sc sc) (inline member))
-  (let* ((sb (sc-sb sc))
-	 (element-size (sc-element-size sc))
-	 (alignment (sc-alignment sc))
-	 (size (finite-sb-current-size sb))
-	 (start-offset (finite-sb-last-offset sb)))
-    (let ((current-start (* (the index (ceiling start-offset alignment))
-			    alignment))
-	  (wrap-p nil))
-      (declare (type index current-start))
-      (loop
-	(when (> (+ current-start element-size) size)
-	  (cond ((or wrap-p (> element-size size))
-		 (return nil))
-		(t
-		 (setq current-start 0)
-		 (setq wrap-p t))))
-
-	(if (or (eq (sb-kind sb) :unbounded)
-		(and (member current-start (sc-locations sc))
-		     (or use-reserved-locs
-			 (not (member current-start
-				      (sc-reserve-locations sc))))))
-	    (dotimes (i element-size
-			(return-from select-location current-start))
-	      (let ((offset (+ current-start i)))
-		(when (offset-conflicts-in-sb tn sb offset)
-		  (setq current-start
-			(* (the index (ceiling (1+ offset) alignment))
-			   alignment))
-		  (return))))
-	    (incf current-start alignment))))))
-
-
-;;;; 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*)
-
-;;; If we unpack some TNs, then we mark all affected blocks by sticking them in
-;;; this hash-table.  This is initially null.  We create the hashtable if we do
-;;; any unpacking.
-;;;
-(defvar *repack-blocks*)
-(declaim (type (or hash-table null) *repack-blocks*))
-
-;;; 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 (backend-sb-list *backend*))
-    (when (eq (sb-kind sb) :finite)
-      (fill (finite-sb-live-tns sb) nil)))
-
-  (do-live-tns (tn (ir2-block-live-in block) block)
-    (let* ((sc (tn-sc tn))
-	   (sb (sc-sb sc)))
-      (when (eq (sb-kind sb) :finite)
-	(loop for offset from (tn-offset tn)
-	      repeat (sc-element-size sc) do
-	  (setf (svref (finite-sb-live-tns sb) offset) 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, excluding results of the VOP.  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)
-  (declare (type ir2-block block) (type vop vop))
-  (unless (eq block *live-block*)
-    (init-live-tns block))
-  
-  (do ((current *live-vop* (vop-prev current)))
-      ((eq current vop)
-       (do ((res (vop-results vop) (tn-ref-across res)))
-	   ((null res))
-	 (let* ((tn (tn-ref-tn res))
-		(sc (tn-sc tn))
-		(sb (sc-sb sc)))
-	   (when (eq (sb-kind sb) :finite)
-	     (loop for offset from (tn-offset tn)
-	           repeat (sc-element-size sc) do
-	       (setf (svref (finite-sb-live-tns sb) offset) nil))))))
-    (do ((ref (vop-refs current) (tn-ref-next-ref ref)))
-	((null ref))
-      (let ((ltn (tn-ref-load-tn ref)))
-	(when ltn
-	  (let* ((sc (tn-sc ltn))
-		 (sb (sc-sb sc)))
-	    (when (eq (sb-kind sb) :finite)
-	      (let ((tns (finite-sb-live-tns sb)))
-		(loop for offset from (tn-offset ltn)
-		      repeat (sc-element-size sc) do
-		  (assert (null (svref tns offset)))))))))
-
-      (let* ((tn (tn-ref-tn ref))
-	     (sc (tn-sc tn))
-	     (sb (sc-sb sc)))
-	(when (eq (sb-kind sb) :finite)
-	  (let ((tns (finite-sb-live-tns sb)))
-	    (loop for offset from (tn-offset tn)
-	          repeat (sc-element-size sc) do
-	      (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))
-
-
-;;; LOAD-TN-OFFSET-CONFLICTS-IN-SB  --  Internal
-;;;
-;;;    Kind of like Offset-Conflicts-In-SB, except that it uses the VOP refs to
-;;; determine whether a Load-TN for OP could be packed in the specified
-;;; location, disregarding conflicts with TNs not referenced by this VOP.
-;;; There is a conflict if either:
-;;;  1] The reference is a result, and the same location is either:
-;;;     -- Used by some other result.
-;;;     -- Used in any way after the reference (exclusive).
-;;;  2] The reference is an argument, and the same location is either:
-;;;     -- Used by some other argument.
-;;;     -- Used in any way before the reference (exclusive).
-;;;
-;;;    In 1 (and 2) above, the first bullet corresponds to result-result
-;;; (and argument-argument) conflicts.  We need this case because there aren't
-;;; any TN-REFs to represent the implicit reading of results or writing of
-;;; arguments.
-;;;
-;;;    The second bullet corresponds conflicts with temporaries or between
-;;; arguments and results.
-;;;
-;;;    We consider both the TN-REF-TN and the TN-REF-LOAD-TN (if any) to be
-;;; referenced simultaneously and in the same way.  This causes load-TNs to
-;;; appear live to the beginning (or end) of the VOP, as appropriate.
-;;;
-;;; We return a conflicting TN if there is a conflict.
-;;;
-(defun load-tn-offset-conflicts-in-sb (op sb offset)
-  (declare (type tn-ref op) (type finite-sb sb) (type index offset))
-  (assert (eq (sb-kind sb) :finite))
-  (let ((vop (tn-ref-vop op)))
-    (labels ((tn-overlaps (tn)
-	       (let ((sc (tn-sc tn))
-		     (tn-offset (tn-offset tn)))
-		 (when (and (eq (sc-sb sc) sb)
-			    (<= tn-offset offset)
-			    (< offset
-			       (the index
-				    (+ tn-offset (sc-element-size sc)))))
-		   tn)))
-	     (same (ref)
-	       (let ((tn (tn-ref-tn ref))
-		     (ltn (tn-ref-load-tn ref)))
-		 (or (tn-overlaps tn)
-		     (and ltn (tn-overlaps ltn)))))
-	     (is-op (ops)
-	       (do ((ops ops (tn-ref-across ops)))
-		   ((null ops) nil)
-		 (let ((found (same ops)))
-		   (when (and found (not (eq ops op)))
-		     (return found)))))
-	     (is-ref (refs end)
-	       (do ((refs refs (tn-ref-next-ref refs)))
-		   ((eq refs end) nil)
-		 (let ((found (same refs)))
-		 (when found (return found))))))
-      (declare (inline is-op is-ref tn-overlaps))
-      (if (tn-ref-write-p op)
-	  (or (is-op (vop-results vop))
-	      (is-ref (vop-refs vop) op))
-	  (or (is-op (vop-args vop))
-	      (is-ref (tn-ref-next-ref op) nil))))))
-
-
-;;; LOAD-TN-CONFLICTS-IN-SC  --  Internal
-;;;
-;;;    Iterate over all the elements in the SB that would be allocated by
-;;; allocating a TN in SC at Offset, checking for conflict with load-TNs or
-;;; other TNs (live in the LIVE-TNS, which must be set up.)  We also return
-;;; true if there aren't enough locations after Offset to hold a TN in SC.
-;;; If Ignore-Live is true, then we ignore the live-TNs, considering only
-;;; references within Op's VOP.
-;;;
-;;;    We return a conflicting TN, or :OVERFLOW if the TN won't fit.
-;;;
-(defun load-tn-conflicts-in-sc (op sc offset ignore-live)
-  (let* ((sb (sc-sb sc))
-	 (size (finite-sb-current-size sb)))
-    (loop for i from offset
-          repeat (sc-element-size sc)
-          thereis (or (when (>= i size) :overflow)
-		      (and (not ignore-live)
-			   (svref (finite-sb-live-tns sb) offset))
-		      (load-tn-offset-conflicts-in-sb op sb i)))))
-
-
-;;; 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.
-;;;
-;;;    We require the target to be in SC (and not merely to overlap with SC).
-;;; This prevents SC information from being lost in load TNs (we won't pack a
-;;; load TN in ANY-REG when it is targeted to a DESCRIPTOR-REG.)  This
-;;; shouldn't hurt the code as long as all relevant overlapping SCs are allowed
-;;; in the operand SC restriction.
-;;;
-(defun find-load-tn-target (op sc)
-  (declare (inline member))
-  (let ((target (tn-ref-target op)))
-    (when target
-      (let* ((tn (tn-ref-tn target))
-	     (loc (tn-offset tn)))
-	(if (and (eq (tn-sc tn) sc)
-		 (member (the index loc) (sc-locations sc))
-		 (not (load-tn-conflicts-in-sc op sc loc nil)))
-	    loc
-	    nil)))))
-
-
-;;; Select-Load-Tn-Location  --  Internal
-;;;
-;;;    Select a legal location for a load TN for Op in SC.  We just iterate
-;;; over the SC's 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))
-  (dolist (loc (sc-locations sc) nil)
-    (unless (load-tn-conflicts-in-sc op sc loc nil)
-      (return loc))))
-
-
-(defevent unpack-tn "Unpacked a TN to satisfy operand SC restriction.")
-
-;;; UNPACK-TN  --  Internal
-;;;
-;;;    Make TN's location the same as for its save TN (allocating a save TN if
-;;; necessary.)  Delete any save/restore code that has been emitted thus far.
-;;; Mark all blocks containing references as needing to be repacked.
-;;;
-(defun unpack-tn (tn)
-  (event unpack-tn)
-  (let ((stn (or (tn-save-tn tn)
-		 (pack-save-tn tn))))
-    (setf (tn-sc tn) (tn-sc stn))
-    (setf (tn-offset tn) (tn-offset stn))
-    (flet ((zot (refs)
-	     (do ((ref refs (tn-ref-next ref)))
-		 ((null ref))
-	       (let ((vop (tn-ref-vop ref)))
-		 (if (eq (vop-info-name (vop-info vop)) 'move-operand)
-		     (delete-vop vop)
-		     (setf (gethash (vop-block vop) *repack-blocks*) t))))))
-      (zot (tn-reads tn))
-      (zot (tn-writes tn))))
-
-  (undefined-value))
-
-(defevent unpack-fallback "Unpacked some random operand TN.")
-
-;;; UNPACK-FOR-LOAD-TN  --  Internal
-;;;
-;;;     Called by Pack-Load-TN where there isn't any location free that we can
-;;; pack into.  What we do is move some live TN in one of the specified SCs to
-;;; memory, then mark this block all blocks that reference the TN as needing
-;;; repacking.  If we suceed, we throw to UNPACKED-TN.  If we fail, we return
-;;; NIL.
-;;;
-;;; We can unpack any live TN that appears in the NORMAL-TNs list (isn't wired
-;;; or restricted.)  We prefer to unpack TNs that are not used by the VOP.  If
-;;; we can't find any such TN, then we unpack some random argument or result
-;;; TN.  The only way we can fail is if all locations in SC are used by
-;;; load-TNs or temporaries in VOP.
-;;;
-(defun unpack-for-load-tn (sc op)
-  (declare (type sc sc) (type tn-ref op))
-  (let ((sb (sc-sb sc))
-	(normal-tns (ir2-component-normal-tns
-		     (component-info *compile-component*)))
-	(node (vop-node (tn-ref-vop op)))
-	(fallback nil))
-    (flet ((unpack-em (victims)
-	     (unless *repack-blocks*
-	       (setq *repack-blocks* (make-hash-table :test #'eq)))
-	     (setf (gethash (vop-block (tn-ref-vop op)) *repack-blocks*) t)
-	     (dolist (victim victims)
-	       (event unpack-tn node)
-	       (unpack-tn victim))
-	     (throw 'unpacked-tn nil)))
-      (dolist (loc (sc-locations sc))
-	(declare (type index loc))
-	(block SKIP
-	  (collect ((victims nil adjoin))
-	    (loop for i from loc
-	      as victim = (svref (finite-sb-live-tns sb) i)
-	      repeat (sc-element-size sc) do
-	      (when victim
-		(unless (find-in #'tn-next victim normal-tns)
-		  (return-from SKIP))
-		(victims victim)))
-	    
-	    (let ((conf (load-tn-conflicts-in-sc op sc loc t)))
-	      (cond ((not conf)
-		     (unpack-em (victims)))
-		    ((eq conf :overflow))
-		    ((not fallback)
-		     (cond ((find conf (victims))
-			    (setq fallback (victims)))
-			   ((find-in #'tn-next conf normal-tns)
-			    (setq fallback (list conf))))))))))
-      
-      (when fallback
-	(event unpack-fallback node)
-	(unpack-em fallback))))
-
-  nil)
-
-
-;;; Pack-Load-TN  --  Internal
-;;;
-;;;    Try to pack a load TN in the SCs indicated by Load-SCs.  If we run out
-;;; of SCs, then we unpack some TN and try again.  We return the packed load
-;;; TN.
-;;;
-;;; Note: we allow a Load-TN to be packed in the target location even if that
-;;; location is in a SC not allowed by the primitive type.  (The SC must still
-;;; be allowed by the operand restriction.)  This makes move VOPs more
-;;; efficient, since we won't do a move from the stack into a non-descriptor
-;;; any-reg though a descriptor argument load-TN.  This does give targeting
-;;; some real semantics, making it not a pure advisory to pack.  It allows pack
-;;; to do some packing it wouldn't have done before.
-;;;
-(defun pack-load-tn (load-scs op)
-  (declare (type sc-vector load-scs) (type tn-ref op))
-  (let ((vop (tn-ref-vop op)))
-    (compute-live-tns (vop-block vop) vop))
-  
-  (let* ((tn (tn-ref-tn op))
-	 (ptype (tn-primitive-type tn))
-	 (scs (svref load-scs (sc-number (tn-sc tn)))))
-    (let ((current-scs scs)
-	  (allowed ()))
-      (loop
-	(cond
-	 ((null current-scs)
-	  (unless allowed
-	    (no-load-scs-allowed-by-primitive-type-error op))
-	  (dolist (sc allowed)
-	    (unpack-for-load-tn sc op))
-	  (failed-to-pack-load-tn-error allowed op))
-	(t
-	 (let* ((sc (svref (backend-sc-numbers *backend*) (pop current-scs)))
-		(target (find-load-tn-target op sc)))
-	   (when (or target (sc-allowed-by-primitive-type sc ptype))
-	     (let ((loc (or target
-			    (select-load-tn-location op sc))))
-	       (when loc
-		 (let ((res (make-tn 0 :load nil sc)))
-		   (setf (tn-offset res) loc)
-		   (return res))))
-	     (push sc allowed)))))))))
-
-
-;;; Check-Operand-Restrictions  --  Internal
-;;;
-;;;    Scan a list of load-SCs vectors and a list of TN-Refs threaded by
-;;; TN-Ref-Across.  When we find a reference whose TN doesn't satisfy the
-;;; restriction, we pack a Load-TN and load the operand into it.  If a load-tn
-;;; has already been allocated, we can assume that the restriction is
-;;; satisfied.
-;;;
-(proclaim '(inline check-operand-restrictions))
-(defun check-operand-restrictions (scs ops)
-  (declare (list scs) (type (or tn-ref null) ops))
-  (do ((scs scs (cdr scs))
-       (op ops (tn-ref-across op)))
-      ((null scs))
-    (let* ((load-tn (tn-ref-load-tn op))
-	   (load-scs (svref (car scs)
-			    (sc-number (tn-sc (or load-tn (tn-ref-tn op)))))))
-      (if load-tn
-	  (assert (eq load-scs t))
-	  (unless (eq load-scs t)
-	    (setf (tn-ref-load-tn op) (pack-load-tn (car scs) 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)
-  (catch 'unpacked-tn
-    (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
-	((null vop))
-      (let ((info (vop-info vop)))
-	(check-operand-restrictions (vop-info-result-load-scs info)
-				    (vop-results vop))
-	(check-operand-restrictions (vop-info-arg-load-scs info)
-				    (vop-args vop)))))
-  (undefined-value))
-
-
-;;; Pack-TN  --  Internal
-;;;
-;;;    Attempt to pack TN in all possible SCs, first in the SC chosen by
-;;; representation selection, then in the alternate SCs in the order they were
-;;; specified in the SC definition.  If the TN-COST is negative, then we
-;;; don't attempt to pack in SCs that must be saved.  If Restricted, then we
-;;; can only pack in TN-SC, not in any Alternate-SCs.
-;;;
-;;;    If we are attempting to pack in the SC of the save TN for a TN with a
-;;; :SPECIFIED-SAVE TN, then we pack in that location, instead of allocating a
-;;; new stack location.
-;;;
-(defun pack-tn (tn restricted)
-  (declare (type tn tn))
-  (let* ((original (original-tn tn))
-	 (fsc (tn-sc tn))
-	 (alternates (unless restricted (sc-alternate-scs fsc)))
-	 (save (tn-save-tn tn))
-	 (specified-save-sc
-	  (when (and save
-		     (eq (tn-kind save) :specified-save))
-	    (tn-sc save))))
-
-    (do ((sc fsc (pop alternates)))
-	((null sc)
-	 (failed-to-pack-error tn restricted))
-      (when (eq sc specified-save-sc)
-	(unless (tn-offset save)
-	  (pack-tn save nil))
-	(setf (tn-offset tn) (tn-offset save))
-	(setf (tn-sc tn) (tn-sc save))
-	(return))
-      (when (or restricted
-		(not (and (minusp (tn-cost tn)) (sc-save-p sc))))
-	(let ((loc (or (find-ok-target-offset original sc)
-		       (select-location original sc)
-		       (and restricted
-			    (select-location original sc t))
-		       (when (eq (sb-kind (sc-sb sc)) :unbounded)
-			 (grow-sc sc)
-			 (or (select-location original sc)
-			     (error "Failed to pack after growing SC?"))))))
-	  (when loc
-	    (add-location-conflicts original sc loc)
-	    (setf (tn-sc tn) sc)
-	    (setf (tn-offset tn) loc)
-	    (return))))))
-	    
-  (undefined-value))
-
-
-;;; 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.
-;;;
-;;; ### Checking for conflicts is disabled for :SPECIFIED-SAVE TNs.  This is
-;;; kind of a hack to make specifying wired stack save locations for local call
-;;; arguments (such as OLD-FP) work, since the caller and callee OLD-FP save
-;;; locations may conflict when the save locations don't really (due to being
-;;; in different frames.)
-;;;
-(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)))
-	 (original (original-tn tn)))
-    (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 (and (not (eq (tn-kind tn) :specified-save))
-	       (conflicts-in-sc original sc offset))
-      (error "~S wired to a location that it conflicts with." tn))
-    (add-location-conflicts original sc offset)))
-
-
-(defevent repack-block "Repacked a block due to TN unpacking.")
-
-;;; Pack  --  Interface
-;;;
-(defun pack (component)
-  (assert (not *in-pack*))
-  (let ((*in-pack* t)
-	(optimize (policy nil (or (>= speed cspeed) (>= space cspeed))))
-	(2comp (component-info component)))
-    (init-sb-vectors component)
-    ;;
-    ;; Call the target functions.
-    (do-ir2-blocks (block component)
-      (do ((vop (ir2-block-start-vop block) (vop-next vop)))
-	  ((null vop))
-	(let ((target-fun (vop-info-target-function (vop-info vop))))
-	  (when target-fun
-	    (funcall target-fun vop)))))
-    
-    ;;
-    ;; Pack wired TNs first.
-    (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn)))
-	((null tn))
-      (pack-wired-tn tn))
-    ;;
-    ;; Pack restricted component TNs.
-    (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
-	((null tn))
-      (when (eq (tn-kind tn) :component)
-	(pack-tn tn t)))
-    ;;
-    ;; Pack other restricted TNs.
-    (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
-	((null tn))
-      (unless (tn-offset tn)
-	(pack-tn tn t)))
-    ;;
-    ;; Assign costs to normal TNs so we know which ones should always be
-    ;; packed on the stack.
-    (when (and optimize pack-assign-costs)
-      (assign-tn-costs component))
-    ;;
-    ;; Pack normal TNs in the order that they appear in the code.  This
-    ;; should have some tendency to pack important TNs first, since control
-    ;; analysis favors the drop-through.  This should also help targeting,
-    ;; since we will pack the target TN soon after we determine the location
-    ;; of the targeting TN.
-    (do-ir2-blocks (block component)
-      (let ((ltns (ir2-block-local-tns block)))
-	(do ((i (1- (ir2-block-local-tn-count block)) (1- i)))
-	    ((minusp i))
-	  (declare (fixnum i))
-	  (let ((tn (svref ltns i)))
-	    (unless (or (null tn) (eq tn :more) (tn-offset tn))
-	      (pack-tn tn nil))))))
-    ;;
-    ;; Pack any leftover normal TNs.  This is to deal with :MORE TNs, which
-    ;; could possibly not appear in any local TN map.
-    (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
-	((null tn))
-      (unless (tn-offset tn)
-	(pack-tn tn nil)))
-    ;;
-    ;; Do load TN packing and emit saves.
-    (let ((*repack-blocks* nil))
-      (let ((*live-block* nil)
-	    (*live-vop* nil))
-	(cond ((and optimize pack-optimize-saves)
-	       (optimized-emit-saves component)
-	       (do-ir2-blocks (block component)
-		 (pack-load-tns block)))
-	      (t
-	       (do-ir2-blocks (block component)
-		 (emit-saves block)
-		 (pack-load-tns block)))))
-      (when *repack-blocks*
-	(loop
-	  (when (zerop (hash-table-count *repack-blocks*)) (return))
-	  (let ((*live-block* nil)
-		(*live-vop* nil))
-	    (maphash #'(lambda (block v)
-			 (declare (ignore v))
-			 (remhash block *repack-blocks*)
-			 (event repack-block)
-			 (pack-load-tns block))
-		     *repack-blocks*)))))
-
-    (undefined-value)))
diff --git a/compiler/profile.lisp b/compiler/profile.lisp
deleted file mode 100644
index 34319b5cba9bda24887feff0e5ddc5920c9a7be3..0000000000000000000000000000000000000000
--- a/compiler/profile.lisp
+++ /dev/null
@@ -1,88 +0,0 @@
-;;; -*- Package: C -*-
-(in-package "C")
-
-(use-package "PROFILE")
-(declaim (ftype (function (t t t) *) ir1-top-level))
-(declaim (ftype (function (t) *) find-initial-dfo))
-(declaim (ftype (function (t) *) find-dfo))
-(declaim (ftype (function (t) *) local-call-analyze))
-(declaim (ftype (function (t) *) delete-block))
-(declaim (ftype (function (t) *) join-successor-if-possible))
-(declaim (ftype (function (t) *) ir1-optimize-block))
-(declaim (ftype (function (t) *) flush-dead-code))
-(declaim (ftype (function (t) *) generate-type-checks))
-(declaim (ftype (function (t) *) constraint-propagate))
-(declaim (ftype (function (t) *) pre-environment-analyze-top-level))
-(declaim (ftype (function (t) *) environment-analyze))
-(declaim (ftype (function (t) *) gtn-analyze))
-(declaim (ftype (function (t t) *) control-analyze))
-(declaim (ftype (function (t) *) ltn-analyze))
-(declaim (ftype (function (t) *) stack-analyze))
-(declaim (ftype (function (t) *) ir2-convert))
-(declaim (ftype (function (t) *) copy-propagate))
-(declaim (ftype (function (t) *) select-representations))
-(declaim (ftype (function (t) *) lifetime-analyze))
-(declaim (ftype (function (t) *) delete-unreferenced-tns))
-(declaim (ftype (function (t) *) pack))
-(declaim (ftype (function (t) *) generate-code))
-(declaim (ftype (function (t t t t t t) *) fasl-dump-component))
-(declaim (ftype (function (t) *) clear-ir2-info))
-(declaim (ftype (function (t) *) macerate-ir1-component))
-(declaim (ftype (function (t) *) merge-top-level-lambdas))
-(declaim (ftype (function (t t) *) note-failed-optimization))
-(declaim (ftype (function () *) clear-stuff))
-(declaim (ftype (function (t) *) read-source-form))
-(declaim (ftype (function (t t) *) fasl-dump-source-info))
-(declaim (ftype (function (t t) *) fasl-dump-top-level-lambda-call))
-
-(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
-	 pre-environment-analyze-top-level
-	 environment-analyze
-	 gtn-analyze
-	 control-analyze
-	 ltn-analyze
-	 stack-analyze
-	 ir2-convert
-	 copy-propagate
-	 select-representations
-
-	 lifetime-analyze
-#|
-	 lifetime-pre-pass
-	 lifetime-flow-analysis
-	 reset-current-conflict
-	 lifetime-post-pass
-|#
-	 delete-unreferenced-tns
-	 pack
-#|
-	 pack-wired-tn
-	 pack-tn
-	 pack-load-tns
-	 assign-tn-costs
-	 optimized-emit-saves
-	 emit-saves
-|#
-	 generate-code
-	 fasl-dump-component
-	 clear-ir2-info
-	 macerate-ir1-component
-	 merge-top-level-lambdas
-	 note-failed-optimization
-	 clear-stuff
-	 read-source-form
-	 fasl-dump-source-info
-	 fasl-dump-top-level-lambda-call
-;	 check-life-consistency
-;	 check-ir1-consistency
-;	 check-ir2-consistency
-	 )
diff --git a/compiler/pseudo-vops.lisp b/compiler/pseudo-vops.lisp
deleted file mode 100644
index 2b23852ed7531321757c367be292d2d8a5c95883..0000000000000000000000000000000000000000
--- a/compiler/pseudo-vops.lisp
+++ /dev/null
@@ -1,43 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/pseudo-vops.lisp,v 1.7 1992/06/04 16:13:14 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains definitions of VOPs used as internal markers by the
-;;; compiler.  Since they don't emit any code, they should be portable. 
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; Notes the place at which the environment is properly initialized, for
-;;; debug-info purposes.
-;;;
-(define-vop (note-environment-start)
-  (:info start-lab)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 0
-    (emit-label start-lab)
-    (note-debug-location vop start-lab :non-local-entry)))
-
-
-;;; Call a move function.  Used for register save/restore and spilling.
-;;;
-(define-vop (move-operand)
-  (:args (x))
-  (:results (y))
-  (:info name)
-  (:vop-var vop)
-  (:generator 0
-    (funcall (symbol-function name) vop x y)))
-
diff --git a/compiler/represent.lisp b/compiler/represent.lisp
deleted file mode 100644
index 11d958a61e9f5a2c9a03f0c29b8c46de88350b1b..0000000000000000000000000000000000000000
--- a/compiler/represent.lisp
+++ /dev/null
@@ -1,722 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/represent.lisp,v 1.32 1992/02/24 05:50:28 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the implementation independent code for the
-;;; representation selection phase in the compiler.  Representation selection
-;;; decides whether to use non-descriptor representations for objects and emits
-;;; the appropriate representation-specific move and coerce vops.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Error routines:
-;;;
-;;;    Problems in the VM definition often show up here, so we try to be as
-;;; implementor-friendly as possible.
-;;;
-
-;;; GET-OPERAND-INFO  --  Interface
-;;;
-;;;    Given a TN ref for a VOP argument or result, return these values:
-;;; 1] True if the operand is an argument, false otherwise.
-;;; 2] The ordinal position of the operand.
-;;; 3] True if the operand is a more operand, false otherwise.
-;;; 4] The costs for this operand.
-;;; 5] The load-scs vector for this operand (NIL if more-p.)
-;;; 6] True if the costs or SCs in the VOP-INFO are inconsistent with the
-;;;    currently record ones.
-;;;
-(defun get-operand-info (ref)
-  (declare (type tn-ref ref))
-  (let* ((arg-p (not (tn-ref-write-p ref)))
-	 (vop (tn-ref-vop ref))
-	 (info (vop-info vop)))
-    (flet ((frob (refs costs load more-cost)
-	     (do ((refs refs (tn-ref-across refs))
-		  (costs costs (cdr costs))
-		  (load load (cdr load))
-		  (n 0 (1+ n)))
-		 ((null costs)
-		  (assert more-cost)
-		  (values arg-p
-			  (+ n
-			     (or (position-in #'tn-ref-across ref refs)
-				 (error "Couldn't find REF?"))
-			     1)
-			  t
-			  more-cost
-			  nil
-			  nil))
-	       (when (eq refs ref)
-		 (let ((parse (vop-parse-or-lose (vop-info-name info)
-						 *backend*)))
-		   (multiple-value-bind
-		       (ccosts cscs)
-		       (compute-loading-costs
-			(elt (if arg-p
-				 (vop-parse-args parse)
-				 (vop-parse-results parse))
-			     n)
-			arg-p)
-		     
-		     (return
-		      (values arg-p
-			      (1+ n)
-			      nil
-			      (car costs)
-			      (car load)
-			      (not (and (equalp ccosts (car costs))
-					(equalp cscs (car load))))))))))))
-      (if arg-p
-	  (frob (vop-args vop) (vop-info-arg-costs info)
-	        (vop-info-arg-load-scs info)
-	        (vop-info-more-arg-costs info))
-	  (frob (vop-results vop) (vop-info-result-costs info)
-	        (vop-info-result-load-scs info)
-	        (vop-info-more-result-costs info))))))
-
-
-;;; LISTIFY-RESTRICTIONS  --  Interface
-;;;
-;;;    Convert a load-costs vector to the list of SCs allowed by the operand
-;;; restriction.
-;;;
-(defun listify-restrictions (restr)
-  (declare (type sc-vector restr))
-  (collect ((res))
-    (dotimes (i sc-number-limit)
-      (when (eq (svref restr i) t)
-	(res (svref (backend-sc-numbers *backend*) i))))
-    (res)))
-
-    
-;;; BAD-COSTS-ERROR  --  Internal
-;;;
-;;;    Try to give a helpful error message when Ref has no cost specified for
-;;; some SC allowed by the TN's primitive-type.
-;;;
-(defun bad-costs-error (ref)
-  (declare (type tn-ref ref))
-  (let* ((tn (tn-ref-tn ref))
-	 (ptype (tn-primitive-type tn)))
-    (multiple-value-bind (arg-p pos more-p costs load-scs incon)
-			 (get-operand-info ref)
-      (collect ((losers))
-	(dolist (scn (primitive-type-scs ptype))
-	  (unless (svref costs scn)
-	    (losers (svref (backend-sc-numbers *backend*) scn))))
-
-	(unless (losers)
-	  (error "Representation selection flamed out for no obvious reason.~@
-	          Try again after recompiling the VM definition."))
-	
-	(error "~S is not valid as the ~:R ~:[result~;argument~] to the~@
-	        ~S VOP, since the TN's primitive type ~S allows SCs:~%  ~S~@
-		~:[which cannot be coerced or loaded into the allowed SCs:~
-		~%  ~S~;~*~]~:[~;~@
-		Current cost info inconsistent with that in effect at compile ~
-		time.  Recompile.~%Compilation order may be incorrect.~]"
-	       tn pos arg-p
-	       (template-name (vop-info (tn-ref-vop ref)))
-	       (primitive-type-name ptype)
-	       (mapcar #'sc-name (losers))
-	       more-p
-	       (unless more-p
-		 (mapcar #'sc-name (listify-restrictions load-scs)))
-	       incon)))))
-
-
-;;; BAD-COERCE-ERROR  --  Internal
-;;;
-;;;    Try to give a helpful error message when we fail to do a coercion
-;;; for some reason.
-;;;
-(defun bad-coerce-error (op)
-  (declare (type tn-ref op))
-  (let* ((op-tn (tn-ref-tn op))
-	 (op-sc (tn-sc op-tn))
-	 (op-scn (sc-number op-sc))
-	 (ptype (tn-primitive-type op-tn))
-	 (write-p (tn-ref-write-p op)))
-    (multiple-value-bind (arg-p pos more-p costs load-scs incon)
-			 (get-operand-info op)
-      (declare (ignore costs more-p))
-      (collect ((load-lose)
-		(no-move-scs)
-		(move-lose))
-	(dotimes (i sc-number-limit)
-	  (let ((i-sc (svref (backend-sc-numbers *backend*) i)))
-	    (when (eq (svref load-scs i) t)
-	      (cond ((not (sc-allowed-by-primitive-type i-sc ptype))
-		     (load-lose i-sc))
-		    ((not (find-move-vop op-tn write-p i-sc ptype
-					 #'sc-move-vops))
-		     (let ((vops (if write-p
-				     (svref (sc-move-vops op-sc) i)
-				     (svref (sc-move-vops i-sc) op-scn))))
-		       (if vops
-			   (dolist (vop vops) (move-lose (template-name vop)))
-			   (no-move-scs i-sc))))
-		    (t
-		     (error "Representation selection flamed out for no ~
-		             obvious reason."))))))
-	
-	(unless (or (load-lose) (no-move-scs) (move-lose))
-	  (error "Representation selection flamed out for no obvious reason.~@
-	          Try again after recompiling the VM definition."))
-
-	(error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~
-	        ~%  ~S~%Primitive type: ~S~@
-		SC restrictions:~%  ~S~@
-		~@[The primitive type disallows these loadable SCs:~%  ~S~%~]~
-		~@[No move VOPs are defined to coerce to these allowed SCs:~
-		~%  ~S~%~]~
-		~@[These move VOPs couldn't be used due to operand type ~
-		restrictions:~%  ~S~%~]~
-		~:[~;~@
-		Current cost info inconsistent with that in effect at compile ~
-		time.  Recompile.~%Compilation order may be incorrect.~]"
-	       op-tn pos arg-p
-	       (template-name (vop-info (tn-ref-vop op)))
-	       (primitive-type-name ptype)
-	       (mapcar #'sc-name (listify-restrictions load-scs))
-	       (mapcar #'sc-name (load-lose))
-	       (mapcar #'sc-name (no-move-scs))
-	       (move-lose)
-	       incon)))))
-
-
-;;; BAD-MOVE-ARG-ERROR  --  Internal
-;;;
-(defun bad-move-arg-error (val pass)
-  (declare (type tn val pass))
-  (error "No :MOVE-ARGUMENT VOP defined to move ~S (SC ~S) to ~
-          ~S (SC ~S.)"
-	 val (sc-name (tn-sc val))
-	 pass (sc-name (tn-sc pass))))
-
-
-;;;; VM Consistency Checking:
-;;;
-;;;    We do some checking of the consistency of the VM definition at load
-;;; time.
-
-;;; CHECK-MOVE-FUNCTION-CONSISTENCY  --  Interface
-;;;
-(defun check-move-function-consistency ()
-  (dotimes (i sc-number-limit)
-    (let ((sc (svref (backend-sc-numbers *backend*) i)))
-      (when sc
-	(let ((moves (sc-move-functions sc)))
-	  (dolist (const (sc-constant-scs sc))
-	    (unless (svref moves (sc-number const))
-	      (warn "No move function defined to load SC ~S from constant ~
-	             SC ~S."
-		    (sc-name sc) (sc-name const))))
-	  
-	  (dolist (alt (sc-alternate-scs sc))
-	    (unless (svref moves (sc-number alt))
-	      (warn "No move function defined to load SC ~S from alternate ~
-	             SC ~S."
-		    (sc-name sc) (sc-name alt)))
-	    (unless (svref (sc-move-functions alt) i)
-	      (warn "No move function defined to save SC ~S to alternate ~
-	             SC ~S."
-		    (sc-name sc) (sc-name alt)))))))))
-
-
-;;;; Representation selection:
-
-;;; VOPs that we ignore in initial cost computation.  We ignore SET in the
-;;; hopes that nobody is setting specials inside of loops.  We ignore
-;;; TYPE-CHECK-ERROR because we don't want the possibility of error to bias the
-;;; result.  Notes are suppressed for T-C-E as well, since we don't need to
-;;; worry about the efficiency of that case.
-;;;
-(defconstant ignore-cost-vops '(set type-check-error))
-(defconstant suppress-note-vops '(type-check-error))
-
-(declaim (start-block select-tn-representation))
-
-;;; ADD-REPRESENTATION-COSTS  --  Local
-;;;
-;;;    We special-case the move VOP, since using this costs for the normal MOVE
-;;; would spuriously encourage descriptor representations.  We won't actually
-;;; need to coerce to descriptor and back, since we will replace the MOVE with
-;;; a specialized move VOP.  What we do is look at the other operand.  If its
-;;; representation has already been chosen (e.g.  if it is wired), then we use
-;;; the appropriate move costs, otherwise we just ignore the references.
-;;;
-(defun add-representation-costs (refs scs costs
-				      ops-slot costs-slot more-costs-slot
-				      write-p)
-  (do ((ref refs (tn-ref-next ref)))
-      ((null ref))
-    (flet ((add-costs (cost)
-	     (dolist (scn scs)
-	       (let ((res (svref cost scn)))
-		 (unless res
-		   (bad-costs-error ref))
-		 (incf (svref costs scn) res)))))
-      (let* ((vop (tn-ref-vop ref))
-	     (info (vop-info vop)))
-	(case (vop-info-name info)
-	  (#.ignore-cost-vops)
-	  (move
-	   (let ((rep (tn-sc
-		       (tn-ref-tn
-			(if write-p
-			    (vop-args vop)
-			    (vop-results vop))))))
-	     (when rep
-	       (if write-p
-		   (dolist (scn scs)
-		     (let ((res (svref (sc-move-costs
-					(svref (backend-sc-numbers *backend*)
-					       scn))
-				       (sc-number rep))))
-		       (when res
-			 (incf (svref costs scn) res))))
-		   (dolist (scn scs)
-		     (let ((res (svref (sc-move-costs rep) scn)))
-		       (when res
-			 (incf (svref costs scn) res))))))))
-	  (t
-	   (do ((cost (funcall costs-slot info) (cdr cost))
-		(op (funcall ops-slot vop) (tn-ref-across op)))
-	       ((null cost)
-		(add-costs (funcall more-costs-slot info)))
-	     (when (eq op ref)
-	       (add-costs (car cost))
-	       (return))))))))
-  (undefined-value))
-
-
-;;; SELECT-TN-REPRESENTATION  --  Internal
-;;;
-;;;    Return the best representation for a normal TN.  SCs is a list of the SC
-;;; numbers of the SCs to select from.  Costs is a scratch vector.
-;;;
-;;;    What we do is sum the costs for each reference to TN in each of the
-;;; SCs, and then return the SC having the lowest cost.
-;;;
-(defun select-tn-representation (tn scs costs)
-  (declare (type tn tn) (type sc-vector costs)
-	   (inline add-representation-costs))
-  (dolist (scn scs)
-    (setf (svref costs scn) 0))
-  
-  
-  (add-representation-costs (tn-reads tn) scs costs
-			    #'vop-args #'vop-info-arg-costs
-			    #'vop-info-more-arg-costs
-			    nil)
-  (add-representation-costs (tn-writes tn) scs costs
-			    #'vop-results #'vop-info-result-costs
-			    #'vop-info-more-result-costs
-			    t)
-  
-  (let ((min most-positive-fixnum)
-	(min-scn nil))
-    (dolist (scn scs)
-      (let ((cost (svref costs scn)))
-	(when (< cost min)
-	  (setq min cost)
-	  (setq min-scn scn))))
-    
-    (svref (backend-sc-numbers *backend*) min-scn)))
-
-(declaim (end-block))
-
-
-;;; NOTE-NUMBER-STACK-TN  --  Internal
-;;;
-;;;    Prepare for the possibility of a TN being allocated on the number stack
-;;; by setting NUMBER-STACK-P in all functions that TN is referenced in and in
-;;; all the functions in their tail sets.  Refs is a TN-Refs list of references
-;;; to the TN.
-;;;
-(defun note-number-stack-tn (refs)
-  (declare (type (or tn-ref null) refs))
-  
-  (do ((ref refs (tn-ref-next ref)))
-      ((null ref))
-    (let* ((lambda (block-home-lambda
-		    (ir2-block-block
-		     (vop-block (tn-ref-vop ref)))))
-	   (tails (lambda-tail-set lambda)))
-      (flet ((frob (fun)
-	       (setf (ir2-environment-number-stack-p
-		      (environment-info
-		       (lambda-environment fun)))
-		     t)))
-	(frob lambda)
-	(when tails
-	  (dolist (fun (tail-set-functions tails))
-	    (frob fun))))))
-
-  (undefined-value))
-
-
-;;; GET-OPERAND-NAME  --  Internal
-;;;
-;;;    If TN is a variable, return the name.  If TN is used by a VOP emitted
-;;; for a return, then return a string indicating this.  Otherwise, return NIL.
-;;;
-(defun get-operand-name (tn arg-p)
-  (declare (type tn tn))
-  (let* ((actual (if (eq (tn-kind tn) :alias) (tn-save-tn tn) tn))
-	 (reads (tn-reads tn))
-	 (leaf (tn-leaf actual)))
-    (cond ((lambda-var-p leaf) (leaf-name leaf))
-	  ((and (not arg-p) reads
-		(return-p (vop-node (tn-ref-vop reads))))
-	   "<return value>")
-	  (t
-	   nil))))
-
-
-;;; DO-COERCE-EFFICIENCY-NOTE  --  Internal
-;;;
-;;;    If policy indicates, give an efficiency note for doing the a coercion
-;;; Vop, where Op is the operand we are coercing for and Dest-TN is the
-;;; distinct destination in a move.
-;;;
-(defun do-coerce-efficiency-note (vop op dest-tn)
-  (declare (type vop-info vop) (type tn-ref op) (type (or tn null) dest-tn))
-  (let* ((note (or (template-note vop) (template-name vop)))
-	 (cost (template-cost vop))
-	 (op-vop (tn-ref-vop op))
-	 (op-node (vop-node op-vop))
-	 (op-tn (tn-ref-tn op))
-	 (*compiler-error-context* op-node))
-    (cond ((eq (tn-kind op-tn) :constant))
-	  ((policy op-node (<= speed brevity) (<= space brevity)))
-	  ((member (template-name (vop-info op-vop)) suppress-note-vops))
-	  ((null dest-tn)
-	   (let* ((op-info (vop-info op-vop))
-		  (op-note (or (template-note op-info)
-			       (template-name op-info)))
-		  (arg-p (not (tn-ref-write-p op)))
-		  (name (get-operand-name op-tn arg-p))
-		  (pos (1+ (or (position-in #'tn-ref-across op
-					    (if arg-p
-						(vop-args op-vop)
-						(vop-results op-vop)))
-			       (error "Couldn't fine op?  Bug!")))))
-	     (compiler-note
-	      "Doing ~A (cost ~D)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~
-	       The ~:R ~:[result~;argument~] of ~A."
-	      note cost name arg-p name
-	      pos arg-p op-note)))
-	  (t
-	   (compiler-note "Doing ~A (cost ~D)~@[ from ~S~]~@[ to ~S~]."
-			  note cost (get-operand-name op-tn t)
-			  (get-operand-name dest-tn nil)))))
-  (undefined-value))
-
-
-;;; FIND-MOVE-VOP  --  Internal
-;;;
-;;;    Find a move VOP to move from the operand OP-TN to some other
-;;; representation corresponding to OTHER-SC and OTHER-PTYPE.  Slot is the SC
-;;; slot that we grab from (move or move-argument).  Write-P indicates that OP
-;;; is a VOP result, so OP is the move result and other is the arg, otherwise
-;;; OP is the arg and other is the result.
-;;;
-;;;    If an operand is of primitive type T, then we use the type of the other
-;;; operand instead, effectively intersecting the argument and result type
-;;; assertions.  This way, a move VOP can restrict whichever operand makes more
-;;; sense, without worrying about which operand has the type info.
-;;;
-(defun find-move-vop (op-tn write-p other-sc other-ptype slot)
-  (declare (type tn op-tn) (type sc other-sc)
-	   (type primitive-type other-ptype)
-	   (type function slot))
-  (let* ((op-sc (tn-sc op-tn))
-	 (op-scn (sc-number op-sc))
-	 (other-scn (sc-number other-sc))
-	 (any-ptype (backend-any-primitive-type *backend*))
-	 (op-ptype (tn-primitive-type op-tn)))
-    (let ((other-ptype (if (eq other-ptype any-ptype) op-ptype other-ptype))
-	  (op-ptype (if (eq op-ptype any-ptype) other-ptype op-ptype)))
-      (dolist (info (if write-p
-			(svref (funcall slot op-sc) other-scn)
-			(svref (funcall slot other-sc) op-scn))
-		    nil)
-	(when (and (operand-restriction-ok
-		    (first (template-arg-types info))
-		    (if write-p other-ptype op-ptype)
-		    :tn op-tn :t-ok nil)
-		   (operand-restriction-ok
-		    (first (template-result-types info))
-		    (if write-p op-ptype other-ptype)
-		    :t-ok nil))
-	  (return info))))))
-
-	
-;;; EMIT-COERCE-VOP  --  Internal
-;;;
-;;;    Emit a coercion VOP for Op Before the specifed VOP or die trying.  SCS
-;;; is the operand's LOAD-SCS vector, which we use to determine what SCs the
-;;; VOP will accept.  We pick any acceptable coerce VOP, since it practice it
-;;; seems uninteresting to have more than one applicable.
-;;;
-;;;    What we do is look at each SC allowed by both the operand restriction
-;;; and the operand primitive-type, and see if there is a move VOP which moves
-;;; between the operand's SC and load SC.  If we find such a VOP, then we make
-;;; a TN having the load SC as the representation.
-;;;
-;;;    Dest-TN is the TN that we are moving to, for a move or move-arg.  This
-;;; is only for efficiency notes.
-;;;
-;;;    If the TN is an unused result TN, then we don't actually emit the move;
-;;; we just change to the right kind of TN.
-;;;
-(defun emit-coerce-vop (op dest-tn scs before)
-  (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before)
-	   (type (or tn null) dest-tn))
-  (let* ((op-tn (tn-ref-tn op))
-	 (ptype (tn-primitive-type op-tn))
-	 (write-p (tn-ref-write-p op))
-	 (vop (tn-ref-vop op))
-	 (node (vop-node vop))
-	 (block (vop-block vop)))
-    (dotimes (i sc-number-limit (bad-coerce-error op))
-      (let ((i-sc (svref (backend-sc-numbers *backend*) i)))
-	(when (and (eq (svref scs i) t)
-		   (sc-allowed-by-primitive-type i-sc ptype))
-	  (let ((res (find-move-vop op-tn write-p i-sc ptype #'sc-move-vops)))
-	    (when res
-	      (when (>= (vop-info-cost res) *efficiency-note-cost-threshold*)
-		(do-coerce-efficiency-note res op dest-tn))
-	      (let ((temp (make-representation-tn ptype i)))
-		(change-tn-ref-tn op temp)
-		(cond
-		 ((not write-p)
-		  (emit-move-template node block res op-tn temp before))
-		 ((and (null (tn-reads op-tn))
-		       (eq (tn-kind op-tn) :normal)))
-		 (t
-		  (emit-move-template node block res temp op-tn before))))
-	      (return))))))))
-
-
-;;; COERCE-SOME-OPERANDS  --  Internal
-;;;
-;;;    Scan some operands and call EMIT-COERCE-VOP on any for which we can't
-;;; load the operand.  The coerce VOP is inserted Before the specified VOP.
-;;; Dest-TN is the destination TN if we are doing a move or move-arg, and is
-;;; NIL otherwise.  This is only used for efficiency notes.
-;;;
-(proclaim '(inline coerce-some-operands))
-(defun coerce-some-operands (ops dest-tn load-scs before)
-  (declare (type (or tn-ref null) ops) (list load-scs)
-	   (type (or tn null) dest-tn) (type (or vop null) before))
-  (do ((op ops (tn-ref-across op))
-       (scs load-scs (cdr scs)))
-      ((null scs))
-    (unless (svref (car scs)
-		   (sc-number (tn-sc (tn-ref-tn op))))
-      (emit-coerce-vop op dest-tn (car scs) before)))
-  (undefined-value))
-
-
-;;; COERCE-VOP-OPERANDS  --  Internal
-;;;
-;;;    Emit coerce VOPs for the args and results, as needed.
-;;;
-(defun coerce-vop-operands (vop)
-  (declare (type vop vop))
-  (let ((info (vop-info vop)))
-    (coerce-some-operands (vop-args vop) nil (vop-info-arg-load-scs info) vop)
-    (coerce-some-operands (vop-results vop) nil (vop-info-result-load-scs info)
-			  (vop-next vop)))
-  (undefined-value))
-
-
-;;; EMIT-ARG-MOVES  --  Internal
-;;;
-;;;    Iterate over the more operands to a call VOP, emitting move-arg VOPs and
-;;; any necessary coercions.  We determine which FP to use by looking at the
-;;; MOVE-ARGS annotation.  If the vop is a :LOCAL-CALL, we insert any needed
-;;; coercions before the ALLOCATE-FRAME so that lifetime analysis doesn't get
-;;; confused (since otherwise, only passing locations are written between A-F
-;;; and call.)
-;;;
-(defun emit-arg-moves (vop)
-  (let* ((info (vop-info vop))
-	 (node (vop-node vop))
-	 (block (vop-block vop))
-	 (how (vop-info-move-args info))
-	 (args (vop-args vop))
-	 (fp-tn (tn-ref-tn args))
-	 (nfp-tn (if (eq how :local-call)
-		     (tn-ref-tn (tn-ref-across args))
-		     nil))
-	 (pass-locs (first (vop-codegen-info vop)))
-	 (prev (vop-prev vop)))
-    (do ((val (do ((arg args (tn-ref-across arg))
-		   (req (template-arg-types info) (cdr req)))
-		  ((null req) arg))
-	      (tn-ref-across val))
-	 (pass pass-locs (cdr pass)))
-	((null val)
-	 (assert (null pass)))
-      (let* ((val-tn (tn-ref-tn val))
-	     (pass-tn (first pass))
-	     (pass-sc (tn-sc pass-tn))
-	     (res (find-move-vop val-tn nil pass-sc
-				 (tn-primitive-type pass-tn)
-				 #'sc-move-arg-vops)))
-	(unless res
-	  (bad-move-arg-error val-tn pass-tn))
-	
-	(change-tn-ref-tn val pass-tn)
-	(let* ((this-fp
-		(cond ((not (sc-number-stack-p pass-sc)) fp-tn)
-		      (nfp-tn)
-		      (t
-		       (assert (eq how :known-return))
-		       (setq nfp-tn (make-number-stack-pointer-tn))
-		       (setf (tn-sc nfp-tn)
-			     (svref (backend-sc-numbers *backend*)
-				    (first (primitive-type-scs
-					    (tn-primitive-type nfp-tn)))))
-		       (emit-context-template
-			node block
-			(template-or-lose 'compute-old-nfp *backend*)
-			nfp-tn vop)
-		       (assert (not (sc-number-stack-p (tn-sc nfp-tn))))
-		       nfp-tn)))
-	       (new (emit-move-arg-template node block res val-tn this-fp
-					    pass-tn vop))
-	       (after
-		(cond ((eq how :local-call)
-		       (assert (eq (vop-info-name (vop-info prev))
-				   'allocate-frame))
-		       prev)
-		      (prev (vop-next prev))
-		      (t
-		       (ir2-block-start-vop block)))))
-	  (coerce-some-operands (vop-args new) pass-tn
-				(vop-info-arg-load-scs res)
-				after)))))
-  (undefined-value))
-
-
-;;; EMIT-MOVES-AND-COERCIONS  --  Internal
-;;;
-;;;    Scan the IR2 looking for move operations that need to be replaced with
-;;; special-case VOPs and emitting coercion VOPs for operands of normal VOPs.
-;;; We delete moves to TNs that are never read at this point, rather than
-;;; possibly converting them to some expensive move operation.
-;;;
-(defun emit-moves-and-coercions (block)
-  (declare (type ir2-block block))
-  (do ((vop (ir2-block-start-vop block)
-	    (vop-next vop)))
-      ((null vop))
-    (let ((info (vop-info vop))
-	  (node (vop-node vop))
-	  (block (vop-block vop)))
-      (cond
-       ((eq (vop-info-name info) 'move)
-	(let* ((args (vop-args vop))
-	       (x (tn-ref-tn args))
-	       (y (tn-ref-tn (vop-results vop)))
-	       (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y)
-				   #'sc-move-vops)))
-	  (cond ((and (null (tn-reads y))
-		      (eq (tn-kind y) :normal))
-		 (delete-vop vop))
-		((eq res info))
-		(res
-		 (when (>= (vop-info-cost res)
-			   *efficiency-note-cost-threshold*)
-		   (do-coerce-efficiency-note res args y))
-		 (emit-move-template node block res x y vop)
-		 (delete-vop vop))
-		(t
-		 (coerce-vop-operands vop)))))
-       ((vop-info-move-args info)
-	(emit-arg-moves vop))
-       (t
-	(coerce-vop-operands vop))))))
-
-
-;;; NOTE-IF-NUMBER-STACK  --  Internal
-;;;
-;;;    If TN is in a number stack SC, make all the right annotations.  Note
-;;; that this should be called after TN has been referenced, since it must
-;;; iterate over the referencing environments.
-;;;
-(proclaim '(inline note-if-number-stack))
-(defun note-if-number-stack (tn 2comp restricted)
-  (declare (type tn tn) (type ir2-component 2comp))
-  (when (if restricted
-	    (eq (sb-name (sc-sb (tn-sc tn))) 'non-descriptor-stack)
-	    (sc-number-stack-p (tn-sc tn)))
-    (unless (ir2-component-nfp 2comp)
-      (setf (ir2-component-nfp 2comp) (make-nfp-tn)))
-    (note-number-stack-tn (tn-reads tn))
-    (note-number-stack-tn (tn-writes tn)))
-  (undefined-value))
-
-
-;;; SELECT-REPRESENTATIONS  --  Interface
-;;;
-;;;    Entry to representation selection.  First we select the representation
-;;; for all normal TNs, setting the TN-SC.  After selecting the TN
-;;; representations, we set the SC for all :ALIAS TNs to be the representation
-;;; chosen for the original TN.  We then scan all the IR2, emitting any
-;;; necessary coerce and move-arg VOPs.  Finally, we scan all TNs looking for
-;;; ones that might be placed on the number stack, noting this so that the
-;;; number-FP can be allocated.  This must be done last, since references in
-;;; new environments may be introduced by MOVE-ARG insertion.
-;;;
-(defun select-representations (component)
-  (let ((costs (make-array sc-number-limit))
-	(2comp (component-info component)))
-	        
-    (do ((tn (ir2-component-normal-tns 2comp)
-	     (tn-next tn)))
-	((null tn))
-      (assert (tn-primitive-type tn))
-      (unless (tn-sc tn)
-	(let* ((scs (primitive-type-scs (tn-primitive-type tn)))
-	       (sc (if (rest scs)
-		       (select-tn-representation tn scs costs)
-		       (svref (backend-sc-numbers *backend*) (first scs)))))
-	  (assert sc)
-	  (setf (tn-sc tn) sc))))
-
-    (do ((alias (ir2-component-alias-tns 2comp)
-		(tn-next alias)))
-	((null alias))
-      (setf (tn-sc alias) (tn-sc (tn-save-tn alias))))
-
-    (do-ir2-blocks (block component)
-      (emit-moves-and-coercions block))
-    
-    (macrolet ((frob (slot restricted)
-		 `(do ((tn (,slot 2comp) (tn-next tn)))
-		      ((null tn))
-		    (note-if-number-stack tn 2comp ,restricted))))
-      (frob ir2-component-normal-tns nil)
-      (frob ir2-component-wired-tns t)
-      (frob ir2-component-restricted-tns t)))
-
-  (undefined-value))
diff --git a/compiler/rt/afpa.lisp b/compiler/rt/afpa.lisp
deleted file mode 100644
index 45395b94c3448bd221af8124668c0007e17b9b98..0000000000000000000000000000000000000000
--- a/compiler/rt/afpa.lisp
+++ /dev/null
@@ -1,486 +0,0 @@
-;;; -*- Package: RT -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/afpa.lisp,v 1.4 1992/03/09 20:37:26 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; The following code is to support the AFPA on the EAPC card and the
-;;; accessory AFPA for the APC card.  There isn't heavy use of AFPA features;
-;;; other than the size of the register set, and the DMA use, this would work
-;;; on the FPA (supposing anyone still has one of those.)  This is adapted from
-;;; the 68881 support, and from the MIPS support.
-;;;
-;;; See section 4 in Vol 1 of the RT technical manual.  In particular DMA is
-;;; described on 4-96 to 4-98.
-;;;
-(in-package "RT")
-
-;;;; Status register formats.
-
-(defconstant afpa-rounding-mode-byte (byte 2 (- 31 24)))
-(defconstant afpa-compare-result-byte (byte 2 (- 31 22)))
-
-;;; The condition code bits.
-;;;
-(defconstant afpa-compare-gtr #b00)
-(defconstant afpa-compare-eql #b01)
-(defconstant afpa-compare-lss #b10)
-(defconstant afpa-compare-unordered #b11)
-
-;;; ### Note: the following status register constants are totally bogus (are
-;;; actually for the mc68881, and exist only to make some code compile without
-;;; errors.
-;;;
-;;; Encoding of float exceptions in the FLOATING-POINT-MODES result.  This is
-;;; also the encoding used in the mc68881 accrued exceptions.
-;;;
-(defconstant float-inexact-trap-bit (ash 1 0))
-(defconstant float-divide-by-zero-trap-bit (ash 1 1))
-(defconstant float-underflow-trap-bit (ash 1 2))
-(defconstant float-overflow-trap-bit (ash 1 3))
-(defconstant float-invalid-trap-bit (ash 1 4))
-
-(defconstant float-round-to-nearest 0)
-(defconstant float-round-to-zero 1)
-(defconstant float-round-to-negative 2)
-(defconstant float-round-to-positive 3)
-
-;;; Positions of bits in the FLOATING-POINT-MODES result.
-;;;
-(defconstant float-rounding-mode (byte 2 0))
-(defconstant float-sticky-bits (byte 5 2))
-(defconstant float-traps-byte (byte 5 7))
-(defconstant float-exceptions-byte (byte 5 12))
-(defconstant float-fast-bit 0)
-
-
-;;;; Move functions:
-;;;
-;;;    Since moving between memory and a FP register reqires *two* temporaries,
-;;; we need a special temporary to form the magic address we store to do a
-;;; floating point operation.  We get this temp by always spilling NL0 on the
-;;; number stack.  See WITH-FP-TEMP in the 68881 support.
-;;;
-;;; We also use LIP to form the address of the data location that we are
-;;; reading or writing.
-
-
-(define-move-function (load-afpa-single 7) (vop x y)
-  ((single-stack) (afpa-single-reg))
-  (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
-  (with-fp-temp (temp)
-    (inst afpa-load y lip-tn :single temp)
-    (inst afpa-noop temp)))
-
-(define-move-function (store-single 8) (vop x y)
-  ((afpa-single-reg) (single-stack))
-  (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
-  (with-fp-temp (temp)
-    (inst afpa-store x lip-tn :single temp)
-    (inst afpa-noop temp)))
-
-(define-move-function (load-double 7) (vop x y)
-  ((double-stack) (afpa-double-reg))
-  (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
-  (with-fp-temp (temp)
-    (inst afpa-load y lip-tn :double temp)
-    (inst afpa-noop temp)))
-
-(define-move-function (store-double 8) (vop x y)
-  ((afpa-double-reg) (double-stack))
-  (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
-  (with-fp-temp (temp)
-    (inst afpa-store x lip-tn :double temp)
-    (inst afpa-noop temp)))
-
-
-;;;; Move VOPs:
-
-
-(macrolet ((frob (vop sc inst)
-	     `(progn
-		(define-vop (,vop)
-		  (:args (x :scs (,sc)
-			    :target y
-			    :load-if (not (location= x y))))
-		  (:results (y :scs (,sc)
-			       :load-if (not (location= x y))))
-		  (:note "float move")
-		  (:temporary (:sc sap-reg) temp)
-		  (:generator 0
-		    (unless (location= y x)
-		      (inst afpa-unop y x ,inst temp))))
-		(define-move-vop ,vop :move (,sc) (,sc)))))
-  (frob afpa-single-move afpa-single-reg :cops)
-  (frob afpa-double-move afpa-double-reg :copl))
-
-
-
-(macrolet ((frob (name format data sc)
-	     `(progn
-		(define-vop (,name)
-		  (:args (x :scs (descriptor-reg)))
-		  (:results (y :scs (,sc)))
-		  (:temporary (:sc sap-reg) temp)
-		  (:generator 7
-		    (inst cal lip-tn x (- (* ,data vm:word-bytes)
-					  vm:other-pointer-type))
-		    (inst afpa-load y lip-tn ,format temp)
-		    (inst afpa-noop temp)))
-		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
-  (frob move-to-afpa-single :single vm:single-float-value-slot
-    afpa-single-reg)
-  (frob move-to-afpa-double :double vm:double-float-value-slot
-    afpa-double-reg))
-
-
-
-(macrolet ((frob (name sc format size type data)
-	     `(progn
-		(define-vop (,name)
-		  (:args (x :scs (afpa-single-reg afpa-double-reg) :to :save))
-		  (:results (y :scs (descriptor-reg)))
-		  (:temporary (:scs (sap-reg)) ndescr)
-		  (:temporary (:scs (word-pointer-reg)) alloc)
-		  (:generator 20
-		    (with-fixed-allocation (y ndescr alloc ,type ,size)
-		      (inst cal lip-tn y (- (* ,data vm:word-bytes)
-					    vm:other-pointer-type))
-		      (inst afpa-store x lip-tn ,format ndescr)
-		      (inst afpa-noop ndescr))))
-		(define-move-vop ,name :move (,sc) (descriptor-reg)))))
-  (frob move-from-afpa-single afpa-single-reg
-    :single vm:single-float-size vm:single-float-type
-    vm:single-float-value-slot)
-  (frob move-from-afpa-double afpa-double-reg
-    :double vm:double-float-size vm:double-float-type
-    vm:double-float-value-slot))
-
-(define-vop (move-to-afpa-argument)
-  (:args (x :scs (afpa-single-reg afpa-double-reg))
-	 (nfp :scs (word-pointer-reg)
-	      :load-if (not (sc-is y afpa-single-reg afpa-double-reg))))
-  (:results (y))
-  (:temporary (:sc sap-reg) temp)
-  (:variant-vars format)
-  (:vop-var vop)
-  (:generator 7
-    (sc-case y
-      ((afpa-single-reg afpa-double-reg)
-       (unless (location= y x)
-	 (inst afpa-move y x format temp)))
-      ((single-stack double-stack)
-       (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
-       (inst afpa-store y lip-tn format temp)
-       (inst afpa-noop temp)))))
-
-(macrolet ((frob (name format sc)
-	     `(progn
-		(define-vop (,name move-to-afpa-argument)
-		  (:variant ,format))
-		(define-move-vop ,name :move-argument
-		  (,sc descriptor-reg) (,sc)))))
-  (frob move-afpa-single-float-argument :single afpa-single-reg)
-  (frob move-afpa-double-float-argument :double afpa-double-reg))
-
-(define-move-vop move-argument :move-argument
-  (afpa-single-reg afpa-double-reg) (descriptor-reg))
-
-
-;;;; Arithmetic VOPs:
-
-(define-vop (afpa-op)
-  (:args (x) (y))
-  (:results (r))
-  (:temporary (:sc sap-reg) temp)
-  (:policy :fast-safe)
-  (:guard (eq *target-float-hardware* :afpa))
-  (:note "inline float arithmetic")
-  (:vop-var vop)
-  (:save-p :compute-only))
-
-(macrolet ((frob (name sc ptype format)
-	     `(define-vop (,name afpa-op)
-		(:args (x :scs (,sc) :target r)
-		       (y :scs (,sc)))
-		(:results (r :scs (,sc) :from (:argument 0)))
-		(:arg-types ,ptype ,ptype)
-		(:result-types ,ptype)
-		(:variant-vars op)
-		(:generator 20
-		  (unless (location= x r)
-		    (inst afpa-move r x ,format temp))
-		  (note-this-location vop :internal-error)
-		  (inst afpa-binop r y op temp)))))
-  (frob afpa-single-float-op afpa-single-reg afpa-single-float :single)
-  (frob afpa-double-float-op afpa-double-reg afpa-double-float :double))
-
-(macrolet ((frob (op sinst sname dinst dname)
-	     `(progn
-		(define-vop (,sname afpa-single-float-op)
-		  (:translate ,op)
-		  (:variant ,sinst))
-		(define-vop (,dname afpa-double-float-op)
-		  (:translate ,op)
-		  (:variant ,dinst)))))
-  (frob + :adds +/single-float :addl +/double-float)
-  (frob - :subs -/single-float :subl -/double-float)
-  (frob * :muls */single-float :mull */double-float)
-  (frob / :divs //single-float :divl //double-float))
-
-(define-vop (afpa-unop afpa-op)
-  (:args (x)))
-
-(macrolet ((frob (name sc ptype)
-	     `(define-vop (,name afpa-unop)
-		(:args (x :scs (,sc)))
-		(:results (r :scs (,sc)))
-		(:arg-types ,ptype)
-		(:result-types ,ptype)
-		(:variant-vars op)
-		(:generator 20
-		  (inst afpa-unop r x op temp)))))
-  (frob afpa-single-float-unop afpa-single-reg afpa-single-float)
-  (frob afpa-double-float-unop afpa-double-reg afpa-double-float))
-
-
-(macrolet ((frob (op sinst sname dinst dname)
-	     `(progn
-		(define-vop (,sname afpa-single-float-unop)
-		  (:translate ,op)
-		  (:variant ,sinst))
-		(define-vop (,dname afpa-double-float-unop)
-		  (:translate ,op)
-		  (:variant ,dinst)))))
-  (frob abs :abss abs/single-float :absl abs/double-float)
-  (frob %negate :negs %negate/single-float :negl %negate/double-float))
-
-
-;;;; Comparison:
-
-(define-vop (afpa-compare)
-  (:args (x) (y))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:guard (eq *target-float-hardware* :afpa))
-  (:temporary (:sc sap-reg) temp)
-  (:variant-vars condition format)
-  (:note "inline float comparison")
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 15
-    (note-this-location vop :internal-error)
-    (inst afpa-compare x y
-	  (ecase format
-	    (:single :comts)
-	    (:double :comtl))
-	  temp)
-    (inst afpa-get-status temp temp)
-    (inst nilz temp temp (mask-field afpa-compare-result-byte -1))
-    (inst c temp (dpb condition afpa-compare-result-byte 0))
-    (if not-p
-	(inst bnc :eq target)
-	(inst bc :eq target))))
-
-
-(macrolet ((frob (name sc ptype)
-	     `(define-vop (,name afpa-compare)
-		(:args (x :scs (,sc))
-		       (y :scs (,sc)))
-		(:arg-types ,ptype ,ptype))))
-  (frob afpa-single-float-compare afpa-single-reg afpa-single-float)
-  (frob afpa-double-float-compare afpa-double-reg afpa-double-float))
-
-(macrolet ((frob (translate sname dname condition)
-	     `(progn
-		(define-vop (,sname afpa-single-float-compare)
-		  (:translate ,translate)
-		  (:variant ,condition :single))
-		(define-vop (,dname afpa-double-float-compare)
-		  (:translate ,translate)
-		  (:variant ,condition :double)))))
-  (frob < afpa-</single-float afpa-</double-float afpa-compare-lss)
-  (frob > afpa->/single-float afpa->/double-float afpa-compare-gtr)
-  (frob eql afpa-eql/single-float afpa-eql/double-float afpa-compare-eql))
-
-
-;;;; Conversion:
-
-(macrolet ((frob (name translate
-		       from-sc from-type
-		       to-sc to-type
-		       word-p op)
-	     `(define-vop (,name)
-		(:args (x :scs (,from-sc)))
-		(:results (y :scs (,to-sc)))
-		(:arg-types ,from-type)
-		(:result-types ,to-type)
-		(:temporary (:sc sap-reg) temp)
-		(:policy :fast-safe)
-		(:guard (eq *target-float-hardware* :afpa))
-		(:note "inline float coercion")
-		(:translate ,translate)
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 10
-		  (note-this-location vop :internal-error)
-		  ,@(if word-p
-			`((inst afpa-put-float-inst y x temp
-				(do-afpa-inst ,op temp :fr2 y :data x
-					      :ds :fr1-immediate)))
-			`((inst afpa-unop y x ,op temp)))))))
-  (frob %afpa-single-float/signed %single-float
-    signed-reg signed-num
-    afpa-single-reg afpa-single-float
-    t :cws)
-  (frob %afpa-double-float/signed %double-float
-    signed-reg signed-num
-    afpa-double-reg afpa-double-float
-    t :cwl)
-  (frob %afpa-single-float/double-float %single-float
-    afpa-double-reg afpa-double-float
-    afpa-single-reg afpa-single-float
-    nil :cls)
-  (frob %afpa-double-float/single-float %double-float
-    afpa-single-reg afpa-single-float
-    afpa-double-reg afpa-double-float
-    nil :csl))
-
-(macrolet ((frob (translate name from-sc from-type op)
-	     `(define-vop (,name)
-		(:args (x :scs (,from-sc)))
-		(:results (y :scs (signed-reg)))
-		(:temporary (:from (:argument 0) :sc ,from-sc) fp-temp)
-		(:temporary (:sc sap-reg) temp)
-		(:arg-types ,from-type)
-		(:result-types signed-num)
-		(:translate ,translate)
-		(:policy :fast-safe)
-		(:guard (eq *target-float-hardware* :afpa))
-		(:note "inline float round/truncate")
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 10
-		  (note-this-location vop :internal-error)
-		  (inst afpa-unop fp-temp x ,op temp)
-		  (inst afpa-get-float y fp-temp temp)))))
-
-  (frob %unary-round %unary-round/afpa-single-float
-    afpa-single-reg afpa-single-float :rsw)
-  (frob %unary-round %unary-round/afpa-double-float
-    afpa-double-reg afpa-double-float :rlw)
-  (frob %unary-truncate %unary-truncate/afpa-single-float
-    afpa-single-reg afpa-single-float :tsw)
-  (frob %unary-truncate %unary-truncate/afpa-double-float
-    afpa-double-reg afpa-double-float :tlw))
-
-
-(define-vop (make-afpa-single-float)
-  (:args (bits :scs (signed-reg)))
-  (:results (res :scs (afpa-single-reg)))
-  (:arg-types signed-num)
-  (:temporary (:sc sap-reg) temp)
-  (:guard (eq *target-float-hardware* :afpa))
-  (:result-types afpa-single-float)
-  (:translate make-single-float)
-  (:policy :fast-safe)
-  (:generator 5
-    (inst afpa-put-float res bits temp)))
-
-(define-vop (make-afpa-double-float)
-  (:args (hi-bits :scs (signed-reg))
-	 (lo-bits :scs (unsigned-reg)))
-  (:results (res :scs (afpa-double-reg)))
-  (:temporary (:sc sap-reg) temp)
-  (:guard (eq *target-float-hardware* :afpa))
-  (:arg-types signed-num unsigned-num)
-  (:result-types afpa-double-float)
-  (:translate make-double-float)
-  (:policy :fast-safe)
-  (:generator 10
-    (inst afpa-put-float-odd res lo-bits temp)
-    (inst afpa-put-float res hi-bits temp)))
-
-(define-vop (afpa-single-float-bits)
-  (:args (float :scs (afpa-single-reg)))
-  (:results (bits :scs (signed-reg)))
-  (:temporary (:sc sap-reg) temp)
-  (:guard (eq *target-float-hardware* :afpa))
-  (:arg-types afpa-single-float)
-  (:result-types signed-num)
-  (:translate single-float-bits)
-  (:policy :fast-safe)
-  (:generator 5
-    (inst afpa-get-float bits float temp)))
-
-(define-vop (afpa-double-float-high-bits)
-  (:args (float :scs (afpa-double-reg)))
-  (:results (hi-bits :scs (signed-reg)))
-  (:temporary (:sc sap-reg) temp)
-  (:guard (eq *target-float-hardware* :afpa))
-  (:arg-types afpa-double-float)
-  (:result-types signed-num)
-  (:translate double-float-high-bits)
-  (:policy :fast-safe)
-  (:generator 5
-    (inst afpa-get-float hi-bits float temp)))
-
-(define-vop (afpa-double-float-low-bits)
-  (:args (float :scs (afpa-double-reg)))
-  (:results (lo-bits :scs (unsigned-reg)))
-  (:temporary (:sc sap-reg) temp)
-  (:guard (eq *target-float-hardware* :afpa))
-  (:arg-types afpa-double-float)
-  (:result-types unsigned-num)
-  (:translate double-float-low-bits)
-  (:policy :fast-safe)
-  (:generator 5
-    (inst afpa-get-float-odd lo-bits float temp)))
-
-
-;;;; Float mode hackery:
-
-(deftype float-modes () '(unsigned-byte 32))
-(defknown floating-point-modes () float-modes (flushable))
-(defknown ((setf floating-point-modes)) (float-modes)
-  float-modes)
-
-(define-vop (floating-point-modes)
-  (:results (res :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:translate floating-point-modes)
-  (:policy :fast-safe)
-  #+nil (:vop-var vop)
-  #+nil (:temporary (:sc unsigned-stack) temp)
-  (:generator 3
-    #+nil
-    (let ((nfp (current-nfp-tn vop)))
-      (inst stfsr nfp (* word-bytes (tn-offset temp)))
-      (loadw res nfp (tn-offset temp))
-      (inst nop))
-    (inst li res 0)))
-
-(define-vop (set-floating-point-modes)
-  (:args (new :scs (unsigned-reg) :target res))
-  (:results (res :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:result-types unsigned-num)
-  (:translate (setf floating-point-modes))
-  (:policy :fast-safe)
-  #+nil (:temporary (:sc unsigned-stack) temp)
-  #+nil (:vop-var vop)
-  (:generator 3
-    #+nil
-    (let ((nfp (current-nfp-tn vop)))
-      (storew new nfp (tn-offset temp))
-      (inst ldfsr nfp (* word-bytes (tn-offset temp)))
-      (move res new))
-    (move res new)))
diff --git a/compiler/rt/alloc.lisp b/compiler/rt/alloc.lisp
deleted file mode 100644
index b0802c9f347785d2f5737fdcc993824a88aac112..0000000000000000000000000000000000000000
--- a/compiler/rt/alloc.lisp
+++ /dev/null
@@ -1,139 +0,0 @@
-;;; -*- Package: rt -*-
-;;;
-;;; **********************************************************************
-;;; 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/rt/alloc.lisp,v 1.4 1991/10/22 16:43:17 wlott Exp $
-;;;
-;;; Allocation VOPs for the IBM RT port.
-;;;
-;;; Written by William Lott.
-;;; Converted by Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-;;;; LIST and LIST*
-
-(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)
-  (:temporary (:scs (word-pointer-reg)) alloc)
-  (: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 cons-car-slot))
-		  `(let ((reg
-			  (sc-case ,tn
-			    ((any-reg descriptor-reg) ,tn)
-			    (null null-tn)
-			    (control-stack
-			     (load-stack-tn temp ,tn)
-			     temp))))
-		     (storew reg ,list ,slot list-pointer-type))))
-	     (let ((cons-cells (if star (1- num) num)))
-	       (pseudo-atomic (ndescr)
-		 (load-symbol-value alloc *allocation-pointer*)
-		 (inst cal res alloc list-pointer-type)
-		 (inst cal alloc alloc (* (pad-data-block cons-size)
-					  cons-cells))
-		 (store-symbol-value alloc *allocation-pointer*)
-		 (move ptr res)
-		 (dotimes (i (1- cons-cells))
-		   (store-car (tn-ref-tn things) ptr)
-		   (setf things (tn-ref-across things))
-		   (inst cal ptr ptr (pad-data-block cons-size))
-		   (storew ptr ptr
-			   (- cons-cdr-slot cons-size)
-			   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 cons-cdr-slot))
-		       (t
-			(storew null-tn ptr
-				cons-cdr-slot list-pointer-type)))
-		 (assert (null (tn-ref-across things)))
-		 (move result res))
-	       (load-symbol-value ndescr *internal-gc-trigger*)
-	       (inst tlt ndescr alloc)))))))
-
-(define-vop (list list-or-list*)
-  (:variant nil))
-
-(define-vop (list* list-or-list*)
-  (:variant t))
-
-
-
-;;;; Special purpose inline allocators.
-
-(define-vop (allocate-code-object)
-  (:args (boxed-arg :scs (any-reg))
-	 (unboxed-arg :scs (any-reg) :target unboxed))
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:temporary (:scs (word-pointer-reg)) alloc)
-  (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
-  (:generator 100
-    (inst li ndescr (lognot lowtag-mask))
-    (inst cal boxed boxed-arg (fixnum (1+ vm:code-trace-table-offset-slot)))
-    (inst n boxed ndescr)
-    (move unboxed unboxed-arg)
-    (inst sr unboxed word-shift)
-    (inst a unboxed lowtag-mask)
-    (inst n unboxed ndescr)
-    (pseudo-atomic (ndescr)
-      (load-symbol-value alloc *allocation-pointer*)
-      (inst cal result alloc other-pointer-type)
-      (inst cas alloc boxed alloc)
-      (inst cas alloc unboxed alloc)
-      (store-symbol-value alloc *allocation-pointer*)
-      (move ndescr boxed)
-      (inst sl ndescr (- type-bits word-shift))
-      (inst oil ndescr code-header-type)
-      (storew ndescr result 0 other-pointer-type)
-      (storew unboxed result code-code-size-slot other-pointer-type)
-      (storew null-tn result code-entry-points-slot other-pointer-type)
-      (storew null-tn result code-debug-info-slot other-pointer-type))
-    (load-symbol-value ndescr *internal-gc-trigger*)
-    (inst tlt ndescr alloc)))
-
-(define-vop (make-symbol)
-  (:args (name :scs (descriptor-reg) :to :eval))
-  (:temporary (:scs (sap-reg)) temp)
-  (:temporary (:scs (word-pointer-reg)) alloc)
-  (:results (result :scs (descriptor-reg) :from :argument))
-  (:policy :fast-safe)
-  (:translate make-symbol)
-  (:generator 37
-    (with-fixed-allocation (result temp alloc symbol-header-type symbol-size)
-      (inst li temp unbound-marker-type)
-      (storew temp result symbol-value-slot other-pointer-type)
-      (storew temp result symbol-function-slot other-pointer-type)
-      (storew temp result symbol-setf-function-slot other-pointer-type)
-      (inst cai temp (make-fixup "undefined_tramp" :foreign))
-      (storew temp result symbol-raw-function-addr-slot
-	      other-pointer-type)
-      (storew null-tn result symbol-plist-slot other-pointer-type)
-      (storew name result symbol-name-slot other-pointer-type)
-      (storew null-tn result symbol-package-slot other-pointer-type))))
diff --git a/compiler/rt/arith.lisp b/compiler/rt/arith.lisp
deleted file mode 100644
index 66e7eda64a951307f7144438d83890d194ead5cb..0000000000000000000000000000000000000000
--- a/compiler/rt/arith.lisp
+++ /dev/null
@@ -1,920 +0,0 @@
-;;; -*- Package: RT; 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/rt/arith.lisp,v 1.10 1991/06/13 16:37:48 wlott Exp $
-;;;
-;;; This file contains the VM definition arithmetic VOPs for the IBM RT.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-;;;; Unary operations.
-
-(define-vop (fixnum-unop)
-  (:args (x :scs (any-reg)))
-  (:results (res :scs (any-reg)))
-  (:note "inline fixnum arithmetic")
-  (:arg-types tagged-num)
-  (:result-types tagged-num)
-  (:policy :fast-safe))
-
-(define-vop (signed-unop)
-  (:args (x :scs (signed-reg)))
-  (:results (res :scs (signed-reg)))
-  (:note "inline (signed-byte 32) arithmetic")
-  (:arg-types signed-num)
-  (:result-types signed-num)
-  (:policy :fast-safe))
-
-(define-vop (fast-negate/fixnum fixnum-unop)
-  (:translate %negate)
-  (:generator 1
-    (inst neg res x)))
-
-(define-vop (fast-negate/signed signed-unop)
-  (:translate %negate)
-  (:generator 2
-    (inst neg res x)))
-
-(define-vop (fast-lognot/fixnum fixnum-unop)
-  (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target res)
-	      temp)
-  (:translate lognot)
-  (:generator 2
-    (inst li temp (fixnum -1))
-    (inst x temp x)
-    (move res temp)))
-
-(define-vop (fast-lognot/signed signed-unop)
-  (:translate lognot)
-  (:generator 1
-    (inst not res x)))
-
-
-
-;;;; Binary fixnum operations (+, -, LOGIOR, LOGAND, LOGXOR).
-
-;;; Assume that any constant operand is the second arg...
-
-(define-vop (fast-fixnum-binop)
-  (:args (x :target r :scs (any-reg))
-	 (y :scs (any-reg immediate) :to :save))
-  (:arg-types tagged-num tagged-num)
-  (:temporary (:scs (any-reg)) temp)
-  (:results (r :scs (any-reg)))
-  (:result-types tagged-num)
-  (:note "inline fixnum arithmetic")
-  (:effects)
-  (:affected)
-  (:policy :fast-safe))
-
-(define-vop (fast-unsigned-binop)
-  (:args (x :target r :scs (unsigned-reg))
-	 (y :scs (unsigned-reg immediate) :to :save))
-  (:arg-types unsigned-num unsigned-num)
-  (:temporary (:scs (any-reg)) temp)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:note "inline (unsigned-byte 32) arithmetic")
-  (:effects)
-  (:affected)
-  (:policy :fast-safe))
-
-(define-vop (fast-signed-binop)
-  (:args (x :target r :scs (signed-reg))
-	 (y :scs (signed-reg immediate) :to :save))
-  (:arg-types signed-num signed-num)
-  (:temporary (:scs (any-reg)) temp)
-  (:results (r :scs (signed-reg)))
-  (:result-types signed-num)
-  (:note "inline (signed-byte 32) arithmetic")
-  (:effects)
-  (:affected)
-  (:policy :fast-safe))
-
-(eval-when (compile eval)
-
-(defmacro define-binop (translate cost op &body imm-body)
-  `(progn
-     (define-vop (,(intern (concatenate 'simple-string
-					"FAST-"
-					(string translate)
-					"/FIXNUM=>FIXNUM"))
-		  fast-fixnum-binop)
-       (:translate ,translate)
-       (:generator ,cost
-	 (sc-case y
-	   (any-reg
-	    (move r x)
-	    (inst ,op r y))
-	   (immediate
-	    (let ((value (fixnum (tn-value y))))
-	      ,@imm-body)))))
-     (define-vop (,(intern (concatenate 'simple-string
-					"FAST-"
-					(string translate)
-					"/SIGNED=>SIGNED"))
-		  fast-signed-binop)
-       (:translate ,translate)
-       (:generator ,(1+ cost)
-	 (sc-case y
-	   (signed-reg
-	    (move r x)
-	    (inst ,op r y))
-	   (immediate
-	    (let ((value (tn-value y)))
-	      ,@imm-body)))))
-     (define-vop (,(intern (concatenate 'simple-string
-					"FAST-"
-					(string translate)
-					"/UNSIGNED=>UNSIGNED"))
-		  fast-unsigned-binop)
-       (:translate ,translate)
-       (:generator ,(1+ cost)
-	 (sc-case y
-	   (unsigned-reg
-	    (move r x)
-	    (inst ,op r y))
-	   (immediate
-	    (let ((value (tn-value y)))
-	      ,@imm-body)))))))
-
-) ;EVAL-WHEN
-
-
-(define-binop + 3 a
-  (cond ((typep value '(signed-byte 16))
-	 (inst a r x value))
-	(t
-	 (move r x)
-	 (inst li temp value)
-	 (inst a r temp))))
-
-(define-binop - 3 s
-  (cond ((typep value '(signed-byte 16))
-	 (inst s r x value))
-	(t
-	 (move r x)
-	 (inst li temp value)
-	 (inst s r temp))))
-
-(define-binop logior 2 o
-  (let ((low (ldb (byte 16 0) value))
-	(high (ldb (byte 16 16) value)))
-    (cond ((zerop value)
-	   (move r x))
-	  ((zerop low)
-	   (inst oiu r x high))
-	  ((zerop high)
-	   (inst oil r x low))
-	  (t
-	   (inst oil r x low)
-	   (inst oiu r r high)))))
-
-(define-binop logxor 2 x
-  (let ((low (ldb (byte 16 0) value))
-	(high (ldb (byte 16 16) value)))
-    (cond ((zerop value)
-	   (move r x))
-	  ((zerop low)
-	   (inst xiu r x high))
-	  ((zerop high)
-	   (inst xil r x low))
-	  (t
-	   (inst xil r x low)
-	   (inst xiu r r high)))))
-
-(define-binop logand 1 n
-  (let ((low (ldb (byte 16 0) value))
-	(high (ldb (byte 16 16) value)))
-    (cond ((= low high #xFFFF)
-	   (move r x))
-	  ((zerop low)
-	   (inst niuz r x high))
-	  ((= low #xFFFF)
-	   (inst niuo r x high))
-	  ((zerop high)
-	   (inst nilz r x low))
-	  ((= high #xFFFF)
-	   (inst nilo r x low))
-	  (t
-	   (inst nilo r x low)
-	   (inst niuo r r high)))))
-
-
-
-;;;; Binary fixnum operations.
-
-(define-vop (fast-ash)
-  (:note "inline ASH")
-  (:args (number :scs (signed-reg unsigned-reg) :to (:result 0) :target result)
-	 (amount-arg :scs (signed-reg immediate) :target amount))
-  (:arg-types (:or signed-num unsigned-num) signed-num)
-  (:results (result :scs (signed-reg unsigned-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:translate ash)
-  (:policy :fast-safe)
-  (:temporary (:sc non-descriptor-reg :from (:argument 1)) amount)
-  (:generator 12
-    (sc-case amount-arg
-      (signed-reg
-       (let ((positive (gen-label))
-	     (shift-right (gen-label))
-	     (done (gen-label)))
-	 ;; Copy the amount and check to see if it's positive.
-	 (inst oil amount amount-arg 0)
-	 (inst bnc :lt positive)
-
-	 ;; We want to shift to the right, so make the amount positive.
-	 (inst neg amount)
-	 (inst c amount 32)
-	 ;; If less than 32, do the shifting.
-	 (inst bc :lt shift-right)
-	 ;; 32 or greater, we just shift by 31.
-	 (inst li amount 31)
-	 (emit-label shift-right)
-	 (move result number)
-	 (inst bx done)
-	 (sc-case number
-	   (signed-reg
-	    (inst sar result amount))
-	   (unsigned-reg
-	    (inst sr result amount)))
-
-	 (emit-label positive)
-	 ;; The result-type assures us that this shift will not overflow.
-	 (move result number)
-	 (inst sl result amount)
-
-	 (emit-label done)))
-
-      (immediate
-       (let ((amount (tn-value amount-arg)))
-	 (cond ((minusp amount)
-		(sc-case number
-		  (unsigned-reg
-		   (move result number)
-		   (inst sr result (min (- amount) 31)))
-		  (t
-		   (move result number)
-		   (inst sar result (min (- amount) 31)))))
-	       (t
-		(move result number)
-		(inst sl result (min amount 31)))))))))
-
-
-;;; SIGNED-BYTE-32-LEN -- VOP.
-;;;
-;;; Common Lisp INTEGER-LENGTH.  Due to the definition of this operation,
-;;;    (integer-length x) == (integer-length (lognot x)).
-;;; We determine the result by using the RT's count-leading-zeros which only
-;;; works on the zeros in the lower half of a word, so we have to use it on
-;;; the upperhalf and lowerhalf of number separately and do a little addition
-;;; (actually, subtraction from the right values) to get the length.
-;;;
-(define-vop (signed-byte-32-len)
-  (:translate integer-length)
-  (:note "inline (signed-byte 32) integer-length")
-  (:policy :fast-safe)
-  (:args (arg :scs (signed-reg)))
-  (:arg-types signed-num)
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) number)
-  (:temporary (:scs (non-descriptor-reg) :from (:eval 0)) temp)
-  (:generator 16
-    (let ((upper-not-zero (gen-label))
-	  (count (gen-label)))
-      ;; Move arg and tell us if number is positive.
-      (inst oil number arg 0)
-      (inst bnc :lt count)
-      ;; Number is negative, so logically negate it to compute length.
-      (inst not number)
-      (emit-label count)
-      ;; Shift the upperhalf down and see if there are any 1's in it.
-      (move temp number)
-      (inst sr temp 16)
-      (inst bncx :eq upper-not-zero)
-      (inst li res 32)
-      ;; Upper half is all 0's, so get ready to subtract leading 0's in
-      ;; the lowerhalf from 16 to determine integer length.
-      (inst li res 16)
-      (move temp number)
-      (emit-label upper-not-zero)
-      ;; Here temp contains the upperhalf if not all 0's or the lowerhalf.
-      ;; Res contains the appropriate value (32 or 16) from which to subtract
-      ;; the number of leading 0's in temp to determine integer length.
-      (inst clz temp)
-      (inst s res temp))))
-
-;;; UNSIGNED-BYTE-32-COUNT -- VOP.
-;;;
-;;; To count the 1's in number, count how many times you can do the following:
-;;;    AND number and the result of subtracting 1 from number.
-;;;    Set number to the result of the AND operation.
-;;; This subtract and AND clears the lowest 1 in number, so when number becomes
-;;; zero, you're done.
-;;;
-(define-vop (unsigned-byte-32-count)
-  (:translate logcount)
-  (:note "inline (unsigned-byte 32) logcount")
-  (:policy :fast-safe)
-  (:args (arg :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:results (res :scs (any-reg)))
-  (:result-types positive-fixnum)
-  (:temporary (:scs (non-descriptor-reg)) number temp)
-  (:generator 14
-    (let ((loop (gen-label))
-	  (done (gen-label)))
-      ;; Move arg and tell us if number is zero, in which case res is 0.
-      (inst oil number arg 0)
-      (inst bcx :eq done)
-      (inst li res 0)
-      ;; Count 1's in number.
-      (emit-label loop)
-      (move temp number)
-      (inst s temp 1)
-      (inst n number temp)
-      (inst bncx :eq loop)
-      (inst a res (fixnum 1))
-      ;; We're done and res already has result.
-      (emit-label done))))      
-
-
-
-;;;; Binary conditional VOPs:
-
-(define-vop (fast-conditional)
-  (:conditional)
-  (:info target not-p)
-  (:effects)
-  (:affected)
-  (:policy :fast-safe))
-
-(define-vop (fast-conditional/fixnum fast-conditional)
-  (:args (x :scs (any-reg))
-	 (y :scs (any-reg)))
-  (:arg-types tagged-num tagged-num)
-  (:note "inline fixnum comparison"))
-
-(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
-  (:args (x :scs (any-reg)))
-  ;; Leave room in the signed field for
-  (:arg-types tagged-num (:constant (signed-byte 14)))
-  (:info target not-p y))
-
-(define-vop (fast-conditional/signed fast-conditional)
-  (:args (x :scs (signed-reg))
-	 (y :scs (signed-reg)))
-  (:arg-types signed-num signed-num)
-  (:note "inline (signed-byte 32) comparison"))
-
-(define-vop (fast-conditional-c/signed fast-conditional/signed)
-  (:args (x :scs (signed-reg)))
-  (:arg-types signed-num (:constant (signed-byte 16)))
-  (:info target not-p y))
-
-(define-vop (fast-conditional/unsigned fast-conditional)
-  (:args (x :scs (unsigned-reg))
-	 (y :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num)
-  (:note "inline (unsigned-byte 32) comparison"))
-
-(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
-  (:args (x :scs (unsigned-reg)))
-  (:arg-types unsigned-num (:constant (unsigned-byte 15)))
-  (:info target not-p y))
-
-
-(defmacro define-conditional-vop (translate &rest generator)
-  `(progn
-     ,@(mapcar #'(lambda (suffix cost signed)
-		   (unless (and (member suffix '(/fixnum -c/fixnum))
-				(eq translate 'eql))
-		     `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
-						    translate suffix))
-				   ,(intern
-				     (format nil "~:@(FAST-CONDITIONAL~A~)"
-					     suffix)))
-			(:translate ,translate)
-			(:generator ,cost
-			  (let* ((signed ,signed)
-				 (-c/fixnum ,(eq suffix '-c/fixnum))
-				 (y (if -c/fixnum (fixnum y) y)))
-			    ,@generator)))))
-	       '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
-	       ;; All these really take six cycles, but we decrease the -c/...
-	       ;; cost to prefer these VOPs since we avoid doing
-	       ;; load-immediates.  Then the first two are decreased by by one
-	       ;; more to prefer comparing the fixnum representation directly.
-	       '(5 4 6 5 6 5)
-	       '(t t t t nil nil))))
-
-(define-conditional-vop <
-  (if signed
-      (inst c x y)
-      (inst cl x y))
-  (if not-p
-      (inst bnc :lt target)
-      (inst bc :lt target)))
-
-(define-conditional-vop >
-  (if signed
-      (inst c x y)
-      (inst cl x y))
-  (if not-p
-      (inst bnc :gt target)
-      (inst bc :gt target)))
-
-;;; This only handles EQL of restricted integers, so it's simple.
-;;;
-(define-conditional-vop eql
-  (declare (ignore signed))
-  (inst c x y)
-  (if not-p
-      (inst bnc :eq target)
-      (inst bc :eq target)))
-
-
-;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
-;;; known fixnum.
-;;;
-
-(define-vop (fast-eql/fixnum fast-conditional)
-  (:args (x :scs (any-reg descriptor-reg))
-	 (y :scs (any-reg)))
-  (:arg-types * tagged-num)
-  (:note "inline fixnum comparison")
-  (:translate eql)
-  (:ignore temp)
-  (:generator 4
-    (inst c x y)
-    (if not-p
-	(inst bnc :eq target)
-	(inst bc :eq target))))
-
-(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:arg-types * (:constant (signed-byte 14)))
-  (:info target not-p y)
-  (:translate eql)
-  (:generator 3
-    (inst c x (fixnum y))
-    (if not-p
-	(inst bnc :eq target)
-	(inst bc :eq target))))
-
-
-
-;;;; 32-bit logical operations
-
-(define-vop (32bit-logical)
-  (:args (x :scs (unsigned-reg) :target r)
-	 (y :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num)
-  (:results (r :scs (unsigned-reg) :from (:argument 0)))
-  (:result-types unsigned-num)
-  (:policy :fast-safe))
-
-(define-vop (32bit-logical-not 32bit-logical)
-  (:translate 32bit-logical-not)
-  (:args (x :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:generator 1
-    (inst not r x)))
-
-(define-vop (32bit-logical-and 32bit-logical)
-  (:translate 32bit-logical-and)
-  (:generator 1
-    (move r x)
-    (inst n r y)))
-
-(deftransform 32bit-logical-nand ((x y) (* *))
-  '(32bit-logical-not (32bit-logical-and x y)))
-
-(define-vop (32bit-logical-or 32bit-logical)
-  (:translate 32bit-logical-or)
-  (:generator 1
-    (move r x)
-    (inst o r y)))
-
-(deftransform 32bit-logical-nor ((x y) (* *))
-  '(32bit-logical-not (32bit-logical-or x y)))
-
-(define-vop (32bit-logical-xor 32bit-logical)
-  (:translate 32bit-logical-xor)
-  (:generator 1
-    (move r x)
-    (inst x r y)))
-
-(deftransform 32bit-logical-eqv ((x y) (* *))
-  '(32bit-logical-not (32bit-logical-xor x y)))
-
-(deftransform 32bit-logical-andc1 ((x y) (* *))
-  '(32bit-logical-and (32bit-logical-not x) y))
-
-(deftransform 32bit-logical-andc2 ((x y) (* *))
-  '(32bit-logical-and x (32bit-logical-not y)))
-
-(deftransform 32bit-logical-orc1 ((x y) (* *))
-  '(32bit-logical-or (32bit-logical-not x) y))
-
-(deftransform 32bit-logical-orc2 ((x y) (* *))
-  '(32bit-logical-or x (32bit-logical-not y)))
-
-(define-vop (shift-towards-someplace)
-  (:policy :fast-safe)
-  (:args (num :scs (unsigned-reg) :target r :to (:eval 0))
-	 (amount :scs (signed-reg) :target temp))
-  (:temporary (:scs (signed-reg) :from (:argument 1)) temp)
-  (:arg-types unsigned-num tagged-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num))
-
-(define-vop (shift-towards-start shift-towards-someplace)
-  (:translate shift-towards-start)
-  (:note "SHIFT-TOWARDS-START")
-  (:generator 1
-    (move temp amount)
-    (inst nilz temp #x1f)
-    (move r num)
-    (inst sl r temp)))
-
-(define-vop (shift-towards-end shift-towards-someplace)
-  (:translate shift-towards-end)
-  (:note "SHIFT-TOWARDS-END")
-  (:generator 1
-    (move temp amount)
-    (inst nilz temp #x1f)
-    (move r num)
-    (inst sr r temp)))
-
-
-
-
-;;;; Bignum stuff.
-
-(define-vop (bignum-length get-header-data)
-  (:translate bignum::%bignum-length)
-  (:policy :fast-safe))
-
-(define-vop (bignum-set-length set-header-data)
-  (:translate bignum::%bignum-set-length)
-  (:policy :fast-safe))
-
-(define-vop (bignum-ref word-index-ref)
-  (:variant vm:bignum-digits-offset vm:other-pointer-type)
-  (:translate bignum::%bignum-ref)
-  (:results (value :scs (unsigned-reg)))
-  (:result-types unsigned-num))
-
-(define-vop (bignum-set word-index-set)
-  (:variant vm:bignum-digits-offset vm:other-pointer-type)
-  (:translate bignum::%bignum-set)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg immediate))
-	 (value :scs (unsigned-reg)))
-  (:arg-types t positive-fixnum unsigned-num)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num))
-
-(define-vop (digit-0-or-plus)
-  (:translate bignum::%digit-0-or-plusp)
-  (:policy :fast-safe)
-  (:args (digit :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 7
-    (let ((done (gen-label)))
-      (inst c digit 0)
-      (inst bcx :lt done)
-      (move result null-tn)
-      (load-symbol result 't)
-      (emit-label done))))
-
-(define-vop (add-w/carry)
-  (:translate bignum::%add-with-carry)
-  (:policy :fast-safe)
-  (:args (a :scs (unsigned-reg) :target result)
-	 (b :scs (unsigned-reg))
-	 (carry-in :scs (any-reg)))
-  (:arg-types unsigned-num unsigned-num positive-fixnum)
-  (:results (result :scs (unsigned-reg) :from (:argument 0))
-	    (carry :scs (unsigned-reg)))
-  (:result-types unsigned-num positive-fixnum)
-  (:temporary (:scs (non-descriptor-reg) :to (:argument 2)) temp)
-  (:generator 5
-    ;; Set the carry condition bit.
-    (inst a temp carry-in -1)
-    ;; Add A & B.
-    (move result a)
-    (inst ae result b)
-    ;; Set carry to the condition bit.
-    ;; Add zero to zero and see if we get a one.
-    (inst li carry 0)
-    (inst ae carry carry)))
-
-(define-vop (sub-w/borrow)
-  (:translate bignum::%subtract-with-borrow)
-  (:policy :fast-safe)
-  (:args (a :scs (unsigned-reg) :target result)
-	 (b :scs (unsigned-reg))
-	 (borrow-in :scs (any-reg)))
-  (:arg-types unsigned-num unsigned-num positive-fixnum)
-  (:results (result :scs (unsigned-reg) :from (:argument 0))
-	    (borrow :scs (unsigned-reg) :from :eval))
-  (:result-types unsigned-num positive-fixnum)
-  (:temporary (:scs (non-descriptor-reg)
-		    :from (:argument 0) :to (:argument 2)) temp)
-  (:generator 5
-    (move result a)
-    ;; Set the carry condition bit.
-    ;; Borrow-in is zero if there was a borrow, one if there was no borrow.
-    ;; The RT has the same sense with its C0 condition bit.
-    (inst a temp borrow-in -1)
-    (inst se result b)
-    ;; Set borrow to 0 if the carry condition bit is zero, or to 1 otherwise.
-    (inst li borrow 0)
-    (inst ae borrow borrow)))
-
-(define-vop (bignum-mult-and-add-3-arg)
-  (:translate bignum::%multiply-and-add)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:args (x :scs (unsigned-reg))
-	 (y :scs (unsigned-reg))
-	 (carry-in :scs (unsigned-reg unsigned-stack) :to (:eval 1)))
-  (:arg-types unsigned-num unsigned-num unsigned-num)
-  (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
-  (:temporary (:scs (unsigned-reg) :to (:result 0) :target high-res) high)
-  (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1)
-		    :target low-res) low)
-  (:results (high-res :scs (unsigned-reg))
-	    (low-res :scs (unsigned-reg)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 76
-    ;; Do the multiply.
-    (unsigned-multiply x y high low)
-
-    ;; Add the carry-in.
-    (sc-case carry-in
-      (unsigned-stack
-       (load-stack-tn temp carry-in vop)
-       (inst a low temp))
-      (unsigned-reg
-       (inst a low carry-in)))
-    (inst ae high 0)
-    (move high-res high)
-    (move low-res low)))
-
-(define-vop (bignum-mult-and-add-4-arg)
-  (:translate bignum::%multiply-and-add)
-  (:vop-var vop)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg))
-	 (y :scs (unsigned-reg))
-	 (prev :scs (unsigned-reg unsigned-stack) :to (:eval 1))
-	 (carry-in :scs (unsigned-reg unsigned-stack) :to (:eval 1)))
-  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
-  (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
-  (:temporary (:scs (unsigned-reg) :to (:result 0) :target high-res) high)
-  (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1)
-		    :target low-res) low)
-  (:results (high-res :scs (unsigned-reg))
-	    (low-res :scs (unsigned-reg)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 81
-    ;; Do the multiply.
-    (unsigned-multiply x y high low)
-
-    ;; Add the carry-in.
-    (sc-case carry-in
-      (unsigned-stack
-       (load-stack-tn temp carry-in vop)
-       (inst a low temp))
-      (unsigned-reg
-       (inst a low carry-in)))
-    (inst ae high 0)
-    
-    ;; Add in digit from accumulating result.
-    (sc-case carry-in
-      (unsigned-stack
-       (load-stack-tn temp prev vop)
-       (inst a low temp))
-      (unsigned-reg
-       (inst a low prev)))
-    (inst ae high 0)
-    (move high-res high)
-    (move low-res low)))
-
-(define-vop (bignum-mult)
-  (:translate bignum::%multiply)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg))
-	 (y :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num)
-  (:results (high :scs (unsigned-reg) :from :load)
-	    (low :scs (unsigned-reg)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 74
-    ;; Do the multiply.
-    (unsigned-multiply x y high low)))
-
-;;; UNSIGNED-MULTIPLY -- Internal.
-;;;
-;;; The RT has a signed multiply.  To unsigned-multiply bignum digits, we use
-;;; the following identity:
-;;;    signed-interpretation
-;;;       =  unsigned-interpretation  -  (sign-bit)(2^32)
-;;;    ==>
-;;;    ui = si + (sb)(2^32)
-;;; This gives us the following equation:
-;;;    (ui1) (ui2)  =  [si1 + (sb1)(2^32)] [si2 + (sb2)(2^32)]
-;;;    (ui1) (ui2)  =  (si1) (si2)
-;;;                  + [(sb1)(si2) + (sb2)(si1)] (2^32)
-;;; 		     + (sb1)(sb2)(2^32)
-;;; Inspection and the fact that the result must fit into 64 bits reveals that
-;;; the third time can always be ignored.
-;;;
-(defun unsigned-multiply (x y high low)
-  ;; Setup system register for multiply.
-  (inst mtmqscr x)
-  
-  ;; Do the multiply.
-  ;; Subtract high from high to set it to zero and to set the C0 condition
-  ;; bit appropriately for the m instruction.
-  (inst s high high)
-  (dotimes (i 16)
-    (inst m high y))
-  ;; Adjust high word of result for unsigned multiply.
-  ;; If x is negative, add in y.  If y is negative, add in x.
-  (let ((x-pos (gen-label))
-	(y-pos (gen-label)))
-    (inst c x 0)
-    (inst bnc :lt x-pos)
-    (inst a high y)
-    (emit-label x-pos)
-    (inst c y 0)
-    (inst bnc :lt y-pos)
-    (inst a high x)
-    (emit-label y-pos))
-  
-  ;; Get the low 32 bits of the product.
-  (inst mfmqscr low))
-
-
-(define-vop (bignum-lognot)
-  (:translate bignum::%lognot)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (inst not r x)))
-
-(define-vop (fixnum-to-digit)
-  (:translate bignum::%fixnum-to-digit)
-  (:policy :fast-safe)
-  (:args (fixnum :scs (any-reg) :target digit))
-  (:arg-types tagged-num)
-  (:results (digit :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (move digit fixnum)
-    (inst sar digit 2)))
-
-;;; BIGNUM-FLOOR -- VOP.
-;;;
-;;; The way the bignum code uses this allows us to ignore dividing by 0, 1, or
-;;; -1.  Furthermore, we always divided a positive high:low value by a positive
-;;; divisor value.  This means we don't have to worry about using the RT's
-;;; signed divide instruction to get an unsigned division result.
-;;;
-;;; We are going to copy the GENERIC-TRUNCATE assembly routine to implement
-;;; this since FLOOR and TRUNCATE return the same values for positive
-;;; arguments.  However, we do modify it slightly to make use of the positive
-;;; nature of the arguments.
-;;;
-(define-vop (bignum-floor)
-  (:translate bignum::%floor)
-  (:policy :fast-safe)
-  (:args (dividend-high :scs (unsigned-reg) :target rem)
-	 (dividend-low :scs (unsigned-reg))
-	 (divisor :scs (unsigned-reg) :to (:eval 1)))
-  (:arg-types unsigned-num unsigned-num unsigned-num)
-  (:results (quo :scs (unsigned-reg))
-	    (rem :scs (unsigned-reg) :from (:eval 0)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 44
-    (inst mtmqscr dividend-low)
-    (move rem dividend-high)
-    (dotimes (i 32)
-      (inst d rem divisor))
-    ;; Check preliminary remainder by considering signs of rem and divisor.
-    ;; This is an extra step to account for the non-restoring divide-step instr.
-    ;; We don't actually have to check this since the d instruction set :c0
-    ;; when the signs of rem and divisor are the same.
-    (let ((rem-okay (gen-label)))
-      (inst bc :c0 rem-okay)
-      (inst a rem divisor)
-      (emit-label rem-okay))
-
-    (let ((move-results (gen-label)))
-      ;; The RT gives us some random division concept, but we're writing
-      ;; TRUNCATE.  The fixup involves adding one to the quotient and
-      ;; subtracting the divisor from the remainder under certain
-      ;; circumstances (for this VOP, as opposed to the assembly routine,
-      ;; this boils down to one test):
-      ;;
-      ;; IF the remainder is equal to the divisor, we can obviously take
-      ;; one more divisor out of the dividend, so do it.
-      (inst c rem divisor)
-      (inst bnc :eq move-results) ;Just fall through to do it.
-
-      ;; Add 1 to quotient and subtract divisor from remainder.
-      (inst mfmqscr quo)
-      (inst inc quo 1)
-      (inst s rem divisor)
-      
-      (emit-label move-results))
-
-    (inst mfmqscr quo)))
-
-
-;;; SIGNIFY-DIGIT -- VOP.
-;;;
-;;; This is supposed to make digit into a fixnum which is signed.  We just
-;;; move it here, letting the compiler's operand motion stuff make this
-;;; result into a fixnum.
-;;;
-(define-vop (signify-digit)
-  (:translate bignum::%fixnum-digit-with-correct-sign)
-  (:policy :fast-safe)
-  (:args (digit :scs (unsigned-reg) :target res))
-  (:arg-types unsigned-num)
-  (:results (res :scs (signed-reg)))
-  (:result-types signed-num)
-  (:generator 1
-    (move res digit)))
-
-(define-vop (digit-ashr)
-  (:translate bignum::%ashr)
-  (:policy :fast-safe)
-  (:args (digit :scs (unsigned-reg) :target result)
-	 (count :scs (unsigned-reg immediate)))
-  (:arg-types unsigned-num positive-fixnum)
-  (:results (result :scs (unsigned-reg) :from (:argument 0)))
-  (:result-types unsigned-num)
-  (:generator 2
-    (move result digit)
-    (inst sar result
-	  (sc-case count
-	    (unsigned-reg count)
-	    (immediate (tn-value count))))))
-
-(define-vop (digit-lshr digit-ashr)
-  (:translate bignum::%digit-logical-shift-right)
-  (:generator 2
-    (move result digit)
-    (inst sr result
-	  (sc-case count
-	    (unsigned-reg count)
-	    (immediate (tn-value count))))))
-
-(define-vop (digit-ashl digit-ashr)
-  (:translate bignum::%ashl)
-  (:generator 2
-    (move result digit)
-    (inst sl result
-	  (sc-case count
-	    (unsigned-reg count)
-	    (immediate (tn-value count))))))
-
-
-
-;;;; Static functions.
-
-(define-static-function two-arg-gcd (x y) :translate gcd)
-(define-static-function two-arg-lcm (x y) :translate lcm)
-
-(define-static-function two-arg-/ (x y) :translate /)
-
-(define-static-function %negate (x) :translate %negate)
-
-(define-static-function two-arg-and (x y) :translate logand)
-(define-static-function two-arg-ior (x y) :translate logior)
-(define-static-function two-arg-xor (x y) :translate logxor)
diff --git a/compiler/rt/array.lisp b/compiler/rt/array.lisp
deleted file mode 100644
index dabac38c3b3dcc6198fe1e77547f29603889e491..0000000000000000000000000000000000000000
--- a/compiler/rt/array.lisp
+++ /dev/null
@@ -1,584 +0,0 @@
-;;; -*- Package: RT; 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/rt/array.lisp,v 1.10 1992/01/29 20:22:12 ram Exp $
-;;;
-;;; This file contains the IBM RT definitions for array operations.
-;;;
-;;; Written by William Lott and Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-;;;; Allocator for the array header.
-
-(define-vop (make-array-header)
-  (:translate make-array-header)
-  (:policy :fast-safe)
-  (:args (type :scs (any-reg descriptor-reg))
-	 (rank :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
-  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
-  (:temporary (:sc word-pointer-reg) alloc)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 0
-    (pseudo-atomic (ndescr)
-      ;; Take free pointer and make descriptor pointer for the result.  Just
-      ;; add in the three low-tag bits since alloc ptr is dual-word aligned,
-      ;; and its three low bits are zero.
-      (load-symbol-value alloc *allocation-pointer*)
-      (inst cal header alloc vm:other-pointer-type)
-      (inst cal alloc alloc
-	    (+ (* vm:array-dimensions-offset vm:word-bytes)
-	       vm:lowtag-mask))
-      ;; Rank is the dimensions as a fixnum which happens to be the number of
-      ;; bytes (by the machine's interpretation) we need to add to the alloc
-      ;; ptr.
-      (inst cas alloc rank alloc)
-      (inst nilo alloc (logand #xFFFF (lognot vm:lowtag-mask)))
-      (store-symbol-value alloc *allocation-pointer*)
-      (inst cal ndescr rank (fixnum (1- vm:array-dimensions-offset)))
-      ;; Shift the fixnum representation of the length, then OR in the fixnum
-      ;; rep of the type code, and then shift off the two extra fixnum zeros.
-      (inst sl ndescr vm:type-bits)
-      (inst o ndescr type)
-      (inst sr ndescr 2)
-      (storew ndescr header 0 vm:other-pointer-type))
-    (load-symbol-value ndescr *internal-gc-trigger*)
-    (inst tlt ndescr alloc)
-    (move result header)))
-
-
-
-;;;; Additional accessors and setters for the array header.
-
-(defknown lisp::%array-dimension (t fixnum) fixnum
-  (flushable))
-(defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum
-  ())
-
-(define-vop (%array-dimension word-index-ref)
-  (:translate lisp::%array-dimension)
-  (:policy :fast-safe)
-  (:variant vm:array-dimensions-offset vm:other-pointer-type))
-
-(define-vop (%set-array-dimension word-index-set)
-  (:translate lisp::%set-array-dimension)
-  (:policy :fast-safe)
-  (:variant vm:array-dimensions-offset vm:other-pointer-type))
-
-
-
-(defknown lisp::%array-rank (t) fixnum (flushable))
-
-;;; ARRAY-RANK-VOP -- VOP.
-;;;
-;;; The length of the array header manifests the rank of the array.  We fetch
-;;; the header word, extract the length, and subtract off the start of the
-;;; dimension slots.
-;;;
-(define-vop (array-rank-vop)
-  (:translate lisp::%array-rank)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg) :type random :target res) temp)
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 6
-    (loadw temp x 0 vm:other-pointer-type)
-    (inst sr temp vm:type-bits)
-    (inst s temp (1- vm:array-dimensions-offset))
-    (inst sl temp 2)
-    (move res temp)))
-
-
-
-;;;; Bounds checking routine.
-
-(define-vop (check-bound)
-  (:translate %check-bound)
-  (:policy :fast-safe)
-  (:args (array :scs (descriptor-reg))
-	 (bound :scs (any-reg descriptor-reg))
-	 (index :scs (any-reg descriptor-reg) :target result))
-  (:results (result :scs (any-reg descriptor-reg)))
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 5
-    (let ((error (generate-error-code vop invalid-array-index-error
-				      array bound index)))
-      (inst c index bound)
-      (inst bnc :lt error)
-      (move result index))))
-
-
-
-;;;; 32-bit, 16-bit, and 8-bit vectors.
-
-;;; We build these variants on top of VOP's defined in memory.lisp.  These
-;;; vectors' elements are represented in integer registers and are built out of
-;;; 8, 16, or 32 bit elements.
-
-(eval-when (compile eval)
-(defmacro def-data-vector-frobs (type variant element-type &rest scs)
-  `(progn
-     (define-vop (,(intern (concatenate 'simple-string
-					"DATA-VECTOR-REF/"
-					(string type)))
-		  ,(intern (concatenate 'simple-string
-					(string variant)
-					"-REF")))
-       (:note "inline array access")
-       (:variant vm:vector-data-offset vm:other-pointer-type)
-       (:translate data-vector-ref)
-       (:arg-types ,type positive-fixnum)
-       (:results (value :scs ,scs))
-       (:result-types ,element-type))
-     (define-vop (,(intern (concatenate 'simple-string
-					"DATA-VECTOR-SET/"
-					(string type)))
-		  ,(intern (concatenate 'simple-string
-					(string variant)
-					"-SET")))
-       (:note "inline array store")
-       (:variant vm:vector-data-offset vm:other-pointer-type)
-       (:translate data-vector-set)
-       (:arg-types ,type positive-fixnum ,element-type)
-       (:args (object :scs (descriptor-reg))
-	      (index :scs (any-reg immediate))
-	      (value :scs ,scs))
-       (:results (result :scs ,scs))
-       (:result-types ,element-type))))
-) ;EVAL-WHEN
-
-(def-data-vector-frobs simple-string byte-index
-  base-char base-char-reg)
-(def-data-vector-frobs simple-vector word-index
-  * descriptor-reg any-reg)
-
-(def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
-  positive-fixnum unsigned-reg)
-(def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
-  positive-fixnum unsigned-reg)
-(def-data-vector-frobs simple-array-unsigned-byte-32 word-index
-  unsigned-num unsigned-reg)
-
-
-
-;;;; Integer vectors with 1, 2, and 4 bit elements.
-
-(eval-when (compile eval)
-
-(defmacro def-small-data-vector-frobs (type bits)
-  (let* ((elements-per-word (floor vm:word-bits bits))
-	 (bit-shift (1- (integer-length elements-per-word))))
-    `(progn
-       (define-vop (,(symbolicate 'data-vector-ref/ type))
-	 (:note "inline array access")
-	 (:translate data-vector-ref)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(index :scs (unsigned-reg)))
-	 (:arg-types ,type positive-fixnum)
-	 (:results (value :scs (any-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
-	 (:generator 20
-	   (move temp index)
-	   (inst sr temp ,bit-shift)
-	   (inst sl temp 2)
-	   (move lip object)
-	   (inst a lip temp)
-	   (loadw result lip vm:vector-data-offset vm:other-pointer-type)
-	   (inst nilz temp index ,(1- elements-per-word))
-	   (inst xil temp ,(1- elements-per-word))
-	   ,@(unless (= bits 1)
-	       `((inst sl temp ,(1- (integer-length bits)))))
-	   (inst sr result temp)
-	   (inst nilz result ,(1- (ash 1 bits)))
-	   (move value result)
-	   (inst sl value 2)))
-       (define-vop (,(symbolicate 'data-vector-ref-c/ type))
-	 (:translate data-vector-ref)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg)))
-	 (:arg-types ,type (:constant index))
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:info index)
-	 (:results (result :scs (unsigned-reg)))
-	 (:result-types positive-fixnum)
-	 (:generator 15
-	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
-	     (setf extra (logxor extra (1- ,elements-per-word)))
-	     (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
-			      vm:other-pointer-type)))
-	       (cond ((typep offset '(signed-byte 16))
-		      ;; Use the load with immediate offset if possible.
-		      (inst l result offset))
-		     (t
-		      ;; Load the upper half of the offset in one instruction
-		      ;; and add the lower half as an immediate offset in
-		      ;; the load.  NOTE: if bit 15 is on, the load will sign-
-		      ;; extend it, so we have to add 1 to the upper half now
-		      ;; to counter the effect of the -1 from the sign-extension.
-		      (inst cau lip object
-			    (if (logbitp 15 offset)
-				(1+ (ash offset -16))
-				(ash offset -16)))
-		      (inst l result lip (logand #xFFFF offset)))))
-	     (unless (zerop extra)
-	       (inst sr result (* extra ,bits)))
-	     (unless (= extra ,(1- elements-per-word))
-	       (inst n result ,(1- (ash 1 bits)))))))
-       (define-vop (,(symbolicate 'data-vector-set/ type))
-	 (:note "inline array store")
-	 (:translate data-vector-set)
-	 (:policy :fast-safe)
-	 (:vop-var vop)
-	 (:args (object :scs (descriptor-reg) :to (:eval 0))
-		;; Normally, we would take the next arg in an unsigned-reg too.
-		;; This caused a discrimination problem in the compiler for
-		;; choosing a move function.  Since this VOP uses so many
-		;; non-descriptor registers anyway which has been a hassle, we
-		;; just removed unsigned-reg.
-		(index :scs (any-reg) :to (:eval 1))
-		(value :scs (unsigned-reg immediate)
-		       :load-if (not (sc-is value unsigned-stack))
-		       :target value-save))
-	 (:arg-types ,type positive-fixnum positive-fixnum)
-	 (:results (result :scs (unsigned-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (unsigned-stack) :from (:argument 2)) value-save)
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:temporary (:scs (non-descriptor-reg) :from (:argument 2)
-			   :to (:result 0)) temp)
-	 (:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:result 0))
-		     old)
-	 (:temporary (:scs (non-descriptor-reg) :from (:eval 1) :to (:result 0))
-		     shift)
-	 (:generator 25
-	   (when (sc-is value unsigned-reg)
-	     (storew value (current-nfp-tn vop) (tn-offset value-save)))
-	   (move temp index)
-	   (inst sr temp
-		 (sc-case index
-		   ;; In addition to dividing the index to map it to
-		   ;; a number of words to skip, shift off the fixnum tag
-		   ;; bits too.
-		   (any-reg ,(+ bit-shift 2))
-		   ;; No extraneous bits in this case.
-		   (unsigned-reg ,bit-shift)))
-	   (inst sl temp 2)
-	   (move lip object)
-	   (inst a lip temp)
-	   (loadw old lip vm:vector-data-offset vm:other-pointer-type)
-	   (sc-case index
-	     (unsigned-reg
-	      (inst nilz shift index ,(1- elements-per-word))
-	      ,@(unless (= bits 1)
-		  `((inst sl shift ,(1- (integer-length bits))))))
-	     (any-reg
-	      (inst nilz shift index ,(ash (1- elements-per-word) 2))
-	      ,@(unless (= bits 4)
-		  `((inst sr shift ,(- 3 (integer-length bits)))))))
-	   (inst xil shift ,(1- elements-per-word))
-	      
-	   ;; Unless our immediate is all 1's, zero the destination bits.
-	   (unless (and (sc-is value immediate)
-			(= (tn-value value) ,(1- (ash 1 bits))))
-	     (inst li temp ,(1- (ash 1 bits)))
-	     (inst sl temp shift)
-	     (inst not temp)
-	     (inst n old temp))
-	   ;; Unless the value is zero, really deposit it.
-	   (unless (and (sc-is value immediate)
-			(zerop (tn-value value)))
-	     (sc-case value
-	       (immediate
-		(inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
-	       ((unsigned-reg unsigned-stack)
-		(loadw temp (current-nfp-tn vop)
-		       (tn-offset (if (sc-is value unsigned-stack)
-				      value
-				      value-save)))
-		(inst nilz temp ,(1- (ash 1 bits)))))
-	     (inst sl temp shift)
-	     (inst o old temp))
-	   (storew old lip vm:vector-data-offset vm:other-pointer-type)
-	   (sc-case value
-	     (immediate
-	      (inst li result (tn-value value)))
-	     ((unsigned-reg unsigned-stack)
-	      (loadw result (current-nfp-tn vop)
-		     (tn-offset (if (sc-is value unsigned-stack)
-				    value
-				    value-save)))))))
-       (define-vop (,(symbolicate 'data-vector-set-c/ type))
-	 (:translate data-vector-set)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(value :scs (unsigned-reg immediate) :target result))
-	 (:arg-types ,type (:constant index) positive-fixnum)
-	 (:temporary (:scs (interior-reg)) lip)
-	 (:info index)
-	 (:results (result :scs (unsigned-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (non-descriptor-reg)) temp old)
-	 (:generator 20
-	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
-	     (setf extra (logxor extra (1- ,elements-per-word)))
-	     (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
-			      vm:other-pointer-type)))
-	       (cond ((typep offset '(signed-byte 16))
-		      ;; Use the load with immediate offset if possible.
-		      (inst l old offset))
-		     (t
-		      ;; Load the upper half of the offset in one instruction
-		      ;; and add the lower half as an immediate offset in
-		      ;; the load.  NOTE: if bit 15 is on, the load will sign-
-		      ;; extend it, so we have to add 1 to the upper half now
-		      ;; to counter the effect of the -1 from the sign-extension.
-		      (inst cau lip object
-			    (if (logbitp 15 offset)
-				(1+ (ash offset -16))
-				(ash offset -16)))
-		      (inst l old lip (logand #xFFFF offset)))))
-	     ;; Unless our immediate is all 1's, zero the destination bits.
-	     (unless (and (sc-is value immediate)
-			  (= (tn-value value) ,(1- (ash 1 bits))))
-	       (inst li temp
-		     (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits))))
-	       (inst n old temp))
-	     ;; Unless the value is zero, really deposit it.
-	     (unless (and (sc-is value immediate)
-			  (zerop (tn-value value)))
-	       (sc-case value
-		 (immediate
-		  (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
-				    (* extra ,bits))))
-		    ;; Isn't this test silly, or the otherwise branch doesn't
-		    ;; work anyway????
-		    (cond ((< value #x10000)
-			   (inst oil old (logand #xFF value))
-			   (inst oiu old (logand #xFF00 value)))
-			  (t
-			   (inst li temp value)
-			   (inst o old temp)))))
-		 (unsigned-reg
-		  (move temp value)
-		  ;; Shouldn't we do this to check the size of the value?
-		  (inst nilz temp ,(1- (ash 1 bits)))
-		  (inst sl temp (* extra ,bits))
-		  (inst o old temp))))
-	     (storew old object vm:vector-data-offset vm:other-pointer-type)
-	     (sc-case value
-	       (immediate
-		(inst li result (tn-value value)))
-	       (unsigned-reg
-		(move result value)))))))))
-
-) ;EVAL-WHEN
-
-(def-small-data-vector-frobs simple-bit-vector 1)
-(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
-(def-small-data-vector-frobs simple-array-unsigned-byte-4 4)
-
-
-
-;;;; Float vectors.
-
-#-afpa(progn
-(define-vop (data-vector-ref/simple-array-mc68881-single-float)
-  (:note "inline array access")
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg)))
-  (:arg-types simple-array-single-float positive-fixnum)
-  (:results (value :scs (mc68881-single-reg)))
-  (:result-types mc68881-single-float)
-  (:temporary (:sc sap-reg :from :eval) scratch)
-  (:temporary (:scs (interior-reg)) lip)
-  (:generator 20
-    (inst cas lip object index)
-    (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
-		     vm:other-pointer-type))
-    (inst mc68881-load value lip :single scratch)))
-
-(define-vop (data-vector-set/simple-array-mc68881-single-float)
-  (:note "inline array store")
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg))
-	 (value :scs (mc68881-single-reg) :target result))
-  (:arg-types simple-array-single-float positive-fixnum mc68881-single-float)
-  (:results (result :scs (mc68881-single-reg)))
-  (:result-types mc68881-single-float)
-  (:temporary (:scs (interior-reg)) lip)
-  (:temporary (:sc sap-reg :from :eval) scratch)
-  (:generator 20
-    (inst cas lip object index)
-    (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
-		     vm:other-pointer-type))
-    (inst mc68881-store value lip :single scratch)
-    (unless (location= result value)
-      (inst mc68881-move result value scratch))))
-
-(define-vop (data-vector-ref/simple-array-mc68881-double-float)
-  (:note "inline array access")
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg)))
-  (:arg-types simple-array-double-float positive-fixnum)
-  (:results (value :scs (mc68881-double-reg)))
-  (:result-types mc68881-double-float)
-  (:temporary (:scs (interior-reg)) lip)
-  (:temporary (:sc sap-reg :from :eval) scratch)
-  (:generator 20
-    (inst cas lip object index)
-    (inst cas lip lip index)
-    (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
-		     vm:other-pointer-type))
-    (inst mc68881-load value lip :double scratch)))
-
-(define-vop (data-vector-set/simple-array-mc68881-double-float)
-  (:note "inline array store")
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg))
-	 (value :scs (mc68881-double-reg) :target result))
-  (:arg-types simple-array-double-float positive-fixnum mc68881-double-float)
-  (:results (result :scs (mc68881-double-reg)))
-  (:result-types mc68881-double-float)
-  (:temporary (:scs (interior-reg)) lip)
-  (:temporary (:sc sap-reg :from :eval) scratch)
-  (:generator 20
-    (inst cas lip object index)
-    (inst cas lip lip index)
-    (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
-		     vm:other-pointer-type))
-    (inst mc68881-store value lip :double scratch)
-    (unless (location= result value)
-      (inst mc68881-move result value scratch))))
-)
-
-#+afpa(progn
-(define-vop (data-vector-ref/simple-array-afpa-single-float)
-  (:note "inline array access")
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg)))
-  (:arg-types simple-array-single-float positive-fixnum)
-  (:results (value :scs (afpa-single-reg)))
-  (:result-types afpa-single-float)
-  (:temporary (:sc sap-reg :from :eval) scratch)
-  (:temporary (:scs (interior-reg)) lip)
-  (:generator 20
-    (inst cas lip object index)
-    (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
-		     vm:other-pointer-type))
-    (inst afpa-load value lip :single scratch)
-    (inst afpa-noop scratch)))
-
-(define-vop (data-vector-set/simple-array-afpa-single-float)
-  (:note "inline array store")
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg))
-	 (value :scs (afpa-single-reg) :target result))
-  (:arg-types simple-array-single-float positive-fixnum afpa-single-float)
-  (:results (result :scs (afpa-single-reg)))
-  (:result-types afpa-single-float)
-  (:temporary (:scs (interior-reg)) lip)
-  (:temporary (:sc sap-reg :from :eval) scratch)
-  (:generator 20
-    (inst cas lip object index)
-    (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
-		     vm:other-pointer-type))
-    (inst afpa-store value lip :single scratch)
-    (inst afpa-noop scratch)
-    (unless (location= result value)
-      (inst afpa-move result value :single scratch))))
-
-(define-vop (data-vector-ref/simple-array-afpa-double-float)
-  (:note "inline array access")
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg)))
-  (:arg-types simple-array-double-float positive-fixnum)
-  (:results (value :scs (afpa-double-reg)))
-  (:result-types afpa-double-float)
-  (:temporary (:scs (interior-reg)) lip)
-  (:temporary (:sc sap-reg :from :eval) scratch)
-  (:generator 20
-    (inst cas lip object index)
-    (inst cas lip lip index)
-    (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
-		     vm:other-pointer-type))
-    (inst afpa-load value lip :double scratch)
-    (inst afpa-noop scratch)))
-
-(define-vop (data-vector-set/simple-array-afpa-double-float)
-  (:note "inline array store")
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg))
-	 (value :scs (afpa-double-reg) :target result))
-  (:arg-types simple-array-double-float positive-fixnum afpa-double-float)
-  (:results (result :scs (afpa-double-reg)))
-  (:result-types afpa-double-float)
-  (:temporary (:scs (interior-reg)) lip)
-  (:temporary (:sc sap-reg :from :eval) scratch)
-  (:generator 20
-    (inst cas lip object index)
-    (inst cas lip lip index)
-    (inst inc lip (- (* vm:vector-data-offset vm:word-bytes)
-		     vm:other-pointer-type))
-    (inst afpa-store value lip :double scratch)
-    (inst afpa-noop scratch)
-    (unless (location= result value)
-      (inst afpa-move result value :double scratch))))
-)
-
-
-;;;; Raw bits without regard to vector type.
-
-(define-vop (raw-bits word-index-ref)
-  (:note "raw-bits VOP")
-  (:translate %raw-bits)
-  (:results (value :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:variant 0 vm:other-pointer-type))
-
-(define-vop (set-raw-bits word-index-set)
-  (:note "setf raw-bits VOP")
-  (:translate %set-raw-bits)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg immediate))
-	 (value :scs (unsigned-reg)))
-  (:arg-types * positive-fixnum unsigned-num)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:variant 0 vm:other-pointer-type))
-
-
-
-;;;; Vector subtype frobs.
-
-(define-vop (get-vector-subtype get-header-data))
-(define-vop (set-vector-subtype set-header-data))
diff --git a/compiler/rt/c-call.lisp b/compiler/rt/c-call.lisp
deleted file mode 100644
index e893edd3e270d81f7bc8b76a59fb78fb54fd1c11..0000000000000000000000000000000000000000
--- a/compiler/rt/c-call.lisp
+++ /dev/null
@@ -1,217 +0,0 @@
-;;; -*- Package: RT -*-
-;;;
-;;; **********************************************************************
-;;; 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/rt/c-call.lisp,v 1.10 1992/03/25 16:14:44 wlott Exp $
-;;;
-;;; This file contains the VOPs and other necessary machine specific support
-;;; routines for call-out to C.
-;;;
-;;; Written by William Lott.
-;;; Converted by Bill Chiles.
-;;;
-
-(in-package "RT")
-(use-package "ALIEN")
-(use-package "ALIEN-INTERNALS")
-
-
-
-;;;; Make-call-out-tns and support stuff.
-
-(defun c-call-wired-tn (primitive-type sc-name offset)
-  (make-wired-tn (primitive-type-or-lose primitive-type)
-		 (sc-number-or-lose sc-name)
-		 offset))
-
-
-(defstruct arg-state
-  (offset 0))
-
-(defun int-arg (state prim-type stack-sc)
-  ;; C expects 4 register args and the 5th arg at the top of the stack.
-  ;; We can't put args in registers, because we need those registers
-  ;; for something else.  So we put them just beyond the end of the
-  ;; stack and the trampoline code will move them into place.
-  (let ((frame-size (arg-state-offset state)))
-    (setf (arg-state-offset state) (1+ frame-size))
-    (c-call-wired-tn prim-type stack-sc frame-size)))
-
-(defun int-result (state prim-type reg-sc)
-  (let ((reg-num (arg-state-offset state)))
-    (setf (arg-state-offset state) (1+ reg-num))
-    (c-call-wired-tn prim-type reg-sc reg-num)))
-
-(def-alien-type-method (integer :arg-tn) (type state)
-  (if (alien-integer-type-signed type)
-      (int-arg state 'signed-byte-32 'signed-stack)
-      (int-arg state 'unsigned-byte-32 'unsigned-stack)))
-
-(def-alien-type-method (integer :result-tn) (type state)
-  (if (alien-integer-type-signed type)
-      (int-result state 'signed-byte-32 'signed-reg)
-      (int-result state 'unsigned-byte-32 'unsigned-reg)))
-
-(def-alien-type-method (system-area-pointer :arg-tn) (type state)
-  (declare (ignore type))
-  (int-arg state 'system-area-pointer 'sap-stack))
-
-(def-alien-type-method (system-area-pointer :result-tn) (type state)
-  (declare (ignore type))
-  (int-result state 'system-area-pointer 'sap-reg))
-
-(def-alien-type-method (values :result-tn) (type state)
-  (mapcar #'(lambda (type)
-	      (invoke-alien-type-method :result-tn type state))
-	  (alien-values-type-values type)))
-
-(def-vm-support-routine make-call-out-tns (type)
-  (declare (type alien-function-type type))
-  (let ((arg-state (make-arg-state)))
-    (collect ((arg-tns))
-      (dolist (arg-type (alien-function-type-arg-types type))
-	(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
-      (values (c-call-wired-tn 'positive-fixnum 'word-pointer-reg nsp-offset)
-	      (* (arg-state-offset arg-state) word-bytes)
-	      (arg-tns)
-	      (invoke-alien-type-method
-	       :result-tn
-	       (alien-function-type-result-type type)
-	       (make-arg-state :offset nl0-offset))))))
-
-
-;;;; Deftransforms to convert uses of %alien-funcall into cononical form.
-
-(deftransform %alien-funcall ((function type &rest args)
-			      (t * &rest t))
-  (assert (c::constant-continuation-p type))
-  (let* ((type (c::continuation-value type))
-	 (arg-types (alien-function-type-arg-types type))
-	 (result-type (alien-function-type-result-type type)))
-    (assert (= (length arg-types) (length args)))
-    (if (some #'alien-double-float-type-p arg-types)
-	(collect ((new-args) (lambda-vars) (new-arg-types))
-	  (dolist (type arg-types)
-	    (let ((arg (gensym)))
-	      (lambda-vars arg)
-	      (typecase type
-		(alien-double-float-type
-		 (new-args `(double-float-high-bits ,arg))
-		 (new-args `(double-float-low-bits ,arg))
-		 (new-arg-types (parse-alien-type '(signed 32)))
-		 (new-arg-types (parse-alien-type '(unsigned 32))))
-		(t
-		 (new-args arg)
-		 (new-arg-types type)))))
-	  `(lambda (function type ,@(lambda-vars))
-	     (declare (ignore type))
-	     (%alien-funcall function
-			     ',(make-alien-function-type
-				:arg-types (new-arg-types)
-				:result-type result-type)
-			     ,@(new-args))))
-	(c::give-up))))
-
-(deftransform %alien-funcall ((function type &rest args)
-			      (* t &rest t))
-  (assert (c::constant-continuation-p type))
-  (let* ((type (c::continuation-value type))
-	 (arg-types (alien-function-type-arg-types type))
-	 (result-type (alien-function-type-result-type type)))
-    (assert (= (length arg-types) (length args)))
-    (flet ((make-arg-name-list ()
-	     (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
-		     arg-types)))
-      (typecase result-type
-	(alien-double-float-type
-	 (let ((arg-names (make-arg-name-list)))
-	   `(lambda (function type ,@arg-names)
-	      (declare (ignore type))
-	      (multiple-value-bind
-		  (hi lo)
-		  (%alien-funcall function
-				  ',(make-alien-function-type
-				     :arg-types arg-types
-				     :result-type
-				     (let ((*values-type-okay* t))
-				       (parse-alien-type
-					'(values (signed 32)
-						 (unsigned 32)))))
-				  ,@arg-names)
-	      (make-double-float hi lo)))))
-	(alien-single-float-type
-	 (let ((arg-names (make-arg-name-list)))
-	   `(lambda (function type ,@arg-names)
-	      (declare (ignore type))
-	      (make-single-float
-	       (%alien-funcall function
-			       ',(parse-alien-type
-				  `(function (signed 32) ,@arg-types))
-			       ,@arg-names)))))
-	(t
-	 (c::give-up))))))
-
-
-;;;; Vops.
-
-
-(define-vop (foreign-symbol-address)
-  (:translate foreign-symbol-address)
-  (:policy :fast-safe)
-  (:args)
-  (:arg-types (:constant simple-string))
-  (:info foreign-symbol)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 2
-    (inst cai res (make-fixup (concatenate 'simple-string "_" foreign-symbol)
-			      :foreign))))
-
-(define-vop (call-out)
-  (:args (function :scs (sap-reg) :target nl0)
-	 (args :more t))
-  (:results (results :more t))
-  (:ignore args results)
-  (:save-p t)
-  (:temporary (:sc any-reg :offset nl0-offset
-		   :from (:argument 0) :to (:result 0)) nl0)
-  (:temporary (:sc any-reg :offset lra-offset) lra)
-  (:temporary (:sc any-reg :offset code-offset) code)
-  (:temporary (:scs (sap-reg) :to (:result 0)) temp)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:vop-var vop)
-  (:generator 0
-    (let ((lra-label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
-      (move nl0 function)
-      (when cur-nfp
-	(store-stack-tn cur-nfp nfp-save))
-      (inst compute-lra-from-code lra code lra-label)
-      (inst cai temp (make-fixup "call_into_c" :foreign))
-      (inst b temp)
-
-      (align vm:lowtag-bits)
-      (emit-label lra-label)
-      (inst lra-header-word)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save)))))
-
-(define-vop (alloc-number-stack-space)
-  (:info amount)
-  (:results (result :scs (sap-reg any-reg)))
-  (:generator 0
-    (unless (zerop amount)
-      (inst cal nsp-tn nsp-tn (- (logandc2 (+ amount 7) 7))))
-    (move result nsp-tn)))
-
-(define-vop (dealloc-number-stack-space)
-  (:info amount)
-  (:policy :fast-safe)
-  (:generator 0
-    (unless (zerop amount)
-      (inst cal nsp-tn  nsp-tn (logandc2 (+ amount 7) 7)))))
diff --git a/compiler/rt/call.lisp b/compiler/rt/call.lisp
deleted file mode 100644
index 8b530e978a267a82d16230efe1f8e9d21ef772d3..0000000000000000000000000000000000000000
--- a/compiler/rt/call.lisp
+++ /dev/null
@@ -1,1158 +0,0 @@
-;;; -*- Package: RT; 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)
-;;; **********************************************************************
-;;;
-;;; This file contains the VM definition of function call for the IBM RT.
-;;;
-;;; Written by Rob MacLachlan, William Lott, and Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-;;;; Interfaces to IR2 conversion:
-
-;;; STANDARD-ARGUMENT-LOCATION -- Interface.
-;;;
-;;; Return a wired TN describing the N'th full call argument passing location.
-;;;
-(def-vm-support-routine 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*
-		     control-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.
-;;;
-;;; These are *any-primitive-type* since LRA's are descriptor objects.
-;;;
-(def-vm-support-routine make-return-pc-passing-location (standard)
-  (if standard
-      (make-wired-tn *any-primitive-type* register-arg-scn lra-offset)
-      (make-restricted-tn *any-primitive-type* register-arg-scn)))
-
-;;; MAKE-OLD-FP-PASSING-LOCATION -- Interface.
-;;;
-;;; Similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a location to supply
-;;; the old control FP.  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.
-;;;
-;;; These are *word-pointer-type* since FP's are word aligned pointers,
-;;; so the low tow bits are zero.
-;;;
-(def-vm-support-routine make-old-fp-passing-location (standard)
-  (if standard
-      (make-wired-tn *word-pointer-type* immediate-arg-scn ocfp-offset)
-      (make-normal-tn *word-pointer-type*)))
-
-;;; MAKE-OLD-FP-SAVE-LOCATION, MAKE-RETURN-PC-SAVE-LOCATION -- Interface.
-;;;
-;;; Make the TN's used to hold the old control FP and return-PC within the
-;;; current function.  We treat these specially so that the debugger can find
-;;; them at a known location.
-;;;
-;;; ### Fix to use specified save TNs...
-;;;
-;;; See comments for MAKE-RETURN-PC-PASSING-LOCATION and M-O-FP-P-L.
-;;;
-(def-vm-support-routine make-old-fp-save-location (env)
-  (specify-save-tn
-   (environment-debug-live-tn (make-normal-tn *word-pointer-type*) env)
-   (make-wired-tn *word-pointer-type*
-		  control-stack-arg-scn
-		  ocfp-save-offset)))
-;;;
-(def-vm-support-routine make-return-pc-save-location (env)
-  (specify-save-tn
-   (environment-debug-live-tn (make-normal-tn *any-primitive-type*) env)
-   (make-wired-tn *any-primitive-type*
-		  control-stack-arg-scn
-		  lra-save-offset)))
-
-;;; 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.
-;;;
-(def-vm-support-routine make-argument-count-location ()
-  (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset))
-
-
-;;; MAKE-NFP-TN -- Interface.
-;;;
-;;; Make a TN to hold the number-stack frame pointer.  This is allocated once
-;;; per component, and is component-live.
-;;;
-(def-vm-support-routine make-nfp-tn ()
-  (component-live-tn
-   (make-wired-tn *word-pointer-type* immediate-arg-scn nfp-offset)))
-
-;;; MAKE-STACK-POINTER-TN -- Interface.
-;;;
-;;; This is of fixnum type because stack pointers are word aligned on our
-;;; byte-addressable machine, so they have fixnum tag bits inherently.  Also,
-;;; GC doesn't need to fix these since the stack doesn't move.
-;;;
-(def-vm-support-routine make-stack-pointer-tn ()
-  (make-normal-tn *word-pointer-type*))
-
-;;; MAKE-NUMBER-STACK-POINTER-TN -- Interface.
-;;; 
-(def-vm-support-routine make-number-stack-pointer-tn ()
-  (make-normal-tn *word-pointer-type*))
-
-;;; MAKE-UNKNOWN-VALUES-LOCATIONS -- Interface.
-;;;
-;;; Return a list of TN's that can be used to represent an unknown-values
-;;; continuation within a function.  The first one is a stack pointer TN, and
-;;; the second is an argument count TN.
-;;;
-(def-vm-support-routine make-unknown-values-locations ()
-  (list (make-stack-pointer-tn)
-	(make-normal-tn *fixnum-primitive-type*)))
-
-
-;;; 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 additional noise in the code object
-;;; header.
-;;;
-(def-vm-support-routine select-component-format (component)
-  (declare (type component component))
-  (dotimes (i code-constants-offset)
-    (vector-push-extend nil
-			(ir2-component-constants (component-info component))))
-  (undefined-value))
-
-
-
-;;;; Frame hackery:
-
-;;; CURRENT-FP -- VOP.
-;;;
-;;; Used for setting up the OCFP in local call.
-;;;
-(define-vop (current-fp)
-  ;; Stack pointers look like fixnums, and GC doesn't need to fix them.
-  (:results (val :scs (word-pointer-reg)))
-  (:generator 1
-    (move val cfp-tn)))
-
-;;; COMPUTE-OLD-NFP  --  VOP.
-;;;
-;;; A returner uses this for computing the returnee's NFP for use in
-;;; known-values return.  Only works assuming there is no variable size stuff
-;;; on the nstack.
-;;;
-(define-vop (compute-old-nfp)
-  (:results (val :scs (word-pointer-reg)
-		 :load-if (current-nfp-tn vop)))
-  (:vop-var vop)
-  (:generator 1
-    (let ((nfp (current-nfp-tn vop)))
-      ;; We know nfp is in a register.
-      (when nfp
-	;; The number stack grows down in memory, so the old-nfp is greater
-	;; than the current one -- add a positive number.
-	(inst cal val nfp
-	      (component-non-descriptor-stack-usage))))))
-
-;;; XEP-ALLOCATE-FRAME -- VOP.
-;;;
-;;; This is the first VOP invoked by the compiler at every entry point for a
-;;; component.  It sets up to be dual-word aligned (because of our low-tag
-;;; bits), emits the header-word for the function data-block, and emits any
-;;; extra words for data about the function (such as debug-info, its name,
-;;; etc.).  Then it emits instructions to allocate whatever room the function
-;;; will need on the control stack.
-;;;
-(define-vop (xep-allocate-frame)
-  (:info start-lab)
-  (:vop-var vop)
-  (:generator 1
-    ;; Make sure the label is aligned.
-    (align vm:lowtag-bits)
-    (emit-label start-lab)
-    ;; Allocate function header.
-    (inst function-header-word)
-    (dotimes (i (1- vm:function-header-code-offset))
-      (inst word 0))
-    ;; The start of the actual code.  A pointer to here is stored in symbols
-    ;; for named call.  Make CODE point to the component from this pointer.
-    (let ((entry-point (gen-label)))
-      (emit-label entry-point)
-      (inst compute-code-from-fn code-tn lip-tn entry-point))
-    ;; Caller has set FP to the beginning of the callee's frame.
-    (inst cal csp-tn cfp-tn
-	  (* vm:word-bytes (sb-allocated-size 'control-stack)))
-    (let ((nfp-tn (current-nfp-tn vop)))
-      (when nfp-tn
-	(inst cal nsp-tn nsp-tn
-	      (- (component-non-descriptor-stack-usage)))
-	(move nfp-tn nsp-tn)))))
-
-;;; ALLOCATE-FRAME -- VOP.
-;;;
-;;; The compiler invokes this in local call for the caller.
-;;;
-(define-vop (allocate-frame)
-  (:results (res :scs (word-pointer-reg))
-	    (nfp :scs (word-pointer-reg)
-		 :load-if (ir2-environment-number-stack-p callee)))
-  (:info callee)
-  (:generator 2
-    (move res csp-tn)
-    (inst cal csp-tn csp-tn
-	  (* vm:word-bytes (sb-allocated-size 'control-stack)))
-    (when (ir2-environment-number-stack-p callee)
-      (inst cal nsp-tn nsp-tn
-	    (- (component-non-descriptor-stack-usage)))
-      (move nfp nsp-tn))))
-
-;;; ALLOCATE-FULL-CALL-FRAME -- VOP.
-;;;
-;;; Allocate a partial frame for passing stack arguments in a full call.  Nargs
-;;; is the number of arguments passed.  If no stack arguments are passed, then
-;;; we don't have to do anything.  The compiler only invokes this for the
-;;; caller.
-;;;
-(define-vop (allocate-full-call-frame)
-  (:info nargs)
-  (:results (res :scs (word-pointer-reg)
-		 :load-if (> nargs register-arg-count)))
-  (:generator 2
-    (when (> nargs register-arg-count)
-      (move res csp-tn)
-      (inst cal csp-tn csp-tn (* nargs vm:word-bytes)))))
-
-
-
-
-;;; DEFAULT-UNKNOWN-VALUES  --  Internal.
-;;;
-;;; Emit code needed at the return-point from an unknown-values call to get or
-;;; default a desired, 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).
-;;;
-;;; Move-Temp is a Descriptor-Reg TNs used as a temporary.
-;;;
-;;; 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 ocfp-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 ocfp-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 (values nvals move-temp lra-label)
-  (declare (type (or tn-ref null) values)
-	   (type unsigned-byte nvals) (type tn move-temp))
-  (cond
-   ((<= nvals 1)
-    ;; Don't use MOVE.  Use a known 32-bit long instruction, so the returner
-    ;; can know how many bytes we used here in the multiple-value return case.
-    ;; The returner wants to add a known quantity to LRA indicating how many
-    ;; values it returned.
-    (inst cal csp-tn ocfp-tn 0)
-    (inst compute-code-from-lra code-tn code-tn lra-label))
-   (t
-    (let ((regs-defaulted (gen-label))
-	  (defaulting-done (gen-label))
-	  (default-stack-vars (gen-label)))
-      ;; Branch off to the MV case.
-      ;; The returner has setup value registers and NARGS, and OCFP points to
-      ;; any stack values.
-      ;; Use a known 32-bit long instruction, so the returner can know how many
-      ;; bytes we used here in the multiple-value return case.  The returner
-      ;; wants to add a known quantity to LRA indicating how many values it
-      ;; returned.
-      (inst bnb :pz regs-defaulted)
-      ;;
-      ;; Do the single value case.
-      ;; Fill in some n-1 registers with nil to get to a consistent state with
-      ;; having gotten multiple values, so the code after regs-defaulted can
-      ;; be the same for both cases.
-      (do ((i 1 (1+ i))
-	   (val (tn-ref-across values) (tn-ref-across val)))
-	  ((= i (min nvals register-arg-count)))
-	(move (tn-ref-tn val) null-tn))
-      ;; Set OCFP to CSP and (maybe) jump to the code that defaults (i.e.
-      ;; NILs out) all the values that would come from the stack.  We have
-      ;; to set OCFP because the stack defaulting stuff is going to set CSP
-      ;; to OCFP when it gets done to clear any values off the stack, and we
-      ;; don't want that to trash CSP.
-      (when (> nvals register-arg-count)
-	(inst bx default-stack-vars))
-      (move ocfp-tn csp-tn)
-      
-      (emit-label regs-defaulted)
-      
-      (when (> nvals register-arg-count)
-	(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))
-	      (inst c nargs-tn (fixnum i))
-	      (inst bnbx :gt default-lab)
-	      (loadw move-temp ocfp-tn i)
-	      (store-stack-tn move-temp tn)))
-
-	  (emit-label defaulting-done)
-
-	  (assemble (*elsewhere*)
-	    (emit-label default-stack-vars)
-	    (dolist (def (defaults))
-	      (emit-label (car def))
-	      (store-stack-tn null-tn (cdr def)))
-	    (inst b defaulting-done))))
-
-      (inst compute-code-from-lra code-tn code-tn lra-label)
-      (move csp-tn ocfp-tn))))
-  (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 (args nargs start count lra-label)
-  (declare (type tn args nargs start count))
-  (let ((variable-values (gen-label))
-	(done (gen-label)))
-    ;; Use a known 32-bit long instruction, so the returner can know how many
-    ;; bytes we used here in the multiple-value return case.  The returner
-    ;; wants to add a known quantity to LRA indicating how many values it
-    ;; returned.
-    (inst bnb :pz variable-values)
-    ;; Here's the return point for the single-value return.
-    (inst compute-code-from-lra code-tn code-tn lra-label)
-    (inst inc csp-tn vm:word-bytes)
-    (storew (first register-arg-tns) csp-tn -1)
-    (inst cal start csp-tn -4)
-    (inst li count (fixnum 1))
-    
-    (emit-label done)
-    
-    (assemble (*elsewhere*)
-      (emit-label variable-values)
-      (inst compute-code-from-lra code-tn code-tn lra-label)
-      (do ((arg register-arg-tns (rest arg))
-	   (i 0 (1+ i)))
-	  ((null arg))
-	(storew (first arg) args i))
-      (move start args)
-      (move count nargs)
-      (inst b done)))
-  (undefined-value))
-
-
-;;; UNKNOWN-VALUES-RECEIVER -- VOP.
-;;;
-;;; This is inherited by unknown values receivers.  The main thing this handles
-;;; is allocation of the result temporaries.  This has to be included for in
-;;; any VOP using RECEIVE-UNKNOWN-VALUES.
-;;;
-(define-vop (unknown-values-receiver)
-  (:results
-   (start :scs (word-pointer-reg))
-   (count :scs (any-reg)))
-  (:temporary (:sc descriptor-reg :offset ocfp-offset
-		   :from :eval :to (:result 0))
-	      values-start)
-  (:temporary (:sc any-reg :offset nargs-offset
-	       :from :eval :to (:result 1))
-	      nvals))
-
-
-
-;;;; 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 (fp :scs (word-pointer-reg control-stack))
-	 (nfp :scs (word-pointer-reg control-stack))
-	 (args :more t))
-  (:results (values :more t))
-  (:save-p t)
-  (:move-args :local-call)
-  (:info arg-locs callee target nvals)
-  (:ignore arg-locs args nfp)
-  (:vop-var vop)
-  (:temporary (:scs (descriptor-reg)) move-temp)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:generator 5
-    (let ((label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn cur-nfp nfp-save))
-      (let ((callee-nfp (callee-nfp-tn callee)))
-	(when callee-nfp
-	  (maybe-load-stack-tn callee-nfp nfp)))
-      (maybe-load-stack-tn cfp-tn fp)
-      (inst compute-lra-from-code
-	    (callee-return-pc-tn callee) code-tn label)
-      (inst b target)
-      (emit-return-pc label)
-      (note-this-location vop :unknown-return)
-      (default-unknown-values values nvals move-temp label)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-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 (fp :scs (word-pointer-reg control-stack))
-	 (nfp :scs (word-pointer-reg control-stack))
-	 (args :more t))
-  (:save-p t)
-  (:move-args :local-call)
-  (:info save callee target)
-  (:ignore args save)
-  (:vop-var vop)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:generator 20
-    (let ((label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn cur-nfp nfp-save))
-      (let ((callee-nfp (callee-nfp-tn callee)))
-	(when callee-nfp
-	  (maybe-load-stack-tn callee-nfp nfp)))
-      (maybe-load-stack-tn cfp-tn fp)
-      (inst compute-lra-from-code
-	    (callee-return-pc-tn callee) code-tn label)
-      (inst b target)
-      (emit-return-pc label)
-      (note-this-location vop :unknown-return)
-      (receive-unknown-values values-start nvals start count label)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-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 (fp :scs (word-pointer-reg control-stack))
-	 (nfp :scs (word-pointer-reg control-stack))
-	 (args :more t))
-  (:results (res :more t))
-  (:move-args :local-call)
-  (:save-p t)
-  (:info save callee target)
-  (:ignore args res save)
-  (:vop-var vop)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:generator 5
-    (let ((label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn cur-nfp nfp-save))
-      (let ((callee-nfp (callee-nfp-tn callee)))
-	(when callee-nfp
-	  (maybe-load-stack-tn callee-nfp nfp)))
-      (maybe-load-stack-tn cfp-tn fp)
-      (inst compute-lra-from-code
-	    (callee-return-pc-tn callee) code-tn label)
-      (inst b target)
-      (emit-return-pc label)
-      (note-this-location vop :known-return)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save)))))
-
-;;; Return from known values call.  We receive the return locations as
-;;; arguments to terminate their lifetimes in the returning function.  We
-;;; restore FP and CSP and jump to the Return-PC.
-;;;
-(define-vop (known-return)
-  (:args (old-fp :scs (word-pointer-reg control-stack))
-	 (return-pc-arg :scs (descriptor-reg control-stack)
-			:target return-pc)
-	 (vals :more t))
-  (:temporary (:scs (interior-reg) :type interior) lip)
-  (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc)
-  (:move-args :known-return)
-  (:info val-locs)
-  (:ignore val-locs vals)
-  (:vop-var vop)
-  (:generator 6
-    (move csp-tn cfp-tn)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(inst cal nsp-tn cur-nfp
-	      (component-non-descriptor-stack-usage))))
-    (maybe-load-stack-tn return-pc return-pc-arg)
-    ;; Skip over a word, the LRA header, and subtract out low-tag bits.
-    (inst cal lip return-pc (- vm:word-bytes vm:other-pointer-type))
-    (inst bx lip)
-    (maybe-load-stack-tn cfp-tn old-fp)))
-
-
-
-;;;; 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 creating a partial frame on the
-;;; stack top and storing stack arguments into that frame.  On entry to the
-;;; callee, this partial frame is pointed to by FP.  If there are no stack
-;;; arguments, we don't bother allocating a partial frame, and instead set FP
-;;; to SP just before the call.
-
-;;; 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-Fp and Return-PC are passed as the second and third arguments.
-;;;
-;;; In non-tail calls, the pointer to the stack arguments is passed as the last
-;;; fixed argument.  If Variable is false, then the passing locations are
-;;; passed as a more arg.  Variable is true if there are a variable number of
-;;; arguments passed on the stack.  Variable cannot be specified with :Tail
-;;; return.  TR variable argument call is implemented separately.
-;;;
-;;; When variable is false, the compiler actually has already invoked VOP's to
-;;; explicitly move arguments into their passing locations.  Hence the VOP
-;;; argument args (which is :more t) is actually ignored.  We pass it into the
-;;; call VOP's for lifetime analysis, and the TN references it represents stand
-;;; in at the call site for the references to those TN's where the callee
-;;; actually reads them.
-;;;
-;;; In tail call with fixed arguments, the passing locations are passed as a
-;;; more arg, but there is no new-FP, since the arguments have been set up in
-;;; the current frame.
-;;;
-(eval-when (compile eval)
-(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
-      ,@(unless (eq return :tail)
-	  '((new-fp :scs (word-pointer-reg) :to :eval)))
-
-      ,(if named
-	   '(name :scs (descriptor-reg) :target name-pass)
-	   '(arg-fun :scs (descriptor-reg) :target lexenv))
-      
-      ,@(when (eq return :tail)
-	  '((old-fp :scs (word-pointer-reg) :target old-fp-pass)
-	    (return-pc :scs (descriptor-reg control-stack)
-		       :target return-pc-pass)))
-      
-      ,@(unless variable '((args :more t :scs (descriptor-reg)))))
-
-     ,@(when (eq return :fixed)
-	 '((:results (values :more t))))
-   
-     ,@(unless (eq return :tail)
-	 `((:save-p t)
-	   ,@(unless variable
-	       '((:move-args :full-call)))))
-
-     (:vop-var vop)
-     (:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
-	    ,@(unless variable '(nargs))
-	    ,@(when (eq return :fixed) '(nvals)))
-
-     (:ignore
-      ,@(unless (or variable (eq return :tail)) '(arg-locs))
-      ,@(unless variable '(args)))
-
-     (:temporary (:sc descriptor-reg
-		  :offset ocfp-offset
-		  :from (:argument 1)
-		  :to :eval)
-		 old-fp-pass)
-
-     (:temporary (:sc descriptor-reg
-		  :offset lra-offset
-		  :from (:argument ,(if (eq return :tail) 2 1))
-		  :to :eval)
-		 return-pc-pass)
-
-     ,@(if named
-	 `((:temporary (:sc descriptor-reg :offset cname-offset
-			:from (:argument ,(if (eq return :tail) 0 1))
-			:to :eval)
-		       name-pass))
-
-	 `((:temporary (:sc descriptor-reg :offset lexenv-offset
-			:from (:argument ,(if (eq return :tail) 0 1))
-			:to :eval)
-		       lexenv)
-	   (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
-		       function)))
-
-
-     (:temporary (:sc descriptor-reg :offset nargs-offset :to :eval)
-		 nargs-pass)
-
-     ,@(when variable
-	 (mapcar #'(lambda (name offset)
-		     `(:temporary (:sc descriptor-reg
-				   :offset ,offset
-				   :to :eval)
-			 ,name))
-		 register-arg-names register-arg-offsets))
-     ,@(when (eq return :fixed)
-	 '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
-
-     ,@(unless (eq return :tail)
-	 '((:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
-
-     (:temporary (:scs (interior-reg) :type interior) lip)
-
-     (:generator ,(+ (if named 5 0)
-		     (if variable 19 1)
-		     (if (eq return :tail) 0 10)
-		     15
-		     (if (eq return :unknown) 25 0))
-       
-       (let ((cur-nfp (current-nfp-tn vop))
-	     ,@(unless (eq return :tail)
-		 '((lra-label (gen-label)))))
-
-	 ,@(if variable
-	       ;; Compute the number of arguments and move some of the arguments
-	       ;; from the stack to the argument registers.
-	       `((move nargs-pass csp-tn)
-		 ;; This computes a byte difference, but due to the number of
-		 ;; bytes per word and out fixnum tags, this leaves a fixnum
-		 ;; word count for the callee.
-		 (inst s nargs-pass new-fp)
-		 ,@(let ((index -1))
-		     (mapcar #'(lambda (name)
-				 `(loadw ,name new-fp ,(incf index)))
-			     register-arg-names)))
-	       `((inst li nargs-pass (fixnum nargs))))
- 
-
-	 ,@(if named
-	       `((move name-pass name)
-		 (loadw lip name-pass vm:symbol-raw-function-addr-slot
-			vm:other-pointer-type))
-	       `((move lexenv arg-fun)
-		 (loadw function lexenv vm:closure-function-slot
-			vm:function-pointer-type)
-		 (inst cal lip function (- (ash vm:function-header-code-offset
-						vm:word-shift)
-					   vm:function-pointer-type))))
-
-	 ,@(if (eq return :tail)
-	       '((move old-fp-pass old-fp)
-		 (maybe-load-stack-tn return-pc-pass return-pc)
-		 (when cur-nfp
-		   (inst cal nsp-tn cur-nfp
-			 (component-non-descriptor-stack-usage)))
-		 (inst b lip))
-	       `((inst compute-lra-from-code
-		       return-pc-pass code-tn lra-label)
-		 (move old-fp-pass cfp-tn)
-		 (when cur-nfp
-		   (store-stack-tn cur-nfp nfp-save))
-		 ,(if variable
-		      '(move cfp-tn new-fp)
-		      '(if (> nargs register-arg-count)
-			   (move cfp-tn new-fp)
-			   (move cfp-tn csp-tn)))
-		 (inst b lip)
-		 (emit-return-pc lra-label)))
-
-	 ,@(ecase return
-	     (:fixed
-	      '((note-this-location vop :unknown-return)
-		(default-unknown-values values nvals move-temp lra-label)
-		(when cur-nfp
-		  (load-stack-tn cur-nfp nfp-save))))
-	     (:unknown
-	      '((note-this-location vop :unknown-return)
-		(receive-unknown-values values-start nvals start count
-					lra-label)
-		(when cur-nfp
-		  (load-stack-tn cur-nfp nfp-save))))
-	     (:tail))))))
-) ;EVAL-WHEN
-
-(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 special code that BLT's the arguments
-;;; down.
-;;;
-(define-vop (tail-call-variable)
-  (:args (args-arg :scs (word-pointer-reg) :target args)
-	 (function-arg :scs (descriptor-reg) :target lexenv)
-	 (old-fp-arg :scs (word-pointer-reg) :target old-fp)
-	 (lra-arg :scs (descriptor-reg) :target lra))
-  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args)
-  (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv)
-  (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) old-fp)
-  (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra)
-  (:temporary (:scs (any-reg) :from :eval) temp)
-  (:vop-var vop)
-  (:generator 75
-    ;; Move these into the passing locations if they are not already there.
-    (move args args-arg)
-    (move lexenv function-arg)
-    (move old-fp old-fp-arg)
-    (move lra lra-arg)
-
-    ;; Clear the number stack if anything is there.
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(inst cal nsp-tn cur-nfp
-	      (component-non-descriptor-stack-usage))))
-
-    ;; And jump to the assembly-routine that moves the arguments for us.
-    (inst bala (make-fixup 'really-tail-call-variable :assembly-routine))))
-
-
-
-;;;; 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
-;;; FP 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 FP 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-fp :scs (word-pointer-reg))
-   (return-pc :scs (descriptor-reg) :to (:eval 1))
-   (values :more t))
-  (:ignore values)
-  (:info nvals)
-  (:temporary (:sc any-reg :offset a0-offset :from (:eval 0) :to (:eval 1))
-	      a0)
-  (:temporary (:sc any-reg :offset a1-offset :from (:eval 0) :to (:eval 1))
-	      a1)
-  (:temporary (:sc any-reg :offset a2-offset :from (:eval 0) :to (:eval 1))
-	      a2)
-  (:temporary (:sc any-reg :offset nargs-offset) nargs)
-  (:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
-  (:temporary (:scs (interior-reg) :type interior) lip)
-  (:vop-var vop)
-  (:generator 6
-    (cond ((= nvals 1)
-	   ;; Clear the stacks.
-	   (let ((cur-nfp (current-nfp-tn vop)))
-	     (when cur-nfp
-	       (inst cal nsp-tn cur-nfp
-		     (component-non-descriptor-stack-usage))))
-	   (move csp-tn cfp-tn)
-	   ;; Reset the frame pointer.
-	   (move cfp-tn old-fp)
-	   ;; Out of here.
-	   ;; The return-pc (LRA) has other-pointer lowtag bits.  Also, in the
-	   ;; instruction sequence in which the LRA points, there is a header
-	   ;; word with immediate data indicating the offset back to the
-	   ;; beginning of the component.  The calling convention says to
-	   ;; return one word past the return point when the returner knows
-	   ;; it has only one value, so we skip that word here and the header
-	   ;; for the LRA.
-	   (inst cal lip return-pc (- (* 2 word-bytes) other-pointer-type))
-	   (inst bx lip)
-	   (move code-tn return-pc))
-	  (t
-	   (inst li nargs (fixnum nvals))
-	   ;; Clear the number stack.
-	   (let ((cur-nfp (current-nfp-tn vop)))
-	     (when cur-nfp
-	       (inst cal nsp-tn cur-nfp
-		     (component-non-descriptor-stack-usage))))
-	   (move val-ptr cfp-tn)
-	   ;; Reset the frame pointer.
-	   (move cfp-tn old-fp)
-	   
-	   (let ((immediate (* nvals word-bytes)))
-	     (assert (typep immediate '(signed-byte 16)))
-	     (inst cal csp-tn val-ptr immediate))
-	   
-	   (when (< nvals 1) (move a0 null-tn))
-	   (when (< nvals 2) (move a1 null-tn))
-	   (when (< nvals 3) (move a2 null-tn))
-	   
-	   (lisp-return return-pc lip)))))
-
-;;; RETURN-MULTIPLE -- VOP.
-;;;
-;;; 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 an assembler routine.
-;;;
-;;; 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-Fp, 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
-   (ocfp-arg :scs (word-pointer-reg) :target ocfp)
-   (lra-arg :scs (descriptor-reg) :target lra)
-   (vals-arg :scs (word-pointer-reg) :target vals)
-   (nvals-arg :scs (any-reg) :target nvals))
-  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) ocfp)
-  (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
-  (:temporary (:sc any-reg :offset cname-offset :from (:argument 2)) vals)
-  (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals)
-  (:temporary (:sc descriptor-reg :offset a0-offset) a0)
-  (:temporary (:scs (interior-reg) :type interior) lip)
-  (:vop-var vop)
-  (:generator 13
-    (let ((not-single (gen-label)))
-      ;; Clear the number stack.
-      (let ((cur-nfp (current-nfp-tn vop)))
-	(when cur-nfp
-	  (inst cal nsp-tn cur-nfp
-		(component-non-descriptor-stack-usage))))
-      
-      ;; Single case?
-      (inst c nvals-arg (fixnum 1))
-      (inst bnc :eq not-single)
-      
-      ;; Return with one value.
-      (loadw a0 vals-arg)
-      (move csp-tn cfp-tn)
-      (move cfp-tn ocfp-arg)
-      (lisp-return lra-arg lip :offset 1)
-      
-      ;; Nope, not the single case.
-      (emit-label not-single)
-      
-      ;; Load the register args, bailing out when we are done.
-      (move ocfp ocfp-arg)
-      (move lra lra-arg)
-      (move vals vals-arg)
-      (move nvals nvals-arg)
-      (inst bala (make-fixup 'really-return-multiple :assembly-routine)))))
-
-;;; COMPONENT-NON-DESCRIPTOR-STACK-USAGE -- Internal.
-;;;
-;;; This returns the non-descriptor stack usage in bytes for the component on
-;;; which the compiler is currently working.
-;;;
-;;; On the MIPS, the stack must be dual-word aligned since it is also the C
-;;; call stack.
-;;;
-;;; We're going to make the same assumption on the RT, but we don't even know
-;;; why this is true on the MIPS.
-;;;
-(defun component-non-descriptor-stack-usage ()
-  (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1)
-     vm:word-bytes))
-
-
-
-;;;; XEP hackery:
-
-
-;;; We don't need to do any special setup for regular functions.
-;;;
-(define-vop (setup-environment)
-  (:info label)
-  (:generator 5))
-
-;;; Extract the closure from the passing location (LEXENV).
-;;;
-(define-vop (setup-closure-environment)
-  (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
-	       :to (:result 0))
-	      lexenv)
-  (:results (closure :scs (descriptor-reg)))
-  (:info label)
-  (:generator 6
-    ;; Get result.
-    (move closure lexenv)))
-
-;;; Copy a more arg from the argument area to the end of the current frame.
-;;; Fixed is the number of non-more arguments. 
-;;;
-;;; We wire the temporaries to make sure they do not interfere with any of
-;;; special registers used during full-call, because we do not have acurate
-;;; lifetime info about them at the time this vop is used.
-;;; 
-(define-vop (copy-more-arg)
-  (:temporary (:sc descriptor-reg :offset cname-offset) temp)
-  (:info fixed)
-  (:generator 20
-    (let ((do-more-args (gen-label))
-	  (done-more-args (gen-label)))
-      (inst c nargs-tn (fixnum fixed))
-      (inst bc :gt do-more-args)
-      (assemble (*elsewhere*)
-	(emit-label do-more-args)
-	;; Jump to assembler routine passing fixed at cname-offset.
-	(inst li temp (fixnum fixed))
-	(inst bala (make-fixup 'really-copy-more-args :assembly-routine))
-	(inst b done-more-args))
-      (emit-label done-more-args))))
-
-
-;;; More args are stored consequtively on the stack, starting immediately at
-;;; the context pointer.  The context pointer is not typed, so the lowtag is 0.
-;;;
-(define-vop (more-arg word-index-ref)
-  (:variant 0 0)
-  (:translate %more-arg))
-
-
-;;; Turn more arg (context, count) into a list.
-;;;
-(define-vop (listify-rest-args)
-  (:args (context-arg :target context :scs (descriptor-reg))
-	 (count-arg :target count :scs (any-reg)))
-  (:arg-types * tagged-num)
-  (:temporary (:scs (word-pointer-reg) :from (:argument 0)) context)
-  (:temporary (:scs (non-descriptor-reg) :from :eval) ndescr dst)
-  (:temporary (:scs (any-reg) :from (:argument 1)) count)
-  (:temporary (:scs (word-pointer-reg) :from :eval) alloc)
-  (:temporary (:scs (descriptor-reg) :from :eval) temp)
-  (:results (result :scs (descriptor-reg)))
-  (:translate %listify-rest-args)
-  (:policy :safe)
-  (:generator 20
-    (let ((enter (gen-label))
-	  (loop (gen-label))
-	  (done (gen-label)))
-      (move context context-arg)
-      (move count count-arg)
-      ;; Check to see if there are any arguments.
-      (inst c count 0)
-      (inst bcx :eq done)
-      (move result null-tn)
-
-      ;; We need to do this atomically.
-      (pseudo-atomic (ndescr)
-	(load-symbol-value alloc *allocation-pointer*)
-	;; Allocate a cons (2 words) for each item.
-	(inst cal result alloc vm:list-pointer-type)
-	(move dst result)
-	(inst cas alloc count alloc)
-	(inst cas alloc count alloc)
-	(inst bx enter)
-	(store-symbol-value alloc *allocation-pointer*)
-
-	;; Store the current cons in the cdr of the previous cons.
-	(emit-label loop)
-	(storew dst dst -1 vm:list-pointer-type)
-
-	;; Grab one value and stash it in the car of this cons.
-	(emit-label enter)
-	(loadw temp context)
-	(inst inc context vm:word-bytes)
-	(storew temp dst 0 vm:list-pointer-type)
-
-	;; Dec count, and if != zero, go back for more.
-	(inst s count (fixnum 1))
-	(inst bncx :eq loop)
-	(inst inc dst (* 2 vm:word-bytes))
-
-	;; NIL out the last cons.
-	(storew null-tn dst -1 vm:list-pointer-type))
-      (load-symbol-value ndescr *internal-gc-trigger*)
-      (inst tlt ndescr alloc)
-      (emit-label done))))
-
-
-
-;;; 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)))
-  (:arg-types positive-fixnum)
-  (:info fixed)
-  (:results
-   (context :scs (descriptor-reg))
-   (count :scs (any-reg)))
-  (:generator 5
-    (inst s count supplied (fixnum fixed))
-    (move context csp-tn)
-    (inst s context count)))
-
-
-;;; Signal wrong argument count error if Nargs isn't = to Count.
-;;;
-(define-vop (verify-argument-count)
-  (:args (nargs :scs (any-reg)))
-  (:arg-types positive-fixnum)
-  (:info count)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 3
-    (let ((err-lab
-	   (generate-error-code vop invalid-argument-count-error nargs)))
-      (inst c nargs (fixnum count))
-      (inst bnc :eq err-lab))))
-
-;;; Signal an argument count error.
-;;;
-(macrolet ((frob (name error &rest args)
-	     `(define-vop (,name)
-		(:args ,@(mapcar #'(lambda (arg)
-				     `(,arg :scs (any-reg descriptor-reg)))
-				 args))
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 1000
-		  (error-call vop ,error ,@args)))))
-  (frob argument-count-error invalid-argument-count-error nargs)
-  (frob type-check-error object-not-type-error object type)
-  (frob odd-keyword-arguments-error odd-keyword-arguments-error)
-  (frob unknown-keyword-argument-error unknown-keyword-argument-error key)
-  (frob nil-function-returned-error nil-function-returned-error fun))
diff --git a/compiler/rt/cell.lisp b/compiler/rt/cell.lisp
deleted file mode 100644
index c085c4a8bdf1e63325e9135cb8588cda6236bc70..0000000000000000000000000000000000000000
--- a/compiler/rt/cell.lisp
+++ /dev/null
@@ -1,348 +0,0 @@
-;;; -*- Package: RT; 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/rt/cell.lisp,v 1.7 1992/03/10 10:00:02 wlott Exp $
-;;;
-;;; This file contains the VM definition of various primitive memory access
-;;; VOPs for the IBM RT.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-;;;; Data object definition macros.
-
-(vm:define-for-each-primitive-object (obj)
-  (collect ((forms))
-    (let ((lowtag (vm:primitive-object-lowtag obj)))
-      (dolist (slot (vm:primitive-object-slots obj))
-	(let* ((name (vm:slot-name slot))
-	       (offset (vm:slot-offset slot))
-	       (rest-p (vm:slot-rest-p slot))
-	       (slot-opts (vm:slot-options slot))
-	       (ref-trans (getf slot-opts :ref-trans))
-	       (ref-vop (getf slot-opts :ref-vop ref-trans))
-	       (set-trans (getf slot-opts :set-trans))
-	       (setf-function-p (and (listp set-trans)
-				     (= (length set-trans) 2)
-				     (eq (car set-trans) 'setf)))
-	       (setf-vop (getf slot-opts :setf-vop
-			       (when setf-function-p
-				 (intern (concatenate
-					  'simple-string
-					  "SET-"
-					  (string (cadr set-trans)))))))
-	       (set-vop (getf slot-opts :set-vop
-			      (if setf-vop nil set-trans))))
-	  (when ref-vop
-	    (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref))
-				(:variant ,offset ,lowtag)
-		      ,@(when ref-trans
-			  `((:translate ,ref-trans))))))
-	  (when (or set-vop setf-vop)
-	    (forms `(define-vop ,(cond ((and rest-p setf-vop)
-					(error "Can't automatically generate ~
-					a setf VOP for :rest-p ~
-					slots: ~S in ~S"
-					       name
-					       (vm:primitive-object-name obj)))
-				       (rest-p `(,set-vop slot-set))
-				       ((and set-vop setf-function-p)
-					(error "Setf functions (list ~S) must ~
-					use :setf-vops."
-					       set-trans))
-				       (set-vop `(,set-vop cell-set))
-				       (setf-function-p
-					`(,setf-vop cell-setf-function))
-				       (t
-					`(,setf-vop cell-setf)))
-		      (:variant ,offset ,lowtag)
-		      ,@(when set-trans
-			  `((:translate ,set-trans)))))))))
-    (when (forms)
-      `(progn
-	 ,@(forms)))))
-
-
-
-;;;; Symbol hacking VOPs:
-
-;;; CHECKED-CELL-REF -- VOP.
-;;;
-;;; 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 (word-pointer-reg descriptor-reg any-reg)))
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
-
-;;; SYMBOL-VALUE -- VOP.
-;;;
-;;; Check that the value isn't the trap object.
-;;;
-(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 vop unbound-symbol-error obj-temp)))
-      (inst c value vm:unbound-marker-type)
-      (inst bc :eq err-lab))))
-
-;;; SYMBOL-FUNCTION -- VOP.
-;;;
-;;; Check that the result is a function, so NIL is always un-fbound.
-;;;
-(define-vop (symbol-function checked-cell-ref)
-  (:translate symbol-function)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
-  (:generator 10
-    (move obj-temp object)
-    (loadw value obj-temp vm:symbol-function-slot vm:other-pointer-type)
-    (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
-      (test-type value temp err-lab t vm:function-pointer-type))))
-
-
-;;; BOUNDP-FROB -- VOP.
-;;;
-;;; 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 c value vm:unbound-marker-type)
-    (if not-p
-	;; If they're the same, symbol is unbound, so if not-p (the symbol is
-	;; bound), then go to target.
-	(inst bc :eq target)
-	(inst bnc :eq target))))
-
-
-;;; 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-type value temp target not-p vm:function-pointer-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))
-
-(define-vop (set-symbol-function)
-  (:translate %set-symbol-function)
-  (:policy :fast-safe)
-  (:args (symbol :scs (descriptor-reg))
-	 (function :scs (descriptor-reg) :target result))
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) type)
-  (:temporary (:scs (any-reg)) temp)
-  (:save-p :compute-only)
-  (:vop-var vop)
-  (:generator 30
-    (let ((closure (gen-label))
-	  (normal-fn (gen-label)))
-      (load-type type function vm:function-pointer-type)
-      (inst c type vm:closure-header-type)
-      (inst bc :eq closure)
-      (inst c type funcallable-instance-header-type)
-      (inst bc :eq closure)
-      (inst c type vm:function-header-type)
-      (inst bcx :eq normal-fn)
-      (inst a temp function
-	    (- (ash vm:function-header-code-offset vm:word-shift)
-	       vm:function-pointer-type))
-      (error-call vop kernel:object-not-function-error function)
-      (emit-label closure)
-      (inst cai temp (make-fixup "closure_tramp" :foreign))
-      (emit-label normal-fn)
-      (storew function symbol vm:symbol-function-slot vm:other-pointer-type)
-      (storew temp symbol vm:symbol-raw-function-addr-slot vm:other-pointer-type)
-      (move result function))))
-
-
-(defknown fmakunbound/symbol (symbol) symbol (unsafe))
-;;;
-(deftransform fmakunbound ((symbol) (symbol))
-  '(when symbol
-     (fmakunbound/symbol symbol)))
-;;;
-(define-vop (fmakunbound/symbol)
-  (:translate fmakunbound/symbol)
-  (:policy :fast-safe)
-  (:args (symbol :scs (descriptor-reg) :target result))
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:scs (sap-reg)) temp)
-  (:generator 5
-    (inst li temp vm:unbound-marker-type)
-    (storew temp symbol vm:symbol-function-slot vm:other-pointer-type)
-    (inst cai temp (make-fixup "undefined_tramp" :foreign))
-    (storew temp symbol vm:symbol-raw-function-addr-slot vm:other-pointer-type)
-    (move result symbol)))
-
-
-;;; 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)
-  (:temporary (:scs (word-pointer-reg)) bsp)
-  (:generator 7
-    (loadw temp symbol vm:symbol-value-slot vm:other-pointer-type)
-    (load-symbol-value bsp *binding-stack-pointer*)
-    (inst inc bsp (* vm:binding-size vm:word-bytes))
-    (store-symbol-value bsp *binding-stack-pointer*)
-    (storew temp bsp (- vm:binding-value-slot vm:binding-size))
-    (storew symbol bsp (- vm:binding-symbol-slot vm:binding-size))
-    (storew val symbol vm:symbol-value-slot vm:other-pointer-type)))
-
-(define-vop (unbind)
-  (:temporary (:scs (descriptor-reg)) symbol value)
-  (:temporary (:scs (word-pointer-reg)) bsp)
-  (:generator 7
-    (load-symbol-value bsp *binding-stack-pointer*)
-    (loadw symbol bsp (- vm:binding-symbol-slot vm:binding-size))
-    (loadw value bsp (- vm:binding-value-slot vm:binding-size))
-    (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
-    (inst li value 0)
-    (storew value bsp (- vm:binding-symbol-slot vm:binding-size))
-    (inst dec bsp (* vm:binding-size vm:word-bytes))
-    (store-symbol-value bsp *binding-stack-pointer*)))
-
-(define-vop (unbind-to-here)
-  (:args (arg :scs (descriptor-reg any-reg) :target where))
-  (:temporary (:scs (any-reg) :from (:argument 0)) where)
-  (:temporary (:scs (descriptor-reg)) symbol value)
-  (:temporary (:scs (word-pointer-reg)) bsp)
-  (:generator 0
-    (let ((loop (gen-label))
-	  (skip (gen-label))
-	  (done (gen-label)))
-      (move where arg)
-      (load-symbol-value bsp *binding-stack-pointer*)
-      (inst c where bsp)
-      (inst bc :eq done)
-
-      (emit-label loop)
-      (loadw symbol bsp (- vm:binding-symbol-slot vm:binding-size))
-      (inst c symbol 0)
-      (inst bc :eq skip)
-      (loadw value bsp (- vm:binding-value-slot vm:binding-size))
-      (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
-      (inst li value 0)
-      (storew value bsp (- vm:binding-symbol-slot vm:binding-size))
-
-      (emit-label skip)
-      (inst dec bsp (* vm:binding-size vm:word-bytes))
-      (store-symbol-value bsp *binding-stack-pointer*)
-      (inst c where bsp)
-      (inst bnc :eq loop)
-
-      (emit-label done))))
-
-
-
-;;;; Closure indexing.
-
-(define-vop (closure-index-ref word-index-ref)
-  (:variant vm:closure-info-offset vm:function-pointer-type)
-  (:translate %closure-index-ref))
-
-(define-vop (set-funcallable-instance-info word-index-set)
-  (:variant funcallable-instance-info-offset function-pointer-type)
-  (:translate %set-funcallable-instance-info))
-
-
-;;;; Structure hackery:
-
-(define-vop (structure-length)
-  (:policy :fast-safe)
-  (:translate structure-length)
-  (:args (struct :scs (descriptor-reg)))
-  ;;(:temporary (:scs (non-descriptor-reg)) temp)
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 4
-    (loadw res struct 0 structure-pointer-type)
-    (inst sr res vm:type-bits)))
-
-(define-vop (structure-ref slot-ref)
-  (:variant structure-slots-offset structure-pointer-type)
-  (:policy :fast-safe)
-  (:translate structure-ref)
-  (:arg-types structure (:constant index)))
-
-(define-vop (structure-set slot-set)
-  (:policy :fast-safe)
-  (:translate structure-set)
-  (:variant structure-slots-offset structure-pointer-type)
-  (:arg-types structure (:constant index) *))
-
-(define-vop (structure-index-ref word-index-ref)
-  (:policy :fast-safe) 
-  (:translate structure-ref)
-  (:variant structure-slots-offset structure-pointer-type)
-  (:arg-types structure positive-fixnum))
-
-(define-vop (structure-index-set word-index-set)
-  (:policy :fast-safe) 
-  (:translate structure-set)
-  (:variant structure-slots-offset structure-pointer-type)
-  (:arg-types structure positive-fixnum *))
-
-
-
-;;;; Extra random indexers.
-
-(define-vop (code-header-ref word-index-ref)
-  (:translate code-header-ref)
-  (:policy :fast-safe)
-  (:variant 0 other-pointer-type))
-
-(define-vop (code-header-set word-index-set)
-  (:translate code-header-set)
-  (:policy :fast-safe)
-  (:variant 0 other-pointer-type))
-
-
diff --git a/compiler/rt/char.lisp b/compiler/rt/char.lisp
deleted file mode 100644
index 62837a0db0e9d06b125a916b2ccb0c731cbdbebf..0000000000000000000000000000000000000000
--- a/compiler/rt/char.lisp
+++ /dev/null
@@ -1,167 +0,0 @@
-;;; -*- Package: RT; 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/rt/char.lisp,v 1.3 1992/03/10 10:00:34 wlott Exp $
-;;; 
-;;; This file contains the RT VM definition of character operations.
-;;;
-;;; Written by Rob MacLachlan and Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-;;;; Moves and coercions:
-
-;;; MOVE-TO-BASE-CHAR -- VOP.
-;;;
-;;; Move a tagged char to an untagged representation.
-;;;
-(define-vop (move-to-base-char)
-  (:args (x :scs (any-reg descriptor-reg) :target y))
-  (:arg-types base-char)
-  (:results (y :scs (base-char-reg)))
-  (:generator 1
-    (move y x)
-    (inst sr y vm:type-bits)))
-;;;
-(define-move-vop move-to-base-char :move
-  (any-reg descriptor-reg) (base-char-reg))
-
-
-;;; MOVE-FROM-BASE-CHAR -- VOP.
-;;;
-;;; Move an untagged char to a tagged representation.
-;;;
-(define-vop (move-from-base-char)
-  (:args (x :scs (base-char-reg) :target temp))
-  (:temporary (:scs (base-char-reg) :from (:argument 0)) temp)
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:result-types base-char)
-  (:generator 1
-    (move temp x)
-    (inst sl temp vm:type-bits)
-    (inst oil y temp vm:base-char-type)))
-;;;
-(define-move-vop move-from-base-char :move
-  (base-char-reg) (any-reg descriptor-reg))
-
-;;; BASE-CHAR-MOVE -- VOP.
-;;;
-;;; Move untagged base-char values.
-;;;
-(define-vop (base-char-move)
-  (:args (x :target y
-	    :scs (base-char-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (base-char-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:generator 0
-    (move y x)))
-;;;
-(define-move-vop base-char-move :move
-  (base-char-reg) (base-char-reg))
-
-
-;;; MOVE-BASE-CHAR-ARGUMENT -- VOP.
-;;;
-;;; Move untagged base-char arguments/return-values.
-;;;
-(define-vop (move-base-char-argument)
-  (:args (x :target y
-	    :scs (base-char-reg))
-	 (fp :scs (word-pointer-reg)
-	     :load-if (not (sc-is y base-char-reg))))
-  (:results (y))
-  (:generator 0
-    (sc-case y
-      (base-char-reg
-       (move y x))
-      (base-char-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-base-char-argument :move-argument
-  (any-reg base-char-reg) (base-char-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
-;;; to a descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (base-char-reg) (any-reg descriptor-reg))
-
-
-
-;;;; Other operations:
-
-;;; CHAR-CODE -- VOP.
-;;;
-;;; This assumes it is best to keep characters in their raw representation.
-;;;
-(define-vop (char-code)
-  (:translate char-code)
-  (:policy :fast-safe)
-  (:args (ch :scs (base-char-reg) :target temp))
-  (:arg-types base-char)
-  (:temporary (:scs (base-char-reg)
-		    :from (:argument 0) :to (:result 0)
-		    :target res) temp)
-  (:results (res :scs (any-reg)))
-  (:result-types positive-fixnum)
-  (:generator 1
-    (move temp ch)
-    (inst sl temp 2)
-    (move res temp)))
-
-;;; CODE-CHAR -- VOP.
-;;;
-(define-vop (code-char)
-  (:translate code-char)
-  (:policy :fast-safe)
-  (:args (code :scs (any-reg) :target res))
-  (:arg-types positive-fixnum)
-  (:results (res :scs (base-char-reg)))
-  (:result-types base-char)
-  (:generator 1
-    (move res code)
-    (inst sr res 2)))
-
-
-
-;;; Comparison of base-chars.
-;;;
-(define-vop (base-char-compare)
-  (:args (x :scs (base-char-reg))
-	 (y :scs (base-char-reg)))
-  (:arg-types base-char base-char)
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:note "inline comparison")
-  (:variant-vars condition)
-  (:generator 6
-    (inst cl x y)
-    (if not-p
-	(inst bnc condition target)
-	(inst bc condition target))))
-
-(define-vop (fast-char=/base-char base-char-compare)
-  (:translate char=)
-  (:variant :eq))
-
-(define-vop (fast-char</base-char base-char-compare)
-  (:translate char<)
-  (:variant :lt))
-
-(define-vop (fast-char>/base-char base-char-compare)
-  (:translate char>)
-  (:variant :gt))
diff --git a/compiler/rt/debug.lisp b/compiler/rt/debug.lisp
deleted file mode 100644
index 631db922b402816f347a36ad7e943a8782529717..0000000000000000000000000000000000000000
--- a/compiler/rt/debug.lisp
+++ /dev/null
@@ -1,149 +0,0 @@
-;;; -*- Package: RT; 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/rt/debug.lisp,v 1.4 1992/03/10 09:20:19 wlott Exp $
-;;;
-;;; Compiler support for the new whizzy debugger.
-;;;
-;;; Written by William Lott.
-;;; Converted to RT by Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-(defknown di::current-sp () system-area-pointer (movable flushable))
-(defknown di::current-fp () system-area-pointer (movable flushable))
-(defknown di::stack-ref (system-area-pointer index) t (flushable))
-(defknown di::%set-stack-ref (system-area-pointer index t) t (unsafe))
-(defknown di::lra-code-header (t) t (movable flushable))
-(defknown di::function-code-header (t) t (movable flushable))
-(defknown di::make-lisp-obj ((unsigned-byte 32)) t (movable flushable))
-(defknown di::get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable))
-
-(define-vop (debug-cur-sp)
-  (:translate di::current-sp)
-  (:policy :fast-safe)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 1
-    (move res csp-tn)))
-
-(define-vop (debug-cur-fp)
-  (:translate di::current-fp)
-  (:policy :fast-safe)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 1
-    (move res cfp-tn)))
-
-
-(define-vop (read-control-stack-c)
-  (:policy :fast-safe)
-  (:translate di::stack-ref)
-  (:args (base :scs (sap-reg)))
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:arg-types system-area-pointer (:constant (unsigned-byte 13)))
-  (:info offset)
-  (:generator 5
-    (inst l result base (* offset word-bytes))))
-
-(define-vop (read-control-stack)
-  (:policy :fast-safe)
-  (:translate di::stack-ref)
-  (:args (object :scs (sap-reg) :target base)
-	 (offset :scs (any-reg)))
-  (:results (result :scs (descriptor-reg)))
-  (:arg-types system-area-pointer positive-fixnum)
-  (:result-types *)
-  (:temporary (:scs (sap-reg) :from (:argument 0) :to :eval) base)
-  (:generator 7
-    (move base object)
-    (inst a base offset)
-    (inst l result base 0)))
-
-(define-vop (write-control-stack-c)
-  (:policy :fast-safe)
-  (:translate di::%set-stack-ref)
-  (:args (base :scs (sap-reg))
-	 (data :scs (descriptor-reg) :target result :to (:result 0)))
-  (:arg-types system-area-pointer (:constant (unsigned-byte 13)) *)
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:info offset)
-  (:generator 5
-    (inst st data base (* offset word-bytes))
-    (move result data)))
-
-(define-vop (write-control-stack)
-  (:policy :fast-safe)
-  (:translate di::%set-stack-ref)
-  (:args (object :scs (sap-reg) :target base)
-	 (offset :scs (any-reg))
-	 (data :scs (descriptor-reg) :target result))
-  (:arg-types system-area-pointer positive-fixnum *)
-  (:temporary (:scs (sap-reg) :from (:argument 0) :to :eval) base)
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:generator 7
-    (move base object)
-    (inst cas base base offset)
-    (inst st data base 0)
-    (move result data)))
-
-
-(define-vop (code-from-mumble)
-  (:policy :fast-safe)
-  (:args (thing :scs (descriptor-reg) :target code))
-  (:results (code :scs (descriptor-reg)))
-  (:temporary (:scs (sap-reg)) temp)
-  (:variant-vars lowtag)
-  (:generator 5
-    (let ((bogus (gen-label))
-	  (done (gen-label)))
-      (loadw temp thing 0 lowtag)
-      (inst sr temp vm:type-bits)
-      (inst bc :eq bogus)
-      (inst sl temp (1- (integer-length vm:word-bytes)))
-      (unless (= lowtag vm:other-pointer-type)
-	(inst cal temp temp (- lowtag vm:other-pointer-type)))
-      (move code thing)
-      (inst s code temp)
-      (emit-label done)
-      (assemble (*elsewhere*)
-	(emit-label bogus)
-	(inst bx done)
-	(move code null-tn)))))
-
-(define-vop (code-from-lra code-from-mumble)
-  (:translate di::lra-code-header)
-  (:variant vm:other-pointer-type))
-
-(define-vop (code-from-function code-from-mumble)
-  (:translate di::function-code-header)
-  (:variant vm:function-pointer-type))
-
-(define-vop (di::make-lisp-obj)
-  (:policy :fast-safe)
-  (:translate di::make-lisp-obj)
-  (:args (value :scs (unsigned-reg) :target result))
-  (:arg-types unsigned-num)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 1
-    (move result value)))
-
-(define-vop (di::get-lisp-obj-address)
-  (:policy :fast-safe)
-  (:translate di::get-lisp-obj-address)
-  (:args (thing :scs (descriptor-reg) :target result))
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (move result thing)))
diff --git a/compiler/rt/insts.lisp b/compiler/rt/insts.lisp
deleted file mode 100644
index 43525248430c563763a43d848d2bbc43bbd2ee7b..0000000000000000000000000000000000000000
--- a/compiler/rt/insts.lisp
+++ /dev/null
@@ -1,1437 +0,0 @@
-;;; -*- Package: RT -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/insts.lisp,v 1.13 1992/01/22 18:09:31 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Description of the IBM RT instruction set.
-;;;
-;;; Written by William Lott and Bill Chiles.
-;;;
-
-(in-package "RT")
-
-(use-package "ASSEM")
-(use-package "EXT")
-
-
-;;;; Resources:
-
-(disassem:set-disassem-params :instruction-alignment 16)
-(define-resources memory float-status mq cc)
-
-
-;;;; Formats.
-
-(define-format (j1 16 :use (cc))
-  (op (byte 4 12))
-  (sub-op (byte 1 11))
-  (n (byte 3 8))
-  (j1 (byte 8 0)))
-
-(define-format (x 16 :clobber (cc))
-  (op (byte 4 12))
-  (r1 (byte 4 8) :write t)
-  (r2 (byte 4 4) :read t)
-  (r3 (byte 4 0) :read t))
-
-
-(define-format (r 16 :clobber (cc))
-  (op (byte 8 8))
-  (r2 (byte 4 4) :read t :write t)
-  (r3 (byte 4 0) :read t))
-
-(define-format (r-immed 16 :clobber (cc))
-  (op (byte 8 8))
-  (r2 (byte 4 4) :read t :write t)
-  (r3 (byte 4 0)))
-
-
-(define-format (bi 32 :use (cc))
-  (op (byte 8 24))
-  (r2 (byte 4 20))
-  (bi (byte 20 0)))
-
-(define-format (ba 32 :attributes (assembly-call))
-  (op (byte 8 24))
-  (ba (byte 24 0)))
-
-(define-format (d 32 :clobber (cc))
-  (op (byte 8 24))
-  (r2 (byte 4 20) :write t)
-  (r3 (byte 4 16) :read t)
-  (i (byte 16 0)))
-
-(define-format (d-short 16 :clobber (cc))
-  (op (byte 4 12))
-  (i (byte 4 8))
-  (r2 (byte 4 4) :write t)
-  (r3 (byte 4 0) :read t))
-
-
-;;;; Special argument types and fixups.
-
-(define-argument-type register
-  :type '(satisfies (lambda (object)
-		      (and (tn-p object)
-			   (or (eq (sc-name (tn-sc object)) 'null)
-			       (eq (sb-name (sc-sb (tn-sc object)))
-				   'registers)))))
-  :function (lambda (tn)
-	      (case (sc-name (tn-sc tn))
-		(null null-offset)
-		(t (tn-offset tn)))))
-
-(defun address-register-p (object)
-  (and (tn-p object)
-       (not (zerop (tn-offset object)))
-       (eq (sb-name (sc-sb (tn-sc object))) 'registers)))
-
-(define-argument-type address-register
-  :type '(satisfies address-register-p)
-  :function tn-offset)
-
-
-;;; LABEL-OFFSET -- Internal.
-;;;
-;;; This uses assem:*current-position* and the label's position to compute
-;;; the bits that an instructions immediate field wants.
-;;;
-(defun label-offset (label)
-  (ash (- (label-position label) *current-position*) -1))
-
-(define-argument-type relative-label
-  :type 'label
-  :function label-offset)
-
-
-(defun jump-condition-value (cond)
-  (ecase cond
-    (:pz #b000)
-    (:lt #b001)
-    (:eq #b010)
-    (:gt #b011)
-    (:c0 #b100)
-    (:ov #b110)
-    (:tb #b111)))
-
-(define-argument-type jump-condition
-  :type '(member :pz :lt :eq :gt :c0 :ov :tb)
-  :function jump-condition-value)
-
-(defun branch-condition-value (cond)
-  (ecase cond
-    (:pz #b1000)
-    (:lt #b1001)
-    (:eq #b1010)
-    (:gt #b1011)
-    (:c0 #b1100)
-    (:ov #b1110)
-    (:tb #b1111)))
-
-(define-argument-type branch-condition
-  :type '(member :pz :lt :eq :gt :c0 :ov :tb)
-  :function branch-condition-value)
-
-
-(define-fixup-type :ba) ;branch-absolute.
-(define-fixup-type :cau)
-(define-fixup-type :cal)
-
-
-
-;;;; Loading and storing.
-
-;;; load-character.
-;;;
-(define-instruction (lc)
-  (d-short (op :constant 4)
-	   (r2 :argument register)
-	   (r3 :argument address-register)
-	   (i :argument (unsigned-byte 4)))
-  (d-short (op :constant 4)
-	   (r2 :argument register)
-	   (r3 :argument address-register)
-	   (i :constant 0))
-  (d (op :constant #xCE)
-     (r2 :argument register)
-     (r3 :argument address-register)
-     (i :argument (signed-byte 16))))
-
-;;; store-character.
-;;;
-(define-instruction (stc)
-  (d-short (op :constant 1)
-	   (r2 :argument register :read t :write nil)
-	   (r3 :argument address-register)
-	   (i :argument (unsigned-byte 4)))
-  (d-short (op :constant 1)
-	   (r2 :argument register :read t :write nil)
-	   (r3 :argument address-register)
-	   (i :constant 0))
-  (d (op :constant #xDE)
-     (r2 :argument register :read t :write nil)
-     (r3 :argument address-register)
-     (i :argument (signed-byte 16))))
-
-;;; load-half.
-;;;
-(define-instruction (lh)
-  (d (op :constant #xDA)
-     (r2 :argument register)
-     (r3 :argument address-register)
-     (i :argument (signed-byte 16)))
-  (r (op :constant #xEB)
-     (r2 :argument register :read nil)
-     (r3 :argument register)))
-
-;;; load-half-algebraic.
-;;;
-(define-instruction (lha)
-  (d (op :constant #xCA)
-     (r2 :argument register)
-     (r3 :argument address-register)
-     (i :argument (signed-byte 16)))
-  (d-short (op :constant 5)
-	   (r2 :argument register)
-	   (r3 :argument address-register)
-	   ;; We want the instruction to take byte indexes, but we plug the
-	   ;; index into the instruction as a half-word index.
-	   (i :argument (member 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
-	      :function (lambda (x) (ash x -1)))))
-
-;;; store-half.
-;;;
-(define-instruction (sth)
-  (d-short (op :constant 2)
-	   (r2 :argument register :read t :write nil)
-	   (r3 :argument address-register)
-	   ;; We want the instruction to take byte indexes, but we plug the
-	   ;; index into the instruction as a half-word index.
-	   (i :argument (member 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
-	      :function (lambda (x) (ash x -1))))
-  (d (op :constant #xDC)
-     (r2 :argument register :read t :write nil)
-     (r3 :argument address-register)
-     (i :argument (signed-byte 16))))
-
-;;; load-word.
-;;;
-(define-instruction (l)
-  (d-short (op :constant 7)
-	   (r2 :argument register)
-	   (r3 :argument address-register)
-	   ;; We want the instruction to take byte indexes, but we plug the
-	   ;; index into the instruction as a word index.
-	   (i :argument (member 0 4 8 12 16 20 24 28 32 36 40 44 48 52 56 60)
-	      :function (lambda (x) (ash x -2))))
-  (d-short (op :constant 7)
-	   (r2 :argument register)
-	   (r3 :argument address-register)
-	   (i :constant 0))
-  (d (op :constant #xCD)
-     (r2 :argument register)
-     (r3 :argument address-register)
-     (i :argument (signed-byte 16))))
-
-;;; store-word.
-;;;
-(define-instruction (st)
-  (d-short (op :constant 3)
-	   (r2 :argument register :read t :write nil)
-	   (r3 :argument address-register)
-	   ;; We want the instruction to take byte indexes, but we plug the
-	   ;; index into the instruction as a word index.
-	   (i :argument (member 0 4 8 12 16 20 24 28 32 36 40 44 48 52 56 60)
-	      :function (lambda (x) (ash x -2))))
-  (d-short (op :constant 3)
-	   (r2 :argument register :read t :write nil)
-	   (r3 :argument address-register)
-	   (i :constant 0))
-  (d (op :constant #xDD)
-     (r2 :argument register :read t :write nil)
-     (r3 :argument address-register)
-     (i :argument (signed-byte 16))))
-
-
-;;;; Address computation.
-
-;;; compute-address-lower-half.
-;;;
-;;; The second format can be used for load-immediate (signed-byte 16).
-;;;
-(define-instruction (cal)
-  (d (op :constant #xC8)
-     (r2 :argument register)
-     (r3 :argument address-register)
-     (i :argument (signed-byte 16)))
-  (d (op :constant #xC8)
-     (r2 :argument register)
-     (r3 :same-as r2)
-     (i :argument (signed-byte 16)))
-  (d (op :constant #xC8)
-     (r2 :argument register)
-     (r3 :argument (integer 0 0) :read nil)
-     (i :argument (signed-byte 16)))
-  (d (op :constant #xC8)
-     (r2 :argument register)
-     (r3 :argument address-register)
-     (i :argument cal-fixup)))
-
-;;; compute-address-lower-half-16bit.
-;;;
-;;; The second format can be used for load-immediate (unsigned-byte 16).
-;;;
-(define-instruction (cal16)
-  (d (op :constant #xC2)
-     (r2 :argument register)
-     (r3 :argument address-register)
-     (i :argument (unsigned-byte 16)))
-  (d (op :constant #xC2)
-     (r2 :argument register)
-     (r3 :constant 0)
-     (i :argument (unsigned-byte 16))))
-
-;;; compute-address-upper-half.
-;;;
-(define-instruction (cau)
-  (d (op :constant #xD8)
-     (r2 :argument register)
-     (r3 :argument address-register)
-     (i :argument (unsigned-byte 16)))
-  (d (op :constant #xD8)
-     (r2 :argument register)
-     (r3 :argument (integer 0 0) :read nil)
-     (i :argument (unsigned-byte 16)))
-  (d (op :constant #xD8)
-     (r2 :argument register)
-     (r3 :constant 0)
-     (i :argument (unsigned-byte 16)))
-  (d (op :constant #xD8)
-     (r2 :argument register)
-     (r3 :constant 0)
-     (i :argument cau-fixup)))
-
-;;; compute-address-short.
-;;;
-;;; Use the second flavor to copy registers.
-;;;
-(define-instruction (cas)
-  (x (op :constant 6)
-     (r1 :argument register)
-     (r2 :argument register)
-     (r3 :argument address-register))
-  (x (op :constant 6)
-     (r1 :argument register)
-     (r2 :argument register)
-     (r3 :constant 0)))
-
-;;; increment.
-;;;
-(define-instruction (inc)
-  (r-immed
-   (op :constant #x91)
-   (r2 :argument register)
-   (r3 :argument (unsigned-byte 4))))
-
-;;; decrement
-;;;
-(define-instruction (dec)
-  (r-immed
-   (op :constant #x93)
-   (r2 :argument register)
-   (r3 :argument (unsigned-byte 4))))
-
-
-;;; load-immediate-short.
-;;;
-(define-instruction (lis)
-  (r-immed
-   (op :constant #xA4)
-   (r2 :argument register :read nil)
-   (r3 :argument (unsigned-byte 4))))
-
-
-
-;;;; Arithmetics.
-
-(macrolet ((define-math-inst (name &key two-regs unary short-immediate
-				   immediate function (signed t)
-				   (use nil use-p) 
-				   (clobber nil clobber-p))
-	     `(define-instruction (,name
-				   ,@(when use-p `(:use ,use))
-				   ,@(when clobber-p `(:clobber ,clobber)))
-		,@(when two-regs
-		    `((r (op :constant ,two-regs)
-			 (r2 :argument register)
-			 (r3 :argument register))
-		      (r (op :constant ,two-regs)
-			 (r2 :argument register)
-			 (r3 :same-as r2))))
-		,@(when unary
-		    `((r (op :constant ,unary)
-			 (r2 :argument register :read nil)
-			 (r3 :argument register))
-		      (r (op :constant ,unary)
-			 (r2 :argument register :read nil)
-			 (r3 :same-as r2))))
-		,@(when short-immediate
-		    `((r-immed
-		       (op :constant ,short-immediate)
-		       (r2 :argument register)
-		       (r3 :argument (unsigned-byte 4)))))
-		,@(when immediate
-		    `((d (op :constant ,immediate)
-			 (r2 :argument register)
-			 (r3 :argument register)
-			 (i :argument
-			    (,(if signed 'signed-byte 'unsigned-byte) 16)
-			    ,@(if function `(:function ,function))))
-		      (d (op :constant ,immediate)
-			 (r2 :argument register)
-			 (r3 :same-as r2)
-			 (i :argument
-			    (,(if signed 'signed-byte 'unsigned-byte) 16)
-			    ,@(if function `(:function ,function)))))))))
-
-  (define-math-inst a :two-regs #xE1 :short-immediate #x90 :immediate #xC1)
-  (define-math-inst ae :two-regs #xF1 :immediate #xD1 :use (cc))
-  (define-math-inst abs :unary #xE0)
-  (define-math-inst neg :unary #xE4) ;Arithmetic negation (two's complement).
-  (define-math-inst s :two-regs #xE2 :short-immediate #x92
-    :immediate #xC1 :function -)
-  (define-math-inst sf :two-regs #xB2 :immediate #xD2)
-  (define-math-inst se :two-regs #xF2 :use (cc))
-  (define-math-inst d :two-regs #xB6 :use (cc mq) :clobber (cc mq))
-  (define-math-inst m :two-regs #xE6 :use (cc mq) :clobber (cc mq))
-  
-  (define-math-inst exts :unary #xB1)
-  
-  (define-math-inst clrbl :short-immediate #x99)
-  (define-math-inst clrbu :short-immediate #x98)
-  (define-math-inst setbl :short-immediate #x9B)
-  (define-math-inst setbu :short-immediate #x9A)
-  
-  (define-math-inst not :unary #xF4) ;Logical not.
-  (define-math-inst n :two-regs #xE5)
-  (define-math-inst nilz :immediate #xC5 :signed nil)
-  (define-math-inst nilo :immediate #xC6 :signed nil)
-  (define-math-inst niuz :immediate #xD5 :signed nil)
-  (define-math-inst niuo :immediate #xD6 :signed nil)
-  (define-math-inst o :two-regs #xE3)
-  (define-math-inst oil :immediate #xC4 :signed nil)
-  (define-math-inst oiu :immediate #xC3 :signed nil)
-  (define-math-inst x :two-regs #xE7)
-  (define-math-inst xil :immediate #xC7 :signed nil)
-  (define-math-inst xiu :immediate #xD7 :signed nil)
-
-  (define-math-inst clz :two-regs #xF5)
-
-) ;macrolet
-
-
-;;; compare.
-;;; compare-immediate-short.
-;;; compare-immediate.
-;;;
-(define-instruction (c)
-  (r (op :constant #xB4)
-     (r2 :argument register :write nil)
-     (r3 :argument register))
-  (r-immed
-   (op :constant #x94)
-   (r2 :argument register :write nil)
-   (r3 :argument (unsigned-byte 4)))
-  (d (op :constant #xD4)
-     (r2 :constant 0)
-     (r3 :argument register)
-     (i :argument (signed-byte 16))))
-
-
-;;; compare-logical.
-;;; compare-logical-immediate.
-;;;
-(define-instruction (cl)
-  (r (op :constant #xB3)
-     (r2 :argument register :write nil)
-     (r3 :argument register))
-  (d (op :constant #xD3)
-     (r2 :constant 0)
-     (r3 :argument register)
-     (i :argument (signed-byte 16))))
-
-
-
-;;;; Shifting.
-
-(define-instruction (sr)
-  (r (op :constant #xB8)
-     (r2 :argument register)
-     (r3 :argument register))
-  (r-immed
-   (op :constant #xA8)
-   (r2 :argument register :write nil)
-   (r3 :argument (unsigned-byte 4)))
-  (r-immed
-   (op :constant #xA9)
-   (r2 :argument register :write nil)
-   (r3 :argument (integer 16 31)
-       :function (lambda (x) (- x 16)))))
-
-(define-instruction (sl)
-  (r (op :constant #xBA)
-     (r2 :argument register)
-     (r3 :argument register))
-  (r-immed
-   (op :constant #xAA)
-   (r2 :argument register)
-   (r3 :argument (unsigned-byte 4)))
-  (r-immed
-   (op :constant #xAB)
-   (r2 :argument register)
-   (r3 :argument (integer 16 31)
-       :function (lambda (x) (- x 16)))))
-
-(define-instruction (sar)
-  (r (op :constant #xB0)
-     (r2 :argument register)
-     (r3 :argument register))
-  (r-immed
-   (op :constant #xA0)
-   (r2 :argument register)
-   (r3 :argument (unsigned-byte 4)))
-  (r-immed
-   (op :constant #xA1)
-   (r2 :argument register)
-   (r3 :argument (integer 16 31)
-       :function (lambda (x) (- x 16)))))
-
-
-;;;; Branch instructions.
-
-;;; There are some pseudo-instructions defined after this page that use these
-;;; definitions.
-;;;
-
-(define-instruction (jb)
-  (j1 (op :constant 0)
-      (sub-op :constant 1)
-      (n :argument jump-condition)
-      (j1 :argument relative-label)))
-
-(define-instruction (jnb)
-  (j1 (op :constant 0)
-      (sub-op :constant 0)
-      (n :argument jump-condition)
-      (j1 :argument relative-label)))
-
-(macrolet ((define-branch-inst (name immediate-op register-op)
-	     `(define-instruction (,name)
-		(bi (op :constant ,immediate-op)
-		    (r2 :argument branch-condition)
-		    (bi :argument relative-label))
-		(r (op :constant ,register-op)
-		   (r2 :argument branch-condition :read nil :write nil)
-		   (r3 :argument register)))))
-
-  ;; branch-on-condition-bit-immediate.
-  ;; branch-on-condition-bit-register.
-  ;;
-  (define-branch-inst bb #x8E #xEE)
-  
-  ;; branch-on-condition-bit-immediate-with-execute.
-  ;; branch-on-condition-bit-register-with-execute.
-  ;;
-  (define-branch-inst bbx #x8F #xEF)
-
-  ;; branch-on-not-condition-bit-immediate.
-  ;; branch-on-not-condition-bit-register.
-  ;;
-  (define-branch-inst bnb #x88 #xE8)
-
-  ;; branch-on-not-condition-bit-immediate-with-execute.
-  ;; branch-on-not-condition-bit-register-with-execute.
-  ;;
-  (define-branch-inst bnbx #x89 #xE9)
-
-) ;MACROLET
-
-(define-instruction (bala)
-  (ba (op :constant #x8A)
-      (ba :argument ba-fixup)))
-
-(define-instruction (balax)
-  (ba (op :constant #x8B)
-      (ba :argument ba-fixup)))
-
-
-
-;;;; Pseudo-instructions
-
-;;; move.
-;;;
-;;; This body is the second format of compute-address-short.
-;;;
-(define-instruction (move)
-  (x (op :constant 6)
-     (r1 :argument register)
-     (r2 :argument register)
-     (r3 :constant 0)))
-
-;;;
-;;; A couple load-immediate pseudo-instructions.
-;;;
-
-;;; load-immediate.
-;;;
-;;; This might affect the condition codes, but it allows for loading 32-bit
-;;; quantities into R0.
-;;;
-(define-pseudo-instruction li 64 (reg value)
-  (etypecase value
-    ((unsigned-byte 4)
-     (inst lis reg value))
-    ((signed-byte 16)
-     (inst cal reg 0 value))
-    ((unsigned-byte 16)
-     (inst cal16 reg value))
-    ((or (signed-byte 32) (unsigned-byte 32))
-     (inst cau reg (ldb (byte 16 16) value))
-     (let ((low (ldb (byte 16 0) value)))
-       (unless (zerop low)
-	 (inst oil reg low))))))
-
-;;; compute-address-immediate.
-;;;
-;;; This basically exists to load 32-bit constants into address-registers, and
-;;; it does not affect condition codes.  Since fixups are always addresses, we
-;;; have the fixup branch here instead of in load-immediate.  We may use the
-;;; other branches since it already exists.
-;;;
-(define-pseudo-instruction cai 64 (reg value)
-  (etypecase value
-    ((unsigned-byte 4)
-     (inst lis reg value))
-    ((signed-byte 16)
-     (inst cal reg 0 value))
-    ((unsigned-byte 16)
-     (inst cal16 reg value))
-    ((or (signed-byte 32) (unsigned-byte 32))
-     (inst cau reg (ldb (byte 16 16) value))
-     (let ((low (ldb (byte 16 0) value)))
-       (unless (zerop low)
-	 (inst cal16 reg reg low))))
-    (fixup
-     (inst cau reg value)
-     (inst cal reg reg value))))
-
-
-;;; branch-unconditional.
-;;;
-(define-pseudo-instruction b 32 (target)
-  (if (and (assem::label-p target)
-	   (<= -128 (label-offset target) 127))
-      (inst jnb :pz target)
-      (inst bnb :pz target)))
-
-;;; branch-unconditional-with-execute.
-;;;
-(define-pseudo-instruction bx 32 (target)
-  (inst bnbx :pz target))
-
-;;; branch-condition.
-;;;
-(define-pseudo-instruction bc 32 (condition target)
-  (if (and (assem::label-p target)
-	   (<= -128 (label-offset target) 127))
-      (inst jb condition target)
-      (inst bb condition target)))
-
-;;; branch-not-condition.
-;;;
-(define-pseudo-instruction bnc 32 (condition target)
-  (if (and (assem::label-p target)
-	   (<= -128 (label-offset target) 127))
-      (inst jnb condition target)
-      (inst bnb condition target)))
-
-;;; branch-condition-with-execute.
-;;; branch-not-condition-with-execute.
-;;;
-;;; We define these, so VOP readers see a consistent naming scheme in branch
-;;; instructions.
-;;;
-(define-pseudo-instruction bcx 32 (condition target)
-  (inst bbx condition target))
-;;;
-(define-pseudo-instruction bncx 32 (condition target)
-  (inst bnbx condition target))
-
-;;; no-op.
-;;;
-;;; This is compute-address-short, adding zero to R0 putting the result in R0.
-;;;
-(define-instruction (no-op)
-  (x (op :constant 6)
-     (r1 :constant 0)
-     (r2 :constant 0)
-     (r3 :constant 0)))
-
-(define-format (word-format 32)
-  (data (byte 32 0)))
-(define-instruction (word)
-  (word-format (data :argument (or (unsigned-byte 32) (signed-byte 32)))))
-
-(define-format (short-format 16)
-  (data (byte 16 0)))
-(define-instruction (short)
-  (short-format (data :argument (or (unsigned-byte 16) (signed-byte 16)))))
-
-(define-format (byte-format 8)
-  (data (byte 8 0)))
-(define-instruction (byte)
-  (byte-format (data :argument (or (unsigned-byte 8) (signed-byte 8)))))
-
-
-
-;;;; Breaking.
-
-(define-instruction (tge)
-  (r (op :constant #xBD)
-     (r2 :argument register)
-     (r3 :argument register)))
-
-(define-instruction (tlt)
-  (r (op :constant #xBE)
-     (r2 :argument register)
-     (r3 :argument register)))
-
-;;; break.
-;;;
-;;; This is trap-on-condition-immediate.  We use the immediate field to
-;;; stick in a constant value indicating why we're breaking.
-;;;
-(define-instruction (break)
-  (d (op :constant #xCC)
-     (r2 :constant #b0111)
-     (r3 :constant 0)
-     (i :argument (signed-byte 16))))
-
-
-
-;;;; System control.
-
-;;; move-to-multiplier-quotient-system-control-register
-;;;
-(define-instruction (mtmqscr)
-  (r (op :constant #xB5)
-     (r2 :constant 10)
-     (r3 :argument register)))
-
-;;; move-from-multiplier-quotient-system-control-register
-;;;
-(define-instruction (mfmqscr)
-  (r (op :constant #x96)
-     (r2 :constant 10)
-     (r3 :argument register :read nil :write t)))
-
-
-
-;;;; Function and LRA Headers emitters and calculation stuff.
-
-(defun header-data (ignore)
-  (declare (ignore ignore))
-  (ash (+ *current-position* (component-header-length)) (- vm:word-shift)))
-
-(define-format (header-object 32)
-  (type (byte 8 0))
-  (data (byte 24 8) :default 0 :function header-data))
-
-(define-instruction (function-header-word)
-  (header-object (type :constant vm:function-header-type)))
-
-(define-instruction (lra-header-word)
-  (header-object (type :constant vm:return-pc-header-type)))
-
-
-;;; DEFINE-COMPUTE-INSTRUCTION -- Internal.
-;;;
-;;; This defines a pseudo-instruction, name, which requires the other specific
-;;; instructions.  When the pseudo-instruction expands, it looks at the current
-;;; value of the calculation to choose between two instruction sequences.
-;;; Later, when the assembler emits the instructions, the :function's run to
-;;; really compute the calculation's value.  This is guaranteed to be lesser in
-;;; magnitude than the original test in the pseudo-instruction since all these
-;;; calculation are relative to the component start, so we can only remove
-;;; instructions in that range, not add them.
-;;;
-(defmacro define-compute-instruction (name calculation)
-  (let ((cal (symbolicate name "-CAL"))
-	(cau (symbolicate name "-CAU")))
-    `(progn
-       ;; This is a special compute-address-lower that takes a label and
-       ;; asserts the type of the immediate value.
-       (defun ,name (label)
-	 (let* ((whole ,calculation)
-		(low (logand whole #xffff))
-		(high (ash whole -16)))
-	   (values (if (logbitp 15 low)
-		       (1+ high)
-		       high)
-		   low)))
-       (define-instruction (,cal)
-	 (d (op :constant #xC8)
-	    (r2 :argument register)
-	    (r3 :argument address-register)
-	    (i :argument label
-	       :function (lambda (label)
-			   (multiple-value-bind (high low) (,name label)
-			     (declare (ignore high))
-			     low)))))
-       (define-instruction (,cau)
-	 (d (op :constant #xD8)
-	    (r2 :argument register)
-	    (r3 :argument address-register)
-	    (i :argument label
-	       :function (lambda (label)
-			   (multiple-value-bind (high low) (,name label)
-			     (declare (ignore low))
-			     high)))))
-       (define-pseudo-instruction ,name 64 (dst src label)
-	 (multiple-value-bind (high low) (,name label)
-	   (declare (ignore low))
-	   (cond ((zerop high)
-		  (inst ,cal dst src label))
-		 (t
-		  (inst ,cal dst src label)
-		  (inst ,cau dst dst label))))))))
-
-
-;; code = fn - header - label-offset + other-pointer-tag
-(define-compute-instruction compute-code-from-fn
-			    (- vm:other-pointer-type
-			       (label-position label)
-			       (component-header-length)))
-
-;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
-(define-compute-instruction compute-code-from-lra
-			    (- (+ (label-position label)
-				  (component-header-length))))
-
-;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
-(define-compute-instruction compute-lra-from-code
-			    (+ (label-position label)
-			       (component-header-length)))
-
-;;;; 68881 instruction set details:
-
-;;; The low 7 bits of the 68881 instructions.
-;;; 
-(defconstant mc68881-opcodes
-  '((:move . #x00)
-    (:int . #x01)
-    (:sinh . #x02)
-    (:intrz . #x03)
-    (:sqrt . #x04)
-    (:lognp1 . #x06)
-    (:etoxm1 . #x08)
-    (:tanh . #x09)
-    (:atan . #x0A)
-    (:asin . #x0C)
-    (:atanh . #x0D)
-    (:sin . #x0E)
-    (:tan . #x0F)
-    (:etox . #x10)
-    (:twotox . #x11)
-    (:tentox . #x12)
-    (:logn . #x14)
-    (:log10 . #x15)
-    (:log2 . #x16)
-    (:abs . #x18)
-    (:cosh . #x19)
-    (:neg . #x1A)
-    (:acos . #x1C)
-    (:cos . #x1D)
-    (:getexp . #x1E)
-    (:getman . #x1F)
-    (:div . #x20)
-    (:mod . #x21)
-    (:add . #x22)
-    (:mul . #x23)
-    (:sgldiv . #x24)
-    (:rem . #x25)
-    (:scale . #x26)
-    (:sglmul . #x27)
-    (:sub . #x28)
-    (:sincos . #x30)
-    (:cmp . #x38)
-    (:tst . #x3A)))
-
-
-;;; Names of interesting 68881 control registers.
-;;;
-(defconstant mc68881-control-regs
-  '((:fpsr . 2)
-    (:fpcr . 4)
-    (:fpiar . 1)))
-
-
-;;; The encoding of operand format in memory (bits 10..12 in the 68881
-;;; instruction.)
-;;;
-(defconstant mc68881-operand-types
-  '((:integer . 0)	      ; 32 bit integer.
-    (:single . 1)	      ; 32 bit float.
-    (:double . 5)))	      ; 64 bit float.
-
-
-;;; Bits 13..15 in the 68881 instruction.  Controls where operands are found.
-;;;
-(defconstant mc68881-instruction-classes
-  '((:freg-to-freg . 0)
-    (:mem-to-freg . 2)
-    (:freg-to-mem . 3)
-    (:mem-to-scr . 4)
-    (:scr-to-mem . 5)))
-
-
-;;; Length in words of memory data to transfer.  This is part of the RT
-;;; hardware assist protocol, and is placed in the low two bits of the address
-;;; to the store instruction.
-;;;
-(defconstant mc68881-operand-lengths
-  '((nil . 0) ; No transfer...
-    (:integer . 1)
-    (:single . 1)
-    (:double . 2)))
-
-;;; RT hardware assist protocol for whether to read or write memory, here
-;;; represented as a function of the mc68881 instruction class.
-;;; 
-(defconstant mc68881-transfer-control-field-alist
-  '((:freg-to-freg . 0)
-    (:mem-to-freg . 0)
-    (:freg-to-mem . #x3c0000)
-    (:mem-to-scr . 0)
-    (:scr-to-mem . #x3c0000)))
-
-
-(defun mc68881-fp-reg-p (object)
-  (and (tn-p object)
-       (eq (sb-name (sc-sb (tn-sc object)))
-	   'mc68881-float-registers)))
-
-(define-argument-type mc68881-fp-reg
-  :type '(satisfies mc68881-fp-reg-p)
-  :function tn-offset)
-
-;;; This is really a ST (store word) instruction, but we have magic extra
-;;; arguments to represent the reading and writing of the FP registers.  R3
-;;; will already have been set up with the high bits of the FP instruction by a
-;;; preceding CAL.
-;;;
-(define-format (mc68881-inst 32)
-  (fpn (byte 0 0) :read t :write t)
-  (fpm (byte 0 0) :read t)
-  (op (byte 8 24) :default #xDD)
-  (r2 (byte 4 20) :read t)
-  (r3 (byte 4 16) :read t)
-  (i (byte 16 0)))
-
-
-;;; DO-68881-INST  --  Internal
-;;;
-;;;    Utility used to emit a 68881 operation.  We emit the CAU that sets up
-;;; the high bits of the operation in Temp, and we return the low bits that
-;;; should be passed as the I field of the actual FP operation instruction.
-;;;
-(defun do-68881-inst (op temp &key fpn fpm (class :freg-to-freg)
-			 data optype creg)
-  (assert (if fpm
-	      (and (mc68881-fp-reg-p fpm)
-		   (not (or optype data))
-		   (eql class :freg-to-freg))
-	      (and (tn-p data)
-		   (eq (sb-name (sc-sb (tn-sc data))) 'registers)
- 		   (or optype creg)
-		   (not (eql class :freg-to-freg)))))
-  (assert (if fpn
-	      (mc68881-fp-reg-p fpn)
-	      (and creg (member class '(:mem-to-scr :scr-to-mem)))))
-		   
-  (let* ((opcode
-	  (logior #xFC000000
-		  (or (cdr (assoc class mc68881-transfer-control-field-alist))
-		      (error "Unknown instruction class ~S." class))
-		  (ash (cdr (assoc class mc68881-instruction-classes))
-		       15)
-		  (ash (ecase class
-			 (:freg-to-freg (tn-offset fpm))
-			 ((:mem-to-freg :freg-to-mem)
-			  (or (cdr (assoc optype mc68881-operand-types))
-			      (error "Unknown operation type ~S." optype)))
-			 ((:mem-to-scr :scr-to-mem)
-			  (or (cdr (assoc creg mc68881-control-regs))
-			      (error "Unknown control register ~S." creg))))
-		       12)
-		  (ash (if fpn
-			   (tn-offset fpn)
-			   0)
-		       9)
-		  (ash (or (cdr (assoc op mc68881-opcodes))
-			   (error "Unknown opcode ~S." op))
-		       2)
-		  (if creg
-		      1
-		      (or (cdr (assoc optype mc68881-operand-lengths))
-			  (error "Unknown operation type ~S." optype)))))
-	 (low (logand opcode #xFFFF))
-	 (high (+ (logand (ash opcode -16) #xFFFF)
-		  (if (eql (logand low #x8000) 0) 0 1))))
-    (inst cau temp 0 high)
-    low))
-
-
-(define-instruction (mc68881-binop-inst)
-  (mc68881-inst
-   (fpn :argument mc68881-fp-reg)
-   (fpm :argument mc68881-fp-reg)
-   (r2 :constant null-offset)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-;;; This pseudo-instruction emits a floating-point binop on the 68881.  FPN is
-;;; the destination float register (and second arg) FPM is the source float
-;;; register.  Op is the 68881 opcode.  Temp is a sap-reg (i.e. non-zero,
-;;; non-descriptor) register that we form the FP instruction in.
-;;;
-(define-pseudo-instruction mc68881-binop 64 (fpn fpm op temp)
-  (inst mc68881-binop-inst fpn fpm temp
-	(do-68881-inst op temp :fpm fpm :fpn fpn)))
-
-
-;;; Unop is like binop, but we don't read FPN before we write it.
-;;;
-(define-instruction (mc68881-unop-inst)
-  (mc68881-inst
-   (fpn :argument mc68881-fp-reg :read nil)
-   (fpm :argument mc68881-fp-reg)
-   (r2 :constant null-offset)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction mc68881-unop 64 (fpn fpm op temp)
-  (inst mc68881-unop-inst fpn fpm temp
-	(do-68881-inst op temp :fpm fpm :fpn fpn)))
-
-;;; Compare is like binop, but we don't write FPN.
-;;;
-(define-instruction (mc68881-compare-inst)
-  (mc68881-inst
-   (fpn :argument mc68881-fp-reg :write nil)
-   (fpm :argument mc68881-fp-reg)
-   (r2 :constant null-offset)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction mc68881-compare 64 (fpn fpm op temp)
-  (inst mc68881-compare-inst fpn fpm temp
-	(do-68881-inst op temp :fpm fpm :fpn fpn)))
-
-;;; Move FPM to FPN.
-;;;
-(define-pseudo-instruction mc68881-move 64 (fpn fpm temp)
-  (inst mc68881-unop fpn fpm :move temp))
-
-
-
-(define-format (s 16)
-  (op (byte 12 4))
-  (n (byte 4 0)))
-			   
-;;; This is a "setcb 8", which is used to wait for a result from the FPA to
-;;; appear in memory (or something...)
-;;;
-(define-instruction (mc68881-wait)
-  (s
-   (op :constant #x97F)
-   (n :constant 8)))
-
-
-(define-instruction (mc68881-load-inst :use (memory))
-  (mc68881-inst
-   (fpn :argument mc68881-fp-reg :read nil)
-   (fpm :constant 0)
-   (r2 :argument register)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction mc68881-load 80 (fpn data optype temp)
-  (inst mc68881-load-inst fpn data temp
-	(do-68881-inst :move temp :fpn fpn :data data :optype optype
-		       :class :mem-to-freg))
-  (inst mc68881-wait))
-
-(define-instruction (mc68881-store-inst :clobber (memory))
-  (mc68881-inst
-   (fpn :argument mc68881-fp-reg :write nil)
-   (fpm :constant 0)
-   (r2 :argument register)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction mc68881-store 80 (fpn data optype temp)
-  (inst mc68881-store-inst fpn data temp
-	(do-68881-inst :move temp :fpn fpn :data data :optype optype
-		       :class :freg-to-mem))
-  (inst mc68881-wait))
-
-
-(define-instruction (mc68881-load-status-inst :use (memory)
-					      :clobber (float-status))
-  (mc68881-inst
-   (fpn :constant 0)
-   (fpm :constant 0)
-   (r2 :argument register)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction mc68881-load-status 80 (creg data temp)
-  (inst mc68881-load-status-inst data temp
-	(do-68881-inst :move temp :creg creg :data data
-		       :class :mem-to-scr))
-  (inst mc68881-wait))
-
-(define-instruction (mc68881-store-status-inst :clobber (memory)
-					       :use (float-status))
-  (mc68881-inst
-   (fpn :constant 0)
-   (fpm :constant 0)
-   (r2 :argument register)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction mc68881-store-status 80 (creg data temp)
-  (inst mc68881-store-status-inst data temp
-	(do-68881-inst :move temp :creg creg :data data
-		       :class :scr-to-mem))
-  (inst mc68881-wait))
-
-
-;;; AFPA instruction set details:
-
-;;; Support for the AFPA on IBM RT PC (APC and EAPC models).
-
-(defconstant afpa-opcodes
-  '((:absl . #x74)
-    (:abss . #x75)
-    (:addl . #x40)
-    (:adds . #x41)
-    (:coml . #x48)
-    (:coms . #x49)
-    (:comtl . #x4A)
-    (:comts . #x4B)
-    (:csl  . #x1B)
-    (:cls  . #x16)
-    (:cwl  . #x03)
-    (:cws  . #x07)
-    (:copl . #x44)
-    (:cops . #x45)
-    (:divl . #x60)
-    (:divs . #x61)
-    (:flw  . #x3B)
-    (:fsw  . #x3F)
-    (:mull . #x70)
-    (:muls . #x71)
-    (:negl . #x54)
-    (:negs . #x55)
-    (:noop . #x9F)
-    (:rdfr . #xBC) ; type = ld
-    (:rlw  . #x23)
-    (:rsw  . #x27)
-    (:subl . #x50)
-    (:subs . #x51)
-    (:tlw  . #x2B)
-    (:tsw  . #x2F)
-    (:wtfr . #x94)))
-  
-(defconstant afpa-special-opcodes
-  '((:wtstr . #.(ash #x10FEE 2)) ; DS = #b01, OP1, OP2 = #xE.
-    (:rdstr . #.(ash #x137EE 2)) ; DS = #b01, OP1, OP2 = #xE, type = ld
-    (:rddma . #.(ash #xF9F00 2)))) ; DS = #b11, OP2 = #x30
-
-(defconstant afpa-ds-codes
-  '((:register . #b00)
-    (:fr1-immediate . #b10)
-    (:fr2-immediate . #b01)))
-
-(defconstant afpa-ts-codes
-  '((:pio . #b00)
-    (:word . #b01)
-    (:single . #b01)
-    (:double . #b10)
-    (:multiple . #b11)))
-
-#|
-(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-sqrl #x064)
-(defconstant afpa-sqrs #x065)
-(defconstant afpa-tanl #x0C4)
-|#
-
-(defun afpa-fp-reg-p (object)
-  (and (tn-p object)
-       (eq (sb-name (sc-sb (tn-sc object)))
-	   'afpa-float-registers)))
-
-(define-argument-type afpa-fp-reg
-  :type '(satisfies afpa-fp-reg-p)
-  :function tn-offset)
-
-;;; These are really L and ST (load and store word) instructions, but we have
-;;; magic extra arguments to represent the reading and writing of the FP
-;;; registers.  R3 will already have been set up with the high bits of the FP
-;;; instruction by a preceding CAL.
-;;;
-(define-format (afpa-l-inst 32)
-  (fr2 (byte 0 0) :default 0)
-  (fr1 (byte 0 0) :read t)
-  (op (byte 8 24) :default #xCD)
-  (r2 (byte 4 20) :write t)
-  (r3 (byte 4 16) :read t)
-  (i (byte 16 0)))
-;;;
-(define-format (afpa-st-inst 32)
-  (fr2 (byte 0 0) :read t :write t)
-  (fr1 (byte 0 0) :read t)
-  (op (byte 8 24) :default #xDD)
-  (r2 (byte 4 20) :read t)
-  (r3 (byte 4 16) :read t)
-  (i (byte 16 0)))
-
-
-;;; DO-AFPA-INST  --  Internal
-;;;
-;;;    Utility used to emit a afpa operation.  We emit the CAU that sets up
-;;; the high bits of the operation in Temp, and we return the low bits that
-;;; should be passed as the I field of the actual FP operation instruction.
-;;;
-;;; Note: FR2 is the modified register (if any), and the *first* operand to
-;;; binops (I didn't make this up.)
-;;;
-(defun do-afpa-inst (op temp &key fr1 fr2 (ds :register) (ts :pio)
-			data odd)
-  (when fr1
-    (assert (afpa-fp-reg-p fr1)))
-  (when fr2
-    (assert (afpa-fp-reg-p fr2)))
-  (when data
-    (assert (and (tn-p data)
-		 (eq (sb-name (sc-sb (tn-sc data))) 'registers)
-		 (not (and fr1 fr2)))))
-  (when odd (assert data))
-  (let* ((inc (if odd 1 0))
-	 (fr1-offset (if fr1 (+ (tn-offset fr1) inc) 0))
-	 (fr2-offset (if fr2 (+ (tn-offset fr2) inc) 0))
-	 (opcode
-	  (logior (ash (if (eq ts :pio) #xFF #xFE) 24)
-		  (ash (ldb (byte 2 4) fr1-offset) 22)
-		  (ash (ldb (byte 2 4) fr2-offset) 20)
-		  (ash (or (cdr (assoc ds afpa-ds-codes))
-			   (error "Unknown DS code: ~S." ds))
-		       18)
-		  (let ((res (cdr (assoc op afpa-opcodes))))
-		    (if res
-			(ash res 10)
-			(or (cdr (assoc op afpa-special-opcodes))
-			    (error "Unknown opcode: ~S." op))))
-		  (ash (ldb (byte 4 0) fr1-offset) 6)
-		  (ash (ldb (byte 4 0) fr2-offset) 2)
-		  (or (cdr (assoc ts afpa-ts-codes))
-		      (error "Unknown TS code: ~S." ts))))
-	 (low (logand opcode #xFFFF))
-	 (high (+ (logand (ash opcode -16) #xFFFF)
-		  (if (eql (logand low #x8000) 0) 0 1))))
-    (inst cau temp 0 high)
-    low))
-
-
-;;; The AFPA-BINOP pseudo-instruction emits a floating-point binop on the afpa.
-;;; FR2 is the destination float register (and first arg).  FR1 is the source
-;;; float register.  Op is the afpa opcode.  Temp is a sap-reg (i.e. non-zero,
-;;; non-descriptor) register that we form the FP instruction in.
-;;;
-(define-instruction (afpa-binop-inst)
-  (afpa-st-inst
-   (fr2 :argument afpa-fp-reg)
-   (fr1 :argument afpa-fp-reg)
-   (r2 :constant null-offset)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-;;;
-(define-pseudo-instruction afpa-binop 64 (fr2 fr1 op temp)
-  (inst afpa-binop-inst fr2 fr1 temp
-	(do-afpa-inst op temp :fr1 fr1 :fr2 fr2)))
-
-
-;;; Unop is like binop, but we don't read FR2 before we write it.
-;;;
-(define-instruction (afpa-unop-inst)
-  (afpa-st-inst
-   (fr2 :argument afpa-fp-reg :read nil)
-   (fr1 :argument afpa-fp-reg)
-   (r2 :constant null-offset)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction afpa-unop 64 (fr2 fr1 op temp)
-  (inst afpa-unop-inst fr2 fr1 temp
-	(do-afpa-inst op temp :fr1 fr1 :fr2 fr2)))
-
-;;; Sugar up the move a bit...
-(define-pseudo-instruction afpa-move 64 (fr2 fr1 format temp)
-  (inst afpa-unop fr2 fr1
-	(ecase format
-	  (:single :cops)
-	  (:double :copl))
-	temp))
-
-;;; Compare is like binop, but we don't write FR2.
-;;;
-(define-instruction (afpa-compare-inst)
-  (afpa-st-inst
-   (fr2 :argument afpa-fp-reg :write nil)
-   (fr1 :argument afpa-fp-reg)
-   (r2 :constant null-offset)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction afpa-compare 64 (fr2 fr1 op temp)
-  (inst afpa-compare-inst fr2 fr1 temp
-	(do-afpa-inst op temp :fr1 fr1 :fr2 fr2)))
-
-
-;;; Noop is used to wait for DMA operations (load and store) to complete.
-;;;
-(define-instruction (afpa-noop-inst :pinned t)
-  (afpa-st-inst
-   (fr1 :constant 0)
-   (fr2 :constant 0)
-   (r2 :constant null-offset)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction afpa-noop 64 (temp)
-  (inst afpa-noop-inst temp
-	(do-afpa-inst :noop temp)))
-
-
-;;; Load = WTFR (write float reg) + DMA.
-;;;
-(define-instruction (afpa-load-inst :use (memory))
-  (afpa-st-inst
-   (fr2 :argument afpa-fp-reg :read nil)
-   (fr1 :constant 0)
-   (r2 :argument register)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction afpa-load 64 (fr2 data ts temp)
-  (inst afpa-load-inst fr2 data temp
-	(do-afpa-inst :wtfr temp :fr2 fr2 :data data :ts ts)))
-
-
-;;; Store = RDDMA
-;;;
-(define-instruction (afpa-store-inst :clobber (memory))
-  (afpa-st-inst
-   (fr2 :constant 0)
-   (fr1 :argument afpa-fp-reg)
-   (r2 :argument register)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction afpa-store 64 (fr1 data ts temp)
-  (inst afpa-store-inst fr1 data temp
-	(do-afpa-inst :rddma temp :fr1 fr1 :data data :ts ts)))
-
-
-;;; Get float = RDFR
-;;;
-(define-instruction (afpa-get-float-inst :clobber (float-status))
-  (afpa-l-inst
-   (fr2 :constant 0)
-   (fr1 :argument afpa-fp-reg)
-   (r2 :argument register)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction afpa-get-float 64 (data fr1 temp)
-  (inst afpa-get-float-inst fr1 data temp
-	(do-afpa-inst :rdfr temp :fr1 fr1 :data data)))
-
-(define-pseudo-instruction afpa-get-float-odd 64 (data fr1 temp)
-  (inst afpa-get-float-inst fr1 data temp
-	(do-afpa-inst :rdfr temp :fr1 fr1 :data data :odd t)))
-
-
-;;; Put float = WTFR
-;;;
-(define-instruction (afpa-put-float-inst)
-  (afpa-st-inst
-   (fr2 :argument afpa-fp-reg)
-   (fr1 :constant 0)
-   (r2 :argument register)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction afpa-put-float 64 (fr2 data temp)
-  (inst afpa-put-float-inst fr2 data temp
-	(do-afpa-inst :wtfr temp :fr2 fr2 :data data)))
-
-(define-pseudo-instruction afpa-put-float-odd 64 (fr2 data temp)
-  (inst afpa-put-float-inst fr2 data temp
-	(do-afpa-inst :wtfr temp :fr2 fr2 :data data :odd t)))
-
-
-;;; Get status = RDSTR
-;;;
-(define-instruction (afpa-get-status-inst :clobber (float-status))
-  (afpa-l-inst
-   (fr2 :constant 0)
-   (fr1 :constant 0)
-   (r2 :argument register)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction afpa-get-status 64 (data temp)
-  (inst afpa-get-status-inst data temp
-	(do-afpa-inst :rdstr temp :data data)))
-
-
-;;; Put status = WTSTR
-;;;
-(define-instruction (afpa-put-status-inst :use (float-status))
-  (afpa-st-inst
-   (fr2 :constant 0)
-   (fr1 :constant 0)
-   (r2 :argument register)
-   (r3 :argument address-register)
-   (i :argument (unsigned-byte 16))))
-
-(define-pseudo-instruction afpa-put-status 64 (data temp)
-  (inst afpa-put-status-inst data temp
-	(do-afpa-inst :wtstr temp :data data)))
diff --git a/compiler/rt/macros.lisp b/compiler/rt/macros.lisp
deleted file mode 100644
index e3a0306147480170a16c6250f54332bbd272e316..0000000000000000000000000000000000000000
--- a/compiler/rt/macros.lisp
+++ /dev/null
@@ -1,540 +0,0 @@
-;;; -*- Package: RT; 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)
-;;; **********************************************************************
-;;;
-;;; This file contains various useful macros for generating code for the IBM
-;;; RT.
-;;;
-;;; Written by William Lott, Christopher Hoover, and Rob Maclachlin, and Bill
-;;; Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-;;; Instruction-like macros.
-
-;;; MOVE -- Interface.
-;;;
-(defmacro move (dst src)
-  "Move src into dst unless they are LOCATION=."
-  (once-only ((n-dst dst)
-	      (n-src src))
-    `(unless (location= ,n-dst ,n-src)
-       (inst move ,n-dst ,n-src))))
-
-;;; LOADW and STOREW -- Interface.
-;;;
-;;; Load and store words.
-;;;
-(macrolet ((def-mem-op (op inst)
-	    `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
-	       `(inst ,',inst ,object ,base
-		      (- (ash ,offset word-shift) ,lowtag)))))
-  (def-mem-op loadw l)
-  (def-mem-op storew st))
-
-;;; LOAD-SYMBOL -- Interface.
-;;;
-(defmacro load-symbol (reg symbol)
-  "Load a pointer to the static symbol into reg."
-  `(inst a ,reg null-tn (static-symbol-offset ,symbol)))
-
-;;; LOAD-SYMBOL-FUNCTION, STORE-SYMBOL-FUNCTION,
-;;; LOAD-SYMBOL-VALUE, STORE-SYMBOL-VALUE		-- interface.
-;;;
-(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)
-	      `(inst l ,reg null-tn
-		     (+ (static-symbol-offset ',symbol)
-			(ash ,',offset word-shift)
-			(- other-pointer-type))))
-	    (defmacro ,storer (reg symbol)
-	      `(inst st ,reg null-tn
-		     (+ (static-symbol-offset ',symbol)
-			(ash ,',offset word-shift)
-			(- other-pointer-type))))))))
-  (frob value)
-  (frob function))
-
-;;; LOAD-TYPE -- Interface.
-;;;
-;;; Subtract the low-tag from the pointer and add one less than the address
-;;; units per word to get us to the low byte since the RT is big-endian.
-;;;
-(defmacro load-type (target source &optional (low-tag 0))
-  "Loads the type bits from the source pointer into target, where pointer has
-   the specified low-tag."
-  `(inst lc ,target ,source (- word-bytes 1 ,low-tag)))
-
-
-
-;;;; Call and Return.
-
-;;; Macros to handle the fact that we cannot use the machine native call and
-;;; return instructions due to low-tag bits on pointers.
-;;;
-
-;;; LISP-JUMP -- Interface.
-;;;
-(defmacro lisp-jump (function lip)
-  "Jump to the lisp function.  Lip is the lisp interior pointer register
-   used as a temporary."
-  `(progn
-     (inst cal ,lip ,function (- (ash function-header-code-offset
-				      word-shift)
-				 function-pointer-type))
-     (inst bx ,lip)
-     (move code-tn ,function)))
-
-;;; LISP-RETURN -- Interface.
-;;;
-(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
-  "Return to return-pc, an LRA.  Lip is the lisp interior pointer register
-   used as a temporary.  Offset is the number of words to skip at the target,
-   and it has to be small enough for whatever instruction used in here."
-  `(progn
-     (inst cal ,lip ,return-pc
-	   (- (ash (1+ ,offset) word-shift) other-pointer-type))
-     ,@(if frob-code
-	  `((inst bx ,lip)
-	    (move code-tn ,return-pc))
-	  `((inst b ,lip)))))
-
-;;; EMIT-RETURN-PC -- Interface.
-;;;
-(defmacro emit-return-pc (label)
-  "Emit a return-pc header word, making sure it is aligned properly for our
-   low-tag bits since there are other-pointers referring to the LRA's.  label
-   is the label to use for this return-pc."
-  `(progn
-     (align 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.  If the VOP is supplied,
-;;; we can load from (or store onto) the number stack also.
-;;;
-(defmacro load-stack-tn (reg stack &optional vop)
-  (once-only ((n-reg reg)
-	      (n-stack stack))
-    `(sc-case ,n-stack
-       (control-stack
-	(loadw ,n-reg cfp-tn (tn-offset ,n-stack)))
-       ,@(when vop
-	   `(((unsigned-stack signed-stack base-char-stack sap-stack)
-	      (loadw ,n-reg (current-nfp-tn ,vop) (tn-offset ,n-stack))))))))
-;;;
-(defmacro store-stack-tn (reg stack &optional vop)
-  (once-only ((n-reg reg)
-	      (n-stack stack))
-    `(sc-case ,n-stack
-       (control-stack
-	(storew ,n-reg cfp-tn (tn-offset ,n-stack)))
-       ,@(when vop
-	   `(((unsigned-stack signed-stack base-char-stack sap-stack)
-	      (storew ,n-reg (current-nfp-tn ,vop) (tn-offset ,n-stack))))))))
-
-
-;;; MAYBE-LOAD-STACK-TN  --  Interface.
-;;;
-(defmacro maybe-load-stack-tn (reg reg-or-stack)
-  "Move the TN Reg-Or-Stack into Reg if it isn't already there."
-  (once-only ((n-reg reg)
-	      (n-stack reg-or-stack))
-    `(sc-case ,n-reg
-       ((any-reg descriptor-reg non-descriptor-reg word-pointer-reg)
-	(sc-case ,n-stack
-	  ((any-reg descriptor-reg non-descriptor-reg word-pointer-reg)
-	   (move ,n-reg ,n-stack))
-	  ((control-stack)
-	   (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
-
-
-
-;;;; Storage allocation:
-
-;;; WITH-FIXED-ALLOCATION -- Internal Interface.
-;;;
-(defmacro with-fixed-allocation ((result-tn header-tn alloc-tn type-code size)
-				 &body body)
-  "Do stuff to allocate an other-pointer object of fixed Size with a single
-   word header having the specified Type-Code.  The result is placed in
-   Result-TN.  Header-Tn is any register temp which this uses to hold the
-   header of the allocated object before storing it into the header slot.
-   Alloc-tn is a register to hold the heap pointer, and it can be any register
-   since raw heap pointers look like fixnums (dual-word aligned objects).  The
-   body is placed inside PSEUDO-ATOMIC, and presumably initializes the object."
-  `(progn
-     (pseudo-atomic (,header-tn)
-       (load-symbol-value ,alloc-tn *allocation-pointer*)
-       ;; Take free pointer and make descriptor pointer.
-       ;; Just add in three low-tag bits since alloc ptr is dual-word aligned.
-       (inst cal ,result-tn ,alloc-tn other-pointer-type)
-       (inst cal ,alloc-tn ,alloc-tn (pad-data-block ,size))
-       (store-symbol-value ,alloc-tn *allocation-pointer*)
-       (inst li ,header-tn (logior (ash (1- ,size) type-bits) ,type-code))
-       (storew ,header-tn ,result-tn 0 other-pointer-type)
-       ,@body)
-     (load-symbol-value ,header-tn *internal-gc-trigger*)
-     (inst tlt ,header-tn ,alloc-tn)))
-
-
-
-;;;; Type testing noise.
-
-;;; GEN-RANGE-TEST -- Internal.
-;;;
-;;; Generate code that branches to TARGET iff REG contains one of VALUES.  If
-;;; NOT-P is true, invert the test.  Jumping to DROP-THROUGH is the same as
-;;; falling out the bottom.
-;;;
-(defun gen-range-test (reg target drop-through not-p values
-		       &optional (separation 1) (min 0))
-  (let ((tests nil)
-	(start nil)
-	(end nil)
-	(insts nil))
-    ;; Block off list of values into ranges, so we can test these as intervals
-    ;; instead of individually.
-    (flet ((emit-test ()
-		      (if (= start end)
-			  (push start tests)
-			  (push (cons start end) tests))))
-      (dolist (value values)
-	(cond ((< value min)
-	       (error "~S is less than the specified minimum of ~S"
-		      value min))
-	      ((null start)
-	       (setf start value))
-	      ((> value (+ end separation))
-	       (emit-test)
-	       (setf start value)))
-	(setf end value))
-      (emit-test))
-    ;; Output tests, dealing with not-p.
-    (macrolet ((inst (name &rest args)
-		     `(push (list 'inst ',name ,@args) insts)))
-      (do ((remaining (nreverse tests) (cdr remaining)))
-	  ((null remaining))
-	(let ((test (car remaining))
-	      (last (null (cdr remaining))))
-	  (cond
-	   ((atom test)
-	    (inst c reg test)
-	    (if last
-		(if not-p
-		    ;; We compared for the thing.  If not-p, since it is the
-		    ;; last thing to look for, and we don't want it, then goto
-		    ;; target.
-		    (inst bnc :eq target)
-		    ;; If we do want the thing, and we got it, then goto
-		    ;; target.
-		    (inst bc :eq target))
-		;; If it is not the last thing, and it is not not-p, and we
-		;; have it, then go to target.  If not-p, and we have the thing
-		;; we don't want, then drop through.
-		(inst bc :eq (if not-p drop-through target))))
-	   (t
-	    (let ((start (car test))
-		  (end (cdr test)))
-	      ;; We don't need this code if start is the smallest value we
-	      ;; could possibly have.  We know reg can't be less than start.
-	      (unless (= start min)
-		(inst c reg start)
-		;; If I want the range, and I'm less than the start, then
-		;; drop through.  If I don't want the range, goto target
-		;; because I'm not in the range.
-		(inst bc :lt (if not-p target drop-through)))
-	      ;; We know reg is greater than or equal to start, so see if it
-	      ;; is less than or equal to end.
-	      (inst c reg end)
-	      (if last
-		  (if not-p
-		      ;; If this range is the last test, and I don't
-		      ;; want it, and I'm not in it, then goto target.
-		      (inst bc :gt target)
-		      ;; If this range is the last test, and I want the
-		      ;; range, and I'm in it, then goto target.
-		      (inst bnc :gt target))
-		  (inst bnc :gt (if not-p drop-through target)))))))))
-    (nreverse insts)))
-
-(defconstant type-separation 4)
-(defconstant min-type (+ other-immediate-0-type lowtag-limit))
-
-;;; TEST-TYPE-AUX -- Internal.
-;;;
-(defun test-type-aux (reg temp target drop-through not-p lowtags immed hdrs
-			  function-p)
-  (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql)
-		       (member odd-fixnum-type lowtags :test #'eql)))
-	 (lowtags (sort (if fixnump
-			    (delete even-fixnum-type
-				    (remove odd-fixnum-type lowtags
-					    :test #'eql)
-				    :test #'eql)
-			    (copy-list lowtags))
-			#'<))
-	 (lowtag (if function-p
-		     vm:function-pointer-type
-		     vm:other-pointer-type))
-	 (hdrs (sort (copy-list hdrs) #'<))
-	 (immed (sort (copy-list immed) #'<)))
-    (append
-     (when immed
-       `((inst nilz ,temp ,reg type-mask)
-	 ,@(if (or fixnump lowtags hdrs)
-	       ;; If we're going to output any tests below, fall through to
-	       ;; those tests from these.
-	       (let ((fall-through (gensym)))
-		 `((let (,fall-through (gen-label))
-		     ,@(gen-range-test
-			temp (if not-p drop-through target)
-			fall-through nil immed type-separation)
-		     (emit-label ,fall-through))))
-	       ;; If there are no other tests, drop through to the end of all
-	       ;; these tests.
-	       (gen-range-test temp target drop-through not-p
-			       immed type-separation))))
-     (when fixnump
-       `((inst nilz ,temp ,reg 3)
-	 ,(if (or lowtags hdrs)
-	      ;; If more tests follow this one, fall through to them.
-	      `(inst bc :eq ,(if not-p drop-through target))
-	      ;; If no more tests follow, drop totally out of here.
-	      `(inst ,(if not-p 'bnc 'bc) :eq ,target))))
-     (when (or lowtags hdrs)
-       `((inst nilz ,temp ,reg lowtag-mask)))
-     (when lowtags
-       (if hdrs
-	   ;; If we're going to output any tests below, fall through to
-	   ;; those tests from these.
-	   (let ((fall-through (gensym)))
-	     `((let ((,fall-through (gen-label)))
-		 ,@(gen-range-test temp (if not-p drop-through target)
-				   fall-through nil lowtags)
-		 (emit-label ,fall-through))))
-	   (gen-range-test temp target drop-through not-p lowtags)))
-     (when hdrs
-       `((inst c ,temp ,lowtag)
-	 (inst bnc :eq ,(if not-p target drop-through))
-	 (load-type ,temp ,reg ,lowtag)
-	 ,@(gen-range-test temp target drop-through not-p
-			   hdrs type-separation min-type))))))
-
-(defconstant immediate-types
-  (list base-char-type unbound-marker-type))
-
-(defconstant function-subtypes
-  (list funcallable-instance-header-type closure-header-type
-	function-header-type closure-function-header-type))
-
-;;; TEST-TYPE -- Interface.
-;;;
-;;; This is used in type-vops.lisp.
-;;;
-(defmacro test-type (register temp target not-p &rest type-codes)
-  "Register holds a descriptor object that might have one of the types in
-   type-codes.  If it does, goto target; otherwise, fall through.  If not-p is
-   set, goto target when register does not hold one of the types.  Type-codes
-   must be compile-time constants that this evaluates to get numeric codes.
-   Temp is a non-descriptor temporary needed by the code returned by the
-   macro."
-  (let* ((type-codes (mapcar #'eval type-codes))
-	 (lowtags (remove lowtag-limit type-codes :test #'<))
-	 (extended (remove lowtag-limit type-codes :test #'>))
-	 (immediates (intersection extended immediate-types :test #'eql))
-	 (headers (set-difference extended immediate-types :test #'eql))
-	 (function-p nil))
-    (unless type-codes
-      (error "Must supply at least on type for test-type."))
-    (when (and headers (member other-pointer-type lowtags))
-      (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers)
-      (setf headers nil))
-    (when (and immediates
-	       (or (member other-immediate-0-type lowtags)
-		   (member other-immediate-1-type lowtags)))
-      (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
-      (setf immediates nil))
-    (when (intersection headers function-subtypes)
-      (unless (subsetp headers function-subtypes)
-	(error "Can't test for mix of function subtypes and normal ~
-		header types."))
-      (setq function-p t))
-    (let ((n-reg (gensym))
-	  (n-temp (gensym))
-	  (n-target (gensym))
-	  (drop-through (gensym)))
-      `(let ((,n-reg ,register)
-	     (,n-temp ,temp)
-	     (,n-target ,target)
-	     (,drop-through (gen-label)))
-	 (declare (ignorable ,n-temp))
-	 ,@(if (constantp not-p)
-	       (test-type-aux n-reg n-temp n-target drop-through
-			      (eval not-p) lowtags immediates headers
-			      function-p)
-	       `((cond (,not-p
-			,@(test-type-aux n-reg n-temp n-target drop-through t
-					 lowtags immediates headers
-					 function-p))
-		       (t
-			,@(test-type-aux n-reg n-temp n-target drop-through nil
-					 lowtags immediates headers
-					 function-p)))))
-	 (emit-label ,drop-through)))))
-
-
-
-;;;; Error Code
-
-(defvar *adjustable-vectors* nil)
-
-(defmacro with-adjustable-vector ((var) &rest body)
-  `(let ((,var (or (pop *adjustable-vectors*)
-		   (make-array 16
-			       :element-type '(unsigned-byte 8)
-			       :fill-pointer 0
-			       :adjustable t))))
-     (setf (fill-pointer ,var) 0)
-     (unwind-protect
-	 (progn
-	   ,@body)
-       (push ,var *adjustable-vectors*))))
-
-(eval-when (compile load eval)
-  (defun emit-error-break (vop kind code values)
-    (let ((vector (gensym)))
-      `((let ((vop ,vop))
-	  (when vop
-	    (note-this-location vop :internal-error)))
-	(inst break ,kind)
-	(with-adjustable-vector (,vector)
-	  (write-var-integer (error-number-or-lose ',code) ,vector)
-	  ,@(mapcar #'(lambda (tn)
-			`(let ((tn ,tn))
-			   (write-var-integer (make-sc-offset (sc-number
-							       (tn-sc tn))
-							      (tn-offset tn))
-					      ,vector)))
-		    values)
-	  (inst byte (length ,vector))
-	  (dotimes (i (length ,vector))
-	    (inst byte (aref ,vector i))))
-	(align word-shift)))))
-
-(defmacro error-call (vop error-code &rest values)
-  "Cause an error.  ERROR-CODE is the error to cause."
-  (cons 'progn
-	(emit-error-break vop error-trap error-code values)))
-
-
-;;; CERROR-CALL -- Internal Interface.
-;;;
-;;; Output the error break stuff followed by a branch to the continuable code.
-;;; The break handler can skip the error break data, setting the pc in the
-;;; signal context to our following branch, and if we continue, we're setup.
-;;;
-(defmacro cerror-call (vop label error-code &rest values)
-  "Cause a continuable error.  If the error is continued, execution resumes at
-  LABEL."
-  `(progn
-     ,@(emit-error-break vop cerror-trap error-code values)
-     (inst b ,label)))
-
-(defmacro generate-error-code (vop error-code &rest values)
-  "Generate-Error-Code Error-code Value*
-  Emit code for an error with the specified Error-Code and context Values."
-  `(assemble (*elsewhere*)
-     (let ((start-lab (gen-label)))
-       (emit-label start-lab)
-       (error-call ,vop ,error-code ,@values)
-       start-lab)))
-
-(defmacro generate-cerror-code (vop error-code &rest values)
-  "Generate-CError-Code Error-code Value*
-  Emit code for a continuable error with the specified Error-Code and
-  context Values.  If the error is continued, execution resumes after
-  the GENERATE-CERROR-CODE form."
-  (let ((continue (gensym "CONTINUE-LABEL-"))
-	(error (gensym "ERROR-LABEL-")))
-    `(let ((,continue (gen-label)))
-       (emit-label ,continue)
-       (assemble (*elsewhere*)
-	 (let ((,error (gen-label)))
-	   (emit-label ,error)
-	   (cerror-call ,vop ,continue ,error-code ,@values)
-	   ,error)))))
-
-
-
-;;;; PSEUDO-ATOMIC.
-
-;;; PSEUDO-ATOMIC -- Internal Interface.
-;;;
-(defmacro pseudo-atomic ((ndescr-temp) &rest forms)
-  (let ((label (gensym "LABEL-")))
-    `(let ((,label (gen-label)))
-       (inst li ,ndescr-temp 0)
-       (store-symbol-value ,ndescr-temp lisp::*pseudo-atomic-interrupted*)
-       ;; Note: we just use cfp as some not-zero value.
-       (store-symbol-value cfp-tn lisp::*pseudo-atomic-atomic*)
-       ,@forms
-       (inst li ,ndescr-temp 0)
-       (store-symbol-value ,ndescr-temp lisp::*pseudo-atomic-atomic*)
-       (load-symbol-value ,ndescr-temp lisp::*pseudo-atomic-interrupted*)
-       (inst c ,ndescr-temp 0)
-       (inst bc :eq ,label)
-       (inst break pending-interrupt-trap)
-       (emit-label ,label))))
-
-;;;; Float stuff:
-;;;
-;;;    Since moving between memory and a FP register reqires *two* temporaries,
-;;; we need a special temporary to form the magic address we store to do a
-;;; floating point operation.  We get this temp by always spilling NL0 on the
-;;; number stack.  This appears rather grody, but actually the 68881 is so slow
-;;; compared to the ROMP that this overhead is not very great.
-;;;
-;;; Note: The RT interrupt handler preserves 64 bytes beyond the current stack
-;;; pointer, so we don't need to dink the stack pointer.  We can just use the
-;;; space beyond it.
-;;;
-;;; We also use LIP to form the address of the data location that we are
-;;; reading or writing.
-
-(defvar *in-with-fp-temp* nil)
-
-(defmacro with-fp-temp ((var) &body body)
-  `(if *in-with-fp-temp*
-       (error "Can only have one FP temp.")
-       (let ((,var nl0-tn)
-	     (*in-with-fp-temp* t))
-	 (storew ,var nsp-tn -1)
-	 (multiple-value-prog1 (progn ,@body)
-	   (loadw ,var nsp-tn -1)))))
diff --git a/compiler/rt/mc68881.lisp b/compiler/rt/mc68881.lisp
deleted file mode 100644
index 33a33a8fd85a42a538b2167c2a8b2ae3a55c0340..0000000000000000000000000000000000000000
--- a/compiler/rt/mc68881.lisp
+++ /dev/null
@@ -1,564 +0,0 @@
-;;; -*- Package: RT -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/mc68881.lisp,v 1.11 1992/03/09 20:37:46 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; The following code is to support the MC68881 floating point chip on the APC
-;;; card.  Adapted by Rob MacLachlan from the Sparc support, written by Rob
-;;; MacLachlan and William Lott, with some stuff from Dave McDonald's original
-;;; RT miscops.
-;;;
-(in-package "RT")
-
-(eval-when (compile eval load)
-
-;;; The actual positions of the info in the mc68881 FPCR and FPSR.
-;;;
-(defconstant mc68881-fpcr-rounding-mode-byte (byte 2 4))
-(defconstant mc68881-fpcr-rounding-precision-byte (byte 2 6))
-(defconstant mc68881-fpcr-traps-byte (byte 8 8))
-(defconstant mc68881-fpsr-accrued-exceptions-byte (byte 5 3))
-(defconstant mc68881-fpsr-current-exceptions-byte (byte 8 8))
-(defconstant mc68881-fpsr-condition-code-byte (byte 4 24))
-
-;;; Amount to shift by the get the condition code, - 16.
-;;;
-(defconstant mc68881-fpsr-condition-code-shift-16 8)
-
-;;; The condition code bits.
-;;;
-(defconstant mc68881-nan-condition (ash 1 0))
-(defconstant mc68881-infinity-condition (ash 1 1))
-(defconstant mc68881-zero-condition (ash 1 2))
-(defconstant mc68881-negative-condition (ash 1 3))
-
-;;; Masks that map the extended set of exceptions implemented by the 68881 to
-;;; the IEEE exceptions.  This extended format is used for the enabled traps
-;;; and the current exceptions.
-;;;
-(defconstant mc68881-invalid-exception (ash #b111 5))
-(defconstant mc68881-overflow-exception (ash 1 4))
-(defconstant mc68881-underflow-exception (ash 1 3))
-(defconstant mc68881-divide-zero-exception (ash 1 2))
-(defconstant mc68881-inexact-exception (ash #b11 0))
-
-;;; Encoding of float exceptions in the FLOATING-POINT-MODES result.  This is
-;;; also the encoding used in the mc68881 accrued exceptions.
-;;;
-(defconstant float-inexact-trap-bit (ash 1 0))
-(defconstant float-divide-by-zero-trap-bit (ash 1 1))
-(defconstant float-underflow-trap-bit (ash 1 2))
-(defconstant float-overflow-trap-bit (ash 1 3))
-(defconstant float-invalid-trap-bit (ash 1 4))
-
-(defconstant float-round-to-nearest 0)
-(defconstant float-round-to-zero 1)
-(defconstant float-round-to-negative 2)
-(defconstant float-round-to-positive 3)
-
-;;; Positions of bits in the FLOATING-POINT-MODES result.
-;;;
-(defconstant float-rounding-mode (byte 2 0))
-(defconstant float-sticky-bits (byte 5 2))
-(defconstant float-traps-byte (byte 5 7))
-(defconstant float-exceptions-byte (byte 5 12))
-(defconstant float-fast-bit 0)
-
-); eval-when
-
-;;; When compared to the 68881 documentation, the RT only uses the low 16 bits
-;;; of the instruction.  Memory access is controlled in an RT specific way.
-;;; See the AFPA coprocessor hardware assist operation (page B34 in volume 1.)
-
-
-;;;; Move functions:
-;;;
-;;; See With-FP-Temp comment...
-
-(define-move-function (load-single 7) (vop x y)
-  ((single-stack) (mc68881-single-reg))
-  (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
-  (with-fp-temp (temp)
-    (inst mc68881-load y lip-tn :single temp)))
-
-(define-move-function (store-single 8) (vop x y)
-  ((mc68881-single-reg) (single-stack))
-  (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
-  (with-fp-temp (temp)
-    (inst mc68881-store x lip-tn :single temp)))
-
-(define-move-function (load-double 7) (vop x y)
-  ((double-stack) (mc68881-double-reg))
-  (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
-  (with-fp-temp (temp)
-    (inst mc68881-load y lip-tn :double temp)))
-
-(define-move-function (store-double 8) (vop x y)
-  ((mc68881-double-reg) (double-stack))
-  (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
-  (with-fp-temp (temp)
-    (inst mc68881-store x lip-tn :double temp)))
-
-
-;;;; Move VOPs:
-
-(define-vop (mc68881-move)
-  (:args (x :scs (mc68881-single-reg mc68881-double-reg)
-	    :target y
-	    :load-if (not (location= x y))))
-  (:results (y :scs (mc68881-single-reg mc68881-double-reg)
-	       :load-if (not (location= x y))))
-  (:temporary (:sc sap-reg) temp)
-  (:generator 0
-    (unless (location= y x)
-      (inst mc68881-move y x temp))))
-
-(define-move-vop mc68881-move :move
-  (mc68881-single-reg) (mc68881-single-reg)
-  (mc68881-double-reg) (mc68881-double-reg))
-
-
-(define-vop (move-to-mc68881)
-  (:args (x :scs (descriptor-reg)))
-  (:results (y :scs (mc68881-single-reg mc68881-double-reg)))
-  (:temporary (:sc sap-reg) temp)
-  (:variant-vars format data)
-  (:generator 7
-    (inst cal lip-tn x (- (* data vm:word-bytes) vm:other-pointer-type))
-    (inst mc68881-load y lip-tn format temp)))
-
-(macrolet ((frob (name format data sc)
-	     `(progn
-		(define-vop (,name move-to-mc68881)
-		  (:variant ,format ,data))
-		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
-  (frob move-to-mc68881-single :single vm:single-float-value-slot
-    mc68881-single-reg)
-  (frob move-to-mc68881-double :double vm:double-float-value-slot
-    mc68881-double-reg))
-
-
-(define-vop (move-from-mc68881)
-  (:args (x :scs (mc68881-single-reg mc68881-double-reg) :to :save))
-  (:results (y :scs (descriptor-reg)))
-  (:temporary (:scs (sap-reg)) ndescr)
-  (:temporary (:scs (word-pointer-reg)) alloc)
-  (:variant-vars format size type data)
-  (:generator 20
-    (with-fixed-allocation (y ndescr alloc type size)
-      (inst cal lip-tn y (- (* data vm:word-bytes) vm:other-pointer-type))
-      (inst mc68881-store x lip-tn format ndescr))))
-
-(macrolet ((frob (name sc &rest args)
-	     `(progn
-		(define-vop (,name move-from-mc68881)
-		  (:variant ,@args))
-		(define-move-vop ,name :move (,sc) (descriptor-reg)))))
-  (frob move-from-mc68881-single mc68881-single-reg
-    :single vm:single-float-size vm:single-float-type
-    vm:single-float-value-slot)
-  (frob move-from-mc68881-double mc68881-double-reg
-    :double vm:double-float-size vm:double-float-type
-    vm:double-float-value-slot))
-
-(define-vop (move-to-mc68881-argument)
-  (:args (x :scs (mc68881-single-reg mc68881-double-reg) :target y)
-	 (nfp :scs (word-pointer-reg)
-	      :load-if (not (sc-is y mc68881-single-reg mc68881-double-reg))))
-  (:results (y))
-  (:temporary (:sc sap-reg) temp)
-  (:variant-vars format)
-  (:vop-var vop)
-  (:generator 7
-    (sc-case y
-      ((mc68881-single-reg mc68881-double-reg)
-       (unless (location= y x)
-	 (inst mc68881-move y x temp)))
-      ((single-stack double-stack)
-       (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
-       (inst mc68881-store y lip-tn format temp)))))
-
-(macrolet ((frob (name format sc)
-	     `(progn
-		(define-vop (,name move-to-mc68881-argument)
-		  (:variant ,format))
-		(define-move-vop ,name :move-argument
-		  (,sc descriptor-reg) (,sc)))))
-  (frob move-mc68881-single-float-argument :single mc68881-single-reg)
-  (frob move-mc68881-double-float-argument :double mc68881-double-reg))
-
-(define-move-vop move-argument :move-argument
-  (mc68881-single-reg mc68881-double-reg) (descriptor-reg))
-
-
-;;;; Arithmetic VOPs:
-
-(define-vop (mc68881-op)
-  (:args (x) (y))
-  (:results (r))
-  (:temporary (:sc sap-reg) temp)
-  (:policy :fast-safe)
-  (:note "inline float arithmetic")
-  (:vop-var vop)
-  (:save-p :compute-only))
-
-(macrolet ((frob (name sc ptype)
-	     `(define-vop (,name mc68881-op)
-		(:args (x :scs (,sc) :target r)
-		       (y :scs (,sc)))
-		(:results (r :scs (,sc) :from (:argument 0)))
-		(:arg-types ,ptype ,ptype)
-		(:result-types ,ptype)
-		(:variant-vars op)
-		(:generator 20
-		  (unless (location= x r)
-		    (inst mc68881-move r x temp))
-		  (note-this-location vop :internal-error)
-		  (inst mc68881-binop r y op temp)))))
-  (frob mc68881-single-float-op mc68881-single-reg mc68881-single-float)
-  (frob mc68881-double-float-op mc68881-double-reg mc68881-double-float))
-
-(macrolet ((frob (op sinst sname dinst dname)
-	     `(progn
-		(define-vop (,sname mc68881-single-float-op)
-		  (:translate ,op)
-		  (:variant ,sinst))
-		(define-vop (,dname mc68881-double-float-op)
-		  (:translate ,op)
-		  (:variant ,dinst)))))
-  (frob + :add +/single-float :add +/double-float)
-  (frob - :sub -/single-float :sub -/double-float)
-  (frob * :sglmul */single-float :mul */double-float)
-  (frob / :sgldiv //single-float :div //double-float))
-
-(define-vop (mc68881-unop mc68881-op)
-  (:args (x)))
-
-(macrolet ((frob (name sc ptype)
-	     `(define-vop (,name mc68881-unop)
-		(:args (x :scs (,sc)))
-		(:results (r :scs (,sc)))
-		(:arg-types ,ptype)
-		(:result-types ,ptype)
-		(:variant-vars op)
-		(:generator 20
-		  (inst mc68881-unop r x op temp)))))
-  (frob mc68881-single-float-unop mc68881-single-reg mc68881-single-float)
-  (frob mc68881-double-float-unop mc68881-double-reg mc68881-double-float))
-
-
-(macrolet ((frob (op sinst sname dinst dname)
-	     `(progn
-		(define-vop (,sname mc68881-single-float-unop)
-		  (:translate ,op)
-		  (:variant ,sinst))
-		(define-vop (,dname mc68881-double-float-unop)
-		  (:translate ,op)
-		  (:variant ,dinst)))))
-  (frob abs :abs abs/single-float :abs abs/double-float)
-  (frob %negate :neg %negate/single-float :neg %negate/double-float))
-
-
-;;;; Comparison:
-
-(define-vop (mc68881-compare)
-  (:args (x) (y))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:temporary (:sc sap-reg) temp)
-  (:temporary (:sc descriptor-reg) loc)
-  (:temporary (:sc unsigned-stack) loc-tn)
-  (:variant-vars condition)
-  (:note "inline float comparison")
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 20
-    (let ((drop-thru (gen-label)))
-      (note-this-location vop :internal-error)
-      (if (eq condition '<)
-	  (inst mc68881-compare y x :cmp temp)
-	  (inst mc68881-compare x y :cmp temp))
-      (let ((nfp (current-nfp-tn vop)))
-	(inst cal loc nfp (* (tn-offset loc-tn) word-bytes)))
-      (inst mc68881-store-status :fpsr loc temp)
-      (loadw temp loc)
-      (ecase condition
-	((< >)
-	 (inst niuz temp temp
-	       (ash (logior mc68881-zero-condition
-			    mc68881-negative-condition
-			    mc68881-nan-condition)
-		    mc68881-fpsr-condition-code-shift-16)))
-	(eql
-	 (inst niuz temp temp
-	       (ash mc68881-zero-condition
-		    mc68881-fpsr-condition-code-shift-16))
-	 (setq not-p (not not-p))))
-      
-      (if not-p
-	  (inst bnc :eq target)
-	  (inst bc :eq target))
-      (emit-label drop-thru))))
-
-(macrolet ((frob (name sc ptype)
-	     `(define-vop (,name mc68881-compare)
-		(:args (x :scs (,sc))
-		       (y :scs (,sc)))
-		(:arg-types ,ptype ,ptype))))
-  (frob mc68881-single-float-compare mc68881-single-reg mc68881-single-float)
-  (frob mc68881-double-float-compare mc68881-double-reg mc68881-double-float))
-
-(macrolet ((frob (translate sname dname)
-	     `(progn
-		(define-vop (,sname mc68881-single-float-compare)
-		  (:translate ,translate)
-		  (:variant ',translate))
-		(define-vop (,dname mc68881-double-float-compare)
-		  (:translate ,translate)
-		  (:variant ',translate)))))
-  (frob < mc68881-</single-float mc68881-</double-float)
-  (frob > mc68881->/single-float mc68881->/double-float)
-  (frob eql mc68881-eql/single-float mc68881-eql/double-float))
-
-
-;;;; Conversion:
-
-(macrolet ((frob (name translate to-sc to-type)
-	     `(define-vop (,name)
-		(:args (x :scs (signed-reg) :target temp
-			  :load-if (not (sc-is x signed-stack))))
-		(:temporary (:scs (single-stack)) temp)
-		(:temporary (:sc word-pointer-reg) addr)
-		(:temporary (:sc sap-reg) scratch)
-		(:results (y :scs (,to-sc)))
-		(:arg-types signed-num)
-		(:result-types ,to-type)
-		(:policy :fast-safe)
-		(:note "inline float coercion")
-		(:translate ,translate)
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 20
-		  (let ((stack-tn
-			 (sc-case x
-			   (signed-reg
-			    (storew x
-				    (current-nfp-tn vop)
-				    (* (tn-offset temp) vm:word-bytes))
-			    temp)
-			   (signed-stack
-			    x))))
-		    (inst cal addr (current-nfp-tn vop) 
-			 (* (tn-offset stack-tn) vm:word-bytes))
-		    (note-this-location vop :internal-error)
-		    (inst mc68881-load y addr :integer scratch))))))
-  (frob mc68881-%single-float/signed %single-float
-    mc68881-single-reg mc68881-single-float)
-  (frob mc68881-%double-float/signed %double-float
-    mc68881-double-reg mc68881-double-float))
-
-;;; Everything is represented as extended precision, so these operations don't
-;;; really do anything.  (Or, rather, whatever semantics there is, is
-;;; automatically handled by the load functions.)
-;;;
-(macrolet ((frob (name translate from-sc from-type to-sc to-type)
-	     `(define-vop (,name mc68881-move)
-		(:args (x :scs (,from-sc) :target y))
-		(:results (y :scs (,to-sc)))
-		(:arg-types ,from-type)
-		(:result-types ,to-type)
-		(:policy :fast-safe)
-		(:note "inline float coercion")
-		(:translate ,translate))))
-  (frob mc68881-%single-float/double-float %single-float
-    mc68881-double-reg mc68881-double-float
-    mc68881-single-reg mc68881-single-float)
-  (frob mc68881-%double-float/single-float %double-float
-    mc68881-single-reg mc68881-single-float
-    mc68881-double-reg mc68881-double-float))
-
-(macrolet ((frob (trans from-sc from-type inst)
-	     `(define-vop (,(symbolicate trans "/" from-type))
-		(:args (x :scs (,from-sc) :target temp))
-		(:temporary (:from (:argument 0) :sc mc68881-single-reg) temp)
-		(:temporary (:sc sap-reg) scratch)
-		(:temporary (:scs (signed-stack)) stack-temp)
-		(:temporary (:sc word-pointer-reg) addr)
-		(:results (y :scs (signed-reg)
-			     :load-if (not (sc-is y signed-stack))))
-		(:arg-types ,from-type)
-		(:result-types signed-num)
-		(:translate ,trans)
-		(:policy :fast-safe)
-		(:note "inline float truncate")
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 5
-		  (note-this-location vop :internal-error)
-		  (inst mc68881-unop temp x ,inst scratch)
-		  (sc-case y
-		    (signed-stack
-		     (inst cal addr (current-nfp-tn vop)
-			  (* (tn-offset y) vm:word-bytes))
-		     (inst mc68881-store temp addr :integer scratch))
-		    (signed-reg
-		     (inst cal addr (current-nfp-tn vop)
-			  (* (tn-offset stack-temp) vm:word-bytes))
-		     (inst mc68881-store temp addr :integer scratch)
-		     (loadw y (current-nfp-tn vop)
-			    (tn-offset stack-temp))))))))
-  (frob %unary-truncate mc68881-single-reg mc68881-single-float :intrz)
-  (frob %unary-truncate mc68881-double-reg mc68881-double-float :intrz)
-  (frob %unary-round mc68881-single-reg mc68881-single-float :int)
-  (frob %unary-round mc68881-double-reg mc68881-double-float :int))
-
-
-(define-vop (make-mc68881-single-float)
-  (:args (bits :scs (signed-reg) :target res
-	       :load-if (not (sc-is bits signed-stack))))
-  (:results (res :scs (mc68881-single-reg)
-		 :load-if (not (sc-is res single-stack))))
-  (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
-  (:temporary (:scs (signed-stack)) stack-temp)
-  (:temporary (:sc sap-reg) scratch)
-  (:temporary (:sc word-pointer-reg) addr)
-  (:arg-types signed-num)
-  (:result-types mc68881-single-float)
-  (:translate make-single-float)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:generator 20
-    (sc-case bits
-      (signed-reg
-       (sc-case res
-	 (mc68881-single-reg
-	  (storew bits (current-nfp-tn vop) (tn-offset stack-temp))
-	  (inst cal addr (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes))
-	  (inst mc68881-load res addr :single scratch))
-	 (single-stack
-	  (storew bits (current-nfp-tn vop) (tn-offset res)))))
-      (signed-stack
-       (sc-case res
-	 (mc68881-single-reg
-	  (inst cal addr (current-nfp-tn vop)
-		(* (tn-offset bits) vm:word-bytes))
-	  (inst mc68881-load res addr :single scratch))
-	 (single-stack
-	  (unless (location= bits res)
-	    (loadw temp (current-nfp-tn vop) (tn-offset bits))
-	    (storew temp (current-nfp-tn vop) (tn-offset res)))))))))
-
-(define-vop (make-mc68881-double-float)
-  (:args (hi-bits :scs (signed-reg))
-	 (lo-bits :scs (unsigned-reg)))
-  (:arg-types signed-num unsigned-num)
-  (:results (res :scs (mc68881-double-reg)
-		 :load-if (not (sc-is res double-stack))))
-  (:result-types mc68881-double-float)
-  (:temporary (:scs (double-stack)) temp)
-  (:temporary (:sc sap-reg :from (:eval 0)) scratch)
-  (:temporary (:sc word-pointer-reg :from (:eval 0)) addr)
-  (:translate make-double-float)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:generator 25
-    (let ((stack-tn (sc-case res
-		      (double-stack res)
-		      (mc68881-double-reg temp))))
-      (storew hi-bits (current-nfp-tn vop) (tn-offset stack-tn))
-      (storew lo-bits (current-nfp-tn vop) (1+ (tn-offset stack-tn))))
-    (when (sc-is res mc68881-double-reg)
-      (inst cal addr (current-nfp-tn vop) (* (tn-offset temp) vm:word-bytes))
-      (inst mc68881-load res addr :double scratch))))
-
-(define-vop (mc68881-single-float-bits)
-  (:args (float :scs (mc68881-single-reg)))
-  (:results (bits :scs (signed-reg)))
-  (:temporary (:scs (signed-stack)) stack-temp)
-  (:temporary (:sc sap-reg) scratch)
-  (:temporary (:sc word-pointer-reg) addr)
-  (:arg-types mc68881-single-float)
-  (:result-types signed-num)
-  (:translate single-float-bits)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:generator 20
-    (inst cal addr (current-nfp-tn vop)
-	  (* (tn-offset stack-temp) vm:word-bytes))
-    (inst mc68881-store float addr :single scratch)
-    (loadw bits (current-nfp-tn vop) (tn-offset stack-temp))))
-
-(define-vop (mc68881-double-float-high-bits)
-  (:args (float :scs (mc68881-double-reg)))
-  (:results (bits :scs (signed-reg)))
-  (:temporary (:scs (double-stack)) stack-temp)
-  (:temporary (:sc sap-reg) scratch)
-  (:temporary (:sc word-pointer-reg) addr)
-  (:arg-types mc68881-double-float)
-  (:result-types signed-num)
-  (:translate double-float-high-bits)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:variant-vars offset)
-  (:variant 0)
-  (:generator 20
-    (inst cal addr (current-nfp-tn vop)
-	  (* (tn-offset stack-temp) vm:word-bytes))
-    (inst mc68881-store float addr :double scratch)
-    (loadw bits (current-nfp-tn vop) (+ (tn-offset stack-temp) offset))))
-
-(define-vop (mc68881-double-float-low-bits mc68881-double-float-high-bits)
-  (:results (bits :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:variant 1)
-  (:translate double-float-low-bits))
-
-
-;;;; Float mode hackery:
-
-(deftype float-modes () '(unsigned-byte 32))
-(defknown floating-point-modes () float-modes (flushable))
-(defknown ((setf floating-point-modes)) (float-modes)
-  float-modes)
-
-(define-vop (floating-point-modes)
-  (:results (res :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:translate floating-point-modes)
-  (:policy :fast-safe)
-  #+nil (:vop-var vop)
-  #+nil (:temporary (:sc unsigned-stack) temp)
-  (:generator 3
-    #+nil
-    (let ((nfp (current-nfp-tn vop)))
-      (inst stfsr nfp (* word-bytes (tn-offset temp)))
-      (loadw res nfp (tn-offset temp))
-      (inst nop))
-    (inst li res 0)))
-
-(define-vop (set-floating-point-modes)
-  (:args (new :scs (unsigned-reg) :target res))
-  (:results (res :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:result-types unsigned-num)
-  (:translate (setf floating-point-modes))
-  (:policy :fast-safe)
-  #+nil (:temporary (:sc unsigned-stack) temp)
-  #+nil (:vop-var vop)
-  (:generator 3
-    #+nil
-    (let ((nfp (current-nfp-tn vop)))
-      (storew new nfp (tn-offset temp))
-      (inst ldfsr nfp (* word-bytes (tn-offset temp)))
-      (move res new))
-    (move res new)))
diff --git a/compiler/rt/memory.lisp b/compiler/rt/memory.lisp
deleted file mode 100644
index 209840624f20d73d2441661b879e41e9ad256f36..0000000000000000000000000000000000000000
--- a/compiler/rt/memory.lisp
+++ /dev/null
@@ -1,182 +0,0 @@
-;;; -*- Package: RT; 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/rt/memory.lisp,v 1.1 1991/02/18 15:07:59 chiles Exp $
-;;;
-;;; This file contains the IBM RT definitions of some general purpose memory
-;;; reference VOPs inherited by basic memory reference operations.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-;;; CELL-REF -- VOP.
-;;; CELL-SET -- VOP.
-;;; CELL-SETF -- VOP.
-;;; CELL-SETF-FUNCTION -- VOP.
-;;;
-;;; 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.  CELL-SETF-FUNCTION
-;;; takes its arguments as if it were a setf function (new value first, as
-;;; apposed to a setf macro, which takes the new value last).
-;;;
-(define-vop (cell-ref)
-  (:args (object :scs (descriptor-reg)))
-  (:results (value :scs (word-pointer-reg 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 (word-pointer-reg 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 (word-pointer-reg 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-vop (cell-setf-function)
-  (:args (value :scs (word-pointer-reg descriptor-reg any-reg)
-		:target result)
-	 (object :scs (descriptor-reg)))
-  (: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 -- VOP.
-;;; SLOT-SET -- VOP.
-;;;
-;;; 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:
-
-(eval-when (compile eval)
-
-;;; 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.
-;;;
-(defmacro define-indexer (name write-p op shift &key gross-hack)
-  `(define-vop (,name)
-     (:args (object :scs (descriptor-reg) :to :eval)
-	    (index :scs (any-reg immediate)
-		   ,@(unless (zerop shift) '(:target temp)))
-	    ,@(when write-p
-		'((value :scs (any-reg descriptor-reg) :target result))))
-     (:arg-types * tagged-num ,@(when write-p '(*)))
-     (:temporary (:scs (interior-reg) :type interior) lip)
-     ,@(unless (zerop shift)
-	 `((:temporary (:scs (non-descriptor-reg)
-			     :type random :from (:argument 1))
-		       temp)))
-     (:results (,(if write-p 'result 'value)
-		:scs (any-reg descriptor-reg)))
-     (:result-types *)
-     (:variant-vars offset lowtag)
-     (:policy :fast-safe)
-     (:generator 5
-       (sc-case index
-	 ((immediate)
-	  (inst ,op value object
-		(- (+ (if (and (sc-is index immediate) (zerop (tn-value index)))
-			  0
-			  (ash (tn-value index) (- word-shift ,shift)))
-		      (ash offset word-shift))
-		   lowtag))
-	  ,@(if write-p
-		'((move result value))))
-	 (t
-	  ,@(if (zerop shift)
-		;; Object must be the last arg to CAS here since it is cannot
-		;; be in R0.
-		`((inst cas lip index object))
-		`((move temp index)
-		  (inst sr temp ,shift)
-		  (inst cas lip temp object)))
-	  (inst ,op value lip (- (ash offset word-shift) lowtag))
-	  ,@(if write-p
-		'((move result value)))))
-       ;; The RT lacks a signed-byte load instruction, so we have to sign
-       ;; extend this case explicitly.  This is gross but obvious and easy.
-       ,@(when gross-hack
-	   '((inst sl value 24)
-	     (inst sar value 24))))))
-
-) ;EVAL-WHEN
-
-(define-indexer word-index-ref nil l 0)
-(define-indexer word-index-set t st 0)
-(define-indexer halfword-index-ref nil lh 1)
-(define-indexer signed-halfword-index-ref nil lha 1)
-(define-indexer halfword-index-set t sth 1)
-(define-indexer byte-index-ref nil lc 2)
-(define-indexer signed-byte-index-ref nil lc 2 :gross-hack t)
-(define-indexer byte-index-set t stc 2)
diff --git a/compiler/rt/move.lisp b/compiler/rt/move.lisp
deleted file mode 100644
index 64525035b8faebaa98fc824287ad96799ba85184..0000000000000000000000000000000000000000
--- a/compiler/rt/move.lisp
+++ /dev/null
@@ -1,356 +0,0 @@
-;;; -*- Package: RT; 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/rt/move.lisp,v 1.5 1991/11/09 02:37:19 wlott Exp $
-;;;
-;;; This file contains the IBM RT VM definition of operand loading/saving and the
-;;; Move VOP.
-;;;
-;;; Written by Rob MacLachlan.
-;;; MIPS conversion by William Lott.
-;;; IBM RT conversion by William Lott and Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-(define-move-function (load-immediate 1) (vop x y)
-  ((null immediate)
-   (any-reg word-pointer-reg descriptor-reg))
-  (let ((val (tn-value x)))
-    (etypecase val
-      (integer
-       (inst li y (fixnum val)))
-      (null
-       (move y null-tn))
-      (symbol
-       (load-symbol y val))
-      (character
-       (inst li y (logior (ash (char-code val) type-bits)
-			  base-char-type))))))
-
-(define-move-function (load-number 1) (vop x y)
-  ((immediate)
-   (signed-reg unsigned-reg))
-  (inst li y (tn-value x)))
-
-(define-move-function (load-base-char 1) (vop x y)
-  ((immediate) (base-char-reg))
-  (inst li y (char-code (tn-value x))))
-
-(define-move-function (load-system-area-pointer 1) (vop x y)
-  ((immediate) (sap-reg))
-  (inst li y (sap-int (tn-value x))))
-
-(define-move-function (load-constant 5) (vop x y)
-  ((constant) (descriptor-reg))
-  (loadw y code-tn (tn-offset x) other-pointer-type))
-
-(define-move-function (load-stack 5) (vop x y)
-  ((control-stack) (any-reg word-pointer-reg descriptor-reg))
-  (load-stack-tn y x))
-
-(define-move-function (load-number-stack 5) (vop x y)
-  ((base-char-stack) (base-char-reg)
-   (sap-stack) (sap-reg)
-   (signed-stack) (signed-reg)
-   (unsigned-stack) (unsigned-reg))
-  (load-stack-tn y x vop))
-
-(define-move-function (store-stack 5) (vop x y)
-  ((any-reg word-pointer-reg descriptor-reg) (control-stack))
-  (store-stack-tn x y))
-
-(define-move-function (store-number-stack 5) (vop x y)
-  ((base-char-reg) (base-char-stack)
-   (sap-reg) (sap-stack)
-   (signed-reg) (signed-stack)
-   (unsigned-reg) (unsigned-stack))
-  (store-stack-tn x y vop))
-
-(define-move-function (word-pointer-copy 1) (vop x y)
-  ((word-pointer-reg) (any-reg)
-   (any-reg) (word-pointer-reg))
-  (move y x))
-
-
-
-;;;; The Move VOP:
-
-(define-vop (move)
-  (:args (x :target y
-	    :scs (any-reg word-pointer-reg descriptor-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (any-reg word-pointer-reg descriptor-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:generator 0
-    (move y x)))
-
-(define-move-vop move :move
-  (any-reg word-pointer-reg descriptor-reg)
-  (any-reg word-pointer-reg descriptor-reg))
-
-;;; 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)
-
-;;; MOVE-ARGUMENT -- VOP.
-;;;
-;;; This is used for moving descriptor values into another frame for argument
-;;; or known value passing.
-;;;
-(define-vop (move-argument)
-  (:args (x :target y
-	    :scs (any-reg word-pointer-reg descriptor-reg))
-	 (fp :scs (word-pointer-reg)
-	     :load-if (not (sc-is y any-reg descriptor-reg))))
-  (:results (y))
-  (:generator 0
-    (sc-case y
-      ((any-reg word-pointer-reg descriptor-reg)
-       (move y x))
-      (control-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-argument :move-argument
-  (any-reg word-pointer-reg descriptor-reg)
-  (any-reg word-pointer-reg descriptor-reg))
-
-
-
-;;;; ILLEGAL-MOVE
-
-;;; ILLEGAL-MOVE -- VOP.
-;;;
-;;; 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)
-  (:args (x) (type))
-  (:results (y))
-  (:ignore y)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 666
-    (error-call vop object-not-type-error x type)))
-
-
-
-;;;; Moves and coercions:
-
-;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
-;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
-;;; to a tagged bignum or fixnum.
-
-;;; MOVE-TO-WORD/FIXNUM -- VOP.
-;;;
-;;; Arg is a fixnum, so just put it in a non-descriptor register and shift it.
-;;;
-(define-vop (move-to-word/fixnum)
-  (:args (x :scs (any-reg descriptor-reg) :target y))
-  (:results (y :scs (signed-reg unsigned-reg)))
-  (:arg-types tagged-num)
-  (:note "fixnum untagging")
-  (:generator 2
-    (move y x)
-    (inst sar y 2)))
-;;;
-(define-move-vop move-to-word/fixnum :move
-  (any-reg descriptor-reg) (signed-reg unsigned-reg))
-
-;;; MOVE-TO-WORD-C -- VOP.
-;;; 
-;;; Arg is a non-immediate constant, load it.
-;;;
-(define-vop (move-to-word-c)
-  (:args (x :scs (constant)))
-  (:results (y :scs (signed-reg unsigned-reg)))
-  (:note "constant load")
-  (:generator 1
-    (inst li y (tn-value x))))
-;;;
-(define-move-vop move-to-word-c :move
-  (constant) (signed-reg unsigned-reg))
-
-;;; MOVE-TO-WORD/INTEGER -- VOP.
-;;;
-;;; Arg is a fixnum or bignum, figure out which and load if necessary.
-;;;
-(define-vop (move-to-word/integer)
-  (:args (x :scs (descriptor-reg) :to :save))
-  (:results (y :scs (signed-reg unsigned-reg)))
-  (:note "integer to untagged word coercion")
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 8
-    (let ((done (gen-label)))
-      (inst nilz temp x 3)
-      (move y x)
-      (inst bcx :eq done)
-      (inst sar y 2)
-      ;; If it's a bignum, throw away what we computed in y.
-      (loadw y x bignum-digits-offset other-pointer-type)
-      (emit-label done))))
-;;;
-(define-move-vop move-to-word/integer :move
-  (descriptor-reg) (signed-reg unsigned-reg))
-
-
-;;; MOVE-FROM-WORD/FIXNUM -- VOP.
-;;;
-;;; Since the result is know to be a fixnum, we can shift in the tag bits
-;;; without fear of needing a bignum.
-;;;
-(define-vop (move-from-word/fixnum)
-  (:args (x :scs (signed-reg unsigned-reg) :target temp))
-  (:temporary (:scs (non-descriptor-reg)
-		    :from (:argument 0) :to (:result 0) :target y)
-	      temp)
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:result-types tagged-num)
-  (:note "fixnum tagging")
-  (:generator 3
-    (move temp x)
-    (inst sl temp 2)
-    (move y temp)))
-;;;
-(define-move-vop move-from-word/fixnum :move
-  (signed-reg unsigned-reg) (any-reg descriptor-reg))
-
-;;; MOVE-FROM-SIGNED -- VOP.
-;;;
-;;; Result may be a bignum, so we have to check whether shifting to make room
-;;; for tag bits results in a fixnum.  Use a worst-case cost to make sure
-;;; people know they may be number consing.
-;;;
-(define-vop (move-from-signed)
-  (:args (arg :scs (signed-reg unsigned-reg) :target x))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
-  (:temporary (:scs (word-pointer-reg)) alloc)
-  (:note "signed word to integer coercion")
-  (:generator 25
-    (move x arg)
-    (let ((fixnum (gen-label))
-	  (done (gen-label)))
-      (move temp x)
-      (inst sar temp 29)
-      (inst bcx :eq fixnum)
-      (inst not temp)
-      (inst bc :eq fixnum)
-      
-      (with-fixed-allocation (y temp alloc bignum-type 2)
-	(storew x y bignum-digits-offset other-pointer-type))
-      (inst b done)
-      
-      (emit-label fixnum)
-      (move y x)
-      (inst sl y 2)
-      (emit-label done))))
-;;;
-(define-move-vop move-from-signed :move
-  (signed-reg) (descriptor-reg))
-
-
-;;; MOVE-FROM-UNSIGNED -- VOP.
-;;;
-;;; Check for fixnum, and possibly allocate one or two word bignum result.  Use
-;;; a worst-case cost to make sure people know they may be number consing.
-;;;
-(define-vop (move-from-unsigned)
-  (:args (arg :scs (signed-reg unsigned-reg) :target x))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
-  (:temporary (:scs (word-pointer-reg)) alloc)
-  (:note "unsigned word to integer coercion")
-  (:generator 21
-    (move x arg)
-    (let ((done (gen-label))
-	  (bignum (gen-label))
-	  (one-word (gen-label)))
-      (move temp x)
-      (inst sar temp 29)
-      (inst bnc :eq bignum)
-      (inst sl x 2)
-      (move y x)
-      (emit-label done)
-
-      (assemble (*elsewhere*)
-	(emit-label bignum)
-	(pseudo-atomic (temp)
-	  (load-symbol-value alloc *allocation-pointer*)
-	  (inst cal y alloc other-pointer-type)
-	  (inst cal alloc alloc (pad-data-block (1+ bignum-digits-offset)))
-	  (inst c x 0)
-	  (inst bncx :lt one-word)
-	  (inst li temp (logior (ash 1 type-bits) bignum-type))
-	  (inst cal alloc alloc
-		(- (pad-data-block (+ 2 bignum-digits-offset))
-		   (pad-data-block (1+ bignum-digits-offset))))
-	  (inst li temp (logior (ash 2 type-bits) bignum-type))
-	  (emit-label one-word)
-	  (store-symbol-value alloc *allocation-pointer*)
-	  (storew temp y 0 other-pointer-type)
-	  (storew x y bignum-digits-offset other-pointer-type))
-	(load-symbol-value temp *internal-gc-trigger*)
-	(inst tlt temp alloc)
-	(inst b done)))))
-;;;
-(define-move-vop move-from-unsigned :move
-  (unsigned-reg) (descriptor-reg))
-
-
-;;; Move untagged numbers.
-;;;
-(define-vop (word-move)
-  (:args (x :target y
-	    :scs (signed-reg unsigned-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (signed-reg unsigned-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:note "word integer move")
-  (:generator 0
-    (move y x)))
-;;;
-(define-move-vop word-move :move
-  (signed-reg unsigned-reg) (signed-reg unsigned-reg))
-
-
-;;; Move untagged number arguments/return-values.
-;;;
-(define-vop (move-word-argument)
-  (:args (x :target y
-	    :scs (signed-reg unsigned-reg))
-	 (fp :scs (word-pointer-reg)
-	     :load-if (not (sc-is y sap-reg))))
-  (:results (y))
-  (:note "word integer argument move")
-  (:generator 0
-    (sc-case y
-      ((signed-reg unsigned-reg)
-       (move y x))
-      ((signed-stack unsigned-stack)
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-word-argument :move-argument
-  (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a
-;;; descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (signed-reg unsigned-reg) (any-reg descriptor-reg))
diff --git a/compiler/rt/nlx.lisp b/compiler/rt/nlx.lisp
deleted file mode 100644
index 713ed7fbab88ea43bd751230035f0b61dce159ad..0000000000000000000000000000000000000000
--- a/compiler/rt/nlx.lisp
+++ /dev/null
@@ -1,302 +0,0 @@
-;;; -*- Package: RT -*-
-;;;
-;;; **********************************************************************
-;;; 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/rt/nlx.lisp,v 1.4 1992/01/01 15:07:09 ram Exp $
-;;;
-;;; This file contains the definitions of VOPs used for non-local exit (throw,
-;;; lexical exit, etc.)
-;;;
-;;; Written by Rob MacLachlan
-;;; Converted to IBM RT by William Lott and Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-;;; MAKE-NLX-SP-TN  --  Interface.
-;;;
-;;; Make an environment-live stack TN for saving the SP for NLX entry.
-;;;
-(def-vm-support-routine make-nlx-sp-tn (env)
-  (environment-live-tn
-   (make-representation-tn *word-pointer-type*
-			   (sc-number-or-lose 'word-pointer-reg *backend*))
-   env))
-
-
-
-;;; 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.
-;;;
-(def-vm-support-routine make-dynamic-state-tns ()
-  (make-n-tns 4 *fixnum-primitive-type*))
-
-(define-vop (save-dynamic-state)
-  (:results (catch :scs (any-reg))
-	    (nfp :scs (any-reg))
-	    (nsp :scs (any-reg))
-	    (eval :scs (any-reg)))
-  (:vop-var vop)
-  (:generator 13
-    (load-symbol-value catch lisp::*current-catch-block*)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (if cur-nfp
-	  (move nfp cur-nfp)
-	  (inst li nfp 0)))
-    (move nsp nsp-tn)
-    (load-symbol-value eval lisp::*eval-stack-top*)))
-
-(define-vop (restore-dynamic-state)
-  (:args (catch :scs (any-reg))
-	 (nfp :scs (any-reg))
-	 (nsp :scs (any-reg))
-	 (eval :scs (any-reg)))
-  (:temporary (:scs (descriptor-reg) :from (:eval 0)) symbol value)
-  (:temporary (:scs (word-pointer-reg) :from (:eval 0)) bsp)
-  (:vop-var vop)
-  (:generator 10
-    (store-symbol-value catch lisp::*current-catch-block*)
-    (store-symbol-value eval lisp::*eval-stack-top*)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(move cur-nfp nfp)))
-    (move nsp-tn nsp)))
-
-(define-vop (current-stack-pointer)
-  (:results (res :scs (any-reg word-pointer-reg descriptor-reg)))
-  (:generator 1
-    (move res csp-tn)))
-
-(define-vop (current-binding-pointer)
-  (:results (res :scs (any-reg word-pointer-reg descriptor-reg)))
-  (:generator 1
-    (load-symbol-value res *binding-stack-pointer*)))
-
-
-
-;;;; Unwind block hackery:
-
-;;; MAKE-UNWIND-BLOCK -- VOP.
-;;;
-;;; Compute the address of the catch block from its TN, then store into the
-;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
-;;;
-(define-vop (make-unwind-block)
-  (:args (tn))
-  (:info entry-label)
-  (:results (block :scs (word-pointer-reg)))
-  (:temporary (:scs (word-pointer-reg) :target block) block-ptr)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:generator 22
-    (inst cal block-ptr cfp-tn (* (tn-offset tn) vm:word-bytes))
-    (load-symbol-value temp lisp::*current-unwind-protect-block*)
-    (storew temp block-ptr vm:unwind-block-current-uwp-slot)
-    (storew cfp-tn block-ptr vm:unwind-block-current-cont-slot)
-    (storew code-tn block-ptr vm:unwind-block-current-code-slot)
-    (inst compute-lra-from-code temp code-tn entry-label)
-    (storew temp block-ptr vm:catch-block-entry-pc-slot)
-    (move block block-ptr)))
-
-
-;;; MAKE-CATCH-BLOCK -- VOP.
-;;;
-;;; 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 (descriptor-reg)))
-  (:info entry-label)
-  (:results (block :scs (word-pointer-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (word-pointer-reg) :target block :to (:result 0)) result)
-  (:generator 44
-    (inst cal result cfp-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 cfp-tn result vm:catch-block-current-cont-slot)
-    (storew code-tn result vm:catch-block-current-code-slot)
-    (inst compute-lra-from-code temp code-tn entry-label)
-    (storew temp result vm:catch-block-entry-pc-slot)
-
-    (storew tag result vm:catch-block-tag-slot)
-    (load-symbol-value temp lisp::*current-catch-block*)
-    (storew temp result vm:catch-block-previous-catch-slot)
-    (store-symbol-value result lisp::*current-catch-block*)
-
-    (move block result)))
-
-
-;;; SET-UNWIND-PROTECT -- VOP.
-;;;
-;;; 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 cal new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes))
-    (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
-
-;;; UNLINK-CATCH-BLOCK -- VOP.
-;;;
-;;; Remove the catch block from the chain of catches.  This happens when
-;;; we drop out of a catch instead of throwing.
-;;; 
-(define-vop (unlink-catch-block)
-  (:temporary (:scs (word-pointer-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*)))
-
-;;; UNLINK-UNWIND-PROTECT -- VOP.
-;;;
-;;; Same thing with unwind protects.
-;;; 
-(define-vop (unlink-unwind-protect)
-  (:temporary (:scs (word-pointer-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:
-
-
-;;; NLX-ENTRY -- VOP.
-;;;
-;;; We were just thrown to, so load up the results.
-;;; 
-(define-vop (nlx-entry)
-  (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
-	      ; would be inserted before the LRA.
-	 (start)
-	 (count))
-  (:results (values :more t))
-  (:temporary (:scs (descriptor-reg)) move-temp)
-  (:info label nvals)
-  (:save-p :force-to-stack)
-  (:generator 30
-    (emit-return-pc label)
-    (cond ((zerop nvals))
-	  ((= nvals 1)
-	   (let ((no-values (gen-label)))
-	     (inst c count 0)
-	     (inst bcx :eq no-values)
-	     (move (tn-ref-tn values) null-tn)
-	     (loadw (tn-ref-tn values) start)
-	     (emit-label no-values)))
-	  (t
-	   (collect ((defaults))
-	     (inst c count 0)
-	     (do ((i 0 (1+ i))
-		  (tn-ref values (tn-ref-across tn-ref)))
-		 ((null tn-ref))
-	       (let ((default-lab (gen-label))
-		     (tn (tn-ref-tn tn-ref)))
-		 (defaults (cons default-lab tn))
-		 
-		 (inst bc :eq default-lab)
-		 (inst s count (fixnum 1))
-		 (sc-case tn
-		   ((descriptor-reg any-reg)
-		    (loadw tn start i))
-		   (control-stack
-		    (loadw move-temp start i)
-		    (store-stack-tn move-temp tn)))))
-	     
-	     (let ((defaulting-done (gen-label)))
-	       (emit-label defaulting-done)
-	       (assemble (*elsewhere*)
-		 (dolist (def (defaults))
-		   (emit-label (car def))
-		   (let ((tn (cdr def)))
-		     (sc-case tn
-		       ((descriptor-reg any-reg)
-			(move tn null-tn))
-		       (control-stack
-			(store-stack-tn null-tn tn)))))
-		 (inst b defaulting-done))))))
-    (load-stack-tn csp-tn sp)))
-
-
-(define-vop (nlx-entry-multiple)
-  ;; Again, no SC restrictions for the args, 'cause the loading would
-  ;; happen before the entry label.  But we know that start and count will
-  ;; be in registers due to the way this vop is used.
-  (:args (top :target dst)
-	 (start :target src)
-	 (count :target num))
-  (:info label)
-  (:temporary (:scs (any-reg) :from (:argument 0)) dst)
-  (:temporary (:scs (any-reg) :from (:argument 1)) src)
-  (:temporary (:scs (any-reg) :from (:argument 2)) num)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:results (new-start) (new-count))
-  (:save-p :force-to-stack)
-  (:generator 30
-    (emit-return-pc label)
-    (let ((loop (gen-label))
-	  (done (gen-label)))
-
-      ;; Copy args.
-      (load-stack-tn dst top)
-      (move src start)
-      (inst a num count 0)
-
-      ;; Establish results.
-      (sc-case new-start
-	((any-reg word-pointer-reg) (move new-start dst))
-	(control-stack (store-stack-tn dst new-start)))
-      (inst bcx :eq done)
-      (sc-case new-count
-	(any-reg (inst move new-count num))
-	(control-stack (store-stack-tn num new-count)))
-
-      ;; Copy stuff on stack.
-      (emit-label loop)
-      (loadw temp src)
-      (inst inc src vm:word-bytes)
-      (storew temp dst)
-      (inst s num num (fixnum 1))
-      (inst bncx :eq loop)
-      (inst inc dst vm:word-bytes)
-
-      (emit-label done)
-      (move csp-tn dst))))
-
-
-;;; This VOP is just to force the TNs used in the cleanup onto the stack.
-;;;
-(define-vop (uwp-entry)
-  (:info label)
-  (:save-p :force-to-stack)
-  (:results (block) (start) (count))
-  (:ignore block start count)
-  (:generator 0
-    (emit-return-pc label)))
diff --git a/compiler/rt/params.lisp b/compiler/rt/params.lisp
deleted file mode 100644
index 913461e9092d849088c1390049826f04495e20bf..0000000000000000000000000000000000000000
--- a/compiler/rt/params.lisp
+++ /dev/null
@@ -1,220 +0,0 @@
-;;; -*- Package: RT; 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/rt/params.lisp,v 1.13 1992/06/09 23:46:32 wlott Exp $
-;;;
-;;; This file contains some parameterizations of various VM attributes for the
-;;; IBM RT.  This file is separate from other stuff, so we can compile and
-;;; load it earlier.
-;;;
-;;; Written by Rob MacLachlan
-;;; Converted to MIPS by William Lott.
-;;; Converted to IBM RT by William Lott and Bill Chiles.
-;;;
-
-(in-package "RT")
-(use-package "C")
-
-(export '(word-bits byte-bits word-shift word-bytes float-sign-shift
-
-	  single-float-bias single-float-exponent-byte
-	  single-float-significand-byte single-float-normal-exponent-min
-	  single-float-normal-exponent-max single-float-hidden-bit
-	  single-float-trapping-nan-bit single-float-digits
-
-	  double-float-bias double-float-exponent-byte
-	  double-float-significand-byte double-float-normal-exponent-min
-	  double-float-normal-exponent-max double-float-hidden-bit
-	  double-float-trapping-nan-bit double-float-digits
-
-	  float-underflow-trap-bit float-overflow-trap-bit
-	  float-imprecise-trap-bit float-invalid-trap-bit
-	  float-divide-by-zero-trap-bit
-
-))
-
-
-
-;;;; Compiler constants.
-
-(eval-when (compile eval load)
-
-#-afpa (progn
-(setf *target-float-hardware* :mc68881)
-(setf (backend-name *target-backend*) "RT")
-(setf (backend-version *target-backend*) "IBM RT/Mach 1.0")
-(setf (backend-fasl-file-type *target-backend*) "rtf")
-(setf (backend-fasl-file-implementation *target-backend*)
-      rt-fasl-file-implementation)
-(setf *features* (delete :afpa *features*)))
-
-#+afpa (progn
-(setf *target-float-hardware* :afpa)
-(setf (backend-name *target-backend*) "RT")
-(setf (backend-version *target-backend*) "IBM RT EAPC/Mach 1.0")
-(setf (backend-fasl-file-type *target-backend*) "eapcf")
-(setf (backend-fasl-file-implementation *target-backend*)
-      rt-afpa-fasl-file-implementation)
-(pushnew :afpa *features*))
-
-(setf (backend-fasl-file-version *target-backend*) 1)
-(setf (backend-register-save-penalty *target-backend*) 3)
-(setf (backend-byte-order *target-backend*) :big-endian)
-(setf (backend-page-size *target-backend*) 4096)
-
-) ;eval-when
-
-
-
-;;;; Machine Architecture parameters:
-
-(eval-when (compile load eval)
-
-(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.")
-
-(defparameter target-most-positive-fixnum (1- (ash 1 29))
-  "most-positive-fixnum in the target architecture.")
-
-(defparameter target-most-negative-fixnum (ash -1 29)
-  "most-negative-fixnum in the target architecture.")
-
-(defconstant float-sign-shift 31)
-
-;;; The exponent min/max values are wrong, I think.  The denorm, infinity, etc.
-;;; info must go in there somewhere.
-
-(defconstant single-float-bias 126)
-(defconstant single-float-exponent-byte (byte 8 23))
-(defconstant single-float-significand-byte (byte 23 0))
-(defconstant single-float-normal-exponent-min 1)
-(defconstant single-float-normal-exponent-max 254)
-(defconstant single-float-hidden-bit (ash 1 23))
-(defconstant single-float-trapping-nan-bit (ash 1 22))
-
-(defconstant double-float-bias 1022)
-(defconstant double-float-exponent-byte (byte 11 20))
-(defconstant double-float-significand-byte (byte 20 0))
-(defconstant double-float-normal-exponent-min 1)
-(defconstant double-float-normal-exponent-max #x7FE)
-(defconstant double-float-hidden-bit (ash 1 20))
-(defconstant double-float-trapping-nan-bit (ash 1 19))
-
-(defconstant single-float-digits
-  (+ (byte-size single-float-significand-byte) 1))
-
-(defconstant double-float-digits
-  (+ (byte-size double-float-significand-byte) word-bits 1))
-
-); eval-when
-
-
-
-
-;;;; Description of the target address space.
-
-(export '(target-read-only-space-start
-	  target-static-space-start
-	  target-dynamic-space-start))
-
-;;; Where to put the different spaces.
-;;; 
-(defparameter target-read-only-space-start #x00100000)
-(defparameter target-static-space-start    #x05000000)
-(defparameter target-dynamic-space-start   #x07000000)
-
-
-
-;;;; Other non-type constants.
-
-(export '(halt-trap pending-interrupt-trap error-trap cerror-trap
-	  breakpoint-trap function-end-breakpoint-trap))
-
-(defenum (:suffix -trap :start 8)
-  halt
-  pending-interrupt
-  error
-  cerror
-  breakpoint
-  function-end-breakpoint)
-
-
-
-;;;; Static symbols.
-
-(export '(static-symbols exported-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.
-;;;
-;;; The exported static symbols are a subset of the static symbols that get
-;;; exported to the C header file.  NOTE: EXPORTED-STATIC-SYMBOLS IS DEFINED
-;;; AS A FUNCTION OF THE ORDERING OF THIS LIST.
-;;;
-(defparameter static-symbols
-  '(t
-
-    ;; Random stuff needed for initialization.
-    lisp::lisp-environment-list
-    lisp::lisp-command-line-list
-
-    ;; Functions that C needs to call.
-    lisp::%initial-function
-    lisp::maybe-gc
-    kernel::internal-error
-    di::handle-breakpoint
-
-    ;; Free Pointers and the like
-    lisp::*read-only-space-free-pointer*
-    lisp::*static-space-free-pointer*
-    lisp::*initial-dynamic-space-free-pointer*
-    *allocation-pointer*
-    *internal-gc-trigger*
-    *binding-stack-pointer*
-
-    ;; Things needed for non-local-exit.
-    lisp::*current-catch-block*
-    lisp::*current-unwind-protect-block*
-    *eval-stack-top*
-
-    ;; Interrupt Handling
-    lisp::*pseudo-atomic-atomic*
-    lisp::*pseudo-atomic-interrupted*
-    unix::*interrupts-enabled*
-    unix::*interrupt-pending*
-    lisp::*free-interrupt-context-index*
-
-    ;; Static functions.
-    two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-=
-    %negate two-arg-and two-arg-ior two-arg-xor
-    length two-arg-gcd two-arg-lcm truncate
-    ))
-
-(defparameter exported-static-symbols
-  (subseq static-symbols 0 (1+ (position 'lisp::*free-interrupt-context-index*
-					 static-symbols))))
-
-
-
-;;;; Assembler parameters:
-
-;;; The number of bits per element in the assemblers code vector.
-;;;
-(defparameter *assembly-unit-length* 8)
diff --git a/compiler/rt/pred.lisp b/compiler/rt/pred.lisp
deleted file mode 100644
index 9c8973595c705225f04d1c2d2b648f0c216aef1e..0000000000000000000000000000000000000000
--- a/compiler/rt/pred.lisp
+++ /dev/null
@@ -1,53 +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/rt/pred.lisp,v 1.1 1991/02/18 15:08:07 chiles Exp $
-;;;
-;;; This file contains the VM definition of predicate VOPs for the IBM RT.
-;;;
-;;; Written by Rob MacLachlan
-;;; Modified by William Lott and Bill Chiles for the IBM RT.
-;;;
-
-(in-package "RT")
-
-
-
-;;;; The Branch VOP.
-
-;;; The unconditional branch, emitted when we can't drop through to the desired
-;;; destination.  Dest is the label where we want to be.
-;;;
-(define-vop (branch)
-  (:info dest)
-  (:generator 5
-    (inst b dest)))
-
-
-
-;;;; Conditional VOPs:
-
-(define-vop (if-eq)
-  (:args (x :scs (any-reg descriptor-reg null))
-	 (y :scs (any-reg descriptor-reg null)))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:translate eq)
-  (:generator 3
-    (let ((x-prime (sc-case x
-		     ((any-reg descriptor-reg) x)
-		     (null null-tn)))
-	  (y-prime (sc-case y
-		     ((any-reg descriptor-reg) y)
-		     (null null-tn))))
-      (inst c x-prime y-prime)
-      (if not-p
-	  (inst bnc :eq target)
-	  (inst bc :eq target)))))
diff --git a/compiler/rt/print.lisp b/compiler/rt/print.lisp
deleted file mode 100644
index eb3625aee3c63c55047e52591c369558fcde5073..0000000000000000000000000000000000000000
--- a/compiler/rt/print.lisp
+++ /dev/null
@@ -1,47 +0,0 @@
-;;; -*- Package: RT -*-
-;;;
-;;; **********************************************************************
-;;; 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/rt/print.lisp,v 1.2 1991/10/02 23:05:52 ram Exp $
-;;;
-;;; This file contains temporary printing utilities and similar noise.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "RT")
-
-
-(define-vop (print)
-  (:args (object :scs (descriptor-reg)))
-  (:results (result :scs (descriptor-reg)))
-  (:save-p t)
-  (:temporary (:sc any-reg :offset nl0-offset) nl0)
-  (:temporary (:sc any-reg :offset lra-offset) lra)
-  (:temporary (:scs (sap-reg)) temp)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:vop-var vop)
-  (:generator 0
-    (let ((lra-label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn cur-nfp nfp-save))
-      (inst cal nsp-tn nsp-tn -16)
-      (storew object nsp-tn)
-      (inst compute-lra-from-code lra code-tn lra-label)
-      (inst cai nl0 (make-fixup "_debug_print" :foreign))
-      (inst cai temp (make-fixup "call_into_c" :foreign))
-      (inst b temp)
-
-      (align vm:lowtag-bits)
-      (emit-label lra-label)
-      (inst lra-header-word)
-      (inst cal nsp-tn nsp-tn 16)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save))
-      (move result nl0))))
diff --git a/compiler/rt/sap.lisp b/compiler/rt/sap.lisp
deleted file mode 100644
index 787feaa426f7478e382021ca2ed2e9349020edfc..0000000000000000000000000000000000000000
--- a/compiler/rt/sap.lisp
+++ /dev/null
@@ -1,413 +0,0 @@
-;;; -*- Package: RT; 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/rt/sap.lisp,v 1.15 1992/03/11 20:47:38 wlott Exp $
-;;;
-;;; This file contains the IBM RT VM definition of SAP operations.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "RT")
-
-
-
-;;;; Moves and coercions:
-
-;;; MOVE-TO-SAP -- VOP.
-;;;
-;;; Move a tagged SAP to an untagged representation.
-;;;
-(define-vop (move-to-sap)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (y :scs (sap-reg)))
-  (:generator 1
-    (loadw y x vm:sap-pointer-slot vm:other-pointer-type)))
-;;;
-(define-move-vop move-to-sap :move
-  (descriptor-reg) (sap-reg))
-
-
-;;; MOVE-FROM-SAP -- VOP.
-;;;
-;;; Move an untagged SAP to a tagged representation.
-;;;
-(define-vop (move-from-sap)
-  (:args (sap :scs (sap-reg) :to :save))
-  (:temporary (:sc any-reg) header)
-  (:temporary (:sc word-pointer-reg) alloc)
-  (:results (y :scs (descriptor-reg)))
-  (:generator 1
-    (with-fixed-allocation (y header alloc sap-type sap-size)
-      (storew sap y sap-pointer-slot other-pointer-type))))
-;;;
-(define-move-vop move-from-sap :move
-  (sap-reg) (descriptor-reg))
-
-
-;;; SAP-MOVE -- VOP.
-;;;
-;;; Move untagged sap values.
-;;;
-(define-vop (sap-move)
-  (:args (x :target y
-	    :scs (sap-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (sap-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:generator 0
-    (move y x)))
-;;;
-(define-move-vop sap-move :move
-  (sap-reg) (sap-reg))
-
-
-;;; MOVE-SAP-ARGUMENT -- VOP.
-;;;
-;;; Move untagged sap arguments/return-values.
-;;;
-(define-vop (move-sap-argument)
-  (:args (x :target y
-	    :scs (sap-reg))
-	 (fp :scs (word-pointer-reg)
-	     :load-if (not (sc-is y sap-reg))))
-  (:results (y))
-  (:generator 0
-    (sc-case y
-      (sap-reg
-       (move y x))
-      (sap-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-sap-argument :move-argument
-  (descriptor-reg sap-reg) (sap-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
-;;; descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (sap-reg) (descriptor-reg))
-
-
-
-;;;; SAP-INT and INT-SAP
-
-(define-vop (sap-int)
-  (:args (sap :scs (sap-reg) :target int))
-  (:arg-types system-area-pointer)
-  (:results (int :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:translate sap-int)
-  (:policy :fast-safe) 
- (:generator 1
-    (move int sap)))
-
-(define-vop (int-sap)
-  (:args (int :scs (unsigned-reg) :target sap))
-  (:arg-types unsigned-num)
-  (:results (sap :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate int-sap)
-  (:policy :fast-safe)
-  (:generator 1
-    (move sap int)))
-
-
-
-;;;; POINTER+ and POINTER-
-
-(define-vop (pointer+)
-  (:translate sap+)
-  (:args (ptr :scs (sap-reg) :target res)
-	 (offset :scs (signed-reg) :to :save))
-  (:arg-types system-area-pointer signed-num)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:policy :fast-safe)
-  (:generator 2
-    ;; Can't use CAS since offset and ptr may be register 0, so we have to move.
-    (move res ptr)
-    (inst a res offset)))
-;;;
-(define-vop (pointer+-c pointer+)
-  (:args (ptr :scs (sap-reg)))
-  (:info offset)
-  (:arg-types system-area-pointer (:constant (signed-byte 16)))
-  (:generator 1
-    (inst a res ptr offset)))
-
-(define-vop (pointer-)
-  (:translate sap-)
-  (:args (ptr1 :scs (sap-reg) :target res)
-	 (ptr2 :scs (sap-reg) :to :save))
-  (:arg-types system-area-pointer system-area-pointer)
-  (:policy :fast-safe)
-  (:results (res :scs (signed-reg)))
-  (:result-types signed-num)
-  (:generator 1
-    (move res ptr1)
-    (inst s res ptr2)))
-
-
-
-;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
-
-(eval-when (compile eval)
-
-;;; DEFINE-SYSTEM-REF -- Internal Interface.
-;;;
-;;; Name is the name of a computed system-ref offset, from which we generate a
-;;; <name>-c VOP for immediate constant offsets.  Shift is the multiples of two
-;;; for which we must adjust the offset to make it an index in terms of bytes
-;;; (the machines address units).  Translate and signed-translate are the Lisp
-;;; function calls for which these VOP's are in-line expansions.
-;;;
-(defmacro define-system-ref (name size translate result-sc result-type
-				  &optional
-				  signed-translate signed-result-sc
-				  signed-result-type)
-  (let ((access-form 
-	 (ecase size
-	   (:byte
-	    '((inst lc result base offset)
-	      (when signed
-		(inst sl result 24)
-		(inst sar result 24))))
-	   (:halfword
-	    '((if signed
-		  (inst lha result base offset)
-		  (inst lh result base offset))))
-	   (:word
-	    '(signed ; suppress silly warnings.
-	      (inst l result base offset)))))
-	(name-c (symbolicate name "-C")))
-    `(progn
-       (define-vop (,name-c)
-	 (:policy :fast-safe)
-	 (:translate ,translate)
-	 (:args (base :scs (sap-reg)))
-	 (:results (result :scs (,result-sc)))
-	 (:result-types ,result-type)
-	 (:arg-types system-area-pointer (:constant (unsigned-byte 15)))
-	 (:info offset)
-	 (:variant-vars signed)
-	 (:variant nil)
-	 (:generator 5
-	   ,@access-form))
-       
-       (define-vop (,name)
-	 (:policy :fast-safe)
-	 (:translate ,translate)
-	 (:args (object :scs (sap-reg))
-		(offset :scs (unsigned-reg) :target base))
-	 (:results (result :scs (,result-sc)))
-	 (:arg-types system-area-pointer positive-fixnum)
-	 (:result-types ,result-type)
-	 (:temporary (:scs (sap-reg) :from (:argument 1) :to :eval) base)
-	 (:variant-vars signed)
-	 (:variant nil)
-	 (:generator 7
-	   (inst cas base offset object)
-	   (let ((offset 0))
-	     ,@access-form)))
-       
-       ,@(when signed-translate
-	   `((define-vop (,(symbolicate "SIGNED-" name-c) ,name-c)
-	       (:translate ,signed-translate)
-	       (:results (result :scs (,signed-result-sc)))
-	       (:result-types ,signed-result-type)
-	       (:variant t))
-	     
-	     (define-vop (,(symbolicate "SIGNED-" name) ,name)
-	       (:translate ,signed-translate)
-	       (:results (result :scs (,signed-result-sc)))
-	       (:result-types ,signed-result-type)
-	       (:variant t)))))))
-
-) ;eval-when
-
-(define-system-ref 8bit-system-ref :byte
-  sap-ref-8 unsigned-reg positive-fixnum
-  signed-sap-ref-8 signed-reg tagged-num)
-
-(define-system-ref 16bit-system-ref :halfword
-  sap-ref-16 unsigned-reg positive-fixnum
-  signed-sap-ref-16 signed-reg tagged-num)
-
-(define-system-ref 32bit-system-ref :word
-  sap-ref-32 unsigned-reg unsigned-num
-  signed-sap-ref-32 signed-reg signed-num)
-
-(define-system-ref sap-system-ref :word
-  sap-ref-sap sap-reg system-area-pointer)
-
-
-(eval-when (compile eval)
-
-;;; DEFINE-SYSTEM-SET -- Internal.
-;;;
-;;; Name is the name of a computed system-ref offset, from which we generate a
-;;; <name>-c VOP for immediate constant offsets.  Shift is the multiples of two
-;;; for which we must adjust the offset to make it an index in terms of bytes
-;;; (the machines address units).  Translate and signed-translate are the Lisp
-;;; function calls for which these VOP's are in-line expansions.
-;;;
-(defmacro define-system-set (name size translate data-sc data-type)
-  (let ((set-form 
-	 (ecase size
-	   (:byte '(inst stc data base offset))
-	   (:halfword '(inst sth data base offset))
-	   (:word '(inst st data base offset))))
-	(name-c (symbolicate name "-C")))
-    `(progn
-       (define-vop (,name-c)
-	 (:policy :fast-safe)
-	 (:translate ,translate)
-	 (:args (base :scs (sap-reg))
-		(data :scs (,data-sc) :target result :to (:result 0)))
-	 (:arg-types system-area-pointer
-		     (:constant (unsigned-byte 15))
-		     ,data-type)
-	 (:results (result :scs (,data-sc)))
-	 (:result-types ,data-type)
-	 (:info offset)
-	 (:generator 5
-	   ,set-form
-	   (move result data)))
-       
-       (define-vop (,name)
-	 (:policy :fast-safe)
-	 (:translate ,translate)
-	 (:args (object :scs (sap-reg))
-		(offset :scs (unsigned-reg))
-		(data :scs (,data-sc) :target result))
-	 (:arg-types system-area-pointer positive-fixnum ,data-type)
-	 (:temporary (:scs (sap-reg) :from (:argument 1)) base)
-	 (:results (result :scs (,data-sc)))
-	 (:result-types ,data-type)
-	 (:generator 7
-	   (inst cas base offset object)
-	   (let ((offset 0))
-	     ,set-form)
-	   (move result data))))))
-
-) ;EVAL-WHEN
-
-(define-system-set 8bit-system-set :byte %set-sap-ref-8
-  unsigned-reg positive-fixnum)
-
-(define-system-set 16bit-system-set :halfword %set-sap-ref-16
-  unsigned-reg positive-fixnum)
-
-(define-system-set 32bit-system-set :word %set-sap-ref-32
-  unsigned-reg unsigned-num)
-
-(define-system-set signed-8bit-system-set :byte %set-signed-sap-ref-8
-  signed-reg tagged-num)
-
-(define-system-set signed-16bit-system-set :halfword %set-signed-sap-ref-16
-  signed-reg tagged-num)
-
-(define-system-set signed-32bit-system-set :word %set-signed-sap-ref-32
-  signed-reg signed-num)
-
-
-(define-system-set sap-system-set :word %set-sap-ref-sap
-  sap-reg system-area-pointer)
-
-#| 
-
-Maybe we can get away with using define-system-set now that offsets don't 
-need to be shifted.
-
-;;; Ugly, because there are only 2 free sap-regs.  We stash the data value in
-;;; NARGS to free up a sap-reg for BASE.
-;;;
-(define-vop (sap-system-set)
-  (:policy :fast-safe)
-  (:translate %set-sap-ref-sap)
-  (:args (object :scs (sap-reg))
-	 (offset :scs (unsigned-reg) :target base)
-	 (data :scs (sap-reg sap-stack)))
-  (:arg-types system-area-pointer positive-fixnum system-area-pointer)
-  (:temporary (:scs (sap-reg) :from (:eval 0) :to (:eval 1)) base)
-  (:temporary (:scs (non-descriptor-reg) :offset nargs-offset
-	       :from (:eval 0) :to (:eval 1))
-	      save)
-  (:vop-var vop)
-  (:results (result :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 7
-    (sc-case data
-      (sap-reg (move save data))
-      (sap-stack
-       (loadw save (current-nfp-tn vop) (* (tn-offset data) vm:word-bytes))))
-       
-    (inst cas base offset object)
-    (inst st save base)
-    (move result save)))
-
-(define-vop (sap-system-set-c)
-  (:policy :fast-safe)
-  (:translate %set-sap-ref-sap)
-  (:args (object :scs (sap-reg))
-	 (data :scs (sap-reg) :target result))
-  (:info offset)
-  (:arg-types system-area-pointer
-	      (:constant (unsigned-byte 16))
-	      system-area-pointer)
-  (:results (result :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 4
-    (inst st data object offset)
-    (move result data)))
-
-|#
-
-;;; fake the presence of sap-ref-single and sap-ref-double.
-
-(def-source-transform sap-ref-single (sap offset)
-  `(make-single-float (signed-sap-ref-32 ,sap ,offset)))
-
-(def-source-transform %set-sap-ref-single (sap offset value)
-  (once-only ((sap sap) (offset offset) (value value))
-    `(progn
-       (setf (signed-sap-ref-32 ,sap ,offset)
-	     (single-float-bits ,value))
-       ,value)))
-
-(def-source-transform sap-ref-double (sap offset)
-  (once-only ((sap sap) (offset offset))
-    `(make-double-float (signed-sap-ref-32 ,sap ,offset)
-			(sap-ref-32 ,sap (+ ,offset word-bytes)))))
-
-(def-source-transform %set-sap-ref-double (sap offset value)
-  (once-only ((sap sap) (offset offset) (value value))
-    `(progn
-       (setf (signed-sap-ref-32 ,sap ,offset)
-	     (double-float-high-bits ,value))
-       (setf (sap-ref-32 ,sap (+ ,offset word-bytes))
-	     (double-float-low-bits ,value))
-       ,value)))
-
-
-;;;; Noise to convert normal lisp data objects into SAPs.
-
-(define-vop (vector-sap)
-  (:translate vector-sap)
-  (:policy :fast-safe)
-  (:args (vector :scs (descriptor-reg)))
-  (:results (sap :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 2
-    (inst cal sap vector
-	  (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type))))
diff --git a/compiler/rt/static-fn.lisp b/compiler/rt/static-fn.lisp
deleted file mode 100644
index 60045803a1baf0922acf226cc0df2f3ae962978b..0000000000000000000000000000000000000000
--- a/compiler/rt/static-fn.lisp
+++ /dev/null
@@ -1,146 +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/rt/static-fn.lisp,v 1.1 1991/02/18 15:08:13 chiles Exp $
-;;;
-;;; This file contains the VOPs and macro magic necessary to call static
-;;; functions.
-;;;
-;;; Written by William Lott.
-;;; Converted by Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-(define-vop (static-function-template)
-  (:save-p t)
-  (:policy :safe)
-  (:variant-vars symbol)
-  (:vop-var vop)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg)) move-temp)
-  (:temporary (:sc descriptor-reg :offset lra-offset) lra)
-  (:temporary (:sc descriptor-reg :offset cname-offset) cname)
-  (:temporary (:scs (interior-reg) :type interior) lip)
-  (:temporary (:sc any-reg :offset nargs-offset) nargs)
-  (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
-
-
-(eval-when (compile load eval)
-
-(defun static-function-template-name (num-args num-results)
-  (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
-		  num-args num-results)))
-
-(defun moves (dst src)
-  (collect ((moves))
-    (do ((dst dst (cdr dst))
-	 (src src (cdr src)))
-	((or (null dst) (null src)))
-      (moves `(move ,(car dst) ,(car src))))
-    (moves)))
-
-(defun static-function-template-vop (num-args num-results)
-  (assert (and (<= num-args register-arg-count)
-	       (<= num-results register-arg-count))
-	  (num-args num-results)
-	  "Either too many args (~D) or too many results (~D).  Max = ~D"
-	  num-args num-results register-arg-count)
-  (let ((num-temps (max num-args num-results)))
-    (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
-      (dotimes (i num-results)
-	(let ((result-name (intern (format nil "RESULT-~D" i))))
-	  (result-names result-name)
-	  (results `(,result-name :scs (any-reg descriptor-reg)))))
-      (dotimes (i num-temps)
-	(let ((temp-name (intern (format nil "TEMP-~D" i))))
-	  (temp-names temp-name)
-	  (temps `(:temporary (:sc descriptor-reg
-			       :offset ,(nth i register-arg-offsets)
-			       ,@(when (< i num-args)
-				   `(:from (:argument ,i)))
-			       ,@(when (< i num-results)
-				   `(:to (:result ,i)
-				     :target ,(nth i (result-names)))))
-			      ,temp-name))))
-      (dotimes (i num-args)
-	(let ((arg-name (intern (format nil "ARG-~D" i))))
-	  (arg-names arg-name)
-	  (args `(,arg-name
-		  :scs (any-reg descriptor-reg)
-		  :target ,(nth i (temp-names))))))
-      `(define-vop (,(static-function-template-name num-args num-results)
-		    static-function-template)
-	 (:args ,@(args))
-	 ,@(temps)
-	 (:results ,@(results))
-	 (:generator ,(+ 50 num-args num-results)
-	   (let ((lra-label (gen-label))
-		 (cur-nfp (current-nfp-tn vop)))
-	     ,@(moves (temp-names) (arg-names))
-	     (inst li nargs (fixnum ,num-args))
-	     (load-symbol cname symbol)
-	     (loadw lip cname vm:symbol-raw-function-addr-slot
-		    vm:other-pointer-type)
-	     (when cur-nfp
-	       (store-stack-tn cur-nfp nfp-save))
-	     (move old-fp cfp-tn)
-	     (inst compute-lra-from-code lra code-tn lra-label)
-	     (inst bx lip)
-	     (inst move cfp-tn csp-tn)
-	     (emit-return-pc lra-label)
-	     (note-this-location vop :unknown-return)
-	     ,(collect ((bindings) (links))
-		(do ((temp (temp-names) (cdr temp))
-		     (name 'values (gensym))
-		     (prev nil name)
-		     (i 0 (1+ i)))
-		    ((= i num-results))
-		  (bindings `(,name
-			      (make-tn-ref ,(car temp) nil)))
-		  (when prev
-		    (links `(setf (tn-ref-across ,prev) ,name))))
-		`(let ,(bindings)
-		   ,@(links)
-		   (default-unknown-values
-		       ,(if (zerop num-results) nil 'values)
-		       ,num-results move-temp lra-label)))
-	     (when cur-nfp
-	       (load-stack-tn cur-nfp nfp-save))
-	     ,@(moves (result-names) (temp-names))))))))
-
-) ;EVAL-WHEN (compile load eval)
-
-
-(macrolet ((frob (nargs nres)
-	     (static-function-template-vop nargs nres)))
-  (frob 0 1)
-  (frob 1 1)
-  (frob 2 1))
-  
-(defmacro define-static-function (name args &key (results '(x)) translate
-				       policy cost arg-types result-types)
-  `(define-vop (,name
-		,(static-function-template-name (length args)
-						(length results)))
-     (:variant ',name)
-     (:note ,(format nil "static-function ~@(~S~)" name))
-     ,@(when translate
-	 `((:translate ,translate)))
-     ,@(when policy
-	 `((:policy ,policy)))
-     ,@(when cost
-	 `((:generator-cost ,cost)))
-     ,@(when arg-types
-	 `((:arg-types ,@arg-types)))
-     ,@(when result-types
-	 `((:result-types ,@result-types)))))
diff --git a/compiler/rt/subprim.lisp b/compiler/rt/subprim.lisp
deleted file mode 100644
index 2c9eb7942bd8c0e02813747d899d33ce695775b0..0000000000000000000000000000000000000000
--- a/compiler/rt/subprim.lisp
+++ /dev/null
@@ -1,63 +0,0 @@
-;;; -*- Package: MIPS; 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/rt/subprim.lisp,v 1.1 1991/02/18 15:08:16 chiles Exp $
-;;;
-;;; Linkage information for standard static functions, and random vops.
-;;;
-;;; Written by William Lott.
-;;; Converted for IBM RT by Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-;;;; Length
-
-(define-vop (length/list)
-  (:translate length)
-  (:args (object :scs (descriptor-reg) :target ptr))
-  (:arg-types list)
-  (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr)
-  (:temporary (:scs (non-descriptor-reg) :type random) temp)
-  (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result)
-	      count)
-  (:results (result :scs (any-reg descriptor-reg)))
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 50
-    (let ((done (gen-label))
-	  (loop (gen-label))
-	  (not-list (generate-cerror-code vop object-not-list-error object)))
-      (move ptr object)
-      (inst li count 0)
-
-      (emit-label loop)
-
-      (inst c ptr null-tn)
-      (inst bc :eq done)
-
-      (test-type ptr temp not-list t vm:list-pointer-type)
-
-      (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type)
-      (inst inc count (fixnum 1))
-      (test-type ptr temp loop nil vm:list-pointer-type)
-
-      (cerror-call vop done object-not-list-error ptr)
-
-      (emit-label done)
-      (move result count))))
-       
-
-(define-static-function length (object) :translate length)
-
-
-
diff --git a/compiler/rt/system.lisp b/compiler/rt/system.lisp
deleted file mode 100644
index 90f66c3a85e9607bb5e4198d90a2267348f6c747..0000000000000000000000000000000000000000
--- a/compiler/rt/system.lisp
+++ /dev/null
@@ -1,244 +0,0 @@
-;;; -*- Package: rt; 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/rt/system.lisp,v 1.7 1992/03/10 10:01:15 wlott Exp $
-;;;
-;;; IBM RT VM definitions of various system hacking operations.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; IBM RT conversion by Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-;;;; Type frobbing VOPs.
-
-(define-vop (get-lowtag)
-  (:translate get-lowtag)
-  (:policy :fast-safe)
-  (:args (object :scs (any-reg descriptor-reg)))
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 1
-    (inst nilz result object lowtag-mask)))
-
-(define-vop (get-type)
-  (:translate get-type)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (let ((other-ptr (gen-label))
-	  (function-ptr (gen-label))
-	  (lowtag-only (gen-label))
-	  (done (gen-label)))
-      (test-type object ndescr other-ptr nil other-pointer-type)
-      (test-type object ndescr function-ptr nil function-pointer-type)
-      (test-type object ndescr lowtag-only nil
-		 even-fixnum-type odd-fixnum-type list-pointer-type
-		 structure-pointer-type)
-      (inst bx done)
-      (inst nilz result object type-mask)
-
-      (emit-label function-ptr)
-      (load-type result object function-pointer-type)
-      (inst b done)
-
-      (emit-label lowtag-only)
-      (inst bx done)
-      (inst nilz result object lowtag-mask)
-
-      (emit-label other-ptr)
-      (load-type result object other-pointer-type)
-      
-      (emit-label done))))
-
-(define-vop (get-header-data)
-  (:translate get-header-data)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 7
-    (loadw res x 0 other-pointer-type)
-    (inst sr res type-bits)))
-
-(define-vop (get-closure-length)
-  (:translate get-closure-length)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 7
-    (loadw res x 0 function-pointer-type)
-    (inst sr res type-bits)))
-
-;;; SET-HEADER-DATA -- VOP.
-;;;
-;;; In the immediate case for data, we use the OIL instruction assuming the
-;;; data fits in the number of bits determined by 16 minus type-bits.  Due to
-;;; known uses of this VOP, which only store single digit tags, the above
-;;; assumption is reasonable, although unnecessarily slimy.
-;;;
-(define-vop (set-header-data)
-  (:translate set-header-data)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg) :target res)
-	 (data :scs (any-reg immediate) :target t2))
-  (:arg-types * positive-fixnum)
-  (:results (res :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg) :type random) t1)
-  (:temporary (:scs (non-descriptor-reg) :type random :from (:argument 1)) t2)
-  (:generator 15
-    (loadw t1 x 0 other-pointer-type)
-    (inst nilz t1 type-mask)
-    (sc-case data
-      (any-reg
-       (move t2 data)
-       ;; Since the data is in fixnum format, it is already shifted by 2 bits.
-       (inst sl t2 (- type-bits 2))
-       (inst o t1 t2))
-      (immediate
-       (let ((value (tn-value data)))
-	 (unless (zerop value)
-	   (inst oil t1 (ash value type-bits))))))
-    (storew t1 x 0 other-pointer-type)
-    (move res x)))
-
-;;; MAKE-FIXNUM -- VOP.
-;;;
-;;; This is just used in hashing stuff.  It doesn't necessarily have to
-;;; preserve all the bits in the pointer.  Some code expects a positive number,
-;;; so make sure the right shift is logical.
-;;;
-(define-vop (make-fixnum)
-  (:args (ptr :scs (any-reg descriptor-reg) :target temp))
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) temp)
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 3
-    (move temp ptr)
-    (inst sl temp 3)
-    (inst sr temp 1)
-    (move res temp)))
-
-(define-vop (make-other-immediate-type)
-  (:args (val :scs (any-reg descriptor-reg))
-	 (type :scs (any-reg descriptor-reg immediate)))
-  (:results (res :scs (any-reg descriptor-reg) :from :load))
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
-  (:generator 2
-    (move res val)
-    (inst sl res (- type-bits 2))
-    (sc-case type
-      (immediate
-       (inst oil res (tn-value type)))
-      (t
-       ;; Type is a fixnum, so lose those lowtag bits.
-       (move temp type)
-       (inst sr temp 2)
-       (inst o res temp)))))
-
-
-
-;;;; Allocation
-
-(define-vop (dynamic-space-free-pointer)
-  (:results (int :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate dynamic-space-free-pointer)
-  (:policy :fast-safe)
-  (:generator 6
-    (load-symbol-value int *allocation-pointer*)))
-
-(define-vop (binding-stack-pointer-sap)
-  (:results (int :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate binding-stack-pointer-sap)
-  (:policy :fast-safe)
-  (:generator 6
-    (load-symbol-value int *binding-stack-pointer*)))
-
-(define-vop (control-stack-pointer-sap)
-  (:results (int :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate control-stack-pointer-sap)
-  (:policy :fast-safe)
-  (:generator 1
-    (move int csp-tn)))
-
-
-
-;;;; Code object frobbing.
-
-(define-vop (code-instructions)
-  (:translate code-instructions)
-  (:policy :fast-safe)
-  (:args (code :scs (descriptor-reg) :target sap))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:results (sap :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 10
-    (loadw ndescr code 0 other-pointer-type)
-    (inst sr ndescr type-bits)
-    (inst sl ndescr word-shift)
-    (inst s ndescr other-pointer-type)
-    (move sap code)
-    (inst a sap ndescr)))
-
-(define-vop (compute-function)
-  (:args (code :scs (descriptor-reg))
-	 (offset :scs (signed-reg unsigned-reg)))
-  (:arg-types * positive-fixnum)
-  (:results (func :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:generator 10
-    (loadw ndescr code 0 other-pointer-type)
-    (inst sr ndescr type-bits)
-    (inst sl ndescr word-shift)
-    (inst a ndescr offset)
-    (inst a ndescr (- function-pointer-type other-pointer-type))
-    (inst a ndescr code)
-    (move func ndescr)))
-
-
-
-;;;; Other random VOPs.
-
-
-(defknown unix::do-pending-interrupt () (values))
-(define-vop (unix::do-pending-interrupt)
-  (:policy :fast-safe)
-  (:translate unix::do-pending-interrupt)
-  (:generator 1
-    (inst break pending-interrupt-trap)))
-
-
-(define-vop (halt)
-  (:generator 1
-    (inst break halt-trap)))
-
-
-
-;;;; Dynamic vop count collection support
-
-(define-vop (count-me)
-  (:args (count-vector :scs (descriptor-reg)))
-  (:info index)
-  (:temporary (:scs (non-descriptor-reg)) count)
-  (:generator 1
-    (let ((offset
-	   (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
-      (inst l count count-vector offset)
-      (inst inc count 1)
-      (inst st count count-vector offset))))
diff --git a/compiler/rt/type-vops.lisp b/compiler/rt/type-vops.lisp
deleted file mode 100644
index e6442822f4f87368a0652ef1f150d860228dacef..0000000000000000000000000000000000000000
--- a/compiler/rt/type-vops.lisp
+++ /dev/null
@@ -1,474 +0,0 @@
-;;; -*- Package: RT; 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/rt/type-vops.lisp,v 1.5 1992/05/26 13:55:12 wlott Exp $
-;;; 
-;;; This file contains the VM definition of type testing and checking VOPs
-;;; for the IBM RT.
-;;;
-;;; Written by William Lott.
-;;; Converted to IBM RT by Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-;;;; Simple type checking and testing.
-
-;;; These types are represented by a single type code and are easily open-coded
-;;; as a mask and compare.
-;;;
-
-;;; CHECK-TYPE -- VOP.
-;;;
-;;; Type checking VOPs include this.  Instances of this either returns value
-;;; in result, or they jump to error code if the type is wrong.
-;;;
-(define-vop (check-type)
-  (:args (value :target result :scs (any-reg descriptor-reg)))
-  (:results (result :scs (any-reg descriptor-reg)))
-  (:temporary (:type random :scs (non-descriptor-reg)) temp)
-  (:vop-var vop)
-  (:save-p :compute-only))
-
-;;; TYPE-PREDICATE -- VOP.
-;;;
-;;; Type predicate VOPs include this.  They jump to target when value is of the
-;;; appropriate type; otherwise, they drop through.  When not-p is true, they
-;;; drop through if value is of the type and jumps to target if not.
-;;;
-(define-vop (type-predicate)
-  (:args (value :scs (any-reg descriptor-reg)))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:temporary (:scs (non-descriptor-reg)) temp))
-
-
-(eval-when (compile eval)
-
-(defun cost-to-test-types (type-codes)
-  (+ (* 2 (length type-codes))
-     (if (> (apply #'max type-codes) vm:lowtag-limit) 7 2)))
-
-(defmacro def-type-vops (pred-name check-name ptype error-code
-				   &rest type-codes)
-  (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
-    `(progn
-       ,@(when pred-name
-	   `((define-vop (,pred-name type-predicate)
-	       (:translate ,pred-name)
-	       (:generator ,cost
-		 (test-type value temp target not-p ,@type-codes)))))
-       ,@(when check-name
-	   `((define-vop (,check-name check-type)
-	       (:generator ,cost
-		 (let ((err-lab
-			(generate-error-code vop ,error-code value)))
-		   (test-type value temp err-lab t ,@type-codes)
-		   (move result value))))))
-       ,@(when ptype
-	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
-
-); eval-when (compile eval)
-
-
-(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
-  vm:even-fixnum-type vm:odd-fixnum-type)
-
-(def-type-vops functionp check-function function
-  object-not-function-error vm:function-pointer-type)
-
-(def-type-vops listp check-list list
-  object-not-list-error vm:list-pointer-type)
-
-(def-type-vops structurep check-structure structure
-  object-not-structure-error vm:structure-pointer-type)
-
-(def-type-vops bignump check-bigunm bignum
-  object-not-bignum-error vm:bignum-type)
-
-(def-type-vops ratiop check-ratio ratio
-  object-not-ratio-error vm:ratio-type)
-
-(def-type-vops complexp check-complex complex
-  object-not-complex-error vm:complex-type)
-
-(def-type-vops single-float-p check-single-float nil ;single-float
-  object-not-single-float-error vm:single-float-type)
-
-(def-type-vops double-float-p check-double-float nil ;double-float
-  object-not-double-float-error vm:double-float-type)
-
-(def-type-vops simple-string-p check-simple-string simple-string
-  object-not-simple-string-error vm:simple-string-type)
-
-(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
-  object-not-simple-bit-vector-error vm:simple-bit-vector-type)
-
-(def-type-vops simple-vector-p check-simple-vector simple-vector
-  object-not-simple-vector-error vm:simple-vector-type)
-
-(def-type-vops simple-array-unsigned-byte-2-p
-  check-simple-array-unsigned-byte-2
-  simple-array-unsigned-byte-2
-  object-not-simple-array-unsigned-byte-2-error
-  vm:simple-array-unsigned-byte-2-type)
-
-(def-type-vops simple-array-unsigned-byte-4-p
-  check-simple-array-unsigned-byte-4
-  simple-array-unsigned-byte-4
-  object-not-simple-array-unsigned-byte-4-error
-  vm:simple-array-unsigned-byte-4-type)
-
-(def-type-vops simple-array-unsigned-byte-8-p
-  check-simple-array-unsigned-byte-8
-  simple-array-unsigned-byte-8
-  object-not-simple-array-unsigned-byte-8-error
-  vm:simple-array-unsigned-byte-8-type)
-
-(def-type-vops simple-array-unsigned-byte-16-p
-  check-simple-array-unsigned-byte-16
-  simple-array-unsigned-byte-16
-  object-not-simple-array-unsigned-byte-16-error
-  vm:simple-array-unsigned-byte-16-type)
-
-(def-type-vops simple-array-unsigned-byte-32-p
-  check-simple-array-unsigned-byte-32
-  simple-array-unsigned-byte-32
-  object-not-simple-array-unsigned-byte-32-error
-  vm:simple-array-unsigned-byte-32-type)
-
-(def-type-vops simple-array-single-float-p check-simple-array-single-float
-  simple-array-single-float object-not-simple-array-single-float-error
-  vm:simple-array-single-float-type)
-
-(def-type-vops simple-array-double-float-p check-simple-array-double-float
-  simple-array-double-float object-not-simple-array-double-float-error
-  vm:simple-array-double-float-type)
-
-(def-type-vops base-char-p check-base-char base-char
-  object-not-base-char-error vm:base-char-type)
-
-(def-type-vops system-area-pointer-p check-system-area-pointer
-  system-area-pointer object-not-sap-error vm:sap-type)
-
-(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
-  object-not-weak-pointer-error vm:weak-pointer-type)
-
-(def-type-vops array-header-p nil nil nil
-  vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type
-  vm:complex-vector-type vm:complex-array-type)
-
-(def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error
-  vm:function-pointer-type vm:symbol-header-type)
-
-(def-type-vops stringp check-string nil object-not-string-error
-  vm:simple-string-type vm:complex-string-type)
-
-(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
-  vm:simple-bit-vector-type vm:complex-bit-vector-type)
-
-(def-type-vops vectorp check-vector nil object-not-vector-error
-  vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type
-  vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type
-  vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type
-  vm:simple-array-unsigned-byte-32-type vm:simple-array-single-float-type
-  vm:simple-array-double-float-type vm:complex-string-type
-  vm:complex-bit-vector-type vm:complex-vector-type)
-
-(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
-  vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
-  vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
-  vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
-  vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
-  vm:simple-array-single-float-type vm:simple-array-double-float-type)
-
-(def-type-vops arrayp check-array nil object-not-array-error
-  vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
-  vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
-  vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
-  vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
-  vm:simple-array-single-float-type vm:simple-array-double-float-type
-  vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type
-  vm:complex-array-type)
-
-(def-type-vops numberp check-number nil object-not-number-error
-  vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type
-  vm:single-float-type vm:double-float-type vm:complex-type)
-
-(def-type-vops rationalp check-rational nil object-not-rational-error
-  vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type)
-
-(def-type-vops integerp check-integer nil object-not-integer-error
-  vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type)
-
-(def-type-vops floatp check-float nil object-not-float-error
-  vm:single-float-type vm:double-float-type)
-
-(def-type-vops realp check-real nil 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)
-
-(def-type-vops code-component-p nil nil nil code-header-type)
-(def-type-vops lra-p nil nil nil return-pc-header-type)
-(def-type-vops scavenger-hook-p nil nil nil 0)
-
-(def-type-vops funcallable-instance-p nil nil nil
-  vm:funcallable-instance-header-type)
-
-
-;;;; Other integer ranges.
-
-;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
-;;; exactly one digit.
-;;;
-
-(define-vop (signed-byte-32-p type-predicate)
-  (:translate signed-byte-32-p)
-  (:generator 45
-    (let ((not-target (gen-label)))
-      (multiple-value-bind
-	  (yep nope)
-	  (if not-p
-	      (values not-target target)
-	      (values target not-target))
-	;; Is it a fisnum?
-	(inst nilz temp value #x3)
-	(inst bc :eq yep)
-	;; If not, is it an other pointer?
-	(test-type value temp nope t vm:other-pointer-type)
-	;; If so, get the header.
-	(loadw temp value 0 vm:other-pointer-type)
-	;; Is it a bignum of length one?
-	(inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type))
-	(if not-p
-	    (inst bnc :eq target)
-	    (inst bc :eq target))
-	(emit-label not-target)))))
-
-(define-vop (check-signed-byte-32 check-type)
-  (:generator 45
-    (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
-	  (yep (gen-label)))
-      (inst nilz temp value #x3)
-      (inst bc :eq yep)
-      (test-type value temp nope t vm:other-pointer-type)
-      (loadw temp value 0 vm:other-pointer-type)
-      (inst c temp
-	    ;; Header word representing a bignum of length one.
-	    (logior (ash 1 vm:type-bits) vm:bignum-type))
-      (inst bnc :eq nope)
-      (emit-label yep)
-      (move result value))))
-
-
-;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
-;;; bignum with exactly one positive digit, or a bignum with exactly two digits
-;;; and the second digit all zeros.
-
-(define-vop (unsigned-byte-32-p type-predicate)
-  (:translate unsigned-byte-32-p)
-  (:generator 45
-    (let ((not-target (gen-label))
-	  (single-word (gen-label))
-	  (fixnum (gen-label)))
-      (multiple-value-bind
-	  (yep nope)
-	  (if not-p
-	      (values not-target target)
-	      (values target not-target))
-	;; Is it a fixnum?
-	(inst nilz temp value #x3)
-	(inst bcx :eq fixnum)
-	(inst c value 0)
-	;; If not, is it an other pointer?
-	(test-type value temp nope t vm:other-pointer-type)
-	;; Get the header.
-	(loadw temp value 0 vm:other-pointer-type)
-	;; Is it a bignum of length one?
-	(inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type))
-	(inst bcx :eq single-word)
-	;; If it length is other than two, we can't be an (unsigned-byte 32).
-	(inst c temp (+ (ash 2 vm:type-bits) vm:bignum-type))
-	(inst bncx :eq nope)
-	;; Get the second digit.
-	(loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
-	;; All zeros, its an (unsigned-byte 32).
-	(inst c temp 0)
-	(inst bc :eq yep)
-	;; Otherwise, it isn't.
-	(inst b nope)
-	
-	(emit-label single-word)
-	;; Get the single digit.
-	(loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
-	(inst c temp 0)
-
-	;; positive implies (unsigned-byte 32).
-	(emit-label fixnum)
-	(if not-p
-	    (inst bc :lt target)
-	    (inst bnc :lt target))
-
-	(emit-label not-target)))))	  
-
-(define-vop (check-unsigned-byte-32 check-type)
-  (:generator 45
-    (let ((nope
-	   (generate-error-code vop object-not-unsigned-byte-32-error value))
-	  (yep (gen-label))
-	  (fixnum (gen-label))
-	  (single-word (gen-label)))
-      ;; Is it a fixnum?
-      (inst nilz temp value #x3)
-      (inst bcx :eq fixnum)
-      (inst c value 0)
-
-      ;; If not, is it an other pointer?
-      (test-type value temp nope t vm:other-pointer-type)
-      ;; Get the number of digits.
-      (loadw temp value 0 vm:other-pointer-type)
-      ;; Is it one?
-      (inst c temp (logior (ash 1 vm:type-bits) vm:bignum-type))
-      (inst bcx :eq single-word)
-      ;; If it's length is other than two, we can't be an (unsigned-byte 32).
-      (inst c temp (+ (ash 2 vm:type-bits) vm:bignum-type))
-      (inst bncx :eq nope)
-      ;; Get the second digit.
-      (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
-      ;; All zeros, its an (unsigned-byte 32).
-      (inst c temp 0)
-      (inst bc :eq yep)
-      ;; Otherwise, it isn't.
-      (inst bnc :eq nope)
-      
-      (emit-label single-word)
-      ;; Get the single digit.
-      (loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
-      ;; positive implies (unsigned-byte 32).
-      (inst c temp 0)
-      
-      (emit-label fixnum)
-      (inst bc :lt nope)
-      
-      (emit-label yep)
-      (move result value))))
-
-
-
-
-;;;; List/symbol types:
-
-;;; SYMBOLP -- VOP.
-;;;
-;;; This is (or symbol (eq nil)).
-;;;
-(define-vop (symbolp type-predicate)
-  (:translate symbolp)
-  (:generator 12
-    (let* ((drop-thru (gen-label))
-	   (is-symbol-label (if not-p drop-thru target)))
-      (inst c value null-tn)
-      (inst bc :eq is-symbol-label)
-      (test-type value temp target not-p vm:symbol-header-type)
-      (emit-label drop-thru))))
-;;;
-(define-vop (check-symbol check-type)
-  (:generator 12
-    (let ((drop-thru (gen-label))
-	  (error (generate-error-code vop object-not-symbol-error value)))
-      (inst c value null-tn)
-      (inst bc :eq drop-thru)
-      (test-type value temp error t vm:symbol-header-type)
-      (emit-label drop-thru)
-      (move result value))))
-  
-;;; CONSP -- VOP.
-;;;
-;;; This is (and list (not (eq nil))).
-;;;
-(define-vop (consp type-predicate)
-  (:translate consp)
-  (:generator 8
-    (let* ((drop-thru (gen-label))
-	   (is-not-cons-label (if not-p target drop-thru)))
-      (inst c value null-tn)
-      (inst bc :eq is-not-cons-label)
-      (test-type value temp target not-p vm:list-pointer-type)
-      (emit-label drop-thru))))
-;;;
-(define-vop (check-cons check-type)
-  (:generator 8
-    (let ((error (generate-error-code vop object-not-cons-error value)))
-      (inst c value null-tn)
-      (inst bc :eq error)
-      (test-type value temp error t vm:list-pointer-type)
-      (move result value))))
-
-
-
-;;;; 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)))
-  (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
-  (:temporary (:scs (descriptor-reg)) saved-object)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 0
-    (let ((not-function-label (gen-label))
-	  (not-coercable-label (gen-label))
-	  (done-label (gen-label)))
-      (test-type object nd-temp not-function-label t
-		 vm:function-pointer-type)
-      (move result object)
-      (emit-label done-label)
-
-      (assemble (*elsewhere*)
-	(emit-label not-function-label)
-	(test-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-type result nd-temp done-label nil
-		   vm:function-pointer-type)
-	(error-call vop undefined-symbol-error saved-object)
-	
-	(emit-label not-coercable-label)
-	(error-call vop object-not-coercable-to-function-error object)))))
-
-(define-vop (fast-safe-coerce-to-function)
-  (:args (object :scs (descriptor-reg)
-		 :target result))
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
-  (:temporary (:scs (descriptor-reg)) saved-object)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 10
-    (let ((not-function-label (gen-label))
-	  (done-label (gen-label)))
-      (test-type object nd-temp not-function-label t vm:function-pointer-type)
-      (move result object)
-      (emit-label done-label)
-
-      (assemble (*elsewhere*)
-	(emit-label not-function-label)
-	(move saved-object object)
-	(loadw result object vm:symbol-function-slot vm:other-pointer-type)
-	(test-type result nd-temp done-label nil vm:function-pointer-type)
-	(error-call vop undefined-symbol-error saved-object)))))
diff --git a/compiler/rt/values.lisp b/compiler/rt/values.lisp
deleted file mode 100644
index e67e53cd4b61df6954bfc46a0ab1393af736690d..0000000000000000000000000000000000000000
--- a/compiler/rt/values.lisp
+++ /dev/null
@@ -1,102 +0,0 @@
-;;; -*- Package: RT; 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/rt/values.lisp,v 1.3 1991/12/21 23:05:29 ram Exp $
-;;;
-;;; This file contains the implementation of unknown-values VOPs.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted for IBM RT by Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-(define-vop (reset-stack-pointer)
-  (:args (ptr :scs (word-pointer-reg)))
-  (:generator 1
-    (move csp-tn ptr)))
-
-;;; PUSH-VALUES -- VOP.
-;;;
-;;; 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 (word-pointer-reg))
-   (count :scs (any-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 cal csp-tn csp-tn (* nvals 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)
-    (inst li count (fixnum nvals))))
-
-
-;;; VALUES-LIST -- VOP.
-;;;
-;;; 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 (word-pointer-reg))
-	    (count :scs (any-reg)))
-  (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 0
-    (let ((loop (gen-label))
-	  (done (gen-label)))
-
-      (move list arg)
-      (move start csp-tn)
-
-      (emit-label loop)
-      (inst c list null-tn)
-      (inst bcx :eq done)
-      (loadw temp list cons-car-slot list-pointer-type)
-      (loadw list list cons-cdr-slot list-pointer-type)
-      (inst cal csp-tn csp-tn word-bytes)
-      (storew temp csp-tn -1)
-      (test-type list ndescr loop nil list-pointer-type)
-      (error-call vop bogus-argument-to-values-list-error list)
-
-      (emit-label done)
-      (move count csp-tn)
-      (inst s count start))))
diff --git a/compiler/rt/vm.lisp b/compiler/rt/vm.lisp
deleted file mode 100644
index b168d0ee8de67d5b6f374485e44fcebd5703b88f..0000000000000000000000000000000000000000
--- a/compiler/rt/vm.lisp
+++ /dev/null
@@ -1,684 +0,0 @@
-;;; -*- Package: RT; 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)
-;;; **********************************************************************
-;;;
-;;; This file contains the VM definition for the IBM RT.
-;;;
-;;; Written by William Lott, Rob Maclachlan, and Bill Chiles.
-;;;
-
-(in-package "RT")
-
-
-
-;;;; SB and SC definition:
-
-(define-storage-base registers :finite :size 16)
-(define-storage-base mc68881-float-registers :finite :size 8)
-(define-storage-base AFPA-float-registers :finite :size 64)
-(define-storage-base FPA-float-registers :finite :size 16)
-(define-storage-base control-stack :unbounded :size 8)
-(define-storage-base non-descriptor-stack :unbounded :size 0)
-;; These are constants in components.
-(define-storage-base constant :non-packed)
-;; Anything I can cookup out of nowhere and store somewhere.
-(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)
-  (do ((forms (list 'progn)
-	      (let* ((class (car classes))
-		     (sc-name (car class))
-		     (constant-name (intern (concatenate 'simple-string
-							 (string sc-name)
-							 "-SC-NUMBER"))))
-		(list* `(define-storage-class ,sc-name ,index
-			  ,@(cdr class))
-		       `(eval-when (compile load eval)
-			  (defconstant ,constant-name ,index))
-		       `(export ',constant-name)
-		       forms)))
-       (index 0 (1+ index))
-       (classes classes (cdr classes)))
-      ((null classes)
-       (nreverse forms))))
-
-(define-storage-classes
-
-  ;; Non-immediate contstants in the constant pool
-  (constant constant)
-
-
-  (immediate immediate-constant)
-  (null immediate-constant)
-
-
-  ;; The control stack.  (Scanned by GC)
-  (control-stack control-stack)
-
-  ;; The non-descriptor stack SC's.
-  (signed-stack non-descriptor-stack) ; (signed-byte 32)
-  (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
-  (base-char-stack non-descriptor-stack) ; non-descriptor characters.
-  (sap-stack non-descriptor-stack) ; System area pointers.
-  (single-stack non-descriptor-stack) ; single-floats
-  (double-stack non-descriptor-stack :element-size 2) ; double floats.
-
-
-  ;; **** Things that can go in the non-descriptor registers.
-
-  ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
-  ;; bad will happen if they are.  (fixnums, characters, header values, etc).
-  (any-reg registers
-   :locations (9 10 11 12 13 14 0 2 3 4)
-   :constant-scs (immediate)
-   :reserve-locations (0 2 3 4)
-   :save-p t
-   :alternate-scs (control-stack))
-
-  ;; Descriptor objects.  Must be seen by GC.
-  (descriptor-reg registers
-   :locations (9 10 11 12 13 14)
-   ;; Immediate (and constant) for moving NULL around (at least).
-   :constant-scs (constant immediate null)
-   :save-p t
-   :alternate-scs (control-stack))
-
-  ;; Non-Descriptor characters.
-  (base-char-reg registers
-   :locations (0 2 3 4)
-   :constant-scs (immediate)
-   :save-p t
-   :alternate-scs (base-char-stack))
-
-  ;; Non-Descriptor SAP's (arbitrary pointers into address space).
-  (sap-reg registers
-   ;; Exclude R0 here because the instructions we would like to use with sap
-   ;; TN's use R0 as the constant zero instead of using the contents of R0.
-   :locations (2 3 4)
-   :constant-scs (immediate)
-   :save-p t
-   :alternate-scs (sap-stack))
-
-  ;; Non-Descriptor (signed or unsigned) numbers.
-  (signed-reg registers
-   :locations (0 2 3 4)
-   :constant-scs (immediate)
-   :save-p t
-   :alternate-scs (signed-stack))
-  (unsigned-reg registers
-   :locations (0 2 3 4)
-   :constant-scs (immediate)
-   :save-p t
-   :alternate-scs (unsigned-stack))
-
-  ;; Random objects that must not be seen by GC.  Used only as temporaries.
-  (non-descriptor-reg registers
-   :locations (0 2 3 4))
-
-  ;; Word-aligned pointers that cannot be in R0.  Used for temporaries and to
-  ;; hold stack pointers.
-  (word-pointer-reg registers
-   :locations (2 3 4 9 10 11 12 13 14)
-   :save-p t
-   :alternate-scs (control-stack))
-
-  ;; Pointers to the interior of objects.  Used only as an temporary.
-  (interior-reg registers
-   :locations (15))
-
-
-  ;; **** Things that can go in the floating point registers.
-
-  ;; Non-Descriptor mc68881-single-floats.
-  (mc68881-single-reg mc68881-float-registers
-   :locations (0 1 2 3 4 5 6 7)
-   :constant-scs ()
-   :save-p t
-   :alternate-scs (single-stack))
-  ;; Non-Descriptor mc68881-double-floats.
-  (mc68881-double-reg mc68881-float-registers
-   :locations (0 1 2 3 4 5 6 7)
-   :constant-scs ()
-   :save-p t
-   :alternate-scs (double-stack))
-
-  ;; Non-Descriptor FPA-single-floats.
-  (FPA-single-reg FPA-float-registers
-   ;; 14 and 15 are status and exception registers.
-   :locations (0 1 2 3 4 5 6 7 8 9 10 11 12 13)
-   :constant-scs ()
-   :save-p t
-   :alternate-scs (single-stack))
-  ;; Non-Descriptor FPA-double-floats.
-  (FPA-double-reg FPA-float-registers
-   :locations (0 2 4 6 8 10 12) ;14 and 15 are status and exception registers.
-   :element-size 2
-   :constant-scs ()
-   :save-p t
-   :alternate-scs (double-stack))
-
-  ;; Non-Descriptor AFPA-single-floats.  0,1 reserved for loading "immediate"
-  ;; operands.
-  (AFPA-single-reg AFPA-float-registers
-   :locations (2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
-	       24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44
-	       45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63)
-   :constant-scs ()
-   :save-p t
-   :alternate-scs (single-stack))
-  ;; Non-Descriptor AFPA-double-floats.  0 reserved for loading "immediate"
-  ;; operands.
-  (AFPA-double-reg AFPA-float-registers
-   :locations (2 4 6 8 10 12 14 16 18 20 22 24 26 28
-	       30 32 34 36 38 40 42 44 46 48 50 52 54 56 58 60 62)
-   :element-size 2
-   :constant-scs ()
-   :save-p t
-   :alternate-scs (double-stack))
-
-
-  ;; A catch or unwind block.
-  (catch-block control-stack :element-size vm:catch-block-size))
-
-
-(export '(single-reg-sc-number double-reg-sc-number))
-(defconstant single-reg-sc-number
-  (list mc68881-single-reg-sc-number
-	FPA-single-reg-sc-number
-	AFPA-single-reg-sc-number))
-(defconstant double-reg-sc-number
-  (list mc68881-double-reg-sc-number
-	FPA-double-reg-sc-number
-	AFPA-double-reg-sc-number))
-
-
-;;;; Primitive Type Definitions
-
-;;; *any-primitive-type*
-;;;
-;;; Other VOP/VM definition files use this when writing interface code for the
-;;; compiler.
-;;;
-(def-primitive-type t (descriptor-reg))
-(defvar *any-primitive-type* (primitive-type-or-lose 't))
-(setf (c:backend-any-primitive-type c:*target-backend*)
-      (c:primitive-type-or-lose 't))
-
-;;; Primitive integer types that fit in registers.
-;;;
-(def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
-  :type (unsigned-byte 29))
-(def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
-  :type (unsigned-byte 31))
-(def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
-  :type (unsigned-byte 32))
-(def-primitive-type fixnum (any-reg signed-reg)
-  :type (signed-byte 30))
-(def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
-  :type (signed-byte 32))
-(def-primitive-type word-pointer (word-pointer-reg descriptor-reg)
-  :type fixnum)
-
-
-;;; *word-pointer-type*
-;;;
-(defvar *word-pointer-type* (primitive-type-or-lose 'word-pointer))
-
-
-;;; *fixnum-primitive-type*
-;;;
-;;; Other VOP/VM definition files use this when writing interface code for the
-;;; compiler.
-;;;
-(defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
-
-(def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
-(def-primitive-type-alias unsigned-num (:or unsigned-byte-32
-					    unsigned-byte-31
-					    positive-fixnum))
-(def-primitive-type-alias signed-num (:or signed-byte-32
-					  fixnum
-					  unsigned-byte-31
-					  positive-fixnum))
-
-;;; Other primitive immediate types.
-(def-primitive-type base-char (base-char-reg any-reg))
-
-;;; Primitive pointer types.
-;;; 
-(def-primitive-type function (descriptor-reg))
-(def-primitive-type list (descriptor-reg))
-(def-primitive-type structure (descriptor-reg))
-
-;;; Primitive other-pointer number types.
-;;; 
-(def-primitive-type bignum (descriptor-reg))
-(def-primitive-type ratio (descriptor-reg))
-(def-primitive-type complex (descriptor-reg))
-(def-primitive-type mc68881-single-float (mc68881-single-reg descriptor-reg)
-  :type single-float)
-(def-primitive-type mc68881-double-float (mc68881-double-reg descriptor-reg)
-  :type double-float)
-(def-primitive-type FPA-single-float (FPA-single-reg descriptor-reg)
-  :type single-float)
-(def-primitive-type FPA-double-float (FPA-double-reg descriptor-reg)
-  :type double-float)
-(def-primitive-type AFPA-single-float (AFPA-single-reg descriptor-reg)
-  :type single-float)
-(def-primitive-type AFPA-double-float (AFPA-double-reg descriptor-reg)
-  :type double-float)
-(def-primitive-type any-single-float (descriptor-reg)
-  :type single-float)
-(def-primitive-type any-double-float (descriptor-reg)
-  :type double-float)
-
-;;; Primitive other-pointer array types.
-;;; 
-(def-primitive-type simple-string (descriptor-reg) :type simple-base-string)
-(def-primitive-type simple-bit-vector (descriptor-reg))
-(def-primitive-type simple-vector (descriptor-reg))
-(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
-  :type (simple-array (unsigned-byte 2) (*)))
-(def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
-  :type (simple-array (unsigned-byte 4) (*)))
-(def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
-  :type (simple-array (unsigned-byte 8) (*)))
-(def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
-  :type (simple-array (unsigned-byte 16) (*)))
-(def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
-  :type (simple-array (unsigned-byte 32) (*)))
-(def-primitive-type simple-array-single-float (descriptor-reg)
-  :type (simple-array single-float (*)))
-(def-primitive-type simple-array-double-float (descriptor-reg)
-  :type (simple-array double-float (*)))
-
-;;; Note: The complex array types are not included, because it is pointless to
-;;; restrict VOPs to them.
-
-;;; Other primitive other-pointer types.
-;;; 
-(def-primitive-type system-area-pointer (sap-reg descriptor-reg))
-(def-primitive-type weak-pointer (descriptor-reg))
-
-;;; Random primitive types that don't exist at the LISP level.
-;;; 
-(def-primitive-type random (non-descriptor-reg) :type nil)
-(def-primitive-type interior (interior-reg) :type nil)
-(def-primitive-type catch-block (catch-block) :type nil)
-
-
-
-
-;;;; PRIMITIVE-TYPE-OF and friends.
-
-;;; PRIMITIVE-TYPE-OF  --  Interface.
-;;;
-;;; Return the most restrictive primitive type that contains Object.
-;;;
-(def-vm-support-routine 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-char . simple-string)
-    (string-char . 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.")
-
-(defvar *target-float-hardware*)
-
-;;; PRIMITIVE-TYPE -- Internal Interface.
-;;;
-;;; 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.
-;;;
-(def-vm-support-routine primitive-type (type)
-  (declare (type ctype type))
-  (macrolet ((any () '(values *any-primitive-type* nil))
-	     (exactly (type) `(values (primitive-type-or-lose ',type) t))
-	     (part-of (type) `(values (primitive-type-or-lose ',type) nil)))
-    (etypecase type
-      (numeric-type
-       (let ((lo (numeric-type-low type))
-	     (hi (numeric-type-high type)))
-	 (case (numeric-type-complexp type)
-	   (:real
-	    (case (numeric-type-class type)
-	      (integer
-	       (cond ((and hi lo)
-		      (dolist (spec
-			       '((positive-fixnum 0 #.(1- (ash 1 29)))
-				 (unsigned-byte-31 0 #.(1- (ash 1 31)))
-				 (unsigned-byte-32 0 #.(1- (ash 1 32)))
-				 (fixnum #.(ash -1 29) #.(1- (ash 1 29)))
-				 (signed-byte-32 #.(ash -1 31)
-						 #.(1- (ash 1 31))))
-			       (if (or (< hi (ash -1 29))
-				       (> lo (1- (ash 1 29))))
-				   (part-of bignum)
-				   (any)))
-			(let ((type (car spec))
-			      (min (cadr spec))
-			      (max (caddr spec)))
-			  (when (<= min lo hi max)
-			    (return (values (primitive-type-or-lose type)
-					    (and (= lo min) (= hi max))))))))
-		     ((or (and hi (< hi most-negative-fixnum))
-			  (and lo (> lo most-positive-fixnum)))
-		      (part-of bignum))
-		     (t
-		      (any))))
-	      (float
-	       (float-primitive-type lo hi type))
-	      (t
-	       (any))))
-	   (:complex
-	    (part-of complex))
-	   (t
-	    (any)))))
-      (array-type
-       (if (array-type-complexp type)
-	   (any)
-	   (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) '*))
-		 (any)))))
-      (union-type
-       (if (type= type (specifier-type 'list))
-	   (exactly list)
-	   (let ((types (union-type-types type)))
-	     (multiple-value-bind (res exact)
-				  (primitive-type (first types))
-	       (dolist (type (rest types) (values res exact))
-		 (multiple-value-bind (ptype ptype-exact)
-				      (primitive-type type)
-		   (unless ptype-exact (setq exact nil))
-		   (unless (eq ptype res)
-		     (return (any)))))))))
-      (member-type
-       (let* ((members (member-type-members type))
-	      (res (primitive-type-of (first members))))
-	 (dolist (mem (rest members) (values res nil))
-	   (unless (eq (primitive-type-of mem) res)
-	     (return (values *any-primitive-type* nil))))))
-      (named-type
-       (case (named-type-name type)
-	 ((t bignum ratio complex function system-area-pointer weak-pointer
-	     structure)
-	  (values (primitive-type-or-lose (named-type-name type)) t))
-	 ((character base-char string-char)
-	  (exactly base-char))
-	 (standard-char
-	  (part-of base-char))
-	 (cons
-	  (part-of list))
-	 (t
-	  (any))))
-      (function-type
-       (exactly function))
-      (structure-type
-       (part-of structure))
-      (ctype
-       (any)))))
-
-;;; FLOAT-PRIMITIVE-TYPE -- Internal.
-;;;
-(defun float-primitive-type (lo hi type)
-  (let ((exact (and (null lo) (null hi))))
-    (case (numeric-type-format type)
-      ((short-float single-float)
-       (ecase *target-float-hardware*
-	 (:mc68881
-	  (values (primitive-type-or-lose 'mc68881-single-float) exact))
-	 (:fpa
-	  (values (primitive-type-or-lose 'fpa-single-float) exact))
-	 (:afpa
-	  (values (primitive-type-or-lose 'afpa-single-float) exact))
-	 (:any
-	  (values (primitive-type-or-lose 'any-single-float) exact))))
-      ((double-float long-float)
-       (ecase *target-float-hardware*
-	 (:mc68881
-	  (values (primitive-type-or-lose 'mc68881-double-float) exact))
-	 (:fpa
-	  (values (primitive-type-or-lose 'fpa-double-float) exact))
-	 (:afpa
-	  (values (primitive-type-or-lose 'afpa-double-float) exact))
-	 (:any
-	  (values (primitive-type-or-lose 'any-double-float) exact))))
-      (t
-       (values *any-primitive-type* nil)))))
-
-
-
-;;;; Magical Registers
-
-;;; Other VOP/VM definition files use the definitions on this page when writing
-;;; interface code for the compiler.
-;;;
-
-(eval-when (compile eval load)
-  (defconstant nargs-offset 0)
-  (defconstant nsp-offset 1)
-  (defconstant nl0-offset 2)
-  (defconstant ocfp-offset 3)
-  (defconstant nfp-offset 4)
-  (defconstant csp-offset 5)
-  (defconstant cfp-offset 6)
-  (defconstant code-offset 7)
-  (defconstant null-offset 8)
-  (defconstant cname-offset 9)
-  (defconstant lexenv-offset 10)
-  (defconstant lra-offset 11)
-  (defconstant a0-offset 12)
-  (defconstant a1-offset 13)
-  (defconstant a2-offset 14)
-  (defconstant lip-offset 15))
-
-;;; Lisp-interior-pointer register.
-;;;
-(defparameter lip-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset lip-offset))
-
-;;; Nil.
-;;;
-(defparameter null-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'descriptor-reg)
-		  :offset null-offset))
-
-
-;;; Frame Pointer.
-;;;
-(defparameter cfp-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset cfp-offset))
-
-
-;;; Control stack pointer.
-;;;
-(defparameter csp-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset csp-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))
-
-;;; Random non-descriptor tn
-;;;
-(defparameter nl0-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'non-descriptor-reg)
-		  :offset nl0-offset))
-
-
-
-;;;; 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.
-;;;
-(def-vm-support-routine immediate-constant-sc (value)
-  (typecase value
-    ((or fixnum character system-area-pointer)
-     (sc-number-or-lose 'immediate))
-    (null
-     (sc-number-or-lose 'null))
-    (symbol
-     (if (static-symbol-p value)
-	 (sc-number-or-lose 'immediate)
-	 nil))))
-
-
-
-;;;; Function Call Parameters
-
-;;; The SC numbers for register and stack arguments/return values.
-;;;
-;;; Other VOP/VM definition files use this when writing interface code for the
-;;; compiler.
-;;;
-(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
-(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
-(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
-
-
-(eval-when (compile load eval)
-
-;;; Offsets of special stack frame locations.
-;;;
-(defconstant ocfp-save-offset 0)
-(defconstant lra-save-offset 1)
-(defconstant nfp-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 ocfp-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'descriptor-reg)
-		  :offset ocfp-offset))
-
-(defparameter lra-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'descriptor-reg)
-		  :offset lra-offset))
-
-
-(eval-when (compile load eval)
-
-;;; The number of arguments/return values passed in registers.
-;;;
-;;; Other VOP/VM definition files use this when writing interface code for the
-;;; compiler.
-;;;
-(defconstant register-arg-count 3)
-
-;;; The offsets within the register-arg SC where we supply values, first value
-;;; first.
-;;;
-;;; Other VOP/VM definition files use this when writing interface code for the
-;;; compiler.
-;;;
-(defconstant register-arg-offsets '(12 13 14))
-
-;;; Names to use for the argument registers.
-;;; 
-(defconstant register-arg-names '(a0 a1 a2))
-
-); 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))
-
-
-
-;;;; LOCATION-PRINT-NAME.
-
-(defconstant register-names #("NARGS" "NSP" "NL0" "OCFP" "NFP"
-			      "CSP" "CFP" "CODE" "NULL" "CNAME" "LEXENV"
-			      "LRA" "A0" "A1" "A2" "LIP"))
-
-;;; LOCATION-PRINT-NAME  --  Interface.
-;;;
-;;; This function is called by debug output routines that want a pretty name
-;;; for a TN's location.  It returns a thing that can be printed with PRINC.
-;;;
-(def-vm-support-routine location-print-name (tn)
-  (declare (type tn tn))
-  (let ((sb (sb-name (sc-sb (tn-sc tn))))
-	(offset (tn-offset tn)))
-    (ecase sb
-      (registers (svref register-names (tn-offset tn)))
-      ((mc68881-float-registers FPA-float-registers AFPA-float-registers)
-       (format nil "F~D" offset))
-      (control-stack (format nil "CS~D" offset))
-      (non-descriptor-stack (format nil "NS~D" offset))
-      (constant (format nil "Const~D" offset))
-      (immediate-constant "Immed"))))
diff --git a/compiler/saptran.lisp b/compiler/saptran.lisp
deleted file mode 100644
index aa4215218c71efdc535a8f219269fe81bfd7ee6f..0000000000000000000000000000000000000000
--- a/compiler/saptran.lisp
+++ /dev/null
@@ -1,129 +0,0 @@
-;;; -*- Log: C.Log; Package: C -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/saptran.lisp,v 1.3 1992/12/18 20:40:22 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains some magic hacks for optimizing SAP operations.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "C")
-
-
-
-;;;; Defknowns
-
-    
-(defknown foreign-symbol-address (simple-string) system-area-pointer
-  (movable flushable))
-
-(defknown (sap< sap<= sap= sap>= sap>)
-	  (system-area-pointer system-area-pointer) boolean
-  (movable flushable))
-
-(defknown sap+ (system-area-pointer integer) system-area-pointer
-  (movable flushable))
-(defknown sap- (system-area-pointer system-area-pointer) (signed-byte 32)
-  (movable flushable))
-
-(defknown sap-int (system-area-pointer) (unsigned-byte 32) (movable flushable))
-(defknown int-sap ((unsigned-byte 32)) system-area-pointer (movable))
-
-
-(defknown sap-ref-8 (system-area-pointer index) (unsigned-byte 8)
-  (flushable))
-(defknown %set-sap-ref-8 (system-area-pointer index (unsigned-byte 8))
-  (unsigned-byte 8)
-  ())
-
-(defknown sap-ref-16 (system-area-pointer index) (unsigned-byte 16)
-  (flushable))
-(defknown %set-sap-ref-16 (system-area-pointer index (unsigned-byte 16))
-  (unsigned-byte 16)
-  ())
-
-(defknown sap-ref-32 (system-area-pointer index) (unsigned-byte 32)
-  (flushable))
-(defknown %set-sap-ref-32 (system-area-pointer index (unsigned-byte 32))
-  (unsigned-byte 32)
-  ())
-
-
-(defknown signed-sap-ref-8 (system-area-pointer index) (signed-byte 8)
-  (flushable))
-(defknown %set-signed-sap-ref-8 (system-area-pointer index (signed-byte 8))
-  (signed-byte 8)
-  ())
-
-(defknown signed-sap-ref-16 (system-area-pointer index) (signed-byte 16)
-  (flushable))
-(defknown %set-signed-sap-ref-16 (system-area-pointer index (signed-byte 16))
-  (signed-byte 16)
-  ())
-
-(defknown signed-sap-ref-32 (system-area-pointer index) (signed-byte 32)
-  (flushable))
-(defknown %set-signed-sap-ref-32 (system-area-pointer index (signed-byte 32))
-  (signed-byte 32)
-  ())
-
-
-(defknown sap-ref-sap (system-area-pointer index) system-area-pointer
-  (flushable))
-(defknown %set-sap-ref-sap (system-area-pointer index system-area-pointer)
-  system-area-pointer
-  ())
-
-(defknown sap-ref-single (system-area-pointer index) single-float
-  (flushable))
-(defknown sap-ref-double (system-area-pointer index) double-float
-  (flushable))
-
-(defknown %set-sap-ref-single
-	  (system-area-pointer index single-float) single-float
-  ())
-(defknown %set-sap-ref-double
-	  (system-area-pointer index double-float) double-float
-  ())
-
-
-;;;; Transforms for converting sap relation operators.
-
-(dolist (info '((sap< <) (sap<= <=) (sap= =) (sap>= >=) (sap> >)))
-  (destructuring-bind (sap-fun int-fun) info
-    (deftransform sap-fun ((x y) '* '* :eval-name t)
-      `(,int-fun (sap-int x) (sap-int y)))))
-
-
-;;;; Transforms for optimizing sap+
-
-(deftransform sap+ ((sap offset))
-  (cond ((and (constant-continuation-p offset)
-	      (eql (continuation-value offset) 0))
-	 'sap)
-	(t
-	 (extract-function-args sap 'sap+ 2)
-	 '(lambda (sap offset1 offset2)
-	    (sap+ sap (+ offset1 offset2))))))
-
-(dolist (fun '(sap-ref-8 %set-sap-ref-8
-	       signed-sap-ref-8 %set-signed-sap-ref-8
-	       sap-ref-16 %set-sap-ref-16
-	       signed-sap-ref-16 %set-signed-sap-ref-16
-	       sap-ref-32 %set-sap-ref-32
-	       signed-sap-ref-32 %set-signed-sap-ref-32
-	       sap-ref-sap %set-sap-ref-sap
-	       sap-ref-single %set-sap-ref-single
-	       sap-ref-double %set-sap-ref-double))
-  (deftransform fun ((sap offset) '* '* :eval-name t)
-    (extract-function-args sap 'sap+ 2)
-    `(lambda (sap offset1 offset2)
-       (,fun sap (+ offset1 offset2)))))
diff --git a/compiler/seqtran.lisp b/compiler/seqtran.lisp
deleted file mode 100644
index bd1b9f7cb4cac5560aba29dae4b0f0029c2472fa..0000000000000000000000000000000000000000
--- a/compiler/seqtran.lisp
+++ /dev/null
@@ -1,470 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.16 1992/08/05 00:36:42 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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) ((simple-array * (*)) *))
-  '(aref s i))
-
-(deftransform elt ((s i) (list *))
-  '(nth i s))
-
-(deftransform %setelt ((s i v) ((simple-array * (*)) * *))
-  '(%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))
-    
-    (labels ((frob (els)
-	       (if els
-		   `(if (funcall test e ',(car els))
-			',els
-			,(frob (cdr els)))
-		   'nil)))
-      (frob val))))
-
-;;; Names of predicates that compute the same value as CHAR= when applied to
-;;; characters.
-;;; 
-(defconstant char=-functions '(eql equal char=))
-
-
-(deftransform search ((string1 string2 &key (start1 0) end1 (start2 0) end2
-			       test)
-		      (simple-string simple-string &rest t))
-  (unless (or (not test)
-	      (continuation-function-is test char=-functions))
-    (give-up))
-  '(lisp::%sp-string-search string1 start1 (or end1 (length string1))
-			    string2 start2 (or end2 (length string2))))
-			      
-(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 'character)
-	(,(if (constant-value-or-lose from-end)
-	      'lisp::%sp-reverse-find-character
-	      'lisp::%sp-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.
-;;;
-(dolist (stuff '((string< string<*)
-		 (string> string>*)
-		 (string<= string<=*)
-		 (string>= string>=*)
-		 (string= string=*)
-		 (string/= string/=*)))
-  (destructuring-bind (fun pred*) stuff
-    (deftransform fun ((string1 string2 &key (start1 0) end1
-				(start2 0) end2)
-		       '* '* :eval-name t)
-      `(,pred* string1 string2 start1 end1 start2 end2))))
-
-
-;;; STRING-xxx* transform  --  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.
-;;;
-(dolist (stuff '((string<* t nil)
-		 (string<=* t t)
-		 (string>* nil nil)
-		 (string>=* nil t)))
-  (destructuring-bind (name lessp equalp) stuff
-    (deftransform name ((string1 string2 start1 end1 start2 end2)
-			'(simple-string simple-string t t t t) '*
-			:eval-name t)
-      `(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))))))
-
-
-(dolist (stuff '((string=* not)
-		 (string/=* identity)))
-  (destructuring-bind (name result-fun) stuff
-    (deftransform name ((string1 string2 start1 end1 start2 end2)
-			'(simple-string simple-string t t t t) '*
-			:eval-name t)
-      `(,result-fun
-	(lisp::%sp-string-compare
-	 string1 start1 (or end1 (length string1))
-	 string2 start2 (or end2 (length string2)))))))
diff --git a/compiler/sparc/alloc.lisp b/compiler/sparc/alloc.lisp
deleted file mode 100644
index 703cc6036dc5f58b06b9379de87afe07290f6cee..0000000000000000000000000000000000000000
--- a/compiler/sparc/alloc.lisp
+++ /dev/null
@@ -1,192 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/alloc.lisp,v 1.9 1992/12/17 08:59:51 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Allocation VOPs for the SPARC port.
-;;;
-;;; Written by William Lott.
-;;; 
-
-(in-package "SPARC")
-
-
-;;;; LIST and LIST*
-
-(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)
-  (: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
-	       ((maybe-load (tn)
-		  (once-only ((tn tn))
-		    `(sc-case ,tn
-		       ((any-reg descriptor-reg zero null)
-			,tn)
-		       (control-stack
-			(load-stack-tn temp ,tn)
-			temp)))))
-	     (let* ((cons-cells (if star (1- num) num))
-		    (alloc (* (pad-data-block cons-size) cons-cells)))
-	       (pseudo-atomic (:extra alloc)
-		 (inst andn res alloc-tn lowtag-mask)
-		 (inst or res list-pointer-type)
-		 (move ptr res)
-		 (dotimes (i (1- cons-cells))
-		   (storew (maybe-load (tn-ref-tn things)) ptr
-			   cons-car-slot list-pointer-type)
-		   (setf things (tn-ref-across things))
-		   (inst add ptr ptr (pad-data-block cons-size))
-		   (storew ptr ptr
-			   (- cons-cdr-slot cons-size)
-			   list-pointer-type))
-		 (storew (maybe-load (tn-ref-tn things)) ptr
-			 cons-car-slot list-pointer-type)
-		 (storew (if star
-			     (maybe-load (tn-ref-tn (tn-ref-across things)))
-			     null-tn)
-			 ptr cons-cdr-slot list-pointer-type))
-	       (move result res)))))))
-
-(define-vop (list list-or-list*)
-  (:variant nil))
-
-(define-vop (list* list-or-list*)
-  (:variant t))
-
-
-;;;; Special purpose inline allocators.
-
-(define-vop (allocate-code-object)
-  (:args (boxed-arg :scs (any-reg))
-	 (unboxed-arg :scs (any-reg)))
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
-  (:generator 100
-    (inst add boxed boxed-arg (fixnum (1+ code-trace-table-offset-slot)))
-    (inst and boxed (lognot lowtag-mask))
-    (inst srl unboxed unboxed-arg word-shift)
-    (inst add unboxed lowtag-mask)
-    (inst and unboxed (lognot lowtag-mask))
-    (pseudo-atomic ()
-      ;; Note: we don't have to subtract off the 4 that was added by
-      ;; pseudo-atomic, because oring in other-pointer-type just adds
-      ;; it right back.
-      (inst or result alloc-tn other-pointer-type)
-      (inst add alloc-tn boxed)
-      (inst add alloc-tn unboxed)
-      (inst sll ndescr boxed (- type-bits word-shift))
-      (inst or ndescr code-header-type)
-      (storew ndescr result 0 other-pointer-type)
-      (storew unboxed result code-code-size-slot other-pointer-type)
-      (storew null-tn result code-entry-points-slot other-pointer-type)
-      (storew null-tn result code-debug-info-slot other-pointer-type))))
-
-(define-vop (make-fdefn)
-  (:args (name :scs (descriptor-reg) :to :eval))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:results (result :scs (descriptor-reg) :from :argument))
-  (:policy :fast-safe)
-  (:translate make-fdefn)
-  (:generator 37
-    (with-fixed-allocation (result temp fdefn-type fdefn-size)
-      (inst li temp (make-fixup "_undefined_tramp" :foreign))
-      (storew name result fdefn-name-slot other-pointer-type)
-      (storew null-tn result fdefn-function-slot other-pointer-type)
-      (storew temp result fdefn-raw-addr-slot other-pointer-type))))
-
-
-(define-vop (make-closure)
-  (:args (function :to :save :scs (descriptor-reg)))
-  (:info length)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 10
-    (let ((size (+ length closure-info-offset)))
-      (pseudo-atomic (:extra (pad-data-block size))
-	(inst andn result alloc-tn lowtag-mask)
-	(inst or result function-pointer-type)
-	(inst li temp (logior (ash (1- size) type-bits) closure-header-type))
-	(storew temp result 0 function-pointer-type)))
-    (storew function result closure-function-slot function-pointer-type)))
-
-;;; The compiler likes to be able to directly make value cells.
-;;; 
-(define-vop (make-value-cell)
-  (:args (value :to :save :scs (descriptor-reg any-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 10
-    (with-fixed-allocation
-	(result temp value-cell-header-type value-cell-size))
-    (storew value result value-cell-value-slot other-pointer-type)))
-
-
-
-;;;; Automatic allocators for primitive objects.
-
-(define-vop (make-unbound-marker)
-  (:args)
-  (:results (result :scs (any-reg)))
-  (:generator 1
-    (inst li result unbound-marker-type)))
-
-(define-vop (fixed-alloc)
-  (:args)
-  (:info name words type lowtag)
-  (:ignore name)
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 4
-    (pseudo-atomic (:extra (pad-data-block words))
-      (cond ((logbitp 2 lowtag)
-	     (inst or result alloc-tn lowtag))
-	    (t
-	     (inst andn result alloc-tn lowtag-mask)
-	     (inst or result lowtag)))
-      (when type
-	(inst li temp (logior (ash (1- words) type-bits) type))
-	(storew temp result 0 lowtag)))))
-
-(define-vop (var-alloc)
-  (:args (extra :scs (any-reg)))
-  (:arg-types positive-fixnum)
-  (:info name words type lowtag)
-  (:ignore name)
-  (:results (result :scs (descriptor-reg)))
-  (:temporary (:scs (any-reg)) bytes header)
-  (:generator 6
-    (inst add bytes extra (* (1+ words) word-bytes))
-    (inst sll header bytes (- type-bits 2))
-    (inst add header header (+ (ash -2 type-bits) type))
-    (inst and bytes (lognot lowtag-mask))
-    (pseudo-atomic ()
-      (cond ((logbitp 2 lowtag)
-	     (inst or result alloc-tn lowtag))
-	    (t
-	     (inst andn result alloc-tn lowtag-mask)
-	     (inst or result lowtag)))
-      (storew header result 0 lowtag)
-      (inst add alloc-tn alloc-tn bytes))))
diff --git a/compiler/sparc/arith.lisp b/compiler/sparc/arith.lisp
deleted file mode 100644
index cd525e1594a29b2d72f4a07b2096f1ce8f16d7c0..0000000000000000000000000000000000000000
--- a/compiler/sparc/arith.lisp
+++ /dev/null
@@ -1,774 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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/sparc/arith.lisp,v 1.9 1992/08/02 20:17:04 wlott Exp $
-;;;
-;;;    This file contains the VM definition arithmetic VOPs for the MIPS.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by William Lott.
-;;; 
-
-(in-package "SPARC")
-
-
-
-;;;; Unary operations.
-
-(define-vop (fast-safe-arith-op)
-  (:policy :fast-safe)
-  (:effects)
-  (:affected))
-
-
-(define-vop (fixnum-unop fast-safe-arith-op)
-  (:args (x :scs (any-reg)))
-  (:results (res :scs (any-reg)))
-  (:note "inline fixnum arithmetic")
-  (:arg-types tagged-num)
-  (:result-types tagged-num))
-
-(define-vop (signed-unop fast-safe-arith-op)
-  (:args (x :scs (signed-reg)))
-  (:results (res :scs (signed-reg)))
-  (:note "inline (signed-byte 32) arithmetic")
-  (:arg-types signed-num)
-  (:result-types signed-num))
-
-(define-vop (fast-negate/fixnum fixnum-unop)
-  (:translate %negate)
-  (:generator 1
-    (inst neg res x)))
-
-(define-vop (fast-negate/signed signed-unop)
-  (:translate %negate)
-  (:generator 2
-    (inst neg res x)))
-
-(define-vop (fast-lognot/fixnum fixnum-unop)
-  (:translate lognot)
-  (:generator 2
-    (inst xor res x (fixnum -1))))
-
-(define-vop (fast-lognot/signed signed-unop)
-  (:translate lognot)
-  (:generator 1
-    (inst not res x)))
-
-
-
-;;;; Binary fixnum operations.
-
-;;; Assume that any constant operand is the second arg...
-
-(define-vop (fast-fixnum-binop fast-safe-arith-op)
-  (:args (x :target r :scs (any-reg zero))
-	 (y :target r :scs (any-reg zero)))
-  (:arg-types tagged-num tagged-num)
-  (:results (r :scs (any-reg)))
-  (:result-types tagged-num)
-  (:note "inline fixnum arithmetic"))
-
-(define-vop (fast-unsigned-binop fast-safe-arith-op)
-  (:args (x :target r :scs (unsigned-reg zero))
-	 (y :target r :scs (unsigned-reg zero)))
-  (:arg-types unsigned-num unsigned-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:note "inline (unsigned-byte 32) arithmetic"))
-
-(define-vop (fast-signed-binop fast-safe-arith-op)
-  (:args (x :target r :scs (signed-reg zero))
-	 (y :target r :scs (signed-reg zero)))
-  (:arg-types signed-num signed-num)
-  (:results (r :scs (signed-reg)))
-  (:result-types signed-num)
-  (:note "inline (signed-byte 32) arithmetic"))
-
-
-(define-vop (fast-fixnum-binop-c fast-safe-arith-op)
-  (:args (x :target r :scs (any-reg zero)))
-  (:info y)
-  (:arg-types tagged-num
-	      (:constant (and (signed-byte 11) (not (integer 0 0)))))
-  (:results (r :scs (any-reg)))
-  (:result-types tagged-num)
-  (:note "inline fixnum arithmetic"))
-
-(define-vop (fast-unsigned-binop-c fast-safe-arith-op)
-  (:args (x :target r :scs (unsigned-reg zero)))
-  (:info y)
-  (:arg-types unsigned-num
-	      (:constant (and (signed-byte 13) (not (integer 0 0)))))
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:note "inline (unsigned-byte 32) arithmetic"))
-
-(define-vop (fast-signed-binop-c fast-safe-arith-op)
-  (:args (x :target r :scs (signed-reg zero)))
-  (:info y)
-  (:arg-types signed-num
-	      (:constant (and (signed-byte 13) (not (integer 0 0)))))
-  (:results (r :scs (signed-reg)))
-  (:result-types signed-num)
-  (:note "inline (signed-byte 32) arithmetic"))
-
-
-(eval-when (compile load eval)
-
-(defmacro define-binop (translate untagged-penalty op)
-  `(progn
-     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
-		  fast-fixnum-binop)
-       (:translate ,translate)
-       (:generator 2
-	 (inst ,op r x y)))
-     (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
-		  fast-fixnum-binop-c)
-       (:translate ,translate)
-       (:generator 1
-	 (inst ,op r x (fixnum y))))
-     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
-		  fast-signed-binop)
-       (:translate ,translate)
-       (:generator ,(1+ untagged-penalty)
-	 (inst ,op r x y)))
-     (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
-		  fast-signed-binop-c)
-       (:translate ,translate)
-       (:generator ,untagged-penalty
-	 (inst ,op r x y)))
-     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
-		  fast-unsigned-binop)
-       (:translate ,translate)
-       (:generator ,(1+ untagged-penalty)
-	 (inst ,op r x y)))
-     (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
-		  fast-unsigned-binop-c)
-       (:translate ,translate)
-       (:generator ,untagged-penalty
-	 (inst ,op r x y)))))
-
-); eval-when
-
-(define-binop + 4 add)
-(define-binop - 4 sub)
-(define-binop logand 2 and)
-(define-binop logandc2 2 andn)
-(define-binop logior 2 or)
-(define-binop logorc2 2 orn)
-(define-binop logxor 2 xor)
-(define-binop logeqv 2 xnor)
-
-;;; Special case fixnum + and - that trap on overflow.  Useful when we
-;;; don't know that the output type is a fixnum.
-
-(define-vop (+/fixnum fast-+/fixnum=>fixnum)
-  (:policy :safe)
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:result-types tagged-num)
-  (:note "safe inline fixnum arithmetic")
-  (:generator 4
-    (inst taddcctv r x y)))
-
-(define-vop (+-c/fixnum fast-+-c/fixnum=>fixnum)
-  (:policy :safe)
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:result-types tagged-num)
-  (:note "safe inline fixnum arithmetic")
-  (:generator 3
-    (inst taddcctv r x (fixnum y))))
-
-(define-vop (-/fixnum fast--/fixnum=>fixnum)
-  (:policy :safe)
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:result-types tagged-num)
-  (:note "safe inline fixnum arithmetic")
-  (:generator 4
-    (inst tsubcctv r x y)))
-
-(define-vop (--c/fixnum fast---c/fixnum=>fixnum)
-  (:policy :safe)
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:result-types tagged-num)
-  (:note "safe inline fixnum arithmetic")
-  (:generator 3
-    (inst tsubcctv r x (fixnum y))))
-
-;;; Shifting
-
-(define-vop (fast-ash)
-  (:note "inline ASH")
-  (:args (number :scs (signed-reg unsigned-reg) :to :save)
-	 (amount :scs (signed-reg immediate)))
-  (:arg-types (:or signed-num unsigned-num) signed-num)
-  (:results (result :scs (signed-reg unsigned-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:translate ash)
-  (:policy :fast-safe)
-  (:temporary (:sc non-descriptor-reg) ndesc)
-  (:generator 3
-    (sc-case amount
-      (signed-reg
-       (let ((positive (gen-label))
-	     (done (gen-label)))
-	 (inst cmp amount)
-	 (inst b :ge positive)
-	 (inst neg ndesc amount)
-	 (inst cmp ndesc 31)
-	 (inst b :le done)
-	 (sc-case number
-	   (signed-reg (inst sra result number ndesc))
-	   (unsigned-reg (inst srl result number ndesc)))
-	 (inst b done)
-	 (sc-case number
-	   (signed-reg (inst sra result number 31))
-	   (unsigned-reg (inst srl result number 31)))
-
-	 (emit-label positive)
-	 ;; The result-type assures us that this shift will not overflow.
-	 (inst sll result number amount)
-
-	 (emit-label done)))
-
-      (immediate
-       (let ((amount (tn-value amount)))
-	 (if (minusp amount)
-	     (let ((amount (min 31 (- amount))))
-	       (sc-case number
-		 (unsigned-reg
-		  (inst srl result number amount))
-		 (signed-reg
-		  (inst sra result number amount))))
-	     (inst sll result number amount)))))))
-
-
-
-(define-vop (signed-byte-32-len)
-  (:translate integer-length)
-  (:note "inline (signed-byte 32) integer-length")
-  (:policy :fast-safe)
-  (:args (arg :scs (signed-reg) :target shift))
-  (:arg-types signed-num)
-  (:results (res :scs (any-reg)))
-  (:result-types positive-fixnum)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
-  (:generator 30
-    (let ((loop (gen-label))
-	  (test (gen-label)))
-      (inst addcc shift zero-tn arg)
-      (inst b :ge test)
-      (move res zero-tn)
-      (inst b test)
-      (inst not shift)
-
-      (emit-label loop)
-      (inst add res (fixnum 1))
-      
-      (emit-label test)
-      (inst cmp shift)
-      (inst b :ne loop)
-      (inst srl shift 1))))
-
-(define-vop (unsigned-byte-32-count)
-  (:translate logcount)
-  (:note "inline (unsigned-byte 32) logcount")
-  (:policy :fast-safe)
-  (:args (arg :scs (unsigned-reg) :target shift))
-  (:arg-types unsigned-num)
-  (:results (res :scs (any-reg)))
-  (:result-types positive-fixnum)
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift temp)
-  (:generator 30
-    (let ((loop (gen-label))
-	  (done (gen-label)))
-      (inst addcc shift zero-tn arg)
-      (inst b :eq done)
-      (move res zero-tn)
-
-      (emit-label loop)
-      (inst sub temp shift 1)
-      (inst andcc shift temp)
-      (inst b :ne loop)
-      (inst add res (fixnum 1))
-
-      (emit-label done))))
-
-
-;;;; Binary conditional VOPs:
-
-(define-vop (fast-conditional)
-  (:conditional)
-  (:info target not-p)
-  (:effects)
-  (:affected)
-  (:policy :fast-safe))
-
-(deftype integer-with-a-bite-out (s bite)
-  (cond ((eq s '*) 'integer)
-	((and (integerp s) (> s 1))
-	 (let ((bound (ash 1 (1- s))))
-	   `(integer ,(- bound) ,(- bound bite 1))))
-	(t
-	 (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
-
-(define-vop (fast-conditional/fixnum fast-conditional)
-  (:args (x :scs (any-reg zero))
-	 (y :scs (any-reg zero)))
-  (:arg-types tagged-num tagged-num)
-  (:note "inline fixnum comparison"))
-
-(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
-  (:args (x :scs (any-reg zero)))
-  (:arg-types tagged-num (:constant (signed-byte 11)))
-  (:info target not-p y))
-
-(define-vop (fast-conditional/signed fast-conditional)
-  (:args (x :scs (signed-reg zero))
-	 (y :scs (signed-reg zero)))
-  (:arg-types signed-num signed-num)
-  (:note "inline (signed-byte 32) comparison"))
-
-(define-vop (fast-conditional-c/signed fast-conditional/signed)
-  (:args (x :scs (signed-reg zero)))
-  (:arg-types signed-num (:constant (signed-byte 13)))
-  (:info target not-p y))
-
-(define-vop (fast-conditional/unsigned fast-conditional)
-  (:args (x :scs (unsigned-reg zero))
-	 (y :scs (unsigned-reg zero)))
-  (:arg-types unsigned-num unsigned-num)
-  (:note "inline (unsigned-byte 32) comparison"))
-
-(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
-  (:args (x :scs (unsigned-reg zero)))
-  (:arg-types unsigned-num (:constant (unsigned-byte 12)))
-  (:info target not-p y))
-
-
-(defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned)
-  `(progn
-     ,@(mapcar #'(lambda (suffix cost signed)
-		   (unless (and (member suffix '(/fixnum -c/fixnum))
-				(eq tran 'eql))
-		     `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
-						    tran suffix))
-				   ,(intern
-				     (format nil "~:@(FAST-CONDITIONAL~A~)"
-					     suffix)))
-			(:translate ,tran)
-			(:generator ,cost
-			  (inst cmp x
-				,(if (eq suffix '-c/fixnum) '(fixnum y) 'y))
-			  (inst b (if not-p
-				      ,(if signed not-cond not-unsigned)
-				      ,(if signed cond unsigned))
-				target)
-			  (inst nop)))))
-	       '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
-	       '(4 3 6 5 6 5)
-	       '(t t t t nil nil))))
-
-(define-conditional-vop < :lt :ltu :ge :geu)
-
-(define-conditional-vop > :gt :gtu :le :leu)
-
-(define-conditional-vop eql :eq :eq :ne :ne)
-
-;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
-;;; known fixnum.
-
-;;; These versions specify a fixnum restriction on their first arg.  We have
-;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
-;;; the first arg and a higher cost.  The reason for doing this is to prevent
-;;; fixnum specific operations from being used on word integers, spuriously
-;;; consing the argument.
-;;;
-
-(define-vop (fast-eql/fixnum fast-conditional)
-  (:args (x :scs (any-reg descriptor-reg zero))
-	 (y :scs (any-reg zero)))
-  (:arg-types tagged-num tagged-num)
-  (:note "inline fixnum comparison")
-  (:translate eql)
-  (:generator 4
-    (inst cmp x y)
-    (inst b (if not-p :ne :eq) target)
-    (inst nop)))
-;;;
-(define-vop (generic-eql/fixnum fast-eql/fixnum)
-  (:arg-types * tagged-num)
-  (:variant-cost 7))
-
-(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
-  (:args (x :scs (any-reg descriptor-reg zero)))
-  (:arg-types tagged-num (:constant (signed-byte 11)))
-  (:info target not-p y)
-  (:translate eql)
-  (:generator 2
-    (inst cmp x (fixnum y))
-    (inst b (if not-p :ne :eq) target)
-    (inst nop)))
-;;;
-(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
-  (:arg-types * (:constant (signed-byte 11)))
-  (:variant-cost 6))
-
-
-;;;; 32-bit logical operations
-
-(define-vop (merge-bits)
-  (:translate merge-bits)
-  (:args (shift :scs (signed-reg unsigned-reg))
-	 (prev :scs (unsigned-reg))
-	 (next :scs (unsigned-reg)))
-  (:arg-types tagged-num unsigned-num unsigned-num)
-  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
-  (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:policy :fast-safe)
-  (:generator 4
-    (let ((done (gen-label)))
-      (inst cmp shift)
-      (inst b :eq done)
-      (inst srl res next shift)
-      (inst sub temp zero-tn shift)
-      (inst sll temp prev temp)
-      (inst or res temp)
-      (emit-label done)
-      (move result res))))
-
-
-(define-vop (32bit-logical)
-  (:args (x :scs (unsigned-reg zero))
-	 (y :scs (unsigned-reg zero)))
-  (:arg-types unsigned-num unsigned-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:policy :fast-safe))
-
-(define-vop (32bit-logical-not 32bit-logical)
-  (:translate 32bit-logical-not)
-  (:args (x :scs (unsigned-reg zero)))
-  (:arg-types unsigned-num)
-  (:generator 1
-    (inst not r x)))
-
-(define-vop (32bit-logical-and 32bit-logical)
-  (:translate 32bit-logical-and)
-  (:generator 1
-    (inst and r x y)))
-
-(deftransform 32bit-logical-nand ((x y) (* *))
-  '(32bit-logical-not (32bit-logical-and x y)))
-
-(define-vop (32bit-logical-or 32bit-logical)
-  (:translate 32bit-logical-or)
-  (:generator 1
-    (inst or r x y)))
-
-(deftransform 32bit-logical-nor ((x y) (* *))
-  '(32bit-logical-not (32bit-logical-or x y)))
-
-(define-vop (32bit-logical-xor 32bit-logical)
-  (:translate 32bit-logical-xor)
-  (:generator 1
-    (inst xor r x y)))
-
-(define-vop (32bit-logical-eqv 32bit-logical)
-  (:translate 32bit-logical-eqv)
-  (:generator 1
-    (inst xnor r x y)))
-
-(define-vop (32bit-logical-orc2 32bit-logical)
-  (:translate 32bit-logical-orc2)
-  (:generator 1
-    (inst orn r x y)))
-
-(deftransform 32bit-logical-orc1 ((x y) (* *))
-  '(32bit-logical-orc2 y x))
-
-(define-vop (32bit-logical-andc2 32bit-logical)
-  (:translate 32bit-logical-andc2)
-  (:generator 1
-    (inst andn r x y)))
-
-(deftransform 32bit-logical-andc1 ((x y) (* *))
-  '(32bit-logical-andc2 y x))
-
-
-(define-vop (shift-towards-someplace)
-  (:policy :fast-safe)
-  (:args (num :scs (unsigned-reg))
-	 (amount :scs (signed-reg)))
-  (:arg-types unsigned-num tagged-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num))
-
-(define-vop (shift-towards-start shift-towards-someplace)
-  (:translate shift-towards-start)
-  (:note "shift-towards-start")
-  (:generator 1
-    (inst sll r num amount)))
-
-(define-vop (shift-towards-end shift-towards-someplace)
-  (:translate shift-towards-end)
-  (:note "shift-towards-end")
-  (:generator 1
-    (inst srl r num amount)))
-
-
-
-
-;;;; Bignum stuff.
-
-(define-vop (bignum-length get-header-data)
-  (:translate bignum::%bignum-length)
-  (:policy :fast-safe))
-
-(define-vop (bignum-set-length set-header-data)
-  (:translate bignum::%bignum-set-length)
-  (:policy :fast-safe))
-
-(define-vop (bignum-ref word-index-ref)
-  (:variant vm:bignum-digits-offset vm:other-pointer-type)
-  (:translate bignum::%bignum-ref)
-  (:results (value :scs (unsigned-reg)))
-  (:result-types unsigned-num))
-
-(define-vop (bignum-set word-index-set)
-  (:variant vm:bignum-digits-offset vm:other-pointer-type)
-  (:translate bignum::%bignum-set)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg immediate zero))
-	 (value :scs (unsigned-reg)))
-  (:arg-types t positive-fixnum unsigned-num)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num))
-
-(define-vop (digit-0-or-plus)
-  (:translate bignum::%digit-0-or-plusp)
-  (:policy :fast-safe)
-  (:args (digit :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 3
-    (let ((done (gen-label)))
-      (inst cmp digit)
-      (inst b :lt done)
-      (move result null-tn)
-      (load-symbol result t)
-      (emit-label done))))
-
-(define-vop (add-w/carry)
-  (:translate bignum::%add-with-carry)
-  (:policy :fast-safe)
-  (:args (a :scs (unsigned-reg))
-	 (b :scs (unsigned-reg))
-	 (c :scs (any-reg)))
-  (:arg-types unsigned-num unsigned-num positive-fixnum)
-  (:results (result :scs (unsigned-reg))
-	    (carry :scs (unsigned-reg)))
-  (:result-types unsigned-num positive-fixnum)
-  (:generator 3
-    (inst addcc zero-tn c -1)
-    (inst addxcc result a b)
-    (inst addx carry zero-tn zero-tn)))
-
-(define-vop (sub-w/borrow)
-  (:translate bignum::%subtract-with-borrow)
-  (:policy :fast-safe)
-  (:args (a :scs (unsigned-reg))
-	 (b :scs (unsigned-reg))
-	 (c :scs (any-reg)))
-  (:arg-types unsigned-num unsigned-num positive-fixnum)
-  (:results (result :scs (unsigned-reg))
-	    (borrow :scs (unsigned-reg)))
-  (:result-types unsigned-num positive-fixnum)
-  (:generator 4
-    (inst subcc zero-tn c 1)
-    (inst subxcc result a b)
-    (inst addx borrow zero-tn zero-tn)
-    (inst xor borrow 1)))
-
-;;; EMIT-MULTIPLY -- This is used both for bignum stuff and in assembly
-;;; routines.
-;;; 
-(defun emit-multiply (multiplier multiplicand result-high result-low)
-  "Emit code to multiply MULTIPLIER with MULTIPLICAND, putting the result
-  in RESULT-HIGH and RESULT-LOW.  KIND is either :signed or :unsigned.
-  Note: the lifetimes of MULTIPLICAND and RESULT-HIGH overlap."
-  (declare (type tn multiplier result-high result-low)
-	   (type (or tn (signed-byte 13)) multiplicand))
-  (let ((label (gen-label)))
-    (inst wry multiplier)
-    (inst andcc result-high zero-tn)
-    ;; Note: we can't use the Y register until three insts after it's written.
-    (inst nop)
-    (inst nop)
-    (dotimes (i 32)
-      (inst mulscc result-high multiplicand))
-    (inst mulscc result-high zero-tn)
-    (inst cmp multiplicand)
-    (inst b :ge label)
-    (inst nop)
-    (inst add result-high multiplier)
-    (emit-label label)
-    (inst rdy result-low)))
-
-(define-vop (bignum-mult-and-add-3-arg)
-  (:translate bignum::%multiply-and-add)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg) :to (:eval 1))
-	 (y :scs (unsigned-reg) :to (:eval 1))
-	 (carry-in :scs (unsigned-reg) :to (:eval 2)))
-  (:arg-types unsigned-num unsigned-num unsigned-num)
-  (:results (hi :scs (unsigned-reg) :from (:eval 0))
-	    (lo :scs (unsigned-reg) :from (:eval 1)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 40
-    (emit-multiply x y hi lo)
-    (inst addcc lo carry-in)
-    (inst addx hi zero-tn)))
-
-(define-vop (bignum-mult-and-add-4-arg)
-  (:translate bignum::%multiply-and-add)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg) :to (:eval 1))
-	 (y :scs (unsigned-reg) :to (:eval 1))
-	 (prev :scs (unsigned-reg) :to (:eval 2))
-	 (carry-in :scs (unsigned-reg) :to (:eval 2)))
-  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
-  (:results (hi :scs (unsigned-reg) :from (:eval 0))
-	    (lo :scs (unsigned-reg) :from (:eval 1)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 40
-    (emit-multiply x y hi lo)
-    (inst addcc lo carry-in)
-    (inst addx hi zero-tn)
-    (inst addcc lo prev)
-    (inst addx hi zero-tn)))
-
-(define-vop (bignum-mult)
-  (:translate bignum::%multiply)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg) :to (:result 1))
-	 (y :scs (unsigned-reg) :to (:result 1)))
-  (:arg-types unsigned-num unsigned-num)
-  (:results (hi :scs (unsigned-reg))
-	    (lo :scs (unsigned-reg)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 40
-    (emit-multiply x y hi lo)))
-
-(define-vop (bignum-lognot)
-  (:translate bignum::%lognot)
-  (:policy :fast-safe)
-  (:args (x :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (inst not r x)))
-
-(define-vop (fixnum-to-digit)
-  (:translate bignum::%fixnum-to-digit)
-  (:policy :fast-safe)
-  (:args (fixnum :scs (any-reg)))
-  (:arg-types tagged-num)
-  (:results (digit :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (inst sra digit fixnum 2)))
-
-(define-vop (bignum-floor)
-  (:translate bignum::%floor)
-  (:policy :fast-safe)
-  (:args (div-high :scs (unsigned-reg) :target rem)
-	 (div-low :scs (unsigned-reg) :target quo)
-	 (divisor :scs (unsigned-reg)))
-  (:arg-types unsigned-num unsigned-num unsigned-num)
-  (:results (quo :scs (unsigned-reg) :from (:argument 1))
-	    (rem :scs (unsigned-reg) :from (:argument 0)))
-  (:result-types unsigned-num unsigned-num)
-  (:generator 300
-    (move rem div-high)
-    (move quo div-low)
-    (dotimes (i 33)
-      (let ((label (gen-label)))
-	(inst cmp rem divisor)
-	(inst b :ltu label)
-	(inst addxcc quo quo)
-	(inst sub rem divisor)
-	(emit-label label)
-	(unless (= i 32)
-	  (inst addx rem rem))))
-    (inst not quo)))
-
-(define-vop (signify-digit)
-  (:translate bignum::%fixnum-digit-with-correct-sign)
-  (:policy :fast-safe)
-  (:args (digit :scs (unsigned-reg) :target res))
-  (:arg-types unsigned-num)
-  (:results (res :scs (any-reg signed-reg)))
-  (:result-types signed-num)
-  (:generator 1
-    (sc-case res
-      (any-reg
-       (inst sll res digit 2))
-      (signed-reg
-       (move res digit)))))
-
-
-(define-vop (digit-ashr)
-  (:translate bignum::%ashr)
-  (:policy :fast-safe)
-  (:args (digit :scs (unsigned-reg))
-	 (count :scs (unsigned-reg)))
-  (:arg-types unsigned-num positive-fixnum)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (inst sra result digit count)))
-
-(define-vop (digit-lshr digit-ashr)
-  (:translate bignum::%digit-logical-shift-right)
-  (:generator 1
-    (inst srl result digit count)))
-
-(define-vop (digit-ashl digit-ashr)
-  (:translate bignum::%ashl)
-  (:generator 1
-    (inst sll result digit count)))
-
-
-;;;; Static functions.
-
-(define-static-function two-arg-gcd (x y) :translate gcd)
-(define-static-function two-arg-lcm (x y) :translate lcm)
-
-(define-static-function two-arg-+ (x y) :translate +)
-(define-static-function two-arg-- (x y) :translate -)
-(define-static-function two-arg-* (x y) :translate *)
-(define-static-function two-arg-/ (x y) :translate /)
-
-(define-static-function two-arg-< (x y) :translate <)
-(define-static-function two-arg-<= (x y) :translate <=)
-(define-static-function two-arg-> (x y) :translate >)
-(define-static-function two-arg->= (x y) :translate >=)
-(define-static-function two-arg-= (x y) :translate =)
-(define-static-function two-arg-/= (x y) :translate /=)
-
-(define-static-function %negate (x) :translate %negate)
-
-(define-static-function two-arg-and (x y) :translate logand)
-(define-static-function two-arg-ior (x y) :translate logior)
-(define-static-function two-arg-xor (x y) :translate logxor)
diff --git a/compiler/sparc/array.lisp b/compiler/sparc/array.lisp
deleted file mode 100644
index 841f46ae93c6ea5f070b5e29284429ae2ca2965c..0000000000000000000000000000000000000000
--- a/compiler/sparc/array.lisp
+++ /dev/null
@@ -1,428 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/array.lisp,v 1.10 1992/10/11 10:54:20 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the SPARC definitions for array operations.
-;;;
-;;; Written by William Lott
-;;;
-(in-package "SPARC")
-
-
-;;;; Allocator for the array header.
-
-(define-vop (make-array-header)
-  (:translate make-array-header)
-  (:policy :fast-safe)
-  (:args (type :scs (any-reg))
-	 (rank :scs (any-reg)))
-  (:arg-types tagged-num tagged-num)
-  (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 0
-    (pseudo-atomic ()
-      (inst or header alloc-tn other-pointer-type)
-      (inst add ndescr rank (* (1+ array-dimensions-offset) vm:word-bytes))
-      (inst andn ndescr 4)
-      (inst add alloc-tn ndescr)
-      (inst add ndescr rank (fixnum (1- vm:array-dimensions-offset)))
-      (inst sll ndescr ndescr vm:type-bits)
-      (inst or ndescr ndescr type)
-      (inst srl ndescr ndescr 2)
-      (storew ndescr header 0 vm:other-pointer-type))
-    (move result header)))
-
-
-;;;; Additional accessors and setters for the array header.
-
-(defknown lisp::%array-dimension (t fixnum) fixnum
-  (flushable))
-(defknown lisp::%set-array-dimension (t fixnum fixnum) fixnum
-  ())
-
-(define-vop (%array-dimension word-index-ref)
-  (:translate lisp::%array-dimension)
-  (:policy :fast-safe)
-  (:variant vm:array-dimensions-offset vm:other-pointer-type))
-
-(define-vop (%set-array-dimension word-index-set)
-  (:translate lisp::%set-array-dimension)
-  (:policy :fast-safe)
-  (:variant vm:array-dimensions-offset vm:other-pointer-type))
-
-
-
-(defknown lisp::%array-rank (t) fixnum (flushable))
-
-(define-vop (array-rank-vop)
-  (:translate lisp::%array-rank)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 6
-    (loadw temp x 0 vm:other-pointer-type)
-    (inst sra temp vm:type-bits)
-    (inst sub temp (1- vm:array-dimensions-offset))
-    (inst sll res temp 2)))
-
-
-
-;;;; Bounds checking routine.
-
-
-(define-vop (check-bound)
-  (:translate %check-bound)
-  (:policy :fast-safe)
-  (:args (array :scs (descriptor-reg))
-	 (bound :scs (any-reg descriptor-reg))
-	 (index :scs (any-reg descriptor-reg) :target result))
-  (:results (result :scs (any-reg descriptor-reg)))
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 5
-    (let ((error (generate-error-code vop invalid-array-index-error
-				      array bound index)))
-      (inst cmp index bound)
-      (inst b :geu error)
-      (inst nop)
-      (move result index))))
-
-
-
-;;;; Accessors/Setters
-
-;;; Variants built on top of word-index-ref, etc.  I.e. those vectors whos
-;;; elements are represented in integer registers and are built out of
-;;; 8, 16, or 32 bit elements.
-
-(defmacro def-data-vector-frobs (type variant element-type &rest scs)
-  `(progn
-     (define-vop (,(intern (concatenate 'simple-string
-					"DATA-VECTOR-REF/"
-					(string type)))
-		  ,(intern (concatenate 'simple-string
-					(string variant)
-					"-REF")))
-       (:note "inline array access")
-       (:variant vm:vector-data-offset vm:other-pointer-type)
-       (:translate data-vector-ref)
-       (:arg-types ,type positive-fixnum)
-       (:results (value :scs ,scs))
-       (:result-types ,element-type))
-     (define-vop (,(intern (concatenate 'simple-string
-					"DATA-VECTOR-SET/"
-					(string type)))
-		  ,(intern (concatenate 'simple-string
-					(string variant)
-					"-SET")))
-       (:note "inline array store")
-       (:variant vm:vector-data-offset vm:other-pointer-type)
-       (:translate data-vector-set)
-       (:arg-types ,type positive-fixnum ,element-type)
-       (:args (object :scs (descriptor-reg))
-	      (index :scs (any-reg zero immediate))
-	      (value :scs ,scs))
-       (:results (result :scs ,scs))
-       (:result-types ,element-type))))
-
-(def-data-vector-frobs simple-string byte-index
-  base-char base-char-reg)
-(def-data-vector-frobs simple-vector word-index
-  * descriptor-reg any-reg)
-
-(def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
-  positive-fixnum unsigned-reg)
-(def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
-  positive-fixnum unsigned-reg)
-(def-data-vector-frobs simple-array-unsigned-byte-32 word-index
-  unsigned-num unsigned-reg)
-
-
-;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
-;;; and 4-bit vectors.
-;;; 
-
-(eval-when (compile eval)
-
-(defmacro def-small-data-vector-frobs (type bits)
-  (let* ((elements-per-word (floor vm:word-bits bits))
-	 (bit-shift (1- (integer-length elements-per-word))))
-    `(progn
-       (define-vop (,(symbolicate 'data-vector-ref/ type))
-	 (:note "inline array access")
-	 (:translate data-vector-ref)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(index :scs (unsigned-reg)))
-	 (:arg-types ,type positive-fixnum)
-	 (:results (value :scs (any-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
-	 (:generator 20
-	   (inst srl temp index ,bit-shift)
-	   (inst sll temp 2)
-	   (inst add temp (- (* vm:vector-data-offset vm:word-bytes)
-			     vm:other-pointer-type))
-	   (inst ld result object temp)
-	   (inst and temp index ,(1- elements-per-word))
-	   (inst xor temp ,(1- elements-per-word))
-	   ,@(unless (= bits 1)
-	       `((inst sll temp ,(1- (integer-length bits)))))
-	   (inst srl result temp)
-	   (inst and result ,(1- (ash 1 bits)))
-	   (inst sll value result 2)))
-       (define-vop (,(symbolicate 'data-vector-ref-c/ type))
-	 (:translate data-vector-ref)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg)))
-	 (:arg-types ,type (:constant index))
-	 (:info index)
-	 (:results (result :scs (unsigned-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (non-descriptor-reg)) temp)
-	 (:generator 15
-	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
-	     (setf extra (logxor extra (1- ,elements-per-word)))
-	     (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
-			      vm:other-pointer-type)))
-	       (cond ((typep offset '(signed-byte 13))
-		      (inst ld result object offset))
-		     (t
-		      (inst li temp offset)
-		      (inst ld result object temp))))
-	     (unless (zerop extra)
-	       (inst srl result
-		     (logxor (* extra ,bits) ,(1- elements-per-word))))
-	     (unless (= extra ,(1- elements-per-word))
-	       (inst and result ,(1- (ash 1 bits)))))))
-       (define-vop (,(symbolicate 'data-vector-set/ type))
-	 (:note "inline array store")
-	 (:translate data-vector-set)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(index :scs (unsigned-reg) :target shift)
-		(value :scs (unsigned-reg zero immediate) :target result))
-	 (:arg-types ,type positive-fixnum positive-fixnum)
-	 (:results (result :scs (unsigned-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (non-descriptor-reg)) temp old offset)
-	 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
-	 (:generator 25
-	   (inst srl offset index ,bit-shift)
-	   (inst sll offset 2)
-	   (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
-			       vm:other-pointer-type))
-	   (inst ld old object offset)
-	   (inst and shift index ,(1- elements-per-word))
-	   (inst xor shift ,(1- elements-per-word))
-	   ,@(unless (= bits 1)
-	       `((inst sll shift ,(1- (integer-length bits)))))
-	   (unless (and (sc-is value immediate)
-			(= (tn-value value) ,(1- (ash 1 bits))))
-	     (inst li temp ,(1- (ash 1 bits)))
-	     (inst sll temp shift)
-	     (inst not temp)
-	     (inst and old temp))
-	   (unless (sc-is value zero)
-	     (sc-case value
-	       (immediate
-		(inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
-	       (unsigned-reg
-		(inst and temp value ,(1- (ash 1 bits)))))
-	     (inst sll temp shift)
-	     (inst or old temp))
-	   (inst st old object offset)
-	   (sc-case value
-	     (immediate
-	      (inst li result (tn-value value)))
-	     (t
-	      (move result value)))))
-       (define-vop (,(symbolicate 'data-vector-set-c/ type))
-	 (:translate data-vector-set)
-	 (:policy :fast-safe)
-	 (:args (object :scs (descriptor-reg))
-		(value :scs (unsigned-reg zero immediate) :target result))
-	 (:arg-types ,type
-		     (:constant index)
-		     positive-fixnum)
-	 (:info index)
-	 (:results (result :scs (unsigned-reg)))
-	 (:result-types positive-fixnum)
-	 (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
-	 (:generator 20
-	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
-	     (let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
-			      vm:other-pointer-type)))
-	       (cond ((typep offset '(signed-byte 13))
-		      (inst ld old object offset))
-		     (t
-		      (inst li offset-reg offset)
-		      (inst ld old object offset-reg)))
-	       (unless (and (sc-is value immediate)
-			    (= (tn-value value) ,(1- (ash 1 bits))))
-		 (cond ((zerop extra)
-			(inst sll old ,bits)
-			(inst srl old ,bits))
-		       (t
-			(inst li temp
-			      (lognot (ash ,(1- (ash 1 bits))
-					   (* (logxor extra
-						      ,(1- elements-per-word))
-					      ,bits))))
-			(inst and old temp))))
-	       (sc-case value
-		 (zero)
-		 (immediate
-		  (let ((value (ash (logand (tn-value value)
-					    ,(1- (ash 1 bits)))
-				    (* (logxor extra
-					       ,(1- elements-per-word))
-				       ,bits))))
-		    (cond ((typep value '(signed-byte 13))
-			   (inst or old value))
-			  (t
-			   (inst li temp value)
-			   (inst or old temp)))))
-		 (unsigned-reg
-		  (inst sll temp value
-			(* (logxor extra ,(1- elements-per-word)) ,bits))
-		  (inst or old temp)))
-	       (if (typep offset '(signed-byte 13))
-		   (inst st old object offset)
-		   (inst st old object offset-reg)))
-	     (sc-case value
-	       (immediate
-		(inst li result (tn-value value)))
-	       (t
-		(move result value)))))))))
-
-); eval-when (compile eval)
-
-(def-small-data-vector-frobs simple-bit-vector 1)
-(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
-(def-small-data-vector-frobs simple-array-unsigned-byte-4 4)
-
-
-;;; And the float variants.
-;;; 
-
-(define-vop (data-vector-ref/simple-array-single-float)
-  (:note "inline array access")
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg)))
-  (:arg-types simple-array-single-float positive-fixnum)
-  (:results (value :scs (single-reg)))
-  (:temporary (:scs (non-descriptor-reg)) offset)
-  (:result-types single-float)
-  (:generator 5
-    (inst add offset index (- (* vm:vector-data-offset vm:word-bytes)
-			      vm:other-pointer-type))
-    (inst ldf value object offset)))
-
-
-(define-vop (data-vector-set/simple-array-single-float)
-  (:note "inline array store")
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg))
-	 (value :scs (single-reg) :target result))
-  (:arg-types simple-array-single-float positive-fixnum single-float)
-  (:results (result :scs (single-reg)))
-  (:result-types single-float)
-  (:temporary (:scs (non-descriptor-reg)) offset)
-  (:generator 5
-    (inst add offset index
-	  (- (* vm:vector-data-offset vm:word-bytes)
-	     vm:other-pointer-type))
-    (inst stf value object offset)
-    (unless (location= result value)
-      (inst fmovs result value))))
-
-(define-vop (data-vector-ref/simple-array-double-float)
-  (:note "inline array access")
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg)))
-  (:arg-types simple-array-double-float positive-fixnum)
-  (:results (value :scs (double-reg)))
-  (:result-types double-float)
-  (:temporary (:scs (non-descriptor-reg)) offset)
-  (:generator 7
-    (inst sll offset index 1)
-    (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
-			vm:other-pointer-type))
-    (inst lddf value object offset)))
-
-(define-vop (data-vector-set/simple-array-double-float)
-  (:note "inline array store")
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg))
-	 (value :scs (double-reg) :target result))
-  (:arg-types simple-array-double-float positive-fixnum double-float)
-  (:results (result :scs (double-reg)))
-  (:result-types double-float)
-  (:temporary (:scs (non-descriptor-reg)) offset)
-  (:generator 20
-    (inst sll offset index 1)
-    (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
-			vm:other-pointer-type))
-    (inst stdf value object offset)
-    (unless (location= result value)
-      (inst fmovs result value)
-      (inst fmovs-odd result value))))
-
-;;; These vops are useful for accessing the bits of a vector irrespective of
-;;; what type of vector it is.
-;;; 
-
-(define-vop (raw-bits word-index-ref)
-  (:note "raw-bits VOP")
-  (:translate %raw-bits)
-  (:results (value :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:variant 0 vm:other-pointer-type))
-
-(define-vop (set-raw-bits word-index-set)
-  (:note "setf raw-bits VOP")
-  (:translate %set-raw-bits)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg zero immediate))
-	 (value :scs (unsigned-reg)))
-  (:arg-types * positive-fixnum unsigned-num)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:variant 0 vm:other-pointer-type))
-
-
-
-;;;; Misc. Array VOPs.
-
-
-#+nil
-(define-vop (vector-word-length)
-  (:args (vec :scs (descriptor-reg)))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 6
-    (loadw res vec clc::g-vector-header-words)
-    (inst niuo res res clc::g-vector-words-mask-16)))
-
-(define-vop (get-vector-subtype get-header-data))
-(define-vop (set-vector-subtype set-header-data))
-
diff --git a/compiler/sparc/c-call.lisp b/compiler/sparc/c-call.lisp
deleted file mode 100644
index 2cbc597ed93fe9676f72d560650a827f7b14ce0c..0000000000000000000000000000000000000000
--- a/compiler/sparc/c-call.lisp
+++ /dev/null
@@ -1,180 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.9 1992/04/28 15:41:03 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the VOPs and other necessary machine specific support
-;;; routines for call-out to C.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "SPARC")
-(use-package "ALIEN")
-(use-package "ALIEN-INTERNALS")
-
-(defun my-make-wired-tn (prim-type-name sc-name offset)
-  (make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
-		 (sc-number-or-lose sc-name *backend*)
-		 offset))
-
-(defstruct arg-state
-  (register-args 0)
-  ;; No matter what we have to allocate at least 7 stack frame slots.  One
-  ;; because the C call convention requries it, and 6 because whoever we call
-  ;; is going to expect to be able to save his 6 register arguments there.
-  (stack-frame-size 7))
-
-(defun int-arg (state prim-type reg-sc stack-sc)
-  (let ((reg-args (arg-state-register-args state)))
-    (cond ((< reg-args 6)
-	   (setf (arg-state-register-args state) (1+ reg-args))
-	   (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
-	  (t
-	   (let ((frame-size (arg-state-stack-frame-size state)))
-	     (setf (arg-state-stack-frame-size state) (1+ frame-size))
-	     (my-make-wired-tn prim-type stack-sc (+ frame-size 16)))))))
-
-(def-alien-type-method (integer :arg-tn) (type state)
-  (if (alien-integer-type-signed type)
-      (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
-      (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
-
-(def-alien-type-method (system-area-pointer :arg-tn) (type state)
-  (declare (ignore type))
-  (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
-
-(def-alien-type-method (integer :result-tn) (type)
-  (if (alien-integer-type-signed type)
-      (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset)
-      (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset)))
-  
-(def-alien-type-method (system-area-pointer :result-tn) (type)
-  (declare (ignore type))
-  (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset))
-
-(def-alien-type-method (double-float :result-tn) (type)
-  (declare (ignore type))
-  (my-make-wired-tn 'double-float 'double-reg 0))
-
-(def-alien-type-method (values :result-tn) (type)
-  (mapcar #'(lambda (type)
-	      (invoke-alien-type-method :result-tn type))
-	  (alien-values-type-values type)))
-
-
-(def-vm-support-routine make-call-out-tns (type)
-  (declare (type alien-function-type type))
-  (let ((arg-state (make-arg-state)))
-    (collect ((arg-tns))
-      (dolist (arg-type (alien-function-type-arg-types type))
-	(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
-      (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
-	      (* (arg-state-stack-frame-size arg-state) word-bytes)
-	      (arg-tns)
-	      (invoke-alien-type-method
-	       :result-tn
-	       (alien-function-type-result-type type))))))
-
-(deftransform %alien-funcall ((function type &rest args))
-  (assert (c::constant-continuation-p type))
-  (let* ((type (c::continuation-value type))
-	 (arg-types (alien-function-type-arg-types type))
-	 (result-type (alien-function-type-result-type type)))
-    (assert (= (length arg-types) (length args)))
-    (if (some #'alien-double-float-type-p arg-types)
-	(collect ((new-args) (lambda-vars) (new-arg-types))
-	  (dolist (type arg-types)
-	    (let ((arg (gensym)))
-	      (lambda-vars arg)
-	      (cond ((alien-double-float-type-p type)
-		     (new-args `(double-float-high-bits ,arg))
-		     (new-args `(double-float-low-bits ,arg))
-		     (new-arg-types (parse-alien-type '(signed 32)))
-		     (new-arg-types (parse-alien-type '(unsigned 32))))
-		    (t
-		     (new-args arg)
-		     (new-arg-types type)))))
-	  `(lambda (function type ,@(lambda-vars))
-	     (declare (ignore type))
-	     (%alien-funcall function
-			     ',(make-alien-function-type
-				:arg-types (new-arg-types)
-				:result-type result-type)
-			     ,@(new-args))))
-	(c::give-up))))
-
-
-(define-vop (foreign-symbol-address)
-  (:translate foreign-symbol-address)
-  (:policy :fast-safe)
-  (:args)
-  (:arg-types (:constant simple-string))
-  (:info foreign-symbol)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 2
-    (inst li res (make-fixup (concatenate 'simple-string "_" foreign-symbol)
-			     :foreign))))
-
-(define-vop (call-out)
-  (:args (function :scs (sap-reg) :target cfunc)
-	 (args :more t))
-  (:results (results :more t))
-  (:ignore args results)
-  (:save-p t)
-  (:temporary (:sc any-reg :offset cfunc-offset
-		   :from (:argument 0) :to (:result 0)) cfunc)
-  (:temporary (:sc interior-reg :offset lip-offset) lip)
-  (:temporary (:scs (any-reg) :to (:result 0)) temp)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:vop-var vop)
-  (:generator 0
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn nfp-save cur-nfp))
-      (move cfunc function)
-      (inst li temp (make-fixup "_call_into_c" :foreign))
-      (inst jal lip temp)
-      (inst nop)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save)))))
-
-
-(define-vop (alloc-number-stack-space)
-  (:info amount)
-  (:results (result :scs (sap-reg any-reg)))
-  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
-  (:generator 0
-    (unless (zerop amount)
-      (let ((delta (logandc2 (+ amount 7) 7)))
-	(cond ((< delta (ash 1 12))
-	       (inst sub nsp-tn delta))
-	      (t
-	       (inst li temp delta)
-	       (inst sub nsp-tn temp)))))
-    (unless (location= result nsp-tn)
-      ;; They are only location= when the result tn was allocated by
-      ;; make-call-out-tns above, which takes the number-stack-displacement
-      ;; into account itself.
-      (inst add result nsp-tn number-stack-displacement))))
-
-(define-vop (dealloc-number-stack-space)
-  (:info amount)
-  (:policy :fast-safe)
-  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
-  (:generator 0
-    (unless (zerop amount)
-      (let ((delta (logandc2 (+ amount 7) 7)))
-	(cond ((< delta (ash 1 12))
-	       (inst add nsp-tn delta))
-	      (t
-	       (inst li temp delta)
-	       (inst add nsp-tn temp)))))))
diff --git a/compiler/sparc/call.lisp b/compiler/sparc/call.lisp
deleted file mode 100644
index 9c09b581aa1f9a694584e3527ae049d3b8148f6a..0000000000000000000000000000000000000000
--- a/compiler/sparc/call.lisp
+++ /dev/null
@@ -1,1239 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/call.lisp,v 1.21 1992/12/17 09:39:14 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the VM definition of function call for the SPARC.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "SPARC")
-
-
-;;;; Interfaces to IR2 conversion:
-
-;;; Standard-Argument-Location  --  Interface
-;;;
-;;;    Return a wired TN describing the N'th full call argument passing
-;;; location.
-;;;
-(def-vm-support-routine 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* control-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.
-;;;
-(def-vm-support-routine make-return-pc-passing-location (standard)
-  (if standard
-      (make-wired-tn *any-primitive-type* register-arg-scn lra-offset)
-      (make-restricted-tn *any-primitive-type* register-arg-scn)))
-
-;;; Make-Old-FP-Passing-Location  --  Interface
-;;;
-;;;    Similar to Make-Return-PC-Passing-Location, but makes a location to pass
-;;; Old-FP 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.
-;;;
-(def-vm-support-routine make-old-fp-passing-location (standard)
-  (if standard
-      (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)
-      (make-normal-tn *fixnum-primitive-type*)))
-
-;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location  --  Interface
-;;;
-;;;    Make the TNs used to hold Old-FP and Return-PC within the current
-;;; function.  We treat these specially so that the debugger can find them at a
-;;; known location.
-;;;
-(def-vm-support-routine make-old-fp-save-location (env)
-  (specify-save-tn
-   (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
-   (make-wired-tn *fixnum-primitive-type*
-		  control-stack-arg-scn
-		  ocfp-save-offset)))
-;;;
-(def-vm-support-routine make-return-pc-save-location (env)
-  (specify-save-tn
-   (environment-debug-live-tn (make-normal-tn *any-primitive-type*) env)
-   (make-wired-tn *any-primitive-type*
-		  control-stack-arg-scn
-		  lra-save-offset)))
-
-;;; 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.
-;;;
-(def-vm-support-routine make-argument-count-location ()
-  (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset))
-
-
-;;; MAKE-NFP-TN  --  Interface
-;;;
-;;;    Make a TN to hold the number-stack frame pointer.  This is allocated
-;;; once per component, and is component-live.
-;;;
-(def-vm-support-routine make-nfp-tn ()
-  (component-live-tn
-   (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset)))
-
-;;; MAKE-STACK-POINTER-TN ()
-;;; 
-(def-vm-support-routine make-stack-pointer-tn ()
-  (make-normal-tn *fixnum-primitive-type*))
-
-;;; MAKE-NUMBER-STACK-POINTER-TN ()
-;;; 
-(def-vm-support-routine make-number-stack-pointer-tn ()
-  (make-normal-tn *fixnum-primitive-type*))
-
-;;; Make-Unknown-Values-Locations  --  Interface
-;;;
-;;;    Return a list of TNs that can be used to represent an unknown-values
-;;; continuation within a function.
-;;;
-(def-vm-support-routine make-unknown-values-locations ()
-  (list (make-stack-pointer-tn)
-	(make-normal-tn *fixnum-primitive-type*)))
-
-
-;;; 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 additional
-;;; noise in the code object header.
-;;;
-(def-vm-support-routine select-component-format (component)
-  (declare (type component component))
-  (dotimes (i code-constants-offset)
-    (vector-push-extend nil
-			(ir2-component-constants (component-info component))))
-  (undefined-value))
-
-
-;;;; Frame hackery:
-
-;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal
-;;;
-;;; Return the number of bytes needed for the current non-descriptor stack
-;;; frame.  Non-descriptor stack frames must be multiples of 8 bytes on
-;;; the PMAX.
-;;; 
-(defun bytes-needed-for-non-descriptor-stack-frame ()
-  (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1)
-     vm:word-bytes))
-
-
-;;; Used for setting up the Old-FP in local call.
-;;;
-(define-vop (current-fp)
-  (:results (val :scs (any-reg)))
-  (:generator 1
-    (move val cfp-tn)))
-
-;;; Used for computing the caller's NFP for use in known-values return.  Only
-;;; works assuming there is no variable size stuff on the nstack.
-;;;
-(define-vop (compute-old-nfp)
-  (:results (val :scs (any-reg)))
-  (:vop-var vop)
-  (:generator 1
-    (let ((nfp (current-nfp-tn vop)))
-      (when nfp
-	(inst add val nfp (bytes-needed-for-non-descriptor-stack-frame))))))
-
-
-(define-vop (xep-allocate-frame)
-  (:info start-lab)
-  (:vop-var vop)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 1
-    ;; Make sure the function is aligned, and drop a label pointing to this
-    ;; function header.
-    (align vm:lowtag-bits)
-    (trace-table-entry trace-table-function-prologue)
-    (emit-label start-lab)
-    ;; Allocate function header.
-    (inst function-header-word)
-    (dotimes (i (1- vm:function-code-offset))
-      (inst word 0))
-    ;; The start of the actual code.
-    ;; Fix CODE, cause the function object was passed in.
-    (inst compute-code-from-fn code-tn code-tn start-lab temp)
-    ;; Build our stack frames.
-    (inst add csp-tn cfp-tn
-	  (* vm:word-bytes (sb-allocated-size 'control-stack)))
-    (let ((nfp-tn (current-nfp-tn vop)))
-      (when nfp-tn
-	(inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame))
-	(inst add nfp-tn nsp-tn number-stack-displacement)))
-    (trace-table-entry trace-table-normal)))
-
-(define-vop (allocate-frame)
-  (:results (res :scs (any-reg))
-	    (nfp :scs (any-reg)))
-  (:info callee)
-  (:generator 2
-    (trace-table-entry trace-table-function-prologue)
-    (move res csp-tn)
-    (inst add csp-tn csp-tn
-	  (* vm:word-bytes (sb-allocated-size 'control-stack)))
-    (when (ir2-environment-number-stack-p callee)
-      (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame))
-      (inst add nfp nsp-tn number-stack-displacement))
-    (trace-table-entry trace-table-normal)))
-
-;;; Allocate a partial frame for passing stack arguments in a full call.  Nargs
-;;; is the number of arguments passed.  If no stack arguments are passed, then
-;;; we don't have to do anything.
-;;;
-(define-vop (allocate-full-call-frame)
-  (:info nargs)
-  (:results (res :scs (any-reg)))
-  (:generator 2
-    (when (> nargs register-arg-count)
-      (move res csp-tn)
-      (inst add csp-tn csp-tn (* nargs vm:word-bytes)))))
-
-
-
-
-;;; 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).
-;;;
-;;;    Move-Temp is a Descriptor-Reg TN used as a temporary.
-;;;
-;;;    This code exploits the fact that in the unknown-values convention, a
-;;; single value return returns at the return PC + 8, 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:
-#|
-	b regs-defaulted		; Skip if MVs
-	nop
-
-	move a1 null-tn			; Default register values
-	...
-	loadi nargs 1			; Force defaulting of stack values
-	move old-fp csp			; Set up args for SP resetting
-
-regs-defaulted
-	subcc temp nargs register-arg-count
-
-	b :lt default-value-7	; jump to default code
-	loadw move-temp ocfp-tn 6	; Move value to correct location.
-        subcc temp 1
-	store-stack-tn val4-tn move-temp
-
-	b :lt default-value-8
-	loadw move-temp ocfp-tn 7
-        subcc temp 1
-	store-stack-tn val5-tn move-temp
-
-	...
-
-defaulting-done
-	move csp ocfp			; Reset SP.
-<end of code>
-
-<elsewhere>
-default-value-7
-	store-stack-tn val4-tn null-tn	; Nil out 7'th value. (first on stack)
-
-default-value-8
-	store-stack-tn val5-tn null-tn	; Nil out 8'th value.
-
-	...
-
-	br defaulting-done
-        nop
-|#
-;;;
-(defun default-unknown-values (vop values nvals move-temp temp lra-label)
-  (declare (type (or tn-ref null) values)
-	   (type unsigned-byte nvals) (type tn move-temp temp))
-  (if (<= nvals 1)
-      (progn
-	(new-assem:without-scheduling ()
-	  (note-this-location vop :single-value-return)
-	  (move csp-tn ocfp-tn)
-	  (inst nop))
-	(inst compute-code-from-lra code-tn code-tn lra-label temp))
-      (let ((regs-defaulted (gen-label))
-	    (defaulting-done (gen-label))
-	    (default-stack-vals (gen-label)))
-	;; Branch off to the MV case.
-	(new-assem:without-scheduling ()
-	  (note-this-location vop :unknown-return)
-	  (inst b regs-defaulted)
-	  (if (> nvals register-arg-count)
-	      (inst subcc temp nargs-tn (fixnum register-arg-count))
-	      (move csp-tn ocfp-tn)))
-	
-	;; Do the single value calse.
-	(do ((i 1 (1+ i))
-	     (val (tn-ref-across values) (tn-ref-across val)))
-	    ((= i (min nvals register-arg-count)))
-	  (move (tn-ref-tn val) null-tn))
-	(when (> nvals register-arg-count)
-	  (inst b default-stack-vals)
-	  (move ocfp-tn csp-tn))
-	
-	(emit-label regs-defaulted)
-	(when (> nvals register-arg-count)
-	  (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))
-		
-		(inst b :lt default-lab)
-		(inst ld move-temp ocfp-tn (* i vm:word-bytes))
-		(inst subcc temp (fixnum 1))
-		(store-stack-tn tn move-temp)))
-	    
-	    (emit-label defaulting-done)
-	    (move csp-tn ocfp-tn)
-	    
-	    (let ((defaults (defaults)))
-	      (when defaults
-		(assemble (*elsewhere*)
-		  (emit-label default-stack-vals)
-		  (trace-table-entry trace-table-function-prologue)
-		  (do ((remaining defaults (cdr remaining)))
-		      ((null remaining))
-		    (let ((def (car remaining)))
-		      (emit-label (car def))
-		      (when (null (cdr remaining))
-			(inst b defaulting-done))
-		      (store-stack-tn (cdr def) null-tn)))
-		  (trace-table-entry trace-table-normal))))))
-
-	(inst compute-code-from-lra code-tn code-tn lra-label temp)))
-  (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 (args nargs start count lra-label temp)
-  (declare (type tn args nargs start count temp))
-  (let ((variable-values (gen-label))
-	(done (gen-label)))
-    (new-assem:without-scheduling ()
-      (inst b variable-values)
-      (inst nop))
-    
-    (inst compute-code-from-lra code-tn code-tn lra-label temp)
-    (inst add csp-tn 4)
-    (storew (first register-arg-tns) csp-tn -1)
-    (inst sub start csp-tn 4)
-    (inst li count (fixnum 1))
-    
-    (emit-label done)
-    
-    (assemble (*elsewhere*)
-      (trace-table-entry trace-table-function-prologue)
-      (emit-label variable-values)
-      (inst compute-code-from-lra code-tn code-tn lra-label temp)
-      (do ((arg register-arg-tns (rest arg))
-	   (i 0 (1+ i)))
-	  ((null arg))
-	(storew (first arg) args i))
-      (move start args)
-      (move count nargs)
-      (inst b done)
-      (inst nop)
-      (trace-table-entry trace-table-normal)))
-  (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 (any-reg))
-   (count :scs (any-reg)))
-  (:temporary (:sc descriptor-reg :offset ocfp-offset
-		   :from :eval :to (:result 0))
-	      values-start)
-  (:temporary (:sc any-reg :offset nargs-offset
-	       :from :eval :to (:result 1))
-	      nvals)
-  (:temporary (:scs (non-descriptor-reg)) temp))
-
-
-
-;;;; 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.
-;;;
-;;; Note: we can't use normal load-tn allocation for the fixed args, since all
-;;; registers may be tied up by the more operand.  Instead, we use
-;;; MAYBE-LOAD-STACK-TN.
-;;;
-(define-vop (call-local)
-  (:args (fp)
-	 (nfp)
-	 (args :more t))
-  (:results (values :more t))
-  (:save-p t)
-  (:move-args :local-call)
-  (:info arg-locs callee target nvals)
-  (:vop-var vop)
-  (:temporary (:scs (descriptor-reg) :from (:eval 0)) move-temp)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:temporary (:sc any-reg :offset ocfp-offset :from (:eval 0)) ocfp)
-  (:ignore arg-locs args ocfp)
-  (:generator 5
-    (trace-table-entry trace-table-call-site)
-    (let ((label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn nfp-save cur-nfp))
-      (let ((callee-nfp (callee-nfp-tn callee)))
-	(when callee-nfp
-	  (move callee-nfp nfp)))
-      (maybe-load-stack-tn cfp-tn fp)
-      (inst compute-lra-from-code
-	    (callee-return-pc-tn callee) code-tn label temp)
-      (note-this-location vop :call-site)
-      (inst b target)
-      (inst nop)
-      (emit-return-pc label)
-      (default-unknown-values vop values nvals move-temp temp label)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save)))
-    (trace-table-entry trace-table-normal)))
-
-
-;;; 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.
-;;;
-;;; Note: we can't use normal load-tn allocation for the fixed args, since all
-;;; registers may be tied up by the more operand.  Instead, we use
-;;; MAYBE-LOAD-STACK-TN.
-;;;
-(define-vop (multiple-call-local unknown-values-receiver)
-  (:args (fp)
-	 (nfp)
-	 (args :more t))
-  (:save-p t)
-  (:move-args :local-call)
-  (:info save callee target)
-  (:ignore args save)
-  (:vop-var vop)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:generator 20
-    (trace-table-entry trace-table-call-site)
-    (let ((label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn nfp-save cur-nfp))
-      (let ((callee-nfp (callee-nfp-tn callee)))
-	(when callee-nfp
-	  (move callee-nfp nfp)))
-      (maybe-load-stack-tn cfp-tn fp)
-      (inst compute-lra-from-code
-	    (callee-return-pc-tn callee) code-tn label temp)
-      (note-this-location vop :call-site)
-      (inst b target)
-      (inst nop)
-      (emit-return-pc label)
-      (note-this-location vop :unknown-return)
-      (receive-unknown-values values-start nvals start count label temp)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save)))
-    (trace-table-entry trace-table-normal)))
-
-
-;;;; 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.
-;;;
-;;; Note: we can't use normal load-tn allocation for the fixed args, since all
-;;; registers may be tied up by the more operand.  Instead, we use
-;;; MAYBE-LOAD-STACK-TN.
-;;;
-(define-vop (known-call-local)
-  (:args (fp)
-	 (nfp)
-	 (args :more t))
-  (:results (res :more t))
-  (:move-args :local-call)
-  (:save-p t)
-  (:info save callee target)
-  (:ignore args res save)
-  (:vop-var vop)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 5
-    (trace-table-entry trace-table-call-site)
-    (let ((label (gen-label))
-	  (cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn nfp-save cur-nfp))
-      (let ((callee-nfp (callee-nfp-tn callee)))
-	(when callee-nfp
-	  (move callee-nfp nfp)))
-      (maybe-load-stack-tn cfp-tn fp)
-      (inst compute-lra-from-code
-	    (callee-return-pc-tn callee) code-tn label temp)
-      (note-this-location vop :call-site)
-      (inst b target)
-      (inst nop)
-      (emit-return-pc label)
-      (note-this-location vop :known-return)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save)))
-    (trace-table-entry trace-table-normal)))
-
-;;; Return from known values call.  We receive the return locations as
-;;; arguments to terminate their lifetimes in the returning function.  We
-;;; restore FP and CSP and jump to the Return-PC.
-;;;
-;;; Note: we can't use normal load-tn allocation for the fixed args, since all
-;;; registers may be tied up by the more operand.  Instead, we use
-;;; MAYBE-LOAD-STACK-TN.
-;;;
-(define-vop (known-return)
-  (:args (old-fp :target old-fp-temp)
-	 (return-pc :target return-pc-temp)
-	 (vals :more t))
-  (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp)
-  (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp)
-  (:move-args :known-return)
-  (:info val-locs)
-  (:ignore val-locs vals)
-  (:vop-var vop)
-  (:generator 6
-    (trace-table-entry trace-table-function-epilogue)
-    (maybe-load-stack-tn old-fp-temp old-fp)
-    (maybe-load-stack-tn return-pc-temp return-pc)
-    (move csp-tn cfp-tn)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(inst add nsp-tn cur-nfp 
-	      (- (bytes-needed-for-non-descriptor-stack-frame)
-		 number-stack-displacement))))
-    (inst j return-pc-temp (- vm:word-bytes vm:other-pointer-type))
-    (move cfp-tn old-fp-temp)
-    (trace-table-entry trace-table-normal)))
-
-
-;;;; 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 creating a partial frame on the
-;;; stack top and storing stack arguments into that frame.  On entry to the
-;;; callee, this partial frame is pointed to by FP.  If there are no stack
-;;; arguments, we don't bother allocating a partial frame, and instead set FP
-;;; to SP just before the call.
-
-;;; 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-Fp and Return-PC are passed as the second and third arguments.
-;;;
-;;; In non-tail calls, the pointer to the stack arguments is passed as the last
-;;; fixed argument.  If Variable is false, then the passing locations are
-;;; passed as a more arg.  Variable is true if there are a variable number of
-;;; arguments passed on the stack.  Variable cannot be specified with :Tail
-;;; return.  TR variable argument call is implemented separately.
-;;;
-;;; In tail call with fixed arguments, the passing locations are passed as a
-;;; more arg, but there is no new-FP, since the arguments have been set up in
-;;; the current frame.
-;;;
-(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
-      ,@(unless (eq return :tail)
-	  '((new-fp :scs (any-reg) :to :eval)))
-
-      ,(if named
-	   '(name :target name-pass)
-	   '(arg-fun :target lexenv))
-      
-      ,@(when (eq return :tail)
-	  '((old-fp :target old-fp-pass)
-	    (return-pc :target return-pc-pass)))
-      
-      ,@(unless variable '((args :more t :scs (descriptor-reg)))))
-
-     ,@(when (eq return :fixed)
-	 '((:results (values :more t))))
-   
-     (:save-p ,(if (eq return :tail) :compute-only t))
-
-     ,@(unless (or (eq return :tail) variable)
-	 '((:move-args :full-call)))
-
-     (:vop-var vop)
-     (:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
-	    ,@(unless variable '(nargs))
-	    ,@(when (eq return :fixed) '(nvals)))
-
-     (:ignore
-      ,@(unless (or variable (eq return :tail)) '(arg-locs))
-      ,@(unless variable '(args)))
-
-     (:temporary (:sc descriptor-reg
-		  :offset ocfp-offset
-		  :from (:argument 1)
-		  ,@(unless (eq return :fixed)
-		      '(:to :eval)))
-		 old-fp-pass)
-
-     (:temporary (:sc descriptor-reg
-		  :offset lra-offset
-		  :from (:argument ,(if (eq return :tail) 2 1))
-		  :to :eval)
-		 return-pc-pass)
-
-     ,(if named
-	  `(:temporary (:sc descriptor-reg :offset cname-offset
-			    :from (:argument ,(if (eq return :tail) 0 1))
-			    :to :eval)
-		       name-pass)
-	  `(:temporary (:sc descriptor-reg :offset lexenv-offset
-			    :from (:argument ,(if (eq return :tail) 0 1))
-			    :to :eval)
-		       lexenv))
-
-     (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
-		 function)
-     (:temporary (:sc any-reg :offset nargs-offset :to :eval)
-		 nargs-pass)
-
-     ,@(when variable
-	 (mapcar #'(lambda (name offset)
-		     `(:temporary (:sc descriptor-reg
-				   :offset ,offset
-				   :to :eval)
-			 ,name))
-		 register-arg-names register-arg-offsets))
-     ,@(when (eq return :fixed)
-	 '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
-
-     ,@(unless (eq return :tail)
-	 '((:temporary (:scs (non-descriptor-reg)) temp)
-	   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
-
-     (:generator ,(+ (if named 5 0)
-		     (if variable 19 1)
-		     (if (eq return :tail) 0 10)
-		     15
-		     (if (eq return :unknown) 25 0))
-       (trace-table-entry trace-table-call-site)
-       (let* ((cur-nfp (current-nfp-tn vop))
-	      ,@(unless (eq return :tail)
-		  '((lra-label (gen-label))))
-	      (filler
-	       (remove nil
-		       (list :load-nargs
-			     ,@(if (eq return :tail)
-				   '((unless (location= old-fp old-fp-pass)
-				       :load-old-fp)
-				     (unless (location= return-pc
-							return-pc-pass)
-				       :load-return-pc)
-				     (when cur-nfp
-				       :frob-nfp))
-				   '(:comp-lra
-				     (when cur-nfp
-				       :frob-nfp)
-				     :save-fp
-				     :load-fp))))))
-	 (flet ((do-next-filler ()
-		  (let* ((next (pop filler))
-			 (what (if (consp next) (car next) next)))
-		    (ecase what
-		      (:load-nargs
-		       ,@(if variable
-			     `((inst sub nargs-pass csp-tn new-fp)
-			       ,@(let ((index -1))
-				   (mapcar #'(lambda (name)
-					       `(loadw ,name new-fp
-						       ,(incf index)))
-					   register-arg-names)))
-			     '((inst li nargs-pass (fixnum nargs)))))
-		      ,@(if (eq return :tail)
-			    '((:load-old-fp
-			       (sc-case old-fp
-				 (any-reg
-				  (inst move old-fp-pass old-fp))
-				 (control-stack
-				  (loadw old-fp-pass cfp-tn
-					 (tn-offset old-fp)))))
-			      (:load-return-pc
-			       (sc-case return-pc
-				 (descriptor-reg
-				  (inst move return-pc-pass return-pc))
-				 (control-stack
-				  (loadw return-pc-pass cfp-tn
-					 (tn-offset return-pc)))))
-			      (:frob-nfp
-			       (inst add nsp-tn cur-nfp
-				     (- (bytes-needed-for-non-descriptor-stack-frame)
-					number-stack-displacement))))
-			    `((:comp-lra
-			       (inst compute-lra-from-code
-				     return-pc-pass code-tn lra-label temp))
-			      (:frob-nfp
-			       (store-stack-tn nfp-save cur-nfp))
-			      (:save-fp
-			       (inst move old-fp-pass cfp-tn))
-			      (:load-fp
-			       ,(if variable
-				    '(move cfp-tn new-fp)
-				    '(if (> nargs register-arg-count)
-					 (move cfp-tn new-fp)
-					 (move cfp-tn csp-tn))))))
-		      ((nil))))))
-
-	   ,@(if named
-		 `((sc-case name
-		     (descriptor-reg (move name-pass name))
-		     (control-stack
-		      (loadw name-pass cfp-tn (tn-offset name))
-		      (do-next-filler))
-		     (constant
-		      (loadw name-pass code-tn (tn-offset name)
-			     vm:other-pointer-type)
-		      (do-next-filler)))
-		   (loadw function name-pass fdefn-raw-addr-slot
-			  other-pointer-type)
-		   (do-next-filler))
-		 `((sc-case arg-fun
-		     (descriptor-reg (move lexenv arg-fun))
-		     (control-stack
-		      (loadw lexenv cfp-tn (tn-offset arg-fun))
-		      (do-next-filler))
-		     (constant
-		      (loadw lexenv code-tn (tn-offset arg-fun)
-			     vm:other-pointer-type)
-		      (do-next-filler)))
-		   (loadw function lexenv vm:closure-function-slot
-			  vm:function-pointer-type)
-		   (do-next-filler)))
-	   (loop
-	     (if filler
-		 (do-next-filler)
-		 (return)))
-	   
-	   (note-this-location vop :call-site)
-	   (inst j function
-		 (- (ash vm:function-code-offset vm:word-shift)
-		    vm:function-pointer-type))
-	   (inst move code-tn function))
-
-	 ,@(ecase return
-	     (:fixed
-	      '((emit-return-pc lra-label)
-		(default-unknown-values vop values nvals move-temp
-					temp lra-label)
-		(when cur-nfp
-		  (load-stack-tn cur-nfp nfp-save))))
-	     (:unknown
-	      '((emit-return-pc lra-label)
-		(note-this-location vop :unknown-return)
-		(receive-unknown-values values-start nvals start count
-					lra-label temp)
-		(when cur-nfp
-		  (load-stack-tn cur-nfp nfp-save))))
-	     (:tail)))
-       (trace-table-entry trace-table-normal))))
-
-
-(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 special code that BLT's the arguments
-;;; down.
-;;;
-(define-vop (tail-call-variable)
-  (:args
-   (args-arg :scs (any-reg) :target args)
-   (function-arg :scs (descriptor-reg) :target lexenv)
-   (old-fp-arg :scs (any-reg) :target old-fp)
-   (lra-arg :scs (descriptor-reg) :target lra))
-
-  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args)
-  (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv)
-  (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) old-fp)
-  (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra)
-
-  (:temporary (:scs (any-reg) :from :eval) temp)
-
-  (:vop-var vop)
-
-  (:generator 75
-
-    ;; Move these into the passing locations if they are not already there.
-    (move args args-arg)
-    (move lexenv function-arg)
-    (move old-fp old-fp-arg)
-    (move lra lra-arg)
-
-    ;; Clear the number stack if anything is there.
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(inst add nsp-tn cur-nfp
-	      (- (bytes-needed-for-non-descriptor-stack-frame)
-		 number-stack-displacement))))
-
-    ;; And jump to the assembly-routine that does the bliting.
-    (inst ji temp (make-fixup 'tail-call-variable :assembly-routine))
-    (inst nop)))
-
-
-;;;; Unknown values return:
-
-
-;;; Return a single value using the unknown-values convention.
-;;; 
-(define-vop (return-single)
-  (:args (old-fp :scs (any-reg))
-	 (return-pc :scs (descriptor-reg))
-	 (value))
-  (:ignore value)
-  (:vop-var vop)
-  (:generator 6
-    (trace-table-entry trace-table-function-epilogue)
-    ;; Clear the number stack.
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(inst add nsp-tn cur-nfp
-	      (- (bytes-needed-for-non-descriptor-stack-frame)
-		 number-stack-displacement))))
-    ;; Clear the control stack, and restore the frame pointer.
-    (move csp-tn cfp-tn)
-    (move cfp-tn old-fp)
-    ;; Out of here.
-    (lisp-return return-pc :offset 2)
-    (trace-table-entry trace-table-normal)))
-
-;;; 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
-;;; FP and jump to the single-value entry at Return-PC + 8.
-;;;
-;;; If returning other than one value, then load the number of values returned,
-;;; NIL out unsupplied values registers, restore FP 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-fp :scs (any-reg))
-   (return-pc :scs (descriptor-reg) :to (:eval 1))
-   (values :more t))
-  (:ignore values)
-  (:info nvals)
-  (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0)
-  (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1)
-  (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2)
-  (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3)
-  (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4)
-  (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5)
-  (:temporary (:sc any-reg :offset nargs-offset) nargs)
-  (:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
-  (:vop-var vop)
-  (:generator 6
-    (trace-table-entry trace-table-function-epilogue)
-    ;; Clear the number stack.
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(inst add nsp-tn cur-nfp
-	      (- (bytes-needed-for-non-descriptor-stack-frame)
-		 number-stack-displacement))))
-    (cond ((= nvals 1)
-	   ;; Clear the control stack, and restore the frame pointer.
-	   (move csp-tn cfp-tn)
-	   (move cfp-tn old-fp)
-	   ;; Out of here.
-	   (lisp-return return-pc :offset 2))
-	  (t
-	   ;; Establish the values pointer and values count.
-	   (move val-ptr cfp-tn)
-	   (inst li nargs (fixnum nvals))
-	   ;; restore the frame pointer and clear as much of the control
-	   ;; stack as possible.
-	   (move cfp-tn old-fp)
-	   (inst add csp-tn val-ptr (* nvals word-bytes))
-	   ;; pre-default any argument register that need it.
-	   (when (< nvals register-arg-count)
-	     (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
-	       (move reg null-tn)))
-	   ;; And away we go.
-	   (lisp-return return-pc)))
-    (trace-table-entry trace-table-normal)))
-
-;;; 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 an assembly-routine.
-;;;
-(define-vop (return-multiple)
-  (:args
-   (old-fp-arg :scs (any-reg) :to (:eval 1))
-   (lra-arg :scs (descriptor-reg) :to (:eval 1))
-   (vals-arg :scs (any-reg) :target vals)
-   (nvals-arg :scs (any-reg) :target nvals))
-
-  (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp)
-  (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
-  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals)
-  (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals)
-  (:temporary (:sc descriptor-reg :offset a0-offset) a0)
-
-  (:temporary (:scs (any-reg) :from (:eval 1)) temp)
-
-  (:vop-var vop)
-
-  (:generator 13
-    (trace-table-entry trace-table-function-epilogue)
-    (let ((not-single (gen-label)))
-      ;; Clear the number stack.
-      (let ((cur-nfp (current-nfp-tn vop)))
-	(when cur-nfp
-	  (inst add nsp-tn cur-nfp
-		(- (bytes-needed-for-non-descriptor-stack-frame)
-		   number-stack-displacement))))
-
-      ;; Check for the single case.
-      (inst cmp nvals-arg (fixnum 1))
-      (inst b :ne not-single)
-      (inst ld a0 vals-arg)
-
-      ;; Return with one value.
-      (move csp-tn cfp-tn)
-      (move cfp-tn old-fp-arg)
-      (lisp-return lra-arg :offset 2)
-		
-      ;; Nope, not the single case.
-      (emit-label not-single)
-      (move old-fp old-fp-arg)
-      (move lra lra-arg)
-      (move vals vals-arg)
-      (move nvals nvals-arg)
-      (inst ji temp (make-fixup 'return-multiple :assembly-routine))
-      (inst nop))
-    (trace-table-entry trace-table-normal)))
-
-
-
-;;;; XEP hackery:
-
-
-;;; We don't need to do anything special for regular functions.
-;;;
-(define-vop (setup-environment)
-  (:info label)
-  (:ignore label)
-  (:generator 0
-    ;; Don't bother doing anything.
-    ))
-
-;;; Get the lexical environment from it's passing location.
-;;;
-(define-vop (setup-closure-environment)
-  (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
-	       :to (:result 0))
-	      lexenv)
-  (:results (closure :scs (descriptor-reg)))
-  (:info label)
-  (:ignore label)
-  (:generator 6
-    ;; Get result.
-    (move closure lexenv)))
-
-;;; Copy a more arg from the argument area to the end of the current frame.
-;;; Fixed is the number of non-more arguments. 
-;;;
-(define-vop (copy-more-arg)
-  (:temporary (:sc any-reg :offset nl0-offset) result)
-  (:temporary (:sc any-reg :offset nl1-offset) count)
-  (:temporary (:sc any-reg :offset nl2-offset) src)
-  (:temporary (:sc any-reg :offset nl3-offset) dst)
-  (:temporary (:sc descriptor-reg :offset l0-offset) temp)
-  (:info fixed)
-  (:generator 20
-    (let ((loop (gen-label))
-	  (do-regs (gen-label))
-	  (done (gen-label)))
-      (when (< fixed register-arg-count)
-	;; Save a pointer to the results so we can fill in register args.
-	;; We don't need this if there are more fixed args than reg args.
-	(move result csp-tn))
-      ;; Allocate the space on the stack.
-      (cond ((zerop fixed)
-	     (inst cmp nargs-tn)
-	     (inst b :eq done)
-	     (inst add csp-tn csp-tn nargs-tn))
-	    (t
-	     (inst subcc count nargs-tn (fixnum fixed))
-	     (inst b :le done)
-	     (inst nop)
-	     (inst add csp-tn csp-tn count)))
-      (when (< fixed register-arg-count)
-	;; We must stop when we run out of stack args, not when we run out of
-	;; more args.
-	(inst subcc count nargs-tn (fixnum register-arg-count))
-	;; Everything of interest in registers.
-	(inst b :le do-regs))
-      ;; Initialize dst to be end of stack.
-      (move dst csp-tn)
-      ;; Initialize src to be end of args.
-      (inst add src cfp-tn nargs-tn)
-
-      (emit-label loop)
-      ;; *--dst = *--src, --count
-      (inst add src src (- vm:word-bytes))
-      (inst subcc count count (fixnum 1))
-      (loadw temp src)
-      (inst add dst dst (- vm:word-bytes))
-      (inst b :gt loop)
-      (storew temp dst)
-
-      (emit-label do-regs)
-      (when (< fixed register-arg-count)
-	;; Now we have to deposit any more args that showed up in registers.
-	(inst subcc count nargs-tn (fixnum fixed))
-	(do ((i fixed (1+ i)))
-	    ((>= i register-arg-count))
-	  ;; Don't deposit any more than there are.
-	  (inst b :eq done)
-	  (inst subcc count (fixnum 1))
-	  ;; Store it relative to the pointer saved at the start.
-	  (storew (nth i register-arg-tns) result (- i fixed))))
-      (emit-label done))))
-
-
-;;; More args are stored consequtively on the stack, starting immediately at
-;;; the context pointer.  The context pointer is not typed, so the lowtag is 0.
-;;;
-(define-vop (more-arg word-index-ref)
-  (:variant 0 0)
-  (:translate %more-arg))
-
-
-;;; Turn more arg (context, count) into a list.
-;;;
-(define-vop (listify-rest-args)
-  (:args (context-arg :target context :scs (descriptor-reg))
-	 (count-arg :target count :scs (any-reg)))
-  (:arg-types * tagged-num)
-  (:temporary (:scs (any-reg) :from (:argument 0)) context)
-  (:temporary (:scs (any-reg) :from (:argument 1)) count)
-  (:temporary (:scs (descriptor-reg) :from :eval) temp)
-  (:temporary (:scs (non-descriptor-reg) :from :eval) dst)
-  (:results (result :scs (descriptor-reg)))
-  (:translate %listify-rest-args)
-  (:policy :safe)
-  (:generator 20
-    (let ((enter (gen-label))
-	  (loop (gen-label))
-	  (done (gen-label)))
-      (move context context-arg)
-      (move count count-arg)
-      ;; Check to see if there are any arguments.
-      (inst cmp count)
-      (inst b :eq done)
-      (move result null-tn)
-
-      ;; We need to do this atomically.
-      (pseudo-atomic ()
-	;; Allocate a cons (2 words) for each item.
-	(inst andn result alloc-tn lowtag-mask)
-	(inst or result list-pointer-type)
-	(move dst result)
-	(inst sll temp count 1)
-	(inst b enter)
-	(inst add alloc-tn temp)
-
-	;; Store the current cons in the cdr of the previous cons.
-	(emit-label loop)
-	(storew dst dst -1 vm:list-pointer-type)
-
-	;; Grab one value and stash it in the car of this cons.
-	(emit-label enter)
-	(loadw temp context)
-	(inst add context context vm:word-bytes)
-	(storew temp dst 0 vm:list-pointer-type)
-
-	;; Dec count, and if != zero, go back for more.
-	(inst subcc count (fixnum 1))
-	(inst b :gt loop)
-	(inst add dst dst (* 2 vm:word-bytes))
-
-	;; NIL out the last cons.
-	(storew null-tn dst -1 vm:list-pointer-type))
-      (emit-label done))))
-
-
-;;; 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)
-  (:policy :fast-safe)
-  (:translate c::%more-arg-context)
-  (:args (supplied :scs (any-reg)))
-  (:arg-types tagged-num (:constant fixnum))
-  (:info fixed)
-  (:results (context :scs (descriptor-reg))
-	    (count :scs (any-reg)))
-  (:result-types t tagged-num)
-  (:note "more-arg-context")
-  (:generator 5
-    (inst sub count supplied (fixnum fixed))
-    (inst sub context csp-tn count)))
-
-
-;;; Signal wrong argument count error if Nargs isn't = to Count.
-;;;
-(define-vop (verify-argument-count)
-  (:args (nargs :scs (any-reg)))
-  (:arg-types positive-fixnum)
-  (:info count)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 3
-    (let ((err-lab
-	   (generate-error-code vop invalid-argument-count-error nargs)))
-      (inst cmp nargs (fixnum count))
-      (inst b :ne err-lab)
-      (inst nop))))
-
-;;; Signal various errors.
-;;;
-(macrolet ((frob (name error &rest args)
-	     `(define-vop (,name)
-		(:args ,@(mapcar #'(lambda (arg)
-				     `(,arg :scs (any-reg descriptor-reg)))
-				 args))
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 1000
-		  (error-call vop ,error ,@args)))))
-  (frob argument-count-error invalid-argument-count-error nargs)
-  (frob type-check-error object-not-type-error object type)
-  (frob odd-keyword-arguments-error odd-keyword-arguments-error)
-  (frob unknown-keyword-argument-error unknown-keyword-argument-error key)
-  (frob nil-function-returned-error nil-function-returned-error fun))
diff --git a/compiler/sparc/cell.lisp b/compiler/sparc/cell.lisp
deleted file mode 100644
index b10584ea6369ecbefdcacc17ed151cffdde18040..0000000000000000000000000000000000000000
--- a/compiler/sparc/cell.lisp
+++ /dev/null
@@ -1,288 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/cell.lisp,v 1.14 1992/12/16 20:27:10 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the VM definition of various primitive memory access
-;;; VOPs for the SPARC.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by William Lott.
-;;; 
-
-(in-package "SPARC")
-
-
-;;;; Data object ref/set stuff.
-
-(define-vop (slot)
-  (:args (object :scs (descriptor-reg)))
-  (:info name offset lowtag)
-  (:ignore name)
-  (:results (result :scs (descriptor-reg any-reg)))
-  (:generator 1
-    (loadw result object offset lowtag)))
-
-(define-vop (set-slot)
-  (:args (object :scs (descriptor-reg))
-	 (value :scs (descriptor-reg any-reg)))
-  (:info name offset lowtag)
-  (:ignore name)
-  (:results)
-  (:generator 1
-    (storew value object offset lowtag)))
-
-
-
-;;;; Symbol hacking VOPs:
-
-;;; The compiler likes to be able to directly SET symbols.
-;;;
-(define-vop (set cell-set)
-  (:variant symbol-value-slot other-pointer-type))
-
-;;; 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 (: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 vop unbound-symbol-error obj-temp)))
-      (inst cmp value vm:unbound-marker-type)
-      (inst b :eq err-lab)
-      (inst nop))))
-
-;;; 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))
-
-(define-vop (boundp boundp-frob)
-  (:translate boundp)
-  (:generator 9
-    (loadw value object vm:symbol-value-slot vm:other-pointer-type)
-    (inst cmp value vm:unbound-marker-type)
-    (inst b (if not-p :eq :ne) target)
-    (inst nop)))
-
-(define-vop (fast-symbol-value cell-ref)
-  (:variant vm:symbol-value-slot vm:other-pointer-type)
-  (:policy :fast)
-  (:translate symbol-value))
-
-
-;;;; Fdefinition (fdefn) objects.
-
-(define-vop (fdefn-function cell-ref)
-  (:variant fdefn-function-slot other-pointer-type))
-
-(define-vop (safe-fdefn-function)
-  (:args (object :scs (descriptor-reg) :target obj-temp))
-  (:results (value :scs (descriptor-reg any-reg)))
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
-  (:generator 10
-    (move obj-temp object)
-    (loadw value obj-temp fdefn-function-slot other-pointer-type)
-    (inst cmp value null-tn)
-    (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
-      (inst b :eq err-lab))
-    (inst nop)))
-
-(define-vop (set-fdefn-function)
-  (:policy :fast-safe)
-  (:translate (setf fdefn-function))
-  (:args (function :scs (descriptor-reg) :target result)
-	 (fdefn :scs (descriptor-reg)))
-  (:temporary (:scs (interior-reg)) lip)
-  (:temporary (:scs (non-descriptor-reg)) type)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 38
-    (let ((normal-fn (gen-label)))
-      (load-type type function (- function-pointer-type))
-      (inst cmp type function-header-type)
-      (inst b :eq normal-fn)
-      (inst move lip function)
-      (inst li lip (make-fixup "_closure_tramp" :foreign))
-      (emit-label normal-fn)
-      (storew function fdefn fdefn-function-slot other-pointer-type)
-      (storew lip fdefn fdefn-raw-addr-slot other-pointer-type)
-      (move result function))))
-
-(define-vop (fdefn-makunbound)
-  (:policy :fast-safe)
-  (:translate fdefn-makunbound)
-  (:args (fdefn :scs (descriptor-reg) :target result))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 38
-    (storew null-tn fdefn fdefn-function-slot other-pointer-type)
-    (inst li temp (make-fixup "_undefined_tramp" :foreign))
-    (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)
-    (move result fdefn)))
-
-
-
-;;;; 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 add bsp-tn bsp-tn (* 2 vm:word-bytes))
-    (storew temp bsp-tn (- vm:binding-value-slot vm:binding-size))
-    (storew symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size))
-    (storew val symbol vm:symbol-value-slot vm:other-pointer-type)))
-
-
-(define-vop (unbind)
-  (:temporary (:scs (descriptor-reg)) symbol value)
-  (:generator 0
-    (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size))
-    (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size))
-    (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
-    (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size))
-    (inst sub bsp-tn bsp-tn (* 2 vm:word-bytes))))
-
-
-(define-vop (unbind-to-here)
-  (:args (arg :scs (descriptor-reg any-reg) :target where))
-  (:temporary (:scs (any-reg) :from (:argument 0)) where)
-  (:temporary (:scs (descriptor-reg)) symbol value)
-  (:generator 0
-    (let ((loop (gen-label))
-	  (skip (gen-label))
-	  (done (gen-label)))
-      (move where arg)
-      (inst cmp where bsp-tn)
-      (inst b :eq done)
-      (inst nop)
-
-      (emit-label loop)
-      (loadw symbol bsp-tn (- vm:binding-symbol-slot vm:binding-size))
-      (inst cmp symbol)
-      (inst b :eq skip)
-      (loadw value bsp-tn (- vm:binding-value-slot vm:binding-size))
-      (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
-      (storew zero-tn bsp-tn (- vm:binding-symbol-slot vm:binding-size))
-
-      (emit-label skip)
-      (inst sub bsp-tn bsp-tn (* 2 vm:word-bytes))
-      (inst cmp where bsp-tn)
-      (inst b :ne loop)
-      (inst nop)
-
-      (emit-label done))))
-
-
-
-;;;; Closure indexing.
-
-(define-vop (closure-index-ref word-index-ref)
-  (:variant vm:closure-info-offset vm:function-pointer-type)
-  (:translate %closure-index-ref))
-
-(define-vop (set-funcallable-instance-info word-index-set)
-  (:variant funcallable-instance-info-offset function-pointer-type)
-  (:translate %set-funcallable-instance-info))
-
-
-(define-vop (closure-ref slot-ref)
-  (:variant closure-info-offset function-pointer-type))
-
-(define-vop (closure-init slot-set)
-  (:variant closure-info-offset function-pointer-type))
-
-
-;;;; Value Cell hackery.
-
-(define-vop (value-cell-ref cell-ref)
-  (:variant value-cell-value-slot other-pointer-type))
-
-(define-vop (value-cell-set cell-set)
-  (:variant value-cell-value-slot other-pointer-type))
-
-
-
-;;;; Structure hackery:
-
-(define-vop (structure-length)
-  (:policy :fast-safe)
-  (:translate structure-length)
-  (:args (struct :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 4
-    (loadw temp struct 0 structure-pointer-type)
-    (inst srl res temp vm:type-bits)))
-
-(define-vop (structure-ref slot-ref)
-  (:variant structure-slots-offset structure-pointer-type)
-  (:policy :fast-safe)
-  (:translate structure-ref)
-  (:arg-types structure (:constant index)))
-
-(define-vop (structure-set slot-set)
-  (:policy :fast-safe)
-  (:translate structure-set)
-  (:variant structure-slots-offset structure-pointer-type)
-  (:arg-types structure (:constant index) *))
-
-(define-vop (structure-index-ref word-index-ref)
-  (:policy :fast-safe) 
-  (:translate structure-ref)
-  (:variant structure-slots-offset structure-pointer-type)
-  (:arg-types structure positive-fixnum))
-
-(define-vop (structure-index-set word-index-set)
-  (:policy :fast-safe) 
-  (:translate structure-set)
-  (:variant structure-slots-offset structure-pointer-type)
-  (:arg-types structure positive-fixnum *))
-
-
-
-;;;; Code object frobbing.
-
-(define-vop (code-header-ref word-index-ref)
-  (:translate code-header-ref)
-  (:policy :fast-safe)
-  (:variant 0 other-pointer-type))
-
-(define-vop (code-header-set word-index-set)
-  (:translate code-header-set)
-  (:policy :fast-safe)
-  (:variant 0 other-pointer-type))
-
diff --git a/compiler/sparc/char.lisp b/compiler/sparc/char.lisp
deleted file mode 100644
index 7e0a851919dd5179dfa987c4ee436fba2bb05637..0000000000000000000000000000000000000000
--- a/compiler/sparc/char.lisp
+++ /dev/null
@@ -1,148 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/char.lisp,v 1.6 1992/02/25 07:04:51 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;; 
-;;; This file contains the SPARC VM definition of character operations.
-;;;
-;;; Written by Rob MacLachlan
-;;; Converted for the MIPS R2000 by Christopher Hoover.
-;;; And then to the SPARC by William Lott.
-;;;
-(in-package "SPARC")
-
-
-
-;;;; Moves and coercions:
-
-;;; Move a tagged char to an untagged representation.
-;;;
-(define-vop (move-to-base-char)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (y :scs (base-char-reg)))
-  (:note "character untagging")
-  (:generator 1
-    (inst srl y x vm:type-bits)))
-;;;
-(define-move-vop move-to-base-char :move
-  (any-reg descriptor-reg) (base-char-reg))
-
-
-;;; Move an untagged char to a tagged representation.
-;;;
-(define-vop (move-from-base-char)
-  (:args (x :scs (base-char-reg)))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:note "character tagging")
-  (:generator 1
-    (inst sll y x vm:type-bits)
-    (inst or y vm:base-char-type)))
-;;;
-(define-move-vop move-from-base-char :move
-  (base-char-reg) (any-reg descriptor-reg))
-
-;;; Move untagged base-char values.
-;;;
-(define-vop (base-char-move)
-  (:args (x :target y
-	    :scs (base-char-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (base-char-reg)
-	       :load-if (not (location= x y))))
-  (:note "character move")
-  (:effects)
-  (:affected)
-  (:generator 0
-    (move y x)))
-;;;
-(define-move-vop base-char-move :move
-  (base-char-reg) (base-char-reg))
-
-
-;;; Move untagged base-char arguments/return-values.
-;;;
-(define-vop (move-base-char-argument)
-  (:args (x :target y
-	    :scs (base-char-reg))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y base-char-reg))))
-  (:results (y))
-  (:note "character arg move")
-  (:generator 0
-    (sc-case y
-      (base-char-reg
-       (move y x))
-      (base-char-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-base-char-argument :move-argument
-  (any-reg base-char-reg) (base-char-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
-;;; to a descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (base-char-reg) (any-reg descriptor-reg))
-
-
-
-;;;; Other operations:
-
-(define-vop (char-code)
-  (:translate char-code)
-  (:policy :fast-safe)
-  (:args (ch :scs (base-char-reg) :target res))
-  (:arg-types base-char)
-  (:results (res :scs (any-reg)))
-  (:result-types positive-fixnum)
-  (:generator 1
-    (inst sll res ch 2)))
-
-(define-vop (code-char)
-  (:translate code-char)
-  (:policy :fast-safe)
-  (:args (code :scs (any-reg) :target res))
-  (:arg-types positive-fixnum)
-  (:results (res :scs (base-char-reg)))
-  (:result-types base-char)
-  (:generator 1
-    (inst srl res code 2)))
-
-
-;;; Comparison of base-chars.
-;;;
-(define-vop (base-char-compare)
-  (:args (x :scs (base-char-reg))
-	 (y :scs (base-char-reg)))
-  (:arg-types base-char base-char)
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:note "inline comparison")
-  (:variant-vars condition not-condition)
-  (:generator 3
-    (inst cmp x y)
-    (inst b (if not-p not-condition condition) target)
-    (inst nop)))
-
-(define-vop (fast-char=/base-char base-char-compare)
-  (:translate char=)
-  (:variant :eq :ne))
-
-(define-vop (fast-char</base-char base-char-compare)
-  (:translate char<)
-  (:variant :ltu :geu))
-
-(define-vop (fast-char>/base-char base-char-compare)
-  (:translate char>)
-  (:variant :gtu :leu))
-
diff --git a/compiler/sparc/debug.lisp b/compiler/sparc/debug.lisp
deleted file mode 100644
index d2d4ab7a2398f24ed05aa347c7950289de205dcd..0000000000000000000000000000000000000000
--- a/compiler/sparc/debug.lisp
+++ /dev/null
@@ -1,128 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/debug.lisp,v 1.3 1992/02/25 07:06:23 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Compiler support for the new whizzy debugger.
-;;;
-;;; Written by William Lott.
-;;; 
-(in-package "SPARC")
-
-(defknown di::current-sp () system-area-pointer (movable flushable))
-(defknown di::current-fp () system-area-pointer (movable flushable))
-(defknown di::stack-ref (system-area-pointer index) t (flushable))
-(defknown di::%set-stack-ref (system-area-pointer index t) t (unsafe))
-(defknown di::lra-code-header (t) t (movable flushable))
-(defknown di::function-code-header (t) t (movable flushable))
-(defknown di::make-lisp-obj ((unsigned-byte 32)) t (movable flushable))
-(defknown di::get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable))
-(defknown di::function-word-offset (function) index (movable flushable))
-
-(define-vop (debug-cur-sp)
-  (:translate di::current-sp)
-  (:policy :fast-safe)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 1
-    (move res csp-tn)))
-
-(define-vop (debug-cur-fp)
-  (:translate di::current-fp)
-  (:policy :fast-safe)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 1
-    (move res cfp-tn)))
-
-(define-vop (read-control-stack)
-  (:translate kernel:stack-ref)
-  (:policy :fast-safe)
-  (:args (sap :scs (sap-reg))
-	 (offset :scs (any-reg)))
-  (:arg-types system-area-pointer positive-fixnum)
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:generator 5
-    (inst ld result sap offset)))
-
-(define-vop (write-control-stack)
-  (:translate kernel:%set-stack-ref)
-  (:policy :fast-safe)
-  (:args (sap :scs (sap-reg))
-	 (offset :scs (any-reg))
-	 (value :scs (descriptor-reg) :target result))
-  (:arg-types system-area-pointer positive-fixnum *)
-  (:results (result :scs (descriptor-reg)))
-  (:result-types *)
-  (:generator 5
-    (inst st value sap offset)
-    (move result value)))
-
-(define-vop (code-from-mumble)
-  (:policy :fast-safe)
-  (:args (thing :scs (descriptor-reg)))
-  (:results (code :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:variant-vars lowtag)
-  (:generator 5
-    (let ((bogus (gen-label))
-	  (done (gen-label)))
-      (loadw temp thing 0 lowtag)
-      (inst srl temp vm:type-bits)
-      (inst cmp temp)
-      (inst b :eq bogus)
-      (inst sll temp (1- (integer-length vm:word-bytes)))
-      (unless (= lowtag vm:other-pointer-type)
-	(inst add temp (- lowtag vm:other-pointer-type)))
-      (inst sub code thing temp)
-      (emit-label done)
-      (assemble (*elsewhere*)
-	(emit-label bogus)
-	(inst b done)
-	(move code null-tn)))))
-
-(define-vop (code-from-lra code-from-mumble)
-  (:translate di::lra-code-header)
-  (:variant vm:other-pointer-type))
-
-(define-vop (code-from-function code-from-mumble)
-  (:translate di::function-code-header)
-  (:variant vm:function-pointer-type))
-
-(define-vop (make-lisp-obj)
-  (:policy :fast-safe)
-  (:translate di::make-lisp-obj)
-  (:args (value :scs (unsigned-reg) :target result))
-  (:arg-types unsigned-num)
-  (:results (result :scs (descriptor-reg)))
-  (:generator 1
-    (move result value)))
-
-(define-vop (get-lisp-obj-address)
-  (:policy :fast-safe)
-  (:translate di::get-lisp-obj-address)
-  (:args (thing :scs (descriptor-reg) :target result))
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 1
-    (move result thing)))
-
-
-(define-vop (function-word-offset)
-  (:policy :fast-safe)
-  (:translate di::function-word-offset)
-  (:args (fun :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 5
-    (loadw res fun 0 function-pointer-type)
-    (inst srl res vm:type-bits)))
diff --git a/compiler/sparc/float.lisp b/compiler/sparc/float.lisp
deleted file mode 100644
index b273ad7d5aa3d54012d0328265cb50428a30b646..0000000000000000000000000000000000000000
--- a/compiler/sparc/float.lisp
+++ /dev/null
@@ -1,520 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.10 1992/10/20 03:10:34 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains floating point support for the MIPS.
-;;;
-;;; Written by Rob MacLachlan
-;;; Sparc conversion by William Lott.
-;;;
-(in-package "SPARC")
-
-
-;;;; Move functions:
-
-(define-move-function (load-single 1) (vop x y)
-  ((single-stack) (single-reg))
-  (inst ldf y (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes)))
-
-(define-move-function (store-single 1) (vop x y)
-  ((single-reg) (single-stack))
-  (inst stf x (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes)))
-
-
-(define-move-function (load-double 2) (vop x y)
-  ((double-stack) (double-reg))
-  (let ((nfp (current-nfp-tn vop))
-	(offset (* (tn-offset x) vm:word-bytes)))
-    (inst lddf y nfp offset)))
-
-(define-move-function (store-double 2) (vop x y)
-  ((double-reg) (double-stack))
-  (let ((nfp (current-nfp-tn vop))
-	(offset (* (tn-offset y) vm:word-bytes)))
-    (inst stdf x nfp offset)))
-
-
-
-;;;; Move VOPs:
-
-(macrolet ((frob (vop sc double-p)
-	     `(progn
-		(define-vop (,vop)
-		  (:args (x :scs (,sc)
-			    :target y
-			    :load-if (not (location= x y))))
-		  (:results (y :scs (,sc)
-			       :load-if (not (location= x y))))
-		  (:note "float move")
-		  (:generator 0
-		    (unless (location= y x)
-		      (inst fmovs y x)
-		      ,@(when double-p
-			  '((inst fmovs-odd y x))))))
-		(define-move-vop ,vop :move (,sc) (,sc)))))
-  (frob single-move single-reg nil)
-  (frob double-move double-reg t))
-
-
-(define-vop (move-from-float)
-  (:args (x :to :save))
-  (:results (y))
-  (:note "float to pointer coercion")
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:variant-vars double-p size type data)
-  (:generator 13
-    (with-fixed-allocation (y ndescr type size))
-    (if double-p
-	(inst stdf x y (- (* data vm:word-bytes) vm:other-pointer-type))
-	(inst stf x y (- (* data vm:word-bytes) vm:other-pointer-type)))))
-
-(macrolet ((frob (name sc &rest args)
-	     `(progn
-		(define-vop (,name move-from-float)
-		  (:args (x :scs (,sc) :to :save))
-		  (:results (y :scs (descriptor-reg)))
-		  (:variant ,@args))
-		(define-move-vop ,name :move (,sc) (descriptor-reg)))))
-  (frob move-from-single single-reg
-    nil vm:single-float-size vm:single-float-type vm:single-float-value-slot)
-  (frob move-from-double double-reg
-    t vm:double-float-size vm:double-float-type vm:double-float-value-slot))
-
-(macrolet ((frob (name sc double-p value)
-	     `(progn
-		(define-vop (,name)
-		  (:args (x :scs (descriptor-reg)))
-		  (:results (y :scs (,sc)))
-		  (:note "pointer to float coercion")
-		  (:generator 2
-		    (inst ,(if double-p 'lddf 'ldf) y x
-			  (- (* ,value vm:word-bytes) vm:other-pointer-type))))
-		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
-  (frob move-to-single single-reg nil vm:single-float-value-slot)
-  (frob move-to-double double-reg t vm:double-float-value-slot))
-
-
-(macrolet ((frob (name sc stack-sc double-p)
-	     `(progn
-		(define-vop (,name)
-		  (:args (x :scs (,sc) :target y)
-			 (nfp :scs (any-reg)
-			      :load-if (not (sc-is y ,sc))))
-		  (:results (y))
-		  (:note "float argument move")
-		  (:generator ,(if double-p 2 1)
-		    (sc-case y
-		      (,sc
-		       (unless (location= x y)
-			 (inst fmovs y x)
-			 ,@(when double-p
-			     '((inst fmovs-odd y x)))))
-		      (,stack-sc
-		       (let ((offset (* (tn-offset y) vm:word-bytes)))
-			 (inst ,(if double-p 'stdf 'stf) x nfp offset))))))
-		(define-move-vop ,name :move-argument
-		  (,sc descriptor-reg) (,sc)))))
-  (frob move-single-float-argument single-reg single-stack nil)
-  (frob move-double-float-argument double-reg double-stack t))
-
-
-(define-move-vop move-argument :move-argument
-  (single-reg double-reg) (descriptor-reg))
-
-
-;;;; Arithmetic VOPs:
-
-(define-vop (float-op)
-  (:args (x) (y))
-  (:results (r))
-  (:policy :fast-safe)
-  (:note "inline float arithmetic")
-  (:vop-var vop)
-  (:save-p :compute-only))
-
-(macrolet ((frob (name sc ptype)
-	     `(define-vop (,name float-op)
-		(:args (x :scs (,sc))
-		       (y :scs (,sc)))
-		(:results (r :scs (,sc)))
-		(:arg-types ,ptype ,ptype)
-		(:result-types ,ptype))))
-  (frob single-float-op single-reg single-float)
-  (frob double-float-op double-reg double-float))
-
-(macrolet ((frob (op sinst sname scost dinst dname dcost)
-	     `(progn
-		(define-vop (,sname single-float-op)
-		  (:translate ,op)
-		  (:generator ,scost
-		    (inst ,sinst r x y)))
-		(define-vop (,dname double-float-op)
-		  (:translate ,op)
-		  (:generator ,dcost
-		    (inst ,dinst r x y))))))
-  (frob + fadds +/single-float 2 faddd +/double-float 2)
-  (frob - fsubs -/single-float 2 fsubd -/double-float 2)
-  (frob * fmuls */single-float 4 fmuld */double-float 5)
-  (frob / fdivs //single-float 12 fdivd //double-float 19))
-
-(macrolet ((frob (name inst translate double-p sc type)
-	     `(define-vop (,name)
-		(:args (x :scs (,sc)))
-		(:results (y :scs (,sc)))
-		(:translate ,translate)
-		(:policy :fast-safe)
-		(:arg-types ,type)
-		(:result-types ,type)
-		(:note "inline float arithmetic")
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 1
-		  (note-this-location vop :internal-error)
-		  (inst ,inst y x)
-		  ,@(when double-p
-		      '((inst fmovs-odd y x)))))))
-  (frob abs/single-float fabss abs nil single-reg single-float)
-  (frob abs/double-float fabss abs t double-reg double-float)
-  (frob %negate/single-float fnegs %negate nil single-reg single-float)
-  (frob %negate/double-float fnegs %negate t double-reg double-float))
-
-
-;;;; Comparison:
-
-(define-vop (float-compare)
-  (:args (x) (y))
-  (:conditional)
-  (:info target not-p)
-  (:variant-vars format yep nope)
-  (:policy :fast-safe)
-  (:note "inline float comparison")
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 3
-    (note-this-location vop :internal-error)
-    (ecase format
-      (:single (inst fcmps x y))
-      (:double (inst fcmpd x y)))
-    (inst nop)
-    (inst fb (if not-p nope yep) target)
-    (inst nop)))
-
-(macrolet ((frob (name sc ptype)
-	     `(define-vop (,name float-compare)
-		(:args (x :scs (,sc))
-		       (y :scs (,sc)))
-		(:arg-types ,ptype ,ptype))))
-  (frob single-float-compare single-reg single-float)
-  (frob double-float-compare double-reg double-float))
-
-(macrolet ((frob (translate yep nope sname dname)
-	     `(progn
-		(define-vop (,sname single-float-compare)
-		  (:translate ,translate)
-		  (:variant :single ,yep ,nope))
-		(define-vop (,dname double-float-compare)
-		  (:translate ,translate)
-		  (:variant :double ,yep ,nope)))))
-  (frob < :l :ge </single-float </double-float)
-  (frob > :g :le >/single-float >/double-float)
-  (frob eql :eq :ne eql/single-float eql/double-float))
-
-
-;;;; Conversion:
-
-(macrolet ((frob (name translate inst to-sc to-type)
-	     `(define-vop (,name)
-		(:args (x :scs (signed-reg) :target temp
-			  :load-if (not (sc-is x signed-stack))))
-		(:temporary (:scs (single-stack)) temp)
-		(:results (y :scs (,to-sc)))
-		(:arg-types signed-num)
-		(:result-types ,to-type)
-		(:policy :fast-safe)
-		(:note "inline float coercion")
-		(:translate ,translate)
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 5
-		  (let ((stack-tn
-			 (sc-case x
-			   (signed-reg
-			    (inst st x
-				  (current-nfp-tn vop)
-				  (* (tn-offset temp) vm:word-bytes))
-			    temp)
-			   (signed-stack
-			    x))))
-		    (inst ldf y
-			  (current-nfp-tn vop)
-			  (* (tn-offset stack-tn) vm:word-bytes))
-		    (note-this-location vop :internal-error)
-		    (inst ,inst y y))))))
-  (frob %single-float/signed %single-float fitos single-reg single-float)
-  (frob %double-float/signed %double-float fitod double-reg double-float))
-
-(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
-	     `(define-vop (,name)
-		(:args (x :scs (,from-sc)))
-		(:results (y :scs (,to-sc)))
-		(:arg-types ,from-type)
-		(:result-types ,to-type)
-		(:policy :fast-safe)
-		(:note "inline float coercion")
-		(:translate ,translate)
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 2
-		  (note-this-location vop :internal-error)
-		  (inst ,inst y x)))))
-  (frob %single-float/double-float %single-float fdtos
-    double-reg double-float single-reg single-float)
-  (frob %double-float/single-float %double-float fstod
-    single-reg single-float double-reg double-float))
-
-(macrolet ((frob (trans from-sc from-type inst)
-	     `(define-vop (,(symbolicate trans "/" from-type))
-		(:args (x :scs (,from-sc) :target temp))
-		(:temporary (:from (:argument 0) :sc single-reg) temp)
-		(:temporary (:scs (signed-stack)) stack-temp)
-		(:results (y :scs (signed-reg)
-			     :load-if (not (sc-is y signed-stack))))
-		(:arg-types ,from-type)
-		(:result-types signed-num)
-		(:translate ,trans)
-		(:policy :fast-safe)
-		(:note "inline float truncate")
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:generator 5
-		  (note-this-location vop :internal-error)
-		  (inst ,inst temp x)
-		  (sc-case y
-		    (signed-stack
-		     (inst stf temp (current-nfp-tn vop)
-			   (* (tn-offset y) vm:word-bytes)))
-		    (signed-reg
-		     (inst stf temp (current-nfp-tn vop)
-			   (* (tn-offset stack-temp) vm:word-bytes))
-		     (inst ld y (current-nfp-tn vop)
-			   (* (tn-offset stack-temp) vm:word-bytes))))))))
-  (frob %unary-truncate single-reg single-float fstoi)
-  (frob %unary-truncate double-reg double-float fdtoi)
-  #-sun4
-  (frob %unary-round single-reg single-float fstoir)
-  #-sun4
-  (frob %unary-round double-reg double-float fdtoir))
-
-#+sun4
-(deftransform %unary-round ((x) (float) (signed-byte 32))
-  '(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x)))
-	  (extra (- x trunc))
-	  (absx (abs extra))
-	  (one-half (float 1/2 x)))
-     (if (if (oddp trunc)
-	     (>= absx one-half)
-	     (> absx one-half))
-	 (truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
-	 trunc)))
-
-(define-vop (make-single-float)
-  (:args (bits :scs (signed-reg) :target res
-	       :load-if (not (sc-is bits signed-stack))))
-  (:results (res :scs (single-reg)
-		 :load-if (not (sc-is res single-stack))))
-  (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
-  (:temporary (:scs (signed-stack)) stack-temp)
-  (:arg-types signed-num)
-  (:result-types single-float)
-  (:translate make-single-float)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:generator 4
-    (sc-case bits
-      (signed-reg
-       (sc-case res
-	 (single-reg
-	  (inst st bits (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes))
-	  (inst ldf res (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes)))
-	 (single-stack
-	  (inst st bits (current-nfp-tn vop)
-		(* (tn-offset res) vm:word-bytes)))))
-      (signed-stack
-       (sc-case res
-	 (single-reg
-	  (inst ldf res (current-nfp-tn vop)
-		(* (tn-offset bits) vm:word-bytes)))
-	 (single-stack
-	  (unless (location= bits res)
-	    (inst ld temp (current-nfp-tn vop)
-		  (* (tn-offset bits) vm:word-bytes))
-	    (inst st temp (current-nfp-tn vop)
-		  (* (tn-offset res) vm:word-bytes)))))))))
-
-(define-vop (make-double-float)
-  (:args (hi-bits :scs (signed-reg))
-	 (lo-bits :scs (unsigned-reg)))
-  (:results (res :scs (double-reg)
-		 :load-if (not (sc-is res double-stack))))
-  (:temporary (:scs (double-stack)) temp)
-  (:arg-types signed-num unsigned-num)
-  (:result-types double-float)
-  (:translate make-double-float)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:generator 2
-    (let ((stack-tn (sc-case res
-		      (double-stack res)
-		      (double-reg temp))))
-      (inst st hi-bits (current-nfp-tn vop)
-	    (* (tn-offset stack-tn) vm:word-bytes))
-      (inst st lo-bits (current-nfp-tn vop)
-	    (* (1+ (tn-offset stack-tn)) vm:word-bytes)))
-    (when (sc-is res double-reg)
-      (inst lddf res (current-nfp-tn vop)
-	    (* (tn-offset temp) vm:word-bytes)))))
-
-(define-vop (single-float-bits)
-  (:args (float :scs (single-reg descriptor-reg)
-		:load-if (not (sc-is float single-stack))))
-  (:results (bits :scs (signed-reg)
-		  :load-if (or (sc-is float descriptor-reg single-stack)
-			       (not (sc-is bits signed-stack)))))
-  (:temporary (:scs (signed-stack)) stack-temp)
-  (:arg-types single-float)
-  (:result-types signed-num)
-  (:translate single-float-bits)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:generator 4
-    (sc-case bits
-      (signed-reg
-       (sc-case float
-	 (single-reg
-	  (inst stf float (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes))
-	  (inst ld bits (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes)))
-	 (single-stack
-	  (inst ld bits (current-nfp-tn vop)
-		(* (tn-offset float) vm:word-bytes)))
-	 (descriptor-reg
-	  (loadw bits float vm:single-float-value-slot vm:other-pointer-type))))
-      (signed-stack
-       (sc-case float
-	 (single-reg
-	  (inst stf float (current-nfp-tn vop)
-		(* (tn-offset bits) vm:word-bytes))))))))
-
-(define-vop (double-float-high-bits)
-  (:args (float :scs (double-reg descriptor-reg)
-		:load-if (not (sc-is float double-stack))))
-  (:results (hi-bits :scs (signed-reg)
-		     :load-if (or (sc-is float descriptor-reg double-stack)
-				  (not (sc-is hi-bits signed-stack)))))
-  (:temporary (:scs (signed-stack)) stack-temp)
-  (:arg-types double-float)
-  (:result-types signed-num)
-  (:translate double-float-high-bits)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:generator 5
-    (sc-case hi-bits
-      (signed-reg
-       (sc-case float
-	 (double-reg
-	  (inst stf float (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes))
-	  (inst ld hi-bits (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes)))
-	 (double-stack
-	  (inst ld hi-bits (current-nfp-tn vop)
-		(* (tn-offset float) vm:word-bytes)))
-	 (descriptor-reg
-	  (loadw hi-bits float vm:double-float-value-slot
-		 vm:other-pointer-type))))
-      (signed-stack
-       (sc-case float
-	 (double-reg
-	  (inst stf float (current-nfp-tn vop)
-		(* (tn-offset hi-bits) vm:word-bytes))))))))
-
-(define-vop (double-float-low-bits)
-  (:args (float :scs (double-reg descriptor-reg)
-		:load-if (not (sc-is float double-stack))))
-  (:results (lo-bits :scs (unsigned-reg)
-		     :load-if (or (sc-is float descriptor-reg double-stack)
-				  (not (sc-is lo-bits unsigned-stack)))))
-  (:temporary (:scs (unsigned-stack)) stack-temp)
-  (:arg-types double-float)
-  (:result-types unsigned-num)
-  (:translate double-float-low-bits)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:generator 5
-    (sc-case lo-bits
-      (unsigned-reg
-       (sc-case float
-	 (double-reg
-	  (inst stf-odd float (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes))
-	  (inst ld lo-bits (current-nfp-tn vop)
-		(* (tn-offset stack-temp) vm:word-bytes)))
-	 (double-stack
-	  (inst ld lo-bits (current-nfp-tn vop)
-		(* (1+ (tn-offset float)) vm:word-bytes)))
-	 (descriptor-reg
-	  (loadw lo-bits float (1+ vm:double-float-value-slot)
-		 vm:other-pointer-type))))
-      (unsigned-stack
-       (sc-case float
-	 (double-reg
-	  (inst stf-odd float (current-nfp-tn vop)
-		(* (tn-offset lo-bits) vm:word-bytes))))))))
-
-
-;;;; Float mode hackery:
-
-(deftype float-modes () '(unsigned-byte 32))
-(defknown floating-point-modes () float-modes (flushable))
-(defknown ((setf floating-point-modes)) (float-modes)
-  float-modes)
-
-(define-vop (floating-point-modes)
-  (:results (res :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:translate floating-point-modes)
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:temporary (:sc unsigned-stack) temp)
-  (:generator 3
-    (let ((nfp (current-nfp-tn vop)))
-      (inst stfsr nfp (* word-bytes (tn-offset temp)))
-      (loadw res nfp (tn-offset temp))
-      (inst nop))))
-
-(define-vop (set-floating-point-modes)
-  (:args (new :scs (unsigned-reg) :target res))
-  (:results (res :scs (unsigned-reg)))
-  (:arg-types unsigned-num)
-  (:result-types unsigned-num)
-  (:translate (setf floating-point-modes))
-  (:policy :fast-safe)
-  (:temporary (:sc unsigned-stack) temp)
-  (:vop-var vop)
-  (:generator 3
-    (let ((nfp (current-nfp-tn vop)))
-      (storew new nfp (tn-offset temp))
-      (inst ldfsr nfp (* word-bytes (tn-offset temp)))
-      (move res new))))
diff --git a/compiler/sparc/insts.lisp b/compiler/sparc/insts.lisp
deleted file mode 100644
index 2cb290326bf713731dbcc5fcec7bc51c024e8361..0000000000000000000000000000000000000000
--- a/compiler/sparc/insts.lisp
+++ /dev/null
@@ -1,890 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.10 1992/07/23 17:46:06 hallgren Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Description of the SPARC architecture.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "SPARC")
-
-(use-package "NEW-ASSEM")
-(use-package "EXT")
-(use-package "C")
-
-(def-assembler-params
-    :scheduler-p nil)
-
-
-;;;; Constants, types, conversion functions, some disassembler stuff.
-
-(defun reg-tn-encoding (tn)
-  (declare (type tn tn))
-  (sc-case tn
-    (zero zero-offset)
-    (null null-offset)
-    (t
-     (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
-	 (tn-offset tn)
-	 (error "~S isn't a register." tn)))))
-
-(defun fp-reg-tn-encoding (tn &optional odd)
-  (declare (type tn tn))
-  (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
-    (error "~S isn't a floating-point register." tn))
-  (if odd
-      (1+ (tn-offset tn))
-      (tn-offset tn)))
-
-(disassem:set-disassem-params :instruction-alignment 32)
-
-(defvar *disassem-use-lisp-reg-names* t)
-
-(defconstant reg-symbols
-  (map 'vector
-       #'(lambda (name)
-	   (cond ((null name) nil)
-		 (t (make-symbol (concatenate 'string "%" name)))))
-       sparc::*register-names*))
-
-(disassem:define-argument-type reg
-  :printer #'(lambda (value stream dstate)
-	       (declare (stream stream) (fixnum value))
-	       (let ((regname (aref reg-symbols value)))
-		 (princ regname stream)
-		 (disassem:maybe-note-associated-storage-ref
-		  value
-		  'registers
-		  regname
-		  dstate))))
-
-(defconstant float-reg-symbols
-  (coerce 
-   (loop for n from 0 to 31 collect (make-symbol (format nil "%F~d" n)))
-   'vector))
-
-(disassem:define-argument-type fp-reg
-  :printer #'(lambda (value stream dstate)
-	       (declare (stream stream) (fixnum value))
-	       (let ((regname (aref float-reg-symbols value)))
-		 (princ regname stream)
-		 (disassem:maybe-note-associated-storage-ref
-		  value
-		  'float-registers
-		  regname
-		  dstate))))
-
-(disassem:define-argument-type relative-label
-  :sign-extend t
-  :use-label #'(lambda (value dstate)
-		 (declare (type (signed-byte 13) value)
-			  (type disassem:disassem-state dstate))
-		 (+ (ash value 2) (disassem:dstate-cur-addr dstate))))
-
-(defconstant branch-conditions
-  '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc))
-
-;;; Note that these aren't the standard names for branch-conditions, I think
-;;; they're a bit more readable (e.g., "eq" instead of "e").  You could just
-;;; put a vector of the normal ones here too.
-(defconstant branch-cond-name-vec
-  (coerce branch-conditions 'vector))
-
-(disassem:define-argument-type branch-condition
-  :printer branch-cond-name-vec)
-
-(deftype branch-condition ()
-  `(member ,@branch-conditions))
-
-(defun branch-condition (condition)
-  (or (position condition branch-conditions)
-      (error "Unknown branch condition: ~S~%Must be one of: ~S"
-	     condition branch-conditions)))
-
-(defconstant branch-cond-true
-  #b1000)
-
-(defconstant branch-fp-conditions
-  '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o))
-
-(defconstant branch-fp-cond-name-vec
-  (coerce branch-fp-conditions 'vector))
-
-(disassem:define-argument-type branch-fp-condition
-  :printer branch-fp-cond-name-vec)
-
-(disassem:define-argument-type call-fixup :use-label t)
-
-(deftype fp-branch-condition ()
-  `(member ,@branch-fp-conditions))
-
-(defun fp-branch-condition (condition)
-  (or (position condition branch-fp-conditions)
-      (error "Unknown fp-branch condition: ~S~%Must be one of: ~S"
-	     condition branch-fp-conditions)))
-
-
-;;;; dissassem:define-instruction-formats
-
-(disassem:define-instruction-format
-    (format-1 32 :default-printer '(:name :tab disp))
-  (op   :field (byte 2 30) :value 1)
-  (disp :field (byte 30 0)))
-
-(disassem:define-instruction-format
-    (format-2-immed 32 :default-printer '(:name :tab immed ", " rd))
-  (op    :field (byte 2 30) :value 0)
-  (rd    :field (byte 5 25) :type 'reg)
-  (op2   :field (byte 3 22))
-  (immed :field (byte 22 0)))
-
-(defconstant branch-printer
-  `(:name (:unless (:constant ,branch-cond-true) cond)
-	  (:unless (a :constant 0) "," 'A)
-	  :tab
-	  disp))
-
-(disassem:define-instruction-format
-    (format-2-branch 32 :default-printer branch-printer)
-  (op   :field (byte 2 30) :value 0)
-  (a    :field (byte 1 29) :value 0)
-  (cond :field (byte 4 25) :type 'branch-condition)
-  (op2  :field (byte 3 22))
-  (disp :field (byte 22 0) :type 'relative-label))
-
-(disassem:define-instruction-format
-    (format-2-unimp 32 :default-printer '(:name :tab data))
-  (op     :field (byte 2 30) :value 0)
-  (ignore :field (byte 5 25) :value 0)
-  (op2    :field (byte 3 22) :value 0)
-  (data   :field (byte 22 0)))
-
-(defconstant f3-printer
-  '(:name :tab
-	  (:unless (:same-as rd) rs1 ", ")
-	  (:choose rs2 immed) ", "
-	  rd))
-
-(disassem:define-instruction-format
-    (format-3-reg 32 :default-printer f3-printer)
-  (op  :field (byte 2 30))
-  (rd  :field (byte 5 25) :type 'reg)
-  (op3 :field (byte 6 19))
-  (rs1 :field (byte 5 14) :type 'reg)
-  (i   :field (byte 1 13) :value 0)
-  (asi :field (byte 8 5)  :value 0)
-  (rs2 :field (byte 5 0)  :type 'reg))
-
-(disassem:define-instruction-format
-    (format-3-immed 32 :default-printer f3-printer)
-  (op    :field (byte 2 30))
-  (rd    :field (byte 5 25) :type 'reg)
-  (op3   :field (byte 6 19))
-  (rs1   :field (byte 5 14) :type 'reg)
-  (i     :field (byte 1 13) :value 1)
-  (immed :field (byte 13 0) :sign-extend t))	; usually sign extended
-
-(disassem:define-instruction-format
-    (format-3-fpop 32
-     :default-printer
-        '(:name :tab (:unless (:same-as rd) rs1 ", ") rs2 ", " rd))
-  (op	:field (byte 2 30))
-  (rd 	:field (byte 5 25) :type 'fp-reg)
-  (op3  :field (byte 6 19))
-  (rs1  :field (byte 5 14) :type 'fp-reg)
-  (opf  :field (byte 9 5))
-  (rs2  :field (byte 5 0) :type 'fp-reg))
-
-
-
-;;;; Primitive emitters.
-
-(define-emitter emit-word 32
-  (byte 32 0))
-
-(define-emitter emit-short 16
-  (byte 16 0))
-
-(define-emitter emit-format-1 32
-  (byte 2 30) (byte 30 0))
-
-(define-emitter emit-format-2-immed 32
-  (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
-
-(define-emitter emit-format-2-branch 32
-  (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 22 0))
-
-(define-emitter emit-format-2-unimp 32
-  (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
-
-(define-emitter emit-format-3-reg 32
-  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 8 5)
-  (byte 5 0))
-
-(define-emitter emit-format-3-immed 32
-  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 13 0))
-
-(define-emitter emit-format-3-fpop 32
-  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 9 5) (byte 5 0))
-
-
-
-;;;; Most of the format-3-instructions.
-
-(defun emit-format-3-inst (segment op op3 dst src1 src2
-				   &key load-store fixup dest-kind odd)
-  (unless src2
-    (cond ((and (typep src1 'tn) load-store)
-	   (setf src2 0))
-	  (t
-	   (setf src2 src1)
-	   (setf src1 dst))))
-  (etypecase src2
-    (tn
-     (emit-format-3-reg segment op
-			(if dest-kind
-			    (fp-reg-tn-encoding dst odd)
-			    (reg-tn-encoding dst))
-			op3 (reg-tn-encoding src1) 0 0 (reg-tn-encoding src2)))
-    (integer
-     (emit-format-3-immed segment op
-			  (if dest-kind
-			      (fp-reg-tn-encoding dst odd)
-			      (reg-tn-encoding dst))
-			  op3 (reg-tn-encoding src1) 1 src2))
-    (fixup
-     (unless (or load-store fixup)
-       (error "Fixups aren't allowed."))
-     (note-fixup segment :add src2)
-     (emit-format-3-immed segment op
-			  (if dest-kind
-			      (fp-reg-tn-encoding dst odd)
-			      (reg-tn-encoding dst))
-			  op3 (reg-tn-encoding src1) 1 0))))
-
-(eval-when (compile eval)
-
-;;; have to do this because defconstant is evalutated in the null lex env.
-(defmacro with-ref-format (printer)
-  `(let* ((addend
-	   '(:choose (:plus-integer immed) ("+" rs2)))
-	  (ref-format
-	   `("[" rs1 (:unless (:constant 0) ,addend) "]"
-	     (:choose (:unless (:constant 0) asi) nil))))
-     ,printer))
-
-(defconstant load-printer
-  (with-ref-format `(:NAME :TAB ,ref-format ", " rd)))
-
-(defconstant store-printer
-  (with-ref-format `(:NAME :TAB rd ", " ,ref-format)))
-
-(defmacro define-f3-inst (name op op3 &key fixup load-store (dest-kind 'reg)
-			       (printer :default))
-  (let ((printer
-	 (if (eq printer :default)
-	     (case load-store
-	       ((nil) :default)
-	       ((:load t) 'load-printer)
-	       (:store 'store-printer))
-	     printer)))
-    `(define-instruction ,name (segment dst src1 &optional src2)
-       (:declare (type tn dst)
-		 ,(if (or fixup load-store)
-		      '(type (or tn (signed-byte 13) null fixup) src1 src2)
-		      '(type (or tn (signed-byte 13) null) src1 src2)))
-       ,@(unless (eq dest-kind 'odd-fp-reg)
-	   `((:printer format-3-reg
-		       ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
-		       ,printer)
-	     (:printer format-3-immed
-		       ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
-		       ,printer)))
-       (:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2
-				     :load-store ,load-store
-				     :fixup ,fixup
-				     :dest-kind (not (eq ',dest-kind 'reg))
-				     :odd (eq ',dest-kind 'odd-fp-reg))))))
-
-) ; eval-when (compile eval)
-
-(define-f3-inst ldsb #b11 #b001001 :load-store :load)
-(define-f3-inst ldsh #b11 #b001010 :load-store :load)
-(define-f3-inst ldub #b11 #b000001 :load-store :load)
-(define-f3-inst lduh #b11 #b000010 :load-store :load)
-(define-f3-inst ld #b11 #b000000 :load-store :load)
-(define-f3-inst ldd #b11 #b000011 :load-store :load)
-(define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load)
-(define-f3-inst ldf-odd #b11 #b100000 :dest-kind odd-fp-reg :load-store :load)
-(define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store :load)
-(define-f3-inst stb #b11 #b000101 :load-store :store)
-(define-f3-inst sth #b11 #b000110 :load-store :store)
-(define-f3-inst st #b11 #b000100 :load-store :store)
-(define-f3-inst std #b11 #b000111 :load-store :store)
-(define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store)
-(define-f3-inst stf-odd #b11 #b100100 :dest-kind odd-fp-reg :load-store :store)
-(define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store :store)
-(define-f3-inst ldstub #b11 #b001101 :load-store t)
-(define-f3-inst swap #b11 #b001111 :load-store t)
-(define-f3-inst add #b10 #b000000 :fixup t)
-(define-f3-inst addcc #b10 #b010000)
-(define-f3-inst addx #b10 #b001000)
-(define-f3-inst addxcc #b10 #b011000)
-(define-f3-inst taddcc #b10 #b100000)
-(define-f3-inst taddcctv #b10 #b100010)
-(define-f3-inst sub #b10 #b000100)
-(define-f3-inst subcc #b10 #b010100)
-(define-f3-inst subx #b10 #b001100)
-(define-f3-inst subxcc #b10 #b011100)
-(define-f3-inst tsubcc #b10 #b100001)
-(define-f3-inst tsubcctv #b10 #b100011)
-(define-f3-inst mulscc #b10 #b100100)
-(define-f3-inst and #b10 #b000001)
-(define-f3-inst andcc #b10 #b010001)
-(define-f3-inst andn #b10 #b000101)
-(define-f3-inst andncc #b10 #b010101)
-(define-f3-inst or #b10 #b000010)
-(define-f3-inst orcc #b10 #b010010)
-(define-f3-inst orn #b10 #b000110)
-(define-f3-inst orncc #b10 #b010110)
-(define-f3-inst xor #b10 #b000011)
-(define-f3-inst xorcc #b10 #b010011)
-(define-f3-inst xnor #b10 #b000111)
-(define-f3-inst xnorcc #b10 #b010111)
-(define-f3-inst sll #b10 #b100101)
-(define-f3-inst srl #b10 #b100110)
-(define-f3-inst sra #b10 #b100111)
-(define-f3-inst save #b10 #b111100)
-(define-f3-inst restore #b10 #b111101)
-
-
-
-;;;; Random instructions.
-
-(define-instruction ldfsr (segment src1 src2)
-  (:declare (type tn src1) (type (signed-byte 13) src2))
-  (:printer format-3-immed ((op #b11) (op3 #b100001)))
-  (:reads (list src1 :memory))
-  (:writes :float-status)
-  (:emitter (emit-format-3-immed segment #b11 0 #b100001
-				 (reg-tn-encoding src1) 1 src2)))
-
-(define-instruction stfsr (segment src1 src2)
-  (:declare (type tn src1) (type (signed-byte 13) src2))
-  (:printer format-3-immed ((op #b11) (op3 #b100101)))
-  (:reads (list src1 :float-status))
-  (:writes :memory)
-  (:emitter (emit-format-3-immed segment #b11 0 #b100101 
-				 (reg-tn-encoding src1) 1 src2)))
-
-(eval-when (compile load eval)
-  (defun sethi-arg-printer (value stream dstate)
-    (declare (ignore dstate))
-    (format stream "%hi(#x~8,'0x)" (ash value 10)))
-) ; eval-when (compile load eval)
-
-(define-instruction sethi (segment dst src1)
-  (:declare (type tn dst)
-	    (type (or (signed-byte 22) (unsigned-byte 22) fixup) src1))
-  (:printer format-2-immed
-            ((op2 #b100) (immed nil :printer #'sethi-arg-printer)))
-  (:writes dst)
-  (:emitter
-   (etypecase src1
-     (integer
-      (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100
-				 src1))
-     (fixup
-      (note-fixup segment :sethi src1)
-      (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 0)))))
-			   
-(define-instruction rdy (segment dst)
-  (:declare (type tn dst))
-  (:printer format-3-immed ((op #b10) (op3 #b101000) (rs1 0) (immed 0))
-            '('RD :tab '%Y ", " rd))
-  (:reads dst)
-  (:emitter (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b101000
-				 0 1 0)))
-
-(defconstant wry-printer
-  '('WR :tab rs1 (:unless (:constant 0) ", " (:choose immed rs2)) ", " '%Y))
-
-(define-instruction wry (segment src1 &optional src2)
-  (:declare (type tn src1) (type (or (signed-byte 13) tn null) src2))
-  (:printer format-3-reg ((op #b10) (op3 #b110000) (rd 0)) wry-printer)
-  (:printer format-3-immed ((op #b10) (op3 #b110000) (rd 0)) wry-printer)
-  (:writes (if src2 (list src1 src2) src1))
-  (:delay 3)
-  (:emitter
-   (etypecase src2
-     (null 
-      (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 0))
-     (tn
-      (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0
-			 (reg-tn-encoding src2)))
-     (integer
-      (emit-format-3-immed segment #b10 0 #b110000 (reg-tn-encoding src1) 1
-			   src2)))))
-
-(defun snarf-error-junk (sap offset &optional length-only)
-  (let* ((length (system:sap-ref-8 sap offset))
-         (vector (make-array length :element-type '(unsigned-byte 8))))
-    (declare (type system:system-area-pointer sap)
-             (type (unsigned-byte 8) length)
-             (type (simple-array (unsigned-byte 8) (*)) vector))
-    (cond (length-only
-           (values 0 (1+ length) nil nil))
-          (t
-           (kernel:copy-from-system-area sap (* sparc:byte-bits (1+ offset))
-                                         vector (* sparc:word-bits
-                                                   sparc:vector-data-offset)
-                                         (* length sparc:byte-bits))
-           (collect ((sc-offsets)
-                     (lengths))
-             (lengths 1)                ; the length byte
-             (let* ((index 0)
-                    (error-number (c::read-var-integer vector index)))
-               (lengths index)
-               (loop
-                 (when (>= index length)
-                   (return))
-                 (let ((old-index index))
-                   (sc-offsets (c::read-var-integer vector index))
-                   (lengths (- index old-index))))
-               (values error-number
-                       (1+ length)
-                       (sc-offsets)
-                       (lengths))))))))
-
-(defun unimp-control (chunk inst stream dstate)
-  (declare (ignore inst))
-  (flet ((nt (x) (if stream (disassem:note x dstate))))
-    (case (format-2-unimp-data chunk dstate)
-      (#.vm:error-trap
-       (nt "Error trap")
-       (disassem:handle-break-args #'snarf-error-junk stream dstate))
-      (#.vm:cerror-trap
-       (nt "Cerror trap")
-       (disassem:handle-break-args #'snarf-error-junk stream dstate))
-      (#.vm:object-not-list-trap
-       (nt "Object not list trap"))
-      (#.vm:breakpoint-trap
-       (nt "Breakpoint trap"))
-      (#.vm:pending-interrupt-trap
-       (nt "Pending interrupt trap"))
-      (#.vm:halt-trap
-       (nt "Halt trap"))
-      (#.vm:function-end-breakpoint-trap
-       (nt "Function end breakpoint trap"))
-      (#.vm:object-not-structure-trap
-       (nt "Object not structure trap"))
-    )))
-
-(define-instruction unimp (segment data)
-  (:declare (type (unsigned-byte 22) data))
-  (:printer format-2-unimp () :default :control #'unimp-control)
-  (:emitter (emit-format-2-unimp segment 0 0 0 data)))
-
-
-
-;;;; Branch instructions.
-
-(defun emit-relative-branch (segment a op2 cond-or-target target &optional fp)
-  (emit-back-patch segment 4
-		  #'(lambda (segment posn)
-		      (unless target
-			(setf target cond-or-target)
-			(setf cond-or-target :t))
-		      (emit-format-2-branch
-		       segment #b00 a
-		       (if fp
-			   (fp-branch-condition cond-or-target)
-			   (branch-condition cond-or-target))
-		       op2
-		       (ash (- (label-position target) posn) -2)))))
-
-(define-instruction b (segment cond-or-target &optional target)
-  (:declare (type (or label branch-condition) cond-or-target)
-	    (type (or label null) target))
-  (:printer format-2-branch ((op #b00) (op2 #b010)))
-  (:emitter
-   (emit-relative-branch segment 0 #b010 cond-or-target target)))
-
-(define-instruction ba (segment cond-or-target &optional target)
-  (:declare (type (or label branch-condition) cond-or-target)
-	    (type (or label null) target))
-  (:printer format-2-branch ((op #b00) (op2 #b010) (a 1))
-            nil
-            :print-name 'b)
-  (:emitter
-   (emit-relative-branch segment 1 #b010 cond-or-target target)))
-
-(define-instruction t (segment condition target)
-  (:declare (type branch-condition condition)
-	    (type (or (signed-byte 13) (unsigned-byte 13)) target))
-  (:printer format-3-immed ((op #b10)
-                            (rd nil :type 'branch-condition)
-                            (op3 #b111010)
-                            (rs1 0))
-            '(:name rd :tab immed))
-  (:emitter (emit-format-3-immed segment #b10 (branch-condition condition)
-				 #b111010 0 1 target)))
-
-(define-instruction fb (segment condition target)
-  (:declare (type fp-branch-condition condition) (type label target))
-  (:printer format-2-branch ((Op #B00)
-                             (cond nil :type 'branch-fp-condition)
-                             (op2 #b110)))
-  (:emitter
-   (emit-relative-branch segment 0 #b110 condition target t)))
-
-(defconstant jal-printer
-  '(:name :tab
-          (:choose (rs1 (:unless (:constant 0) (:plus-integer immed)))
-                   (:cond ((rs2 :constant 0) rs1)
-                          ((rs1 :constant 0) rs2)
-                          (t rs1 "+" rs2)))
-          (:unless (:constant 0) ", " rd)))
-
-(define-instruction jal (segment dst src1 &optional src2)
-  (:declare (type tn dst)
-	    (type (or tn integer) src1)
-	    (type (or null fixup tn (signed-byte 13)) src2))
-  (:printer format-3-reg ((op #b10) (op3 #b111000)) jal-printer)
-  (:printer format-3-immed ((op #b10) (op3 #b111000)) jal-printer)
-  (:emitter
-   (unless src2
-     (setf src2 src1)
-     (setf src1 0))
-   (etypecase src2
-     (tn
-      (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b111000
-			 (if (integerp src1)
-			     src1
-			     (reg-tn-encoding src1))
-			 0 0 (reg-tn-encoding src2)))
-     (integer
-      (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b111000
-			   (reg-tn-encoding src1) 1 src2))
-     (fixup
-      (note-fixup segment :add src2)
-      (emit-format-3-immed segment #b10 (reg-tn-encoding dst)
-			   #b111000 (reg-tn-encoding src1) 1 0)))))
-
-(define-instruction j (segment src1 &optional src2)
-  (:declare (type tn src1) (type (or tn (signed-byte 13) fixup null) src2))
-  (:printer format-3-reg ((op #b10) (op3 #b111000) (rd 0)) jal-printer)
-  (:printer format-3-immed ((op #b10) (op3 #b111000) (rd 0)) jal-printer)
-  (:emitter
-   (etypecase src2
-     (null
-      (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0 0))
-     (tn
-      (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0
-			 (reg-tn-encoding src2)))
-     (integer
-      (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
-			   src2))
-     (fixup
-      (note-fixup segment :add src2)
-      (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
-			   0)))))
-
-
-
-;;;; Unary and binary fp insts.
-
-(defun emit-fp-inst (segment opf op3 dst src1 src2)
-  (unless src2
-    (setf src2 src1)
-    (setf src1 dst))
-  (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst) op3
-		      (fp-reg-tn-encoding src1) opf (fp-reg-tn-encoding src2)))
-
-(eval-when (compile eval)
-
-(defmacro define-unary-fp-inst (name opf)
-  `(define-instruction ,name (segment dst src1 &optional src2)
-     (:declare (type tn dst src1) (type (or null tn) src2))
-     (:printer format-3-fpop ((op #b10) (op3 #b110100) (opf ,opf)))
-     (:emitter (emit-fp-inst segment ,opf #b110100 dst src1 src2))))
-
-(defmacro define-binary-fp-inst (name opf &optional (op3 #b110100))
-  `(define-instruction ,name (segment dst src1 &optional src2)
-     (:declare (type tn dst src1) (type (or null tn) src2))
-     (:printer format-3-fpop ((op #b10) (op3 ,op3) (opf ,opf)))
-     (:emitter (emit-fp-inst segment ,opf ,op3 dst src1 src2))))
-  
-); eval-when (compile eval)
-
-
-(define-unary-fp-inst fitos #b011000100)
-(define-unary-fp-inst fitod #b011001000)
-(define-unary-fp-inst fitox #b011001100)
-
-(define-unary-fp-inst fstoir #b011000001)
-(define-unary-fp-inst fdtoir #b011000010)
-(define-unary-fp-inst fxtoir #b011000011)
-
-(define-unary-fp-inst fstoi #b011010001)
-(define-unary-fp-inst fdtoi #b011010010)
-(define-unary-fp-inst fxtoi #b011010011)
-
-(define-unary-fp-inst fstod #b011001001)
-(define-unary-fp-inst fstox #b011001101)
-(define-unary-fp-inst fdtos #b011000110)
-(define-unary-fp-inst fdtox #b011001110)
-(define-unary-fp-inst fxtos #b011000111)
-(define-unary-fp-inst fxtod #b011001011)
-
-(define-unary-fp-inst fmovs #b000000001)
-(define-instruction fmovs-odd (segment dst src1 &optional src2)
-  (:declare (type tn dst src1) (type (or null tn) src2))
-  (:emitter (emit-fp-inst segment #b000000001 #b110100 dst src1 src2)))
-(define-unary-fp-inst fnegs #b000000101)
-(define-unary-fp-inst fabss #b000001001)
-
-(define-unary-fp-inst fsqrts #b000101001)
-(define-unary-fp-inst fsqrtd #b000101010)
-(define-unary-fp-inst fsqrtx #b000101011)
-
-
-
-(define-binary-fp-inst fadds #b001000001)
-(define-binary-fp-inst faddd #b001000010)
-(define-binary-fp-inst faddx #b001000011)
-(define-binary-fp-inst fsubs #b001000101)
-(define-binary-fp-inst fsubd #b001000110)
-(define-binary-fp-inst fsubx #b001000111)
-
-(define-binary-fp-inst fmuls #b001001001)
-(define-binary-fp-inst fmuld #b001001010)
-(define-binary-fp-inst fmulx #b001001011)
-(define-binary-fp-inst fdivs #b001001101)
-(define-binary-fp-inst fdivd #b001001110)
-(define-binary-fp-inst fdivx #b001001111)
-
-(define-binary-fp-inst fcmps #b001010001 #b110101)
-(define-binary-fp-inst fcmpd #b001010010 #b110101)
-(define-binary-fp-inst fcmpx #b001010011 #b110101)
-(define-binary-fp-inst fcmpes #b001010101 #b110101)
-(define-binary-fp-inst fcmped #b001010110 #b110101)
-(define-binary-fp-inst fcmpex #b001010111 #b110101)
-
-
-
-;;;; li, jali, ji, nop, cmp, not, neg, move, and more
-
-(define-instruction li (segment reg value)
-  (:declare (type tn reg)
-	    (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
-		      fixup) value))
-  (:vop-var vop)
-  (:emitter
-   (assemble (segment vop)
-	     (etypecase value
-	       ((signed-byte 13)
-		(inst add reg zero-tn value))
-	       ((or (signed-byte 32) (unsigned-byte 32))
-		(let ((hi (ldb (byte 22 10) value))
-		      (lo (ldb (byte 10 0) value)))
-		  (inst sethi reg hi)
-		  (unless (zerop lo)
-		    (inst add reg lo))))
-	       (fixup
-		(inst sethi reg value)
-		(inst add reg value))))))
-
-;;; Jal to a full 32-bit address.  Tmpreg is trashed.
-(define-instruction jali (segment link tmpreg value)
-  (:declare (type tn link tmpreg)
-	    (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
-		      fixup) value))
-  (:vop-var vop)
-  (:emitter
-   (assemble (segment vop)
-     (etypecase value
-       ((signed-byte 13)
-	(inst jal link zero-tn value))
-       ((or (signed-byte 32) (unsigned-byte 32))
-	(let ((hi (ldb (byte 22 10) value))
-	      (lo (ldb (byte 10 0) value)))
-	  (inst sethi tmpreg hi)
-	  (inst jal link tmpreg lo)))
-       (fixup
-	(inst sethi tmpreg value)
-	(inst jal link tmpreg value))))))
-
-;;; Jump to a full 32-bit address.  Tmpreg is trashed.
-(define-instruction ji (segment tmpreg value)
-  (:declare (type tn tmpreg)
-	    (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
-		      fixup) value))
-  (:vop-var vop)
-  (:emitter
-   (assemble (segment vop)
-	     (inst jali zero-tn tmpreg value))))
-
-(define-instruction nop (segment)
-  (:printer format-2-immed ((rd 0) (op2 #b100) (immed 0)) '(:name))
-  (:emitter (emit-format-2-immed segment 0 0 #b100 0)))
-
-(define-instruction cmp (segment src1 &optional src2)
-  (:declare (type tn src1) (type (or null tn (signed-byte 13)) src2))
-  (:printer format-3-reg ((op #b10) (op3 #b010100) (rd 0))
-            '(:name :tab rs1 ", " rs2))
-  (:printer format-3-immed ((op #b10) (op3 #b010100) (rd 0))
-            '(:name :tab rs1 ", " immed))
-  (:emitter
-   (etypecase src2
-     (null
-      (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 0))
-     (tn
-      (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0
-			 (reg-tn-encoding src2)))
-     (integer
-      (emit-format-3-immed segment #b10 0 #b010100 (reg-tn-encoding src1) 1
-			   src2)))))
-
-(define-instruction not (segment dst &optional src1)
-  (:declare (type tn dst) (type (or tn null) src1))
-  (:printer format-3-reg ((op #b10) (op3 #b000111) (rs2 0))
-            '(:name :tab (:unless (:same-as rd) rs1 ", " ) rd))
-  (:emitter
-   (unless src1
-     (setf src1 dst))
-   (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000111
-		      (reg-tn-encoding src1) 0 0 0)))
-
-(define-instruction neg (segment dst &optional src1)
-  (:declare (type tn dst) (type (or tn null) src1))
-  (:printer format-3-reg ((op #b10) (op3 #b000100) (rs1 0))
-            '(:name :tab (:unless (:same-as rd) rs2 ", " ) rd))
-  (:emitter
-   (unless src1
-     (setf src1 dst))
-   (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000100
-		      0 0 0 (reg-tn-encoding src1))))
-
-(define-instruction move (segment dst src1)
-  (:declare (type tn dst src1))
-  (:printer format-3-reg ((op #b10) (op3 #b000010) (rs1 0))
-            '(:name :tab rs2 ", " rd))
-  (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000010
-			       0 0 0 (reg-tn-encoding src1))))
-
-
-
-;;;; Instructions for dumping data and header objects.
-
-(define-instruction word (segment word)
-  (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
-  :pinned
-  (:emitter
-   (emit-word segment word)))
-
-(define-instruction short (segment short)
-  (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
-  :pinned
-  (:emitter
-   (emit-short segment short)))
-
-(define-instruction byte (segment byte)
-  (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
-  :pinned
-  (:emitter
-   (emit-byte segment byte)))
-
-(define-emitter emit-header-object 32
-  (byte 24 8) (byte 8 0))
-
-
-  
-(defun emit-header-data (segment type)
-  (emit-back-patch
-   segment 4
-   #'(lambda (segment posn)
-       (emit-word segment
-		  (logior type
-			  (ash (+ posn (component-header-length))
-			       (- type-bits word-shift)))))))
-
-(define-instruction function-header-word (segment)
-  :pinned
-  (:emitter
-   (emit-header-data segment function-header-type)))
-
-(define-instruction lra-header-word (segment)
-  :pinned
-  (:emitter
-   (emit-header-data segment return-pc-header-type)))
-
-
-;;;; Instructions for converting between code objects, functions, and lras.
-
-(defun emit-compute-inst (segment vop dst src label temp calc)
-  (emit-chooser
-   ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
-   segment 12 3
-   #'(lambda (segment posn delta-if-after)
-       (let ((delta (funcall calc label posn delta-if-after)))
-	 (when (<= (- (ash 1 12)) delta (1- (ash 1 12)))
-	   (emit-back-patch segment 4
-			    #'(lambda (segment posn)
-				(assemble (segment vop)
-					  (inst add dst src
-						(funcall calc label posn 0)))))
-	   t)))
-   #'(lambda (segment posn)
-       (let ((delta (funcall calc label posn 0)))
-	 (assemble (segment vop)
-		   (inst sethi temp (ldb (byte 22 10) delta))
-		   (inst or temp (ldb (byte 10 0) delta))
-		   (inst add dst src temp))))))
-
-;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag
-(define-instruction compute-code-from-fn (segment dst src label temp)
-  (:declare (type tn dst src temp) (type label label))
-  (:reads src)
-  (:writes (list dst temp))
-  (:vop-var vop)
-  (:emitter
-   (emit-compute-inst segment vop dst src label temp
-		      #'(lambda (label posn delta-if-after)
-			  (- other-pointer-type
-			     function-pointer-type
-			     (label-position label posn delta-if-after)
-			     (component-header-length))))))
-
-;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
-(define-instruction compute-code-from-lra (segment dst src label temp)
-  (:declare (type tn dst src temp) (type label label))
-  (:reads src)
-  (:writes (list dst temp))
-  (:vop-var vop)
-  (:emitter
-   (emit-compute-inst segment vop dst src label temp
-		      #'(lambda (label posn delta-if-after)
-			  (- (+ (label-position label posn delta-if-after)
-				(component-header-length)))))))
-
-;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
-(define-instruction compute-lra-from-code (segment dst src label temp)
-  (:declare (type tn dst src temp) (type label label))
-  (:reads src)
-  (:writes (list dst temp))
-  (:vop-var vop)
-  (:emitter
-   (emit-compute-inst segment vop dst src label temp
-		      #'(lambda (label posn delta-if-after)
-			  (+ (label-position label posn delta-if-after)
-			     (component-header-length))))))
diff --git a/compiler/sparc/macros.lisp b/compiler/sparc/macros.lisp
deleted file mode 100644
index baa5163481e75329b86f3f42e13ba15a70f2c396..0000000000000000000000000000000000000000
--- a/compiler/sparc/macros.lisp
+++ /dev/null
@@ -1,438 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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/sparc/macros.lisp,v 1.9 1992/12/17 09:40:58 wlott Exp $
-;;;
-;;; This file contains various useful macros for generating SPARC code.
-;;;
-;;; Written by William Lott.
-;;; 
-
-(in-package "SPARC")
-
-
-;;; Instruction-like macros.
-
-(defmacro move (dst src)
-  "Move SRC into DST unless they are location=."
-  (once-only ((n-dst dst)
-	      (n-src src))
-    `(unless (location= ,n-dst ,n-src)
-       (inst move ,n-dst ,n-src))))
-
-(macrolet
-    ((frob (op inst shift)
-       `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
-	  `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
-  (frob loadw ld word-shift)
-  (frob storew st word-shift))
-
-(defmacro load-symbol (reg symbol)
-  `(inst add ,reg null-tn (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)
-	      `(inst ld ,reg null-tn
-		     (+ (static-symbol-offset ',symbol)
-			(ash ,',offset word-shift)
-			(- other-pointer-type))))
-	    (defmacro ,storer (reg symbol)
-	      `(inst st ,reg null-tn
-		     (+ (static-symbol-offset ',symbol)
-			(ash ,',offset word-shift)
-			(- 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 (backend-byte-order *target-backend*)
-      (:little-endian
-       `(inst ldub ,n-target ,n-source ,n-offset))
-      (:big-endian
-       `(inst ldub ,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)
-  "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
-  `(progn
-     (inst j ,function
-	   (- (ash function-code-offset word-shift) function-pointer-type))
-     (move code-tn ,function)))
-
-(defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
-  "Return to RETURN-PC."
-  `(progn
-     (inst j ,return-pc
-	   (- (* (1+ ,offset) word-bytes) other-pointer-type))
-     ,(if frob-code
-	  `(move code-tn ,return-pc)
-	  '(inst nop))))
-
-(defmacro emit-return-pc (label)
-  "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
-  `(progn
-     (align 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)
-  `(let ((reg ,reg)
-	 (stack ,stack))
-     (let ((offset (tn-offset stack)))
-       (sc-case stack
-	 ((control-stack)
-	  (loadw reg cfp-tn offset))))))
-
-(defmacro store-stack-tn (stack reg)
-  `(let ((stack ,stack)
-	 (reg ,reg))
-     (let ((offset (tn-offset stack)))
-       (sc-case stack
-	 ((control-stack)
-	  (storew reg cfp-tn offset))))))
-
-
-;;; MAYBE-LOAD-STACK-TN  --  Interface
-;;;
-(defmacro maybe-load-stack-tn (reg reg-or-stack)
-  "Move the TN Reg-Or-Stack into Reg if it isn't already there."
-  (once-only ((n-reg reg)
-	      (n-stack reg-or-stack))
-    `(sc-case ,n-reg
-       ((any-reg descriptor-reg)
-	(sc-case ,n-stack
-	  ((any-reg descriptor-reg)
-	   (move ,n-reg ,n-stack))
-	  ((control-stack)
-	   (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
-
-
-;;;; Storage allocation:
-
-(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
-				 &body body)
-  "Do stuff to allocate an other-pointer object of fixed Size with a single
-  word header having the specified Type-Code.  The result is placed in
-  Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
-  by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
-  initializes the object."
-  (once-only ((result-tn result-tn) (temp-tn temp-tn)
-	      (type-code type-code) (size size))
-    `(pseudo-atomic (:extra (pad-data-block ,size))
-       (inst or ,result-tn alloc-tn other-pointer-type)
-       (inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code))
-       (storew ,temp-tn ,result-tn 0 other-pointer-type)
-       ,@body)))
-
-
-;;;; Type testing noise.
-
-;;; GEN-RANGE-TEST -- internal
-;;;
-;;; Generate code that branches to TARGET iff REG contains one of VALUES.
-;;; If NOT-P is true, invert the test.  Jumping to NOT-TARGET is the same
-;;; as falling out the bottom.
-;;; 
-(defun gen-range-test (reg target not-target not-p min seperation max values)
-  (let ((tests nil)
-	(start nil)
-	(end nil)
-	(insts nil))
-    (multiple-value-bind (equal less-or-equal greater-or-equal label)
-			 (if not-p
-			     (values :ne :gt :lt not-target)
-			     (values :eq :le :ge target))
-      (flet ((emit-test ()
-	       (if (= start end)
-		   (push start tests)
-		   (push (cons start end) tests))))
-	(dolist (value values)
-	  (cond ((< value min)
-		 (error "~S is less than the specified minimum of ~S"
-			value min))
-		((> value max)
-		 (error "~S is greater than the specified maximum of ~S"
-			value max))
-		((not (zerop (rem (- value min) seperation)))
-		 (error "~S isn't an even multiple of ~S from ~S"
-			value seperation min))
-		((null start)
-		 (setf start value))
-		((> value (+ end seperation))
-		 (emit-test)
-		 (setf start value)))
-	  (setf end value))
-	(emit-test))
-      (macrolet ((inst (name &rest args)
-		       `(push (list 'inst ',name ,@args) insts)))
-	(do ((remaining (nreverse tests) (cdr remaining)))
-	    ((null remaining))
-	  (let ((test (car remaining))
-		(last (null (cdr remaining))))
-	    (if (atom test)
-		(progn
-		  (inst cmp reg test)
-		  (if last
-		      (inst b equal target)
-		      (inst b :eq label)))
-		(let ((start (car test))
-		      (end (cdr test)))
-		  (cond ((and (= start min) (= end max))
-			 (warn "The values ~S cover the entire range from ~
-			 ~S to ~S [step ~S]."
-			       values min max seperation)
-			 (push `(unless ,not-p (inst b ,target)) insts))
-			((= start min)
-			 (inst cmp reg end)
-			 (if last
-			     (inst b less-or-equal target)
-			     (inst b :le label)))
-			((= end max)
-			 (inst cmp reg start)
-			 (if last
-			     (inst b greater-or-equal target)
-			     (inst b :ge label)))
-			(t
-			 (inst cmp reg start)
-			 (inst b :lt (if not-p target not-target))
-			 (inst cmp reg end)
-			 (if last
-			     (inst b less-or-equal target)
-			     (inst b :le label))))))))))
-    (nreverse insts)))
-
-(defun gen-other-immediate-test (reg target not-target not-p values)
-  (gen-range-test reg target not-target not-p
-		  (+ other-immediate-0-type lowtag-limit)
-		  (- other-immediate-1-type other-immediate-0-type)
-		  (ash 1 type-bits)
-		  values))
-
-
-(defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
-			  function-p)
-  (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql)
-		       (member odd-fixnum-type lowtags :test #'eql)))
-	 (lowtags (sort (if fixnump
-			    (delete even-fixnum-type
-				    (remove odd-fixnum-type lowtags
-					    :test #'eql)
-				    :test #'eql)
-			    (copy-list lowtags))
-			#'<))
-	 (lowtag (if function-p
-		     vm:function-pointer-type
-		     vm:other-pointer-type))
-	 (hdrs (sort (copy-list hdrs) #'<))
-	 (immed (sort (copy-list immed) #'<)))
-    (append
-     (when immed
-       `((inst and ,temp ,reg type-mask)
-	 ,@(if (or fixnump lowtags hdrs)
-	       (let ((fall-through (gensym)))
-		 `((let (,fall-through (gen-label))
-		     ,@(gen-other-immediate-test
-			temp (if not-p not-target target)
-			fall-through nil immed)
-		     (emit-label ,fall-through))))
-	       (gen-other-immediate-test temp target not-target not-p immed))))
-     (when fixnump
-       `((inst andcc zero-tn ,reg 3)
-	 ,(if (or lowtags hdrs)
-	      `(inst b :eq ,(if not-p not-target target))
-	      `(inst b ,(if not-p :ne :eq) ,target))))
-     (when (or lowtags hdrs)
-       `((inst and ,temp ,reg lowtag-mask)))
-     (when lowtags
-       (if hdrs
-	   (let ((fall-through (gensym)))
-	     `((let ((,fall-through (gen-label)))
-		 ,@(gen-range-test temp (if not-p not-target target)
-				   fall-through nil
-				   0 1 (1- lowtag-limit) lowtags)
-		 (emit-label ,fall-through))))
-	   (gen-range-test temp target not-target not-p 0 1
-			   (1- lowtag-limit) lowtags)))
-     (when hdrs
-       `((inst cmp ,temp ,lowtag)
-	 (inst b :ne ,(if not-p target not-target))
-	 (inst nop)
-	 (load-type ,temp ,reg (- ,lowtag))
-	 ,@(gen-other-immediate-test temp target not-target not-p hdrs))))))
-
-(defconstant immediate-types
-  (list base-char-type unbound-marker-type))
-
-(defconstant function-subtypes
-  (list funcallable-instance-header-type dylan-function-header-type
-	function-header-type closure-function-header-type
-	closure-header-type))
-
-(defmacro test-type (register temp target not-p &rest type-codes)
-  (let* ((type-codes (mapcar #'eval type-codes))
-	 (lowtags (remove lowtag-limit type-codes :test #'<))
-	 (extended (remove lowtag-limit type-codes :test #'>))
-	 (immediates (intersection extended immediate-types :test #'eql))
-	 (headers (set-difference extended immediate-types :test #'eql))
-	 (function-p nil))
-    (unless type-codes
-      (error "Must supply at least on type for test-type."))
-    (when (and headers (member other-pointer-type lowtags))
-      (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers)
-      (setf headers nil))
-    (when (and immediates
-	       (or (member other-immediate-0-type lowtags)
-		   (member other-immediate-1-type lowtags)))
-      (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
-      (setf immediates nil))
-    (when (intersection headers function-subtypes)
-      (unless (subsetp headers function-subtypes)
-	(error "Can't test for mix of function subtypes and normal ~
-		header types."))
-      (setq function-p t))
-      
-    (let ((n-reg (gensym))
-	  (n-temp (gensym))
-	  (n-target (gensym))
-	  (not-target (gensym)))
-      `(let ((,n-reg ,register)
-	     (,n-temp ,temp)
-	     (,n-target ,target)
-	     (,not-target (gen-label)))
-	 (declare (ignorable ,n-temp))
-	 ,@(if (constantp not-p)
-	       (test-type-aux n-reg n-temp n-target not-target
-			      (eval not-p) lowtags immediates headers
-			      function-p)
-	       `((cond (,not-p
-			,@(test-type-aux n-reg n-temp n-target not-target t
-					 lowtags immediates headers
-					 function-p))
-		       (t
-			,@(test-type-aux n-reg n-temp n-target not-target nil
-					 lowtags immediates headers
-					 function-p)))))
-	 (inst nop)
-	 (emit-label ,not-target)))))
-
-
-;;;; Error Code
-
-(defvar *adjustable-vectors* nil)
-
-(defmacro with-adjustable-vector ((var) &rest body)
-  `(let ((,var (or (pop *adjustable-vectors*)
-		   (make-array 16
-			       :element-type '(unsigned-byte 8)
-			       :fill-pointer 0
-			       :adjustable t))))
-     (setf (fill-pointer ,var) 0)
-     (unwind-protect
-	 (progn
-	   ,@body)
-       (push ,var *adjustable-vectors*))))
-
-(eval-when (compile load eval)
-  (defun emit-error-break (vop kind code values)
-    (let ((vector (gensym)))
-      `((let ((vop ,vop))
-	  (when vop
-	    (note-this-location vop :internal-error)))
-	(inst unimp ,kind)
-	(with-adjustable-vector (,vector)
-	  (write-var-integer (error-number-or-lose ',code) ,vector)
-	  ,@(mapcar #'(lambda (tn)
-			`(let ((tn ,tn))
-			   (write-var-integer (make-sc-offset (sc-number
-							       (tn-sc tn))
-							      (tn-offset tn))
-					      ,vector)))
-		    values)
-	  (inst byte (length ,vector))
-	  (dotimes (i (length ,vector))
-	    (inst byte (aref ,vector i))))
-	(align word-shift)))))
-
-(defmacro error-call (vop error-code &rest values)
-  "Cause an error.  ERROR-CODE is the error to cause."
-  (cons 'progn
-	(emit-error-break vop error-trap error-code values)))
-
-
-(defmacro cerror-call (vop label error-code &rest values)
-  "Cause a continuable error.  If the error is continued, execution resumes at
-  LABEL."
-  `(progn
-     (inst b ,label)
-     ,@(emit-error-break vop cerror-trap error-code values)))
-
-(defmacro generate-error-code (vop error-code &rest values)
-  "Generate-Error-Code Error-code Value*
-  Emit code for an error with the specified Error-Code and context Values."
-  `(assemble (*elsewhere*)
-     (let ((start-lab (gen-label)))
-       (emit-label start-lab)
-       (error-call ,vop ,error-code ,@values)
-       start-lab)))
-
-(defmacro generate-cerror-code (vop error-code &rest values)
-  "Generate-CError-Code Error-code Value*
-  Emit code for a continuable error with the specified Error-Code and
-  context Values.  If the error is continued, execution resumes after
-  the GENERATE-CERROR-CODE form."
-  (let ((continue (gensym "CONTINUE-LABEL-"))
-	(error (gensym "ERROR-LABEL-")))
-    `(let ((,continue (gen-label)))
-       (emit-label ,continue)
-       (assemble (*elsewhere*)
-	 (let ((,error (gen-label)))
-	   (emit-label ,error)
-	   (cerror-call ,vop ,continue ,error-code ,@values)
-	   ,error)))))
-
-
-
-;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
-;;;
-(defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
-  (let ((n-extra (gensym)))
-    `(let ((,n-extra ,extra))
-       (without-scheduling ()
-	 (inst add alloc-tn 4))
-       ,@forms
-       (without-scheduling ()
-	 (inst taddcctv alloc-tn (- ,n-extra 4))))))
diff --git a/compiler/sparc/memory.lisp b/compiler/sparc/memory.lisp
deleted file mode 100644
index 6150db0920593885ed9a9953f6268d887e3a8043..0000000000000000000000000000000000000000
--- a/compiler/sparc/memory.lisp
+++ /dev/null
@@ -1,116 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/memory.lisp,v 1.2 1992/12/16 20:26:30 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the SPARC definitions of some general purpose memory
-;;; reference VOPs inherited by basic memory reference operations.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by William Lott.
-;;; 
-
-(in-package "SPARC")
-
-;;; 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.
-;;;
-(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)))
-
-;;; 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.
-;;;
-(defmacro define-indexer (name write-p op shift)
-  `(define-vop (,name)
-     (:args (object :scs (descriptor-reg))
-	    (index :scs (any-reg zero immediate))
-	    ,@(when write-p
-		'((value :scs (any-reg descriptor-reg) :target result))))
-     (:arg-types * tagged-num ,@(when write-p '(*)))
-     (:temporary (:scs (non-descriptor-reg)) temp)
-     (:results (,(if write-p 'result 'value)
-		:scs (any-reg descriptor-reg)))
-     (:result-types *)
-     (:variant-vars offset lowtag)
-     (:policy :fast-safe)
-     (:generator 5
-       (sc-case index
-	 ((immediate zero)
-	  (let ((offset (- (+ (if (sc-is index zero)
-				  0
-				  (ash (tn-value index)
-				       (- vm:word-shift ,shift)))
-			      (ash offset vm:word-shift))
-			   lowtag)))
-	    (etypecase offset
-	      ((signed-byte 13)
-	       (inst ,op value object offset))
-	      ((or (unsigned-byte 32) (signed-byte 32))
-	       (inst li temp offset)
-	       (inst ,op value object temp)))))
-	 (t
-	  ,@(unless (zerop shift)
-	      `((inst srl temp index ,shift)))
-	  (inst add temp ,(if (zerop shift) 'index 'temp)
-		(- (ash offset vm:word-shift) lowtag))
-	  (inst ,op value object temp)))
-       ,@(when write-p
-	   '((move result value))))))
-
-(define-indexer word-index-ref nil ld 0)
-(define-indexer word-index-set t st 0)
-(define-indexer halfword-index-ref nil lduh 1)
-(define-indexer signed-halfword-index-ref nil ldsh 1)
-(define-indexer halfword-index-set t sth 1)
-(define-indexer byte-index-ref nil ldub 2)
-(define-indexer signed-byte-index-ref nil ldsb 2)
-(define-indexer byte-index-set t stb 2)
-
diff --git a/compiler/sparc/move.lisp b/compiler/sparc/move.lisp
deleted file mode 100644
index 77403fd7ca4e3505200c79b3801462cddbbed96c..0000000000000000000000000000000000000000
--- a/compiler/sparc/move.lisp
+++ /dev/null
@@ -1,324 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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/sparc/move.lisp,v 1.4 1992/03/11 21:29:13 wlott Exp $
-;;;
-;;;    This file contains the SPARC VM definition of operand loading/saving and
-;;; the Move VOP.
-;;;
-;;; Written by Rob MacLachlan.
-;;; SPARC conversion by William Lott.
-;;;
-(in-package "SPARC")
-
-
-(define-move-function (load-immediate 1) (vop x y)
-  ((null immediate zero)
-   (any-reg descriptor-reg))
-  (let ((val (tn-value x)))
-    (etypecase val
-      (integer
-       (inst li y (fixnum val)))
-      (null
-       (move y null-tn))
-      (symbol
-       (load-symbol y val))
-      (character
-       (inst li y (logior (ash (char-code val) type-bits)
-			  base-char-type))))))
-
-(define-move-function (load-number 1) (vop x y)
-  ((immediate zero)
-   (signed-reg unsigned-reg))
-  (inst li y (tn-value x)))
-
-(define-move-function (load-base-char 1) (vop x y)
-  ((immediate) (base-char-reg))
-  (inst li y (char-code (tn-value x))))
-
-(define-move-function (load-system-area-pointer 1) (vop x y)
-  ((immediate) (sap-reg))
-  (inst li y (sap-int (tn-value x))))
-
-(define-move-function (load-constant 5) (vop x y)
-  ((constant) (descriptor-reg))
-  (loadw y code-tn (tn-offset x) other-pointer-type))
-
-(define-move-function (load-stack 5) (vop x y)
-  ((control-stack) (any-reg descriptor-reg))
-  (load-stack-tn y x))
-
-(define-move-function (load-number-stack 5) (vop x y)
-  ((base-char-stack) (base-char-reg)
-   (sap-stack) (sap-reg)
-   (signed-stack) (signed-reg)
-   (unsigned-stack) (unsigned-reg))
-  (let ((nfp (current-nfp-tn vop)))
-    (loadw y nfp (tn-offset x))))
-
-(define-move-function (store-stack 5) (vop x y)
-  ((any-reg descriptor-reg) (control-stack))
-  (store-stack-tn y x))
-
-(define-move-function (store-number-stack 5) (vop x y)
-  ((base-char-reg) (base-char-stack)
-   (sap-reg) (sap-stack)
-   (signed-reg) (signed-stack)
-   (unsigned-reg) (unsigned-stack))
-  (let ((nfp (current-nfp-tn vop)))
-    (storew x nfp (tn-offset y))))
-
-
-;;;; The Move VOP:
-;;;
-(define-vop (move)
-  (:args (x :target y
-	    :scs (any-reg descriptor-reg zero null)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (any-reg descriptor-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:generator 0
-    (move y x)))
-
-(define-move-vop move :move
-  (any-reg descriptor-reg)
-  (any-reg descriptor-reg))
-
-;;; 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)
-
-;;;    The Move-Argument VOP is used for moving descriptor values into another
-;;; frame for argument or known value passing.
-;;;
-(define-vop (move-argument)
-  (:args (x :target y
-	    :scs (any-reg descriptor-reg zero null))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y any-reg descriptor-reg))))
-  (:results (y))
-  (:generator 0
-    (sc-case y
-      ((any-reg descriptor-reg)
-       (move y x))
-      (control-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-argument :move-argument
-  (any-reg descriptor-reg)
-  (any-reg descriptor-reg))
-
-
-
-;;;; 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)
-  (:args (x) (type))
-  (:results (y))
-  (:ignore y)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 666
-    (error-call vop object-not-type-error x type)))
-
-
-
-;;;; Moves and coercions:
-
-;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
-;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
-;;; to a tagged bignum or fixnum.
-
-;;; Arg is a fixnum, so just shift it.  We need a type restriction because some
-;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
-;;;
-(define-vop (move-to-word/fixnum)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (y :scs (signed-reg unsigned-reg)))
-  (:arg-types tagged-num)
-  (:note "fixnum untagging")
-  (:generator 1
-    (inst sra y x 2)))
-;;;
-(define-move-vop move-to-word/fixnum :move
-  (any-reg descriptor-reg) (signed-reg unsigned-reg))
-
-;;; Arg is a non-immediate constant, load it.
-(define-vop (move-to-word-c)
-  (:args (x :scs (constant)))
-  (:results (y :scs (signed-reg unsigned-reg)))
-  (:note "constant load")
-  (:generator 1
-    (inst li y (tn-value x))))
-;;;
-(define-move-vop move-to-word-c :move
-  (constant) (signed-reg unsigned-reg))
-
-
-;;; Arg is a fixnum or bignum, figure out which and load if necessary.
-(define-vop (move-to-word/integer)
-  (:args (x :scs (descriptor-reg)))
-  (:results (y :scs (signed-reg unsigned-reg)))
-  (:note "integer to untagged word coercion")
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 4
-    (let ((done (gen-label)))
-      (inst andcc temp x 3)
-      (inst b :eq done)
-      (sc-case y
-	(signed-reg
-	 (inst sra y x 2))
-	(unsigned-reg
-	 (inst srl y x 2)))
-      
-      (loadw y x bignum-digits-offset other-pointer-type)
-      
-      (emit-label done))))
-;;;
-(define-move-vop move-to-word/integer :move
-  (descriptor-reg) (signed-reg unsigned-reg))
-
-
-
-;;; Result is a fixnum, so we can just shift.  We need the result type
-;;; restriction because of the control-stack ambiguity noted above.
-;;;
-(define-vop (move-from-word/fixnum)
-  (:args (x :scs (signed-reg unsigned-reg)))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:result-types tagged-num)
-  (:note "fixnum tagging")
-  (:generator 1
-    (inst sll y x 2)))
-;;;
-(define-move-vop move-from-word/fixnum :move
-  (signed-reg unsigned-reg) (any-reg descriptor-reg))
-
-
-;;; Result may be a bignum, so we have to check.  Use a worst-case cost to make
-;;; sure people know they may be number consing.
-;;;
-(define-vop (move-from-signed)
-  (:args (arg :scs (signed-reg unsigned-reg) :target x))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
-  (:note "signed word to integer coercion")
-  (:generator 20
-    (move x arg)
-    (let ((fixnum (gen-label))
-	  (done (gen-label)))
-      (inst sra temp x 29)
-      (inst cmp temp)
-      (inst b :eq fixnum)
-      (inst orncc temp zero-tn temp)
-      (inst b :eq done)
-      (inst sll y x 2)
-      
-      (with-fixed-allocation
-	(y temp bignum-type (1+ bignum-digits-offset))
-	(storew x y bignum-digits-offset other-pointer-type))
-      (inst b done)
-      (inst nop)
-      
-      (emit-label fixnum)
-      (inst sll y x 2)
-      (emit-label done))))
-;;;
-(define-move-vop move-from-signed :move
-  (signed-reg) (descriptor-reg))
-
-
-;;; Check for fixnum, and possibly allocate one or two word bignum result.  Use
-;;; a worst-case cost to make sure people know they may be number consing.
-;;;
-(define-vop (move-from-unsigned)
-  (:args (arg :scs (signed-reg unsigned-reg) :target x))
-  (:results (y :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
-  (:note "unsigned word to integer coercion")
-  (:generator 20
-    (move x arg)
-    (let ((done (gen-label))
-	  (one-word (gen-label))
-	  (initial-alloc (pad-data-block (1+ bignum-digits-offset))))
-      (inst sra temp x 29)
-      (inst cmp temp)
-      (inst b :eq done)
-      (inst sll y x 2)
-      
-      (pseudo-atomic (:extra initial-alloc)
-	(inst or y alloc-tn other-pointer-type)
-	(inst cmp x)
-	(inst b :ge one-word)
-	(inst li temp (logior (ash 1 type-bits) bignum-type))
-	(inst add alloc-tn
-	      (- (pad-data-block (+ bignum-digits-offset 2))
-		 (pad-data-block (+ bignum-digits-offset 1))))
-	(inst li temp (logior (ash 2 type-bits) bignum-type))
-	(emit-label one-word)
-	(storew temp y 0 other-pointer-type)
-	(storew x y bignum-digits-offset other-pointer-type))
-      (emit-label done))))
-;;;
-(define-move-vop move-from-unsigned :move
-  (unsigned-reg) (descriptor-reg))
-
-
-;;; Move untagged numbers.
-;;;
-(define-vop (word-move)
-  (:args (x :target y
-	    :scs (signed-reg unsigned-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (signed-reg unsigned-reg)
-	       :load-if (not (location= x y))))
-  (:effects)
-  (:affected)
-  (:note "word integer move")
-  (:generator 0
-    (move y x)))
-;;;
-(define-move-vop word-move :move
-  (signed-reg unsigned-reg) (signed-reg unsigned-reg))
-
-
-;;; Move untagged number arguments/return-values.
-;;;
-(define-vop (move-word-argument)
-  (:args (x :target y
-	    :scs (signed-reg unsigned-reg))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y sap-reg))))
-  (:results (y))
-  (:note "word integer argument move")
-  (:generator 0
-    (sc-case y
-      ((signed-reg unsigned-reg)
-       (move y x))
-      ((signed-stack unsigned-stack)
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-word-argument :move-argument
-  (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a
-;;; descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (signed-reg unsigned-reg) (any-reg descriptor-reg))
diff --git a/compiler/sparc/nlx.lisp b/compiler/sparc/nlx.lisp
deleted file mode 100644
index faa010a3f52e10891d4b99d46d3bf2332a1753be..0000000000000000000000000000000000000000
--- a/compiler/sparc/nlx.lisp
+++ /dev/null
@@ -1,279 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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/sparc/nlx.lisp,v 1.5 1992/05/21 23:22:31 wlott Exp $
-;;;
-;;;    This file contains the definitions of VOPs used for non-local exit
-;;; (throw, lexical exit, etc.)
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package "SPARC")
-
-;;; MAKE-NLX-SP-TN  --  Interface
-;;;
-;;;    Make an environment-live stack TN for saving the SP for NLX entry.
-;;;
-(def-vm-support-routine make-nlx-sp-tn (env)
-  (environment-live-tn
-   (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
-   env))
-
-
-
-;;; 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.
-;;;
-(def-vm-support-routine make-dynamic-state-tns ()
-  (make-n-tns 4 *any-primitive-type*))
-
-(define-vop (save-dynamic-state)
-  (:results (catch :scs (descriptor-reg))
-	    (nfp :scs (descriptor-reg))
-	    (nsp :scs (descriptor-reg))
-	    (eval :scs (descriptor-reg)))
-  (:vop-var vop)
-  (:generator 13
-    (load-symbol-value catch lisp::*current-catch-block*)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(move nfp cur-nfp)))
-    (move nsp nsp-tn)
-    (load-symbol-value eval lisp::*eval-stack-top*)))
-
-(define-vop (restore-dynamic-state)
-  (:args (catch :scs (descriptor-reg))
-	 (nfp :scs (descriptor-reg))
-	 (nsp :scs (descriptor-reg))
-	 (eval :scs (descriptor-reg)))
-  (:vop-var vop)
-  (:generator 10
-    (store-symbol-value catch lisp::*current-catch-block*)
-    (store-symbol-value eval lisp::*eval-stack-top*)
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(move cur-nfp nfp)))
-    (move nsp-tn nsp)))
-
-(define-vop (current-stack-pointer)
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (move res csp-tn)))
-
-(define-vop (current-binding-pointer)
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (move res bsp-tn)))
-
-
-
-;;;; Unwind block hackery:
-
-;;; Compute the address of the catch block from its TN, then store into the
-;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
-;;;
-(define-vop (make-unwind-block)
-  (:args (tn))
-  (:info entry-label)
-  (:results (block :scs (any-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:generator 22
-    (inst add block cfp-tn (* (tn-offset tn) vm:word-bytes))
-    (load-symbol-value temp lisp::*current-unwind-protect-block*)
-    (storew temp block vm:unwind-block-current-uwp-slot)
-    (storew cfp-tn block vm:unwind-block-current-cont-slot)
-    (storew code-tn block vm:unwind-block-current-code-slot)
-    (inst compute-lra-from-code temp code-tn entry-label ndescr)
-    (storew temp block vm:catch-block-entry-pc-slot)))
-
-
-;;; 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 (descriptor-reg)))
-  (:info entry-label)
-  (:results (block :scs (any-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:generator 44
-    (inst add result cfp-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 cfp-tn result vm:catch-block-current-cont-slot)
-    (storew code-tn result vm:catch-block-current-code-slot)
-    (inst compute-lra-from-code temp code-tn entry-label ndescr)
-    (storew temp result vm:catch-block-entry-pc-slot)
-
-    (storew tag result vm:catch-block-tag-slot)
-    (load-symbol-value temp lisp::*current-catch-block*)
-    (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 add new-uwp cfp-tn (* (tn-offset tn) vm:word-bytes))
-    (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
-
-
-(define-vop (unlink-catch-block)
-  (:temporary (:scs (any-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 (any-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:
-
-
-(define-vop (nlx-entry)
-  (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
-	      ; would be inserted before the LRA.
-	 (start)
-	 (count))
-  (:results (values :more t))
-  (:temporary (:scs (descriptor-reg)) move-temp)
-  (:info label nvals)
-  (:save-p :force-to-stack)
-  (:vop-var vop)
-  (:generator 30
-    (emit-return-pc label)
-    (note-this-location vop :non-local-entry)
-    (cond ((zerop nvals))
-	  ((= nvals 1)
-	   (let ((no-values (gen-label)))
-	     (inst cmp count)
-	     (inst b :eq no-values)
-	     (move (tn-ref-tn values) null-tn)
-	     (loadw (tn-ref-tn values) start)
-	     (emit-label no-values)))
-	  (t
-	   (collect ((defaults))
-	     (inst subcc count (fixnum 1))
-	     (do ((i 0 (1+ i))
-		  (tn-ref values (tn-ref-across tn-ref)))
-		 ((null tn-ref))
-	       (let ((default-lab (gen-label))
-		     (tn (tn-ref-tn tn-ref)))
-		 (defaults (cons default-lab tn))
-		 
-		 (inst b :lt default-lab)
-		 (inst subcc count (fixnum 1))
-		 (sc-case tn
-			  ((descriptor-reg any-reg)
-			   (loadw tn start i))
-			  (control-stack
-			   (loadw move-temp start i)
-			   (store-stack-tn tn move-temp)))))
-	     
-	     (let ((defaulting-done (gen-label)))
-	       
-	       (emit-label defaulting-done)
-	       
-	       (assemble (*elsewhere*)
-		 (dolist (def (defaults))
-		   (emit-label (car def))
-		   (let ((tn (cdr def)))
-		     (sc-case tn
-			      ((descriptor-reg any-reg)
-			       (move tn null-tn))
-			      (control-stack
-			       (store-stack-tn tn null-tn)))))
-		 (inst b defaulting-done)
-		 (inst nop))))))
-    (load-stack-tn csp-tn sp)))
-
-
-(define-vop (nlx-entry-multiple)
-  (:args (top :target result) (src) (count))
-  ;; Again, no SC restrictions for the args, 'cause the loading would
-  ;; happen before the entry label.
-  (:info label)
-  (:temporary (:scs (any-reg)) dst)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:results (result :scs (any-reg) :from (:argument 0))
-	    (num :scs (any-reg) :from (:argument 0)))
-  (:save-p :force-to-stack)
-  (:vop-var vop)
-  (:generator 30
-    (emit-return-pc label)
-    (note-this-location vop :non-local-entry)
-    (let ((loop (gen-label))
-	  (done (gen-label)))
-
-      ;; Setup results, and test for the zero value case.
-      (load-stack-tn result top)
-      (inst cmp count)
-      (inst b :eq done)
-      (inst li num 0)
-
-      ;; Compute dst as one slot down from result, because we inc the index
-      ;; before we use it.
-      (inst sub dst result 4)
-
-      ;; Copy stuff down the stack.
-      (emit-label loop)
-      (inst ld temp src num)
-      (inst add num (fixnum 1))
-      (inst cmp num count)
-      (inst b :ne loop)
-      (inst st temp dst num)
-
-      ;; Reset the CSP.
-      (emit-label done)
-      (inst add csp-tn result num))))
-
-
-;;; This VOP is just to force the TNs used in the cleanup onto the stack.
-;;;
-(define-vop (uwp-entry)
-  (:info label)
-  (:save-p :force-to-stack)
-  (:results (block) (start) (count))
-  (:ignore block start count)
-  (:vop-var vop)
-  (:generator 0
-    (emit-return-pc label)
-    (note-this-location vop :non-local-entry)))
-
diff --git a/compiler/sparc/parms.lisp b/compiler/sparc/parms.lisp
deleted file mode 100644
index 11020d01cb57399f0136210271bbcdbecbae1977..0000000000000000000000000000000000000000
--- a/compiler/sparc/parms.lisp
+++ /dev/null
@@ -1,238 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/parms.lisp,v 1.20 1992/12/07 22:25:04 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains some parameterizations of various VM
-;;; attributes for the SPARC.  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 "SPARC")
-(use-package "C")
-
-
-;;;; Compiler constants.
-
-(eval-when (compile eval load)
-
-(setf (backend-name *target-backend*) "SPARC")
-(setf (backend-version *target-backend*) "SPARCstation/Sun 4")
-(setf (backend-fasl-file-type *target-backend*) "sparcf")
-(setf (backend-fasl-file-implementation *target-backend*)
-      sparc-fasl-file-implementation)
-(setf (backend-fasl-file-version *target-backend*) 4)
-(setf (backend-register-save-penalty *target-backend*) 3)
-(setf (backend-byte-order *target-backend*) :big-endian)
-(setf (backend-page-size *target-backend*)
-      #+mach 4096 #+sunos 8192)
-
-); eval-when
-
-(pushnew :new-assembler *features*)
-
-
-;;;; Machine Architecture parameters:
-
-(export '(word-bits byte-bits word-shift word-bytes float-sign-shift
-
-	  single-float-bias single-float-exponent-byte
-	  single-float-significand-byte single-float-normal-exponent-min
-	  single-float-normal-exponent-max single-float-hidden-bit
-	  single-float-trapping-nan-bit single-float-digits
-
-	  double-float-bias double-float-exponent-byte
-	  double-float-significand-byte double-float-normal-exponent-min
-	  double-float-normal-exponent-max double-float-hidden-bit
-	  double-float-trapping-nan-bit double-float-digits
-
-	  float-underflow-trap-bit float-overflow-trap-bit
-	  float-imprecise-trap-bit float-invalid-trap-bit
-	  float-divide-by-zero-trap-bit))
-
-	  
-
-(eval-when (compile load eval)
-
-(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 float-sign-shift 31)
-
-(defconstant single-float-bias 126)
-(defconstant single-float-exponent-byte (byte 8 23))
-(defconstant single-float-significand-byte (byte 23 0))
-(defconstant single-float-normal-exponent-min 1)
-(defconstant single-float-normal-exponent-max 254)
-(defconstant single-float-hidden-bit (ash 1 23))
-(defconstant single-float-trapping-nan-bit (ash 1 22))
-
-(defconstant double-float-bias 1022)
-(defconstant double-float-exponent-byte (byte 11 20))
-(defconstant double-float-significand-byte (byte 20 0))
-(defconstant double-float-normal-exponent-min 1)
-(defconstant double-float-normal-exponent-max #x7FE)
-(defconstant double-float-hidden-bit (ash 1 20))
-(defconstant double-float-trapping-nan-bit (ash 1 19))
-
-(defconstant single-float-digits
-  (+ (byte-size single-float-significand-byte) 1))
-
-(defconstant double-float-digits
-  (+ (byte-size double-float-significand-byte) word-bits 1))
-
-
-(defconstant float-inexact-trap-bit (ash 1 0))
-(defconstant float-divide-by-zero-trap-bit (ash 1 1))
-(defconstant float-underflow-trap-bit (ash 1 2))
-(defconstant float-overflow-trap-bit (ash 1 3))
-(defconstant float-invalid-trap-bit (ash 1 4))
-
-(defconstant float-round-to-nearest 0)
-(defconstant float-round-to-zero 1)
-(defconstant float-round-to-positive 2)
-(defconstant float-round-to-negative 3)
-
-(defconstant float-rounding-mode (byte 2 30))	  ; RD 
-(defconstant float-sticky-bits (byte 5 5))	  ; aexc
-(defconstant float-traps-byte (byte 5 23))	  ; TEM
-(defconstant float-exceptions-byte (byte 5 0))	  ; cexc
-
-;;; According to the SPARC doc (as opposed to FPU doc), the fast mode bit (EFM)
-;;; is "reserved", and should always be zero.
-(defconstant float-fast-bit 0)
-
-); eval-when
-
-;;; NUMBER-STACK-DISPLACEMENT
-;;;
-;;; The number of bytes reserved above the number stack pointer.  These
-;;; slots are required by architecture for a place to spill register windows.
-;;; 
-(defconstant number-stack-displacement
-  (* 16 vm:word-bytes))
-
-
-;;;; Description of the target address space.
-
-(export '(target-read-only-space-start
-	  target-static-space-start
-	  target-dynamic-space-start))
-
-;;; Where to put the different spaces.
-;;; 
-(defparameter target-read-only-space-start #x00200000)
-(defparameter target-static-space-start    #x0c000000)
-(defparameter target-dynamic-space-start   #x10000000)
-
-
-
-;;;; Other random constants.
-
-(export '(halt-trap pending-interrupt-trap error-trap cerror-trap
-	  breakpoint-trap function-end-breakpoint-trap
-	  after-breakpoint-trap
-	  object-not-list-trap object-not-structure-trap
-	  trace-table-normal trace-table-call-site
-	  trace-table-function-prologue trace-table-function-epilogue))
-
-(defenum (:suffix -trap :start 8)
-  halt
-  pending-interrupt
-  error
-  cerror
-  breakpoint
-  function-end-breakpoint
-  after-breakpoint)
-
-(defenum (:prefix object-not- :suffix -trap :start 16)
-  list
-  structure)
-
-(defenum (:prefix trace-table-)
-  normal
-  call-site
-  function-prologue
-  function-epilogue)
-
-
-;;;; Static symbols.
-
-(export '(static-symbols static-functions))
-
-;;; 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.
-;;;
-;;; The fdefn objects for the static functions are loaded into static
-;;; space directly after the static symbols.  That way, the raw-addr
-;;; can be loaded directly out of them by indirecting relative to NIL.
-;;;
-(defparameter static-symbols
-  '(t
-
-    ;; The C startup code must fill these in.
-    lisp::lisp-environment-list
-    lisp::lisp-command-line-list
-    lisp::*initial-fdefn-objects*
-
-    ;; Functions that the C code needs to call
-    lisp::%initial-function
-    lisp::maybe-gc
-    kernel::internal-error
-    di::handle-breakpoint
-    lisp::fdefinition-object
-
-    ;; Free Pointers.
-    lisp::*read-only-space-free-pointer*
-    lisp::*static-space-free-pointer*
-    lisp::*initial-dynamic-space-free-pointer*
-
-    ;; Things needed for non-local-exit.
-    lisp::*current-catch-block*
-    lisp::*current-unwind-protect-block*
-    *eval-stack-top*
-
-    ;; Interrupt Handling
-    lisp::*free-interrupt-context-index*
-    unix::*interrupts-enabled*
-    unix::*interrupt-pending*
-    ))
-
-(defparameter static-functions
-  '(length
-    two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-=
-    two-arg-<= two-arg->= two-arg-/= eql %negate
-    two-arg-and two-arg-ior two-arg-xor
-    two-arg-gcd two-arg-lcm
-    ))
-
-
-
-;;;; Assembler parameters:
-
-;;; The number of bits per element in the assemblers code vector.
-;;;
-(defparameter *assembly-unit-length* 8)
diff --git a/compiler/sparc/pred.lisp b/compiler/sparc/pred.lisp
deleted file mode 100644
index 3dd37ef3f9407afcad1ad2f8c3f40d0a8dee6848..0000000000000000000000000000000000000000
--- a/compiler/sparc/pred.lisp
+++ /dev/null
@@ -1,46 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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/sparc/pred.lisp,v 1.1 1990/11/30 17:04:59 wlott Exp $
-;;;
-;;;    This file contains the VM definition of predicate VOPs for the SPARC.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by William Lott.
-;;; 
-
-(in-package "SPARC")
-
-
-;;;; 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 b dest)
-    (inst nop)))
-
-
-;;;; Conditional VOPs:
-
-(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
-    (inst cmp x y)
-    (inst b (if not-p :ne :eq) target)
-    (inst nop)))
diff --git a/compiler/sparc/print.lisp b/compiler/sparc/print.lisp
deleted file mode 100644
index 66361f358feafc6aa67226b5a5e2fe889250ef1a..0000000000000000000000000000000000000000
--- a/compiler/sparc/print.lisp
+++ /dev/null
@@ -1,41 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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/sparc/print.lisp,v 1.1 1990/11/30 17:05:00 wlott Exp $
-;;;
-;;; This file contains VOPs for things like printing during %initial-function
-;;; before the world is initialized.
-;;;
-;;; Written by William Lott.
-
-(in-package "SPARC")
-
-
-(define-vop (print)
-  (:args (object :scs (descriptor-reg any-reg) :target nl0))
-  (:results (result :scs (descriptor-reg)))
-  (:save-p t)
-  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) nl0)
-  (:temporary (:sc any-reg :offset cfunc-offset) cfunc)
-  (:temporary (:sc interior-reg :offset lip-offset) lip)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
-  (:vop-var vop)
-  (:generator 100
-    (let ((cur-nfp (current-nfp-tn vop)))
-      (when cur-nfp
-	(store-stack-tn nfp-save cur-nfp))
-      (move nl0 object)
-      (inst li cfunc (make-fixup "_debug_print" :foreign))
-      (inst li temp (make-fixup "_call_into_c" :foreign))
-      (inst jal lip temp)
-      (inst nop)
-      (when cur-nfp
-	(load-stack-tn cur-nfp nfp-save))
-      (move result nl0))))
diff --git a/compiler/sparc/sap.lisp b/compiler/sparc/sap.lisp
deleted file mode 100644
index 5a92f99aa5c836a8a0fab497e9543aee8f69da21..0000000000000000000000000000000000000000
--- a/compiler/sparc/sap.lisp
+++ /dev/null
@@ -1,287 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/sap.lisp,v 1.5 1992/04/27 20:04:06 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the SPARC VM definition of SAP operations.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "SPARC")
-
-
-;;;; Moves and coercions:
-
-;;; Move a tagged SAP to an untagged representation.
-;;;
-(define-vop (move-to-sap)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (y :scs (sap-reg)))
-  (:note "pointer to SAP coercion")
-  (:generator 1
-    (loadw y x sap-pointer-slot other-pointer-type)))
-
-;;;
-(define-move-vop move-to-sap :move
-  (descriptor-reg) (sap-reg))
-
-
-;;; Move an untagged SAP to a tagged representation.
-;;;
-(define-vop (move-from-sap)
-  (:args (sap :scs (sap-reg) :to :save))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:results (res :scs (descriptor-reg)))
-  (:note "SAP to pointer coercion") 
-  (:generator 20
-    (with-fixed-allocation (res ndescr sap-type sap-size)
-      (storew sap res sap-pointer-slot other-pointer-type))))
-;;;
-(define-move-vop move-from-sap :move
-  (sap-reg) (descriptor-reg))
-
-
-;;; Move untagged sap values.
-;;;
-(define-vop (sap-move)
-  (:args (x :target y
-	    :scs (sap-reg)
-	    :load-if (not (location= x y))))
-  (:results (y :scs (sap-reg)
-	       :load-if (not (location= x y))))
-  (:note "SAP move")
-  (:effects)
-  (:affected)
-  (:generator 0
-    (move y x)))
-;;;
-(define-move-vop sap-move :move
-  (sap-reg) (sap-reg))
-
-
-;;; Move untagged sap arguments/return-values.
-;;;
-(define-vop (move-sap-argument)
-  (:args (x :target y
-	    :scs (sap-reg))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y sap-reg))))
-  (:results (y))
-  (:note "SAP argument move")
-  (:generator 0
-    (sc-case y
-      (sap-reg
-       (move y x))
-      (sap-stack
-       (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-sap-argument :move-argument
-  (descriptor-reg sap-reg) (sap-reg))
-
-
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
-;;; descriptor passing location.
-;;;
-(define-move-vop move-argument :move-argument
-  (sap-reg) (descriptor-reg))
-
-
-
-;;;; SAP-INT and INT-SAP
-
-(define-vop (sap-int)
-  (:args (sap :scs (sap-reg) :target int))
-  (:arg-types system-area-pointer)
-  (:results (int :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:translate sap-int)
-  (:policy :fast-safe)
-  (:generator 1
-    (move int sap)))
-
-(define-vop (int-sap)
-  (:args (int :scs (unsigned-reg) :target sap))
-  (:arg-types unsigned-num)
-  (:results (sap :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate int-sap)
-  (:policy :fast-safe)
-  (:generator 1
-    (move sap int)))
-
-
-
-;;;; POINTER+ and POINTER-
-
-(define-vop (pointer+)
-  (:translate sap+)
-  (:args (ptr :scs (sap-reg))
-	 (offset :scs (signed-reg)))
-  (:arg-types system-area-pointer signed-num)
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:policy :fast-safe)
-  (:generator 2
-    (inst add res ptr offset)))
-
-(define-vop (pointer+-c)
-  (:translate sap+)
-  (:args (ptr :scs (sap-reg)))
-  (:info offset)
-  (:arg-types system-area-pointer (:constant (signed-byte 13)))
-  (:results (res :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:policy :fast-safe)
-  (:generator 1
-    (inst add res ptr offset)))
-
-(define-vop (pointer-)
-  (:translate sap-)
-  (:args (ptr1 :scs (sap-reg))
-	 (ptr2 :scs (sap-reg)))
-  (:arg-types system-area-pointer system-area-pointer)
-  (:policy :fast-safe)
-  (:results (res :scs (signed-reg)))
-  (:result-types signed-num)
-  (:generator 1
-    (inst sub res ptr1 ptr2)))
-
-
-
-;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
-
-(eval-when (compile eval)
-
-(defmacro def-system-ref-and-set
-	  (ref-name set-name sc type size &optional signed)
-  (let ((ref-name-c (symbolicate ref-name "-C"))
-	(set-name-c (symbolicate set-name "-C")))
-    `(progn
-       (define-vop (,ref-name)
-	 (:translate ,ref-name)
-	 (:policy :fast-safe)
-	 (:args (sap :scs (sap-reg))
-		(offset :scs (unsigned-reg)))
-	 (:arg-types system-area-pointer unsigned-num)
-	 (:results (result :scs (,sc)))
-	 (:result-types ,type)
-	 (:generator 5
-	   (inst ,(ecase size
-		    (:byte (if signed 'ldsb 'ldub))
-		    (:short (if signed 'ldsh 'lduh))
-		    (:long 'ld)
-		    (:single 'ldf)
-		    (:double 'lddf))
-		 result sap offset)))
-       (define-vop (,ref-name-c)
-	 (:translate ,ref-name)
-	 (:policy :fast-safe)
-	 (:args (sap :scs (sap-reg)))
-	 (:arg-types system-area-pointer (:constant (signed-byte 13)))
-	 (:info offset)
-	 (:results (result :scs (,sc)))
-	 (:result-types ,type)
-	 (:generator 4
-	   (inst ,(ecase size
-		    (:byte (if signed 'ldsb 'ldub))
-		    (:short (if signed 'ldsh 'lduh))
-		    (:long 'ld)
-		    (:single 'ldf)
-		    (:double 'lddf))
-		 result sap offset)))
-       (define-vop (,set-name)
-	 (:translate ,set-name)
-	 (:policy :fast-safe)
-	 (:args (sap :scs (sap-reg))
-		(offset :scs (unsigned-reg))
-		(value :scs (,sc) :target result))
-	 (:arg-types system-area-pointer unsigned-num ,type)
-	 (:results (result :scs (,sc)))
-	 (:result-types ,type)
-	 (:generator 5
-	   (inst ,(ecase size
-		    (:byte 'stb)
-		    (:short 'sth)
-		    (:long 'st)
-		    (:single 'stf)
-		    (:double 'stdf))
-		 value sap offset)
-	   (unless (location= result value)
-	     ,@(case size
-		 (:single
-		  '((inst fmovs result value)))
-		 (:double
-		  '((inst fmovs result value)
-		    (inst fmovs-odd result value)))
-		 (t
-		  '((inst move result value)))))))
-       (define-vop (,set-name-c)
-	 (:translate ,set-name)
-	 (:policy :fast-safe)
-	 (:args (sap :scs (sap-reg))
-		(value :scs (,sc) :target result))
-	 (:arg-types system-area-pointer (:constant (signed-byte 13)) ,type)
-	 (:info offset)
-	 (:results (result :scs (,sc)))
-	 (:result-types ,type)
-	 (:generator 4
-	   (inst ,(ecase size
-		    (:byte 'stb)
-		    (:short 'sth)
-		    (:long 'st)
-		    (:single 'stf)
-		    (:double 'stdf))
-		 value sap offset)
-	   (unless (location= result value)
-	     ,@(case size
-		 (:single
-		  '((inst fmovs result value)))
-		 (:double
-		  '((inst fmovs result value)
-		    (inst fmovs-odd result value)))
-		 (t
-		  '((inst move result value))))))))))
-
-); eval-when (compile eval)
-
-(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
-  unsigned-reg positive-fixnum :byte nil)
-(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
-  signed-reg tagged-num :byte t)
-(def-system-ref-and-set sap-ref-16 %set-sap-ref-16
-  unsigned-reg positive-fixnum :short nil)
-(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
-  signed-reg tagged-num :short t)
-(def-system-ref-and-set sap-ref-32 %set-sap-ref-32
-  unsigned-reg unsigned-num :long nil)
-(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
-  signed-reg signed-num :long t)
-(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
-  sap-reg system-area-pointer :long)
-(def-system-ref-and-set sap-ref-single %set-sap-ref-single
-  single-reg single-float :single)
-(def-system-ref-and-set sap-ref-double %set-sap-ref-double
-  double-reg double-float :double)
-
-
-
-;;; Noise to convert normal lisp data objects into SAPs.
-
-(define-vop (vector-sap)
-  (:translate vector-sap)
-  (:policy :fast-safe)
-  (:args (vector :scs (descriptor-reg)))
-  (:results (sap :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 2
-    (inst add sap vector
-	  (- (* vector-data-offset word-bytes) other-pointer-type))))
-
diff --git a/compiler/sparc/static-fn.lisp b/compiler/sparc/static-fn.lisp
deleted file mode 100644
index 168b4e28db1c889b58d8ecfe8f31041e607417e3..0000000000000000000000000000000000000000
--- a/compiler/sparc/static-fn.lisp
+++ /dev/null
@@ -1,150 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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/sparc/static-fn.lisp,v 1.4 1992/12/17 09:42:02 wlott Exp $
-;;;
-;;; This file contains the VOPs and macro magic necessary to call static
-;;; functions.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "SPARC")
-
-
-
-(define-vop (static-function-template)
-  (:save-p t)
-  (:policy :safe)
-  (:variant-vars symbol)
-  (:vop-var vop)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg)) move-temp)
-  (:temporary (:sc descriptor-reg :offset lra-offset) lra)
-  (:temporary (:scs (descriptor-reg)) func)
-  (:temporary (:sc any-reg :offset nargs-offset) nargs)
-  (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
-  (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
-
-
-(eval-when (compile load eval)
-
-
-(defun static-function-template-name (num-args num-results)
-  (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
-		  num-args num-results)))
-
-
-(defun moves (dst src)
-  (collect ((moves))
-    (do ((dst dst (cdr dst))
-	 (src src (cdr src)))
-	((or (null dst) (null src)))
-      (moves `(move ,(car dst) ,(car src))))
-    (moves)))
-
-(defun static-function-template-vop (num-args num-results)
-  (assert (and (<= num-args register-arg-count)
-	       (<= num-results register-arg-count))
-	  (num-args num-results)
-	  "Either too many args (~D) or too many results (~D).  Max = ~D"
-	  num-args num-results register-arg-count)
-  (let ((num-temps (max num-args num-results)))
-    (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
-      (dotimes (i num-results)
-	(let ((result-name (intern (format nil "RESULT-~D" i))))
-	  (result-names result-name)
-	  (results `(,result-name :scs (any-reg descriptor-reg)))))
-      (dotimes (i num-temps)
-	(let ((temp-name (intern (format nil "TEMP-~D" i))))
-	  (temp-names temp-name)
-	  (temps `(:temporary (:sc descriptor-reg
-			       :offset ,(nth i register-arg-offsets)
-			       ,@(when (< i num-args)
-				   `(:from (:argument ,i)))
-			       ,@(when (< i num-results)
-				   `(:to (:result ,i)
-				     :target ,(nth i (result-names)))))
-			      ,temp-name))))
-      (dotimes (i num-args)
-	(let ((arg-name (intern (format nil "ARG-~D" i))))
-	  (arg-names arg-name)
-	  (args `(,arg-name
-		  :scs (any-reg descriptor-reg)
-		  :target ,(nth i (temp-names))))))
-      `(define-vop (,(static-function-template-name num-args num-results)
-		    static-function-template)
-	 (:args ,@(args))
-	 ,@(temps)
-	 (:results ,@(results))
-	 (:generator ,(+ 50 num-args num-results)
-	   (let ((lra-label (gen-label))
-		 (cur-nfp (current-nfp-tn vop)))
-	     ,@(moves (temp-names) (arg-names))
-	     (inst ld func null-tn (static-function-offset symbol))
-	     (inst li nargs (fixnum ,num-args))
-	     (when cur-nfp
-	       (store-stack-tn nfp-save cur-nfp))
-	     (inst move old-fp cfp-tn)
-	     (inst move cfp-tn csp-tn)
-	     (inst compute-lra-from-code lra code-tn lra-label temp)
-	     (note-this-location vop :call-site)
-	     (inst j func (- (ash function-code-offset word-shift)
-			     function-pointer-type))
-	     (inst move code-tn func)
-	     (emit-return-pc lra-label)
-	     ,(collect ((bindings) (links))
-		(do ((temp (temp-names) (cdr temp))
-		     (name 'values (gensym))
-		     (prev nil name)
-		     (i 0 (1+ i)))
-		    ((= i num-results))
-		  (bindings `(,name
-			      (make-tn-ref ,(car temp) nil)))
-		  (when prev
-		    (links `(setf (tn-ref-across ,prev) ,name))))
-		`(let ,(bindings)
-		   ,@(links)
-		   (default-unknown-values vop
-		       ,(if (zerop num-results) nil 'values)
-		       ,num-results move-temp temp lra-label)))
-	     (when cur-nfp
-	       (load-stack-tn cur-nfp nfp-save))
-	     ,@(moves (result-names) (temp-names))))))))
-
-
-) ; eval-when (compile load eval)
-
-
-(macrolet ((frob (num-args num-res)
-	     (static-function-template-vop (eval num-args) (eval num-res))))
-  (frob 0 1)
-  (frob 1 1)
-  (frob 2 1)
-  (frob 3 1)
-  (frob 4 1)
-  (frob 5 1))
-
-
-(defmacro define-static-function (name args &key (results '(x)) translate
-				       policy cost arg-types result-types)
-  `(define-vop (,name
-		,(static-function-template-name (length args)
-						(length results)))
-     (:variant ',name)
-     (:note ,(format nil "static-function ~@(~S~)" name))
-     ,@(when translate
-	 `((:translate ,translate)))
-     ,@(when policy
-	 `((:policy ,policy)))
-     ,@(when cost
-	 `((:generator-cost ,cost)))
-     ,@(when arg-types
-	 `((:arg-types ,@arg-types)))
-     ,@(when result-types
-	 `((:result-types ,@result-types)))))
diff --git a/compiler/sparc/subprim.lisp b/compiler/sparc/subprim.lisp
deleted file mode 100644
index 726b4ac59ac72057510436250d7a02149e37f1de..0000000000000000000000000000000000000000
--- a/compiler/sparc/subprim.lisp
+++ /dev/null
@@ -1,62 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/subprim.lisp,v 1.2 1992/10/11 10:54:22 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Linkage information for standard static functions, and random vops.
-;;;
-;;; Written by William Lott.
-;;; 
-(in-package "SPARC")
-
-
-
-;;;; Length
-
-(define-vop (length/list)
-  (:translate length)
-  (:args (object :scs (descriptor-reg) :target ptr))
-  (:arg-types list)
-  (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr)
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result)
-	      count)
-  (:results (result :scs (any-reg descriptor-reg)))
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 50
-    (let ((done (gen-label))
-	  (loop (gen-label))
-	  (not-list (generate-cerror-code vop object-not-list-error object)))
-      (move ptr object)
-      (move count zero-tn)
-
-      (emit-label loop)
-
-      (inst cmp ptr null-tn)
-      (inst b :eq done)
-      (inst nop)
-
-      (test-type ptr temp not-list t vm:list-pointer-type)
-
-      (loadw ptr ptr vm:cons-cdr-slot vm:list-pointer-type)
-      (inst add count count (fixnum 1))
-      (test-type ptr temp loop nil vm:list-pointer-type)
-
-      (cerror-call vop done object-not-list-error ptr)
-
-      (emit-label done)
-      (move result count))))
-       
-
-(define-static-function length (object) :translate length)
-
diff --git a/compiler/sparc/system.lisp b/compiler/sparc/system.lisp
deleted file mode 100644
index 1f29d07edd9002e5ec2fe0b87b6f78a2406806e0..0000000000000000000000000000000000000000
--- a/compiler/sparc/system.lisp
+++ /dev/null
@@ -1,245 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/system.lisp,v 1.9 1992/10/11 10:54:24 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    MIPS VM definitions of various system hacking operations.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Mips conversion by William Lott and Christopher Hoover.
-;;;
-(in-package "SPARC")
-
-
-
-;;;; Type frobbing VOPs
-
-(define-vop (get-lowtag)
-  (:translate get-lowtag)
-  (:policy :fast-safe)
-  (:args (object :scs (any-reg descriptor-reg)))
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 1
-    (inst and result object vm:lowtag-mask)))
-
-(define-vop (get-type)
-  (:translate get-type)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (let ((other-ptr (gen-label))
-	  (function-ptr (gen-label))
-	  (done (gen-label)))
-      (test-type object ndescr other-ptr nil vm:other-pointer-type)
-      (test-type object ndescr function-ptr nil vm:function-pointer-type)
-      (inst andcc result object
-	    (logand vm:other-immediate-0-type vm:other-immediate-1-type))
-      (inst b :eq done)
-      (inst nop)
-
-      (inst b done)
-      (inst and result object vm:type-mask)
-
-      (emit-label function-ptr)
-      (load-type result object (- vm:function-pointer-type))
-      (inst b done)
-      (inst nop)
-
-      (emit-label other-ptr)
-      (load-type result object (- vm:other-pointer-type))
-      (inst nop)
-      
-      (emit-label done))))
-
-(define-vop (function-subtype)
-  (:translate function-subtype)
-  (:policy :fast-safe)
-  (:args (function :scs (descriptor-reg)))
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (load-type result function (- vm:function-pointer-type))))
-
-(define-vop (set-function-subtype)
-  (:translate (setf function-subtype))
-  (:policy :fast-safe)
-  (:args (type :scs (unsigned-reg) :target result)
-	 (function :scs (descriptor-reg)))
-  (:arg-types positive-fixnum *)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (inst stb type function (- 3 function-pointer-type))
-    (move result type)))
-
-(define-vop (get-header-data)
-  (:translate get-header-data)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (loadw res x 0 vm:other-pointer-type)
-    (inst srl res res vm:type-bits)))
-
-(define-vop (get-closure-length)
-  (:translate get-closure-length)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg)))
-  (:results (res :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:generator 6
-    (loadw res x 0 vm:function-pointer-type)
-    (inst srl res res vm:type-bits)))
-
-(define-vop (set-header-data)
-  (:translate set-header-data)
-  (:policy :fast-safe)
-  (:args (x :scs (descriptor-reg) :target res)
-	 (data :scs (any-reg immediate zero)))
-  (:arg-types * positive-fixnum)
-  (:results (res :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) t1 t2)
-  (:generator 6
-    (loadw t1 x 0 vm:other-pointer-type)
-    (inst and t1 vm:type-mask)
-    (sc-case data
-      (any-reg
-       (inst sll t2 data (- vm:type-bits 2))
-       (inst or t1 t2))
-      (immediate
-       (inst or t1 (ash (tn-value data) vm:type-bits)))
-      (zero))
-    (storew t1 x 0 vm:other-pointer-type)
-    (move res x)))
-
-
-(define-vop (make-fixnum)
-  (:args (ptr :scs (any-reg descriptor-reg)))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 1
-    ;;
-    ;; Some code (the hash table code) depends on this returning a
-    ;; positive number so make sure it does.
-    (inst sll res ptr 3)
-    (inst srl res res 1)))
-
-(define-vop (make-other-immediate-type)
-  (:args (val :scs (any-reg descriptor-reg))
-	 (type :scs (any-reg descriptor-reg immediate)
-	       :target temp))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 2
-    (sc-case type
-      (immediate
-       (inst sll temp val vm:type-bits)
-       (inst or res temp (tn-value type)))
-      (t
-       (inst sra temp type 2)
-       (inst sll res val (- vm:type-bits 2))
-       (inst or res res temp)))))
-
-
-;;;; Allocation
-
-(define-vop (dynamic-space-free-pointer)
-  (:results (int :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate dynamic-space-free-pointer)
-  (:policy :fast-safe)
-  (:generator 1
-    (move int alloc-tn)))
-
-(define-vop (binding-stack-pointer-sap)
-  (:results (int :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate binding-stack-pointer-sap)
-  (:policy :fast-safe)
-  (:generator 1
-    (move int bsp-tn)))
-
-(define-vop (control-stack-pointer-sap)
-  (:results (int :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:translate control-stack-pointer-sap)
-  (:policy :fast-safe)
-  (:generator 1
-    (move int csp-tn)))
-
-
-;;;; Code object frobbing.
-
-(define-vop (code-instructions)
-  (:translate code-instructions)
-  (:policy :fast-safe)
-  (:args (code :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:results (sap :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:generator 10
-    (loadw ndescr code 0 vm:other-pointer-type)
-    (inst srl ndescr vm:type-bits)
-    (inst sll ndescr vm:word-shift)
-    (inst sub ndescr vm:other-pointer-type)
-    (inst add sap code ndescr)))
-
-(define-vop (compute-function)
-  (:args (code :scs (descriptor-reg))
-	 (offset :scs (signed-reg unsigned-reg)))
-  (:arg-types * positive-fixnum)
-  (:results (func :scs (descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:generator 10
-    (loadw ndescr code 0 vm:other-pointer-type)
-    (inst srl ndescr vm:type-bits)
-    (inst sll ndescr vm:word-shift)
-    (inst add ndescr offset)
-    (inst add ndescr (- vm:function-pointer-type vm:other-pointer-type))
-    (inst add func code ndescr)))
-
-
-
-;;;; Other random VOPs.
-
-
-(defknown unix::do-pending-interrupt () (values))
-(define-vop (unix::do-pending-interrupt)
-  (:policy :fast-safe)
-  (:translate unix::do-pending-interrupt)
-  (:generator 1
-    (inst unimp pending-interrupt-trap)))
-
-
-(define-vop (halt)
-  (:generator 1
-    (inst unimp halt-trap)))
-
-
-
-;;;; Dynamic vop count collection support
-
-(define-vop (count-me)
-  (:args (count-vector :scs (descriptor-reg)))
-  (:info index)
-  (:temporary (:scs (non-descriptor-reg)) count)
-  (:generator 1
-    (let ((offset
-	   (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
-      (assert (typep offset '(signed-byte 13)))
-      (inst ld count count-vector offset)
-      (inst add count 1)
-      (inst st count count-vector offset))))
diff --git a/compiler/sparc/type-vops.lisp b/compiler/sparc/type-vops.lisp
deleted file mode 100644
index e8c3e2a887f3f452231b3264afa470d6c93dcdb3..0000000000000000000000000000000000000000
--- a/compiler/sparc/type-vops.lisp
+++ /dev/null
@@ -1,421 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/type-vops.lisp,v 1.12 1992/12/05 21:57:12 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;; 
-;;; This file contains the VM definition of type testing and checking VOPs
-;;; for the SPARC.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "SPARC")
-
-
-;;;; Simple type checking and testing:
-;;;
-;;;    These types are represented by a single type code, so are easily
-;;; open-coded as a mask and compare.
-
-(define-vop (check-type)
-  (:args (value :target result :scs (any-reg descriptor-reg)))
-  (:results (result :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:vop-var vop)
-  (:save-p :compute-only))
-
-(define-vop (type-predicate)
-  (:args (value :scs (any-reg descriptor-reg)))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:temporary (:scs (non-descriptor-reg)) temp))
-
-(eval-when (compile eval)
-
-(defun cost-to-test-types (type-codes)
-  (+ (* 2 (length type-codes))
-     (if (> (apply #'max type-codes) vm:lowtag-limit) 7 2)))
-
-(defmacro def-type-vops (pred-name check-name ptype error-code
-				   &rest type-codes)
-  (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
-    `(progn
-       ,@(when pred-name
-	   `((define-vop (,pred-name type-predicate)
-	       (:translate ,pred-name)
-	       (:generator ,cost
-		 (test-type value temp target not-p ,@type-codes)))))
-       ,@(when check-name
-	   `((define-vop (,check-name check-type)
-	       (:generator ,cost
-		 (let ((err-lab
-			(generate-error-code vop ,error-code value)))
-		   (test-type value temp err-lab t ,@type-codes)
-		   (move result value))))))
-       ,@(when ptype
-	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
-
-); eval-when (compile eval)
-
-(def-type-vops fixnump nil nil nil vm:even-fixnum-type vm:odd-fixnum-type)
-(define-vop (check-fixnum check-type)
-  (:ignore temp)
-  (:generator 1
-    (inst taddcctv result value zero-tn)))
-(primitive-type-vop check-fixnum (:check) fixnum)
-
-
-(def-type-vops functionp check-function function
-  object-not-function-error vm:function-pointer-type)
-
-(def-type-vops listp nil nil nil vm:list-pointer-type)
-(define-vop (check-list check-type)
-  (:generator 3
-    (inst and temp value lowtag-mask)
-    (inst cmp temp list-pointer-type)
-    (inst t :ne (logior (ash (tn-offset value) 8) object-not-list-trap))
-    (move result value)))
-(primitive-type-vop check-list (:check) list)
-
-(def-type-vops structurep nil nil nil vm:structure-pointer-type)
-(define-vop (check-structure check-type)
-  (:generator 3
-    (inst and temp value lowtag-mask)
-    (inst cmp temp structure-pointer-type)
-    (inst t :ne (logior (ash (tn-offset value) 8) object-not-structure-trap))
-    (move result value)))
-(primitive-type-vop check-structure (:check) structure)
-
-(def-type-vops bignump check-bigunm bignum
-  object-not-bignum-error vm:bignum-type)
-
-(def-type-vops ratiop check-ratio ratio
-  object-not-ratio-error vm:ratio-type)
-
-(def-type-vops complexp check-complex complex
-  object-not-complex-error vm:complex-type)
-
-(def-type-vops single-float-p check-single-float single-float
-  object-not-single-float-error vm:single-float-type)
-
-(def-type-vops double-float-p check-double-float double-float
-  object-not-double-float-error vm:double-float-type)
-
-(def-type-vops simple-string-p check-simple-string simple-string
-  object-not-simple-string-error vm:simple-string-type)
-
-(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
-  object-not-simple-bit-vector-error vm:simple-bit-vector-type)
-
-(def-type-vops simple-vector-p check-simple-vector simple-vector
-  object-not-simple-vector-error vm:simple-vector-type)
-
-(def-type-vops simple-array-unsigned-byte-2-p
-  check-simple-array-unsigned-byte-2
-  simple-array-unsigned-byte-2
-  object-not-simple-array-unsigned-byte-2-error
-  vm:simple-array-unsigned-byte-2-type)
-
-(def-type-vops simple-array-unsigned-byte-4-p
-  check-simple-array-unsigned-byte-4
-  simple-array-unsigned-byte-4
-  object-not-simple-array-unsigned-byte-4-error
-  vm:simple-array-unsigned-byte-4-type)
-
-(def-type-vops simple-array-unsigned-byte-8-p
-  check-simple-array-unsigned-byte-8
-  simple-array-unsigned-byte-8
-  object-not-simple-array-unsigned-byte-8-error
-  vm:simple-array-unsigned-byte-8-type)
-
-(def-type-vops simple-array-unsigned-byte-16-p
-  check-simple-array-unsigned-byte-16
-  simple-array-unsigned-byte-16
-  object-not-simple-array-unsigned-byte-16-error
-  vm:simple-array-unsigned-byte-16-type)
-
-(def-type-vops simple-array-unsigned-byte-32-p
-  check-simple-array-unsigned-byte-32
-  simple-array-unsigned-byte-32
-  object-not-simple-array-unsigned-byte-32-error
-  vm:simple-array-unsigned-byte-32-type)
-
-(def-type-vops simple-array-single-float-p check-simple-array-single-float
-  simple-array-single-float object-not-simple-array-single-float-error
-  vm:simple-array-single-float-type)
-
-(def-type-vops simple-array-double-float-p check-simple-array-double-float
-  simple-array-double-float object-not-simple-array-double-float-error
-  vm:simple-array-double-float-type)
-
-(def-type-vops base-char-p check-base-char base-char
-  object-not-base-char-error vm:base-char-type)
-
-(def-type-vops system-area-pointer-p check-system-area-pointer
-  system-area-pointer object-not-sap-error vm:sap-type)
-
-(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
-  object-not-weak-pointer-error vm:weak-pointer-type)
-
-(def-type-vops scavenger-hook-p nil nil nil
-  0)
-
-(def-type-vops code-component-p nil nil nil
-  vm:code-header-type)
-
-(def-type-vops lra-p nil nil nil
-  vm:return-pc-header-type)
-
-(def-type-vops fdefn-p nil nil nil
-  vm:fdefn-type)
-
-(def-type-vops funcallable-instance-p nil nil nil
-  vm:funcallable-instance-header-type)
-
-(def-type-vops dylan::dylan-function-p nil nil nil
-  dylan-function-header-type)
-
-(def-type-vops array-header-p nil nil nil
-  vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type
-  vm:complex-vector-type vm:complex-array-type)
-
-(def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error
-  vm:function-pointer-type vm:symbol-header-type)
-
-(def-type-vops stringp check-string nil object-not-string-error
-  vm:simple-string-type vm:complex-string-type)
-
-(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
-  vm:simple-bit-vector-type vm:complex-bit-vector-type)
-
-(def-type-vops vectorp check-vector nil object-not-vector-error
-  vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type
-  vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type
-  vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type
-  vm:simple-array-unsigned-byte-32-type vm:simple-array-single-float-type
-  vm:simple-array-double-float-type vm:complex-string-type
-  vm:complex-bit-vector-type vm:complex-vector-type)
-
-(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
-  vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
-  vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
-  vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
-  vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
-  vm:simple-array-single-float-type vm:simple-array-double-float-type)
-
-(def-type-vops arrayp check-array nil object-not-array-error
-  vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
-  vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
-  vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
-  vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
-  vm:simple-array-single-float-type vm:simple-array-double-float-type
-  vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type
-  vm:complex-array-type)
-
-(def-type-vops numberp check-number nil object-not-number-error
-  vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type
-  vm:single-float-type vm:double-float-type vm:complex-type)
-
-(def-type-vops rationalp check-rational nil object-not-rational-error
-  vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type)
-
-(def-type-vops integerp check-integer nil object-not-integer-error
-  vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type)
-
-(def-type-vops floatp check-float nil object-not-float-error
-  vm:single-float-type vm:double-float-type)
-
-(def-type-vops realp check-real nil 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)
-
-
-;;;; Other integer ranges.
-
-;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
-;;; exactly one digit.
-
-(define-vop (signed-byte-32-p type-predicate)
-  (:translate signed-byte-32-p)
-  (:generator 45
-    (let ((not-target (gen-label)))
-      (multiple-value-bind
-	  (yep nope)
-	  (if not-p
-	      (values not-target target)
-	      (values target not-target))
-	(inst andcc zero-tn value #x3)
-	(inst b :eq yep)
-	(test-type value temp nope t vm:other-pointer-type)
-	(loadw temp value 0 vm:other-pointer-type)
-	(inst cmp temp (+ (ash 1 vm:type-bits)
-			  vm:bignum-type))
-	(inst b (if not-p :ne :eq) target)
-	(inst nop)
-	(emit-label not-target)))))
-
-(define-vop (check-signed-byte-32 check-type)
-  (:generator 45
-    (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
-	  (yep (gen-label)))
-      (inst andcc temp value #x3)
-      (inst b :eq yep)
-      (test-type value temp nope t vm:other-pointer-type)
-      (loadw temp value 0 vm:other-pointer-type)
-      (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type))
-      (inst b :ne nope)
-      (inst nop)
-      (emit-label yep)
-      (move result value))))
-
-
-;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
-;;; bignum with exactly one positive digit, or a bignum with exactly two digits
-;;; and the second digit all zeros.
-
-(define-vop (unsigned-byte-32-p type-predicate)
-  (:translate unsigned-byte-32-p)
-  (:generator 45
-    (let ((not-target (gen-label))
-	  (single-word (gen-label))
-	  (fixnum (gen-label)))
-      (multiple-value-bind
-	  (yep nope)
-	  (if not-p
-	      (values not-target target)
-	      (values target not-target))
-	;; Is it a fixnum?
-	(inst andcc temp value #x3)
-	(inst b :eq fixnum)
-	(inst cmp value)
-
-	;; If not, is it an other pointer?
-	(test-type value temp nope t vm:other-pointer-type)
-	;; Get the header.
-	(loadw temp value 0 vm:other-pointer-type)
-	;; Is it one?
-	(inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type))
-	(inst b :eq single-word)
-	;; If it's other than two, we can't be an (unsigned-byte 32)
-	(inst cmp temp (+ (ash 2 vm:type-bits) vm:bignum-type))
-	(inst b :ne nope)
-	;; Get the second digit.
-	(loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
-	;; All zeros, its an (unsigned-byte 32).
-	(inst cmp temp)
-	(inst b :eq yep)
-	(inst nop)
-	;; Otherwise, it isn't.
-	(inst b nope)
-	(inst nop)
-	
-	(emit-label single-word)
-	;; Get the single digit.
-	(loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
-	(inst cmp temp)
-
-	;; positive implies (unsigned-byte 32).
-	(emit-label fixnum)
-	(inst b (if not-p :lt :ge) target)
-	(inst nop)
-
-	(emit-label not-target)))))	  
-
-(define-vop (check-unsigned-byte-32 check-type)
-  (:generator 45
-    (let ((nope
-	   (generate-error-code vop object-not-unsigned-byte-32-error value))
-	  (yep (gen-label))
-	  (fixnum (gen-label))
-	  (single-word (gen-label)))
-      ;; Is it a fixnum?
-      (inst andcc temp value #x3)
-      (inst b :eq fixnum)
-      (inst cmp value)
-
-      ;; If not, is it an other pointer?
-      (test-type value temp nope t vm:other-pointer-type)
-      ;; Get the number of digits.
-      (loadw temp value 0 vm:other-pointer-type)
-      ;; Is it one?
-      (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type))
-      (inst b :eq single-word)
-      ;; If it's other than two, we can't be an (unsigned-byte 32)
-      (inst cmp temp (+ (ash 2 vm:type-bits) vm:bignum-type))
-      (inst b :ne nope)
-      ;; Get the second digit.
-      (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
-      ;; All zeros, its an (unsigned-byte 32).
-      (inst cmp temp)
-      (inst b :eq yep)
-      ;; Otherwise, it isn't.
-      (inst b :ne nope)
-      (inst nop)
-      
-      (emit-label single-word)
-      ;; Get the single digit.
-      (loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
-      ;; positive implies (unsigned-byte 32).
-      (inst cmp temp)
-      
-      (emit-label fixnum)
-      (inst b :lt nope)
-      (inst nop)
-      
-      (emit-label yep)
-      (move result value))))
-
-
-
-
-;;;; List/symbol types:
-;;; 
-;;; symbolp (or symbol (eq nil))
-;;; consp (and list (not (eq nil)))
-
-(define-vop (symbolp type-predicate)
-  (:translate symbolp)
-  (:generator 12
-    (let* ((drop-thru (gen-label))
-	   (is-symbol-label (if not-p drop-thru target)))
-      (inst cmp value null-tn)
-      (inst b :eq is-symbol-label)
-      (test-type value temp target not-p vm:symbol-header-type)
-      (emit-label drop-thru))))
-
-(define-vop (check-symbol check-type)
-  (:generator 12
-    (let ((drop-thru (gen-label))
-	  (error (generate-error-code vop object-not-symbol-error value)))
-      (inst cmp value null-tn)
-      (inst b :eq drop-thru)
-      (test-type value temp error t vm:symbol-header-type)
-      (emit-label drop-thru)
-      (move result value))))
-  
-(define-vop (consp type-predicate)
-  (:translate consp)
-  (:generator 8
-    (let* ((drop-thru (gen-label))
-	   (is-not-cons-label (if not-p target drop-thru)))
-      (inst cmp value null-tn)
-      (inst b :eq is-not-cons-label)
-      (test-type value temp target not-p vm:list-pointer-type)
-      (emit-label drop-thru))))
-
-(define-vop (check-cons check-type)
-  (:generator 8
-    (let ((error (generate-error-code vop object-not-cons-error value)))
-      (inst cmp value null-tn)
-      (inst b :eq error)
-      (test-type value temp error t vm:list-pointer-type)
-      (move result value))))
-
diff --git a/compiler/sparc/values.lisp b/compiler/sparc/values.lisp
deleted file mode 100644
index db76810548e57394b6860bde1cb0d70565b89c10..0000000000000000000000000000000000000000
--- a/compiler/sparc/values.lisp
+++ /dev/null
@@ -1,91 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/values.lisp,v 1.2 1992/10/11 10:54:28 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains the implementation of unknown-values VOPs.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted for SPARC by William Lott.
-;;; 
-
-(in-package "SPARC")
-
-(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 (any-reg) :from :load)
-	    (count :scs (any-reg)))
-  (:info nvals)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:generator 20
-    (inst move start csp-tn)
-    (inst add 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 i))
-	  (control-stack
-	   (load-stack-tn temp tn)
-	   (storew temp start i)))))
-    (inst li count (fixnum 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))
-	    (count :scs (any-reg)))
-  (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 0
-    (let ((loop (gen-label))
-	  (done (gen-label)))
-
-      (move list arg)
-      (move start csp-tn)
-
-      (emit-label loop)
-      (inst cmp list null-tn)
-      (inst b :eq done)
-      (loadw temp list vm:cons-car-slot vm:list-pointer-type)
-      (loadw list list vm:cons-cdr-slot vm:list-pointer-type)
-      (inst add csp-tn csp-tn vm:word-bytes)
-      (storew temp csp-tn -1)
-      (test-type list ndescr loop nil vm:list-pointer-type)
-      (error-call vop bogus-argument-to-values-list-error list)
-
-      (emit-label done)
-      (inst sub count csp-tn start))))
-
diff --git a/compiler/sparc/vm.lisp b/compiler/sparc/vm.lisp
deleted file mode 100644
index 773b833b03d90a1777e3cde78d8fb30a4c49eb06..0000000000000000000000000000000000000000
--- a/compiler/sparc/vm.lisp
+++ /dev/null
@@ -1,340 +0,0 @@
-;;; -*- Package: SPARC -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/vm.lisp,v 1.6 1992/05/21 02:21:35 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the VM definition for the SPARC.
-;;;
-;;; Written by William Lott.
-;;;
-(in-package "SPARC")
-
-
-;;;; Define the registers
-
-(eval-when (compile eval)
-
-(defmacro defreg (name offset)
-  (let ((offset-sym (symbolicate name "-OFFSET")))
-    `(eval-when (compile eval load)
-       (defconstant ,offset-sym ,offset)
-       (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
-
-(defmacro defregset (name &rest regs)
-  `(eval-when (compile eval load)
-     (defconstant ,name
-       (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))
-
-); eval-when (compile eval)
-
-
-(eval-when (compile load eval)
-
-(defvar *register-names* (make-array 32 :initial-element nil))
-
-); eval-when (compile load eval)
-
-
-;; Globals.  These are difficult to extract from a sigcontext.
-(defreg zero 0)
-(defreg alloc 1)
-(defreg null 2)
-(defreg csp 3)
-(defreg cfp 4)
-(defreg bsp 5)
-(defreg nfp 6)
-(defreg cfunc 7)
-
-;; Outs.  These get clobbered when we call into C.
-(defreg nl0 8)
-(defreg nl1 9)
-(defreg nl2 10)
-(defreg nl3 11)
-(defreg nl4 12)
-(defreg nl5 13)
-(defreg nsp 14)
-(defreg nargs 15)
-
-;; Locals.  These are preserved when we call into C.
-(defreg a0 16)
-(defreg a1 17)
-(defreg a2 18)
-(defreg a3 19)
-(defreg a4 20)
-(defreg a5 21)
-(defreg ocfp 22)
-(defreg lra 23)
-
-;; Ins.  These are preserved just like locals.
-(defreg cname 24)
-(defreg lexenv 25)
-(defreg l0 26)
-(defreg l1 27)
-(defreg l2 28)
-(defreg code 29)
-;; we can't touch reg 30 if we ever want to return
-(defreg lip 31)
-
-(defregset non-descriptor-regs
-  nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp)
-
-(defregset descriptor-regs
-  a0 a1 a2 a3 a4 a5 ocfp lra cname lexenv l0 l1 l2)
-
-(defregset register-arg-offsets
-  a0 a1 a2 a3 a4 a5)
-
-
-
-;;;; SB and SC definition:
-
-(define-storage-base registers :finite :size 32)
-(define-storage-base float-registers :finite :size 32)
-(define-storage-base control-stack :unbounded :size 8)
-(define-storage-base non-descriptor-stack :unbounded :size 0)
-(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)
-  (do ((forms (list 'progn)
-	      (let* ((class (car classes))
-		     (sc-name (car class))
-		     (constant-name (intern (concatenate 'simple-string
-							 (string sc-name)
-							 "-SC-NUMBER"))))
-		(list* `(define-storage-class ,sc-name ,index
-			  ,@(cdr class))
-		       `(defconstant ,constant-name ,index)
-		       `(export ',constant-name)
-		       forms)))
-       (index 0 (1+ index))
-       (classes classes (cdr classes)))
-      ((null classes)
-       (nreverse forms))))
-
-(define-storage-classes
-
-  ;; Non-immediate contstants in the constant pool
-  (constant constant)
-
-  ;; ZERO and NULL are in registers.
-  (zero immediate-constant)
-  (null immediate-constant)
-
-  ;; Anything else that can be an immediate.
-  (immediate immediate-constant)
-
-
-  ;; **** The stacks.
-
-  ;; The control stack.  (Scanned by GC)
-  (control-stack control-stack)
-
-  ;; The non-descriptor stacks.
-  (signed-stack non-descriptor-stack) ; (signed-byte 32)
-  (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
-  (base-char-stack non-descriptor-stack) ; non-descriptor characters.
-  (sap-stack non-descriptor-stack) ; System area pointers.
-  (single-stack non-descriptor-stack) ; single-floats
-  (double-stack non-descriptor-stack
-		:element-size 2 :alignment 2) ; double floats.
-
-
-  ;; **** Things that can go in the integer registers.
-
-  ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
-  ;; bad will happen if they are.  (fixnums, characters, header values, etc).
-  (any-reg
-   registers
-   :locations #.(append non-descriptor-regs descriptor-regs)
-   :constant-scs (zero immediate)
-   :save-p t
-   :alternate-scs (control-stack))
-
-  ;; Pointer descriptor objects.  Must be seen by GC.
-  (descriptor-reg registers
-   :locations #.descriptor-regs
-   :constant-scs (constant null immediate)
-   :save-p t
-   :alternate-scs (control-stack))
-
-  ;; Non-Descriptor characters
-  (base-char-reg registers
-   :locations #.non-descriptor-regs
-   :constant-scs (immediate)
-   :save-p t
-   :alternate-scs (base-char-stack))
-
-  ;; Non-Descriptor SAP's (arbitrary pointers into address space)
-  (sap-reg registers
-   :locations #.non-descriptor-regs
-   :constant-scs (immediate)
-   :save-p t
-   :alternate-scs (sap-stack))
-
-  ;; Non-Descriptor (signed or unsigned) numbers.
-  (signed-reg registers
-   :locations #.non-descriptor-regs
-   :constant-scs (zero immediate)
-   :save-p t
-   :alternate-scs (signed-stack))
-  (unsigned-reg registers
-   :locations #.non-descriptor-regs
-   :constant-scs (zero immediate)
-   :save-p t
-   :alternate-scs (unsigned-stack))
-
-  ;; Random objects that must not be seen by GC.  Used only as temporaries.
-  (non-descriptor-reg registers
-   :locations #.non-descriptor-regs)
-
-  ;; Pointers to the interior of objects.  Used only as an temporary.
-  (interior-reg registers
-   :locations (#.lip-offset))
-
-
-  ;; **** Things that can go in the floating point registers.
-
-  ;; Non-Descriptor single-floats.
-  (single-reg float-registers
-   :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
-   ;; ### Note: We really should have every location listed, but then we
-   ;; would have to make load-tns work with element-sizes other than 1.
-   :constant-scs ()
-   :save-p t
-   :alternate-scs (single-stack))
-
-  ;; Non-Descriptor double-floats.
-  (double-reg float-registers
-   :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
-   ;; ### Note: load-tns don't work with an element-size other than 1.
-   ;; :element-size 2 :alignment 2
-   :constant-scs ()
-   :save-p t
-   :alternate-scs (double-stack))
-
-
-  ;; A catch or unwind block.
-  (catch-block control-stack :element-size vm:catch-block-size))
-
-
-
-;;;; Make some random tns for important registers.
-
-(eval-when (compile eval)
-
-(defmacro defregtn (name sc)
-  (let ((offset-sym (symbolicate name "-OFFSET"))
-	(tn-sym (symbolicate name "-TN")))
-    `(defparameter ,tn-sym
-       (make-random-tn :kind :normal
-		       :sc (sc-or-lose ',sc)
-		       :offset ,offset-sym))))
-
-); eval-when (compile eval)
-
-(defregtn zero any-reg)
-(defregtn null descriptor-reg)
-(defregtn code descriptor-reg)
-(defregtn alloc any-reg)
-
-(defregtn nargs any-reg)
-(defregtn bsp any-reg)
-(defregtn csp any-reg)
-(defregtn cfp any-reg)
-(defregtn ocfp any-reg)
-(defregtn nsp any-reg)
-
-
-
-;;; Immediate-Constant-SC  --  Interface
-;;;
-;;; If value can be represented as an immediate constant, then return the
-;;; appropriate SC number, otherwise return NIL.
-;;;
-(def-vm-support-routine immediate-constant-sc (value)
-  (typecase value
-    ((integer 0 0)
-     (sc-number-or-lose 'zero *backend*))
-    (null
-     (sc-number-or-lose 'null *backend*))
-    ((or fixnum system-area-pointer character)
-     (sc-number-or-lose 'immediate *backend*))
-    (symbol
-     (if (static-symbol-p value)
-	 (sc-number-or-lose 'immediate *backend*)
-	 nil))))
-
-
-;;;; Function Call Parameters
-
-;;; The SC numbers for register and stack arguments/return values.
-;;;
-(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
-(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
-(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
-
-(eval-when (compile load eval)
-
-;;; Offsets of special stack frame locations
-(defconstant ocfp-save-offset 0)
-(defconstant lra-save-offset 1)
-(defconstant nfp-save-offset 2)
-
-;;; The number of arguments/return values passed in registers.
-;;;
-(defconstant register-arg-count 6)
-
-;;; 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))
-
-;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
-;;;
-;;; This is used by the debugger.
-;;;
-(export 'single-value-return-byte-offset)
-(defconstant single-value-return-byte-offset 8)
-
-
-;;; LOCATION-PRINT-NAME  --  Interface
-;;;
-;;;    This function is called by debug output routines that want a pretty name
-;;; for a TN's location.  It returns a thing that can be printed with PRINC.
-;;;
-(def-vm-support-routine location-print-name (tn)
-  (declare (type tn tn))
-  (let ((sb (sb-name (sc-sb (tn-sc tn))))
-	(offset (tn-offset tn)))
-    (ecase sb
-      (registers (or (svref *register-names* offset)
-		     (format nil "R~D" offset)))
-      (float-registers (format nil "F~D" offset))
-      (control-stack (format nil "CS~D" offset))
-      (non-descriptor-stack (format nil "NS~D" offset))
-      (constant (format nil "Const~D" offset))
-      (immediate-constant "Immed"))))
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
deleted file mode 100644
index a85ab957f0ff49f486fdc211220b3736878443fd..0000000000000000000000000000000000000000
--- a/compiler/srctran.lisp
+++ /dev/null
@@ -1,1587 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.39 1992/12/13 15:18:54 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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))
-
-;;; CONSTANTLY source transform  --  Internal
-;;;
-;;;    Bind the values and make a closure that returns them.
-;;;
-(def-source-transform constantly (value &rest values)
-  (let ((temps (loop repeat (1+ (length values))
-		     collect (gensym)))
-	(dum (gensym)))
-    `(let ,(loop for temp in temps and
-	         value in (list* value values)
-	         collect `(,temp ,value))
-       #'(lambda (&rest ,dum)
-	   (declare (ignore ,dum))
-	   (values ,@temps)))))
-
-
-;;; COMPLEMENT IR1 transform  --  Internal
-;;;
-;;;    If the function has a known number of arguments, then return a lambda
-;;; with the appropriate fixed number of args.  If the destination is a
-;;; FUNCALL, then do the &REST APPLY thing, and let MV optimization figure
-;;; things out.
-;;;
-(deftransform complement ((fun) * * :node node)
-  "open code"
-  (multiple-value-bind (min max)
-		       (function-type-nargs (continuation-type fun))
-    (cond
-     ((and min (eql min max))
-      (let ((dums (loop repeat min collect (gensym))))
-	`#'(lambda ,dums (not (funcall fun ,@dums)))))
-     ((let* ((cont (node-cont node))
-	     (dest (continuation-dest cont)))
-	(and (combination-p dest)
-	     (eq (combination-fun dest) cont)))
-      '#'(lambda (&rest args)
-	   (not (apply fun args))))
-     (t
-      (give-up "Function doesn't have fixed argument count.")))))
-
-
-;;;; 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)
-  "convert NTHCDR to CAxxR"
-  (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.
-
-(macrolet ((frob (fun)
-	     `(def-source-transform ,fun (x &optional (y nil y-p))
-		(declare (ignore y))
-		(if y-p
-		    (values nil t)
-		    `(,',fun ,x 1)))))
-  (frob truncate)
-  (frob round))
-
-(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 (mask-field ,bytespec ,integer))))
-
-
-;;; With the ratio and complex accessors, we pick off the "identity" case, and
-;;; use a primitive to handle the cell access case.
-;;;
-(def-source-transform numerator (num)
-  (once-only ((n-num `(the rational ,num)))
-    `(if (ratiop ,n-num)
-	 (%numerator ,n-num)
-	 ,n-num)))
-;;;
-(def-source-transform denominator (num)
-  (once-only ((n-num `(the rational ,num)))
-    `(if (ratiop ,n-num)
-	 (%denominator ,n-num)
-	 1)))
-;;;
-(def-source-transform realpart (num)
-  (once-only ((n-num num))
-    `(if (complexp ,n-num)
-	 (%realpart ,n-num)
-	 ,n-num)))
-;;;
-(def-source-transform imagpart (num)
-  (once-only ((n-num num))
-    `(cond ((complexp ,n-num)
-	    (%imagpart ,n-num))
-	   ((floatp ,n-num)
-	    (float 0 ,n-num))
-	   (t
-	    0))))
-
-
-;;;; 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 (/ derive-type) ((x y))
-  (numeric-contagion (continuation-type x) (continuation-type y)))
-
-
-(defoptimizer (ash derive-type) ((n shift))
-  (or (let ((n-type (continuation-type n)))
-	(when (numeric-type-p n-type)
-	  (let ((n-low (numeric-type-low n-type))
-		(n-high (numeric-type-high n-type)))
-	    (if (constant-continuation-p shift)
-		(let ((shift (continuation-value shift)))
-		  (make-numeric-type :class 'integer  :complexp :real
-				     :low (when n-low
-					    #+new-compiler
-					    (ash n-low shift)
-					    ;; ### fuckin' bignum bug.
-					    #-new-compiler
-					    (* n-low (ash 1 shift)))
-				     :high (when n-high (ash n-high shift))))
-		(let ((s-type (continuation-type shift)))
-		  (when (numeric-type-p s-type)
-		    (let ((s-low (numeric-type-low s-type))
-			  (s-high (numeric-type-high s-type)))
-		      (if (and s-low s-high (<= s-low 32) (<= s-high 32))
-			  (make-numeric-type :class 'integer  :complexp :real
-					     :low (when n-low
-						    (min (ash n-low s-high)
-							 (ash n-low s-low)))
-					     :high (when n-high
-						     (max (ash n-high s-high)
-							  (ash n-high s-low))))
-			  (make-numeric-type :class 'integer
-					     :complexp :real)))))))))
-      *universal-type*))
-
-
-(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))))
-
-
-(defoptimizer (abs derive-type) ((num))
-  (let ((type (continuation-type num)))
-    (if (and (numeric-type-p type)
-	     (eq (numeric-type-class type) 'integer)
-	     (eq (numeric-type-complexp type) :real))
-	(let ((lo (numeric-type-low type))
-	      (hi (numeric-type-high type)))
-	  (make-numeric-type :class 'integer :complexp :real
-			     :low (cond ((and hi (minusp hi))
-					 (abs hi))
-					(lo
-					 (max 0 lo))
-					(t
-					 0))
-			     :high (if (and hi lo)
-				       (max (abs hi) (abs lo))
-				       nil)))
-	(numeric-contagion type type))))
-
-
-(defoptimizer (truncate derive-type) ((number divisor))
-  (let ((number-type (continuation-type number))
-	(divisor-type (continuation-type divisor))
-	(integer-type (specifier-type 'integer)))
-    (if (and (numeric-type-p number-type)
-	     (csubtypep number-type integer-type)
-	     (numeric-type-p divisor-type)
-	     (csubtypep divisor-type integer-type))
-	(let ((number-low (numeric-type-low number-type))
-	      (number-high (numeric-type-high number-type))
-	      (divisor-low (numeric-type-low divisor-type))
-	      (divisor-high (numeric-type-high divisor-type)))
-	  (values-specifier-type
-	   `(values ,(integer-truncate-derive-type number-low number-high
-						   divisor-low divisor-high)
-		    ,(integer-rem-derive-type number-low number-high
-					      divisor-low divisor-high))))
-	*universal-type*)))
-
-;;; NUMERIC-RANGE-INFO  --  internal.
-;;;
-;;; Derive useful information about the range.  Returns three values:
-;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
-;;; - The abs of the minimal value (i.e. closest to 0) in the range.
-;;; - The abs of the maximal value if there is one, or nil if it is unbounded.
-;;; 
-(defun numeric-range-info (low high)
-  (cond ((and low (not (minusp low)))
-	 (values '+ low high))
-	((and high (not (plusp high)))
-	 (values '- (- high) (if low (- low) nil)))
-	(t
-	 (values nil 0 (and low high (max (- low) high))))))
-
-;;; INTEGER-TRUNCATE-DERIVE-TYPE -- internal
-;;; 
-(defun integer-truncate-derive-type
-       (number-low number-high divisor-low divisor-high)
-  ;; The result cannot be larger in magnitude than the number, but the sign
-  ;; might change.  If we can determine the sign of either the number or
-  ;; the divisor, we can eliminate some of the cases.
-  (multiple-value-bind
-      (number-sign number-min number-max)
-      (numeric-range-info number-low number-high)
-    (multiple-value-bind
-	(divisor-sign divisor-min divisor-max)
-	(numeric-range-info divisor-low divisor-high)
-      (when (and divisor-max (zerop divisor-max))
-	;; We've got a problem: guarenteed division by zero.
-	(return-from integer-truncate-derive-type t))
-      (when (zerop divisor-min)
-	;; We'll assume that they arn't going to divide by zero.
-	(incf divisor-min))
-      (cond ((and number-sign divisor-sign)
-	     ;; We know the sign of both.
-	     (if (eq number-sign divisor-sign)
-		 ;; Same sign, so the result will be positive.
-		 `(integer ,(if divisor-max
-				(truncate number-min divisor-max)
-				0)
-			   ,(if number-max
-				(truncate number-max divisor-min)
-				'*))
-		 ;; Different signs, the result will be negative.
-		 `(integer ,(if number-max
-				(- (truncate number-max divisor-min))
-				'*)
-			   ,(if divisor-max
-				(- (truncate number-min divisor-max))
-				0))))
-	    ((eq divisor-sign '+)
-	     ;; The divisor is positive.  Therefore, the number will just
-	     ;; become closer to zero.
-	     `(integer ,(if number-low
-			    (truncate number-low divisor-min)
-			    '*)
-		       ,(if number-high
-			    (truncate number-high divisor-min)
-			    '*)))
-	    ((eq divisor-sign '-)
-	     ;; The divisor is negative.  Therefore, the absolute value of
-	     ;; the number will become closer to zero, but the sign will also
-	     ;; change.
-	     `(integer ,(if number-high
-			    (- (truncate number-high divisor-min))
-			    '*)
-		       ,(if number-low
-			    (- (truncate number-low divisor-min))
-			    '*)))
-	    ;; The divisor could be either positive or negative.
-	    (number-max
-	     ;; The number we are dividing has a bound.  Divide that by the
-	     ;; smallest posible divisor.
-	     (let ((bound (truncate number-max divisor-min)))
-	       `(integer ,(- bound) ,bound)))
-	    (t
-	     ;; The number we are dividing is unbounded, so we can't tell
-	     ;; anything about the result.
-	     'integer)))))
-	  
-(defun integer-rem-derive-type
-       (number-low number-high divisor-low divisor-high)
-  (if (and divisor-low divisor-high)
-      ;; We know the range of the divisor, and the remainder must be smaller
-      ;; than the divisor.  We can tell the sign of the remainer if we know
-      ;; the sign of the number.
-      (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
-	`(integer ,(if (or (null number-low)
-			   (minusp number-low))
-		       (- divisor-max)
-		       0)
-		  ,(if (or (null number-high)
-			   (plusp number-high))
-		       divisor-max
-		       0)))
-      ;; The divisor is potentially either very positive or very negative.
-      ;; Therefore, the remainer is unbounded, but we might be able to tell
-      ;; something about the sign from the number.
-      `(integer ,(if (and number-low (not (minusp number-low)))
-		     ;; The number we are dividing is positive.  Therefore,
-		     ;; the remainder must be positive.
-		     0
-		     '*)
-		,(if (and number-high (not (plusp number-high)))
-		     ;; The number we are dividing is negative.  Therefore,
-		     ;; the remainder must be negative.
-		     0
-		     '*))))
-
-(defoptimizer (random derive-type) ((bound &optional state))
-  (let ((type (continuation-type bound)))
-    (when (numeric-type-p type)
-      (let ((class (numeric-type-class type))
-	    (high (numeric-type-high type))
-	    (format (numeric-type-format type)))
-	(make-numeric-type
-	 :class class
-	 :format format
-	 :low (coerce 0 (or format class 'real))
-	 :high (cond ((not high) nil)
-		     ((eq class 'integer) (max (1- high) 0))
-		     ((or (consp high) (zerop high)) high)
-		     (t `(,high))))))))
-
-
-;;;; Logical derive-type methods:
-
-
-;;; Integer-Type-Length -- Internal
-;;;
-;;; Return the maximum number of bits an integer of the supplied type can take
-;;; up, or NIL if it is unbounded.  The second (third) value is T if the
-;;; integer can be positive (negative) and NIL if not.  Zero counts as
-;;; positive.
-;;;
-(defun integer-type-length (type)
-  (if (numeric-type-p type)
-      (let ((min (numeric-type-low type))
-	    (max (numeric-type-high type)))
-	(values (and min max (max (integer-length min) (integer-length max)))
-		(or (null max) (not (minusp max)))
-		(or (null min) (minusp min))))
-      (values nil t t)))
-
-(defoptimizer (logand derive-type) ((x y))
-  (multiple-value-bind
-      (x-len x-pos x-neg)
-      (integer-type-length (continuation-type x))
-    (declare (ignore x-pos))
-    (multiple-value-bind
-	(y-len y-pos y-neg)
-	(integer-type-length (continuation-type y))
-      (declare (ignore y-pos))
-      (if (not x-neg)
-	  ;; X must be positive.
-	  (if (not y-neg)
-	      ;; The must both be positive.
-	      (cond ((or (null x-len) (null y-len))
-		     (specifier-type 'unsigned-byte))
-		    ((or (zerop x-len) (zerop y-len))
-		     (specifier-type '(integer 0 0)))
-		    (t
-		     (specifier-type `(unsigned-byte ,(min x-len y-len)))))
-	      ;; X is positive, but Y might be negative.
-	      (cond ((null x-len)
-		     (specifier-type 'unsigned-byte))
-		    ((zerop x-len)
-		     (specifier-type '(integer 0 0)))
-		    (t
-		     (specifier-type `(unsigned-byte ,x-len)))))
-	  ;; X might be negative.
-	  (if (not y-neg)
-	      ;; Y must be positive.
-	      (cond ((null y-len)
-		     (specifier-type 'unsigned-byte))
-		    ((zerop y-len)
-		     (specifier-type '(integer 0 0)))
-		    (t
-		     (specifier-type
-		      `(unsigned-byte ,y-len))))
-	      ;; Either might be negative.
-	      (if (and x-len y-len)
-		  ;; The result is bounded.
-		  (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
-		  ;; We can't tell squat about the result.
-		  (specifier-type 'integer)))))))
-
-(defoptimizer (logior derive-type) ((x y))
-  (multiple-value-bind
-      (x-len x-pos x-neg)
-      (integer-type-length (continuation-type x))
-    (multiple-value-bind
-	(y-len y-pos y-neg)
-	(integer-type-length (continuation-type y))
-      (cond
-       ((and (not x-neg) (not y-neg))
-	;; Both are positive.
-	(specifier-type `(unsigned-byte ,(if (and x-len y-len)
-					     (max x-len y-len)
-					     '*))))
-       ((not x-pos)
-	;; X must be negative.
-	(if (not y-pos)
-	    ;; Both are negative.  The result is going to be negative and be
-	    ;; the same length or shorter than the smaller.
-	    (if (and x-len y-len)
-		;; It's bounded.
-		(specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
-		;; It's unbounded.
-		(specifier-type '(integer * -1)))
-	    ;; X is negative, but we don't know about Y.  The result will be
-	    ;; negative, but no more negative than X.
-	    (specifier-type
-	     `(integer ,(or (numeric-type-low (continuation-type x)) '*)
-		       -1))))
-       (t
-	;; X might be either positive or negative.
-	(if (not y-pos)
-	    ;; But Y is negative.  The result will be negative.
-	    (specifier-type
-	     `(integer ,(or (numeric-type-low (continuation-type y)) '*)
-		       -1))
-	    ;; We don't know squat about either.  It won't get any bigger.
-	    (if (and x-len y-len)
-		;; Bounded.
-		(specifier-type `(signed-byte ,(1+ (max x-len y-len))))
-		;; Unbounded.
-		(specifier-type 'integer))))))))
-
-(defoptimizer (logxor derive-type) ((x y))
-  (multiple-value-bind
-      (x-len x-pos x-neg)
-      (integer-type-length (continuation-type x))
-    (multiple-value-bind
-	(y-len y-pos y-neg)
-	(integer-type-length (continuation-type y))
-      (cond
-       ((or (and (not x-neg) (not y-neg))
-	    (and (not x-pos) (not y-pos)))
-	;; Either both are negative or both are positive.  The result will be
-	;; positive, and as long as the longer.
-	(specifier-type `(unsigned-byte ,(if (and x-len y-len)
-					     (max x-len y-len)
-					     '*))))
-       ((or (and (not x-pos) (not y-neg))
-	    (and (not y-neg) (not y-pos)))
-	;; Either X is negative and Y is positive of vice-verca.  The result
-	;; will be negative.
-	(specifier-type `(integer ,(if (and x-len y-len)
-				       (ash -1 (max x-len y-len))
-				       '*)
-				  -1)))
-       ;; We can't tell what the sign of the result is going to be.  All we
-       ;; know is that we don't create new bits.
-       ((and x-len y-len)
-	(specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
-       (t
-	(specifier-type 'integer))))))
-
-
-
-;;;; Miscellaneous derive-type methods:
-
-
-(defoptimizer (code-char derive-type) ((code))
-  (specifier-type 'base-char))
-
-
-(defoptimizer (values derive-type) ((&rest values))
-  (values-specifier-type
-   `(values ,@(mapcar #'(lambda (x)
-			  (type-specifier (continuation-type x)))
-		      values))))
-
-
-
-;;;; 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)))
-
-
-(defoptimizer (%ldb derive-type) ((size posn num))
-  (let ((size (continuation-type size)))
-    (if (and (numeric-type-p size)
-	     (csubtypep size (specifier-type 'integer)))
-	(let ((size-high (numeric-type-high size)))
-	  (if (and size-high (<= size-high vm:word-bits))
-	      (specifier-type `(unsigned-byte ,size-high))
-	      (specifier-type 'unsigned-byte)))
-	*universal-type*)))
-
-(defoptimizer (%mask-field derive-type) ((size posn num))
-  (let ((size (continuation-type size))
-	(posn (continuation-type posn)))
-    (if (and (numeric-type-p size)
-	     (csubtypep size (specifier-type 'integer))
-	     (numeric-type-p posn)
-	     (csubtypep posn (specifier-type 'integer)))
-	(let ((size-high (numeric-type-high size))
-	      (posn-high (numeric-type-high posn)))
-	  (if (and size-high posn-high
-		   (<= (+ size-high posn-high) vm:word-bits))
-	      (specifier-type `(unsigned-byte ,(+ size-high posn-high)))
-	      (specifier-type 'unsigned-byte)))
-	*universal-type*)))
-
-(defoptimizer (%dpb derive-type) ((newbyte size posn int))
-  (let ((size (continuation-type size))
-	(posn (continuation-type posn))
-	(int (continuation-type int)))
-    (if (and (numeric-type-p size)
-	     (csubtypep size (specifier-type 'integer))
-	     (numeric-type-p posn)
-	     (csubtypep posn (specifier-type 'integer))
-	     (numeric-type-p int)
-	     (csubtypep int (specifier-type 'integer)))
-	(let ((size-high (numeric-type-high size))
-	      (posn-high (numeric-type-high posn))
-	      (high (numeric-type-high int))
-	      (low (numeric-type-low int)))
-	  (if (and size-high posn-high high low
-		   (<= (+ size-high posn-high) vm:word-bits))
-	      (specifier-type
-	       (list (if (minusp low) 'signed-byte 'unsigned-byte)
-		     (max (integer-length high)
-			  (integer-length low)
-			  (+ size-high posn-high))))
-	      *universal-type*))
-	*universal-type*)))
-
-(defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
-  (let ((size (continuation-type size))
-	(posn (continuation-type posn))
-	(int (continuation-type int)))
-    (if (and (numeric-type-p size)
-	     (csubtypep size (specifier-type 'integer))
-	     (numeric-type-p posn)
-	     (csubtypep posn (specifier-type 'integer))
-	     (numeric-type-p int)
-	     (csubtypep int (specifier-type 'integer)))
-	(let ((size-high (numeric-type-high size))
-	      (posn-high (numeric-type-high posn))
-	      (high (numeric-type-high int))
-	      (low (numeric-type-low int)))
-	  (if (and size-high posn-high high low
-		   (<= (+ size-high posn-high) vm:word-bits))
-	      (specifier-type
-	       (list (if (minusp low) 'signed-byte 'unsigned-byte)
-		     (max (integer-length high)
-			  (integer-length low)
-			  (+ size-high posn-high))))
-	      *universal-type*))
-	*universal-type*)))
-
-
-
-(deftransform %ldb ((size posn int)
-		    (fixnum fixnum integer)
-		    (unsigned-byte #.vm:word-bits))
-  "convert to inline logical ops"
-  `(logand (ash int (- posn))
-	   (ash ,(1- (ash 1 vm:word-bits))
-		(- size ,vm:word-bits))))
-
-(deftransform %mask-field ((size posn int)
-			   (fixnum fixnum integer)
-			   (unsigned-byte #.vm:word-bits))
-  "convert to inline logical ops"
-  `(logand int
-	   (ash (ash ,(1- (ash 1 vm:word-bits))
-		     (- size ,vm:word-bits))
-		posn)))
-
-;;; Note: for %dpb and %deposit-field, we can't use (or (signed-byte n)
-;;; (unsigned-byte n)) as the result type, as that would allow result types
-;;; that cover the range -2^(n-1) .. 1-2^n, instead of allowing result types
-;;; of (unsigned-byte n) and result types of (signed-byte n).
-
-(deftransform %dpb ((new size posn int)
-		    *
-		    (unsigned-byte #.vm:word-bits))
-  "convert to inline logical ops"
-  `(let ((mask (ldb (byte size 0) -1)))
-     (logior (ash (logand new mask) posn)
-	     (logand int (lognot (ash mask posn))))))
-
-(deftransform %dpb ((new size posn int)
-		    *
-		    (signed-byte #.vm:word-bits))
-  "convert to inline logical ops"
-  `(let ((mask (ldb (byte size 0) -1)))
-     (logior (ash (logand new mask) posn)
-	     (logand int (lognot (ash mask posn))))))
-
-(deftransform %deposit-field ((new size posn int)
-			      *
-			      (unsigned-byte #.vm:word-bits))
-  "convert to inline logical ops"
-  `(let ((mask (ash (ldb (byte size 0) -1) posn)))
-     (logior (logand new mask)
-	     (logand int (lognot mask)))))
-
-(deftransform %deposit-field ((new size posn int)
-			      *
-			      (signed-byte #.vm:word-bits))
-  "convert to inline logical ops"
-  `(let ((mask (ash (ldb (byte size 0) -1) posn)))
-     (logior (logand new mask)
-	     (logand int (lognot mask)))))
-
-
-;;; Miscellanous numeric transforms:
-
-
-;;; COMMUTATIVE-ARG-SWAP  --  Internal
-;;;
-;;;    If a constant appears as the first arg, swap the args.
-;;;
-(deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
-  (if (and (constant-continuation-p x)
-	   (not (constant-continuation-p y)))
-      `(,(continuation-function-name (basic-combination-fun node))
-	y
-	,(continuation-value x))
-      (give-up)))
-
-(dolist (x '(= char= + * logior logand logxor))
-  (%deftransform x '(function * *) #'commutative-arg-swap
-		 "place constant arg last."))
-
-;;; Handle the case of a constant boole-code.
-;;;
-(deftransform boole ((op x y))
-  "convert to inline logical ops"
-  (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)))))
-
-
-;;;; Convert multiply/divide to shifts.
-
-;;; If arg is a constant power of two, turn * into a shift.
-;;;
-(deftransform * ((x y) (integer integer))
-  "convert x*2^k to shift"
-  (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))))
-
-;;; If both arguments and the result are (unsigned-byte 32), try to come up
-;;; with a ``better'' multiplication using multiplier recoding.  There are two
-;;; different ways the multiplier can be recoded.  The more obvious is to shift
-;;; X by the correct amount for each bit set in Y and to sum the results.  But
-;;; if there is a string of bits that are all set, you can add X shifted by
-;;; one more then the bit position of the first set bit and subtract X shifted
-;;; by the bit position of the last set bit.  We can't use this second method
-;;; when the high order bit is bit 31 because shifting by 32 doesn't work
-;;; too well.
-;;; 
-(deftransform * ((x y)
-		 ((unsigned-byte 32) (unsigned-byte 32))
-		 (unsigned-byte 32))
-  "recode as shift and add"
-  (unless (constant-continuation-p y)
-    (give-up))
-  (let ((y (continuation-value y))
-	(result nil)
-	(first-one nil))
-    (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x))
-	     (add (next-factor)
-	       (setf result
-		     (tub32
-		      (if result
-			  `(+ ,result ,(tub32 next-factor))
-			  next-factor)))))
-      (declare (inline add))
-      (dotimes (bitpos 32)
-	(if first-one
-	    (when (not (logbitp bitpos y))
-	      (add (if (= (1+ first-one) bitpos)
-		       ;; There is only a single bit in the string.
-		       `(ash x ,first-one)
-		       ;; There are at least two.
-		       `(- ,(tub32 `(ash x ,bitpos))
-			   ,(tub32 `(ash x ,first-one)))))
-	      (setf first-one nil))
-	    (when (logbitp bitpos y)
-	      (setf first-one bitpos))))
-      (when first-one
-	(cond ((= first-one 31))
-	      ((= first-one 30)
-	       (add '(ash x 30)))
-	      (t
-	       (add `(- ,(tub32 '(ash x 31)) ,(tub32 `(ash x ,first-one))))))
-	(add '(ash x 31))))
-    (or result 0)))
-
-;;; If arg is a constant power of two, turn floor into a shift and mask.
-;;; If ceiling, add in (1- (abs y)) and then do floor.
-;;;
-(flet ((frob (y ceil-p)
-	 (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))
-	   (let ((shift (- len))
-		 (mask (1- y-abs)))
-	     `(let ,(when ceil-p `((x (+ x ,(1- y-abs)))))
-		,(if (minusp y)
-		     `(values (ash (- x) ,shift)
-			      (- (logand (- x) ,mask)))
-		     `(values (ash x ,shift)
-			      (logand x ,mask))))))))
-  (deftransform floor ((x y) (integer integer))
-    "convert division by 2^k to shift"
-    (frob y nil))
-  (deftransform ceiling ((x y) (integer integer))
-    "convert division by 2^k to shift"
-    (frob y t)))
-
-
-;;; Do the same for mod.
-;;;
-(deftransform mod ((x y) (integer integer))
-  "convert remainder mod 2^k to LOGAND"
-  (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))
-    (let ((mask (1- y-abs)))
-      (if (minusp y)
-	  `(- (logand (- x) ,mask))
-	  `(logand x ,mask)))))
-
-
-;;; If arg is a constant power of two, turn truncate into a shift and mask.
-;;;
-(deftransform truncate ((x y) (integer integer))
-  "convert division by 2^k to shift"
-  (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))
-    (let* ((shift (- len))
-	   (mask (1- y-abs)))
-      `(if (minusp x)
-	   (values ,(if (minusp y)
-			`(ash (- x) ,shift)
-			`(- (ash (- x) ,shift)))
-		   (- (logand (- x) ,mask)))
-	   (values ,(if (minusp y)
-			`(- (ash (- x) ,shift))
-			`(ash x ,shift))
-		   (logand x ,mask))))))
-
-;;; And the same for rem.
-;;;
-(deftransform rem ((x y) (integer integer))
-  "convert remainder mod 2^k to LOGAND"
-  (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))
-    (let ((mask (1- y-abs)))
-      `(if (minusp x)
-	   (- (logand (- x) ,mask))
-	   (logand x ,mask)))))
-
-
-;;;; Arithmetic and logical identity operation elimination:
-;;;
-;;; Flush calls to random arith functions that convert to the identity
-;;; function or a constant.
-
-
-(dolist (stuff '((ash 0 x)
-		 (logand -1 x)
-		 (logand 0 0)
-		 (logior 0 x)
-		 (logior -1 -1)
-		 (logxor -1 (lognot x))
-		 (logxor 0 x)))
-  (destructuring-bind (name identity result) stuff
-    (deftransform name ((x y) `(* (constant-argument (member ,identity))) '*
-			:eval-name t)
-      "fold identity operations"
-      result)))
-
-
-;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
-;;; (* 0 -4.0) is -0.0.
-;;;
-(deftransform - ((x y) ((constant-argument (member 0)) rational))
-  "convert (- 0 x) to negate"
-  '(%negate y))
-;;;
-(deftransform * ((x y) (rational (constant-argument (member 0))))
-  "convert (* x 0) to 0."
-  0)
-
-
-;;; NOT-MORE-CONTAGIOUS  --  Interface
-;;;
-;;;    Return T if in an arithmetic op including continuations X and Y, the
-;;; result type is not affected by the type of X.  That is, Y is at least as
-;;; contagious as X.
-;;;
-(defun not-more-contagious (x y)
-  (declare (type continuation x y))
-  (let ((x (continuation-type x))
-	(y (continuation-type y)))
-    (values (type= (numeric-contagion x y)
-		   (numeric-contagion y y)))))
-
-
-;;; Fold (OP x 0).
-;;;
-;;;    If y is not constant, not zerop, or is contagious, then give up.
-;;;
-(dolist (stuff '((+ x)
-		 (- x)
-		 (expt 1)))
-  (destructuring-bind (name result) stuff
-    (deftransform name ((x y) '(t (constant-argument t)) '* :eval-name t)
-      "fold zero arg"
-      (let ((val (continuation-value y)))
-	(unless (and (zerop val)
-		     (not (and (floatp val) (minusp (float-sign val))))
-		     (not-more-contagious y x))
-	  (give-up)))
-      result)))
-
-;;; Fold (OP x +/-1)
-;;;
-(dolist (stuff '((* x (%negate x))
-		 (/ x (%negate x))
-		 (expt x (/ 1 x))))
-  (destructuring-bind (name result minus-result) stuff
-    (deftransform name ((x y) '(t (constant-argument real)) '* :eval-name t)
-      "fold identity operations"
-      (let ((val (continuation-value y)))
-	(unless (and (= (abs val) 1)
-		     (not-more-contagious y x))
-	  (give-up))
-	(if (minusp val) minus-result result)))))
-
-
-;;;; Character operations:
-
-(deftransform char-equal ((a b) (base-char base-char))
-  "open code"
-  '(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) (base-char))
-  "open code"
-  '(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) (base-char))
-  "open code"
-  '(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, and the value of the leaf cannot change.
-;;;
-(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))
-	 (constant-reference-p x-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)
-	((not (types-intersect (continuation-type x) (continuation-type y)))
-	 'nil)
-	(t
-	 (give-up))))
-
-(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 either arg is definitely not a number, then we can compare with EQ.
-;;; -- Otherwise, we try to put the arg we know more about second.  If X is
-;;;    constant then we put it second.  If X is a subtype of Y, we put it
-;;;    second.  These rules make it easier for the back end to match these
-;;;    interesting cases.
-;;; -- If Y is a fixnum, then we quietly pass because the back end can handle
-;;;    that case, otherwise give an efficency note.
-;;;
-(deftransform eql ((x y))
-  "convert to simpler equality predicate"
-  (let ((x-type (continuation-type x))
-	(y-type (continuation-type y))
-	(char-type (specifier-type 'character))
-	(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))
-	  ((or (not (types-intersect x-type number-type))
-	       (not (types-intersect y-type number-type)))
-	   '(eq x y))
-	  ((and (not (constant-continuation-p y))
-		(or (constant-continuation-p x)
-		    (and (csubtypep x-type y-type)
-			 (not (csubtypep y-type x-type)))))
-	   '(eql y x))
-	  (t
-	   (give-up)))))
-
-
-;;; = IR1 Transform  --  Internal
-;;;
-;;;    Convert to EQL if both args are the "same" numeric type.  This allows
-;;; all of EQL's type-specific expertise to come into play.  "Same" means
-;;; either both rational or both floats of the same format.  Complexp must also
-;;; be specified and identical.
-;;; 
-(deftransform = ((x y))
-  "open code"
-  (let ((x-type (continuation-type x))
-	(y-type (continuation-type y)))
-    (if (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)))))
-	'(eql x y)
-	(give-up "Operands might not be the same type."))))
-
-
-;;; 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
-;;; X's high bound is < Y's low, then X < Y.  Similarly, if X's low is >= to
-;;; Y's high, the X >= Y (so return NIL).  If not, at least make sure any
-;;; constant arg is second.
-;;;
-(defun ir1-transform-< (x y first second inverse)
-  (if (same-leaf-ref-p x y)
-      'nil
-      (let* ((x-type (numeric-type-or-lose x))
-	     (x-lo (numeric-type-low x-type))
-	     (x-hi (numeric-type-high x-type))
-	     (y-type (numeric-type-or-lose y))
-	     (y-lo (numeric-type-low y-type))
-	     (y-hi (numeric-type-high y-type)))
-	(cond ((and x-hi y-lo (< x-hi y-lo))
-	       't)
-	      ((and y-hi x-lo (>= x-lo y-hi))
-	       'nil)
-	      ((and (constant-continuation-p first)
-		    (not (constant-continuation-p second)))
-	       `(,inverse y x))
-	      (t
-	       (give-up))))))
-	      
-
-(deftransform < ((x y) (integer integer))
-  (ir1-transform-< x y x y '>))
-
-(deftransform > ((x y) (integer integer))
-  (ir1-transform-< y x x y '<))
-
-
-;;;; 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. 
-;;;
-(defun source-transform-transitive (fun args identity &optional leaf-fun)
-  (declare (symbol fun leaf-fun) (list args))
-  (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)
-  (if (evenp (length args))
-      `(lognot (logxor ,@args))
-      `(logxor ,@args)))
-
-;;; Note: we can't use source-transform-transitive for GCD and LCM because when
-;;; they are given one argument, they return it's absolute value.
-
-(def-source-transform gcd (&rest args)
-  (case (length args)
-    (0 0)
-    (1 `(abs (the integer ,(first args))))
-    (2 (values nil t))
-    (t (associate-arguments 'gcd (first args) (rest args)))))
-
-(def-source-transform lcm (&rest args)
-  (case (length args)
-    (0 1)
-    (1 `(abs (the integer ,(first args))))
-    (2 (values nil t))
-    (t (associate-arguments 'lcm (first args) (rest args)))))
-
-
-;;; Source-Transform-Intransitive  --  Internal
-;;;
-;;;    Do source transformations for intransitive n-arg functions such as /.
-;;; With one arg, we form the inverse.  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 inverse)
-  (case (length args)
-    ((0 2) (values nil t))
-    (1 `(,@inverse ,(first args)))
-    (t
-     (associate-arguments function (first args) (rest args)))))
-
-(def-source-transform - (&rest args)
-  (source-transform-intransitive '- args '(%negate)))
-(def-source-transform / (&rest args)
-  (source-transform-intransitive '/ args '(/ 1)))
-
-
-;;;; 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))
-  "convert to output primitives"
-  (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))
-	    (when args
-	      (compiler-warning "~R extra format argument~:P.  Ignoring..."
-				(length args))
-	      (forms `(progn ,@args)))
-
-	    (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"
-			     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.
-	  (flet ((next-arg ()
-		   (unless args
-		     (abort-transform "Missing FORMAT argument."))
-		   (pop args)))
-	    (forms
-	     (case (schar control (1+ command-index))
-	       ((#\b #\B) `(let ((*print-base* 2))
-			     (princ ,(next-arg) ,@stream-form)))
-	       ((#\o #\O) `(let ((*print-base* 8))
-			     (princ ,(next-arg) ,@stream-form)))
-	       ((#\d #\D) `(let ((*print-base* 10))
-			     (princ ,(next-arg) ,@stream-form)))
-	       ((#\x #\X) `(let ((*print-base* 16))
-			     (princ ,(next-arg) ,@stream-form)))
-	       ((#\a #\A) `(princ ,(next-arg) ,@stream-form))
-	       ((#\s #\S) `(prin1 ,(next-arg) ,@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 fb9bc00d2c2fbf5b09c61b08d4a07ec3b0358ca3..0000000000000000000000000000000000000000
--- a/compiler/sset.lisp
+++ /dev/null
@@ -1,300 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sset.lisp,v 1.4 1991/02/20 14:59:48 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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 index 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))
-			  (setq num3 (sset-element-number (car el3)))
-			  (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 b3a0b52d32ae97d740b7402d6d6244e4fef3e827..0000000000000000000000000000000000000000
--- a/compiler/stack.lisp
+++ /dev/null
@@ -1,259 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/stack.lisp,v 1.5 1991/05/08 01:15:34 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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 don't have all the continuations that we have on our Start-Stack on
-;;; their End-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.
-;;;
-;;;    We can use the tailp test, since the only time we want to bottom out
-;;; with a non-empty stack is when we intersect with another path from the same
-;;; top-level call to this function that has more values receivers on that
-;;; path.  When we bottom out in this way, we are counting on
-;;; DISCARD-UNUSED-VALUES doing its thing.
-;;;
-;;;    When we do recurse, we check that predecessor's END-STACK is a
-;;; subsequence of our START-STACK.  There may be extra stuff on the top
-;;; of our stack because the last path to the predecessor may have discarded
-;;; some values that we use.  There may be extra stuff on the bottom of our
-;;; stack because this walk may be from a values receiver whose lifetime
-;;; encloses that of the previous walk.
-;;;
-;;;    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 (block-environment block))
-			    :key #'nlx-info-target))
-	      (let ((pred-stack (ir2-block-end-stack (block-info pred))))
-		(unless (tailp new-stack pred-stack)
-		  (assert (search 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.
-;;;
-;;;    If we see a pushed continuation that is the CONT of a tail call, then we
-;;; ignore it, since the tail call didn't actually push anything.  The tail
-;;; call must always the last in the block. 
-;;;
-(defun annotate-dead-values (block)
-  (declare (type cblock block))
-  (let* ((2block (block-info block))
-	 (stack (ir2-block-end-stack 2block))
-	 (last (block-last block))
-	 (tailp-cont (if (node-tail-p last) (node-cont last))))
-    (do ((pushes (ir2-block-pushed 2block) (rest pushes))
-	 (popping nil))
-	((null pushes))
-      (let ((push (first pushes)))
-	(cond ((member push stack)
-	       (assert (not popping)))
-	      ((eq push tailp-cont)
-	       (assert (null (rest pushes))))
-	      (t
-	       (push push (ir2-block-end-stack 2block))
-	       (setq popping t))))))
-  
-  (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 (tailp block2-stack block1-stack))
-
-    (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:
-
-
-;;; FIND-VALUES-GENERATORS  --  Internal
-;;;
-;;;    Return a list of all the blocks containing genuine uses of one of the
-;;; Receivers.  Exits are excluded, since they don't drop through to the
-;;; receiver.
-;;;
-(defun find-values-generators (receivers)
-  (declare (list receivers))
-  (collect ((res nil adjoin))
-    (dolist (rec receivers)
-      (dolist (pop (ir2-block-popped (block-info rec)))
-	(do-uses (use pop)
-	  (unless (exit-p use)
-	    (res (node-block use))))))
-    (res)))
-
-
-;;; 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.
-;;;
-;;;    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 (find-values-generators receivers)))
-
-    (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-start succ)
-		     (not (eq (car (ir2-block-start-stack (block-info succ)))
-			      top)))
-	    (discard-unused-values block succ))))))
-  
-  (undefined-value))
diff --git a/compiler/statcount.lisp b/compiler/statcount.lisp
deleted file mode 100644
index 0fa9f3597b0a8581d5af99641332bab0a0d81dab..0000000000000000000000000000000000000000
--- a/compiler/statcount.lisp
+++ /dev/null
@@ -1,166 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/statcount.lisp,v 1.5 1992/08/04 08:22:44 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/statcount.lisp,v 1.5 1992/08/04 08:22:44 wlott Exp $
-;;;
-;;; Functions and utilities for collecting statistics on static vop usages.
-;;;
-;;; Written by William Lott
-;;;
-(in-package "C")
-
-(export '(*count-vop-usages*))
-
-
-
-;;;; Vop counting utilities
-
-;;; T if we should count the number of times we use each vop and the number
-;;; of instructions that come from each.
-;;; 
-(defvar *count-vop-usages* nil)
-
-;;; Hash table containing all the current counts.  The key is the name of the
-;;; vop, and the value is a 3 element simple-vector.  The elements are:
-;;;   0 - the name of the vop.
-;;;   1 - the number of times this vop was emitted.
-;;;   2 - the number of normal instructions emitted due to this vop.
-;;;   3 - the number of elsewhere instructions emitted due to this vop.
-;;; 
-(defvar *vop-counts* (make-hash-table :test #'eq))
-
-;;; COUNT-VOPS  --  internal interface.
-;;;
-;;; COUNT-VOPS is called by COMPILE-COMPONENT to count the vop usages in
-;;; component.
-;;; 
-(defun count-vops (component)
-  (declare (ignore component))
-  (error "Vop counting not implemented for the new assembler.")
-  #+nil
-  (flet ((vop-entry (vop)
-	   (let* ((name (vop-info-name (vop-info vop)))
-		  (entry (gethash name *vop-counts*)))
-	     (the (simple-vector 4)
-		  (or entry
-		      (let ((new (make-array 4 :initial-element 0)))
-			(setf (svref new 0) name)
-			(setf (gethash name *vop-counts*) new)
-			new))))))
-    (do-ir2-blocks (block component)
-      (do ((vop (ir2-block-start-vop block) (vop-next vop)))
-	  ((null vop))
-	(incf (svref (vop-entry vop) 1))))
-    (assem:count-instructions
-     #'(lambda (vop count elsewherep)
-	 (incf (svref (vop-entry vop)
-		      (if elsewherep 3 2))
-	       count))
-     *code-segment*
-     *elsewhere*
-     :size))
-  (undefined-value))
-
-
-;;;; Stuff for using the statistics.
-
-;;; Clear-Vop-Counts -- interface
-;;; 
-(defun clear-vop-counts ()
-  (clrhash *vop-counts*)
-  nil)
-
-;;; Report-Vop-Counts -- interface
-;;;
-(defun report-vop-counts (&key (cut-off 15) (sort-by :size))
-  (declare (type (or null unsigned-byte) cut-off)
-	   (type (member :size :count :name) sort-by))
-  (let ((results nil)
-	(total-count 0)
-	(total-size 0)
-	(w/o-elsewhere-size 0))
-    (maphash #'(lambda (key value)
-		 (declare (ignore key))
-		 (push value results)
-		 (incf total-count (svref value 1))
-		 (incf total-size (+ (svref value 2) (svref value 3)))
-		 (incf w/o-elsewhere-size (svref value 2)))
-	     *vop-counts*)
-    (format t "~18<Vop ~> ~17:@<Count~> ~17:@<Bytes~> ~
-              ~17:@<W/o elsewhere~> Ave Sz~%")
-    (let ((total-count (coerce total-count 'double-float))
-	  (total-size (coerce total-size 'double-float))
-	  (w/o-elsewhere-size (coerce w/o-elsewhere-size 'double-float)))
-      (dolist (info (sort results
-			  (ecase sort-by
-			    (:name #'(lambda (name-1 name-2)
-				       (string< (symbol-name name-1)
-						(symbol-name name-2))))
-			    ((:count :size) #'>))
-			  :key (ecase sort-by
-				 (:name #'(lambda (x) (svref x 0)))
-				 (:count #'(lambda (x) (svref x 1)))
-				 (:size #'(lambda (x)
-					    (+ (svref x 2)
-					       (svref x 3)))))))
-	(when cut-off
-	  (if (zerop cut-off)
-	      (return)
-	      (decf cut-off)))
-	(let* ((name (symbol-name (svref info 0)))
-	       (name-len (length name))
-	       (count (svref info 1))
-	       (count-len (truncate (truncate (rational (log count 10))) 3/4))
-	       (w/o-elsewhere (svref info 2))
-	       (size (+ w/o-elsewhere (svref info 3))))
-	  (if (> (+ name-len count-len) 24)
-	      (format t "~A:~%~18T~9:D" name count)
-	      (format t "~VT~A:~VT~:D"
-		      (max (- 18 name-len) 0)
-		      name
-		      (- 26 count-len)
-		      count))
-	  (format t " (~4,1,2F%) ~9:D (~4,1,2F%) ~9:D (~4,1,2F%) ~3D ~3D~%"
-		  (/ (coerce count 'double-float) total-count)
-		  size
-		  (/ (coerce size 'double-float) total-size)
-		  w/o-elsewhere
-		  (/ (coerce w/o-elsewhere 'double-float) w/o-elsewhere-size)
-		  (round size count)
-		  (round w/o-elsewhere count))))))
-  (values))
-
-(defun save-vop-counts (filename)
-  (with-open-file (stream filename :direction :output :if-exists :supersede)
-    (maphash #'(lambda (key value)
-		 (declare (ignore key))
-		 (prin1 value stream)
-		 (terpri stream))
-	     *vop-counts*)))
-
-(defun augment-vop-counts (filename)
-  (with-open-file (stream filename)
-    (loop
-      (let ((stuff (read stream nil :eof)))
-	(when (eq stuff :eof)
-	  (return))
-	(multiple-value-bind
-	    (entry found)
-	    (gethash (svref stuff 0) *vop-counts*)
-	  (cond (found
-		 (incf (svref entry 1) (svref stuff 1))
-		 (incf (svref entry 2) (svref stuff 3))
-		 (incf (svref entry 3) (svref stuff 2)))
-		(t
-		 (setf (gethash (svref stuff 0) *vop-counts*) stuff))))))))
-
diff --git a/compiler/tn.lisp b/compiler/tn.lisp
deleted file mode 100644
index cc5718c20095f437d401c0c38ce9654d74752ae6..0000000000000000000000000000000000000000
--- a/compiler/tn.lisp
+++ /dev/null
@@ -1,572 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/tn.lisp,v 1.16 1992/06/27 21:51:42 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains utilities used for creating and manipulating TNs, and
-;;; some other more assorted IR2 utilities.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(export '(make-normal-tn make-representation-tn make-wired-tn
-	  make-restricted-tn environment-live-tn
-	  environment-debug-live-tn component-live-tn specify-save-tn
-	  make-constant-tn make-alias-tn make-load-time-constant-tn
-	  make-n-tns location= tn-value force-tn-to-stack))
-
-;;; 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.  We mark non-deleted alias TNs so that aliased TNs
-;;; aren't considered to be unreferenced.
-;;;
-(defun delete-unreferenced-tns (component)
-  (let* ((2comp (component-info component))
-	 (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp))
-			      :element-type 'bit :initial-element 0)))
-    (labels ((delete-some (getter setter)
-	       (let ((prev nil))
-		 (do ((tn (funcall getter 2comp) (tn-next tn)))
-		     ((null tn))
-		   (cond
-		    ((or (used-p tn)
-			 (and (eq (tn-kind tn) :specified-save)
-			      (used-p (tn-save-tn tn))))
-		     (setq prev tn))
-		    (t
-		     (delete-1 tn prev setter))))))
-	     (used-p (tn)
-	       (or (tn-reads tn) (tn-writes tn)
-		   (member (tn-kind tn) '(:component :environment))
-		   (not (zerop (sbit aliases (tn-number tn))))))
-	     (delete-1 (tn prev setter)
-	       (if prev
-		   (setf (tn-next prev) (tn-next tn))
-		   (funcall setter (tn-next tn) 2comp))
-	       (setf (tn-offset tn) nil)
-	       (case (tn-kind tn)
-		 (:environment
-		  (clear-live tn #'ir2-environment-live-tns
-			      #'(setf ir2-environment-live-tns)))
-		 (:debug-environment
-		  (clear-live tn #'ir2-environment-debug-live-tns
-			      #'(setf ir2-environment-debug-live-tns)))))
-	     (clear-live (tn getter setter)
-	       (let ((env (environment-info (tn-environment tn))))
-		 (funcall setter (delete tn (funcall getter env)) env))))
-      (declare (inline used-p delete-some delete-1 clear-live))
-      (delete-some #'ir2-component-alias-tns
-		   #'(setf ir2-component-alias-tns))
-      (do ((tn (ir2-component-alias-tns 2comp) (tn-next tn)))
-	  ((null tn))
-	(setf (sbit aliases (tn-number (tn-save-tn tn))) 1))
-      (delete-some #'ir2-component-normal-tns
-		   #'(setf ir2-component-normal-tns))
-      (delete-some #'ir2-component-restricted-tns
-		   #'(setf ir2-component-restricted-tns))
-      (delete-some #'ir2-component-wired-tns
-		   #'(setf ir2-component-wired-tns))))
-  (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)))
-    (push-in tn-next res (ir2-component-normal-tns component))
-    res))
-
-
-;;; MAKE-REPRESENTATION-TN  --  Interface
-;;;
-;;;    Create a normal packed TN with representation indicated by SCN.
-;;;
-(defun make-representation-tn (ptype scn)
-  (declare (type primitive-type ptype) (type sc-number scn))
-  (let* ((component (component-info *compile-component*))
-	 (res (make-tn (incf (ir2-component-global-tn-counter component))
-		       :normal ptype
-		       (svref (backend-sc-numbers *backend*) scn))))
-    (push-in tn-next res (ir2-component-normal-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.  Ptype is the TN's primitive-type, which may be NIL in VOP
-;;; temporaries.
-;;;
-(defun make-wired-tn (ptype scn offset)
-  (declare (type (or primitive-type null) ptype)
-	   (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 ptype
-		       (svref (backend-sc-numbers *backend*) scn))))
-    (setf (tn-offset res) offset)
-    (push-in tn-next res (ir2-component-wired-tns component))
-    res))
-
-
-;;; Make-Restricted-TN  --  Interface
-;;;
-;;;    Create a packed TN restricted to the SC with number SCN.  Ptype is as
-;;; for MAKE-WIRED-TN.
-;;;
-(defun make-restricted-tn (ptype scn)
-  (declare (type (or primitive-type null) ptype) (type sc-number scn))
-  (let* ((component (component-info *compile-component*))
-	 (res (make-tn (incf (ir2-component-global-tn-counter component))
-		       :normal ptype
-		       (svref (backend-sc-numbers *backend*) scn))))
-    (push-in tn-next res (ir2-component-restricted-tns component))
-    res))
-
-
-;;; ENVIRONMENT-LIVE-TN, ENVIRONMENT-DEBUG-LIVE-TN  --  Interface
-;;;
-;;;    Make TN be live throughout environment.  Return TN.  In the DEBUG case,
-;;; the TN is treated normally in blocks in the environment which reference the
-;;; TN, allowing targeting to/from the TN.  This results in move efficient
-;;; code, but may result in the TN sometimes not being live when you want it.
-;;;
-(defun environment-live-tn (tn env)
-  (declare (type tn tn) (type environment env))
-  (assert (eq (tn-kind tn) :normal))
-  (setf (tn-kind tn) :environment)
-  (setf (tn-environment tn) env)
-  (push tn (ir2-environment-live-tns (environment-info env)))
-  tn)
-;;;
-(defun environment-debug-live-tn (tn env)
-  (declare (type tn tn) (type environment env))
-  (assert (eq (tn-kind tn) :normal))
-  (setf (tn-kind tn) :debug-environment)
-  (setf (tn-environment tn) env)
-  (push tn (ir2-environment-debug-live-tns (environment-info env)))
-  tn)
-
-
-;;; Component-Live-TN  --  Interface
-;;;
-;;;    Make TN be live throughout the current component.  Return TN.
-;;;
-(defun component-live-tn (tn)
-  (declare (type tn tn))
-  (assert (eq (tn-kind tn) :normal))
-  (setf (tn-kind tn) :component)
-  (push tn (ir2-component-component-tns (component-info *compile-component*)))
-  tn)
-
-
-;;; SPECIFY-SAVE-TN  --  Interface
-;;;
-;;;    Specify that Save be used as the save location for TN.  TN is returned. 
-;;;
-(defun specify-save-tn (tn save)
-  (declare (type tn tn save))
-  (assert (eq (tn-kind save) :normal))
-  (assert (and (not (tn-save-tn tn)) (not (tn-save-tn save))))
-  (setf (tn-kind save) :specified-save)
-  (setf (tn-save-tn tn) save)
-  (setf (tn-save-tn save) tn)
-  (push save
-	(ir2-component-specified-save-tns
-	 (component-info *compile-component*)))
-  tn)
-
-
-;;; 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 (backend-sc-numbers *backend*)
-		    (or immed (sc-number-or-lose 'constant *backend*))))
-	 (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-VALUE-TN  --  interface.
-;;;
-(defun make-load-time-value-tn (handle type)
-  (let* ((component (component-info *compile-component*))
-	 (sc (svref (backend-sc-numbers *backend*)
-		    (sc-number-or-lose 'constant *backend*)))
-	 (res (make-tn 0 :constant (primitive-type type) sc))
-	 (constants (ir2-component-constants component)))
-    (setf (tn-offset res) (fill-pointer constants))
-    (vector-push-extend (cons :load-time-value handle) constants)
-    (push-in tn-next res (ir2-component-constant-tns component))
-    res))
-
-;;; MAKE-ALIAS-TN  --  Interface
-;;;
-;;;    Make a TN that aliases TN for use in local call argument passing.
-;;;
-(defun make-alias-tn (tn)
-  (declare (type tn tn))
-  (let* ((component (component-info *compile-component*))
-	 (res (make-tn (incf (ir2-component-global-tn-counter component))
-		       :alias (tn-primitive-type tn) nil)))
-    (setf (tn-save-tn res) tn)
-    (push-in tn-next res
-	     (ir2-component-alias-tns component))
-    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 (backend-any-primitive-type *backend*)
-		       (svref (backend-sc-numbers *backend*)
-			      (sc-number-or-lose 'constant *backend*))))
-	 (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)
-	  (return))))
-
-    (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.
-;;;
-(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:
-
-
-;;; Emit-Move-Template  --  Internal
-;;;
-;;;    Emit a move-like template determined at run-time, with X as the argument
-;;; and Y as the result.  Useful for move, coerce and type-check templates.  If
-;;; supplied, then insert before VOP, otherwise insert at then end of the
-;;; block.  Returns the last VOP inserted.
-;;;
-(defun emit-move-template (node block template x y &optional before)
-  (declare (type node node) (type ir2-block block)
-	   (type template template) (type tn x y))
-  (let ((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)
-      last)))
-
-
-;;; EMIT-LOAD-TEMPLATE  --  Internal
-;;;
-;;;    Like EMIT-MOVE-TEMPLATE, except that we pass in Info args too.
-;;;
-(defun emit-load-template (node block template x y info &optional before)
-  (declare (type node node) (type ir2-block block)
-	   (type template template) (type tn x y))
-  (let ((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 info)
-      (insert-vop-sequence first last block before)
-      last)))
-
-
-;;; EMIT-MOVE-ARG-TEMPLATE  --  Internal
-;;;
-;;;    Like EMIT-MOVE-TEMPLATE, except that the VOP takes two args.
-;;;
-(defun emit-move-arg-template (node block template x f y &optional before)
-  (declare (type node node) (type ir2-block block)
-	   (type template template) (type tn x f y))
-  (let ((x-ref (reference-tn x nil))
-	(f-ref (reference-tn f nil))
-	(y-ref (reference-tn y t)))
-    (setf (tn-ref-across x-ref) f-ref)
-    (multiple-value-bind
-	(first last)
-	(funcall (template-emit-function template) node block template x-ref
-		 y-ref)
-      (insert-vop-sequence first last block before)
-      last)))
-
-
-;;; EMIT-CONTEXT-TEMPLATE  --  Internal
-;;;
-;;;    Like EMIT-MOVE-TEMPLATE, except that the VOP takes no args.
-;;;
-(defun emit-context-template (node block template y &optional before)
-  (declare (type node node) (type ir2-block block)
-	   (type template template) (type tn y))
-  (let ((y-ref (reference-tn y t)))
-    (multiple-value-bind
-	(first last)
-	(funcall (template-emit-function template) node block template nil
-		 y-ref)
-      (insert-vop-sequence first last block before)
-      last)))
-
-
-;;; 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))))
-
-
-;;; 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))
-
-
-;;; DELETE-VOP  --  Interface
-;;;
-;;;    Delete all of the TN-Refs associated with VOP and remove VOP from the
-;;; IR2.
-;;;
-(defun delete-vop (vop)
-  (declare (type vop vop))
-  (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
-      ((null ref))
-    (delete-tn-ref ref))
-
-  (let ((prev (vop-prev vop))
-	(next (vop-next vop))
-	(block (vop-block vop)))
-    (if prev
-	(setf (vop-next prev) next)
-	(setf (ir2-block-start-vop block) next))
-    (if next
-	(setf (vop-prev next) prev)
-	(setf (ir2-block-last-vop block) prev)))
-
-  (undefined-value))
-
-
-;;; 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)))
-  (constant-value (tn-leaf tn)))
-
-
-;;; Force-TN-To-Stack  --  Interface
-;;;
-;;;    Force TN to be allocated in a SC that doesn't need to be saved: an
-;;; unbounded non-save-p SC.  We don't actually make it a real "restricted" TN,
-;;; but since we change the SC to an unbounded one, we should always succeed in
-;;; packing it in that SC.
-;;;
-(defun force-tn-to-stack (tn)
-  (declare (type tn tn))
-  (let ((sc (tn-sc tn)))
-    (unless (and (not (sc-save-p sc))
-		 (eq (sb-kind (sc-sb sc)) :unbounded))
-      (dolist (alt (sc-alternate-scs sc)
-		   (error "SC ~S has no :unbounded :save-p NIL alternate SC."
-			  (sc-name sc)))
-	(when (and (not (sc-save-p alt))
-		   (eq (sb-kind (sc-sb alt)) :unbounded))
-	  (setf (tn-sc tn) alt)
-	  (return)))))
-  (undefined-value))
-
diff --git a/compiler/vmdef.lisp b/compiler/vmdef.lisp
deleted file mode 100644
index 700049403e81957cb70ef20d89fb72d195bfcb8d..0000000000000000000000000000000000000000
--- a/compiler/vmdef.lisp
+++ /dev/null
@@ -1,281 +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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/vmdef.lisp,v 1.46 1992/08/25 17:44:03 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    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)
-
-(export '(template-or-lose sc-or-lose sb-or-lose sc-number-or-lose
-	  primitive-type-or-lose note-this-location note-next-instruction))
-
-;;; Template-Or-Lose  --  Internal
-;;;
-;;;    Return the template having the specified name, or die trying.
-;;;
-(defun template-or-lose (x &optional (backend *target-backend*))
-  (the template
-       (or (gethash x (backend-template-names backend))
-	   (error "~S is not a defined template." x))))
-
-
-;;; 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.
-;;;
-(defun sc-or-lose (x &optional (backend *target-backend*))
-  (the sc
-       (or (gethash x (backend-sc-names backend))
-	   (error "~S is not a defined storage class." x))))
-;;;
-(defun sb-or-lose (x &optional (backend *target-backend*))
-  (the sb
-       (or (gethash x (backend-sb-names backend))
-	   (error "~S is not a defined storage base." x))))
-;;;
-(defun sc-number-or-lose (x &optional (backend *target-backend*))
-  (the sc-number (sc-number (sc-or-lose x backend))))
-
-
-
-;;;; Side-Effect Classes
-
-(def-boolean-attribute vop
-  any)
-
-
-
-;;;; Move/coerce definition:
-
-;;; COMPUTE-MOVE-COSTS  --  Internal
-;;;
-;;; Compute at compiler load time the costs for moving between all SCs that
-;;; can be loaded from FROM-SC and to TO-SC given a base move cost Cost.
-;;;
-(defun compute-move-costs (from-sc to-sc cost)
-  (declare (type sc from-sc to-sc) (type index cost))
-  (let ((to-scn (sc-number to-sc))
-	(from-costs (sc-load-costs from-sc)))
-    (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
-      (let ((vec (sc-move-costs dest-sc))
-	    (dest-costs (sc-load-costs dest-sc)))
-	(setf (svref vec (sc-number from-sc)) cost)
-	(dolist (sc (append (sc-alternate-scs from-sc)
-			    (sc-constant-scs from-sc)))
-	  (let* ((scn (sc-number sc))
-		 (total (+ (svref from-costs scn)
-			   (svref dest-costs to-scn)
-			   cost))
-		 (old (svref vec scn)))
-	    (unless (and old (< old total))
-	      (setf (svref vec scn) total))))))))
-
-
-;;;; Primitive type definition:
-
-;;; PRIMITIVE-TYPE-OR-LOSE  --  Interface
-;;;
-;;;    Return the primitive type corresponding to the specified name, or die
-;;; trying.
-;;;
-(defun primitive-type-or-lose (name &optional (backend *target-backend*))
-  (the primitive-type
-       (or (gethash name (backend-primitive-type-names backend))
-	   (error "~S is not a defined primitive type." name))))
-
-
-;;; SC-ALLOWED-BY-PRIMITIVE-TYPE  --  Interface
-;;;
-;;;    Return true if SC is either one of Ptype's SC's, or one of those SC's
-;;; alternate or constant SCs.
-;;;
-(defun sc-allowed-by-primitive-type (sc ptype)
-  (declare (type sc sc) (type primitive-type ptype))
-  (let ((scn (sc-number sc)))
-    (dolist (allowed (primitive-type-scs ptype) nil)
-      (when (eql allowed scn)
-	(return t))
-      (let ((allowed-sc (svref (backend-sc-numbers *backend*) allowed)))
-	(when (or (member sc (sc-alternate-scs allowed-sc))
-		  (member sc (sc-constant-scs allowed-sc)))
-	  (return t))))))
-
-
-;;;; Emit function generation:
-
-(defconstant max-vop-tn-refs 256)
-
-(defvar *vop-tn-refs* (make-array max-vop-tn-refs :initial-element nil))
-(defvar *using-vop-tn-refs* nil)
-
-(defun flush-vop-tn-refs ()
-  (unless *using-vop-tn-refs*
-    (fill *vop-tn-refs* nil)))
-
-(pushnew 'flush-vop-tn-refs *before-gc-hooks*)
-
-(defconstant sc-bits (integer-length (1- sc-number-limit)))
-
-(defun emit-generic-vop (node block template args results &optional info)
-  (%emit-generic-vop node block template args results info))
-
-(defun %emit-generic-vop (node block template args results info)
-  (let* ((vop (make-vop block node template args results))
-	 (num-args (vop-info-num-args template))
-	 (last-arg (1- num-args))
-	 (num-results (vop-info-num-results template))
-	 (num-operands (+ num-args num-results))
-	 (last-result (1- num-operands))
-	 (ref-ordering (vop-info-ref-ordering template)))
-    (declare (type vop vop)
-	     (type (integer 0 #.max-vop-tn-refs)
-		   num-args num-results num-operands)
-	     (type (integer -1 #.(1- max-vop-tn-refs)) last-arg last-result)
-	     (type (simple-array (mod #.max-vop-tn-refs) (*)) ref-ordering))
-    (setf (vop-codegen-info vop) info)
-    (let ((refs *vop-tn-refs*)
-	  (*using-vop-tn-refs* t))
-      (declare (type (simple-vector #.max-vop-tn-refs) refs))
-      (do ((index 0 (1+ index))
-	   (ref args (and ref (tn-ref-across ref))))
-	  ((= index num-args))
-	(setf (svref refs index) ref))
-      (do ((index num-args (1+ index))
-	   (ref results (and ref (tn-ref-across ref))))
-	  ((= index num-operands))
-	(setf (svref refs index) ref))
-      (let ((temps (vop-info-temps template)))
-	(when temps
-	  (let ((index num-operands)
-		(prev nil))
-	    (dotimes (i (length temps))
-	      (let* ((temp (aref temps i))
-		     (tn (if (logbitp 0 temp)
-			     (make-wired-tn nil
-					    (ldb (byte sc-bits 1) temp)
-					    (ash temp (- (1+ sc-bits))))
-			     (make-restricted-tn nil (ash temp -1))))
-		     (write-ref (reference-tn tn t)))
-		(setf (aref refs index) (reference-tn tn nil))
-		(setf (aref refs (1+ index)) write-ref)
-		(if prev
-		    (setf (tn-ref-across prev) write-ref)
-		    (setf (vop-temps vop) write-ref))
-		(setf prev write-ref)
-		(incf index 2))))))
-      (let ((prev nil))
-	(flet ((add-ref (ref)
-		 (setf (tn-ref-vop ref) vop)
-		 (setf (tn-ref-next-ref ref) prev)
-		 (setf prev ref)))
-	  (declare (inline add-ref))
-	  (dotimes (i (length ref-ordering))
-	    (let* ((index (aref ref-ordering i))
-		   (ref (aref refs index)))
-	      (if (or (= index last-arg) (= index last-result))
-		  (do ((ref ref (tn-ref-across ref)))
-		      ((null ref))
-		    (add-ref ref))
-		  (add-ref ref)))))
-	(setf (vop-refs vop) prev))
-      (let ((targets (vop-info-targets template)))
-	(when targets
-	  (dotimes (i (length targets))
-	    (let ((target (aref targets i)))
-	      (target-if-desirable (aref refs (ldb (byte 8 8) target))
-				   (aref refs (ldb (byte 8 0) target))))))))
-    (values vop vop)))
-
-
-;;;; Function translation stuff:
-
-;;; Adjoin-Template  --  Internal
-;;;
-;;;    Add Template into List, removing any old template with the same name.
-;;; We also maintain the increasing cost ordering.
-;;;
-(defun adjoin-template (template list)
-  (declare (type template template) (list list))
-  (sort (cons template
-	      (remove (template-name template) list
-		      :key #'template-name))
-	#'<=
-	:key #'template-cost))
-
-
-
-;;; 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
-			(ecase (first x)
-			  (:or `(or ,@(mapcar #'(lambda (type)
-						  (type-specifier
-						   (primitive-type-type
-						    type)))
-					      (rest x))))
-			  (:constant `(constant-argument ,(third 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))))))
-
-
-;;;; Random utilities.
-
-;;; NOTE-THIS-LOCATION  --  Interface
-;;;
-(defun note-this-location (vop kind)
-  "NOTE-THIS-LOCATION VOP Kind
-  Note 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."
-  (let ((lab (gen-label)))
-    (emit-label lab)
-    (note-debug-location vop lab kind)))
-
-;;; NOTE-NEXT-INSTRUCTION -- interface.
-;;; 
-(defun note-next-instruction (vop kind)
-  "NOTE-NEXT-INSTRUCTION VOP Kind
-   Similar to NOTE-THIS-LOCATION, except the use the location of the next
-   instruction for the code location, wherever the scheduler decided to put
-   it."
-  (let ((loc (note-debug-location vop nil kind)))
-    (new-assem:emit-postit #'(lambda (segment posn)
-			       (declare (ignore segment))
-			       (setf (location-info-label loc) posn))))
-  (undefined-value))
diff --git a/contrib/CATALOG.TXT b/contrib/CATALOG.TXT
deleted file mode 100644
index 99796fae142834636fd18b2701fdbca03039f6cb..0000000000000000000000000000000000000000
--- a/contrib/CATALOG.TXT
+++ /dev/null
@@ -1,291 +0,0 @@
-Package Name:
-   DEMOS
-
-Description:
-   Graphics demonstration programs for CMU Common Lisp using version 11 of the
-X Window System.
-
-Author:
-   CMU Common Lisp Group.
-
-Maintainer:
-   CMU Common Lisp Group.
-
-Address:
-   Carnegie-Mellon University
-   Computer Science Department
-   Pittsburgh, PA 15213
-
-Net Address:
-   slisp-group@b
-
-Copyright Status:
-   Public Domain.
-
-Files:
-   demos.lisp, demos.fasl, demos.catalog.
-
-How to Get:
-   The following unix command will copy the pertinent files into directory
-<spec>:
-   cp /afs/cs.cmu.edu/project/slisp/library/demos/* <spec>
-
-Portability:
-   Should run in any Common Lisp supporting CLX V11R3.
-
-Instructions:
-   The function DEMOS:DO-ALL-DEMOS will run through each of the demos once, and
-the function DEMOS:DEMO will present a menu of all the demos.
-
-
-Name:
-   Follow Mouse.
-
-Package Name:
-   HEMLOCK
-
-Description:
-   This Hemlock customization causes Hemlock's current window to be set to
-whatever Hemlock window the mouse enters, except the echo area.
-
-Author:
-   Todd Kaufmann, modified by Dave Touretzky.
-
-Maintainer:
-   Todd Kaufmann.
-
-Address:
-   Carnegie-Mellon University
-   Computer Science Department
-   Pittsburgh, PA 15213
-
-Net Address:
-   Todd.Kaufmann@CS.CMU.EDU
-
-Copyright Status:
-   Public Domain.
-
-Files:
-   follow-mouse.lisp, follow-mouse.fasl, follow-mouse.catalog.
-
-How to Get:
-   The following unix command will copy the pertinent files into directory
-<spec>:
-   cp /afs/cs.cmu.edu/project/slisp/library/follow-mouse/* <spec>
-
-Portability:
-   This should work in any Common Lisp supporting Hemlock and CLX V11R3.
-
-Instructions:
-   Load the fasl file into your editor Lisp.  A value of T for the hemlock
-variable "Follow Mouse To Read-Only Buffers", which is the default, means
-follow mouse is on.  Anything else means hemlock will behave normally.
-
-Bugs:
-   A few more PROMPT-FOR-... functions need to be modified.  They are mentioned
-in the source code.
-
-
-Package Name:
-   HIST
-
-Description:
-   Simple histogram facility using Format strings for output.
-
-Author:
-   Scott E. Fahlman
-
-Address:
-   Carnegie-Mellon University
-   Computer Science Department
-   Pittsburgh, PA 15213
-
-Net Address:
-   Scott.Fahlman@CS.CMU.EDU
-
-Copyright Status:
-   Public Domain.
-
-Files:
-   hist.lisp, hist.fasl, hist.catalog
-
-How to Get:
-   The following unix command will copy the pertinent files into directory
-<spec>.
-   cp /afs/cs.cmu.edu/project/slisp/library/hist/* <spec>
-
-Portability:
-   Should run in any legal Common Lisp.
-
-Instructions:
-   Hist is a macro of form (HIST (min max [bucket-size]) . body)
-
-Creates a histogram with buckets of the specified size (defaults to 1),
-spanning the range from Low (inclusive) to High (exclusive), with two
-additional buckets to catch values below and above this range.  The body is
-executed as a progn, and every call to Hist-Record within the body provides a
-value for the histogram to count.  When Body exits, the histogram is printed
-out and Hist returns Nil.
-
-A simple example:
-   (hist (0 10) (dotimes (i 1000) (random 10)))
-This example may make the RANDOM distribution look more normal:
-   (hist (0 10 2) (dotimes (i 1000) (random 10)))
-This example will show you overflow buckets:
-   (hist (2 12) (dotimes (i 1000) (random 15)))
-
-Wish List:
-   Some sort of automatic scaling for the number and size of buckets would be
-nice, if the user chooses not to supply these.  This would probably require
-running the body twice, once to determine the spread of values, and again to
-actually produce the histogram.
-
-
-Name:
-   OPS
-
-Package Name:
-   OPS
-
-Description:
-   Interpreter for Ops5, a programming language for production systems.
-
-Author:
-   Charles L. Forgy.  Ported to Common lisp by George Wood and Jim Kowalski.
-CMU Common Lisp mods by Dario Guise, Skef Wholey, and Dan Kuokka.
-
-Maintainer:
-   CMU Common Lisp Group.
-
-Net Address:
-   slisp-group@b
-
-Copyright Status:
-   Public domain.
-
-Files:
-   ops.lisp, ops-backup.lisp, ops-compile.lisp, ops-io.lisp, ops-main.lisp,
-ops-match.lisp, ops-rhs.lisp, ops-util.lisp, ops.catalog, ops-demo-mab.lisp,
-ops-demo-ttt.lisp, and binaries.
-
-How to Get:
-   The following unix command will copy the pertinent files into directory
-<spec>.
-   cp /afs/cs.cmu.edu/project/slisp/library/ops/* <spec>
-
-Portability:
-   Should run in any legal Common Lisp implementation.
-
-Instructions:
-   From Lisp, load "ops" and then go into the OPS package with (in-package
-'ops).  Now you can load your OPS5 code or start typing in productions.
-
-There are two demos -- interactive tic-tac-toe and the monkey and banana
-problem.  To run the former just load it and call RUN.  For the latter, first
-enter "(make start 1)" and then call RUN.
-
-See the OPS5 User's Manual, July 1981, by Forgy, CMU CSD.
-
-Bugs:
-   This has been put in its own package, but only a few interfaces have been
-exported.  You must run in the ops package.
-
-
-Package Name:
-   PROFILE
-
-Description:
-   Provides macros to do simple code profiling things.
-
-Author:
-   Skef Wholey
-   Rob MacLachlan
-
-Address:
-   Carnegie-Mellon University
-   Computer Science Department
-   Pittsburgh, PA 15213
-
-Net Address:
-   ram@cs.cmu.edu
-
-Copyright Status:
-   Public Domain
-
-Files:
-   profile.lisp, profile.fasl, profile.doc, profile.catalog
-
-How to Get:
-   The following unix command will copy the pertinent files into directory
-<spec>:
-   cp /afs/cs.cmu.edu/project/slisp/library/profile/* <spec>
-
-Portability:
-   Should run in any Common Lisp.  Someone porting this may want to change a
-few things mentioned in profile.lisp to tune it to another implementation.
-
-Instructions:
-   See the file profile.doc for details.
-
-
-Name:
-   PSgrapher
-
-Description:
-   The PSgrapher is a set of Lisp routines that can be called to produce
-Postscript commands that display a directed acyclic graph.
-
-Author:
-   Joseph Bates.  Skef put the whole thing in the PSGRPAPH package and added
-functionality which allows the user to specify EQ, EQUAL, or EQUALP as the
-node equivalence function.  Bill made all exported symbols have stars on them.
-
-Address:
-   Carnegie-Mellon University
-   Computer Science Department
-   Pittsburgh, PA 15213
-
-Net Address:
-   Joseph.Bates@CS.CMU.EDU
-
-Copyright Status:
-   Public Domain.
-
-Files:
-   psgraph.lisp, psgraph.fasl, psgraph.doc, psgraph.log, psgraph.catalog
-
-How to Get:
-   The following unix command will copy the pertinent files into directory
-<spec>.
-   cp /afs/cs.cmu.edu/project/clisp/library/psgraph/* <spec>
-
-Portability:
-   Should run in any legal Common Lisp.  Requires Postscript for printing.
-
-Instructions:
-   See psgraph.doc.
-
-Bugs:
-   This code blindly outputs what the user gives it as node labels.  It should
-run through the output escaping any PS control characters.  For example, if
-node labels contain parentheses, your output PS file will not print.
-
-Examples:
-   Skef Wholey submitted this as a reasonable example:
-
-;;; I use this in my compiler so I can look at code trees without
-;;; crawling around them in the inspector.  The postsript previewer
-;;; groks the generated ps file, which is bitchin' marvy.
-
-   (defun code-graph-to-file (s file &optional shrink insert)
-     (let ((psgraph:*fontname* "Times-Roman")
-	   (psgraph:*fontsize* 8)
-	   (psgraph:*second-fontname* "Times-BoldItalic")
-	   (psgraph:*second-fontsize* 6)
-	   (psgraph:*boxgray* "0")
-	   (psgraph:*edgegray* "0")
-	   (psgraph:*extra-x-spacing* 30))
-       (with-open-file (*standard-output* file
-					  :direction :output
-					  :if-exists :supersede)
-	 (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq))))
diff --git a/contrib/READ-ME.TXT b/contrib/READ-ME.TXT
deleted file mode 100644
index 7e9800b6a4fbd091f4be8251362436f415fc927a..0000000000000000000000000000000000000000
--- a/contrib/READ-ME.TXT
+++ /dev/null
@@ -1,132 +0,0 @@
-DESCRIPTION OF THE CMU COMMON LISP LIBRARY AND CATALOG ENTRY FORMAT.
-
-The CMU Common Lisp library contains a variety of useful or interesting
-software packages written by users of CMU Common Lisp.  Each entry is contained
-in its own subdirectory.  The CATALOG.TXT describes every entry in the library.
-Two subdirectories are for library maintainers, library-broken and
-library-maintenance.
-
-To submit a program for inclusion in the library, send mail to Gripe
-pointing to the relevant files and providing the information for the
-catalog entry in the format described below.  The library maintainers will
-verify that the program runs as documented in the current Lisp, has no
-crippling bugs, and that the functionality is not duplicated in some other
-program; then we will add the program to the library.  Programs that are
-made obsolete by later submissions may be dropped from the library, after
-due notice is given to the user community.  Some programs may be deemed so
-useful that they will be included in the standard CMU Common Lisp system.
-
-All source files must be included for each software package in the library.
-Whenever possible, a program should be submitted as a single large file
-rather than as a collection of smaller files; this will help to minimize
-version-control problems.
-
-Note: We plan to distribute this software freely over the Arpanet and we
-may set up some mechanism to provide non-arpanet users with tapes.  We can
-in general accept only public-domain code (anything with no copyright
-notice in the source will be assumed to be in the public domain) and code
-for which Carnegie-Mellon University holds the copyright.  If you have any
-code of commercial value, the copyright system provides little real
-protection in any case.
-
-Bugs in library programs not listed in the "bugs" section of the program's
-description should be reported to the maintainer listed below (or to the
-author if there is no maintainer), with CC to Gripe.
-
-Send any questions or comments to Gripe.
-
-
-CATALOG ENTRY FORMAT FOR CATALOG.TXT.
-
-Each entry is on a separate page, separated by the page mark Control-L.
-
-Each entry consists of fields.  Each new field begins on a fresh line with a
-field name terminated by a colon.  Then on a new line, indented at least one
-space, is an arbitrary amount of text.  This somewhat rigid format is designed
-to make it easy to build various sorts of software to automatically manipulate
-catalogs, but the indentation is simply a convenience for paragraph
-manipulation and filling commands in the editor.  The field names are sensitive
-to spelling, but insensitive to case and extra whitespace.
-
-The following is a specification of the possible fields in the catalog format:
-
-Name:		or
-Module Name:
-   This specifies the name of the program or set of programs.  If the supplier
-of the entry does not specify a Package Name, then this is the package in which
-the code lives.
-
-Package Name:
-   If the programs are loaded into a package of their own, this is the name of
-that package.  If the supplier of the entry does not specify a Name or Module
-Name, the package name will be used as the name for everything.
-
-Description:
-   This is a brief description of what the program does.
-
-Author:
-   This is the name of the author, or "anonymous".
-
-Maintainer:
-   This is the name of the current maintainer, if different from the author.
-If a program is not being maintained by anyone, the Maintainer is "none".
-
-Address:		or
-Address of Author:	or
-Address of Maintainer:
-   This is the physical mailing address of the author or maintainer.  If the
-field is just "address", it is assumed to be the maintainer if one is
-specified, and the author otherwise.
-
-Net Address:			or
-Net Address of Author:		or
-Net Address of Maintainer:
-   This is a network address that can be reached from the arpanet.
-
-Copyright Status:
-   This is "Public domain.", or some sort of copyright notice.
-
-Files:
-   This is a list of the files that constitute this facility.  For example, a
-system named "Foo" may be distributed as files "foo.lisp", "foo.fasl", and
-(optionally) "foo.doc" or "foo.PS" for documentation.  In order to minimize
-maintenance headaches and encourage people to build on the work of others, we
-want all programs in the library to include complete sources.
-
-How to Get:
-   This can either be a shell command using such programs as lcp or cp, or
-there may be a .cmd file that will copy all the sources, binaries, catalog, and
-log files to the user's current directory.  This .cmd file will try to preserve
-write date (such as using -p with cp).
-
-Portability:
-   If the program will run in any legal Common Lisp, say so.  If there are
-known dependencies on CMU Common Lisp specific or Mach/RT specific features,
-describe them here.  Programs relying on CLX, CLOS, etc. should be considered
-to have a high expectation of portability.
-
-Dependencies:
-   If the program requires other library packages not built into the standard
-CMU Common Lisp core image, list those other packages here.
-
-Instructions:
-   Place here any instructions for use that are too lengthy to be mere
-documentation strings, but that are not lengthy enough to deserve a separate
-document.
-
-Recent Changes:
-   What is different between this version and the one that preceded it, if any.
-(May go back several versions at the author's discretion.)
-
-Bugs:
-   Describe here any known bugs or treacherous features.
-
-Future Plans:
-   Describe here any improvements planned by the author.
-
-Wish List:
-   Describe here any desirable features that the author does not plan to work
-on in the near future.
-
-Notes:
-   This is anything else that users or potential users ought to know about.
diff --git a/contrib/defsystem/defsystem.lisp b/contrib/defsystem/defsystem.lisp
deleted file mode 100644
index 33c2541f89dfeee4b06fde241dd9424d4a54137b..0000000000000000000000000000000000000000
--- a/contrib/defsystem/defsystem.lisp
+++ /dev/null
@@ -1,1217 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-Lisp -*-
- 
-;;; ********************************************************************
-;;; Portable Mini-DefSystem ********************************************
-;;; ********************************************************************
-;;; Fri Feb  2 10:24:17 1990 by Mark Kantrowitz <mkant@GS8.SP.CS.CMU.EDU>
-
-;;; This is a portable system definition facility for Common Lisp. 
-;;; Though home-grown, the syntax was inspired by fond memories of the
-;;; defsystem facility on Symbolics 3600's. The exhaustive lists of
-;;; filename extensions for various lisps and the idea to have one
-;;; "operate-on-system" function instead of separate "compile-system"
-;;; and "load-system" functions were taken from Xerox Corp.'s PCL 
-;;; system.
-
-;;; This system improves on both PCL and Symbolics defsystem utilities
-;;; by performing a topological sort of the graph of file-dependency 
-;;; constraints. Thus, the components of the system need not be listed
-;;; in any special order, because the defsystem command reorganizes them
-;;; based on their constraints. It includes all the standard bells and
-;;; whistles, such as not recompiling a binary file that is up to date
-;;; (unless the user specifies that all files should be recompiled).
-
-;;; Written by Mark Kantrowitz, School of Computer Science, 
-;;; Carnegie Mellon University, October 1989.
-
-;;; Copyright (c) 1989 by Mark Kantrowitz. All rights reserved.
-
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted, so long as the following
-;;; conditions are met:
-;;;      o no fees or compensation are charged for use, copies, or
-;;;        access to this software
-;;;      o this copyright notice is included intact.
-;;; This software is made available AS IS, and no warranty is made about 
-;;; the software or its performance. 
-
-;;; Please send bug reports, comments and suggestions to mkant@cs.cmu.edu. 
-
-
-;;; ********************************************************************
-;;; How to Use this System *********************************************
-;;; ********************************************************************
-
-;;; To use this system,
-;;; 1. If you want to have a central registry of system definitions, 
-;;;    modify the value of the variable *central-registry* below.
-;;; 2. Load this file (defsystem.lisp) in either source or compiled form,
-;;; 3. Load the file containing the "defsystem" definition of your system,
-;;; 4. Use the function "operate-on-system" to do things to your system.
-
-;;; For more information, see the documentation and examples in defsystem.text.
-
-;;; ****************************************************************
-;;; Lisp Code ******************************************************
-;;; ****************************************************************
-
-;;; ********************************
-;;; Set up Package *****************
-;;; ********************************
-
-(in-package "DEFSYSTEM" 
-	    :nicknames '("DEFSYS" "MAKE")
-	    :use '("USER"
-		   "LISP")
-	    )
-
-(provide 'defsystem)
-
-(defvar *exports*
-   '(defsystem operate-on-system oos afs-binary-directory files-in-system))
-
-(defvar *other-exports* 
-  '(*central-registry* *bin-subdir* 
-     machine-type-translation software-type-translation
-					;require
-     allegro-make-system-fasl files-which-need-compilation 
-     ))
-
-(export (append *exports* *other-exports*))
-#|
-;(import *exports* "LISP")
-;(import *exports* "USER")
-|#
-
-#-(OR CMU :CCL)
-(import *exports* "USER")
-#+(OR CMU :CCL)
-(progn
-  (import (cdr *exports*) "USER")
-  (shadowing-import (car *exports*) "USER"))
-
-#-PCL(when (find-package "PCL") (push :pcl *modules*)(push :pcl *features*))
-
-
-
-;;; ********************************
-;;; Customizable System Parameters *
-;;; ********************************
-
-;;; Change this variable to set up the location of a central
-;;; repository for system definitions if you want one.
-(defvar *central-registry* "/afs/cs.cmu.edu/project/oz/oz2/system/Registry/" 
-  "Central directory of system definitions" )
-
-(defvar *bin-subdir* ".bin/"
-  "The subdirectory of an AFS directory where the binaries are really kept.")
-
-;;; These variables set up defaults for operate-on-system, and are used 
-;;; for communication in lieu of parameter passing. Yes, this is bad,
-;;; but it keeps the interface small. Also, in the case of the -if-no-binary
-;;; variables, parameter passing would require multiple value returns
-;;; from some functions. Why make life complicated?
-(defvar *tell-user-when-done* nil
-  "If T, system will print ...DONE at the end of an operation")
-(defvar *oos-verbose* nil 
-  "Operate on System Verbose Mode")
-(defvar *oos-test* nil 
-  "Operate on System Test Mode")
-(defvar *load-source-if-no-binary* nil
-  "If T, system will try loading the source if the binary is missing")
-(defvar *bother-user-if-no-binary* t
-  "If T, the system will ask the user whether to load the source if the binary is missing")
-(defvar *load-source-instead-of-binary* nil
-  "If T, the system will load the source file instead of the binary.")
-
-;;; Particular to CMULisp
-(defvar *compile-error-file-type* "err"
-  "File type of compilation error file in cmulisp")
-(defvar *cmu-errors-to-terminal* t
-  "Argument to :errors-to-terminal in compile-file in cmulisp")
-(defvar *cmu-errors-to-file* t
-  "If T, cmulisp will write an error file during compilation")
-
-;;; ********************************
-;;; Global Variables ***************
-;;; ********************************
-
-;;; Massage people's *features* into better shape.
-(eval-when (compile load eval)  
-  (dolist (feature *features*)
-    (when (and (symbolp feature)   ; 3600
-               (equal (symbol-name feature) "CMU"))
-      (pushnew :CMU *features*)))
-  
-  #+Lucid
-  (when (search "IBM RT PC" (machine-type))
-    (pushnew :ibm-rt-pc *features*))
-  )
-
-;;; *filename-extensions* is a cons of the source and binary extensions.
-(defvar *filename-extensions*
-  (car '(#+(and Symbolics Lispm)              ("lisp" . "bin")
-         #+(and dec common vax (not ultrix))  ("LSP"  . "FAS")
-         #+(and dec common vax ultrix)        ("lsp"  . "fas")
-         #+KCL                                ("lsp"  . "o")
-         #+IBCL                               ("lsp"  . "o")
-         #+Xerox                              ("lisp" . "dfasl")
-         #+(and Lucid MC68000)                ("lisp" . "lbin")
-         #+(and Lucid Vax)                    ("lisp" . "vbin")   
-         #+(and Lucid Prime)                  ("lisp" . "pbin")
-         #+(and Lucid SUNRise)                ("lisp" . "sbin")
-         #+(and Lucid SPARC)                  ("lisp" . "sbin")
-         #+(and Lucid :IBM-RT-PC)              ("lisp" . "bbin")
-         #+excl                               ("cl"   . "fasl")
-         #+:CMU                               ("lisp" . "fasl")
-	 #+PRIME                              ("lisp" . "pbin")
-         #+HP                                 ("l"    . "b")
-         #+TI ("lisp" . #.(string (si::local-binary-file-type)))
-         #+:gclisp                            ("LSP"  . "F2S")
-         #+pyramid                            ("clisp" . "o")
-         #+:coral                             ("lisp" . "fasl")
-         
-         ;; Otherwise,
-         ("lisp" . "lbin")))
-  "Filename extensions for Common Lisp. A cons of the form
-   (Source-Extension . Binary-Extension). If the system is 
-   unknown (as in *features* not known), defaults to lisp and lbin.")
-
-;;; There is no real support for this variable being nil, so don't change it.
-;;; Note that in any event, the toplevel system (defined with defsystem)
-;;; will have its dependencies delayed. Not having dependencies delayed
-;;; might be useful if we define several systems within one defsystem.
-(defvar *system-dependencies-delayed* t 
-  "If T, system dependencies are expanded at run time")
-
-(defun non-empty-listp (list)
-  (and list (listp list)))
-
-;;; ********************************
-;;; Alist Manipulation *************
-;;; ********************************
-(defun alist-lookup (name alist &key test test-not key)
-  (cdr (assoc name alist :test test :test-not test-not :key key)))
-
-(defmacro set-alist-lookup ((name alist &key test test-not key) value)
-  (let ((pair (gensym)))
-    `(let ((,pair (assoc ,name ,alist :test ,test :test-not ,test-not :key ,key)))
-       (if ,pair
-	   (rplacd ,pair ,value)
-	 (push (cons ,name ,value) ,alist)))))
-
-(defvar *component-operations* nil
-  "Alist of (operation-name function) pairs" )
-(defun component-operation (name &optional operation)
-  (if operation
-      (set-alist-lookup (name *component-operations*) operation)
-    (alist-lookup name *component-operations*)))
-
-;;; ********************************
-;;; AFS @sys immitator *************
-;;; ********************************
-(defun afs-binary-directory (root-directory)
-  ;; Function for obtaining the directory AFS's @sys feature would have
-  ;; chosen when we're not in AFS. This function is useful as the argument
-  ;; to :binary-pathname in defsystem.
-  (let ((machine (machine-type-translation (machine-type)))
-	(software (software-type-translation (software-type))))
-    ;; pmax_mach rt_mach sun3_35 sun3_mach vax_mach
-    (format nil "~A~@[~A~]~@[~A/~]" 
-	    (namestring root-directory)
-	    *bin-subdir*
-	    (afs-component machine software)
-	    )))
-
-(defun afs-component (machine software)
-  (format nil "~@[~A~]~@[_~A~]" 
-	    machine 
-	    (or software "mach")))
-
-(defvar *machine-type-alist* nil
-  "Alist for retrieving the machine-type")
-(defun machine-type-translation (name &optional operation)
-  (if operation
-      (set-alist-lookup (name *machine-type-alist* :test #'string-equal) operation)
-    (alist-lookup name *machine-type-alist* :test #'string-equal)))
-
-(machine-type-translation "IBM RT PC"   "rt")
-(machine-type-translation "DEC 3100"    "pmax")
-(machine-type-translation "DEC VAX-11"  "vax")
-(machine-type-translation "Sun3"        "sun3")
-
-(defvar *software-type-alist* nil
-  "Alist for retrieving the software-type")
-(defun software-type-translation (name &optional operation)
-  (if operation
-      (set-alist-lookup (name *software-type-alist* :test #'string-equal) operation)
-    (alist-lookup name *software-type-alist* :test #'string-equal)))
-
-(software-type-translation "BSD UNIX" "mach") ; "unix"
-(software-type-translation "Ultrix" "mach") ; "ultrix"
-(software-type-translation "SunOS" "SunOS")
-(software-type-translation "MACH/4.3BSD" "mach")
-
-;;; ********************************
-;;; System Names *******************
-;;; ********************************
-(defun canonicalize-system-name (name)
-  ;; Names of modules or files may be symbols or strings, but
-  ;; names of systems must be symbols for accessing the system.
-  (if (symbolp name)
-      name
-      (intern (string-upcase (string name)))))
-
-(defun get-system (name)
-  ;; The system definition is stored under the
-  ;; 'system property of the system name.
-  (get (canonicalize-system-name name) 'system))
-
-(defsetf get-system (name) (value)
-  `(setf (get (canonicalize-system-name ,name) 'system) ,value))
-
-;;; ********************************
-;;; Directory Pathname Hacking *****
-;;; ********************************
-
-;;; There is no CL primitive for tacking a subdirectory onto a directory.
-;;; Such a primitive is needed since we use both absolute and relative 
-;;; directories. The merge-directories function was a try that failed
-;;; (we're keeping it around to prevent future mistakes of that sort),
-;;; while the append-directories function seems to work right most
-;;; of the time (i.e., it gets the pathname delimiters right).
-
-;;; Unix example: An absolute directory starts with / while a 
-;;; relative directory doesn't. A directory ends with /, while
-;;; a file's pathname doesn't. This is important 'cause
-;;; (pathname-directory "foo/bar") will return "foo" and not "foo/".
-
-(defun append-directories (absolute-directory relative-directory)
-  ;; Assumptions: Absolute-directory is a directory, with no
-  ;; filename stuck on the end. Relative-directory, however, may
-  ;; have a filename stuck on the end.
-  (when (or absolute-directory relative-directory)
-	#+ExCL(when (and (stringp absolute-directory)
-			 (null-string absolute-directory))
-		    (setq absolute-directory nil))
-	#+CMU(when (pathnamep absolute-directory) 
-		   (setq absolute-directory (namestring absolute-directory)))
-	#+CMU(when (pathnamep relative-directory) 
-		   (setq relative-directory (namestring relative-directory)))
-	(namestring (make-pathname :directory absolute-directory 
-				   :name relative-directory))))
-
-(defun null-string (s)
-  (string-equal s ""))
-
-#|
-<cl> (defun d (d n) (namestring (make-pathname :directory d :name n)))
-
-D
-<cl> (d "/foo/bar/" "baz/barf.lisp")
-
-"/foo/bar/baz/barf.lisp"
-<cl> (d "foo/bar/" "baz/barf.lisp")
-
-"foo/bar/baz/barf.lisp"
-<cl> (d "foo/bar" "baz/barf.lisp")
-
-"foo/bar/baz/barf.lisp"
-<cl> (d "foo/bar" "/baz/barf.lisp")
-
-"foo/bar//baz/barf.lisp"
-<cl> (d "foo/bar" nil)
-
-"foo/bar/"
-<cl> (d nil "baz/barf.lisp")
-
-"baz/barf.lisp"
-<cl> (d nil nil)
-
-""
-
-|#
-
-#|
-(defun merge-directories (absolute-directory relative-directory)
-	  ;; replace concatenate with something more intelligent
-	  ;; i.e., concatenation won't work with some directories.
-	  ;; it should also behave well if the parent directory 
-	  ;; has a filename at the end, or if the relative-directory ain't relative
-	  (when absolute-directory 
-	    (setq absolute-directory (pathname-directory absolute-directory)))
-	  (concatenate 'string 
-		       (or absolute-directory "")
-		       (or relative-directory "")))
-|#
-
-(defun namestring-or-nil (pathname)
-  (when pathname
-    (namestring pathname)))
-
-(defun new-file-type (pathname type)
-  (make-pathname
-   :host (pathname-host pathname)
-   :device (pathname-device pathname)
-   :directory (pathname-directory pathname)
-   :name (pathname-name pathname)
-   :type type
-   :version (pathname-version pathname)))
-
-;;; ********************************
-;;; Component Defstruct ************
-;;; ********************************
-(defstruct (topological-sort-node (:conc-name topsort-))
-  color
-  time)
-
-(defstruct (component (:include topological-sort-node)
-                      (:print-function print-component))
-  type                ; :system, :module, or :file, or :private-file
-  name                ; a symbol or string
-  indent              ; number of characters of indent in verbose output to the user.
-  host                ; the pathname host (i.e., "/../a")
-  device              ; the pathname device
-  source-root-dir
-  source-pathname     ; relative or absolute (starts with "/"), directory or file (ends with "/")
-  source-extension    ; a string, e.g., "lisp". If nil, uses default for machine-type
-  binary-pathname
-  binary-root-dir
-  binary-extension    ; a string, e.g., "fasl". If nil, uses default for machine-type
-  package             ; package for use-package
-  components          ; a list of components comprising this component's definition
-  depends-on          ; a list of the components this one depends on. may refer only
-                      ; to the components at the same level as this one.
-  initially-do        ; form to evaluate before the operation
-  finally-do          ; form to evaluate after the operation
-  compile-form        ; for foreign libraries
-  load-form           ; for foreign libraries
-)
-
-(defun print-component (component stream depth)
-  (declare (ignore depth))
-  (format stream "#<~:(~A~) ~A>"
-          (component-type component)
-          (component-name component)))
-
-(defun canonicalize-component-name (component)
-  ;; Within the component, the name is a string.
-  (if (typep (component-name component) 'string)
-      ;; Unnecessary to change it, so just return it, same case
-      (component-name component)
-    ;; Otherwise, make it a downcase string
-    (setf (component-name component) 
-	  (string-downcase (string (component-name component))))))
-
-(defun component-pathname (component type)
-  (when component
-    (case type
-      (:source (component-source-pathname component))
-      (:binary (component-binary-pathname component))
-      (:error  (component-error-pathname component)))))
-(defun component-error-pathname (component)
-  (let ((binary (component-pathname component :binary)))
-    (new-file-type binary *compile-error-file-type*)))
-(defsetf component-pathname (component type) (value)
-  `(when ,component
-     (case ,type
-       (:source (setf (component-source-pathname ,component) ,value))
-       (:binary (setf (component-binary-pathname ,component) ,value)))))
-
-(defun component-root-dir (component type)
-  (when component
-    (case type
-      (:source (component-source-root-dir component))
-      ((:binary :error) (component-binary-root-dir component))
-      )))
-(defsetf component-root-dir (component type) (value)
-  `(when ,component
-     (case ,type
-       (:source (setf (component-source-root-dir ,component) ,value))
-       (:binary (setf (component-binary-root-dir ,component) ,value)))))
-
-(defvar *version-dir* nil
-  "The version subdir. bound in oos.")
-(defvar *version-replace* nil
-  "The version replace. bound in oos.")
-(defvar *version* nil
-  "Default version")
-(defun component-full-pathname (component type &optional (version *version*)
-					  &aux version-dir replace)
-  (when component
-    ;; If the pathname-type is :binary and the root pathname is null,
-    ;; distribute the binaries among the sources (= use :source pathname).
-    ;; This assumes that the component's :source pathname has been set
-    ;; before the :binary one.
-    (if version
-	(multiple-value-setq (version-dir replace) (translate-version version))
-      (setq version-dir *version-dir* replace *version-replace*))
-    (let ((pathname
-	   (append-directories 
-	    (if replace
-		version-dir
-	      (append-directories (component-root-dir component type)
-				  version-dir))
-	    (component-pathname component type))))
-      (make-pathname :name (pathname-name pathname)
-		     :type (component-extension component type)
-		     :host (pathname-host (component-host component))
-		     :device #+CMU :absolute
-		             #-CMU (pathname-device (component-device component))
-		     ;; :version :newest
-		     ;; Use :directory instead of :defaults
-		     :directory (pathname-directory pathname)))))
-
-(defun translate-version (version)
-  ;; Value returns the version directory and whether it replaces 
-  ;; the entire root (t) or is a subdirectory.
-  ;; Version may be nil to signify no subdirectory,
-  ;; a symbol, such as alpha, beta, omega, :alpha, mark, which
-  ;; specifies a subdirectory of the root, or
-  ;; a string, which replaces the root.
-  (cond ((null version) 
-	 (values "" nil))
-	((symbolp version)
-	 (values (string-downcase (string version)) nil))
-	((stringp version)
-	 (values version t))
-	(t (error "~&; Illegal version ~S" version))))
-
-(defun component-extension (component type)
-  (case type
-    (:source (component-source-extension component))
-    (:binary (component-binary-extension component))
-    (:error  *compile-error-file-type*)))
-(defsetf component-extension (component type) (value)
-  `(case ,type
-     (:source (setf (component-source-extension ,component) ,value))
-     (:binary (setf (component-binary-extension ,component) ,value))
-     (:error  (setf *compile-error-file-type* ,value))))
-
-;;; ********************************
-;;; System Definition **************
-;;; ********************************
-(defmacro defsystem (name &rest definition-body)    
-  `(create-component :system ',name ',definition-body nil 0))
-
-(defun create-component (type name definition-body &optional parent (indent 0))
-  (let ((component (apply #'make-component :type type :name name :indent indent definition-body)))
-    ;; Initializations/after makes
-    (canonicalize-component-name component)
-
-    ;; Type specific setup:
-    (when (eq type :system)
-      (setf (get-system name) component))
-
-    ;; Set up the component's pathname
-    (create-component-pathnames component parent)
-
-    ;; If there are any components of the component, expand them too.
-    (expand-component-components component (+ indent 2))
-
-    ;; Make depends-on refer to structs instead of names.
-    (link-component-depends-on (component-components component))
-
-    ;; Design Decision: Topologically sort the dependency graph at
-    ;; time of definition instead of at time of use. Probably saves a
-    ;; little bit of time for the user.
-
-    ;; Topological Sort the components at this level.
-    (setf (component-components component)
-          (topological-sort (component-components component)))
-
-    ;; Return the component.
-    component))
-
-(defun create-component-pathnames (component parent)
-  ;; Evaluate the root dir arg
-  (setf (component-root-dir component :source)
-	(eval (component-root-dir component :source)))
-  (setf (component-root-dir component :binary)
-	(eval (component-root-dir component :binary)))
-  ;; Evaluate the pathname arg
-  (setf (component-pathname component :source)
-	(eval (component-pathname component :source)))
-  (setf (component-pathname component :binary)
-	(eval (component-pathname component :binary)))
-  ;; Pass along the host and devices
-  (setf (component-host component)
-	(or (component-host component)
-	    (when parent (component-host parent))))
-  (setf (component-device component)
-	(or (component-device component)
-	    (when parent (component-device parent))))
-  ;; Set up extension defaults
-  (setf (component-extension component :source)
-	(or (component-extension component :source) ; for local defaulting
-	    (when parent		; parent's default
-	      (component-extension parent :source))
-	    (car *filename-extensions*))) ; system default
-  (setf (component-extension component :binary)
-	(or (component-extension component :binary) ; for local defaulting
-	    (when parent		; parent's default
-	      (component-extension parent :binary))
-	    (cdr *filename-extensions*))) ; system default
-  ;; Set up pathname defaults -- expand with parent
-  ;; We must set up the source pathname before the binary pathname
-  ;; to allow distribution of binaries among the sources to work.
-  (generate-component-pathname component parent :source)
-  (generate-component-pathname component parent :binary))
-
-;; maybe file's inheriting of pathnames should be moved elsewhere?
-(defun generate-component-pathname (component parent pathname-type)
-  ;; Pieces together a pathname for the component based on its component-type.
-  ;; Assumes source defined first.
-  ;; Null binary pathnames inherit from source instead of the component's
-  ;; name. This allows binaries to be distributed among the source if
-  ;; binary pathnames are not specified. Or if the root directory is
-  ;; specified for binaries, but no module directories, it inherits
-  ;; parallel directory structure.
-  (case (component-type component)
-    (:system				; Absolute Pathname
-     ;; Set the root-dir to be the absolute pathname
-     (setf (component-root-dir component pathname-type)
-	   (or (component-pathname component pathname-type)
-	       (when (eq pathname-type :binary)
-		 ;; When the binary root is nil, use source.
-		 (component-root-dir component :source))) )
-     ;; Set the relative pathname to be nil
-     (setf (component-pathname component pathname-type) 
-	   nil));; should this be "" instead?
-    ;; If the name of the component-pathname is nil, it
-    ;; defaults to the name of the component. Use "" to
-    ;; avoid this defaulting.
-    (:private-file                      ; Absolute Pathname
-     ;; Root-dir is the directory part of the pathname
-     (setf (component-root-dir component pathname-type)
-	   ""
-	   #+ignore(or (when (component-pathname component pathname-type)
-			 (pathname-directory 
-			  (component-pathname component pathname-type)))
-		       (when (eq pathname-type :binary)
-			 ;; When the binary root is nil, use source.
-			 (component-root-dir component :source)))
-	   )
-     ;; The relative pathname is the name part
-     (setf (component-pathname component pathname-type)
-	   (or (when (and (eq pathname-type :binary)
-			  (null (component-pathname component :binary)))
-		 ;; When the binary-pathname is nil use source.
-		 (component-pathname component :source))
-	       (or (when (component-pathname component pathname-type)
-;		     (pathname-name )
-		     (component-pathname component pathname-type))
-		   (component-name component)))))
-    (:module				; Pathname relative to parent.
-     ;; Inherit root-dir from parent
-     (setf (component-root-dir component pathname-type)
-	   (component-root-dir parent pathname-type))
-     ;; Tack the relative-dir onto the pathname
-     (setf (component-pathname component pathname-type)
-	   (or (when (and (eq pathname-type :binary)
-			  (null (component-pathname component :binary)))
-		 ;; When the binary-pathname is nil use source.
-		 (component-pathname component :source))
-	       (append-directories
-		(component-pathname parent pathname-type)
-		(or (component-pathname component pathname-type)
-		    (component-name component))))))
-    (:file				; Pathname relative to parent.
-     ;; Inherit root-dir from parent
-     (setf (component-root-dir component pathname-type)
-	   (component-root-dir parent pathname-type))
-     ;; Tack the relative-dir onto the pathname
-     (setf (component-pathname component pathname-type)
-	   (or (append-directories
-		(component-pathname parent pathname-type)
-		(or (component-pathname component pathname-type)
-		    (component-name component)
-		    (when (eq pathname-type :binary)
-		      ;; When the binary-pathname is nil use source.
-		      (component-pathname component :source)))))))
-    ))	   
-
-(defun expand-component-components (component &optional (indent 0)) 
-  (setf (component-components component)
-        (mapcar #'(lambda (definition)
-                    (expand-component-definition definition component indent))
-                (component-components component))))
-
-(defun expand-component-definition (definition parent &optional (indent 0))
-  ;; Should do some checking for malformed definitions here.
-  (cond ((null definition) nil)
-        ((stringp definition) 
-         ;; Strings are assumed to be of type :file
-         (create-component :file definition nil parent indent))
-        ((and (listp definition)
-              (not (member (car definition) 
-			   '(:system :module :file :private-file))))
-         ;; Lists whose first element is not a component type
-         ;; are assumed to be of type :file
-         (create-component :file (car definition) (cdr definition) parent indent))
-        ((listp definition)
-         ;; Otherwise, it is (we hope) a normal form definition
-         (create-component (car definition)   ; type
-                           (cadr definition)  ; name
-                           (cddr definition)  ; definition body
-                           parent             ; parent
-			   indent)            ; indent
-         )))
-
-(defun link-component-depends-on (components)
-  (dolist (component components)
-    (unless (and *system-dependencies-delayed*
-                 (eq (component-type component) :system))
-      (setf (component-depends-on component)
-            (mapcar #'(lambda (dependency)
-                        (find (string dependency) components :key #'component-name 
-                              :test #'string-equal)) 
-                    (component-depends-on component))))))
-
-;;; ********************************
-;;; Topological Sort the Graph *****
-;;; ********************************
-(defun topological-sort (list &aux (time 0))
-  ;; The algorithm works by calling depth-first-search to compute the
-  ;; blackening times for each vertex, and then sorts the vertices into
-  ;; reverse order by blackening time.
-  (labels ((dfs-visit (node)
-             (setf (topsort-color node) 'gray)
-             (unless (and *system-dependencies-delayed*
-                          (eq (component-type node) :system))
-               (dolist (child (component-depends-on node))
-                 (cond ((eq (topsort-color child) 'white)
-                        (dfs-visit child))
-                       ((eq (topsort-color child) 'gray)
-                        (format t "~&Detected cycle containing ~A" child)))))
-             (setf (topsort-color node) 'black)
-             (setf (topsort-time node) time)
-             (incf time)))
-    (dolist (node list)
-      (setf (topsort-color node) 'white))
-    (dolist (node list)
-      (when (eq (topsort-color node) 'white)
-        (dfs-visit node)))
-    (sort list #'< :key #'topsort-time)))
-
-;;; ********************************
-;;; Output to User *****************
-;;; ********************************
-;;; All output to the user is via the tell-user functions.
-
-(defun split-string (string &key (item #\space) (test #'char=))
-  ;; Splits the string into substrings at spaces.
-  (let ((len (length string))
-	(index 0) result)
-    (dotimes (i len
-		(progn (unless (= index len)
-			 (push (subseq string index) result))
-		       (reverse result)))
-      (when (funcall test (char string i) item)
-	(unless (= index i);; two spaces in a row
-	  (push (subseq string index i) result))
-	(setf index (1+ i))))))
-
-(defun prompt-string (component)
-  (format nil "; ~:[~;TEST:~]~V,@T "
-	  *oos-test*
-	  (component-indent component)))
-
-(defun format-justified-string (prompt contents)
-  (format t (concatenate 'string "~%" prompt "-~{~<~%" prompt " ~1,80:; ~A~>~^~}")
-	  (split-string contents))
-  (finish-output *standard-output*))
-
-(defun tell-user (what component &optional type no-dots force)
-  (when (or *oos-verbose* force)
-    (format-justified-string (prompt-string component)
-     (format nil "~A ~(~A~) ~@[\"~A\"~] ~:[~;...~]"
-	     (case what 
-	       ((compile :compile) "Compiling")
-	       ((load :load) "Loading")
-	       (otherwise what))
-	     (component-type component)
-	     (or (when type
-		   (namestring-or-nil (component-full-pathname
-				       component type)))
-		 (component-name component))
-	     (and *tell-user-when-done*
-		  (not no-dots))))))
-
-(defun tell-user-done (component &optional force no-dots)
-  ;; test is no longer really used, but we're leaving it in.
-  (when (and *tell-user-when-done*
-	     (or *oos-verbose* force))
-    (format t "~&~A~:[~;...~] Done."
-	    (prompt-string component) (not no-dots))
-    (finish-output *standard-output*)))
-
-(defmacro with-tell-user ((what component &optional type no-dots force) &body body)
-  `(progn
-     (tell-user ,what ,component ,type ,no-dots ,force)
-     ,@body
-     (tell-user-done ,component ,force ,no-dots)))
-
-(defun tell-user-no-files (component &optional force)
-  (when (or *oos-verbose* force)
-    (format-justified-string (prompt-string component)
-      (format nil "Binary file ~A ~
-             ~:[and source file ~A do~;does~] not exist, not loading."
-	      (namestring (component-full-pathname component :binary))
-	      (or *load-source-if-no-binary* *load-source-instead-of-binary*)
-	      (namestring (component-full-pathname component :source))))))
-
-(defun tell-user-require-system (name parent)
-  (when *oos-verbose*
-    (format t "~&; ~:[~;TEST:~] - System ~A requires ~S"
-	    *oos-test* (component-name parent) name)
-    (finish-output *standard-output*)))
-
-(defun tell-user-generic (string)
-  (when *oos-verbose*
-    (format t "~&; ~:[~;TEST:~] - ~A"
-	    *oos-test* string)
-    (finish-output *standard-output*)))
-
-;;; ********************************
-;;; Y-OR-N-P-WAIT ******************
-;;; ********************************
-;;; y-or-n-p-wait is like y-or-n-p, but will timeout
-;;; after a specified number of seconds
-(defun internal-real-time-in-seconds ()
-  (float (/ (get-internal-real-time) 
-	    internal-time-units-per-second)))
-
-(defun read-char-wait (&optional (timeout 20) input-stream &aux char)
-  (do ((start (internal-real-time-in-seconds)))
-      ((or (setq char (read-char-no-hang input-stream)) ;(listen *query-io*)
-	   (< (+ start timeout) (internal-real-time-in-seconds)))
-       char)))
-
-(defun y-or-n-p-wait (&optional (default #\y) (timeout 20) 
-				format-string &rest args)
-  (clear-input *query-io*)
-  (format *query-io* "~&~?" (or format-string "") args)
-  (finish-output *query-io*);; needed for CMU and other places
-  (let* ((read-char (read-char-wait timeout *query-io*))
-	 (char (or read-char default)))
-    (clear-input *query-io*)
-    (when (null read-char) (format *query-io* "~@[~A~]" default))
-    (cond ((null char)  t)
-	  ((find char '(#\y #\Y #\space) :test #'char=) t)
-	  ((find char '(#\n #\N) :test #'char=) nil)
-	  (t (y-or-n-p-wait default timeout 
-			    "Type \"y\" for yes or \"n\" for no. ")))))
-
-(defvar *use-timeouts* t)
-
-(defun y-or-n-p-wait-optional (&optional (default #\y) (timeout 20) 
-					 format-string &rest args)
-  (cond ((and default
-	      *use-timeouts*)
-	 (apply 'y-or-n-p-wait default timeout format-string args))
-	(t       (apply 'y-or-n-p format-string args))))
-
-#|
-(y-or-n-p-wait #\y 20 "What? ")
-(progn (format t "~&hi")
-       (y-or-n-p-wait #\y 10 "1? ")
-       (y-or-n-p-wait #\n 10 "2? "))
-|#
-;;; ********************************
-;;; Operate on System **************
-;;; ********************************
-;;; Operate-on-system
-;; Operation is :compile, 'compile, :load or 'load
-;; Force is :all or :new-source or :new-source-and-dependents or a list of
-;; specific modules.
-;;    :all (or T) forces a recompilation of every file in the system
-;;    :new-source-and-dependents compiles only those files whose
-;;          sources have changed or who depend on recompiled files.
-;;    :new-source compiles only those files whose sources have changed
-;;    A list of modules means that only those modules and their dependents are recompiled.
-;; Test is T to print out what it would do without actually doing it. 
-;;      Note: it automatically sets verbose to T if test is T.
-;; Verbose is T to print out what it is doing (compiling, loading of
-;;      modules and files) as it does it.
-;; Dribble should be the pathname of the dribble file if you want to 
-;; dribble the compilation.
-;; Load-source-instead-of-binary is T to load .lisp instead of binary files.
-;; Version may be nil to signify no subdirectory,
-;; a symbol, such as alpha, beta, omega, :alpha, mark, which
-;; specifies a subdirectory of the root, or
-;; a string, which replaces the root.
-(defun operate-on-system (name operation &key force
-			       (version *version*)
-			       (test *oos-test*) (verbose *oos-verbose*)
-                               (load-source-instead-of-binary *load-source-instead-of-binary*)
-                               (load-source-if-no-binary *load-source-if-no-binary*) 
-			       (bother-user-if-no-binary *bother-user-if-no-binary*)
-			       dribble)
-  (when dribble (dribble dribble))
-  (when test (setq verbose t))
-  (when (null force);; defaults
-    (case operation
-      ((load :load) (setq force :all))
-      ((compile :compile) (setq force :new-source-and-dependents))))
-  ;; Some CL implementations have a variable called *compile-verbose*
-  (multiple-value-bind (*version-dir* *version-replace*) 
-      (translate-version version)
-    (let ((*load-verbose* nil);; CL implementations may uniformly default this to nil
-	  (*version* version)
-	  (*oos-verbose* verbose)
-	  (*oos-test* test)
-	  (*load-source-if-no-binary* load-source-if-no-binary)
-	  (*bother-user-if-no-binary* bother-user-if-no-binary)
-	  (*load-source-instead-of-binary* load-source-instead-of-binary)
-	  (system (get-system name)))
-      (unless system (error "Can't find system named ~A." name))
-      (unless (component-operation operation) (error "Operation ~A undefined." operation))
-      (operate-on-component system operation force)))
-  (when dribble (dribble)))
-
-(defun operate-on-component (component operation force &aux changed)
-  ;; Returns T if something changed and had to be compiled.
-  (let ((type (component-type component))
-	;; Use the correct package.
-	#+ignore(*package*
-		 (or (when (component-package component)
-		       (tell-user-generic (format nil "Using package ~A" 
-						  (component-package component)))
-		       (cond (*oos-test* *package*)
-			     (t (find-package (component-package component)))))
-		     *package*))
-)
-    (when (component-package component)
-      (tell-user-generic (format nil "Using package ~A" 
-				 (component-package component)))
-      (cond (*oos-test* *package*)
-	    (t (unless (find-package (component-package component))
-		 (require (component-package component)))
-	       (use-package (component-package component)))))
-
-    ;; Load any required systems
-    (when (eq type :system)
-      (operate-on-system-dependencies component))
-
-    ;; Do any initial actions
-    (when (component-initially-do component)
-      (tell-user-generic (format nil "Doing initializations for ~A"
-				 (component-name component)))
-      (or *oos-test*
-	  (eval (component-initially-do component))))
-
-    ;; Do operation and set changed flag if necessary.
-    (setq changed 
-	  (case type
-	    ((:file :private-file)
-	     (funcall (component-operation operation) component force))
-	    ((:module :system)
-	     (operate-on-components component operation force changed))))
-
-    ;; Do any final actions
-    (when (component-finally-do component)
-      (tell-user-generic (format nil "Doing finalizations for ~A"
-				 (component-name component)))
-      (or *oos-test*
-	  (eval (component-finally-do component))))
-
-    ;; Provide the loaded system
-    (when (eq type :system)
-      (tell-user-generic (format nil "Providing system ~A"
-				 (component-name component)))
-      (or *oos-test*
-	  (provide (canonicalize-system-name (component-name component))))))
-
-  ;; Return t if something changed in this component and hence had to be recompiled.
-  changed)
-
-(defun operate-on-system-dependencies (component)
-  (when *system-dependencies-delayed*
-    (dolist (system (component-depends-on component))
-      ;; For each system that this system depends on,
-      ;; runs require (my version) on that system to load it.
-      ;; Explores the system tree in a DFS manner.
-      (cond ((listp system)
-	     (tell-user-require-system 
-	      (cond ((and (null (car system)) (null (cadr system)))
-		     (caddr system))
-		    (t system))
-	      component)
-	     (or *oos-test* (require (car system) nil
-				     (eval (cadr system))
-				     (caddr system) 
-				     (or (car (cdddr system))
-					 *version*))))
-	    (t
-	     (tell-user-require-system system component)
-	     (or *oos-test* (require system))))
-      )))
-
-(defun operate-on-components (component operation force changed)
-  (with-tell-user (operation component)
-    (if (component-components component)
-	(dolist (module (component-components component))
-	  (when (operate-on-component module operation
-		  (cond ((and (some #'(lambda (dependent)
-					(member dependent changed))
-				    (component-depends-on module))
-			      (or (non-empty-listp force)
-				  (eq force :new-source-and-dependents)))
-			 ;; The component depends on a changed file 
-			 ;; and force agrees.
-			 (if (eq force :new-source-and-dependents)
-			     :new-source-all
-			   :all))
-			((and (non-empty-listp force)
-			      (member (component-name module) force
-				      :test #'string-equal :key #'string))
-			 ;; Force is a list of modules 
-			 ;; and the component is one of them.
-			 :all)
-			(t force)))
-	    (push module changed)))
-	(case operation
-	  ((compile :compile)
-	   (eval (component-compile-form component)))
-	  ((load :load)
-	   (eval (component-load-form component))))))
-  changed)
-
-;;; ********************************
-;;; Component Operations ***********
-;;; ********************************
-;;; Define :compile/compile and :load/load operations
-(component-operation :compile  'compile-and-load-operation)
-(component-operation 'compile  'compile-and-load-operation)
-(component-operation :load     'load-file-operation)
-(component-operation 'load     'load-file-operation)
-
-(defun compile-and-load-operation (component force)
-  (let ((changed (compile-file-operation component force)))
-    (load-file-operation component changed)
-    changed))
-
-(defun compile-file-operation (component force)
-  ;; Returns T if the file had to be compiled.
-  (let ((must-compile
-	 (or (find force '(:all :new-source-all t) :test #'eq) 
-	     (and (find force '(:new-source :new-source-and-dependents)
-			:test #'eq)
-		  (needs-compilation component)))))
-
-    (cond ((and must-compile
-		(probe-file (component-full-pathname component :source)))
-	   (with-tell-user ("Compiling source" component :source)
-	       (or *oos-test*
-		   (compile-file (component-full-pathname component :source)
-		       :output-file (component-full-pathname component :binary)
-		       #+CMU :error-file #+CMU (and *cmu-errors-to-file* 
-						    (component-full-pathname component :error))
-		       #+CMU :errors-to-terminal #+CMU *cmu-errors-to-terminal*
-		       )))
-	   must-compile)
-	  (must-compile
-	   (tell-user "Source file not found. Not compiling"
-		      component :source :no-dots :force)
-	   nil)
-	  (t nil))))
-
-(defun needs-compilation (component)
-  ;; If there is no binary, or it is older than the source
-  ;; file, then the component needs to be compiled.
-  ;; Otherwise we only need to recompile if it depends on a file that changed.
-  (or
-   ;; no binary
-   (null (probe-file (component-full-pathname component :binary))) 
-   ;; old binary
-   (< (file-write-date (component-full-pathname component :binary)) 
-      (file-write-date (component-full-pathname component :source)))))
-
-(defun load-file-operation (component force)
-  ;; Returns T if the file had to be loaded
-  (let ((load-source
-	 (or *load-source-instead-of-binary*
-	     (and (find force '(:new-source :new-source-and-dependents
-					    :new-source-all)
-			:test #'eq)
-		  (needs-compilation component))))
-	(load-binary
-	 (or (find force '(:all :new-source-all t) :test #'eq) ; Force load. 
-	     ;; :new-source* and binary up to date
-	     (find force '(:new-source :new-source-and-dependents)
-		   :test #'eq))))
-
-    (cond ((and load-source
-		(probe-file (component-full-pathname component :source)))
-	   (with-tell-user ("Loading source" component :source)
-	       (or *oos-test*
-		   (load (component-full-pathname component :source))))
-	   T)
-	  ((and load-binary 
-		(probe-file (component-full-pathname component :binary)))
-	   (with-tell-user ("Loading binary"   component :binary)
-	       (or *oos-test*
-		   (load (component-full-pathname component :binary))))
-	   T)
-	  ((and load-binary
-		(probe-file (component-full-pathname component :source))
-		(load-source-if-no-binary component))
-	   (with-tell-user ("Loading source"   component :source)
-	       (or *oos-test*
-		   (load (component-full-pathname component :source))))
-	   T)
-	  ((or load-source load-binary)
-	   (tell-user-no-files component :force)
-	   nil)
-	  (t nil))))
-
-	
-;; when the operation = :compile, we can assume the binary exists in test mode.
-;;	((and *oos-test*
-;;	      (eq operation :compile)
-;;	      (probe-file (component-full-pathname component :source)))
-;;	 (with-tell-user ("Loading binary"   component :binary)))
-
-(defun load-source-if-no-binary (component)
-  (and (not *load-source-instead-of-binary*)
-       (or *load-source-if-no-binary*
-	   (when *bother-user-if-no-binary*
-	     (let* ((prompt (prompt-string component))
-		    (load-source
-		     (y-or-n-p-wait-optional
-		      #\y 30
-		      "~A- Binary file ~A does not exist. ~
-                       ~&~A  Load source file ~A instead? "
-		      prompt
-		      (namestring (component-full-pathname component :binary))
-		      prompt
-		      (namestring (component-full-pathname component :source)))))
-	       (setq *bother-user-if-no-binary*
-		     (y-or-n-p-wait-optional 
-		      #\n 30
-		      "~A- Should I bother you if this happens again? "
-		      prompt ))
-	       (unless *bother-user-if-no-binary*
-		 (setq *load-source-if-no-binary* load-source))
-	       load-source)))))
-
-;;; ********************************
-;;; New Require ********************
-;;; ********************************
-(defun compute-system-path (module-name definition-pname)
-  (let* ((filename (format nil "~A.system" 
-			   (if (symbolp module-name)
-			       (string-downcase (string module-name))
-			     module-name))))
-    (or (when definition-pname		; given pathname for system def
-	  (probe-file definition-pname))
-	(probe-file filename)		; try current dir
-	(probe-file (append-directories *central-registry* filename))) ; central registry
-    ))
-
-(unless (fboundp 'old-require)
-  (setf (symbol-function 'old-require) (symbol-function 'lisp:require))
-
-  (let (#+:CCL (ccl:*warn-if-redefine-kernel* nil))
-    (defun lisp:require (module-name &optional pathname definition-pname
-				     default-action (version *version*)
-				     &aux system-path)
-      ;; If the pathname is present, this behaves like the old require.
-      (unless (and module-name 
-		   (find #-CMU (string module-name)
-			 #+CMU (string-downcase (string module-name))
-			 *modules* :test #'string=)) 
-	(cond (pathname
-	       (funcall 'old-require module-name pathname))
-	      ;; If the system is defined, load it.
-	      ((or (get-system module-name)
-		   (and (setq system-path 
-			      (compute-system-path module-name definition-pname))
-			(load system-path)
-			(get-system module-name)))
-	       (operate-on-system module-name :load
-				  :version version
-				  :test *oos-test*
-				  :verbose *oos-verbose*
-				  :load-source-if-no-binary *load-source-if-no-binary*
-				  :bother-user-if-no-binary *bother-user-if-no-binary*
-				  :load-source-instead-of-binary *load-source-instead-of-binary*))
-	      ;; If there's a default action, do it. This could be a progn which
-	      ;; loads a file that does everything. 
-	      ((and default-action
-		    (eval default-action)))
-	      ;; If no system definition file, try regular require.
-	      ((funcall 'old-require module-name pathname))
-	      ;; If no default action, print a warning or error message.
-	      (t
-	       (format t "~&Warning: System ~A doesn't seem to be defined..." module-name))
-	      )))))
-
-;;; ********************************
-;;; Allegro Make System Fasl *******
-;;; ********************************
-#+:excl
-(defun allegro-make-system-fasl (system destination)
-  (excl:shell
-   (format nil "rm -f ~A; cat~{ ~A~} > ~A" 
-	   destination
-	   (mapcar #'namestring
-		   (files-in-system system :all :binary)))))
-
-(defun files-which-need-compilation (system)
-  (mapcar #'(lambda (comp) (namestring (component-full-pathname comp :source)))
-	  (remove nil
-		  (file-components-in-component
-		   (get-system system) :new-source))))
-
-(defun files-in-system (name &optional (force :all) (type :source) version
-			     &aux system)
-  ;; Returns a list of the pathnames in system in load order.
-  (setq system (get-system name))
-  (unless system (error "Can't find system named ~A." name))
-  (multiple-value-bind (*version-dir* *version-replace*) 
-      (translate-version version)
-  (let ((*version* version))
-    (file-pathnames-in-component system type force))))
-
-(defun file-pathnames-in-component (component type &optional (force :all))
-  (mapcar #'(lambda (comp) (component-full-pathname comp type))
-	  (file-components-in-component component force)))
-
-(defun file-components-in-component (component &optional (force :all) 
-					       &aux result changed)
-  (case (component-type component)
-    ((:file :private-file)
-     (when (setq changed 
-		 (or (find force '(:all t) :test #'eq) 
-		     (and (not (non-empty-listp force))
-			  (needs-compilation component))))
-       (setq result
-	     (list component))))
-    ((:module :system)
-     (dolist (module (component-components component))
-       (multiple-value-bind (r c)
-	   (file-components-in-component 
-	    module 
-	    (cond ((and (some #'(lambda (dependent)
-				  (member dependent changed))
-			      (component-depends-on module))
-			(or (non-empty-listp force)
-			    (eq force :new-source-and-dependents)))
-		   ;; The component depends on a changed file and force agrees.
-		   :all)
-		  ((and (non-empty-listp force)
-			(member (component-name module) force
-				:test #'string-equal :key #'string))
-		   ;; Force is a list of modules and the component is one of them.
-		   :all)
-		  (t force)))
-	 (when c
-	   (push module changed)
-	   (setq result (append result r)))))))
-  (values result changed))
-
-(setf (symbol-function 'oos) (symbol-function 'operate-on-system))
-
-;;; *END OF FILE*
diff --git a/contrib/defsystem/defsystem.ps b/contrib/defsystem/defsystem.ps
deleted file mode 100644
index a6daf15fac2a874bfd015fd51e6c60e97d78258c..0000000000000000000000000000000000000000
--- a/contrib/defsystem/defsystem.ps
+++ /dev/null
@@ -1,1118 +0,0 @@
-%!PS-Adobe-1.0
-%%Title: defsystem.mss
-%%DocumentFonts: (atend)
-%%Creator: Mark Kantrowitz and Scribe 6(1600)
-%%CreationDate: 31 January 1990 12:40
-%%Pages: (atend)
-%%EndComments
-% PostScript Prelude for Scribe.
-/BS {/SV save def 0.0 792.0 translate .01 -.01 scale} bind def
-/ES {showpage SV restore} bind def
-/SC {setrgbcolor} bind def
-/FMTX matrix def
-/RDF {WFT SLT 0.0 eq 
-  {SSZ 0.0 0.0 SSZ neg 0.0 0.0 FMTX astore}
-  {SSZ 0.0 SLT neg sin SLT cos div SSZ mul SSZ neg 0.0 0.0 FMTX astore}
-  ifelse makefont setfont} bind def
-/SLT 0.0 def
-/SI { /SLT exch cvr def RDF} bind def
-/WFT /Courier findfont def
-/SF { /WFT exch findfont def RDF} bind def
-/SSZ 1000.0 def
-/SS { /SSZ exch 100.0 mul def RDF} bind def
-/AF { /WFT exch findfont def /SSZ exch 100.0 mul def RDF} bind def
-/MT /moveto load def
-/XM {currentpoint exch pop moveto} bind def
-/UL {gsave newpath moveto dup 2.0 div 0.0 exch rmoveto
-   setlinewidth 0.0 rlineto stroke grestore} bind def
-/LH {gsave newpath moveto setlinewidth
-   0.0 rlineto
-   gsave stroke grestore} bind def
-/LV {gsave newpath moveto setlinewidth
-   0.0 exch rlineto
-   gsave stroke grestore} bind def
-/BX {gsave newpath moveto setlinewidth
-   exch
-   dup 0.0 rlineto
-   exch 0.0 exch neg rlineto
-   neg 0.0 rlineto
-   closepath
-   gsave stroke grestore} bind def
-/BX1 {grestore} bind def
-/BX2 {setlinewidth 1 setgray stroke grestore} bind def
-/PB {/PV save def newpath translate
-    100.0 -100.0 scale pop /showpage {} def} bind def
-/PE {PV restore} bind def
-/GB {/PV save def newpath translate rotate
-    div dup scale 100.0 -100.0 scale /showpage {} def} bind def
-/GE {PV restore} bind def
-/FB {dict dup /FontMapDict exch def begin} bind def
-/FM {cvn exch cvn exch def} bind def
-/FE {end /original-findfont /findfont load def  /findfont
-   {dup FontMapDict exch known{FontMapDict exch get} if
-   original-findfont} def} bind def
-/BC {gsave moveto dup 0 exch rlineto exch 0 rlineto neg 0 exch rlineto closepath clip} bind def
-/EC /grestore load def
-/SH /show load def
-/MX {exch show 0.0 rmoveto} bind def
-/W {0 32 4 -1 roll widthshow} bind def
-/WX {0 32 5 -1 roll widthshow 0.0 rmoveto} bind def
-%%EndProlog
-%%Page: 1 1
-BS
-0 SI
-15 /Helvetica-Bold AF
-11090 8294 MT
-(Defsystem: A Portable Make Facility for Common Lisp)SH
-13 SS 
-24641 15620 MT
-(by Mark Kantrowitz)SH
-21752 19236 MT
-(School of Computer Science)SH
-22256 22852 MT
-(Carnegie Mellon University)SH
-26480 26468 MT
-(January 1990)SH
-12 SS 
-7200 32344 MT
-(Introduction)SH
-10 /Helvetica AF
-7200 35777 MT
-(This document describes the defsystem system definition macro, a portable "Make" facility for)
-87 W( Common)86 W
-7200 37297 MT
-(Lisp.)SH
-7200 40793 MT
-(Support is provided for organizing systems into hierarchical layers of modules, with matching directory)133 W
-7200 42313 MT
-(structure. Moreover, the components of the system may be listed in any order)
-49 W( the user desires, because)48 W
-7200 43833 MT
-(the defsystem command reorganizes them according)
-69 W( to the file-dependency constraints specified by the)70 W
-7200 45353 MT
-(user. Since it accomplishes this by performing a topological sort of the constraint-graph,)
-351 W( cyclical)350 W
-7200 46873 MT
-(dependencies are not supported \050the graph must be a DAG\051.)SH
-7200 50369 MT
-(Only two operations, compile and load, are currently defined. The)
-87 W( interface for defining new operations,)88 W
-7200 51889 MT
-(however, is simple and extendible.)SH
-7200 55385 MT
-(Though home-grown, the syntax was inspired by fond)
-108 W( memories of the defsystem facility on Symbolics)107 W
-7200 56905 MT
-(3600 series lisp)
-100 W( machines. The exhaustive lists of filename extensions for various lisps and the idea to)101 W
-7200 58425 MT
-(have one)240 W
-/Helvetica-Oblique SF
-12072 XM
-(operate-on-system)SH
-/Helvetica SF
-20925 XM
-(function instead of separate)239 W
-/Helvetica-Oblique SF
-34444 XM
-(compile-system)SH
-/Helvetica SF
-41906 XM
-(and)SH
-/Helvetica-Oblique SF
-44091 XM
-(load-system)SH
-/Helvetica SF
-49998 XM
-(functions)SH
-7200 59945 MT
-(were taken from Xerox Corporation's PCL \050Portable Common Loops\051 system.)SH
-7200 63441 MT
-(The code for the defsystem facility and this documentation may be found in the files)SH
-11648 65030 MT
-(/afs/cs.cmu.edu/user/mkant/Defsystem/defsystem.{text,lisp})SH
-7200 68526 MT
-(Please send bug reports, comments and suggestions to mkant@cs.cmu.edu.)SH
-ES
-%%Page: 2 2
-BS
-0 SI
-10 /Helvetica-Bold AF
-30322 4329 MT
-(2)SH
-12 SS 
-7200 8075 MT
-(Using the System)SH
-10 /Helvetica AF
-7200 11508 MT
-(To use this system,)SH
-9424 12909 MT
-(1.)SH
-10536 XM
-(If you want to have a central)
-55 W( directory where system definition files will be kept, modify the)56 W
-10536 14052 MT
-(value of *central-registry* in defsystem.lisp to be the pathname of that directory.)SH
-9424 15867 MT
-(2.)SH
-10536 XM
-(Save and load the file defsystem.lisp)SH
-9424 17682 MT
-(3.)SH
-10536 XM
-(Load the)
-235 W( file containing the defsystem form defining your system. If the name of your)234 W
-10536 18825 MT
-(system is foo, the)
-43 W( file will be named "foo.system".  [If you are going to load the system and)44 W
-10536 19968 MT
-(not compile it, you can use \050require "foo"\051)
-10 W( to load it if the definition file is in either the current)9 W
-10536 21111 MT
-(directory or the central registry.])SH
-9424 22926 MT
-(4.)SH
-10536 XM
-(Use the function)60 W
-/Helvetica-Oblique SF
-18220 XM
-(operate-on-system)SH
-/Helvetica SF
-26894 XM
-(to do things to your system.)
-60 W( For example \050operate-on-)61 W
-10536 24069 MT
-(system "foo" 'load\051 will load the system, while \050operate-on-system "foo" 'compile\051 will)306 W
-10536 25212 MT
-(compile it.)SH
-12 /Helvetica-Bold AF
-7200 29013 MT
-(External Interface)SH
-10 /Helvetica AF
-7200 32446 MT
-(The external interface to)
-226 W( the defsystem facility are the defsystem macro and the operate-on-system)227 W
-7200 33966 MT
-(function. Defsystem is used to define a new system and operate-on-system)
-43 W( to compile it and load it. The)42 W
-7200 35486 MT
-(definition of require has been modified to mesh well with systems)
-104 W( defined using defsystem, and is fully)105 W
-7200 37006 MT
-(backward-compatible.)SH
-7200 40502 MT
-(In addition, the function)
-107 W( afs-binary-directory has been provided for immitating the behavior of the @sys)106 W
-7200 42022 MT
-(feature of the Andrew File System on systems not)
-123 W( running AFS. The @sys feature allows soft links to)124 W
-7200 43542 MT
-(point to different directories depending on)
-86 W( which platform is accessing the files. A common setup would)85 W
-7200 45062 MT
-(be to have the bin directory soft linked to .bin/@sys and to have subdirectories of .bin corresponding)
-84 W( to)85 W
-7200 46582 MT
-(each platform \050.bin/vax_mach, .bin/unix, .bin/pmax_mach, etc.\051. The afs-binary-directory)
-81 W( function returns)80 W
-7200 48102 MT
-(the appropriate binary directory for use as the :binary-pathname)
-99 W( argument in the defsystem macro. For)100 W
-7200 49622 MT
-(example, if we evaluate \050afs-binary-directory)
-220 W( "foodir/"\051 on a vax running the Mach operating system,)219 W
-7200 51142 MT
-("foodir/.bin/vax_mach/" would be returned.)SH
-12 /Helvetica-Bold AF
-7200 54485 MT
-(Defining Systems with Defsystem)SH
-10 /Helvetica AF
-7200 57918 MT
-(A system is a set of components with associated properties. These properties include the type,)
-126 W( name,)127 W
-7200 59438 MT
-(source and binary pathnames,)
-523 W( package, component-dependencies, initializations, and a set of)522 W
-7200 60958 MT
-(components.)SH
-7200 64454 MT
-(Components may be of three types: :system, :module, or)
-259 W( :file.  Components of type :system have)260 W
-7200 65974 MT
-(absolute pathnames and are used to define a multi-system system. The)
-93 W( toplevel system defined by the)92 W
-7200 67494 MT
-(defsystem macro)
-174 W( is implicitly of type :system. Components of type :module have pathnames that are)175 W
-7200 69014 MT
-(relative to their containing system or module,)
-89 W( and may contain a set of files and modules. This enables)88 W
-7200 70534 MT
-(one to define subsystems, subsubsystems, submodules, and so on.)SH
-ES
-%%Page: 3 3
-BS
-0 SI
-10 /Helvetica-Bold AF
-30322 4329 MT
-(3)SH
-/Helvetica SF
-7200 7929 MT
-(Foreign systems \050systems defined using some other system definition tool\051, may be)
-16 W( included by providing)17 W
-7200 9449 MT
-(separate compile and load forms for them \050using)
-189 W( the :compile-form and :load-form keywords\051. These)188 W
-7200 10969 MT
-(forms will be run if and only if they are included in)
-33 W( a module with no components. [In some future version)34 W
-7200 12489 MT
-(of the defsystem)
-120 W( facility there will be new component types corresponding to each possible operation.])119 W
-7200 14009 MT
-(This is useful if it isn't possible to convert these systems to the defsystem format all at once.)SH
-7200 17505 MT
-(The name of a component may be a symbol or a string. For ease of access the definition)
-29 W( of a system \050its)30 W
-7200 19025 MT
-(component\051 is stored under the system properties of the symbol corresponding to its uppercase name.)
-28 W( If)332 W
-7200 20545 MT
-(the system name is a symbol, for all other purposes the name is converted to)
-34 W( a lowercase string \050system)35 W
-7200 22065 MT
-(names that are strings are left alone\051. It is usually best to)
-20 W( use the string version of a system's name when)19 W
-7200 23585 MT
-(defining or referring to it. A system defined as 'foo will)
-16 W( have an internal name of "foo" and will be stored in)17 W
-7200 25105 MT
-(the file "foo.system". A system defined as "Foo" will have an internal name of "Foo" and)
-52 W( will be stored in)51 W
-7200 26625 MT
-(the file "Foo.system".)SH
-7200 30121 MT
-(The absolute \050for components of type :system\051 and relative)
-70 W( \050for all other components\051 pathnames of the)71 W
-7200 31641 MT
-(binary and source files may be specified using the :source-pathname and :binary-pathname keywords in)60 W
-7200 33161 MT
-(the component definition. The pathnames associated with a module correspond to subdirectories of the)94 W
-7200 34681 MT
-(containing module or system. If)
-86 W( no binary pathname is specified, the binaries are distributed among the)85 W
-7200 36201 MT
-(sources. If no source pathname is given for a component, it defaults to the name of the)
-9 W( component. Since)10 W
-7200 37721 MT
-(the names are converted to lowercase, pathnames must be provided for each component if)
-26 W( the operating)25 W
-7200 39241 MT
-(system is)
-244 W( case sensitive \050unless the pathnames are all lowercase\051. Similarly, if a module does not)245 W
-7200 40761 MT
-(correspond to a subdirectory, a null-string pathname \050""\051 must be provided.)SH
-7200 44257 MT
-(File types \050e.g., "lisp" and "fasl"\051 for source and binary files may be specified using the)
-40 W( :source-extension)39 W
-7200 45777 MT
-(and :binary-extension keywords. If)
-27 W( these are not specified or given as nil, the makes a reasonable choice)28 W
-7200 47297 MT
-(of defaults based on the machine type and underlying operating system. These)
-28 W( file types are inherited by)27 W
-7200 48817 MT
-(the components of the system.)SH
-7200 52313 MT
-(At system definition time, every relative directory is replaced with the corresponding cumulative)
-103 W( relative)104 W
-7200 53833 MT
-(pathname with all the components incorporated.)SH
-7200 57329 MT
-(One may also specify the package)
-219 W( to be used and any initializations and finalizations. Initializations)218 W
-7200 58849 MT
-(\050specified with the keyword :initially-do\051 are)
-210 W( evaluated before the system is loaded or compiled, and)211 W
-7200 60369 MT
-(finalizations \050specified with the keyword :finally-do\051 are evaluated after)
-92 W( the system is finished loading or)91 W
-7200 61889 MT
-(compiling. The argument to the keyword is a form which is evaluated. Multiple forms may be evaluated)
-10 W( by)11 W
-7200 63409 MT
-(wrapping a progn around the forms.)SH
-7200 66905 MT
-(The components of a system, module or file are specified with the :components keyword, and are)
-14 W( defined)13 W
-7200 68425 MT
-(in a manner analogous to the way in which a system is defined.)SH
-7200 71921 MT
-(The dependencies of a system, module or file are specified with the :depends-on keyword,)
-45 W( followed by a)46 W
-ES
-%%Page: 4 4
-BS
-0 SI
-10 /Helvetica-Bold AF
-30322 4329 MT
-(4)SH
-/Helvetica SF
-7200 7929 MT
-(list of the names of the components the system, module)
-56 W( or file depends on. The components referred to)55 W
-7200 9449 MT
-(must exist at the same level of the hierarchy as the referring component.  This enforces the modularity of)31 W
-7200 10969 MT
-(the defined system. If module A depends on a file)
-25 W( contained within module B, then module A depends on)24 W
-7200 12489 MT
-(module B)
-175 W( and should be specified as such. Any other use would make a mockery of the concept of)176 W
-7200 14009 MT
-(modularity. This requirement is not enforced in the software, but)
-216 W( any use contrary to it will produce)215 W
-7200 15529 MT
-(unpredictable results.)SH
-7200 19025 MT
-(Thus the only requirement in how the files are organized is that at the)
-8 W( level of each module or system, the)9 W
-7200 20545 MT
-(dependency graph)
-312 W( of the components must be a DAG \050directed)311 W
-/Helvetica-Bold SF
-38659 XM
-(acyclic)SH
-/Helvetica SF
-42584 XM
-(graph\051. If there are any)311 W
-7200 22065 MT
-(dependency cycles \050i.e., module A uses definitions from module)
-96 W( B, and module B uses definitions from)97 W
-7200 23585 MT
-(module A\051, the defsystem macro will not be)
-48 W( able to compute a total ordering of the files \050a linear order in)47 W
-7200 25105 MT
-(which they should be compiled and loaded\051. Usually the defsystem will detect such cycles and halt)
-80 W( with)81 W
-7200 26625 MT
-(an error.)SH
-7200 30121 MT
-(If no dependencies are provided for the system, modules and files, it may load them in)
-229 W( any order.)228 W
-7200 31641 MT
-(Currently, however, it loads them in serial order. In a future version of defsystem this will)
-233 W( probably)234 W
-7200 33161 MT
-(become a supported feature. [In other words, this)
-56 W( feature hasn't been tested to make sure that they files)55 W
-7200 34681 MT
-(are not)
-2 W( accidentally loaded in the opposite order in some cases. It all depends on whether the definition of)3 W
-7200 36201 MT
-(topological-sort used is a stable sort or not.])SH
-7200 39697 MT
-(The basic algorithm used is to topologically sort the DAG at each level)
-195 W( of abstraction \050system level,)194 W
-7200 41217 MT
-(module level, submodule)
-45 W( level, etc.\051 to insure that the system's files are compiled and loaded in the right)46 W
-7200 42737 MT
-(order. This occurs at system)
-86 W( definition time, rather than at system use time, since it probably saves the)85 W
-7200 44257 MT
-(user some time.)SH
-12 /Helvetica-Bold AF
-7200 47600 MT
-(BNF for Components)SH
-10 /Helvetica AF
-7200 51033 MT
-(The general format of a component's definition is:)SH
-/Courier-Bold SF
-7200 52838 MT
-(<definition> ::= \050<type> <name> [:host <host>] [:device <device>])SH
-26400 53969 MT
-([:source-pathname <pathname>])SH
-26400 55100 MT
-([:source-extension <extension>])SH
-26400 56231 MT
-([:binary-pathname <pathname>])SH
-26400 57362 MT
-([:binary-extension <extension>])SH
-26400 58493 MT
-([:package <package>])SH
-26400 59624 MT
-([:initially-do <form>])SH
-26400 60755 MT
-([:finally-do <form>])SH
-26400 61886 MT
-([:components \050<definition>*\051])SH
-26400 63017 MT
-([:depends-on \050<name>*\051])SH
-26400 64148 MT
-([:compile-form <form>])SH
-26400 65279 MT
-([:load-form <form>]\051)SH
-7200 66410 MT
-(<type> ::= :system | :module | :file)SH
-/Helvetica SF
-7200 69906 MT
-(The toplevel defsystem form substitutes defsystem for :system.)SH
-ES
-%%Page: 5 5
-BS
-0 SI
-10 /Helvetica-Bold AF
-30322 4329 MT
-(5)SH
-12 SS 
-7200 8075 MT
-(Using Systems with Operate-on-System)SH
-10 /Helvetica AF
-7200 11508 MT
-(The function operate-on-system is used)
-166 W( to compile or load a system, or do any other operation on a)167 W
-7200 13028 MT
-(system. At present only compile and load operations are defined, but other operations such as edit,)200 W
-7200 14548 MT
-(hardcopy, or applying arbitrary functions \050e.g., enscript, lpr\051 to every file in the system)
-125 W( could be added)126 W
-7200 16068 MT
-(easily.)SH
-7200 19564 MT
-(The syntax of operate-on-system is as follows:)SH
-/Helvetica-Bold SF
-7200 23060 MT
-(OPERATE-ON-SYSTEM)SH
-/Helvetica-Oblique SF
-18640 XM
-(system-name operation)50 W
-/Helvetica SF
-29466 XM
-(&key)SH
-/Helvetica-Oblique SF
-32017 XM
-(force test)
-50 W( verbose dribble load-source-instead-of-)49 W
-7200 24580 MT
-(binary load-source-if-no-binary bother-user-if-no-binary)SH
-/Symbol SF
-9242 26052 MT
-(\267)SH
-/Helvetica-Bold SF
-9980 XM
-(system-name)SH
-/Helvetica SF
-16649 XM
-(is the name of the system and may be a symbol or string.)SH
-/Symbol SF
-9242 27867 MT
-(\267)SH
-/Helvetica-Bold SF
-9980 XM
-(operation)SH
-/Helvetica SF
-14940 XM
-(is 'compile \050or :compile\051 or 'load \050or :load\051 or any new operation)
-126 W( defined by the)127 W
-9980 29010 MT
-(user.)SH
-/Symbol SF
-9242 30825 MT
-(\267)SH
-/Helvetica-Bold SF
-9980 XM
-(force)SH
-/Helvetica SF
-12703 XM
-(determines what files are operated on:)SH
-7 /Symbol AF
-12160 32076 MT
-(\267)SH
-10 /Helvetica-Oblique AF
-12760 32226 MT
-(:all)SH
-/Helvetica SF
-14316 XM
-(\050or T\051 specifies that all files in the system should be used)SH
-7 /Symbol AF
-12160 33891 MT
-(\267)SH
-10 /Helvetica-Oblique AF
-12760 34041 MT
-(:new-source)SH
-/Helvetica SF
-18573 XM
-(If the operation is 'compile, compiles only those files whose sources are)88 W
-12760 35184 MT
-(more recent than the binaries. If the operation is)
-114 W( 'load, loads the source if it is more)115 W
-12760 36327 MT
-(recent than the binaries. This allows you to load the most up)
-139 W( to date version of the)138 W
-12760 37470 MT
-(system even if it isn't compiled.)SH
-7 /Symbol AF
-12160 39135 MT
-(\267)SH
-10 /Helvetica-Oblique AF
-12760 39285 MT
-(:new-sources-and-dependents)SH
-/Helvetica SF
-26688 XM
-(uses all files used by :new-source,)
-144 W( plus any files that)145 W
-12760 40428 MT
-(depend on the those files or their dependents \050recursively\051.)SH
-7 /Symbol AF
-12160 42093 MT
-(\267)SH
-10 /Helvetica AF
-12760 42243 MT
-(Force may also be a list)
-289 W( of the specific modules or files to be used \050plus their)288 W
-12760 43386 MT
-(dependents\051.)SH
-9980 44787 MT
-(The default for 'load is :all and for 'compile is :new-source-and-dependents.)SH
-/Symbol SF
-9242 46602 MT
-(\267)SH
-/Helvetica-Bold SF
-9980 XM
-(version)SH
-/Helvetica SF
-13989 XM
-(indicates which version of the system should be used. If nil, then the usual root)174 W
-9980 47745 MT
-(directory is)
-101 W( used. If a symbol, such as 'alpha, 'beta, 'omega, :alpha, or 'mark, it substitutes)100 W
-9980 48888 MT
-(the appropriate)
-19 W( \050lowercase\051 subdirectory of the root directory for the root directory. If a string,)20 W
-9980 50031 MT
-(it replaces the entire root directory with the given directory. \050default *version*, which is nil\051)SH
-/Symbol SF
-9242 51846 MT
-(\267)SH
-/Helvetica-Bold SF
-9980 XM
-(verbose)SH
-/Helvetica SF
-14146 XM
-(is T to print out what it is doing)
-53 W( \050compiling, loading of modules and files\051 as it does)52 W
-9980 52989 MT
-(it. \050default nil\051)SH
-/Symbol SF
-9242 54804 MT
-(\267)SH
-/Helvetica-Bold SF
-9980 XM
-(test)SH
-/Helvetica SF
-12051 XM
-(is T)
-15 W( to print out what it would do without actually doing it.  If test is T it automatically sets)16 W
-9980 55947 MT
-(verbose to T. \050default nil\051)SH
-/Symbol SF
-9242 57762 MT
-(\267)SH
-/Helvetica-Bold SF
-9980 XM
-(dribble)SH
-/Helvetica SF
-13873 XM
-(should be the pathname of a dribble file if you want to keep a record of)
-281 W( the)280 W
-9980 58905 MT
-(compilation. \050default nil\051)SH
-/Symbol SF
-9242 60720 MT
-(\267)SH
-/Helvetica-Bold SF
-9980 XM
-(load-source-instead-of-binary)SH
-/Helvetica SF
-24392 XM
-(is T to force)
-21 W( the system to load source files instead of binary)22 W
-9980 61863 MT
-(files. \050default nil\051)SH
-/Symbol SF
-9242 63678 MT
-(\267)SH
-/Helvetica-Bold SF
-9980 XM
-(load-source-if-no-binary)SH
-/Helvetica SF
-22022 XM
-(is T to have the)
-263 W( system load source files if the binary file is)262 W
-9980 64821 MT
-(missing. \050default nil\051)SH
-/Symbol SF
-9242 66636 MT
-(\267)SH
-/Helvetica-Bold SF
-9980 XM
-(bother-user-if-no-binary)SH
-/Helvetica SF
-21818 XM
-(is T to)
-171 W( have the system bother the user about missing binaries)172 W
-9980 67779 MT
-(before it goes ahead and loads them if load-source-if-no-binary is T. \050default)
-67 W( t\051 Times out in)66 W
-9980 68922 MT
-(60 seconds unless *use-timeouts* is set to nil.)SH
-ES
-%%Page: 6 6
-BS
-0 SI
-10 /Helvetica-Bold AF
-30322 4329 MT
-(6)SH
-/Helvetica SF
-7200 7929 MT
-(An implicit assumption is that if we need to)
-10 W( load a file for some reason, then we should be able to compile)11 W
-7200 9449 MT
-(it immediately before we need to)
-138 W( load it. This obviates the need to specify separate load and compile)137 W
-7200 10969 MT
-(dependencies in the modules.)SH
-7200 14465 MT
-(Files which must not)
-117 W( be compiled should be loaded in the initializations or finalizations of a module by)118 W
-7200 15985 MT
-(means of an explicit load form.)SH
-7200 19481 MT
-(Note that under this assumption, the example given)
-207 W( in the PCL defsystem becomes quite ludicrous.)206 W
-7200 21001 MT
-(Those constraints are of the form:)SH
-9424 22402 MT
-(1.)SH
-10536 XM
-(C must be loaded before A&B are loaded)SH
-9424 24217 MT
-(2.)SH
-10536 XM
-(A&B must be loaded before C is compiled)SH
-7200 25737 MT
-(When you add in the reasonable assumption that before you load C, you must compile C, you get a cycle.)SH
-7200 29233 MT
-(The only case is which this might not be true is in a system which worked on)
-86 W( the dependency graph of)87 W
-7200 30753 MT
-(individual definitions. But we have restricted)
-112 W( ourselves to file dependencies and will stick with that.  \050In)111 W
-7200 32273 MT
-(situations where a file defining macros must have the sources loaded before compiling them, most often)
-7 W( it)8 W
-7200 33793 MT
-(is because the macros are used before they are defined, and)
-82 W( hence assumed to be functions. This can)81 W
-7200 35313 MT
-(be fixed by organizing the macros better, or including them in a separate file.\051)SH
-12 /Helvetica-Bold AF
-7200 38656 MT
-(Defining New Operations)SH
-10 /Helvetica AF
-7200 42089 MT
-(To define a new)
-203 W( operation, write a function with parameters component and force that performs the)204 W
-7200 43609 MT
-(operation. The)
-82 W( function component-pathname may be used to extract the source and binary pathnames)81 W
-7200 45129 MT
-(from the component. [Component-pathname takes parameters component and file-type,)
-10 W( where file-type is)11 W
-7200 46649 MT
-(either :source or :binary,)
-120 W( and returns the appropriate pathname.] If the component has "changed" as a)119 W
-7200 48169 MT
-(result of the operation, T should)
-3 W( be returned; otherwise nil. See the definition of compile-file-operation and)4 W
-7200 49689 MT
-(load-file-operation for examples.)SH
-7200 53185 MT
-(Then install the definition using component-operation, which takes as)
-99 W( parameters the symbol which will)98 W
-7200 54705 MT
-(be used)
-58 W( to name the operation in operate-on-system, and the name of the function. For example, here's)59 W
-7200 56225 MT
-(the definition of the 'compile and :compile operations:)SH
-/Courier-Bold SF
-13200 58030 MT
-(\050component-operation :compile  'compile-and-load-operation\051)SH
-13200 59161 MT
-(\050component-operation 'compile  'compile-and-load-operation\051)SH
-/Helvetica SF
-7200 61021 MT
-(Eventually this system will include portable definitions of 'hardcopy and 'edit.)SH
-12 /Helvetica-Bold AF
-7200 64364 MT
-(Changes to Require)SH
-10 /Helvetica AF
-7200 67797 MT
-(This defsystem interacts smoothly)
-138 W( with the require and provide facilities of Common Lisp. Operate-on-)137 W
-7200 69317 MT
-(system automatically provides the name of any system it loads, and uses the new definition of)
-49 W( require to)50 W
-7200 70837 MT
-(load any dependencies of the toplevel system.)SH
-ES
-%%Page: 7 7
-BS
-0 SI
-10 /Helvetica-Bold AF
-30322 4329 MT
-(7)SH
-/Helvetica SF
-7200 7929 MT
-(To facilitate this, three new optional arguments have been added)
-174 W( to require. Thus the new syntax of)173 W
-7200 9449 MT
-(require is as follows:)SH
-/Helvetica-Bold SF
-7200 12945 MT
-(REQUIRE)SH
-/Helvetica-Oblique SF
-12034 XM
-(system-name)SH
-/Helvetica SF
-18313 XM
-(&optional)SH
-/Helvetica-Oblique SF
-22760 XM
-(pathname definition-pname default-action version)SH
-/Helvetica SF
-7200 16441 MT
-(If pathname is provided, the new require behaves just like the old)
-46 W( definition. Otherwise it first tries to find)47 W
-7200 17961 MT
-(the definition of the system-name \050if it is not already defined it will load the definition file if it is in the)143 W
-7200 19481 MT
-(current-directory, the central-registry directory, or the directory specified by definition-pname\051 and)
-147 W( runs)148 W
-7200 21001 MT
-(operate-on-system on the system definition. If no definition is to be found, it)
-160 W( will evaluate the default-)159 W
-7200 22521 MT
-(action if there)
-52 W( is one. Otherwise it will try running the old definition of require on just the system name. If)53 W
-7200 24041 MT
-(all else fails, it will print out a warning.)SH
-12 /Helvetica-Bold AF
-7200 27384 MT
-(A Sample System Definition and Its Use)SH
-10 /Helvetica AF
-7200 30817 MT
-(Here's a system definition for the files in the following directory structure:)SH
-/Courier-Bold SF
-8400 32622 MT
-(% du -a test)SH
-8400 33753 MT
-(1 test/fancy/macros.lisp)3600 W
-8400 34884 MT
-(1 test/fancy/primitives.lisp)3600 W
-8400 36015 MT
-(3 test/fancy)3600 W
-8400 37146 MT
-(1 test/macros.lisp)3600 W
-8400 38277 MT
-(1 test/primitives.lisp)3600 W
-8400 39408 MT
-(1 test/graphics/macros.lisp)3600 W
-8400 40539 MT
-(1 test/graphics/primitives.lisp)3600 W
-8400 41670 MT
-(3 test/graphics)3600 W
-8400 42801 MT
-(1 test/os/macros.lisp)3600 W
-8400 43932 MT
-(1 test/os/primitives.lisp)3600 W
-8400 45063 MT
-(3 test/os)3600 W
-8400 46194 MT
-(12 test)3000 W
-8400 49587 MT
-(\050defsystem test)SH
-9600 50718 MT
-(:source-pathname "/afs/cs.cmu.edu/user/mkant/Defsystem/test/")SH
-9600 51849 MT
-(:source-extension "lisp")SH
-9600 52980 MT
-(:binary-pathname nil)SH
-9600 54111 MT
-(:binary-extension nil)SH
-9600 55242 MT
-(:components \050\050:module basic)SH
-22800 56373 MT
-(:source-pathname "")SH
-22800 57504 MT
-(:components \050\050:file "primitives"\051)SH
-30600 58635 MT
-(\050:file "macros")SH
-34800 59766 MT
-(:depends-on \050"primitives"\051\051\051\051)SH
-17400 60897 MT
-(\050:module graphics)SH
-22800 62028 MT
-(:source-pathname "graphics")SH
-22800 63159 MT
-(:components \050\050:file "macros")SH
-34800 64290 MT
-(:depends-on \050"primitives"\051\051)SH
-30600 65421 MT
-(\050:file "primitives"\051\051)SH
-22800 66552 MT
-(:depends-on \050basic\051\051)SH
-17400 67683 MT
-(\050:module fancy-stuff)SH
-22800 68814 MT
-(:source-pathname "fancy")SH
-22800 69945 MT
-(:components \050\050:file "macros")SH
-34800 71076 MT
-(:depends-on \050"primitives"\051\051)SH
-ES
-%%Page: 8 8
-BS
-0 SI
-10 /Helvetica-Bold AF
-30322 4329 MT
-(8)SH
-/Courier-Bold SF
-30600 7874 MT
-(\050:file "primitives"\051\051)SH
-22800 9005 MT
-(:depends-on \050graphics operating-system\051\051)SH
-17400 10136 MT
-(\050:module operating-system)SH
-22800 11267 MT
-(:source-pathname "os")SH
-22800 12398 MT
-(:components \050\050:file "primitives"\051)SH
-30600 13529 MT
-(\050:file "macros")SH
-34800 14660 MT
-(:depends-on \050"primitives"\051\051\051)SH
-22800 15791 MT
-(:depends-on \050basic\051\051\051)SH
-9600 16922 MT
-(:depends-on nil\051)SH
-8400 19184 MT
-(<cl> \050operate-on-system 'test 'compile :verbose t\051)SH
-8400 21446 MT
-(; -)
-600 W( Compiling system "test")SH
-8400 22577 MT
-(; -)
-1800 W( Compiling module "basic")SH
-8400 23708 MT
-(; -)
-3000 W( Compiling source file)SH
-8400 24839 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/primitives.lisp")4200 W
-8400 25970 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 27101 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/primitives.fasl")4200 W
-8400 28232 MT
-(; -)
-3000 W( Compiling source file)SH
-8400 29363 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/macros.lisp")4200 W
-8400 30494 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 31625 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/macros.fasl")4200 W
-8400 32756 MT
-(; -)
-1800 W( Compiling module "graphics")SH
-8400 33887 MT
-(; -)
-3000 W( Compiling source file)SH
-8400 35018 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/primitives.lisp)4200 W
-8400 36149 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 37280 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/primitives.fasl)4200 W
-8400 38411 MT
-(; -)
-3000 W( Compiling source file)SH
-8400 39542 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/macros.lisp")4200 W
-8400 40673 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 41804 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/macros.fasl")4200 W
-8400 42935 MT
-(; -)
-1800 W( Compiling module "operating-system")SH
-8400 44066 MT
-(; -)
-3000 W( Compiling source file)SH
-8400 45197 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/primitives.lisp")4200 W
-8400 46328 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 47459 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/primitives.fasl")4200 W
-8400 48590 MT
-(; -)
-3000 W( Compiling source file)SH
-8400 49721 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/macros.lisp")4200 W
-8400 50852 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 51983 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/macros.fasl")4200 W
-8400 53114 MT
-(; -)
-1800 W( Compiling module "fancy-stuff")SH
-8400 54245 MT
-(; -)
-3000 W( Compiling source file)SH
-8400 55376 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/primitives.lisp")4200 W
-8400 56507 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 57638 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/primitives.fasl")4200 W
-8400 58769 MT
-(; -)
-3000 W( Compiling source file)SH
-8400 59900 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/macros.lisp")4200 W
-8400 61031 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 62162 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/macros.fasl")4200 W
-8400 63293 MT
-(; -)
-600 W( Providing system test)SH
-8400 64424 MT
-(NIL)SH
-8400 66686 MT
-(<cl> \050operate-on-system 'test 'load :verbose t\051)SH
-8400 68948 MT
-(; -)
-600 W( Loading system "test")SH
-8400 70079 MT
-(; -)
-1800 W( Loading module "basic")SH
-8400 71210 MT
-(; -)
-3000 W( Loading binary file)SH
-ES
-%%Page: 9 9
-BS
-0 SI
-10 /Helvetica-Bold AF
-30322 4329 MT
-(9)SH
-/Courier-Bold SF
-8400 7874 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/primitives.fasl")4200 W
-8400 9005 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 10136 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/macros.fasl")4200 W
-8400 11267 MT
-(; -)
-1800 W( Loading module "graphics")SH
-8400 12398 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 13529 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/primitives.fasl)4200 W
-8400 14660 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 15791 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/graphics/macros.fasl")4200 W
-8400 16922 MT
-(; -)
-1800 W( Loading module "operating-system")SH
-8400 18053 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 19184 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/primitives.fasl")4200 W
-8400 20315 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 21446 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/os/macros.fasl")4200 W
-8400 22577 MT
-(; -)
-1800 W( Loading module "fancy-stuff")SH
-8400 23708 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 24839 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/primitives.fasl")4200 W
-8400 25970 MT
-(; -)
-3000 W( Loading binary file)SH
-8400 27101 MT
-(; "/afs/cs.cmu.edu/user/mkant/Defsystem/test/fancy/macros.fasl")4200 W
-8400 28232 MT
-(; -)
-600 W( Providing system test)SH
-8400 29363 MT
-(NIL)SH
-12 /Helvetica-Bold AF
-7200 33623 MT
-(Miscellaneous Notes)SH
-10 /Helvetica AF
-7200 37056 MT
-(Macintosh pathnames are)
-27 W( not fully supported at this time because of irregularities in the Allegro Common)26 W
-7200 38576 MT
-(Lisp definition of the pathname functions. Thus)
-92 W( system definitions will not be portable to the Macintosh.)93 W
-7200 40096 MT
-(To convert them, include the device in the toplevel pathname and include trailing colons in)
-7 W( the pathnames)6 W
-7200 41616 MT
-(of each module.)SH
-7200 45112 MT
-(We currently assume that)
-205 W( compilation-load dependencies and if-changed dependencies are identical.)206 W
-7200 46632 MT
-(However, in some cases this might not be true. For example, if we change)
-21 W( a macro we have to recompile)20 W
-7200 48152 MT
-(functions that depend on it, but not if we change)
-239 W( a function. Splitting these apart \050with appropriate)240 W
-7200 49672 MT
-(defaulting\051 would be nice, but not worth doing immediately since it may save only a)
-252 W( couple of file)251 W
-7200 51192 MT
-(recompilations, while making the defsystem much)
-222 W( more complex. And if someone has such a large)223 W
-7200 52712 MT
-(system that this matters, they've got more important problems.)SH
-ES
-%%Trailer
-%%Pages: 9 
-%%DocumentFonts: Helvetica Helvetica-Bold Helvetica-Oblique Courier-Bold Symbol
diff --git a/contrib/demos/demos.catalog b/contrib/demos/demos.catalog
deleted file mode 100644
index c38ec9a8fa1633008d4de8c329cb99ba794a279f..0000000000000000000000000000000000000000
--- a/contrib/demos/demos.catalog
+++ /dev/null
@@ -1,38 +0,0 @@
-Package Name:
-   DEMOS
-
-Description:
-   Graphics demonstration programs for CMU Common Lisp using version 11 of the
-X Window System.
-
-Author:
-   CMU Common Lisp Group.
-
-Maintainer:
-   CMU Common Lisp Group.
-
-Address:
-   Carnegie-Mellon University
-   Computer Science Department
-   Pittsburgh, PA 15213
-
-Net Address:
-   slisp-group@b
-
-Copyright Status:
-   Public Domain.
-
-Files:
-   demos.lisp, demos.fasl, demos.catalog.
-
-How to Get:
-   The following unix command will copy the pertinent files into directory
-<spec>:
-   cp /afs/cs.cmu.edu/project/slisp/library/demos/* <spec>
-
-Portability:
-   Should run in any Common Lisp supporting CLX V11R3.
-
-Instructions:
-   The function DEMOS:DO-ALL-DEMOS will run through each of the demos once, and
-the function DEMOS:DEMO will present a menu of all the demos.
diff --git a/contrib/demos/demos.lisp b/contrib/demos/demos.lisp
deleted file mode 100644
index 91aa7e7b1067eecf839f5cb2d5203ea2606e24ff..0000000000000000000000000000000000000000
--- a/contrib/demos/demos.lisp
+++ /dev/null
@@ -1,1038 +0,0 @@
-;;; -*- Mode: Lisp; Package: Demos -*-
-;;;
-;;; This file contains various graphics hacks written and ported over the
-;;; years by various and numerous persons.
-;;;
-;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88.
-;;;
-
-(in-package "DEMOS" :use '("LISP"))
-
-(export '(do-all-demos demo))
-
-
-
-;;;; Graphic demos wrapper macro.
-
-;;; This wrapper macro should be reconsidered with respect to its property
-;;; list usage.  Possibly a demo structure should be used with *demos*
-;;; pointing to these instead of function names.  Also, something should
-;;; be done about a title window that displays the name of the demo while
-;;; it is running.
-
-(defparameter *demos* nil)
-
-(defvar *display* nil)
-(defvar *screen* nil)
-(defvar *root* nil)
-(defvar *black-pixel* nil)
-(defvar *white-pixel* nil)
-(defvar *window* nil)
-
-(defmacro defdemo (fun-name demo-name args x y width height doc &rest forms)
-  `(progn
-     (defun ,fun-name ,args
-       ,doc
-       (cond (*display*
-	      (xlib:with-state (*window*)
-		(setf (xlib:drawable-x *window*) ,x)
-		(setf (xlib:drawable-y *window*) ,y)
-		(setf (xlib:drawable-width *window*) ,width)
-		(setf (xlib:drawable-height *window*) ,height)))
-	     (t
-	      #+:cmu
-	      (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
-	      #-:cmu
-	      (progn
-		;; Portable method
-		(setf *display* (xlib:open-display (machine-instance)))
-		(setf *screen* (xlib:display-default-screen *display*)))
-	      (setf *root* (xlib:screen-root *screen*))
-	      (setf *black-pixel* (xlib:screen-black-pixel *screen*))
-	      (setf *white-pixel* (xlib:screen-white-pixel *screen*))
-	      (setf *window* (xlib:create-window :parent *root*
-						 :x ,x :y ,y
-						 :event-mask nil
-						 :width ,width :height ,height
-						 :background *white-pixel*
-						 :border *black-pixel*
-						 :border-width 2
-						 :override-redirect :on))))
-       (xlib:map-window *window*)
-       ;; 
-       ;; I hate to do this since this is not something any normal
-       ;; program should do ...
-       (setf (xlib:window-priority *window*) :above)
-       (xlib:display-finish-output *display*)
-       (unwind-protect
-	   (progn ,@forms)
-	 (xlib:unmap-window *window*)
-	 (xlib:display-finish-output *display*)))
-     (setf (get ',fun-name 'demo-name) ',demo-name)
-     (setf (get ',fun-name 'demo-doc) ',doc)
-     (export ',fun-name)
-     (pushnew ',fun-name *demos*)
-     ',fun-name))
-
-
-;;;; Main entry points.
-
-(defun do-all-demos ()
-  (dolist (demo *demos*)
-    (funcall demo)
-    (sleep 3)))
-
-;;; DEMO is a hack to get by.  It should be based on creating a menu.  At
-;;; that time, *name-to-function* should be deleted, since this mapping will
-;;; be manifested in the menu slot name cross its action.  Also the
-;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for
-;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi".
-;;;
-
-(defvar *name-to-function* (make-hash-table :test #'eq))
-(defvar *keyword-package* (find-package "KEYWORD"))
-
-(defun demo ()
-  (macrolet ((read-demo ()
-	       `(let ((*package* *keyword-package*))
-		  (read))))
-    (dolist (d *demos*)
-      (setf (gethash (intern (string-upcase (get d 'demo-name))
-			     *keyword-package*)
-		     *name-to-function*)
-	    d))
-    (loop
-      (fresh-line)
-      (dolist (d *demos*)
-	(write-string "   ")
-	(write-line (get d 'demo-name)))
-      (write-string "   ")
-      (write-line "Help <demo name>")
-      (write-string "   ")
-      (write-line "Quit")
-      (write-string "Enter demo name: ")
-      (let ((demo (read-demo)))
-	(case demo
-	  (:help
-	   (let* ((demo (read-demo))
-		  (fun (gethash demo *name-to-function*)))
-	     (fresh-line)
-	     (if fun
-		 (format t "~&~%~A~&~%" (get fun 'demo-doc))
-		 (format t "Unknown demo name -- ~A." demo))))
-	  (:quit (return t))
-	  (t
-	   (let ((fun (gethash demo *name-to-function*)))
-	     (if fun
-		 (funcall fun)
-		 (format t "~&~%Unknown demo name -- ~A.~&~%" demo)))))))))
-
-
-;;;; Shared demo utilities.
-
-(defun full-window-state (w)
-  (xlib:with-state (w)
-    (values (xlib:drawable-width w) (xlib:drawable-height w)
-	    (xlib:drawable-x w) (xlib:drawable-y w)
-	    (xlib:window-map-state w))))
-
-
-;;;; Greynetic.
-
-;;; GREYNETIC displays random sized and shaded boxes in a window.  This is
-;;; real slow.  It needs work.
-;;; 
-(defun greynetic (window duration)
-  (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1
-				     :drawable window))
-	 (gcontext (xlib:create-gcontext :drawable window
-					 :background *white-pixel*
-					 :foreground *black-pixel*
-					 :tile pixmap
-					 :fill-style :tiled)))
-    (multiple-value-bind (width height) (full-window-state window)
-      (dotimes (i duration)
-	(let* ((pixmap-data (greynetic-pixmapper))
-	       (image (xlib:create-image :width 32 :height 32
-					 :depth 1 :data pixmap-data)))
-	  (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32)
-	  (xlib:draw-rectangle window gcontext
-			       (- (random width) 5)
-			       (- (random height) 5)
-			       (+ 4 (random (truncate width 3)))
-			       (+ 4 (random (truncate height 3)))
-			       t))
-	(xlib:display-force-output *display*)))
-    (xlib:free-gcontext gcontext)
-    (xlib:free-pixmap pixmap)))
-
-(defvar *greynetic-pixmap-array*
-  (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel))
-
-(defun greynetic-pixmapper ()
-  (let ((pixmap-data *greynetic-pixmap-array*))
-    (dotimes (i 4)
-      (declare (fixnum i))
-      (let ((nibble (random 16)))
-	(setf nibble (logior nibble (ash nibble 4))
-	      nibble (logior nibble (ash nibble 8))
-	      nibble (logior nibble (ash nibble 12))
-	      nibble (logior nibble (ash nibble 16)))
-	(dotimes (j 32)
-	  (let ((bit (if (logbitp j nibble) 1 0)))
-	    (setf (aref pixmap-data i j) bit
-		  (aref pixmap-data (+ 4 i) j) bit
-		  (aref pixmap-data (+ 8 i) j) bit
-		  (aref pixmap-data (+ 12 i) j) bit
-		  (aref pixmap-data (+ 16 i) j) bit
-		  (aref pixmap-data (+ 20 i) j) bit
-		  (aref pixmap-data (+ 24 i) j) bit
-		  (aref pixmap-data (+ 28 i) j) bit)))))
-    pixmap-data))
-
-(defdemo greynetic-demo "Greynetic" (&optional (duration 300))
-  100 100 600 600
-  "Displays random grey rectangles."
-  (greynetic *window* duration))
-
-
-;;;; Qix.
-
-(defstruct qix
-  buffer
-  (dx1 5)
-  (dy1 10)
-  (dx2 10)
-  (dy2 5))
-
-(defun construct-qix (length)
-  (let ((qix (make-qix)))
-    (setf (qix-buffer qix) (make-circular-list length))
-    qix))
-
-(defun make-circular-list (length)
-  (let ((l (make-list length)))
-    (rplacd (last l) l)))
-
-
-(defun qix (window lengths duration)
-  "Each length is the number of lines to put in a qix, and that many qix
-  (of the correct size) are put up on the screen.  Lets the qix wander around
-  the screen for Duration steps."
-  (let ((histories (mapcar #'construct-qix lengths)))
-    (multiple-value-bind (width height) (full-window-state window)
-      (declare (fixnum width height))
-      (xlib:clear-area window)
-      (xlib:display-force-output *display*)
-      (do ((h histories (cdr h))
-	   (l lengths (cdr l)))
-	  ((null h))
-	(do ((x (qix-buffer (car h)) (cdr x))
-	     (i 0 (1+ i)))
-	    ((= i (car l)))
-	  (rplaca x (make-array 4))))
-      ;; Start each qix at a random spot on the screen.
-      (dolist (h histories)
-	(let ((x (random width))
-	      (y (random height)))
-	  (rplaca (qix-buffer h)
-		  (make-array 4 :initial-contents (list x y x y)))))
-      (rplacd (last histories) histories)
-      (let (x1 y1 x2 y2 dx1 dy1 dx2 dy2 tem line next-line qix
-	       (gc (xlib:create-gcontext :drawable window
-					 :foreground *white-pixel*
-					 :background *black-pixel*
-					 :line-width 0 :line-style :solid
-					 :function boole-c2)))
-	(declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2))
-	(dotimes (i duration)
-	  ;; Line is the next line in the next qix. Rotate this qix and
-	  ;; the qix ring.
-	  (setq qix (car histories))
-	  (setq line (car (qix-buffer qix)))
-	  (setq next-line (cadr (qix-buffer qix)))
-	  (setf (qix-buffer qix) (cdr (qix-buffer qix)))
-	  (setq histories (cdr histories))
-	  (setf x1 (svref line 0))
-	  (setf y1 (svref line 1))
-	  (setf x2 (svref line 2))
-	  (setf y2 (svref line 3))
-	  (xlib:draw-line window gc x1 y1 x2 y2)
-	  (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1))
-	  (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1))
-	  (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1))
-	  (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1))
-	  (cond ((> dx1 10) (setq dx1 10))
-		((< dx1 -10) (setq dx1 -10)))
-	  (cond ((> dy1 10) (setq dy1 10))
-		((< dy1 -10) (setq dy1 -10)))
-	  (cond ((> dx2 10) (setq dx2 10))
-		((< dx2 -10) (setq dx2 -10)))
-	  (cond ((> dy2 10) (setq dy2 10))
-		((< dy2 -10) (setq dy2 -10)))
-	  (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem))
-		 (setq dx1 (- dx1))))
-	  (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem))
-		 (setq dx2 (- dx2))))
-	  (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem))
-		 (setq dy1 (- dy1))))
-	  (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem))
-		 (setq dy2 (- dy2))))
-	  (setf (qix-dy2 qix) dy2)
-	  (setf (qix-dx2 qix) dx2)
-	  (setf (qix-dy1 qix) dy1)
-	  (setf (qix-dx1 qix) dx1)
-	  (when (svref next-line 0)
-	    (xlib:draw-line window gc
-			    (svref next-line 0) (svref next-line 1)
-			    (svref next-line 2) (svref next-line 3)))
-	  (setf (svref next-line 0) (+ x1 dx1))
-	  (setf (svref next-line 1) (+ y1 dy1))
-	  (setf (svref next-line 2) (+ x2 dx2))
-	  (setf (svref next-line 3) (+ y2 dy2))
-	  (xlib:display-force-output *display*))))))
-
-
-(defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000))
-  0 0 700 700
-  "Hypnotic wandering lines."
-  (qix *window* lengths duration))
-
-
-
-;;;; Petal.
-
-;;; Fast sine constants:
-
-(defconstant d360 #o5500)
-(defconstant d270 #o4160)
-(defconstant d180 #o2640)
-(defconstant d90 #o1320)
-(defconstant vecmax 2880)
-
-(defconstant sin-array
-  '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 
-     #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145
-     #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 
-     #o12743 #o13357 #o13771 #o14401 #o15007 #o15414
-     #o16016 #o16416 #o17013 #o17407 #o20000 #o20366
-     #o20752 #o21333 #o21711 #o22265 #o22636 #o23204
-     #o23546 #o24106 #o24443 #o24774 #o25323 #o25645
-     #o26165 #o26501 #o27011 #o27316 #o27617 #o30115
-     #o30406 #o30674 #o31156 #o31434 #o31706 #o32154
-     #o32416 #o32654 #o33106 #o33333 #o33554 #o33771
-     #o34202 #o34406 #o34605 #o35000 #o35167 #o35351
-     #o35526 #o35677 #o36043 #o36203 #o36336 #o36464
-     #o36605 #o36721 #o37031 #o37134 #o37231 #o37322
-     #o37407 #o37466 #o37540 #o37605 #o37646 #o37701
-     #o37730 #o37751 #o37766 #o37775 #o40000))
-
-(defmacro psin (val)
-  `(let* ((val ,val)
-	  neg
-	  frac
-	  sinlo)
-     (if (>= val d180)
-	 (setq neg t
-	       val (- val d180)))
-     (if (>= val d90)
-	 (setq val (- d180 val)))
-     (setq frac (logand val 7))
-     (setq val (ash val -3))
-     ;; 
-     (setq sinlo (if (>= val 90)
-		     (svref sin-array 90)
-		     (svref sin-array val)))
-     ;; 
-     (if (< val 90)
-	 (setq sinlo
-	       (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo))
-			     -3))))
-     ;; 
-     (if neg
-	 (- sinlo)
-	 sinlo)))
-
-(defmacro pcos (x)
-  `(let ((tmp (- ,x d270)))
-     (psin (if (minusp tmp) (+ tmp d360) tmp))))
-
-
-;;;; Miscellaneous petal hackery.
-
-(defmacro high-16bits-* (a b)
-  `(let ((a-h (ash ,a -8))
-	 (b-h (ash ,b -8)))
-     (+ (* a-h b-h)
-	(ash (* a-h (logand ,b 255)) -8)
-	(ash (* b-h (logand ,a 255)) -8))))
-
-(defun complete (style petal)
-  (let ((repnum 1)
-	factor cntval needed)
-    (dotimes (i 3)
-      (case i
-	(0 (setq factor 2 cntval 6)) 
-	(1 (setq factor 3 cntval 2))
-	(2 (setq factor 5 cntval 1)))
-      (do ()
-	  ((or (minusp cntval) (not (zerop (rem style factor)))))
-	(setq repnum (* repnum factor))
-	(setq cntval (1- cntval))
-	(setq style (floor style factor))))
-    (setq needed (floor vecmax repnum))
-    (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed)))
-
-
-;;;; Petal Parameters and Petal itself
-
-(defparameter continuous t)
-(defparameter styinc 2)
-(defparameter petinc 1)
-(defparameter scalfac-fac 8192)
-
-(defun petal (petal-window &optional (how-many 10) (style 0) (petal 0))
-  (let ((width 512)
-	(height 512))
-    (xlib:clear-area petal-window)
-    (xlib:display-force-output *display*)
-    (let ((veccnt 0)
-	  (nustyle 722)
-	  (nupetal 3)
-	  (scalfac (1+ (floor scalfac-fac (min width height))))
-	  (ctrx (floor width 2))
-	  (ctry (floor height 2))
-	  (tt 0)
-	  (s 0)
-	  (lststyle 0)
-	  (lstpetal 0)
-	  (petstyle 0)
-	  (vectors 0)
-	  (r 0)
-	  (x1 0)
-	  (y1 0)
-	  (x2 0)
-	  (y2 0)
-	  (i 0)
-	  (gc (xlib:create-gcontext :drawable petal-window
-				    :foreground *black-pixel*
-				    :background *white-pixel*
-				    :line-width 0 :line-style :solid)))
-      (loop
-	(when (zerop veccnt)
-	  (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal
-		style nustyle petstyle (rem (* petal style) d360)
-		vectors (complete style petal))
-	  (when continuous
-	    (setq nupetal  (+ nupetal petinc)
-		  nustyle (+ nustyle styinc)))
-	  (when (or (/= lststyle style) (/= lstpetal petal))
-	    (xlib:clear-area petal-window)
-	    (xlib:display-force-output *display*)))
-	(when (or (/= lststyle style) (/= lstpetal petal))
-	  (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2
-		tt (rem (+ tt style) d360)
-		s (rem (+ s petstyle) d360)
-		r (pcos s))
-	  (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac))
-		y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac)))
-	  (when (/= i 1)
-	    (xlib:draw-line petal-window gc x1 y1 x2 y2)
-	    (xlib:display-force-output *display*)))
-	(when (> veccnt vectors)
-	  (setq veccnt 0)
-	  (setq how-many (1- how-many))
-	  (sleep 2)
-	  (when (zerop how-many) (return)))))))
-
-(defdemo petal-demo "Petal" (&optional (how-many 10) (style 0) (petal 0))
-  100 100 512 512
-  "Flower-like display."
-  (petal *window* how-many style petal))
-
-
-;;;; Hanoi.
-
-;;; Random parameters:
-
-(defparameter disk-thickness 15 "The thickness of a disk in pixels.")
-(defparameter disk-spacing (+ disk-thickness 3)
-  "The amount of vertical space used by a disk on a needle.")
-(defvar *horizontal-velocity* 20 "The speed at which disks slide sideways.")
-(defvar *vertical-velocity* 12 "The speed at which disks move up and down.")
-
-;;; These variables are bound by the main function.
-
-(defvar *hanoi-window* () "The window that Hanoi is happening on.")
-(defvar *hanoi-window-height* () "The height of the viewport Hanoi is happening on.")
-(defvar *transfer-height* () "The height at which disks are transferred.")
-(defvar *hanoi-gcontext* () "The graphics context for Hanoi under X11.")
-
-;;; Needle Functions
-
-(defstruct disk
-  size)
-
-(defstruct needle
-  position
-  disk-stack)
-
-;;; Needle-Top-Height returns the height of the top disk on NEEDLE.
-
-(defun needle-top-height (needle)
-  (- *hanoi-window-height*
-     (* disk-spacing (length (the list (needle-disk-stack needle))))))
-
-(defvar available-disks
-  (do ((i 10 (+ i 10))
-       (dlist () (cons (make-disk :size i) dlist)))
-      ((> i 80) dlist)))
-
-(defvar needle-1 (make-needle :position 184))
-(defvar needle-2 (make-needle :position 382))
-(defvar needle-3 (make-needle :position 584))
-
-;;; Graphic interface abstraction:
-
-;;; Invert-Rectangle calls the CLX function draw-rectangle with "fill-p"
-;;; set to T.  Update-Screen forces the display output.
-;;; 
-(defmacro invert-rectangle (x y height width)
-  `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext*
-			,x ,y ,width ,height t))
-
-(defmacro update-screen ()
-  `(xlib:display-force-output *display*))
-
-
-;;;; Moving disks up and down
-
-;;; Slide-Up slides the image of a disk up from the coordinates X,
-;;; START-Y to the point X, END-Y.  DISK-SIZE is the size of the disk to
-;;; move.  START-Y must be greater than END-Y
-
-(defun slide-up (start-y end-y x disk-size)
-  (multiple-value-bind (number-moves pixels-left)
-		       (truncate (- start-y end-y) *vertical-velocity*)
-    (do ((x (- x disk-size))
-	 (width (* disk-size 2))
-	 (old-y start-y (- old-y *vertical-velocity*))
-	 (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*))
-	 (number-moves number-moves (1- number-moves)))
-	((zerop number-moves)
-	 (when (plusp pixels-left)
-	   (invert-rectangle x (- old-y pixels-left) disk-thickness width)
-	   (invert-rectangle x old-y disk-thickness width)
-	   (update-screen)))
-      ;; Loop body writes disk at new height & erases at old height.
-      (invert-rectangle x old-y disk-thickness width)
-      (invert-rectangle x new-y disk-thickness width)
-      (update-screen))))
-
-;;; Slide-Down slides the image of a disk down from the coordinates X,
-;;; START-Y to the point X, END-Y.  DISK-SIZE is the size of the disk to
-;;; move.  START-Y must be less than END-Y.
-
-(defun slide-down (start-y end-y x disk-size)
-  (multiple-value-bind (number-moves pixels-left)
-		       (truncate (- end-y start-y) *vertical-velocity*)
-    (do ((x (- x disk-size))
-	 (width (* disk-size 2))
-	 (old-y start-y (+ old-y *vertical-velocity*))
-	 (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*))
-	 (number-moves number-moves (1- number-moves)))
-	((zerop number-moves)
-	 (when (plusp pixels-left)
-	   (invert-rectangle x (+ old-y pixels-left) disk-thickness width)
-	   (invert-rectangle x old-y disk-thickness width)
-	   (update-screen)))
-      ;; Loop body writes disk at new height & erases at old height.
-      (invert-rectangle X old-y disk-thickness width)
-      (invert-rectangle X new-y disk-thickness width)
-      (update-screen))))
-
-
-;;;; Lifting and Droping Disks
-
-;;; Lift-disk pops the top disk off of needle and raises it up to the
-;;; transfer height.  The disk is returned.
-
-(defun lift-disk (needle)
-  "Pops the top disk off of NEEDLE, Lifts it above the needle, & returns it."
-  (let* ((height (needle-top-height needle))
-	 (disk (pop (needle-disk-stack needle))))
-    (slide-up height
-	      *transfer-height*
-	      (needle-position needle)
-	      (disk-size disk))
-    disk))
-
-;;; Drop-disk drops a disk positioned over needle at the transfer height
-;;; onto needle.  The disk is pushed onto needle.
-
-(defun drop-disk (disk needle)
-  "DISK must be positioned above NEEDLE.  It is dropped onto NEEDLE."
-  (push disk (needle-disk-stack needle))
-  (slide-down *transfer-height*
-	      (needle-top-height needle)
-	      (needle-position needle)
-	      (disk-size disk))
-  t)
-
-
-;;; Drop-initial-disk is the same as drop-disk except that the disk is
-;;; drawn once before dropping.
-
-(defun drop-initial-disk (disk needle)
-  "DISK must be positioned above NEEDLE.  It is dropped onto NEEDLE."
-  (let* ((size (disk-size disk))
-	 (lx (- (needle-position needle) size)))
-    (invert-rectangle lx *transfer-height* disk-thickness (* size 2))
-    (push disk (needle-disk-stack needle))
-    (slide-down *transfer-height*
-		(needle-top-height needle)
-		(needle-position needle)
-		(disk-size disk))
-    t))
-
-
-;;;; Sliding Disks Right and Left
-
-;;; Slide-Right slides the image of a disk located at START-X, Y to the
-;;; position END-X, Y.  DISK-SIZE is the size of the disk.  START-X is
-;;; less than END-X.
-
-(defun slide-right (start-x end-x Y disk-size)
-  (multiple-value-bind (number-moves pixels-left)
-		       (truncate (- end-x start-x) *horizontal-velocity*)
-    (do ((right-x (+ start-x disk-size) (+ right-x *horizontal-velocity*))
-	 (left-x  (- start-x disk-size) (+ left-x  *horizontal-velocity*))
-	 (number-moves number-moves (1- number-moves)))
-	((zerop number-moves)
-	 (when (plusp pixels-left)
-	   (invert-rectangle right-x Y disk-thickness pixels-left)
-	   (invert-rectangle left-x  Y disk-thickness pixels-left)
-	   (update-screen)))
-      ;; Loop body adds chunk *horizontal-velocity* pixels wide to right
-      ;; side of disk, then chops off left side.
-      (invert-rectangle right-x Y disk-thickness *horizontal-velocity*)
-      (invert-rectangle left-x Y disk-thickness *horizontal-velocity*)
-      (update-screen))))
-
-;;; Slide-Left is the same as Slide-Right except that START-X is greater
-;;; than END-X.
-
-(defun slide-left (start-x end-x Y disk-size)
-  (multiple-value-bind (number-moves pixels-left)
-		       (truncate (- start-x end-x) *horizontal-velocity*)
-    (do ((right-x (- (+ start-x disk-size) *horizontal-velocity*)
-		  (- right-x *horizontal-velocity*))
-	 (left-x  (- (- start-x disk-size) *horizontal-velocity*)
-		  (- left-x  *horizontal-velocity*))
-	 (number-moves number-moves (1- number-moves)))
-	((zerop number-moves)
-	 (when (plusp pixels-left)
-	   (setq left-x  (- (+ left-x  *horizontal-velocity*) pixels-left))
-	   (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left))
-	   (invert-rectangle left-x  Y disk-thickness pixels-left)
-	   (invert-rectangle right-x Y disk-thickness pixels-left)
-	   (update-screen)))
-      ;; Loop body adds chunk *horizontal-velocity* pixels wide to left
-      ;; side of disk, then chops off right side.
-      (invert-rectangle left-x  Y disk-thickness *horizontal-velocity*)
-      (invert-rectangle right-x Y disk-thickness *horizontal-velocity*)
-      (update-screen))))
-
-
-;;;; Transferring Disks
-
-;;; Transfer disk slides a disk at the transfer height from a position
-;;; over START-NEEDLE to a position over END-NEEDLE.  Modified disk is
-;;; returned.
-
-(defun transfer-disk (disk start-needle end-needle)
-  "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE."
-  (let ((start (needle-position start-needle))
-	(end (needle-position end-needle)))
-    (if (< start end)
-	(slide-right start end *transfer-height* (disk-size disk))
-	(slide-left start end *transfer-height* (disk-size disk)))
-    disk))
-
-
-;;; Move-One-Disk moves the top disk from START-NEEDLE to END-NEEDLE.
-
-(defun move-one-disk (start-needle end-needle)
-  "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE."
-  (drop-disk (transfer-disk (lift-disk start-needle)
-			    start-needle
-			    end-needle)
-	     end-needle)
-  t)
-
-;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE
-;;; obeying the rules of the towers of hannoi problem.  To move the
-;;; disks, a third needle, TEMP-NEEDLE, is needed for temporary storage.
-
-(defun move-n-disks (n start-needle end-needle temp-needle)
-  "Moves the top N disks from START-NEEDLE to END-NEEDLE.  
-   Uses TEMP-NEEDLE for temporary storage."
-  (cond ((= n 1)
-	 (move-one-disk start-needle end-needle))
-	(t
-	 (move-n-disks (1- n) start-needle temp-needle end-needle)
-	 (move-one-disk start-needle end-needle)
-	 (move-n-disks (1- n) temp-needle end-needle start-needle)))
-  t)
-
-
-;;;; Hanoi itself.
-
-(defun hanoi (window n)
-  (multiple-value-bind (width height) (full-window-state window)
-    (declare (ignore width))
-    (let* ((*hanoi-window* window)
-	   (*hanoi-window-height* height)
-	   (*transfer-height* (- height (* disk-spacing n)))
-	   (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window*
-						   :foreground *white-pixel*
-						   :background *black-pixel*
-						   :fill-style :solid
-						   :function boole-c2)))
-      (xlib:clear-area *hanoi-window*)
-      (xlib:display-force-output *display*)
-      (setf (needle-disk-stack needle-1) ())
-      (setf (needle-disk-stack needle-2) ())
-      (setf (needle-disk-stack needle-3) ())
-      (do ((n n (1- n))
-	   (available-disks available-disks (cdr available-disks)))
-	  ((zerop n))
-	(drop-initial-disk (car available-disks) needle-1))
-      (move-n-disks n needle-1 needle-3 needle-2)
-      t)))
-
-;;; Change the names of these when the DEMO loop isn't so stupid.
-;;; 
-(defdemo slow-hanoi-demo "Slow-towers-of-Hanoi" (&optional (how-many 4))
-  0 100 768 300
-  "Solves the Towers of Hanoi problem before your very eyes."
-  (let ((*horizontal-velocity* 3)
-	(*vertical-velocity* 1))
-    (hanoi *window* how-many)))
-;;;
-(defdemo fast-hanoi-demo "Fast-towers-of-Hanoi" (&optional (how-many 7))
-  0 100 768 300
-  "Solves the Towers of Hanoi problem before your very eyes."
-  (hanoi *window* how-many))
-
-
-
-;;;; Bounce window.
-
-;;; BOUNCE-WINDOW takes a window and seemingly drops it to the bottom of
-;;; the screen.  Optionally, the window can have an initial x velocity,
-;;; screen border elasticity, and gravity value.  The outer loop is
-;;; entered the first time with the window at its initial height, but
-;;; each iteration after this, the loop starts with the window at the
-;;; bottom of the screen heading upward.  The inner loop, except for the
-;;; first execution, carries the window up until the negative velocity
-;;; becomes positive, carrying the window down to bottom when the
-;;; velocity is positive.  Due to number lossage, ROUND'ing and
-;;; TRUNC'ing when the velocity gets so small will cause the window to
-;;; head upward with the same velocity over two iterations which will
-;;; cause the window to bounce forever, so we have prev-neg-velocity and
-;;; number-problems to check for this.  This is not crucial with the x
-;;; velocity since the loop terminates as a function of the y velocity.
-;;; 
-(defun bounce-window (window &optional
-			     (x-velocity 0) (elasticity 0.85) (gravity 2))
-  (unless (< 0 elasticity 1)
-    (error "Elasticity must be between 0 and 1."))
-  (unless (plusp gravity)
-    (error "Gravity must be positive."))
-  (multiple-value-bind (width height x y mapped) (full-window-state window)
-    (when (eq mapped :viewable)
-      (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height))
-	    (left-of-window-at-right (- (xlib:drawable-width *root*) width))
-	    (y-velocity 0)
-	    (prev-neg-velocity most-negative-fixnum)
-	    (number-problems nil))
-	(declare (fixnum top-of-window-at-bottom left-of-window-at-right
-			 y-velocity))
-	(loop
-	  (when (= prev-neg-velocity 0) (return t))
-	  (let ((negative-velocity (minusp y-velocity)))
-	    (loop
-	      (let ((next-y (+ y y-velocity))
-		    (next-y-velocity (+ y-velocity gravity)))
-		(declare (fixnum next-y next-y-velocity))
-		(when (> next-y top-of-window-at-bottom)
-		  (cond
-		   (number-problems
-		    (setf y-velocity (incf prev-neg-velocity)))
-		   (t
-		    (setq y-velocity
-			  (- (truncate (* elasticity y-velocity))))
-		    (when (= y-velocity prev-neg-velocity)
-		      (incf y-velocity)
-		      (setf number-problems t))
-		    (setf prev-neg-velocity y-velocity)))
-		  (setf y top-of-window-at-bottom)
-		  (setf (xlib:drawable-x window) x
-			(xlib:drawable-y window) y)
-		  (xlib:display-force-output *display*)
-		  (return))
-		(setq y-velocity next-y-velocity)
-		(setq y next-y))
-	      (when (and negative-velocity (>= y-velocity 0))
-		(setf negative-velocity nil))
-	      (let ((next-x (+ x x-velocity)))
-		(declare (fixnum next-x))
-		(when (or (> next-x left-of-window-at-right)
-			  (< next-x 0))
-		  (setq x-velocity (- (truncate (* elasticity x-velocity)))))
-		(setq x next-x))
-	      (setf (xlib:drawable-x window) x
-		    (xlib:drawable-y window) y)
-	      (xlib:display-force-output *display*))))))))
-
-;;; Change the name of this when DEMO is not so stupid.
-;;; 
-(defdemo shove-bounce-demo "Shove-bounce" ()
-  100 100 300 300
-  "Drops the demo window with an inital X velocity which bounces off
-  screen borders."
-  (bounce-window *window* 30))
-
-(defdemo bounce-demo "Bounce" ()
-  100 100 300 300
-  "Drops the demo window which bounces off screen borders."
-  (bounce-window *window*))
-
-
-;;;; Recurrence Demo
-
-;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu)
-
-;;; Permission is granted to any individual or institution to use, copy,
-;;; modify, and distribute this software, provided that this complete
-;;; copyright and permission notice is maintained, intact, in all copies and
-;;; supporting documentation.  
-
-;;; The author provides this software "as is" without express or
-;;; implied warranty.
-
-;;; This routine plots the recurrence 
-;;;      x <- y(1+sin(0.7x)) - 1.2(|x|)^.5
-;;;      y <- .21 - x
-;;; As described in a ?? 1983 issue of the Mathematical Intelligencer
-
-(defun recurrence (display window &optional (point-count 10000))
-  (let ((gc (xlib:create-gcontext :drawable window
-				  :background *white-pixel*
-				  :foreground *black-pixel*)))
-    (multiple-value-bind (width height) (full-window-state window)
-      (xlib:clear-area window)
-      (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5))
-      (xlib:display-force-output display)
-      (sleep 4))
-    (xlib:free-gcontext gc)))
-
-;;; Draw points.  X assumes points are in the range of width x height,
-;;; with 0,0 being upper left and 0,H being lower left.
-;;; hw and hh are half-width and half-height of screen
-
-(defun draw-ppict (win gc count x y hw hh)
-  "Recursively draw pretty picture"
-  (unless (zerop count)
-    (let ((xf (floor (* (+ 1.0 x) hw ))) ;These lines center the picture
-          (yf (floor (* (+ 0.7 y) hh ))))
-      (xlib:draw-point win gc xf yf)
-      (draw-ppict win gc (1- count) 
-                  (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x))))
-                  (- 0.21 x)
-                  hw
-                  hh))))
-
-(defdemo recurrence-demo "Recurrence" ()
-  10 10 700 700
-  "Plots a cool recurrence relation."
-  (recurrence *display* *window*))
-
-
-;;;; Plaid
-
-;;; 
-;;; Translated from the X11 Plaid Demo written in C by Christopher Hoover.
-;;; 
-
-(defmacro rect-x (rects n)
-  `(svref ,rects (ash ,n 2)))
-(defmacro rect-y (rects n)
-  `(svref ,rects (+ (ash ,n 2) 1)))
-(defmacro rect-width (rects n)
-  `(svref ,rects (+ (ash ,n 2) 2)))
-(defmacro rect-height (rects n)
-  `(svref ,rects (+ (ash ,n 2) 3)))
-
-(defun plaid (display window &optional (num-iterations 10000) (num-rectangles 10))
-  (let ((gcontext (xlib:create-gcontext :drawable window
-					:function boole-c2
-					:plane-mask (logxor *white-pixel*
-							    *black-pixel*)
-					:background *white-pixel*
-					:foreground *black-pixel*
-					:fill-style :solid))
-	(rectangles (make-array (* 4 num-rectangles)
-				:element-type 'number
-				:initial-element 0)))
-    (multiple-value-bind (width height) (full-window-state window)
-      (let ((center-x (ash width -1))
-	    (center-y (ash height -1))
-	    (x-dir -2)
-	    (y-dir -2)
-	    (x-off 2)
-	    (y-off 2))
-	(dotimes (iter (truncate num-iterations num-rectangles))
-	  (dotimes (i num-rectangles)
-	    (setf (rect-x rectangles i) (- center-x x-off))
-	    (setf (rect-y rectangles i) (- center-y y-off))
-	    (setf (rect-width rectangles i) (ash x-off 1))
-	    (setf (rect-height rectangles i) (ash y-off 1))
-	    (incf x-off x-dir)
-	    (incf y-off y-dir)
-	    (when (or (<= x-off 0) (>= x-off center-x))
-	      (decf x-off (ash x-dir 1))
-	      (setf x-dir (- x-dir)))
-	    (when (or (<= y-off 0) (>= y-off center-y))
-	      (decf y-off (ash y-dir 1))
-	      (setf y-dir (- y-dir))))
-	  (xlib:draw-rectangles window gcontext rectangles t)
-	  (xlib:display-force-output display))))
-    (xlib:free-gcontext gcontext)))
-
-(defdemo plaid-demo "Plaid" (&optional (iterations 10000) (num-rectangles 10))
-  10 10 101 201
-  "Plaid, man."
-  (plaid *display* *window* iterations num-rectangles))
-
-
-;;;; Bball demo
-
-;;; 
-;;; Ported to CLX by Blaine Burks
-;;; 
-
-(defvar *ball-size-x* 38)
-(defvar *ball-size-y* 34)
-
-(defmacro xor-ball (pixmap window gcontext x y)
-  `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y*
-		   ,window ,x ,y))
-
-(defconstant bball-gravity 1)
-(defconstant maximum-x-drift 7)
-
-(defvar *max-bball-x*)
-(defvar *max-bball-y*)
-
-(defstruct ball
-  (x (random (- *max-bball-x* *ball-size-x*)))
-  (y (random (- *max-bball-y* *ball-size-y*)))
-  (dx (if (zerop (random 2)) (random maximum-x-drift)
-	  (- (random maximum-x-drift))))
-  (dy 0))
-
-(defun get-bounce-image ()
-  "Returns the pixmap to be bounced around the screen."
-  (xlib::bitmap-image   #*000000000000000000000000000000000000
-			#*000000000000000000000000000000000000
-			#*000000000000000000001000000010000000
-			#*000000000000000000000000000100000000
-			#*000000000000000000000100001000000000
-			#*000000000000000010000000010000000000
-			#*000000000000000000100010000000000000
-			#*000000000000000000001000000000000000
-			#*000000000001111100000000000101010000
-			#*000000000010000011000111000000000000
-			#*000000000100000000111000000000000000
-			#*000000000100000000000000000100000000
-			#*000000000100000000001000100010000000
-			#*000000111111100000010000000001000000
-			#*000000111111100000100000100000100000
-			#*000011111111111000000000000000000000
-			#*001111111111111110000000100000000000
-			#*001111111111111110000000000000000000
-			#*011111111111111111000000000000000000
-			#*011111111111111111000000000000000000
-			#*111111111111110111100000000000000000
-			#*111111111111111111100000000000000000
-			#*111111111111111101100000000000000000
-			#*111111111111111101100000000000000000
-			#*111111111111111101100000000000000000
-			#*111111111111111111100000000000000000
-			#*111111111111110111100000000000000000
-			#*011111111111111111000000000000000000
-			#*011111111111011111000000000000000000
-			#*001111111111111110000000000000000000
-			#*001111111111111110000000000000000000
-			#*000011111111111000000000000000000000
-			#*000000111111100000000000000000000000
-			#*000000000000000000000000000000000000))
-
-
-(defun bounce-1-ball (pixmap window gcontext ball)
-  (let ((x (ball-x ball))
-	(y (ball-y ball))
-	(dx (ball-dx ball))
-	(dy (ball-dy ball)))
-    (xor-ball pixmap window gcontext x y)
-    (setq x (+ x dx))
-    (setq y (+ y dy))
-    (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*)))
-	(setq x (- x dx)
-	      dx (- dx)))
-    (if (> y (- *max-bball-y* *ball-size-y*))
-	(setq y (- y dy)
-	      dy (- dy)))
-    (setq dy (+ dy bball-gravity))
-    (setf (ball-x ball) x)
-    (setf (ball-y ball) y)
-    (setf (ball-dx ball) dx)
-    (setf (ball-dy ball) dy)
-    (xor-ball pixmap window gcontext x y)))
-
-(defun bounce-balls (display window how-many duration)
-  (xlib:clear-area window)
-  (xlib:display-force-output display)
-  (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window)
-    (let* ((balls (do ((i 0 (1+ i))
-		       (list () (cons (make-ball) list)))
-		      ((= i how-many) list)))
-	   (gcontext (xlib:create-gcontext :drawable window
-					   :foreground *white-pixel*
-					   :background *black-pixel*
-					   :function boole-xor
-					   :exposures :off))
-	   (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1
-					      :drawable window))
-	   (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap
-					    :foreground *white-pixel*
-					    :background *black-pixel*)))
-      (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image)
-		      :x 0 :y 0 :width 38 :height 34)
-      (xlib:free-gcontext pixmap-gc)
-      (dolist (ball balls)
-	(xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball)))
-      (xlib:display-force-output display)
-      (dotimes (i duration)
-	(dolist (ball balls)
-	  (bounce-1-ball bounce-pixmap window gcontext ball))
-	(xlib:display-force-output display))
-      (xlib:free-pixmap bounce-pixmap)
-      (xlib:free-gcontext gcontext))))
-
-(defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500))
-  34 34 700 500
-  "Bouncing balls in space."
-  (bounce-balls *display*  *window* how-many duration))
diff --git a/contrib/follow-mouse/follow-mouse.catalog b/contrib/follow-mouse/follow-mouse.catalog
deleted file mode 100644
index dfc32e7579b1797371920e8ba8bd4fbd7884f2d5..0000000000000000000000000000000000000000
--- a/contrib/follow-mouse/follow-mouse.catalog
+++ /dev/null
@@ -1,46 +0,0 @@
-Name:
-   Follow Mouse.
-
-Package Name:
-   HEMLOCK
-
-Description:
-   This Hemlock customization causes Hemlock's current window to be set to
-whatever Hemlock window the mouse enters, except the echo area.
-
-Author:
-   Todd Kaufmann, modified by Dave Touretzky.
-
-Maintainer:
-   Todd Kaufmann.
-
-Address:
-   Carnegie-Mellon University
-   Computer Science Department
-   Pittsburgh, PA 15213
-
-Net Address:
-   Todd.Kaufmann@CS.CMU.EDU
-
-Copyright Status:
-   Public Domain.
-
-Files:
-   follow-mouse.lisp, follow-mouse.fasl, follow-mouse.catalog.
-
-How to Get:
-   The following unix command will copy the pertinent files into directory
-<spec>:
-   cp /afs/cs.cmu.edu/project/slisp/library/follow-mouse/* <spec>
-
-Portability:
-   This should work in any Common Lisp supporting Hemlock and CLX V11R3.
-
-Instructions:
-   Load the fasl file into your editor Lisp.  A value of T for the hemlock
-variable "Follow Mouse To Read-Only Buffers", which is the default, means
-follow mouse is on.  Anything else means hemlock will behave normally.
-
-Bugs:
-   A few more PROMPT-FOR-... functions need to be modified.  They are mentioned
-in the source code.
diff --git a/contrib/follow-mouse/follow-mouse.lisp b/contrib/follow-mouse/follow-mouse.lisp
deleted file mode 100644
index d45c3a505fdbc10823617a463889271d27f03b75..0000000000000000000000000000000000000000
--- a/contrib/follow-mouse/follow-mouse.lisp
+++ /dev/null
@@ -1,152 +0,0 @@
-;;; -*- Mode: Lisp; Package: HEMLOCK-INTERNALS  -*-
-
-(in-package "HEMLOCK-INTERNALS")
-
-;;; todd kaufmann     24 mar 88
-
-;;; because we will have lots of windows, with users moving between them lots,
-;;; we would like the window the mouse is in to be the one input goes to.
-;;; 
-;;; also, this is more in line with the way most X windows work
-;;;   (unless you like to use focus)
-
-;;; Modified by Dave Touretzky 5/23/88 to fix incremental search problem,
-;;; to change windows upon leaving the echo area if the mouse moves
-;;; while we're prompting for input, and to select the correct window
-;;; when we split a window, based on where the mouse ends up.
-
-;;; Bugs:
-;;;  - a few more prompt-for-* functions need to be modified.  they're
-;;;    flagged below.
-
-(defhvar "Follow Mouse to Window"
-  "When T, the current window becomes the one the mouse enters; when NIL,
-  behaves the old way"
-  :value T)
-
-(defhvar "Follow Mouse To Read-only Buffers"
-  "Whether to follow the mouse to Read-only buffers or not"
-  :value T)
-
-(defvar *last-window-mouse-entered* nil)  ;set to the most recent LEGAL window entered
-
-(defun change-to-current-entered-window (window)
-  "Make the buffer the mouse has moved to be the current buffer."
-  (let ((buffer (window-buffer window)))
-    (when
-	(and *in-the-editor*
-	     (value ed::follow-mouse-to-window)
-	     ;; don't move cursor to menus
-	     (not (string= (buffer-major-mode buffer) "HMenu"))
-	     ;; don't move TO echo area
-	     (not (eq buffer *echo-area-buffer*))
-	     ;; can move to read-only buffers if user says it's okay
-	     (if (buffer-writable buffer) t
-		 (value ed::follow-mouse-to-read-only-buffers))
-	     ;; if we get here, this is a valid window to move to:  remember it
-	     (setf *last-window-mouse-entered* window)
-	     ;; but don't move OUT of the echo area if it's currently prompting.
-	     (not (eq (current-window) *echo-area-window*))
-	     ;; and don't move out of current window during an incremental search
-	     (not *during-incremental-search*)
-	     ;; Make sure it's not a random typeout buffer.
-	     (member window *window-list*)
-	     )
-      (setf (current-window) window
-	    (current-buffer) buffer
-	    *last-window-mouse-entered* nil))))
-
-
-(add-hook ed::enter-window-hook 'change-to-current-entered-window)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; If the user is being prompted in the echo area and moves the
-;;; mouse, we can't switch windows.  So remember where the mouse
-;;; has gone to, and switch when he leaves the echo area buffer.
-
-(defun change-windows-if-mouse-moved ()
-  (when (and *last-window-mouse-entered*
-	     (not (eq (current-window) *last-window-mouse-entered*)))
-    (change-to-current-entered-window *last-window-mouse-entered*)))
-
-
-;from echo.lisp
-
-(defun parse-for-something ()
-  (display-prompt-nicely)
-  (let ((start-window (current-window)))
-    (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*))
-    (setf (current-window) *echo-area-window*)
-    (unwind-protect
-	(use-buffer *echo-area-buffer*
-		    (recursive-edit nil))
-      (setf (current-window) start-window)
-      (change-windows-if-mouse-moved))))  ; <--- here's the change
-
-;---> Note:  must make the same change to the following:
-;	prompt-for-y-or-n
-;	prompt-for-character*
-;	prompt-for-key
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Fix for the problem of switching buffers in the middle of an
-;;; incremental search.
-;;;
-;;; Modify %i-search from searchcoms.lisp to bind a global variable
-;;; hi::*during-incremental-search* to T.  Check for this in body of
-;;; change-to-current-entered-window above.
-
-(defvar *during-incremental-search* nil)
-
-(in-package "HEMLOCK")
-
-(defun %i-search (string point trailer direction failure)
-  (unwind-protect			           ;<---- here's the change
-   (do* ((hi::*during-incremental-search* t)       ;<---- here's the change
-	 (curr-point (copy-mark point :temporary))
-	 (curr-trailer (copy-mark trailer :temporary))
-	 (next-char (get-key-event *editor-input* t)
-		    (get-key-event *editor-input* t)))
-	(nil)
-     (case (%i-search-char-eval next-char string point trailer direction failure)
-       (:cancel
-	(%i-search-echo-refresh string direction failure)
-	(unless (zerop (length string))
-	  (i-search-pattern string direction)))
-       (:return-cancel
-	(unless (zerop (length string)) (return :cancel))
-	(beep))
-       (:control-g
-	(when failure (return :control-g))
-	(%i-search-echo-refresh string direction nil)
-	(unless (zerop (length string))
-	  (i-search-pattern string direction))))
-     (move-mark point curr-point)
-     (move-mark trailer curr-trailer))
-   (hi::change-windows-if-mouse-moved)))	   ;<---- here's the change
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Fix Split Window to not change the current window.
-;;; That way, if the mouse is still in the current window,
-;;; everything's fine.  If the mouse ended up in the new
-;;; window, a mouse-entered-window event will handle the
-;;; change to the new window.
-
-; From filecoms.lisp:
-
-(defcommand "Split Window" (p)
-  "Make a new window by splitting the current window.
-   The new window is made the current window and displays starting at
-   the same place as the current window."
-  "Create a new window which displays starting at the same place
-   as the current window."
-  (declare (ignore p))
-  (let ((new (make-window (window-display-start (current-window)))))
-    (unless new (editor-error "Could not make a new window."))
-;    (setf (current-window) new)     <--- commented out this line
- ))
diff --git a/contrib/games/feebs/brains.lisp b/contrib/games/feebs/brains.lisp
deleted file mode 100644
index a5c953bc5d08161dd7210fb1d81224cff5ffa123..0000000000000000000000000000000000000000
--- a/contrib/games/feebs/brains.lisp
+++ /dev/null
@@ -1,58 +0,0 @@
-;;; -*- Mode: Lisp; Package: Sample-Brains; Log: feebs.log -*-
-;;;
-;;; Some Feeb brains.
-;;; Written by Skef Wholey and Scott Fahlman.
-;;;
-;;; The file Feebs.Lisp contains some feebs that are built-in for noise
-;;; purposes while running: RANDOM-BRAIN, WANDERING-BRAIN, and
-;;; CONSERVATIVE-BRAIN.  This file contains some other simply examples of
-;;; feebs.
-;;;
-
-(in-package "SAMPLE-BRAINS" :use '("LISP" "FEEBS"))
-
-
-;;; Experimental brain.  Like the built-in conservative brain, but without the
-;;; range limitation.
-;;;
-(defun cautious-brain (status proximity vision vision-left vision-right)
-  (declare (ignore vision-left vision-right))
-  (let ((stuff (my-square proximity)))
-    (cond ((and (consp stuff) (member :mushroom stuff :test #'eq))
-	   :eat-mushroom)
-	  ((and (consp stuff) (member :carcass stuff :test #'eq))
-	   :eat-carcass)
-	  ((and (ready-to-fire status)
-		(> (energy-reserve status) 30)
-		(dotimes (index (line-of-sight status))
-		  (let ((stuff (aref vision index)))
-		    (if (listp stuff)
-			(if (dolist (thing stuff)
-			      (if (feeb-image-p thing)
-				  (return t)))
-			    (return t))
-			(if (feeb-image-p stuff)
-			    (return t))))))
-	   :flame)
-	  ((and (not (eq (left-square proximity) :rock))
-		(> 0.2 (random 1.0)))
-	   :turn-left)
-	  ((and (not (eq (right-square proximity) :rock))
-		(> 0.2 (random 1.0)))
-	   :turn-right)
-	  ((not (ready-to-fire status))
-	   :wait)
-	  ((> (line-of-sight status) 0)
-	   :move-forward)
-	  ((not (eq (left-square proximity) :rock))
-	   :turn-left)
-	  ((not (eq (right-square proximity) :rock))
-	   :turn-right)
-	  (t
-	   :turn-around))))
-
-(define-feeb "Cau1" 'cautious-brain)
-(define-feeb "Cau2" 'cautious-brain)
-(define-feeb "Cau3" 'cautious-brain)
-
-
diff --git a/contrib/games/feebs/feebs.catalog b/contrib/games/feebs/feebs.catalog
deleted file mode 100644
index 3ae7ae87d00bb7f433f0065cf880ebc657a63da0..0000000000000000000000000000000000000000
--- a/contrib/games/feebs/feebs.catalog
+++ /dev/null
@@ -1,37 +0,0 @@
-[Name]		FEEBS
-
-[Description]	"Planet of the Feebs is a simulation game that is
-		intended as a training aid for beginning programmers in
-		Common Lisp.  It is loosely based on the "Maze War" game,
-		written by Jim Guyton, Bruce Malasky, and assorted others
-		at Xerox PARC.  In "Planet of the Feebs", however, the
-		players do not control their creatures by hand.  Instead,
-		they supply programs which control the creatures as they
-		move around the maze trying to zap one another.  The game
-		presents an open-ended challenge, and advanced players may
-		find themselves reaching deep into the AI bag of tricks as
-		they try to build ever more clever and adaptable creatures.
-
-[Author]	Skef Wholey, Scott Fahlman, Dan Kuokka, Jim Healy
-
-[Maintainer]	Members of the CMU Common Lisp Group.
-[Address]	Carnegie-Mellon University
-		Computer Science Department
-		Pittsburgh, PA 15213
-
-[Net Address]   Slisp@C.CS.CMU.EDU  (at CMU send mail to Gripe)
-
-[Copywrite Status] Public domain.
-
-[Files]		feebs.lisp, feebs.fasl, feebs.catalog, feebs.mss,
-		feebs.log, brains.lisp, brains.fasl, mazes.lisp
-
-[How to Get]	source /../spice/usr/slisp/library/rt/feebs/get-feebs.cmd
-
-[Portability]	Dependent on Version 10 of the X Window Manager.
-
-[Instructions]	Load feebs.fasl and brains.fasl.
-		call FEEBS:FEEBS.
-
-[Wish List]	Add egocentric display for one selected feeb.
-
diff --git a/contrib/games/feebs/feebs.lisp b/contrib/games/feebs/feebs.lisp
deleted file mode 100644
index b48340a562d7daf9302953afafc9f1b50618387a..0000000000000000000000000000000000000000
--- a/contrib/games/feebs/feebs.lisp
+++ /dev/null
@@ -1,1779 +0,0 @@
-;;; -*- Mode: Lisp; Package: Feebs; Log: feebs.log -*-
-;;;
-;;; Planet of the Feebs.
-;;; A somewhat educational simulation game.
-;;;
-;;; Written by Skef Wholey.
-;;; Modified by Scott Fahlman.
-;;; Modified by Dan Kuokka.
-;;; Modified by Jim Healy.
-
-
-(in-package "FEEBS" :use "LISP")
-
-;;; Export everything we want the players to get their hands on.
-
-(export '(*single-step* *delay*
-          *number-of-feebs* *game-length*
-	  *points-for-killing* *points-for-dying* *maze-i-size*
-	  *maze-j-size* *flame-energy* *mushroom-energy*
-	  *carcass-energy* *maximum-energy* *minimum-starting-energy*
-	  *maximum-starting-energy* *number-of-mushrooms*
-	  *number-of-mushroom-sites* *carcass-guaranteed-lifetime*
-	  *carcass-rot-probability* *fireball-dissipation-probability*
-	  *fireball-reflection-probability* *flame-recovery-probability*
-	  *slow-feeb-noop-switch* *slow-feeb-noop-factor*
-	  name facing i-position j-position peeking line-of-sight
-	  energy-reserve score kills ready-to-fire aborted last-move
-	  feeb-image-p feeb-image-name feeb-image-facing
-	  fireball-image-p fireball-image-direction
-	  my-square left-square right-square rear-square
-	  list-parameter-settings
-	  define-feeb feebs load-feebs north south east west))
-
-;;; Macro for computing whether a random event has occurred, given the
-;;; chance of occurrence as a ratio.
-
-(defmacro chance (ratio)
-  `(< (random (denominator ,ratio)) (numerator ,ratio)))
-
-;;; Directions
-
-(defconstant north 0)
-(defconstant east 1)
-(defconstant south 2)
-(defconstant west 3)
-
-;;; These control the user interface.
-
-(defvar *single-step* nil
-  "If non-null, wait for a mouse click at the end of each round.")
-
-(defvar *delay* nil
-  "If non-null, sleep this many seconds after each round.")
-
-(defvar *continue* t
-  "If null, quit the game immediately.")
-
-(defvar *feep-dead-feebs* nil
-  "If non-null, feep every-time a feep dies or is killed.")
-
-
-;;; Parameters that affect strategy of the game.
-
-(defvar *feeb-parameters* nil)
-
-(defmacro def-feeb-parm (name value doc)
-  `(progn
-    (defvar ,name ,value ,doc)
-    (pushnew ',name *feeb-parameters*)))
-
-(defun list-parameter-settings ()
-  (let ((settings nil))
-    (dolist (parm *feeb-parameters*)
-      (push (cons parm (symbol-value parm)) settings))
-    settings))
-
-
-;;; General game parameters:
-
-(def-feeb-parm *number-of-feebs* 10
-  "Number of feebs that will play in the game.")
-
-(def-feeb-parm *game-length* 1000
-  "Number of cycles in the simulation.")
-
-(def-feeb-parm *slow-feeb-noop-switch* t
-  "If non-null, each feeb has a chance of having its orders aborted in
-  proportion to the time it takes to produce them.")
-
-(def-feeb-parm *slow-feeb-noop-factor* .25
-  "If *slow-feeb-noop-switch* is non-null, a feeb's orders will be aborted
-  with probability equal to the product of this factor times the time
-  taken by this feeb divided by the total time taken by all feebs this turn.")
-
-(def-feeb-parm *feep-dead-feebs-volume* 1
-  "An integer between -7 and 7 which determines the volume of the feep
-   emitted when a feeb dies.  The softest volume is 0 and the loudest
-   is 7.  Negative volumes are usually not heard.")
-
-;;; Scoring:
-
-(def-feeb-parm *points-for-killing* 1
-  "Added to one's score for killing an opponent.")
-
-(def-feeb-parm *points-for-dying* -2
-  "Added to one's score for being killed or starving.")
-
-
-;;; Characteristics of the maze:
-
-(def-feeb-parm *maze-i-size* 32
-  "Number of rows in the maze.")
-
-(def-feeb-parm *maze-j-size* 32
-  "Number of columns in the maze.")
-
-(def-feeb-parm *number-of-mushrooms* 10
-  "Average number of mushrooms in the maze at any given time.")
-
-(def-feeb-parm *number-of-mushroom-sites* 0
-  "Number of places at which mushrooms might grow.")
-
-
-;;; Energies:
-
-(def-feeb-parm *flame-energy* 10
-  "Energy used when a feeb flames.")
-
-(def-feeb-parm *mushroom-energy* 50
-  "Energy gained when a mushroom is eaten.")
-
-(def-feeb-parm *carcass-energy* 30
-  "Energy gained by feeding on a carcass.")
-
-(def-feeb-parm *maximum-energy* 200
-  "The most energy a feeb can accumulate.")
-
-(def-feeb-parm *minimum-starting-energy* 50
-  "Smallest amount of energy a feeb will start with.")
-
-(def-feeb-parm *maximum-starting-energy* 100
-  "Greatest amount of energy a feeb will start with.")
-
-
-;;; Carcasses:
-
-(def-feeb-parm *carcass-guaranteed-lifetime* 3
-  "Minimum number of turns a carcass will hang around.")
-
-(def-feeb-parm *carcass-rot-probability* 1/3
-  "Chance of a carcass rotting away each turn after its guaranteed lifetime.")
-
-
-;;; Fireballs:
-
-(def-feeb-parm *fireball-dissipation-probability* 1/4
-  "Chance that a fireball will dissipate each turn after it is fired.")
-
-(def-feeb-parm *fireball-reflection-probability* 1/2
-  "Chance that a fireball will reflect when it hits a wall.")
-
-(def-feeb-parm *flame-recovery-probability* 1/2
-  "Chance a feeb will regain its ability to flame each turn after flaming once.")
-
-
-;;; Structures:
-
-;;; The Feeb structure contains all of the info relevant to a particular feeb.
-;;; The info available to the brain function is in the Status sub-structure.
-
-(defstruct (feeb
-	    (:print-function print-feeb)
-	    (:constructor make-feeb (id brain)))
-  id
-  brain
-  image
-  status
-  proximity
-  time
-  last-score
-  last-kills
-  (dead-p nil)
-  (turns-dead 0)
-  (turns-since-flamed 0)
-  (vision (make-array (max *maze-j-size* *maze-j-size*)))
-  (vision-left (make-array (max *maze-j-size* *maze-j-size*)))
-  (vision-right (make-array (max *maze-j-size* *maze-j-size*))))
-
-(defstruct (status
-	    (:conc-name nil)
-	    (:constructor make-status (name facing i-position j-position)))
-  name
-  facing
-  i-position
-  j-position
-  peeking
-  line-of-sight
-  (energy-reserve (+ *minimum-starting-energy*
-		     (random (- *maximum-starting-energy*
-				*minimum-starting-energy*))))
-  (score 0)
-  (kills 0)
-  (ready-to-fire t)
-  (aborted nil)
-  (last-move :dead))
-
-
-(defun print-feeb (structure stream depth)
-  (declare (ignore depth))
-  (format stream "#<Feeb ~S>"
-	  (name (feeb-status structure))))
-
-
-(defstruct (proximity
-	    (:conc-name nil))
-  my-square
-  rear-square
-  left-square
-  right-square)
-
-
-;;; These image structures are used to represent feebs and fireballs in
-;;; the sensory displays of other feebs.
-
-(defstruct (feeb-image
-	    (:print-function print-feeb-image)
-	    (:constructor make-feeb-image (name facing feeb)))
-  name
-  facing
-  feeb)
-
-(defun print-feeb-image (structure stream depth)
-  (declare (ignore depth))
-  (format stream "#<Feeb-Image of ~S facing ~S>"
-	  (feeb-image-name structure)
-	  (feeb-image-facing structure)))
-
-
-(defstruct (fireball-image
-	    (:print-function print-fireball-image)
-	    (:constructor make-fireball-image (direction owner i j di dj)))
-  direction
-  owner
-  i
-  j
-  di
-  dj
-  (new t))
-
-(defun print-fireball-image (structure stream depth)
-  (declare (ignore depth))
-  (format stream "#<Fireball moving ~S>"
-	  (fireball-image-direction structure)))
-
-(defstruct (position
-	    (:constructor make-position (i j))
-	    (:print-function print-position))
-  i
-  j)
-
-(defun print-position (structure stream depth)
-  (declare (ignore depth))
-  (format stream "#<Position (~A, ~A)>"
-	  (position-i structure)
-	  (position-j structure)))
-
-
-;;; Setting up the maze.
-
-;;; The default maze.
-;;; X represents a wall,
-;;; * represents a mushroom patch, and
-;;; e is a feeb entry point.
-
-(defparameter default-layout
-  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "Xe   *        XXXXXXX XXXXXXXXXX"
-    "XXXXX XXXXXXX XXXXXXX    * XXXXX"
-    "XXXXX XXXXXXX XXXXXXX XXX XXXXXX"
-    "XXXXX XXX XXX  XXXXXXeXXX XXXXXX"
-    "XXXXX XXX XXXX XXXXXXXXXX XXXXXX"
-    "XXXXX XXX XXXX XX XXXXXXX XXXXXX"
-    "XXXXX    *  XX XX XXXXXXX XXXXXX"
-    "XXXXX XXXX XXX XX*    *   XXXXXX"
-    "XX   *XXXX XXX XX XXXX XXXXXXXXX"
-    "XX XX XXXXeXXX XX XXXX XXXXXXXXX"
-    "XX XX XXXX XXX   * *  *        X"
-    "XX XX XXXX XXXXXXXX XXXXXXXXXXeX"
-    "XXeXX XXXX XXXXXXXX XXXXXXXXXX X"
-    "XX XX     *   *     XXXXXXXX   X"
-    "XX XXXXXXXXXXX XXXX XXXXXXXX XXX"
-    "XX eXXXXXXXXXX  XXXe  XXXXXX XXX"
-    "XX XXXXXXXXXXXXe XXXXXXXXXXX XXX"
-    "XX*  XXX XXXXXXX  XXXXXXXXXX XXX"
-    "XX X  XX XXXXXXXX eXXXXXXXXX XXX"
-    "XX XX  X XXXXXXXXX  XXXXXXXX XXX"
-    "X  XXX  *    XXXXXX*        *  X"
-    "X XXXXXX XXX XXXXXX XXXXXXXXXX X"
-    "X XXXXXX XXX XXXXXX X        X X"
-    "X XXXXXX XXX XXXXXX X XXXXXX X X"
-    "X    *     *     XX X X  *eX X X"
-    "XXXXX XXXX XXXXXXXX X XXX XX X X"
-    "XXXXX XXXX XXXXX   *X XXX XX X X"
-    "XXXXX XXXX XXXXX XX X    e   X X"
-    "XXXXX XXXX     e XX XXX*XXXXXX X"
-    "XXXXX XXXXXXXXXXXXX            X"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
-
-(defvar maze (make-array (list *maze-i-size* *maze-j-size*)
-			 :initial-element ()))
-
-(defvar *mushroom-sites*)
-(defvar *entry-points*)
-(defvar *number-of-entry-points*)
-
-(defun init-maze (maze-strings)
-  (setq *mushroom-sites* nil)
-  (setq *entry-points* nil)
-  (do ((rows maze-strings (cdr rows))
-       (i 0 (1+ i)))
-      ((null rows))
-    (let ((str (car rows)))
-      (dotimes (j (length str))
-	(setf (aref maze i j) nil)
-	(case (schar str j)
-	  (#\X
-	   (setf (aref maze i j) :rock))
-	  (#\*
-	   (push (make-position i j) *mushroom-sites*))
-	  (#\e
-	   (push (make-position i j) *entry-points*))
-	  (#\space
-	   )
-	  (t
-	   (error "Bad thing in maze spec: ~C." (schar str j)))))))
-  (setq *number-of-mushroom-sites* (length *mushroom-sites*))
-  (setq *number-of-entry-points* (length *entry-points*)))
-
-(defun create-mushrooms ()
-  (dotimes (i *number-of-mushrooms*)
-    (do ((site (nth (random *number-of-mushroom-sites*) *mushroom-sites*)
-	       (nth (random *number-of-mushroom-sites*) *mushroom-sites*)))
-	((null (aref maze (position-i site) (position-j site)))
-	 (setf (aref maze (position-i site) (position-j site)) :mushroom)))))
-
-
-;;; Setting up the feebs.
-
-(defvar *feebs* nil
-  "A list of all the feebs in the current game.")
-
-(defvar *next-feeb-id* 0
-  "A counter used to assign a unique numerical code to each feeb.")
-
-(defun create-feeb (name brain)
-  (let* ((feeb (make-feeb *next-feeb-id* brain))
-	 (facing (random 4))
-	 (position (pick-random-entry-point)))
-    (setf (feeb-image feeb)
-	  (make-feeb-image name facing feeb))
-    (setf (feeb-status feeb)
-	  (make-status name facing (position-i position)
-		       (position-j position)))
-    (setf (feeb-proximity feeb) (make-proximity))
-    (push feeb *feebs*)
-    (incf *next-feeb-id*)
-    (setf (aref maze (position-i position) (position-j position))
-	  (feeb-image feeb))
-    feeb))
-
-;;; Start at some randomly chosen entry point.  If this one is occupied,
-;;; scan successive entry points until a winner is found.  Circle back
-;;; to start of list if necessary.
-
-(defun pick-random-entry-point ()
-  (do ((points (nthcdr (random *number-of-entry-points*) *entry-points*)
-	       (cdr points)))
-      (nil)
-    (when (null points)
-	  (setq points *entry-points*))
-    (when (null (aref maze (position-i (car points))
-		           (position-j (car points))))
-	  (return (car points)))))
-
-
-;;; Define-Feeb builds a list of feebs to create.  Create-Feebs actually
-;;; builds the feebs on this list.
-
-(defvar *feebs-to-be* nil)
-
-(defun define-feeb (name brain)
-  (push (cons name brain) *feebs-to-be*))
-
-(defun create-feebs ()
-  (when (> (length *feebs-to-be*) *number-of-entry-points*)
-	(error "More feebs than entry points."))
-  (setq *feebs* nil)
-  (setq *next-feeb-id* 0)
-  (dolist (feeb-spec (reverse *feebs-to-be*))
-    (create-feeb (car feeb-spec) (cdr feeb-spec))))
-
-
-;;; Vision calculation.
-
-;;; Some macros for directional arithmetic.
-
-(defmacro left-of (facing)
-  `(mod (+ ,facing 3) 4))
-
-(defmacro right-of (facing)
-  `(mod (+ ,facing 1) 4))
-
-(defmacro behind (facing)
-  `(mod (+ ,facing 2) 4))
-
-;;; These guys tell us offsets given an orientation.
-
-(defconstant facing-vector-1 '#(-1 0 1 0))
-(defconstant facing-vector-2 '#(0 1 0 -1))
-
-(defmacro forward-di (facing)
-  `(svref facing-vector-1 ,facing))
-
-(defmacro forward-dj (facing)
-  `(svref facing-vector-2 ,facing))
-
-(defmacro left-di (facing)
-  `(forward-di (left-of ,facing)))
-
-(defmacro left-dj (facing)
-  `(forward-dj (left-of ,facing)))
-
-(defmacro right-di (facing)
-  `(forward-di (right-of ,facing)))
-
-(defmacro right-dj (facing)
-  `(forward-dj (right-of ,facing)))
-
-(defmacro behind-di (facing)
-  `(forward-di (behind ,facing)))
-
-(defmacro behind-dj (facing)
-  `(forward-dj (behind ,facing)))
-
-(defun compute-vision (feeb)
-  (let* ((status (feeb-status feeb))
-	 (proximity (feeb-proximity feeb))
-	 (vision (feeb-vision feeb))
-	 (vision-left (feeb-vision-left feeb))
-	 (vision-right (feeb-vision-right feeb))
-	 (facing (facing status))
-	 vision-di
-	 vision-dj
-	 (i (i-position status))
-	 (j (j-position status)))
-    ;; First fill in proximity info.
-    (setf (my-square proximity)
-	  (aref maze i j))
-    (setf (left-square proximity)
-	  (aref maze (+ i (left-di facing)) (+ j (left-dj facing))))
-    (setf (right-square proximity)
-	  (aref maze (+ i (right-di facing)) (+ j (right-dj facing))))
-    (setf (rear-square proximity)
-	  (aref maze (+ i (behind-di facing)) (+ j (behind-dj facing))))
-    ;; The vision vector starts in the square the feeb is facing.
-    (setq i (+ i (forward-di facing)))
-    (setq j (+ j (forward-dj facing)))
-    ;; Figure out which direction to scan in.
-    (case (peeking status)
-      (nil)
-      (:left (setq facing (left-of facing)))
-      (:right (setq facing (right-of facing))))
-    (setq vision-di (forward-di facing))
-    (setq vision-dj (forward-dj facing))
-    (do* ((i i (+ i vision-di))
-	  (j j (+ j vision-dj))
-	  (left-wall-i (+ i (left-di facing)) (+ left-wall-i vision-di))
-	  (left-wall-j (+ j (left-dj facing)) (+ left-wall-j vision-dj))
-	  (right-wall-i (+ i (right-di facing)) (+ right-wall-i vision-di))
-	  (right-wall-j (+ j (right-dj facing)) (+ right-wall-j vision-dj))
-	  (index 0 (1+ index)))
-	 ((eq (aref maze i j) :rock)
-	  (setf (line-of-sight status) index))
-      (setf (aref vision index) (aref maze i j))
-      (setf (aref vision-left index)
-	    (side-imagify (aref maze left-wall-i left-wall-j)
-			  (right-of facing)))
-      (setf (aref vision-right index)
-	    (side-imagify (aref maze right-wall-i right-wall-j)
-			  (left-of facing))))))
-
-;;; Compute the info to be put into the vision-left and vision-right vectors.
-;;; A peeking feeb must be facing in the specified direction in order to count.
-
-(defun side-imagify (stuff facing)
-  (cond ((eq stuff :rock) :rock)
-	((and (feeb-image-p stuff)
-	      (= facing (feeb-image-facing stuff))
-	      (peeking (feeb-status (feeb-image-feeb stuff))))
-	 :peeking)
-	((listp stuff)
-	 (do ((stuff stuff (cdr stuff)))
-	     ((null stuff) nil)
-	   (when (and (feeb-image-p (car stuff))
-		      (= facing (feeb-image-facing (car stuff)))
-		      (peeking (feeb-status (feeb-image-feeb (car stuff)))))
-		 (return :peeking))))
-	(t nil)))
-
-
-;;; Movement.
-
-;;; Each turn, the following stuff has to happen:
-;;;	1. Bump the turn counter; end the game if we should.
-;;;	2. Maybe grow some mushrooms.
-;;;	3. Maybe disappear some carcasses.
-;;;	4. Move fireballs around.
-;;;	5. See if any feebs have starved.
-;;;	6. See if any feebs can flame again.
-;;;	7. Compute vision and stuff for feebs.
-;;;	8. Collect the feebs' moves.
-;;;	9. Do the feeb's moves.
-
-(defvar *current-turn* 0)
-
-(defvar *mushrooms-alive*)
-(defvar *dead-feebs*)
-(defvar *fireballs-flying*)
-
-(defun init-play ()
-  (setq *mushrooms-alive* *number-of-mushrooms*)
-  (setq *dead-feebs* nil)
-  (setq *fireballs-flying* nil))
-
-(defun play ()
-  (dotimes (*current-turn* *game-length*)
-    (play-one-turn)
-    (when (plusp (x:xpending)) (system:server))
-    (redisplay)
-    (display-status)
-    (cond ((not *continue*) (return-from play))
-	  (*single-step* (get-mouse-buttonpress))
-	  (*delay* (sleep-with-server *delay*)))))
-
-(defun play-one-turn ()
-  ;; Grow some mushrooms:
-  (dotimes (i (- *number-of-mushrooms* *mushrooms-alive*))
-    (let* ((site (nth (random *number-of-mushroom-sites*) *mushroom-sites*))
-	   (i (position-i site))
-	   (j (position-j site))
-	   (stuff (aref maze (position-i site) (position-j site))))
-      (cond ((null stuff)
-	     (place-object :mushroom i j))
-	    ((atom stuff)
-	     (unless (eq stuff :mushroom)
-	       (place-object :mushroom i j)))
-	    (t
-	     (unless (member :mushroom stuff)
-	       (place-object :mushroom i j))))))
-  ;; Rot some carcasses:
-  (dolist (feeb *dead-feebs*)
-    (incf (feeb-turns-dead feeb))
-    (when (> (feeb-turns-dead feeb) *carcass-guaranteed-lifetime*)
-      (when (chance *carcass-rot-probability*)
-	(delete-object :carcass
-		       (i-position (feeb-status feeb))
-		       (j-position (feeb-status feeb)))
-	(setq *dead-feebs* (delete feeb *dead-feebs*))
-	(reincarnate-feeb feeb))))
-  ;; Move some fireballs:
-  (dolist (fireball *fireballs-flying*)
-    (move-one-fireball fireball))
-  ;; Starve some feebs:
-  (dolist (feeb *feebs*)
-    (unless (feeb-dead-p feeb)
-      (when (<= (decf (energy-reserve (feeb-status feeb))) 0)
-	(kill-feeb feeb))))
-  ;; Let some feebs regain the power to flame:
-  (dolist (feeb *feebs*)
-    (unless (feeb-dead-p feeb)
-      (unless (ready-to-fire (feeb-status feeb))
-	(incf (feeb-turns-since-flamed feeb))
-	(when (and (> (feeb-turns-since-flamed feeb) 1)
-		   (chance *flame-recovery-probability*))
-	  (setf (ready-to-fire (feeb-status feeb)) t)))))
-  ;; Compute vision for all the feebs.
-  (dolist (feeb *feebs*)
-    (unless (feeb-dead-p feeb)
-      (compute-vision feeb)))
-  ;; Collect all the feebs' moves, keeping track of the time each one takes.
-  (let ((total-time 1))
-    (dolist (feeb *feebs*)
-      (unless (feeb-dead-p feeb)
-	(let ((time (get-internal-real-time)))
-	  (setf (last-move (feeb-status feeb))
-		(funcall (feeb-brain feeb)
-			 (feeb-status feeb)
-			 (feeb-proximity feeb)
-			 (feeb-vision feeb)
-			 (feeb-vision-left feeb)
-			 (feeb-vision-right feeb)))
-	  (setq time (- (get-internal-real-time) time))
-	  (incf total-time time)
-	  (setf (feeb-time feeb) time))))
-    ;; Do all the feebs' moves, or perhaps abort the move according
-    ;; to the time taken by the feeb.
-    (setq total-time (float total-time))
-    (dolist (feeb *feebs*)
-      (unless (feeb-dead-p feeb)
-	(cond ((and *slow-feeb-noop-switch*
-		    (< (random 1.0)
-		       (* *slow-feeb-noop-factor*
-			  (/ (float (feeb-time feeb)) total-time))))
-	       (setf (aborted (feeb-status feeb)) t))
-	      (t (setf (aborted (feeb-status feeb)) nil)
-		 (do-move feeb (last-move (feeb-status feeb)))))
-	;; Make the image consistent with the feeb.
-	(setf (feeb-image-facing (feeb-image feeb))
-	      (facing (feeb-status feeb)))))))
-
-(defun move-one-fireball (fireball)
-  (let ((i (fireball-image-i fireball))
-	(j (fireball-image-j fireball)))
-    ;; Remove fireball from current square, unless it is new.
-    (if (fireball-image-new fireball)
-	(setf (fireball-image-new fireball) nil)
-	(delete-object fireball i j))
-    ;; The fireball might dissipate.
-    (when (chance *fireball-dissipation-probability*)
-	  (setq *fireballs-flying* (delete fireball *fireballs-flying*))
-	  (return-from move-one-fireball nil))
-    ;; Now move it to new coordinates.
-    (incf i (fireball-image-di fireball))
-    (incf j (fireball-image-dj fireball))
-    ;; If it hits rock, either reflect or dissipate.
-    (when (eq (aref maze i j) :rock)
-      (cond ((chance *fireball-reflection-probability*)
-	     (setf (fireball-image-di fireball)
-		   (- (fireball-image-di fireball)))
-	     (setf (fireball-image-dj fireball)
-		   (- (fireball-image-dj fireball)))
-	     (setf (fireball-image-direction fireball)
-		   (behind (fireball-image-direction fireball)))
-	     (setq i (fireball-image-i fireball))
-	     (setq j (fireball-image-j fireball)))
-	    (t (setq *fireballs-flying*
-		     (delete fireball *fireballs-flying*))
-	       (return-from move-one-fireball nil))))
-    ;; Now put the fireball into the new square.
-    (setf (fireball-image-i fireball) i)
-    (setf (fireball-image-j fireball) j)
-    (place-object fireball i j)
-    ;; And destroy whatever is there.
-    (let ((stuff (aref maze i j)))
-      ;; If there is other stuff in the square, the contents will be a list.
-      (when (listp stuff)
-	    (dolist (thing stuff)
-	      (cond ((fireball-image-p thing) nil)
-		    ((eq thing :mushroom)
-		     (delete-object :mushroom i j))
-		    ((feeb-image-p thing)
-		     (setq thing (feeb-image-feeb thing))
-		     (score-kill fireball thing))))))))
-
-;;; The fireball kills the feeb.  Update score for killer and victims.
-;;; No credit for the kill if you shoot yourself.
-
-(defun score-kill (fireball feeb)
-  (unless (eq (fireball-image-owner fireball) feeb)
-	  (incf (score (feeb-status (fireball-image-owner fireball)))
-		*points-for-killing*)
-	  (incf (kills (feeb-status (fireball-image-owner fireball)))))
-  (kill-feeb feeb))
-
-
-;;; Doing feeb moves.
-
-(defun do-move (feeb move)
-  (let ((status (feeb-status feeb)))
-    ;; Redisplay the feeb's old square, whatever the action is.
-    (queue-redisplay (i-position status) (j-position status))
-    ;; If feeb was peeking last move, redisplay the square it is facing
-    ;; to get rid of the periscope.
-    (when (peeking status)
-      (queue-redisplay (+ (i-position status) (forward-di (facing status)))
-		       (+ (j-position status) (forward-dj (facing status)))))
-    ;; Peeking gets undone every move.
-    (setf (peeking status) nil)
-    (case move
-      (:turn-left
-       (setf (facing status) (left-of (facing status))))      
-      (:turn-right
-       (setf (facing status) (right-of (facing status))))
-      (:turn-around
-       (setf (facing status) (behind (facing status))))
-      (:move-forward
-       (let* ((facing (facing status))
-	      (old-i (i-position status))
-	      (old-j (j-position status))
-	      (new-i (+ (forward-di facing) old-i))
-	      (new-j (+ (forward-dj facing) old-j))
-	      (stuff (aref maze new-i new-j)))
-	 (when (eq stuff :rock) (return-from do-move nil))
-	 (delete-object (feeb-image feeb) old-i old-j)
-	 (setf (i-position status) new-i)
-	 (setf (j-position status) new-j)
-	 (place-object (feeb-image feeb) new-i new-j)
-	 ;; Look for a fireball in the destination square.
-	 (when (fireball-image-p stuff)
-	   (score-kill stuff feeb)
-	   (return-from do-move nil))
-	 (when (consp stuff)
-	   (dolist (thing stuff)
-	     (when (fireball-image-p thing)
-	       (score-kill thing feeb)
-	       (return-from do-move nil))))))
-      (:flame
-       (when (ready-to-fire status)
-	 (let* ((facing (facing status))
-		(i (i-position status))
-		(j (j-position status))
-		(fireball (make-fireball-image
-			   facing feeb i j
-			   (forward-di facing) (forward-dj facing))))
-	   ;; Queue the fireball, marked as new, but don't put it on map yet.
-	   (push fireball *fireballs-flying*)
-	   (decf (energy-reserve status) *flame-energy*)
-	   (setf (ready-to-fire status) nil)
-	   (setf (feeb-turns-since-flamed feeb) 0))))
-      (:eat-mushroom
-       (let* ((i (i-position status))
-	      (j (j-position status))
-	      (stuff (aref maze i j)))
-	 (when (and (listp stuff)
-		    (member :mushroom stuff))
-	   (delete-object :mushroom i j)
-	   (setf (energy-reserve status)
-		 (min (+ (energy-reserve status) *mushroom-energy*)
-		      *maximum-energy*)))))
-      (:eat-carcass
-       (let* ((i (i-position status))
-	      (j (j-position status))
-	      (stuff (aref maze i j)))
-	 (when (and (listp stuff)
-		    (member :carcass stuff))
-	   (setf (energy-reserve status)
-		 (min (+ (energy-reserve status) *carcass-energy*)
-		      *maximum-energy*)))))
-      (:peek-left
-       (unless (eq (aref maze (+ (i-position status)
-				 (forward-di (facing status)))
-			      (+ (j-position status)
-				 (forward-dj (facing status))))
-		   :rock)
-	       (setf (peeking status) :left)))
-      (:peek-right
-       (unless (eq (aref maze (+ (i-position status)
-				 (forward-di (facing status)))
-			      (+ (j-position status)
-				 (forward-dj (facing status))))
-		   :rock)
-	       (setf (peeking status) :right)))
-      (:wait
-       ))))
-
-;;; Movement/Redisplay interface.
-
-(defun delete-object (thing i j)
-  (when (eq thing :mushroom)
-    (decf *mushrooms-alive*))
-  (let ((stuff (aref maze i j)))
-    (cond ((atom stuff)
-	   (setf (aref maze i j) nil))
-	  ((null (cddr stuff))
-	   (setf (aref maze i j)
-		 (if (eq (car stuff) thing)
-		     (cadr stuff)
-		     (car stuff))))
-	  (t
-	   (setf (aref maze i j) (delete thing stuff)))))
-  (queue-redisplay i j))
-
-(defun place-object (thing i j)
-  (when (eq thing :mushroom)
-    (incf *mushrooms-alive*))
-  (let ((stuff (aref maze i j)))
-    (cond ((null stuff)
-	   (setf (aref maze i j) thing))
-	  ((consp stuff)
-	   (setf (aref maze i j) (cons thing stuff)))
-	  (t
-	   (setf (aref maze i j) (list thing stuff)))))
-  (queue-redisplay i j))
-
-(defun reincarnate-feeb (feeb)
-  (let ((position (nth (random (length *entry-points*)) *entry-points*))
-	(facing (random 4))
-	(status (feeb-status feeb)))
-    (place-object (feeb-image feeb)
-		  (position-i position) (position-j position))
-    (setf (i-position status) (position-i position))
-    (setf (j-position status) (position-j position))
-    (setf (facing status) facing)
-    (setf (feeb-dead-p feeb) nil)
-    (setf (ready-to-fire status) t)
-    (setf (energy-reserve status)
-	  (+ *minimum-starting-energy*
-	     (random (- *maximum-starting-energy*
-			*minimum-starting-energy*))))
-    (setf (last-move status) :dead)))
-
-(defun kill-feeb (feeb)
-  (push feeb *dead-feebs*)
-  (setf (feeb-dead-p feeb) t)
-  (setf (feeb-turns-dead feeb) 0)
-  (setf (energy-reserve (feeb-status feeb)) 0)
-  (let* ((status (feeb-status feeb))
-	 (i (i-position status))
-	 (j (j-position status)))
-    (incf (score status) *points-for-dying*)
-    ;; Clean up the periscope when a peeking feeb dies.
-    (when (peeking status)
-      (queue-redisplay (+ i (forward-di (facing status)))
-		       (+ j (forward-dj (facing status)))))
-    (delete-object (feeb-image feeb) i j)
-    (place-object :carcass i j)
-    (when *feep-dead-feebs*
-      (feep *feep-dead-feebs-volume*))))
-
-;;; Display routines for Feebs under X (Version 10).  All display
-;;; primitives used in this program are defined here.  This was
-;;; written for a monochrome display but could easily be adapted
-;;; for a color display.
-
-(defvar *birds-eye-window*)
-(defvar *status-window*)
-(defvar *banner-window*)
-
-(defvar *status-font-id*)
-(defvar *banner-font-id*)
-
-(defparameter bordercolor nil)
-(defparameter background nil)
-(defparameter borderwidth 1)
-
-(defparameter birds-eye-width 704)
-(defparameter birds-eye-height 704)
-(defparameter birds-eye-x 36)
-(defparameter birds-eye-y 60)
-
-(defparameter status-window-width 248)
-(defparameter status-window-height 704)
-(defparameter status-window-x 740)
-(defparameter status-window-y 60)
-
-(defparameter banner-window-width 952)
-(defparameter banner-window-height 27)
-(defparameter banner-window-x 36)
-(defparameter banner-window-y 32)
-
-(defparameter feebs-font "8x13")
-(defparameter *char-width* 8)
-(defparameter *char-height* 13)
-
-(defparameter banner-font "micr25")
-(defparameter feebs-banner
-  "Planet of the Feebs: A Somewhat Educational Simulation Game")
-
-(defconstant redisplay-scale 22)
-(defconstant pixel-character #\X)
-
-(defun init-graphics ()
-  (x:open-console)
-  (setf bordercolor (x:blackpixmap))
-  (setf background (x:whitepixmap))
-  (setq *status-font-id* (x:xgetfont feebs-font))
-  (setq *banner-font-id* (x:xgetfont banner-font)))
-
-(defun tini-graphics ()
-  (x:xfreefont *status-font-id*)
-  (x:xfreefont *banner-font-id*))
-
-(defmacro create-window (x y width height)
-  (declare (fixnum x y width height))
-  `(x:xcreatewindow (x:rootwindow) ,x ,y ,width ,height borderwidth
-		  bordercolor background))
-
-(defmacro prepare-for-xevents (window)
-  `(progn (x:xselectinput ,window important-xevents)
-     (system:add-xwindow-object ,window ,window *feebs-windows*)))
-
-(defmacro display-window (window)
-  `(x:xmapwindow ,window))
-
-(defmacro delete-window (window)
-  `(x:xdestroywindow ,window))
-
-;;; Window event control section.  Lots of hair necessary to deal
-;;; with funny stuff of X windows.  Ignore it if you want to, but
-;;; it won't go away.
-
-(defconstant important-xevents
-  (logior x:exposeregion x:exposewindow x:buttonpressed x:keypressed))
-
-(defvar *buttonpressed-flag* nil)
-(defconstant blow-away-feebs-character #\q)
-(defconstant single-step-feebs-character #\s)
-(defconstant auto-mode-feebs-character #\a)
-
-;;; Create an object set of windows to receive certain events from X.
-
-(defvar *feebs-windows* (system:make-object-set "Feebs Windows"))
-
-;;; Sleep-with-server sleeps the appropriate amount of time but
-;;; still processes xevents with the system server.
-
-(defun sleep-with-server (time)
-  (let ((end (+ (get-internal-real-time)
-		(truncate (* time internal-time-units-per-second)))))
-    (loop
-      (let ((left (- end (get-internal-real-time))))
-	(unless (plusp left) (return nil))
-	(system:server (* left (truncate 1000 internal-time-units-per-second)))))))
-
-;;; Redraws a specific window if an exposure event (either exposewindow
-;;; or exposeregion) occurs.
-
-(defun redraw-all-exposed-regions (object width height x y subwindow)
-  (declare (ignore width height x y subwindow))
-  (cond ((eq object *birds-eye-window*)
-	 (redisplay-all))
-	((eq object *status-window*)
-	 (display-all-status))
-	((eq object *banner-window*)
-	 (redisplay-banner))))
-
-(defun redraw-all-exposed-windows (object subwindow)
-  (declare (ignore object subwindow))
-  (cond ((eq object *birds-eye-window*)
-	 (redisplay-all))
-	((eq object *status-window*)
-	 (display-all-status))
-	((eq object *banner-window*)
-	 (redisplay-banner))))
-
-;;; Sets the buttonpressed flag to true when a mouse button is pressed.
-
-(defun set-buttonpressed-flag (object mod-bits scan-code x y
-				      subwindow time abs-x abs-y)
-  (declare (ignore object mod-bits scan-code x y subwindow time abs-x abs-y))
-  (setq *buttonpressed-flag* t))
-
-;;; Check which key was pressed and do the appropriate thing.
-
-(defun check-keypressed (object mod-bits scan-code x y
-				subwindow time abs-x abs-y)
-  (declare (ignore object x y subwindow time abs-x abs-y))
-  (cond ((eq (hemlock-internals::translate-character scan-code mod-bits)
-	     blow-away-feebs-character)
-	 (format t "Feebs was interrupted at turn ~D.~%" *current-turn*)
-	 (setq *continue* nil))
-	((eq (hemlock-internals::translate-character scan-code mod-bits)
-	     single-step-feebs-character)
-	 (setq *single-step* t))
-	((eq (hemlock-internals::translate-character scan-code mod-bits)
-	     auto-mode-feebs-character)
-	 (setq *single-step* nil))))
-
-;;; Stops and waits until any one of the mouse buttons is pressed.
-
-(defun get-mouse-buttonpress ()
-  (loop
-    (when *buttonpressed-flag*
-      (setq *buttonpressed-flag* nil)
-      (return))
-    (system:server)))
-
-;;; Tell the X server which functions will handle which events when
-;;; they occur.
-
-(x:serve-exposeregion  *feebs-windows* #'redraw-all-exposed-regions)
-(x:serve-exposewindow  *feebs-windows* #'redraw-all-exposed-windows)
-(x:serve-buttonpressed *feebs-windows* #'set-buttonpressed-flag)
-(x:serve-keypressed    *feebs-windows* #'check-keypressed)
-
-;;; Rings the keyboard bell.
-
-(defun feep (feep-volume)
-  (x:xfeep feep-volume))
-
-;;; The following section of code is used to manipulate an array
-;;; of 16-bit unsigned integers (a "bit-array").  This array
-;;; can be encoded with a graphic pattern from strings with
-;;; "X"'s in them and then passed to X window manager routines to 
-;;; create a bitmap for display.
-
-;;; Computes the number of 16-bit unsigned integers needed for
-;;; the bit-array.
-
-(defmacro bit-array-size (width height)
-  (declare (fixnum width height))
-  `(* (truncate (+ ,width 15) 16) ,height))
-
-;;; Computes how many bits each line of the bit-array has.
-
-(defmacro bit-array-line-len (width)
-  (declare (fixnum width))
-  `(truncate (+ ,width 15) 16))
-
-;;; Allows referencing of individual bits in the bit-array.
-
-(defun bit-array-ref (array x y width)
-  (declare (fixnum x y width))
-  (multiple-value-bind (words bits) (truncate x 16)
-    (ldb (byte 1 bits)
-	 (aref array
-	       (+ (* y (bit-array-line-len width))
-		  words))))))
-
-;;; Defines bit-array-ref as a setfable form to allow setting
-;;; of the individual bits in the bit-array.
-
-(defsetf bit-array-ref (array x y width) (new)
-  (declare (fixnum x y width))
-  (let ((words (gensym))
-	(bits (gensym)))
-    `(multiple-value-bind (,words ,bits) (truncate ,x 16)
-       (setf (ldb (byte 1 ,bits) 
-		  (aref ,array
-			(+ (* ,y (bit-array-line-len ,width))
-			   ,words)))
-	     ,new))))
-
-;;; Creates an array of 16-bit unsigned integers with the bits
-;;; in this array set to 1 or 0 according to where there is an
-;;; "X" in the strings.  This bit-array can then be passed to
-;;; the X routines to create a bitmap.
-
-(defun make-bit-array-from-strings (strings width height)
-  (declare (list strings) (integer width height))
-  (let ((bit-array (make-array (bit-array-size width height)
-				 :element-type '(unsigned-byte 16)
-				 :initial-element 0)))
-    (do ((strings strings (cdr strings))
-	 (row 0 (1+ row)))
-	((eq row height))
-      (let ((string (car strings)))
-	(declare (simple-string string))
-	(dotimes (column width)
-	  (if (char= (schar string column) pixel-character)
-	      (setf (bit-array-ref bit-array column row width) 1)))))
-    bit-array))
-
-(defmacro make-bitmap (bit-array width height)
-  (declare (fixnum width height))
-  `(x:xstorebitmap ,width ,height ,bit-array))
-
-(defmacro delete-bitmap (bitmap)
-  `(x:xfreebitmap ,bitmap))
-
-;;; Rotates the image in the bit-array to face in the
-;;; specified direction relative to the current.
-
-(defun rotate-bit-array (bit-array width height direction)
-  (declare (fixnum width height))
-  (if (eq width height)
-      (let ((rotated-bit-array (make-array (bit-array-size width height)
-				    :element-type '(unsigned-byte 16)
-				    :initial-element 0)))
-	(cond ((eq direction east)
-	       (dotimes (j height)
-		 (dotimes (i width)
-		   (if (eq (bit-array-ref bit-array i j width) 1)
-		       (setf (bit-array-ref rotated-bit-array 
-					    (- width j) i width) 1)))))
-	      ((eq direction south)
-	       (dotimes (j height)
-		 (dotimes (i width)
-		   (if (eq (bit-array-ref bit-array i j width) 1)
-		       (setf (bit-array-ref rotated-bit-array
-					    (- width i) (- height j)
-					    width) 1)))))
-	      ((eq direction west)
-	       (dotimes (j height)
-		 (dotimes (i width)
-		   (if (eq (bit-array-ref bit-array i j width) 1)
-		       (setf (bit-array-ref rotated-bit-array
-					    j (- height i) width) 1))))))
-	rotated-bit-array)))
-
-;;; Completely shades in a rectangular region of the screen at
-;;; x and y coordinates and specified width and height.  (or
-;;; shades the region white if :undraw is t.)
-
-(defmacro draw-rectangle (window x y width height &key (undraw nil))
-  (declare (fixnum x y width height))
-  `(x:xpixset ,window ,x ,y ,width ,height (if ,undraw x:whitepixel x:blackpixel)))
-
-;;; Draws an X bitmap to the screen at x and y coordinates with
-;;; the specified width and height.
-
-(defmacro draw-bitmap (window x y width height bitmap)
-  (declare (fixnum x y width height))
-  `(x:xpixfill ,window ,x ,y ,width ,height x:blackpixel ,bitmap
-	     x:gxclear x:allplanes))
-
-;;; Prints a string of characters in the specified location.
-
-(defmacro draw-string (window x y string)
-  (declare (fixnum x y) (simple-string string))
-  `(x:xtext ,window ,x ,y ,string (length ,string)
-	  *status-font-id* x:blackpixel x:whitepixel))
-
-;;; Prints a feeb-id in inverse video in the specified location.
-
-(defmacro draw-feeb-id (window x y string)
-  (declare (fixnum x y) (simple-string string))
-  `(x:xtext ,window ,x ,y ,string (length ,string)
-	  *status-font-id* x:whitepixel x:blackpixel))
-
-
-;;; Redisplay functions.  Control the movement of the feebs in the
-;;; maze window.
-
-(defun init-banner ()
-  (setq *banner-window*
-	(create-window banner-window-x banner-window-y
-		       banner-window-width banner-window-height))
-  (x:xsync 1)
-  (prepare-for-xevents *banner-window*)
-  (display-window *banner-window*)
-  (redisplay-banner))
-
-(defun tini-banner ()
-  (x:xflush)
-  (delete-window *banner-window*))
-
-(defun init-redisplay ()
-  (setq *birds-eye-window* 
-	(create-window birds-eye-x birds-eye-y birds-eye-width birds-eye-height))
-  (init-bitmaps)
-  (x:xsync 1)
-  (prepare-for-xevents *birds-eye-window*)
-  (display-window *birds-eye-window*)
-  (redisplay-all))
-
-(defun tini-redisplay ()
-  (x:xflush)
-  (delete-window *birds-eye-window*)
-  (tini-bitmaps))
-
-(defun redisplay-banner ()
-  (x:xtextpad *banner-window* 40 3 feebs-banner 59 *banner-font-id*
-	      0 8 x:blackpixel x:whitepixel x:gxcopy x:allplanes))
-
-(defvar *redisplay-map* (make-array (list *maze-i-size* *maze-j-size*)
-				    :element-type 'bit))
-
-(defvar *redisplay-hints* (make-array *maze-i-size*))
-
-(defun queue-redisplay (i j)
-  (setf (aref *redisplay-map* i j) 1)
-  (setf (aref *redisplay-hints* i) t))
-
-(defun redisplay ()
-  (dotimes (i *maze-i-size*)
-    (when (aref *redisplay-hints* i)
-      (setf (aref *redisplay-hints* i) nil)
-      (dotimes (j *maze-j-size*)
-	(when (/= (aref *redisplay-map* i j) 0)
-	  (setf (aref *redisplay-map* i j) 0)
-	  (redisplay-square i j)))))
-  (dolist (feeb *feebs*)
-    (draw-periscope feeb)))
-
-(defun redisplay-all ()
-  (dotimes (i *maze-i-size*)
-    (setf (aref *redisplay-hints* i) nil)
-    (dotimes (j *maze-j-size*)
-      (setf (aref *redisplay-map* i j) 0)
-      (redisplay-square i j)))
-  (dolist (feeb *feebs*)
-    (unless (feeb-dead-p feeb)
-      (draw-periscope feeb))))
-
-(defun redisplay-square (i j)
-  (let ((stuff (aref maze i j))
-	(display-x (* j redisplay-scale))
-	(display-y (* i redisplay-scale)))
-    (if (eq stuff :rock)
-      (draw-rectangle *birds-eye-window* display-x display-y
-		      redisplay-scale redisplay-scale)
-      (draw-rectangle *birds-eye-window* display-x display-y
-		      redisplay-scale redisplay-scale :undraw t))
-    (if (consp stuff)
-	(dolist (substuff stuff)
-	  (display-one-item substuff display-x display-y))
-	(display-one-item stuff display-x display-y))))
-
-(defun display-one-item (stuff display-x display-y)
-  (cond ((null stuff)
-	 )
-	((eq stuff :rock)
-	 )
-	((eq stuff :mushroom)
-	 (draw-mushroom display-x display-y))
-	((eq stuff :carcass)
-	 (draw-carcass display-x display-y))
-	((feeb-image-p stuff)
-	 (setq stuff (feeb-image-feeb stuff))
-	 (draw-feeb display-x display-y stuff))
-	((fireball-image-p stuff)
-	 (draw-fireball display-x display-y
-			(fireball-image-direction stuff)))
-	(t
-	 (error "Some strange thing in the maze: ~S." stuff))))
-
-
-;;; String-maps for images.  These will be transformed into bitmaps
-;;; that can be displayed in a small area.  The scale of the string-
-;;; maps is given by the variable redisplay-scale.
-
-(defvar *mushroom-bitmap*)
-(defvar *carcass-bitmap*)
-(defvar *fireball-bitmaps* (make-array 4))
-
-(defun init-bitmaps ()
-  (setq *mushroom-bitmap*
-	(make-bitmap
-	 (make-bit-array-from-strings
-	  '("                      "
-	    "                      "
-	    "                      "
-	    "                      "
-	    "        XXXXXXX       "
-	    "     XXXX X X XXX     "
-	    "    XX X X X X X X    "
-	    "   XX X X X X X X X   "
-	    "  XX X X X X X X X X  "
-	    " XX XXX X XXX XXX X X "
-	    "         X X          "
-	    "         X X          "
-	    "         X  X         "
-	    "          X X         "
-	    "          X X         "
-	    "          X  X        "
-	    "           X X        "
-	    "          X   X       "
-	    "    XXXXXX     XXXX   "
-	    "                      "
-	    "                      "
-	    "                      ")
-	  redisplay-scale redisplay-scale)
-	 redisplay-scale redisplay-scale))
-  (setq *carcass-bitmap* 
-	(make-bitmap
-	 (make-bit-array-from-strings
-	  '("                      "
-	    "                      "
-	    "  XXXXX         XXXXX "
-	    "  XXXXX         XXXXX "
-	    "    XXX         XXX   "
-	    "    XXX         XXX   "
-	    " XXXXXXXXXXXXXXXXXXXX "
-	    " XXXXXXXXXXXXXXXXXXXX "
-	    " XXXXXXXXXXXXXXXXXXXX "
-	    " XXXXXXXXXXXXXXXXXXXX "
-	    " XXXXXXXXXXXXXXXXXXXX "
-	    " XXXXXXXXXXXXXXXXXXXX "
-	    " XXXXXXXXXXXXXXXXXXXX "
-	    " XXXX   XXXXXX   XXXX "
-	    " XXX X X XXXX X X XXX "
-	    " XXX  X  XXXX  X  XXX "
-	    " XXX X X XXXX X X XXX "
-	    " XXXX   XXXXXX   XXXX "
-	    " XXXXXXXXXXXXXXXXXXXX "
-	    " XXXXXXXXXXXXXXXXXXXX "
-	    "                      "
-	    "                      ")
-	  redisplay-scale redisplay-scale)
-	 redisplay-scale redisplay-scale))
-  (let ((bit-array (make-bit-array-from-strings
-		      '("                      "
-			"           X          "
-			"         X  X  X      "
-			"      X X  X XX X     "
-			"       X       X      "
-			"     X    X X    X    "
-			"     X   XXXX  X      "
-			"     X   XXXX  X      "
-			"       X  XX   X X    "
-			"      X X       X     "
-			"     X  X     X       "
-			"       X X  X  X      "
-			"       X    X         "
-			"       X  X  X        "
-			"        X X  X        "
-			"        X   X         "
-			"         X            "
-			"         X X          "
-			"            X         "
-			"          X           "
-			"          X           "
-			"                      ")
-		      redisplay-scale redisplay-scale)))
-    (setf (svref *fireball-bitmaps* 0)
-	  (make-bitmap bit-array redisplay-scale redisplay-scale))
-    (setf (svref *fireball-bitmaps* 1)
-	  (make-bitmap (rotate-bit-array bit-array redisplay-scale
-					   redisplay-scale east)
-			redisplay-scale redisplay-scale))
-    (setf (svref *fireball-bitmaps* 2)
-	  (make-bitmap (rotate-bit-array bit-array redisplay-scale
-					   redisplay-scale south)
-			redisplay-scale redisplay-scale))
-    (setf (svref *fireball-bitmaps* 3)
-	  (make-bitmap (rotate-bit-array bit-array redisplay-scale
-					   redisplay-scale west)
-			redisplay-scale redisplay-scale))))
-
-(defun tini-bitmaps ()
-  (delete-bitmap *mushroom-bitmap*)
-  (delete-bitmap *carcass-bitmap*)
-  (dotimes (i 4)
-    (delete-bitmap (svref *fireball-bitmaps* i))))
-
-(defun draw-mushroom (x y)
-  (draw-bitmap *birds-eye-window* x y redisplay-scale redisplay-scale
-	       *mushroom-bitmap*))
-
-(defun draw-carcass (x y)
-  (draw-bitmap *birds-eye-window* x y redisplay-scale redisplay-scale
-	       *carcass-bitmap*))
-
-(defun draw-feeb (x y feeb)
-  (let ((id (make-string 1 :initial-element (digit-char (feeb-id feeb)))))
-    (draw-rectangle *birds-eye-window* (+ x 1) (+ y 1) 20 20)
-    (case (facing (feeb-status feeb))
-      (0
-       ;; Draw the feeb-id on the feeb's chest.
-       (draw-feeb-id *birds-eye-window* (+ x 7) (+ y 8) id)
-       ;; Draw the feeb's eye-outline.
-       (draw-rectangle *birds-eye-window* (+ x 4) (+ y 3) 5 5 :undraw t)
-       (draw-rectangle *birds-eye-window* (+ x 14) (+ y 3) 5 5 :undraw t)
-       ;; Put pupils in the feeb's eyes.
-       (draw-rectangle *birds-eye-window* (+ x 5) (+ y 4) 3 3)
-       (draw-rectangle *birds-eye-window* (+ x 15) (+ y 4) 3 3)
-       (draw-rectangle *birds-eye-window* (+ x 6) (+ y 5) 1 1 :undraw t)
-       (draw-rectangle *birds-eye-window* (+ x 16) (+ y 5) 1 1 :undraw t))
-      (1
-       ;; Draw the feeb-id on the feeb's chest.
-       (draw-feeb-id *birds-eye-window* (+ x 3) (+ y 5) id)
-       ;; Draw the feeb's eye-outline.
-       (draw-rectangle *birds-eye-window* (+ x 14) (+ y 4) 5 5 :undraw t)
-       (draw-rectangle *birds-eye-window* (+ x 14) (+ y 14) 5 5 :undraw t)
-       ;; Put pupils in the feeb's eyes.
-       (draw-rectangle *birds-eye-window* (+ x 15) (+ y 5) 3 3)
-       (draw-rectangle *birds-eye-window* (+ x 15) (+ y 15) 3 3)
-       (draw-rectangle *birds-eye-window* (+ x 16) (+ y 6) 1 1 :undraw t)
-       (draw-rectangle *birds-eye-window* (+ x 16) (+ y 16) 1 1 :undraw t))
-      (2
-       ;; Draw the feeb-id on the feeb's chest.
-       (draw-feeb-id *birds-eye-window* (+ x 7) (+ y 1) id)
-       ;; Draw the feeb's eye-outline.
-       (draw-rectangle *birds-eye-window* (+ x 14) (+ y 14) 5 5 :undraw t)
-       (draw-rectangle *birds-eye-window* (+ x 4) (+ y 14) 5 5 :undraw t)
-       ;; Put pupils in the feeb's eyes.
-       (draw-rectangle *birds-eye-window* (+ x 15) (+ y 15) 3 3)
-       (draw-rectangle *birds-eye-window* (+ x 5) (+ y 15) 3 3)
-       (draw-rectangle *birds-eye-window* (+ x 16) (+ y 16) 1 1 :undraw t)
-       (draw-rectangle *birds-eye-window* (+ x 6) (+ y 16) 1 1 :undraw t))
-      (3
-       ;; Draw the feeb-id on the feeb's chest.
-       (draw-feeb-id *birds-eye-window* (+ x 11) (+ y 5) id)
-       ;; Draw the feeb's eye-outline.
-       (draw-rectangle *birds-eye-window* (+ x 4) (+ y 14) 5 5 :undraw t)
-       (draw-rectangle *birds-eye-window* (+ x 4) (+ y 4) 5 5 :undraw t)
-       ;; Put pupils in the feeb's eyes.
-       (draw-rectangle *birds-eye-window* (+ x 5) (+ y 15) 3 3)
-       (draw-rectangle *birds-eye-window* (+ x 5) (+ y 5) 3 3)
-       (draw-rectangle *birds-eye-window* (+ x 6) (+ y 16) 1 1 :undraw t)
-       (draw-rectangle *birds-eye-window* (+ x 6) (+ y 6) 1 1 :undraw t)))))
-
-;;; Must draw a peeking feeb's periscope in a separate operation, so that it
-;;; doesn't get clobbered by other drawing in the square being peeked at.
-
-(defun draw-periscope (feeb)
-  (when (and (not (feeb-dead-p feeb))
-	     (peeking (feeb-status feeb)))
-    (let* ((status (feeb-status feeb))
-	   (peeking (peeking status))
-	   (x (* redisplay-scale (j-position status)))
-	   (y (* redisplay-scale (i-position status))))
-      (case (facing status)
-	(0
-	 (draw-rectangle *birds-eye-window* (+ x 11) (- y 5) 2 7)
-	 (if (eq peeking :left)
-	     (draw-rectangle *birds-eye-window* (+ x 9) (- y 5) 2 2)
-	     (draw-rectangle *birds-eye-window* (+ x 13) (- y 5) 2 2)))
-	(1
-	 (draw-rectangle *birds-eye-window* (+ x 22) (+ y 11) 7 2)
-	 (if (eq peeking :left)
-	     (draw-rectangle *birds-eye-window* (+ x 27) (+ y 9) 2 2)
-	     (draw-rectangle *birds-eye-window* (+ x 27) (+ y 13) 2 2)))
-	(2
-	 (draw-rectangle *birds-eye-window* (+ x 11) (+ y 22) 2 7)
-	 (if (eq peeking :left)
-	     (draw-rectangle *birds-eye-window* (+ x 13) (+ y 27) 2 2)
-	     (draw-rectangle *birds-eye-window* (+ x 9) (+ y 27) 2 2)))
-	(3
-	 (draw-rectangle *birds-eye-window* (- x 5) (+ y 11) 7 2)
-	 (if (eq peeking :left)
-	     (draw-rectangle *birds-eye-window* (- x 5) (+ y 13) 2 2)
-	     (draw-rectangle *birds-eye-window* (- x 5) (+ y 9) 2 2)))))))
-
-(defun draw-fireball (x y facing)
-  (declare (fixnum x y facing))
-  (draw-bitmap *birds-eye-window* x y redisplay-scale redisplay-scale
-	       (svref *fireball-bitmaps* facing)))
-
-
-;;; Status display.
-
-(defconstant turn-column 6)
-(defconstant id-column 0)
-(defconstant name-column 3)
-(defconstant score-column 8)
-(defconstant kill-column 13)
-(defconstant energy-column 18)
-(defconstant last-move-column 23)
-
-(defun init-status-display ()
-  (setq *status-window* (create-window status-window-x status-window-y
-				       status-window-width status-window-height))
-  (x:xsync 1)
-  (prepare-for-xevents *status-window*)
-  (display-window *status-window*)
-  (display-all-status))
-
-(defun tini-status-display ()
-  (x:xflush)
-  (delete-window *status-window*))
-
-;;; Energy values change every turn, and always are in the range
-;;; from 0 to 200, so just pre-compute all the strings for efficiency.
-
-(defvar *small-number-strings*
-  '#("  0" "  1" "  2" "  3" "  4" "  5" "  6" "  7" "  8" "  9"
-     " 10" " 11" " 12" " 13" " 14" " 15" " 16" " 17" " 18" " 19"
-     " 20" " 21" " 22" " 23" " 24" " 25" " 26" " 27" " 28" " 29"
-     " 30" " 31" " 32" " 33" " 34" " 35" " 36" " 37" " 38" " 39"
-     " 40" " 41" " 42" " 43" " 44" " 45" " 46" " 47" " 48" " 49"
-     " 50" " 51" " 52" " 53" " 54" " 55" " 56" " 57" " 58" " 59"
-     " 60" " 61" " 62" " 63" " 64" " 65" " 66" " 67" " 68" " 69"
-     " 70" " 71" " 72" " 73" " 74" " 75" " 76" " 77" " 78" " 79"
-     " 80" " 81" " 82" " 83" " 84" " 85" " 86" " 87" " 88" " 89"
-     " 90" " 91" " 92" " 93" " 94" " 95" " 96" " 97" " 98" " 99"
-     "100" "101" "102" "103" "104" "105" "106" "107" "108" "109"
-     "110" "111" "112" "113" "114" "115" "116" "117" "118" "119"
-     "120" "121" "122" "123" "124" "125" "126" "127" "128" "129"
-     "130" "131" "132" "133" "134" "135" "136" "137" "138" "139"
-     "140" "141" "142" "143" "144" "145" "146" "147" "148" "149"
-     "150" "151" "152" "153" "154" "155" "156" "157" "158" "159"
-     "160" "161" "162" "163" "164" "165" "166" "167" "168" "169"
-     "170" "171" "172" "173" "174" "175" "176" "177" "178" "179"
-     "180" "181" "182" "183" "184" "185" "186" "187" "188" "189"
-     "190" "191" "192" "193" "194" "195" "196" "197" "198" "199"
-     "200"))
-
-(defmacro energy-to-string (energy)
-  `(svref *small-number-strings* (max ,energy 0)))
-
-;;; This refreshes or initializes all parts of the display.
-
-(defun display-all-status ()
-  (display-string "*STATUS*" 1 8 8)
-  (display-string "Turn: " 3 0 6)
-  (display-number *current-turn* 3 8 6)
-  ;; 00000000001111111111222222222233333333334444444444
-  ;; 01234567890123456789012345678901234567890123456789
-  (display-string 
-    "ID Name Sco. Kill Eng. LM" 4 0 25)
-  (display-string
-    "-------------------------" 5 0 25)
-  (dolist (feeb *feebs*)
-    (let ((status (feeb-status feeb))
-	  (line (+ (feeb-id feeb) 6)))
-      (display-number (feeb-id feeb) line 0 3)
-      (display-string (name status) line 3 4)
-      (setf (feeb-last-score feeb) (score status))
-      (display-number (score status) line 8 4)
-      (setf (feeb-last-kills feeb) (kills status))
-      (display-number (kills status) line 13 4)
-      (display-string (energy-to-string (energy-reserve status)) line 18 4)
-      (display-string (cond ((feeb-dead-p feeb) "De")
-			    ((aborted status) "Ab")
-			    (t (case (last-move status)
-				 (:turn-left "TL")
-				 (:turn-right "TR")
-				 (:turn-around "TA")
-				 (:move-forward "MF")
-				 (:eat-mushroom "EM")
-				 (:eat-carcass "EC")
-				 (:peek-left "PL")
-				 (:peek-right "PR")
-				 (:wait "WA")
-				 (T "NM"))))
-		      line 23 2)))
-  (display-string
-   "Click any mouse button to" 22 0 25)
-  (display-string
-   "zap windows at the end." 23 3 23)
-  (display-string
-   "Press the \"q\" key to quit" 25 0 25)
-  (display-string
-   "at any time." 26 3 12)
-  (display-string
-   "Press the \"s\" key to jump" 28 0 25)
-  (display-string
-   "into single-step mode." 29 3 22)
-  (display-string
-   "Click any mouse button to" 31 0 25)
-  (display-string
-   "single-step." 32 3 12)
-  (display-string
-   "Press the \"a\" key to jump" 34 0 25)
-  (display-string
-   "back to automatic mode." 35 3 13))
-
-(defun display-status ()
-  (display-number *current-turn* 3 8 6)
-  (dolist (feeb *feebs*)
-    (let ((status (feeb-status feeb))
-	  (line (+ (feeb-id feeb) 6))
-	  temp)
-      (unless (= (feeb-last-score feeb)
-		 (setq temp (score status)))
-	(setf (feeb-last-score feeb) temp)
-	(display-number temp line 8 4))
-      (unless (= (feeb-last-kills feeb)
-		 (setq temp (kills status)))
-	(setf (feeb-last-kills feeb) temp)
-	(display-number temp line 13 4))
-      (display-string (energy-to-string (energy-reserve status)) line 18 4)
-      (display-string (cond ((feeb-dead-p feeb) "De")
-			    ((aborted status) "Ab")
-			    (t (case (last-move status)
-				 (:turn-left "TL")
-				 (:turn-right "TR")
-				 (:turn-around "TA")
-				 (:move-forward "MF")
-				 (:eat-mushroom "EM")
-				 (:eat-carcass "EC")
-				 (:peek-left "PL")
-				 (:peek-right "PR")
-				 (:wait "WA")
-				 (T "NM"))))
-		      line 23 2))))
-
-(defun display-string (string line column field-width)
-  (draw-rectangle *status-window* 
-		  (* (+ column 2) *char-width*) (* line *char-height*) 
-		  (* field-width *char-width*) *char-height* :undraw t)
-  (draw-string *status-window* (* (+ column 2) *char-width*)
-	       (* line *char-height*)
-	       string))
-
-;;; Print a number plus optionally a leading minus sign.  Buffers the
-;;; characters in a pre-existing string, so does no consing.  The number
-;;; is printed right-justified within a field of the specified length,
-;;; starting at the specified line and column.
-
-(defvar *number-string-length* 5)
-(defvar *number-string-buffer* (make-array *number-string-length*
-					   :element-type 'string-char))
-
-(defun display-number (n line column field )
-  (let ((charpos *number-string-length*)
-	(quotient (abs n))
-	(remainder 0))
-    (cond ((zerop n)
-	   ;; Special-case zero so it doesn't print as nothing at all.
-	   (decf charpos)
-	   (setf (schar *number-string-buffer* charpos) #\0))
-	  (t
-	   ;; Stuff digits into the string from right to left.
-	   (do ()
-	       ((zerop quotient))
-	     (multiple-value-setq (quotient remainder)
-	       (truncate quotient 10))
-	     (decf charpos)
-	     (setf (schar *number-string-buffer* charpos)
-		   (digit-char remainder)))
-	   ;; And output the minus sign if needed.
-	   (when (minusp n)
-		 (decf charpos)
-		 (setf (schar *number-string-buffer* charpos) #\-))))
-    (do ()
-        ((<= charpos 0))
-      (decf charpos)
-      (setf (schar *number-string-buffer* charpos) #\space))
-    ;; Now print it.
-    (draw-rectangle *status-window*
-		    (* column *char-width*) (* line *char-height*)
-		    (* field *char-width*) *char-height* :undraw t)
-    (draw-string *status-window* 
-		  (* (+ column field (- *number-string-length*)) *char-width*)
-		  (* line *char-height*)
-		  *number-string-buffer*)))
-
-;;; It.
-
-(defun feebs (&key (layout default-layout)	
-		   single-step
-		   delay
-		   files
-		   feep-dead-feebs)
-  "This starts the simulation.  Takes some options as keyword arguments.
-  :Single-step, if non-null, says to wait for any mouse click after each round.
-  :Delay, if non-null, is a number of seconds to wait after each round.
-  :Layout is the layout of the maze to use, if you don't want the default.
-  :Files is a list of files containing feeb definitions."
-  (let ((*single-step* single-step)
-	(*delay* delay)
-	(*feep-dead-feebs* feep-dead-feebs)
-	(*continue* t))
-    (when files (apply #'load-feebs files))
-    (let ((n (- *number-of-feebs* (length *feebs-to-be*))))
-      (cond ((minusp n)
-	     (error "Too many pre-defined feebs: ~S.~%"
-		    (length *feebs-to-be*)))
-	    ((zerop n))
-	    (t (format t "Making ~S dumb auto-feebs.~%" n)
-	       (make-auto-feebs n))))
-    (init-maze layout)
-    (create-mushrooms)
-    (create-feebs)
-    (init-play)
-    (unwind-protect
-	(progn
-	  (init-graphics)
-	  (init-banner)
-	  (init-redisplay)
-	  (init-status-display)
-	  (play))
-      (when (and (not *single-step*) *continue*)
-	(display-string "THE END." 19 8 8)
-	(get-mouse-buttonpress))
-      (x:xsync 1)
-      (tini-redisplay)
-      (tini-status-display)
-      (tini-banner)
-      (x:xflush)
-      (tini-graphics))
-    (write-line "Final scores:")
-    (dolist (feeb (reverse *feebs*))
-      (format t "(~A) ~20A  ~5D~%"
-	      (feeb-id feeb)
-	      (feeb-image-name (feeb-image feeb))
-	      (score (feeb-status feeb))))))
-
-
-;;; Feeb creation.
-
-(defun reset-feebs ()
-  (setq *feebs-to-be* nil))
-
-(defun load-feebs (&rest files)
-  (reset-feebs)
-  (dolist (file files)
-    (load file)))
-
-(defun make-auto-feebs (n)
-  (let* ((nrandoms (floor n 3))
-	 (nwanders (floor n 3))
-	 (nconserve (- n nrandoms nwanders)))
-    (dotimes (i nrandoms)
-      (push (cons (concatenate 'string "Rnd" (princ-to-string (1+ i)))
-		  'random-brain)
-	    *feebs-to-be*))
-    (dotimes (i nwanders)
-      (push (cons (concatenate 'string "Wnd" (princ-to-string (1+ i)))
-		  'wandering-brain)
-	    *feebs-to-be*))
-    (dotimes (i nconserve)
-      (push (cons (concatenate 'string "Cns" (princ-to-string (1+ i)))
-		  'conservative-brain)
-	    *feebs-to-be*))))
-
-
-;;; Here are some simple auto-feeb brains to use until we get better ones.
-
-;;; About the stupidest brain possible.  Something for everyone to feel
-;;; superior to.
-
-(defun random-brain (status proximity vision vision-left vision-right)
-  (declare (ignore status proximity vision vision-left vision-right))
-  (svref '#(:turn-left :turn-right :turn-around :move-forward
-	    :flame :eat-mushroom :eat-carcass :peek-left :peek-right
-	    :wait)
-	 (random 10)))
-
-
-;;; This one wanders around, feeds when it can, and shoots at any visible
-;;; opponent.
-
-(defun wandering-brain (status proximity vision vision-left vision-right)
-  (declare (ignore vision-left vision-right))
-  (let ((stuff (my-square proximity)))
-    (cond ((and (consp stuff) (member :mushroom stuff :test #'eq))
-	   :eat-mushroom)
-	  ((and (consp stuff) (member :carcass stuff :test #'eq))
-	   :eat-carcass)
-	  ((and (ready-to-fire status)
-		(dotimes (index (line-of-sight status))
-		  (let ((stuff (aref vision index)))
-		    (if (listp stuff)
-			(if (dolist (thing stuff)
-			      (if (feeb-image-p thing)
-				  (return t)))
-			    (return t))
-			(if (feeb-image-p stuff)
-			    (return t))))))
-	   :flame)
-	  ((and (not (eq (left-square proximity) :rock))
-		(> 0.2 (random 1.0)))
-	   :turn-left)
-	  ((and (not (eq (right-square proximity) :rock))
-		(> 0.2 (random 1.0)))
-	   :turn-right)
-	  ((not (ready-to-fire status))
-	   :wait)
-	  ((> (line-of-sight status) 0)
-	   :move-forward)
-	  ((not (eq (left-square proximity) :rock))
-	   :turn-left)
-	  ((not (eq (right-square proximity) :rock))
-	   :turn-right)
-	  (t
-	   :turn-around))))
-
-;;; This one is similar to the wandering brain, but doesn't shoot if
-;;; energy reserves are too low or the opponent is too far away.
-
-(defun conservative-brain (status proximity vision vision-left vision-right)
-  (declare (ignore vision-left vision-right))
-  (let ((stuff (my-square proximity)))
-    (cond ((and (consp stuff) (member :mushroom stuff :test #'eq))
-	   :eat-mushroom)
-	  ((and (consp stuff) (member :carcass stuff :test #'eq))
-	   :eat-carcass)
-	  ((and (ready-to-fire status)
-		(> (energy-reserve status) 30)
-		(dotimes (index (min (line-of-sight status) 5))
-		  (let ((stuff (aref vision index)))
-		    (if (listp stuff)
-			(if (dolist (thing stuff)
-			      (if (feeb-image-p thing)
-				  (return t)))
-			    (return t))
-			(if (feeb-image-p stuff)
-			    (return t))))))
-	   :flame)
-	  ((and (not (eq (left-square proximity) :rock))
-		(> 0.2 (random 1.0)))
-	   :turn-left)
-	  ((and (not (eq (right-square proximity) :rock))
-		(> 0.2 (random 1.0)))
-	   :turn-right)
-	  ((not (ready-to-fire status))
-	   :wait)
-	  ((> (line-of-sight status) 0)
-	   :move-forward)
-	  ((not (eq (left-square proximity) :rock))
-	   :turn-left)
-	  ((not (eq (right-square proximity) :rock))
-	   :turn-right)
-	  (t
-	   :turn-around))))
diff --git a/contrib/games/feebs/feebs.log b/contrib/games/feebs/feebs.log
deleted file mode 100644
index bcd02a8ee47465688d68713b38e26041559733a0..0000000000000000000000000000000000000000
--- a/contrib/games/feebs/feebs.log
+++ /dev/null
@@ -1,90 +0,0 @@
-/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 16:33:43, Edit by Chiles.
-  Made FEEBS bind, instead of set, *single-step*,*delay*,
-  *feep-dead-feebs*, and *continue*.  These values were being retained
-  between runs.
-
-/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 15:35:47, Edit by Chiles.
-  Fixed X interaction by calling X:OPEN-CONSOLE in INIT-GRAPHICS.  Also,
-  set bordercolor and background parameters in INIT-GRAPHICS.  Made
-  KILL-FEEB look at the value of *feep-dead-feebs*.
-
-/usr2/lisp/library/rt/feebs/brains.lisp, 11-Oct-87 12:01:50, Edit by Chiles.
-  Written by Skef and Scott.  This is just a file of sample feebs that are
-  pretty dumb.
-
-/usr2/lisp/library/rt/feebs/mazes.lisp, 11-Oct-87 11:57:15, Edit by Chiles.
-  Created by Jim Healy, July 1987.  This file contains some sample mazes
-  with various curious properties.
-
-/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 11:53:54, Edit by Chiles.
-  No time stamp for this either, but it is close to the previous line's.
-
-  ;;; Modifications by Jim Healy:
-  ;;;
-  ;;; Ported the graphics to the IBM RT PC using the X window manager.
-  ;;; Added functions to create and store bitmaps for X.
-  ;;; Added event-handling routines to catch incoming events from the
-  ;;;   X server and redisplay the windows if exposed.
-  ;;; Changed :single-step option to work by clicking a mouse button.
-  ;;; Added keypress features to quit the game prematurely (q), jump
-  ;;;   into single-step mode (s), and go back to automatic mode (a).
-  ;;; Added the neat "Planet of the Feebs" banner at the top.
-  ;;; Added feature to zap windows at end of game by clicking a mouse
-  ;;;   button.
-  ;;; Fixed the disembodied periscopes bug.
-
-/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 11:52:55, Edit by Chiles.
-  No time stamp on this entry.
-
-  ;;; Modifications by Dan Kuokka:
-  ;;;
-  ;;; Built the interface to a generalized set of graphics primitives.
-  ;;; Wrote rotate-bitmap.
-
-/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 11:51:54, Edit by Chiles.
-  No time stamp on this entry either.
-
-  ;;; The following by Scott Fahlman, for initial public release:
-  ;;;
-  ;;; Installed CHANCE macro to speed up random events. 
-  ;;; Modified points for being killed from -5 to -2. 
-  ;;; When you zap yourself, you get no points for the kill.
-  ;;; Eliminated random length of game.  Now *GAME-LENGTH* = 1000.
-  ;;; Modified default maze slightly so that no two entry points are
-  ;;;   line of sight, regardless of how the feebs are facing.
-  ;;; Changed directions from keywords to constants, with integer values:
-  ;;;   north = 1, east = 2, etc.
-  ;;; Randomize initial entry points for feebs.
-  ;;; Display more interesting stuff in text area: score, energy, last move.
-  ;;; Keep energy in range 0 to 200 always, fix bug that caused any eating
-  ;;;   to push energy to maximum.
-  ;;; Display kills in status area, along with score.
-  ;;; ABORTED status field was not being maintained.
-  ;;; Install a smoother function for aborting moves of slow feebs.
-  ;;; Add single-step and slow motion.
-  ;;; Put in proximity sense, start vision array in space in front of the
-  ;;;   the feeb's current location, going forward, left, or right from there.
-  ;;; Store the appropriate image list in each maze cell, eliminating the
-  ;;;   IMAGIFY operations.  Add a pointer from the feeb-image back to the
-  ;;;   full feeb-structure.
-  ;;; Allow *maze-i-size* and *maze-j-size* to be different.
-  ;;; Fixed a couple of bugs in fireball motion.
-  ;;; Feebs running into fireballs get zapped.
-  ;;; Make sure image is updated between action and redisplay.
-  ;;; Queue redisplay for a feeb's old square on every move.
-  ;;; Improve mushroom image to not hit edges of square.
-  ;;; Improve fireball display to show direction of travel.
-  ;;; On reflection, update fireball DIRECTION as well as DI, DJ.
-  ;;; Display current turn.  Improve kludgy number printing.
-  ;;; Display periscope-like appendage when feeb is peeking.
-  ;;; Do not execute peek command if the feeb is facing a rock wall.
-  ;;; When a feeb was peeking last move, queue the forward square for
-  ;;;   redisplay to get rid of the periscope.
-  ;;; Set up auto-feeb creation and add some stupid auto-feebs.
-  ;;; Remove the terse printing function for the status structure to make
-  ;;;   it somewhat easier to debug things.
-  ;;; Fixed a bug in the DI and DJ macros.
-
-/usr2/lisp/library/rt/feebs/feebs.lisp, 11-Oct-87 11:50:10, Edit by Chiles.
-  Created by Skef Wholey -- No time stamp.
-
diff --git a/contrib/games/feebs/feebs.mss b/contrib/games/feebs/feebs.mss
deleted file mode 100644
index 450d2e97cf996830a9e8b77dbb4149af219720ea..0000000000000000000000000000000000000000
--- a/contrib/games/feebs/feebs.mss
+++ /dev/null
@@ -1,556 +0,0 @@
-@make [article]
-@device [dover]
-
-@begin [titlepage]
-@begin [titlebox]
-@majorheading [Planet of the Feebs]
-@heading [A Somewhat Educational Simulation Game]
-
-Scott E. Fahlman
-Computer Science Department
-Carnegie-Mellon University
-
-Version: @value [filedate]
-@end [titlebox]
-
-@copyrightnotice [Scott E. Fahlman]
-@end[titlepage]
-@newpage
-@section [Introduction]
-
-@i[Planet of the Feebs] is a simulation game that is intended as a
-training aid for beginning programmers in Common Lisp.  It is loosely
-based on the "Maze War" game, written by Jim Guyton, Bruce Malasky, and
-assorted others at Xerox PARC.  In @i[Planet of the Feebs], however, the
-players do not control their creatures by hand.  Instead, they supply
-programs which control the creatures as they move around the maze trying
-to zap one another.  The game presents an open-ended challenge, and
-advanced players may find themselves reaching deep into the AI bag of
-tricks as they try to build ever more clever and adaptable creatures.
-
-The current version of the program runs in CMU Common Lisp on the IBM RT
-PC under the Mach operating system.  It uses the X window manager.  It
-was designed by Scott Fahlman and programmed by Fahlman, Skef Wholey,
-and Dan Kuokka.  Other members of the Spice Lisp group at CMU have
-contributed ideas and have helped to tune and polish the system.
-
-The Feebs environment is easily reconfigurable by changing certain
-global parameters.  Normally, the parameters to be used in a given
-contest are announced to the players before they begin writing their
-programs, since very different strategies may be appropriate with
-different parameters.  In this document, we will indicate the names of
-those parameters in boldface, followed by the usual value of this
-parameter in parentheses.  To see how any given feebs world is
-configured, execute the function (list-parameter-settings), which will
-create and return an A-list of all the interesting parameters:
-
-@begin [example]
-((*number-of-feebs* . 10)
- (*carcass-rot-probability* . 1/3) ...)
-@end [example]
-
-@section [Life Among The Feebs]
-
-Deep below the surface of a medium-sized planet, in a long-forgotten
-maze of tunnels, live a race of strange creatures, the feebs.  The
-origin of the name "feebs" is lost in the mists of antiquity.  Some say
-that the name is short for "feeble minded", which most of the creatures
-certainly are; some say that the name is a contraction of the term
-"flaming bogons", a phrase whose origins are also, unfortunately, lost
-in antiquity; most likely, the name comes from the feebing noise that
-the creatures occasionally make as they wander the maze.
-
-Locked in their isolated world, the feebs compete fiercely for the
-two types of available food: large mushrooms that sometimes appear at
-certain places in the labyrinth, and each other.  Life is tough in the
-labyrinth; it's every feeb for itself.  The goal is survival, and any
-competitors must be ruthlessly eliminated.
-
-Physically very similar to one another, the feebs must try to survive by
-superior intelligence.  Each feeb has an electrical organ which can use
-to "flame" at its competitors, emitting a lethal "fireball" -- actually
-an unstable ball of high-energy plasma, similar to ball lightning.  The
-fireball travels erratically down the tunnel in the direction the
-creature is facing.  The flame is the feeb's only weapon.  The only
-defense is to stay out of the line of fire or to outrun the oncoming
-fireball, but a feeb who hides in a secluded corner of the maze will
-eventually starve.  Unfortunately, the mushrooms tend to grow at tunnel
-junctions and in dead-end corridors, places where feeding creatures run
-a considerable risk of ambush or entrapment.
-
-The walls of the maze emit a soft glow due to a coating of
-phosphorescent (but inedible) fungi.  Even in this dim light, the feebs
-can see well.  The feebs can peek around corners without exposing
-themselves to hostile fire, but a peeking feeb can be seen by opponents
-in the tunnel he is peeking into.
-
-The simple feeb world does not allow for much variety of action.  Feebs
-can turn by 90 or 180 degrees, move one step forward, flame, feed, peek
-around corners, or stay put.  Feebs cannot back up or move sideways;
-they must turn in the direction they want to go.  Some feebs are
-moderately intelligent, but none of them has much coordination.
-Consequently, a feeb can only perform one of these basic actions at
-once.  (Very early in feeb evolution they learned not to chew gum.)  All
-of the feebs suffer from the same limitations, so cleverness -- and
-sometimes a bit of luck -- are all-important.
-
-@section [The Game]
-
-@subsection [Overview]
-
-@i[Planet of the Feebs] is played by up to @b[*number-of-feebs*] (10)
-human players at once.  Each player controls one of the feebs in the
-maze.  This control is not exerted directly, but rather by supplying a
-program, called the @i[behavior function], that controls the creature's
-actions.  All of the programmed feebs are turned loose in the maze at
-once, and the competition for survival begins.  The game runs for a
-number of turns specified by @b[*game-length*] (1000).  Zapping an
-opponent gives a feeb @b[*points-for-killing*] (+1) point, while being
-zapped or dying of hunger gives it a penalty of @b[*points-for-dying*]
-(-2) points.  Feebs that manage to shoot themselves do not get credit
-for the kill.  A dead feeb is reincarnated as soon as his carcass has
-rotted, which takes a few turns.  These newly reincarnated creatures
-re-enter the maze at some randomly-chosen entry point.
-
-Being highly evolved creatures, the feebs think using Common Lisp.  (At
-one time there were feebs who thought using Pascal, but all of these
-have attained a provably correct extinction.)  Each feeb's behavior, at
-each turn of the game, is supplied by a Common Lisp function (which may
-be a lexical closure).  This function receives as its arguments the
-feeb's sensory inputs (including some internal sensations such as the
-degree of hunger) and it returns one of the simple actions of which the
-feeb is capable.
-
-The game proceeds as a series of synchronous turns.  At the start of
-each turn various natural phenomena occur: mushrooms grow, flame-balls
-move (destroying things as they go), and feebs occasionally die of
-starvation.  Next, the behavior function for each feeb receives its
-sensory inputs and computes its desired action.  Occasionally an action
-is turned to a no-op because the feeb has responded too slowly (see
-below).  Finally, all remaining actions are executed at once.
-
-The maze is laid out as a array of size @b[*maze-i-size*] by
-@b[*maze-j-size*] (32 x 32).  Some locations or "squares" contain rock,
-others empty space.  All tunnels are one unit wide.  There are T, L and
-+ junctions, as well as dead ends, but no large rooms.  There are no
-disconnected parts of the maze: it is possible to reach any tunnel
-square from any other tunnel square.  The feebs may or may not know the
-specific layout of the maze in advance (see the section on Contest
-Rules), but a feeb in a strange maze may build up some sort of map as he
-wanders around.  Feebs do have a mysterious navigational sense that
-tells them their own I and J coordinates at any given time, as well as
-the direction in which they are facing.
-
-A feeb always faces North, South, East, or West, and never anything in
-between.  Any number of feebs may occupy a given square at once.  A feeb
-has a short-range sense of "proximity" that tells it what is in its own
-square and certain adjacent squares.  However, a feeb cannot flame into
-its own square or engage in hand-to-hand combat (feebs have no hands,
-and their rubbery beaks are only strong enough to attack mushrooms and
-flame-broiled opponents).  It is rather awkward for two feebs in the
-same square to disengage without becoming targets for one another, but
-it is also dangerous to remain together, since a successful shot into
-this square by another feeb will kill all the occupants.  Mushrooms and
-carcasses do not impede the movement of live feebs.
-
-A maze normally contains @b[*number-of-feebs*] (10) feebs, usually
-representing that many different players.  If fewer than the specified
-number of players are participating, the remaining niches are filled by
-the addition of "autofeebs" supplied by the system.  These creatures
-come in several types, but all have rather simple behavior patterns.
-Some are almost suicidally aggressive, for example, while others run
-from trouble whenever possible.
-
-The maze designer pre-designates a set of entry points.  These may be
-close to one another, but no entry point will be visible from any other.
-There must be at least as many of these entry points as there are feebs
-in the maze.  At the start of the game, each feeb is assigned a
-different entry point, randomly chosen from this predefined set, facing
-in a randomly chosen direction.  A feeb being reincarnated will appear
-at one of the original entry points, chosen at random.  This might
-result in two feebs suddenly facing one another, but the new feeb is in
-considerably greater danger than the existing ones, since it may well
-materialize facing a wall or dead end -- yet another reason not to get
-yourself killed in the first place.
-
-@subsection [Food]
-
-Feebs have to eat.  At each turn, the behavior function receives an
-indication of the creature's current energy reserves, measured in Zots.
-This energy reserve is decreased by one Zot after each turn, regardless
-of what the creature did during that turn.  Flaming uses up an
-additional @b[*flame-energy*] (10) Zots.  The energy is decremented when
-the action is executed; if the remaining energy at the start of a turn
-is zero or negative, the creature starves to death immediately, leaving
-a carcass.
-
-A feeb feeds by executing the :EAT-MUSHROOM or :EAT-CARCASS command
-while in a square occupied by the specified type of food.  A feeding
-feeb can do nothing else in that turn, and hence is rather vulnerable.
-Feeding on a mushroom increments the feeb's energy reserve by
-@b[*mushroom-energy*] (50) Zots, but destroys the mushroom.  Feeding on
-a carcass increments the energy reserve by @b[*carcass-energy*] (30)
-Zots per turn, and may go on for several turns before the carcass rots.
-Feebs have a maximum capacity of @b[*maximum-energy*] (200) Zots --
-gorging beyond that point does not increase the creature's reserves,
-though it may be useful as a way of keeping food away from opponents.
-Feebs start the game moderately hungry, with a reserve randomly chosen
-between @b[*minimum-starting-energy*] (50) and
-@b[*maximum-starting-energy*] (100) Zots.
-
-The maze designer pre-designates certain squares as mushroom-growing
-locations.  Typically, there will be @b[*number-of-mushrooms*] (10)
-mushrooms in the maze at any given time and
-@b[*number-of-mushroom-sites*] (30) places where they may appear.  The
-initial locations of the mushrooms are chosen at random from this set of
-locations.  Once a mushroom appears, it will remain in that square until
-it is eaten or destroyed by a fireball.  Whenever a mushroom is
-destroyed, a new one appears at some vacant mushroom-growing location,
-chosen at random.  There can never be more than one mushroom in a square
-at any given time.  Since an eaten mushroom reappears somewhere else and
-an uneaten mushroom will stay around forever, as the game progresses the
-mushrooms will tend to be found in parts of the maze that are seldom
-visited or at exposed locations where feeding is too risky.
-
-Whenever a feeb dies, either from incineration or starvation, a carcass
-is left behind in the square where the death occurred.  Unlike
-mushrooms, which disappear when eaten, a carcass may be fed upon
-repeatedly, by any number of feebs, until it rots away.  A feeb killed
-during Turn T will not begin to rot until turn T+N, where N is the value
-of @b[*carcass-guaranteed-lifetime*] (3).  At the end of that turn, and
-at the end of each turn thereafter, it has a
-@b[*carcass-rot-probability*] (1/3) chance of rotting away (disappearing
-completely).  The feeb that died is not reincarnated until after the
-carcass has rotted away.  At that point, the feeb appears in one of the
-starting squares, pointing in some random direction, and with energy
-reserves computed as at the start of the game.
-
-@subsection [Flaming]
-
-When a feeb flames, the fireball travels down the tunnel in the direction
-the feeb is facing, moving at one square per turn.  More precisely, if a
-feeb gives the :FLAME command during turn T, the fireball appears in the
-adjacent square at the start of turn T+1, destroying the contents.  (The
-intended victim may, however, have moved away during turn T.)  The fireball
-enters the next square at the start of turn T+2, and so on.
-
-As the fireball tries to enter each new square, including the first one, it
-has a certain probability of dissipating: this is controlled by
-@b[*fireball-dissipation-probability*] (1/4).  When a fireball enters a
-square containing a mushroom, that mushroom is destroyed.  When a fireball
-enters a square containing a live feeb, that feeb is killed, leaving a
-carcass.  Existing carcasses are already burned, so they are not affected
-by subsequent fireballs.  A feeb will also be killed if it moves into a
-square currently occupied by a fireball.
-
-The fireball proceeds in this manner, killing everything in its path,
-until it either dissipates or encounters the wall at the end of the
-straight-line corridor.  When the fireball hits the wall, it often
-dissipates, but it may be reflected back in the direction it came from
-with probability @b[*fireball-reflection-probability*] (1/2).  More
-precisely, if the fireball is in square S, the last space of a corridor,
-at time T, and would move into a solid-rock square at T+1, and it
-happens to be successfully reflected, its direction is reversed and it
-appears to be entering square S from the solid rock square at the start
-of time T+1.  In addition to the possibility that it will not be
-reflected, the fireball must face the usual dissipation probability on
-this turn as well.  A reflected fireball then proceeds to travel back in
-the direction it came from until it dissipates or is reflected again.
-Fireballs pass through one another with no interference.
-
-The relatively slow motion of the fireballs has some interesting
-consequences.  If a feeb sees a fireball coming, it may well be able to
-outrun it or to duck into a side corridor, though time wasted in turning
-may be fatal.  It is safe to dash past the mouth of a tunnel in which
-another feeb is lurking unless the second feeb happens to flame in
-anticipation of the move.  However, it is unwise to stop or turn while
-in such an intersection.  Because of the rule that a feeb moving into a
-square occupied by a fireball is killed, a feeb cannot avoid a fireball
-by rushing toward it, attempting to swap places.  However, a feeb can
-safely move into the square of an enemy feeb that is firing on the
-current turn.  It is very unhealthy for a feeb to move forward in the
-turn immediately following one in which it fires.
-
-After flaming, the feeb must wait an unpredictable amount of time before
-it can flame again.  On the turn after it fires, a feeb definitely will
-be unable to fire.  On every every turn thereafter, the flamer will have
-a probability of @b[*flame-recovery-probability*] (1/2) of recovering
-and being able to flame again.  A feeb can sense whether it is ready to
-fire or not, but cannot tell whether an opponent is able to fire.  Thus,
-a certain amount of bluffing is possible.
-
-@subsection [Timing]
-
-It is dangerous for a feeb to spend too much time thinking about what to do
-next.  The time taken by each of the behavior functions is recorded.  The
-action ordered by the feeb has a chance of being aborted (turned into a
-no-op) with a probability that is proportional to the time the feeb took to
-generate the order.  This can be particularly awkward in the middle of a
-shootout or when running from a fireball.
-
-More precisely, if @b[*slow-feeb-noop-switch*] (T) is non-nil, then the
-probability of aborting a feeb's move is the product of the time the feeb
-took and @b[*slow-feeb-noop-factor*] (.25), divided by the total time taken
-by all feebs on this turn.  If @b[*slow-feeb-noop-switch*] is NIL, this
-feature is disabled and no moves are aborted; this mode is recommended when
-some of the feebs are being controlled by hand.
-
-@subsection [Actions]
-
-Behavior functions are only called when the creature is alive.
-A behavior function indicates its selected action by returning one of
-the following keyword symbols:
-
-@Begin[Description]
-:TURN-LEFT @\Turn left by 90 degrees, staying in the current square.
-
-:TURN-RIGHT @\Turn right by 90 degrees, staying in the current square.
-
-:TURN-AROUND @\Turn around 180 degrees, staying in the current square.
-
-:MOVE-FORWARD @\Move forward one square.
-
-:FLAME @\Shoot a flame in the direction the creature is facing.
-
-:EAT-MUSHROOM @\Feed on a mushroom if one is available in the current
-square.  Otherwise, do nothing.
-
-:EAT-CARCASS @\Feed on a carcass if at least one is available in the
-current square.  Otherwise, do nothing.
-
-:PEEK-LEFT @\The creature does not actually move, but the visual input
-received next turn will be what the creature would see if it were to move
-forward one square and turn left.  If the creature wishes to continue
-peeking left, this command must be repeated each turn.
-
-:PEEK-RIGHT @\Analogous to PEEK-LEFT.
-
-:WAIT @\Stay put and do nothing.
-@End[Description]
-
-Any output that is not one of the symbols listed above is interpreted as
-a :WAIT.
-
-@subsection [Sensory Inputs]
-
-The behavior function always receives five arguments, representing its
-various sensory inputs.  The programmer can call these whatever he
-likes, but I will call them STATUS, PROXIMITY, VISION, VISION-LEFT, and
-VISION-RIGHT.  Each of these is a data structure that the program can
-access, but not modify, using a variety of accessing functions.  The
-system will destructively modify these structures from one turn to the
-next.
-
-The information in the STATUS structure can be accessed as follows:
-
-@Begin[Description]
-
-(name status) @\A string.  Whatever name the user supplied for this
-creature at the start of the game.
-
-(facing status) @\The direction the feeb is facing, encoded as a small
-integer: 0 = north, 1 = east, 2 = south, 3 = west.  Note: for
-convenience, NORTH, EAST, SOUTH, and WEST are defined as constants with
-the integer values specified above.
-
-(i-position status) @\An integer from zero (inclusive) to @b[*maze-i-size*]
-(exclusive) indicating the creature's current I position.
-
-(j-position status) @\Analogous to i-position.
-
-(peeking status) @\One of :LEFT, :RIGHT, or NIL.  Indicates whether the
-visual information coming in this turn is the result of a peek command
-in the previous turn.
-
-(line-of-sight status) @\An integer indicating the number of squares
-that can be seen in the direction the feeb is facing or peeking.  Thus,
-the number of valid entries in the VISION vector.
-
-(energy-reserve status) @\An integer indicating how many energy units
-the creature has, equivalent to the number of turns it can live (without
-flaming) before it starves to death.
-
-(score status) @\The creature's current score.
-
-(kills status) @\The total number of rivals killed by this feeb (not
-counting suicides).
-
-(ready-to-fire status) @\T if the creature is able to fire this turn,
-NIL if not.
-
-(aborted status) @\T if the creature's last move was aborted because it
-took too long.
-
-(last-move status) @\The last move issued by the creature.  Any of the
-action symbols listed above, or :DEAD if the creature has just been
-reincarnated.
-@End[Description]
-
-The PROXIMITY input is also a read-only structure, with slots describing
-the contents of the creature's current square and the adjacent ones to
-its rear, left, and right.  The slots are accessed as follows:
-
-@Begin[Description]
-(my-square proximity) @\Returns the contents of the current square.  A
-feeb does not see himself in this square, even though he is there.
-
-(rear-square proximity) @\Returns the contents of the square behind the
-creature.
-
-(left-square proximity) @\Returns the contents of the square to the
-creature's left.
-
-(right-square proximity) @\Returns the contents of the square to the
-creature's right.
-@End[Description]
-
-The values returned by these functions can be any of the following:
-
-@Begin[Description]
-NIL @\The square is empty space.
-
-:ROCK @\A solid rock wall in this direction.
-
-:MUSHROOM @\The square contains a mushroom.
-
-:CARCASS @\The square contains a carcass.
-
-A structure of type FEEB-IMAGE @\This represents a feeb.  One can call
-(feeb-image-name x) on this image to get the feeb's name and
-(feeb-image-facing x) to get the direction it is facing, expressed as an
-integer from 0 to 3.
-
-A structure of type FIREBALL-IMAGE @\This represents a fireball.  One
-can call (fireball-image-direction x) on this image to get the direction
-the fireball is moving, expressed as an integer from 0 to 3.
-
-A list @\This is used when more than one item is in the square at once.
-The list can contain any number of image structures, plus perhaps a
-:MUSHROOM and/or :CARCASS symbol.
-@End[Description]
-
-The VISION argument receives a simple vector whose length is the maximum of
-*maze-i-size* and *maze-j-size*.  Thus, it can hold any possible linear
-line of sight that can occur in the maze.  However, only some of the
-entries are really valid, as indicated by the value returned by the
-(line-of-sight status) call; entries beyond the valid range may contain
-garbage or hallucinations.
-
-Each item in the VISION vector describes what is in a given cell, using
-the same notation as for the PROXIMITY argument.  (svref vision 0)
-should return information about the square into which the feeb is
-facing, the same information that would be returned by (front-square
-proximity).  If the feeb is looking straight ahead, (svref vision 1)
-would return the contents of the next square in that direction, and so
-on, until we reach (svref vision (line-of-sight status)), which contains
-garbage.  If the feeb is peeking left or right, (svref vision 0)
-still accesses the square physically in front of the feeb, but higher
-indices access a line of squares to the left or right of that square.
-
-The VISION-LEFT and VISION-RIGHT arguments are simple vectors whose
-entries correspond to the entries in VISION.  Instead of indicating what
-is in each square along the line of sight, however, they tell the
-creature what is to the left or right of that square, along the
-direction in which you are looking (or peeking).  Each entry will have
-one of three values: NIL (an opening on that side), :ROCK (a solid rock
-wall on that side), or :PEEKING (an opening from which some creature is
-peeking into your corridor).  There is no way to tell whether the peeker
-is peeking in your feeb's direction or the other way or whether there are
-more than one of them.
-
-@section [Contest Rules]
-
-The rules for a feeb contest, including the settings of all the control
-parameters, are announced in advance so that the programmers know what
-kind of strategy to program into their behavior functions.  Knowledge
-about the maze itself may or may not be available, depending on how
-difficult the contest organizers want to make the game.  There are four
-levels of complexity:
-
-@begin [description]
-Level 0:@\The players are told in advance what the maze will look like,
-with or without information about the location of mushroom spaces and
-starting spaces.  This information can be used in writing the behavior
-functions.
-
-Level 1:@\No information is available about the maze in advance, but
-once the game begins a feeb can examine a map of the entire maze and
-plan a global strategy.  The map is an array of dimensions *maze-i-size*
-by *maze-j-size*, capable of holding any Lisp object in each element.
-Initially, each array cell will be either :ROCK or NIL (open space).  To
-obtain a map, call (GET-MAZE-MAP).  Each call produces a distinct map
-array, so it is possible to write into the map array, perhaps to take
-notes.
-
-Level 2:@\No map is available.  If a feeb wants information about the
-shape of the maze, it must explore the maze for itself.  Calls to
-(GET-MAZE-MAP) return NIL.
-
-Level 3:@\No map is available, and the feeb's location sense is
-disabled.  The I-POSITION and J-POSITION cells of the status object will
-always read 0.  This makes it much harder to create a map, since
-sections of map developed during different incarnations must be fitted
-together.
-@end [description]
-
-Each player will supply a feeb-creation function with some unique name.
-This function, which should be compiled, is loaded and then called with
-no arguments.  It returns two values: a behavior function for one feeb
-and a string that will be used as that feeb's name.  To avoid name
-conflicts, each player should choose a different package.  A complete
-feeb definition file might look like this:
-
-@begin [example]
-;;; -*- Package: Darth-Feeb -*-
-
-(in-package "DARTH-FEEB" :use '("LISP" "FEEBS"))
-
-;;; This feeb probably won't do too well against any other feebs.
-
-(defun darth-feeb-creator ()
-  (values
-    #'(lambda (status vision vision-left vision-right)
-        (declare (ignore status vision vision-left vision-right))
-        (svref '#(:turn-left :move-forward :flame) (random 3)))
-    "Darth Feeb"))
-
-@end [example]
-
-In a new Lisp, load "feebs.fasl" and any files containing feeb creation
-functions.  Then call (feebs:create-feeb <foo>) for each of the feeb
-creation functions.  Finally type (feebs:feebs) to start the show.
-Auto-feebs will be created as needed.  At the end, the final scores of
-all the feebs will be printed.
-
-Team play is possible, with a sort of telepathic communication between
-feebs on the same team.  This is accomplished by calling each
-feeb-creation function more than once.  All feebs "hatched" from the
-same creation function are team-mates, and their scores can be added
-together at the end of the game.  The creation function should return a
-different name for each team member; it can return the same behavior
-function for all team members, or a different function for each.  It is
-possible for these behavior functions to communicate via shared lexical
-variables.
-
-@section [Ideas for Future Extensions]
-
-It would be possible to create a large set of attributes and abilities
-that feebs might possess, and to make some of the existing ones
-optional.  Each of these abilities could be assigned a certain value,
-and players could select which combination of abilities their feebs will
-have from this menu.  There could be a fixed limit on the total value of
-features chosen, or a feeb too heavily loaded with features might just
-become slower or less energy-efficient than the others.
-
-Among the features that might be on the menu would be the ability to
-move backwards or sideways, the ability to peek, some ability to kill
-opponents in one's own square, extended range for the omni-directional
-proximity sense, a limited range for the visual sense, some ability to
-survive a fireball hit, a sense of smell that indicates the distance to
-the nearest food, the ability to see through a fireball (taken for
-granted now), the ability to obtain a complete or partial map,
-cold-bloodedness (a stationary feeb uses much less energy), and so on.
-
-We might also create a much more diverse and interesting set of
-non-player flora and fauna, and perhaps a more interesting landscape.
-
diff --git a/contrib/games/feebs/mazes.lisp b/contrib/games/feebs/mazes.lisp
deleted file mode 100644
index 0b7cc587a81bac3f968dadbfc9dd6698cba8069b..0000000000000000000000000000000000000000
--- a/contrib/games/feebs/mazes.lisp
+++ /dev/null
@@ -1,238 +0,0 @@
-;;; -*- Mode: Lisp; Package: Feebs; Log: feebs.log -*-
-;;;
-;;; Mazes for Planet of the Feebs.
-;;; A somewhat educational simulation game.
-;;;
-;;; Created by Jim Healy, July 1987.
-;;;
-;;; **************************************************
-;;; Maze guidelines:
-;;;    Maze should be *maze-i-size* by *maze-j-size*
-;;;       (currently 32 x 32).
-;;;    X represents a wall.
-;;;    * represents a mushroom patch.
-;;;    e is a feeb entry point.
-;;; **************************************************
-
-;;; Maze1 has a good number of dead ends and little nooks.
-
-(defparameter maze1
-  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXX     *eXXXX      *e      ** X"
-    "XXX XXXXX XXXX XXXXXXXXXXXX XX X"
-    "XXX   XXX      XXXXXX       X  X"
-    "XXXXX XXXXXXX XXXXXXX XXXXXXX XX"
-    "X *       XXX XX *    XeXX    XX"
-    "X XXXXXXX XXX XXXXXXX X XXX XXXX"
-    "X  XXXXXX XXX XX      X      *XX"
-    "X XXXXXXX XXX XXXXXXX XXXXXXXXXX"
-    "X XXXXXXX XXX*     e  XXXXXX XXX"
-    "X         XXXXX XXXXXXXXX  * XXX"
-    "X XXXXX XXXXXX     XXXXXX XX  XX"
-    "X eXXXX XXXXXX XXX  XXXXX XX XXX"
-    "X XXXXX*       XXXXe XXXX XX  XX"
-    "X XXXXX XXXXXX XXXXX  XXX XXX XX"
-    "X eXXXX    e   XXXXXX *XX XX  XX"
-    "X XXXXX XXXXXX XXXXXXX  X XXeXXX"
-    "X   XXX        XXXXXXXX   XX  XX"
-    "X XXXXX XXXXXX XXXXXXXXXX XXXXXX"
-    "X XXXXX      * XXXXX          XX"
-    "X*  XXX XXXXXX XXXXX XXXXXX X XX"
-    "X XXXXX e      XXXXX X  e   X XX"
-    "X XX XX XXXXXX XXXXX X XXXXXX XX"
-    "X         *XXX XXXXX       *  XX"
-    "X XX XX XXXXXX XXXXXXXXXX XXXXXX"
-    "X XXXXX XXXXXX   *   *        XX"
-    "X   XXX XXXXXXXXXXXXXXXXXXXXX XX"
-    "X XXXX    X    X   eX    X    XX"
-    "X  XXX XX X XX X XX X XX X XX XX"
-    "X XXXX XX X XX X XX X XX*X XX XX"
-    "X e *  XX   XX * XX   XX   XXeXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
-
-;;; Maze2 doesn't have any really long corridors.
-
-(defparameter maze2
-  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "X  eXXXXX * X   XXXXXX X e XXXXX"
-    "X XXXX    X X XXXX   X   X XXXXX"
-    "X  XX  XXXX   XXXX X*  X X XXXXX"
-    "XX XX XXX   XXXX   XX XX X     X"
-    "XX e  XXX XXXXXXX XX  XXXXXXXX*X"
-    "XXXX XXX    XXXXX X e XXX   XX X"
-    "XXXX XXX XXXXXXXX   XXXX  X    X"
-    "XX * XX   XXe  XXXXXXXXXX XX XXX"
-    "XX XXXX X XX X   XXX XXXXX   XXX"
-    "XX        XX XXX X   XX    XXXXX"
-    "XXXXX XXX   *XXX   X    XXXXXXXX"
-    "XX*   XXXXXX  XXXX XXXX XXXXXXXX"
-    "XXXXX XX XXXX XXXXXXXXX XXXXXXXX"
-    "XXXXX  e XXXX   *XXXXXX   eXXXXX"
-    "XXXXXXXX XXXXXXX XXXXXXXXX XXXXX"
-    "XXXXXX     XXXXX  eXXXXX   XXXXX"
-    "XXXXXX XXX XXXXXXX XXXXX XXXXXXX"
-    "XX     XXX X   XXX XX    X    XX"
-    "XX XXX   XXXXX XX   XX XXX XX XX"
-    "XX XXXXX  *X   XX X XX XXXXXX*XX"
-    "X    XXXXX   XXXX X      XX   XX"
-    "X XX XXXXXXX   XXXXX*X X Xe XXXX"
-    "X    XXXX  e X XXXXX*XX  XX XXXX"
-    "X XX XXXXXX XX   XXX*XXX     XXX"
-    "XXXX  eXXX  XXXX XX  XXXXX X   X"
-    "XXXXXX XXXXXXXXX XX XXXX   XXX X"
-    "XXX *  X X    XX    XXXX XXX X X"
-    "XX  XXXX X XX XXXX XXX   X  e  X"
-    "XX XX  *   X *   X XXXX XX XXX*X"
-    "XX    XXX XXX XX  eXXX     XXX*X"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
-
-;;; Maze3 has the minimum number of mushroom sites, most
-;;; of which are between a rock and a hard place.  Those
-;;; poor feebs!
-
-(defparameter maze3
-  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "X    e  XXXXXX XXXXXXX*XXXXXXXXX"
-    "X X XXX XXXXX e   XXXX XXX e   X"
-    "X   XXX XXXXXX XX XX   XXX XXX X"
-    "XXX XXX XXXXXX XX XX X X   e   X"
-    "Xe  XXX*XXXX*  XX XXeX X XXXXX X"
-    "X X XXX XXXXXX XX XX X   XXXXX X"
-    "X   XXX XXXXXX XX*   XXXXXXXXX X"
-    "X XXXXX XX e   XX XXXXXXXX XXX X"
-    "X X XXX XXX XXXXX XXXXXX   XXX X"
-    "Xe  XXX      XXXX XXXX   X X   X"
-    "XXX XXXX XXXXXXXX  X   XXX   XXX"
-    "XXX  eXX XXXXXXXXX   XXXXX XXXXX"
-    "XXXXX XXXXXXXXXXXX XXXXXX    XXX"
-    "XXXXX     *    XX eXX XXX XX XXX"
-    "XX*XXXX XXXXXX XX XXX XXX XX XXX"
-    "XX X    XXXXX  X  XXX    eXX XXX"
-    "X    XXXXXXXX XX XXXX XXX XX XXX"
-    "X XXXXeXXXXXX    XXXX XXX XX XXX"
-    "X      XX*XXXXX XXXXXXXXX    XXX"
-    "XXXXXX    XXX   XXXX  XXXXXX XXX"
-    "XXXXXXXXX XXX XXXXXX XXXXXX  XXX"
-    "XXX       XX  e          eX XXXX"
-    "XX  XXXXX    XXXX XXXX XXXX XXXX"
-    "XX XXXXX  XX XXXX XXXX XXXX   XX"
-    "XX eXXXX XX  XXXX XXXX XXXXXX XX"
-    "XXX XX   XXX     *        XXX XX"
-    "XX  XX XXXX* XXXX XXXX XXXXXX XX"
-    "XXX  X XXXXX XXXX XXXX X      XX"
-    "XXXX    e    XXXX XXXX X XX X  X"
-    "XXXXXXXXXXXX     *e       X e XX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
-
-
-;;; Maze4 is symmetric about the vertical axis.  (Wow...)
-
-(defparameter maze4
-  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "X*        eXXXXXXXXXXe        *X"
-    "X XXXXXXXX            XXXXXXXX X"
-    "X XX   XXXXXXX XX XXXXXXX   XX X"
-    "X    XeXXXXXXX XX XXXXXXXeX    X"
-    "XX X XXXXXXX  eXXe  XXXXXXX X XX"
-    "XX X XXXXXXX XXXXXX XXXXXXX X XX"
-    "XX * XXXXXXX XXXXXX XXXXXXX * XX"
-    "XX X XXXe              eXXX X XX"
-    "XX X XXX XXXXXXXXXXXXXX XXX X XX"
-    "XX e XXX    XXXXXXXX    XXX e XX"
-    "XX X XXXXXX XXXXXXXX XXXXXX X XX"
-    "XX X XXXX   XXXXXXXX   XXXX X XX"
-    "XX   XXXX XXXe   eXXXX XXXX   XX"
-    "XXX XXXXX XXX XXX XXXX XXXXX XXX"
-    "XXX XXXXX XXX      XXX XXXXX XXX"
-    "X*  XXXXX     XXXX     XXXXX  *X"
-    "X XXXXX XX XX  **  XX XX XXXXX X"
-    "X XXXXX XX XX XXXX XX XX XXXXX X"
-    "X XXX e XX XX XXXX XX XX e XXX X"
-    "X XXXXX XX    XXXX    XX XXXXX X"
-    "X XXXXX XXXXX XXXX XXXXX XXXXX X"
-    "X     X XXXXX XXXX XXXXX X     X"
-    "XXXXX  *                *  XXXXX"
-    "XXXXX XXXXXXXX XX XXXXXXXX XXXXX"
-    "XXXXX XXXXXXXX XX XXXXXXXX XXXXX"
-    "XXXXX    XXXXX XX XXXXX    XXXXX"
-    "XXXX  XX  XXXXeXXeXXXX  XX  XXXX"
-    "XXX  XXXX  XXX XX XXX  XXXX  XXX"
-    "XXX XXXXXX XXX XX XXX XXXXXX XXX"
-    "XX*       e    XX    e       *XX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
-
-;;; Maze5 has a lot of long corridors good for feeb showdowns.
-;;; Furthermore, all the feeb entry-points are in the corridors.
-;;; You can run but you can't hide!
-
-(defparameter maze5
-  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "X              e           e   X"
-    "X XXXXXXX*XXXXXXXXXXXX XXXXXXX X"
-    "X               e              X"
-    "X X XXXXX XXXXXXXXXXXX XXXXX X X"
-    "X              *               X"
-    "X X XX XX XXXXXXXXXXXX XX XX X X"
-    "X X XX XX XXXXXXXXXXXX XXeXX X X"
-    "X X XX XX    *         XX XX X X"
-    "XeX XX XX XXXXXXXXXXXX XX XX X X"
-    "X X XX XX XXXXXXXXXXXX XX XX X X"
-    "X X XX XX          e   XX XXeX X"
-    "X X XXeXX XXXXXXXXXXXX XX XX X X"
-    "X X XX XX XXXXXXXXXXXX XX XX XeX"
-    "X*X XX XX              XX XX X X"
-    "X X XX XX XXXXXXXXXXXX XX XX X X"
-    "X XeXX XX XXXXXXXXXXXX*XX XX X X"
-    "X X XX XX  *           XX XX*X X"
-    "X X XX XX XXXXXXXXXXXX XX XX X X"
-    "X X XX XX XXXXXXXXXXXX XX XX X X"
-    "X X XX XX  e           XX XX*X X"
-    "X X XX*XX XXXXXXXXXXXX XX XX X X"
-    "X X XX XX XXXXXXXXXXXX XX XX X X"
-    "X X XX XX              XX XXeX X"
-    "X X XX XX XXXXXXXXXXXX XX XX X X"
-    "X X XX XX XXXXXXXXXXXX XX XX X X"
-    "X             e                X"
-    "X*X XXXXX XXXXXXXXXXXX XXXXX X*X"
-    "X             e       *        X"
-    "X XXXXXXX XXXXXXXXXXXX XXXXXXX X"
-    "X     e        *               X"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
-
-;;; Don't try to run this next one!  Just use it to create
-;;; new mazes.
-
-(defparameter maze-template
-  '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
-    "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
-
diff --git a/contrib/hist/hist.catalog b/contrib/hist/hist.catalog
deleted file mode 100644
index e6858e5e332903b8ed1bba1d78ba5aae8119fa39..0000000000000000000000000000000000000000
--- a/contrib/hist/hist.catalog
+++ /dev/null
@@ -1,53 +0,0 @@
-Package Name:
-   HIST
-
-Description:
-   Simple histogram facility using Format strings for output.
-
-Author:
-   Scott E. Fahlman
-
-Address:
-   Carnegie-Mellon University
-   Computer Science Department
-   Pittsburgh, PA 15213
-
-Net Address:
-   Scott.Fahlman@CS.CMU.EDU
-
-Copyright Status:
-   Public Domain.
-
-Files:
-   hist.lisp, hist.fasl, hist.catalog
-
-How to Get:
-   The following unix command will copy the pertinent files into directory
-<spec>.
-   cp /afs/cs.cmu.edu/project/slisp/library/hist/* <spec>
-
-Portability:
-   Should run in any legal Common Lisp.
-
-Instructions:
-   Hist is a macro of form (HIST (min max [bucket-size]) . body)
-
-Creates a histogram with buckets of the specified size (defaults to 1),
-spanning the range from Low (inclusive) to High (exclusive), with two
-additional buckets to catch values below and above this range.  The body is
-executed as a progn, and every call to Hist-Record within the body provides a
-value for the histogram to count.  When Body exits, the histogram is printed
-out and Hist returns Nil.
-
-A simple example:
-   (hist (0 10) (dotimes (i 1000) (random 10)))
-This example may make the RANDOM distribution look more normal:
-   (hist (0 10 2) (dotimes (i 1000) (random 10)))
-This example will show you overflow buckets:
-   (hist (2 12) (dotimes (i 1000) (random 15)))
-
-Wish List:
-   Some sort of automatic scaling for the number and size of buckets would be
-nice, if the user chooses not to supply these.  This would probably require
-running the body twice, once to determine the spread of values, and again to
-actually produce the histogram.
diff --git a/contrib/hist/hist.lisp b/contrib/hist/hist.lisp
deleted file mode 100644
index 40f212416371cae068f458448a8f71ac5c84cbdb..0000000000000000000000000000000000000000
--- a/contrib/hist/hist.lisp
+++ /dev/null
@@ -1,89 +0,0 @@
-;;; -*- Mode: Lisp; Package: Hist; Log: Hist.Log -*-
-;;;
-;;; This code has been placed in the public domain by the author.
-;;; It is distributed without warranty of any kind.
-;;;
-;;; Description: Simple Histogram facility.  Just prints out the result
-;;;   using Format.  No fancy graphics.
-;;;
-;;; Author: Scott E. Fahlman
-;;;
-;;; Current maintainer:	Scott E. Fahlman
-;;;
-;;; Address: Carnegie-Mellon University
-;;;          Computer Science Department
-;;;	     Pittsburgh, PA 15213
-;;;
-;;; Net address: Scott.Fahlman@cmu-cs-a
-;;;
-;;; Copyright status: Public domain.
-;;;
-;;; Compatibility: Should run in any legal Common Lisp implementation.
-;;;
-;;; Dependencies: Depends only on standard Common Lisp facilities.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(in-package "HIST")
-(export '(hist hist-record))
-
-;;; Uses a bunch of specials for communication.
-
-(proclaim '(special *hist-lower-limit*
-		    *hist-upper-limit*
-		    *hist-bucket-size*
-		    *hist-nbuckets*
-		    *hist-array*))
-
-(defconstant hist-limit 60
-  "The maximum number of #'s that are to be printed.")
-
-(defmacro hist ((low high &optional (bucket-size 1))
-		&body body)
-  "Format is (HIST (low high [bucket-size]) . body).
-  Creates a histogram with buckets of the specified size (defaults to 1),
-  spanning the range from Low (inclusive) to High (exclusive), with two
-  additional buckets to catch values below and above this range.
-  The body is executed as a progn, and every call to Hist-Record within
-  the body provides a value for the histogram to count.
-  When Body exits, the histogram is printed out and Hist returns Nil."
-  `(let* ((*hist-lower-limit* ,low)
-	  (*hist-upper-limit* ,high)
-	  (*hist-bucket-size* ,bucket-size)
-	  (*hist-nbuckets*
-	   (+ 2 (ceiling (- *hist-upper-limit* *hist-lower-limit*)
-			 *hist-bucket-size*)))
-	  (*hist-array* (make-array *hist-nbuckets* :initial-element 0)))
-     (progn ,@body)
-     (let ((biggest 0) (scale 1))
-       (dotimes (b (- *hist-nbuckets* 2))
-	 (when (> (svref *hist-array* b) biggest)
-	   (setq biggest (svref *hist-array* b))))
-       (when (> biggest hist-limit)
-	 (setq scale (ceiling biggest hist-limit))
-	 (format t "~&Each \"#\" equals ~S units.  The \".\" indicates a fraction."
-		 scale))
-       (format t "~&< ~S: ~12,8T~S~%"
-	       *hist-lower-limit*
-	       (svref *hist-array* (1- *hist-nbuckets*)))
-       (do ((b 0 (1+ b))
-	    (bval *hist-lower-limit* (+ bval *hist-bucket-size*))
-	    (bcount 0))
-	   ((= b (- *hist-nbuckets* 2)))
-	 (setq bcount (svref *hist-array* b))
-	 (multiple-value-bind (q r) (truncate bcount scale)
-	   (format t "~S: ~12,8T~S~20,8T~V,1,0,'#@A~%"
-		   bval bcount (1+ q) (if (zerop r) #\  #\.))))
-       (format t "> ~S: ~12,8T~S~%"
-	       *hist-upper-limit*
-	       (svref *hist-array* (- *hist-nbuckets* 2))))
-     nil))
-
-(defun hist-record (value)
-  "This function should only be called within the body of a HIST form.
-  Increments the proper histogram counter to record this value."
-  (cond ((< value *hist-lower-limit*)
-	 (incf (svref *hist-array* (1- *hist-nbuckets*))))
-	((>= value *hist-upper-limit*)
-	 (incf (svref *hist-array* (- *hist-nbuckets* 2))))
-	(t (incf (svref *hist-array* (floor (- value *hist-lower-limit*)
-					    *hist-bucket-size*))))))
diff --git a/contrib/library-maintenance/catalog-cat.lisp b/contrib/library-maintenance/catalog-cat.lisp
deleted file mode 100644
index 4d2493896adae6dc08f02c1300adf74b9f3257f5..0000000000000000000000000000000000000000
--- a/contrib/library-maintenance/catalog-cat.lisp
+++ /dev/null
@@ -1,64 +0,0 @@
-;;; -*- Mode: Lisp; Package: library -*-
-;;; 
-;;; This contains somewhat specific code for gathering all the pertinent
-;;; .catalog files from the CMU Common Lisp Library subdirectories to
-;;; construct one catalog.txt file from them.
-;;; 
-;;; This code uses at least one implementation internal function, hacks
-;;; pathnames as strings, accepts CMU Common Lisp logical names, tries
-;;; to determine what a directory name looks like, uses CMU Common Lisp
-;;; extensions, and generally tries not to be portable in any way.
-;;; 
-;;; Written by Bill Chiles
-;;;
-
-(in-package "LIBRARY" :nicknames '("LIB"))
-
-(export 'build-catalog)
-
-
-(defun build-catalog (dir)
-  "Gather all the .catalog files from the subdirectories of dir, bashing them
-   into a file named \"new-catalog.txt\" in dir.  The argument must be a
-   logical name or end with a slash (/)"
-  (with-open-file (stream (merge-pathnames dir "new-catalog.txt")
-			  :direction :output :if-exists :new-version)
-    (let* ((files (catalog-files dir))
-	   (last (car (last files))))
-      (dolist (f files)
-	(with-open-file (catalog f)
-	  (do ((line (read-line catalog nil :eof)
-		     (read-line catalog nil :eof)))
-	      ((eq line :eof))
-	    (write-line line stream))
-	  (unless (equal f last)
-	    (format stream "~%~|~%")))))))
-
-
-;;; CATALOG-FILES does a DIRECTORY (CMU Common Lisp) of dir returning a
-;;; list of file names containing the string ".catalog".  The directory
-;;; listing may include subdirectories, but these subdirs contain only
-;;; files (one of which is a catalog file).  The subdirectory catalog
-;;; files are included in the result list in order of the subdirectory's
-;;; appearance.
-;;; 
-(defun catalog-files (dir)
-  (let ((listing (directory dir))
-	result)
-    (dolist (f listing (nreverse result))
-      (let ((name (namestring f)))
-	(declare (simple-string name))
-	(if (directoryp f)
-	    (dolist (f (directory name))
-	      (let ((name (namestring f)))
-		(declare (simple-string name))
-		(when (search ".catalog" name :test #'char=)
-		  (push name result)
-		  (return))))
-	    (if (search ".catalog" name :test #'char=)
-		(push name result)))))))
-
-(defun directoryp (p)
-  (let ((p (pathname p)))
-    (string= (the simple-string (directory-namestring p))
-	     (the simple-string (namestring p)))))
diff --git a/contrib/library-maintenance/compile-lib.lisp b/contrib/library-maintenance/compile-lib.lisp
deleted file mode 100644
index 8525db0fdab037d62a4ed9f1994348451be8fee6..0000000000000000000000000000000000000000
--- a/contrib/library-maintenance/compile-lib.lisp
+++ /dev/null
@@ -1,21 +0,0 @@
-;;; -*- Mode: Lisp; Package: library -*-
-;;;
-;;; This file contains stupid code to simply compile all the library entries.
-;;;
-;;; Written by Blaine Burks.
-;;;
-
-(in-package "LIBRARY" :nicknames '("LIB"))
-
-(export '(compile-entries))
-
-(defun compile-entries ()
-  (let ((lib-directory (directory ed::*lisp-library-directory*)))
-    (dolist (lib-spec lib-directory)
-      (let* ((path-parts (pathname-directory lib-spec))
-	     (last (svref path-parts (1- (length path-parts))))
-	     (raw-pathname (merge-pathnames last lib-spec)))
-	(when (and (ed::directoryp lib-spec)
-		   (probe-file (merge-pathnames ".catalog" raw-pathname)))
-	  (compile-file (merge-pathnames raw-pathname ".lisp") :error-file nil)
-	  (write-string last))))))
diff --git a/contrib/library-maintenance/old-catalog-format.txt b/contrib/library-maintenance/old-catalog-format.txt
deleted file mode 100644
index d6ea1d00eec4d0a342b3c12e7ce2c1f6b0b23982..0000000000000000000000000000000000000000
--- a/contrib/library-maintenance/old-catalog-format.txt
+++ /dev/null
@@ -1,72 +0,0 @@
-
-CATALOG ENTRY FORMAT FOR CATALOG.TXT.
-
-Each entry is on a separate page, separated by the page mark Control-L.
-
-Each entry consists of fields.  Each new field begins with a field name in
-square brackets, then an arbitrary amount of text.  This rather rigid
-format is designed to make it easy to build various sorts of software to
-automatically manipulate catalogs.  The field names are sensitive to
-spelling, but insensitive to case and extra whitespace.
-
-Fields currently recognized are as follows:
-
-[Name] or [Module Name]: The name of the program or set of programs.  If no
-Package Name is supplied, then this is assumed to name of the package in
-which the code lives.
-
-[Package Name]: If the programs are loaded into a package of their own, the
-name of this package.  If no Name or Module Name is supplied, the package
-name will be used as the name for everything.
-
-[Description]: A brief description of what the program does.
-
-[Author]: Name of the author, or "anonymous".
-
-[Maintainer]: Name of current maintainer, if different from the author.  If
-a program is not being maintained by anyone, the Maintainer is "none".
-
-[Address], [Address of Author], [Address of Maintainer]: Physical mailing
-address of author or maintainer.  If the field is just "address", it is
-assumed to be the maintainer if one is specified, and the author otherwise.
-
-[Net Address], [Net Address of Author], [Net Address of Maintainer]: A
-network address that can be reached from the arpanet.
-
-[Copyright Status]: "Public domain" or some sort of copyright notice.
-
-[Files]: A list of the files comprising this facility.  If a system whose
-name is "Foo" is distributed as files "foo.slisp", "foo.sfasl", and
-(optionally) "foo.doc" or "foo.press" for documentation.  In order to
-minimize maintenance headaches and encourage people to build on the work of
-others, we want all programs in the library to include complete sources.
-
-[How to Get]: This can either be a shell command using such programs as lcp
-or cp.  There will usually be a .cmd file that will copy all the sources,
-binaries, catalog, and log files to the user's current directory.  This
-.cmd file will try to preserve write date (such as using -p with cp).
-
-[Portability]: If the program will run in any legal Common Lisp, say so.
-If there are known dependencies on CMU Common Lisp specific or
-Mach/RT specific features, describe them here.
-
-[Dependencies]: If the program requires other library packages not built
-into the standard CMU Common Lisp core image, list those other packages
-here.
-
-[Instructions]: Place here any instructions for use that are too lengthy to
-be mere documentation strings, but that are not lengthy enough to deserve a
-separate document.
-
-[Recent Changes]: What is different between this version and the one that
-preceded it, if any.  (May go back several versions at the author's
-discretion.)
-
-[Bugs]: Describe here any known bugs or treacherous features.
-
-[Future Plans]: Describe here any improvements planned by the author.
-
-[Wish List]: Describe here any desirable features that the author does not
-plan to work on in the near future.
-
-[Notes]: Anything else that users or potential users ought to know about.
diff --git a/contrib/ops/b.ops b/contrib/ops/b.ops
deleted file mode 100644
index b774bd1d1090962a46ff755a4c2b4ef0911c3343..0000000000000000000000000000000000000000
--- a/contrib/ops/b.ops
+++ /dev/null
@@ -1,181 +0,0 @@
-
-
-(literalize primer zero role count zero)
-(literalize maker role count fin zero)
-(literalize goal count zero)
-
-
-(p run
-	(goal ^count <c>)
-    -->
-	(bind <z> (compute <c> + 1))
-	(modify 1    ^count <z>))
-
-
-(p makeprimer
-	(maker ^count <c>    ^fin > <c>    ^role <r>)
-    -->
-	(make    primer    ^role <r>    ^zero 0    ^count <c>)
-	(bind <z> (compute <c> + 1))
-	(modify 1    ^count <z>))
-
-
-(p beginrun
-	(maker ^count <c>    ^fin = <c>    ^role left)
-	(maker ^count <d>    ^fin = <d>    ^role right)
-    -->
-	(remove 1)
-	(remove 1)
-	(make goal    ^count 0    ^zero 0))
-
-
-(p start
-	(start)
-    -->
-	(remove 1)
-	(make maker    ^role left     ^count 1    ^fin 50)
-	(make maker    ^role right    ^count 1    ^fin 50))
-
-
-(p leftrule10
-	(goal ^zero <c>)
-	(primer    ^role left     ^zero <> <c>    ^count <> 10)
-    -->
-	(remove 1))
-
-
-(p leftrule9
-	(goal ^zero <c>)
-	(primer    ^role left     ^zero <> <c>    ^count <> 9)
-    -->
-	(remove 1))
-
-
-(p leftrule8
-	(goal ^zero <c>)
-	(primer    ^role left     ^zero <> <c>    ^count <> 8)
-    -->
-	(remove 1))
-
-
-(p leftrule7
-	(goal ^zero <c>)
-	(primer    ^role left     ^zero <> <c>    ^count <> 7)
-    -->
-	(remove 1))
-
-
-(p leftrule6
-	(goal ^zero <c>)
-	(primer    ^role left     ^zero <> <c>    ^count <> 6)
-    -->
-	(remove 1))
-
-
-(p leftrule5
-	(goal ^zero <c>)
-	(primer    ^role left     ^zero <> <c>    ^count <> 5)
-    -->
-	(remove 1))
-
-
-(p leftrule4
-	(goal ^zero <c>)
-	(primer    ^role left     ^zero <> <c>    ^count <> 4)
-    -->
-	(remove 1))
-
-
-(p leftrule3
-	(goal ^zero <c>)
-	(primer    ^role left     ^zero <> <c>    ^count <> 3)
-    -->
-	(remove 1))
-
-
-(p leftrule2
-	(goal ^zero <c>)
-	(primer    ^role left     ^zero <> <c>    ^count <> 2)
-    -->
-	(remove 1))
-
-
-(p leftrule1
-	(goal ^zero <c>)
-	(primer    ^role left     ^zero <> <c>    ^count <> 1)
-    -->
-	(remove 1))
-
-
-
-
-(p rightrule10
-	(primer    ^role right     ^zero <c>    ^count <> 10)
-	(goal ^zero <> <c>)
-    -->
-	(remove 1))
-
-
-(p rightrule9
-	(primer    ^role right     ^zero <c>    ^count <> 9)
-	(goal ^zero <> <c>)
-    -->
-	(remove 1))
-
-
-(p rightrule8
-	(primer    ^role right     ^zero <c>    ^count <> 8)
-	(goal ^zero <> <c>)
-    -->
-	(remove 1))
-
-
-(p rightrule7
-	(primer    ^role right     ^zero <c>    ^count <> 7)
-	(goal ^zero <> <c>)
-    -->
-	(remove 1))
-
-
-(p rightrule6
-	(primer    ^role right     ^zero <c>    ^count <> 6)
-	(goal ^zero <> <c>)
-    -->
-	(remove 1))
-
-
-(p rightrule5
-	(primer    ^role right     ^zero <c>    ^count <> 5)
-	(goal ^zero <> <c>)
-    -->
-	(remove 1))
-
-
-(p rightrule4
-	(primer    ^role right     ^zero <c>    ^count <> 4)
-	(goal ^zero <> <c>)
-    -->
-	(remove 1))
-
-
-(p rightrule3
-	(primer    ^role right     ^zero <c>    ^count <> 3)
-	(goal ^zero <> <c>)
-    -->
-	(remove 1))
-
-
-(p rightrule2
-	(primer    ^role right     ^zero <c>    ^count <> 2)
-	(goal ^zero <> <c>)
-    -->
-	(remove 1))
-
-
-(p rightrule1
-	(primer    ^role right     ^zero <c>    ^count <> 1)
-	(goal ^zero <> <c>)
-    -->
-	(remove 1))
-
-
diff --git a/contrib/ops/bug.ops b/contrib/ops/bug.ops
deleted file mode 100644
index b907f35f38a4de343c12512db3ff7123238c15dd..0000000000000000000000000000000000000000
--- a/contrib/ops/bug.ops
+++ /dev/null
@@ -1,15 +0,0 @@
-(literalize wme val)
-
-(p sort
-    (wme    ^val <x>)
-  - (wme    ^val < <x>)
-    -->
-    (write <x> (crlf))
-    (remove 1))
-
-(p start
-    (start)
-    -->
-    (make wme    ^val 0)
-    (make wme    ^val 1)
-    (make wme    ^val -1))
diff --git a/contrib/ops/ceramic.ops b/contrib/ops/ceramic.ops
deleted file mode 100644
index a49dee19b05eccfd41eaec654f3b3c93cda6b8f3..0000000000000000000000000000000000000000
--- a/contrib/ops/ceramic.ops
+++ /dev/null
@@ -1,348 +0,0 @@
-
-
-(literalize component)	(literalize context)	(literalize pcon)	(literalize datum)
-(literalize computation)	(literalize setattr)	(literalize template)	(literalize interaction)
-(literalize lineitem)	(literalize local)	(literalize discrlist)	(literalize task)
-(literalize arg)	(literalize call)	(literalize order)	(literalize wip)
-(literalize location)	(literalize input)	(literalize object)	(literalize x)
-(literalize status)	(literalize place)	(literalize time)	(literalize port)
-(literalize module)	(literalize link)	(literalize lists)	(literalize outnode)
-(literalize operator)	(literalize current)	(literalize attval)	(literalize choice)
-(literalize applied)	(literalize stateop)	(literalize exit)
-(literalize component0)	(literalize context0)	(literalize pcon0)	(literalize datum0)
-(literalize computation0)	(literalize setattr0)	(literalize template0)	(literalize interaction0)
-(literalize lineitem0)	(literalize local0)	(literalize discrlist0)	(literalize task0)
-(literalize arg0)	(literalize call0)	(literalize order0)	(literalize wip0)
-(literalize location0)	(literalize input0)	(literalize object0)	(literalize x0)
-(literalize status0)	(literalize place0)	(literalize time0)	(literalize port0)
-(literalize module0)	(literalize link0)	(literalize lists0)	(literalize outnode0)
-(literalize operator0)	(literalize current0)	(literalize attval0)	(literalize choice0)
-(literalize applied0)	(literalize stateop0)	(literalize exit0)
-(literalize tank)	(literalize pipe)	(literalize measurement)	(literalize reading)
-(literalize goal)	(literalize material)
-
-(literalize primer
-	spacer
-	role
-	cnt
-	null)
-
-(literalize count
-	spacer
-	role
-	null
-	val
-	delta
-	null2)
-
-
-
-(p start
-	(start)
-    -->
-    	(remove 1)
-	(make primer    ^role exist    ^cnt 1)
-	(make primer    ^role exist    ^cnt 2)
-	(make primer    ^role exist    ^cnt 3)
-	(make primer    ^role exist    ^cnt 4)
-	(make primer    ^role exist    ^cnt 5)
-	(make primer    ^role exist    ^cnt 6)
-	(make primer    ^role exist    ^cnt 7)
-	(make primer    ^role exist    ^cnt 8)
-	(make primer    ^role exist    ^cnt 9)
-	(make primer    ^role exist    ^cnt 10)
-	(make primer    ^role exist    ^cnt 11)
-	(make primer    ^role exist    ^cnt 12)
-	(make primer    ^role exist    ^cnt 13)
-	(make primer    ^role exist    ^cnt 14)
-	(make primer    ^role exist    ^cnt 15)
-	(make primer    ^role exist    ^cnt 16)
-	(make primer    ^role exist    ^cnt 17)
-	(make primer    ^role exist    ^cnt 18)
-	(make primer    ^role exist    ^cnt 19)
-	(make primer    ^role exist    ^cnt 20)
-	(make primer    ^role exist    ^cnt 21)
-	(make primer    ^role exist    ^cnt 22)
-	(make primer    ^role exist    ^cnt 23)
-	(make primer    ^role exist    ^cnt 24)
-	(make primer    ^role exist    ^cnt 25)
-	(make primer    ^role exist    ^cnt 26)
-	(make primer    ^role exist    ^cnt 27)
-	(make primer    ^role exist    ^cnt 28)
-	(make primer    ^role exist    ^cnt 29)
-	(make primer    ^role exist    ^cnt 30)
-	(make count    ^role exist    ^val 1    ^delta 7)
-	(make count    ^role exist    ^val 2    ^delta 7)
-	(make count    ^role exist    ^val 3    ^delta 7)
-	(make count    ^role exist    ^val 4    ^delta 7)
-	(make count    ^role exist    ^val 5    ^delta 7)
-	(make count    ^role exist    ^val 6    ^delta 7)
-	(make count    ^role exist    ^val 7    ^delta 7)
-	(make primer    ^role driver    ^cnt -1))
-
-
-
-(p driver
-	(primer    ^role driver    ^null <x>)
-	(count    ^null <x>    ^val <val>    ^delta <delta>)
-    -	(count    ^val < <val>)
-    -->
-    	(modify 2 ^val  (compute <val> + <delta>)))
-
-
-(p driverCopy
-	(primer    ^role driver    ^null <x>)
-	(count    ^null <x>    ^val <val>    ^delta <delta>)
-    -	(count    ^val < <val>)
-    -->
-    	(modify 2 ^val  (compute <val> + <delta>)))
-
-
-(p alphamem
-	(primer    ^role nonexist)
-	(count)
-	(count)
-	(count)
-	(count)
-	(count)
-	(count)
-	(count)
-    -->
-        (halt))
-
-
-(p betamem1
-	(count    ^null <> betamem1)
-	(primer	   ^role nonexist)
-    -->
-        (halt))
-
-
-(p betamem2
-	(count    ^null <> betamem2)
-	(primer	   ^role nonexist)
-    -->
-        (halt))
-
-
-(p betamem3
-	(count    ^null <> betamem3)
-	(primer	   ^role exist    ^cnt < 1)
-    -->
-        (halt))
-
-
-(p betaleft1
-	(count    ^null <> betamem3    ^null <n>)
-	(primer	   ^role exist    ^cnt <= 25    ^role <n>)
-    -->
-        (halt))
-
-
-(p betaleft2
-	(count    ^null <> betamem3    ^null <n>)
-	(primer	   ^role exist    ^cnt <= 24    ^role <n>)
-    -->
-        (halt))
-
-
-(p andrightnull1
-	(primer    ^role nonexist1)
-	(count)
-	(count)
-	(count)
-	(count)
-	(count)
-	(count)
-	(count)
-    -->
-        (halt))
-
-
-(p andrightnull2
-	(primer    ^role nonexist2)
-	(count)
-	(count)
-	(count)
-	(count)
-    -->
-        (halt))
-
-
-(p andrightloop
-	(primer    ^role exist    ^cnt <= 13    ^null <n>)
-	(count    ^role <n>)
-    -->
-    	(halt))
-
-
-(p notleft
-	(primer    ^role driver    ^null <x>)
-	(count    ^null <x>)
-    -	(primer    ^role exist    ^cnt <= 23    ^null <x>    ^null <x>)
-    -->
-    	(halt))
-
-
-(p notrnull1
-	(primer    ^role notex1)
-    -	(count)
-    -->
-        (halt))
-
-
-(p notrnull2
-	(primer    ^role notex2)
-    -	(count)
-    -->
-        (halt))
-
-
-(p notrnull3
-	(primer    ^role notex3)
-    -	(count)
-    -->
-        (halt))
-
-
-(p notrnull4
-	(primer    ^role notex4)
-    -	(count)
-    -->
-        (halt))
-
-
-(p notrnull5
-	(primer    ^role notex5)
-    -	(count)
-    -->
-        (halt))
-
-
-(p notrnull6
-	(primer    ^role notex6)
-    -	(count)
-    -->
-        (halt))
-
-
-(p notright
-	(primer    ^role exist    ^cnt <= 8   ^null <x>)
-    -	(count    ^null <x>    ^null2 <x>)
-    -->
-        (halt))
-
-
-(p object12
-	(component)	(context)	(pcon)		(datum)
-	(computation)	(setattr)    	(template)	(interaction)
-	(lineitem)	(local)		(discrlist)	(task)
-	-->
-	(halt))
-
-(p object24
-	(arg)		(call)		(order)		(wip)
-	(location)	(input)		(object)	(x)
-	(status)	(place)		(time)		(port)
-	-->
-	(halt))
-
-(p object36
-	(module)	(link)		(lists)		(outnode)
-	(operator)	(current)	(attval)	(choice)
-	(operator)	(applied)	(stateop)	(exit)
-	-->
-	(halt))
-
-
-(p object48
-	(component0)	(context0)	(pcon0)		(datum0)
-	(computation0)	(setattr0)    	(template0)	(interaction0)
-	(lineitem0)	(local0)	(discrlist0)	(task0)
-	-->
-	(halt))
-
-(p object60
-	(arg0)		(call0)		(order0)	(wip0)
-	(location0)	(input0)	(object0)	(x0)
-	(status0)	(place0)	(time0)		(port0)
-	-->
-	(halt))
-
-(p object72
-	(module0)	(link0)		(lists0)	(outnode0)
-	(operator0)	(current0)	(attval0)	(choice0)
-	(operator0)	(applied0)	(stateop0)	(exit0)
-	-->
-	(halt))
-
-(p object78
-	(tank)		(pipe)		(measurement)	(reading)
-	(goal)		(material)
-	-->
-	(halt))
-
-
-(p tnea0
-	(count    ^null a)
-	(count    ^null b)
-	(count    ^null c)
-	(count    ^null d)
-	(count    ^null e)
-	(count    ^null f)
-	(count    ^null g)
-	(count    ^null h)
-	(count    ^null i)
-	(count    ^null j)
-    -->
-    	(halt))
-
-(p tnea1
-	(count    ^null a1)
-	(count    ^null b1)
-	(count    ^null c1)
-	(count    ^null d1)
-	(count    ^null e1)
-	(count    ^null f1)
-	(count    ^null g1)
-	(count    ^null h1)
-	(count    ^null i1)
-	(count    ^null j1)
-    -->
-    	(halt))
-
-(p tnea2
-	(count    ^null a2)
-	(count    ^null b2)
-	(count    ^null c2)
-	(count    ^null d2)
-	(count    ^null e2)
-	(count    ^null f2)
-	(count    ^null g2)
-	(count    ^null h2)
-	(count    ^null i2)
-	(count    ^null j2)
-    -->
-    	(halt))
-
-(p tnea3
-	(count    ^null a3)
-	(count    ^null b3)
-	(count    ^null c3)
-	(count    ^null d3)
-	(count    ^null e3)
-	(count    ^null f3)
-	(count    ^null g3)
-    -->
-    	(halt))
-
-
-(p cs
-	(primer    ^role exist    ^cnt <= 2)
-	(primer    ^role exist    ^cnt <= 2)
-	(primer    ^role exist    ^cnt <= 2)
-	(primer    ^role exist    ^cnt <= 1)
-	(primer    ^role exist    ^cnt <= 1)
-	(primer    ^role exist    ^cnt <= 1)
-    -->
-    	(halt))
diff --git a/contrib/ops/compile-ops.lisp b/contrib/ops/compile-ops.lisp
deleted file mode 100644
index e4ef985dd7373dd5ae195798aa58f609a5f75e72..0000000000000000000000000000000000000000
--- a/contrib/ops/compile-ops.lisp
+++ /dev/null
@@ -1,12 +0,0 @@
-(unless (find-package "OPS") (make-package "OPS"))
-
-(compile-file 
- '("library:contrib/ops/ops-util.lisp"
-   "library:contrib/ops/ops-compile.lisp"
-   "library:contrib/ops/ops-rhs.lisp"
-   "library:contrib/ops/ops-match.lisp"
-   "library:contrib/ops/ops-main.lisp"
-   "library:contrib/ops/ops-backup.lisp"
-   "library:contrib/ops/ops-io.lisp"
-   "library:contrib/ops/ops.lisp")
- :output-file "library:contrib/ops/ops.fasl")
diff --git a/contrib/ops/dec.ops b/contrib/ops/dec.ops
deleted file mode 100644
index de2b04a6c5658c8afcb8061c8788447c97511c11..0000000000000000000000000000000000000000
--- a/contrib/ops/dec.ops
+++ /dev/null
@@ -1,299 +0,0 @@
-
-(literalize player
-  number
-  nights-scheduled)
-
-(literalize foursome
-  night
-  group
-  north
-  south
-  east
-  west)
-
-(literalize context
-  name)
-
-(literalize scheduling
-  night)
-
-(literalize already-played
-  player1
-  player2)
-
-(literalize candidate
-  group
-  chosen
-  south
-  east
-  west)
-
-
-(p startup 
-  (start)
--->
-  (make player ^number 1 ^nights-scheduled 0)
-  (make player ^number 2 ^nights-scheduled 0)
-  (make player ^number 3 ^nights-scheduled 0)
-  (make player ^number 4 ^nights-scheduled 0)
-  (make player ^number 5 ^nights-scheduled 0)
-  (make player ^number 6 ^nights-scheduled 0)
-  (make player ^number 7 ^nights-scheduled 0)
-  (make player ^number 8 ^nights-scheduled 0)
-  (make player ^number 9 ^nights-scheduled 0)
-  (make player ^number 10 ^nights-scheduled 0)
-  (make player ^number 11 ^nights-scheduled 0)
-  (make player ^number 12 ^nights-scheduled 0)
-  (make player ^number 13 ^nights-scheduled 0)
-  (make player ^number 14 ^nights-scheduled 0)
-  (make player ^number 15 ^nights-scheduled 0)
-  (make player ^number 16 ^nights-scheduled 0)
-  (make foursome ^night 1 ^group a ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 1 ^group b ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 1 ^group c ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 1 ^group d ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 2 ^group a ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 2 ^group b ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 2 ^group c ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 2 ^group d ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 3 ^group a ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 3 ^group b ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 3 ^group c ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 3 ^group d ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 4 ^group a ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 4 ^group b ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 4 ^group c ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 4 ^group d ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 5 ^group a ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 5 ^group b ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 5 ^group c ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 5 ^group d ^north nil ^south nil ^east nil ^west nil)
-  (make context ^name north)
-  (make scheduling ^night 1)
-  (write (tabto 32) |Tournament Schedule| (crlf) (crlf)
-	 (tabto 15) |N  S  E  W|
-	 (tabto 42) |N  S  E  W|
-	 (tabto 68) |N  S  E  W| (crlf)
-	 (tabto 15) |=  =  =  =|
-	 (tabto 42) |=  =  =  =|
-	 (tabto 68) |=  =  =  =| (crlf)))
-
-(p north:pick-one-1
-  (context ^name north)
-  (scheduling ^night <n>)
-  { <THE-FOURSOME> (foursome ^night <n> ^north nil) }
-  { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) }
-  (foursome ^night <n> ^north { <p1> <> nil })
-  (foursome ^night <n> ^north { <p2> <> <p1> <> nil })
-  (foursome ^night <n> ^north { <p3> <> <p2> <> <p1> <> nil })
-  (already-played ^player1 <p> ^player2 <p1>)
-  (already-played ^player1 <p> ^player2 <p2>)
-  (already-played ^player1 <p> ^player2 <p3>)
--->
-  (modify <THE-PLAYER> ^nights-scheduled <n>)
-  (modify <THE-FOURSOME> ^north <p>) )
-
-(p north:pick-one-2
-  (context ^name north)
-  (scheduling ^night <n>)
-  { <THE-FOURSOME> (foursome ^night <n> ^north nil) }
-  { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) }
-  (foursome ^night <n> ^north { <p1> <> nil })
-  (foursome ^night <n> ^north { <p2> <> <p1> <> nil })
-  (already-played ^player1 <p> ^player2 <p1>)
-  (already-played ^player1 <p> ^player2 <p2>)
--->
-  (modify <THE-PLAYER> ^nights-scheduled <n>)
-  (modify <THE-FOURSOME> ^north <p>) )
-
-(p north:pick-one-3
-  (context ^name north)
-  (scheduling ^night <n>)
-  { <THE-FOURSOME> (foursome ^night <n> ^north nil) }
-  { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) }
-  (foursome ^night <n> ^north { <p1> <> nil })
-  (already-played ^player1 <p> ^player2 <p1>)
--->
-  (modify <THE-PLAYER> ^nights-scheduled <n>)
-  (modify <THE-FOURSOME> ^north <p>) )
-
-(p north:pick-one-4
-  (context ^name north)
-  (scheduling ^night <n>)
-  { <THE-FOURSOME> (foursome ^night <n> ^north nil) }
-  { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) }
--->
-  (modify <THE-PLAYER> ^nights-scheduled <n>)
-  (modify <THE-FOURSOME> ^north <p>) )
-
-(p north:done
-  { <THE-CONTEXT> (context ^name north) }
--->
-  (modify <THE-CONTEXT> ^name make-candidates))
-
-(p make-candidates:make-candidate
-  (context ^name make-candidates)
-  (scheduling ^night { <n> < 3 })
-  (foursome ^night <n> ^group <g> ^north <yankee>)
-  (player ^number <redneck> ^nights-scheduled < <n>)
-  (player ^number { <oriental> < <redneck> } ^nights-scheduled < <n>)
-  (player ^number { <cowboy> < <oriental> } ^nights-scheduled < <n>)
-  - (already-played ^player1 <yankee> ^player2 <redneck>)
-  - (already-played ^player1 <yankee> ^player2 <oriental>)
-  - (already-played ^player1 <yankee> ^player2 <cowboy>)
-  - (already-played ^player1 <redneck> ^player2 <oriental>)
-  - (already-played ^player1 <redneck> ^player2 <cowboy>)
-  - (already-played ^player1 <oriental> ^player2 <cowboy>)
-  - (candidate ^group <g> ^chosen no ^south <redneck> ^east <oriental>)
-  - (candidate ^group <g> ^chosen no ^south <redneck> ^west <cowboy>)
-  - (candidate ^group <g> ^chosen no ^east <oriental> ^west <cowboy>)
--->
-  (make candidate ^group <g> ^chosen no
-	 ^south <redneck> ^east <oriental> ^west <cowboy>))
-
-(p make-candidates:make-candidate-late
-  (context ^name make-candidates)
-  (scheduling ^night { <n> > 2 })
-  (foursome ^night <n> ^group <g> ^north <yankee>)
-  (player ^number <redneck> ^nights-scheduled < <n>)
-  (player ^number { <oriental> < <redneck> } ^nights-scheduled < <n>)
-  (player ^number { <cowboy> < <oriental> } ^nights-scheduled < <n>)
-  - (already-played ^player1 <yankee> ^player2 <redneck>)
-  - (already-played ^player1 <yankee> ^player2 <oriental>)
-  - (already-played ^player1 <yankee> ^player2 <cowboy>)
-  - (already-played ^player1 <redneck> ^player2 <oriental>)
-  - (already-played ^player1 <redneck> ^player2 <cowboy>)
-  - (already-played ^player1 <oriental> ^player2 <cowboy>)
--->
-  (make candidate ^group <g> ^chosen no
-	^south <redneck> ^east <oriental> ^west <cowboy>))
-
-(p make-candidates:done
-  { <THE-CONTEXT> (context ^name make-candidates) }
--->
-  (modify <THE-CONTEXT> ^name make-choice)) 
-
-(p make-choice:doit
-  { <THE-CONTEXT> (context ^name make-choice) }
-  { <WINNER-A> (candidate ^group a ^chosen no
-	^south <sa>
-	^east  <ea>
-	^west  <wa>) }
-  { <WINNER-B> (candidate ^group b ^chosen no
-	^south { <sb> <> <sa> <> <ea> <> <wa> }
-	^east  { <eb> <> <sa> <> <ea> <> <wa> }
-	^west  { <wb> <> <sa> <> <ea> <> <wa> }) }
-  { <WINNER-C> (candidate ^group c ^chosen no
-	^south { <sc> <> <sa> <> <ea> <> <wa> <> <sb> <> <eb> <> <wb> }
-	^east  { <ec> <> <sa> <> <ea> <> <wa> <> <sb> <> <eb> <> <wb> }
-	^west  { <wc> <> <sa> <> <ea> <> <wa> <> <sb> <> <eb> <> <wb> }) }
-  { <WINNER-D> (candidate ^group d ^chosen no
-	^south { <sd>
-			<> <sa> <> <ea> <> <wa>
-			<> <sb> <> <eb> <> <wb>
-			<> <sc> <> <ec> <> <wc> }
-	^east  { <ed>
-			<> <sa> <> <ea> <> <wa>
-			<> <sb> <> <eb> <> <wb>
-			<> <sc> <> <ec> <> <wc> }
-	^west  { <wd>
-			<> <sa> <> <ea> <> <wa>
-			<> <sb> <> <eb> <> <wb>
-			<> <sc> <> <ec> <> <wc> }) }
---> 
-  (modify <WINNER-A> ^chosen yes)
-  (modify <WINNER-B> ^chosen yes)
-  (modify <WINNER-C> ^chosen yes)
-  (modify <WINNER-D> ^chosen yes)
-  (modify <THE-CONTEXT> ^name remove-candidates))
-
-(p remove-candidates:bye
-  (context ^name remove-candidates)
-  { <THE-CANDIDATE> (candidate ^chosen no) }
--->
-  (remove <THE-CANDIDATE>))
-
-(p remove-candidates:done
-  { <THE-CONTEXT> (context ^name remove-candidates) }
--->
-  (modify <THE-CONTEXT> ^name apply-choice))
-
-(p apply-choice:doit
-  (context ^name apply-choice)
-  (scheduling ^night <n>)
-  { <THE-FOURSOME> (foursome ^night <n> ^group <g> ^north <yankee>) }
-  { <THE-CHOICE> (candidate ^group <g> ^chosen yes
-			^south <redneck> ^east <oriental> ^west <cowboy>) }
--->
-  (modify <THE-FOURSOME> ^south <redneck> ^east <oriental> ^west <cowboy>)
-  (remove <THE-CHOICE>)
-  (make already-played ^player1 <yankee> ^player2 <redneck>)
-  (make already-played ^player2 <yankee> ^player1 <redneck>)
-  (make already-played ^player1 <yankee> ^player2 <oriental>)
-  (make already-played ^player2 <yankee> ^player1 <oriental>)
-  (make already-played ^player1 <yankee> ^player2 <cowboy>)
-  (make already-played ^player2 <yankee> ^player1 <cowboy>)
-  (make already-played ^player1 <redneck> ^player2 <oriental>)
-  (make already-played ^player2 <redneck> ^player1 <oriental>)
-  (make already-played ^player1 <redneck> ^player2 <cowboy>)
-  (make already-played ^player2 <redneck> ^player1 <cowboy>)
-  (make already-played ^player1 <oriental> ^player2 <cowboy>)
-  (make already-played ^player2 <oriental> ^player1 <cowboy>))
-
-(p apply-choice:done
-  { <THE-CONTEXT> (context ^name apply-choice) }
--->
-  (modify <THE-CONTEXT> ^name report))
-
-(p report:night-schedule
-  { <THE-CONTEXT> (context ^name report) }
-  (scheduling ^night <n>)
-  (foursome ^night <n> ^group a ^north <an> ^south <as> ^east <ae> ^west <aw>)
-  (foursome ^night <n> ^group b ^north <bn> ^south <bs> ^east <be> ^west <bw>)
-  (foursome ^night <n> ^group c ^north <cn> ^south <cs> ^east <ce> ^west <cw>)
-  (foursome ^night <n> ^group d ^north <dn> ^south <ds> ^east <de> ^west <dw>)
--->
-  (modify <THE-CONTEXT> ^name next-night)
-  (bind <n2> (compute <n> + 5))
-  (bind <n3> (compute <n> + 10))
-  (write (crlf) (rjust 1) |#| (rjust 1) <n> (rjust 1) : (tabto 5)
-	|Group A:| (rjust 3) <an> (rjust 3) <as> (rjust 3) <ae> (rjust 3) <aw>
-	(tabto 27) (rjust 1) |#| (rjust 2) <n2> (rjust 1) : (tabto 32)
-	|Group A:| (rjust 3) <an> (rjust 3) <ae> (rjust 3) <as> (rjust 3) <aw>
-	(tabto 53) (rjust 1) |#| (rjust 2) <n3> (rjust 1) : (tabto 58)
-	|Group A:| (rjust 3) <an> (rjust 3) <aw> (rjust 3) <ae> (rjust 3) <as>)
-   (write (crlf)
-	(tabto 5)
-	|Group B:| (rjust 3) <bn> (rjust 3) <bs> (rjust 3) <be> (rjust 3) <bw>
-	(tabto 32)
-	|Group B:| (rjust 3) <bn> (rjust 3) <be> (rjust 3) <bs> (rjust 3) <bw>
-	(tabto 58)
-	|Group B:| (rjust 3) <bn> (rjust 3) <bw> (rjust 3) <be> (rjust 3) <bs>)
-   (write  (crlf)
-	(tabto 5)
-	|Group C:| (rjust 3) <cn> (rjust 3) <cs> (rjust 3) <ce> (rjust 3) <cw>
-	(tabto 32)
-	|Group C:| (rjust 3) <cn> (rjust 3) <ce> (rjust 3) <cs> (rjust 3) <cw>
-	(tabto 58)
-	|Group C:| (rjust 3) <cn> (rjust 3) <cw> (rjust 3) <ce> (rjust 3) <cs>)
-   (write (crlf)
-	(tabto 5)
-	|Group D:| (rjust 3) <dn> (rjust 3) <ds> (rjust 3) <de> (rjust 3) <dw>
-	(tabto 32)
-	|Group D:| (rjust 3) <dn> (rjust 3) <de> (rjust 3) <ds> (rjust 3) <dw>
-	(tabto 58)
-	|Group D:| (rjust 3) <dn> (rjust 3) <dw> (rjust 3) <de> (rjust 3) <ds>
-    (crlf)))
-
-(p next-night:more
-  { <THE-CONTEXT> (context ^name next-night) }
-  { <THE-NIGHT> (scheduling ^night { <n> < 5 }) }
--->
-  (modify <THE-CONTEXT> ^name north)
-  (modify <THE-NIGHT> ^night (compute <n> + 1)))
-
-(p next-night:done
-  (context ^name next-night)
--->
-  (write (tabto 32) |End of Scheduling| (crlf) (crlf)))
-
diff --git a/contrib/ops/fbug.ops b/contrib/ops/fbug.ops
deleted file mode 100644
index 878f005255daf0311a6972b80d497b1a946db36b..0000000000000000000000000000000000000000
--- a/contrib/ops/fbug.ops
+++ /dev/null
@@ -1,3089 +0,0 @@
-
-
-(literal wme-type = 1)
-
-
-
-
-
-
-
- (literal
-     geometry             = 2
-     row                  = 3
-     column               = 4 )
-
-
-
-
-
- (literal
-     length               = 3
-     delta                = 2
-     nb                   = 4
-     nb+d                 = 5
-     nb+2d                = 6
-     nb+3d                = 7
-     nb+4d                = 8
-     nb+5d                = 9
-     nb+6d                = 10 )
-
-
-
-
-
- (literal
-     nb                   = 4
-     nb-incremented       = 2 )
-
-
-
-
-
- (literal
-     value                = 3 )
-
-
-
-
-
- (literal
-     name                 = 5
-     length               = 3
-     geometry             = 2
-     owner                = 4
-     position-1-state     = 6
-     position-2-state     = 7
-     position-3-state     = 8
-     position-4-state     = 9
-     position-5-state     = 10
-     position-6-state     = 11
-     position-7-state     = 12
-     position-1-counter-to-update  = 13
-     position-2-counter-to-update  = 14
-     position-3-counter-to-update  = 15
-     position-4-counter-to-update  = 16
-     position-5-counter-to-update  = 17
-     position-6-counter-to-update  = 18
-     position-7-counter-to-update  = 19 )
-
-
-
-
-
- (literal
-     row                  = 3
-     column               = 4
-     point-of-view        = 2
-     name                 = 5 )
-
-
-
-
-
- (literal
-     row                  = 3
-     column               = 4
-     point-of-view        = 2
-     nb-of-compulsory-answer-creations  = 5
-     nb-of-fragile-winners  = 6
-     nb-of-strong-winners  = 7 )
-
-
-
-
-
- (literal
-     type                 = 2
-     is-better-than-type  = 3 )
-
-
-
-
-
- (literal
-     type                 = 2
-     state                = 5
-     row                  = 3
-     column               = 4
-     score                = 6 )
-
-
-
-
-
- (literal
-     name                 = 5
-     point-of-views&counters-to-add  = 6
-     comment              = 2 )
-
-
-
-
-
- (literal
-     type                 = 2
-     value                = 3 )
-
-
-
-
-
- (literal
-     beginning-row        = 2
-     beginning-column     = 3
-     ending-row           = 4
-     ending-column        = 5 )
-
-
-
-
-
- (literal
-     state                = 5
-     row                  = 3
-     column               = 4 )
-
-
-
-
-
- (literal
-     meaning              = 2
-     drawing-character    = 3 )
-
-
-
-
-
- (literal
-     nb-of-columns        = 2
-     nb-of-rows           = 3
-     nb-of-columns-incr   = 4
-     nb-of-rows-incr      = 5
-     max-board-size       = 6
-     max-board-size-incr  = 7 )
-
-
-
-
-
- (literal
-     board-row            = 3
-     board-column         = 4
-     type                 = 2
-     line-type            = 5
-     previous-board-position-row  = 6
-     previous-board-position-column  = 7
-     next-board-position-row  = 8
-     next-board-position-column  = 9
-     nw-board-position-row  = 10
-     nw-board-position-column  = 11
-     ne-board-position-row  = 12
-     ne-board-position-column  = 13
-     se-board-position-row  = 14
-     se-board-position-column  = 15
-     sw-board-position-row  = 16
-     sw-board-position-column  = 17 )
-
-
-
-
-
- (literal
-     of                   = 2
-     is                   = 3 )
-
-
-
-
-
- (literal
-     row                  = 3
-     column               = 4
-     state                = 5
-     vertical-state       = 2
-     horizontal-state     = 6
-     right-bent-state     = 7
-     left-bent-state      = 8 )
-
-
-
-
-
- (literal
-     current-context      = 2
-     current-sub-context  = 3
-     current-player       = 4
-     human-score          = 5
-     computer-score       = 6 )
-
-
-
-(p board-analyse::segment-updating-of-length-5
-    (incrementation-table ^length 5 ^delta <i> ^nb <nb1> ^nb+d <nb1+i>
-       ^nb+2d <nb1+2i> ^nb+3d <nb1+3i> ^nb+4d <nb1+4i>)
-    (incrementation-table ^length 5 ^delta <j> ^nb <nb2> ^nb+d <nb2+j>
-      ^nb+2d <nb2+2j> ^nb+3d <nb2+3j> ^nb+4d <nb2+4j>)
-    (direction ^geometry <geometry> ^row <i> ^column <j>)
-    (segment-type
-      ^length 5 ^geometry <geometry>
-      ^owner <owner>
-      ^position-1-state <position-1-state>
-      ^position-2-state <position-2-state>
-      ^position-3-state <position-3-state>
-      ^position-4-state <position-4-state>
-      ^position-5-state <position-5-state>
-      ^position-1-counter-to-update <position-1-counter-to-update>
-      ^position-2-counter-to-update <position-2-counter-to-update>
-      ^position-3-counter-to-update <position-3-counter-to-update>
-      ^position-4-counter-to-update <position-4-counter-to-update>
-      ^position-5-counter-to-update <position-5-counter-to-update>)
-    (position ^row <nb1> ^column <nb2> ^state <position-1-state>)
-    (position ^row <nb1+i> ^column <nb2+j> ^state <position-2-state>)
-    (position ^row <nb1+2i> ^column <nb2+2j> ^state <position-3-state>)
-    (position ^row <nb1+3i> ^column <nb2+3j> ^state <position-4-state>)
-    (position ^row <nb1+4i> ^column <nb2+4j> ^state <position-5-state>)
--->
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1> ^column <nb2>
-           ^name <position-1-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+i> ^column <nb2+j>
-           ^name <position-2-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+2i> ^column <nb2+2j>
-           ^name <position-3-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+3i> ^column <nb2+3j>
-           ^name <position-4-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+4i> ^column <nb2+4j>
-           ^name <position-5-counter-to-update>))
-
-(p board-analyse::segment-updating-of-length-6
-    (incrementation-table ^length 6 ^delta <i> ^nb <nb1> ^nb+d <nb1+i>
-       ^nb+2d <nb1+2i> ^nb+3d <nb1+3i> ^nb+4d <nb1+4i> ^nb+5d <nb1+5i>)
-    (incrementation-table ^length 6 ^delta <j> ^nb <nb2> ^nb+d <nb2+j>
-      ^nb+2d <nb2+2j> ^nb+3d <nb2+3j> ^nb+4d <nb2+4j> ^nb+5d <nb2+5j>)
-    (direction ^geometry <geometry> ^row <i> ^column <j>)
-    (segment-type
-      ^length 6 ^geometry <geometry>
-      ^owner <owner>
-      ^position-1-state <position-1-state>
-      ^position-2-state <position-2-state>
-      ^position-3-state <position-3-state>
-      ^position-4-state <position-4-state>
-      ^position-5-state <position-5-state>
-      ^position-6-state <position-6-state>
-      ^position-1-counter-to-update <position-1-counter-to-update>
-      ^position-2-counter-to-update <position-2-counter-to-update>
-      ^position-3-counter-to-update <position-3-counter-to-update>
-      ^position-4-counter-to-update <position-4-counter-to-update>
-      ^position-5-counter-to-update <position-5-counter-to-update>
-      ^position-6-counter-to-update <position-6-counter-to-update>)
-    (position ^row <nb1> ^column <nb2> ^state <position-1-state>)
-    (position ^row <nb1+i> ^column <nb2+j> ^state <position-2-state>)
-    (position ^row <nb1+2i> ^column <nb2+2j> ^state <position-3-state>)
-    (position ^row <nb1+3i> ^column <nb2+3j> ^state <position-4-state>)
-    (position ^row <nb1+4i> ^column <nb2+4j> ^state <position-5-state>)
-    (position ^row <nb1+5i> ^column <nb2+5j> ^state <position-6-state>)
--->
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1> ^column <nb2>
-           ^name <position-1-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+i> ^column <nb2+j>
-           ^name <position-2-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+2i> ^column <nb2+2j>
-           ^name <position-3-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+3i> ^column <nb2+3j>
-           ^name <position-4-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+4i> ^column <nb2+4j>
-           ^name <position-5-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+5i> ^column <nb2+5j>
-           ^name <position-6-counter-to-update>))
-
-(p board-analyse::segment-updating-of-length-7
-    (incrementation-table ^length 7 ^delta <i> ^nb <nb1> ^nb+d <nb1+i>
-       ^nb+2d <nb1+2i> ^nb+3d <nb1+3i> ^nb+4d <nb1+4i> ^nb+5d <nb1+5i> ^nb+6d <nb1+6i>)
-    (incrementation-table ^length 7 ^delta <j> ^nb <nb2> ^nb+d <nb2+j>
-      ^nb+2d <nb2+2j> ^nb+3d <nb2+3j> ^nb+4d <nb2+4j> ^nb+5d <nb2+5j> ^nb+6d <nb2+6j>)
-    (direction ^geometry <geometry> ^row <i> ^column <j>)
-    (segment-type
-      ^length 7 ^geometry <geometry>
-      ^owner <owner>
-      ^position-1-state <position-1-state>
-      ^position-2-state <position-2-state>
-      ^position-3-state <position-3-state>
-      ^position-4-state <position-4-state>
-      ^position-5-state <position-5-state>
-      ^position-6-state <position-6-state>
-      ^position-7-state <position-7-state>
-      ^position-1-counter-to-update <position-1-counter-to-update>
-      ^position-2-counter-to-update <position-2-counter-to-update>
-      ^position-3-counter-to-update <position-3-counter-to-update>
-      ^position-4-counter-to-update <position-4-counter-to-update>
-      ^position-5-counter-to-update <position-5-counter-to-update>
-      ^position-6-counter-to-update <position-6-counter-to-update>
-      ^position-7-counter-to-update <position-7-counter-to-update>)
-    (position ^row <nb1> ^column <nb2> ^state <position-1-state>)
-    (position ^row <nb1+i> ^column <nb2+j> ^state <position-2-state>)
-    (position ^row <nb1+2i> ^column <nb2+2j> ^state <position-3-state>)
-    (position ^row <nb1+3i> ^column <nb2+3j> ^state <position-4-state>)
-    (position ^row <nb1+4i> ^column <nb2+4j> ^state <position-5-state>)
-    (position ^row <nb1+5i> ^column <nb2+5j> ^state <position-6-state>)
-    (position ^row <nb1+6i> ^column <nb2+6j> ^state <position-7-state>)
--->
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1> ^column <nb2>
-           ^name <position-1-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+i> ^column <nb2+j>
-           ^name <position-2-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+2i> ^column <nb2+2j>
-           ^name <position-3-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+3i> ^column <nb2+3j>
-           ^name <position-4-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+4i> ^column <nb2+4j>
-           ^name <position-5-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+5i> ^column <nb2+5j>
-           ^name <position-6-counter-to-update>)
-    (make counter-to-update
-           ^point-of-view <owner>
-           ^row <nb1+6i> ^column <nb2+6j>
-           ^name <position-7-counter-to-update>))
-
-(p board-analyse::garbage-cleaning
-    (game-state
-      ^current-context board-analyse
-      ^current-sub-context garbage-cleaning)
-    (counter-to-update)
--->
-    (remove 2))
-
-(p board-analyse::garbage-cleaning-end
-    (game-state
-      ^current-context board-analyse
-      ^current-sub-context garbage-cleaning)
--->
-    (modify 1 ^current-sub-context counters-decrementation))
-
-(p board-analyse::initialisations-for-counters-decrementation
-    (game-state
-      ^current-context board-analyse
-      ^current-sub-context counters-decrementation)
-    (new-move ^row <row> ^column <column>)
-    (position ^row <row> ^column <column>)
-    (number-to-add-while-updating-counters ^value <> -1)
--->
-    (modify 4 ^value -1)
-    (modify 3 ^row <row>))
-
-(p board-analyse::counters-decrementation-end
-    (game-state
-      ^current-context board-analyse
-      ^current-sub-context counters-decrementation)
--->
-    (modify 1 ^current-sub-context counters-incrementation))
-
-(p board-analyse::initialisations-for-counters-incrementation
-    (game-state
-      ^current-context board-analyse
-      ^current-sub-context counters-incrementation)
-    (new-move ^row <row> ^column <column> ^state <state>)
-    (position ^row <row> ^column <column>)
-    (number-to-add-while-updating-counters ^value <> 1)
--->
-    (remove 2)
-    (modify 4 ^value 1)
-    (modify 3 ^state <state>))
-
-(p board-analyse::counters-incrementation-end
-    (game-state
-      ^current-context board-analyse
-      ^current-sub-context counters-incrementation)
-    (number-to-add-while-updating-counters)
--->
-    (modify 2 ^value ignore-it)
-    (modify 1 ^current-context choice-of-a-move
-              ^current-sub-context choice-of-segments))
-
-
-(p board-analyse::counter-updating
-    (game-state ^current-context board-analyse)
-    (counter-to-update
-      ^name {<name> <> garbage}
-      ^row <row>
-      ^column <column>
-      ^point-of-view <point-of-view>)
-    (number-to-add-while-updating-counters
-      ^value {<increment-value> <> ignore-it})
-    (position-analyse
-      ^row <row>
-      ^column <column>
-      ^point-of-view <point-of-view>)
-    (position
-      ^row <row>
-      ^column <column>
-      ^state vacant)
--->
-    (bind <counter-value> (substr 4 <name> <name>))
-    (modify 4 ^<name> (compute <increment-value> + <counter-value>))
-    (remove 2))
-
-(p board-analyse::making-of-two-position-analyses
-    (game-state ^current-context board-analyse)
-    (counter-to-update
-      ^name {<name> <> garbage}
-      ^row <row>
-      ^column <column>)
-    (number-to-add-while-updating-counters
-      ^value <> ignore-it)
-   -(position-analyse
-      ^row <row>
-      ^column <column>)
-    (position
-      ^row <row>
-      ^column <column>
-      ^state vacant)
-
--->
-    (make position-analyse
-           ^row <row> ^column <column>
-           ^point-of-view human
-           ^nb-of-compulsory-answer-creations 0
-           ^nb-of-fragile-winners 0
-           ^nb-of-strong-winners 0)
-    (make position-analyse
-           ^row <row> ^column <column>
-           ^point-of-view computer
-           ^nb-of-compulsory-answer-creations 0
-           ^nb-of-fragile-winners 0
-           ^nb-of-strong-winners 0))
-
-(p board-analyse::removal-of-a-pointless-position-analyse
-    (game-state ^current-context board-analyse)
-    (number-to-add-while-updating-counters
-      ^value {<increment-value> <> ignore-it})
-    (position-analyse
-      ^row <row>
-      ^column <column>)
-    (position
-      ^row <row>
-      ^column <column>
-      ^state <> vacant)
--->
-    (remove 3))
-
-
-(p board-analyse::removal-of-a-pointless-counter-updating
-    (counter-to-update
-      ^name garbage)
--->
-    (remove 1))
-
-
-
-
-
-(p choice-of-a-move-by-the-computer::compulsory-answers-computation
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context generation-of-the-best-possible-moves
-      ^current-player computer)
-    (position-analyse
-      ^point-of-view computer
-      ^row <row>
-      ^column <column>
-      ^nb-of-compulsory-answer-creations <nbcacc>)
-    (position-analyse
-      ^point-of-view human
-      ^row <row>
-      ^column <column>
-      ^nb-of-strong-winners <nbswh>)
--->
-    (make possible-move
-           ^state non-validated-nb-of-compulsory-answer-creations
-           ^row <row>
-           ^column <column>
-	   ^score (compute <nbcacc> + <nbswh>)))
-
-(p choice-of-a-move-by-the-computer::compulsory-answers-validation
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context generation-of-the-best-possible-moves
-      ^current-player computer)
-   {(possible-move
-     ^state non-validated-nb-of-compulsory-answer-creations
-     ^row <row>
-     ^column <column>
-     ^score {<score> >= 2 }) <possible-move>}
--->
-    (modify <possible-move>
-	    ^state validated-nb-of-compulsory-answer-creations))
-
-(p choice-of-a-move-by-the-computer::compulsory-answers-validation-to-0
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context generation-of-the-best-possible-moves
-      ^current-player computer)
-   {(possible-move
-     ^state non-validated-nb-of-compulsory-answer-creations
-     ^row <row>
-     ^column <column>
-     ^score {<score> < 2 }) <possible-move>}
--->
-    (modify <possible-move>
-	    ^score 0
-	    ^state validated-nb-of-compulsory-answer-creations))
-
-(p choice-of-a-move-by-the-computer::score-computation
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context generation-of-the-best-possible-moves
-      ^current-player computer)
-  {(possible-move
-     ^state validated-nb-of-compulsory-answer-creations
-     ^row <row>
-     ^column <column>
-     ^score <score>) <possible-move>}
-    (position-analyse
-      ^point-of-view computer
-      ^row <row>
-      ^column <column>
-      ^nb-of-fragile-winners <nbfwc>
-      ^nb-of-strong-winners <nbswc>)
-    (position-analyse
-      ^point-of-view human
-      ^row <row>
-      ^column <column>
-      ^nb-of-fragile-winners <nbfwh>
-      ^nb-of-compulsory-answer-creations <nbcach>)
--->
-    (modify <possible-move>
-	    ^state computed
-	    ^score (compute (100 * (<nbfwh> + <nbfwc>)) +
-			    (10 * <score>) +
-			    <nbcach> + (2 * <nbswc>))))
-
-
-(p choice-of-a-move-by-the-computer::selection-of-the-best-moves
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context generation-of-the-best-possible-moves
-      ^current-player computer)
-   {(possible-move
-      ^state computed
-      ^score <score-i>) <possible-move-i>}
-    (possible-move
-      ^state computed
-      ^score  > <score-i>)
--->
-    (remove  <possible-move-i>))
-
-(p choice-of-a-move-by-the-computer::generation-of-the-best-possible-moves-end
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context generation-of-the-best-possible-moves
-      ^current-player computer)
--->
-    (modify 1
-      ^current-sub-context choice-of-the-move))
-
-(p choice-of-a-move-by-the-computer::removal-of-all-possible-moves
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-the-move
-      ^current-player computer)
-    (possible-move
-      ^row <row>
-      ^column <column>)
-    (new-move)
--->
-    (remove 2))
-
-(p choice-of-a-move-by-the-computer::blind-pick-up-of-one-of-the-best
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-the-move
-      ^current-player computer)
-    (possible-move
-      ^row <row>
-      ^column <column>)
-   -(new-move)
--->
-    (make last-computer-move <row> <column>)
-    (make new-move
-           ^state computer
-           ^row <row>
-           ^column <column>))
-
-(p choice-of-a-move-by-the-computer::blind-pick-up-of-a-vacant-position
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-the-move
-      ^current-player computer)
-   -(possible-move)
-   -(new-move)
-    (position ^state << human computer >>)
-    (position
-      ^state vacant
-      ^row <row>
-      ^column <column>)
--->
-    (make last-computer-move <row> <column>)
-    (make new-move
-           ^state computer
-           ^row <row>
-           ^column <column>))
-
-(p choice-of-a-move-by-the-computer::first-move
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-the-move
-      ^current-player computer)
-   -(position ^state << computer human >>)
--->
-    (make last-computer-move 6 5)
-    (make new-move
-           ^state computer
-           ^row 6
-           ^column 5))
-
-(p choice-of-a-move-by-the-computer::end-of-the-choice-of-the-move
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-the-move
-      ^current-player computer)
--->
-    (modify 1 ^current-context board-analyse
-              ^current-sub-context garbage-cleaning))
-
-(p choice-of-a-move-by-the-computer::vertical-segment-choice
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^computer-score <computer-score>
-      ^current-player computer)
-    (incrementation-table ^length 4 ^delta 1 ^nb <nb1> ^nb+d <nb1+i>
-       ^nb+2d <nb1+2i> ^nb+3d <nb1+3i>)
-    (incrementation-table ^length 4 ^delta 0 ^nb <nb2> ^nb+d <nb2+j>
-      ^nb+2d <nb2+2j> ^nb+3d <nb2+3j>)
-    (position ^row <nb1> ^column <nb2>
-              ^state computer ^vertical-state << free end-of-a-segment >>)
-    (position ^row <nb1+i> ^column <nb2+j>
-              ^state computer ^vertical-state << free end-of-a-segment >>)
-    (position ^row <nb1+2i> ^column <nb2+2j>
-              ^state computer ^vertical-state << free end-of-a-segment >>)
-    (position ^row <nb1+3i> ^column <nb2+3j>
-              ^state computer ^vertical-state << free end-of-a-segment >>)
--->
-    (modify 1 ^computer-score (compute <computer-score> + 1))
-    (modify 4 ^vertical-state end-of-a-segment)
-    (modify 5 ^vertical-state inside-a-segment)
-    (modify 6 ^vertical-state inside-a-segment)
-    (modify 7 ^vertical-state end-of-a-segment))
-
-(p choice-of-a-move-by-the-computer::horizontal-segment-choice
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^computer-score <computer-score>
-      ^current-player computer)
-    (incrementation-table ^length 4 ^delta 0 ^nb <nb1> ^nb+d <nb1+i>
-       ^nb+2d <nb1+2i> ^nb+3d <nb1+3i>)
-    (incrementation-table ^length 4 ^delta 1 ^nb <nb2> ^nb+d <nb2+j>
-      ^nb+2d <nb2+2j> ^nb+3d <nb2+3j>)
-    (position ^row <nb1> ^column <nb2>
-              ^state computer ^horizontal-state << free end-of-a-segment >>)
-    (position ^row <nb1+i> ^column <nb2+j>
-              ^state computer ^horizontal-state << free end-of-a-segment >>)
-    (position ^row <nb1+2i> ^column <nb2+2j>
-              ^state computer ^horizontal-state << free end-of-a-segment >>)
-    (position ^row <nb1+3i> ^column <nb2+3j>
-              ^state computer ^horizontal-state << free end-of-a-segment >>)
--->
-    (modify 1 ^computer-score (compute <computer-score> + 1))
-    (modify 4 ^horizontal-state end-of-a-segment)
-    (modify 5 ^horizontal-state inside-a-segment)
-    (modify 6 ^horizontal-state inside-a-segment)
-    (modify 7 ^horizontal-state end-of-a-segment))
-
-(p choice-of-a-move-by-the-computer::right-bent-segment-choice
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^computer-score <computer-score>
-      ^current-player computer)
-    (incrementation-table ^length 4 ^delta -1 ^nb <nb1> ^nb+d <nb1+i>
-       ^nb+2d <nb1+2i> ^nb+3d <nb1+3i>)
-    (incrementation-table ^length 4 ^delta 1 ^nb <nb2> ^nb+d <nb2+j>
-      ^nb+2d <nb2+2j> ^nb+3d <nb2+3j>)
-    (position ^row <nb1> ^column <nb2>
-              ^state computer ^right-bent-state << free end-of-a-segment >>)
-    (position ^row <nb1+i> ^column <nb2+j>
-              ^state computer ^right-bent-state << free end-of-a-segment >>)
-    (position ^row <nb1+2i> ^column <nb2+2j>
-              ^state computer ^right-bent-state << free end-of-a-segment >>)
-    (position ^row <nb1+3i> ^column <nb2+3j>
-              ^state computer ^right-bent-state << free end-of-a-segment >>)
--->
-    (modify 1 ^computer-score (compute <computer-score> + 1))
-    (modify 4 ^right-bent-state end-of-a-segment)
-    (modify 5 ^right-bent-state inside-a-segment)
-    (modify 6 ^right-bent-state inside-a-segment)
-    (modify 7 ^right-bent-state end-of-a-segment))
-
-(p choice-of-a-move-by-the-computer::left-bent-segment-choice
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^computer-score <computer-score>
-      ^current-player computer)
-    (incrementation-table ^length 4 ^delta 1 ^nb <nb1> ^nb+d <nb1+i>
-       ^nb+2d <nb1+2i> ^nb+3d <nb1+3i>)
-    (incrementation-table ^length 4 ^delta 1 ^nb <nb2> ^nb+d <nb2+j>
-      ^nb+2d <nb2+2j> ^nb+3d <nb2+3j>)
-    (position ^row <nb1> ^column <nb2>
-              ^state computer ^left-bent-state << free end-of-a-segment >>)
-    (position ^row <nb1+i> ^column <nb2+j>
-              ^state computer ^left-bent-state << free end-of-a-segment >>)
-    (position ^row <nb1+2i> ^column <nb2+2j>
-              ^state computer ^left-bent-state << free end-of-a-segment >>)
-    (position ^row <nb1+3i> ^column <nb2+3j>
-              ^state computer ^left-bent-state << free end-of-a-segment >>)
--->
-    (modify 1 ^computer-score (compute <computer-score> + 1))
-    (modify 4 ^left-bent-state end-of-a-segment)
-    (modify 5 ^left-bent-state inside-a-segment)
-    (modify 6 ^left-bent-state inside-a-segment)
-    (modify 7 ^left-bent-state end-of-a-segment))
-
-(p choice-of-a-move-by-the-computer::end-of-choice-of-segments
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^computer-score <computer-score>
-      ^current-player computer)
--->
-    (modify 1
-            ^current-context board-drawing
-            ^current-player human))
-
-
-
-
-
-
-
-
-(p generation-of-incrementation
-    (game-state ^current-context initialisations)
-    (board-parameters
-      ^max-board-size-incr <mbs+1>)
-    (incrementation
-      ^nb <nb>
-      ^nb-incremented  {<nb-incremented> < <mbs+1>})
-   -(incrementation
-      ^nb <nb-incremented>)
--->
-    (make incrementation
-           ^nb <nb-incremented>
-           ^nb-incremented (compute <nb-incremented> + 1)))
-
-
-(p generation-of-incrementation-table
-    (game-state ^current-context initialisations)
-    (delta <delta>)
-    (nb <nb>)
-    (length <length>)
--->
-    (make incrementation-table
-	      ^length <length>
-	      ^delta <delta>
-	      ^nb <nb>
-	      ^nb+d (compute <nb> + <delta>)
-              ^nb+2d (compute <nb> + ( 2 * <delta>))
-              ^nb+3d (compute <nb> + ( 3 * <delta>))
-              ^nb+4d (compute <nb> + ( 4 * <delta>))
-              ^nb+5d (compute <nb> + ( 5 * <delta>))
-              ^nb+6d (compute <nb> + ( 6 * <delta>))))
-
-(p cleaning-of-superfluous-incrementation-tables-2
-    (game-state ^current-context initialisations)
-    (board-parameters
-      ^max-board-size-incr <mbs+1>)
-   {(incrementation-table ^length 7 ^nb+6d > <mbs+1>)
-    <incrementation-table>}
--->
-    (remove <incrementation-table>))
-
-(p cleaning-of-superfluous-incrementation-tables-3
-    (game-state ^current-context initialisations)
-    (board-parameters
-      ^max-board-size-incr <mbs+1>)
-   {(incrementation-table ^length 6 ^nb+5d > <mbs+1>)
-    <incrementation-table>}
--->
-    (remove <incrementation-table>))
-
-(p cleaning-of-superfluous-incrementation-tables-4
-    (game-state ^current-context initialisations)
-    (board-parameters
-      ^max-board-size-incr <mbs+1>)
-   {(incrementation-table ^length 5 ^nb+4d > <mbs+1>)
-    <incrementation-table>}
--->
-    (remove <incrementation-table>))
-
-(p cleaning-of-superfluous-incrementation-tables-5
-    (game-state ^current-context initialisations)
-    (board-parameters
-      ^max-board-size <mbs>)
-   {(incrementation-table ^length 4 ^nb+3d > <mbs>)
-    <incrementation-table>}
--->
-    (remove <incrementation-table>))
-
-(p cleaning-of-superfluous-incrementation-tables-2-bis
-    (game-state ^current-context initialisations)
-   {(incrementation-table ^length 7 ^nb+6d < 0)
-    <incrementation-table>}
--->
-    (remove <incrementation-table>))
-
-(p cleaning-of-superfluous-incrementation-tables-3-bis
-    (game-state ^current-context initialisations)
-   {(incrementation-table ^length 6 ^nb+5d < 0)
-    <incrementation-table>}
--->
-    (remove <incrementation-table>))
-
-(p cleaning-of-superfluous-incrementation-tables-4-bis
-    (game-state ^current-context initialisations)
-   {(incrementation-table ^length 5 ^nb+4d < 0)
-    <incrementation-table>}
--->
-    (remove <incrementation-table>))
-
-(p cleaning-of-superfluous-incrementation-tables-5-bis
-    (game-state ^current-context initialisations)
-   {(incrementation-table ^length 4 ^nb+3d <= 0)
-    <incrementation-table>}
--->
-    (remove <incrementation-table>))
-
-(p generation-of-an-edge-horizontally
-    (game-state ^current-context initialisations)
-    (board-parameters
-      ^nb-of-columns <nbbc>)
-    (position
-      ^row {<< 0 11 >> <existing-position-row>}
-      ^column  {<= <nbbc> <existing-position-column>})
-    (incrementation
-      ^nb <existing-position-column>
-      ^nb-incremented <existing-position-column-incremented>)
-   -(position
-      ^row <existing-position-row>
-      ^column <existing-position-column-incremented>)
--->
-    (make position
-           ^row <existing-position-row>
-           ^column <existing-position-column-incremented>
-           ^state edge
-           ^vertical-state nil
-           ^horizontal-state nil
-           ^right-bent-state nil
-           ^left-bent-state nil))
-
-(p generation-of-an-edge-vertically
-    (game-state ^current-context initialisations)
-    (board-parameters
-      ^nb-of-rows <nbbr>)
-    (position
-      ^column {<< 0  11 >> <existing-position-column>}
-      ^row  {<= <nbbr> <existing-position-row>})
-    (incrementation
-      ^nb <existing-position-row>
-      ^nb-incremented <existing-position-row-incremented>)
-   -(position
-      ^column <existing-position-column>
-      ^row  <existing-position-row-incremented>)
--->
-    (make position
-           ^column <existing-position-column>
-           ^row <existing-position-row-incremented>
-           ^state edge
-           ^vertical-state nil
-           ^horizontal-state nil
-           ^right-bent-state nil
-           ^left-bent-state nil))
-
-(p generation-of-an-empty-board-horizontally
-    (game-state ^current-context initialisations)
-    (board-parameters
-      ^nb-of-rows <nbbr>
-      ^nb-of-columns <nbbc>)
-    (position
-      ^row {<existing-position-row> > 0 <= <nbbr>}
-      ^column  {< <nbbc> <existing-position-column>})
-    (incrementation
-      ^nb <existing-position-column>
-      ^nb-incremented <existing-position-column-incremented>)
-   -(position
-      ^row <existing-position-row>
-      ^column <existing-position-column-incremented>)
--->
-    (make position
-           ^row <existing-position-row>
-           ^column <existing-position-column-incremented>
-           ^state vacant
-           ^vertical-state free
-           ^horizontal-state free
-           ^right-bent-state free
-           ^left-bent-state free))
-
-(p generation-of-an-empty-board-vertically
-    (game-state ^current-context initialisations)
-    (board-parameters
-      ^nb-of-rows <nbbr>
-      ^nb-of-columns <nbbc>)
-    (position
-      ^column {<existing-position-column> > 0 <= <nbbc>}
-      ^row  {< <nbbr> <existing-position-row>})
-    (incrementation
-      ^nb <existing-position-row>
-      ^nb-incremented <existing-position-row-incremented>)
-   -(position
-      ^column <existing-position-column>
-      ^row  <existing-position-row-incremented>)
--->
-    (make position
-           ^column <existing-position-column>
-           ^row <existing-position-row-incremented>
-           ^state vacant
-           ^vertical-state free
-           ^horizontal-state free
-           ^right-bent-state free
-           ^left-bent-state free))
-
-(p determination-of-the-player-who-is-going-to-start
-   {<game-state>
-    (game-state
-      ^current-context initialisations
-      ^current-player {<> human <> computer})}
-    (symbol
-      ^meaning human
-      ^drawing-character <human-drawing-character>)
-    (symbol
-      ^meaning computer
-      ^drawing-character <computer-drawing-character>)
-    (board-parameters
-      ^nb-of-columns <nbbc>
-      ^nb-of-rows <nbbr>)
--->
-    (write |___________________________________________|
-           (crlf)
-           (crlf)
-           |   The board has | <nbbc> | rows and | <nbbc> | columns.|
-           (crlf)
-           |       You are | <human-drawing-character> |, I am |
-           <computer-drawing-character> |.|
-           (crlf)
-           | ___________________________________________|
-           (crlf)
-           (crlf)
-           |Do you want to start (return: yes, anything else: no)? |)
-           (make input ^type first-player ^value (acceptline human read)))
-
-(p validation-of-the-answer-1
-   {<game-state>
-    (game-state
-      ^current-context initialisations)}
-   {(input ^type first-player ^value human) <input>}
--->
-    (remove <input>)
-    (modify <game-state>
-	      ^current-player human
-              ^current-context choice-of-a-move
-              ^current-sub-context choice-of-the-move))
-
-(p validation-of-the-answer-2
-   {<game-state>
-    (game-state
-      ^current-context initialisations)}
-   {(input ^type first-player ^value <> human) <input>}
--->
-    (remove <input>)
-    (modify <game-state>
-	      ^current-player computer
-              ^current-context choice-of-a-move
-              ^current-sub-context choice-of-the-move))
-
-
-
-(p initialisations-for-board-drawing
-   {<game-state>
-    (game-state ^current-context board-drawing)}
-   {(last-computer-move <row> <column>) <last-computer-move>}
-   -(drawing-position-printed)
--->
-    (write (crlf)
-           (crlf)
-           |score: human |
-           (substr <game-state> human-score human-score)
-           | computer |
-           (substr <game-state> computer-score computer-score)
-           |. I just played| <row> <column> |.|
-           (crlf)
-           (crlf))
-    (remove <last-computer-move>)
-    (make drawing-position-printed
-           ^type outside-board
-           ^line-type first-line
-           ^board-row nil
-           ^board-column 1))
-
-(p drawing-of-the-first-line
-    (game-state ^current-context board-drawing)
-    (board-parameters
-      ^nb-of-columns <nbbc>)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type first-line
-      ^board-column {<> <nbbc> <board-column>})}
-
--->
-    (bind <tab> (compute (2 + (<board-column> * 4))))
-    (write (tabto <tab>)
-           <board-column>)
-    (modify <drawing-position-printed>
-              ^board-column (compute <board-column> + 1)))
-
-(p end-of-the-drawing-of-the-first-line
-    (game-state ^current-context board-drawing)
-    (board-parameters
-      ^nb-of-columns <nb-of-columns>)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type first-line
-      ^board-column <nb-of-columns>)}
--->
-    (bind <tab> (compute (2 + (4 * <nb-of-columns>))))
-    (write (tabto <tab>)
-           <nb-of-columns>
-           (crlf) (crlf))
-    (modify <drawing-position-printed>
-             ^board-row 1
-             ^line-type board-line
-             ^type outside-board))
-
-(p drawing-of-the-beginning-of-a-board-line
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type board-line
-      ^type outside-board
-      ^board-row <board-row>)}
--->
-    (write <board-row>)
-    (modify <drawing-position-printed>
-              ^type board-position
-              ^board-column 1
-              ^previous-board-position-column 1
-              ^previous-board-position-row <board-row>
-              ^next-board-position-column 2
-              ^next-board-position-row <board-row>))
-
-(p drawing-of-a-board-position
-    (game-state ^current-context board-drawing)
-    (board-parameters
-      ^nb-of-columns <nbbc>)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type board-line
-      ^type board-position
-      ^board-row <board-row>
-      ^board-column {<> <nbbc> <board-column>})}
-    (position
-      ^state <board-position-state>
-      ^row <board-row>
-      ^column <board-column>)
-    (symbol
-      ^meaning <board-position-state>
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute (2 + (4 * <board-column>))))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-horizontal-segment))
-
-(p drawing-of-the-end-of-a-board-line
-    (game-state ^current-context board-drawing)
-    (board-parameters
-      ^nb-of-rows <nbbr>
-      ^nb-of-columns <nbbc>)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type board-line
-      ^type board-position
-      ^board-row {<> <nbbr> <board-row>}
-      ^board-column <nbbc>)}
-    (position
-      ^state <board-position-state>
-      ^row <board-row>
-      ^column <nbbc>)
-    (symbol
-      ^meaning <board-position-state>
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute (2 + (4 * <nbbc>))))
-    (write (tabto <tab>)
-           <drawing-character>
-           (crlf))
-    (modify <drawing-position-printed>
-              ^type outside-board
-              ^line-type intermediate-line))
-
-(p drawing-of-the-end-of-the-board
-   {<game-state>
-    (game-state ^current-context board-drawing)}
-    (board-parameters
-      ^nb-of-rows <nbbr>
-      ^nb-of-columns <nbbc>)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type board-line
-      ^type board-position
-      ^board-row <nbbr>
-      ^board-column <nbbc>)}
-    (position
-      ^state <board-position-state>
-      ^row <nbbr>
-      ^column <nbbc>)
-    (symbol
-      ^meaning <board-position-state>
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute (2 + (4 * <nbbc>))))
-    (write (tabto <tab>)
-           <drawing-character>
-           (crlf) (crlf))
-    (remove <drawing-position-printed>)
-    (modify <game-state>
-              ^current-context choice-of-a-move
-              ^current-sub-context choice-of-the-move
-              ^current-player human))
-
-(p drawing-of-an-horizontal-piece-of-segment-1
-
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type board-line
-      ^type possibly-a-piece-of-horizontal-segment
-      ^board-column <board-column>
-      ^board-row <board-row>
-      ^next-board-position-column <nbpc>
-      ^previous-board-position-column <pbpc>)}
-    (position
-      ^row <board-row>
-      ^column <pbpc>
-      ^state <> vacant
-      ^horizontal-state inside-a-segment)
-    (symbol
-      ^meaning piece-of-horizontal-segment
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute (2 + (4 * <board-column>) + 2)))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type board-position
-              ^board-column (compute <board-column> + 1)
-              ^previous-board-position-column <nbpc>
-              ^next-board-position-column (compute <nbpc> + 1)))
-
-(p drawing-of-an-horizontal-piece-of-segment-2
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type board-line
-      ^type possibly-a-piece-of-horizontal-segment
-      ^board-column <board-column>
-      ^board-row <board-row>
-      ^next-board-position-column <nbpc>
-      ^previous-board-position-column <pbpc>)}
-    (position
-      ^row <board-row>
-      ^column <nbpc>
-      ^state <> vacant
-      ^horizontal-state inside-a-segment)
-    (symbol
-      ^meaning piece-of-horizontal-segment
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute (2 + (4 * <board-column>) + 2)))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type board-position
-              ^board-column (compute <board-column> + 1)
-              ^previous-board-position-column <nbpc>
-              ^next-board-position-column (compute <nbpc> + 1)))
-
-
-(p non-drawing-of-an-horizontal-piece-of-segment
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type board-line
-      ^type possibly-a-piece-of-horizontal-segment
-      ^board-column <board-column>
-      ^board-row <board-row>
-      ^next-board-position-column <nbpc>
-      ^previous-board-position-column <pbpc>)}
--->
-    (modify <drawing-position-printed>
-              ^type board-position
-              ^board-column (compute <board-column> + 1)
-              ^previous-board-position-column <nbpc>
-              ^next-board-position-column (compute <nbpc> + 1)))
-
-(p drawing-of-the-beginning-of-an-intermediate-line
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type outside-board
-      ^board-row <board-row>)}
--->
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-vertical-segment
-              ^nw-board-position-row <board-row>
-              ^nw-board-position-column 1
-              ^sw-board-position-row (compute 1 + <board-row>)
-              ^sw-board-position-column 1
-              ^ne-board-position-row <board-row>
-              ^ne-board-position-column 2
-              ^se-board-position-row (compute 1 + <board-row>)
-              ^se-board-position-column 2))
-
-(p drawing-of-a-vertical-piece-of-segment-1
-    (game-state ^current-context board-drawing)
-    (board-parameters
-      ^nb-of-columns <nbbc>)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-vertical-segment
-      ^nw-board-position-column {<> <nbbc> <board-column>}
-      ^nw-board-position-row <nwbpr>)}
-    (position
-      ^row <nwbpr>
-      ^column <board-column>
-      ^state <> vacant
-      ^vertical-state inside-a-segment)
-    (symbol
-      ^meaning piece-of-vertical-segment
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute 2 + (4 * <board-column>)))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-bent-segment))
-
-(p drawing-of-a-vertical-piece-of-segment-2
-    (game-state ^current-context board-drawing)
-    (board-parameters
-      ^nb-of-columns <nbbc>)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-vertical-segment
-      ^nw-board-position-column {<> <nbbc> <board-column>}
-      ^sw-board-position-row <swbpr>)}
-    (position
-      ^row <swbpr>
-      ^column <board-column>
-      ^state <> vacant
-      ^vertical-state inside-a-segment)
-    (symbol
-      ^meaning piece-of-vertical-segment
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute 2 + (4 * <board-column>)))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-bent-segment))
-
-(p non-drawing-of-a-vertical-piece-of-segment
-    (game-state ^current-context board-drawing)
-    (board-parameters
-      ^nb-of-columns <nbbc>)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-vertical-segment
-      ^nw-board-position-column {<> <nbbc> <board-column>}
-      ^sw-board-position-row <swbpr>)}
--->
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-bent-segment))
-
-(p drawing-of-a-piece-of-right-bent-segment-1
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-bent-segment
-      ^nw-board-position-column <board-column>
-      ^board-row <board-row>
-      ^sw-board-position-column <swbpc>
-      ^nw-board-position-column <nwbpc>
-      ^se-board-position-column <sebpc>
-      ^ne-board-position-column <nebpc>
-      ^sw-board-position-row <swbpr>)}
-    (position
-      ^row <swbpr>
-      ^column <swbpc>
-      ^state <> vacant
-      ^right-bent-state inside-a-segment)
-    (symbol
-      ^meaning piece-of-right-bent-segment
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute 2 + (4 * <board-column>) + 2))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-vertical-segment
-              ^sw-board-position-column <sebpc>
-              ^nw-board-position-column <nebpc>
-              ^se-board-position-column (compute <sebpc> + 1)
-              ^ne-board-position-column (compute <nebpc> + 1)))
-
-(p drawing-of-a-piece-of-right-bent-segment-2
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-bent-segment
-      ^nw-board-position-column <board-column>
-      ^board-row <board-row>
-      ^sw-board-position-column <swbpc>
-      ^nw-board-position-column <nwbpc>
-      ^se-board-position-column <sebpc>
-      ^ne-board-position-column <nebpc>
-      ^ne-board-position-row <nebpr>)}
-    (position
-      ^row <nebpr>
-      ^column <nebpc>
-      ^state <> vacant
-      ^right-bent-state inside-a-segment)
-    (symbol
-      ^meaning piece-of-right-bent-segment
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute 2 + (4 * <board-column>) + 2))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-vertical-segment
-              ^sw-board-position-column <sebpc>
-              ^nw-board-position-column <nebpc>
-              ^se-board-position-column (compute <sebpc> + 1)
-              ^ne-board-position-column (compute <nebpc> + 1)))
-
-(p drawing-of-a-piece-of-left-bent-segment-1
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-bent-segment
-      ^nw-board-position-column <board-column>
-      ^board-row <board-row>
-      ^sw-board-position-column <swbpc>
-      ^nw-board-position-column <nwbpc>
-      ^se-board-position-column <sebpc>
-      ^ne-board-position-column <nebpc>
-      ^se-board-position-row <sebpr>)}
-    (position
-      ^row <sebpr>
-      ^column <sebpc>
-      ^state <> vacant
-      ^left-bent-state inside-a-segment)
-    (symbol
-      ^meaning piece-of-left-bent-segment
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute 2 + (4 * <board-column>) + 2))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-vertical-segment
-              ^sw-board-position-column <sebpc>
-              ^nw-board-position-column <nebpc>
-              ^se-board-position-column (compute <sebpc> + 1)
-              ^ne-board-position-column (compute <nebpc> + 1)))
-
-(p drawing-of-a-piece-of-left-bent-segment-2
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-bent-segment
-      ^nw-board-position-column <board-column>
-      ^board-row <board-row>
-      ^sw-board-position-column <swbpc>
-      ^nw-board-position-column <nwbpc>
-      ^se-board-position-column <sebpc>
-      ^ne-board-position-column <nebpc>
-      ^nw-board-position-row <nwbpr>)}
-    (position
-      ^row <nwbpr>
-      ^column <nwbpc>
-      ^state <> vacant
-      ^left-bent-state inside-a-segment)
-    (symbol
-      ^meaning piece-of-left-bent-segment
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute 2 + (4 * <board-column>) + 2))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-vertical-segment
-              ^sw-board-position-column <sebpc>
-              ^nw-board-position-column <nebpc>
-              ^se-board-position-column (compute <sebpc> + 1)
-              ^ne-board-position-column (compute <nebpc> + 1)))
-
-(p drawing-of-a-crossing-of-segments-1
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-bent-segment
-      ^nw-board-position-column <board-column>
-      ^board-row <board-row>
-      ^sw-board-position-column <swbpc>
-      ^nw-board-position-column <nwbpc>
-      ^se-board-position-column <sebpc>
-      ^ne-board-position-column <nebpc>
-      ^se-board-position-row <sebpr>
-      ^sw-board-position-row <swbpr>)}
-    (position
-      ^row <swbpr>
-      ^column <swbpc>
-      ^state <> vacant
-      ^right-bent-state inside-a-segment)
-    (position
-      ^row <sebpr>
-      ^column <sebpc>
-      ^state <> vacant
-      ^left-bent-state inside-a-segment)
-    (symbol
-      ^meaning crossing-of-two-bent-segments
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute 2 + (4 * <board-column>) + 2))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-vertical-segment
-              ^sw-board-position-column <sebpc>
-              ^nw-board-position-column <nebpc>
-              ^se-board-position-column (compute <sebpc> + 1)
-              ^ne-board-position-column (compute <nebpc> + 1)))
-
-(p drawing-of-a-crossing-of-segments-2
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-bent-segment
-      ^nw-board-position-column <board-column>
-      ^board-row <board-row>
-      ^sw-board-position-column <swbpc>
-      ^nw-board-position-column <nwbpc>
-      ^se-board-position-column <sebpc>
-      ^ne-board-position-column <nebpc>
-      ^ne-board-position-row <nebpr>
-      ^nw-board-position-row <nwbpr>)}
-    (position
-      ^row <nwbpr>
-      ^column <nwbpc>
-      ^state <> vacant
-      ^left-bent-state inside-a-segment)
-    (position
-      ^row <nebpr>
-      ^column <nebpc>
-      ^state <> vacant
-      ^right-bent-state inside-a-segment)
-    (symbol
-      ^meaning crossing-of-two-bent-segments
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute 2 + (4 * <board-column>) + 2))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-vertical-segment
-              ^sw-board-position-column <sebpc>
-              ^nw-board-position-column <nebpc>
-              ^se-board-position-column (compute <sebpc> + 1)
-              ^ne-board-position-column (compute <nebpc> + 1)))
-
-(p drawing-of-a-crossing-of-segments-3
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-bent-segment
-      ^nw-board-position-column <board-column>
-      ^board-row <board-row>
-      ^sw-board-position-column <swbpc>
-      ^nw-board-position-column <nwbpc>
-      ^se-board-position-column <sebpc>
-      ^ne-board-position-column <nebpc>
-      ^ne-board-position-row <nebpr>
-      ^se-board-position-row <sebpr>)}
-    (position
-      ^row <sebpr>
-      ^column <sebpc>
-      ^state <> vacant
-      ^left-bent-state inside-a-segment)
-    (position
-      ^row <nebpr>
-      ^column <nebpc>
-      ^state <> vacant
-      ^right-bent-state inside-a-segment)
-    (symbol
-      ^meaning crossing-of-two-bent-segments
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute 2 + (4 * <board-column>) + 2))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-vertical-segment
-              ^sw-board-position-column <sebpc>
-              ^nw-board-position-column <nebpc>
-              ^se-board-position-column (compute <sebpc> + 1)
-              ^ne-board-position-column (compute <nebpc> + 1)))
-
-(p drawing-of-a-crossing-of-segments-4
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-bent-segment
-      ^nw-board-position-column <board-column>
-      ^board-row <board-row>
-      ^sw-board-position-column <swbpc>
-      ^nw-board-position-column <nwbpc>
-      ^se-board-position-column <sebpc>
-      ^ne-board-position-column <nebpc>
-      ^nw-board-position-row <nwbpr>
-      ^sw-board-position-row <swbpr>)}
-    (position
-      ^row <swbpr>
-      ^column <swbpc>
-      ^state <> vacant
-      ^right-bent-state inside-a-segment)
-    (position
-      ^row <nwbpr>
-      ^column <nwbpc>
-      ^state <> vacant
-      ^left-bent-state inside-a-segment)
-    (symbol
-      ^meaning crossing-of-two-bent-segments
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute 2 + (4 * <board-column>) + 2))
-    (write (tabto <tab>)
-           <drawing-character>)
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-vertical-segment
-              ^sw-board-position-column <sebpc>
-              ^nw-board-position-column <nebpc>
-              ^se-board-position-column (compute <sebpc> + 1)
-              ^ne-board-position-column (compute <nebpc> + 1)))
-
-(p non-drawing-of-an-intermediate-position-of-an-intermediate-line
-    (game-state ^current-context board-drawing)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-bent-segment
-      ^board-row <board-row>
-      ^sw-board-position-column <swbpc>
-      ^nw-board-position-column <nwbpc>
-      ^se-board-position-column <sebpc>
-      ^ne-board-position-column <nebpc>
-      ^nw-board-position-row <nwbpr>
-      ^sw-board-position-row <swbpr>)}
--->
-    (modify <drawing-position-printed>
-              ^type possibly-a-piece-of-vertical-segment
-              ^sw-board-position-column <sebpc>
-              ^nw-board-position-column <nebpc>
-              ^se-board-position-column (compute <sebpc> + 1)
-              ^ne-board-position-column (compute <nebpc> + 1)))
-
-(p drawing-of-the-end-of-an-intermediate-line-1
-    (game-state ^current-context board-drawing)
-    (board-parameters
-      ^nb-of-columns <nbbc>)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-vertical-segment
-      ^nw-board-position-column <nbbc>
-      ^board-row <board-row>
-      ^sw-board-position-row <swbpr>)}
-    (position
-      ^row <swbpr>
-      ^column <nbbc>
-      ^state <> vacant
-      ^vertical-state inside-a-segment)
-    (symbol
-      ^meaning piece-of-vertical-segment
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute 2 + (4 * <nbbc>)))
-    (write (tabto <tab>)
-           <drawing-character>
-           (crlf))
-    (modify <drawing-position-printed>
-              ^type outside-board
-              ^line-type board-line
-              ^board-row (compute <board-row> + 1)))
-
-(p drawing-of-the-end-of-an-intermediate-line-2
-    (game-state ^current-context board-drawing)
-    (board-parameters
-      ^nb-of-columns <nbbc>)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-vertical-segment
-      ^nw-board-position-column <nbbc>
-      ^board-row <board-row>
-      ^nw-board-position-row <nwbpr>)}
-    (position
-      ^row <nwbpr>
-      ^column <nbbc>
-      ^state <> vacant
-      ^vertical-state inside-a-segment)
-    (symbol
-      ^meaning piece-of-vertical-segment
-      ^drawing-character <drawing-character>)
--->
-    (bind <tab> (compute 2 + (4 * <nbbc>)))
-    (write (tabto <tab>)
-           <drawing-character>
-           (crlf))
-    (modify <drawing-position-printed>
-              ^type outside-board
-              ^line-type board-line
-              ^board-row (compute <board-row> + 1)))
-
-(p non-drawing-of-the-end-of-an-intermediate-line
-    (game-state ^current-context board-drawing)
-    (board-parameters
-      ^nb-of-columns <nbbc>)
-   {<drawing-position-printed>
-    (drawing-position-printed
-      ^line-type intermediate-line
-      ^type possibly-a-piece-of-vertical-segment
-      ^nw-board-position-column <nbbc>
-      ^board-row <board-row>
-      ^nw-board-position-row <nwbpr>)}
--->
-    (modify <drawing-position-printed>
-              ^type outside-board
-              ^line-type board-line
-              ^board-row (compute <board-row> + 1))
-    (write (crlf)))
-
-
-
-(p choice-of-a-move-by-human
-   {<game-state>
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-the-move
-      ^current-player human)}
--->
-    (write |Where do you play (row column)?|)
-    (make input ^type position ^value (acceptline)))
-
-(p correction-of-a-move-by-human
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-the-move
-      ^current-player human)
-   {(input ^type position) <input>}
--->
-    (write |Your move is illegal.|
-           (crlf)
-           |Where do you play (row column)?|)
-    (modify <input>
-      ^value (acceptline)))
-
-(p end-of-the-choice-of-the-move
-   {<game-state>
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-the-move
-      ^current-player human)}
-   {(input
-      ^type position
-      ^value <row> <column>) <input>}
-    (position
-      ^row  <row>
-      ^column <column>
-      ^state vacant)
--->
-    (make new-move
-	   ^row <row>
-	   ^column <column>
-	   ^state human)
-    (remove <input>)
-    (modify <game-state>
-              ^current-context board-analyse
-              ^current-sub-context garbage-cleaning))
-
-(p asking-the-human-whether-he-wants-to-draw-a-segment
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^current-player human)
-   -(segment)
-   -(input)
--->
-(write |Segment to draw (ret., or beginning row & column, ending ...)?|)
-    (make input
-	  ^type segment
-	  ^value (acceptline no read)))
-
-(p asking-the-human-whether-he-wants-to-draw-another-segment
-   {<game-state>
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-player human)}
--->
-    (modify <game-state>
-             ^current-context choice-of-a-move))
-
-(p removal-of-a-negative-segment-input
-   {(game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^current-player human) <game-state>}
-   {(input
-      ^type segment
-      ^value no) <input>}
--->
-    (remove <input>)
-    (modify <game-state>
-	     ^current-context choice-of-a-move
-	     ^current-sub-context generation-of-the-best-possible-moves
-	     ^current-player computer))
-
-(p drawing-of-a-segment-by-human
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^current-player human)
-   {(input
-      ^type segment
-      ^value {<> no <beginning-row>}
-             <beginning-column>
-             <ending-row>
-             <ending-column>) <input>}
--->
-    (make segment
-            ^beginning-row <beginning-row>
-            ^beginning-column <beginning-column>
-            ^ending-row <ending-row>
-            ^ending-column <ending-column>)
-    (remove <input>))
-
-(p orientation-of-a-non-vertical-segment
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^current-player human)
-   {<segment>
-    (segment
-      ^beginning-row <beginning-row>
-      ^ending-row <ending-row>
-      ^beginning-column <beginning-column>
-      ^ending-column {<ending-column> < <beginning-column>})}
--->
-    (modify <segment>
-              ^beginning-row <ending-row>
-              ^ending-row <beginning-row>
-              ^beginning-column <ending-column>
-              ^ending-column <beginning-column>))
-
- (p orientation-of-a-vertical-segment
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^current-player human)
-   {<segment>
-    (segment
-      ^beginning-column <column>
-      ^ending-column  <column>
-      ^beginning-row <beginning-row>
-      ^ending-row {<ending-row> < <beginning-row>})}
--->
-    (modify <segment>
-              ^beginning-row <ending-row>
-              ^ending-row <beginning-row>))
-
-(p checking-of-the-legality-of-a-horizontal-oriented-segment
-   {<game-state>
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^current-player human
-      ^human-score <human-score>)}
-   {<segment>
-    (segment
-      ^beginning-row <row>
-      ^ending-row  <row>
-      ^beginning-column <beginning-column>
-      ^ending-column <ending-column>)}
-    (incrementation
-      ^nb <beginning-column>
-      ^nb-incremented <column2>)
-    (incrementation
-      ^nb <column2>
-      ^nb-incremented <column3>)
-    (incrementation
-      ^nb <column3>
-      ^nb-incremented <column4>)
-   {<position1>
-    (position
-      ^column <beginning-column>
-      ^row <row>
-      ^state human
-      ^horizontal-state << free end-of-a-segment >>)}
-   {<position2>
-    (position
-      ^column <column2>
-      ^row <row>
-      ^state human
-      ^horizontal-state << free end-of-a-segment >>)}
-   {<position3>
-    (position
-      ^column <column3>
-      ^row <row>
-      ^state human
-      ^horizontal-state << free end-of-a-segment >>)}
-   {<position4>
-    (position
-      ^column {<ending-column> <column4>}
-      ^row <row>
-      ^state human
-      ^horizontal-state << free end-of-a-segment >>)}
--->
-    (modify <position1>
-              ^horizontal-state end-of-a-segment)
-    (modify <position2>
-              ^horizontal-state inside-a-segment)
-    (modify <position3>
-              ^horizontal-state inside-a-segment)
-    (modify <position4>
-              ^horizontal-state end-of-a-segment)
-    (modify <game-state>
-              ^human-score (compute <human-score> + 1))
-    (remove <segment>))
-
-(p checking-of-the-legality-of-a-vertical-oriented-segment
-   {<game-state>
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^current-player human
-      ^human-score <human-score>)}
-   {<segment>
-    (segment
-      ^beginning-column <column>
-      ^ending-column  <column>
-      ^beginning-row <beginning-row>
-      ^ending-row <ending-row>)}
-    (incrementation
-      ^nb <beginning-row>
-      ^nb-incremented <row2>)
-    (incrementation
-      ^nb <row2>
-      ^nb-incremented <row3>)
-    (incrementation
-      ^nb <row3>
-      ^nb-incremented <row4>)
-   {<position1>
-    (position
-      ^row <beginning-row>
-      ^column <column>
-      ^state human
-      ^vertical-state << free end-of-a-segment >>)}
-   {<position2>
-    (position
-      ^row <row2>
-      ^column <column>
-      ^state human
-      ^vertical-state << free end-of-a-segment >>)}
-   {<position3>
-    (position
-      ^row <row3>
-      ^column <column>
-      ^state human
-      ^vertical-state << free end-of-a-segment >>)}
-   {<position4>
-    (position
-      ^row {<ending-row> <row4>}
-      ^column <column>
-      ^state human
-      ^vertical-state << free end-of-a-segment >>)}
--->
-    (modify <position1>
-              ^vertical-state end-of-a-segment)
-    (modify <position2>
-              ^vertical-state inside-a-segment)
-    (modify <position3>
-              ^vertical-state inside-a-segment)
-    (modify <position4>
-              ^vertical-state end-of-a-segment)
-    (modify <game-state>
-              ^human-score (compute <human-score> + 1))
-    (remove <segment>))
-
-(p checking-of-the-legality-of-a-left-bent-oriented-segment
-   {<game-state>
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^current-player human
-      ^human-score <human-score>)}
-   {<segment>
-    (segment
-      ^beginning-column <beginning-column>
-      ^ending-column  <ending-column>
-      ^beginning-row <beginning-row>
-      ^ending-row <ending-row>)}
-    (incrementation
-      ^nb <beginning-row>
-      ^nb-incremented <row2>)
-    (incrementation
-      ^nb <row2>
-      ^nb-incremented <row3>)
-    (incrementation
-      ^nb <row3>
-      ^nb-incremented <row4>)
-    (incrementation
-      ^nb <beginning-column>
-      ^nb-incremented <column2>)
-    (incrementation
-      ^nb <column2>
-      ^nb-incremented <column3>)
-    (incrementation
-      ^nb <column3>
-      ^nb-incremented <column4>)
-   {<position1>
-    (position
-      ^row <beginning-row>
-      ^column <beginning-column>
-      ^state human
-      ^left-bent-state << free end-of-a-segment >>)}
-   {<position2>
-    (position
-      ^row <row2>
-      ^column <column2>
-      ^state human
-      ^left-bent-state << free end-of-a-segment >>)}
-   {<position3>
-    (position
-      ^row <row3>
-      ^column <column3>
-      ^state human
-      ^left-bent-state << free end-of-a-segment >>)}
-   {<position4>
-    (position
-      ^row {<ending-row> <row4>}
-      ^column {<ending-column> <column4>}
-      ^state human
-      ^left-bent-state << free end-of-a-segment >>)}
--->
-    (modify <position1>
-              ^left-bent-state end-of-a-segment)
-    (modify <position2>
-              ^left-bent-state inside-a-segment)
-    (modify <position3>
-              ^left-bent-state inside-a-segment)
-    (modify <position4>
-              ^left-bent-state end-of-a-segment)
-    (modify <game-state>
-              ^human-score (compute <human-score> + 1))
-    (remove <segment>))
-
-(p checking-of-the-legality-of-a-right-bent-oriented-segment
-   {<game-state>
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^current-player human
-      ^human-score <human-score>)}
-   {<segment>
-    (segment
-      ^beginning-row <beginning-row>
-      ^ending-row  <ending-row>
-      ^beginning-column <beginning-column>
-      ^ending-column <ending-column>)}
-    (incrementation
-      ^nb <beginning-column>
-      ^nb-incremented <column2>)
-    (incrementation
-      ^nb <column2>
-      ^nb-incremented <column3>)
-    (incrementation
-      ^nb <column3>
-      ^nb-incremented <column4>)
-    (incrementation
-      ^nb <ending-row>
-      ^nb-incremented <row3>)
-    (incrementation
-      ^nb <row3>
-      ^nb-incremented <row2>)
-    (incrementation
-      ^nb <row2>
-      ^nb-incremented <row1>)
-   {<position1>
-    (position
-      ^column <beginning-column>
-      ^row {<row1> <beginning-row>}
-      ^state human
-      ^right-bent-state << free end-of-a-segment >>)}
-   {<position2>
-    (position
-      ^column <column2>
-      ^row <row2>
-      ^state human
-      ^right-bent-state << free end-of-a-segment >>)}
-   {<position3>
-    (position
-      ^column <column3>
-      ^row <row3>
-      ^state human
-      ^right-bent-state << free end-of-a-segment >>)}
-   {<position4>
-    (position
-      ^column {<ending-column> <column4>}
-      ^row <ending-row>
-      ^state human
-      ^right-bent-state << free end-of-a-segment >>)}
--->
-    (modify <position1>
-              ^right-bent-state end-of-a-segment)
-    (modify <position2>
-              ^right-bent-state inside-a-segment)
-    (modify <position3>
-              ^right-bent-state inside-a-segment)
-    (modify <position4>
-              ^right-bent-state end-of-a-segment)
-    (modify <game-state>
-              ^human-score (compute <human-score> + 1))
-    (remove <segment>))
-
-(p correction-of-a-segment
-   {<game-state>
-    (game-state
-      ^current-context choice-of-a-move
-      ^current-sub-context choice-of-segments
-      ^current-player human
-      ^human-score <human-score>)}
-   {<segment>
-    (segment
-      ^beginning-row <beginning-row>
-      ^ending-row  <ending-row>
-      ^beginning-column <beginning-column>
-      ^ending-column <ending-column>)}
--->
-    (remove <segment>)
-    (write |Your segment is illegal.|
-           (crlf)
-           |Segment to draw (ret., or beginning row & column, ending ...)?|)
-    (make input
-	  ^type segment
-	  ^value (acceptline no read)))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-(p fbug-start
-    (start)
-  -->
-    (make position
-           ^row 0
-           ^column 0
-           ^state edge
-           ^vertical-state nil
-           ^horizontal-state nil
-           ^right-bent-state nil
-           ^left-bent-state nil)
-    (make opposite ^of human ^is computer)
-    (make opposite ^of computer ^is human)
-    (make board-parameters
-           ^nb-of-columns 10
-           ^nb-of-rows 10
-           ^nb-of-columns-incr 11
-           ^nb-of-rows-incr 11
-	   ^max-board-size 10
-	   ^max-board-size-incr 11)
-    (make symbol
-           ^meaning vacant
-           ^drawing-character |.|)
-    (make symbol
-           ^meaning human
-           ^drawing-character |o|)
-    (make symbol
-           ^meaning computer
-           ^drawing-character |*|)
-    (make symbol
-           ^meaning piece-of-horizontal-segment
-           ^drawing-character |-|)
-    (make symbol
-           ^meaning piece-of-vertical-segment
-           ^drawing-character |l|)
-    (make symbol
-           ^meaning piece-of-right-bent-segment
-           ^drawing-character |/|)
-    (make symbol
-           ^meaning piece-of-left-bent-segment
-           ^drawing-character |\|)
-    (make symbol
-           ^meaning crossing-of-two-bent-segments
-           ^drawing-character |x|)
-    (make game-state
-           ^current-context initialisations
-           ^human-score 0
-           ^computer-score 0)
-    (make delta 0)
-    (make delta 1)
-    (make delta -1)
-    (make nb 0)
-    (make nb 1)
-    (make nb 2)
-    (make nb 3)
-    (make nb 4)
-    (make nb 5)
-    (make nb 6)
-    (make nb 7)
-    (make nb 8)
-    (make nb 9)
-    (make nb 10)
-    (make nb 11)
-    (make length 4)
-    (make length 5)
-    (make length 6)
-    (make length 7)
-    (make incrementation
-      ^nb 0
-      ^nb-incremented 1)
-    (make direction ^geometry assymetric ^row 0 ^column 1)
-    (make direction ^geometry assymetric ^row 1 ^column 1)
-    (make direction ^geometry assymetric ^row 1 ^column 0)
-    (make direction ^geometry assymetric ^row 1 ^column -1)
-    (make direction ^geometry assymetric ^row 0 ^column -1)
-    (make direction ^geometry assymetric ^row -1 ^column -1)
-    (make direction ^geometry assymetric ^row -1 ^column 0)
-    (make direction ^geometry assymetric ^row -1 ^column 1)
-    (make direction ^geometry symetric ^row 0 ^column 1)
-    (make direction ^geometry symetric ^row 1 ^column 1)
-    (make direction ^geometry symetric ^row 1 ^column 0)
-    (make direction ^geometry symetric ^row 1 ^column -1)
-    (make number-to-add-while-updating-counters ^value ignore-it)
-    (make segment-type
-           ^name opcxcpo
-           ^length 7
-           ^geometry symetric
-           ^owner computer
-           ^position-1-state human
-           ^position-2-state vacant
-           ^position-3-state vacant
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-7-state human
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update nb-of-compulsory-answer-creations
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update garbage
-           ^position-7-counter-to-update garbage)
-    (make segment-type
-           ^name ipcxcpo
-           ^length 7
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state vacant
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-7-state human
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update nb-of-compulsory-answer-creations
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update garbage
-           ^position-7-counter-to-update garbage)
-    (make segment-type
-           ^name ipcxcpi
-           ^length 7
-           ^geometry symetric
-           ^owner computer
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state vacant
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-7-state edge
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update nb-of-compulsory-answer-creations
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update garbage
-           ^position-7-counter-to-update garbage)
-    (make segment-type
-           ^name pccxccp
-           ^length 7
-           ^geometry symetric
-           ^owner computer
-           ^position-1-state vacant
-           ^position-2-state vacant
-           ^position-3-state vacant
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-7-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update nb-of-compulsory-answer-creations
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations
-           ^position-7-counter-to-update garbage)
-    (make segment-type
-           ^name opcxccp
-           ^length 7
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state human
-           ^position-2-state vacant
-           ^position-3-state vacant
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-7-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update nb-of-compulsory-answer-creations
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations
-           ^position-7-counter-to-update garbage)
-    (make segment-type
-           ^name ipcxccp
-           ^length 7
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state vacant
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-7-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update nb-of-compulsory-answer-creations
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations
-           ^position-7-counter-to-update garbage)
-    (make segment-type
-           ^name cxfxc
-           ^length 5
-           ^geometry symetric
-           ^owner computer
-           ^position-1-state vacant
-           ^position-2-state computer
-           ^position-3-state vacant
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-1-counter-to-update nb-of-compulsory-answer-creations
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update nb-of-fragile-winners
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name oxxcc
-           ^length 5
-           ^geometry assymetric
-           ^owner human
-	   ^position-1-state human
-           ^position-2-state computer
-           ^position-3-state computer
-           ^position-4-state vacant
-           ^position-5-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update nb-of-compulsory-answer-creations
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name ixxcc
-           ^length 5
-           ^geometry assymetric
-           ^owner human
-	   ^position-1-state edge
-           ^position-2-state computer
-           ^position-3-state computer
-           ^position-4-state vacant
-           ^position-5-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update nb-of-compulsory-answer-creations
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name oxxfx
-           ^length 5
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state human
-           ^position-2-state computer
-           ^position-3-state computer
-           ^position-4-state vacant
-           ^position-5-state computer
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update nb-of-fragile-winners
-           ^position-5-counter-to-update garbage)
-    (make segment-type
-           ^name ixxfx
-           ^length 5
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state edge
-           ^position-2-state computer
-           ^position-3-state computer
-           ^position-4-state vacant
-           ^position-5-state computer
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update nb-of-fragile-winners
-           ^position-5-counter-to-update garbage)
-    (make segment-type
-           ^name ocxxco
-           ^length 6
-           ^geometry symetric
-           ^owner computer
-           ^position-1-state human
-           ^position-2-state vacant
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state human
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update garbage)
-    (make segment-type
-           ^name icxxco
-           ^length 6
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state human
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update garbage)
-    (make segment-type
-           ^name icxxci
-           ^length 6
-           ^geometry symetric
-           ^owner computer
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state edge
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update garbage)
-    (make segment-type
-           ^name ocxxfc
-           ^length 6
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state human
-           ^position-2-state vacant
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name icxxfc
-           ^length 6
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name ocxxfx
-           ^length 6
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state human
-           ^position-2-state vacant
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state computer
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners
-           ^position-6-counter-to-update garbage)
-    (make segment-type
-           ^name icxxfx
-           ^length 6
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state computer
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners
-           ^position-6-counter-to-update garbage)
-    (make segment-type
-           ^name cfxxfc
-           ^length 6
-           ^geometry symetric
-           ^owner computer
-           ^position-1-state vacant
-           ^position-2-state vacant
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-1-counter-to-update nb-of-compulsory-answer-creations
-           ^position-2-counter-to-update nb-of-fragile-winners
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name xfxxfc
-           ^length 6
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state computer
-           ^position-2-state vacant
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-fragile-winners
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name xwxxwx
-           ^length 6
-           ^geometry symetric
-           ^owner computer
-           ^position-1-state computer
-           ^position-2-state vacant
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-6-state computer
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-strong-winners
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-strong-winners
-           ^position-6-counter-to-update garbage)
-    (make segment-type
-           ^name oxxxf
-           ^length 5
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state human
-           ^position-2-state computer
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners)
-    (make segment-type
-           ^name ixxxf
-           ^length 5
-           ^geometry assymetric
-           ^owner computer
-           ^position-1-state edge
-           ^position-2-state computer
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners)
-    (make segment-type
-           ^name wxxxw
-           ^length 5
-           ^geometry symetric
-           ^owner computer
-           ^position-1-state vacant
-           ^position-2-state computer
-           ^position-3-state computer
-           ^position-4-state computer
-           ^position-5-state vacant
-           ^position-1-counter-to-update nb-of-strong-winners
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-strong-winners)
-    (make segment-type
-           ^name opcxcpo
-           ^length 7
-           ^geometry symetric
-           ^owner human
-           ^position-1-state computer
-           ^position-2-state vacant
-           ^position-3-state vacant
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-7-state computer
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update nb-of-compulsory-answer-creations
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update garbage
-           ^position-7-counter-to-update garbage)
-    (make segment-type
-           ^name ipcxcpo
-           ^length 7
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state vacant
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-7-state computer
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update nb-of-compulsory-answer-creations
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update garbage
-           ^position-7-counter-to-update garbage)
-    (make segment-type
-           ^name ipcxcpi
-           ^length 7
-           ^geometry symetric
-           ^owner human
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state vacant
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-7-state edge
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update nb-of-compulsory-answer-creations
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update garbage
-           ^position-7-counter-to-update garbage)
-    (make segment-type
-           ^name pccxccp
-           ^length 7
-           ^geometry symetric
-           ^owner human
-           ^position-1-state vacant
-           ^position-2-state vacant
-           ^position-3-state vacant
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-7-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update nb-of-compulsory-answer-creations
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations
-           ^position-7-counter-to-update garbage)
-    (make segment-type
-           ^name opcxccp
-           ^length 7
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state computer
-           ^position-2-state vacant
-           ^position-3-state vacant
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-7-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update nb-of-compulsory-answer-creations
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations
-           ^position-7-counter-to-update garbage)
-    (make segment-type
-           ^name ipcxccp
-           ^length 7
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state vacant
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-7-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update nb-of-compulsory-answer-creations
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations
-           ^position-7-counter-to-update garbage)
-    (make segment-type
-           ^name cxfxc
-           ^length 5
-           ^geometry symetric
-           ^owner human
-           ^position-1-state vacant
-           ^position-2-state human
-           ^position-3-state vacant
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-1-counter-to-update nb-of-compulsory-answer-creations
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update nb-of-fragile-winners
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name oxxcc
-           ^length 5
-           ^geometry assymetric
-           ^owner computer
-	   ^position-1-state computer
-           ^position-2-state human
-           ^position-3-state human
-           ^position-4-state vacant
-           ^position-5-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update nb-of-compulsory-answer-creations
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name ixxcc
-           ^length 5
-           ^geometry assymetric
-           ^owner computer
-	   ^position-1-state edge
-           ^position-2-state human
-           ^position-3-state human
-           ^position-4-state vacant
-           ^position-5-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update nb-of-compulsory-answer-creations
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name oxxfx
-           ^length 5
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state computer
-           ^position-2-state human
-           ^position-3-state human
-           ^position-4-state vacant
-           ^position-5-state human
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update nb-of-fragile-winners
-           ^position-5-counter-to-update garbage)
-    (make segment-type
-           ^name ixxfx
-           ^length 5
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state edge
-           ^position-2-state human
-           ^position-3-state human
-           ^position-4-state vacant
-           ^position-5-state human
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update nb-of-fragile-winners
-           ^position-5-counter-to-update garbage)
-    (make segment-type
-           ^name ocxxco
-           ^length 6
-           ^geometry symetric
-           ^owner human
-           ^position-1-state computer
-           ^position-2-state vacant
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state computer
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update garbage)
-    (make segment-type
-           ^name icxxco
-           ^length 6
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state computer
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update garbage)
-    (make segment-type
-           ^name icxxci
-           ^length 6
-           ^geometry symetric
-           ^owner human
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state edge
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-compulsory-answer-creations
-           ^position-6-counter-to-update garbage)
-    (make segment-type
-           ^name ocxxfc
-           ^length 6
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state computer
-           ^position-2-state vacant
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name icxxfc
-           ^length 6
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name ocxxfx
-           ^length 6
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state computer
-           ^position-2-state vacant
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state human
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners
-           ^position-6-counter-to-update garbage)
-    (make segment-type
-           ^name icxxfx
-           ^length 6
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state edge
-           ^position-2-state vacant
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state human
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-compulsory-answer-creations
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners
-           ^position-6-counter-to-update garbage)
-    (make segment-type
-           ^name cfxxfc
-           ^length 6
-           ^geometry symetric
-           ^owner human
-           ^position-1-state vacant
-           ^position-2-state vacant
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-1-counter-to-update nb-of-compulsory-answer-creations
-           ^position-2-counter-to-update nb-of-fragile-winners
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name xfxxfc
-           ^length 6
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state human
-           ^position-2-state vacant
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-fragile-winners
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners
-           ^position-6-counter-to-update nb-of-compulsory-answer-creations)
-    (make segment-type
-           ^name xwxxwx
-           ^length 6
-           ^geometry symetric
-           ^owner human
-           ^position-1-state human
-           ^position-2-state vacant
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-6-state human
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update nb-of-strong-winners
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-strong-winners
-           ^position-6-counter-to-update garbage)
-    (make segment-type
-           ^name oxxxf
-           ^length 5
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state computer
-           ^position-2-state human
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners)
-    (make segment-type
-           ^name ixxxf
-           ^length 5
-           ^geometry assymetric
-           ^owner human
-           ^position-1-state edge
-           ^position-2-state human
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-1-counter-to-update garbage
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-fragile-winners)
-    (make segment-type
-           ^name wxxxw
-           ^length 5
-           ^geometry symetric
-           ^owner human
-           ^position-1-state vacant
-           ^position-2-state human
-           ^position-3-state human
-           ^position-4-state human
-           ^position-5-state vacant
-           ^position-1-counter-to-update nb-of-strong-winners
-           ^position-2-counter-to-update garbage
-           ^position-3-counter-to-update garbage
-           ^position-4-counter-to-update garbage
-           ^position-5-counter-to-update nb-of-strong-winners)
-    (make move-type-classification
-           ^type fragile-winner
-           ^is-better-than-type multiple-fragile-winners-creation)
-    (make move-type-classification
-           ^type fragile-winner
-           ^is-better-than-type agressivity)
-    (make move-type-classification
-           ^type multiple-fragile-winners-creation
-           ^is-better-than-type agressivity)
-    (make move-type
-           ^name agressivity
-           ^point-of-views&counters-to-add
-             human nb-of-compulsory-answer-creations
-             computer nb-of-strong-winners
-           ^comment nil)
-    (make move-type
-           ^name multiple-fragile-winners-creation
-           ^point-of-views&counters-to-add
-             computer nb-of-compulsory-answer-creations
-             human nb-of-strong-winners
-           ^comment need-to-be-validated-separetely)
-    (make move-type
-           ^name fragile-winner
-           ^point-of-views&counters-to-add
-             computer nb-of-fragile-winners human nb-of-fragile-winners
-           ^comment nil)
-)
-
-
-
diff --git a/contrib/ops/haunt.ops b/contrib/ops/haunt.ops
deleted file mode 100644
index 4de108e6e8944de0ecb147b921dae9dfc12185f0..0000000000000000000000000000000000000000
--- a/contrib/ops/haunt.ops
+++ /dev/null
@@ -1,6745 +0,0 @@
-;;; Source code for the haunt program by John Laird
-
-;;; Added comment, -BGM 2/3/89
-(defmacro comment (&rest r) `',r)
-
-(comment Haunt mps OPS5 productions for haunt)
-
-(strategy mea)
-
-(literalize current type name)
-
-(literalize links id name type)
-
-(literalize object name holds state inside scored xscore alive
-place side north south east up contains covered tied wears asleep treasure)
-
-(literalize location name side north south east up underwater book book2
-ontop siton general)
-
- (literalize portal name door status)
-
- (literalize place name visited state water virgin)
-
- (literalize history atetoken northpole forever hiwater grave_status 
-grave_status2 hungry clue bus_stopped)
-
- (literalize command string)
-
- (literalize control state special)
-
- (literalize time realtime cancer morning midnight orc_status orc_time
-	oil_status oil_time btime)
-
- (literalize status score die died bdie likes sound went going answer noway 
-	quit notreasure cut)
-
-(comment **************** Start the show ****************)
-
-(p name01
- (x 0)
- (current ^type operator ^name  readfirst)
- (input)
- -->
- (remove 3)
- (write (crlf) |I assume that means yes.|)
- (modify 2 ^type operator ^name read))
-
-(p name02
- (x 10)
- (current ^type operator ^name  readfirst)
- (input <<  yes y oui nothing  >>)
- -->
- (remove 3)
- (modify 2 ^type operator ^name read))
-
-(p name06
- (x 0)
- (current ^type operator ^name process)
- (input)
- -->
- (write (crlf) |What?|)
- (remove 3)
- (modify 2 ^name read))
-
-(p name07
- (x 10)
- (current ^type operator ^name process)
- (status ^going <> nil)
- -->
- (write (crlf) |You can't go that way.|)
- (modify 2 ^name read)
- (modify 3 ^going nil))
-
-(p name08
- (x 10)
- (current ^type operator ^name process)
- (status ^going nil)
--(input)
- -->
- (modify 2 ^type operator ^name read))
-
-(p name09
- (x 10)
- (current ^type operator ^name read)
- (status ^going nil)
- (time ^realtime <x>)
--(input)
- -->
- (modify 2 ^type operator ^name process)
- (write (crlf) |*|)
- (make input (acceptline nothing read))
- (modify 4 ^realtime (compute <x> + 2)))
-
-(p name010
- (x 50)
- (current ^type operator ^name  readfirst)
-  -->
- (write (crlf) |This is HAUNT.  Version 4.6|)
- (write (crlf) |See NEWS for news.|)
- (write (crlf) |Have you played before?| (crlf) |*|)
- (make input (accept))
- (write (crlf) | |))
-
-(p name011
- (x 20)
- (current ^type operator ^name read)
--(location)
- -->
- (make location ^name bus_stop))
-
-(p name012
- (x 40)
- (current ^type operator ^name  readfirst)
- (input <<  n no  >>)
- -->
- (remove 3)
- (modify 2 ^name read)
- (write (crlf) |Welcome novice.  You are playing one of the world's largest|)
- (write (crlf) |production systems.  The purpose of this game is to find|)
- (write (crlf) |treasure in a haunted house and then escape from the house.|)
- (write (crlf) | |)
- (write (crlf) |The program will give descriptions of locations and accept|)
- (write (crlf) |commands to perform actions.|)
- (write (crlf) |Give it directives with simple 1-5 word commands.|)
- (write (crlf) |Its knowledge of English is limited but imaginative.|)
- (write (crlf) |The directions are north, south, east, west,|)
- (write (crlf) |up and down.  Directions can be one letter (n,s,e,w,u,d).|)
- (write (crlf) |Forward, back, left and right also work.|)
- (write (crlf) |To string commands together use 'then'.  (eg.  west then s)|)
- (write (crlf) |It will describe things to you, and a phrase enclosed in ' ' |)
- (write (crlf) |is something it hears.|)
- (write (crlf) | |)
- (write (crlf) |Special commands: INVEN tells you what you hold.|)
- (write (crlf) |                  SCORE gives your current score.  |)
- (write (crlf) |                  STOP ends the adventure.  |)
- (write (crlf) |                  LOOK describes your current position.|)
- (write (crlf) |                  NEWS describes new features.|)
- (write (crlf) | |)
- (write (crlf) |*************************************************************|)
- (write (crlf) |You get 15 points for finding a treasure and 5 points for|)
- (write (crlf) |getting it to the lawn outside the house.  You get an extra|)
- (write (crlf) |bonus of 20 points for getting your body off the estate.|)
- (write (crlf) |The maximum number of points is 440|)
- (write (crlf) |Good luck, you'll need it.  Ask for help if you want.|)
- (write (crlf) |*************************************************************|)
- (write (crlf) |Copyright (C) 1979, 1980, 1981, 1982, 1983 John Laird|)
- (write (crlf) |*************************************************************|)
- (write (crlf) | |)
- (write (crlf) |On with the adventure!!|)
- (write (crlf) | |)
- (write (crlf) | |)
- (write (crlf) | |)
- (write (crlf) | |)
- (write (crlf) | |)
- (write (crlf) | |)
- (write (crlf) | |)
- (write (crlf) | |)
- (write (crlf) | |)
- (write (crlf) | |)
- (write (crlf) |Along time ago, a young couple was picnicing near the woods|)
- (write (crlf) |on the outskirts of town.  They were celebrating the birth|)
- (write (crlf) |of their first child.  Unfortunately, a crazed moose|)
- (write (crlf) |inhabited that area and attacked them.  The child and husband|)
- (write (crlf) |were unharmed, but the wife was gored to death by the moose.|)
- (write (crlf) | |)
- (write (crlf) |After the funeral, the man bought the land where the incident occurred|)
- (write (crlf) |and constructed a large mansion: CHEZ MOOSE.  He filled it|)
- (write (crlf) |with the treasures of his family and claimed that his wife's|)
- (write (crlf) |soul was still in the area.  He vowed to remain in the|)
- (write (crlf) |mansion until he had returned her soul to human flesh.|)
- (write (crlf) |He tried to bridge the gap between life and death to reclaim her.|)
- (write (crlf) |Some say he was insane with grief, but others claimed that the madness was|)
- (write (crlf) |in his blood, and his wife's death brought it to the surface.|)
- (write (crlf) |After he entered the house, he never returned, and was declared dead |)
- (write (crlf) |seven years later.  Several people have entered the mansion|)
- (write (crlf) |looking for him but none of them have ever returned.|)
- (write (crlf) |There were rumors that he and his wife now haunt the house.|)
- (write (crlf) | |)
- (write (crlf) |That would be the end of the story except that the house|)
- (write (crlf) |still stands and is filled with priceless treasures.|)
- (write (crlf) |The house and all its contents are willed to his only descendant.|)
- (write (crlf) |Oh yes, I forgot to tell you, the day the mother was killed,|)
- (write (crlf) |the child was stolen by Gypsies.|)
- (write (crlf) |The Will claims that only the descendant will know|)
- (write (crlf) |how to avoid going crazy and committing suicide|)
- (write (crlf) |while spending a night in the mansion.|)
- (write (crlf) |An obscure hereditary disease, Orkhisnoires sakioannes,|)
- (write (crlf) |is supposed to play some part in this.|)
- (write (crlf) | |)
- (write (crlf) |So if your heritage is in doubt, you may be the descendant|)
- (write (crlf) |that can claim the treasure in the mansion.|)
- (write (crlf) |Many people, claiming to be descendants have died trying...|)
- (write (crlf) | or at least never returned.|)
- (write (crlf) | |)
- (write (crlf) |The terms of the Will say you get to keep any treasure|)
- (write (crlf) |you get to the lawn, but of course you must also get off the premises alive.|)
- (write (crlf) |Because the house is haunted it must be destroyed, and nobody|)
- (write (crlf) |would be crazy enough to try and recover the rest of the treasure.|)
- (write (crlf) |If you do get out, the government has agreed to|)
- (write (crlf) |buy the land and destroy the house.|)
- (write (crlf) | |)
- (write (crlf) |If you are insane enough to try, your adventure starts at a bus stop.|)
- (write (crlf) |Remember, type STOP to end the adventure.|)
- (write (crlf) | |))
-
-(p name013
- (start)
- -->
- (make current ^type operator ^name readfirst)
- (remove 1)
- (make x 0)
- (make x 10)
- (make x 20)
- (make x 30)
- (make x 40)
- (make x 50)
- (make x 60))
-
-(p name1005
- (x 60)
- (current ^type operator ^name  readfirst)
-  -->
- (make status ^score 0 ^went w ^sound on)
- (make object ^name elevator		^place H)
- (make object ^name candlesticks	^place dining_room ^treasure t)
- (make object ^name ghost		^place cheese_room)
- (make object ^name candy		^place foyer)
- (make object ^name jade		^place backroom ^treasure t)
- (make object ^name soap		^place bathroom)
- (make object ^name mattress		^place bedroom)
- (make object ^name chest ^place ocean ^south 2 ^east 2 ^up 1 ^treasure t)
- (make object ^name marijuana		^place secret_room ^treasure t)
- (make object ^name bottle		^place bar)
- (make object ^name painting		^place smelly_room	^covered t)
- (make object ^name chair		^place main_hall ^treasure t)
- (make object ^name stool		^place bar)
- (make object ^name gold		^place small_closet ^treasure t)
- (make object ^name Dracula		^place dark_room	^asleep t)
- (make object ^name monster		^place laboratory)
- (make object ^name coins		^place bathysphere ^treasure t)
- (make object ^name corkscrew		^place wine_cellar ^treasure t)
- (make object ^name wetsuit		^place closet)
- (make object ^name speargun		^place bathysphere	^state loaded)
- (make object ^name diamonds		^place cave ^treasure t)
- (make object ^name cube		^place frig ^treasure t)
- (make object ^name tokens		^place held)
- (make object ^name orchid		^place lawn
-					^side in ^east 3 ^north 7 ^state seed)
- (make object ^name watch		^place held)
- (make object ^name stairs	^state whole)
- (make object ^name rope 	^tied noose)
- (make object ^name damsel 	^alive t ^tied t)
- (make object ^name turpentine 	^inside bottle)
- (make object ^name moray_eel 	^alive t)
- (make object ^name seamonster 	^alive t)
- (make object ^name octopus 	^alive t)
- (make portal ^name truck		^door closed)
- (make portal ^name library		^door closed)
- (make portal ^name casket		^door closed)
- (make portal ^name grill		^door closed)
- (make portal ^name elevator		^door closed)
- (make portal ^name large_door		^door closed)
- (make portal ^name safe		^door closed)
- (make portal ^name rdoor		^door closed)
- (make portal ^name wdoor		^door closed)
- (make portal ^name closet		^door open)
- (make portal ^name wall		^door closed)
- (make time ^btime 2214  ^realtime 2200)
- (make history ^grave_status undug)
- (make place ^name bathtub ^water out)
- (make place ^name foyer ^virgin t))
-
-(p name1
-  (x 50)
-  (location ^name <name>)
-- (place ^name <name>)
-  -->
-  (make place ^name <name>))
-
-(p name3
- (x 10)
- (location ^name <y>)
- (object ^name <x> ^place <> <y>)
- (input <a> <x>)
- -->
- (remove 4)
- (write (crlf) |The| <x> |is not here.|))
-
-(p name4
- (x 30)
- (input news)
- -->
- (remove 2)
- (write (crlf) |Version 4.6, 6-21-82|)
- (write (crlf) |As always, a few more bugs have been fixed.|)
- (write (crlf) |Send gripes to John.Laird@CMUA.|)
- (write (crlf) |Or John Laird, Computer Science Department|)
- (write (crlf) |Carnegie-Mellon University, Pittsburgh, Pa. 15213|)
- (write (crlf) |The max score is 440.|)
- (write (crlf) |Copyright (C) 1979,1980,1981,1982,1983 John E. Laird|))
-
-(p name5
- (x 30)
- (input who is bzm <x>)
- -->
- (remove 2)
- (write (crlf) |A famous graduate of CMU CSD.|))
-
-(p name6
- (x 30)
- (input xstat)
- -->
- (remove 2)
- (halt))
-
-(p name7
- (x 50)
- (location ^name <x>)
- (place ^name <x> ^visited t)
- -->
- (write (crlf) |You are in| <x> |.|))
-
-(p name8
- (x 30)
- (input <x> <y> on)
- -->
- (make input <x> on <y> (substr 2 5 inf))
- (remove 2))
-
-(p name9
- (x 30)
- (input <x> <y> off)
- -->
- (make input <x> off <y> (substr 2 5 inf))
- (remove 2))
-
-(p name10
- (x 30)
- (input <x> to <y>)
- -->
- (remove 2)
- (make input <x> <y>))
-
-(p name11
- (x 30)
- (location ^name <x>)
- (input gamma <y>)
- -->
- (remove 3)
- (modify 2 ^name <y>))
-
-(p name12
- (x 30)
- (input <x> the)
- -->
- (remove 2)
- (make input <x> (substr 2 4 inf)))
-
-(p name13
- (x 30)
- (input <x> <y> the)
- -->
- (remove 2)
- (make input <x> <y> (substr 2 5 inf)))
-
-(p name14
- (x 30)
- (input <x> a)
- -->
- (remove 2)
- (make input <x> (substr 2 4 inf)))
-
-(p name15
- (x 30)
- (input <x> then)
- -->
- (remove 2)
- (make input <x>)
- (make input then (substr 2 4 inf)))
-
-(p name16
- (x 30)
- (input <x> <y> then)
- -->
- (remove 2)
- (make input <x> <y>)
- (make input (substr 2 4 inf)))
-
-(p name17
- (x 30)
- (input <x> <y> then <W> it)
- -->
- (remove 2)
- (make input <x> <y>)
- (make input then <W> <y> (substr 2 7 inf)))
-
-(p name18
- (x 30)
- (input <x> {<> then <y>} <n> then)
- -->
- (remove 2)
- (make input <x> <y> <n>)
- (make input (substr 2 5 inf)))
-
-(p name19
- (x 30)
- (input then)
- (time ^realtime <y>)
- -->
- (remove 2)
- (make input (substr 2 3 inf))
- (modify 3 ^realtime (compute <y> + 2)))
-
-(p name20
- (x 30)
- (object ^name <y> ^place held)
- (input <x> it)
- -->
- (remove 3)
- (make input <x> <y> (substr 3 4 inf)))
-
-(p name21
- (x 30)
- (object ^name <y> ^place <Z>)
- (location ^name <Z>)
- (input <x> it)
- -->
- (remove 4)
- (make input <x> <y> (substr 4 4 inf)))
-
-
-(comment ********Directions************************************************ )
-
-(p name22
- (x 30)
- (input {<< n s e w u d >> <direction>})
- (status)
- -->
- (remove 2)
- (modify 3 ^going <direction> ^went <direction>))
-
-(p name23
- (x 30)
- (input << out leave >>)
- -->
- (make input exit (substr 2 3 inf))
- (remove 2))
-
-(p name24
- (x 30)
- (input get in)
- -->
- (remove 2)
- (make input enter (substr 2 4 inf)))
-
-(p name25
- (x 30)
- (input << walkin in inside >>)
- -->
- (remove 2)
- (make input enter (substr 2 3 inf)))
-
-(p name26
- (x 30)
- (input west)
- (status)
- -->
- (remove 2)
- (modify 3 ^going w ^went w))
-
-(p name27
- (x 30)
- (input east)
- (status)
- -->
- (remove 2)
- (modify 3 ^going e ^went e))
-
-(p name28
- (x 30)
- (input north)
- (status)
- -->
- (remove 2)
- (modify 3 ^going n ^went n))
-
-(p name29
- (x 30)
- (input south)
- (status)
- -->
- (remove 2)
- (modify 3 ^going s ^went s))
-
-(p name30
- (x 30)
- (input up)
- (status)
- -->
- (remove 2)
- (modify 3 ^going u ^went u))
-
-(p name31
- (x 30)
- (input down)
- (status)
- -->
- (remove 2)
- (modify 3 ^going d ^went d))
-
-(p name32
- (x 30)
- (status ^going n)
- -->
- (modify 2 ^going nil ^noway t))
-
-(p name33
- (x 30)
- (status ^going s)
- -->
- (modify 2 ^going nil ^noway t))
-
-(p name34
- (x 30)
- (status ^going w)
- -->
- (modify 2 ^going nil ^noway t))
-
-(p name35
- (x 30)
- (status ^going e)
- -->
- (modify 2 ^going nil ^noway t))
-
-(p name36
- (x 30)
- (status ^going d)
- -->
- (modify 2 ^going nil)
- (write (crlf) |You can't go down from here.|))
-
-(p name37
- (x 30)
- (status ^going u)
- -->
- (modify 2 ^going nil)
- (write (crlf) |There is nothing to go up on.|))
-
-(p name38
- (x 30)
- (status ^noway t)
- -->
- (write (crlf) |You can't go that way.|)
- (modify 2 ^noway nil ^going nil))
-
-(p name39
- (x 30)
- (status ^went w)
- (input right)
- -->
- (modify 2 ^going n ^went n)
- (remove 3))
-
-(p name40
- (x 30)
- (status ^went <direction>)
- (input forward)
- -->
- (modify 2 ^going <direction>)
- (remove 3))
-
-(p name41
- (x 30)
- (status ^went s)
- (input left)
- -->
- (modify 2 ^going e ^went e)
- (remove 3))
-
-(p name42
- (x 30)
- (status ^went e)
- (input left)
- -->
- (modify 2 ^going n ^went n)
- (remove 3))
-
-(p name43
- (x 30)
- (status ^went e)
- (input right)
- -->
- (modify 2 ^going s ^went s)
- (remove 3))
-
-(p name44
- (x 30)
- (status ^went e)
- (input back)
- -->
- (modify 2 ^going w ^went w)
- (remove 3))
-
-(p name45
- (x 30)
- (status ^went s)
- (input right)
- -->
- (modify 2 ^going w ^went w)
- (remove 3))
-
-(p name46
- (x 30)
- (status ^went s)
- (input back)
- -->
- (modify 2 ^going n ^went n)
- (remove 3))
-
-(p name47
- (x 30)
- (status ^went n)
- (input left)
- -->
- (modify 2 ^going w ^went w)
- (remove 3))
-
-(p name48
- (x 30)
- (status ^went n)
- (input right)
- -->
- (modify 2 ^going e ^went e)
- (remove 3))
-
-(p name49
- (x 30)
- (status ^went n)
- (input back)
- -->
- (modify 2 ^going s ^went s)
- (remove 3))
-
-(p name50
- (x 30)
- (status ^went w)
- (input left)
- -->
- (modify 2 ^going s ^went s)
- (remove 3))
-
-(p name51
- (x 30)
- (status ^went u)
- (input back)
- -->
- (modify 2 ^going d ^went d)
- (remove 3))
-
-(p name52
- (x 30)
- (status ^went d)
- (input back)
- -->
- (modify 2 ^going u ^went u)
- (remove 3))
-
-(p name53
- (x 30)
- (status ^went w)
- (input back)
- -->
- (modify 2 ^going e ^went e)
- (remove 3))
-
-(p name54
- (x 30)
- (input ahead)
- -->
- (remove 2)
- (make input forward))
-
-(p name55
- (x 30)
- (status ^went <y>)
- (input direction)
- -->
- (remove 3)
- (write (crlf) |You are facing | <y>))
-
-(p name56
- (x 20)
- (input exit)
- -->
- (remove 2)
- (make input back))
-
-(p name57
- (x 20)
- (input enter <x>)
- -->
- (remove 2)
- (write (crlf) |I can't enter| <x> |.|))
-
-(p name58
- (x 30)
- (input go nil)
- -->
- (make input forward)
- (remove 2))
-
-(p name59
- (x 30)
- (input go <> nil)
- -->
- (remove 2)
- (make input (substr 2 3 inf)))
-
-
-(comment *****************Get and Drop************************************* )
-
-(p name60
- (x 30)
- (location ^name <x>)
- (object ^name <n> ^place <x>)
- (input get all)
- -->
- (make input get <n>))
-
-(p name61
- (x 20)
- (input get all)
- -->
- (remove 2)
- (write (crlf) |OK, all done.|))
-
-(p name62
- (x 30)
- (object ^name <p> ^place held)
- (input get <p>)
- -->
- (remove 3)
- (write (crlf) |You already have| <p>))
-
-(p name63
- (x 10)
- (input get <p>)
- -->
- (remove 2)
- (write (crlf) |I can't get| <p>))
-
-(p name64
- (x 30)
- (object ^name <x> ^place <p> ^side <s> ^north <n> ^east <e> ^state nil)
- (location ^name <p> ^side <s> ^north <n> ^east <e>)
- (input get <x>)
- -->
- (remove 4)
- (modify 2 ^place held)
- (write (crlf) |You just got| <x> |.|))
-
-(p name65
- (x 40)
- (object ^name monster ^place laboratory)
- (location ^name laboratory)
- (input get monster)
- -->
- (remove 4)
- (write (crlf) |That would be a big mistake.|))
-
-(p name66
- (x 40)
- (object ^name cecil ^place <x>)
- (location ^name <x>)
- (input get cecil)
- -->
- (remove 4)
- (write (crlf) |Cecil is a free spirit.  He doesn't come with you.|))
-
-(p name67
- (x 30)
- (input << pull pickup grab pry lift take carry >> <x>)
- -->
- (remove 2)
- (make input get <x>))
-
-(p name68
- (x 30)
- (input pick up <x>)
- -->
- (make input get <x>)
- (remove 2))
-
-(p name69
- (x 10)
- (input drop all)
- -->
- (remove 2)
- (write (crlf) |All dropped.|))
-
-(p name70
- (x 30)
- (input drop all)
- (location ^name <p>)
- (object ^name <n> ^place held)
- -->
- (make input drop <n>))
-
-(p name71
- (x 20)
- (object ^name <x> ^place held)
- (location ^name <y> ^side <s> ^north <n> ^east <e>)
- (input drop <x>)
- -->
- (remove 4)
- (modify 2 ^place <y> ^side <s> ^north <n> ^east <e>))
-
-(p name72
- (x 30)
- (input << discard release >> <x>)
- -->
- (remove 2)
- (make input drop <x>))
-
-(p name73
- (x 10)
- (object ^name <x> ^place <> held)
- (input drop <x>)
- -->
- (remove 3)
- (write (crlf) |You don't have| <x>))
-
-(p name74
- (x 30)
- (input put down <x>)
- -->
- (remove 2)
- (make input drop <x>))
-
-(p name75
- (x 30)
- (input take off <x>)
- -->
- (remove 2)
- (make input remove <x>))
-
-
-(comment *****************Inventory************************************  )
-
-(p name76
- (x 30)
- (object ^name <p> ^place held)
- (input inven)
- -->
- (write (crlf) <p>))
-
-(p name77
- (x 20)
- (input inven)
- -->
- (remove 2))
-
-(p name78
- (x 40)
- (input inven)
- -->
- (write (crlf) |You have the following:|))
-
-(p name79
- (x 30)
- (input inventory)
- -->
- (remove 2)
- (make input inven))
-
-(p name80
- (x 30)
- (object ^name <p> ^place held)
- (object ^name <C> ^inside <p>)
- (input inven)
- -->
- (write (crlf) <C>))
-
-(p name81
- (x 50)
--(object ^name <x> ^place held)
- (input inven)
- -->
- (remove 2)
- (write (crlf) |You're empty handed.|))
-
-
-(comment ******************Random inputs********************************* )
-
-(p name82
- (x 30)
- (input run nil)
- -->
- (remove 2)
- (write (crlf) |I'm going as fast as I can.|))
-
-(p name83
- (x 30)
- (input run <> nil)
- -->
- (remove 2)
- (write (crlf) |I can't go any faster.|))
-
-(p name84
- (x 30)
- (input listen)
- -->
- (remove 2)
- (write (crlf) |Silence!|))
-
-
-(p name85
- (x 30)
- (status ^sound on)
- (input listen)
- -->
- (remove 3)
- (modify 2 ^sound on))
-
-(p name86
- (x 30)
- (input whistle)
- -->
- (remove 2)
- (write (crlf) |What, without an accompanying orchestra?|))
-
-(p name87
- (x 30)
- (input hum)
- -->
- (remove 2)
- (write (crlf) |Hum de dum de dum, hum hum dum dum de dum.|))
-
-(p name88
- (x 30)
- (input sing)
- -->
- (remove 2)
- (write (crlf) |In-A-Gadda-Da-Vida Baby, don't you know that I love you.|))
-
-(p name89
- (x 30)
- (input mumble)
- -->
- (remove 2)
- (write (crlf) |mumbmaubmmmsms|))
-
-(p name90
- (x 30)
- (status)
- (input << quit halt stop >>)
- -->
- (remove 3)
- (modify 2 ^quit t)
- (write (crlf) |The party's over.|))
-
-
-(comment ***********************Death*************************************** )
-
-(p name1007
- (x 40)
- (status ^die t ^died t ^quit nil)
- -->
- (write (crlf) |Well, you're one more that didn't get the treasure and live.|)
- (modify 2 ^quit t))
-
-(p name1008
- (x 40)
- (status ^die t  ^score <Q> ^died nil)
- -->
- (modify 2 ^score (compute <Q> - 20) ^died t)
- (write (crlf) |Hmm...  you went and got yourself killed.|)
- (write (crlf) |But I'll let you play a bit longer.|))
-
-(p name96
- (x 30)
--(object ^name bottle ^place held)
- (input pour)
- -->
- (remove 2)
- (write (crlf) |You don't have a bottle full of anything.|))
-
-(p name97
- (x 30)
- (object ^name bottle ^place held)
- (object ^name <x> ^inside bottle)
- (input drink)
--->
- (remove 4)
- (remove 3)
- (write (crlf) |I love that| <x> |for breakfast every morning.|))
-
-(p name98
- (x 30)
- (object ^name bottle ^place held)
- (location ^name beach)
- (input get sand)
- -->
- (remove 4)
- (write (crlf) |The sand clogs in the neck of the bottle.|)
- (write (crlf) |For all practical purposes you can't get any sand.|))
-
-(p name99
- (x 30)
- (object ^name bottle ^place held)
- (location ^name beach)
- (input fill bottle)
- -->
- (remove 4)
- (make input get sand))
-
-
-(comment ********Treasure Objects***************************** )
-
-(p name100
- (x 20)
- (object ^name corkscrew ^place <x>)
- (location ^name <x>)
- -->
- (write (crlf) |There is a diamond studded corkscrew here!|))
-
-(p name101
- (x 30)
- (object ^name corkscrew ^place held)
- (input screw)
- -->
- (write (crlf)|Cork screwing is a little out of my league.|)
- (remove 3))
-
-(p name102
- (x 20)
- (location ^name <x>)
- (object ^name ring ^place <x>)
- -->
- (write (crlf) |There is a huge diamond ring here.|))
-
-
-(comment **************************Candy*************************************)
-
-(p name103
- (x 20)
- (location ^name <x>)
- (object ^name candy ^place <x>)
- -->
- (write (crlf) |There is a bowl of candy on the ground.|))
-
-(p name104
- (x 30)
- (input <x> bowl)
- -->
- (remove 2)
- (make input <x> candy))
-
-(p name105
- (x 30)
- (object ^name candy ^place <x>)
- (location ^name <x>)
- (input eat candy)
- -->
- (write (crlf) |Candy tastes good; uhm!|)
- (write (crlf) |Of course the pins in the Snickers take a little chewing.|)
- (remove 2)
- (remove 4))
-
-(p name106
- (x 30)
- (object ^name candy ^place held)
- (input eat candy)
- -->
- (write (crlf) |You eat the candy; and get cavities.|)
- (remove 2)
- (remove 3))
-
-
-(comment *****************Marijuana************************************)
-
-(p name107
- (x 30)
- (location ^name <x>)
- (object ^name marijuana ^place <x>)
- -->
- (write (crlf) |There is some fine marijuana here! Good stuff.|))
-
-(p name108
- (object ^name matches ^place held)
- (location ^name lawn)
- (input burn <x>)
- -->
- (remove 3)
- (write (crlf) |The matches go out before you can burn| <x>))
-
-(p name109
- (x 30)
- (object ^name marijuana ^place held)
- (object ^name matches ^place held)
- (history ^hungry nil)
- (location ^name lawn)
- (input smoke marijuana)
- -->
- (remove 2)
- (remove 3)
- (remove 5)
- (modify 4 ^hungry t)
- (write (crlf) |You manage to light up,|)
- (write (crlf) |the matches haved dried out here, this very expensive stuff.|)
- (write (crlf) |Its very smooth, you begin to think you really don't|)
- (write (crlf) |need to adventure anymore.  You are hungry.|))
-
-(p name110
- (x 30)
- (object ^name marijuana ^place held)
- (input smoke marijuana)
- -->
- (remove 3)
- (write (crlf) |You don't have any matches.|))
-
-(p name111
- (x 30)
- (input smoke marijuana)
- -->
- (remove 2)
- (write (crlf) |You don't have any.|))
-
-(p name112
- (x 30)
- (object ^name marijuana ^place held)
- (object ^name matches ^place held)
- (input smoke marijuana)
- -->
- (remove 4)
- (write (crlf) |The matches are wet.|))
-
-(p name113
- (x 30)
- (history ^hungry t)
- (object ^name <x> ^place held)
- -->
- (write (crlf) |I'm so hungry, I could eat a | <x> )
- (make input eat <x>))
-
-(p name114
- (x 20)
- (history ^hungry t)
- -->
- (modify 1 ^hungry nil))
-
-(p name115
- (x 30)
- (input <y> << maryjane marihuana dope grass pot >>)
- -->
- (remove 2)
- (make input <y> marijuana))
-
-(p name116
- (x 30)
- (input << smoke light burn >> marijuana)
- -->
- (remove 2)
- (make input smoke marijuana))
-
-
-(comment ***********************************CUBE*****************************)
-(p name117
- (x 20)
- (location ^name <x>)
- (object ^name cube ^place <x>)
- -->
- (write (crlf) |There is a small white cube here.|))
-
-(p name118
- (x 30)
- (object ^name cube ^place held)
- (input lick cube)
- -->
- (remove 3)
- (write (crlf) |UHM! That tasted good!!!|))
-
-(p name119
- (x 30)
- (object ^name cube ^place held)
- (input taste cube)
- -->
- (remove 3)
- (write (crlf) |To taste it you should really eat the cube.|))
-
-(p name120
- (x 30)
- (object ^name cube ^place held)
- (object ^name watch ^place held)
- (input eat cube)
- -->
- (remove 2)
- (remove 4)
- (write (crlf) |The cube tastes like sugar.  You are suddenly surrounded by|)
- (write (crlf) |a herd of moose.  They start talking to you about a moose-load of things.|)
- (write (crlf) |One walks over to you and whispers, 'Fa Lowe, why her?'|)
- (write (crlf) |You look at your watch , but the hands suddenly spin!|)
- (write (crlf) |You find yourself staring at the|)
- (write (crlf) |m|)
- (write (crlf) | o|)
- (write (crlf) |  o|)
- (write (crlf) |   s|)
- (write (crlf) |    e|)
- (write (crlf) |     ?|)
- (write (crlf) |  for a long time, and enjoying it.|))
-
-(p name121
- (x 30)
- (object ^name cube ^place held)
- (input eat cube)
- -->
- (remove 2)
- (remove 3)
- (write (crlf) |The cube tastes like sugar.  You are suddenly surrounded by|)
- (write (crlf) |a herd of moose.  They start talking to you about a moose-load of things.|)
- (write (crlf) |One walks over to you and whispers, 'Fa Lowe, why her?'|)
- (write (crlf) |You find yourself staring at your toes|)
- (write (crlf) |  for a long time, and enjoying it.|))
-
-(p name122
- (x 30)
- (location ^name kitchen)
- (object ^name cube ^place held)
- (input eat cube)
- -->
- (remove 3)
- (remove 4)
- (write (crlf) |That was sweet.|)
- (write (crlf) |This kitchen is real deary.  A bad place to take acid.|)
- (write (crlf) |You have to get out of here!!|)
- (write (crlf) |You feel on fire, you need water to cool off.|)
- (make input
- w then push button then n then push b then exit then push red button))
-
-(p name123
- (x 30)
- (input <x> white cube)
- -->
- (remove 2)
- (make input <x> cube))
-
-(p name124
- (x 30)
- (input <x> << sugar acid >>)
- -->
- (remove 2)
- (make input <x> cube))
-
-(comment *************************CANCER*************************************)
-
-(p name125
- (x 60)
- (location)
- (status ^likes  <B>)
- (time ^cancer  <TIME> ^realtime <TIME>)
- -->
- (write (crlf) |Your wicked and lusty life has finally caught up with you.|)
- (write (crlf) |That cigarette you had with the| <B> |has caused cancer to|)
- (write (crlf) |spread throughout your lungs.  COUGH!! COUGH!! You are|)
- (write (crlf) |weakening.  Hack! You're down on your knees.  COUGH COUGH!!|)
- (write (crlf) |You keel over and die....|)
- (modify 3 ^quit t))
-
-
-(comment **********************Going Crazy********************************  )
-
-(p name126
- (x 60)
- (time ^orc_status sweat ^orc_time <x> ^realtime <x>)
- -->
- (modify 2 ^orc_status dizzy ^orc_time (compute <x> + 120))
- (write (crlf) | |)
- (write (crlf) |You are starting to sweat.  I think this place is getting to you.|))
-
-(p name127
- (x 60)
- (time ^orc_status dizzy ^orc_time <x> ^realtime <x>)
- -->
- (modify 2 ^orc_status mad ^orc_time (compute <x> + 60))
- (write (crlf) | |)
- (write (crlf) |Your getting a little dizzy.|)
- (write (crlf) |The area around seems to swim a little when you move.|))
-
-(p name128
- (x 60)
- (time ^orc_status mad ^orc_time <x> ^realtime <x>)
- -->
- (modify 2 ^orc_status suicide ^orc_time (compute <x> + 30))
- (write (crlf) | |)
- (write (crlf) |I think you are definitely going insane.  The sweaty palms and dizziness were|)
- (write (crlf) |the first signs.  If you don't do something quick, you'll commit suicide!|))
-
-(p name129
- (x 60)
- (time ^orc_status suicide ^orc_time <x> ^realtime <x>)
- (status)
- -->
- (modify 2 ^orc_status nil ^orc_time nil)
- (modify 3 ^die t)
- (write (crlf) | |)
- (write (crlf) |~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|)
- (write (crlf) |You can't stand it anymore, you are now totally crazy!|)
- (write (crlf) |You start laughing uncontrollably, but choke on your tongue.|)
- (write (crlf) |Ugh! Well at least you died happy!|))
-
-(p name130
- (x 30)
- (time ^orc_status <> nil) 
- (command ^string eat_it)
- -->
- (modify 2 ^orc_status nil)
- (remove 3)
- (write (crlf) |You feel much saner.|)
- (write (crlf) |You've managed to avoid the St.  John curse!|))
-
-(p name131
- (x 30)
- (time ^orc_status suicide)
- (command ^string eat_it)
- -->
- (modify 2 ^orc_status nil)
- (remove 3)
- (write (crlf) |You've done it! The orchid returns you to sanity.|))
-
-
-(comment **********************More  Random********************************* )
-
-(p name132
- (x 30)
- (input << examine describe >> <x>)
- -->
- (remove 2)
- (make input look <x>))
-
-(p name133
- (x 30)
- (place ^name <y> ^visited t)
- (location ^name <y>)
- (input look)
- -->
- (remove 4)
- (modify 2 ^visited nil))
-
-(p name134
- (x 30)
- (input kill)
- -->
- (remove 2)
- (write (crlf) |With what? Your bare hands?|))
-
-(p name135
- (x 30)
- (object ^name <x> ^place <z>)
- (location ^name <z>)
- (input kill <x> with <y>)
- -->
- (remove 4)
- (write (crlf) |Even with that you can't kill it.|))
-
-(p name136
- (x 30)
- (object ^name football ^holds nil)
- (input throw football)
- --> 
- (remove 3)
- (write (crlf) |You don't have a football Dummy!|))
-
-(p name137
- (x 30)
- (input throw)
- -->
- (remove 2)
- (write (crlf) |I don't throw anything but a regulation NFL football.|))
-
-(p name138
- (x 30)
- (input throw up)
- -->
- (remove 2)
- (write (crlf) |I don't have the stomach for that.|))
-
-(p name139
- (x 30)
- (input cut)
- -->
- (remove 2)
- (write (crlf) |There is nothing to cut with.|))
-
-(p name140
- (x 30)
- (input cut <x> with <y>)
- -->
- (remove 2)
- (write (crlf) |The| <y>  |won't cut the| <x>  |.|))
-
-(p name141
- (x 30)
- (input cut cheese)
- -->
- (remove 2)
- (write (crlf) |Look, this room is smelly enough already without that.|))
-
-(p name142
- (x 30)
- (input break <x>)
- -->
- (remove 2)
- (write (crlf) |You hurt your hand.|))
-
-(p name143
- (x 30)
- (input bust bust)
- -->
- (remove 2)
- (write (crlf) |Homer looks hurt.|))
-
-(p name144
- (x 30)
- (input kick <x>)
- -->
- (remove 2)
- (write (crlf) |Ouch! The| <x>  |kicks back.|))
-
-(p name145
- (x 30)
- (object ^name <x> ^place held)
- (location ^name <y> ^side <s> ^north <n> ^east <e>)
- (input kick <x>)
- -->
- (modify 2 ^place <y> ^side <s> ^north <n> ^east <e>)
- (remove 4)
- (write (crlf) |Thud! Not much of a kicker I see.|))
-
-(p name146
- (x 30)
- (input kick football)
- -->
- (remove 2)
- (write (crlf) |I see no football here.|))
-
-(p name147
- (x 30)
- (input punt <x>)
- -->
- (remove 2)
- (make input kick <x>))
-
-(p name148
- (x 20)
- (input jump)
- -->
- (remove 2)
- (write (crlf) |Up you go, down you come.|))
-
-(p name149
- (x 20)
- (input burn <x>)
- -->
- (remove 2)
- (write (crlf) |You can't burn| <x> |without matches.|))
-
-(p name150
- (x 30)
- (object ^name matches ^place held)
- (input burn)
- -->
- (remove 3)
- (write (crlf) |You may have matches, but you didn't light one.|))
-
-(p name151
- (x 30)
- (input open)
- -->
- (remove 2)
- (write (crlf)  |I don't see anything that is closed.|))
-
-(p name152
- (x 30)
- (input open chest)
- -->
- (remove 2)
- (write (crlf) |The chest can't be opened, but it is worth mucho closed.|))
-
-(p name153
- (x 30)
- (input help)
- -->
- (remove 2)
- (write (crlf) |Help yourself|))
-
-(p name154
- (x 20)
- (current ^type operator ^name process)
- (input yes)
- -->
- (remove 3)
- (write (crlf) |Cute, but lets get on with the show.|))
-
-(p name155
- (x 30)
- (current ^type operator ^name process)
- (input no)
- -->
- (remove 3)
- (write (crlf) |That was rhetorical you fool.|))
-
-(p name156
- (x 30)
- (input spit <x>)
- -->
- (remove 2)
- (write (crlf) |Your throat is too dry.|))
-
-(p name157
- (x 30)
- (input where <x>)
- -->
- (remove 2)
- (write (crlf) |I don't know where| <x> |.  I hope we aren't lost!!|))
-
-(p name158
- (x 30)
- (input find <x>)
- -->
- (remove 2)
- (write (crlf) |That would be cheating if I did it.|))
-
-(p name159
- (x 20)
- (input drink <a>)
- -->
- (remove 2)
- (write (crlf) |The| <a> |is not drinkable.|))
-
-(p name160
- (x 20)
- (input drink nil)
- -->
- (remove 2)
- (write (crlf) |I don't know what to drink.|))
-
-(p name161
- (x 30)
- (input screw)
- -->
- (remove 2)
- (write (crlf) |Sorry, but i don't have a screw driver.|))
-
-(p name162
- (x 30)
- (input fuck)
- -->
- (remove 2)
- (write (crlf) |That would be pretty kinky.|))
-
-(p name163
- (x 30)
- (input fuck bust)
- -->
- (remove 2)
- (write (crlf) |Homer is harder than you are.|))
-
-(p name164
- (x 30)
- (status ^wears wetsuit)
- (input fuck <x>)
- -->
- (remove 3)
- (write (crlf) |You can't do that with a wetsuit on!|))
-
-(p name165
- (x 30)
- (input up yours)
- -->
- (remove 2)
- (write (crlf) |Up your own.|))
-
-(p name166
- (x 30)
- (input oh shit)
- -->
- (remove 2)
- (write (crlf) |Isn't life a pisser?|))
-
-(p name167
- (x 30)
- (input oh no)
- -->
- (remove 2)
- (write (crlf) |Mais oui.|))
-
-(p name168
- (x 30)
- (input shit)
- -->
- (remove 2)
- (write (crlf) |Hey, let's not mess up the place!|))
-
-(p name169
- (x 30)
- (input rape <x>)
- -->
- (remove 2)
- (make input torture <x>))
-
-(p name170
- (x 30)
- (input kiss)
- -->
- (remove 2)
- (write (crlf) |SMACK!|))
-
-(p name171
- (x 30)
- (input << ball copulate hump >> <x>)
- -->
- (remove 2)
- (make input fuck <x>))
-
-(p name172
- (x 30)
- (input make love)
- (status ^likes  <x>)
- -->
- (remove 2)
- (make input fuck <x>))
-
-(p name173
- (x 30)
- (input masturbate)
- -->
- (remove 2)
- (write (crlf) |You're too scared to get aroused at all.|))
-
-(p name174
- (x 30)
- (input god damn)
- -->
- (remove 2)
- (make input pray))
-
-(p name175
- (x 30)
- (input tingle)
- -->
- (remove 2)
- (write (crlf) |Nothing happens.|))
-
-(p name176
- (x 30)
- (input blow)
- -->
- (remove 2)
- (write (crlf) |Whoooooosh!|))
-
-(p name177
- (x 20)
- (input knock)
- -->
- (remove 2)
- (write (crlf) |Thud, thud.|))
-
-(p name178
- (x 30)
- (input eat <> orchid)
- -->
- (remove 2)
- (write (crlf) |That is not part of a balanced diet.|))
-
-(p name179
- (x 30)
- (object ^name <x> ^holds nil)
- (input eat <x>)
- -->
- (remove 3)
- (write (crlf) |You don't have| <x> |on you.|))
-
-(p name180
- (x 30)
- (input eat shit)
- -->
- (remove 2)
- (write (crlf) |YEACH! Fuck off!|))
-
-(p name181
- (x 30)
- (status)
- (input go to hell)
- -->
- (remove 3)
- (write (crlf) |Oh yeah! I'm fed up with you!!|)
- (modify 2 ^quit t))
-
-(p name182
- (x 30)
- (input <x> moose)
- -->
- (remove 2)
- (write (crlf) |I see no moose.|))
-
-(p name183
- (x 30)
- (input go blue)
- -->
- (remove 2)
- (write (crlf) |Beat State.|))
-
-(p name184
- (x 30)
- (input pray)
- -->
- (remove 2)
- (write (crlf) |GOD responds:|)
- (make input help))
-
-(p name185
- (x 30)
- (input damn <x>)
- -->
- (remove 2)
- (write (crlf) |Clean up your act.|))
-
-
-(p name186
- (x 30)
- (input open sesame)
- -->
- (remove 2)
- (write (crlf) |No says me!|))
-
-(p name187
- (x 30)
- (input I <x>)
- -->
- (remove 2)
- (write (crlf) |Quit talking about yourself and give me a command.|))
-
-(p name188
- (x 20)
- (input give <x> to <y>)
- -->
- (remove 2)
- (write (crlf) |The| <y>  |doesn't take| <x> ))
-
-(p name189
- (x 20)
- (input give <x> <y>)
- -->
- (remove 2)
- (write (crlf) |The| <x>  |doesn't want| <y> ))
-
-(p name190
- (x 30)
- (object ^name <x> ^place held)
- (input give <x>)
- -->
- (remove 3)
- (write (crlf) |Hey, after we went through all the trouble to get |
-	(crlf) <x>  |I ain't gonna let you give it away.|))
-
-(p name191
- (x 20)
- (input give <x>)
- -->
- (remove 2)
- (write (crlf) |First we should get it.|))
-
-(p name192
- (x 30)
- (time ^realtime 0002)
- (input follow moose)
- -->
- (remove 3)
- (write (crlf) |Crash!! Into the wall you go.|))
-
-(p name193
- (x 30)
- (location ^name bus_stop)
- (time ^realtime 0002)
- (input follow moose)
- -->
- (remove 4)
- (write (crlf) |Last I saw he went west, so away we go.|)
- (make input west))
-
-(p name194
- (x 30)
- (input follow moose)
- -->
- (remove 2)
- (write (crlf) |I see no moose here.|))
-
-(p name195
- (x 30)
- (input swim)
- -->
- (remove 2)
- (write (crlf) |Why don't you wait until we are in the water.|))
-
-
-(comment **************Get on and off objects ****************************** )
-
-(p name196
- (x 30)
- (status)
- (input mount)
- -->
- (remove 3)
- (modify 2 ^going u ^went u))
-
-(p name197
- (x 30)
- (input stand on)
- -->
- (remove 2)
- (make input mount))
-
-(p name198
- (x 20)
- (input get on)
- -->
- (remove 2)
- (make input mount))
-
-(p name199
- (x 30)
- (input climb on)
- -->
- (remove 2)
- (make input mount))
-
-(p name200
- (x 30)
- (status)
- (input climb)
- -->
- (remove 3)
- (modify 2 ^going u ^went u))
-
-(p name201
- (x 30)
- (location ^name <> bus)
- (status)
- (input get off)
- -->
- (remove 4)
- (modify 3 ^going d ^went d))
-
-(p name202
- (x 30)
- (status)
- (input get down)
- -->
- (remove 3)
- (modify 2 ^going d ^went d))
-
-(p name203
- (x 30)
- (status)
- (input dismount)
- -->
- (remove 3)
- (modify 2 ^going d ^went d))
-
-(p name204
- (x 30)
- (input sit in)
- -->
- (remove 2)
- (make input sit on))
-
-(p name205
- (x 30)
- (input sit)
- -->
- (remove 2)
- (write (crlf) |I don't know how to sit on it.|))
-
-(p name206
- (x 50)
- (location ^ontop <> nil ^going d)
- -->
- (modify 2 ^ontop nil ^going nil)
- (write (crlf) |You are back on Terra Firma.|))
-
-(p name207
- (x 40)
- (location ^ontop <> nil ^going <> nil)
- -->
- (modify 2 ^ontop nil ^going nil)
- (write (crlf) |You just fell to the ground.|)
- (make input look))
-
-(p name208
- (x 40)
- (location ^siton <> nil ^going <> nil)
- -->
- (modify 2 ^siton nil))
-
-(p name209
- (x 30)
- (location ^siton <> nil)
- (input get up)
- -->
- (modify 2 ^siton nil)
- (remove 3)
- (write (crlf) |You are now standing.|))
-
-(p name210
- (x 30)
- (location siton <> nil)
- (input stand <x>)
- -->
- (modify 2 ^siton nil)
- (remove 3)
- (write (crlf) |You are no longer sitting.|))
-
-(p name211
- (x 30)
- (location ^siton  <Q>)
- (input get <Q>)
- -->
- (remove 3)
- (write (crlf) |You'll have to stand up first.|))
-
-(p name212
- (x 30)
- (location ^ontop <Q>)
- (input get <Q>)
- -->
- (remove 3)
- (write (crlf) |Cute, why don't you get off it first.|))
-
-(p name213
- (x 30)
- (object ^name <x> ^place held)
- (input mount <x>)
- -->
- (remove 3)
- (write (crlf) |Why don't you drop it first.|))
-
-
-(comment *****Touchy Feelie*************************************************)
-
-(p name214
- (x 30)
- (input << fondle cuddle hug rub tap feel >>)
- -->
- (remove 2)
- (make input touch))
-
-(p name215
- (x 30)
- (object ^name <x> ^place held)
- (input touch <x>)
- -->
- (remove 3)
- (write (crlf) |It is in your hands, and it feels like a| <x> |.|))
-
-(p name216
- (x 30)
- (input touch wall)
- -->
- (remove 2)
- (write (crlf) |Surprize! The wall is flat and cold.|))
-
-(p name217
- (x 30)
- (object ^name painting ^place held)
- (input touch painting)
- -->
- (remove 3)
- (write (crlf) |The painting is still wet!!|))
-
-(p name218
- (x 30)
- (input touch)
- -->
- (remove 2)
- (write (crlf) |You should get it first.|))
-
-
-(comment ********************Bottle*********************************** )
-(p name219
- (x 30)
- (object ^name bottle ^place held)
- (history ^grave_status2 oil)
- (location ^name lawn ^side in ^east 8 ^north 8)
- (input fill bottle)
- -->
- (remove 5)
- (write (crlf) |The oil won't go into the bottle, sorry.|))
-
-(p name220
- (x 30)
- (history ^grave_status2 oil)
- (object ^name bottle ^place held)
- (location ^name lawn ^side in ^east 8 ^north 8)
- (input get oil)
- -->
- (remove 5)
- (write (crlf) |The oil is too thick to go into the bottle.|))
-
-(p name221
- (x 20)
- (location ^name <x>)
- (object ^name bottle ^place <x>)
--(object ^inside bottle)
--->
- (write (crlf) |There is an empty bottle here.|))
-
-(p name222
- (x 20)
- (location ^name <x>)
- (object ^name bottle ^place <x>)
- (object ^name <q> ^inside bottle)
--->
- (write (crlf) |There is a bottle of| <q>  |here.|))
-
-(p name223
- (x 30)
- (object ^name <q> ^inside bottle)
- (object ^name bottle ^place <x>)
- (location ^name <x>)
- (input get <q>)
- -->
- (modify 2 ^place held)
- (remove 5)
- (write (crlf) |You are now holding the bottle.|))
-
-(p name224
- (x 30)
- (object ^name bottle ^place held)
- (location ^name bathroom)
- (input fill bottle <g>)
--(object ^inside bottle)
- -->
- (remove 4)
- (make object ^name bathwater ^inside bottle)
- (write (crlf) |The bottle is full of bathwater.|))
-
-(p name225
- (x 30)
- (object ^name bottle ^place held)
- (location ^name beach ^east 3)
- (input fill bottle <g>)
--(object ^inside bottle)
- -->
- (remove 4)
- (make object ^name water ^inside bottle)
- (write (crlf) |The bottle is full of sparkling water.|))
-
-(p name226
- (x 30)
- (object ^name bottle ^place held)
- (object ^inside bottle)
- (location ^name beach ^east 3)
- (input pour)
- -->
- (remove 3)
- (remove 5)
- (write (crlf) |The bottle is empty.  The liquid disappears in the sand.|))
-
-(p name227
- (x 30)
- (object ^name bottle ^place held)
- (object ^inside bottle)
- (location ^name bathroom)
- (input pour)
- -->
- (remove 3)
- (remove 5)
- (write (crlf) |The bottle is now empty.|))
-(comment ++++++++++++++++)
-(p name228
- (location ^underwater t)
- (object ^name bottle ^place held)
- (input fill bottle)
--(object ^name <> nil ^inside bottle)
- -->
- (remove 3)
- (make object ^name seawater ^inside bottle)
- (write (crlf) |The bottle is full of seawater.|))
-
-(p name229
- (input get << seawater bathwater water >>)
- -->
- (remove 1)
- (make input fill bottle))
-
-(p name230
- (input fill up)
- -->
- (remove 1)
- (make input fill bottle))
-
-(p name231
- (object ^name bottle ^place held)
- (input fill bottle <g>)
--(object ^name <q> ^inside bottle)
- -->
- (remove 2)
- (write (crlf) |There is nothing to fill the bottle with.|))
-
-(p name232
- (object ^name bottle ^place held)
- (object ^inside bottle)
- (input fill bottle)
- -->
- (remove 3)
- (write (crlf) |The bottle is already full.|))
-
-(p name233
- (input fill bottle)
- -->
- (remove 1)
- (write (crlf) |You don't have a bottle to fill.|))
-
-(p name234
- (input pour)
- (location ^underwater t)
- -->
- (remove 1)
- (write (crlf) |Hmm, you want me to empty a bottle underwater.|)
- (write (crlf) |I'm afraid that is out of my league.|))
-
-(p name235
- (object ^name water ^place <x>)
- (location ^name <x>)
- -->
- (write (crlf) |There is a wet spot here.|))
-
-(p name236
- (object ^name seawater ^place <x>)
- (location ^name <x>)
- -->
- (write (crlf) |There is a salty wet spot here.|))
-
-(p name237
- (location ^name <x>)
- (object ^name bathwater ^place <x>)
- -->
- (write (crlf) |There is a bit of a wet spot here.|))
-
-(p name238
- (location ^name <x>)
- (object ^name turpentine ^place <x>)
- -->
- (remove 2)
- (write (crlf) |The turpentine evaporates as it leaves the bottle.|))
-
-(p name239
- (location ^name <y>)
- (object ^name bottle ^place held)
- (object ^name <q> ^inside bottle)
- (input drop <q>)
- -->
- (modify 2 ^place <y>)
- (remove 4))
-
-(p name240
- (location ^name <y>)
- (object ^name bottle ^place held)
- (object ^name <q> ^inside bottle)
- (input pour)
- -->
- (remove 4)
- (modify 3 ^inside nil ^place <y>))
-
-(p name241
- (location ^name <x>)
- (object ^name << water seawater bathwater >> ^place <x>)
- (input fill bottle)
- -->
- (remove 3)
- (write (crlf) |Sorry, I don't have a mop!|))
-
-(p name242
- (location ^name <x>)
- (object ^name water ^inside bottle)
- (object ^name bottle ^place held)
- (input drink water)
- (status)
- -->
- (remove 1)
- (remove 2)
- (remove 4)
- (write (crlf) |You have changed into a baby, the adventure must end.|)
- (modify 5 ^quit t))
-
-(p name243
- (object ^name bottle ^place held)
- (object ^name seawater ^inside bottle)
- (input drink)
- -->
- (remove 2)
- (remove 3)
- (write (crlf) |Yech! It tastes salty!!|))
-
-(p name244
- (input << water empty >>)
- -->
- (remove 1)
- (make input pour))
-
-
-(comment ********************MATCHES************************************* )
-
-(p name245
- (location ^name <x>)
- (object ^name matches ^place <x>)
- -->
- (write (crlf) |There are matches here.|))
-
-(p name246
- (object ^name matches ^place held)
- (input <x> match)
- -->
- (remove 2)
- (make input <x> matches))
-
-(p name247
- (object ^name matches ^place held)
- (input << light strike dry >> matches)
- -->
- (remove 2)
- (write (crlf) |This house is to damp to light the matches in.|))
-
-(p name248
- (location ^name lawn)
- (object ^name matches ^place held)
- (input dry matches)
- -->
- (remove 3)
- (write (crlf) |The matches dry out.|))
-
-(p name249
- (location ^name lawn)
- (object ^name matches ^place held)
- (input << light strike >> matches)
- -->
- (remove 3)
- (write (crlf) |The match lights but goes out quickly.|))
-
-(p name250
- (input smoke <x>)
- (object ^name <x> ^place <> holds)
- -->
- (remove 1)
- (write (crlf) |You're not holding it.|))
-
-(p name251
- (input light marijuana <x>)
- -->
- (remove 1)
- (make input smoke marijuana))
-
-
-(comment *******************FOOTBALL****************************************)
-
-(p name252
- (location ^name <x>)
- (object ^name football ^place <x>)
- -->
- (write (crlf) |There is an official NFL football here!|))
-
-(p name253
- (location ^name <x>)
- (object ^name football ^place held)
- (input kick football)
- -->
- (remove 3)
- (write (crlf) |Oh wow! You kick it around,|)
- (write (crlf) |luckily nothing breaks.|)
- (modify 2 ^place <x>))
-
-(p name254
- (location ^name <x>)
- (object ^name football ^place held)
- (input throw football)
- -->
- (remove 3)
- (write (crlf) |Throw is short.  Incomplete pass.  Fourth down, 10 to go.|)
- (modify 2 ^place <x>))
-
-(p name255
- (input <x> ball)
- -->
- (remove 1)
- (make input <x> football))
-
-
-(comment ***************************TIME************************************ )
-(p name256
- (input what time)
- (object ^name watch ^place held)
- (time ^realtime <x>)
- -->
- (remove 1)
- (write (crlf) |The time is| <x>))
-
-(p name257
- (location ^name <x>)
- (object ^name watch ^place <x>)
- -->
- (write (crlf) |There's a watch here, it even has a luminous dial.|))
-
-(p name258
- (input time)
- -->
- (remove 1)
- (make input what time))
-
-(p name259
- (input read watch)
- -->
- (remove 1)
- (make input what time))
-
-(p name260
- (input tell time)
- -->
- (remove 1)
- (make input what time))
-
-(p name261
- (x 10)
- (input what time)
- -->
- (remove 2)
- (write (crlf) |I have no watch.|))
-
-(p name262
- (input look at watch)
- -->
- (remove 1)
- (make input what time))
-
-(p name263
- (input put on watch)
- -->
- (remove 1)
- (make input get watch))
-
-(p name264
- (input wind watch)
- -->
- (remove 1)
- (write (crlf) |The watch is electric.|))
-
-(p name265
- (input open watch)
- -->
- (remove 1)
- (write (crlf) |The watch is sealed shut.|))
-
-(p name266
- (input break watch)
- -->
- (remove 1)
- (write (crlf) |The watch is shock resistent too.  It still works.|))
-
-(p name267
- (time ^realtime 0600 ^morning nil)
- -->
- (modify 1 ^morning t)
- (write (crlf) |'Cock-a-doodle-do'.  You hear a rooster crow.|))
-
-(p name268
- (time ^realtime 2000 ^morning t)
- -->
- (modify 1 ^morning nil)
- (write (crlf) |'Clunk!'  I think night just fell.|))
-
-(p name269
- (time ^realtime 0000 ^midnight nil)
- -->
- (modify 1 ^midnight t))
-
-(p name270
- (time ^midnight t)
- -->
- (modify 1 ^midnight nil)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |A moose comes running out of a wall at full speed straight at you!!!|)
- (write (crlf) |He is right on top of you!!! He runs right through you and disappears.|))
-
-(p name271
- (time ^midnight t)
- (location ^name lawn)
- -->
- (modify 1 ^midnight nil)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |A moose comes running across the lawn at full speed straight at you!!!|)
- (write (crlf) |He is right on top of you.  He runs right through you and disappears.|))
-
-
-(p name272
- (time ^midnight t)
- (location ^underwater t)
- -->
- (remove 1)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |BonG!|)
- (write (crlf) |A moose comes swimming out of the darkness, at full speed straight at you.|)
- (write (crlf) |He has on full scuba gear, and is really moving.|)
- (write (crlf) |He is right on top of you.  He runs right through you and disappears.|))
-
-
-(comment **************************PAINTING***************************)
-
-(p name273
- (input <x> art <y>)
- -->
- (remove 1)
- (make input <x> painting <y>))
-
-(p name274
- (location ^name <x>)
- (object ^name painting ^place <x> ^covered t)
- -->
- (write (crlf) |There is a work of ugly modern art on the ground.|))
-
-(p name275
- (location ^name <x>)
- (object ^name painting ^place <x> ^covered nil)
- -->
- (write (crlf) |There is a valuable Rembrandt here.|))
-
-(p name276
- (object ^name painting ^place held ^covered t)
- (object ^name bottle ^place held)
- (object ^name turpentine ^inside bottle)
- (input << clean pour >>)
- -->
- (modify 1 ^covered nil ^treasure t)
- (remove 3)
- (remove 4)
- (write (crlf) |The ugly paint comes off! Underneath is a Rembrandt|)
- (write (crlf) |This will be very valuable.|)
- (write (crlf) |It is a person and a bust in the painting.|))
-
-(p name277
- (location ^name <x>)
- (object ^name painting ^place <x> ^covered t)
- (object ^name bottle ^place held)
- (object ^name turpentine ^inside bottle)
- (input << clean pour >>)
- -->
- (modify 2 ^covered nil ^treasure t)
- (remove 4)
- (remove 5)
- (write (crlf) |The turpentine hits the painting and causes the paint to come off.|)
- (write (crlf) |The painting has a person contemplating a bust.|))
-
-(p name278
- (input remove paint)
- -->
- (remove 1)
- (make input clean))
-
-(p name279
- (object ^name painting ^place held ^covered t)
- -->
- (write (crlf) |Upon closer look, this is worthless!|))
-
-
-(comment *******************Money************************************* )
-
-(p name280
- (location ^name <x>)
- (object ^name money ^place <x>)
- -->
- (write (crlf) |The money is here!|))
-
-(comment *******************Stereo************************************* )
-
-(p name281
- (location ^name smelly_room)
- (object ^name stereo ^place held)
- (status ^sound on)
- -->
- (modify 3 ^sound off))
-
-(p name282
- (object ^name stereo ^place smelly_room)
- (location ^name smelly_room)
- (status ^sound on)
- (input turn off)
- -->
- (modify 3 ^sound off)
- (remove 4)
- (write (crlf) |The stereo is off.  But you broke it, so it won't turn on.|))
-
-(p name283
- (location ^name <x>)
- (object ^name stereo ^place <x>)
- -->
- (write (crlf) |There is an expensive stereo here, worth many megabucks!!|))
-
-
-(comment *******************Book****************************** )
-
-(p name284
- (location ^name <x>)
- (object ^name book ^place <x>)
- -->
- (write (crlf) |There is a book on the ground.|))
-
-(p name285
- (object ^name book ^place held)
- (input read book)
- -->
- (remove 2)
- (write (crlf) |Vampires can only be destroyed by a stake through the heart,|)
- (write (crlf) |or by the light of day.  They are invunerable to all other|)
- (write (crlf) |attacks.  They dislike garlic and fear crosses.  They are known|)
- (write (crlf) | to frequent dark rooms.|))
-
-(comment ************************GOLD************************)
-
-(p name286
- (location ^name <x>)
- (object ^name gold ^place <x>)
- -->
- (write (crlf) |There is gold here.|))
-
-
-(comment ************************HORN************************)
-
-(p name287
- (location ^name <x>)
- (object ^name horn ^place <x>)
- -->
- (write (crlf) |There is a magic unicorn horn here.|))
-
-(p name288
- (location ^name <x>)
- (object ^name horn ^place <x>)
- (object ^name horn ^place held)
- (input drop horn)
- -->
- (remove 3)
- (remove 4)
- (write (crlf) |When you drop the horn, it and the one on the ground merge together.|))
-
-(p name289
- (location ^name dining_room ^ontop stool)
- (object ^name horn ^place held)
- (input get horn)
- -->
- (remove 3)
- (write (crlf) |The horn won't come off.|))
-
-(p name290
- (object ^name horn ^place held)
- (input blow horn)
- (history ^clue nil)
- -->
- (remove 1)
- (remove 2)
- (write (crlf) |A terrific noise comes from the horn.  BLAT!!!|)
- (write (crlf) |The horn disappears from your hands.|)
- (write (crlf) |Your body shakes and you black out ......|)
- (modify 3 ^clue t))
-
-(p name291
- (history ^clue t ^grave_status undug)
- -->
- (write (crlf) |A spirit appears to you in your sleep.|)
- (write (crlf) |Your mind is filled with the following phrase:|)
- (write (crlf) |'As your family is sheep, the gold that is YOUR color must be found|)
- (write (crlf) |before you can escape this estate.' |)
- (modify 1 ^clue nil))
-
-(p name292
- (history ^clue t)
- -->
- (modify 1 ^clue nil)
- (write (crlf) |When you wake you see smoke form the words:|)
- (write (crlf) |EVERY OPTIon on A MACHINE HAS A PURPOSE.  The smoke then dissapates.|))
-
-(p name293
- (history ^clue t)
- (object ^name orchid ^place lawn)
- -->
- (write (crlf) |You dream of a garden of flowers.|)
- (modify 1 ^clue nil))
-
-(comment ************************Candlesticks************************)
-
-(p name294
- (input <x> them)
- -->
- (remove 1)
- (make input <x> candlesticks))
-
-(p name295
- (location ^name <x>)
- (object ^name candlesticks ^place <x>)
- -->
- (write (crlf) |There is a pair of silver candlesticks here!! No candles though.|))
-
-(p name296
- (object ^name candlesticks ^place held)
- (input form cross)
- -->
- (modify 1 ^state crossed)
- (remove 2)
- (write (crlf) |The candlesticks are in a cross.|))
-
-(p name297
- (object ^name candlesticks ^place held)
- (input make cross)
- -->
- (modify 1 ^state crossed)
- (remove 2)
- (write (crlf) |The candlesticks are in a cross.|))
-
-(p name298
- (location ^name <x>)
- (object ^name candlesticks ^place held ^state crossed)	
- (input drop candlesticks)
- -->
- (modify 2 ^place <x> ^state nil)
- (remove 3))
-
-(p name299
- (input << make form >> cross)
- -->
- (remove 1)
- (write (crlf) |You have nothing to form a cross with, arms don't work.|))
-
-(p name300
- (input cross candlesticks)
- -->
- (remove 1)
- (make input make cross))
-
-(comment *********************CHAIR*************************************)
-(p name301
- (location ^name <x>)
- (object ^name chair ^place <x>)
- -->
- (write (crlf) |There is an old style chair on the ground.|))
-
-(p name302
- (object ^name chair ^place held)
- -->
- (write (crlf) |The plate of the back of the chair says 'MADE BY LOUIS XIV'|))
-
-(p name303
- (location ^name <x>)
- (object ^name chair ^place <x>)
- (input mount chair)
- -->
- (remove 2)
- (remove 3)
- (write (crlf) |The priceless chair breaks under your weight.|)
- (write (crlf) |It then disappears.|))
-
-(p name304
- (location ^name <x>)
- (object ^name chair ^place <x>)
- (input sit on chair)
- -->
- (remove 2)
- (remove 3)
- (write (crlf) |You sat on the chair and it broke!|)
- (write (crlf) |It disappears.|))
-
-
-(comment **********************STOOL*************************************)
-
-(p name305
- (location ^name <x>)
- (object ^name stool ^place <x>)
- -->
- (write (crlf) |There is a sturdy stool here.|))
-
-(p name306
- (location ^name <x>)
- (object ^name stool ^place <x>)
- (input sit)
- -->
- (remove 3)
- (modify 1 ^siton stool)
- (write (crlf) |You're sitting on the stool.|))
-
-(p name307
- (object ^name stool ^place held)
- (input sit)
- -->
- (remove 2)
- (write (crlf) |I suggest you drop the stool first.|))
-
-(p name308
- (location ^name <x>)
- (object ^name stool ^place <x>)
- (input mount stool)
- -->
- (modify 1 ^siton stool)
- (remove 3)
- (write (crlf) |You are on the stool.|))
-
-(p name309
- (input climb stool)
- -->
- (remove 1)
- (make input mount stool))
-
-(comment ****************Additional objects********************)
-
-(comment ****Chest**** )
-
-(p name310
- (location ^name <x>)
- (object ^name chest ^place <x>)
- -->
- (write (crlf) |There is a chest of treasure!!!|))
-
-(p name311
- (object ^name chest ^place held)
- (input open chest)
- -->
- (remove 2)
- (write (crlf) |Give up, the chest doesn't open, but is worth gigabucks the way it is.|))
-
-(comment ****Conch**** )
-
-(p name312
- (object ^name conch ^place held)
- (input blow conch)
- -->
- (remove 2)
- (write (crlf) |'Hoooonk!'|))
-
-(p name313
- (object ^name conch ^place <x>)
- (location ^name <x>)
- -->
- (write (crlf) |There is a large conch shell here.|))
-
-(p name314
- (input <x> shell)
- -->
- (remove 1)
- (make input <x> conch))
-
-(p name315
- (object ^name conch ^place held)
- (input listen conch)
- -->
- (remove 1)
- (write (crlf) |You hear the ocean 'rumble'.|))
-
-(p name316
- (location ^name <x>)
- (object ^name token ^place <x>)
- -->
- (write (crlf) |There is a token here.|))
-
-(p name317
- (location ^name <x>)
- (object ^name tokens ^place <x>)
- -->
- (write (crlf) |There are tokens here.|))
-
-(p name318
- (input bite <x>)
- (object ^name <x> ^place held)
- -->
- (remove 1)
- (write (crlf) |The| <x>  |bites back, Chomp!!|))
-
-(p name319
- (x 10)
- (input bite)
- -->
- (remove 2)
- (write (crlf) |You must be holding what you are trying to bite.|))
-
-(p name0320
- (object ^name <x> ^treasure t ^place held ^scored nil)
- (status ^score <y>)
- -->
- (modify 2 ^score (compute <y> + 15))
- (modify 1 ^scored t))
-
-(p name0321
- (object ^name bottle ^place lawn)
- (object ^name water ^inside bottle ^xscore nil)
- (status ^score <y>)
- -->
- (modify 3 ^score (compute 5 + <y>))
- (modify 2 ^xscore t))
-
-(p name0322
- (input pour)
- (object ^name bottle ^place held)
- (object ^name water ^xscore t)
- (status ^score <z>)
- -->
- (remove 1)
- (modify 4 ^score (compute <z> - 5)))
-
-(p name0323
- (object ^name <x> ^place lawn ^treasure t ^xscore nil)
- (status ^score <y>)
- -->
- (modify 2 ^score (compute 5 + <y>))
- (modify 1 ^name <x> ^xscore t))
-
-(p name0324
- (object ^name <x> ^xscore t ^place held)
- (status ^score <y>)
- -->
- (modify 1 ^xscore nil)
- (modify 2 ^score (compute <y> - 5)))
-
-(p name321
- (input score)
- (status ^score <x>)
- -->
- (write (crlf) |Score =| <x>)
- (remove 1))
-
-(p name322
- (status ^quit t ^score <x>)
- -->
- (write (crlf) |Your final score is| <x>)
- (write (crlf) |The total possible is 440|)
- (make turnoff))
-
-(p name323
- (turnoff)
- (status ^score < 20)
- -->
- (write (crlf) |Hmm...  I don't think you tried very hard.|))
-
-(p name324
- (turnoff)
- -->
- (halt))
-
-(p name325
- (turnoff)
- (status ^score {< 50 > 21})
- -->
- (write (crlf) |Rank Novice! Are you scared of your own shadow?|))
-
-(p name326
- (turnoff)
- (status ^score {> 51 < 80})
- -->
- (write (crlf) |Beginning Ghost Hunter|))
-
-(p name327
- (turnoff)
- (status ^score {> 81 < 140})
- -->
- (write (crlf) |Reasonable Spirit Fighter|))
-
-(p name328
- (turnoff)
- (status ^score {> 141 < 220})
- -->
- (write (crlf) |Intermediate Haunt Hacker|))
-
-(p name329
- (turnoff)
- (status ^score {> 221 < 290})
- -->
- (write (crlf) |Advanced Monster Killer|))
-
-(p name330
- (turnoff)
- (status ^score {> 291 < 360})
- -->
- (write (crlf) |Master Haunter!!|))
-
-(p name331
- (turnoff)
- (status ^score > 361)
- -->
- (write (crlf) |Fearless Vampire Killer|))
-
-(p name332
- (status ^likes  <x>)
- (turnoff)
- (status ^score > 435)
- -->
- (write (crlf) |and waster of many cycles.|))
-
-(p name333
- (location ^name <x>)
- (object ^name pearls ^place <x>)
- -->
- (write (crlf) |There are huge pearls here!!|))
-
-(p name334
- (location ^name <x>)
- (object ^name diamonds ^place <x>)
- -->
- (write (crlf) |There are diamonds here!|))
-
-(p name335
- (location ^name <x>)
- (object ^name orchid ^place <x> ^state plant)
- -->
- (write (crlf) |There is a beautiful black orchid here.|))
-
-(p name336
- (location ^name <x>)
- (object ^name orchid ^place <x> ^state plant)
- (input smell <y>)
- -->
- (remove 3)
- (write (crlf) |Yum! The orchid smells delicious!|))
-
-(p name337
- (object ^name orchid ^place held)
- (input smell orchid)
- -->
- (remove 2)
- (write (crlf) |I like the odor! Sniff.  Sniff.|))
-
-(p name338
- (input pick orchid)
- -->
- (remove 1)
- (make input get orchid))
-
-(p name339
- (input smell <x>)
- -->
- (remove 1)
- (write (crlf) |Ah CHOOOO! There is alot of dust around here.|))
-
-(p name340
- (input sniff <x>)
- -->
- (remove 1)
- (make input smell <x>))
-
-(p name341
- (location ^name <x>)
- (object ^name rope ^place <x> ^tied noose)
- -->
- (write (crlf) |There is rope in a noose here.|))
-
-(p name342
- (location ^name <x>)
- (object ^name rope ^place <x> ^tied untied)
- -->
- (write (crlf) |There is some loose rope here.|))
-
-(p name343
- (location ^name <x>)
- (object ^name <y> ^place <x>)
- (object ^name rope ^place <> <x> ^tied <y>)
- -->
- (write (crlf) |A rope is tied to the| <y> ))
-
-(p name344
- (location ^name <x>)
- (object ^name <y> ^place <> <x>)
- (object ^name rope ^place <x> ^tied <y>)
- -->
- (write (crlf) |An end of a rope is here.|))
-
-(p name345
- (location ^name <x>)
- (object ^name rope ^place <x> ^tied <y>)
- (object ^name <y> ^place <x>)
--->
- (write (crlf) |An end of the rope is here, tied to the | <y> ))
-
-(p name346
- (location ^name <x>)
- (object ^name rope ^place <x> ^tied <y>)
- (object ^name <y> ^place held)
--->
- (write (crlf) |A rope tied to the| <y> |is here.|))
-
-(p name347
- (object ^name rope ^place held ^tied noose)
- (input untie rope)
- -->
- (modify 1 ^tied untied)
- (remove 2)
- (write (crlf) |The rope is now untied.|))
-
-(p name348
- (object ^name rope ^tied noose)
- (input hang <x>)
- -->
- (remove 2)
- (write (crlf) |No hanging around here.|))
-
-(p name349
- (object ^name rope ^place held ^tied noose)
- (input tie rope <x>)
- -->
- (remove 2)
- (write (crlf) |The rope is already in knots.|))
-
-(p name350
- (object ^name rope ^place held)
- (input tie <x>)
- -->
- (remove 2)
- (write (crlf) |Look, don't tie| <x> |, tie rope to something you have on you.|))
-
-(p name351
- (object ^name rope ^place held)
- (input tieup <x>)
- -->
- (remove 2)
- (make input tie rope to <x>))
-
-(p name352
- (object ^name rope ^place held ^tied untied)
- (object ^name <x> ^place held)
- (input tie rope to <x>)
- -->
- (modify 1 ^tied <x>)
- (remove 3)
- (write (crlf) |The rope is tied to| <x>  |.|))
-
-(p name353
- (object ^name rope ^place held ^tied <z>)
- (input tie rope to <x>)
- -->
- (remove 2)
- (write (crlf) |The rope is already tied to the| <z> )
- (write (crlf) |I can tie the rope to only one object at a time.|))
-
-(p name354
- (location ^name <y>)
- (object ^name <x> ^place <y>)
- (object ^name rope ^place <> held ^tied <x>)
- (input get <x>)
- -->
- (modify 3 ^place held)
- (write (crlf) |You get the rope first and then ...|))
-
-(p name355
- (location ^name <y>)
- (object ^name <x> ^place held)
- (object ^name rope ^place <> held ^tied <x>)
- (input get rope)
- -->
- (modify 3 ^place held)
- (remove 4)
- (write (crlf) |You just pulled in the rest of the rope.|))
-
-(p name356
- (location ^name <Z>)
- (object ^name rope ^place held)
- (object ^name cecil ^place <Z>)
- (input tie rope to cecil)
- -->
- (remove 4)
- (write (crlf) |You can't tie cecil down!|))
-
-(p name357
- (location ^name laboratory)
- (object ^name rope ^place held)
- (input tie rope to monster)
- -->
- (remove 3)
- (write (crlf) |That would be very foolish.|))
-
-(p name358
- (location ^name <Z>)
- (object ^name rope ^place held ^tied untied)
- (object ^name dracula ^place <Z>)
- (input tie rope to dracula)
- -->
- (remove 4)
- (write (crlf) |You can't get Dracula, not to mention tie him up.|))
-
-(p name359
- (input tie rope to {<< candy marijuana cube orchid >> <x>} )
- (object ^name rope ^place held ^tied untied)
- (object ^name <x> ^place held)
- -->
- (remove 1)
- (write (crlf) |That is too small for the rope to be tied to.|))
-
-(p name360
- (input lasso <x>)
- -->
- (remove 1)
- (make input tie rope to <x>))
-
-(p name361
- (object ^name rope ^place held ^tied untied)
- (input tie rope to rope)
- -->
- (modify 1 ^tied noose)
- (remove 2)
- (write (crlf) |The rope is tied in knots.|))
-
-(p name362
- (location ^name torture_chamber)
- (status ^likes  <x>)
- (object ^name rope ^place held)
- (object ^name damsel ^state free)
- (input tie rope to <x>)
- -->
- (remove 5)
- (make input torture damsel))
-
-(p name363
- (location ^name <x>)
- (object ^name rope ^place held)
- (object ^name chest ^place <x>)
- (object ^name octopus ^alive t)
- (input tie rope to chest)
- -->
- (remove 5)
- (write (crlf) |The octopus blocks your way.|))
-
-(p name364
- (object ^name rope ^place held)
- (input tie rope to <x>)
- -->
- (remove 2)
- (write (crlf) |Either you aren't holding | <x>  |, or I can't tie the rope to it.|))
-
-(p name365
- (object ^name rope ^place <> held)
- (input tie rope to <z>)
- -->
- (remove 2)
- (write (crlf) |You don't have the rope.|))
-
-(p name366
- (input untie rope)
- (object ^name rope ^tied <x>)
- (object ^name <x> ^place held)
--->
- (remove 1)
- (modify 2 ^tied untied)
- (write (crlf) |The rope is no longer tied to| <x>  |.|))
-
-(p name367
- (input pull rope)
- (object ^name rope ^place held ^tied <x>)
- (object ^name <x>)
--->
- (write (crlf) |Umph! You just pulled in the| <x>  |.|)
- (remove 1)
- (modify 3 ^place held))
-
-(p name368x5
- (input pull rope)
- (object ^name rope ^tied <x>)
- (object ^name <x> ^place held)
- -->
- (remove 1)
- (modify 2 ^place held)
- (write (crlf) |You now have all the rope.|))
-
-(p name368
- (input untie rope)
- (object ^name rope ^tied untied)
- -->
- (remove 1)
- (write (crlf) |The rope isn't tied to anything.|))
-
-(p name369
- (input untie rope)
- (object ^name rope ^tied <x>)
- (object ^name <x> ^place <y>)
- -->
- (remove 1)
- (write (crlf) |The rope is tied to the| <x> |, which you aren't holding.|))
-
-(p name370
- (location ^name bathysphere)
- (input pull rope)
- (object ^name rope ^tied <x>)
- (object ^name <x> ^place ocean)
- (portal ^name wdoor ^door closed)
- -->
- (remove 2)
- (write (crlf) |The airlock door is closed on the rope.|))
-
-(p name371
- (location ^name <x>)
- (object ^name wetsuit ^place <x>)
- -->
- (write (crlf) |There is a wetsuit, with everything needed to survive (location ^underwater t).|))
-
-(p name372
- (input << don wear >> <x>)
- -->
- (remove 1)
- (make input put on <x>))
-
-(p name373
- (location ^name <x>)
- (object ^name wetsuit ^place <x>)
- (input put on wetsuit)
- -->
- (modify 2 ^place held))
-
-(p name374
- (object ^name wetsuit ^place held)
- (input put on wetsuit)
- -->
- (modify 1 ^wears t)
- (remove 2)
- (write (crlf) |You are wearing a wetsuit.|))
-
-(p name375
- (object ^name wetsuit ^wears t)
- (input << remove doff >> wetsuit)
--->
- (modify 1 ^wears nil)
- (remove 2)
- (write (crlf) |Your wetsuit is in your arms.|))
-
-(p name376
- (location ^name <x>)
- (input drop wetsuit)
- (object ^name wetsuit ^place held ^wears t)
- -->
- (remove 2)
- (modify 3 ^wears nil ^place <x>))
-
-(p name377
- (location ^name <x>)
- (object ^name speargun ^place <x>)
- -->
- (write (crlf) |There is a speargun that shoots underwater.|))
-
-(p name378
- (location ^name <x>)
- (object ^name speargun ^place <x> ^state loaded)
--->
- (write (crlf) |The speargun is loaded, ready to fire.|))
-
-(p name379
- (location ^name <x>)
- (object ^name speargun ^place held ^state loaded)
- (location ^underwater nil)
- (input shoot)
- (status)
- -->
- (modify 2 ^state unloaded)
- (remove 4)
- (write (crlf) |The gun goes off.  BRRRANG!!|)
- (write (crlf) |The backlash from the speargun snaps your neck!|)
- (modify 5 ^quit t))
-
-(p name380
- (object ^name speargun ^place held ^state unloaded)
- (input shoot speargun)
- -->
- (remove 2)
- (write (crlf) |The gun isn't loaded with a spear!|))
-
-(p name381
- (object ^name speargun ^place held ^state unloaded)
- (object ^name spear ^place held)
- (input load)
- -->
- (write (crlf) |The gun is now loaded.|)
- (modify 1 ^state loaded))
-
-(p name382
- (location ^name <x>)
- (object ^name spear ^place <x>)
- -->
- (write (crlf) |There is a speargun spear here.|))
-
-(p name383
- (input <x> gun)
- -->
- (remove 1)
- (make input <x> speargun))
-
-(p name384
- (input << pres p depress push >> <x>)
- -->
- (remove 1)
- (make input press <x>))
-
-(p name385
- (location ^name <x>)
- (object ^name coins ^place <x>)
- -->
- (write (crlf) |You see many coins here!|))
-
-(p name386
- (location ^name <x>)
- (object ^name bone ^place <x>)
- -->
- (write (crlf) |There is a bone here that you identify as from the MISSING LINK!|))
-
-(p name387
- (location ^name <x>)
- (object ^name soap ^place <x>)
- -->
- (write (crlf) |There is a bar of soap here.|))
-
-(p name388
- (location ^name <x>)
- (object ^name gem ^place <x>)
- -->
- (write (crlf) |There is a valuable gem here.|))
-
-(p name396
- (location ^name <x>)
- (object ^name jade ^place <x>)
- -->
- (write (crlf) |There is a piece of valuable jade here.|))
-
-(p name397
- (input why <x>)
- -->
- (remove 1)
- (write (crlf) |Hey, I don't know.|)
- (write (crlf) |Send mail to Laird@cmua if you have questions.|))
-
-(p name398
- (input eat orchid)
- (object ^name orchid ^place held)
- -->
- (remove 1)
- (remove 2)
- (write (crlf) |Chomp! chomp.  I don't think your real family had a taste for orchids.|)
- (write (crlf) |It looks like you aren't one of those that knows how to digest orchids.|))
-
-(p name399
- (input eat orchid)
- (status ^name <x> St |.| John)
- (object ^name orchid ^place held)
- -->
- (remove 1)
- (remove 2)
- (remove 3)
- (write (crlf) |An orchid a day keeps the crazies away!|)
- (make command ^string eat_it))
-
-(p name400
- (location ^name <x>)
- (object ^name orchid ^place <x>)
- (input eat orchid)
- -->
- (make input get orchid))
-
-(p name401
- (input say <x>)
- -->
- (remove 1)
- (make input <x>)
- (write (crlf) |You can just type| <x> )
- (write (crlf) |and I'll try and understand| <x>  |right now.|))
-
-(p name402
- (input << scream shout yell >> <x>)
- -->
- (write (crlf) |'| <x> |!!'|)
- (remove 1)
- (write (crlf) |I don't think anybody is listening.|))
-
-(p name403
- (input hello)
- -->
- (remove 1)
- (write (crlf) |Your greeting is met with silence.|))
-
-(p name404
- (input fly)
- -->
- (remove 1)
- (write (crlf) |You flap your arms, but nothing happens.|))
-
-(p name405
- (input afihywn)
- -->
- (remove 1)
- (write (crlf) |Hmm, is that Australian?|))
-
-(p name1009
- (location ^name bus_stop)
- -->
- (write (crlf) |We are at an intersection of two streets going n-s and e-w.|)
- (write (crlf) |There is a bus stop here.|)
- (write (crlf) |To the west a bus is pulling away from the next bus stop.|))
-
-(p name1010
- (location ^name bus_stop)
- (status ^going <> nil)
- (time ^realtime <x> ^btime <y>)
- -->
- (modify 1 ^name bus_stop)
- (modify 2 ^going nil)
- (modify 3 ^btime (compute <x> + 16)))
-
-(p name1011
- (location ^name bus_stop)
- (time ^realtime <x> ^btime <x>)
- (history ^bus_stopped nil)
- -->
- (modify 3 ^bus_stopped t))
-
-(p name1012
- (location ^name bus_stop)
- (history ^bus_stopped t)
- -->
- (write (crlf) |A bus has stopped in front of us.|))
-
-(p name1013
- (input wait)
- -->
- (write (crlf) |La dee da.|)
- (remove 1))
-
-(p name1014
- (input wait)
- (location ^name bus_stop)
- (history ^bus_stopped nil)
- -->
- (remove 1)
- (modify 3 ^bus_stopped t)
- (write (crlf) |Yawn!|))
-
-(p name1015
- (input << mount board >>)
- (location ^name bus_stop)
- -->
- (remove 1)
- (make input enter bus))
-
-(p name1016
- (input enter)
- (location ^name bus_stop)
- (history ^bus_stopped t)
- (object ^name tokens ^place held)
- -->
- (remove 1)
- (modify 2 ^name on_bus)
- (modify 3 ^bus_stopped nil)
- (remove 4)
- (make object ^name token ^place held))
-
-(p name1017
- (input enter)
- (location ^name bus_stop)
- (history ^bus_stopped t)
- (object ^name token ^place held)
- -->
- (remove 1)
- (modify 2 ^name on_bus)
- (modify 3 ^bus_stopped nil)
- (remove 4))
-
-(p name1018
- (location ^name bus_stop)
- (input take ride)
- -->
- (remove 1)
- (make input enter bus))
-
-(p name1019
- (location ^name bus_stop)
- (history ^bus_stopped t)
--(object ^name tokens)
--(object ^name token)
- (status)
- (input enter <x>)
- -->
- (remove 4)
- (write (crlf) |You don't have any tokens.  You sit on the corner and starve to death.|)
- (modify 3 ^quit t))
-
-(p name1020
- (location ^name bus_stop)
- (history ^bus_stopped t)
- (input enter)
- (object ^name token ^place bus stop)
- -->
- (remove 3)
- (write (crlf) |The bus doors remain closed.|))
-
-(p name1021
- (location ^name bus_stop)
- (history ^bus_stopped t)
- (input enter)
- (object ^name tokens ^place bus stop)
--->
- (remove 3)
- (write (crlf) |You stumble over some tokens and bang your head on the bus.|))
-
-(p name1022
- (location ^name on_bus)
- -->
- (modify 1 ^name bus)
- (make place bus ^visited t)
- (write (crlf) |As you find your seat, you notice the bus is empty.|)
- (write (crlf) |There isn't even a driver.  But before you can change your mind,|)
- (write (crlf) |the bus starts up and drives away from the intersection.|)
- (write (crlf) |Va Vooooom!|)
- (write (crlf) |Looking out the window you see many intersections flash by.|)
- (write (crlf) | |)
- (write (crlf) |After a while the intersections get farther apart.|)
- (write (crlf) |The bus is now in the outskirts of town.|)
- (write (crlf) |The bus comes up to an old mansion with a high gate surrounding it and stops.|)
- (write (crlf) |A voice comes over the speaker: 'ALL OUT, END OF THE LINE.'|))
-
-(p name1023
- (location ^name bus)
- (place ^name bus ^visited nil)
- -->
- (write (crlf) | |)
- (write (crlf) |You are in a bus.  There isn't a driver and the exit doors are open.|))
-
-(p name1024
- (location ^name bus)
- (input get off <x>)
- -->
- (remove 2)
- (make input exit))
-
-(p name1025
- (location ^name bus)
- (input << leave depart disembark >>)
- -->
- (remove 2)
- (make input exit))
-
-(p name1026
- (location ^name bus)
- (input exit <x>)
- -->
- (remove 2)
- (modify 1 ^name lawn ^side out ^east 5 ^north 2)
- (write (crlf) |The bus drives off as you get off.|))
-
-(p name1027
- (location ^name bus)
- (input get out <x>)
- -->
- (remove 2)
- (make input exit))
-
-(p name1028
- (location ^name bus_stop)
- (input << chase follow catch >> bus)
- (status)
- -->
- (remove 2)
- (write (crlf) |I'm assuming that means GO WEST.|)
- (modify 3 ^going w went w))
-
-(p name1029
- (location ^name bus_stop)
- (time ^realtime 2226)
- -->
- (write (crlf) |Hint: patience is a virtue.|))
-
-(p name1030
- (location ^name bus)
- (input hijack bus)
- -->
- (remove 2)
- (write (crlf) |Sorry, this bus doesn't go to Cuba, that's another line.|))
-
-(p name1031
- (location ^name bus)
- (input <x> driver)
- -->
- (remove 2)
- (write (crlf) |There isn't a driver on this bus.|))
-
-(p name1032
- (location ^name bus)
- (input drive bus)
- -->
- (remove 2)
- (write (crlf) |I'm sorry but you don't have a chauffeur's license.|))
-
-(p name1033
- (location ^name bus)
- (input <x> bus)
- -->
- (remove 2)
- (write (crlf) |Give up and get off the bus.|))
-
-(p name1034
- (location ^name bus_stop)
- (input hail bus)
- -->
- (remove 2)
- (write (crlf) |The bus does not stop for you.|))
-
-(p name1035
- (location ^name lawn ^side out ^east {<< 2 3 4 5 6 7 >> <C>}
-	   ^north << 1 2 8 >>)
- (status ^going e)
- -->
- (modify 2 ^going nil)
- (modify 1 ^east (compute 1 + <C>)))
-
-(p name01035
- (location ^name lawn ^side out ^east 1)
- (status ^going e)
- -->
- (modify 2 ^going nil)
- (modify 1 ^east 2))
-
-(p name1036
- (location ^name lawn ^side out ^east << 1 2 8 >> 
-	   ^north {<< 2 3 4 5 6 7 >> <N>})
- (status ^going n)
- -->
- (modify 2 ^going nil)
- (modify 1 ^north (compute 1 + <N>)))
-
-(p name001036
- (location ^name lawn ^side out ^north 1)
- (status ^going n)
- -->
- (modify 2 ^going nil)
- (modify 1 ^north 2))
-
-(p name1037
- (location ^name lawn ^side out ^east << 1 2 8 >>
-	   ^north {<< 3 4 5 6 7 8 >> <N>})
- (status ^going s)
- -->
- (modify 2 ^going nil)
- (modify 1 ^north (compute <N> - 1)))
-
-(p name01037
- (location ^name lawn ^side out ^north 2)
- (status ^going s)
- -->
- (modify 2 ^going nil)
- (modify 1 ^north 1))
-
-(p name1038
- (location ^name lawn ^side out ^east {> 2 <E>} ^north << 1 2 8 >>)
- (status ^going w)
- -->
- (modify 2 ^going nil)
- (modify 1 ^east (compute <E> - 1)))
-
-(p name01038
- (location ^name lawn ^side out ^east 2)
- (status ^going w)
- -->
- (modify 2 ^going nil)
- (modify 1 ^east 1))
-
-(p name1039
- (location ^name lawn ^side out ^east 1 ^north <> 1)
- (status ^going w)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The woods are too dense to penetrate.|))
-
-(p name1041
- (location ^name lawn ^side out ^east 1 ^north 1)
- (status ^going w)
- -->
- (modify 2 ^going nil)
- (modify 1 ^name bus_stop))
-
-(p name1043
- (location ^name lawn ^side out ^east 8 ^north 1)
- (status ^going e)
- -->
- (modify 2 ^going nil)
- (modify 1 ^name bus_stop))
-
-(p name1044
- (location ^name lawn ^side out ^east 8 ^north <> 1)
- (status ^going e)
- -->
- (modify 2 ^going nil)
- (write (crlf) |You are unable to penetrate into the woods.|))
-
-(p name1045
- (location ^name lawn ^side out ^north 1)
- (status ^going s)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The forest can not be penetrated.|))
-
-(p name1046
- (location ^name lawn ^side out ^north 8)
- (status ^going n)
- -->
- (modify 2 ^going nil)
- (write (crlf) |Penetration into the forest is impossible|))
-
-(p name1047
- (location ^name lawn ^side out ^east << 3 4 5 6 7 >> ^north 2)
- (status ^going n)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The wall prevents passage to the north.|))
-
-(p name1049
- (location ^name lawn ^side out ^east << 3 4 5 6 7 >> ^north 8)
- (status ^going s)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The wall is in the way.|))
-
-(p name1051
- (location ^name lawn ^side out ^east << 3 4 5 6 7 >> ^north 8)
- -->
- (write (crlf) |You're on the north border of a wall, on the outside.|))
-
-(p name1053
- (location ^name lawn ^side out ^east  << 3 4 5 6 7 >> ^north 2)
- -->
- (write (crlf) |To the north is the wall that surrounds CHEZ MOOSE.|)
- (write (crlf) |To the south is a road.|))
-
-(p name1055
- (location ^name lawn ^side out ^north  << 3 4 5 6 7 >> ^east 2)
- -->
- (write (crlf) |To the west is a thick forest, and to the east is a wall.|))
-
-(p name1056
- (location ^name lawn ^side out ^east 8 ^north  << 3 4 5 6 7 >>)
- -->
- (write (crlf) |To the east is a dark forest, and to the west is a high wall.|))
-
-(p name1060
- (location ^name lawn ^side out ^east 2 ^north  << 3 4 5 6 7 >>)
- (status ^going e)
- -->
- (modify 2 ^going nil)
- (write (crlf) |Ahh, there is the big wall in the way.|))
-
-(p name1061
- (location ^name lawn ^side out ^east 8 ^north  << 3 4 5 6 7 >>)
- (status ^going w)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The wall is in the way.|))
-
-(p name1074
- (location ^name lawn ^side out ^north 1)
- -->
- (write (crlf) |You are on the road, to the south is a forest.|))
-
-(p name1075
- (location ^name lawn ^side out ^east 1 ^north > 1)
- -->
- (write (crlf) |You are in a forest.|))
-
-(p name1098
- (location ^name lawn ^side out ^east 5 ^north 2)
- -->
- (write (crlf) |To the north is a gate in a wall.|)
- (write (crlf) |Further north a huge mansion looms.|)
- (write (crlf) | |)
- (write (crlf) |Lights from inside illuminate the surrounding estate.|)
- (write (crlf) |The gate is inoperable, and you won't be able to open it.|))
-
-(p name1114
- (location ^name lawn ^side out ^east 2 ^north 2)
- -->
- (write (crlf) |This is the sw corner of the wall.|))
-
-(p name1115
- (location ^name lawn ^side out ^east 8 ^north 2)
- -->
- (write (crlf) |This is the se corner of the wall.  You can go n, s, e or w.|))
-
-(p name1116
- (location ^name lawn ^side out ^east 8 ^north 8)
- -->
- (write (crlf) |This is the ne corner of the wall.|))
-
-(p name1117
- (location ^name lawn ^side out ^east 2 ^north 8)
- -->
- (write (crlf) |This is the nw corner of the wall.|))
-
-(comment inside)
-
-(p name1140
- (location ^name lawn ^side in ^east << 2 3 4 6 7 8 >> 
-	   ^north { < 8 <N>})
- (status ^going n)
- -->
- (modify 2 ^going nil)
- (modify 1 ^north (compute 1 + <N>) ^general nil))
-
-(p name1141
- (location ^name lawn ^side in ^east 5 
-	   ^north { << 2 3 6 7 >> <N>})
- (status ^going n)
- -->
- (modify 2 ^going nil)
- (modify 1 ^north (compute 1 + <N>) ^general nil))
-
-(p name1142
- (location ^name lawn ^side in ^east << 2 3 4 6 7 8 >> 
-	   ^north { > 2 <N>})
- (status ^going s)
- -->
- (modify 2 ^going nil)
- (modify 1 ^north (compute <N> - 1) ^general nil))
-
-(p name1143
- (location ^name lawn ^side in ^east 5 
-	   ^north { << 3 4 7 8 >> <N>})
- (status ^going s)
- -->
- (modify 2 ^going nil)
- (modify 1 ^north (compute <N> - 1) ^general nil))
-
-(p name1150
- (location ^name lawn ^side in ^north << 2 3 4 6 7 8 >> 
-	   ^east { < 8 <N>})
- (status ^going e)
- -->
- (modify 2 ^going nil)
- (modify 1 ^east (compute 1 + <N>) ^general nil))
-
-(p name1151
- (location ^name lawn ^side in ^north 5 
-	   ^east { << 2 3 6 7 >> <N>})
- (status ^going e)
- -->
- (modify 2 ^going nil)
- (modify 1 ^east (compute 1 + <N>) ^general nil))
-
-(p name1152
- (location ^name lawn ^side in ^north << 2 3 4 6 7 8 >> 
-	   ^east { > 2 <N>})
- (status ^going w)
- -->
- (modify 2 ^going nil)
- (modify 1 ^east (compute <N> - 1) ^general nil))
-
-(p name1153
- (location ^name lawn ^side in ^north 5 
-	   ^east { << 3 4 7 8 >> <N>})
- (status ^going w)
- -->
- (modify 2 ^going nil)
- (modify 1 ^east (compute <N> - 1) ^general nil))
-
-(p name1048
- (location ^name lawn ^side in ^north 2)
- (status ^going s)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The wall won't let you go south.|))
-
-(p name1050
- (location ^name lawn ^side in ^north 8)
- (status ^going n)
- -->
- (modify 2 ^going nil)
- (write (crlf) |Hey, the wall is north.|))
-
-(p name1052
- (location ^name lawn ^side in ^north 8)
- -->
- (write (crlf) |You're on the inside of north border of a wall.|))
-
-(p name1054
- (location ^name lawn ^side in ^north 2)
- -->
- (write (crlf) |A wall is to the south.|))
-
-(p name1057
- (location ^name lawn ^side in ^east 8)
- -->
- (write (crlf) |To the east is a wall.|))
-
-(p name1058
- (location ^name lawn ^side in ^east 2)
- -->
- (write (crlf) |To the west is a wall.|))
-
-(p name1059
- (location ^name lawn ^side in ^east 2)
- (status ^going w)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The wall blocks your way.|))
-
-(p name1062
- (location ^name lawn ^side in ^east 8)
- (status ^going e)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The wall is in the way.|))
-
-(p name1063
- (location ^name lawn ^side in ^east 4 ^north 4)
- -->
- (write (crlf) |You are at the sw corner of the house.|))
-
-(p name1064
- (location ^name lawn ^side in ^east 6 ^north 4)
- -->
- (write (crlf) |You are at the se corner of the house.|))
-
-(p name1065
- (location ^name lawn ^side in ^east 4 ^north 5)
- -->
- (write (crlf) |You are on the west side of the house.|))
-
-(p name1066
- (location ^name lawn ^side in ^east 4 ^north 6)
- -->
- (write (crlf) |This is the north-west corner of the house.|))
-
-(p name1067
- (location ^name lawn ^side in ^east 5 ^north 6)
- -->
- (write (crlf) |This is the north side of the house.|))
-
-(p name1068
- (location ^name lawn ^side in ^east 6 ^north 6)
- -->
- (write (crlf) |This is the north east corner of the mansion.|))
-
-(p name1069
- (location ^name lawn ^side in ^east 6 ^north 5)
- -->
- (write (crlf) |This is the east side of the house.|))
-
-(p name1070
- (location ^name lawn ^side in ^east 6 ^north 5)
- (status ^going w)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The house is in the way.|))
-
-(p name1071
- (location ^name lawn ^side in ^east 4 ^north 5)
- (status ^going e)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The house is in the way.|))
-
-(p name1072
- (location ^name lawn ^side in ^east 5 ^north 4)
- (status ^going n)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The house is in the way.|))
-
-(p name1073
- (location ^name lawn ^side in ^east 5 ^north 6)
- (status ^going s)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The house is in the way.|))
-
-(p name1076
- (location ^name lawn ^side in ^east 3 ^north 3 ^general nil)
- -->
- (modify 1 ^general lawns))
-
-(p name1077
- (location ^name lawn ^side in ^east 4 ^north 3 ^general nil)
- -->
- (modify 1 ^general lawns))
-
-(p name1078
- (location ^name lawn ^side in ^east 6 ^north 3 ^general nil)
- -->
- (modify 1 ^general lawns))
-
-(p name1079
- (location ^name lawn ^side in ^east 7 ^north 3 ^general nil)
- -->
- (modify 1 ^general lawns))
-
-(p name1080
- (location ^name lawn ^side in ^east 7 ^north 4 ^general nil)
- -->
- (modify 1 ^general lawns))
-
-(p name1081
- (location ^name lawn ^side in ^east 7 ^north 7 ^general nil)
- -->
- (modify 1 ^general lawns))
-
-(p name1082
- (location ^name lawn ^side in ^east 6 ^north 7 ^general nil)
- -->
- (modify 1 ^general lawns))
-
-(p name1083
- (location ^name lawn ^side in ^east 5 ^north 7 ^general nil)
- -->
- (modify 1 ^general lawns))
-
-(p name1084
- (location ^name lawn ^side in ^east 4 ^north 7 ^general nil)
- -->
- (modify 1 ^general lawns))
-
-(p name1085
- (location ^name lawn ^side in ^east 3 ^north 6 ^general nil)
- -->
- (modify 1 ^general lawns))
-
-(p name1086
- (location ^name lawn ^side in ^east 3 ^north 7)
- -->
- (write (crlf)|This looks like an old garden, but the land is all dried and hard.|))
-
-(p name1087
- (object ^name bathwater ^place lawn ^side in ^east 3 ^north 7)
- (object ^name orchid ^state seed)
- -->
- (modify 2 ^state plant)
- (write (crlf) |The ground shakes...|)
- (write (crlf) |An orchid sprouts from the ground.|))
-
-(p name1088
- (object ^name water ^place lawn ^side in ^east 3 ^north 7)
- (object ^name orchid ^place lawn ^side in ^east 3 ^north 7 ^state plant)
- (object ^name bathwater ^place lawn ^side in ^east 3 ^north 7)
- -->
- (remove 2)
- (write (crlf) |The orchid shrinks and disappears underground.|))
-
-(p name1089
- (object ^name water ^place lawn ^side in ^east 3 ^north 7)
- (object ^name orchid ^place lawn ^side in ^east 3 ^north 7 ^state seed)
--->
- (remove 2)
- (write (crlf) |Nothing happens.  That must be strange water.|))
-
-(p name1090
- (object ^name seawater ^place lawn ^side in ^east 3 ^north 7)
- (object ^name orchid ^place lawn ^side in ^east 3 ^north 7)
--->
- (remove 2)
- (write (crlf) |I think you killed what ever was planted.|))
-
-(p name1091
- (object ^name bathwater ^place <x>)
- (object ^name water ^place <x>)
--->
- (remove 1)
- (remove 2)
- (write (crlf) |The two types of water evaporate.|))
-
-(p name1092
- (location ^name lawn ^side in ^east 3 ^north 5 ^general nil)
- -->
- (modify 1 ^general lawns))
-
-(p name1093
- (location ^name lawn ^side in ^east 3 ^north 4 ^general nil)
- -->
- (modify 1 ^general lawns)) 
-
-(p name1094
- (location ^general lawns)
- -->
- (write (crlf) |You're on the lawn of the mansion.|))
-
-(p name1095
- (location ^name lawn ^side in ^east 5 ^north 3)
- -->
- (write (crlf) |You're on the front walk.|))
-
-(p name1096
- (location ^name lawn ^side in ^east 5 ^north 2)
- -->
- (write (crlf) |You're at the front gate, which can't be opened.|))
-
-(p name1097
- (location ^name lawn ^side <side> ^east 5 ^north 2)
- (input climb)
- -->
- (remove 2)
- (write (crlf) |Nice try, but the upper part of the gate is electrified!|)
- (write (crlf) |I suggest you try somewhere else.|))
-
-(p name1105
- (location ^name lawn ^side in ^east 7 ^north 5)
- -->
- (write (crlf) |You are on the drive way.|)
- (write (crlf) |The drive has a gate in the wall to the east.|))
-
-(p name1106
- (location ^name lawn ^side in ^east 7 ^north 6)
- -->
- (write (crlf) |You are on a parking space.|))
-
-(p name1118
- (location ^name lawn)
- (input << scale climb >>)
- -->
- (remove 2)
- (write (crlf) |The wall is too slick to climb up.  You can't get a grip.|))
-
-(p name1119
- (location ^name lawn)
- (input << burrow tunnel dig >>)
- -->
- (remove 2)
- (write (crlf) |The ground is too hard to dig here.|))
-
-(p name1120
- (location ^name lawn)
- (object ^name <x> ^place held)
- (input throw <x> at wall)
- -->
- (remove 3)
- (write (crlf) |The| <x> |bounces off the wall.|)
- (make input drop <x>))
-
-(p name1121
- (input jump wall)
- (location ^name lawn)
- -->
- (remove 1)
- (write (crlf) |You aren't the HULK or Dwight Stones.|))
-
-(p name1122
- (input jump wall)
- (location ^name lawn)
- (status ^name Dwight Stones)
--->
- (remove 1)
- (write (crlf) |You approach the wall.  Up, up you go.|)
- (write (crlf) |SPLAT!! You hit the wall right at 8".  That would|)
- (write (crlf) |be a new world's record.  Too bad the wall is ten feet tall.|))
-
-(p name1123
- (input jump wall)
- (location ^name lawn)
- (status ^name the Hulk)
- -->
- (remove 1)
- (write (crlf) |Ha! You aren't the Hulk, you're just a little green|)
- (write (crlf) |from the bus ride.|))
-
-(p name1124
- (input jump over wall)
- (location ^name lawn)
- -->
- (remove 1)
- (write (crlf) |You watched Superman too many times!|))
-
-(p name1125
- (location ^name lawn)
- (input throw <y> over <Z>)
- -->
- (remove 2)
- (write (crlf) |The wall is too high for you to throw anything over it.|))
-
-(p name1126
- (input let me in)
- -->
- (remove 1)
- (write (crlf) |I'm afraid you aren't getting anyone's attention.|))
-
-(p name1127
- (input open gate)
- -->
- (remove 1)
- (write (crlf) |The gate can't be opened by you.|))
-
-(p name1128
- (status ^notreasure t)
- (object ^name <x> ^place )
- -->
- (remove 2))
-
-(p name1129
- (location ^name lawn ^side in ^east 5 ^north 6)
- -->
- (write (crlf) |There is ivy on the walls of the house.|))
-(p name389
- (time ^oil_status oil ^oil_time <x> ^realtime <x>)
- -->
- (modify 1 ^oil_status enter ^oil_time (compute <x> + 10)))
-
-(p name390
- (time ^oil_status enter ^oil_time <x> ^realtime <x>)
- -->
- (make object ^name truck ^place lawn ^side in ^east 7 ^north 5)
- (modify 1 ^oil_status walk ^oil_time (compute <x> + 10)))
-
-(p name391
- (time ^oil_status walk ^oil_time <x> ^realtime <x>)
- (history ^grave_status undug)
- -->
- (modify 1 ^oil_status walk ^oil_time (compute <x> + 4))
- (modify 2 ^grave_status dug))
-
-(p name392
- (time ^oil_status walk ^oil_time <x> ^realtime <x>)
- (history ^grave_status dug)
- -->
- (modify 1 ^oil_status walk ^oil_time (compute <x> + 4))
- (modify 2 ^grave_status deep))
-
-(p name393
- (time ^oil_status walk ^oil_time <x> ^realtime <x>)
- (history ^grave_status deep ^grave_status2 oil)
- -->
- (modify 2 ^grave_status2 nil)
- (modify 1 ^oil_status fixit ^oil_time (compute <x> + 8)))
-
-(p name394
- (time ^oil_status fixit ^oil_time <x> ^realtime <x>)
- -->
- (make fixed)
- (modify 1 ^oil_status return ^oil_time (compute <x> + 10)))
-
-(p name395
- (time ^oil_status return ^oil_time <x> ^realtime <x>)
- (object ^name truck ^place <y>)
- -->
- (modify 1 ^oil_status done)
- (remove 2))
-
-(p name500
- (location ^name lawn ^side in ^east 8 ^north 8)
- (history ^grave_status undug)
--->
- (write (crlf) |There is a fresh grave here.|))
-
-(p name501
- (location ^name lawn ^side in ^east 8 ^north 8)
- (history ^grave_status undug)
- (input dig)
- -->
- (remove 3)
- (modify 2 ^grave_status dug)
- (write (crlf) |Luckily, the dirt is soft.|))
-
-(p name502
- (location ^name lawn ^side in ^east 8 ^north 8)
- (history ^grave_status dug)
--->
- (write (crlf) |There is a open grave.|))
-
-(p name503
- (location ^name lawn ^side in ^east 8 ^north 8)
- (history ^grave_status dug)
- (input dig)
- -->
- (remove 3)
- (modify 2 ^grave_status deep))
-
-(p name504
- (location ^name lawn ^side in ^east 8 ^north 8)
- (history ^grave_status deep)
--->
- (write (crlf) |There is a large pipe that goes through the grave.|)
- (write (crlf) |There is a lever on the pipe labelled 'Emergency Release.'|))
-
-(p name505
- (location ^name lawn ^side in ^east 8 ^north 8)
- (input <x> dirt <y>)
- -->
- (remove 2)
- (write (crlf) |Hmmm..  I didn't understand that.  I can only dig holes and fill in holes.|))
-
-(p name506
- (location ^name lawn ^side in ^east 8 ^north 8)
- (input get dirt)
- -->
- (remove 2)
- (write (crlf) |Sorry, that won't wash.  I can only dig holes and fill in holes.|)
- (write (crlf) |You can't get the dirt.|))
-
-(p name507
- (location ^name lawn ^side in ^east 8 ^north 8)
- (input pull lever)
- (history ^grave_status deep ^grave_status2 <> oil)
- (time ^realtime <x>)
--(fixed)
- -->
- (remove 2)
- (write (crlf) |Ummph!|)
- (modify 3 ^grave_status2 oil)
- (modify 4 ^oil_time (compute <x> + 30)))
-
-(p name508
- (location ^name lawn ^side in ^east 8 ^north 8)
- (history ^grave_status2 oil)
--->
- (write (crlf) |There is oil seeping out of the pipe.|))
-
-(p name509
- (input << throw get push turn close >> lever)
- -->
- (remove 1)
- (make input pull lever))
-
-(p name510
- (input <x> lever)
- -->
- (remove 1)
- (write (crlf) |I don't understand the word| <x>  |as a verb for lever.|))
-
-(p name511
- (history ^grave_status2 oil)
- (input pull lever)
- -->
- (remove 2)
- (write (crlf) |The lever won't close, a special tool is needed!|)
- (write (crlf) |The oil continues to seep out.|))
-
-(p name512
- (location ^name lawn ^side in ^east 8 ^north 8)
- (input <x> oil)
- -->
- (remove 2)
- (write (crlf) |The oil is too slippery to do anything with it.|))
-
-(p name513
- (location ^name lawn ^side in ^east 8 ^north 8)
- (input refill)
- (walk <x>)
- (history ^grave_status <y>)
- -->
- (remove 2)
- (write (crlf) |You are unable to affect the driver's digging.|))
-
-(p name514
- (location ^name lawn ^side in ^east 8 ^north 8)
- (input refill)
- (fixit <x>)
- (history ^grave_status <y>)
- -->
- (remove 2)
- (write (crlf) |You are unable to affect the driver's work.|))
-
-(p name515
- (location ^name lawn ^side in ^east 8 ^north 8)
- (input refill)
- (history ^grave_status2 oil ^grave_status deep)
- -->
- (remove 2)
- (modify 3 ^grave_status dug)
- (write (crlf) |The oil still seeps out.|))
-
-(p name516
- (location ^name lawn ^side in ^east 8 ^north 8)
- (history ^grave_status deep)
- (input refill)
- -->
- (remove 3)
- (modify 2 ^grave_status dug))
-
-(p name517
- (location ^name lawn ^side in ^east 8 ^north 8)
- (history ^grave_status dug)
- (input refill)
- -->
- (remove 3)
- (modify 2 ^grave_status undug))
-
-(p name518
- (input oil)
- (location ^name lawn ^side in ^east 8 ^north 8)
--->
- (remove 1)
- (write (crlf) |The oil is too slippery to use.|))
-
-(p name519
- (input fill in)
- -->
- (remove 1)
- (make input refill))
-
-(p name520
- (input fillin)
- -->
- (remove 1)
- (make input refill))
-
-(p name521
- (input cover)
- -->
- (remove 1)
- (make input refill))
-
-(p name522
- (input << scoop shovel >>)
- -->
- (remove 1)
- (make input dig))
-
-(p name523
- (input dig)
- (location ^name lawn ^side in ^east 8 ^north 8)
--->
- (remove 1)
- (write (crlf) |The ground is too hard to dig anymore.|))
-
-(p name524
- (input refill)
- (location ^name lawn ^side in ^east 8 ^north 8)
--->
- (remove 1)
- (write (crlf) |The grave is filled.|))
-
-(p name525
- (history ^grave_status dug)
--(object ^name bone)
--->
- (make object ^name bone ^place lawn ^side in ^east 8 ^north 8 ^treasure t))
-
-(p name526
- (fixed)
- (location ^name lawn ^side in ^east 8 ^north 8)
- -->
- (write (crlf) |The oil is not seeping out, the lever has been fixed but can not be pulled.|))
-
-(p name527
- (fixed)
- (location ^name lawn ^side in ^east 8 ^north 8)
- (input pull)
- -->
- (remove 3)
- (write (crlf) |The lever won't budge.|))
-
-
-(p name530
- (location ^name lawn ^side in ^east 8 ^north 5)
- (enter)
- -->
- (write (crlf) |You see a truck outside at the gate.|))
-
-(p name531
- (location ^name lawn ^side in ^east > 6 ^north 5)
- (enter <x>)
- (time ^realtime <x>)
- (input <z>)
- -->
- (write (crlf) |The gates open and the truck enters.  The gate closes before you can escape.|)
- (write (crlf) |The truck says 'Oil line fixit' on the side.|)
- (write (crlf) |The truck pulls in and parks on the drive.|)
- (write (crlf) |The driver gets out and heads north east.|))
-
-(p name532
- (enter <x>)
- (time ^realtime <x>)
--(location ^name lawn ^side in ^east > 6 ^north 5)
- (input <z>)
- -->
- (write (crlf) |You hear a truck pull into the driveway and stop.|))
-
-(p name533
- (walk <x>)
- (location ^name lawn ^side in ^east 8 ^north 8)
- -->
- (write (crlf) |The driver is digging to get a better angle on the pipe.|))
-
-(p name534
- (fixit <x>)
- (location ^name lawn ^side in ^east 8 ^north 8)
- -->
- (write (crlf) |The driver is fixing the pipe.|))
-
-(p name535
- (fixit <x>)
- (time ^realtime <x>)
- (location ^name lawn ^side in ^east 8 ^north 8)
- (input <z>)
- -->
- (write (crlf) |The driver is finished with the work, and heads back to the truck.|))
-
-(p name536
- (return <x>)
- (time ^realtime <x>)
- (input <z>)
- (location ^name lawn ^side in ^east > 6 ^north 5)
- -->
- (write (crlf) |The man gets in the truck and backs out as the gate opens.|)
- (write (crlf) |You are unable to escape as it leaves.|))
-
-(p name537
- (input <x> driver <y>)
- -->
- (remove 1)
- (write (crlf) |You are unable to contact or make contact with the driver.|)
- (write (crlf) |It is as if he doesn't know you are there.|))
-
-(p name538
- (input get truck)
- -->
- (remove 1)
- (write (crlf) |The truck is a little heavy to get.|))
-
-(p name539
- (location ^name lawn ^side in ^east 7 ^north 5)
- (portal ^name truck ^place lawn ^side in ^east 7 ^north 5)
- -->
- (write (crlf) |There is a panel truck here.|))
-
-(p name540
- (location ^name lawn ^side in ^east 7 ^north 5)
- (portal ^name truck ^place lawn ^side in ^east 7 ^north 5)
- (input mount truck)
- -->
- (remove 3)
- (write (crlf) |The truck is too tall to climb up on.|))
-
-(p name541
- (location ^name lawn ^side in ^east 7 ^north 5)
- (object ^name truck ^place lawn ^side in ^east 7 ^north 5)
- (input open <y>)
- -->
- (remove 3)
- (write (crlf) |The front doors are locked, but you were able to open the back.|)
- (modify 2 ^door open))
-
-(p name542
- (portal  ^name truck ^door closed)
- (object ^name truck ^side in ^east 7 ^north 5)
- (location ^name lawn ^side in ^east 7 ^north 5)
- (input open <y>)
- -->
- (write (crlf) |The back doors are now open.|)
- (modify 1 ^door open)
- (remove 4))
-
-(p name543
- (location ^name lawn ^side in ^east 7 ^north 5)
- (object ^name truck ^place lawn ^side in ^east 7 ^north 5)
- (input << mount enter >> <y>)
- -->
- (remove 3)
- (write (crlf) |None of the doors are open.|))
-
-(p name544
- (location ^place lawn ^side in ^east 7 ^north 5)
- (object ^name truck ^place lawn ^side in ^east 7 ^north 5)
- (portal ^name truck ^door open)
- (input close <y>)
--->
- (modify 3 ^door close)
- (remove 4)
- (write (crlf) |Ok.|))
-
-(p name545
- (location ^name lawn ^side in ^east 7 ^north 5)
- (object ^name truck ^place lawn ^side in ^east 7 ^north 5)
- (portal ^name truck ^door open)
- (input << mount enter >> <h>)
--->
- (remove 4)
- (modify 1 ^place intruck)
- (write (crlf) |You are in the back of the truck.|))
-
-(p name546
- (location ^name intruck)
- (input look)
- -->
- (remove 2)
- (write (crlf) |You are inside the panel truck.  It is empty.|))
-
-(p name547
- (object ^name truck ^place lawn ^side in ^east 7 ^north 5)
- (portal ^name truck ^door open)
- (location ^name intruck)
- (return <y>)
- (time ^realtime <y>)
- (input <z>)
- -->
- (write (crlf) |As the truck starts up, it accelerates so fast that you fall out the back.|)
- (remove 6)
- (modify 3 ^place lawn ^side in ^east 7 ^north 5))
-
-(p name548
- (object ^name truck ^place lawn ^side in ^east 7 ^north 5)
- (portal ^name truck ^door closed)
- (location ^name intruck)
- (return <y>)
- (time ^realtime <y>)
- (input <z>)
- (status)
- -->
- (remove 6)
- (write (crlf) |VaVoom! The truck has started up.|)
- (write (crlf) |Bump bump! You feel yourself being driven out of the yard.|)
- (modify 7 ^going out))
-
-(p name549
- (location ^name lawn ^side in ^east 7 ^north 5)
- (object ^name truck ^place lawn ^side in ^east 7 ^north 5)
- (portal ^name truck ^door open)
- (input << mount enter >> <R>)
- (object ^name <y> ^place held)
- -->
- (remove 4)
- (write (crlf) |The| <y>  |won't fit through the door!|))
-
-(p name550
- (status ^going out)
- -->
- (modify 1 ^going nil)
- (write (crlf) |As you drive by the gate you hear from the speaker:|)
- (write (crlf) |'Good job son!'|)
- (write (crlf) ||)
- (write (crlf) |The truck drives on for a while then stops.|)
- (write (crlf) |Your open the truck door and find that you are outside the walls.|)
- (write (crlf) |You've escaped!|)
- (write (crlf) ||)
- (write (crlf) |In the distance you here the trumpeting of a bull moose.|)
- (write (crlf) ||)
- (write (crlf) |James Watt is here with a check for $10,000,000 to buy the land|)
- (write (crlf) |for the Department of the Interior.|)
- (write (crlf) |He assures you that the government will not sell the land, but admits|)
- (write (crlf) |that he may allow some leasing of mineral rights.  You have the option|)
- (write (crlf) |of selling it and making big bucks, or you can donate, with the|)
- (write (crlf) |restriction that it be perserved in its current state.|)
-
- (write (crlf) |What is your choice? Sell, or donate?|)
- (make selldonate (accept)))
-
-(p name551
- (selldonate sell)
- (status ^score <x>)
- -->
- (remove 1)
- (write (crlf) |Hmm.  I don't think your father would have approved.|)
- (write (crlf) |Oh my god! Out of the forest a moose comes charging at you.|)
- (write (crlf) |He is coming right at you.  You can't escape.  |)
- (write (crlf) |ARGHH! He gored you, but missed James Watt.|)
- (write (crlf) |You're dead, what a bummer after what you have been through.|)
- (make input stop)
- (modify 2 ^score (compute <x> - 20)))
-
-(p name552
- (selldonate)
- -->
- (remove 1)
- (write (crlf) |Make up your mind, Sell or donate.|)
- (make selldonate (accept)))
-
-(p name553
- (selldonate donate)
- (status ^score <x>)
- -->
- (remove 1)
- (write (crlf) |James Watt accuses you of being a reactionary idiot.|)
- (write (crlf) |He stomps off, mumbling, 'Those strip miners are going|)
- (write (crlf) |to be real disappointed', and walks right through a pile of moose turds.|)
- (write (crlf) |I think you made the right decision.|)
- (make gone)
- (modify 2 ^score (compute <x> + 20)))
-
-(p name554
- (gone)
- -->
- (make input stop))
-
-(p name555
- (gone)
- (status ^score <x>)
- (object ^name cube ^place lawn)
- -->
- (modify 2 ^score (compute <x> - 50))
- (make input stop)
- (write (crlf) |The police bust into the yard of the house to collect|)
- (write (crlf) |your treasure for you.|)
- (write (crlf) |Unfortunately they find the sugar cube with the LSd in it.|)
- (write (crlf) |You are arrested and thrown in jail for 50 years!!!|)
- (write (crlf) |What a loser!|))
-
-(p name556
- (gone)
- (status ^score <x>)
- (object ^name marijuana ^place lawn)
--->
- (modify 2 ^score (compute <x> - 20))
- (make input stop)
- (write (crlf) |The police bust into the yard of the house to collect your treasure for you.|)
- (write (crlf) |They find the marijuana! Luckily you are in the state of confusion|)
- (write (crlf) |and you get a $5 fine, but lose the $300 worth of pot.|)
- (write (crlf) |Oh well, maybe next time you'll enjoy it first.|))
-
-(p name557
- (location ^name intruck)
- (input get out)
- (portal ^name truck ^door open)
- -->
- (remove 2)
- (modify 1 ^name lawn ^side in ^east 7 ^north 5))
-
-
-(p name1130
- (location ^name lawn ^side in ^east 5 ^north 6)
- (input get ivy)
- -->
- (remove 2)
- (write (crlf) |The ivy is stuck to the wall.|))
-
-
-(p name1131
- (input hi)
- (location ^name lawn ^side out ^east 8 ^north 5)
--->
- (remove 1)
- (write (crlf) |The gate opens.  You rush in and then it closes behind you.|)
- (write (crlf) |Out of the speaker you hear, 'Now you are in, but will you ever get out?'|)
- (modify 2 ^side in))
-
-(p name1132
- (location ^name lawn ^side in ^east 8 ^north 5)
- -->
- (write (crlf) |You are on the driveway.  The gate to the outside|)
- (write (crlf) |is to the east, but is locked electronically.|))
-
-(p name1133
- (location ^name lawn ^side in ^east 8 ^north 5)
- (status ^going e)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The gate is locked, and you can't open it.|))
-
-(p name1134
- (location ^name lawn ^side out ^east 8 ^north 5)
- -->
- (write (crlf) |There is a gate in the wall that spans the|)
- (write (crlf) |driveway that leads into the inner grounds of the mansion.|)
- (write (crlf) |By the left hand side of the gate is a 'Jack-in-the-box'|)
- (write (crlf) | speaker with a button.|))
-
-(p name1200
- (input << climb scale >> )
- (location ^name lawn ^side in ^east 5 ^north 6)
- -->
- (remove 1)
- (modify 2 ^name balcony ^side nil ^east nil ^north nil)
- (write (crlf) |The ivy allows you to get a grip.  You climb up the wall.|)
- (write (crlf) |The ivy starts to thin out and you haven't found anywhere to stop.|)
- (write (crlf) |To the right you spy a balcony.  Using your great skill as a|)
- (write (crlf) |world class haunted house climber, you jump to the balcony.|))
-
-(p name01200
- (status ^going u)
- (location ^name lawn ^side in ^east 5 ^north 6)
- -->
- (modify 1 ^going nil)
- (modify 2 ^name balcony ^side nil ^east nil ^north nil)
- (write (crlf) |The ivy allows you to get a grip.  You climb up the wall.|)
- (write (crlf) |The ivy starts to thin out and you haven't found anywhere to stop.|)
- (write (crlf) |To the right you spy a balcony.  Using your great skill as a|)
- (write (crlf) |world class haunted house climber, you jump to the balcony.|))
-
-(p name1201
- (location ^name balcony)
- (place ^name balcony ^visited nil)
- -->
- (write (crlf) |You are on the balcony.  The doors to the inside|)
- (write (crlf) |are missing leaving a large doorway to the inside.|))
-
-(p name1202
- (location ^name balcony)
- (status ^going u)
- -->
- (modify 2 ^going nil)
- (write (crlf) |You can't climb any higher.|))
-
-(p name1203
- (location ^name balcony)
- (input climb up)
- (status)
- -->
- (remove 2)
- (modify 3 ^going u ^went u))
-
-(p name1204
- (location ^name balcony)
- (input climb nil)
- -->
- (remove 2)
- (write (crlf) |Climb up or climb down?|))
-
-(p name1205
- (input climb down)
- (location ^name balcony)
- (status)
- -->
- (remove 1)
- (write (crlf) |I warned you that the ivy gave out up here!|)
- (write (crlf) |When you tried to leap over to get a grip, you missed!!|)
- (write (crlf) |Down you go|)
- (write (crlf) |           o|)
- (write (crlf) |            o|)
- (write (crlf) |             o|)
- (write (crlf) |              o.|)
- (write (crlf) |Your foot gets caught in some ivy near the bottom and you land|)
- (write (crlf) |on your head.  |)
- (modify 3 ^die t))
-
-(p name1206
- (location ^name balcony)
- (status ^going d)
- -->
- (modify 2 ^going nil)
- (write (crlf) |Is that climb down or jump?|))
-
-(p name1207
- (location ^name balcony)
- (input jump)
- (status)
- -->
- (write (crlf) |Paratrooper training comes in helpful sometimes.|)
- (write (crlf) |Unfortunately you never had it.  You break your neck when you hit.|)
- (remove 2)
- (modify 3 ^die t))
-
-(p name1208
- (location ^name balcony)
- (input jump)
- (object ^name mattress ^place held)
- (status)
- -->
- (modify 4 ^die t)
- (write (crlf) |You flip over in mid-air and land on your back! 'CRUNCH'|)
- (remove 2))
-
-(p name1209
- (location ^name balcony)
- (input jump)
- (object ^name mattress ^place lawn ^side in ^east 5 ^north 6)
- -->
- (remove 2)
- (modify 1 ^name lawn ^side in ^east 5 ^north 6)
- (write (crlf) |Luckily you land on the mattress.|))
-
-(p name1210
- (input drop mattress)
- (location ^name balcony)
- (object ^name mattress ^place held)
- -->
- (remove 1)
- (modify 3 ^place lawn ^side in ^east 5 ^north 6)
- (write (crlf) |The mattress floats to the ground.|))
-
-(p name1211
- (input throw mattress)
- (location ^name balcony)
- -->
- (remove 1)
- (make input drop mattress))
-
-(p name1212
- (input enter)
- (location ^name balcony)
- (status)
- -->
- (modify 3 ^going s ^went s)
- (remove 1))
-
-(p name1213
- (location ^name balcony)
- (place ^name balcony)
- (status ^going s)
- -->
- (modify 1 ^name bedroom)
- (modify 2 ^name balcony ^visited t)
- (modify 3 ^going nil))
-
-(p name1214
- (location ^name bedroom)
- (place ^name bedroom ^visited nil)
- -->
- (write (crlf) |You are in what looks like the master bedroom of the mansion.|)
- (write (crlf) |A large doorway opens to the balcony to the north.|)
- (write (crlf) |To the east is a opening to the bathroom.|)
- (write (crlf) |The main doorway to the rest of the house is boarded up and impassable.|))
-
-(p name1215
- (input enter)
- (location ^name bedroom)
- -->
- (remove 1)
- (make input e))
-
-(p name1216
- (location ^name bedroom)
- (make input exit)
- -->
- (remove 2)
- (make input n))
-
-(p name1217
- (location ^name bedroom)
- (object ^name mattress ^place held)
- (status ^going e)
- -->
- (modify 3 ^going nil)
- (write (crlf) |The mattress won't fit through the door.|))
-
-(p name1218
- (location ^name bedroom)
- (object ^name mattress ^place held)
- (status ^going n)
- -->
- (write (crlf) |The mattress just clears the door.|))
-
-(p name1219
- (location ^name bedroom)
- (place ^name bedroom)
- (status ^going n)
- -->
- (modify 3 ^going nil)
- (modify 2 ^name bedroom ^visited t)
- (modify 1 ^name balcony))
-
-(p name1220
- (location ^name bedroom)
- (status ^going e)
- (place ^name bedroom)
- -->
- (modify 2 ^going nil)
- (modify 3 ^name bedroom ^visited t)
- (modify 1 ^name bathroom))
-
-(p name1221
- (location ^name bedroom)
- (status ^sound on)
- -->
- (write (crlf) |Some noise can be heard through the boarded up door.|))
-
-(p name1222
- (location ^name bedroom)
- (object ^name mattress ^place bedroom)
- -->
- (write (crlf) |There is a king-size bed in the middle of the room.|))
-
-(p name1223
- (location ^name bedroom)
--(object ^name mattress ^place bedroom)
- -->
- (write (crlf) |There is the frame and springs of a king-size bed in the room.|))
-
-(p name1224
- (location ^name bedroom)
- (input get bed)
- -->
- (remove 2)
- (write (crlf) |All you can get is the mattress, the rest is too heavy.|)
- (make input get mattress))
-
-(p name1225
- (location ^name <x>)
- (object ^name mattress ^place <x>)
- (input cut mattress)
- -->
- (remove 3)
- (remove 2)
- (write (crlf) |The mattress is poorly made and you rip it to shreds.|)
- (write (crlf) |In fact it is in a million pieces that float away.|))
-
-(p name1226
- (input cut mattress)
- (object ^name mattress ^place held)
- -->
- (remove 1)
- (remove 2)
- (write (crlf) |The mattress falls to pieces in your hands and they all float away.|))
-
-(p name1227
- (input << chop rip tear >>)
- -->
- (remove 1)
- (make input cut))
-
-(p name1228
- (location ^name bedroom)
- (input look under bed)
- -->
- (remove 2)
- (write (crlf) |'Ahhh Chooo!' There is dust under the bed.|))
-
-(p name1229
- (location ^name bedroom)
- (input <x> under bed)
- -->
- (remove 2)
- (write (crlf) |The bed is too low to go under.|))
-
-(p name1230
- (input mount bed)
- (location ^name bedroom)
- -->
- (remove 1)
- (modify 2 ^ontop bed)
- (write (crlf) |You are on the bed.|))
-
-(p name1231
- (location ^name bedroom ^ontop bed)
- (object ^name mattress ^place bedroom)
- (input jump)
--(object ^name mirror ^state broke)
- -->
- (remove 3)
- (write (crlf) |You bounce up and hit the mirror.  It shatters into many small pieces.|)
- (make object ^name mirror ^state broke))
-
-(p name1232
- (input bounce)
- -->
- (remove 1)
- (make input jump))
-
-(p name1233
- (location ^name bedroom ^ontop bed)
- (input jump)
- -->
- (remove 2)
- (write (crlf) |Without the mattress on you don't get any cheap thrills.|))
-
-(p name1234
- (location ^name bedroom ^ontop <> nil)
- (input get mirror)
- -->
- (remove 2)
- (write (crlf) |The mirror is still out of reach.|))
-
-(p name1235
- (location ^name bedroom)
- (input get mirror)
- -->
- (remove 2)
- (write (crlf) |The mirror is much too high to reach.|))
-
-(p name1236
- (location ^name bedroom)
--(object ^name mirror ^state broke)
- -->
- (write (crlf) |There is a mirror on the ceiling above the bed.|))
-
-(p name1237
- (location ^name bedroom)
- (object ^name mirror ^state broke)
- (input get mirror)
- (status ^cut nil)
- -->
- (remove 3)
- (modify 4 ^cut t)
- (write (crlf) |The glass is too sharp to carry, you cut yourself.  'Ouch!'|))
-
-(p name1238
- (location ^name bedroom ^ontop bed)
- (object ^name mirror ^state broke)
- (input get mirror <x>)
- (status)
- -->
- (remove 3)
- (modify 4 ^cut t)
- (write (crlf) |The glass cuts you when you try to pick it up.|))
-
-(p name1239
- (location ^name bedroom)
- (object ^name mirror ^state broke)
- (input get glass)
- (status)
- -->
- (remove 3)
- (modify 4 ^cut t)
- (write (crlf) |'Ouch!' The glass cuts you, you can't carry it.|))
-
-(p name1240
- (location ^name bedroom)
- (object ^name mirror ^state broke)
- -->
- (write (crlf) |There is glass from a broken mirror on the floor.|))
-
-(p name1241
- (input sleep)
- (location ^name bedroom ^ontop bed)
- -->
- (write (crlf) |Snooze...
-	.
-	.
-	.
-	.
-	.
-	...  snort.  Ah that was refreshing, but useless, you're still ugly.|)
- (remove 1))
-
-(p name1242
- (input get << on in >> bed)
- (location ^name bedroom)
- -->
- (remove 1)
- (make input mount bed))
-
-(p name1243
- (location ^name bedroom)
- (input sit on bed)
- -->
- (remove 2)
- (make input mount bed))
-
-(p name1244
- (x 10)
- (input sleep)
- -->
- (remove 2)
- (write (crlf) |Let's wait until we are on a bed.|))
-
-(p name1245
- (location ^name {<> bedroom <x>})
- (object ^name mattress ^place <x>)
- -->
- (write (crlf) |There is a king-size mattress here.|))
-
-(p name1246
- (location ^name bathroom)
- (place ^name bathroom ^visited nil)
- -->
- (write (crlf) |You are in the master bathroom.|)
- (write (crlf) |The exciting features around are the bathtub and the toilet.|))
-
-(p name1247
- (location ^name bathroom)
- (status ^going w)
- (place ^name bathroom)
- -->
- (modify 1 ^name bedroom)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name1248
- (location ^name bathroom)
- (input urinate)
- -->
- (remove 2)
- (write (crlf) |That was a relief!|))
-
-(p name1249
- (location ^name bathroom)
- (input urinate)
- (status ^likes  prince)
- -->
- (modify 1 ^siton  toilet))
-
-(p name1250
- (input urinate into bottle)
- -->
- (remove 1)
- (write (crlf) |The adventure has frighten you so much that your|)
- (write (crlf) |urethra won't relax|)
- (write (crlf) |and you are unable to even expel a drop.|))
-
-(p name1251
- (input get urine)
- -->
- (remove 1)
- (make input urinate into bottle))
-
-(p name1252
- (input urinate in bottle)
- -->
- (remove 1)
- (make input urinate into bottle))
-
-(p name1253
- (input shit)
- (location ^name bathroom)
- -->
- (remove 1)
- (modify 2 ^siton  toilet)
- (write (crlf) |Too bad there isn't any tissue!|))
-
-(p name1254
- (input piss)
- -->
- (remove 1)
- (make input urinate))
-
-(p name1255
- (input take a leak)
- -->
- (remove 1)
- (make input urinate))
-
-(p name1256
- (input take a crap)
- (location ^name bathroom)
- -->
- (remove 1)
- (make input shit))
-
-(p name1257
- (input mount toilet)
- (location ^name bathroom)
- -->
- (remove 1)
- (modify 2 ^siton  toilet)
- (write (crlf) |Sitting on a toilet is lots of fun!|))
-
-(p name1258
- (input sit on toilet)
- (location ^name bathroom)
- -->
- (remove 1)
- (modify 2 ^siton  toilet)
- (write (crlf) |Duly sat.|))
-
-(p name1259
- (location ^name bathroom)
- (input flush)
- (status)
- -->
- (remove 2)
- (modify 3 ^die t)
- (write (crlf) |When you flush the toilet it spins around, knocking you off your feet!|)
- (write (crlf) |You crack your head on the bathtub and die!!|))
-
-(p name1260
- (location ^name bathroom ^siton <> nil)
- (status ^going w)
- -->
- (modify 1 ^siton nil))
-
-(p name1261
- (input flush)
- (location ^name bathroom ^siton  toilet)
- (place ^name bathroom)
- -->
- (remove 1)
- (modify 2 ^name backroom)
- (modify 3 ^visited t))
-
-(p name1262
- (location ^name bathroom)
- (input get toilet)
- -->
- (remove 2)
- (write (crlf) |Give me a break! The toilet stays here!|))
-
-(p name1263
- (location ^name bathroom)
- (input get bathtub)
- -->
- (write (crlf) |The bathtub doesn't move.|)
- (remove 2))
-
-(p name1264
- (location ^name bathroom)
- (input << enter mount >> bathtub)
- -->
- (modify 1 ^siton  bathtub)
- (remove 2)
- (write (crlf) |Ok.|))
-
-(p name1265
- (location ^name bathroom)
- (input sit in bathtub)
- -->
- (modify 1 ^siton  bathtub)
- (remove 2)
- (write (crlf) |Ok.|))
-
-(p name1266
- (location ^name bathroom)
- (input turn on water)
- (place ^name bathroom)
- -->
- (remove 2)
- (modify 3 ^state water_running))
-
-(p name1267
- (location ^name bathroom)
- (place ^name bathroom ^state water_running)
- -->
- (write (crlf) |The water is on in the bathtub.|))
-
-(p name1268
- (location ^name bathroom)
- (place ^name bathroom ^state <> water_running)
- (input turn off water)
- -->
- (remove 3)
- (write (crlf) |The water is already off.|))
-
-(p name1269
- (location ^name bathroom)
- (place ^name bathroom ^state water_running)
- (input turn off water)
- -->
- (modify 2 ^state nil)
- (remove 3)
- (write (crlf) |The water is turned off.|)
- (write (crlf) |All the water drains out.|))
-
-(p name1270
- (location ^name bathroom)
- (input turn on shower)
- -->
- (remove 2)
- (write (crlf) |There isn't a shower head, just a bathtub.|))
-
-(p name1271
- (location ^name bathroom)
- (input take shower)
- -->
- (remove 2)
- (write (crlf) |I thought I said there was only a bathtub!|))
-
-(p name1272
- (location ^name bathroom)
- (input take bath)
- -->
- (remove 2)
- (make command ^string wash))
-
-(p name1273
- (location ^name bathroom)
- (input wash)
- -->
- (remove 2)
- (make command ^string wash))
-
-(p name1274
- (location ^name bathroom)
- (command ^string wash)
- (place ^name bathroom ^state <> water_running)
- -->
- (write (crlf) |Well, I must turn on the water.|)
- (modify 3 ^state water_running))
-
-(p name1275
- (location ^name bathroom ^siton  <> bathtub)
- (command ^string wash)
- -->
- (write (crlf) |Let's get in the bathtub.|)
- (modify 1 ^siton  bathtub))
-
-(p name1276
- (location ^name bathroom)
- (command ^string wash)
- (object ^name soap ^place bathroom)
- -->
- (write (crlf) |Hmmm...  now where was that soap.|)
- (make input get soap))
-
-(p name1277
- (location ^name bathroom ^siton  bathtub)
- (command ^string wash)
- (object ^name soap ^place held)
- (place ^name bathroom ^state water_running)
- -->
- (remove 2)
- (remove 3)
- (write (crlf) |Luckily we don't worry about clothes in this adventure!|)
- (write (crlf) |The water is nice and warm.  Too bad I don't have a rubber duckie!|)
- (write (crlf) |Well let's use the soap to get clean.|)
- (write (crlf) |There is so much dirt here it takes alot of soap.|)
- (write (crlf) |As the soap wears away, we are left with a GEM!!.|)
- (make object ^name gem ^place held ^treasure t))
-
-(p name1278
- (x 10)
- (command ^string wash)
- -->
- (remove 1)
- (write (crlf) |Ahh, can't wash without any soap and water.|))
-
-(p name1279
- (location ^siton  bathtub)
- (object ^name soap ^place held)
- (place ^name bathroom ^state water_running)
- -->
- (write (crlf) |As long as we're here, we might as well wash.|)
- (make command ^string wash))
-
-(p name1280
- (location ^name bathroom)
- (object ^name soap ^place held)
- (input drop soap in << bathtub water >>)
- (place ^name bathroom ^state water_running)
- -->
- (remove 2)
- (remove 3)
- (write (crlf) |The soap dissolves and a gem remains!|)
- (make object ^name gem ^place bathroom ^treasure t))
-
-(p name1281
- (location ^siton  bathtub)
- (object ^name <x> ^wears t)
- -->
- (remove 1)
- (write (crlf) |If we're getting in the bathtub I'm going to take off the|
- <x>  |.|)
- (make input take off <x>))
-
-(p name1282
- (location ^name bathroom)
- (input lather)
- -->
- (remove 2)
- (make input wash))
-
-(p name1283
- (location ^name bathroom)
- (input drop soap in water)
- -->
- (remove 2)
- (make input wash))
-
-(p name1284
- (location ^name bathroom)
- (input drop soap in bathtub)
- -->
- (remove 2)
- (make input wash)
- (write (crlf) |Let's jump in after it and take a bath.|))
-
-(p name1285
- (location ^name bathroom)
- (input drink water)
- -->
- (remove 2)
- (write (crlf) |Gross! I'm not that thirsty!|))
-
-(p name1286
- (input urinate <x>)
- (object ^name <x> ^wears <> nil)
- -->
- (remove 1)
- (make input take off <x>)
- (write (crlf) |Well, I think it is best to undress a little first.|))
-
-(p name1287
- (location ^name bathroom)
- (input shit)
- (object ^name <x> ^wears <> nil)
- -->
- (remove 2)
- (make input take off <x>)
- (write (crlf) |I'll take off the suit first.|))
-
-(p name1288
- (input pee)
- -->
- (remove 1)
- (make input urinate))
-
-(p name1289
- (location ^name bathroom)
- (input <x> drain)
- -->
- (remove 2)
- (write (crlf) |The drain is open, even shoving the bed down it won't close it|))
-
-(p name1290
- (location ^name bathroom)
- (input plug)
- -->
- (remove 2)
- (write (crlf) |You can't plug it.|))
-
-(p name1291
- (location ^name bathroom)
- (input <x> plug <y>)
- -->
- (remove 2)
- (write (crlf) |I see no plug here.|))
-
-(p name1292
- (location ^name bathroom)
- (place ^name bathroom ^state water_running)
- (input splash)
--->
- (remove 3)
- (write (crlf) |Hey, watch it! No splashing around here.|))
-
-(p name1293
- (location ^name bathroom ^siton  bathtub)
- (place ^name bathroom ^state water_running)
- (input drown)
- (status)
- -->
- (modify 2 ^state nil)
- (remove 3)
- (modify 4 ^die t)
- (write (crlf) |Adventure a little to tough for you eh?|)
- (write (crlf) |Well you did look a little blue, especially after you held your head under|)
- (write (crlf) |for ten minutes!|))
-
-(p name1294
- (location ^name backroom)
- (place ^name backroom ^visited nil)
- -->
- (write (crlf) |The toilet and the wall have swivled around 180 degrees.|)
- (write (crlf) |You are now in a backroom.|)
- (write (crlf) |I assume this was for when grand-dad wanted to ...  in private.|)
- (write (crlf) |There are no doors or windows.  Just the toilet.|))
-
-(p name1295
- (location ^name backroom)
- (input flush)
- (place ^name backroom)
- -->
- (modify 1 ^name bathroom)
- (remove 2)
- (modify 3 ^visited t)
- (write (crlf) |Around you go again.|))
-
-(p name1296
- (location ^name backroom)
- (input urinate)
- -->
- (remove 2)
- (write (crlf) |Your bladder is empty.|))
-
-(p name1297
- (location ^name backroom)
- (input shit)
- -->
- (remove 2)
- (write (crlf) |Plop!|))
-
-(p name1298
- (location ^name backroom)
- (input stand)
- -->
- (remove 2)
- (write (crlf) |There isn't enough room to stand.|))
-
-(p name1299
- (location ^name backroom)
- (input get up)
- -->
- (remove 2)
- (write (crlf) |I see no up here.  Ha ha, only kidding.  There isn't room to stand in here.|))
-(p name2000
- (location ^name lawn ^side in ^east 5 ^north 4)
- (input ouvre)
- (portal ^name large_door ^door closed)
- (status ^likes <f>)
- -->
- (remove 2)
- (modify 3 ^name large_door ^door open)
- (write (crlf) |The door creaks open.|)
- (write (crlf) |A voice from within says: 'Welcome,| <f> |lover.'|))
-
-(p name2001
- (location ^name lawn ^side in ^east 5 ^north 4)
- (input ouvre)
- (portal ^name large_door ^door open)
- -->
- (remove 2)
- (write (crlf) |The door stays open.|))
-
-(p name2002
- (location ^name lawn ^side in ^east 5 ^north 4)
- (status ^going n)
- -->
- (remove 2)
- (write (crlf) |The door is closed, you bump your nose!|))
-
-(p name2003
- (location ^name lawn ^side in ^east 5 ^north 4)
- (status ^going n)
- (portal ^name large_door ^door open)
- -->
- (modify 1 ^name foyer ^side nil ^east nil ^north nil)
- (modify 2 ^going nil))
-
-(p name2004
- (location ^name lawn ^side in ^east 5 ^north 4)
- (status ^going n)
- (portal ^name large_door ^door open)
- (object ^name mattress ^place held)
- -->
- (modify 2 ^going nil)
- (write (crlf) |The mattress won't fit throught the door.|))
-
-(p name2005
- (location ^name lawn ^side in ^east 5 ^north 4)
- (status ^going n)
- (portal ^name large_door ^door open)
- (object ^name cube ^place held)
--->
- (modify 4 ^place lawn ^side in ^east 5 ^north 4)
- (write (crlf) |You stumble over the threshold and drop the cube outside.|))
-
-(p name2006
- (location ^name lawn ^side in ^east 5 ^north 4)
- (status ^going n)
- (portal ^name large_door ^door open)
- (object ^name marijuana ^place held)
- -->
- (write (crlf) |The dope slips from your hand.|)
- (modify 4 ^place lawn ^side in ^east 5 ^north 4))
-
-(p name2007
- (location ^name lawn ^side in ^east 5 ^north 4)
- (input enter)
- (status)
- -->
- (remove 2)
- (modify 3 ^going n ^went n))
-
-(p name2008
- (location ^name lawn ^side in ^east 5 ^north 4)
- -->
- (write (crlf) |You are outside a large door in the front of an old mansion.|))
-
-(p name2009
- (location ^name lawn ^side in ^east 5 ^north 4)
- (input knock)
- -->
- (remove 2)
- (write (crlf) |'Knock! Knock!'|)
- (make input ouvre))
-
-(p name2010
- (location ^name lawn ^side in ^east 5 ^north 4)
- (input ring)
- -->
- (remove 2)
- (write (crlf) |Ding dong!|)
- (make input ouvre))
-
-(p name2011
- (x 30)
- (input ring)
- -->
- (remove 2)
- (write (crlf) |I see no bell here.|))
-
-(p name2012
- (location ^name lawn ^side in ^east 5 ^north 4)
- (input open)
- (portal ^name large_door ^door closed)
- -->
- (remove 2)
- (write (crlf) |Didn't your mother teach you any manners?|)
- (write (crlf) |You shouldn't open someones door without their permission!|))
-
-(p name2013
- (location ^name lawn ^side in ^east 5 ^north 4)
- (portal ^name large_door ^door open)
- (input close)
- -->
- (modify 2 ^door closed)
- (remove 3)
- (write (crlf) |The door closes.|))
-
-(p name2014
- (location ^name lawn ^side in ^east 5 ^north 4)
- (status ^sound on)
- -->
- (write (crlf) |Muffled sounds can be heard from inside.|))
-
-(p name2015
- (location ^name foyer)
- (place ^name foyer ^visited nil)
- -->
- (write (crlf) |You are inside of the house in the inner foyer.|)
- (write (crlf) |There is a walk-in closet to the west, an entrance to a hall to the north.|))
-
-(p name2016
- (location ^name foyer)
- (status ^going s)
- (portal ^name large_door ^door open)
- -->
- (modify 2 ^going nil)
- (modify 3 ^door closed)
- (write (crlf) |Before you can get out the large door slams shut; BOOM!|)
- (write (crlf) |Laughter can be heard in the upper floors of the house.|))
-
-(p name2017
- (location ^name foyer)
- (portal ^name large_door ^door closed)
- (input open)
- -->
- (remove 3)
- (write (crlf) |The large door is locked impossible to open.|))
-
-(p name2018
- (location ^name foyer)
- (status ^going n)
- (place ^name foyer)
- -->
- (modify 2 ^going nil)
- (modify 3 ^visited t)
- (modify 1 ^name main_hall))
-
-(p name2019
- (location ^name foyer)
- (portal ^name large_door ^door closed)
- (status ^going s)
- -->
- (modify 3 ^going nil)
- (write (crlf) |The door is shut.|))
-
-(p name2020
- (location ^name foyer)
- (input enter closet)
- (status)
- -->
- (remove 2)
- (modify 3 ^going w ^went w))
-
-(p name2021
- (location ^name foyer)
- (input enter hall)
- (status)
- -->
- (modify 3 ^going n ^went n)
- (remove 2))
-
-(p name2022
- (location ^name foyer)
- (status ^going w)
- (place ^name foyer)
- -->
- (modify 3 ^visited t)
- (modify 1 ^name closet)
- (modify 2 ^going nil))
-
-(p name2023
- (location ^name foyer)
- (portal ^name large_door ^door open)
- (input close)
- -->
- (remove 3)
- (modify 2 ^door closed)
- (write (crlf) |The door closes.|))
-
-(p name2024
- (location ^name foyer)
- (place ^name foyer ^virgin t)
- (time ^realtime <y>)
- -->
- (modify 2 ^virgin nil)
- (modify 3 ^orc_status sweat ^orc_time (compute <y> + 160))
- (write (crlf) |You feel a chill run down your spine, and you doubt your own sanity.|)
- (write (crlf) | |)
- (write (crlf) |A booming voice proclaims:|)
- (write (crlf) |'YOU WON'T GET OUT BY A DOOR.'|)
- (write (crlf) |'...  at least alive!'|)
- (write (crlf) | |)
- (write (crlf) |The house is very damp and musty.|))
-
-(p name2025
- (location ^name foyer)
- (time ^realtime <y> ^orc_time < <y>)
- -->
- (modify 2 ^orc_time (compute <y> + 20))
- (write (crlf) |A booming voice proclaims:|)
- (write (crlf) |'You must be mad to return.  If you're not, you will be soon.'|))
-
-(p name2026
- (location ^name foyer)
- (time ^realtime <y>)
- (command ^string eat_it)
- -->
- (modify 2 ^orc_status nil)
- (remove 3))
-
-(p name2027
- (location ^name foyer)
- (status ^sound on)
- -->
- (write (crlf) |Some noise is coming from the hall.|))
-
-(p name2028
- (location ^name main_hall)
- (status ^going s)
- (place ^name main_hall)
- -->
- (modify 1 ^name foyer)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2029
- (location ^name main_hall)
- (place ^name main_hall ^visited nil)
- -->
- (write (crlf) |You are in the main hall.|)
- (write (crlf) |The foyer is south.|)
- (write (crlf) |The hall extends west and darkens.|)
- (write (crlf) |A large room is to the east.|))
-
-(p name2030
- (location ^name main_hall)
- (place ^name main_hall)
- (status ^going w)
- -->
- (modify 1 ^name dark_hall)
- (modify 2 ^visited t)
- (modify 3 ^going nil))
-
-(p name2031
- (location ^name main_hall)
- (status ^going e)
- (place ^name main_hall)
- -->
- (modify 1 ^name library)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2032
- (location ^name main_hall)
- (status ^going << u n >>)
- (object ^name stairs ^state whole)
- (place ^name main_hall)
- -->
- (modify 1 ^name stairs)
- (modify 2 ^going nil)
- (modify 4 ^visited t))
-
-(p name2033
- (location ^name main_hall)
- (status ^going n)
- (object ^name stairs ^state collapsed)
- (place ^name main_hall)
- -->
- (modify 1 ^name stairs_debris)
- (modify 2 ^going nil)
- (modify 4 ^visited t))
-
-(p name2034
- (location ^name main_hall)
- (status ^sound on)
- -->
- (write (crlf) |Weird noises are coming from above.|))
-
-(p name2035
- (location ^name closet)
- (status ^going e)
- (place ^name closet)
- -->
- (modify 1 ^name foyer)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2036
- (location ^name closet)
- (place ^name closet ^visited nil)
- -->
- (write (crlf) |You are in a large closet, you can see all its contents|)
- (write (crlf) | by the light from the foyer.|))
-
-(p name2037
- (location ^name dark_hall)
- (place ^name dark_hall ^visited nil)
- -->
- (write (crlf) |You are in a poorly lit hall.  There is a faint scent of fresh paint.|))
-(p name2038
- (location ^name dark_hall)
- (status ^going w)
- (place ^name dark_hall)
- -->
- (modify 1 ^name smelly_room)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2039
- (location ^name dark_hall)
- (status ^going e)
- (place ^name dark_hall)
- -->
- (modify 1 ^name main_hall)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2040
- (location ^name stairs)
- (place ^name stairs ^visited nil)
- -->
- (write (crlf) |You are on the landing of the stair case.|)
- (write (crlf) |stairs go up and down.|)
- (write (crlf) | |)
- (write (crlf) |The stairs are squeeky! They seem about to collapse.|))
-
-(p name2041
- (location ^name stairs)
- (status ^sound on)
- -->
- (write (crlf) |The sound is coming from above you.|))
-
-(p name2042
- (location ^name stairs)
- (status ^going u)
- (place ^name stairs)
-  -->
- (modify 1 ^name upper_hall)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2043
- (location ^name stairs)
- (status ^going d)
- (place ^name stairs)
-  -->
- (modify 1 ^name main_hall)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2045
- (location ^name stairs)
- (place ^name stairs ^visited t)
- -->
- (write (crlf) |SQUEEK! These stairs are delicate!|))
-
-(p name2046
- (location ^name stairs)
- (object ^name stairs ^state whole)
- (input jump)
- -->
- (write (crlf) |CRASH! You've collapsed the stairs.|)
- (modify 1 ^name stairs_debris)
- (modify 2 ^state collapsed)
- (remove 3))
-
-(p name2047
- (location ^name smelly_room)
- (place ^name smelly_room ^visited nil)
- -->
- (write (crlf) |You are in a room that smells of paint.|)
- (write (crlf) |There are no windows or door except the one you came through.|)
- (write (crlf) |The walls are wood panel.|))
-
-(p name2048
- (location ^name smelly_room)
- (status ^going e)
- (place ^name smelly_room)
-  -->
- (modify 1 ^name dark_hall)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2049
- (location ^name library)
- (place ^name library ^visited nil)
- -->
- (write (crlf) |You are in the library.  All the walls are lined with books.|)
- (write (crlf) |There is a bust of Homer within reach.|))
-
-(p name2050
- (location ^name library)
- (status ^going w)
- (place ^name library)
-  -->
- (modify 1 ^name main_hall)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2051
- (location ^name library)
- (input get bust)
- -->
- (remove 1)
- (write (crlf) |The bust is too heavy to carry.|))
-
-(p name2052
- (location ^name library)
- (input turn bust)
- (portal ^name library ^door closed)
- -->
- (remove 2)
- (modify 3 ^door open))
-
-(p name2053
- (location ^name library)
- (input enter)
- (portal ^name library ^door open)
- (status)
- -->
- (remove 2)
- (modify 4 ^going e ^went e))
-
-(p name2054
- (location ^name library)
- (portal ^name library ^door open)
- (object ^name wetsuit ^wears t)
- (status ^going e)
- -->
- (modify 4 ^going nil)
- (write (crlf) |You can't fit into the opening.|))
-
-(p name2055
- (location ^name library)
- (portal ^name library ^door open)
- (object ^name wetsuit ^place held)
- (status ^going e)
- -->
- (modify 4 ^going nil)
- (write (crlf) |Something you're carrying is to big to fit through the door.|))
-
-(p name2056
- (location ^name library)
- (portal ^name library ^door open)
- (status ^going e)
- (place ^name library)
- -->
- (modify 1 ^name secret_stairs)
- (modify 3 ^going nil)
- (modify 4 ^visited t))
-
-(p name2057
- (location ^name library)
- (input turn bust)
- (portal ^name library ^door open)
- -->
- (remove 2)
- (modify 3 ^door closed)
- (write (crlf) |The shelves close.|))
-
-(p name2058
- (location ^name library)
- (portal ^name library ^door open)
- -->
- (write (crlf) |The east wall of books is open!|))
-
-(p name2059
- (location ^name library)
- (input bust)
- -->
- (remove 2)
- (write (crlf) |I'll bust you if you don't watch it.|))
-
-(p name2060
- (location ^name library)
- (input rub bust)
- -->
- (remove 2)
- (write (crlf) |That isn't very rewarding, nothing happens.|))
-
-(p name2061
- (location ^name library)
- (input kiss bust)
- -->
- (remove 2)
- (write (crlf) |That might turn on a frog, but homer is unmoved.|))
-
-(p name2062
- (location ^name library ^book nil)
- (input get book)
- -->
- (modify 1 ^book t)
- (remove 2)
- (write (crlf) |You get a book but discover it has only virtual pages.|)
- (write (crlf) |The book disappears.|))
-
-(p name2063
- (location ^name library ^book t ^book2 nil)
- (input get book)
- -->
- (write (crlf) |The title of the book is 'Vampires I have known'|)
- (modify 1 ^book2 t)
- (remove 2)
- (make object ^name book ^place held))
-
-(p name2064
- (location ^name library ^book t ^book2 t)
- (input get book)
- -->
- (remove 2)
- (write (crlf) |All the rest of the books are fake.|)
- (write (crlf) |They seem to be wood.|))
-
-(p name2065
- (location ^name secret_stairs)
- (place ^name secret_stairs ^visited nil)
- -->
- (write (crlf) |You are in the head of a secret staircase.|)
- (write (crlf) |The stairs go down.  A pole in the room goes through a hole in the ceiling.|))
-
-(p name2066
- (location ^name secret_stairs)
- (status ^going w)
- (portal ^name library ^door open)
- (place ^name secret_stairs)
- -->
- (modify 1 ^name library)
- (modify 2 ^going nil)
- (modify 4 ^visited t))
-
-(p name2067
- (location ^name secret_stairs)
- (status ^going d)
- (place ^name secret_stairs)
- -->
- (modify 1 ^name  wine_cellar)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2068
- (location ^name secret_stairs)
- (portal ^name library ^door closed)
- (input open <x>)
- -->
- (remove 3)
- (write (crlf) |The stacks can't be opened from here.|))
-
-(p name2069
- (location ^name secret_stairs)
- (portal ^name library ^door open)
- -->
- (write (crlf) |The west wall is open.|))
-
-(p name2070
- (location ^name secret_stairs)
- (status ^going u)
- -->
- (modify 2 ^going nil)
- (write (crlf) |That isn't a bat pole, ROBIN.  You can only come down.|))
-
-(p name2071
- (location ^name stairs_debris)
- (place ^name stairs_debris ^visited nil)
- -->
- (write (crlf) |You are on wreckage of the stairs.|)
- (write (crlf) |To the south is the main_hall, north is a small opening.|))
-
-(p name2072
- (location ^name stairs_debris)
- (status ^going s)
- (place ^name stairs_debris)
- -->
- (modify 1 ^name  main_hall)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2073
- (location ^name stairs_debris)
- (status ^going n)
- (place ^name stairs_debris)
- -->
- (modify 1 ^name  back_hall)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2074
- (location ^name back_hall)
- (place ^name back_hall ^visited nil)
- -->
- (write (crlf) |This is the back hall.  It connects the kitchen and|)
- (write (crlf) |dining room.  The kitchen is east and the dining room is west.|))
-
-(p name2075
- (location ^name back_hall)
- (object ^name stairs ^state collapsed)
- -->
- (write (crlf) |To the south is the wreckage of the stairs.|))
-
-(p name2076
- (location ^name back_hall)
- (status ^going e)
- (place ^name back_hall)
- -->
- (modify 1 ^name  kitchen)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2077
- (location ^name back_hall)
- (status ^going w)
- (place ^name back_hall)
- -->
- (modify 1 ^name  dining_room)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2078
- (location ^name back_hall)
- (status ^going s)
- (place ^name back_hall)
- (object ^name stairs ^state collapsed)
- -->
- (modify 1 ^name  stairs_debris)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2079
- (location ^name kitchen)
- (place ^name kitchen ^visited nil)
- -->
- (write (crlf) |You are in a old kitchen.  All the windows are|)
- (write (crlf) |boarded up.  The only exit is west.|)
- (write (crlf) | |)
- (write (crlf) |There is a refrigerator in the corner.|)
- (write (crlf) |A ventilation duct is open over the refrigerator.|))
-
-(p name2080
- (location ^name kitchen)
- (status ^going w)
- (place ^name kitchen)
- -->
- (modify 1 ^name  back_hall)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2081
- (location ^name kitchen)
- (input exit)
- (status)
- -->
- (remove 2)
- (modify 3 ^going w ^went w))
-
-(p name2082
- (location ^name kitchen)
- (portal ^name rdoor ^door closed)
- -->
- (write (crlf) |The refrigirator door is closed.|))
-
-(p name2083
- (location ^name kitchen)
- (portal ^name rdoor ^door open)
- -->
- (write (crlf) |The door of the ice box is open.|))
-
-(p name2084
- (location ^name kitchen)
- (portal ^name rdoor ^door closed)
- (input open)
- -->
- (remove 3)
- (modify 2 ^door open))
-
-(p name2085
- (location ^name kitchen)
- (portal ^name rdoor ^door open)
- (input close)
--->
- (remove 3)
- (modify 2 ^door closed))
-
-(p name2086
- (location ^name kitchen)
- (portal ^name rdoor ^door open)
- (object ^name cube ^place frig)
- -->
- (write (crlf) |There is a small white cube in the refrigirator.|))
-
-(p name2087
- (location ^name kitchen)
- (portal ^name rdoor ^door open)
- (object ^name cube ^place frig)
- (input get cube)
- -->
- (remove 4)
- (write (crlf) |You have a cube.|)
- (modify 3 ^place held))
-
-(p name2088
- (location ^name kitchen)
- (status ^going u)
- -->
- (modify 2 ^going nil)
- (modify 1 ^ontop frig))
-
-(p name2089
- (location ^name kitchen ^ontop frig)
- -->
- (write (crlf) |You are ontop the refrigirator.|)
- (write (crlf) |Going down will put you on the floor, going south will put you in the duct.|))
-
-(p name2090
- (location ^name kitchen)
- (input mount)
- -->
- (remove 2)
- (modify 1 ^ontop frig))
-
-(p name2091
- (location ^name kitchen ^ontop frig)
- (status ^going s)
- (place ^name kitchen)
- -->
- (modify 2 ^going nil)
- (modify 3 ^visited t)
- (modify 1 ^name ductf2 ^ontop nil))
-
-(p name2092
- (location ^name dining_room)
- (place ^name dining room ^visited nil)
- -->
- (write (crlf) |You are in a large dining room.  The ceiling is very high.|)
- (write (crlf) |The hall is east.|))
-
-(p name2093
- (location ^name dining_room)
- (status ^going e)
- (place ^name dining_room)
- -->
- (modify 1 ^name  back_hall)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2094
- (location ^name upper_hall)
- (place ^name upper_hall ^visited nil)
- -->
- (write (crlf) |You are at the upper hall.  You can see down the|)
- (write (crlf) |first steps of some stairs.  A circular staircase|)
- (write (crlf) |continues up.|)
- (write (crlf) | |)
- (write (crlf) |There is a dark room to the south,|)
- (write (crlf) |a hall to the west, a stone wall to the east,|)
- (write (crlf) |and another room to the north.|))
-
-(p name2095
- (location ^name upper_hall)
- (object ^name stairs ^state collapsed)
- (status ^going d)
- -->
- (modify 3 ^going nil)
- (write (crlf) |The stairs are collapsed.|))
-
-(p name2096
- (location ^name upper_hall)
- (status ^going d)
- (place ^name upper_hall)
- (object ^name stairs ^state whole)
- -->
- (modify 1 ^name  stairs)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2097
- (location ^name upper_hall)
- (status ^going s)
- (place ^name upper_hall)
- -->
- (modify 1 ^name  dark_room)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2098
- (location ^name upper_hall)
- (status ^going w)
- (place ^name upper_hall)
- -->
- (modify 1 ^name  long_hall)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2099
- (location ^name upper_hall)
- (status ^going n)
- (place ^name upper_hall)
- -->
- (modify 1 ^name  dull_room)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2100
- (location ^name upper_hall)
- (status ^going e)
- (place ^name upper_hall)
- (portal ^name wall ^door open)
- -->
- (modify 1 ^name  secret_room)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2101
- (location ^name upper_hall)
- (portal ^name wall ^door closed)
- (input << move pull get >> brick)
- -->
- (remove 3)
- (write (crlf) |The brick moves, but can't be removed from the wall.|)
- (write (crlf) |A secret panel in the wall opens!|)
- (write (crlf) |There is a room ahead.|)
- (modify 2 ^door open))
-
-(p name2102
- (location ^name upper_hall)
- (input close wall)
- (portal ^name wall ^door open)
- -->
- (remove 2)
- (modify 3 ^door closed)
- (write (crlf) |The wall closes.|))
-
-(p name2103
- (location ^name upper_hall)
- (status ^going u)
- (place ^name upper_hall)
- -->
- (modify 1 ^name  laboratory)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2104
- (location ^name upper_hall)
- (status ^sound on)
- -->
- (write (crlf) |You hear clanking and screams coming from the hall.|))
-
-(p name2105
- (location ^name laboratory)
- (location ^name laboratory)
- (place ^name laboratory ^visited nil)
- -->
- (write (crlf) |You are in the laboratory.  The most notable feature is a huge |)
- (write (crlf) |slab in the middle of the room.  There is a large |)
- (write (crlf) |lever switch.  The stairs are the only obvious exit.  The ceiling|)
- (write (crlf) |is a glass dome painted black, much too high to reach.|))
-
-(p name2106
- (location ^name laboratory)
- (status ^going d)
- (place ^name laboratory)
- -->
- (modify 1 ^name  upper_hall)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2107
- (location ^name laboratory)
- (status ^going w)
- (place ^name laboratory)
- (wall is down)
- -->
- (modify 1 ^name  bar)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2108
- (location ^name laboratory)
- (wall is down)
- -->
- (write (crlf) |The west wall has the shape of a running figure in it.|))
-
-(p name2109
- (location ^name laboratory)
- (input <B> << lever switch >>)
- -->
- (remove 2)
- (make monster live))
-
-(p name2110
- (location ^name laboratory)
- (input <x> lever)
- (object ^name lever ^state thrown)
- -->
- (remove 2)
- (write (crlf) |The lever is stuck.|))
-
-(p name2111
- (location ^name laboratory)
- (monster live)
- (object ^name monster ^place laboratory)
--(object ^name lever ^state thrown)
- -->
- (remove 2)
- (write (crlf) |The lights dim.  A massive door on the east wall|)
- (write (crlf) |opens revealing a bank of computers, generators, and misc.|)
- (write (crlf) |electronic gear.  The generators start to scream.|)
- (write (crlf) |The lights dim more.  Suddenly sparks start to fly from the|)
- (write (crlf) |equipment.  The body on the table starts to jerk around.|)
- (write (crlf) | |)
- (write (crlf) |As suddenly as it started, the generators turn off, the|)
- (write (crlf) |wall closes.  And everything returns to normal.....|)
- (write (crlf) |Then the body rises, removes its sheet and it is a monster.|)
- (write (crlf) | |)
- (write (crlf) |The monster approaches you and says 'Trick or Treat'|)
- (make object ^name lever ^state thrown))
-
-(p name2112
- (location ^name laboratory)
- (object ^name monster ^place laboratory)
--(object ^name lever ^state thrown)
- -->
- (write (crlf) |There is the shape of a body on the slab, covered with a sheet.|))
-
-(p name2113
- (location ^name laboratory)
- (object ^name monster ^place laboratory)
- (object ^name candy ^place held)
- (object ^name lever ^state thrown)
- (input give candy)
- -->
- (remove 3)
- (remove 2)
- (remove 5)
- (write (crlf) |The monster is pleased.|
-	 |He eats the candy, walks through the west wall|)
- (write (crlf) |and disappears.|)
- (make wall is down))
-
-(p name2114
- (location ^name laboratory)
- (object ^name monster ^place laboratory)
- (object ^name lever ^state thrown)
- (input <x> monster)
- -->
- (remove 2)
- (remove 4)
- (write (crlf) |The monster is frightened and holds his breath until he turns|)
- (write (crlf) |blue.  He then disappears.|))
-
-(p name2115
- (location ^name laboratory)
- (object ^name lever ^state thrown)
- -->
- (write (crlf) |The lever has been thrown, and is stuck in that position.|))
-
-(p name2116
- (location ^name laboratory)
- (object ^name football ^place held)
- (input kick football)
- -->
- (remove 3)
- (write (crlf) |The football goes crashing through the glass dome.|)
- (modify 2 ^place lawn ^side in ^east 7 ^north 4)
- (make object ^name dome ^state broken))
-
-(p name2117
- (location ^name laboratory)
- (object ^name football ^place held)
- (object ^name rope ^state tied ^tied football)
- (input kick football <p>)
- -->
- (remove 4)
- (write (crlf) |Kicking the football tears the rope off of it.|)
- (write (crlf) |The football goes crashing through the glass dome.|)
- (modify 3 ^state untied)
- (modify 2 ^place lawn ^side in ^east 7 ^north 4)
- (make object ^name dome ^state broken))
-
-(p name2118
- (location ^name laboratory)
- (object ^name Dracula ^place laboratory)
- (object ^name dome ^state broken)
- -->
- (remove 2)
- (write (crlf) |The bat flies through the hole in the dome and escapes.|))
-
-(p name2119
- (location ^name laboratory)
- (object ^name Dracula ^place laboratory)
- -->
- (write (crlf) |There is a bat flying around in the dome, too high to reach.|))
-
-(p name2120
- (location ^name laboratory)
- (object ^name Dracula ^place laboratory)
- (input get Dracula)
- -->
- (remove 3)
- (write (crlf) |I said the bat was too high to reach, even on a stool.|))
-
-(p name2121
- (location ^name laboratory)
- (object ^name Dracula ^place laboratory)
- (input get bat)
- -->
- (remove 3)
- (write (crlf) |The bat is much too high for you to get.|))
-
-(p name2122
- (location ^name laboratory)
- (object ^name Dracula ^place laboratory)
- (object ^name dome ^state broken)
- (time ^morning t)
- -->
- (remove 2)
- (make object ^name ring ^place laboratory ^treasure t)
- (write (crlf) |The sun's rays cause the bat to shrivel.  Something falls to the floor.|))
-
-(p name2123
- (object ^name Dracula ^place laboratory)
- (object ^name dome ^state broken)
- (time ^morning t)
- -->
- (remove 1)
- (make object ^name ring ^place laboratory ^treasure t))
-
-(p name2124
- (location ^name laboratory)
- (object ^name monster ^place laboratory)
- (object ^name lever ^state thrown)
- (place ^name laboratory ^visited t)
- -->
- (write (crlf) |The monster is drooling on himself, saying 'Trick or Treat'|))
-
-(p name2125
- (location ^name laboratory)
- (object ^name monster ^place laboratory)
- (object ^name lever ^state thrown)
- (input give <x>)
- -->
- (remove 4)
- (write (crlf) |The monster doesn't like | <x> |.  |)
- (write (crlf) |He is getting very angry.|))
-
-(p name2126
- (location ^name laboratory)
- (object ^name monster ^place laboratory)
- (object ^name lever ^state thrown)
- (input give monster <x>)
- -->
- (remove 4)
- (make input give <x>))
-
-(p name2127
- (location ^name laboratory)
- (object ^name monster ^place laboratory)
- (object ^name lever ^state thrown)
- (input give <x> to monster)
- -->
- (remove 4)
- (make input give <x>))
-
-(p name2128
- (location ^name laboratory)
- (object ^name monster ^place laboratory)
- (object ^name lever ^state thrown)
- (input throw <x>)
- -->
- (remove 4)
- (make input give <x>))
-
-(p name2129
- (location ^name laboratory)
- (object ^name dome ^state broken)
- (time ^morning t)
- -->
- (write (crlf) |Light shows throught the hole.|))
-
-(p name2130
- (location ^name laboratory)
- (object ^name matches ^place laboratory)
- (time ^morning t)
- -->
- (write (crlf) |Even in the sun light the matches don't dry.|)
- (write (crlf) |The laboratory is damp and musty.|))
-
-(p name2131
- (location ^name laboratory)
- (input dry matches)
- -->
- (remove 2)
- (write (crlf) |The laboratory is very damp.|))
-
-(p name2132
- (location ^name laboratory)
- (object ^name dome ^state broken)
- (time ^morning nil)
- -->
- (write (crlf) |You can see the moon through the dome.|))
-
-(p name2133
- (location ^name laboratory)
- (object ^name monster ^place laboratory)
- (object ^name cube ^place held)
- (object ^name lever ^state thrown)
- (input give cube)
- -->
- (remove 2)
- (remove 3)
- (remove 5)
- (write (crlf) |The monster eats the cube.  He then starts saying 'ohhh, ahhhh'.|)
- (write (crlf) |'Out of sight man.' Then he jumps straight up through the dome.|)
- (make object ^name dome ^state broken))
-
-(p name2134
- (location ^name bar)
- (location ^name bar)
- (place ^name bar ^visited nil)
- -->
- (write (crlf) |You are in a bar.  There isn't any booze.|))
-
-(p name2135
- (location ^name bar)
- (status ^going e)
- (place ^name bar)
- -->
- (modify 1 ^name  laboratory)
- (modify 2 ^going nil)
- (modify 3 ^visited t))
-
-(p name2136
- (location ^name wine_racks)
- -->
- (write (crlf) |You are in rows of wine racks that stretch out of sight in all directions.|))
-
-(p name2137
- (location ^name wine_racks ^east <e>)
- (status ^going e)
- -->
- (remove 1)
- (modify 2 ^going nil)
- (modify 1 ^name wine_racks ^east (compute 1 + <e>)))
-
diff --git a/contrib/ops/mab.ops b/contrib/ops/mab.ops
deleted file mode 100644
index 9632ad56e7d15de8ba8134cc0ba3c8c7720bf05c..0000000000000000000000000000000000000000
--- a/contrib/ops/mab.ops
+++ /dev/null
@@ -1,174 +0,0 @@
-(literalize start)
-
-(literalize monkey
-	at
-	on
-	holds)
-
-(literalize object
-	name
-	at
-	weight
-	on)
-
-(literalize goal
-	status
-	type
-	object
-	to)
-
-(p mb1
-	(goal ^status active ^type holds ^object <w>)
-	(object ^name <w> ^at <p> ^on ceiling)
-    -->
-	(make goal ^status active ^type move ^object ladder ^to <p>))
-
-
-(p mb2
-	(goal ^status active ^type holds ^object <w>)
-	(object ^name <w> ^at <p> ^on ceiling)
-	(object ^name ladder ^at <p>)
-    -->
-	(make goal ^status active ^type on ^object ladder))
-
-(p mb4
-	(goal ^status active ^type holds ^object <w>)
-	(object ^name <w> ^at <p> ^on ceiling)
-	(object ^name ladder ^at <p>)
-	(monkey ^on ladder ^holds nil)
-    -->
-	(write (crlf) grab <w>)
-	(modify 4 ^holds <w>)
-	(modify 1 ^status satisfied))
-
-(p mb3
-	(goal ^status active ^type holds ^object <w>)
-	(object ^name <w> ^at <p> ^on ceiling)
-	(object ^name ladder ^at <p>)
-	(monkey ^on ladder)
-    -->
-	(make goal ^status active ^type holds ^object nil))
-
-(p mb5
-	(goal ^status active ^type holds ^object <w>)
-	(object ^name <w> ^at <p> ^on floor)
-    -->
-	(make goal ^status active ^type walk-to ^object <p>))
-
-(p mb7
-	(goal ^status active ^type holds ^object <w>)
-	(object ^name <w> ^at <p> ^on floor)
-	(monkey ^at <p> ^holds nil)
-    -->
-	(write (crlf) grab <w>)
-	(modify 3 ^holds <w>)
-	(modify 1 ^status satisfied))
-
-(p mb6
-	(goal ^status active ^type holds ^object <w>)
-	(object ^name <w> ^at <p> ^on floor)
-	(monkey ^at <p>)
-    -->
-	(make goal ^status active ^type holds ^object nil))
-
-(p mb8
-	(goal ^status active ^type move ^object <o> ^to <p>)
-	(object ^name <o> ^weight light ^at <> <p>)
-    -->
-	(make goal ^status active ^type holds ^object <o>))
-
-
-(p mb9
-	(goal ^status active ^type move ^object <o> ^to <p>)
-	(object ^name <o> ^weight light ^at <> <p>)
-	(monkey ^holds <o>)
-    -->
-	(make goal ^status active ^type walk-to ^object <p>))
-
-
-(p mb10
-	(goal ^status active ^type move ^object <o> ^to <p>)
-	(object ^name <o> ^weight light ^at <p>)
-    -->
-	(modify 1 ^status satisfied))
-
-
-(p mb11
-	(goal ^status active ^type walk-to ^object <p>)
-    -->
-	(make goal ^status active ^type on ^object floor))
-
-(p mb12
-	(goal ^status active ^type walk-to ^object <p>)
-	(monkey ^on floor ^at {<c> <> <p>} ^holds nil)
-    -->
-	(write (crlf) walk to <p>)
-	(modify 2 ^at <p>)
-	(modify 1 ^status satisfied))
-
-
-(p mb13
-	(goal ^status active ^type walk-to ^object <p>)
-	(monkey ^on floor ^at {<c> <> <p>} ^holds {<w> <> nil})
-	(object ^name <w>)
-    -->
-	(write (crlf) walk to <p>)
-	(modify 2 ^at <p>)
-	(modify 3 ^at <p>)
-	(modify 1 ^status satisfied))
-
-(p mb14
-	(goal ^status active ^type on ^object floor)
-	(monkey ^on {<x> <> floor})
-    -->
-	(write (crlf) jump onto the floor)
-	(modify 2 ^on floor)
-	(modify 1 ^status satisfied))
-
-(p mb15
-	(goal ^status active ^type on ^object <o>)
-	(object ^name <o> ^at <p>)
-    -->
-	(make goal ^status active ^type walk-to ^object <p>))
-
-
-
-(p mb16
-	(goal ^status active ^type on ^object <o>)
-	(object ^name <o> ^at <p>)
-	(monkey ^at <p>)
-    -->
-	(make goal ^status active ^type holds ^object nil))
-
-
-(p mb17
-	(goal ^status active ^type on ^object <o>)
-	(object ^name <o> ^at <p>)
-	(monkey ^at <p> ^holds nil)
-    -->
-	(write (crlf) climb onto <o>)
-	(modify 3 ^on <o>)
-	(modify 1 ^status satisfied))
-
-(p mb18
-	(goal ^status active ^type holds ^object nil)
-	(monkey ^holds {<x> <> nil})
-    -->
-	(write (crlf) drop <x>)
-	(modify 2 ^holds nil)
-	(modify 1 ^status satisfied))
-
-(p mb19
-	(goal ^status active)
-    -->
-	(modify 1 ^status not-processed))
-
-(p t1
-	(start)
-    -->
-	(make monkey ^at 5-7 ^on couch)
-	(make object ^name couch ^at 5-7 ^weight heavy)
-	(make object ^name bananas ^on ceiling ^at 2-2)
-	(make object ^name ladder ^on floor ^at 9-5 ^weight light)
-	(make goal ^status active ^type holds ^object bananas))
-
diff --git a/contrib/ops/myw.ops b/contrib/ops/myw.ops
deleted file mode 100644
index f78a299b33e9df44829aaea7b6d92a734a964a86..0000000000000000000000000000000000000000
--- a/contrib/ops/myw.ops
+++ /dev/null
@@ -1,9029 +0,0 @@
-(literalize unit unit-name file-name)
-
-(literalize pin net-name pin-name external-net-name external-pin-name pin-left-x pin-left-y fixed-pin pin-x pin-y pin-layer pin-layer-constraint pin-channel-side pin-is-attached)
-
-(literalize channel channel-bottom-left-x channel-bottom-left-y channel-top-right-x channel-top-right-y channel-width channel-length no-of-left-pins no-of-right-pins no-of-bottom-pins no-of-top-pins right-fixed left-fixed bottom-fixed top-fixed channel-type no-of-fixed-sides)
-
-(literalize net net-name parent-name net-no-of-pins net-left-x net-left-y net-right-x net-right-y no-of-left-pins no-of-right-pins no-of-top-pins no-of-bottom-pins net-is-routed left-most-pin-name right-most-pin-name bottom-most-pin-name top-most-pin-name fixed-net net-layer external-net-name no-of-inter max-no-of-via)
-
-(literalize layer-info layer-name layer-order layer-priority)
-
-(literalize context present previous saved)
-
-(literalize ff net-name pin-name grid-layer grid-x grid-y came-from can-chng-layer)
-
-(literalize next-net-to-be-routed net-name no-of-attached-pins criteria)
-
-(literalize to-be-routed net-name no-of-attached-pins)
-
-(literalize occupied x y m)
-
-(literalize constraint constraint-type constraint-relation channel-side constraint-reason net-name-1 net-name-2 pin-name-1 pin-name-2 seg-id-1 seg-id-2)
-
-(literalize congestion direction coordinate no-of-nets extra-nets como)
-
-(literalize intersection net-name direction min max)
-
-(literalize horizontal min max com compo commo layer status min-net max-net net-name pin-name)
-
-(literalize vertical min max com compo commo layer status min-net max-net net-name pin-name)
-
-(literalize horizontal-s net-name min max com id top-count bot-count sum difference absolute side)
-
-(literalize vertical-s net-name min max com id top-count bot-count sum difference absolute side)
-
-(literalize total net-name row-col coor level-pins total-pins cong min-xy max-xy last-pin last-xy nets)
-
-(literalize tree net-name orientation com min max count id)
-
-(vector-attribute nets)
-
-(p p327
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>)
-    (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max { <hmax> >= <gx> > <min> } ^com 1 ^id <id>)
-  - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side bottom)
-    (constraint ^constraint-type vertical ^seg-id-1 <id>)
-    (total ^net-name <> <nn>)
-  - (total-verti <nn>)
-  -->
-    (remove <t>)
-)
-
-(p p328
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>)
-    (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> < <max> } ^max { <hmax> >= <gx> } ^com <lr> ^id <id>)
-  - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <> <id>)
-    (last-row <lr>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side top)
-    (constraint ^constraint-type vertical ^seg-id-2 <id>)
-    (total ^net-name <> <nn>)
-  - (total-verti <nn>)
-  -->
-    (remove <t>)
-)
-
-(p p329
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> })
-    (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> > <min> } ^com 1 ^id <id>)
-  - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side left)
-    (constraint ^constraint-type horizontal ^seg-id-1 <id>)
-    (total ^net-name <> <nn>)
-  - (total-verti <nn>)
-  -->
-    (remove <t>)
-)
-
-(p p330
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> })
-    (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> < <max> } ^max { <vmax> >= <gy> } ^com <lc> ^id <id>)
-  - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <> <id>)
-    (last-col <lc>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side right)
-    (constraint ^constraint-type horizontal ^seg-id-2 <id>)
-    (total ^net-name <> <nn>)
-  - (total-verti <nn>)
-  -->
-    (remove <t>)
-)
-
-(p p331
-    { <c> (context ^present modify-total) }
-  -->
-    (modify <c> ^present delete-total)
-)
-
-(p p332
-    { <c> (context ^present delete-total) }
-  - (total)
-  -->
-    (remove <c>)
-    (make context ^previous find-no-of-pins-on-a-row-col)
-)
-
-(p p333
-    { <c> (context ^present extend-total) }
-    (last-row <lr>)
-  -->
-    (make maximum-total 0 0 0 1 0 <lr> 0)
-    (make merge-direction left)
-    (modify <c> ^present merge)
-    (make eliminate-total)
-)
-
-(p p334
-    { <c> (context ^present delete-total) }
-  -->
-    (modify <c> ^present extend-total)
-)
-
-(p p335
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>)
-    (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max { <hmax> >= <gx> } ^com 1 ^id <id> ^absolute <a> ^sum <s>)
-  - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>)
-  - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <hmin> ^max-xy <hmax> ^last-pin checked)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side bottom)
-  -->
-    (make (substr <t> 1 inf) ^min-xy <hmin> ^max-xy <hmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <hmin> <hmax>)
-)
-
-(p p336
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>)
-    (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max { <hmax> >= <gx> } ^com <lr> ^id <id> ^absolute <a> ^sum <s>)
-  - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <> <id>)
-  - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <hmin> ^max-xy <hmax> ^last-pin checked)
-    (last-row <lr>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side top)
-  -->
-    (make (substr <t> 1 inf) ^min-xy <hmin> ^max-xy <hmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <hmin> <hmax>)
-)
-
-(p p337
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> })
-    (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> } ^com 1 ^id <id> ^absolute <a> ^sum <s>)
-  - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>)
-  - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <vmin> ^max-xy <vmax> ^last-pin checked)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side left)
-  -->
-    (make (substr <t> 1 inf) ^min-xy <vmin> ^max-xy <vmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <vmin> <vmax>)
-)
-
-(p p338
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> })
-    (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> } ^com <lc> ^id <id> ^absolute <a> ^sum <s>)
-  - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <> <id>)
-  - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <vmin> ^max-xy <vmax> ^last-pin checked)
-    (last-col <lc>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side right)
-  -->
-    (make (substr <t> 1 inf) ^min-xy <vmin> ^max-xy <vmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <vmin> <vmax>)
-)
-
-(p p339
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>)
-    (horizontal-s ^net-name <nn> ^min 1 ^max { <hmax> >= <gx> } ^com <com> ^id <id> ^absolute <a> ^sum <s>)
-  - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>)
-  - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy 1 ^max-xy <hmax> ^last-pin checked)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x 0 ^pin-y <com> ^pin-channel-side left)
-  -->
-    (make (substr <t> 1 inf) ^min-xy 1 ^max-xy <hmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> 1 <hmax>)
-)
-
-(p p340
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>)
-    (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max <lc> ^com <com> ^id <id> ^absolute <a> ^sum <s>)
-  - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>)
-  - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <hmin> ^max-xy <lc> ^last-pin checked)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-y <com> ^pin-channel-side right)
-    (last-col <lc>)
-  -->
-    (make (substr <t> 1 inf) ^min-xy <hmin> ^max-xy <lc> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <hmin> <lc>)
-)
-
-(p p341
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> })
-    (vertical-s ^net-name <nn> ^min 1 ^max { <vmax> >= <gy> } ^com <com> ^id <id> ^absolute <a> ^sum <s>)
-  - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>)
-  - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy 1 ^max-xy <vmax> ^last-pin checked)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x <com> ^pin-channel-side bottom)
-  -->
-    (make (substr <t> 1 inf) ^min-xy 1 ^max-xy <vmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> 1 <vmax>)
-)
-
-(p p342
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> })
-    (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max <lr> ^com <com> ^id <id> ^absolute <a> ^sum <s>)
-  - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>)
-  - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <vmin> ^max-xy <lr> ^last-pin checked)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x <com> ^pin-channel-side top)
-    (last-row <lr>)
-  -->
-    (make (substr <t> 1 inf) ^min-xy <vmin> ^max-xy <lr> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <vmin> <lr>)
-)
-
-(p p343
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (total ^net-name <nn> ^row-col <rc> ^coor <y> ^last-pin checked)
-  -->
-    (remove <t>)
-)
-
-(p p344
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-  -->
-    (remove <t>)
-)
-
-(p p345
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (net ^net-name <nn> ^net-no-of-pins 2)
-  -->
-    (modify <t> ^last-pin checked ^nets <nn> <min> <max>)
-)
-
-(p p346
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-  - (total ^last-pin checked)
-  -->
-    (modify <t> ^last-pin checked ^nets <nn> <min> <max>)
-)
-
-(p p347
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) }
-    (last-col <lc>)
-    (horizontal-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { >= <min> <> <lc> } ^com <y> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-x 0 ^pin-y <y>)
-  - (pin ^net-name <nn> ^pin-y <y> ^pin-channel-side right)
-  -->
-    (remove <t>)
-)
-
-(p p348
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <tmin> ^max-xy <max>) }
-    (last-col <lc>)
-    (horizontal-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { <maxs> <> <lc> } ^com <y> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-x 0 ^pin-y <y>)
-    (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com { <min> > 1 <= <maxs> })
-  - (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com < <min>)
-    { <h> (horizontal ^net-name <nn1> ^min 0 ^max { <hmax> < <min> } ^com <y> ^layer <lay>) }
-    { <ff> (ff ^net-name <nn1> ^grid-x <hmax> ^grid-y <y> ^grid-layer <lay> ^came-from west) }
-    { <h1> (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <y> ^layer <lay>) }
-  - (pin ^net-name <nn> ^pin-y <y>)
-  - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <y> ^max >= <y> ^com <min> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <min> ^max >= <min> ^com <y> ^layer <lay>)
-  -->
-    (remove <t>)
-    (modify <h> ^max <min>)
-    (modify <h1> ^min <min> ^min-net <nn1>)
-    (modify <ff> ^grid-x <min> ^can-chng-layer nil)
-)
-
-(p p349
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) }
-    (last-col <lc>)
-    (horizontal-s ^net-name { <nn1> <> <nn> } ^min { <= <max> <> 1 } ^max <lc> ^com <y> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-y <y> ^pin-channel-side right)
-  - (pin ^net-name <nn> ^pin-y <y> ^pin-channel-side left)
-  -->
-    (remove <t>)
-)
-
-(p p350
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <tmax>) }
-    (last-col <lc>)
-    (horizontal-s ^net-name { <nn1> <> <nn> } ^min { <mins> <> 1 } ^max <lc> ^com <y> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-y <y> ^pin-channel-side right)
-    (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com { <max> >= <mins> < <lc> })
-  - (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com > <max>)
-    { <h> (horizontal ^net-name <nn1> ^min { <hmin> > <max> } ^max <garb> ^com <y> ^layer <lay>) }
-    { <ff> (ff ^net-name <nn1> ^grid-x <hmin> ^grid-y <y> ^grid-layer <lay> ^came-from east) }
-    { <h1> (horizontal ^net-name nil ^min < <max> ^max <hmin> ^com <y> ^layer <lay>) }
-  - (pin ^net-name <nn> ^pin-y <y>)
-  - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <y> ^max >= <y> ^com <max> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <max> ^max >= <max> ^com <y> ^layer <lay>)
-  -->
-    (remove <t>)
-    (modify <h> ^min <max>)
-    (modify <h1> ^max <max> ^max-net <nn1>)
-    (modify <ff> ^grid-x <max> ^can-chng-layer nil)
-)
-
-(p p351
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) }
-    (last-row <lr>)
-    (vertical-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { >= <min> <> <lr> } ^com <x> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x <x> ^pin-channel-side top)
-  -->
-    (remove <t>)
-)
-
-(p p352
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <tmin> ^max-xy <max>) }
-    (last-row <lr>)
-    (vertical-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { <maxs> <> <lr> } ^com <x> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side bottom)
-    (horizontal ^net-name <nn> ^min <= <x> ^max <x> ^com { <min> > 1 <= <maxs> })
-  - (horizontal ^net-name <nn> ^min <= <x> ^max <x> ^com < <min>)
-    { <v> (vertical ^net-name <nn1> ^min 0 ^max { <vmax> < <min> } ^com <x> ^layer <lay>) }
-    { <ff> (ff ^net-name <nn1> ^grid-x <x> ^grid-y <vmax> ^grid-layer <lay> ^came-from south) }
-    { <v1> (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <x> ^layer <lay>) }
-  - (pin ^net-name <nn> ^pin-x <x>)
-  - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <min> ^max >= <min> ^com <x>)
-  - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <x> ^max >= <x> ^com <min>)
-  -->
-    (remove <t>)
-    (modify <v> ^max <min>)
-    (modify <v1> ^min <min> ^min-net <nn1>)
-    (modify <ff> ^grid-y <min> ^can-chng-layer nil)
-)
-
-(p p353
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) }
-    (last-row <lr>)
-    (vertical-s ^net-name { <nn1> <> <nn> } ^min { <= <max> <> 1 } ^max <lr> ^com <x> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x <x> ^pin-channel-side bottom)
-  -->
-    (remove <t>)
-)
-
-(p p354
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <tmax>) }
-    (last-row <lr>)
-    (vertical-s ^net-name { <nn1> <> <nn> } ^min { <mins> <> 1 } ^max <lr> ^com <x> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side top)
-    (horizontal ^net-name <nn> ^min <= <x> ^max >= <x> ^com { <max> >= <mins> < <lr> })
-  - (horizontal ^net-name <nn> ^min <= <x> ^max >= <x> ^com > <max>)
-    { <v> (vertical ^net-name <nn1> ^min { <vmin> > <max> } ^max <garb> ^com <x> ^layer <lay>) }
-    { <ff> (ff ^net-name <nn1> ^grid-x <x> ^grid-y <vmin> ^grid-layer <lay> ^came-from north) }
-    { <v1> (vertical ^net-name nil ^min < <vmin> ^max <vmin> ^com <x> ^layer <lay>) }
-  - (pin ^net-name <nn> ^pin-x <x>)
-  - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <max> ^max >= <max> ^com <x>)
-  - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <x> ^max >= <x> ^com <max>)
-  -->
-    (remove <t>)
-    (modify <v> ^min <max>)
-    (modify <v1> ^max <max> ^max-net <nn1>)
-    (modify <ff> ^grid-y <max> ^can-chng-layer nil)
-)
-
-(p p355
-    (context ^present extend-total)
-  - (switch-box)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-xy <id>) }
-    (last-row > <y>)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>)
-  - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>)
-  - (horizontal ^net-name <nn> ^min <= <min> ^max >= <min> ^com <y>)
-  - (horizontal ^net-name <nn> ^min <= <max> ^max >= <max> ^com <y>)
-  - (horizontal ^net-name <nn> ^min >= <min> ^max <= <max> ^com <y>)
-    (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com > <y>)
-  - (ff ^net-name <nn> ^grid-x { >= <min> <= <max> } ^grid-y <y> ^pin-name >= 1000)
-  -->
-    (modify <t> ^coor (compute <y> + 1))
-)
-
-(p p356
-    (context ^present extend-total)
-  - (switch-box)
-    { <t> (total ^net-name <nn> ^row-col row ^coor { <y> > 0 } ^min-xy <min> ^max-xy <max> ^last-xy <id>) }
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <id>)
-    (last-row <lr>)
-  - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>)
-  - (horizontal ^net-name <nn> ^min <= <min> ^max >= <min> ^com <y>)
-  - (horizontal ^net-name <nn> ^min <= <max> ^max >= <max> ^com <y>)
-  - (horizontal ^net-name <nn> ^min >= <min> ^max <= <max> ^com <y>)
-    (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com < <y>)
-  - (ff ^net-name <nn> ^grid-x { >= <min> <= <max> } ^grid-y <y> ^pin-name >= 1000)
-  -->
-    (modify <t> ^coor (compute <y> - 1))
-)
-
-(p p357
-    (context ^present extend-total)
-  - (switch-box)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-xy <id>) }
-    (last-col > <x>)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>)
-  - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>)
-  - (vertical ^net-name <nn> ^min <= <min> ^max >= <min> ^com <x>)
-  - (vertical ^net-name <nn> ^min <= <max> ^max >= <max> ^com <x>)
-  - (vertical ^net-name <nn> ^min >= <min> ^max <= <max> ^com <x>)
-    (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com > <x>)
-  - (ff ^net-name <nn> ^grid-x <x> ^grid-y { >= <min> <= <max> } ^pin-name >= 1000)
-  -->
-    (modify <t> ^coor (compute <x> + 1))
-)
-
-(p p358
-    (context ^present extend-total)
-  - (switch-box)
-    { <t> (total ^net-name <nn> ^row-col col ^coor { <x> > 0 } ^min-xy <min> ^max-xy <max> ^last-xy <id>) }
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <id>)
-    (last-col <lc>)
-  - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>)
-  - (vertical ^net-name <nn> ^min <= <min> ^max >= <min> ^com <x>)
-  - (vertical ^net-name <nn> ^min <= <max> ^max >= <max> ^com <x>)
-  - (vertical ^net-name <nn> ^min >= <min> ^max <= <max> ^com <x>)
-    (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com < <x>)
-  - (ff ^net-name <nn> ^grid-x <x> ^grid-y { >= <min> <= <max> } ^pin-name >= 1000)
-  -->
-    (modify <t> ^coor (compute <x> - 1))
-)
-
-(p p359
-    (context ^present extend-total)
-    (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-xy <id>)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>)
-    (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> < <y> } ^grid-layer <lay> ^pin-name <pn>) }
-    { <v> (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { <vmax> >= <y> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <y> ^max >= <y> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <y> ^layer <lay>)
-  -->
-    (make vertical ^min <y> ^max <vmax> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>)
-    (modify <v> ^max <gy> ^max-net <nn>)
-    (make vertical ^min <gy> ^max <y> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>)
-    (modify <ff> ^grid-y <y> ^came-from south ^can-chng-layer nil)
-)
-
-(p p360
-    (context ^present extend-total)
-    (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-xy <id>)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <id>)
-    (last-row <lr>)
-    (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> > <y> } ^grid-layer <lay> ^pin-name <pn>) }
-    { <v> (vertical ^net-name nil ^min { <vmin> <= <y> } ^max { <vmax> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <y> ^max >= <y> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <y> ^layer <lay>)
-  -->
-    (make vertical ^min <gy> ^max <vmax> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>)
-    (modify <v> ^max <y> ^max-net <nn>)
-    (make vertical ^min <y> ^max <gy> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>)
-    (modify <ff> ^grid-y <y> ^came-from north ^can-chng-layer nil)
-)
-
-(p p361
-    (context ^present extend-total)
-    (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-xy <id>)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>)
-    (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx> < <x> } ^grid-y { <gy> >= <min> <= <max> } ^grid-layer <lay> ^pin-name <pn>) }
-    { <v> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> >= <x> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <x> ^max >= <x> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <x> ^layer <lay>)
-  -->
-    (make horizontal ^min <x> ^max <hmax> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>)
-    (modify <v> ^max <gx> ^max-net <nn>)
-    (make horizontal ^min <gx> ^max <x> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>)
-    (modify <ff> ^grid-x <x> ^came-from west ^can-chng-layer nil)
-)
-
-(p p362
-    (context ^present extend-total)
-    (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-xy <id>)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <id>)
-    (last-col <lc>)
-    (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx> > <x> } ^grid-y { <gy> >= <min> <= <max> } ^grid-layer <lay> ^pin-name <pn>) }
-    { <v> (horizontal ^net-name nil ^min { <hmin> <= <x> } ^max { <hmax> >= <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <x> ^max >= <x> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <x> ^layer <lay>)
-  -->
-    (make horizontal ^min <gx> ^max <hmax> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>)
-    (modify <v> ^max <x> ^max-net <nn>)
-    (make horizontal ^min <x> ^max <gx> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>)
-    (modify <ff> ^grid-x <x> ^came-from east ^can-chng-layer nil)
-)
-
-(p p490
-    { <c> (context ^present separate) }
-  -->
-    (modify <c> ^present reconnect)
-)
-
-(p p491
-    { <c> (context ^present reconnect) }
-  -->
-    (modify <c> ^present form-verti)
-)
-
-(p p492
-    { <c> (context ^present form-verti) }
-  -->
-    (modify <c> ^present partial-route)
-)
-
-(p p493
-    { <c> (context ^present partial-route) }
-  -->
-    (modify <c> ^present extend-pins)
-)
-
-(p p494
-    { <c1> (context ^present extend-pins) }
-  -->
-    (modify <c1> ^present nil ^previous extend-pins)
-)
-
-(p p495
-    { <c1> (context ^previous extend-pins) }
-  -->
-    (make switch-box)
-    (make context ^present propagate-constraint)
-    (remove <c1>)
-)
-
-(p p496
-    { <c1> (context ^previous extend-pins) }
-    (channel ^no-of-left-pins 0 ^no-of-right-pins 0)
-  -->
-    (remove <c1>)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p497
-    { <c1> (context ^previous extend-pins) }
-    (channel ^no-of-bottom-pins 0 ^no-of-top-pins 0)
-  -->
-    (remove <c1>)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p498
-    (context ^previous propagate-constraint)
-    (net ^net-is-routed <> yes)
-  -->
-    (remove 1)
-    (make context ^present lshape1)
-)
-
-(p p499
-    (context ^present lshape1)
-  -->
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p500
-    { <c> (context ^previous find-no-of-pins-on-a-row-col) }
-  - (total)
-  - (extend-ff-tried)
-  -->
-    (remove <c>)
-    (make context ^present lshape4)
-)
-
-(p p501
-    { <c> (context ^present lshape4) }
-  -->
-    (remove <c>)
-    (make extend-ff-tried)
-    (make context ^present extend-ff)
-)
-
-(p p502
-    { <c> (context ^present extend-ff) }
-  -->
-    (remove <c>)
-    (make context ^previous extend-ff)
-)
-
-(p p503
-    { <c> (context ^previous extend-ff) }
-  - (extended-ff)
-  -->
-    (remove <c>)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p504
-    { <c> (context ^previous extend-ff) }
-    { <e> (extended-ff) }
-    { <ex> (extend-ff-tried) }
-  -->
-    (remove <c> <e> <ex>)
-    (make context ^present find-no-of-pins-on-a-row-col)
-    (make goal cleanup extended-ff)
-)
-
-(p p505
-    (context ^previous find-no-of-pins-on-a-row-col)
-  - (total)
-    (extend-ff-tried)
-  - (total-verti)
-  -->
-    (remove 1)
-    (make context ^present find-no-of-vcg-hcg)
-    (make goal cleanup counted-verti)
-)
-
-(p p506
-    (context ^previous find-no-of-pins-on-a-row-col)
-  - (total)
-    (total-verti)
-  - (verti-has-loop)
-  -->
-    (remove 1)
-    (make verti-has-loop)
-    (make context ^present choose-between-total-verti)
-)
-
-(p p507
-    (context ^previous find-no-of-pins-on-a-row-col)
-  - (total)
-    (total-verti)
-    (verti-has-loop)
-  -->
-    (make context ^present extend-h-v-s)
-    (make goal cleanup total-verti)
-    (make goal cleanup counted-verti)
-    (make goal cleanup extend-ff-tried)
-    (remove 1 3)
-)
-
-(p p508
-    (context ^present choose-between-total-verti)
-  - (total-verti ^4 > 0)
-  -->
-    (modify 1 ^present extend-h-v-s)
-    (make goal cleanup counted-verti)
-)
-
-(p p509
-    (context ^previous find-no-of-vcg-hcg)
-  - (total-verti)
-  -->
-    (remove 1)
-    (make context ^present extend-h-v-s)
-)
-
-(p p510
-    (context ^present loose-constraint)
-  -->
-    (make context ^present lshape2)
-    (remove 1)
-)
-
-(p p511
-    (context ^present lshape2)
-  -->
-    (modify 1 ^present lshape3)
-)
-
-(p p512
-    (context ^present lshape3)
-  -->
-    (remove 1)
-    (make context ^present random0)
-)
-
-(p p513
-    (context ^present random0)
-  -->
-    (remove 1)
-    (make context ^present random1)
-)
-
-(p p514
-    (context ^present remove-routed-net-segments)
-  - (net ^net-is-routed <> yes)
-  - (horizontal ^net-name <> nil ^status nil)
-  - (vertical ^net-name <> nil ^status nil)
-  -->
-    (write (crlf) | Finished with the routing.|)
-    (halt)
-)
-
-(p p1
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^com <min>)
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top)
-  - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>)
-    (pin ^net-name <> <nn> ^pin-x <min> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x { < <px> > <min> })
-    (pin ^net-name <nn> ^pin-x > <px> ^pin-channel-side top)
-  -->
-    (modify <h> ^min <px>)
-    (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p2
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^com <min>)
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom)
-  - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>)
-    (pin ^net-name <> <nn> ^pin-x <min> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x { < <px> > <min> })
-    (pin ^net-name <nn> ^pin-x > <px> ^pin-channel-side bottom)
-  -->
-    (modify <h> ^min <px>)
-    (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p3
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^com <max>)
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top)
-  - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>)
-    (pin ^net-name <> <nn> ^pin-x <max> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <px> })
-    (pin ^net-name <nn> ^pin-x < <px> ^pin-channel-side top)
-  -->
-    (modify <h> ^max <px>)
-    (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p4
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^com <max>)
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom)
-  - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>)
-    (pin ^net-name <> <nn> ^pin-x <max> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <px> })
-    (pin ^net-name <nn> ^pin-x < <px> ^pin-channel-side bottom)
-  -->
-    (modify <h> ^max <px>)
-    (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p5
-    (context ^present reconnect)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom)
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top)
-  - (pin ^pin-x <max> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^max <max>)
-)
-
-(p p6
-    (context ^present reconnect)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top)
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom)
-  - (pin ^pin-x <min> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^min <min>)
-)
-
-(p p7
-    (context ^present reconnect)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom)
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top)
-  - (pin ^pin-x <max> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^max <max>)
-)
-
-(p p8
-    (context ^present reconnect)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top)
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom)
-  - (pin ^pin-x <min> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^min <min>)
-)
-
-(p p9
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com>)
-    (horizontal-s ^net-name <nn> ^min { <min1> >= <min> } ^max { <max1> <= <max> } ^com <> <com>)
-    { <v> (vertical-s ^net-name <nn> ^com { <com1> >= <min1> <= <max1> }) }
-    (pin ^net-name <> <nn> ^pin-x <com1>)
-    (congestion ^direction col ^coordinate { <px> >= <min1> <= <max1> })
-  - (pin ^net-name <> <nn> ^pin-x <px>)
-  - (vertical-s ^com <px>)
-  -->
-    (modify <v> ^com <px>)
-)
-
-(p p10
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com>)
-    (horizontal-s ^net-name <nn> ^min { <min1> >= <min> <= <max> } ^max { <max1> >= <max> } ^com <> <com>)
-    { <v> (vertical-s ^net-name <nn> ^com { <com1> >= <min1> <= <max> }) }
-    (pin ^net-name <> <nn> ^pin-x <com1>)
-    (congestion ^direction col ^coordinate { <px> >= <min1> <= <max> })
-  - (pin ^net-name <> <nn> ^pin-x <px>)
-  - (vertical-s ^com <px>)
-  -->
-    (modify <v> ^com <px>)
-)
-
-(p p11
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>)
-    (horizontal-s ^net-name <nn> ^min { <min1> >= <min> } ^max { <max1> <= <max> } ^com <> <hcom>)
-  - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max1> })
-    { <v> (vertical-s ^net-name <nn> ^com { <vcom> < <min1> }) }
-  - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>)
-  -->
-    (modify <v> ^com <min1>)
-)
-
-(p p12
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>)
-    (horizontal-s ^net-name <nn> ^min { <min1> >= <min> } ^max { <max1> <= <max> } ^com <> <hcom>)
-  - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max1> })
-    { <v> (vertical-s ^net-name <nn> ^com { <vcom> > <max1> }) }
-  - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>)
-  -->
-    (modify <v> ^com <max1>)
-)
-
-(p p13
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>)
-    (horizontal-s ^net-name <nn> ^min { <min1> >= <min> <= <max> } ^max { <max1> >= <max> } ^com <> <hcom>)
-  - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max> })
-    { <v> (vertical-s ^net-name <nn> ^com { <vcom> < <min1> }) }
-  - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>)
-  -->
-    (modify <v> ^com <min1>)
-)
-
-(p p14
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>)
-    (horizontal-s ^net-name <nn> ^min { <min1> >= <min> <= <max> } ^max { <max1> >= <max> } ^com <> <hcom>)
-  - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max> })
-    { <v> (vertical-s ^net-name <nn> ^com { <vcom> > <max> }) }
-  - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>)
-  -->
-    (modify <v> ^com <max>)
-)
-
-(p p15
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min1> ^max <max1> ^id <id1>)
-    { <h> (horizontal-s ^net-name <nn> ^min <max1> ^max <max2> ^com <com> ^id <id2>) }
-    (horizontal-s ^net-name <nn> ^min <max2> ^max <max3> ^id <id3>)
-  - (horizontal-s ^net-name <nn> ^id { <> <id1> <> <id2> <> <id3> })
-    (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max1>)
-    (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max2>)
-  -->
-    (modify <h> ^min <min1> ^max <max3>)
-)
-
-(p p16
-    (context ^present reconnect)
-    (vertical-s ^net-name <nn> ^min <min1> ^max <max1> ^id <id1>)
-    { <h> (vertical-s ^net-name <nn> ^min <max1> ^max <max2> ^com <com> ^id <id2>) }
-    (vertical-s ^net-name <nn> ^min <max2> ^max <max3> ^id <id3>)
-  - (vertical-s ^net-name <nn> ^id { <> <id1> <> <id2> <> <id3> })
-    (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max1>)
-    (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max2>)
-  -->
-    (modify <h> ^min <min1> ^max <max3>)
-)
-
-(p p17
-    (context ^present separate)
-    { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <max>)
-    (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side right)
-  - (pin ^net-name <nn> ^pin-x > <com> ^pin-y { > <py> <= <max> })
-  - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side top)
-  - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <py> < <max> })
-  - (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <max>)
-  -->
-    (modify <v> ^max <py>)
-    (make vertical-s ^net-name <nn> ^min <py> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p18
-    (context ^present separate)
-    { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <max>)
-    (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side left)
-  - (pin ^net-name <nn> ^pin-x < <com> ^pin-y { > <py> <= <max> })
-  - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side top)
-  - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <py> < <max> })
-  - (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <max>)
-  -->
-    (modify <v> ^max <py>)
-    (make vertical-s ^net-name <nn> ^min <py> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p19
-    (context ^present separate)
-    { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <min>)
-    (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side right)
-  - (pin ^net-name <nn> ^pin-x > <com> ^pin-y { < <py> >= <min> })
-  - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side bottom)
-  - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <py> })
-  - (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <min>)
-  -->
-    (modify <v> ^min <py>)
-    (make vertical-s ^net-name <nn> ^min <min> ^max <py> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p20
-    (context ^present separate)
-    { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <min>)
-    (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side left)
-  - (pin ^net-name <nn> ^pin-x < <com> ^pin-y { < <py> >= <min> })
-  - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side bottom)
-  - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <py> })
-  - (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <min>)
-  -->
-    (modify <v> ^min <py>)
-    (make vertical-s ^net-name <nn> ^min <min> ^max <py> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p21
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <min>)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x { < <px> >= <min> } ^pin-y > <com>)
-  - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side left)
-  - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <px> })
-  - (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <min>)
-  -->
-    (modify <h> ^min <px>)
-    (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p22
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <min>)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x { < <px> >= <min> } ^pin-y < <com>)
-  - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side left)
-  - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <px> })
-  - (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <min>)
-  -->
-    (modify <h> ^min <px>)
-    (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p23
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <max>)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x { > <px> <= <max> } ^pin-y > <com>)
-  - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side right)
-  - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <px> < <max> })
-  - (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <max>)
-  -->
-    (modify <h> ^max <px>)
-    (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p24
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <max>)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x { > <px> <= <max> } ^pin-y < <com>)
-  - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side right)
-  - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <px> < <max> })
-  - (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <max>)
-  -->
-    (modify <h> ^max <px>)
-    (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p604
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side top)
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>)
-  - (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical)
-)
-
-(p p605
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side bottom)
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>)
-  - (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side top)
-  - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>)
-  -->
-    (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type vertical)
-)
-
-(p p606
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side top)
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1> ^com 1)
-    (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical)
-)
-
-(p p607
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side bottom)
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1> ^com <> 1)
-    (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side top)
-  - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>)
-  -->
-    (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type vertical)
-)
-
-(p p608
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0)
-    (vertical-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> })
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x <vcom> ^pin-channel-side top)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical)
-)
-
-(p p609
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0)
-    (vertical-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> })
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x <vcom> ^pin-channel-side bottom)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side top)
-  - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>)
-  -->
-    (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type vertical)
-)
-
-(p p610
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com 1 ^id <id>)
-    (vertical-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> })
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <lr> ^id <id1>)
-    (last-row <lr>)
-    (vertical-s ^net-name <bnn> ^com <vcom>)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x <vcom> ^pin-channel-side top)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical)
-)
-
-(p p611
-    (context ^present form-verti)
-    (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y { <vcom> >= <min> <= <max> } ^pin-channel-side right)
-    (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side left)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type horizontal)
-)
-
-(p p612
-    (context ^present form-verti)
-    (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y { <vcom> >= <min> <= <max> } ^pin-channel-side left)
-    (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side right)
-  - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>)
-  -->
-    (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type horizontal)
-)
-
-(p p613
-    (context ^present form-verti)
-    (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0)
-    (horizontal-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> })
-    (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y <vcom> ^pin-channel-side right)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side left)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type horizontal)
-)
-
-(p p614
-    (context ^present form-verti)
-    (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0)
-    (horizontal-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> })
-    (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y <vcom> ^pin-channel-side left)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side right)
-  - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>)
-  -->
-    (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type horizontal)
-)
-
-(p p615
-    (context ^present form-verti)
-    (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com 1 ^id <id>)
-    (horizontal-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> })
-    (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <lc> ^id <id1>)
-    (last-col <lc>)
-    (horizontal-s ^net-name <bnn> ^com <vcom>)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y <vcom> ^pin-channel-side right)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side left)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type horizontal)
-)
-
-(p p616
-    (context ^present form-verti)
-    (constraint ^constraint-type vertical ^net-name-1 <tnn> ^net-name-2 <bnn> ^seg-id-1 <tid> ^seg-id-2 <bid>)
-    (constraint ^constraint-type vertical ^net-name-1 <nn1> ^net-name-2 <tnn> ^seg-id-1 <id1> ^seg-id-2 <tid2>)
-  - (vertical-cycle <tnn> <tid> <tid2>)
-  -->
-    (make vertical-cycle <tnn> <tid> <tid2>)
-)
-
-(p p617
-    (context ^present form-verti)
-    (constraint ^constraint-type horizontal ^net-name-1 <tnn> ^net-name-2 <bnn> ^seg-id-1 <tid> ^seg-id-2 <bid>)
-    (constraint ^constraint-type horizontal ^net-name-1 <nn1> ^net-name-2 <tnn> ^seg-id-1 <id1> ^seg-id-2 <tid2>)
-  - (horizontal-cycle <tnn> <tid> <tid2>)
-  -->
-    (make horizontal-cycle <tnn> <tid> <tid2>)
-)
-
-(p p618
-    (context ^present remove-cycle)
-    { <h> (horizontal-cycle <nn>) }
-  - (constraint ^constraint-type horizontal ^net-name-1 <nn>)
-  - (constraint ^constraint-type horizontal ^net-name-2 <nn>)
-  -->
-    (remove <h>)
-)
-
-(p p619
-    (context ^present remove-cycle)
-    { <h> (horizontal-cycle <nn>) }
-  - (constraint ^constraint-type horizontal ^net-name-2 <nn>)
-  -->
-    (remove <h>)
-)
-
-(p p620
-    (context ^present remove-cycle)
-    { <h> (horizontal-cycle <nn>) }
-  - (constraint ^constraint-type horizontal ^net-name-1 <nn>)
-  -->
-    (remove <h>)
-)
-
-(p p621
-    (context ^present remove-cycle)
-    { <h> (vertical-cycle <nn>) }
-  - (constraint ^constraint-type vertical ^net-name-1 <nn>)
-  - (constraint ^constraint-type vertical ^net-name-2 <nn>)
-  -->
-    (remove <h>)
-)
-
-(p p622
-    (context ^present remove-cycle)
-    { <h> (vertical-cycle <nn>) }
-  - (constraint ^constraint-type vertical ^net-name-2 <nn>)
-  -->
-    (remove <h>)
-)
-
-(p p623
-    (context ^present remove-cycle)
-    { <h> (vertical-cycle <nn>) }
-  - (constraint ^constraint-type vertical ^net-name-1 <nn>)
-  -->
-    (remove <h>)
-)
-
-(p p624
-    { <c> (context ^present remove-cycle) }
-  -->
-    (remove <c>)
-)
-
-(p p625
-    (context ^present remove-cycle)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom)
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <max>)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^max <max>)
-)
-
-(p p626
-    (context ^present remove-cycle)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top)
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <min>)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^min <min>)
-)
-
-(p p627
-    (context ^present remove-cycle)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom)
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <max>)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^max <max>)
-)
-
-(p p628
-    (context ^present remove-cycle)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top)
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <min>)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^min <min>)
-)
-
-(p p629
-    (context ^present remove-cycle)
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com 1)
-    (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from south)
-  - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y < <gy>)
-  - (vertical-s ^net-name <nn> ^min 1 ^max > <gy> ^com <gx>)
-  -->
-    (make vertical-s ^net-name <nn> ^min 1 ^max (compute <gy> + 1) ^com <gx> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p630
-    (context ^present remove-cycle)
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com 1)
-    (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from south)
-  - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y <= <gy>)
-    { <v> (vertical-s ^net-name <nn> ^min 1 ^max <= <gy> ^com <gx>) }
-  -->
-    (modify <v> ^max (compute <gy> + 1))
-)
-
-(p p631
-    (context ^present remove-cycle)
-    (last-row <lr>)
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com <lr>)
-    (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from north)
-  - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y > <gy>)
-  - (vertical-s ^net-name <nn> ^min < <gy> ^max <lr> ^com <gx>)
-  -->
-    (make vertical-s ^net-name <nn> ^min (compute <gy> - 1) ^max <lr> ^com <gx> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p632
-    (context ^present remove-cycle)
-    (last-row <lr>)
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com <lr>)
-    (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from north)
-  - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y >= <gy>)
-    { <v> (vertical-s ^net-name <nn> ^min >= <gy> ^max <lr> ^com <gx>) }
-  -->
-    (modify <v> ^min (compute <gy> - 1))
-)
-
-(p p633
-    (context ^present remove-cycle)
-    (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com 1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from west)
-  - (ff ^net-name <nn> ^grid-x < <gx> ^grid-y <> <gy>)
-  - (horizontal-s ^net-name <nn> ^min 1 ^max > <gx> ^com <gy>)
-  -->
-    (make horizontal-s ^net-name <nn> ^min 1 ^max (compute <gx> + 1) ^com <gy> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p634
-    (context ^present remove-cycle)
-    (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com 1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from west)
-  - (ff ^net-name <nn> ^grid-x <= <gx> ^grid-y <> <gy>)
-    { <h> (horizontal-s ^net-name <nn> ^min 1 ^max <= <gx> ^com <gy>) }
-  -->
-    (modify <h> ^max (compute <gx> + 1))
-)
-
-(p p635
-    (context ^present remove-cycle)
-    (last-col <lc>)
-    (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com <lc>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from east)
-  - (ff ^net-name <nn> ^grid-x > <gx> ^grid-y <> <gy>)
-  - (horizontal-s ^net-name <nn> ^min < <gx> ^max <lc> ^com <gy>)
-  -->
-    (make horizontal-s ^net-name <nn> ^min (compute <gx> - 1) ^max <lc> ^com <gy> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p636
-    (context ^present remove-cycle)
-    (last-col <lc>)
-    (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com <lc>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from east)
-  - (ff ^net-name <nn> ^grid-x >= <gx> ^grid-y <> <gy>)
-    { <h> (horizontal-s ^net-name <nn> ^min >= <gx> ^max <lc> ^com <gy>) }
-  -->
-    (modify <h> ^min (compute <gx> - 1))
-)
-
-(p p637
-    (context ^present remove-cycle)
-    (last-row <lr>)
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0)
-    { <v> (vertical-s ^net-name <nn> ^min 1 ^max { <lr> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) }
-    (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side top)
-    (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from south)
-  -->
-    (modify <v> ^min (compute <lr> - 1))
-)
-
-(p p638
-    (context ^present remove-cycle)
-    (last-row <lr>)
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0)
-    { <v> (vertical-s ^net-name <nn> ^min 1 ^max { <lr> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) }
-    (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side bottom)
-    (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from north)
-  -->
-    (modify <v> ^max 2)
-)
-
-(p p639
-    (context ^present remove-cycle)
-    (last-col <lc>)
-    (vertical-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0)
-    { <v> (horizontal-s ^net-name <nn> ^min 1 ^max { <lc> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) }
-    (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side right)
-    (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from west)
-  -->
-    (modify <v> ^min (compute <lc> - 1))
-)
-
-(p p640
-    (context ^present remove-cycle)
-    (last-col <lc>)
-    (vertical-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0)
-    { <v> (horizontal-s ^net-name <nn> ^min 1 ^max { <lc> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) }
-    (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side left)
-    (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from east)
-  -->
-    (modify <v> ^max 2)
-)
-
-(p p472
-    (context ^present partial-route)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) }
-    { <vs> (vertical-s ^net-name <nn> ^min <gy1> ^max <gy> ^com <gx>) }
-    { <ff2> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1> ^came-from south) }
-    { <v> (vertical ^net-name nil ^min <gy1> ^max <gy> ^com <gx> ^layer <lay>) }
-  -->
-    (modify <v> ^net-name <nn> ^pin-name <pn>)
-    (remove <ff1> <ff2> <vs>)
-)
-
-(p p473
-    (context ^present partial-route)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from east) }
-    { <vs> (horizontal-s ^net-name <nn> ^min <gx1> ^max <gx> ^com <gy>) }
-    { <ff2> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn1> ^came-from west) }
-    { <v> (horizontal ^net-name nil ^min <gx1> ^max <gx> ^com <gy> ^layer <lay>) }
-  -->
-    (modify <v> ^net-name <nn> ^pin-name <pn>)
-    (remove <ff1> <ff2> <vs>)
-)
-
-(p p474
-    (context ^present partial-route)
-    { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) }
-    { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from east)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from north)
-  -->
-    (remove <v2>)
-    (modify <h> ^com <vmin>)
-    (modify <v1> ^min <vmin>)
-)
-
-(p p475
-    (context ^present partial-route)
-    { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from east)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from north)
-  -->
-    (modify <v2> ^com <vcom>)
-    (modify <h> ^com <vmin>)
-)
-
-(p p476
-    (context ^present partial-route)
-    { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) }
-    { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from west)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from north)
-  -->
-    (remove <v2>)
-    (modify <h> ^com <vmin>)
-    (modify <v1> ^min <vmin>)
-)
-
-(p p477
-    (context ^present partial-route)
-    { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from west)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from north)
-  -->
-    (modify <v2> ^com <vcom>)
-    (modify <h> ^com <vmin>)
-)
-
-(p p478
-    (context ^present partial-route)
-    { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) }
-    { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from east)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from south)
-  -->
-    (remove <v2>)
-    (modify <h> ^com <vmax>)
-    (modify <v1> ^max <vmax>)
-)
-
-(p p479
-    (context ^present partial-route)
-    { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from east)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from south)
-  -->
-    (modify <v2> ^com <vcom>)
-    (modify <h> ^com <vmax>)
-)
-
-(p p480
-    (context ^present partial-route)
-    { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) }
-    { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from west)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from south)
-  -->
-    (remove <v2>)
-    (modify <h> ^com <vmax>)
-    (modify <v1> ^max <vmax>)
-)
-
-(p p481
-    (context ^present partial-route)
-    { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from west)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from south)
-  -->
-    (modify <v2> ^com <vcom>)
-    (modify <h> ^com <vmax>)
-)
-
-(p p482
-    (context ^present partial-route)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) }
-    { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from north)
-    (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from east)
-  -->
-    (remove <h2>)
-    (modify <v> ^com <hmin>)
-    (modify <h1> ^min <hmin>)
-)
-
-(p p483
-    (context ^present partial-route)
-    { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from north)
-    (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from east)
-  -->
-    (modify <h2> ^com <hcom>)
-    (modify <v> ^com <hmin>)
-)
-
-(p p484
-    (context ^present partial-route)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) }
-    { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from north)
-    (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from west)
-  -->
-    (remove <h2>)
-    (modify <v> ^com <hmax>)
-    (modify <h1> ^max <hmax>)
-)
-
-(p p485
-    (context ^present partial-route)
-    { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from north)
-    (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from west)
-  -->
-    (modify <h2> ^com <hcom>)
-    (modify <v> ^com <hmax>)
-)
-
-(p p486
-    (context ^present partial-route)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) }
-    { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from south)
-    (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from east)
-  -->
-    (remove <h2>)
-    (modify <v> ^com <hmin>)
-    (modify <h1> ^min <hmin>)
-)
-
-(p p487
-    (context ^present partial-route)
-    { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from south)
-    (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from east)
-  -->
-    (modify <h2> ^com <hcom>)
-    (modify <v> ^com <hmin>)
-)
-
-(p p488
-    (context ^present partial-route)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) }
-    { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from south)
-    (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from west)
-  -->
-    (remove <h2>)
-    (modify <v> ^com <hmax>)
-    (modify <h1> ^max <hmax>)
-)
-
-(p p489
-    (context ^present partial-route)
-    { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from south)
-    (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from west)
-  -->
-    (modify <h2> ^com <hcom>)
-    (modify <v> ^com <hmax>)
-)
-
-(p p186
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^difference { <d> < 0 })
-  - (horizontal-s ^difference < <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from south) }
-  - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y < <gy1>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y <gy1>)
-  - (horizontal ^net-name nil ^min < <gx2> ^max > <gx1> ^com <gy1>)
-  - (horizontal ^net-name nil ^min <gx2> ^max > <gx1> ^com <gy1> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx2> ^max <gx1> ^com <gy1> ^max-net nil)
-    { <v> (vertical ^net-name nil ^max { <max> > <gy1> } ^min { < <max> <= <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>)
-  - (extended-ff <nn> bottom)
-  - (vertical-cycle <nn>)
-  -->
-    (modify <v> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy1> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p187
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^difference { <d> < 0 })
-  - (horizontal-s ^difference < <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from south) }
-  - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y < <gy1>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y <gy1>)
-  - (horizontal ^net-name nil ^min < <gx1> ^max > <gx2> ^com <gy1>)
-  - (horizontal ^net-name nil ^min <gx1> ^max > <gx2> ^com <gy1> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx1> ^max <gx2> ^com <gy1> ^max-net nil)
-    { <v> (vertical ^net-name nil ^max { <max> > <gy1> } ^min { < <max> <= <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>)
-  - (extended-ff <nn> bottom)
-  - (vertical-cycle <nn>)
-  -->
-    (modify <v> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy1> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p188
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^difference { <d> < 0 })
-  - (horizontal-s ^difference < <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from south) }
-    (vertical-s ^net-name <nn> ^min <= <gy1> ^max > <gy1> ^com <gx1>)
-  - (ff ^net-name <nn> ^grid-x <> <gx1> ^grid-y <= <gy1>)
-    { <v> (vertical ^net-name nil ^max { <max> > <gy1> } ^min { < <max> <= <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy1>)
-  - (vertical-s ^net-name <> <nn> ^min <= <gy2> ^max >= <gy2> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>)
-  - (extended-ff <nn> bottom)
-  - (vertical-cycle <nn>)
-  -->
-    (make extended-ff <nn> bottom)
-    (modify <v> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy1> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p189
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^difference { <d> > 0 })
-  - (horizontal-s ^difference > <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from north) }
-  - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y > <gy1>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y <gy1>)
-  - (horizontal ^net-name nil ^min < <gx2> ^max > <gx1> ^com <gy1>)
-  - (horizontal ^net-name nil ^min <gx2> ^max > <gx1> ^com <gy1> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx2> ^max <gx1> ^com <gy1> ^max-net nil)
-    { <v> (vertical ^net-name nil ^max { <max> >= <gy1> } ^min { < <max> < <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy1> ^como <gy2>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>)
-  - (extended-ff <nn> top)
-  - (vertical-cycle <nn>)
-  -->
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy1> ^min <gy2> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p190
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^difference { <d> > 0 })
-  - (horizontal-s ^difference > <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from north) }
-  - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y > <gy1>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y <gy1>)
-  - (horizontal ^net-name nil ^min < <gx1> ^max > <gx2> ^com <gy1>)
-  - (horizontal ^net-name nil ^min <gx1> ^max > <gx2> ^com <gy1> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx1> ^max <gx2> ^com <gy1> ^max-net nil)
-    { <v> (vertical ^net-name nil ^max { <max> >= <gy1> } ^min { < <max> < <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy1> ^como <gy2>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>)
-  - (extended-ff <nn> top)
-  - (vertical-cycle <nn>)
-  -->
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy1> ^min <gy2> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p191
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^difference { <d> > 0 })
-  - (horizontal-s ^difference > <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from north) }
-    (vertical-s ^net-name <nn> ^min < <gy1> ^max >= <gy1> ^com <gx1>)
-  - (ff ^net-name <nn> ^grid-x <> <gx1> ^grid-y >= <gy1>)
-    { <v> (vertical ^net-name nil ^max { <max> >= <gy1> } ^min { < <max> < <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy1> ^como <gy2>)
-  - (vertical-s ^net-name <> <nn> ^min <= <gy2> ^max >= <gy2> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>)
-  - (extended-ff <nn> top)
-  - (vertical-cycle <nn>)
-  -->
-    (make extended-ff <nn> top)
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy1> ^min <gy2> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p192
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (horizontal-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <max> ^grid-y <gy> ^grid-layer <lay> ^came-from south ^pin-name <pn>) }
-  - (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com <gy>)
-    { <v> (vertical ^net-name nil ^max { <vmax> > <gy> } ^min { < <vmax> <= <gy> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <max> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gy2> ^layer <lay>)
-  - (vertical-cycle <nn>)
-    (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com > <gy>)
-  -->
-    (modify <v> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p193
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (horizontal-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <min> ^grid-y <gy> ^grid-layer <lay> ^came-from south ^pin-name <pn>) }
-  - (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com <gy>)
-    { <v> (vertical ^net-name nil ^max { <vmax> > <gy> } ^min { < <vmax> <= <gy> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <min> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gy2> ^layer <lay>)
-  - (vertical-cycle <nn>)
-    (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com > <gy>)
-  -->
-    (modify <v> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p194
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (horizontal-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <max> ^grid-y <gy> ^grid-layer <lay> ^came-from north ^pin-name <pn>) }
-  - (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com <gy>)
-    { <v> (vertical ^net-name nil ^max { <vmax> >= <gy> } ^min { < <vmax> < <gy> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy> ^como <gy2>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <max> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gy2> ^layer <lay>)
-  - (vertical-cycle <nn>)
-    (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com < <gy>)
-  -->
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p195
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (horizontal-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <min> ^grid-y <gy> ^grid-layer <lay> ^came-from north ^pin-name <pn>) }
-  - (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com <gy>)
-    { <v> (vertical ^net-name nil ^max { <vmax> >= <gy> } ^min { < <vmax> < <gy> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy> ^como <gy2>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <min> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gy2> ^layer <lay>)
-  - (vertical-cycle <nn>)
-    (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com < <gy>)
-  -->
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p196
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^difference { <d> < 0 })
-  - (vertical-s ^difference < <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from west) }
-  - (ff ^net-name <nn> ^grid-x < <gx1> ^grid-y <garb1>)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> < <gy1> })
-  - (vertical ^net-name nil ^min < <gy2> ^max > <gy1> ^com <gx1>)
-  - (vertical ^net-name nil ^min <gy2> ^max > <gy1> ^com <gx1> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy2> ^max <gy1> ^com <gx1> ^max-net nil)
-    { <v> (horizontal ^net-name nil ^max { <max> > <gx1> } ^min { < <max> <= <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>)
-  - (extended-ff <nn> left)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx2> ^min <gx1> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p197
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^difference { <d> < 0 })
-  - (vertical-s ^difference < <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from west) }
-  - (ff ^net-name <nn> ^grid-x < <gx1> ^grid-y <garb1>)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> > <gy1> })
-  - (vertical ^net-name nil ^min < <gy1> ^max > <gy2> ^com <gx1>)
-  - (vertical ^net-name nil ^min <gy1> ^max > <gy2> ^com <gx1> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy1> ^max <gy2> ^com <gx1> ^max-net nil)
-    { <v> (horizontal ^net-name nil ^max { <max> > <gx1> } ^min { < <max> <= <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>)
-  - (extended-ff <nn> left)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx2> ^min <gx1> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p198
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^difference { <d> < 0 })
-  - (vertical-s ^difference < <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from west) }
-    (horizontal-s ^net-name <nn> ^min <= <gx1> ^max > <gx1> ^com <gy1>)
-  - (ff ^net-name <nn> ^grid-x <= <gx1> ^grid-y <> <gy1>)
-    { <v> (horizontal ^net-name nil ^max { <max> > <gx1> } ^min { < <max> <= <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx1>)
-  - (horizontal-s ^net-name <> <nn> ^min <= <gx2> ^max >= <gx2> ^com <gy1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>)
-  - (extended-ff <nn> left)
-  - (horizontal-cycle <nn>)
-  -->
-    (make extended-ff <nn> left)
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx2> ^min <gx1> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p199
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^difference { <d> > 0 })
-  - (vertical-s ^difference > <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from east) }
-  - (ff ^net-name <nn> ^grid-x > <gx1> ^grid-y <garb1>)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> < <gy1> })
-  - (vertical ^net-name nil ^min < <gy2> ^max > <gy1> ^com <gx1>)
-  - (vertical ^net-name nil ^min <gy2> ^max > <gy1> ^com <gx1> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy2> ^max <gy1> ^com <gx1> ^max-net nil)
-    { <v> (horizontal ^net-name nil ^max { <max> >= <gx1> } ^min { < <max> < <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx1> ^como <gx2>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>)
-  - (extended-ff <nn> right)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx1> ^min <gx2> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p200
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^difference { <d> > 0 })
-  - (vertical-s ^difference > <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from east) }
-  - (ff ^net-name <nn> ^grid-x > <gx1> ^grid-y <gy1>)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> > <gy1> })
-  - (vertical ^net-name nil ^min < <gy1> ^max > <gy2> ^com <gx1>)
-  - (vertical ^net-name nil ^min <gy1> ^max > <gy2> ^com <gx1> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy1> ^max <gy2> ^com <gx1> ^max-net nil)
-    { <v> (horizontal ^net-name nil ^max { <max> >= <gx1> } ^min { < <max> < <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx1> ^como <gx2>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>)
-  - (extended-ff <nn> right)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx1> ^min <gx2> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p201
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^difference { <d> > 0 })
-  - (vertical-s ^difference > <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from east) }
-    (horizontal-s ^net-name <nn> ^min < <gx1> ^max >= <gx1> ^com <gy1>)
-  - (ff ^net-name <nn> ^grid-x >= <gx1> ^grid-y <> <gy1>)
-    { <v> (horizontal ^net-name nil ^max { <max> >= <gx1> } ^min { < <max> < <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx1> ^como <gx2>)
-  - (horizontal-s ^net-name <> <nn> ^min <= <gx2> ^max >= <gx2> ^com <gy1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>)
-  - (extended-ff <nn> right)
-  - (horizontal-cycle <nn>)
-  -->
-    (make extended-ff <nn> right)
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx1> ^min <gx2> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p202
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (vertical-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <max> ^grid-layer <lay> ^came-from west ^pin-name <pn>) }
-  - (vertical ^net-name nil ^min < <max> ^max >= <max> ^com <gx>)
-    { <v> (horizontal ^net-name nil ^max { <vmax> > <gx> } ^min { < <vmax> <= <gx> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <max> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gx2> ^layer <lay>)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx2> ^min <gx> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p203
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (vertical-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <min> ^grid-layer <lay> ^came-from west ^pin-name <pn>) }
-  - (vertical ^net-name nil ^min <= <min> ^max > <min> ^com <gx>)
-    { <v> (horizontal ^net-name nil ^max { <vmax> > <gx> } ^min { < <vmax> <= <gx> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <min> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gx2> ^layer <lay>)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx2> ^min <gx> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p204
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (vertical-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <max> ^grid-layer <lay> ^came-from east ^pin-name <pn>) }
-  - (vertical ^net-name nil ^min < <max> ^max >= <max> ^com <gx>)
-    { <v> (horizontal ^net-name nil ^max { <vmax> >= <gx> } ^min { < <vmax> < <gx> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx> ^como <gx2>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <max> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gx2> ^layer <lay>)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx> ^min <gx2> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p205
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (vertical-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <min> ^grid-layer <lay> ^came-from east ^pin-name <pn>) }
-  - (vertical ^net-name nil ^min <= <min> ^max > <min> ^com <gx>)
-    { <v> (horizontal ^net-name nil ^max { <vmax> >= <gx> } ^min { < <vmax> < <gx> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx> ^como <gx2>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <min> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gx2> ^layer <lay>)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx> ^min <gx2> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p206
-    { <c> (context ^present extend-h-v-s) }
-  -->
-    (modify <c> ^present loose-constraint0)
-)
-
-(p p207
-    { <c> (context ^present extend-h-v-s) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from west ^pin-name <pn>) }
-    (horizontal-s ^net-name <nn> ^min <= <gx> ^max { <hmaxs> > <gx> } ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^com <gy>)
-    (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { <vcoms> > <gx> <= <hmaxs> })
-  - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { >= <gx> < <vcoms> })
-    { <h> (horizontal ^net-name nil ^min <gx> ^max { <hmax> >= <vcoms> } ^com <gy> ^layer <lay>) }
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <vcoms> ^layer <lay>)
-  -->
-    (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <vcoms>)
-    (modify <h> ^min <vcoms> ^min-net <nn>)
-    (modify <ff> ^grid-x <vcoms> ^can-chng-layer nil)
-    (modify <c> ^present propagate-constraint)
-)
-
-(p p208
-    { <c> (context ^present extend-h-v-s) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from east ^pin-name <pn>) }
-    (horizontal-s ^net-name <nn> ^min { <hmins> < <gx> } ^max >= <gx> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^com <gy>)
-    (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { <vcoms> < <gx> >= <hmins> })
-  - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { <= <gx> > <vcoms> })
-    { <h> (horizontal ^net-name nil ^min { <hmin> <= <vcoms> } ^max <gx> ^com <gy> ^layer <lay>) }
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <vcoms> ^layer <lay>)
-  -->
-    (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <vcoms>)
-    (modify <h> ^max <vcoms> ^max-net <nn>)
-    (modify <ff> ^grid-x <vcoms> ^can-chng-layer nil)
-    (modify <c> ^present propagate-constraint)
-)
-
-(p p209
-    { <c> (context ^present extend-h-v-s) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from south ^pin-name <pn>) }
-    (vertical-s ^net-name <nn> ^min <= <gy> ^max { <vmaxs> > <gy> } ^com <gx>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <gx>)
-    (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { <hcoms> > <gy> <= <vmaxs> })
-  - (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { >= <gy> < <hcoms> })
-    { <v> (vertical ^net-name nil ^min <gy> ^max { <vmax> >= <hcoms> } ^com <gx> ^layer <lay>) }
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <hcoms> ^layer <lay>)
-  -->
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <hcoms>)
-    (modify <v> ^min <hcoms> ^min-net <nn>)
-    (modify <ff> ^grid-y <hcoms> ^can-chng-layer nil)
-    (modify <c> ^present propagate-constraint)
-)
-
-(p p210
-    { <c> (context ^present extend-h-v-s) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from north ^pin-name <pn>) }
-    (vertical-s ^net-name <nn> ^min { <vmins> < <gy> } ^max >= <gy> ^com <gx>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <gx>)
-    (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { <hcoms> < <gy> >= <vmins> })
-  - (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { <= <gy> > <hcoms> })
-    { <v> (vertical ^net-name nil ^min { <vmin> <= <hcoms> } ^max <gy> ^com <gx> ^layer <lay>) }
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <hcoms> ^layer <lay>)
-  -->
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <hcoms>)
-    (modify <v> ^max <hcoms> ^max-net <nn>)
-    (modify <ff> ^grid-y <hcoms> ^can-chng-layer nil)
-    (modify <c> ^present propagate-constraint)
-)
-
-(p p29
-    (goal cleanup <c>)
-    (<c>)
-  -->
-    (remove 2)
-)
-
-(p p30
-    (goal cleanup <c>)
-  - (<c>)
-  -->
-    (remove 1)
-)
-
-(p p31
-    (goal cleanup)
-    (verti-has-loop)
-  -->
-    (remove 2)
-)
-
-(p p83
-    (context ^present propagate-constraint)
-  -->
-    (remove 1)
-    (make context ^previous propagate-constraint)
-    (make context ^present remove-cycle)
-)
-
-(p p84
-    (context ^present << propagate-constraint extend-pins move-ff >>)
-    (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com> ^layer <lay> ^compo <cpo> ^commo <egarb1>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <min2> <= <max1> } ^max { <max2> >= <min1> } ^com <cpo> ^layer <lay> ^compo <garb1> ^commo <egarb2>)
-    { <v1> (vertical ^net-name nil ^min { <min3> <= <com> } ^max { <max3> >= <cpo> > <min3> } ^com { <com2> <= <max1> >= <min1> <= <max2> >= <min2> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) }
-  -->
-    (make vertical ^min <min3> ^max <com> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <nn1> ^min-net <mnn>)
-    (make vertical ^min <cpo> ^max <max3> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <nn2> ^max-net <man>)
-    (remove <v1>)
-)
-
-(p p85
-    (context ^present << propagate-constraint extend-pins >>)
-    (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <com> ^layer <lay> ^compo <egarb2> ^commo <gy>)
-    { <v1> (vertical ^net-name nil ^min { <min3> <= <gy> } ^max { <max3> >= <com> > <min3> } ^com <gx> ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) }
-  -->
-    (make vertical ^min <min3> ^max <gy> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <nn1> ^min-net <mnn>)
-    (make vertical ^min <com> ^max <max3> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <nn2> ^max-net <man>)
-    (remove <v1>)
-)
-
-(p p86
-    (context ^present << propagate-constraint extend-pins >>)
-    (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <com> ^layer <lay> ^compo <gy> ^commo <egarb2>)
-    { <v1> (vertical ^net-name nil ^min { <min3> <= <com> } ^max { <max3> >= <gy> > <min3> } ^com <gx> ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) }
-  -->
-    (make vertical ^min <min3> ^max <com> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <nn2> ^min-net <mnn>)
-    (make vertical ^min <gy> ^max <max3> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <nn1> ^max-net <man>)
-    (remove <v1>)
-)
-
-(p p87
-    (context ^present propagate-constraint)
-    (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <max1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min <min2> ^max <gar2> ^com <com> ^layer <lay> ^compo <egarb3> ^commo <egarb4>)
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <min2> > <max1> } ^com <com> ^layer <lay> ^compo <egarb5> ^commo <egarb6>) }
-  - (vertical ^com { > <max1> < <min2> })
-  -->
-    (remove <h1>)
-)
-
-(p p88
-    (context ^present << propagate-constraint extend-pins move-ff >>)
-    (vertical ^status nil ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com> ^layer <lay> ^compo <cpo> ^commo <egarb1>)
-    (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <min2> <= <max1> } ^max { <max2> >= <min1> } ^com <cpo> ^layer <lay> ^compo <garb1> ^compo <egarb2>)
-    { <h1> (horizontal ^net-name nil ^min { <min3> <= <com> } ^max { <max3> >= <cpo> } ^com { <com2> <= <max1> >= <min1> <= <max2> >= <min2> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) }
-  -->
-    (make horizontal ^min <min3> ^max <com> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <mnn> ^max-net <nn1>)
-    (make horizontal ^min <cpo> ^max <max3> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <man> ^min-net <nn2>)
-    (remove <h1>)
-)
-
-(p p89
-    (context ^present propagate-constraint)
-    (vertical ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <max1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min <min2> ^max <garb2> ^com <com> ^layer <lay> ^compo <egarb3> ^commo <egarb4>)
-  - (horizontal ^com { > <max1> < <min2> })
-    { <v1> (vertical ^net-name nil ^min <max1> ^max { <min2> > <max1> } ^com <com> ^layer <lay> ^compo <egarb5> ^commo <egarb6>) }
-  -->
-    (remove <v1>)
-)
-
-(p p90
-    (context ^present propagate-constraint)
-    (vertical ^status nil ^net-name { <nn1> <> nil } ^min <vmin> ^max <garb1> ^com <vcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <vcom> } ^max { <garb3> >= <vcom> } ^com <hcom> ^layer <lay> ^compo <vmin> ^commo <garb5>)
-    { <v1> (vertical ^net-name nil ^min <garb4> ^max { <vmin> > <garb4> } ^com <vcom> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) }
-  -->
-    (modify <v1> ^max <hcom> ^max-net <nn2>)
-)
-
-(p p91
-    (context ^present propagate-constraint)
-    (vertical ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <vcom> } ^max { <garb3> >= <vcom> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <vmax>)
-    { <v1> (vertical ^net-name nil ^min <vmax> ^max { <garb5> > <vmax> } ^com <vcom> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) }
-  -->
-    (modify <v1> ^min <hcom> ^min-net <nn2>)
-)
-
-(p p92
-    (context ^present propagate-constraint)
-    (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <min> ^max <garb1> ^com <hcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <hcom> } ^max { <garb3> >= <hcom> } ^com <vcom> ^layer <lay> ^compo <min> ^commo <egarb3>)
-    { <h1> (horizontal ^net-name nil ^min <garb4> ^max { <min> > <garb4> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-  -->
-    (modify <h1> ^max <vcom> ^max-net <nn2>)
-)
-
-(p p93
-    (context ^present propagate-constraint)
-    (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <max> ^com <hcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <hcom> } ^max { <garb3> >= <hcom> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <max>)
-    { <h1> (horizontal ^net-name nil ^min <max> ^max { <garb4> > <max> } ^com <hcom> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) }
-  -->
-    (modify <h1> ^min <vcom> ^min-net <nn2>)
-)
-
-(p p94
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    { <h1> (horizontal ^net-name nil ^min <garb3> ^max { <gx> > <garb3> } ^com <gy> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) }
-    (vertical ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <vcom> ^layer <lay> ^compo <gx> ^commo <egarb2>)
-  -->
-    (modify <h1> ^max <vcom> ^max-net <nn2>)
-)
-
-(p p95
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { <garb4> > <gx> } ^com <gy> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-    (vertical ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <vcom> ^layer <lay> ^compo <garb3> ^commo <gx>)
-  -->
-    (modify <h1> ^min <vcom> ^min-net <nn2>)
-)
-
-(p p96
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <hcom> ^layer <lay> ^compo <gy> ^commo <garb3>)
-    { <v1> (vertical ^net-name nil ^min <garb4> ^max { <gy> > <garb4> } ^com <gx> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  -->
-    (modify <v1> ^max <hcom> ^max-net <nn2>)
-)
-
-(p p97
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <hcom> ^layer <lay> ^compo <garb3> ^commo <gy>)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { <garb4> > <gy> } ^com <gx> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  -->
-    (modify <v1> ^min <hcom> ^min-net <nn2>)
-)
-
-(p p98
-    (context ^present << propagate-constraint extend-pins random1 check-for-routed-net >>)
-    { <h1> (horizontal ^min <min> ^max <= <min>) }
-  -->
-    (remove <h1>)
-)
-
-(p p99
-    (context ^present << propagate-constraint extend-pins random1 check-for-routed-net >>)
-    { <v1> (vertical ^min <min> ^max <= <min>) }
-  -->
-    (remove <v1>)
-)
-
-(p p100
-    { <h1> (horizontal ^min <min> ^max <= <min>) }
-  -->
-    (remove <h1>)
-)
-
-(p p101
-    { <v1> (vertical ^min <min> ^max <= <min>) }
-  -->
-    (remove <v1>)
-)
-
-(p p102
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com <min1>)
-  - (horizontal ^status nil ^min < <min1> ^max >= <min1> ^com <com1>)
-    (vertical ^status nil ^net-name <garb1> ^min { <vmin> <= <com1> } ^max { >= <com1> > <vmin> } ^com { <com2> > <min1> <= <max1> } ^layer <garb2> ^compo <egarb4> ^commo <egarb5>)
-  - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com { < <com2> >= <min1> })
-  -->
-    (modify <h1> ^min <com2> ^min-net nil)
-)
-
-(p p103
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com <min1>)
-  - (vertical ^status nil ^min < <min1> ^max >= <min1> ^com <com1>)
-    (horizontal ^status nil ^net-name <garb1> ^min { <hmin> <= <com1> } ^max { <garb2> >= <com1> > <hmin> } ^com { <com2> > <min1> <= <max1> } ^layer <garb3> ^compo <egarb4> ^commo <egarb5>)
-  - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com { < <com2> >= <min1> })
-  -->
-    (modify <v1> ^min <com2> ^min-net nil)
-)
-
-(p p104
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-  - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com <max1>)
-  - (horizontal ^status nil ^min <= <max1> ^max > <max1> ^com <com1>)
-    (vertical ^status nil ^net-name <garb1> ^min { <vmin> <= <com1> } ^max { <garb2> >= <com1> > <vmin> } ^com { <com2> >= <min1> < <max1> } ^layer <egarb1> ^compo <egarb2> ^commo <egarb3>)
-  - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com { > <com2> <= <max1> })
-  -->
-    (modify <h1> ^max <com2> ^max-net nil)
-)
-
-(p p105
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com <max1>)
-  - (vertical ^status nil ^min <= <max1> ^max > <max1> ^com <com1>)
-    (horizontal ^status nil ^net-name <garb1> ^min { <hmin> <= <com1> } ^max { <garb2> >= <com1> > <hmin> } ^com { <com2> >= <min1> < <max1> } ^layer <egarb1> ^compo <egarb4> ^commo <egarb5>)
-  - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com { > <com2> <= <max1> })
-  -->
-    (modify <v1> ^max <com2> ^max-net nil)
-)
-
-(p p106
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <hmin> ^max { <hmax> > <hmin> } ^com <hcom> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) }
-  - (vertical ^com { > <hmin> < <hmax> })
-  - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmax> ^layer <lay>)
-  - (horizontal ^status nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <lay>)
-    (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <hmax> ^layer <> <lay> ^compo <egarb4> ^commo <egarb5>)
-    (vertical ^net-name { <> <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <hmin> ^layer <> <lay> ^compo <egarb2> ^commo <egarb3>)
-  -->
-    (remove <h1>)
-)
-
-(p p107
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <vmin> ^max { <vmax> > <vmin> } ^com <vcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  - (horizontal ^com { > <vmin> < <vmax> })
-  - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmax> ^layer <lay>)
-  - (vertical ^status nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <lay>)
-    (horizontal ^net-name { <nn1> <> nil } ^min { <garb1> <= <vcom> } ^max { <garb2> >= <vcom> } ^com <vmax> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>)
-    (horizontal ^net-name { <> <nn1> <> nil } ^min { <garb4> <= <vcom> } ^max { <garb5> >= <vcom> } ^com <vmin> ^layer { <garb6> <> <lay> } ^compo <egarb4> ^commo <egarb5>)
-  -->
-    (remove <v1>)
-)
-
-(p p108
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <hmin> ^max { <hmax> > <hmin> } ^com <hcom> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) }
-  - (vertical ^com { > <hmin> < <hmax> })
-  - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmin> ^layer <lay>)
-  - (horizontal ^status nil ^min < <hmin> ^max <hmin> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmax> ^layer <lay>)
-  - (horizontal ^status nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <lay>)
-    (vertical ^net-name { <nn1> <> nil } ^min { <garb1> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <hmax> ^layer { <garb3> <> <lay> } ^compo <egarb2> ^commo <egarb3>)
-    (vertical ^net-name { <garb7> <> <nn1> <> nil } ^min { <gabr4> <= <hcom> } ^max { <garb5> >= <hcom> } ^com <hmin> ^layer { <garb6> <> <lay> } ^compo <egarb4> ^commo <egarb5>)
-  -->
-    (remove <h1>)
-)
-
-(p p109
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <vmin> ^max { <vmax> > <vmin> } ^com <vcom> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) }
-  - (horizontal ^com { > <vmin> < <vmax> })
-  - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmin> ^layer <lay>)
-  - (vertical ^status nil ^min < <vmin> ^max <vmin> ^com <vcom> ^layer <lay>)
-    (horizontal ^net-name { <nn1> <> nil } ^min { <garb1> <= <vcom> } ^max { <garb2> >= <vcom> } ^com <vmax> ^layer { <garb3> <> <lay> } ^compo <egarb2> ^commo <egarb3>)
-    (horizontal ^net-name { <garb7> <> <nn1> <> nil } ^min { <garb4> <= <vcom> } ^max { <garb5> >= <vcom> } ^com <vmin> ^layer { <garb6> <> <lay> } ^compo <egarb4> ^commo <egarb5>)
-  -->
-    (remove <v1>)
-)
-
-(p p110
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-  - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max2> ^layer <lay>)
-  - (horizontal ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> < <max2> })
-  - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> < <max2> } ^max-net nil)
-  - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> < <max2> } ^min-net nil)
-    (horizontal ^net-name { <nn> <> nil } ^min <garb1> ^max <max1> ^com <hcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>)
-    (vertical ^net-name { <nn1> <> <nn> <> nil } ^min { <garb4> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max2> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>)
-  - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> < <max2> })
-  -->
-    (modify <h1> ^max (compute <max2> - 1) ^max-net nil)
-)
-
-(p p111
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-  - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max1> ^layer <lay>)
-  - (horizontal ^min < <max1> ^max <max1> ^com <hcom> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> < <max2> })
-  - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> < <max2> } ^max-net nil)
-  - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> < <max2> } ^min-net nil)
-    (horizontal ^net-name { <nn> <> nil } ^min <max2> ^max <garb1> ^com <hcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>)
-    (vertical ^net-name { <nn1> <> <nn> <> nil } ^min { <garb4> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max1> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>)
-  - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> < <max2> })
-  -->
-    (modify <h1> ^min (compute <max1> + 1) ^min-net nil)
-)
-
-(p p112
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-  - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max2> ^layer <lay>)
-  - (horizontal ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { >= <max1> < <max2> })
-  - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { >= <max1> < <max2> } ^max-net nil)
-  - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { >= <max1> < <max2> } ^min-net nil)
-  - (horizontal ^min < <max1> ^max <max1> ^com <hcom> ^layer <lay>)
-    (vertical ^net-name { <nn1> <> nil } ^min { <garb1> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max2> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>)
-  - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { >= <max1> < <max2> })
-  -->
-    (modify <h1> ^max (compute <max2> - 1) ^max-net nil)
-)
-
-(p p113
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-  - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max1> ^layer <lay>)
-  - (horizontal ^min < <max1> ^max <max1> ^com <hcom> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> <= <max2> })
-  - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> <= <max2> } ^max-net nil)
-  - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> <= <max2> } ^min-net nil)
-  - (horizontal ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>)
-    (vertical ^net-name { <nn1> <> nil } ^min { <garb1> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max1> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>)
-  - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> <= <max2> })
-  -->
-    (modify <h1> ^min (compute <max1> + 1) ^min-net nil)
-)
-
-(p p114
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-    (vertical ^net-name { <nn> <> nil } ^min <garb1> ^max <max1> ^com <hcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>)
-  - (horizontal ^min <= <hcom> ^max >= <hcom> ^com <max2> ^layer <lay>)
-  - (vertical ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> < <max2> })
-  - (horizontal ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> < <max2> } ^max-net nil)
-  - (horizontal ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> < <max2> } ^min-net nil)
-    (horizontal ^net-name { <nn1> <> <nn> <> nil } ^min { <garb2> <= <hcom> } ^max { <garb3> >= <hcom> } ^com <max2> ^layer { <garb4> <> <lay> } ^compo <egarb6> ^commo <egarb7>)
-  - (horizontal ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> < <max2> })
-  -->
-    (modify <v1> ^max (compute <max2> - 1) ^max-net nil)
-)
-
-(p p115
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^compo <gy>)
-    { <v1> (vertical ^net-name nil ^min <vmin> ^max { <gy> > <vmin> } ^com <gx> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { >= <vmin> < <gy> })
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { >= <vmin> < <gy> } ^max-net nil)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { >= <vmin> < <gy> } ^min-net nil)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <vmin> < <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <vmin> ^max >= <vmin> ^com <gx>)
-  -->
-    (modify <v1> ^max (compute <gy> - 1) ^max-net nil)
-)
-
-(p p116
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { <max2> > <gx> } ^com <gy> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> <= <max2> } ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> <= <max2> })
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> <= <max2> } ^max-net nil)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> <= <max2> })
-  -->
-    (modify <h1> ^min (compute <gx> + 1) ^min-net nil)
-)
-
-(p p117
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <vmin> ^max { <vmax> > <vmin> } ^com <vcom> ^layer <lay> ^min-net { <nn> <> nil }) }
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { <hmax> >= <vcom> > <hmin> } ^com <vmax> ^layer <lay> ^commo <vmin> ^min-net { <> <nn> <> nil } ^max-net { <> <nn> <> nil })
-  - (vertical ^net-name nil ^min < <vmax> ^max > <vmax> ^com { > <hmin> < <hmax> })
-  - (vertical ^net-name nil ^min < <vmax> ^max <vmax> ^com { > <hmin> < <vcom> } ^max-net nil)
-  - (vertical ^net-name nil ^min < <vmax> ^max <vmax> ^com { > <vcom> < <hmax> } ^max-net nil)
-  - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com { > <hmin> < <hmax> } ^min-net nil)
-  - (vertical ^net-name { <nn> <> nil } ^min <= <vmax> ^max >= <vmax> ^com { > <hmin> < <hmax> })
-  -->
-    (remove <v1>)
-)
-
-(p p118
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>)
-  - (vertical ^net-name nil ^com <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com > <max1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com < <min1>)
-    { <h1> (horizontal ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) }
-  - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com { >= <min1> <= <max1> } ^layer <lay2>)
-    { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) }
-  - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>)
-    (pin ^net-name <nn2> ^pin-x < <com1>)
-    (pin ^net-name <nn2> ^pin-x > <com1>)
-    { <b1> (branch-no <pn>) }
-  -->
-    (make branch-no (compute <pn> + 1))
-    (modify <t1> ^no-of-attached-pins (compute <nap> - 1))
-    (remove <b1>)
-    (make horizontal ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make horizontal ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>)
-    (make horizontal ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cmo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from east)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cpo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from west)
-    (remove <h1>)
-)
-
-(p p119
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>)
-  - (vertical ^net-name nil ^com <com1>)
-    { <h1> (horizontal ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) }
-  - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com > <com2>)
-  - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com < <com2>)
-    { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) }
-  - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>)
-    (pin ^net-name <nn2> ^pin-x < <com1>)
-    (pin ^net-name <nn2> ^pin-x > <com1>)
-    { <b1> (branch-no <pn>) }
-  -->
-    (make branch-no (compute <pn> + 1))
-    (modify <t1> ^no-of-attached-pins (compute <nap> - 1))
-    (remove <b1>)
-    (make horizontal ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make horizontal ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>)
-    (make horizontal ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cmo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from east)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cpo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from west)
-    (remove <h1>)
-)
-
-(p p120
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>)
-  - (horizontal ^net-name nil ^com <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com > <max1>)
-  - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com < <min1>)
-    { <v1> (vertical ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) }
-  - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com { >= <min1> <= <max1> } ^layer <lay2>)
-    { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) }
-  - (vertical ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>)
-    (pin ^net-name <nn2> ^pin-y < <com1>)
-    (pin ^net-name <nn2> ^pin-y > <com1>)
-    { <b1> (branch-no <pn>) }
-  -->
-    (make branch-no (compute <pn> + 1))
-    (modify <t1> ^no-of-attached-pins (compute <nap> - 1))
-    (remove <b1>)
-    (make vertical ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make vertical ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>)
-    (make vertical ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cmo1> ^grid-layer <lay2> ^came-from north)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cpo1> ^grid-layer <lay2> ^came-from south)
-    (remove <v1>)
-)
-
-(p p121
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>)
-  - (horizontal ^net-name nil ^com <com1>)
-    { <v1> (vertical ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) }
-  - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com > <com2>)
-  - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com < <com2>)
-    { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) }
-  - (vertical ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>)
-    (pin ^net-name <nn2> ^pin-y < <com1>)
-    (pin ^net-name <nn2> ^pin-y > <com1>)
-    { <b1> (branch-no <pn>) }
-  -->
-    (make branch-no (compute <pn> + 1))
-    (modify <t1> ^no-of-attached-pins (compute <nap> - 1))
-    (remove <b1>)
-    (make vertical ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make vertical ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>)
-    (make vertical ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cmo1> ^grid-layer <lay2> ^came-from north)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cpo1> ^grid-layer <lay2> ^came-from south)
-    (remove <v1>)
-)
-
-(p p122
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <min2> ^max { <max2> > <min2> } ^com <com2> ^layer <lay2> ^compo <cpo2> ^commo <cmo2>) }
-  - (horizontal ^net-name nil ^min <= <min2> ^max >= <max2> ^com > <com2>)
-  - (horizontal ^net-name nil ^min <= <min2> ^max >= <max2> ^com < <com2>)
-  - (horizontal ^net-name nil ^min <= <min2> ^max >= <max2> ^com <com2> ^layer <> <lay2>)
-    (congestion ^direction col ^coordinate { <x1> <= <max2> } ^como { <x2> >= <min2> })
-  - (horizontal ^net-name nil ^min <= <x2> ^max >= <x1> ^com > <com2>)
-  - (horizontal ^net-name nil ^min <= <x2> ^max >= <x1> ^com < <com2>)
-  - (horizontal ^net-name nil ^min <= <x2> ^max >= <x1> ^com <com2> ^layer <> <lay2>)
-    { <t1> (to-be-routed ^net-name <nn2> ^no-of-attached-pins <nap>) }
-  - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <x2> ^max >= <x1>)
-    (pin ^net-name <nn2> ^pin-x <= <x2>)
-    (pin ^net-name <nn2> ^pin-x >= <x1>)
-    { <b1> (branch-no <pn>) }
-  - (horizontal ^net-name { <> <nn2> <> nil } ^min <= <x2> ^max >= <x2> ^com <com2> ^layer <lay2>)
-  - (vertical ^net-name { <> <nn2> <> nil } ^min <= <com2> ^max >= <com2> ^com <x2> ^layer <lay2>)
-  - (horizontal ^net-name { <> <nn2> <> nil } ^min <= <x1> ^max >= <x1> ^com <com2> ^layer <lay2>)
-  - (vertical ^net-name { <> <nn2> <> nil } ^min <= <com2> ^max >= <com2> ^com <x1> ^layer <lay2>)
-  -->
-    (make branch-no (compute <pn> + 1))
-    (modify <t1> ^no-of-attached-pins (compute <nap> - 1))
-    (remove <b1>)
-    (make horizontal ^min <x2> ^max <x1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make horizontal ^min <min2> ^max <x2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>)
-    (make horizontal ^min <x1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <x2> ^grid-y <com2> ^grid-layer <lay2> ^came-from east)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <x1> ^grid-y <com2> ^grid-layer <lay2> ^came-from west)
-    (remove <h1>)
-)
-
-(p p123
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com { <com1> <> 1 } ^layer <lay1> ^compo <cpo1> ^commo <cmo1> ^min-net <mnn> ^max-net <xnn>) }
-  - (horizontal ^net-name nil ^min < <com1> ^max > <com1>)
-    (horizontal ^net-name nil ^min <com1> ^max { <garb3> > <com1> } ^com { <bhcom> <= <max1> >= <min1> } ^layer <garb4>)
-    (horizontal ^net-name nil ^min { <garb1> < <com1> } ^max <com1> ^com { <thcom> <= <max1> > <bhcom> } ^layer <garb2>)
-  - (horizontal ^net-name nil ^min < <com1> ^max <com1> ^com { < <thcom> > <bhcom> })
-  - (horizontal ^net-name nil ^min <com1> ^max > <com1> ^com { < <thcom> > <bhcom> })
-    { <t1> (to-be-routed ^net-name <nn2> ^no-of-attached-pins <nap>) }
-  - (vertical ^status nil ^net-name { <nn2> <> nil } ^com <com1>)
-  - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>)
-    (pin ^net-name <nn2> ^pin-x < <com1>)
-    (pin ^net-name <nn2> ^pin-x > <com1>)
-    { <b1> (branch-no <pn>) }
-  -->
-    (make branch-no (compute <pn> + 1))
-    (modify <t1> ^no-of-attached-pins (compute <nap> - 1))
-    (remove <v1> <b1>)
-    (make vertical ^min <min1> ^max <bhcom> ^com <com1> ^layer <lay1> ^commo <cmo1> ^compo <cpo1> ^max-net <nn2> ^min-net <mnn>)
-    (make vertical ^min <thcom> ^max <max1> ^com <com1> ^layer <lay1> ^commo <cmo1> ^compo <cpo1> ^min-net <nn2> ^max-net <xnn>)
-    (make vertical ^min <bhcom> ^max <thcom> ^com <com1> ^layer <lay1> ^commo <cmo1> ^compo <cpo1> ^net-name <nn2> ^pin-name <pn>)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com1> ^grid-y <bhcom> ^grid-layer <lay1> ^came-from north)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com1> ^grid-y <thcom> ^grid-layer <lay1> ^came-from south)
-)
-
-(p p124
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <com2> ^grid-layer <lay1> ^pin-name <egarb1>)
-  - (vertical ^net-name nil ^min <= <com2> ^max >= <com2> ^com <gx>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com > <com2>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com < <com2>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min < <gx>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^com < <gx>)
-    { <h1> (horizontal ^net-name nil ^min { <min2> < <gx> } ^max { <max2> >= <gx> > <min2> } ^com <com2> ^layer <lay1> ^compo <cpo2> ^commo <cmo2> ^min-net <nn2>) }
-  -->
-    (make horizontal ^min <min2> ^max (compute <gx> - 1) ^com <com2> ^layer <lay1> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>)
-    (modify <h1> ^min <gx> ^min-net <nn1>)
-)
-
-(p p125
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <com2> ^grid-layer <lay1> ^pin-name <egarb1>)
-  - (vertical ^net-name nil ^min <= <com2> ^max >= <com2> ^com <gx>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com > <com2>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com < <com2>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^max > <gx>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^com > <gx>)
-    { <h1> (horizontal ^net-name nil ^min { <min2> <= <gx> } ^max { <max2> > <gx> > <min2> } ^com <com2> ^layer <lay1> ^compo <cpo2> ^commo <cmo2> ^max-net <nn2>) }
-  -->
-    (make horizontal ^min (compute <gx> + 1) ^max <max2> ^com <com2> ^layer <lay1> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>)
-    (modify <h1> ^max <gx> ^max-net <nn1>)
-)
-
-(p p126
-    (context ^present << propagate-constraint extend-total-verti >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> east ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) }
-  - (horizontal ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>)
-  - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>)
-  -->
-    (modify <h1> ^min (compute <max1> + 1) ^min-net <nn>)
-    (make horizontal ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>)
-    (modify <ff1> ^grid-x (compute <max1> + 1) ^came-from west ^can-chng-layer nil)
-)
-
-(p p127
-    (context ^present << propagate-constraint extend-total-verti >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> west ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <h1> (horizontal ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) }
-  - (horizontal ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>)
-  - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>)
-  -->
-    (modify <h1> ^max (compute <max1> - 1) ^max-net <nn>)
-    (make horizontal ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>)
-    (modify <ff1> ^grid-x (compute <max1> - 1) ^came-from east ^can-chng-layer nil)
-)
-
-(p p128
-    (context ^present << propagate-constraint extend-total-verti >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> north ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <v1> (vertical ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) }
-  - (vertical ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>)
-  -->
-    (modify <v1> ^min (compute <max1> + 1) ^min-net <nn>)
-    (make vertical ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>)
-    (modify <ff1> ^grid-y (compute <max1> + 1) ^came-from south ^can-chng-layer nil)
-)
-
-(p p129
-    (context ^present << propagate-constraint extend-total-verti >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> south ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <v1> (vertical ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) }
-  - (vertical ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>)
-  -->
-    (modify <v1> ^max (compute <max1> - 1) ^max-net <nn>)
-    (make vertical ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>)
-    (modify <ff1> ^grid-y (compute <max1> - 1) ^came-from north ^can-chng-layer nil)
-)
-
-(p p130
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <h1> (horizontal ^status nil ^net-name <nn> ^min <min> ^max { <max> > <min> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <gar1>) }
-    { <h2> (horizontal ^status nil ^net-name <nn> ^min <max> ^max { <max2> > <max> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <nn1>) }
-  -->
-    (modify <h1> ^max <max2> ^max-net <nn1>)
-    (remove <h2>)
-)
-
-(p p131
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <v1> (vertical ^status nil ^net-name <nn> ^min <min> ^max { <max> > <min> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <gar1>) }
-    { <v2> (vertical ^status nil ^net-name <nn> ^min <max> ^max { <max2> > <max> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <nn1>) }
-  -->
-    (modify <v1> ^max <max2> ^max-net <nn1>)
-    (remove <v2>)
-)
-
-(p p132
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <gar1> ^max <max> ^com <com> ^layer <lay> ^pin-name <pn>) }
-    { <h2> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) }
-    (vertical ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>)
-  -->
-    (modify <h1> ^max <max2>)
-    (remove <h2>)
-)
-
-(p p133
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <gar1> ^com <com> ^layer <lay> ^pin-name <pn>) }
-    { <h2> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min2> ^max <min> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) }
-    (vertical ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>)
-  -->
-    (modify <h1> ^min <min2>)
-    (remove <h2>)
-)
-
-(p p134
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <gar1> ^max <max> ^com <com> ^layer <lay> ^pin-name <pn>) }
-    { <v2> (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>)
-  -->
-    (modify <v1> ^max <max2>)
-    (remove <v2>)
-)
-
-(p p135
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <gar1> ^com <com> ^layer <lay> ^pin-name <pn>) }
-    { <v2> (vertical ^status nil ^net-name { <nn> <> nil } ^min <min2> ^max <min> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>)
-  -->
-    (modify <v1> ^min <min2>)
-    (remove <v2>)
-)
-
-(p p136
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> east ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) }
-  - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>)
-  -->
-    (modify <h1> ^min (compute <max1> + 1) ^min-net <nn>)
-    (make horizontal ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>)
-    (modify <ff1> ^grid-x (compute <max1> + 1) ^came-from west ^can-chng-layer nil)
-)
-
-(p p137
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> west ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <h1> (horizontal ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) }
-  - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>)
-  -->
-    (modify <h1> ^max (compute <max1> - 1) ^max-net <nn>)
-    (make horizontal ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>)
-    (modify <ff1> ^grid-x (compute <max1> - 1) ^came-from east ^can-chng-layer nil)
-)
-
-(p p138
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> north ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <v1> (vertical ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) }
-  - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>)
-  -->
-    (modify <v1> ^min (compute <max1> + 1) ^min-net <nn>)
-    (make vertical ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>)
-    (modify <ff1> ^grid-y (compute <max1> + 1) ^came-from south ^can-chng-layer nil)
-)
-
-(p p139
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> south ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <v1> (vertical ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) }
-  - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>)
-  - (vertical ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>)
-  -->
-    (modify <v1> ^max (compute <max1> - 1) ^max-net <nn>)
-    (make vertical ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>)
-    (modify <ff1> ^grid-y (compute <max1> - 1) ^came-from north ^can-chng-layer nil)
-)
-
-(p p140
-    (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com> ^max >= <com> ^com { >= <min> <= <max> } ^pin-name { <pn2> <> <pn1> })
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-  - (included <nn> <pn1>)
-    (included <nn> <pn2>)
-  -->
-    (make included <nn> <pn1>)
-    (modify <t1> ^no-of-attached-pins (compute <nap> + 1))
-)
-
-(p p141
-    (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com> ^max >= <com> ^com { >= <min> <= <max> } ^pin-name { <pn2> <> <pn1> })
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-    (included <nn> <pn1>)
-  - (included <nn> <pn2>)
-  -->
-    (make included <nn> <pn2>)
-    (modify <t1> ^no-of-attached-pins (compute <nap> + 1))
-)
-
-(p p142
-    (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> })
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-    (included <nn> <pn1>)
-  - (included <nn> <pn2>)
-  -->
-    (make included <nn> <pn2>)
-    (modify <t1> ^no-of-attached-pins (compute <nap> + 1))
-)
-
-(p p143
-    (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <egarb4> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> })
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-  - (included <nn> <pn1>)
-    (included <nn> <pn2>)
-  -->
-    (make included <nn> <pn1>)
-    (modify <t1> ^no-of-attached-pins (compute <nap> + 1))
-)
-
-(p p144
-    (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <egarb4> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> })
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-    (included <nn> <pn1>)
-  - (included <nn> <pn2>)
-  -->
-    (make included <nn> <pn2>)
-    (modify <t1> ^no-of-attached-pins (compute <nap> + 1))
-)
-
-(p p145
-    (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> })
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-  - (included <nn> <pn1>)
-    (included <nn> <pn2>)
-  -->
-    (make included <nn> <pn1>)
-    (modify <t1> ^no-of-attached-pins (compute <nap> + 1))
-)
-
-(p p146
-    { <c1> (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) }
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-    { <n1> (net ^net-name <nn> ^net-no-of-pins <nap>) }
-  -->
-    (remove <c1> <t1>)
-    (make join-routed-net <nn>)
-    (modify <n1> ^net-is-routed yes)
-)
-
-(p p147
-    { <c1> (context ^present check-for-routed-net) }
-  -->
-    (remove <c1>)
-    (make context ^present move-ff)
-)
-
-(p p148
-    { <con> (context ^present move-ff) }
-  -->
-    (modify <con> ^present set-min-max)
-)
-
-(p p149
-    { <con> (context ^present set-min-max) }
-  -->
-    (remove <con>)
-    (make context ^present propagate-constraint)
-)
-
-(p p150
-    (context ^present propagate-constraint)
-    { <c1> (constraint ^pin-name-2 <pn>) }
-  - (ff ^pin-name <pn>)
-  -->
-    (remove <c1>)
-)
-
-(p p151
-    (context ^present propagate-constraint)
-    { <c1> (constraint ^pin-name-1 <pn>) }
-  - (ff ^pin-name <pn>)
-  -->
-    (remove <c1>)
-)
-
-(p p152
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <ff2> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb2> ^pin-name <> <pn>) }
-  -->
-    (remove <ff1> <ff2>)
-)
-
-(p p153
-    (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <ff2> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2> ^grid-layer <lay> ^pin-name <> <pn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy1>)
-    { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1> <ff2>)
-    (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <v1> ^min <gy2> ^min-net <nn>)
-    (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p154
-    (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <gy2> ^layer <lay> ^compo <egarb1> ^commo <gy1> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2>)
-    { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1>)
-    (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <v1> ^min <gy2> ^min-net <nn>)
-    (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p155
-    (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2> ^grid-layer <lay> ^pin-name <pn>) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <gy1> ^layer <lay> ^compo <gy2> ^commo <egarb1> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1>)
-    { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1>)
-    (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <v1> ^min <gy2> ^min-net <nn>)
-    (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p156
-    (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) }
-    (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> > <gx1> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^pin-name <garb1>)
-    { <ff2> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> <= <max> } ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx1>)
-    { <h1> (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1> <ff2>)
-    (make horizontal ^min <min> ^max <gx1> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <h1> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^min <gx1> ^max <gx2> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p157
-    (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) }
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <gx2> ^layer <lay> ^compo <egarb1> ^commo <gx1> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-x <gx2> ^grid-y <gy>)
-    { <h1> (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1>)
-    (make horizontal ^min <min> ^max <gx1> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <h1> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^min <gx1> ^max <gx2> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p158
-    (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx2> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) }
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <gx1> ^layer <lay> ^compo <gx2> ^commo <egarb1> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy>)
-    { <h1> (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1>)
-    (make horizontal ^min <min> ^max <gx1> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <h1> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^min <gx1> ^max <gx2> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p159
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) }
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (vertical ^net-name <> nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-  - (horizontal ^net-name <> nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { >= <gy> > <vmin> } ^com <gx> ^layer { <lay2> <> <lay> })
-  -->
-    (modify <ff1> ^grid-layer <lay2> ^can-chng-layer no)
-)
-
-(p p160
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) }
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (vertical ^net-name <> nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-  - (horizontal ^net-name <> nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { >= <gx> > <hmin> } ^com <gy> ^layer { <lay2> <> lay> })
-  -->
-    (modify <ff1> ^grid-layer <lay2> ^can-chng-layer no)
-)
-
-(p p161
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) }
-  - (horizontal ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-  - (vertical ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-  -->
-    (modify <ff1> ^can-chng-layer no)
-)
-
-(p p162
-    (context ^present << propagate-constraint move-ff >>)
-    { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) }
-    (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-  -->
-    (modify <ff1> ^can-chng-layer no)
-)
-
-(p p163
-    (context ^present << propagate-constraint move-ff >>)
-    { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) }
-    (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-  -->
-    (modify <ff1> ^can-chng-layer no)
-)
-
-(p p164
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^can-chng-layer no ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn>) }
-    { <ff2> (ff ^can-chng-layer no ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay2> ^pin-name <garb1>) }
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx2>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy1>)
-    { <h1> (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> >= <gx1> > <hmin> } ^com <gy1> ^layer <lay1> ^compo <hcpo> ^commo <gy2> ^min-net <hnn1>) }
-    { <v1> (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> >= <gy1> > <vmin> } ^com <gx2> ^layer <lay2> ^compo <gx1> ^commo <vcmo> ^min-net <vnn1>) }
-  -->
-    (make horizontal ^min <hmin> ^max <gx2> ^com <gy1> ^commo <gy2> ^compo <hcpo> ^layer <lay1> ^min-net <hnn1> ^max-net <nn>)
-    (modify <h1> ^min <gx1> ^min-net <nn>)
-    (make vertical ^min <vmin> ^max <gy2> ^com <gx2> ^commo <vcmo> ^compo <gx1> ^layer <lay2> ^min-net <vnn1> ^max-net <nn>)
-    (modify <v1> ^min <gy1> ^min-net <nn>)
-    (remove <ff1> <ff2>)
-    (make horizontal ^min <gx2> ^max <gx1> ^com <gy1> ^commo <gy2> ^compo <hcpo> ^layer <lay1> ^net-name <nn> ^pin-name <pn>)
-    (make vertical ^min <gy2> ^max <gy1> ^com <gx2> ^commo <vcmo> ^compo <gx1> ^layer <lay2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p165
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <garb1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <v1> (vertical ^net-name nil ^min <garb2> ^max { <max> > <garb2> } ^com <com> ^layer <lay> ^max-net <> <nn>) }
-  -->
-    (modify <v1> ^max-net <nn>)
-)
-
-(p p166
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <min> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <v1> (vertical ^net-name nil ^min <min> ^max { <garb2> > <min> } ^com <com> ^layer <lay> ^min-net <> <nn>) }
-  -->
-    (modify <v1> ^min-net <nn>)
-)
-
-(p p167
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <max> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <v1> (vertical ^net-name nil ^min { <garb1> < <max> } ^max <max> ^com { >= <hmin> <= <hmax> } ^layer <lay> ^max-net <> <nn>) }
-  -->
-    (modify <v1> ^max-net <nn>)
-)
-
-(p p168
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <min> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <v1> (vertical ^net-name nil ^min <min> ^max { <garb1> > <min> } ^com { >= <hmin> <= <hmax> } ^layer <lay> ^min-net <> <nn>) }
-  -->
-    (modify <v1> ^min-net <nn>)
-)
-
-(p p169
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <garb1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <h1> (horizontal ^net-name nil ^min <garb2> ^max { <max> > <garb2> } ^com <com> ^layer <lay> ^max-net <> <nn>) }
-  -->
-    (modify <h1> ^max-net <nn>)
-)
-
-(p p170
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <min> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <h1> (horizontal ^net-name nil ^min <min> ^max { <garb2> > <min> } ^com <com> ^layer <lay> ^min-net <> <nn>) }
-  -->
-    (modify <h1> ^min-net <nn>)
-)
-
-(p p171
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <max> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <h1> (horizontal ^net-name nil ^min <garb1> ^max { <max> > <garb1> } ^com { >= <vmin> <= <vmax> } ^layer <lay> ^max-net <> <nn>) }
-  -->
-    (modify <h1> ^max-net <nn>)
-)
-
-(p p172
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <min> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <h1> (horizontal ^net-name nil ^min <min> ^max { <garb1> > <min> } ^com { >= <vmin> <= <vmax> } ^layer <lay> ^min-net <> <nn>) }
-  -->
-    (modify <h1> ^min-net <nn>)
-)
-
-(p p173
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^can-chng-layer no ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <gy2> ^layer <garb3> ^compo <garb4> ^commo <gy1> ^pin-name <> <pn>)
-  - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com <gy2>)
-  - (vertical ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx>)
-    { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1>)
-    (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <v1> ^min <gy2> ^min-net <nn>)
-    (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p174
-    (join-routed-net <nn>)
-    { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <com> ^layer <lay> ^compo <garb1> ^commo <garb2>) }
-    { <h2> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>) }
-  -->
-    (modify <h1> ^max <max2>)
-    (remove <h2>)
-)
-
-(p p175
-    (join-routed-net <nn>)
-    { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <max> ^com <com> ^layer <lay> ^compo <garb2> ^commo <garb3>) }
-    { <v2> (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-  -->
-    (modify <v1> ^max <max2>)
-    (remove <v2>)
-)
-
-(p p176
-    { <j1> (join-routed-net <nn>) }
-  -->
-    (remove <j1>)
-    (make move-via <nn>)
-)
-
-(p p177
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <vlayer> ^pin-name <egarb1>)
-    (horizontal ^net-name nil ^min <hmin2> ^max { <gx> > <hmin2> } ^com <vmax> ^layer <vlayer> ^compo <egarb8> ^commo <egarb9>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { < <vmax> > <gy> })
-    { <v1> (vertical ^net-name nil ^min { <garb1> <= <gy> } ^max { <vmax> > <garb1> > <gy> } ^com <gx> ^layer <vlayer> ^commo <cmo> ^compo <cpo> ^max-net <maxn>) }
-    (horizontal ^net-name { <> <nn> <> nil } ^min { <hmin1> <= <gx> } ^max >= <gx> ^com <vmax> ^layer <> <vlayer>)
-    (vertical ^net-name { <> <nn> <> nil } ^min <= <vmax> ^max >= <vmax> ^com { <vcom> < <gx> >= <hmin1> >= <hmin2> } ^layer <vlayer>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com <vmax>)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { < <vmax> > <gy> } ^max-net nil)
-  - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <gx>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmax> ^max > <vmax> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <gx> ^max > <gx> ^com <vmax>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { < <vmax> > <gy> } ^min-net nil)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { < <vmax> > <gy> })
-  - (vertical ^net-name nil ^min < <vmax> ^max > <vmax> ^com { < <gx> > <vcom> })
-  - (vertical ^net-name nil ^min < <vmax> ^max <vmax> ^com { < <gx> > <vcom> } ^max-net nil)
-  - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com { < <gx> > <vcom> } ^min-net nil)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <vmax> ^max >= <vmax> ^com { < <gx> > <vcom> })
-  -->
-    (make vertical ^min (compute <gy> + 1) ^max <vmax> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <vlayer> ^max-net <maxn>)
-    (modify <v1> ^max <gy> ^max-net <nn>)
-)
-
-(p p178
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <layer> ^pin-name <pn>)
-    { <h1> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <gx> > <hmin> } ^com <gy> ^layer <layer> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (vertical ^net-name { <> <nn> <> nil } ^min <cpo> ^max { <garb2> >= <cpo> } ^com <vcom> ^layer <layer1> ^compo <vcpo> ^commo <gx>)
-    (horizontal ^net-name { <> <nn> <> nil } ^min { <garb3> <= <vcom> } ^max { <garb4> >= <vcom> } ^com <cpo> ^layer <> <layer1> ^compo <garb5> ^commo <gy>)
-    (vertical ^net-name { <> <nn> <> nil } ^min { <garb6> <= <cmo> } ^max <cmo> ^com <vcom> ^layer <layer2> ^compo <vcpo> ^commo <gx>)
-    (horizontal ^net-name { <> <nn> <> nil } ^min { <garb7> <= <vcom> } ^max { <garb8> >= <vcom> } ^com <cmo> ^layer <> <layer2> ^compo <gy> ^commo <garb9>)
-    (vertical ^net-name { <> <nn> <> nil } ^min { <garb13> <= <gy> } ^max { <garb14> >= <gy> } ^com <vcpo> ^layer <layer3> ^compo <garb10> ^commo <vcom>)
-    (horizontal ^net-name { <> <nn> <> nil } ^min { <garb11> <= <vcpo> } ^max { <garb12> >= <vcpo> } ^com <gy> ^layer <> <layer3> ^compo <cpo> ^commo <cmo>)
-  -->
-    (make horizontal ^min (compute <gx> + 1) ^max <hmax> ^com <gy> ^compo <cpo> ^commo <cmo> ^layer <layer> ^max-net <mn>)
-    (modify <h1> ^max <gx> ^max-net <nn>)
-)
-
-(p p179
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <pn>) }
-    (vertical ^net-name { <> <nn> <> nil } ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> } ^com <vcom> ^layer <lay2> ^compo <garb1> ^commo <gx>)
-    (vertical ^net-name { <> <nn> <> nil } ^min { <vmax2> > <gy> <= <vmax> } ^max <garb4> ^com <gx> ^layer <lay4>)
-    (vertical ^net-name { <> <nn> <> nil } ^min <garb2> ^max { <vmin2> < <gy> >= <vmin> } ^com <gx> ^layer <lay3>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmin2> < <gy> })
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmin2> < <gy> } ^layer <> <lay2> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmin2> < <gy> } ^max-net nil)
-  - (horizontal ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { > <vmin2> < <gy> })
-    (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <vmin2> ^layer <> <lay3>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmax2> })
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmax2> } ^layer <> <lay2> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmax2> } ^max-net nil)
-  - (horizontal ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmax2> })
-    (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <vmax2> ^layer <> <lay4>)
-    { <h1> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> >= <vcom> > <hmin> } ^com <gy> ^layer { <lay5> <> <lay2> } ^compo <hcpo> ^commo <hcmo> ^max-net <mn>) }
-  -->
-    (make horizontal ^layer <lay5> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <nn> ^max-net <mn> ^min <vcom> ^max <hmax>)
-    (modify <h1> ^max <gx> ^max-net <nn>)
-    (make horizontal ^layer <lay5> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <vcom>)
-    (modify <ff1> ^grid-x <vcom> ^grid-layer <lay5> ^can-chng-layer no)
-)
-
-(p p180
-    (context ^present propagate-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <vmax> ^com <vcom> ^layer <lay1> ^compo <cpo> ^commo <cmo>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb2> <= <vcom> } ^max { <garb3> >= <vcom> } ^com <vmax> ^layer { <garb4> <> <lay1> })
-    (vertical ^net-name { <nn1> <> <nn> <> nil } ^min { <vmin> > <vmax> } ^max <garb5> ^com <vcom> ^layer <lay2>)
-    (horizontal ^net-name { <nn1> <> nil } ^min { <garb6> <= <vcom> } ^max { <garb7> >= <vcom> } ^com <vmin> ^layer { <garb8> <> <lay2> })
-    (vertical ^net-name { <> <nn> <> nil } ^min { <vmin2> <= <vmax> } ^max { <vmax2> >= <vmin> } ^com <cpo> ^layer <lay3>)
-    { <v1> (vertical ^net-name nil ^min <vmax> ^max { <vmax3> > <vmax> } ^com <vcom> ^layer <lay3>) }
-  - (vertical ^net-name nil ^min <vmax3> ^com <vcom>)
-  - (horizontal ^net-name nil ^min < <vcom> ^max > <vcom> ^com { > <vmax> <= <vmax3> })
-  - (horizontal ^net-name nil ^min <vcom> ^max > <vcom> ^com { > <vmax> <= <vmax3> } ^layer <> <lay3> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <vcom> ^max <vcom> ^com { > <vmax> <= <vmax3> } ^max-net nil)
-  - (horizontal ^net-name { <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com { > <vmax> <= <vmax3> })
-  -->
-    (modify <v1> ^min (compute <vmax> + 1) ^min-net nil)
-)
-
-(p p181
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <garb1> ^grid-layer <lay> ^pin-name <> <pn>)
-  - (vertical ^com { > <gx> < <gx2> })
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { <egarb1> > <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2>)
-  -->
-    (modify <h1> ^min (compute <gx> + 1) ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^com <gy> ^max (compute <gx> + 1) ^commo <hcmo> ^compo <hcpo> ^layer <lay>)
-    (modify <ff1> ^grid-x (compute <gx> + 1) ^came-from west)
-)
-
-(p p182
-    (context ^present propagate-constraint)
-    { <v3> (vertical ^net-name nil ^min <vmin2> ^max { <vmax2> > <vmin2> } ^com <vcom> ^layer <garb1> ^compo <vcpo> ^commo <egarb1>) }
-    (congestion ^direction row ^coordinate <vmax2> ^como <vmin2>)
-  - (horizontal ^status nil ^min < <vcom> ^max >= <vcom> ^com { <= <vmax2> >= <vmin2> })
-  - (vertical ^status nil ^min <vmax2> ^max > <vmax2> ^com <vcom>)
-  - (vertical ^status nil ^max <vmin2> ^min < <vmin2> ^com <vcom>)
-    (vertical ^net-name nil ^min { <vmin> <= <vmin2> } ^max { > <vmin> >= <vmax2> } ^com <vcpo> ^layer <lay>)
-    (horizontal ^net-name nil ^min <vcom> ^max { <egarb2> > <vcom> } ^com <vmax2> ^layer <lay> ^compo <egarb3> ^commo <egarb4>)
-    (horizontal ^net-name nil ^min <vcom> ^max { <egarb5> > <vcom> } ^com <vmin2> ^layer <lay> ^compo <egarb6> ^commo <egarb7>)
-  -->
-    (remove <v3>)
-)
-
-(p p183
-    (context ^present propagate-constraint)
-    { <v3> (vertical ^net-name nil ^min <vmin2> ^max { <vmax2> > <vmin2> } ^com <vcom> ^layer <garb1> ^compo <garb2> ^commo <vcmo>) }
-    (congestion ^direction row ^coordinate <vmax2> ^como <vmin2>)
-  - (horizontal ^status nil ^min <= <vcom> ^max > <vcom> ^com { <= <vmax2> >= <vmin2> })
-  - (vertical ^status nil ^min <vmax2> ^max > <vmax2> ^com <vcom>)
-  - (vertical ^status nil ^max <vmin2> ^min < <vmin2> ^com <vcom>)
-    (vertical ^net-name nil ^min { <vmin> <= <vmin2> } ^max { > <vmin> >= <vmax2> } ^com <vcmo> ^layer <lay>)
-    (horizontal ^net-name nil ^min <egarb1> ^max { <vcom> > <egarb1> } ^com <vmax2> ^layer <lay> ^compo <egarb2> ^commo <egarb3>)
-    (horizontal ^net-name nil ^min <egarb6> ^max { <vcom> > <egarb6> } ^com <vmin2> ^layer <lay> ^compo <egarb4> ^commo <egarb5>)
-  -->
-    (remove <v3>)
-)
-
-(p p184
-    (context ^present propagate-constraint)
-    { <h3> (horizontal ^net-name nil ^min <hmin2> ^max { <hmax2> > <hmin2> } ^com <hcom> ^layer <garb1> ^compo <hcpo> ^commo <egarb1>) }
-    (congestion ^direction col ^coordinate <hmax2> ^como <hmin2>)
-  - (vertical ^status nil ^min < <hcom> ^max >= <hcom> ^com { <= <hmax2> >= <hmin2> })
-  - (horizontal ^status nil ^min <hmax2> ^max > <hmax2> ^com <hcom>)
-  - (horizontal ^status nil ^max <hmin2> ^min < <hmin2> ^com <hcom>)
-    (horizontal ^net-name nil ^min { <hmin> <= <hmin2> } ^max { > <hmin> >= <hmax2> } ^com <hcpo> ^layer <lay>)
-    (vertical ^net-name nil ^min <hcom> ^max { <egarb2> > <hcom> } ^com <hmax2> ^layer <lay> ^compo <egarb3> ^commo <egarb4>)
-    (vertical ^net-name nil ^min <hcom> ^max { <egarb5> > <hcom> } ^com <hmin2> ^layer <lay> ^compo <egarb6> ^commo <egarb7>)
-  -->
-    (remove <h3>)
-)
-
-(p p185
-    (context ^present propagate-constraint)
-    { <h3> (horizontal ^net-name nil ^min <hmin2> ^max { <hmax2> > <hmin2> } ^com <hcom> ^layer <garb1> ^compo <garb2> ^commo <hcmo>) }
-    (congestion ^direction col ^coordinate <hmax2> ^como <hmin2>)
-  - (vertical ^status nil ^min <= <hcom> ^max > <hcom> ^com { <= <hmax2> >= <hmin2> })
-  - (horizontal ^status nil ^min <hmax2> ^max > <hmax2> ^com <hcom>)
-  - (horizontal ^status nil ^max <hmin2> ^min < <hmin2> ^com <hcom>)
-    (horizontal ^net-name nil ^min { <hmin> <= <hmin2> } ^max { > <hmin> >= <hmax2> } ^com <hcmo> ^layer <lay>)
-    (vertical ^net-name nil ^min <egarb1> ^max { <hcom> > <egarb1> } ^com <hmax2> ^layer <lay> ^compo <egarb3> ^compo <egarb4>)
-    (vertical ^net-name nil ^min <egarb5> ^max { <hcom> > <egarb5> } ^com <hmin2> ^layer <lay> ^compo <egarb6> ^commo <egarb7>)
-  -->
-    (remove <h3>)
-)
-
-(p p538
-    (finally-routed <nn>)
-    { <i1> (included <nn>) }
-  -->
-    (remove <i1>)
-)
-
-(p p539
-    (finally-routed <nn>)
-    { <ff1> (ff ^net-name <nn>) }
-  -->
-    (remove <ff1>)
-)
-
-(p p540
-    (finally-routed <nn>)
-    { <c1> (constraint ^constraint-type << vertical horizontal >> ^net-name-1 <nn>) }
-  -->
-    (remove <c1>)
-)
-
-(p p541
-    (finally-routed <nn>)
-    { <c1> (constraint ^constraint-type << vertical horizontal >> ^net-name-2 <nn>) }
-  -->
-    (remove <c1>)
-)
-
-(p p542
-    (finally-routed <nn>)
-    { <c> (<< horizontal-cycle vertical-cycle >> <nn>) }
-  -->
-    (remove <c>)
-)
-
-(p p543
-    (finally-routed <nn>)
-    { <c1> (constraint ^constraint-type << vertical horizontal >> ^net-name-2 <nn>) }
-  -->
-    (remove <c1>)
-)
-
-(p p544
-    (finally-routed <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <garb1> ^commo <garb2>)
-    { <h1> (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { <hmax> > <hmin> >= <vcom> } ^com { <hcom> >= <vmin> <= <vmax> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <nn1>) }
-  -->
-    (make horizontal ^min <hmin> ^max (compute <vcom> - 1) ^com <hcom> ^compo <hcpo> ^commo <hcmo> ^layer <lay> ^min-net <nn1>)
-    (modify <h1> ^min (compute <vcom> + 1) ^min-net nil)
-)
-
-(p p545
-    (finally-routed <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <garb1> ^commo <garb2>)
-    { <v1> (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { <vmax> > <vmin> >= <hcom> } ^com { <vcom> >= <hmin> <= <hmax> } ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <nn1>) }
-  -->
-    (make vertical ^min <vmin> ^max (compute <hcom> - 1) ^com <vcom> ^compo <vcpo> ^commo <vcmo> ^layer <lay> ^min-net <nn1>)
-    (modify <v1> ^min (compute <hcom> + 1) ^min-net nil)
-)
-
-(p p546
-    (finally-routed <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <rmax> ^com <com> ^layer <lay> ^compo <garb4> ^commo <garb3>)
-    { <v1> (vertical ^net-name nil ^min <rmax> ^max { <garb2> > <rmax> } ^com <com> ^layer <lay> ^compo <garb6> ^commo <garb5>) }
-  -->
-    (modify <v1> ^min (compute <rmax> + 1) ^min-net nil)
-)
-
-(p p547
-    (finally-routed <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <rmin> ^max <garb1> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>)
-    { <v1> (vertical ^net-name nil ^min <garb2> ^max { <rmin> > <garb2> } ^com <com> ^layer <lay> ^compo <garb5> ^commo <garb6>) }
-  -->
-    (modify <v1> ^max (compute <rmin> - 1) ^max-net nil)
-)
-
-(p p548
-    (finally-routed <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <rmax> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>)
-    { <h1> (horizontal ^net-name nil ^min <rmax> ^max { <garb2> > <rmax> } ^com <com> ^layer <lay> ^compo <garb5> ^commo <garb6>) }
-  -->
-    (modify <h1> ^min (compute <rmax> + 1) ^min-net nil)
-)
-
-(p p549
-    (finally-routed <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <rmin> ^max <garb1> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>)
-    { <h1> (horizontal ^net-name nil ^min <garb2> ^max { <rmin> > <garb2> } ^com <com> ^layer <lay> ^compo <garb5> ^commo <garb6>) }
-  -->
-    (modify <h1> ^max (compute <rmin> - 1) ^max-net nil)
-)
-
-(p p550
-    { <f1> (finally-routed <nn>) }
-  -->
-    (remove <f1>)
-    (make context ^present remove-routed-net-segments <nn>)
-)
-
-(p p551
-    (context ^present remove-routed-net-segments <nn>)
-    { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <c> ^layer <lay> ^compo <garb1> ^commo <garb2>) }
-  -->
-    (modify <h1> ^status routed)
-    (write (crlf) |hor | <nn> <min> <max> <c> <lay>)
-)
-
-(p p552
-    (context ^present remove-routed-net-segments <nn>)
-    { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <c> ^layer <lay> ^compo <garb1> ^commo <garb2>) }
-  -->
-    (modify <v1> ^status routed)
-    (write (crlf) |ver | <nn> <min> <max> <c> <lay>)
-)
-
-(p p553
-    (context ^present remove-routed-net-segments <nn>)
-    { <h> (horizontal-s ^net-name <nn>) }
-  -->
-    (remove <h>)
-)
-
-(p p554
-    (context ^present remove-routed-net-segments <nn>)
-    { <v> (vertical-s ^net-name <nn>) }
-  -->
-    (remove <v>)
-)
-
-(p p555
-    (context ^present remove-routed-net-segments <nn>)
-    { <p> (pin ^net-name <nn>) }
-  -->
-    (remove <p>)
-)
-
-(p p556
-    (context ^present remove-routed-net-segments <nn>)
-    { <n> (net ^net-name <nn>) }
-  -->
-    (remove <n>)
-)
-
-(p p557
-    { <c1> (context ^present remove-routed-net-segments) }
-  -->
-    (remove <c1>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p32
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-    { <v> (vertical ^net-name nil ^min <gy2> ^max > <gy2> ^com <gx2> ^layer <lay> ^commo <cmo> ^compo <gx1> ^min-net <garb2>) }
-  - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com <gy2> ^layer <lay>)
-    (congestion ^direction row ^coordinate <gy3> ^como <gy2>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx2> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy3> ^layer <lay>)
-  -->
-    (modify <v> ^min <gy3> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn2> ^min <gy2> ^max <gy3> ^com <gx2> ^compo <gx1> ^commo <cmo> ^layer <lay>)
-    (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from south)
-)
-
-(p p33
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-    { <v> (vertical ^net-name nil ^min < <gy1> ^max <gy1> ^com <gx1> ^layer <lay> ^commo <gx2> ^compo <cpo> ^min-net <garb2>) }
-  - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com <gy1> ^layer <lay>)
-    (congestion ^direction row ^coordinate <gy1> ^como <gy3>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx1> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy3> ^layer <lay>)
-  -->
-    (modify <v> ^max <gy3> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn1> ^min <gy3> ^max <gy1> ^com <gx1> ^compo <cpo> ^commo <gx2> ^layer <lay>)
-    (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from north)
-)
-
-(p p34
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-    { <v> (vertical ^net-name nil ^min <gy2> ^max > <gy2> ^com <gx2> ^layer <lay> ^commo <gx1> ^compo <cpo> ^min-net <garb2>) }
-  - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com <gy2> ^layer <lay>)
-    (congestion ^direction row ^coordinate <gy3> ^como <gy2>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx2> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy3> ^layer <lay>)
-  -->
-    (modify <v> ^min <gy3> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn2> ^min <gy2> ^max <gy3> ^com <gx2> ^compo <cpo> ^commo <gx1> ^layer <lay>)
-    (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from south)
-)
-
-(p p35
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-    { <v> (vertical ^net-name nil ^min < <gy1> ^max <gy1> ^com <gx1> ^layer <lay> ^commo <cmo> ^compo <gx2> ^min-net <garb2>) }
-  - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com <gy1> ^layer <lay>)
-    (congestion ^direction row ^coordinate <gy1> ^como <gy3>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx1> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy3> ^layer <lay>)
-  -->
-    (modify <v> ^max <gy3> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn1> ^min <gy3> ^max <gy1> ^com <gx1> ^compo <gx2> ^commo <cmo> ^layer <lay>)
-    (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from north)
-)
-
-(p p36
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-    { <v> (horizontal ^net-name nil ^min <gx2> ^max > <gx2> ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gy1> ^min-net <garb2>) }
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx2> ^layer <lay>)
-    (congestion ^direction col ^coordinate <gx3> ^como <gx2>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy2> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx3> ^layer <lay>)
-  -->
-    (modify <v> ^min <gx3> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn2> ^min <gx2> ^max <gx3> ^com <gy2> ^compo <gy1> ^commo <cmo> ^layer <lay>)
-    (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from west)
-)
-
-(p p37
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-    { <v> (horizontal ^net-name nil ^min < <gx1> ^max <gx1> ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^min-net <garb2>) }
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx1> ^layer <lay>)
-    (congestion ^direction col ^coordinate <gx1> ^como <gx3>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy1> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx3> ^layer <lay>)
-  -->
-    (modify <v> ^max <gx3> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn1> ^min <gx3> ^max <gx1> ^com <gy1> ^compo <cpo> ^commo <gy2> ^layer <lay>)
-    (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from east)
-)
-
-(p p38
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-    { <v> (horizontal ^net-name nil ^min < <gx2> ^max <gx2> ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gx1> ^min-net <garb2>) }
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx2> ^layer <lay>)
-    (congestion ^direction col ^coordinate <gx2> ^como <gx3>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy2> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx3> ^layer <lay>)
-  -->
-    (modify <v> ^max <gx3> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn2> ^min <gx3> ^max <gx2> ^com <gy2> ^compo <gy1> ^commo <cmo> ^layer <lay>)
-    (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from east)
-)
-
-(p p39
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-    { <v> (horizontal ^net-name nil ^min <gx1> ^max > <gx1> ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^min-net <garb2>) }
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx1> ^layer <lay>)
-    (congestion ^direction col ^coordinate <gx3> ^como <gx1>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy1> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx3> ^layer <lay>)
-  -->
-    (modify <v> ^min <gx3> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn1> ^min <gx1> ^max <gx3> ^com <gy1> ^compo <cpo> ^commo <gy2> ^layer <lay>)
-    (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from west)
-)
-
-(p p40
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>)
-    (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^max <hmax2> ^max-net nil)
-)
-
-(p p41
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>)
-    (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^min <hmax2> ^min-net nil)
-)
-
-(p p42
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>)
-    (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>)
-    (last-row <gy>)
-  -->
-    (modify <h1> ^max <hmax2> ^max-net nil)
-)
-
-(p p43
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>)
-    (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>)
-    (last-row <gy>)
-  -->
-    (modify <h1> ^min <hmax2> ^min-net nil)
-)
-
-(p p44
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay> ^commo 0) }
-    (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>)
-    (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^max <hmax2> ^max-net nil)
-)
-
-(p p45
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay> ^commo 0) }
-    (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>)
-    (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^min <hmax2> ^min-net nil)
-)
-
-(p p46
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil)
-    { <h1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>)
-    (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^max <vmax2> ^max-net nil)
-)
-
-(p p47
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>)
-    (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <v1> ^min <vmax2> ^min-net nil)
-)
-
-(p p48
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>)
-    (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>)
-    (last-col <gx>)
-  -->
-    (modify <v1> ^max <vmax2> ^max-net nil)
-)
-
-(p p49
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>)
-    (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>)
-    (last-col <gx>)
-  -->
-    (modify <v1> ^min <vmax2> ^min-net nil)
-)
-
-(p p50
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay> ^commo 0) }
-    (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>)
-    (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <v1> ^max <vmax2> ^max-net nil)
-)
-
-(p p51
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay> ^commo 0) }
-    (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>)
-    (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <v1> ^min <vmax2> ^min-net nil)
-)
-
-(p p52
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <gx> ^max <ppgarb> ^com <gy>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>)
-    (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^max <hmax2> ^max-net nil)
-)
-
-(p p53
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gx> ^com <gy>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>)
-    (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^min <hmax2> ^min-net nil)
-)
-
-(p p54
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <gx> ^max <ppgarb> ^com <gy>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>)
-    (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>)
-    (last-row <gy>)
-  -->
-    (modify <h1> ^max <hmax2> ^max-net nil)
-)
-
-(p p55
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gx> ^com <gy>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>)
-    (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>)
-    (last-row <gy>)
-  -->
-    (modify <h1> ^min <hmax2> ^min-net nil)
-)
-
-(p p56
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <gx> ^max <ppgarb> ^com <gy>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay> ^commo 0) }
-    (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>)
-    (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^max <hmax2> ^max-net nil)
-)
-
-(p p57
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gx> ^com <gy>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay> ^commo 0) }
-    (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>)
-    (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^min <hmax2> ^min-net nil)
-)
-
-(p p58
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <gy> ^max <ppgarb> ^com <gx>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil)
-    { <h1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>)
-    (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^max <vmax2> ^max-net nil)
-)
-
-(p p59
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gy> ^com <gx>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>)
-    (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <v1> ^min <vmax2> ^min-net nil)
-)
-
-(p p60
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <gy> ^max <ppgarb> ^com <gx>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>)
-    (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>)
-    (last-col <gx>)
-  -->
-    (modify <v1> ^max <vmax2> ^max-net nil)
-)
-
-(p p61
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gy> ^com <gx>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>)
-    (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>)
-    (last-col <gx>)
-  -->
-    (modify <v1> ^min <vmax2> ^min-net nil)
-)
-
-(p p62
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <gy> ^max <ppgarb> ^com <gx>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay> ^commo 0) }
-    (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>)
-    (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <v1> ^max <vmax2> ^max-net nil)
-)
-
-(p p63
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gy> ^com <gx>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay> ^commo 0) }
-    (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>)
-    (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <v1> ^min <vmax2> ^min-net nil)
-)
-
-(p p64
-    (context ^present propagate-constraint)
-    { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max { <hmax> > <vcom> } ^com <vmax> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    (vertical ^net-name { <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>)
-    (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcpo> ^layer <lay> ^compo <garb2> ^commo <vcom>)
-    (horizontal ^net-name nil ^min < <vcom> ^max > <vcom> ^com <hcmo> ^layer <lay>)
-  - (vertical ^status nil ^min <vmax> ^max > <vmax> ^com <vcom>)
-  - (horizontal ^status nil ^min { <temp> <= <vcom> } ^max { > <temp> >= <vcom> } ^com <vmax> ^layer <> <lay>)
-  -->
-    (modify <v> ^max <hcmo> ^max-net nil)
-    (make (substr <h> 1 inf) ^max <vcmo> ^max-net <nn1>)
-    (modify <h> ^min <vcpo> ^min-net <nn2>)
-)
-
-(p p65
-    (context ^present propagate-constraint)
-    { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max { <hmax> > <vcom> } ^com <vmin> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    (vertical ^net-name { <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>)
-    (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcpo> ^layer <lay> ^compo <garb2> ^commo <vcom>)
-    (horizontal ^net-name nil ^min < <vcom> ^max > <vcom> ^com <hcpo> ^layer <lay>)
-  - (vertical ^status nil ^min < <vmin> ^max <vmin> ^com <vcom>)
-  - (horizontal ^status nil ^min { <temp> <= <vcom> } ^max { > <temp> >= <vcom> } ^com <vmin> ^layer <> <lay>)
-  -->
-    (modify <v> ^min <hcpo> ^min-net nil)
-    (make (substr <h> 1 inf) ^max <vcmo> ^max-net <nn1>)
-    (modify <h> ^min <vcpo> ^min-net <nn2>)
-)
-
-(p p66
-    (context ^present propagate-constraint)
-    { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max { <vmax> > <hcom> } ^com <hmax> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    (horizontal ^net-name { <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>)
-    (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcpo> ^layer <lay> ^compo <garb2> ^commo <hcom>)
-    (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com <vcmo> ^layer <lay>)
-  - (horizontal ^status nil ^min <hmax> ^max > <hmax> ^com <hcom>)
-  - (vertical ^status nil ^min { <temp> <= <hcom> } ^max { > <temp> >= <hcom> } ^com <hmax> ^layer <> <lay>)
-  -->
-    (modify <h> ^max <vcmo> ^max-net nil)
-    (make (substr <v> 1 inf) ^max <hcmo> ^max-net <nn1>)
-    (modify <v> ^min <hcpo> ^min-net <nn2>)
-)
-
-(p p67
-    (context ^present propagate-constraint)
-    { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max { <vmax> > <hcom> } ^com <hmin> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    (horizontal ^net-name { <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>)
-    (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcpo> ^layer <lay> ^compo <garb2> ^commo <hcom>)
-    (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com <vcpo> ^layer <lay>)
-  - (horizontal ^status nil ^min < <hmin> ^max <hmin> ^com <hcom>)
-  - (vertical ^status nil ^min { <temp> <= <hcom> } ^max { > <temp> >= <hcom> } ^com <hmin> ^layer <> <lay>)
-  -->
-    (modify <h> ^min <vcpo> ^min-net nil)
-    (make (substr <v> 1 inf) ^max <hcmo> ^max-net <nn1>)
-    (modify <v> ^min <hcpo> ^min-net <nn2>)
-)
-
-(p p68
-    (context ^present propagate-constraint)
-    { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com <vmax> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    (vertical ^net-name { <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>)
-    (horizontal ^net-name nil ^min < <vcom> ^max >= <vcom> ^com <hcmo> ^layer <lay>)
-  - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <vcom> ^max > <vcom> ^com <vmax> ^layer <> <lay>)
-  -->
-    (modify <h> ^max <vcmo> ^max-net <nn1>)
-)
-
-(p p69
-    (context ^present propagate-constraint)
-    { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    { <h> (horizontal ^net-name nil ^min <vcom> ^max { <hmax> > <vcom> } ^com <vmax> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    (vertical ^net-name { <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcpo> ^layer <lay> ^compo <garb1> ^commo <vcom>)
-    (horizontal ^net-name nil ^min <= <vcom> ^max > <vcom> ^com <hcmo> ^layer <lay>)
-  - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <vcom> ^max <vcom> ^com <vmax> ^layer <> <lay>)
-  -->
-    (modify <h> ^min <vcpo> ^min-net <nn1>)
-)
-
-(p p70
-    (context ^present propagate-constraint)
-    { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com <vmin> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    (vertical ^net-name { <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>)
-    (horizontal ^net-name nil ^min < <vcom> ^max >= <vcom> ^com <hcpo> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <vmin> ^max <vmin> ^com <vcom> ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <vcom> ^max > <vcom> ^com <vmin> ^layer <> <lay>)
-  -->
-    (modify <h> ^max <vcmo> ^max-net <nn1>)
-)
-
-(p p71
-    (context ^present propagate-constraint)
-    { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    { <h> (horizontal ^net-name nil ^min <vcom> ^max { <hmax> > <vcom> } ^com <vmin> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    (vertical ^net-name { <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcpo> ^layer <lay> ^compo <garb1> ^commo <vcom>)
-    (horizontal ^net-name nil ^min <= <vcom> ^max > <vcom> ^com <hcpo> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <vmin> ^max <vmin> ^com <vcom> ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <vcom> ^max <vcom> ^com <vmin> ^layer <> <lay>)
-  -->
-    (modify <h> ^min <vcpo> ^min-net <nn1>)
-)
-
-(p p72
-    (context ^present propagate-constraint)
-    { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    { <v> (vertical ^net-name nil ^min <hcom> ^max { <vmax> > <hcom> } ^com <hmax> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    (horizontal ^net-name { <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcpo> ^layer <lay> ^compo <garb1> ^commo <hcom>)
-    (vertical ^net-name nil ^min <= <hcom> ^max > <hcom> ^com <vcmo> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com <hmax> ^layer <> <lay>)
-  -->
-    (modify <v> ^min <hcpo> ^min-net <nn1>)
-)
-
-(p p73
-    (context ^present propagate-constraint)
-    { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max <hcom> ^com <hmax> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    (horizontal ^net-name { <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>)
-    (vertical ^net-name nil ^min < <hcom> ^max >= <hcom> ^com <vcmo> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com <hmax> ^layer <> <lay>)
-  -->
-    (modify <v> ^max <hcmo> ^max-net <nn1>)
-)
-
-(p p74
-    (context ^present propagate-constraint)
-    { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    { <v> (vertical ^net-name nil ^min <hcom> ^max { <vmax> > <hcom> } ^com <hmin> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    (horizontal ^net-name { <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcpo> ^layer <lay> ^compo <garb1> ^commo <hcom>)
-    (vertical ^net-name nil ^min <= <hcom> ^max > <hcom> ^com <vcpo> ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <hmin> ^max <hmin> ^com <hcom> ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com <hmin> ^layer <> <lay>)
-  -->
-    (modify <v> ^min <hcpo> ^min-net <nn1>)
-)
-
-(p p75
-    (context ^present propagate-constraint)
-    { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max <hcom> ^com <hmin> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    (horizontal ^net-name { <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>)
-    (vertical ^net-name nil ^min < <hcom> ^max >= <hcom> ^com <vcpo> ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <hmin> ^max <hmin> ^com <hcom> ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com <hmin> ^layer <> <lay>)
-  -->
-    (modify <v> ^max <hcmo> ^max-net <nn1>)
-)
-
-(p p76
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay>)
-    (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <vlay>)
-    (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer { <hlay> <> <vlay> } ^compo <hcpo> ^commo <vmax>)
-  - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmax>)
-    { <v> (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <hlay>) }
-  -->
-    (modify <v> ^min <hcom> ^min-net <nn2>)
-)
-
-(p p77
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay>)
-    (vertical ^net-name nil ^min <garb1> ^max { <vmin> > <garb1> } ^com <vcom> ^layer <vlay>)
-    (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer { <hlay> <> <vlay> } ^compo <vmin> ^commo <hcmo>)
-  - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmin>)
-    { <v> (vertical ^net-name nil ^min <garb2> ^max { <vmin> > <garb2> } ^com <vcom> ^layer <hlay>) }
-  -->
-    (modify <v> ^max <hcom> ^max-net <nn2>)
-)
-
-(p p78
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay>)
-    (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <hlay>)
-    (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer { <vlay> <> <hlay> } ^compo <vcpo> ^commo <hmax>)
-  - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmax>)
-    { <h> (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <vlay>) }
-  -->
-    (modify <h> ^min <vcom> ^min-net <nn2>)
-)
-
-(p p79
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay>)
-    (horizontal ^net-name nil ^min <garb1> ^max { <hmin> > <garb1> } ^com <hcom> ^layer <hlay>)
-    (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer { <vlay> <> <hlay> } ^compo <hmin> ^commo <vcmo>)
-  - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmin>)
-    { <h> (horizontal ^net-name nil ^min <garb2> ^max { <hmin> > <garb2> } ^com <hcom> ^layer <vlay>) }
-  -->
-    (modify <h> ^max <vcom> ^max-net <nn2>)
-)
-
-(p p80
-    (context ^present propagate-constraint)
-    (last-col <lc>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> <= 1 } ^max <vmax> ^com <vcom> ^layer <vlay> ^pin-name <pn> ^commo <vcmo>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max { <hmax> >= <lc> } ^com <vmax> ^layer <hlay>)
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com { <hcom> >= <vmin> <= <vmax> } ^layer <lay>) }
-  - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> })
-  - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> })
-  - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>)
-  - (vertical ^net-name <nn> ^min <= <vmax> ^max >= <vmax> ^com { > <vcom> <= <hmax> })
-  - (vertical ^net-name nil ^min <= <vmax> ^max >= <vmax> ^com { > <vcom> <= <hmax> })
-  - (vertical ^net-name nil ^min <= <vmax> ^max >= <vmax> ^com <vcom>)
-  - (vertical ^net-name <nn> ^min <vmax> ^max > <vmax> ^com <vcom>)
-  - (vertical ^net-name nil ^min <= <vmin> ^max >= <vmin> ^com <vcom>)
-  - (vertical ^net-name <nn> ^min < <vmin> ^max <vmin> ^com <vcom>)
-  -->
-    (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <vcmo>)
-    (modify <h> ^max <vcmo> ^max-net <nn>)
-    (make ff ^grid-x <vcmo> ^grid-y <hcom> ^grid-layer <lay> ^net-name <nn> ^pin-name <pn> ^came-from east)
-)
-
-(p p81
-    (context ^present propagate-constraint)
-    (last-row <lr>)
-    (last-col <lc>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max { <vmax> >= <lr> } ^com <vcom> ^layer <vlay> ^pin-name <pn> ^commo <vcmo>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max { <hmax> >= <lc> } ^com <vmin> ^layer <hlay>)
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com { <hcom> >= <vmin> <= <vmax> } ^layer <lay>) }
-  - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> })
-  - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> })
-  - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>)
-  - (vertical ^net-name <nn> ^min <= <vmin> ^max >= <vmin> ^com { > <vcom> <= <hmax> })
-  - (vertical ^net-name nil ^min <= <vmin> ^max >= <vmin> ^com { > <vcom> <= <hmax> })
-  - (vertical ^net-name nil ^min <= <vmin> ^max >= <vmin> ^com <vcom>)
-  - (vertical ^net-name <nn> ^min < <vmin> ^max <vmin> ^com <vcom>)
-  - (vertical ^net-name nil ^min <= <vmax> ^max >= <vmax> ^com <vcom>)
-  - (vertical ^net-name <nn> ^min <vmax> ^max > <vmax> ^com <vcom>)
-  -->
-    (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <vcmo>)
-    (modify <h> ^max <vcmo> ^max-net <nn>)
-    (make ff ^grid-x <vcmo> ^grid-y <hcom> ^grid-layer <lay> ^net-name <nn> ^pin-name <pn> ^came-from east)
-)
-
-(p p82
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^pin-name <pn> ^commo <hcmo>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max <vmax1> ^com <hmin> ^layer <vlay1>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max <vmax2> ^com <hmax> ^layer <vlay2>)
-    { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max <hcom> ^com { <vcom> >= <hmin> <= <hmax> } ^layer <lay>) }
-  - (vertical ^net-name <nn> ^min < <hcom> ^max >= <hcom> ^com { > <vcom> <= <hmax> })
-  - (vertical ^net-name <nn> ^min < <hcom> ^max >= <hcom> ^com { < <vcom> >= <hmin> })
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <hcom> ^com { > <vcom> <= <hmax> })
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <hcom> ^com { < <vcom> >= <hmin> })
-  - (vertical ^net-name <nn> ^min < <hcom> ^max >= <hcom> ^com <vcom> ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <> <lay>)
-  - (horizontal ^net-name <nn> ^min <= <hmax> ^max >= <hmax> ^com { > <hcom> <= <vmax2> })
-  - (horizontal ^net-name <nn> ^min <= <hmin> ^max >= <hmin> ^com { > <hcom> <= <vmax1> })
-  - (horizontal ^net-name nil ^min <= <hmax> ^max >= <hmax> ^com { > <hcom> <= <vmax2> })
-  - (horizontal ^net-name nil ^min <= <hmin> ^max >= <hmin> ^com { > <hcom> <= <vmax1> })
-  - (horizontal ^net-name nil ^min <= <hmax> ^max >= <hmax> ^com <hcom>)
-  - (horizontal ^net-name <nn> ^min <hmax> ^max > <hmax> ^com <hcom>)
-  - (horizontal ^net-name nil ^min <= <hmin> ^max >= <hmin> ^com <hcom>)
-  - (horizontal ^net-name <nn> ^min < <hmin> ^max <hmin> ^com <hcom>)
-  -->
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <hcmo>)
-    (modify <v> ^max <hcmo> ^max-net <nn>)
-    (make ff ^grid-x <vcom> ^grid-y <hcmo> ^grid-layer <lay> ^net-name <nn> ^pin-name <pn> ^came-from north)
-)
-
-(p p377
-    (context ^present find-no-of-pins-on-a-row-col)
-    (horizontal ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gy> ^layer <lay> ^compo <egarb1> ^commo <egabr2>)
-    (ff ^net-name <nn> ^grid-x { <fx> >= <min> <= <max> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn1>)
-    (ff ^net-name <nn> ^grid-y <gy> ^pin-name { <pn2> <> <pn1> } ^grid-x { <gx> > <fx> <= <max> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <fx> ^max >= <gx> ^com <gy>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <fx> <= <gx> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <fx> ^max >= <fx> ^com <gy> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-    (net ^net-name <nn> ^net-no-of-pins <np>)
-  - (total ^net-name <nn> ^row-col row ^coor <gy>)
-  -->
-    (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins 1 ^total-pins <np> ^min-xy <fx> ^max-xy <gx> ^last-pin <pn1> ^last-xy <fx>)
-)
-
-(p p378
-    (context ^present find-no-of-pins-on-a-row-col)
-    (horizontal ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gy> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (ff ^net-name <nn> ^grid-x { <fx> >= <min> <= <max> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn1>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx> > <fx> <= <max> } ^pin-name { <pn2> <> <pn1> })
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <fx> ^max >= <gx> ^com <gy>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <fx> <= <gx> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <fx> ^max >= <fx> ^com <gy> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-    (net ^net-name <nn> ^net-no-of-pins <np>)
-  - (total ^net-name <nn> ^row-col row ^coor <gy>)
-  -->
-    (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins 1 ^total-pins <np> ^min-xy <fx> ^max-xy <gx> ^last-pin <pn1> ^last-xy <fx>)
-)
-
-(p p379
-    (context ^present find-no-of-pins-on-a-row-col)
-    (horizontal ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gy> ^layer <lay>)
-    (ff ^net-name <nn> ^grid-x { <fx> >= <min> <= <max> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn1>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx> < <fx> >= <min> } ^pin-name { <pn2> <> <pn1> })
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <fx> ^com <gy>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <fx> >= <gx> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <fx> ^max >= <fx> ^com <gy> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-    (net ^net-name <nn> ^net-no-of-pins <np>)
-  - (total ^net-name <nn> ^row-col row ^coor <gy>)
-  -->
-    (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins 1 ^total-pins <np> ^min-xy <gx> ^max-xy <fx> ^last-pin <pn2> ^last-xy <gx>)
-)
-
-(p p380
-    (context ^present find-no-of-pins-on-a-row-col)
-    (vertical ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gx> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <fy> >= <min> <= <max> } ^grid-layer <garb1> ^pin-name <pn1>)
-    (ff ^net-name <nn> ^grid-x <gx> ^pin-name { <pn2> <> <pn1> } ^grid-y { <gy> > <fy> <= <max> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <fy> ^max >= <gy> ^com <gx>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <fy> <= <gy> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <fy> ^max >= <fy> ^com <gx> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-    (net ^net-name <nn> ^net-no-of-pins <np>)
-  - (total ^net-name <nn> ^row-col col ^coor <gx>)
-  -->
-    (make total ^net-name <nn> ^row-col col ^coor <gx> ^level-pins 1 ^total-pins <np> ^min-xy <fy> ^max-xy <gy> ^last-pin <pn1> ^last-xy <fy>)
-)
-
-(p p381
-    (context ^present find-no-of-pins-on-a-row-col)
-    (vertical ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gx> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <fy> >= <min> <= <max> } ^grid-layer <garb1> ^pin-name <pn1>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy> > <fy> <= <max> } ^pin-name { <pn2> <> <pn1> })
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <fy> ^max >= <gy> ^com <gx>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <fy> <= <gy> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <fy> ^max >= <fy> ^com <gx> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-    (net ^net-name <nn> ^net-no-of-pins <np>)
-  - (total ^net-name <nn> ^row-col col ^coor <gx>)
-  -->
-    (make total ^net-name <nn> ^row-col col ^coor <gx> ^level-pins 1 ^total-pins <np> ^min-xy <fy> ^max-xy <gy> ^last-pin <pn1> ^last-xy <fy>)
-)
-
-(p p382
-    (context ^present find-no-of-pins-on-a-row-col)
-    (vertical ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gx> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <fy> >= <min> <= <max> } ^grid-layer <garb1> ^pin-name <pn1>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy> < <fy> >= <min> } ^pin-name { <pn2> <> <pn1> })
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <fy> ^com <gx>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <gy> <= <fy> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <fy> ^max >= <fy> ^com <gx> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-    (net ^net-name <nn> ^net-no-of-pins <np>)
-  - (total ^net-name <nn> ^row-col col ^coor <gx>)
-  -->
-    (make total ^net-name <nn> ^row-col col ^coor <gx> ^level-pins 1 ^total-pins <np> ^min-xy <gy> ^max-xy <fy> ^last-pin <pn2> ^last-xy <gy>)
-)
-
-(p p383
-    (context ^present find-no-of-pins-on-a-row-col)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <gy> ^grid-layer <garb2> ^pin-name <pn>)
-    (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <np> ^no-of-bottom-pins <garb3>)
-  - (ff ^net-name <nn> ^grid-y <= <gy> ^pin-name <> <pn>)
-  - (total ^net-name <nn>)
-  -->
-    (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins <np> ^total-pins <np>)
-)
-
-(p p384
-    (context ^present find-no-of-pins-on-a-row-col)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <gy> ^grid-layer <garb2> ^pin-name <pn>)
-    (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <garb3> ^no-of-bottom-pins <np>)
-  - (ff ^net-name <nn> ^grid-y >= <gy> ^pin-name <> <pn>)
-  - (total ^net-name <nn>)
-  -->
-    (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins <np> ^total-pins <np>)
-)
-
-(p p385
-    (context ^present find-no-of-pins-on-a-row-col)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <np> ^no-of-bottom-pins <garb2>)
-  - (total ^net-name <nn>)
-    (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn> ^grid-x { <fx> > <gx> })
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <fx> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <fx> ^com <gy>)
-    { <v1> (vertical ^net-name nil ^min { <min> < <gy> } ^max >= <gy> ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <mn>) }
-  - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>)
-    (congestion ^direction row ^coordinate <gy> ^como <hcmo>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <hcmo> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>)
-    (modify <v1> ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff1> ^grid-y <hcmo> ^can-chng-layer nil)
-    (make total ^net-name <nn> ^row-col row ^coor <hcmo> ^level-pins <np> ^total-pins <np>)
-)
-
-(p p386
-    (context ^present find-no-of-pins-on-a-row-col)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <garb2> ^no-of-bottom-pins <np>)
-  - (total ^net-name <nn>)
-    (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn> ^grid-x { <fx> > <gx> })
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <fx> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <fx> ^com <gy>)
-    { <v1> (vertical ^net-name nil ^min <= <gy> ^max { <max> > <gy> } ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <mn>) }
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>)
-    (congestion ^direction row ^coordinate <hcmo> ^como <gy>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <max> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <nn> ^max-net <mn>)
-    (modify <v1> ^max <gy> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^min <gy> ^max <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff1> ^grid-y <hcmo> ^can-chng-layer nil)
-    (make total ^net-name <nn> ^row-col row ^coor <hcmo> ^level-pins <np> ^total-pins <np>)
-)
-
-(p p387
-    { <t1> (total ^net-name <nn> ^row-col row ^coor <y> ^level-pins <np> ^total-pins <np> ^min-xy nil ^max-xy nil) }
-    (pin ^net-name <nn> ^pin-x <px1>)
-  - (pin ^net-name <nn> ^pin-x < <px1>)
-    (pin ^net-name <nn> ^pin-x { <px2> > <px1> })
-  - (pin ^net-name <nn> ^pin-x > <px2>)
-  -->
-    (modify <t1> ^min-xy <px1> ^max-xy <px2>)
-)
-
-(p p388
-    (context ^present find-no-of-pins-on-a-row-col)
-  -->
-    (make context ^previous find-no-of-pins-on-a-row-col)
-    (remove 1)
-)
-
-(p p389
-    (context ^previous find-no-of-pins-on-a-row-col)
-    (total)
-  -->
-    (remove 1)
-    (make context ^present modify-total)
-)
-
-(p p390
-    (context ^present delete-totals)
-  -->
-    (modify 1 ^present choose-between-nets-on-the-same-row-col)
-)
-
-(p p391
-    { <c1> (context ^present << choose-between-nets-on-the-same-row-col choose-between-nets-on-the-same-row-col-con >>) }
-    { <t1> (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <xy> ^level-pins <cou> ^total-pins <garb1>) }
-  - (total ^net-name <> <nn> ^level-pins >= <cou>)
-  - (total ^net-name <nn> ^row-col <> <rc> ^level-pins >= <cou>)
-  -->
-    (remove <c1> <t1>)
-    (make change-priority)
-    (make tran-total <rc> <xy> (substr <t1> nets inf))
-)
-
-(p p392
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <garb1> ^row-col { << row col >> <garb2> } ^coor <garb3> ^level-pins <cou> ^total-pins <cou>)
-    { <t1> (total ^level-pins < <cou>) }
-  -->
-    (remove <t1>)
-)
-
-(p p393
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <garb1> ^row-col { << row col >> <garb2> } ^coor <garb3> ^level-pins <cou> ^total-pins <garb4>)
-    { <t1> (total ^level-pins <cou1> ^total-pins { < <cou> <> <cou1> }) }
-  -->
-    (remove <t1>)
-)
-
-(p p394
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <garb1> ^level-pins <cou>)
-    { <t1> (total ^net-name <nn> ^row-col <> <rc> ^level-pins <cou>) }
-  -->
-    (remove <t1>)
-)
-
-(p p395
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <xy> ^level-pins <cou> ^total-pins <garb1>)
-    { <t1> (total ^net-name <nn> ^row-col <rc> ^coor <> <xy> ^level-pins <cou>) }
-  -->
-    (remove <t1>)
-)
-
-(p p396
-    { <c1> (context ^present << choose-between-nets-on-the-same-row-col choose-between-nets-on-the-same-row-col-con >>) }
-    { <t1> (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <xy> ^level-pins <cou> ^total-pins <cou>) }
-  - (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou>)
-  -->
-    (remove <c1> <t1>)
-    (make change-priority)
-    (make tran-total <rc> <xy> (substr <t1> nets inf))
-)
-
-(p p397
-    { <t1> (tran-total <rc> <xy> { <nn> <> nil <> end } <min> <max>) }
-  -->
-    (write (crlf) |***** next net to be routed is| <nn> *****)
-    (make next-segment <nn> <rc> <xy> useless <min> <max>)
-    (remove <t1>)
-    (make tran-total <rc> <xy> (substr <t1> 7 inf))
-)
-
-(p p398
-    { <t1> (tran-total <rc> <xy> nil) }
-  -->
-    (make dominant-layer)
-    (remove <t1>)
-    (make goal cleanup total-verti)
-    (make goal cleanup counted-verti)
-    (make goal cleanup total)
-    (make goal cleanup extend-ff-tried)
-)
-
-(p p399
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <nn> ^row-col { << row col >> <garb1> } ^coor <garb2> ^level-pins <cou> ^total-pins <cou>)
-    { <t1> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins > <cou>) }
-  -->
-    (remove <t1>)
-)
-
-(p p400
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <nn> ^row-col { << row col >> <garb1> } ^coor <garb2> ^level-pins <cou> ^total-pins <cou1>)
-    { <t1> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins > <cou1>) }
-  - (total ^net-name <garb3> ^row-col <garb4> ^coor <garb5> ^level-pins <cou2> ^total-pins <cou2>)
-  -->
-    (remove <t1>)
-)
-
-(p p401
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <garb1> ^row-col <garb2> ^coor <garb3> ^level-pins <cou1> ^total-pins <cou2>)
-    { <t1> (total ^net-name <garb4> ^row-col <garb5> ^coor <garb6> ^level-pins < <cou1> ^total-pins < <cou2>) }
-  -->
-    (remove <t1>)
-)
-
-(p p402
-    (context ^present choose-between-nets-on-the-same-row-col)
-  -->
-    (modify 1 ^present choose-between-nets-on-the-same-row-col-con)
-)
-
-(p p403
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    { <t1> (total ^net-name <nn> ^row-col row ^level-pins <cou> ^total-pins <cou2> ^cong nil) }
-    (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2>)
-    (pin ^net-name <nn> ^pin-x <px1>)
-  - (pin ^net-name <nn> ^pin-x < <px1>)
-    (pin ^net-name <nn> ^pin-x { <px2> > <px1> })
-  - (pin ^net-name <nn> ^pin-x > <px2>)
-    (congestion ^direction col ^coordinate { >= <px1> <= <px2> } ^no-of-nets <non>)
-  - (congestion ^direction col ^coordinate { >= <px1> <= <px2> } ^no-of-nets > <non>)
-  -->
-    (modify <t1> ^cong <non>)
-)
-
-(p p404
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    { <t1> (total ^net-name <nn> ^row-col col ^level-pins <cou> ^total-pins <cou2> ^cong nil) }
-    (total <> <nn> { } { } <cou> <cou2>)
-    (pin ^net-name <nn> ^pin-y <py1>)
-  - (pin ^net-name <nn> ^pin-y < <py1>)
-    (pin ^net-name <nn> ^pin-y { <py2> > <py1> })
-  - (pin ^net-name <nn> ^pin-y > <py2>)
-    (congestion ^direction row ^coordinate { >= <py1> <= <py2> } ^no-of-nets <non>)
-  - (congestion ^direction row ^coordinate { >= <py1> <= <py2> } ^no-of-nets > <non>)
-  -->
-    (modify <t1> ^cong <non>)
-)
-
-(p p405
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy <min1> ^max-xy <max1>)
-    (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy { <min2> > <max1> } ^max-xy <max2>)
-    { <t> (total ^net-name <nn1> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy <= <max1> ^max-xy >= <min2>) }
-  -->
-    (remove <t>)
-)
-
-(p p406
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy <min1> ^max-xy <max1>)
-    { <t> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy >= <min1> ^max-xy <= <max1>) }
-  -->
-    (remove <t>)
-)
-
-(p p407
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil })
-    { <t> (total ^net-name { <nn1> <> <nn> } ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) }
-    (<< vertical-cycle horizontal-cycle >> <nn1>)
-  -->
-    (remove <t>)
-)
-
-(p p408
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    (total ^net-name <nn> ^row-col row ^coor <y> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil })
-    { <t> (total ^net-name { <nn1> <> <nn> } ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) }
-    (pin ^net-name <nn1> ^pin-y { <py> < <y> } ^pin-channel-side << left right >>)
-  - (pin ^net-name <nn> ^pin-y { > <py> < <y> } ^pin-channel-side << left right >>)
-  -->
-    (remove <t>)
-)
-
-(p p409
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    (total ^net-name <nn> ^row-col row ^coor <y> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil })
-    { <t> (total ^net-name { <nn1> <> <nn> } ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) }
-    (pin ^net-name <nn1> ^pin-y { <py> > <y> } ^pin-channel-side << left right >>)
-  - (pin ^net-name <nn> ^pin-y { > <y> < <py> } ^pin-channel-side << left right >>)
-  -->
-    (remove <t>)
-)
-
-(p p410
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong <non>)
-  - (total ^cong nil)
-    { <t> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2> ^cong <= <non>) }
-  -->
-    (remove <t>)
-)
-
-(p p411
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <nn1> ^row-col <rc1> ^coor <xy1> ^level-pins <cou> ^total-pins > <cou>)
-    { <t1> (total ^net-name <nn2> ^row-col { <rc2> <> <rc1> } ^coor <xy2> ^level-pins <cou> ^total-pins > <cou>) }
-    { <t2> (total ^net-name <> <nn2> ^row-col <rc2> ^coor <xy2> ^level-pins <cou> ^total-pins > <cou>) }
-  -->
-    (remove <t1> <t2>)
-)
-
-(p p412
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <nn1> ^row-col <rc1> ^coor <xy1> ^level-pins <cou> ^total-pins > <cou>)
-    { <t1> (total ^net-name <nn2> ^row-col <rc2> ^coor { <xy2> <> <xy1> } ^level-pins <cou> ^total-pins > <cou>) }
-    { <t2> (total ^net-name <> <nn2> ^row-col <rc2> ^coor <xy2> ^level-pins <cou> ^total-pins > <cou>) }
-  -->
-    (remove <t1> <t2>)
-)
-
-(p p413
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-bottom-pins { <np> > 1 } ^net-is-routed <> yes)
-  - (total-verti <nn> bottom)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom)
-  -->
-    (make total-verti <nn> bottom 0 <np>)
-)
-
-(p p414
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-bottom-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> bottom)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>)
-  -->
-    (make total-verti <nn> bottom 0 <np>)
-)
-
-(p p415
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-bottom-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> bottom)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>)
-  -->
-    (make total-verti <nn> bottom 0 <np>)
-)
-
-(p p416
-    (context ^present find-no-of-vcg-hcg)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <garb1>)
-    (pin ^net-name <nn> ^pin-x <gx> ^pin-channel-side top ^pin-name <pn1>)
-    (net ^net-name { <nn1> <> <nn> } ^no-of-bottom-pins { <np> > 0 } ^net-is-routed <> yes)
-    (pin ^net-name <nn1> ^pin-x <gx> ^pin-channel-side bottom ^pin-name <pn2>)
-  - (total-verti <nn1> bottom)
-  - (constraint ^constraint-type vertical ^net-name-1 <nn> ^net-name-2 <nn1> ^pin-name-1 <pn1> ^pin-name-2 <pn2>)
-  -->
-    (make counted-verti <nn1> bottom <nn> <pn1> <pn2>)
-    (make total-verti <nn1> bottom 1 <np>)
-)
-
-(p p417
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-left-pins { <np> > 1 } ^net-is-routed <> yes)
-  - (total-verti <nn> left)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side left)
-  -->
-    (make total-verti <nn> left 0 <np>)
-)
-
-(p p418
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-left-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> left)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side left)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>)
-  -->
-    (make total-verti <nn> left 0 <np>)
-)
-
-(p p419
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-left-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> left)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side left)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>)
-  -->
-    (make total-verti <nn> left 0 <np>)
-)
-
-(p p420
-    (context ^present find-no-of-vcg-hcg)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <gy> ^grid-layer <garb3> ^pin-name <garb2>)
-    (pin ^net-name <nn> ^pin-y <gy> ^pin-channel-side right ^pin-name <pn1>)
-    (net ^net-name { <nn1> <> <nn> } ^no-of-left-pins { <np> > 0 } ^net-is-routed <> yes)
-    (pin ^net-name <nn1> ^pin-y <gy> ^pin-channel-side left ^pin-name <pn2>)
-  - (total-verti <nn1> left)
-  - (constraint ^constraint-type horizontal ^net-name-1 <nn> ^net-name-2 <nn1> ^pin-name-1 <pn1> ^pin-name-2 <pn2>)
-  -->
-    (make counted-verti <nn1> left <nn> <pn1> <pn2>)
-    (make total-verti <nn1> left 1 <np>)
-)
-
-(p p421
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-top-pins { <np> > 1 } ^net-is-routed <> yes)
-  - (total-verti <nn> top)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top)
-  -->
-    (make total-verti <nn> top 0 <np>)
-)
-
-(p p422
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-top-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> top)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>)
-  -->
-    (make total-verti <nn> top 0 <np>)
-)
-
-(p p423
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-top-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> top)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>)
-  -->
-    (make total-verti <nn> top 0 <np>)
-)
-
-(p p424
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-right-pins { <np> > 1 } ^net-is-routed <> yes)
-  - (total-verti <nn> right)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side right)
-  -->
-    (make total-verti <nn> right 0 <np>)
-)
-
-(p p425
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-right-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> right)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side right)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>)
-  -->
-    (make total-verti <nn> right 0 <np>)
-)
-
-(p p426
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-right-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> right)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side right)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>)
-  -->
-    (make total-verti <nn> right 0 <np>)
-)
-
-(p p427
-    (context ^present find-no-of-vcg-hcg)
-    (total-verti <nn> bottom <ntc>)
-    (constraint ^constraint-type vertical ^net-name-1 <tn> ^net-name-2 <nn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  - (counted-verti <nn> bottom <tn> <tpn> <bpn>)
-  -->
-    (make counted-verti <nn> bottom <tn> <tpn> <bpn>)
-    (modify 2 ^4 (compute <ntc> + 1))
-)
-
-(p p428
-    (context ^present find-no-of-vcg-hcg)
-    (total-verti <nn> left <ntc>)
-    (constraint ^constraint-type horizontal ^net-name-1 <tn> ^net-name-2 <nn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  - (counted-verti <nn> left <tn> <tpn> <bpn>)
-  -->
-    (make counted-verti <nn> left <tn> <tpn> <bpn>)
-    (modify 2 ^4 (compute <ntc> + 1))
-)
-
-(p p429
-    (context ^present find-no-of-vcg-hcg)
-    (total-verti <nn> top <ntc>)
-    (constraint ^constraint-type vertical ^net-name-1 <nn> ^net-name-2 <bn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  - (counted-verti <nn> top <bn> <tpn> <bpn>)
-  -->
-    (make counted-verti <nn> top <bn> <tpn> <bpn>)
-    (modify 2 ^4 (compute <ntc> + 1))
-)
-
-(p p430
-    (context ^present find-no-of-vcg-hcg)
-    (total-verti <nn> right <ntc>)
-    (constraint ^constraint-type horizontal ^net-name-1 <nn> ^net-name-2 <bn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  - (counted-verti <nn> right <bn> <tpn> <bpn>)
-  -->
-    (make counted-verti <nn> right <bn> <tpn> <bpn>)
-    (modify 2 ^4 (compute <ntc> + 1))
-)
-
-(p p431
-    (context ^present find-no-of-vcg-hcg)
-  -->
-    (remove 1)
-    (make context ^previous find-no-of-vcg-hcg)
-)
-
-(p p432
-    (context ^previous find-no-of-vcg-hcg)
-    (total-verti)
-  -->
-    (remove 1)
-    (make context ^present choose-between-total-verti)
-    (make context ^present choose-between-total-verti-0)
-)
-
-(p p433
-    (context ^present choose-between-total-verti)
-  - (total-verti ^4 0)
-    { <t> (total-verti <nn> bottom <garb> > 1) }
-  - (ff ^net-name <nn> ^came-from south)
-  -->
-    (remove <t>)
-)
-
-(p p434
-    (context ^present choose-between-total-verti)
-  - (total-verti ^4 0)
-    { <t> (total-verti <nn> top <garb> > 1) }
-  - (ff ^net-name <nn> ^came-from north)
-  -->
-    (remove <t>)
-)
-
-(p p435
-    (context ^present choose-between-total-verti)
-  - (total-verti ^4 0)
-    { <t> (total-verti <nn> left <garb> > 1) }
-  - (ff ^net-name <nn> ^came-from west)
-  -->
-    (remove <t>)
-)
-
-(p p436
-    (context ^present choose-between-total-verti)
-  - (total-verti ^4 0)
-    { <t> (total-verti <nn> right <garb> > 1) }
-  - (ff ^net-name <nn> ^came-from east)
-  -->
-    (remove <t>)
-)
-
-(p p437
-    (context ^present choose-between-total-verti)
-  -->
-    (modify 1 ^present extend-total-verti)
-)
-
-(p p438
-    (context ^present choose-between-total-verti)
-    (total-verti ^4 > 0)
-    (total-verti ^4 0)
-  -->
-    (remove 3)
-)
-
-(p p439
-    (context ^present choose-between-total-verti)
-    (total-verti <nn> { << top bottom >> <tb> } > 0)
-    (total-verti <nn> { << top bottom >> <> <tb> } 0)
-  -->
-    (remove 3)
-)
-
-(p p440
-    (context ^present choose-between-total-verti)
-    (total-verti <nn> { << left right >> <tb> } > 0)
-    (total-verti <nn> { << left right >> <> <tb> } 0)
-  -->
-    (remove 3)
-)
-
-(p p441
-    (context ^present choose-between-total-verti-0)
-    (total-verti <nn> { << top bottom >> <tb> } > 0)
-    (total-verti <nn> { << top bottom >> <> <tb> } > 0)
-  -->
-    (remove 2 3)
-)
-
-(p p442
-    (context ^present choose-between-total-verti-0)
-    (total-verti <nn> { << left right >> <tb> } > 0)
-    (total-verti <nn> { << left right >> <> <tb> } > 0)
-  -->
-    (remove 2 3)
-)
-
-(p p443
-    (context ^present choose-between-total-verti-0)
-  -->
-    (remove 1)
-)
-
-(p p444
-    (context ^present extend-total-verti)
-    (total-verti <nn> bottom ^5 > 1)
-  - (total-verti ^5 1)
-    (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy> ^com <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy> } ^max { > <min> > <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-    (congestion ^direction row ^coordinate <como> ^como <gy>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <como> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^min <min> ^max <gy> ^min-net <mn> ^max-net <nn> ^commo <vcmo> ^compo <vcpo> ^com <gx> ^layer <lay>)
-    (modify 4 ^min <como> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^min <gy> ^max <como> ^layer <lay> ^commo <vcmo> ^compo <vcpo> ^pin-name <pn> ^com <gx>)
-    (modify 3 ^grid-y <como> ^can-chng-layer nil)
-    (remove 2)
-)
-
-(p p445
-    (context ^present extend-total-verti)
-    (total-verti <nn> left ^5 > 1)
-  - (total-verti ^5 1)
-    (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^grid-x < <gx>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx> ^com <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { > <min> > <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-    (congestion ^direction col ^coordinate <como> ^como <gx>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gy> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <como> ^layer <lay>)
-  -->
-    (make horizontal ^net-name nil ^min <min> ^max <gx> ^min-net <mn> ^max-net <nn> ^commo <hcmo> ^compo <hcpo> ^com <gy> ^layer <lay>)
-    (modify 4 ^min <como> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^min <gx> ^max <como> ^layer <lay> ^commo <hcmo> ^compo <hcpo> ^pin-name <pn> ^com <gy>)
-    (modify 3 ^grid-x <como> ^can-chng-layer nil)
-    (remove 2)
-)
-
-(p p446
-    (context ^present extend-total-verti)
-    (total-verti <nn> top ^5 > 1)
-  - (total-verti ^5 1)
-    (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy> ^com <gx>)
-    (vertical ^net-name nil ^max { <max> >= <gy> } ^min { < <max> < <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^max-net <mn>)
-    (congestion ^direction row ^coordinate <gy> ^como <como>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <como> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^min <gy> ^max <max> ^max-net <mn> ^min-net <nn> ^commo <vcmo> ^compo <vcpo> ^com <gx> ^layer <lay>)
-    (modify 4 ^max <como> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <como> ^layer <lay> ^commo <vcmo> ^compo <vcpo> ^pin-name <pn> ^com <gx>)
-    (modify 3 ^grid-y <como> ^can-chng-layer nil)
-    (remove 2)
-)
-
-(p p447
-    (context ^present extend-total-verti)
-    (total-verti <nn> right ^5 > 1)
-  - (total-verti ^5 1)
-    (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^grid-x > <gx>)
-  - (horizontal ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx> ^status nil ^com <gy>)
-    (horizontal ^net-name nil ^max { <max> >= <gx> } ^min { < <max> < <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^max-net <mn>)
-    (congestion ^direction col ^coordinate <gx> ^como <como>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gy> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <como> ^layer <lay>)
-  -->
-    (make horizontal ^net-name nil ^min <gx> ^max <max> ^max-net <mn> ^min-net <nn> ^commo <hcmo> ^compo <hcpo> ^com <gy> ^layer <lay>)
-    (modify 4 ^max <como> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx> ^min <como> ^layer <lay> ^commo <hcmo> ^compo <hcpo> ^pin-name <pn> ^com <gy>)
-    (modify 3 ^grid-x <como> ^can-chng-layer nil)
-    (remove 2)
-)
-
-(p p448
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> bottom ^5 1) }
-    (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-  - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin>)
-    { <c6> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay> ^compo <garb1> ^commo <garb2>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> >= <vvmin> < <vmin> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { >= <vvmin> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c6> ^max <hcom> ^max-net <nn>)
-    (modify <c4> ^min <hcom>)
-    (make pull-ff north <nn> <gx> <gy> <gx> <hcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from north)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p449
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> bottom ^5 1) }
-    (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin> ^grid-layer <garb1> ^pin-name <garb2>) }
-    { <c7> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay> ^compo <garb3> ^commo <garb4>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> >= <vvmin> < <vmin> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { >= <vvmin> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c7> ^max <hcom> ^max-net <nn>)
-    (modify <c4> ^min <hcom>)
-    (make pull-ff north <nn> <gx> <gy> <gx> <hcom>)
-    (modify <c5> ^grid-y <hcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p450
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> bottom ^5 1) }
-    (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-    { <c6> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay> ^compo <garb1> ^commo <garb2>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> >= <vvmin> < <vmin> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { >= <vvmin> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> })
-    { <c41> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin1> > <gy> } ^com { <vcom1> > <gx> } ^layer <lay> ^pin-name <pn1>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom1>)
-    { <c61> (vertical ^net-name nil ^min <vvmin1> ^max { <vmin1> > <vvmin1> } ^com <vcom1> ^layer <lay>) }
-    (horizontal ^net-name nil ^min { <hmin1> <= <gx> } ^max { > <hmin1> >= <vcom1> } ^com { <hcom1> >= <vvmin1> < <vmin1> <= <hcom> })
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom1> ^com { >= <vvmin1> < <hcom1> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom1> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin1> > <hcom1> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom1> ^max >= <vcom1> ^com <hcom1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom1> ^max >= <hcom1> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c61> ^max <hcom1> ^max-net <nn>)
-    (modify <c41> ^min <hcom1>)
-    (make pull-ff north <nn> <gx> <gy> <gx> <hcom1>)
-    (make ff ^net-name <nn> ^pin-name <pn1> ^grid-layer <lay> ^grid-x <vcom1> ^grid-y <hcom1> ^came-from north)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p451
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> bottom ^5 1) }
-    (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-  - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin>)
-    { <c6> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> >= <vvmin> < <vmin> })
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { >= <vvmin> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c6> ^max <hcom> ^max-net <nn>)
-    (modify <c4> ^min <hcom>)
-    (make pull-ff north <nn> <gx> <gy> <gx> <hcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from north)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p452
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> bottom ^5 1) }
-    (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin> ^grid-layer <garb1> ^pin-name <garb2>) }
-    { <c7> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> >= <vvmin> < <vmin> })
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { >= <vvmin> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c7> ^max <hcom> ^max-net <nn>)
-    (modify <c4> ^min <hcom>)
-    (make pull-ff north <nn> <gx> <gy> <gx> <hcom>)
-    (modify <c5> ^grid-y <hcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p453
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> top ^5 1) }
-    (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-  - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax>)
-    { <c6> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> <= <vvmax> > <vmax> })
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { <= <vvmax> > <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c6> ^min <hcom> ^min-net <nn>)
-    (modify <c4> ^max <hcom>)
-    (make pull-ff south <nn> <gx> <gy> <gx> <hcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from south)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p454
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> top ^5 1) }
-    (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax> ^grid-layer <garb2> ^pin-name <garb3>) }
-    { <c7> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> <= <vvmax> > <vmax> })
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { <= <vvmax> > <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c7> ^min <hcom> ^min-net <nn>)
-    (modify <c4> ^max <hcom>)
-    (make pull-ff south <nn> <gx> <gy> <gx> <hcom>)
-    (modify <c5> ^grid-y <hcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p455
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> top ^5 1) }
-    (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-  - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax>)
-    { <c6> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> <= <vvmax> > <vmax> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { <= <vvmax> > <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c6> ^min <hcom> ^min-net <nn>)
-    (modify <c4> ^max <hcom>)
-    (make pull-ff south <nn> <gx> <gy> <gx> <hcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from south)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p456
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> top ^5 1) }
-    (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax> ^grid-layer <garb4> ^pin-name <garb5>) }
-    { <c7> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> <= <vvmax> > <vmax> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { <= <vvmax> > <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c7> ^min <hcom> ^min-net <nn>)
-    (modify <c4> ^max <hcom>)
-    (make pull-ff south <nn> <gx> <gy> <gx> <hcom>)
-    (modify <c5> ^grid-y <hcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p457
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> left ^5 1) }
-    (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-  - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom>)
-    { <c6> (horizontal ^net-name nil ^min <hhmin> ^max { <hmin> > <hhmin> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-    (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> >= <hhmin> < <hmin> })
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { >= <hhmin> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c6> ^max <vcom> ^max-net <nn>)
-    (modify <c4> ^min <vcom>)
-    (make pull-ff east <nn> <gx> <gy> <gy> <vcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from east)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p458
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> left ^5 1) }
-    (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) }
-    { <c7> (horizontal ^net-name nil ^min <hhmin> ^max { <hmin> > <hhmin> } ^com <hcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) }
-    (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> >= <hhmin> < <hmin> })
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { >= <hhmin> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c7> ^max <vcom> ^max-net <nn>)
-    (modify <c4> ^min <vcom>)
-    (make pull-ff east <nn> <gx> <gy> <gy> <vcom>)
-    (modify <c5> ^grid-x <vcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p459
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> left ^5 1) }
-    (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-  - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom>)
-    { <c6> (horizontal ^net-name nil ^max <hmin> ^min { <hhmin> < <hmin> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> >= <hhmin> < <hmin> })
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { >= <hhmin> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c6> ^max <vcom> ^max-net <nn>)
-    (modify <c4> ^min <vcom>)
-    (make pull-ff east <nn> <gx> <gy> <gy> <vcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from east)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p460
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> left ^5 1) }
-    (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) }
-    { <c7> (horizontal ^net-name nil ^min <hhmin> ^max { <hmin> > <hhmin> } ^com <hcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) }
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> >= <hhmin> < <hmin> })
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { >= <hhmin> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c7> ^max <vcom> ^max-net <nn>)
-    (modify <c4> ^min <vcom>)
-    (make pull-ff east <nn> <gx> <gy> <gy> <vcom>)
-    (modify <c5> ^grid-x <vcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p461
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> right ^5 1) }
-    (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-  - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom>)
-    { <c6> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> <= <hhmax> > <hmax> })
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { <= <hhmax> > <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c6> ^min <vcom> ^min-net <nn>)
-    (modify <c4> ^max <vcom>)
-    (make pull-ff west <nn> <gx> <gy> <gy> <vcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from west)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p462
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> right ^5 1) }
-    (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) }
-    { <c7> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <gabr6> ^commo <garb7>) }
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> <= <hhmax> > <hmax> })
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { <= <hhmax> > <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c7> ^min <vcom> ^min-net <nn>)
-    (modify <c4> ^max <vcom>)
-    (make pull-ff west <nn> <gx> <gy> <gy> <vcom>)
-    (modify <c5> ^grid-x <vcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p463
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> right ^5 1) }
-    (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-  - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom>)
-    { <c6> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <gabr5>) }
-    (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> <= <hhmax> > <hmax> })
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { <= <hhmax> > <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c6> ^min <vcom> ^min-net <nn>)
-    (modify <c4> ^max <vcom>)
-    (make pull-ff west <nn> <gx> <gy> <gy> <vcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from west)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p464
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> right ^5 1) }
-    (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) }
-    { <c7> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) }
-    (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> <= <hhmax> > <hmax> })
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { <= <hhmax> > <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c7> ^min <vcom> ^min-net <nn>)
-    (modify <c4> ^max <vcom>)
-    (make pull-ff west <nn> <gx> <gy> <gy> <vcom>)
-    (modify <c5> ^grid-x <vcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p465
-    { <c1> (context ^present remove-total-verti-gt1) }
-  -->
-    (modify <c1> ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p466
-    { <c1> (context ^present extend-total-verti) }
-  -->
-    (modify <c1> ^present remove-total-verti-gt1)
-)
-
-(p p467
-    (context ^present remove-total-verti-gt1)
-    (total-verti ^5 > 1)
-    { <t> (total-verti ^5 1) }
-  -->
-    (remove <t>)
-)
-
-(p p468
-    { <c1> (context ^present remove-total-verti-gt1) }
-    (total-verti ^5 > 1)
-  - (total-verti ^5 1)
-  -->
-    (make remove-all-total-vertis)
-    (modify <c1> ^present extend-total-verti)
-)
-
-(p p469
-    { <c1> (context ^present remove-total-verti-gt1) }
-    { <c> (remove-all-total-vertis) }
-  - (total-verti)
-  -->
-    (remove <c>)
-    (modify <c1> ^present propagate-constraint)
-)
-
-(p p470
-    { <c1> (context ^present remove-total-verti-gt1) }
-    { <c> (remove-all-total-vertis) }
-  -->
-    (remove <c>)
-    (modify <c1> ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p471
-    { <c1> (context ^present << extend-total-verti remove-total-verti-gt1 >>) }
-  - (total-verti)
-  -->
-    (modify <c1> ^present propagate-constraint)
-)
-
-(p p515
-    { <c> (context ^previous find-no-of-pins-on-a-row-col) }
-  - (total)
-    { <p> (pull-ff north <nn> <gx> <gy1> <gx> <gy2>) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from south ^pin-name <pn>) }
-    { <v> (vertical ^net-name nil ^min <gy1> ^max >= <gy2> ^com <gx> ^layer <lay>) }
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  -->
-    (remove <p> <c>)
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <gy2>)
-    (modify <v> ^min <gy2> ^min-net <nn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p516
-    { <c> (context ^previous find-no-of-pins-on-a-row-col) }
-  - (total)
-    { <p> (pull-ff south <nn> <gx> <gy1> <gx> <gy2>) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from north ^pin-name <pn>) }
-    { <v> (vertical ^net-name nil ^min <= <gy2> ^max <gy1> ^com <gx> ^layer <lay>) }
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  -->
-    (remove <p> <c>)
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <gy2>)
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p517
-    { <c> (context ^previous find-no-of-pins-on-a-row-col) }
-  - (total)
-    { <p> (pull-ff east <nn> <gx1> <gy> <gx2> <gy>) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from west ^pin-name <pn>) }
-    { <v> (horizontal ^net-name nil ^min <gx1> ^max >= <gx2> ^com <gy> ^layer <lay>) }
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove <p> <c>)
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <gx2>)
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p518
-    { <c> (context ^previous find-no-of-pins-on-a-row-col) }
-  - (total)
-    { <p> (pull-ff west <nn> <gx1> <gy> <gx2> <gy>) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from east ^pin-name <pn>) }
-    { <v> (horizontal ^net-name nil ^min <= <gx2> ^max <gx1> ^com <gy> ^layer <lay>) }
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove <p> <c>)
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <gx2>)
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p293
-    (eliminate-total)
-    (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>)
-    { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy <min2> ^max-xy { <max2> > <max1> } ^level-pins < <p1>) }
-  - (total ^row-col <rc> ^coor <xy> ^max-xy < <min2>)
-  - (total ^row-col <rc> ^coor <xy> ^min-xy { > <max1> < <max2> })
-  -->
-    (remove <t1>)
-)
-
-(p p294
-    (eliminate-total)
-    (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>)
-    { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy <min2> ^max-xy { <max2> < <max1> } ^level-pins < <p1>) }
-  - (total ^row-col <rc> ^coor <xy> ^max-xy < <min2>)
-  - (total ^row-col <rc> ^coor <xy> ^min-xy { > <max2> < <max1> })
-  -->
-    (remove <t1>)
-)
-
-(p p295
-    (eliminate-total)
-    (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>)
-    { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy { <min2> < <min1> } ^max-xy <max2> ^level-pins < <p1>) }
-  - (total ^row-col <rc> ^coor <xy> ^min-xy > <max2>)
-  - (total ^row-col <rc> ^coor <xy> ^max-xy { > <min2> < <min1> })
-  -->
-    (remove <t1>)
-)
-
-(p p296
-    (eliminate-total)
-    (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>)
-    { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy { <min2> > <min1> } ^max-xy <max2> ^level-pins < <p1>) }
-  - (total ^row-col <rc> ^coor <xy> ^min-xy > <max2>)
-  - (total ^row-col <rc> ^coor <xy> ^max-xy { > <min1> < <min2> })
-  -->
-    (remove <t1>)
-)
-
-(p p297
-    (context ^present merge)
-    { <m> (merge-direction left) }
-    { <t1> (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^level-pins <lcou> ^total-pins <tcou> ^min-xy <min> ^max-xy <max>) }
-  - (rmerge)
-  - (total ^net-name <> <nn1> ^row-col <rc> ^coor <xy> ^max-xy < <max>)
-    (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy > <max>)
-  -->
-    (remove <m>)
-    (make merge-direction right)
-    (make lmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou> (substr <t1> nets inf))
-)
-
-(p p298
-    (context ^present merge)
-    { <m> (merge-direction right) }
-    { <t1> (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^level-pins <lcou> ^total-pins <tcou> ^min-xy <min> ^max-xy <max>) }
-  - (lmerge)
-  - (total ^net-name <> <nn1> ^row-col <rc> ^coor <xy> ^min-xy > <min>)
-    (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^max-xy < <min>)
-  -->
-    (remove <m>)
-    (make merge-direction left)
-    (make rmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou> (substr <t1> nets inf))
-)
-
-(p p299
-    { <c> (lmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou>) }
-    { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy { <min1> > <max> } ^max-xy <max1>) }
-  - (total ^row-col <rc> ^coor <xy> ^min-xy > <max> ^max-xy < <min1>)
-  - (place-holder <rc> <xy> > <max> < <min1>)
-  -->
-    (make total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^level-pins (compute <lcou> + <cou3>) ^total-pins (compute <tcou> + <cou4>) ^min-xy <min> ^max-xy <max1> ^nets (substr <c> 9 inf) (substr <t2> nets inf))
-    (make delete-merged <nn2> <rc> <xy> <min1> <max1> (genatom))
-)
-
-(p p300
-    { <c> (rmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou>) }
-    { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy <min1> ^max-xy { <max1> < <min> }) }
-  - (total ^row-col <rc> ^coor <xy> ^min-xy > <max1> ^max-xy < <min>)
-  - (place-holder <rc> <xy> > <max1> < <min>)
-  -->
-    (make total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins (compute <lcou> + <cou3>) ^total-pins (compute <tcou> + <cou4>) ^min-xy <min1> ^max-xy <max> ^nets (substr <c> 9 inf) (substr <t2> nets inf))
-    (make rdelete-merged <nn2> <rc> <xy> <min1> <max1> (genatom))
-)
-
-(p p301
-    { <d> (delete-merged <nn> <rc> <xy> <min> <max> <id>) }
-    (delete-merged <nn> <rc> <xy> <min> <max> <> <id>)
-  -->
-    (remove <d>)
-)
-
-(p p302
-    { <d> (rdelete-merged <nn> <rc> <xy> <min> <max> <id>) }
-    (rdelete-merged <nn> <rc> <xy> <min> <max> <> <id>)
-  -->
-    (remove <d>)
-)
-
-(p p303
-    (delete-merged <nn> <rc> <xy> <min> <max>)
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) }
-  - (lmerge)
-  -->
-    (remove <t>)
-)
-
-(p p304
-    (rdelete-merged <nn> <rc> <xy> <min> <max>)
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) }
-  - (rmerge)
-  -->
-    (remove <t>)
-)
-
-(p p305
-    { <d> (<< delete-merged rdelete-merged >>) }
-  - (<< lmerge rmerge >>)
-  -->
-    (remove <d>)
-)
-
-(p p306
-    (delete-merged <nn> <rc> <xy> <min> <max>)
-    { <t1> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max> ^level-pins <cou1> ^total-pins <cou2>) }
-    { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy <min1> ^max-xy { <max1> < <min> }) }
-  - (lmerge)
-  -->
-    (make place-holder <rc> <xy> <min> <max> (genatom))
-    (make total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins (compute <cou1> + <cou3>) ^total-pins (compute <cou2> + <cou4>) ^min-xy <min1> ^max-xy <max> ^nets (substr <t1> nets inf) (substr <t2> nets inf))
-)
-
-(p p307
-    (rdelete-merged <nn> <rc> <xy> <min> <max>)
-    { <t1> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max> ^level-pins <cou1> ^total-pins <cou2>) }
-    { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy { <min1> > <max> } ^max-xy <max1>) }
-  - (rmerge)
-  -->
-    (make place-holder <rc> <xy> <min> <max> (genatom))
-    (make total ^net-name <nn> ^row-col <rc> ^coor <xy> ^level-pins (compute <cou1> + <cou3>) ^total-pins (compute <cou2> + <cou4>) ^min-xy <min> ^max-xy <max1> ^nets (substr <t1> nets inf) (substr <t2> nets inf))
-)
-
-(p p308
-    { <p> (place-holder <rc> <xy> <min> <max> <id>) }
-    (place-holder <rc> <xy> <min> <max> <> <id>)
-  -->
-    (remove <p>)
-)
-
-(p p309
-    (<< lmerge rmerge >>)
-    { <p> (place-holder <rc> <xy> <min> <max> <id>) }
-  - (total ^row-col <rc> ^coor <xy> ^max-xy < <min>)
-  -->
-    (remove <p>)
-)
-
-(p p310
-    (<< lmerge rmerge >>)
-    { <p> (place-holder <rc> <xy> <min> <max> <id>) }
-  - (total ^row-col <rc> ^coor <xy> ^min-xy > <max>)
-  -->
-    (remove <p>)
-)
-
-(p p311
-    (context ^present merge)
-    { <l> (lmerge <nn> <rc> <xy> <min> <max>) }
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) }
-  -->
-    (remove <l> <t>)
-)
-
-(p p312
-    (context ^present merge)
-    { <l> (rmerge <nn> <rc> <xy> <min> <max>) }
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) }
-  -->
-    (remove <l> <t>)
-)
-
-(p p313
-    (context ^present merge)
-    (total ^level-pins <cou> ^total-pins <cou>)
-  - (total ^level-pins { <cou1> > <cou> } ^total-pins <cou1>)
-    { <m> (maximum-total < <cou>) }
-  -->
-    (modify <m> ^2 <cou>)
-)
-
-(p p314
-    (context ^present merge)
-    (total ^row-col row ^coor 1 ^level-pins <cou> ^total-pins <cou>)
-  - (total ^row-col row ^coor 1 ^level-pins { <cou1> > <cou> } ^total-pins <cou1>)
-    { <m> (maximum-total ^5 1 < <cou>) }
-  -->
-    (modify <m> ^6 <cou>)
-)
-
-(p p315
-    (context ^present merge)
-    (last-row <lr>)
-    (total ^row-col row ^coor <lr> ^level-pins <cou> ^total-pins <cou>)
-  - (total ^row-col row ^coor <lr> ^level-pins { <cou1> > <cou> } ^total-pins <cou1>)
-    { <m> (maximum-total ^7 <lr> < <cou>) }
-  -->
-    (modify <m> ^8 <cou>)
-)
-
-(p p316
-    (context ^present merge)
-    (total ^level-pins <cou1> ^total-pins <cou2>)
-  - (total ^level-pins > <cou1> ^total-pins > <cou2>)
-    { <m> (maximum-total <garb4> { <min1> < <cou1> }) }
-  -->
-    (modify <m> ^3 <cou1> ^4 <cou2>)
-)
-
-(p p317
-    { <con> (context ^present merge) }
-  -->
-    (modify <con> ^present delete-totals)
-    (make goal cleanup eliminate-total)
-    (make goal cleanup merge-direction)
-)
-
-(p p318
-    (context ^present delete-totals)
-    (maximum-total <max> <garb1> <garb2>)
-    { <t> (total ^level-pins { <cou> < <max> } ^total-pins <> <cou>) }
-  -->
-    (remove <t>)
-)
-
-(p p319
-    (context ^present delete-totals)
-    (maximum-total ^5 1 ^6 <cou>)
-    { <t> (total ^row-col row ^coor 1 ^level-pins { <cou1> < <cou> } ^total-pins <cou1>) }
-  -->
-    (remove <t>)
-)
-
-(p p320
-    (context ^present delete-totals)
-    (maximum-total ^7 <lr> ^8 <cou>)
-    { <t> (total ^row-col row ^coor <lr> ^level-pins { <cou1> < <cou> } ^total-pins <cou1>) }
-  -->
-    (remove <t>)
-)
-
-(p p321
-    (context ^present delete-totals)
-    (maximum-total <garb1> <min> <max>)
-    { <t> (total ^level-pins { <cou> < <min> }) }
-    (last-row <lr>)
-    (total ^row-col row ^coor { <> 1 <> <lr> })
-  -->
-    (remove <t>)
-)
-
-(p p322
-    (context ^present delete-totals)
-    (total ^row-col <rc> ^coor <xy> ^level-pins <min> ^total-pins <max>)
-    { <t1> (total ^row-col <rc> ^coor <xy> ^level-pins { <cou> <= <min> } ^total-pins > <max>) }
-  -->
-    (remove <t1>)
-)
-
-(p p323
-    (context ^present delete-totals)
-    { <m> (maximum-total <garb1> <garb2> <garb3>) }
-  -->
-    (remove <m>)
-)
-
-(p p324
-    { <c1> (context ^present delete-totals) }
-  - (maximum-total)
-    { <t1> (total ^net-name <nn1> ^row-col row ^coor 1) }
-    { <t2> (total ^net-name <nn2> ^row-col row ^coor <lr>) }
-  - (total ^row-col row ^coor { <> 1 <> <lr> })
-    (last-row <lr>)
-  -->
-    (remove <c1> <t1> <t2>)
-    (make change-priority)
-    (make tran-total row 1 (substr <t1> nets inf) end)
-    (make tran-total row <lr> (substr <t2> nets inf) end)
-    (make goal cleanup total)
-)
-
-(p p325
-    (context ^present delete-totals)
-  - (maximum-total)
-    (total ^net-name <nn1> ^row-col row ^coor 1)
-    (total ^net-name <nn2> ^row-col row ^coor <lr>)
-    { <t1> (total ^net-name <> <nn1> ^row-col row ^coor 1) }
-    (last-row <lr>)
-  -->
-    (remove <t1>)
-)
-
-(p p326
-    { <t1> (tran-total <rc> <xy1> end) }
-    { <t2> (tran-total <rc> <> <xy1> end) }
-  -->
-    (remove <t2>)
-    (modify <t1> ^4 nil)
-)
-
-(p p519
-    (context ^present random1)
-    (net ^net-name <nn> ^net-no-of-pins 2)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>)
-    (vertical-layer <lay>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> <= <gy1> } ^grid-layer <lay>)
-    (vertical ^net-name nil ^min { <vmin1> <= <gy1> } ^max { <vmax1> > <vmin1> >= <gy1> } ^com <gx1> ^layer <lay> ^compo <gx2> ^commo <cmo> ^min-net <vnn1>)
-    (vertical ^net-name nil ^min { <vmin2> <= <gy2> } ^max { <vmax2> > <vmin2> >= <gy2> >= <vmin1> } ^com <gx2> ^layer <lay> ^compo <cpo> ^commo <garb1> ^max-net <vnn2>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> >= <gx2> > <hmin> } ^com { <hcom> <= <vmax1> >= <vmin1> <= <vmax2> >= <vmin2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-  - (horizontal ^net-name <> nil ^com <hcom>)
-  -->
-    (remove 1 3 5)
-    (make vertical ^com <gx1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <gx2> ^commo <cmo> ^min-net <vnn1> ^max-net <nn>)
-    (modify 6 ^min <gy1> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <lay> ^min <hcom> ^max <vmax2> ^compo <cpo> ^commo <gx1> ^min-net <nn> ^max-net <vnn2>)
-    (modify 7 ^max <gy2> ^max-net <nn>)
-    (make horizontal ^min <hmin> ^max <gx1> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 8 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <lay> ^min <hcom> ^max <gy1> ^commo <cmo> ^compo <gx2> ^net-name <nn> ^pin-name <pn>)
-    (make vertical ^com <gx2> ^layer <lay> ^max <hcom> ^min <gy2> ^commo <gx1> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <hcom> ^layer <lay> ^min <gx1> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p520
-    (context ^present random1)
-    (net ^net-name <nn> ^net-no-of-pins 2)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>)
-    (horizontal-layer <lay>)
-    (ff ^net-name <nn> ^grid-x { <gx2> >= <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <lay>)
-    (horizontal ^net-name nil ^min { <hmin1> <= <gx1> } ^max { <hmax1> > <hmin1> >= <gx1> } ^com <gy1> ^layer <lay> ^compo <gy2> ^commo <cmo> ^max-net <hnn1>)
-    (horizontal ^net-name nil ^min { <hmin2> <= <gx2> } ^max { <hmax2> > <hmin2> >= <gx2> >= <hmax1> } ^com <gy2> ^layer <lay> ^compo <cpo> ^commo <garb1> ^min-net <hnn2>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> >= <gy2> > <vmin> } ^com { <vcom> <= <hmax1> >= <hmin1> <= <hmax2> >= <hmin2> } ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-  - (vertical ^net-name <> nil ^com <vcom>)
-  -->
-    (remove 1 3 5)
-    (make horizontal ^com <gy1> ^layer <lay> ^min <vcom> ^max <hmax1> ^compo <gy2> ^commo <cmo> ^min-net <nn> ^max-net <hnn1>)
-    (modify 6 ^max <gx1> ^max-net <nn>)
-    (make horizontal ^com <gy2> ^layer <lay> ^min <hmin2> ^max <vcom> ^compo <cpo> ^commo <gy1> ^min-net <hnn2> ^max-net <nn>)
-    (modify 7 ^min <gx2> ^min-net <nn>)
-    (make vertical ^min <vmin> ^max <gy1> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 8 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <lay> ^min <gx1> ^max <vcom> ^commo <cmo> ^compo <gy2> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <lay> ^min <vcom> ^max <gx2> ^commo <gy1> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (make vertical ^com <vcom> ^layer <lay> ^min <gy1> ^max <gy2> ^commo <vcmo> ^compo <vcpo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p521
-    (context ^present random1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> > <gx> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { >= <gx> < <vcom1> })
-    (vertical ^com { <vcom2> <= <vcom1> > <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom2>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom2> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom2> ^max >= <vcom2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <vcom2> >= <gx> } ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x < <gx>)
-  - (ff ^grid-x <vcom2> ^grid-y <gy>)
-  -->
-    (make made-random-move)
-    (make horizontal ^min <hmin> ^layer <lay> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <vcom2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <vcom2> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify 2 ^grid-x <vcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from west)
-)
-
-(p p522
-    (context ^present random1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> < <gx> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <= <gx> > <vcom1> })
-    (vertical ^com { <vcom2> >= <vcom1> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom2> ^max >= <gx>)
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom2> } ^max { > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom2> ^max >= <vcom2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <gx> >= <vcom2> } ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x > <gx>)
-  - (ff ^grid-x <vcom2> ^grid-y <gy>)
-  -->
-    (make made-random-move)
-    (make horizontal ^min <hmin> ^layer <lay> ^max <vcom2> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <gx> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <vcom2> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify 2 ^grid-x <vcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from east)
-)
-
-(p p523
-    (context ^present random1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <vcom1> < <gx> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <= <gx> > <vcom1> })
-    (vertical ^com { <vcom2> >= <vcom1> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom2> ^max >= <gx>)
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom2> } ^max { > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom2> ^max >= <vcom2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <gx> >= <vcom2> } ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x > <gx>)
-  - (ff ^grid-x <vcom2> ^grid-y <gy>)
-  -->
-    (make made-random-move)
-    (make horizontal ^min <hmin> ^layer <lay> ^max <vcom2> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <gx> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <vcom2> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify 2 ^grid-x <vcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from east)
-)
-
-(p p524
-    (context ^present random1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> < <gy> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom1> <= <gy> })
-    (horizontal ^com { <hcom2> >= <hcom1> < <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcom2> ^max >= <gy>)
-    (vertical ^net-name nil ^min { <vmin> <= <hcom2> } ^max { > <vmin> >= <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <hcom2> <= <gy> } ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom2> ^max >= <hcom2> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  - (ff ^grid-x <gx> ^grid-y <hcom2>)
-  -->
-    (make made-random-move)
-    (make vertical ^min <vmin> ^layer <lay> ^max <hcom2> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^min <hcom2> ^max <gy> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>)
-    (modify 2 ^grid-y <hcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from north)
-)
-
-(p p525
-    (context ^present random1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> > <gy> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <hcom1> >= <gy> })
-    (horizontal ^com { <hcom2> <= <hcom1> > <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <hcom2>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom2> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <gy> <= <hcom2> } ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom2> ^max >= <hcom2> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  - (ff ^grid-x <gx> ^grid-y <hcom2>)
-  -->
-    (make made-random-move)
-    (make vertical ^min <vmin> ^layer <lay> ^max <gy> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <hcom2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy> ^max <hcom2> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>)
-    (modify 2 ^grid-y <hcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from south)
-)
-
-(p p526
-    (context ^present random1)
-  -->
-    (remove 1)
-    (make context ^present check-random-move)
-)
-
-(p p527
-    { <c> (context ^present check-random-move) }
-    { <m> (made-random-move) }
-  -->
-    (remove <c> <m>)
-    (make context ^present check-for-routed-net)
-    (make goal cleanup made-random-move)
-)
-
-(p p528
-    { <c> (context ^present check-random-move) }
-  - (made-random-move)
-  -->
-    (remove <c>)
-    (make context ^present random2)
-)
-
-(p p529
-    (context ^present random2)
-  -->
-    (write (crlf) |Sorry, I can not proceed anymore because of my ignorance.|)
-    (halt)
-)
-
-(p p530
-    (context ^present random0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^pin-name <> <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> < <gy> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom1> <= <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcom1> ^max >= <gy>)
-    (vertical ^net-name nil ^min { <vmin> <= <hcom1> } ^max { > <vmin> >= <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-    (vertical-layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <hcom1> <= <gy> } ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom1> ^max >= <hcom1> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  -->
-    (remove 1)
-    (make vertical ^min <vmin> ^layer <lay> ^max <hcom1> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 4 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^min <hcom1> ^max <gy> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>)
-    (modify 2 ^grid-y <hcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from north)
-    (make context ^present propagate-constraint)
-)
-
-(p p531
-    (context ^present random0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^pin-name <> <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> > <gy> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <hcom1> >= <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <hcom1>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom1> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-    (vertical-layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <gy> <= <hcom1> } ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom1> ^max >= <hcom1> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  -->
-    (remove 1)
-    (make vertical ^min <vmin> ^layer <lay> ^max <gy> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 4 ^min <hcom1> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy> ^max <hcom1> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>)
-    (modify 2 ^grid-y <hcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from south)
-    (make context ^present propagate-constraint)
-)
-
-(p p532
-    (context ^present random0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^pin-name <> <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> < <gx> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <= <gx> > <vcom1> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom1> ^max >= <gx>)
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom1> } ^max { > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-    (horizontal-layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom1> ^max >= <vcom1> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <vcom1> <= <gx> } ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x > <gx>)
-  -->
-    (remove 1)
-    (make horizontal ^min <hmin> ^layer <lay> ^max <vcom1> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 4 ^min <gx> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <vcom1> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify 2 ^grid-x <vcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from east)
-    (make context ^present propagate-constraint)
-)
-
-(p p533
-    (context ^present random0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^pin-name <> <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> > <gx> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { >= <gx> < <vcom1> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom1>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom1> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-    (horizontal-layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom1> ^max >= <vcom1> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <gx> <= <vcom1> } ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x < <gx>)
-  -->
-    (remove 1)
-    (make horizontal ^min <hmin> ^layer <lay> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 4 ^min <vcom1> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <vcom1> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify 2 ^grid-x <vcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from west)
-    (make context ^present propagate-constraint)
-)
-
-(p p534
-    { <c> (context ^present random2) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (vertical ^status nil ^net-name { <nn> <> nil } ^com > <gx>)
-    { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  -->
-    (make horizontal ^min <hmin> ^layer <lay> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify <h> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify <ff> ^grid-x <gx2> ^grid-layer <lay> ^can-chng-layer nil ^came-from west)
-    (remove <c>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p535
-    { <c> (context ^present random2) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (vertical ^status nil ^net-name { <nn> <> nil } ^com < <gx>)
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <gx> } ^max { <hmax> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) }
-    (congestion ^direction col ^coordinate <gx> ^como <gx2>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  -->
-    (make horizontal ^min <hmin> ^layer <lay> ^max <gx2> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify <h> ^min <gx> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx2> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify <ff> ^grid-x <gx2> ^grid-layer <lay> ^can-chng-layer nil ^came-from east)
-    (remove <c>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p536
-    { <c> (context ^present random2) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^com > <gy>)
-    { <h> (vertical ^net-name nil ^min { <hmin> <= <gy> } ^max { <hmax> > <gy> } ^com <gx> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  -->
-    (make vertical ^min <hmin> ^layer <lay> ^max <gy> ^com <gx> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify <h> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy> ^max <gy2> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gx>)
-    (modify <ff> ^grid-y <gy2> ^grid-layer <lay> ^can-chng-layer nil ^came-from south)
-    (remove <c>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p537
-    { <c> (context ^present random2) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^com < <gy>)
-    { <h> (vertical ^net-name nil ^min { <hmin> < <gy> } ^max { <hmax> >= <gy> } ^com <gx> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) }
-    (congestion ^direction row ^coordinate <gy> ^como <gy2>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  -->
-    (make vertical ^min <hmin> ^layer <lay> ^max <gy2> ^com <gx> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify <h> ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy2> ^max <gy> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gx>)
-    (modify <ff> ^grid-y <gy2> ^grid-layer <lay> ^can-chng-layer nil ^came-from north)
-    (remove <c>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p558
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> <= <nmax> } ^grid-y <gy>)
-  - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-  - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com <gy> ^layer <> <lay>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove 2 3)
-    (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p559
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> > <gx1> <= <nmax> })
-  - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx1> < <gx2> })
-    (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove 2)
-    (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p560
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> < <gx1> >= <nmin> })
-  - (ff ^net-name <nn> ^grid-x { < <gx1> > <gx2> } ^grid-y <gy>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { < <gx1> > <gx2> })
-    (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> >= <gx1> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx2> ^max >= <gx1> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove 2)
-    (make horizontal ^com <gy> ^min <min> ^max <gx2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make horizontal ^com <gy> ^min <gx1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gx2> ^max <gx1> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p561
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> > <gx1> <= <nmax> })
-  - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx1> < <gx2> })
-    (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-    (horizontal-layer <lay>)
-    (dominant-layer)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove 2)
-    (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p562
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> < <gx1> >= <nmin> })
-  - (ff ^net-name <nn> ^grid-x { < <gx1> > <gx2> } ^grid-y <gy>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { < <gx1> > <gx2> })
-    (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> >= <gx1> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-    (horizontal-layer <lay>)
-    (dominant-layer)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx2> ^max >= <gx1> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove 2)
-    (make horizontal ^com <gy> ^min <min> ^max <gx2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make horizontal ^com <gy> ^min <gx1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gx2> ^max <gx1> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p563
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> <= <nmax> } ^grid-y <gy>)
-  - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-    (horizontal-layer <lay>)
-    (dominant-layer)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove 2 3)
-    (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p564
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <gy1> <= <nmax> } ^grid-x <gx>)
-  - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-  - (vertical ^net-name nil ^min <= <gy1> ^max >= <gy2> ^com <gx> ^layer <> <lay>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (remove 2 3)
-    (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p565
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> > <gy1> <= <nmax> })
-  - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy1> < <gy2> })
-    (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (remove 2)
-    (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p566
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> < <gy1> >= <nmin> })
-  - (ff ^net-name <nn> ^grid-y { > <gy2> < <gy1> } ^grid-x <gx>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy2> < <gy1> })
-    (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> >= <gy1> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy2> ^max >= <gy1> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (remove 2)
-    (make vertical ^com <gx> ^min <min> ^max <gy2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make vertical ^com <gx> ^min <gy1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gy2> ^max <gy1> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p567
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> > <gy1> <= <nmax> })
-  - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy1> < <gy2> })
-    (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-    (vertical-layer <lay>)
-    (dominant-layer)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (remove 2)
-    (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p568
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> < <gy1> >= <nmin> })
-  - (ff ^net-name <nn> ^grid-y { > <gy2> < <gy1> } ^grid-x <gx>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy2> < <gy1> })
-    (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> >= <gy1> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-    (vertical-layer <lay>)
-    (dominant-layer)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy2> ^max >= <gy1> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (remove 2)
-    (make vertical ^com <gx> ^min <min> ^max <gy2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make vertical ^com <gx> ^min <gy1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gy2> ^max <gy1> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p569
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <gy1> <= <nmax> } ^grid-x <gx>)
-  - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-    (vertical-layer <lay>)
-    (dominant-layer)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (remove 2 3)
-    (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p570
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <max> >= <nmin> <= <nmax> } ^com <gy> ^layer <garb2> ^compo <garb3> ^commo <garb4> ^pin-name <pn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <max> ^max > <max> ^com <gy>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <min> > <max> <= <nmax> } ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <min> ^max >= <min> ^com <gy>)
-    (horizontal ^net-name nil ^min <max> ^max { <min> > <max> } ^com <gy> ^layer <garb5> ^compo <garb6> ^commo <garb7>)
-  -->
-    (modify 4 ^net-name <nn> ^pin-name <pn> ^max-net nil ^min-net nil)
-)
-
-(p p571
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <max> >= <nmin> <= <nmax> } ^com <gx> ^layer <garb2> ^compo <garb3> ^commo <garb4> ^pin-name <pn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <max> ^max > <max> ^com <gx>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min { <min> > <max> <= <nmax> } ^com <gx>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <min> ^max >= <min> ^com <gx>)
-    (vertical ^net-name nil ^min <max> ^max { <min> > <max> } ^com <gx> ^layer <garb5> ^compo <garb6> ^commo <garb7>)
-  -->
-    (modify 4 ^net-name <nn> ^pin-name <pn> ^max-net nil ^min-net nil)
-)
-
-(p p572
-    { <next> (next-segment <nn> row <gy>) }
-    (ff ^net-name <nn> ^grid-y <gy> ^pin-name <pn> ^came-from north)
-    (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <np> ^no-of-bottom-pins <garb1>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-    { <ff> (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^pin-name <pn2> ^grid-x <gx> ^grid-layer <lay> ^came-from north) }
-    { <v1> (vertical ^net-name nil ^min { <min> <= <gy> } ^max { > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>) }
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com { < <gy2> >= <gy> } ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <gy> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>)
-    (modify <v1> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn2>)
-    (modify <ff> ^grid-y <gy> ^can-chng-layer nil)
-    (modify <next> ^5 useless)
-)
-
-(p p573
-    { <next> (next-segment <nn> row <gy>) }
-    (ff ^came-from south ^net-name <nn> ^grid-y <gy> ^pin-name <pn>)
-    (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <garb1> ^no-of-bottom-pins <np>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-    { <ff> (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^pin-name <pn2> ^grid-x <gx> ^grid-layer <lay> ^came-from south) }
-    { <v1> (vertical ^net-name nil ^max { <max> >= <gy> } ^min { < <max> <= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com { > <gy2> <= <gy> } ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <max> ^min <gy> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <nn> ^max-net <mn>)
-    (modify <v1> ^max <gy2> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn2>)
-    (modify <ff> ^grid-y <gy> ^can-chng-layer nil)
-    (modify <v1> ^5 useless)
-)
-
-(p p574
-    (next-segment <nn> row <gy> <gg1> <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^grid-x { <gx> >= <nmin> <= <nmax> } ^grid-layer <lay> ^pin-name <pn>)
-    (vertical ^net-name nil ^min { <min> <= <gy> } ^max { > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>)
-    (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy2> ^com <gx>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <gy> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>)
-    (modify 3 ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify 2 ^grid-y <gy> ^can-chng-layer nil)
-    (modify 1 ^2 <nn>)
-)
-
-(p p575
-    (next-segment <nn> row <gy> <gg1> <nmin> <nmax>)
-    (vertical ^net-name { <nn> <> nil } ^min { <gy2> > <gy> } ^com { <gx> >= <nmin> <= <nmax> } ^layer <lay> ^pin-name <pn>)
-    (vertical ^net-name nil ^min { < <gy2> <= <gy> } ^max <gy2> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-    (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy2> ^com <gx>)
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2>)
-  - (vertical ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy2> ^com <gx>)
-  - (ff ^net-name <> <nn> ^grid-x <gx>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  -->
-    (modify 3 ^max <gy> ^max-net <nn>)
-    (modify 2 ^min <gy>)
-    (make ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north)
-    (modify 1 ^2 <nn>)
-)
-
-(p p576
-    (next-segment <nn> row <gy> <gg1> <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^grid-x { <gx> >= <nmin> <= <nmax> } ^grid-layer <lay> ^pin-name <pn>)
-    (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>)
-    (vertical-s ^net-name <nn> ^min <= <gy2> ^max >= <gy> ^com <gx>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <gy2> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>)
-    (modify 3 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify 2 ^grid-y <gy> ^can-chng-layer nil)
-    (modify 1 ^2 <nn>)
-)
-
-(p p577
-    (next-segment <nn> row <gy> <gg1> <nmin> <nmax>)
-    (vertical ^net-name { <nn> <> nil } ^min { <gy2> < <gy> } ^com { <gx> >= <nmin> <= <nmax> } ^layer <lay> ^pin-name <pn>)
-    (vertical ^net-name nil ^min <gy2> ^max { > <gy2> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-    (vertical-s ^net-name <nn> ^min <= <gy2> ^max >= <gy> ^com <gx>)
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2>)
-  - (vertical ^net-name { <nn> <> nil } ^min <= <gy2> ^max >= <gy> ^com <gx>)
-  - (ff ^net-name <> <nn> ^grid-x <gx>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  -->
-    (modify 3 ^min <gy> ^min-net <nn>)
-    (modify 2 ^max <gy>)
-    (make ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from south)
-    (modify 1 ^2 <nn>)
-)
-
-(p p578
-    (next-segment <nn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <garb2>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <garb3> ^compo <garb4> ^commo <garb5>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <garb6> ^compo <garb7> ^commo <garb8>)
-  -->
-    (remove 2)
-)
-
-(p p579
-    (next-segment <nn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <garb2>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max <gx> ^com <gy>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <gx> ^max > <gx> ^com <gy>)
-  -->
-    (remove 2)
-)
-
-(p p580
-    (change-priority)
-    { <n> (next-segment ^5 useless) }
-  -->
-    (modify <n> ^5 nil)
-)
-
-(p p581
-    (change-priority)
-    { <n> (next-segment <nn> col <x> useless <min> <max>) }
-    (vertical-s ^net-name <nn> ^com <x> ^sum 2 ^difference 0)
-    (last-row <lr>)
-  -->
-    (modify <n> ^5 nil 1 <lr>)
-)
-
-(p p582
-    (change-priority)
-    { <n> (next-segment <nn> row <y> useless <min> <max>) }
-    (horizontal-s ^net-name <nn> ^com <x> ^sum 2 ^difference 0)
-    (last-col <lc>)
-  -->
-    (modify <n> ^5 nil 1 <lc>)
-)
-
-(p p583
-    { <n> (next-segment <nn> <rc> <xy> nil) }
-  - (next-segment ^5 <> nil)
-  -->
-    (remove <n>)
-    (make move-ff <nn> <rc> <xy>)
-)
-
-(p p584
-    { <c> (change-priority) }
-  -->
-    (remove <c>)
-    (make end-of-specialized-move-ff)
-)
-
-(p p585
-    (move-ff <nn> row <xy>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <xy> ^layer <lay> ^compo <cpo> ^commo <garb1>)
-    { <ff> (ff ^came-from south ^net-name { <nn1> <> <nn> } ^grid-x { <gx> >= <min> <= <max> } ^grid-y <xy> ^grid-layer { <flay> <> <lay> }) }
-    { <v1> (vertical ^status nil ^net-name <nn1> ^min < <xy> ^max <xy> ^com <gx> ^layer <flay>) }
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <xy> ^layer <flay>)
-    { <v2> (vertical ^net-name nil ^min <xy> ^max { <garb4> > <xy> } ^com <gx> ^layer <flay> ^compo <garb2> ^commo <garb3>) }
-  -->
-    (modify <v2> ^min <cpo> ^min-net <nn1>)
-    (modify <v1> ^max <cpo>)
-    (modify <ff> ^grid-y <cpo> ^can-chng-layer nil)
-)
-
-(p p586
-    (move-ff <nn> row <xy>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <xy> ^layer <lay> ^compo <garb1> ^commo <cmo>)
-    { <ff> (ff ^came-from north ^net-name { <nn1> <> <nn> } ^grid-x { <gx> >= <min> <= <max> } ^grid-y <xy> ^grid-layer { <flay> <> <lay> }) }
-    { <v1> (vertical ^status nil ^net-name <nn1> ^min <xy> ^max > <xy> ^com <gx> ^layer <flay>) }
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <xy> ^layer <flay>)
-    { <v2> (vertical ^net-name nil ^min <vmin> ^max { <xy> > <vmin> } ^com <gx> ^layer <flay> ^compo <garb2> ^commo <garb3>) }
-  -->
-    (modify <v2> ^max <cmo> ^max-net <nn1>)
-    (modify <v1> ^min <cmo>)
-    (modify <ff> ^grid-y <cmo> ^can-chng-layer nil)
-)
-
-(p p587
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <min> ^max <max>)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max>) }
-  -->
-    (remove <h>)
-)
-
-(p p588
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <min> ^max <max>)
-    { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max>) }
-  -->
-    (remove <v>)
-)
-
-(p p589
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <min> ^max <max> ^com <com>)
-    (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> < <com> })
-    { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <com> } ^com <gx> ^id <id>) }
-    (vertical ^net-name nil ^min <= <gy> ^max >= <com> ^com <gx>)
-  - (vertical-s ^net-name <> <nn> ^com <gx>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> col <gx> nil <vmin> <vmax>)
-)
-
-(p p590
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <min> ^max <max> ^com <com>)
-    (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> > <com> })
-    { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <com> } ^max { <vmax> >= <gy> } ^com <gx> ^id <id>) }
-    (vertical ^net-name nil ^min <= <com> ^max >= <gy> ^com <gx>)
-  - (vertical-s ^net-name <> <nn> ^com <gx>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> col <gx> nil <vmin> <vmax>)
-)
-
-(p p591
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> < <hcom1> })
-    { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) }
-    (vertical ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax2> })
-  - (vertical-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> col <vcom2> nil <vmin> <vmax>)
-)
-
-(p p592
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> > <hcom1> })
-    { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) }
-    (vertical ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax2> })
-  - (vertical-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> col <vcom2> nil <vmin> <vmax>)
-)
-
-(p p593
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> < <hcom1> })
-    { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) }
-    (vertical ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax1> })
-  - (vertical-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> col <vcom2> nil <vmin> <vmax>)
-)
-
-(p p594
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> > <hcom1> })
-    { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) }
-    (vertical ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax1> })
-  - (vertical-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> col <vcom2> nil <vmin> <vmax>)
-)
-
-(p p595
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <min> ^max <max> ^com <com>)
-    (ff ^net-name <nn> ^grid-x { <gx> < <com> } ^grid-y { <gy> >= <min> <= <max> })
-    { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <gx> } ^max { <vmax> >= <com> } ^com <gy> ^id <id>) }
-    (horizontal ^net-name nil ^min <= <gx> ^max >= <com> ^com <gy>)
-  - (horizontal-s ^net-name <> <nn> ^com <gy>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> row <gy> nil <vmin> <vmax>)
-)
-
-(p p596
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <min> ^max <max> ^com <com>)
-    (ff ^net-name <nn> ^grid-x { <gx> > <com> } ^grid-y { <gy> >= <min> <= <max> })
-    { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <com> } ^max { <vmax> >= <gx> } ^com <gy> ^id <id>) }
-    (horizontal ^net-name nil ^min <= <com> ^max >= <gx> ^com <gy>)
-  - (horizontal-s ^net-name <> <nn> ^com <gy>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> row <gy> nil <vmin> <vmax>)
-)
-
-(p p597
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> < <hcom1> })
-    { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) }
-    (horizontal ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax2> })
-  - (horizontal-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> row <vcom2> nil <vmin> <vmax>)
-)
-
-(p p598
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> > <hcom1> })
-    { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) }
-    (horizontal ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax2> })
-  - (horizontal-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> row <vcom2> nil <vmin> <vmax>)
-)
-
-(p p599
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> < <hcom1> })
-    { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) }
-    (horizontal ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax1> })
-  - (horizontal-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> row <vcom2> nil <vmin> <vmax>)
-)
-
-(p p600
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> > <hcom1> })
-    { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) }
-    (horizontal ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax1> })
-  - (horizontal-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> row <vcom2> nil <vmin> <vmax>)
-)
-
-(p p601
-    { <m> (move-ff) }
-  -->
-    (remove <m>)
-)
-
-(p p602
-    { <e> (end-of-specialized-move-ff) }
-  - (next-segment)
-  -->
-    (remove <e>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p603
-    (context ^present << check-for-routed-net propagate-constraint >>)
-    (<< dominant-layer change-priority next-segment >>)
-  -->
-    (remove 2)
-)
-
-(p p244
-    (context ^present lshape1)
-    (<< total-verti counted-verti total counted >>)
-  -->
-    (remove 2)
-)
-
-(p p245
-    (context ^present lshape1)
-    (last-row <gy>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north)
-  - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <gy2>)
-  - (vertical ^com { > <gx> < <gx2> })
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy> ^layer <lay> ^commo <hcmo> ^compo <hcpo> ^min-net <mn>)
-  - (pin ^pin-x <gx2> ^pin-y <hcpo>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  -->
-    (make horizontal ^layer <lay> ^min <hmin> ^max <gx> ^min-net <mn> ^max-net <nn> ^com <gy> ^commo <hcmo> ^compo <hcpo>)
-    (modify 5 ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx> ^max <gx2> ^com <gy> ^commo <hcmo> ^compo <hcpo>)
-    (modify 3 ^grid-x <gx2> ^came-from west)
-)
-
-(p p246
-    (context ^present lshape1)
-    (last-row <gy>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north)
-  - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y <gy2>)
-  - (vertical ^com { > <gx2> < <gx> })
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (pin ^pin-x <gx2> ^pin-y <hcpo>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  -->
-    (make horizontal ^layer <lay> ^min <hmin> ^max <gx2> ^min-net <mn> ^max-net <nn> ^com <gy> ^commo <hcmo> ^compo <hcpo>)
-    (modify 5 ^min <gx> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx2> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo>)
-    (modify 3 ^grid-x <gx2> ^came-from east)
-)
-
-(p p247
-    (context ^present lshape1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y 1 ^grid-layer <lay> ^pin-name <pn> ^came-from south)
-  - (ff ^net-name <nn> ^grid-y 1 ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <gy2>)
-  - (vertical ^com { > <gx> < <gx2> })
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <hmin> >= <gx2> } ^com 1 ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (pin ^pin-x <gx2> ^pin-y 0)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gx2> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com 1 ^layer <lay>)
-  -->
-    (make horizontal ^layer <lay> ^min <hmin> ^max <gx> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <hcmo> ^compo <hcpo>)
-    (modify 4 ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx> ^max <gx2> ^com 1 ^commo <hcmo> ^compo <hcpo>)
-    (modify 2 ^grid-x <gx2> ^came-from west)
-)
-
-(p p248
-    (context ^present lshape1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y 1 ^grid-layer <lay> ^pin-name <pn> ^came-from south)
-  - (ff ^net-name <nn> ^grid-y 1 ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y <gy2>)
-  - (vertical ^com { > <gx2> < <gx> })
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx> } ^com 1 ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (pin ^pin-x <gx2> ^pin-y 0)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gx2> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com 1 ^layer <lay>)
-  -->
-    (make horizontal ^layer <lay> ^min <hmin> ^max <gx2> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <hcmo> ^compo <hcpo>)
-    (modify 4 ^min <gx> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx2> ^max <gx> ^com 1 ^commo <hcmo> ^compo <hcpo>)
-    (modify 2 ^grid-x <gx2> ^came-from east)
-)
-
-(p p249
-    (context ^present lshape1)
-    (last-col <gx>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from east)
-  - (ff ^net-name <nn> ^grid-x <gx> ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> > <gy> })
-  - (horizontal ^com { > <gy> < <gy2> })
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy2> > <vmin> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (pin ^pin-x <vcpo> ^pin-y <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^layer <lay> ^min <vmin> ^max <gy> ^min-net <mn> ^max-net <nn> ^com <gx> ^commo <vcmo> ^compo <vcpo>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy> ^max <gy2> ^com <gx> ^commo <vcmo> ^compo <vcpo>)
-    (modify 3 ^grid-y <gy2> ^came-from south)
-)
-
-(p p250
-    (context ^present lshape1)
-    (last-col <gx>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from east)
-  - (ff ^net-name <nn> ^grid-x <gx> ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> < <gy> })
-  - (horizontal ^com { > <gy2> < <gy> })
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> >= <gy> > <vmin> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (pin ^pin-x <vcpo> ^pin-y <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^layer <lay> ^min <vmin> ^max <gy2> ^min-net <mn> ^max-net <nn> ^com <gx> ^commo <vcmo> ^compo <vcpo>)
-    (modify 5 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy2> ^max <gy> ^com <gx> ^commo <vcmo> ^compo <vcpo>)
-    (modify 3 ^grid-y <gy2> ^came-from north)
-)
-
-(p p251
-    (context ^present lshape1)
-    (ff ^net-name <nn> ^grid-x 1 ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from west)
-  - (ff ^net-name <nn> ^grid-x 1 ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> > <gy> })
-  - (horizontal ^com { > <gy> < <gy2> })
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { <vmax> > <vmin> >= <gy2> } ^com 1 ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (pin ^pin-x 0 ^pin-y <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com 1 ^layer <lay>)
-  -->
-    (make vertical ^layer <lay> ^min <vmin> ^max <gy> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <vcmo> ^compo <vcpo>)
-    (modify 4 ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy> ^max <gy2> ^com 1 ^commo <vcmo> ^compo <vcpo>)
-    (modify 2 ^grid-y <gy2> ^came-from south)
-)
-
-(p p252
-    (context ^present lshape1)
-    (ff ^net-name <nn> ^grid-x 1 ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from west)
-  - (ff ^net-name <nn> ^grid-x 1 ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> < <gy> })
-  - (horizontal ^com { > <gy2> < <gy> })
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy> } ^com 1 ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (pin ^pin-x 0 ^pin-y <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com 1 ^layer <lay>)
-  -->
-    (make vertical ^layer <lay> ^min <vmin> ^max <gy2> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <vcmo> ^compo <vcpo>)
-    (modify 4 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy2> ^max <gy> ^com 1 ^commo <vcmo> ^compo <vcpo>)
-    (modify 2 ^grid-y <gy2> ^came-from north)
-)
-
-(p p253
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> >= <gy1> > <vmin> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> >= <gx2> > <hmin> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p254
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p255
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p256
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p257
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>)
-  - (pin ^net-name <nn1> ^pin-x >= <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p258
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy2> ^grid-x > <gx1>)
-  - (pin ^net-name <nn1> ^pin-x <= <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p259
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>)
-  - (pin ^net-name <nn1> ^pin-x >= <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p260
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy1> ^grid-x > <gx2>)
-  - (pin ^net-name <nn1> ^pin-x <= <gx2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p261
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>)
-  - (pin ^net-name <nn1> ^pin-y >= <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p262
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>)
-  - (pin ^net-name <nn1> ^pin-y >= <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p263
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y > <gy2>)
-  - (pin ^net-name <nn1> ^pin-y <= <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p264
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx2> ^grid-y > <gy1>)
-  - (pin ^net-name <nn1> ^pin-y <= <gy1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p265
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>)
-  - (pin ^net-name <nn1> ^pin-y >= <gy2>)
-    (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>)
-  - (pin ^net-name <nn2> ^pin-x >= <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p266
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>)
-  - (pin ^net-name <nn1> ^pin-y >= <gy2>)
-    (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy2> ^grid-x > <gx1>)
-  - (pin ^net-name <nn2> ^pin-x <= <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p267
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y > <gy2>)
-  - (pin ^net-name <nn1> ^pin-y <= <gy2>)
-    (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>)
-  - (pin ^net-name <nn2> ^pin-x >= <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p268
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx2> ^grid-y > <gy1>)
-  - (pin ^net-name <nn1> ^pin-y <= <gy1>)
-    (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy1> ^grid-x > <gx2>)
-  - (pin ^net-name <nn2> ^pin-x <= <gx2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p269
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p270
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p271
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p272
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p273
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p274
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p275
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p276
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p277
-    (context ^present lshape3)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p278
-    (context ^present lshape3)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p279
-    (context ^present lshape3)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p280
-    (context ^present lshape3)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p281
-    (context ^present lshape4)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <garb2>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p282
-    (context ^present lshape4)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <garb2>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p283
-    (context ^present lshape4)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <garb2>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p284
-    (context ^present lshape4)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <garb2>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p285
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-  - (ff ^grid-x <gx1> ^net-name <> <nn>)
-    { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy1> } ^max { <vmax1> > <vmin1> >= <gy1> } ^com <gx1> ^layer <lay> ^commo <gx2> ^compo <cpo> ^min-net <vnn1>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com { <hcom> >= <vmin1> < <gy1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (vertical-layer <lay>)
-    (ff ^grid-x <gx2> ^net-name <> <nn>)
-  - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com { >= <vmin1> < <hcom> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>)
-  -->
-    (remove <c>)
-    (make vertical ^com <gx1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <cpo> ^commo <gx2> ^min-net <vnn1> ^max-net <nn>)
-    (modify <v> ^min <gy1> ^min-net <nn>)
-    (make horizontal ^min <hmin> ^max <gx2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <lay> ^min <hcom> ^max <gy1> ^commo <gx2> ^compo <cpo> ^net-name <nn> ^pin-name <pn1>)
-    (make horizontal ^com <hcom> ^layer <lay> ^min <gx2> ^max <gx1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>)
-    (modify <ff> ^grid-x <gx2> ^grid-y <hcom> ^can-chng-layer nil ^came-from east)
-    (make context ^present check-for-routed-net)
-)
-
-(p p286
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-  - (ff ^grid-x <gx2> ^net-name <> <nn>)
-    { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy2> } ^max { <vmax1> > <vmin1> >= <gy2> } ^com <gx2> ^layer <lay> ^commo <cmo> ^compo <gx1> ^max-net <vnn1>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com { <hcom> <= <vmax1> > <gy2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (vertical-layer <lay>)
-    (ff ^grid-x <gx1> ^net-name <> <nn>)
-  - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com { <= <vmax1> > <hcom> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>)
-  -->
-    (remove <c>)
-    (make vertical ^com <gx2> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <gx1> ^commo <cmo> ^max-net <vnn1> ^min-net <nn>)
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make horizontal ^min <hmin> ^max <gx2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <lay> ^max <hcom> ^min <gy2> ^commo <cmo> ^compo <gx1> ^net-name <nn> ^pin-name <pn2>)
-    (make horizontal ^com <hcom> ^layer <lay> ^min <gx2> ^max <gx1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>)
-    (modify <ff> ^grid-x <gx1> ^grid-y <hcom> ^can-chng-layer nil ^came-from west)
-    (make context ^present check-for-routed-net)
-)
-
-(p p287
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-  - (ff ^grid-x <gx1> ^net-name <> <nn>)
-    { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy1> } ^max { <vmax1> > <vmin1> >= <gy1> } ^com <gx1> ^layer <lay> ^commo <cmo> ^compo <gx2> ^min-net <vnn1>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com { <hcom> >= <vmin1> < <gy1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (vertical-layer <lay>)
-    (ff ^grid-x <gx2> ^net-name <> <nn>)
-  - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com { >= <vmin1> < <hcom> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>)
-  -->
-    (remove <c>)
-    (make vertical ^com <gx1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <gx2> ^commo <cmo> ^min-net <vnn1> ^max-net <nn>)
-    (modify <v> ^min <gy1> ^min-net <nn>)
-    (make horizontal ^min <hmin> ^max <gx1> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <lay> ^min <hcom> ^max <gy1> ^commo <cmo> ^compo <gx2> ^net-name <nn> ^pin-name <pn1>)
-    (make horizontal ^com <hcom> ^layer <lay> ^min <gx1> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>)
-    (modify <ff> ^grid-x <gx2> ^grid-y <hcom> ^can-chng-layer nil ^came-from west)
-    (make context ^present check-for-routed-net)
-)
-
-(p p288
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-  - (ff ^grid-x <gx2> ^net-name <> <nn>)
-    { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy2> } ^max { <vmax1> > <vmin1> >= <gy2> } ^com <gx2> ^layer <lay> ^commo <gx1> ^compo <cpo> ^max-net <vnn1>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com { <hcom> <= <vmax1> > <gy2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (vertical-layer <lay>)
-    (ff ^grid-x <gx1> ^net-name <> <nn>)
-  - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com { <= <vmax1> > <hcom> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>)
-  -->
-    (remove <c>)
-    (make vertical ^com <gx2> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <cpo> ^commo <gx1> ^max-net <vnn1> ^min-net <nn>)
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make horizontal ^min <hmin> ^max <gx1> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <lay> ^max <hcom> ^min <gy2> ^commo <gx1> ^compo <cpo> ^net-name <nn> ^pin-name <pn2>)
-    (make horizontal ^com <hcom> ^layer <lay> ^min <gx1> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>)
-    (modify <ff> ^grid-x <gx1> ^grid-y <hcom> ^can-chng-layer nil ^came-from east)
-    (make context ^present check-for-routed-net)
-)
-
-(p p289
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-  - (ff ^grid-y <gy1> ^net-name <> <nn>)
-    { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx1> } ^max { <vmax1> > <vmin1> >= <gx1> } ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^min-net <vnn1>) }
-    { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> >= <vmin1> < <gx1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (horizontal-layer <lay>)
-    (ff ^grid-y <gy2> ^net-name <> <nn>)
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { >= <vmin1> < <hcom> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>)
-  -->
-    (remove <c>)
-    (make horizontal ^com <gy1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <cpo> ^commo <gy2> ^min-net <vnn1> ^max-net <nn>)
-    (modify <v> ^min <gx1> ^min-net <nn>)
-    (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <lay> ^min <hcom> ^max <gx1> ^commo <gy2> ^compo <cpo> ^net-name <nn> ^pin-name <pn1>)
-    (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>)
-    (modify <ff> ^grid-y <gy2> ^grid-x <hcom> ^can-chng-layer nil ^came-from north)
-    (make context ^present check-for-routed-net)
-)
-
-(p p290
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-  - (ff ^grid-y <gy2> ^net-name <> <nn>)
-    { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx2> } ^max { <vmax1> > <vmin1> >= <gx2> } ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gy1> ^max-net <vnn1>) }
-    { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> <= <vmax1> > <gx2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (horizontal-layer <lay>)
-    (ff ^grid-y <gy1> ^net-name <> <nn>)
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { <= <vmax1> > <hcom> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>)
-  -->
-    (remove <c>)
-    (make horizontal ^com <gy2> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <gy1> ^commo <cmo> ^max-net <vnn1> ^min-net <nn>)
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <lay> ^max <hcom> ^min <gx2> ^commo <cmo> ^compo <gy1> ^net-name <nn> ^pin-name <pn2>)
-    (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>)
-    (modify <ff> ^grid-y <gy1> ^grid-x <hcom> ^can-chng-layer nil ^came-from south)
-    (make context ^present check-for-routed-net)
-)
-
-(p p291
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-  - (ff ^grid-y <gy1> ^net-name <> <nn>)
-    { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx1> } ^max { <vmax1> > <vmin1> >= <gx1> } ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^max-net <vnn1>) }
-    { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> <= <vmax1> > <gx1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (horizontal-layer <lay>)
-    (ff ^grid-y <gy2> ^net-name <> <nn>)
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { <= <vmax1> > <hcom> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>)
-  -->
-    (remove <c>)
-    (make horizontal ^com <gy1> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <cpo> ^commo <gy2> ^max-net <vnn1> ^min-net <nn>)
-    (modify <v> ^max <gx1> ^max-net <nn>)
-    (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <lay> ^min <gx1> ^max <hcom> ^commo <gy2> ^compo <cpo> ^net-name <nn> ^pin-name <pn1>)
-    (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>)
-    (modify <ff> ^grid-y <gy2> ^grid-x <hcom> ^can-chng-layer nil ^came-from north)
-    (make context ^present check-for-routed-net)
-)
-
-(p p292
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-  - (ff ^grid-y <gy2> ^net-name <> <nn>)
-    { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx2> } ^max { <vmax1> > <vmin1> >= <gx2> } ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gy1> ^min-net <vnn1>) }
-    { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> >= <vmin1> < <gx2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (horizontal-layer <lay>)
-    (ff ^grid-y <gy1> ^net-name <> <nn>)
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { >= <vmin1> < <hcom> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>)
-  -->
-    (remove <c>)
-    (make horizontal ^com <gy2> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <gy1> ^commo <cmo> ^min-net <vnn1> ^max-net <nn>)
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <lay> ^max <gx2> ^min <hcom> ^commo <cmo> ^compo <gy1> ^net-name <nn> ^pin-name <pn2>)
-    (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>)
-    (modify <ff> ^grid-y <gy1> ^grid-x <hcom> ^can-chng-layer nil ^came-from south)
-    (make context ^present check-for-routed-net)
-)
-
-(p p211
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> west ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx> })
-    (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> >= <gx> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x >= <gx> ^grid-y < <gy>)
-  - (ff ^net-name <nn> ^grid-x >= <gx> ^grid-y > <gy>)
-  -->
-    (make horizontal ^min <min> ^max (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min <gx> ^min-net <nn>)
-    (make horizontal ^max <gx> ^min (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-x (compute <gx> - 1) ^came-from east ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p212
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> south ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-y { <gy2> < <gy> })
-    (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x < <gx> ^grid-y >= <gy>)
-  - (ff ^net-name <nn> ^grid-x > <gx> ^grid-y >= <gy>)
-  -->
-    (make vertical ^min <min> ^max (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min <gy> ^min-net <nn>)
-    (make vertical ^max <gy> ^min (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-y (compute <gy> - 1) ^came-from north ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p213
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> east ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx> })
-    (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { <max> > <min> >= <gx2> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <= <gx> ^grid-y < <gy>)
-  - (ff ^net-name <nn> ^grid-x <= <gx> ^grid-y > <gy>)
-  -->
-    (make horizontal ^max <max> ^min (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max <gx> ^max-net <nn>)
-    (make horizontal ^min <gx> ^max (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-x (compute <gx> + 1) ^came-from west ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p214
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <gy> })
-    (vertical ^net-name nil ^min { <min> <= <gy> } ^max { <max> > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x < <gx> ^grid-y <= <gy>)
-  - (ff ^net-name <nn> ^grid-x > <gx> ^grid-y <= <gy>)
-  -->
-    (make vertical ^max <max> ^min (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max <gy> ^max-net <nn>)
-    (make vertical ^min <gy> ^max (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-y (compute <gy> + 1) ^came-from south ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p215
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> west ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y <= <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> > <min> >= <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  -->
-    (make horizontal ^min <min> ^max (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min <gx> ^min-net <nn>)
-    (make horizontal ^max <gx> ^min (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-x (compute <gx> - 1) ^came-from east ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p216
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> west ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y >= <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> > <min> >= <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  -->
-    (make horizontal ^min <min> ^max (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min <gx> ^min-net <nn>)
-    (make horizontal ^max <gx> ^min (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-x (compute <gx> - 1) ^came-from east ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p217
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> east ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <= <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { <max> > <min> >= <gx2> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  -->
-    (make horizontal ^max <max> ^min (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max <gx> ^max-net <nn>)
-    (make horizontal ^min <gx> ^max (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-x (compute <gx> + 1) ^came-from west ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p218
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> east ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y >= <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { <max> > <min> >= <gx2> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  -->
-    (make horizontal ^max <max> ^min (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max <gx> ^max-net <nn>)
-    (make horizontal ^min <gx> ^max (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-x (compute <gx> + 1) ^came-from west ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p219
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^grid-x >= <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy> } ^max { <max> > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x < <gx>)
-  -->
-    (make vertical ^max <max> ^min (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>)
-    (modify 4 ^max <gy> ^max-net <nn>)
-    (make vertical ^min <gy> ^max (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-y (compute <gy> + 1) ^came-from south ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p220
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^grid-x <= <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy> } ^max { <max> > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x > <gx>)
-  -->
-    (make vertical ^max <max> ^min (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>)
-    (modify 4 ^max <gy> ^max-net <nn>)
-    (make vertical ^min <gy> ^max (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-y (compute <gy> + 1) ^came-from south ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p221
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> south ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^grid-x <= <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x > <gx>)
-  -->
-    (make vertical ^min <min> ^max (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>)
-    (modify 4 ^min <gy> ^min-net <nn>)
-    (make vertical ^max <gy> ^min (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-y (compute <gy> - 1) ^came-from north ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p222
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^grid-x >= <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x < <gx>)
-  -->
-    (make vertical ^min <min> ^max (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>)
-    (modify 4 ^min <gy> ^min-net <nn>)
-    (make vertical ^max <gy> ^min (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-y (compute <gy> - 1) ^came-from north ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p223
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  -->
-    (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p224
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <com1> } ^grid-x <gx>)
-    (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  -->
-    (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p225
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  -->
-    (make horizontal ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p226
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-y { <gy2> < <com1> } ^grid-x <gx>)
-    (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  -->
-    (make vertical ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p227
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  -->
-    (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p228
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <com1> } ^grid-x <gx>)
-    (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  -->
-    (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p229
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  -->
-    (make horizontal ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p230
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> < <com1> })
-    (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  -->
-    (make vertical ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p231
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (vertical ^net-name nil ^max <min1> ^com <com1>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p232
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (vertical ^net-name nil ^max <min1> ^com <com1>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p233
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (vertical ^net-name nil ^max <min1> ^com <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make horizontal ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p234
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (vertical ^net-name nil ^max <min1> ^com <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make horizontal ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p235
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> > <com1> })
-    (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^max <min1> ^com <com1>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p236
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> > <com1> })
-    (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^max <min1> ^com <com1>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p237
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> < <com1> })
-    (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^max <min1> ^com <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make vertical ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p238
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> < <com1> })
-    (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^commo <cmo2> ^compo <cpo2> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^max <min1> ^com <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make vertical ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p239
-    (context ^present loose-constraint0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top)
-    (vertical ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy> ^com { <vcom> > <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom> ^com <gy>)
-    (vertical ^net-name nil ^min { <min> < <gy> } ^max >= <gy> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>)
-  - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>)
-    (congestion ^direction row ^coordinate <gy> ^como <hcmo>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <hcmo> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify 2 ^grid-y <hcmo> ^can-chng-layer nil)
-    (modify 1 ^present propagate-constraint)
-)
-
-(p p240
-    (context ^present loose-constraint0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top)
-    (vertical ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy> ^com { <vcom> < <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom> ^max >= <gx> ^com <gy>)
-    (vertical ^net-name nil ^min { <min> < <gy> } ^max >= <gy> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>)
-  - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>)
-    (congestion ^direction row ^coordinate <gy> ^como <hcmo>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <hcmo> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify 2 ^grid-y <hcmo> ^can-chng-layer nil)
-    (modify 1 ^present propagate-constraint)
-)
-
-(p p241
-    (context ^present loose-constraint0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from south)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom)
-    (vertical ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy> ^com { <vcom> > <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom> ^com <gy>)
-    (vertical ^net-name nil ^min <= <gy> ^max { <max> > <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>)
-  - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>)
-    (congestion ^direction row ^coordinate <hcmo> ^como <gy>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <max> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^max-net <mn> ^min-net <nn>)
-    (modify 5 ^max <gy> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^min <gy> ^max <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify 2 ^grid-y <hcmo> ^can-chng-layer nil)
-    (modify 1 ^present propagate-constraint)
-)
-
-(p p242
-    (context ^present loose-constraint0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from south)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom)
-    (vertical ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy> ^com { <vcom> < <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom> ^max >= <gx> ^com <gy>)
-    (vertical ^net-name nil ^min <= <gy> ^max { <max> > <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>)
-  - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>)
-    (congestion ^direction row ^coordinate <hcmo> ^como <gy>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <max> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^max-net <mn> ^min-net <nn>)
-    (modify 5 ^max <gy> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^min <gy> ^max <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify 2 ^grid-y <hcmo> ^can-chng-layer nil)
-    (modify 1 ^present propagate-constraint)
-)
-
-(p p243
-    (context ^present loose-constraint0)
-  -->
-    (modify 1 ^present loose-constraint)
-)
-
-(p p363
-    (move-via <nn>)
-  -->
-    (remove 1)
-    (make finally-routed <nn>)
-)
-
-(p p364
-    (move-via <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <garb1> ^commo <hcmo> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcmo> ^max <hcom> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> })
-    (vertical ^net-name nil ^min { <vmin2> <= <hcmo> } ^max { <vmax2> > <vmin2> >= <hcom> } ^com <vcom> ^layer <hlay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (horizontal ^net-name <> <nn> ^min < <vcom> ^max >= <vcom> ^com <hcmo>)
-  - (vertical ^net-name <> <nn> ^min < <hcmo> ^max <hcmo> ^com <vcom>)
-  -->
-    (modify 3 ^max <hcmo>)
-    (make vertical ^layer <vlay> ^max <hcom> ^min <hcmo> ^com <vcom> ^min-net <nn> ^commo <vcmo> ^compo <vcpo>)
-    (make vertical ^layer <hlay> ^min <vmin2> ^max <hcmo> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>)
-    (modify 4 ^min <hcom> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcmo> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^com <vcom>)
-    (remove 1)
-    (make move-via <nn> <vlay> <vcom> <hcom>)
-)
-
-(p p365
-    (move-via <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <garb1> ^commo <hcmo> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcmo> ^max <hcom> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> })
-    (vertical ^net-name nil ^min { <vmin2> <= <hcmo> } ^max { <vmax2> > <vmin2> >= <hcom> } ^com <vcom> ^layer <hlay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (horizontal ^net-name <> <nn> ^min <= <vcom> ^max > <vcom> ^com <hcmo>)
-  - (vertical ^net-name <> <nn> ^min < <hcmo> ^max <hcmo> ^com <vcom>)
-  -->
-    (modify 3 ^max <hcmo>)
-    (make vertical ^layer <vlay> ^max <hcom> ^min <hcmo> ^com <vcom> ^min-net <nn> ^commo <vcmo> ^compo <vcpo>)
-    (make vertical ^layer <hlay> ^min <vmin2> ^max <hcmo> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>)
-    (modify 4 ^min <hcom> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcmo> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^com <vcom>)
-    (remove 1)
-    (make move-via <nn> <vlay> <vcom> <hcom>)
-)
-
-(p p366
-    (move-via <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <garb1> ^commo <vcmo> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcmo> ^max <vcom> ^com { <hcom> >= <vmin> <= <vmax> } ^layer { <hlay> <> <vlay> })
-    (horizontal ^net-name nil ^min { <hmin2> <= <vcmo> } ^max { <hmax2> > <hmin2> >= <vcom> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (vertical ^net-name <> <nn> ^min < <hcom> ^max >= <hcom> ^com <vcmo>)
-  - (horizontal ^net-name <> <nn> ^min < <vcmo> ^max <vcmo> ^com <hcom>)
-  -->
-    (modify 3 ^max <vcmo>)
-    (make horizontal ^layer <hlay> ^max <vcom> ^min <vcmo> ^com <hcom> ^min-net <nn> ^commo <hcmo> ^compo <hcpo>)
-    (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcmo> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>)
-    (modify 4 ^min <vcom> ^min-net <nn>)
-    (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcmo> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^com <hcom>)
-    (remove 1)
-    (make move-via <nn> <hlay> <hcom> <vcom>)
-)
-
-(p p367
-    (move-via <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <garb1> ^commo <vcmo> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcmo> ^com { <hcom> >= <vmin> <= <vmax> } ^max <vcom> ^layer { <hlay> <> <vlay> })
-    (horizontal ^net-name nil ^min { <hmin2> <= <vcmo> } ^max { <hmax2> > <hmin2> >= <vcom> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (vertical ^net-name <> <nn> ^min <= <hcom> ^max > <hcom> ^com <vcmo>)
-  - (horizontal ^net-name <> <nn> ^min < <vcmo> ^max <vcmo> ^com <hcom>)
-  -->
-    (modify 3 ^max <vcmo>)
-    (make horizontal ^layer <hlay> ^max <vcom> ^min <vcmo> ^com <hcom> ^min-net <nn> ^commo <hcmo> ^compo <hcpo>)
-    (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcmo> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>)
-    (modify 4 ^min <vcom> ^min-net <nn>)
-    (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcmo> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^com <hcom>)
-    (remove 1)
-    (make move-via <nn> <hlay> <hcom> <vcom>)
-)
-
-(p p368
-    (move-via <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <hcpo> ^commo <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max >= <hcpo> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> })
-    (vertical ^net-name nil ^min { <vmin2> <= <hcom> } ^max { <vmax2> > <vmin2> >= <hcpo> } ^com <vcom> ^layer <hlay> ^commo <vcmo> ^compo <vcpo> ^min-net <mn>)
-  - (horizontal ^net-name <> <nn> ^min < <vcom> ^max >= <vcom> ^com <hcpo>)
-  - (vertical ^net-name <> <nn> ^min <hcpo> ^max > <hcpo> ^com <vcom>)
-  -->
-    (modify 3 ^min <hcpo>)
-    (make vertical ^layer <vlay> ^min <hcom> ^max <hcpo> ^com <vcom> ^max-net <nn> ^commo <vcmo> ^compo <vcpo>)
-    (make vertical ^layer <hlay> ^min <vmin2> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>)
-    (modify 4 ^min <hcpo> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcom> ^max <hcpo> ^commo <vcmo> ^compo <vcpo> ^com <vcom>)
-    (remove 1)
-    (make move-via <nn> <vlay> <vcom> <hcom>)
-)
-
-(p p369
-    (move-via <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <hcpo> ^commo <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max >= <hcpo> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> })
-    (vertical ^net-name nil ^min { <vmin2> <= <hcom> } ^max { <vmax2> > <vmin2> >= <hcpo> } ^com <vcom> ^layer <hlay> ^commo <vcmo> ^compo <vcpo> ^min-net <mn>)
-  - (horizontal ^net-name <> <nn> ^min <= <vcom> ^max > <vcom> ^com <hcpo>)
-  - (vertical ^net-name <> <nn> ^min <hcpo> ^max > <hcpo> ^com <vcom>)
-  -->
-    (modify 3 ^min <hcpo>)
-    (make vertical ^layer <vlay> ^min <hcom> ^max <hcpo> ^com <vcom> ^max-net <nn> ^commo <vcmo> ^compo <vcpo>)
-    (make vertical ^layer <hlay> ^min <vmin2> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>)
-    (modify 4 ^min <hcpo> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcom> ^max <hcpo> ^commo <vcmo> ^compo <vcpo> ^com <vcom>)
-    (remove 1)
-    (make move-via <nn> <vlay> <vcom> <hcom>)
-)
-
-(p p370
-    (move-via <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <vcpo> ^commo <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max >= <vcpo> ^com { <hcom> >= <vmin> <= <vmax> } ^layer { <hlay> <> <vlay> })
-    (horizontal ^net-name nil ^min { <hmin2> <= <vcom> } ^max { <hmax2> > <hmin2> >= <vcpo> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (vertical ^net-name <> <nn> ^min < <hcom> ^max >= <hcom> ^com <vcpo>)
-  - (horizontal ^net-name <> <nn> ^min <vcpo> ^max > <vcpo> ^com <hcom>)
-  -->
-    (modify 3 ^min <vcpo>)
-    (make horizontal ^layer <hlay> ^max <vcpo> ^min <vcom> ^com <hcom> ^max-net <nn> ^commo <hcmo> ^compo <hcpo>)
-    (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>)
-    (modify 4 ^min <vcpo> ^min-net <nn>)
-    (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcom> ^max <vcpo> ^commo <hcmo> ^compo <hcpo> ^com <hcom>)
-    (remove 1)
-    (make move-via <nn> <hlay> <hcom> <vcom>)
-)
-
-(p p371
-    (move-via <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <vcpo> ^commo <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max >= <vcpo> ^com { <hcom> >= <vmin> <= <vmax> } ^layer { <hlay> <> <vlay> })
-    (horizontal ^net-name nil ^min { <hmin2> <= <vcom> } ^max { <hmax2> > <hmin2> >= <vcpo> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (vertical ^net-name <> <nn> ^min <= <hcom> ^max > <hcom> ^com <vcmo>)
-  - (horizontal ^net-name <> <nn> ^min <vcpo> ^max > <vcpo> ^com <hcom>)
-  -->
-    (modify 3 ^min <vcpo>)
-    (make horizontal ^layer <hlay> ^max <vcpo> ^min <vcom> ^com <hcom> ^max-net <nn> ^commo <hcmo> ^compo <hcpo>)
-    (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>)
-    (modify 4 ^min <vcpo> ^min-net <nn>)
-    (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcom> ^max <vcpo> ^commo <hcmo> ^compo <hcpo> ^com <hcom>)
-    (remove 1)
-    (make move-via <nn> <hlay> <hcom> <vcom>)
-)
-
-(p p372
-    (move-via <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin1> ^max <vmax1> ^com <vcom1> ^layer <vlay> ^compo <vcpo1> ^commo <vcmo1> ^pin-name <pn1>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmax1> ^max <vmax2> ^com { <vcom2> > <vcom1> } ^layer <vlay> ^compo <vcpo2> ^commo <vcmo2> ^pin-name <pn2>)
-    { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom1> ^max <vcom2> ^com <vmax1> ^layer { <hlay> <> <vlay> }) }
-    { <h2> (horizontal ^status nil ^net-name nil ^min { <fmin> <= <vcom1> } ^max { <fmax> >= <vcom2> } ^com <vmax1> ^layer <vlay>) }
-  - (vertical ^min < <vmax1> ^max >= <vmax1> ^com { > <vcom1> < <vcom2> })
-  -->
-    (remove <h2>)
-    (modify <h1> ^net-name nil ^pin-name nil ^min-net nil ^max-net nil)
-    (make (substr <h2> 1 inf) ^max <vcmo1> ^max-net nil)
-    (make (substr <h2> 1 inf) ^min <vcpo2> ^min-net nil)
-    (make (substr <h1> 1 inf) ^layer <vlay>)
-)
-
-(p p373
-    (move-via <nn> <lay> <x> <y>)
-    (horizontal ^min <x> ^max <garb1> ^com <y> ^layer <lay> ^min-net <nn> ^max-net <garb2>)
-  -->
-    (modify 2 ^min-net nil)
-)
-
-(p p374
-    (move-via <nn> <lay> <x> <y>)
-    (vertical ^min <y> ^max <garb1> ^com <x> ^layer <lay> ^min-net <nn> ^max-net <garb2>)
-  -->
-    (modify 2 ^min-net nil)
-)
-
-(p p375
-    (move-via <nn> <lay> <x> <y>)
-    (horizontal ^min <garb1> ^max <x> ^com <y> ^layer <lay> ^min-net <garb2> ^max-net <nn>)
-  -->
-    (modify 2 ^max-net nil)
-)
-
-(p p376
-    (move-via <nn> <lay> <x> <y>)
-    (vertical ^min <garb1> ^max <y> ^com <x> ^layer <lay> ^min-net <garb2> ^max-net <nn>)
-  -->
-    (modify 2 ^max-net nil)
-)
-
-(p start-dummy
-    (start)
-  -->
-    (write (crlf) | Dummy START, do "loadwm" from "kuh.tmp".| (crlf))
-
-
-
-(make layer-info    ^layer-name metal    ^layer-order 2)
-(make layer-info    ^layer-name poly    ^layer-order 1)
-(make channel    ^channel-bottom-left-x 0    ^channel-bottom-left-y 0    ^channel-top-right-x 13    ^channel-top-right-y 5    ^channel-width 5    ^channel-length 13    ^no-of-left-pins 0    ^no-of-right-pins 0    ^no-of-top-pins 12    ^no-of-bottom-pins 12)
-(make last-row    4    3)
-(make last-col    12    11)
-(make pin    ^net-name 3    ^external-pin-name 1    ^pin-x 1    ^pin-y 0    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side bottom    ^pin-name 35    ^external-net-name 3)
-(make pin    ^net-name 1    ^external-pin-name 2    ^pin-x 2    ^pin-y 0    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side bottom    ^pin-name 34    ^external-net-name 1)
-(make pin    ^net-name 5    ^external-pin-name 3    ^pin-x 3    ^pin-y 0    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side bottom    ^pin-name 33    ^external-net-name 5)
-(make pin    ^net-name 3    ^external-pin-name 4    ^pin-x 4    ^pin-y 0    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side bottom    ^pin-name 32    ^external-net-name 3)
-(make pin    ^net-name 5    ^external-pin-name 5    ^pin-x 5    ^pin-y 0    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side bottom    ^pin-name 31    ^external-net-name 5)
-(make pin    ^net-name 2    ^external-pin-name 6    ^pin-x 6    ^pin-y 0    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side bottom    ^pin-name 30    ^external-net-name 2)
-(make pin    ^net-name 6    ^external-pin-name 7    ^pin-x 7    ^pin-y 0    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side bottom    ^pin-name 29    ^external-net-name 6)
-(make pin    ^net-name 8    ^external-pin-name 8    ^pin-x 8    ^pin-y 0    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side bottom    ^pin-name 28    ^external-net-name 8)
-(make pin    ^net-name 9    ^external-pin-name 9    ^pin-x 9    ^pin-y 0    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side bottom    ^pin-name 27    ^external-net-name 9)
-(make pin    ^net-name 8    ^external-pin-name 10    ^pin-x 10    ^pin-y 0    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side bottom    ^pin-name 26    ^external-net-name 8)
-(make pin    ^net-name 7    ^external-pin-name 11    ^pin-x 11    ^pin-y 0    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side bottom    ^pin-name 25    ^external-net-name 7)
-(make pin    ^net-name 9    ^external-pin-name 12    ^pin-x 12    ^pin-y 0    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side bottom    ^pin-name 24    ^external-net-name 9)
-(make pin    ^net-name 2    ^external-pin-name 13    ^pin-x 1    ^pin-y 5    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side top    ^pin-name 6    ^external-net-name 2)
-(make pin    ^net-name 1    ^external-pin-name 14    ^pin-x 2    ^pin-y 5    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side top    ^pin-name 7    ^external-net-name 1)
-(make pin    ^net-name 4    ^external-pin-name 15    ^pin-x 3    ^pin-y 5    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side top    ^pin-name 8    ^external-net-name 4)
-(make pin    ^net-name 5    ^external-pin-name 16    ^pin-x 4    ^pin-y 5    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side top    ^pin-name 9    ^external-net-name 5)
-(make pin    ^net-name 1    ^external-pin-name 17    ^pin-x 5    ^pin-y 5    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side top    ^pin-name 10    ^external-net-name 1)
-(make pin    ^net-name 6    ^external-pin-name 18    ^pin-x 6    ^pin-y 5    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side top    ^pin-name 11    ^external-net-name 6)
-(make pin    ^net-name 7    ^external-pin-name 19    ^pin-x 7    ^pin-y 5    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side top    ^pin-name 12    ^external-net-name 7)
-(make pin    ^net-name 10    ^external-pin-name 20    ^pin-x 8    ^pin-y 5    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side top    ^pin-name 13    ^external-net-name 10)
-(make pin    ^net-name 4    ^external-pin-name 21    ^pin-x 9    ^pin-y 5    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side top    ^pin-name 14    ^external-net-name 4)
-(make pin    ^net-name 9    ^external-pin-name 22    ^pin-x 10    ^pin-y 5    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side top    ^pin-name 15    ^external-net-name 9)
-(make pin    ^net-name 10    ^external-pin-name 23    ^pin-x 11    ^pin-y 5    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side top    ^pin-name 16    ^external-net-name 10)
-(make pin    ^net-name 10    ^external-pin-name 24    ^pin-x 12    ^pin-y 5    ^pin-layer poly    ^pin-layer-constraint fixed    ^pin-channel-side top    ^pin-name 17    ^external-net-name 10)
-(make net    ^net-name 3    ^parent-name 3    ^net-no-of-pins 2    ^net-left-x 1    ^net-left-y 0    ^net-right-x 4    ^net-right-y 0    ^no-of-left-pins 0    ^no-of-right-pins 0    ^no-of-top-pins 0    ^no-of-bottom-pins 2    ^left-most-pin-name 35    ^right-most-pin-name 32    ^bottom-most-pin-name 35    ^top-most-pin-name 35    ^external-net-name 3)
-(make to-be-routed    ^net-name 3    ^no-of-attached-pins 1)
-(make included    3    35)
-(make net    ^net-name 1    ^parent-name 1    ^net-no-of-pins 3    ^net-left-x 2    ^net-left-y 0    ^net-right-x 5    ^net-right-y 5    ^no-of-left-pins 0    ^no-of-right-pins 0    ^no-of-top-pins 2    ^no-of-bottom-pins 1    ^left-most-pin-name 34    ^right-most-pin-name 10    ^bottom-most-pin-name 34    ^top-most-pin-name 7    ^external-net-name 1)
-(make to-be-routed    ^net-name 1    ^no-of-attached-pins 1)
-(make included    1    34)
-(make net    ^net-name 5    ^parent-name 5    ^net-no-of-pins 3    ^net-left-x 3    ^net-left-y 0    ^net-right-x 5    ^net-right-y 5    ^no-of-left-pins 0    ^no-of-right-pins 0    ^no-of-top-pins 1    ^no-of-bottom-pins 2    ^left-most-pin-name 33    ^right-most-pin-name 31    ^bottom-most-pin-name 33    ^top-most-pin-name 9    ^external-net-name 5)
-(make to-be-routed    ^net-name 5    ^no-of-attached-pins 1)
-(make included    5    33)
-(make net    ^net-name 2    ^parent-name 2    ^net-no-of-pins 2    ^net-left-x 1    ^net-left-y 0    ^net-right-x 6    ^net-right-y 5    ^no-of-left-pins 0    ^no-of-right-pins 0    ^no-of-top-pins 1    ^no-of-bottom-pins 1    ^left-most-pin-name 6    ^right-most-pin-name 30    ^bottom-most-pin-name 30    ^top-most-pin-name 6    ^external-net-name 2)
-(make to-be-routed    ^net-name 2    ^no-of-attached-pins 1)
-(make included    2    30)
-(make net    ^net-name 6    ^parent-name 6    ^net-no-of-pins 2    ^net-left-x 6    ^net-left-y 0    ^net-right-x 7    ^net-right-y 5    ^no-of-left-pins 0    ^no-of-right-pins 0    ^no-of-top-pins 1    ^no-of-bottom-pins 1    ^left-most-pin-name 11    ^right-most-pin-name 29    ^bottom-most-pin-name 29    ^top-most-pin-name 11    ^external-net-name 6)
-(make to-be-routed    ^net-name 6    ^no-of-attached-pins 1)
-(make included    6    29)
-(make net    ^net-name 8    ^parent-name 8    ^net-no-of-pins 2    ^net-left-x 8    ^net-left-y 0    ^net-right-x 10    ^net-right-y 0    ^no-of-left-pins 0    ^no-of-right-pins 0    ^no-of-top-pins 0    ^no-of-bottom-pins 2    ^left-most-pin-name 28    ^right-most-pin-name 26    ^bottom-most-pin-name 28    ^top-most-pin-name 28    ^external-net-name 8)
-(make to-be-routed    ^net-name 8    ^no-of-attached-pins 1)
-(make included    8    28)
-(make net    ^net-name 9    ^parent-name 9    ^net-no-of-pins 3    ^net-left-x 9    ^net-left-y 0    ^net-right-x 12    ^net-right-y 5    ^no-of-left-pins 0    ^no-of-right-pins 0    ^no-of-top-pins 1    ^no-of-bottom-pins 2    ^left-most-pin-name 27    ^right-most-pin-name 24    ^bottom-most-pin-name 27    ^top-most-pin-name 15    ^external-net-name 9)
-(make to-be-routed    ^net-name 9    ^no-of-attached-pins 1)
-(make included    9    27)
-(make net    ^net-name 7    ^parent-name 7    ^net-no-of-pins 2    ^net-left-x 7    ^net-left-y 0    ^net-right-x 11    ^net-right-y 5    ^no-of-left-pins 0    ^no-of-right-pins 0    ^no-of-top-pins 1    ^no-of-bottom-pins 1    ^left-most-pin-name 12    ^right-most-pin-name 25    ^bottom-most-pin-name 25    ^top-most-pin-name 12    ^external-net-name 7)
-(make to-be-routed    ^net-name 7    ^no-of-attached-pins 1)
-(make included    7    25)
-(make net    ^net-name 4    ^parent-name 4    ^net-no-of-pins 2    ^net-left-x 3    ^net-left-y 5    ^net-right-x 9    ^net-right-y 5    ^no-of-left-pins 0    ^no-of-right-pins 0    ^no-of-top-pins 2    ^no-of-bottom-pins 0    ^left-most-pin-name 8    ^right-most-pin-name 14    ^bottom-most-pin-name 8    ^top-most-pin-name 8    ^external-net-name 4)
-(make to-be-routed    ^net-name 4    ^no-of-attached-pins 1)
-(make included    4    8)
-(make net    ^net-name 10    ^parent-name 10    ^net-no-of-pins 3    ^net-left-x 8    ^net-left-y 5    ^net-right-x 12    ^net-right-y 5    ^no-of-left-pins 0    ^no-of-right-pins 0    ^no-of-top-pins 3    ^no-of-bottom-pins 0    ^left-most-pin-name 13    ^right-most-pin-name 17    ^bottom-most-pin-name 13    ^top-most-pin-name 13    ^external-net-name 10)
-(make to-be-routed    ^net-name 10    ^no-of-attached-pins 1)
-(make included    10    13)
-(make vertical-layer    poly    24)
-(make horizontal-layer    metal    0)
-(make congestion    ^coordinate 0    ^direction row    ^no-of-nets 12    ^como -1)
-(make congestion    ^coordinate 1    ^direction row    ^no-of-nets 12    ^como 0)
-(make congestion    ^coordinate 2    ^direction row    ^no-of-nets 6    ^como 1)
-(make congestion    ^coordinate 3    ^direction row    ^no-of-nets 6    ^como 2)
-(make congestion    ^coordinate 4    ^direction row    ^no-of-nets 12    ^como 3)
-(make congestion    ^coordinate 5    ^direction row    ^no-of-nets 12    ^como 4)
-(make congestion    ^coordinate 0    ^direction col    ^no-of-nets 0    ^como -1)
-(make congestion    ^coordinate 1    ^direction col    ^no-of-nets 2    ^como 0)
-(make congestion    ^coordinate 2    ^direction col    ^no-of-nets 3    ^como 1)
-(make congestion    ^coordinate 3    ^direction col    ^no-of-nets 5    ^como 2)
-(make congestion    ^coordinate 4    ^direction col    ^no-of-nets 5    ^como 3)
-(make congestion    ^coordinate 5    ^direction col    ^no-of-nets 4    ^como 4)
-(make congestion    ^coordinate 6    ^direction col    ^no-of-nets 3    ^como 5)
-(make congestion    ^coordinate 7    ^direction col    ^no-of-nets 3    ^como 6)
-(make congestion    ^coordinate 8    ^direction col    ^no-of-nets 4    ^como 7)
-(make congestion    ^coordinate 9    ^direction col    ^no-of-nets 5    ^como 8)
-(make congestion    ^coordinate 10    ^direction col    ^no-of-nets 4    ^como 9)
-(make congestion    ^coordinate 11    ^direction col    ^no-of-nets 3    ^como 10)
-(make congestion    ^coordinate 12    ^direction col    ^no-of-nets 2    ^como 11)
-(make congestion    ^coordinate 13    ^direction col    ^no-of-nets 0    ^como 12)
-(make horizontal    ^compo 3    ^com 2    ^min 1    ^max 12    ^commo 1    ^layer metal)
-(make horizontal    ^compo 3    ^com 2    ^min 1    ^max 12    ^commo 1    ^layer poly)
-(make horizontal    ^compo 4    ^com 3    ^min 1    ^max 12    ^commo 2    ^layer metal)
-(make horizontal    ^compo 4    ^com 3    ^min 1    ^max 12    ^commo 2    ^layer poly)
-(make vertical    ^compo 3    ^com 2    ^min 1    ^max 4    ^commo 1    ^layer metal)
-(make vertical    ^compo 3    ^com 2    ^min 1    ^max 4    ^commo 1    ^layer poly    ^min-net 1    ^max-net 1)
-(make vertical    ^compo 4    ^com 3    ^min 1    ^max 4    ^commo 2    ^layer metal)
-(make vertical    ^compo 4    ^com 3    ^min 1    ^max 4    ^commo 2    ^layer poly    ^min-net 5    ^max-net 4)
-(make vertical    ^compo 5    ^com 4    ^min 1    ^max 4    ^commo 3    ^layer metal)
-(make vertical    ^compo 5    ^com 4    ^min 1    ^max 4    ^commo 3    ^layer poly    ^min-net 3    ^max-net 5)
-(make vertical    ^compo 6    ^com 5    ^min 1    ^max 4    ^commo 4    ^layer metal)
-(make vertical    ^compo 6    ^com 5    ^min 1    ^max 4    ^commo 4    ^layer poly    ^min-net 5    ^max-net 1)
-(make vertical    ^compo 7    ^com 6    ^min 1    ^max 4    ^commo 5    ^layer metal)
-(make vertical    ^compo 7    ^com 6    ^min 1    ^max 4    ^commo 5    ^layer poly    ^min-net 2    ^max-net 6)
-(make vertical    ^compo 8    ^com 7    ^min 1    ^max 4    ^commo 6    ^layer metal)
-(make vertical    ^compo 8    ^com 7    ^min 1    ^max 4    ^commo 6    ^layer poly    ^min-net 6    ^max-net 7)
-(make vertical    ^compo 9    ^com 8    ^min 1    ^max 4    ^commo 7    ^layer metal)
-(make vertical    ^compo 9    ^com 8    ^min 1    ^max 4    ^commo 7    ^layer poly    ^min-net 8    ^max-net 10)
-(make vertical    ^compo 10    ^com 9    ^min 1    ^max 4    ^commo 8    ^layer metal)
-(make vertical    ^compo 10    ^com 9    ^min 1    ^max 4    ^commo 8    ^layer poly    ^min-net 9    ^max-net 4)
-(make vertical    ^compo 11    ^com 10    ^min 1    ^max 4    ^commo 9    ^layer metal)
-(make vertical    ^compo 11    ^com 10    ^min 1    ^max 4    ^commo 9    ^layer poly    ^min-net 8    ^max-net 9)
-(make vertical    ^compo 12    ^com 11    ^min 1    ^max 4    ^commo 10    ^layer metal)
-(make vertical    ^compo 12    ^com 11    ^min 1    ^max 4    ^commo 10    ^layer poly    ^min-net 7    ^max-net 10)
-(make horizontal    ^compo 2    ^com 1    ^min 1    ^max 12    ^commo 0    ^layer metal)
-(make horizontal    ^compo 5    ^com 4    ^min 11    ^max 12    ^commo 3    ^layer poly    ^min-net 10    ^max-net 10)
-(make horizontal    ^compo 5    ^com 4    ^min 1    ^max 12    ^commo 3    ^layer metal)
-(make vertical    ^compo 2    ^com 1    ^min 1    ^max 4    ^commo 0    ^layer poly    ^min-net 3    ^max-net 2)
-(make vertical    ^compo 2    ^com 1    ^min 1    ^max 4    ^commo 0    ^layer metal)
-(make vertical    ^compo 13    ^com 12    ^min 1    ^max 4    ^commo 11    ^layer poly    ^min-net 9    ^max-net 10)
-(make vertical    ^compo 13    ^com 12    ^min 1    ^max 4    ^commo 11    ^layer metal)
-(make vertical    ^net-name 3    ^compo 2    ^com 1    ^min 0    ^max 1    ^commo 0    ^layer poly    ^pin-name 35)
-(make ff    ^net-name 3    ^grid-layer poly    ^grid-x 1    ^grid-y 1    ^came-from south    ^pin-name 35)
-(make vertical    ^net-name 1    ^compo 3    ^com 2    ^min 0    ^max 1    ^commo 1    ^layer poly    ^pin-name 34)
-(make ff    ^net-name 1    ^grid-layer poly    ^grid-x 2    ^grid-y 1    ^came-from south    ^pin-name 34)
-(make vertical    ^net-name 5    ^compo 4    ^com 3    ^min 0    ^max 1    ^commo 2    ^layer poly    ^pin-name 33)
-(make ff    ^net-name 5    ^grid-layer poly    ^grid-x 3    ^grid-y 1    ^came-from south    ^pin-name 33)
-(make vertical    ^net-name 3    ^compo 5    ^com 4    ^min 0    ^max 1    ^commo 3    ^layer poly    ^pin-name 32)
-(make ff    ^net-name 3    ^grid-layer poly    ^grid-x 4    ^grid-y 1    ^came-from south    ^pin-name 32)
-(make vertical    ^net-name 5    ^compo 6    ^com 5    ^min 0    ^max 1    ^commo 4    ^layer poly    ^pin-name 31)
-(make ff    ^net-name 5    ^grid-layer poly    ^grid-x 5    ^grid-y 1    ^came-from south    ^pin-name 31)
-(make vertical    ^net-name 2    ^compo 7    ^com 6    ^min 0    ^max 1    ^commo 5    ^layer poly    ^pin-name 30)
-(make ff    ^net-name 2    ^grid-layer poly    ^grid-x 6    ^grid-y 1    ^came-from south    ^pin-name 30)
-(make vertical    ^net-name 6    ^compo 8    ^com 7    ^min 0    ^max 1    ^commo 6    ^layer poly    ^pin-name 29)
-(make ff    ^net-name 6    ^grid-layer poly    ^grid-x 7    ^grid-y 1    ^came-from south    ^pin-name 29)
-(make vertical    ^net-name 8    ^compo 9    ^com 8    ^min 0    ^max 1    ^commo 7    ^layer poly    ^pin-name 28)
-(make ff    ^net-name 8    ^grid-layer poly    ^grid-x 8    ^grid-y 1    ^came-from south    ^pin-name 28)
-(make vertical    ^net-name 9    ^compo 10    ^com 9    ^min 0    ^max 1    ^commo 8    ^layer poly    ^pin-name 27)
-(make ff    ^net-name 9    ^grid-layer poly    ^grid-x 9    ^grid-y 1    ^came-from south    ^pin-name 27)
-(make vertical    ^net-name 8    ^compo 11    ^com 10    ^min 0    ^max 1    ^commo 9    ^layer poly    ^pin-name 26)
-(make ff    ^net-name 8    ^grid-layer poly    ^grid-x 10    ^grid-y 1    ^came-from south    ^pin-name 26)
-(make vertical    ^net-name 7    ^compo 12    ^com 11    ^min 0    ^max 1    ^commo 10    ^layer poly    ^pin-name 25)
-(make ff    ^net-name 7    ^grid-layer poly    ^grid-x 11    ^grid-y 1    ^came-from south    ^pin-name 25)
-(make vertical    ^net-name 9    ^compo 13    ^com 12    ^min 0    ^max 1    ^commo 11    ^layer poly    ^pin-name 24)
-(make ff    ^net-name 9    ^grid-layer poly    ^grid-x 12    ^grid-y 1    ^came-from south    ^pin-name 24)
-(make vertical    ^net-name 2    ^compo 2    ^com 1    ^min 4    ^max 5    ^commo 0    ^layer poly    ^pin-name 6)
-(make ff    ^net-name 2    ^grid-layer poly    ^grid-x 1    ^grid-y 4    ^came-from north    ^pin-name 6)
-(make vertical    ^net-name 1    ^compo 3    ^com 2    ^min 4    ^max 5    ^commo 1    ^layer poly    ^pin-name 7)
-(make ff    ^net-name 1    ^grid-layer poly    ^grid-x 2    ^grid-y 4    ^came-from north    ^pin-name 7)
-(make vertical    ^net-name 4    ^compo 4    ^com 3    ^min 4    ^max 5    ^commo 2    ^layer poly    ^pin-name 8)
-(make ff    ^net-name 4    ^grid-layer poly    ^grid-x 3    ^grid-y 4    ^came-from north    ^pin-name 8)
-(make vertical    ^net-name 5    ^compo 5    ^com 4    ^min 4    ^max 5    ^commo 3    ^layer poly    ^pin-name 9)
-(make ff    ^net-name 5    ^grid-layer poly    ^grid-x 4    ^grid-y 4    ^came-from north    ^pin-name 9)
-(make vertical    ^net-name 1    ^compo 6    ^com 5    ^min 4    ^max 5    ^commo 4    ^layer poly    ^pin-name 10)
-(make ff    ^net-name 1    ^grid-layer poly    ^grid-x 5    ^grid-y 4    ^came-from north    ^pin-name 10)
-(make vertical    ^net-name 6    ^compo 7    ^com 6    ^min 4    ^max 5    ^commo 5    ^layer poly    ^pin-name 11)
-(make ff    ^net-name 6    ^grid-layer poly    ^grid-x 6    ^grid-y 4    ^came-from north    ^pin-name 11)
-(make vertical    ^net-name 7    ^compo 8    ^com 7    ^min 4    ^max 5    ^commo 6    ^layer poly    ^pin-name 12)
-(make ff    ^net-name 7    ^grid-layer poly    ^grid-x 7    ^grid-y 4    ^came-from north    ^pin-name 12)
-(make vertical    ^net-name 10    ^compo 9    ^com 8    ^min 4    ^max 5    ^commo 7    ^layer poly    ^pin-name 13)
-(make ff    ^net-name 10    ^grid-layer poly    ^grid-x 8    ^grid-y 4    ^came-from north    ^pin-name 13)
-(make vertical    ^net-name 4    ^compo 10    ^com 9    ^min 4    ^max 5    ^commo 8    ^layer poly    ^pin-name 14)
-(make ff    ^net-name 4    ^grid-layer poly    ^grid-x 9    ^grid-y 4    ^came-from north    ^pin-name 14)
-(make vertical    ^net-name 9    ^compo 11    ^com 10    ^min 4    ^max 5    ^commo 9    ^layer poly    ^pin-name 15)
-(make ff    ^net-name 9    ^grid-layer poly    ^grid-x 10    ^grid-y 4    ^came-from north    ^pin-name 15)
-(make vertical    ^net-name 10    ^compo 12    ^com 11    ^min 4    ^max 5    ^commo 10    ^layer poly    ^pin-name 16)
-(make ff    ^net-name 10    ^grid-layer poly    ^grid-x 11    ^grid-y 4    ^came-from north    ^pin-name 16)
-(make vertical    ^net-name 10    ^compo 13    ^com 12    ^min 4    ^max 5    ^commo 11    ^layer poly    ^pin-name 17)
-(make ff    ^net-name 10    ^grid-layer poly    ^grid-x 12    ^grid-y 4    ^came-from north    ^pin-name 17)
-(make horizontal-s    ^net-name 3    ^top-count 0    ^com 1    ^min 1    ^max 4    ^bot-count 2    ^id 0    ^sum 2    ^difference -2    ^absolute 2)
-(make vertical-s    ^net-name 1    ^top-count 1    ^com 2    ^min 1    ^max 4    ^bot-count 0    ^id 1    ^sum 1    ^difference 1    ^absolute 1)
-(make horizontal-s    ^net-name 1    ^top-count 2    ^com 4    ^min 2    ^max 5    ^bot-count 1    ^id 2    ^sum 3    ^difference 1    ^absolute 1)
-(make horizontal-s    ^net-name 5    ^top-count 1    ^com 1    ^min 3    ^max 5    ^bot-count 2    ^id 3    ^sum 3    ^difference -1    ^absolute 1)
-(make vertical-s    ^net-name 5    ^top-count 1    ^com 4    ^min 1    ^max 4    ^bot-count 1    ^id 4    ^sum 2    ^difference 0    ^absolute 0)
-(make vertical-s    ^net-name 2    ^top-count 1    ^com 1    ^min 1    ^max 4    ^bot-count 1    ^id 5    ^sum 2    ^difference 0    ^absolute 0)
-(make horizontal-s    ^net-name 2    ^top-count 1    ^com 1    ^min 1    ^max 6    ^bot-count 1    ^id 6    ^sum 2    ^difference 0    ^absolute 0)
-(make vertical-s    ^net-name 6    ^top-count 1    ^com 6    ^min 1    ^max 4    ^bot-count 0    ^id 7    ^sum 1    ^difference 1    ^absolute 1)
-(make horizontal-s    ^net-name 6    ^top-count 1    ^com 1    ^min 6    ^max 7    ^bot-count 1    ^id 8    ^sum 2    ^difference 0    ^absolute 0)
-(make horizontal-s    ^net-name 8    ^top-count 0    ^com 1    ^min 8    ^max 10    ^bot-count 2    ^id 9    ^sum 2    ^difference -2    ^absolute 2)
-(make horizontal-s    ^net-name 9    ^top-count 1    ^com 1    ^min 9    ^max 12    ^bot-count 2    ^id 10    ^sum 3    ^difference -1    ^absolute 1)
-(make vertical-s    ^net-name 9    ^top-count 1    ^com 10    ^min 1    ^max 4    ^bot-count 1    ^id 11    ^sum 2    ^difference 0    ^absolute 0)
-(make vertical-s    ^net-name 7    ^top-count 1    ^com 7    ^min 1    ^max 4    ^bot-count 0    ^id 12    ^sum 1    ^difference 1    ^absolute 1)
-(make horizontal-s    ^net-name 7    ^top-count 1    ^com 1    ^min 7    ^max 11    ^bot-count 1    ^id 13    ^sum 2    ^difference 0    ^absolute 0)
-(make horizontal-s    ^net-name 4    ^top-count 2    ^com 4    ^min 3    ^max 9    ^bot-count 0    ^id 14    ^sum 2    ^difference 2    ^absolute 2)
-(make horizontal-s    ^net-name 10    ^top-count 3    ^com 4    ^min 8    ^max 12    ^bot-count 0    ^id 15    ^sum 3    ^difference 3    ^absolute 3)
-(make branch-no    1000)
-(make context    ^present separate)
-)
diff --git a/contrib/ops/ops-backup.lisp b/contrib/ops/ops-backup.lisp
deleted file mode 100644
index a940546f2c8eef3ea307c3aeeafebf77b79cf2e9..0000000000000000000000000000000000000000
--- a/contrib/ops/ops-backup.lisp
+++ /dev/null
@@ -1,196 +0,0 @@
-;
-;************************************************************************
-;
-;	VPS2 -- Interpreter for OPS5
-;
-;
-;
-; This Common Lisp version of OPS5 is in the public domain.  It is based
-; in part on based on a Franz Lisp implementation done by Charles L. Forgy
-; at Carnegie-Mellon University, which was placed in the public domain by
-; the author in accordance with CMU policies.  This version has been
-; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
-; and Dan Kuokka.
-;
-; This code is made available is, and without warranty of any kind by the
-; authors or by Carnegie-Mellon University.
-;
-
-;;;; Definitions and functions for backing up.
-
-(in-package "OPS")
-
-
-;;; Internal Global Variables
-
-(defvar *refracts*)
-(defvar *record*)
-(defvar *record-array*)
-(defvar *recording*)
-(defvar *max-record-index*)
-(defvar *record-index*)
-
-
-
-(defun backup-init ()
-  (setq *recording* nil)
-  (setq *refracts* nil)
-  (setq *record-array* (make-array 256 :initial-element ()))  ;jgk
-  (initialize-record))
-
-
-(defun back (k)
-  (prog (r)
-    loop   (and (< k 1.) (return nil))
-    (setq r (getvector *record-array* *record-index*))	; (('))
-    (and (null r) (return '|nothing more stored|))
-    (putvector *record-array* *record-index* nil)
-    (record-index-plus -1.)
-    (undo-record r)
-    (setq k (1- k))
-    (go loop)))
-
-
-; *max-record-index* holds the maximum legal index for record-array
-; so it and the following must be changed at the same time
-
-(defun begin-record (p data)
-  (setq *recording* t)
-  (setq *record* (list '=>refract p data))) 
-
-(defun end-record nil
-  (cond (*recording*
-	 (setq *record*
-	       (cons *cycle-count* (cons *p-name* *record*)))
-	 (record-index-plus 1.)
-	 (putvector *record-array* *record-index* *record*)
-	 (setq *record* nil)
-	 (setq *recording* nil)))) 
-
-(defun record-change (direct time elm)
-  (cond (*recording*
-	 (setq *record*
-	       (cons direct (cons time (cons elm *record*))))))) 
-
-; to maintain refraction information, need keep only one piece of information:
-; need to record all unsuccessful attempts to delete things from the conflict
-; set.  unsuccessful deletes are caused by attempting to delete refracted
-; instantiations.  when backing up, have to avoid putting things back into the
-; conflict set if they were not deleted when running forward
-
-(defun record-refract (rule data)
-  (and *recording*
-       (setq *record* (cons '<=refract (cons rule (cons data *record*))))))
-
-(defun refracted (rule data)
-  (prog (z)
-    (and (null *refracts*) (return nil))
-    (setq z (cons rule data))
-    (return (member z *refracts* :test #'equal))))
-
-
-(defun record-index-plus (k)
-  (setq *record-index* (+ k *record-index*))	;"plus" changed to "+" by gdw
-  (cond ((< *record-index* 0.)
-	 (setq *record-index* *max-record-index*))
-	((> *record-index* *max-record-index*)
-	 (setq *record-index* 0.)))) 
-
-; the following routine initializes the record.  putting nil in the
-; first slot indicates that that the record does not go back further
-; than that.  (when the system backs up, it writes nil over the used
-; records so that it will recognize which records it has used.  thus
-; the system is set up anyway never to back over a nil.)
-
-(defun initialize-record nil
-  (setq *record-index* 0.)
-  (setq *recording* nil)
-  (setq *max-record-index* 31.)
-  (putvector *record-array* 0. nil)) 
-
-
-;; replaced per jcp
-;;; Commented out
-#|
-(defun undo-record (r)
-  (prog (save act a b rate)
-    ;###	(comment *recording* must be off during back up)
-    (setq save *recording*)
-    (setq *refracts* nil)
-    (setq *recording* nil)
-    (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
-    (setq r (cddr r))
-    top  (and (atom r) (go fin))
-    (setq act (car r))
-    (setq a (cadr r))
-    (setq b (caddr r))
-    (setq r (cdddr r))
-    (and *wtrace* (back-print (list '|undo:| act a)))
-    (cond ((eq act '<=wm) (add-to-wm b a))
-	  ((eq act '=>wm) (remove-from-wm b))
-	  ((eq act '<=refract)
-	   (setq *refracts* (cons (cons a b) *refracts*)))
-	  ((and (eq act '=>refract) (still-present b))
-	   (setq *refracts* (delete (cons a b) *refracts*))
-	   (setq rate (rating-part (get a 'topnode)))
-	   (removecs a b)
-	   (insertcs a b rate))
-	  (t (%warn '|back: cannot undo action| (list act a))))
-    (go top)
-    fin  (setq *recording* save)
-    (setq *refracts* nil)
-    (return nil)))
-;;; End commented out
-|#
-
-
-(defun undo-record (r)
-  (prog (save act a b rate)
-    ;###	(comment *recording* must be off during back up)
-    (setq save *recording*)
-    (setq *refracts* nil)
-    (setq *recording* nil)
-    (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
-    (setq r (cddr r))
-    top  (and (atom r) (go fin))
-    (setq act (car r))
-    (setq a (cadr r))
-    (setq b (caddr r))
-    (setq r (cdddr r))
-    (and *wtrace* (back-print (list '|undo:| act a)))
-    (cond ((eq act '<=wm) (add-to-wm b a))
-	  ((eq act '=>wm) (remove-from-wm b))
-	  ((eq act '<=refract)
-	   (setq *refracts* (cons (cons a b) *refracts*)))
-	  ((and (eq act '=>refract) (still-present b))
-	   (setq *refracts* (spdelete (cons a b) *refracts*))
-	   (setq rate (rating-part (get a 'topnode)))
-	   (removecs a b)
-	   (insertcs a b rate))
-	  (t (%warn '|back: cannot undo action| (list act a))))
-    (go top)
-    fin  (setq *recording* save)
-    (setq *refracts* nil)
-    (return nil))) 
-
-
-
-; still-present makes sure that the user has not deleted something
-; from wm which occurs in the instantiation about to be restored; it
-; makes the check by determining whether each wme still has a time tag.
-
-(defun still-present (data)
-  (prog nil
-    loop
-    (cond ((atom data) (return t))
-	  ((creation-time (car data))
-	   (setq data (cdr data))
-	   (go loop))
-	  (t (return nil))))) 
-
-
-(defun back-print (x) 
-  (prog (port)
-    (setq port (trace-file))
-    (terpri port)
-    (print x port)))
diff --git a/contrib/ops/ops-compile.lisp b/contrib/ops/ops-compile.lisp
deleted file mode 100644
index bdf7960ffd3e602e70396770d3a7249e51b2d6ac..0000000000000000000000000000000000000000
--- a/contrib/ops/ops-compile.lisp
+++ /dev/null
@@ -1,805 +0,0 @@
-;
-;************************************************************************
-;
-;	VPS2 -- Interpreter for OPS5
-;
-;
-;
-; This Common Lisp version of OPS5 is in the public domain.  It is based
-; in part on based on a Franz Lisp implementation done by Charles L. Forgy
-; at Carnegie-Mellon University, which was placed in the public domain by
-; the author in accordance with CMU policies.  This version has been
-; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
-; and Dan Kuokka.
-;
-; This code is made available is, and without warranty of any kind by the
-; authors or by Carnegie-Mellon University.
-;
-
-;;;; This file contains functions compile productions.
-
-(in-package "OPS")
-(shadow '(remove write))    ; Should get this by requiring ops-rhs
-(export '--> )
-
-
-;;; External global variables
-
-(defvar *real-cnt*)
-(defvar *virtual-cnt*)
-(defvar *last-node*)
-(defvar *first-node*)
-(defvar *pcount*)
-
-
-;;; Internal global variables
-
-(defvar *matrix*)
-(defvar *curcond*)
-(defvar *feature-count*)
-(defvar *ce-count*)
-(defvar *vars*)
-(defvar *ce-vars*)
-(defvar *rhs-bound-vars*)
-(defvar *rhs-bound-ce-vars*)
-(defvar *last-branch*)
-(defvar *subnum*)
-(defvar *cur-vars*)
-(defvar *action-type*)
-
-
-
-(defun compile-init ()
-  (setq *real-cnt* (setq *virtual-cnt* 0.))
-  (setq *pcount* 0.)
-  (make-bottom-node))
-
-
-;;; LHS Compiler
-
-(defun ops-p (z) 
-  (finish-literalize)
-  (princ '*) 
-  ;(drain) commented out temporarily
-  (force-output)			;@@@ clisp drain?
-  (compile-production (car z) (cdr z))) 
-
-
-(defun compile-production (name matrix) ;jgk inverted args to catch and quoted tag
-  (setq *p-name* name)
-  (catch '!error! (cmp-p name matrix))
-  (setq *p-name* nil))
-#|
-(defun compile-production (name matrix) ;jgk inverted args to catch 
-  (prog (erm)				;and quoted tag
-    (setq *p-name* name)
-    (setq erm (catch '!error! (cmp-p name matrix)))
-    (setq *p-name* nil)))
-|#
-
-(defun peek-lex nil (car *matrix*)) 
-
-(defun lex nil
-  (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*)))) 
-
-(defun end-of-p nil (atom *matrix*)) 
-
-(defun rest-of-p nil *matrix*) 
-
-(defun prepare-lex (prod) (setq *matrix* prod)) 
-
-
-(defun peek-sublex nil (car *curcond*)) 
-
-(defun sublex nil
-  (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*)))) 
-
-(defun end-of-ce nil (atom *curcond*)) 
-
-(defun rest-of-ce nil *curcond*) 
-
-(defun prepare-sublex (ce) (setq *curcond* ce)) 
-
-(defun make-bottom-node nil (setq *first-node* (list '&bus nil))) 
-
-(defun cmp-p (name matrix)
-  (prog (m bakptrs)
-    (cond ((or (null name) (consp  name))	;dtpr\consp gdw
-	   (%error '|illegal production name| name))
-	  ((equal (get name 'production) matrix)
-	   (return nil)))
-    (prepare-lex matrix)
-    (excise-p name)
-    (setq bakptrs nil)
-    (setq *pcount* (1+ *pcount*))		;"plus" changed to "+" by gdw
-    (setq *feature-count* 0.)
-    (setq *ce-count* 0)
-    (setq *vars* nil)
-    (setq *ce-vars* nil)
-    (setq *rhs-bound-vars* nil)
-    (setq *rhs-bound-ce-vars* nil)
-    (setq *last-branch* nil)
-    (setq m (rest-of-p))
-    l1   (and (end-of-p) (%error '|no '-->' in production| m))
-    (cmp-prin)
-    (setq bakptrs (cons *last-branch* bakptrs))
-    (or (eq '--> (peek-lex)) (go l1))
-    (lex)
-    (check-rhs (rest-of-p))
-    (link-new-node (list '&p
-			 *feature-count*
-			 name
-			 (encode-dope)
-			 (encode-ce-dope)
-			 (cons 'progn (rest-of-p))))
-    (putprop name (cdr (nreverse bakptrs)) 'backpointers)
-    (putprop name matrix 'production)
-    (putprop name *last-node* 'topnode))) 
-
-(defun rating-part (pnode) (cadr pnode)) 
-
-(defun var-part (pnode) (car (cdddr pnode))) 
-
-(defun ce-var-part (pnode) (cadr (cdddr pnode))) 
-
-(defun rhs-part (pnode) (caddr (cdddr pnode))) 
-
-(defun cmp-prin nil
-  (prog nil
-    (setq *last-node* *first-node*)
-    (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
-	  ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
-	  (t (cmp-posce) (cmp-and))))) 
-
-(defun cmp-negce nil (lex) (cmp-ce)) 
-
-(defun cmp-posce nil
-  (setq *ce-count* (1+ *ce-count*))		;"plus" changed to "+" by gdw
-  (cond ((eq (peek-lex) '\{) (cmp-ce+cevar))	;"plus" changed to "+" by gdw
-	(t (cmp-ce)))) 
-
-(defun cmp-ce+cevar nil
-  (prog (z)
-    (lex)
-    (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
-	  (t (cmp-ce) (cmp-cevar)))
-    (setq z (lex))
-    (or (eq z '\}) (%error '|missing '}'| z)))) 
-
-(defun new-subnum (k)
-  (or (numberp k) (%error '|tab must be a number| k))
-  (setq *subnum* (fix k))) 
-
-(defun incr-subnum nil (setq *subnum* (1+ *subnum*))) 
-
-(defun cmp-ce nil
-  (prog (z)
-    (new-subnum 0.)
-    (setq *cur-vars* nil)
-    (setq z (lex))
-    (and (atom z)
-	 (%error '|atomic conditions are not allowed| z))
-    (prepare-sublex z)
-    la   (and (end-of-ce) (return nil))
-    (incr-subnum)
-    (cmp-element)
-    (go la))) 
-
-(defun cmp-element nil
-  (and (eq (peek-sublex) '^) (cmp-tab))
-  (cond ((eq (peek-sublex) '\{) (cmp-product))
-	(t (cmp-atomic-or-any))))
-
-(defun cmp-atomic-or-any nil
-  (cond ((eq (peek-sublex) '<<) (cmp-any))
-	(t (cmp-atomic))))
-
-(defun cmp-any nil
-  (prog (a z)
-    (sublex)
-    (setq z nil)
-    la   (cond ((end-of-ce) (%error '|missing '>>'| a)))
-    (setq a (sublex))
-    (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
-    (link-new-node (list '&any nil (current-field) z)))) 
-
-
-(defun cmp-tab nil
-  (prog (r)
-    (sublex)
-    (setq r (sublex))
-    (setq r ($litbind r))
-    (new-subnum r))) 
-
-(defun get-bind (x)
-  (prog (r)
-    (cond ((and (symbolp x) (setq r (literal-binding-of x)))
-	   (return r))
-	  (t (return nil))))) 
-
-(defun cmp-atomic nil
-  (prog (test x)
-    (setq x (peek-sublex))
-    (cond ((eq x '= ) (setq test 'eq) (sublex))
-	  ((eq x '<>) (setq test 'ne) (sublex))
-	  ((eq x '<) (setq test 'lt) (sublex))
-	  ((eq x '<=) (setq test 'le) (sublex))
-	  ((eq x '>) (setq test 'gt) (sublex))
-	  ((eq x '>=) (setq test 'ge) (sublex))
-	  ((eq x '<=>) (setq test 'xx) (sublex))
-	  (t (setq test 'eq)))
-    (cmp-symbol test))) 
-
-(defun cmp-product nil
-  (prog (save)
-    (setq save (rest-of-ce))
-    (sublex)
-    la   (cond ((end-of-ce)
-		(cond ((member '\} save :test #'equal) 
-		       (%error '|wrong contex for '}'| save))
-		      (t (%error '|missing '}'| save))))
-	       ((eq (peek-sublex) '\}) (sublex) (return nil)))
-    (cmp-atomic-or-any)
-    (go la))) 
-
-(defun cmp-symbol (test)
-  (prog (flag)
-    (setq flag t)
-    (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
-    (cond ((and flag (variablep (peek-sublex)))
-	   (cmp-var test))
-	  ((numberp (peek-sublex)) (cmp-number test))
-	  ((symbolp (peek-sublex)) (cmp-constant test))
-	  (t (%error '|unrecognized symbol| (sublex)))))) 
-
-(defun cmp-constant (test)   ;jgk inserted concatenate form
-  (or (member test '(eq ne xx))
-      (%error '|non-numeric constant after numeric predicate| (sublex)))
-  (link-new-node (list (intern (concatenate 'string
-					    "T"
-					    (symbol-name  test)
-					    "A"))
-		       nil
-		       (current-field)
-		       (sublex)))) 
-
-(defun cmp-number (test)   ;jgk inserted concatenate form
-  (link-new-node (list (intern (concatenate 'string
-					    "T"
-					    (symbol-name  test)
-;@@@ error? reported by laird fix\	    "A"))
-		       "N"))
-  nil
-  (current-field)
-  (sublex)))) 
-
-(defun current-field nil (field-name *subnum*)) 
-
-(defun field-name (num)
-  (if (< 0 num 127)
-      (svref '#(nil *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9* *c10* *c11*
-		    *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19* *c20* *c21*
-		    *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29* *c30* *c31*
-		    *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39* *c40* *c41*
-		    *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49* *c50* *c51*
-		    *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59* *c60* *c61*
-		    *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69* *c70* *c71*
-		    *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79* *c80* *c81*
-		    *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89* *c90* *c91*
-		    *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99* *c100*
-		    *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108*
-		    *c109* *c110* *c111* *c112* *c113* *c114* *c115* *c116*
-		    *c117* *c118* *c119* *c120* *c121* *c122* *c123* *c124*
-		    *c125* *c126* *c127*)
-	     num)
-      (%error '|condition is too long| (rest-of-ce))))
-
-;;; Compiling variables
-;
-;
-;
-; *cur-vars* are the variables in the condition element currently 
-; being compiled.  *vars* are the variables in the earlier condition
-; elements.  *ce-vars* are the condition element variables.  note
-; that the interpreter will not confuse condition element and regular
-; variables even if they have the same name.
-;
-; *cur-vars* is a list of triples: (name predicate subelement-number)
-; eg:		( (<x> eq 3)
-;		  (<y> ne 1)
-;		  . . . )
-;
-; *vars* is a list of triples: (name ce-number subelement-number)
-; eg:		( (<x> 3 3)
-;		  (<y> 1 1)
-;		  . . . )
-;
-; *ce-vars* is a list of pairs: (name ce-number)
-; eg:		( (ce1 1)
-;		  (<c3> 3)
-;		  . . . )
-
-(defmacro var-dope (var) `(assq ,var *vars*))
-
-(defmacro ce-var-dope (var) `(assq ,var *ce-vars*))
-
-(defun cmp-var (test)
-  (prog (old name)
-    (setq name (sublex))
-    (setq old (assq name *cur-vars*))
-    (cond ((and old (eq (cadr old) 'eq))
-	   (cmp-old-eq-var test old))
-	  ((and old (eq test 'eq)) (cmp-new-eq-var name old))
-	  (t (cmp-new-var name test))))) 
-
-(defun cmp-new-var (name test)
-  (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*))) 
-
-(defun cmp-old-eq-var (test old)  ; jgk inserted concatenate form
-  (link-new-node (list (intern (concatenate 'string
-					    "T"
-					    (symbol-name  test)
-					    "S"))
-		       nil
-		       (current-field)
-		       (field-name (caddr old))))) 
-
-
-
-(defun cmp-new-eq-var (name old)  ;jgk inserted concatenate form
-  (prog (pred next)
-    (setq *cur-vars* (delq old *cur-vars*))
-    (setq next (assq name *cur-vars*))
-    (cond (next (cmp-new-eq-var name next))
-	  (t (cmp-new-var name 'eq)))
-    (setq pred (cadr old))
-    (link-new-node (list (intern (concatenate 'string
-					      "T"
-					      (symbol-name  pred)
-					      "S"))
-			 nil
-			 (field-name (caddr old))
-			 (current-field))))) 
-
-(defun cmp-cevar nil
-  (prog (name old)
-    (setq name (lex))
-    (setq old (assq name *ce-vars*))
-    (and old
-	 (%error '|condition element variable used twice| name))
-    (setq *ce-vars* (cons (list name 0.) *ce-vars*)))) 
-
-(defun cmp-not nil (cmp-beta '&not)) 
-
-(defun cmp-nobeta nil (cmp-beta nil)) 
-
-(defun cmp-and nil (cmp-beta '&and)) 
-
-(defun cmp-beta (kind)
-  (prog (tlist vdope vname #|vpred vpos|# old)
-    (setq tlist nil)
-    la   (and (atom *cur-vars*) (go lb))
-    (setq vdope (car *cur-vars*))
-    (setq *cur-vars* (cdr *cur-vars*))
-    (setq vname (car vdope))
-    ;;  (setq vpred (cadr vdope))    Dario - commented out (unused)
-    ;;  (setq vpos (caddr vdope))
-    (setq old (assq vname *vars*))
-    (cond (old (setq tlist (add-test tlist vdope old)))
-	  ((not (eq kind '&not)) (promote-var vdope)))
-    (go la)
-    lb   (and kind (build-beta kind tlist))
-    (or (eq kind '&not) (fudge))
-    (setq *last-branch* *last-node*))) 
-
-(defun add-test (list new old) ; jgk inserted concatenate form
-  (prog (ttype lloc rloc)
-    (setq *feature-count* (1+ *feature-count*))
-    (setq ttype (intern (concatenate 'string "T"
-				     (symbol-name (cadr new))
-				     "B")))
-    (setq rloc (encode-singleton (caddr new)))
-    (setq lloc (encode-pair (cadr old) (caddr old)))
-    (return (cons ttype (cons lloc (cons rloc list)))))) 
-
-; the following two functions encode indices so that gelm can
-; decode them as fast as possible
-
-(defun encode-pair (a b)
-  (logior (ash (1- a) encode-pair-shift) (1- b))) 
-
-(defun encode-singleton (a) (1- a)) 
-
-(defun promote-var (dope)
-  (prog (vname vpred vpos new)
-    (setq vname (car dope))
-    (setq vpred (cadr dope))
-    (setq vpos (caddr dope))
-    (or (eq 'eq vpred)
-	(%error '|illegal predicate for first occurrence|
-		(list vname vpred)))
-    (setq new (list vname 0. vpos))
-    (setq *vars* (cons new *vars*)))) 
-
-(defun fudge nil
-  (mapc (function fudge*) *vars*)
-  (mapc (function fudge*) *ce-vars*)) 
-
-(defun fudge* (z)
-  (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a))))) 
-
-(defun build-beta (type tests)
-  (prog (rpred lpred lnode lef)
-    (link-new-node (list '&mem nil nil (protomem)))
-    (setq rpred *last-node*)
-    (cond ((eq type '&and)
-	   (setq lnode (list '&mem nil nil (protomem))))
-	  (t (setq lnode (list '&two nil nil))))
-    (setq lpred (link-to-branch lnode))
-    (cond ((eq type '&and) (setq lef lpred))
-	  (t (setq lef (protomem))))
-    (link-new-beta-node (list type nil lef rpred tests)))) 
-
-(defun protomem nil (list nil)) 
-
-(defun memory-part (mem-node) (car (cadddr mem-node))) 
-
-(defun encode-dope nil
-  (prog (r all z k)
-    (setq r nil)
-    (setq all *vars*)
-    la   (and (atom all) (return r))
-    (setq z (car all))
-    (setq all (cdr all))
-    (setq k (encode-pair (cadr z) (caddr z)))
-    (setq r (cons (car z) (cons k r)))
-    (go la))) 
-
-(defun encode-ce-dope nil
-  (prog (r all z k)
-    (setq r nil)
-    (setq all *ce-vars*)
-    la   (and (atom all) (return r))
-    (setq z (car all))
-    (setq all (cdr all))
-    (setq k (cadr z))
-    (setq r (cons (car z) (cons k r)))
-    (go la))) 
-
-
-
-;;; Linking the nodes
-
-(defun link-new-node (r)
-  (cond ((not (member (car r) '(&p &mem &two &and &not) :test #'equal))
-	 (setq *feature-count* (1+ *feature-count*))))
-  (setq *virtual-cnt* (1+ *virtual-cnt*))
-  (setq *last-node* (link-left *last-node* r))) 
-
-(defun link-to-branch (r)
-  (setq *virtual-cnt* (1+ *virtual-cnt*))
-  (setq *last-branch* (link-left *last-branch* r))) 
-
-(defun link-new-beta-node (r)
-  (setq *virtual-cnt* (1+ *virtual-cnt*))
-  (setq *last-node* (link-both *last-branch* *last-node* r))
-  (setq *last-branch* *last-node*)) 
-
-(defun link-left (pred succ)
-  (prog (a r)
-    (setq a (left-outs pred))
-    (setq r (find-equiv-node succ a))
-    (and r (return r))
-    (setq *real-cnt* (1+ *real-cnt*))
-    (attach-left pred succ)
-    (return succ))) 
-
-(defun link-both (left right succ)
-  (prog (a r)
-    (setq a (interq (left-outs left) (right-outs right)))
-    (setq r (find-equiv-beta-node succ a))
-    (and r (return r))
-    (setq *real-cnt* (1+ *real-cnt*))
-    (attach-left left succ)
-    (attach-right right succ)
-    (return succ))) 
-
-(defun attach-right (old new)
-  (rplaca (cddr old) (cons new (caddr old)))) 
-
-(defun attach-left (old new)
-  (rplaca (cdr old) (cons new (cadr old)))) 
-
-(defun right-outs (node) (caddr node)) 
-
-(defun left-outs (node) (cadr node)) 
-
-(defun find-equiv-node (node list)
-  (prog (a)
-    (setq a list)
-    l1   (cond ((atom a) (return nil))
-	       ((equiv node (car a)) (return (car a))))
-    (setq a (cdr a))
-    (go l1))) 
-
-(defun find-equiv-beta-node (node list)
-  (prog (a)
-    (setq a list)
-    l1   (cond ((atom a) (return nil))
-	       ((beta-equiv node (car a)) (return (car a))))
-    (setq a (cdr a))
-    (go l1))) 
-
-; do not look at the predecessor fields of beta nodes; they have to be
-; identical because of the way the candidate nodes were found
-
-(defun equiv (a b)
-  (and (eq (car a) (car b))
-       (or (eq (car a) '&mem)
-	   (eq (car a) '&two)
-	   (equal (caddr a) (caddr b)))
-       (equal (cdddr a) (cdddr b)))) 
-
-(defun beta-equiv (a b)
-  (and (eq (car a) (car b))
-       (equal (cddddr a) (cddddr b))
-       (or (eq (car a) '&and) (equal (caddr a) (caddr b))))) 
-
-; the equivalence tests are set up to consider the contents of
-; node memories, so they are ready for the build action
-
-
-
-;;; Check the RHSs of productions 
-
-
-(defun check-rhs (rhs) (mapc (function check-action) rhs))
-
-(defun check-action (x)
-  (prog (a)
-    (cond ((atom x)
-	   (%warn '|atomic action| x)
-	   (return nil)))
-    (setq a (setq *action-type* (car x)))
-    (case a
-      (bind (check-bind x))
-      (cbind (check-cbind x))
-      (make (check-make x))
-      (modify (check-modify x))
-      (remove (check-remove x))
-      (write (check-write x))	
-      (call (check-call x))		
-      (halt (check-halt x))
-      (openfile (check-openfile x))
-      (closefile (check-closefile x))
-      (default (check-default x))
-      (build (check-build x))
-      (t (%warn '|undefined rhs action| a)))))
-
-
-;(defun chg-to-write (x)
-;	(setq x (cons 'write (cdr x))))
-
-(defun check-build (z)
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (check-build-collect (cdr z)))
-
-(defun check-build-collect (args)
-  (prog (r)
-    top	(and (null args) (return nil))
-    (setq r (car args))
-    (setq args (cdr args))
-    (cond ((consp  r) (check-build-collect r))	;dtpr\consp gdw
-	  ((eq r '\\)
-	   (and (null args) (%warn '|nothing to evaluate| r))
-	   (check-rhs-value (car args))
-	   (setq args (cdr args))))
-    (go top)))
-
-(defun check-remove (z) 				;@@@ kluge by gdw
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (mapc (function check-rhs-ce-var) (cdr z))) 
-
-;(defun check-remove (z) 					;original
-   ; (and (null (cdr z)) (%warn '|needs arguments| z))
-   ;(mapc (function check-rhs-ce-var) (cdr z))) 
-
-(defun check-make (z)
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (check-change& (cdr z))) 
-
-(defun check-openfile (z)
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (check-change& (cdr z))) 
-
-(defun check-closefile (z)
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (check-change& (cdr z))) 
-
-(defun check-default (z)
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (check-change& (cdr z))) 
-
-(defun check-modify (z)
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (check-rhs-ce-var (cadr z))
-  (and (null (cddr z)) (%warn '|no changes to make| z))
-  (check-change& (cddr z))) 
-
-(defun check-write (z)				;note this works w/write
-  (and (null (cdr z)) (%warn '|needs arguments| z))
-  (check-change& (cdr z))) 
-
-(defun check-call (z)
-  (prog (f)
-    (and (null (cdr z)) (%warn '|needs arguments| z))
-    (setq f (cadr z))
-    (and (variablep f)
-	 (%warn '|function name must be a constant| z))
-    (or (symbolp f)
-	(%warn '|function name must be a symbolic atom| f))
-    (or (externalp f)
-	(%warn '|function name not declared external| f))
-    (check-change& (cddr z)))) 
-
-(defun check-halt (z)
-  (or (null (cdr z)) (%warn '|does not take arguments| z))) 
-
-(defun check-cbind (z)
-  (prog (v)
-    (or (= (length z) 2.) (%warn '|takes only one argument| z))
-    (setq v (cadr z))
-    (or (variablep v) (%warn '|takes variable as argument| z))
-    (note-ce-variable v))) 
-
-(defun check-bind (z)
-  (prog (v)
-    (or (> (length z) 1.) (%warn '|needs arguments| z))
-    (setq v (cadr z))
-    (or (variablep v) (%warn '|takes variable as argument| z))
-    (note-variable v)
-    (check-change& (cddr z)))) 
-
-
-(defun check-change& (z)
-  (prog (r tab-flag)
-    (setq tab-flag nil)
-    la   (and (atom z) (return nil))
-    (setq r (car z))
-    (setq z (cdr z))
-    (cond ((eq r '^)
-	   (and tab-flag
-		(%warn '|no value before this tab| (car z)))
-	   (setq tab-flag t)
-	   (check-tab-index (car z))
-	   (setq z (cdr z)))
-	  ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
-	  (t (setq tab-flag nil) (check-rhs-value r)))
-    (go la))) 
-
-(defun check-rhs-ce-var (v)
-  (cond ((and (not (numberp v)) (not (ce-bound? v)))
-	 (%warn '|unbound element variable| v))
-	((and (numberp v) (or (< v 1.) (> v *ce-count*)))
-	 (%warn '|numeric element designator out of bounds| v)))) 
-
-(defun check-rhs-value (x)
-  (cond ((consp  x) (check-rhs-function x))	;dtpr\consp gdw
-	(t (check-rhs-atomic x)))) 
-
-(defun check-rhs-atomic (x)
-  (and (variablep x) 
-       (not (bound? x)) 
-       (%warn '|unbound variable| x)))
-
-(defun check-rhs-function (x)
-  (prog (a)
-    (setq a (car x))
-    (cond ((eq a 'compute) (check-compute x))
-	  ((eq a 'arith) (check-compute x))
-	  ((eq a 'substr) (check-substr x))
-	  ((eq a 'accept) (check-accept x))
-	  ((eq a 'acceptline) (check-acceptline x))
-	  ((eq a 'crlf) (check-crlf x))
-	  ((eq a 'genatom) (check-genatom x))
-	  ((eq a 'litval) (check-litval x))
-	  ((eq a 'tabto) (check-tabto x))
-	  ((eq a 'rjust) (check-rjust x))
-	  ((not (externalp a))
-	   (%warn '"rhs function not declared external" a)))))
-
-(defun externalp (x)
-  ;  (cond ((symbolp x) (get x 'external-routine)) 	;) @@@
-  ;ok, I'm eliminating this temporarily @@@@
-  (cond ((symbolp x) t)
-	(t (%warn '|not a legal function name| x) nil)))
-
-
-(defun check-litval (x) 
-  (or (= (length x) 2) (%warn '|wrong number of arguments| x))
-  (check-rhs-atomic (cadr x)))
-
-(defun check-accept (x)
-  (cond ((= (length x) 1) nil)
-	((= (length x) 2) (check-rhs-atomic (cadr x)))
-	(t (%warn '|too many arguments| x))))
-
-(defun check-acceptline (x)
-  (mapc (function check-rhs-atomic) (cdr x)))
-
-(defun check-crlf (x) 
-  (check-0-args x)) 
-
-(defun check-genatom (x) (check-0-args x)) 
-
-(defun check-tabto (x)
-  (or (= (length x) 2) (%warn '|wrong number of arguments| x))
-  (check-print-control (cadr x)))
-
-(defun check-rjust (x)
-  (or (= (length x) 2) (%warn '|wrong number of arguments| x))
-  (check-print-control (cadr x)))
-
-(defun check-0-args (x)
-  (or (= (length x) 1.) (%warn '|should not have arguments| x))) 
-
-(defun check-substr (x)
-  (or (= (length x) 4.) (%warn '|wrong number of arguments| x))
-  (check-rhs-ce-var (cadr x))
-  (check-substr-index (caddr x))
-  (check-last-substr-index (cadddr x))) 
-
-(defun check-compute (x) (check-arithmetic (cdr x))) 
-
-(defun check-arithmetic (l)
-  (cond ((atom l)
-	 (%warn '|syntax error in arithmetic expression| l))
-	((atom (cdr l)) (check-term (car l)))
-	((not (member (cadr l) '(+ - * // \\)))	;"plus" changed to "+" by gdw
-	 (%warn '|unknown operator| l))
-	(t (check-term (car l)) (check-arithmetic (cddr l))))) 
-
-(defun check-term (x)
-  (cond ((consp  x) (check-arithmetic x))	;dtpr\consp gdw
-	(t (check-rhs-atomic x)))) 
-
-(defun check-last-substr-index (x)
-  (or (eq x 'inf) (check-substr-index x))) 
-
-(defun check-substr-index (x)
-  (prog (v)
-    (cond ((bound? x) (return x)))
-    (setq v ($litbind x))
-    (cond ((not (numberp v))
-	   (%warn '|unbound symbol used as index in substr| x))
-	  ((or (< v 1.) (> v 127.))
-	   (%warn '|index out of bounds in tab| x))))) 
-
-(defun check-print-control (x)
-  (prog ()
-    (cond ((bound? x) (return x)))
-    (cond ((or (not (numberp x)) (< x 1.) (> x 127.))
-	   (%warn '|illegal value for printer control| x))))) 
-
-(defun check-tab-index (x)
-  (prog (v)
-    (cond ((bound? x) (return x)))
-    (setq v ($litbind x))
-    (cond ((not (numberp v))
-	   (%warn '|unbound symbol occurs after ^| x))
-	  ((or (< v 1.) (> v 127.))
-	   (%warn '|index out of bounds after ^| x))))) 
-
-(defun note-variable (var)
-  (setq *rhs-bound-vars* (cons var *rhs-bound-vars*)))
-
-(defun bound? (var)
-  (or (member var *rhs-bound-vars*)
-      (var-dope var)))
-
-(defun note-ce-variable (ce-var)
-  (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*)))
-
-(defun ce-bound? (ce-var)
-  (or (member ce-var *rhs-bound-ce-vars*)
-      (ce-var-dope ce-var)))
diff --git a/contrib/ops/ops-io.lisp b/contrib/ops/ops-io.lisp
deleted file mode 100644
index 216c3c416a6ee22009ea3b4bf71540f4d0f19636..0000000000000000000000000000000000000000
--- a/contrib/ops/ops-io.lisp
+++ /dev/null
@@ -1,541 +0,0 @@
-;
-;************************************************************************
-;
-;	VPS2 -- Interpreter for OPS5
-;
-;
-;
-; This Common Lisp version of OPS5 is in the public domain.  It is based
-; in part on based on a Franz Lisp implementation done by Charles L. Forgy
-; at Carnegie-Mellon University, which was placed in the public domain by
-; the author in accordance with CMU policies.  This version has been
-; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
-; and Dan Kuokka.
-;
-; This code is made available is, and without warranty of any kind by the
-; authors or by Carnegie-Mellon University.
-;
-
-;;;; This file contains all the functions pertaining to I/O.
-
-(in-package "OPS")
-(shadow '(write))    ; Should get this by requiring ops-rhs
-
-
-;;; Internal global variables.
-
-(defvar *write-file*)
-(defvar *trace-file*)
-(defvar *accept-file*)
-(defvar *ppline*)
-(defvar *filters*)
-
-
-
-;;; Initialization
-
-(defun io-init ()
-  (setq *write-file* nil)
-  (setq *trace-file* nil)
-  (setq *accept-file* nil))
-
-
-
-;;; User I/O commands
-;;; Dario Giuse - rewrote the (write) function to follow OPS-5 specifications.
-;;; Michael Huhns fixed a few bugs in this rewrttien functions some years later.
-
-
-(defmacro append-string (x)
-  `(setq wrstring (concatenate 'simple-string wrstring ,x)))
-
-
-(defun ops-write (z)
-  (prog (port max k x)
-    (cond ((not *in-rhs*)
-	   (%warn '|cannot be called at top level| 'write)
-	   (return nil)))
-    ($reset)
-    (eval-args z)
-    (setq max ($parametercount))
-    (cond ((< max 1)
-	   (%warn '|write: nothing to print| z)
-	   (return nil)))
-    (setq x ($parameter 1))
-    (cond ((and (symbolp x) ($ofile x)) 
-	   (setq port ($ofile x))
-	   (setq k 2))
-	  (t
-	   (setq port (default-write-file))
-	   (setq k 1)))
-    ;; Analyze and output all the parameters (write) was passed.
-    (do* ((wrstring "")
-	  (x ($parameter k) ($parameter k))
-	  (field-width))
-	 ((> k max)
-	  (format port wrstring)
-	  (force-output))     ; Dario Giuse - added to force output
-      (incf k)
-      (case x
-	(|=== C R L F ===|
-	 (format port "~A~%" wrstring)     ; Flush the previous line
-	 (setq wrstring ""))
-	(|=== R J U S T ===|
-	 (setq field-width ($parameter k))           ; Number following (tabto)
-	 (incf k)
-	 (setq x (format nil "~A" ($parameter k)))   ; Next field to print
-	 (when (<= (length x) field-width)
-	   ;; Right-justify field
-	   (append-string (format nil "~V@A" field-width x))
-	   (incf k)))   ; Skip next field, since we printed it already
-	(|=== T A B T O ===|
-	 (setq x ($parameter k))         ; Position to tab to
-	 (incf k)
-	 (when (< x (length wrstring))
-	   ;; Flush line, start a new one
-	   (format port "~A~%" wrstring)
-	   (setq wrstring ""))
-	 (append-string (format nil "~V,1@T" (- x (length wrstring) 1))))
-	(t
-	 (append-string (format nil "~A " x)))))))
-
-
-(defun ops-openfile (z)
-  (prog (file mode id)
-    ($reset)
-    (eval-args z)
-    (cond ((not (equal ($parametercount) 3.))
-	   (%warn '|openfile: wrong number of arguments| z)
-	   (return nil)))
-    (setq id ($parameter 1))
-    (setq file ($parameter 2))
-    (setq mode ($parameter 3))
-    (cond ((not (symbolp id))
-	   (%warn '|openfile: file id must be a symbolic atom| id)
-	   (return nil))
-	  ((null id)
-	   (%warn '|openfile: 'nil' is reserved for the terminal| nil)
-	   (return nil))
-	  ((or ($ifile id)($ofile id))
-	   (%warn '|openfile: name already in use| id)
-	   (return nil)))
-;@@@	(cond ((eq mode 'in) (putprop id (infile file) 'inputfile))
-;@@@	      ((eq mode 'out) (putprop id (outfile file) 'outputfile))
-; dec 7 83 gdw added setq : is putprop needed ? )
-    (cond ((eq mode 'in) (putprop id (setq id (infile file)) 'inputfile))
-	  ((eq mode 'out) (putprop id (setq id (outfile file)) 'outputfile))
-	  (t (%warn '|openfile: illegal mode| mode)
-	     (return nil)))
-    (return nil)))
-
-
-(defun infile (f_name)
-  (open f_name :direction :input))
-
-(defun outfile (f_name)
-  (open f_name :direction :output :if-exists :new-version))
-
-(defun ops-closefile (z)
-  ($reset)
-  (eval-args z)
-  (mapc (function closefile2) (use-result-array)))
-
-(defun closefile2 (file)
-  (prog (port)
-    (cond ((not (symbolp file))
-	   (%warn '|closefile: illegal file identifier| file))
-	  ((setq port ($ifile file))
-	   (close port)
-	   (remprop file 'inputfile))
-	  ((setq port ($ofile file))
-	   (close port)
-	   (remprop file 'outputfile)))
-    (return nil)))
-
-
-(defun ops-default (z)
-  (prog (file use)
-    ($reset)
-    (eval-args z)
-    (cond ((not (equal ($parametercount) 2.))
-	   (%warn '|default: wrong number of arguments| z)
-	   (return nil)))
-    (setq file ($parameter 1))
-    (setq use ($parameter 2))
-    (cond ((not (symbolp file))
-	   (%warn '|default: illegal file identifier| file)
-	   (return nil))
-	  ((not (member use '(write accept trace) :test #'equal))
-	   (%warn '|default: illegal use for a file| use)
-	   (return nil))
-	  ((and (member use '(write trace) :test #'equal)
-		(not (null file))
-		(not ($ofile file)))
-	   (%warn '|default: file has not been opened for output| file)
-	   (return nil))
-	  ((and (equal use 'accept) 
-		(not (null file))
-		(not ($ifile file)))
-	   (%warn '|default: file has not been opened for input| file)
-	   (return nil))
-	  ((equal use 'write) (setq *write-file* file))
-	  ((equal use 'accept) (setq *accept-file* file))
-	  ((equal use 'trace) (setq *trace-file* file)))
-    (return nil)))
-
-
-(defun ops-accept (z)
-  (prog (port arg)
-    (cond ((> (length z) 1.)
-	   (%warn '|accept: wrong number of arguments| z)
-	   (return nil)))
-    (setq port *standard-input*)
-    (cond (*accept-file*
-	   (setq port ($ifile *accept-file*))
-	   (cond ((null port) 
-		  (%warn '|accept: file has been closed| *accept-file*)
-		  (return nil)))))
-    (cond ((= (length z) 1)
-	   (setq arg ($varbind (car z)))
-	   (cond ((not (symbolp arg))
-		  (%warn '|accept: illegal file name| arg)
-		  (return nil)))
-	   (setq port ($ifile arg))
-	   (cond ((null port) 
-		  (%warn '|accept: file not open for input| arg)
-		  (return nil)))))
-    (cond ((equal (peek-char t port nil "eof" ) "eof" )
-	   ($value 'end-of-file)
-	   (return nil)))
-    (flat-value (read port)))) 
-
-
-
-;;; Dario Giuse - completely changed the algorithm. It now uses one read-line
-;;; and the read-from-string.
-;;;
-(defun ops-acceptline (z)
-  (let ((port *standard-input*)
-	(def z))
-    (cond (*accept-file*
-	   (setq port ($ifile *accept-file*))
-	   (cond ((null port) 
-		  (%warn '|acceptline: file has been closed| 
-			 *accept-file*)
-		  (return-from ops-acceptline nil)))))
-    (cond ((> (length def) 0)
-	   (let ((arg ($varbind (car def))))
-	     (cond ((and (symbolp arg) ($ifile arg))
-		    (setq port ($ifile arg))
-		    (setq def (cdr def)))))))
-    (let ((line (read-line port nil 'eof)))
-      (declare (simple-string line))
-      ;; Strip meaningless characters from start and end of string.
-      (setq line (string-trim '(#\( #\) #\, #\tab #\space) line))
-      (when (equal line "")
-	(mapc (function $change) def)
-	(return-from ops-acceptline nil))
-      (setq line (concatenate 'simple-string "(" line ")"))
-      ;; Read all items from the line
-      (flat-value (read-from-string line)))))
-
-
-
-
-(defun ops-rjust (z)
-  (prog (val)
-    (cond ((not (= (length z) 1.))
-	   (%warn '|rjust: wrong number of arguments| z)
-	   (return nil)))
-    (setq val ($varbind (car z)))
-    (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
-	   (%warn '|rjust: illegal value for field width| val)
-	   (return nil)))
-    ($value '|=== R J U S T ===|)
-    ($value val)))
-
-
-(defun ops-crlf (z)
-  (cond  (z (%warn '|crlf: does not take arguments| z))
-	 (t ($value '|=== C R L F ===|))))
-
-
-(defun ops-tabto (z)
-  (prog (val)
-    (cond ((not (= (length z) 1.))
-	   (%warn '|tabto: wrong number of arguments| z)
-	   (return nil)))
-    (setq val ($varbind (car z)))
-    (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
-	   (%warn '|tabto: illegal column number| z)
-	   (return nil)))
-    ($value '|=== T A B T O ===|)
-    ($value val)))
-
-
-
-(defun do-rjust (width value port)
-  (prog (size)
-    (cond ((eq value '|=== T A B T O ===|)
-	   (%warn '|rjust cannot precede this function| 'tabto)
-	   (return nil))
-	  ((eq value '|=== C R L F ===|)
-	   (%warn '|rjust cannot precede this function| 'crlf)
-	   (return nil))
-	  ((eq value '|=== R J U S T ===|)
-	   (%warn '|rjust cannot precede this function| 'rjust)
-	   (return nil)))
-    ;original->        (setq size (flatc value (1+ width)))
-    (setq size (min value (1+ width)))  ;### KLUGE
-    (cond ((> size width)
-	   (princ '| | port)
-	   (princ value port)
-	   (return nil)))
-    ;###        (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
-    ;^^^KLUGE @@@do
-    (princ value port)))
-
-(defun do-tabto (col port)
-  (prog (pos)
-    ;### KLUGE: FLUSHES STREAM & SETS POS TO 0
-    ;OIRGINAL->	(setq pos (1+ (nwritn port)))	;hmm-takes 1 arg @@@ port
-    (finish-output port);kluge
-    (setq pos 0);kluge
-    (cond ((> pos col)
-	   (terpri port)
-	   (setq pos 1)))
-    ;###(do k (- col pos) (1- k) (not (> k 0)) (princ '| | port))
-    ;^^^KLUGE @@@do
-    (return nil)))
-
-
-(defun flat-value (x)
-  (cond ((atom x) ($value x))
-	(t (mapc (function flat-value) x)))) 
-
-
-
-;;; Printing WM
-
-(defun ops-ppwm (avlist)
-  (prog (next a)
-    (setq *filters* nil)
-    (setq next 1.)
-    loop   (and (atom avlist) (go print))
-    (setq a (car avlist))
-    (setq avlist (cdr avlist))
-    ;this must be expecting (ppwm class ^ attr ^ attr2 ...) not ^attr
-    (cond ((eq a '^)
-	   (setq next (car avlist))
-	   (setq avlist (cdr avlist))
-	   (setq next ($litbind next))
-	   (and (floatp next) (setq next (fix next)))
-	   (cond ((or (not (numberp next))
-		      (> next *size-result-array*)
-		      (> 1. next))
-		  (%warn '|illegal index after ^| next)
-		  (return nil))))
-	  ((variablep a)
-	   (%warn '|ppwm does not take variables| a)
-	   (return nil))
-	  (t (setq *filters* (cons next (cons a *filters*)))
-	     (setq next (1+ next))))
-    (go loop)
-    print (mapwm (function ppwm2))
-    (terpri)
-    (return nil))) 
-
-
-(defun default-write-file ()
-  (prog (port)
-    (setq port *standard-output*)
-    (cond (*write-file*
-	   (setq port ($ofile *write-file*))
-	   (cond ((null port) 
-		  (%warn '|write: file has been closed| *write-file*)
-		  (setq port *standard-output*)))))
-    (return port)))
-
-
-(defun trace-file ()
-  (prog (port)
-    (setq port *standard-output*)
-    (cond (*trace-file*
-	   (setq port ($ofile *trace-file*))
-	   (cond ((null port)
-		  (%warn '|trace: file has been closed| *trace-file*)
-		  (setq port *standard-output*)))))
-    (return port)))
-
-
-(defun ppwm2 (elm-tag)
-  (cond ((filter (car elm-tag))
-	 (terpri) (ppelm (car elm-tag) (default-write-file))))) 
-
-(defun filter (elm)
-  (prog (fl indx val)
-    (setq fl *filters*)
-    top  (and (atom fl) (return t))
-    (setq indx (car fl))
-    (setq val (cadr fl))
-    (setq fl (cddr fl))
-    (and (ident (nth (1- indx) elm) val) (go top))
-    (return nil))) 
-
-(defun ident (x y)
-  (cond ((eq x y) t)
-	((not (numberp x)) nil)
-	((not (numberp y)) nil)
-	((=alg x y) t)
-	(t nil))) 
-
-; the new ppelm is designed especially to handle literalize format
-; however, it will do as well as the old ppelm on other formats
-
-(defun ppelm (elm port)
-  (prog (ppdat sep val att mode lastpos)
-    (princ (creation-time elm) port)
-    (princ '|:  | port)
-    (setq mode 'vector)
-    (setq ppdat (get (car elm) 'ppdat))
-    (and ppdat (setq mode 'a-v))
-    (setq sep "(")				; ")" 
-    (setq lastpos 0)
-    (do ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
-	((atom vlist) nil)					; terminate
-      (setq val (car vlist))				; tagbody begin
-      (setq att (assoc curpos ppdat))	;should ret (curpos attr-name) 
-      (cond (att (setq att (cdr att)))	; att = (attr-name) ??
-	    (t (setq att curpos)))
-      (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
-      (cond ((or (not (null val)) (eq mode 'vector))
-	     (princ sep port)
-	     (ppval val att lastpos port)
-	     (setq sep '|    |)
-	     (setq lastpos curpos))))
-    (princ '|)| port)))
-
-(defun ppval (val att lastpos port)
-  ;  (break "in ppval")		
-  (cond ((not (equal att (1+ lastpos)))		; ok, if we got an att 
-	 (princ '^ port)
-	 (princ att port)
-	 (princ '| | port)))
-  (princ val port))
-
-
-
-;;; Printing production memory
-
-(defun ops-pm (z) (mapc (function pprule) z) (terpri) nil)
-
-(defun pprule (name)
-  (prog (matrix next lab)
-    (and (not (symbolp name)) (return nil))
-    (setq matrix (get name 'production))
-    (and (null matrix) (return nil))
-    (terpri)
-    (princ '|(p |)      ;)
-    (princ name)
-    top	(and (atom matrix) (go fin))
-    (setq next (car matrix))
-    (setq matrix (cdr matrix))
-    (setq lab nil)
-    (terpri)
-    (cond ((eq next '-)
-	   (princ '|  - |)
-	   (setq next (car matrix))
-	   (setq matrix (cdr matrix)))
-	  ((eq next '-->)
-	   (princ '|  |))
-	  ((and (eq next '{) (atom (car matrix)))
-	   (princ '|   {|)
-	   (setq lab (car matrix))
-	   (setq next (cadr matrix))
-	   (setq matrix (cdddr matrix)))
-	  ((eq next '{)
-	   (princ '|   {|)
-	   (setq lab (cadr matrix))
-	   (setq next (car matrix))
-	   (setq matrix (cdddr matrix)))
-	  (t (princ '|    |)))
-    (ppline next)
-    (cond (lab (princ '| |) (princ lab) (princ '})))
-    (go top)
-    fin	(princ '|)|)))
-
-(defun ppline (line)
-  (prog ()
-    (cond ((atom line) (princ line))
-	  (t
-	   (princ '|(|)      ;)
-	   (setq *ppline* line)
-	   (ppline2)
-	   ;(
-	   (princ '|)|)))
-    (return nil)))
-
-(defun ppline2 ()
-  (prog (needspace)
-    (setq needspace nil)
-    top  (and (atom *ppline*) (return nil))
-    (and needspace (princ '| |))
-    (cond ((eq (car *ppline*) '^) (ppattval))
-	  (t (pponlyval)))
-    (setq needspace t)
-    (go top)))
-
-(defun ppattval ()
-  (prog (att val)
-    (setq att (cadr *ppline*))
-    (setq *ppline* (cddr *ppline*))
-    (setq val (getval))
-    ;###	(cond ((> (+ (nwritn) (flatc att) (flatc val)) 76.)))
-    ;@@@ nwritn no arg
-    ;						;"plus" changed to "+" by gdw
-    ;	       (terpri)
-    ;	       (princ '|        |)
-    (princ '^)
-    (princ att)
-    (mapc (function (lambda (z) (princ '| |) (princ z))) val)))
-
-(defun pponlyval ()
-  (prog (val needspace)
-    (setq val (getval))
-    (setq needspace nil)
-    ;###	(cond ((> (+ (nwritn) (flatc val)) 76.)))
-    ;"plus" changed to "+" by gdw
-    ;	       (setq needspace nil)		;^nwritn no arg @@@
-    ;	       (terpri)
-    ;	       (princ '|        |)
-    top	(and (atom val) (return nil))
-    (and needspace (princ '| |))
-    (setq needspace t)
-    (princ (car val))
-    (setq val (cdr val))
-    (go top)))
-
-(defun getval ()
-  (prog (res v1)
-    (setq v1 (car *ppline*))
-    (setq *ppline* (cdr *ppline*))
-    (cond ((member v1 '(= <> < <= => > <=>))
-	   (setq res (cons v1 (getval))))
-	  ((eq v1 '{)
-	   (setq res (cons v1 (getupto '}))))
-	  ((eq v1 '<<)
-	   (setq res (cons v1 (getupto '>>))))
-	  ((eq v1 '//)
-	   (setq res (list v1 (car *ppline*)))
-	   (setq *ppline* (cdr *ppline*)))
-	  (t (setq res (list v1))))
-    (return res)))
-
-(defun getupto (end)
-  (prog (v)
-    (and (atom *ppline*) (return nil))
-    (setq v (car *ppline*))
-    (setq *ppline* (cdr *ppline*))
-    (cond ((eq v end) (return (list v)))
-	  (t (return (cons v (getupto end))))))) 
-
diff --git a/contrib/ops/ops-main.lisp b/contrib/ops/ops-main.lisp
deleted file mode 100644
index 7397abff24d89aa8a0ab57c84c01316a48192cb2..0000000000000000000000000000000000000000
--- a/contrib/ops/ops-main.lisp
+++ /dev/null
@@ -1,726 +0,0 @@
-;
-;************************************************************************
-;
-;	VPS2 -- Interpreter for OPS5
-;
-;
-;
-; This Common Lisp version of OPS5 is in the public domain.  It is based
-; in part on based on a Franz Lisp implementation done by Charles L. Forgy
-; at Carnegie-Mellon University, which was placed in the public domain by
-; the author in accordance with CMU policies.  This version has been
-; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
-; and Dan Kuokka.
-;
-; This code is made available is, and without warranty of any kind by the
-; authors or by Carnegie-Mellon University.
-;
-
-;;;; This file contains the top-level functions, function to literalize
-;;;; and access attributes, and functions to manage the conflict set.
-
-
-(in-package "OPS")
-
-(export '(literalize p vector-attribute strategy watch))
-
-
-;;; Global variables also used by other modules.
-
-(defvar *halt-flag*)
-(defvar *cycle-count*)
-(defvar *p-name*)
-(defvar *ptrace*)
-(defvar *wtrace*)
-
-
-;;; Global variables used in this module only.
-
-(defvar *limit-token*)
-(defvar *total-wm*)
-(defvar *max-token*)
-(defvar *total-token*)
-(defvar *brkpts*)
-(defvar *phase*)
-(defvar *break-flag*)
-(defvar *remaining-cycles*)
-(defvar *conflict-set*)
-(defvar *max-cs*)
-(defvar *total-cs*)
-(defvar *limit-cs*)
-(defvar *strategy*)
-(defvar *class-list*)
-(defvar *buckets*)
-
-
-
-(defun main-init ()
-  (setq *cycle-count* 0.)
-  (setq *p-name* nil)
-  (setq *ptrace* t)
-  (setq *wtrace* nil)
-  (setq *limit-token* 1000000.)
-  (setq *limit-cs* 1000000.)
-  (setq *total-wm* 0.)
-  (setq *total-token* (setq *max-token* 0.))
-  (setq *max-cs* (setq *total-cs* 0.))
-  (setq *conflict-set* nil)
-  (setq *strategy* 'lex)
-  (setq *buckets* 127.)		; regular OPS5 allows 64 named slots
-  (setq *class-list* nil)
-  (setq *brkpts* nil)
-  (setq *remaining-cycles* 1000000))
-
-
-
-;;;; Top level commands.
-
-
-(defmacro run (&body z)
-  `(ops-run ',z))
-
-(defmacro ppwm (&body avlist)
-  `(ops-ppwm ',avlist))
-
-(defmacro wm (&body a) 
-  `(ops-wm ',a))
-
-(defmacro pm (&body z)
-  `(ops-pm ',z))
-
-(defmacro cs (&body z)
-  `(ops-cs ',z))
-
-(defmacro matches (&body rule-list)
-  `(ops-matches ',rule-list))
-
-(defmacro strategy (&body z)
-  `(ops-strategy ',z))
-
-(defmacro watch (&body z)
-  `(ops-watch ',z))
-
-(defmacro pbreak (&body z)
-  `(ops-pbreak ',z))
-
-(defmacro excise (&body z)
-  `(ops-excise ',z))
-
-(defmacro p (&body z) 
-  `(ops-p ',z))
-
-(defmacro external (&body z) 
-  `(ops-external ',z))
-
-(defmacro literal (&body z)
-  `(ops-literal ',z))
-
-(defmacro literalize (&body z)
-  `(ops-literalize ',z))
-
-(defmacro vector-attribute (&body l)
-  `(ops-vector-attribute ',l))
-
-(defun top-level-remove (z)
-  (cond ((equal z '(*)) (process-changes nil (get-wm nil)))
-	(t (process-changes nil (get-wm z))))) 
-
-
-
-;;; Functions for run command
-
-(defun ops-run (z)
-  (cond ((atom z) (setq *remaining-cycles* 1000000.) (do-continue nil))
-	((and (atom (cdr z)) (numberp (car z)) (> (car z) 0.))
-	 (setq *remaining-cycles* (car z))
-	 (do-continue nil))
-	(t 'what?))) 
-
-
-(defun do-continue (wmi)
-  (cond (*critical*
-	 (terpri)
-	 (princ '|warning: network may be inconsistent|)))
-  (process-changes wmi nil)
-  (print-times (main))) 
-
-
-(defun process-changes (adds dels)
-  (prog (x)
-    process-deletes (and (atom dels) (go process-adds))
-    (setq x (car dels))
-    (setq dels (cdr dels))
-    (remove-from-wm x)
-    (go process-deletes)
-    process-adds (and (atom adds) (return nil))
-    (setq x (car adds))
-    (setq adds (cdr adds))
-    (add-to-wm x nil)
-    (go process-adds))) 
-
-
-(defun main nil
-  (prog (instance r)
-    (setq *halt-flag* nil)
-    (setq *break-flag* nil)
-    (setq instance nil)
-    dil  (setq *phase* 'conflict-resolution)
-    (cond (*halt-flag*
-	   (setq r '|end -- explicit halt|)
-	   (go finis))
-	  ((zerop *remaining-cycles*)
-	   (setq r '***break***)
-	   (setq *break-flag* t)
-	   (go finis))
-	  (*break-flag* (setq r '***break***) (go finis)))
-    (setq *remaining-cycles* (1- *remaining-cycles*))
-    (setq instance (conflict-resolution))
-    (cond ((not instance)
-	   (setq r '|end -- no production true|)
-	   (go finis)))
-    (setq *phase* (car instance))
-    (accum-stats)
-    (eval-rhs (car instance) (cdr instance))
-    (check-limits)
-    (and (broken (car instance)) (setq *break-flag* t))
-    (go dil)
-    finis (setq *p-name* nil)
-    (return r))) 
-
-
-(defun broken (rule) (member rule *brkpts*))
-
-
-(defun accum-stats nil
-  (setq *cycle-count* (1+ *cycle-count*))
-  (setq *total-token* (+ *total-token* *current-token*))
-  ;"plus" changed to "+" by gdw
-  (cond ((> *current-token* *max-token*)
-	 (setq *max-token* *current-token*)))
-  (setq *total-wm* (+ *total-wm* *current-wm*))	;"plus" changed to "+" by gdw
-  (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*)))) 
-
-
-(defun check-limits nil
-  (cond ((> (length *conflict-set*) *limit-cs*)
-	 (format t "~%~%conflict set size exceeded the limit of ~D after ~D~%"
-		 *limit-cs* *p-name*)
-	 (setq *halt-flag* t)))
-  (cond ((> *current-token* *limit-token*)
-	 (format t "~%~%token memory size exceeded the limit of ~D after ~D~%"
-		 *limit-token* *p-name*)
-	 (setq *halt-flag* t))))
-
-
-(defun print-times (mess)
-  (prog (cc)
-    (cond (*break-flag* (terpri) (return mess)))
-    (setq cc (+ (float *cycle-count*) 1.0e-20))
-    (terpri)
-    (princ mess)
-    (terpri)
-    (format t "~3D productions (~D // ~D nodes)~%"
-	    *pcount* *real-cnt* *virtual-cnt*)
-    (format t "~3D firings (~D rhs actions)~%"
-	    *cycle-count* *action-count*)
-    (format t "~3D mean working memory size (~D maximum)~%"
-	    (round (float *total-wm*) cc) *max-wm*)
-    (format t "~3D mean conflict set size (~D maximum)~%"
-	    (round (float *total-cs*) cc) *max-cs*)
-    (format t "~3D mean token memory size (~D maximum)~%"
-	    (round (float *total-token*) cc)
-	    *max-token*)))
-
-
-;;; Functions for strategy command
-
-(defun ops-strategy (z)
-  (cond ((atom z) *strategy*)
-	((equal z '(lex)) (setq *strategy* 'lex))
-	((equal z '(mea)) (setq *strategy* 'mea))
-	(t 'what?))) 
-
-
-;;; Functions for watch command
-
-(defun ops-watch (z)
-  (cond ((equal z '(0.))
-	 (setq *wtrace* nil)
-	 (setq *ptrace* nil)
-	 0.)
-	((equal z '(1.)) (setq *wtrace* nil) (setq *ptrace* t) 1.)
-	((equal z '(2.)) (setq *wtrace* t) (setq *ptrace* t) 2.)
-	((equal z '(3.))
-	 (setq *wtrace* t)
-	 (setq *ptrace* t)
-	 '(2. -- conflict set trace not supported))
-	((and (atom z) (null *ptrace*)) 0.)
-	((and (atom z) (null *wtrace*)) 1.)
-	((atom z) 2.)
-	(t 'what?))) 
-
-
-;;; Functions for excise command
-
-(defun ops-excise (z) (mapc (function excise-p) z))
-
-(defun excise-p (name)
-  (cond ((and (symbolp name) (get name 'topnode))
-	 (format t "~S is excised~%" name)
-	 (setq *pcount* (1- *pcount*))
-	 (remove-from-conflict-set name)
-	 (kill-node (get name 'topnode))
-	 (remprop name 'production)
-	 (remprop name 'backpointers)
-	 (remprop name 'topnode)))) 
-
-(defun kill-node (node)
-  (prog nil
-    top  (and (atom node) (return nil))
-    (rplaca node '&old)
-    (setq node (cdr node))
-    (go top))) 
-
-
-;;; Functions for external command
-
-(defun ops-external (z) (catch '!error! (external2 z))) ;jgk inverted args
-;& quoted tag
-(defun external2 (z) (mapc (function external3) z))
-
-(defun external3 (x) 
-  (cond ((symbolp x) (putprop x t 'external-routine))
-	(t (%error '|not a legal function name| x))))
-
-;;; Functions for pbreak command
-
-(defun ops-pbreak (z)
-  (cond ((atom z) (terpri) *brkpts*)
-	(t (mapc (function pbreak2) z) nil)))
-
-(defun pbreak2 (rule)
-  (cond ((not (symbolp rule)) (%warn '|illegal name| rule))
-	((not (get rule 'topnode)) (%warn '|not a production| rule))
-	((member rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*)))
-	(t (setq *brkpts* (cons rule *brkpts*)))))
-
-(defun rematm (atm list)
-  (cond ((atom list) list)
-	((eq atm (car list)) (rematm atm (cdr list)))
-	(t (cons (car list) (rematm atm (cdr list))))))
-
-
-;;; Functions for matches command
-
-(defun ops-matches (rule-list)
-  (mapc (function matches2) rule-list)
-  (terpri)) 
-
-
-(defun matches2 (p)
-  (cond ((atom p)
-	 (terpri)
-	 (terpri)
-	 (princ p)
-	 (matches3 (get p 'backpointers) 2. (ncons 1.))))) 
-
-
-(defun matches3 (nodes ce part)
-  (cond ((not (null nodes))
-	 (terpri)
-	 (princ '| ** matches for |)
-	 (princ part)
-	 (princ '| ** |)
-	 (mapc (function write-elms) (find-left-mem (car nodes)))
-	 (terpri)
-	 (princ '| ** matches for |)
-	 (princ (ncons ce))
-	 (princ '| ** |)
-	 (mapc (function write-elms) (find-right-mem (car nodes)))
-	 (matches3 (cdr nodes) (1+ ce) (cons ce part))))) 
-
-
-(defun write-elms (wme-or-count)
-  (cond ((consp  wme-or-count)	;dtpr\consp gdw
-	 (terpri)
-	 (mapc (function write-elms2) wme-or-count)))) 
-
-
-(defun write-elms2 (x)
-  (princ '|  |)
-  (princ (creation-time x)))
-
-
-(defun find-left-mem (node)
-  (cond ((eq (car node) '&and) (memory-part (caddr node)))
-	(t (car (caddr node))))) 
-
-
-(defun find-right-mem (node) (memory-part (cadddr node))) 
-
-
-;;; Function for cs command.
-
-(defun ops-cs (z)
-  (cond ((atom z) (conflict-set))
-	(t 'what?))) 
-
-
-
-;;;; Functions for literalize and related operations.
-
-(defun ops-literal (z)
-  (prog (atm val old)
-    top  (and (atom z) (return 'bound))
-    (or (eq (cadr z) '=) (return (%warn '|wrong format| z)))
-    (setq atm (car z))
-    (setq val (caddr z))
-    (setq z (cdddr z))
-    (cond ((not (numberp val))
-	   (%warn '|can bind only to numbers| val))
-	  ((or (not (symbolp atm)) (variablep atm))
-	   (%warn '|can bind only constant atoms| atm))
-	  ((and (setq old (literal-binding-of atm)) (not (equal old val)))
-	   (%warn '|attempt to rebind attribute| atm))
-	  (t (putprop atm val 'ops-bind)))
-    (go top))) 
-
-
-(defun ops-literalize (l)
-  (prog (class-name atts)
-    (setq class-name (car l))
-    (cond ((have-compiled-production)
-	   (%warn '|literalize called after p| class-name)
-	   (return nil))
-	  ((get class-name 'att-list)
-	   (%warn '|attempt to redefine class| class-name)
-	   (return nil)))
-    (setq *class-list* (cons class-name *class-list*))
-    (setq atts (remove-duplicates (cdr l)))		; ??? should this
-    ; warn of dup atts?
-    (test-attribute-names atts)
-    (mark-conflicts atts atts)
-    (putprop class-name atts 'att-list))) 
-
-(defun ops-vector-attribute (l)
-  (cond ((have-compiled-production)
-	 (%warn '|vector-attribute called after p| l))
-	(t 
-	 (test-attribute-names l)
-	 (mapc (function vector-attribute2) l)))) 
-
-(defun vector-attribute2 (att) (putprop att t 'vector-attribute))
-
-(defun is-vector-attribute (att) (get att 'vector-attribute))
-
-(defun test-attribute-names (l)
-  (mapc (function test-attribute-names2) l)) 
-
-(defun test-attribute-names2 (atm)
-  (cond ((or (not (symbolp atm)) (variablep atm))
-	 (%warn '|can bind only constant atoms| atm)))) 
-
-(defun finish-literalize nil
-  (cond ((not (null *class-list*))
-	 (mapc (function note-user-assigns) *class-list*)
-	 (mapc (function assign-scalars) *class-list*)
-	 (mapc (function assign-vectors) *class-list*)
-	 (mapc (function put-ppdat) *class-list*)
-	 (mapc (function erase-literal-info) *class-list*)
-	 (setq *class-list* nil)
-	 (setq *buckets* nil)))) 
-
-(defun have-compiled-production nil (not (zerop *pcount*))) 
-	   
-(defun put-ppdat (class)
-  (prog (al att ppdat)
-    (setq ppdat nil)
-    (setq al (get class 'att-list))
-    top  (cond ((not (atom al))
-		(setq att (car al))
-		(setq al (cdr al))
-		(setq ppdat
-		      (cons (cons (literal-binding-of att) att)
-			    ppdat))
-		(go top)))
-    (putprop class ppdat 'ppdat))) 
-
-; note-user-assigns and note-user-vector-assigns are needed only when
-; literal and literalize are both used in a program.  They make sure that
-; the assignments that are made explicitly with literal do not cause problems
-; for the literalized classes.
-
-(defun note-user-assigns (class)
-  (mapc (function note-user-assigns2) (get class 'att-list)))
-
-(defun note-user-assigns2 (att)
-  (prog (num conf buck clash)
-    (setq num (literal-binding-of att))
-    (and (null num) (return nil))
-    (setq conf (get att 'conflicts))
-    (setq buck (store-binding att num))
-    (setq clash (find-common-atom buck conf))
-    (and clash
-	 (%warn '|attributes in a class assigned the same number|
-		(cons att clash)))
-    (return nil)))
-
-(defun note-user-vector-assigns (att given needed)
-  (and (> needed given)
-       (%warn '|vector attribute assigned too small a value in literal| att)))
-
-(defun assign-scalars (class)
-  (mapc (function assign-scalars2) (get class 'att-list))) 
-
-(defun assign-scalars2 (att)
-  (prog (tlist num bucket conf)
-    (and (literal-binding-of att) (return nil))
-    (and (is-vector-attribute att) (return nil))
-    (setq tlist (buckets))
-    (setq conf (get att 'conflicts))
-    top  (cond ((atom tlist)
-		(%warn '|could not generate a binding| att)
-		(store-binding att -1.)
-		(return nil)))
-    (setq num (caar tlist))
-    (setq bucket (cdar tlist))
-    (setq tlist (cdr tlist))
-    (cond ((disjoint bucket conf) (store-binding att num))
-	  (t (go top))))) 
-
-(defun assign-vectors (class)
-  (mapc (function assign-vectors2) (get class 'att-list))) 
-
-(defun assign-vectors2 (att)
-  (prog (big conf new old need)
-    (and (not (is-vector-attribute att)) (return nil))
-    (setq big 1.)
-    (setq conf (get att 'conflicts))
-    top  (cond ((not (atom conf))
-		(setq new (car conf))
-		(setq conf (cdr conf))
-		(cond ((is-vector-attribute new)
-		       (%warn '|class has two vector attributes|
-			      (list att new)))
-		      (t (setq big (max (literal-binding-of new) big))))
-		(go top)))
-    (setq need (1+ big))			;"plus" changed to "+" by gdw
-    (setq old (literal-binding-of att))
-    (cond (old (note-user-vector-assigns att old need))
-	  (t (store-binding att need)))
-    (return nil)))
-
-(defun disjoint (la lb) (not (find-common-atom la lb))) 
-
-(defun find-common-atom (la lb)
-  (prog nil
-    top  (cond ((null la) (return nil))
-	       ((member (car la) lb) (return (car la)))
-	       (t (setq la (cdr la)) (go top))))) 
-
-(defun mark-conflicts (rem all)
-  (cond ((not (null rem))
-	 (mark-conflicts2 (car rem) all)
-	 (mark-conflicts (cdr rem) all)))) 
-
-(defun mark-conflicts2 (atm lst)
-  (prog (l)
-    (setq l lst)
-    top  (and (atom l) (return nil))
-    (conflict atm (car l))
-    (setq l (cdr l))
-    (go top))) 
-
-(defun conflict (a b)
-  (prog (old)
-    (setq old (get a 'conflicts))
-    (and (not (eq a b))
-	 (not (member b old))
-	 (putprop a (cons b old) 'conflicts)))) 
-
-;@@@ use intrinsic 
-;(defun remove-duplicates  (lst)
-   ;  (cond ((atom lst) nil)
-	    ;        ((member (car lst) (cdr lst)) (remove-duplicates (cdr lst)))
-	    ;        (t (cons (car lst) (remove-duplicates (cdr lst)))))) 
-
-(defun literal-binding-of (name) (get name 'ops-bind)) 
-
-(defun store-binding (name lit)
-  (putprop name lit 'ops-bind)
-  (add-bucket name lit)) 
-
-(defun add-bucket (name num)
-  (prog (buc)
-    (setq buc (assoc num (buckets)))
-    (and (not (member name buc))
-	 (rplacd buc (cons name (cdr buc))))
-    (return buc))) 
-
-(defun buckets nil
-  (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
-  *buckets*) 
-
-(defun make-nums (k)
-  (prog (nums)
-    (setq nums nil)
-    l    (and (< k 2.) (return nums))
-    (setq nums (cons (ncons k) nums))
-    (setq k (1- k))
-    (go l))) 
-
-(defun erase-literal-info (class)
-  (mapc (function erase-literal-info2) (get class 'att-list))
-  (remprop class 'att-list)) 
-
-(defun erase-literal-info2 (att) (remprop att 'conflicts)) 
-
-
-
-
-;;;; Functions for conflict set management and resolution.
-
-
-;;; Each conflict set element is a list of the following form:
-;;; ((p-name . data-part) (sorted wm-recency) special-case-number)
-
-(defun conflict-resolution nil
-  (prog (best len)
-    (setq len (length *conflict-set*))
-    (cond ((> len *max-cs*) (setq *max-cs* len)))
-    (setq *total-cs* (+ *total-cs* len))	;"plus" changed to "+" by gdw
-    (cond (*conflict-set*
-	   (setq best (best-of *conflict-set*))
-	   (setq *conflict-set* (delq best *conflict-set*))
-	   (return (pname-instantiation best)))
-	  (t (return nil))))) 
-
-(defun removecs (name data)
-  (prog (cr-data inst cs)
-    (setq cr-data (cons name data))
-    (setq cs *conflict-set*)
-    loop	(cond ((null cs) 
-		       (record-refract name data)
-		       (return nil)))
-    (setq inst (car cs))
-    (setq cs (cdr cs))
-    (and (not (top-levels-eq (car inst) cr-data)) (go loop))
-    (setq *conflict-set* (delq inst *conflict-set*))))
-
-(defun insertcs (name data rating)
-  (prog (instan)
-    (and (refracted name data) (return nil))
-    (setq instan (list (cons name data) (order-tags data) rating))
-    (and (atom *conflict-set*) (setq *conflict-set* nil))
-    (return (setq *conflict-set* (cons instan *conflict-set*))))) 
-
-
-(defun remove-from-conflict-set (name)
-  (prog (cs entry)
-    l1   (setq cs *conflict-set*)
-    l2   (cond ((atom cs) (return nil)))
-    (setq entry (car cs))
-    (setq cs (cdr cs))
-    (cond ((eq name (caar entry))
-	   (setq *conflict-set* (delq entry *conflict-set*))
-	   (go l1))
-	  (t (go l2))))) 
-
-(defun order-tags (dat)
-  (prog (tags)
-    (setq tags nil)
-    l1p  (and (atom dat) (go l2p))
-    (setq tags (cons (creation-time (car dat)) tags))
-    (setq dat (cdr dat))
-    (go l1p)
-    l2p  (cond ((eq *strategy* 'mea)
-		(return (cons (car tags) (dsort (cdr tags)))))
-	       (t (return (dsort tags)))))) 
-
-; destructively sort x into descending order
-
-(defun dsort (x)
-  (prog (sorted cur next cval nval)
-    (and (atom (cdr x)) (return x))
-    loop (setq sorted t)
-    (setq cur x)
-    (setq next (cdr x))
-    chek (setq cval (car cur))
-    (setq nval (car next))
-    (cond ((> nval cval)
-	   (setq sorted nil)
-	   (rplaca cur nval)
-	   (rplaca next cval)))
-    (setq cur next)
-    (setq next (cdr cur))
-    (cond ((not (null next)) (go chek))
-	  (sorted (return x))
-	  (t (go loop))))) 
-
-(defun best-of (set) (best-of* (car set) (cdr set))) 
-
-(defun best-of* (best rem)
-  (cond ((not rem) best)
-	((conflict-set-compare best (car rem))
-	 (best-of* best (cdr rem)))
-	(t (best-of* (car rem) (cdr rem))))) 
-
-(defun pname-instantiation (conflict-elem) (car conflict-elem)) 
-
-(defun order-part (conflict-elem) (cdr conflict-elem)) 
-
-(defun instantiation (conflict-elem)
-  (cdr (pname-instantiation conflict-elem))) 
-
-
-(defun conflict-set-compare (x y)
-  (prog (x-order y-order xl yl xv yv)
-    (setq x-order (order-part x))
-    (setq y-order (order-part y))
-    (setq xl (car x-order))
-    (setq yl (car y-order))
-    data (cond ((and (null xl) (null yl)) (go ps))
-	       ((null yl) (return t))
-	       ((null xl) (return nil)))
-    (setq xv (car xl))
-    (setq yv (car yl))
-    (cond ((> xv yv) (return t))
-	  ((> yv xv) (return nil)))
-    (setq xl (cdr xl))
-    (setq yl (cdr yl))
-    (go data)
-    ps   (setq xl (cdr x-order))
-    (setq yl (cdr y-order))
-    psl  (cond ((null xl) (return t)))
-    (setq xv (car xl))
-    (setq yv (car yl))
-    (cond ((> xv yv) (return t))
-	  ((> yv xv) (return nil)))
-    (setq xl (cdr xl))
-    (setq yl (cdr yl))
-    (go psl))) 
-
-
-(defun conflict-set nil
-  (prog (cnts cs p z best)
-    (setq cnts nil)
-    (setq cs *conflict-set*)
-    l1p  (and (atom cs) (go l2p))
-    (setq p (caaar cs))
-    (setq cs (cdr cs))
-    (setq z (assq p cnts))
-    (cond ((null z) (setq cnts (cons (cons p 1.) cnts)))
-	  (t (rplacd z (1+ (cdr z)))))
-    (go l1p)
-    l2p  (cond ((atom cnts)
-		(setq best (best-of *conflict-set*))
-		(terpri)
-		(return (list (caar best) 'dominates))))
-    (terpri)
-    (princ (caar cnts))
-    (cond ((> (cdar cnts) 1.)
-	   (princ '|	(|)
-		  (princ (cdar cnts))
-		  (princ '| occurrences)|)))
-    (setq cnts (cdr cnts))
-    (go l2p))) 
diff --git a/contrib/ops/ops-match.lisp b/contrib/ops/ops-match.lisp
deleted file mode 100644
index 1ae230697a2429d5de22f4b3d88c5d54d7e99ba6..0000000000000000000000000000000000000000
--- a/contrib/ops/ops-match.lisp
+++ /dev/null
@@ -1,749 +0,0 @@
-;
-;************************************************************************
-;
-;	VPS2 -- Interpreter for OPS5
-;
-;
-;
-; This Common Lisp version of OPS5 is in the public domain.  It is based
-; in part on based on a Franz Lisp implementation done by Charles L. Forgy
-; at Carnegie-Mellon University, which was placed in the public domain by
-; the author in accordance with CMU policies.  This version has been
-; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
-; and Dan Kuokka.
-;
-; This code is made available is, and without warranty of any kind by the
-; authors or by Carnegie-Mellon University.
-;
-
-;;;; This file contains the functions that match working memory
-;;;; elements against productions LHS.
-
-(in-package "OPS")
-
-
-
-;;; External global variables
-
-(defvar *current-token*)
-
-
-;;; Internal global variables
-
-(defvar *alpha-data-part*)
-(defvar *alpha-flag-part*)
-(defvar *flag-part*)
-(defvar *data-part*)
-(defvar *sendtocall*)
-(defvar *side*)
-(proclaim '(special *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
-	   *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
-	   *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
-	   *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
-	   *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
-	   *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
-	   *c60* *c61* *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69*
-	   *c70* *c71* *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79*
-	   *c80* *c81* *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89*
-	   *c90* *c91* *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99*
-	   *c100* *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108* *c109*
-	   *c110* *c111* *c112* *c113* *c114* *c115* *c116* *c117* *c118* *c119*
-	   *c120* *c121* *c122* *c123* *c124* *c125* *c126* *c127*))
-
-
-
-;;; Network interpreter
-
-
-(defun match-init ()
-  (setq *current-token* 0.))
-
-
-(defun match (flag wme)
-  (sendto flag (list wme) 'left (list *first-node*)))
-
-; note that eval-nodelist is not set up to handle building
-; productions.  would have to add something like ops4's build-flag
-
-(defun eval-nodelist (nl)
-  (prog nil
-    top  (and (not nl) (return nil))
-    (setq *sendtocall* nil)
-    (setq *last-node* (car nl))
-    (apply (caar nl) (cdar nl))
-    (setq nl (cdr nl))
-    (go top))) 
-
-(defun sendto (flag data side nl)
-  (prog nil
-    top  (and (not nl) (return nil))
-    (setq *side* side)
-    (setq *flag-part* flag)
-    (setq *data-part* data)
-    (setq *sendtocall* t)
-    (setq *last-node* (car nl))
-    (apply (caar nl) (cdar nl))
-    (setq nl (cdr nl))
-    (go top))) 
-
-; &bus sets up the registers for the one-input nodes.  note that this
-(defun &bus (outs)
-  (prog (dp)
-    (setq *alpha-flag-part* *flag-part*)
-    (setq *alpha-data-part* *data-part*)
-    (setq dp (car *data-part*))
-    (setq *c1* (car dp))
-    (setq dp (cdr dp))
-    (setq *c2* (car dp))
-    (setq dp (cdr dp))
-    (setq *c3* (car dp))
-    (setq dp (cdr dp))
-    (setq *c4* (car dp))
-    (setq dp (cdr dp))
-    (setq *c5* (car dp))
-    (setq dp (cdr dp))
-    (setq *c6* (car dp))
-    (setq dp (cdr dp))
-    (setq *c7* (car dp))
-    (setq dp (cdr dp))
-    (setq *c8* (car dp))
-    (setq dp (cdr dp))
-    (setq *c9* (car dp))
-    (setq dp (cdr dp))
-    (setq *c10* (car dp))
-    (setq dp (cdr dp))
-    (setq *c11* (car dp))
-    (setq dp (cdr dp))
-    (setq *c12* (car dp))
-    (setq dp (cdr dp))
-    (setq *c13* (car dp))
-    (setq dp (cdr dp))
-    (setq *c14* (car dp))
-    (setq dp (cdr dp))
-    (setq *c15* (car dp))
-    (setq dp (cdr dp))
-    (setq *c16* (car dp))
-    (setq dp (cdr dp))
-    (setq *c17* (car dp))
-    (setq dp (cdr dp))
-    (setq *c18* (car dp))
-    (setq dp (cdr dp))
-    (setq *c19* (car dp))
-    (setq dp (cdr dp))
-    (setq *c20* (car dp))
-    (setq dp (cdr dp))
-    (setq *c21* (car dp))
-    (setq dp (cdr dp))
-    (setq *c22* (car dp))
-    (setq dp (cdr dp))
-    (setq *c23* (car dp))
-    (setq dp (cdr dp))
-    (setq *c24* (car dp))
-    (setq dp (cdr dp))
-    (setq *c25* (car dp))
-    (setq dp (cdr dp))
-    (setq *c26* (car dp))
-    (setq dp (cdr dp))
-    (setq *c27* (car dp))
-    (setq dp (cdr dp))
-    (setq *c28* (car dp))
-    (setq dp (cdr dp))
-    (setq *c29* (car dp))
-    (setq dp (cdr dp))
-    (setq *c30* (car dp))
-    (setq dp (cdr dp))
-    (setq *c31* (car dp))
-    (setq dp (cdr dp))
-    (setq *c32* (car dp))
-    (setq dp (cdr dp))
-    (setq *c33* (car dp))
-    (setq dp (cdr dp))
-    (setq *c34* (car dp))
-    (setq dp (cdr dp))
-    (setq *c35* (car dp))
-    (setq dp (cdr dp))
-    (setq *c36* (car dp))
-    (setq dp (cdr dp))
-    (setq *c37* (car dp))
-    (setq dp (cdr dp))
-    (setq *c38* (car dp))
-    (setq dp (cdr dp))
-    (setq *c39* (car dp))
-    (setq dp (cdr dp))
-    (setq *c40* (car dp))
-    (setq dp (cdr dp))
-    (setq *c41* (car dp))
-    (setq dp (cdr dp))
-    (setq *c42* (car dp))
-    (setq dp (cdr dp))
-    (setq *c43* (car dp))
-    (setq dp (cdr dp))
-    (setq *c44* (car dp))
-    (setq dp (cdr dp))
-    (setq *c45* (car dp))
-    (setq dp (cdr dp))
-    (setq *c46* (car dp))
-    (setq dp (cdr dp))
-    (setq *c47* (car dp))
-    (setq dp (cdr dp))
-    (setq *c48* (car dp))
-    (setq dp (cdr dp))
-    (setq *c49* (car dp))
-    (setq dp (cdr dp))
-    (setq *c50* (car dp))
-    (setq dp (cdr dp))
-    (setq *c51* (car dp))
-    (setq dp (cdr dp))
-    (setq *c52* (car dp))
-    (setq dp (cdr dp))
-    (setq *c53* (car dp))
-    (setq dp (cdr dp))
-    (setq *c54* (car dp))
-    (setq dp (cdr dp))
-    (setq *c55* (car dp))
-    (setq dp (cdr dp))
-    (setq *c56* (car dp))
-    (setq dp (cdr dp))
-    (setq *c57* (car dp))
-    (setq dp (cdr dp))
-    (setq *c58* (car dp))
-    (setq dp (cdr dp))
-    (setq *c59* (car dp))
-    (setq dp (cdr dp))
-    (setq *c60* (car dp))
-    (setq dp (cdr dp))
-    (setq *c61* (car dp))
-    (setq dp (cdr dp))
-    (setq *c62* (car dp))
-    (setq dp (cdr dp))
-    (setq *c63* (car dp))
-    (setq dp (cdr dp))
-    (setq *c64* (car dp))
-    ;-------- added for 127 atr
-    (setq dp (cdr dp))
-    (setq *c65* (car dp))
-    (setq dp (cdr dp))
-    (setq *c66* (car dp))
-    (setq dp (cdr dp))
-    (setq *c67* (car dp))
-    (setq dp (cdr dp))
-    (setq *c68* (car dp))
-    (setq dp (cdr dp))
-    (setq *c69*(car dp))
-    (setq dp (cdr dp))
-    (setq *c70* (car dp))
-    (setq dp (cdr dp))
-    (setq *c71* (car dp))
-    (setq dp (cdr dp))
-    (setq *c72* (car dp))
-    (setq dp (cdr dp))
-    (setq *c73* (car dp))
-    (setq dp (cdr dp))
-    (setq *c74* (car dp))
-    (setq dp (cdr dp))
-    (setq *c75* (car dp))
-    (setq dp (cdr dp))
-    (setq *c76* (car dp))
-    (setq dp (cdr dp))
-    (setq *c77* (car dp))
-    (setq dp (cdr dp))
-    (setq *c78* (car dp))
-    (setq dp (cdr dp))
-    (setq *c79*(car dp))
-    (setq dp (cdr dp))
-    (setq *c80* (car dp))
-    (setq dp (cdr dp))
-    (setq *c81* (car dp))
-    (setq dp (cdr dp))
-    (setq *c82* (car dp))
-    (setq dp (cdr dp))
-    (setq *c83* (car dp))
-    (setq dp (cdr dp))
-    (setq *c84* (car dp))
-    (setq dp (cdr dp))
-    (setq *c85* (car dp))
-    (setq dp (cdr dp))
-    (setq *c86* (car dp))
-    (setq dp (cdr dp))
-    (setq *c87* (car dp))
-    (setq dp (cdr dp))
-    (setq *c88* (car dp))
-    (setq dp (cdr dp))
-    (setq *c89*(car dp))
-    (setq dp (cdr dp))
-    (setq *c90* (car dp))
-    (setq dp (cdr dp))
-    (setq *c91* (car dp))
-    (setq dp (cdr dp))
-    (setq *c92* (car dp))
-    (setq dp (cdr dp))
-    (setq *c93* (car dp))
-    (setq dp (cdr dp))
-    (setq *c94* (car dp))
-    (setq dp (cdr dp))
-    (setq *c95* (car dp))
-    (setq dp (cdr dp))
-    (setq *c96* (car dp))
-    (setq dp (cdr dp))
-    (setq *c97* (car dp))
-    (setq dp (cdr dp))
-    (setq *c98* (car dp))
-    (setq dp (cdr dp))
-    (setq *c99*(car dp))
-    (setq dp (cdr dp))
-    (setq *c100* (car dp))
-    (setq dp (cdr dp))
-    (setq *c101* (car dp))
-    (setq dp (cdr dp))
-    (setq *c102* (car dp))
-    (setq dp (cdr dp))
-    (setq *c103* (car dp))
-    (setq dp (cdr dp))
-    (setq *c104* (car dp))
-    (setq dp (cdr dp))
-    (setq *c105* (car dp))
-    (setq dp (cdr dp))
-    (setq *c106* (car dp))
-    (setq dp (cdr dp))
-    (setq *c107* (car dp))
-    (setq dp (cdr dp))
-    (setq *c108* (car dp))
-    (setq dp (cdr dp))
-    (setq *c109*(car dp))
-    (setq dp (cdr dp))
-    (setq *c110* (car dp))
-    (setq dp (cdr dp))
-    (setq *c111* (car dp))
-    (setq dp (cdr dp))
-    (setq *c112* (car dp))
-    (setq dp (cdr dp))
-    (setq *c113* (car dp))
-    (setq dp (cdr dp))
-    (setq *c114* (car dp))
-    (setq dp (cdr dp))
-    (setq *c115* (car dp))
-    (setq dp (cdr dp))
-    (setq *c116* (car dp))
-    (setq dp (cdr dp))
-    (setq *c117* (car dp))
-    (setq dp (cdr dp))
-    (setq *c118* (car dp))
-    (setq dp (cdr dp))
-    (setq *c119*(car dp))
-    (setq dp (cdr dp))
-    (setq *c120* (car dp))
-    (setq dp (cdr dp))
-    (setq *c121* (car dp))
-    (setq dp (cdr dp))
-    (setq *c122* (car dp))
-    (setq dp (cdr dp))
-    (setq *c123* (car dp))
-    (setq dp (cdr dp))
-    (setq *c124* (car dp))
-    (setq dp (cdr dp))
-    (setq *c125* (car dp))
-    (setq dp (cdr dp))
-    (setq *c126* (car dp))
-    (setq dp (cdr dp))
-    (setq *c127* (car dp))
-    ;(setq dp (cdr dp))
-    ;(setq *c128* (car dp))
-    ;--------
-    (eval-nodelist outs))) 
-
-(defun &any (outs register const-list)
-  (prog (z c)
-    (setq z (fast-symeval register))
-    (cond ((numberp z) (go number)))
-    symbol (cond ((null const-list) (return nil))
-		 ((eq (car const-list) z) (go ok))
-		 (t (setq const-list (cdr const-list)) (go symbol)))
-    number (cond ((null const-list) (return nil))
-		 ((and (numberp (setq c (car const-list)))
-		       (=alg c z))
-		  (go ok))
-		 (t (setq const-list (cdr const-list)) (go number)))
-    ok   (eval-nodelist outs))) 
-
-(defun teqa (outs register constant)
-  (and (eq (fast-symeval register) constant) (eval-nodelist outs))) 
-
-(defun tnea (outs register constant)
-  (and (not (eq (fast-symeval register) constant)) (eval-nodelist outs))) 
-
-(defun txxa (outs register constant)
-  (declare (ignore constant))
-  (and (symbolp (fast-symeval register)) (eval-nodelist outs))) 
-
-(defun teqn (outs register constant)
-  (prog (z)
-    (setq z (fast-symeval register))
-    (and (numberp z)
-	 (=alg z constant)
-	 (eval-nodelist outs)))) 
-
-(defun tnen (outs register constant)
-  (prog (z)
-    (setq z (fast-symeval register))
-    (and (or (not (numberp z))
-	     (not (=alg z constant)))
-	 (eval-nodelist outs)))) 
-
-(defun txxn (outs register constant)
-  (declare (ignore constant))
-  (prog (z)
-    (setq z (fast-symeval register))
-    (and (numberp z) (eval-nodelist outs)))) 
-
-(defun tltn (outs register constant)
-  (prog (z)
-    (setq z (fast-symeval register))
-    (and (numberp z)
-	 (> constant z)
-	 (eval-nodelist outs)))) 
-
-(defun tgtn (outs register constant)
-  (prog (z)
-    (setq z (fast-symeval register))
-    (and (numberp z)
-	 (> z constant)
-	 (eval-nodelist outs)))) 
-
-(defun tgen (outs register constant)
-  (prog (z)
-    (setq z (fast-symeval register))
-    (and (numberp z)
-	 (not (> constant z))
-	 (eval-nodelist outs)))) 
-
-(defun tlen (outs register constant)
-  (prog (z)
-    (setq z (fast-symeval register))
-    (and (numberp z)
-	 (not (> z constant))
-	 (eval-nodelist outs)))) 
-
-(defun teqs (outs vara varb)
-  (prog (a b)
-    (setq a (fast-symeval vara))
-    (setq b (fast-symeval varb))
-    (cond ((eq a b) (eval-nodelist outs))
-	  ((and (numberp a)
-		(numberp b)
-		(=alg a b))
-	   (eval-nodelist outs))))) 
-
-(defun tnes (outs vara varb)
-  (prog (a b)
-    (setq a (fast-symeval vara))
-    (setq b (fast-symeval varb))
-    (cond ((eq a b) (return nil))
-	  ((and (numberp a)
-		(numberp b)
-		(=alg a b))
-	   (return nil))
-	  (t (eval-nodelist outs))))) 
-
-(defun txxs (outs vara varb)
-  (prog (a b)
-    (setq a (fast-symeval vara))
-    (setq b (fast-symeval varb))
-    (cond ((and (numberp a) (numberp b)) (eval-nodelist outs))
-	  ((and (not (numberp a)) (not (numberp b)))
-	   (eval-nodelist outs))))) 
-
-(defun tlts (outs vara varb)
-  (prog (a b)
-    (setq a (fast-symeval vara))
-    (setq b (fast-symeval varb))
-    (and (numberp a)
-	 (numberp b)
-	 (> b a)
-	 (eval-nodelist outs)))) 
-
-(defun tgts (outs vara varb)
-  (prog (a b)
-    (setq a (fast-symeval vara))
-    (setq b (fast-symeval varb))
-    (and (numberp a)
-	 (numberp b)
-	 (> a b)
-	 (eval-nodelist outs)))) 
-
-(defun tges (outs vara varb)
-  (prog (a b)
-    (setq a (fast-symeval vara))
-    (setq b (fast-symeval varb))
-    (and (numberp a)
-	 (numberp b)
-	 (not (> b a))
-	 (eval-nodelist outs)))) 
-
-(defun tles (outs vara varb)
-  (prog (a b)
-    (setq a (fast-symeval vara))
-    (setq b (fast-symeval varb))
-    (and (numberp a)
-	 (numberp b)
-	 (not (> a b))
-	 (eval-nodelist outs)))) 
-
-(defun &two (left-outs right-outs)
-  (prog (fp dp)
-    (cond (*sendtocall*
-	   (setq fp *flag-part*)
-	   (setq dp *data-part*))
-	  (t
-	   (setq fp *alpha-flag-part*)
-	   (setq dp *alpha-data-part*)))
-    (sendto fp dp 'left left-outs)
-    (sendto fp dp 'right right-outs))) 
-
-(defun &mem (left-outs right-outs memory-list)
-  (prog (fp dp)
-    (cond (*sendtocall*
-	   (setq fp *flag-part*)
-	   (setq dp *data-part*))
-	  (t
-	   (setq fp *alpha-flag-part*)
-	   (setq dp *alpha-data-part*)))
-    (sendto fp dp 'left left-outs)
-    (add-token memory-list fp dp nil)
-    (sendto fp dp 'right right-outs))) 
-
-(defun &and (outs lpred rpred tests)
-  (prog (mem)
-    (cond ((eq *side* 'right) (setq mem (memory-part lpred)))
-	  (t (setq mem (memory-part rpred))))
-    (cond ((not mem) (return nil))
-	  ((eq *side* 'right) (and-right outs mem tests))
-	  (t (and-left outs mem tests))))) 
-
-(defun and-left (outs mem tests)
-  (prog (fp dp memdp tlist tst lind rind res)
-    (setq fp *flag-part*)
-    (setq dp *data-part*)
-    fail (and (null mem) (return nil))
-    (setq memdp (car mem))
-    (setq mem (cdr mem))
-    (setq tlist tests)
-    tloop (and (null tlist) (go succ))
-    (setq tst (car tlist))
-    (setq tlist (cdr tlist))
-    (setq lind (car tlist))
-    (setq tlist (cdr tlist))
-    (setq rind (car tlist))
-    (setq tlist (cdr tlist))
-    ;###        (comment the next line differs in and-left & -right)
-    (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
-    (cond (res (go tloop))
-	  (t (go fail)))
-    succ 
-    ;###	(comment the next line differs in and-left & -right)
-    (sendto fp (cons (car memdp) dp) 'left outs)
-    (go fail))) 
-
-(defun and-right (outs mem tests)
-  (prog (fp dp memdp tlist tst lind rind res)
-    (setq fp *flag-part*)
-    (setq dp *data-part*)
-    fail (and (null mem) (return nil))
-    (setq memdp (car mem))
-    (setq mem (cdr mem))
-    (setq tlist tests)
-    tloop (and (null tlist) (go succ))
-    (setq tst (car tlist))
-    (setq tlist (cdr tlist))
-    (setq lind (car tlist))
-    (setq tlist (cdr tlist))
-    (setq rind (car tlist))
-    (setq tlist (cdr tlist))
-    ;###        (comment the next line differs in and-left & -right)
-    (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
-    (cond (res (go tloop))
-	  (t (go fail)))
-    succ 
-    ;###        (comment the next line differs in and-left & -right)
-    (sendto fp (cons (car dp) memdp) 'right outs)
-    (go fail))) 
-
-
-(defun teqb (new eqvar)
-  (cond ((eq new eqvar) t)
-	((not (numberp new)) nil)
-	((not (numberp eqvar)) nil)
-	((=alg new eqvar) t)
-	(t nil))) 
-
-(defun tneb (new eqvar)
-  (cond ((eq new eqvar) nil)
-	((not (numberp new)) t)
-	((not (numberp eqvar)) t)
-	((=alg new eqvar) nil)
-	(t t))) 
-
-(defun tltb (new eqvar)
-  (cond ((not (numberp new)) nil)
-	((not (numberp eqvar)) nil)
-	((> eqvar new) t)
-	(t nil))) 
-
-(defun tgtb (new eqvar)
-  (cond ((not (numberp new)) nil)
-	((not (numberp eqvar)) nil)
-	((> new eqvar) t)
-	(t nil))) 
-
-(defun tgeb (new eqvar)
-  (cond ((not (numberp new)) nil)
-	((not (numberp eqvar)) nil)
-	((not (> eqvar new)) t)
-	(t nil))) 
-
-(defun tleb (new eqvar)
-  (cond ((not (numberp new)) nil)
-	((not (numberp eqvar)) nil)
-	((not (> new eqvar)) t)
-	(t nil))) 
-
-(defun txxb (new eqvar)
-  (cond ((numberp new)
-	 (cond ((numberp eqvar) t)
-	       (t nil)))
-	(t
-	 (cond ((numberp eqvar) nil)
-	       (t t))))) 
-
-
-(defun &p (rating name var-dope ce-var-dope rhs)
-  (declare (ignore var-dope ce-var-dope rhs))
-  (prog (fp dp)
-    (cond (*sendtocall*
-	   (setq fp *flag-part*)
-	   (setq dp *data-part*))
-	  (t
-	   (setq fp *alpha-flag-part*)
-	   (setq dp *alpha-data-part*)))
-    (and (member fp '(nil old)) (removecs name dp))
-    (and fp (insertcs name dp rating)))) 
-
-(defun &old (a b c d e)
-  (declare (ignore a b c d e))
-  nil) 
-
-(defun &not (outs lmem rpred tests)
-  (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil)
-	((eq *side* 'right) (not-right outs (car lmem) tests))
-	(t (not-left outs (memory-part rpred) tests lmem)))) 
-
-(defun not-left (outs mem tests own-mem)
-  (prog (fp dp memdp tlist tst lind rind res c)
-    (setq fp *flag-part*)
-    (setq dp *data-part*)
-    (setq c 0.)
-    fail (and (null mem) (go fin))
-    (setq memdp (car mem))
-    (setq mem (cdr mem))
-    (setq tlist tests)
-    tloop (and (null tlist) (setq c (1+ c)) (go fail))
-    (setq tst (car tlist))
-    (setq tlist (cdr tlist))
-    (setq lind (car tlist))
-    (setq tlist (cdr tlist))
-    (setq rind (car tlist))
-    (setq tlist (cdr tlist))
-    ;###        (comment the next line differs in not-left & -right)
-    (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
-    (cond (res (go tloop))
-	  (t (go fail)))
-    fin  (add-token own-mem fp dp c)
-    (and (== c 0.) (sendto fp dp 'left outs)))) 
-
-(defun not-right (outs mem tests)
-  (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
-    (setq fp *flag-part*)
-    (setq dp *data-part*)
-    (cond ((not fp) (setq inc -1.) (setq newfp 'new))
-	  ((eq fp 'new) (setq inc 1.) (setq newfp nil))
-	  (t (return nil)))
-    fail (and (null mem) (return nil))
-    (setq memdp (car mem))
-    (setq newc (cadr mem))
-    (setq tlist tests)
-    tloop (and (null tlist) (go succ))
-    (setq tst (car tlist))
-    (setq tlist (cdr tlist))
-    (setq lind (car tlist))
-    (setq tlist (cdr tlist))
-    (setq rind (car tlist))
-    (setq tlist (cdr tlist))
-    ;###        (comment the next line differs in not-left & -right)
-    (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
-    (cond (res (go tloop))
-	  (t (setq mem (cddr mem)) (go fail)))
-    succ (setq newc (+ inc newc))		;"plus" changed to "+" by gdw
-    (rplaca (cdr mem) newc)
-    (cond ((or (and (== inc -1.) (== newc 0.))
-	       (and (== inc 1.) (== newc 1.)))
-	   (sendto newfp memdp 'right outs)))
-    (setq mem (cddr mem))
-    (go fail))) 
-
-
-;;; Node memories
-
-
-(defun add-token (memlis flag data-part num)
-  (prog (was-present)
-    (cond ((eq flag 'new)
-	   (setq was-present nil)
-	   (real-add-token memlis data-part num))
-	  ((not flag) 
-	   (setq was-present (remove-old memlis data-part num)))
-	  ((eq flag 'old) (setq was-present t)))
-    (return was-present))) 
-
-(defun real-add-token (lis data-part num)
-  (setq *current-token* (1+ *current-token*))
-  (cond (num (rplaca lis (cons num (car lis)))))
-  (rplaca lis (cons data-part (car lis)))) 
-
-(defun remove-old (lis data num)
-  (cond (num (remove-old-num lis data))
-	(t (remove-old-no-num lis data)))) 
-
-(defun remove-old-num (lis data)
-  (prog (m next last)
-    (setq m (car lis))
-    (cond ((atom m) (return nil))
-	  ((top-levels-eq data (car m))
-	   (setq *current-token* (1- *current-token*))
-	   (rplaca lis (cddr m))
-	   (return (car m))))
-    (setq next m)
-    loop (setq last next)
-    (setq next (cddr next))
-    (cond ((atom next) (return nil))
-	  ((top-levels-eq data (car next))
-	   (rplacd (cdr last) (cddr next))
-	   (setq *current-token* (1- *current-token*))
-	   (return (car next)))
-	  (t (go loop))))) 
-
-(defun remove-old-no-num (lis data)
-  (prog (m next last)
-    (setq m (car lis))
-    (cond ((atom m) (return nil))
-	  ((top-levels-eq data (car m))
-	   (setq *current-token* (1- *current-token*))
-	   (rplaca lis (cdr m))
-	   (return (car m))))
-    (setq next m)
-    loop (setq last next)
-    (setq next (cdr next))
-    (cond ((atom next) (return nil))
-	  ((top-levels-eq data (car next))
-	   (rplacd last (cdr next))
-	   (setq *current-token* (1- *current-token*))
-	   (return (car next)))
-	  (t (go loop))))) 
diff --git a/contrib/ops/ops-rhs.lisp b/contrib/ops/ops-rhs.lisp
deleted file mode 100644
index 7b8de9bd75d23bc8e1009ee60734ec0922f0fcf9..0000000000000000000000000000000000000000
--- a/contrib/ops/ops-rhs.lisp
+++ /dev/null
@@ -1,646 +0,0 @@
-;
-;************************************************************************
-;
-;	VPS2 -- Interpreter for OPS5
-;
-;
-;
-; This Common Lisp version of OPS5 is in the public domain.  It is based
-; in part on based on a Franz Lisp implementation done by Charles L. Forgy
-; at Carnegie-Mellon University, which was placed in the public domain by
-; the author in accordance with CMU policies.  This version has been
-; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
-; and Dan Kuokka.
-;
-; This code is made available is, and without warranty of any kind by the
-; authors or by Carnegie-Mellon University.
-;
-
-;;;; This file contains all the functions necessary for RHS actions
-;;;; including $actions.
-
-(in-package "OPS")
-(shadow '(remove write))
-(export '(remove write make modify crlf))
-
-
-(proclaim '(special *ptrace* *cycle-count* *halt-flag* *wtrace*))
-
-
-;;; External global variables
-
-(defvar *size-result-array*)
-(defvar *in-rhs*)
-(defvar *current-wm*)
-(defvar *max-wm*)
-(defvar *action-count*)
-(defvar *critical*)
-
-
-;;; Internal global variables
-
-(defvar *wmpart-list*)
-(defvar *wm-filter*)
-(defvar *wm*)
-(defvar *old-wm*)
-(defvar *result-array*)
-(defvar *variable-memory*)
-(defvar *last*)
-(defvar *max-index*)
-(defvar *next-index*)
-(defvar *data-matched*)
-(defvar *ce-variable-memory*)
-(defvar *rest*)
-(defvar *build-trace*)
-
-
-;;;; Functions for RHS evaluation
-
-(defun rhs-init ()
-  ; if the size of result-array changes, change the line in i-g-v which
-  ; sets the value of *size-result-array*
-  (setq *size-result-array* 255.)                             ;255 /256 set by gdw
-  (setq *result-array* (make-array 256 :initial-element nil))  ;jgk
-  (setq *in-rhs* nil)
-  (setq *build-trace* nil)
-  (setq *max-wm* (setq *current-wm* 0.))
-  (setq *action-count* 0.)
-  (setq *critical* nil)
-  (setq *wmpart-list* nil))
-
-
-(defun eval-rhs (pname data)
-  (prog (node port)
-    (cond (*ptrace*
-	   (setq port (trace-file))
-	   (terpri port)
-	   (princ *cycle-count* port)
-	   (princ '|. | port)
-	   (princ pname port)
-	   (time-tag-print data port)))
-    (setq *data-matched* data)
-    (setq *p-name* pname)
-    (setq *last* nil)
-    (setq node (get pname 'topnode))
-    (init-var-mem (var-part node))
-    (init-ce-var-mem (ce-var-part node))
-    (begin-record pname data)
-    (setq *in-rhs* t)
-    (eval (rhs-part node))
-    (setq *in-rhs* nil)
-    (end-record))) 
-
-
-(defun eval-args (z)
-  (prog (r)
-    (rhs-tab 1.)
-    la   (and (atom z) (return nil))
-    (setq r (car z))
-    (setq z (cdr z))
-    (cond ((EQ R '^)
-	   (RHS-tab (car z))
-	   (setq r (cadr z))
-	   (setq z (cddr z))))
-    (cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
-	  (t ($change r)))
-    (go la))) 
-
-
-
-;;;; RHS actions
-;;;; Some of these can be called at the top level.
-
-(defmacro make (&body z)
-  `(ops-make ',z))
-
-(defmacro remove (&body z)
-  `(ops-remove ',z))
-
-(defmacro modify (&body z)
-  `(ops-modify ',z))
-
-(defmacro openfile (&body z)
-  `(ops-openfile ',z))
-
-(defmacro closefile (&body z)
-  `(ops-closefile ',z))
-
-(defmacro default (&body z)
-  `(ops-default ',z))
-
-(defmacro write (&body z)
-  `(ops-write ',z))
-
-(defmacro crlf (&body z)
-  `(ops-crlf ',z))
-
-(defmacro tabto (&body z)
-  `(ops-tabto ',z))
-
-(defmacro rjust (&body z)
-  `(ops-rjust ',z))
-
-(defmacro call (&body z)
-  `(ops-call ',z))
-
-(defmacro bind (&body z)
-  `(ops-bind ',z))
-
-(defmacro cbind (&body z)
-  `(ops-cbind ',z))
-
-(defmacro build (&body z)
-  `(ops-build ',z))
-
-(defmacro substr (&body l)
-  `(ops-substr ',l))
-
-(defmacro compute (&body z)
-  `(ops-compute ',z))
-
-(defmacro litval (&body z)
-  `(ops-litval ',z))
-
-(defmacro accept (&body z)
-  `(ops-accept ',z))
-
-(defmacro acceptline (&body z)
-  `(ops-acceptline ',z))
-
-(defmacro arith (&body z)
-  `(ops-arith ',z))
-
-
-(defun ops-make (z)
-  (prog nil
-    ($reset)
-    (eval-args z)
-    ($assert))) 
-
-(defun ops-remove (z)
-  (prog (old)
-    (and (not *in-rhs*)(return (top-level-remove z)))
-    top  (and (atom z) (return nil))
-    (setq old (get-ce-var-bind (car z)))
-    (cond ((null old)
-	   (%warn '|remove: argument not an element variable| (car z))
-	   (return nil)))
-    (remove-from-wm old)
-    (setq z (cdr z))
-    (go top))) 
-
-(defun ops-modify (z)
-  (prog (old)
-    (cond ((not *in-rhs*)
-	   (%warn '|cannot be called at top level| 'modify)
-	   (return nil)))
-    (setq old (get-ce-var-bind (car z)))
-    (cond ((null old)
-	   (%warn '|modify: first argument must be an element variable|
-		  (car z))
-	   (return nil)))
-    (remove-from-wm old)
-    (setq z (cdr z))
-    ($reset)
-    copy (and (atom old) (go fin))
-    ($change (car old))
-    (setq old (cdr old))
-    (go copy)
-    fin  (eval-args z)
-    ($assert))) 
-
-(defun ops-bind (z)
-  (prog (val)
-    (cond ((not *in-rhs*)
-	   (%warn '|cannot be called at top level| 'bind)
-	   (return nil)))
-    (cond ((< (length z) 1.)
-	   (%warn '|bind: wrong number of arguments to| z)
-	   (return nil))
-	  ((not (symbolp (car z)))
-	   (%warn '|bind: illegal argument| (car z))
-	   (return nil))
-	  ((= (length z) 1.) (setq val (gensym)))
-	  (t ($reset)
-	     (eval-args (cdr z))
-	     (setq val ($parameter 1.))))
-    (make-var-bind (car z) val))) 
-
-(defun ops-cbind (z)
-  (cond ((not *in-rhs*)
-	 (%warn '|cannot be called at top level| 'cbind))
-	((not (= (length z) 1.))
-	 (%warn '|cbind: wrong number of arguments| z))
-	((not (symbolp (car z)))
-	 (%warn '|cbind: illegal argument| (car z)))
-	((null *last*)
-	 (%warn '|cbind: nothing added yet| (car z)))
-	(t (make-ce-var-bind (car z) *last*)))) 
-
-
-(defun ops-call (z)
-  (prog (f)
-    (setq f (car z))
-    ($reset)
-    (eval-args (cdr z))
-    (funcall f))) 
-
-
-(defun halt nil 
-  (cond ((not *in-rhs*)
-	 (%warn '|cannot be called at top level| 'halt))
-	(t (setq *halt-flag* t)))) 
-
-(defun ops-build (z)
-  (prog (r)
-    (cond ((not *in-rhs*)
-	   (%warn '|cannot be called at top level| 'build)
-	   (return nil)))
-    ($reset)
-    (build-collect z)
-    (setq r (unflat (use-result-array)))
-    (and *build-trace* (funcall *build-trace* r))
-    (compile-production (car r) (cdr r)))) 
-
-(defun ops-compute (z) ($value (ari z))) 
-
-; arith is the obsolete form of compute
-(defun ops-arith (z) ($value (ari z))) 
-
-(defun ari (x)
-  (cond ((atom x)
-	 (%warn '|bad syntax in arithmetic expression | x)
-	 0.)
-	((atom (cdr x)) (ari-unit (car x)))
-	((eq (cadr x) '+)
-	 (+ (ari-unit (car x)) (ari (cddr x))))
-	;"plus" changed to "+" by gdw
-	((eq (cadr x) '-)
-	 (- (ari-unit (car x)) (ari (cddr x))))
-	((eq (cadr x) '*)
-	 (* (ari-unit (car x)) (ari (cddr x))))
-	((eq (cadr x) '//)
-	 (floor (ari-unit (car x)) (ari (cddr x))))   ;@@@ quotient? /
-	;@@@ kluge only works for integers
-	;@@@ changed to floor by jcp (from round)
-	((eq (cadr x) '\\)
-	 (mod (fix (ari-unit (car x))) (fix (ari (cddr x)))))
-	(t (%warn '|bad syntax in arithmetic expression | x) 0.))) 
-
-(defun ari-unit (a)
-  (prog (r)
-    (cond ((consp  a) (setq r (ari a)))	;dtpr\consp gdw
-	  (t (setq r ($varbind a))))
-    (cond ((not (numberp r))
-	   (%warn '|bad value in arithmetic expression| a)
-	   (return 0.))
-	  (t (return r))))) 
-
-(defun ops-substr (l)
-  (prog (k elm start end)
-    (cond ((not (= (length l) 3.))
-	   (%warn '|substr: wrong number of arguments| l)
-	   (return nil)))
-    (setq elm (get-ce-var-bind (car l)))
-    (cond ((null elm)
-	   (%warn '|first argument to substr must be a ce var|
-		  l)
-	   (return nil)))
-    (setq start ($varbind (cadr l)))
-    (setq start ($litbind start))
-    (cond ((not (numberp start))
-	   (%warn '|second argument to substr must be a number|
-		  l)
-	   (return nil)))
-;###	(comment |if a variable is bound to INF, the following|
-;	 |will get the binding and treat it as INF is|
-;	 |always treated.  that may not be good|)
-    (setq end ($varbind (caddr l)))
-    (cond ((eq end 'inf) (setq end (length elm))))
-    (setq end ($litbind end))
-    (cond ((not (numberp end))
-	   (%warn '|third argument to substr must be a number|
-		  l)
-	   (return nil)))
-;###	(comment |this loop does not check for the end of elm|
-;         |instead it relies on cdr of nil being nil|
-;         |this may not work in all versions of lisp|)
-    (setq k 1.)
-    la   (cond ((> k end) (return nil))
-	       ((not (< k start)) ($value (car elm))))
-    (setq elm (cdr elm))
-    (setq k (1+ k))
-    (go la))) 
-
-(defun genatom nil ($value (gensym))) 
-
-(defun ops-litval (z)
-  (prog (r)
-    (cond ((not (= (length z) 1.))
-	   (%warn '|litval: wrong number of arguments| z)
-	   ($value 0) 
-	   (return nil))
-	  ((numberp (car z)) ($value (car z)) (return nil)))
-    (setq r ($litbind ($varbind (car z))))
-    (cond ((numberp r) ($value r) (return nil)))
-    (%warn '|litval: argument has no literal binding| (car z))
-    ($value 0)))
-
-
-
-; rhs-tab implements the tab ('^') function in the rhs.  it has
-; four responsibilities:
-;	- to move the array pointers
-;	- to watch for tabbing off the left end of the array
-;	  (ie, to watch for pointers less than 1)
-;	- to watch for tabbing off the right end of the array
-;	- to write nil in all the slots that are skipped
-; the last is necessary if the result array is not to be cleared
-; after each use; if rhs-tab did not do this, $reset
-; would be much slower.
-
-(defun rhs-tab (z) ($tab ($varbind z)))
-
-
-(defun time-tag-print (data port)
-  (cond ((not (null data))
-	 (time-tag-print (cdr data) port)
-	 (princ '| | port)
-	 (princ (creation-time (car data)) port))))
-
-(defun init-var-mem (vlist)
-  (prog (v ind r)
-    (setq *variable-memory* nil)
-    top  (and (atom vlist) (return nil))
-    (setq v (car vlist))
-    (setq ind (cadr vlist))
-    (setq vlist (cddr vlist))
-    (setq r (gelm *data-matched* ind))
-    (setq *variable-memory* (cons (cons v r) *variable-memory*))
-    (go top))) 
-
-(defun init-ce-var-mem (vlist)
-  (prog (v ind r)
-    (setq *ce-variable-memory* nil)
-    top  (and (atom vlist) (return nil))
-    (setq v (car vlist))
-    (setq ind (cadr vlist))
-    (setq vlist (cddr vlist))
-    (setq r (ce-gelm *data-matched* ind))
-    (setq *ce-variable-memory*
-	  (cons (cons v r) *ce-variable-memory*))
-    (go top))) 
-
-(defun make-ce-var-bind (var elem)
-  (setq *ce-variable-memory*
-	(cons (cons var elem) *ce-variable-memory*))) 
-
-(defun make-var-bind (var elem)
-  (setq *variable-memory* (cons (cons var elem) *variable-memory*))) 
-
-(defun get-ce-var-bind (x)
-  (prog (r)
-    (cond ((numberp x) (return (get-num-ce x))))
-    (setq r (assq x *ce-variable-memory*))
-    (cond (r (return (cdr r)))
-	  (t (return nil))))) 
-
-(defun get-num-ce (x)
-  (prog (r l d)
-    (setq r *data-matched*)
-    (setq l (length r))
-    (setq d (- l x))
-    (and (> 0. d) (return nil))
-    la   (cond ((null r) (return nil))
-	       ((> 1. d) (return (car r))))
-    (setq d (1- d))
-    (setq r (cdr r))
-    (go la))) 
-
-
-(defun build-collect (z)
-  (prog (r)
-    la   (and (atom z) (return nil))
-    (setq r (car z))
-    (setq z (cdr z))
-    (cond ((consp  r)	;dtpr\consp gdw
-	   ($value '\()
-		   (build-collect r)
-		   ($value '\)))
-	  ((eq r '\\) ($change (car z)) (setq z (cdr z)))
-	  (t ($value r)))
-    (go la))) 
-
-(defun unflat (x) (setq *rest* x) (unflat*)) 
-
-(defun unflat* nil
-  (prog (c)
-    (cond ((atom *rest*) (return nil)))
-    (setq c (car *rest*))
-    (setq *rest* (cdr *rest*))
-    (cond ((eq c '\() (return (cons (unflat*) (unflat*))))
-	   ((eq c '\)) (return nil))
-	  (t (return (cons c (unflat*))))))) 
-
-
-
-;;;; $Functions.
-;;;; These functions provide an interface to the result array.
-;;;; The result array is used to organize attribute values into their
-;;;; correct slot.
-
-(defun $litbind (x)
-  (prog (r)
-    (cond ((and (symbolp x) (setq r (literal-binding-of x)))
-	   (return r))
-	  (t (return x))))) 
-
-(defun $varbind (x)
-  (prog (r)
-    (and (not *in-rhs*) (return x))
-    (setq r (assq x *variable-memory*))
-    (cond (r (return (cdr r)))
-	  (t (return x))))) 
-
-(defun $change (x)
-  (prog nil
-    (cond ((consp  x) (eval-function x))	;dtpr\consp gdw
-	  (t ($value ($varbind x)))))) 
-
-(defun $reset nil
-  (setq *max-index* 0.)
-  (setq *next-index* 1.)) 
-
-(defun $tab (z)
-  (prog (edge next)
-    (setq next ($litbind z))
-    (and (floatp next) (setq next (fix next)))
-    (cond ((or (not (numberp next)) 
-	       (> next *size-result-array*)
-	       (> 1. next))				; ( '| |)
-	   (%warn '|illegal index after ^| next)
-	   (return *next-index*)))
-    (setq edge (- next 1.))
-    (cond ((> *max-index* edge) (go ok)))
-    clear (cond ((== *max-index* edge) (go ok)))
-    (putvector *result-array* edge nil)
-    (setq edge (1- edge))
-    (go clear)
-    ok   (setq *next-index* next)
-    (return next))) 
-
-(defun $value (v)
-  (cond ((> *next-index* *size-result-array*)
-	 (%warn '|index too large| *next-index*))
-	(t
-	 (and (> *next-index* *max-index*)
-	      (setq *max-index* *next-index*))
-	 (putvector *result-array* *next-index* v)
-	 (setq *next-index* (1+ *next-index*))))) 
-
-(defun $assert nil
-  (setq *last* (use-result-array))
-  (add-to-wm *last* nil))
-
-(defun $parametercount nil *max-index*)
-
-(defun $parameter (k)
-  (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
-	 (%warn '|illegal parameter number | k)
-	 nil)
-	((> k *max-index*) nil)
-	(t (getvector *result-array* k))))
-
-(defun $ifile (x) 
-  (cond ((symbolp x) (get x 'inputfile))
-	(t nil)))
-
-(defun $ofile (x) 
-  (cond ((symbolp x) (get x 'outputfile))
-	(t nil)))
-
-
-;;; Use-result-array returns the contents of the result array as a list.
-
-(defun use-result-array nil
-  (prog (k r)
-    (setq k *max-index*)
-    (setq r nil)
-    top  (and (== k 0.) (return r))
-    (setq r (cons (getvector *result-array* k) r))
-    (setq k (1- k))
-    (go top))) 
-
-
-(defun eval-function (form)
-  (cond ((not *in-rhs*)
-	 (%warn '|functions cannot be used at top level| (car form)))
-	(t (eval form))))
-
-
-
-;;;; WM maintaining functions
-
-;;; The order of operations in the following two functions is critical.
-;;; add-to-wm order: (1) change wm (2) record change (3) match 
-;;; remove-from-wm order: (1) record change (2) match (3) change wm
-;;; (back will not restore state properly unless wm changes are recorded
-;;; before the cs changes that they cause)  (match will give errors if 
-;;; the thing matched is not in wm at the time)
-
-(defun add-to-wm (wme override)
-  (prog (fa z part timetag port)
-    (setq *critical* t)
-    (setq *current-wm* (1+ *current-wm*))
-    (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
-    (setq *action-count* (1+ *action-count*))
-    (setq fa (wm-hash wme))
-    (or (member fa *wmpart-list*)
-	(setq *wmpart-list* (cons fa *wmpart-list*)))
-    (setq part (get fa 'wmpart*))
-    (cond (override (setq timetag override))
-	  (t (setq timetag *action-count*)))
-    (setq z (cons wme timetag))
-    (putprop fa (cons z part) 'wmpart*)
-    (record-change '=>wm *action-count* wme)
-    (match 'new wme)
-    (setq *critical* nil)
-    (cond ((and *in-rhs* *wtrace*)
-	   (setq port (trace-file))
-	   (terpri port)
-	   (princ '|=>wm: | port)
-	   (ppelm wme port))))) 
-
-;;; remove-from-wm uses eq, not equal to determine if wme is present
-
-(defun remove-from-wm (wme)
-  (prog (fa z part timetag port)
-    (setq fa (wm-hash wme))
-    (setq part (get fa 'wmpart*))
-    (setq z (assq wme part))
-    (or z (return nil))
-    (setq timetag (cdr z))
-    (cond ((and *wtrace* *in-rhs*)
-	   (setq port (trace-file))
-	   (terpri port)
-	   (princ '|<=wm: | port)
-	   (ppelm wme port)))
-    (setq *action-count* (1+ *action-count*))
-    (setq *critical* t)
-    (setq *current-wm* (1- *current-wm*))
-    (record-change '<=wm timetag wme)
-    (match nil wme)
-    (putprop fa (delq z part) 'wmpart*)
-    (setq *critical* nil))) 
-
-;;; mapwm maps down the elements of wm, applying fn to each element
-;;; each element is of form (datum . creation-time)
-
-(defun mapwm (fn)
-  (prog (wmpl part)
-    (setq wmpl *wmpart-list*)
-    lab1 (cond ((atom wmpl) (return nil)))
-    (setq part (get (car wmpl) 'wmpart*))
-    (setq wmpl (cdr wmpl))
-    (mapc fn part)
-    (go lab1))) 
-
-(defun ops-wm (a) 
-  (mapc (function (lambda (z) (terpri) (ppelm z *standard-output*))) 
-	(get-wm a))
-  nil) 
-
-(defun creation-time (wme)
-  (cdr (assq wme (get (wm-hash wme) 'wmpart*)))) 
-
-
-(defun get-wm (z)
-  (setq *wm-filter* z)
-  (setq *wm* nil)
-  (mapwm (function get-wm2))
-  (prog2 nil *wm* (setq *wm* nil))) 
-
-(defun get-wm2 (elem) 
-  ; (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*) :test #'equal)))
-  (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*)) ;test #'equal)
-	(setq *wm* (cons (car elem) *wm*)))))
-
-(defun wm-hash (x)
-  (cond ((not x) '<default>)
-	((not (car x)) (wm-hash (cdr x)))
-	((symbolp (car x)) (car x))
-	(t (wm-hash (cdr x))))) 
-
-(defun refresh nil
-  (prog nil
-    (setq *old-wm* nil)
-    (mapwm (function refresh-collect))
-    (mapc (function refresh-del) *old-wm*)
-    (mapc (function refresh-add) *old-wm*)
-    (setq *old-wm* nil))) 
-
-(defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*))) 
-
-(defun refresh-del (x) (remove-from-wm (car x))) 
-
-(defun refresh-add (x) (add-to-wm (car x) (cdr x))) 
diff --git a/contrib/ops/ops-util.lisp b/contrib/ops/ops-util.lisp
deleted file mode 100644
index 58eabfba1b52990662801ccdfd8e713b8cd971c6..0000000000000000000000000000000000000000
--- a/contrib/ops/ops-util.lisp
+++ /dev/null
@@ -1,242 +0,0 @@
-;
-;************************************************************************
-;
-;	VPS2 -- Interpreter for OPS5
-;
-;
-;
-; This Common Lisp version of OPS5 is in the public domain.  It is based
-; in part on based on a Franz Lisp implementation done by Charles L. Forgy
-; at Carnegie-Mellon University, which was placed in the public domain by
-; the author in accordance with CMU policies.  This version has been
-; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
-; and Dan Kuokka.
-;
-; This code is made available is, and without warranty of any kind by the
-; authors or by Carnegie-Mellon University.
-;
-
-;;;; This file contains utility definitions that are needed by other ops
-;;;; modules.  This must be loaded first so commonlisp systems that
-;;;; expand macros early have them available.
-
-(unless (find-package "OPS") (make-package "OPS"))
-
-(in-package "OPS")
-
-;;; Assq is included in some Common Lisp implementations (like Spice Lisp and
-;;; the Zetalisp CLCP) as an extension.  We'll use ASSOC if it's not there.
-;;; DK- turned assq into a function so it can be 'applied'
-
-(eval-when (compile load eval)
-  (unless (fboundp 'assq)
-    (defmacro assq (i l)
-      `(assoc ,i ,l))))
-
-;;; Ditto for DELQ.
-
-(eval-when (compile load eval)
-  (unless (fboundp 'delq)
-    (defmacro delq (i l)
-      `(delete ,i ,l :test #'eq))))
-
-;
-; Spdelete "special delete" is a function which deletes every occurence
-; of element from list. This function was defined because common lisp's
-; delete function only deletes top level elements from a list, not lists
-; from lists. 
-;
-(defun spdelete (element list)
-  
-  (cond ((null list) nil)
-	((equal element (car list)) (spdelete element (cdr list)))
-	(t (cons (car list) (spdelete element (cdr list))))))
-
-
-;;; Functions that were revised so that they would compile efficiently
-
-(eval-when (compile eval load)
-	   
-;* The function == is machine dependent!
-;* This function compares small integers for equality.  It uses EQ
-;* so that it will be fast, and it will consequently not work on all
-;* Lisps.  It works in Franz Lisp for integers in [-128, 127]
-;(system::macro == (z) `(eq ,(cadr z) ,(caddr z)))
-;;;
-;;; Dario Giuse - made a macro. This is going to be faster than anything else.
-;;;
-;;; Skef Wholey - The = function in Common Lisp will compile into good code
-;;; (in all implementations that I know of) when given the right declarations.
-;;; In this case, we know both numbers are fixnums, so we use that information.
-
-(defmacro == (x y)
-  `(= (the fixnum ,x) (the fixnum ,y)))
-
-;;; =ALG returns T if A and B are algebraically equal.
-;;; This corresponds to equalp - Dario Giuse
-;;; But equalp uses eql for comparison if the things are numbers - Skef Wholey
-;;;
-(defmacro =alg (a b)
-  `(eql ,a ,b))
-
-	   
-(defmacro fast-symeval (&body z)
-  `(symbol-value ,(car z)))
-
-; getvector and putvector are fast routines for using ONE-DIMENSIONAL
-; arrays.  these routines do no checking; they assume
-;	1. the array is a vector with 0 being the index of the first
-;	   element
-;	2. the vector holds arbitrary list values
-
-; Example call: (putvector array index value)
-;;; Dario Giuse - 6/20/84
-
-(defmacro putvector (array index value)
-  `(setf (aref ,array ,index) ,value))
-
-;;; Example call: (getvector name index)
-;;;
-(defmacro getvector (array index)
-  `(aref ,array ,index))
-
-
-;;; Dario Giuse  6/21/84
-(defmacro putprop (atom value property)
-  `(setf (get ,atom ,property) ,value))
-
-) ;eval-when
-
-
-(defun ce-gelm (x k)
-  (declare (fixnum k))
-  (declare (optimize (speed 3) (safety 0)))
-  (prog nil
-    loop (and (== k 1.) (return (car x)))
-    (setq k (1- k))
-    (setq x (cdr x))
-    (go loop))) 
-
-(defconstant encode-pair-shift 14)
-
-; The loops in gelm were unwound so that fewer calls on DIFFERENCE
-; would be needed
-
-(defun gelm (x k)
-  (declare (optimize speed (safety 0)) (fixnum k))
-  (prog ((ce (ash k (- encode-pair-shift)))
-	 (sub (ldb (byte 14 0) k)))
-    (declare (fixnum ce sub))
-    celoop (and (eql ce 0.) (go ph2))
-    (setq x (cdr x))
-    (and (eql ce 1.) (go ph2))
-    (setq x (cdr x))
-    (and (eql ce 2.) (go ph2))
-    (setq x (cdr x))
-    (and (eql ce 3.) (go ph2))
-    (setq x (cdr x))
-    (and (eql ce 4.) (go ph2))
-    (setq ce (- ce 4.))
-    (go celoop)
-    ph2  (setq x (car x))
-    subloop (and (eql sub 0.) (go finis))
-    (setq x (cdr x))
-    (and (eql sub 1.) (go finis))
-    (setq x (cdr x))
-    (and (eql sub 2.) (go finis))
-    (setq x (cdr x))
-    (and (eql sub 3.) (go finis))
-    (setq x (cdr x))
-    (and (eql sub 4.) (go finis))
-    (setq x (cdr x))
-    (and (eql sub 5.) (go finis))
-    (setq x (cdr x))
-    (and (eql sub 6.) (go finis))
-    (setq x (cdr x))
-    (and (eql sub 7.) (go finis))
-    (setq x (cdr x))
-    (and (eql sub 8.) (go finis))
-    (setq sub (- sub 8.))
-    (go subloop)
-    finis (return (car x))) ) ;  )  	;end prog,< locally >, defun
-
-
-
-;;; intersect two lists using eq for the equality test
-(defun interq (x y)
-  (cond ((atom x) nil)
-	((member (car x) y) (cons (car x) (interq (cdr x) y)))
-	(t (interq (cdr x) y)))) 
-
-
-(proclaim '(special *p-name*))
-
-(defun %warn (what where)
-  (prog nil
-    (terpri)
-    (princ '?)
-    (and *p-name* (princ *p-name*))
-    (princ '|..|)
-    (princ where)
-    (princ '|..|)
-    (princ what)
-    (return where))) 
-
-(defun %error (what where)
-  (%warn what where)
-  (throw '!error! '!error!)) 	;jgk quoted arguments
-
-;@@@(defun round (x) (fix (+ 0.5 x))) 		;"plus" changed to "+" by gdw
-;@@@ removed; calls converted to native clisp (round)
-
-(defun top-levels-eq (la lb)
-  (prog nil
-    lx   (cond ((eq la lb) (return t))
-	       ((null la) (return nil))
-	       ((null lb) (return nil))
-	       ((not (eq (car la) (car lb))) (return nil)))
-    (setq la (cdr la))
-    (setq lb (cdr lb))
-    (go lx))) 
-
-
-;(defun dtpr  (x) (consp x))	;dtpr\consp gdw
-
-
-(defun fix (x)(floor x))
-
-
-(eval-when (compile load eval)
-(defmacro ncons (x) `(cons ,x nil))
-);eval-when
-
-
-;@@@ revision suggested by sf/inc. by gdw
-(defun variablep (x)
-  (and (symbolp x)
-       (let ((name (symbol-name x)))
-	 (and (>= (length name) 1)
-	      (char= (char name 0) #\<)))))
-
-
-
-;@@@   this is a mistake: it must either go before = is called for 
-;non-numeric args, or such calls replaced with eq, equal, etc.
-;(defun = 
-;(x y) (equal x y))
-
-
-
-#|
-Commented out - Dario Giuse.
-This is unnecessary in Spice Lisp
-
-; break mechanism:
-(proclaim '(special erm *break-character*))
-
-(defun setbreak nil (setq *break-flag* t))
-(setq *break-character* #\control-D)
-(bind-keyboard-function *break-character* #'setbreak)
-(princ "*** use control-d for ops break, or setq *break-character asciival***")
-
-|#
diff --git a/contrib/ops/ops.catalog b/contrib/ops/ops.catalog
deleted file mode 100644
index c961a8199c0c935bddaba17c49cbffd7995d91e1..0000000000000000000000000000000000000000
--- a/contrib/ops/ops.catalog
+++ /dev/null
@@ -1,43 +0,0 @@
-Name:
-   OPS
-
-Package Name:
-   OPS
-
-Description:
-   Interpreter for Ops5, a programming language for production systems.
-
-Author:
-   Charles L. Forgy.  Ported to Common lisp by George Wood and Jim Kowalski.
-CMU Common Lisp mods by Dario Guise, Skef Wholey, and Dan Kuokka.
-
-Maintainer:
-   Not really maintained.
-
-Copyright Status:
-   Public domain.
-
-Files:
-   ops.lisp, ops-backup.lisp, ops-compile.lisp, ops-io.lisp, ops-main.lisp,
-ops-match.lisp, ops-rhs.lisp, ops-util.lisp, ops.catalog, *.ops
-
-Portability:
-   Should run in any legal Common Lisp implementation.
-
-Instructions:
-
-To compile for CMU Common Lisp, (load "library:contrib/ops/compile-ops").
-After OPS has been compiled, you can (load "library:contrib/ops/ops.fasl").
-Then go into the OPS package with (in-package :ops).  Now you can load your
-OPS5 code or start typing in productions.
-
-There are a number of demos and sample programs; particularly amusing is the
-Haunt adventure game.  Do (load "<name>.ops"), then "(run)".  Many systems
-require an initial "(make start)" before the "(run)" --- if this is missing,
-"(run)" will do nothing.  Set *ptrace* to NIL to eliminate production tracing.
-
-See the OPS5 User's Manual, July 1981, by Forgy, CMU CSD.
-
-Bugs:
-   This has been put in its own package, but only a few interfaces have been
-exported.  You must run in the ops package.
diff --git a/contrib/ops/ops.lisp b/contrib/ops/ops.lisp
deleted file mode 100644
index d4ed92997b634d08763fb02903015ed9440cdccf..0000000000000000000000000000000000000000
--- a/contrib/ops/ops.lisp
+++ /dev/null
@@ -1,42 +0,0 @@
-;
-;************************************************************************
-;
-;	VPS2 -- Interpreter for OPS5
-;
-;
-;
-; This Common Lisp version of OPS5 is in the public domain.  It is based
-; in part on based on a Franz Lisp implementation done by Charles L. Forgy
-; at Carnegie-Mellon University, which was placed in the public domain by
-; the author in accordance with CMU policies.  This version has been
-; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
-; and Dan Kuokka.
-;
-; This code is made available is, and without warranty of any kind by the
-; authors or by Carnegie-Mellon University.
-;
-
-;;;; This file performs the necessary initialization of the OPS interpreter.
-
-
-(in-package "OPS")
-
-(defun ops-init ()
-  ; Allows ^ , { , and } operators to be right next to another symbol.
-  (set-macro-character #\{ #'(lambda (s c)
-			       (declare (ignore s c))
-			       '\{))
-  (set-macro-character #\} #'(lambda (s c)
-			       (declare (ignore s c))
-			       '\}))
-  (set-macro-character #\^ #'(lambda (s c)
-			       (declare (ignore s c))
-			       '\^))
-  (backup-init)
-  (compile-init)
-  (main-init)
-  (match-init)
-  (io-init)
-  (rhs-init))
-
-(ops-init)
diff --git a/contrib/ops/pp.ops b/contrib/ops/pp.ops
deleted file mode 100644
index 1fe316ec63e5e81353a5ef83eff3ee2a28836a1f..0000000000000000000000000000000000000000
--- a/contrib/ops/pp.ops
+++ /dev/null
@@ -1,53 +0,0 @@
-; Production pretty printer.
-; The program takes productions in any lousy
-; format and attempts to print them properly.
-
-(declare (special pcount oport cinp))
-
-(defun pp (ifile ofile)
-       (prog (iport)
-	     (setq iport (infile ifile))
-	     (setq oport (outfile ofile))
-	     (setq pcount 1)
-	     (setq cinp (read iport))
-	     (while cinp
-		    (cond ((atom cinp) (print cinp oport) (terpri oport))
-			  ((not (equal (car cinp) 'p)) (print cinp oport)
-				 (terpri oport))
-			  (t (print-prod) (terpri oport)))
-		    (setq cinp (read iport)))
-	     (terpri oport)))
-
-
-(defun print-prod ()
-       (prog nil
-	     (princ "(p " oport)
-	     (print (cadr cinp) oport) (terpri oport)
-	     (setq cinp (cddr cinp))
-	     (while cinp
-		    (cond ((and (atom (car cinp)) (equal (car cinp) '-->))
-			   (princ "  -->" oport) (terpri oport)
-			   (setq cinp (cdr cinp)))
-			  ((and (atom (car cinp)) (equal (car cinp) '{))
-			   (princ "    " oport)
-			   (print-ce-with-var) (terpri oport))
-			  ((and (atom (car cinp)) (equal (car cinp) '-))
-			   (princ "  - " oport) 
-			   (print (cadr cinp) oport) (terpri oport)
-			   (setq cinp (cddr cinp)))
-			  (t (princ "    " oport)
-			     (print (car cinp) oport) (terpri oport)
-			     (setq cinp (cdr cinp)))))
-	     (setq pcount (1+ pcount))
-	     (princ ")" oport) (terpri oport)))
-
-
-(defun print-ce-with-var ()
-    (prog nil
-	  (while (not (equal (car cinp) '}))
-		 (print (car cinp) oport) (princ " " oport)
-		 (setq cinp (cdr cinp)))
-	  (print (car cinp) oport)
-	  (setq cinp (cdr cinp))))
-
-							 
diff --git a/contrib/ops/rubik.ops b/contrib/ops/rubik.ops
deleted file mode 100644
index ee615986f3b5aa5b6c76bec50791c75dcbf26af6..0000000000000000000000000000000000000000
--- a/contrib/ops/rubik.ops
+++ /dev/null
@@ -1,2026 +0,0 @@
-
-
-
-(literalize goal
-    want
-    object
-    number
-    direction
-    value
-    id
-    seq
-    status)
-
-(literalize vodor
-    right
-    left
-    top
-    bottom
-    front
-    posterior
-    id
-    status)
-
-(literalize task-list
-    task
-    object
-    subtask
-    subtask-object)
-
-(literalize face
-    number
-    block
-    color)
-
-(literalize cubie-order
-    face-num
-    direction
-    adj-face-num
-    block
-    adj-blk-num)
-
-(literalize face-relation
-    front
-    posterior
-    right
-    left
-    top
-    bottom)
-
-(literalize front-face
-    number
-    color
-    id
-    status)
-
-(literalize source-face
-    number
-    color
-    ic
-    id
-    status)
-
-(literalize bottom-corner
-    number
-    face
-    color
-    cubie
-    id
-    status)
-
-(literalize bottom-edge
-    number
-    face
-    color
-    cubie
-    id
-    status)
-
-
-
-
-(p start
-    (start)
--->
-    (remove 1)
-    (make face ^number 1 ^block 1 ^color blue)
-    (make face ^number 1 ^block 2 ^color blue)
-    (make face ^number 1 ^block 3 ^color blue)
-    (make face ^number 1 ^block 4 ^color blue)
-    (make face ^number 1 ^block 5 ^color blue)
-    (make face ^number 1 ^block 6 ^color blue)
-    (make face ^number 1 ^block 7 ^color blue)
-    (make face ^number 1 ^block 8 ^color blue)
-    (make face ^number 1 ^block 9 ^color blue)
-    (make face ^number 2 ^block 1 ^color red)
-    (make face ^number 2 ^block 2 ^color red)
-    (make face ^number 2 ^block 3 ^color red)
-    (make face ^number 2 ^block 4 ^color red)
-    (make face ^number 2 ^block 5 ^color red)
-    (make face ^number 2 ^block 6 ^color red)
-    (make face ^number 2 ^block 7 ^color red)
-    (make face ^number 2 ^block 8 ^color red)
-    (make face ^number 2 ^block 9 ^color red)
-    (make face ^number 3 ^block 1 ^color green)
-    (make face ^number 3 ^block 2 ^color green)
-    (make face ^number 3 ^block 3 ^color green)
-    (make face ^number 3 ^block 4 ^color green)
-    (make face ^number 3 ^block 5 ^color green)
-    (make face ^number 3 ^block 6 ^color green)
-    (make face ^number 3 ^block 7 ^color green)
-    (make face ^number 3 ^block 8 ^color green)
-    (make face ^number 3 ^block 9 ^color green)
-    (make face ^number 4 ^block 1 ^color white)
-    (make face ^number 4 ^block 2 ^color white)
-    (make face ^number 4 ^block 3 ^color white)
-    (make face ^number 4 ^block 4 ^color white)
-    (make face ^number 4 ^block 5 ^color white)
-    (make face ^number 4 ^block 6 ^color white)
-    (make face ^number 4 ^block 7 ^color white)
-    (make face ^number 4 ^block 8 ^color white)
-    (make face ^number 4 ^block 9 ^color white)
-    (make face ^number 5 ^block 1 ^color yellow)
-    (make face ^number 5 ^block 2 ^color yellow)
-    (make face ^number 5 ^block 3 ^color yellow)
-    (make face ^number 5 ^block 4 ^color yellow)
-    (make face ^number 5 ^block 5 ^color yellow)
-    (make face ^number 5 ^block 6 ^color yellow)
-    (make face ^number 5 ^block 7 ^color yellow)
-    (make face ^number 5 ^block 8 ^color yellow)
-    (make face ^number 5 ^block 9 ^color yellow)
-    (make face ^number 6 ^block 1 ^color orange)
-    (make face ^number 6 ^block 2 ^color orange)
-    (make face ^number 6 ^block 3 ^color orange)
-    (make face ^number 6 ^block 4 ^color orange)
-    (make face ^number 6 ^block 5 ^color orange)
-    (make face ^number 6 ^block 6 ^color orange)
-    (make face ^number 6 ^block 7 ^color orange)
-    (make face ^number 6 ^block 8 ^color orange)
-    (make face ^number 6 ^block 9 ^color orange)
-    (make cubie-order ^face-num 1 ^direction dn
-                      ^adj-face-num 2 ^block 7 ^adj-blk-num 1)
-    (make cubie-order ^face-num 1 ^direction dn
-                      ^adj-face-num 2 ^block 8 ^adj-blk-num 2)
-    (make cubie-order ^face-num 1 ^direction dn
-                      ^adj-face-num 2 ^block 9 ^adj-blk-num 3)
-    (make cubie-order ^face-num 1 ^direction rt
-                      ^adj-face-num 3 ^block 3 ^adj-blk-num 3)
-    (make cubie-order ^face-num 1 ^direction rt
-                      ^adj-face-num 3 ^block 6 ^adj-blk-num 2)
-    (make cubie-order ^face-num 1 ^direction rt
-                      ^adj-face-num 3 ^block 9 ^adj-blk-num 1)
-    (make cubie-order ^face-num 1 ^direction up
-                      ^adj-face-num 4 ^block 1 ^adj-blk-num 3)
-    (make cubie-order ^face-num 1 ^direction up
-                      ^adj-face-num 4 ^block 2 ^adj-blk-num 2)
-    (make cubie-order ^face-num 1 ^direction up
-                      ^adj-face-num 4 ^block 3 ^adj-blk-num 1)
-    (make cubie-order ^face-num 1 ^direction lf
-                      ^adj-face-num 5 ^block 1 ^adj-blk-num 1)
-    (make cubie-order ^face-num 1 ^direction lf
-                      ^adj-face-num 5 ^block 4 ^adj-blk-num 2)
-    (make cubie-order ^face-num 1 ^direction lf
-                      ^adj-face-num 5 ^block 7 ^adj-blk-num 3)
-    (make cubie-order ^face-num 2 ^direction up
-                      ^adj-face-num 1 ^block 1 ^adj-blk-num 7)
-    (make cubie-order ^face-num 2 ^direction up
-                      ^adj-face-num 1 ^block 2 ^adj-blk-num 8)
-    (make cubie-order ^face-num 2 ^direction up
-                      ^adj-face-num 1 ^block 3 ^adj-blk-num 9)
-    (make cubie-order ^face-num 2 ^direction rt
-                      ^adj-face-num 3 ^block 3 ^adj-blk-num 1)
-    (make cubie-order ^face-num 2 ^direction rt
-                      ^adj-face-num 3 ^block 6 ^adj-blk-num 4)
-    (make cubie-order ^face-num 2 ^direction rt
-                      ^adj-face-num 3 ^block 9 ^adj-blk-num 7)
-    (make cubie-order ^face-num 2 ^direction dn
-                      ^adj-face-num 6 ^block 7 ^adj-blk-num 1)
-    (make cubie-order ^face-num 2 ^direction dn
-                      ^adj-face-num 6 ^block 8 ^adj-blk-num 2)
-    (make cubie-order ^face-num 2 ^direction dn
-                      ^adj-face-num 6 ^block 9 ^adj-blk-num 3)
-    (make cubie-order ^face-num 2 ^direction lf
-                      ^adj-face-num 5 ^block 1 ^adj-blk-num 3)
-    (make cubie-order ^face-num 2 ^direction lf
-                      ^adj-face-num 5 ^block 4 ^adj-blk-num 6)
-    (make cubie-order ^face-num 2 ^direction lf
-                      ^adj-face-num 5 ^block 7 ^adj-blk-num 9)
-    (make cubie-order ^face-num 3 ^direction up
-                      ^adj-face-num 1 ^block 1 ^adj-blk-num 9)
-    (make cubie-order ^face-num 3 ^direction up
-                      ^adj-face-num 1 ^block 2 ^adj-blk-num 6)
-    (make cubie-order ^face-num 3 ^direction up
-                      ^adj-face-num 1 ^block 3 ^adj-blk-num 3)
-    (make cubie-order ^face-num 3 ^direction rt
-                      ^adj-face-num 4 ^block 3 ^adj-blk-num 1)
-    (make cubie-order ^face-num 3 ^direction rt
-                      ^adj-face-num 4 ^block 6 ^adj-blk-num 4)
-    (make cubie-order ^face-num 3 ^direction rt
-                      ^adj-face-num 4 ^block 9 ^adj-blk-num 7)
-    (make cubie-order ^face-num 3 ^direction dn
-                      ^adj-face-num 6 ^block 7 ^adj-blk-num 3)
-    (make cubie-order ^face-num 3 ^direction dn
-                      ^adj-face-num 6 ^block 8 ^adj-blk-num 6)
-    (make cubie-order ^face-num 3 ^direction dn
-                      ^adj-face-num 6 ^block 9 ^adj-blk-num 9)
-    (make cubie-order ^face-num 3 ^direction lf
-                      ^adj-face-num 2 ^block 1 ^adj-blk-num 3)
-    (make cubie-order ^face-num 3 ^direction lf
-                      ^adj-face-num 2 ^block 4 ^adj-blk-num 6)
-    (make cubie-order ^face-num 3 ^direction lf
-                      ^adj-face-num 2 ^block 7 ^adj-blk-num 9)
-    (make cubie-order ^face-num 4 ^direction up
-                      ^adj-face-num 1 ^block 1 ^adj-blk-num 3)
-    (make cubie-order ^face-num 4 ^direction up
-                      ^adj-face-num 1 ^block 2 ^adj-blk-num 2)
-    (make cubie-order ^face-num 4 ^direction up
-                      ^adj-face-num 1 ^block 3 ^adj-blk-num 1)
-    (make cubie-order ^face-num 4 ^direction rt
-                      ^adj-face-num 5 ^block 3 ^adj-blk-num 1)
-    (make cubie-order ^face-num 4 ^direction rt
-                      ^adj-face-num 5 ^block 6 ^adj-blk-num 4)
-    (make cubie-order ^face-num 4 ^direction rt
-                      ^adj-face-num 5 ^block 9 ^adj-blk-num 7)
-    (make cubie-order ^face-num 4 ^direction dn
-                      ^adj-face-num 6 ^block 7 ^adj-blk-num 9)
-    (make cubie-order ^face-num 4 ^direction dn
-                      ^adj-face-num 6 ^block 8 ^adj-blk-num 8)
-    (make cubie-order ^face-num 4 ^direction dn
-                      ^adj-face-num 6 ^block 9 ^adj-blk-num 7)
-    (make cubie-order ^face-num 4 ^direction lf
-                      ^adj-face-num 3 ^block 1 ^adj-blk-num 3)
-    (make cubie-order ^face-num 4 ^direction lf
-                      ^adj-face-num 3 ^block 4 ^adj-blk-num 6)
-    (make cubie-order ^face-num 4 ^direction lf
-                      ^adj-face-num 3 ^block 7 ^adj-blk-num 9)
-    (make cubie-order ^face-num 5 ^direction up
-                      ^adj-face-num 1 ^block 1 ^adj-blk-num 1)
-    (make cubie-order ^face-num 5 ^direction up
-                      ^adj-face-num 1 ^block 2 ^adj-blk-num 4)
-    (make cubie-order ^face-num 5 ^direction up
-                      ^adj-face-num 1 ^block 3 ^adj-blk-num 7)
-    (make cubie-order ^face-num 5 ^direction rt
-                      ^adj-face-num 2 ^block 3 ^adj-blk-num 1)
-    (make cubie-order ^face-num 5 ^direction rt
-                      ^adj-face-num 2 ^block 6 ^adj-blk-num 4)
-    (make cubie-order ^face-num 5 ^direction rt
-                      ^adj-face-num 2 ^block 9 ^adj-blk-num 7)
-    (make cubie-order ^face-num 5 ^direction dn
-                      ^adj-face-num 6 ^block 7 ^adj-blk-num 7)
-    (make cubie-order ^face-num 5 ^direction dn
-                      ^adj-face-num 6 ^block 8 ^adj-blk-num 4)
-    (make cubie-order ^face-num 5 ^direction dn
-                      ^adj-face-num 6 ^block 9 ^adj-blk-num 1)
-    (make cubie-order ^face-num 5 ^direction lf
-                      ^adj-face-num 4 ^block 1 ^adj-blk-num 3)
-    (make cubie-order ^face-num 5 ^direction lf
-                      ^adj-face-num 4 ^block 4 ^adj-blk-num 6)
-    (make cubie-order ^face-num 5 ^direction lf
-                      ^adj-face-num 4 ^block 7 ^adj-blk-num 9)
-    (make cubie-order ^face-num 6 ^direction up
-                      ^adj-face-num 2 ^block 1 ^adj-blk-num 7)
-    (make cubie-order ^face-num 6 ^direction up
-                      ^adj-face-num 2 ^block 2 ^adj-blk-num 8)
-    (make cubie-order ^face-num 6 ^direction up
-                      ^adj-face-num 2 ^block 3 ^adj-blk-num 9)
-    (make cubie-order ^face-num 6 ^direction rt
-                      ^adj-face-num 3 ^block 3 ^adj-blk-num 7)
-    (make cubie-order ^face-num 6 ^direction rt
-                      ^adj-face-num 3 ^block 6 ^adj-blk-num 8)
-    (make cubie-order ^face-num 6 ^direction rt
-                      ^adj-face-num 3 ^block 9 ^adj-blk-num 9)
-    (make cubie-order ^face-num 6 ^direction dn
-                      ^adj-face-num 4 ^block 7 ^adj-blk-num 9)
-    (make cubie-order ^face-num 6 ^direction dn
-                      ^adj-face-num 4 ^block 8 ^adj-blk-num 8)
-    (make cubie-order ^face-num 6 ^direction dn
-                      ^adj-face-num 4 ^block 9 ^adj-blk-num 7)
-    (make cubie-order ^face-num 6 ^direction lf
-                      ^adj-face-num 5 ^block 1 ^adj-blk-num 9)
-    (make cubie-order ^face-num 6 ^direction lf
-                      ^adj-face-num 5 ^block 4 ^adj-blk-num 8)
-    (make cubie-order ^face-num 6 ^direction lf
-                      ^adj-face-num 5 ^block 7 ^adj-blk-num 7)
-    (make face-relation ^front 2 ^right 3 ^left 5
-                        ^top 1 ^bottom 6 ^posterior 4)
-    (make face-relation ^front 3 ^right 4 ^left 2
-                        ^top 1 ^bottom 6 ^posterior 5)
-    (make face-relation ^front 4 ^right 5 ^left 3
-                        ^top 1 ^bottom 6 ^posterior 2)
-    (make face-relation ^front 5 ^right 2 ^left 4
-                        ^top 1 ^bottom 6 ^posterior 3)
-    (make face-relation ^front 6 ^posterior 1)
-    (make task-list ^task orient ^object bottom-edge
-                    ^subtask position ^subtask-object bottom-edge)
-    (make task-list ^task position ^object bottom-edge
-                    ^subtask orient ^subtask-object bottom-corner)
-    (make task-list ^task orient ^object bottom-corner
-                    ^subtask position ^subtask-object bottom-corner)
-    (make task-list ^task position ^object bottom-corner
-                    ^subtask orient ^subtask-object vertical-edge)
-    (make task-list ^task orient ^object vertical-edge
-                    ^subtask position ^subtask-object vertical-edge)
-    (make task-list ^task position ^object vertical-edge
-                    ^subtask orient ^subtask-object top-corner)
-    (make task-list ^task orient ^object top-corner
-                    ^subtask position ^subtask-object top-corner)
-    (make task-list ^task position ^object top-corner
-                    ^subtask orient ^subtask-object top-edge)
-    (make task-list ^task orient ^object top-edge
-                    ^subtask position ^subtask-object top-edge)
-    (write (crlf) normal cube order is |:|)
-    (write (crlf) (tabto 20) top face 1 |:| blue)
-    (write (crlf) (tabto 20) bottom face 6 |:| orange)
-    (write (crlf) (tabto 20) front face 2 |:| red)
-    (write (crlf) (tabto 20) right face 3 |:| green)
-    (write (crlf) (tabto 20) posterior face 4 |:| white)
-    (write (crlf) (tabto 20) left face 5 |:| yellow)
-    (make goal ^want scramble ^object cube ^id 1 ^number nil ^status active))
-
-(p scramble*initiate
-    (goal ^want scramble ^object cube ^id <id> ^number nil ^status active)
--->
-    (write (crlf) how many scrambling operations  >0  shall i perform |?_| )
-    (modify 1 ^number (accept)))
-
-(p scramble*sequence
-    (goal ^want scramble ^object cube ^id <id> ^number {<n> > 0}
-          ^status active)
--->
-	   (modify 1 ^number (compute <n> - 1))
-    (write (crlf) about which face 1-6 shall i perform this rotation |?_|)
-    (bind <f> (accept))
-    (write (crlf) in which direction pos neg shall i rotate |?_|)
-    (bind <d> (accept))
-    (write (crlf) what size rotation shall i perform 90-180 |?_|)
-    (bind <v> (accept))
-    (make goal ^want rotate ^object face ^number <f> ^direction <d>
-               ^value <v> ^seq 1 ^status active))
-
-(p scramble*exit
-    (goal ^want scramble ^object cube ^id <id> ^number 0 ^status active)
--->
-    (remove 1)
-    (write (crlf) initiating solution |:| (crlf))
-    (make goal ^want orient ^object bottom-edge ^id 1 ^status consider))
-
-
-
-
-(p sequence-1
-    (goal ^want { << orient position >> <w> } ^object <o>
-          ^id <id> ^status consider)
-    (task-list ^task <w> ^object <o> ^subtask <st> ^subtask-object <sto>)
-   -(goal ^want <st> ^object <sto> ^status done)
-   -(goal ^want rotate ^status active)
--->
-    (write (crlf) (crlf) suspending task to <w> <o>)
-    (write (crlf) considering task to <st> <sto>)
-    (modify 1 ^status pending)
-    (make goal ^want <st> ^object <sto> ^id (compute <id> + 1)
-               ^status consider))
-
-
-(p sequence-2
-    (goal ^want { << orient position >> <w> } ^object <o>
-          ^id <id> ^status consider)
-   -(task-list ^task <w> ^object <o>)
-   -(goal ^want rotate ^status active)
--->
-    (write (crlf) (crlf) initiating task to <w> <o>)
-    (modify 1 ^status active))
-
-
-(p sequence-3
-    (goal ^want { << orient position >> <w> } ^object <o>
-          ^id <id> ^status active)
-   -(goal ^want rotate ^status active)
--->
-    (write (crlf) (crlf) i find no further tasks to <w> <o>)
-    (modify 1 ^status done))
-
-
-(p sequence-4
-    (goal ^want { << orient position >> <w> } ^object <o>
-          ^id <id> ^status pending)
-   -(goal ^status << active  consider >>)
-   -(goal ^id > <id> ^status pending)
--->
-    (write (crlf) (crlf) reconsidering task to <w> <o>)
-    (modify 1 ^status consider))
-
-(p sequence-5
-    (goal ^want { << orient position >> <w> } ^object <o>
-          ^id <id> ^status consider)
-    (task-list ^task <w> ^object <o> ^subtask <st> ^subtask-object <sto>)
-    (goal ^want <st> ^object <sto> ^status done)
-   -(goal ^want rotate ^status active)
--->
-    (write (crlf) (crlf) initiating task to <w> <o>)
-    (modify 1 ^status active))
-
-
-(p detect_normal-order
-    (goal ^want { << orient position >> <w> } ^object <o>)
-    (face ^number 1 ^block 5 ^color <c1>)
-   -(face ^number 1 ^block << 1 2 3 4 6 7 8 9 >> ^color <> <c1>)
-    (face ^number 2 ^block 5 ^color <c2>)
-   -(face ^number 2 ^block << 1 2 3 4 6 7 8 9 >> ^color <> <c2>)
-    (face ^number 3 ^block 5 ^color <c3>)
-   -(face ^number 3 ^block << 1 2 3 4 6 7 8 9 >> ^color <> <c3>)
-    (face ^number 4 ^block 5 ^color <c4>)
-   -(face ^number 4 ^block << 1 2 3 4 6 7 8 9 >> ^color <> <c4>)
-    (face ^number 5 ^block 5 ^color <c5>)
-   -(face ^number 2 ^block << 1 2 3 4 6 7 8 9 >> ^color <> <c2>)
-    (face ^number 6 ^block 5 ^color <c6>)
-   -(face ^number 6 ^block << 1 2 3 4 6 7 8 9 >> ^color <> <c6>)
--->
-    (write (crlf) i find cube in normal order while attempting to <w> <o>)
-    (halt))
-
-
-
-(p plus-90
-    (goal ^want rotate ^object face ^number <n> ^direction pos
-          ^value 90 ^id <id> ^seq <seq> ^status active)
-   -(goal ^want rotate ^object face ^id <id> ^seq < <seq> ^status active)
-    (face ^number <n> ^block 1 ^color <c1>)
-    (face ^number <n> ^block 2 ^color <c2>)
-    (face ^number <n> ^block 3 ^color <c3>)
-    (face ^number <n> ^block 4 ^color <c4>)
-    (face ^number <n> ^block 5 ^color <c5>)
-    (face ^number <n> ^block 6 ^color <c6>)
-    (face ^number <n> ^block 7 ^color <c7>)
-    (face ^number <n> ^block 8 ^color <c8>)
-    (face ^number <n> ^block 9 ^color <c9>)
-    (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup>
-                 ^block 1 ^adj-blk-num <nup1>)
-    (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup>
-                 ^block 2 ^adj-blk-num <nup2>)
-    (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup>
-                 ^block 3 ^adj-blk-num <nup3>)
-    (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt>
-                 ^block 3 ^adj-blk-num <nrt3>)
-    (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt>
-                 ^block 6 ^adj-blk-num <nrt6>)
-    (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt>
-                 ^block 9 ^adj-blk-num <nrt9>)
-    (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn>
-                 ^block 7 ^adj-blk-num <ndn7>)
-    (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn>
-                 ^block 8 ^adj-blk-num <ndn8>)
-    (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn>
-                 ^block 9 ^adj-blk-num <ndn9>)
-    (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf>
-                 ^block 1 ^adj-blk-num <nlf1>)
-    (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf>
-                 ^block 4 ^adj-blk-num <nlf4>)
-    (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf>
-                 ^block 7 ^adj-blk-num <nlf7>)
-    (face ^number <nrt> ^block <nrt3> ^color <cnrt3>)
-    (face ^number <nrt> ^block <nrt6> ^color <cnrt6>)
-    (face ^number <nrt> ^block <nrt9> ^color <cnrt9>)
-    (face ^number <nlf> ^block <nlf7> ^color <cnlf7>)
-    (face ^number <nlf> ^block <nlf4> ^color <cnlf4>)
-    (face ^number <nlf> ^block <nlf1> ^color <cnlf1>)
-    (face ^number <nup> ^block <nup1> ^color <cnup1>)
-    (face ^number <nup> ^block <nup2> ^color <cnup2>)
-    (face ^number <nup> ^block <nup3> ^color <cnup3>)
-    (face ^number <ndn> ^block <ndn9> ^color <cndn9>)
-    (face ^number <ndn> ^block <ndn8> ^color <cndn8>)
-    (face ^number <ndn> ^block <ndn7> ^color <cndn7>)
--->
-    (write (crlf) rotating face <n>  the <c5> face  plus 90)
-    (modify 1 ^status done)
-    (modify 2 ^color <c7>)
-    (modify 3 ^color <c4>)
-    (modify 4 ^color <c1>)
-    (modify 5 ^color <c8>)
-    (modify 6 ^color <c5>)
-    (modify 7 ^color <c2>)
-    (modify 8. ^color <c9>)
-    (modify 9. ^color <c6>)
-    (modify 10. ^color <c3>)
-    (modify 23. ^color <cnup1>)
-    (modify 24. ^color <cnup2>)
-    (modify 25. ^color <cnup3>)
-    (modify 26. ^color <cndn9>)
-    (modify 27. ^color <cndn8>)
-    (modify 28. ^color <cndn7>)
-    (modify 29. ^color <cnlf7>)
-    (modify 30. ^color <cnlf4>)
-    (modify 31. ^color <cnlf1>)
-    (modify 32. ^color <cnrt3>)
-    (modify 33. ^color <cnrt6>)
-    (modify 34. ^color <cnrt9>))
-
-(p minus-90
-    (goal ^want rotate ^object face ^number <n> ^direction neg
-          ^value 90 ^id <id> ^seq <seq> ^status active)
-   -(goal ^want rotate ^object face ^id <id> ^seq < <seq> ^status active)
-    (face ^number <n> ^block 1 ^color <c1>)
-    (face ^number <n> ^block 2 ^color <c2>)
-    (face ^number <n> ^block 3 ^color <c3>)
-    (face ^number <n> ^block 4 ^color <c4>)
-    (face ^number <n> ^block 5 ^color <c5>)
-    (face ^number <n> ^block 6 ^color <c6>)
-    (face ^number <n> ^block 7 ^color <c7>)
-    (face ^number <n> ^block 8 ^color <c8>)
-    (face ^number <n> ^block 9 ^color <c9>)
-    (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup>
-                 ^block 1 ^adj-blk-num <nup1>)
-    (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup>
-                 ^block 2 ^adj-blk-num <nup2>)
-    (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup>
-                 ^block 3 ^adj-blk-num <nup3>)
-    (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt>
-                 ^block 3 ^adj-blk-num <nrt3>)
-    (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt>
-                 ^block 6 ^adj-blk-num <nrt6>)
-    (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt>
-                 ^block 9 ^adj-blk-num <nrt9>)
-    (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn>
-                 ^block 7 ^adj-blk-num <ndn7>)
-    (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn>
-                 ^block 8 ^adj-blk-num <ndn8>)
-    (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn>
-                 ^block 9 ^adj-blk-num <ndn9>)
-    (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf>
-                 ^block 1 ^adj-blk-num <nlf1>)
-    (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf>
-                 ^block 4 ^adj-blk-num <nlf4>)
-    (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf>
-                 ^block 7 ^adj-blk-num <nlf7>)
-    (face ^number <nrt> ^block <nrt3> ^color <cnrt3>)
-    (face ^number <nrt> ^block <nrt6> ^color <cnrt6>)
-    (face ^number <nrt> ^block <nrt9> ^color <cnrt9>)
-    (face ^number <nlf> ^block <nlf7> ^color <cnlf7>)
-    (face ^number <nlf> ^block <nlf4> ^color <cnlf4>)
-    (face ^number <nlf> ^block <nlf1> ^color <cnlf1>)
-    (face ^number <nup> ^block <nup1> ^color <cnup1>)
-    (face ^number <nup> ^block <nup2> ^color <cnup2>)
-    (face ^number <nup> ^block <nup3> ^color <cnup3>)
-    (face ^number <ndn> ^block <ndn9> ^color <cndn9>)
-    (face ^number <ndn> ^block <ndn8> ^color <cndn8>)
-    (face ^number <ndn> ^block <ndn7> ^color <cndn7>)
--->
-    (write (crlf) rotating face <n>  the <c5> face  minus 90)
-    (modify 1 ^status done)
-    (modify 2 ^color <c3>)
-    (modify 3 ^color <c6>)
-    (modify 4 ^color <c9>)
-    (modify 5 ^color <c2>)
-    (modify 6 ^color <c5>)
-    (modify 7 ^color <c8>)
-    (modify 8. ^color <c1>)
-    (modify 9. ^color <c4>)
-    (modify 10. ^color <c7>)
-    (modify 23. ^color <cndn9>)
-    (modify 24. ^color <cndn8>)
-    (modify 25. ^color <cndn7>)
-    (modify 26. ^color <cnup1>)
-    (modify 27. ^color <cnup2>)
-    (modify 28. ^color <cnup3>)
-    (modify 29. ^color <cnrt3>)
-    (modify 30. ^color <cnrt6>)
-    (modify 31. ^color <cnrt9>)
-    (modify 32. ^color <cnlf7>)
-    (modify 33. ^color <cnlf4>)
-    (modify 34. ^color <cnlf1>))
-
-(p plus-minus-180
-    (goal ^want rotate ^object face ^number <n>
-          ^direction { << pos neg >> <dir> } ^value 180 ^id <id> ^seq <seq>
-          ^status active)
-   -(goal ^want rotate ^object face ^id <id> ^seq < <seq> ^status active)
-    (face ^number <n> ^block 1 ^color <c1>)
-    (face ^number <n> ^block 2 ^color <c2>)
-    (face ^number <n> ^block 3 ^color <c3>)
-    (face ^number <n> ^block 4 ^color <c4>)
-    (face ^number <n> ^block 5 ^color <c5>)
-    (face ^number <n> ^block 6 ^color <c6>)
-    (face ^number <n> ^block 7 ^color <c7>)
-    (face ^number <n> ^block 8 ^color <c8>)
-    (face ^number <n> ^block 9 ^color <c9>)
-    (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup>
-                 ^block 1 ^adj-blk-num <nup1>)
-    (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup>
-                 ^block 2 ^adj-blk-num <nup2>)
-    (cubie-order ^face-num <n> ^direction up ^adj-face-num <nup>
-                 ^block 3 ^adj-blk-num <nup3>)
-    (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt>
-                 ^block 3 ^adj-blk-num <nrt3>)
-    (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt>
-                 ^block 6 ^adj-blk-num <nrt6>)
-    (cubie-order ^face-num <n> ^direction rt ^adj-face-num <nrt>
-                 ^block 9 ^adj-blk-num <nrt9>)
-    (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn>
-                 ^block 7 ^adj-blk-num <ndn7>)
-    (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn>
-                 ^block 8 ^adj-blk-num <ndn8>)
-    (cubie-order ^face-num <n> ^direction dn ^adj-face-num <ndn>
-                 ^block 9 ^adj-blk-num <ndn9>)
-    (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf>
-                 ^block 1 ^adj-blk-num <nlf1>)
-    (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf>
-                 ^block 4 ^adj-blk-num <nlf4>)
-    (cubie-order ^face-num <n> ^direction lf ^adj-face-num <nlf>
-                 ^block 7 ^adj-blk-num <nlf7>)
-    (face ^number <nrt> ^block <nrt3> ^color <cnrt3>)
-    (face ^number <nrt> ^block <nrt6> ^color <cnrt6>)
-    (face ^number <nrt> ^block <nrt9> ^color <cnrt9>)
-    (face ^number <nlf> ^block <nlf7> ^color <cnlf7>)
-    (face ^number <nlf> ^block <nlf4> ^color <cnlf4>)
-    (face ^number <nlf> ^block <nlf1> ^color <cnlf1>)
-    (face ^number <nup> ^block <nup1> ^color <cnup1>)
-    (face ^number <nup> ^block <nup2> ^color <cnup2>)
-    (face ^number <nup> ^block <nup3> ^color <cnup3>)
-    (face ^number <ndn> ^block <ndn9> ^color <cndn9>)
-    (face ^number <ndn> ^block <ndn8> ^color <cndn8>)
-    (face ^number <ndn> ^block <ndn7> ^color <cndn7>)
--->
-    (write (crlf) rotating face <n>  the <c5> face  <dir> 180)
-    (modify 1 ^status done)
-    (modify 2 ^color <c9>)
-    (modify 3 ^color <c8>)
-    (modify 4 ^color <c7>)
-    (modify 5 ^color <c6>)
-    (modify 6 ^color <c5>)
-    (modify 7 ^color <c4>)
-    (modify 8. ^color <c3>)
-    (modify 9. ^color <c2>)
-    (modify 10. ^color <c1>)
-    (modify 23. ^color <cnlf7>)
-    (modify 24. ^color <cnlf4>)
-    (modify 25. ^color <cnlf1>)
-    (modify 26. ^color <cnrt3>)
-    (modify 27. ^color <cnrt6>)
-    (modify 28. ^color <cnrt9>)
-    (modify 29. ^color <cndn9>)
-    (modify 30. ^color <cndn8>)
-    (modify 31. ^color <cndn7>)
-    (modify 32. ^color <cnup1>)
-    (modify 33. ^color <cnup2>)
-    (modify 34. ^color <cnup3>))
-
-
-
-(p position_top_edge*get_defining_faces
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (face ^number 1 ^block 5 ^color <ct>)
-    (face ^number { << 2 3 4 5 >> <nf> } ^block 5 ^color <cf>)
-   -(front-face ^status active)
-   -(front-face ^number <nf> ^id <id> ^status used)
-    (face ^number <n1> ^block { << 2 4 6 8 >> <b1> } ^color <ct>)
-    (face ^number { <n2> <> <n1> } ^block { << 2 4 6 8 >> <b2> } ^color <cf>)
-    (cubie-order ^face-num <n1> ^adj-face-num <n2>
-                 ^block <b1> ^adj-blk-num <b2>)
--->
-    (make front-face ^number <nf> ^color <cf> ^id <id> ^status active)
-    (make source-face ^number <n1> ^color <ct> ^id <id> ^status active)
-    (make source-face ^number <n2> ^color <cf> ^id <id> ^status active))
-
-(p position_top_edge*desired_cubie_in_position
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number 1 ^id <id> ^status active)
-    (face-relation ^front <nf> ^top 1)
--->
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-
-(p rt-to-ft
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (front-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number <nr> ^id <id> ^status active)
-    (source-face ^number {<nt> <> <nr>} ^id <id> ^status active)
-    (face-relation ^front <nf> ^right <nr>)
--->
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-(p pt-to-ft
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (front-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number <np> ^id <id> ^status active)
-    (source-face ^number {<nt> <> <np>} ^id <id> ^status active)
-    (face-relation ^front <nf> ^posterior <np> ^right <nr> ^top <nt>)
--->
-    (make goal ^want rotate ^object face ^number <nt> ^direction pos
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <nt> ^direction neg
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction neg
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-(p lt-to-ft
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (front-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number <nl> ^id <id> ^status active)
-    (source-face ^number {<nt> <> <nl>} ^id <id> ^status active)
-    (face-relation ^front <nf> ^left <nl> ^top <nt>)
--->
-    (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-(p fr-to-ft
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (front-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number {<nr> <> <nf>} ^id <id> ^status active)
-    (face-relation ^front <nf> ^right <nr>)
--->
-    (make goal ^want rotate ^object face ^number <nf> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-(p pr-to-ft
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (front-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number <np> ^id <id> ^status active)
-    (source-face ^number {<nr> <> <np>} ^id <id> ^status active)
-    (face-relation ^front <nf> ^posterior <np> ^right <nr>)
--->
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 180 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 180 ^id <id> ^seq 3 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-(p lp-to-ft
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (front-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number <nl> ^id <id> ^status active)
-    (source-face ^number {<np> <> <nl>} ^id <id> ^status active)
-    (face-relation ^front <nf> ^posterior <np> ^left <nl>)
--->
-    (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 180 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 180 ^id <id> ^seq 3 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-(p fl-to-ft
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (front-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number {<nl> <> <nf>} ^id <id> ^status active)
-    (face-relation ^front <nf> ^left <nl>)
--->
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-(p bf-to-ft
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (front-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number <nb> ^id <id> ^status active)
-    (source-face ^number {<nf> <> <nb>} ^id <id> ^status active)
-    (face-relation ^front <nf> ^bottom <nb>)
--->
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 180 ^id <id> ^seq 1 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-(p br-to-ft
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (front-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number <nb> ^id <id> ^status active)
-    (source-face ^number {<nr> <> <nb>} ^id <id> ^status active)
-    (face-relation ^front <nf> ^right <nr> ^bottom <nb>)
--->
-    (make goal ^want rotate ^object face ^number <nb> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 180 ^id <id> ^seq 2 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-(p bp-to-ft
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (front-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number <nb> ^id <id> ^status active)
-    (source-face ^number {<np> <> <nb>} ^id <id> ^status active)
-    (face-relation ^front <nf> ^posterior <np> ^bottom <nb>)
--->
-    (make goal ^want rotate ^object face ^number <nb> ^direction pos
-               ^value 180 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 180 ^id <id> ^seq 2 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-(p bl-to-ft
-    (goal ^want position ^object top-edge ^id <id> ^status active)
-    (front-face ^number <nf> ^id <id> ^status active)
-    (source-face ^number <nb> ^id <id> ^status active)
-    (source-face ^number {<nl> <> <nb>} ^id <id> ^status active)
-    (face-relation ^front <nf> ^left <nl> ^bottom <nb>)
--->
-    (make goal ^want rotate ^object face ^number <nb> ^direction pos
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 180 ^id <id> ^seq 2 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-(p orient_top_edge
-    (goal ^want orient ^object top-edge ^id <id> ^status active)
-    (face ^number 1 ^block 5 ^color <ct>)
-    (face ^number { << 2 3 4 5 >> <nf> } ^block 5 ^color <cf>)
-    (face ^number 1 ^block { << 2 4 6 8 >> <b> } ^color <cf>)
-    (face ^number <nf> ^block 2 ^color <ct>)
-    (cubie-order ^face-num <nf> ^direction up
-                 ^adj-face-num 1 ^block 2 ^adj-blk-num <b>)
-    (face-relation ^front <nf> ^top 1 ^left <nl>)
--->
-    (make goal ^want rotate ^object face ^number <nf> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number 1 ^direction pos
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number 1 ^direction neg
-               ^value 90 ^id <id> ^seq 4 ^status active))
-
-(p position_top_corner*get_defining_faces
-    (goal ^want position ^object top-corner ^id <id> ^status active)
-   -(front-face ^id <id> ^status active)
-   -(source-face ^id <id> ^status active)
-    (face ^number 1 ^block 5 ^color <ct>)
-    (face ^number { << 2 3 4 5 >> <nf> } ^block 5 ^color <cf>)
-   -(front-face ^number <nf> ^id <id> ^status used)
-    (face ^number { <nr> <> <nf> <> 1 <> 6 } ^block 5 ^color <cr>)
-    (face-relation ^front <nf> ^right <nr> ^top 1)
-    (face ^number <n1> ^block { << 1 3 7 9 >> <b1> } ^color <ct>)
-    (face ^number { <n2> <> <n1> } ^block { << 1 3 7 9 >> <b2> } ^color <cf>)
-    (face ^number { <n3> <> <n2> } ^block { << 1 3 7 9 >> <b3> } ^color <cr>)
-    (cubie-order ^face-num <n1> ^adj-face-num <n2> ^block <b1>
-                 ^adj-blk-num <b2>)
-    (cubie-order ^face-num <n1> ^adj-face-num <n3> ^block <b1>
-                 ^adj-blk-num <b3>)
-    (cubie-order ^face-num <n2> ^adj-face-num <n3> ^block <b2>
-                 ^adj-blk-num <b3>)
--->
-    (make front-face ^number <nf> ^color <cf> ^id <id> ^status active)
-    (make source-face ^number <n1> ^color <ct> ^id <id> ^status active)
-    (make source-face ^number <n2> ^color <cf> ^id <id> ^status active)
-    (make source-face ^number <n3> ^color <cr> ^id <id> ^status active))
-
-(p position_top_corner*desired_cubie_in_position
-    (goal ^want position ^object top-corner ^id <id> ^status active)
-    (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nt> <> <nf> <> 6} ^id <id> ^status active)
-    (source-face ^number {<nr> <> <nt> <> <nf> <> 6} ^id <id> ^status active)
-    (face-relation ^front <nf> ^right <nr> ^top <nt>)
--->
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used)
-    (modify 5 ^status used))
-
-(p position_top_corner*desired_cubie_on_left_front_top
-    (goal ^want position ^object top-corner ^id <id> ^status active)
-    (front-face ^number {<n3> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number 1 ^id <id> ^status active)
-    (source-face ^number {<n2> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<n3> <> <n2> <> 1 <> 6} ^id <id> ^status active)
-    (face-relation ^front {<n2> <> 1 <> 6} ^posterior <n4> ^right <n3> ^top 1)
--->
-    (make goal ^want rotate ^object face ^number <n3> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <n3> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 180 ^id <id> ^seq 4 ^status active)
-    (make goal ^want rotate ^object face ^number <n4> ^direction neg
-               ^value 90 ^id <id> ^seq 5 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 6 ^status active)
-    (make goal ^want rotate ^object face ^number <n4> ^direction pos
-               ^value 90 ^id <id> ^seq 7 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used)
-    (modify 5 ^status used))
-
-(p position_top_corner*desired_cubie_on_top_right_posterior
-    (goal ^want position ^object top-corner ^id <id> ^status active)
-    (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number 1 ^id <id> ^status active)
-    (source-face ^number {<n2> <> <nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<n3> <> <n2> <> 1 <> 6} ^id <id> ^status active)
-    (face-relation ^front {<n2> <> 1 <> 6} ^right {<n3> <> 1 <> 6} ^top 1)
-    (face-relation ^front {<nf> <> 1 <> 6} ^right {<n2> <> 1 <> 6} ^top 1)
--->
-    (make goal ^want rotate ^object face ^number <n3> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <n3> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number <n2> ^direction neg
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 5 ^status active)
-    (make goal ^want rotate ^object face ^number <n2> ^direction pos
-               ^value 90 ^id <id> ^seq 6 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used)
-    (modify 5 ^status used))
-
-(p position_top_corner*desired_cubie_on_top_left_posterior
-    (goal ^want position ^object top-corner ^id <id> ^status active)
-    (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number 1 ^id <id> ^status active)
-    (source-face ^number {<n2> <> <nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<n3> <> <n2> <> 1 <> 6} ^id <id> ^status active)
-    (face-relation ^front {<n2> <> <nf>} ^right {<n3> <> <nf>} ^top 1)
-    (face-relation ^front <nf> ^right <n4> ^left <n3> ^top 1)
--->
-    (make goal ^want rotate ^object face ^number <n3> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 180 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <n3> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number <n4> ^direction neg
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 5 ^status active)
-    (make goal ^want rotate ^object face ^number <n4> ^direction pos
-               ^value 90 ^id <id> ^seq 6 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used)
-    (modify 5 ^status used))
-
-(p position_top_corner*desired_cubie_under_desired_position
-    (goal ^want position ^object top-corner ^id <id> ^status active)
-    (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nr> <> <nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number 6 ^id <id> ^status active)
-    (face-relation ^front <nf> ^right <nr> ^bottom 6)
--->
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used)
-    (modify 5 ^status used))
-
-(p position_top_corner*desired_cubie_on_bottom_left_front
-    (goal ^want position ^object top-corner ^id <id> ^status active)
-    (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nl> <> <nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number 6 ^id <id> ^status active)
-    (face-relation ^front <nl> ^posterior <np> ^right <nf> ^bottom 6)
--->
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <np> ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number <np> ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used)
-    (modify 5 ^status used))
-
-(p position_top_corner*desired_cubie_on_bottom_left_posterior
-    (goal ^want position ^object top-corner ^id <id> ^status active)
-    (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nl> <> <nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<np> <> <nl> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number 6 ^id <id> ^status active)
-    (face-relation ^front <nf> ^posterior <np> ^right <nr>
-                   ^left <nl> ^bottom 6)
--->
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 180 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used)
-    (modify 5 ^status used))
-
-(p position_top_corner*desired_cubie_on_bottom_right_posterior
-    (goal ^want position ^object top-corner ^id <id> ^status active)
-    (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nr> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<np> <> <nr> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number 6 ^id <id> ^status active)
-    (face-relation ^front <nf> ^posterior <np> ^right <nr> ^bottom 6)
--->
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used)
-    (modify 5 ^status used))
-
-(p orient_top_corner
-    (goal ^want orient ^object top-corner ^id <id> ^status active)
-    (face ^number 1 ^block 5 ^color <ct>)
-    (face ^number { << 2 3 4 5 >> <nf> } ^block 5 ^color <cf>)
-    (face ^number { <nr> <> <nf> <> 1 <> 6 } ^block 5 ^color <cr>)
-    (face-relation ^front <nf> ^right <nr> ^top 1 ^bottom 6)
-    (face ^number <nf> ^block 3 ^color <> <cf>)
--->
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 180 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 180 ^id <id> ^seq 5 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction neg
-               ^value 90 ^id <id> ^seq 6 ^status active))
-
-(p position_vertical_edge*get_defining_faces
-    (goal ^want position ^object vertical-edge ^id <id> ^status active)
-   -(source-face ^id <id> ^status active)
-    (face ^number { << 2 3 4 5 >> <nf> } ^block 5 ^color <cf>)
-   -(front-face ^number <nf> ^id <id> ^status used)
-    (face ^number { <nr> <> <nf> <> 1 <> 6 } ^block 5 ^color <cr>)
-    (face-relation ^front <nf> ^right <nr> ^top 1 ^bottom 6)
-    (face ^number {<n1> <> 1} ^block { << 2 4 6 8 >> <b1> } ^color <cf>)
-    (face ^number {<n2> <> <n1> <> 1} ^block { << 2 4 6 8 >> <b2> }
-          ^color <cr>)
-    (cubie-order ^face-num <n1> ^adj-face-num <n2>
-                 ^block <b1> ^adj-blk-num <b2>)
--->
-    (make front-face ^number <nf> ^color <cf> ^id <id> ^status active)
-    (make source-face ^number <n1> ^color <cf> ^id <id> ^status active)
-    (make source-face ^number <n2> ^color <cr> ^id <id> ^status active))
-
-(p position_vertical_edge*desired_cube_in_position
-    (goal ^want position ^object vertical-edge ^id <id> ^status active)
-    (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nr> <> <nf> <> 1 <> 6} ^id <id> ^status active)
-    (face-relation ^front <nf> ^right <nr> ^top 1)
--->
-    (modify 2 ^status used)
-    (modify 3 ^status used)
-    (modify 4 ^status used))
-
-(p position_vertical_edge*fr-to-bp
-    (goal ^want position ^object vertical-edge ^id <id> ^status active)
-    (front-face ^number {<n1> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number {<nr> <> <nf> <> 1 <> 6} ^id <id>
-                 ^status active)
-    (face-relation ^front <nf> ^posterior <np> ^right <nr> ^bottom 6)
-   -(face-relation ^front <n1> ^right <nr> ^bottom 6)
--->
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 5 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 6 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction neg
-               ^value 90 ^id <id> ^seq 7 ^status active)
-    (modify 3 ^number 6)
-    (modify 4 ^number <np>))
-
-(p position_vertical_edge*try_bottom_rotation
-    (goal ^want position ^object vertical-edge ^id <id> ^status active)
-    (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (source-face ^number { << 2 3 4 5 >> <ns> } ^color <cs>
-                 ^id <id>^status active)
-    (face ^number <ns> ^block 5 ^color <> <cs>)
-    (source-face ^number 6 ^id <id> ^status active)
-    (face-relation ^front <ns> ^right <nsr> ^bottom 6)
--->
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (modify 3 ^number <nsr>))
-
-(p position_vertical_edge*match_on_f-face
-    (goal ^want position ^object vertical-edge ^id <id> ^status active)
-    (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (face-relation ^front <nf> ^right <nr> ^bottom 6)
-    (face ^number <nf> ^block 5 ^color <cf>)
-    (face ^number <nf> ^block 8 ^color <cf>)
-    (face ^number <nr> ^block 5 ^color <cr>)
-    (source-face ^number {<nf> <> 1 <> 6} ^color <cf> ^id <id> ^status active)
-    (source-face ^number 6 ^color <cr> ^id <id> ^status active)
--->
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 5 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 6 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 7 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction neg
-               ^value 90 ^id <id> ^seq 8 ^status active)
-    (modify 2 ^status used)
-    (modify 7 ^status used)
-    (modify 8 ^status used))
-
-(p position_vertical_edge*match_on_r-face
-    (goal ^want position ^object vertical-edge ^id <id> ^status active)
-    (front-face ^number {<nf> <> 1 <> 6} ^id <id> ^status active)
-    (face-relation ^front <nf> ^right <nr> ^bottom 6)
-    (face ^number <nf> ^block 5 ^color <cf>)
-    (face ^number <nr> ^block 5 ^color <cr>)
-    (face ^number <nr> ^block 8 ^color <cr>)
-    (source-face ^number {<nr> <> 1 <> 6} ^color <cr> ^id <id> ^status active)
-    (source-face ^number 6 ^color <cf> ^id <id> ^status active)
--->
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction neg
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 5 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 6 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 7 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 8 ^status active)
-    (modify 2 ^status used)
-    (modify 7 ^status used)
-    (modify 8 ^status used))
-
-(p orient_vertical_edge
-    (goal ^want orient ^object vertical-edge ^id <id> ^status active)
-    (face ^number { << 2 3 4 5 >> <nf> } ^block 5 ^color <cf>)
-    (face ^number { <nr> <> <nf> <> 1 <> 6 } ^block 5 ^color <cr>)
-    (face ^number <nf> ^block 6 ^color <cr>)
-    (face ^number <nr> ^block 4 ^color <cf>)
-    (cubie-order ^face-num <nf> ^direction rt
-                 ^adj-face-num <nr> ^block 6 ^adj-blk-num 4)
-    (face-relation ^front <nf> ^top 1 ^right <nr>)
--->
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 5 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 6 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction neg
-               ^value 90 ^id <id> ^seq 7 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 8 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 9 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 10 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 11 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 12 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 13 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 14 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction neg
-               ^value 90 ^id <id> ^seq 15 ^status active))
-
-(p position_bottom_corner
-    (goal ^want position ^object bottom-corner ^id <id> ^status active)
-   -(bottom-corner ^id <id> ^status << active done >>)
-   -(goal ^want clean-up ^object bottom-corner ^id <id> ^status active)
-    (face ^number 2 ^block 9 ^color <c29>)
-    (face ^number 3 ^block 7 ^color <c37>)
-    (cubie-order ^face-num 2 ^direction dn ^adj-face-num 6
-                 ^block 9 ^adj-blk-num <blk269>)
-    (face ^number 6 ^block <blk269> ^color <c269>)
-    (face ^number 3 ^block 9 ^color <c39>)
-    (face ^number 4 ^block 7 ^color <c47>)
-    (cubie-order ^face-num 3 ^direction dn ^adj-face-num 6
-                 ^block 9 ^adj-blk-num <blk369>)
-    (face ^number 6 ^block <blk369> ^color <c369>)
-    (face ^number 4 ^block 9 ^color <c49>)
-    (face ^number 5 ^block 7 ^color <c57>)
-    (cubie-order ^face-num 4 ^direction dn ^adj-face-num 6
-                 ^block 9 ^adj-blk-num <blk469>)
-    (face ^number 6 ^block <blk469> ^color <c469>)
-    (face ^number 5 ^block 9 ^color <c59>)
-    (face ^number 2 ^block 7 ^color <c27>)
-    (cubie-order ^face-num 5 ^direction dn ^adj-face-num 6
-                 ^block 9 ^adj-blk-num <blk569>)
-    (face ^number 6 ^block <blk569> ^color <c569>)
--->
-    (make bottom-corner ^number 1 ^face 2 ^color <c29>
-                      ^id <id> ^status active)
-    (make bottom-corner ^number 1 ^face 3 ^color <c37>
-                      ^id <id> ^status active)
-    (make bottom-corner ^number 1 ^face 6 ^color <c269>
-                      ^id <id> ^status active)
-    (make bottom-corner ^number 2 ^face 3 ^color <c39>
-                      ^id <id> ^status active)
-    (make bottom-corner ^number 2 ^face 4 ^color <c47>
-                      ^id <id> ^status active)
-    (make bottom-corner ^number 2 ^face 6 ^color <c369>
-                      ^id <id> ^status active)
-    (make bottom-corner ^number 3 ^face 4 ^color <c49>
-                      ^id <id> ^status active)
-    (make bottom-corner ^number 3 ^face 5 ^color <c57>
-                      ^id <id> ^status active)
-    (make bottom-corner ^number 3 ^face 6 ^color <c469>
-                      ^id <id> ^status active)
-    (make bottom-corner ^number 4 ^face 5 ^color <c59>
-                      ^id <id> ^status active)
-    (make bottom-corner ^number 4 ^face 2 ^color <c27>
-                      ^id <id> ^status active)
-    (make bottom-corner ^number 4 ^face 6 ^color <c569>
-                      ^id <id> ^status active))
-
-(p position_bottom_corner*find_no_match
-    (goal ^want position ^object bottom-corner ^id <id> ^status active)
-   -(goal ^want clean-up ^object bottom-corner ^id <id> ^status active)
-   -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active)
-    (bottom-corner ^number 1 ^face 2 ^id <id> ^status active)
--->
-    (make goal ^want clean-up ^object bottom-corner ^id <id> ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 1 ^status active))
-
-(p position_bottom_corner*clean_up_bottom_corner
-    (goal ^want position ^object bottom-corner ^id <id> ^status active)
-    (goal ^want clean-up ^object bottom-corner ^id <id> ^status active)
-   -(goal ^want rotate ^object face ^id <id> ^status active)
-    (bottom-corner ^id <id> ^status active)
--->
-    (modify 3 ^status used))
-
-(p position_bottom_corner*clean_up_bottom_corner*exit
-    (goal ^want position ^object bottom-corner ^id <id> ^status active)
-    (goal ^want clean-up ^object bottom-corner ^id <id> ^status active)
-   -(goal ^want rotate ^object face ^id <id> ^status active)
-   -(bottom-corner ^id <id> ^status active)
--->
-    (remove 2))
-
-(p position_bottom_corner*find_one_match
-     (goal ^want position ^object bottom-corner ^id <id> ^status active)
-    -(goal ^want clean-up ^object bottom-corner ^id <id> ^status active)
-    -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active)
-    -(bottom-corner ^id <id> ^status done)
-     (face ^number <nf> ^block 5 ^color <cf>)
-     (face ^number <nr> ^block 5 ^color <cr>)
-     (face ^number <nb> ^block 5 ^color <cb>)
-     (face-relation ^front <nf> ^right <nr> ^bottom <nb>)
-     (bottom-corner ^number <n1> ^color <cf> ^status active)
-     (bottom-corner ^number <n1> ^color <cr> ^status active)
-     (bottom-corner ^number <n1> ^color <cb> ^status active)
-     (bottom-corner ^number <n1> ^face <nf> ^status active)
-     (bottom-corner ^number <n1> ^face <nr> ^status active)
-     (bottom-corner ^number <n1> ^face <nb> ^status active)
--->
-     (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 1 ^status active)
-     (make goal ^want clean-up ^object bottom-corner ^id <id> ^status active))
-
-(p position_bottom_corner*exchange_two_adjacent
-     (goal ^want position ^object bottom-corner ^id <id> ^status active)
-    -(goal ^want clean-up ^object bottom-corner ^id <id> ^status active)
-    -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active)
-    -(bottom-corner ^id <id> ^status done)
-     (face ^number <nf> ^block 5 ^color <cf>)
-     (face ^number <nl> ^block 5 ^color <cl>)
-     (face ^number <nb> ^block 5 ^color <cb>)
-     (face-relation ^front <nf> ^posterior <np> ^left <nl> ^right <nr>
-                    ^bottom <nb>)
-     (bottom-corner ^number <n1> ^color <cf> ^status active)
-     (bottom-corner ^number <n1> ^color <cl> ^status active)
-     (bottom-corner ^number <n1> ^color <cb> ^status active)
-     (bottom-corner ^number <n1> ^face <nf> ^status active)
-     (bottom-corner ^number <n1> ^face <nl> ^status active)
-     (bottom-corner ^number <n1> ^face <nb> ^status active)
-     (face ^number <nf> ^block 5 ^color <cf>)
-     (face ^number <nr> ^block 5 ^color <cr>)
-     (bottom-corner ^number {<n2> <> <n1>} ^color <cf> ^status active)
-     (bottom-corner ^number <n2> ^color <cr> ^status active)
-     (bottom-corner ^number <n2> ^color <cb> ^status active)
-     (bottom-corner ^number <n2> ^face <nf> ^status active)
-     (bottom-corner ^number <n2> ^face <nr> ^status active)
-     (bottom-corner ^number <n2> ^face <nb> ^status active)
--->
-     (make bottom-corner ^id <id> ^status done)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-     (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-     (make goal ^want rotate ^object face ^number <np> ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-     (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 5 ^status active)
-     (make goal ^want rotate ^object face ^number <np> ^direction neg
-               ^value 90 ^id <id> ^seq 6 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 7 ^status active)
-     (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 8 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 9 ^status active)
-     (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 180 ^id <id> ^seq 10 ^status active)
-     (make goal ^want clean-up ^object bottom-corner ^id <id> ^status active))
-
-(p position_bottom_corner*exchange_two_diagonal
-     (goal ^want position ^object bottom-corner ^id <id> ^status active)
-    -(goal ^want clean-up ^object bottom-corner ^id <id> ^status active)
-    -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active)
-    -(bottom-corner ^id <id> ^status done)
-     (face ^number <nf> ^block 5 ^color <cf>)
-     (face ^number <nl> ^block 5 ^color <cl>)
-     (face ^number <nb> ^block 5 ^color <cb>)
-     (face-relation ^front <nf> ^posterior <np> ^left <nl> ^right <nr>
-                    ^bottom <nb>)
-     (bottom-corner ^number <n1> ^color <cf> ^status active)
-     (bottom-corner ^number <n1> ^color <cl> ^status active)
-     (bottom-corner ^number <n1> ^color <cb> ^status active)
-     (bottom-corner ^number <n1> ^face <nf> ^status active)
-     (bottom-corner ^number <n1> ^face <nl> ^status active)
-     (bottom-corner ^number <n1> ^face <nb> ^status active)
-     (face ^number <nr> ^block 5 ^color <cr>)
-     (face ^number <np> ^block 5 ^color <cp>)
-     (face-relation ^front <nr> ^right <np> ^bottom <nb>)
-     (bottom-corner ^number {<n2> > <n1>} ^color <cr> ^status active)
-     (bottom-corner ^number <n2> ^color <cp> ^status active)
-     (bottom-corner ^number <n2> ^color <cb> ^status active)
-     (bottom-corner ^number <n2> ^face <nr> ^status active)
-     (bottom-corner ^number <n2> ^face <np> ^status active)
-     (bottom-corner ^number <n2> ^face <nb> ^status active)
--->
-     (make bottom-corner ^id <id> ^status done)
-     (make goal ^want rotate ^object face ^number <np> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-     (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-     (make goal ^want rotate ^object face ^number <np> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-     (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 180 ^id <id> ^seq 5 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 6 ^status active)
-     (make goal ^want rotate ^object face ^number <np> ^direction neg
-               ^value 90 ^id <id> ^seq 7 ^status active)
-     (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 8 ^status active)
-     (make goal ^want rotate ^object face ^number <np> ^direction pos
-               ^value 90 ^id <id> ^seq 9 ^status active)
-     (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 10 ^status active)
-     (make goal ^want clean-up ^object bottom-corner ^id <id> ^status active))
-
-(p position_bottom_corner*match_four
-     (goal ^want position ^object bottom-corner ^id <id> ^status active)
-    -(goal ^want clean-up ^object bottom-corner ^id <id> ^status active)
-    -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active)
-    -(bottom-corner ^id <id> ^status done)
-     (face ^number <n1f> ^block 5 ^color <c1f>)
-     (face ^number <n1r> ^block 5 ^color <c1r>)
-     (face ^number <nb> ^block 5 ^color <c1b>)
-     (face-relation ^front <n1f> ^right <n1r> ^bottom <nb>)
-     (bottom-corner ^number 1 ^color <c1f> ^status active)
-     (bottom-corner ^number 1 ^color <c1r> ^status active)
-     (bottom-corner ^number 1 ^color <c1b> ^status active)
-     (bottom-corner ^number 1 ^face <n1f> ^status active)
-     (bottom-corner ^number 1 ^face <n1r> ^status active)
-     (bottom-corner ^number 1 ^face <nb> ^status active)
-     (face ^number <n2f> ^block 5 ^color <c2f>)
-     (face ^number <n2r> ^block 5 ^color <c2r>)
-     (face-relation ^front <n2f> ^right <n2r> ^bottom <nb>)
-     (bottom-corner ^number 2 ^color <c2f> ^status active)
-     (bottom-corner ^number 2 ^color <c2r> ^status active)
-     (bottom-corner ^number 2 ^color <c2b> ^status active)
-     (bottom-corner ^number 2 ^face <n2f> ^status active)
-     (bottom-corner ^number 2 ^face <n2r> ^status active)
-     (bottom-corner ^number 2 ^face <nb> ^status active)
-     (face ^number <n3f> ^block 5 ^color <c3f>)
-     (face ^number <n3r> ^block 5 ^color <c3r>)
-     (face-relation ^front <n3f> ^right <n3r> ^bottom <nb>)
-     (bottom-corner ^number 3 ^color <c3f> ^status active)
-     (bottom-corner ^number 3 ^color <c3r> ^status active)
-     (bottom-corner ^number 3 ^color <c3b> ^status active)
-     (bottom-corner ^number 3 ^face <n3f> ^status active)
-     (bottom-corner ^number 3 ^face <n3r> ^status active)
-     (bottom-corner ^number 3 ^face <nb> ^status active)
-     (face ^number <n4f> ^block 5 ^color <c4f>)
-     (face ^number <n4r> ^block 5 ^color <c4r>)
-     (face-relation ^front <n4f> ^right <n4r> ^bottom <nb>)
-     (bottom-corner ^number 4 ^color <c4f> ^status active)
-     (bottom-corner ^number 4 ^color <c4r> ^status active)
-     (bottom-corner ^number 4 ^color <c4b> ^status active)
-     (bottom-corner ^number 4 ^face <n4f> ^status active)
-     (bottom-corner ^number 4 ^face <n4r> ^status active)
-     (bottom-corner ^number 4 ^face <nb> ^status active)
--->
-     (make bottom-corner ^id <id> ^status done)
-     (modify 6 ^status used)
-     (modify 7 ^status used)
-     (modify 8 ^status used)
-     (modify 15 ^status used)
-     (modify 16 ^status used)
-     (modify 17 ^status used)
-     (modify 24 ^status used)
-     (modify 25 ^status used)
-     (modify 26 ^status used)
-     (modify 33 ^status used)
-     (modify 34 ^status used)
-     (modify 35 ^status used))
-
-(p orient_bottom_corner*bc1
-    (goal ^want orient ^object bottom-corner ^id <id> ^status active)
-    (face ^number 6 ^block 5 ^color <cb>)
-    (face ^number <nf> ^block 9 ^color <cb>)
-    (face ^number <nr> ^block 9 ^color <cb>)
-    (face ^number <np> ^block 9 ^color <cb>)
-    (cubie-order ^face-num <nf> ^direction dn ^adj-face-num 6
-                 ^block 7 ^adj-blk-num <abn>)
-    (face ^number 6 ^block <abn> ^color <cb>)
-    (face-relation ^front <nf> ^right <nr> ^posterior <np> 
-                   ^top 1 ^bottom 6)
--->
-    (make vodor ^right <nr> ^bottom 6 ^id <id> ^status active))
-
-(p orient_bottom_corner*bc2
-    (goal ^want orient ^object bottom-corner ^id <id> ^status active)
-    (face ^number 6 ^block 5 ^color <cb>)
-    (face ^number <nr> ^block 7 ^color <cb>)
-    (face ^number <np> ^block 7 ^color <cb>)
-    (face ^number <nl> ^block 7 ^color <cb>)
-    (cubie-order ^face-num <nl> ^direction dn ^adj-face-num 6
-                 ^block 9 ^adj-blk-num <abn>)
-    (face ^number 6 ^block <abn> ^color <cb>)
-    (face-relation ^front <nf> ^right <nr> ^left <nl> ^posterior <np> 
-                   ^top 1 ^bottom 6)
--->
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 180 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 180 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 5 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 6 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 90 ^id <id> ^seq 7 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 8 ^status active))
-
-(p orient_bottom_corner*bc3
-    (goal ^want orient ^object bottom-corner ^id <id> ^status active)
-    (face ^number 6 ^block 5 ^color <cb>)
-    (face ^number <nr> ^block 7 ^color <cb>)
-    (face ^number <np> ^block 7 ^color <cb>)
-    (face ^number <np> ^block 9 ^color <cb>)
-    (face ^number <nl> ^block 9 ^color <cb>)
-    (face-relation ^front <nf> ^right <nr> ^left <nl> ^posterior <np> 
-                   ^top 1 ^bottom 6)
--->
-    (make vodor ^right <nr> ^bottom 6 ^id <id> ^status active))
-
-(p orient_bottom_corner*bc4
-    (goal ^want orient ^object bottom-corner ^id <id> ^status active)
-    (face ^number 6 ^block 5 ^color <cb>)
-    (face ^number <nf> ^block 7 ^color <cb>)
-    (face ^number <np> ^block 9 ^color <cb>)
-    (face-relation ^front <nf> ^right <nr> ^posterior <np> 
-                   ^top 1 ^bottom 6)
-    (cubie-order ^face-num <nf> ^direction dn ^adj-face-num 6
-                 ^block 9 ^adj-blk-num <abn1>)
-    (face ^number 6 ^block <abn1> ^color <cb>)
-    (cubie-order ^face-num <np> ^direction dn ^adj-face-num 6
-                 ^block 7 ^adj-blk-num <abn2>)
-    (face ^number 6 ^block <abn2> ^color <cb>)
--->
-    (make vodor ^right <nr> ^bottom 6 ^id <id> ^status active))
-
-(p orient_bottom_corner*bc5
-    (goal ^want orient ^object bottom-corner ^id <id> ^status active)
-    (face ^number 6 ^block 5 ^color <cb>)
-    (face ^number <nf> ^block 7 ^color <cb>)
-    (face ^number <nf> ^block 9 ^color <cb>)
-    (face-relation ^front <nf> ^right <nr> ^posterior <np> 
-                   ^top 1 ^bottom 6)
-    (cubie-order ^face-num <np> ^direction dn ^adj-face-num 6
-                 ^block 7 ^adj-blk-num <abn1>)
-    (face ^number 6 ^block <abn1> ^color <cb>)
-    (cubie-order ^face-num <np> ^direction dn ^adj-face-num 6
-                 ^block 9 ^adj-blk-num <abn2>)
-    (face ^number 6 ^block <abn2> ^color <cb>)
--->
-    (make vodor ^right <nr> ^bottom 6 ^id <id> ^status active))
-
-(p orient_bottom_corner*bc6
-    (goal ^want orient ^object bottom-corner ^id <id> ^status active)
-    (face ^number 6 ^block 5 ^color <cb>)
-    (face ^number <nf> ^block 7 ^color <cb>)
-    (face ^number <nr> ^block 9 ^color <cb>)
-    (face-relation ^front <nf> ^right <nr> ^posterior <np> 
-                   ^top 1 ^bottom 6)
-    (cubie-order ^face-num <nf> ^direction dn ^adj-face-num 6
-                 ^block 9 ^adj-blk-num <abn1>)
-    (face ^number 6 ^block <abn1> ^color <cb>)
-    (cubie-order ^face-num <np> ^direction dn ^adj-face-num 6
-                 ^block 9 ^adj-blk-num <abn2>)
-    (face ^number 6 ^block <abn2> ^color <cb>)
--->
-    (make vodor ^right <nr> ^bottom 6 ^id <id> ^status active))
-
-(p orient_bottom_corner*bc7
-    (goal ^want orient ^object bottom-corner ^id <id> ^status active)
-    (face ^number 6 ^block 5 ^color <cb>)
-    (face ^number <nr> ^block 7 ^color <cb>)
-    (face ^number <nr> ^block 9 ^color <cb>)
-    (face ^number <nl> ^block 7 ^color <cb>)
-    (face ^number <nl> ^block 9 ^color <cb>)
-    (face-relation ^front <nf> ^right <nr> ^left <nl> ^posterior <np> 
-                   ^top 1 ^bottom 6)
--->
-    (make vodor ^right <nr> ^bottom 6 ^id <id> ^status active))
-
-(p orient_bottom_corner*rotate_utility
-    (goal ^want orient ^object bottom-corner ^id <id> ^status active)
-    (vodor ^right <nr> ^bottom 6 ^id <id> ^status active)
--->
-    (modify 2 ^status used)
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction neg
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 5 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 180 ^id <id> ^seq 6 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 7 ^status active)
-    (make goal ^want rotate ^object face ^number 6 ^direction pos
-               ^value 180 ^id <id> ^seq 8 ^status active))
-
-(p position_orient_bottom_edge*make_bottom_edges
-    (goal ^want << position orient >> ^object bottom-edge ^id <id>
-          ^status active)
-   -(bottom-edge ^id <id> ^status << active done >>)
-   -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active)
-    (face ^number 2 ^block 8 ^color <c28>)
-    (cubie-order ^face-num 2 ^direction dn ^adj-face-num 6
-                 ^block 8 ^adj-blk-num <blk268>)
-    (face ^number 6 ^block <blk268> ^color <c268>)
-    (face ^number 3 ^block 8 ^color <c38>)
-    (cubie-order ^face-num 3 ^direction dn ^adj-face-num 6
-                 ^block 8 ^adj-blk-num <blk368>)
-    (face ^number 6 ^block <blk368> ^color <c368>)
-    (face ^number 4 ^block 8 ^color <c48>)
-    (cubie-order ^face-num 4 ^direction dn ^adj-face-num 6
-                 ^block 8 ^adj-blk-num <blk468>)
-    (face ^number 6 ^block <blk468> ^color <c468>)
-    (face ^number 5 ^block 8 ^color <c58>)
-    (cubie-order ^face-num 5 ^direction dn ^adj-face-num 6
-                 ^block 8 ^adj-blk-num <blk568>)
-    (face ^number 6 ^block <blk568> ^color <c568>)
--->
-    (make bottom-edge ^number 1 ^face 2 ^color <c28>
-                      ^id <id> ^status active)
-    (make bottom-edge ^number 1 ^face 6 ^color <c268>
-                      ^id <id> ^status active)
-    (make bottom-edge ^number 2 ^face 3 ^color <c38>
-                      ^id <id> ^status active)
-    (make bottom-edge ^number 2 ^face 6 ^color <c368>
-                      ^id <id> ^status active)
-    (make bottom-edge ^number 3 ^face 4 ^color <c48>
-                      ^id <id> ^status active)
-    (make bottom-edge ^number 3 ^face 6 ^color <c468>
-                      ^id <id> ^status active)
-    (make bottom-edge ^number 4 ^face 5 ^color <c58>
-                      ^id <id> ^status active)
-    (make bottom-edge ^number 4 ^face 6 ^color <c568>
-                      ^id <id> ^status active))
-
-(p position_bottom_edge*find_no_match
-     (goal ^want position ^object bottom-edge ^id <id> ^status active)
-    -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active)
-    -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active)
-     (bottom-edge ^number 1 ^face 2 ^id <id> ^status active)
--->
-     (make goal ^want clean-up ^object bottom-edge ^id <id> ^status active)
-     (make vodor ^right 4 ^left 2 ^front 3 ^bottom 6 ^id <id>
-                       ^status active))
-
-(p position_bottom_edge*clean_up_bottom_edge
-    (goal ^want position ^object bottom-edge ^id <id> ^status active)
-    (goal ^want clean-up ^object bottom-edge ^id <id> ^status active)
-   -(goal ^want rotate ^object face ^id <id> ^status active)
-    (bottom-edge ^id <id> ^status active)
--->
-    (modify 3 ^status used))
-
-(p position_bottom_edge*clean_up_bottom_edge*exit
-    (goal ^want position ^object bottom-edge ^id <id> ^status active)
-    (goal ^want clean-up ^object bottom-edge ^id <id> ^status active)
-   -(goal ^want rotate ^object face ^id <id> ^status active)
-   -(bottom-edge ^id <id> ^status active)
--->
-    (remove 2))
-
-(p position_bottom_edge*find_one_match
-     (goal ^want position ^object bottom-edge ^id <id> ^status active)
-    -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active)
-    -(goal ^want rotate ^object face ^number 6 ^id <id> ^status active)
-    -(bottom-edge ^id <id> ^status done)
-     (face ^number <nf> ^block 5 ^color <cf>)
-     (face ^number <nb> ^block 5 ^color <cb>)
-     (face-relation ^front <nf> ^right <nr> ^left <nl> ^bottom <nb>)
-     (bottom-edge ^number <n1> ^color <cf> ^status active)
-     (bottom-edge ^number <n1> ^color <cb> ^status active)
-     (bottom-edge ^number <n1> ^face <nf> ^status active)
-     (bottom-edge ^number <n1> ^face <nb> ^status active)
--->
-     (make vodor ^right <nr> ^left <nl> ^front <nf> ^bottom <nb> ^id <id>
-                       ^status active)
-     (make goal ^want clean-up ^object bottom-edge ^id <id> ^status active))
-
-(p position_bottom_edge*match_four
-     (goal ^want position ^object bottom-edge ^id <id> ^status active)
-    -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active)
-    -(goal ^want rotate ^object face ^id <id> ^status active)
-    -(bottom-edge ^id <id> ^status done)
-     (face ^number <n1f> ^block 5 ^color <c1f>)
-     (face ^number <nb> ^block 5 ^color <cb>)
-     (face-relation ^front <n1f> ^bottom <nb>)
-     (bottom-edge ^number 1 ^color <c1f> ^status active)
-     (bottom-edge ^number 1 ^color <cb> ^status active)
-     (bottom-edge ^number 1 ^face <n1f> ^status active)
-     (bottom-edge ^number 1 ^face <nb> ^status active)
-     (face ^number <n2f> ^block 5 ^color <c2f>)
-     (face-relation ^front <n2f> ^bottom <nb>)
-     (bottom-edge ^number 2 ^color <c2f> ^status active)
-     (bottom-edge ^number 2 ^color <cb> ^status active)
-     (bottom-edge ^number 2 ^face <n2f> ^status active)
-     (bottom-edge ^number 2 ^face <nb> ^status active)
-     (face ^number <n3f> ^block 5 ^color <c3f>)
-     (face-relation ^front <n3f> ^bottom <nb>)
-     (bottom-edge ^number 3 ^color <c3f> ^status active)
-     (bottom-edge ^number 3 ^color <cb> ^status active)
-     (bottom-edge ^number 3 ^face <n3f> ^status active)
-     (bottom-edge ^number 3 ^face <nb> ^status active)
-     (face ^number <n4f> ^block 5 ^color <c4f>)
-     (face-relation ^front <n4f> ^bottom <nb>)
-     (bottom-edge ^number 4 ^color <c4f> ^status active)
-     (bottom-edge ^number 4 ^color <cb> ^status active)
-     (bottom-edge ^number 4 ^face <n4f> ^status active)
-     (bottom-edge ^number 4 ^face <nb> ^status active)
--->
-     (make bottom-edge ^id <id> ^status done)
-     (modify 5 ^status used)
-     (modify 6 ^status used)
-     (modify 11 ^status used)
-     (modify 12 ^status used)
-     (modify 17 ^status used)
-     (modify 18 ^status used)
-     (modify 23 ^status used)
-     (modify 24 ^status used))
-
-(p orient_bottom_edge*be1
-     (goal ^want orient ^object bottom-edge ^id <id> ^status active)
-    -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active)
-    -(goal ^want rotate ^object face ^id <id> ^status active)
-    -(bottom-edge ^id <id> ^status done)
-     (face ^number {2 <nf>} ^block 5 ^color <cf>)
-     (face ^number <nb> ^block 5 ^color <cb>)
-     (face-relation ^front <nf> ^posterior <np> ^right <nr> ^left <nl>
-                    ^bottom <nb>)
-     (bottom-edge ^number <n1> ^face <nf> ^color <cb> ^status active)
-     (bottom-edge ^number <n1> ^face <nb> ^color <cf> ^status active)
-     (face ^number <nr> ^block 5 ^color <cr>)
-     (bottom-edge ^number <n2> ^face <nr> ^color <cb> ^status active)
-     (bottom-edge ^number <n2> ^face <nb> ^color <cr> ^status active)
-     (face ^number <np> ^block 5 ^color <cp>)
-     (bottom-edge ^number <n3> ^face <np> ^color <cb> ^status active)
-     (bottom-edge ^number <n3> ^face <nb> ^color <cp> ^status active)
-     (face ^number <nl> ^block 5 ^color <cl>)
-     (bottom-edge ^number <n4> ^face <nl> ^color <cb> ^status active)
-     (bottom-edge ^number <n4> ^face <nb> ^color <cl> ^status active)
--->
-     (make bottom-edge ^id <id> ^status done)
-     (modify 5 ^status used)
-     (modify 6 ^status used)
-     (modify 8 ^status used)
-     (modify 9 ^status used)
-     (modify 11 ^status used)
-     (modify 12 ^status used)
-     (modify 14 ^status used)
-     (modify 15 ^status used)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 2 ^status active)
-     (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 180 ^id <id> ^seq 3 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 5 ^status active)
-     (make goal ^want rotate ^object face ^number <nb> ^direction pos
-               ^value 180 ^id <id> ^seq 6 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 7 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 8 ^status active)
-     (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 9 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 10 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 11 ^status active)
-     (make goal ^want rotate ^object face ^number <nb> ^direction pos
-               ^value 180 ^id <id> ^seq 12 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 13 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 14 ^status active)
-     (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 180 ^id <id> ^seq 15 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 16 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 17 ^status active)
-     (make goal ^want rotate ^object face ^number <nb> ^direction neg
-               ^value 90 ^id <id> ^seq 18 ^status active))
-
-(p orient_bottom_edge*be2
-     (goal ^want orient ^object bottom-edge ^id <id> ^status active)
-    -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active)
-    -(goal ^want rotate ^object face ^id <id> ^status active)
-    -(bottom-edge ^id <id> ^status done)
-     (face ^number <nf> ^block 5 ^color <cf>)
-     (face ^number <nb> ^block 5 ^color <cb>)
-     (face-relation ^front <nf> ^posterior <np> ^right <nr> ^left <nl>
-                    ^bottom <nb>)
-     (bottom-edge ^number <n1> ^face <nf> ^color <cb> ^status active)
-     (bottom-edge ^number <n1> ^face <nb> ^color <cf> ^status active)
-     (face ^number <nr> ^block 5 ^color <cr>)
-     (bottom-edge ^number <n2> ^face <nr> ^color <cr> ^status active)
-     (bottom-edge ^number <n2> ^face <nb> ^color <cb> ^status active)
-     (face ^number <np> ^block 5 ^color <cp>)
-     (bottom-edge ^number <n3> ^face <np> ^color <cb> ^status active)
-     (bottom-edge ^number <n3> ^face <nb> ^color <cp> ^status active)
-     (face ^number <nl> ^block 5 ^color <cl>)
-     (bottom-edge ^number <n4> ^face <nl> ^color <cl> ^status active)
-     (bottom-edge ^number <n4> ^face <nb> ^color <cb> ^status active)
--->
-     (make bottom-edge ^id <id> ^status done)
-     (modify 5 ^status used)
-     (modify 6 ^status used)
-     (modify 8 ^status used)
-     (modify 9 ^status used)
-     (modify 11 ^status used)
-     (modify 12 ^status used)
-     (modify 14 ^status used)
-     (modify 15 ^status used)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 2 ^status active)
-     (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 5 ^status active)
-     (make goal ^want rotate ^object face ^number <nb> ^direction pos
-               ^value 90 ^id <id> ^seq 6 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 7 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 8 ^status active)
-     (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 9 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 10 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 11 ^status active)
-     (make goal ^want rotate ^object face ^number <nb> ^direction pos
-               ^value 90 ^id <id> ^seq 12 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 13 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 14 ^status active)
-     (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 180 ^id <id> ^seq 15 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 16 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 17 ^status active)
-     (make goal ^want rotate ^object face ^number <nb> ^direction pos
-               ^value 90 ^id <id> ^seq 18 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 19 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 20 ^status active)
-     (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq  21 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 22 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 23 ^status active)
-     (make goal ^want rotate ^object face ^number <nb> ^direction pos
-               ^value 90 ^id <id> ^seq 24 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 25 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 26 ^status active)
-     (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 27 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 28 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 29 ^status active)
-     (make goal ^want rotate ^object face ^number <nb> ^direction pos
-               ^value 180 ^id <id> ^seq 30 ^status active))
-
-(p orient_bottom_edge*be3
-     (goal ^want orient ^object bottom-edge ^id <id> ^status active)
-    -(goal ^want clean-up ^object bottom-edge ^id <id> ^status active)
-    -(goal ^want rotate ^object face ^id <id> ^status active)
-    -(bottom-edge ^id <id> ^status done)
-     (face ^number <nf> ^block 5 ^color <cf>)
-     (face ^number <nb> ^block 5 ^color <cb>)
-     (face-relation ^front <nf> ^posterior <np> ^right <nr> ^left <nl>
-                    ^bottom <nb>)
-     (bottom-edge ^number <n1> ^face <nf> ^color <cf> ^status active)
-     (bottom-edge ^number <n1> ^face <nb> ^color <cb> ^status active)
-     (face ^number <nr> ^block 5 ^color <cr>)
-     (bottom-edge ^number <n2> ^face <nr> ^color <cr> ^status active)
-     (bottom-edge ^number <n2> ^face <nb> ^color <cb> ^status active)
-     (face ^number <np> ^block 5 ^color <cp>)
-     (bottom-edge ^number <n3> ^face <np> ^color <cb> ^status active)
-     (bottom-edge ^number <n3> ^face <nb> ^color <cp> ^status active)
-     (face ^number <nl> ^block 5 ^color <cl>)
-     (bottom-edge ^number <n4> ^face <nl> ^color <cb> ^status active)
-     (bottom-edge ^number <n4> ^face <nb> ^color <cl> ^status active)
-     (goal ^id <oldid>)
-    -(goal ^id > <oldid>)
--->
-     (modify 1 ^status done)
-     (modify 1 ^want position ^object bottom-edge ^id (compute <oldid> + 1)
-                ^status active)
-     (make bottom-edge ^id <id> ^status done)
-     (modify 5 ^status used)
-     (modify 6 ^status used)
-     (modify 8 ^status used)
-     (modify 9 ^status used)
-     (modify 11 ^status used)
-     (modify 12 ^status used)
-     (modify 14 ^status used)
-     (modify 15 ^status used)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 2 ^status active)
-     (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 5 ^status active)
-     (make goal ^want rotate ^object face ^number <nb> ^direction neg
-               ^value 90 ^id <id> ^seq 6 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 7 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 8 ^status active)
-     (make goal ^want rotate ^object face ^number <nf> ^direction neg
-               ^value 90 ^id <id> ^seq 9 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 10 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 11 ^status active)
-     (make goal ^want rotate ^object face ^number <nb> ^direction neg
-               ^value 90 ^id <id> ^seq 12 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 13 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 14 ^status active)
-     (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 180 ^id <id> ^seq 15 ^status active)
-     (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 16 ^status active)
-     (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 17 ^status active))
-
-(p orient_position_bottom_edge*rotate_utility
-    (goal ^want { << orient position >> <w> } ^object bottom-edge ^id <id>
-          ^status active)
-    (vodor ^right <nr> ^left <nl> ^front <nf> ^bottom <nb> ^id <id>
-          ^status active)
--->
-    (modify 2 ^status used)
-    (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 1 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 2 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 3 ^status active)
-    (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 4 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 5 ^status active)
-    (make goal ^want rotate ^object face ^number <nb> ^direction pos
-               ^value 180 ^id <id> ^seq 6 ^status active)
-    (make goal ^want rotate ^object face ^number <nl> ^direction neg
-               ^value 90 ^id <id> ^seq 7 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction pos
-               ^value 90 ^id <id> ^seq 8 ^status active)
-    (make goal ^want rotate ^object face ^number <nf> ^direction pos
-               ^value 90 ^id <id> ^seq 9 ^status active)
-    (make goal ^want rotate ^object face ^number <nl> ^direction pos
-               ^value 90 ^id <id> ^seq 10 ^status active)
-    (make goal ^want rotate ^object face ^number <nr> ^direction neg
-               ^value 90 ^id <id> ^seq 11 ^status active))
-
-
-
-
-
-
-
-
-
-
-
diff --git a/contrib/ops/test1.ops b/contrib/ops/test1.ops
deleted file mode 100644
index a257cb2a2dec3df7d4393bac13ef0287bb75e742..0000000000000000000000000000000000000000
--- a/contrib/ops/test1.ops
+++ /dev/null
@@ -1,21 +0,0 @@
-(literalize c1  a1 a2)
-(literalize c2  a1 a2)
-(literalize c3  a1 a2)
-
-(p p1 
-	(start)
-    -->
-	(make c1 ^a1 5    ^a2 foo)
-	(make c2 ^a1 foo  ^a2 1  )
-	(make c3 ^a1 5    ^a2 foo)
-	(make c1 ^a1 10   ^a2 foo))
-	      
-
-
-(p p2
-	(c1  ^a1 <x>   ^a2 <y>)
-	(c2  ^a1 <y>   ^a2 < <x>)
-      - (c3  ^a1 <x>   ^a2 foo)
-   -->
-	(write    --------  x: <x> all fine --------- (crlf)))
-
diff --git a/contrib/ops/test2.ops b/contrib/ops/test2.ops
deleted file mode 100644
index dba08b059b1b0474b8d3be5f5e2ffbccdd8ffaeb..0000000000000000000000000000000000000000
--- a/contrib/ops/test2.ops
+++ /dev/null
@@ -1,74 +0,0 @@
-
-(literalize loop                 ;  loop counter
-	count)
-(literalize buf                  ;  input buffer
-	input)
-(literalize buffield             ;  holds an atom from the input
-	extracted value)
-
-(vector-attribute input)
-
-(literal extracted = 2
-         value     = 3)
-
-; Test acceptline
-
-(p p1
-	 (start)      		;  begin here
-	-->
-	 (make loop ^count 1)
-	 (make buffield ^extracted FALSE ^value nil) )
-
-
-(p p2
-	 (loop ^count 1)        ;  Get a new line of input
-	-->
-	 (write (crlf) Enter a line of "input: ")
-	 (make buf ^input (acceptline nothing read))
-	 (modify 1 ^count 2) )
-
-
-
-
-(p p3
-	 (loop ^count { <x> > 1 < 128 })    ;  Extract a field
-	 (buf ^input <> end-of-file)
-	 (buffield ^extracted FALSE)
-	-->
- 	 (modify 3 ^extracted TRUE ^value (substr 2 <x>  <x>)) )
-
-
-
-(p p4
-	(loop ^count <x>)     	;  Print non-nil field
-	(buffield ^extracted TRUE ^value { <v> <> nil })
-       -->
-        (write (crlf) Field <x> is <v>)
-        (modify 1 ^count (compute (<x> + 1)))
-	(modify 2 ^extracted FALSE) )
-
-
-
-(p p5
-	(loop ^count <x>)     	;  Skip over nil field
-	(buffield ^extracted TRUE ^value nil)
-       -->
-        (modify 1 ^count (compute (<x> + 1)))
-	(modify 2 ^extracted FALSE) )
-
-
-
-(p p6
-	(loop ^count 128)     	;  Start over again
-	(buf)
-       -->
-	(modify 1 ^count 1)
-	(remove 2) )
-
-
-
-(p p7
-	(buf ^input end-of-file)     ;  Exit on EOF
-       -->
-	(write (crlf) End-of-file reached in input.)
-	(halt) )
diff --git a/contrib/ops/test3.ops b/contrib/ops/test3.ops
deleted file mode 100644
index 539650eb9cf17cc00028ddb1c8716755e38467e8..0000000000000000000000000000000000000000
--- a/contrib/ops/test3.ops
+++ /dev/null
@@ -1,110 +0,0 @@
-
-
-(literalize component)	(literalize context)	(literalize pcon)	(literalize datum)
-(literalize computation)	(literalize setattr)	(literalize template)	(literalize interaction)
-(literalize lineitem)	(literalize local)	(literalize discrlist)	(literalize task)
-(literalize arg)	(literalize call)	(literalize order)	(literalize wip)
-(literalize location)	(literalize input)	(literalize object)	(literalize x)
-(literalize status)	(literalize place)	(literalize time)	(literalize port)
-(literalize module)	(literalize link)	(literalize lists)	(literalize outnode)
-(literalize operator)	(literalize current)	(literalize attval)	(literalize choice)
-(literalize applied)	(literalize stateop)	(literalize exit)
-(literalize component0)	(literalize context0)	(literalize pcon0)	(literalize datum0)
-(literalize computation0)	(literalize setattr0)	(literalize template0)	(literalize interaction0)
-(literalize lineitem0)	(literalize local0)	(literalize discrlist0)	(literalize task0)
-(literalize arg0)	(literalize call0)	(literalize order0)	(literalize wip0)
-(literalize location0)	(literalize input0)	(literalize object0)	(literalize x0)
-(literalize status0)	(literalize place0)	(literalize time0)	(literalize port0)
-(literalize module0)	(literalize link0)	(literalize lists0)	(literalize outnode0)
-(literalize operator0)	(literalize current0)	(literalize attval0)	(literalize choice0)
-(literalize applied0)	(literalize stateop0)	(literalize exit0)
-(literalize tank)	(literalize pipe)	(literalize measurement)	(literalize reading)
-(literalize goal)	(literalize material)
-
-(literalize primer
-	spacer
-	role
-	cnt
-	null)
-
-(literalize count
-	spacer
-	role
-	null
-	val
-	delta
-	null2)
-
-
-
-(p start
-	(start)
-    -->
-    	(remove 1)
-	(make primer    ^role exist    ^cnt 1)
-	(make primer    ^role exist    ^cnt 2)
-	(make primer    ^role exist    ^cnt 3)
-	(make primer    ^role exist    ^cnt 4)
-	(make primer    ^role exist    ^cnt 5)
-	(make primer    ^role exist    ^cnt 6)
-	(make primer    ^role exist    ^cnt 7)
-	(make primer    ^role exist    ^cnt 8)
-	(make primer    ^role exist    ^cnt 9)
-	(make primer    ^role exist    ^cnt 10)
-	(make primer    ^role exist    ^cnt 11)
-	(make primer    ^role exist    ^cnt 12)
-	(make primer    ^role exist    ^cnt 13)
-	(make primer    ^role exist    ^cnt 14)
-	(make primer    ^role exist    ^cnt 15)
-	(make primer    ^role exist    ^cnt 16)
-	(make primer    ^role exist    ^cnt 17)
-	(make primer    ^role exist    ^cnt 18)
-	(make primer    ^role exist    ^cnt 19)
-	(make primer    ^role exist    ^cnt 20)
-	(make primer    ^role exist    ^cnt 21)
-	(make primer    ^role exist    ^cnt 22)
-	(make primer    ^role exist    ^cnt 23)
-	(make primer    ^role exist    ^cnt 24)
-	(make primer    ^role exist    ^cnt 25)
-	(make primer    ^role exist    ^cnt 26)
-	(make primer    ^role exist    ^cnt 27)
-	(make primer    ^role exist    ^cnt 28)
-	(make primer    ^role exist    ^cnt 29)
-	(make primer    ^role exist    ^cnt 30)
-	(make count    ^role exist    ^val 1    ^delta 7)
-	(make count    ^role exist    ^val 2    ^delta 7)
-	(make count    ^role exist    ^val 3    ^delta 7)
-	(make count    ^role exist    ^val 4    ^delta 7)
-	(make count    ^role exist    ^val 5    ^delta 7)
-	(make count    ^role exist    ^val 6    ^delta 7)
-	(make count    ^role exist    ^val 7    ^delta 7)
-	(make primer    ^role driver    ^cnt -1))
-
-
-
-(p driver
-	(primer    ^role driver    ^null <x>)
-	(count    ^null <x>    ^val <val>    ^delta <delta>)
-    -	(count    ^val < <val>)
-    -->
-    	(modify 2 ^val  (compute <val> + <delta>)))
-
-
-(p driverCopy
-	(primer    ^role driver    ^null <x>)
-	(count    ^null <x>    ^val <val>    ^delta <delta>)
-    -	(count    ^val < <val>)
-    -->
-    	(modify 2 ^val  (compute <val> + <delta>)))
-
-
-
-(p cs
-	(primer    ^role exist    ^cnt <= 2)
-	(primer    ^role exist    ^cnt <= 2)
-	(primer    ^role exist    ^cnt <= 2)
-	(primer    ^role exist    ^cnt <= 1)
-	(primer    ^role exist    ^cnt <= 1)
-	(primer    ^role exist    ^cnt <= 1)
-    -->
-    	(halt))
diff --git a/contrib/ops/tourney.ops b/contrib/ops/tourney.ops
deleted file mode 100644
index edfef50c56f2eaa39b5433718943871e7c0d8fb9..0000000000000000000000000000000000000000
--- a/contrib/ops/tourney.ops
+++ /dev/null
@@ -1,299 +0,0 @@
-
-(literalize player
-  number
-  nights-scheduled)
-
-(literalize foursome
-  night
-  group
-  north
-  south
-  east
-  west)
-
-(literalize context
-  name)
-
-(literalize scheduling
-  night)
-
-(literalize already-played
-  player1
-  player2)
-
-(literalize candidate
-  group
-  chosen
-  south
-  east
-  west)
-
-
-(p startup 
-  (start)
--->
-  (make player ^number 1 ^nights-scheduled 0)
-  (make player ^number 2 ^nights-scheduled 0)
-  (make player ^number 3 ^nights-scheduled 0)
-  (make player ^number 4 ^nights-scheduled 0)
-  (make player ^number 5 ^nights-scheduled 0)
-  (make player ^number 6 ^nights-scheduled 0)
-  (make player ^number 7 ^nights-scheduled 0)
-  (make player ^number 8 ^nights-scheduled 0)
-  (make player ^number 9 ^nights-scheduled 0)
-  (make player ^number 10 ^nights-scheduled 0)
-  (make player ^number 11 ^nights-scheduled 0)
-  (make player ^number 12 ^nights-scheduled 0)
-  (make player ^number 13 ^nights-scheduled 0)
-  (make player ^number 14 ^nights-scheduled 0)
-  (make player ^number 15 ^nights-scheduled 0)
-  (make player ^number 16 ^nights-scheduled 0)
-  (make foursome ^night 1 ^group a ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 1 ^group b ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 1 ^group c ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 1 ^group d ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 2 ^group a ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 2 ^group b ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 2 ^group c ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 2 ^group d ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 3 ^group a ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 3 ^group b ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 3 ^group c ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 3 ^group d ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 4 ^group a ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 4 ^group b ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 4 ^group c ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 4 ^group d ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 5 ^group a ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 5 ^group b ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 5 ^group c ^north nil ^south nil ^east nil ^west nil)
-  (make foursome ^night 5 ^group d ^north nil ^south nil ^east nil ^west nil)
-  (make context ^name north)
-  (make scheduling ^night 1)
-  (write (tabto 32) |Tournament Schedule| (crlf) (crlf)
-	 (tabto 15) |N  S  E  W|
-	 (tabto 42) |N  S  E  W|
-	 (tabto 68) |N  S  E  W| (crlf)
-	 (tabto 15) |=  =  =  =|
-	 (tabto 42) |=  =  =  =|
-	 (tabto 68) |=  =  =  =| (crlf)))
-
-(p north-pick-one-1
-  (context ^name north)
-  (scheduling ^night <n>)
-  { <THE-FOURSOME> (foursome ^night <n> ^north nil) }
-  { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) }
-  (foursome ^night <n> ^north { <p1> <> nil })
-  (foursome ^night <n> ^north { <p2> <> <p1> <> nil })
-  (foursome ^night <n> ^north { <p3> <> <p2> <> <p1> <> nil })
-  (already-played ^player1 <p> ^player2 <p1>)
-  (already-played ^player1 <p> ^player2 <p2>)
-  (already-played ^player1 <p> ^player2 <p3>)
--->
-  (modify <THE-PLAYER> ^nights-scheduled <n>)
-  (modify <THE-FOURSOME> ^north <p>) )
-
-(p north-pick-one-2
-  (context ^name north)
-  (scheduling ^night <n>)
-  { <THE-FOURSOME> (foursome ^night <n> ^north nil) }
-  { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) }
-  (foursome ^night <n> ^north { <p1> <> nil })
-  (foursome ^night <n> ^north { <p2> <> <p1> <> nil })
-  (already-played ^player1 <p> ^player2 <p1>)
-  (already-played ^player1 <p> ^player2 <p2>)
--->
-  (modify <THE-PLAYER> ^nights-scheduled <n>)
-  (modify <THE-FOURSOME> ^north <p>) )
-
-(p north-pick-one-3
-  (context ^name north)
-  (scheduling ^night <n>)
-  { <THE-FOURSOME> (foursome ^night <n> ^north nil) }
-  { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) }
-  (foursome ^night <n> ^north { <p1> <> nil })
-  (already-played ^player1 <p> ^player2 <p1>)
--->
-  (modify <THE-PLAYER> ^nights-scheduled <n>)
-  (modify <THE-FOURSOME> ^north <p>) )
-
-(p north-pick-one-4
-  (context ^name north)
-  (scheduling ^night <n>)
-  { <THE-FOURSOME> (foursome ^night <n> ^north nil) }
-  { <THE-PLAYER> (player ^number <p> ^nights-scheduled < <n>) }
--->
-  (modify <THE-PLAYER> ^nights-scheduled <n>)
-  (modify <THE-FOURSOME> ^north <p>) )
-
-(p north-done
-  { <THE-CONTEXT> (context ^name north) }
--->
-  (modify <THE-CONTEXT> ^name make-candidates))
-
-(p make-candidates-make-candidate
-  (context ^name make-candidates)
-  (scheduling ^night { <n> < 3 })
-  (foursome ^night <n> ^group <g> ^north <yankee>)
-  (player ^number <redneck> ^nights-scheduled < <n>)
-  (player ^number { <oriental> < <redneck> } ^nights-scheduled < <n>)
-  (player ^number { <cowboy> < <oriental> } ^nights-scheduled < <n>)
-  - (already-played ^player1 <yankee> ^player2 <redneck>)
-  - (already-played ^player1 <yankee> ^player2 <oriental>)
-  - (already-played ^player1 <yankee> ^player2 <cowboy>)
-  - (already-played ^player1 <redneck> ^player2 <oriental>)
-  - (already-played ^player1 <redneck> ^player2 <cowboy>)
-  - (already-played ^player1 <oriental> ^player2 <cowboy>)
-  - (candidate ^group <g> ^chosen no ^south <redneck> ^east <oriental>)
-  - (candidate ^group <g> ^chosen no ^south <redneck> ^west <cowboy>)
-  - (candidate ^group <g> ^chosen no ^east <oriental> ^west <cowboy>)
--->
-  (make candidate ^group <g> ^chosen no
-	 ^south <redneck> ^east <oriental> ^west <cowboy>))
-
-(p make-candidates-make-candidate-late
-  (context ^name make-candidates)
-  (scheduling ^night { <n> > 2 })
-  (foursome ^night <n> ^group <g> ^north <yankee>)
-  (player ^number <redneck> ^nights-scheduled < <n>)
-  (player ^number { <oriental> < <redneck> } ^nights-scheduled < <n>)
-  (player ^number { <cowboy> < <oriental> } ^nights-scheduled < <n>)
-  - (already-played ^player1 <yankee> ^player2 <redneck>)
-  - (already-played ^player1 <yankee> ^player2 <oriental>)
-  - (already-played ^player1 <yankee> ^player2 <cowboy>)
-  - (already-played ^player1 <redneck> ^player2 <oriental>)
-  - (already-played ^player1 <redneck> ^player2 <cowboy>)
-  - (already-played ^player1 <oriental> ^player2 <cowboy>)
--->
-  (make candidate ^group <g> ^chosen no
-	^south <redneck> ^east <oriental> ^west <cowboy>))
-
-(p make-candidates-done
-  { <THE-CONTEXT> (context ^name make-candidates) }
--->
-  (modify <THE-CONTEXT> ^name make-choice)) 
-
-(p make-choice-doit
-  { <THE-CONTEXT> (context ^name make-choice) }
-  { <WINNER-A> (candidate ^group a ^chosen no
-	^south <sa>
-	^east  <ea>
-	^west  <wa>) }
-  { <WINNER-B> (candidate ^group b ^chosen no
-	^south { <sb> <> <sa> <> <ea> <> <wa> }
-	^east  { <eb> <> <sa> <> <ea> <> <wa> }
-	^west  { <wb> <> <sa> <> <ea> <> <wa> }) }
-  { <WINNER-C> (candidate ^group c ^chosen no
-	^south { <sc> <> <sa> <> <ea> <> <wa> <> <sb> <> <eb> <> <wb> }
-	^east  { <ec> <> <sa> <> <ea> <> <wa> <> <sb> <> <eb> <> <wb> }
-	^west  { <wc> <> <sa> <> <ea> <> <wa> <> <sb> <> <eb> <> <wb> }) }
-  { <WINNER-D> (candidate ^group d ^chosen no
-	^south { <sd>
-			<> <sa> <> <ea> <> <wa>
-			<> <sb> <> <eb> <> <wb>
-			<> <sc> <> <ec> <> <wc> }
-	^east  { <ed>
-			<> <sa> <> <ea> <> <wa>
-			<> <sb> <> <eb> <> <wb>
-			<> <sc> <> <ec> <> <wc> }
-	^west  { <wd>
-			<> <sa> <> <ea> <> <wa>
-			<> <sb> <> <eb> <> <wb>
-			<> <sc> <> <ec> <> <wc> }) }
---> 
-  (modify <WINNER-A> ^chosen yes)
-  (modify <WINNER-B> ^chosen yes)
-  (modify <WINNER-C> ^chosen yes)
-  (modify <WINNER-D> ^chosen yes)
-  (modify <THE-CONTEXT> ^name remove-candidates))
-
-(p remove-candidates-bye
-  (context ^name remove-candidates)
-  { <THE-CANDIDATE> (candidate ^chosen no) }
--->
-  (remove <THE-CANDIDATE>))
-
-(p remove-candidates-done
-  { <THE-CONTEXT> (context ^name remove-candidates) }
--->
-  (modify <THE-CONTEXT> ^name apply-choice))
-
-(p apply-choice-doit
-  (context ^name apply-choice)
-  (scheduling ^night <n>)
-  { <THE-FOURSOME> (foursome ^night <n> ^group <g> ^north <yankee>) }
-  { <THE-CHOICE> (candidate ^group <g> ^chosen yes
-			^south <redneck> ^east <oriental> ^west <cowboy>) }
--->
-  (modify <THE-FOURSOME> ^south <redneck> ^east <oriental> ^west <cowboy>)
-  (remove <THE-CHOICE>)
-  (make already-played ^player1 <yankee> ^player2 <redneck>)
-  (make already-played ^player2 <yankee> ^player1 <redneck>)
-  (make already-played ^player1 <yankee> ^player2 <oriental>)
-  (make already-played ^player2 <yankee> ^player1 <oriental>)
-  (make already-played ^player1 <yankee> ^player2 <cowboy>)
-  (make already-played ^player2 <yankee> ^player1 <cowboy>)
-  (make already-played ^player1 <redneck> ^player2 <oriental>)
-  (make already-played ^player2 <redneck> ^player1 <oriental>)
-  (make already-played ^player1 <redneck> ^player2 <cowboy>)
-  (make already-played ^player2 <redneck> ^player1 <cowboy>)
-  (make already-played ^player1 <oriental> ^player2 <cowboy>)
-  (make already-played ^player2 <oriental> ^player1 <cowboy>))
-
-(p apply-choice-done
-  { <THE-CONTEXT> (context ^name apply-choice) }
--->
-  (modify <THE-CONTEXT> ^name report))
-
-(p report-night-schedule
-  { <THE-CONTEXT> (context ^name report) }
-  (scheduling ^night <n>)
-  (foursome ^night <n> ^group a ^north <an> ^south <as> ^east <ae> ^west <aw>)
-  (foursome ^night <n> ^group b ^north <bn> ^south <bs> ^east <be> ^west <bw>)
-  (foursome ^night <n> ^group c ^north <cn> ^south <cs> ^east <ce> ^west <cw>)
-  (foursome ^night <n> ^group d ^north <dn> ^south <ds> ^east <de> ^west <dw>)
--->
-  (modify <THE-CONTEXT> ^name next-night)
-  (bind <n2> (compute <n> + 5))
-  (bind <n3> (compute <n> + 10))
-  (write (crlf) (rjust 1) |#| (rjust 1) <n> (rjust 1) - (tabto 5)
-	|Group A-| (rjust 3) <an> (rjust 3) <as> (rjust 3) <ae> (rjust 3) <aw>
-	(tabto 27) (rjust 1) |#| (rjust 2) <n2> (rjust 1) - (tabto 32)
-	|Group A-| (rjust 3) <an> (rjust 3) <ae> (rjust 3) <as> (rjust 3) <aw>
-	(tabto 53) (rjust 1) |#| (rjust 2) <n3> (rjust 1) - (tabto 58)
-	|Group A-| (rjust 3) <an> (rjust 3) <aw> (rjust 3) <ae> (rjust 3) <as>)
-   (write (crlf)
-	(tabto 5)
-	|Group B-| (rjust 3) <bn> (rjust 3) <bs> (rjust 3) <be> (rjust 3) <bw>
-	(tabto 32)
-	|Group B-| (rjust 3) <bn> (rjust 3) <be> (rjust 3) <bs> (rjust 3) <bw>
-	(tabto 58)
-	|Group B-| (rjust 3) <bn> (rjust 3) <bw> (rjust 3) <be> (rjust 3) <bs>)
-   (write  (crlf)
-	(tabto 5)
-	|Group C-| (rjust 3) <cn> (rjust 3) <cs> (rjust 3) <ce> (rjust 3) <cw>
-	(tabto 32)
-	|Group C-| (rjust 3) <cn> (rjust 3) <ce> (rjust 3) <cs> (rjust 3) <cw>
-	(tabto 58)
-	|Group C-| (rjust 3) <cn> (rjust 3) <cw> (rjust 3) <ce> (rjust 3) <cs>)
-   (write (crlf)
-	(tabto 5)
-	|Group D-| (rjust 3) <dn> (rjust 3) <ds> (rjust 3) <de> (rjust 3) <dw>
-	(tabto 32)
-	|Group D-| (rjust 3) <dn> (rjust 3) <de> (rjust 3) <ds> (rjust 3) <dw>
-	(tabto 58)
-	|Group D-| (rjust 3) <dn> (rjust 3) <dw> (rjust 3) <de> (rjust 3) <ds>
-    (crlf)))
-
-(p next-night-more
-  { <THE-CONTEXT> (context ^name next-night) }
-  { <THE-NIGHT> (scheduling ^night { <n> < 5 }) }
--->
-  (modify <THE-CONTEXT> ^name north)
-  (modify <THE-NIGHT> ^night (compute <n> + 1)))
-
-(p next-night-done
-  (context ^name next-night)
--->
-  (write (tabto 32) |End of Scheduling| (crlf) (crlf)))
-
diff --git a/contrib/ops/ttt.ops b/contrib/ops/ttt.ops
deleted file mode 100644
index defe3823d8ed8db1f01b6550ee9766aed5676048..0000000000000000000000000000000000000000
--- a/contrib/ops/ttt.ops
+++ /dev/null
@@ -1,308 +0,0 @@
-(strategy mea)
-(watch 0)
-
-
-(literalize task
-	actor)
-(literalize position
-	row column value identity)
-(literalize opposite
-	of is)
-(literalize player
-	with-mark is)
-(literalize move
-	status whose-turn input)
-(vector-attribute input)
-
-
-
-(p start
-;	 generate the wm-elements defining the "board" and find out whether
-;	 the human wants his mark to be x or o
-	 (ready)
-	-->
-	 (make task ^actor referee)
-	 (make position ^row 1 ^column 1 ^value | | ^identity top-left)
-	 (make position ^row 1 ^column 2 ^value | | ^identity top-middle)
-	 (make position ^row 1 ^column 3 ^value | | ^identity top-right)
-	 (make position ^row 2 ^column 1 ^value | | ^identity middle-left)
-	 (make position ^row 2 ^column 2 ^value | | ^identity center)
-	 (make position ^row 2 ^column 3 ^value | | ^identity middle-right)
-	 (make position ^row 3 ^column 1 ^value | | ^identity bottom-left)
-	 (make position ^row 3 ^column 2 ^value | | ^identity bottom-middle)
-	 (make position ^row 3 ^column 3 ^value | | ^identity bottom-right)
-	 (make opposite ^of x ^is o)
-	 (make opposite ^of o ^is x)
-	 (write (crlf) Do you want to be x or "o?  " )
-	 (make player ^with-mark (accept) ^is human) )
-
-(make ready)
-
-(p pop
-	 ; if there is nothing more to do in the most recently generated task,
-	 ; delete the task
-	 (task)
-	-->
-	 (remove 1) )
-
-
-(p referee--display-the-board
-	 ; after each move, display the board
-	 (task ^actor referee)
-	 (move ^status made ^whose-turn <mark>)
-	 (opposite ^of <mark> ^is <opponent-mark>)
-	 (position ^row 1 ^column 1 ^value <l1>)
-	 (position ^row 1 ^column 2 ^value <m1>)
-	 (position ^row 1 ^column 3 ^value <r1>)
-	 (position ^row 2 ^column 1 ^value <l2>)
-	 (position ^row 2 ^column 2 ^value <m2>)
-	 (position ^row 2 ^column 3 ^value <r2>)
-	 (position ^row 3 ^column 1 ^value <l3>)
-	 (position ^row 3 ^column 2 ^value <m3>)
-	 (position ^row 3 ^column 3 ^value <r3>)
-	-->
-	 (modify 2 ^status unmade ^whose-turn <opponent-mark>)
-	 (write (crlf) (crlf) (crlf)
-		(tabto 12) <l1> (tabto 15) "|" (tabto 18) <m1>
-		(tabto 21) "|" (tabto 24) <r1>
-		(tabto 10) -----------------
-		(tabto 12) <l2> (tabto 15) "|" (tabto 18) <m2>
-		(tabto 21) "|" (tabto 24) <r2>
-		(tabto 10) -----------------
-		(tabto 12) <l3> (tabto 15) "|" (tabto 18) <m3>
-		(tabto 21) "|" (tabto 24) <r3>) )
-
-(p referee--prepare-for-first-move
-;	 identify the mark of the computer and create the move wm-element that
-;	 will drive the game
-	 (task ^actor referee)
-	 (player ^with-mark <mark> ^is human)
-	 (opposite ^of <mark> ^is <other-mark>)
-	-->
-	 (write (crlf) (crlf) When you are asked where you want your |mark,|
-		enter two |numbers.|
-		(crlf) The first number should be the row you |want,| the
-		second |number, the column.|)
-	 (make player ^with-mark <other-mark> ^is computer)
-	 (make move ^status unmade ^whose-turn x) )
-
-(p referee--get-a-good-mark
-;	 if the human says he wants to be something other than x or o, make
-;	 him x
-	 (task ^actor referee)
-	 (player ^with-mark <mark> ^is human)
-	 - (opposite ^of <mark>)
-	-->
-	 (modify 2 ^with-mark x)
-	 (write (crlf) (crlf) Try to remember that |you're x.|) )
-
-(p referee--next-move
-;	 if it's time for the next move to be made, generate the appropriate
-;	 subtask
-	 (task ^actor referee)
-	 (move ^status unmade ^whose-turn <mark>)
-	 (player ^with-mark <mark> ^is <who>)
-	-->
-	 (make task ^actor <who>) )
-
-(p referee--recognize-column-win
-;	 if someone has filled a column, note that fact
-	 (task ^actor referee)
-	 (move ^status unmade ^whose-turn <mark>)
-	 (opposite ^of <mark> ^is <other-mark>)
-	 (player ^with-mark <other-mark>)
-	 (position ^column <c> ^value <other-mark>)
-	 - (position ^column <c> ^value <> <other-mark>)
-	-->
-	 (remove 2)
-	 (make player ^with-mark <other-mark> ^is winner) )
-
-(p referee--recognize-row-win
-;	 if someone has filled a row, note that fact
-	 (task ^actor referee)
-	 (move ^status unmade ^whose-turn <mark>)
-	 (opposite ^of <mark> ^is <other-mark>)
-	 (player ^with-mark <other-mark>)
-	 (position ^row <r> ^value <other-mark>)
-	 - (position ^row <r> ^value <> <other-mark>)
-	-->
-	 (remove 2)
-	 (make player ^with-mark <other-mark> ^is winner) )
-
-(p referee--recognize-diagonal-win
-;	 if someone has filled a diagonal, note that fact
-	 (task ^actor referee)
-	 (move ^status unmade ^whose-turn <mark>)
-	 (opposite ^of <mark> ^is <other-mark>)
-	 (player ^with-mark <other-mark>)
-	 (position ^row 2 ^column 2 ^value <other-mark>)
-	 (position ^row {<r> <> 2} ^column {<c> <> 2}
-		   ^identity <id> ^value <other-mark>)
-	 (position ^row <c> ^column <r>
-		   ^identity <> <id> ^value <other-mark>)
-	-->
-	 (remove 2)
-	 (make player ^with-mark <other-mark> ^is winner) )
-
-(p referee--human-wins
-;	 if the human won, let him know
-	 (task ^actor referee)
-	 (player ^with-mark <other-mark> ^is winner)
-	 (player ^with-mark <other-mark> ^is human)
-	-->
-	 (write (crlf) (crlf) You |win.| (crlf) (crlf)) )
-
-(p referee--computer-wins
-;	 if the computer won, let the human know
-	 (task ^actor referee)
-	 (player ^with-mark <other-mark> ^is winner)
-	 (player ^with-mark <other-mark> ^is computer)
-	-->
-	 (write (crlf) (crlf) I |win.| (crlf) (crlf)) )
-
-(p referee--draw
-;	 if there are no empty spaces, the game is a draw
-	 (task ^actor referee)
-	 (move ^status unmade ^whose-turn <mark>)
-	 (player ^with-mark <mark>)
-	 - (position ^value | |)
-	-->
-	 (write (crlf) (crlf) We |drew.| (crlf) (crlf))
-	 (remove 2) )
-
-(p referee--cleanup
-;	 if the game is over, delete all of the wm-elements
-	 (task ^actor referee)
-	 - (move)
-	 (<> task)
-	-->
-	 (remove 2) )
-
-
-(p human--ask-for-next-move
-	 ; get the position (row and column) where the human wants his mark
-	 (task ^actor human)
-	 (move ^status unmade ^input nil)
-	-->
- 	 (write (crlf) (crlf) Where do you want your "mark?  ")
-	 (modify 2 ^input (acceptline)) )
-
-(p human--accept-move
-	 ; if the move is legal, accept it
-	 ; the move wm-element is remade so that the value of ^input becomes
-	 ; nil (there are 2 simpler but less educational ways of achieving
-	 ; this same end)
-	 (task ^actor human)
-	 (move ^status unmade ^whose-turn <mark>
-	       ^input {<row> >= 0 <= 3} {<column> >= 0 <= 3} nil)
-	 (position ^row <row> ^column <column> ^value | |)
-	-->
-	 (remove 2)
-	 (make move (substr 2 2 input) ^status made ^input nil)
-	 (modify 3 ^value <mark>) )
-
-(p human--reject-attempt-to-overwrite
-	 ; if the position specified is not empty, complain
-	 ; the move condition element in this rule differs from the move
-	 ; condition in the previous rule only so you can see two equivalent
-	 ; ways of expressing the same condition
-	 (task ^actor human)
-	 (move ^status unmade
-	       ^input <row> <column> nil ^input << 1 2 3 >> << 1 2 3 >>)
-	 (position ^row <row> ^column <column> ^value {<mark> <> | |})
-	-->
-	 (write (crlf) (crlf) There is already an <mark> in <row> <column>)
-	 (modify 2 ^input nil nil) )
-
-(p human--reject-out-of-bounds-move
-	 ; if the row or column specified is not within bounds or if more than
-	 ; two numbers have been entered, complain
-	 ; the move wm-element is remade so that the value of ^input becomes
-	 ; nil (there is a simpler but less educational way of achieving this
-	 ; same end)
-	 (task ^actor human)
-	 (move ^status unmade ^input <> nil)
-	-->
-	 (write (crlf) (crlf) (substr 2 input inf) is not a legal |move.|)
-	 (remove 2)
-	 (make move (substr 2 2 input) ^input nil) )
-
-
-(p computer--select-move
-	 ; select any empty position
-	 (task ^actor computer)
-	 (move ^status unmade ^whose-turn <mark>)
-	 - (position ^row 2 ^column 2 ^value | |)
-	 (position ^row <r> ^column <c> ^value | |)
-	-->
-	 (modify 2 ^status made)
-	 (modify 3 ^value <mark>) )
-
-(p computer--select-center
-	 ; select the center if it's available
-	 (task ^actor computer)
-	 (move ^status unmade ^whose-turn <mark>)
-	 (position ^row 2 ^column 2 ^value | |)
-	-->
-	 (modify 2 ^status made)
-	 (modify 3 ^value <mark>) )
-
-(p computer--block-column-win
-	 ; if the human has two in a column, block
-	 (task ^actor computer)
-	 (move ^status unmade ^whose-turn <mark>)
-	 (position ^row <r> ^column <c>
-		   ^value {<other-mark> <> <mark> <> | |})
-	 (position ^column <c> ^value | |)
-	 (position ^row <> <r> ^column <c> ^value <other-mark>)
-	-->
-	 (modify 2 ^status made)
-	 (modify 4 ^value <mark>) )
-
-(p computer--block-row-win
-	 ; if the human has two in a row, block
-	 (task ^actor computer)
-	 (move ^status unmade ^whose-turn <mark>)
-	 (position ^row <r> ^column <c>
-		   ^value {<other-mark> <> <mark> <> | |})
-	 (position ^row <r> ^value | |)
-	 (position ^row <r> ^column <> <c> ^value <other-mark>)
-	-->
-	 (modify 2 ^status made)
-	 (modify 4 ^value <mark>) )
-
-(p computer--block-diagonal-win
-	 ; if the human has two on a diagonal, block
-	 (task ^actor computer)
-	 (move ^status unmade ^whose-turn <mark>)
-	 (position ^row 2 ^column 2
-		   ^value {<other-mark> <> <mark> <> | |})
-	 (position ^row {<r> <> 2} ^column {<c> <> 2} ^value | |)
-	 (position ^row <c> ^column <r> ^value <other-mark>)
-	-->
-	 (modify 2 ^status made)
-	 (modify 4 ^value <mark>) )
-
-(p computer--possible-column
-	 ; if the computer has one mark in an otherwise empty column, put
-	 ; another mark in that column
-	 (task ^actor computer)
-	 (move ^status unmade ^whose-turn <mark>)
-	 (position ^row <r> ^column <c> ^value <mark>)
-	 - (position ^row <> <r> ^column <c> ^value <> | |)
-	 (position ^row <> <r> ^column <c> ^value | |)
-	-->
-	 (modify 2 ^status made)
-	 (modify 4 ^value <mark>) )
-
-(p computer--possible-row
-	 ; if the computer has one mark in an otherwise empty row, put
-	 ; another mark in that row
-	 (task ^actor computer)
-	 (move ^status unmade ^whose-turn <mark>)
-	 (position ^row <r> ^column <c> ^value <mark>)
-	 - (position ^row <r> ^column <> <c> ^value <> | |)
-	 (position ^row <r> ^column <> <c> ^value | |)
-	-->
-	 (modify 2 ^status made)
-	 (modify 4 ^value <mark>) )
diff --git a/contrib/ops/weaver.ops b/contrib/ops/weaver.ops
deleted file mode 100644
index c1b8711d9cf21c72d8eca49700b97dd24a720075..0000000000000000000000000000000000000000
--- a/contrib/ops/weaver.ops
+++ /dev/null
@@ -1,8850 +0,0 @@
-(literalize unit unit-name file-name)
-
-(literalize pin net-name pin-name external-net-name external-pin-name pin-left-x pin-left-y fixed-pin pin-x pin-y pin-layer pin-layer-constraint pin-channel-side pin-is-attached)
-
-(literalize channel channel-bottom-left-x channel-bottom-left-y channel-top-right-x channel-top-right-y channel-width channel-length no-of-left-pins no-of-right-pins no-of-bottom-pins no-of-top-pins right-fixed left-fixed bottom-fixed top-fixed channel-type no-of-fixed-sides)
-
-(literalize net net-name parent-name net-no-of-pins net-left-x net-left-y net-right-x net-right-y no-of-left-pins no-of-right-pins no-of-top-pins no-of-bottom-pins net-is-routed left-most-pin-name right-most-pin-name bottom-most-pin-name top-most-pin-name fixed-net net-layer external-net-name no-of-inter max-no-of-via)
-
-(literalize layer-info layer-name layer-order layer-priority)
-
-(literalize context present previous saved)
-
-(literalize ff net-name pin-name grid-layer grid-x grid-y came-from can-chng-layer)
-
-(literalize next-net-to-be-routed net-name no-of-attached-pins criteria)
-
-(literalize to-be-routed net-name no-of-attached-pins)
-
-(literalize occupied x y m)
-
-(literalize constraint constraint-type constraint-relation channel-side constraint-reason net-name-1 net-name-2 pin-name-1 pin-name-2 seg-id-1 seg-id-2)
-
-(literalize congestion direction coordinate no-of-nets extra-nets como)
-
-(literalize intersection net-name direction min max)
-
-(literalize horizontal min max com compo commo layer status min-net max-net net-name pin-name)
-
-(literalize vertical min max com compo commo layer status min-net max-net net-name pin-name)
-
-(literalize horizontal-s net-name min max com id top-count bot-count sum difference absolute side)
-
-(literalize vertical-s net-name min max com id top-count bot-count sum difference absolute side)
-
-(literalize total net-name row-col coor level-pins total-pins cong min-xy max-xy last-pin last-xy nets)
-
-(literalize tree net-name orientation com min max count id)
-
-(vector-attribute nets)
-
-(p p327
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>)
-    (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max { <hmax> >= <gx> > <min> } ^com 1 ^id <id>)
-  - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side bottom)
-    (constraint ^constraint-type vertical ^seg-id-1 <id>)
-    (total ^net-name <> <nn>)
-  - (total-verti <nn>)
-  -->
-    (remove <t>)
-)
-
-(p p328
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>)
-    (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> < <max> } ^max { <hmax> >= <gx> } ^com <lr> ^id <id>)
-  - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <> <id>)
-    (last-row <lr>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side top)
-    (constraint ^constraint-type vertical ^seg-id-2 <id>)
-    (total ^net-name <> <nn>)
-  - (total-verti <nn>)
-  -->
-    (remove <t>)
-)
-
-(p p329
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> })
-    (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> > <min> } ^com 1 ^id <id>)
-  - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side left)
-    (constraint ^constraint-type horizontal ^seg-id-1 <id>)
-    (total ^net-name <> <nn>)
-  - (total-verti <nn>)
-  -->
-    (remove <t>)
-)
-
-(p p330
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> })
-    (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> < <max> } ^max { <vmax> >= <gy> } ^com <lc> ^id <id>)
-  - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <> <id>)
-    (last-col <lc>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side right)
-    (constraint ^constraint-type horizontal ^seg-id-2 <id>)
-    (total ^net-name <> <nn>)
-  - (total-verti <nn>)
-  -->
-    (remove <t>)
-)
-
-(p p331
-    { <c> (context ^present modify-total) }
-  -->
-    (modify <c> ^present delete-total)
-)
-
-(p p332
-    { <c> (context ^present delete-total) }
-  - (total)
-  -->
-    (remove <c>)
-    (make context ^previous find-no-of-pins-on-a-row-col)
-)
-
-(p p333
-    { <c> (context ^present extend-total) }
-    (last-row <lr>)
-  -->
-    (make maximum-total 0 0 0 1 0 <lr> 0)
-    (make merge-direction left)
-    (modify <c> ^present merge)
-    (make eliminate-total)
-)
-
-(p p334
-    { <c> (context ^present delete-total) }
-  -->
-    (modify <c> ^present extend-total)
-)
-
-(p p335
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>)
-    (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max { <hmax> >= <gx> } ^com 1 ^id <id> ^absolute <a> ^sum <s>)
-  - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>)
-  - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <hmin> ^max-xy <hmax> ^last-pin checked)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side bottom)
-  -->
-    (make (substr <t> 1 inf) ^min-xy <hmin> ^max-xy <hmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <hmin> <hmax>)
-)
-
-(p p336
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>)
-    (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max { <hmax> >= <gx> } ^com <lr> ^id <id> ^absolute <a> ^sum <s>)
-  - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <> <id>)
-  - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <hmin> ^max-xy <hmax> ^last-pin checked)
-    (last-row <lr>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x { >= <hmin> <= <hmax> } ^pin-channel-side top)
-  -->
-    (make (substr <t> 1 inf) ^min-xy <hmin> ^max-xy <hmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <hmin> <hmax>)
-)
-
-(p p337
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> })
-    (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> } ^com 1 ^id <id> ^absolute <a> ^sum <s>)
-  - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <> <id>)
-  - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <vmin> ^max-xy <vmax> ^last-pin checked)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side left)
-  -->
-    (make (substr <t> 1 inf) ^min-xy <vmin> ^max-xy <vmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <vmin> <vmax>)
-)
-
-(p p338
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> })
-    (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> } ^com <lc> ^id <id> ^absolute <a> ^sum <s>)
-  - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <> <id>)
-  - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <vmin> ^max-xy <vmax> ^last-pin checked)
-    (last-col <lc>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-y { >= <vmin> <= <vmax> } ^pin-channel-side right)
-  -->
-    (make (substr <t> 1 inf) ^min-xy <vmin> ^max-xy <vmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <vmin> <vmax>)
-)
-
-(p p339
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>)
-    (horizontal-s ^net-name <nn> ^min 1 ^max { <hmax> >= <gx> } ^com <com> ^id <id> ^absolute <a> ^sum <s>)
-  - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>)
-  - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy 1 ^max-xy <hmax> ^last-pin checked)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x 0 ^pin-y <com> ^pin-channel-side left)
-  -->
-    (make (substr <t> 1 inf) ^min-xy 1 ^max-xy <hmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> 1 <hmax>)
-)
-
-(p p340
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y <y>)
-    (horizontal-s ^net-name <nn> ^min { <hmin> <= <gx> } ^max <lc> ^com <com> ^id <id> ^absolute <a> ^sum <s>)
-  - (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>)
-  - (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <hmin> ^max-xy <lc> ^last-pin checked)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-y <com> ^pin-channel-side right)
-    (last-col <lc>)
-  -->
-    (make (substr <t> 1 inf) ^min-xy <hmin> ^max-xy <lc> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <hmin> <lc>)
-)
-
-(p p341
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> })
-    (vertical-s ^net-name <nn> ^min 1 ^max { <vmax> >= <gy> } ^com <com> ^id <id> ^absolute <a> ^sum <s>)
-  - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>)
-  - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy 1 ^max-xy <vmax> ^last-pin checked)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x <com> ^pin-channel-side bottom)
-  -->
-    (make (substr <t> 1 inf) ^min-xy 1 ^max-xy <vmax> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> 1 <vmax>)
-)
-
-(p p342
-    (context ^present modify-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (ff ^net-name <nn> ^pin-name <pn> ^grid-x <x> ^grid-y { <gy> >= <min> <= <max> })
-    (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max <lr> ^com <com> ^id <id> ^absolute <a> ^sum <s>)
-  - (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <garb> ^id <> <id>)
-  - (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <vmin> ^max-xy <lr> ^last-pin checked)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-x <com> ^pin-channel-side top)
-    (last-row <lr>)
-  -->
-    (make (substr <t> 1 inf) ^min-xy <vmin> ^max-xy <lr> ^level-pins <a> ^total-pins <s> ^last-pin checked ^last-xy <id> ^nets <nn> <vmin> <lr>)
-)
-
-(p p343
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (total ^net-name <nn> ^row-col <rc> ^coor <y> ^last-pin checked)
-  -->
-    (remove <t>)
-)
-
-(p p344
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-  -->
-    (remove <t>)
-)
-
-(p p345
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-    (net ^net-name <nn> ^net-no-of-pins 2)
-  -->
-    (modify <t> ^last-pin checked ^nets <nn> <min> <max>)
-)
-
-(p p346
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <y> ^min-xy <min> ^max-xy <max> ^last-pin <> checked) }
-  - (total ^last-pin checked)
-  -->
-    (modify <t> ^last-pin checked ^nets <nn> <min> <max>)
-)
-
-(p p347
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) }
-    (last-col <lc>)
-    (horizontal-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { >= <min> <> <lc> } ^com <y> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-x 0 ^pin-y <y>)
-  - (pin ^net-name <nn> ^pin-y <y> ^pin-channel-side right)
-  -->
-    (remove <t>)
-)
-
-(p p348
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <tmin> ^max-xy <max>) }
-    (last-col <lc>)
-    (horizontal-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { <maxs> <> <lc> } ^com <y> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-x 0 ^pin-y <y>)
-    (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com { <min> > 1 <= <maxs> })
-  - (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com < <min>)
-    { <h> (horizontal ^net-name <nn1> ^min 0 ^max { <hmax> < <min> } ^com <y> ^layer <lay>) }
-    { <ff> (ff ^net-name <nn1> ^grid-x <hmax> ^grid-y <y> ^grid-layer <lay> ^came-from west) }
-    { <h1> (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <y> ^layer <lay>) }
-  - (pin ^net-name <nn> ^pin-y <y>)
-  - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <y> ^max >= <y> ^com <min> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <min> ^max >= <min> ^com <y> ^layer <lay>)
-  -->
-    (remove <t>)
-    (modify <h> ^max <min>)
-    (modify <h1> ^min <min> ^min-net <nn1>)
-    (modify <ff> ^grid-x <min> ^can-chng-layer nil)
-)
-
-(p p349
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max>) }
-    (last-col <lc>)
-    (horizontal-s ^net-name { <nn1> <> <nn> } ^min { <= <max> <> 1 } ^max <lc> ^com <y> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-y <y> ^pin-channel-side right)
-  - (pin ^net-name <nn> ^pin-y <y> ^pin-channel-side left)
-  -->
-    (remove <t>)
-)
-
-(p p350
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <tmax>) }
-    (last-col <lc>)
-    (horizontal-s ^net-name { <nn1> <> <nn> } ^min { <mins> <> 1 } ^max <lc> ^com <y> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-y <y> ^pin-channel-side right)
-    (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com { <max> >= <mins> < <lc> })
-  - (vertical ^net-name <nn> ^min <= <y> ^max >= <y> ^com > <max>)
-    { <h> (horizontal ^net-name <nn1> ^min { <hmin> > <max> } ^max <garb> ^com <y> ^layer <lay>) }
-    { <ff> (ff ^net-name <nn1> ^grid-x <hmin> ^grid-y <y> ^grid-layer <lay> ^came-from east) }
-    { <h1> (horizontal ^net-name nil ^min < <max> ^max <hmin> ^com <y> ^layer <lay>) }
-  - (pin ^net-name <nn> ^pin-y <y>)
-  - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <y> ^max >= <y> ^com <max> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <max> ^max >= <max> ^com <y> ^layer <lay>)
-  -->
-    (remove <t>)
-    (modify <h> ^min <max>)
-    (modify <h1> ^max <max> ^max-net <nn1>)
-    (modify <ff> ^grid-x <max> ^can-chng-layer nil)
-)
-
-(p p351
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) }
-    (last-row <lr>)
-    (vertical-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { >= <min> <> <lr> } ^com <x> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x <x> ^pin-channel-side top)
-  -->
-    (remove <t>)
-)
-
-(p p352
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <tmin> ^max-xy <max>) }
-    (last-row <lr>)
-    (vertical-s ^net-name { <nn1> <> <nn> } ^min 1 ^max { <maxs> <> <lr> } ^com <x> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side bottom)
-    (horizontal ^net-name <nn> ^min <= <x> ^max <x> ^com { <min> > 1 <= <maxs> })
-  - (horizontal ^net-name <nn> ^min <= <x> ^max <x> ^com < <min>)
-    { <v> (vertical ^net-name <nn1> ^min 0 ^max { <vmax> < <min> } ^com <x> ^layer <lay>) }
-    { <ff> (ff ^net-name <nn1> ^grid-x <x> ^grid-y <vmax> ^grid-layer <lay> ^came-from south) }
-    { <v1> (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <x> ^layer <lay>) }
-  - (pin ^net-name <nn> ^pin-x <x>)
-  - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <min> ^max >= <min> ^com <x>)
-  - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <x> ^max >= <x> ^com <min>)
-  -->
-    (remove <t>)
-    (modify <v> ^max <min>)
-    (modify <v1> ^min <min> ^min-net <nn1>)
-    (modify <ff> ^grid-y <min> ^can-chng-layer nil)
-)
-
-(p p353
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max>) }
-    (last-row <lr>)
-    (vertical-s ^net-name { <nn1> <> <nn> } ^min { <= <max> <> 1 } ^max <lr> ^com <x> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x <x> ^pin-channel-side bottom)
-  -->
-    (remove <t>)
-)
-
-(p p354
-    (context ^present delete-total)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <tmax>) }
-    (last-row <lr>)
-    (vertical-s ^net-name { <nn1> <> <nn> } ^min { <mins> <> 1 } ^max <lr> ^com <x> ^id <=> 1)
-    (pin ^net-name <nn1> ^pin-x <x> ^pin-channel-side top)
-    (horizontal ^net-name <nn> ^min <= <x> ^max >= <x> ^com { <max> >= <mins> < <lr> })
-  - (horizontal ^net-name <nn> ^min <= <x> ^max >= <x> ^com > <max>)
-    { <v> (vertical ^net-name <nn1> ^min { <vmin> > <max> } ^max <garb> ^com <x> ^layer <lay>) }
-    { <ff> (ff ^net-name <nn1> ^grid-x <x> ^grid-y <vmin> ^grid-layer <lay> ^came-from north) }
-    { <v1> (vertical ^net-name nil ^min < <vmin> ^max <vmin> ^com <x> ^layer <lay>) }
-  - (pin ^net-name <nn> ^pin-x <x>)
-  - (vertical ^status nil ^net-name { <> <nn1> <> nil } ^min <= <max> ^max >= <max> ^com <x>)
-  - (horizontal ^status nil ^net-name { <> <nn1> <> nil } ^min <= <x> ^max >= <x> ^com <max>)
-  -->
-    (remove <t>)
-    (modify <v> ^min <max>)
-    (modify <v1> ^max <max> ^max-net <nn1>)
-    (modify <ff> ^grid-y <max> ^can-chng-layer nil)
-)
-
-(p p355
-    (context ^present extend-total)
-  - (switch-box)
-    { <t> (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-xy <id>) }
-    (last-row > <y>)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>)
-  - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>)
-  - (horizontal ^net-name <nn> ^min <= <min> ^max >= <min> ^com <y>)
-  - (horizontal ^net-name <nn> ^min <= <max> ^max >= <max> ^com <y>)
-  - (horizontal ^net-name <nn> ^min >= <min> ^max <= <max> ^com <y>)
-    (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com > <y>)
-  - (ff ^net-name <nn> ^grid-x { >= <min> <= <max> } ^grid-y <y> ^pin-name >= 1000)
-  -->
-    (modify <t> ^coor (compute <y> + 1))
-)
-
-(p p356
-    (context ^present extend-total)
-  - (switch-box)
-    { <t> (total ^net-name <nn> ^row-col row ^coor { <y> > 0 } ^min-xy <min> ^max-xy <max> ^last-xy <id>) }
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <id>)
-    (last-row <lr>)
-  - (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>)
-  - (horizontal ^net-name <nn> ^min <= <min> ^max >= <min> ^com <y>)
-  - (horizontal ^net-name <nn> ^min <= <max> ^max >= <max> ^com <y>)
-  - (horizontal ^net-name <nn> ^min >= <min> ^max <= <max> ^com <y>)
-    (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com < <y>)
-  - (ff ^net-name <nn> ^grid-x { >= <min> <= <max> } ^grid-y <y> ^pin-name >= 1000)
-  -->
-    (modify <t> ^coor (compute <y> - 1))
-)
-
-(p p357
-    (context ^present extend-total)
-  - (switch-box)
-    { <t> (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-xy <id>) }
-    (last-col > <x>)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>)
-  - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>)
-  - (vertical ^net-name <nn> ^min <= <min> ^max >= <min> ^com <x>)
-  - (vertical ^net-name <nn> ^min <= <max> ^max >= <max> ^com <x>)
-  - (vertical ^net-name <nn> ^min >= <min> ^max <= <max> ^com <x>)
-    (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com > <x>)
-  - (ff ^net-name <nn> ^grid-x <x> ^grid-y { >= <min> <= <max> } ^pin-name >= 1000)
-  -->
-    (modify <t> ^coor (compute <x> + 1))
-)
-
-(p p358
-    (context ^present extend-total)
-  - (switch-box)
-    { <t> (total ^net-name <nn> ^row-col col ^coor { <x> > 0 } ^min-xy <min> ^max-xy <max> ^last-xy <id>) }
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <id>)
-    (last-col <lc>)
-  - (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>)
-  - (vertical ^net-name <nn> ^min <= <min> ^max >= <min> ^com <x>)
-  - (vertical ^net-name <nn> ^min <= <max> ^max >= <max> ^com <x>)
-  - (vertical ^net-name <nn> ^min >= <min> ^max <= <max> ^com <x>)
-    (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com < <x>)
-  - (ff ^net-name <nn> ^grid-x <x> ^grid-y { >= <min> <= <max> } ^pin-name >= 1000)
-  -->
-    (modify <t> ^coor (compute <x> - 1))
-)
-
-(p p359
-    (context ^present extend-total)
-    (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-xy <id>)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>)
-    (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> < <y> } ^grid-layer <lay> ^pin-name <pn>) }
-    { <v> (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { <vmax> >= <y> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <y> ^max >= <y> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <y> ^layer <lay>)
-  -->
-    (make vertical ^min <y> ^max <vmax> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>)
-    (modify <v> ^max <gy> ^max-net <nn>)
-    (make vertical ^min <gy> ^max <y> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>)
-    (modify <ff> ^grid-y <y> ^came-from south ^can-chng-layer nil)
-)
-
-(p p360
-    (context ^present extend-total)
-    (total ^net-name <nn> ^row-col row ^coor <y> ^min-xy <min> ^max-xy <max> ^last-xy <id>)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <lr> ^id <id>)
-    (last-row <lr>)
-    (horizontal ^net-name nil ^min <= <min> ^max >= <max> ^com <y>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> > <y> } ^grid-layer <lay> ^pin-name <pn>) }
-    { <v> (vertical ^net-name nil ^min { <vmin> <= <y> } ^max { <vmax> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <y> ^max >= <y> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <y> ^layer <lay>)
-  -->
-    (make vertical ^min <gy> ^max <vmax> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>)
-    (modify <v> ^max <y> ^max-net <nn>)
-    (make vertical ^min <y> ^max <gy> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>)
-    (modify <ff> ^grid-y <y> ^came-from north ^can-chng-layer nil)
-)
-
-(p p361
-    (context ^present extend-total)
-    (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-xy <id>)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com 1 ^id <id>)
-    (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx> < <x> } ^grid-y { <gy> >= <min> <= <max> } ^grid-layer <lay> ^pin-name <pn>) }
-    { <v> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> >= <x> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <x> ^max >= <x> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <x> ^layer <lay>)
-  -->
-    (make horizontal ^min <x> ^max <hmax> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>)
-    (modify <v> ^max <gx> ^max-net <nn>)
-    (make horizontal ^min <gx> ^max <x> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>)
-    (modify <ff> ^grid-x <x> ^came-from west ^can-chng-layer nil)
-)
-
-(p p362
-    (context ^present extend-total)
-    (total ^net-name <nn> ^row-col col ^coor <x> ^min-xy <min> ^max-xy <max> ^last-xy <id>)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <lc> ^id <id>)
-    (last-col <lc>)
-    (vertical ^net-name nil ^min <= <min> ^max >= <max> ^com <x>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx> > <x> } ^grid-y { <gy> >= <min> <= <max> } ^grid-layer <lay> ^pin-name <pn>) }
-    { <v> (horizontal ^net-name nil ^min { <hmin> <= <x> } ^max { <hmax> >= <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <x> ^max >= <x> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <x> ^layer <lay>)
-  -->
-    (make horizontal ^min <gx> ^max <hmax> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn> ^max-net <mn>)
-    (modify <v> ^max <x> ^max-net <nn>)
-    (make horizontal ^min <x> ^max <gx> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^net-name <nn> ^pin-name <pn>)
-    (modify <ff> ^grid-x <x> ^came-from east ^can-chng-layer nil)
-)
-
-(p p490
-    { <c> (context ^present separate) }
-  -->
-    (modify <c> ^present reconnect)
-)
-
-(p p491
-    { <c> (context ^present reconnect) }
-  -->
-    (modify <c> ^present form-verti)
-)
-
-(p p492
-    { <c> (context ^present form-verti) }
-  -->
-    (modify <c> ^present partial-route)
-)
-
-(p p493
-    { <c> (context ^present partial-route) }
-  -->
-    (modify <c> ^present extend-pins)
-)
-
-(p p494
-    { <c1> (context ^present extend-pins) }
-  -->
-    (modify <c1> ^present nil ^previous extend-pins)
-)
-
-(p p495
-    { <c1> (context ^previous extend-pins) }
-  -->
-    (make switch-box)
-    (make context ^present propagate-constraint)
-    (remove <c1>)
-)
-
-(p p496
-    { <c1> (context ^previous extend-pins) }
-    (channel ^no-of-left-pins 0 ^no-of-right-pins 0)
-  -->
-    (remove <c1>)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p497
-    { <c1> (context ^previous extend-pins) }
-    (channel ^no-of-bottom-pins 0 ^no-of-top-pins 0)
-  -->
-    (remove <c1>)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p498
-    (context ^previous propagate-constraint)
-    (net ^net-is-routed <> yes)
-  -->
-    (remove 1)
-    (make context ^present lshape1)
-)
-
-(p p499
-    (context ^present lshape1)
-  -->
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p500
-    { <c> (context ^previous find-no-of-pins-on-a-row-col) }
-  - (total)
-  - (extend-ff-tried)
-  -->
-    (remove <c>)
-    (make context ^present lshape4)
-)
-
-(p p501
-    { <c> (context ^present lshape4) }
-  -->
-    (remove <c>)
-    (make extend-ff-tried)
-    (make context ^present extend-ff)
-)
-
-(p p502
-    { <c> (context ^present extend-ff) }
-  -->
-    (remove <c>)
-    (make context ^previous extend-ff)
-)
-
-(p p503
-    { <c> (context ^previous extend-ff) }
-  - (extended-ff)
-  -->
-    (remove <c>)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p504
-    { <c> (context ^previous extend-ff) }
-    { <e> (extended-ff) }
-    { <ex> (extend-ff-tried) }
-  -->
-    (remove <c> <e> <ex>)
-    (make context ^present find-no-of-pins-on-a-row-col)
-    (make goal cleanup extended-ff)
-)
-
-(p p505
-    (context ^previous find-no-of-pins-on-a-row-col)
-  - (total)
-    (extend-ff-tried)
-  - (total-verti)
-  -->
-    (remove 1)
-    (make context ^present find-no-of-vcg-hcg)
-    (make goal cleanup counted-verti)
-)
-
-(p p506
-    (context ^previous find-no-of-pins-on-a-row-col)
-  - (total)
-    (total-verti)
-  - (verti-has-loop)
-  -->
-    (remove 1)
-    (make verti-has-loop)
-    (make context ^present choose-between-total-verti)
-)
-
-(p p507
-    (context ^previous find-no-of-pins-on-a-row-col)
-  - (total)
-    (total-verti)
-    (verti-has-loop)
-  -->
-    (make context ^present extend-h-v-s)
-    (make goal cleanup total-verti)
-    (make goal cleanup counted-verti)
-    (make goal cleanup extend-ff-tried)
-    (remove 1 3)
-)
-
-(p p508
-    (context ^present choose-between-total-verti)
-  - (total-verti ^4 > 0)
-  -->
-    (modify 1 ^present extend-h-v-s)
-    (make goal cleanup counted-verti)
-)
-
-(p p509
-    (context ^previous find-no-of-vcg-hcg)
-  - (total-verti)
-  -->
-    (remove 1)
-    (make context ^present extend-h-v-s)
-)
-
-(p p510
-    (context ^present loose-constraint)
-  -->
-    (make context ^present lshape2)
-    (remove 1)
-)
-
-(p p511
-    (context ^present lshape2)
-  -->
-    (modify 1 ^present lshape3)
-)
-
-(p p512
-    (context ^present lshape3)
-  -->
-    (remove 1)
-    (make context ^present random0)
-)
-
-(p p513
-    (context ^present random0)
-  -->
-    (remove 1)
-    (make context ^present random1)
-)
-
-(p p514
-    (context ^present remove-routed-net-segments)
-  - (net ^net-is-routed <> yes)
-  - (horizontal ^net-name <> nil ^status nil)
-  - (vertical ^net-name <> nil ^status nil)
-  -->
-    (write (crlf) | Finished with the routing.|)
-    (halt)
-)
-
-(p p1
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^com <min>)
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top)
-  - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>)
-    (pin ^net-name <> <nn> ^pin-x <min> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x { < <px> > <min> })
-    (pin ^net-name <nn> ^pin-x > <px> ^pin-channel-side top)
-  -->
-    (modify <h> ^min <px>)
-    (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p2
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^com <min>)
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom)
-  - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>)
-    (pin ^net-name <> <nn> ^pin-x <min> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x { < <px> > <min> })
-    (pin ^net-name <nn> ^pin-x > <px> ^pin-channel-side bottom)
-  -->
-    (modify <h> ^min <px>)
-    (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p3
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^com <max>)
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top)
-  - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>)
-    (pin ^net-name <> <nn> ^pin-x <max> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <px> })
-    (pin ^net-name <nn> ^pin-x < <px> ^pin-channel-side top)
-  -->
-    (modify <h> ^max <px>)
-    (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p4
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^com <max>)
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom)
-  - (horizontal-s ^net-name <nn> ^min <= <px> ^max >= <px> ^id <> <id>)
-    (pin ^net-name <> <nn> ^pin-x <max> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x <px> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <px> })
-    (pin ^net-name <nn> ^pin-x < <px> ^pin-channel-side bottom)
-  -->
-    (modify <h> ^max <px>)
-    (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p5
-    (context ^present reconnect)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom)
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top)
-  - (pin ^pin-x <max> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^max <max>)
-)
-
-(p p6
-    (context ^present reconnect)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top)
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom)
-  - (pin ^pin-x <min> ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^min <min>)
-)
-
-(p p7
-    (context ^present reconnect)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom)
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top)
-  - (pin ^pin-x <max> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^max <max>)
-)
-
-(p p8
-    (context ^present reconnect)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top)
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom)
-  - (pin ^pin-x <min> ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^min <min>)
-)
-
-(p p9
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com>)
-    (horizontal-s ^net-name <nn> ^min { <min1> >= <min> } ^max { <max1> <= <max> } ^com <> <com>)
-    { <v> (vertical-s ^net-name <nn> ^com { <com1> >= <min1> <= <max1> }) }
-    (pin ^net-name <> <nn> ^pin-x <com1>)
-    (congestion ^direction col ^coordinate { <px> >= <min1> <= <max1> })
-  - (pin ^net-name <> <nn> ^pin-x <px>)
-  - (vertical-s ^com <px>)
-  -->
-    (modify <v> ^com <px>)
-)
-
-(p p10
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com>)
-    (horizontal-s ^net-name <nn> ^min { <min1> >= <min> <= <max> } ^max { <max1> >= <max> } ^com <> <com>)
-    { <v> (vertical-s ^net-name <nn> ^com { <com1> >= <min1> <= <max> }) }
-    (pin ^net-name <> <nn> ^pin-x <com1>)
-    (congestion ^direction col ^coordinate { <px> >= <min1> <= <max> })
-  - (pin ^net-name <> <nn> ^pin-x <px>)
-  - (vertical-s ^com <px>)
-  -->
-    (modify <v> ^com <px>)
-)
-
-(p p11
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>)
-    (horizontal-s ^net-name <nn> ^min { <min1> >= <min> } ^max { <max1> <= <max> } ^com <> <hcom>)
-  - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max1> })
-    { <v> (vertical-s ^net-name <nn> ^com { <vcom> < <min1> }) }
-  - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>)
-  -->
-    (modify <v> ^com <min1>)
-)
-
-(p p12
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>)
-    (horizontal-s ^net-name <nn> ^min { <min1> >= <min> } ^max { <max1> <= <max> } ^com <> <hcom>)
-  - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max1> })
-    { <v> (vertical-s ^net-name <nn> ^com { <vcom> > <max1> }) }
-  - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>)
-  -->
-    (modify <v> ^com <max1>)
-)
-
-(p p13
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>)
-    (horizontal-s ^net-name <nn> ^min { <min1> >= <min> <= <max> } ^max { <max1> >= <max> } ^com <> <hcom>)
-  - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max> })
-    { <v> (vertical-s ^net-name <nn> ^com { <vcom> < <min1> }) }
-  - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>)
-  -->
-    (modify <v> ^com <min1>)
-)
-
-(p p14
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom> ^id <id>)
-    (horizontal-s ^net-name <nn> ^min { <min1> >= <min> <= <max> } ^max { <max1> >= <max> } ^com <> <hcom>)
-  - (vertical-s ^net-name <nn> ^com { >= <min1> <= <max> })
-    { <v> (vertical-s ^net-name <nn> ^com { <vcom> > <max> }) }
-  - (horizontal-s ^net-name <nn> ^min <= <vcom> ^max >= <vcom> ^id <> <id>)
-  -->
-    (modify <v> ^com <max>)
-)
-
-(p p15
-    (context ^present reconnect)
-    (horizontal-s ^net-name <nn> ^min <min1> ^max <max1> ^id <id1>)
-    { <h> (horizontal-s ^net-name <nn> ^min <max1> ^max <max2> ^com <com> ^id <id2>) }
-    (horizontal-s ^net-name <nn> ^min <max2> ^max <max3> ^id <id3>)
-  - (horizontal-s ^net-name <nn> ^id { <> <id1> <> <id2> <> <id3> })
-    (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max1>)
-    (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max2>)
-  -->
-    (modify <h> ^min <min1> ^max <max3>)
-)
-
-(p p16
-    (context ^present reconnect)
-    (vertical-s ^net-name <nn> ^min <min1> ^max <max1> ^id <id1>)
-    { <h> (vertical-s ^net-name <nn> ^min <max1> ^max <max2> ^com <com> ^id <id2>) }
-    (vertical-s ^net-name <nn> ^min <max2> ^max <max3> ^id <id3>)
-  - (vertical-s ^net-name <nn> ^id { <> <id1> <> <id2> <> <id3> })
-    (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max1>)
-    (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com <max2>)
-  -->
-    (modify <h> ^min <min1> ^max <max3>)
-)
-
-(p p17
-    (context ^present separate)
-    { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <max>)
-    (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side right)
-  - (pin ^net-name <nn> ^pin-x > <com> ^pin-y { > <py> <= <max> })
-  - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side top)
-  - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <py> < <max> })
-  - (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <max>)
-  -->
-    (modify <v> ^max <py>)
-    (make vertical-s ^net-name <nn> ^min <py> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p18
-    (context ^present separate)
-    { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <max>)
-    (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side left)
-  - (pin ^net-name <nn> ^pin-x < <com> ^pin-y { > <py> <= <max> })
-  - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side top)
-  - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <py> < <max> })
-  - (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <max>)
-  -->
-    (modify <v> ^max <py>)
-    (make vertical-s ^net-name <nn> ^min <py> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p19
-    (context ^present separate)
-    { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <min>)
-    (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side right)
-  - (pin ^net-name <nn> ^pin-x > <com> ^pin-y { < <py> >= <min> })
-  - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side bottom)
-  - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <py> })
-  - (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <min>)
-  -->
-    (modify <v> ^min <py>)
-    (make vertical-s ^net-name <nn> ^min <min> ^max <py> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p20
-    (context ^present separate)
-    { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (horizontal-s ^net-name <nn> ^min <com> ^max <hmax> ^com <min>)
-    (pin ^net-name <nn> ^pin-y { <py> > <min> < <max> } ^pin-channel-side left)
-  - (pin ^net-name <nn> ^pin-x < <com> ^pin-y { < <py> >= <min> })
-  - (pin ^net-name <nn> ^pin-x <com> ^pin-channel-side bottom)
-  - (horizontal-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <py> })
-  - (horizontal-s ^net-name <nn> ^min <hmin> ^max <com> ^com <min>)
-  -->
-    (modify <v> ^min <py>)
-    (make vertical-s ^net-name <nn> ^min <min> ^max <py> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p21
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <min>)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x { < <px> >= <min> } ^pin-y > <com>)
-  - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side left)
-  - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <px> })
-  - (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <min>)
-  -->
-    (modify <h> ^min <px>)
-    (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p22
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <min>)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x { < <px> >= <min> } ^pin-y < <com>)
-  - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side left)
-  - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <min> < <px> })
-  - (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <min>)
-  -->
-    (modify <h> ^min <px>)
-    (make horizontal-s ^net-name <nn> ^min <min> ^max <px> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p23
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <max>)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side top)
-  - (pin ^net-name <nn> ^pin-x { > <px> <= <max> } ^pin-y > <com>)
-  - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side right)
-  - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <px> < <max> })
-  - (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <max>)
-  -->
-    (modify <h> ^max <px>)
-    (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p24
-    (context ^present separate)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <com> ^id <id>) }
-    (vertical-s ^net-name <nn> ^min <com> ^max <vmax> ^com <max>)
-    (pin ^net-name <nn> ^pin-x { <px> > <min> < <max> } ^pin-channel-side bottom)
-  - (pin ^net-name <nn> ^pin-x { > <px> <= <max> } ^pin-y < <com>)
-  - (pin ^net-name <nn> ^pin-y <com> ^pin-channel-side right)
-  - (vertical-s ^net-name <nn> ^min <= <com> ^max >= <com> ^com { > <px> < <max> })
-  - (vertical-s ^net-name <nn> ^min <vmin> ^max <com> ^com <max>)
-  -->
-    (modify <h> ^max <px>)
-    (make horizontal-s ^net-name <nn> ^min <px> ^max <max> ^com <com> ^id (compute <id> + 1000) ^top-count 1 ^bot-count 1 ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p604
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side top)
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>)
-  - (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical)
-)
-
-(p p605
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side bottom)
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>)
-  - (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side top)
-  - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>)
-  -->
-    (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type vertical)
-)
-
-(p p606
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side top)
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1> ^com 1)
-    (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical)
-)
-
-(p p607
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x { <vcom> >= <min> <= <max> } ^pin-channel-side bottom)
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1> ^com <> 1)
-    (horizontal-s ^net-name <bnn> ^min <= <vcom> ^max >= <vcom> ^id <> <id1>)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side top)
-  - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>)
-  -->
-    (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type vertical)
-)
-
-(p p608
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0)
-    (vertical-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> })
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x <vcom> ^pin-channel-side top)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical)
-)
-
-(p p609
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0)
-    (vertical-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> })
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x <vcom> ^pin-channel-side bottom)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side top)
-  - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>)
-  -->
-    (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type vertical)
-)
-
-(p p610
-    (context ^present form-verti)
-    (horizontal-s ^net-name <tnn> ^min <min> ^max <max> ^com 1 ^id <id>)
-    (vertical-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> })
-    (horizontal-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <lr> ^id <id1>)
-    (last-row <lr>)
-    (vertical-s ^net-name <bnn> ^com <vcom>)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-x <vcom> ^pin-channel-side top)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-x <vcom> ^pin-channel-side bottom)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type vertical)
-)
-
-(p p611
-    (context ^present form-verti)
-    (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y { <vcom> >= <min> <= <max> } ^pin-channel-side right)
-    (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side left)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type horizontal)
-)
-
-(p p612
-    (context ^present form-verti)
-    (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference 0)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y { <vcom> >= <min> <= <max> } ^pin-channel-side left)
-    (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^id <id1>)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side right)
-  - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>)
-  -->
-    (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type horizontal)
-)
-
-(p p613
-    (context ^present form-verti)
-    (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0)
-    (horizontal-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> })
-    (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y <vcom> ^pin-channel-side right)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side left)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type horizontal)
-)
-
-(p p614
-    (context ^present form-verti)
-    (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com <com> ^id <id> ^difference <> 0)
-    (horizontal-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> })
-    (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <com> ^id <id1>)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y <vcom> ^pin-channel-side left)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side right)
-  - (constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn>)
-  -->
-    (make constraint ^net-name-1 <bnn> ^net-name-2 <tnn> ^pin-name-1 <bpn> ^pin-name-2 <tpn> ^seg-id-1 <id1> ^seg-id-2 <id> ^constraint-type horizontal)
-)
-
-(p p615
-    (context ^present form-verti)
-    (vertical-s ^net-name <tnn> ^min <min> ^max <max> ^com 1 ^id <id>)
-    (horizontal-s ^net-name <tnn> ^com { <vcom> >= <min> <= <max> })
-    (vertical-s ^net-name { <bnn> <> <tnn> } ^min <= <vcom> ^max >= <vcom> ^com <lc> ^id <id1>)
-    (last-col <lc>)
-    (horizontal-s ^net-name <bnn> ^com <vcom>)
-    (pin ^net-name <tnn> ^pin-name <tpn> ^pin-y <vcom> ^pin-channel-side right)
-    (pin ^net-name <bnn> ^pin-name <bpn> ^pin-y <vcom> ^pin-channel-side left)
-  - (constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  -->
-    (make constraint ^net-name-1 <tnn> ^net-name-2 <bnn> ^pin-name-1 <tpn> ^pin-name-2 <bpn> ^seg-id-1 <id> ^seg-id-2 <id1> ^constraint-type horizontal)
-)
-
-(p p616
-    (context ^present form-verti)
-    (constraint ^constraint-type vertical ^net-name-1 <tnn> ^net-name-2 <bnn> ^seg-id-1 <tid> ^seg-id-2 <bid>)
-    (constraint ^constraint-type vertical ^net-name-1 <nn1> ^net-name-2 <tnn> ^seg-id-1 <id1> ^seg-id-2 <tid2>)
-  - (vertical-cycle <tnn> <tid> <tid2>)
-  -->
-    (make vertical-cycle <tnn> <tid> <tid2>)
-)
-
-(p p617
-    (context ^present form-verti)
-    (constraint ^constraint-type horizontal ^net-name-1 <tnn> ^net-name-2 <bnn> ^seg-id-1 <tid> ^seg-id-2 <bid>)
-    (constraint ^constraint-type horizontal ^net-name-1 <nn1> ^net-name-2 <tnn> ^seg-id-1 <id1> ^seg-id-2 <tid2>)
-  - (horizontal-cycle <tnn> <tid> <tid2>)
-  -->
-    (make horizontal-cycle <tnn> <tid> <tid2>)
-)
-
-(p p618
-    (context ^present remove-cycle)
-    { <h> (horizontal-cycle <nn>) }
-  - (constraint ^constraint-type horizontal ^net-name-1 <nn>)
-  - (constraint ^constraint-type horizontal ^net-name-2 <nn>)
-  -->
-    (remove <h>)
-)
-
-(p p619
-    (context ^present remove-cycle)
-    { <h> (horizontal-cycle <nn>) }
-  - (constraint ^constraint-type horizontal ^net-name-2 <nn>)
-  -->
-    (remove <h>)
-)
-
-(p p620
-    (context ^present remove-cycle)
-    { <h> (horizontal-cycle <nn>) }
-  - (constraint ^constraint-type horizontal ^net-name-1 <nn>)
-  -->
-    (remove <h>)
-)
-
-(p p621
-    (context ^present remove-cycle)
-    { <h> (vertical-cycle <nn>) }
-  - (constraint ^constraint-type vertical ^net-name-1 <nn>)
-  - (constraint ^constraint-type vertical ^net-name-2 <nn>)
-  -->
-    (remove <h>)
-)
-
-(p p622
-    (context ^present remove-cycle)
-    { <h> (vertical-cycle <nn>) }
-  - (constraint ^constraint-type vertical ^net-name-2 <nn>)
-  -->
-    (remove <h>)
-)
-
-(p p623
-    (context ^present remove-cycle)
-    { <h> (vertical-cycle <nn>) }
-  - (constraint ^constraint-type vertical ^net-name-1 <nn>)
-  -->
-    (remove <h>)
-)
-
-(p p624
-    { <c> (context ^present remove-cycle) }
-  -->
-    (remove <c>)
-)
-
-(p p625
-    (context ^present remove-cycle)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom)
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <max>)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^max <max>)
-)
-
-(p p626
-    (context ^present remove-cycle)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top)
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <min>)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^min <min>)
-)
-
-(p p627
-    (context ^present remove-cycle)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <min1> ^max <min> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side bottom)
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side top)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <max>)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <max> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^max <max>)
-)
-
-(p p628
-    (context ^present remove-cycle)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^id <id1>) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <max1> ^id <id2>) }
-    (pin ^net-name <nn> ^pin-x <max> ^pin-channel-side top)
-    (pin ^net-name <nn> ^pin-x <min> ^pin-channel-side bottom)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <min>)
-  - (pin ^net-name <nn> ^pin-x { < <max> > <min> })
-    (last-row <lr>)
-  - (horizontal-s ^net-name <nn> ^id <id1> ^com { > 1 < <lr> })
-  - (horizontal-s ^net-name <nn> ^id <id2> ^com { > 1 < <lr> })
-  -->
-    (remove <h1>)
-    (make vertical-s ^net-name <nn> ^min 1 ^max <lr> ^com <min> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-    (modify <h2> ^min <min>)
-)
-
-(p p629
-    (context ^present remove-cycle)
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com 1)
-    (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from south)
-  - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y < <gy>)
-  - (vertical-s ^net-name <nn> ^min 1 ^max > <gy> ^com <gx>)
-  -->
-    (make vertical-s ^net-name <nn> ^min 1 ^max (compute <gy> + 1) ^com <gx> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p630
-    (context ^present remove-cycle)
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com 1)
-    (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from south)
-  - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y <= <gy>)
-    { <v> (vertical-s ^net-name <nn> ^min 1 ^max <= <gy> ^com <gx>) }
-  -->
-    (modify <v> ^max (compute <gy> + 1))
-)
-
-(p p631
-    (context ^present remove-cycle)
-    (last-row <lr>)
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com <lr>)
-    (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from north)
-  - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y > <gy>)
-  - (vertical-s ^net-name <nn> ^min < <gy> ^max <lr> ^com <gx>)
-  -->
-    (make vertical-s ^net-name <nn> ^min (compute <gy> - 1) ^max <lr> ^com <gx> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p632
-    (context ^present remove-cycle)
-    (last-row <lr>)
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^com <lr>)
-    (ff ^net-name <nn> ^grid-x { <gx> >= <hmin> <= <hmax> } ^grid-y <gy> ^came-from north)
-  - (ff ^net-name <nn> ^grid-x <> <gx> ^grid-y >= <gy>)
-    { <v> (vertical-s ^net-name <nn> ^min >= <gy> ^max <lr> ^com <gx>) }
-  -->
-    (modify <v> ^min (compute <gy> - 1))
-)
-
-(p p633
-    (context ^present remove-cycle)
-    (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com 1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from west)
-  - (ff ^net-name <nn> ^grid-x < <gx> ^grid-y <> <gy>)
-  - (horizontal-s ^net-name <nn> ^min 1 ^max > <gx> ^com <gy>)
-  -->
-    (make horizontal-s ^net-name <nn> ^min 1 ^max (compute <gx> + 1) ^com <gy> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p634
-    (context ^present remove-cycle)
-    (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com 1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from west)
-  - (ff ^net-name <nn> ^grid-x <= <gx> ^grid-y <> <gy>)
-    { <h> (horizontal-s ^net-name <nn> ^min 1 ^max <= <gx> ^com <gy>) }
-  -->
-    (modify <h> ^max (compute <gx> + 1))
-)
-
-(p p635
-    (context ^present remove-cycle)
-    (last-col <lc>)
-    (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com <lc>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from east)
-  - (ff ^net-name <nn> ^grid-x > <gx> ^grid-y <> <gy>)
-  - (horizontal-s ^net-name <nn> ^min < <gx> ^max <lc> ^com <gy>)
-  -->
-    (make horizontal-s ^net-name <nn> ^min (compute <gx> - 1) ^max <lc> ^com <gy> ^id (genatom) ^difference 0 ^absolute 0 ^sum 2)
-)
-
-(p p636
-    (context ^present remove-cycle)
-    (last-col <lc>)
-    (vertical-s ^net-name <nn> ^min <vmin> ^max <vmax> ^com <lc>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy> >= <vmin> <= <vmax> } ^came-from east)
-  - (ff ^net-name <nn> ^grid-x >= <gx> ^grid-y <> <gy>)
-    { <h> (horizontal-s ^net-name <nn> ^min >= <gx> ^max <lc> ^com <gy>) }
-  -->
-    (modify <h> ^min (compute <gx> - 1))
-)
-
-(p p637
-    (context ^present remove-cycle)
-    (last-row <lr>)
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0)
-    { <v> (vertical-s ^net-name <nn> ^min 1 ^max { <lr> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) }
-    (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side top)
-    (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from south)
-  -->
-    (modify <v> ^min (compute <lr> - 1))
-)
-
-(p p638
-    (context ^present remove-cycle)
-    (last-row <lr>)
-    (horizontal-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0)
-    { <v> (vertical-s ^net-name <nn> ^min 1 ^max { <lr> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) }
-    (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side bottom)
-    (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from north)
-  -->
-    (modify <v> ^max 2)
-)
-
-(p p639
-    (context ^present remove-cycle)
-    (last-col <lc>)
-    (vertical-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0)
-    { <v> (horizontal-s ^net-name <nn> ^min 1 ^max { <lc> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) }
-    (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side right)
-    (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from west)
-  -->
-    (modify <v> ^min (compute <lc> - 1))
-)
-
-(p p640
-    (context ^present remove-cycle)
-    (last-col <lc>)
-    (vertical-s ^net-name <nn> ^min <hmin> ^max <hmax> ^sum 2 ^difference 0)
-    { <v> (horizontal-s ^net-name <nn> ^min 1 ^max { <lc> <> 2 } ^com { <vcom> >= <hmin> <= <hmax> }) }
-    (pin ^net-name <nn> ^pin-x <vcom> ^pin-channel-side left)
-    (ff ^net-name <> <nn> ^grid-x <vcom> ^came-from east)
-  -->
-    (modify <v> ^max 2)
-)
-
-(p p472
-    (context ^present partial-route)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north) }
-    { <vs> (vertical-s ^net-name <nn> ^min <gy1> ^max <gy> ^com <gx>) }
-    { <ff2> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1> ^came-from south) }
-    { <v> (vertical ^net-name nil ^min <gy1> ^max <gy> ^com <gx> ^layer <lay>) }
-  -->
-    (modify <v> ^net-name <nn> ^pin-name <pn>)
-    (remove <ff1> <ff2> <vs>)
-)
-
-(p p473
-    (context ^present partial-route)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from east) }
-    { <vs> (horizontal-s ^net-name <nn> ^min <gx1> ^max <gx> ^com <gy>) }
-    { <ff2> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn1> ^came-from west) }
-    { <v> (horizontal ^net-name nil ^min <gx1> ^max <gx> ^com <gy> ^layer <lay>) }
-  -->
-    (modify <v> ^net-name <nn> ^pin-name <pn>)
-    (remove <ff1> <ff2> <vs>)
-)
-
-(p p474
-    (context ^present partial-route)
-    { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) }
-    { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from east)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from north)
-  -->
-    (remove <v2>)
-    (modify <h> ^com <vmin>)
-    (modify <v1> ^min <vmin>)
-)
-
-(p p475
-    (context ^present partial-route)
-    { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from east)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from north)
-  -->
-    (modify <v2> ^com <vcom>)
-    (modify <h> ^com <vmin>)
-)
-
-(p p476
-    (context ^present partial-route)
-    { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) }
-    { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from west)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from north)
-  -->
-    (remove <v2>)
-    (modify <h> ^com <vmin>)
-    (modify <v1> ^min <vmin>)
-)
-
-(p p477
-    (context ^present partial-route)
-    { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <vmin> ^max <min> ^com <hmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from west)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from north)
-  -->
-    (modify <v2> ^com <vcom>)
-    (modify <h> ^com <vmin>)
-)
-
-(p p478
-    (context ^present partial-route)
-    { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) }
-    { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from east)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from south)
-  -->
-    (remove <v2>)
-    (modify <h> ^com <vmax>)
-    (modify <v1> ^max <vmax>)
-)
-
-(p p479
-    (context ^present partial-route)
-    { <h> (horizontal-s ^net-name <nn> ^min <vcom> ^max <hmax> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from east)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from south)
-  -->
-    (modify <v2> ^com <vcom>)
-    (modify <h> ^com <vmax>)
-)
-
-(p p480
-    (context ^present partial-route)
-    { <v1> (vertical-s ^net-name <nn> ^min <min> ^max <max> ^com <vcom>) }
-    { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from west)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <min> ^came-from south)
-  -->
-    (remove <v2>)
-    (modify <h> ^com <vmax>)
-    (modify <v1> ^max <vmax>)
-)
-
-(p p481
-    (context ^present partial-route)
-    { <h> (horizontal-s ^net-name <nn> ^min <hmin> ^max <vcom> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <v2> (vertical-s ^net-name <nn> ^min <max> ^max <vmax> ^com <hmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from west)
-    (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <max> ^came-from south)
-  -->
-    (modify <v2> ^com <vcom>)
-    (modify <h> ^com <vmax>)
-)
-
-(p p482
-    (context ^present partial-route)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) }
-    { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from north)
-    (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from east)
-  -->
-    (remove <h2>)
-    (modify <v> ^com <hmin>)
-    (modify <h1> ^min <hmin>)
-)
-
-(p p483
-    (context ^present partial-route)
-    { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmax> ^came-from north)
-    (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from east)
-  -->
-    (modify <h2> ^com <hcom>)
-    (modify <v> ^com <hmin>)
-)
-
-(p p484
-    (context ^present partial-route)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) }
-    { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from north)
-    (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from west)
-  -->
-    (remove <h2>)
-    (modify <v> ^com <hmax>)
-    (modify <h1> ^max <hmax>)
-)
-
-(p p485
-    (context ^present partial-route)
-    { <v> (vertical-s ^net-name <nn> ^min <hcom> ^max <vmax> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmax> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmax> ^came-from north)
-    (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from west)
-  -->
-    (modify <h2> ^com <hcom>)
-    (modify <v> ^com <hmax>)
-)
-
-(p p486
-    (context ^present partial-route)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) }
-    { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from south)
-    (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from east)
-  -->
-    (remove <h2>)
-    (modify <v> ^com <hmin>)
-    (modify <h1> ^min <hmin>)
-)
-
-(p p487
-    (context ^present partial-route)
-    { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <min> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <hmin> ^max <min> ^com <vmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <vmin> ^came-from south)
-    (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from east)
-  -->
-    (modify <h2> ^com <hcom>)
-    (modify <v> ^com <hmin>)
-)
-
-(p p488
-    (context ^present partial-route)
-    { <h1> (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^com <hcom>) }
-    { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from south)
-    (ff ^net-name <nn> ^grid-x <min> ^grid-y <hcom> ^came-from west)
-  -->
-    (remove <h2>)
-    (modify <v> ^com <hmax>)
-    (modify <h1> ^max <hmax>)
-)
-
-(p p489
-    (context ^present partial-route)
-    { <v> (vertical-s ^net-name <nn> ^min <vmin> ^max <hcom> ^com <max> ^top-count 1 ^bot-count 1) }
-    { <h2> (horizontal-s ^net-name <nn> ^min <max> ^max <hmax> ^com <vmin> ^top-count 1 ^bot-count 1) }
-    (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <vmin> ^came-from south)
-    (ff ^net-name <nn> ^grid-x <max> ^grid-y <hcom> ^came-from west)
-  -->
-    (modify <h2> ^com <hcom>)
-    (modify <v> ^com <hmax>)
-)
-
-(p p186
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^difference { <d> < 0 })
-  - (horizontal-s ^difference < <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from south) }
-  - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y < <gy1>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y <gy1>)
-  - (horizontal ^net-name nil ^min < <gx2> ^max > <gx1> ^com <gy1>)
-  - (horizontal ^net-name nil ^min <gx2> ^max > <gx1> ^com <gy1> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx2> ^max <gx1> ^com <gy1> ^max-net nil)
-    { <v> (vertical ^net-name nil ^max { <max> > <gy1> } ^min { < <max> <= <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>)
-  - (extended-ff <nn> bottom)
-  - (vertical-cycle <nn>)
-  -->
-    (modify <v> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy1> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p187
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^difference { <d> < 0 })
-  - (horizontal-s ^difference < <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from south) }
-  - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y < <gy1>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y <gy1>)
-  - (horizontal ^net-name nil ^min < <gx1> ^max > <gx2> ^com <gy1>)
-  - (horizontal ^net-name nil ^min <gx1> ^max > <gx2> ^com <gy1> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx1> ^max <gx2> ^com <gy1> ^max-net nil)
-    { <v> (vertical ^net-name nil ^max { <max> > <gy1> } ^min { < <max> <= <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>)
-  - (extended-ff <nn> bottom)
-  - (vertical-cycle <nn>)
-  -->
-    (modify <v> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy1> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p188
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^difference { <d> < 0 })
-  - (horizontal-s ^difference < <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from south) }
-    (vertical-s ^net-name <nn> ^min <= <gy1> ^max > <gy1> ^com <gx1>)
-  - (ff ^net-name <nn> ^grid-x <> <gx1> ^grid-y <= <gy1>)
-    { <v> (vertical ^net-name nil ^max { <max> > <gy1> } ^min { < <max> <= <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy1>)
-  - (vertical-s ^net-name <> <nn> ^min <= <gy2> ^max >= <gy2> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>)
-  - (extended-ff <nn> bottom)
-  - (vertical-cycle <nn>)
-  -->
-    (make extended-ff <nn> bottom)
-    (modify <v> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy1> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p189
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^difference { <d> > 0 })
-  - (horizontal-s ^difference > <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from north) }
-  - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y > <gy1>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y <gy1>)
-  - (horizontal ^net-name nil ^min < <gx2> ^max > <gx1> ^com <gy1>)
-  - (horizontal ^net-name nil ^min <gx2> ^max > <gx1> ^com <gy1> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx2> ^max <gx1> ^com <gy1> ^max-net nil)
-    { <v> (vertical ^net-name nil ^max { <max> >= <gy1> } ^min { < <max> < <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy1> ^como <gy2>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>)
-  - (extended-ff <nn> top)
-  - (vertical-cycle <nn>)
-  -->
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy1> ^min <gy2> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p190
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^difference { <d> > 0 })
-  - (horizontal-s ^difference > <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from north) }
-  - (ff ^net-name <nn> ^grid-x <garb1> ^grid-y > <gy1>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y <gy1>)
-  - (horizontal ^net-name nil ^min < <gx1> ^max > <gx2> ^com <gy1>)
-  - (horizontal ^net-name nil ^min <gx1> ^max > <gx2> ^com <gy1> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx1> ^max <gx2> ^com <gy1> ^max-net nil)
-    { <v> (vertical ^net-name nil ^max { <max> >= <gy1> } ^min { < <max> < <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy1> ^como <gy2>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>)
-  - (extended-ff <nn> top)
-  - (vertical-cycle <nn>)
-  -->
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy1> ^min <gy2> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p191
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^difference { <d> > 0 })
-  - (horizontal-s ^difference > <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from north) }
-    (vertical-s ^net-name <nn> ^min < <gy1> ^max >= <gy1> ^com <gx1>)
-  - (ff ^net-name <nn> ^grid-x <> <gx1> ^grid-y >= <gy1>)
-    { <v> (vertical ^net-name nil ^max { <max> >= <gy1> } ^min { < <max> < <gy1> } ^com <gx1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy1> ^como <gy2>)
-  - (vertical-s ^net-name <> <nn> ^min <= <gy2> ^max >= <gy2> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx1> ^layer <lay1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx1> ^max >= <gx1> ^com <gy2> ^layer <lay1>)
-  - (extended-ff <nn> top)
-  - (vertical-cycle <nn>)
-  -->
-    (make extended-ff <nn> top)
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy1> ^min <gy2> ^layer <lay1> ^com <gx1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p192
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (horizontal-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <max> ^grid-y <gy> ^grid-layer <lay> ^came-from south ^pin-name <pn>) }
-  - (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com <gy>)
-    { <v> (vertical ^net-name nil ^max { <vmax> > <gy> } ^min { < <vmax> <= <gy> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <max> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gy2> ^layer <lay>)
-  - (vertical-cycle <nn>)
-    (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com > <gy>)
-  -->
-    (modify <v> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p193
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (horizontal-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <min> ^grid-y <gy> ^grid-layer <lay> ^came-from south ^pin-name <pn>) }
-  - (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com <gy>)
-    { <v> (vertical ^net-name nil ^max { <vmax> > <gy> } ^min { < <vmax> <= <gy> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <min> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gy2> ^layer <lay>)
-  - (vertical-cycle <nn>)
-    (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com > <gy>)
-  -->
-    (modify <v> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p194
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (horizontal-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <max> ^grid-y <gy> ^grid-layer <lay> ^came-from north ^pin-name <pn>) }
-  - (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com <gy>)
-    { <v> (vertical ^net-name nil ^max { <vmax> >= <gy> } ^min { < <vmax> < <gy> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy> ^como <gy2>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <max> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gy2> ^layer <lay>)
-  - (vertical-cycle <nn>)
-    (horizontal ^net-name nil ^min < <max> ^max >= <max> ^com < <gy>)
-  -->
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p195
-    (context ^present extend-ff)
-    (horizontal-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (horizontal-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <min> ^grid-y <gy> ^grid-layer <lay> ^came-from north ^pin-name <pn>) }
-  - (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com <gy>)
-    { <v> (vertical ^net-name nil ^max { <vmax> >= <gy> } ^min { < <vmax> < <gy> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction row ^coordinate <gy> ^como <gy2>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <min> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gy2> ^layer <lay>)
-  - (vertical-cycle <nn>)
-    (horizontal ^net-name nil ^min <= <min> ^max > <min> ^com < <gy>)
-  -->
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-)
-
-(p p196
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^difference { <d> < 0 })
-  - (vertical-s ^difference < <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from west) }
-  - (ff ^net-name <nn> ^grid-x < <gx1> ^grid-y <garb1>)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> < <gy1> })
-  - (vertical ^net-name nil ^min < <gy2> ^max > <gy1> ^com <gx1>)
-  - (vertical ^net-name nil ^min <gy2> ^max > <gy1> ^com <gx1> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy2> ^max <gy1> ^com <gx1> ^max-net nil)
-    { <v> (horizontal ^net-name nil ^max { <max> > <gx1> } ^min { < <max> <= <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>)
-  - (extended-ff <nn> left)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx2> ^min <gx1> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p197
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^difference { <d> < 0 })
-  - (vertical-s ^difference < <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from west) }
-  - (ff ^net-name <nn> ^grid-x < <gx1> ^grid-y <garb1>)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> > <gy1> })
-  - (vertical ^net-name nil ^min < <gy1> ^max > <gy2> ^com <gx1>)
-  - (vertical ^net-name nil ^min <gy1> ^max > <gy2> ^com <gx1> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy1> ^max <gy2> ^com <gx1> ^max-net nil)
-    { <v> (horizontal ^net-name nil ^max { <max> > <gx1> } ^min { < <max> <= <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>)
-  - (extended-ff <nn> left)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx2> ^min <gx1> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p198
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^difference { <d> < 0 })
-  - (vertical-s ^difference < <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from west) }
-    (horizontal-s ^net-name <nn> ^min <= <gx1> ^max > <gx1> ^com <gy1>)
-  - (ff ^net-name <nn> ^grid-x <= <gx1> ^grid-y <> <gy1>)
-    { <v> (horizontal ^net-name nil ^max { <max> > <gx1> } ^min { < <max> <= <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx1>)
-  - (horizontal-s ^net-name <> <nn> ^min <= <gx2> ^max >= <gx2> ^com <gy1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>)
-  - (extended-ff <nn> left)
-  - (horizontal-cycle <nn>)
-  -->
-    (make extended-ff <nn> left)
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx2> ^min <gx1> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p199
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^difference { <d> > 0 })
-  - (vertical-s ^difference > <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from east) }
-  - (ff ^net-name <nn> ^grid-x > <gx1> ^grid-y <garb1>)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> < <gy1> })
-  - (vertical ^net-name nil ^min < <gy2> ^max > <gy1> ^com <gx1>)
-  - (vertical ^net-name nil ^min <gy2> ^max > <gy1> ^com <gx1> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy2> ^max <gy1> ^com <gx1> ^max-net nil)
-    { <v> (horizontal ^net-name nil ^max { <max> >= <gx1> } ^min { < <max> < <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx1> ^como <gx2>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>)
-  - (extended-ff <nn> right)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx1> ^min <gx2> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p200
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^difference { <d> > 0 })
-  - (vertical-s ^difference > <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from east) }
-  - (ff ^net-name <nn> ^grid-x > <gx1> ^grid-y <gy1>)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y { <gy2> > <gy1> })
-  - (vertical ^net-name nil ^min < <gy1> ^max > <gy2> ^com <gx1>)
-  - (vertical ^net-name nil ^min <gy1> ^max > <gy2> ^com <gx1> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy1> ^max <gy2> ^com <gx1> ^max-net nil)
-    { <v> (horizontal ^net-name nil ^max { <max> >= <gx1> } ^min { < <max> < <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx1> ^como <gx2>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>)
-  - (extended-ff <nn> right)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx1> ^min <gx2> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p201
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^difference { <d> > 0 })
-  - (vertical-s ^difference > <d>)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn> ^came-from east) }
-    (horizontal-s ^net-name <nn> ^min < <gx1> ^max >= <gx1> ^com <gy1>)
-  - (ff ^net-name <nn> ^grid-x >= <gx1> ^grid-y <> <gy1>)
-    { <v> (horizontal ^net-name nil ^max { <max> >= <gx1> } ^min { < <max> < <gx1> } ^com <gy1> ^layer <lay1> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx1> ^como <gx2>)
-  - (horizontal-s ^net-name <> <nn> ^min <= <gx2> ^max >= <gx2> ^com <gy1>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy1> ^layer <lay1>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy1> ^max >= <gy1> ^com <gx2> ^layer <lay1>)
-  - (extended-ff <nn> right)
-  - (horizontal-cycle <nn>)
-  -->
-    (make extended-ff <nn> right)
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx1> ^min <gx2> ^layer <lay1> ^com <gy1> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p202
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (vertical-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <max> ^grid-layer <lay> ^came-from west ^pin-name <pn>) }
-  - (vertical ^net-name nil ^min < <max> ^max >= <max> ^com <gx>)
-    { <v> (horizontal ^net-name nil ^max { <vmax> > <gx> } ^min { < <vmax> <= <gx> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <max> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gx2> ^layer <lay>)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx2> ^min <gx> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p203
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (vertical-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <min> ^grid-layer <lay> ^came-from west ^pin-name <pn>) }
-  - (vertical ^net-name nil ^min <= <min> ^max > <min> ^com <gx>)
-    { <v> (horizontal ^net-name nil ^max { <vmax> > <gx> } ^min { < <vmax> <= <gx> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <min> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gx2> ^layer <lay>)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx2> ^min <gx> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p204
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (vertical-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <max> ^grid-layer <lay> ^came-from east ^pin-name <pn>) }
-  - (vertical ^net-name nil ^min < <max> ^max >= <max> ^com <gx>)
-    { <v> (horizontal ^net-name nil ^max { <vmax> >= <gx> } ^min { < <vmax> < <gx> } ^com <max> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx> ^como <gx2>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <max> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <max> ^max >= <max> ^com <gx2> ^layer <lay>)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx> ^min <gx2> ^layer <lay> ^com <max> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p205
-    (context ^present extend-ff)
-    (vertical-s ^net-name <nn> ^min <min> ^max <max> ^difference 0)
-  - (vertical-s ^difference <> 0)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <min> ^grid-layer <lay> ^came-from east ^pin-name <pn>) }
-  - (vertical ^net-name nil ^min <= <min> ^max > <min> ^com <gx>)
-    { <v> (horizontal ^net-name nil ^max { <vmax> >= <gx> } ^min { < <vmax> < <gx> } ^com <min> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (congestion ^direction col ^coordinate <gx> ^como <gx2>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <min> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <min> ^max >= <min> ^com <gx2> ^layer <lay>)
-  - (horizontal-cycle <nn>)
-  -->
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx> ^min <gx2> ^layer <lay> ^com <min> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-)
-
-(p p206
-    { <c> (context ^present extend-h-v-s) }
-  -->
-    (modify <c> ^present loose-constraint0)
-)
-
-(p p207
-    { <c> (context ^present extend-h-v-s) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from west ^pin-name <pn>) }
-    (horizontal-s ^net-name <nn> ^min <= <gx> ^max { <hmaxs> > <gx> } ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^com <gy>)
-    (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { <vcoms> > <gx> <= <hmaxs> })
-  - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { >= <gx> < <vcoms> })
-    { <h> (horizontal ^net-name nil ^min <gx> ^max { <hmax> >= <vcoms> } ^com <gy> ^layer <lay>) }
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <vcoms> ^layer <lay>)
-  -->
-    (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <vcoms>)
-    (modify <h> ^min <vcoms> ^min-net <nn>)
-    (modify <ff> ^grid-x <vcoms> ^can-chng-layer nil)
-    (modify <c> ^present propagate-constraint)
-)
-
-(p p208
-    { <c> (context ^present extend-h-v-s) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from east ^pin-name <pn>) }
-    (horizontal-s ^net-name <nn> ^min { <hmins> < <gx> } ^max >= <gx> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^com <gy>)
-    (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { <vcoms> < <gx> >= <hmins> })
-  - (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy> ^com { <= <gx> > <vcoms> })
-    { <h> (horizontal ^net-name nil ^min { <hmin> <= <vcoms> } ^max <gx> ^com <gy> ^layer <lay>) }
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <vcoms> ^layer <lay>)
-  -->
-    (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <vcoms>)
-    (modify <h> ^max <vcoms> ^max-net <nn>)
-    (modify <ff> ^grid-x <vcoms> ^can-chng-layer nil)
-    (modify <c> ^present propagate-constraint)
-)
-
-(p p209
-    { <c> (context ^present extend-h-v-s) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from south ^pin-name <pn>) }
-    (vertical-s ^net-name <nn> ^min <= <gy> ^max { <vmaxs> > <gy> } ^com <gx>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <gx>)
-    (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { <hcoms> > <gy> <= <vmaxs> })
-  - (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { >= <gy> < <hcoms> })
-    { <v> (vertical ^net-name nil ^min <gy> ^max { <vmax> >= <hcoms> } ^com <gx> ^layer <lay>) }
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <hcoms> ^layer <lay>)
-  -->
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <hcoms>)
-    (modify <v> ^min <hcoms> ^min-net <nn>)
-    (modify <ff> ^grid-y <hcoms> ^can-chng-layer nil)
-    (modify <c> ^present propagate-constraint)
-)
-
-(p p210
-    { <c> (context ^present extend-h-v-s) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^came-from north ^pin-name <pn>) }
-    (vertical-s ^net-name <nn> ^min { <vmins> < <gy> } ^max >= <gy> ^com <gx>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^com <gx>)
-    (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { <hcoms> < <gy> >= <vmins> })
-  - (horizontal-s ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { <= <gy> > <hcoms> })
-    { <v> (vertical ^net-name nil ^min { <vmin> <= <hcoms> } ^max <gy> ^com <gx> ^layer <lay>) }
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <hcoms> ^layer <lay>)
-  -->
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <hcoms>)
-    (modify <v> ^max <hcoms> ^max-net <nn>)
-    (modify <ff> ^grid-y <hcoms> ^can-chng-layer nil)
-    (modify <c> ^present propagate-constraint)
-)
-
-(p p29
-    (goal cleanup <c>)
-    (<c>)
-  -->
-    (remove 2)
-)
-
-(p p30
-    (goal cleanup <c>)
-  - (<c>)
-  -->
-    (remove 1)
-)
-
-(p p31
-    (goal cleanup)
-    (verti-has-loop)
-  -->
-    (remove 2)
-)
-
-(p p83
-    (context ^present propagate-constraint)
-  -->
-    (remove 1)
-    (make context ^previous propagate-constraint)
-    (make context ^present remove-cycle)
-)
-
-(p p84
-    (context ^present << propagate-constraint extend-pins move-ff >>)
-    (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com> ^layer <lay> ^compo <cpo> ^commo <egarb1>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <min2> <= <max1> } ^max { <max2> >= <min1> } ^com <cpo> ^layer <lay> ^compo <garb1> ^commo <egarb2>)
-    { <v1> (vertical ^net-name nil ^min { <min3> <= <com> } ^max { <max3> >= <cpo> > <min3> } ^com { <com2> <= <max1> >= <min1> <= <max2> >= <min2> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) }
-  -->
-    (make vertical ^min <min3> ^max <com> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <nn1> ^min-net <mnn>)
-    (make vertical ^min <cpo> ^max <max3> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <nn2> ^max-net <man>)
-    (remove <v1>)
-)
-
-(p p85
-    (context ^present << propagate-constraint extend-pins >>)
-    (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <com> ^layer <lay> ^compo <egarb2> ^commo <gy>)
-    { <v1> (vertical ^net-name nil ^min { <min3> <= <gy> } ^max { <max3> >= <com> > <min3> } ^com <gx> ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) }
-  -->
-    (make vertical ^min <min3> ^max <gy> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <nn1> ^min-net <mnn>)
-    (make vertical ^min <com> ^max <max3> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <nn2> ^max-net <man>)
-    (remove <v1>)
-)
-
-(p p86
-    (context ^present << propagate-constraint extend-pins >>)
-    (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <com> ^layer <lay> ^compo <gy> ^commo <egarb2>)
-    { <v1> (vertical ^net-name nil ^min { <min3> <= <com> } ^max { <max3> >= <gy> > <min3> } ^com <gx> ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) }
-  -->
-    (make vertical ^min <min3> ^max <com> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <nn2> ^min-net <mnn>)
-    (make vertical ^min <gy> ^max <max3> ^com <gx> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <nn1> ^max-net <man>)
-    (remove <v1>)
-)
-
-(p p87
-    (context ^present propagate-constraint)
-    (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <max1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min <min2> ^max <gar2> ^com <com> ^layer <lay> ^compo <egarb3> ^commo <egarb4>)
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <min2> > <max1> } ^com <com> ^layer <lay> ^compo <egarb5> ^commo <egarb6>) }
-  - (vertical ^com { > <max1> < <min2> })
-  -->
-    (remove <h1>)
-)
-
-(p p88
-    (context ^present << propagate-constraint extend-pins move-ff >>)
-    (vertical ^status nil ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com> ^layer <lay> ^compo <cpo> ^commo <egarb1>)
-    (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <min2> <= <max1> } ^max { <max2> >= <min1> } ^com <cpo> ^layer <lay> ^compo <garb1> ^compo <egarb2>)
-    { <h1> (horizontal ^net-name nil ^min { <min3> <= <com> } ^max { <max3> >= <cpo> } ^com { <com2> <= <max1> >= <min1> <= <max2> >= <min2> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <mnn> ^max-net <man>) }
-  -->
-    (make horizontal ^min <min3> ^max <com> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^min-net <mnn> ^max-net <nn1>)
-    (make horizontal ^min <cpo> ^max <max3> ^com <com2> ^compo <cpo2> ^commo <cmo2> ^layer <lay> ^max-net <man> ^min-net <nn2>)
-    (remove <h1>)
-)
-
-(p p89
-    (context ^present propagate-constraint)
-    (vertical ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <max1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min <min2> ^max <garb2> ^com <com> ^layer <lay> ^compo <egarb3> ^commo <egarb4>)
-  - (horizontal ^com { > <max1> < <min2> })
-    { <v1> (vertical ^net-name nil ^min <max1> ^max { <min2> > <max1> } ^com <com> ^layer <lay> ^compo <egarb5> ^commo <egarb6>) }
-  -->
-    (remove <v1>)
-)
-
-(p p90
-    (context ^present propagate-constraint)
-    (vertical ^status nil ^net-name { <nn1> <> nil } ^min <vmin> ^max <garb1> ^com <vcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <vcom> } ^max { <garb3> >= <vcom> } ^com <hcom> ^layer <lay> ^compo <vmin> ^commo <garb5>)
-    { <v1> (vertical ^net-name nil ^min <garb4> ^max { <vmin> > <garb4> } ^com <vcom> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) }
-  -->
-    (modify <v1> ^max <hcom> ^max-net <nn2>)
-)
-
-(p p91
-    (context ^present propagate-constraint)
-    (vertical ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <vcom> } ^max { <garb3> >= <vcom> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <vmax>)
-    { <v1> (vertical ^net-name nil ^min <vmax> ^max { <garb5> > <vmax> } ^com <vcom> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) }
-  -->
-    (modify <v1> ^min <hcom> ^min-net <nn2>)
-)
-
-(p p92
-    (context ^present propagate-constraint)
-    (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <min> ^max <garb1> ^com <hcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <hcom> } ^max { <garb3> >= <hcom> } ^com <vcom> ^layer <lay> ^compo <min> ^commo <egarb3>)
-    { <h1> (horizontal ^net-name nil ^min <garb4> ^max { <min> > <garb4> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-  -->
-    (modify <h1> ^max <vcom> ^max-net <nn2>)
-)
-
-(p p93
-    (context ^present propagate-constraint)
-    (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <garb1> ^max <max> ^com <hcom> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (vertical ^status nil ^net-name { <nn2> <> <nn1> <> nil } ^min { <garb2> <= <hcom> } ^max { <garb3> >= <hcom> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <max>)
-    { <h1> (horizontal ^net-name nil ^min <max> ^max { <garb4> > <max> } ^com <hcom> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) }
-  -->
-    (modify <h1> ^min <vcom> ^min-net <nn2>)
-)
-
-(p p94
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    { <h1> (horizontal ^net-name nil ^min <garb3> ^max { <gx> > <garb3> } ^com <gy> ^layer <lay> ^compo <egarb3> ^commo <egarb4>) }
-    (vertical ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <vcom> ^layer <lay> ^compo <gx> ^commo <egarb2>)
-  -->
-    (modify <h1> ^max <vcom> ^max-net <nn2>)
-)
-
-(p p95
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { <garb4> > <gx> } ^com <gy> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-    (vertical ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <vcom> ^layer <lay> ^compo <garb3> ^commo <gx>)
-  -->
-    (modify <h1> ^min <vcom> ^min-net <nn2>)
-)
-
-(p p96
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <hcom> ^layer <lay> ^compo <gy> ^commo <garb3>)
-    { <v1> (vertical ^net-name nil ^min <garb4> ^max { <gy> > <garb4> } ^com <gx> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  -->
-    (modify <v1> ^max <hcom> ^max-net <nn2>)
-)
-
-(p p97
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    (horizontal ^status nil ^net-name { <nn2> <> <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <hcom> ^layer <lay> ^compo <garb3> ^commo <gy>)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { <garb4> > <gy> } ^com <gx> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  -->
-    (modify <v1> ^min <hcom> ^min-net <nn2>)
-)
-
-(p p98
-    (context ^present << propagate-constraint extend-pins random1 check-for-routed-net >>)
-    { <h1> (horizontal ^min <min> ^max <= <min>) }
-  -->
-    (remove <h1>)
-)
-
-(p p99
-    (context ^present << propagate-constraint extend-pins random1 check-for-routed-net >>)
-    { <v1> (vertical ^min <min> ^max <= <min>) }
-  -->
-    (remove <v1>)
-)
-
-(p p100
-    { <h1> (horizontal ^min <min> ^max <= <min>) }
-  -->
-    (remove <h1>)
-)
-
-(p p101
-    { <v1> (vertical ^min <min> ^max <= <min>) }
-  -->
-    (remove <v1>)
-)
-
-(p p102
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com <min1>)
-  - (horizontal ^status nil ^min < <min1> ^max >= <min1> ^com <com1>)
-    (vertical ^status nil ^net-name <garb1> ^min { <vmin> <= <com1> } ^max { >= <com1> > <vmin> } ^com { <com2> > <min1> <= <max1> } ^layer <garb2> ^compo <egarb4> ^commo <egarb5>)
-  - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com { < <com2> >= <min1> })
-  -->
-    (modify <h1> ^min <com2> ^min-net nil)
-)
-
-(p p103
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com <min1>)
-  - (vertical ^status nil ^min < <min1> ^max >= <min1> ^com <com1>)
-    (horizontal ^status nil ^net-name <garb1> ^min { <hmin> <= <com1> } ^max { <garb2> >= <com1> > <hmin> } ^com { <com2> > <min1> <= <max1> } ^layer <garb3> ^compo <egarb4> ^commo <egarb5>)
-  - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com { < <com2> >= <min1> })
-  -->
-    (modify <v1> ^min <com2> ^min-net nil)
-)
-
-(p p104
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-  - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com <max1>)
-  - (horizontal ^status nil ^min <= <max1> ^max > <max1> ^com <com1>)
-    (vertical ^status nil ^net-name <garb1> ^min { <vmin> <= <com1> } ^max { <garb2> >= <com1> > <vmin> } ^com { <com2> >= <min1> < <max1> } ^layer <egarb1> ^compo <egarb2> ^commo <egarb3>)
-  - (vertical ^status nil ^min <= <com1> ^max >= <com1> ^com { > <com2> <= <max1> })
-  -->
-    (modify <h1> ^max <com2> ^max-net nil)
-)
-
-(p p105
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com <com1> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com <max1>)
-  - (vertical ^status nil ^min <= <max1> ^max > <max1> ^com <com1>)
-    (horizontal ^status nil ^net-name <garb1> ^min { <hmin> <= <com1> } ^max { <garb2> >= <com1> > <hmin> } ^com { <com2> >= <min1> < <max1> } ^layer <egarb1> ^compo <egarb4> ^commo <egarb5>)
-  - (horizontal ^status nil ^min <= <com1> ^max >= <com1> ^com { > <com2> <= <max1> })
-  -->
-    (modify <v1> ^max <com2> ^max-net nil)
-)
-
-(p p106
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <hmin> ^max { <hmax> > <hmin> } ^com <hcom> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) }
-  - (vertical ^com { > <hmin> < <hmax> })
-  - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmax> ^layer <lay>)
-  - (horizontal ^status nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <lay>)
-    (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <hmax> ^layer <> <lay> ^compo <egarb4> ^commo <egarb5>)
-    (vertical ^net-name { <> <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <hmin> ^layer <> <lay> ^compo <egarb2> ^commo <egarb3>)
-  -->
-    (remove <h1>)
-)
-
-(p p107
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <vmin> ^max { <vmax> > <vmin> } ^com <vcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  - (horizontal ^com { > <vmin> < <vmax> })
-  - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmax> ^layer <lay>)
-  - (vertical ^status nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <lay>)
-    (horizontal ^net-name { <nn1> <> nil } ^min { <garb1> <= <vcom> } ^max { <garb2> >= <vcom> } ^com <vmax> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>)
-    (horizontal ^net-name { <> <nn1> <> nil } ^min { <garb4> <= <vcom> } ^max { <garb5> >= <vcom> } ^com <vmin> ^layer { <garb6> <> <lay> } ^compo <egarb4> ^commo <egarb5>)
-  -->
-    (remove <v1>)
-)
-
-(p p108
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <hmin> ^max { <hmax> > <hmin> } ^com <hcom> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) }
-  - (vertical ^com { > <hmin> < <hmax> })
-  - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmin> ^layer <lay>)
-  - (horizontal ^status nil ^min < <hmin> ^max <hmin> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmax> ^layer <lay>)
-  - (horizontal ^status nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <lay>)
-    (vertical ^net-name { <nn1> <> nil } ^min { <garb1> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <hmax> ^layer { <garb3> <> <lay> } ^compo <egarb2> ^commo <egarb3>)
-    (vertical ^net-name { <garb7> <> <nn1> <> nil } ^min { <gabr4> <= <hcom> } ^max { <garb5> >= <hcom> } ^com <hmin> ^layer { <garb6> <> <lay> } ^compo <egarb4> ^commo <egarb5>)
-  -->
-    (remove <h1>)
-)
-
-(p p109
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <vmin> ^max { <vmax> > <vmin> } ^com <vcom> ^layer <lay> ^compo <egarb6> ^commo <egarb7>) }
-  - (horizontal ^com { > <vmin> < <vmax> })
-  - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmin> ^layer <lay>)
-  - (vertical ^status nil ^min < <vmin> ^max <vmin> ^com <vcom> ^layer <lay>)
-    (horizontal ^net-name { <nn1> <> nil } ^min { <garb1> <= <vcom> } ^max { <garb2> >= <vcom> } ^com <vmax> ^layer { <garb3> <> <lay> } ^compo <egarb2> ^commo <egarb3>)
-    (horizontal ^net-name { <garb7> <> <nn1> <> nil } ^min { <garb4> <= <vcom> } ^max { <garb5> >= <vcom> } ^com <vmin> ^layer { <garb6> <> <lay> } ^compo <egarb4> ^commo <egarb5>)
-  -->
-    (remove <v1>)
-)
-
-(p p110
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-  - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max2> ^layer <lay>)
-  - (horizontal ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> < <max2> })
-  - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> < <max2> } ^max-net nil)
-  - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> < <max2> } ^min-net nil)
-    (horizontal ^net-name { <nn> <> nil } ^min <garb1> ^max <max1> ^com <hcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>)
-    (vertical ^net-name { <nn1> <> <nn> <> nil } ^min { <garb4> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max2> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>)
-  - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> < <max2> })
-  -->
-    (modify <h1> ^max (compute <max2> - 1) ^max-net nil)
-)
-
-(p p111
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-  - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max1> ^layer <lay>)
-  - (horizontal ^min < <max1> ^max <max1> ^com <hcom> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> < <max2> })
-  - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> < <max2> } ^max-net nil)
-  - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> < <max2> } ^min-net nil)
-    (horizontal ^net-name { <nn> <> nil } ^min <max2> ^max <garb1> ^com <hcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>)
-    (vertical ^net-name { <nn1> <> <nn> <> nil } ^min { <garb4> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max1> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>)
-  - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> < <max2> })
-  -->
-    (modify <h1> ^min (compute <max1> + 1) ^min-net nil)
-)
-
-(p p112
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-  - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max2> ^layer <lay>)
-  - (horizontal ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { >= <max1> < <max2> })
-  - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { >= <max1> < <max2> } ^max-net nil)
-  - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { >= <max1> < <max2> } ^min-net nil)
-  - (horizontal ^min < <max1> ^max <max1> ^com <hcom> ^layer <lay>)
-    (vertical ^net-name { <nn1> <> nil } ^min { <garb1> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max2> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>)
-  - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { >= <max1> < <max2> })
-  -->
-    (modify <h1> ^max (compute <max2> - 1) ^max-net nil)
-)
-
-(p p113
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-  - (vertical ^min <= <hcom> ^max >= <hcom> ^com <max1> ^layer <lay>)
-  - (horizontal ^min < <max1> ^max <max1> ^com <hcom> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> <= <max2> })
-  - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> <= <max2> } ^max-net nil)
-  - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> <= <max2> } ^min-net nil)
-  - (horizontal ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>)
-    (vertical ^net-name { <nn1> <> nil } ^min { <garb1> <= <hcom> } ^max { <garb2> >= <hcom> } ^com <max1> ^layer { <garb3> <> <lay> } ^compo <egarb6> ^commo <egarb7>)
-  - (vertical ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> <= <max2> })
-  -->
-    (modify <h1> ^min (compute <max1> + 1) ^min-net nil)
-)
-
-(p p114
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <max1> ^max { <max2> > <max1> } ^com <hcom> ^layer <lay> ^compo <egarb4> ^commo <egarb5>) }
-    (vertical ^net-name { <nn> <> nil } ^min <garb1> ^max <max1> ^com <hcom> ^layer <lay> ^compo <egarb2> ^commo <egarb3>)
-  - (horizontal ^min <= <hcom> ^max >= <hcom> ^com <max2> ^layer <lay>)
-  - (vertical ^min <max2> ^max > <max2> ^com <hcom> ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <hcom> ^max > <hcom> ^com { > <max1> < <max2> })
-  - (horizontal ^net-name nil ^min < <hcom> ^max <hcom> ^com { > <max1> < <max2> } ^max-net nil)
-  - (horizontal ^net-name nil ^min <hcom> ^max > <hcom> ^com { > <max1> < <max2> } ^min-net nil)
-    (horizontal ^net-name { <nn1> <> <nn> <> nil } ^min { <garb2> <= <hcom> } ^max { <garb3> >= <hcom> } ^com <max2> ^layer { <garb4> <> <lay> } ^compo <egarb6> ^commo <egarb7>)
-  - (horizontal ^net-name { <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com { > <max1> < <max2> })
-  -->
-    (modify <v1> ^max (compute <max2> - 1) ^max-net nil)
-)
-
-(p p115
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^compo <gy>)
-    { <v1> (vertical ^net-name nil ^min <vmin> ^max { <gy> > <vmin> } ^com <gx> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { >= <vmin> < <gy> })
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { >= <vmin> < <gy> } ^max-net nil)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { >= <vmin> < <gy> } ^min-net nil)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <vmin> < <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <vmin> ^max >= <vmin> ^com <gx>)
-  -->
-    (modify <v1> ^max (compute <gy> - 1) ^max-net nil)
-)
-
-(p p116
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { <max2> > <gx> } ^com <gy> ^layer <lay> ^compo <egarb2> ^commo <egarb3>) }
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> <= <max2> } ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> <= <max2> })
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> <= <max2> } ^max-net nil)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> <= <max2> })
-  -->
-    (modify <h1> ^min (compute <gx> + 1) ^min-net nil)
-)
-
-(p p117
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <vmin> ^max { <vmax> > <vmin> } ^com <vcom> ^layer <lay> ^min-net { <nn> <> nil }) }
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { <hmax> >= <vcom> > <hmin> } ^com <vmax> ^layer <lay> ^commo <vmin> ^min-net { <> <nn> <> nil } ^max-net { <> <nn> <> nil })
-  - (vertical ^net-name nil ^min < <vmax> ^max > <vmax> ^com { > <hmin> < <hmax> })
-  - (vertical ^net-name nil ^min < <vmax> ^max <vmax> ^com { > <hmin> < <vcom> } ^max-net nil)
-  - (vertical ^net-name nil ^min < <vmax> ^max <vmax> ^com { > <vcom> < <hmax> } ^max-net nil)
-  - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com { > <hmin> < <hmax> } ^min-net nil)
-  - (vertical ^net-name { <nn> <> nil } ^min <= <vmax> ^max >= <vmax> ^com { > <hmin> < <hmax> })
-  -->
-    (remove <v1>)
-)
-
-(p p118
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>)
-  - (vertical ^net-name nil ^com <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com > <max1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com < <min1>)
-    { <h1> (horizontal ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) }
-  - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com { >= <min1> <= <max1> } ^layer <lay2>)
-    { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) }
-  - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>)
-    (pin ^net-name <nn2> ^pin-x < <com1>)
-    (pin ^net-name <nn2> ^pin-x > <com1>)
-    { <b1> (branch-no <pn>) }
-  -->
-    (make branch-no (compute <pn> + 1))
-    (modify <t1> ^no-of-attached-pins (compute <nap> - 1))
-    (remove <b1>)
-    (make horizontal ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make horizontal ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>)
-    (make horizontal ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cmo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from east)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cpo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from west)
-    (remove <h1>)
-)
-
-(p p119
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>)
-  - (vertical ^net-name nil ^com <com1>)
-    { <h1> (horizontal ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) }
-  - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com > <com2>)
-  - (horizontal ^net-name nil ^min < <com1> ^max > <com1> ^com < <com2>)
-    { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) }
-  - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>)
-    (pin ^net-name <nn2> ^pin-x < <com1>)
-    (pin ^net-name <nn2> ^pin-x > <com1>)
-    { <b1> (branch-no <pn>) }
-  -->
-    (make branch-no (compute <pn> + 1))
-    (modify <t1> ^no-of-attached-pins (compute <nap> - 1))
-    (remove <b1>)
-    (make horizontal ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make horizontal ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>)
-    (make horizontal ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cmo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from east)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <cpo1> ^grid-y <com2> ^grid-layer <lay2> ^came-from west)
-    (remove <h1>)
-)
-
-(p p120
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>)
-  - (horizontal ^net-name nil ^com <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com > <max1>)
-  - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com < <min1>)
-    { <v1> (vertical ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) }
-  - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com { >= <min1> <= <max1> } ^layer <lay2>)
-    { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) }
-  - (vertical ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>)
-    (pin ^net-name <nn2> ^pin-y < <com1>)
-    (pin ^net-name <nn2> ^pin-y > <com1>)
-    { <b1> (branch-no <pn>) }
-  -->
-    (make branch-no (compute <pn> + 1))
-    (modify <t1> ^no-of-attached-pins (compute <nap> - 1))
-    (remove <b1>)
-    (make vertical ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make vertical ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>)
-    (make vertical ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cmo1> ^grid-layer <lay2> ^came-from north)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cpo1> ^grid-layer <lay2> ^came-from south)
-    (remove <v1>)
-)
-
-(p p121
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay1> ^compo <cpo1> ^commo <cmo1>)
-  - (horizontal ^net-name nil ^com <com1>)
-    { <v1> (vertical ^net-name nil ^min { <min2> < <com1> } ^max { <max2> > <com1> > <min2> } ^com { <com2> >= <min1> <= <max1> } ^layer { <lay2> <> <lay1> } ^compo <cpo2> ^commo <cmo2>) }
-  - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com > <com2>)
-  - (vertical ^net-name nil ^min < <com1> ^max > <com1> ^com < <com2>)
-    { <t1> (to-be-routed ^net-name { <nn2> <> <nn1> } ^no-of-attached-pins <nap>) }
-  - (vertical ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>)
-    (pin ^net-name <nn2> ^pin-y < <com1>)
-    (pin ^net-name <nn2> ^pin-y > <com1>)
-    { <b1> (branch-no <pn>) }
-  -->
-    (make branch-no (compute <pn> + 1))
-    (modify <t1> ^no-of-attached-pins (compute <nap> - 1))
-    (remove <b1>)
-    (make vertical ^min <cmo1> ^max <cpo1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make vertical ^min <min2> ^max <cmo1> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>)
-    (make vertical ^min <cpo1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cmo1> ^grid-layer <lay2> ^came-from north)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com2> ^grid-y <cpo1> ^grid-layer <lay2> ^came-from south)
-    (remove <v1>)
-)
-
-(p p122
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^net-name nil ^min <min2> ^max { <max2> > <min2> } ^com <com2> ^layer <lay2> ^compo <cpo2> ^commo <cmo2>) }
-  - (horizontal ^net-name nil ^min <= <min2> ^max >= <max2> ^com > <com2>)
-  - (horizontal ^net-name nil ^min <= <min2> ^max >= <max2> ^com < <com2>)
-  - (horizontal ^net-name nil ^min <= <min2> ^max >= <max2> ^com <com2> ^layer <> <lay2>)
-    (congestion ^direction col ^coordinate { <x1> <= <max2> } ^como { <x2> >= <min2> })
-  - (horizontal ^net-name nil ^min <= <x2> ^max >= <x1> ^com > <com2>)
-  - (horizontal ^net-name nil ^min <= <x2> ^max >= <x1> ^com < <com2>)
-  - (horizontal ^net-name nil ^min <= <x2> ^max >= <x1> ^com <com2> ^layer <> <lay2>)
-    { <t1> (to-be-routed ^net-name <nn2> ^no-of-attached-pins <nap>) }
-  - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <x2> ^max >= <x1>)
-    (pin ^net-name <nn2> ^pin-x <= <x2>)
-    (pin ^net-name <nn2> ^pin-x >= <x1>)
-    { <b1> (branch-no <pn>) }
-  - (horizontal ^net-name { <> <nn2> <> nil } ^min <= <x2> ^max >= <x2> ^com <com2> ^layer <lay2>)
-  - (vertical ^net-name { <> <nn2> <> nil } ^min <= <com2> ^max >= <com2> ^com <x2> ^layer <lay2>)
-  - (horizontal ^net-name { <> <nn2> <> nil } ^min <= <x1> ^max >= <x1> ^com <com2> ^layer <lay2>)
-  - (vertical ^net-name { <> <nn2> <> nil } ^min <= <com2> ^max >= <com2> ^com <x1> ^layer <lay2>)
-  -->
-    (make branch-no (compute <pn> + 1))
-    (modify <t1> ^no-of-attached-pins (compute <nap> - 1))
-    (remove <b1>)
-    (make horizontal ^min <x2> ^max <x1> ^com <com2> ^layer <lay2> ^net-name <nn2> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make horizontal ^min <min2> ^max <x2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>)
-    (make horizontal ^min <x1> ^max <max2> ^com <com2> ^layer <lay2> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <x2> ^grid-y <com2> ^grid-layer <lay2> ^came-from east)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <x1> ^grid-y <com2> ^grid-layer <lay2> ^came-from west)
-    (remove <h1>)
-)
-
-(p p123
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^net-name nil ^min <min1> ^max { <max1> > <min1> } ^com { <com1> <> 1 } ^layer <lay1> ^compo <cpo1> ^commo <cmo1> ^min-net <mnn> ^max-net <xnn>) }
-  - (horizontal ^net-name nil ^min < <com1> ^max > <com1>)
-    (horizontal ^net-name nil ^min <com1> ^max { <garb3> > <com1> } ^com { <bhcom> <= <max1> >= <min1> } ^layer <garb4>)
-    (horizontal ^net-name nil ^min { <garb1> < <com1> } ^max <com1> ^com { <thcom> <= <max1> > <bhcom> } ^layer <garb2>)
-  - (horizontal ^net-name nil ^min < <com1> ^max <com1> ^com { < <thcom> > <bhcom> })
-  - (horizontal ^net-name nil ^min <com1> ^max > <com1> ^com { < <thcom> > <bhcom> })
-    { <t1> (to-be-routed ^net-name <nn2> ^no-of-attached-pins <nap>) }
-  - (vertical ^status nil ^net-name { <nn2> <> nil } ^com <com1>)
-  - (horizontal ^status nil ^net-name { <nn2> <> nil } ^min <= <com1> ^max >= <com1>)
-    (pin ^net-name <nn2> ^pin-x < <com1>)
-    (pin ^net-name <nn2> ^pin-x > <com1>)
-    { <b1> (branch-no <pn>) }
-  -->
-    (make branch-no (compute <pn> + 1))
-    (modify <t1> ^no-of-attached-pins (compute <nap> - 1))
-    (remove <v1> <b1>)
-    (make vertical ^min <min1> ^max <bhcom> ^com <com1> ^layer <lay1> ^commo <cmo1> ^compo <cpo1> ^max-net <nn2> ^min-net <mnn>)
-    (make vertical ^min <thcom> ^max <max1> ^com <com1> ^layer <lay1> ^commo <cmo1> ^compo <cpo1> ^min-net <nn2> ^max-net <xnn>)
-    (make vertical ^min <bhcom> ^max <thcom> ^com <com1> ^layer <lay1> ^commo <cmo1> ^compo <cpo1> ^net-name <nn2> ^pin-name <pn>)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com1> ^grid-y <bhcom> ^grid-layer <lay1> ^came-from north)
-    (make ff ^net-name <nn2> ^pin-name <pn> ^grid-x <com1> ^grid-y <thcom> ^grid-layer <lay1> ^came-from south)
-)
-
-(p p124
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <com2> ^grid-layer <lay1> ^pin-name <egarb1>)
-  - (vertical ^net-name nil ^min <= <com2> ^max >= <com2> ^com <gx>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com > <com2>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com < <com2>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min < <gx>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^com < <gx>)
-    { <h1> (horizontal ^net-name nil ^min { <min2> < <gx> } ^max { <max2> >= <gx> > <min2> } ^com <com2> ^layer <lay1> ^compo <cpo2> ^commo <cmo2> ^min-net <nn2>) }
-  -->
-    (make horizontal ^min <min2> ^max (compute <gx> - 1) ^com <com2> ^layer <lay1> ^commo <cmo2> ^compo <cpo2> ^min-net <nn2>)
-    (modify <h1> ^min <gx> ^min-net <nn1>)
-)
-
-(p p125
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn1> ^grid-x <gx> ^grid-y <com2> ^grid-layer <lay1> ^pin-name <egarb1>)
-  - (vertical ^net-name nil ^min <= <com2> ^max >= <com2> ^com <gx>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com > <com2>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com < <com2>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^max > <gx>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^com > <gx>)
-    { <h1> (horizontal ^net-name nil ^min { <min2> <= <gx> } ^max { <max2> > <gx> > <min2> } ^com <com2> ^layer <lay1> ^compo <cpo2> ^commo <cmo2> ^max-net <nn2>) }
-  -->
-    (make horizontal ^min (compute <gx> + 1) ^max <max2> ^com <com2> ^layer <lay1> ^commo <cmo2> ^compo <cpo2> ^max-net <nn2>)
-    (modify <h1> ^max <gx> ^max-net <nn1>)
-)
-
-(p p126
-    (context ^present << propagate-constraint extend-total-verti >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> east ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) }
-  - (horizontal ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>)
-  - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>)
-  -->
-    (modify <h1> ^min (compute <max1> + 1) ^min-net <nn>)
-    (make horizontal ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>)
-    (modify <ff1> ^grid-x (compute <max1> + 1) ^came-from west ^can-chng-layer nil)
-)
-
-(p p127
-    (context ^present << propagate-constraint extend-total-verti >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> west ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <h1> (horizontal ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) }
-  - (horizontal ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>)
-  - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>)
-  -->
-    (modify <h1> ^max (compute <max1> - 1) ^max-net <nn>)
-    (make horizontal ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>)
-    (modify <ff1> ^grid-x (compute <max1> - 1) ^came-from east ^can-chng-layer nil)
-)
-
-(p p128
-    (context ^present << propagate-constraint extend-total-verti >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> north ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <v1> (vertical ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) }
-  - (vertical ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>)
-  -->
-    (modify <v1> ^min (compute <max1> + 1) ^min-net <nn>)
-    (make vertical ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>)
-    (modify <ff1> ^grid-y (compute <max1> + 1) ^came-from south ^can-chng-layer nil)
-)
-
-(p p129
-    (context ^present << propagate-constraint extend-total-verti >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> south ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <v1> (vertical ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo1> ^commo <cmo1>) }
-  - (vertical ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1>)
-  -->
-    (modify <v1> ^max (compute <max1> - 1) ^max-net <nn>)
-    (make vertical ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo1> ^compo <cpo1>)
-    (modify <ff1> ^grid-y (compute <max1> - 1) ^came-from north ^can-chng-layer nil)
-)
-
-(p p130
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <h1> (horizontal ^status nil ^net-name <nn> ^min <min> ^max { <max> > <min> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <gar1>) }
-    { <h2> (horizontal ^status nil ^net-name <nn> ^min <max> ^max { <max2> > <max> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <nn1>) }
-  -->
-    (modify <h1> ^max <max2> ^max-net <nn1>)
-    (remove <h2>)
-)
-
-(p p131
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <v1> (vertical ^status nil ^net-name <nn> ^min <min> ^max { <max> > <min> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <gar1>) }
-    { <v2> (vertical ^status nil ^net-name <nn> ^min <max> ^max { <max2> > <max> } ^com <com> ^layer <lay> ^pin-name <pn> ^max-net <nn1>) }
-  -->
-    (modify <v1> ^max <max2> ^max-net <nn1>)
-    (remove <v2>)
-)
-
-(p p132
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <gar1> ^max <max> ^com <com> ^layer <lay> ^pin-name <pn>) }
-    { <h2> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) }
-    (vertical ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>)
-  -->
-    (modify <h1> ^max <max2>)
-    (remove <h2>)
-)
-
-(p p133
-    (context ^present propagate-constraint)
-    { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <gar1> ^com <com> ^layer <lay> ^pin-name <pn>) }
-    { <h2> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min2> ^max <min> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) }
-    (vertical ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>)
-  -->
-    (modify <h1> ^min <min2>)
-    (remove <h2>)
-)
-
-(p p134
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <gar1> ^max <max> ^com <com> ^layer <lay> ^pin-name <pn>) }
-    { <v2> (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>)
-  -->
-    (modify <v1> ^max <max2>)
-    (remove <v2>)
-)
-
-(p p135
-    (context ^present propagate-constraint)
-    { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <gar1> ^com <com> ^layer <lay> ^pin-name <pn>) }
-    { <v2> (vertical ^status nil ^net-name { <nn> <> nil } ^min <min2> ^max <min> ^com <com> ^layer <lay> ^pin-name { <pn1> <> <pn> }) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^pin-name <pn1>)
-  -->
-    (modify <v1> ^min <min2>)
-    (remove <v2>)
-)
-
-(p p136
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> east ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <h1> (horizontal ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) }
-  - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>)
-  -->
-    (modify <h1> ^min (compute <max1> + 1) ^min-net <nn>)
-    (make horizontal ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>)
-    (modify <ff1> ^grid-x (compute <max1> + 1) ^came-from west ^can-chng-layer nil)
-)
-
-(p p137
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> west ^net-name <nn> ^grid-x <max1> ^grid-y <com1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <h1> (horizontal ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) }
-  - (vertical ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>)
-  -->
-    (modify <h1> ^max (compute <max1> - 1) ^max-net <nn>)
-    (make horizontal ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>)
-    (modify <ff1> ^grid-x (compute <max1> - 1) ^came-from east ^can-chng-layer nil)
-)
-
-(p p138
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> north ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <v1> (vertical ^net-name nil ^min <max1> ^max { <garb1> > <max1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) }
-  - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <max1> ^max <max1> ^com <com1> ^layer <lay>)
-  -->
-    (modify <v1> ^min (compute <max1> + 1) ^min-net <nn>)
-    (make vertical ^min <max1> ^max (compute <max1> + 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>)
-    (modify <ff1> ^grid-y (compute <max1> + 1) ^came-from south ^can-chng-layer nil)
-)
-
-(p p139
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <ff1> (ff ^can-chng-layer no ^came-from <> south ^net-name <nn> ^grid-x <com1> ^grid-y <max1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <v1> (vertical ^net-name nil ^min <garb1> ^max { <max1> > <garb1> } ^com <com1> ^layer <lay> ^compo <cpo> ^commo <cmo>) }
-  - (horizontal ^net-name nil ^min <= <com1> ^max >= <com1> ^com <max1> ^layer <lay>)
-  - (vertical ^net-name nil ^min <max1> ^max > <max1> ^com <com1> ^layer <lay>)
-  -->
-    (modify <v1> ^max (compute <max1> - 1) ^max-net <nn>)
-    (make vertical ^max <max1> ^min (compute <max1> - 1) ^com <com1> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^compo <cpo> ^commo <cmo>)
-    (modify <ff1> ^grid-y (compute <max1> - 1) ^came-from north ^can-chng-layer nil)
-)
-
-(p p140
-    (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com> ^max >= <com> ^com { >= <min> <= <max> } ^pin-name { <pn2> <> <pn1> })
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-  - (included <nn> <pn1>)
-    (included <nn> <pn2>)
-  -->
-    (make included <nn> <pn1>)
-    (modify <t1> ^no-of-attached-pins (compute <nap> + 1))
-)
-
-(p p141
-    (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com> ^max >= <com> ^com { >= <min> <= <max> } ^pin-name { <pn2> <> <pn1> })
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-    (included <nn> <pn1>)
-  - (included <nn> <pn2>)
-  -->
-    (make included <nn> <pn2>)
-    (modify <t1> ^no-of-attached-pins (compute <nap> + 1))
-)
-
-(p p142
-    (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> })
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-    (included <nn> <pn1>)
-  - (included <nn> <pn2>)
-  -->
-    (make included <nn> <pn2>)
-    (modify <t1> ^no-of-attached-pins (compute <nap> + 1))
-)
-
-(p p143
-    (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <egarb4> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> })
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-  - (included <nn> <pn1>)
-    (included <nn> <pn2>)
-  -->
-    (make included <nn> <pn1>)
-    (modify <t1> ^no-of-attached-pins (compute <nap> + 1))
-)
-
-(p p144
-    (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <egarb4> ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> })
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-    (included <nn> <pn1>)
-  - (included <nn> <pn2>)
-  -->
-    (make included <nn> <pn2>)
-    (modify <t1> ^no-of-attached-pins (compute <nap> + 1))
-)
-
-(p p145
-    (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^max <max> ^com <com> ^layer <egarb1> ^compo <egarb2> ^commo <egarb3> ^pin-name <pn1>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^com <com> ^pin-name { <pn2> <> <pn1> })
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-  - (included <nn> <pn1>)
-    (included <nn> <pn2>)
-  -->
-    (make included <nn> <pn1>)
-    (modify <t1> ^no-of-attached-pins (compute <nap> + 1))
-)
-
-(p p146
-    { <c1> (context ^present << propagate-constraint check-for-routed-net find-no-of-pins-on-a-row-col >>) }
-    { <t1> (to-be-routed ^net-name <nn> ^no-of-attached-pins <nap>) }
-    { <n1> (net ^net-name <nn> ^net-no-of-pins <nap>) }
-  -->
-    (remove <c1> <t1>)
-    (make join-routed-net <nn>)
-    (modify <n1> ^net-is-routed yes)
-)
-
-(p p147
-    { <c1> (context ^present check-for-routed-net) }
-  -->
-    (remove <c1>)
-    (make context ^present move-ff)
-)
-
-(p p148
-    { <con> (context ^present move-ff) }
-  -->
-    (modify <con> ^present set-min-max)
-)
-
-(p p149
-    { <con> (context ^present set-min-max) }
-  -->
-    (remove <con>)
-    (make context ^present propagate-constraint)
-)
-
-(p p150
-    (context ^present propagate-constraint)
-    { <c1> (constraint ^pin-name-2 <pn>) }
-  - (ff ^pin-name <pn>)
-  -->
-    (remove <c1>)
-)
-
-(p p151
-    (context ^present propagate-constraint)
-    { <c1> (constraint ^pin-name-1 <pn>) }
-  - (ff ^pin-name <pn>)
-  -->
-    (remove <c1>)
-)
-
-(p p152
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (context ^present << propagate-constraint extend-total-verti move-ff >>)
-    { <ff2> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb2> ^pin-name <> <pn>) }
-  -->
-    (remove <ff1> <ff2>)
-)
-
-(p p153
-    (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) }
-    { <ff2> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2> ^grid-layer <lay> ^pin-name <> <pn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy1>)
-    { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1> <ff2>)
-    (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <v1> ^min <gy2> ^min-net <nn>)
-    (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p154
-    (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <gy2> ^layer <lay> ^compo <egarb1> ^commo <gy1> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2>)
-    { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1>)
-    (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <v1> ^min <gy2> ^min-net <nn>)
-    (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p155
-    (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2> ^grid-layer <lay> ^pin-name <pn>) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <gy1> ^layer <lay> ^compo <gy2> ^commo <egarb1> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1>)
-    { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1>)
-    (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <v1> ^min <gy2> ^min-net <nn>)
-    (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p156
-    (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) }
-    (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> > <gx1> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^pin-name <garb1>)
-    { <ff2> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> <= <max> } ^grid-y <gy> ^grid-layer <lay> ^pin-name <egarb1>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx1>)
-    { <h1> (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1> <ff2>)
-    (make horizontal ^min <min> ^max <gx1> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <h1> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^min <gx1> ^max <gx2> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p157
-    (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) }
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <gx2> ^layer <lay> ^compo <egarb1> ^commo <gx1> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-x <gx2> ^grid-y <gy>)
-    { <h1> (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1>)
-    (make horizontal ^min <min> ^max <gx1> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <h1> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^min <gx1> ^max <gx2> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p158
-    (context ^present << propagate-constraint extend-pins find-no-of-pins-on-a-row-col check-for-routed-net >>)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx2> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) }
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gy> } ^max { <garb2> >= <gy> } ^com <gx1> ^layer <lay> ^compo <gx2> ^commo <egarb1> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy>)
-    { <h1> (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1>)
-    (make horizontal ^min <min> ^max <gx1> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <h1> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^min <gx1> ^max <gx2> ^com <gy> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p159
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) }
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (vertical ^net-name <> nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-  - (horizontal ^net-name <> nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { >= <gy> > <vmin> } ^com <gx> ^layer { <lay2> <> <lay> })
-  -->
-    (modify <ff1> ^grid-layer <lay2> ^can-chng-layer no)
-)
-
-(p p160
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) }
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (vertical ^net-name <> nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-  - (horizontal ^net-name <> nil ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { >= <gx> > <hmin> } ^com <gy> ^layer { <lay2> <> lay> })
-  -->
-    (modify <ff1> ^grid-layer <lay2> ^can-chng-layer no)
-)
-
-(p p161
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) }
-  - (horizontal ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-  - (vertical ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-  -->
-    (modify <ff1> ^can-chng-layer no)
-)
-
-(p p162
-    (context ^present << propagate-constraint move-ff >>)
-    { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) }
-    (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-  -->
-    (modify <ff1> ^can-chng-layer no)
-)
-
-(p p163
-    (context ^present << propagate-constraint move-ff >>)
-    { <ff1> (ff ^can-chng-layer <> no ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay>) }
-    (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-  -->
-    (modify <ff1> ^can-chng-layer no)
-)
-
-(p p164
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^can-chng-layer no ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay1> ^pin-name <pn>) }
-    { <ff2> (ff ^can-chng-layer no ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay2> ^pin-name <garb1>) }
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx2>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy1>)
-    { <h1> (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> >= <gx1> > <hmin> } ^com <gy1> ^layer <lay1> ^compo <hcpo> ^commo <gy2> ^min-net <hnn1>) }
-    { <v1> (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> >= <gy1> > <vmin> } ^com <gx2> ^layer <lay2> ^compo <gx1> ^commo <vcmo> ^min-net <vnn1>) }
-  -->
-    (make horizontal ^min <hmin> ^max <gx2> ^com <gy1> ^commo <gy2> ^compo <hcpo> ^layer <lay1> ^min-net <hnn1> ^max-net <nn>)
-    (modify <h1> ^min <gx1> ^min-net <nn>)
-    (make vertical ^min <vmin> ^max <gy2> ^com <gx2> ^commo <vcmo> ^compo <gx1> ^layer <lay2> ^min-net <vnn1> ^max-net <nn>)
-    (modify <v1> ^min <gy1> ^min-net <nn>)
-    (remove <ff1> <ff2>)
-    (make horizontal ^min <gx2> ^max <gx1> ^com <gy1> ^commo <gy2> ^compo <hcpo> ^layer <lay1> ^net-name <nn> ^pin-name <pn>)
-    (make vertical ^min <gy2> ^max <gy1> ^com <gx2> ^commo <vcmo> ^compo <gx1> ^layer <lay2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p165
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <garb1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <v1> (vertical ^net-name nil ^min <garb2> ^max { <max> > <garb2> } ^com <com> ^layer <lay> ^max-net <> <nn>) }
-  -->
-    (modify <v1> ^max-net <nn>)
-)
-
-(p p166
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <min> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <v1> (vertical ^net-name nil ^min <min> ^max { <garb2> > <min> } ^com <com> ^layer <lay> ^min-net <> <nn>) }
-  -->
-    (modify <v1> ^min-net <nn>)
-)
-
-(p p167
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <max> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <v1> (vertical ^net-name nil ^min { <garb1> < <max> } ^max <max> ^com { >= <hmin> <= <hmax> } ^layer <lay> ^max-net <> <nn>) }
-  -->
-    (modify <v1> ^max-net <nn>)
-)
-
-(p p168
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <min> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <v1> (vertical ^net-name nil ^min <min> ^max { <garb1> > <min> } ^com { >= <hmin> <= <hmax> } ^layer <lay> ^min-net <> <nn>) }
-  -->
-    (modify <v1> ^min-net <nn>)
-)
-
-(p p169
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <garb1> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <h1> (horizontal ^net-name nil ^min <garb2> ^max { <max> > <garb2> } ^com <com> ^layer <lay> ^max-net <> <nn>) }
-  -->
-    (modify <h1> ^max-net <nn>)
-)
-
-(p p170
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <min> ^com <com> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <h1> (horizontal ^net-name nil ^min <min> ^max { <garb2> > <min> } ^com <com> ^layer <lay> ^min-net <> <nn>) }
-  -->
-    (modify <h1> ^min-net <nn>)
-)
-
-(p p171
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <max> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <h1> (horizontal ^net-name nil ^min <garb1> ^max { <max> > <garb1> } ^com { >= <vmin> <= <vmax> } ^layer <lay> ^max-net <> <nn>) }
-  -->
-    (modify <h1> ^max-net <nn>)
-)
-
-(p p172
-    (context ^present << propagate-constraint extend-pins set-min-max >>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <min> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    { <h1> (horizontal ^net-name nil ^min <min> ^max { <garb1> > <min> } ^com { >= <vmin> <= <vmax> } ^layer <lay> ^min-net <> <nn>) }
-  -->
-    (modify <h1> ^min-net <nn>)
-)
-
-(p p173
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^can-chng-layer no ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb1> <= <gx> } ^max { <garb2> >= <gx> } ^com <gy2> ^layer <garb3> ^compo <garb4> ^commo <gy1> ^pin-name <> <pn>)
-  - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com <gy2>)
-  - (vertical ^net-name { <> nil <> <nn> } ^min <= <gy2> ^max >= <gy2> ^com <gx>)
-    { <v1> (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1>) }
-  -->
-    (remove <ff1>)
-    (make vertical ^min <min> ^max <gy1> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (modify <v1> ^min <gy2> ^min-net <nn>)
-    (make vertical ^min <gy1> ^max <gy2> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <lay> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p174
-    (join-routed-net <nn>)
-    { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <com> ^layer <lay> ^compo <garb1> ^commo <garb2>) }
-    { <h2> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>) }
-  -->
-    (modify <h1> ^max <max2>)
-    (remove <h2>)
-)
-
-(p p175
-    (join-routed-net <nn>)
-    { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <max> ^com <com> ^layer <lay> ^compo <garb2> ^commo <garb3>) }
-    { <v2> (vertical ^status nil ^net-name { <nn> <> nil } ^min <max> ^max <max2> ^com <com> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-  -->
-    (modify <v1> ^max <max2>)
-    (remove <v2>)
-)
-
-(p p176
-    { <j1> (join-routed-net <nn>) }
-  -->
-    (remove <j1>)
-    (make move-via <nn>)
-)
-
-(p p177
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <vlayer> ^pin-name <egarb1>)
-    (horizontal ^net-name nil ^min <hmin2> ^max { <gx> > <hmin2> } ^com <vmax> ^layer <vlayer> ^compo <egarb8> ^commo <egarb9>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { < <vmax> > <gy> })
-    { <v1> (vertical ^net-name nil ^min { <garb1> <= <gy> } ^max { <vmax> > <garb1> > <gy> } ^com <gx> ^layer <vlayer> ^commo <cmo> ^compo <cpo> ^max-net <maxn>) }
-    (horizontal ^net-name { <> <nn> <> nil } ^min { <hmin1> <= <gx> } ^max >= <gx> ^com <vmax> ^layer <> <vlayer>)
-    (vertical ^net-name { <> <nn> <> nil } ^min <= <vmax> ^max >= <vmax> ^com { <vcom> < <gx> >= <hmin1> >= <hmin2> } ^layer <vlayer>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com <vmax>)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { < <vmax> > <gy> } ^max-net nil)
-  - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <gx>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmax> ^max > <vmax> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <gx> ^max > <gx> ^com <vmax>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { < <vmax> > <gy> } ^min-net nil)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { < <vmax> > <gy> })
-  - (vertical ^net-name nil ^min < <vmax> ^max > <vmax> ^com { < <gx> > <vcom> })
-  - (vertical ^net-name nil ^min < <vmax> ^max <vmax> ^com { < <gx> > <vcom> } ^max-net nil)
-  - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com { < <gx> > <vcom> } ^min-net nil)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <vmax> ^max >= <vmax> ^com { < <gx> > <vcom> })
-  -->
-    (make vertical ^min (compute <gy> + 1) ^max <vmax> ^com <gx> ^commo <cmo> ^compo <cpo> ^layer <vlayer> ^max-net <maxn>)
-    (modify <v1> ^max <gy> ^max-net <nn>)
-)
-
-(p p178
-    (context ^present propagate-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <layer> ^pin-name <pn>)
-    { <h1> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <gx> > <hmin> } ^com <gy> ^layer <layer> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-    (vertical ^net-name { <> <nn> <> nil } ^min <cpo> ^max { <garb2> >= <cpo> } ^com <vcom> ^layer <layer1> ^compo <vcpo> ^commo <gx>)
-    (horizontal ^net-name { <> <nn> <> nil } ^min { <garb3> <= <vcom> } ^max { <garb4> >= <vcom> } ^com <cpo> ^layer <> <layer1> ^compo <garb5> ^commo <gy>)
-    (vertical ^net-name { <> <nn> <> nil } ^min { <garb6> <= <cmo> } ^max <cmo> ^com <vcom> ^layer <layer2> ^compo <vcpo> ^commo <gx>)
-    (horizontal ^net-name { <> <nn> <> nil } ^min { <garb7> <= <vcom> } ^max { <garb8> >= <vcom> } ^com <cmo> ^layer <> <layer2> ^compo <gy> ^commo <garb9>)
-    (vertical ^net-name { <> <nn> <> nil } ^min { <garb13> <= <gy> } ^max { <garb14> >= <gy> } ^com <vcpo> ^layer <layer3> ^compo <garb10> ^commo <vcom>)
-    (horizontal ^net-name { <> <nn> <> nil } ^min { <garb11> <= <vcpo> } ^max { <garb12> >= <vcpo> } ^com <gy> ^layer <> <layer3> ^compo <cpo> ^commo <cmo>)
-  -->
-    (make horizontal ^min (compute <gx> + 1) ^max <hmax> ^com <gy> ^compo <cpo> ^commo <cmo> ^layer <layer> ^max-net <mn>)
-    (modify <h1> ^max <gx> ^max-net <nn>)
-)
-
-(p p179
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <pn>) }
-    (vertical ^net-name { <> <nn> <> nil } ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy> } ^com <vcom> ^layer <lay2> ^compo <garb1> ^commo <gx>)
-    (vertical ^net-name { <> <nn> <> nil } ^min { <vmax2> > <gy> <= <vmax> } ^max <garb4> ^com <gx> ^layer <lay4>)
-    (vertical ^net-name { <> <nn> <> nil } ^min <garb2> ^max { <vmin2> < <gy> >= <vmin> } ^com <gx> ^layer <lay3>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmin2> < <gy> })
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmin2> < <gy> } ^layer <> <lay2> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmin2> < <gy> } ^max-net nil)
-  - (horizontal ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { > <vmin2> < <gy> })
-    (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <vmin2> ^layer <> <lay3>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmax2> })
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmax2> } ^layer <> <lay2> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmax2> } ^max-net nil)
-  - (horizontal ^net-name <nn> ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmax2> })
-    (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <vmax2> ^layer <> <lay4>)
-    { <h1> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> >= <vcom> > <hmin> } ^com <gy> ^layer { <lay5> <> <lay2> } ^compo <hcpo> ^commo <hcmo> ^max-net <mn>) }
-  -->
-    (make horizontal ^layer <lay5> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <nn> ^max-net <mn> ^min <vcom> ^max <hmax>)
-    (modify <h1> ^max <gx> ^max-net <nn>)
-    (make horizontal ^layer <lay5> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <vcom>)
-    (modify <ff1> ^grid-x <vcom> ^grid-layer <lay5> ^can-chng-layer no)
-)
-
-(p p180
-    (context ^present propagate-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <vmax> ^com <vcom> ^layer <lay1> ^compo <cpo> ^commo <cmo>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <garb2> <= <vcom> } ^max { <garb3> >= <vcom> } ^com <vmax> ^layer { <garb4> <> <lay1> })
-    (vertical ^net-name { <nn1> <> <nn> <> nil } ^min { <vmin> > <vmax> } ^max <garb5> ^com <vcom> ^layer <lay2>)
-    (horizontal ^net-name { <nn1> <> nil } ^min { <garb6> <= <vcom> } ^max { <garb7> >= <vcom> } ^com <vmin> ^layer { <garb8> <> <lay2> })
-    (vertical ^net-name { <> <nn> <> nil } ^min { <vmin2> <= <vmax> } ^max { <vmax2> >= <vmin> } ^com <cpo> ^layer <lay3>)
-    { <v1> (vertical ^net-name nil ^min <vmax> ^max { <vmax3> > <vmax> } ^com <vcom> ^layer <lay3>) }
-  - (vertical ^net-name nil ^min <vmax3> ^com <vcom>)
-  - (horizontal ^net-name nil ^min < <vcom> ^max > <vcom> ^com { > <vmax> <= <vmax3> })
-  - (horizontal ^net-name nil ^min <vcom> ^max > <vcom> ^com { > <vmax> <= <vmax3> } ^layer <> <lay3> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <vcom> ^max <vcom> ^com { > <vmax> <= <vmax3> } ^max-net nil)
-  - (horizontal ^net-name { <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com { > <vmax> <= <vmax3> })
-  -->
-    (modify <v1> ^min (compute <vmax> + 1) ^min-net nil)
-)
-
-(p p181
-    (context ^present propagate-constraint)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <garb1> ^grid-layer <lay> ^pin-name <> <pn>)
-  - (vertical ^com { > <gx> < <gx2> })
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { <egarb1> > <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2>)
-  -->
-    (modify <h1> ^min (compute <gx> + 1) ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^com <gy> ^max (compute <gx> + 1) ^commo <hcmo> ^compo <hcpo> ^layer <lay>)
-    (modify <ff1> ^grid-x (compute <gx> + 1) ^came-from west)
-)
-
-(p p182
-    (context ^present propagate-constraint)
-    { <v3> (vertical ^net-name nil ^min <vmin2> ^max { <vmax2> > <vmin2> } ^com <vcom> ^layer <garb1> ^compo <vcpo> ^commo <egarb1>) }
-    (congestion ^direction row ^coordinate <vmax2> ^como <vmin2>)
-  - (horizontal ^status nil ^min < <vcom> ^max >= <vcom> ^com { <= <vmax2> >= <vmin2> })
-  - (vertical ^status nil ^min <vmax2> ^max > <vmax2> ^com <vcom>)
-  - (vertical ^status nil ^max <vmin2> ^min < <vmin2> ^com <vcom>)
-    (vertical ^net-name nil ^min { <vmin> <= <vmin2> } ^max { > <vmin> >= <vmax2> } ^com <vcpo> ^layer <lay>)
-    (horizontal ^net-name nil ^min <vcom> ^max { <egarb2> > <vcom> } ^com <vmax2> ^layer <lay> ^compo <egarb3> ^commo <egarb4>)
-    (horizontal ^net-name nil ^min <vcom> ^max { <egarb5> > <vcom> } ^com <vmin2> ^layer <lay> ^compo <egarb6> ^commo <egarb7>)
-  -->
-    (remove <v3>)
-)
-
-(p p183
-    (context ^present propagate-constraint)
-    { <v3> (vertical ^net-name nil ^min <vmin2> ^max { <vmax2> > <vmin2> } ^com <vcom> ^layer <garb1> ^compo <garb2> ^commo <vcmo>) }
-    (congestion ^direction row ^coordinate <vmax2> ^como <vmin2>)
-  - (horizontal ^status nil ^min <= <vcom> ^max > <vcom> ^com { <= <vmax2> >= <vmin2> })
-  - (vertical ^status nil ^min <vmax2> ^max > <vmax2> ^com <vcom>)
-  - (vertical ^status nil ^max <vmin2> ^min < <vmin2> ^com <vcom>)
-    (vertical ^net-name nil ^min { <vmin> <= <vmin2> } ^max { > <vmin> >= <vmax2> } ^com <vcmo> ^layer <lay>)
-    (horizontal ^net-name nil ^min <egarb1> ^max { <vcom> > <egarb1> } ^com <vmax2> ^layer <lay> ^compo <egarb2> ^commo <egarb3>)
-    (horizontal ^net-name nil ^min <egarb6> ^max { <vcom> > <egarb6> } ^com <vmin2> ^layer <lay> ^compo <egarb4> ^commo <egarb5>)
-  -->
-    (remove <v3>)
-)
-
-(p p184
-    (context ^present propagate-constraint)
-    { <h3> (horizontal ^net-name nil ^min <hmin2> ^max { <hmax2> > <hmin2> } ^com <hcom> ^layer <garb1> ^compo <hcpo> ^commo <egarb1>) }
-    (congestion ^direction col ^coordinate <hmax2> ^como <hmin2>)
-  - (vertical ^status nil ^min < <hcom> ^max >= <hcom> ^com { <= <hmax2> >= <hmin2> })
-  - (horizontal ^status nil ^min <hmax2> ^max > <hmax2> ^com <hcom>)
-  - (horizontal ^status nil ^max <hmin2> ^min < <hmin2> ^com <hcom>)
-    (horizontal ^net-name nil ^min { <hmin> <= <hmin2> } ^max { > <hmin> >= <hmax2> } ^com <hcpo> ^layer <lay>)
-    (vertical ^net-name nil ^min <hcom> ^max { <egarb2> > <hcom> } ^com <hmax2> ^layer <lay> ^compo <egarb3> ^commo <egarb4>)
-    (vertical ^net-name nil ^min <hcom> ^max { <egarb5> > <hcom> } ^com <hmin2> ^layer <lay> ^compo <egarb6> ^commo <egarb7>)
-  -->
-    (remove <h3>)
-)
-
-(p p185
-    (context ^present propagate-constraint)
-    { <h3> (horizontal ^net-name nil ^min <hmin2> ^max { <hmax2> > <hmin2> } ^com <hcom> ^layer <garb1> ^compo <garb2> ^commo <hcmo>) }
-    (congestion ^direction col ^coordinate <hmax2> ^como <hmin2>)
-  - (vertical ^status nil ^min <= <hcom> ^max > <hcom> ^com { <= <hmax2> >= <hmin2> })
-  - (horizontal ^status nil ^min <hmax2> ^max > <hmax2> ^com <hcom>)
-  - (horizontal ^status nil ^max <hmin2> ^min < <hmin2> ^com <hcom>)
-    (horizontal ^net-name nil ^min { <hmin> <= <hmin2> } ^max { > <hmin> >= <hmax2> } ^com <hcmo> ^layer <lay>)
-    (vertical ^net-name nil ^min <egarb1> ^max { <hcom> > <egarb1> } ^com <hmax2> ^layer <lay> ^compo <egarb3> ^compo <egarb4>)
-    (vertical ^net-name nil ^min <egarb5> ^max { <hcom> > <egarb5> } ^com <hmin2> ^layer <lay> ^compo <egarb6> ^commo <egarb7>)
-  -->
-    (remove <h3>)
-)
-
-(p p538
-    (finally-routed <nn>)
-    { <i1> (included <nn>) }
-  -->
-    (remove <i1>)
-)
-
-(p p539
-    (finally-routed <nn>)
-    { <ff1> (ff ^net-name <nn>) }
-  -->
-    (remove <ff1>)
-)
-
-(p p540
-    (finally-routed <nn>)
-    { <c1> (constraint ^constraint-type << vertical horizontal >> ^net-name-1 <nn>) }
-  -->
-    (remove <c1>)
-)
-
-(p p541
-    (finally-routed <nn>)
-    { <c1> (constraint ^constraint-type << vertical horizontal >> ^net-name-2 <nn>) }
-  -->
-    (remove <c1>)
-)
-
-(p p542
-    (finally-routed <nn>)
-    { <c> (<< horizontal-cycle vertical-cycle >> <nn>) }
-  -->
-    (remove <c>)
-)
-
-(p p543
-    (finally-routed <nn>)
-    { <c1> (constraint ^constraint-type << vertical horizontal >> ^net-name-2 <nn>) }
-  -->
-    (remove <c1>)
-)
-
-(p p544
-    (finally-routed <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <garb1> ^commo <garb2>)
-    { <h1> (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { <hmax> > <hmin> >= <vcom> } ^com { <hcom> >= <vmin> <= <vmax> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <nn1>) }
-  -->
-    (make horizontal ^min <hmin> ^max (compute <vcom> - 1) ^com <hcom> ^compo <hcpo> ^commo <hcmo> ^layer <lay> ^min-net <nn1>)
-    (modify <h1> ^min (compute <vcom> + 1) ^min-net nil)
-)
-
-(p p545
-    (finally-routed <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <garb1> ^commo <garb2>)
-    { <v1> (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { <vmax> > <vmin> >= <hcom> } ^com { <vcom> >= <hmin> <= <hmax> } ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <nn1>) }
-  -->
-    (make vertical ^min <vmin> ^max (compute <hcom> - 1) ^com <vcom> ^compo <vcpo> ^commo <vcmo> ^layer <lay> ^min-net <nn1>)
-    (modify <v1> ^min (compute <hcom> + 1) ^min-net nil)
-)
-
-(p p546
-    (finally-routed <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <rmax> ^com <com> ^layer <lay> ^compo <garb4> ^commo <garb3>)
-    { <v1> (vertical ^net-name nil ^min <rmax> ^max { <garb2> > <rmax> } ^com <com> ^layer <lay> ^compo <garb6> ^commo <garb5>) }
-  -->
-    (modify <v1> ^min (compute <rmax> + 1) ^min-net nil)
-)
-
-(p p547
-    (finally-routed <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <rmin> ^max <garb1> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>)
-    { <v1> (vertical ^net-name nil ^min <garb2> ^max { <rmin> > <garb2> } ^com <com> ^layer <lay> ^compo <garb5> ^commo <garb6>) }
-  -->
-    (modify <v1> ^max (compute <rmin> - 1) ^max-net nil)
-)
-
-(p p548
-    (finally-routed <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max <rmax> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>)
-    { <h1> (horizontal ^net-name nil ^min <rmax> ^max { <garb2> > <rmax> } ^com <com> ^layer <lay> ^compo <garb5> ^commo <garb6>) }
-  -->
-    (modify <h1> ^min (compute <rmax> + 1) ^min-net nil)
-)
-
-(p p549
-    (finally-routed <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <rmin> ^max <garb1> ^com <com> ^layer <lay> ^compo <garb3> ^commo <garb4>)
-    { <h1> (horizontal ^net-name nil ^min <garb2> ^max { <rmin> > <garb2> } ^com <com> ^layer <lay> ^compo <garb5> ^commo <garb6>) }
-  -->
-    (modify <h1> ^max (compute <rmin> - 1) ^max-net nil)
-)
-
-(p p550
-    { <f1> (finally-routed <nn>) }
-  -->
-    (remove <f1>)
-    (make context ^present remove-routed-net-segments <nn>)
-)
-
-(p p551
-    (context ^present remove-routed-net-segments <nn>)
-    { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <c> ^layer <lay> ^compo <garb1> ^commo <garb2>) }
-  -->
-    (modify <h1> ^status routed)
-    (write (crlf) |hor | <nn> <min> <max> <c> <lay>)
-)
-
-(p p552
-    (context ^present remove-routed-net-segments <nn>)
-    { <v1> (vertical ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <c> ^layer <lay> ^compo <garb1> ^commo <garb2>) }
-  -->
-    (modify <v1> ^status routed)
-    (write (crlf) |ver | <nn> <min> <max> <c> <lay>)
-)
-
-(p p553
-    (context ^present remove-routed-net-segments <nn>)
-    { <h> (horizontal-s ^net-name <nn>) }
-  -->
-    (remove <h>)
-)
-
-(p p554
-    (context ^present remove-routed-net-segments <nn>)
-    { <v> (vertical-s ^net-name <nn>) }
-  -->
-    (remove <v>)
-)
-
-(p p555
-    (context ^present remove-routed-net-segments <nn>)
-    { <p> (pin ^net-name <nn>) }
-  -->
-    (remove <p>)
-)
-
-(p p556
-    (context ^present remove-routed-net-segments <nn>)
-    { <n> (net ^net-name <nn>) }
-  -->
-    (remove <n>)
-)
-
-(p p557
-    { <c1> (context ^present remove-routed-net-segments) }
-  -->
-    (remove <c1>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p32
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-    { <v> (vertical ^net-name nil ^min <gy2> ^max > <gy2> ^com <gx2> ^layer <lay> ^commo <cmo> ^compo <gx1> ^min-net <garb2>) }
-  - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com <gy2> ^layer <lay>)
-    (congestion ^direction row ^coordinate <gy3> ^como <gy2>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx2> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy3> ^layer <lay>)
-  -->
-    (modify <v> ^min <gy3> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn2> ^min <gy2> ^max <gy3> ^com <gx2> ^compo <gx1> ^commo <cmo> ^layer <lay>)
-    (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from south)
-)
-
-(p p33
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-    { <v> (vertical ^net-name nil ^min < <gy1> ^max <gy1> ^com <gx1> ^layer <lay> ^commo <gx2> ^compo <cpo> ^min-net <garb2>) }
-  - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com <gy1> ^layer <lay>)
-    (congestion ^direction row ^coordinate <gy1> ^como <gy3>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx1> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy3> ^layer <lay>)
-  -->
-    (modify <v> ^max <gy3> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn1> ^min <gy3> ^max <gy1> ^com <gx1> ^compo <cpo> ^commo <gx2> ^layer <lay>)
-    (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from north)
-)
-
-(p p34
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-    { <v> (vertical ^net-name nil ^min <gy2> ^max > <gy2> ^com <gx2> ^layer <lay> ^commo <gx1> ^compo <cpo> ^min-net <garb2>) }
-  - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com <gy2> ^layer <lay>)
-    (congestion ^direction row ^coordinate <gy3> ^como <gy2>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx2> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy3> ^layer <lay>)
-  -->
-    (modify <v> ^min <gy3> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn2> ^min <gy2> ^max <gy3> ^com <gx2> ^compo <cpo> ^commo <gx1> ^layer <lay>)
-    (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from south)
-)
-
-(p p35
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-top-pins 1 ^no-of-bottom-pins 1)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-    { <v> (vertical ^net-name nil ^min < <gy1> ^max <gy1> ^com <gx1> ^layer <lay> ^commo <cmo> ^compo <gx2> ^min-net <garb2>) }
-  - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com <gy1> ^layer <lay>)
-    (congestion ^direction row ^coordinate <gy1> ^como <gy3>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy3> ^max >= <gy3> ^com <gx1> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy3> ^layer <lay>)
-  -->
-    (modify <v> ^max <gy3> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn1> ^min <gy3> ^max <gy1> ^com <gx1> ^compo <gx2> ^commo <cmo> ^layer <lay>)
-    (modify <ff> ^grid-y <gy3> ^can-chng-layer nil ^came-from north)
-)
-
-(p p36
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-    { <v> (horizontal ^net-name nil ^min <gx2> ^max > <gx2> ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gy1> ^min-net <garb2>) }
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx2> ^layer <lay>)
-    (congestion ^direction col ^coordinate <gx3> ^como <gx2>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy2> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx3> ^layer <lay>)
-  -->
-    (modify <v> ^min <gx3> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn2> ^min <gx2> ^max <gx3> ^com <gy2> ^compo <gy1> ^commo <cmo> ^layer <lay>)
-    (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from west)
-)
-
-(p p37
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-    { <v> (horizontal ^net-name nil ^min < <gx1> ^max <gx1> ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^min-net <garb2>) }
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx1> ^layer <lay>)
-    (congestion ^direction col ^coordinate <gx1> ^como <gx3>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy1> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx3> ^layer <lay>)
-  -->
-    (modify <v> ^max <gx3> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn1> ^min <gx3> ^max <gx1> ^com <gy1> ^compo <cpo> ^commo <gy2> ^layer <lay>)
-    (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from east)
-)
-
-(p p38
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-    { <v> (horizontal ^net-name nil ^min < <gx2> ^max <gx2> ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gx1> ^min-net <garb2>) }
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx2> ^layer <lay>)
-    (congestion ^direction col ^coordinate <gx2> ^como <gx3>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy2> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx3> ^layer <lay>)
-  -->
-    (modify <v> ^max <gx3> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn2> ^min <gx3> ^max <gx2> ^com <gy2> ^compo <gy1> ^commo <cmo> ^layer <lay>)
-    (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from east)
-)
-
-(p p39
-    (context ^present propagate-constraint)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes ^no-of-right-pins 1 ^no-of-left-pins 1)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-    { <v> (horizontal ^net-name nil ^min <gx1> ^max > <gx1> ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^min-net <garb2>) }
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com <gx1> ^layer <lay>)
-    (congestion ^direction col ^coordinate <gx3> ^como <gx1>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx3> ^max >= <gx3> ^com <gy1> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx3> ^layer <lay>)
-  -->
-    (modify <v> ^min <gx3> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn1> ^min <gx1> ^max <gx3> ^com <gy1> ^compo <cpo> ^commo <gy2> ^layer <lay>)
-    (modify <ff> ^grid-x <gx3> ^can-chng-layer nil ^came-from west)
-)
-
-(p p40
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>)
-    (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^max <hmax2> ^max-net nil)
-)
-
-(p p41
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>)
-    (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^min <hmax2> ^min-net nil)
-)
-
-(p p42
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>)
-    (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>)
-    (last-row <gy>)
-  -->
-    (modify <h1> ^max <hmax2> ^max-net nil)
-)
-
-(p p43
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>)
-    (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>)
-    (last-row <gy>)
-  -->
-    (modify <h1> ^min <hmax2> ^min-net nil)
-)
-
-(p p44
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay> ^commo 0) }
-    (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>)
-    (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^max <hmax2> ^max-net nil)
-)
-
-(p p45
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay> ^commo 0) }
-    (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>)
-    (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^min <hmax2> ^min-net nil)
-)
-
-(p p46
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil)
-    { <h1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>)
-    (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^max <vmax2> ^max-net nil)
-)
-
-(p p47
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>)
-    (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <v1> ^min <vmax2> ^min-net nil)
-)
-
-(p p48
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>)
-    (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>)
-    (last-col <gx>)
-  -->
-    (modify <v1> ^max <vmax2> ^max-net nil)
-)
-
-(p p49
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>)
-    (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>)
-    (last-col <gx>)
-  -->
-    (modify <v1> ^min <vmax2> ^min-net nil)
-)
-
-(p p50
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay> ^commo 0) }
-    (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>)
-    (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <v1> ^max <vmax2> ^max-net nil)
-)
-
-(p p51
-    (context ^present propagate-constraint)
-    (ff ^can-chng-layer <> no ^net-name <nn1> ^grid-x <gx> ^grid-y <gy> ^grid-layer <ttgarb>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay> ^commo 0) }
-    (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>)
-    (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <v1> ^min <vmax2> ^min-net nil)
-)
-
-(p p52
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <gx> ^max <ppgarb> ^com <gy>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>)
-    (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^max <hmax2> ^max-net nil)
-)
-
-(p p53
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gx> ^com <gy>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>)
-    (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^min <hmax2> ^min-net nil)
-)
-
-(p p54
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <gx> ^max <ppgarb> ^com <gy>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>)
-    (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cmo> ^layer <lay>)
-    (last-row <gy>)
-  -->
-    (modify <h1> ^max <hmax2> ^max-net nil)
-)
-
-(p p55
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gx> ^com <gy>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cmo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay>) }
-    (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>)
-    (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cmo> ^layer <lay>)
-    (last-row <gy>)
-  -->
-    (modify <h1> ^min <hmax2> ^min-net nil)
-)
-
-(p p56
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <gx> ^max <ppgarb> ^com <gy>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <hmax1> < <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <gx> ^max >= <hmax1> ^com <cpo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <hmax1> < <gx> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min { < <gx> >= <hmax1> } ^max <gx> ^com <gy> ^layer <lay> ^commo 0) }
-    (vertical ^com <hmin2> ^compo <garb10> ^commo <hmax1>)
-    (vertical ^com <hmax2> ^compo <gx> ^commo <garb11>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin2> ^max >= <hmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^max <hmax2> ^max-net nil)
-)
-
-(p p57
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gx> ^com <gy>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min { <hmin1> > <gx> } ^max <garb1> ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <> <lay>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmin1> ^max >= <gx> ^com <cpo> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <nn1> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <gy> ^max > <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^min-net nil)
-  - (vertical ^net-name nil ^min < <gy> ^max <gy> ^com { > <gx> < <hmin1> } ^layer <> <lay> ^max-net nil)
-    { <h1> (horizontal ^net-name nil ^min <gx> ^max { > <gx> <= <hmin1> } ^com <gy> ^layer <lay> ^commo 0) }
-    (vertical ^com <hmin2> ^compo <hmin1> ^commo <garb10>)
-    (vertical ^com <hmax2> ^compo <garb11> ^commo <gx>)
-    (horizontal ^net-name { <> nil <> <nn1> } ^min <= <hmax2> ^max >= <hmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^min <hmax2> ^min-net nil)
-)
-
-(p p58
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <gy> ^max <ppgarb> ^com <gx>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil)
-    { <h1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>)
-    (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <h1> ^max <vmax2> ^max-net nil)
-)
-
-(p p59
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gy> ^com <gx>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>)
-    (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <v1> ^min <vmax2> ^min-net nil)
-)
-
-(p p60
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <gy> ^max <ppgarb> ^com <gx>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>)
-    (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cmo> ^layer <lay>)
-    (last-col <gx>)
-  -->
-    (modify <v1> ^max <vmax2> ^max-net nil)
-)
-
-(p p61
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gy> ^com <gx>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cmo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay>) }
-    (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>)
-    (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cmo> ^layer <lay>)
-    (last-col <gx>)
-  -->
-    (modify <v1> ^min <vmax2> ^min-net nil)
-)
-
-(p p62
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <gy> ^max <ppgarb> ^com <gx>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <garb1> ^max { <vmax1> < <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <gy> ^max >= <vmax1> ^com <cpo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <vmax1> < <gy> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min { < <gy> >= <vmax1> } ^max <gy> ^com <gx> ^layer <lay> ^commo 0) }
-    (horizontal ^com <vmin2> ^compo <garb10> ^commo <vmax1>)
-    (horizontal ^com <vmax2> ^compo <gy> ^commo <garb11>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin2> ^max >= <vmax2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <v1> ^max <vmax2> ^max-net nil)
-)
-
-(p p63
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <ppgarb> ^max <gy> ^com <gx>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min { <vmin1> > <gy> } ^max <garb1> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <> <lay>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmin1> ^max >= <gy> ^com <cpo> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <nn1> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <gx> ^max > <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^min-net nil)
-  - (horizontal ^net-name nil ^min < <gx> ^max <gx> ^com { > <gy> < <vmin1> } ^layer <> <lay> ^max-net nil)
-    { <v1> (vertical ^net-name nil ^min <gy> ^max { > <gy> <= <vmin1> } ^com <gx> ^layer <lay> ^commo 0) }
-    (horizontal ^com <vmin2> ^compo <vmin1> ^commo <garb10>)
-    (horizontal ^com <vmax2> ^compo <garb11> ^commo <gy>)
-    (vertical ^net-name { <> nil <> <nn1> } ^min <= <vmax2> ^max >= <vmin2> ^com <cpo> ^layer <lay>)
-  -->
-    (modify <v1> ^min <vmax2> ^min-net nil)
-)
-
-(p p64
-    (context ^present propagate-constraint)
-    { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max { <hmax> > <vcom> } ^com <vmax> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    (vertical ^net-name { <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>)
-    (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcpo> ^layer <lay> ^compo <garb2> ^commo <vcom>)
-    (horizontal ^net-name nil ^min < <vcom> ^max > <vcom> ^com <hcmo> ^layer <lay>)
-  - (vertical ^status nil ^min <vmax> ^max > <vmax> ^com <vcom>)
-  - (horizontal ^status nil ^min { <temp> <= <vcom> } ^max { > <temp> >= <vcom> } ^com <vmax> ^layer <> <lay>)
-  -->
-    (modify <v> ^max <hcmo> ^max-net nil)
-    (make (substr <h> 1 inf) ^max <vcmo> ^max-net <nn1>)
-    (modify <h> ^min <vcpo> ^min-net <nn2>)
-)
-
-(p p65
-    (context ^present propagate-constraint)
-    { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max { <hmax> > <vcom> } ^com <vmin> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    (vertical ^net-name { <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>)
-    (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcpo> ^layer <lay> ^compo <garb2> ^commo <vcom>)
-    (horizontal ^net-name nil ^min < <vcom> ^max > <vcom> ^com <hcpo> ^layer <lay>)
-  - (vertical ^status nil ^min < <vmin> ^max <vmin> ^com <vcom>)
-  - (horizontal ^status nil ^min { <temp> <= <vcom> } ^max { > <temp> >= <vcom> } ^com <vmin> ^layer <> <lay>)
-  -->
-    (modify <v> ^min <hcpo> ^min-net nil)
-    (make (substr <h> 1 inf) ^max <vcmo> ^max-net <nn1>)
-    (modify <h> ^min <vcpo> ^min-net <nn2>)
-)
-
-(p p66
-    (context ^present propagate-constraint)
-    { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max { <vmax> > <hcom> } ^com <hmax> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    (horizontal ^net-name { <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>)
-    (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcpo> ^layer <lay> ^compo <garb2> ^commo <hcom>)
-    (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com <vcmo> ^layer <lay>)
-  - (horizontal ^status nil ^min <hmax> ^max > <hmax> ^com <hcom>)
-  - (vertical ^status nil ^min { <temp> <= <hcom> } ^max { > <temp> >= <hcom> } ^com <hmax> ^layer <> <lay>)
-  -->
-    (modify <h> ^max <vcmo> ^max-net nil)
-    (make (substr <v> 1 inf) ^max <hcmo> ^max-net <nn1>)
-    (modify <v> ^min <hcpo> ^min-net <nn2>)
-)
-
-(p p67
-    (context ^present propagate-constraint)
-    { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max { <vmax> > <hcom> } ^com <hmin> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    (horizontal ^net-name { <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>)
-    (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcpo> ^layer <lay> ^compo <garb2> ^commo <hcom>)
-    (vertical ^net-name nil ^min < <hcom> ^max > <hcom> ^com <vcpo> ^layer <lay>)
-  - (horizontal ^status nil ^min < <hmin> ^max <hmin> ^com <hcom>)
-  - (vertical ^status nil ^min { <temp> <= <hcom> } ^max { > <temp> >= <hcom> } ^com <hmin> ^layer <> <lay>)
-  -->
-    (modify <h> ^min <vcpo> ^min-net nil)
-    (make (substr <v> 1 inf) ^max <hcmo> ^max-net <nn1>)
-    (modify <v> ^min <hcpo> ^min-net <nn2>)
-)
-
-(p p68
-    (context ^present propagate-constraint)
-    { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com <vmax> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    (vertical ^net-name { <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>)
-    (horizontal ^net-name nil ^min < <vcom> ^max >= <vcom> ^com <hcmo> ^layer <lay>)
-  - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <vcom> ^max > <vcom> ^com <vmax> ^layer <> <lay>)
-  -->
-    (modify <h> ^max <vcmo> ^max-net <nn1>)
-)
-
-(p p69
-    (context ^present propagate-constraint)
-    { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    { <h> (horizontal ^net-name nil ^min <vcom> ^max { <hmax> > <vcom> } ^com <vmax> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    (vertical ^net-name { <nn1> <> nil } ^min < <vmax> ^max >= <vmax> ^com <vcpo> ^layer <lay> ^compo <garb1> ^commo <vcom>)
-    (horizontal ^net-name nil ^min <= <vcom> ^max > <vcom> ^com <hcmo> ^layer <lay>)
-  - (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <vcom> ^max <vcom> ^com <vmax> ^layer <> <lay>)
-  -->
-    (modify <h> ^min <vcpo> ^min-net <nn1>)
-)
-
-(p p70
-    (context ^present propagate-constraint)
-    { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com <vmin> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    (vertical ^net-name { <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcmo> ^layer <lay> ^compo <vcom> ^commo <garb1>)
-    (horizontal ^net-name nil ^min < <vcom> ^max >= <vcom> ^com <hcpo> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <vmin> ^max <vmin> ^com <vcom> ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <vcom> ^max > <vcom> ^com <vmin> ^layer <> <lay>)
-  -->
-    (modify <h> ^max <vcmo> ^max-net <nn1>)
-)
-
-(p p71
-    (context ^present propagate-constraint)
-    { <v> (vertical ^net-name nil ^min <vmin> ^max <vmax> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    { <h> (horizontal ^net-name nil ^min <vcom> ^max { <hmax> > <vcom> } ^com <vmin> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    (vertical ^net-name { <nn1> <> nil } ^min <= <vmin> ^max > <vmin> ^com <vcpo> ^layer <lay> ^compo <garb1> ^commo <vcom>)
-    (horizontal ^net-name nil ^min <= <vcom> ^max > <vcom> ^com <hcpo> ^layer <lay>)
-  - (vertical ^net-name nil ^min < <vmin> ^max <vmin> ^com <vcom> ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min < <vcom> ^max <vcom> ^com <vmin> ^layer <> <lay>)
-  -->
-    (modify <h> ^min <vcpo> ^min-net <nn1>)
-)
-
-(p p72
-    (context ^present propagate-constraint)
-    { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    { <v> (vertical ^net-name nil ^min <hcom> ^max { <vmax> > <hcom> } ^com <hmax> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    (horizontal ^net-name { <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcpo> ^layer <lay> ^compo <garb1> ^commo <hcom>)
-    (vertical ^net-name nil ^min <= <hcom> ^max > <hcom> ^com <vcmo> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com <hmax> ^layer <> <lay>)
-  -->
-    (modify <v> ^min <hcpo> ^min-net <nn1>)
-)
-
-(p p73
-    (context ^present propagate-constraint)
-    { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max <hcom> ^com <hmax> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    (horizontal ^net-name { <nn1> <> nil } ^min < <hmax> ^max >= <hmax> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>)
-    (vertical ^net-name nil ^min < <hcom> ^max >= <hcom> ^com <vcmo> ^layer <lay>)
-  - (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com <hmax> ^layer <> <lay>)
-  -->
-    (modify <v> ^max <hcmo> ^max-net <nn1>)
-)
-
-(p p74
-    (context ^present propagate-constraint)
-    { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    { <v> (vertical ^net-name nil ^min <hcom> ^max { <vmax> > <hcom> } ^com <hmin> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    (horizontal ^net-name { <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcpo> ^layer <lay> ^compo <garb1> ^commo <hcom>)
-    (vertical ^net-name nil ^min <= <hcom> ^max > <hcom> ^com <vcpo> ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <hmin> ^max <hmin> ^com <hcom> ^layer <> <lay>)
-  - (vertical ^net-name nil ^min < <hcom> ^max <hcom> ^com <hmin> ^layer <> <lay>)
-  -->
-    (modify <v> ^min <hcpo> ^min-net <nn1>)
-)
-
-(p p75
-    (context ^present propagate-constraint)
-    { <h> (horizontal ^net-name nil ^min <hmin> ^max <hmax> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo>) }
-    { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max <hcom> ^com <hmin> ^layer <lay> ^compo <vcpo> ^commo <vcmo>) }
-    (horizontal ^net-name { <nn1> <> nil } ^min <= <hmin> ^max > <hmin> ^com <hcmo> ^layer <lay> ^compo <hcom> ^commo <garb1>)
-    (vertical ^net-name nil ^min < <hcom> ^max >= <hcom> ^com <vcpo> ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <hmin> ^max <hmin> ^com <hcom> ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <hcom> ^max > <hcom> ^com <hmin> ^layer <> <lay>)
-  -->
-    (modify <v> ^max <hcmo> ^max-net <nn1>)
-)
-
-(p p76
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay>)
-    (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <vlay>)
-    (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer { <hlay> <> <vlay> } ^compo <hcpo> ^commo <vmax>)
-  - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmax>)
-    { <v> (vertical ^net-name nil ^min <vmax> ^max > <vmax> ^com <vcom> ^layer <hlay>) }
-  -->
-    (modify <v> ^min <hcom> ^min-net <nn2>)
-)
-
-(p p77
-    (context ^present propagate-constraint)
-    (vertical ^net-name { <nn1> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay>)
-    (vertical ^net-name nil ^min <garb1> ^max { <vmin> > <garb1> } ^com <vcom> ^layer <vlay>)
-    (horizontal ^net-name { <nn2> <> <nn1> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer { <hlay> <> <vlay> } ^compo <vmin> ^commo <hcmo>)
-  - (horizontal ^status nil ^min <= <vcom> ^max >= <vcom> ^com <vmin>)
-    { <v> (vertical ^net-name nil ^min <garb2> ^max { <vmin> > <garb2> } ^com <vcom> ^layer <hlay>) }
-  -->
-    (modify <v> ^max <hcom> ^max-net <nn2>)
-)
-
-(p p78
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay>)
-    (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <hlay>)
-    (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer { <vlay> <> <hlay> } ^compo <vcpo> ^commo <hmax>)
-  - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmax>)
-    { <h> (horizontal ^net-name nil ^min <hmax> ^max > <hmax> ^com <hcom> ^layer <vlay>) }
-  -->
-    (modify <h> ^min <vcom> ^min-net <nn2>)
-)
-
-(p p79
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn1> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay>)
-    (horizontal ^net-name nil ^min <garb1> ^max { <hmin> > <garb1> } ^com <hcom> ^layer <hlay>)
-    (vertical ^net-name { <nn2> <> <nn1> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer { <vlay> <> <hlay> } ^compo <hmin> ^commo <vcmo>)
-  - (vertical ^status nil ^min <= <hcom> ^max >= <hcom> ^com <hmin>)
-    { <h> (horizontal ^net-name nil ^min <garb2> ^max { <hmin> > <garb2> } ^com <hcom> ^layer <vlay>) }
-  -->
-    (modify <h> ^max <vcom> ^max-net <nn2>)
-)
-
-(p p80
-    (context ^present propagate-constraint)
-    (last-col <lc>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> <= 1 } ^max <vmax> ^com <vcom> ^layer <vlay> ^pin-name <pn> ^commo <vcmo>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max { <hmax> >= <lc> } ^com <vmax> ^layer <hlay>)
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com { <hcom> >= <vmin> <= <vmax> } ^layer <lay>) }
-  - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> })
-  - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> })
-  - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>)
-  - (vertical ^net-name <nn> ^min <= <vmax> ^max >= <vmax> ^com { > <vcom> <= <hmax> })
-  - (vertical ^net-name nil ^min <= <vmax> ^max >= <vmax> ^com { > <vcom> <= <hmax> })
-  - (vertical ^net-name nil ^min <= <vmax> ^max >= <vmax> ^com <vcom>)
-  - (vertical ^net-name <nn> ^min <vmax> ^max > <vmax> ^com <vcom>)
-  - (vertical ^net-name nil ^min <= <vmin> ^max >= <vmin> ^com <vcom>)
-  - (vertical ^net-name <nn> ^min < <vmin> ^max <vmin> ^com <vcom>)
-  -->
-    (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <vcmo>)
-    (modify <h> ^max <vcmo> ^max-net <nn>)
-    (make ff ^grid-x <vcmo> ^grid-y <hcom> ^grid-layer <lay> ^net-name <nn> ^pin-name <pn> ^came-from east)
-)
-
-(p p81
-    (context ^present propagate-constraint)
-    (last-row <lr>)
-    (last-col <lc>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max { <vmax> >= <lr> } ^com <vcom> ^layer <vlay> ^pin-name <pn> ^commo <vcmo>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max { <hmax> >= <lc> } ^com <vmin> ^layer <hlay>)
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <vcom> } ^max <vcom> ^com { <hcom> >= <vmin> <= <vmax> } ^layer <lay>) }
-  - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> })
-  - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { > <hcom> <= <vmax> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com { < <hcom> >= <vmin> })
-  - (horizontal ^net-name <nn> ^min < <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>)
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <> <lay>)
-  - (vertical ^net-name <nn> ^min <= <vmin> ^max >= <vmin> ^com { > <vcom> <= <hmax> })
-  - (vertical ^net-name nil ^min <= <vmin> ^max >= <vmin> ^com { > <vcom> <= <hmax> })
-  - (vertical ^net-name nil ^min <= <vmin> ^max >= <vmin> ^com <vcom>)
-  - (vertical ^net-name <nn> ^min < <vmin> ^max <vmin> ^com <vcom>)
-  - (vertical ^net-name nil ^min <= <vmax> ^max >= <vmax> ^com <vcom>)
-  - (vertical ^net-name <nn> ^min <vmax> ^max > <vmax> ^com <vcom>)
-  -->
-    (make (substr <h> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <vcmo>)
-    (modify <h> ^max <vcmo> ^max-net <nn>)
-    (make ff ^grid-x <vcmo> ^grid-y <hcom> ^grid-layer <lay> ^net-name <nn> ^pin-name <pn> ^came-from east)
-)
-
-(p p82
-    (context ^present propagate-constraint)
-    (horizontal ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^pin-name <pn> ^commo <hcmo>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max <vmax1> ^com <hmin> ^layer <vlay1>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max <vmax2> ^com <hmax> ^layer <vlay2>)
-    { <v> (vertical ^net-name nil ^min { <vmin> < <hcom> } ^max <hcom> ^com { <vcom> >= <hmin> <= <hmax> } ^layer <lay>) }
-  - (vertical ^net-name <nn> ^min < <hcom> ^max >= <hcom> ^com { > <vcom> <= <hmax> })
-  - (vertical ^net-name <nn> ^min < <hcom> ^max >= <hcom> ^com { < <vcom> >= <hmin> })
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <hcom> ^com { > <vcom> <= <hmax> })
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <hcom> ^com { < <vcom> >= <hmin> })
-  - (vertical ^net-name <nn> ^min < <hcom> ^max >= <hcom> ^com <vcom> ^layer <> <lay>)
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <> <lay>)
-  - (horizontal ^net-name <nn> ^min <= <hmax> ^max >= <hmax> ^com { > <hcom> <= <vmax2> })
-  - (horizontal ^net-name <nn> ^min <= <hmin> ^max >= <hmin> ^com { > <hcom> <= <vmax1> })
-  - (horizontal ^net-name nil ^min <= <hmax> ^max >= <hmax> ^com { > <hcom> <= <vmax2> })
-  - (horizontal ^net-name nil ^min <= <hmin> ^max >= <hmin> ^com { > <hcom> <= <vmax1> })
-  - (horizontal ^net-name nil ^min <= <hmax> ^max >= <hmax> ^com <hcom>)
-  - (horizontal ^net-name <nn> ^min <hmax> ^max > <hmax> ^com <hcom>)
-  - (horizontal ^net-name nil ^min <= <hmin> ^max >= <hmin> ^com <hcom>)
-  - (horizontal ^net-name <nn> ^min < <hmin> ^max <hmin> ^com <hcom>)
-  -->
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <hcmo>)
-    (modify <v> ^max <hcmo> ^max-net <nn>)
-    (make ff ^grid-x <vcom> ^grid-y <hcmo> ^grid-layer <lay> ^net-name <nn> ^pin-name <pn> ^came-from north)
-)
-
-(p p377
-    (context ^present find-no-of-pins-on-a-row-col)
-    (horizontal ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gy> ^layer <lay> ^compo <egarb1> ^commo <egabr2>)
-    (ff ^net-name <nn> ^grid-x { <fx> >= <min> <= <max> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn1>)
-    (ff ^net-name <nn> ^grid-y <gy> ^pin-name { <pn2> <> <pn1> } ^grid-x { <gx> > <fx> <= <max> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <fx> ^max >= <gx> ^com <gy>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <fx> <= <gx> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <fx> ^max >= <fx> ^com <gy> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-    (net ^net-name <nn> ^net-no-of-pins <np>)
-  - (total ^net-name <nn> ^row-col row ^coor <gy>)
-  -->
-    (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins 1 ^total-pins <np> ^min-xy <fx> ^max-xy <gx> ^last-pin <pn1> ^last-xy <fx>)
-)
-
-(p p378
-    (context ^present find-no-of-pins-on-a-row-col)
-    (horizontal ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gy> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (ff ^net-name <nn> ^grid-x { <fx> >= <min> <= <max> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn1>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx> > <fx> <= <max> } ^pin-name { <pn2> <> <pn1> })
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <fx> ^max >= <gx> ^com <gy>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <fx> <= <gx> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <fx> ^max >= <fx> ^com <gy> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-    (net ^net-name <nn> ^net-no-of-pins <np>)
-  - (total ^net-name <nn> ^row-col row ^coor <gy>)
-  -->
-    (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins 1 ^total-pins <np> ^min-xy <fx> ^max-xy <gx> ^last-pin <pn1> ^last-xy <fx>)
-)
-
-(p p379
-    (context ^present find-no-of-pins-on-a-row-col)
-    (horizontal ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gy> ^layer <lay>)
-    (ff ^net-name <nn> ^grid-x { <fx> >= <min> <= <max> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn1>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx> < <fx> >= <min> } ^pin-name { <pn2> <> <pn1> })
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <fx> ^com <gy>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <fx> >= <gx> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <fx> ^max >= <fx> ^com <gy> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-    (net ^net-name <nn> ^net-no-of-pins <np>)
-  - (total ^net-name <nn> ^row-col row ^coor <gy>)
-  -->
-    (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins 1 ^total-pins <np> ^min-xy <gx> ^max-xy <fx> ^last-pin <pn2> ^last-xy <gx>)
-)
-
-(p p380
-    (context ^present find-no-of-pins-on-a-row-col)
-    (vertical ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gx> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <fy> >= <min> <= <max> } ^grid-layer <garb1> ^pin-name <pn1>)
-    (ff ^net-name <nn> ^grid-x <gx> ^pin-name { <pn2> <> <pn1> } ^grid-y { <gy> > <fy> <= <max> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <fy> ^max >= <gy> ^com <gx>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <fy> <= <gy> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <fy> ^max >= <fy> ^com <gx> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-    (net ^net-name <nn> ^net-no-of-pins <np>)
-  - (total ^net-name <nn> ^row-col col ^coor <gx>)
-  -->
-    (make total ^net-name <nn> ^row-col col ^coor <gx> ^level-pins 1 ^total-pins <np> ^min-xy <fy> ^max-xy <gy> ^last-pin <pn1> ^last-xy <fy>)
-)
-
-(p p381
-    (context ^present find-no-of-pins-on-a-row-col)
-    (vertical ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gx> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <fy> >= <min> <= <max> } ^grid-layer <garb1> ^pin-name <pn1>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy> > <fy> <= <max> } ^pin-name { <pn2> <> <pn1> })
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <fy> ^max >= <gy> ^com <gx>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <fy> <= <gy> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <fy> ^max >= <fy> ^com <gx> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-    (net ^net-name <nn> ^net-no-of-pins <np>)
-  - (total ^net-name <nn> ^row-col col ^coor <gx>)
-  -->
-    (make total ^net-name <nn> ^row-col col ^coor <gx> ^level-pins 1 ^total-pins <np> ^min-xy <fy> ^max-xy <gy> ^last-pin <pn1> ^last-xy <fy>)
-)
-
-(p p382
-    (context ^present find-no-of-pins-on-a-row-col)
-    (vertical ^net-name nil ^min <min> ^max { <max> > <min> } ^com <gx> ^layer <lay> ^compo <egarb1> ^commo <egarb2>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <fy> >= <min> <= <max> } ^grid-layer <garb1> ^pin-name <pn1>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy> < <fy> >= <min> } ^pin-name { <pn2> <> <pn1> })
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^pin-name <> <pn1>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <fy> ^com <gx>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <gy> <= <fy> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <fy> ^max >= <fy> ^com <gx> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-    (net ^net-name <nn> ^net-no-of-pins <np>)
-  - (total ^net-name <nn> ^row-col col ^coor <gx>)
-  -->
-    (make total ^net-name <nn> ^row-col col ^coor <gx> ^level-pins 1 ^total-pins <np> ^min-xy <gy> ^max-xy <fy> ^last-pin <pn2> ^last-xy <gy>)
-)
-
-(p p383
-    (context ^present find-no-of-pins-on-a-row-col)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <gy> ^grid-layer <garb2> ^pin-name <pn>)
-    (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <np> ^no-of-bottom-pins <garb3>)
-  - (ff ^net-name <nn> ^grid-y <= <gy> ^pin-name <> <pn>)
-  - (total ^net-name <nn>)
-  -->
-    (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins <np> ^total-pins <np>)
-)
-
-(p p384
-    (context ^present find-no-of-pins-on-a-row-col)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <gy> ^grid-layer <garb2> ^pin-name <pn>)
-    (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <garb3> ^no-of-bottom-pins <np>)
-  - (ff ^net-name <nn> ^grid-y >= <gy> ^pin-name <> <pn>)
-  - (total ^net-name <nn>)
-  -->
-    (make total ^net-name <nn> ^row-col row ^coor <gy> ^level-pins <np> ^total-pins <np>)
-)
-
-(p p385
-    (context ^present find-no-of-pins-on-a-row-col)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <np> ^no-of-bottom-pins <garb2>)
-  - (total ^net-name <nn>)
-    (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn> ^grid-x { <fx> > <gx> })
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <fx> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <fx> ^com <gy>)
-    { <v1> (vertical ^net-name nil ^min { <min> < <gy> } ^max >= <gy> ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <mn>) }
-  - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>)
-    (congestion ^direction row ^coordinate <gy> ^como <hcmo>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <hcmo> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>)
-    (modify <v1> ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff1> ^grid-y <hcmo> ^can-chng-layer nil)
-    (make total ^net-name <nn> ^row-col row ^coor <hcmo> ^level-pins <np> ^total-pins <np>)
-)
-
-(p p386
-    (context ^present find-no-of-pins-on-a-row-col)
-    { <ff1> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <garb2> ^no-of-bottom-pins <np>)
-  - (total ^net-name <nn>)
-    (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn> ^grid-x { <fx> > <gx> })
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <fx> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <fx> ^com <gy>)
-    { <v1> (vertical ^net-name nil ^min <= <gy> ^max { <max> > <gy> } ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <mn>) }
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>)
-    (congestion ^direction row ^coordinate <hcmo> ^como <gy>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <max> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <nn> ^max-net <mn>)
-    (modify <v1> ^max <gy> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^min <gy> ^max <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify <ff1> ^grid-y <hcmo> ^can-chng-layer nil)
-    (make total ^net-name <nn> ^row-col row ^coor <hcmo> ^level-pins <np> ^total-pins <np>)
-)
-
-(p p387
-    { <t1> (total ^net-name <nn> ^row-col row ^coor <y> ^level-pins <np> ^total-pins <np> ^min-xy nil ^max-xy nil) }
-    (pin ^net-name <nn> ^pin-x <px1>)
-  - (pin ^net-name <nn> ^pin-x < <px1>)
-    (pin ^net-name <nn> ^pin-x { <px2> > <px1> })
-  - (pin ^net-name <nn> ^pin-x > <px2>)
-  -->
-    (modify <t1> ^min-xy <px1> ^max-xy <px2>)
-)
-
-(p p388
-    (context ^present find-no-of-pins-on-a-row-col)
-  -->
-    (make context ^previous find-no-of-pins-on-a-row-col)
-    (remove 1)
-)
-
-(p p389
-    (context ^previous find-no-of-pins-on-a-row-col)
-    (total)
-  -->
-    (remove 1)
-    (make context ^present modify-total)
-)
-
-(p p390
-    (context ^present delete-totals)
-  -->
-    (modify 1 ^present choose-between-nets-on-the-same-row-col)
-)
-
-(p p391
-    { <c1> (context ^present << choose-between-nets-on-the-same-row-col choose-between-nets-on-the-same-row-col-con >>) }
-    { <t1> (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <xy> ^level-pins <cou> ^total-pins <garb1>) }
-  - (total ^net-name <> <nn> ^level-pins >= <cou>)
-  - (total ^net-name <nn> ^row-col <> <rc> ^level-pins >= <cou>)
-  -->
-    (remove <c1> <t1>)
-    (make change-priority)
-    (make tran-total <rc> <xy> (substr <t1> nets inf))
-)
-
-(p p392
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <garb1> ^row-col { << row col >> <garb2> } ^coor <garb3> ^level-pins <cou> ^total-pins <cou>)
-    { <t1> (total ^level-pins < <cou>) }
-  -->
-    (remove <t1>)
-)
-
-(p p393
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <garb1> ^row-col { << row col >> <garb2> } ^coor <garb3> ^level-pins <cou> ^total-pins <garb4>)
-    { <t1> (total ^level-pins <cou1> ^total-pins { < <cou> <> <cou1> }) }
-  -->
-    (remove <t1>)
-)
-
-(p p394
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <garb1> ^level-pins <cou>)
-    { <t1> (total ^net-name <nn> ^row-col <> <rc> ^level-pins <cou>) }
-  -->
-    (remove <t1>)
-)
-
-(p p395
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <xy> ^level-pins <cou> ^total-pins <garb1>)
-    { <t1> (total ^net-name <nn> ^row-col <rc> ^coor <> <xy> ^level-pins <cou>) }
-  -->
-    (remove <t1>)
-)
-
-(p p396
-    { <c1> (context ^present << choose-between-nets-on-the-same-row-col choose-between-nets-on-the-same-row-col-con >>) }
-    { <t1> (total ^net-name <nn> ^row-col { << row col >> <rc> } ^coor <xy> ^level-pins <cou> ^total-pins <cou>) }
-  - (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou>)
-  -->
-    (remove <c1> <t1>)
-    (make change-priority)
-    (make tran-total <rc> <xy> (substr <t1> nets inf))
-)
-
-(p p397
-    { <t1> (tran-total <rc> <xy> { <nn> <> nil <> end } <min> <max>) }
-  -->
-    (write (crlf) |***** next net to be routed is| <nn> *****)
-    (make next-segment <nn> <rc> <xy> useless <min> <max>)
-    (remove <t1>)
-    (make tran-total <rc> <xy> (substr <t1> 7 inf))
-)
-
-(p p398
-    { <t1> (tran-total <rc> <xy> nil) }
-  -->
-    (make dominant-layer)
-    (remove <t1>)
-    (make goal cleanup total-verti)
-    (make goal cleanup counted-verti)
-    (make goal cleanup total)
-    (make goal cleanup extend-ff-tried)
-)
-
-(p p399
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <nn> ^row-col { << row col >> <garb1> } ^coor <garb2> ^level-pins <cou> ^total-pins <cou>)
-    { <t1> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins > <cou>) }
-  -->
-    (remove <t1>)
-)
-
-(p p400
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <nn> ^row-col { << row col >> <garb1> } ^coor <garb2> ^level-pins <cou> ^total-pins <cou1>)
-    { <t1> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins > <cou1>) }
-  - (total ^net-name <garb3> ^row-col <garb4> ^coor <garb5> ^level-pins <cou2> ^total-pins <cou2>)
-  -->
-    (remove <t1>)
-)
-
-(p p401
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <garb1> ^row-col <garb2> ^coor <garb3> ^level-pins <cou1> ^total-pins <cou2>)
-    { <t1> (total ^net-name <garb4> ^row-col <garb5> ^coor <garb6> ^level-pins < <cou1> ^total-pins < <cou2>) }
-  -->
-    (remove <t1>)
-)
-
-(p p402
-    (context ^present choose-between-nets-on-the-same-row-col)
-  -->
-    (modify 1 ^present choose-between-nets-on-the-same-row-col-con)
-)
-
-(p p403
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    { <t1> (total ^net-name <nn> ^row-col row ^level-pins <cou> ^total-pins <cou2> ^cong nil) }
-    (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2>)
-    (pin ^net-name <nn> ^pin-x <px1>)
-  - (pin ^net-name <nn> ^pin-x < <px1>)
-    (pin ^net-name <nn> ^pin-x { <px2> > <px1> })
-  - (pin ^net-name <nn> ^pin-x > <px2>)
-    (congestion ^direction col ^coordinate { >= <px1> <= <px2> } ^no-of-nets <non>)
-  - (congestion ^direction col ^coordinate { >= <px1> <= <px2> } ^no-of-nets > <non>)
-  -->
-    (modify <t1> ^cong <non>)
-)
-
-(p p404
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    { <t1> (total ^net-name <nn> ^row-col col ^level-pins <cou> ^total-pins <cou2> ^cong nil) }
-    (total <> <nn> { } { } <cou> <cou2>)
-    (pin ^net-name <nn> ^pin-y <py1>)
-  - (pin ^net-name <nn> ^pin-y < <py1>)
-    (pin ^net-name <nn> ^pin-y { <py2> > <py1> })
-  - (pin ^net-name <nn> ^pin-y > <py2>)
-    (congestion ^direction row ^coordinate { >= <py1> <= <py2> } ^no-of-nets <non>)
-  - (congestion ^direction row ^coordinate { >= <py1> <= <py2> } ^no-of-nets > <non>)
-  -->
-    (modify <t1> ^cong <non>)
-)
-
-(p p405
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy <min1> ^max-xy <max1>)
-    (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy { <min2> > <max1> } ^max-xy <max2>)
-    { <t> (total ^net-name <nn1> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy <= <max1> ^max-xy >= <min2>) }
-  -->
-    (remove <t>)
-)
-
-(p p406
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy <min1> ^max-xy <max1>)
-    { <t> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil } ^min-xy >= <min1> ^max-xy <= <max1>) }
-  -->
-    (remove <t>)
-)
-
-(p p407
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil })
-    { <t> (total ^net-name { <nn1> <> <nn> } ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) }
-    (<< vertical-cycle horizontal-cycle >> <nn1>)
-  -->
-    (remove <t>)
-)
-
-(p p408
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    (total ^net-name <nn> ^row-col row ^coor <y> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil })
-    { <t> (total ^net-name { <nn1> <> <nn> } ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) }
-    (pin ^net-name <nn1> ^pin-y { <py> < <y> } ^pin-channel-side << left right >>)
-  - (pin ^net-name <nn> ^pin-y { > <py> < <y> } ^pin-channel-side << left right >>)
-  -->
-    (remove <t>)
-)
-
-(p p409
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    (total ^net-name <nn> ^row-col row ^coor <y> ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil })
-    { <t> (total ^net-name { <nn1> <> <nn> } ^level-pins <cou> ^total-pins <cou2> ^cong { <non> <> nil }) }
-    (pin ^net-name <nn1> ^pin-y { <py> > <y> } ^pin-channel-side << left right >>)
-  - (pin ^net-name <nn> ^pin-y { > <y> < <py> } ^pin-channel-side << left right >>)
-  -->
-    (remove <t>)
-)
-
-(p p410
-    (context ^present choose-between-nets-on-the-same-row-col-con)
-    (total ^net-name <nn> ^level-pins <cou> ^total-pins <cou2> ^cong <non>)
-  - (total ^cong nil)
-    { <t> (total ^net-name <> <nn> ^level-pins <cou> ^total-pins <cou2> ^cong <= <non>) }
-  -->
-    (remove <t>)
-)
-
-(p p411
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <nn1> ^row-col <rc1> ^coor <xy1> ^level-pins <cou> ^total-pins > <cou>)
-    { <t1> (total ^net-name <nn2> ^row-col { <rc2> <> <rc1> } ^coor <xy2> ^level-pins <cou> ^total-pins > <cou>) }
-    { <t2> (total ^net-name <> <nn2> ^row-col <rc2> ^coor <xy2> ^level-pins <cou> ^total-pins > <cou>) }
-  -->
-    (remove <t1> <t2>)
-)
-
-(p p412
-    (context ^present choose-between-nets-on-the-same-row-col)
-    (total ^net-name <nn1> ^row-col <rc1> ^coor <xy1> ^level-pins <cou> ^total-pins > <cou>)
-    { <t1> (total ^net-name <nn2> ^row-col <rc2> ^coor { <xy2> <> <xy1> } ^level-pins <cou> ^total-pins > <cou>) }
-    { <t2> (total ^net-name <> <nn2> ^row-col <rc2> ^coor <xy2> ^level-pins <cou> ^total-pins > <cou>) }
-  -->
-    (remove <t1> <t2>)
-)
-
-(p p413
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-bottom-pins { <np> > 1 } ^net-is-routed <> yes)
-  - (total-verti <nn> bottom)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom)
-  -->
-    (make total-verti <nn> bottom 0 <np>)
-)
-
-(p p414
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-bottom-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> bottom)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>)
-  -->
-    (make total-verti <nn> bottom 0 <np>)
-)
-
-(p p415
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-bottom-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> bottom)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>)
-  -->
-    (make total-verti <nn> bottom 0 <np>)
-)
-
-(p p416
-    (context ^present find-no-of-vcg-hcg)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <garb1>)
-    (pin ^net-name <nn> ^pin-x <gx> ^pin-channel-side top ^pin-name <pn1>)
-    (net ^net-name { <nn1> <> <nn> } ^no-of-bottom-pins { <np> > 0 } ^net-is-routed <> yes)
-    (pin ^net-name <nn1> ^pin-x <gx> ^pin-channel-side bottom ^pin-name <pn2>)
-  - (total-verti <nn1> bottom)
-  - (constraint ^constraint-type vertical ^net-name-1 <nn> ^net-name-2 <nn1> ^pin-name-1 <pn1> ^pin-name-2 <pn2>)
-  -->
-    (make counted-verti <nn1> bottom <nn> <pn1> <pn2>)
-    (make total-verti <nn1> bottom 1 <np>)
-)
-
-(p p417
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-left-pins { <np> > 1 } ^net-is-routed <> yes)
-  - (total-verti <nn> left)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side left)
-  -->
-    (make total-verti <nn> left 0 <np>)
-)
-
-(p p418
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-left-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> left)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side left)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>)
-  -->
-    (make total-verti <nn> left 0 <np>)
-)
-
-(p p419
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-left-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> left)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side left)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>)
-  -->
-    (make total-verti <nn> left 0 <np>)
-)
-
-(p p420
-    (context ^present find-no-of-vcg-hcg)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <gy> ^grid-layer <garb3> ^pin-name <garb2>)
-    (pin ^net-name <nn> ^pin-y <gy> ^pin-channel-side right ^pin-name <pn1>)
-    (net ^net-name { <nn1> <> <nn> } ^no-of-left-pins { <np> > 0 } ^net-is-routed <> yes)
-    (pin ^net-name <nn1> ^pin-y <gy> ^pin-channel-side left ^pin-name <pn2>)
-  - (total-verti <nn1> left)
-  - (constraint ^constraint-type horizontal ^net-name-1 <nn> ^net-name-2 <nn1> ^pin-name-1 <pn1> ^pin-name-2 <pn2>)
-  -->
-    (make counted-verti <nn1> left <nn> <pn1> <pn2>)
-    (make total-verti <nn1> left 1 <np>)
-)
-
-(p p421
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-top-pins { <np> > 1 } ^net-is-routed <> yes)
-  - (total-verti <nn> top)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top)
-  -->
-    (make total-verti <nn> top 0 <np>)
-)
-
-(p p422
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-top-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> top)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>)
-  -->
-    (make total-verti <nn> top 0 <np>)
-)
-
-(p p423
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-top-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> top)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>)
-  -->
-    (make total-verti <nn> top 0 <np>)
-)
-
-(p p424
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-right-pins { <np> > 1 } ^net-is-routed <> yes)
-  - (total-verti <nn> right)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side right)
-  -->
-    (make total-verti <nn> right 0 <np>)
-)
-
-(p p425
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-right-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> right)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side right)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-1 <nn>)
-  -->
-    (make total-verti <nn> right 0 <np>)
-)
-
-(p p426
-    (context ^present find-no-of-vcg-hcg)
-    (net ^net-name <nn> ^no-of-right-pins { <np> > 0 } ^net-is-routed <> yes)
-  - (total-verti <nn> right)
-    (ff ^net-name <nn> ^grid-x <garb1> ^grid-y <garb2> ^grid-layer <garb3> ^pin-name <pn>)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side right)
-    (constraint ^constraint-type << horizontal vertical >> ^net-name-2 <nn>)
-  -->
-    (make total-verti <nn> right 0 <np>)
-)
-
-(p p427
-    (context ^present find-no-of-vcg-hcg)
-    (total-verti <nn> bottom <ntc>)
-    (constraint ^constraint-type vertical ^net-name-1 <tn> ^net-name-2 <nn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  - (counted-verti <nn> bottom <tn> <tpn> <bpn>)
-  -->
-    (make counted-verti <nn> bottom <tn> <tpn> <bpn>)
-    (modify 2 ^4 (compute <ntc> + 1))
-)
-
-(p p428
-    (context ^present find-no-of-vcg-hcg)
-    (total-verti <nn> left <ntc>)
-    (constraint ^constraint-type horizontal ^net-name-1 <tn> ^net-name-2 <nn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  - (counted-verti <nn> left <tn> <tpn> <bpn>)
-  -->
-    (make counted-verti <nn> left <tn> <tpn> <bpn>)
-    (modify 2 ^4 (compute <ntc> + 1))
-)
-
-(p p429
-    (context ^present find-no-of-vcg-hcg)
-    (total-verti <nn> top <ntc>)
-    (constraint ^constraint-type vertical ^net-name-1 <nn> ^net-name-2 <bn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  - (counted-verti <nn> top <bn> <tpn> <bpn>)
-  -->
-    (make counted-verti <nn> top <bn> <tpn> <bpn>)
-    (modify 2 ^4 (compute <ntc> + 1))
-)
-
-(p p430
-    (context ^present find-no-of-vcg-hcg)
-    (total-verti <nn> right <ntc>)
-    (constraint ^constraint-type horizontal ^net-name-1 <nn> ^net-name-2 <bn> ^pin-name-1 <tpn> ^pin-name-2 <bpn>)
-  - (counted-verti <nn> right <bn> <tpn> <bpn>)
-  -->
-    (make counted-verti <nn> right <bn> <tpn> <bpn>)
-    (modify 2 ^4 (compute <ntc> + 1))
-)
-
-(p p431
-    (context ^present find-no-of-vcg-hcg)
-  -->
-    (remove 1)
-    (make context ^previous find-no-of-vcg-hcg)
-)
-
-(p p432
-    (context ^previous find-no-of-vcg-hcg)
-    (total-verti)
-  -->
-    (remove 1)
-    (make context ^present choose-between-total-verti)
-    (make context ^present choose-between-total-verti-0)
-)
-
-(p p433
-    (context ^present choose-between-total-verti)
-  - (total-verti ^4 0)
-    { <t> (total-verti <nn> bottom <garb> > 1) }
-  - (ff ^net-name <nn> ^came-from south)
-  -->
-    (remove <t>)
-)
-
-(p p434
-    (context ^present choose-between-total-verti)
-  - (total-verti ^4 0)
-    { <t> (total-verti <nn> top <garb> > 1) }
-  - (ff ^net-name <nn> ^came-from north)
-  -->
-    (remove <t>)
-)
-
-(p p435
-    (context ^present choose-between-total-verti)
-  - (total-verti ^4 0)
-    { <t> (total-verti <nn> left <garb> > 1) }
-  - (ff ^net-name <nn> ^came-from west)
-  -->
-    (remove <t>)
-)
-
-(p p436
-    (context ^present choose-between-total-verti)
-  - (total-verti ^4 0)
-    { <t> (total-verti <nn> right <garb> > 1) }
-  - (ff ^net-name <nn> ^came-from east)
-  -->
-    (remove <t>)
-)
-
-(p p437
-    (context ^present choose-between-total-verti)
-  -->
-    (modify 1 ^present extend-total-verti)
-)
-
-(p p438
-    (context ^present choose-between-total-verti)
-    (total-verti ^4 > 0)
-    (total-verti ^4 0)
-  -->
-    (remove 3)
-)
-
-(p p439
-    (context ^present choose-between-total-verti)
-    (total-verti <nn> { << top bottom >> <tb> } > 0)
-    (total-verti <nn> { << top bottom >> <> <tb> } 0)
-  -->
-    (remove 3)
-)
-
-(p p440
-    (context ^present choose-between-total-verti)
-    (total-verti <nn> { << left right >> <tb> } > 0)
-    (total-verti <nn> { << left right >> <> <tb> } 0)
-  -->
-    (remove 3)
-)
-
-(p p441
-    (context ^present choose-between-total-verti-0)
-    (total-verti <nn> { << top bottom >> <tb> } > 0)
-    (total-verti <nn> { << top bottom >> <> <tb> } > 0)
-  -->
-    (remove 2 3)
-)
-
-(p p442
-    (context ^present choose-between-total-verti-0)
-    (total-verti <nn> { << left right >> <tb> } > 0)
-    (total-verti <nn> { << left right >> <> <tb> } > 0)
-  -->
-    (remove 2 3)
-)
-
-(p p443
-    (context ^present choose-between-total-verti-0)
-  -->
-    (remove 1)
-)
-
-(p p444
-    (context ^present extend-total-verti)
-    (total-verti <nn> bottom ^5 > 1)
-  - (total-verti ^5 1)
-    (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy> ^com <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy> } ^max { > <min> > <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-    (congestion ^direction row ^coordinate <como> ^como <gy>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <como> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^min <min> ^max <gy> ^min-net <mn> ^max-net <nn> ^commo <vcmo> ^compo <vcpo> ^com <gx> ^layer <lay>)
-    (modify 4 ^min <como> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^min <gy> ^max <como> ^layer <lay> ^commo <vcmo> ^compo <vcpo> ^pin-name <pn> ^com <gx>)
-    (modify 3 ^grid-y <como> ^can-chng-layer nil)
-    (remove 2)
-)
-
-(p p445
-    (context ^present extend-total-verti)
-    (total-verti <nn> left ^5 > 1)
-  - (total-verti ^5 1)
-    (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^grid-x < <gx>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx> ^com <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { > <min> > <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-    (congestion ^direction col ^coordinate <como> ^como <gx>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gy> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <como> ^layer <lay>)
-  -->
-    (make horizontal ^net-name nil ^min <min> ^max <gx> ^min-net <mn> ^max-net <nn> ^commo <hcmo> ^compo <hcpo> ^com <gy> ^layer <lay>)
-    (modify 4 ^min <como> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^min <gx> ^max <como> ^layer <lay> ^commo <hcmo> ^compo <hcpo> ^pin-name <pn> ^com <gy>)
-    (modify 3 ^grid-x <como> ^can-chng-layer nil)
-    (remove 2)
-)
-
-(p p446
-    (context ^present extend-total-verti)
-    (total-verti <nn> top ^5 > 1)
-  - (total-verti ^5 1)
-    (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy> ^com <gx>)
-    (vertical ^net-name nil ^max { <max> >= <gy> } ^min { < <max> < <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^max-net <mn>)
-    (congestion ^direction row ^coordinate <gy> ^como <como>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <como> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^min <gy> ^max <max> ^max-net <mn> ^min-net <nn> ^commo <vcmo> ^compo <vcpo> ^com <gx> ^layer <lay>)
-    (modify 4 ^max <como> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <como> ^layer <lay> ^commo <vcmo> ^compo <vcpo> ^pin-name <pn> ^com <gx>)
-    (modify 3 ^grid-y <como> ^can-chng-layer nil)
-    (remove 2)
-)
-
-(p p447
-    (context ^present extend-total-verti)
-    (total-verti <nn> right ^5 > 1)
-  - (total-verti ^5 1)
-    (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^grid-x > <gx>)
-  - (horizontal ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx> ^status nil ^com <gy>)
-    (horizontal ^net-name nil ^max { <max> >= <gx> } ^min { < <max> < <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^max-net <mn>)
-    (congestion ^direction col ^coordinate <gx> ^como <como>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <como> ^max >= <como> ^com <gy> ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <como> ^layer <lay>)
-  -->
-    (make horizontal ^net-name nil ^min <gx> ^max <max> ^max-net <mn> ^min-net <nn> ^commo <hcmo> ^compo <hcpo> ^com <gy> ^layer <lay>)
-    (modify 4 ^max <como> ^max-net <nn>)
-    (make horizontal ^net-name <nn> ^max <gx> ^min <como> ^layer <lay> ^commo <hcmo> ^compo <hcpo> ^pin-name <pn> ^com <gy>)
-    (modify 3 ^grid-x <como> ^can-chng-layer nil)
-    (remove 2)
-)
-
-(p p448
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> bottom ^5 1) }
-    (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-  - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin>)
-    { <c6> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay> ^compo <garb1> ^commo <garb2>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> >= <vvmin> < <vmin> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { >= <vvmin> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c6> ^max <hcom> ^max-net <nn>)
-    (modify <c4> ^min <hcom>)
-    (make pull-ff north <nn> <gx> <gy> <gx> <hcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from north)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p449
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> bottom ^5 1) }
-    (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin> ^grid-layer <garb1> ^pin-name <garb2>) }
-    { <c7> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay> ^compo <garb3> ^commo <garb4>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> >= <vvmin> < <vmin> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { >= <vvmin> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c7> ^max <hcom> ^max-net <nn>)
-    (modify <c4> ^min <hcom>)
-    (make pull-ff north <nn> <gx> <gy> <gx> <hcom>)
-    (modify <c5> ^grid-y <hcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p450
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> bottom ^5 1) }
-    (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-    { <c6> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay> ^compo <garb1> ^commo <garb2>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> >= <vvmin> < <vmin> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { >= <vvmin> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> })
-    { <c41> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin1> > <gy> } ^com { <vcom1> > <gx> } ^layer <lay> ^pin-name <pn1>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom1>)
-    { <c61> (vertical ^net-name nil ^min <vvmin1> ^max { <vmin1> > <vvmin1> } ^com <vcom1> ^layer <lay>) }
-    (horizontal ^net-name nil ^min { <hmin1> <= <gx> } ^max { > <hmin1> >= <vcom1> } ^com { <hcom1> >= <vvmin1> < <vmin1> <= <hcom> })
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom1> ^com { >= <vvmin1> < <hcom1> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom1> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin1> > <hcom1> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom1> ^max >= <vcom1> ^com <hcom1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom1> ^max >= <hcom1> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c61> ^max <hcom1> ^max-net <nn>)
-    (modify <c41> ^min <hcom1>)
-    (make pull-ff north <nn> <gx> <gy> <gx> <hcom1>)
-    (make ff ^net-name <nn> ^pin-name <pn1> ^grid-layer <lay> ^grid-x <vcom1> ^grid-y <hcom1> ^came-from north)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p451
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> bottom ^5 1) }
-    (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-  - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin>)
-    { <c6> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> >= <vvmin> < <vmin> })
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { >= <vvmin> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c6> ^max <hcom> ^max-net <nn>)
-    (modify <c4> ^min <hcom>)
-    (make pull-ff north <nn> <gx> <gy> <gx> <hcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from north)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p452
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> bottom ^5 1) }
-    (ff ^came-from south ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min { <vmin> > <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmin> ^grid-layer <garb1> ^pin-name <garb2>) }
-    { <c7> (vertical ^net-name nil ^min <vvmin> ^max { <vmin> > <vvmin> } ^com <vcom> ^layer <lay>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> >= <vvmin> < <vmin> })
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { >= <vvmin> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <vmin> > <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c7> ^max <hcom> ^max-net <nn>)
-    (modify <c4> ^min <hcom>)
-    (make pull-ff north <nn> <gx> <gy> <gx> <hcom>)
-    (modify <c5> ^grid-y <hcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p453
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> top ^5 1) }
-    (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-  - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax>)
-    { <c6> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> <= <vvmax> > <vmax> })
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { <= <vvmax> > <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c6> ^min <hcom> ^min-net <nn>)
-    (modify <c4> ^max <hcom>)
-    (make pull-ff south <nn> <gx> <gy> <gx> <hcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from south)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p454
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> top ^5 1) }
-    (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> > <gx> } ^layer <lay> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax> ^grid-layer <garb2> ^pin-name <garb3>) }
-    { <c7> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom> } ^com { <hcom> <= <vvmax> > <vmax> })
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com { <= <vvmax> > <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <gx> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c7> ^min <hcom> ^min-net <nn>)
-    (modify <c4> ^max <hcom>)
-    (make pull-ff south <nn> <gx> <gy> <gx> <hcom>)
-    (modify <c5> ^grid-y <hcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p455
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> top ^5 1) }
-    (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-  - (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax>)
-    { <c6> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> <= <vvmax> > <vmax> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { <= <vvmax> > <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c6> ^min <hcom> ^min-net <nn>)
-    (modify <c4> ^max <hcom>)
-    (make pull-ff south <nn> <gx> <gy> <gx> <hcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from south)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p456
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> top ^5 1) }
-    (ff ^came-from north ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <vmax> < <gy> } ^com { <vcom> < <gx> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (vertical-s ^net-name <> <nn> ^com <vcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <vcom> ^grid-y <vmax> ^grid-layer <garb4> ^pin-name <garb5>) }
-    { <c7> (vertical ^net-name nil ^min <vmax> ^max { <vvmax> > <vmax> } ^com <vcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) }
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom> } ^max { > <hmin> >= <gx> } ^com { <hcom> <= <vvmax> > <vmax> })
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com { <= <vvmax> > <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <vcom> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <vmax> < <hcom> })
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  -->
-    (modify <c7> ^min <hcom> ^min-net <nn>)
-    (modify <c4> ^max <hcom>)
-    (make pull-ff south <nn> <gx> <gy> <gx> <hcom>)
-    (modify <c5> ^grid-y <hcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p457
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> left ^5 1) }
-    (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-  - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom>)
-    { <c6> (horizontal ^net-name nil ^min <hhmin> ^max { <hmin> > <hhmin> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-    (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> >= <hhmin> < <hmin> })
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { >= <hhmin> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c6> ^max <vcom> ^max-net <nn>)
-    (modify <c4> ^min <vcom>)
-    (make pull-ff east <nn> <gx> <gy> <gy> <vcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from east)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p458
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> left ^5 1) }
-    (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) }
-    { <c7> (horizontal ^net-name nil ^min <hhmin> ^max { <hmin> > <hhmin> } ^com <hcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) }
-    (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> >= <hhmin> < <hmin> })
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { >= <hhmin> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c7> ^max <vcom> ^max-net <nn>)
-    (modify <c4> ^min <vcom>)
-    (make pull-ff east <nn> <gx> <gy> <gy> <vcom>)
-    (modify <c5> ^grid-x <vcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p459
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> left ^5 1) }
-    (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-  - (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom>)
-    { <c6> (horizontal ^net-name nil ^max <hmin> ^min { <hhmin> < <hmin> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> >= <hhmin> < <hmin> })
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { >= <hhmin> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c6> ^max <vcom> ^max-net <nn>)
-    (modify <c4> ^min <vcom>)
-    (make pull-ff east <nn> <gx> <gy> <gy> <vcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from east)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p460
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> left ^5 1) }
-    (ff ^came-from west ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <hmin> > <gx> } ^max <garb1> ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <hmin> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) }
-    { <c7> (horizontal ^net-name nil ^min <hhmin> ^max { <hmin> > <hhmin> } ^com <hcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) }
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> >= <hhmin> < <hmin> })
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { >= <hhmin> < <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { < <hmin> > <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c7> ^max <vcom> ^max-net <nn>)
-    (modify <c4> ^min <vcom>)
-    (make pull-ff east <nn> <gx> <gy> <gy> <vcom>)
-    (modify <c5> ^grid-x <vcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p461
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> right ^5 1) }
-    (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-  - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom>)
-    { <c6> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <garb5>) }
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> <= <hhmax> > <hmax> })
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { <= <hhmax> > <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c6> ^min <vcom> ^min-net <nn>)
-    (modify <c4> ^max <vcom>)
-    (make pull-ff west <nn> <gx> <gy> <gy> <vcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from west)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p462
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> right ^5 1) }
-    (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> > <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) }
-    { <c7> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <gabr6> ^commo <garb7>) }
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom> } ^com { <vcom> <= <hhmax> > <hmax> })
-  - (vertical ^net-name nil ^min <= <gy> ^max >= <hcom> ^com { <= <hhmax> > <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <gy> < <hcom> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c7> ^min <vcom> ^min-net <nn>)
-    (modify <c4> ^max <vcom>)
-    (make pull-ff west <nn> <gx> <gy> <gy> <vcom>)
-    (modify <c5> ^grid-x <vcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p463
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> right ^5 1) }
-    (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-  - (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom>)
-    { <c6> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <garb4> ^commo <gabr5>) }
-    (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> <= <hhmax> > <hmax> })
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { <= <hhmax> > <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c6> ^min <vcom> ^min-net <nn>)
-    (modify <c4> ^max <vcom>)
-    (make pull-ff west <nn> <gx> <gy> <gy> <vcom>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-layer <lay> ^grid-x <vcom> ^grid-y <hcom> ^came-from west)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p464
-    (context ^present extend-total-verti)
-    { <c2> (total-verti <nn> right ^5 1) }
-    (ff ^came-from east ^net-name <nn> ^grid-x <gx> ^grid-y <gy>)
-    { <c4> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <hmax> < <gx> } ^com { <hcom> < <gy> } ^layer <lay> ^compo <garb2> ^commo <garb3> ^pin-name <pn>) }
-  - (horizontal-s ^net-name <> <nn> ^com <hcom>)
-    { <c5> (ff ^net-name <nn> ^grid-x <hmax> ^grid-y <hcom> ^grid-layer <garb4> ^pin-name <garb5>) }
-    { <c7> (horizontal ^net-name nil ^min <hmax> ^max { <hhmax> > <hmax> } ^com <hcom> ^layer <lay> ^compo <garb6> ^commo <garb7>) }
-    (vertical ^net-name nil ^min { <vmin> <= <hcom> } ^max { > <vmin> >= <gy> } ^com { <vcom> <= <hhmax> > <hmax> })
-  - (vertical ^net-name nil ^min <= <hcom> ^max >= <gy> ^com { <= <hhmax> > <vcom> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom> < <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { > <hmax> < <vcom> })
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <vcom> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom> ^max >= <vcom> ^com <hcom> ^layer <lay>)
-  -->
-    (modify <c7> ^min <vcom> ^min-net <nn>)
-    (modify <c4> ^max <vcom>)
-    (make pull-ff west <nn> <gx> <gy> <gy> <vcom>)
-    (modify <c5> ^grid-x <vcom> ^grid-layer <lay>)
-    (modify 1 ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p465
-    { <c1> (context ^present remove-total-verti-gt1) }
-  -->
-    (modify <c1> ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p466
-    { <c1> (context ^present extend-total-verti) }
-  -->
-    (modify <c1> ^present remove-total-verti-gt1)
-)
-
-(p p467
-    (context ^present remove-total-verti-gt1)
-    (total-verti ^5 > 1)
-    { <t> (total-verti ^5 1) }
-  -->
-    (remove <t>)
-)
-
-(p p468
-    { <c1> (context ^present remove-total-verti-gt1) }
-    (total-verti ^5 > 1)
-  - (total-verti ^5 1)
-  -->
-    (make remove-all-total-vertis)
-    (modify <c1> ^present extend-total-verti)
-)
-
-(p p469
-    { <c1> (context ^present remove-total-verti-gt1) }
-    { <c> (remove-all-total-vertis) }
-  - (total-verti)
-  -->
-    (remove <c>)
-    (modify <c1> ^present propagate-constraint)
-)
-
-(p p470
-    { <c1> (context ^present remove-total-verti-gt1) }
-    { <c> (remove-all-total-vertis) }
-  -->
-    (remove <c>)
-    (modify <c1> ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p471
-    { <c1> (context ^present << extend-total-verti remove-total-verti-gt1 >>) }
-  - (total-verti)
-  -->
-    (modify <c1> ^present propagate-constraint)
-)
-
-(p p515
-    { <c> (context ^previous find-no-of-pins-on-a-row-col) }
-  - (total)
-    { <p> (pull-ff north <nn> <gx> <gy1> <gx> <gy2>) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from south ^pin-name <pn>) }
-    { <v> (vertical ^net-name nil ^min <gy1> ^max >= <gy2> ^com <gx> ^layer <lay>) }
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  -->
-    (remove <p> <c>)
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <gy2>)
-    (modify <v> ^min <gy2> ^min-net <nn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p516
-    { <c> (context ^previous find-no-of-pins-on-a-row-col) }
-  - (total)
-    { <p> (pull-ff south <nn> <gx> <gy1> <gx> <gy2>) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from north ^pin-name <pn>) }
-    { <v> (vertical ^net-name nil ^min <= <gy2> ^max <gy1> ^com <gx> ^layer <lay>) }
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  -->
-    (remove <p> <c>)
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <gy2>)
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (modify <ff> ^grid-y <gy2> ^can-chng-layer nil)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p517
-    { <c> (context ^previous find-no-of-pins-on-a-row-col) }
-  - (total)
-    { <p> (pull-ff east <nn> <gx1> <gy> <gx2> <gy>) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from west ^pin-name <pn>) }
-    { <v> (horizontal ^net-name nil ^min <gx1> ^max >= <gx2> ^com <gy> ^layer <lay>) }
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove <p> <c>)
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^max <gx2>)
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p518
-    { <c> (context ^previous find-no-of-pins-on-a-row-col) }
-  - (total)
-    { <p> (pull-ff west <nn> <gx1> <gy> <gx2> <gy>) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy1> ^grid-layer <lay> ^came-from east ^pin-name <pn>) }
-    { <v> (horizontal ^net-name nil ^min <= <gx2> ^max <gx1> ^com <gy> ^layer <lay>) }
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove <p> <c>)
-    (make (substr <v> 1 inf) ^net-name <nn> ^pin-name <pn> ^min <gx2>)
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (modify <ff> ^grid-x <gx2> ^can-chng-layer nil)
-    (make context ^present find-no-of-pins-on-a-row-col)
-)
-
-(p p293
-    (eliminate-total)
-    (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>)
-    { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy <min2> ^max-xy { <max2> > <max1> } ^level-pins < <p1>) }
-  - (total ^row-col <rc> ^coor <xy> ^max-xy < <min2>)
-  - (total ^row-col <rc> ^coor <xy> ^min-xy { > <max1> < <max2> })
-  -->
-    (remove <t1>)
-)
-
-(p p294
-    (eliminate-total)
-    (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>)
-    { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy <min2> ^max-xy { <max2> < <max1> } ^level-pins < <p1>) }
-  - (total ^row-col <rc> ^coor <xy> ^max-xy < <min2>)
-  - (total ^row-col <rc> ^coor <xy> ^min-xy { > <max2> < <max1> })
-  -->
-    (remove <t1>)
-)
-
-(p p295
-    (eliminate-total)
-    (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>)
-    { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy { <min2> < <min1> } ^max-xy <max2> ^level-pins < <p1>) }
-  - (total ^row-col <rc> ^coor <xy> ^min-xy > <max2>)
-  - (total ^row-col <rc> ^coor <xy> ^max-xy { > <min2> < <min1> })
-  -->
-    (remove <t1>)
-)
-
-(p p296
-    (eliminate-total)
-    (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^min-xy <min1> ^max-xy <max1> ^level-pins <p1>)
-    { <t1> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy { <min2> > <min1> } ^max-xy <max2> ^level-pins < <p1>) }
-  - (total ^row-col <rc> ^coor <xy> ^min-xy > <max2>)
-  - (total ^row-col <rc> ^coor <xy> ^max-xy { > <min1> < <min2> })
-  -->
-    (remove <t1>)
-)
-
-(p p297
-    (context ^present merge)
-    { <m> (merge-direction left) }
-    { <t1> (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^level-pins <lcou> ^total-pins <tcou> ^min-xy <min> ^max-xy <max>) }
-  - (rmerge)
-  - (total ^net-name <> <nn1> ^row-col <rc> ^coor <xy> ^max-xy < <max>)
-    (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^min-xy > <max>)
-  -->
-    (remove <m>)
-    (make merge-direction right)
-    (make lmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou> (substr <t1> nets inf))
-)
-
-(p p298
-    (context ^present merge)
-    { <m> (merge-direction right) }
-    { <t1> (total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^level-pins <lcou> ^total-pins <tcou> ^min-xy <min> ^max-xy <max>) }
-  - (lmerge)
-  - (total ^net-name <> <nn1> ^row-col <rc> ^coor <xy> ^min-xy > <min>)
-    (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^max-xy < <min>)
-  -->
-    (remove <m>)
-    (make merge-direction left)
-    (make rmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou> (substr <t1> nets inf))
-)
-
-(p p299
-    { <c> (lmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou>) }
-    { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy { <min1> > <max> } ^max-xy <max1>) }
-  - (total ^row-col <rc> ^coor <xy> ^min-xy > <max> ^max-xy < <min1>)
-  - (place-holder <rc> <xy> > <max> < <min1>)
-  -->
-    (make total ^net-name <nn1> ^row-col <rc> ^coor <xy> ^level-pins (compute <lcou> + <cou3>) ^total-pins (compute <tcou> + <cou4>) ^min-xy <min> ^max-xy <max1> ^nets (substr <c> 9 inf) (substr <t2> nets inf))
-    (make delete-merged <nn2> <rc> <xy> <min1> <max1> (genatom))
-)
-
-(p p300
-    { <c> (rmerge <nn1> <rc> <xy> <min> <max> <lcou> <tcou>) }
-    { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy <min1> ^max-xy { <max1> < <min> }) }
-  - (total ^row-col <rc> ^coor <xy> ^min-xy > <max1> ^max-xy < <min>)
-  - (place-holder <rc> <xy> > <max1> < <min>)
-  -->
-    (make total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins (compute <lcou> + <cou3>) ^total-pins (compute <tcou> + <cou4>) ^min-xy <min1> ^max-xy <max> ^nets (substr <c> 9 inf) (substr <t2> nets inf))
-    (make rdelete-merged <nn2> <rc> <xy> <min1> <max1> (genatom))
-)
-
-(p p301
-    { <d> (delete-merged <nn> <rc> <xy> <min> <max> <id>) }
-    (delete-merged <nn> <rc> <xy> <min> <max> <> <id>)
-  -->
-    (remove <d>)
-)
-
-(p p302
-    { <d> (rdelete-merged <nn> <rc> <xy> <min> <max> <id>) }
-    (rdelete-merged <nn> <rc> <xy> <min> <max> <> <id>)
-  -->
-    (remove <d>)
-)
-
-(p p303
-    (delete-merged <nn> <rc> <xy> <min> <max>)
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) }
-  - (lmerge)
-  -->
-    (remove <t>)
-)
-
-(p p304
-    (rdelete-merged <nn> <rc> <xy> <min> <max>)
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) }
-  - (rmerge)
-  -->
-    (remove <t>)
-)
-
-(p p305
-    { <d> (<< delete-merged rdelete-merged >>) }
-  - (<< lmerge rmerge >>)
-  -->
-    (remove <d>)
-)
-
-(p p306
-    (delete-merged <nn> <rc> <xy> <min> <max>)
-    { <t1> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max> ^level-pins <cou1> ^total-pins <cou2>) }
-    { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy <min1> ^max-xy { <max1> < <min> }) }
-  - (lmerge)
-  -->
-    (make place-holder <rc> <xy> <min> <max> (genatom))
-    (make total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins (compute <cou1> + <cou3>) ^total-pins (compute <cou2> + <cou4>) ^min-xy <min1> ^max-xy <max> ^nets (substr <t1> nets inf) (substr <t2> nets inf))
-)
-
-(p p307
-    (rdelete-merged <nn> <rc> <xy> <min> <max>)
-    { <t1> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max> ^level-pins <cou1> ^total-pins <cou2>) }
-    { <t2> (total ^net-name <nn2> ^row-col <rc> ^coor <xy> ^level-pins <cou3> ^total-pins <cou4> ^min-xy { <min1> > <max> } ^max-xy <max1>) }
-  - (rmerge)
-  -->
-    (make place-holder <rc> <xy> <min> <max> (genatom))
-    (make total ^net-name <nn> ^row-col <rc> ^coor <xy> ^level-pins (compute <cou1> + <cou3>) ^total-pins (compute <cou2> + <cou4>) ^min-xy <min> ^max-xy <max1> ^nets (substr <t1> nets inf) (substr <t2> nets inf))
-)
-
-(p p308
-    { <p> (place-holder <rc> <xy> <min> <max> <id>) }
-    (place-holder <rc> <xy> <min> <max> <> <id>)
-  -->
-    (remove <p>)
-)
-
-(p p309
-    (<< lmerge rmerge >>)
-    { <p> (place-holder <rc> <xy> <min> <max> <id>) }
-  - (total ^row-col <rc> ^coor <xy> ^max-xy < <min>)
-  -->
-    (remove <p>)
-)
-
-(p p310
-    (<< lmerge rmerge >>)
-    { <p> (place-holder <rc> <xy> <min> <max> <id>) }
-  - (total ^row-col <rc> ^coor <xy> ^min-xy > <max>)
-  -->
-    (remove <p>)
-)
-
-(p p311
-    (context ^present merge)
-    { <l> (lmerge <nn> <rc> <xy> <min> <max>) }
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) }
-  -->
-    (remove <l> <t>)
-)
-
-(p p312
-    (context ^present merge)
-    { <l> (rmerge <nn> <rc> <xy> <min> <max>) }
-    { <t> (total ^net-name <nn> ^row-col <rc> ^coor <xy> ^min-xy <min> ^max-xy <max>) }
-  -->
-    (remove <l> <t>)
-)
-
-(p p313
-    (context ^present merge)
-    (total ^level-pins <cou> ^total-pins <cou>)
-  - (total ^level-pins { <cou1> > <cou> } ^total-pins <cou1>)
-    { <m> (maximum-total < <cou>) }
-  -->
-    (modify <m> ^2 <cou>)
-)
-
-(p p314
-    (context ^present merge)
-    (total ^row-col row ^coor 1 ^level-pins <cou> ^total-pins <cou>)
-  - (total ^row-col row ^coor 1 ^level-pins { <cou1> > <cou> } ^total-pins <cou1>)
-    { <m> (maximum-total ^5 1 < <cou>) }
-  -->
-    (modify <m> ^6 <cou>)
-)
-
-(p p315
-    (context ^present merge)
-    (last-row <lr>)
-    (total ^row-col row ^coor <lr> ^level-pins <cou> ^total-pins <cou>)
-  - (total ^row-col row ^coor <lr> ^level-pins { <cou1> > <cou> } ^total-pins <cou1>)
-    { <m> (maximum-total ^7 <lr> < <cou>) }
-  -->
-    (modify <m> ^8 <cou>)
-)
-
-(p p316
-    (context ^present merge)
-    (total ^level-pins <cou1> ^total-pins <cou2>)
-  - (total ^level-pins > <cou1> ^total-pins > <cou2>)
-    { <m> (maximum-total <garb4> { <min1> < <cou1> }) }
-  -->
-    (modify <m> ^3 <cou1> ^4 <cou2>)
-)
-
-(p p317
-    { <con> (context ^present merge) }
-  -->
-    (modify <con> ^present delete-totals)
-    (make goal cleanup eliminate-total)
-    (make goal cleanup merge-direction)
-)
-
-(p p318
-    (context ^present delete-totals)
-    (maximum-total <max> <garb1> <garb2>)
-    { <t> (total ^level-pins { <cou> < <max> } ^total-pins <> <cou>) }
-  -->
-    (remove <t>)
-)
-
-(p p319
-    (context ^present delete-totals)
-    (maximum-total ^5 1 ^6 <cou>)
-    { <t> (total ^row-col row ^coor 1 ^level-pins { <cou1> < <cou> } ^total-pins <cou1>) }
-  -->
-    (remove <t>)
-)
-
-(p p320
-    (context ^present delete-totals)
-    (maximum-total ^7 <lr> ^8 <cou>)
-    { <t> (total ^row-col row ^coor <lr> ^level-pins { <cou1> < <cou> } ^total-pins <cou1>) }
-  -->
-    (remove <t>)
-)
-
-(p p321
-    (context ^present delete-totals)
-    (maximum-total <garb1> <min> <max>)
-    { <t> (total ^level-pins { <cou> < <min> }) }
-    (last-row <lr>)
-    (total ^row-col row ^coor { <> 1 <> <lr> })
-  -->
-    (remove <t>)
-)
-
-(p p322
-    (context ^present delete-totals)
-    (total ^row-col <rc> ^coor <xy> ^level-pins <min> ^total-pins <max>)
-    { <t1> (total ^row-col <rc> ^coor <xy> ^level-pins { <cou> <= <min> } ^total-pins > <max>) }
-  -->
-    (remove <t1>)
-)
-
-(p p323
-    (context ^present delete-totals)
-    { <m> (maximum-total <garb1> <garb2> <garb3>) }
-  -->
-    (remove <m>)
-)
-
-(p p324
-    { <c1> (context ^present delete-totals) }
-  - (maximum-total)
-    { <t1> (total ^net-name <nn1> ^row-col row ^coor 1) }
-    { <t2> (total ^net-name <nn2> ^row-col row ^coor <lr>) }
-  - (total ^row-col row ^coor { <> 1 <> <lr> })
-    (last-row <lr>)
-  -->
-    (remove <c1> <t1> <t2>)
-    (make change-priority)
-    (make tran-total row 1 (substr <t1> nets inf) end)
-    (make tran-total row <lr> (substr <t2> nets inf) end)
-    (make goal cleanup total)
-)
-
-(p p325
-    (context ^present delete-totals)
-  - (maximum-total)
-    (total ^net-name <nn1> ^row-col row ^coor 1)
-    (total ^net-name <nn2> ^row-col row ^coor <lr>)
-    { <t1> (total ^net-name <> <nn1> ^row-col row ^coor 1) }
-    (last-row <lr>)
-  -->
-    (remove <t1>)
-)
-
-(p p326
-    { <t1> (tran-total <rc> <xy1> end) }
-    { <t2> (tran-total <rc> <> <xy1> end) }
-  -->
-    (remove <t2>)
-    (modify <t1> ^4 nil)
-)
-
-(p p519
-    (context ^present random1)
-    (net ^net-name <nn> ^net-no-of-pins 2)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>)
-    (vertical-layer <lay>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> <= <gy1> } ^grid-layer <lay>)
-    (vertical ^net-name nil ^min { <vmin1> <= <gy1> } ^max { <vmax1> > <vmin1> >= <gy1> } ^com <gx1> ^layer <lay> ^compo <gx2> ^commo <cmo> ^min-net <vnn1>)
-    (vertical ^net-name nil ^min { <vmin2> <= <gy2> } ^max { <vmax2> > <vmin2> >= <gy2> >= <vmin1> } ^com <gx2> ^layer <lay> ^compo <cpo> ^commo <garb1> ^max-net <vnn2>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> >= <gx2> > <hmin> } ^com { <hcom> <= <vmax1> >= <vmin1> <= <vmax2> >= <vmin2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-  - (horizontal ^net-name <> nil ^com <hcom>)
-  -->
-    (remove 1 3 5)
-    (make vertical ^com <gx1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <gx2> ^commo <cmo> ^min-net <vnn1> ^max-net <nn>)
-    (modify 6 ^min <gy1> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <lay> ^min <hcom> ^max <vmax2> ^compo <cpo> ^commo <gx1> ^min-net <nn> ^max-net <vnn2>)
-    (modify 7 ^max <gy2> ^max-net <nn>)
-    (make horizontal ^min <hmin> ^max <gx1> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 8 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <lay> ^min <hcom> ^max <gy1> ^commo <cmo> ^compo <gx2> ^net-name <nn> ^pin-name <pn>)
-    (make vertical ^com <gx2> ^layer <lay> ^max <hcom> ^min <gy2> ^commo <gx1> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <hcom> ^layer <lay> ^min <gx1> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p520
-    (context ^present random1)
-    (net ^net-name <nn> ^net-no-of-pins 2)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn>)
-    (horizontal-layer <lay>)
-    (ff ^net-name <nn> ^grid-x { <gx2> >= <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <lay>)
-    (horizontal ^net-name nil ^min { <hmin1> <= <gx1> } ^max { <hmax1> > <hmin1> >= <gx1> } ^com <gy1> ^layer <lay> ^compo <gy2> ^commo <cmo> ^max-net <hnn1>)
-    (horizontal ^net-name nil ^min { <hmin2> <= <gx2> } ^max { <hmax2> > <hmin2> >= <gx2> >= <hmax1> } ^com <gy2> ^layer <lay> ^compo <cpo> ^commo <garb1> ^min-net <hnn2>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> >= <gy2> > <vmin> } ^com { <vcom> <= <hmax1> >= <hmin1> <= <hmax2> >= <hmin2> } ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-  - (vertical ^net-name <> nil ^com <vcom>)
-  -->
-    (remove 1 3 5)
-    (make horizontal ^com <gy1> ^layer <lay> ^min <vcom> ^max <hmax1> ^compo <gy2> ^commo <cmo> ^min-net <nn> ^max-net <hnn1>)
-    (modify 6 ^max <gx1> ^max-net <nn>)
-    (make horizontal ^com <gy2> ^layer <lay> ^min <hmin2> ^max <vcom> ^compo <cpo> ^commo <gy1> ^min-net <hnn2> ^max-net <nn>)
-    (modify 7 ^min <gx2> ^min-net <nn>)
-    (make vertical ^min <vmin> ^max <gy1> ^com <vcom> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 8 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <lay> ^min <gx1> ^max <vcom> ^commo <cmo> ^compo <gy2> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <lay> ^min <vcom> ^max <gx2> ^commo <gy1> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (make vertical ^com <vcom> ^layer <lay> ^min <gy1> ^max <gy2> ^commo <vcmo> ^compo <vcpo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p521
-    (context ^present random1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> > <gx> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { >= <gx> < <vcom1> })
-    (vertical ^com { <vcom2> <= <vcom1> > <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom2>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom2> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom2> ^max >= <vcom2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <vcom2> >= <gx> } ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x < <gx>)
-  - (ff ^grid-x <vcom2> ^grid-y <gy>)
-  -->
-    (make made-random-move)
-    (make horizontal ^min <hmin> ^layer <lay> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <vcom2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <vcom2> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify 2 ^grid-x <vcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from west)
-)
-
-(p p522
-    (context ^present random1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> < <gx> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <= <gx> > <vcom1> })
-    (vertical ^com { <vcom2> >= <vcom1> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom2> ^max >= <gx>)
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom2> } ^max { > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom2> ^max >= <vcom2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <gx> >= <vcom2> } ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x > <gx>)
-  - (ff ^grid-x <vcom2> ^grid-y <gy>)
-  -->
-    (make made-random-move)
-    (make horizontal ^min <hmin> ^layer <lay> ^max <vcom2> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <gx> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <vcom2> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify 2 ^grid-x <vcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from east)
-)
-
-(p p523
-    (context ^present random1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <vcom1> < <gx> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <= <gx> > <vcom1> })
-    (vertical ^com { <vcom2> >= <vcom1> < <gx> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom2> ^max >= <gx>)
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom2> } ^max { > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom2> ^max >= <vcom2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <= <gx> >= <vcom2> } ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x > <gx>)
-  - (ff ^grid-x <vcom2> ^grid-y <gy>)
-  -->
-    (make made-random-move)
-    (make horizontal ^min <hmin> ^layer <lay> ^max <vcom2> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <gx> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <vcom2> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify 2 ^grid-x <vcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from east)
-)
-
-(p p524
-    (context ^present random1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> < <gy> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom1> <= <gy> })
-    (horizontal ^com { <hcom2> >= <hcom1> < <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcom2> ^max >= <gy>)
-    (vertical ^net-name nil ^min { <vmin> <= <hcom2> } ^max { > <vmin> >= <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <hcom2> <= <gy> } ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom2> ^max >= <hcom2> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  - (ff ^grid-x <gx> ^grid-y <hcom2>)
-  -->
-    (make made-random-move)
-    (make vertical ^min <vmin> ^layer <lay> ^max <hcom2> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^min <hcom2> ^max <gy> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>)
-    (modify 2 ^grid-y <hcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from north)
-)
-
-(p p525
-    (context ^present random1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> > <gy> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <hcom1> >= <gy> })
-    (horizontal ^com { <hcom2> <= <hcom1> > <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <hcom2>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom2> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <gy> <= <hcom2> } ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom2> ^max >= <hcom2> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  - (ff ^grid-x <gx> ^grid-y <hcom2>)
-  -->
-    (make made-random-move)
-    (make vertical ^min <vmin> ^layer <lay> ^max <gy> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <hcom2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy> ^max <hcom2> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>)
-    (modify 2 ^grid-y <hcom2> ^grid-layer <lay> ^can-chng-layer nil ^came-from south)
-)
-
-(p p526
-    (context ^present random1)
-  -->
-    (remove 1)
-    (make context ^present check-random-move)
-)
-
-(p p527
-    { <c> (context ^present check-random-move) }
-    { <m> (made-random-move) }
-  -->
-    (remove <c> <m>)
-    (make context ^present check-for-routed-net)
-    (make goal cleanup made-random-move)
-)
-
-(p p528
-    { <c> (context ^present check-random-move) }
-  - (made-random-move)
-  -->
-    (remove <c>)
-    (make context ^present random2)
-)
-
-(p p529
-    (context ^present random2)
-  -->
-    (write (crlf) |Sorry, I can not proceed anymore because of my ignorance.|)
-    (halt)
-)
-
-(p p530
-    (context ^present random0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^pin-name <> <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> < <gy> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { > <hcom1> <= <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcom1> ^max >= <gy>)
-    (vertical ^net-name nil ^min { <vmin> <= <hcom1> } ^max { > <vmin> >= <gy> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-    (vertical-layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <hcom1> <= <gy> } ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom1> ^max >= <hcom1> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  -->
-    (remove 1)
-    (make vertical ^min <vmin> ^layer <lay> ^max <hcom1> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 4 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^min <hcom1> ^max <gy> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>)
-    (modify 2 ^grid-y <hcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from north)
-    (make context ^present propagate-constraint)
-)
-
-(p p531
-    (context ^present random0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^pin-name <> <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^com { <hcom1> > <gy> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^com { < <hcom1> >= <gy> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <hcom1>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { > <vmin> >= <hcom1> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-    (vertical-layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { >= <gy> <= <hcom1> } ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <hcom1> ^max >= <hcom1> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  -->
-    (remove 1)
-    (make vertical ^min <vmin> ^layer <lay> ^max <gy> ^com <gx> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 4 ^min <hcom1> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy> ^max <hcom1> ^commo <vcmo> ^compo <vcpo> ^layer <lay> ^com <gx>)
-    (modify 2 ^grid-y <hcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from south)
-    (make context ^present propagate-constraint)
-)
-
-(p p532
-    (context ^present random0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^pin-name <> <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> < <gx> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { <= <gx> > <vcom1> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom1> ^max >= <gx>)
-    (horizontal ^net-name nil ^min { <hmin> <= <vcom1> } ^max { > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-    (horizontal-layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom1> ^max >= <vcom1> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <vcom1> <= <gx> } ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x > <gx>)
-  -->
-    (remove 1)
-    (make horizontal ^min <hmin> ^layer <lay> ^max <vcom1> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 4 ^min <gx> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <vcom1> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify 2 ^grid-x <vcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from east)
-    (make context ^present propagate-constraint)
-)
-
-(p p533
-    (context ^present random0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-  - (ff ^net-name <nn> ^pin-name <> <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^com { <vcom1> > <gx> })
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^com { >= <gx> < <vcom1> })
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom1>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { > <hmin> >= <vcom1> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-    (horizontal-layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <vcom1> ^max >= <vcom1> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { >= <gx> <= <vcom1> } ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x < <gx>)
-  -->
-    (remove 1)
-    (make horizontal ^min <hmin> ^layer <lay> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify 4 ^min <vcom1> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <vcom1> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify 2 ^grid-x <vcom1> ^grid-layer <lay> ^can-chng-layer nil ^came-from west)
-    (make context ^present propagate-constraint)
-)
-
-(p p534
-    { <c> (context ^present random2) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (vertical ^status nil ^net-name { <nn> <> nil } ^com > <gx>)
-    { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) }
-    (congestion ^direction col ^coordinate <gx2> ^como <gx>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  -->
-    (make horizontal ^min <hmin> ^layer <lay> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify <h> ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify <ff> ^grid-x <gx2> ^grid-layer <lay> ^can-chng-layer nil ^came-from west)
-    (remove <c>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p535
-    { <c> (context ^present random2) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (vertical ^status nil ^net-name { <nn> <> nil } ^com < <gx>)
-    { <h> (horizontal ^net-name nil ^min { <hmin> < <gx> } ^max { <hmax> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) }
-    (congestion ^direction col ^coordinate <gx> ^como <gx2>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  -->
-    (make horizontal ^min <hmin> ^layer <lay> ^max <gx2> ^com <gy> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify <h> ^min <gx> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^min <gx2> ^max <gx> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gy>)
-    (modify <ff> ^grid-x <gx2> ^grid-layer <lay> ^can-chng-layer nil ^came-from east)
-    (remove <c>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p536
-    { <c> (context ^present random2) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^com > <gy>)
-    { <h> (vertical ^net-name nil ^min { <hmin> <= <gy> } ^max { <hmax> > <gy> } ^com <gx> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) }
-    (congestion ^direction row ^coordinate <gy2> ^como <gy>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  -->
-    (make vertical ^min <hmin> ^layer <lay> ^max <gy> ^com <gx> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify <h> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy> ^max <gy2> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gx>)
-    (modify <ff> ^grid-y <gy2> ^grid-layer <lay> ^can-chng-layer nil ^came-from south)
-    (remove <c>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p537
-    { <c> (context ^present random2) }
-    { <ff> (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>) }
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^com < <gy>)
-    { <h> (vertical ^net-name nil ^min { <hmin> < <gy> } ^max { <hmax> >= <gy> } ^com <gx> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>) }
-    (congestion ^direction row ^coordinate <gy> ^como <gy2>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  -->
-    (make vertical ^min <hmin> ^layer <lay> ^max <gy2> ^com <gx> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn>)
-    (modify <h> ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^min <gy2> ^max <gy> ^commo <hcmo> ^compo <hcpo> ^layer <lay> ^com <gx>)
-    (modify <ff> ^grid-y <gy2> ^grid-layer <lay> ^can-chng-layer nil ^came-from north)
-    (remove <c>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p558
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> <= <nmax> } ^grid-y <gy>)
-  - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-  - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com <gy> ^layer <> <lay>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove 2 3)
-    (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p559
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> > <gx1> <= <nmax> })
-  - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx1> < <gx2> })
-    (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove 2)
-    (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p560
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> < <gx1> >= <nmin> })
-  - (ff ^net-name <nn> ^grid-x { < <gx1> > <gx2> } ^grid-y <gy>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { < <gx1> > <gx2> })
-    (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> >= <gx1> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx2> ^max >= <gx1> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove 2)
-    (make horizontal ^com <gy> ^min <min> ^max <gx2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make horizontal ^com <gy> ^min <gx1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gx2> ^max <gx1> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p561
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> > <gx1> <= <nmax> })
-  - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { > <gx1> < <gx2> })
-    (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-    (horizontal-layer <lay>)
-    (dominant-layer)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove 2)
-    (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p562
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { <gx2> < <gx1> >= <nmin> })
-  - (ff ^net-name <nn> ^grid-x { < <gx1> > <gx2> } ^grid-y <gy>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com { < <gx1> > <gx2> })
-    (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> >= <gx1> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-    (horizontal-layer <lay>)
-    (dominant-layer)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx2> ^max >= <gx1> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove 2)
-    (make horizontal ^com <gy> ^min <min> ^max <gx2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make horizontal ^com <gy> ^min <gx1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gx2> ^max <gx1> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p563
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x { <gx1> >= <nmin> <= <nmax> } ^grid-y <gy> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> <= <nmax> } ^grid-y <gy>)
-  - (ff ^net-name <nn> ^grid-x { > <gx1> < <gx2> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx1> } ^max { <max> >= <gx2> } ^max { <max> >= <gx2> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-    (horizontal-layer <lay>)
-    (dominant-layer)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx1> ^max >= <gx2> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <gy> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx1> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  -->
-    (remove 2 3)
-    (make horizontal ^com <gy> ^min <min> ^max <gx1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make horizontal ^com <gy> ^min <gx2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gx1> ^max <gx2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p564
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <gy1> <= <nmax> } ^grid-x <gx>)
-  - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-  - (vertical ^net-name nil ^min <= <gy1> ^max >= <gy2> ^com <gx> ^layer <> <lay>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (remove 2 3)
-    (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p565
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> > <gy1> <= <nmax> })
-  - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy1> < <gy2> })
-    (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (remove 2)
-    (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p566
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> < <gy1> >= <nmin> })
-  - (ff ^net-name <nn> ^grid-y { > <gy2> < <gy1> } ^grid-x <gx>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy2> < <gy1> })
-    (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> >= <gy1> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy2> ^max >= <gy1> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (remove 2)
-    (make vertical ^com <gx> ^min <min> ^max <gy2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make vertical ^com <gx> ^min <gy1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gy2> ^max <gy1> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p567
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> > <gy1> <= <nmax> })
-  - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy1> < <gy2> })
-    (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-    (vertical-layer <lay>)
-    (dominant-layer)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (remove 2)
-    (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p568
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { <gy2> < <gy1> >= <nmin> })
-  - (ff ^net-name <nn> ^grid-y { > <gy2> < <gy1> } ^grid-x <gx>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com { > <gy2> < <gy1> })
-    (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> >= <gy1> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-    (vertical-layer <lay>)
-    (dominant-layer)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy2> ^max >= <gy1> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (remove 2)
-    (make vertical ^com <gx> ^min <min> ^max <gy2> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make vertical ^com <gx> ^min <gy1> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gy2> ^max <gy1> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p569
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy1> >= <nmin> <= <nmax> } ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <gy1> <= <nmax> } ^grid-x <gx>)
-  - (ff ^net-name <nn> ^grid-y { > <gy1> < <gy2> } ^grid-x <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy1> } ^max { <max> >= <gy2> > <min> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <nn1> ^max-net <nn2>)
-    (vertical-layer <lay>)
-    (dominant-layer)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy1> ^max >= <gy2> ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy1> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <gx> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (remove 2 3)
-    (make vertical ^com <gx> ^min <min> ^max <gy1> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn1> ^max-net <nn>)
-    (make vertical ^com <gx> ^min <gy2> ^max <max> ^compo <cpo> ^commo <cmo> ^layer <lay> ^min-net <nn> ^max-net <nn2>)
-    (modify 4 ^min <gy1> ^max <gy2> ^net-name <nn> ^pin-name <pn>)
-)
-
-(p p570
-    (next-segment <nn> row <gy> nil <nmin> <nmax>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <max> >= <nmin> <= <nmax> } ^com <gy> ^layer <garb2> ^compo <garb3> ^commo <garb4> ^pin-name <pn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <max> ^max > <max> ^com <gy>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min { <min> > <max> <= <nmax> } ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <min> ^max >= <min> ^com <gy>)
-    (horizontal ^net-name nil ^min <max> ^max { <min> > <max> } ^com <gy> ^layer <garb5> ^compo <garb6> ^commo <garb7>)
-  -->
-    (modify 4 ^net-name <nn> ^pin-name <pn> ^max-net nil ^min-net nil)
-)
-
-(p p571
-    (next-segment <nn> col <gx> nil <nmin> <nmax>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <garb1> ^max { <max> >= <nmin> <= <nmax> } ^com <gx> ^layer <garb2> ^compo <garb3> ^commo <garb4> ^pin-name <pn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <max> ^max > <max> ^com <gx>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min { <min> > <max> <= <nmax> } ^com <gx>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <min> ^max >= <min> ^com <gx>)
-    (vertical ^net-name nil ^min <max> ^max { <min> > <max> } ^com <gx> ^layer <garb5> ^compo <garb6> ^commo <garb7>)
-  -->
-    (modify 4 ^net-name <nn> ^pin-name <pn> ^max-net nil ^min-net nil)
-)
-
-(p p572
-    { <next> (next-segment <nn> row <gy>) }
-    (ff ^net-name <nn> ^grid-y <gy> ^pin-name <pn> ^came-from north)
-    (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <np> ^no-of-bottom-pins <garb1>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-    { <ff> (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^pin-name <pn2> ^grid-x <gx> ^grid-layer <lay> ^came-from north) }
-    { <v1> (vertical ^net-name nil ^min { <min> <= <gy> } ^max { > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>) }
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com { < <gy2> >= <gy> } ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <gy> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>)
-    (modify <v1> ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn2>)
-    (modify <ff> ^grid-y <gy> ^can-chng-layer nil)
-    (modify <next> ^5 useless)
-)
-
-(p p573
-    { <next> (next-segment <nn> row <gy>) }
-    (ff ^came-from south ^net-name <nn> ^grid-y <gy> ^pin-name <pn>)
-    (net ^net-name <nn> ^net-no-of-pins <np> ^no-of-top-pins <garb1> ^no-of-bottom-pins <np>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-    { <ff> (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^pin-name <pn2> ^grid-x <gx> ^grid-layer <lay> ^came-from south) }
-    { <v1> (vertical ^net-name nil ^max { <max> >= <gy> } ^min { < <max> <= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>) }
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com { > <gy2> <= <gy> } ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <max> ^min <gy> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <nn> ^max-net <mn>)
-    (modify <v1> ^max <gy2> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn2>)
-    (modify <ff> ^grid-y <gy> ^can-chng-layer nil)
-    (modify <v1> ^5 useless)
-)
-
-(p p574
-    (next-segment <nn> row <gy> <gg1> <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^grid-x { <gx> >= <nmin> <= <nmax> } ^grid-layer <lay> ^pin-name <pn>)
-    (vertical ^net-name nil ^min { <min> <= <gy> } ^max { > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>)
-    (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy2> ^com <gx>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <gy> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>)
-    (modify 3 ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy2> ^min <gy> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify 2 ^grid-y <gy> ^can-chng-layer nil)
-    (modify 1 ^2 <nn>)
-)
-
-(p p575
-    (next-segment <nn> row <gy> <gg1> <nmin> <nmax>)
-    (vertical ^net-name { <nn> <> nil } ^min { <gy2> > <gy> } ^com { <gx> >= <nmin> <= <nmax> } ^layer <lay> ^pin-name <pn>)
-    (vertical ^net-name nil ^min { < <gy2> <= <gy> } ^max <gy2> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-    (vertical-s ^net-name <nn> ^min <= <gy> ^max >= <gy2> ^com <gx>)
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2>)
-  - (vertical ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy2> ^com <gx>)
-  - (ff ^net-name <> <nn> ^grid-x <gx>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  -->
-    (modify 3 ^max <gy> ^max-net <nn>)
-    (modify 2 ^min <gy>)
-    (make ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north)
-    (modify 1 ^2 <nn>)
-)
-
-(p p576
-    (next-segment <nn> row <gy> <gg1> <nmin> <nmax>)
-    (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^grid-x { <gx> >= <nmin> <= <nmax> } ^grid-layer <lay> ^pin-name <pn>)
-    (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>)
-    (vertical-s ^net-name <nn> ^min <= <gy2> ^max >= <gy> ^com <gx>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <gy2> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>)
-    (modify 3 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <gy2> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify 2 ^grid-y <gy> ^can-chng-layer nil)
-    (modify 1 ^2 <nn>)
-)
-
-(p p577
-    (next-segment <nn> row <gy> <gg1> <nmin> <nmax>)
-    (vertical ^net-name { <nn> <> nil } ^min { <gy2> < <gy> } ^com { <gx> >= <nmin> <= <nmax> } ^layer <lay> ^pin-name <pn>)
-    (vertical ^net-name nil ^min <gy2> ^max { > <gy2> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo>)
-    (vertical-s ^net-name <nn> ^min <= <gy2> ^max >= <gy> ^com <gx>)
-  - (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy2>)
-  - (vertical ^net-name { <nn> <> nil } ^min <= <gy2> ^max >= <gy> ^com <gx>)
-  - (ff ^net-name <> <nn> ^grid-x <gx>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^com <gx>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  -->
-    (modify 3 ^min <gy> ^min-net <nn>)
-    (modify 2 ^max <gy>)
-    (make ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from south)
-    (modify 1 ^2 <nn>)
-)
-
-(p p578
-    (next-segment <nn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <garb2>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy> ^layer <garb3> ^compo <garb4> ^commo <garb5>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx> ^layer <garb6> ^compo <garb7> ^commo <garb8>)
-  -->
-    (remove 2)
-)
-
-(p p579
-    (next-segment <nn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <garb1> ^pin-name <garb2>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max <gx> ^com <gy>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <gx> ^max > <gx> ^com <gy>)
-  -->
-    (remove 2)
-)
-
-(p p580
-    (change-priority)
-    { <n> (next-segment ^5 useless) }
-  -->
-    (modify <n> ^5 nil)
-)
-
-(p p581
-    (change-priority)
-    { <n> (next-segment <nn> col <x> useless <min> <max>) }
-    (vertical-s ^net-name <nn> ^com <x> ^sum 2 ^difference 0)
-    (last-row <lr>)
-  -->
-    (modify <n> ^5 nil 1 <lr>)
-)
-
-(p p582
-    (change-priority)
-    { <n> (next-segment <nn> row <y> useless <min> <max>) }
-    (horizontal-s ^net-name <nn> ^com <x> ^sum 2 ^difference 0)
-    (last-col <lc>)
-  -->
-    (modify <n> ^5 nil 1 <lc>)
-)
-
-(p p583
-    { <n> (next-segment <nn> <rc> <xy> nil) }
-  - (next-segment ^5 <> nil)
-  -->
-    (remove <n>)
-    (make move-ff <nn> <rc> <xy>)
-)
-
-(p p584
-    { <c> (change-priority) }
-  -->
-    (remove <c>)
-    (make end-of-specialized-move-ff)
-)
-
-(p p585
-    (move-ff <nn> row <xy>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <xy> ^layer <lay> ^compo <cpo> ^commo <garb1>)
-    { <ff> (ff ^came-from south ^net-name { <nn1> <> <nn> } ^grid-x { <gx> >= <min> <= <max> } ^grid-y <xy> ^grid-layer { <flay> <> <lay> }) }
-    { <v1> (vertical ^status nil ^net-name <nn1> ^min < <xy> ^max <xy> ^com <gx> ^layer <flay>) }
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <xy> ^layer <flay>)
-    { <v2> (vertical ^net-name nil ^min <xy> ^max { <garb4> > <xy> } ^com <gx> ^layer <flay> ^compo <garb2> ^commo <garb3>) }
-  -->
-    (modify <v2> ^min <cpo> ^min-net <nn1>)
-    (modify <v1> ^max <cpo>)
-    (modify <ff> ^grid-y <cpo> ^can-chng-layer nil)
-)
-
-(p p586
-    (move-ff <nn> row <xy>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min> ^max <max> ^com <xy> ^layer <lay> ^compo <garb1> ^commo <cmo>)
-    { <ff> (ff ^came-from north ^net-name { <nn1> <> <nn> } ^grid-x { <gx> >= <min> <= <max> } ^grid-y <xy> ^grid-layer { <flay> <> <lay> }) }
-    { <v1> (vertical ^status nil ^net-name <nn1> ^min <xy> ^max > <xy> ^com <gx> ^layer <flay>) }
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <gx> ^com <xy> ^layer <flay>)
-    { <v2> (vertical ^net-name nil ^min <vmin> ^max { <xy> > <vmin> } ^com <gx> ^layer <flay> ^compo <garb2> ^commo <garb3>) }
-  -->
-    (modify <v2> ^max <cmo> ^max-net <nn1>)
-    (modify <v1> ^min <cmo>)
-    (modify <ff> ^grid-y <cmo> ^can-chng-layer nil)
-)
-
-(p p587
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <min> ^max <max>)
-    { <h> (horizontal-s ^net-name <nn> ^min <min> ^max <max>) }
-  -->
-    (remove <h>)
-)
-
-(p p588
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <min> ^max <max>)
-    { <v> (vertical-s ^net-name <nn> ^min <min> ^max <max>) }
-  -->
-    (remove <v>)
-)
-
-(p p589
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <min> ^max <max> ^com <com>)
-    (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> < <com> })
-    { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <gy> } ^max { <vmax> >= <com> } ^com <gx> ^id <id>) }
-    (vertical ^net-name nil ^min <= <gy> ^max >= <com> ^com <gx>)
-  - (vertical-s ^net-name <> <nn> ^com <gx>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> col <gx> nil <vmin> <vmax>)
-)
-
-(p p590
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <min> ^max <max> ^com <com>)
-    (ff ^net-name <nn> ^grid-x { <gx> >= <min> <= <max> } ^grid-y { <gy> > <com> })
-    { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <com> } ^max { <vmax> >= <gy> } ^com <gx> ^id <id>) }
-    (vertical ^net-name nil ^min <= <com> ^max >= <gy> ^com <gx>)
-  - (vertical-s ^net-name <> <nn> ^com <gx>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> col <gx> nil <vmin> <vmax>)
-)
-
-(p p591
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> < <hcom1> })
-    { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) }
-    (vertical ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax2> })
-  - (vertical-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> col <vcom2> nil <vmin> <vmax>)
-)
-
-(p p592
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> > <hcom1> })
-    { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) }
-    (vertical ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax2> })
-  - (vertical-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> col <vcom2> nil <vmin> <vmax>)
-)
-
-(p p593
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> < <hcom1> })
-    { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) }
-    (vertical ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax1> })
-  - (vertical-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> col <vcom2> nil <vmin> <vmax>)
-)
-
-(p p594
-    (move-ff <nn>)
-    (horizontal ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (horizontal ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> > <hcom1> })
-    { <v> (vertical-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) }
-    (vertical ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax1> })
-  - (vertical-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> col <vcom2> nil <vmin> <vmax>)
-)
-
-(p p595
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <min> ^max <max> ^com <com>)
-    (ff ^net-name <nn> ^grid-x { <gx> < <com> } ^grid-y { <gy> >= <min> <= <max> })
-    { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <gx> } ^max { <vmax> >= <com> } ^com <gy> ^id <id>) }
-    (horizontal ^net-name nil ^min <= <gx> ^max >= <com> ^com <gy>)
-  - (horizontal-s ^net-name <> <nn> ^com <gy>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> row <gy> nil <vmin> <vmax>)
-)
-
-(p p596
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <min> ^max <max> ^com <com>)
-    (ff ^net-name <nn> ^grid-x { <gx> > <com> } ^grid-y { <gy> >= <min> <= <max> })
-    { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <com> } ^max { <vmax> >= <gx> } ^com <gy> ^id <id>) }
-    (horizontal ^net-name nil ^min <= <com> ^max >= <gx> ^com <gy>)
-  - (horizontal-s ^net-name <> <nn> ^com <gy>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> row <gy> nil <vmin> <vmax>)
-)
-
-(p p597
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> < <hcom1> })
-    { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) }
-    (horizontal ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax2> })
-  - (horizontal-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> row <vcom2> nil <vmin> <vmax>)
-)
-
-(p p598
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> } ^max { <hmax2> <= <hmax1> } ^com { <hcom2> > <hcom1> })
-    { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax2> } ^id <id>) }
-    (horizontal ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax2> })
-  - (horizontal-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> row <vcom2> nil <vmin> <vmax>)
-)
-
-(p p599
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> < <hcom1> })
-    { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom2> } ^max { <vmax> >= <hcom1> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) }
-    (horizontal ^net-name nil ^min <= <hcom2> ^max >= <hcom1> ^com { <vcom2> >= <hmin2> <= <hmax1> })
-  - (horizontal-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> row <vcom2> nil <vmin> <vmax>)
-)
-
-(p p600
-    (move-ff <nn>)
-    (vertical ^net-name <nn> ^min <hmin1> ^max <hmax1> ^com <hcom1>)
-    (vertical ^net-name <nn> ^min { <hmin2> >= <hmin1> <= <hmax1> } ^max { <hmax2> >= <hmax1> } ^com { <hcom2> > <hcom1> })
-    { <v> (horizontal-s ^net-name <nn> ^min { <vmin> <= <hcom1> } ^max { <vmax> >= <hcom2> } ^com { <vcom> >= <hmin2> <= <hmax1> } ^id <id>) }
-    (horizontal ^net-name nil ^min <= <hcom1> ^max >= <hcom2> ^com { <vcom2> >= <hmin2> <= <hmax1> })
-  - (horizontal-s ^net-name <> <nn> ^com <vcom2>)
-  -->
-    (remove <v>)
-    (make next-segment <nn> row <vcom2> nil <vmin> <vmax>)
-)
-
-(p p601
-    { <m> (move-ff) }
-  -->
-    (remove <m>)
-)
-
-(p p602
-    { <e> (end-of-specialized-move-ff) }
-  - (next-segment)
-  -->
-    (remove <e>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p603
-    (context ^present << check-for-routed-net propagate-constraint >>)
-    (<< dominant-layer change-priority next-segment >>)
-  -->
-    (remove 2)
-)
-
-(p p244
-    (context ^present lshape1)
-    (<< total-verti counted-verti total counted >>)
-  -->
-    (remove 2)
-)
-
-(p p245
-    (context ^present lshape1)
-    (last-row <gy>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north)
-  - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <gy2>)
-  - (vertical ^com { > <gx> < <gx2> })
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy> ^layer <lay> ^commo <hcmo> ^compo <hcpo> ^min-net <mn>)
-  - (pin ^pin-x <gx2> ^pin-y <hcpo>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> nil <> <nn> } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  -->
-    (make horizontal ^layer <lay> ^min <hmin> ^max <gx> ^min-net <mn> ^max-net <nn> ^com <gy> ^commo <hcmo> ^compo <hcpo>)
-    (modify 5 ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx> ^max <gx2> ^com <gy> ^commo <hcmo> ^compo <hcpo>)
-    (modify 3 ^grid-x <gx2> ^came-from west)
-)
-
-(p p246
-    (context ^present lshape1)
-    (last-row <gy>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north)
-  - (ff ^net-name <nn> ^grid-y <gy> ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y <gy2>)
-  - (vertical ^com { > <gx2> < <gx> })
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx> } ^com <gy> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (pin ^pin-x <gx2> ^pin-y <hcpo>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy> ^max >= <gy> ^com <gx2> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <gy> ^layer <lay>)
-  -->
-    (make horizontal ^layer <lay> ^min <hmin> ^max <gx2> ^min-net <mn> ^max-net <nn> ^com <gy> ^commo <hcmo> ^compo <hcpo>)
-    (modify 5 ^min <gx> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx2> ^max <gx> ^com <gy> ^commo <hcmo> ^compo <hcpo>)
-    (modify 3 ^grid-x <gx2> ^came-from east)
-)
-
-(p p247
-    (context ^present lshape1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y 1 ^grid-layer <lay> ^pin-name <pn> ^came-from south)
-  - (ff ^net-name <nn> ^grid-y 1 ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <gy2>)
-  - (vertical ^com { > <gx> < <gx2> })
-    (horizontal ^net-name nil ^min { <hmin> <= <gx> } ^max { <hmax> > <hmin> >= <gx2> } ^com 1 ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (pin ^pin-x <gx2> ^pin-y 0)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gx2> ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com 1 ^layer <lay>)
-  -->
-    (make horizontal ^layer <lay> ^min <hmin> ^max <gx> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <hcmo> ^compo <hcpo>)
-    (modify 4 ^min <gx2> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx> ^max <gx2> ^com 1 ^commo <hcmo> ^compo <hcpo>)
-    (modify 2 ^grid-x <gx2> ^came-from west)
-)
-
-(p p248
-    (context ^present lshape1)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y 1 ^grid-layer <lay> ^pin-name <pn> ^came-from south)
-  - (ff ^net-name <nn> ^grid-y 1 ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y <gy2>)
-  - (vertical ^com { > <gx2> < <gx> })
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx> } ^com 1 ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (pin ^pin-x <gx2> ^pin-y 0)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gx2> ^layer <lay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com 1 ^layer <lay>)
-  -->
-    (make horizontal ^layer <lay> ^min <hmin> ^max <gx2> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <hcmo> ^compo <hcpo>)
-    (modify 4 ^min <gx> ^min-net <nn>)
-    (make horizontal ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gx2> ^max <gx> ^com 1 ^commo <hcmo> ^compo <hcpo>)
-    (modify 2 ^grid-x <gx2> ^came-from east)
-)
-
-(p p249
-    (context ^present lshape1)
-    (last-col <gx>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from east)
-  - (ff ^net-name <nn> ^grid-x <gx> ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> > <gy> })
-  - (horizontal ^com { > <gy> < <gy2> })
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { <vmax> >= <gy2> > <vmin> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (pin ^pin-x <vcpo> ^pin-y <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^layer <lay> ^min <vmin> ^max <gy> ^min-net <mn> ^max-net <nn> ^com <gx> ^commo <vcmo> ^compo <vcpo>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy> ^max <gy2> ^com <gx> ^commo <vcmo> ^compo <vcpo>)
-    (modify 3 ^grid-y <gy2> ^came-from south)
-)
-
-(p p250
-    (context ^present lshape1)
-    (last-col <gx>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from east)
-  - (ff ^net-name <nn> ^grid-x <gx> ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> < <gy> })
-  - (horizontal ^com { > <gy2> < <gy> })
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> >= <gy> > <vmin> } ^com <gx> ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (pin ^pin-x <vcpo> ^pin-y <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= <gx> ^max >= <gx> ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^layer <lay> ^min <vmin> ^max <gy2> ^min-net <mn> ^max-net <nn> ^com <gx> ^commo <vcmo> ^compo <vcpo>)
-    (modify 5 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy2> ^max <gy> ^com <gx> ^commo <vcmo> ^compo <vcpo>)
-    (modify 3 ^grid-y <gy2> ^came-from north)
-)
-
-(p p251
-    (context ^present lshape1)
-    (ff ^net-name <nn> ^grid-x 1 ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from west)
-  - (ff ^net-name <nn> ^grid-x 1 ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> > <gy> })
-  - (horizontal ^com { > <gy> < <gy2> })
-    (vertical ^net-name nil ^min { <vmin> <= <gy> } ^max { <vmax> > <vmin> >= <gy2> } ^com 1 ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (pin ^pin-x 0 ^pin-y <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com 1 ^layer <lay>)
-  -->
-    (make vertical ^layer <lay> ^min <vmin> ^max <gy> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <vcmo> ^compo <vcpo>)
-    (modify 4 ^min <gy2> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy> ^max <gy2> ^com 1 ^commo <vcmo> ^compo <vcpo>)
-    (modify 2 ^grid-y <gy2> ^came-from south)
-)
-
-(p p252
-    (context ^present lshape1)
-    (ff ^net-name <nn> ^grid-x 1 ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from west)
-  - (ff ^net-name <nn> ^grid-x 1 ^pin-name <> <pn>)
-    (ff ^net-name <nn> ^grid-x <gx2> ^grid-y { <gy2> < <gy> })
-  - (horizontal ^com { > <gy2> < <gy> })
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy> } ^com 1 ^layer <lay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (pin ^pin-x 0 ^pin-y <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min <= 1 ^max >= 1 ^com <gy2> ^layer <lay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com 1 ^layer <lay>)
-  -->
-    (make vertical ^layer <lay> ^min <vmin> ^max <gy2> ^min-net <mn> ^max-net <nn> ^com 1 ^commo <vcmo> ^compo <vcpo>)
-    (modify 4 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <lay> ^min <gy2> ^max <gy> ^com 1 ^commo <vcmo> ^compo <vcpo>)
-    (modify 2 ^grid-y <gy2> ^came-from north)
-)
-
-(p p253
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> >= <gy1> > <vmin> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> >= <gx2> > <hmin> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p254
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p255
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p256
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p257
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>)
-  - (pin ^net-name <nn1> ^pin-x >= <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p258
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy2> ^grid-x > <gx1>)
-  - (pin ^net-name <nn1> ^pin-x <= <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p259
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>)
-  - (pin ^net-name <nn1> ^pin-x >= <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p260
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-y <gy1> ^grid-x > <gx2>)
-  - (pin ^net-name <nn1> ^pin-x <= <gx2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p261
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>)
-  - (pin ^net-name <nn1> ^pin-y >= <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p262
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>)
-  - (pin ^net-name <nn1> ^pin-y >= <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p263
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y > <gy2>)
-  - (pin ^net-name <nn1> ^pin-y <= <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p264
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx2> ^grid-y > <gy1>)
-  - (pin ^net-name <nn1> ^pin-y <= <gy1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p265
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>)
-  - (pin ^net-name <nn1> ^pin-y >= <gy2>)
-    (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>)
-  - (pin ^net-name <nn2> ^pin-x >= <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p266
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y < <gy2>)
-  - (pin ^net-name <nn1> ^pin-y >= <gy2>)
-    (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy2> ^grid-x > <gx1>)
-  - (pin ^net-name <nn2> ^pin-x <= <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p267
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx1> ^grid-y > <gy2>)
-  - (pin ^net-name <nn1> ^pin-y <= <gy2>)
-    (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy2> ^grid-x < <gx1>)
-  - (pin ^net-name <nn2> ^pin-x >= <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p268
-    (context ^present lshape1)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-    (ff ^net-name { <nn1> <> <nn> } ^grid-x <gx2> ^grid-y > <gy1>)
-  - (pin ^net-name <nn1> ^pin-y <= <gy1>)
-    (ff ^net-name { <nn2> <> <nn> } ^grid-y <gy1> ^grid-x > <gx2>)
-  - (pin ^net-name <nn2> ^pin-x <= <gx2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p269
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p270
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p271
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p272
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p273
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p274
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p275
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p276
-    (context ^present lshape2)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p277
-    (context ^present lshape3)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p278
-    (context ^present lshape3)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p279
-    (context ^present lshape3)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <vlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <hlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p280
-    (context ^present lshape3)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <hlay> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <vlay>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p281
-    (context ^present lshape4)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <garb2>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p282
-    (context ^present lshape4)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <garb2>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx2> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p283
-    (context ^present lshape4)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> > <gy1> } ^grid-layer <garb2>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy1> } ^max { <vmax> > <vmin> >= <gy2> } ^com <gx1> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy2> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx1>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy2>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <vmin> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy2> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <vlay> ^min <gy1> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy2> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p284
-    (context ^present lshape4)
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <garb1> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <garb2>)
-    (vertical ^net-name nil ^min { <vmin> <= <gy2> } ^max { <vmax> > <vmin> >= <gy1> } ^com <gx2> ^layer <vlay> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn>)
-    (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com <gy1> ^layer <hlay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>)
-    (vertical-layer <vlay>)
-    (horizontal-layer <hlay>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^max <= <vmin> ^com <gx2>)
-  - (vertical ^status nil ^net-name { <> <nn> <> nil } ^min >= <vmax> ^com <gx2>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^max <= <hmin> ^com <gy1>)
-  - (horizontal ^status nil ^net-name { <> <nn> <> nil } ^min >= <hmax> ^com <gy1>)
-  -->
-    (remove 1 3 4)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <vmin> ^max <gy2> ^compo <vcpo> ^commo <vcmo> ^min-net <vnn> ^max-net <nn>)
-    (modify 5 ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <hmin> ^max <gx1> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify 6 ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <vlay> ^min <gy2> ^max <gy1> ^compo <vcpo> ^commo <vcmo> ^net-name <nn> ^pin-name <pn>)
-    (make horizontal ^com <gy1> ^layer <hlay> ^min <gx1> ^max <gx2> ^compo <hcpo> ^commo <hcmo> ^net-name <nn> ^pin-name <pn>)
-    (make context ^present check-for-routed-net)
-)
-
-(p p285
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-  - (ff ^grid-x <gx1> ^net-name <> <nn>)
-    { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy1> } ^max { <vmax1> > <vmin1> >= <gy1> } ^com <gx1> ^layer <lay> ^commo <gx2> ^compo <cpo> ^min-net <vnn1>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com { <hcom> >= <vmin1> < <gy1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (vertical-layer <lay>)
-    (ff ^grid-x <gx2> ^net-name <> <nn>)
-  - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com { >= <vmin1> < <hcom> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>)
-  -->
-    (remove <c>)
-    (make vertical ^com <gx1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <cpo> ^commo <gx2> ^min-net <vnn1> ^max-net <nn>)
-    (modify <v> ^min <gy1> ^min-net <nn>)
-    (make horizontal ^min <hmin> ^max <gx2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <lay> ^min <hcom> ^max <gy1> ^commo <gx2> ^compo <cpo> ^net-name <nn> ^pin-name <pn1>)
-    (make horizontal ^com <hcom> ^layer <lay> ^min <gx2> ^max <gx1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>)
-    (modify <ff> ^grid-x <gx2> ^grid-y <hcom> ^can-chng-layer nil ^came-from east)
-    (make context ^present check-for-routed-net)
-)
-
-(p p286
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-  - (ff ^grid-x <gx2> ^net-name <> <nn>)
-    { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy2> } ^max { <vmax1> > <vmin1> >= <gy2> } ^com <gx2> ^layer <lay> ^commo <cmo> ^compo <gx1> ^max-net <vnn1>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx2> } ^max { <hmax> > <hmin> >= <gx1> } ^com { <hcom> <= <vmax1> > <gy2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (vertical-layer <lay>)
-    (ff ^grid-x <gx1> ^net-name <> <nn>)
-  - (horizontal ^net-name nil ^min <= <gx2> ^max >= <gx1> ^com { <= <vmax1> > <hcom> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>)
-  -->
-    (remove <c>)
-    (make vertical ^com <gx2> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <gx1> ^commo <cmo> ^max-net <vnn1> ^min-net <nn>)
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make horizontal ^min <hmin> ^max <gx2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gx1> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <lay> ^max <hcom> ^min <gy2> ^commo <cmo> ^compo <gx1> ^net-name <nn> ^pin-name <pn2>)
-    (make horizontal ^com <hcom> ^layer <lay> ^min <gx2> ^max <gx1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>)
-    (modify <ff> ^grid-x <gx1> ^grid-y <hcom> ^can-chng-layer nil ^came-from west)
-    (make context ^present check-for-routed-net)
-)
-
-(p p287
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-  - (ff ^grid-x <gx1> ^net-name <> <nn>)
-    { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy1> } ^max { <vmax1> > <vmin1> >= <gy1> } ^com <gx1> ^layer <lay> ^commo <cmo> ^compo <gx2> ^min-net <vnn1>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com { <hcom> >= <vmin1> < <gy1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (vertical-layer <lay>)
-    (ff ^grid-x <gx2> ^net-name <> <nn>)
-  - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com { >= <vmin1> < <hcom> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>)
-  -->
-    (remove <c>)
-    (make vertical ^com <gx1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <gx2> ^commo <cmo> ^min-net <vnn1> ^max-net <nn>)
-    (modify <v> ^min <gy1> ^min-net <nn>)
-    (make horizontal ^min <hmin> ^max <gx1> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx1> ^layer <lay> ^min <hcom> ^max <gy1> ^commo <cmo> ^compo <gx2> ^net-name <nn> ^pin-name <pn1>)
-    (make horizontal ^com <hcom> ^layer <lay> ^min <gx1> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>)
-    (modify <ff> ^grid-x <gx2> ^grid-y <hcom> ^can-chng-layer nil ^came-from west)
-    (make context ^present check-for-routed-net)
-)
-
-(p p288
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-  - (ff ^grid-x <gx2> ^net-name <> <nn>)
-    { <v> (vertical ^net-name nil ^min { <vmin1> <= <gy2> } ^max { <vmax1> > <vmin1> >= <gy2> } ^com <gx2> ^layer <lay> ^commo <gx1> ^compo <cpo> ^max-net <vnn1>) }
-    { <h> (horizontal ^net-name nil ^min { <hmin> <= <gx1> } ^max { <hmax> > <hmin> >= <gx2> } ^com { <hcom> <= <vmax1> > <gy2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (vertical-layer <lay>)
-    (ff ^grid-x <gx1> ^net-name <> <nn>)
-  - (horizontal ^net-name nil ^min <= <gx1> ^max >= <gx2> ^com { <= <vmax1> > <hcom> } ^layer <lay>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx2> ^max >= <gx2> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx2>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <gx1> ^max >= <gx1> ^com <hcom>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gx1>)
-  -->
-    (remove <c>)
-    (make vertical ^com <gx2> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <cpo> ^commo <gx1> ^max-net <vnn1> ^min-net <nn>)
-    (modify <v> ^max <gy2> ^max-net <nn>)
-    (make horizontal ^min <hmin> ^max <gx1> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gx2> ^min-net <nn>)
-    (make vertical ^com <gx2> ^layer <lay> ^max <hcom> ^min <gy2> ^commo <gx1> ^compo <cpo> ^net-name <nn> ^pin-name <pn2>)
-    (make horizontal ^com <hcom> ^layer <lay> ^min <gx1> ^max <gx2> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>)
-    (modify <ff> ^grid-x <gx1> ^grid-y <hcom> ^can-chng-layer nil ^came-from east)
-    (make context ^present check-for-routed-net)
-)
-
-(p p289
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-  - (ff ^grid-y <gy1> ^net-name <> <nn>)
-    { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx1> } ^max { <vmax1> > <vmin1> >= <gx1> } ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^min-net <vnn1>) }
-    { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> >= <vmin1> < <gx1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (horizontal-layer <lay>)
-    (ff ^grid-y <gy2> ^net-name <> <nn>)
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { >= <vmin1> < <hcom> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>)
-  -->
-    (remove <c>)
-    (make horizontal ^com <gy1> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <cpo> ^commo <gy2> ^min-net <vnn1> ^max-net <nn>)
-    (modify <v> ^min <gx1> ^min-net <nn>)
-    (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <lay> ^min <hcom> ^max <gx1> ^commo <gy2> ^compo <cpo> ^net-name <nn> ^pin-name <pn1>)
-    (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>)
-    (modify <ff> ^grid-y <gy2> ^grid-x <hcom> ^can-chng-layer nil ^came-from north)
-    (make context ^present check-for-routed-net)
-)
-
-(p p290
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> < <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-  - (ff ^grid-y <gy2> ^net-name <> <nn>)
-    { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx2> } ^max { <vmax1> > <vmin1> >= <gx2> } ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gy1> ^max-net <vnn1>) }
-    { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> <= <vmax1> > <gx2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (horizontal-layer <lay>)
-    (ff ^grid-y <gy1> ^net-name <> <nn>)
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { <= <vmax1> > <hcom> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>)
-  -->
-    (remove <c>)
-    (make horizontal ^com <gy2> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <gy1> ^commo <cmo> ^max-net <vnn1> ^min-net <nn>)
-    (modify <v> ^max <gx2> ^max-net <nn>)
-    (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <lay> ^max <hcom> ^min <gx2> ^commo <cmo> ^compo <gy1> ^net-name <nn> ^pin-name <pn2>)
-    (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>)
-    (modify <ff> ^grid-y <gy1> ^grid-x <hcom> ^can-chng-layer nil ^came-from south)
-    (make context ^present check-for-routed-net)
-)
-
-(p p291
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    { <ff> (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>) }
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>)
-  - (ff ^grid-y <gy1> ^net-name <> <nn>)
-    { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx1> } ^max { <vmax1> > <vmin1> >= <gx1> } ^com <gy1> ^layer <lay> ^commo <gy2> ^compo <cpo> ^max-net <vnn1>) }
-    { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> <= <vmax1> > <gx1> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (horizontal-layer <lay>)
-    (ff ^grid-y <gy2> ^net-name <> <nn>)
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { <= <vmax1> > <hcom> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>)
-  -->
-    (remove <c>)
-    (make horizontal ^com <gy1> ^layer <lay> ^min <hcom> ^max <vmax1> ^compo <cpo> ^commo <gy2> ^max-net <vnn1> ^min-net <nn>)
-    (modify <v> ^max <gx1> ^max-net <nn>)
-    (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy1> ^layer <lay> ^min <gx1> ^max <hcom> ^commo <gy2> ^compo <cpo> ^net-name <nn> ^pin-name <pn1>)
-    (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn1>)
-    (modify <ff> ^grid-y <gy2> ^grid-x <hcom> ^can-chng-layer nil ^came-from north)
-    (make context ^present check-for-routed-net)
-)
-
-(p p292
-    { <c> (context ^present lshape1) }
-    (net ^net-name <nn> ^net-no-of-pins 2 ^net-is-routed <> yes)
-    (ff ^net-name <nn> ^grid-x <gx1> ^grid-y <gy1> ^grid-layer <lay> ^pin-name <pn1>)
-    { <ff> (ff ^net-name <nn> ^grid-x { <gx2> > <gx1> } ^grid-y { <gy2> < <gy1> } ^grid-layer <lay> ^pin-name <pn2>) }
-  - (ff ^grid-y <gy2> ^net-name <> <nn>)
-    { <v> (horizontal ^net-name nil ^min { <vmin1> <= <gx2> } ^max { <vmax1> > <vmin1> >= <gx2> } ^com <gy2> ^layer <lay> ^commo <cmo> ^compo <gy1> ^min-net <vnn1>) }
-    { <h> (vertical ^net-name nil ^min { <hmin> <= <gy2> } ^max { <hmax> > <hmin> >= <gy1> } ^com { <hcom> >= <vmin1> < <gx2> } ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn>) }
-    (horizontal-layer <lay>)
-    (ff ^grid-y <gy1> ^net-name <> <nn>)
-  - (vertical ^net-name nil ^min <= <gy2> ^max >= <gy1> ^com { >= <vmin1> < <hcom> } ^layer <lay>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy2> ^max >= <gy2> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy2>)
-  - (vertical ^net-name { <> <nn> <> nil } ^min <= <gy1> ^max >= <gy1> ^com <hcom>)
-  - (horizontal ^net-name { <> <nn> <> nil } ^min <= <hcom> ^max >= <hcom> ^com <gy1>)
-  -->
-    (remove <c>)
-    (make horizontal ^com <gy2> ^layer <lay> ^min <vmin1> ^max <hcom> ^compo <gy1> ^commo <cmo> ^min-net <vnn1> ^max-net <nn>)
-    (modify <v> ^min <gx2> ^min-net <nn>)
-    (make vertical ^min <hmin> ^max <gy2> ^com <hcom> ^layer <lay> ^compo <hcpo> ^commo <hcmo> ^min-net <hnn> ^max-net <nn>)
-    (modify <h> ^min <gy1> ^min-net <nn>)
-    (make horizontal ^com <gy2> ^layer <lay> ^max <gx2> ^min <hcom> ^commo <cmo> ^compo <gy1> ^net-name <nn> ^pin-name <pn2>)
-    (make vertical ^com <hcom> ^layer <lay> ^min <gy2> ^max <gy1> ^commo <hcmo> ^compo <hcpo> ^net-name <nn> ^pin-name <pn2>)
-    (modify <ff> ^grid-y <gy1> ^grid-x <hcom> ^can-chng-layer nil ^came-from south)
-    (make context ^present check-for-routed-net)
-)
-
-(p p211
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> west ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx> })
-    (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> >= <gx> > <min> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x >= <gx> ^grid-y < <gy>)
-  - (ff ^net-name <nn> ^grid-x >= <gx> ^grid-y > <gy>)
-  -->
-    (make horizontal ^min <min> ^max (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min <gx> ^min-net <nn>)
-    (make horizontal ^max <gx> ^min (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-x (compute <gx> - 1) ^came-from east ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p212
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> south ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-y { <gy2> < <gy> })
-    (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x < <gx> ^grid-y >= <gy>)
-  - (ff ^net-name <nn> ^grid-x > <gx> ^grid-y >= <gy>)
-  -->
-    (make vertical ^min <min> ^max (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min <gy> ^min-net <nn>)
-    (make vertical ^max <gy> ^min (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-y (compute <gy> - 1) ^came-from north ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p213
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> east ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx> })
-    (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { <max> > <min> >= <gx2> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <= <gx> ^grid-y < <gy>)
-  - (ff ^net-name <nn> ^grid-x <= <gx> ^grid-y > <gy>)
-  -->
-    (make horizontal ^max <max> ^min (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max <gx> ^max-net <nn>)
-    (make horizontal ^min <gx> ^max (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-x (compute <gx> + 1) ^came-from west ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p214
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <gy> })
-    (vertical ^net-name nil ^min { <min> <= <gy> } ^max { <max> > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x < <gx> ^grid-y <= <gy>)
-  - (ff ^net-name <nn> ^grid-x > <gx> ^grid-y <= <gy>)
-  -->
-    (make vertical ^max <max> ^min (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max <gy> ^max-net <nn>)
-    (make vertical ^min <gy> ^max (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-y (compute <gy> + 1) ^came-from south ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p215
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> west ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y <= <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> > <min> >= <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  -->
-    (make horizontal ^min <min> ^max (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min <gx> ^min-net <nn>)
-    (make horizontal ^max <gx> ^min (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-x (compute <gx> - 1) ^came-from east ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p216
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> west ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <gx> } ^grid-y >= <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx2> } ^max { <max> > <min> >= <gx> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <gx> ^max >= <gx>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  -->
-    (make horizontal ^min <min> ^max (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min <gx> ^min-net <nn>)
-    (make horizontal ^max <gx> ^min (compute <gx> - 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-x (compute <gx> - 1) ^came-from east ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p217
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> east ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y <= <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { <max> > <min> >= <gx2> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx>)
-  - (vertical ^net-name nil ^min < <gy> ^max >= <gy> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  -->
-    (make horizontal ^max <max> ^min (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max <gx> ^max-net <nn>)
-    (make horizontal ^min <gx> ^max (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-x (compute <gx> + 1) ^came-from west ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p218
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> east ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <gx> } ^grid-y >= <gy>)
-    (horizontal ^net-name nil ^min { <min> <= <gx> } ^max { <max> > <min> >= <gx2> } ^com <gy> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max > <gx>)
-  - (vertical ^net-name nil ^min <= <gy> ^max > <gy> ^com <gx> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  -->
-    (make horizontal ^max <max> ^min (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max <gx> ^max-net <nn>)
-    (make horizontal ^min <gx> ^max (compute <gx> + 1) ^com <gy> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-x (compute <gx> + 1) ^came-from west ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p219
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^grid-x >= <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy> } ^max { <max> > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x < <gx>)
-  -->
-    (make vertical ^max <max> ^min (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>)
-    (modify 4 ^max <gy> ^max-net <nn>)
-    (make vertical ^min <gy> ^max (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-y (compute <gy> + 1) ^came-from south ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p220
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <gy> } ^grid-x <= <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy> } ^max { <max> > <min> >= <gy2> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x > <gx>)
-  -->
-    (make vertical ^max <max> ^min (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>)
-    (modify 4 ^max <gy> ^max-net <nn>)
-    (make vertical ^min <gy> ^max (compute <gy> + 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-y (compute <gy> + 1) ^came-from south ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p221
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> south ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^grid-x <= <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy>)
-  - (horizontal ^net-name nil ^min < <gx> ^max >= <gx> ^com <gy> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x > <gx>)
-  -->
-    (make vertical ^min <min> ^max (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>)
-    (modify 4 ^min <gy> ^min-net <nn>)
-    (make vertical ^max <gy> ^min (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-y (compute <gy> - 1) ^came-from north ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p222
-    (context ^present loose-constraint)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from <> north ^can-chng-layer no)
-    (ff ^net-name <nn> ^grid-y { <gy2> < <gy> } ^grid-x >= <gx>)
-    (vertical ^net-name nil ^min { <min> <= <gy2> } ^max { <max> > <min> >= <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <vnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max > <gx> ^com <gy> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x < <gx>)
-  -->
-    (make vertical ^min <min> ^max (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^max-net <vnn> ^min-net <nn>)
-    (modify 4 ^min <gy> ^min-net <nn>)
-    (make vertical ^max <gy> ^min (compute <gy> - 1) ^com <gx> ^layer <lay> ^commo <cmo> ^compo <cpo> ^net-name <nn> ^pin-name <pn>)
-    (modify 2 ^grid-y (compute <gy> - 1) ^came-from north ^can-chng-layer nil)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p223
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  -->
-    (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p224
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <com1> } ^grid-x <gx>)
-    (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  -->
-    (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p225
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  -->
-    (make horizontal ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p226
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-y { <gy2> < <com1> } ^grid-x <gx>)
-    (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  -->
-    (make vertical ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p227
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  -->
-    (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p228
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-y { <gy2> > <com1> } ^grid-x <gx>)
-    (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  -->
-    (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p229
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  -->
-    (make horizontal ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p230
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> < <com1> })
-    (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^max-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^layer <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  -->
-    (make vertical ^max <max2> ^min <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^max-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p231
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (vertical ^net-name nil ^max <min1> ^com <com1>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p232
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> > <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gx2> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (vertical ^net-name nil ^max <min1> ^com <com1>)
-  - (horizontal ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make horizontal ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make horizontal ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> + 1) ^grid-y <com2> ^grid-layer <lay> ^came-from west)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p233
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (vertical ^net-name nil ^max <min1> ^com <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make horizontal ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p234
-    (context ^present loose-constraint)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x { <gx2> < <com1> } ^grid-y <gy>)
-    (horizontal ^net-name nil ^min { <min2> <= <gx2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gy> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (vertical ^net-name nil ^max <min1> ^com <com1>)
-  - (horizontal ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-x <com1>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make horizontal ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make horizontal ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-x (compute <com1> - 1) ^grid-y <com2> ^grid-layer <lay> ^came-from east)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p235
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> > <com1> })
-    (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^max <min1> ^com <com1>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p236
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> > <com1> })
-    (vertical ^net-name nil ^min { <min2> <= <com1> } ^max { <max2> > <min2> >= <gy2> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <com1> ^max > <com1>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^max <min1> ^com <com1>)
-  - (vertical ^net-name nil ^min <= <com1> ^max > <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make vertical ^min <min2> ^max <com1> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^max-net <nn>)
-    (modify 4 ^min (compute <com1> + 1) ^min-net <nn>)
-    (make vertical ^min <com1> ^max (compute <com1> + 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> + 1) ^grid-x <com2> ^grid-layer <lay> ^came-from south)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p237
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> < <com1> })
-    (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> >= <gx> } ^layer <lay> ^compo <cpo2> ^commo <cmo2> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { < <com2> >= <min1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^max <min1> ^com <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make vertical ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p238
-    (context ^present loose-constraint)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <min1> ^max <max1> ^com <com1> ^layer <lay> ^compo <garb1> ^commo <garb2> ^pin-name <pn>)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y { <gy2> < <com1> })
-    (vertical ^net-name nil ^min { <min2> <= <gy2> } ^max { <max2> > <min2> >= <com1> } ^com { <com2> >= <min1> <= <max1> <= <gx> } ^layer <lay> ^commo <cmo2> ^compo <cpo2> ^min-net <hnn>)
-  - (vertical ^status nil ^net-name { <nn> <> nil } ^min < <com1> ^max >= <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com { > <com2> <= <max1> } ^layer <lay>)
-  - (horizontal ^net-name nil ^max <min1> ^com <com1>)
-  - (vertical ^net-name nil ^min < <com1> ^max >= <com1> ^com <com2> ^layer <> <lay>)
-  - (ff ^net-name <nn> ^grid-y <com1>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^max <min1> ^com <com1> ^layer <lay>)
-  -->
-    (make vertical ^min <com1> ^max <max2> ^commo <cmo2> ^compo <cpo2> ^layer <lay> ^com <com2> ^min-net <hnn> ^min-net <nn>)
-    (modify 4 ^max (compute <com1> - 1) ^max-net <nn>)
-    (make vertical ^max <com1> ^min (compute <com1> - 1) ^com <com2> ^layer <lay> ^net-name <nn> ^pin-name <pn> ^commo <cmo2> ^compo <cpo2>)
-    (make ff ^net-name <nn> ^pin-name <pn> ^grid-y (compute <com1> - 1) ^grid-x <com2> ^grid-layer <lay> ^came-from north)
-    (remove 1)
-    (make context ^present propagate-constraint)
-)
-
-(p p239
-    (context ^present loose-constraint0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top)
-    (vertical ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy> ^com { <vcom> > <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom> ^com <gy>)
-    (vertical ^net-name nil ^min { <min> < <gy> } ^max >= <gy> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>)
-  - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>)
-    (congestion ^direction row ^coordinate <gy> ^como <hcmo>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <hcmo> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify 2 ^grid-y <hcmo> ^can-chng-layer nil)
-    (modify 1 ^present propagate-constraint)
-)
-
-(p p240
-    (context ^present loose-constraint0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from north)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side top)
-    (vertical ^net-name { <nn> <> nil } ^min < <gy> ^max >= <gy> ^com { <vcom> < <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-y > <gy>)
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom> ^max >= <gx> ^com <gy>)
-    (vertical ^net-name nil ^min { <min> < <gy> } ^max >= <gy> ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^min-net <mn>)
-  - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>)
-    (congestion ^direction row ^coordinate <gy> ^como <hcmo>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <hcmo> ^min <min> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^min-net <mn> ^max-net <nn>)
-    (modify 5 ^min <gy> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^max <gy> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify 2 ^grid-y <hcmo> ^can-chng-layer nil)
-    (modify 1 ^present propagate-constraint)
-)
-
-(p p241
-    (context ^present loose-constraint0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from south)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom)
-    (vertical ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy> ^com { <vcom> > <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  - (horizontal ^net-name nil ^min <= <gx> ^max >= <vcom> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <gx> ^max >= <vcom> ^com <gy>)
-    (vertical ^net-name nil ^min <= <gy> ^max { <max> > <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>)
-  - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>)
-    (congestion ^direction row ^coordinate <hcmo> ^como <gy>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <max> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^max-net <mn> ^min-net <nn>)
-    (modify 5 ^max <gy> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^min <gy> ^max <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify 2 ^grid-y <hcmo> ^can-chng-layer nil)
-    (modify 1 ^present propagate-constraint)
-)
-
-(p p242
-    (context ^present loose-constraint0)
-    (ff ^net-name <nn> ^grid-x <gx> ^grid-y <gy> ^grid-layer <lay> ^pin-name <pn> ^came-from south)
-    (pin ^net-name <nn> ^pin-name <pn> ^pin-channel-side bottom)
-    (vertical ^net-name { <nn> <> nil } ^min <= <gy> ^max > <gy> ^com { <vcom> < <gx> } ^layer <garb1> ^compo <garb2> ^commo <garb3> ^pin-name <> <pn>)
-  - (ff ^net-name <nn> ^grid-y < <gy>)
-  - (horizontal ^net-name nil ^min <= <vcom> ^max >= <gx> ^com <gy>)
-  - (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcom> ^max >= <gx> ^com <gy>)
-    (vertical ^net-name nil ^min <= <gy> ^max { <max> > <gy> } ^com <gx> ^layer <lay> ^compo <cpo> ^commo <cmo> ^max-net <mn>)
-  - (horizontal ^net-name { <> nil <> <nn> } ^min <= <gx> ^max >= <gx> ^layer <lay> ^compo <gy>)
-    (congestion ^direction row ^coordinate <hcmo> ^como <gy>)
-  - (vertical ^status nil ^net-name { <> nil <> <nn> } ^min <= <hcmo> ^max >= <hcmo> ^com <gx> ^layer <lay>)
-  -->
-    (make vertical ^net-name nil ^max <max> ^min <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^max-net <mn> ^min-net <nn>)
-    (modify 5 ^max <gy> ^max-net <nn>)
-    (make vertical ^net-name <nn> ^min <gy> ^max <hcmo> ^layer <lay> ^com <gx> ^commo <cmo> ^compo <cpo> ^pin-name <pn>)
-    (modify 2 ^grid-y <hcmo> ^can-chng-layer nil)
-    (modify 1 ^present propagate-constraint)
-)
-
-(p p243
-    (context ^present loose-constraint0)
-  -->
-    (modify 1 ^present loose-constraint)
-)
-
-(p p363
-    (move-via <nn>)
-  -->
-    (remove 1)
-    (make finally-routed <nn>)
-)
-
-(p p364
-    (move-via <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <garb1> ^commo <hcmo> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcmo> ^max <hcom> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> })
-    (vertical ^net-name nil ^min { <vmin2> <= <hcmo> } ^max { <vmax2> > <vmin2> >= <hcom> } ^com <vcom> ^layer <hlay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (horizontal ^net-name <> <nn> ^min < <vcom> ^max >= <vcom> ^com <hcmo>)
-  - (vertical ^net-name <> <nn> ^min < <hcmo> ^max <hcmo> ^com <vcom>)
-  -->
-    (modify 3 ^max <hcmo>)
-    (make vertical ^layer <vlay> ^max <hcom> ^min <hcmo> ^com <vcom> ^min-net <nn> ^commo <vcmo> ^compo <vcpo>)
-    (make vertical ^layer <hlay> ^min <vmin2> ^max <hcmo> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>)
-    (modify 4 ^min <hcom> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcmo> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^com <vcom>)
-    (remove 1)
-    (make move-via <nn> <vlay> <vcom> <hcom>)
-)
-
-(p p365
-    (move-via <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <garb1> ^commo <hcmo> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <= <hcmo> ^max <hcom> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> })
-    (vertical ^net-name nil ^min { <vmin2> <= <hcmo> } ^max { <vmax2> > <vmin2> >= <hcom> } ^com <vcom> ^layer <hlay> ^compo <vcpo> ^commo <vcmo> ^min-net <mn>)
-  - (horizontal ^net-name <> <nn> ^min <= <vcom> ^max > <vcom> ^com <hcmo>)
-  - (vertical ^net-name <> <nn> ^min < <hcmo> ^max <hcmo> ^com <vcom>)
-  -->
-    (modify 3 ^max <hcmo>)
-    (make vertical ^layer <vlay> ^max <hcom> ^min <hcmo> ^com <vcom> ^min-net <nn> ^commo <vcmo> ^compo <vcpo>)
-    (make vertical ^layer <hlay> ^min <vmin2> ^max <hcmo> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>)
-    (modify 4 ^min <hcom> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcmo> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^com <vcom>)
-    (remove 1)
-    (make move-via <nn> <vlay> <vcom> <hcom>)
-)
-
-(p p366
-    (move-via <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <garb1> ^commo <vcmo> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcmo> ^max <vcom> ^com { <hcom> >= <vmin> <= <vmax> } ^layer { <hlay> <> <vlay> })
-    (horizontal ^net-name nil ^min { <hmin2> <= <vcmo> } ^max { <hmax2> > <hmin2> >= <vcom> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (vertical ^net-name <> <nn> ^min < <hcom> ^max >= <hcom> ^com <vcmo>)
-  - (horizontal ^net-name <> <nn> ^min < <vcmo> ^max <vcmo> ^com <hcom>)
-  -->
-    (modify 3 ^max <vcmo>)
-    (make horizontal ^layer <hlay> ^max <vcom> ^min <vcmo> ^com <hcom> ^min-net <nn> ^commo <hcmo> ^compo <hcpo>)
-    (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcmo> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>)
-    (modify 4 ^min <vcom> ^min-net <nn>)
-    (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcmo> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^com <hcom>)
-    (remove 1)
-    (make move-via <nn> <hlay> <hcom> <vcom>)
-)
-
-(p p367
-    (move-via <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <garb1> ^commo <vcmo> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <= <vcmo> ^com { <hcom> >= <vmin> <= <vmax> } ^max <vcom> ^layer { <hlay> <> <vlay> })
-    (horizontal ^net-name nil ^min { <hmin2> <= <vcmo> } ^max { <hmax2> > <hmin2> >= <vcom> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (vertical ^net-name <> <nn> ^min <= <hcom> ^max > <hcom> ^com <vcmo>)
-  - (horizontal ^net-name <> <nn> ^min < <vcmo> ^max <vcmo> ^com <hcom>)
-  -->
-    (modify 3 ^max <vcmo>)
-    (make horizontal ^layer <hlay> ^max <vcom> ^min <vcmo> ^com <hcom> ^min-net <nn> ^commo <hcmo> ^compo <hcpo>)
-    (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcmo> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>)
-    (modify 4 ^min <vcom> ^min-net <nn>)
-    (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcmo> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^com <hcom>)
-    (remove 1)
-    (make move-via <nn> <hlay> <hcom> <vcom>)
-)
-
-(p p368
-    (move-via <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <hcpo> ^commo <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max >= <hcpo> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> })
-    (vertical ^net-name nil ^min { <vmin2> <= <hcom> } ^max { <vmax2> > <vmin2> >= <hcpo> } ^com <vcom> ^layer <hlay> ^commo <vcmo> ^compo <vcpo> ^min-net <mn>)
-  - (horizontal ^net-name <> <nn> ^min < <vcom> ^max >= <vcom> ^com <hcpo>)
-  - (vertical ^net-name <> <nn> ^min <hcpo> ^max > <hcpo> ^com <vcom>)
-  -->
-    (modify 3 ^min <hcpo>)
-    (make vertical ^layer <vlay> ^min <hcom> ^max <hcpo> ^com <vcom> ^max-net <nn> ^commo <vcmo> ^compo <vcpo>)
-    (make vertical ^layer <hlay> ^min <vmin2> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>)
-    (modify 4 ^min <hcpo> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcom> ^max <hcpo> ^commo <vcmo> ^compo <vcpo> ^com <vcom>)
-    (remove 1)
-    (make move-via <nn> <vlay> <vcom> <hcom>)
-)
-
-(p p369
-    (move-via <nn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <hmin> ^max <hmax> ^com <hcom> ^layer <hlay> ^compo <hcpo> ^commo <garb1> ^pin-name <pn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <hcom> ^max >= <hcpo> ^com { <vcom> >= <hmin> <= <hmax> } ^layer { <vlay> <> <hlay> })
-    (vertical ^net-name nil ^min { <vmin2> <= <hcom> } ^max { <vmax2> > <vmin2> >= <hcpo> } ^com <vcom> ^layer <hlay> ^commo <vcmo> ^compo <vcpo> ^min-net <mn>)
-  - (horizontal ^net-name <> <nn> ^min <= <vcom> ^max > <vcom> ^com <hcpo>)
-  - (vertical ^net-name <> <nn> ^min <hcpo> ^max > <hcpo> ^com <vcom>)
-  -->
-    (modify 3 ^min <hcpo>)
-    (make vertical ^layer <vlay> ^min <hcom> ^max <hcpo> ^com <vcom> ^max-net <nn> ^commo <vcmo> ^compo <vcpo>)
-    (make vertical ^layer <hlay> ^min <vmin2> ^max <hcom> ^commo <vcmo> ^compo <vcpo> ^min-net <mn> ^max-net <nn> ^com <vcom>)
-    (modify 4 ^min <hcpo> ^min-net <nn>)
-    (make vertical ^net-name <nn> ^pin-name <pn> ^layer <hlay> ^min <hcom> ^max <hcpo> ^commo <vcmo> ^compo <vcpo> ^com <vcom>)
-    (remove 1)
-    (make move-via <nn> <vlay> <vcom> <hcom>)
-)
-
-(p p370
-    (move-via <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <vcpo> ^commo <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max >= <vcpo> ^com { <hcom> >= <vmin> <= <vmax> } ^layer { <hlay> <> <vlay> })
-    (horizontal ^net-name nil ^min { <hmin2> <= <vcom> } ^max { <hmax2> > <hmin2> >= <vcpo> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (vertical ^net-name <> <nn> ^min < <hcom> ^max >= <hcom> ^com <vcpo>)
-  - (horizontal ^net-name <> <nn> ^min <vcpo> ^max > <vcpo> ^com <hcom>)
-  -->
-    (modify 3 ^min <vcpo>)
-    (make horizontal ^layer <hlay> ^max <vcpo> ^min <vcom> ^com <hcom> ^max-net <nn> ^commo <hcmo> ^compo <hcpo>)
-    (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>)
-    (modify 4 ^min <vcpo> ^min-net <nn>)
-    (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcom> ^max <vcpo> ^commo <hcmo> ^compo <hcpo> ^com <hcom>)
-    (remove 1)
-    (make move-via <nn> <hlay> <hcom> <vcom>)
-)
-
-(p p371
-    (move-via <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin> ^max <vmax> ^com <vcom> ^layer <vlay> ^compo <vcpo> ^commo <garb1> ^pin-name <pn>)
-    (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom> ^max >= <vcpo> ^com { <hcom> >= <vmin> <= <vmax> } ^layer { <hlay> <> <vlay> })
-    (horizontal ^net-name nil ^min { <hmin2> <= <vcom> } ^max { <hmax2> > <hmin2> >= <vcpo> } ^com <hcom> ^layer <vlay> ^compo <hcpo> ^commo <hcmo> ^min-net <mn>)
-  - (vertical ^net-name <> <nn> ^min <= <hcom> ^max > <hcom> ^com <vcmo>)
-  - (horizontal ^net-name <> <nn> ^min <vcpo> ^max > <vcpo> ^com <hcom>)
-  -->
-    (modify 3 ^min <vcpo>)
-    (make horizontal ^layer <hlay> ^max <vcpo> ^min <vcom> ^com <hcom> ^max-net <nn> ^commo <hcmo> ^compo <hcpo>)
-    (make horizontal ^layer <vlay> ^min <hmin2> ^max <vcom> ^commo <hcmo> ^compo <hcpo> ^min-net <mn> ^max-net <nn> ^com <hcom>)
-    (modify 4 ^min <vcpo> ^min-net <nn>)
-    (make horizotnal ^net-name <nn> ^pin-name <pn> ^layer <vlay> ^min <vcom> ^max <vcpo> ^commo <hcmo> ^compo <hcpo> ^com <hcom>)
-    (remove 1)
-    (make move-via <nn> <hlay> <hcom> <vcom>)
-)
-
-(p p372
-    (move-via <nn>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmin1> ^max <vmax1> ^com <vcom1> ^layer <vlay> ^compo <vcpo1> ^commo <vcmo1> ^pin-name <pn1>)
-    (vertical ^status nil ^net-name { <nn> <> nil } ^min <vmax1> ^max <vmax2> ^com { <vcom2> > <vcom1> } ^layer <vlay> ^compo <vcpo2> ^commo <vcmo2> ^pin-name <pn2>)
-    { <h1> (horizontal ^status nil ^net-name { <nn> <> nil } ^min <vcom1> ^max <vcom2> ^com <vmax1> ^layer { <hlay> <> <vlay> }) }
-    { <h2> (horizontal ^status nil ^net-name nil ^min { <fmin> <= <vcom1> } ^max { <fmax> >= <vcom2> } ^com <vmax1> ^layer <vlay>) }
-  - (vertical ^min < <vmax1> ^max >= <vmax1> ^com { > <vcom1> < <vcom2> })
-  -->
-    (remove <h2>)
-    (modify <h1> ^net-name nil ^pin-name nil ^min-net nil ^max-net nil)
-    (make (substr <h2> 1 inf) ^max <vcmo1> ^max-net nil)
-    (make (substr <h2> 1 inf) ^min <vcpo2> ^min-net nil)
-    (make (substr <h1> 1 inf) ^layer <vlay>)
-)
-
-(p p373
-    (move-via <nn> <lay> <x> <y>)
-    (horizontal ^min <x> ^max <garb1> ^com <y> ^layer <lay> ^min-net <nn> ^max-net <garb2>)
-  -->
-    (modify 2 ^min-net nil)
-)
-
-(p p374
-    (move-via <nn> <lay> <x> <y>)
-    (vertical ^min <y> ^max <garb1> ^com <x> ^layer <lay> ^min-net <nn> ^max-net <garb2>)
-  -->
-    (modify 2 ^min-net nil)
-)
-
-(p p375
-    (move-via <nn> <lay> <x> <y>)
-    (horizontal ^min <garb1> ^max <x> ^com <y> ^layer <lay> ^min-net <garb2> ^max-net <nn>)
-  -->
-    (modify 2 ^max-net nil)
-)
-
-(p p376
-    (move-via <nn> <lay> <x> <y>)
-    (vertical ^min <garb1> ^max <y> ^com <x> ^layer <lay> ^min-net <garb2> ^max-net <nn>)
-  -->
-    (modify 2 ^max-net nil)
-)
-
-(p start-dummy
-    (start)
-  -->
-    (write (crlf) | Dummy START, do "loadwm" from "kuh.tmp".| (crlf))
-)
-
-
diff --git a/contrib/psgraph/psgraph.catalog b/contrib/psgraph/psgraph.catalog
deleted file mode 100644
index 2703a4a8757bbb9b3dc3d91bfadab1e25c3e40d4..0000000000000000000000000000000000000000
--- a/contrib/psgraph/psgraph.catalog
+++ /dev/null
@@ -1,61 +0,0 @@
-Name:
-   PSgrapher
-
-Description:
-   The PSgrapher is a set of Lisp routines that can be called to produce
-Postscript commands that display a directed acyclic graph.
-
-Author:
-   Joseph Bates.  Skef put the whole thing in the PSGRPAPH package and added
-functionality which allows the user to specify EQ, EQUAL, or EQUALP as the
-node equivalence function.  Bill made all exported symbols have stars on them.
-
-Address:
-   Carnegie-Mellon University
-   Computer Science Department
-   Pittsburgh, PA 15213
-
-Net Address:
-   Joseph.Bates@CS.CMU.EDU
-
-Copyright Status:
-   Public Domain.
-
-Files:
-   psgraph.lisp, psgraph.fasl, psgraph.doc, psgraph.log, psgraph.catalog
-
-How to Get:
-   The following unix command will copy the pertinent files into directory
-<spec>.
-   cp /afs/cs.cmu.edu/project/clisp/library/psgraph/* <spec>
-
-Portability:
-   Should run in any legal Common Lisp.  Requires Postscript for printing.
-
-Instructions:
-   See psgraph.doc.
-
-Bugs:
-   This code blindly outputs what the user gives it as node labels.  It should
-run through the output escaping any PS control characters.  For example, if
-node labels contain parentheses, your output PS file will not print.
-
-Examples:
-   Skef Wholey submitted this as a reasonable example:
-
-;;; I use this in my compiler so I can look at code trees without
-;;; crawling around them in the inspector.  The postsript previewer
-;;; groks the generated ps file, which is bitchin' marvy.
-
-   (defun code-graph-to-file (s file &optional shrink insert)
-     (let ((psgraph:*fontname* "Times-Roman")
-	   (psgraph:*fontsize* 8)
-	   (psgraph:*second-fontname* "Times-BoldItalic")
-	   (psgraph:*second-fontsize* 6)
-	   (psgraph:*boxgray* "0")
-	   (psgraph:*edgegray* "0")
-	   (psgraph:*extra-x-spacing* 30))
-       (with-open-file (*standard-output* file
-					  :direction :output
-					  :if-exists :supersede)
-	 (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq))))
diff --git a/contrib/psgraph/psgraph.doc b/contrib/psgraph/psgraph.doc
deleted file mode 100644
index e7b17692d06d8a4714eb3ee0a3268ef9b1cff85d..0000000000000000000000000000000000000000
--- a/contrib/psgraph/psgraph.doc
+++ /dev/null
@@ -1,125 +0,0 @@
-Here is a brief summary of how to use the PSgrapher.
-
-The PSgrapher is a set of Lisp routines that can be called to produce
-Postscript commands to display a directed acyclic graph.  It uses the same
-basic algorithm as the ISI Grapher.  It is slower than the ISI grapher, but
-produces much prettier output than using Xdump to copy an ISI Grapher screen
-image to a Postscript printer.  It also allows arbitrary information to be
-displayed with a node, and can print as many output pages as are necessary to
-accomodate large graphs (subject to Postscript printer limits, typically one or
-two thousand nodes).
-
-The PSgrapher is small enough and easy enough to use to be included in other
-systems without pain.  It is also free and not copyrighted.
-
-Copy the file /afs/cs/project/clisp/library/psgraph/psgraph.lisp to your
-directory.  It is written in Common Lisp, and has been tested on CMU Common
-Lisp on RTs and Lucid on SUNs.  All interfaces described below are exported
-from the "PSGRAPH" package.
-
-There are several useful global variables that can be modified and one function
-to be called.  The variables affect the style of the printed image, the
-function walks a graph and produces output.
-
-A graph is defined by a root node and a function for getting children of a
-node.  Nodes are named by Lisp objects, and these names are checked using a
-user-supplied test function (defaults to EQUAL) for purposes of walking the
-graph and topologically sorting it.  Typically one uses atoms to name nodes,
-for example in graphing an inheritence net one could use the class names as
-node names.
-
-To produce a graph call the function:
-    (psgraph:psgraph root-node-name
-		     child-function
-		     info-function
-		     &optional (shrink nil)
-		     &optional (insert nil)
-		     &optional (test #'equal))
-
-Root-node-name is a Lisp object naming the root of the graph (there must be
-exactly one root).
-
-Child-function takes a node name and returns a list of node names.
-
-Info-function takes a node name and returns a list of strings.  Each string
-shows up as one line in the printed form of the node, with the first string
-displayed in one font (determined by variables *fontname*, *fontsize*) and the
-others in another font (determined by variables *second-fontname*,
-*second-fontsize*).  Typically the first string is just the name of the node,
-eg, (string node-name).
-
-Shrink is a boolean.  It defaults to nil, and in this case the graph
-prints on as many pages as are needed to show the whole thing.  If shrink
-is t then the entire graph is squashed appropriately to fit on one page
-of output.
-
-Insert is a boolean.  It defaults to nil, and in this case the generated
-Postscript file contains commands to print the output.  If insert is t
-then the output file is always shrunk (shrink is t) and no commands are
-generated to print the page.  This means the resulting file can be included
-in Scribe files, for example, and Scribe can decide when to print the page.
-
-Test is a function that return whether two nodes are the same.
-
-After loading psgraph, one can play with the various global variables, all of
-which have string values (except for the two font size variables).  *fontname*,
-*fontsize*, *second-fontname*, *second-fontsize* are as described above.  They
-default to "Helvetica" in 10 point and "Helvetica-Oblique" in 8 point,
-respectively.  *boxgray* and *boxkind* determine how the boxes around nodes
-look.  *boxkind* is either "fill" or "stroke", for solid or outline boxes, and
-*boxgray* is "0" for solid black, "1" for solid white, or in between.  These
-default to ".2" and "stroke".
-
-Other variables:
-   *max-psnodes*
-   *extra-x-spacing*
-   *extra-y-spacing*
-   *edgewidth*
-   *edgegray*
-   *edgecap*
-   *textgray*
-   *pageheight*
-   *pagewidth*
-   *boxradius*
-   *boxedge*
-   *chunksize*
-
-
-Psgraph sends its output to *standard-output*, so typically it is called
-from within (with-open-file  ....).  For example, one might use it like this:
-
-   (load "psgraph.fasl")
-   (setf psgraph:*boxkind* "fill")
-   (setf psgraph:*boxgray* ".8")
-   (setf psgraph:*fontsize* 8)
-   (setf psgraph:*second-fontsize* 6)
-
-   (defun graph (&optional (shrink t))
-     (with-open-file (*standard-output* "g.ps"
-		      :direction :output
-		      :if-exists :supersede)
-	  (psgraph:psgraph 'A #'children #'info shrink nil #'eq)))
-
-   (defun children (x)
-      (cond ((eq x 'A) '(B C D))
-	    ((member x '(B C D)) '(E F G))
-	    ((member x '(E F G)) '(H))
-	    (t nil)))
-
-   (defun info (x)
-      (list (string x)))
-
-
-Another example:
-   (defun code-graph-to-file (s file &optional shrink insert)
-     (let ((psgraph:*fontname* "Times-Roman")
-	   (psgraph:*fontsize* 8)
-	   (psgraph:*second-fontname* "Times-BoldItalic")
-	   (psgraph:*second-fontsize* 6)
-	   (psgraph:*boxgray* "0")
-	   (psgraph:*edgegray* "0")
-	   (psgraph:*extra-x-spacing* 30))
-       (with-open-file (*standard-output* file
-					  :direction :output
-					  :if-exists :supersede)
-	 (psgraph:psgraph s #'psg-children #'psg-info shrink insert #'eq))))
diff --git a/contrib/psgraph/psgraph.lisp b/contrib/psgraph/psgraph.lisp
deleted file mode 100644
index 09e37bbcf1871f09e96468e385606260f77bc3e4..0000000000000000000000000000000000000000
--- a/contrib/psgraph/psgraph.lisp
+++ /dev/null
@@ -1,506 +0,0 @@
-;;; -*- Mode: Lisp; Package: PSGRAPH; Log: psgraph.log -*-
-;;;
-;;; PostScript DAG Grapher  -- Joseph Bates, CMU CSD, March 1988
-;;;
-;;; See psgraph.log for other modifiers.
-;;;
-(in-package "PSGRAPH")
-
-(export '(*max-psnodes* *extra-x-spacing* *extra-y-spacing* *fontname*
-	  *fontsize* *second-fontname* *second-fontsize* *boxgray* *boxkind*
-	  *edgewidth* *edgegray* *edgecap* *textgray* *pageheight* *pagewidth*
-	  *boxradius* *boxedge* *chunksize*
-
-	  psgraph))
-
-
-(defstruct psnode
-  name
-  info
-  children
-  parents
-  appears-in-top-sort
-  children-appear-in-top-sort
-  yvalue
-  height
-)
-
-(defvar *max-psnodes* 5000)
-(defvar *extra-x-spacing* 20)
-(defvar *extra-y-spacing* 6)
-(defvar *fontname* "Helvetica")
-(defvar *fontsize* 10)
-(defvar *second-fontname* "Helvetica-Oblique")
-(defvar *second-fontsize* 8)
-(defvar *boxgray* ".2")      ;; 0 is black, 1 is white
-(defvar *boxkind* "stroke")  ;; stroke for outline, fill for solid
-(defvar *edgewidth* ".5")    ;; .5 is thin lines, 1 is fairly thick
-(defvar *edgegray* ".2")     ;; dark, but not solid black, lines
-(defvar *edgecap* "1")       ;; round the line caps
-(defvar *textgray* "0")      ;; solid black text
-(defvar *pageheight* 720)
-(defvar *pagewidth* (+ (* 7 72) 36))
-(defvar *boxradius* (floor *fontsize* 2))
-(defvar *boxedge* (floor *fontsize* 4))
-(defvar *chunksize* 400)
-
-(defvar num-psnodes)
-(defvar narray)
-(defvar psnode-index)
-(defvar child-function)
-(defvar info-function)
-(defvar top-sort)
-(defvar maximum-y)
-(defvar minimum-y)
-(defvar rows)
-(defvar y-offset)
-(defvar psnodes-at-y)
-(defvar ancestor-cache)
-
-(defun psgraph (root childf infof &optional (shrink nil) (insert nil) (test #'equal))
-  (unless (member test (list 'eq 'equal 'equalp #'eq #'equal #'equalp))
-    (error "Test must be a function suitable to hand to Make-Hash-Table."))
-  (when insert (setf shrink t))
-  (setq narray (make-array *max-psnodes*))
-  (setq num-psnodes 0)
-  (setq psnode-index (make-hash-table :test test
-				      :size 500
-				      :rehash-size 2.0))
-  (setq child-function childf)
-  (setq info-function infof)
-  (setq ancestor-cache (make-hash-table :test test
-					:size 1000
-					:rehash-size 2.0))
-
-  ;;; walk the graph computing node info
-  (walk-graph root)
-  (dotimes (index num-psnodes)
-    (setf (psnode-parents (aref narray index))
-	  (nreverse (psnode-parents (aref narray index))))
-    (setf (psnode-children (aref narray index))
-	  (nreverse (psnode-children (aref narray index)))))
-
-  ;;; topological sort the graph
-  (setq top-sort nil)
-  (top-sort-node 0)
-  (setq top-sort (nreverse top-sort))
-
-  ;;; declare this as a PostScript file
-  (format t "%!PS-Adobe-1.0~%")
-
-  ;;; this is required for the Apple LaserWriter (it likes to know the page
-  ;;; ordering so that it can print pages upside down).  It is best not to
-  ;;; confuse the LaserWriter when inserting things into a other documents.
-  (when (not insert)
-    (format t "%%Page: ? ?~%"))
-
-  ;;; define global functions
-  (dolist (line '(
-
-     "/max {2 copy lt {exch} if pop} def"
-
-     "/min {2 copy gt {exch} if pop} def"
-
-     "/inch {72 mul} def"
-
-     "/drawbox"
-     " {/height exch def"
-     "  /width exch def"
-     "  /y exch def"
-     "  /x exch def"
-     "  gsave newpath"
-     "  x y boxradius add moveto"
-     "  x y height add x width add y height add boxradius arcto pop pop pop pop"
-     "  x width add y height add x width add y boxradius arcto pop pop pop pop"
-     "  x width add y x y boxradius arcto pop pop pop pop"
-     "  x y x y height add boxradius arcto pop pop pop pop"
-     "  boxgray setgray boxkind grestore"
-     " } def"
-
-     "/printposter"
-     " {/rows exch def"
-     "  /columns exch def"
-     "  /bigpictureproc exch def"
-     "  newpath"
-     "    leftmargin botmargin moveto"
-     "    0 pageheight rlineto"
-     "    pagewidth 0 rlineto"
-     "    0 pageheight neg rlineto"
-     "  closepath clip"
-     "  leftmargin botmargin translate"
-     "  0 1 rows 1 sub"
-     "   {/rowcount exch def"
-     "    0 1 columns 1 sub"
-     "     {/colcount exch def"
-     "      gsave"
-     "       pagewidth colcount mul neg"
-     "       pageheight rowcount mul neg"
-     "       translate"
-     "       bigpictureproc"
-     "       gsave showpage grestore"
-     "      grestore"
-     "     } for"
-     "   } for"
-     " } def"
-
-   )) (format t "~A~%" line))
-
-  ;;; declare arrays
-  (format t "/xarray ~D array def~%" num-psnodes)
-  (format t "/widtharray ~D array def~%" num-psnodes)
-
-  ;;; define global settings
-  (format t "/leftmargin 36 def~%")
-  (format t "/botmargin 36 def~%")
-  (format t "/pagewidth ~D def~%" *pagewidth*)
-  (format t "/pageheight ~D def~%" *pageheight*)
-  (format t "/boxradius ~D def ~%" *boxradius*)
-  (format t "/boxedge ~D def ~%" *boxedge*)
-  (format t "/boxgray ~A def ~%" *boxgray*)
-  (format t "/boxkind {~A} def~%" *boxkind*)
-
-  ;;; compute width and height of each node
-  (format t "/~A findfont ~D scalefont setfont~%" *fontname* *fontsize*)
-  (dotimes (index num-psnodes)
-    (format t "widtharray ~D (~A) stringwidth pop put~%"
-	    index
-	    (car (psnode-info (aref narray index)))))
-  (format t "/~A findfont ~D scalefont setfont~%"
-	  *second-fontname* *second-fontsize*)
-  (dotimes (index num-psnodes)
-    (format t "widtharray ~D get~%" index)
-    (dolist (info (cdr (psnode-info (aref narray index))))
-       (format t "(~A) stringwidth pop max~%" info))
-    (format t "~D add widtharray exch ~D exch put~%"
- 	    (* 2 *boxedge*)
-	    index))
-  (dotimes (index num-psnodes)
-    (setf (psnode-height (aref narray index))
-	  (+ (* 2 *boxedge*)
-	     *extra-y-spacing*
-	     *fontsize*
-	     (* (- (length (psnode-info (aref narray index))) 1)
-		*second-fontsize*))))
-
-  ;;; compute x location of each node
-  (format t "xarray 0 0 put~%")
-  (dolist (index (cdr top-sort))
-    (let ((parents (psnode-parents (aref narray index))))
-      (format t "xarray ~D get widtharray ~D get add~%"
-	      (car parents) (car parents))
-      (dolist (parent (cdr parents))
-	  (format t "xarray ~D get widtharray ~D get add max~%"
-		  parent parent))
-      (format t "~D add xarray exch ~D exch put~%" *extra-x-spacing* index)))
-
-  ;;; compute maximum x used
-  (format t "/maximum-x 0~%")
-  (dotimes (index num-psnodes)
-     (format t "xarray ~D get widtharray ~D get add max~%"
-	     index index))
-  (format t "def~%")
-
-  ;;; compute y location of each node and maximum and minimum y used
-  (setq maximum-y 0)
-  (setq minimum-y 0)
-  (setq psnodes-at-y (make-hash-table :test test
-				      :size (* num-psnodes *fontsize*)
-				      :rehash-size 2.0))
-  (let ((currenty 0))
-    (dolist (index (reverse top-sort))
-       (let (desired-y)
-	 (cond ((null (psnode-children (aref narray index)))
-	          (setf desired-y currenty)
-		  (setf currenty (+ currenty (psnode-height
-					      (aref narray index)))))
-	       (t
-		 (let ((children (psnode-children (aref narray index)))
-		       (ysum 0))
-		   (dolist (child children)
-		      (setf ysum (+ ysum (psnode-yvalue (aref narray child)))))
-		   (setq desired-y (floor ysum (length children))))))
-
-	 ;;; We may not be able to put the node at the desired y.
-	 ;;; If there is another node that overlaps in the y direction
-	 ;;; and that node is neither a parent* nor child* (hence its x
-	 ;;; location may overlap this one) then we have to choose
-         ;;; another y value -- we choose the nearest (up or down)
-	 ;;; location so that there is no possible overlap in y or x.
-	 (let ((height (psnode-height (aref narray index)))
-	       (related (make-hash-table :test test
-					 :size (+ 50 num-psnodes)
-					 :rehash-size 2.0))
-	       collision
-	       upward-bot
-	       upward-top
-	       downward-bot
-	       downward-top)
-	   (setq upward-bot desired-y)
-	   (setq upward-top upward-bot)
-	   (setq downward-top (- (+ desired-y height) 1))
-	   (setq downward-bot downward-top)
-	   (loop
-	      ;;; check upward-top for collision
-	     (setq collision nil)
-	     (dolist (n (gethash upward-top psnodes-at-y))
-		(let ((r (gethash n related)))
-		  (when (null r)
-			(setf r (related-classes n index))
-			(setf (gethash n related) r))
-		  (when (eql r 'no)
-			(setq collision t)
-			(return))))
-				 
-	     ;;; if no collision and big enough space then we win
-	     (incf upward-top)
-	     (when (and (not collision) (= (- upward-top upward-bot) height))
-		   (setf desired-y upward-bot)
-		   (return))
-
-	     (when collision
-		   (setf upward-bot upward-top))
-
-	     ;;; check downward-bot for collision
-	     (setq collision nil)
-	     (dolist (n (gethash downward-bot psnodes-at-y))
-		(let ((r (gethash n related)))
-		  (when (null r)
-			(setf r (related-classes n index))
-			(setf (gethash n related) r))
-		  (when (eql r 'no)
-			(setq collision t)
-			(return))))
-
-	      ;;; if no collision and big enough space then we win
-	     (decf downward-bot)
-	     (when (and (not collision) (= (- downward-top downward-bot) height))
-		   (setf desired-y (+ 1 downward-bot))
-		   (return))
-	     
-	     (when collision
-		   (setf downward-top downward-bot))
-	   )
-	   ;;; add our name to psnodes-at-y table
-	   (dotimes (i height)
-	      (push index (gethash (+ i desired-y) psnodes-at-y)))
-
-	   (setf (psnode-yvalue (aref narray index)) desired-y)
-	 )
-
-	 (setf minimum-y (min minimum-y (psnode-yvalue (aref narray index))))
-	 (setf maximum-y
-	       (max maximum-y (+ (psnode-yvalue (aref narray index))
-				 (psnode-height (aref narray index))))))))
-		       
-  ;;; compute y-offset to center graph vertically
-  (setq rows (ceiling (- maximum-y minimum-y) *pageheight*))
-  (setq y-offset (- (floor (- (* rows *pageheight*) (- maximum-y minimum-y)) 2)
-		    minimum-y))
-  (when shrink (setq y-offset (- 0 minimum-y)))
-
-  ;;; create dictionary big enough to hold all the
-  ;;; procedures defined below and make it a current dictionary
-  (format t "~D dict begin~%"
-	  (+ (* 4 (+ num-psnodes (ceiling num-psnodes *chunksize*))) 50))
-
-  ;;; define procedures to display the background box for each node
-  (dotimes (index num-psnodes)
-     (format t "/box~D {~%" index)
-     (format t "xarray ~D get ~D widtharray ~D get ~D drawbox~%"
-	     index
-	     (+ y-offset 
-		(psnode-yvalue (aref narray index))
-                (floor *extra-y-spacing* 2))
-	     index
-	     (- (psnode-height (aref narray index)) *extra-y-spacing*))
-     (format t "} def~%"))
-
-  ;;; define procedures to display the text info for each node
-  (dotimes (index num-psnodes)
-     (let ((yvalue (+ y-offset
-		      (floor *extra-y-spacing* 2)
-		      (floor *fontsize* 5)
-                      *boxedge*
-		      (psnode-yvalue (aref narray index))
-		      (* *second-fontsize*
-			 (- (length (psnode-info (aref narray index))) 1)))))
-       (format t "/text~D {xarray ~D get boxedge add ~D moveto (~A) show} def~%"
-	       index
-	       index
-	       yvalue
-	       (car (psnode-info (aref narray index))))
-       (when (not (null (cdr (psnode-info (aref narray index)))))
-	   (format t "/secondtext~D {~%" index)
-	   (dolist (info (cdr (psnode-info (aref narray index))))
-	      (setq yvalue (- yvalue *second-fontsize*))
-	      (format t "xarray ~D get boxedge add ~D moveto (~A) show~%"
-		      index
-		      yvalue
-		      info))
-	   (format t "} def~%"))))
-
-  ;;; define procedures to display the edges leading into each node
-  (dotimes (index num-psnodes)
-     (format t "/edge~D {newpath~%" index)
-     (dolist (parent (psnode-parents (aref narray index)))
-        (format t "xarray ~D get widtharray ~D get add ~D moveto~%"
-		parent
-		parent
-		(+ (psnode-yvalue (aref narray parent))
-		   (floor (psnode-height (aref narray parent)) 2)
-		   y-offset))
-	(format t "xarray ~D get ~D lineto~%"
-		index
-		(+ (psnode-yvalue (aref narray index))
-		   (floor (psnode-height (aref narray index)) 2)
-		   y-offset)))
-     (format t "stroke } def~%"))
-
-  ;;; Define procedures to display chunks of boxes, text, and edges.
-  ;;; We limit each chunk to at most *chunksize* calls, to avoid overflowing
-  ;;; the Postscript operand stack.
-  (dotimes (index num-psnodes)
-     (when (eql (mod index *chunksize*) 0)
-	   (format t "/boxchunk~D {~%" (floor index *chunksize*)))
-     (format t "box~D~%" index)
-     (when (or (eql (mod index *chunksize*) (- *chunksize* 1))
-	       (eql index (- num-psnodes 1)))
-	   (format t "} def~%")))
-  (dotimes (index num-psnodes)
-     (when (eql (mod index *chunksize*) 0)
-	   (format t "/textchunk~D {~%" (floor index *chunksize*)))
-     (format t "text~D~%" index)
-     (when (or (eql (mod index *chunksize*) (- *chunksize* 1))
-	       (eql index (- num-psnodes 1)))
-	   (format t "} def~%")))
-  (dotimes (index num-psnodes)
-     (when (eql (mod index *chunksize*) 0)
-	   (format t "/secondtextchunk~D {~%" (floor index *chunksize*)))
-     (when (not (null (cdr (psnode-info (aref narray index)))))
-	   (format t "secondtext~D~%" index))
-     (when (or (eql (mod index *chunksize*) (- *chunksize* 1))
-	       (eql index (- num-psnodes 1)))
-	   (format t "} def~%")))
-  (dotimes (index num-psnodes)
-     (when (eql (mod index *chunksize*) 0)
-	   (format t "/edgechunk~D {~%" (floor index *chunksize*)))
-     (format t "edge~D~%" index)
-     (when (or (eql (mod index *chunksize*) (- *chunksize* 1))
-	       (eql index (- num-psnodes 1)))
-	   (format t "} def~%")))
-
-  ;;; Define procedure to display entire graph.
-  ;;; First do the boxes, then the edges, then the text.
-  (format t "/drawgraph { gsave~%")
-  (dotimes (i (ceiling num-psnodes *chunksize*))
-     (format t "boxchunk~D~%" i))
-  (format t "~A setlinewidth~%" *edgewidth*)
-  (format t "~A setlinecap~%" *edgecap*)
-  (format t "~A setgray~%" *edgegray*)
-  (dotimes (i (ceiling num-psnodes *chunksize*))
-     (format t "edgechunk~D~%" i))
-  (format t "~A setgray~%" *textgray*)
-  (format t "/~A findfont ~D scalefont setfont~%" *fontname* *fontsize*)
-  (dotimes (i (ceiling num-psnodes *chunksize*))
-     (format t "textchunk~D~%" i))
-  (format t "/~A findfont ~D scalefont setfont~%" *second-fontname* *second-fontsize*)
-  (dotimes (i (ceiling num-psnodes *chunksize*))
-     (format t "secondtextchunk~D~%" i))
-  (format t "grestore } def~%")
-
-  ;;; show the virtual page in as many actual pages as needed
-  (cond (shrink
-          ;;; shrink the output to fit on one page
-	  (format t "leftmargin botmargin translate~%")
-	  (format t "pagewidth dup maximum-x max div pageheight dup ~D max ~
-	             div min dup scale~%"
-		  (- maximum-y minimum-y))
-	  (if insert
-	      (format t "drawgraph end~%")
-	      (format t "drawgraph showpage end~%")))
-	(t
-	  (format t "{drawgraph} maximum-x pagewidth div ceiling ~
-	             ~D printposter end~%"
-		  rows)))
-  
-)
-
-
-(defun walk-graph (root)
-  (when (eql num-psnodes *max-psnodes*)
-	(error "More than ~D nodes in graph.  Graphing aborted."))
-  (let ((root-index num-psnodes)
-	(child-names (apply child-function (list root))))
-    (incf num-psnodes)
-    (setf (gethash root psnode-index) root-index)
-    (setf (aref narray root-index) (make-psnode))
-    (setf (psnode-name (aref narray root-index)) root)
-    (setf (psnode-info (aref narray root-index))
-	  (apply info-function (list root)))
-    (setf (psnode-children (aref narray root-index)) nil)
-    (setf (psnode-parents (aref narray root-index)) nil)
-    (setf (psnode-appears-in-top-sort (aref narray root-index)) nil)
-    (setf (psnode-children-appear-in-top-sort (aref narray root-index)) nil)
-    (dolist (child child-names)
-	    (let ((child-index (gethash child psnode-index)))
-	      (cond (child-index
-		      (push child-index
-			    (psnode-children (aref narray root-index)))
-		      (push root-index
-			    (psnode-parents (aref narray child-index))))
-		    (t
-		      (let ((child-index (walk-graph child)))
-			(push child-index
-			      (psnode-children (aref narray root-index)))
-			(push root-index
-			      (psnode-parents (aref narray child-index))))))))
-    root-index)
-)
-	  
-(defun top-sort-node (index)
-  (when (not (psnode-appears-in-top-sort (aref narray index)))
-
-	;;; make sure the parents are processed
-	(dolist (parent (psnode-parents (aref narray index)))
-		(top-sort-parent parent))
-
-	;;; add this node to top-sort
-	(push index top-sort)
-	(setf (psnode-appears-in-top-sort (aref narray index)) t))
-
-  (when (not (psnode-children-appear-in-top-sort (aref narray index)))
-	(dolist (child (psnode-children (aref narray index)))
-		(top-sort-node child))
-	(setf (psnode-children-appear-in-top-sort (aref narray index)) t))
-)
-
-(defun top-sort-parent (index)
-  (when (not (psnode-appears-in-top-sort (aref narray index)))
-
-	;;; make sure the parents are processed
-	(dolist (parent (psnode-parents (aref narray index)))
-		(top-sort-parent parent))
-
-	;;; add this node to top-sort
-	(push index top-sort)
-	(setf (psnode-appears-in-top-sort (aref narray index)) t))
-)
-
-(defun related-classes (x y)
-  (cond ((ancestor x y) 'yes)
-	((ancestor y x) 'yes)
-	(t 'no))
-)
-
-(defun ancestor (x y)
-  (let ((cached-value (gethash (list x y) ancestor-cache)))
-    (cond (cached-value (car cached-value))
-	  (t
-	    (setq cached-value
-		  (cond ((equal x y) t)
-			(t
-			  (some #'(lambda (child) (ancestor child y))
-				(psnode-children (aref narray x))))))
-	    (setf (gethash (list x y) ancestor-cache) (list cached-value))
-	    cached-value)))
-)
diff --git a/contrib/psgraph/psgraph.log b/contrib/psgraph/psgraph.log
deleted file mode 100644
index 2214c46483006730ea5c185b074b31324f2678ef..0000000000000000000000000000000000000000
--- a/contrib/psgraph/psgraph.log
+++ /dev/null
@@ -1,18 +0,0 @@
-/usr1/chiles/work/psgraph.lisp, Jul-90 10:59:13, Edit by Mkant.
-  Fixed shrink mode so that it scales x and y axes uniformly (e.g., aspect
-  ratio = 1).
-
-/usr1/chiles/work/psgraph.lisp, 01-May-90 10:59:13, Edit by Chiles.
-  Made exported specials have stars.
-
-/usr1/chiles/work/psgraph.lisp, APR 90, Edit by Skef Wholey.
-  ;;;     -- Now lives in the PSGRAPH package (instead of USER, or *package*...)
-  ;;;        with user-tweakable stuff exported.
-  ;;;     -- Node equivalence function can now be specified as EQ, EQUAL,
-  ;;;        or EQUALP.
-
-/usr1/chiles/work/psgraph.lisp, DEC 88, Edit by Joseph Bates
-  Modified to include optional insert parameter to psgraph.
-
-/usr1/chiles/work/psgraph.lisp, MAR 88, Edit by Joseph Bates
-  File created.
diff --git a/docs/cmu-user/cmu-user.dict b/docs/cmu-user/cmu-user.dict
deleted file mode 100644
index ce86160b6440636b8f2b33b0077b932a5cd4cece..0000000000000000000000000000000000000000
--- a/docs/cmu-user/cmu-user.dict
+++ /dev/null
@@ -1,460 +0,0 @@
-'BAR
-VARREF
-'TEST
-UPCASE
-ENDLISP
-SUBSEQ
-ENDDEFUN
-FUNARGS
-GENSYM
-VARS
-UNINTERNED
-VAR
-VSOURCE
-CLISP
-COND
-MYSTUFF
-TRADEOFFS
-PATHNAME
-LLISP
-CMUCL
-REF
-YETMOREKEYS
-CLEANUP
-ARGS
-DEFUN
-ZOQ
-FOO
-'S
-CLTL
-MACROEXPANDS
-MACROEXPANSION
-PROXY
-ERRORFUL
-EQ
-ECASE
-PYTHON
-DEFMACRO
-PROMISCUOUS
-FLAMAGE
-DEBUGGABILITY
-FEATUREFULNESS
-DEBUGGABLE
-ENDDEFVAR
-MACROEXPANDED
-DEFVAR
-ENDDEFMAC
-KWD
-MGROUP
-MSTAR
-DEFMAC
-OFFS
-NOTINLINE
-TRADEOFF
-FUNCALL
-SOMEVAL
-SOMEFUN
-CM
-DEFTYPE
-CONSING
-FIXNUMS
-BIGNUMS
-FROB
-'FOO
-RECOMPILES
-FTYPE
-TYPECASE
-TYPEP
-UNTYPED
-UNIONED
-GLOBALS
-MODICUM
-MACREF
-SLEAZING
-ES
-STEELE
-ETYPECASE
-'EQL
-'IDENTITY
-'FUN
-LOCALFUN
-ISQRT
-ODDP
-MYFUN
-POS
-ZOW
-YOW
-'YOW
-CADR
-ZEROP
-RES
-EXPT
-PARED
-PUSHING
-'ING
-RPLACD
-IOTA
-NTHCDR
-NTH
-CADDDR
-RPLACA
-CADDR
-FIENDS
-SQRT
-'SQRT
-LISPY
-BLANKSPACE
-MYCHAPTER
-UNENCAPSULATED
-ENCAPSULATIONS
-UNENCAPSULATE
-UNTRACED
-UNTRACE
-EVALED
-SPEC
-PUSHES
-TRUENAME
-MYMAC
-UNINFORMATIVE
-FOOBAR
-BAZ
-BACKQUOTE
-MALFORMED
-MOREKEYS
-FUNREF
-QUIRKS
-UNDILUTED
-DISASSEMBLY
-NAN
-DENORMALIZED
-ENDDEFCONST
-DEFCONST
-HASHTABLES
-EFF
-OBFUSCATING
-SNOC
-GRUE
-GORP
-FLO
-NUM
-VEC
-MULTBY
-SOMEOTHERFUN
-'CHAR
-NOTP
-TESTP
-FUNVAR
-RAZ
-ZUG
-XFF
-IO
-GC'ING
-EXT
-MEGABYTE
-SYS
-UX
-ED
-MATCHMAKER
-DIRED
-PCL
-CLOS
-CONFORMANCE
-ENDDEFCON
-DEFCON
-DECLAIM
-DEFSTRUCT
-ENUM
-EXTERN
-LOWERCASING
-DEREFERENCED
-MOPT
-STRUCT
-DEFTP
-ENDDEFTP
-MALLOC
-CSH
-PXLREF
-ATYPE
-CONSTRUCTUED
-ANAME
-PXREF
-ENV
-ONECOLUMN
-TP
-VR
-FN
-PRINTINDEX
-UNNUMBERED
-TWOCOLUMN
-TLF
-UNCOMPILED
-DEACTIVATE
-CALLABLE
-UNREFERENCED
-SUPPLIEDP
-INTERNING
-UNHANDLED
-BACKTRACING
-TEX
-OOB
-OBJ
-PRIN
-OBJS
-GP
-LINKERS
-CC
-AR
-CFUN
-INTS
-SIZEOF
-PRINTF
-CFOO
-SUBFORM
-SVREF
-STASH
-FOOS
-LC
-LD
-'N
-'X
-ERRNO
-UPPERCASING
-EXPR
-ADDR
-'STR
-STR
-DEREF
-PTR
-SWINDOW
-IWINDOW
-'SLIDER
-DRAWABLE
-'KEY
-'EXT
-TIMEOUTS
-'MY
-ID
-PIXMAPS
-'EQ
-FUNCALLED
-XWINDOW
-'IH
-SIGSTOP
-GETPID
-SIGTSTP
-SCP
-SIGINT
-IH
-CNT
-GENERALRETURN
-DEFMACX
-'NUKEGARBAGE
-GR
-HASSLE
-PREPENDS
-TIMEOUT
-FD
-MSG
-SYSCALL
-UNHELPFUL
-PREPENDED
-VM
-PAGEREF
-INT
-PORTSID
-PORTSNAME
-SERVPORT
-KERN
-DATATYPES
-TTY
-STDERR
-STDOUT
-STDIN
-CMD
-AUX
-PS
-UNACCOUNTED
-RUNTIMES
-PROFILER
-UNPROFILE
-REPROFILED
-UNPROFILED
-CF
-ELT
-VOPS
-MAPCAR
-OPTIONALS
-CONSES
-CONTORTIONS
-ALISTS
-ALIST
-ASSOC
-EXP
-MYEXP
-DEFCONSTANT
-INCF
-MEMQ
-COERCIONS
-EQL
-LOGAND
-AREF
-CONSP
-TYPEN
-LOGIOR
-EQUIV
-SUPERTYPE
-DEFMETHOD
-SUBFORMS
-CERROR
-PSETQ
-TAGBODY
-DOTIMES
-PLOQ
-ROQ
-SPECS
-MPLUS
-STEPPER
-FDEFINITION
-FUNCALLABLE
-ST
-BR
-DB
-LB
-LL
-HFILL
-PP
-VPRINT
-TH
-ARGLISTS
-SETQ
-NAMESPACE
-SUBFUNCTION
-BACKTRACE
-'B
-FLET
-ARG
-'A
-CPSUBINDEX
-PROGN
-CONTRIB
-WEEKDAYS
-GREENWICH
-TIMEZONE
-DEST
-WEEKDAY
-JAN
-CINDEX
-NAMESTRING
-PATHNAMES
-FASL
-SIGSEGV
-PLIST
-'ABLE
-SETF
-PID
-EXECVE
-DEV
-SUBPROCESS
-PTY
-'TH
-UNSUPPLIED
-DEFVARX
-GCS
-CONSED
-GC'ED
-GC
-TRASHING
-XLIB
-CL
-HI
-COMMONLOOPS
-CTRL
-XLREF
-DEFUNX
-DEFCONSTX
-SUBSUBSECTION
-VINDEXED
-TINDEXED
-RESEARCHCREDIT
-EM
-WHOLEY
-SKEF
-KAUFMANN
-TODD
-KOLOJEJCHICK
-BUSDIECKER
-''
-NOINDENT
-MOORE
-TIM
-LOTT
-LEINEN
-HALLGREN
-GLEICHAUF
-DUNNING
-TED
-BADER
-MYLISP
-NOINIT
-FINDEXED
-INIT
-EVAL
-SUBDIRECTORIES
-COPYRIGHTED
-FTP
-LANG
-COMP
-MEG
-MEGABYTES
-UNCOMPRESS
-CD
-OS
-USERNAME
-SLISP
-RT
-LIB
-SETENV
-SAMP
-SETPATH
-LOGIN
-MISC
-USR
-MODMISC
-TXT
-DOC
-EXECUTABLES
-PERQ
-UNTAGGED
-BENCHMARKING
-WINDOWING
-INTRO
-DOCS
-EDU
-AFS
-VSPACE
-IFINFO
-DIR
-SETFILENAME
-TABLEOFCONTENTS
-PAGENUMBERING
-CLEARPAGE
-MAKETITLE
-ARPASUPPORT
-CITATIONINFO
-TRNUMBER
-IFTEX
-SUNOS
-SPARC
-DECSTATIONS
-THEABSTRACT
-DEF
-KY
-CP
-NEWINDEX
-ALWAYSREFILL
-PAGESTYLE
-CMULISP
-TITLEPAGE
-ELISP
-LATEXINFO
-DOCUMENTSTYLE
diff --git a/docs/cmu-user/cmu-user.tex b/docs/cmu-user/cmu-user.tex
deleted file mode 100644
index cb2a86881567072f500b2f1cdd575a7c2f1c295f..0000000000000000000000000000000000000000
--- a/docs/cmu-user/cmu-user.tex
+++ /dev/null
@@ -1,11506 +0,0 @@
-\documentstyle[latexinfo,elisp,cmu-titlepage,cmulisp]{report} % -*-latexinfo-*-
-\pagestyle{headings}
-
-\begin{document}
-\alwaysrefill
-\newindex{cp}
-\newindex{ky}
-
-\def\theabstract{
-CMU Common Lisp is an implementation of that Common Lisp is currently
-supported on MIPS-processor DECstations, Sparc-based workstations from
-Sun and the IBM RT PC, and other ports are planned.  All architectures
-are supported under Mach, a Berkeley Unix 4.3 binary compatible
-operating system.  The Sparc is also supported under SunOS.  The largest
-single part of this document describes the Python compiler and the
-programming styles and techniques that the compiler encourages.  The
-rest of the document describes extensions and the implementation
-dependent choices made in developing this implementation of Common Lisp.
-We have added several extensions, including a source level debugger, an
-interface to Unix system calls, a foreign function call interface,
-support for interprocess communication and remote procedure call, and
-other features that provide a good environment for developing Lisp code.
-}
-
-\begin{iftex}
-\pagestyle{empty}
-\title{CMU Common Lisp User's Manual}
-
-\author{Robert A. MacLachlan, \var{Editor}}
-\date{July 1992}
-\trnumber{CMU-CS-92-161}
-\citationinfo{
-\begin{center}
-Supersedes Technical Reports CMU-CS-87-156 and CMU-CS-91-108.
-\end{center}
-}
-\arpasupport{strategic}
-\abstract{\theabstract}
-\keywords{lisp, Common Lisp, manual, compiler, 
-          programming language implementation, programming environment}
-
-\maketitle
-
-\clearpage
-\pagestyle{headings}
-\pagenumbering{roman}
-\tableofcontents
-
-\clearpage
-\pagenumbering{arabic}
-\end{iftex}
-
-\setfilename{cmu-user.info}
-\node Top, Introduction, (dir), (dir)
-
-\begin{ifinfo}
-\vspace{1.3in}
-\begin{center}
-CMU Common Lisp User's Manual
-Robert A. MacLachlan, \var{Editor}
-
-School of Computer Science
-Carnegie Mellon University
-Pittsburgh, PA 15213
-\end{center}
-
-\theabstract
-
-\end{ifinfo}
-
-
-\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/intro.ms}
-
-
-
-\hide{ -*- Dictionary: cmu-user -*- }
-\begin{menu}
-* Introduction::                
-* Design Choices and Extensions::  
-* The Debugger::                
-* The Compiler::                
-* Advanced Compiler Use and Efficiency Hints::  
-* UNIX Interface::              
-* Event Dispatching with SERVE-EVENT::  
-* Alien Objects::               
-* Interprocess Communication under LISP::  
-* Debugger Programmer's Interface::  
-* Function Index::              
-* Variable Index::              
-* Type Index::                  
-* Concept Index::               
-
- --- The Detailed Node Listing ---
-
-Introduction
-
-* Support::                     
-* Local Distribution of CMU Common Lisp::  
-* Net Distribution of CMU Common Lisp::  
-* Source Availability::         
-* Command Line Options::        
-* Credits::                     
-
-Design Choices and Extensions
-
-* Data Types::                  
-* Default Interrupts for Lisp::  
-* Packages::                    
-* The Editor::                  
-* Garbage Collection::          
-* Describe::                    
-* The Inspector::               
-* Load::                        
-* The Reader::                  
-* Running Programs from Lisp::  
-* Saving a Core Image::         
-* Search Lists::                
-* Time Parsing and Formatting::  
-* Lisp Library::                
-
-Data Types
-
-* Symbols::                     
-* Integers::                    
-* Floats::                      
-* Characters::                  
-* Array Initialization::        
-
-Floats
-
-* IEEE Special Values::         
-* Negative Zero::               
-* Denormalized Floats::         
-* Floating Point Exceptions::   
-* Floating Point Rounding Mode::  
-* Accessing the Floating Point Modes::  
-
-The Inspector
-
-* The Windowing Inspector::     
-* The TTY Inspector::           
-
-Running Programs from Lisp
-
-* Process Accessors::           
-
-Search Lists
-
-* Search List Example::         
-
-The Debugger
-
-* Debugger Introduction::       
-* The Command Loop::            
-* Stack Frames::                
-* Variable Access::             
-* Source Location Printing::    
-* Compiler Policy Control::     
-* Exiting Commands::            
-* Information Commands::        
-* Breakpoint Commands::
-* Function Tracing::            
-* Specials::                    
-
-Stack Frames
-
-* Stack Motion::                
-* How Arguments are Printed::   
-* Function Names::              
-* Funny Frames::                
-* Debug Tail Recursion::        
-* Unknown Locations and Interrupts::  
-
-Variable Access
-
-* Variable Value Availability::  
-* Note On Lexical Variable Access::  
-
-Source Location Printing
-
-* How the Source is Found::     
-* Source Location Availability::  
-
-Breakpoint Commands
-
-* Breakpoint Example::
-
-Function Tracing
-
-* Encapsulation Functions::     
-
-The Compiler
-
-* Compiler Introduction::       
-* Calling the Compiler::        
-* Compilation Units::           
-* Interpreting Error Messages::  
-* Types in Python::             
-* Getting Existing Programs to Run::  
-* Compiler Policy::             
-* Open Coding and Inline Expansion::  
-
-Compilation Units
-
-* Undefined Warnings::          
-* Context Declarations::        
-* Context Declaration Example::  
-
-Interpreting Error Messages
-
-* The Parts of the Error Message::  
-* The Original and Actual Source::  
-* The Processing Path::         
-* Error Severity::              
-* Errors During Macroexpansion::  
-* Read Errors::                 
-* Error Message Parameterization::  
-
-Types in Python
-
-* Compile Time Type Errors::    
-* Precise Type Checking::       
-* Weakened Type Checking::      
-
-Compiler Policy
-
-* The Optimize Declaration::    
-* The Optimize-Interface Declaration::  
-
-Advanced Compiler Use and Efficiency Hints
-
-* Advanced Compiler Introduction::  
-* More About Types in Python::  
-* Type Inference::              
-* Source Optimization::         
-* Tail Recursion::              
-* Local Call::                  
-* Block Compilation::           
-* Inline Expansion::            
-* Object Representation::       
-* Numbers::                     
-* General Efficiency Hints::    
-* Efficiency Notes::            
-* Profiling::                   
-
-Advanced Compiler Introduction
-
-* Types::                       
-* Optimization::                
-* Function Call::               
-* Representation of Objects::   
-* Writing Efficient Code::      
-
-More About Types in Python
-
-* More Types Meaningful::       
-* Canonicalization::            
-* Member Types::                
-* Union Types::                 
-* The Empty Type::              
-* Function Types::              
-* The Values Declaration::      
-* Structure Types::             
-* The Freeze-Type Declaration::  
-* Type Restrictions::           
-* Type Style Recommendations::  
-
-Type Inference
-
-* Variable Type Inference::     
-* Local Function Type Inference::  
-* Global Function Type Inference::  
-* Operation Specific Type Inference::  
-* Dynamic Type Inference::      
-* Type Check Optimization::     
-
-Source Optimization
-
-* Let Optimization::            
-* Constant Folding::            
-* Unused Expression Elimination::  
-* Control Optimization::        
-* Unreachable Code Deletion::   
-* Multiple Values Optimization::  
-* Source to Source Transformation::  
-* Style Recommendations::       
-
-Tail Recursion
-
-* Tail Recursion Exceptions::   
-
-Local Call
-
-* Self-Recursive Calls::        
-* Let Calls::                   
-* Closures::                    
-* Local Tail Recursion::        
-* Return Values::               
-
-Block Compilation
-
-* Block Compilation Semantics::  
-* Block Compilation Declarations::  
-* Compiler Arguments::          
-* Practical Difficulties::      
-
-Inline Expansion
-
-* Inline Expansion Recording::  
-* Semi-Inline Expansion::       
-* The Maybe-Inline Declaration::  
-
-Object Representation
-
-* Think Before You Use a List::  
-* Structures::                  
-* Arrays::                      
-* Vectors::                     
-* Bit-Vectors::                 
-* Hashtables::                  
-
-Numbers
-
-* Descriptors::                 
-* Non-Descriptor Representations::  
-* Variables::                   
-* Generic Arithmetic::          
-* Fixnums::                     
-* Word Integers::               
-* Floating Point Efficiency::   
-* Specialized Arrays::          
-* Interactions With Local Call::  
-* Representation of Characters::  
-
-General Efficiency Hints
-
-* Compile Your Code::           
-* Avoid Unnecessary Consing::   
-* Complex Argument Syntax::     
-* Mapping and Iteration::       
-* Trace Files and Disassembly::  
-
-Efficiency Notes
-
-* Type Uncertainty::            
-* Efficiency Notes and Type Checking::  
-* Representation Efficiency Notes::  
-* Verbosity Control::           
-
-Profiling
-
-* Profile Interface::           
-* Profiling Techniques::        
-* Nested or Recursive Calls::   
-* Clock resolution::            
-* Profiling overhead::          
-* Additional Timing Utilities::  
-* A Note on Timing::            
-* Benchmarking Techniques::     
-
-UNIX Interface
-
-* Reading the Command Line::    
-* Lisp Equivalents for C Routines::  
-* Type Translations::           
-* System Area Pointers::        
-* Unix System Calls::           
-* File Descriptor Streams::     
-* Making Sense of Mach Return Codes::  
-* Unix Interrupts::             
-
-Unix Interrupts
-
-* Changing Interrupt Handlers::  
-* Examples of Signal Handlers::  
-
-Event Dispatching with SERVE-EVENT
-
-* Object Sets::                 
-* The SERVE-EVENT Function::    
-* Using SERVE-EVENT with Unix File Descriptors::  
-* Using SERVE-EVENT with the CLX Interface to X::  
-* A SERVE-EVENT Example::       
-
-Using SERVE-EVENT with the CLX Interface to X
-
-* Without Object Sets::         
-* With Object Sets::            
-
-A SERVE-EVENT Example
-
-* Without Object Sets Example::  
-* With Object Sets Example::    
-
-Alien Objects
-
-* Introduction to Aliens::      
-* Alien Types::                 
-* Alien Operations::            
-* Alien Variables::             
-* Alien Data Structure Example::  
-* Loading Unix Object Files::   
-* Alien Function Calls::        
-* Step-by-Step Alien Example::  
-
-Alien Types
-
-* Defining Alien Types::        
-* Alien Types and Lisp Types::  
-* Alien Type Specifiers::       
-* The C-Call Package::          
-
-Alien Operations
-
-* Alien Access Operations::     
-* Alien Coercion Operations::   
-* Alien Dynamic Allocation::    
-
-Alien Variables
-
-* Local Alien Variables::       
-* External Alien Variables::    
-
-Alien Function Calls
-
-* alien-funcall::               The alien-funcall Primitive
-* def-alien-routine::           The def-alien-routine Macro
-* def-alien-routine Example::   
-* Calling Lisp from C::         
-
-Interprocess Communication under LISP
-
-* The REMOTE Package::          
-* The WIRE Package::            
-* Out-Of-Band Data::            
-
-The REMOTE Package
-
-* Connecting Servers and Clients::  
-* Remote Evaluations::          
-* Remote Objects::              
-* Host Addresses::              
-
-The WIRE Package
-
-* Untagged Data::               
-* Tagged Data::                 
-* Making Your Own Wires::       
-
-Debugger Programmer's Interface
-
-* DI Exceptional Conditions::   
-* Debug-variables::             
-* Frames::                      
-* Debug-functions::             
-* Debug-blocks::                
-* Breakpoints::                 
-* Code-locations::              
-* Debug-sources::               
-* Source Translation Utilities::  
-
-DI Exceptional Conditions
-
-* Debug-conditions::            
-* Debug-errors::                
-\end{menu}
-
-\node Introduction, Design Choices and Extensions, Top, Top
-\chapter{Introduction}
-
-CMU Common Lisp is a public-domain implementation of Common Lisp
-developed in the Computer Science Department of Carnegie Mellon
-University.  CMU Common Lisp is currently supported on MIPS-processor
-DECstations, Sparc-based workstations from Sun and the IBM RT PC, and
-other ports are planned.  Currently, it runs under CMU's Mach operating
-system, OSF/1 or SunOS.  This document describes the implementation
-based on the Python compiler.  Previous versions of CMU Common Lisp ran
-on the IBM RT PC and (when known as Spice Lisp) on the Perq workstation.
-See \code{man cmucl} (\file{man/man1/cmucl.1}) for other general
-information.
-
-\cmucl{} sources and executables are freely available via anonymous FTP; this
-software is ``as is'', and has no warranty of any kind.  CMU and the
-authors assume no responsibility for the consequences of any use of this
-software.  See \file{doc/release-notes.txt} for a description of the
-state of the release you have.
-
-\begin{menu}
-* Support::                     
-* Local Distribution of CMU Common Lisp::  
-* Net Distribution of CMU Common Lisp::  
-* Source Availability::         
-* Command Line Options::        
-* Credits::                     
-\end{menu}
-
-\node Support, Local Distribution of CMU Common Lisp, Introduction, Introduction
-\section{Support}
-
-The CMU Common Lisp project's goal is to develop a high quality public
-domain system, so we want your bug reports, bug fixes and enhancements.
-However, staff limitations prevent us from providing extensive support
-to people outside of CMU.  We are looking for university and industrial
-affiliates to help us with porting and maintenance for hardware and
-software that is not widely used at CMU.
-
-This manual contains only implementation-specific information about \cmucl.
-Users will also need a separate manual describing the \clisp{} standard.
-\clisp{} was initially defined in \i{Common Lisp: The Language}, by Guy L.
-Steele Jr.  \clisp{} is now undergoing standardization by the X3J13 committee
-of ANSI.  The X3J13 spec is not yet completed, but a number of clarifications
-and modification have been approved.  We intend that \cmucl{} will eventually
-adhere to the X3J13 spec, and we have already implemented many of the changes
-approved by X3J13.
-
-Until the X3J13 standard is completed, the second edition of \cltl2{} is
-probably the best available manual for the language and for our
-implementation of it.  This book has no official role in the
-standardization process, but it does include many of the changes adopted
-since the first edition was completed.
-
-In addition to the language itself, this document describes a number of useful
-library modules that run in \cmucl. \hemlock, an Emacs-like text editor, is
-included as an integral part of the \cmucl{} environment.  Two documents
-describe \hemlock{}: the \i{Hemlock User's Manual}, and the \i{Hemlock Command
-Implementor's Manual}.
-
-\node Local Distribution of CMU Common Lisp, Net Distribution of CMU Common Lisp, Support, Introduction
-\section{Local Distribution of CMU Common Lisp}
-
-At CMU, you can get Common Lisp by running \code{modmisc}:
-\begin{example}
-    /usr/cs/etc/modmisc - cs.misc.cmucl
-\end{example}
-
-This establishes \file{/usr/misc/.cmucl} as a symbolic link to the release area.
-In your \file{.login}, add CMU CL to your path:
-\begin{example}
-setpath -i /usr/misc/.cmucl
-\end{example}
-Then run \samp{lisp}.  Note that the first time you run Lisp, it
-will take AFS several minutes to copy the image into its local cache.
-Subsequent starts will be much faster.
-
-Or, you can run directly out of the AFS release area (which may be
-necessary on SunOS machines).  Put this in your \file{.login} shell
-script:
-\begin{example}
-setenv CMUCLLIB "/afs/cs/misc/cmucl/@sys/beta/lib"
-setpath -i /afs/cs/misc/cmucl/@sys/beta
-\end{example}
-
-After setting your path, `\code{man cmucl}' will give an introduction
-to CMU CL and \samp{man lisp} will describe command line options.
-For SunOS installation notes, see the \file{README} file in the SunOS
-release area.
-
-See \file{/usr/misc/.cmucl/doc} for release notes and documentation.
-Hardcopy documentation is available in the document room.
-Documentation supplements may be available for recent additions: see
-the \file{README} file.
-
-Send bug reports and questions to \samp{cmucl-bugs@cs.cmu.edu}.  If
-you send a bug report to \samp{gripe} or \samp{help}, they will just
-forward it to this mailing list.
-
-\node Net Distribution of CMU Common Lisp, Source Availability, Local Distribution of CMU Common Lisp, Introduction
-\section{Net Distribution of CMU Common Lisp}
-
-Externally, CMU Common Lisp is only available via anonymous FTP.  We
-don't have the manpower to make tapes.  These are our distribution
-machines:
-\begin{example}
-lisp-rt1.slisp.cs.cmu.edu (128.2.217.9)
-lisp-rt2.slisp.cs.cmu.edu (128.2.217.10)
-\end{example}
-
-Log in with the user \samp{anonymous} and \samp{username@host} as password
-(i.e. your EMAIL address.)  When you log in, the current directory should be
-set to the \cmucl{} release area.  If you have any trouble with FTP access,
-please send mail to \samp{slisp@cs.cmu.edu}.
-
-The release area holds compressed tar files with names of the form:
-\begin{example}
-\var{version}-\var{machine}_\var{os}.tar.Z
-\end{example}
-FTP compressed tar archives in binary mode.  To extract, \samp{cd} to the
-directory that is to be the root of the tree, then type:
-\begin{example}
-uncompress <file.tar.Z | tar xf - .
-\end{example}
-The resulting tree is about 23 megabytes.  For installation directions, see the
-section ``site initialization'' in README file at the root of the tree.
-
-If poor network connections make it difficult to transfer a 10 meg file,
-the release is also available split into five parts, with the suffix
-\file{.0} to \file{.4}. To extract from multiple files, use:
-\begin{example}
-cat file.tar.Z.* | uncompress | tar xf - .
-\end{example}
-
-The release area also contains source distributions and other binary
-distributions.  A listing of the current contents of the release area is
-in \file{FILES}.  Major release announcements will be made to
-\code{comp.lang.lisp} until there is enough volume to warrant a
-\code{comp.lang.lisp.cmu}.
-
-\node Source Availability, Command Line Options, Net Distribution of CMU Common Lisp, Introduction
-\section{Source Availability}
-
-Lisp and documentation sources are available via anonymous FTP ftp to any CMU
-CS machine.  All CMU written code is public domain, but CMU CL also makes use
-of two imported packages: PCL and CLX.  Although these packages are
-copyrighted, they may be freely distributed without any licensing agreement or
-fee.  See the \file{README} file in the binary distribution for up-to-date source
-pointers.
-
-The release area contains a source distribution, which is an image of all the
-\file{.lisp} source files used to build a particular system \var{version}:
-\begin{example}
-\var{version}-source.tar.Z (3.6 meg)
-\end{example}
-
-All of our files (including the release area) are actually in the AFS
-file system.  On the release machines, the FTP server's home is the
-release directory: \file{/afs/cs.cmu.edu/project/clisp/release}.  The
-actual working source areas are in other subdirectories of \file{clisp},
-and you can directly ``cd'' to those directories if you know the name.
-Due to the way anonymous FTP access control is done, it is important to
-``cd'' to the source directory with a single command, and then do a
-``get'' operation.
-
-\node Command Line Options, Credits, Source Availability, Introduction
-\section{Command Line Options}
-
-The command line syntax and environment is described in the lisp(1) man page in
-the man/man1 directory of the distribution.  See also cmucl(1).
-Currently Lisp accepts the following switches:
-\begin{description}
-
-\item[\code{-core}] requires an argument that should be the name of a
-core file.  Rather than using the default core file
-(\file{/usr/misc/.lisp/lib/lisp.core}), the specified core file is
-loaded.
-
-\item[\code{-edit}] specifies to enter Hemlock.  A file to edit may be
-specified by placing the name of the file between the program name
-(usually \file{lisp}) and the first switch.
-
-\item[\code{-eval}]
-accepts one argument which should be a Lisp form to evaluate during
-the start up sequence.  The value of the form will not be printed unless it is
-wrapped in a form that does output.
-
-\item[\code{-hinit}]
-accepts an argument that should be the name of
-the hemlock init file to load the first time the function
-\findexed{ed} is invoked.  The default is to load
-\file{hemlock-init.\var{object-type}}, or if that does not
-exist, \file{hemlock-init.lisp} from the user's home directory.  If
-the file is not in the user's home directory, the full path must be
-specified.
-
-\item[\code{-init}] accepts an argument that should be the name of an
-init file to load during the normal start up sequence.  The default is
-to load \file{init.\var{object-type}} or, if that does not exist,
-\file{init.lisp} from the user's home directory.  If the file is not in
-the user's home directory, the full path must be specified.
-
-\item[\code{-noinit}]
-accepts no arguments and specifies that an init file should not
-be loaded during the normal start up sequence.  Also, this switch
-suppresses the loading of a hemlock init file when Hemlock is started up
-with the \code{-edit} switch.
-
-\item[\code{-load}]
-accepts an argument which should be the name of a file to load
-into Lisp before entering Lisp's read-eval-print loop.
-
-\item[\code{-slave}] specifies that Lisp should start up as a \i{slave}
-Lisp and try to connect to an editor Lisp.  The name of the editor to
-connect to must be specified \dash{} to find the editor's name, use the
-\hemlock{} \w{"\code{Accept Slave Connections}"} command.  The name for
-the editor Lisp is of the form:
-\begin{example}
-\var{machine-name}\code{:}\var{socket}
-\end{example}
-where \var{machine-name} is the internet host name for the machine and
-\var{socket} is the decimal number of the socket to connect to.
-\end{description}
-For more details on the use of the \code{-edit} and \code{-slave}
-switches, see the \i{Hemlock User's Manual}.
-
-Arguments to the above switches can be specified in one of two ways:
-\w{\var{switch}\code{=}\var{value}} or
-\w{\var{switch}<\var{space}>\var{value}}.  For example, to start up the saved
-core file mylisp.core use either of the following two commands:
-\begin{example}
-\code{lisp -core=mylisp.core
-lisp -core mylisp.core}
-\end{example}
-
-\node Credits,  , Command Line Options, Introduction
-\section{Credits}
-
-Since 1981 many people have contributed to the development of CMU Common
-Lisp.  The currently active members are:
-\begin{display}
-David Axmark
-Miles Bader
-Ted Dunning
-Scott Fahlman * (fearless leader)		
-Mike Garland +
-Paul Gleichauf *
-Sean Hallgren +
-Simon Leinen
-William Lott *
-Robert A. Maclachlan *
-Tim Moore
-\end{display}
-\noindent
-Many people are voluntarily working on improving CMU Common Lisp.  ``*''
-means a full-time CMU employee, and ``+'' means a part-time student
-employee.  A partial listing of significant past contributors follows:
-\begin{display}
-Rick Busdiecker
-Bill Chiles *
-Chris Hoover +
-John Kolojejchick
-Todd Kaufmann +
-Dave McDonald *
-Skef Wholey *
-\end{display}
-
-\vspace{2 em}
-\researchcredit
-
-
-\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/design.ms}
-
-\hide{ -*- Dictionary: cmu-user -*- }
-\node Design Choices and Extensions, The Debugger, Introduction, Top
-\chapter{Design Choices and Extensions}
-
-Several design choices in Common Lisp are left to the individual
-implementation, and some essential parts of the programming environment
-are left undefined.  This chapter discusses the most important design
-choices and extensions.
-
-\begin{menu}
-* Data Types::                  
-* Default Interrupts for Lisp::  
-* Packages::                    
-* The Editor::                  
-* Garbage Collection::          
-* Describe::                    
-* The Inspector::               
-* Load::                        
-* The Reader::                  
-* Running Programs from Lisp::  
-* Saving a Core Image::         
-* Search Lists::                
-* Time Parsing and Formatting::  
-* Lisp Library::                
-\end{menu}
-
-\node Data Types, Default Interrupts for Lisp, Design Choices and Extensions, Design Choices and Extensions
-\section{Data Types}
-
-\begin{menu}
-* Symbols::                     
-* Integers::                    
-* Floats::                      
-* Characters::                  
-* Array Initialization::        
-\end{menu}
-
-\node Symbols, Integers, Data Types, Data Types
-\subsection{Symbols}
-
-As in \cltl, all symbols and package names are printed in lower case, as
-a user is likely to type them.  Internally, they are normally stored
-upper case only.
-
-\node Integers, Floats, Symbols, Data Types
-\subsection{Integers}
-
-The \tindexed{fixnum} type is equivalent to \code{(signed-byte 30)}.
-Integers outside this range are represented as a \tindexed{bignum} or a word
-integer (\pxlref{word-integers}.)  Almost all integers that appear in
-programs can be represented as a \code{fixnum}, so integer number
-consing is rare.
-
-\node Floats, Characters, Integers, Data Types
-\subsection{Floats}
-\label{ieee-float}
-
-\cmucl{} supports two floating point formats: \tindexed{single-float} and
-\tindexed{double-float}.  These are implemented with IEEE single and
-double float arithmetic, respectively.  \code{short-float} is a
-synonym for \code{single-float}, and \code{long-float} is a synonym
-for \code{double-float}.  The initial value of
-\vindexed{read-default-float-format} is \code{single-float}.
-
-Both \code{single-float} and \code{double-float} are represented with a pointer
-descriptor, so float operations can cause number consing.  Number consing is
-greatly reduced if programs are written to allow the use of non-descriptor
-representations (\pxlref{numeric-types}.)
-
-
-\begin{menu}
-* IEEE Special Values::         
-* Negative Zero::               
-* Denormalized Floats::         
-* Floating Point Exceptions::   
-* Floating Point Rounding Mode::  
-* Accessing the Floating Point Modes::  
-\end{menu}
-
-\node IEEE Special Values, Negative Zero, Floats, Floats
-\subsubsection{IEEE Special Values}
-
-\cmucl{} supports the IEEE infinity and NaN special values.  These non-numeric
-values will only be generated when trapping is disabled for some floating point
-exception (\pxlref{float-traps}), so users of the default
-configuration need not concern themselves with special values.
-
-\defconst{short-float-positive-infinity}[extensions]
-\defconstx{short-float-negative-infinity}[extensions]
-\defconstx{single-float-positive-infinity}[extensions]
-\defconstx{single-float-negative-infinity}[extensions]
-\defconstx{double-float-positive-infinity}[extensions]
-\defconstx{double-float-negative-infinity}[extensions]
-\defconstx{long-float-positive-infinity}[extensions]
-\defconstx{long-float-negative-infinity}[extensions]
-The values of these constants are the IEEE positive and negative infinity
-objects for each float format.
-\enddefconst
-
-\defun{float-infinity-p}[extensions]{\args{\var{x}}}
-This function returns true if \var{x} is an IEEE float infinity (of either sign.)
-\var{x} must be a float.
-\enddefun
-
-\defun{float-nan-p}[extensions]{\args{\var{x}}}
-\defunx{float-trapping-nan-p}[extensions]{\args{\var{x}}}
-\code{float-nan-p} returns true if \var{x} is an IEEE NaN (Not A Number) object.
-\code{float-trapping-nan-p} returns true only if \var{x} is a trapping NaN.  With 
-either function, \var{x} must be a float.
-\enddefun
-
-\node Negative Zero, Denormalized Floats, IEEE Special Values, Floats
-\subsubsection{Negative Zero}
-
-The IEEE float format provides for distinct positive and negative
-zeros.  To test the sign on zero (or any other float), use the
-\clisp{} \findexed{float-sign} function.  Negative zero prints as
-\code{-0.0f0} or \code{-0.0d0}.
-
-\node Denormalized Floats, Floating Point Exceptions, Negative Zero, Floats
-\subsubsection{Denormalized Floats}
-
-\cmucl{} supports IEEE denormalized floats.  Denormalized floats provide a
-mechanism for gradual underflow.  The \clisp{}
-\findexed{float-precision} function returns the actual precision of a
-denormalized float, which will be less than \findexed{float-digits}.  Note
-that in order to generate (or even print) denormalized floats,
-trapping must be disabled for the underflow exception
-(\pxlref{float-traps}.)  The \clisp{}
-\w{\code{least-positive-}\var{format}-\code{float}} constants are
-denormalized.
-
-\defun{float-normalized-p}[extensions]{\args{\var{x}}}
-This function returns true if \var{x} is a denormalized float.  \var{x} must be a
-float.
-\enddefun
-
-\node Floating Point Exceptions, Floating Point Rounding Mode, Denormalized Floats, Floats
-\subsubsection{Floating Point Exceptions}
-\label{float-traps}
-
-The IEEE floating point standard defines several exceptions that occur when the
-result of a floating point operation is unclear or undesirable.  Exceptions can
-be ignored, in which case some default action is taken, such as returning a
-special value.  When trapping is enabled for an exception, a error is signalled
-whenever that exception occurs.  These are the possible floating point
-exceptions:
-\begin{description}
-
-\item[\kwd{underflow}] This exception occurs when the result of an
-operation is too small to be represented as a normalized float in its
-format.  If trapping is enabled, the
-\tindexed{floating-point-underflow} condition is signalled.
-Otherwise, the operation results in a denormalized float or zero.
-
-\item[\kwd{overflow}] This exception occurs when the result of an
-operation is too large to be represented as a float in its format.
-If trapping is enabled, the \tindexed{floating-point-overflow}
-exception is signalled.  Otherwise, the operation results in the
-appropriate infinity.
-
-\item[\kwd{inexact}]
-This exception occurs when the result of a floating point
-operation is not exact, i.e. the result was rounded.  If trapping is enabled,
-the \code{extensions:floating-point-inexact} condition is signalled.  Otherwise,
-the rounded result is returned.
-
-\item[\kwd{invalid}]
-This exception occurs when the result of an operation is
-ill-defined, such as \code{\w{(/ 0.0 0.0)}}.  If trapping is enabled, the
-\code{extensions:floating-point-invalid} condition is signalled.  Otherwise, a
-quiet NaN is returned.
-
-\item[\kwd{divide-by-zero}]
-This exception occurs when a float is divided by zero.
-If trapping is enabled, the \tindexed{divide-by-zero} condition is signalled.
-Otherwise, the appropriate infinity is returned.
-\end{description}
-
-\node Floating Point Rounding Mode, Accessing the Floating Point Modes, Floating Point Exceptions, Floats
-\subsubsection{Floating Point Rounding Mode}
-\label{float-rounding-modes}
-
-IEEE floating point specifies four possible rounding modes:
-\begin{description}
-
-\item[\kwd{nearest}] In this mode, the inexact results are rounded to
-the nearer of the two possible result values.  If the neither
-possibility is nearer, then the even alternative is chosen.  This
-form of rounding is also called "round to even", and is the form of
-rounding specified for the \clisp{} \findexed{round} function.
-
-\item[\kwd{positive-infinity}] This mode rounds inexact results to
-the possible value closer to positive infinity.  This is analogous to
-the \clisp{} \findexed{ceiling} function.
-
-\item[\kwd{negative-infinity}] This mode rounds inexact results to
-the possible value closer to negative infinity.  This is analogous to
-the \clisp{} \findexed{floor} function.
-
-\item[\kwd{zero}]
-This mode rounds inexact results to the possible value closer to
-zero.  This is analogous to the \clisp{} \findexed{truncate} function.
-\end{description}
-
-\paragraph{Warning:}
-
-Although the rounding mode can be changed with
-\code{set-floating-point-modes}, use of any value other than the
-default (\kwd{nearest}) can cause unusual behavior, since it will
-affect rounding done by \llisp{} system code as well as rounding in
-user code.  In particular, the unary \code{round} function will stop
-doing round-to-nearest on floats, and instead do the selected form of
-rounding.
-
-\node Accessing the Floating Point Modes,  , Floating Point Rounding Mode, Floats
-\subsubsection{Accessing the Floating Point Modes}
-
-These functions can be used to modify or read the floating point modes:
-
-\defun{set-floating-point-modes}[extensions]{
-       \keys{:traps :rounding-mode}
-       \morekeys{:fast-mode :accrued-exceptions}
-       \yetmorekeys{:current-exceptions}}
-\defunx{get-floating-point-modes}[extensions]{}
-The keyword arguments to \code{set-floating-point-modes} set various modes
-controlling how floating point arithmetic is done:
-\begin{description}
-
-\item[\kwd{traps}]
-A list of the exception conditions that should cause traps.
-Possible exceptions are \kwd{underflow}, \kwd{overflow}, \kwd{inexact},
-\kwd{invalid} and \kwd{divide-by-zero}.  Initially all traps except
-\kwd{inexact} are enabled.  \xlref{float-traps}.
-
-\item[\kwd{rounding-mode}] The rounding mode to use when the result is
-not exact.  Possible values are \kwd{nearest}, \kwd{positive-infinity},
-\kwd{negative-infinity} and \kwd{zero}.  Initially, the rounding mode is
-\kwd{nearest}.  See the warning in section \ref{float-rounding-modes}
-about use of other rounding modes.
-
-\item[\kwd{current-exceptions}, \kwd{accrued-exceptions}]
-Lists of exception keywords used to set the
-exception flags.  The \var{current-exceptions} are the exceptions for the
-previous operation, so setting it is not very useful.  The
-\var{accrued-exceptions} are a cumulative record of the exceptions that occurred
-since the last time these flags were cleared.  Specifying \code{()} will clear any
-accrued exceptions.
-
-\item[\kwd{fast-mode}]
-Set the hardware's "fast mode" flag, if any.  When set, IEEE
-conformance or debuggability may be impaired.  Some machines may not have this
-feature, in which case the value is always \false.  No currently supported
-machines have a fast mode.
-\end{description}
-If a keyword argument is not supplied, then the associated state is not
-changed.
-
-\code{get-floating-point-modes} returns a list representing the state of the
-floating point modes.  The list is in the same format as the keyword arguments
-to \code{set-floating-point-modes}, so \code{apply} could be used with
-\code{set-floating-point-modes} to restore the modes in effect at the time of the
-call to \code{get-floating-point-modes}.
-\enddefun
-
-
-\node Characters, Array Initialization, Floats, Data Types
-\subsection{Characters}
-
-\cmucl{} implements characters according to \i{Common Lisp: the Language II}.
-The main difference from the first version is that character bits and
-font have been eliminated, and the names of the types have been
-changed.  \tindexed{base-character} is the new equivalent of the old
-\tindexed{string-char}.  In this implementation, all characters are base
-characters (there are no extended characters.)  Character codes range
-between \code{0} and \code{255}, using the ASCII encoding.
-
-
-\node Array Initialization,  , Characters, Data Types
-\subsection{Array Initialization}
-
-If no \code{:initial-value} is specified, arrays are initialized to zero.
-
-
-\node Default Interrupts for Lisp, Packages, Data Types, Design Choices and Extensions
-\section{Default Interrupts for Lisp}
-
-CMU Common Lisp has several interrupt handlers defined when it starts up,
-as follows:
-\begin{description}
-
-\item[\code{SIGINT} (\ctrl{c})]
-causes Lisp to enter a break loop.  This puts you into the debugger
-which allows you to look at the current state of the computation.  If you
-proceed from the break loop, the computation will proceed from where it was
-interrupted.
-
-\item[\code{SIGQUIT} (\ctrl{\\})]
-causes Lisp to do a throw to the top-level.  This causes the current
-computation to be aborted, and control returned to the top-level
-read-eval-print loop.
-
-\item[\code{SIGTSTP} (\ctrl{z})]
-causes Lisp to suspend execution and return to the Unix shell.  If
-control is returned to Lisp, the computation will proceed from where it was
-interrupted.
-
-\item[\code{SIGILL}, \code{SIGBUS}, \code{SIGSEGV}, and \code{SIGFPE}]
-cause Lisp to signal an error.
-\end{description}
-For keyboard interrupt signals, the standard interrupt character is in
-parentheses.  Your \file{.login} may set up different interrupt
-characters.  When a signal is generated, there may be some delay before
-it is processed since Lisp cannot be interrupted safely in an arbitrary
-place.  The computation will continue until a safe point is reached and
-then the interrupt will be processed.  \xlref{signal-handlers} to define
-your own signal handlers.
-
-\node Packages, The Editor, Default Interrupts for Lisp, Design Choices and Extensions
-\section{Packages}
-
-When CMU Common Lisp is first started up, the default package is the
-\code{user} package.  The \code{user} package uses the
-\code{common-lisp}, \code{extensions}, and
-\code{pcl} packages.  The symbols exported from these three packages can be
-referenced without package qualifiers.  This section describes packages which
-have exported interfaces that may concern users.  The numerous internal
-packages which implement parts of the system are not described here.  Package
-nicknames are in parenthesis after the full name.  
-\begin{description}
-\item[\code{alien}, \code{c-call}] Export the features of the Alien foreign
-data structure facility (\pxlref{aliens}.)
-
-\item[\code{pcl}]
-This package contains PCL (Portable CommonLoops), which is a portable
-implementation of CLOS (the Common Lisp Object System.)  This implements
-most (but not all) of the features in the CLOS chapter of \cltl2.
-
-\item[\code{debug}] 
-The \code{debug} package contains the command-line oriented
-debugger.  It exports utility various functions and switches.
-
-\item[\code{debug-internals}] The \code{debug-internals} package exports the
-primitives used to write debuggers.  \xlref{debug-internals}.
-
-\item[\code{extensions (ext)}]
-The \code{extensions} packages exports local extensions
-to Common Lisp that are documented in this manual.  Examples include the
-\code{save-lisp} function and time parsing.
-
-\item[\code{hemlock (ed)}]
-The \code{hemlock} package contains all the code to implement
-Hemlock commands.  The \code{hemlock} package currently exports no symbols.
-
-\item[\code{hemlock-internals (hi)}]
-The \code{hemlock-internals} package contains code
-that implements low level primitives and exports those symbols used to
-write Hemlock commands.
-
-\item[\code{keyword}]
-The \code{keyword} package contains keywords (e.g., \kwd{start}).
-All symbols in the \code{keyword} package are exported and evaluate to
-themselves (i.e., the value of the symbol is the symbol itself).
-
-\item[\code{profile}] The \code{profile} package exports a simple run-time profiling
-facility (\pxlref{profiling}).
-
-\item[\code{common-lisp (cl lisp)}]
-The \code{common-lisp} package exports all the symbols defined by \i{Common
-Lisp: the Language} and only those symbols.  Strictly portable Lisp code
-will depend only on the symbols exported from the \code{lisp} package.
-
-\item[\code{unix}, \code{mach}]
-These packages export system call interfaces to generic BSD Unix and Mach
-(\pxlref{unix-interface}).
-
-\item[\code{system (sys)}]
-The \code{system} package contains functions and information necessary for system
-interfacing.   This package is used by the \code{lisp} package and exports several
-symbols that are necessary to interface to system code.
-
-\item[\code{common-lisp-user (user cl-user)}]
-The \code{common-lisp-user} package is the default package and is where a user's
-code and data is placed unless otherwise specified.  This package exports no
-symbols.
-
-\item[\code{xlib}]
-The \code{xlib} package contains the Common Lisp X interface (CLX)
-to the X11 protocol.  This is mostly Lisp code with a couple of functions
-that are defined in C to connect to the server.
-
-\item[\code{wire}] The \code{wire} package exports a remote procedure call facility
-(\pxlref{remote}).
-\end{description}
-
-
-\node The Editor, Garbage Collection, Packages, Design Choices and Extensions
-\section{The Editor}
-
-The \code{ed} function invokes the Hemlock editor which is described in \i{Hemlock
-User's Manual} and \i{Hemlock Command Implementor's Manual}.  Most users at CMU
-prefer to use Hemlock's slave \Llisp{} mechanism which provides an interactive
-buffer for the \code{read-eval-print} loop and editor commands for evaluating and
-compiling text from a buffer into the slave \Llisp.  Since the editor runs in
-the \Llisp, using slaves keeps users from trashing their editor by developing
-in the same \Llisp{} with \Hemlock.
-
-
-\node Garbage Collection, Describe, The Editor, Design Choices and Extensions
-\section{Garbage Collection}
-
-CMU Common Lisp uses a stop-and-copy garbage collector that compacts the items
-in dynamic space every time it runs.  Most users cause the system to garbage
-collect (GC) frequently, long before space is exhausted.  With 16 or 24
-megabytes of memory, causing GC's more frequently on less garbage allows the
-system to GC without much (if any) paging.
-
-\hide{ 
-With the default value for the following variable, you can expect a GC to take
-about one minute of elapsed time on a 6 megabyte machine running X as well as
-Lisp.  On machines with 8 megabytes or more of memory a GC should run without
-much (if any) paging.  GC's run more frequently but tend to take only about 5
-seconds.
-}
-
-The following functions invoke the garbage collector or control whether
-automatic garbage collection is in effect:
-
-\defun{gc}[extensions]{}
-This function runs the garbage collector.  If \code{ext:*gc-verbose*} is non-\nil,
-then it invokes \code{ext:*gc-notify-before*} before GC'ing and
-\code{ext:*gc-notify-after*} afterwards.
-\enddefun
-
-\defun{gc-off}[extensions]{}
-This function inhibits automatic garbage collection.  After calling it, the
-system will not GC unless you call \code{ext:gc} or \code{ext:gc-on}.
-\enddefun
-
-\defun{gc-on}[extensions]{}
-This function reinstates automatic garbage collection.  If the system
-would have GC'ed while automatic GC was inhibited, then this will call
-\code{ext:gc}.
-\enddefun
-
-
-The following variables control the behavior of the garbage collector:
-
-\defvar{bytes-consed-between-gcs}[extensions]
-CMU Common Lisp automatically GC's whenever the amount of memory allocated to
-dynamic objects exceeds the value of an internal variable.  After each GC, the
-system sets this internal variable to the amount of dynamic space in use at
-that point plus the value of the variable \code{ext:*bytes-consed-between-gcs*}.
-The default value is 2000000.
-\enddefvar
-
-\defvar{gc-verbose}[extensions]
-This variable controls whether \code{ext:gc} invokes the functions in
-\code{ext:*gc-notify-before*} and \code{ext:*gc-notify-after*}.  If
-\code{*gc-verbose*} is \nil, \code{ext:gc} foregoes printing any
-messages.  The default value is \code{T}.
-\enddefvar
-
-\defvar{gc-notify-before}[extensions]
-This variable's value is a function that should notify the user that the system
-is about to GC.  It takes one argument, the amount of dynamic space in use
-before the GC measured in bytes.  The default value of this variable is a
-function that prints a message similar to the following:
-\begin{display}
-\b{[GC threshold exceeded with 2,107,124 bytes in use.  Commencing GC.]}
-\end{display}
-\enddefvar
-
-\defvar{gc-notify-after}[extensions]
-This variable's value is a function that should notify the user when a GC
-finishes.  The function must take three arguments, the amount of dynamic spaced
-retained by the GC, the amount of dynamic space freed, and the new threshold
-which is the minimum amount of space in use before the next GC will occur.  All
-values are byte quantities.  The default value of this variable is a function
-that prints a message similar to the following:
-\begin{display}
-\b{[GC completed with 25,680 bytes retained and 2,096,808 bytes freed.]}
-\b{[GC will next occur when at least 2,025,680 bytes are in use.]}
-\end{display}
-\enddefvar
-
-Note that a garbage collection will not happen at exactly the new threshold
-printed by the default \code{ext:*gc-notify-after*} function.  The system
-periodically checks whether this threshold has been exceeded, and only then
-does a garbage collection.
-
-\defvar{gc-inhibit-hook}[extensions]
-This variable's value is either a function of one argument or \nil.  When the
-system has triggered an automatic GC, if this variable is a function, then the
-system calls the function with the amount of dynamic space currently in use
-(measured in bytes).  If the function returns \nil, then the GC occurs;
-otherwise, the system inhibits automatic GC as if you had called
-\code{ext:gc-off}.  The writer of this hook is responsible for knowing when
-automatic GC has been turned off and for calling or providing a way to call
-\code{ext:gc-on}.  The default value of this variable is \nil.
-\enddefvar
-
-\defvar{before-gc-hooks}[extensions]
-\defvarx{after-gc-hooks}[extensions]
-These variables' values are lists of functions to call before or after any GC
-occurs.  The system provides these purely for side-effect, and the functions
-take no arguments.
-\enddefvar
-
-
-\node Describe, The Inspector, Garbage Collection, Design Choices and Extensions
-\section{Describe}
-
-In addition to the basic function described below, there are a number of
-switches and other things that can be used to control \code{describe}'s
-behavior.
-
-\defun{describe}{ \args{\var{object} \&optional{} \var{stream}}}
-The \code{describe} function prints useful information about \var{object}
-on \var{stream}, which defaults to \code{*standard-output*}.  For any
-object, \code{describe} will print out the type.  Then it prints other
-information based on the type of \var{object}.  The types which are
-presently handled are:
-
-\begin{description}
-
-\item[\tindexed{hash-table}]
-\code{describe} prints the number of entries currently
-in the hash table and the number of buckets currently allocated.
-
-\item[\tindexed{function}]
-\code{describe} prints a list of the function's name (if any) and
-its formal parameters.  If the name has function documentation, then it will be
-printed.  If the function is compiled, then the file where it is defined will
-be printed as well.
-
-\item[\tindexed{fixnum}]
-\code{describe} prints whether the integer is prime or not.
-
-\item[\tindexed{symbol}]
-The symbol's value, properties, and documentation are printed.  If
-the symbol has a function definition, then the function is described.
-\end{description}
-If there is anything interesting to be said about some component of
-the object, describe will invoke itself recursively to describe that
-object.  The level of recursion is indicated by indenting output.
-\enddefun
-
-\defvar{describe-level}[extensions]
-The maximum level of recursive description allowed.  Initially two.
-\enddefvar
-
-\defvar{describe-indentation}[extensions]
-The number of spaces to indent for each level of recursive
-description, initially three.
-\enddefvar
-
-\defvar{describe-print-level}[extensions]
-\defvarx{describe-print-length}[extensions]
-The values of \code{*print-level*} and \code{*print-length*} during
-description.  Initially two and five.
-\enddefvar
-
-\node The Inspector, Load, Describe, Design Choices and Extensions
-\section{The Inspector}
-
-\cmucl{} has both a graphical inspector that uses X windows and a simple
-terminal-based inspector.
-
-\defun{inspect}{ \args{\&optional{} \var{object}}}
-\code{Inspect} calls the inspector on the optional argument \var{object}.  If
-\var{object} is unsupplied, \code{inspect} immediately returns \false.
-Otherwise, the behavior of inspect depends on whether Lisp is running
-under X.  When \code{inspect} is eventually exited, it returns some
-selected Lisp object.
-\enddefun
-
-\begin{menu}
-* The Windowing Inspector::     
-* The TTY Inspector::           
-\end{menu}
-
-\node The Windowing Inspector, The TTY Inspector, The Inspector, The Inspector
-\subsection{The Windowing Inspector}
-
-If X is available, \code{inspect} creates an X window and displays
-\var{object} in the window.  While \code{inspect} is running and the
-cursor is in the inspector's X window, mouse clicks and keyboard input
-have the following meaning:
-\begin{description}
-
-\item[Left]
-When the left mouse button is clicked over a component object, that
-object will be inspected in the current inspector window.
-
-\item[Middle]
-When the middle mouse button is clicked over a component object,
-\code{inspect} is exited returning the component as the result.  All the new
-inspector windows are deleted.
-
-\item[Shift Middle]
-When the shift key is depressed and the middle mouse button is
-clicked over a component object, \code{inspect} exits and returns the component
-as the result.  All the inspector windows are left displayed on the screen.
-
-\item[Right]
-When the right mouse button is clicked over a component object,
-that object will be inspected in a new inspector window.
-
-\item[d, D]
-When either d or D is typed, the current window is
-deleted.  If there are no more windows, then \code{inspect} exits and returns the
-original \var{object}.
-
-\item[h, H, ?]
-When any of h, H, or ? are typed while in an inspector window, a
-new window with help information is displayed.
-
-\item[m, M]
-When either m or M is typed, a component object may be modified.  The
-cursor changes to an arrow with an M beside it.  Clicking any mouse button
-while the mouse is over a component will select that component as the
-destination for modification.  If m was typed, the source object is also
-selected by the mouse which is indicated by an S beside the arrow in the
-cursor.  If M was typed, the source object will be prompted for on the
-*query-io* stream.  The source object replaces the destination object.
-While choosing the destination or source with the mouse, the operation can
-be aborted by type q or Q.
-
-\item[q, Q]
-When either q or Q is typed, \code{inspect} exits and
-returns the original \var{object}.  All new inspector windows are deleted.
-
-\item[p, P]
-When either p or P is typed, \code{inspect} exits and
-returns the original \var{object}.  All the inspector windows are left on the
-screen.
-
-\item[r, R]
-When either r or R is typed, the current inspector display is
-recomputed.  This is necessary to maintain a consistent display for an
-object that may have changed since the display was originally computed.
-
-\item[u, U]
-When either u or U is typed, the object of which the current object
-is a component is displayed.  This is the inverse operation to clicking the
-left mouse button over a component object.  If the window is currently
-displaying the top level object, nothing changes.
-\end{description}
-When the cursor is over a component object, the object is highlighted with a
-surrounding box.
-
-
-\node The TTY Inspector,  , The Windowing Inspector, The Inspector
-\subsection{The TTY Inspector}
-
-If X is unavailable, a terminal inspector is invoked.  The TTY inspector
-is a crude interface to \code{describe} which allows objects to be
-traversed and maintains a history.  This inspector prints information
-about and object and a numbered list of the components of the object.
-The command-line based interface is a normal
-\code{read}--\code{eval}--\code{print} loop, but an integer \var{n}
-descends into the \var{n}'th component of the current object, and
-symbols with these special names are interpreted as commands:
-\begin{description}
-\item[U] Move back to the enclosing object.  As you descend into the
-components of an object, a stack of all the objects previously seen is
-kept.  This command pops you up one level of this stack.
-
-\item[Q, E] Return the current object from \code{inspect}.
-
-\item[R] Recompute object display, and print again.  Useful if the
-object may have changed.
-
-\item[D] Display again without recomputing.
-
-\item[H, ?] Show help message.
-\end{description}
-
-\node Load, The Reader, The Inspector, Design Choices and Extensions
-\section{Load}
-
-\defun{load}{\var{filename} \keys{:verbose :print :if-does-not-exist}
-	     \morekeys{:if-source-newer :contents}}
-As in standard Common Lisp, this function loads a file containing source or
-object code into the running Lisp.  Several CMU extensions have been made to
-\code{load} to conveniently support a variety of program file organizations.
-\var{filename} may be a wildcard pathname such as 
-\file{*.lisp}, in which case all matching files are loaded.
-
-If \var{filename} has a \code{pathname-type} (or extension), then that exact
-file is loaded.  If the file has no extension, then this tells \code{load} to
-use a heuristic to load the ``right'' file.  The
-\code{*load-source-types*} and \code{*load-object-types*} variables below are
-used to determine the default source and object file types.  If only the source
-or the object file exists (but not both), then that file is quietly loaded.
-Similarly, if both the source and object file exist, and the object file is
-newer than the source file, then the object file is loaded.
-The value of the \var{if-source-newer} argument is used to determine what
-action to take when both the source and object files exist, but the object file
-is out of date:
-\begin{description}
-\item[:load-object]
-The object file is loaded even though the source file is
-newer.
-
-\item[:load-source]
-The source file is loaded instead of the older object file.
-
-\item[:compile]
-The source file is compiled and then the new object file is
-loaded.
-
-\item[:query]
-The user is asked a yes or no question to determine whether the
-source or object file is loaded.
-\end{description}
-This argument defaults to the value of \code{ext:*load-if-source-newer*}
-(initially \code{:load-object}.)
-
-The \var{contents} argument can be used to override the heuristic (based on the
-file extension) that normally determines whether to load the file as a source
-file or an object file.  If non-null, this argument must be either
-\code{:source} or \code{:binary}, which forces loading in source and binary
-mode, respectively. You really shouldn't ever need to use this argument.
-\enddefun
-
-\defvar{load-source-types}[extensions]
-\defvarx{load-object-types}[extensions]
-These variables are lists of possible \code{pathname-type} values for source
-and object files to be passed to \code{load}.  These variables are only used
-when the file passed to \code{load} has no type; in this case, the possible
-source and object types are used to default the type in order to determine the
-names of the source and object files.
-\enddefvar
-
-\defvar{load-if-source-newer}[extensions]
-This variable determines the default value of the \var{if-source-newer}
-argument to \code{load}.  Its initial value is \code{:load-object}.
-\enddefvar
-
-\node The Reader, Running Programs from Lisp, Load, Design Choices and Extensions
-\section{The Reader}
-
-\defvar{ignore-extra-close-parentheses}[extensions]
-If this variable is \true{} (the default), then the reader merely prints a
-warning when an extra close parenthesis is detected (instead of signalling an
-error.)
-\enddefvar
-
-
-
-\node Running Programs from Lisp, Saving a Core Image, The Reader, Design Choices and Extensions
-\section{Running Programs from Lisp}
-
-It is possible to run programs from Lisp by using the following function.
-
-\defun{run-program}[extensions]{
-       \args{\var{program} \var{args}}
-       \keys{:env :wait :pty :input}
-       \morekeys{:if-input-does-not-exist}
-       \yetmorekeys{:output ...}}
-
-\code{Run-program} runs \var{program} in a child process.
-\var{Program} should be a pathname or string naming the program.
-\var{Args} should be a list of strings which this passes to
-\var{program} as normal Unix parameters.  For no arguments, specify
-\var{args} as \nil.  The value returned is either a process structure or
-\nil.  The process interface follows the description of
-\code{run-program}.  If \code{run-program} fails to fork the child
-process, it returns \nil.
-
-Except for sharing file descriptors as explained in keyword argument
-descriptions, \code{run-program} closes all file descriptors in the
-child process before running the program.  When you are done using a
-process, call \code{process-close} to reclaim system resources.  You
-only need to do this when you supply \kwd{stream} for one of
-\kwd{input}, \kwd{output}, or \kwd{error}, or you supply
-\kwd{pty} non-\nil.  You can call \code{process-close} regardless of
-whether you must to reclaim resources without penalty if you feel safer.
-
-\code{run-program} accepts the following keyword arguments:
-\begin{description}
-
-\item[\kwd{env}]
-This is an a-list mapping keywords and simple-strings.  The default
-is \code{ext:*environment-list*}.  If \kwd{env} is specified, \code{run-program} uses
-the value given and does not combine the environment passed to Lisp with the
-one specified.
-
-\item[\kwd{wait}]
-If non-\nil{} (the default), wait until the child process terminates.
-If \nil, continue running Lisp while the child process runs.
-
-\item[\kwd{pty}]
-This should be one of \true, \nil, or a stream.  If specified
-non-\nil, the subprocess executes under a Unix \i{PTY}.  If specified as a
-stream, the system collects all output to this pty and writes it to this
-stream.  If specified as \true, the \code{process-pty} slot contains a stream from
-which you can read the program's output and to which you can write input for
-the program.  The default is \nil.
-
-\item[\kwd{input}]
-This specifies how the program gets its input.  If specified as a
-string, it is the name of a file that contains input for the child process.
-\code{run-program} opens the file as standard input.  If specified as \nil{} (the
-default), then standard input is the file \file{/dev/null}.  If specified as
-\true, the program uses the current standard input.  This may cause some
-confusion if \kwd{wait} is \nil{} since two processes may use the terminal at the
-same time.  If specified as \kwd{stream}, then the \code{process-input} slot
-contains an output stream.  Anything written to this stream goes to the program
-as input.  \i{:Input} may also be an input stream that already contains all the
-input for the process.  In this case \code{run-program} reads all the input from
-this stream before returning, so this cannot be used to interact with the
-process.
-
-\item[\kwd{if-input-does-not-exist}]
-This specifies what to do if the input file does
-not exist.  The following values are valid: \nil{} (the default) causes
-\code{run-program} to return \nil{} without doing anything; \kwd{create} creates the
-named file; and \kwd{error} signals an error.
-
-\item[\kwd{output}]
-This specifies what happens with the program's output.  If
-specified as a pathname, it is the name of a file that contains output the
-program writes to its standard output.  If specified as \nil{} (the default), all
-output goes to \file{/dev/null}.  If specified as \true, the program writes to
-the Lisp process's standard output.  This may cause confusion if \kwd{wait} is
-\nil{} since two processes may write to the terminal at the same time.  If
-specified as \kwd{stream}, then the \code{process-output} slot contains an input
-stream from which you can read the program's output.
-
-\item[\kwd{if-output-exists}]
-This specifies what to do if the output file already
-exists.  The following values are valid: \nil{} causes \code{run-program} to return
-\nil{} without doing anything; \kwd{error} (the default) signals an error;
-\kwd{supersede} overwrites the current file; and \kwd{append} appends all output
-to the file.
-
-\item[\kwd{error}]
-This is similar to \kwd{output}, except the file becomes the
-program's standard error.  Additionally, \kwd{error} can be \kwd{output} in which
-case the program's error output is routed to the same place specified for
-\kwd{output}.  If specified as \kwd{stream}, the \code{process-error} contains a
-stream similar to the \code{process-output} slot when specifying the \kwd{output}
-argument.
-
-\item[\kwd{if-error-exists}]
-This specifies what to do if the error output file
-already exists.  It accepts the same values as \kwd{if-output-exists}.
-
-\item[\kwd{status-hook}]
-This specifies a function to call whenever the process
-changes status.  This is especially useful when specifying \kwd{wait} as \nil.
-The function takes the process as a required argument.
-
-\item[\kwd{before-execve}]
-This specifies a function to run in the child process
-before it becomes the program to run.  This is useful for actions such as
-authenticating the child process without modifying the parent Lisp process.
-\end{description}
-
-\enddefun
-
-
-\begin{menu}
-* Process Accessors::           
-\end{menu}
-
-\node Process Accessors,  , Running Programs from Lisp, Running Programs from Lisp
-\subsection{Process Accessors}
-
-The following functions interface the process returned by \code{run-program}:
-
-\defun{process-p}[extensions]{\args{\var{thing}}}
-This function returns \true{} if \var{thing} is a process.  Otherwise it returns
-\nil{}
-\enddefun
-
-\defun{process-pid}[extensions]{\args{\var{process}}}
-This function returns the process ID, an integer, for the \var{process}.
-\enddefun
-
-\defun{process-status}[extensions]{\args{\var{process}}}
-This function returns the current status of \var{process}, which is one of
-\code{:running}, \code{:stopped}, \code{:exited}, or \code{:signaled}.
-\enddefun
-
-\defun{process-exit-code}[extensions]{\args{\var{process}}}
-This function returns either the exit code for \var{process}, if it is
-\code{:exited}, or the termination signal \var{process} if it is \code{:signaled}.  The
-result is undefined for processes that are still alive.
-\enddefun
-
-\defun{process-core-dumped}[extensions]{\args{\var{process}}}
-This function returns \true{} if someone used a Unix signal to terminate the
-\var{process} and caused it to dump a Unix core image.
-\enddefun
-
-\defun{process-pty}[extensions]{\args{\var{process}}}
-This function returns either the two-way stream connected to
-\var{process}'s Unix
-\i{PTY} connection or \nil{} if there is none.
-\enddefun
-
-\defun{process-input}[extensions]{\args{\var{process}}}
-\defunx{process-output}[extensions]{\args{\var{process}}}
-\defunx{process-error}[extensions]{\args{\var{process}}}
-If the corresponding stream was created, these functions return the
-input, output or error file descriptor.  \nil{} is returned if there is
-no stream.
-\enddefun
-
-\defun{process-status-hook}[extensions]{\args{\var{process}}}
-This function returns the current function to call whenever \var{process}'s
-status changes.  This function takes the \var{process} as a required argument.
-\code{process-status-hook} is \code{setf}'able.
-\enddefun
-
-\defun{process-plist}[extensions]{\args{\var{process}}}
-This function returns annotations supplied by users, and it is \code{setf}'able.
-This is available solely for users to associate information with \var{process}
-without having to build a-lists or hash tables of process structures.
-\enddefun
-
-\defun{process-wait}[extensions]{
-        \args{\var{process} \&optional{} \var{check-for-stopped}}}
- This function waits for \var{process} to finish.  If \var{check-for-stopped} is
-non-\nil, this also returns when \var{process} stops.
-\enddefun
-
-\defun{process-kill}[extensions]{
-        \args{\i{process signal} \&optional{} \var{whom}}}
- This function sends the Unix \var{signal} to \var{process}.  \var{Signal} should be
-the number of the signal or a keyword with the Unix name (for example,
-\kwd{sigsegv}).  \var{Whom} should be one of the following:
-\begin{description}
-
-\item[\kwd{pid}]
-This is the default, and it indicates sending the signal to
-\var{process} only.
-
-\item[\kwd{process-group}]
-This indicates sending the signal to \var{process}'s group.
-
-\item[\kwd{pty-process-group}]
-This indicates sending the signal to the process group
-currently in the foreground on the Unix \i{PTY} connected to \var{process}.  This
-last option is useful if the running program is a shell, and you wish to signal
-the program running under the shell, not the shell itself.  If \code{process-pty}
-of \var{process} is \nil, using this option is an error.
-\end{description}
-\enddefun
-
-\defun{process-alive-p}[extensions]{\args{\var{process}}}
-This function returns \true{} if \var{process}'s status is either \code{:running} or
-\code{:stopped}.
-\enddefun
-
-\defun{process-close}[extensions]{\args{\var{process}}}
-This function closes all the streams associated with \var{process}.  When you are
-done using a process, call this to reclaim system resources.
-\enddefun
-
-
-\node Saving a Core Image, Search Lists, Running Programs from Lisp, Design Choices and Extensions
-\section{Saving a Core Image}
-
-A mechanism has been provided to save a running Lisp core image and to
-later restore it.  This is convenient if you don't want to load several files
-into a Lisp when you first start it up.  The main problem is the large
-size of each saved Lisp image, typically at least 20 megabytes.
-
-\defun{save-lisp}[extensions]{
-       \args{\var{file}}
-       \keys{:purify :root-structures :init-function}
-       \morekeys{:load-init-file :print-herald}
-       \yetmorekeys{:process-command-line}}
-The \code{save-lisp} function saves the state of the currently running Lisp
-core image in \var{file}.  The keyword arguments have the following meaning:
-\begin{description}
-
-\item[\kwd{purify}]
-If non-NIL (the default), the core image is purified before it is
-saved.  This means moving accessible Lisp objects from dynamic space into
-read-only and static space.  This reduces the amount of work the garbage
-collector must do when the resulting core image is being run.  Also, if
-more than one Lisp is running on the same machine, this maximizes the
-amount of memory that can be shared between the two processes.  Objects in
-read-only and static space can never be reclaimed, even if all pointers to
-them are dropped.
-
-\item[\kwd{root-structures}]
-This should be a list of the main entry points for
-the resulting core image.  The purification process tries to localize
-symbols, functions, etc., in the core image so that paging performance
-is improved.  The default value is NIL which means that Lisp objects will
-still be localized but probably not as optimally as they could be.  This
-argument has no meaning if \kwd{purify} is NIL.
-
-\item[\kwd{init-function}]
-This is a function which is called when the saved core 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 \code{save-lisp}.
-
-\item[\kwd{load-init-file}]
-If non-NIL, then load an init file; either the one
-specified on the command line or \w{"\file{init.}\var{fasl-type}"}, or, if
-\w{"\file{init.}\var{fasl-type}"} does not exist, \code{init.lisp} from the user's
-home directory.  If the init file is found, it is loaded into the resumed core
-file before the read-eval-print loop is entered.
-
-\item[\kwd{print-herald}]
-If non-NIL, then print out the standard Lisp herald when
-starting.
-
-\item[\kwd{process-command-line}]
-If non-NIL, processes the command line switches
-and performs the appropriate actions.
-\end{description}
-\enddefun
-
-To resume a saved file, type:
-\begin{example}
-lisp -core file
-\end{example}
-
-
-\node Search Lists, Time Parsing and Formatting, Saving a Core Image, Design Choices and Extensions
-\section{Search Lists}
-
-Search lists are an extension to Common Lisp pathnames.  Search lists are used
-for two purposes:
-\begin{itemize}
-\item They provide a convenient shorthand for commonly used directory names,
-and
-
-\item They allow the abstract (directory structure independent) specification
-of file locations in program pathname constants (similar to logical pathnames.)
-\end{itemize}
-Each search list has an associated list of directories (represented as
-pathnames with no name or type component.)  The namestring for any relative
-pathname may be prefixed with ``\var{slist}\code{:}'', indicating that the
-pathname is relative to the search list \var{slist} (instead of to the current
-working directory.)  Once qualified with a search list, the pathname is no
-longer considered to be relative.
-
-When a search list qualified pathname is passed to a file-system operation such
-as \code{open}, \code{load} or \code{truename}, each directory in the search
-list is successively used as the root of the pathname until the file is
-located.  When a file is written to a search list directory, the file is always
-written to the first directory in the list.
-
-\defun{search-list}[extensions]{\var{name}}
-This function returns the list of directories associated with the search list
-\var{name}.  If \var{name} is not a defined search list, then an error is
-signalled.   When set with \code{setf}, the list of directories is changed to
-the new value.  If the new value is just a namestring or pathname, then it is
-interpreted as a one-element list.  Note that (unlike Unix pathnames), search
-list names are case-insensitive.
-\enddefun
-
-\defun{search-list-defined-p}[extensions]{\var{name}}
-\defunx{clear-search-list}[extensions]{\var{name}}
-\code{search-list-defined-p} returns \true{} if \var{name} is a defined search
-list name, \false{} otherwise.  \code{clear-search-list} make the search list
-\var{name} undefined.
-\enddefun
-
-\defmac{enumerate-search-list}[extensions]{
- (\var{var} \var{pathname} \mopt{result})
- \mstar{form}}
-
-This macro provides an interface to search list resolution.  The body
-\var{forms} are executed with \var{var} bound to each successive possible
-expansion for \var{name}.  If \var{name} does not contain a search-list, then
-the body is executed exactly once.  Everything is wrapped in a block named
-\nil, so \code{return} can be used to terminate early.  The \var{result} form
-(default \nil) is evaluated to determine the result of the iteration.
-\enddefmac
-
-\begin{menu}
-* Search List Example::         
-\end{menu}
-
-\node Search List Example,  , Search Lists, Search Lists
-\subsection{Search List Example}
-
-The search list \code{code:} can be defined as follows:
-\begin{example}
-(setf (ext:search-list "code:") '("/usr/lisp/code/"))
-\end{example}
-It is now possible to use \code{code:} as an abbreviation for the directory
-\file{/usr/lisp/code/} in all file operations.  For example, you can now specify
-\code{code:eval.lisp} to refer to the file \file{/usr/lisp/code/eval.lisp}.
-
-To obtain the value of a search-list name, use the function search-list
-as follows:
-\begin{example}
-(ext:search-list \var{name})
-\end{example}
-Where \var{name} is the name of a search list as described above.  For example,
-calling \code{ext:search-list} on \code{code:} as follows:
-\begin{example}
-(ext:search-list "code:")
-\end{example}
-returns the list \code{("/usr/lisp/code/")}.
-
-
-\node Time Parsing and Formatting, Lisp Library, Search Lists, Design Choices and Extensions
-\section{Time Parsing and Formatting}
-
-\cindex{time parsing} \cindex{time formatting}
-Functions are provided to allow parsing strings containing time information
-and printing time in various formats are available.
-
-\defun{parse-time}[extensions]{
-       \args{\var{time-string}}
-       \keys{:error-on-mismatch :default-seconds}
-       \morekeys{:default-minutes :default-hours}
-       \yetmorekeys{:default-day ...}}
-\code{parse-time} accepts a string containing a time (e.g., 
-\w{"\code{Jan 12, 1952}"})
-and returns the universal time if it is successful.  If it is unsuccessful
-and the keyword argument \kwd{error-on-mismatch} is non-\FALSE, it signals an
-error.  Otherwise it returns \FALSE.  The other keyword arguments have the
-following meaning:
-\begin{description}
-
-\item[\kwd{default-seconds}]
-specifies the default value for the seconds value if
-one is not provided by \var{time-string}.  The default value is 0.
-
-\item[\kwd{default-minutes}]
-specifies the default value for the minutes value if
-one is not provided by \var{time-string}.  The default value is 0.
-
-\item[\kwd{default-hours}]
-specifies the default value for the hours value if
-one is not provided by \var{time-string}.  The default value is 0.
-
-\item[\kwd{default-day}]
-specifies the default value for the day value if one is
-not provided by \var{time-string}.  The default value is the current day.
-
-\item[\kwd{default-month}]
-specifies the default value for the month value if one
-is not provided by \var{time-string}.  The default value is the current
-month.
-
-\item[\kwd{default-year}]
-specifies the default value for the year value if one is
-not provided by \var{time-string}.  The default value is the current year.
-
-\item[\kwd{default-zone}]
-specifies the default value for the time zone value if
-one is not provided by \var{time-string}.  The default value is the current
-time zone.
-
-\item[\kwd{default-weekday}]
-specifies the default value for the day of the week
-if one is not provided by \var{time-string}.  The default value is the
-current day of the week.
-\end{description}
-Any of the above keywords can be given the value \kwd{current} which means
-to use the current value as determined by a call to the operating system.
-\enddefun
-
-\defun{format-universal-time}[extensions]{
-       \args{\i{dest universal-time}}
-       \keys{:timezone}
-       \morekeys{:style :date-first}
-       \yetmorekeys{:print-seconds ...}}
-
-\defunx{format-decoded-time}[extensions]{
-              \args{\i{dest seconds minutes hours day month year} \&key{} ...}}
-
-\code{format-universal-time} formats the time specified by \var{universal-time}.
-\code{format-decoded-time} formats the time specified by \var{seconds},
-\var{minutes}, \var{hours}, \var{day}, \var{month}, and \var{year}.
-\var{Dest} is any destination accepted by the \code{format} function.
-The keyword arguments have the following meaning:
-\begin{description}
-
-\item[\kwd{timezone}]
-is an integer specifying the hours west of Greenwich.
-\i{:Timezone} defaults to the current time zone.
-
-\item[\kwd{style}]
-specifies the style to use in formatting the time.  The legal
-values are:
-\begin{description}
-
-\item[\kwd{short}]
-specifies to use a numeric date.
-
-\item[\kwd{long}]
-specifies to format months and weekdays as words instead of
-numbers.
-
-\item[\kwd{abbreviated}]
-is similar to long except the words are abbreviated.
-
-\item[\kwd{government}]
-is similar to abbreviated, except the date is of the form
-"day month year" instead of "month day, year".
-\end{description}
-
-\item[\kwd{date-first}]
-if non-\false{} (default) will place the date first.
-Otherwise, the time is placed first.
-
-\item[\kwd{print-seconds}]
-if non-\false{} (default) will format the seconds as part of
-the time.  Otherwise, the seconds will be omitted.
-
-\item[\kwd{print-meridian}]
-if non-\false{} (default) will format "AM" or "PM" as part of
-the time.  Otherwise, the "AM" or "PM" will be omitted.
-
-\item[\kwd{print-timezone}]
-if non-\false{} (default) will format the time zone as part of
-the time.  Otherwise, the time zone will be omitted.
-
-\item[\kwd{print-seconds}]
-if non-\false{} (default) will format the seconds as part of
-the time.  Otherwise, the seconds will be omitted.
-
-\item[\kwd{print-weekday}]
-if non-\false{} (default) will format the weekday as part of
-date.  Otherwise, the weekday will be omitted.
-\end{description}
-\enddefun
-
-
-\node Lisp Library,  , Time Parsing and Formatting, Design Choices and Extensions
-\section{Lisp Library}
-\label{lisp-lib}
-
-The CMU Common Lisp project maintains a collection of useful or interesting
-programs written by users of our system.  The library is in
-\file{lib/contrib/}.  Two files there that users should read are:
-\begin{description}
-
-\item[CATALOG.TXT]
-This file contains a page for each entry in the library.  It
-contains information such as the author, portability or dependency issues, how
-to load the entry, etc.
-
-\item[READ-ME.TXT]
-This file describes the library's organization and all the
-possible pieces of information an entry's catalog description could contain.
-\end{description}
-
-Hemlock has a command \F{Library Entry} that displays a list of the current
-library entries in an editor buffer.  There are mode specific commands that
-display catalog descriptions and load entries.  This is a simple and convenient
-way to browse the library.
-
-
-\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/debug.ms}
-
-
-
-\node The Debugger, The Compiler, Design Choices and Extensions, Top
-\chapter{The Debugger} \hide{-*- Dictionary: cmu-user -*-}
-\begin{center}
-\b{By Robert MacLachlan}
-\end{center}
-\cindex{debugger}
-\label{debugger}
-
-\begin{menu}
-* Debugger Introduction::       
-* The Command Loop::            
-* Stack Frames::                
-* Variable Access::             
-* Source Location Printing::    
-* Compiler Policy Control::     
-* Exiting Commands::            
-* Information Commands::        
-* Breakpoint Commands::
-* Function Tracing::            
-* Specials::                    
-\end{menu}
-
-\node Debugger Introduction, The Command Loop, The Debugger, The Debugger
-\section{Debugger Introduction}
-
-The \cmucl{} debugger is unique in its level of support for source-level
-debugging of compiled code.  Although some other debuggers allow access of
-variables by name, this seems to be the first \llisp{} debugger that:
-\begin{itemize}
-
-\item
-Tells you when a variable doesn't have a value because it hasn't been
-initialized yet or has already been deallocated, or
-
-\item
-Can display the precise source location corresponding to a code
-location in the debugged program.
-\end{itemize}
-These features allow the debugging of compiled code to be made almost
-indistinguishable from interpreted code debugging.
-
-The debugger is an interactive command loop that allows a user to examine
-the function call stack.  The debugger is invoked when:
-\begin{itemize}
-
-\item
-A \tindexed{serious-condition} is signalled, and it is not handled, or
-
-\item
-\findexed{error} is called, and the condition it signals is not handled, or
-
-\item
-The debugger is explicitly invoked with the \clisp{} \findexed{break}
-or \findexed{debug} functions.
-\end{itemize}
-When you enter the debugger, it looks something like this:
-\begin{example}
-Error in function CAR.
-Wrong type argument, 3, should have been of type LIST.
-
-Restarts:
-  0: Return to Top-Level.
-
-Debug  (type H for help)
-
-(CAR 3)
-0]
-\end{example}
-The first group of lines describe what the error was that put us in the
-debugger.  In this case \code{car} was called on \code{3}.  After \code{Restarts:}
-is a list of all the ways that we can restart execution after this error.  In
-this case, the only option is to return to top-level.  After printing its
-banner, the debugger prints the current frame and the debugger prompt.
-
-
-\node The Command Loop, Stack Frames, Debugger Introduction, The Debugger
-\section{The Command Loop}
-
-The debugger is an interactive read-eval-print loop much like the normal
-top-level, but some symbols are interpreted as debugger commands instead
-of being evaluated.  A debugger command starts with the symbol name of
-the command, possibly followed by some arguments on the same line.  Some
-commands prompt for additional input.  Debugger commands can be
-abbreviated by any unambiguous prefix: \code{help} can be typed as
-\code{h}, \code{he}, etc.  For convenience, some commands have
-ambiguous one-letter abbreviations: \code{f} for \code{frame}.
-
-The package is not significant in debugger commands; any symbol with the
-name of a debugger command will work.  If you want to show the value of
-a variable that happens also to be the name of a debugger command, you
-can use the \code{list-locals} command or the \code{debug:var}
-function, or you can wrap the variable in a \code{progn} to hide it from
-the command loop.
-
-The debugger prompt is "\var{frame}\code{]}", where \var{frame} is the number
-of the current frame.  Frames are numbered starting from zero at the top (most
-recent call), increasing down to the bottom.  The current frame is the frame
-that commands refer to.  The current frame also provides the lexical
-environment for evaluation of non-command forms.
-
-\cpsubindex{evaluation}{debugger} The debugger evaluates forms in the lexical
-environment of the functions being debugged.  The debugger can only
-access variables.  You can't \code{go} or \code{return-from} into a
-function, and you can't call local functions.  Special variable
-references are evaluated with their current value (the innermost binding
-around the debugger invocation) \dash{} you don't get the value that the
-special had in the current frame.  \xlref{debug-vars} for more
-information on debugger variable access.
-
-
-\node Stack Frames, Variable Access, The Command Loop, The Debugger
-\section{Stack Frames}
-\cindex{stack frames} \cpsubindex{frames}{stack}
-
-A stack frame is the run-time representation of a call to a function;
-the frame stores the state that a function needs to remember what it is
-doing.  Frames have:
-\begin{itemize}
-
-\item
-Variables (\pxlref{debug-vars}), which are the values being operated
-on, and
-
-\item
-Arguments to the call (which are really just particularly interesting
-variables), and
-
-\item
-A current location (\pxlref{source-locations}), which is the place in
-the program where the function was running when it stopped to call another
-function, or because of an interrupt or error.
-\end{itemize}
-
-
-
-\begin{menu}
-* Stack Motion::                
-* How Arguments are Printed::   
-* Function Names::              
-* Funny Frames::                
-* Debug Tail Recursion::        
-* Unknown Locations and Interrupts::  
-\end{menu}
-
-\node Stack Motion, How Arguments are Printed, Stack Frames, Stack Frames
-\subsection{Stack Motion}
-
-These commands move to a new stack frame and print the name of the function
-and the values of its arguments in the style of a Lisp function call:
-\begin{description}
-
-\item[\code{up}]
-Move up to the next higher frame.  More recent function calls are considered
-to be higher on the stack.
-
-\item[\code{down}]
-Move down to the next lower frame.
-
-\item[\code{top}]
-Move to the highest frame.
-
-\item[\code{bottom}]
-Move to the lowest frame.
-
-\item[\code{frame} [\var{n}]]
-Move to the frame with the specified number.  Prompts for the number if not
-supplied.
-
-\begin{ignore}
-\key{S} [\var{function-name} [\var{n}]]
-
-\item
-Search down the stack for function.  Prompts for the function name if not
-supplied.  Searches an optional number of times, but doesn't prompt for
-this number; enter it following the function.
-
-\item[\key{R} [\var{function-name} [\var{n}]]]
-Search up the stack for function.  Prompts for the function name if not
-supplied.  Searches an optional number of times, but doesn't prompt for
-this number; enter it following the function.
-\end{ignore}
-\end{description}
-
-\node How Arguments are Printed, Function Names, Stack Motion, Stack Frames
-\subsection{How Arguments are Printed}
-
-A frame is printed to look like a function call, but with the actual argument
-values in the argument positions.  So the frame for this call in the source:
-\begin{lisp}
-(myfun (+ 3 4) 'a)
-\end{lisp}
-would look like this:
-\begin{example}
-(MYFUN 7 A)
-\end{example}
-All keyword and optional arguments are displayed with their actual
-values; if the corresponding argument was not supplied, the value will
-be the default.  So this call:
-\begin{lisp}
-(subseq "foo" 1)
-\end{lisp}
-would look like this:
-\begin{example}
-(SUBSEQ "foo" 1 3)
-\end{example}
-And this call:
-\begin{lisp}
-(string-upcase "test case")
-\end{lisp}
-would look like this:
-\begin{example}
-(STRING-UPCASE "test case" :START 0 :END NIL)
-\end{example}
-
-The arguments to a function call are displayed by accessing the argument
-variables.  Although those variables are initialized to the actual argument
-values, they can be set inside the function; in this case the new value will be
-displayed.
-
-\code{&rest} arguments are handled somewhat differently.  The value of
-the rest argument variable is displayed as the spread-out arguments to
-the call, so:
-\begin{lisp}
-(format t "~A is a ~A." "This" 'test)
-\end{lisp}
-would look like this:
-\begin{example}
-(FORMAT T "~A is a ~A." "This" 'TEST)
-\end{example}
-Rest arguments cause an exception to the normal display of keyword
-arguments in functions that have both \code{&rest} and \code{&key}
-arguments.  In this case, the keyword argument variables are not
-displayed at all; the rest arg is displayed instead.  So for these
-functions, only the keywords actually supplied will be shown, and the
-values displayed will be the argument values, not values of the
-(possibly modified) variables.
-
-If the variable for an argument is never referenced by the function, it will be
-deleted.  The variable value is then unavailable, so the debugger prints
-\code{<unused-arg>} instead of the value.  Similarly, if for any of a number of
-reasons (described in more detail in section \ref{debug-vars}) the value of the
-variable is unavailable or not known to be available, then
-\code{<unavailable-arg>} will be printed instead of the argument value.
-
-Printing of argument values is controlled by \code{*debug-print-level*} and
-\varref{debug-print-length}.
-
-
-\node Function Names, Funny Frames, How Arguments are Printed, Stack Frames
-\subsection{Function Names}
-\cpsubindex{function}{names}
-\cpsubindex{names}{function}
-
-If a function is defined by \code{defun}, \code{labels}, or \code{flet}, then the
-debugger will print the actual function name after the open parenthesis, like:
-\begin{example}
-(STRING-UPCASE "test case" :START 0 :END NIL)
-((SETF AREF) #\back a "for" 1)
-\end{example}
-Otherwise, the function name is a string, and will be printed in quotes:
-\begin{example}
-("DEFUN MYFUN" BAR)
-("DEFMACRO DO" (DO ((I 0 (1+ I))) ((= I 13))) NIL)
-("SETQ *GC-NOTIFY-BEFORE*")
-\end{example}
-This string name is derived from the \w{\code{def}\var{mumble}} form that encloses
-or expanded into the lambda, or the outermost enclosing form if there is no
-\w{\code{def}\var{mumble}}.
-
-
-\node Funny Frames, Debug Tail Recursion, Function Names, Stack Frames
-\subsection{Funny Frames}
-\cindex{external entry points}
-\cpsubindex{entry points}{external}
-\cpsubindex{block compilation}{debugger implications}
-\cpsubindex{external}{stack frame kind}
-\cpsubindex{optional}{stack frame kind}
-\cpsubindex{cleanup}{stack frame kind}
-
-Sometimes the evaluator introduces new functions that are used to implement a
-user function, but are not directly specified in the source.  The main place
-this is done is for checking argument type and syntax.  Usually these functions
-do their thing and then go away, and thus are not seen on the stack in the
-debugger.  But when you get some sort of error during lambda-list processing,
-you end up in the debugger on one of these funny frames.
-
-These funny frames are flagged by printing "\code{[}\var{keyword}\code{]}" after the
-parentheses.  For example, this call:
-\begin{lisp}
-(car 'a 'b)
-\end{lisp}
-will look like this:
-\begin{example}
-(CAR 2 A) [:EXTERNAL]
-\end{example}
-And this call:
-\begin{lisp}
-(string-upcase "test case" :end)
-\end{lisp}
-would look like this:
-\begin{example}
-("DEFUN STRING-UPCASE" "test case" 335544424 1) [:OPTIONAL]
-\end{example}
-
-As you can see, these frames have only a vague resemblance to the original
-call.  Fortunately, the error message displayed when you enter the debugger
-will usually tell you what problem is (in these cases, too many arguments
-and odd keyword arguments.)  Also, if you go down the stack to the frame for
-the calling function, you can display the original source (\pxlref{source-locations}.)
-
-With recursive or block compiled functions (\pxlref{block-compilation}), an \code{:EXTERNAL} frame may appear before the frame
-representing the first call to the recursive function or entry to the compiled
-block.  This is a consequence of the way the compiler does block compilation:
-there is nothing odd with your program.  You will also see \code{:CLEANUP} frames
-during the execution of \code{unwind-protect} cleanup code.  Note that inline
-expansion and open-coding affect what frames are present in the debugger, see
-sections \ref{debugger-policy} and \ref{open-coding}.
-
-
-\node Debug Tail Recursion, Unknown Locations and Interrupts, Funny Frames, Stack Frames
-\subsection{Debug Tail Recursion}
-\label{debug-tail-recursion}
-\cindex{tail recursion}
-\cpsubindex{recursion}{tail}
-
-Both the compiler and the interpreter are "properly tail recursive."  If a
-function call is in a tail-recursive position, the stack frame will be
-deallocated \i{at the time of the call}, rather than after the call returns.
-Consider this backtrace:
-\begin{example}
-(BAR ...) 
-(FOO ...)
-\end{example}
-Because of tail recursion, it is not necessarily the case that
-\code{FOO} directly called \code{BAR}.  It may be that \code{FOO} called
-some other function \code{FOO2} which then called \code{BAR}
-tail-recursively, as in this example:
-\begin{example}
-(defun foo ()
-  ...
-  (foo2 ...)
-  ...)
-
-(defun foo2 (...)
-  ...
-  (bar ...))
-
-(defun bar (...)
-  ...)
-\end{example}
-
-Usually the elimination of tail-recursive frames makes debugging more
-pleasant, since theses frames are mostly uninformative.  If there is any
-doubt about how one function called another, it can usually be
-eliminated by finding the source location in the calling frame (section
-\ref{source-locations}.)
-
-For a more thorough discussion of tail recursion, \pxlref{tail-recursion}.
-
-
-\node Unknown Locations and Interrupts,  , Debug Tail Recursion, Stack Frames
-\subsection{Unknown Locations and Interrupts}
-\label{unknown-locations}
-\cindex{unknown code locations}
-\cpsubindex{locations}{unknown}
-\cindex{interrupts}
-\cpsubindex{errors}{run-time}
-
-The debugger operates using special debugging information attached to
-the compiled code.  This debug information tells the debugger what it
-needs to know about the locations in the code where the debugger can be
-invoked.  If the debugger somehow encounters a location not described in
-the debug information, then it is said to be \var{unknown}.  If the code
-location for a frame is unknown, then some variables may be
-inaccessible, and the source location cannot be precisely displayed.
-
-There are three reasons why a code location could be unknown:
-\begin{itemize}
-
-\item
-There is inadequate debug information due to the value of the \code{debug}
-optimization quality.  \xlref{debugger-policy}.
-
-\item
-The debugger was entered because of an interrupt such as \code{^C}.
-
-\item
-A hardware error such as "\code{bus error}" occurred in code that was
-compiled unsafely due to the value of the \code{safety} optimization
-quality.  \xlref{optimize-declaration}.
-\end{itemize}
-
-In the last two cases, the values of argument variables are accessible,
-but may be incorrect.  \xlref{debug-var-validity} for more details on
-when variable values are accessible.
-
-It is possible for an interrupt to happen when a function call or return is in
-progress.  The debugger may then flame out with some obscure error or insist
-that the bottom of the stack has been reached, when the real problem is that
-the current stack frame can't be located.  If this happens, return from the
-interrupt and try again.
-
-When running interpreted code, all locations should be known.  However,
-an interrupt might catch some subfunction of the interpreter at an
-unknown location.  In this case, you should be able to go up the stack a
-frame or two and reach an interpreted frame which can be debugged.
-
-
-\node Variable Access, Source Location Printing, Stack Frames, The Debugger
-\section{Variable Access}
-\label{debug-vars}
-\cpsubindex{variables}{debugger access}
-\cindex{debug variables}
-
-There are three ways to access the current frame's local variables in the
-debugger.  The simplest is to type the variable's name into the debugger's
-read-eval-print loop.  The debugger will evaluate the variable reference as
-though it had appeared inside that frame.
-
-The debugger doesn't really understand lexical scoping; it has just one
-namespace for all the variables in a function.  If a symbol is the name of
-multiple variables in the same function, then the reference appears ambiguous,
-even though lexical scoping specifies which value is visible at any given
-source location.  If the scopes of the two variables are not nested, then the
-debugger can resolve the ambiguity by observing that only one variable is
-accessible.
-
-When there are ambiguous variables, the evaluator assigns each one a
-small integer identifier.  The \code{debug:var} function and the
-\code{list-locals} command use this identifier to distinguish between
-ambiguous variables:
-\begin{description}
-
-\item[\code{list-locals} \mopt{\var{prefix}}]\hfill\\
-This command prints the name and value of all variables in the current
-frame whose name has the specified \var{prefix}.  \var{prefix} may be a
-string or a symbol.  If no \var{prefix} is given, then all available
-variables are printed.  If a variable has a potentially ambiguous name,
-then the name is printed with a "\code{#}\var{identifier}" suffix, where
-\var{identifier} is the small integer used to make the name unique.
-\end{description}
-
-\defun{var}[debug]{\args{\var{name} \&optional{} \var{identifier}}}
-This function returns the value of the variable in the current frame with the
-specified \var{name}.  If supplied, \var{identifier} determines which value to
-return when there are ambiguous variables.
-
-When \var{name} is a symbol, it is interpreted as the symbol name of the
-variable, i.e. the package is significant.  If \var{name} is an
-uninterned symbol (gensym), then return the value of the uninterned
-variable with the same name.  If \var{name} is a string,
-\code{debug:var} interprets it as the prefix of a variable name, and
-must unambiguously complete to the name of a valid variable.
-
-This function is useful mainly for accessing the value of uninterned or
-ambiguous variables, since most variables can be evaluated directly.
-\enddefun
-
-
-\begin{menu}
-* Variable Value Availability::  
-* Note On Lexical Variable Access::  
-\end{menu}
-
-\node Variable Value Availability, Note On Lexical Variable Access, Variable Access, Variable Access
-\subsection{Variable Value Availability}
-\label{debug-var-validity}
-\cindex{availability of debug variables}
-\cindex{validity of debug variables}
-\cindex{debug optimization quality}
-
-The value of a variable may be unavailable to the debugger in portions of the
-program where \clisp{} says that the variable is defined.  If a variable value is
-not available, the debugger will not let you read or write that variable.  With
-one exception, the debugger will never display an incorrect value for a
-variable.  Rather than displaying incorrect values, the debugger tells you the
-value is unavailable.
-
-The one exception is this: if you interrupt (e.g., with \code{^C}) or if there is
-an unexpected hardware error such as "\code{bus error}" (which should only happen
-in unsafe code), then the values displayed for arguments to the interrupted
-frame might be incorrect.\footnote{Since the location of an interrupt or hardware
-error will always be an unknown location (\pxlref{unknown-locations}),
-non-argument variable values will never be available in the interrupted frame.}
-This exception applies only to the interrupted frame: any frame farther down
-the stack will be fine.
-
-The value of a variable may be unavailable for these reasons:
-\begin{itemize}
-
-\item
-The value of the \code{debug} optimization quality may have omitted debug
-information needed to determine whether the variable is available.
-Unless a variable is an argument, its value will only be available when
-\code{debug} is at least \code{2}.
-
-\item
-The compiler did lifetime analysis and determined that the value was no longer
-needed, even though its scope had not been exited.  Lifetime analysis is
-inhibited when the \code{debug} optimization quality is \code{3}.
-
-\item
-The variable's name is an uninterned symbol (gensym).  To save space, the
-compiler only dumps debug information about uninterned variables when the
-\code{debug} optimization quality is \code{3}.
-
-\item
-The frame's location is unknown (\pxlref{unknown-locations}) because
-the debugger was entered due to an interrupt or unexpected hardware error.
-Under these conditions the values of arguments will be available, but might be
-incorrect.  This is the exception above.
-
-\item
-The variable was optimized out of existence.  Variables with no reads are
-always optimized away, even in the interpreter.  The degree to which the
-compiler deletes variables will depend on the value of the \code{compile-speed}
-optimization quality, but most source-level optimizations are done under all
-compilation policies.
-\end{itemize}
-
-
-Since it is especially useful to be able to get the arguments to a function,
-argument variables are treated specially when the \code{speed} optimization
-quality is less than \code{3} and the \code{debug} quality is at least \code{1}.
-With this compilation policy, the values of argument variables are almost
-always available everywhere in the function, even at unknown locations.  For
-non-argument variables, \code{debug} must be at least \code{2} for values to be
-available, and even then, values are only available at known locations.
-
-
-\node Note On Lexical Variable Access,  , Variable Value Availability, Variable Access
-\subsection{Note On Lexical Variable Access}
-\cpsubindex{evaluation}{debugger}
- 
-When the debugger command loop establishes variable bindings for available
-variables, these variable bindings have lexical scope and dynamic
-extent.\footnote{The variable bindings are actually created using the \clisp{}
-\code{symbol-macro-let} special form.}  You can close over them, but such closures
-can't be used as upward funargs.
-
-You can also set local variables using \code{setq}, but if the variable was closed
-over in the original source and never set, then setting the variable in the
-debugger may not change the value in all the functions the variable is defined
-in.  Another risk of setting variables is that you may assign a value of a type
-that the compiler proved the variable could never take on.  This may result in
-bad things happening.
-
-
-\node Source Location Printing, Compiler Policy Control, Variable Access, The Debugger
-\section{Source Location Printing}
-\label{source-locations}
-\cpsubindex{source location printing}{debugger}
-
-One of CMU \clisp{}'s unique capabilities is source level debugging of compiled
-code.  These commands display the source location for the current frame:
-\begin{description}
-
-\item[\code{source} \mopt{\var{context}}]\hfill\\
-This command displays the file that the current frame's function was defined
-from (if it was defined from a file), and then the source form responsible for
-generating the code that the current frame was executing.  If \var{context} is
-specified, then it is an integer specifying the number of enclosing levels of
-list structure to print.
-
-\item[\code{vsource} \mopt{\var{context}}]\hfill\\
-This command is identical to \code{source}, except that it uses the
-global values of \code{*print-level*} and \code{*print-length*} instead
-of the debugger printing control variables \code{*debug-print-level*}
-and \code{*debug-print-length*}.
-\end{description}
-
-The source form for a location in the code is the innermost list present
-in the original source that encloses the form responsible for generating
-that code.  If the actual source form is not a list, then some enclosing
-list will be printed.  For example, if the source form was a reference
-to the variable \code{*some-random-special*}, then the innermost
-enclosing evaluated form will be printed.  Here are some possible
-enclosing forms:
-\begin{example}
-(let ((a *some-random-special*))
-  ...)
-
-(+ *some-random-special* ...)
-\end{example}
-
-If the code at a location was generated from the expansion of a macro or a
-source-level compiler optimization, then the form in the original source that
-expanded into that code will be printed.  Suppose the file
-\file{/usr/me/mystuff.lisp} looked like this:
-\begin{example}
-(defmacro mymac ()
-  '(myfun))
-
-(defun foo ()
-  (mymac)
-  ...)
-\end{example}
-If \code{foo} has called \code{myfun}, and is waiting for it to return, then the
-\code{source} command would print:
-\begin{example}
-; File: /usr/me/mystuff.lisp
-
-(MYMAC)
-\end{example}
-Note that the macro use was printed, not the actual function call form,
-\code{(myfun)}.
-
-If enclosing source is printed by giving an argument to \code{source} or
-\code{vsource}, then the actual source form is marked by wrapping it in a list
-whose first element is \code{#:***HERE***}.  In the previous example, 
-\w{\code{source 1}} would print:
-\begin{example}
-; File: /usr/me/mystuff.lisp
-
-(DEFUN FOO ()
-  (#:***HERE***
-   (MYMAC))
-  ...)
-\end{example}
-
-
-\begin{menu}
-* How the Source is Found::     
-* Source Location Availability::  
-\end{menu}
-
-\node How the Source is Found, Source Location Availability, Source Location Printing, Source Location Printing
-\subsection{How the Source is Found}
-
-If the code was defined from \llisp{} by \code{compile} or
-\code{eval}, then the source can always be reliably located.  If the
-code was defined from a \code{fasl} file created by
-\findexed{compile-file}, then the debugger gets the source forms it
-prints by reading them from the original source file.  This is a
-potential problem, since the source file might have moved or changed
-since the time it was compiled.
-
-The source file is opened using the \code{truename} of the source file
-pathname originally given to the compiler.  This is an absolute pathname
-with all logical names and symbolic links expanded.  If the file can't
-be located using this name, then the debugger gives up and signals an
-error.
-
-If the source file can be found, but has been modified since the time it was
-compiled, the debugger prints this warning:
-\begin{example}
-; File has been modified since compilation:
-;   \var{filename}
-; Using form offset instead of character position.
-\end{example}
-where \var{filename} is the name of the source file.  It then proceeds using a
-robust but not foolproof heuristic for locating the source.  This heuristic
-works if:
-\begin{itemize}
-
-\item
-No top-level forms before the top-level form containing the source have been
-added or deleted, and
-
-\item
-The top-level form containing the source has not been modified much.  (More
-precisely, none of the list forms beginning before the source form have been
-added or deleted.)
-\end{itemize}
-
-If the heuristic doesn't work, the displayed source will be wrong, but will
-probably be near the actual source.  If the "shape" of the top-level form in
-the source file is too different from the original form, then an error will be
-signalled.  When the heuristic is used, the the source location commands are
-noticeably slowed.
-
-Source location printing can also be confused if (after the source was
-compiled) a read-macro you used in the code was redefined to expand into
-something different, or if a read-macro ever returns the same \code{eq}
-list twice.  If you don't define read macros and don't use \code{##} in
-perverted ways, you don't need to worry about this.
-
-
-\node Source Location Availability,  , How the Source is Found, Source Location Printing
-\subsection{Source Location Availability}
-
-\cindex{debug optimization quality}
-Source location information is only available when the \code{debug}
-optimization quality is at least \code{2}.  If source location information is
-unavailable, the source commands will give an error message.
-
-If source location information is available, but the source location is
-unknown because of an interrupt or unexpected hardware error
-(\pxlref{unknown-locations}), then the command will print:
-\begin{example}
-Unknown location: using block start.
-\end{example}
-and then proceed to print the source location for the start of the \i{basic
-block} enclosing the code location. \cpsubindex{block}{basic} 
-\cpsubindex{block}{start location} 
-It's a bit complicated to explain exactly what a basic block is, but
-here are some properties of the block start location:
-\begin{itemize}
-
-\item
-The block start location may be the same as the true location.
-
-\item
-The block start location will never be later in the the program's flow of
-control than the true location.
-
-\item
-No conditional control structures (such as \code{if}, \code{cond}, \code{or}) will
-intervene between the block start and the true location (but note that some
-conditionals present in the original source could be optimized away.)  Function
-calls \i{do not} end basic blocks.
-
-\item
-The head of a loop will be the start of a block.
-
-\item
-The programming language concept of "block structure" and the \clisp{} \code{block}
-special form are totally unrelated to the compiler's basic block.
-\end{itemize}
-
-In other words, the true location lies between the printed location and the
-next conditional (but watch out because the compiler may have changed the
-program on you.)
-
-
-\node Compiler Policy Control, Exiting Commands, Source Location Printing, The Debugger
-\section{Compiler Policy Control}
-\label{debugger-policy}
-\cpsubindex{policy}{debugger}
-\cindex{debug optimization quality}
-\cindex{optimize declaration}
-
-The compilation policy specified by \code{optimize} declarations affects the
-behavior seen in the debugger.  The \code{debug} quality directly affects the
-debugger by controlling the amount of debugger information dumped.  Other
-optimization qualities have indirect but observable effects due to changes in
-the way compilation is done.
-
-Unlike the other optimization qualities (which are compared in relative value
-to evaluate tradeoffs), the \code{debug} optimization quality is directly
-translated to a level of debug information.  This absolute interpretation
-allows the user to count on a particular amount of debug information being
-available even when the values of the other qualities are changed during
-compilation.  These are the levels of debug information that correspond to the
-values of the \code{debug} quality:
-\begin{description}
-
-\item[\code{0}]
-Only the function name and enough information to allow the stack to
-be parsed.
-
-\item[\code{\w{> 0}}]
-Any level greater than \code{0} gives level \code{0} plus all
-argument variables.  Values will only be accessible if the argument
-variable is never set and
-\code{speed} is not \code{3}.  \cmucl{} allows any real value for optimization
-qualities.  It may be useful to specify \code{0.5} to get backtrace argument
-display without argument documentation.
-
-\item[\code{1}] Level \code{1} provides argument documentation
-(printed arglists) and derived argument/result type information.
-This makes \findexed{describe} more informative, and allows the
-compiler to do compile-time argument count and type checking for any
-calls compiled at run-time.
-
-\item[\code{2}]
-Level \code{1} plus all interned local variables, source location
-information, and lifetime information that tells the debugger when arguments
-are available (even when \code{speed} is \code{3} or the argument is set.)  This is
-the default.
-
-\item[\code{3}]
-Level \code{2} plus all uninterned variables.  In addition, lifetime
-analysis is disabled (even when \code{speed} is \code{3}), ensuring that all variable
-values are available at any known location within the scope of the binding.
-This has a speed penalty in addition to the obvious space penalty.
-\end{description}
-
-As you can see, if the \code{speed} quality is \code{3}, debugger performance is
-degraded.  This effect comes from the elimination of argument variable
-special-casing (\pxlref{debug-var-validity}.)  Some degree of
-speed/debuggability tradeoff is unavoidable, but the effect is not too drastic
-when \code{debug} is at least \code{2}.
-
-\cindex{inline expansion}
-\cindex{semi-inline expansion}
-In addition to \code{inline} and \code{notinline} declarations, the relative values
-of the \code{speed} and \code{space} qualities also change whether functions are
-inline expanded (\pxlref{inline-expansion}.)  If a function is inline
-expanded, then there will be no frame to represent the call, and the arguments
-will be treated like any other local variable.  Functions may also be
-"semi-inline", in which case there is a frame to represent the call, but the
-call is to an optimized local version of the function, not to the original
-function.
-
-
-\node Exiting Commands, Information Commands, Compiler Policy Control, The Debugger
-\section{Exiting Commands}
-
-These commands get you out of the debugger.
-
-\begin{description}
-
-\item[\code{quit}]
-Throw to top level.
-
-\item[\code{restart} \mopt{\var{n}}]\hfill\\
-Invokes the \var{n}th restart case as displayed by the \code{error}
-command.  If \var{n} is not specified, the available restart cases are
-reported.
-
-\item[\code{go}]
-Calls \code{continue} on the condition given to \code{debug}.  If there is no
-restart case named \var{continue}, then an error is signaled.
-
-\item[\code{abort}]
-Calls \code{abort} on the condition given to \code{debug}.  This is
-useful for popping debug command loop levels or aborting to top level,
-as the case may be.
-
-\begin{ignore}
-(\code{debug:debug-return} \var{expression} \mopt{\var{frame}})
-
-\item
-From the current or specified frame, return the result of evaluating
-expression.  If multiple values are expected, then this function should be
-called for multiple values.
-\end{ignore}
-\end{description}
-
-
-\node Information Commands, Breakpoint Commands, Exiting Commands, The Debugger
-\section{Information Commands}
-
-Most of these commands print information about the current frame or
-function, but a few show general information.
-
-\begin{description}
-
-\item[\code{help}, \code{?}]
-Displays a synopsis of debugger commands.
-
-\item[\code{describe}]
-Calls \code{describe} on the current function, displays number of local
-variables, and indicates whether the function is compiled or interpreted.
-
-\item[\code{print}]
-Displays the current function call as it would be displayed by moving to
-this frame.
-
-\item[\code{vprint} (or \code{pp}) \mopt{\var{verbosity}}]\hfill\\
-Displays the current function call using \code{*print-level*} and
-\code{*print-length*} instead of \code{*debug-print-level*} and
-\code{*debug-print-length*}.  \var{verbosity} is a small integer
-(default 2) that controls other dimensions of verbosity.
-
-\item[\code{error}]
-Prints the condition given to \code{invoke-debugger} and the active
-proceed cases.
-
-\item[\code{backtrace} \mopt{\var{n}}]\hfill\\
-Displays all the frames from the current to the bottom.  Only shows
-\var{n} frames if specified.  The printing is controlled by
-\code{*debug-print-level*} and \code{*debug-print-length*}.
-
-\begin{ignore}
-(\code{debug:debug-function} \mopt{\var{n}})
-
-\item
-Returns the function from the current or specified frame.
-
-\item[(\code{debug:function-name} \mopt{\var{n}])]
-Returns the function name from the current or specified frame.
-
-\item[(\code{debug:pc} \mopt{\var{frame}})]
-Returns the index of the instruction for the function in the current or
-specified frame.  This is useful in conjunction with \code{disassemble}.
-The pc returned points to the instruction after the one that was fatal.
-\end{ignore}
-\end{description}
-
-
-\node Breakpoint Commands, Function Tracing, Information Commands, The Debugger
-\section{Breakpoint Commands}
-
-\cmucl{} supports setting of breakpoints inside compiled functions and
-stepping of compiled code.  Breakpoints can only be set at at known
-locations (\pxlref{unknown-locations}), so these commands are largely
-useless unless the \code{debug} optimize quality is at least \code{2}
-(\pxlref{debugger-policy}).  These commands manipulate breakpoints:
-\begin{description}
-\item[\code{breakpoint} \var{location} \mstar{\var{option} \var{value}}]
-\hfill\\
-Set a breakpoint in some function.  \var{location} may be an integer
-code location number (as displayed by \code{list-locations}) or a
-keyword.  The keyword can be used to indicate setting a breakpoint at
-the function start (\code{:start}, \code{:s}) or function end
-(\code{:end}, \code{:e}).  The \code{breakpoint} command has
-\code{:condition}, \code{:break}, \code{:print} and \code{:function}
-options which work similarly to the \code{trace} options.
-
-\item[\code{list-locations} (or \code{ll}) \mopt{\var{function}}]\hfill\\
-List all the code locations in the current frame's function, or in
-\var{function} if it is supplied.  The display format is the code
-location number, a colon and then the source form for that location:
-\begin{example}
-3: (1- N)
-\end{example}
-If consecutive locations have the same source, then a numeric range like
-\code{3-5:} will be printed.  For example, a default function call has a
-known location both immediately before and after the call, which would
-result in two code locations with the same source.  The listed function
-becomes the new default function for breakpoint setting (via the
-\code{breakpoint}) command.
-
-\item[\code{list-breakpoints} (or \code{lb})]\hfill\\
-List all currently active breakpoints with their breakpoint number.
-
-\item[\code{delete-breakpoint} (or \code{db}) \mopt{\var{number}}]\hfill\\
-Delete a breakpoint specified by its breakpoint number.  If no number is
-specified, delete all breakpoints.
-
-\item[\code{step}]\hfill\\
-Step to the next possible breakpoint location in the current function.
-This always steps over function calls, instead of stepping into them
-\end{description}
-
-\begin{menu}
-* Breakpoint Example::
-\end{menu}
-
-\node Breakpoint Example,  , Breakpoint Commands, Breakpoint Commands
-\subsection{Breakpoint Example}
-
-Consider this definition of the factorial function:
-\begin{lisp}
-(defun ! (n)
-  (if (zerop n)
-      1
-      (* n (! (1- n)))))
-\end{lisp}
-This debugger session demonstrates the use of breakpoints:
-\begin{example}
-common-lisp-user> (break) ; Invoke debugger
-
-Break
-
-Restarts:
-  0: [CONTINUE] Return from BREAK.
-  1: [ABORT   ] Return to Top-Level.
-
-Debug  (type H for help)
-
-(INTERACTIVE-EVAL (BREAK))
-0] ll #'!
-0: #'(LAMBDA (N) (BLOCK ! (IF # 1 #)))
-1: (ZEROP N)
-2: (* N (! (1- N)))
-3: (1- N)
-4: (! (1- N))
-5: (* N (! (1- N)))
-6: #'(LAMBDA (N) (BLOCK ! (IF # 1 #)))
-0] br 2
-(* N (! (1- N)))
-1: 2 in !
-Added.
-0] q
-
-common-lisp-user> (! 10) ; Call the function
-
-*Breakpoint hit*
-
-Restarts:
-  0: [CONTINUE] Return from BREAK.
-  1: [ABORT   ] Return to Top-Level.
-
-Debug  (type H for help)
-
-(! 10) ; We are now in first call (arg 10) before the multiply
-Source: (* N (! (1- N)))
-3] st
-
-*Step*
-
-(! 10) ; We have finished evaluation of (1- n)
-Source: (1- N)
-3] st
-
-*Breakpoint hit*
-
-Restarts:
-  0: [CONTINUE] Return from BREAK.
-  1: [ABORT   ] Return to Top-Level.
-
-Debug  (type H for help)
-
-(! 9) ; We hit the breakpoint in the recursive call
-Source: (* N (! (1- N)))
-3] 
-\end{example}
-
-
-
-
-\node Function Tracing, Specials, Breakpoint Commands, The Debugger
-\section{Function Tracing}
-\cindex{tracing}
-\cpsubindex{function}{tracing}
-
-The tracer causes selected functions to print their arguments and
-their results whenever they are called.  Options allow conditional
-printing of the trace information and conditional breakpoints on
-function entry or exit.
-
-\defmac{trace}{\mstar{option global-value} \mstar{name \mstar{option value}}}
-\code{trace} is a debugging tool that prints information when specified
-functions are called.  In its simplest form:
-\begin{example}
-(trace \var{name-1} \var{name-2} ...)
-\end{example}
-\code{trace} causes a printout on \vindexed{trace-output} each time that one
-of the named functions is entered or returns (the \var{names} are not
-evaluated.)  Trace output is indented according to the number of pending
-traced calls, and this trace depth is printed at the beginning of each
-line of output.  Printing verbosity of arguments and return values is
-controlled by \vindexed{debug-print-level} and \vindexed{debug-print-length}.
-
-If no \var{names} or \var{options} are are given, \code{trace} returns the
-list of all currently traced functions, \code{*traced-function-list*}.
-
-Trace options can cause the normal printout to be suppressed, or cause
-extra information to be printed.  Each option is a pair of an option
-keyword and a value form.  Options may be interspersed with function
-names.  Options only affect tracing of the function whose name they
-appear immediately after.  Global options are specified before the first
-name, and affect all functions traced by a given use of \code{trace}.
-If an already traced function is traced again, any new options replace the
-old options.  The following options are defined:
-\begin{description}
-\item[\code{:condition} \var{form}, 
-\code{:condition-after} \var{form}, 
-\code{:condition-all} \var{form}]\hfill\\
-If \code{:condition} is specified, then \code{trace} does nothing unless
-\var{form} evaluates to true at the time of the call.  \code{:condition-after}
-is similar, but suppresses the initial printout, and is tested when the
-function returns.  \code{:condition-all} tries both before and after.
-
-\item[\code{:wherein} \var{names}]\hfill\\
-If specified, \var{names} is a function name or list of names.  \code{trace}
-does nothing unless a call to one of those functions encloses the call
-to this function (i.e. it would appear in a backtrace.)  Anonymous
-functions have string names like \code{"DEFUN FOO"}.
-
-\item[\code{:break} \var{form}, 
-\code{:break-after} \var{form}, 
-\code{:break-all} \var{form}]\hfill\\
-If specified, and \var{form} evaluates to true, then the debugger is
-invoked at the start of the function, at the end of the function, or
-both, according to the respective option.
-
-\item[\code{:print} \var{form}, 
-\code{:print-after} \var{form},
-\code{:print-all} \var{form}]\hfill\\
-In addition to the usual printout, the result of evaluating \var{form} is
-printed at the start of the function, at the end of the function, or
-both, according to the respective option.  Multiple print options cause
-multiple values to be printed.
-
-\item[\code{:function} \var{function-form}]\hfill\\
-This is a not really an option, but rather another way of specifying
-what function to trace.  The \var{function-form} is evaluated immediately,
-and the resulting function is traced.
-
-\item[\code{:encapsulate \mgroup{:default | t | nil}}]\hfill\\ 
-In \cmucl, tracing can be done either by temporarily redefining the
-function name (encapsulation), or using breakpoints.  When breakpoints
-are used, the function object itself is destructively modified to cause
-the tracing action.  The advantage of using breakpoints is that tracing
-works even when the function is anonymously called via \code{funcall}.
-
-When \code{:encapsulate} is true, tracing is done via encapsulation.
-\code{:default} is the default, and means to use encapsulation for
-interpreted functions and funcallable instances, breakpoints otherwise.
-When encapsulation is used, forms are {\it not} evaluated in the
-function's lexical environment, but \code{debug:arg} can still be used.
-\end{description}
-
-\code{:condition}, \code{:break} and \code{:print} forms are evaluated
-in the lexical environment of the called function; \code{debug:var} and
-\code{debug:arg} can be used.  The \code{-after} and \code{-all} forms
-are evaluated in the null environment.
-\enddefmac
-
-\defmac{untrace}{ \args{\&rest{} \var{function-names}}}
-This macro turns off tracing for the specified functions, and removes
-their names from \code{*traced-function-list*}.  If no
-\var{function-names} are given, then all currently traced functions are
-untraced.
-\enddefmac
-
-\defvar{traced-function-list}[extensions]
-A list of function names maintained and used by \code{trace},
-\code{untrace}, and \code{untrace-all}.  This list should contain the names
-of all functions currently being traced.
-\enddefvar
-
-\defvar{max-trace-indentation}[extensions]
-The maximum number of spaces which should be used to indent trace
-printout.  This variable is initially set to 40.
-\enddefvar
-
-\begin{menu}
-* Encapsulation Functions::     
-\end{menu}
-
-\node Encapsulation Functions,  , Function Tracing, Function Tracing
-\subsection{Encapsulation Functions}
-\cindex{encapsulation}
-\cindex{advising}
-
-The encapsulation functions provide a mechanism for intercepting the
-arguments and results of a function.  \code{encapsulate} changes the
-function definition of a symbol, and saves it so that it can be
-restored later.  The new definition normally calls the original
-definition.  The \clisp{} \findexed{fdefinition} function always returns
-the original definition, stripping off any encapsulation.
-
-The original definition of the symbol can be restored at any time by
-the \code{unencapsulate} function.  \code{encapsulate} and \code{unencapsulate}
-allow a symbol to be multiply encapsulated in such a way that different
-encapsulations can be completely transparent to each other.
-
-Each encapsulation has a type which may be an arbitrary lisp object.
-If a symbol has several encapsulations of different types, then any
-one of them can be removed without affecting more recent ones.
-A symbol may have more than one encapsulation of the same type, but
-only the most recent one can be undone.
-
-\defun{encapsulate}[extensions]{\args{\i{symbol type body}}}
-Saves the current definition of \var{symbol}, and replaces it with a
-function which returns the result of evaluating the form, \var{body}. 
-\var{Type} is an arbitrary lisp object which is the type of
-encapsulation.
-
-When the new function is called, the following variables are bound for the
-evaluation of \var{body}:
-\begin{description}
-
-\item[\code{extensions:argument-list}]
-A list of the arguments to the function.
-
-\item[\code{extensions:basic-definition}]
-The unencapsulated definition of the
-function.
-\end{description}
-The unencapsulated definition may be called with the original
-arguments by including the form
-\begin{lisp}
-(apply extensions:basic-definition extensions:argument-list)
-\end{lisp}
-
-\code{encapsulate} always returns \var{symbol}.
-\enddefun
-
-\defun{unencapsulate}[extensions]{\args{\i{symbol type}}} Undoes
-\var{symbol}'s most recent encapsulation of type \var{type}.
-\var{Type} is compared with \code{eq}.  Encapsulations of other types
-are left in place.
-\enddefun
-
-\defun{encapsulated-p}[extensions]{\args{\i{symbol type}}}
-Returns \code{t} if \var{symbol} has an encapsulation of type \var{type}.
-Returns \nil{} otherwise.  \var{Type} is compared with \code{eq}.
-\enddefun
-
-
-\begin{ignore}
-section{The Single Stepper}
-
-\defmac{step}{ \args{\var{form}}}
-Evaluates form with single stepping enabled or if \var{form} is \code{T},
-enables stepping until explicitly disabled.  Stepping can be
-disabled by quitting to the lisp top level, or by evaluating the form
-\w{\code{(step ())}}.
-
-While stepping is enabled, every call to eval will prompt the user for
-a single character command.  The prompt is the form which is about to
-be \code{eval}ed.  It is printed with \code{*print-level*} and
-\code{*print-length*} bound to \code{*step-print-level*} and
-\code{*step-print-length*}.  All interaction is done through the stream
-\code{*query-io*}.  Because of this, the stepper can not be used in Hemlock
-eval mode.  When connected to a slave Lisp, the stepper can be used
-from Hemlock.
-
-The commands are:
-\begin{description}
-
-\item[\key{n} (next)]
-Evaluate the expression with stepping still enabled.
-
-\item[\key{s} (skip)]
-Evaluate the expression with stepping disabled.
-
-\item[\key{q} (quit)]
-Evaluate the expression, but disable all further
-stepping inside the current call to \code{step}.
-
-\item[\key{p} (print)]
-Print current form.  (does not use
-\code{*step-print-level*} or \code{*step-print-length*}.)
-
-\item[\key{b} (break)]
-Enter break loop, and then prompt for the command
-again when the break loop returns.
-
-\item[\key{e} (eval)]
-Prompt for and evaluate an arbitrary expression.
-The expression is evaluated with stepping disabled.
-
-\item[\key{?} (help)]
-Prints a brief list of the commands.
-
-\item[\key{r} (return)]
-Prompt for an arbitrary value to return as result
-of the current call to eval.
-
-\item[\key{g}]
-Throw to top level.
-\end{description}
-\enddefmac
-
-\defvar{step-print-level}[extensions]
-\defvarx{step-print-length}[extensions]
-\code{*print-level*} and \code{*print-length*} are bound to these values while
-printing the current form.  \code{*Step-print-level*} and
-\code{*step-print-length*} are initially bound to 4 and 5, respectively.
-\enddefvar
-
-\defvar{max-step-indentation}[extensions]
-Step indents the prompts to highlight the nesting of the evaluation.
-This variable contains the maximum number of spaces to use for
-indenting.  Initially set to 40.
-\enddefvar
-
-\end{ignore}
-
-
-\node Specials,  , Function Tracing, The Debugger
-\section{Specials}
-These are the special variables that control the debugger action.
-
-\defvar{debug-print-level}[extensions]
-\defvarx{debug-print-length}[extensions]
-
-\code{*print-level*} and \code{*print-length*} are bound to these values
-during the execution of some debug commands.  When evaluating
-arbitrary expressions in the debugger, the normal values of
-\code{*print-level*} and \code{*print-length*} are in effect.  These
-variables are initially set to 3 and 5, respectively.
-\enddefvar
-
-
-\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/compiler.ms}
-
-
-\node The Compiler, Advanced Compiler Use and Efficiency Hints, The Debugger, Top
-\chapter{The Compiler} \hide{ -*- Dictionary: cmu-user -*-}
-
-\begin{menu}
-* Compiler Introduction::       
-* Calling the Compiler::        
-* Compilation Units::           
-* Interpreting Error Messages::  
-* Types in Python::             
-* Getting Existing Programs to Run::  
-* Compiler Policy::             
-* Open Coding and Inline Expansion::  
-\end{menu}
-
-\node Compiler Introduction, Calling the Compiler, The Compiler, The Compiler
-\section{Compiler Introduction}
-
-This chapter contains information about the compiler that every \cmucl{} user
-should be familiar with.  Chapter \ref{advanced-compiler} goes into greater
-depth, describing ways to use more advanced features.
-
-The \cmucl{} compiler (also known as \Python{}) has many features
-that are seldom or never supported by conventional \llisp{}
-compilers:
-\begin{itemize}
-
-\item
-Source level debugging of compiled code (see chapter \ref{debugger}.)
-
-\item
-Type error compiler warnings for type errors detectable at compile time.
-
-\item
-Compiler error messages that provide a good indication of where the error
-appeared in the source.
-
-\item
-Full run-time checking of all potential type errors, with optimization of type
-checks to minimize the cost.
-
-\item
-Scheme-like features such as proper tail recursion and extensive source-level
-optimization.
-
-\item
-Advanced tuning and optimization features such as comprehensive efficiency
-notes, flow analysis, and untagged number representations (see chapter
-\ref{advanced-compiler}.)
-\end{itemize}
-
-
-
-\node Calling the Compiler, Compilation Units, Compiler Introduction, The Compiler
-\section{Calling the Compiler}
-\cindex{compiling}
-Functions may be compiled using \code{compile}, \code{compile-file}, or 
-\code{compile-from-stream}.  
-
-\defun{compile}{ \args{\var{name} \&optional{} \var{definition}}}
-This function compiles the function whose name is \var{name}.  If
-\var{name} is \false, the compiled function object is returned.  If
-\var{definition} is supplied, it should be a lambda expression that
-is to be compiled and then placed in the function cell of \var{name}.
-As per the proposed X3J13 cleanup "compile-argument-problems",
-\var{definition} may also be an interpreted function.
-
-The return values are as per the proposed X3J13 cleanup
-"compiler-diagnostics".  The first value is the function name or
-function object.  The second value is \false{} if no compiler
-diagnostics were issued, and \true{} otherwise.  The third value is
-\false{} if no compiler diagnostics other than style warnings were
-issued.  A non-\false{} value indicates that there were "serious"
-compiler diagnostics issued, or that other conditions of type
-\tindexed{error} or \tindexed{warning} (but not
-\tindexed{style-warning}) were signalled during compilation.
-\enddefun
-
-
-\defun{compile-file}{
-        \args{\var{input-pathname}}
-        \keys{:output-file :error-file :trace-file}
-        \morekeys{:error-output :verbose :print :progress}
-        \yetmorekeys{:load :block-compile :entry-points}}
-The \cmucl{} \code{compile-file} is extended through the addition of several new
-keywords and an additional interpretation of \var{input-pathname}:
-\begin{description}
-
-\item[\var{input-pathname}] If this argument is a list of input
-files, rather than a single input pathname, then all the source files
-are compiled into a single object file.  In this case, the name of
-the first file is used to determine the default output file names.
-This is especially useful in combination with \var{block-compile}.
-
-\item[\var{output-file}] This argument specifies the name of the
-output file.  \true{} gives the default name, \false{} suppresses the
-output file.
-
-\item[\var{error-file}] A listing of all the error output is directed
-to this file.  If there are no errors, then no error file is produced
-(and any existing error file is deleted.)  \true{} gives
-\w{"\var{name}\code{.err}"} (the default), and \false{} suppresses
-the output file.
-
-\item[\var{error-output}]
-If \true{} (the default), then error output is sent to \code{*error-output*}.  If
-a stream, then output is sent to that stream instead.  If \false, then error
-output is suppressed.  Note that this error output is in addition to (but the
-same as) the output placed in the \var{error-file}.
-
-\item[\var{verbose}] If \true{} (the default), then the compiler
-prints to error output at the start and end of compilation of each
-file.  See \varref{compile-verbose}.
-
-\item[\var{print}]
-If \true{} (the default), then the compiler prints to error output
-when each function is compiled.  See \varref{compile-print}.
-
-\item[\var{progress}] If \true{} (default \false{}), then the
-compiler prints to error output progress information about the phases
-of compilation of each function.  This is a CMU extension that is
-useful mainly in large block compilations.  See \varref{compile-progress}.
-
-\item[\var{trace-file}] If true, several of the intermediate
-representations (including annotated assembly code) are dumped out to
-this file.  \true{} gives \w{"\var{name}\code{.trace}"}.  Trace
-output is off by default.  \xlref{trace-files}.
-
-\item[\var{load}] If true, load the resulting output file.
-
-\item[\var{block-compile}] Controls the compile-time resolution of
-function calls.  By default, only self-recursive calls are resolved,
-unless an \code{ext:block-start} declaration appears in the source
-file.  \xlref{compile-file-block}.
-
-\item[\var{entry-points}] If non-null, then this is a list of the
-names of all functions in the file that should have global
-definitions installed (because they are referenced in other files.)
-\xlref{compile-file-block}.
-\end{description}
-
-The return values are as per the proposed X3J13 cleanup
-"compiler-diagnostics".  The first value from \code{compile-file} is the
-truename of the output file, or \false{} if the file could not be
-created.  The interpretation of the second and third values is
-described above for \code{compile}.
-\enddefun
-
-\defvar{compile-verbose}
-\defvarx{compile-print}
-\defvarx{compile-progress}
-These variables determine the default values for the \kwd{verbose},
-\kwd{print} and \kwd{progress} arguments to \code{compile-file}.
-\enddefvar
-
-\defun{compile-from-stream}[extensions]{\args{input-stream}
-        \keys{:error-stream}
-        \morekeys{:trace-stream}
-        \yetmorekeys{:block-compile :entry-points}}
-This function is similar to \code{compile-file}, but it takes all its
-arguments as streams.  It reads \llisp{} code from \var{input-stream}
-until end of file is reached, compiling into the current environment.
-This function returns the same two values as the last two values of
-\code{compile}.  No output files are produced.
-\enddefun
-
-
-
-\node Compilation Units, Interpreting Error Messages, Calling the Compiler, The Compiler
-\section{Compilation Units}
-\cpsubindex{compilation}{units}
-
-\cmucl{} supports the \code{with-compilation-unit} macro added to the language by
-the proposed X3J13 "with-compilation-unit" compiler cleanup.  This provides a
-mechanism for eliminating spurious undefined warnings when there are forward
-references across files, and also provides a standard way to access compiler
-extensions.
-
-\defmac{with-compilation-unit}{
-        \args{(\mstar{\var{key} \var{value}}) \mstar{\var{form}}}} 
-
-This macro evaluates the \var{forms} in an environment that causes warnings for
-undefined variables, functions and types to be delayed until all the forms have
-been evaluated.  Each keyword \var{value} is an evaluated form.  These keyword
-options are recognized:
-\begin{description}
-
-\item[\kwd{override}]
-If uses of \code{with-compilation-unit} are dynamically nested, the outermost
-use will take precedence, suppressing printing of undefined warnings by inner
-uses.  However, when the \code{override} option is true this shadowing is
-inhibited; an inner use will print summary warnings for the compilations within
-the inner scope.
-
-\item[\kwd{optimize}]
-This is a CMU extension that specifies of the "global" compilation policy for
-the dynamic extent of the body.  The argument should evaluate to an
-\code{optimize} declare form, like:
-\begin{lisp}
-(optimize (speed 3) (safety 0))
-\end{lisp}
-\xlref{optimize-declaration}
-
-\item[\kwd{optimize-interface}]
-Similar to \kwd{optimize}, but specifies the compilation policy for function
-interfaces (argument count and type checking) for the dynamic extent of the
-body.  \xlref{optimize-interface-declaration}.
-
-\item[\kwd{context-declarations}]
-This is a CMU extension that pattern-matches on function names, automatically
-splicing in any appropriate declarations at the head of the function
-definition.  \xlref{context-declarations}.
-\end{description}
-\enddefmac
-
-\begin{menu}
-* Undefined Warnings::          
-* Context Declarations::        
-* Context Declaration Example::  
-\end{menu}
-
-\node Undefined Warnings, Context Declarations, Compilation Units, Compilation Units
-\subsection{Undefined Warnings}
-
-\cindex{undefined warnings}
-Warnings about undefined variables, functions and types are delayed until the
-end of the current compilation unit.  The compiler entry functions
-(\code{compile}, etc.) implicitly use \code{with-compilation-unit}, so undefined
-warnings will be printed at the end of the compilation unless there is an
-enclosing \code{with-compilation-unit}.  In order the gain the benefit of this
-mechanism, you should wrap a single \code{with-compilation-unit} around the calls
-to \code{compile-file}, i.e.:
-\begin{lisp}
-(with-compilation-unit ()
-  (compile-file "file1")
-  (compile-file "file2")
-  ...)
-\end{lisp}
-
-Unlike for functions and types, undefined warnings for variables are not
-suppressed when a definition (e.g. \code{defvar}) appears after the reference (but
-in the same compilation unit.)  This is because doing special declarations out
-of order just doesn't work \dash{} although early references will be compiled as
-special, bindings will be done lexically.
-
-Undefined warnings are printed with full source context (\pxlref{error-messages}), which tremendously simplifies the problem of finding
-undefined references that resulted from macroexpansion.  After printing
-detailed information about the undefined uses of each name,
-\code{with-compilation-unit} also prints summary listings of the names of all the
-undefined functions, types and variables.
-
-\defvar{undefined-warning-limit}
-This variable controls the number of undefined warnings for each distinct name
-that are printed with full source context when the compilation unit ends.  If
-there are more undefined references than this, then they are condensed into a
-single warning:
-\begin{example}
-Warning: \var{count} more uses of undefined function \var{name}.
-\end{example}
-When the value is \code{0}, then the undefined warnings are not broken down by
-name at all: only the summary listing of undefined names is printed.
-\enddefvar
-
-\node Context Declarations, Context Declaration Example, Undefined Warnings, Compilation Units
-\subsection{Context Declarations}
-\label{context-declarations}
-\cindex{context sensitive declarations}
-\cpsubindex{declarations}{context-sensitive}
-
-\cmucl{} has a context-sensitive declaration mechanism which is useful because it
-allows flexible control of the compilation policy in large systems without
-requiring changes to the source files.  The primary use of this feature is to
-allow the exported interfaces of a system to be compiled more safely than the
-system internals.  The context used is the name being defined and the kind of
-definition (function, macro, etc.) 
-
-The \kwd{context-declarations} option to \macref{with-compilation-unit} has
-dynamic scope, affecting all compilation done during the evaluation of the
-body.  The argument to this option should evaluate to a list of lists of the
-form:
-\begin{example}
-(\var{context-spec} \mplus{\var{declare-form}})
-\end{example}
-In the indicated context, the specified declare forms are inserted at
-the head of each definition.  The declare forms for all contexts that
-match are appended together, with earlier declarations getting
-precedence over later ones.  A simple example:
-\begin{example}
-    :context-declarations
-    '((:external (declare (optimize (safety 2)))))
-\end{example}
-This will cause all functions that are named by external symbols to be
-compiled with \code{safety 2}.
-
-The full syntax of context specs is:
-\begin{description}
-
-\item[\kwd{internal}, \kwd{external}]
-True if the symbol is internal (external) in its home package.
-
-\item[\kwd{uninterned}]
-True if the symbol has no home package.
-
-\item[\code{\w{(:package \mstar{\var{package-name}})}}]
-True if the symbol's home package is in any of the named packages (false if
-uninterned.)
-
-\item[\kwd{anonymous}]
-True if the function doesn't have any interesting name (not
-\code{defmacro}, \code{defun}, \code{labels} or \code{flet}).
-
-\item[\kwd{macro}, \kwd{function}]
-\kwd{macro} is a global (\code{defmacro}) macro.  \kwd{function} is anything
-else.
-
-\item[\kwd{local}, \kwd{global}]
-\kwd{local} is a \code{labels} or \code{flet}.  \kwd{global} is anything else.
-
-\item[\code{\w{(:or \mstar{\var{context-spec}})}}]
-True when any supplied \var{context-spec} is true.
-
-\item[\code{\w{(:and \mstar{\var{context-spec}})}}]
-True only when all supplied \var{context-spec}s are true.
-
-\item[\code{\w{(:not \mstar{\var{context-spec}})}}]
-True when \var{context-spec} is false.
-
-\item[\code{\w{(:member \mstar{\var{name}})}}]
-True when the defined name is one of these names (\code{equal} test.)
-
-\item[\code{\w{(:match \mstar{\var{pattern}})}}]
-True when any of the patterns is a substring of the name.  The name is wrapped
-with \code{$}'s, so "\code{$FOO}" matches names beginning with "\code{FOO}", etc.
-\end{description}
-
-\node Context Declaration Example,  , Context Declarations, Compilation Units
-\subsection{Context Declaration Example}
-
-Here is a more complex example of \code{with-compilation-unit} options:
-\begin{example}
-:optimize '(optimize (speed 2) (space 2) (inhibit-warnings 2)
-                     (debug 1) (safety 0))
-:optimize-interface '(optimize-interface (safety 1) (debug 1))
-:context-declarations
-'(((:or :external (:and (:match "%") (:match "SET")))
-   (declare (optimize-interface (safety 2))))
-  ((:or (:and :external :macro)
-        (:match "$PARSE-"))
-   (declare (optimize (safety 2)))))
-\end{example}
-The \code{optimize} and \code{extensions:optimize-interface} declarations (\pxlref{optimize-declaration}) set up the global compilation policy.  The
-bodies of functions are to be compiled completely unsafe (\code{safety 0}), but
-argument count and weakened argument type checking is to be done when a
-function is called (\code{speed 2 safety 1}).
-
-The first declaration specifies that all functions that are external or
-whose names contain both "\code{%}" and "\code{SET}" are to be compiled
-compiled with completely safe interfaces (\code{safety 2}).  The reason for this
-particular \kwd{match} rule is that \code{setf} inverse functions in this system
-tend to have both strings in their name somewhere.  We want \code{setf} inverses
-to be safe because they are implicitly called by users even though their name
-is not exported.
-
-The second declaration makes external macros or functions whose names start
-with "\code{PARSE-}" have safe bodies (as well as interfaces).  This is desirable
-because a syntax error in a macro may cause a type error inside the body.  The
-\kwd{match} rule is used because macros often have auxiliary functions whose
-names begin with this string.
-
-This particular example is used to build part of the standard \cmucl{} system.
-Note however, that context declarations must be set up according to the needs
-and coding conventions of a particular system; different parts of \cmucl{} are
-compiled with different context declarations, and your system will probably
-need its own declarations.  In particular, any use of the \kwd{match} option
-depends on naming conventions used in coding.
-
-
-\node Interpreting Error Messages, Types in Python, Compilation Units, The Compiler
-\section{Interpreting Error Messages}
-\label{error-messages}
-\cpsubindex{error messages}{compiler}
-\cindex{compiler error messages}
-
-One of \Python{}'s unique features is the level of source location information it
-provides in error messages.  The error messages contain a lot of detail in a
-terse format, to they may be confusing at first.  Error messages will be
-illustrated using this example program:
-\begin{lisp}
-(defmacro zoq (x)
-  `(roq (ploq (+ ,x 3))))
-
-(defun foo (y)
-  (declare (symbol y))
-  (zoq y))
-\end{lisp}
-The main problem with this program is that it is trying to add \code{3} to a
-symbol.  Note also that the functions \code{roq} and \code{ploq} aren't defined
-anywhere.
-
-\begin{menu}
-* The Parts of the Error Message::  
-* The Original and Actual Source::  
-* The Processing Path::         
-* Error Severity::              
-* Errors During Macroexpansion::  
-* Read Errors::                 
-* Error Message Parameterization::  
-\end{menu}
-
-\node The Parts of the Error Message, The Original and Actual Source, Interpreting Error Messages, Interpreting Error Messages
-\subsection{The Parts of the Error Message}
-
-The compiler will produce this warning:
-\begin{example}
-File: /usr/me/stuff.lisp
-
-In: DEFUN FOO
-  (ZOQ Y)
---> ROQ PLOQ + 
-==>
-  Y
-Warning: Result is a SYMBOL, not a NUMBER.
-\end{example}
-In this example we see each of the six possible parts of a compiler error
-message:
-\begin{description}
-
-\item[\w{\code{File: /usr/me/stuff.lisp}}]
-This is the \var{file} that the compiler read the relevant code from.  The file
-name is displayed because it may not be immediately obvious when there is an
-error during compilation of a large system, especially when
-\code{with-compilation-unit} is used to delay undefined warnings.
-
-\item[\w{\code{In: DEFUN FOO}}]
-This is the \var{definition} or top-level form responsible for the error.  It
-is obtained by taking the first two elements of the enclosing form whose first
-element is a symbol beginning with "\code{DEF}".  If there is no enclosing
-\w{\var{def}mumble}, then the outermost form is used.  If there are multiple
-\w{\var{def}mumbles}, then they are all printed from the out in, separated by
-\code{=>}'s.  In this example, the problem was in the \code{defun} for \code{foo}.
-
-\item[\w{\code{(ZOQ Y)}}]
-This is the \i{original source} form responsible for the error.  Original
-source means that the form directly appeared in the original input to the
-compiler, i.e. in the lambda passed to \code{compile} or the top-level form read
-from the source file.  In this example, the expansion of the \code{zoq} macro was
-responsible for the error.
-
-\item[\w{\code{--> ROQ PLOQ +}} ]
-This is the \i{processing path} that the compiler used to produce the
-errorful code.  The processing path is a representation of the evaluated forms
-enclosing the actual source that the compiler encountered when processing the
-original source.  The path is the first element of each form, or the form
-itself if the form is not a list.  These forms result from the expansion of
-macros or source-to-source transformation done by the compiler.  In this
-example, the enclosing evaluated forms are the calls to \code{roq}, \code{ploq} and
-\code{+}.  These calls resulted from the expansion of the \code{zoq} macro.
-
-\item[\code{==>  Y}]
-This is the \i{actual source} responsible for the error.  If the actual
-source appears in the explanation, then we print the next enclosing evaluated
-form, instead of printing the actual source twice.  (This is the form that
-would otherwise have been the last form of the processing path.)  In this
-example, the problem is with the evaluation of the reference to the variable
-\code{y}.
-
-\item[\w{\code{Warning: Result is a SYMBOL, not a NUMBER.}}]
-This is the \var{explanation} the problem.  In this example, the
-problem is that \code{y} evaluates to a \code{symbol}, but is in a context where a
-number is required (the argument to \code{+}).
-\end{description}
-
-Note that each part of the error message is distinctively marked:
-\begin{itemize}
-
-\item
-\code{File:} and \code{In:} mark the file and definition, respectively.
-
-\item
-The original source is an indented form with no prefix.
-
-\item
-Each line of the processing path is prefixed with \code{-->}.
-
-\item
-The actual source form is indented like the original source, but is marked by a
-preceding \code{==>} line.  This is like the "macroexpands to" notation used in
-\cltl.
-
-\item
-The explanation is prefixed with the error severity (\pxlref{error-severity}), either \code{Error:}, \code{Warning:}, or \code{Note:}.
-\end{itemize}
-
-
-Each part of the error message is more specific than the preceding one.  If
-consecutive error messages are for nearby locations, then the front part of the
-error messages would be the same.  In this case, the compiler omits as much of
-the second message as in common with the first.  For example:
-\begin{example}
-File: /usr/me/stuff.lisp
-
-In: DEFUN FOO
-  (ZOQ Y)
---> ROQ 
-==>
-  (PLOQ (+ Y 3))
-Warning: Undefined function: PLOQ
-
-==>
-  (ROQ (PLOQ (+ Y 3)))
-Warning: Undefined function: ROQ
-\end{example}
-In this example, the file, definition and original source are identical for the
-two messages, so the compiler omits them in the second message.  If consecutive
-messages are entirely identical, then the compiler prints only the first
-message, followed by:
-\begin{example}
-[Last message occurs \var{repeats} times]
-\end{example}
-where \var{repeats} is the number of times the message was given.
-
-If the source was not from a file, then no file line is printed.  If the actual
-source is the same as the original source, then the processing path and actual
-source will be omitted.  If no forms intervene between the original source and
-the actual source, then the processing path will also be omitted.
-
-
-\node The Original and Actual Source, The Processing Path, The Parts of the Error Message, Interpreting Error Messages
-\subsection{The Original and Actual Source}
-\cindex{original source}
-\cindex{actual source}
-
-The \i{original source} displayed will almost always be a list.  If the actual
-source for an error message is a symbol, the original source will be the
-immediately enclosing evaluated list form.  So even if the offending symbol
-does appear in the original source, the compiler will print the enclosing list
-and then print the symbol as the actual source (as though the symbol were
-introduced by a macro.)
-
-When the \i{actual source} is displayed (and is not a symbol), it will always
-be code that resulted from the expansion of a macro or a source-to-source
-compiler optimization.  This is code that did not appear in the original
-source program; it was introduced by the compiler.
-
-Keep in mind that when the compiler displays a source form in an error message,
-it always displays the most specific (innermost) responsible form.  For
-example, compiling this function:
-\begin{lisp}
-(defun bar (x)
-  (let (a)
-    (declare (fixnum a))
-    (setq a (foo x))
-    a))
-\end{lisp}
-Gives this error message:
-\begin{example}
-In: DEFUN BAR
-  (LET (A) (DECLARE (FIXNUM A)) (SETQ A (FOO X)) A)
-Warning: The binding of A is not a FIXNUM:
-  NIL
-\end{example}
-This error message is not saying "there's a problem somewhere in this \code{let}"
-\dash{} it is saying that there is a problem with the \code{let} itself.  In this
-example, the problem is that \code{a}'s \false{} initial value is not a \code{fixnum}.
-
-
-\node The Processing Path, Error Severity, The Original and Actual Source, Interpreting Error Messages
-\subsection{The Processing Path}
-\cindex{processing path}
-\cindex{macroexpansion}
-\cindex{source-to-source transformation}
-
-The processing path is mainly useful for debugging macros, so if you don't
-write macros, you can ignore the processing path.  Consider this example:
-\begin{lisp}
-(defun foo (n)
-  (dotimes (i n *undefined*)))
-\end{lisp}
-Compiling results in this error message:
-\begin{example}
-In: DEFUN FOO
-  (DOTIMES (I N *UNDEFINED*))
---> DO BLOCK LET TAGBODY RETURN-FROM 
-==>
-  (PROGN *UNDEFINED*)
-Warning: Undefined variable: *UNDEFINED*
-\end{example}
-Note that \code{do} appears in the processing path.  This is because \code{dotimes}
-expands into:
-\begin{lisp}
-(do ((i 0 (1+ i)) (#:g1 n))
-    ((>= i #:g1) *undefined*)
-  (declare (type unsigned-byte i)))
-\end{lisp}
-The rest of the processing path results from the expansion of \code{do}:
-\begin{lisp}
-(block nil
-  (let ((i 0) (#:g1 n))
-    (declare (type unsigned-byte i))
-    (tagbody (go #:g3)
-     #:g2    (psetq i (1+ i))
-     #:g3    (unless (>= i #:g1) (go #:g2))
-             (return-from nil (progn *undefined*)))))
-\end{lisp}
-In this example, the compiler descended into the \code{block}, \code{let},
-\code{tagbody} and \code{return-from} to reach the \code{progn} printed as the actual
-source.  This is a place where the "actual source appears in explanation" rule
-was applied.  The innermost actual source form was the symbol \code{*undefined*}
-itself, but that also appeared in the explanation, so the compiler backed out
-one level.
-
-
-\node Error Severity, Errors During Macroexpansion, The Processing Path, Interpreting Error Messages
-\subsection{Error Severity}
-\label{error-severity}
-\cindex{severity of compiler errors}
-\cindex{compiler error severity}
-
-There are three levels of compiler error severity:
-\begin{description}
-
-\item[Error]
-This severity is used when the compiler encounters a problem serious enough
-to prevent normal processing of a form.  Instead of compiling the form, the
-compiler compiles a call to \code{error}.  Errors are used mainly for signalling
-syntax errors.  If an error happens during macroexpansion, the compiler will
-handle it.  The compiler also handles and attempts to proceed from read errors.
-
-\item[Warning]
-Warnings are used when the compiler can prove that something bad will happen
-if a portion of the program is executed, but the compiler can proceed by
-compiling code that signals an error at runtime if the problem has not been
-fixed:
-\begin{itemize}
-
-\item
-Violation of type declarations, or
-
-\item
-Function calls that have the wrong number of arguments or malformed keyword
-argument lists, or
-
-\item
-Referencing a variable declared \code{ignore}, or unrecognized declaration
-specifiers.
-\end{itemize}
-
-In the language of the \clisp{} standard, these are situations where the compiler
-can determine that a situation with undefined consequences or that would cause
-an error to be signalled would result at runtime.
-
-\item[Note]
-Notes are used when there is something that seems a bit odd, but that might
-reasonably appear in correct programs.
-\end{description}
-Note that the compiler does not fully conform to the proposed X3J13
-"compiler-diagnostics" cleanup.  Errors, warnings and notes mostly correspond
-to errors, warnings and style-warnings, but many things that the cleanup
-considers to be style-warnings are printed as warnings rather than notes.
-Also, warnings, style-warnings and most errors aren't really signalled using
-the condition system.
-
-
-\node Errors During Macroexpansion, Read Errors, Error Severity, Interpreting Error Messages
-\subsection{Errors During Macroexpansion}
-\cpsubindex{macroexpansion}{errors during}
-
-The compiler handles errors that happen during macroexpansion, turning them
-into compiler errors.  If you want to debug the error (to debug a macro), you
-can set \code{*break-on-signals*} to \code{error}.  For example, this definition:
-\begin{lisp}
-(defun foo (e l)
-  (do ((current l (cdr current))
-       ((atom current) nil))
-      (when (eq (car current) e) (return current))))
-\end{lisp}
-gives this error:
-\begin{example}
-In: DEFUN FOO
-  (DO ((CURRENT L #) (# NIL)) (WHEN (EQ # E) (RETURN CURRENT)) )
-Error: (during macroexpansion)
-
-Error in function LISP::DO-DO-BODY.
-DO step variable is not a symbol: (ATOM CURRENT)
-\end{example}
-
-
-
-\node Read Errors, Error Message Parameterization, Errors During Macroexpansion, Interpreting Error Messages
-\subsection{Read Errors}
-\cpsubindex{read errors}{compiler}
-
-The compiler also handles errors while reading the source.  For example:
-\begin{example}
-Error: Read error at 2:
- "(,/\back foo)"
-Error in function LISP::COMMA-MACRO.
-Comma not inside a backquote.
-\end{example}
-The "\code{at 2}" refers to the character position in the source file at
-which the error was signalled, which is generally immediately after the
-erroneous text.  The next line, "\code{(,/\back foo)}", is the line in
-the source that contains the error file position.  The "\code{/\back }"
-indicates the error position within that line (in this example,
-immediately after the offending comma.)
-
-When in \hemlock{} (or any other EMACS-like editor), you can go to a
-character position with:
-\begin{example}
-M-< C-u \var{position} C-f
-\end{example}
-Note that if the source is from a \hemlock{} buffer, then the position
-is relative to the start of the compiled region or \code{defun}, not the
-file or buffer start.
-
-After printing a read error message, the compiler attempts to recover from the
-error by backing up to the start of the enclosing top-level form and reading
-again with \code{*read-suppress*} true.  If the compiler can recover from the
-error, then it substitutes a call to \code{cerror} for the unreadable form and
-proceeds to compile the rest of the file normally.
-
-If there is a read error when the file position is at the end of the file
-(i.e., an unexpected EOF error), then the error message looks like this:
-\begin{example}
-Error: Read error in form starting at 14:
- "(defun test ()"
-Error in function LISP::FLUSH-WHITESPACE.
-EOF while reading #<Stream for file "/usr/me/test.lisp">
-\end{example}
-In this case, "\code{starting at 14}" indicates the character position at which
-the compiler started reading, i.e. the position before the start of the form
-that was missing the closing delimiter.  The line \w{"\code{(defun test ()}"} is
-first line after the starting position that the compiler thinks might contain
-the unmatched open delimiter.
-
-
-\node Error Message Parameterization,  , Read Errors, Interpreting Error Messages
-\subsection{Error Message Parameterization}
-\cpsubindex{error messages}{verbosity}
-\cpsubindex{verbosity}{of error messages}
-
-There is some control over the verbosity of error messages.  See also
-\varref{undefined-warning-limit}, \code{*efficiency-note-limit*} and
-\varref{efficiency-note-cost-threshold}.
-
-\defvar{enclosing-source-cutoff} 
-This variable specifies the number
-of enclosing actual source forms that are printed in full, rather
-than in the abbreviated processing path format.  Increasing the value
-from its default of \code{1} allows you to see more of the guts of
-the macroexpanded source, which is useful when debugging macros.
-\enddefvar
-
-\defvar{error-print-length}
-\defvarx{error-print-level}
-These variables are the print level and print length used in printing
-error messages.  The default values are \code{5} and \code{3}.  If
-null, the global values of \code{*print-level*} and
-\code{*print-length*} are used.
-\enddefvar
-
-\defmac{def-source-context}[extensions]
-  {name lambda-list \mstar{form}}
-This macro defines how to extract an abbreviated source context from the
-\var{name}d form when it appears in the compiler input.
-\var{lambda-list} is a \code{defmacro} style lambda-list used to parse
-the arguments.  The \var{body} should return a list of subforms
-that can be printed on about one line.  There are predefined
-methods for \code{defstruct}, \code{defmethod}, etc.  If no method is
-defined, then the first two subforms are returned.  Note that this
-facility implicitly determines the string name associated with
-anonymous functions.
-\enddefmac
-
-
-\node Types in Python, Getting Existing Programs to Run, Interpreting Error Messages, The Compiler
-\section{Types in Python}
-\cpsubindex{types}{in python}
-
-A big difference between \Python{} and all other \llisp{} compilers
-is the approach to type checking and amount of knowledge about types:
-\begin{itemize}
-
-\item
-\Python{} treats type declarations much differently that other Lisp
-compilers do.  \Python{} doesn't blindly believe type declarations; it
-considers them assertions about the program that should be checked.
-
-\item
-\Python{} also has a tremendously greater knowledge of the \clisp{} type system than
-other compilers.  Support is incomplete only for the \code{not}, \code{and} and
-\code{satisfies} types.
-\end{itemize}
-See also sections \ref{advanced-type-stuff} and \ref{type-inference}.
-
-
-\begin{menu}
-* Compile Time Type Errors::    
-* Precise Type Checking::       
-* Weakened Type Checking::      
-\end{menu}
-
-\node Compile Time Type Errors, Precise Type Checking, Types in Python, Types in Python
-\subsection{Compile Time Type Errors}
-\cindex{compile time type errors}
-\cpsubindex{type checking}{at compile time}
-
-If the compiler can prove at compile time that some portion of the program
-cannot be executed without a type error, then it will give a warning at compile
-time.  It is possible that the offending code would never actually be executed
-at run-time due to some higher level consistency constraint unknown to the
-compiler, so a type warning doesn't always indicate an incorrect program.  For
-example, consider this code fragment:
-\begin{lisp}
-(defun raz (foo)
-  (let ((x (case foo
-             (:this 13)
-             (:that 9)
-             (:the-other 42))))
-    (declare (fixnum x))
-    (foo x)))
-\end{lisp}
-Compilation produces this warning:
-\begin{example}
-In: DEFUN RAZ
-  (CASE FOO (:THIS 13) (:THAT 9) (:THE-OTHER 42))
---> LET COND IF COND IF COND IF 
-==>
-  (COND)
-Warning: This is not a FIXNUM:
-  NIL
-\end{example}
-In this case, the warning is telling you that if \code{foo} isn't any of
-\code{:this}, \code{:that} or \code{:the-other}, then \code{x} will be initialized to
-\false, which the \code{fixnum} declaration makes illegal.  The warning will go
-away if \code{ecase} is used instead of \code{case}, or if \code{:the-other} is changed
-to \true.
-
-This sort of spurious type warning happens moderately often in the expansion
-of complex macros and in inline functions.  In such cases, there may be dead
-code that is impossible to correctly execute.  The compiler can't always prove
-this code is dead (could never be executed), so it compiles the erroneous code
-(which will always signal an error if it is executed) and gives a warning.
-
-\defun{required-argument}[extensions]{}
-This function can be used as the default value for keyword arguments that must
-always be supplied.  Since it is known by the compiler to never return, it will
-avoid any compile-time type warnings that would result from a default value
-inconsistent with the declared type.  When this function is called, it signals
-an error indicating that a required keyword argument was not supplied.  This
-function is also useful for \code{defstruct} slot defaults corresponding to
-required arguments.  \xlref{empty-type}.
-
-Although this function is a CMU extension, it is relatively harmless to use it
-in otherwise portable code, since you can easily define it yourself:
-\begin{lisp}
-(defun required-argument ()
-  (error "A required keyword argument was not supplied."))
-\end{lisp}
-\enddefun
-
-Type warnings are inhibited when the \code{extensions:inhibit-warnings}
-optimization quality is \code{3} (\pxlref{compiler-policy}.)  This can be
-used in a local declaration to inhibit type warnings in a code fragment that
-has spurious warnings.
-
-
-\node Precise Type Checking, Weakened Type Checking, Compile Time Type Errors, Types in Python
-\subsection{Precise Type Checking}
-\label{precise-type-checks}
-\cindex{precise type checking}
-\cpsubindex{type checking}{precise}
-
-With the default compilation policy, all type assertions\footnote{There are a few
-circumstances where a type declaration is discarded rather than being used as
-type assertion.  This doesn't affect safety much, since such discarded
-declarations are also not believed to be true by the compiler.}  are precisely
-checked.  Precise checking means that the check is done as though \code{typep} had
-been called with the exact type specifier that appeared in the declaration.
-\Python{} uses \var{policy} to determine whether to trust type assertions
-(\pxlref{compiler-policy}).  Type assertions from declarations are
-indistinguishable from the type assertions on arguments to built-in functions.
-In \Python, adding type declarations makes code safer.
-
-If a variable is declared to be \w{\code{(integer 3 17)}}, then its value must
-always always be an integer between \code{3} and \code{17}.  If multiple type
-declarations apply to a single variable, then all the declarations must be
-correct; it is as though all the types were intersected producing a single
-\code{and} type specifier.
-
-Argument type declarations are automatically enforced.  If you declare the type
-of a function argument, a type check will be done when that function is called.
-In a function call, the called function does the argument type checking, which
-means that a more restrictive type assertion in the calling function (e.g.,
-from \code{the}) may be lost.
-
-The types of structure slots are also checked.  The value of a
-structure slot must always be of the type indicated in any
-\code{:type} slot option.\footnote{The initial value need not be of
-this type as long as the corresponding argument to the constructor is
-always supplied, but this will cause a compile-time type warning
-unless \code{required-argument} is used.} Because of precise type
-checking, the arguments to slot accessors are checked to be the
-correct type of structure.
-
-In traditional \llisp{} compilers, not all type assertions are checked, and type
-checks are not precise.  Traditional compilers blindly trust explicit type
-declarations, but may check the argument type assertions for built-in
-functions.  Type checking is not precise, since the argument type checks will
-be for the most general type legal for that argument.  In many systems, type
-declarations suppress what little type checking is being done, so adding type
-declarations makes code unsafe.  This is a problem since it discourages
-writing type declarations during initial coding.  In addition to being more
-error prone, adding type declarations during tuning also loses all the benefits
-of debugging with checked type assertions.
-
-To gain maximum benefit from \Python{}'s type checking, you should always declare
-the types of function arguments and structure slots as precisely as possible.
-This often involves the use of \code{or}, \code{member} and other list-style type
-specifiers.  Paradoxically, even though adding type declarations introduces
-type checks, it usually reduces the overall amount of type checking.  This is
-especially true for structure slot type declarations.
-
-\Python{} uses the \code{safety} optimization quality (rather than presence or
-absence of declarations) to choose one of three levels of run-time type error
-checking: \pxlref{optimize-declaration}.  \xlref{advanced-type-stuff} for more information about types in \Python.
-
-
-\node Weakened Type Checking,  , Precise Type Checking, Types in Python
-\subsection{Weakened Type Checking}
-\label{weakened-type-checks}
-\cindex{weakened type checking}
-\cpsubindex{type checking}{weakened}
-
-When the value for the \code{speed} optimization quality is greater than
-\code{safety}, and \code{safety} is not \code{0}, then type checking is weakened to
-reduce the speed and space penalty.  In structure-intensive code this can
-double the speed, yet still catch most type errors.  Weakened type checks
-provide a level of safety similar to that of "safe" code in other \llisp{}
-compilers.
-
-A type check is weakened by changing the check to be for some
-convenient supertype of the asserted type.  For example,
-\code{\w{(integer 3 17)}} is changed to \code{fixnum},
-\code{\w{(simple-vector 17)}} to \code{simple-vector}, and structure
-types are changed to \code{structure}.  A complex check like:
-\begin{example}
-(or node hunk (member :foo :bar :baz))
-\end{example}
-will be omitted entirely (i.e., the check is weakened to \code{*}.)  If
-a precise check can be done for no extra cost, then no weakening is
-done.
-
-Although weakened type checking is similar to type checking done by other
-compilers, it is sometimes safer and sometimes less safe.  Weakened checks are
-done in the same places is precise checks, so all the preceding discussion
-about where checking is done still applies.  Weakened checking is sometimes
-somewhat unsafe because although the check is weakened, the precise type is
-still input into type inference.  In some contexts this will result in type
-inferences not justified by the weakened check, and hence deletion of some type
-checks that would be done by conventional compilers.
-
-For example, if this code was compiled with weakened checks:
-\begin{lisp}
-(defstruct foo
-  (a nil :type simple-string))
-
-(defstruct bar
-  (a nil :type single-float))
-
-(defun myfun (x)
-  (declare (type bar x))
-  (* (bar-a x) 3.0))
-\end{lisp}
-and \code{myfun} was passed a \code{foo}, then no type error would be signalled, and
-we would try to multiply a \code{simple-vector} as though it were a float (with
-unpredictable results.)  This is because the check for \code{bar} was weakened to
-\code{structure}, yet when compiling the call to \code{bar-a}, the compiler thinks it
-knows it has a \code{bar}.
-
-Note that normally even weakened type checks report the precise type in error
-messages.  For example, if \code{myfun}'s \code{bar} check is weakened to
-\code{structure}, and the argument is \false{}, then the error will be:
-\begin{example}
-Type-error in MYFUN:
-  NIL is not of type BAR
-\end{example}
-However, there is some speed and space cost for signalling a precise error, so
-the weakened type is reported if the \code{speed} optimization quality is \code{3} or
-\code{debug} quality is less than \code{1}:
-\begin{example}
-Type-error in MYFUN:
-  NIL is not of type STRUCTURE
-\end{example}
-\xlref{optimize-declaration} for further discussion of the
-\code{optimize} declaration.
-
-
-\node Getting Existing Programs to Run, Compiler Policy, Types in Python, The Compiler
-\section{Getting Existing Programs to Run}
-\cpsubindex{existing programs}{to run}
-\cpsubindex{types}{portability}
-\cindex{compatibility with other Lisps}
-
-Since \Python{} does much more comprehensive type checking than other Lisp
-compilers, \Python{} will detect type errors in many programs that have been
-debugged using other compilers.  These errors are mostly incorrect
-declarations, although compile-time type errors can find actual bugs if parts
-of the program have never been tested.  
-
-Some incorrect declarations can only be detected by run-time type checking.  It
-is very important to initially compile programs with full type checks and then
-test this version.  After the checking version has been tested, then you can
-consider weakening or eliminating type checks.  \b{This applies even to
-previously debugged programs.}  \Python{} does much more type inference than
-other \llisp{} compilers, so believing an incorrect declaration does much more
-damage.
-
-The most common problem is with variables whose initial value doesn't match the
-type declaration.  Incorrect initial values will always be flagged by a
-compile-time type error, and they are simple to fix once located.  Consider
-this code fragment:
-\begin{example}
-(prog (foo)
-  (declare (fixnum foo))
-  (setq foo ...)
-  ...)
-\end{example}
-Here the variable \code{foo} is given an initial value of \false, but is declared
-to be a \code{fixnum}.  Even if it is never read, the initial value of a variable
-must match the declared type.  There are two ways to fix this problem.  Change
-the declaration:
-\begin{example}
-(prog (foo)
-  (declare (type (or fixnum null) foo))
-  (setq foo ...)
-  ...)
-\end{example}
-or change the initial value:
-\begin{example}
-(prog ((foo 0))
-  (declare (fixnum foo))
-  (setq foo ...)
-  ...)
-\end{example}
-It is generally preferable to change to a legal initial value rather than to
-weaken the declaration, but sometimes it is simpler to weaken the
-declaration than to try to make an initial value of the appropriate type.
-
-
-Another declaration problem occasionally encountered is incorrect declarations
-on \code{defmacro} arguments.  This probably usually happens when a function is
-converted into a macro.   Consider this macro:
-\begin{lisp}
-(defmacro my-1+ (x)
-  (declare (fixnum x))
-  `(the fixnum (1+ ,x)))
-\end{lisp}
-Although legal and well-defined \clisp, this meaning of this definition is
-almost certainly not what the writer intended.  For example, this call is
-illegal:
-\begin{lisp}
-(my-1+ (+ 4 5))
-\end{lisp}
-The call is illegal because the argument to the macro is \w{\code{(+ 4 5)}}, which
-is a \code{list}, not a \code{fixnum}.  Because of macro semantics, it is hardly ever
-useful to declare the types of macro arguments.  If you really want to assert
-something about the type of the result of evaluating a macro argument, then put
-a \code{the} in the expansion:
-\begin{lisp}
-(defmacro my-1+ (x)
-  `(the fixnum (1+ (the fixnum ,x))))
-\end{lisp}
-In this case, it would be stylistically preferable to change this macro back to
-a function and declare it inline.  Macros have no efficiency advantage over
-inline functions when using \Python.  \xlref{inline-expansion}.
-
-
-Some more subtle problems are caused by incorrect declarations that can't be
-detected at compile time.  Consider this code:
-\begin{example}
-(do ((pos 0 (position #\back a string :start (1+ pos))))
-    ((null pos))
-  (declare (fixnum pos))
-  ...)
-\end{example}
-Although \code{pos} is almost always a \code{fixnum}, it is \false{} at the end of the
-loop.  If this example is compiled with full type checks (the default), then
-running it will signal a type error at the end of the loop.  If compiled
-without type checks, the program will go into an infinite loop (or perhaps
-\code{position} will complain because \w{\code{(1+ nil)}} isn't a sensible start.)
-Why?  Because if you compile without type checks, the compiler just quietly
-believes the type declaration.  Since \code{pos} is always a \code{fixnum}, it is
-never \nil, so \w{\code{(null pos)}} is never true, and the loop exit test is
-optimized away.  Such errors are sometimes flagged by unreachable code notes
-(\pxlref{dead-code-notes}), but it is still important to initially compile
-any system with full type checks, even if the system works fine when compiled
-using other compilers.
-
-In this case, the fix is to weaken the type declaration to
-\w{\code{(or fixnum null)}}.\footnote{Actually, this declaration is totally
-unnecessary in \Python, since it already knows \code{position} returns a
-non-negative \code{fixnum} or \false.}  Note that there is usually little
-performance penalty for weakening a declaration in this way.  Any numeric
-operations in the body can still assume the variable is a \code{fixnum}, since
-\false{} is not a legal numeric argument.  Another possible fix would be to say:
-\begin{example}
-(do ((pos 0 (position #\back a string :start (1+ pos))))
-    ((null pos))
-  (let ((pos pos))
-    (declare (fixnum pos))
-    ...))
-\end{example}
-This would be preferable in some circumstances, since it would allow a
-non-standard representation to be used for the local \code{pos} variable in the
-loop body (see section \ref{ND-variables}.)
-
-In summary, remember that \var{all} values that a variable \var{ever} has must be
-of the declared type, and that you should test using safe code initially.
-
-
-\node Compiler Policy, Open Coding and Inline Expansion, Getting Existing Programs to Run, The Compiler
-\section{Compiler Policy}
-\label{compiler-policy}
-\cpsubindex{policy}{compiler}
-\cindex{compiler policy}
-
-The policy is what tells the compiler \var{how} to compile a program.  This is
-logically (and often textually) distinct from the program itself.  Broad
-control of policy is provided by the \code{optimize} declaration; other
-declarations and variables control more specific aspects of compilation.
-
-
-\begin{menu}
-* The Optimize Declaration::    
-* The Optimize-Interface Declaration::  
-\end{menu}
-
-\node The Optimize Declaration, The Optimize-Interface Declaration, Compiler Policy, Compiler Policy
-\subsection{The Optimize Declaration}
-\label{optimize-declaration}
-\cindex{optimize declaration}
-\cpsubindex{declarations}{\code{optimize}}
-
-The \code{optimize} declaration recognizes six different \var{qualities}.  The
-qualities are conceptually independent aspects of program performance.  In
-reality, increasing one quality tends to have adverse effects on other
-qualities.  The compiler compares the relative values of qualities when it
-needs to make a trade-off; i.e., if \code{speed} is greater than \code{safety}, then
-improve speed at the cost of safety.
-
-The default for all qualities (except \code{debug}) is \code{1}.  Whenever
-qualities are equal, ties are broken according to a broad idea of what a good
-default environment is supposed to be.  Generally this downplays \code{speed},
-\code{compile-speed} and \code{space} in favor of \code{safety} and \code{debug}.
-Novice and casual users should stick to the default policy.  Advanced users
-often want to improve speed and memory usage at the cost of safety and
-debuggability.
-
-If the value for a quality is \code{0} or \code{3}, then it may have a special
-interpretation.  A value of \code{0} means "totally unimportant", and a \code{3}
-means "ultimately important."  These extreme optimization values enable
-"heroic" compilation strategies that are not always desirable and sometimes
-self-defeating.  Specifying more than one quality as \code{3} is not desirable,
-since it doesn't tell the compiler which quality is most important.
-
-
-These are the optimization qualities:
-\begin{description}
-
-\item[\code{speed}]
-\cindex{speed optimization quality}How fast the program should is run.
-\code{speed 3} enables some optimizations that hurt debuggability.
-
-\item[\code{compilation-speed}]
-\cindex{compilation-speed optimization quality}How fast the compiler should
-run.  Note that increasing this above \code{safety} weakens type checking.
-
-\item[\code{space}]
-\cindex{space optimization quality}How much space the compiled code should take
-up.  Inline expansion is mostly inhibited when \code{space} is greater than
-\code{speed}.  A value of \code{0} enables promiscuous inline expansion.  Wide use of
-a \code{0} value is not recommended, as it may waste so much space that run time
-is slowed.  \xlref{inline-expansion} for a discussion of inline
-expansion.
-
-\item[\code{debug}]
-\cindex{debug optimization quality}How debuggable the program should be.  The
-quality is treated differently from the other qualities: each value indicates a
-particular level of debugger information; it is not compared with the other
-qualities.  \xlref{debugger-policy} for more details.
-
-\item[\code{safety}]
-\cindex{safety optimization quality}How much error checking should be done.  If
-\code{speed}, \code{space} or \code{compilation-speed} is more important than
-\code{safety}, then type checking is weakened (\pxlref{weakened-type-checks}).  If \code{safety} if \code{0}, then no run time error
-checking is done.  In addition to suppressing type checks, \code{0} also
-suppresses argument count checking, unbound-symbol checking and array bounds
-checks.
-
-\item[\code{extensions:inhibit-warnings}]
-\cindex{inhibit-warnings optimization quality}This is a CMU extension that
-determines how little (or how much) diagnostic output should be printed during
-compilation.  This quality is compared to other qualities to determine whether
-to print style notes and warnings concerning those qualities.  If \code{speed} is
-greater than \code{inhibit-warnings}, then notes about how to improve speed will
-be printed, etc.  The default value is \code{1}, so raising the value for any
-standard quality above its default enables notes for that quality.  If
-\code{inhibit-warnings} is \code{3}, then all notes and most non-serious warnings are
-inhibited.  This is useful with \code{declare} to suppress warnings about
-unavoidable problems.
-\end{description}
-
-\node The Optimize-Interface Declaration,  , The Optimize Declaration, Compiler Policy
-\subsection{The Optimize-Interface Declaration}
-\label{optimize-interface-declaration}
-\cindex{optimize-interface declaration}
-\cpsubindex{declarations}{\code{optimize-interface}}
-
-The \code{extensions:optimize-interface} declaration is identical in syntax to the
-\code{optimize} declaration, but it specifies the policy used during compilation
-of code the compiler automatically generates to check the number and type of
-arguments supplied to a function.  It is useful to specify this policy
-separately, since even thoroughly debugged functions are vulnerable to being
-passed the wrong arguments.  The \code{optimize-interface} declaration can specify
-that arguments should be checked even when the general \code{optimize} policy is
-unsafe.
-
-Note that this argument checking is the checking of user-supplied arguments to
-any functions defined within the scope of the declaration, \code{not} the checking
-of arguments to \llisp{} primitives that appear in those definitions.
-
-The idea behind this declaration is that it allows the definition of functions
-that appear fully safe to other callers, but that do no internal error
-checking.  Of course, it is possible that arguments may be invalid in ways
-other than having incorrect type.  Functions compiled unsafely must still
-protect themselves against things like user-supplied array indices that are out
-of bounds and improper lists.  See also the \kwd{context-declarations} option
-to \macref{with-compilation-unit}.
-
-
-\node Open Coding and Inline Expansion,  , Compiler Policy, The Compiler
-\section{Open Coding and Inline Expansion}
-\label{open-coding}
-\cindex{open-coding}
-\cindex{inline expansion}
-\cindex{static functions}
-
-Since \clisp{} forbids the redefinition of standard functions\footnote{See the
-proposed X3J13 "lisp-symbol-redefinition" cleanup.}, the compiler can have
-special knowledge of these standard functions embedded in it.  This special
-knowledge is used in various ways (open coding, inline expansion, source
-transformation), but the implications to the user are basically the same:
-\begin{itemize}
-
-\item
-Attempts to redefine standard functions may be frustrated, since the function
-may never be called.  Although it is technically illegal to redefine standard
-functions, users sometimes want to implicitly redefine these functions when
-they are debugging using the \code{trace} macro.  Special-casing of standard
-functions can be inhibited using the \code{notinline} declaration.
-
-\item
-The compiler can have multiple alternate implementations of standard functions
-that implement different trade-offs of speed, space and safety.  This selection
-is based on the compiler policy, \pxlref{compiler-policy}.
-\end{itemize}
-
-
-When a function call is \i{open coded}, inline code whose effect is
-equivalent to the function call is substituted for that function call.
-When a function call is \i{closed coded}, it is usually left as is,
-although it might be turned into a call to a different function with
-different arguments.  As an example, if \code{nthcdr} were to be open
-coded, then
-\begin{lisp}
-(nthcdr 4 foobar)
-\end{lisp}
-might turn into
-\begin{lisp}
-(cdr (cdr (cdr (cdr foobar))))
-\end{lisp}
-or even 
-\begin{lisp}
-(do ((i 0 (1+ i))
-     (list foobar (cdr foobar)))
-    ((= i 4) list))
-\end{lisp}
-
-If \code{nth} is closed coded, then
-\begin{lisp}
-(nth x l)
-\end{lisp}
-might stay the same, or turn into something like:
-\begin{lisp}
-(car (nthcdr x l))
-\end{lisp}
-
-In general, open coding sacrifices space for speed, but some functions (such as
-\code{car}) are so simple that they are always open-coded.  Even when not
-open-coded, a call to a standard function may be transformed into a different
-function call (as in the last example) or compiled as \i{static call}.  Static
-function call uses a more efficient calling convention that forbids
-redefinition.
-
-\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/efficiency.ms}
-
-
-
-\hide{ -*- Dictionary: cmu-user -*- }
-\node Advanced Compiler Use and Efficiency Hints, UNIX Interface, The Compiler, Top
-\chapter{Advanced Compiler Use and Efficiency Hints}
-\begin{center}
-\b{By Robert MacLachlan}
-\end{center}
-\vspace{1 cm}
-\label{advanced-compiler}
-
-\begin{menu}
-* Advanced Compiler Introduction::  
-* More About Types in Python::  
-* Type Inference::              
-* Source Optimization::         
-* Tail Recursion::              
-* Local Call::                  
-* Block Compilation::           
-* Inline Expansion::            
-* Object Representation::       
-* Numbers::                     
-* General Efficiency Hints::    
-* Efficiency Notes::            
-* Profiling::                   
-\end{menu}
-
-\node Advanced Compiler Introduction, More About Types in Python, Advanced Compiler Use and Efficiency Hints, Advanced Compiler Use and Efficiency Hints
-\section{Advanced Compiler Introduction}
-
-In \cmucl, as is any language on any computer, the path to efficient code
-starts with good algorithms and sensible programming techniques, but to avoid
-inefficiency pitfalls, you need to know some of this implementation's quirks
-and features.  This chapter is mostly a fairly long and detailed overview of
-what optimizations \python{} does.  Although there are the usual negative
-suggestions of inefficient features to avoid, the main emphasis is on
-describing the things that programmers can count on being efficient.
-
-The optimizations described here can have the effect of speeding up existing
-programs written in conventional styles, but the potential for new programming
-styles that are clearer and less error-prone is at least as significant.  For
-this reason, several sections end with a discussion of the implications of
-these optimizations for programming style.
-
-\begin{menu}
-* Types::                       
-* Optimization::                
-* Function Call::               
-* Representation of Objects::   
-* Writing Efficient Code::      
-\end{menu}
-
-\node Types, Optimization, Advanced Compiler Introduction, Advanced Compiler Introduction
-\subsection{Types}
-
-Python's support for types is unusual in three major ways:
-\begin{itemize}
-
-\item
-Precise type checking encourages the specific use of type declarations as a
-form of run-time consistency checking.  This speeds development by localizing
-type errors and giving more meaningful error messages.  \xlref{precise-type-checks}.  \python{} produces completely safe code; optimized
-type checking maintains reasonable efficiency on conventional hardware (\pxlref{type-check-optimization}.)
-
-\item
-Comprehensive support for the \clisp{} type system makes complex type specifiers
-useful.  Using type specifiers such as \code{or} and \code{member} has both
-efficiency and robustness advantages.  \xlref{advanced-type-stuff}.
-
-\item
-Type inference eliminates the need for some declarations, and also aids
-compile-time detection of type errors.  Given detailed type declarations, type
-inference can often eliminate type checks and enable more efficient object
-representations and code sequences.  Checking all types results in
-fewer type checks.  See sections \ref{type-inference} and
-\ref{non-descriptor}.
-\end{itemize}
-
-
-\node Optimization, Function Call, Types, Advanced Compiler Introduction
-\subsection{Optimization}
-
-The main barrier to efficient Lisp programs is not that there is no efficient
-way to code the program in Lisp, but that it is difficult to arrive at that
-efficient coding.  Common Lisp is a highly complex language, and usually has
-many semantically equivalent "reasonable" ways to code a given problem.  It is
-desirable to make all of these equivalent solutions have comparable efficiency
-so that programmers don't have to waste time discovering the most efficient
-solution.
-
-Source level optimization increases the number of efficient ways to solve a
-problem.  This effect is much larger than the increase in the efficiency of the
-"best" solution.  Source level optimization transforms the original program
-into a more efficient (but equivalent) program.  Although the optimizer isn't
-doing anything the programmer couldn't have done, this high-level optimization
-is important because:
-\begin{itemize}
-
-\item
-The programmer can code simply and directly, rather than obfuscating code to
-please the compiler.
-
-\item
-When presented with a choice of similar coding alternatives, the programmer can
-chose whichever happens to be most convenient, instead of worrying about which
-is most efficient.
-\end{itemize}
-
-Source level optimization eliminates the need for macros to optimize their
-expansion, and also increases the effectiveness of inline expansion.
-See sections \ref{source-optimization} and \ref{inline-expansion}.
-
-Efficient support for a safer programming style is the biggest advantage of
-source level optimization.  Existing tuned programs typically won't benefit
-much from source optimization, since their source has already been optimized by
-hand.  However, even tuned programs tend to run faster under \python{} because:
-\begin{itemize}
-
-\item
-Low level optimization and register allocation provides modest speedups in any
-program.
-
-\item
-Block compilation and inline expansion can reduce function call overhead,
-but may require some program restructuring.  See sections
-\ref{inline-expansion}, \ref{local-call} and \ref{block-compilation}.
-
-\item
-Efficiency notes will point out important type declarations that are often
-missed even in highly tuned programs.  \xlref{efficiency-notes}.
-
-\item
-Existing programs can be compiled safely without prohibitive speed penalty,
-although they would be faster and safer with added declarations.  \xlref{type-check-optimization}.
-\end{itemize}
-
-
-\node Function Call, Representation of Objects, Optimization, Advanced Compiler Introduction
-\subsection{Function Call}
-
-The sort of symbolic programs generally written in \llisp{} often favor recursion
-over iteration, or have inner loops so complex that they involve multiple
-function calls.  Such programs spend a larger fraction of their time doing
-function calls than is the norm in other languages; for this reason \llisp{}
-implementations strive to make the general (or full) function call as
-inexpensive as possible.  \python{} goes beyond this by providing two good
-alternatives to full call:
-\begin{itemize}
-
-\item
-Local call resolves function references at compile time, allowing better
-calling sequences and optimization across function calls.  \xlref{local-call}.
-
-\item
-Inline expansion totally eliminates call overhead and allows many context
-dependent optimizations.  This provides a safe and efficient implementation of
-operations with function semantics, eliminating the need for error-prone macro
-definitions or manual case analysis.  Although most \clisp{} implementations
-support inline expansion, it becomes a more powerful tool with \python{}'s source
-level optimization.  See sections \ref{source-optimization} and
-\ref{inline-expansion}.
-\end{itemize}
-
-
-Generally, \python{} provides simple implementations for simple uses of function
-call, rather than having only a single calling convention.  These features
-allow a more natural programming style:
-\begin{itemize}
-
-\item
-Proper tail recursion.  \xlref{tail-recursion}
-
-\item
-Relatively efficient closures.
-
-\item
-A \code{funcall} that is as efficient as normal named call.
-
-\item
-Calls to local functions such as from \code{labels} are optimized:
-\begin{itemize}
-
-\item
-Control transfer is a direct jump.
-
-\item
-The closure environment is passed in registers rather than heap allocated.
-
-\item
-Keyword arguments and multiple values are implemented more efficiently.
-\end{itemize}
-
-\xlref{local-call}.
-\end{itemize}
-
-\node Representation of Objects, Writing Efficient Code, Function Call, Advanced Compiler Introduction
-\subsection{Representation of Objects}
-
-Sometimes traditional \llisp{} implementation techniques compare so poorly to the
-techniques used in other languages that \llisp{} can become an impractical
-language choice.  Terrible inefficiencies appear in number-crunching programs,
-since \llisp{} numeric operations often involve number-consing and generic
-arithmetic.  \python{} supports efficient natural representations for numbers
-(and some other types), and allows these efficient representations to be used
-in more contexts.  \python{} also provides good efficiency notes that warn when a
-crucial declaration is missing.
-
-See section \ref{non-descriptor} for more about object representations and
-numeric types.  Also \pxlref{efficiency-notes} about efficiency notes.
-
-\node Writing Efficient Code,  , Representation of Objects, Advanced Compiler Introduction
-\subsection{Writing Efficient Code}
-\label{efficiency-overview}
-
-Writing efficient code that works is a complex and prolonged process.  It is
-important not to get so involved in the pursuit of efficiency that you lose
-sight of what the original problem demands.  Remember that:
-\begin{itemize}
-
-\item
-The program should be correct \dash{} it doesn't matter how quickly you get the
-wrong answer.
-
-\item
-Both the programmer and the user will make errors, so the program must be
-robust \dash{} it must detect errors in a way that allows easy correction.
-
-\item
-A small portion of the program will consume most of the resources, with the
-bulk of the code being virtually irrelevant to efficiency considerations.  Even
-experienced programmers familiar with the problem area cannot reliably predict
-where these "hot spots" will be.
-\end{itemize}
-
-
-
-The best way to get efficient code that is still worth using, is to separate
-coding from tuning.  During coding, you should:
-\begin{itemize}
-
-\item
-Use a coding style that aids correctness and robustness without being
-incompatible with efficiency.
-
-\item
-Choose appropriate data structures that allow efficient algorithms and object
-representations (\pxlref{object-representation}).  Try to make
-interfaces abstract enough so that you can change to a different representation
-if profiling reveals a need.
-
-\item
-Whenever you make an assumption about a function argument or global data
-structure, add consistency assertions, either with type declarations or
-explicit uses of \code{assert}, \code{ecase}, etc.
-\end{itemize}
-
-During tuning, you should:
-\begin{itemize}
-
-\item
-Identify the hot spots in the program through profiling (section
-\ref{profiling}.)
-
-\item
-Identify inefficient constructs in the hot spot with efficiency notes, more
-profiling, or manual inspection of the source.  See sections
-\ref{general-efficiency} and \ref{efficiency-notes}.
-
-\item
-Add declarations and consider the application of optimizations.  See sections
-\ref{local-call}, \ref{inline-expansion} and \ref{non-descriptor}.
-
-\item
-If all else fails, consider algorithm or data structure changes.  If you did a
-good job coding, changes will be easy to introduce.
-\end{itemize}
-
-
-
-
-\node More About Types in Python, Type Inference, Advanced Compiler Introduction, Advanced Compiler Use and Efficiency Hints
-\section{More About Types in Python}
-\label{advanced-type-stuff}
-\cpsubindex{types}{in python}
-
-This section goes into more detail describing what types and declarations are
-recognized by \python.  The area where \python{} differs most radically from
-previous \llisp{} compilers is in its support for types:
-\begin{itemize}
-
-\item
-Precise type checking helps to find bugs at run time.
-
-\item
-Compile-time type checking helps to find bugs at compile time.
-
-\item
-Type inference minimizes the need for generic operations, and also increases
-the efficiency of run time type checking and the effectiveness of compile time
-type checking.
-
-\item
-Support for detailed types provides a wealth of opportunity for 
-operation-specific type inference and optimization.
-\end{itemize}
-
-
-
-\begin{menu}
-* More Types Meaningful::       
-* Canonicalization::            
-* Member Types::                
-* Union Types::                 
-* The Empty Type::              
-* Function Types::              
-* The Values Declaration::      
-* Structure Types::             
-* The Freeze-Type Declaration::  
-* Type Restrictions::           
-* Type Style Recommendations::  
-\end{menu}
-
-\node More Types Meaningful, Canonicalization, More About Types in Python, More About Types in Python
-\subsection{More Types Meaningful}
-
-\clisp{} has a very powerful type system, but conventional \llisp{} implementations
-typically only recognize the small set of types special in that
-implementation.  In these systems, there is an unfortunate paradox: a
-declaration for a relatively general type like \code{fixnum} will be recognized by
-the compiler, but a highly specific declaration such as \code{\w{(integer 3 17)}}
-is totally ignored.
-
-This is obviously a problem, since the user has to know how to specify the type
-of an object in the way the compiler wants it.  A very minimal (but rarely
-satisfied) criterion for type system support is that it be no worse to make a
-specific declaration than to make a general one.  \python{} goes beyond this by
-exploiting a number of advantages obtained from detailed type information.
-
-Using more restrictive types in declarations allows the compiler to do better
-type inference and more compile-time type checking.  Also, when type
-declarations are considered to be consistency assertions that should be
-verified (conditional on policy), then complex types are useful for making more
-detailed assertions.
-
-Python "understands" the list-style \code{or}, \code{member}, \code{function}, array and
-number type specifiers.  Understanding means that:
-\begin{itemize}
-
-\item
-If the type contains more information than is used in a particular context,
-then the extra information is simply ignored, rather than derailing type
-inference.
-
-\item
-In many contexts, the extra information from these type specifier is used to
-good effect.  In particular, type checking in \code{Python} is \var{precise}, so
-these complex types can be used in declarations to make interesting assertions
-about functions and data structures (\pxlref{precise-type-checks}.)
-More specific declarations also aid type inference and reduce the cost for
-type checking.
-\end{itemize}
-
-For related information, \pxlref{numeric-types} for numeric types, and
-section \ref{array-types} for array types.
-
-
-\node Canonicalization, Member Types, More Types Meaningful, More About Types in Python
-\subsection{Canonicalization}
-\cpsubindex{types}{equivalence}
-\cindex{canonicalization of types}
-\cindex{equivalence of types}
-
-When given a type specifier, \python{} will often rewrite it into a different
-(but equivalent) type.  This is the mechanism that \python{} uses for detecting
-type equivalence.  For example, in \python{}'s canonical representation, these
-types are equivalent:
-\begin{example}
-(or list (member :end)) \equiv{} (or cons (member nil :end))
-\end{example}
-This has two implications for the user:
-\begin{itemize}
-
-\item
-The standard symbol type specifiers for \code{atom}, \code{null},
-\code{fixnum}, etc., are in no way magical.  The \tindexed{null} type
-is actually defined to be \code{\w{(member nil)}}, \tindexed{list} is
-\code{\w{(or cons null)}}, and \tindexed{fixnum} is
-\code{\w{(signed-byte 30)}}.
-
-\item
-When the compiler prints out a type, it may not look like the type specifier
-that originally appeared in the program.  This is generally not a problem, but
-it must be taken into consideration when reading compiler error messages.
-\end{itemize}
-
-
-\node Member Types, Union Types, Canonicalization, More About Types in Python
-\subsection{Member Types}
-\cindex{member types}
-
-The \tindexed{member} type specifier can be used to represent
-"symbolic" values, analogous to the enumerated types of Pascal.  For
-example, the second value of \code{find-symbol} has this type:
-\begin{lisp}
-(member :internal :external :inherited nil)
-\end{lisp}
-Member types are very useful for expressing consistency constraints on data
-structures, for example:
-\begin{lisp}
-(defstruct ice-cream
-  (flavor :vanilla :type (member :vanilla :chocolate :strawberry)))
-\end{lisp}
-Member types are also useful in type inference, as the number of members can
-sometimes be pared down to one, in which case the value is a known constant.
-
-\node Union Types, The Empty Type, Member Types, More About Types in Python
-\subsection{Union Types}
-\cindex{union (\code{or}) types}
-\cindex{or (union) types}
-
-The \tindexed{or} (union) type specifier is understood, and is
-meaningfully applied in many contexts.  The use of \code{or} allows
-assertions to be made about types in dynamically typed programs.  For
-example:
-\begin{lisp}
-(defstruct box
-  (next nil :type (or box null))
-  (top :removed :type (or box-top (member :removed))))
-\end{lisp}
-The type assertion on the \code{top} slot ensures that an error will be signalled
-when there is an attempt to store an illegal value (such as \code{:rmoved}.)
-Although somewhat weak, these union type assertions provide a useful input into
-type inference, allowing the cost of type checking to be reduced.  For example,
-this loop is safely compiled with no type checks:
-\begin{lisp}
-(defun find-box-with-top (box)
-  (declare (type (or box null) box))
-  (do ((current box (box-next current)))
-      ((null current))
-    (unless (eq (box-top current) :removed)
-      (return current))))
-\end{lisp}
-
-Union types are also useful in type inference for representing types that are
-partially constrained.  For example, the result of this expression:
-\begin{lisp}
-(if foo
-    (logior x y)
-    (list x y))
-\end{lisp}
-can be expressed as \code{\w{(or integer cons)}}.
-
-\node The Empty Type, Function Types, Union Types, More About Types in Python
-\subsection{The Empty Type}
-\label{empty-type}
-\cindex{NIL type}
-\cpsubindex{empty type}{the}
-\cpsubindex{errors}{result type of}
-
-The type \false{} is also called the empty type, since no object is
-of type \false{}.  The union of no types, \code{(or)}, is also empty.
-\python{}'s interpretation of an expression whose type is \false{} is
-that the expression never yields any value, but rather fails to
-terminate, or is thrown out of.  For example, the type of a call to
-\code{error} or a use of \code{return} is \false{}.  When the type of
-an expression is empty, compile-time type warnings about its value
-are suppressed; presumably somebody else is signalling an error.  If
-a function is declared to have return type \false{}, but does in fact
-return, then (in safe compilation policies) a 
-\code{"NIL Function returned"} error will be signalled.  See also the function
-\funref{required-argument}.
-
-\node Function Types, The Values Declaration, The Empty Type, More About Types in Python
-\subsection{Function Types}
-\label{function-types}
-\cpsubindex{function}{types}
-\cpsubindex{types}{function}
-
-\findexed{function} types are understood in the restrictive sense, specifying:
-\begin{itemize}
-
-\item
-The argument syntax that the function must be called with.  This is
-information about what argument counts are acceptable, and which
-keyword arguments are recognized.  In \python, warnings about
-argument syntax are a consequence of function type checking.
-
-\item
-The types of the argument values that the caller must pass.  If the compiler
-can prove that some argument to a call is of a type disallowed by the called
-function's type, then it will give a compile-time type warning.  In addition to
-being used for compile-time type checking, these type assertions are also used
-as output type assertions in code generation.  For example, if \code{foo} is
-declared to have a \code{fixnum} argument, then the \code{1+} in \w{\code{(foo (1+ x))}}
-is compiled with knowledge that the result must be a fixnum.
-
-\item
-The types the values that will be bound to argument variables in the function's
-definition.  Declaring a function's type with \code{ftype} implicitly declares the
-types of the arguments in the definition.  \python{} checks for consistency
-between the definition and the \code{ftype} declaration.  Because of precise type
-checking, an error will be signalled when a function is called with an argument
-of the wrong type.
-
-\item
-The type of return value(s) that the caller can expect.  This information is a
-useful input to type inference.  For example, if a function is declared to
-return a \code{fixnum}, then when a call to that function appears in an
-expression, the expression will be compiled with knowledge that the call will
-return a \code{fixnum}.
-
-\item
-The type of return value(s) that the definition must return.  The result type
-in an \code{ftype} declaration is treated like an implicit \code{the} wrapped around
-the body of the definition.  If the definition returns a value of the wrong
-type, an error will be signalled.  If the compiler can prove that the function
-returns the wrong type, then it will give a compile-time warning.
-\end{itemize}
-
-This is consistent with the new interpretation of function types and the
-\code{ftype} declaration in the proposed X3J13
-"function-type-argument-type-semantics" cleanup.  Note also, that if you don't
-explicitly declare the type of a function using a global \code{ftype} declaration,
-then \python{} will compute a function type from the definition, providing a
-degree of inter-routine type inference, \pxlref{function-type-inference}.
-
-\node The Values Declaration, Structure Types, Function Types, More About Types in Python
-\subsection{The Values Declaration}
-\cindex{values declaration}
-
-\cmucl{} supports the \code{values} declaration as an extension to \clisp.  The
-syntax is \w{\code{(values \i{type1} \i{type2} ... \var{typen})}}.
-This declaration is semantically equivalent to a \code{the} form
-wrapped around the body of the special form in which the
-\code{values} declaration appears.  The advantage of \code{values}
-over \findexed{the} is purely syntactic \dash{} it doesn't introduce
-more indentation.  For example:
-\begin{example}
-(defun foo (x)
-  (declare (values single-float))
-  (ecase x
-    (:this ...)
-    (:that ...)
-    (:the-other ...)))
-\end{example}
-is equivalent to:
-\begin{example}
-(defun foo (x)
-  (the single-float
-       (ecase x
-         (:this ...)
-         (:that ...)
-         (:the-other ...))))
-\end{example}
-and
-\begin{example}
-(defun floor (number &optional (divisor 1))
-  (declare (values integer real))
-  ...)
-\end{example}
-is equivalent to:
-\begin{example}
-(defun floor (number &optional (divisor 1))
-  (the (values integer real)
-       ...))
-\end{example}
-In addition to being recognized by \code{lambda} (and hence by \code{defun}), the
-\code{values} declaration is recognized by all the other special forms with bodies
-and declarations: \code{let}, \code{let*}, \code{labels} and \code{flet}.  Macros with
-declarations usually splice the declarations into one of the above forms, so
-they will accept this declaration too, but the exact effect of a \code{values}
-declaration will depend on the macro.
-
-If you declare the types of all arguments to a function, and also declare the
-return value types with \code{values}, you have described the type of the
-function.  \python{} will use this argument and result type information to derive
-a function type that will then be applied to calls of the function (\pxlref{function-types}.)  This provides a way to declare the types of functions
-that is much less syntactically awkward than using the \code{ftype} declaration
-with a \code{function} type specifier.
-
-Although the \code{values} declaration is non-standard, it is relatively harmless
-to use it in otherwise portable code, since any warning in non-CMU
-implementations can be suppressed with the standard \code{declaration}
-proclamation.
-
-\node Structure Types, The Freeze-Type Declaration, The Values Declaration, More About Types in Python
-\subsection{Structure Types}
-\label{structure-types}
-\cindex{structure types}
-\cindex{defstruct types}
-\cpsubindex{types}{structure}
-
-Because of precise type checking, structure types are much better supported by
-Python than by conventional compilers:
-\begin{itemize}
-
-\item
-The structure argument to structure accessors is precisely checked \dash{} if you
-call \code{foo-a} on a \code{bar}, an error will be signalled.
-
-\item
-The types of slot values are precisely checked \dash{} if you pass the wrong type
-argument to a constructor or a slot setter, then an error will be signalled.
-\end{itemize}
-This error checking is tremendously useful for detecting bugs in programs that
-manipulate complex data structures.
-
-An additional advantage of checking structure types and enforcing slot types
-is that the compiler can safely believe slot type declarations.  \python{}
-effectively moves the type checking from the slot access to the slot setter or
-constructor call.  This is more efficient since caller of the setter or
-constructor often knows the type of the value, entirely eliminating the need to
-check the value's type.  Consider this example:
-\begin{lisp}
-(defstruct coordinate
-  (x nil :type single-float)
-  (y nil :type single-float))
-
-(defun make-it ()
-  (make-coordinate :x 1.0 :y 1.0))
-
-(defun use-it (it)
-  (declare (type coordinate it))
-  (sqrt (expt (coordinate-x it) 2) (expt (coordinate-y it) 2)))
-\end{lisp}
-\code{make-it} and \code{use-it} are compiled with no checking on the types of the
-float slots, yet \code{use-it} can use \code{single-float} arithmetic with perfect
-safety.  Note that \code{make-coordinate} must still check the values of \code{x} and
-\code{y} unless the call is block compiled or inline expanded (\pxlref{local-call}.)  But even without this advantage, it is almost always more
-efficient to check slot values on structure initialization, since slots are
-usually written once and read many times.
-
-\node The Freeze-Type Declaration, Type Restrictions, Structure Types, More About Types in Python
-\subsection{The Freeze-Type Declaration}
-\cindex{freeze-type declaration}
-\label{freeze-type}
-
-The \code{extensions:freeze-type} declaration is a CMU extension that enables more
-efficient compilation of user-defined types by asserting that the definition is
-not going to change.  This declaration may only be used globally (with
-\code{declaim} or \code{proclaim}).  Currently \code{freeze-type} only affects structure
-type testing done by \code{typep}, \code{typecase}, etc.  Here is an example:
-\begin{lisp}
-(declaim (freeze-type foo bar))
-\end{lisp}
-This asserts that the types \code{foo} and \code{bar} and their subtypes are not
-going to change.  This allows more efficient type testing, since the compiler
-can open-code a test for all possible subtypes, rather than having to examine
-the type hierarchy at run-time.
-
-\node Type Restrictions, Type Style Recommendations, The Freeze-Type Declaration, More About Types in Python
-\subsection{Type Restrictions}
-\cpsubindex{types}{restrictions on}
-
-Avoid use of the \code{and}, \code{not} and \code{satisfies} types in declarations,
-since type inference has problems with them.  When these types do appear in a
-declaration, they are still checked precisely, but the type information is of
-limited use to the compiler.  \code{and} types are effective as long as the
-intersection can be canonicalized to a type that doesn't use \code{and}.  For
-example:
-\begin{example}
-(and fixnum unsigned-byte)
-\end{example}
-is fine, since it is the same as:
-\begin{example}
-(integer 0 \var{most-positive-fixnum})
-\end{example}
-but this type:
-\begin{example}
-(and symbol (not (member :end)))
-\end{example}
-will not be fully understood by type interference since the \code{and} can't be
-removed by canonicalization.
-
-Using any of these type specifiers in a type test with \code{typep} or
-\code{typecase} is fine, since as tests, these types can be translated into the
-\code{and} macro, the \code{not} function or a call to the satisfies predicate.
-
-\node Type Style Recommendations,  , Type Restrictions, More About Types in Python
-\subsection{Type Style Recommendations}
-\cindex{style recommendations}
-
-Python provides good support for some currently unconventional ways of using
-the \clisp{} type system.  With \python, it is desirable to make declarations as
-precise as possible, but type inference also makes some declarations
-unnecessary.  Here are some general guidelines for maximum robustness and
-efficiency:
-\begin{itemize}
-
-\item
-Declare the types of all function arguments and structure slots as precisely as
-possible (while avoiding \code{not}, \code{and} and \code{satisfies}).  Put these
-declarations in during initial coding so that type assertions can find bugs for
-you during debugging.
-
-\item
-Use the \tindexed{member} type specifier where there are a small number of possible
-symbol values, for example: \w{\code{(member :red :blue :green)}}.
-
-\item
-Use the \tindexed{or} type specifier in situations where the type is
-not certain, but there are only a few possibilities, for example:
-\w{\code{(or list vector)}}.
-
-\item
-Declare integer types with the tightest bounds that you can, such as 
-\code{\w{(integer 3 7)}}.
-
-\item
-Define \findexed{deftype} or \findexed{defstruct} types before they
-are used.  Definition after use is legal (producing no "undefined
-type" warnings), but type tests and structure operations will be
-compiled much less efficiently.
-
-\item
-In addition to declaring the array element type and simpleness, also declare
-the dimensions if they are fixed, for example:
-\begin{example}
-(simple-array single-float (1024 1024))
-\end{example}
-This bounds information allows array indexing for multi-dimensional arrays to
-be compiled much more efficiently, and may also allow array bounds checking to
-be done at compile time.  \xlref{array-types}.
-
-\item
-Avoid use of the \findexed{the} declaration within expressions.  Not
-only does it clutter the code, but it is also almost worthless under
-safe policies.  If the need for an output type assertion is revealed
-by efficiency notes during tuning, then you can consider \code{the}, but
-it is preferable to constrain the argument types more, allowing the
-compiler to prove the desired result type.
-
-\item
-Don't bother declaring the type of \findexed{let} or other
-non-argument variables unless the type is non-obvious.  If you
-declare function return types and structure slot types, then the type
-of a variable is often obvious both to the programmer and to the
-compiler.  An important case where the type isn't obvious, and a
-declaration is appropriate, is when the value for a variable is
-pulled out of untyped structure (e.g., the result of \code{car}), or
-comes from some weakly typed function, such as \code{read}.
-
-\item
-Declarations are sometimes necessary for integer loop variables, since the
-compiler can't always prove that the value is of a good integer type.  These
-declarations are best added during tuning, when an efficiency note indicates
-the need.
-\end{itemize}
-
-
-
-\node Type Inference, Source Optimization, More About Types in Python, Advanced Compiler Use and Efficiency Hints
-\section{Type Inference}
-\label{type-inference}
-\cindex{type inference}
-\cindex{inference of types}
-\cindex{derivation of types}
-
-Type inference is the process by which the compiler tries to figure out the
-types of expressions and variables, given an inevitable lack of complete type
-information.  Although \python{} does much more type inference than most \llisp{}
-compilers, remember that the more precise and comprehensive type declarations
-are, the more type inference will be able to do.
-
-\begin{menu}
-* Variable Type Inference::     
-* Local Function Type Inference::  
-* Global Function Type Inference::  
-* Operation Specific Type Inference::  
-* Dynamic Type Inference::      
-* Type Check Optimization::     
-\end{menu}
-
-\node Variable Type Inference, Local Function Type Inference, Type Inference, Type Inference
-\subsection{Variable Type Inference}
-\label{variable-type-inference}
-
-The type of a variable is the union of the types of all the
-definitions.  In the degenerate case of a let, the type of the
-variable is the type of the initial value.  This inferred type is
-intersected with any declared type, and is then propagated to all the
-variable's references.  The types of \findexed{multiple-value-bind}
-variables are similarly inferred from the types of the individual
-values of the values form.
-
-If multiple type declarations apply to a single variable, then all the
-declarations must be correct; it is as though all the types were intersected
-producing a single \tindexed{and} type specifier.  In this example:
-\begin{example}
-(defmacro my-dotimes ((var count) &body body)
-  `(do ((,var 0 (1+ ,var)))
-       ((>= ,var ,count))
-     (declare (type (integer 0 *) ,var))
-     ,@body))
-
-(my-dotimes (i ...)
-  (declare (fixnum i))
-  ...)
-\end{example}
-the two declarations for \code{i} are intersected, so \code{i} is known to be a
-non-negative fixnum.
-
-In practice, this type inference is limited to lets and local functions, since
-the compiler can't analyze all the calls to a global function.  But type
-inference works well enough on local variables so that it is often unnecessary
-to declare the type of local variables.  This is especially likely when
-function result types and structure slot types are declared.  The main areas
-where type inference breaks down are:
-\begin{itemize}
-
-\item
-When the initial value of a variable is a untyped expression, such as
-\code{\w{(car x)}}, and
-
-\item
-When the type of one of the variable's definitions is a function of the
-variable's current value, as in: \code{(setq x (1+ x))}
-\end{itemize}
-
-
-\node Local Function Type Inference, Global Function Type Inference, Variable Type Inference, Type Inference
-\subsection{Local Function Type Inference}
-\cpsubindex{local call}{type inference}
-
-The types of arguments to local functions are inferred in the same was as any
-other local variable; the type is the union of the argument types across
-all the calls to the function, intersected with the declared type.  If there
-are any assignments to the argument variables, the type of the assigned value
-is unioned in as well.
-
-The result type of a local function is computed in a special way that takes
-tail recursion (\pxlref{tail-recursion}) into consideration.  The
-result type is the union of all possible return values that aren't
-tail-recursive calls.  For example, \python{} will infer that the result type of
-this function is \code{integer}:
-\begin{lisp}
-(defun ! (n res)
-  (declare (integer n res))
-  (if (zerop n)
-      res
-      (! (1- n) (* n res))))
-\end{lisp}
-Although this is a rather obvious result, it becomes somewhat less trivial in
-the presence of mutual tail recursion of multiple functions.  Local function
-result type inference interacts with the mechanisms for ensuring proper tail
-recursion mentioned in section \ref{local-call-return}.
-
-\node Global Function Type Inference, Operation Specific Type Inference, Local Function Type Inference, Type Inference
-\subsection{Global Function Type Inference}
-\label{function-type-inference}
-\cpsubindex{function}{type inference}
-
-As described in section \ref{function-types}, a global function type
-(\tindexed{ftype}) declaration places implicit type assertions on the call arguments,
-and also guarantees the type of the return value.  So wherever a call to a
-declared function appears, there is no doubt as to the types of the arguments
-and return value.  Furthermore, \python{} will infer a function type from the
-function's definition if there is no \code{ftype} declaration.  Any type
-declarations on the argument variables are used as the argument types in the
-derived function type, and the compiler's best guess for the result type of the
-function is used as the result type in the derived function type.
-
-This method of deriving function types from the definition implicitly assumes
-that functions won't be redefined at run-time.  Consider this example:
-\begin{lisp}
-(defun foo-p (x)
-  (let ((res (and (consp x) (eq (car x) 'foo))))
-    (format t "It is ~:[not ~;~]foo." res)))
-
-(defun frob (it)
-  (if (foo-p it)
-      (setf (cadr it) 'yow!)
-      (1+ it)))
-\end{lisp}
-
-Presumably, the programmer really meant to return \code{res} from \code{foo-p}, but
-he seems to have forgotten.  When he tries to call do 
-\code{\w{(frob (list 'foo nil))}}, \code{frob} will flame out when it tries to add to
-a \code{cons}.  Realizing his error, he fixes \code{foo-p} and recompiles it.  But
-when he retries his test case, he is baffled because the error is still there.
-What happened in this example is that \python{} proved that the result of
-\code{foo-p} is \code{null}, and then proceeded to optimize away the \code{setf} in
-\code{frob}.
-
-Fortunately, in this example, the error is detected at compile time due to
-notes about unreachable code (\pxlref{dead-code-notes}.)  Still, some
-users may not want to worry about this sort of problem during incremental
-development, so there is a variable to control deriving function types.
-
-\defvar{derive-function-types}[extensions]
-If true (the default), argument and result type information derived from
-compilation of \code{defun}s is used when compiling calls to that function.  If
-false, only information from \code{ftype} proclamations will be used.
-\enddefvar
-
-\node Operation Specific Type Inference, Dynamic Type Inference, Global Function Type Inference, Type Inference
-\subsection{Operation Specific Type Inference}
-\label{operation-type-inference}
-\cindex{operation specific type inference}
-\cindex{arithmetic type inference}
-\cpsubindex{numeric}{type inference}
-
-Many of the standard \clisp{} functions have special type inference procedures
-that determine the result type as a function of the argument types.  For
-example, the result type of \code{aref} is the array element type.  Here are some
-other examples of type inferences:
-\begin{lisp}
-(logand x #xFF) \result{} (unsigned-byte 8)
-
-(+ (the (integer 0 12) x) (the (integer 0 1) y)) \result{} (integer 0 13)
-
-(ash (the (unsigned-byte 16) x) -8) \result{} (unsigned-byte 8)
-\end{lisp}
-
-\node Dynamic Type Inference, Type Check Optimization, Operation Specific Type Inference, Type Inference
-\subsection{Dynamic Type Inference}
-\label{constraint-propagation}
-\cindex{dynamic type inference}
-\cindex{conditional type inference}
-\cpsubindex{type inference}{dynamic}
-
-Python uses flow analysis to infer types in dynamically typed programs.  For
-example:
-\begin{example}
-(ecase x
-  (list (length x))
-  ...)
-\end{example}
-Here, the compiler knows the argument to \code{length} is a list,
-because the call to \code{length} is only done when \code{x} is a list.
-The most significant efficiency effect of inference from assertions is
-usually in type check optimization.
-
-
-Dynamic type inference has two inputs: explicit conditionals and
-implicit or explicit type assertions.  Flow analysis propagates these
-constraints on variable type to any code that can be executed only
-after passing though the constraint.  Explicit type constraints come
-from \findexed{if}s where the test is either a lexical variable or a
-function of lexical variables and constants, where the function is
-either a type predicate, a numeric comparison or \code{eq}.
-
-If there is an \code{eq} (or \code{eql}) test, then the compiler will actually
-substitute one argument for the other in the true branch.  For example:
-\begin{lisp}
-(when (eq x :yow!) (return x))
-\end{lisp}
-becomes:
-\begin{lisp}
-(when (eq x :yow!) (return :yow!))
-\end{lisp}
-This substitution is done when one argument is a constant, or one argument has
-better type information than the other.  This transformation reveals
-opportunities for constant folding or type-specific optimizations.  If the test
-is against a constant, then the compiler can prove that the variable is not
-that constant value in the false branch, or \w{\code{(not (member :yow!))}}
-in the example above.  This can eliminate redundant tests, for example:
-\begin{example}
-(if (eq x nil)
-    ...
-    (if x a b))
-\end{example}
-is transformed to this:
-\begin{example}
-(if (eq x nil)
-    ...
-    a)
-\end{example}
-Variables appearing as \code{if} tests are interpreted as 
-\code{\w{(not (eq \var{var} nil))}} tests.  The compiler also converts \code{=} into
-\code{eql} where possible.  It is difficult to do inference directly on \code{=}
-since it does implicit coercions.
-
-When there is an explicit \code{<} or \code{>} test on integer variables, the
-compiler makes inferences about the ranges the variables can assume in the true
-and false branches.  This is mainly useful when it proves that the values are
-small enough in magnitude to allow open-coding of arithmetic operations.  For
-example, in many uses of \code{dotimes} with a \code{fixnum} repeat count, the
-compiler proves that fixnum arithmetic can be used.
-
-Implicit type assertions are quite common, especially if you declare function
-argument types.  Dynamic inference from implicit type assertions sometimes
-helps to disambiguate programs to a useful degree, but is most noticeable when
-it detects a dynamic type error.  For example:
-\begin{lisp}
-(defun foo (x)
-  (+ (car x) x))
-\end{lisp} 
-results in this warning:
-\begin{example}
-In: DEFUN FOO
-  (+ (CAR X) X)
-==>
-  X
-Warning: Result is a LIST, not a NUMBER.
-\end{example}
-
-Note that \llisp{}'s dynamic type checking semantics make dynamic type
-inference useful even in programs that aren't really dynamically typed, for
-example:
-\begin{lisp}
-(+ (car x) (length x))
-\end{lisp}
-Here, \code{x} presumably always holds a list, but in the absence of a declaration
-the compiler cannot assume \code{x} is a list simply because list-specific
-operations are sometimes done on it.  The compiler must consider the program to
-be dynamically typed until it proves otherwise.  Dynamic type inference proves
-that the argument to \code{length} is always a list because the call to \code{length}
-is only done after the list-specific \code{car} operation.
-
-
-\node Type Check Optimization,  , Dynamic Type Inference, Type Inference
-\subsection{Type Check Optimization}
-\label{type-check-optimization}
-\cpsubindex{type checking}{optimization}
-\cpsubindex{optimization}{type check}
-
-Python backs up its support for precise type checking by minimizing the cost of
-run-time type checking.  This is done both through type inference and though
-optimizations of type checking itself.
-
-Type inference often allows the compiler to prove that a value is of the
-correct type, and thus no type check is necessary.  For example:
-\begin{lisp}
-(defstruct foo a b c)
-(defstruct link
-  (foo (required-argument) :type foo)
-  (next nil :type (or link null)))
-
-(foo-a (link-foo x))
-\end{lisp}
-Here, there is no need to check that the result of \code{link-foo} is a \code{foo},
-since it always is.  Even when some type checks are necessary, type inference
-can often reduce the number:
-\begin{example}
-(defun test (x)
-  (let ((a (foo-a x))
-        (b (foo-b x))
-        (c (foo-c x)))
-    ...))
-\end{example}
-In this example, only one \w{\code{(foo-p x)}} check is needed.  This applies to a
-lesser degree in list operations, such as:
-\begin{lisp}
-(if (eql (car x) 3) (cdr x) y)
-\end{lisp}
-Here, we only have to check that \code{x} is a list once.
-
-Since \python{} recognizes explicit type tests, code that explicitly protects
-itself against type errors has little introduced overhead due to implicit type
-checking.  For example, this loop compiles with no implicit checks checks for
-\code{car} and \code{cdr}:
-\begin{lisp}
-(defun memq (e l)
-  (do ((current l (cdr current)))
-      ((atom current) nil)
-    (when (eq (car current) e) (return current))))
-\end{lisp}
-
-\cindex{complemented type checks}
-Python reduces the cost of checks that must be done through an optimization
-called \var{complementing}.  A complemented check for \var{type} is simply a check
-that the value is not of the type \w{\code{(not \var{type})}}.  This is only
-interesting when something is known about the actual type, in which case we can
-test for the complement of \w{\code{(and \var{known-type} (not \var{type}))}}, or the
-difference between the known type and the assertion.  An example:
-\begin{lisp}
-(link-foo (link-next x))
-\end{lisp}
-Here, we change the type check for \code{link-foo} from a test for \code{foo} to a
-test for:
-\begin{lisp}
-(not (and (or foo null) (not foo)))
-\end{lisp}
-or more simply \w{\code{(not null)}}.  This is probably the most important use of
-complementing, since the situation is fairly common, and a \code{null} test is
-much cheaper than a structure type test.
-
-Here is a more complicated example that illustrates the combination of
-complementing with dynamic type inference:
-\begin{lisp}
-(defun find-a (a x)
-  (declare (type (or link null) x))
-  (do ((current x (link-next current)))
-      ((null current) nil)
-    (let ((foo (link-foo current)))
-      (when (eq (foo-a foo) a) (return foo)))))
-\end{lisp}
-This loop can be compiled with no type checks.  The \code{link} test for
-\code{link-foo} and \code{link-next} is complemented to \w{\code{(not null)}}, and then
-deleted because of the explicit \code{null} test.  As before, no check is
-necessary for \code{foo-a}, since the \code{link-foo} is always a \code{foo}.  This sort
-of situation shows how precise type checking combined with precise declarations
-can actually result in reduced type checking.
-
-
-\node Source Optimization, Tail Recursion, Type Inference, Advanced Compiler Use and Efficiency Hints
-\section{Source Optimization}
-\label{source-optimization}
-\cindex{optimization}
-
-This section describes source-level transformations that \python{} does on
-programs in an attempt to make them more efficient.  Although source-level
-optimizations can make existing programs more efficient, the biggest advantage
-of this sort of optimization is that it makes it easier to write efficient
-programs.  If a clean, straightforward implementation is can be transformed
-into an efficient one, then there is no need for tricky and dangerous hand
-optimization. 
-
-\begin{menu}
-* Let Optimization::            
-* Constant Folding::            
-* Unused Expression Elimination::  
-* Control Optimization::        
-* Unreachable Code Deletion::   
-* Multiple Values Optimization::  
-* Source to Source Transformation::  
-* Style Recommendations::       
-\end{menu}
-
-\node Let Optimization, Constant Folding, Source Optimization, Source Optimization
-\subsection{Let Optimization}
-\label{let-optimization}
-
-\cindex{let optimization} \cpsubindex{optimization}{let}
-The primary optimization of let variables is to delete them when they are
-unnecessary.  Whenever the value of a let variable is a constant, a constant
-variable or a constant (local or non-notinline) function, the variable is
-deleted, and references to the variable are replaced with references to the
-constant expression.  This is useful primarily in the expansion of macros or
-inline functions, where argument values are often constant in any given call,
-but are in general non-constant expressions that must be bound to preserve
-order of evaluation.  Let variable optimization eliminates the need for macros
-to carefully avoid spurious bindings, and also makes inline functions just as
-efficient as macros.
-
-A particularly interesting class of constant is a local function.  Substituting
-for lexical variables that are bound to a function can substantially improve
-the efficiency of functional programming styles, for example:
-\begin{lisp}
-(let ((a #'(lambda (x) (zow x))))
-  (funcall a 3))
-\end{lisp}
-effectively transforms to:
-\begin{lisp}
-(zow 3)
-\end{lisp}
-This transformation is done even when the function is a closure, as in:
-\begin{lisp}
-(let ((a (let ((y (zug)))
-           #'(lambda (x) (zow x y)))))
-  (funcall a 3))
-\end{lisp}
-becoming:
-\begin{lisp}
-(zow 3 (zug))
-\end{lisp}
-
-A constant variable is a lexical variable that is never assigned to, always
-keeping its initial value.  Whenever possible, avoid setting lexical variables
-\dash{} instead bind a new variable to the new value.  Except for loop variables,
-it is almost always possible to avoid setting lexical variables.  This form:
-\begin{example}
-(let ((x (f x)))
-  ...)
-\end{example}
-is \var{more} efficient than this form:
-\begin{example}
-(setq x (f x))
-...
-\end{example}
-Setting variables makes the program more difficult to understand, both to the
-compiler and to the programmer.  \python{} compiles assignments at least as
-efficiently as any other \llisp{} compiler, but most let optimizations are only
-done on constant variables.
-
-Constant variables with only a single use are also optimized away, even when
-the initial value is not constant.\footnote{The source transformation in this
-example doesn't represent the preservation of evaluation order implicit in the
-compiler's internal representation.  Where necessary, the back end will
-reintroduce temporaries to preserve the semantics.}  For example, this
-expansion of \code{incf}:
-\begin{lisp}
-(let ((#:g3 (+ x 1)))
-  (setq x #:G3))
-\end{lisp}
-becomes:
-\begin{lisp}
-(setq x (+ x 1))
-\end{lisp}
-The type semantics of this transformation are more important than the
-elimination of the variable itself.  Consider what happens when \code{x} is
-declared to be a \code{fixnum}; after the transformation, the compiler can compile
-the addition knowing that the result is a \code{fixnum}, whereas before the
-transformation the addition would have to allow for fixnum overflow.
-
-Another variable optimization deletes any variable that is never read.  This
-causes the initial value and any assigned values to be unused, allowing those
-expressions to be deleted if they have no side-effects.
-
-Note that a let is actually a degenerate case of local call (\pxlref{let-calls}), and that let optimization can be done on calls that weren't
-created by a let.  Also, local call allows an applicative style of iteration
-that is totally assignment free.
-
-\node Constant Folding, Unused Expression Elimination, Let Optimization, Source Optimization
-\subsection{Constant Folding}
-\cindex{constant folding}
-\cpsubindex{folding}{constant}
-
-Constant folding is an optimization that replaces a call of constant arguments
-with the constant result of that call.  Constant folding is done on all
-standard functions for which it is legal.  Inline expansion allows folding of
-any constant parts of the definition, and can be done even on functions that
-have side-effects.
-
-It is convenient to rely on constant folding when programming, as in this
-example:
-\begin{example}
-(defconstant limit 42)
-
-(defun foo ()
-  (... (1- limit) ...))
-\end{example}
-Constant folding is also helpful when writing macros or inline functions, since
-it usually eliminates the need to write a macro that special-cases constant
-arguments.
-
-\cindex{constant-function declaration}
-Constant folding of a user defined function is enabled by the
-\code{extensions:constant-function} proclamation.   In this example:
-\begin{example}
-(declaim (ext:constant-function myfun))
-(defun myexp (x y)
-  (declare (single-float x y))
-  (exp (* (log x) y)))
-
- ... (myexp 3.0 1.3) ...
-\end{example}
-The call to \code{myexp} is constant-folded to \code{4.1711674}.
-
-
-\node Unused Expression Elimination, Control Optimization, Constant Folding, Source Optimization
-\subsection{Unused Expression Elimination}
-\cindex{unused expression elimination}
-\cindex{dead code elimination}
-
-If the value of any expression is not used, and the expression has no
-side-effects, then it is deleted.  As with constant folding, this optimization
-applies most often when cleaning up after inline expansion and other
-optimizations.  Any function declared an \code{extensions:constant-function} is
-also subject to unused expression elimination.
-
-Note that \python{} will eliminate parts of unused expressions known to be
-side-effect free, even if there are other unknown parts.  For example:
-\begin{lisp}
-(let ((a (list (foo) (bar))))
-  (if t
-      (zow)
-      (raz a)))
-\end{lisp}
-becomes:
-\begin{lisp}
-(progn (foo) (bar))
-(zow)
-\end{lisp}
-
-
-\node Control Optimization, Unreachable Code Deletion, Unused Expression Elimination, Source Optimization
-\subsection{Control Optimization}
-\cindex{control optimization}
-\cpsubindex{optimization}{control}
-
-The most important optimization of control is recognizing when an
-\findexed{if} test is known at compile time, then deleting the
-\code{if}, the test expression, and the unreachable branch of the
-\code{if}.  This can be considered a special case of constant folding,
-although the test doesn't have to be truly constant as long as it is
-definitely not \false.  Note also, that type inference propagates the
-result of an \code{if} test to the true and false branches,
-\pxlref{constraint-propagation}.
-
-A related \code{if} optimization is this transformation:\footnote{Note that the code
-for \code{x} and \code{y} isn't actually replicated.}
-\begin{lisp}
-(if (if a b c) x y)
-\end{lisp}
-into:
-\begin{lisp}
-(if a
-    (if b x y)
-    (if c x y))
-\end{lisp}
-The opportunity for this sort of optimization usually results from a
-conditional macro.  For example:
-\begin{lisp}
-(if (not a) x y)
-\end{lisp}
-is actually implemented as this:
-\begin{lisp}
-(if (if a nil t) x y)
-\end{lisp}
-which is transformed to this:
-\begin{lisp}
-(if a
-    (if nil x y)
-    (if t x y))
-\end{lisp}
-which is then optimized to this:
-\begin{lisp}
-(if a y x)
-\end{lisp}
-Note that due to \python{}'s internal representations, the \code{if}\dash{}\code{if}
-situation will be recognized even if other forms are wrapped around the inner
-\code{if}, like:
-\begin{example}
-(if (let ((g ...))
-      (loop
-        ...
-        (return (not g))
-        ...))
-    x y)
-\end{example}
-
-In \python, all the \clisp{} macros really are macros, written in terms of
-\code{if}, \code{block} and \code{tagbody}, so user-defined control macros can be just
-as efficient as the standard ones.  \python{} emits basic blocks using a heuristic
-that minimizes the number of unconditional branches.  The code in a \code{tagbody}
-will not be emitted in the order it appeared in the source, so there is no
-point in arranging the code to make control drop through to the target.
-
-\node Unreachable Code Deletion, Multiple Values Optimization, Control Optimization, Source Optimization
-\subsection{Unreachable Code Deletion}
-\label{dead-code-notes}
-\cindex{unreachable code deletion}
-\cindex{dead code elimination}
-
-Python will delete code whenever it can prove that the code can never be
-executed.  Code becomes unreachable when:
-\begin{itemize}
-
-\item
-An \code{if} is optimized away, or
-
-\item
-There is an explicit unconditional control transfer such as \code{go} or
-\code{return-from}, or
-
-\item
-The last reference to a local function is deleted (or there never was any
-reference.)
-\end{itemize}
-
-
-When code that appeared in the original source is deleted, the compiler prints
-a note to indicate a possible problem (or at least unnecessary code.)  For
-example:
-\begin{lisp}
-(defun foo ()
-  (if t
-      (write-line "True.")
-      (write-line "False.")))
-\end{lisp}
-will result in this note:
-\begin{example}
-In: DEFUN FOO
-  (WRITE-LINE "False.")
-Note: Deleting unreachable code.
-\end{example}
-
-It is important to pay attention to unreachable code notes, since they often
-indicate a subtle type error.  For example:
-\begin{example}
-(defstruct foo a b)
-
-(defun lose (x)
-  (let ((a (foo-a x))
-        (b (if x (foo-b x) :none)))
-    ...))
-\end{example}
-results in this note:
-\begin{example}
-In: DEFUN LOSE
-  (IF X (FOO-B X) :NONE)
-==>
-  :NONE
-Note: Deleting unreachable code.
-\end{example}
-The \kwd{none} is unreachable, because type inference knows that the argument
-to \code{foo-a} must be a \code{foo}, and thus can't be \false.  Presumably the
-programmer forgot that \code{x} could be \false{} when he wrote the binding for
-\code{a}.
-
-Here is an example with an incorrect declaration:
-\begin{lisp}
-(defun count-a (string)
-  (do ((pos 0 (position #\back a string :start (1+ pos)))
-       (count 0 (1+ count)))
-      ((null pos) count)
-    (declare (fixnum pos))))
-\end{lisp}
-This time our note is:
-\begin{example}
-In: DEFUN COUNT-A
-  (DO ((POS 0 #) (COUNT 0 #))
-      ((NULL POS) COUNT)
-    (DECLARE (FIXNUM POS)))
---> BLOCK LET TAGBODY RETURN-FROM PROGN 
-==>
-  COUNT
-Note: Deleting unreachable code.
-\end{example}
-The problem here is that \code{pos} can never be null since it is declared a
-\code{fixnum}.
-
-It takes some experience with unreachable code notes to be able to tell what
-they are trying to say.  In non-obvious cases, the best thing to do is to call
-the function in a way that should cause the unreachable code to be executed.
-Either you will get a type error, or you will find that there truly is no way
-for the code to be executed.
-
-Not all unreachable code results in a note:
-\begin{itemize}
-
-\item
-A note is only given when the unreachable code textually appears in the
-original source.  This prevents spurious notes due to the optimization of
-macros and inline functions, but sometimes also foregoes a note that would have
-been useful.
-
-\item
-Since accurate source information is not available for non-list forms, there is
-an element of heuristic in determining whether or not to give a note about an
-atom.  Spurious notes may be given when a macro or inline function defines a
-variable that is also present in the calling function.  Notes about \false{} and
-\true{} are never given, since it is too easy to confuse these constants in
-expanded code with ones in the original source.
-
-\item
-Notes are only given about code unreachable due to control flow.  There is no
-note when an expression is deleted because its value is unused, since this is a
-common consequence of other optimizations.
-\end{itemize}
-
-
-Somewhat spurious unreachable code notes can also result when a macro inserts
-multiple copies of its arguments in different contexts, for example:
-\begin{lisp}
-(defmacro t-and-f (var form)
-  `(if ,var ,form ,form))
-
-(defun foo (x)
-  (t-and-f x (if x "True." "False.")))
-\end{lisp}
-results in these notes:
-\begin{example}
-In: DEFUN FOO
-  (IF X "True." "False.")
-==>
-  "False."
-Note: Deleting unreachable code.
-
-==>
-  "True."
-Note: Deleting unreachable code.
-\end{example}
-It seems like it has deleted both branches of the \code{if}, but it has really
-deleted one branch in one copy, and the other branch in the other copy.  Note
-that these messages are only spurious in not satisfying the intent of the rule
-that notes are only given when the deleted code appears in the original source;
-there is always \var{some} code being deleted when a unreachable code note is
-printed.
-
-
-\node Multiple Values Optimization, Source to Source Transformation, Unreachable Code Deletion, Source Optimization
-\subsection{Multiple Values Optimization}
-\cindex{multiple value optimization}
-\cpsubindex{optimization}{multiple value}
-
-Within a function, \python{} implements uses of multiple values particularly
-efficiently.  Multiple values can be kept in arbitrary registers, so using
-multiple values doesn't imply stack manipulation and representation
-conversion.  For example, this code:
-\begin{example}
-(let ((a (if x (foo x) u))
-      (b (if x (bar x) v)))
-  ...)
-\end{example}
-is actually more efficient written this way:
-\begin{example}
-(multiple-value-bind
-    (a b)
-    (if x
-        (values (foo x) (bar x))
-        (values u v))
-  ...)
-\end{example}
-
-Also, \pxlref{local-call-return} for information on how local call
-provides efficient support for multiple function return values.
-
-
-\node Source to Source Transformation, Style Recommendations, Multiple Values Optimization, Source Optimization
-\subsection{Source to Source Transformation}
-\cindex{source-to-source transformation}
-\cpsubindex{transformation}{source-to-source}
-
-The compiler implements a number of operation-specific optimizations as
-source-to-source transformations.  You will often see unfamiliar code in error
-messages, for example:
-\begin{lisp}
-(defun my-zerop () (zerop x))
-\end{lisp}
-gives this warning:
-\begin{example}
-In: DEFUN MY-ZEROP
-  (ZEROP X)
-==>
-  (= X 0)
-Warning: Undefined variable: X
-\end{example}
-The original \code{zerop} has been transformed into a call to \code{=}.  This
-transformation is indicated with the same \code{==>} used to mark macro and
-function inline expansion.  Although it can be confusing, display of the
-transformed source is important, since warnings are given with respect to the
-transformed source.  This a more obscure example:
-\begin{lisp}
-(defun foo (x) (logand 1 x))
-\end{lisp}
-gives this efficiency note:
-\begin{example}
-In: DEFUN FOO
-  (LOGAND 1 X)
-==>
-  (LOGAND C::Y C::X)
-Note: Forced to do static-function Two-arg-and (cost 53).
-      Unable to do inline fixnum arithmetic (cost 1) because:
-      The first argument is a INTEGER, not a FIXNUM.
-      etc.
-\end{example}
-Here, the compiler commuted the call to \code{logand}, introducing temporaries.
-The note complains that the \var{first} argument is not a \code{fixnum}, when in the
-original call, it was the second argument.  To make things more confusing, the
-compiler introduced temporaries called \code{c::x} and \code{c::y} that are bound to
-\code{y} and \code{1}, respectively.
-
-You will also notice source-to-source optimizations when efficiency notes are
-enabled (\pxlref{efficiency-notes}.)  When the compiler is unable to
-do a transformation that might be possible if there was more information, then
-an efficiency note is printed.  For example, \code{my-zerop} above will also give
-this efficiency note:
-\begin{example}
-In: DEFUN FOO
-  (ZEROP X)
-==>
-  (= X 0)
-Note: Unable to optimize because:
-      Operands might not be the same type, so can't open code.
-\end{example}
-
-\node Style Recommendations,  , Source to Source Transformation, Source Optimization
-\subsection{Style Recommendations}
-\cindex{style recommendations}
-
-Source level optimization makes possible a clearer and more relaxed programming
-style:
-\begin{itemize}
-
-\item
-Don't use macros purely to avoid function call.  If you want an inline
-function, write it as a function and declare it inline.  It's clearer, less
-error-prone, and works just as well.
-
-\item
-Don't write macros that try to "optimize" their expansion in trivial ways such
-as avoiding binding variables for simple expressions.  The compiler does
-these optimizations too, and is less likely to make a mistake.
-
-\item
-Make use of local functions (i.e., \code{labels} or \code{flet}) and tail-recursion
-in places where it is clearer.  Local function call is faster than full call.
-
-\item
-Avoid setting local variables when possible.  Binding a new \code{let} variable is
-at least as efficient as setting an existing variable, and is easier to
-understand, both for the compiler and the programmer.
-
-\item
-Instead of writing similar code over and over again so that it can be hand
-customized for each use, define a macro or inline function, and let the
-compiler do the work.
-\end{itemize}
-
-
-
-\node Tail Recursion, Local Call, Source Optimization, Advanced Compiler Use and Efficiency Hints
-\section{Tail Recursion}
-\label{tail-recursion}
-\cindex{tail recursion}
-\cindex{recursion}
-
-A call is tail-recursive if nothing has to be done after the the call returns,
-i.e. when the call returns, the returned value is immediately returned from the
-calling function.  In this example, the recursive call to \code{myfun} is
-tail-recursive:
-\begin{lisp}
-(defun myfun (x)
-  (if (oddp (random x))
-      (isqrt x)
-      (myfun (1- x))))
-\end{lisp}
-
-Tail recursion is interesting because it is form of recursion that can be
-implemented much more efficiently than general recursion.  In general, a
-recursive call requires the compiler to allocate storage on the stack at
-run-time for every call that has not yet returned.  This memory consumption
-makes recursion unacceptably inefficient for representing repetitive algorithms
-having large or unbounded size.  Tail recursion is the special case of
-recursion that is semantically equivalent to the iteration constructs normally
-used to represent repetition in programs.  Because tail recursion is equivalent
-to iteration, tail-recursive programs can be compiled as efficiently as
-iterative programs.
-
-So why would you want to write a program recursively when you can write it
-using a loop?  Well, the main answer is that recursion is a more general
-mechanism, so it can express some solutions simply that are awkward to write as
-a loop.  Some programmers also feel that recursion is a stylistically
-preferable way to write loops because it avoids assigning variables.
-For example, instead of writing:
-\begin{lisp}
-(defun fun1 (x)
-  something-that-uses-x)
-
-(defun fun2 (y)
-  something-that-uses-y)
-
-(do ((x something (fun2 (fun1 x))))
-    (nil))
-\end{lisp}
-You can write:
-\begin{lisp}
-(defun fun1 (x)
-  (fun2 something-that-uses-x))
-
-(defun fun2 (y)
-  (fun1 something-that-uses-y))
-
-(fun1 something)
-\end{lisp}
-The tail-recursive definition is actually more efficient, in addition to being
-(arguably) clearer.  As the number of functions and the complexity of their
-call graph increases, the simplicity of using recursion becomes compelling.
-Consider the advantages of writing a large finite-state machine with separate
-tail-recursive functions instead of using a single huge \code{prog}.
-
-It helps to understand how to use tail recursion if you think of a
-tail-recursive call as a \code{psetq} that assigns the argument values to the
-called function's variables, followed by a \code{go} to the start of the called
-function.  This makes clear an inherent efficiency advantage of tail-recursive
-call: in addition to not having to allocate a stack frame, there is no need to
-prepare for the call to return (e.g., by computing a return PC.)
-
-Is there any disadvantage to tail recursion?  Other than an increase in
-efficiency, the only way you can tell that a call has been compiled
-tail-recursively is if you use the debugger.  Since a tail-recursive call has
-no stack frame, there is no way the debugger can print out the stack frame
-representing the call.  The effect is that backtrace will not show some calls
-that would have been displayed in a non-tail-recursive implementation.  In
-practice, this is not as bad as it sounds \dash{} in fact it isn't really clearly
-worse, just different.  \xlref{debug-tail-recursion} for information
-about the debugger implications of tail recursion.
-
-In order to ensure that tail-recursion is preserved in arbitrarily complex
-calling patterns across separately compiled functions, the compiler must
-compile any call in a tail-recursive position as a tail-recursive call.  This
-is done regardless of whether the program actually exhibits any sort of
-recursive calling pattern.  In this example, the call to \code{fun2} will always
-be compiled as a tail-recursive call:
-\begin{lisp}
-(defun fun1 (x)
-  (fun2 x))
-\end{lisp}
-So tail recursion doesn't necessarily have anything to do with recursion
-as it is normally thought of.  \xlref{local-tail-recursion} for more
-discussion of using tail recursion to implement loops.
-
-\begin{menu}
-* Tail Recursion Exceptions::   
-\end{menu}
-
-\node Tail Recursion Exceptions,  , Tail Recursion, Tail Recursion
-\subsection{Tail Recursion Exceptions}
-
-Although \python{} is claimed to be "properly" tail-recursive, some might dispute
-this, since there are situations where tail recursion is inhibited:
-\begin{itemize}
-
-\item
-When the call is enclosed by a special binding, or
-
-\item
-When the call is enclosed by a \code{catch} or \code{unwind-protect}, or
-
-\item
-When the call is enclosed by a \code{block} or \code{tagbody} and the block name or
-\code{go} tag has been closed over.
-\end{itemize}
-These dynamic extent binding forms inhibit tail recursion because they
-allocate stack space to represent the binding.  Shallow-binding
-implementations of dynamic scoping also require cleanup code to be
-evaluated when the scope is exited.
-
-
-\node Local Call, Block Compilation, Tail Recursion, Advanced Compiler Use and Efficiency Hints
-\section{Local Call}
-\label{local-call}
-\cindex{local call}
-\cpsubindex{call}{local}
-\cpsubindex{function call}{local}
-
-Python supports two kinds of function call: full call and local call.  Full
-call is the standard calling convention; its late binding and generality make
-\llisp{} what it is, but create unavoidable overheads.  When the compiler can
-compile the calling function and the called function simultaneously, it can use
-local call to avoid some of the overhead of full call.  Local call is really a
-collection of compilation strategies.  If some aspect of call overhead is not
-needed in a particular local call, then it can be omitted.  In some cases,
-local call can be totally free.  Local call provides two main advantages to the
-user:
-\begin{itemize}
-
-\item
-Local call makes the use of the lexical function binding forms
-\findexed{flet} and \findexed{labels} much more efficient.  A local
-call is always faster than a full call, and in many cases is much faster.
-
-\item
-Local call is a natural approach to \i{block compilation}, a compilation
-technique that resolves function references at compile time.  Block compilation
-speeds function call, but increases compilation times and prevents function
-redefinition.
-\end{itemize}
-
-
-\begin{menu}
-* Self-Recursive Calls::        
-* Let Calls::                   
-* Closures::                    
-* Local Tail Recursion::        
-* Return Values::               
-\end{menu}
-
-\node Self-Recursive Calls, Let Calls, Local Call, Local Call
-\subsection{Self-Recursive Calls}
-\cpsubindex{recursion}{self}
-
-Local call is used when a function defined by \code{defun} calls itself.  For
-example:
-\begin{lisp}
-(defun fact (n)
-  (if (zerop n)
-      1
-      (* n (fact (1- n)))))
-\end{lisp}
-This use of local call speeds recursion, but can also complicate debugging,
-since \findexed{trace} will only show the first call to \code{fact}, and not the
-recursive calls.  This is because the recursive calls directly jump to the
-start of the function, and don't indirect through the \code{symbol-function}.
-Self-recursive local call is inhibited when the \kwd{block-compile} argument to
-\code{compile-file} is \false{} (\pxlref{compile-file-block}.)
-
-\node Let Calls, Closures, Self-Recursive Calls, Local Call
-\subsection{Let Calls}
-\label{let-calls}
-Because local call avoids unnecessary call overheads, the compiler internally
-uses local call to implement some macros and special forms that are not
-normally thought of as involving a function call.  For example, this \code{let}:
-\begin{example}
-(let ((a (foo))
-      (b (bar)))
-  ...)
-\end{example}
-is internally represented as though it was macroexpanded into:
-\begin{example}
-(funcall #'(lambda (a b)
-             ...)
-         (foo)
-         (bar))
-\end{example}
-This implementation is acceptable because the simple cases of local call
-(equivalent to a \code{let}) result in good code.  This doesn't make \code{let} any
-more efficient, but does make local calls that are semantically the same as \code{let}
-much more efficient than full calls.  For example, these definitions are all
-the same as far as the compiler is concerned:
-\begin{example}
-(defun foo ()
-  ...some other stuff...
-  (let ((a something))
-    ...some stuff...))
-
-(defun foo ()
-  (flet ((localfun (a)
-           ...some stuff...))
-    ...some other stuff...
-    (localfun something)))
-
-(defun foo ()
-  (let ((funvar #'(lambda (a)
-                    ...some stuff...)))
-    ...some other stuff...
-    (funcall funvar something)))
-\end{example}
-
-Although local call is most efficient when the function is called only once, a
-call doesn't have to be equivalent to a \code{let} to be more efficient than full
-call.  All local calls avoid the overhead of argument count checking and
-keyword argument parsing, and there are a number of other advantages that apply
-in many common situations.  \xlref{let-optimization} for a
-discussion of the optimizations done on let calls.
-
-\node Closures, Local Tail Recursion, Let Calls, Local Call
-\subsection{Closures}
-\cindex{closures}
-
-Local call allows for much more efficient use of closures, since the closure
-environment doesn't need to be allocated on the heap, or even stored in memory
-at all.  In this example, there is no penalty for \code{localfun} referencing
-\code{a} and \code{b}:
-\begin{lisp}
-(defun foo (a b)
-  (flet ((localfun (x)
-           (1+ (* a b x))))
-    (if (= a b)
-        (localfun (- x))
-        (localfun x))))
-\end{lisp}
-In local call, the compiler effectively passes closed-over values as extra
-arguments, so there is no need for you to "optimize" local function use by
-explicitly passing in lexically visible values.  Closures may also be subject
-to let optimization (\pxlref{let-optimization}.)
-
-Note: indirect value cells are currently always allocated on the heap when a
-variable is both assigned to (with \code{setq} or \code{setf}) and closed over,
-regardless of whether the closure is a local function or not.  This is another
-reason to avoid setting variables when you don't have to.
-
-\node Local Tail Recursion, Return Values, Closures, Local Call
-\subsection{Local Tail Recursion}
-\label{local-tail-recursion}
-\cindex{tail recursion}
-\cpsubindex{recursion}{tail}
-
-Tail-recursive local calls are particularly efficient, since they are in effect
-an assignment plus a control transfer.  Scheme programmers write loops with
-tail-recursive local calls, instead of using the imperative \code{go} and
-\code{setq}.  This has not caught on in the \clisp{} community, since conventional
-\llisp{} compilers don't implement local call.  In \python, users can choose to
-write loops such as:
-\begin{lisp}
-(defun ! (n)
-  (labels ((loop (n total)
-             (if (zerop n)
-                 total
-                 (loop (1- n) (* n total)))))
-    (loop n 1)))
-\end{lisp}
-
-\defmac{iterate}[extensions]{\args
-        {\var{name} (\mstar{(\var{var} \var{initial-value})}) \mstar{\var{declaration}} \mstar{\var{form}}}}
-This macro provides syntactic sugar for using \findexed{labels} to do iteration.  It
-creates a local function \var{name} with the specified \var{var}s as its arguments
-and the \var{declaration}s and \var{form}s as its body.  This function is then
-called with the \var{initial-values}, and the result of the call is return from
-the macro.
-
-Here is our factorial example rewritten using \code{iterate}:
-\begin{lisp}
-(defun ! (n)
-  (iterate loop
-           ((n n)
-            (total 1))
-    (if (zerop n)
-        total
-        (loop (1- n) (* n total)))))
-\end{lisp}
-The main advantage of using \code{iterate} over \code{do} is that \code{iterate}
-naturally allows stepping to be done differently depending on conditionals in
-the body of the loop.  \code{iterate} can also be used to implement algorithms
-that aren't really iterative by simply doing a non-tail call.  For example,
-the standard recursive definition of factorial can be written like this:
-\begin{lisp}
-(iterate fact
-         ((n n))
-  (if (zerop n)
-      1
-      (* n (fact (1- n)))))
-\end{lisp}
-\enddefmac
-
-\node Return Values,  , Local Tail Recursion, Local Call
-\subsection{Return Values}
-\label{local-call-return}
-\cpsubindex{return values}{local call}
-\cpsubindex{local call}{return values}
-
-One of the more subtle costs of full call comes from allowing arbitrary numbers
-of return values.  This overhead can be avoided in local calls to functions
-that always return the same number of values.  For efficiency reasons (as well
-as stylistic ones), you should write functions so that they always return the
-same number of values.  This may require passing extra \false{} arguments to
-\code{values} in some cases, but the result is more efficient, not less so.
-
-When efficiency notes are enabled (\pxlref{efficiency-notes}), and the
-compiler wants to use known values return, but can't prove that the function
-always returns the same number of values, then it will print a note like this:
-\begin{example}
-In: DEFUN GRUE
-  (DEFUN GRUE (X) (DECLARE (FIXNUM X)) (COND (# #) (# NIL) (T #)))
-Note: Return type not fixed values, so can't use known return convention:
-  (VALUES (OR (INTEGER -536870912 -1) NULL) &REST T)
-\end{example}
-
-In order to implement proper tail recursion in the presence of known values
-return (\pxlref{tail-recursion}), the compiler sometimes must prove that
-multiple functions all return the same number of values.  When this can't be
-proven, the compiler will print a note like this:
-\begin{example}
-In: DEFUN BLUE
-  (DEFUN BLUE (X) (DECLARE (FIXNUM X)) (COND (# #) (# #) (# #) (T #)))
-Note: Return value count mismatch prevents known return from
-      these functions:
-  BLUE
-  SNOO
-\end{example}
-\xlref{number-local-call} for the interaction between local call
-and the representation of numeric types.
-
-
-\node Block Compilation, Inline Expansion, Local Call, Advanced Compiler Use and Efficiency Hints
-\section{Block Compilation}
-\label{block-compilation}
-\cindex{block compilation}
-\cpsubindex{compilation}{block}
-
-Block compilation allows calls to global functions defined by
-\findexed{defun} to be compiled as local calls.  The function call
-can be in a different top-level form than the \code{defun}, or even in a
-different file.
-
-In addition, block compilation allows the declaration of the \i{entry points}
-to the block compiled portion.  An entry point is any function that may be
-called from outside of the block compilation.  If a function is not an entry
-point, then it can be compiled more efficiently, since all calls are known at
-compile time.  In particular, if a function is only called in one place, then
-it will be let converted.  This effectively inline expands the function, but
-without the code duplication that results from defining the function normally
-and then declaring it inline.
-
-The main advantage of block compilation is that it it preserves efficiency in
-programs even when (for readability and syntactic convenience) they are broken
-up into many small functions.  There is absolutely no overhead for calling a
-non-entry point function that is defined purely for modularity (i.e. called
-only in one place.)
-
-Block compilation also allows the use of non-descriptor arguments and return
-values in non-trivial programs (\pxlref{number-local-call}).
-
-\begin{menu}
-* Block Compilation Semantics::  
-* Block Compilation Declarations::  
-* Compiler Arguments::          
-* Practical Difficulties::      
-\end{menu}
-
-\node Block Compilation Semantics, Block Compilation Declarations, Block Compilation, Block Compilation
-\subsection{Block Compilation Semantics}
-
-The effect of block compilation can be envisioned as the compiler turning all
-the \code{defun}s in the block compilation into a single \code{labels} form:
-\begin{example}
-(declaim (start-block fun1 fun3))
-
-(defun fun1 ()
-  ...)
-
-(defun fun2 ()
-  ...
-  (fun1)
-  ...)
-
-(defun fun3 (x)
-  (if x
-      (fun1)
-      (fun2)))
-
-(declaim (end-block))
-\end{example}
-becomes:
-\begin{example}
-(labels ((fun1 ()
-           ...)
-         (fun2 ()
-           ...
-           (fun1)
-           ...)
-         (fun3 (x)
-           (if x
-               (fun1)
-               (fun2))))
-  (setf (fdefinition 'fun1) #'fun1)
-  (setf (fdefinition 'fun3) #'fun3))
-\end{example}
-Calls between the block compiled functions are local calls, so changing the
-global definition of \code{fun1} will have no effect on what \code{fun2} does;
-\code{fun2} will keep calling the old \code{fun1}.
-
-The entry points \code{fun1} and \code{fun3} are still installed in the
-\code{symbol-function} as the global definitions of the functions, so a full call
-to an entry point works just as before.  However, \code{fun2} is not an entry
-point, so it is not globally defined.  In addition, \code{fun2} is only called in
-one place, so it will be let converted.
-
-
-\node Block Compilation Declarations, Compiler Arguments, Block Compilation Semantics, Block Compilation
-\subsection{Block Compilation Declarations}
-\cpsubindex{declarations}{block compilation}
-\cindex{start-block declaration}
-\cindex{end-block declaration}
-
-The \code{extensions:start-block} and \code{extensions:end-block} declarations allow
-fine-grained control of block compilation.  These declarations are only legal
-as a global declarations (\code{declaim} or \code{proclaim}).
-
-\noindent
-\vspace{1 em}
-The \code{start-block} declaration has this syntax:
-\begin{example}
-(start-block \mstar{\var{entry-point-name}})
-\end{example}
-When processed by the compiler, this declaration marks the start of
-block compilation, and specifies the entry points to that block.  If no
-entry points are specified, then \var{all} functions are made into entry
-points.  If already block compiling, then the compiler ends the current
-block and starts a new one.
-
-\noindent
-\vspace{1 em}
-The \code{end-block} declaration has no arguments:
-\begin{lisp}
-(end-block)
-\end{lisp}
-The \code{end-block} declaration ends a block compilation unit without
-starting a new one.  This is useful mainly when only a portion of a file
-is worth block compiling.
-
-\node Compiler Arguments, Practical Difficulties, Block Compilation Declarations, Block Compilation
-\subsection{Compiler Arguments}
-\label{compile-file-block}
-\cpsubindex{compile-file}{block compilation arguments}
-
-The \kwd{block-compile} and \kwd{entry-points} arguments to
-\code{extensions:compile-from-stream} and \funref{compile-file} provide overall
-control of block compilation, and allow block compilation without requiring
-modification of the program source.
-
-There are three possible values of the \kwd{block-compile} argument:
-\begin{description}
-
-\item[\false{}]
-Do no compile-time resolution of global function names, not even for
-self-recursive calls.  This inhibits any \code{start-block} declarations appearing
-in the file, allowing all functions to be incrementally redefined.
-
-\item[\true{}]
-Start compiling in block compilation mode.  This is mainly useful for block
-compiling small files that contain no \code{start-block} declarations.  See also
-the \kwd{entry-points} argument.
-
-\item[\kwd{specified}]
-Start compiling in form-at-a-time mode, but exploit \code{start-block}
-declarations and compile self-recursive calls as local calls.  Normally
-\kwd{specified} is the default for this argument (see
-\varref{block-compile-default}.)
-\end{description}
-
-The \kwd{entry-points} argument can be used in conjunction with
-\w{\kwd{block-compile} \true{}} to specify the entry-points to a block-compiled
-file.  If not specified or \nil, all global functions will be compiled as entry
-points.  When \kwd{block-compile} is not \true, this argument is ignored.
-
-\defvar{block-compile-default}
-This variable determines the default value for the \kwd{block-compile} argument
-to \code{compile-file} and \code{compile-from-stream}.  The initial value of this
-variable is \kwd{specified}, but \false{} is sometimes useful for totally
-inhibiting block compilation.
-\enddefvar
-
-\node Practical Difficulties,  , Compiler Arguments, Block Compilation
-\subsection{Practical Difficulties}
-
-The main problem with block compilation is that the compiler uses
-large amounts of memory when it is block compiling.  This places an
-upper limit on the amount of code that can be block compiled as a
-unit.  To make best use of block compilation, it is necessary to
-locate the parts of the program containing many internal calls, and
-then add the appropriate \code{start-block} declarations.  When writing
-new code, it is a good idea to put in block compilation declarations
-from the very beginning, since writing block declarations correctly
-requires accurate knowledge of the program's function call structure.
-If you want to initially develop code with full incremental
-redefinition, you can compile with \varref{block-compile-default} set to
-\false.
-
-Note if a \code{defun} appears in a non-null lexical environment, then
-calls to it cannot be block compiled.
-
-Unless files are very small, it is probably impractical to block compile
-multiple files as a unit by specifying a list of files to \code{compile-file}.
-Semi-inline expansion (\pxlref{semi-inline}) provides another way to
-extend block compilation across file boundaries.
-
-
-\node Inline Expansion, Object Representation, Block Compilation, Advanced Compiler Use and Efficiency Hints
-\section{Inline Expansion}
-\label{inline-expansion}
-\cindex{inline expansion}
-\cpsubindex{expansion}{inline}
-\cpsubindex{call}{inline}
-\cpsubindex{function call}{inline}
-\cpsubindex{optimization}{function call}
-
-Python can expand almost any function inline, including functions
-with keyword arguments.  The only restrictions are that keyword
-argument keywords in the call must be constant, and that global
-function definitions (\code{defun}) must be done in a null lexical
-environment (not nested in a \code{let} or other binding form.)  Local
-functions (\code{flet}) can be inline expanded in any environment.
-Combined with \python{}'s source-level optimization, inline expansion
-can be used for things that formerly required macros for efficient
-implementation.  In \python, macros don't have any efficiency
-advantage, so they need only be used where a macro's syntactic
-flexibility is required.
-
-Inline expansion is a compiler optimization technique that reduces
-the overhead of a function call by simply not doing the call:
-instead, the compiler effectively rewrites the program to appear as
-though the definition of the called function was inserted at each
-call site.  In \llisp, this is straightforwardly expressed by
-inserting the \code{lambda} corresponding to the original definition:
-\begin{lisp}
-(proclaim '(inline my-1+))
-(defun my-1+ (x) (+ x 1))
-
-(my-1+ someval) \result{} ((lambda (x) (+ x 1)) someval)
-\end{lisp}
-
-When the function expanded inline is large, the program after inline expansion
-may be substantially larger than the original program.  If the program becomes
-too large, inline expansion hurts speed rather than helping it, since hardware
-resources such as physical memory and cache will be exhausted.  Inline
-expansion is called for:
-\begin{itemize}
-
-\item
-When profiling has shown that a relatively simple function is called
-so often that a large amount of time is being wasted in the calling
-of that function (as opposed to running in that function.)  If a
-function is complex, it will take a long time to run relative the
-time spent in call, so the speed advantage of inline expansion is
-diminished at the same time the space cost of inline expansion is
-increased.  Of course, if a function is rarely called, then the
-overhead of calling it is also insignificant.
-
-\item
-With functions so simple that they take less space to inline expand than would
-be taken to call the function (such as \code{my-1+} above.)  It would require
-intimate knowledge of the compiler to be certain when inline expansion would
-reduce space, but it is generally safe to inline expand functions whose
-definition is a single function call, or a few calls to simple \clisp{}
-functions.
-\end{itemize}
-
-
-In addition to this speed/space tradeoff from inline expansion's avoidance of
-the call, inline expansion can also reveal opportunities for optimization.
-\python{}'s extensive source-level optimization can make use of context
-information from the caller to tremendously simplify the code resulting from
-the inline expansion of a function.
-
-The main form of caller context is local information about the actual argument
-values: what the argument types are and whether the arguments are constant.
-Knowledge about argument types can eliminate run-time type tests (e.g., for
-generic arithmetic.)  Constant arguments in a call provide opportunities for
-constant folding optimization after inline expansion.
-
-A hidden way that constant arguments are often supplied to functions is through
-the defaulting of unsupplied optional or keyword arguments.  There can be a
-huge efficiency advantage to inline expanding functions that have complex
-keyword-based interfaces, such as this definition of the \code{member} function:
-\begin{lisp}
-(proclaim '(inline member))
-(defun member (item list &key
-                    (key #'identity)
-                    (test #'eql testp)
-                    (test-not nil notp))
-  (do ((list list (cdr list)))
-      ((null list) nil)
-    (let ((car (car list)))
-      (if (cond (testp
-                 (funcall test item (funcall key car)))
-                (notp
-                 (not (funcall test-not item (funcall key car))))
-                (t
-                 (funcall test item (funcall key car))))
-          (return list)))))
-
-\end{lisp}
-After inline expansion, this call is simplified to the obvious code:
-\begin{lisp}
-(member a l :key #'foo-a :test #'char=) \result{}
-
-(do ((list list (cdr list)))
-    ((null list) nil)
-  (let ((car (car list)))
-    (if (char= item (foo-a car))
-        (return list))))
-\end{lisp}
-In this example, there could easily be more than an order of magnitude
-improvement in speed.  In addition to eliminating the original call to
-\code{member}, inline expansion also allows the calls to \code{char=} and \code{foo-a}
-to be open-coded.  We go from a loop with three tests and two calls to a loop
-with one test and no calls.
-
-\xlref{source-optimization} for more discussion of source level
-optimization.
-
-\begin{menu}
-* Inline Expansion Recording::  
-* Semi-Inline Expansion::       
-* The Maybe-Inline Declaration::  
-\end{menu}
-
-\node Inline Expansion Recording, Semi-Inline Expansion, Inline Expansion, Inline Expansion
-\subsection{Inline Expansion Recording}
-\cindex{recording of inline expansions}
-
-Inline expansion requires that the source for the inline expanded function to
-be available when calls to the function are compiled.  The compiler doesn't
-remember the inline expansion for every function, since that would take an
-excessive about of space.  Instead, the programmer must tell the compiler to
-record the inline expansion before the definition of the inline expanded
-function is compiled.  This is done by globally declaring the function inline
-before the function is defined, by using the \code{inline} and
-\code{extensions:maybe-inline} (\pxlref{maybe-inline-declaration})
-declarations.
-
-In addition to recording the inline expansion of inline functions at the time
-the function is compiled, \code{compile-file} also puts the inline expansion in
-the output file.  When the output file is loaded, the inline expansion is made
-available for subsequent compilations; there is no need to compile the
-definition again to record the inline expansion.
-
-If a function is declared inline, but no expansion is recorded, then the
-compiler will give an efficiency note like:
-\begin{example}
-Note: MYFUN is declared inline, but has no expansion.
-\end{example}
-When you get this note, check that the \code{inline} declaration and the
-definition appear before the calls that are to be inline expanded.  This note
-will also be given if the inline expansion for a \code{defun} could not be
-recorded because the \code{defun} was in a non-null lexical environment.
-
-\node Semi-Inline Expansion, The Maybe-Inline Declaration, Inline Expansion Recording, Inline Expansion
-\subsection{Semi-Inline Expansion}
-\label{semi-inline}
-
-Python supports \var{semi-inline} functions.  Semi-inline expansion shares a
-single copy of a function across all the calls in a component by converting the
-inline expansion into a local function (\pxlref{local-call}.)  This
-takes up less space when there are multiple calls, but also provides less
-opportunity for context dependent optimization.  When there is only one call,
-the result is identical to normal inline expansion.  Semi-inline expansion is
-done when the \code{space} optimization quality is \code{0}, and the function has
-been declared \code{extensions:maybe-inline}.
-
-This mechanism of inline expansion combined with local call also allows
-recursive functions to be inline expanded.  If a recursive function is declared
-\code{inline}, calls will actually be compiled semi-inline.  Although recursive
-functions are often so complex that there is little advantage to semi-inline
-expansion, it can still be useful in the same sort of cases where normal inline
-expansion is especially advantageous, i.e. functions where the calling context
-can help a lot.
-
-\node The Maybe-Inline Declaration,  , Semi-Inline Expansion, Inline Expansion
-\subsection{The Maybe-Inline Declaration}
-\label{maybe-inline-declaration}
-\cindex{maybe-inline declaration}
-
-The \code{extensions:maybe-inline} declaration is a \cmucl{} extension.  It is
-similar to \code{inline}, but indicates that inline expansion may sometimes be
-desirable, rather than saying that inline expansion should almost always be
-done.  When used in a global declaration, \code{extensions:maybe-inline} causes
-the expansion for the named functions to be recorded, but the functions aren't
-actually inline expanded unless \code{space} is \code{0} or the function is
-eventually (perhaps locally) declared \code{inline}.
-
-Use of the \code{extensions:maybe-inline} declaration followed by the \code{defun} is
-preferable to the standard idiom of:
-\begin{lisp}
-(proclaim '(inline myfun))
-(defun myfun () ...)
-(proclaim '(notinline myfun))
-
-;;; \i{Any calls to \code{myfun} here are not inline expanded.}
-
-(defun somefun ()
-  (declare (inline myfun))
-  ;;
-  ;; \i{Calls to \code{myfun} here are inline expanded.}
-  ...)
-\end{lisp}
-The problem with using \code{notinline} in this way is that in \clisp{} it does more
-than just suppress inline expansion, it also forbids the compiler to use any
-knowledge of \code{myfun} until a later \code{inline} declaration overrides the
-\code{notinline}.  This prevents compiler warnings about incorrect calls to the
-function, and also prevents block compilation.
-
-The \code{extensions:maybe-inline} declaration is used like this:
-\begin{lisp}
-(proclaim '(extensions:maybe-inline myfun))
-(defun myfun () ...)
-
-;;; \i{Any calls to \code{myfun} here are not inline expanded.}
-
-(defun somefun ()
-  (declare (inline myfun))
-  ;;
-  ;; \i{Calls to \code{myfun} here are inline expanded.}
-  ...)
-
-(defun someotherfun ()
-  (declare (optimize (space 0)))
-  ;;
-  ;; \i{Calls to \code{myfun} here are expanded semi-inline.}
-  ...)
-\end{lisp}
-In this example, the use of \code{extensions:maybe-inline} causes the expansion to
-be recorded when the \code{defun} for \code{somefun} is compiled, and doesn't waste
-space through doing inline expansion by default.  Unlike \code{notinline}, this
-declaration still allows the compiler to assume that the known definition
-really is the one that will be called when giving compiler warnings, and also
-allows the compiler to do semi-inline expansion when the policy is appropriate.
-
-When the goal is merely to control whether inline expansion is done by default,
-it is preferable to use \code{extensions:maybe-inline} rather than \code{notinline}.
-The \code{notinline} declaration should be reserved for those special occasions
-when a function may be redefined at run-time, so the compiler must be told that
-the obvious definition of a function is not necessarily the one that will be in
-effect at the time of the call.
-
-
-\node Object Representation, Numbers, Inline Expansion, Advanced Compiler Use and Efficiency Hints
-\section{Object Representation}
-\label{object-representation}
-\cindex{object representation}
-\cpsubindex{representation}{object}
-\cpsubindex{efficiency}{of objects}
-
-A somewhat subtle aspect of writing efficient \clisp{} programs is choosing the
-correct data structures so that the underlying objects can be implemented
-efficiently.  This is partly because of the need for multiple representations
-for a given value (\pxlref{non-descriptor}), but is also due to
-the sheer number of object types that \clisp{} has built in.  The number of
-possible representations complicates the choice of a good representation
-because semantically similar objects may vary in their efficiency depending on
-how the program operates on them.
-
-\begin{menu}
-* Think Before You Use a List::  
-* Structures::                  
-* Arrays::                      
-* Vectors::                     
-* Bit-Vectors::                 
-* Hashtables::                  
-\end{menu}
-
-\node Think Before You Use a List, Structures, Object Representation, Object Representation
-\subsection{Think Before You Use a List}
-\cpsubindex{lists}{efficiency of}
-
-Although Lisp's creator seemed to think that it was for LISt Processing, the
-astute observer may have noticed that the chapter on list manipulation makes up
-less that three percent of \i{Common Lisp: the Language II}.  The language has
-grown since Lisp 1.5 \dash{} new data types supersede lists for many purposes.
-
-\node Structures, Arrays, Think Before You Use a List, Object Representation
-\subsection{Structures}
-\cpsubindex{structure types}{efficiency of}
-One of the best ways of building complex data structures is to define
-appropriate structure types using \findexed{defstruct}.  In \python, access of
-structure slots is always at least as fast as list or vector access, and is
-usually faster.  In comparison to a list representation of a tuple, structures
-also have a space advantage.
-
-Even if structures weren't more efficient than other representations, structure
-use would still be attractive because programs that use structures in
-appropriate ways are much more maintainable and robust than programs written
-using only lists.  For example:
-\begin{lisp}
-(rplaca (caddr (cadddr x)) (caddr y))
-\end{lisp}
-could have been written using structures in this way:
-\begin{lisp}
-(setf (beverage-flavor (astronaut-beverage x)) (beverage-flavor y))
-\end{lisp}
-The second version is more maintainable because it is easier to understand what
-it is doing.  It is more robust because structures accesses are type checked.
-An \code{astronaut} will never be confused with a \code{beverage}, and the result of
-\code{beverage-flavor} is always a flavor.  See sections \ref{structure-types} and
-\ref{freeze-type} for more information about structure types.  \xlref{type-inference} for a number of examples that make clear the advantages of
-structure typing.
-
-Note that the structure definition should be compiled before any uses of its
-accessors or type predicate so that these function calls can be efficiently
-open-coded.
-
-\node Arrays, Vectors, Structures, Object Representation
-\subsection{Arrays}
-\label{array-types}
-\cpsubindex{arrays}{efficiency of}
-
-Arrays are often the most efficient representation for collections of objects
-because:
-\begin{itemize}
-
-\item
-Array representations are often the most compact.  An array is always more
-compact than a list containing the same number of elements.
-
-\item
-Arrays allow fast constant-time access.
-
-\item
-Arrays are easily destructively modified, which can reduce consing.
-
-\item
-Array element types can be specialized, which reduces both overall size and
-consing (\pxlref{specialized-array-types}.)
-\end{itemize}
-
-
-Access of arrays that are not of type \code{simple-array} is less efficient, so
-declarations are appropriate when an array is of a simple type like
-\code{simple-string} or \code{simple-bit-vector}.  Arrays are almost always simple,
-but the compiler may not be able to prove simpleness at every use.  The only
-way to get a non-simple array is to use the \kwd{displaced-to},
-\kwd{fill-pointer} or \code{adjustable} arguments to \code{make-array}.  If you don't
-use these hairy options, then arrays can always be declared to be simple.
-
-Because of the many specialized array types and the possibility of non-simple
-arrays, array access is much like generic arithmetic (\pxlref{generic-arithmetic}).  In order for array accesses to be efficiently
-compiled, the element type and simpleness of the array must be known at compile
-time.  If there is inadequate information, the compiler is forced to call a
-generic array access routine.  You can detect inefficient array accesses by
-enabling efficiency notes, \pxlref{efficiency-notes}.
-
-\node Vectors, Bit-Vectors, Arrays, Object Representation
-\subsection{Vectors}
-\cpsubindex{vectors}{efficiency of}
-
-Vectors (one dimensional arrays) are particularly useful, since in addition to
-their obvious array-like applications, they are also well suited to
-representing sequences.  In comparison to a list representation, vectors are
-faster to access and take up between two and sixty-four times less space
-(depending on the element type.)  As with arbitrary arrays, the compiler needs
-to know that vectors are not complex, so you should use \code{simple-string} in
-preference to \code{string}, etc.
-
-The only advantage that lists have over vectors for representing sequences is
-that it is easy to change the length of a list, add to it and remove items from
-it.  Likely signs of archaic, slow lisp code are \code{nth} and \code{nthcdr}.  If
-you are using these functions you should probably be using a vector.
-
-\node Bit-Vectors, Hashtables, Vectors, Object Representation
-\subsection{Bit-Vectors}
-\cpsubindex{bit-vectors}{efficiency of}
-
-Another thing that lists have been used for is set manipulation.  In
-applications where there is a known, reasonably small universe of items
-bit-vectors can be used to improve performance.  This is much less convenient
-than using lists, because instead of symbols, each element in the universe must
-be assigned a numeric index into the bit vector.  Using a bit-vector will
-nearly always be faster, and can be tremendously faster if the number of
-elements in the set is not small.  The logical operations on
-\code{simple-bit-vector}s are efficient, since they operate on a word at a time.
-
-
-\node Hashtables,  , Bit-Vectors, Object Representation
-\subsection{Hashtables}
-\cpsubindex{hash-tables}{efficiency of}
-
-Hashtables are an efficient and general mechanism for maintaining associations
-such as the association between an object and its name.  Although hashtables
-are usually the best way to maintain associations, efficiency and style
-considerations sometimes favor the use of an association list (a-list).
-
-\code{assoc} is fairly fast when the \var{test} argument is \code{eq} or \code{eql} and
-there are only a few elements, but the time goes up in proportion with the
-number of elements.  In contrast, the hash-table lookup has a somewhat higher
-overhead, but the speed is largely unaffected by the number of entries in the
-table.  For an \code{equal} hash-table or alist, hash-tables have an even greater
-advantage, since the test is more expensive.  Whatever you do, be sure to use
-the most restrictive test function possible.
-
-The style argument observes that although hash-tables and alists
-overlap in function, they do not do all things equally well.
-\begin{itemize}
-
-\item
-Alists are good for maintaining scoped environments.  They were originally
-invented to implement scoping in the Lisp interpreter, and are still used for
-this in \python.  With an alist one can non-destructively change an association
-simply by consing a new element on the front.  This is something that cannot be
-done with hash-tables.
-
-\item
-Hashtables are good for maintaining a global association.
-The value associated with an entry can easily be changed with
-\code{setf}.  With an alist, one has to go through contortions, either
-\code{rplacd}'ing the cons if the entry exists, or pushing a new one if
-it doesn't.  The side-effecting nature of hash-table operations is an
-advantage here.
-\end{itemize}
-
-
-Historically, symbol property lists were often used for global name
-associations.  Property lists provide an awkward and error-prone combination of
-name association and record structure.  If you must use the property list,
-please store all the related values in a single structure under a single
-property, rather than using many properties.  This makes access more efficient,
-and also adds a modicum of typing and abstraction.  \xlref{advanced-type-stuff} for information on types in \cmucl.
-
-        
-\node Numbers, General Efficiency Hints, Object Representation, Advanced Compiler Use and Efficiency Hints
-\section{Numbers}
-\label{numeric-types}
-\cpsubindex{numeric}{types}
-\cpsubindex{types}{numeric}
-
-Numbers are interesting because numbers are one of the few \llisp{} data types
-that have direct support in conventional hardware.  If a number can be
-represented in the way that the hardware expects it, then there is a big
-efficiency advantage.
-
-Using hardware representations is problematical in \llisp{} due to dynamic typing
-(where the type of a value may be unknown at compile time.)  It is possible to
-compile code for statically typed portions of a \llisp{} program with efficiency
-comparable to that obtained in statically typed languages such as C, but not
-all \llisp{} implementations succeed.  There are two main barriers to efficient
-numerical code in \llisp{}:
-\begin{itemize}
-
-\item
-The compiler must prove that the numerical expression is in fact statically
-typed, and
-
-\item
-The compiler must be able to somehow reconcile the conflicting demands of the
-hardware mandated number representation with the \llisp{} requirements of dynamic
-typing and garbage-collecting dynamic storage allocation.
-\end{itemize}
-
-Because of its type inference (\pxlref{type-inference}) and efficiency
-notes (\pxlref{efficiency-notes}), \python{} is better than conventional
-\llisp{} compilers at ensuring that numerical expressions are statically typed.
-Python also goes somewhat farther than existing compilers in the area of
-allowing native machine number representations in the presence of garbage
-collection.
-
-\begin{menu}
-* Descriptors::                 
-* Non-Descriptor Representations::  
-* Variables::                   
-* Generic Arithmetic::          
-* Fixnums::                     
-* Word Integers::               
-* Floating Point Efficiency::   
-* Specialized Arrays::          
-* Interactions With Local Call::  
-* Representation of Characters::  
-\end{menu}
-
-\node Descriptors, Non-Descriptor Representations, Numbers, Numbers
-\subsection{Descriptors}
-\cpsubindex{descriptors}{object}
-\cindex{object representation}
-\cpsubindex{representation}{object}
-\cpsubindex{consing}{overhead of}
-
-\llisp{}'s dynamic typing requires that it be possible to represent any value
-with a fixed length object, known as a \var{descriptor}.  This fixed-length
-requirement is implicit in features such as:
-\begin{itemize}
-
-\item
-Data types (like \code{simple-vector}) that can contain any type of object, and
-that can be destructively modified to contain different objects (of possibly
-different types.)
-
-\item
-Functions that can be called with any type of argument, and that can be
-redefined at run time.
-\end{itemize}
-
-In order to save space, a descriptor is invariably represented as a single
-word.  Objects that can be directly represented in the descriptor itself are
-said to be \var{immediate}.  Descriptors for objects larger than one word are in
-reality pointers to the memory actually containing the object.
-
-Representing objects using pointers has two major disadvantages:
-\begin{itemize}
-
-\item
-The memory pointed to must be allocated on the heap, so it must eventually be
-freed by the garbage collector.  Excessive heap allocation of objects (or
-"consing") is inefficient in several ways.  \xlref{consing}.
-
-\item
-Representing an object in memory requires the compiler to emit additional
-instructions to read the actual value in from memory, and then to write the
-value back after operating on it.
-\end{itemize}
-
-The introduction of garbage collection makes things even worse, since the
-garbage collector must be able to determine whether a descriptor is an
-immediate object or a pointer.  This requires that a few bits in each
-descriptor be dedicated to the garbage collector.  The loss of a few bits
-doesn't seem like much, but it has a major efficiency implication \dash{} objects
-whose natural machine representation is a full word (integers and
-single-floats) cannot have an immediate representation.  So the compiler is
-forced to use an unnatural immediate representation (such as \code{fixnum}) or a
-natural pointer representation (with the attendant consing overhead.)
-
-
-\node Non-Descriptor Representations, Variables, Descriptors, Numbers
-\subsection{Non-Descriptor Representations}
-\label{non-descriptor}
-\cindex{non-descriptor representations}
-\cindex{stack numbers}
-
-From the discussion above, we can see that the standard descriptor
-representation has many problems, the worst being number consing.
-\llisp{} compilers try to avoid these descriptor efficiency problems by using
-\var{non-descriptor} representations.  A compiler that uses non-descriptor
-representations can compile this function so that it does no number consing:
-\begin{lisp}
-(defun multby (vec n)
-  (declare (type (simple-array single-float (*)) vec)
-           (single-float n))
-  (dotimes (i (length vec))
-    (setf (aref vec i)
-          (* n (aref vec i)))))
-\end{lisp}
-If a descriptor representation were used, each iteration of the loop might
-cons two floats and do three times as many memory references.
-
-As its negative definition suggests, the range of possible non-descriptor
-representations is large.  The performance improvement from non-descriptor
-representation depends upon both the number of types that have non-descriptor
-representations and the number of contexts in which the compiler is forced to
-use a descriptor representation.
-
-Many \llisp{} compilers support non-descriptor representations for float types
-such as \code{single-float} and \code{double-float} (section \ref{float-efficiency}.)
-\python{} adds support for full word integers (\pxlref{word-integers}),
-characters (\pxlref{characters}) and system-area pointers (unconstrained
-pointers, \pxlref{system-area-pointers}.)  Many \llisp{} compilers
-support non-descriptor representations for variables (section
-\ref{ND-variables}) and array elements (section \ref{specialized-array-types}.)
-\python{} adds support for non-descriptor arguments and return values in local
-call (\pxlref{number-local-call}).
-\node Variables, Generic Arithmetic, Non-Descriptor Representations, Numbers
-\subsection{Variables}
-\label{ND-variables}
-\cpsubindex{variables}{non-descriptor}
-\cpsubindex{type declarations}{variable}
-\cpsubindex{efficiency}{of numeric variables}
-
-In order to use a non-descriptor representation for a variable or expression
-intermediate value, the compiler must be able to prove that the value is always
-of a particular type having a non-descriptor representation.  Type inference
-(\pxlref{type-inference}) often needs some help from user-supplied
-declarations.  The best kind of type declaration is a variable type declaration
-placed at the binding point:
-\begin{lisp}
-(let ((x (car l)))
-  (declare (single-float x))
-  ...)
-\end{lisp}
-Use of \code{the}, or of variable declarations not at the binding form is
-insufficient to allow non-descriptor representation of the variable \dash{} with
-these declarations it is not certain that all values of the variable are of the
-right type.  It is sometimes useful to introduce a gratuitous binding that
-allows the compiler to change to a non-descriptor representation, like:
-\begin{lisp}
-(etypecase x
-  ((signed-byte 32)
-   (let ((x x))
-     (declare (type (signed-byte 32) x)) 
-     ...))
-  ...)
-\end{lisp}
-The declaration on the inner \code{x} is necessary here due to a phase ordering
-problem.  Although the compiler will eventually prove that the outer \code{x} is
-a \w{\code{(signed-byte 32)}} within that \code{etypecase} branch, the inner \code{x}
-would have been optimized away by that time.  Declaring the type makes let
-optimization more cautious.
-
-Note that storing a value into a global (or \code{special}) variable always forces
-a descriptor representation.  Wherever possible, you should operate only on
-local variables, binding any referenced globals to local variables at the
-beginning of the function, and doing any global assignments at the end.
-
-Efficiency notes signal use of inefficient representations, so programmer's
-needn't continuously worry about the details of representation selection (\pxlref{representation-eff-note}.)
-
-\node Generic Arithmetic, Fixnums, Variables, Numbers
-\subsection{Generic Arithmetic}
-\label{generic-arithmetic}
-\cindex{generic arithmetic}
-\cpsubindex{arithmetic}{generic}
-\cpsubindex{numeric}{operation efficiency}
-
-In \clisp, arithmetic operations are \var{generic}.\footnote{As Steele notes in CLTL
-II, this is a generic conception of generic, and is not to be confused with the
-CLOS concept of a generic function.}  The \code{+} function can be passed
-\code{fixnum}s, \code{bignum}s, \code{ratio}s, and various kinds of \code{float}s and
-\code{complex}es, in any combination.  In addition to the inherent complexity of
-\code{bignum} and \code{ratio} operations, there is also a lot of overhead in just
-figuring out which operation to do and what contagion and canonicalization
-rules apply.  The complexity of generic arithmetic is so great that it is
-inconceivable to open code it.  Instead, the compiler does a function call to a
-generic arithmetic routine, consuming many instructions before the actual
-computation even starts.
-
-This is ridiculous, since even \llisp{} programs do a lot of arithmetic, and the
-hardware is capable of doing operations on small integers and floats with a
-single instruction.  To get acceptable efficiency, the compiler special-cases
-uses of generic arithmetic that are directly implemented in the hardware.  In
-order to open code arithmetic, several constraints must be met:
-\begin{itemize}
-
-\item
-All the arguments must be known to be a good type of number.
-
-\item
-The result must be known to be a good type of number.
-
-\item
-Any intermediate values such as the result of \w{\code{(+ a b)}} in the call
-\w{\code{(+ a b c)}} must be known to be a good type of number.
-
-\item
-All the above numbers with good types must be of the \var{same} good type.  Don't
-try to mix integers and floats or different float formats.
-\end{itemize}
-
-The "good types" are \w{\code{(signed-byte 32)}}, \w{\code{(unsigned-byte 32)}},
-\code{single-float} and \code{double-float}.  See sections \ref{fixnums},
-\ref{word-integers} and \ref{float-efficiency} for more discussion of good
-numeric types.
-
-\code{float} is not a good type, since it might mean either \code{single-float} or
-\code{double-float}.  \code{integer} is not a good type, since it might mean
-\code{bignum}.  \code{rational} is not a good type, since it might mean \code{ratio}.
-Note however that these types are still useful in declarations, since
-type inference may be able to strengthen a weak declaration into a good one,
-when it would be at a loss if there was no declaration at all (\pxlref{type-inference}).  The \code{integer} and \code{unsigned-byte} (or non-negative
-integer) types are especially useful in this regard, since they can often be
-strengthened to a good integer type.
-
-Arithmetic with \code{complex} numbers is inefficient in comparison to float and
-integer arithmetic.  Complex numbers are always represented with a pointer
-descriptor (causing consing overhead), and complex arithmetic is always closed
-coded using the general generic arithmetic functions.  But arithmetic with
-complex types such as:
-\begin{lisp}
-(complex float)
-(complex fixnum)
-\end{lisp}
-is still faster than \code{bignum} or \code{ratio} arithmetic, since the
-implementation is much simpler.
-
-Note: don't use \code{/} to divide integers unless you want the overhead of
-rational arithmetic.  Use \code{truncate} even when you know that the arguments
-divide evenly.
-
-You don't need to remember all the rules for how to get open-coded arithmetic,
-since efficiency notes will tell you when and where there is a problem \dash{}
-\pxlref{efficiency-notes}.
-
-
-\node Fixnums, Word Integers, Generic Arithmetic, Numbers
-\subsection{Fixnums}
-\label{fixnums}
-\cindex{fixnums}
-\cindex{bignums}
-
-A fixnum is a "FIXed precision NUMber".  In modern \llisp{} implementations,
-fixnums can be represented with an immediate descriptor, so operating on
-fixnums requires no consing or memory references.  Clever choice of
-representations also allows some arithmetic operations to be done on fixnums
-using hardware supported word-integer instructions, somewhat reducing the
-speed penalty for using an unnatural integer representation.
-
-It is useful to distinguish the \code{fixnum} type from the fixnum representation
-of integers.  In \python, there is absolutely nothing magical about the
-\code{fixnum} type in comparison to other finite integer types.  \code{fixnum} is
-equivalent to (is defined with \code{deftype} to be) \w{\code{(signed-byte 30)}}.
-\code{fixnum} is simply the largest subset of integers that \i{can be represented}
-using an immediate fixnum descriptor.
-
-Unlike in other \clisp{} compilers, it is in no way desirable to use the
-\code{fixnum} type in declarations in preference to more restrictive integer types
-such as \code{bit}, \w{\code{(integer -43 7)}} and \w{\code{(unsigned-byte 8)}}.  Since
-Python does understand these integer types, it is preferable to use the more
-restrictive type, as it allows better type inference (\pxlref{operation-type-inference}.)
-
-The small, efficient fixnum is contrasted with bignum, or "BIG NUMber".  This
-is another descriptor representation for integers, but this time a pointer
-representation that allows for arbitrarily large integers.  Bignum operations
-are less efficient than fixnum operations, both because of the consing and
-memory reference overheads of a pointer descriptor, and also because of the
-inherent complexity of extended precision arithmetic.  While fixnum operations
-can often be done with a single instruction, bignum operations are so complex
-that they are always done using generic arithmetic.
-
-A crucial point is that the compiler will use generic arithmetic if
-it can't \var{prove} that all the arguments, intermediate values, and results are
-fixnums.  With bounded integer types such as \code{fixnum}, the result type proves
-to be especially problematical, since these types are not closed under
-common arithmetic operations such as \code{+}, \code{-}, \code{*} and \code{/}.  For
-example, \w{\code{(1+ (the fixnum x))}} does not necessarily evaluate to a
-\code{fixnum}.  Bignums were added to \llisp{} to get around this problem, but they
-really just transform the correctness problem "if this add overflows, you will
-get the wrong answer" to the efficiency problem "if this add \var{might} overflow
-then your program will run slowly (because of generic arithmetic.)"
-
-There is just no getting around the fact that the hardware only directly
-supports short integers.  To get the most efficient open coding, the compiler
-must be able to prove that the result is a good integer type.  This is an
-argument in favor of using more restrictive integer types: 
-\w{\code{(1+ (the fixnum x))}} may not always be a \code{fixnum}, but
-\w{\code{(1+ (the (unsigned-byte 8) x))}} always is.
-Of course, you can also assert the result type by putting in lots of \code{the}
-declarations and then compiling with \code{safety} \code{0}.
-
-\node Word Integers, Floating Point Efficiency, Fixnums, Numbers
-\subsection{Word Integers}
-\label{word-integers}
-\cindex{word integers}
-
-Python is unique in its efficient implementation of arithmetic
-on full-word integers through non-descriptor representations and open coding.
-Arithmetic on any subtype of these types:
-\begin{lisp}
-(signed-byte 32)
-(unsigned-byte 32)
-\end{lisp}
-is reasonably efficient, although subtypes of \code{fixnum} remain somewhat more
-efficient.
-
-If a word integer must be represented as a descriptor, then the \code{bignum}
-representation is used, with its associated consing overhead.  The support for
-word integers in no way changes the language semantics, it just makes
-arithmetic on small bignums vastly more efficient.  It is fine to do arithmetic
-operations with mixed \code{fixnum} and word integer operands; just declare the
-most specific integer type you can, and let the compiler decide what
-representation to use.
-
-In fact, to most users, the greatest advantage of word integer arithmetic is
-that it effectively provides a few guard bits on the fixnum representation.  If
-there are missing assertions on intermediate values in a fixnum expression, the
-intermediate results can usually be proved to fit in a word.  After the whole
-expression is evaluated, there will often be a fixnum assertion on the final
-result, allowing creation of a fixnum result without even checking for
-overflow.
-
-The remarks in section \ref{fixnums} about fixnum result type also apply to
-word integers; you must be careful to give the compiler enough information to
-prove that the result is still a word integer.  This time, though, when we blow
-out of word integers we land in into generic bignum arithmetic, which is much
-worse than sleazing from \code{fixnum}s to word integers.  Note that mixing
-\w{\code{(unsigned-byte 32)}} arguments with arguments of any signed type (such as
-\code{fixnum}) is a no-no, since the result might not be unsigned.
-
-\node Floating Point Efficiency, Specialized Arrays, Word Integers, Numbers
-\subsection{Floating Point Efficiency}
-\label{float-efficiency}
-\cindex{floating point efficiency}
-
-Arithmetic on objects of type \code{single-float} and \code{double-float} is
-efficiently implemented using non-descriptor representations and open coding.
-As for integer arithmetic, the arguments must be known to be of the same float
-type.  Unlike for integer arithmetic, the results and intermediate values
-usually take care of themselves due to the rules of float contagion, i.e.
-\w{\code{(1+ (the single-float x))}} is always a \code{single-float}.
-
-Although they are not specially implemented, \code{short-float} and \code{long-float}
-are also acceptable in declarations, since they are synonyms for the
-\code{single-float} and \code{double-float} types, respectively.  It is harmless to
-use list-style float type specifiers such as \w{\code{(single-float 0.0 1.0)}},
-but Python currently makes little use of bounds on float types.
-
-When a float must be represented as a descriptor, a pointer representation is
-used, creating consing overhead.  For this reason, you should try to avoid
-situations (such as full call and non-specialized data structures) that force a
-descriptor representation.  See sections \ref{specialized-array-types} and
-\ref{number-local-call}.
-
-\xlref{ieee-float} for information on the extensions to support IEEE
-floating point.
-
-\node Specialized Arrays, Interactions With Local Call, Floating Point Efficiency, Numbers
-\subsection{Specialized Arrays}
-\label{specialized-array-types}
-\cindex{specialized array types}
-\cpsubindex{array types}{specialized}
-\cpsubindex{types}{specialized array}
-
-\clisp{} supports specialized array element types through the \kwd{element-type}
-argument to \code{make-array}.  When an array has a specialized element type, only
-elements of that type can be stored in the array.  From this restriction comes
-two major efficiency advantages:
-\begin{itemize}
-
-\item
-A specialized array can save space by packing multiple elements into a single
-word.  For example, a \code{base-char} array can have 4 elements per word, and
-a \code{bit} array can have 32.  This space-efficient representation is possible
-because it is not necessary to separately indicate the type of each element.
-
-\item
-The elements in a specialized array can be given the same non-descriptor
-representation as the one used in registers and on the stack, eliminating the
-need for representation conversions when reading and writing array elements.
-For objects with pointer descriptor representations (such as floats and word
-integers) there is also a substantial consing reduction because it is not
-necessary to allocate a new object every time an array element is modified.
-\end{itemize}
-
-
-These are the specialized element types currently supported:
-\begin{lisp}
-bit
-(unsigned-byte 2)
-(unsigned-byte 4)
-(unsigned-byte 8)
-(unsigned-byte 16)
-(unsigned-byte 32)
-base-character
-single-float
-double-float
-\end{lisp}
-Although a \code{simple-vector} can hold any type of object, \true{} should still be
-considered a specialized array type, since arrays with element type \true{} are
-specialized to hold descriptors.
-
-When using non-descriptor representations, it is particularly important to make
-sure that array accesses are open-coded, since in addition to the generic
-operation overhead, efficiency is lost when the array element is converted to a
-descriptor so that it can be passed to (or from) the generic access routine.
-You can detect inefficient array accesses by enabling efficiency notes, \pxlref{efficiency-notes}.  \xlref{array-types}.
-
-\node Interactions With Local Call, Representation of Characters, Specialized Arrays, Numbers
-\subsection{Interactions With Local Call}
-\label{number-local-call}
-\cpsubindex{local call}{numeric operands}
-\cpsubindex{call}{numeric operands}
-\cindex{numbers in local call}
-
-Local call has many advantages (\pxlref{local-call}); one relevant to
-our discussion here is that local call extends the usefulness of non-descriptor
-representations.  If the compiler knows from the argument type that an argument
-has a non-descriptor representation, then the argument will be passed in that
-representation.  The easiest way to ensure that the argument type is known at
-compile time is to always declare the argument type in the called function,
-like:
-\begin{lisp}
-(defun 2+f (x)
-  (declare (single-float x))
-  (+ x 2.0))
-\end{lisp}
-The advantages of passing arguments and return values in a non-descriptor
-representation are the same as for non-descriptor representations in general:
-reduced consing and memory access (\pxlref{non-descriptor}.)  This
-extends the applicative programming styles discussed in section
-\ref{local-call} to numeric code.  Also, if source files are kept reasonably
-small, block compilation can be used to reduce number consing to a minimum.
-
-Note that non-descriptor return values can only be used with the known return
-convention (section \ref{local-call-return}.)  If the compiler can't prove that
-a function always returns the same number of values, then it must use the
-unknown values return convention, which requires a descriptor representation.
-Pay attention to the known return efficiency notes to avoid number consing.
- 
-\node Representation of Characters,  , Interactions With Local Call, Numbers
-\subsection{Representation of Characters}
-\label{characters}
-\cindex{characters}
-\cindex{strings}
-
-Python also uses a non-descriptor representation for characters when
-convenient.  This improves the efficiency of string manipulation, but is
-otherwise pretty invisible; characters have an immediate descriptor
-representation, so there is not a great penalty for converting a character to a
-descriptor.  Nonetheless, it may sometimes be helpful to declare
-character-valued variables as \code{base-character}.
-
-
-\node General Efficiency Hints, Efficiency Notes, Numbers, Advanced Compiler Use and Efficiency Hints
-\section{General Efficiency Hints}
-\label{general-efficiency}
-\cpsubindex{efficiency}{general hints}
-
-This section is a summary of various implementation costs and ways to get
-around them.  These hints are relatively unrelated to the use of the \python{}
-compiler, and probably also apply to most other \llisp{} implementations.  In
-each section, there are references to related in-depth discussion.
-
-\begin{menu}
-* Compile Your Code::           
-* Avoid Unnecessary Consing::   
-* Complex Argument Syntax::     
-* Mapping and Iteration::       
-* Trace Files and Disassembly::  
-\end{menu}
-
-\node Compile Your Code, Avoid Unnecessary Consing, General Efficiency Hints, General Efficiency Hints
-\subsection{Compile Your Code}
-\cpsubindex{compilation}{why to}
-
-At this point, the advantages of compiling code relative to running it
-interpreted probably need not be emphasized too much, but remember that
-in \cmucl, compiled code typically runs hundreds of times faster than
-interpreted code.  Also, compiled (\code{fasl}) files load significantly faster
-than source files, so it is worthwhile compiling files which are loaded many
-times, even if the speed of the functions in the file is unimportant.
-
-Even disregarding the efficiency advantages, compiled code is as good or better
-than interpreted code.  Compiled code can be debugged at the source level (see
-chapter \ref{debugger}), and compiled code does more error checking.  For these
-reasons, the interpreter should be regarded mainly as an interactive command
-interpreter, rather than as a programming language implementation.
-
-\b{Do not} be concerned about the performance of your program until you
-see its speed compiled.  Some techniques that make compiled code run
-faster make interpreted code run slower.
-
-\node Avoid Unnecessary Consing, Complex Argument Syntax, Compile Your Code, General Efficiency Hints
-\subsection{Avoid Unnecessary Consing}
-\cindex{consing}
-\cindex{garbage collection}
-\cindex{memory allocation}
-\cpsubindex{efficiency}{of memory use}
-
-\label{consing} Consing is another name for allocation of storage, as done by
-the \code{cons} function (hence its name.)  \code{cons} is by no means the only
-function which conses \dash{} so does \code{make-array} and many other functions.
-Arithmetic and function call can also have hidden consing overheads.  Consing
-hurts performance in the following ways:
-\begin{itemize}
-
-\item
-Consing reduces memory access locality, increasing paging activity.
-
-\item
-Consing takes time just like anything else.
-
-\item
-Any space allocated eventually needs to be reclaimed, either by garbage
-collection or by starting a new \code{lisp} process.
-\end{itemize}
-
-
-Consing is not undiluted evil, since programs do things other than consing, and
-appropriate consing can speed up the real work.  It would certainly save time
-to allocate a vector of intermediate results that are reused hundreds of
-times.  Also, if it is necessary to copy a large data structure many times, it
-may be more efficient to update the data structure non-destructively; this
-somewhat increases update overhead, but makes copying trivial.
-
-Note that the remarks in section \ref{efficiency-overview} about the importance
-of separating tuning from coding also apply to consing overhead.  The majority
-of consing will be done by a small portion of the program.  The consing hot
-spots are even less predictable than the CPU hot spots, so don't waste time and
-create bugs by doing unnecessary consing optimization.  During initial coding,
-avoid unnecessary side-effects and cons where it is convenient.  If profiling
-reveals a consing problem, \var{then} go back and fix the hot spots.
-
-\xlref{non-descriptor} for a discussion of how to avoid number
-consing in \python.
-
-
-\node Complex Argument Syntax, Mapping and Iteration, Avoid Unnecessary Consing, General Efficiency Hints
-\subsection{Complex Argument Syntax}
-\cpsubindex{argument syntax}{efficiency}
-\cpsubindex{efficiency}{of argument syntax}
-\cindex{keyword argument efficiency}
-\cindex{rest argument efficiency}
-
-Common Lisp has very powerful argument passing mechanisms.  Unfortunately, two
-of the most powerful mechanisms, rest arguments and keyword arguments, have a
-significant performance penalty:
-\begin{itemize}
-
-\item
-With keyword arguments, the called function has to parse the supplied keywords
-by iterating over them and checking them against the desired keywords.
-
-\item
-With rest arguments, the function must cons a list to hold the arguments.  If a
-function is called many times or with many arguments, large amounts of memory
-will be allocated.
-\end{itemize}
-
-Although rest argument consing is worse than keyword parsing, neither problem
-is serious unless thousands of calls are made to such a function.  The use of
-keyword arguments is strongly encouraged in functions with many arguments or
-with interfaces that are likely to be extended, and rest arguments are often
-natural in user interface functions.
-
-Optional arguments have some efficiency advantage over keyword arguments, but
-their syntactic clumsiness and lack of extensibility has caused many \clisp{}
-programmers to abandon use of optionals except in functions that have obviously
-simple and immutable interfaces (such as \code{subseq}), or in functions that are
-only called in a few places.  When defining an interface function to be used by
-other programmers or users, use of only required and keyword arguments is
-recommended.
-
-Parsing of \code{defmacro} keyword and rest arguments is done at compile time, so
-a macro can be used to provide a convenient syntax with an efficient
-implementation.  If the macro-expanded form contains no keyword or rest
-arguments, then it is perfectly acceptable in inner loops.
-
-Keyword argument parsing overhead can also be avoided by use of inline
-expansion (\pxlref{inline-expansion}) and block compilation (section
-\ref{block-compilation}.)
-
-Note: the compiler open-codes most heavily used system functions which have
-keyword or rest arguments, so that no run-time overhead is involved.
-
-\node Mapping and Iteration, Trace Files and Disassembly, Complex Argument Syntax, General Efficiency Hints
-\subsection{Mapping and Iteration}
-\cpsubindex{mapping}{efficiency of}
-
-One of the traditional \llisp{} programming styles is a highly applicative one,
-involving the use of mapping functions and many lists to store intermediate
-results.  To compute the sum of the square-roots of a list of numbers, one
-might say:
-\begin{lisp}
-(apply #'+ (mapcar #'sqrt list-of-numbers))
-\end{lisp}
-
-This programming style is clear and elegant, but unfortunately results
-in slow code.  There are two reasons why:
-\begin{itemize}
-
-\item
-The creation of lists of intermediate results causes much consing (see
-\ref{consing}).
-
-\item
-Each level of application requires another scan down the list.  Thus,
-disregarding other effects, the above code would probably take twice
-as long as a straightforward iterative version.
-\end{itemize}
-
-
-An example of an iterative version of the same code:
-\begin{lisp}
-(do ((num list-of-numbers (cdr num))
-     (sum 0 (+ (sqrt (car num)) sum)))
-    ((null num) sum))
-\end{lisp}
-
-See sections \ref{variable-type-inference} and \ref{let-optimization} for a
-discussion of the interactions of iteration constructs with type inference and
-variable optimization.  Also, section \ref{local-tail-recursion} discusses an
-applicative style of iteration.
-
-\node Trace Files and Disassembly,  , Mapping and Iteration, General Efficiency Hints
-\subsection{Trace Files and Disassembly}
-\label{trace-files}
-\cindex{trace files}
-\cindex{assembly listing}
-\cpsubindex{listing files}{trace}
-\cindex{Virtual Machine (VM, or IR2) representation}
-\cindex{implicit continuation representation (IR1)}
-\cpsubindex{continuations}{implicit representation}
-
-In order to write efficient code, you need to know the relative costs of
-different operations.  The main reason why writing efficient \llisp{} code is
-difficult is that there are so many operations, and the costs of these
-operations vary in obscure context-dependent ways.  Although efficiency notes
-point out some problem areas, the only way to ensure generation of the best code
-is to look at the assembly code output.
-
-The \code{disassemble} function is a convenient way to get the assembly code for a
-function, but it can be very difficult to interpret, since the correspondence
-with the original source code is weak.  A better (but more awkward) option is
-to use the \kwd{trace-file} argument to \code{compile-file} to generate a trace
-file.
-
-A trace file is a dump of the compiler's internal representations, including
-annotated assembly code.  Each component in the program gets three pages in
-the trace file (separated by "\code{^L}"):
-\begin{itemize}
-
-\item
-The implicit-continuation (or IR1) representation of the optimized source.
-This is a dump of the flow graph representation used for "source level"
-optimizations.  As you will quickly notice, it is not really very close to the
-source.  This representation is not very useful to even sophisticated users.
-
-\item
-The Virtual Machine (VM, or IR2) representation of the program.  This dump
-represents the generated code as sequences of "Virtual OPerations" (VOPs.)
-This representation is intermediate between the source and the assembly code
-\dash{} each VOP corresponds fairly directly to some primitive function or
-construct, but a given VOP also has a fairly predictable instruction sequence.
-An operation (such as \code{+}) may have multiple implementations with different
-cost and applicability.  The choice of a particular VOP such as \code{+/fixnum} or
-\code{+/single-float} represents this choice of implementation.  Once you are
-familiar with it, the VM representation is probably the most useful for
-determining what implementation has been used.
-
-\item
-An assembly listing, annotated with the VOP responsible for generating the
-instructions.  This listing is useful for figuring out what a VOP does and how
-it is implemented in a particular context, but its large size makes it more
-difficult to read.
-\end{itemize}
-
-
-Note that trace file generation takes much space and time, since the trace file
-is tens of times larger than the source file.  To avoid huge confusing trace
-files and much wasted time, it is best to separate the critical program portion
-into its own file and then generate the trace file from this small file.
-
-
-\node Efficiency Notes, Profiling, General Efficiency Hints, Advanced Compiler Use and Efficiency Hints
-\section{Efficiency Notes}
-\label{efficiency-notes}
-\cindex{efficiency notes}
-\cpsubindex{notes}{efficiency}
-\cindex{tuning}
-
-Efficiency notes are messages that warn the user that the compiler has chosen a
-relatively inefficient implementation for some operation.  Usually an
-efficiency note reflects the compiler's desire for more type information.  If
-the type of the values concerned is known to the programmer, then additional
-declarations can be used to get a more efficient implementation.
-
-Efficiency notes are controlled by the \code{extensions:inhibit-warnings}
-optimization quality (\pxlref{optimize-declaration}.)  When \code{speed}
-is greater than \code{extensions:inhibit-warnings}, efficiency notes are enabled.
-Note that this implicitly enables efficiency notes whenever \code{speed} is
-increased from its default of \code{1}.
-
-Consider this program with an obscure missing declaration:
-\begin{lisp}
-(defun eff-note (x y z)
-  (declare (fixnum x y z))
-  (the fixnum (+ x y z)))
-\end{lisp}
-If compiled with \code{\w{(speed 3) (safety 0)}}, this note is given:
-\begin{example}
-In: DEFUN EFF-NOTE
-  (+ X Y Z)
-==>
-  (+ (+ X Y) Z)
-Note: Forced to do inline (signed-byte 32) arithmetic (cost 3).
-      Unable to do inline fixnum arithmetic (cost 2) because:
-      The first argument is a (INTEGER -1073741824 1073741822),
-      not a FIXNUM.
-\end{example}
-This efficiency note tells us that the result of the intermediate computation
-\code{\w{(+ x y)}} is not known to be a \code{fixnum}, so the addition of the
-intermediate sum to \code{z} must be done less efficiently.  This can be fixed by
-changing the definition of \code{eff-note}:
-\begin{lisp}
-(defun eff-note (x y z)
-  (declare (fixnum x y z))
-  (the fixnum (+ (the fixnum (+ x y)) z)))
-\end{lisp}
-
-\begin{menu}
-* Type Uncertainty::            
-* Efficiency Notes and Type Checking::  
-* Representation Efficiency Notes::  
-* Verbosity Control::           
-\end{menu}
-
-\node Type Uncertainty, Efficiency Notes and Type Checking, Efficiency Notes, Efficiency Notes
-\subsection{Type Uncertainty}
-\cpsubindex{types}{uncertainty}
-\cindex{uncertainty of types}
-
-The main cause of inefficiency is the compiler's lack of adequate information
-about the types of function argument and result values.  Many important
-operations (such as arithmetic) have an inefficient general (generic) case, but
-have efficient implementations that can usually be used if there is sufficient
-argument type information.
-
-Type efficiency notes are given when a value's type is uncertain.  There is an
-important distinction between values that are \i{not known} to be of a good
-type (uncertain) and values that are \i{known not} to be of a good type.
-Efficiency notes are given mainly for the first case (uncertain types.)  If it
-is clear to the compiler that that there is not an efficient implementation for
-a particular function call, then an efficiency note will only be given if the
-\code{extensions:inhibit-warnings} optimization quality is \code{0} (\pxlref{optimize-declaration}.)
-
-In other words, the default efficiency notes only suggest that you add
-declarations, not that you change the semantics of your program so that an
-efficient implementation will apply.  For example, compilation of this form
-will not give an efficiency note:
-\begin{lisp}
-(elt (the list l) i)
-\end{lisp}
-even though a vector access is more efficient than indexing a list.
-
-\node Efficiency Notes and Type Checking, Representation Efficiency Notes, Type Uncertainty, Efficiency Notes
-\subsection{Efficiency Notes and Type Checking}
-\cpsubindex{type checking}{efficiency of}
-\cpsubindex{efficiency}{of type checking}
-\cpsubindex{optimization}{type check}
-
-It is important that the \code{eff-note} example above used
-\w{\code{(safety 0)}}.  When type checking is enabled, you may get apparently
-spurious efficiency notes.  With \w{\code{(safety 1)}}, the note has this extra
-line on the end:
-\begin{example}
-The result is a (INTEGER -1610612736 1610612733), not a FIXNUM.
-\end{example}
-This seems strange, since there is a \code{the} declaration on the result of that
-second addition.
-
-In fact, the inefficiency is real, and is a consequence of \python{}'s treating
-declarations as assertions to be verified.  The compiler can't assume that the
-result type declaration is true \dash{} it must generate the result and then test
-whether it is of the appropriate type.
-
-In practice, this means that when you are tuning a program to run without type
-checks, you should work from the efficiency notes generated by unsafe
-compilation.  If you want code to run efficiently with type checking, then you
-should pay attention to all the efficiency notes that you get during safe
-compilation.  Since user supplied output type assertions (e.g., from \code{the})
-are disregarded when selecting operation implementations for safe code, you
-must somehow give the compiler information that allows it to prove that the
-result truly must be of a good type.  In our example, it could be done by
-constraining the argument types more:
-\begin{lisp}
-(defun eff-note (x y z)
-  (declare (type (unsigned-byte 18) x y z))
-  (+ x y z))
-\end{lisp}
-Of course, this declaration is acceptable only if the arguments to \code{eff-note}
-always \var{are} \w{\code{(unsigned-byte 18)}} integers.
-
-\node Representation Efficiency Notes, Verbosity Control, Efficiency Notes and Type Checking, Efficiency Notes
-\subsection{Representation Efficiency Notes}
-\label{representation-eff-note}
-\cindex{representation efficiency notes}
-\cpsubindex{efficiency notes}{for representation}
-\cindex{object representation efficiency notes}
-\cindex{stack numbers}
-\cindex{non-descriptor representations}
-\cpsubindex{descriptor representations}{forcing of}
-
-When operating on values that have non-descriptor representations (\pxlref{non-descriptor}), there can be a substantial time and consing penalty for
-converting to and from descriptor representations.  For this reason, the
-compiler gives an efficiency note whenever it is forced to do a representation
-coercion more expensive than \varref{efficiency-note-cost-threshold}.
-
-Inefficient representation coercions may be due to type uncertainty, as in this example:
-\begin{lisp}
-(defun set-flo (x)
-  (declare (single-float x))
-  (prog ((var 0.0))
-    (setq var (gorp))
-    (setq var x)
-    (return var)))
-\end{lisp}
-which produces this efficiency note:
-\begin{example}
-In: DEFUN SET-FLO
-  (SETQ VAR X)
-Note: Doing float to pointer coercion (cost 13) from X to VAR.
-\end{example}
-The variable \code{var} is not known to always hold values of type
-\code{single-float}, so a descriptor representation must be used for its value.
-In sort of situation, and adding a declaration will eliminate the inefficiency.
-
-Often inefficient representation conversions are not due to type uncertainty
-\dash{} instead, they result from evaluating a non-descriptor expression in a
-context that requires a descriptor result:
-\begin{itemize}
-
-\item
-Assignment to or initialization of any data structure other than a specialized
-array (\pxlref{specialized-array-types}), or
-
-\item
-Assignment to a \code{special} variable, or
-
-\item
-Passing as an argument or returning as a value in any function call that is not
-a local call (\pxlref{number-local-call}.)
-\end{itemize}
-
-If such inefficient coercions appear in a "hot spot" in the program, data
-structures redesign or program reorganization may be necessary to improve
-efficiency.  See sections \ref{block-compilation}, \ref{numeric-types} and
-\ref{profiling}.
-
-Because representation selection is done rather late in compilation, the source
-context in these efficiency notes is somewhat vague, making interpretation more
-difficult.  This is a fairly straightforward example:
-\begin{lisp}
-(defun cf+ (x y)
-  (declare (single-float x y))
-  (cons (+ x y) t))
-\end{lisp}
-which gives this efficiency note:
-\begin{example}
-In: DEFUN CF+
-  (CONS (+ X Y) T)
-Note: Doing float to pointer coercion (cost 13), for:
-      The first argument of CONS.
-\end{example}
-The source context form is almost always the form that receives the value being
-coerced (as it is in the preceding example), but can also be the source form
-which generates the coerced value.  Compiling this example:
-\begin{lisp}
-(defun if-cf+ (x y)
-  (declare (single-float x y))
-  (cons (if (grue) (+ x y) (snoc)) t))
-\end{lisp}
-produces this note:
-\begin{example}
-In: DEFUN IF-CF+
-  (+ X Y)
-Note: Doing float to pointer coercion (cost 13).
-\end{example}
-
-In either case, the note's text explanation attempts to include additional
-information about what locations are the source and destination of the
-coercion.  Here are some example notes:
-\begin{example}
-  (IF (GRUE) X (SNOC))
-Note: Doing float to pointer coercion (cost 13) from X.
-
-  (SETQ VAR X)
-Note: Doing float to pointer coercion (cost 13) from X to VAR.
-\end{example}
-Note that the return value of a function is also a place to which coercions may
-have to be done:
-\begin{example}
-  (DEFUN F+ (X Y) (DECLARE (SINGLE-FLOAT X Y)) (+ X Y))
-Note: Doing float to pointer coercion (cost 13) to "<return value>".
-\end{example}
-Sometimes the compiler is unable to determine a name for the source or
-destination, in which case the source context is the only clue.
-
-
-\node Verbosity Control,  , Representation Efficiency Notes, Efficiency Notes
-\subsection{Verbosity Control}
-\cpsubindex{verbosity}{of efficiency notes}
-\cpsubindex{efficiency notes}{verbosity}
-
-These variables control the verbosity of efficiency notes:
-
-\defvar{efficiency-note-cost-threshold}
-Before printing some efficiency notes, the compiler compares the value of this
-variable to the difference in cost between the chosen implementation and the
-best potential implementation.  If the difference is not greater than this
-limit, then no note is printed.  The units are implementation dependent; 
-the initial value suppresses notes about "trivial" inefficiencies.  A value of
-\code{1} will note any inefficiency.
-\enddefvar
-
-\defvar{efficiency-note-limit}
-When printing some efficiency notes, the compiler reports possible efficient
-implementations.  The initial value of \code{2} prevents excessively long
-efficiency notes in the common case where there is no type information, so all
-implementations are possible.
-\enddefvar
-
-
-\node Profiling,  , Efficiency Notes, Advanced Compiler Use and Efficiency Hints
-\section{Profiling}
-
-\cindex{profiling}
-\cindex{timing}
-\cindex{consing}
-\cindex{tuning}
-\label{profiling}
-
-The first step in improving a program's performance is to profile the activity
-of the program to find where it spends its time.  The best way to do this is to
-use the profiling utility found in the \code{profile} package.  This package
-provides a macro \code{profile} that encapsulates functions with statistics
-gathering code.  
-
-\begin{menu}
-* Profile Interface::           
-* Profiling Techniques::        
-* Nested or Recursive Calls::   
-* Clock resolution::            
-* Profiling overhead::          
-* Additional Timing Utilities::  
-* A Note on Timing::            
-* Benchmarking Techniques::     
-\end{menu}
-
-\node Profile Interface, Profiling Techniques, Profiling, Profiling
-\subsection{Profile Interface}
-
-\defvar{timed-functions}
-This variable holds a list of all functions that are currently being profiled.
-\enddefvar
-
-\defmac{profile}{ \args{\mstar{\var{name}}}}
-This macro wraps profiling code around the named functions.  As in \code{trace},
-the \var{name}s are not evaluated.  If a function is already profiled, then the
-function is unprofiled and reprofiled (useful to notice function redefinition.)
-A warning is printed for each name that is not a defined function.
-\enddefmac
-
-\defmac{unprofile}{ \args{\mstar{\var{name}}}}
-This macro removes profiling code from the named functions.  If no \var{name}s
-are supplied, all currently profiled functions are unprofiled.
-\enddefmac
-
-
-\defmac{report-time}{ \args{\mstar{\var{name}}}}
-This macro prints a report for each \var{name}d function of the following
-information:
-\begin{itemize}
-\item The total CPU time used in that function for all calls,
-
-\item the total number of bytes consed in that function for all calls,
-
-\item the total number of calls,
-
-\item the average amount of CPU time per call.
-\end{itemize}
-Summary totals of the CPU time, consing and calls columns are printed.  An
-estimate of the profiling overhead is also printed (see below).  If no
-\var{name}s are supplied, then the times for all currently profiled functions are
-printed.
-\enddefmac
-
-\defmac{reset-time}{ \args{\mstar{\var{name}}}}
-This macro resets the profiling counters associated with the \var{name}d
-functions.  If no \var{name}s are supplied, then all currently profiled functions
-are reset.
-\enddefmac
-
-
-\node Profiling Techniques, Nested or Recursive Calls, Profile Interface, Profiling
-\subsection{Profiling Techniques}
-
-Start by profiling big pieces of a program, then carefully choose which
-functions close to, but not in, the inner loop are to be profiled next.
-Avoid profiling functions that are called by other profiled functions, since
-this opens the possibility of profiling overhead being included in the reported
-times.
-
-If the per-call time reported is less than 1/10 second, then consider the clock
-resolution and profiling overhead before you believe the time.  It may be that
-you will need to run your program many times in order to average out to a
-higher resolution.
-
-
-\node Nested or Recursive Calls, Clock resolution, Profiling Techniques, Profiling
-\subsection{Nested or Recursive Calls}
-
-The profiler attempts to compensate for nested or recursive calls.  Time and
-consing overhead will be charged to the dynamically innermost (most recent)
-call to a profiled function.  So profiling a subfunction of a profiled function
-will cause the reported time for the outer function to decrease.  However if an
-inner function has a large number of calls, some of the profiling overhead may
-"leak" into the reported time for the outer function.  In general, be wary of
-profiling short functions that are called many times.
-
-\node Clock resolution, Profiling overhead, Nested or Recursive Calls, Profiling
-\subsection{Clock resolution}
-
-Unless you are very lucky, the length of your machine's clock "tick" is
-probably much longer than the time it takes simple function to run.  For
-example, on the IBM RT, the clock resolution is 1/50 second.  This means that
-if a function is only called a few times, then only the first couple decimal
-places are really meaningful.  
-
-Note however, that if a function is called many times, then the statistical
-averaging across all calls should result in increased resolution.  For example,
-on the IBM RT, if a function is called a thousand times, then a resolution of
-tens of microseconds can be expected.
-
-\node Profiling overhead, Additional Timing Utilities, Clock resolution, Profiling
-\subsection{Profiling overhead}
-
-The added profiling code takes time to run every time that the profiled
-function is called, which can disrupt the attempt to collect timing
-information.  In order to avoid serious inflation of the times for functions
-that take little time to run, an estimate of the overhead due to profiling is
-subtracted from the times reported for each function.
-
-Although this correction works fairly well, it is not totally accurate,
-resulting in times that become increasingly meaningless for functions with
-short runtimes.  This is only a concern when the estimated profiling overhead
-is many times larger than reported total CPU time.
-
-The estimated profiling overhead is not represented in the reported total CPU
-time.  The sum of total CPU time and the estimated profiling overhead should be
-close to the total CPU time for the entire profiling run (as determined by the
-\code{time} macro.)  Time unaccounted for is probably being used by functions that
-you forgot to profile.
-
-\node Additional Timing Utilities, A Note on Timing, Profiling overhead, Profiling
-\subsection{Additional Timing Utilities}
-
-\defmac{time}{ \args{\var{form}}}
-This macro evaluates \var{form}, prints some timing and memory allocation
-information to \code{*trace-output*}, and returns any values that \var{form}
-returns.  The timing information includes real time, user run time, and system
-run time.    This macro executes a form and reports the time and consing
-overhead.  If the \code{time} form is not compiled (e.g. it was typed at
-top-level), then \code{compile} will be called on the form to give more accurate
-timing information.  If you really want to time interpreted speed, you can say:
-\begin{lisp}
-(time (eval '\var{form}))
-\end{lisp}
-Things that execute fairly quickly should be timed more than once, since there
-may be more paging overhead in the first timing.  To increase the accuracy of
-very short times, you can time multiple evaluations:
-\begin{lisp}
-(time (dotimes (i 100) \var{form}))
-\end{lisp}
-\enddefmac
-
-\defun{get-bytes-consed}[extensions]{}
-This function returns the number of bytes allocated since the first time you
-called it.  The first time it is called it returns zero.  The above profiling
-routines use this to report consing information.
-\enddefun
-
-\defvar{gc-run-time}[extensions]
-This variable accumulates the run-time consumed by garbage
-collection, in the units returned by \findexed{get-internal-run-time}.
-\enddefvar
-
-\defconst{internal-time-units-per-second}
-The value of internal-time-units-per-second is 100.
-\enddefconst
-
-\node A Note on Timing, Benchmarking Techniques, Additional Timing Utilities, Profiling
-\subsection{A Note on Timing}
-\cpsubindex{CPU time}{interpretation of}
-\cpsubindex{run time}{interpretation of}
-\cindex{interpretation of run time}
-
-There are two general kinds of timing information provided by the \code{time}
-macro and other profiling utilities: real time and run time.  Real time is
-elapsed, wall clock time.  It will be affected in a fairly obvious way by any
-other activity on the machine.  The more other processes contending for CPU
-and memory, the more real time will increase.  This means that real time
-measurements are difficult to replicate, though this is less true on a
-dedicated workstation.  The advantage of real time is that it is real.  It
-tells you really how long the program took to run under the benchmarking
-conditions.  The problem is that you don't know exactly what those conditions
-were.
-
-Run time is the amount of time that the processor supposedly spent running the
-program, as opposed to waiting for I/O or running other processes.  "User run
-time" and "system run time" are numbers reported by the Unix kernel.  They are
-supposed to be a measure of how much time the processor spent running your
-"user" program (which will include GC overhead, etc.), and the amount of time
-that the kernel spent running "on your behalf".
-
-Ideally, user time should be totally unaffected by benchmarking
-conditions; in reality user time does depend on other system activity,
-though in rather non-obvious ways.
-
-System time will clearly depend on benchmarking conditions.  In Lisp
-benchmarking, paging activity increases system run time (but not by as much
-as it increases real time, since the kernel spends some time waiting for
-the disk, and this is not run time, kernel or otherwise.)
-
-In my experience, the biggest trap in interpreting kernel/user run time is
-to look only at user time.  In reality, it seems that the \var{sum} of kernel
-and user time is more reproducible.  The problem is that as system activity
-increases, there is a spurious \var{decrease} in user run time.  In effect, as
-paging, etc., increases, user time leaks into system time.
-
-So, in practice, the only way to get truly reproducible results is to run
-with the same competing activity on the system.  Try to run on a machine
-with nobody else logged in, and check with "ps aux" to see if there are any
-system processes munching large amounts of CPU or memory.  If the ratio
-between real time and the sum of user and system time varies much between
-runs, then you have a problem.
-
-\node Benchmarking Techniques,  , A Note on Timing, Profiling
-\subsection{Benchmarking Techniques}
-\cindex{benchmarking techniques}
-
-Given these imperfect timing tools, how do should you do benchmarking?  The
-answer depends on whether you are trying to measure improvements in the
-performance of a single program on the same hardware, or if you are trying to
-compare the performance of different programs and/or different hardware.
-
-For the first use (measuring the effect of program modifications with
-constant hardware), you should look at \var{both} system+user and real time to
-understand what effect the change had on CPU use, and on I/O (including
-paging.)  If you are working on a CPU intensive program, the change in
-system+user time will give you a moderately reproducible measure of
-performance across a fairly wide range of system conditions.  For a CPU
-intensive program, you can think of system+user as "how long it would have
-taken to run if I had my own machine."  So in the case of comparing CPU
-intensive programs, system+user time is relatively real, and reasonable to
-use.
-
-For programs that spend a substantial amount of their time paging, you
-really can't predict elapsed time under a given operating condition without
-benchmarking in that condition.  User or system+user time may be fairly
-reproducible, but it is also relatively meaningless, since in a paging or
-I/O intensive program, the program is spending its time waiting, not
-running, and system time and user time are both measures of run time.
-A change that reduces run time might increase real time by increasing
-paging.
-
-Another common use for benchmarking is comparing the performance of the same
-program on different hardware.  You want to know which machine to run your
-program on.  For comparing different machines (operating systems, etc.), the
-only way to compare that makes sense is to set up the machines in \var{exactly}
-the way that they will \var{normally} be run, and then measure \var{real} time.  If
-the program will normally be run along with X, then run X.  If the program will
-normally be run on a dedicated workstation, then be sure nobody else is on the
-benchmarking machine.  If the program will normally be run on a machine with
-three other Lisp jobs, then run three other Lisp jobs.  If the program will
-normally be run on a machine with 8meg of memory, then run with 8meg.  Here,
-"normal" means "normal for that machine".  If you the choice of an unloaded RT
-or a heavily loaded PMAX, do your benchmarking on an unloaded RT and a heavily
-loaded PMAX.
-
-If you have a program you believe to be CPU intensive, then you might be
-tempted to compare "run" times across systems, hoping to get a meaningful
-result even if the benchmarking isn't done under the expected running
-condition.  Don't to this, for two reasons:
-\begin{itemize}
-
-\item
-The operating systems might not compute run time in the same way.
-
-\item
-Under the real running condition, the program might not be CPU
-intensive after all.
-\end{itemize}
-
-
-In the end, only real time means anything \dash{} it is the amount of time you
-have to wait for the result.  The only valid uses for run time are:
-\begin{itemize}
-
-\item
-To develop insight into the program.  For example, if run time is much less
-than elapsed time, then you are probably spending lots of time paging.
-
-\item
-To evaluate the relative performance of CPU intensive programs in the
-same environment.
-\end{itemize}
-
-
-\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/Unix.ms}
-
-
-
-\node UNIX Interface, Event Dispatching with SERVE-EVENT, Advanced Compiler Use and Efficiency Hints, Top
-\chapter{UNIX Interface}
-\label{unix-interface}
-\begin{center}
-\b{By Robert MacLachlan, Skef Wholey,}
-\end{center}
-\begin{center}
-\b{Bill Chiles, and William Lott}
-\end{center}
-
-CMU Common Lisp attempts to make the full power of the underlying
-environment available to the Lisp programmer.  This is done using
-combination of hand-coded interfaces and foreign function calls to C
-libraries.  Although the techniques differ, the style of interface is
-similar.  This chapter provides an overview of the facilities
-available and general rules for using them, as well as describing
-specific features in detail.  It is assumed that the reader has a
-working familiarity with Mach, Unix and X, as well as access to the
-standard system documentation.
-
-\begin{menu}
-* Reading the Command Line::    
-* Lisp Equivalents for C Routines::  
-* Type Translations::           
-* System Area Pointers::        
-* Unix System Calls::           
-* File Descriptor Streams::     
-* Making Sense of Mach Return Codes::  
-* Unix Interrupts::             
-\end{menu}
-
-
-\node Reading the Command Line, Useful Variables, UNIX Interface, UNIX Interface
-\section{Reading the Command Line}
-
-The shell parses the command line with which Lisp is invoked, and
-passes a data structure containing the parsed information to Lisp.
-This information is then extracted from that data structure and put
-into a set of Lisp data structures.
-
-\defvar{command-line-strings}[extensions]
-\defvarx{command-line-utility-name}[extensions]
-\defvarx{command-line-words}[extensions]
-\defvarx{command-line-switches}[extensions]
-The value of \code{*command-line-words*} is a list of strings that make up the
-command line, one word per string.  The first word on the command line, i.e.
-the name of the program invoked (usually \code{lisp}) is stored in
-\code{*command-line-utility-name*}.  The value of \code{*command-line-switches*} is a
-list of \code{command-line-switch} structures, with a structure for each word on
-the command line starting with a hyphen.  All the command line words between
-the program name and the first switch are stored in \code{*command-line-words*}.
-\enddefvar
-
-The following functions may be used to examine \code{command-line-switch}
-structures.
-\defun{cmd-switch-name}[extensions]{\args{\var{switch}}}
-Returns the name of the switch, less the preceding hyphen and trailing equal
-sign (if any).
-\enddefun
-\defun{cmd-switch-value}[extensions]{\args{\var{switch}}}
-Returns the value designated using an embedded equal sign, if any.  If the
-switch has no equal sign, then this is null.
-\enddefun
-\defun{cmd-switch-words}[extensions]{\args{\var{switch}}}
-Returns a list of the words between this switch and the next switch or the end
-of the command line.
-\enddefun
-
-
-\node Useful Variables, Lisp Equivalents for C Routines, Reading the Command Line, UNIX Interface
-
-\section{Useful Variables}
-
-\defvar{stdin}[system]
-\defvarx{stdout}[system]
-\defvarx{stderr}[system]
-Streams connected to the standard input, output and error file
-descriptors.
-\enddefvar
-
-\defvar{tty}[system]
-A stream connected to \file{/dev/tty}.
-\enddefvar
-
-\defvar{task-self}[system]
-\defvarx{task-data}[system]
-\defvarx{task-notify}[system]
-The initial ports for the Lisp process (Mach only.)
-\enddefvar
-
-
-\node Lisp Equivalents for C Routines, Type Translations, Useful Variables, UNIX Interface
-\section{Lisp Equivalents for C Routines}
-
-The UNIX documentation describes the system interface in terms of C
-procedure headers.  The corresponding Lisp function will have a somewhat
-different interface, since Lisp argument passing conventions and
-datatypes are different.
-
-The main difference in the argument passing conventions is that Lisp does not
-support passing values by reference.  In Lisp, all argument and results are
-passed by value.  Interface functions take some fixed number of arguments and
-return some fixed number of values.  A given "parameter" in the C
-specification will appear as an argument, return value, or both, depending on
-whether it is an In parameter, Out parameter, or In/Out parameter.  The basic
-transformation one makes to come up with the Lisp equivalent of a C routine is
-to remove the Out parameters from the call, and treat them as extra return
-values.  In/Out parameters appear both as arguments and return values.  Since
-Out and In/Out parameters are only conventions in C, you must determine the
-usage from the documentation.
-
-
-Thus, the C routine declared as
-\begin{example}
-kern_return_t lookup(servport, portsname, portsid)
-        port        servport;
-        char        *portsname;
-        int        *portsid;        /* out */
- {
-  ...
-  *portsid = <expression to compute portsid field>
-  return(KERN_SUCCESS);
- }
-\end{example}
-has as its Lisp equivalent something like
-\begin{lisp}
-(defun lookup (ServPort PortsName)
-  ...
-  (values
-   success
-   <expression to compute portsid field>))
-\end{lisp}
-If there are multiple out or in-out arguments, then there are multiple
-additional returns values.
-
-Fortunately, CMU Common Lisp programmers rarely have to worry about the
-nuances of this translation process, since the names of the arguments and
-return values are documented in a way so that the \code{describe} function
-(and the \Hemlock{} \code{Describe Function Call} command, invoked with
-\b{C-M-Shift-A}) will list this information.  Since the names of arguments
-and return values are usually descriptive, the information that
-\code{describe} prints is usually all one needs to write a
-call. Most programmers use this on-line documentation nearly
-all of the time, and thereby avoid the need to handle bulky
-manuals and perform the translation from barbarous tongues.
-
-\node Type Translations, System Area Pointers, Lisp Equivalents for C Routines, UNIX Interface
-\section{Type Translations}
-\cindex{aliens}
-\cpsubindex{types}{alien}
-\cpsubindex{types}{foreign language}
-
-Lisp data types have very different representations from those used by
-conventional languages such as C.  Since the system interfaces are
-designed for conventional languages, Lisp must translate objects to and
-from the Lisp representations.  Many simple objects have a direct
-translation: integers, characters, strings and floating point numbers
-are translated to the corresponding Lisp object.  A number of types,
-however, are implemented differently in Lisp for reasons of clarity and
-efficiency.
-
-Instances of enumerated types are expressed as keywords in Lisp.
-Records, arrays, and pointer types are implemented with the \Alien{}
-facility (see page \pageref{aliens}.)  Access functions are defined
-for these types which convert fields of records, elements of arrays,
-or data referenced by pointers into Lisp objects (possibly another
-object to be referenced with another access function).
-
-One should dispose of \Alien{} objects created by constructor
-functions or returned from remote procedure calls when they are no
-longer of any use, freeing the virtual memory associated with that
-object.  Since \alien{}s contain pointers to non-Lisp data, the
-garbage collector cannot do this itself.  If the memory
-was obtained from \funref{make-alien} or from a foreign function call
-to a routine that used \code{malloc}, then \funref{free-alien} should
-be used.    If the \alien{} was created
-using MACH memory allocation (e.g.  \code{vm_allocate}), then the
-storage should be freed using \code{vm_deallocate}.
-
-\node System Area Pointers, Unix System Calls, Type Translations, UNIX Interface
-\section{System Area Pointers}
-\label{system-area-pointers}
-
-\cindex{pointers}\cpsubindex{malloc}{C function}\cpsubindex{free}{C function}
-Note that in some cases an address is represented by a Lisp integer, and in
-other cases it is represented by a real pointer.  Pointers are usually used
-when an object in the current address space is being referred to.  The MACH
-virtual memory manipulation calls must use integers, since in principle the
-address could be in any process, and Lisp cannot abide random pointers.
-Because these types are represented differently in Lisp, one must explicitly
-coerce between these representations.
-
-System Area Pointers (SAPs) provide a mechanism that bypasses the \Alien{} type
-system and accesses virtual memory directly.  A SAP is a raw byte pointer into
-the \code{lisp} process address space.  SAPs are represented with a pointer
-descriptor, so SAP creation can cause consing.  However, the compiler uses
-a non-descriptor representation for SAPs when possible, so the consing
-overhead is generally minimal.  \xlref{non-descriptor}.
-
-\defun{sap-int}[system]{\args{\var{sap}}}
-\defunx{int-sap}[system]{\args{\var{int}}}
-The function \code{sap-int} is used to generate an integer corresponding to the
-system area pointer, suitable for passing to the kernel interfaces (which want
-all addresses specified as integers).  The function \code{int-sap} is used to do
-the opposite conversion.  The integer representation of a SAP is the byte
-offset of the SAP from the start of the address space.
-\enddefun
-
-\defun{sap+}[system]{\args{\var{sap} \var{offset}}}
-This function adds a byte \var{offset} to \var{sap}, returning a new SAP.
-\enddefun
-
-\defun{sap-ref-8}[system]{\args{\var{sap} \var{offset}}}
-\defunx{sap-ref-16}[system]{\args{\var{sap} \var{offset}}}
-\defunx{sap-ref-32}[system]{\args{\var{sap} \var{offset}}}
-These functions return the 8, 16 or 32 bit unsigned integer at
-\var{offset} from \var{sap}.  The \var{offset} is always a byte
-offset, regardless of the number of bits accessed.  \code{setf} may
-be used with the these functions to deposit values into virtual
-memory.
-\enddefun
-
-\defun{signed-sap-ref-8}[system]{\args{\var{sap} \var{offset}}}
-\defunx{signed-sap-ref-16}[system]{\args{\var{sap} \var{offset}}}
-\defunx{signed-sap-ref-32}[system]{\args{\var{sap} \var{offset}}}
-These functions are the same as the above unsigned operations, except
-that they sign-extend, returning a negative number if the high bit is
-set.
-\enddefun
-
-\node Unix System Calls, File Descriptor Streams, System Area Pointers, UNIX Interface
-\section{Unix System Calls}
-
-You probably won't have much cause to use them, but all the Unix system
-calls are available.  The Unix system call functions are in the
-\code{Unix} package.  The name of the interface for a particular system
-call is the name of the system call prepended with \code{unix-}.  The
-system usually defines the associated constants without any prefix name.
-To find out how to use a particular system call, try using
-\code{describe} on it.  If that is unhelpful, look at the source in
-\file{syscall.lisp} or consult your system maintainer.
-
-The Unix system calls indicate an error by returning \false{} as the
-first value and the Unix error number as the second value.  If the call
-succeeds, then the first value will always be non-\nil, often \code{t}.
-
-\defun{get-unix-error-msg}[Unix]{\args{\var{error}}}
-This function returns a string describing the Unix error number \var{error}.
-\enddefun
-
-\node File Descriptor Streams, Making Sense of Mach Return Codes, Unix System Calls, UNIX Interface
-\section{File Descriptor Streams}
-
-Many of the UNIX system calls return file descriptors.  Instead of using other
-UNIX system calls to perform I/O on them, you can create a stream around them.
-For this purpose, fd-streams exist.
-
-\defun{make-fd-stream}[system]{\args{\var{descriptor}}
-         \keys{:input :output :element-type}
-        \morekeys{:buffering :name :file :original}
-        \yetmorekeys{:delete-original :auto-close}
-        \yetmorekeys{:timeout}}
-
-This function creates a file descriptor stream using \var{descriptor}.
-If \var{input} is non-\nil, input operations are allowed.  If
-\var{output} is non-\nil, output operations are allowed.  The default is
-input only.  These keywords are defined:
-\begin{description}
-\item[\var{element-type}] is the type of the unit of transaction for the
-stream, which defaults to \code{string-char}.  See the Common Lisp
-description of \code{open} for valid values.
-
-\item[\var{buffering}] is the kind of output buffering desired for the stream.
-Legal values are \kwd{none} for no buffering, \kwd{line} for buffering up to
-each newline, and \kwd{full} for full buffering.
-
-\item[\var{name}] is a simple-string name to use for descriptive
-purposes when the system prints an fd-stream.  When printing fd-streams,
-the system prepends the streams name with \code{Stream for }.  If
-\var{name} is unspecified, it defaults to a string containing \var{file}
-or \var{descriptor}, in order of preference.
-
-\item[\var{file}, \var{original}]: \var{file} specifies the name of the
-associated file when creating a file stream (must be a
-\code{simple-string}). \var{original} is the \code{simple-string} name
-of a backup file containing the original contents of \var{file} while
-writing \var{file}.
-
-When you abort the stream by passing \true{} to
-\code{close} as the second argument, if you supplied both \var{file} and
-\var{original}, \code{close} will rename the \var{original} name to the
-\var{file} name.  When you \code{close} the stream normally, if you supplied
-\var{original}, and \var{delete-original} is non-\nil, \code{close}
-deletes \var{original}.  If \var{auto-close} is true (the default), then
-\var{descriptor} will be closed when the stream is garbage collected.
-
-\item[\var{timeout}] if non-null, then \var{timeout} is an integer
-number of seconds after which an input wait should time out.  If a read
-does time out, then the \code{system:io-timeout} condition is signalled.
-\end{description}
-\enddefun
-
-\defun{fd-stream-p}[system]{\args{\var{object}}}
-This function returns \true{} if \var{object} is an fd-stream, and \nil{} if not.
-\enddefun
-
-\defun{fd-stream-fd}[system]{\args{\var{stream}}}
-This returns the file descriptor associated with \var{stream}.
-\enddefun
-
-
-\node Making Sense of Mach Return Codes, Unix Interrupts, File Descriptor Streams, UNIX Interface
-\section{Making Sense of Mach Return Codes}
-
-Whenever a remote procedure call returns a Unix error code (such as
-\code{kern_return_t}), it is usually prudent to check that code to see if the call
-was successful.  To relieve the programmer of the hassle of testing this value
-himself, and to centralize the information about the meaning of non-success
-return codes, CMU Common Lisp provides a number of macros and functions.
-See also \funref{get-unix-error-msg}.
-
-\defun{gr-error}[system]{
-        \args{\var{function} \var{gr} \&optional{} \var{context}}}
-Signals a Lisp error, printing a message indicating that the call to the
-specified \var{function} failed, with the return code \var{gr}.  If supplied, the
-\var{context} string is printed after the \var{function} name and before the string
-associated with the \var{gr}.  For example:
-\begin{example}
-* (gr-error 'nukegarbage 3 "lost big")
-
-Error in function GR-ERROR:
-NUKEGARBAGE lost big, no space.
-Proceed cases:
-0: Return to Top-Level.
-Debug  (type H for help)
-(Signal #<Conditions:Simple-Error.5FDE0>)
-0] 
-\end{example}
-\enddefun
-
-\defmac{gr-call}[system]{\args{\var{function} \&rest{} \var{args}}}
-\defmacx{gr-call*}[system]{\args{\var{function} \&rest{} \var{args}}}
-These macros can be used to call a function and automatically check the
-GeneralReturn code and signal an appropriate error in case of non-successful
-return.  \code{gr-call} returns \false{} if no error occurs, while \code{gr-call*}
-returns the second value of the function called.
-\begin{example}
-* (gr-call mach:port_allocate *task-self*)
-NIL
-* 
-\end{example}
-\enddefmac
-
-\defmac{gr-bind}[system]{
-        \args{\code{(}\mstar{\var{var}}\code{)} \code{(}\var{function} \mstar{\var{arg}}\code{)} \mstar{\var{form}}}}
-This macro can be used much like \code{multiple-value-bind} to bind the \var{var}s
-to return values resulting from calling the \var{function} with the given
-\var{arg}s.  The first return value is not bound to a variable, but is checked as a
-GeneralReturn code, as in \code{gr-call}.
-\begin{example}
-* (gr-bind (port_list port_list_cnt)
-           (mach:port_select *task-self*)
-    (format t "The port count is ~S." port_list_cnt)
-    port_list)
-The port count is 0.
-#<Alien value>
-* 
-\end{example}
-\enddefmac
-
-\node Unix Interrupts,  , Making Sense of Mach Return Codes, UNIX Interface
-\section{Unix Interrupts}
-
-\cindex{unix interrupts} \cindex{interrupts}
-CMU Common Lisp allows access to all the Unix signals that can be generated
-under Unix.  It should be noted that if this capability is abused, it is
-possible to completely destroy the running Lisp.  The following macros and
-functions allow access to the Unix interrupt system.  The signal names as
-specified in section 2 of the \i{Unix Programmer's Manual} are exported
-from the Unix package.
-
-\begin{menu}
-* Changing Interrupt Handlers::  
-* Examples of Signal Handlers::  
-\end{menu}
-
-\node Changing Interrupt Handlers, Examples of Signal Handlers, Unix Interrupts, Unix Interrupts
-\subsection{Changing Interrupt Handlers}
-\label{signal-handlers}
-
-\defmac{with-enabled-interrupts}[system]{
-        \args{\var{specs} \&rest{} \var{body}}} 
-
-This macro should be called with a list of signal specifications, \var{specs}.
-Each element of \var{specs} should be a list of two\hide{ or three} elements:
-the first should be the Unix signal for which a handler should be established,
-the second should be a function to be called when the signal is
-received\hide{, and
-the third should be an optional character used to generate the signal from the
-keyboard.  This last item is only useful for the SIGINT, SIGQUIT, and SIGTSTP
-signals.}  One or more signal handlers can be established in this way.
-\code{with-enabled-interrupts} establishes the correct signal handlers and then
-executes the forms in \var{body}.  The forms are executed in an unwind-protect so
-that the state of the signal handlers will be restored to what it was before
-the \code{with-enabled-interrupts} was entered.  A signal handler function
-specified as NIL will set the Unix signal handler to the default which is
-normally either to ignore the signal or to cause a core dump depending on the
-particular signal.
-\enddefmac
-
-\defmac{without-interrupts}[system]{\args{\&rest{} \var{body}}}
-It is sometimes necessary to execute a piece a code that can not be
-interrupted.  This macro the forms in \var{body} with interrupts disabled.  Note
-that the Unix interrupts are not actually disabled, rather they are queued
-until after \var{body} has finished executing.
-\enddefmac
-
-\defmac{with-interrupts}[system]{\args{\&rest{} \var{body}}}
-When executing an interrupt handler, the system disables interrupts, as if the
-handler was wrapped in in a \code{without-interrupts}.  The macro
-\code{with-interrupts} can be used to enable interrupts while the forms in
-\var{body} are evaluated.  This is useful if \var{body} is going to enter a break
-loop or do some long computation that might need to be interrupted.
-\enddefmac
-
-\defmac{without-hemlock}[system]{\args{\&rest{} \var{body}}}
-For some interrupts, such as SIGTSTP (suspend the Lisp process and return
-to the Unix shell) it is necessary to leave Hemlock and then return to it.
-This macro executes the forms in \var{body} after exiting Hemlock.  When
-\var{body} has been executed, control is returned to Hemlock.
-\enddefmac
-
-\defun{enable-interrupt}[system]{
-       \args{\var{signal} \var{function}\hide{ \&optional{} \var{character}}}} 
-
-This function establishes \var{function} as the handler for \var{signal}.
-\hide{The optional \var{character} can be specified for the SIGINT, SIGQUIT,
-and SIGTSTP signals and causes that character to generate the appropriate
-signal from the keyboard.}  Unless you want to establish a global signal
-handler, you should use the macro \code{with-enabled-interrupts} to temporarily
-establish a signal handler.  \hide{Without \var{character},}
-\code{enable-interrupt} returns the old function associated with the signal.
-\hide{When \var{character} is specified for SIGINT, SIGQUIT, or SIGTSTP, it
-returns the old character code.}
-\enddefun
-
-\defun{ignore-interrupt}[system]{\args{\var{signal}}}
-Ignore-interrupt sets the Unix signal mechanism to ignore \var{signal}
-which means that the Lisp process will never see the signal.
-Ignore-interrupt returns the old function associated with the signal or \false{}
-if none is currently defined.
-\enddefun
-
-\defun{default-interrupt}[system]{\args{\var{signal}}}
-Default-interrupt can be used to tell the Unix signal mechanism to perform
-the default action for \var{signal}.  For details on what the default action
-for a signal is, see section 2 of the \i{Unix Programmer's Manual}.  In
-general, it is likely to ignore the signal or to cause a core dump.
-\enddefun
-
-\node Examples of Signal Handlers,  , Changing Interrupt Handlers, Unix Interrupts
-\subsection{Examples of Signal Handlers}
-
-The following code is the signal handler used by the Lisp system for the
-SIGINT signal.
-\begin{lisp}
-(defun ih-sigint (signal code scp)
-  (declare (ignore signal code scp))
-  (without-hemlock
-   (with-interrupts
-    (break "Software Interrupt" t))))
-\end{lisp}
-The \code{without-hemlock} form is used to make sure that Hemlock is exited before
-a break loop is entered.  The \code{with-interrupts} form is used to enable
-interrupts because the user may want to generate an interrupt while in the
-break loop.  Finally, break is called to enter a break loop, so the user
-can look at the current state of the computation.  If the user proceeds
-from the break loop, the computation will be restarted from where it was
-interrupted.
-
-The following function is the Lisp signal handler for the SIGTSTP signal
-which suspends a process and returns to the Unix shell.
-\begin{lisp}
-(defun ih-sigtstp (signal code scp)
-  (declare (ignore signal code scp))
-  (without-hemlock
-   (Unix:unix-kill (Unix:unix-getpid) Unix:sigstop)))
-\end{lisp}
-Lisp uses this interrupt handler to catch the SIGTSTP signal because it is
-necessary to get out of Hemlock in a clean way before returning to the shell.
-
-To set up these interrupt handlers, the following is recommended:
-\begin{lisp}
-(with-enabled-interrupts ((Unix:SIGINT #'ih-sigint)
-                          (Unix:SIGTSTP #'ih-sigtstp))
-  <user code to execute with the above signal handlers enabled.>
-)
-\end{lisp}
-
-
-\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/server.ms}
-
-\node Event Dispatching with SERVE-EVENT, Alien Objects, UNIX Interface, Top
-\chapter{Event Dispatching with SERVE-EVENT}
-\begin{center}
-\b{By Bill Chiles and Robert MacLachlan}
-\end{center}
-
-It is common to have multiple activities simultaneously operating in the same
-Lisp process.  Furthermore, Lisp programmers tend to expect a flexible
-development environment.  It must be possible to load and modify application
-programs without requiring modifications to other running programs.  CMU Common
-Lisp achieves this by having a central scheduling mechanism based on an
-event-driven, object-oriented paradigm.
-
-An \var{event} is some interesting happening that should cause the Lisp process
-to wake up and do something.  These events include X events and activity on
-Unix file descriptors.  The object-oriented mechanism is only available with
-the first two, and it is optional with X events as described later in this
-chapter.  In an X event, the window ID is the object capability and the X event
-type is the operation code.  The Unix file descriptor input mechanism simply
-consists of an association list of a handler to call when input shows up on a
-particular file descriptor.
-
-
-\begin{menu}
-* Object Sets::                 
-* The SERVE-EVENT Function::    
-* Using SERVE-EVENT with Unix File Descriptors::  
-* Using SERVE-EVENT with the CLX Interface to X::  
-* A SERVE-EVENT Example::       
-\end{menu}
-
-\node Object Sets, The SERVE-EVENT Function, Event Dispatching with SERVE-EVENT, Event Dispatching with SERVE-EVENT
-\section{Object Sets}
-\label{object-sets}
-\cindex{object sets}
-An \i{object set} is a collection of objects that have the same implementation
-for each operation.  Externally the object is represented by the object
-capability and the operation is represented by the operation code.  Within
-Lisp, the object is represented by an arbitrary Lisp object, and the
-implementation for the operation is represented by an arbitrary Lisp function.
-The object set mechanism maintains this translation from the external to the
-internal representation.
-
-\defun{make-object-set}[system]{
-        \args{\var{name} \&optional{} \var{default-handler}}}
- This function makes a new object set.  \var{Name} is a string used
-only for purposes of identifying the object set when it is printed.
-\var{Default-handler} is the function used as a handler when an
-undefined operation occurs on an object in the set.  You can define
-operations with the \code{serve-}\var{operation} functions exported
-the \code{extensions} package for X events
-(\pxlref{x-serve-mumbles}).  Objects are added with
-\code{system:add-xwindow-object}.  Initially the object set has no
-objects and no defined operations.
-\enddefun
-
-\defun{object-set-operation}[system]{
-        \args{\var{object-set} \var{operation-code}}}
-
- This function returns the handler function that is the
-implementation of the operation corresponding to \var{operation-code}
-in \var{object-set}.  When set with \code{setf}, the setter function
-establishes the new handler.  The \code{serve-}\var{operation}
-functions exported from the \code{extensions} package for X events
-(\pxlref{x-serve-mumbles}) call this on behalf of the user when
-announcing a new operation for an object set.
-\enddefun
-
-\defun{add-xwindow-object}[system]{
-        \args{\var{window} \var{object} \var{object-set}}}
-These functions add \var{port} or \var{window} to \var{object-set}.  \var{Object} is
-an arbitrary Lisp object that is associated with the \var{port} or \var{window}
-capability.  \var{Window} is a CLX window.  When an event occurs,
-\code{system:serve-event} passes \var{object} as an argument to the handler
-function.
-\enddefun
-
-
-\node The SERVE-EVENT Function, Using SERVE-EVENT with Unix File Descriptors, Object Sets, Event Dispatching with SERVE-EVENT
-\section{The SERVE-EVENT Function}
-
-The \code{system:serve-event} function is the standard way for an application
-to wait for something to happen.  For example, the Lisp system calls
-\code{system:serve-event} when it wants input from X or a terminal stream.
-The idea behind \code{system:serve-event} is that it knows the appropriate
-action to take when any interesting event happens.  If an application calls
-\code{system:serve-event} when it is idle, then any other applications with
-pending events can run.  This allows several applications to run "at the
-same time" without interference, even though there is only one thread of
-control.  Note that if an application is waiting for input of any kind,
-then other applications will get events.
-
-\defun{serve-event}[system]{\args{\&optional{} \var{timeout}}}
-This function waits for an event to happen and then dispatches to the
-correct handler function.  If specified, \var{timeout} is the number of
-seconds to wait before timing out.  A time out of zero seconds is legal and
-causes \code{system:serve-event} to poll for any events immediately available
-for processing.  \code{system:serve-event} returns \true{} if it serviced at
-least one event, and \nil{} otherwise.  Depending on the application, when
-\code{system:serve-event} returns \true, you might want to call it repeatedly
-with a timeout of zero until it returns \nil.
-
-If input is available on any designated file descriptor, then this calls the
-appropriate handler function supplied by \code{system:add-fd-handler}.
-
-Since events for many different applications may arrive
-simultaneously, an application waiting for a specific event
-must loop on \code{system:serve-event} until the desired event
-happens.  Since programs such as \hemlock{} call
-\code{system:serve-event} for input, applications usually do
-not need to call \code{system:serve-event} at all; \hemlock{}
-allows other application's handlers to run when it goes into an
-input wait.
-\enddefun
-
-\defun{serve-all-events}[system]{\args{\&optional{} \var{timeout}}}
-This function is similar to \code{system:serve-event}, except it serves all
-the pending events rather than just one.  It returns \true{} if it serviced
-at least one event, and \nil{} otherwise.
-\enddefun
-
-
-\node Using SERVE-EVENT with Unix File Descriptors, Using SERVE-EVENT with the CLX Interface to X, The SERVE-EVENT Function, Event Dispatching with SERVE-EVENT
-\section{Using SERVE-EVENT with Unix File Descriptors}
-Object sets are not available for use with file descriptors, as there are
-only two operations possible on file descriptors: input and output.
-Instead, a handler for either input or output can be registered with
-\code{system:serve-event} for a specific file descriptor.  Whenever any input
-shows up, or output is possible on this file descriptor, the function
-associated with the handler for that descriptor is funcalled with the
-descriptor as it's single argument.
-
-\defun{add-fd-handler}[system]{\args{\i{fd direction function}}}
-This function installs and returns a new handler for the file descriptor
-\var{fd}.  \var{Direction} can be either \kwd{input} if the system should invoke
-the handler when input is available or \kwd{output} if the system should invoke
-the handler when output is possible.  This returns a unique object representing
-the handler, and this is a suitable argument for \code{system:remove-fd-handler}
-\var{Function} must take one argument, the file descriptor.
-\enddefun
-
-\defun{remove-fd-handler}[system]{\args{\var{handler}}}
-This function removes \var{handler}, that \code{add-fd-handler} must have previously
-returned.
-\enddefun
-
-\defmac{with-fd-handler}[system]{
-        \args{(\i{direction fd function}) \mstar{\var{form}}}}
- This macro executes the supplied forms with a handler installed using \var{fd},
-\var{direction}, and \var{function}.  See \code{system:add-fd-handler}.
-\enddefmac
-
-\defun{wait-until-fd-usable}[system]{
-        \args{\i{direction fd} \&optional{} \var{timeout}}}
- This function waits for up to \var{timeout} seconds for \var{fd} to become usable
-for \var{direction} (either \kwd{input} or \kwd{output}).  If \var{timeout} is \nil{}
-or unspecified, this waits forever.
-\enddefun
-
-\defun{invalidate-descriptor}[system]{\args{\var{fd}}}
-This function removes all handlers associated with \var{fd}.  This should only be
-used in drastic cases (such as I/O errors, but not necessarily EOF).  Normally,
-you should use \code{remove-fd-handler} to remove the specific handler.
-\enddefun
-
-\begin{ignore}
-
-section{Using SERVE-EVENT with Matchmaker Interfaces}
-\label{ipc-serve-mumbles}
-Remember from section \ref{object-sets}, an object set is a collection of
-objects, ports in this case, with some set of operations, message ID's, with
-corresponding implementations, the same handler functions.
-
-Matchmaker uses the object set operations to implement servers.  For each
-server interface \i{XXX}, Matchmaker defines a function, \code{serve-}\i{XXX}, of
-two arguments, an object set and a function.  The \code{serve-}\i{XXX} function
-establishes the function as the implementation of the \i{XXX} operation in the
-object set.  Recall from section \ref{object-sets}, \code{system:add-port-object}
-associates some Lisp object with a port in an object set.  When
-\code{system:serve-event} notices activity on a port, it calls the function given
-to \code{serve-}\i{XXX} with the object given to \code{system:add-port-object} and
-the input parameters specified in the message definition.  The return values
-from the function are used as the output parameters for the message, if any.
-\code{serve-}\i{XXX} functions are also generated for each \i{server message} and
-asynchronous user interface.
-
-To use a Lisp server:
-\begin{itemize}
-
-\item
-Create an object set.
-
-\item
-Define some operations on it using the \code{serve-}\i{XXX} functions.
-
-\item
-Create an object for every port on which you receive requests.
-
-\item
-Call \code{system:serve-event} to service an RPC request.
-\end{itemize}
-
-
-Object sets allow many servers in the same Lisp to operate without knowing
-about each other.  There can be multiple implementations of the same interface
-with different operation handlers established in distinct object sets.  This
-property is especially useful when handling emergency messages.
-
-\end{ignore}
-
-\node Using SERVE-EVENT with the CLX Interface to X, A SERVE-EVENT Example, Using SERVE-EVENT with Unix File Descriptors, Event Dispatching with SERVE-EVENT
-\section{Using SERVE-EVENT with the CLX Interface to X}
-\label{x-serve-mumbles}
-Remember from section \ref{object-sets}, an object set is a collection of
-objects, CLX windows in this case, with some set of operations, event keywords,
-with corresponding implementations, the same handler functions.  Since X allows
-multiple display connections from a given process, you can avoid using object
-sets if every window in an application or display connection behaves the same.
-If a particular X application on a single display connection has windows that
-want to handle certain events differently, then using object sets is a
-convenient way to organize this since you need some way to map the window/event
-combination to the appropriate functionality.
-
-The following is a discussion of functions exported from the \code{extensions}
-package that facilitate handling CLX events through \code{system:serve-event}.
-The first two routines are useful regardless of whether you use
-\code{system:serve-event}:
-\defun{open-clx-display}[ext]{
-       \args{\&optional{} \var{string}}}
- This function parses \var{string} for an X display specification including
-display and screen numbers.  \var{String} defaults to the following:
-\begin{verbatim}
-(cdr (assoc :display ext:*environment-list* :test #'eq))
-\end{verbatim}
-If any field in the display specification is missing, this signals an error.
-\code{ext:open-clx-display} returns the CLX display and screen.
-\enddefun
-
-\defun{flush-display-events}[ext]{\args{\var{display}}}
-This function flushes all the events in \var{display}'s event queue including the
-current event, in case the user calls this from within an event handler.
-\enddefun
-
-
-\begin{menu}
-* Without Object Sets::         
-* With Object Sets::            
-\end{menu}
-
-\node Without Object Sets, With Object Sets, Using SERVE-EVENT with the CLX Interface to X, Using SERVE-EVENT with the CLX Interface to X
-\subsection{Without Object Sets}
-Since most applications that use CLX, can avoid the complexity of object sets,
-these routines are described in a separate section.  The routines described in
-the next section that use the object set mechanism are based on these
-interfaces.
-
-\defun{enable-clx-event-handling}[ext]{
-       \args{\var{display} \var{handler}}} 
- This function causes \code{system:serve-event} to notice when there is input
-on \var{display}'s connection to the X11 server.  When this happens,
-\code{system:serve-event} invokes \var{handler} on \var{display} in a dynamic
-context with an error handler bound that flushes all events from
-\var{display} and returns.  By returning, the error handler 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
-\code{system:serve-event} for input.  Calling this repeatedly on the same
-\var{display} establishes \var{handler} as a new handler, replacing any
-previous one for \var{display}.  \enddefun
-
-\defun{disable-clx-event-handling}[ext]{\args{\var{display}}}
-This function undoes the effect of \code{ext:enable-clx-event-handling}.
-\enddefun
-
-\defmac{with-clx-event-handling}[ext]{
-          \args{(\var{display} \var{handler}) \mstar{form}}}
- This macro evaluates each \var{form} in a context where
-\code{system:serve-event} invokes \var{handler} on \var{display} whenever there is
-input on \var{display}'s connection to the X server.  This destroys any
-previously established handler for \var{display}.
-\enddefmac
-
-
-\node With Object Sets,  , Without Object Sets, Using SERVE-EVENT with the CLX Interface to X
-\subsection{With Object Sets}
-This section discusses the use of object sets and \code{system:serve-event} to
-handle CLX events.  This is necessary when a single X application has distinct
-windows that want to handle the same events in different ways.  Basically, you
-need some way of asking for a given window which way you want to handle some
-event because this event is handled differently depending on the window.
-Object sets provide this feature.
-
-For each CLX event-key symbol-name \i{XXX} (for example, \var{key-press}), there
-is a function \code{serve-}\i{XXX} of two arguments, an object set and a function.
-The \code{serve-}\i{XXX} function establishes the function as the handler for the
-\kwd{XXX} event in the object set.  Recall from section \ref{object-sets},
-\code{system:add-xwindow-object} associates some Lisp object with a CLX window in
-an object set.  When \code{system:serve-event} notices activity on a window, it
-calls the function given to \code{ext:enable-clx-event-handling}.  If this
-function is \code{ext:object-set-event-handler}, it calls the function given to
-\code{serve-}\i{XXX}, passing the object given to \code{system:add-xwindow-object}
-and the event's slots as well as a couple other arguments described below.
-
-To use object sets in this way:
-\begin{itemize}
-
-\item
-Create an object set.
-
-\item
-Define some operations on it using the \code{serve-}\i{XXX} functions.
-
-\item
-Add an object for every window on which you receive requests.  This can be the
-CLX window itself or some structure more meaningful to your application.
-
-\item
-Call \code{system:serve-event} to service an X event.
-\end{itemize}
-
-
-\defun{object-set-event-handler}[ext]{\args{\var{display}}}
-This function is a suitable argument to \code{ext:enable-clx-event-handling}.  The
-actual event handlers defined for particular events within a given object set
-must take an argument for every slot in the appropriate event.  In addition to
-the event slots, \code{ext:object-set-event-handler} passes the following
-arguments: 
-\begin{itemize}
-
-\item
-The object, as established by \code{system:add-xwindow-object}, on which the event
-occurred.
-
-\item
-event-key, see \code{xlib:event-case}.
-
-\item
-send-event-p, see \code{xlib:event-case}.
-\end{itemize}
-
-Describing any \code{ext:serve-}\var{event-key-name} function, where
-\var{event-key-name} is an event-key symbol-name (for example,
-\code{ext:serve-key-press}), indicates exactly what all the arguments are in their
-correct order.
-
-\begin{ignore}
-\code{ext:object-set-event-handler} ignores \kwd{no-exposure}
-events on pixmaps, issuing a warning if one occurs.  It is only
-prepared to dispatch events for windows.
-\end{ignore}
-
-When creating an object set for use with \code{ext:object-set-event-handler},
-specify \code{ext:default-clx-event-handler} as the default handler for events in
-that object set.  If no default handler is specified, and the system invokes
-the default default handler, it will cause an error since this function takes
-arguments suitable for handling port messages.
-\enddefun
-
-
-\node A SERVE-EVENT Example,  , Using SERVE-EVENT with the CLX Interface to X, Event Dispatching with SERVE-EVENT
-\section{A SERVE-EVENT Example}
-This section contains two examples using \code{system:serve-event}.  The first
-one does not use object sets, and the second, slightly more complicated one
-does.
-
-
-\begin{menu}
-* Without Object Sets Example::  
-* With Object Sets Example::    
-\end{menu}
-
-\node Without Object Sets Example, With Object Sets Example, A SERVE-EVENT Example, A SERVE-EVENT Example
-\subsection{Without Object Sets Example}
-This example defines an input handler for a CLX display connection.  It only
-recognizes \kwd{key-press} events.  The body of the example loops over
-\code{system:serve-event} to get input.
-
-\begin{lisp}
-(in-package "SERVER-EXAMPLE")
-
-(defun my-input-handler (display)
-  (xlib:event-case (display :timeout 0)
-    (:key-press (event-window code state)
-     (format t "KEY-PRESSED (Window = ~D) = ~S.~%"
-                  (xlib:window-id event-window)
-             ;; See Hemlock Command Implementor's Manual for convenient
-             ;; input mapping function.
-             (ext:translate-character display code state))
-      ;; Make XLIB:EVENT-CASE discard the event.
-      t)))
-\end{lisp}
-\begin{lisp}
-(defun server-example ()
-  "An example of using the SYSTEM:SERVE-EVENT function and object sets to
-   handle CLX events."
-  (let* ((display (ext:open-clx-display))
-         (screen (display-default-screen display))
-         (black (screen-black-pixel screen))
-         (white (screen-white-pixel screen))
-         (window (create-window :parent (screen-root screen)
-                                :x 0 :y 0 :width 200 :height 200
-                                :background white :border black
-                                :border-width 2
-                                :event-mask
-                                (xlib:make-event-mask :key-press))))
-    ;; Wrap code in UNWIND-PROTECT, so we clean up after ourselves.
-    (unwind-protect
-        (progn
-          ;; Enable event handling on the display.
-          (ext:enable-clx-event-handling display #'my-input-handler)
-          ;; Map the windows to the screen.
-          (map-window window)
-          ;; Make sure we send all our requests.
-          (display-force-output display)
-          ;; Call serve-event for 100,000 events or immediate timeouts.
-          (dotimes (i 100000) (system:serve-event)))
-      ;; Disable event handling on this display.
-      (ext:disable-clx-event-handling display)
-      ;; Get rid of the window.
-      (destroy-window window)
-      ;; Pick off any events the X server has already queued for our
-      ;; windows, so we don't choke since SYSTEM:SERVE-EVENT is no longer
-      ;; prepared to handle events for us.
-      (loop
-       (unless (deleting-window-drop-event *display* window)
-        (return)))
-      ;; Close the display.
-      (xlib:close-display display))))
-
-(defun deleting-window-drop-event (display win)
-  "Check for any events on win.  If there is one, remove it from the
-   event queue and return t; otherwise, return nil."
-  (xlib:display-finish-output display)
-  (let ((result nil))
-    (xlib:process-event
-     display :timeout 0
-     :handler #'(lambda (&key event-window &allow-other-keys)
-                  (if (eq event-window win)
-                      (setf result t)
-                      nil)))
-    result))
-\end{lisp}
-
-
-\node With Object Sets Example,  , Without Object Sets Example, A SERVE-EVENT Example
-\subsection{With Object Sets Example}
-This example involves more work, but you get a little more for your effort.  It
-defines two objects, \code{input-box} and \code{slider}, and establishes a
-\kwd{key-press} handler for each object, \code{key-pressed} and
-\code{slider-pressed}.  We have two object sets because we handle events on the
-windows manifesting these objects differently, but the events come over the
-same display connection.
-
-\begin{lisp}
-(in-package "SERVER-EXAMPLE")
-
-(defstruct (input-box (:print-function print-input-box)
-                      (:constructor make-input-box (display window)))
-  "Our program knows about input-boxes, and it doesn't care how they
-   are implemented."
-  display        ; The CLX display on which my input-box is displayed.
-  window)        ; The CLX window in which the user types.
-;;;
-(defun print-input-box (object stream n)
-  (declare (ignore n))
-  (format stream "#<Input-Box ~S>" (input-box-display object)))
-
-(defvar *input-box-windows*
-        (system:make-object-set "Input Box Windows"
-                                #'ext:default-clx-event-handler))
-
-(defun key-pressed (input-box event-key event-window root child
-                    same-screen-p x y root-x root-y modifiers time
-                    key-code send-event-p)
-  "This is our :key-press event handler."
-  (declare (ignore event-key root child same-screen-p x y
-                   root-x root-y time send-event-p))
-  (format t "KEY-PRESSED (Window = ~D) = ~S.~%"
-          (xlib:window-id event-window)
-          ;; See Hemlock Command Implementor's Manual for convenient
-          ;; input mapping function.
-          (ext:translate-character (input-box-display input-box)
-                                     key-code modifiers)))
-;;;
-(ext:serve-key-press *input-box-windows* #'key-pressed)
-\end{lisp}
-\begin{lisp}
-(defstruct (slider (:print-function print-slider)
-                   (:include input-box)
-                   (:constructor %make-slider
-                                    (display window window-width max)))
-  "Our program knows about sliders too, and these provide input values
-   zero to max."
-  bits-per-value  ; bits per discrete value up to max.
-  max)            ; End value for slider.
-;;;
-(defun print-slider (object stream n)
-  (declare (ignore n))
-  (format stream "#<Slider ~S  0..~D>"
-          (input-box-display object)
-          (1- (slider-max object))))
-;;;
-(defun make-slider (display window max)
-  (%make-slider display window
-                  (truncate (xlib:drawable-width window) max)
-                max))
-
-(defvar *slider-windows*
-        (system:make-object-set "Slider Windows"
-                                #'ext:default-clx-event-handler))
-
-(defun slider-pressed (slider event-key event-window root child
-                       same-screen-p x y root-x root-y modifiers time
-                       key-code send-event-p)
-  "This is our :key-press event handler for sliders.  Probably this is
-   a mouse thing, but for simplicity here we take a character typed."
-  (declare (ignore event-key root child same-screen-p x y
-                   root-x root-y time send-event-p))
-  (format t "KEY-PRESSED (Window = ~D) = ~S  -->  ~D.~%"
-          (xlib:window-id event-window)
-          ;; See Hemlock Command Implementor's Manual for convenient
-          ;; input mapping function.
-          (ext:translate-character (input-box-display slider)
-                                     key-code modifiers)
-          (truncate x (slider-bits-per-value slider))))
-;;;
-(ext:serve-key-press *slider-windows* #'slider-pressed)
-\end{lisp}
-\begin{lisp}
-(defun server-example ()
-  "An example of using the SYSTEM:SERVE-EVENT function and object sets to
-   handle CLX events."
-  (let* ((display (ext:open-clx-display))
-         (screen (display-default-screen display))
-         (black (screen-black-pixel screen))
-         (white (screen-white-pixel screen))
-         (iwindow (create-window :parent (screen-root screen)
-                                 :x 0 :y 0 :width 200 :height 200
-                                 :background white :border black
-                                 :border-width 2
-                                 :event-mask
-                                 (xlib:make-event-mask :key-press)))
-         (swindow (create-window :parent (screen-root screen)
-                                 :x 0 :y 300 :width 200 :height 50
-                                 :background white :border black
-                                 :border-width 2
-                                 :event-mask
-                                 (xlib:make-event-mask :key-press)))
-         (input-box (make-input-box display iwindow))
-         (slider (make-slider display swindow 15)))
-    ;; Wrap code in UNWIND-PROTECT, so we clean up after ourselves.
-    (unwind-protect
-        (progn
-          ;; Enable event handling on the display.
-          (ext:enable-clx-event-handling display
-                                         #'ext:object-set-event-handler)
-          ;; Add the windows to the appropriate object sets.
-          (system:add-xwindow-object iwindow input-box
-                                       *input-box-windows*)
-          (system:add-xwindow-object swindow slider
-                                       *slider-windows*)
-          ;; Map the windows to the screen.
-          (map-window iwindow)
-          (map-window swindow)
-          ;; Make sure we send all our requests.
-          (display-force-output display)
-          ;; Call server for 100,000 events or immediate timeouts.
-          (dotimes (i 100000) (system:serve-event)))
-      ;; Disable event handling on this display.
-      (ext:disable-clx-event-handling display)
-      (delete-window iwindow display)
-      (delete-window swindow display)
-      ;; Close the display.
-      (xlib:close-display display))))
-\end{lisp}
-\begin{lisp}
-(defun delete-window (window display)
-  ;; Remove the windows from the object sets before destroying them.
-  (system:remove-xwindow-object window)
-  ;; Destroy the window.
-  (destroy-window window)
-  ;; Pick off any events the X server has already queued for our
-  ;; windows, so we don't choke since SYSTEM:SERVE-EVENT is no longer
-  ;; prepared to handle events for us.
-  (loop
-   (unless (deleting-window-drop-event display window)
-     (return))))
-
-(defun deleting-window-drop-event (display win)
-  "Check for any events on win.  If there is one, remove it from the
-   event queue and return t; otherwise, return nil."
-  (xlib:display-finish-output display)
-  (let ((result nil))
-    (xlib:process-event
-     display :timeout 0
-     :handler #'(lambda (&key event-window &allow-other-keys)
-                  (if (eq event-window win)
-                      (setf result t)
-                      nil)))
-    result))
-\end{lisp}
-
-\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/alien.ms}
-
-\node Alien Objects, Interprocess Communication under LISP, Event Dispatching with SERVE-EVENT, Top
-\chapter{Alien Objects}
-\label{aliens}
-\begin{center}
-\b{By Robert MacLachlan and William Lott}
-\end{center}
-\vspace{1 cm}
-
-\begin{menu}
-* Introduction to Aliens::      
-* Alien Types::                 
-* Alien Operations::            
-* Alien Variables::             
-* Alien Data Structure Example::  
-* Loading Unix Object Files::   
-* Alien Function Calls::        
-* Step-by-Step Alien Example::  
-\end{menu}
-
-\node Introduction to Aliens, Alien Types, Alien Objects, Alien Objects
-\section{Introduction to Aliens}
-
-Because of Lisp's emphasis on dynamic memory allocation and garbage
-collection, Lisp implementations use unconventional memory representations
-for objects.  This representation mismatch creates problems when a Lisp
-program must share objects with programs written in another language.  There
-are three different approaches to establishing communication:
-\begin{itemize}
-\item The burden can be placed on the foreign program (and programmer) by
-requiring the use of Lisp object representations.  The main difficulty with
-this approach is that either the foreign program must be written with Lisp
-interaction in mind, or a substantial amount of foreign ``glue'' code must be
-written to perform the translation.
-
-\item The Lisp system can automatically convert objects back and forth
-between the Lisp and foreign representations.  This is convenient, but
-translation becomes prohibitively slow when large or complex data structures
-must be shared.
-
-\item The Lisp program can directly manipulate foreign objects through the
-use of extensions to the Lisp language.  Most Lisp systems make use of
-this approach, but the language for describing types and expressing
-accesses is often not powerful enough for complex objects to be easily
-manipulated.
-\end{itemize}
-\cmucl{} relies primarily on the automatic conversion and direct manipulation
-approaches: Aliens of simple scalar types are automatically converted,
-while complex types are directly manipulated in their foreign
-representation.  Any foreign objects that can't automatically be
-converted into Lisp values are represented by objects of type
-\code{alien-value}.  Since Lisp is a dynamically typed language, even
-foreign objects must have a run-time type; this type information is
-provided by encapsulating the raw pointer to the foreign data within an
-\code{alien-value} object.
-
-The Alien type language and operations are most similar to those of the
-C language, but Aliens can also be used when communicating with most
-other languages that can be linked with C.
-
-
-\node Alien Types, Alien Operations, Introduction to Aliens, Alien Objects
-\section{Alien Types}
-
-Alien types have a description language based on nested list structure.  For
-example:
-\begin{example}
-struct foo \{
-    int a;
-    struct foo *b[100];
-\};
-\end{example}
-has the corresponding Alien type:
-\begin{lisp}
-(struct foo
-  (a int)
-  (b (array (* (struct foo)) 100)))
-\end{lisp}
-
-
-\begin{menu}
-* Defining Alien Types::        
-* Alien Types and Lisp Types::  
-* Alien Type Specifiers::       
-* The C-Call Package::          
-\end{menu}
-
-\node Defining Alien Types, Alien Types and Lisp Types, Alien Types, Alien Types
-\subsection{Defining Alien Types}
-
-Types may be either named or anonymous.  With structure and union types, the
-name is part of the type specifier, allowing recursively defined types such as:
-\begin{lisp}
-(struct foo (a (* (struct foo))))
-\end{lisp}
-An anonymous structure or union type is specified by using the name \nil.  The
-\funref{with-alien} macro defines a local scope which ``captures'' any named
-type definitions.  Other types are not inherently named, but can be given
-named abbreviations using \code{def-alien-type}.
-
-\defmac{def-alien-type}[alien]{name type}
-This macro globally defines \var{name} as a shorthand for the Alien type
-\var{type}.  When introducing global structure and union type definitions,
-\var{name} may be \nil, in which case the name to define is taken from the
-type's name.
-\enddefmac
-
-
-\node Alien Types and Lisp Types, Alien Type Specifiers, Defining Alien Types, Alien Types
-\subsection{Alien Types and Lisp Types}
-
-The Alien types form a subsystem of the \cmucl{} type system.  An \code{alien}
-type specifier provides a way to use any Alien type as a Lisp type
-specifier.  For example
-\begin{lisp}
-(typep foo '(alien (* int)))
-\end{lisp}
-can be used to determine whether \code{foo} is a pointer to an \code{int}.
-\code{alien} type specifiers can be used in the same ways as ordinary type
-specifiers (like \code{string}.)  Alien type declarations are subject to the same
-precise type checking as any other declaration (section
-\xlref{precise-type-checks}.)
-
-Note that the Alien type system overlaps with normal Lisp type specifiers in
-some cases.  For example, the type specifier \code{(alien single-float)} is
-identical to \code{single-float}, since Alien floats are automatically
-converted to Lisp floats.  When \code{type-of} is called on an Alien value
-that is not automatically converted to a Lisp value, then it will return an
-\code{alien} type specifier.
-
-\node Alien Type Specifiers, The C-Call Package, Alien Types and Lisp Types, Alien Types
-\subsection{Alien Type Specifiers}
-
-Some Alien type names are \clisp symbols, but the names are
-still exported from the \code{alien} package, so it is legal to say
-\code{alien:single-float}.  These are the basic Alien type specifiers: 
-
-\deftp{Alien type}{*}{\var{type}}
-A pointer to an object of the specified \var{type}.  If \var{type} is \true,
-then it means a pointer to anything, similar to ``\code{void *}'' in ANSI C.
-Currently, the only way to detect a null pointer is:
-\begin{lisp}
-(zerop (sap-int (alien-sap \var{ptr})))
-\end{lisp}
-\xlref{system-area-pointers}
-\enddeftp
-
-\deftp{Alien type}{array}{\var{type} \mstar{\var{dimension}}} 
-An array of the specified \var{dimensions}, holding elements of type
-\var{type}.  Note that \code{(* int)} and \code{(array int)} are considered to
-be different types when type checking is done; pointer and array types must be
-explicitly coerced using \code{cast}.
-
-Arrays are accessed using \code{deref}, passing the indices as additional
-arguments.  Elements are stored in column-major order (as in C), so the first
-dimension determines only the size of the memory block, and not the layout of
-the higher dimensions.  An array whose first dimension is variable may be
-specified by using \nil{} as the first dimension.  Fixed-size arrays can be
-allocated as array elements, structure slots or \code{with-alien} variables.
-Dynamic arrays can only be allocated using \funref{make-alien}.
-\enddeftp
-
-\deftp{Alien type}{struct}{\var{name} 
-                            \mstar{(\var{field} \var{type} \mopt{\var{bits}})}}
-
-A structure type with the specified \var{name} and \var{fields}.  Fields are
-allocated at the same positions used by the implementation's C compiler.
-\var{bits} is intended for C-like bit field support, but is currently unused.
-If \var{name} is \false, then the type is anonymous.
-
-If a named Alien \code{struct} specifier is passed to \funref{def-alien-type}
-or \funref{with-alien}, then this defines, respectively, a new global or local
-Alien structure type.  If no \var{fields} are specified, then the fields are
-taken from the current (local or global) Alien structure type definition of
-\var{name}.
-\enddeftp
-
-\deftp{Alien type}{union}{\var{name} 
-                           \mstar{(\var{field} \var{type} \mopt{\var{bits}})}}
-Similar to \code{struct}, but defines a union type.  All fields are allocated at
-the same offset, and the size of the union is the size of the largest field.
-The programmer must determine which field is active from context.
-\enddeftp
-
-\deftp{Alien type}{enum}{\var{name} \mstar{\var{spec}}}
-An enumeration type that maps between integer values and keywords.  If
-\var{name} is \false, then the type is anonymous.  Each \var{spec} is either
-a keyword, or a list \code{(\var{keyword} \var{value})}.  If \var{integer} is
-not supplied, then it defaults to one greater than the value for the preceding
-spec (or to zero if it is the first spec.)
-\enddeftp
-
-\deftp{Alien type}{signed}{\mopt{\var{bits}}}  
-A signed integer with the specified number of bits precision.  The upper limit
-on integer precision is determined by the machine's word size.  If no size is
-specified, the maximum size will be used.
-\enddeftp
-
-\deftp{Alien type}{integer}{\mopt{\var{bits}}}  
-Identical to \code{signed} --- the distinction between \code{signed} and
-\code{integer} is purely stylistic.
-\enddeftp
-
-\deftp{Alien type}{unsigned}{\mopt{\var{bits}}}
-Like \code{signed}, but specifies an unsigned integer.
-\enddeftp
-
-\deftp{Alien type}{boolean}{\mopt{\var{bits}}}
-Similar to an enumeration type that maps \code{0} to \false{} and all other values
-to \true.  \var{bits} determines the amount of storage allocated to hold the
-truth value.
-\enddeftp
-
-\deftp{Alien type}{single-float}{}
-A floating-point number in IEEE single format.
-\enddeftp
-
-\deftp{Alien type}{double-float}{}
-A floating-point number in IEEE double format.
-\enddeftp
-
-\deftp{Alien type}{function}{\var{result-type} \mstar{\var{arg-type}}}
-\label{alien-function-types}
-A Alien function that takes arguments of the specified \var{arg-types} and
-returns a result of type \var{result-type}.  Note that the only context where
-a \code{function} type is directly specified is in the argument to
-\code{alien-funcall} (see section \ref{alien-funcall}.)  In all other contexts,
-functions are represented by function pointer types: \code{(* (function
-...))}.  \enddeftp
-
-\deftp{Alien type}{system-area-pointer}{}
-A pointer which is represented in Lisp as a \code{system-area-pointer} object
-(\pxlref{system-area-pointers}.)
-\enddeftp
-
-\node The C-Call Package,  , Alien Type Specifiers, Alien Types
-\subsection{The C-Call Package}
-
-The \code{c-call} package exports these type-equivalents to the C type of the
-same name: \code{char}, \code{short}, \code{int}, \code{long},
-\code{unsigned-char}, \code{unsigned-short}, \code{unsigned-int},
-\code{unsigned-long}, \code{float}, \code{double}.  \code{c-call} also exports
-these types:
-
-\deftp{Alien type}{void}{}
-This type is used in function types to declare that no useful value is
-returned.  Evaluation of an \code{alien-funcall} form will return zero values.
-\enddeftp
-
-\deftp{Alien type}{c-string}{}
-This type is similar to \code{(* char)}, but is interpreted as a
-null-terminated string, and is automatically converted into a Lisp string when
-accessed.  If the pointer is C \code{NULL} (or 0), then accessing gives Lisp
-\false.
-
-Assigning a Lisp string to a \code{c-string} structure field or variable stores
-the contents of the string to the memory already pointed to by that variable.
-When an Alien of type \code{(* char)} is assigned to a \code{c-string}, then
-the \code{c-string} pointer is assigned to.  This allows \code{c-string}
-pointers to be initialized.  For example:
-\begin{lisp}
-(def-alien-type nil (struct foo (str c-string)))
-
-(defun make-foo (str)
-  (let ((my-foo (make-alien (struct foo))))
-    (setf (slot my-foo 'str) (make-alien char (length str)))
-    (setf (slot my-foo 'str) str)
-    my-foo))
-\end{lisp}
-Storing Lisp \false{} writes C \code{NULL} to the \code{c-string} pointer.
-\enddeftp
-
-
-\node Alien Operations, Alien Variables, Alien Types, Alien Objects
-\section{Alien Operations}
-
-This section describes the basic operations on Alien values.
-
-\begin{menu}
-* Alien Access Operations::     
-* Alien Coercion Operations::   
-* Alien Dynamic Allocation::    
-\end{menu}
-
-\node Alien Access Operations, Alien Coercion Operations, Alien Operations, Alien Operations
-\subsection{Alien Access Operations}
-
-\defun{deref}[alien]{\var{pointer-or-array} \&rest \var{indices}}
-This function returns the value pointed to by an Alien pointer or the value of
-an Alien array element.  If a pointer, an optional single index can be
-specified to give the equivalent of C pointer arithmetic; this index is scaled
-by the size of the type pointed to.  If an array, the number of indices must
-be the same as the number of dimensions in the array type.  \code{deref} can
-be set with \code{setf} to assign a new value.
-\enddefun
- 
-\defun{slot}[alien]{\var{struct-or-union} \var{slot-name}}
-This function extracts the value of slot \var{slot-name} from the an Alien
-\code{struct} or \code{union}.  If \var{struct-or-union} is a pointer to a
-structure or union, then it is automatically dereferenced.  This can be
-set with \code{setf} to assign a new value.  Note that \var{slot-name}
-is evaluated, and need not be a compile-time constant (but only constant
-slot accesses are efficiently compiled.)
-\enddefun
-
-\node Alien Coercion Operations, Alien Dynamic Allocation, Alien Access Operations, Alien Operations
-\subsection{Alien Coercion Operations}
-
-\defmac{addr}[alien]{\var{alien-expr}}
-This macro returns a pointer to the location specified by \var{alien-expr},
-which must be either an Alien variable, a use of \code{deref}, a use of \code{slot},
-or a use of \funref{extern-alien}.
-\enddefmac
-
-\defmac{cast}[alien]{\var{alien} \var{new-type}}
-This macro converts \var{alien} to a new Alien with the specified
-\var{new-type}.  Both types must be an Alien pointer, array or function type.
-Note that the result is not \code{eq} to the argument, but does refer to the same
-data bits.
-\enddefmac
-
-\defmac{sap-alien}[alien]{\var{sap} \var{type}}
-\defunx{alien-sap}[alien]{\var{alien-value}}
-\code{sap-alien} converts \var{sap} (a system area pointer
-\pxlref{system-area-pointers}) to an Alien value with the specified
-\var{type}.  \var{type} is not evaluated.
-
-\code{alien-sap} returns the SAP which points to \var{alien-value}'s
-data.
-
-The \var{type} to \code{sap-alien} and the type of the \var{alien-value} to
-\code{alien-sap} must some Alien pointer, array or record type.
-\enddefmac
-
-\node Alien Dynamic Allocation,  , Alien Coercion Operations, Alien Operations
-\subsection{Alien Dynamic Allocation}
-
-Dynamic Aliens are allocated using the \code{malloc} library, so foreign code
-can call \code{free} on the result of \code{make-alien}, and Lisp code can
-call \code{free-alien} on objects allocated by foreign code.
-
-\defmac{make-alien}[alien]{\var{type} \mopt{\var{size}}}
-This macro returns a dynamically allocated Alien of the specified
-\var{type} (which is not evaluated.)  The allocated memory is not
-initialized, and may contain arbitrary junk.  If supplied, \var{size} is
-an expression to evaluate to compute the size of the allocated object.
-There are two major cases:
-\begin{itemize}
-\item When \var{type} is an array type, an array of that type is
-allocated and a \var{pointer} to it is returned.  Note that you must use
-\code{deref} to change the result to an array before you can use
-\code{deref} to read or write elements:
-\begin{lisp}
-(defvar *foo* (make-alien (array char 10)))
-
-(type-of *foo*)
-\result{} (alien (* (array (signed 8) 10)))
-
-(setf (deref (deref foo) 0) 10)
-\result{} 10
-\end{lisp}
-If supplied, \var{size} is used as the first dimension for the array.
-
-\item When \var{type} is any other type, then then an object for that type is
-allocated, and a \var{pointer} to it is returned.  So \code{(make-alien int)}
-returns a \code{(* int)}.  If \var{size} is specified, then a block of that
-many objects is allocated, with the result pointing to the first one.
-\end{itemize}
-\enddefmac
- 
-\defun{free-alien}[alien]{\var{alien}}
-This function frees the storage for \var{alien} (which must have been allocated
-with \code{make-alien} or \code{malloc}.)
-\enddefun
-
-See also \funref{with-alien}, which stack-allocates Aliens.
-
-
-\node Alien Variables, Alien Data Structure Example, Alien Operations, Alien Objects
-\section{Alien Variables}
-
-Both local (stack allocated) and external (C global) Alien variables are
-supported.
-
-\begin{menu}
-* Local Alien Variables::       
-* External Alien Variables::    
-\end{menu}
-
-\node Local Alien Variables, External Alien Variables, Alien Variables, Alien Variables
-\subsection{Local Alien Variables}
-
-\defmac{with-alien}[alien]{\mstar{(\var{name} \var{type} 
-                                  \mopt{\var{initial-value}})}
-                         \mstar{form}}
-
-This macro establishes local alien variables with the specified Alien types
-and names for dynamic extent of the body.  The variable \var{names} are
-established as symbol-macros; the bindings have lexical scope, and may be
-assigned with \code{setq} or \code{setf}.  This form is analogous to defining a local
-variable in C: additional storage is allocated, and the initial value is
-copied.
-
-\code{with-alien} also establishes a new scope for named structures and unions.
-Any \var{type} specified for a variable may contain name structure or union
-types with the slots specified.  Within the lexical scope of the binding
-specifiers and body, a locally defined structure type \var{foo} can be
-referenced by its name using:
-\begin{lisp}
-(struct foo)
-\end{lisp}
-\enddefmac
-
-\node External Alien Variables,  , Local Alien Variables, Alien Variables
-\subsection{External Alien Variables} 
-\label{external-aliens}
-
-External Alien names are strings, and Lisp names are symbols.  When an
-external Alien is represented using a Lisp variable, there must be a way to
-convert from one name syntax into the other.  The macros \code{extern-alien},
-\code{def-alien-variable} and \funref{def-alien-routine} use this conversion
-heuristic:
-\begin{itemize}
-\item Alien names are converted to Lisp names by uppercasing and replacing
-underscores with hyphens.
-
-\item Conversely, Lisp names are converted to Alien names by lowercasing and
-replacing hyphens with underscores. 
-
-\item Both the Lisp symbol and Alien string names may be separately
-specified by using a list of the form:
-\begin{lisp}
-(\var{lisp-symbol} \var{alien-string})
-\end{lisp}
-\end{itemize}
-
-\defmac{def-alien-variable}[alien]{\var{name} \var{type}}
-This macro defines \var{name} as an external Alien variable of the specified
-Alien \var{type}.  \var{name} and \var{type} are not evaluated.  The Lisp name
-of the variable (see above) becomes a global Alien variable in the Lisp
-namespace.  Global Alien variables are effectively ``global symbol macros'';
-a reference to the variable fetches the contents of the external variable.
-Similarly, setting the variable stores new contents --- the new contents must
-be of the declared \var{type}.
-
-For example, it is often necessary to read the global C variable \code{errno} to
-determine why a particular function call failed.  It is possible to define
-errno and make it accessible from Lisp by the following:
-\begin{lisp}
-(def-alien-variable "errno" int)
-
-;; Now it is possible to get the value of the C variable errno simply by
-;; referencing that Lisp variable:
-;;
-(print errno)
-\end{lisp}
-\enddefmac
-
-\defmac{extern-alien}[alien]{\var{name} \var{type}}
-This macro returns an Alien with the specified \var{type} which points to an
-externally defined value.  \var{name} is not evaluated, and may be specified
-either as a string or a symbol.  \var{type} is an unevaluated Alien type
-specifier.
-\enddefmac
-
-
-\node Alien Data Structure Example, Loading Unix Object Files, Alien Variables, Alien Objects
-\section{Alien Data Structure Example}
-
-Now that we have Alien types, operations and variables, we can manipulate
-foreign data structures.  This C declaration can be translated into the
-following Alien type:
-\begin{lisp}
-struct foo \{
-    int a;
-    struct foo *b[100];
-\};
-
- \equiv{}
-
-(def-alien-type nil
-  (struct foo
-    (a int)
-    (b (array (* (struct foo)) 100))))
-\end{lisp}
-
-With this definition, the following C expression can be translated in this way:
-\begin{example}
-struct foo f;
-f.b[7].a
-
- \equiv{}
-
-(with-alien ((f (struct foo)))
-  (slot (deref (slot f 'b) 7) 'a)
-  ;;
-  ;; Do something with f...
-  )
-\end{example}
-
-
-Or consider this example of an external C variable and some accesses:
-\begin{example}
-struct c_struct \{
-        short x, y;
-        char a, b;
-        int z;
-        c_struct *n;
-\};
-
-extern struct c_struct *my_struct;
-
-my_struct->x++;
-my_struct->a = 5;
-my_struct = my_struct->n;
-\end{example}
-which can be made be manipulated in Lisp like this:
-\begin{lisp}
-(def-alien-type nil
-  (struct c-struct
-          (x short)
-          (y short)
-          (a char)
-          (b char)
-          (z int)
-          (n (* c-struct))))
-
-(def-alien-variable "my_struct" (* c-struct))
-
-(incf (slot my-struct 'x))
-(setf (slot my-struct 'a) 5)
-(setq my-struct (slot my-struct 'n))
-\end{lisp}
-
-
-
-\node Loading Unix Object Files, Alien Function Calls, Alien Data Structure Example, Alien Objects
-\section{Loading Unix Object Files}
-
-Foreign object files are loaded into the running Lisp process by
-\code{load-foreign}.  First, it runs the linker on the files and libraries,
-creating an absolute Unix object file.  This object file is then loaded into
-into the currently running Lisp.  The external symbols defining routines and
-variables are made available for future external references (e.g.  by
-\code{extern-alien}.)  \code{load-foreign} must be run before any of the defined
-symbols are referenced.
-
-Note that if a Lisp core image is saved (using \funref{save-lisp}), all
-loaded foreign code is lost when the image is restarted.
-
-\defun{load-foreign}[alien]{\var{files} \&key{} libraries base-file env}
-
-\var{files} is a \code{simple-string} or list of \code{simple-string}s
-specifying the names of the object files.  \var{libraries} is a list of
-\code{simple-string}s specifying libraries in a format that \code{ld}, the Unix
-linker, expects.  The default value for \var{libraries} is \code{("-lc")}
-(i.e., the standard C library).  \var{base-file} is the file to use for the
-initial symbol table information.  The default is the Lisp start up code:
-\file{path:lisp}.  \var{env} should be a list of simple strings in the format
-of Unix environment variables (i.e., \code{\var{A}=\var{B}}, where \var{A} is
-an environment variable and \var{B} is its value).  The default value for
-\var{env} is the environment information available at the time Lisp was
-invoked.  Unless you are certain that you want to change this, you should just
-use the default.
-\enddefun
-
-
-\node Alien Function Calls, Step-by-Step Alien Example, Loading Unix Object Files, Alien Objects
-\section{Alien Function Calls}
-
-The foreign function call interface allows a Lisp program to call functions
-written in other languages.  The current implementation of the foreign
-function call interface assumes a C calling convention and thus routines
-written in any language that adheres to this convention may be called from
-Lisp.
-
-Lisp sets up various interrupt handling routines and other environment
-information when it first starts up, and expects these to be in place at all
-times.  The C functions called by Lisp should either not change the
-environment, especially the interrupt entry points, or should make sure
-that these entry points are restored when the C function returns to Lisp.
-If a C function makes changes without restoring things to the way they were
-when the C function was entered, there is no telling what will happen.
-
-\begin{menu}
-* alien-funcall::               The alien-funcall Primitive
-* def-alien-routine::           The def-alien-routine Macro
-* def-alien-routine Example::   
-* Calling Lisp from C::         
-\end{menu}
-
-\node alien-funcall, def-alien-routine, Alien Function Calls, Alien Function Calls
-\subsection{The alien-funcall Primitive}
-
-\defun{alien-funcall}[alien]{\var{alien-function} \&rest \var{arguments}}
-This function is the foreign function call primitive: \var{alien-function} is
-called with the supplied \var{arguments} and its value is returned.  The
-\var{alien-function} is an arbitrary run-time expression; to call a constant
-function, use \funref{extern-alien} or \code{def-alien-routine}.
-
-The type of \var{alien-function} must be \code{(alien (function ...))} or
-\code{(alien (* (function ...)))}, \xlref{alien-function-types}.  The function
-type is used to determine how to call the function (as through it was declared
-with a prototype.)  The type need not be known at compile time, but only
-known-type calls are efficiently compiled.  Limitations:
-\begin{itemize}
-\item Structure type return values are not implemented.
-\item Passing of structures by value is not implemented.
-\end{itemize}
-\enddefun
-
-Here is an example which allocates a \code{(struct foo)}, calls a foreign
-function to initialize it, then returns a Lisp vector of all the
-\code{(* (struct foo))} objects filled in by the foreign call:
-\begin{lisp}
-;;
-;; Allocate a foo on the stack.
-(with-alien ((f (struct foo)))
-  ;;
-  ;; Call some C function to fill in foo fields.
-  (alien-funcall (extern-alien "mangle_foo" (function void (* foo)))
-                 (addr f))
-  ;;
-  ;; Find how many foos to use by getting the A field.
-  (let* ((num (slot f 'a))
-         (result (make-array num)))
-    ;;
-    ;; Get a pointer to the array so that we don't have to keep extracting it:
-    (with-alien ((a (* (array (* (struct foo)) 100)) (addr (slot f 'b))))
-      ;;
-      ;; Loop over the first N elements and stash them in the result vector.
-      (dotimes (i num)
-        (setf (svref result i) (deref (deref a) i)))
-      result)))
-\end{lisp}
-
-\node def-alien-routine, def-alien-routine Example, alien-funcall, Alien Function Calls
-\subsection{The def-alien-routine Macro}
-
-
-\defmac{def-alien-routine}[alien]{\var{name} \var{result-type}
-                         \mstar{(\var{aname} \var{atype} \mopt{style})}}
-
-This macro is a convenience for automatically generating Lisp interfaces to
-simple foreign functions.  The primary feature is the parameter style
-specification, which translates the C pass-by-reference idiom into additional
-return values.
-
-\var{name} is usually a string external symbol, but may also be a symbol Lisp
-name or a list of the Lisp name and the foreign name.  If only one name is
-specified, the other is automatically derived,
-(\pxlref{external-aliens}.)
-
-\var{result-type} is the Alien type of the return value.  Each remaining
-subform specifies an argument to the foreign function.  \var{aname} is the
-symbol name of the argument to the constructed function (for documentation)
-and \var{atype} is the Alien type of corresponding foreign argument.  The
-semantics of the actual call are the same as for \funref{alien-funcall}.
-\var{style} should be one of the following:
-\begin{description}
-\item[:in] specifies that the argument is passed by value.  This is the
-default.  \kwd{in} arguments have no corresponding return value from the Lisp
-function.
-
-\item[:out] specifies a pass-by-reference output value.  The type of the
-argument must be a pointer to a fixed sized object (such as an integer or
-pointer).  \kwd{out} and \kwd{in-out} cannot be used with pointers to arrays,
-records or functions.  An object of the correct size is allocated, and its
-address is passed to the foreign function.  When the function returns, the
-contents of this location are returned as one of the values of the Lisp
-function. 
-
-\item[:copy]
-is similar to \kwd{in}, but the argument is copied to a pre-allocated
-object and a pointer to this object is passed to the foreign routine.
-
-\item[:in-out]
-is a combination of \kwd{copy} and \kwd{out}.  The argument is copied to a
-pre-allocated object and a pointer to this object is passed to the
-foreign routine.  On return, the contents of this location is returned as an
-additional value.
-\end{description}
-Any efficiency-critical foreign interface function should be inline expanded by
-preceding \code{def-alien-routine} with:
-\begin{lisp}
-(declaim (inline \var{lisp-name}))
-\end{lisp}
-In addition to avoiding the Lisp call overhead, this allows pointers,
-word-integers and floats to be passed using non-descriptor representations,
-avoiding consing (\pxlref{non-descriptor}.)
-\enddefmac
-
-\node def-alien-routine Example, Calling Lisp from C, def-alien-routine, Alien Function Calls
-\subsection{def-alien-routine Example}
-
-Consider the C function \code{cfoo} with the following calling convention:
-\begin{example}
-cfoo (a, i)
-    char *str;
-    char *a; /* update */
-    int *i; /* out */
-\{
-/* Body of cfoo. */
-\}
-\end{example}
-which can be described by the following call to \code{def-alien-routine}:
-\begin{lisp}
-(def-alien-routine "cfoo" void
-  (str c-string)
-  (a char :in-out)
-  (i int :out))
-\end{lisp}
-The Lisp function \code{cfoo} will have two arguments (\var{str} and \var{a})
-and two return values (\var{a} and \var{i}).
-
-\node Calling Lisp from C,  , def-alien-routine Example, Alien Function Calls
-\subsection{Calling Lisp from C}
-
-{\it There is currently a mechanism for calling Lisp functions from C, but it
-is rather restricted, and is scheduled for replacement.  If you need to call
-Lisp functions from C, contact us and we will let you know what capabilities
-are available in the system you have.  }
-
-
-\node Step-by-Step Alien Example,  , Alien Function Calls, Alien Objects
-\section{Step-by-Step Alien Example}
-
-This section presents a complete example of an interface to a somewhat
-complicated C function.  This example should give a fairly good idea of how to
-get the effect you want for almost any kind of C function.  Suppose you have
-the following C function which you want to be able to call from Lisp in the
-file \file{test.c}:
-\begin{verbatim}                
-struct c_struct
-{
-  int x;
-  char *s;
-};
- 
-struct c_struct *c_function (i, s, r, a)
-    int i;
-    char *s;
-    struct c_struct *r;
-    int a[10];
-{
-  int j;
-  struct c_struct *r2;
- 
-  printf("i = %d\n", i);
-  printf("s = %s\n", s);
-  printf("r->x = %d\n", r->x);
-  printf("r->s = %s\n", r->s);
-  for (j = 0; j < 10; j++) printf("a[%d] = %d.\n", j, a[j]);
-  r2 = (struct c_struct *) malloc (sizeof(struct c_struct));
-  r2->x = i + 5;
-  r2->s = "A C string";
-  return(r2);
-};
-\end{verbatim}
-It is possible to call this function from Lisp using the file \file{test.lisp}
-whose contents is:
-\begin{lisp}
-;;; -*- Package: test-c-call -*-
-(in-package "TEST-C-CALL")
-(use-package "ALIEN")
-(use-package "C-CALL")
-
-;;; Define the record c-struct in Lisp.
-(def-alien-type nil
-    (struct c-struct
-	    (x int)
-	    (s c-string)))
-
-;;; Define the Lisp function interface to the C routine.  It returns a
-;;; pointer to a record of type c-struct.  It accepts four parameters:
-;;; i, an int; s, a pointer to a string; r, a pointer to a c-struct
-;;; record; and a, a pointer to the array of 10 ints.
-;;;
-;;; The INLINE declaration eliminates some efficiency notes about heap
-;;; allocation of Alien values.
-(declaim (inline c-function))
-(def-alien-routine c-function
-    (* (struct c-struct))
-  (i int)
-  (s c-string)
-  (r (* (struct c-struct)))
-  (a (array int 10)))
-
-;;; A function which sets up the parameters to the C function and
-;;; actually calls it.
-(defun call-cfun ()
-  (with-alien ((ar (array int 10))
-	       (c-struct (struct c-struct)))
-    (dotimes (i 10)                     ; Fill array.
-      (setf (deref ar i) i))
-    (setf (slot c-struct 'x) 20)
-    (setf (slot c-struct 's) "A Lisp String")
-
-    (with-alien ((res (* (struct c-struct))
-		      (c-function 5 "Another Lisp String" (addr c-struct) ar)))
-      (format t "Returned from C function.~%")
-      (multiple-value-prog1
-	  (values (slot res 'x)
-		  (slot res 's))
-	;;		
-	;; Deallocate result \i{after} we are done using it.
-	(free-alien res)))))
-\end{lisp}
-To execute the above example, it is necessary to compile the C routine as
-follows:
-\begin{example}
-cc -c test.c
-\end{example}
-In order to enable incremental loading with some linkers, you may need to say:
-\begin{example}
-cc -G 0 -c test.c
-\end{example}
-Once the C code has been compiled, you can start up Lisp and load it in:
-\begin{example}
-%lisp
-;;; Lisp should start up with its normal prompt.
-
-;;; Compile the Lisp file.  This step can be done separately.  You don't have
-;;; to recompile every time.
-* (compile-file "test.lisp")
-
-;;; Load the foreign object file to define the necessary symbols.  This must
-;;; be done before loading any code that refers to these symbols.  next block
-;;; of comments are actually the output of LOAD-FOREIGN.  Different linkers
-;;; will give different warnings, but some warning about redefining the code
-;;; size is typical.
-* (load-foreign "test.o")
-
-;;; Running library:load-foreign.csh...
-;;; Loading object file...
-;;; Parsing symbol table...
-Warning:  "_gp" moved from #x00C082C0 to #x00C08460.
-
-Warning:  "end" moved from #x00C00340 to #x00C004E0.
-
-;;; o.k. now load the compiled Lisp object file.
-* (load "test")
-
-;;; Now we can call the routine that sets up the parameters and calls the C
-;;; function.
-* (test-c-call::call-cfun)
-
-;;; The C routine prints the following information to standard output.
-i = 5
-s = Another Lisp string
-r->x = 20
-r->s = A Lisp string
-a[0] = 0.
-a[1] = 1.
-a[2] = 2.
-a[3] = 3.
-a[4] = 4.
-a[5] = 5.
-a[6] = 6.
-a[7] = 7.
-a[8] = 8.
-a[9] = 9.
-;;; Lisp prints out the following information.
-Returned from C function.
-;;; Return values from the call to test-c-call::call-cfun.
-10
-"A C string"
-*
-\end{example}
-
-If any of the foreign functions do output, they should not be called from
-within Hemlock.  Depending on the situation, various strange behavior occurs.
-Under X, the output goes to the window in which Lisp was started; on a
-terminal, the output will overwrite the Hemlock screen image; in a Hemlock
-slave, standard output is \file{/dev/null} by default, so any output is
-discarded.
-
-\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/ipc.ms}
-
-\node Interprocess Communication under LISP, Debugger Programmer's Interface, Alien Objects, Top
-\chapter{Interprocess Communication under LISP}
-\begin{center}
-\b{Written by William Lott and Bill Chiles}
-\end{center}
-\label{remote}
-
-CMU Common Lisp offers a facility for interprocess communication (IPC)
-on top of using Unix system calls and the complications of that level
-of IPC.  There is a simple remote-procedure-call (RPC) package build
-on top of TCP/IP sockets.
-
-
-\begin{menu}
-* The REMOTE Package::          
-* The WIRE Package::            
-* Out-Of-Band Data::            
-\end{menu}
-
-\node The REMOTE Package, The WIRE Package, Interprocess Communication under LISP, Interprocess Communication under LISP
-\section{The REMOTE Package}
-The \code{remote} package provides simple RPC facility including
-interfaces for creating servers, connecting to already existing
-servers, and calling functions in other Lisp processes.  The routines
-for establishing a connection between two processes,
-\code{create-request-server} and \code{connect-to-remote-server},
-return \var{wire} structures.  A wire maintains the current state of
-a connection, and all the RPC forms require a wire to indicate where
-to send requests.
-
-
-\begin{menu}
-* Connecting Servers and Clients::  
-* Remote Evaluations::          
-* Remote Objects::              
-* Host Addresses::              
-\end{menu}
-
-\node Connecting Servers and Clients, Remote Evaluations, The REMOTE Package, The REMOTE Package
-\subsection{Connecting Servers and Clients}
-
-Before a client can connect to a server, it must know the network address on
-which the server accepts connections.  Network addresses consist of a host
-address or name, and a port number.  Host addresses are either a string of the
-form \code{VANCOUVER.SLISP.CS.CMU.EDU} or a 32 bit unsigned integer.  Port
-numbers are 16 bit unsigned integers.  Note: \var{port} in this context has
-nothing to do with Mach ports and message passing.
-
-When a process wants to receive connection requests (that is, become a
-server), it first picks an integer to use as the port.  Only one server
-(Lisp or otherwise) can use a given port number on a given machine at
-any particular time.  This can be an iterative process to find a free
-port: picking an integer and calling \code{create-request-server}.  This
-function signals an error if the chosen port is unusable.  You will
-probably want to write a loop using \code{handler-case}, catching
-conditions of type error, since this function does not signal more
-specific conditions.
-
-\defun{create-request-server}[wire]{
- \args{\var{port} \&optional{} \var{on-connect}}}
- \code{create-request-server} sets up the current Lisp to accept connections on
-the given port.  If port is unavailable for any reason, this signals an error.
-When a client connects to this port, the acceptance mechanism makes a wire
-structure and invokes the \var{on-connect} function.  Invoking this function has
-a couple purposes, and \var{on-connect} may be \nil{} in which case the system
-foregoes invoking any function at connect time.
-
-The \var{on-connect} function is both a hook that allows you access to the wire
-created by the acceptance mechanism, and it confirms the connection.  This
-function takes two arguments, the wire and the host address of the connecting
-process.  See the section on host addresses below.  When \var{on-connect} is
-\nil, the request server allows all connections.  When it is non-\nil, the
-function returns two values, whether to accept the connection and a function
-the system should call when the connection terminates.  Either value may be
-\nil, but when the first value is \nil, the acceptance mechanism destroys the
-wire.
-
-\code{create-request-server} returns an object that \code{destroy-request-server}
-uses to terminate a connection.
-\enddefun
-
-\defun{destroy-request-server}[wire]{\args{\var{server}}}
-\code{destroy-request-server} takes the result of \code{create-request-server} and
-terminates that server.  Any existing connections remain intact, but all
-additional connection attempts will fail.
-\enddefun
-
-\defun{connect-to-remote-server}[wire]{
- \args{\var{host} \var{port} \&optional{} \var{on-death}}}
- \code{connect-to-remote-server} attempts to connect to a remote server at the
-given \var{port} on \var{host} and returns a wire structure if it is successful.
-If \var{on-death} is non-\nil, it is a function the system invokes when this
-connection terminates.
-\enddefun
-
-
-\node Remote Evaluations, Remote Objects, Connecting Servers and Clients, The REMOTE Package
-\subsection{Remote Evaluations}
-After the server and client have connected, they each have a wire allowing
-function evaluation in the other process.  This RPC mechanism has three
-flavors: for side-effect only, for a single value, and for multiple values.
-
-Only a limited number of data types can be sent across wires as arguments for
-remote function calls and as return values: integers inclusively less than 32
-bits in length, symbols, lists, and \var{remote-objects} (\pxlref{remote-objs}).  The system sends symbols as two strings, the package name
-and the symbol name, and if the package doesn't exist remotely, the remote
-process signals an error.  The system ignores other slots of symbols.  Lists
-may be any tree of the above valid data types.  To send other data types you
-must represent them in terms of these supported types.  For example, you could
-use \code{prin1-to-string} locally, send the string, and use \code{read-from-string}
-remotely.
-
-\defmac{remote}[wire]{\args{\i{wire \mstar{call-specs}}}}
-The \code{remote} macro arranges for the process at the other end of \var{wire} to
-invoke each of the functions in the \var{call-specs}.  To make sure the system
-sends the remote evaluation requests over the wire, you must call
-\code{wire-force-output}.
-
-Each of \var{call-specs} looks like a function call textually, but it has some
-odd constraints and semantics.  The function position of the form must be the
-symbolic name of a function.  \code{remote} evaluates each of the argument
-subforms for each of the \var{call-specs} locally in the current context, sending
-these values as the arguments for the functions.
-
-Consider the following example:
-\begin{verbatim}
-(defun write-remote-string (str)
-  (declare (simple-string str))
-  (wire:remote wire
-    (write-string str)))
-\end{verbatim}
-The value of \code{str} in the local process is passed over the wire with a
-request to invoke \code{write-string} on the value.  The system does not expect to
-remotely evaluate \code{str} for a value in the remote process.
-\enddefmac
-
-\defun{wire-force-output}[wire]{\args{\var{wire}}}
-\code{wire-force-output} flushes all internal buffers associated with \var{wire},
-sending the remote requests.  This is necessary after a call to \code{remote}.
-\enddefun
-
-\defmac{remote-value}[wire]{\args{\i{wire call-spec}}}
-The \code{remote-value} macro is similar to the \code{remote} macro.
-\code{remote-value} only takes one \var{call-spec}, and it returns the value
-returned by the function call in the remote process.  The value must be a valid
-type the system can send over a wire, and there is no need to call
-\code{wire-force-output} in conjunction with this interface.
-
-If client unwinds past the call to \code{remote-value}, the server continues
-running, but the system ignores the value the server sends back.
-
-If the server unwinds past the remotely requested call, instead of returning
-normally, \code{remote-value} returns two values, \nil{} and \true.  Otherwise this
-returns the result of the remote evaluation and \nil.
-\enddefmac
-
-\defmac{remote-value-bind}[wire]{
-  \args{\i{wire (\mstar{variable}) remote-form \mstar{local-forms}}}}
- \code{remote-value-bind} is similar to \code{multiple-value-bind} except the values
-bound come from \var{remote-form}'s evaluation in the remote process.  The
-\var{local-forms} execute in an implicit \code{progn}.
-
-If the client unwinds past the call to \code{remote-value-bind}, the server
-continues running, but the system ignores the values the server sends back.
-
-If the server unwinds past the remotely requested call, instead of returning
-normally, the \var{local-forms} never execute, and \code{remote-value-bind} returns
-\nil.
-\enddefmac
-
-
-\node Remote Objects, Host Addresses, Remote Evaluations, The REMOTE Package
-\subsection{Remote Objects}
-\label{remote-objs}
-
-The wire mechanism only directly supports a limited number of data
-types for transmission as arguments for remote function calls and as
-return values: integers inclusively less than 32 bits in length,
-symbols, lists.  Sometimes it is useful to allow remote processes to
-refer to local data structures without allowing the remote process
-to operate on the data.  We have \var{remote-objects} to support
-this without the need to represent the data structure in terms of
-the above data types, to send the representation to the remote
-process, to decode the representation, to later encode it again, and
-to send it back along the wire.
-
-You can convert any Lisp object into a remote-object.  When you send
-a remote-object along a wire, the system simply sends a unique token
-for it.  In the remote process, the system looks up the token and
-returns a remote-object for the token.  When the remote process
-needs to refer to the original Lisp object as an argument to a
-remote call back or as a return value, it uses the remote-object it
-has which the system converts to the unique token, sending that
-along the wire to the originating process.  Upon receipt in the
-first process, the system converts the token back to the same
-(\code{eq}) remote-object.
-
-\defun{make-remote-object}[wire]{\args{\var{object}}}
-\code{make-remote-object} returns a remote-object that has \var{object} as its
-value.  The remote-object can be passed across wires just like the directly
-supported wire data types.
-\enddefun
-
-\defun{remote-object-p}[wire]{\args{\var{object}}}
-The function \code{remote-object-p} returns \true{} if \var{object}
-is a remote object and \nil{} otherwise.
-\enddefun
-
-\defun{remote-object-local-p}[wire]{\args{\var{remote}}}
-The
-function \code{remote-object-local-p} returns \true{} if
-\var{remote} refers to an object in the local process.  This is can
-only occur if the local process created \var{remote} with
-\code{make-remote-object}.
-\enddefun
-
-\defun{remote-object-eq}[wire]{\args{\i{obj1 obj2}}}
-The function \code{remote-object-eq} returns \true{} if \i{obj1} and
-\i{obj2} refer to the same (\code{eq}) lisp object, regardless of
-which process created the remote-objects.
-\enddefun
-
-\defun{remote-object-value}[wire]{\args{\var{remote}}}
-This function returns the original object used to create the given remote
-object.  It is an error if some other process originally created the
-remote-object.
-\enddefun
-
-\defun{forget-remote-translation}[wire]{\args{\var{object}}}
-This function removes the information and storage necessary to
-translate remote-objects back into \var{object}, so the next
-\code{gc} can reclaim the memory.  You should use this when you no
-longer expect to receive references to \var{object}.  If some remote
-process does send a reference to \var{object},
-\code{remote-object-value} signals an error.
-\enddefun
-
-
-\node Host Addresses,  , Remote Objects, The REMOTE Package
-\subsection{Host Addresses}
-The operating system maintains a database of all the valid host
-addresses.  You can use this database to convert between host names
-and addresses and vice-versa.
-
-\defun{lookup-host-entry}[ext]{\args{\var{host}}}
-\code{lookup-host-entry} searches the database for the given
-\var{host} and returns a host-entry structure for it.  If it fails
-to find \var{host} in the database, it returns \nil.  \var{Host} is
-either the address (as an integer) or the name (as a string) of the
-desired host.
-\enddefun
-
-\defun{host-entry-name}[ext]{\args{\var{host-entry}}}
-\defunx{host-entry-aliases}[ext]{\args{\var{host-entry}}}
-\defunx{host-entry-addr-list}[ext]{\args{\var{host-entry}}}
-\defunx{host-entry-addr}[ext]{\args{\var{host-entry}}}
-\code{host-entry-name}, \code{host-entry-aliases}, and
-\code{host-entry-addr-list} each return the indicated slot from the
-host-entry structure.  \code{host-entry-addr} returns the primary
-(first) address from the list returned by
-\code{host-entry-addr-list}.
-\enddefun
-
-
-\node The WIRE Package, Out-Of-Band Data, The REMOTE Package, Interprocess Communication under LISP
-\section{The WIRE Package}
-
-The \code{wire} package provides for sending data along wires.  The
-\code{remote} package sits on top of this package.  All data sent
-with a given output routine must be read in the remote process with
-the complementary fetching routine.  For example, if you send so a
-string with \code{wire-output-string}, the remote process must know
-to use \code{wire-get-string}.  To avoid rigid data transfers and
-complicated code, the interface supports sending
-\var{tagged} data.  With tagged data, the system sends a tag
-announcing the type of the next data, and the remote system takes
-care of fetching the appropriate type.
-
-When using interfaces at the wire level instead of the RPC level,
-the remote process must read everything sent by these routines.  If
-the remote process leaves any input on the wire, it will later
-mistake the data for an RPC request causing unknown lossage.
-
-\begin{menu}
-* Untagged Data::               
-* Tagged Data::                 
-* Making Your Own Wires::       
-\end{menu}
-
-\node Untagged Data, Tagged Data, The WIRE Package, The WIRE Package
-\subsection{Untagged Data}
-When using these routines both ends of the wire know exactly what types are
-coming and going and in what order. This data is restricted to the following
-types:
-\begin{itemize}
-
-\item
-8 bit unsigned bytes.
-
-\item
-32 bit unsigned bytes.
-
-\item
-32 bit integers.
-
-\item
-simple-strings less than 65535 in length.
-\end{itemize}
-
-
-\defun{wire-output-byte}[wire]{\args{\i{wire byte}}}
-\defunx{wire-get-byte}[wire]{\args{\var{wire}}}
-\defunx{wire-output-number}[wire]{\args{\i{wire number}}}
-\defunx{wire-get-number}[wire]{\args{\var{wire} \&optional{} \var{signed}}}
-\defunx{wire-output-string}[wire]{\args{\i{wire string}}}
-\defunx{wire-get-string}[wire]{\args{\var{wire}}}
-These functions either output or input an object of the specified data type.
-When you use any of these output routines to send data across the wire, you
-must use the corresponding input routine interpret the data.
-\enddefun
-
-
-\node Tagged Data, Making Your Own Wires, Untagged Data, The WIRE Package
-\subsection{Tagged Data}
-When using these routines, the system automatically transmits and interprets
-the tags for you, so both ends can figure out what kind of data transfers
-occur.  Sending tagged data allows a greater variety of data types: integers
-inclusively less than 32 bits in length, symbols, lists, and \var{remote-objects}
-(\pxlref{remote-objs}).  The system sends symbols as two strings, the
-package name and the symbol name, and if the package doesn't exist remotely,
-the remote process signals an error.  The system ignores other slots of
-symbols.  Lists may be any tree of the above valid data types.  To send other
-data types you must represent them in terms of these supported types.  For
-example, you could use \code{prin1-to-string} locally, send the string, and use
-\code{read-from-string} remotely.
-
-\defun{wire-output-object}[wire]{\args{\i{wire object} \&optional{} \var{cache-it}}}
-\defunx{wire-get-object}[wire]{\args{\var{wire}}}
-The function \code{wire-output-object} sends \var{object} over \var{wire} preceded by
-a tag indicating its type.
-
-If \var{cache-it} is non-\nil, this function only sends \var{object} the first time
-it gets \var{object}.  Each end of the wire associates a token with \var{object},
-similar to remote-objects, allowing you to send the object more efficiently on
-successive transmissions.  \var{Cache-it} defaults to \true{} for symbols and \nil{}
-for other types.  Since the RPC level requires function names, a high-level
-protocol based on a set of function calls saves time in sending the functions'
-names repeatedly.
-
-The function \code{wire-get-object} reads the results of \code{wire-output-object}
-and returns that object.
-\enddefun
-
-
-\node Making Your Own Wires,  , Tagged Data, The WIRE Package
-\subsection{Making Your Own Wires}
-You can create wires manually in addition to the \code{remote} package's
-interface creating them for you.  To create a wire, you need a Unix \i{file
-descriptor}.  If you are unfamiliar with Unix file descriptors, see section 2 of
-the Unix manual pages.
-
-\defun{make-wire}[wire]{\args{\var{descriptor}}}
-The function \code{make-wire} creates a new wire when supplied with the file
-descriptor to use for the underlying I/O operations.
-\enddefun
-
-\defun{wire-p}[wire]{\args{\var{object}}}
-This function returns \true{} if \var{object} is indeed a wire, \nil{} otherwise.
-\enddefun
-
-\defun{wire-fd}[wire]{\args{\var{wire}}}
-This function returns the file descriptor used by the \var{wire}.
-\enddefun
-
-
-\node Out-Of-Band Data,  , The WIRE Package, Interprocess Communication under LISP
-\section{Out-Of-Band Data}
-
-The TCP/IP protocol allows users to send data asynchronously, otherwise
-known as \var{out-of-band} data.  When using this feature, the operating
-system interrupts the receiving process if this process has chosen to be
-notified about out-of-band data.  The receiver can grab this input
-without affecting any information currently queued on the socket.
-Therefore, you can use this without interfering with any current
-activity due to other wire and remote interfaces.
-
-Unfortunately, most implementations of TCP/IP are broken, so use of
-out-of-band data is limited for safety reasons.  You can only reliably
-send one character at a time.
-
-This routines in this section provide a mechanism for establishing
-handlers for out-of-band characters and for sending them out-of-band.
-These all take a Unix file descriptor instead of a wire, but you can
-fetch a wire's file descriptor with \code{wire-fd}.
-
-\defun{add-oob-handler}[wire]{\args{\i{fd char handler}}}
-The function \code{add-oob-handler} arranges for \var{handler} to be called
-whenever \var{char} shows up as out-of-band data on the file descriptor
-\var{fd}.
-\enddefun
-
-\defun{remove-oob-handler}[wire]{\args{\i{fd char}}}
-This function removes the handler for the character \var{char} on the file
-descriptor \var{fd}.
-\enddefun
-
-\defun{remove-all-oob-handlers}[wire]{\args{\var{fd}}}
-This function removes all handlers for the file descriptor \var{fd}.
-\enddefun
-
-\defun{send-character-out-of-band}[wire]{\args{\i{fd char}}}
-This function Sends the character \var{char} down the file descriptor \var{fd}
-out-of-band.
-\enddefun
-
-
-\hide{File:debug-int.tex}
-\node Debugger Programmer's Interface, Function Index, Interprocess Communication under LISP, Top
-\chapter{Debugger Programmer's Interface}
-\label{debug-internals}
-
-The debugger programmers interface is exported from from the
-\code{"DEBUG-INTERNALS"} or \code{"DI"} package.  This is a CMU
-extension that allows debugging tools to be written without detailed
-knowledge of the compiler or run-time system.
-
-Some of the interface routines take a code-location as an argument.  As
-described in the section on code-locations, some code-locations are
-unknown.  When a function calls for a \var{basic-code-location}, it
-takes either type, but when it specifically names the argument
-\var{code-location}, the routine will signal an error if you give it an
-unknown code-location.
-
-\begin{menu}
-* DI Exceptional Conditions::   
-* Debug-variables::             
-* Frames::                      
-* Debug-functions::             
-* Debug-blocks::                
-* Breakpoints::                 
-* Code-locations::              
-* Debug-sources::               
-* Source Translation Utilities::  
-\end{menu}
-
-
-\node DI Exceptional Conditions, Debug-variables, Debugger Programmer's Interface, Debugger Programmer's Interface
-\section{DI Exceptional Conditions}
-
-Some of these operations fail depending on the availability debugging
-information.  In the most severe case, when someone saved a Lisp image
-stripping all debugging data structures, no operations are valid.  In
-this case, even backtracing and finding frames is impossible.  Some
-interfaces can simply return values indicating the lack of information,
-or their return values are naturally meaningful in light missing data.
-Other routines, as documented below, will signal
-\code{serious-condition}s when they discover awkward situations.  This
-interface does not provide for programs to detect these situations other
-than by calling a routine that detects them and signals a condition.
-These are serious-conditions because the program using the interface
-must handle them before it can correctly continue execution.  These
-debugging conditions are not errors since it is no fault of the
-programmers that the conditions occur.
-
-\begin{menu}
-* Debug-conditions::            
-* Debug-errors::                
-\end{menu}
-
-\node Debug-conditions, Debug-errors, DI Exceptional Conditions, DI Exceptional Conditions
-\subsection{Debug-conditions}
-
-The debug internals interface signals conditions when it can't adhere
-to its contract.  These are serious-conditions because the program
-using the interface must handle them before it can correctly continue
-execution.  These debugging conditions are not errors since it is no
-fault of the programmers that the conditions occur.  The interface
-does not provide for programs to detect these situations other than
-calling a routine that detects them and signals a condition.
-
-
-\deftp{Condition}{debug-condition}{}
-
-This condition inherits from serious-condition, and all debug-conditions
-inherit from this.  These must be handled, but they are not programmer errors.
-\enddeftp
-
-
-\deftp{Condition}{no-debug-info}{}
-
-This condition indicates there is absolutely no debugging information
-available.
-\enddeftp
-
-
-\deftp{Condition}{no-debug-function-returns}{}
-
-This condition indicates the system cannot return values from a frame since
-its debug-function lacks debug information details about returning values.
-\enddeftp
-
-
-\deftp{Condition}{no-debug-blocks}{}
-This condition indicates that a function was not compiled with debug-block
-information, but this information is necessary necessary for some requested
-operation.
-\enddeftp
-
-\deftp{Condition}{no-debug-variables}{}
-Similar to \code{no-debug-blocks}, except that variable information was
-requested.
-\enddeftp
-
-\deftp{Condition}{lambda-list-unavailable}{}
-Similar to \code{no-debug-blocks}, except that lambda list information was
-requested.
-\enddeftp
-
-\deftp{Condition}{invalid-value}{}
-
-This condition indicates a debug-variable has \code{:invalid} or \code{:unknown}
-value in a particular frame.
-\enddeftp
-
-
-\deftp{Condition}{ambiguous-variable-name}{}
-
-This condition indicates a user supplied debug-variable name identifies more
-than one valid variable in a particular frame.
-\enddeftp
-
-
-\node Debug-errors,  , Debug-conditions, DI Exceptional Conditions
-\subsection{Debug-errors}
-
-These are programmer errors resulting from misuse of the debugging tools'
-programmers' interface.  You could have avoided an occurrence of one of these
-by using some routine to check the use of the routine generating the error.
-
-
-\deftp{Condition}{debug-error}{}
-This condition inherits from error, and all user programming errors inherit
-from this condition.
-\enddeftp
-
-
-\deftp{Condition}{unhandled-condition}{}
-This error results from a signalled \code{debug-condition} occurring
-without anyone handling it.
-\enddeftp
-
-
-\deftp{Condition}{unknown-code-location}{}
-This error indicates the invalid use of an unknown-code-location.
-\enddeftp
-
-
-\deftp{Condition}{unknown-debug-variable}{}
-
-This error indicates an attempt to use a debug-variable in conjunction with an
-inappropriate debug-function; for example, checking the variable's validity
-using a code-location in the wrong debug-function will signal this error.
-\enddeftp
-
-
-\deftp{Condition}{frame-function-mismatch}{}
-
-This error indicates you called a function returned by
-\code{preprocess-for-eval}
-on a frame other than the one for which the function had been prepared.
-\enddeftp
-
-
-
-\node Debug-variables, Frames, DI Exceptional Conditions, Debugger Programmer's Interface
-\section{Debug-variables}
-
-Debug-variables represent the constant information about where the system
-stores argument and local variable values.  The system uniquely identifies with
-an integer every instance of a variable with a particular name and package.  To
-access a value, you must supply the frame along with the debug-variable since
-these are particular to a function, not every instance of a variable on the
-stack.
-
-\defun{debug-variable-name}{debug-variable}
-This function returns the name of the \var{debug-variable}.  The name is the
-name of the symbol used as an identifier when writing the code.
-\enddefun
-
-
-\defun{debug-variable-package}{debug-variable}
-This function returns the package name of the \var{debug-variable}.  This is
-the package name of the symbol used as an identifier when writing the code.
-\enddefun
-
-
-\defun{debug-variable-symbol}{debug-variable}
-This function returns the symbol from interning \code{debug-variable-name} in
-the package named by \code{debug-variable-package}.
-\enddefun
-
-
-\defun{debug-variable-id}{debug-variable}
-This function returns the integer that makes \var{debug-variable}'s name and
-package name unique with respect to other \var{debug-variable}'s in the same
-function.
-\enddefun
-
-
-\defun{debug-variable-validity}{debug-variable basic-code-location}
-This function returns three values reflecting the validity of 
-\var{debug-variable}'s value at \var{basic-code-location}:
-\begin{description}
-   \item[\code{:valid}] The value is known to be available.
-   \item[\code{:invalid}] The value is known to be unavailable.
-   \item[\code{:unknown}] The value's availability is unknown.
-\end{description}
-\enddefun
-
-
-\defun{debug-variable-value}{debug-variable frame}
-This function returns the value stored for \var{debug-variable} in \var{frame}.
-The value may be invalid.  This is \code{SETF}'able.
-\enddefun
-
-
-\defun{debug-variable-valid-value}{debug-variable frame}
-This function returns the value stored for \var{debug-variable} in
-\var{frame}.  If the value is not \code{:valid}, then this signals an
-\code{invalid-value} error.
-\enddefun
-
-
-
-\node Frames, Debug-functions, Debug-variables, Debugger Programmer's Interface
-\section{Frames}
-
-Frames describe a particular call on the stack for a particular thread.  This
-is the environment for name resolution, getting arguments and locals, and
-returning values.  The stack conceptually grows up, so the top of the stack is
-the most recently called function.
-
-\code{top-frame}, \code{frame-down}, \code{frame-up}, and
-\code{frame-debug-function} can only fail when there is absolutely no
-debug information available.  This can only happen when someone saved a
-Lisp image specifying that the system dump all debugging data.
-
-
-\defun{top-frame}{}
-This function never returns the frame for itself, always the frame before
-calling \code{top-frame}.
-\enddefun
-
-
-\defun{frame-down}{frame}
-This returns the frame immediately below \var{frame} on the stack.  When 
-\var{frame} is the bottom of the stack, this returns \nil.
-\enddefun
-
-
-\defun{frame-up}{frame}
-This returns the frame immediately above \var{frame} on the stack.  When 
-\var{frame} is the top of the stack, this returns \nil.
-\enddefun
-
-
-\defun{frame-debug-function}{frame}
-This function returns the debug-function for the function whose call 
-\var{frame} represents.
-\enddefun
-
-
-\defun{frame-code-location}{frame}
-This function returns the code-location where \var{frame}'s debug-function will
-continue running when program execution returns to \var{frame}.  If someone
-interrupted this frame, the result could be an unknown code-location.
-\enddefun
-
-
-\defun{frame-catches}{frame}
-This function returns an a-list for all active catches in \var{frame} mapping
-catch tags to the code-locations at which the catch re-enters.
-\enddefun
-
-
-\defun{eval-in-frame}{frame form}
-This evaluates \var{form} in \var{frame}'s environment.  This can signal
-several different debug-conditions since its success relies on a variety of
-inexact debug information: \code{invalid-value},
-\code{ambiguous-variable-name}, \code{frame-function-mismatch}.  See
-also \funref{preprocess-for-eval}.
-\enddefun
-
-
-\defun{return-from-frame}{frame values}
-This returns the elements in the list \var{values} as multiple values from
-\var{frame} as if the function \var{frame} represents returned these values.
-This signals a \code{no-debug-function-returns} condition when \var{frame}'s
-debug-function lacks information on returning values.
-
-\i{Not Yet Implemented}
-\enddefun
-
-
-\node Debug-functions, Debug-blocks, Frames, Debugger Programmer's Interface
-\section {Debug-functions}
-
-Debug-functions represent the static information about a function determined at
-compile time --- argument and variable storage, their lifetime information,
-etc.  The debug-function also contains all the debug-blocks representing
-basic-blocks of code, and these contains information about specific
-code-locations in a debug-function.
-
-\defmac{do-debug-function-blocks}
-  {(block-var debug-function \mopt{result-form}) \mstar{form}}
-
-This executes the forms in a context with \var{block-var} bound to each
-debug-block in \var{debug-function} successively.  \var{Result-form} is
-an optional form to execute for a return value, and
-\code{do-debug-function-blocks} returns \nil if there is no
-\var{result-form}.  This signals a \code{no-debug-blocks} condition when the
-\var{debug-function} lacks debug-block information.
-\enddefmac
-
-
-\defun{debug-function-lambda-list}{debug-function}
-This function returns a list representing the lambda-list for 
-\var{debug-function}.  The list has the following structure:
-\begin{example}
-   (required-var1 required-var2
-    ...
-    (:optional var3 suppliedp-var4)
-    (:optional var5)
-    ...
-    (:rest var6) (:rest var7)
-    ...
-    (:keyword keyword-symbol var8 suppliedp-var9)
-    (:keyword keyword-symbol var10)
-    ...
-    )
-\end{example}
-Each \code{var}\var{n} is a debug-variable; however, the symbol
-\code{:deleted} appears instead whenever the argument remains unreferenced
-throughout \var{debug-function}.
-
-If there is no lambda-list information, this signals a
-\code{lambda-list-unavailable} condition.
-\enddefun
-
-
-\defmac{do-debug-function-variables}
-  {(var debug-function \mopt{result}) \mstar{form}}
-This macro executes each \var{form} in a context with \var{var} bound to each
-debug-variable in \var{debug-function}.  This returns the value of executing
-\var{result} (defaults to \nil).  This may iterate over only some of 
-\var{debug-function}'s variables or none depending on debug policy; for example,
-possibly the compilation only preserved argument information.
-\enddefmac
-
-
-\defun{debug-variable-info-available}{debug-function}
-This function returns whether there is any variable information for 
-\var{debug-function}.  This is useful for distinguishing whether there were no
-locals in a function or whether there was no variable information.  For
-example, if \code{do-debug-function-variables} executes its forms zero times,
-then you can use this function to determine the reason.
-\enddefun
-
-
-\defun{debug-function-symbol-variables}{debug-function symbol}
-This function returns a list of debug-variables in \var{debug-function} having
-the same name and package as \var{symbol}.  If \var{symbol} is uninterned, then
-this returns a list of debug-variables without package names and with the same
-name as \var{symbol}.  The result of this function is limited to the
-availability of variable information in \var{debug-function}; for example,
-possibly \var{debug-function} only knows about its arguments.
-\enddefun
-
-
-\defun{ambiguous-debug-variables}{debug-function name-prefix-string}
-This function returns a list of debug-variables in \var{debug-function} whose
-names contain \var{name-prefix-string} as an initial substring.  The result of
-this function is limited to the availability of variable information in
-\var{debug-function}; for example, possibly \var{debug-function} only knows
-about its arguments.
-\enddefun
-
-
-\defun{preprocess-for-eval}{form basic-code-location}
-This function returns a function of one argument that evaluates \var{form} in
-the lexical context of \var{basic-code-location}.  This allows efficient
-repeated evaluation of \var{form} at a certain place in a function which could
-be useful for conditional breaking.  This signals a \code{no-debug-variables}
-condition when the code-location's debug-function has no debug-variable
-information available.  The returned function takes a frame as an
-argument.  See also \funref{eval-in-frame}.
-\enddefun
-
-
-\defun{function-debug-function}{function}
-This function returns a debug-function that represents debug information for
-\var{function}.
-\enddefun
-
-
-\defun{debug-function-kind}{debug-function}
-This function returns the kind of function \var{debug-function} represents.
-The value is one of the following:
-\begin{description}
-\item[\code{:optional}]
-This kind of function is an entry point to an ordinary function.  It handles
-optional defaulting, parsing keywords, etc.
-\item[\code{:external}]
-This kind of function is an entry point to an ordinary function.  It checks
-argument values and count and calls the defined function.
-\item[\code{:top-level}]
-This kind of function executes one or more random top-level forms
-from a file.
-\item[\code{:cleanup}]
-This kind of function represents the cleanup forms in an \code{unwind-protect}.
-\item[\nil]
-This kind of function is not one of the above; that is, it is not specially
-marked in any way.
-\end{description}
-\enddefun
-
-
-\defun{debug-function-function}{debug-function}
-This function returns the Common Lisp function associated with the 
-\var{debug-function}.  This returns \nil if the function is unavailable or is
-non-existent as a user callable function object.
-\enddefun
-
-
-\defun{debug-function-name}{debug-function}
-This function returns the name of the function represented by 
-\var{debug-function}.  This may be a string or a cons; do not assume it is a symbol.
-\enddefun
-
-
-
-\node Debug-blocks, Breakpoints, Debug-functions, Debugger Programmer's Interface
-\section{Debug-blocks}
-
-Debug-blocks contain information pertinent to a specific range of code in a
-debug-function.
-
-\defmac{do-debug-block-locations}
-  {(code-var debug-block \mopt{result}) \mstar{form}}
-This macro executes each \var{form} in a context with \var{code-var} bound to
-each code-location in \var{debug-block}.  This returns the value of executing
-\var{result} (defaults to \nil).
-\enddefmac
-
-
-\defun{debug-block-successors}{debug-block}
-This function returns the list of possible code-locations where execution may
-continue when the basic-block represented by \var{debug-block} completes its
-execution.
-\enddefun
-
-
-\defun{debug-block-elsewhere-p}{debug-block}
-This function returns whether \var{debug-block} represents elsewhere code.
-This is code the compiler has moved out of a function's code sequence for
-optimization reasons.  Code-locations in these blocks are unsuitable for
-stepping tools, and the first code-location has nothing to do with a normal
-starting location for the block.
-\enddefun
-
-
-
-\node Breakpoints, Code-locations, Debug-blocks, Debugger Programmer's Interface
-\section{Breakpoints}
-
-A breakpoint represents a function the system calls with the current frame when
-execution passes a certain code-location.  A break point is active or inactive
-independent of its existence.  They also have an extra slot for users to tag
-the breakpoint with information.
-
-\defun{make-breakpoint}{hook-function what
-			 \keys{:kind :info :function-end-cookie}}
-This function creates and returns a breakpoint.  When program execution
-encounters the breakpoint, the system calls \var{hook-function}.
-\var{Hook-function} takes the current frame for the function in which the
-program is running and the breakpoint object.
-
-\var{what} and \var{kind} determine where in a function the system invokes
-\var{hook-function}.  \var{what} is either a code-location or a
-debug-function.  \var{kind} is one of \code{:code-location}, 
-\code{:function-start}, or \code{:function-end}.  Since the starts and ends of
-functions may not have code-locations representing them, designate these places
-by supplying \var{what} as a debug-function and \var{kind} indicating the
-\code{:function-start} or \code{:function-end}.  When \var{what} is a
-debug-function and \var{kind} is \code{:function-end}, then hook-function must
-take two additional arguments, a list of values returned by the function and a
-function-end-cookie.
-
-\var{info} is information supplied by and used by the user.
-
-\var{function-end-cookie} is a function.  To implement function-end
-breakpoints, the system uses starter breakpoints to establish the function-end
-breakpoint for each invocation of the function.  Upon each entry, the system
-creates a unique cookie to identify the invocation, and when the user supplies
-a function for this argument, the system invokes it on the cookie.  The system
-later invokes the function-end breakpoint hook on the same cookie.  The user
-may save the cookie when passed to the function-end-cookie function for
-later comparison in the hook function.
-
-This signals an error if \var{what} is an unknown code-location.
-\enddefun
-
-
-\defun{activate-breakpoint}{breakpoint}
-This function causes the system to invoke the \var{breakpoint}'s hook-function
-until the next call to \code{deactivate-breakpoint} or \code{delete-breakpoint}.
-The system invokes breakpoint hook functions in the opposite order that you
-activate them.
-\enddefun
-
-
-\defun{deactivate-breakpoint}{breakpoint}
-This function stops the system from invoking the \var{breakpoint}'s
-hook-function.
-\enddefun
-
-
-\defun{breakpoint-active-p}{breakpoint}
-This returns whether \var{breakpoint} is currently active.
-\enddefun
-
-
-\defun{breakpoint-hook-function}{breakpoint}
-This function returns the \var{breakpoint}'s function the system calls when
-execution encounters \var{breakpoint}, and it is active.  This is 
-\code{SETF}'able.
-\enddefun
-
-
-\defun{breakpoint-info}{breakpoint}
-This function returns \var{breakpoint}'s information supplied by the user.
-This is \code{SETF}'able.
-\enddefun
-
-
-\defun{breakpoint-kind}{breakpoint}
-This function returns the \var{breakpoint}'s kind specification.
-\enddefun
-
-
-\defun{breakpoint-what}{breakpoint}
-This function returns the \var{breakpoint}'s what specification.
-\enddefun
-
-
-\defun{delete-breakpoint}{breakpoint}
-This function frees system storage and removes computational overhead
-associated with \var{breakpoint}.  After calling this, \var{breakpoint} is
-useless and can never become active again.
-\enddefun
-
-
-
-\node Code-locations, Debug-sources, Breakpoints, Debugger Programmer's Interface
-\section{Code-locations}
-
-Code-locations represent places in functions where the system has correct
-information about the function's environment and where interesting operations
-can occur --- asking for a local variable's value, setting breakpoints,
-evaluating forms within the function's environment, etc.
-
-Sometimes the interface returns unknown code-locations.  These represent places
-in functions, but there is no debug information associated with them.  Some
-operations accept these since they may succeed even with missing debug data.
-These operations' argument is named \var{basic-code-location} indicating they
-take known and unknown code-locations.  If an operation names its argument
-\var{code-location}, and you supply an unknown one, it will signal an error.
-For example, \code{frame-code-location} may return an unknown code-location if
-someone interrupted Lisp in the given frame.  The system knows where execution
-will continue, but this place in the code may not be a place for which the
-compiler dumped debug information.
-
-\defun{code-location-debug-function}{basic-code-location}
-This function returns the debug-function representing information about the
-function corresponding to the code-location.
-\enddefun
-
-
-\defun{code-location-debug-block}{basic-code-location}
-This function returns the debug-block containing code-location if it is
-available.  Some debug policies inhibit debug-block information, and if none is
-available, then this signals a \code{no-debug-blocks} condition.
-\enddefun
-
-
-\defun{code-location-top-level-form-offset}{code-location}
-This function returns the number of top-level forms before the one containing
-\var{code-location} as seen by the compiler in some compilation unit.  A
-compilation unit is not necessarily a single file, see the section on
-debug-sources.
-\enddefun
-
-
-\defun{code-location-form-number}{code-location}
-This function returns the number of the form corresponding to 
-\var{code-location}.  The form number is derived by walking the subforms of a
-top-level form in depth-first order.  While walking the top-level form, count
-one in depth-first order for each subform that is a cons.  See
-\funref{form-number-translations}. 
-\enddefun
-
-
-\defun{code-location-debug-source}{code-location}
-This function returns \var{code-location}'s debug-source.
-\enddefun
-
-
-\defun{code-location-unknown-p}{basic-code-location}
-This function returns whether \var{basic-code-location} is unknown.  It returns
-\nil when the code-location is known.
-\enddefun
-
-
-\defun{code-location=}{code-location1 code-location2}
-This function returns whether the two code-locations are the same.
-\enddefun
-
-
-
-\node Debug-sources, Source Translation Utilities, Code-locations, Debugger Programmer's Interface
-\section{Debug-sources}
-
-Debug-sources represent how to get back the source for some code.  The source
-is either a file (\code{compile-file} or \code{load}), a lambda-expression
-(\code{compile}, \code{defun}, \code{defmacro}), or a stream (something
-particular to CMU Common Lisp, \code{compile-from-stream}).
-
-When compiling a source, the compiler counts each top-level form it processes,
-but when the compiler handles multiple files as one block compilation, the
-top-level form count continues past file boundaries.  Therefore
-\code{code-location-top-level-form-offset} returns an offset that does not
-always start at zero for the code-location's debug-source.  The offset into a
-particular source is \code{code-location-top-level-form-offset} minus
-\code{debug-source-root-number}.
-
-Inside a top-level form, a code-location's form number indicates the subform
-corresponding to the code-location.  
-
-\defun{debug-source-from}{debug-source}
-This function returns an indication of the type of source.  The following
-are the possible values:
-\begin{description}
-\item[\code{:file}]
-from a file (obtained by \code{compile-file} if compiled).
-\item[\code{:lisp}]
-from Lisp (obtained by \code{compile} if compiled).
-\item[\code{:stream}]
-from a non-file stream (CMU Common Lisp supports \code{compile-from-stream}).
-\end{description}
-\enddefun
-
-
-\defun{debug-source-name}{debug-source}
-This function returns the actual source in some sense represented by
-debug-source, which is related to \code{debug-source-from}:
-\begin{description}
-\item[\code{:file}]
-the pathname of the file.
-\item[\code{:lisp}]
-a lambda-expression.
-\item[\code{:stream}]
-some descriptive string that's otherwise useless.
-\end{description}
-\enddefun
-
-
-\defun{debug-source-created}{debug-source}
-This function returns the universal time someone created the source.  This
-may be \nil if it is unavailable.
-\enddefun
-
-
-\defun{debug-source-compiled}{debug-source}
-This function returns the time someone compiled the source.  This is \nil
-if the source is uncompiled.
-\enddefun
-
-
-\defun{debug-source-root-number}{debug-source}
-This returns the number of top-level forms processed by the compiler before
-compiling this source.  If this source is uncompiled, this is zero.  This may
-be zero even if the source is compiled since the first form in the first file
-compiled in one compilation, for example, must have a root number of zero ---
-the compiler saw no other top-level forms before it.
-\enddefun
-
-
-\node Source Translation Utilities,  , Debug-sources, Debugger Programmer's Interface
-\section{Source Translation Utilities}
-
-These two functions provide a mechanism for converting the rather
-obscure (but highly compact) representation of source locations into an
-actual source form:
-
-\defun{debug-source-start-positions}{debug-source}
-This function returns the file position of each top-level form as an array if
-\var{debug-source} is from a \code{:file}.  If \code{debug-source-from} is 
-\code{:lisp} or \code{:stream}, this returns \nil.
-\enddefun
-
-
-\defun{form-number-translations}{form tlf-number}
-This function returns a table mapping form numbers (see
-\code{code-location-form-number}) to source-paths.  A source-path indicates a
-descent into the top-level-form \var{form}, going directly to the subform
-corresponding to a form number.  \var{Tlf-number} is the top-level-form number
-of \var{form}.
-\enddefun
-
-
-\defun{source-path-context}{form path context}
-This function returns the subform of \var{form} indicated by the source-path.
-\var{Form} is a top-level form, and \var{path} is a source-path into it.  
-\var{Context} is the number of enclosing forms to return instead of directly
-returning the source-path form.  When \var{context} is non-zero, the
-form returned contains a marker, \code{\#:****HERE****}, immediately
-before the form indicated by \var{path}.
-\enddefun
-
-
-
-\twocolumn
-\node Function Index, Variable Index, Debugger Programmer's Interface, Top
-\unnumbered{Function Index}
-\cindex{Function Index}
-
-\printindex{fn}
-
-\twocolumn
-\node Variable Index, Type Index, Function Index, Top
-\unnumbered{Variable Index}
-\cindex{Variable Index}
-
-\printindex{vr}
-
-\twocolumn
-\node Type Index, Concept Index, Variable Index, Top
-\unnumbered{Type Index}
-\cindex{Type Index}
-
-\printindex{tp}
-
-\onecolumn
-\node Concept Index,  , Type Index, Top
-\unnumbered{Concept Index}
-\cindex{Concept Index}
-
-\printindex{cp}
-\end{document}
diff --git a/docs/database/cmulisp-fmt.el b/docs/database/cmulisp-fmt.el
deleted file mode 100644
index c15ce5c44c986dabd3eb3951b28dcc67bb232018..0000000000000000000000000000000000000000
--- a/docs/database/cmulisp-fmt.el
+++ /dev/null
@@ -1,146 +0,0 @@
-(load "clisp-fmt")
-(load "funref-fmt")
-
-(put 'defvar 'latexinfo-deffn-formatting-property
-     'latexinfo-format-specialized-defvar)
-
-(put 'defvarx 'latexinfo-deffn-formatting-property
-     'latexinfo-format-specialized-defvar)
-
-(defun latexinfo-format-specialized-defvar (parsed-args)
-  ;; Specialized variable-like entity:
-  ;; \defvar{name}               In Info, `Variable: Name'
-  ;; Use cdr of command-type to determine category:
-  (let ((category (car (cdr command-type)))
-        (name (car parsed-args))
-        (args (cdr parsed-args)))
-    (if (not (looking-at "\n")) (insert "\n"))
-    (insert " -- " category ": " "*" name "*")
-    (while args
-      (insert " "
-              (if (= ?& (aref (car args) 0))
-                  (car args)
-                (upcase (car args)))
-	      "\n")
-      (setq args (cdr args)))))
-
-
-
-(put 'python 'latexinfo-format 'latexinfo-format-python)
-(defun latexinfo-format-python ()
-  (latexinfo-parse-noarg)
-  (insert "Python"))
-
-(put 'Python 'latexinfo-format 'latexinfo-format-Python)
-(defun latexinfo-format-Python ()
-  (latexinfo-parse-noarg)
-  (insert "Python"))
-
-(put 'hemlock 'latexinfo-format 'latexinfo-format-hemlock)
-(defun latexinfo-format-hemlock ()
-  (latexinfo-parse-noarg)
-  (insert "hemlock"))
-
-(put 'Hemlock 'latexinfo-format 'latexinfo-format-Hemlock)
-(defun latexinfo-format-Hemlock ()
-  (latexinfo-parse-noarg)
-  (insert "Hemlock"))
-
-(put 'clisp 'latexinfo-format 'latexinfo-format-clisp)
-(defun latexinfo-format-clisp ()
-  (latexinfo-parse-noarg)
-  (insert "Common Lisp"))
-
-(put 'cmucl 'latexinfo-format 'latexinfo-format-cmucl)
-(defun latexinfo-format-cmucl ()
-  (latexinfo-parse-noarg)
-  (insert "CMU Common Lisp"))
-
-(put 'cmulisp 'latexinfo-format 'latexinfo-format-cmulisp)
-(defun latexinfo-format-clisp ()
-  (latexinfo-parse-noarg)
-  (insert "CMU Common Lisp"))
-
-(put 'alien 'latexinfo-format 'latexinfo-format-alien)
-(defun latexinfo-format-alien ()
-  (latexinfo-parse-noarg)
-  (insert "alien"))
-
-(put 'Alien 'latexinfo-format 'latexinfo-format-Alien)
-(defun latexinfo-format-Alien ()
-  (latexinfo-parse-noarg)
-  (insert "Alien"))
-
-(put 'Aliens 'latexinfo-format 'latexinfo-format-Aliens)
-(defun latexinfo-format-Aliens ()
-  (latexinfo-parse-noarg)
-  (insert "Aliens"))
-
-(put 'aliens 'latexinfo-format 'latexinfo-format-aliens)
-(defun latexinfo-format-aliens ()
-  (latexinfo-parse-noarg)
-  (insert "aliens"))
-
-(put 'Llisp 'latexinfo-format 'latexinfo-format-llisp)
-(put 'llisp 'latexinfo-format 'latexinfo-format-llisp)
-(defun latexinfo-format-llisp ()
-  (latexinfo-parse-noarg)
-  (insert "Common Lisp"))
-
-(put 'cltl 'latexinfo-format 'latexinfo-format-cltl)
-(defun latexinfo-format-cltl ()
-  (latexinfo-parse-noarg)
-  (insert "\i{Common Lisp: The Language}"))
-
-(put 'hinge 'latexinfo-format 'latexinfo-format-hinge)
-(defun latexinfo-format-hinge ()
-  (latexinfo-parse-noarg)
-  )
-
-(put 'hfill 'latexinfo-format 'latexinfo-format-hfill)
-(defun latexinfo-format-hfill ()
-  (latexinfo-parse-noarg))
-
-(put 'hide 'latexinfo-format 'latexinfo-parse-required-argument)
-(put 'ux 'latexinfo-format 'latexinfo-parse-required-argument)
-
-(put 'dash 'latexinfo-format 'latexinfo-format-dash)
-(defun latexinfo-format-dash ()
-  (latexinfo-parse-noarg)
-  (insert "--"))
-
-(put 'kwd 'latexinfo-format 'latexinfo-format-kwd)
-(defun latexinfo-format-kwd ()
-  (insert ":" (latexinfo-parse-arg-discard) )
-  (goto-char latexinfo-command-start))
-
-(put 'multiple 'latexinfo-format 'latexinfo-format-noop)
-(put 'F 'latexinfo-format 'latexinfo-format-noop)
-
-(put 'keys 'latexinfo-format 'latexinfo-format-keys)
-(defun latexinfo-format-keys ()
-  (insert  "&keys " (latexinfo-parse-required-argument))
-  (goto-char latexinfo-command-start))
-
-(put 'args 'latexinfo-format 'latexinfo-format-args)
-(defun latexinfo-format-args ()
-  (insert (latexinfo-parse-required-argument))
-  (goto-char latexinfo-command-start))
-
-(put 'morekeys 'latexinfo-format 'latexinfo-format-morekeys)
-(put 'yetmorekeys 'latexinfo-format 'latexinfo-format-morekeys)
-(defun latexinfo-format-morekeys ()
-  (insert  "      " (latexinfo-parse-required-argument))
-  (goto-char latexinfo-command-start))
-
-
-(put 'findexed 'latexinfo-format 'latexinfo-format-noop)
-(put 'vindexed 'latexinfo-format 'latexinfo-format-noop)
-(put 'tindexed 'latexinfo-format 'latexinfo-format-noop)
-(put 'conindexed 'latexinfo-format 'latexinfo-format-noop)
-(put 'vrindex 'latexinfo-format 'latexinfo-format-noop)
-(put 'cpindex 'latexinfo-format 'latexinfo-format-noop)
-(put 'fnindex 'latexinfo-format 'latexinfo-format-noop)
-(put 'pgindex 'latexinfo-format 'latexinfo-format-noop)
-(put 'tpindex 'latexinfo-format 'latexinfo-format-noop)
-(put 'kyindex 'latexinfo-format 'latexinfo-format-noop)
diff --git a/docs/database/cmulisp.sty b/docs/database/cmulisp.sty
deleted file mode 100644
index 093591227eb6f166aef069bb9b8bf35cd341b993..0000000000000000000000000000000000000000
--- a/docs/database/cmulisp.sty
+++ /dev/null
@@ -1,119 +0,0 @@
-\input{clisp.sty}
-\input{funref.sty}
-
-\def\researchcredit{
-This research was sponsored by the Defense Advanced
-Research Projects Agency, Information Science and Technology Office,
-under the title \i{Research on Parallel Computing} issued by DARPA/CMO
-under Contract MDA972-90-C-0035 ARPA Order No. 7330.
-
-The views and conclusions contained in this document are those of the
-authors and should not be interpreted as representing the official
-policies, either expressed or implied, of the Defense Advanced Research
-Projects Agency or the U.S. government.
-}
-
-% Now stop making all imbedded control L's <Form Feed> act like \newpage
-\catcode`^^L = \active
-\def^^L{}
-
-% Was @comment[garbage...]
-\long\def\hide#1{}
-
-% See if we can squelch some of the noise in the default cross-reference
-% format.
-\def\xrefX [#1,#2,#3,#4,#5,#6]{section \ref{#1}, page\tie \pageref{#1}}
-
-% Wrap *'s around DEFVAR variables, but not in the vindex.
-\def\defvar{\defun@vspace\defvarx}
-\def\defvarx{\@defvrstar{Variable}}
-
-\def\@defvrstar#1#2{\outer\def\defun@type{#1}\outer\def\defun@name{*#2*}%
-\vrindexbold{#2}\label{VR:#2}%
-\@ifnextchar[{\@defvarpackage}{\@defvarnopackage}
-}
-
-%%% Hemlock Function
-\def\F#1{\code{#1}}
-
-%% Keywords
-\def\kwd#1{\code{:#1}}
-
-
-% Indexing (was fvpindex)
-
-\let\indexfont=\tt
-
-\def\findexed#1{\findex{#1}{\indexfont #1}}
-\def\vindexed#1{\vindex{#1}{\indexfont *#1*}}
-\def\conindexed#1{\vindex{#1}{\indexfont #1}}
-\def\tindexed#1{\tindex{#1}{\indexfont #1}}
-
-\newindex{vr}
-\newindex{fn}
-\newindex{tp}
-
-
-% Cross-referencing (was funref)
-
-% Add support for referencing functions.  This assumes clisp.sty
-% and must be loaded after clisp.sty
-\def\@defn#1#2{\outer\def\defun@type{#1}\outer\def\defun@name{#2}%
-\fnindexbold{#2}\label{FN:#2}%
-\@ifnextchar[{\@defunpackage}{\@defunnopackage}
-}
-
-\def\@defvr#1#2{\outer\def\defun@type{#1}\outer\def\defun@name{#2}%
-\vrindexbold{#2}\label{VR:#2}%
-\@ifnextchar[{\@defvarpackage}{\@defvarnopackage}
-}
-
-\def\@defmc#1#2{\outer\def\defun@type{#1}\outer\def\defun@name{#2}%
-\fnindexbold{#2}\label{FN:#2}%
-\@ifnextchar[{\@defmacpackage}{\@defmacnopackage}
-}
-
-\let\xlref=\xref	% the same indexes in LaTeX, but not in info
-\let\pxlref=\pxref	% the same indexes in LaTeX, but not in info
-
-% These are now supported.
-\def\funref#1{\findexed{#1} (page\tie\pageref{FN:#1})}
-\def\specref#1{\findexed{#1} (page\tie\pageref{FN:#1})}
-\def\macref#1{\findexed{#1} (page\tie\pageref{FN:#1})}
-\def\varref#1{\vindexed{#1} (page\tie\pageref{VR:#1})}
-\def\conref#1{\conindexed{#1} (page\tie\pageref{VR:#1})}
-
-
-% Abbreviations..
-
-\def\clisp{{Common Lisp}}
-
-\def\dash{---}
-\def\alien{{Alien}}
-\def\aliens{{Aliens}}
-\def\Aliens{{Aliens}}
-\def\Alien{{Alien}}
-\def\Hemlock{{Hemlock}}
-\def\hemlock{{Hemlock}}
-\def\python{{Python}}
-\def\Python{{Python}}
-\def\cmucl{{CMU Common Lisp}}
-\def\llisp{{Common Lisp}}
-\def\Llisp{{Common Lisp}}
-\def\cltl{{\i{Common Lisp: The Language}}}
-
-
-% Formatting, from cmu-proc.sty:
-
- \oddsidemargin -10pt \evensidemargin -10pt
- \topmargin -40pt \headheight 12pt \headsep 25pt
- \footheight 12pt \footskip 30pt 
-
-\textheight 9.25in \textwidth 6.75in \columnsep .375in \columnseprule 0pt 
-
-
-\def\@oddhead{}\def\@evenhead{}
-\def\@oddfoot{}
-\def\@evenfoot{\@oddfoot}
-
-\sloppy
diff --git a/docs/database/dbolio.lib b/docs/database/dbolio.lib
deleted file mode 100644
index 2ee721a1c062eaa2222b5e8220d28849e95140e4..0000000000000000000000000000000000000000
--- a/docs/database/dbolio.lib
+++ /dev/null
@@ -1,324 +0,0 @@
-@Marker(Library, DBOLIO, Press, Dover, Postscript)
-
-
-@Modify(Chapter,TitleForm 
-{@Begin(Hd1A, Below 0.8 in)@Skip(0.8 in)@*Chapter @Parm(Numbered)@*@Skip(0.3 in)@*@Parm(Title)@End(Hd1A)},
-	ContentsForm
-{@Begin(Tc1)@Rfstr(@Parm(Page))@Parm(Referenced)@.@ @Parm(Title)@End(Tc1)},
-	  Numbered [@1],IncrementedBy Use,Referenced [@1],Announced)
-@Modify(Appendix,TitleEnv HD1,ContentsEnv tc1,Numbered [@A.],
-	 ContentsForm "@Tc1(Appendix @Parm(Referenced)@.@ @Rfstr(@Parm(Page))@parm(Title))",
-	 TitleForm "@Hd1(@=Appendix @Parm(Referenced)@*@=@Parm(Title))",
-	  IncrementedBy,Referenced [@A],Announced) @Comment{Alias Chapter}
-@Define(F, Facecode F)
-@Define(Sail, Facecode U)
-@Define(Arrow, Facecode N)
-@Commandstring(Minussign = "")
-@Commandstring(Centerdot = "@Begin(W, script +0.4 quad).@End(W)")
-@Commandstring(Tilde = "@Begin(W, script +0.4 quad)~@End(W)")
-@Commandstring(Underscore = "_")
-@Commandstring(Bq = "@;`")
-@Form(Complex = "@f[#C(@Parm(R) @Parm(I))]")
-@Textform(Altmode = "<altmode>")
-@Define(DenseDescription = Description, Spread .3)
-@Define(Defenvironment = Text, Need 4, Nofill, Justification Off, Break,
-		Above 2, Below 2, Spread 0.5)
-@Define(Defbody = Text, Leftmargin +.6in, Indent 0, Spread 0.5, Break)
-@Define(Undefbody = Text, Nofill, Justification Off, Leftmargin -.6in,
-		Above 0, Below 0, Group, Break)
-@Define(Lispenvironment = Verbatim, Group, Leftmargin +.3in, Above .5, Below .5)
-@Commandstring(Nopara = "@Begin(Text, Continue Force)@End(Text)")
-@Commandstring(Optional = "@f[&optional]")
-@Commandstring(Rest = "@f[&rest]")
-@Commandstring(Key = "@f[&key]")
-@Commandstring(allowotherkeys = "@f[&allow-other-keys]")
-@Commandstring(Aux = "@f[&aux]")
-@Commandstring(Body = "@f[&body]")
-@Commandstring(Whole = "@f[&whole]")
-@Commandstring(Special = "@f[&special]")
-@Commandstring(Local = "@f[&local]")
-@Textform(Mopt = "@r{[}@Parm(Text)@r{]}")
-@Textform(Mgroup = "@r[{]@Parm(Text)@r[}]")
-@Textform(Mstar = "@r[{]@Parm(Text)@r[}*]")
-@Textform(Mplus = "@r[{]@Parm(Text)@r[}@+[+]]")
-@Commandstring(Mor = "@r[|]")
-@Commandstring(Lisp = "@Begin(Lispenvironment)@~")
-@Commandstring(Endlisp = "@End(Lispenvironment)")
-@Commandstring(Lispx = "@Begin(Text, Indent 0, Above .5)For example:@End(Text)@Lisp")
-@Comment{
- @Commandstring(EQ = "@Arrow[J]")
- @Commandstring(EV = "@Arrow[A]")
- @Commandstring(EX = "@Arrow[G]")
-}
- @Commandstring(EQ = "@f[<=>]")
- @Commandstring(EV = "@f[=>]")
- @Commandstring(EX = "@f[==>]")
-@Commandstring(lbracket = "@f{[}")
-@Commandstring(rbracket = "@f{]}")
-@Commandstring(lbrace = "@f[{]")
-@Commandstring(rbrace = "@f[}]")
-@define(subi = i)
-@define(subr = r)
-@define(superi = i)
-@define(supersail = sail)
-@define(superg = g)
-@commandstring(superminussign = "@minussign@;")
-@commandstring(supercenterdot = "@centerdot@;")
-@Commandstring(false = "@f[nil]")
-@Commandstring(nil = "@f[nil]")
-@Commandstring(empty = "@f[()]")
-@Commandstring(true = "@f[t]")
-@Commandstring(xlisp = "@r[L@c[isp]]")
-@Commandstring(clisp = "@r[C@c[ommon]] @xlisp")
-@Commandstring(lmlisp = "@PossiblyIndexedRef(K <ZetaLisp>,
-		E <@r[Z@c[eta]@xlisp]>, F <@r[Z@c[eta]@xlisp]>)")
-@Commandstring(newlisp = "@PossiblyIndexedRef(K <NIL>,
-		E <@r[N@c[il]]>, F <@r[N@c[il] (New Implementation of @xlisp]>)")
-@Commandstring(slisp = "@PossiblyIndexedRef(K <Spice LISP>,
-		E <@r[S@c[pice]] @xlisp>, F <@r[S@c[pice]] @xlisp>)")
-@Commandstring(lisp15 = "@PossiblyIndexedRef(K <Lisp 1.5>,
-		E <@xlisp @r[1.5]>, F <@xlisp @r[1.5]>)")
-@Commandstring(maclisp = "@PossiblyIndexedRef(K <MacLISP>,
-		E <@r[M@c[ac]]@xlisp>, F <@r[M@c[ac]]@xlisp>)")
-@Commandstring(franzlisp = "@PossiblyIndexedRef(K <Franz LISP>,
-		E <@r[F@c[ranz]] @xlisp>, F <@r[F@c[ranz]] @xlisp>)")
-@Commandstring(interlisp = "@PossiblyIndexedRef(K <InterLISP>,
-		E <@r[I@c[nter]]@xlisp>, F <@r[I@c[nter]]@xlisp>)")
-@Commandstring(stdlisp = "@PossiblyIndexedRef(K <Standard LISP>,
-		E <@r[S@c[tandard]] @xlisp>, F <@r[S@c[tandard]] @xlisp>)")
-@Commandstring(psl = "@PossiblyIndexedRef(K <Portable Standard LISP>,
-		E <@r[P@c[ortable] S@c[tandard]] @xlisp>, F <@r[P@c[ortable] S@c[tandard]] @xlisp>)")
-@Commandstring(s1lisp = "@PossiblyIndexedRef(K <S-1 Lisp>,
-		E <@r[S-1] @xlisp>, F <@r[S-1] @xlisp>)")
-@Commandstring(scheme = "@PossiblyIndexedRef(K <scheme>,
-		E <@r[S@c[cheme]]>, F <@r[S@c[cheme]]>)")
-@Commandstring(fortran = "@PossiblyIndexedRef(K <Fortran>,
-		E <@c[fortran]>, F <@c[fortran]>)")
-@Commandstring(algol = "@PossiblyIndexedRef(K <Algol>,
-		E <@c[algol]>, F <@c[algol]>)")
-@Commandstring(pascal = "@PossiblyIndexedRef(K <Pascal>,
-		E <@c[pascal]>, F <@c[pascal]>)")
-@Commandstring(ada = "@PossiblyIndexedRef(K <ADA>,
-		E <@c[ada]>, F <@c[ada]>)")
-@Commandstring(apl = "@PossiblyIndexedRef(K <APL>,
-		E <@c[apl]>, F <@c[apl]>)")
-@Commandstring(pl1 = "@PossiblyIndexedRef(K <PL/I>,
-		E <@c[pl/i]>, F <@c[pl/i]>)")
-@Commandstring(clanguage = "@PossiblyIndexedRef(K <C>,
-		E <@c[c]>, F <@c[c] language>)")
-@Define(Smallitemize=Itemize, Spread 0.5, Above 0.5, Below 0.5)
-
-@Marker(Library, DBOLIO, File)
-
-
-@Style(Justification Off)
-@Style(Linewidth 7.2 Inches)
-@Style(Indentation 0)
-@Modify(Chapter,TitleForm 
-{@Begin(Hd1A, Below 0.8 in)@Skip(0.8 in)@*Chapter @Parm(Numbered)@*@Skip(0.3 in)@*@Parm(Title)@End(Hd1A)},
-	ContentsForm
-{@Begin(Tc1)@Rfstr(@Parm(Page))@Parm(Referenced)@.@ @Parm(Title)@End(Tc1)},
-	  Numbered [@1],IncrementedBy Use,Referenced [@1],Announced)
-@Modify(Appendix,TitleEnv HD1,ContentsEnv tc1,Numbered [@A.],
-	 ContentsForm "@Tc1(Appendix @Parm(Referenced)@.@ @Rfstr(@Parm(Page))@parm(Title))",
-	 TitleForm "@Hd1(@=Appendix @Parm(Referenced)@*@=@Parm(Title))",
-	  IncrementedBy,Referenced [@A],Announced) @Comment{Alias Chapter}
-@Define(F, Capitalized)
-@Define(A, Initialize "[APL]")
-@Define(Sail = R)
-@Define(B = R)
-@Commandstring(Minussign = "-")
-@Commandstring(Tilde = "~")
-@Commandstring(Centerdot = ".")
-@Commandstring(Underscore = "_")
-@Commandstring(Bq = "@;`")
-@Form(Complex = "@f[#C(@Parm(R) @Parm(I))]")
-@Textform(Altmode = "$")
-@Define(DenseDescription = Description, Spread 0)
-@Define(Defenvironment = Text, Need 4, Nofill, Justification Off, Break,
-		Leftmargin +12, Indent -12, Above 2, Below 2, Spread 0.5)
-@Define(Defbody = Text, Leftmargin -6in, Indent 0, Spread 0.5, Break)
-@Define(Undefbody = Text, Justification Off, Leftmargin +6, Indent -12,
-		Above 0, Below 0, Group, Break)
-@Define(Lispenvironment = Verbatim, Group, Leftmargin +.5in, Above 1, Below 1)
-@Commandstring(Nopara = "@Begin(Text, Continue Force)@End(Text)")
-@Commandstring(Optional = "@f[&optional]")
-@Commandstring(Rest = "@f[&rest]")
-@Commandstring(Key = "@f[&key]")
-@Commandstring(allowotherkeys = "@f[&allow-other-keys]")
-@Commandstring(Aux = "@f[&aux]")
-@Commandstring(Body = "@f[&body]")
-@Commandstring(Whole = "@f[&whole]")
-@Commandstring(Special = "@f[&special]")
-@Commandstring(Local = "@f[&local]")
-@Textform(Mopt = "@r{[}@Parm(Text)@r{]}")
-@Textform(Mgroup = "@r[{]@Parm(Text)@r[}]")
-@Textform(Mstar = "@r[{]@Parm(Text)@r[}*]")
-@Textform(Mplus = "@r[{]@Parm(Text)@r[}@+[+]]")
-@Commandstring(Mor = "@r[|]")
-@Commandstring(Lisp = "@Begin(Lispenvironment)@~")
-@Commandstring(Endlisp = "@End(Lispenvironment)")
-@Commandstring(Lispx = "@Begin(Text, Indent 0, Above 0)For example:@End(Text)@Lisp")
-@Commandstring(EQ = "==")
-@Commandstring(EV = "->")
-@Commandstring(EX = "<=>")
-@Commandstring(lbracket = "@f{[}")
-@Commandstring(rbracket = "@f{]}")
-@Commandstring(lbrace = "@f[{]")
-@Commandstring(rbrace = "@f[}]")
-@define(subi = i)
-@define(subr = r)
-@define(superi = i)
-@define(supersail = sail)
-@define(superg = g)
-@commandstring(superminussign = "@minussign@;")
-@commandstring(supercenterdot = "@centerdot@;")
-@Commandstring(false = "@f[nil]")
-@Commandstring(nil = "@f[nil]")
-@Commandstring(empty = "@f[()]")
-@Commandstring(true = "@f[t]")
-@Commandstring(xlisp = "@r[L@c[isp]]")
-@Commandstring(clisp = "@r[C@c[ommon]] @xlisp")
-@Commandstring(lmlisp = "@PossiblyIndexedRef(K <ZetaLisp>,
-		E <@r[Z@c[eta]@xlisp]>, F <@r[Z@c[eta]@xlisp]>)")
-@Commandstring(newlisp = "@PossiblyIndexedRef(K <NIL>,
-		E <@r[N@c[il]]>, F <@r[N@c[il] (New Implementation of @xlisp]>)")
-@Commandstring(slisp = "@PossiblyIndexedRef(K <Spice LISP>,
-		E <@r[S@c[pice]] @xlisp>, F <@r[S@c[pice]] @xlisp>)")
-@Commandstring(lisp15 = "@PossiblyIndexedRef(K <Lisp 1.5>,
-		E <@xlisp @r[1.5]>, F <@xlisp @r[1.5]>)")
-@Commandstring(maclisp = "@PossiblyIndexedRef(K <MacLISP>,
-		E <@r[M@c[ac]]@xlisp>, F <@r[M@c[ac]]@xlisp>)")
-@Commandstring(franzlisp = "@PossiblyIndexedRef(K <Franz LISP>,
-		E <@r[F@c[ranz]] @xlisp>, F <@r[F@c[ranz]] @xlisp>)")
-@Commandstring(interlisp = "@PossiblyIndexedRef(K <InterLISP>,
-		E <@r[I@c[nter]]@xlisp>, F <@r[I@c[nter]]@xlisp>)")
-@Commandstring(stdlisp = "@PossiblyIndexedRef(K <Standard LISP>,
-		E <@r[S@c[tandard]] @xlisp>, F <@r[S@c[tandard]] @xlisp>)")
-@Commandstring(psl = "@PossiblyIndexedRef(K <Portable Standard LISP>,
-		E <@r[P@c[ortable] S@c[tandard]] @xlisp>, F <@r[P@c[ortable] S@c[tandard]] @xlisp>)")
-@Commandstring(s1lisp = "@PossiblyIndexedRef(K <S-1 Lisp>,
-		E <@r[S-1] @xlisp>, F <@r[S-1] @xlisp>)")
-@Commandstring(scheme = "@PossiblyIndexedRef(K <scheme>,
-		E <@c[scheme]>, F <@c[scheme]>)")
-@Commandstring(fortran = "@PossiblyIndexedRef(K <Fortran>,
-		E <@c[fortran]>, F <@c[fortran]>)")
-@Commandstring(algol = "@PossiblyIndexedRef(K <Algol>,
-		E <@c[algol]>, F <@c[algol]>)")
-@Commandstring(pascal = "@PossiblyIndexedRef(K <Pascal>,
-		E <@c[pascal]>, F <@c[pascal]>)")
-@Commandstring(ada = "@PossiblyIndexedRef(K <ADA>,
-		E <@c[ada]>, F <@c[ada]>)")
-@Commandstring(apl = "@PossiblyIndexedRef(K <APL>,
-		E <@c[apl]>, F <@c[apl]>)")
-@Commandstring(pl1 = "@PossiblyIndexedRef(K <PL/I>,
-		E <@c[pl/i]>, F <@c[pl/i]>)")
-@Commandstring(clanguage = "@PossiblyIndexedRef(K <C>,
-		E <@c[c]>, F <@c[c] language>)")
-@Define(Smallitemize=Itemize, Spread 0, Above 0, Below 0)
-
-@Marker(Library, DBOLIO)
-
-
-@Modify(Chapter,TitleForm 
-{@Begin(Hd1A, Below 0.8 in)@Skip(0.8 in)@*Chapter @Parm(Numbered)@*@Skip(0.3 in)@*@Parm(Title)@End(Hd1A)},
-	ContentsForm
-{@Begin(Tc1)@Rfstr(@Parm(Page))@Parm(Referenced)@.@ @Parm(Title)@End(Tc1)},
-	  Numbered [@1],IncrementedBy Use,Referenced [@1],Announced)
-@Modify(Appendix,TitleEnv HD1,ContentsEnv tc1,Numbered [@A.],
-	 ContentsForm "@Tc1(Appendix @Parm(Referenced)@.@ @Rfstr(@Parm(Page))@parm(Title))",
-	 TitleForm "@Hd1(@=Appendix @Parm(Referenced)@*@=@Parm(Title))",
-	  IncrementedBy,Referenced [@A],Announced) @Comment{Alias Chapter}
-@Define(F, Capitalized)
-@Define(A, Initialize "[APL]")
-@Define(Sail = R)
-@Define(B = R)
-@Commandstring(Minussign = "-")
-@Commandstring(Tilde = "~")
-@Commandstring(Centerdot = ".")
-@Commandstring(Underscore = "_")
-@Commandstring(Bq = "@;`")
-@Form(Complex = "@f[#C(@Parm(R) @Parm(I))]")
-@Textform(Altmode = "<altmode>")
-@Define(DenseDescription = Description, Spread 0)
-@Define(Defenvironment = Text, Need 4, Nofill, Justification Off, Break,
-		Leftmargin +12, Indent -12, Above 2, Below 2, Spread 0.5)
-@Define(Defbody = Text, Leftmargin -6, Indent 0, Spread 0.5, Break)
-@Define(Undefbody = Text, Justification Off, Leftmargin +6, Indent -12,
-		Above 0, Below 0, Group, Break)
-@Define(Lispenvironment = Verbatim, Group, Leftmargin +4, Above 1, Below 1)
-@Commandstring(Nopara = "@Begin(Text, Continue Force)@End(Text)")
-@Commandstring(Optional = "@f[&optional]")
-@Commandstring(Rest = "@f[&rest]")
-@Commandstring(Key = "@f[&key]")
-@Commandstring(allowotherkeys = "@f[&allow-other-keys]")
-@Commandstring(Aux = "@f[&aux]")
-@Commandstring(Body = "@f[&body]")
-@Commandstring(Whole = "@f[&whole]")
-@Commandstring(Special = "@f[&special]")
-@Commandstring(Local = "@f[&local]")
-@Textform(Mopt = "@r{[}@Parm(Text)@r{]}")
-@Textform(Mgroup = "@r[{]@Parm(Text)@r[}]")
-@Textform(Mstar = "@r[{]@Parm(Text)@r[}*]")
-@Textform(Mplus = "@r[{]@Parm(Text)@r[}@+[+]]")
-@Commandstring(Mor = "@r[|]")
-@Commandstring(Lisp = "@Begin(Lispenvironment)@~")
-@Commandstring(Endlisp = "@End(Lispenvironment)")
-@Commandstring(Lispx = "@Begin(Text, Indent 0, Above 0)For example:@End(Text)@Lisp")
-@Commandstring(EQ = "==")
-@Commandstring(EV = "->")
-@Commandstring(EX = "<=>")
-@Commandstring(lbracket = "@f{[}")
-@Commandstring(rbracket = "@f{]}")
-@Commandstring(lbrace = "@f[{]")
-@Commandstring(rbrace = "@f[}]")
-@define(subi = i)
-@define(subr = r)
-@define(superi = i)
-@define(supersail = sail)
-@define(superg = g)
-@commandstring(superminussign = "@minussign@;")
-@commandstring(supercenterdot = "@centerdot@;")
-@Commandstring(false = "@f[nil]")
-@Commandstring(nil = "@f[nil]")
-@Commandstring(empty = "@f[()]")
-@Commandstring(true = "@f[t]")
-@Commandstring(xlisp = "@r[L@c[isp]]")
-@Commandstring(clisp = "@r[C@c[ommon]] @xlisp")
-@Commandstring(lmlisp = "@PossiblyIndexedRef(K <ZetaLisp>,
-		E <@r[Z@c[eta]@xlisp]>, F <@r[Z@c[eta]@xlisp]>)")
-@Commandstring(newlisp = "@PossiblyIndexedRef(K <NIL>,
-		E <@r[N@c[il]]>, F <@r[N@c[il] (New Implementation of @xlisp)]>)")
-@Commandstring(slisp = "@PossiblyIndexedRef(K <Spice LISP>,
-		E <@r[S@c[pice]] @xlisp>, F <@r[S@c[pice]] @xlisp>)")
-@Commandstring(lisp15 = "@PossiblyIndexedRef(K <Lisp 1.5>,
-		E <@xlisp @r[1.5]>, F <@xlisp @r[1.5]>)")
-@Commandstring(maclisp = "@PossiblyIndexedRef(K <MacLISP>,
-		E <@r[M@c[ac]]@xlisp>, F <@r[M@c[ac]]@xlisp>)")
-@Commandstring(franzlisp = "@PossiblyIndexedRef(K <Franz LISP>,
-		E <@r[F@c[ranz]] @xlisp>, F <@r[F@c[ranz]] @xlisp>)")
-@Commandstring(interlisp = "@PossiblyIndexedRef(K <InterLISP>,
-		E <@r[I@c[nter]]@xlisp>, F <@r[I@c[nter]]@xlisp>)")
-@Commandstring(stdlisp = "@PossiblyIndexedRef(K <Standard LISP>,
-		E <@r[S@c[tandard]] @xlisp>, F <@r[S@c[tandard]] @xlisp>)")
-@Commandstring(psl = "@PossiblyIndexedRef(K <Portable Standard LISP>,
-		E <@r[P@c[ortable] S@c[tandard]] @xlisp>, F <@r[P@c[ortable] S@c[tandard]] @xlisp>)")
-@Commandstring(s1lisp = "@PossiblyIndexedRef(K <S-1 Lisp>,
-		E <@r[S-1] @xlisp>, F <@r[S-1] @xlisp>)")
-@Commandstring(scheme = "@PossiblyIndexedRef(K <scheme>,
-		E <@c[scheme]>, F <@c[scheme]>)")
-@Commandstring(fortran = "@PossiblyIndexedRef(K <Fortran>,
-		E <@c[fortran]>, F <@c[fortran]>)")
-@Commandstring(algol = "@PossiblyIndexedRef(K <Algol>,
-		E <@c[algol]>, F <@c[algol]>)")
-@Commandstring(pascal = "@PossiblyIndexedRef(K <Pascal>,
-		E <@c[pascal]>, F <@c[pascal]>)")
-@Commandstring(ada = "@PossiblyIndexedRef(K <ADA>,
-		E <@c[ada]>, F <@c[ada]>)")
-@Commandstring(apl = "@PossiblyIndexedRef(K <APL>,
-		E <@c[apl]>, F <@c[apl]>)")
-@Commandstring(pl1 = "@PossiblyIndexedRef(K <PL/I>,
-		E <@c[pl/i]>, F <@c[pl/i]>)")
-@Commandstring(clanguage = "@PossiblyIndexedRef(K <C>,
-		E <@c[c]>, F <@c[c] language>)")
-@Define(Smallitemize=Itemize, Spread 0, Above 0, Below 0)
diff --git a/docs/database/hem.lib b/docs/database/hem.lib
deleted file mode 100644
index 794efa037d3a95ea32dc4d73caa1e542326d2672..0000000000000000000000000000000000000000
--- a/docs/database/hem.lib
+++ /dev/null
@@ -1,71 +0,0 @@
-@marker(library, Hem, Press, Dover, Postscript)
-
-@Form(Defhvar = "@Begin(Defenvironment)@Comment(Tabset?)@~
-   @hid[@Parm(Var)]@imbed(val, def <@ @ (initial value @f[@parm(val)])>)@>[@i[@Hemlock Variable]]@\@~
-   @Send(FunList {@hid[@Parm(Var)] @>[@i[@Hemlock Variable]]@\})@~
-   @HVxindex@Parmquote(Var)@~
-   @Imbed(Nolabel, undef '@Imbed(Varlabel,
-                                  def <@Label{@Parm(Varlabel)-hvar}>,
-                                  undef <@Label{@Parm(Var)-hvar}>)')@~
-   @Begin(Defbody)@Tabclear ")
-
-@Form(Defhvar1 = "@Begin(Undefbody)@Comment(Tabset?)@~
-   @hid[@Parm(Var)]@imbed(val, def <@ @ (initial value @f[@parm(val)])>)@>[@i[@hemlock Variable]]@\@~
-   @Send(FunList {@hid[@Parm(Var)] @>[@i[@hemlock Variable]]@\})@~
-   @HVxindex@Parmquote(Var)@~
-   @Imbed(Nolabel, undef '@Imbed(Varlabel,
-                                  def <@Label{@Parm(Varlabel)-hvar}>,
-                                  undef <@Label{@Parm(Var)-hvar}>)')@~
-   @End(Undefbody)")
-
-@Commandstring(Enddefhvar = "@End(Defbody)@End(Defenvironment)")
-@Textform(HVxindex = "@Xindex(T {Hemlock variable}, X {@Parm(Text)}, P {@hid[@Parm(Text)]})@'")
-@Textform(HVindexref = "@Xindexref(T {Hemlock variable}, X {@Parm(Text)}, P {@hid[@Parm(Text)]})@'")
-@Textform(HVarref = '@hid[@Parm(Text)] @~
-    @r[(page @Pageref(@Parm(Text)-hvar))]@HVindexref@Parmquote(Text)')
-
-
-@Form(Defcom = "@Begin(Defenvironment)@Comment(Tabset?)@~
-   @hid[@Parm(Com)]@imbed(bind, def <@ @ (bound to @bf[@parm(bind)])>)@~
-   @imbed(Stuff, def <@ @ (@Parm(Stuff))>)@>[@i[Command]]@\@~
-   @Send(FunList {@hid[@Parm(Com)] @>[@i[Command]]@\})@~
-   @HCxindex@Parmquote(Com)@~
-   @Imbed(Nolabel, undef '@Imbed(Comlabel,
-                                  def <@Label{@Parm(Comlabel)-com}>,
-                                  undef <@Label{@Parm(Com)-com}>)')@~
-   @Begin(Defbody)@Tabclear ")
-
-
-@Form(Defcom1 = "@Begin(Undefbody)@Comment(Tabset?)@~
-   @hid[@Parm(Com)]@imbed(bind, def <@ @ (bound to @bf[@parm(bind)])>)@~
-   @imbed(Stuff, def <@ @ (@Parm(Stuff))>)@>[@i[Command]]@\@~
-   @Send(FunList {@hid[@Parm(Com)] @>[@i[Command]]@\})@~
-   @HCxindex@Parmquote(Com)@~
-   @Imbed(Nolabel, undef '@Imbed(Comlabel,
-                                  def <@Label{@Parm(Comlabel)-com}>,
-                                  undef <@Label{@Parm(Com)-com}>)')@~
-   @End(Undefbody)")
-
-
-@Commandstring(Enddefcom = "@End(Defbody)@End(Defenvironment)")
-@Textform(HCxindex = "@Xindex(T {Command}, X {@Parm(Text)}, P {@hid[@Parm(Text)]})@'")
-@Textform(HCindexref = "@Xindexref(T {Command}, X {@Parm(Text)}, P {@hid[@Parm(Text)]})@'")
-@Textform(Comref = '@hid[@Parm(Text) ]@~
-    @r[(page @Pageref(@Parm(Text)-com))]@HCindexref@Parmquote(Text)')
-
-
-@String(IndexFuns "Yes")
-@string(supresskeyindex "Yes")
-
-@specialfont(f1 = helvetica)
-@commandstring(Hemlock = "@f1(Hemlock)")
-@textform(hid = '@w{@f1{@parm(Text)}}')
-@commandstring[emacs = "@f1<Emacs>"]
-
-@specialfont(f2 = "SouvenirDemi")
-@textform<binding = "@f2[@w(@parm{text})]">
-@textform<bf = "@f2[@w(@parm{text})]">
-
-@commandstring[llisp = "L@c(isp)"]
-
-@commandstring[windows = "X windows"]
diff --git a/docs/database/outtir.lib b/docs/database/outtir.lib
deleted file mode 100644
index 428d1a416142c743844dab57252b9c1f6ef5769b..0000000000000000000000000000000000000000
--- a/docs/database/outtir.lib
+++ /dev/null
@@ -1,329 +0,0 @@
-@Comment{Version of BOLIO.LIB that provides a single unified index
-instead of separate indexes for functions, variables, constants,
-keywords, and concepts.}
-
-@Marker(Library, Uttir, Press, Dover, Postscript)
-
-@Libraryfile(DBolio)
-
-
-@Comment{Constraints on the definition of IndexEnvironment:
-	Indent = - LeftMargin
-	(Linewidth + Leftmargin + Columnmargin) * Columns - Columnmargin
-		 = global line width
-}
-@Define(IndexEnvironment, Boxed, Columns 2, Columnmargin 0.5in,
-        Linewidth 2.7in, Leftmargin +0.3in, Indent -0.3in)
-
-@Define(KeySpreadEnvironment, Facecode F)
-@Textform(SpreadKeys = "@KeySpreadEnvironment<@SpreadKeysLoop@Parm(Text)[]>")
-@Textform(SpreadKeysLoop =
-	"@String(SpreadKeysTemp = @Parmquote(Text))@Case(SpreadKeysTemp,
-	     null <>, else < :@Parm(Text)@SpreadKeysLoop>)")
-
-@Form(IndexKeys = "@Textform(IndexKeysLoop =
-	'@String(IndexKeysTemp = @Quote{@Parmquote(Text)})@Case(IndexKeysTemp,
-	    null <>, else [@Kindex2(P = @Quote{@Parmquote(Text)},
-				    S = {for@f( @Parm(Fun))})@IndexKeysLoop])')@IndexKeysLoop@Parm(Keys)[]@~")
-
-@Counter(UnNumberedIndex,TitleEnv HD1A,ContentsEnv tc1,Announced,Alias Chapter)
-
-@Textform(IndexHeadings = "@UnnumberedIndex@Parmquote(Text)
-@String(ChapterTitle = @Parmquote(Text))
-@Pageheading(Immediate, Left = <>, Right = <>)
-@Pagefooting(Immediate, Center = <@Value(Page)>)
-@Pageheading(Odd, Left = <@c[@Value(ChapterTitle)]>, Right = <@Value(Page)>)
-@Pageheading(Even, Left = <@Value(Page)>, Right = <@c[@Value(ReportTitle)]>)
-@Pagefooting(Center = <>)
-")
-
-@Textform(Incompatibility = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4)
-	@b[Compatibility note:] @Index(@b[Compatibility note])
-	@Parm(Text) @End(Quotation)")
-@Textform(Implementation = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4)
-	@b[Implementation note:] @Index(@b[Implementation note])
-	@Parm(Text) @End(Quotation)")
-@Textform(Rationale = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4)
-	@b[Rationale:] @Index(@b[Rationale]) @Parm(Text) @End(Quotation)")
-@Comment{
-@Textform(Query = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4)
-	@f[???] @b[Query:] @Index(@b[Query]) @Parm(Text) @End(Quotation)")
-}
-
-@Textform(Kwd = "@f[:@Parm(Text)]")
-@Textform(KeywordList = "
-	@Begin(Description)
-	@Textform(Keyword = '@Begin(Multiple)@~
-@f[:@Quote<@Parm(Text)>  ]@\@Kindex2(P = @Quote<@Parmquote(Text)>,
-			   S = {for@f[ @Parm(Text)]})@~
-		@Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~')
-	@Textform(FirstKeyword = '@Begin(Multiple)@~
-@f[:@Quote<@Parm(Text)> @r[or] ]@Kindex2(P = @Quote<@Parmquote(Text)>,
-			   S = {for@f[ @Parm(Text)]})@~
-		@Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~')
-	@Textform(NextKeyword = '@~
-@f[:@Quote<@Parm(Text)> @r[or] ]@Kindex2(P = @Quote<@Parmquote(Text)>,
-			   S = {for@f[ @Parm(Text)]})@~
-		@Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~')
-	@Textform(LastKeyword = '@~
-@f[:@Quote<@Parm(Text)>  ]@\@Kindex2(P = @Quote<@Parmquote(Text)>,
-			   S = {for@f[ @Parm(Text)]})@~
-		@Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~')
-	@Textform(SubKeywordList = '
-		@Begin(Description)
-		@Textform(SubKeyword = <@Begin(Multiple)@~
-@f[:@Quote{@Quote[@Parm(Text)]}  ]@\@Kindex2(P = @Quote{@Quote[@Parmquote(Text)]},
-			   S = {for@f[ @Quote[@Parm(Text)] ]option @~
-				to@f[ @Parm(Text)]})@~
-		@Label{@Parm(Text)-@Quote[@Parm(Text)]-@Quote{@Quote[@Parm(Text)]}-kwd}@~>)')
-")
-@Textform(PseudoKeyword = "@Begin(Multiple)@Parm(Text)   @\@~")
-@Commandstring(Endkeyword = "@End(Multiple)")
-@Commandstring(Endkeywordlist = "@End(Description)")
-@Textform(PseudoSubKeyword = "@Begin(Multiple)@Parm(Text)   @\@~")
-@Commandstring(EndSubKeyword = "@End(Multiple)")
-@Commandstring(EndSubKeywordlist = "@End(Description)")
-@Textform(RandomKeywordList = "
-	@Begin(Description)
-	@Index2(P = {Keywords}, S = {for@f[ ]@Parm(Text)})
-	@Textform(RandomKeyword = '@Begin(Multiple)
-@f[:@Quote<@Parm(Text)>  ]@\@Kindex2(P = @Quote<@Parmquote(Text)>,
-				     S = {for@f[ ]@Parm(Text)})@~')
-")
-@Textform(PseudoRandomKeyword = "@Begin(Multiple)@Parm(Text)   @\@~")
-@Commandstring(Endrandomkeyword = "@End(Multiple)")
-@Commandstring(Endrandomkeywordlist = "@End(Description)")
-
-@Form(Defvar = "@Begin(Defenvironment)@Comment(Tabset?)@~
-   @f[@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\@~
-   @Send(FunList {@f[@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\})@~
-   @Imbed(Nostar, undef<@Vindex@Parmquote(Var)>, def<@Vxindex@Parmquote(Var)>)@~
-   @Imbed(Nolabel, undef '@Imbed(Varlabel,
-			          def <@Label{@Parm(Varlabel)-var}>,
-			          undef <@Label{@Parm(Var)-var}>)')@~
-   @Begin(Defbody)@Tabclear ")
-@Form(Defvar1 = "@Begin(Undefbody)@Comment(Tabset?)@~
-   @f[@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\@~
-   @Send(FunList {@f[@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\})@~
-   @Imbed(Nostar, undef<@Vindex@Parmquote(Var)>, def<@Vxindex@Parmquote(Var)>)@~
-   @Imbed(Nolabel, undef '@Imbed(Varlabel,
-			          def <@Label{@Parm(Varlabel)-var}>,
-			          undef <@Label{@Parm(Var)-var}>)')@~
-   @End(Undefbody)")
-@Commandstring(Enddefvar = "@End(Defbody)@End(Defenvironment)")
-
-@Form(Defcon = "@Begin(Defenvironment)@Comment(Tabset?)@~
-   @f[@Parm(Var)] @>[@i[Constant]]@\@~
-   @Send(FunList {@f[@Parm(Var)] @>[@i[Constant]]@\})@~
-   @Conindex@Parmquote(Var)@~
-   @Imbed(Nolabel, undef '@Imbed(Varlabel,
-			          def <@Label{@Parm(Varlabel)-con}>,
-			          undef <@Label{@Parm(Var)-con}>)')@~
-   @Begin(Defbody)@Tabclear ")
-@Form(Defcon1 = "@Begin(Undefbody)@Comment(Tabset?)@~
-   @f[@Parm(Var)] @>[@i[Constant]]@\@~
-   @Send(FunList {@f[@Parm(Var)] @>[@i[Constant]]@\})@~
-   @Conindex@Parmquote(Var)@~
-   @Imbed(Nolabel, undef '@Imbed(Varlabel,
-			          def <@Label{@Parm(Varlabel)-con}>,
-			          undef <@Label{@Parm(Var)-con}>)')@~
-   @End(Undefbody)")
-@Commandstring(Enddefcon = "@End(Defbody)@End(Defenvironment)")
-
-@Form(Defun = "@Begin(Defenvironment)@Comment(Tabset?)@~
-   @f[@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys, def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\
-@Imbed(MoreKeys, def <@/@Spreadkeys(@Parm(MoreKeys))
->)@~
-@Imbed(YetMoreKeys, def <@/@Spreadkeys(@Parm(YetMoreKeys))
->)@~
-   @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys,
-	def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\@Imbed(MoreKeys,
-	def <
-@/@f[@Spreadkeys(@Parm(MoreKeys))]>)@Imbed(YetMoreKeys,
-	def <
-@/@f[@Spreadkeys(@Parm(YetMoreKeys))]>)})@~
-   @Findex@Parmquote(Fun)@~
-  @Imbed(SuppressKeyIndex, undef <
-   @Imbed(Keys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(Keys))')@~
-   @Imbed(MoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(MoreKeys))')@~
-   @Imbed(YetMoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(YetMoreKeys))')>)@~
-   @Imbed(Nolabel, undef '@Imbed(Funlabel,
-			          def <@Label{@Parm(Funlabel)-fun}>,
-			          undef <@Label{@Parm(Fun)-fun}>)')@~
-   @Begin(Defbody)@Tabclear ")
-@Form(Defun1 = "@Begin(Undefbody)@Comment(Tabset?)@~
-   @f[@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys, def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\
-@Imbed(MoreKeys, def <@/@Spreadkeys(@Parm(MoreKeys))
->)@~
-@Imbed(YetMoreKeys, def <@/@Spreadkeys(@Parm(YetMoreKeys))
->)@~
-   @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys,
-	def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\@Imbed(MoreKeys,
-	def <
-@/@f[@Spreadkeys(@Parm(MoreKeys))]>)@Imbed(YetMoreKeys,
-	def <
-@/@f[@Spreadkeys(@Parm(YetMoreKeys))]>)})@~
-   @Findex@Parmquote(Fun)@~
-  @Imbed(SuppressKeyIndex, undef <
-   @Imbed(Keys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(Keys))')@~
-   @Imbed(MoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(MoreKeys))')@~
-   @Imbed(YetMoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(YetMoreKeys))')>)@~
-   @Imbed(Nolabel, undef '@Imbed(Funlabel,
-			          def [@Label{@Parm(Funlabel)-fun}],
-			          undef [@Label{@Parm(Fun)-fun}])')@~
-   @End(Undefbody)")
-@Commandstring(Enddefun = "@End(Defbody)@End(Defenvironment)")
-
-@Form(Defmac = "@Begin(Defenvironment)@Comment(Tabset?)@~
-   @f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\@~
-   @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\})@~
-   @Mindex@Parmquote(Fun)@~
-   @Imbed(Nolabel, undef '@Imbed(Funlabel,
-			          def <@Label{@Parm(Funlabel)-mac}>,
-			          undef <@Label{@Parm(Fun)-mac}>)')@~
-   @Begin(Defbody)@Tabclear ")
-@Form(Defmac1 = "@Begin(Undefbody)@Comment(Tabset?)@~
-   @f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\@~
-   @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\})@~
-   @Mindex@Parmquote(Fun)@~
-   @Imbed(Nolabel, undef '@Imbed(Funlabel,
-			          def <@Label{@Parm(Funlabel)-mac}>,
-			          undef <@Label{@Parm(Fun)-mac}>)')@~
-   @End(Undefbody)")
-@Commandstring(Enddefmac = "@End(Defbody)@End(Defenvironment)")
-
-@Form(Defspec = "@Begin(Defenvironment)@Comment(Tabset?)@~
-   @f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\@~
-   @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\})@~
-   @Sindex@Parmquote(Fun)@~
-   @Imbed(Nolabel, undef '@Imbed(Funlabel,
-			          def <@Label{@Parm(Funlabel)-spec}>,
-			          undef <@Label{@Parm(Fun)-spec}>)')@~
-   @Begin(Defbody)@Tabclear ")
-@Form(Defspec1 = "@Begin(Undefbody)@Comment(Tabset?)@~
-   @f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\@~
-   @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\})@~
-   @Sindex@Parmquote(Fun)@~
-   @Imbed(Nolabel, undef '@Imbed(Funlabel,
-			          def <@Label{@Parm(Funlabel)-spec}>,
-			          undef <@Label{@Parm(Fun)-spec}>)')@~
-   @End(Undefbody)")
-@Commandstring(Enddefspec = "@End(Defbody)@End(Defenvironment)")
-
-@Textform(Xindent = "@hsp(2.0em)")
-@Textform(Xsepr = "@hsp(0.5em)")
-@Textform(Def = "@Index@Parmquote(Text)@i@Parmquote(Text)")
-@Textform(Index = "@Indexentry{Key {@Parm(Text) !1},
-             Entry {@r[@Parm(Text)]@Xsepr()}, Number {@r[@Parmvalue(Page)]}}@'")
-@Form(PossiblyIndexedRef = "@Indexentry{Key {@Parm(K) !1},
-             Entry {@r[@Parm(F)]@Xsepr()}, Number {@r[@Parmvalue(Page)]}}@Parm(E)")
-@Textform(Index1 = "@Indexentry{Key {@Parm(Text) !1},
-             Entry {@r[@Parm(Text)]@Xsepr()}}@'")
-@Form(Index2 = "@Index1@Parmquote(P)@Indexentry{Key {@Parm(P) !2 @Parm(S)},
-         Entry {@Xindent()@r[@Parm(S)]@Xsepr()}, Number {@Parmvalue(Page)}}@'")
-@Form(Seealso = "@Index1@Parmquote(P)@Indexentry{Key {@Parm(P) !3 @Parm(S)},
-         Entry {@Xindent()@Xindent()@r[See also:]}, Number @Parmquote(S)}@'")
-@Form(Xindex = "@Indexentry{Key {@Parm(X) @Parm(T) 1},
-         Entry {@Parm(Q, default <>)@Parm(P)@Parm(R, default <>)@f[ ]@r[@Parm(T)]@Xsepr()},
-	 Number {@b[@Parmvalue(Page)]}}@'")
-@Form(Xindexref = "@Indexentry{Key {@Parm(X) @Parm(T) 1},
-         Entry {@Parm(Q, default <>)@Parm(P)@Parm(R, default <>)@f[ ]@r[@Parm(T)]@Xsepr()},
-	 Number {@Parmvalue(Page)}}@'")
-@Form(Xindex1 = "@Indexentry{Key {@Parm(X) @Parm(T) 1},
-         Entry {@Parm(Q, default <>)@Parm(P)@Parm(R, default <>)@f[ ]@r[@Parm(T)]@Xsepr()}}@'")
-@Form(Xindex2 = "@Xindex1(X @Parmquote(X), T @Parmquote(T),
-			  P @Parmquote(P)@Imbed(Q, def <, Q @Parmquote(Q)>)@Imbed(R, def <, R @Parmquote(R)>))@~
-         @Indexentry{Key {@Parm(X) @Parm(T) 2 @Parm(S)},
-		     Entry {@Xindent()@Parm(S)@Xsepr()},
-		     Number {@b[@Parmvalue(Page)]}}@'")
-@Form(Xindexref2 = "@Xindex1(X @Parmquote(X), T @Parmquote(T),
-			     P @Parmquote(P)@Imbed(Q, def <, Q @Parmquote(Q)>)@Imbed(R, def <, R @Parmquote(R)>))@~
-         @Indexentry{Key {@Parm(X) @Parm(T) 2 @Parm(S)},
-		     Entry {@Xindent()@Parm(S)@Xsepr()},
-		     Number {@Parmvalue(Page)}}@'")
-@Form(Xseealso = "@Xindex1(X @Parmquote(X), T @Parmquote(T),
-			   P @Parmquote(P)@Imbed(Q, def <, Q @Parmquote(Q)>)@Imbed(R, def <, R @Parmquote(R)>))@~
-         @Indexentry{Key {@Parm(X) @Parm(T) 3 @Parm(S)},
-		     Entry {@Xindent()@Xindent()@r[See also:]},
-		     Number @Parmquote(S)}}@'")
-
-@Textform(Cindex = "@Index@Parmquote(Text)@'")
-
-@Textform(Findex = "@Case(IndexFuns, Yes '@Xindex(T {function}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'")
-@Textform(Findexref = "@Case(IndexFuns, Yes '@Xindexref(T {function}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'")
-@Form(Findex2 = "@Case(IndexFuns, Yes '@Xindex2(T {function}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'")
-@Form(Fseealso = "@Case(IndexFuns, Yes '@Xseealso(T {function}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'")
-
-@Textform(Mindex = "@Case(IndexFuns, Yes '@Xindex(T {macro}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'")
-@Textform(Mindexref = "@Case(IndexFuns, Yes '@Xindexref(T {macro}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'")
-@Form(Mindex2 = "@Case(IndexFuns, Yes '@Xindex2(T {macro}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'")
-@Form(Mseealso = "@Case(IndexFuns, Yes '@Xseealso(T {macro}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'")
-
-@Textform(Sindex = "@Case(IndexFuns, Yes '@Xindex(T {special form}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'")
-@Textform(Sindexref = "@Case(IndexFuns, Yes '@Xindexref(T {special form}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'")
-@Form(Sindex2 = "@Case(IndexFuns, Yes '@Xindex2(T {special form}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'")
-@Form(Sseealso = "@Case(IndexFuns, Yes '@Xseealso(T {special form}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'")
-
-@Textform(Vindex = "@Xindex(T {variable}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[*]}, R{@f[*]})@'")
-@Textform(Vxindex = "@Xindex(T {variable}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Textform(Vindexref = "@Xindexref(T {variable}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[*]}, R{@f[*]})@'")
-@Form(Vindex2 = "@Xindex2(T {variable}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[*]}, R{@f[*]})@'")
-@Form(Vseealso = "@Xseealso(T {variable}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[*]}, R{@f[*]})@'")
-
-@Textform(Conindex = "@Xindex(T {constant}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Textform(Conindexref = "@Xindexref(T {constant}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Form(Conindex2 = "@Xindex2(T {constant}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'")
-@Form(Conseealso = "@Xseealso(T {constant}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'")
-
-@Textform(Kindex = "@Xindex(T {keyword}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[:]})@'")
-@Textform(Kindexref = "@Xindexref(T {keyword}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[:]})@'")
-@Form(Kindex2 = "@Xindex2(T {keyword}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[:]})@'")
-@Form(Kindexref2 = "@Xindexref2(T {keyword}, X {@Parm(K)}, P {@f[@Parm(K)]}, S @Parmquote(S), Q {@f[:]})@'")
-@Form(Kseealso = "@Xseealso(T {keyword}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[:]})@'")
-
-@Textform(Declindex = "@Xindex(T {declaration}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Textform(Declindexref = "@Xindexref(T {declaration}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Form(Declindex2 = "@Xindex2(T {declaration}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'")
-@Form(Declseealso = "@Xseealso(T {declaration}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'")
-
-@Textform(Typeindex = "@Xindex(T {type specifier}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Textform(Typeindexref = "@Xindexref(T {type specifier}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Form(Typeindex2 = "@Xindex2(T {type specifier}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'")
-@Form(Typeseealso = "@Xseealso(T {type specifier}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'")
-
-@Textform(Funref = "@f[@Parm(Text) ]@~
-    @r[(page @Pageref(@Parm(Text)-fun))]@Findexref@Parmquote(Text)@;")
-@Textform(Funreftab = "@f[@Parm(Text) ]@\@r[(page @Pageref(@Parm(Text)-fun))]@Findexref@Parmquote(Text)@;")
-@Form(Xfunref = "@f[@Parm(X) ]@~
-    @r[(page @Pageref(@Parm(L)-fun))]@Findexref@Parmquote(X)@;")
-@Textform(Macref = "@f[@Parm(Text) ]@~
-    @r[(page @Pageref(@Parm(Text)-mac))]@Mindexref@Parmquote(Text)@;")
-@Textform(Macreftab = "@f[@Parm(Text) ]@\@r[(page @Pageref(@Parm(Text)-mac))]@Mindexref@Parmquote(Text)@;")
-@Form(Xmacref = "@f[@Parm(X) ]@~
-    @r[(page @Pageref(@Parm(L)-mac))]@Mindexref@Parmquote(X)@;")
-@Textform(Specref = "@f[@Parm(Text) ]@~
-    @r[(page @Pageref(@Parm(Text)-spec))]@Sindexref@Parmquote(Text)@;")
-@Textform(Specreftab = "@f[@Parm(Text) ]@\@r[(page @Pageref(@Parm(Text)-spec))]@Sindexref@Parmquote(Text)@;")
-@Form(XSpecref = "@f[@Parm(X) ]@~
-    @r[(page @Pageref(@Parm(L)-spec))]@Sindexref@Parmquote(X)@;")
-@Textform(Var = "@f[*@Parm(Text)*]")
-@Textform(Varref = "@f[*@Parm(Text)* ]@~
-    @r[(page @Pageref(@Parm(Text)-var))]@Vindexref@Parmquote(Text)@;")
-@Form(Xvarref = "@f[*@Parm(X)* ]@~
-    @r[(page @Pageref(@Parm(L)-var))]@Vindexref@Parmquote(X)@;")
-@Textform(Conref = "@f[@Parm(Text) ]@~
-    @r[(page @Pageref(@Parm(Text)-con))]@Conindexref@Parmquote(Text)@;")
-@Form(Xconref = "@f[@Parm(X) ]@~
-    @r[(page @Pageref(@Parm(L)-con))]@Conindexref@Parmquote(X)@;")
-@Form(Kwdref = "@f[:@Parm(K) ]@~
-    @r[(page @Pageref(@Parm(F)-@Parm(K)-kwd))]@Kindexref2(S {for@f[ @Parm(F)]},
-						      K @Parmquote(K))@;")
-@Form(SubKwdref = "@f[:@Parm(K)] @~
-    @r[(page @Pageref(@Parm(F)-@Parm(O)-@Parm(K)-kwd))]@~
-	@Kindexref2(S {for@f[ :@Parm(O) ]option to@f[ @Parm(F)]},
-		    K @Parmquote(K))")
-
-@Indexentry(Key {  1}, Entry {@IndexHeadings[Index]@Blankspace(1)@Begin(IndexEnvironment)})
-@Indexentry(Key {~~~ }, Entry {@End(IndexEnvironment)})
-
-@Textform(IndexCleanup = " ")
diff --git a/docs/database/spice.lib b/docs/database/spice.lib
deleted file mode 100644
index a6520620e2c2b17d1fe1359e1183eac8639f30b7..0000000000000000000000000000000000000000
--- a/docs/database/spice.lib
+++ /dev/null
@@ -1,67 +0,0 @@
-@Marker(Library, Spice, Press, Dover, Postscript)
-
-@libraryfile(table)
-@modify(HD3, above 0.3inch, below 0.15inch)
-@modify(HD2, below 0.25inch)
-@modify[HD4, above .3inch, below 0, break before]
-@modify(paragraph, 
-	ContentsForm=" ", 
-	TitleForm="@HD4[@parm(title)@hsp(1quad)]",
-	numbered [], referenced [])
-@textform(mline="@enter(liner,script +5pts)@tabclear()@&@ @\@leave(liner)")
-
-@define(twocolumn,columns 2,columnmargin 1cm,spacing 12pts,boxed,
-	linewidth 3inch)
-
-@form(SpiceTitlePage={
-@begin(titlepage)
-@begin(titlebox,centered)
-@majorheading(CARNEGIE-MELLON UNIVERSITY)
-@heading(DEPARTMENT@  OF@  COMPUTER@  SCIENCE)
-@heading[SPICE@  PROJECT]
-@begin(format, leftmargin +1.10inch, rightmargin +1.10inch)
-@mline()
-@begin(center, spacing 1)
-@heading[@Parm(Title)]
-
-@Parm(Author)
-
-@Parm(Date,default="@value(date)")
-@end(center)
-@mline()
-@end(format)
-@end(titlebox)
-
-@Parm(cruft, default="")
-
-@begin(center,spacing 1.3, above .5inch)
-Keywords and index categories: @Parm(Index,default="<not specified>")
-Location of machine-readable File: @parm(File,default="@value(Manuscript) @@ @value(site)")
-@end(center)
-
-@Copyrightnotice(@Parm(Copyrightholder, default <Carnegie-Mellon University>))
-@begin(researchcredit)
-@imbed( internal, 
-def "This is an internal working document of the Computer Science 
-	Department, Carnegie-Mellon University, Schenley Park, Pittsburgh, 
-	PA 15213.  Some of the ideas expressed in this document may be   
-	only partially developed or erroneous.  Distribution of this document   
-	outside the immediate working community is discouraged; publication   
-	of this document is forbidden.")
-
-Supported by the Defense Advanced Research Projects Agency, Department   
-of Defense, ARPA Order 3597, monitored by the Air Force Avionics   
-Laboratory under contract F33615-78-C-1551.  The views   
-and conclusions contained in this document are those of the authors   
-and should not be interpreted as representing the official policies,   
-either expressed or implied, of the Defense Advanced Research   
-Projects Agency or the U.S. Government.
-@end(researchcredit)
-@end(titlepage)
-
-@newpage
-
-@comment[ Leave larger blank area at top of first page ]
-@format[ @blankspace( 1inch ) ]
-}) @comment[ End of SpiceTitlePage form ]
-@Marker(Library,Spice)
diff --git a/docs/database/spicer.fon b/docs/database/spicer.fon
deleted file mode 100644
index 5244c3d385c5055d57c5a2cf953e15144938166c..0000000000000000000000000000000000000000
--- a/docs/database/spicer.fon
+++ /dev/null
@@ -1,230 +0,0 @@
-@Marker(Font,SpiceRoman10,Press)
-@DefineFont(BodyFont,	
-	R=<Xerox "TimesRoman10R">,
-	I=<Xerox "TimesRoman10I">,
-	B=<Xerox "TimesRoman10B">,
-	P=<Ascii "TimesRoman10BI">,
-	F=<Ascii "SailA10R">,
-	C=<Xerox "TimesRoman8R">,
-	Z=<Xerox "Zfont10R">,
-	G=<Xgreek "Hippo10R">,
-	Y=<Xerox "TimesRoman8R">,
-	X=<Xerox "CMSY10S10R">,
-	U=<Ascii "Sail10">,
-	A=<Ascii "APL10">,
-	T=<Ascii "SailA10R">,
-	K=<Ascii "Operators10R">,
-	L=<Ascii "Operators20R">,
-	M=<Ascii "Relation9R">,
-	N=<Ascii "AllArrows10R">)
-
-@comment(Shrunk: 14-12,10-9,9-8,8-7,6-5 except K and G)
-@DefineFont(SmallBodyFont,
-	R=<Xerox "TimesRoman8R">,
-	B=<Xerox "TimesRoman8B">,
-	I=<Xerox "TimesRoman8I">,
-	P=<Xerox "TimesRoman8BI">,
-	G=<Xgreek "Hippo8R">,
-	F=<Ascii "SailA8R">,
-	Z=<Xerox "Zfont10R">,
-	Y=<Xerox "TimesRoman8R">,
-	X=<Xerox "CMSY8R">,
-	U=<Ascii "Sail8">,
-	A=<Ascii "APL8">,
-	C=<Xerox "TimesRoman6R">,
-	T=<Ascii "SailA8R">,
-	K=<Ascii "Operators8R">,
-	L=<Ascii "Operators12R">,
-	M=<Ascii "Relation8R">,
-	N=<Ascii "AllArrows8R">) @Comment{GLS 5/17/81: AllArrows7R nonexistent}
-
-@DefineFont(LargeBodyFont,
-		R=<Ascii "TimesRoman12">,
-		I=<Ascii "TimesRoman12I">,
-		B=<Ascii "TimesRoman12B">,
-		C=<Ascii "TimesRoman10">)
-@DefineFont(SquareRootFont,
-		R=<Ascii "SquareRoot10">)
-
-@DefineFont(TitleFont1,
-		R=<Xerox "TimesRoman10B">,
-		I=<Xerox "TimesRoman10BI">,
-		F=<Ascii "SailA10R">,
-		C=<Xerox "TimesRoman8B">)
-@DefineFont(TitleFont2,
-		R=<Xerox "TimesRoman12B">,
-		I=<Xerox "TimesRoman12BI">,
-		F=<Ascii "SailA12R">,
-		C=<Xerox "TimesRoman9B">)
-@DefineFont(TitleFont3,
-		R=<Xerox "TimesRoman12B">,
-		I=<Xerox "TimesRoman12BI">,
-		F=<Ascii "SailA12R">,
-		C=<Xerox "TimesRoman9B">)
-@DefineFont(TitleFont4,
-		R=<Xerox "TimesRoman12B">,
-		I=<Xerox "TimesRoman12BI">,
-		F=<Ascii "SailA12R">,
-		C=<Xerox "TimesRoman9B">)
-@DefineFont(TitleFont5,
-		R=<Xerox "TimesRoman18B">,
-		I=<Xerox "TimesRoman18BI">,
-		C=<Xerox "TimesRoman12B">)
-
-@Equate(DisplayFont=BodyFont,TitleFont0=BodyFont,HeadingFont=TitleFont3)
-@Marker(Font,SpiceRoman11,Press)
-@DefineFont(BodyFont,	
-	R=<Xerox "TimesRoman11R">,
-	I=<Xerox "TimesRoman11I">,
-	B=<Xerox "TimesRoman11B">,
-	P=<Ascii "TimesRoman11BI">,
-	F=<Ascii "SailA11R">,
-	C=<Xerox "TimesRoman9R">,
-	Z=<Xerox "Zfont11R">,
-	G=<Xgreek "Hippo11R">,
-	Y=<Xerox "TimesRoman9R">,
-	X=<Xerox "CMSY10S10R">,
-	U=<Ascii "Sail10">,
-	A=<Ascii "APL10">,
-	T=<Ascii "SailA11R">)
-
-@DefineFont(SmallBodyFont,
-	R=<Xerox "TimesRoman9R">,
-	B=<Xerox "TimesRoman9B">,
-	I=<Xerox "TimesRoman9I">,
-	P=<Xerox "TimesRoman9BI">,
-	G=<Xgreek "Hippo9R">,
-	F=<Ascii "SailA9R">,
-	Z=<Xerox "Zfont11R">,
-	Y=<Xerox "TimesRoman9R">,
-	X=<Xerox "CMSY8R">,
-	C=<Xerox "TimesRoman6R">,
-	U=<Ascii "Sail9">,
-	A=<Ascii "APL8">,
-	T=<Ascii "SailA9R">)
-
-@DefineFont(TitleFont1,
-		R=<Xerox "TimesRoman11B">,
-		I=<Xerox "TimesRoman11BI">,
-		C=<Xerox "TimesRoman9B">)
-@DefineFont(TitleFont2,
-		R=<Xerox "TimesRoman12B">,
-		I=<Xerox "TimesRoman12BI">,
-		C=<Xerox "TimesRoman9B">)
-@DefineFont(TitleFont3,
-		R=<Xerox "TimesRoman12B">,
-		I=<Xerox "TimesRoman12BI">,
-		C=<Xerox "TimesRoman9B">)
-@DefineFont(TitleFont4,
-		R=<Xerox "TimesRoman12B">,
-		I=<Xerox "TimesRoman12BI">,
-		C=<Xerox "TimesRoman9B">)
-@DefineFont(TitleFont5,
-		R=<Xerox "TimesRoman18B">,
-		I=<Xerox "TimesRoman18BI">,
-		C=<Xerox "TimesRoman12B">)
-
-@Equate(DisplayFont=BodyFont,TitleFont0=BodyFont,HeadingFont=TitleFont3)
-@Marker(Font,SpiceRoman12,Press)
-@DefineFont(BodyFont,	
-	R=<Xerox "TimesRoman12R">,
-	I=<Xerox "TimesRoman12I">,
-	B=<Xerox "TimesRoman12B">,
-	P=<Ascii "TimesRoman12BI">,
-	F=<Ascii "SailA10R">,
-	C=<Xerox "TimesRoman10R">,
-	Z=<Xerox "Zfont12R">,
-	G=<Xgreek "Hippo12R">,
-	Y=<Xerox "TimesRoman10R">,
-	X=<Xerox "CMSY10S10R">,
-	U=<Ascii "Sail12">,
-	T=<Ascii "SailA10R">)
-
-@DefineFont(SmallBodyFont,
-	R=<Xerox "TimesRoman10R">,
-	B=<Xerox "TimesRoman10B">,
-	I=<Xerox "TimesRoman10I">,
-	P=<Xerox "TimesRoman10BI">,
-	G=<Xgreek "Hippo10R">,
-	F=<Ascii "SailA9R">,
-	Z=<Xerox "Zfont12R">,
-	Y=<Xerox "TimesRoman10R">,
-	X=<Xerox "CMSY8R">,
-	C=<Xerox "TimesRoman6R">,
-	U=<Ascii "Sail10">,
-	A=<Ascii "APL10">,
-	T=<Ascii "SailA9R">)
-
-@DefineFont(TitleFont1,
-		R=<Xerox "TimesRoman12B">,
-		I=<Xerox "TimesRoman12BI">,
-		C=<Xerox "TimesRoman10B">)
-@DefineFont(TitleFont2,
-		R=<Xerox "TimesRoman14B">,
-		I=<Xerox "TimesRoman14BI">,
-		C=<Xerox "TimesRoman9B">)
-@DefineFont(TitleFont3,
-		R=<Xerox "TimesRoman16B">,
-		I=<Xerox "TimesRoman16BI">,
-		C=<Xerox "TimesRoman12B">)
-@DefineFont(TitleFont4,
-		R=<Xerox "TimesRoman16B">,
-		I=<Xerox "TimesRoman16BI">,
-		C=<Xerox "TimesRoman12B">)
-@DefineFont(TitleFont5,
-		R=<Xerox "TimesRoman18B">,
-		I=<Xerox "TimesRoman18BI">,
-		C=<Xerox "TimesRoman14B">)
-
-@Equate(DisplayFont=BodyFont,TitleFont0=BodyFont,HeadingFont=TitleFont3)
-@Marker(Font,SpiceRoman14,Press)
-@DefineFont(BodyFont,	
-	R=<Xerox "TimesRoman14R">,
-	I=<Xerox "TimesRoman14I">,
-	B=<Xerox "TimesRoman14B">,
-	P=<Ascii "TimesRoman14BI">,
-	F=<Ascii "SailA14R">,
-	C=<Xerox "TimesRoman10R">,
-	Z=<Xerox "Zfont14R">,
-	G=<Xgreek "Hippo14R">,
-	Y=<Xerox "TimesRoman10R">,
-	X=<Xerox "CMSY10S10R">,
-	U=<Ascii "Sail14">,
-	T=<Ascii "SailA14R">)
-
-@DefineFont(SmallBodyFont,
-	R=<Xerox "TimesRoman10R">,
-	B=<Xerox "TimesRoman10B">,
-	I=<Xerox "TimesRoman10I">,
-	P=<Xerox "TimesRoman10BI">,
-	G=<Xgreek "Hippo10R">,
-	F=<Ascii "SailA10R">,
-	Z=<Xerox "Zfont10R">,
-	Y=<Xerox "TimesRoman10R">,
-	X=<Xerox "CMSY10S10R">,
-	C=<Xerox "TimesRoman8R">,
-	U=<Ascii "Sail12">,
-	T=<Ascii "SailA10R">)
-
-@DefineFont(TitleFont1,
-		R=<Xerox "TimesRoman14B">,
-		I=<Xerox "TimesRoman14BI">,
-		C=<Xerox "TimesRoman10B">)
-@DefineFont(TitleFont2,
-		R=<Xerox "TimesRoman16B">,
-		I=<Xerox "TimesRoman16BI">,
-		C=<Xerox "TimesRoman12B">)
-@DefineFont(TitleFont3,
-		R=<Xerox "TimesRoman16B">,
-		I=<Xerox "TimesRoman16BI">,
-		C=<Xerox "TimesRoman12B">)
-@DefineFont(TitleFont4,
-		R=<Xerox "TimesRoman18B">,
-		I=<Xerox "TimesRoman18BI">,
-		C=<Xerox "TimesRoman14B">)
-@DefineFont(TitleFont5,
-		R=<Xerox "TimesRoman18B">,
-		I=<Xerox "TimesRoman18BI">,
-		C=<Xerox "TimesRoman14B">)
-
-@Equate(DisplayFont=BodyFont,TitleFont0=BodyFont,HeadingFont=TitleFont3)
diff --git a/docs/database/table.lib b/docs/database/table.lib
deleted file mode 100644
index 0d572fe8305de202a7683bdeaef38f62b1d567e1..0000000000000000000000000000000000000000
--- a/docs/database/table.lib
+++ /dev/null
@@ -1,27 +0,0 @@
-@Marker(Library,Table,Dover,Postscript)
-
-@Comment{New library definitions for tables.}
-
-@Style(StringMax=10000)
-@Modify(Table, Spacing 1)
-
-@Define(Liner, underline all, tabexport off, script -1pt,
-	rightmargin +1pts, leftmargin +2pts)
-@Define(up6, script +6pts)
-
-@textform(VB={@string(NID = "@parm(text)")@case(NID,
-	1 "@hsp(1pt)@ovp[|]@up6[|]",
-	2 "@hsp(1pt)@ovp[|]@up6[|]@>@ovp[|]@up6[|]@\",
-	3 "@hsp(1pt)@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@\",
-	4 "@hsp(1pt)@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@\",
-	5 "@hsp(1pt)@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@\",
-	6 "@hsp(1pt)@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@\",
-	7 "@hsp(1pt)@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@>@ovp[|]@up6[|]@\",
-	else "@hsp(1pt)@ovp[|]@up6[|]")})
-
-@Form(TLine="@enter(Liner, script @parm<height, default=[+3pts]>)@~
-	@tabclear()@&@ @\@leave(Liner)")
-@TextForm(BLine="@ovp<@Liner(@tabclear()@&@ @\)>@VB(@parm(text))")
-@TextForm(TL="@hsp(1)@parm(text)@>@ovp[|]@up6[|]@\")
-@TextForm(TC="@=@parm(text)@>@ovp[|]@up6[|]@\")
-@TextForm(TR="@>@parm(text)@hsp(1)@ovp[|]@up6[|]@\")
diff --git a/docs/database/uttir.lib b/docs/database/uttir.lib
deleted file mode 100644
index 63bdfdca67ef1eb5f48026028813ec89f5890ac4..0000000000000000000000000000000000000000
--- a/docs/database/uttir.lib
+++ /dev/null
@@ -1,329 +0,0 @@
-@Comment{Version of BOLIO.LIB that provides a single unified index
-instead of separate indexes for functions, variables, constants,
-keywords, and concepts.}
-
-@Marker(Library, Uttir, Press, Dover, Postscript)
-
-@Libraryfile(DBolio)
-
-
-@Comment{Constraints on the definition of IndexEnvironment:
-	Indent = - LeftMargin
-	(Linewidth + Leftmargin + Columnmargin) * Columns - Columnmargin
-		 = global line width
-}
-@Define(IndexEnvironment, Boxed, Columns 2, Columnmargin 0.5in,
-        Linewidth 2.7in, Leftmargin +0.3in, Indent -0.3in)
-
-@Define(KeySpreadEnvironment, Facecode F)
-@Textform(SpreadKeys = "@KeySpreadEnvironment<@SpreadKeysLoop@Parm(Text)[]>")
-@Textform(SpreadKeysLoop =
-	"@String(SpreadKeysTemp = @Parmquote(Text))@Case(SpreadKeysTemp,
-	     null <>, else < :@Parm(Text)@SpreadKeysLoop>)")
-
-@Form(IndexKeys = "@Textform(IndexKeysLoop =
-	'@String(IndexKeysTemp = @Quote{@Parmquote(Text)})@Case(IndexKeysTemp,
-	    null <>, else [@Kindex2(P = @Quote{@Parmquote(Text)},
-				    S = {for@f( @Parm(Fun))})@IndexKeysLoop])')@IndexKeysLoop@Parm(Keys)[]@~")
-
-@Counter(UnNumberedIndex,TitleEnv HD1A,ContentsEnv tc1,Announced,Alias Chapter)
-
-@Textform(IndexHeadings = "@UnnumberedIndex@Parmquote(Text)
-@String(ChapterTitle = @Parmquote(Text))
-@Pageheading(Immediate, Left = <>, Right = <>)
-@Pagefooting(Immediate, Center = <@Value(Page)>)
-@Pageheading(Odd, Left = <@c[@Value(ChapterTitle)]>, Right = <@Value(Page)>)
-@Pageheading(Even, Left = <@Value(Page)>, Right = <@c[@Value(ReportTitle)]>)
-@Pagefooting(Center = <>)
-")
-
-@Textform(Incompatibility = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4)
-	@b[Compatibility note:] @Index(@b[Compatibility note])
-	@Parm(Text) @End(Quotation)")
-@Textform(Implementation = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4)
-	@b[Implementation note:] @Index(@b[Implementation note])
-	@Parm(Text) @End(Quotation)")
-@Textform(Rationale = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4)
-	@b[Rationale:] @Index(@b[Rationale]) @Parm(Text) @End(Quotation)")
-@Comment{
-@Textform(Query = "@Begin(Quotation, Font Smallbodyfont, Indent +0, Spread 0.5, need 4)
-	@f[???] @b[Query:] @Index(@b[Query]) @Parm(Text) @End(Quotation)")
-}
-
-@Textform(Kwd = "@f[:@Parm(Text)]")
-@Textform(KeywordList = "
-	@Begin(Description)
-	@Textform(Keyword = '@Begin(Multiple)@~
-@f[:@Quote<@Parm(Text)>  ]@\@Kindex2(P = @Quote<@Parmquote(Text)>,
-			   S = {for@f[ @Parm(Text)]})@~
-		@Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~')
-	@Textform(FirstKeyword = '@Begin(Multiple)@~
-@f[:@Quote<@Parm(Text)> @r[or] ]@Kindex2(P = @Quote<@Parmquote(Text)>,
-			   S = {for@f[ @Parm(Text)]})@~
-		@Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~')
-	@Textform(NextKeyword = '@~
-@f[:@Quote<@Parm(Text)> @r[or] ]@Kindex2(P = @Quote<@Parmquote(Text)>,
-			   S = {for@f[ @Parm(Text)]})@~
-		@Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~')
-	@Textform(LastKeyword = '@~
-@f[:@Quote<@Parm(Text)>  ]@\@Kindex2(P = @Quote<@Parmquote(Text)>,
-			   S = {for@f[ @Parm(Text)]})@~
-		@Label{@Parm(Text)-@Quote<@Parm(Text)>-kwd}@~')
-	@Textform(SubKeywordList = '
-		@Begin(Description)
-		@Textform(SubKeyword = <@Begin(Multiple)@~
-@f[:@Quote{@Quote[@Parm(Text)]}  ]@\@Kindex2(P = @Quote{@Quote[@Parmquote(Text)]},
-			   S = {for@f[ @Quote[@Parm(Text)] ]option @~
-				to@f[ @Parm(Text)]})@~
-		@Label{@Parm(Text)-@Quote[@Parm(Text)]-@Quote{@Quote[@Parm(Text)]}-kwd}@~>)')
-")
-@Textform(PseudoKeyword = "@Begin(Multiple)@Parm(Text)   @\@~")
-@Commandstring(Endkeyword = "@End(Multiple)")
-@Commandstring(Endkeywordlist = "@End(Description)")
-@Textform(PseudoSubKeyword = "@Begin(Multiple)@Parm(Text)   @\@~")
-@Commandstring(EndSubKeyword = "@End(Multiple)")
-@Commandstring(EndSubKeywordlist = "@End(Description)")
-@Textform(RandomKeywordList = "
-	@Begin(Description)
-	@Index2(P = {Keywords}, S = {for@f[ ]@Parm(Text)})
-	@Textform(RandomKeyword = '@Begin(Multiple)
-@f[:@Quote<@Parm(Text)>  ]@\@Kindex2(P = @Quote<@Parmquote(Text)>,
-				     S = {for@f[ ]@Parm(Text)})@~')
-")
-@Textform(PseudoRandomKeyword = "@Begin(Multiple)@Parm(Text)   @\@~")
-@Commandstring(Endrandomkeyword = "@End(Multiple)")
-@Commandstring(Endrandomkeywordlist = "@End(Description)")
-
-@Form(Defvar = "@Begin(Defenvironment)@Comment(Tabset?)@~
-   @f[@Imbed(Package, def '@Parm(Package):')@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\@~
-   @Send(FunList {@f[@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\})@~
-   @Imbed(Nostar, undef<@Vindex@Parmquote(Var)>, def<@Vxindex@Parmquote(Var)>)@~
-   @Imbed(Nolabel, undef '@Imbed(Varlabel,
-			          def <@Label{@Parm(Varlabel)-var}>,
-			          undef <@Label{@Parm(Var)-var}>)')@~
-   @Begin(Defbody)@Tabclear ")
-@Form(Defvar1 = "@Begin(Undefbody)@Comment(Tabset?)@~
-   @f[@Imbed(Package, def '@Parm(Package):')@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\@~
-   @Send(FunList {@f[@Imbed(Nostar, undef '*')@Parm(Var)@Imbed(Nostar, undef '*')] @>[@i[Variable]]@\})@~
-   @Imbed(Nostar, undef<@Vindex@Parmquote(Var)>, def<@Vxindex@Parmquote(Var)>)@~
-   @Imbed(Nolabel, undef '@Imbed(Varlabel,
-			          def <@Label{@Parm(Varlabel)-var}>,
-			          undef <@Label{@Parm(Var)-var}>)')@~
-   @End(Undefbody)")
-@Commandstring(Enddefvar = "@End(Defbody)@End(Defenvironment)")
-
-@Form(Defcon = "@Begin(Defenvironment)@Comment(Tabset?)@~
-   @f[@Imbed(Package, def '@Parm(Package):')@Parm(Var)] @>[@i[Constant]]@\@~
-   @Send(FunList {@f[@Parm(Var)] @>[@i[Constant]]@\})@~
-   @Conindex@Parmquote(Var)@~
-   @Imbed(Nolabel, undef '@Imbed(Varlabel,
-			          def <@Label{@Parm(Varlabel)-con}>,
-			          undef <@Label{@Parm(Var)-con}>)')@~
-   @Begin(Defbody)@Tabclear ")
-@Form(Defcon1 = "@Begin(Undefbody)@Comment(Tabset?)@~
-   @f[@Imbed(Package, def '@Parm(Package):')@Parm(Var)] @>[@i[Constant]]@\@~
-   @Send(FunList {@f[@Parm(Var)] @>[@i[Constant]]@\})@~
-   @Conindex@Parmquote(Var)@~
-   @Imbed(Nolabel, undef '@Imbed(Varlabel,
-			          def <@Label{@Parm(Varlabel)-con}>,
-			          undef <@Label{@Parm(Var)-con}>)')@~
-   @End(Undefbody)")
-@Commandstring(Enddefcon = "@End(Defbody)@End(Defenvironment)")
-
-@Form(Defun = "@Begin(Defenvironment)@Comment(Tabset?)@~
-   @f[@Imbed(Package, def '@Parm(Package):')@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys, def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\
-@Imbed(MoreKeys, def <@/@Spreadkeys(@Parm(MoreKeys))
->)@~
-@Imbed(YetMoreKeys, def <@/@Spreadkeys(@Parm(YetMoreKeys))
->)@~
-   @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys,
-	def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\@Imbed(MoreKeys,
-	def <
-@/@f[@Spreadkeys(@Parm(MoreKeys))]>)@Imbed(YetMoreKeys,
-	def <
-@/@f[@Spreadkeys(@Parm(YetMoreKeys))]>)})@~
-   @Findex@Parmquote(Fun)@~
-  @Imbed(SuppressKeyIndex, undef <
-   @Imbed(Keys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(Keys))')@~
-   @Imbed(MoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(MoreKeys))')@~
-   @Imbed(YetMoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(YetMoreKeys))')>)@~
-   @Imbed(Nolabel, undef '@Imbed(Funlabel,
-			          def <@Label{@Parm(Funlabel)-fun}>,
-			          undef <@Label{@Parm(Fun)-fun}>)')@~
-   @Begin(Defbody)@Tabclear ")
-@Form(Defun1 = "@Begin(Undefbody)@Comment(Tabset?)@~
-   @f[@Imbed(Package, def '@Parm(Package):')@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys, def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\
-@Imbed(MoreKeys, def <@/@Spreadkeys(@Parm(MoreKeys))
->)@~
-@Imbed(YetMoreKeys, def <@/@Spreadkeys(@Parm(YetMoreKeys))
->)@~
-   @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)@Imbed(Keys,
-	def < @key@!@Spreadkeys(@Parm(Keys))>)] @>[@i[Function]]@\@Imbed(MoreKeys,
-	def <
-@/@f[@Spreadkeys(@Parm(MoreKeys))]>)@Imbed(YetMoreKeys,
-	def <
-@/@f[@Spreadkeys(@Parm(YetMoreKeys))]>)})@~
-   @Findex@Parmquote(Fun)@~
-  @Imbed(SuppressKeyIndex, undef <
-   @Imbed(Keys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(Keys))')@~
-   @Imbed(MoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(MoreKeys))')@~
-   @Imbed(YetMoreKeys, def '@IndexKeys(Fun = @Parmquote(Fun), Keys = @Parmquote(YetMoreKeys))')>)@~
-   @Imbed(Nolabel, undef '@Imbed(Funlabel,
-			          def [@Label{@Parm(Funlabel)-fun}],
-			          undef [@Label{@Parm(Fun)-fun}])')@~
-   @End(Undefbody)")
-@Commandstring(Enddefun = "@End(Defbody)@End(Defenvironment)")
-
-@Form(Defmac = "@Begin(Defenvironment)@Comment(Tabset?)@~
-   @f[@Imbed(Package, def '@Parm(Package):')@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\@~
-   @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\})@~
-   @Mindex@Parmquote(Fun)@~
-   @Imbed(Nolabel, undef '@Imbed(Funlabel,
-			          def <@Label{@Parm(Funlabel)-mac}>,
-			          undef <@Label{@Parm(Fun)-mac}>)')@~
-   @Begin(Defbody)@Tabclear ")
-@Form(Defmac1 = "@Begin(Undefbody)@Comment(Tabset?)@~
-   @f[@Imbed(Package, def '@Parm(Package):')@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\@~
-   @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Macro]]@\})@~
-   @Mindex@Parmquote(Fun)@~
-   @Imbed(Nolabel, undef '@Imbed(Funlabel,
-			          def <@Label{@Parm(Funlabel)-mac}>,
-			          undef <@Label{@Parm(Fun)-mac}>)')@~
-   @End(Undefbody)")
-@Commandstring(Enddefmac = "@End(Defbody)@End(Defenvironment)")
-
-@Form(Defspec = "@Begin(Defenvironment)@Comment(Tabset?)@~
-   @f[@Imbed(Package, def '@Parm(Package):')@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\@~
-   @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\})@~
-   @Sindex@Parmquote(Fun)@~
-   @Imbed(Nolabel, undef '@Imbed(Funlabel,
-			          def <@Label{@Parm(Funlabel)-spec}>,
-			          undef <@Label{@Parm(Fun)-spec}>)')@~
-   @Begin(Defbody)@Tabclear ")
-@Form(Defspec1 = "@Begin(Undefbody)@Comment(Tabset?)@~
-   @f[@Imbed(Package, def '@Parm(Package):')@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\@~
-   @Send(FunList {@f[@Parm(Fun) @Parm(Args, default <>)] @>[@i[Special form]]@\})@~
-   @Sindex@Parmquote(Fun)@~
-   @Imbed(Nolabel, undef '@Imbed(Funlabel,
-			          def <@Label{@Parm(Funlabel)-spec}>,
-			          undef <@Label{@Parm(Fun)-spec}>)')@~
-   @End(Undefbody)")
-@Commandstring(Enddefspec = "@End(Defbody)@End(Defenvironment)")
-
-@Textform(Xindent = "@hsp(2.0em)")
-@Textform(Xsepr = "@hsp(0.5em)")
-@Textform(Def = "@Index@Parmquote(Text)@i@Parmquote(Text)")
-@Textform(Index = "@Indexentry{Key {@Parm(Text) !1},
-             Entry {@r[@Parm(Text)]@Xsepr()}, Number {@r[@Parmvalue(Page)]}}@'")
-@Form(PossiblyIndexedRef = "@Indexentry{Key {@Parm(K) !1},
-             Entry {@r[@Parm(F)]@Xsepr()}, Number {@r[@Parmvalue(Page)]}}@Parm(E)")
-@Textform(Index1 = "@Indexentry{Key {@Parm(Text) !1},
-             Entry {@r[@Parm(Text)]@Xsepr()}}@'")
-@Form(Index2 = "@Index1@Parmquote(P)@Indexentry{Key {@Parm(P) !2 @Parm(S)},
-         Entry {@Xindent()@r[@Parm(S)]@Xsepr()}, Number {@Parmvalue(Page)}}@'")
-@Form(Seealso = "@Index1@Parmquote(P)@Indexentry{Key {@Parm(P) !3 @Parm(S)},
-         Entry {@Xindent()@Xindent()@r[See also:]}, Number @Parmquote(S)}@'")
-@Form(Xindex = "@Indexentry{Key {@Parm(X) @Parm(T) 1},
-         Entry {@Parm(Q, default <>)@Parm(P)@Parm(R, default <>)@f[ ]@r[@Parm(T)]@Xsepr()},
-	 Number {@b[@Parmvalue(Page)]}}@'")
-@Form(Xindexref = "@Indexentry{Key {@Parm(X) @Parm(T) 1},
-         Entry {@Parm(Q, default <>)@Parm(P)@Parm(R, default <>)@f[ ]@r[@Parm(T)]@Xsepr()},
-	 Number {@Parmvalue(Page)}}@'")
-@Form(Xindex1 = "@Indexentry{Key {@Parm(X) @Parm(T) 1},
-         Entry {@Parm(Q, default <>)@Parm(P)@Parm(R, default <>)@f[ ]@r[@Parm(T)]@Xsepr()}}@'")
-@Form(Xindex2 = "@Xindex1(X @Parmquote(X), T @Parmquote(T),
-			  P @Parmquote(P)@Imbed(Q, def <, Q @Parmquote(Q)>)@Imbed(R, def <, R @Parmquote(R)>))@~
-         @Indexentry{Key {@Parm(X) @Parm(T) 2 @Parm(S)},
-		     Entry {@Xindent()@Parm(S)@Xsepr()},
-		     Number {@b[@Parmvalue(Page)]}}@'")
-@Form(Xindexref2 = "@Xindex1(X @Parmquote(X), T @Parmquote(T),
-			     P @Parmquote(P)@Imbed(Q, def <, Q @Parmquote(Q)>)@Imbed(R, def <, R @Parmquote(R)>))@~
-         @Indexentry{Key {@Parm(X) @Parm(T) 2 @Parm(S)},
-		     Entry {@Xindent()@Parm(S)@Xsepr()},
-		     Number {@Parmvalue(Page)}}@'")
-@Form(Xseealso = "@Xindex1(X @Parmquote(X), T @Parmquote(T),
-			   P @Parmquote(P)@Imbed(Q, def <, Q @Parmquote(Q)>)@Imbed(R, def <, R @Parmquote(R)>))@~
-         @Indexentry{Key {@Parm(X) @Parm(T) 3 @Parm(S)},
-		     Entry {@Xindent()@Xindent()@r[See also:]},
-		     Number @Parmquote(S)}}@'")
-
-@Textform(Cindex = "@Index@Parmquote(Text)@'")
-
-@Textform(Findex = "@Case(IndexFuns, Yes '@Xindex(T {function}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'")
-@Textform(Findexref = "@Case(IndexFuns, Yes '@Xindexref(T {function}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'")
-@Form(Findex2 = "@Case(IndexFuns, Yes '@Xindex2(T {function}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'")
-@Form(Fseealso = "@Case(IndexFuns, Yes '@Xseealso(T {function}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'")
-
-@Textform(Mindex = "@Case(IndexFuns, Yes '@Xindex(T {macro}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'")
-@Textform(Mindexref = "@Case(IndexFuns, Yes '@Xindexref(T {macro}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'")
-@Form(Mindex2 = "@Case(IndexFuns, Yes '@Xindex2(T {macro}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'")
-@Form(Mseealso = "@Case(IndexFuns, Yes '@Xseealso(T {macro}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'")
-
-@Textform(Sindex = "@Case(IndexFuns, Yes '@Xindex(T {special form}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'")
-@Textform(Sindexref = "@Case(IndexFuns, Yes '@Xindexref(T {special form}, X {@Parm(Text)}, P {@f[@Parm(Text)]})')@'")
-@Form(Sindex2 = "@Case(IndexFuns, Yes '@Xindex2(T {special form}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'")
-@Form(Sseealso = "@Case(IndexFuns, Yes '@Xseealso(T {special form}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))')@'")
-
-@Textform(Vindex = "@Xindex(T {variable}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[*]}, R{@f[*]})@'")
-@Textform(Vxindex = "@Xindex(T {variable}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Textform(Vindexref = "@Xindexref(T {variable}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[*]}, R{@f[*]})@'")
-@Form(Vindex2 = "@Xindex2(T {variable}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[*]}, R{@f[*]})@'")
-@Form(Vseealso = "@Xseealso(T {variable}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[*]}, R{@f[*]})@'")
-
-@Textform(Conindex = "@Xindex(T {constant}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Textform(Conindexref = "@Xindexref(T {constant}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Form(Conindex2 = "@Xindex2(T {constant}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'")
-@Form(Conseealso = "@Xseealso(T {constant}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'")
-
-@Textform(Kindex = "@Xindex(T {keyword}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[:]})@'")
-@Textform(Kindexref = "@Xindexref(T {keyword}, X {@Parm(Text)}, P {@f[@Parm(Text)]}, Q {@f[:]})@'")
-@Form(Kindex2 = "@Xindex2(T {keyword}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[:]})@'")
-@Form(Kindexref2 = "@Xindexref2(T {keyword}, X {@Parm(K)}, P {@f[@Parm(K)]}, S @Parmquote(S), Q {@f[:]})@'")
-@Form(Kseealso = "@Xseealso(T {keyword}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S), Q {@f[:]})@'")
-
-@Textform(Declindex = "@Xindex(T {declaration}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Textform(Declindexref = "@Xindexref(T {declaration}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Form(Declindex2 = "@Xindex2(T {declaration}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'")
-@Form(Declseealso = "@Xseealso(T {declaration}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'")
-
-@Textform(Typeindex = "@Xindex(T {type specifier}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Textform(Typeindexref = "@Xindexref(T {type specifier}, X {@Parm(Text)}, P {@f[@Parm(Text)]})@'")
-@Form(Typeindex2 = "@Xindex2(T {type specifier}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'")
-@Form(Typeseealso = "@Xseealso(T {type specifier}, X {@Parm(P)}, P {@f[@Parm(P)]}, S @Parmquote(S))@'")
-
-@Textform(Funref = "@f[@Parm(Text) ]@~
-    @r[(page @Pageref(@Parm(Text)-fun))]@Findexref@Parmquote(Text)@;")
-@Textform(Funreftab = "@f[@Parm(Text) ]@\@r[(page @Pageref(@Parm(Text)-fun))]@Findexref@Parmquote(Text)@;")
-@Form(Xfunref = "@f[@Parm(X) ]@~
-    @r[(page @Pageref(@Parm(L)-fun))]@Findexref@Parmquote(X)@;")
-@Textform(Macref = "@f[@Parm(Text) ]@~
-    @r[(page @Pageref(@Parm(Text)-mac))]@Mindexref@Parmquote(Text)@;")
-@Textform(Macreftab = "@f[@Parm(Text) ]@\@r[(page @Pageref(@Parm(Text)-mac))]@Mindexref@Parmquote(Text)@;")
-@Form(Xmacref = "@f[@Parm(X) ]@~
-    @r[(page @Pageref(@Parm(L)-mac))]@Mindexref@Parmquote(X)@;")
-@Textform(Specref = "@f[@Parm(Text) ]@~
-    @r[(page @Pageref(@Parm(Text)-spec))]@Sindexref@Parmquote(Text)@;")
-@Textform(Specreftab = "@f[@Parm(Text) ]@\@r[(page @Pageref(@Parm(Text)-spec))]@Sindexref@Parmquote(Text)@;")
-@Form(XSpecref = "@f[@Parm(X) ]@~
-    @r[(page @Pageref(@Parm(L)-spec))]@Sindexref@Parmquote(X)@;")
-@Textform(Var = "@f[*@Parm(Text)*]")
-@Textform(Varref = "@f[*@Parm(Text)* ]@~
-    @r[(page @Pageref(@Parm(Text)-var))]@Vindexref@Parmquote(Text)@;")
-@Form(Xvarref = "@f[*@Parm(X)* ]@~
-    @r[(page @Pageref(@Parm(L)-var))]@Vindexref@Parmquote(X)@;")
-@Textform(Conref = "@f[@Parm(Text) ]@~
-    @r[(page @Pageref(@Parm(Text)-con))]@Conindexref@Parmquote(Text)@;")
-@Form(Xconref = "@f[@Parm(X) ]@~
-    @r[(page @Pageref(@Parm(L)-con))]@Conindexref@Parmquote(X)@;")
-@Form(Kwdref = "@f[:@Parm(K) ]@~
-    @r[(page @Pageref(@Parm(F)-@Parm(K)-kwd))]@Kindexref2(S {for@f[ @Parm(F)]},
-						      K @Parmquote(K))@;")
-@Form(SubKwdref = "@f[:@Parm(K)] @~
-    @r[(page @Pageref(@Parm(F)-@Parm(O)-@Parm(K)-kwd))]@~
-	@Kindexref2(S {for@f[ :@Parm(O) ]option to@f[ @Parm(F)]},
-		    K @Parmquote(K))")
-
-@Indexentry(Key {  1}, Entry {@IndexHeadings[Index]@Blankspace(1)@Begin(IndexEnvironment)})
-@Indexentry(Key {~~~ }, Entry {@End(IndexEnvironment)})
-
-@Textform(IndexCleanup = " ")
diff --git a/docs/doc-diff.lisp b/docs/doc-diff.lisp
deleted file mode 100644
index 7f232bb68f2d9ec72bfa50a76ef747258a3fc47e..0000000000000000000000000000000000000000
--- a/docs/doc-diff.lisp
+++ /dev/null
@@ -1,384 +0,0 @@
-;;; -*- Package: Hemlock -*-
-;;;
-;;;    A hack to compare the functions and variables defined by the hemlock
-;;; documents with the ones defined in the core.
-;;;
-;;; Use GROVEL-LABELS.
-;;;
-
-(in-package "HEMLOCK")
-
-
-(defvar *defined-labels* (make-hash-table :test #'equal))
-
-;;; Ignore these because they would be internal (not for the user) if Hemlock
-;;; had that kind of definition power.
-;;;
-(defvar *hvars-to-ignore*
-  '(auto-save-state current-package draft-information headers-buffer
-    headers-information message-buffer message-information spell-information
-    default-message-modeline-fields current-compile-server current-eval-server))
-
-(defvar *cmds-to-ignore*
-  '("Beginning Of Parse" "Echo Area Backward Character"
-    "Echo Area Backward Word" "Echo Area Delete Previous Character"
-    "Echo Area Kill Previous Word" "Do Nothing" "Illegal" "Insert Parse Default"
-    "Italic Comment Mode" "Kill Parse" "Lisp Insert )" "Next Parse"
-    "Previous Parse" "Start Italic Comment" "Insert ()" "Move over )"
-    "Current Compile Server" "Current Eval Server" "Defhvar" "Defindent"))
-
-;;; These do not get removed from *defined-labels* because they are not
-;;; command names, variable names, or "HI" function names.  These are now
-;;; documented in the Command Implementor's Manual, but we don't want to call
-;;; FIND-UNDOCUMENTED-SYMBOLS on these packages due to all the uninteresting
-;;; symbols they hold.  In the case of routines defined in the "ED" package,
-;;; they aren't exported anyway.
-;;;
-;;; Do not add names to this list that occur in the ED package and have
-;;; asterisks (e.g., specials like *kill-ring* and *last-search-string*).  Use
-;;; the variable below, *unimplemented-strings-to-ignore*.
-;;;
-(defvar *unimplemented-to-ignore*
-  '(spell:spell-try-word spell:maybe-read-spell-dictionary spell:spell-root-word
-    spell:max-entry-length spell:spell-read-dictionary
-    spell:spell-collect-close-words spell:correct-spelling
-    spell:spell-add-entry spell:spell-remove-entry spell:spell-root-flags
-
-    ext:translate-character ext:define-keyboard-modifier
-    ext:define-mouse-code ext:translate-mouse-character ext:define-keysym
-
-    dired:find-file dired:make-directory dired:delete-file
-    dired:pathnames-from-pattern dired:copy-file dired:rename-file
-
-    get-search-pattern current-mark file-compile kill-characters
-    indent-region-for-commands display-page-directory previous-buffer
-    sentence-offset interactive buffer-default-pathname
-    add-definition-dir-translation push-buffer-mark do-active-group
-    paragraph-offset word-offset create-slave make-region-undo
-    process-file-options pre-command-parse-check top-level-offset fill-region
-    pop-buffer-mark region-eval get-current-compile-server mark-top-level-form
-    ed page-directory find-file-buffer deactivate-region valid-spot
-    buffer-history kill-region string-eval backward-up-list
-    define-file-type-hook buffer-history check-region-query-size
-    change-to-buffer region-compile current-region mark-paragraph form-offset
-    check-region-active read-buffer-file fill-region-by-paragraphs
-    forward-up-list define-file-option buffer-mark region-active-p
-    inside-defun-p activate-region start-defun-p delete-buffer-if-possible
-    get-current-eval-server goto-page write-buffer-file save-for-undo
-    eval-form-in-server indent-region in-lisp pathname-to-buffer-name
-    page-offset defun-region delete-definition-dir-translation
-    delete-horizontal-space supply-generic-pointer-up-function))
-
-;;; This is just like *unimplemented-to-ignore*, but these names are hard to
-;;; deal with in *unimplemented-to-ignore* due to one of the following reasons:
-;;;    Scribe,
-;;;    The name is an example and truly unimplemented, or
-;;;    The name has asterisks in core but not in the Scribe label name.
-;;;
-(defvar *unimplemented-strings-to-ignore*
-  '("SAMPLECOMMAND" "SAMPLEVARIABLE"
-
-    "MARK-GTR" "MARK-NEQ" "MARK-LSS" "MARK-LEQ" "MARK-GEQ" "MARK-EQL"
-    "LINE-GEQ" "LINE-LSS" "LINE-GTR" "LINE-LEQ"
-
-    "KILL-RING" "LAST-SEARCH-STRING" "EPHEMERALLY-ACTIVE-COMMAND-TYPES"
-    "HEMLOCK-BEEP" "LAST-SEARCH-PATTERN" "ACTIVE-FILE-GROUP"
-
-    "ERROR-FUNCTION" "REPORT-FUNCTION" "UPDATE-DEFAULT" "YESP-FUNCTION"
-    "CLOBBER-DEFAULT" "RECURSIVE-DEFAULT"))
-
-
-(defun grovel-labels (aux-files output-file)
-  "Read each of the files in the list Aux-Files to find what commands are
-  documented, then compare it with the commands defined in core.  We write
-  documentation forms to the output-file for things defined but not documented,
-  and we put a list of things documented but not implemented in a comment."
-  (clrhash *defined-labels*)
-  (dolist (labels-file aux-files)
-    (with-open-file (s labels-file :direction :input)
-      (loop
-	(let ((l (read-line s nil nil)))
-	  (unless l (return))
-	  (multiple-value-bind (kind label)
-			       (parse-label l)
-	    (when kind
-	      (let ((old (gethash label *defined-labels*)))
-		(when (and old
-			   (not (eq old :hemlock-variable))
-			   (not (eq kind :hemlock-variable)))
-		  (format t "~S multiply defined as ~S and ~S.~%"
-			  label old kind))
-		(setf (gethash label *defined-labels*) kind))))))))
-  (with-open-file (s output-file :direction :output
-		     :if-exists :new-version)
-    (map-undocumented-hemlock-things *command-names* :command s
-				     #'document-command *cmds-to-ignore*)
-    (terpri s)
-    (map-undocumented-hemlock-things *global-variable-names* :hemlock-variable s
-				     #'document-variable *hvars-to-ignore*)
-    (terpri s)
-    (find-undocumented-symbols "HEMLOCK-INTERNALS" s)
-    (terpri s)
-    (write-line "@begin[comment]" s)
-    (let ((ignored-symbols (copy-list *unimplemented-to-ignore*))
-	  (ignored-strings (copy-list *unimplemented-strings-to-ignore*)))
-      (maphash #'(lambda (name type)
-		   (cond ((member name ignored-symbols
-				  :test #'string= :key #'symbol-name)
-			  (setf ignored-symbols
-				(delete name ignored-symbols
-					:test #'string= :key #'symbol-name)))
-			 ((member name ignored-strings :test #'string=)
-			  (setf ignored-strings
-				(delete name ignored-strings :test #'string=)))
-			 (t
-			  (format s "~A ~S is not implemented.~%" type name))))
-	       *defined-labels*)
-      (when ignored-symbols
-	(format s
-		"~&*******************  These ignored \"unimplemented\" symbols ~
-		 were not used.~%~S~%********************~2%"
-		ignored-symbols))
-      (when ignored-strings
-	(format s
-		"~&*******************  These ignored \"unimplemented\" strings ~
-		 were not used.~%~S~%********************~2%"
-		ignored-strings)))
-    (write-line "@end[comment]" s)
-    (values)))
-
-
-;;; Iterate over a string table, checking that each thing has a corresponding
-;;; label of the specified kind.  If there is no label, then call the function
-;;; with the value and stream.  If the label is the wrong kind, print a comment
-;;; on Stream before calling the function.  We also blast the label so we will
-;;; know that it was defined.
-;;;
-(defun map-undocumented-hemlock-things (table kind stream function ignore-stuff)
-  (do-strings (string value table)
-    (let* ((lab (nstring-upcase (remove #\space string)))
-	   (lkind (gethash lab *defined-labels*)))
-      (cond ((and (eq kind :command)
-		  (member (command-name value) ignore-stuff
-			  :test #'string-equal))
-	     (setf ignore-stuff
-		   (remove (command-name value) ignore-stuff
-			   :test #'string-equal)))
-	    ((member value ignore-stuff)
-	     (setf ignore-stuff (remove value ignore-stuff)))
-	    (t
-	     (unless (eq lkind kind)
-	       (when lkind
-		 (format stream
-			 "@comment{~S documented as a ~A, ~
-			  but defined as a ~A.}~2%"
-			 string lkind kind))
-	       (funcall function value stream))))
-      (remhash lab *defined-labels*)))
-  (when ignore-stuff
-    (format stream
-	    "~&********************  These ignored ~Ss were not used.~%~
-	     ~S~%********************~2%"
-	    kind ignore-stuff)))
-
-
-
-(defvar *undocumented-symbols-to-ignore*
-  '(make-xwindow-like-hwindow mark/= default-font input-waiting mark=
-    modify-kbdmac-stream delete-line-font-marks font-mark hemlock-output-stream
-    command reprompt store-cut-string make-kbdmac-stream window window-font
-    delete-font-mark fetch-cut-string fun-defined-from-pathname
-    hemlock-region-stream line< buffer mark< move-font-mark
-    editor-describe-function enter-window-autoraise ring mark<= search-pattern
-    *print-region* mark>= string-table line mark> line> line>= line<=
-    after-editor-initializations *invoke-hook* defhvar))
-
-(defun find-undocumented-symbols (package stream)
-  (let ((ignore-symbols *undocumented-symbols-to-ignore*))
-    (do-external-symbols (sym package)
-      (let* ((name (string-trim "*" (symbol-name sym)))
-	     (kind (gethash name *defined-labels*)))
-	(ecase kind
-	  ((nil)
-	   (if (member sym ignore-symbols)
-	       (setf ignore-symbols (remove sym ignore-symbols))
-	       (let ((*standard-output* stream))
-		 ;; Bind this to squelch CLOS/DESCRIBE bad interaction.
-		 (describe sym)
-		 (terpri)
-		 (terpri))))
-	  ((:function :macro :special-form)
-	   (let ((def (cond ((macro-function sym) :macro)
-				((special-form-p sym) :special-form)
-				((fboundp sym) :function))))
-		 (unless (eq kind def)
-		   (format stream
-			   "@comment{~S is ~:[not defined~;~:*defined as a ~A~]~
-			    , but is documented as a ~A}~%" sym def kind))))
-	  (:constant
-	   (unless (constantp sym)
-	     (format stream
-		     "@comment{~S is documented as a constant, but isn't ~
-		      defined.}~%"
-		     sym)))
-	  (:variable
-	   (unless (or (get sym 'lisp::globally-special)
-		       (string= name (symbol-name sym)))
-	       (format stream
-		       "@comment{~S is documented as a special, but isn't ~
-			declared.}~%"
-		       sym))))
-	(remhash name *defined-labels*)))
-    (when ignore-symbols
-      (format stream
-	      "~&********************  These ignored symbols were not used.~%~
-	       ~S~%********************~2%"
-	      ignore-symbols))))
-
-  
-(defvar *suffix-codes* (make-hash-table :test #'equal))
-(setf (gethash "COM" *suffix-codes*) :command)
-(setf (gethash "HVAR" *suffix-codes*) :hemlock-variable)
-(setf (gethash "FUN" *suffix-codes*) :function)
-(setf (gethash "MAC" *suffix-codes*) :macro)
-(setf (gethash "SPEC" *suffix-codes*) :special-form)
-(setf (gethash "VAR" *suffix-codes*) :variable)
-(setf (gethash "CON" *suffix-codes*) :constant)
-
-
-;;; Parse a line from a Scribe .Aux file, returning the kind of the thing
-;;; documented and its name.
-;;;
-(defun parse-label (entry)
-  (let* ((end (search "), Value" entry :start2 28))
-	 (hpos (position #\- entry :start 28 :end end :from-end t)))
-    (if hpos
-	(let* ((suffix (subseq entry (1+ hpos) end))
-	       (found (gethash suffix *suffix-codes*)))
-	  (if found
-	      (values found (subseq entry 28 hpos))
-	      (values nil nil)))
-	(values nil nil))))
-
-
-(defun document-command (command stream)
-  (format stream "@defcom[com ~S" (command-name command))
-  (let ((binds (command-bindings command)))
-    (when binds
-      (format stream ", bind (")
-      (print-command-bindings binds stream)
-      (format stream ")"))
-    (format stream "]~%~A~%@enddefcom~2%"
-	    (command-documentation command))))
-
-
-(defun document-variable (var stream)
-  (let* ((name (variable-name var :global))
-	 (len (length name)))
-    (unless (string= name "Mode Hook" :start1 (- len 9))
-      (format stream "@defhvar[var ~S~@[, val {~(~S~)}~]]~%~A~%@enddefhvar~2%"
-	      name (variable-value var :global)
-	      (variable-documentation var :global)))))
-
-
-(defvar *definition-pattern*
-  (new-search-pattern :string-insensitive :forward "
-@def"))
-
-(defvar *insert-pattern*
-  (new-search-pattern :string-insensitive :backward "
-
-"))
-
-(defvar *definition-macros* (make-hash-table :test #'equal))
-(setf (gethash "COM" *definition-macros*) :command)
-(setf (gethash "HVAR" *definition-macros*) :hemlock-variable)
-(setf (gethash "UN" *definition-macros*) :function)
-(setf (gethash "MAC" *definition-macros*) :macro)
-(setf (gethash "SPEC" *definition-macros*) :special-form)
-(setf (gethash "VAR" *definition-macros*) :variable)
-(setf (gethash "CON" *definition-macros*) :constant)
-(setf (gethash "COM1" *definition-macros*) :command)
-(setf (gethash "HVAR1" *definition-macros*) :hemlock-variable)
-(setf (gethash "UN1" *definition-macros*) :function)
-(setf (gethash "MAC1" *definition-macros*) :macro)
-(setf (gethash "SPEC1" *definition-macros*) :special-form)
-(setf (gethash "VAR1" *definition-macros*) :variable)
-(setf (gethash "CON1" *definition-macros*) :constant)
-
-(defun parse-doc-macro (line)
-  (let* ((bracket (or (position #\[ line)
-		      (error "No opening #\[ ???")))
-	 (name (nstring-upcase (subseq line 4 bracket)))
-	 (kind (gethash name *definition-macros*))
-	 (nend (case (char line (+ bracket 5))
-		 (#\"
-		  (position #\" line :start (+ bracket 6)))
-		 (#\{
-		  (position #\} line :start (+ bracket 6)))
-		 (t nil))))
-    (cond ((not kind)
-	   (format t "Unknown definition macro:~%~A~%" line)
-	   (values nil nil))
-	  ((not nend)
-	   (format t "Can't parse name:~%~A~%" line)
-	   (values nil nil))
-	  (t
-	   (values kind (subseq line (+ bracket 6) nend))))))
-
-
-(defun annotate-with-online-documentation (input-file output-file)
-  "Take a Scribe input file and produce a Scribe output file with the online
-  documentation for each thing inserted before the offline documentation."
-  (let* ((temp-buffer (make-buffer "Annotate Temporary"))
-	 (point (buffer-point temp-buffer)))
-    (unwind-protect
-	(progn
-	  (read-file input-file point)
-	  (buffer-start point)
-	  (loop
-	    (unless (find-pattern point *definition-pattern*)
-	      (return))
-	    (line-offset point 1)
-	    (multiple-value-bind
-		(kind name)
-		(parse-doc-macro (line-string (mark-line point)))
-	      (when kind
-		(with-mark ((insert point :left-inserting))
-		  (unless (find-pattern insert *insert-pattern*)
-		    (buffer-start insert))
-		  (line-offset insert 2 0)
-		  (with-output-to-mark (stream insert :full)
-		    (ecase kind
-		      ((:function :macro :special-form :constant)
-		       (format stream "@begin[format]~%")
-		       (let ((*standard-output* stream))
-			 (describe (intern (string-upcase name))))
-		       (format stream "~&@end[format]~2%"))
-		      (:variable
-		       (format stream "@begin[format]~%")
-		       (let ((*standard-output* stream))
-			 (describe (intern (concatenate 'string "*"
-							(string-upcase name)
-							"*"))))
-		       (format stream "~&@end[format]~2%"))
-		      (:command
-		       (let ((command (getstring name *command-names*)))
-			 (when command
-			   (format stream "@begin[verse]~%Command @hid[~A]:  ("
-				   (command-name command))
-			   (print-command-bindings (command-bindings command)
-						   stream)
-			   (format stream ")~%@end[verse]~%~A~2&"
-				   (command-documentation command)))))
-		      (:hemlock-variable
-		       (let ((var (getstring name *global-variable-names*)))
-			 (when var
-			   (format stream "@begin[verse]~%Variable @hid[~A]: ~
-			   (~(~S~))~%@end[verse]~%~A~2&"
-				   (variable-name var :global)
-				   (variable-value var :global)
-				   (variable-documentation var :global))))))
-		    )))))
-	  (write-file (buffer-region temp-buffer) output-file))
-      (delete-buffer temp-buffer))))
diff --git a/docs/hem/cim/aux-sys.mss b/docs/hem/cim/aux-sys.mss
deleted file mode 100644
index 945aa7a3358237cbce850305522cb7d773ed410d..0000000000000000000000000000000000000000
--- a/docs/hem/cim/aux-sys.mss
+++ /dev/null
@@ -1,694 +0,0 @@
-@comment{-*- Dictionary: /usr/lisp/scribe/hem/hem; Mode: spell; Package: Hemlock; Log: /usr/lisp/scribe/hem/hem-docs.log -*-}
-@chapter (Auxiliary Systems)
-This chapter describes utilities that some implementations of @hemlock may
-leave unprovided or unsupported.
-
-
-@section[Key-events]
-@index(I/O)
-@index[keyboard input]
-@index[input, keyboard]
-@index[mouse input]
-@index[input, mouse]
-@label[key-events]
-
-These routines are defined in the @f["EXTENSIONS"] package since other projects
-have often used @hemlock's input translations for interfacing to CLX.
-
-
-@subsection[Introduction]
-
-The canonical representation of editor input is a key-event structure.  Users
-can bind commands to keys (see section @ref[key-bindings]), which are non-zero
-length sequences of key-events.  A key-event consists of an identifying token
-known as a @i[keysym] and a field of bits representing modifiers.  Users define
-keysyms, integers between 0 and 65535 inclusively, by supplying names that
-reflect the legends on their keyboard's keys.  Users define modifier names
-similarly, but the system chooses the bit and mask for recognizing the
-modifier.  You can use keysym and modifier names to textually specify
-key-events and Hemlock keys in a @f[#k] syntax.  The following are some
-examples:
-@begin[programexample]
-   #k"C-u"
-   #k"Control-u"
-   #k"c-m-z"
-   #k"control-x meta-d"
-   #k"a"
-   #k"A"
-   #k"Linefeed"
-@end[programexample]
-This is convenient for use within code and in init files containing
-@f[bind-key] calls.
-
-The @f[#k] syntax is delimited by double quotes, but the system parses the
-contents rather than reading it as a Common Lisp string.  Within the double
-quotes, spaces separate multiple key-events.  A single key-event optionally
-starts with modifier names terminated by hyphens.  Modifier names are
-alphabetic sequences of characters which the system uses case-insensitively.
-Following modifiers is a keysym name, which is case-insensitive if it consists
-of multiple characters, but if the name consists of only a single character,
-then it is case-sensitive.
-
-You can escape special characters @dash hyphen, double quote, open angle
-bracket, close angle bracket, and space @dash with a backslash, and you can
-specify a backslash by using two contiguously.  You can use angle brackets to
-enclose a keysym name with many special characters in it.  Between angle
-brackets appearing in a keysym name position, there are only two special
-characters, the closing angle bracket and backslash.
-
-
-
-@subsection[Interface]
-
-All of the following routines and variables are exported from the "EXTENSIONS"
-("EXT") package.
-
-
-@defun[fun {define-keysym}, args {@i[keysym] @i[preferred-name] @rest @i[other-names]}]
-This function establishes a mapping from @i[preferred-name] to @i[keysym] for
-purposes of @f[#k] syntax.  @i[Other-names] also map to @i[keysym], but the
-system uses @i[preferred-name] when printing key-events.  The names are
-case-insensitive simple-strings; however, if the string contains a single
-character, then it is used case-sensitively.  Redefining a keysym or re-using
-names has undefined effects.
-
-You can use this to define unused keysyms, but primarily this defines keysyms
-defined in the @i[X Window System Protocol, MIT X Consortium Standard, X
-Version 11, Release 4].  @f[translate-key-event] uses this knowledge to
-determine what keysyms are modifier keysyms and what keysym stand for
-alphabetic key-events.
-@enddefun
-
-
-@defun[fun {define-mouse-keysym}, args {@i[button] @i[keysym] @i[name] @i[shifted-bit] @i[event-key]}]
-This function defines @i[keysym] named @i[name] for key-events representing the
-X @i[button] cross the X @i[event-key] (@kwd[button-press] or
-@kwd[button-release]).  @i[Shifted-bit] is a defined modifier name that
-@f[translate-mouse-key-event] sets in the key-event it returns whenever the X
-shift bit is set in an incoming event.
-
-Note, by default, there are distinct keysyms for each button distinguishing
-whether the user pressed or released the button.
-
-@i[Keysym] should be an one unspecified in @i[X Window System Protocol, MIT X
-Consortium Standard, X Version 11, Release 4].
-@enddefun
-
-
-@defun[fun {name-keysym}, args {@i[name]}]
-This function returns the keysym named @i[name].  If @i[name] is unknown, this
-returns @nil.
-@enddefun
-
-@defun[fun {keysym-names}, args {@i[keysym]}]
-This function returns the list of all names for @i[keysym].  If @i[keysym] is
-undefined, this returns @nil.
-@enddefun
-
-@defun[fun {keysym-preferred-name}, args {@i[keysym]}]
-This returns the preferred name for @i[keysym], how it is typically printed.
-If @i[keysym] is undefined, this returns @nil.
-@enddefun
-
-@defun[fun {define-key-event-modifier}, args {@i[long-name] @i[short-name]}]
-This establishes @i[long-name] and @i[short-name] as modifier names for
-purposes of specifying key-events in @f[#k] syntax.  The names are
-case-insensitive simple-strings.  If either name is already defined, this
-signals an error.
-
-The system defines the following default modifiers (first the long name,
-then the short name):
-@begin[Itemize]
-@f["Hyper"], @f["H"]
-
-@f["Super"], @f["S"]
-
-@f["Meta"], @f["M"]
-
-@f["Control"], @f["C"]
-
-@f["Shift"], @f["Shift"]
-
-@f["Lock"], @f["Lock"]
-@end[Itemize]
-@enddefun
-
-
-@defvar[var {all-modifier-names}]
-This variable holds all the defined modifier names.
-@enddefvar
-
-
-@defun[fun {define-clx-modifier}, args {@i[clx-mask] @i[modifier-name]}]
-This function establishes a mapping from @i[clx-mask] to a defined key-event
-@i[modifier-name].  @f[translate-key-event] and @f[translate-mouse-key-event]
-can only return key-events with bits defined by this routine.
-
-The system defines the following default mappings between CLX modifiers and
-key-event modifiers:
-@begin[Itemize]
-@f[(xlib:make-state-mask :mod-1)    -->  "Meta"]
-
-@f[(xlib:make-state-mask :control)  -->  "Control"]
-
-@f[(xlib:make-state-mask :lock)     -->  "Lock"]
-
-@f[(xlib:make-state-mask :shift)    -->  "Shift"]
-@end[Itemize]
-@enddefun
-
-
-@defun[fun {make-key-event-bits}, args {@rest @i[modifier-names]}]
-This function returns bits suitable for @f[make-key-event] from the supplied
-@i[modifier-names].  If any name is undefined, this signals an error.
-@enddefun
-
-@defun[fun {key-event-modifier-mask}, args {@i[modifier-name]}]
-This function returns a mask for @i[modifier-name].  This mask is suitable for
-use with @f[key-event-bits].  If @i[modifier-name] is undefined, this signals
-an error.
-@enddefun
-
-@defun[fun {key-event-bits-modifiers}, args {@i[bits]}]
-This returns a list of key-event modifier names, one for each modifier
-set in @i[bits].
-@enddefun
-
-
-@defun[fun {translate-key-event}, args {@i[display] @i[scan-code] @i[bits]}]
-This function translates the X @i[scan-code] and X @i[bits] to a key-event.
-First this maps @i[scan-code] to an X keysym using @f[xlib:keycode->keysym]
-looking at @i[bits] and supplying index as @f[1] if the X shift bit is on,
-@f[0] otherwise.
-
-If the resulting keysym is undefined, and it is not a modifier keysym,
-then this signals an error.  If the keysym is a modifier key, then this
-returns @nil.
-
-If these conditions are satisfied
-@begin[Itemize]
-The keysym is defined.
-
-The X shift bit is off.
-
-The X lock bit is on.
-
-The X keysym represents a lowercase letter.
-@end[Itemize]
-then this maps the @i[scan-code] again supplying index as @f[1] this time,
-treating the X lock bit as a caps-lock bit.  If this results in an undefined
-keysym, this signals an error.  Otherwise, this makes a key-event with the
-keysym and bits formed by mapping the X bits to key-event bits.
-
-Otherwise, this makes a key-event with the keysym and bits formed by
-mapping the X bits to key-event bits.
-@enddefun
-
-
-@defun[fun {translate-mouse-key-event}, args {@i[scan-code] @i[bits] @i[event-key]}]
-This function translates the X button code, @i[scan-code], and modifier bits,
-@i[bits], for the X @i[event-key] into a key-event.  See
-@f[define-mouse-keysym].
-@enddefun
-
-@defun[fun {make-key-event}, args {@i[object] @i[bits]}]
-This function returns a key-event described by @i[object] with @i[bits].
-@i[Object] is one of keysym, string, or key-event.  When @i[object] is a
-key-event, this uses @f[key-event-keysym].  You can form @i[bits] with
-@f[make-key-event-bits] or @f[key-event-modifier-mask].
-@enddefun
-
-@defun[fun {key-event-p}, args {@i[object]}]
-This function returns whether @i[object] is a key-event.
-@enddefun
-
-@defun[fun {key-event-bits}, args {@i[key-event]}]
-This function returns the bits field of a @i[key-event].
-@enddefun
-
-@defun[fun {key-event-keysym}, args {@i[key-event]}]
-This function returns the keysym field of a @i[key-event].
-@enddefun
-
-@defun[fun {char-key-event}, args {@i[character]}]
-This function returns the key-event associated with @i[character].  You can
-associate a key-event with a character by @f[setf]'ing this form.
-@enddefun
-
-@defun[fun {key-event-char}, args {@i[key-event]}]
-This function returns the character associated with @i[key-event].  You can
-associate a character with a key-event by @f[setf]'ing this form.  The system
-defaultly translates key-events in some implementation dependent way for text
-insertion; for example, under an ASCII system, the key-event @f[#k"C-h"], as
-well as @f[#k"backspace"] would map to the Common Lisp character that causes a
-backspace.
-@enddefun
-
-@defun[fun {key-event-bit-p}, args {@i[key-event] @i[bit-name]}]
-This function returns whether @i[key-event] has the bit set named by
-@i[bit-name].  This signals an error if @i[bit-name] is undefined.
-@enddefun
-
-@defmac[fun {do-alpha-key-events}, args
-{(@i[var] @i[kind] @optional @i[result]) @mstar<@i[form]>}]
- This macro evaluates each @i[form] with @i[var] bound to a key-event
-representing an alphabetic character.  @i[Kind] is one of @kwd[lower],
-@kwd[upper], or @kwd[both], and this binds @i[var] to each key-event in order
-as specified in @i[X Window System Protocol, MIT X Consortium Standard, X
-Version 11, Release 4].  When @kwd[both] is specified, this processes lowercase
-letters first.
-@enddefmac
-
-@defun[fun {print-pretty-key}, args {@i[key] @optional @i[stream] @i[long-names-p]}]
-This prints @i[key], a key-event or vector of key-events, in a user-expected
-fashion to @i[stream].  @i[Long-names-p] indicates whether modifiers should
-print with their long or short name.  @i[Stream] defaults to
-@var[standard-output].
-@enddefun
-
-@defun[fun {print-pretty-key-event}, args {@i[key-event] @optional @i[stream] @i[long-names-p]}]
-This prints @i[key-event] to @i[stream] in a user-expected fashion.
-@i[Long-names-p] indicates whether modifier names should appear using the long
-name or short name.  @i[Stream] defaults to @var[standard-output].
-@enddefun
-
-
-
-@section (CLX Interface)
-
-@subsection (Graphics Window Hooks)
-This section describes a few hooks used by Hemlock's internals to handle
-graphics windows that manifest Hemlock windows.  Some heavy users of Hemlock as
-a tool have needed these in the past, but typically functions that replace the
-default values of these hooks must be written in the "@f[HEMLOCK-INTERNALS]"
-package.  All of these symbols are internal to this package.
-
-If you need this level of control for your application, consult the current
-implementation for code fragments that will be useful in correctly writing your
-own window hook functions.
-
-@defvar[var {create-window-hook}]
-This holds a function that @Hemlock calls when @f[make-window] executes under
-CLX.  @Hemlock passes the CLX display and the following arguments from
-@f[make-window]: starting mark, ask-user, x, y, width, height, and modelinep.
-The function returns a CLX window or nil indicating one could not be made.
-@enddefvar
-
-@defvar[var {delete-window-hook}]
-This holds a function that @hemlock calls when @f[delete-window] executes under
-CLX.  @hemlock passes the CLX window and the @hemlock window to this function.
-@enddefvar
-
-@defvar[var {random-typeout-hook}]
-This holds a function that @hemlock calls when random typeout occurs under CLX.
-@hemlock passes it a @hemlock device, a pre-existing CLX window or @nil, and
-the number of pixels needed to display the number of lines requested in the
-@f[with-pop-up-display] form.  It should return a window, and if a new window
-is created, then a CLX gcontext must be the second value.
-@enddefvar
-
-@defvar[var {create-initial-windows-hook}]
-This holds a function that @hemlock calls when it initializes the screen
-manager and makes the first windows, typically windows for the @hid[Main] and
-@hid[Echo Area] buffers.  @hemlock passes the function a @hemlock device.
-@enddefvar
-
-
-@subsection (Entering and Leaving Windows)
-
-@defhvar[var "Enter Window Hook"]
-When the mouse enters an editor window, @hemlock invokes the functions in this
-hook.  These functions take a @Hemlock window as an argument.
-@enddefhvar
-
-@defhvar[var "Exit Window Hook"]
-When the mouse exits an editor window, @hemlock invokes the functions in this
-hook.  These functions take a @Hemlock window as an argument.
-@enddefhvar
-
-
-@subsection (How to Lose Up-Events)
-Often the only useful activity user's design for the mouse is to click on
-something.  @Hemlock sees a character representing the down event, but what do
-you do with the up event character that you know must follow?  Having the
-command eat it would be tasteless, and would inhibit later customizations that
-make use of it, possibly adding on to the down click command's functionality.
-Bind the corresponding up character to the command described here.
-
-@defcom[com "Do Nothing"]
-This does nothing as many times as you tell it.
-@enddefcom
-
-
-@section (Slave Lisps)
-@index (Slave lisp interface functions)
-Some implementations of @hemlock feature the ability to manage multiple slave
-Lisps, each connected to one editor Lisp.  The routines discussed here spawn
-slaves, send evaluation and compilation requests, return the current server,
-etc.  This is very powerful because without it you can lose your editing state
-when code you are developing causes a fatal error in Lisp.
-
-The routines described in this section are best suited for creating editor
-commands that interact with slave Lisps, but in the past users implemented
-several independent Lisps as nodes communicating via these functions.  There is
-a better level on which to write such code that avoids the extra effort these
-routines take for the editor's sake.  See the @i[CMU Common Lisp User's Manual]
-for the @f[remote] and @f[wire] packages.
-
-
-@subsection (The Current Slave)
-There is a slave-information structure that these return which is suitable for
-passing to the routines described in the following subsections.
-
-@defun[fun {create-slave}, args {@optional @i[name]}]
-This creates a slave that tries to connect to the editor.  When the slave
-connects to the editor, this returns a slave-information structure, and the
-interactive buffer is the buffer named @i[name].  This generates a name if
-@i[name] is @nil.  In case the slave never connects, this will eventually
-timeout and signal an editor-error.
-@enddefun
-
-@defun[fun {get-current-eval-server}, args {@optional @i[errorp]}]
-@defhvar1[var {Current Eval Server}]
-This returns the server-information for the @hid[Current Eval Server] after
-making sure it is valid.  Of course, a slave Lisp can die at anytime.  If this
-variable is @nil, and @i[errorp] is non-@nil, then this signals an
-editor-error; otherwise, it tries to make a new slave.  If there is no current
-eval server, then this tries to make a new slave, prompting the user based on a
-few variables (see the @i[Hemlock User's Manual]).
-@enddefun
-
-@defun[fun {get-current-compile-server}]
-@defhvar1[var {Current Compile Server}]
-This returns the server-information for the @hid[Current Compile Server] after
-making sure it is valid.  This may return nil.  Since multiple slaves may
-exist, it is convenient to use one for developing code and one for compiling
-files.  The compilation commands that use slave Lisps prefer to use the current
-compile server but will fall back on the current eval server when necessary.
-Typically, users only have separate compile servers when the slave Lisp can
-live on a separate workstation to save cycles on the editor machine, and the
-@hemlock commands only use this for compiling files.
-@enddefun
-
-
-@subsection (Asynchronous Operation Queuing)
-The routines in this section queue requests with an eval server.  Requests are
-always satisfied in order, but these do not wait for notification that the
-operation actually happened.  Because of this, the user can continue editing
-while his evaluation or compilation occurs.  Note, these usually execute in the
-slave immediately, but if the interactive buffer connected to the slave is
-waiting for a form to return a value, the operation requested must wait until
-the slave is free again.
-
-@defun[fun {string-eval}, args {@i[string]}, keys {[server][package][context]}]
-@defun1[fun {region-eval}, args {@i[region]}, keys {[server][package][context]}]
-@defun1[fun {region-compile}, args {@i[region]}, keys {[server][package]}]
-@f[string-eval] queues the evaluation of the form read from @i[string] on eval
-server @i[server].  @i[Server] defaults to the result of
-@f[get-current-server], and @i[string] is a simple-string.  The evaluation
-occurs with @var[package] bound in the slave to the package named by
-@i[package], which defaults to @hid[Current Package] or the empty string; the
-empty string indicates that the slave should evaluate the form in its current
-package.  The slave reads the form in @i[string] within this context as well.
-@i[Context] is a string to use when reporting start and end notifications in
-the @hid[Echo Area] buffer; it defaults to the concatenation of @f["evaluation
-of "] and @i[string].
-
-@f[region-eval] is the same as @f[string-eval], but @i[context] defaults
-differently.  If the user leaves this unsupplied, then it becomes a string
-involving part of the first line of region.
-
-@f[region-compile] is the same as the above.  @i[Server] defaults the same; it
-does not default to @f[get-current-compile-server] since this compiles the
-region into the slave Lisp's environment, to affect what you are currently
-working on.
-@enddefun
-
-@defun[fun {file-compile}, args {@i[file]},
-			   keys {[output-file][error-file][load][server]},
-			   morekeys {[package]}]
-@defhvar1[var {Remote Compile File}, val {nil}]
-This compiles @i[file] in a slave Lisp.  When @i[output-file] is @true (the
-default), this uses a temporary output file that is publicly writable in case
-the client is on another machine, which allows for file systems that do not
-permit remote write access.  This renames the temporary file to the appropriate
-binary name or deletes it after compilation.  Setting @hid[Remote Compile File]
-to @nil, inhibits this.  If @i[output-file] is non-@nil and not @true, then it
-is the name of the binary file to write.  The compilation occurs with
-@var[package] bound in the slave to the package named by @i[package], which
-defaults to @hid[Current Package] or the empty string; the empty string
-indicates that the slave should evaluate the form in its current package.
-@i[Error-file] is the file in which to record compiler output, and a @nil value
-inhibits this file's creation.  @i[Load] indicates whether to load the
-resulting binary file, defaults to @nil.  @i[Server] defaults to
-@f[get-current-compile-server], but if this returns nil, then @i[server]
-defaults to @f[get-current-server].
-@enddefun
-
-@subsection (Synchronous Operation Queuing)
-The routines in this section queue requests with an eval server and wait for
-confirmation that the evaluation actually occurred.  Because of this, the user
-cannot continue editing while the slave executes the request.  Note, these
-usually execute in the slave immediately, but if the interactive buffer
-connected to the slave is waiting for a form to return a value, the operation
-requested must wait until the slave is free again.
-
-@defun[fun {eval-form-in-server},
-       args {@i[server-info] @i[string] @optional @i[package]}]
- This function queues the evaluation of a form in the server associated with
-@i[server-info] and waits for the results.  The server @f[read]'s the form from
-@i[string] with @var[package] bound to the package named by @i[package].  This
-returns the results from the slave Lisp in a list of string values.  You can
-@f[read] from the strings or simply display them depending on the @f[print]'ing
-of the evaluation results.
-
-@i[Package] defaults to @hid[Current Package].  If this is @nil, the server
-uses the value of @var[package] in the server.
-
-While the slave executes the form, it binds @var[terminal-io] to a stream that
-signals errors when read from and dumps output to a bit-bucket.  This prevents
-the editor and slave from dead locking by waiting for each other to reply.
-@enddefun
-
-@defun[fun {eval-form-in-server-1},
-       args {@i[server-info] @i[string] @optional @i[package]}]
- This function calls @f[eval-form-in-server] and @f[read]'s the result in the
-first string it returns.  This result must be @f[read]'able in the editor's
-Lisp.
-@enddefun
-
-
-@section (Spelling)
-@index (Spelling checking)
-@hemlock supports spelling checking and correcting commands based on the ITS
-Ispell dictionary.  These commands use the following routines which include
-adding and deleting entries, reading the Ispell dictionary in a compiled binary
-format, reading user dictionary files in a text format, and checking and
-correcting possible spellings.
-
-@defun[fun {maybe-read-spell-dictionary}, package {spell}]
-This reads the default binary Ispell dictionary.  Users must call this before
-the following routines will work.
-@enddefun
-
-@defun[fun {spell-read-dictionary}, package {spell}, args {@i[filename]}]
-This adds entries to the dictionary from the lines in the file @i[filename].
-Dictionary files contain line oriented records like the following:
-@begin[programexample]
-entry1/flag1/flag2
-entry2
-entry3/flag1
-@end[programexample]
-The flags are the Ispell flags indicating which endings are appropriate for the
-given entry root, but these are unnecessary for user dictionary files.  You can
-consult Ispell documentation if you want to know more about them.
-@enddefun
-
-@defun[fun {spell-add-entry}, package {spell},
-       args {@i[line] @optional @i[word-end]}]
-This takes a line from a dictionary file, and adds the entry described by
-@i[line] to the dictionary.  @i[Word-end] defaults to the position of the first
-slash character or the length of the line.  @i[Line] is destructively modified.
-@enddefun
-
-@defun[fun {spell-remove-entry}, package {spell}, args {@i[entry]}]
-This removes entry, a simple-string, from the dictionary, so it will be an
-unknown word.  This destructively modifies @i[entry].  If it is a root word,
-then all words derived with @i[entry] and its flags will also be deleted.  If
-@i[entry] is a word derived from some root word, then the root and any words
-derived from it remain known words.
-@enddefun
-
-@defun[fun {correct-spelling}, package {spell}, args {@i[word]}]
-This checks the spelling of @i[word] and outputs the results.  If this finds
-@i[word] is correctly spelled due to some appropriate suffix on a root, it
-generates output indicating this.  If this finds @i[word] as a root entry, it
-simply outputs that it found @i[word].  If this cannot find @i[word] at all,
-then it outputs possibly correct close spellings.  This writes to
-@var[standard-output], and it calls @f[maybe-read-spell-dictionary] before
-attempting any lookups.
-@enddefun
-
-@defun[fun {spell-try-word}, package {spell}, args {@i[word] @i[word-len]}]
-@defcon1[var {max-entry-length}, val {31}]
-This returns an index into the dictionary if it finds @i[word] or an
-appropriate root.  @i[Word-len] must be inclusively in the range 2 through
-@f[max-entry-length], and it is the length of @i[word].  @i[Word] must be
-uppercase.  This returns a second value indicating whether it found @i[word]
-due to a suffix flag, @nil if @i[word] is a root entry.
-@enddefun
-
-@defun[fun {spell-root-word}, package {spell}, args {@i[index]}]
-This returns a copy of the root word at dictionary entry @i[index].  This index
-is the same as returned by @f[spell-try-word].
-@enddefun
-
-@defun[fun {spell-collect-close-words}, package {spell}, args {@i[word]}]
-This returns a list of words correctly spelled that are @i[close] to @i[word].
-@i[Word] must be uppercase, and its length must be inclusively in the range 2
-through @f[max-entry-length].  Close words are determined by the Ispell rules:
-@begin[enumerate]
-Two adjacent letters can be transposed to form a correct spelling.
-
-One letter can be changed to form a correct spelling.
-
-One letter can be added to form a correct spelling.
-
-One letter can be removed to form a correct spelling.
-@end[enumerate]
-@enddefun
-
-@defun[fun {spell-root-flags}, package {spell}, args {@i[index]}]
-This returns a list of suffix flags as capital letters that apply to the
-dictionary root entry at @i[index].  This index is the same as returned by
-@f[spell-try-word].
-@enddefun
-
-
-@section (File Utilities)
-Some implementations of @hemlock provide extensive directory editing commands,
-@hid[Dired], including a single wildcard feature.  An asterisk denotes a
-wildcard.
-
-@defun[fun {copy-file}, package {dired},
-       args {@i[spec1] @i[spec2]}, keys {[update][clobber][directory]}]
- This function copies @i[spec1] to @i[spec2].  It accepts a single wildcard in
-the filename portion of the specification, and it accepts directories.  This
-copies files maintaining the source's write date.
-
-If @i[spec1] and @i[spec2] are both directories, this recursively copies the
-files and subdirectory structure of @i[spec1]; if @i[spec2] is in the
-subdirectory structure of @i[spec1], the recursion will not descend into it.
-Use @f["/spec1/*"] to copy only the files from @i[spec1] to directory
-@i[spec2].
-
-If @i[spec2] is a directory, and @i[spec1] is a file, then this copies
-@i[spec1] into @i[spec2] with the same @f[pathname-name].
-
-When @kwd[update] is non-@nil, then the copying process only copies files if the
-source is newer than the destination.
-
-When @kwd[update] and @kwd[clobber] are @nil, and the destination exists, the
-copying process stops and asks the user whether the destination should be
-overwritten.
-
-When the user supplies @kwd[directory], it is a list of pathnames, directories
-excluded, and @i[spec1] is a pattern containing one wildcard.  This then copies
-each of the pathnames whose @f[pathname-name] matches the pattern.  @i[Spec2]
-is either a directory or a pathname whose @f[pathname-name] contains a
-wildcard.
-@enddefun
-
-@defun[fun {rename-file}, package {dired},
-       args {@i[spec1] @i[spec2]}, keys {[clobber][directory]}]
- This function renames @i[spec1] to @i[spec2].  It accepts a single wildcard in
-the filename portion of the specification, and @i[spec2] may be a directory
-with the destination specification resulting in the merging of @i[spec2] with
-@i[spec1].  If @kwd[clobber] is @nil, and @i[spec2] exists, then this asks the
-user to confirm the renaming.  When renaming a directory, end the specification
-without the trailing slash.
-
-When the user supplies @kwd[directory], it is a list of pathnames, directories
-excluded, and @i[spec1] is a pattern containing one wildcard.  This then copies
-each of the pathnames whose @f[pathname-name] matches the pattern.  @i[Spec2]
-is either a directory or a pathname whose @f[pathname-name] contains a
-wildcard.
-@enddefun
-
-@defun[fun {delete-file}, package {dired},
-       args {@i[spec]}, keys {[recursive][clobber]}]
- This function deletes @i[spec].  It accepts a single wildcard in the filename
-portion of the specification, and it asks for confirmation on each file if
-@kwd[clobber] is @nil.  If @kwd[recursive] is non-@nil, then @i[spec] may be a
-directory to recursively delete the entirety of the directory and its
-subdirectory structure.  An empty directory may be specified without
-@kwd[recursive] being non-@nil.  Specify directories with the trailing
-slash.
-@enddefun
-
-@defun[fun {find-file}, package {dired},
-       args {@i[name] @optional @i[directory] @i[find-all]}]
- This function finds the file with @f[file-namestring] @i[name], recursively
-looking in @i[directory].  If @i[find-all] is non-@nil (defaults to @nil), then
-this continues searching even after finding a first occurrence of file.
-@i[Name] may contain a single wildcard, which causes @i[find-all] to default to
-@true instead of @nil.
-@enddefun
-
-@defun[fun {make-directory}, package {dired}, args {@i[name]}]
-This function creates the directory with @i[name].  If it already exists, this
-signals an error.
-@enddefun
-
-@defun[fun {pathnames-from-pattern}, package {dired},
-       args {@i[pattern] @i[files]}]
-This function returns a list of pathnames from the list @i[files] whose
-@f[file-namestring]'s match @i[pattern].  @i[Pattern] must be a non-empty
-string and contain only one asterisk.  @i[Files] contains no directories.
-@enddefun
-
-@defvar[var {update-default}, package {dired}]
-@defvar1[var {clobber-default}, package {dired}]
-@defvar1[var {recursive-default}, package {dired}]
-These are the default values for the keyword arguments above with corresponding
-names.  These default to @nil, @true, and @nil respectively.
-@enddefvar
-
-@defvar[var {report-function}, package {dired}]
-@defvar1[var {error-function}, package {dired}]
-@defvar1[var {yesp-function}, package {dired}]
-These are the function the above routines call to report progress, signal
-errors, and prompt for @i[yes] or @i[no].  These all take format strings and
-arguments.
-@enddefvar
-
-
-@defun[fun {merge-relative-pathnames}, args {@i[pathname] @i[default-directory]}]
-This function merges @i[pathname] with @i[default-directory].  If @i[pathname]
-is not absolute, this assumes it is relative to @i[default-directory].  The
-result is always a directory pathname.
-@enddefun
-
-@defun[fun {directoryp}, args {@i[pathname]}]
-This function returns whether @i[pathname] names a directory: it has no name
-and no type fields.
-@enddefun
-
-
-@section (Beeping)
-
-@defun[fun {hemlock-beep}]
-@Hemlock binds @f[system:*beep-function*] to this function to beep the device.
-It is different for different devices.
-@enddefvar
-
-@defhvar[var "Bell Style", val {:border-flash}]
-@defhvar1[var "Beep Border Width", val {20}]
-@hid[Bell Style] determines what @var[hemlock-beep] does in @hemlock under CLX.
-Acceptable values are @kwd[border-flash], @kwd[feep],
-@kwd[border-flash-and-feep], @kwd[flash], @kwd[flash-and-feep], and @nil (do
-nothing).
-
-@hid[Beep Border Width] is the width in pixels of the border flashed by border
-flash beep styles.
-@enddefhvar
diff --git a/docs/hem/cim/cim.mss b/docs/hem/cim/cim.mss
deleted file mode 100644
index 03ae31f51712e36eacc62587993e49cf2919661e..0000000000000000000000000000000000000000
--- a/docs/hem/cim/cim.mss
+++ /dev/null
@@ -1,4039 +0,0 @@
-@make[Manual] @comment{-*- Dictionary: /afs/cs/project/clisp/docs/hem/hem; Mode: spell; Package: Hemlock; Log: /usr/lisp/scribe/hem/hem-docs.log -*-}
-@Device[postscript]
-@style(FontFamily = TimesRoman)
-@Style(Spacing = 1.2 lines)
-@Style(StringMax = 5000)
-@style(Hyphenation = On)
-@style(Date="March 1952")
-@use(database "/afs/cs/project/clisp/docs/database/")
-@Style [DoubleSided]
-@Libraryfile[ArpaCredit]
-@Libraryfile[Hem]
-@Libraryfile[Spice]
-@Libraryfile[Uttir]
-
-@String(ReportTitle "Hemlock Command Implementor's Manual")
-
-@comment<
-@begin[TitlePage]
-@begin[TitleBox]
->
-@blankspace(1.3inches)
-@heading[Hemlock Command Implementor's Manual]
-
-@center[
-@b<Bill Chiles>
-@b<Rob MacLachlan>
-
-@b<@value[date]>
-
-@b<CMU-CS-89-134-R1>
-]
-@comment<@end[TitleBox]>
-@blankspace(2lines)
-@begin[Center]
-School of Computer Science
-Carnegie Mellon University
-Pittsburgh, PA 15213
-@end[Center]
-
-@blankspace(2lines)
-@begin[Center]
-This is a revised version of Technical Report CMU-CS-87-159.
-@end[Center]
-@heading[Abstract]
-@begin(Text, indent 0)
-This document describes how to write commands for the @Hemlock text editor, as
-of version M3.2.  @Hemlock is a customizable, extensible text editor whose
-initial command set closely resembles that of ITS/TOPS-20 @Emacs.  @Hemlock is
-written in the CMU Common Lisp and has been ported to other implementations.
-@end(Text)
-
-@blankspace(0.5in)
-@begin[ResearchCredit]
-@arpacredit[Contract=Basic87-90]
-@end[ResearchCredit]
-@comment<@end[TitlePage]>
-
-
-@commandstring(dash = "@Y[M]")
-
-
-@Tabclear
-
-@chapter(Introduction)
-
- @hemlock is a text editor which follows in the tradition of editors
-such as EMACS and the Lisp Machine editor ZWEI.  In its basic form,
-@hemlock has almost the same command set as EMACS, and similar
-features such as multiple buffers and windows, extended commands,
-and built in documentation.
-
-Both user extensions and the original commands are written in Lisp,
-therefore a command implementor will have a working knowledge of this
-language.  Users not familiar with Lisp need not despair however.  Many
-users of Multics EMACS, another text editor written in Lisp, came to learn
-Lisp simply for the purpose of writing their own editor extensions, and
-found, to their surprise, that it was really pretty easy to write simple
-commands.
-
-This document describes the Common Lisp functions, macros and data structures
-that are used to implement new commands.  The basic editor consists of a set of
-Lisp utility functions for manipulating buffers and the other data structures
-of the editor as well as handling the display.  All user level commands are
-written in terms of these functions.  To find out how to define commands see
-chapter @ref[commands].
-
-@chapter(Representation of Text)
-@index (Lines)
-@section(Lines)
-In @hemlock all text is in some @i[line].  Text is broken into lines wherever
-it contains a newline character; newline characters are never stored, but are
-assumed to exist between every pair of lines.  The implicit newline character
-is treated as a single character by the text primitives.
-
-@defun[fun {linep}, args {@i[line]}]
-This function returns @true if @i[line] is a @f[line] object, otherwise @nil.
-@enddefun
-
-@defun[fun {line-string}, args {@i[line]}]
-Given a @i(line), this function returns as a simple string the characters in
-the line.  This is @f[setf]'able to set the @f[line-string] to any string that
-does not contain newline characters.  It is an error to destructively modify
-the result of @f[line-string] or to destructively modify any string after the
-@f[line-string] of some line has been set to that string.
-@enddefun
-
-@defun[fun {line-previous}, args {@i[line]}]
-@defun1[fun {line-next}, args {@i[line]}]
-Given a @i(line), @f[line-previous] returns the previous line or @nil if there
-is no previous line.  Similarly, @f[line-next] returns the line following
-@i[line] or @nil.
-@enddefun
-
-@defun[fun {line-buffer}, args {@i[line]}]
-This function returns the buffer which contains this @i(line).  Since a
-line may not be associated with any buffer, in which case @f[line-buffer]
-returns @nil.
-@enddefun
-
-@defun[fun {line-length}, args {@i[line]}]
-This function returns the number of characters in the @i(line).  This excludes
-the newline character at the end.
-@enddefun
-
-@defun[fun {line-character}, args {@i[line] @i[index]}]
-This function returns the character at position @i[index] within @i[line].  It
-is an error for @i[index] to be greater than the length of the line or less
-than zero.  If @i[index] is equal to the length of the line, this returns a
-@f[#\newline] character.
-@enddefun
-
-@defun[fun {line-plist}, args {@i[line]}]
-This function returns the property-list for @i[line].  @f[setf], @f[getf],
-@f[putf] and @f[remf] can be used to change properties.  This is typically used
-in conjunction with @f[line-signature] to cache information about the line's
-contents.
-@enddefun
-
-@defun[fun {line-signature}, args {@i[line]}]
-This function returns an object that serves as a signature for a @i[line]'s
-contents.  It is guaranteed that any modification of text on the line will
-result in the signature changing so that it is not @f[eql] to any previous
-value.  The signature may change even when the text remains unmodified, but
-this does not happen often.
-@enddefun
-
-
-@section(Marks)
-@label[marks]
-@index (Marks)
-A mark indicates a specific position within the text represented by a line and
-a character position within that line.  Although a mark is sometimes loosely
-referred to as pointing to some character, it in fact points between
-characters.  If the @f[charpos] is zero, the previous character is the newline
-character separating the previous line from the mark's @f[line].  If the
-charpos is equal to the number of characters in the line, the next character is
-the newline character separating the current line from the next.  If the mark's
-line has no previous line, a mark with @f[charpos] of zero has no previous
-character; if the mark's line has no next line, a mark with @f[charpos] equal
-to the length of the line has no next character.
-
-This section discusses the very basic operations involving marks, but a lot of
-@hemlock programming is built on altering some text at a mark.  For more
-extended uses of marks see chapter @ref[doing-stuff].
-
-
-@subsection(Kinds of Marks)
-@index (Permanent marks)
-@index (Temporary marks)
-A mark may have one of two lifetimes: @i[temporary] or @i[permanent].
-Permanent marks remain valid after arbitrary operations on the text; temporary
-marks do not.  Temporary marks are used because less bookkeeping overhead is
-involved in their creation and use.  If a temporary mark is used after the text
-it points to has been modified results will be unpredictable.  Permanent marks
-continue to point between the same two characters regardless of insertions and
-deletions made before or after them.
-
-There are two different kinds of permanent marks which differ only in their
-behavior when text is inserted @i(at the position of the mark); text is
-inserted to the left of a @i[left-inserting] mark and to the right of
-@i[right-inserting] mark.
-
-
-@subsection(Mark Functions)
-@defun[fun {markp}, args {@i[mark]}]
-This function returns @true if @i[mark] is a @f[mark] object, otherwise @nil.
-@enddefun
-
-@defun[fun {mark-line}, args {@i[mark]}]
-This function returns the line to which @i(mark) points.
-@enddefun
-
-@defun[fun {mark-charpos}, args {@i[mark]}]
-This function returns the character position of the character after @i(mark).
-If @i[mark]'s line has no next line, this returns the length of the line as
-usual; however, there is actually is no character after the mark.
-@enddefun
-
-@defun[fun {mark-kind}, args {@i[mark]}]
-This function returns one of @kwd[right-inserting], @kwd[left-inserting] or
-@kwd[temporary] depending on the mark's kind.  A corresponding @f[setf] form
-changes the mark's kind.
-@enddefun
-
-@defun[fun {previous-character}, args {@i[mark]}]
-@defun1[fun {next-character}, args {@i[mark]}]
-This function returns the character immediately before (after) the position of
-the @i[mark], or @nil if there is no previous (next) character.  These
-characters may be set with @f[setf] when they exist; the @f[setf] methods for
-these forms signal errors when there is no previous or next character.
-@enddefun
-
-
-@subsection(Making Marks)
-@defun[fun {mark}, args {@i[line] @i[charpos] @optional @i[kind]}]
-This function returns a mark object that points to the @i(charpos)'th character
-of the @i(line).  @i(Kind) is the kind of mark to create, one of
-@kwd[temporary], @kwd[left-inserting], or @kwd[right-inserting].  The default
-is @kwd[temporary].
-@enddefun
-
-@defun[fun {copy-mark}, args {@i[mark] @optional @i[kind]}]
-This function returns a new mark pointing to the same position and of the same
-kind, or of kind @i[kind] if it is supplied.
-@enddefun
-
-@defun[fun {delete-mark}, args {@i[mark]}]
-This function deletes @i(mark).  Delete any permanent marks when you are
-finished using it.
-@enddefun
-
-@Defmac[Fun {with-mark}, Args 
-        {(@Mstar<(@i[mark] @i[pos] @mopt[@i(kind)])>) @Mstar<@i[form]>}]
- This macro binds to each variable @i[mark] a mark of kind @i[kind], which
-defaults to @kwd[temporary], pointing to the same position as the mark @i[pos].
-On exit from the scope the mark is deleted.  The value of the last @i[form] is
-the value returned.
-@enddefmac
-
-
-@subsection(Moving Marks)
-@index(Moving marks)
-These functions destructively modify marks to point to new positions.  Other
-sections of this document describe mark moving routines specific to higher
-level text forms than characters and lines, such as words, sentences,
-paragraphs, Lisp forms, etc.
-
-@defun[fun {move-to-position}, args {@i[mark] @i[charpos] @optional @i[line]}]
-This function changes the @i(mark) to point to the given character position on
-the line @i(line).  @i(Line) defaults to @i[mark]'s line.
-@enddefun
-
-@defun[fun {move-mark}, args {@i[mark] @i[new-position]}]
-This function moves @i[mark] to the same position as the mark @i[new-position]
-and returns it.
-@enddefun
-
-@defun[fun {line-start}, args {@i[mark] @optional @i[line]}]
-@defun1[fun {line-end}, args {@i[mark] @optional @i[line]}]
-This function changes @i[mark] to point to the beginning or the end of @i(line)
-and returns it.  @i[Line] defaults to @i[mark]'s line.
-@enddefun
-
-@defun[fun {buffer-start}, args {@i[mark] @optional @i[buffer]}]
-@defun1[fun {buffer-end}, args {@i[mark] @optional @i[buffer]}]
-These functions change @i[mark] to point to the beginning or end of @i[buffer],
-which defaults to the buffer @i[mark] currently points into.  If @i[buffer] is
-unsupplied, then it is an error for @i[mark] to be disassociated from any
-buffer.
-@enddefun
-
-@defun[fun {mark-before}, args {@i[mark]}]
-@defun1[fun {mark-after}, args {@i[mark]}]
-These functions change @i[mark] to point one character before or after the
-current position.  If there is no character before/after the current position,
-then they return @nil and leave @i[mark] unmodified.
-@enddefun
-
-@defun[fun {character-offset}, args {@i[mark] @i[n]}]
-This function changes @i[mark] to point @i[n] characters after (@i[n] before if
-@i[n] is negative) the current position.  If there are less than @i[n]
-characters after (before) the @i[mark], then this returns @nil and @i[mark] is
-unmodified.
-@enddefun
-
-@defun[fun {line-offset}, args {@i[mark] @i[n] @optional @i[charpos]}]
-This function changes @i[mark] to point @i[n] lines after (@i[n] before if
-@i[n] is negative) the current position.  The character position of the
-resulting mark is
-@lisp
-(min (line-length @i(resulting-line)) (mark-charpos @i(mark)))
-@endlisp
-if @i[charpos] is unspecified, or
-@lisp
-(min (line-length @i(resulting-line)) @i(charpos))
-@endlisp
-if it is.  As with @t(character-offset), if there are not @i[n] lines then
-@nil is returned and @i[mark] is not modified.
-@enddefun
-
-
-@section(Regions)
-@index (Regions)
-A region is simply a pair of marks: a starting mark and an ending mark.
-The text in a region consists of the characters following the starting
-mark and preceding the ending mark (keep in mind that a mark points between
-characters on a line, not at them).
-
-By modifying the starting or ending mark in a region it is possible to
-produce regions with a start and end which are out of order or even in
-different buffers.  The use of such regions is undefined and may
-result in arbitrarily bad behavior.
-
-
-@subsection(Region Functions)
-@defun[fun {region}, args {@i[start] @i[end]}]
-This function returns a region constructed from the marks @i[start] and
-@i[end].  It is an error for the marks to point to non-contiguous lines or for
-@i(start) to come after @i(end).
-@enddefun
-
-@defun[fun {regionp}, args {@i[region]}]
-This function returns @true if @i[region] is a @f[region] object, otherwise
-@nil.
-@enddefun
-
-@defun[fun {make-empty-region}]
-This function returns a region with start and end marks pointing to the start
-of one empty line.  The start mark is a @kwd[right-inserting] mark, and the end
-is a @kwd[left-inserting] mark.
-@enddefun
-
-@defun[fun {copy-region}, args {@i[region]}]
-This function returns a region containing a copy of the text in the specified
-@i[region].  The resulting region is completely disjoint from @i[region] with
-respect to data references @dash marks, lines, text, etc.
-@enddefun
-
-@defun[fun {region-to-string}, args {@i[region]}]
-@defun1[fun {string-to-region}, args {@i[string]}]
-These functions coerce regions to Lisp strings and vice versa.  Within the
-string, lines are delimited by newline characters.
-@enddefun
-
-@defun[fun {line-to-region}, args {@i[line]}]
-This function returns a region containing all the characters on @i[line].  The
-first mark is @kwd[right-inserting] and the last is @kwd[left-inserting].
-@enddefun
-
-@defun[fun {region-start}, args {@i[region]}]
-@defun1[fun {region-end}, args {@i[region]}]
-This function returns the start or end mark of @i(region).
-@enddefun
-
-@defun[fun {region-bounds}, args {@i[region]}]
-This function returns as multiple-values the starting and ending marks of
-@i[region].
-@enddefun
-
-@defun[fun {set-region-bounds}, args {@i[region] @i[start] @i[end]}]
-This function sets the start and end of region to @i[start] and @i[end].  It is
-an error for @i[start] to be after or in a different buffer from @i[end].
-@enddefun
-
-@index(Counting lines and characters)
-@defun[fun {count-lines}, args {@i[region]}]
-This function returns the number of lines in the @i(region), first and last
-lines inclusive.  A newline is associated with the line it follows, thus a
-region containing some number of non-newline characters followed by one newline
-is one line, but if a newline were added at the beginning, it would be two
-lines.
-@enddefun
-
-@defun[fun {count-characters}, args {@i[region]}]
-This function returns the number of characters in a given @i(region).  This
-counts line breaks as one character.
-@enddefun
-
-@defun[fun {check-region-query-size}, args {@i[region]}]
-@defhvar1[var {Region Query Size}, val {30}]
-@f[check-region-query-size] counts the lines in @i[region], and if their number
-exceeds the @hid[Region Query Size] threshold, it prompts the user for
-confirmation.  This should be used in commands that perform destructive
-operations and are not undoable.  If the user responds negatively, then this
-signals an editor-error, aborting whatever command was in progress.
-@enddefun
-
-
-
-@chapter(Buffers)
-@index (Buffers)
-@label[buffers]
-A buffer is an environment within @hemlock consisting of:
-@begin(enumerate)
-A name.
-
-A piece of text.
-
-A current focus of attention, the point.
-
-An associated file (optional).
-
-A write protect flag.
-
-Some variables (page @pageref[variables]).
-
-Some key bindings (page @pageref[key-bindings]).
-
-Some collection of modes (page @pageref[modes]).
-
-Some windows in which it is displayed (page @pageref[windows]).
-
-A list of modeline fields (optional).
-@end(enumerate)
-
-
-@section (The Current Buffer)
-@index (Current buffer)
-@defun[fun {current-buffer}]
-@defhvar1[var {Set Buffer Hook}]
-@defhvar1[var {After Set Buffer Hook}]
-@f[current-buffer] returns the current buffer object.  Usually this is the
-buffer that @funref[current-window] is displaying.  This value may be changed
-with @f[setf], and the @f[setf] method invokes @hid[Set Buffer Hook] before the
-change occurs with the new value.  After the change occurs, the method invokes
-@hid[After Set Buffer Hook] with the old value.
-@enddefun
-
-@defun[fun {current-point}]
-This function returns the @f[buffer-point] of the current buffer.
-This is such a common idiom in commands that it is defined despite
-its trivial implementation.
-@enddefun
-
-@defun[fun {current-mark}]
-@defun1[fun {pop-buffer-mark}]
-@defun1[fun {push-buffer-mark}, args {@i[mark] @optional @i[activate-region]}]
-@index(Buffer mark stack)
-@index(Mark stack)
-@label(mark-stack)
-@f[current-mark] returns the top of the current buffer's mark stack.  There
-always is at least one mark at the beginning of the buffer's region, and all
-marks returned are right-inserting.
-
-@f[pop-buffer-mark] pops the current buffer's mark stack, returning the mark.
-If the stack becomes empty, this pushes a new mark on the stack pointing to the
-buffer's start.  This always deactivates the current region (see section
-@ref[active-regions]).
-
-@f[push-buffer-mark] pushes @i[mark] into the current buffer's mark stack,
-ensuring that the mark is right-inserting.  If @i[mark] does not point into the
-current buffer, this signals an error.  Optionally, the current region is made
-active, but this never deactivates the current region (see section
-@ref[active-regions]).  @i[Mark] is returned.
-@enddefun
-
-@defvar[var {buffer-list}]
-This variable holds a list of all the buffer objects made with @f[make-buffer].
-@enddefvar
-
-@defvar[var {buffer-names}]
-This variable holds a @f[string-table] (page @pageref(string-tables)) of all the
-names of the buffers in @var[buffer-list].  The values of the entries are the
-corresponding buffer objects.
-@enddefvar
-
-@defvar[var {buffer-history}]
-This is a list of buffer objects ordered from those most recently selected to
-those selected farthest in the past.  When someone makes a buffer, an element
-of @hid[Make Buffer Hook] adds this buffer to the end of this list.  When
-someone deletes a buffer, an element of @hid[Delete Buffer Hook] removes the
-buffer from this list.  Each buffer occurs in this list exactly once, but it
-never contains the @var[echo-area-buffer].
-@enddefvar
-
-@defun[fun {change-to-buffer}, args {@i[buffer]}]
-This switches to @i[buffer] in the @f[current-window] maintaining
-@f[buffer-history].
-@enddefun
-
-@defun[fun {previous-buffer}]
-This returns the first buffer from @var[buffer-history] that is not the
-@f[current-buffer].  If none can be found, then this returns @nil.
-@enddefun
-
-
-@section(Buffer Functions)
-@defun[fun {make-buffer}, args {@i[name]}, keys {[modes][modeline-fields][delete-hook]}]
-@defhvar1[var {Make Buffer Hook}]
-@defhvar1[var {Default Modeline Fields}]
-@f[make-buffer] creates and returns a buffer with the given @i(name).  If a
-buffer named @i[name] already exists, @nil is returned.  @i[Modes] is a list of
-modes which should be in effect in the buffer, major mode first, followed by
-any minor modes.  If this is omitted then the buffer is created with the list
-of modes contained in @hvarref[Default Modes].  @i[Modeline-fields] is a list
-of modeline-field objects (see section @ref[modelines]) which may be @nil.
-@f[delete-hook] is a list of delete hooks specific to this buffer, and
-@f[delete-buffer] invokes these along with @hid[Delete Buffer Hook].
-
-Buffers created with @f[make-buffer] are entered into the list
-@var[buffer-list], and their names are inserted into the
-string-table @var[buffer-names].  When a buffer is created the hook
-@hid[Make Buffer Hook] is invoked with the new buffer.
-@enddefun
-
-@defun[fun {bufferp}, args {@i[buffer]}]
-Returns @true if @i[buffer] is a @f[buffer] object, otherwise @nil.
-@enddefun
-
-@defun[fun {buffer-name}, args {@i[buffer]}]
-@defhvar1[var {Buffer Name Hook}]
-@f[buffer-name] returns the name, which is a string, of the given @i(buffer).
-The corresponding @f[setf] method invokes @hid[Buffer Name Hook] with
-@i[buffer] and the new name and then sets the buffer's name.  When the user
-supplies a name for which a buffer already exists, the @f[setf] method signals
-an error.
-@enddefun
-
-@defun[fun {buffer-region}, args {@i[buffer]}]
-Returns the @i[buffer]'s region.  This can be set with @f[setf].  Note, this
-returns the region that contains all the text in a buffer, not the
-@funref[current-region].
-@enddefun
-
-@defun[fun {buffer-pathname}, args {@i[buffer]}]
-@defhvar1[var {Buffer Pathname Hook}]
-@f[buffer-pathname] returns the pathname of the file associated with
-the given @i(buffer), or nil if it has no associated file.  This is
-the truename of the file as of the most recent time it was read or
-written.  There is a @f[setf] form to change the pathname.  When the
-pathname is changed the hook @hid[Buffer Pathname Hook] is invoked
-with the buffer and new value.
-@enddefun
-
-@defun[fun {buffer-write-date}, args {@i[buffer]}]
-Returns the write date for the file associated with the buffer in universal
-time format.  When this the @f[buffer-pathname] is set, use @f[setf] to set
-this to the corresponding write date, or to @nil if the date is unknown or
-there is no file.
-@enddefun
-
-@defun[fun {buffer-point}, args {@i[buffer]}]
-Returns the mark which is the current location within @i[buffer].  To
-move the point, use @f[move-mark] or @funref[move-to-position] rather
-than setting @f[buffer-point] with @f[setf].
-@enddefun
-
-@defun[fun {buffer-mark}, args {@i[buffer]}]
-@index(Buffer mark stack)
-@index(Mark stack)
-This function returns the top of @i[buffer]'s mark stack.  There always
-is at least one mark at the beginning of @i[buffer]'s region, and all marks
-returned are right-inserting.
-@enddefun
-
-@defun[fun {buffer-start-mark}, args {@i[buffer]}]
-@defun1[fun {buffer-end-mark}, args {@i[buffer]}]
-These functions return the start and end marks of @i[buffer]'s region:
-@Begin[ProgramExample]
-(buffer-start-mark buffer)  <==>
-  (region-start (buffer-region buffer))
-and
-(buffer-end-mark buffer)  <==>
-  (region-end (buffer-region buffer))
-@End[ProgramExample]
-@enddefun
-
-@defun[fun {buffer-writable}, args {@i[buffer]}]
-@defhvar1[var "Buffer Writable Hook"]
-This function returns @true if you can modify the @i(buffer), @nil if you
-cannot.  If a buffer is not writable, then any attempt to alter text in the
-buffer results in an error.  There is a @f[setf] method to change this value.
-
-The @f[setf] method invokes the functions in @hid[Buffer Writable Hook] on the
-buffer and new value before storing the new value.
-@enddefun
-
-@defun[fun {buffer-modified}, args {@i[buffer]}]
-@defhvar1[var "Buffer Modified Hook"]
-@f[buffer-modified] returns @true if the @i[buffer] has been modified, @nil if
-it hasn't.  This attribute is set whenever a text-altering operation is
-performed on a buffer.  There is a @f[setf] method to change this value.
-
-The @f[setf] method invokes the functions in @hid[Buffer Modified Hook] with
-the buffer whenever the value of the modified flag changes.
-@enddefun
-
-@defmac[fun {with-writable-buffer}, args {(@i[buffer]) @rest @i[forms]}]
-This macro executes @i[forms] with @i[buffer]'s writable status set.  After
-@i[forms] execute, this resets the @i[buffer]'s writable and modified status.
-@enddefmac
-
-@defun[fun {buffer-signature}, args {@i[buffer]}]
-This function returns an arbitrary number which reflects the buffer's current
-@i[signature].  The result is @f[eql] to a previous result if and only if the
-buffer has not been modified between the calls.
-@enddefun
-
-@defun[fun {buffer-variables}, args {@i[buffer]}]
-This function returns a string-table (page @pageref[string-tables]) containing
-the names of the buffer's local variables.  See chapter @ref[variables].
-@enddefun
-
-@defun[fun {buffer-modes}, args {@i[buffer]}]
-This function returns the list of the names of the modes active in @i[buffer].
-The major mode is first, followed by any minor modes.  See chapter @ref[modes].
-@enddefun
-
-@defun[fun {buffer-windows}, args {@i[buffer]}]
-This function returns the list of all the windows in which the buffer may be
-displayed.  This list may include windows which are not currently visible.  See
-page @pageref[windows] for a discussion of windows.
-@enddefun
-
-@defun[fun {buffer-delete-hook}, args {@i[buffer]}]
-This function returns the list of buffer specific functions @f[delete-buffer]
-invokes when deleting a buffer.  This is @f[setf]'able.
-@enddefun
-
-@defun[fun {delete-buffer}, args {@i[buffer]}]
-@defhvar1[var {Delete Buffer Hook}]
-@f[delete-buffer] removes @i[buffer] from @varref[buffer-list] and its name
-from @varref[buffer-names].  Before @i[buffer] is deleted, this invokes the
-functions on @i[buffer] returned by @f[buffer-delete-hook] and those found in
-@hid[Delete Buffer Hook].  If @i[buffer] is the @f[current-buffer], or if it is
-displayed in any windows, then this function signals an error.
-@enddefun
-
-@defun[fun {delete-buffer-if-possible}, args {@i[buffer]}]
-This uses @f[delete-buffer] to delete @i[buffer] if at all possible.  If
-@i[buffer] is the @f[current-buffer], then this sets the @f[current-buffer] to
-the first distinct buffer in @f[buffer-history].  If @i[buffer] is displayed in
-any windows, then this makes each window display the same distinct buffer.
-@enddefun
-
-
-@section(Modelines)
-@index(Modelines)
-@label(modelines)
-
-A Buffer may specify a modeline, a line of text which is displayed across the
-bottom of a window to indicate status information.  Modelines are described as
-a list of @f[modeline-field] objects which have individual update functions and
-are optionally fixed-width.  These have an @f[eql] name for convenience in
-referencing and updating, but the name must be unique for all created
-modeline-field objects.  When creating a modeline-field with a specified width,
-the result of the update function is either truncated or padded on the right to
-meet the constraint.  All modeline-field functions must return simple strings
-with standard characters, and these take a buffer and a window as arguments.
-Modeline-field objects are typically shared amongst, or aliased by, different
-buffers' modeline fields lists.  These lists are unique allowing fields to
-behave the same wherever they occur, but different buffers may display these
-fields in different arrangements.
-
-Whenever one of the following changes occurs, all of a buffer's modeline fields
-are updated:
-@Begin[Itemize]
-A buffer's major mode is set.
-
-One of a buffer's minor modes is turned on or off.
-
-A buffer is renamed.
-
-A buffer's pathname changes.
-
-A buffer's modified status changes.
-
-A window's buffer is changed.
-@End[Itemize]
-
-The policy is that whenever one of these changes occurs, it is guaranteed that
-the modeline will be updated before the next trip through redisplay.
-Furthermore, since the system cannot know what modeline-field objects the
-user has added whose update functions rely on these values, or how he has
-changed @hid[Default Modeline Fields], we must update all the fields.  When any
-but the last occurs, the modeline-field update function is invoked once for
-each window into the buffer.  When a window's buffer changes, each
-modeline-field update function is invoked once; other windows' modeline
-fields should not be affected due to a given window's buffer changing.
-
-The user should note that modelines can be updated at any time, so update
-functions should be careful to avoid needless delays (for example, waiting for
-a local area network to determine information).
-
-@defun[fun {make-modeline-field}, keys {[name][width][function]}]
-@defun1[fun {modeline-field-p}, args @i(modeline-field)]
-@defun1[fun {modeline-field-name}, args @i(modeline-field)]
-@f[make-modeline-field] returns a modeline-field object with @i[name],
-@i[width], and @i[function].  @i[Width] defaults to @nil meaning that the field
-is variable width; otherwise, the programmer must supply this as a positive
-integer.  @i[Function] must take a buffer and window as arguments and return a
-@f[simple-string] containing only standard characters.  If @i[name] already
-names a modeline-field object, then this signals an error.
-
-@f[modeline-field-name] returns the name field of a modeline-field object.  If
-this is set with @f[setf], and the new name already names a modeline-field,
-then the @f[setf] method signals an error.
-
-@f[modeline-field-p] returns @true or @nil, depending on whether its argument
-is a @f[modeline-field] object.
-@enddefun
-
-@defun[fun {modeline-field}, args {@i[name]}]
-This returns the modeline-field object named @i[name].  If none exists, this
-returns nil.
-@enddefun
-
-@defun[fun {modeline-field-function}, args {@i[modeline-field]}]
-Returns the function called when updating the @i[modeline-field].  When this is
-set with @f[setf], the @f[setf] method updates @i[modeline-field] for all
-windows on all buffers that contain the given field, so the next trip through
-redisplay will reflect the change.  All modeline-field functions must return
-simple strings with standard characters, and they take a buffer and a window
-as arguments.
-@enddefun
-
-@defun[fun {modeline-field-width}, args {@i[modeline-field]}]
-Returns the width to which @i[modeline-field] is constrained, or @nil
-indicating that it is variable width.  When this is set with @f[setf], the
-@f[setf] method updates all modeline-fields for all windows on all buffers that
-contain the given field, so the next trip through redisplay will reflect the
-change.  All the fields for any such modeline display must be updated, which is
-not the case when setting a modeline-field's function.
-@enddefun
-
-@defun[fun {buffer-modeline-fields}, args {@i[buffer]}]
-Returns a copy of the list of @i[buffer]'s modeline-field objects.  This list
-can be destructively modified without affecting display of @i[buffer]'s
-modeline, but modifying any particular field's components (for example, width
-or function) causes the changes to be reflected the next trip through redisplay
-in every modeline display that uses the modified modeline-field.  When this is
-set with @f[setf], @f[update-modeline-fields] is called for each window into
-@i[buffer].
-@enddefun
-
-@defun[fun {buffer-modeline-field-p}, args {@i[buffer] @i[field]}]
-If @i[field], a modeline-field or the name of one, is in buffer's list of
-modeline-field objects, it is returned; otherwise, this returns nil.
-@enddefun
-
-@defun[fun {update-modeline-fields}, args {@i[buffer] @i[window]}]
-This invokes each modeline-field object's function from @i[buffer]'s list,
-passing @i[buffer] and @i[window].  The results are collected regarding each
-modeline-field object's width as appropriate, and the window is marked so
-the next trip through redisplay will reflect the changes.  If window does not
-display modelines, then no computation occurs.
-@enddefun
-
-@defun[fun {update-modeline-field}, args {@i[buffer] @i[window] @i[field-or-name}]
-This invokes the modeline-field object's function for @i[field-or-name], which
-is a modeline-field object or the name of one for @i[buffer].  This passes
-@i[buffer] and @i[window] to the update function.  The result is applied to the
-@i[window]'s modeline display using the modeline-field object's width, and the
-window is marked so the next trip through redisplay will reflect the changes.
-If the window does not display modelines, then no computation occurs.  If
-@i[field-or-name] is not found in @i[buffer]'s list of modeline-field objects,
-then this signals an error.  See @f[buffer-modeline-field-p] above.
-@enddefun
-
-
-
-@chapter(Altering and Searching Text)
-@label[doing-stuff]
-
-@section(Altering Text)
-@index(Altering text)
-@index(Inserting)
-@index(Deleting)
-A note on marks and text alteration: @kwd[temporary] marks are invalid
-after any change has been made to the text the mark points to; it is an
-error to use a temporary mark after such a change has been made.  If
-text is deleted which has permanent marks pointing into it then they
-are left pointing to the position where the text was.
-
-@defun[fun {insert-character}, args {@i[mark] @i[character]}]
-@defun1[fun {insert-string}, args {@i[mark] @i[string]}]
-@defun1[fun {insert-region}, args {@i[mark] @i[region]}]
-Inserts @i[character], @i[string] or @i[region] at @i[mark].
-@f[insert-character] signals an error if @i[character] is not
-@f[string-char-p].  If @i[string] or @i[region] is empty, and @i[mark] is in
-some buffer, then @hemlock leaves @f[buffer-modified] of @i[mark]'s buffer
-unaffected.
-@enddefun
-
-@defun[fun {ninsert-region}, args {@i[mark] @i[region]}]
-Like @f[insert-region], inserts the @i[region] at the @i[mark]'s position,
-destroying the source region.  This must be used with caution, since if anyone
-else can refer to the source region bad things will happen.  In particular, one
-should make sure the region is not linked into any existing buffer.  If
-@i[region] is empty, and @i[mark] is in some buffer, then @hemlock leaves
-@f[buffer-modified] of @i[mark]'s buffer unaffected.
-@enddefun
-
-@defun[fun {delete-characters}, args {@i[mark] @i[n]}]
-This deletes @i[n] characters after the @i[mark] (or -@i[n] before if @i[n] is
-negative).  If @i[n] characters after (or -@i[n] before) the @i[mark] do not
-exist, then this returns @nil; otherwise, it returns @true.  If @i[n] is zero,
-and @i[mark] is in some buffer, then @hemlock leaves @f[buffer-modified] of
-@i[mark]'s buffer unaffected.
-@enddefun
-
-@defun[fun {delete-region}, args {@i[region]}]
-This deletes @i[region].  This is faster than @f[delete-and-save-region]
-(below) because no lines are copied.  If @i[region] is empty and contained in
-some buffer's @f[buffer-region], then @hemlock leaves @f[buffer-modified] of
-the buffer unaffected.
-@enddefun
-
-@defun[fun {delete-and-save-region}, args {@i[region]}]
-This deletes @i[region] and returns a region containing the original
-@i[region]'s text.  If @i[region] is empty and contained in some buffer's
-@f[buffer-region], then @hemlock leaves @f[buffer-modified] of the buffer
-unaffected.  In this case, this returns a distinct empty region.
-@enddefun
-
-@defun[fun {filter-region}, args {@i[function] @i[region]}]
-Destructively modifies @i[region] by replacing the text
-of each line with the result of the application of @i[function] to a
-string containing that text.  @i[Function] must obey the following
-restrictions:
-@begin[enumerate]
-The argument may not be destructively modified.
-
-The return value may not contain newline characters.
-
-The return value may not be destructively modified after it is
-returned from @i[function].
-@end[enumerate]
-The strings are passed in order, and are always simple strings.
-
-Using this function, a region could be uppercased by doing:
-@lisp
-(filter-region #'string-upcase region)
-@endlisp
-@enddefun
-
-
-@section(Text Predicates)
-@defun[fun {start-line-p}, args {@i[mark]}]
-Returns @true if the @i(mark) points before the first character in a line,
-@nil otherwise.
-@enddefun
-
-@defun[fun {end-line-p}, args {@i[mark]}]
-Returns @true if the @i(mark) points after the last character in a line and
-before the newline, @nil otherwise.
-@enddefun
-
-@defun[fun {empty-line-p}, args {@i[mark]}]
-Return @true of the line which @i[mark] points to contains no characters.
-@enddefun
-
-@defun[fun {blank-line-p}, args {@i[line]}]
-Returns @true if @i[line] contains only characters with a
-@hid[Whitespace] attribute of 1.  See chapter @ref[character-attributes] for
-discussion of character attributes.
-@enddefun
-
-@defun[fun {blank-before-p}, args {@i[mark]}]
-@defun1[fun {blank-after-p}, args {@i[mark]}]
-These functions test if all the characters preceding or following
-@i[mark] on the line it is on have a @hid[Whitespace] attribute of @f[1].
-@enddefun
-
-@defun[fun {same-line-p}, args {@i[mark1] @i[mark2]}]
-Returns @true if @i(mark1) and @i(mark2) point to the same line, or @nil
-otherwise;  That is,
-@example[(same-line-p a b) <==> (eq (mark-line a) (mark-line b))]
-@enddefun
-
-@defun[fun {mark<}, funlabel {mark-LSS}, args {@i[mark1] @i[mark2]}]
-@defun1[fun {mark<=}, funlabel {mark-LEQ}, args {@i[mark1] @i[mark2]}]
-@defun1[fun {mark=}, funlabel {mark-EQL}, args {@i[mark1] @i[mark2]}]
-@defun1[fun {mark/=}, funlabel {mark-NEQ}, args {@i[mark1] @i[mark2]}]
-@defun1[fun {mark>=}, funlabel {mark-GEQ}, args {@i[mark1] @i[mark2]}]
-@defun1[fun {mark>}, funlabel {mark-GTR}, args {@i[mark1] @i[mark2]}]
-These predicates test the relative ordering of two marks in a piece of
-text, that is a mark is @f[mark>] another if it points to a position
-after it.  If the marks point into different, non-connected pieces of
-text, such as different buffers, then it is an error to test their
-ordering; for such marks @f[mark=] is always false and @f[mark/=] is
-always true.
-@enddefun
-
-@defun[fun {line<}, funlabel {line-LSS}, args {@i[line1] @i[line2]}]
-@defun1[fun {line<=}, funlabel {line-LEQ}, args {@i[line1] @i[line2]}]
-@defun1[fun {line>=}, funlabel {line-GEQ}, args {@i[line1] @i[line2]}]
-@defun1[fun {line>}, funlabel {line-GTR}, args {@i[line1] @i[line2]}]
-These predicates test the ordering of @i[line1] and @i[line2].  If the
-lines are in unconnected pieces of text it is an error to test their
-ordering.
-@enddefun
-
-@defun[fun {lines-related}, args {@i[line1] @i[line2]}]
-This function returns @true if @i[line1] and @i[line2] are in the same
-piece of text, or @nil otherwise.
-@enddefun
-
-@defun[fun {first-line-p}, args {@i[mark]}]
-@defun1[fun {last-line-p}, args {@i[mark]}]
-@f[first-line-p] returns @true if there is no line before the line
-@i[mark] is on, and @nil otherwise.  @i[Last-line-p] similarly tests
-tests whether there is no line after @i[mark].
-@enddefun
-
-
-@section(Kill Ring)
-@index(Kill ring)
-@label(kill-ring)
-
-@defvar[var {kill-ring}]
-This is a ring (see section @ref[rings]) of regions deleted from buffers.
-Some commands save affected regions on the kill ring before performing
-modifications.  You should consider making the command undoable (see section
-@ref[undo]), but this is a simple way of achieving a less satisfactory means
-for the user to recover.
-@enddefvar
-
-@defun[fun {kill-region}, args {@i[region] @i[current-type]}]
-This kills @i[region] saving it in @var[kill-ring].  @i[Current-type] is either
-@kwd[kill-forward] or @kwd[kill-backward].  When the @funref[last-command-type]
-is one of these, this adds @i[region] to the beginning or end, respectively, of
-the top of @var[kill-ring].  The result of calling this is undoable using the
-command @hid[Undo] (see the @i[Hemlock User's Manual]).  This sets
-@f[last-command-type] to @i[current-type], and it interacts with
-@f[kill-characters].
-@enddefun
-
-@defun[fun {kill-characters}, args {@i[mark] @i[count]}]
-@defhvar1[var {Character Deletion Threshold}, val {5}]
-@f[kill-characters] kills @i[count] characters after @i[mark] if @i[count] is
-positive, otherwise before @i[mark] if @i[count] is negative.  When @i[count]
-is greater than or equal to @hid[Character Deletion Threshold], the killed
-characters are saved on @var[kill-ring].  This may be called multiple times
-contiguously (that is, without @funref[last-command-type] being set) to
-accumulate an effective count for purposes of comparison with the threshold.
-
-This sets @f[last-command-type], and it interacts with @f[kill-region].  When
-this adds a new region to @var[kill-ring], it sets @f[last-command-type] to
-@kwd[kill-forward] (if @i[count] is positive) or @kwd[kill-backward] (if
-@i[count] is negative).  When @f[last-command-type] is @kwd[kill-forward] or
-@kwd[kill-backward], this adds the killed characters to the beginning (if
-@i[count] is negative) or the end (if @i[count] is positive) of the top of
-@var[kill-ring], and it sets @f[last-command-type] as if it added a new region
-to @var[kill-ring].  When the kill ring is unaffected, this sets
-@f[last-command-type] to @kwd[char-kill-forward] or @kwd[char-kill-backward]
-depending on whether @i[count] is positive or negative, respectively.
-
-This returns mark if it deletes characters.  If there are not @i[count]
-characters in the appropriate direction, this returns nil.
-@enddefun
-
-
-@section(Active Regions)
-@index(Active regions)
-@label(active-regions)
-
-Every buffer has a mark stack (page @pageref[mark-stack]) and a mark known as
-the point where most text altering nominally occurs.  Between the top of the
-mark stack, the @f[current-mark], and the @f[current-buffer]'s point, the
-@f[current-point], is what is known as the @f[current-region].  Certain
-commands signal errors when the user tries to operate on the @f[current-region]
-without its having been activated.  If the user turns off this feature, then
-the @f[current-region] is effectively always active.
-
-When writing a command that marks a region of text, the programmer should make
-sure to activate the region.  This typically occurs naturally from the
-primitives that you use to mark regions, but sometimes you must explicitly
-activate the region.  These commands should be written this way, so they do not
-require the user to separately mark an area and then activate it.  Commands
-that modify regions do not have to worry about deactivating the region since
-modifying a buffer automatically deactivates the region.  Commands that insert
-text often activate the region ephemerally; that is, the region is active for
-the immediately following command, allowing the user wants to delete the region
-inserted, fill it, or whatever.
-
-Once a marking command makes the region active, it remains active until:
-@begin[itemize]
-a command uses the region,
-
-a command modifies the buffer,
-
-a command changes the current window or buffer,
-
-a command signals an editor-error,
-
-or the user types @binding[C-g].
-@end[itemize]
-
-@defhvar[var "Active Regions Enabled", val {t}]
-When this variable is non-@nil, some primitives signal an editor-error if
-the region is not active.  This may be set to @nil for more traditional @emacs
-region semantics.
-@enddefhvar
-
-@defvar[var {ephemerally-active-command-types}]
-This is a list of command types (see section @ref[command-types]), and its
-initial value is the list of @kwd[ephemerally-active] and @kwd[unkill].  When
-the previous command's type is one of these, the @f[current-region] is active
-for the currently executing command only, regardless of whether it does
-something to deactivate the region.  However, the current command may activate
-the region for future commands.  @kwd[ephemerally-active] is a default command
-type that may be used to ephemerally activate the region, and @kwd[unkill] is
-the type used by two commands, @hid[Un-kill] and @hid[Rotate Kill Ring] (what
-users typically think of as @binding[C-y] and @binding[M-y]).
-@enddefvar
-
-@defun[fun {activate-region}]
-This makes the @f[current-region] active.
-@enddefun
-
-@defun[fun {deactivate-region}]
-After invoking this the @f[current-region] is no longer active.
-@enddefun
-
-@defun[fun {region-active-p}]
-Returns whether the @f[current-region] is active, including ephemerally.  This
-ignores @hid[Active Regions Enabled].
-@enddefun
-
-@defun[fun {check-region-active}]
-This signals an editor-error when active regions are enabled, and the
-@f[current-region] is not active.
-@enddefun
-
-@defun[fun {current-region},
-       args {@optional @i[error-if-not-active] @i[deactivate-region]}]
-This returns a region formed with @f[current-mark] and @f[current-point],
-optionally signaling an editor-error if the current region is not active.
-@i[Error-if-not-active] defaults to @true.  Each call returns a distinct region
-object.  Depending on @i[deactivate-region] (defaults to @true), fetching the
-current region deactivates it.  @hemlock primitives are free to modify text
-regardless of whether the region is active, so a command that checks for this
-can deactivate the region whenever it is convenient.
-@enddefun
-
-
-@section(Searching and Replacing)
-@index(Searching)
-@index(Replacing)
-
-Before using any of these functions to do a character search, look at character
-attributes (page @pageref[character-attributes]).  They provide a facility
-similar to the syntax table in real EMACS.  Syntax tables are a powerful,
-general, and efficient mechanism for assigning meanings to characters in
-various modes.
-
-@defcon[var {search-char-code-limit}]
-An exclusive upper limit for the char-code of characters given to the searching
-functions.  The result of searches for characters with a char-code greater than
-or equal to this limit is ill-defined, but it is @i[not] an error to do such
-searches.
-@enddefcon
-
-@defun[fun {new-search-pattern},
-args {@i[kind] @i[direction] @i[pattern] @optional @i[result-search-pattern]}] 
-
-Returns a @i[search-pattern] object which can be given to the @f[find-pattern]
-and @f[replace-pattern] functions.  A search-pattern is a specification of a
-particular sort of search to do.  @i[direction] is either @kwd[forward] or
-@kwd[backward], indicating the direction to search in.  @i[kind] specifies the
-kind of search pattern to make, and @i[pattern] is a thing which specifies what
-to search for.
-
-The interpretation of @i[pattern] depends on the @i[kind] of pattern being
-made.  Currently defined kinds of search pattern are:
-@begin(description)
-@kwd[string-insensitive]@\Does a case-insensitive string search,
-@i[pattern] being the string to search for.
-
-@kwd[string-sensitive]@\Does a case-sensitive string search for
-@i[pattern].
-
-@kwd[character]@\Finds an occurrence of the character @i[pattern].
-This is case sensitive.
-
-@kwd[not-character]@\Find a character which is not the character
-@i[pattern].
-
-@kwd[test]@\Finds a character which satisfies the function @i[pattern].
-This function may not be applied an any particular fashion, so it
-should depend only on what its argument is, and should have no
-side-effects.
-
-@kwd[test-not]@\Similar to as @kwd[test], except it finds a character that
-fails the test.
-
-@kwd[any]@\Finds a character that is in the string @i[pattern].
-
-@kwd[not-any]@\Finds a character that is not in the string @i[pattern].
-@end(description)
-
-@i[result-search-pattern], if supplied, is a search-pattern to
-destructively modify to produce the new pattern.  Where reasonable
-this should be supplied, since some kinds of search patterns may
-involve large data structures.
-@enddefun
-
-@defun[fun {search-pattern-p}, args {@i[search-pattern]}]
-Returns @true if @i[search-pattern] is a @f[search-pattern] object, otherwise
-@nil.
-@enddefun
-
-@defun[fun {get-search-pattern}, args {@i[string] @i[direction]}]
-@defvar1[var {last-search-pattern}]
-@defvar1[var {last-search-string}]
-@f[get-search-pattern] interfaces to a default search string and pattern that
-search and replacing commands can use.  These commands then share a default
-when prompting for what to search or replace, and save on consing a search
-pattern each time they execute.  This uses @hid[Default Search Kind] (see the
-@i[Hemlock User's Manual]) when updating the pattern object.  This returns the
-pattern, so you probably don't need to refer to @var[last-search-pattern], but
-@var[last-search-string] is useful when prompting.
-@enddefun
-
-@defun[fun {find-pattern}, args {@i[mark] @i[search-pattern]}]
-Find the next match of @i[search-pattern] starting at @i[mark].  If a
-match is found then @i[mark] is altered to point before the matched text
-and the number of characters matched is returned.  If no match is
-found then @nil is returned and @i[mark] is not modified.
-@enddefun
-
-@defun[fun {replace-pattern}, args
-        {@i[mark] @i[search-pattern] @i[replacement] @optional @i[n]}]
-Replace @i[n] matches of @i[search-pattern] with the string
-@i[replacement] starting at @i[mark].  If @i[n] is @nil (the default)
-then replace all matches.  A mark pointing before the last replacement
-done is returned.
-@enddefun
-
-
-
-@Chapter(The Current Environment)
-@label(current-environment)
-@index(Current environment)
-
-@section(Different Scopes)
-    In @hemlock the values of @i[variables] (page @pageref[variables]),
-@i[key-bindings] (page @pageref(key-bindings)) and
-@i[character-attributes] (page @pageref[character-attributes]) may
-depend on the @funref(current-buffer) and the modes
-active in it.  There are three possible scopes for
-@hemlock values:
-@begin(description)
-@i[buffer local]@\The value is present only if the buffer it is local
-to is the @f[current-buffer].
-
-@i[mode local]@\The value is present only when the mode it is local to
-is active in the @f[current-buffer].
-
-@i[global]@\The value is always present unless shadowed by a buffer or
-mode local value.
-@end(description)
-
-
-@section(Shadowing)
-    It is possible for there to be a conflict between different values
-for the same thing in different scopes.  For example, there be might a
-global binding for a given variable and also a local binding in the
-current buffer.  Whenever there is a conflict shadowing occurs,
-permitting only one of the values to be visible in the current
-environment.
-
-    The process of resolving such a conflict can be described as a
-search down a list of places where the value might be defined, returning
-the first value found.  The order for the search is as follows:
-@begin(enumerate)
-Local values in the current buffer.
-
-Mode local values in the minor modes of the current buffer, in order
-from the highest precedence mode to the lowest precedence mode.  The
-order of minor modes with equal precedences is undefined.
-
-Mode local values in the current buffer's major mode.
-
-Global values.
-@end(enumerate)
-
-
-
-@chapter(Hemlock Variables)
-@index (Hemlock variables)
-@label(variables)
-@hemlock implements a system of variables separate from normal Lisp variables
-for the following reasons:
-@begin(enumerate)
-@hemlock has different scoping rules which are useful in an editor.  @hemlock
-variables can be local to a @i(buffer) (page @pageref[buffers]) or a @i(mode)
-(page @pageref[modes]).
-
-@hemlock variables have @i(hooks) (page @pageref[hooks]), lists of functions
-called when someone sets the variable.  See @f[variable-value] for the
-arguments @hemlock passes to these hook functions.
-
-There is a database of variable names and documentation which makes it easier
-to find out what variables exist and what their values mean.
-@end(enumerate)
-
-
-@section(Variable Names)
-To the user, a variable name is a case insensitive string.  This
-string is referred to as the @i[string name] of the variable.  A
-string name is conventionally composed of words separated by spaces.
-
-In Lisp code a variable name is a symbol.  The name of this symbol is
-created by replacing any spaces in the string name with hyphens.  This
-symbol name is always interned in the @hemlock package and referring
-to a symbol with the same name in the wrong package is an error.
-
-@defvar[var {global-variable-names}]
-This variable holds a string-table of the names of all the global @hemlock
-variables.  The value of each entry is the symbol name of the variable.
-@enddefvar
-
-@defun[fun {current-variable-tables}]
-This function returns a list of variable tables currently established,
-globally, in the @f[current-buffer], and by the modes of the
-@f[current-buffer].  This list is suitable for use with
-@f[prompt-for-variable].
-@enddefun
-
-
-@section(Variable Functions)
-In the following descriptions @i[name] is the symbol name of the variable.
-
-@defun[fun {defhvar}, args {@i[string-name] @i[documentation]},
-	keys {[mode][buffer][hooks][value]}]
- This function defines a @hemlock variable.  Functions that take a variable
-name signal an error when the variable is undefined.
-@begin(description)
-@i[string-name]@\The string name of the variable to define.
-
-@i[documentation]@\The documentation string for the variable.
-
-@multiple{
-@kwd[mode],
-@kwd[buffer]}@\
- If @i[buffer] is supplied, the variable is local to that buffer.  If @i[mode]
-is supplied, it is local to that mode.  If neither is supplied, it is global.
-
-@kwd[value]@\
- This is the initial value for the variable, which defaults to @nil.
-
-@kwd[hooks]@\
- This is the initial list of functions to call when someone sets the variable's
-value.  These functions execute before @hemlock establishes the new value.  See
-@f[variable-value] for the arguments passed to the hook functions.
-@end(description)
-If a variable with the same name already exists in the same place, then
-@f[defhvar] sets its hooks and value from @i[hooks] and @i[value] if the user
-supplies these keywords.
-@enddefun
-
-@defun[fun {variable-value}, args {@i[name] @optional @i[kind] @i[where]}]
-This function returns the value of a @hemlock variable in some place.
-The following values for @i[kind] are defined:
-@begin[description]
-@kwd[current]@\
- Return the value present in the current environment, taking into consideration
-any mode or buffer local variables.  This is the default.
-
-@kwd[global]@\
- Return the global value.
-
-@kwd[mode]@\
- Return the value in the mode named @i[where].
-
-@kwd[buffer]@\
- Return the value in the buffer @i[where].
-@end[description]
-When set with @f[setf], @hemlock sets the value of the specified variable and
-invokes the functions in its hook list with @i[name], @i[kind], @i[where], and
-the new value.
-@enddefun
-
-@defun[fun {variable-documentation}, args
-	{@i[name] @optional @i[kind] @i[where]}] 
-@defun1[fun {variable-hooks}, args
-        {@i[name] @optional @i[kind] @i[where]}]
-@defun1[fun {variable-name}, args
-	{@i[name] @optional @i[kind] @i[where]}]
-These function return the documentation, hooks and string name of a
-@hemlock variable.  The @i[kind] and @i[where] arguments are the same
-as for @f[variable-value].  The documentation and hook list may be set
-using @f[setf].
-@enddefun
-
-@defun[fun {string-to-variable}, args {@i[string]}]
-This function converts a string into the corresponding variable symbol
-name.  @i[String] need not be the name of an actual @hemlock variable.
-@enddefun
-
-@defmac[fun {value}, args {@i[name]}] 
-@defmac1[fun {setv}, args {@i[name] @i[new-value]}]
-These macros get and set the current value of the @hemlock variable
-@i[name].  @i[Name] is not evaluated.  There is a @f[setf] form for
-@f[value].
-@enddefmac
-
-@Defmac[Fun {hlet}, Args {(@Mstar<(@i[var] @i[value])>) @Mstar<@i[form]>}]
-This macro is very similar to @f[let] in effect; within its scope each
-of the @hemlock variables @i[var] have the respective @i[value]s, but
-after the scope is exited by any means the binding is removed.  This
-does not cause any hooks to be invoked.  The value of the last
-@i[form] is returned.
-@enddefmac
-
-@defun[fun {hemlock-bound-p}, args {@i[name] @optional @i[kind] @i[where]}]
-Returns @true if @i[name] is defined as a @hemlock variable in the
-place specified by @i[kind] and @i[where], or @nil otherwise.
-@enddefun
-
-@defun[fun {delete-variable}, args {@i(name) @optional @i[kind] @i[where]}]
-@defhvar1[var {Delete Variable Hook}]
-@f[delete-variable] makes the @hemlock variable @i[name] no longer
-defined in the specified place.  @i[Kind] and @i[where] have the same
-meanings as they do for @f[variable-value], except that @kwd[current]
-is not available, and the default for @i[kind] is @kwd[global]
-
-An error will be signaled if no such variable exists.  The hook,
-@hid[Delete Variable Hook] is invoked with the same arguments before the
-variable is deleted.
-@enddefun
-
-
-@section(Hooks)
-@index(Hooks)
-@label[hooks]
-@hemlock actions such as setting variables, changing buffers, changing windows,
-turning modes on and off, etc., often have hooks associated with them.  A hook
-is a list of functions called before the system performs the action.  The
-manual describes the object specific hooks with the rest of the operations
-defined on these objects.
-
-Often hooks are stored in @hemlock variables, @hid[Delete Buffer Hook] and
-@hid[Set Window Hook] for example.  This leads to a minor point of confusion
-because these variables have hooks that the system executes when someone
-changes their values.  These hook functions @hemlock invokes when someone sets
-a variable are an example of a hook stored in an object instead of a @hemlock
-variable.  These are all hooks for editor activity, but @hemlock keeps them in
-different kinds of locations.  This is why some of the routines in this section
-have a special interpretation of the hook @i[place] argument.
-
-@defmac[fun {add-hook}, args {@i[place] @i[hook-fun]}]
-@defmac1[fun {remove-hook}, args {@i[place] @i[hook-fun]}]
-These macros add or remove a hook function in some @i[place].  If @i[hook-fun]
-already exists in @i[place], this call has no effect.  If @i[place] is a
-symbol, then it is a @hemlock variable; otherwise, it is a generalized variable
-or storage location.  Here are two examples:
-@Begin[ProgramExample]
-(add-hook delete-buffer-hook 'remove-buffer-from-menu)
-
-(add-hook (variable-hooks 'check-mail-interval)
-          'reschedule-mail-check)
-@End[ProgramExample]
-@enddefmac
-
-@defmac[fun {invoke-hook}, args {@i[place] @rest @i[args]}]
-This macro calls all the functions in @i[place].  If @i[place] is a symbol,
-then it is a @hemlock variable; otherwise, it is a generalized variable.
-@enddefun
-
-
-
-@chapter(Commands)
-@index (Commands)
-@label[commands]
-
-
-@section(Introduction)
-The way that the user tells @hemlock to do something is by invoking a
-@i(command).  Commands have three attributes:
-@begin(description)
-@i[name]@\A command's name provides a way to refer to it.  Command
-names are usually capitalized words separated by spaces, such as 
-@hid[Forward Word].
-
-@i[documentation]@\The documentation for a command is used by
-on-line help facilities.
-
-@i[function]@\A command is implemented by a Lisp function, which is callable
-from Lisp.
-@end(description)
-
-@defvar[var {command-names}]
-Holds a string-table (page @pageref[string-tables]) associating
-command names to command objects.  Whenever a new command is defined
-it is entered in this table.
-@enddefvar
-
-
-@subsection(Defining Commands)
-
-@defmac[fun {defcommand}, args 
-{@^@mgroup<@i[command-name] @MOR (@i[command-name] @i[function-name])> @i[lambda-list]
-@\@i[command-doc] @i[function-doc] @mstar<@i[form]>}]
-
-Defines a command named @i[name].  @f[defcommand] creates a function to
-implement the command from the @i[lambda-list] and @i[form]'s supplied.  The
-@i[lambda-list] must specify one required argument, see section
-@ref[invoking-commands-as-functions], which by convention is typically named
-@f[p].  If the caller does not specify @i[function-name], @f[defcommand]
-creates the command name by replacing all spaces with hyphens and appending
-"@f[-command]".  @i[Function-doc] becomes the documentation for the function
-and should primarily describe issues involved in calling the command as a
-function, such as what any additional arguments are.  @i[Command-doc] becomes
-the command documentation for the command.  @enddefmac
-
-@defun[fun {make-command}, args 
-	{@i[name] @i[documentation] @i[function]}] 
-Defines a new command named @i[name], with command documentation
-@I[documentation] and function @i[function].  The command in entered
-in the string-table @varref[command-names], with the command object as
-its value.  Normally command implementors will use the @f[defcommand]
-macro, but this permits access to the command definition mechanism at
-a lower level, which is occasionally useful.
-@enddefun
-
-@defun[fun {commandp}, args {@i[command]}]
-Returns @true if @i[command] is a @f[command] object, otherwise @nil.
-@enddefun
-
-@defun[fun {command-documentation}, args {@i[command]}]
-@defun1[fun {command-function}, args {@i[command]}]
-@defun1[fun {command-name}, args {@i[command]}]
-Returns the documentation, function, or name for @i[command].  These
-may be set with @f[setf].
-@enddefun
-
-
-@subsection(Command Documentation)
-@i[Command documentation] is a description of what the command does
-when it is invoked as an extended command or from a key.  Command
-documentation may be either a string or a function.  If the
-documentation is a string then the first line should briefly summarize
-the command, with remaining lines filling the details.  Example:
-@lisp
-(defcommand "Forward Character" (p)
-  "Move the point forward one character.
-   With prefix argument move that many characters, with negative
-   argument go backwards."
-  "Move the point of the current buffer forward p characters."
-   . . .)
-@endlisp
-
-Command documentation may also be a function of one argument.  The
-function is called with either @kwd[short] or @kwd[full], indicating
-that the function should return a short documentation string or do
-something to document the command fully.
-
-
-@section(The Command Interpreter)
-@index[Interpreter, command]
-@index[Invocation, command]
-@index[Command interpreter]
-
-The @i[command interpreter] is a function which reads key-events (see section
-@ref[key-events-intro]) from the keyboard and dispatches to different commands
-on the basis of what the user types.  When the command interpreter executes a
-command, we say it @i[invokes] the command.  The command interpreter also
-provides facilities for communication between commands contiguously running
-commands, such as a last command type register.  It also takes care of
-resetting communication mechanisms, clearing the echo area, displaying partial
-keys typed slowly by the user, etc.
-
-@defvar[var {invoke-hook}]
-This variable contains a function the command interpreter calls when it wants
-to invoke a command.  The function receives the command and the prefix argument
-as arguments.  The initial value is a function which simply funcalls the
-@f[command-function] of the command with the supplied prefix argument.  This is
-useful for implementing keyboard macros and similar things.
-@enddefhvar
-
-@defhvar[var "Command Abort Hook"]
-The command interpreter invokes the function in this variable whenever someone
-aborts a command (for example, if someone called @f[editor-error]).
-@enddefhvar
-
-When @hemlock initially starts the command interpreter is in control, but
-commands may read from the keyboard themselves and assign whatever
-interpretation they will to the key-events read.  Commands may call the command
-interpreter recursively using the function @funref[recursive-edit].
-
-
-@subsection(Editor Input)
-@label[key-events-intro]
-@index[key-events]
-
-The canonical representation of editor input is a key-event structure.  Users
-can bind commands to keys (see section @ref[key-bindings]), which are non-zero
-length sequences of key-events.  A key-event consists of an identifying token
-known as a @i[keysym] and a field of bits representing modifiers.  Users define
-keysyms, integers between 0 and 65535 inclusively, by supplying names that
-reflect the legends on their keyboard's keys.  Users define modifier names
-similarly, but the system chooses the bit and mask for recognizing the
-modifier.  You can use keysym and modifier names to textually specify
-key-events and Hemlock keys in a @f[#k] syntax.  The following are some
-examples:
-@begin[programexample]
-   #k"C-u"
-   #k"Control-u"
-   #k"c-m-z"
-   #k"control-x meta-d"
-   #k"a"
-   #k"A"
-   #k"Linefeed"
-@end[programexample]
-This is convenient for use within code and in init files containing
-@f[bind-key] calls.
-
-The @f[#k] syntax is delimited by double quotes, but the system parses the
-contents rather than reading it as a Common Lisp string.  Within the double
-quotes, spaces separate multiple key-events.  A single key-event optionally
-starts with modifier names terminated by hyphens.  Modifier names are
-alphabetic sequences of characters which the system uses case-insensitively.
-Following modifiers is a keysym name, which is case-insensitive if it consists
-of multiple characters, but if the name consists of only a single character,
-then it is case-sensitive.
-
-You can escape special characters @dash hyphen, double quote, open angle
-bracket, close angle bracket, and space @dash with a backslash, and you can
-specify a backslash by using two contiguously.  You can use angle brackets to
-enclose a keysym name with many special characters in it.  Between angle
-brackets appearing in a keysym name position, there are only two special
-characters, the closing angle bracket and backslash.
-
-For more information on key-events see section @ref[key-events].
-
-
-
-@subsection(Binding Commands to Keys)
-@label[Key-Bindings]
-@Index[Key Bindings]
-
-The command interpreter determines which command to invoke on the basis of
-@i[key bindings].  A key binding is an association between a command and a
-sequence of key-events (see section @ref[key-events-intro].  A sequence of
-key-events is called a @i[key] and is represented by a single key-event or a
-sequence (list or vector) of key-events.
-
-Since key bindings may be local to a mode or buffer, the current environment
-(page @pageref[current-environment]) determines the set of key bindings in
-effect at any given time.  When the command interpreter tries to find the
-binding for a key, it first checks if there is a local binding in the
-@w[@funref[current-buffer]], then if there is a binding in each of the minor
-modes and the major mode for the current buffer @w[(page @pageref[modes])], and
-finally checks to see if there is a global binding.  If no binding is found,
-then the command interpreter beeps or flashes the screen to indicate this.
-
-@defun[fun {bind-key}, args
-        {@i(name) @i(key) @optional @i[kind] @i[where]}]
- This function associates command @i[name] and @i[key] in some environment.
-@i[Key] is either a key-event or a sequence of key-events.  There are three
-possible values of @i[kind]:
-@begin(description)
-@kwd[global]@\
- The default, make a global key binding.
-
-@kwd[mode]@\
- Make a mode specific key binding in the mode whose name is @i[where].
-
-@kwd[buffer]@\
- Make a binding which is local to buffer @i[where].
-@end(description)
-
-This processes @i[key] for key translations before establishing the binding.
-See section @ref[key-trans].
-
-If the key is some prefix of a key binding which already exists in the
-specified place, then the new one will override the old one, effectively
-deleting it.
-
-@f[ext:do-alpha-key-events] is useful for setting up bindings in certain new
-modes.
-@enddefun
-
-@defun[fun {command-bindings}, args {@i[command]}]
-This function returns a list of the places where @i[command] is bound.  A place
-is specified as a list of the key (always a vector), the kind of binding, and
-where (either the mode or buffer to which the binding is local, or @nil if it
-is a global).
-@enddefun
-
-@defun[fun {delete-key-binding}, args {@i[key] @optional @i[kind] @i[where]}]
-This function removes the binding of @i[key] in some place.  @i[Key] is either
-a key-event or a sequence of key-events.  @i[kind] is the kind of binding to
-delete, one of @kwd[global] (the default), @kwd[mode] or @kwd[buffer].  If
-@i[kind] is @kwd[mode], @i[where] is the mode name, and if @i[kind] is
-@kwd[buffer], then @i[where] is the buffer.
-
-This function signals an error if @i[key] is unbound.
-
-This processes @i[key] for key translations before deleting the binding.  See
-section @ref[key-trans].
-@enddefun
-
-@defun[fun {get-command}, args {@i[key] @optional @i[kind] @i[where]}]
-This function returns the command bound to @i[key], returning @nil if it is
-unbound.  @i[Key] is either a key-event or a sequence of key-events.  If
-@i[key] is an initial subsequence of some keys, then this returns the keyword
-@kwd[prefix].  There are four cases of @i[kind]:
-@begin(description)
-@kwd[current]@\
- Return the current binding of @i[key] using the current buffer's search list.
-If there are any transparent key bindings for @i[key], then they are returned
-in a list as a second value.
-
-@kwd[global]@\
- Return the global binding of @i[key].  This is the default.
-
-@kwd[mode]@\
- Return the binding of @i[key] in the mode named @i[where].
-
-@kwd[buffer]@\
- Return the binding of @i[key] local to the buffer @i[where].
-@end(description)
-
-This processes @i[key] for key translations before looking for any binding.
-See section @ref[key-trans].
-@enddefun
-
-@defun[fun {map-bindings}, Args {@i[function] @i[kind] @optional @i[where]}]
-This function maps over the key bindings in some place.  For each binding, this
-passes @i[function] the key and the command bound to it.  @i[Kind] and
-@i[where] are the same as in @f[bind-key].  The key is not guaranteed to remain
-valid after a given iteration.
-@enddefmac
-
-
-@subsection[Key Translation]
-@index[bit-prefix keys]
-@index[key translation]
-@index[translating keys]
-@label[key-trans]
-Key translation is a process that the command interpreter applies to keys
-before doing anything else.  There are two kinds of key translations:
-substitution and bit-prefix.  In either case, the command interpreter
-translates a key when a specified key-event sequence appears in a key.
-
-In a substitution translation, the system replaces the matched subsequence with
-another key-event sequence.  Key translation is not recursively applied to the
-substituted key-events.
-
-In a bit-prefix translation, the system removes the matched subsequence and
-effectively sets the specified bits in the next key-event in the key.
-
-While translating a key, if the system encounters an incomplete final
-subsequence of key-events, it aborts the translation process.  This happens
-when those last key-events form a prefix of some translation.  It also happens
-when they translate to a bit-prefix, but there is no following key-event to
-which the system can apply the indicated modifier.  If there is a binding for
-this partially untranslated key, then the command interpreter will invoke that
-command; otherwise, it will wait for the user to type more key-events.
-
-@defun[fun {key-translation}, args {@i[key]}]
-This form is @f[setf]'able and allows users to register key translations that
-the command interpreter will use as users type key-events.
-
-This function returns the key translation for @i[key], returning @nil if there
-is none.  @i[Key] is either a key-event or a sequence of key-events.  If
-@i[key] is a prefix of a translation, then this returns @kwd[prefix].
-
-A key translation is either a key or modifier specification.  The bits
-translations have a list form: @w<@f[(:bits {]@i[bit-name]@f[}*)]>.
-
-Whenever @i[key] appears as a subsequence of a key argument to the binding
-manipulation functions, that portion will be replaced with the translation.
-@enddefun
-
-
-
-@subsection[Transparent Key Bindings]
-@label[transparent-key-bindings]
-@index[Transparent key bindings]
-
-Key bindings local to a mode may be @i[transparent].  A transparent key
-binding does not shadow less local key bindings, but rather indicates that
-the bound command should be invoked before the first normal key binding.
-Transparent key bindings are primarily useful for implementing minor modes
-such as auto fill and word abbreviation.  There may be several transparent
-key bindings for a given key, in which case all of the commands bound are
-invoked in the order they were found.  If there no normal key binding for a
-key typed, then the command interpreter acts as though the key is unbound
-even if there are transparent key bindings.
-
-The @kwd[transparent-p] argument to @funref[defmode] determines whether the
-key bindings in a mode are transparent or not.
-
-
-@subsection (Interactive)
-@index (Keyboard macro vs. interactive)
-@index (Interactive vs. keyboard macro)
-@Hemlock supports keyboard macros.  A user may enter a mode where the editor
-records his actions, and when the user exits this mode, the command @hid[Last
-Keyboard Macro] plays back the actions.  Some commands behave differently when
-invoked as part of the definition of a keyboard macro.  For example, when used
-in a keyboard macro, a command that @f[message]'s useless user confirmation
-will slow down the repeated invocations of @hid[Last Keyboard Macro] because
-the command will pause on each execution to make sure the user sees the
-message.  This can be eliminated with the use of @f[interactive].  As another
-example, some commands conditionally signal an editor-error versus simply
-beeping the device depending on whether it executes on behalf of the user or a
-keyboard macro.
-
-@defun[fun {interactive}]
-This returns @true when the user invoked the command directly.
-@enddefun
-
-
-@section(Command Types)
-@index(Command types)
-@label(command-types)
-In many editors the behavior of a command depends on the kind of command
-invoked before it.  @hemlock provides a mechanism to support this known as
-@i(command type).
-
-@defun[fun {last-command-type}]
-This returns the command type of the last command invoked.  If this is set with
-@f[setf], the supplied value becomes the value of @f[last-command-type] until
-the next command completes.  If the previous command did not set
-@f[last-command-type], then its value is @nil.  Normally a command type is a
-keyword.  The command type is not cleared after a command is invoked due to a
-transparent key binding.
-@enddefun
-
-
-@section(Command Arguments)
-@label[invoking-commands-as-functions]
-There are three ways in which a command may be invoked: It may be bound to a
-key which has been typed, it may be invoked as an extended command, or it may
-be called as a Lisp function.  Ideally commands should be written in such a way
-that they will behave sensibly no matter which way they are invoked.  The
-functions which implement commands must obey certain conventions about argument
-passing if the command is to function properly.
-
-
-@subsection(The Prefix Argument)
-@index(Prefix arguments)
-Whenever a command is invoked it is passed as its first argument what
-is known as the @i[prefix argument].  The prefix argument is always
-either an integer or @nil.  When a command uses this value it is
-usually as a repeat count, or some conceptually similar function.
-
-@defun[fun {prefix-argument}]
-This function returns the current value of the prefix argument.  When
-set with @f[setf], the new value becomes the prefix argument for the
-next command.
-@enddefun
-
-If the prefix argument is not set by the previous command then the
-prefix argument for a command is @nil.  The prefix argument is not cleared
-after a command is invoked due to a transparent key binding.
-
-
-@subsection(Lisp Arguments)
-It is often desirable to call commands from Lisp code, in which case
-arguments which would otherwise be prompted for are passed as optional
-arguments following the prefix argument.  A command should prompt for
-any arguments not supplied.
-
-
-@section(Recursive Edits)
-@index(Recursive edits)
-@defmac[fun {use-buffer}, args {@i[buffer] @mstar<@i[form]>}]
-The effect of this is similar to setting the current-buffer to @i[buffer]
-during the evaluation of @i[forms].  There are restrictions placed on what the
-code can expect about its environment.  In particular, the value of any global
-binding of a @hemlock variable which is also a mode local variable of some mode
-is ill-defined; if the variable has a global binding it will be bound, but the
-value may not be the global value.  It is also impossible to nest
-@f[use-buffer]'s in different buffers.  The reason for using @f[use-buffer] is
-that it may be significantly faster than changing @f[current-buffer] to
-@i[buffer] and back.
-@enddefmac
-
-@defun[fun {recursive-edit}, args {@optional @i[handle-abort]}]
-@defhvar1[var {Enter Recursive Edit Hook}]
-@index[aborting]
-@f[recursive-edit] invokes the command interpreter.  The command interpreter
-will read from the keyboard and invoke commands until it is terminated with
-either @f[exit-recursive-edit] or @f[abort-recursive-edit].
-
-Normally, an editor-error or @bf[C-g] aborts the command in progress and
-returns control to the top-level command loop.  If @f[recursive-edit] is used
-with @i[handle-abort] true, then @f[editor-error] or @bf[C-g] will only abort
-back to the recursive command loop.
-
-Before the command interpreter is entered the hook
-@hid[Enter Recursive Edit Hook] is invoked.
-@enddefun
-
-@defun[fun {in-recursive-edit}]
-This returns whether the calling point is dynamically within a recursive edit
-context.
-@enddefun
-
-@defun[fun {exit-recursive-edit}, args {@optional @i[values-list]}]
-@defhvar1[var {Exit Recursive Edit Hook}]
-@f[exit-recursive-edit] exits a recursive edit returning as multiple values
-each element of @i[values-list], which defaults to @nil.  This invokes
-@hid[Exit Recursive Edit Hook] after exiting the command interpreter.  If no
-recursive edit is in progress, then this signals an error.
-@enddefun
-
-@defun[fun {abort-recursive-edit}, args {@rest @i[args]}]
-@defhvar1[var {Abort Recursive Edit Hook}]
-@f[abort-recursive-edit] terminates a recursive edit by applying
-@funref[editor-error] to @i[args] after exiting the command interpreter.  This
-invokes @hid[Abort Recursive Edit Hook] with @i[args] before aborting the
-recursive edit .  If no recursive edit is in progress, then this signals an
-error.
-@enddefun
-
-
-
-@Chapter(Modes)
-@label[modes]
-@index (Modes)
-A mode is a collection of @hemlock values which may be present in the current
-environment @w<(page @pageref(current-environment))> depending on the editing
-task at hand.  Examples of typical modes are @hid[Lisp], for editing Lisp code,
-and @hid[Echo Area], for prompting in the echo area.
-
-
-@section(Mode Hooks)
-  When a mode is added to or removed from a buffer, its @i[mode hook]
-is invoked.  The hook functions take two arguments, the buffer
-involved and @true if the mode is being added or @nil if it is being
-removed. 
-
-Mode hooks are typically used to make a mode do something additional to
-what it usually does.  One might, for example, make a text mode hook
-that turned on auto-fill mode when you entered.
-
-
-@section(Major and Minor Modes)
-There are two kinds of modes, @i[major] modes and @i[minor] modes.  A buffer
-always has exactly one major mode, but it may have any number of minor modes.
-Major modes may have mode character attributes while minor modes may not.
-
-A major mode is usually used to change the environment in some major way, such
-as to install special commands for editing some language.  Minor modes
-generally change some small attribute of the environment, such as whether lines
-are automatically broken when they get too long.  A minor mode should work
-regardless of what major mode and minor modes are in effect.
-
-@defhvar[var {Default Modes}, val {("Fundamental" "Save")}]
-This variable contains a list of mode names which are instantiated in a
-buffer when no other information is available.
-@enddefhvar
-
-@defvar[var {mode-names}]
-Holds a string-table of the names of all the modes.
-@enddefvar
-
-@defcom[com "Illegal"]
-This is a useful command to bind in modes that wish to shadow global bindings
-by making them effectively illegal.  Also, although less likely, minor modes
-may shadow major mode bindings with this.  This command calls @f[editor-error].
-@enddefcom
-
-
-@section(Mode Functions)
-
-@defun[fun {defmode}, args {@i[name]},
-        keys {[setup-function][cleanup-function][major-p]},
-        morekeys {[precedence][transparent-p][documentation]}]
-This function defines a new mode named @i[name], and enters it in
-@varref[mode-names].  If @i[major-p] is supplied and is not @nil
-then the mode is a major mode; otherwise it is a minor mode.
-
-@i[Setup-function] and @i[cleanup-function] are functions which are
-invoked with the buffer affected, after the mode is turned on, and
-before it is turned off, respectively.  These functions typically are
-used to make buffer-local key or variable bindings and to remove them
-when the mode is turned off.
-
-@i[Precedence] is only meaningful for a minor mode.  The precedence of a
-minor mode determines the order in which it in a buffer's list of modes.
-When searching for values in the current environment, minor modes are
-searched in order, so the precedence of a minor mode determines which value
-is found when there are several definitions.
-
-@i[Transparent-p] determines whether key bindings local to the defined mode
-are transparent.  Transparent key bindings are invoked in addition to the
-first normal key binding found rather than shadowing less local key bindings.
-
-@i[Documentation] is some introductory text about the mode.  Commands such as
-@hid[Describe Mode] use this.
-@enddefun
-
-@defun[fun {mode-documentation}, args {@i[name]}]
-This function returns the documentation for the mode named @i[name].
-@enddefun
-
-@defun[fun {buffer-major-mode}, args {@i[buffer]}]
-@defhvar1[var {Buffer Major Mode Hook}]
-@f[buffer-major-mode] returns the name of @i[buffer]'s major mode.
-The major mode may be changed with @f[setf]; then
- @hid[Buffer Major Mode Hook] is invoked with
-@i[buffer] and the new mode.
-@enddefun
-
-@defun[fun {buffer-minor-mode}, args {@i[buffer] @i[name]}]
-@defhvar1[var {Buffer Minor Mode Hook}]
-@f[buffer-minor-mode] returns @true if the minor mode @i[name] is active
-in @i[buffer], @nil otherwise.  A minor mode may be turned on or off
-by using @f[setf]; then @hid[Buffer Minor Mode Hook] is
-invoked with @i[buffer], @i[name] and the new value.
-@enddefun
-
-@defun[fun {mode-variables}, args {@i[name]}]
-Returns the string-table of mode local variables.
-@enddefun
-
-@defun[fun {mode-major-p}, args {@i[name]}]
-Returns @true if @i[name] is the name of a major mode, or @nil if
-it is the name of a minor mode.  It is an error for @i[name] not to be
-the name of a mode.
-@enddefun
-
-
-
-@chapter(Character Attributes)
-@label(character-attributes)
-@index(Character attributes)
-@index(Syntax tables)
-
-@section(Introduction)
-Character attributes provide a global database of information about characters.
-This facility is similar to, but more general than, the @i[syntax tables] of
-other editors such as @f[EMACS].  For example, you should use character
-attributes for commands that need information regarding whether a character is
-@i[whitespace] or not.  Use character attributes for these reasons:
-@begin(enumerate)
-If this information is all in one place, then it is easy the change the
-behavior of the editor by changing the syntax table, much easier than it would
-be if character constants were wired into commands.
-
-This centralization of information avoids needless duplication of effort.
-
-The syntax table primitives are probably faster than anything that can be
-written above the primitive level.
-@end(enumerate)
-
-Note that an essential part of the character attribute scheme is that
-@i[character attributes are global and are there for the user to change.]
-Information about characters which is internal to some set of commands (and
-which the user should not know about) should not be maintained as a character
-attribute.  For such uses various character searching abilities are provided by
-the function @funref[find-pattern].
-
-@defcon[var {syntax-char-code-limit}]
-The exclusive upper bound on character codes which are significant in
-the character attribute functions.  Font and bits are always ignored.
-@enddefcon
-
-
-@section(Character Attribute Names)
-
-As for @hemlock variables, character attributes have a user visible
-string name, but are referred to in Lisp code as a symbol.  The string
-name, which is typically composed of capitalized words separated by
-spaces, is translated into a keyword by replacing all spaces with
-hyphens and interning this string in the keyword package.  The
-attribute named @hid[Ada Syntax] would thus become @kwd[ada-syntax].
-
-@defvar[var {character-attribute-names}]
-Whenever a character attribute is defined, its name is entered in
-this string table (page @pageref[string-tables]), with the
-corresponding keyword as the value.
-@enddefvar
-
-
-@section(Character Attribute Functions)
-
-@defun[fun {defattribute}, args 
-	{@i[name] @i[documentation] @optional @i[type] @i[initial-value]}]
- This function defines a new character attribute with @i[name], a
-simple-string.  Character attribute operations take attribute arguments as a
-keyword whose name is @i[name] uppercased with spaces replaced by hyphens.
-
-@i[Documentation] describes the uses of the character attribute.
-
-@i[Type], which defaults to @w<@f[(mod 2)]>, specifies what type the values of
-the character attribute are.  Values of a character attribute may be of any
-type which may be specified to @f[make-array].  @i[Initial-value] (default
-@f[0]) is the value which all characters will initially have for this
-attribute.
-@enddefun
-
-@defun[fun {character-attribute-name}, args {@i[attribute]}]
-@defun1[fun {character-attribute-documentation}, args {@i[attribute]}]
-These functions return the name or documentation for @i[attribute].
-@enddefun
-
-@defun[fun {character-attribute}, args	{@i[attribute] @i[character]}]
-@defhvar1[var {Character Attribute Hook}]
-@f[character-attribute] returns the value of @i[attribute] for @i[character].
-This signals an error if @i[attribute] is undefined.
-
-@f[setf] will set a character's attributes.  This @f[setf] method invokes the
-functions in @hid[Character Attribute Hook] on the attribute and character
-before it makes the change.
-
-If @i[character] is @nil, then the value of the attribute for the beginning or
-end of the buffer can be accessed or set.  The buffer beginning and end thus
-become a sort of fictitious character, which simplifies the use of character
-attributes in many cases.
-@enddefun
-
-@defun[fun {character-attribute-p}, args {@i[symbol]}]
-This function returns @true if @i[symbol] is the name of a character attribute,
-@nil otherwise.
-@enddefun
-
-@defun[fun {shadow-attribute}, args 
-{@i[attribute] @i[character] @i[value] @i[mode]}]
-@defhvar1[var {Shadow Attribute Hook}]
-This function establishes @i[value] as the value of @i[character]'s
-@i[attribute] attribute when in the mode @i[mode].  @i[Mode] must be the name
-of a major mode.  @hid[Shadow Attribute Hook] is invoked with the same
-arguments when this function is called.  If the value for an attribute is set
-while the value is shadowed, then only the shadowed value is affected, not the
-global one.
-@enddefun
-
-@defun[fun {unshadow-attribute}, args {@i[attribute] @i[character] @i[mode]}]
-@defhvar1[var {Unshadow Attribute Hook}]
-Make the value of @i[attribute] for @i[character] no longer be shadowed in
-@i[mode].  @hid[Unshadow Attribute Hook] is invoked with the same arguments
-when this function is called.
-@enddefun
-
-@defun[fun {find-attribute},
-	args {@i[mark] @i[attribute] @optional @i[test]}]
-@defun1[fun {reverse-find-attribute},
-	args {@i[mark] @i[attribute] @optional @i[test]}]
- These functions find the next (or previous) character with some value for the
-character attribute @i[attribute] starting at @i[mark].  They pass @i[Test] one
-argument, the value of @i[attribute] for the character tested.  If the test
-succeeds, then these routines modify @i[mark] to point before (after for
-@f[reverse-find-attribute]) the character which satisfied the test.  If no
-characters satisfy the test, then these return @nil, and @i[mark] remains
-unmodified.  @i[Test] defaults to @f[not zerop].  There is no guarantee that
-the test is applied in any particular fashion, so it should have no side
-effects and depend only on its argument.
-@enddefun
-
-
-@section(Character Attribute Hooks)
-
-It is often useful to use the character attribute mechanism as an abstract
-interface to other information about characters which in fact is stored
-elsewhere.  For example, some implementation of @hemlock might decide to define
-a @hid[Print Representation] attribute which controls how a character is
-displayed on the screen.
-
-To make this easy to do, each attribute has a list of hook functions
-which are invoked with the attribute, character and new value whenever
-the current value changes for any reason.
-
-@defun[fun {character-attribute-hooks}, args {@i[attribute]}]
-Return the current hook list for @i[attribute].  This may be set with
-@f[setf].  The @f[add-hook] and @macref[remove-hook] macros should
-be used to manipulate these lists.
-@enddefun
-
-
-@section (System Defined Character Attributes)
-@label(sys-def-chars)
-These are predefined in @hemlock:
-@begin[description]
-@hid[Whitespace]@\
-A value of @f[1] indicates the character is whitespace.
-
-@hid[Word Delimiter]@\
-A value of @f[1] indicates the character separates words (see section
-@ref[text-functions]).
-
-@hid[Digit]@\
-A value of @f[1] indicates the character is a base ten digit.  This may be
-shadowed in modes or buffers to mean something else.
-
-@hid[Space]@\
-This is like @hid[Whitespace], but it should not include @binding[Newline].
-@hemlock uses this primarily for handling indentation on a line.
-
-@hid[Sentence Terminator]@\
-A value of @f[1] indicates these characters terminate sentences (see section
-@ref[text-functions]).
-
-@hid[Sentence Closing Char]@\
-A value of @f[1] indicates these delimiting characters, such as @binding["]
-or @binding[)], may follow a @hid[Sentence Terminator] (see section
-@ref[text-functions]).
-
-@hid[Paragraph Delimiter]@\
-A value of @f[1] indicates these characters delimit paragraphs when they begin
-a line (see section @ref[text-functions]).
-
-@hid[Page Delimiter]@\
-A value of @f[1] indicates this character separates logical pages (see section
-@ref[logical-pages]) when it begins a line.
-
-@hid[Scribe Syntax]@\
-This uses the following symbol values:
-@begin[multiple]
-@begin[description]
-@nil@\These characters have no interesting properties.
-
-@kwd[escape]@\This is @binding[@@] for the Scribe formatting language.
-
-@kwd[open-paren]@\These characters begin delimited text.
-
-@kwd[close-paren]@\These characters end delimited text.
-
-@kwd[space]@\These characters can terminate the name of a formatting command.
-
-@kwd[newline]@\These characters can terminate the name of a formatting command.
-@end[description]
-@end[multiple]
-
-
-@hid[Lisp Syntax]@\
-This uses symbol values from the following:
-@begin[multiple]
-@begin[description]
-@nil@\These characters have no interesting properties.
-
-@kwd[space]@\These characters act like whitespace and should not include
-@binding[Newline].
-
-@kwd[newline]@\This is the @binding[Newline] character.
-
-@kwd[open-paren]@\This is @binding[(] character.
-
-@kwd[close-paren]@\This is @binding[)] character.
-
-@kwd[prefix]@\This is a character that is a part of any form it precedes @dash
-for example, the single quote, @binding['].
-
-@kwd[string-quote]@\This is the character that quotes a string literal,
-@binding["].@comment["]
-
-@kwd[char-quote]@\This is the character that escapes a single character,
-@binding[\].
-
-@kwd[comment]@\This is the character that makes a comment with the rest of the
-line, @binding[;].
-
-@kwd[constituent]@\These characters are constitute symbol names.
-@end[description]
-@end[multiple]
-
-@end[description]
-
-
-
-@chapter (Controlling the Display)
-@section (Windows)
-@tag[windows]
-@index(Windows)
-@index(modelines)
-
-A window is a mechanism for displaying part of a buffer on some physical
-device.  A window is a way to view a buffer but is not synonymous with one; a
-buffer may be viewed in any number of windows.  A window may have a
-@i[modeline] which is a line of text displayed across the bottom of a window to
-indicate status information, typically related to the buffer displayed.
-
-
-@section (The Current Window)
-@index (Current window)
-@defun[fun {current-window}, args {}]
-@defhvar1[var {Set Window Hook}]
-@f[current-window] returns the window in which the cursor is currently
-displayed.  The cursor always tracks the buffer-point of the corresponding
-buffer.  If the point is moved to a position which would be off the screen the
-recentering process is invoked.  Recentering shifts the starting point of the
-window so that the point is once again displayed.  The current window may be
-changed with @f[setf].  Before the current window is changed, the hook @hid[Set
-Window Hook] is invoked with the new value.
-@enddefun
-
-@defvar[var {window-list}]
-Holds a list of all the window objects made with @funref[make-window].
-@enddefvar
-
-
-@section(Window Functions)
-
-@defun[fun {make-window}, args {@i[mark]},
-	keys {[modelinep][window][ask-user]},
-	morekeys {[x][y][width][height]},
-	morekeys {[proportion]}]
-@defhvar1[var {Default Window Width}]
-@defhvar1[var {Default Window Height}]
-@defhvar1[var {Make Window Hook}]
-
-@comment[NOTE, we purposefully do not document the font-family or device
-	 arguments since we don't officially support fonts or devices.]
-
-@f[make-window] returns a window displaying text starting at @i[mark], which
-must point into a buffer.  If it could not make a window on the device, it
-returns nil.  The default action is to make the new window a proportion of the
-@f[current-window]'s height to make room for the new window.
-
-@i[Modelinep] specifies whether the window should display buffer modelines.
-
-@i[Window] is a device dependent window to be used with the Hemlock window.
-The device may not support this argument.  @i[Window] becomes the parent window
-for a new group of windows that behave in a stack orientation as windows do on
-the terminal.
-
-If @i[ask-user] is non-@nil, @hemlock prompts the user for the missing
-dimensions (@i[x], @i[y], @i[width], and @i[height]) to make a new group of
-windows, as with the @i[window] argument.  The device may not support this
-argument.  Non-null values other than @f[t] may have device dependent meanings.
-@i[X] and @i[y] are in pixel units, but @i[width] and @i[height] are characters
-units.  @hid[Default Window Width] and @hid[Default Window Height] are the
-default values for the @i[width] and @i[height] arguments.
-
-@i[Proportion] determines what proportion of the @f[current-window]'s height
-the new window will use.  The @f[current-window] retains whatever space left
-after accommodating the new one.  The default is to split the window in half.
-
-This invokes @hid[Make Window Hook] with the new window.
-@enddefun
-
-@defun[fun {windowp}, args {@i[window]}]
-This function returns @true if @i[window] is a @f[window] object, otherwise
-@nil.
-@enddefun
-
-@defun[fun {delete-window}, args {@i[window]}]
-@defhvar1[var {Delete Window Hook}]
-@f[delete-window] makes @i[window] go away, first invoking @hid[Delete Window
-Hook] with @i[window].
-@enddefun
-
-@defun[fun {window-buffer}, args {@i[window]}]
-@defhvar1[var {Window Buffer Hook}]
-@f[window-buffer] returns the buffer from which the window displays
-text.  This may be changed with @f[setf], in which case the hook
-@hid[Window Buffer Hook] is invoked beforehand with the window and the
-new buffer.
-@enddefun
-
-@defun[fun {window-display-start}, args {@i[window]}]
-@defun1[fun {window-display-end}, args {@i[window]}] 
-@f[window-display-start] returns the mark that points before the first
-character displayed in @i[window].  Note that if @i[window] is the current
-window, then moving the start may not prove much, since recentering may move it
-back to approximately where it was originally.
-
-@f[window-display-end] is similar, but points after the last character
-displayed.  Moving the end is meaningless, since redisplay always moves it to
-after the last character.
-@enddefun
-
-@defun[fun {window-display-recentering}, args {@i[window]}]
-This function returns whether redisplay will ensure the buffer's point of
-@i[window]'s buffer is visible after redisplay.  This is @f[setf]'able, and
-changing @i[window]'s buffer sets this to @nil via @hid[Window Buffer Hook].
-@enddefun
-
-@defun[fun {window-point}, args {@i[window]}]
-This function returns as a mark the position in the buffer where the cursor is
-displayed.  This may be set with @f[setf].  If @i[window] is the current
-window, then setting the point will have little effect; it is forced to track
-the buffer point.  When the window is not current, the window point is the
-position that the buffer point will be moved to when the window becomes
-current.
-@enddefun
-
-@defun[fun {center-window}, args {@i[window] @i[mark]}]
-This function attempts to adjust window's display start so the that @i[mark] is
-vertically centered within the window.
-@enddefun
-
-@defun[fun {scroll-window}, args {@i[window] @i[n]}]
-This function scrolls the window down @i[n] display lines; if @i[n] is negative
-scroll up.  Leave the cursor at the same text position unless we scroll it off
-the screen, in which case the cursor is moved to the end of the window closest
-to its old position.
-@enddefun
-
-@defun[fun {displayed-p}, args {@i[mark] @i[window]}]
-Returns @true if either the character before or the character after @i[mark]
-is being displayed in @i[window], or @nil otherwise.  
-@enddefun
-
-@defun[fun {window-height}, args {@i[window]}]
-@defun1[fun {window-width}, args {@i[window]}]
-Height or width of the area of the window used for displaying the
-buffer, in character positions.  These values may be changed with
-@f[setf], but the setting attempt may fail, in which case nothing is done.
-@enddefun
-
-@defun[fun {next-window}, args {@i[window]}]
-@defun1[fun {previous-window}, args {@i[window]}]
-Return the next or previous window of @i[window].  The exact meaning of next
-and previous depends on the device displaying the window.  It should be
-possible to cycle through all the windows displayed on a device using either
-next or previous (implying that these functions wrap around.)
-@enddefun
-
-
-@section(Cursor Positions)
-@index(Cursor positions)
-A cursor position is an absolute position within a window's coordinate
-system.  The origin is in the upper-left-hand corner and the unit
-is character positions.
-
-@defun[fun {mark-to-cursorpos}, args {@i[mark] @i[window]}]
-Returns as multiple values the @f[X] and @f[Y] position on which
-@i[mark] is being displayed in @i[window], or @nil if it is not within the
-bounds displayed.
-@enddefun
-
-@defun[fun {cursorpos-to-mark}, args {@i[X] @i[Y] @i[window]}]
-Returns as a mark the text position which corresponds to the given
-(@i[X], @i[Y]) position within window, or @nil if that
-position does not correspond to any text within @i[window].
-@enddefun
-
-@defun[fun {last-key-event-cursorpos}]
-Interprets mouse input.  It returns as multiple values the (@i[X], @i[Y])
-position and the window where the pointing device was the last time some key
-event happened.  If the information is unavailable, this returns @nil.
-@enddefun
-
-@defun[fun {mark-column}, args {@i[mark]}]
-This function returns the @i[X] position at which @i[mark] would be displayed,
-supposing its line was displayed on an infinitely wide screen.  This takes into
-consideration strange characters such as tabs.
-@enddefun
-
-@defun[fun {move-to-column}, args {@i[mark] @i[column] @optional @i[line]}]
-This function is analogous to @funref[move-to-position], except that
-it moves @i[mark] to the position on @i[line] which corresponds to the
-specified @i[column].  @i[Line] defaults to the line that @i[mark] is
-currently on.  If the line would not reach to the specified column,
-then @nil is returned and @i[mark] is not modified.  Note that since a
-character may be displayed on more than one column on the screen,
-several different values of @i[column] may cause @i[mark] to be moved
-to the same position.
-@enddefun
-
-@defun[fun {show-mark}, args {@i[mark] @i[window] @i[time]}]
-This function highlights the position of @i[mark] within @i[window] for
-@i[time] seconds, possibly by moving the cursor there.  The wait may be aborted
-if there is pending input.  If @i[mark] is positioned outside the text
-displayed by @i[window], then this returns @nil, otherwise @true.
-@enddefun
-
-
-@section(Redisplay)
-Redisplay translates changes in the internal representation of text into
-changes on the screen.  Ideally this process finds the minimal transformation
-to make the screen correspond to the text in order to maximize the speed of
-redisplay.
-
-@defun[fun {redisplay}]
-@defhvar1[var "Redisplay Hook"]
-@f[redisplay] executes the redisplay process, and @hemlock typically invokes
-this whenever it looks for input.  The redisplay process frequently checks for
-input, and if it detects any, it aborts.  The return value is interpreted as
-follows:
-@begin[description]
-@false@\No update was needed.
-
-@true@\Update was needed, and completed successfully.
-
-@kwd[editor-input]@\Update is needed, but was aborted due to pending input.
-@end[description]
-
-This function invokes the functions in @hid[Redisplay Hook] on the current
-window after computing screen transformations but before executing them.  After
-invoking the hook, this recomputes the redisplay and then executes it on the
-current window.
-
-For the current window and any window with @f[window-display-recentering] set,
-@f[redisplay] ensures the buffer's point for the window's buffer is visible
-after redisplay.
-@enddefun
-
-@defun[fun {redisplay-all}]
-This causes all editor windows to be completely redisplayed.  For the current
-window and any window with @f[window-display-recentering] set, this ensures the
-buffer's point for the window's buffer is visible after redisplay.  The return
-values are the same as for redisplay, except that @false is never returned.
-@enddefun
-
-@defun[fun {editor-finish-output}, args {@i[window]}]
-This makes sure the editor is synchronized with respect to redisplay output to
-@i[window].  This may do nothing on some devices.
-@enddefun
-
-
-
-@chapter(Logical Key-Events)
-@label[logical-key-events]
-@index[Logical key-events]
-
-
-@section[Introduction]
-Some primitives such as @funref[prompt-for-key] and commands such as EMACS
-query replace read key-events directly from the keyboard instead of using the
-command interpreter.  To encourage consistency between these commands and to
-make them portable and easy to customize, there is a mechanism for defining
-@i[logical key-events].
-
-A logical key-event is a keyword which stands for some set of key-events.  The
-system globally interprets these key-events as indicators a particular action.
-For example, the @kwd[help] logical key-event represents the set of key-events
-that request help in a given @hemlock implementation.  This mapping is a
-many-to-many mapping, not one-to-one, so a given logical key-event may have
-multiple corresponding actual key-events.  Also, any key-event may represent
-different logical key-events.
-
-
-@section[Logical Key-Event Functions]
-
-@defvar[var {logical-key-event-names}]
-This variable holds a string-table mapping all logical key-event names to the
-keyword identifying the logical key-event.
-@enddefvar
-
-@defun[fun {define-logical-key-event}, args {@i[string-name] @i[documentation]}]
- This function defines a new logical key-event with name @i[string-name], a
-simple-string.  Logical key-event operations take logical key-events arguments
-as a keyword whose name is @i[string-name] uppercased with spaces replaced by
-hyphens.
-
-@i[Documentation] describes the action indicated by the logical key-event.
-@enddefun
-
-@defun[fun {logical-key-event-key-events}, args {@i[keyword]}]
-This function returns the list of key-events representing the logical key-event
-@i[keyword].
-@enddefun
-
-@defun[fun {logical-key-event-name}, args {@i[keyword]}]
-@defun1[fun {logical-key-event-documentation}, args {@i[keyword]}]
-These functions return the string name and documentation given to
-@f[define-logical-key-event] for logical key-event @i[keyword].
-@enddefun
-
-@defun[fun {logical-key-event-p}, args {@i[key-event] @i[keyword]}]
-This function returns @f[t] if @i[key-event] is the logical key-event
-@i[keyword].  This is @f[setf]'able establishing or disestablishing key-events
-as particular logical key-events.  It is a error for @i[keyword] to be an
-undefined logical key-event.
-@enddefun
-
-
-@section[System Defined Logical Key-Events]
-There are many default logical key-events, some of which are used by functions
-documented in this manual.  If a command wants to read a single key-event
-command that fits one of these descriptions then the key-event read should be
-compared to the corresponding logical key-event instead of explicitly
-mentioning the particular key-event in the code.  In many cases you can use the
-@macref[command-case] macro.  It makes logical key-events easy to use and takes
-care of prompting and displaying help messages.
-
-@begin[description]
-@kwd[yes]@\
- Indicates the prompter should take the action under consideration.
-
-@kwd[no]@\
- Indicates the prompter should NOT take the action under consideration.
-
-@kwd[do-all]@\
- Indicates the prompter should repeat the action under consideration as many
-times as possible.
-
-@kwd[do-once]@\
- Indicates the prompter should execute the action under consideration once and
-then exit.
-
-@kwd[exit]@\
- Indicates the prompter should terminate its activity in a normal fashion.
-
-@kwd[abort]@\
- Indicates the prompter should terminate its activity without performing any
-closing actions of convenience, for example.
-
-@kwd[keep]@\
- Indicates the prompter should preserve something.
-
-@kwd[help]@\
- Indicates the prompter should display some help information.
-
-@kwd[confirm]@\
- Indicates the prompter should take any input provided or use the default if
-the user entered nothing.
-
-@kwd[quote]@\
- Indicates the prompter should take the following key-event as itself without
-any sort of command interpretation.
-
-@kwd[recursive-edit]@\
- Indicates the prompter should enter a recursive edit in the current context.
-
-@kwd[cancel]@\
- Indicates the prompter should cancel the effect of a previous key-event input.
-
-@kwd[forward-search]@\
- Indicates the prompter should search forward in the current context.
-
-@kwd[backward-search]@\
- Indicates the prompter should search backward in the current context.
-@end[description]
-
-@blankspace(1 line)
-Define a new logical key-event whenever:
-@begin[enumerate]
-The key-event concerned represents a general class of actions, and
-several commands may want to take a similar action of this type.
-
-The exact key-event a command implementor chooses may generate violent taste
-disputes among users, and then the users can trivially change the command in
-their init files.
-
-You are using @f[command-case] which prevents implementors from specifying
-non-standard characters for dispatching in otherwise possibly portable code, 
-and you can define and set the logical key-event in a site dependent file where
-you can mention implementation dependent characters.
-@end[enumerate]
-
-
-
-@chapter(The Echo Area)
-
-@hemlock provides a number of facilities for displaying information and
-prompting the user for it.  Most of these work through a small window displayed
-at the bottom of the screen.  This is called the echo area and is supported by
-a buffer and a window.  This buffer's modeline (see section @ref[modelines]) is
-referred to as the status line, which, unlike other buffers' modelines, is used
-to show general status about the editor, Lisp, or world.
-
-@defhvar[var {Default Status Line Fields}]
-This is the initial list of modeline-field objects stored in the echo area
-buffer.
-@enddefhvar
-
-@defhvar[var "Echo Area Height", val {3}]
-This variable determines the initial height in lines of the echo area window. 
-@enddefhvar
-
-
-@section(Echo Area Functions)
-It is considered poor taste to perform text operations on the echo area buffer
-to display messages; the @f[message] function should be used instead.  A
-command must use this function or set @funref[buffer-modified] for the
-@hid[Echo Area] buffer to @nil to cause @hemlock to leave text in the echo area
-after the command's execution.
-
-@defun[fun {clear-echo-area}]
-Clears the echo area.
-@enddefun
-
-@defun[fun {message}, args {@i[control-string] @rest @i[format-arguments]}]
-@defun1[fun {loud-message}, args {@i[control-string] @rest @i[format-arguments]}]
-@defhvar1[var {Message Pause}, val {0.5}]
-Displays a message in the echo area.  The message is always displayed on a
-fresh line.  @f[message] pauses for @hid[Message Pause] seconds before
-returning to assure that messages are not displayed too briefly to be seen.
-Because of this, @f[message] is the best way to display text in the echo area.
-
-@f[loud-message] is like @f[message], but it first clears the echo area and
-beeps.
-@enddefun
-
-@defvar[var {echo-area-window}]
-@defvar1[var {echo-area-buffer}]
-@f[echo-area-buffer] contains the buffer object for the echo area, which is
-named @hid[Echo Area].  This buffer is usually in @hid[Echo Area] mode.
-@f[echo-area-window] contains a window displaying @f[echo-area-buffer].  Its
-modeline is the status line, see the beginning of this chapter.
-@enddefvar
-
-@defvar[var {echo-area-stream}]
-@index (Echo area)
-This is a buffered @hemlock output stream
-(@pageref[make-hemlock-output-stream-fun]) which inserts text written to it at
-the point of the echo area buffer.  Since this stream is buffered a
-@f[force-output] must be done when output is complete to assure that it is
-displayed.
-@enddefvar
-
-
-@section(Prompting Functions)
-@index(Prompting functions)
-Most of the prompting functions accept the following keyword arguments:
-@begin(description)
-@kwd[must-exist] @\If @kwd[must-exist] has a non-@nil value then the
-user is prompted until a valid response is obtained.  If
-@kwd[must-exist] is @nil then return as a string whatever is input.
-The default is @true.
-
-@kwd[default] @\If null input is given when the user is prompted 
-then this value is returned.  If no default is given then
-some input must be given before anything interesting will happen.
-
-@kwd[default-string] @\If a @kwd[default] is given then this is a
-string to be printed to indicate what the default is.  The default is
-some representation of the value for @kwd[default], for example for a
-buffer it is the name of the buffer.
-
-@kwd[prompt] @\This is the prompt string to display.
-
-@kwd[help] @\@multiple{
-This is similar to @kwd[prompt], except that it is displayed when
-the help command is typed during input.  @comment{If there is some known number
-of options as in keyword parses, then they may be displayed, depending
-on the setting of @hvarref[Help Show Options].}
-
-This may also be a function.  When called with no arguments, it should either
-return a string which is the help text or perform some action to help the user,
-returning @Nil.}
-@end(description)
-
-@defun[fun {prompt-for-buffer}, keys {[prompt][help][must-exist][default]},
-	morekeys {[default-string]}] 
-Prompts with completion for a buffer name and returns the corresponding buffer.
-If @i[must-exist] is @nil, then it returns the input string if it is not a
-buffer name.  This refuses to accept the empty string as input when
-@kwd[default] and @kwd[default-string] are @nil.  @kwd[default-string] may be
-used to supply a default buffer name when @kwd[default] is @nil, but when
-@kwd[must-exist] is non-@nil, it must name an already existing buffer.
-@enddefun
-
-@defmac[fun {command-case}, Args {(@mstar<@i[key] @i[value]>) @Mstar<(@Mgroup"(@MSTAR'@i[tag]') @MOR @i[tag]" @i[help] @MSTAR'@i[form]')>}] 
- This macro is analogous to the Common Lisp @f[case] macro.  Commands such as
-@hid[Query Replace] use this to get a key-event, translate it to a character,
-and then to dispatch on the character to some case.  In addition to character
-dispatching, this supports logical key-events @w<(page
-@pageref[logical-key-events])> by using the input key-event directly without
-translating it to a character.  Since the description of this macro is rather
-complex, first consider the following example:
-@lisp
-(defcommand "Save All Buffers" (p)
-  "Give the User a chance to save each modified buffer."
-  "Give the User a chance to save each modified buffer."
-  (dolist (b *buffer-list*)
-    (select-buffer-command () b)
-    (when (buffer-modified b)
-      (command-case (:prompt "Save this buffer: [Y] "
-		     :help "Save buffer, or do something else:")
-	((:yes :confirm)
-	 "Save this buffer and go on to the next."
-	 (save-file-command () b))
-	(:no "Skip saving this buffer, and go on to the next.")
-	(:recursive-edit
-	 "Go into a recursive edit in this buffer."
-	 (do-recursive-edit) (reprompt))
-	((:exit #\p) "Punt this silly loop."
-	 (return nil))))))
-@endlisp
-
-@f[command-case] prompts for a key-event and then executes the code in the
-first branch with a logical key-event or a character (called @i[tags]) matching
-the input.  Each character must be a standard-character, one that satisfies the
-Common Lisp @f[standard-char-p] predicate, and the dispatching mechanism
-compares the input key-event to any character tags by mapping the key-event to
-a character with @f[ext:key-event-char].  If the tag is a logical key-event,
-then the search for an appropriate case compares the key-event read with the
-tag using @f[logical-key-event-p].
-
-All uses of @f[command-case] have two default cases, @kwd[help] and
-@kwd[abort].  You can override these easily by specifying your own branches
-that include these logical key-event tags.  The @kwd[help] branch displays in a
-pop-up window the a description of the valid responses using the variously
-specified help strings.  The @kwd[abort] branch signals an editor-error.
-
-The @i[key]/@i[value] arguments control the prompting.  The following are valid
-values:
-@begin[description]
-@kwd[help]@\
- The default @kwd[help] case displays this string in a pop-up window.  In
-addition it formats a description of the valid input including each case's
-@i[help] string.
-
-@kwd[prompt]@\
- This is the prompt used when reading the key-event.
-
-@kwd[change-window]@\
- If this is non-nil (the default), then the echo area window becomes the
-current window while the prompting mechanism reads a key-event.  Sometimes it
-is desirable to maintain the current window since it may be easier for users to
-answer the question if they can see where the current point is.
-
-@kwd[bind]@\
- This specifies a variable to which the prompting mechanism binds the input
-key-event.  Any case may reference this variable.  If you wish to know what
-character corresponds to the key-event, use @f[ext:key-event-char].
-@end(description)
-
-Instead of specifying a tag or list of tags, you may use @true.  This becomes
-the default branch, and its forms execute if no other branch is taken,
-including the default @kwd[help] and @kwd[abort] cases.  This option has no
-@i[help] string, and the default @kwd[help] case does not describe the default
-branch.  Every @f[command-case] has a default branch; if none is specified, the
-macro includes one that @f[system:beep]'s and @f[reprompt]'s (see below).
-
-Within the body of @f[command-case], there is a defined @f[reprompt] macro.
-It causes the prompting mechanism and dispatching mechanism to immediately
-repeat without further execution in the current branch.
-@enddefmac
-
-
-@defun[fun {prompt-for-key-event}, keys {[prompt][change-window]}]
-This function prompts for a key-event returning immediately when the user types
-the next key-event.  @macref[command-case] is more useful for most purposes.
-When appropriate, use logical key-events @w<(page
-@pageref[logical-key-events])>.
-@enddefun
-
-@defun[fun {prompt-for-key}, keys {[prompt][help][must-exist][default]},
-	morekeys {[default-string]}]
- This function prompts for a @i[key], a vector of key-events, suitable for
-passing to any of the functions that manipulate key bindings @w<(page
-@pageref[key-bindings])>.  If @i[must-exist] is true, then the key must be
-bound in the current environment, and the command currently bound is returned
-as the second value.
-@enddefun
-
-@defun[fun {prompt-for-file}, keys {[prompt][help][must-exist][default]},
-	morekeys {[default-string]}]
- This function prompts for an acceptable filename in some system dependent
-fashion.  "Acceptable" means that it is a legal filename, and it exists if
-@i[must-exist] is non-@nil.  @f[prompt-for-file] returns a Common Lisp
-pathname.
-
-If the file exists as entered, then this returns it, otherwise it is merged
-with @i[default] as by @f[merge-pathnames].
-@enddefun
-
-@defun[fun {prompt-for-integer}, keys {[prompt][help][must-exist][default]},
-	morekeys {[default-string]}] 
- This function prompts for a possibly signed integer.  If @i[must-exist] is
-@nil, then @f[prompt-for-integer] returns the input as a string if it is not a
-valid integer.
-@enddefun
-
-@defun[fun {prompt-for-keyword}, args {@i[string-tables]},
-	keys {[prompt][help][must-exist]},
-	morekeys {[default][default-string]}]
- This function prompts for a keyword with completion, using the string tables
-in the list @i[string-tables].  If @I[must-exist] is non-@nil, then the result
-must be an unambiguous prefix of a string in one of the @i[string-tables], and
-the returns the complete string even if only a prefix of the full string was
-typed.  In addition, this returns the value of the corresponding entry in the
-string table as the second value.
-
-If @i[must-exist] is @nil, then this function returns the string exactly as
-entered.  The difference between @f[prompt-for-keyword] with @i[must-exist]
-@nil, and @f[prompt-for-string], is the user may complete the input using the
-@hid<Complete Parse> and @hid<Complete Field> commands.
-@enddefun
-
-@defun[fun {prompt-for-expression},
-	keys {[prompt][help][must-exist][default]},
-	morekeys {[default-string]}]
- This function reads a Lisp expression.  If @i[must-exist] is @nil, and a read
-error occurs, then this returns the string typed.
-@enddefun
-
-@defun[fun {prompt-for-string}, keys 
-{[prompt][help][default][default-string]}]
- This function prompts for a string; this cannot fail.
-@enddefun
-
-@defun[fun {prompt-for-variable}, keys {[prompt][help][must-exist][default]},
-	morekeys {[default-string]}]
- This function prompts for a variable name.  If @i[must-exist] is non-@nil,
-then the string must be a variable @i[defined in the current environment], in
-which case the symbol name of the variable found is returned as the second
-value.
-@enddefun
-
-@defun[fun {prompt-for-y-or-n}, keys {[prompt][help][must-exist][default]},
-	morekeys {[default-string]}]
- This prompts for @binding[y], @binding[Y], @binding[n], or @binding[N],
-returning @true or @nil without waiting for confirmation.  When the user types
-a confirmation key, this returns @i[default] if it is supplied.  If
-@i[must-exist] is @nil, this returns whatever key-event the user first types;
-however, if the user types one of the above key-events, this returns @true or
-@nil.  This is analogous to the Common Lisp function @f[y-or-n-p].
-@enddefun
-
-@defun[fun {prompt-for-yes-or-no}, keys {[prompt][help][must-exist][default]},
-	morekeys {[default-string]}]
- This function is to @f[prompt-for-y-or-n] as @f[yes-or-no-p] is to
-@f[y-or-n-p].  "Yes" or "No" must be typed out in full and
-confirmation must be given.
-@enddefun
-
-
-@section(Control of Parsing Behavior)
-
-@defhvar[var {Beep On Ambiguity}, val {@true}]
-If this variable is true, then an attempt to complete a parse which is
-ambiguous will result in a "beep".
-@enddefhvar
-
-
-@begin(comment)
-@hemlock provides for limited control of parsing routine behaviour The
-character attribute @hid[Parse Field Separator] is a boolean attribute, a value
-of @f[1] indicating that the character is a field separator recognized by the
-@hid<Complete Field> command.
-@end(comment)
-
-@begin(comment)
-@defhvar[var {Help Show Options}]
-During a keyword or similar parse, typing the help command may cause a
-list of options to be displayed.  If displaying the help would take up
-more lines than the value of this variable then confirmation will be
-asked for before they will be displayed.
-@enddefhvar
-@end(comment)
-
-
-
-@section(Defining New Prompting Functions)
-Prompting functions are implemented as a recursive edit in the
-@hid[Echo Area] buffer.  Completion, help, and other parsing features
-are implemented by commands which are bound in @hid[Echo Area Mode].
-
-A prompting function passes information down into the recursive edit
-by binding a collection of special variables.
-
-@defvar[var {parse-verification-function}]
-The system binds this to a function that @comref[Confirm Parse] calls.  It does
-most of the work when parsing prompted input.  @comref[Confirm Parse] passes
-one argument, which is the string that was in @var<parse-input-region> when the
-user invokes the command.  The function should return a list of values which
-are to be the result of the recursive edit, or @nil indicating that the parse
-failed.  In order to return zero values, a non-@nil second value may be
-returned along with a @nil first value.
-@enddefvar
-
-@defvar[var {parse-string-tables}]
-This is the list of @f[string-table]s, if any, that pertain to this parse.
-@enddefvar
-
-@defvar[var {parse-value-must-exist}]
-This is bound to the value of the @kwd[must-exist] argument, and is
-referred to by the verification function, and possibly some of the
-commands.
-@enddefvar
-
-@defvar[var {parse-default}]
-When prompting the user, this is bound to a string representing the default
-object, the value supplied as the @kwd[default] argument.  @hid<Confirm Parse>
-supplies this to the parse verification function when the
-@var<parse-input-region> is empty.
-@enddefvar
-
-@defvar[var {parse-default-string}]
-When prompting the user, if @var[parse-default] is @nil, @hemlock displays this
-string as a representation of the default object; for example, when prompting
-for a buffer, this variable would be bound to the buffer name.
-@enddefvar
-
-@defvar[var {parse-type}]
-The kind of parse in progress, one of @kwd[file], @kwd[keyword] or
-@kwd[string].  This tells the completion commands how to do completion, with
-@kwd[string] disabling completion.
-@enddefvar
-
-@defvar[var {parse-prompt}]
-The prompt being used for the current parse.
-@enddefvar
-
-@defvar[var {parse-help}]
-The help string or function being used for the current parse.
-@enddefvar
-
-@defvar[var {parse-starting-mark}]
-This variable holds a mark in the @varref[echo-area-buffer] which
-is the position at which the parse began.
-@enddefvar
-
-@defvar[var {parse-input-region}]
-This variable holds a region with @var[parse-starting-mark] as its
-start and the end of the echo-area buffer as its end.  When
-@hid[Confirm Parse] is called, the text in this region is the text
-that will be parsed.
-@enddefvar
-
-
-@section(Some Echo Area Commands)
-
-These are some of the @hid[Echo Area] commands that coordinate with the
-prompting routines.  @Hemlock binds other commands specific to the @hid[Echo
-Area], but they are uninteresting to mention here, such as deleting to the
-beginning of the line or deleting backwards a word.
-
-@defcom[com {Help On Parse},
-	stuff (bound to @bf[Home, C-_] in @hid[Echo Area] mode)]
-Display the help text for the parse currently in progress.
-@enddefcom
-
-@defcom[com {Complete Keyword},
-	stuff (bound to @bf[Escape] in @hid[Echo Area] mode)] 
-This attempts to complete the current region as a keyword in
-@var[string-tables].  It signals an editor-error if the input is ambiguous
-or incorrect.
-@enddefcom
-
-@defcom[com {Complete Field},
-	stuff (bound to @bf[Space] in @hid[Echo Area] mode)]
-Similar to @hid[Complete Keyword], but only attempts to complete up to and
-including the first character in the keyword with a non-zero
-@kwd[parse-field-separator] attribute.  If
-there is no field separator then attempt to complete the entire keyword.
-If it is not a keyword parse then just self-insert.
-@enddefcom
-
-@defcom[com {Confirm Parse},
-	stuff (bound to @bf[Return] in @hid[Echo Area] mode)]
-If @var[string-tables] is non-@nil find the string in the region in
-them.  Call @var[parse-verification-function] with the current input.
-If it returns a non-@nil value then that is returned as the value of
-the parse.  A parse may return a @nil value if the verification
-function returns a non-@nil second value.
-@enddefcom
-
-
-
-@chapter (Files)
-@index (Files)
-This chapter discusses ways to read and write files at various levels @dash at
-marks, into regions, and into buffers.  This also treats automatic mechanisms
-that affect the state of buffers in which files are read.
-
-@section (File Options and Type Hooks)
-@index (File options)
-@index (Type hooks)
-@index (File type hooks)
-The user specifies file options with a special syntax on the first line of a
-file.  If the first line contains the string "@f[-*-]", then @hemlock
-interprets the text between the first such occurrence and the second, which
-must be contained in one line , as a list of @w{"@f<@i[option]: @i[value]>"}
-pairs separated by semicolons.  The following is a typical example:
-@begin[programexample]
-;;; -*- Mode: Lisp, Editor; Package: Hemlock -*-
-@end[programexample]
-See the @i[Hemlock User's Manual] for more details and predefined options.
-
-File type hooks are executed when @hemlock reads a file into a buffer based on
-the type of the pathname.  When the user specifies a @hid[Mode] file option
-that turns on a major mode, @hemlock ignores type hooks.  This mechanism is
-mostly used as a simple means for turning on some appropriate default major
-mode.
-
-@defmac[fun {define-file-option}, args
-{@i[name] (@i[buffer] @i[value]) @mstar<@i[declaration]> @mstar<@i[form]>}]
-This defines a new file option with the string name @i[name].  @i[Buffer] and
-@i[value] specify variable names for the buffer and the option value string,
-and @i[form]'s are evaluated with these bound.
-@enddefmac
-
-@defmac[fun {define-file-type-hook}, args 
-{@i[type-list] (@i[buffer] @i[type]) @mstar<@i[declaration]> @mstar<@i[form]>}]
-
-This defines some code that @f[process-file-options] (below) executes when the
-file options fail to set a major mode.  This associates each type, a
-@f[simple-string], in @i[type-list] with a routine that binds @i[buffer] to the
-buffer the file is in and @i[type] to the type of the pathname.
-@enddefmac
-
-@defun[fun {process-file-options}, args {@i[buffer] @optional @i[pathname]}]
-This checks for file options in buffer and invokes handlers if there are any.
-@i[Pathname] defaults to @i[buffer]'s pathname but may be @nil.  If there is no
-@hid[Mode] file option that specifies a major mode, and @i[pathname] has a
-type, then this tries to invoke the appropriate file type hook.
-@f[read-buffer-file] calls this.
-@enddefun
-
-
-@section (Pathnames and Buffers)
-There is no good way to uniquely identify buffer names and pathnames.  However,
-@hemlock has one way of mapping pathnames to buffer names that should be used
-for consistency among customizations and primitives.  Independent of this,
-@hemlock provides a means for consistently generating prompting defaults when
-asking the user for pathnames.
-
-@defun[fun {pathname-to-buffer-name}, args {@i[pathname]}]
-This function returns a string of the form "@f[file-namestring]
-@f[directory-namestring]".
-@enddefun
-
-@defhvar[var "Pathname Defaults", val {(pathname "gazonk.del")}]
-@defhvar1[var "Last Resort Pathname Defaults Function"]
-@defhvar1[var "Last Resort Pathname Defaults", val {(pathname "gazonk")}]
-These variables control the computation of default pathnames when needed for
-promting the user.  @hid[Pathname Defaults] is a @i[sticky] default.
-See the @i[Hemlock User's Manual] for more details.
-@enddefhvar
-
-@defun[fun {buffer-default-pathname}, args {@i[buffer]}]
-This returns @hid[Buffer Pathname] if it is bound.  If it is not bound, and
-@i[buffer]'s name is composed solely of alphnumeric characters, then return a
-pathname formed from @i[buffer]'s name.  If @i[buffer]'s name has other
-characters in it, then return the value of @hid[Last Resort Pathname Defaults
-Function] called on @i[buffer].
-@enddefun
-
-@section (File Groups)
-@index (File groups)
-File groups provide a simple way of collecting the files that compose a system
-and naming that collection.  @Hemlock supports commands for searching,
-replacing, and compiling groups.
-
-@defvar[var {active-file-group}]
-This is the list of files that constitute the currently selected file group.
-If this is @nil, then there is no current group.
-@enddefvar
-
-@defmac[fun {do-active-group}, args {@mstar<@i[form]>}]
-@defhvar1[var "Group Find File", val {nil}]
-@defhvar1[var "Group Save File Confirm", val {t}]
-@f[do-active-group] iterates over @var[active-file-group] executing the forms
-once for each file.  While the forms are executing, the file is in the current
-buffer, and the point is at the beginning.  If there is no active group, this
-signals an editor-error.
-
-This reads each file into its own buffer using @f[find-file-buffer].  Since
-unwanted buffers may consume large amounts of memory, @hid[Group Find File]
-controls whether to delete the buffer after executing the forms.  When the
-variable is false, this deletes the buffer if it did not previously exist;
-however, regardless of this variable, if the user leaves the buffer modified,
-the buffer persists after the forms have completed.  Whenever this processes a
-buffer that already existed, it saves the location of the buffer's point before
-and restores it afterwards.  
-
-After processing a buffer, if it is modified, @f[do-active-group] tries to save
-it.  If @hid[Group Save File Confirm] is non-@nil, it asks for confirmation.
-@enddefmac
-
-
-@section (File Reading and Writing)
-Common Lisp pathnames are used by the file primitives.  For probing, checking
-write dates, and so forth, all of the Common Lisp file functions are available.
-
-@defun[fun {read-file}, args {@i[pathname] @i[mark]}]
-This inserts the file named by @i[pathname] at @i[mark].
-@enddefun
-
-@defun[fun {write-file}, args {@i[region] @i[pathname]},
-	keys {[keep-backup][access][append]}]
-@defhvar1[var {Keep Backup Files}, val {@nil}]
-This function writes the contents of @i[region] to the file named by
-@i[pathname].  This writes @i[region] using a stream as if it were opened with
-@kwd[if-exists] supplied as @kwd[rename-and-delete].
-
-When @i[keep-backup], which defaults to the value of @hid[Keep Backup Files],
-is non-@nil, this opens the stream as if @kwd[if-exists] were @kwd[rename].  If
-@i[append] is non-@nil, this writes the file as if it were opened with
-@kwd[if-exists] supplied as @kwd[append].
-
-This signals an error if both @i[append] and @i[keep-backup] are supplied as
-non-@nil.
-
-@i[Access] is an implementation dependent value that is suitable for setting
-@i[pathname]'s access or protection bits.
-@enddefun
-
-
-@defun[fun {write-buffer-file}, args {@i[buffer] @i[pathname]}]
-@defhvar1[var {Write File Hook}]
-@defhvar1[var {Add Newline at EOF on Writing File}, val {@kwd[ask-user]}]
-@f[write-buffer-file] writes @i[buffer] to the file named by @i[pathname]
-including the following:
-@begin[itemize]
-It assumes pathname is somehow related to @i[buffer]'s pathname: if the
-@i[buffer]'s write date is not the same as @i[pathname]'s, then this prompts
-the user for confirmation before overwriting the file.
-
-It consults @hid[Add Newline at EOF on Writing File] (see @i[Hemlock User's
-Manual] for possible values) and interacts with the user if necessary.
-
-It sets @hid[Pathname Defaults], and after using @f[write-file], marks
-@i[buffer] unmodified.
-
-It updates @i[Buffer]'s pathname and write date.
-
-It renames the buffer according to the new pathname if possible.
-
-It invokes @hid[Write File Hook].
-@end[itemize]
-
-@hid[Write File Hook] is a list of functions that take the newly written buffer
-as an argument.
-@enddefun
-
-
-@defun[fun {read-buffer-file}, args {@i[pathname] @i[buffer]}]
-@defhvar1[var {Read File Hook}]
-@f[read-buffer-file] deletes @i[buffer]'s region and uses @f[read-file] to read
-@i[pathname] into it, including the following:
-@begin[itemize]
-It sets @i[buffer]'s write date to the file's write date if the file exists;
-otherwise, it @f[message]'s that this is a new file and sets @i[buffer]'s write
-date to @nil.
-
-It moves @i[buffer]'s point to the beginning.
-
-It sets @i[buffer]'s unmodified status.
-
-It sets @i[buffer]'s pathname to the result of probing @i[pathname] if the file
-exists; otherwise, this function sets @i[buffer]'s pathname to the result of
-merging @i[pathname] with @f[default-directory].
-
-It sets @hid[Pathname Defaults] to the result of the previous item.
-
-It processes the file options.
-
-It invokes @hid[Read File Hook].
-@end[itemize]
-
-@hid[Read File Hook] is a list functions that take two arguments @dash the
-buffer read into and whether the file existed, @true if so.
-@enddefun
-
-
-@defun[fun {find-file-buffer}, args {@i[pathname]}]
-This returns a buffer assoicated with the @i[pathname], reading the file into a
-new buffer if necessary.  This returns a second value indicating whether a new
-buffer was created, @true if so.  If the file has already been read, this
-checks to see if the file has been modified on disk since it was read, giving
-the user various recovery options.  This is the basis of the @hid[Find File]
-command.
-@enddefun
-
-
-
-@chapter (Hemlock's Lisp Environment)
-
-@index (Lisp environment)
-This chapter is sort of a catch all for any functions and variables
-which concern @hemlock's interaction with the outside world.
-
-@section(Entering and Leaving the Editor)
-
-@defun[fun {ed}, args {@optional @i[x]}]
-@defhvar1[var "Entry Hook"]
-@f[ed] enters the editor.  It is basically as specified in Common Lisp.  If
-@i[x] is supplied and is a symbol, the definition of @i[x] is put into a
-buffer, and that buffer is selected.  If @i[x] is a pathname, the file
-specified by @i[x] is visited in a new buffer.  If @i[x] is not supplied or
-@nil, the editor is entered in the same state as when last exited.
-	
-The @hid[Entry Hook] is invoked each time the editor is entered.
-@enddefhvar
-
-@defun[fun {exit-hemlock}, args {@optional @i[value]}]
-@defhvar1[var {Exit Hook}]
-@f[exit-hemlock] leaves @hemlock and return to Lisp; @i[value] is the
-value to return, which defaults to @true.  The hook 
-@hvarref[Exit Hook] is invoked before this is done.
-@enddefun
-
-@defun[fun {pause-hemlock}]
-@f[pause-hemlock] suspends the editor process and returns control to the shell.
-When the process is resumed, it will still be running @hemlock.
-@enddefun
-
-
-@section(Keyboard Input)
-@index(I/O)
-@index[keyboard input]
-@index[input, keyboard]
-
-Keyboard input interacts with a number of other parts of the editor.  Since the
-command loop works by reading from the keyboard, keyboard input is the initial
-cause of everything that happens.  Also, @hemlock redisplays in the low-level
-input loop when there is no available input from the user.
-
-
-@defvar[var {editor-input}]
-@defvar1[var {real-editor-input}]
-@defhvar1[var "Input Hook"]
-@defhvar1[var "Abort Hook"]
-@index[aborting]
-@var[editor-input] is an object on which @hemlock's I/O routines operate.  You
-can get input, clear input, return input, and listen for input.  Input appears
-as key-events.
-
-@var[real-editor-input] holds the initial value of @var[editor-input].  This is
-useful for reading from the user when @var[editor-input] is rebound (such as
-within a keyboard macro.)
-
-@Hemlock invokes the functions in @hid[Input Hook] each time someone reads a
-key-event from @var[real-editor-input].  These take no arguments.
-@enddefvar
-
-@defun[fun {get-key-event}, args {@i[editor-input] @optional @i[ignore-abort-attempts-p]}]
-This function returns a key-event as soon as it is available on
-@i[editor-input].  @i[Editor-input] is either @var[editor-input] or
-@var[real-editor-input].  @i[Ignore-abort-attempts-p] indicates whether
-@binding[C-g] and @binding[C-G] throw to the editor's top-level command loop;
-when this is non-nil, this function returns those key-events when the user
-types them.  Otherwise, it aborts the editor's current state, returning to the
-command loop.
-
-When the user aborts, @Hemlock invokes the functions in @hid[Abort Hook].
-These functions take no arguments.  When aborting, @Hemlock ignores the
-@hid[Input Hook].
-@enddefun
-
-
-@defun[fun {unget-key-event}, args {@i[key-event] @i[editor-input]}]
-This function returns @i[key-event] to @i[editor-input], so the next invocation
-of @f[get-key-event] will return @i[key-event].  If @i[key-event] is
-@f[#k"C-g"] or @f[#k"C-G"], then whether @f[get-key-event] returns it depends
-on that function's second argument.  @i[Editor-input] is either
-@var[editor-input] or @var[real-editor-input].
-@enddefun
-
-@defun[fun {clear-editor-input}, args {@i[editor-input]}]
-This function flushes any pending input on @i[editor-input].  @i[Editor-input]
-is either @var[editor-input] or @var[real-editor-input].
-@enddefun
-
-@defun[fun {listen-editor-input}, args {@i[editor-input]}]
-This function returns whether there is any input available on @i[editor-input].
-@i[Editor-input] is either @var[editor-input] or @var[real-editor-input].
-@enddefun
-
-@defun[fun {editor-sleep}, args {@i[time]}]
-Return either after @i[time] seconds have elapsed or when input is available on
-@var[editor-input].
-@enddefun
-
-@defvar[var {key-event-history}]
-This is a @hemlock ring buffer (see page @pageref[rings]) that holds the last
-60 key-events read from the keyboard.
-@enddefvar
-
-@defvar[var {last-key-event-typed}]
-Commands use this variable to realize the last key-event the user typed to
-invoke the commands.  Before @hemlock ever reads any input, the value is @nil.
-This variable usually holds the last key-event read from the keyboard, but it
-is also maintained within keyboard macros allowing commands to behave the same
-on each repetition as they did in the recording invocation.
-@enddefvar
-
-@defvar[var {input-transcript}]
-If this is non-@nil then it should be an adjustable vector with a fill-pointer.
-When it is non-@nil, @hemlock pushes all input read onto this vector.
-@enddefvar
-
-
-
-@section(Hemlock Streams)
-It is possible to create streams which output to or get input from a buffer.
-This mechanism is quite powerful and permits easy interfacing of @hemlock to
-Lisp.
-
-@defun[fun {make-hemlock-output-stream}, args 
-	{@i[mark] @optional @i[buffered]}]
-@defun1[fun {hemlock-output-stream-p}, args {@i[object]}]
-@f[make-hemlock-output-stream] returns a stream that inserts at the permanent
-mark @i[mark] all output directed to it.  @i[Buffered] controls whether the
-stream is buffered or not, and its valid values are the following keywords:
-@begin[description]
-@kwd[none]@\No buffering is done.  This is the default.
-
-@kwd[line]@\The buffer is flushed whenever a newline is written or
-when it is explicitly done with @f[force-output].
-
-@kwd[full]@\The screen is only brought up to date when it is
-explicitly done with @f[force-output]
-@end[description]
-
-@f[hemlock-output-stream-p] returns @true if @i[object] is a
-@f[hemlock-output-stream] object.
-@enddefun
-
-@defun[fun {make-hemlock-region-stream}, args {@i[region]}]
-@defun1[fun {hemlock-region-stream-p}, args {@i[object]}]
-@f[make-hemlock-region-stream] returns a stream from which the text in
-@i[region] can be read.  @f[hemlock-region-stream-p] returns @true if
-@i[object] is a @f[hemlock-region-stream] object.
-@enddefun
-
-@defmac[fun {with-input-from-region}, args
-{(@i[var] @i[region]) @mstar<@i[declaration]> @mstar<@i[form]>}]
-While evaluating @i[form]s, binds @i[var] to a stream which returns input
-from @i[region].
-@enddefmac
-
-@defmac[fun {with-output-to-mark}, args
-{(@i[var] @i[mark] @mopt<@i"buffered">) @mstar<@i[declaration]> @mstar<@i[form]>}]
- During the evaluation of the @i[form]s, binds @i[var] to a stream which
-inserts output at the permanent @i[mark].  @i[Buffered] has the same meaning as
-for @f[make-hemlock-output-stream].
-@enddefmac
-
-@defmac[fun {with-pop-up-display}, args {(@i[var] @key @i[height name]) @mstar<@i[declaration]> @mstar<@i[form]>}]
-@defvar1[var {random-typeout-buffers}]
- This macro executes @i[forms] in a context with @i[var] bound to a stream.
-@Hemlock collects output to this stream and tries to pop up a display of the
-appropriate height containing all the output.  When @i[height] is supplied,
-@Hemlock creates the pop-up display immediately, forcing output on line breaks.
-The system saves the output in a buffer named @i[name], which defaults to
-@hid[Random Typeout].  When the window is the incorrect height, the display
-mechanism will scroll the window with more-style prompting.  This is useful
-for displaying information of temporary interest.
-
-When a buffer with name @i[name] already exists and was not previously created
-by @f[with-pop-up-display], @Hemlock signals an error.
-
-@var[random-typeout-buffers] is an association list mapping random typeout
-buffers to the streams that operate on the buffers.
-@enddefmac
-
-
-@section (Interface to the Error System)
-The error system interface is minimal.  There is a simple editor-error
-condition which is a subtype of error and a convenient means for signaling
-them.  @Hemlock also provides a standard handler for error conditions while in
-the editor.
-
-@defun[fun {editor-error-format-string}, args {@i[condition]}]
-@defun1[fun {editor-error-format-arguments}, args {@i[condition]}]
-Handlers for editor-error conditions can access the condition object with
-these.
-@enddefun
-
-@defun[fun {editor-error}, args {@rest @i[args]}]
-This function is called to signal minor errors within Hemlock; these are errors
-that a normal user could encounter in the course of editing such as a search
-failing or an attempt to delete past the end of the buffer.  This function
-@f[signal]'s an editor-error condition formed from @i[args], which are @nil or
-a @f[format] string possibly followed by @f[format] arguments.  @Hemlock
-invokes commands in a dynamic context with an editor-error condition handler
-bound.  This default handler beeps or flashes (or both) the display.  If the
-condition passed to the handler has a non-@nil string slot, the handler also
-invokes @f[message] on it.  The command in progress is always aborted, and this
-function never returns.
-@enddefun
-
-@defmac[fun {handle-lisp-errors}, args {@mstar<@i[form]>}]
-Within the body of this macro any Lisp errors that occur are handled in some
-fashion more gracefully than simply dumping the user in the debugger.  This
-macro should be wrapped around code which may get an error due to some action
-of the user @dash for example, evaluating code fragments on the behalf of and
-supplied by the user.  Using this in a command allows the established handler
-to shadow the default editor-error handler, so commands should take care to
-signal user errors (calls to @f[editor-errors]) outside of this context.
-@enddefmac
-
-
-@section (Definition Editing)
-@index (Definition editing)
-@hemlock provides commands for finding the definition of a function, macro, or
-command and placing the user at the definition in a buffer.  This, of course,
-is implementation dependent, and if an implementation does not associate a
-source file with a routine, or if @hemlock cannot get at the information, then
-these commands do not work.  If the Lisp system does not store an absolute
-pathname, independent of the machine on which the maintainer built the system,
-then users need a way of translating a source pathname to one that will be able
-to locate the source.
-
-@defun[fun {add-definition-dir-translation}, args {@i[dir1] @i[dir2]}]
-This maps directory pathname @i[dir1] to @i[dir2].  Successive invocations
-using the same @i[dir1] push into a translation list.  When @hemlock seeks a
-definition source file, and it has a translation, then it tries the
-translations in order.  This is useful if your sources are on various machines,
-some of which may be down.  When @hemlock tries to find a translation, it first
-looks for translations of longer directory pathnames, finding more specific
-translations before shorter, more general ones.
-@enddefun
-
-@defun[fun {delete-definition-dir-translation}, args {@i[dir]}]
-This deletes the mapping of @i[dir] to all directories to which it has been
-mapped.
-@enddefun
-
-
-@section (Event Scheduling)
-@index (Event scheduling)
-@index (Scheduling events)
-The mechanism described in this chapter is only operative when the Lisp process
-is actually running inside of @hemlock, within the @f[ed] function.  The
-designers intended its use to be associated with the editor, such as with
-auto-saving files, reminding the user, etc.
-
-@defun[fun {schedule-event}, args {@i[time] @i[function] @optional @i[repeat]}]
-This causes @hemlock to call @i[function] after @i[time] seconds have passed,
-optionally repeating every @i[time] seconds.  @i[Repeat] defaults to @true.
-This is a rough mechanism since commands can take an arbitrary amount of time
-to run; @hemlock invokes @i[function] at the first possible moment after
-@i[time] has elapsed.  @i[Function] takes the time in seconds that has elapsed
-since the last time it was called (or since it was scheduled for the first
-invocation).
-@enddefun
-
-@defun[fun {remove-scheduled-event}, args {@i[function]}]
-This removes @i[function] from the scheduling queue.  @i[Function] does not
-have to be in the queue.
-@enddefun
-
-
-@section (Miscellaneous)
-
-@defun[fun {in-lisp}, args {@mstar<@i[form]>}]
-@index[Evaluating Lisp code]
-This evaluates @i[form]'s inside @f[handle-lisp-errors].  It also binds
-@var[package] to the package named by @hid[Current Package] if it is non-@nil.
-Use this when evaluating Lisp code on behalf of the user.
-@enddefun
-
-@defmac[fun {do-alpha-chars}, args {(@i[var] @i[kind] [@i[result]]) @mstar<@i[form]>}]
-This iterates over alphabetic characters in Common Lisp binding @i[var] to each
-character in order as specified under character relations in @i[Common Lisp the
-Language].  @i[Kind] is one of @kwd[lower], @kwd[upper], or @kwd[both].  When
-the user supplies @kwd[both], lowercase characters are processed first.
-@enddefmac
-
-
-
-@chapter (High-Level Text Primitives)
-This chapter discusses primitives that operate on higher level text forms than
-characters and words.  For English text, there are functions that know about
-sentence and paragraph structures, and for Lisp sources, there are functions
-that understand this language.  This chapter also describes mechanisms for
-organizing file sections into @i[logical pages] and for formatting text forms.
-
-
-@section (Indenting Text)
-@index (Indenting)
-@label(indenting)
-
-@defhvar[var "Indent Function", val {tab-to-tab-stop}]
-The value of this variable determines how indentation is done, and it is a
-function which is passed a mark as its argument.  The function should indent
-the line that the mark points to.  The function may move the mark around on
-the line.  The mark will be @f[:left-inserting].  The default simply inserts a
-@binding[tab] character at the mark.  A function for @hid[Lisp] mode probably
-moves the mark to the beginning of the line, deletes horizontal whitespace, and
-computes some appropriate indentation for Lisp code.
-@enddefhvar
-
-@defhvar[var "Indent with Tabs", val {indent-using-tabs}]
-@defhvar1[var "Spaces per Tab", val {8}]
-@hid[Indent with Tabs] holds a function that takes a mark and a number of
-spaces.  The function will insert a maximum number of tabs and a minimum number
-of spaces at mark to move the specified number of columns.  The default
-definition uses @hid[Spaces per Tab] to determine the size of a tab.  @i[Note,]
-@hid[Spaces per Tab] @i[is not used everywhere in @hemlock yet, so changing
-this variable could have unexpected results.]
-@enddefhvar
-
-@defun[fun {indent-region}, args {@i[region]}]
-@defun1[fun {indent-region-for-commands}, args {@i[region]}]
-@f[indent-region] invokes the value of @hid[Indent Function] on every line of
-region.  @f[indent-region-for-commands] uses @f[indent-region] but first saves
-the region for the @hid[Undo] command.
-@enddefun
-
-@defun[fun {delete-horizontal-space}, args {@i[mark]}]
-This deletes all characters with a @hid[Space] attribute (see section
-@ref[sys-def-chars]) of @f[1].
-@enddefun
-
-
-@section (Lisp Text Buffers)
-@index (Lisp text functions)
-@hemlock bases its Lisp primitives on parsing a block of the buffer and
-annotating lines as to what kind of Lisp syntax occurs on the line or what kind
-of form a mark might be in (for example, string, comment, list, etc.).  These
-do not work well if the block of parsed forms is exceeded when moving marks
-around these forms, but the block that gets parsed is somewhat programmable.
-
-There is also a notion of a @i[top level form] which this documentation often
-uses synonymously with @i[defun], meaning a Lisp form occurring in a source
-file delimited by parentheses with the opening parenthesis at the beginning of
-some line.  The names of the functions include this inconsistency.
-
-@defun[fun {pre-command-parse-check}, args {@i[mark] @i[for-sure]}]
-@defhvar1[var {Parse Start Function}, val {start-of-parse-block}]
-@defhvar1[var {Parse End Function}, val {end-of-parse-block}]
-@defhvar1[var {Minimum Lines Parsed}, val {50}]
-@defhvar1[var {Maximum Lines Parsed}, val {500}]
-@defhvar1[var {Defun Parse Goal}, val {2}]
-@f[pre-command-parse-check] calls @hid[Parse Start Function] and @hid[Parse End
-Function] on @i[mark] to get two marks.  It then parses all the lines between
-the marks including the complete lines they point into.  When @i[for-sure] is
-non-@nil, this parses the area regardless of any cached information about the
-lines.  Every command that uses the following routines calls this before doing
-so.
-
-The default values of the start and end variables use @hid[Minimum Lines
-Parsed], @hid[Maximum Lines Parsed], and @hid[Defun Parse Goal] to determine
-how big a region to parse.  These two functions always include at least the
-minimum number of lines before and after the mark passed to them.  They try to
-include @hid[Defun Parse Goal] number of top level forms before and after the
-mark passed them, but these functions never return marks that include more than
-the maximum number of lines before or after the mark passed to them.
-@enddefun
-
-@defun[fun {form-offset}, args {@i[mark] @i[count]}]
-This tries to move @i[mark] @i[count] forms forward if positive or -@i[count]
-forms backwards if negative.  @i[Mark] is always moved.  If there were enough
-forms in the appropriate direction, this returns @i[mark], otherwise nil.
-@enddefun
-
-@defun[fun {top-level-offset}, args {@i[mark] @i[count]}]
-This tries to move @i[mark] @i[count] top level forms forward if positive or
--@i[count] top level forms backwards if negative.  If there were enough top
-level forms in the appropriate direction, this returns @i[mark], otherwise nil.
-@i[Mark] is moved only if this is successful.
-@enddefun
-
-@defun[fun {mark-top-level-form}, args {@i[mark1] @i[mark2]}]
-This moves @i[mark1] and @i[mark2] to the beginning and end, respectively, of
-the current or next top level form.  @i[Mark1] is used as a reference to start
-looking.  The marks may be altered even if unsuccessful.  If successful, return
-@i[mark2], else nil.  @i[Mark2] is left at the beginning of the line following
-the top level form if possible, but if the last line has text after the closing
-parenthesis, this leaves the mark immediately after the form.
-@enddefun
-
-@defun[fun {defun-region}, args {@i[mark]}]
-This returns a region around the current or next defun with respect to
-@i[mark].  @i[Mark] is not used to form the region.  If there is no appropriate
-top level form, this signals an editor-error.  This calls
-@f[pre-command-parse-check] first.
-@enddefun
-
-@defun[fun {inside-defun-p}, args {@i[mark]}]
-@defun1[fun {start-defun-p}, args {@i[mark]}]
-These return, respectively, whether @i[mark] is inside a top level form or at
-the beginning of a line immediately before a character whose @hid[Lisp Syntax]
-(see section @ref[sys-def-chars]) value is @kwd[opening-paren].
-@enddefun
-
-@defun[fun {forward-up-list}, args {@i[mark]}]
-@defun1[fun {backward-up-list}, args {@i[mark]}]
-Respectively, these move @i[mark] immediately past a character whose @hid[Lisp
-Syntax] (see section @ref[sys-def-chars]) value is @kwd[closing-paren] or
-immediately before a character whose @hid[Lisp Syntax] value is
-@kwd[opening-paren].
-@enddefun
-
-@defun[fun {valid-spot}, args {@i[mark] @i[forwardp]}]
-This returns @true or @nil depending on whether the character indicated by
-@i[mark] is a valid spot.  When @i[forwardp] is set, use the character after
-mark and vice versa.  Valid spots exclude commented text, inside strings, and
-character quoting.
-@enddefun
-
-@defun[fun {defindent}, args {@i[name] @i[count]}]
-This defines the function with @i[name] to have @i[count] special arguments.
-@f[indent-for-lisp], the value of @hid[Indent Function] (see section
-@ref[indenting]) in @hid[Lisp] mode, uses this to specially indent these
-arguments.  For example, @f[do] has two, @f[with-open-file] has one, etc.
-There are many of these defined by the system including definitions for special
-@hemlock forms.  @i[Name] is a simple-string, case insensitive and purely
-textual (that is, not read by the Lisp reader); therefore, @f["with-a-mumble"]
-is distinct from @f["mumble:with-a-mumble"].
-@enddefun
-
-
-@section (English Text Buffers)
-@index (English text functions)
-@label(text-functions)
-This section describes some routines that understand basic English language
-forms.
-
-@defun[fun {word-offset}, args {@i[mark] @i[count]}]
-This moves @i[mark] @i[count] words forward (if positive) or backwards (if
-negative).  If @i[mark] is in the middle of a word, that counts as one.  If
-there were @i[count] (-@i[count] if negative) words in the appropriate
-direction, this returns @i[mark], otherwise nil.  This always moves @i[mark].
-A word lies between two characters whose @hid[Word Delimiter] attribute value
-is @f[1] (see section @ref[sys-def-chars]).
-@enddefun
-
-@defun[fun {sentence-offset}, args {@i[mark] @i[count]}]
-This moves @i[mark] @i[count] sentences forward (if positive) or backwards (if
-negative).  If @i[mark] is in the middle of a sentence, that counts as one.  If
-there were @i[count] (-@i[count] if negative) sentences in the appropriate
-direction, this returns @i[mark], otherwise nil.  This always moves @i[mark].
-
-A sentence ends with a character whose @hid[Sentence Terminator] attribute is
-@f[1] followed by two spaces, a newline, or the end of the buffer.  The
-terminating character is optionally followed by any number of characters whose
-@hid[Sentence Closing Char] attribute is @f[1].  A sentence begins after a
-previous sentence ends, at the beginning of a paragraph, or at the beginning of
-the buffer.
-@enddefun
-
-@defun[fun {paragraph-offset}, args {@i[mark] @i[count] @optional @i[prefix]}]
-@defhvar1[var {Paragraph Delimiter Function}, var {default-para-delim-function}]
-This moves @i[mark] @i[count] paragraphs forward (if positive) or backwards (if
-negative).  If @i[mark] is in the middle of a paragraph, that counts as one.
-If there were @i[count] (-@i[count] if negative) paragraphs in the appropriate
-direction, this returns @i[mark], otherwise nil.  This only moves @i[mark] if
-there were enough paragraphs.
-
-@hid[Paragraph Delimiter Function] holds a function that takes a mark,
-typically at the beginning of a line, and returns whether or not the current
-line should break the paragraph.  @f[default-para-delim-function] returns @true
-if the next character, the first on the line, has a @hid[Paragraph Delimiter]
-attribute value of @f[1].  This is typically a space, for an indented
-paragraph, or a newline, for a block style.  Some modes require a more
-complicated determinant; for example, @hid[Scribe] modes adds some characters
-to the set and special cases certain formatting commands.
-
-@i[Prefix] defaults to @hid[Fill Prefix] (see section @ref[filling]), and the
-right prefix is necessary to correctly skip paragraphs.  If @i[prefix] is
-non-@nil, and a line begins with @i[prefix], then the scanning process skips
-the prefix before invoking the @hid[Paragraph Delimiter Function].
-Note, when scanning for paragraph bounds, and @i[prefix] is non-@nil, lines are
-potentially part of the paragraph regardless of whether they contain the prefix;
-only the result of invoking the delimiter function matters.
-
-The programmer should be aware of an idiom for finding the end of the current
-paragraph.  Assume @f[paragraphp] is the result of moving @f[mark] one
-paragraph, then the following correctly determines whether there actually is a
-current paragraph:
-@begin[programexample]
-(or paragraphp
-    (and (last-line-p mark)
-         (end-line-p mark)
-	 (not (blank-line-p (mark-line mark)))))
-@end[programexample]
-In this example @f[mark] is at the end of the last paragraph in the buffer, and
-there is no last newline character in the buffer.  @f[paragraph-offset] would
-have returned @nil since it could not skip any paragraphs since @f[mark] was at
-the end of the current and last paragraph.  However, you still have found a
-current paragraph on which to operate.  @f[mark-paragraph] understands this
-problem.
-@enddefun
-
-@defun[fun {mark-paragraph}, args {@f[mark1] @f[mark2]}]
-This marks the next or current paragraph, setting @i[mark1] to the beginning
-and @i[mark2] to the end.  This uses @hid[Fill Prefix] (see section
-@ref[filling]).  @i[Mark1] is always on the first line of the paragraph,
-regardless of whether the previous line is blank.  @i[Mark2] is typically at
-the beginning of the line after the line the paragraph ends on, this returns
-@i[mark2] on success.  If this cannot find a paragraph, then the marks are left
-unmoved, and @nil is returned.
-@enddefun
-
-
-@section (Logical Pages)
-@index (Logical pages)
-@index (Page functions)
-@label(logical-pages)
-Logical pages are a way of dividing a file into coarse divisions.  This is
-analogous to dividing a paper into sections, and @hemlock provides primitives
-for moving between the pages of a file and listing a directory of the page
-titles.  Pages are separated by @hid[Page Delimiter] characters (see section
-@ref[sys-def-chars]) that appear at the beginning of a line.
-
-@defun[fun {goto-page}, args {@i[mark] @i[n]}]
-This moves @i[mark] to the absolute page numbered @i[n].  If there are less
-than @i[n] pages, it signals an editor-error.  If it returns, it returns
-@i[mark].  @hemlock numbers pages starting with one for the page delimited by
-the beginning of the buffer and the first @hid[Page Delimiter] (or the end of
-the buffer).
-@enddefun
-
-@defun[fun {page-offset}, args {@i[mark] @i[n]}]
-This moves mark forward @i[n] (-@i[n] backwards, if @i[n] is negative)
-@hid[Page Delimiter] characters that are in the zero'th line position.  If a
-@hid[Page Delimiter] is the immediately next character after mark (or before
-mark, if @i[n] is negative), then skip it before starting.  This always moves
-@i[mark], and if there were enough pages to move over, it returns @i[mark];
-otherwise, it returns @nil.
-@enddefun
-
-@defun[fun {page-directory}, args {@i[buffer]}]
-This returns a list of each first non-blank line in @i[buffer] that follows a
-@hid[Page Delimiter] character that is in the zero'th line position.  This
-includes the first line of the @i[buffer] as the first page title.  If a page
-is empty, then its title is the empty string.
-@enddefun
-
-@defun[fun {display-page-directory}, args {@i[stream] @i[directory]}]
-This writes the list of strings, @i[directory], to @i[stream], enumerating them
-in a field three wide.  The number and string are separated by two spaces, and
-the first line contains headings for the page numbers and title strings.
-@enddefun
-
-
-@section (Filling)
-@index (filling)
-@label(filling)
-Filling is an operation on text that breaks long lines at word boundaries
-before a given column and merges shorter lines together in an attempt to make
-each line roughly the specified length.  This is different from justification
-which tries to add whitespace in awkward places to make each line exactly the
-same length.  @Hemlock's filling optionally inserts a specified string at the
-beginning of each line.  Also, it eliminates extra whitespace between lines and
-words, but it knows two spaces follow sentences (see section
-@ref[text-functions]).
-
-@defhvar[var "Fill Column", val {75}]
-@defhvar1[var "Fill Prefix", val {nil}]
-These variables hold the default values of the prefix and column arguments to
-@hemlock's filling primitives.  If @hid[Fill Prefix] is @nil, then there is no
-fill prefix.
-@enddefhvar
-
-@defun[fun {fill-region}, args {@i[region] @optional @i[prefix] @i[column]}]
-This deletes any blank lines in region and fills it according to prefix and
-column.  @i[Prefix] and @i[column] default to @hid[Fill Prefix] and @hid[Fill
-Column].
-@enddefun
-
-@defun[fun {fill-region-by-paragraphs},
-	args {@i[region] @optional @i[prefix] @i[column]}]
-This finds paragraphs (see section @ref[text-functions]) within region and
-fills them with @f[fill-region].  This ignores blank lines between paragraphs.
-@i[Prefix] and @i[column] default to @hid[Fill Prefix] and @hid[Fill Column].
-@enddefun
-
-
-
-@chapter (Utilities)
-@index (Utilities)
-This chapter describes a number of utilities for manipulating some types of
-objects @hemlock uses to record information.  String-tables are used to store
-names of variables, commands, modes, and buffers.  Ring lists can be used to
-provide a kill ring, recent command history, or other user-visible features.
-
-
-@section(String-table Functions)
-@index (String-tables)
-@label(string-tables)
-
-String tables are similar to Common Lisp hash tables in that they associate a
-value with an object.  There are a few useful differences: in a string table
-the key is always a case insensitive string, and primitives are provided to
-facilitate keyword completion and recognition.  Any type of string may be added
-to a string table, but the string table functions always return
-@f[simple-string]'s.
-
-A string entry in one of these tables may be thought of as being separated into
-fields or keywords.  The interface provides keyword completion and recognition
-which is primarily used to implement some @hid[Echo Area] commands.  These
-routines perform a prefix match on a field-by-field basis allowing the
-ambiguous specification of earlier fields while going on to enter later fields.
-While string tables may use any @f[string-char] as a separator, the use of
-characters other than @binding[space] may make the @hid[Echo Area] commands
-fail or work unexpectedly.
-
-@defun[fun {make-string-table}, keys {[separator][initial-contents]}]
-This function creates an empty string table that uses @i[separator] as the
-character, which must be a @f[string-char], that distinguishes fields.
-@i[Initial-contents] specifies an initial set of strings and their values in
-the form of a dotted @f[a-list], for example:
-@Begin[ProgramExample]
-'(("Global" . t) ("Mode" . t) ("Buffer" . t))
-@End[ProgramExample]
-@enddefun
-
-@defun[fun {string-table-p}, args {@i[string-table]}]
-This function returns @true if @i[string-table] is a @f[string-table] object,
-otherwise @nil.
-@enddefun
-
-@defun[fun {string-table-separator}, args {@i[string-table]}]
-This function returns the separator character given to @f[make-string-table].
-@enddefun
-
-@defun[fun {delete-string}, args {@i[string] @i[table]}]
-@defun1[fun {clrstring}, args {@i[table]}]
-@f[delete-string] removes any entry for @i[string] from the @f[string-table]
-@i[table], returning @true if there was an entry.  @f[clrstring] removes all
-entries from @i[table].
-@enddefun
-
-@defun[fun {getstring}, args {@i[string] @i[table]}]
-This function returns as multiple values, first the value corresponding to the
-string if it is found and @nil if it isn't, and second @true if it is found and
-@nil if it isn't.
-
-This may be set with @f[setf] to add a new entry or to store a new value for a
-string.  It is an error to try to insert a string with more than one
-field separator character occurring contiguously.
-@enddefun
-
-@defun[fun {complete-string}, args {@i[string] @i[tables]}]
-This function completes @i[string] as far as possible over the list of
-@i[tables], returning five values.  It is an error for @i[tables] to have
-different separator characters.  The five return values are as follows:
-@begin[itemize]
-The maximal completion of the string or @nil if there is none.
-
-An indication of the usefulness of the returned string:
-@begin[description]
-@kwd[none]@\
-There is no completion of @i[string].
-
-@kwd[complete]@\
-The completion is a valid entry, but other valid completions exist too.  This
-occurs when the supplied string is an entry as well as initial substring of
-another entry.
-
-@kwd[unique]@\
-The completion is a valid entry and unique.
-
-@kwd[ambiguous]@\
-The completion is invalid; @f[get-string] would return @nil and @nil if given
-the returned string.
-@end[description]
-
-The value of the string when the completion is @kwd[unique] or @kwd[complete],
-otherwise @nil.
-
-An index, or nil, into the completion returned, indicating where the addition
-of a single field to @i[string] ends.  The command @hid[Complete Field] uses
-this when the completion contains the addition to @i[string] of more than one
-field.
-
-An index to the separator following the first ambiguous field when the
-completion is @kwd[ambiguous] or @kwd[complete], otherwise @nil.
-@end[itemize]
-@enddefun
-
-@defun[fun {find-ambiguous}, args {@i[string] @i[table]}]
-@defun1[fun {find-containing}, args {@i[string] @i[table]}]
-@f[find-ambiguous] returns a list in alphabetical order of all the
-strings in @i[table] matching @i[string].  This considers an entry as matching
-if each field in @i[string], taken in order, is an initial substring of the
-entry's fields; entry may have fields remaining.
- 
-@f[find-containing] is similar, but it ignores the order of the fields in
-@i[string], returning all strings in @i[table] matching any permutation of the
-fields in @i[string].
-@enddefun
-
-@defmac[fun {do-strings}, args {(@i[string-var] @i[value-var] @i[table] @MOPT<@i[result]>) @mstar<@i[declaration]> @mstar<@i[tag] @MOR @i[statement]>}]
-This macro iterates over the strings in @i[table] in alphabetical order.  On
-each iteration, it binds @i[string-var] to an entry's string and @i[value-var]
-to an entry's value.
-@enddefmac
-
-
-@section (Ring Functions)
-@index (Rings)
-@label[rings]
-There are various purposes in an editor for which a ring of values can be used,
-so @hemlock provides a general ring buffer type.  It is used for maintaining a
-ring of killed regions (see section @ref[kill-ring]), a ring of marks (see
-section @ref[mark-stack]), or a ring of command strings which various modes and
-commands maintain as a history mechanism.
-
-@defun[fun {make-ring}, args {@i[length] @optional @i[delete-function]}]
-Makes an empty ring object capable of holding up to @i[length] Lisp objects.
-@i[Delete-function] is a function that each object is passed to before it falls
-off the end.  @i[Length] must be greater than zero.
-@enddefun
-
-@defun[fun {ringp}, args {@i[ring]}]
-Returns @true if @i[ring] is a @f[ring] object, otherwise @nil.
-@enddefun
-
-@defun[fun {ring-length}, args {@i[ring]}]
-Returns as multiple-values the number of elements which @i[ring]
-currently holds and the maximum number of elements which it may hold.
-@enddefun
-
-@defun[fun {ring-ref}, args {@i[ring] @i[index]}]
-Returns the @i[index]'th item in the @i[ring], where zero is the index
-of the most recently pushed.  This may be set with @f[setf].
-@enddefun
-
-@defun[fun {ring-push}, args {@i[object] @i[ring]}]
-Pushes @i[object] into @i[ring], possibly causing the oldest item to
-go away.
-@enddefun
-
-@defun[fun {ring-pop}, args {@i[ring]}]
-Removes the most recently pushed object from @i[ring] and returns it.
-If the ring contains no elements then an error is signalled.
-@enddefun
-
-@defun[fun {rotate-ring}, args {@i[ring] @i[offset]}]
-With a positive @i[offset], rotates @i[ring] forward that many times.
-In a forward rotation the index of each element is reduced by one,
-except the one which initially had a zero index, which is made the
-last element.  A negative offset rotates the ring the other way.
-@enddefun
-
-
-@section (Undoing commands)
-@index (Undo functions)
-@label(undo)
-
-@defun[fun {save-for-undo}, args {@i[name] @i[method] @optional @i[cleanup] @i[method-undo] @i[buffer]}]
-This saves information to undo a command.  @i[Name] is a string to display when
-prompting the user for confirmation when he invokes the @hid[Undo] command (for
-example, @f["kill"] or @f["Fill Paragraph"]).  @i[Method] is the function to
-invoke to undo the effect of the command.  @i[Method-undo] is a function that
-undoes the undo function, or effectively re-establishes the state immediately
-after invoking the command.  If there is any existing undo information, this
-invokes the @i[cleanup] function; typically @i[method] closes over or uses
-permanent marks into a buffer, and the @i[cleanup] function should delete such
-references.  @i[Buffer] defaults to the @f[current-buffer], and the @hid[Undo]
-command only invokes undo methods when they were saved for the buffer that is
-current when the user invokes @hid[Undo].
-@enddefun
-
-@defun[fun {make-region-undo}, args {@i[kind] @i[name] @i[region] @optional @i[mark-or-region]}]
-This handles three common cases that commands fall into when setting up undo
-methods, including cleanup and method-undo functions (see @f[save-for-undo]).
-These cases are indicated by the @i[kind] argument:
-@begin[description]
-@kwd[twiddle]@\
-Use this kind when a command modifies a region, and the undo information
-indicates how to swap between two regions @dash the one before any modification
-occurs and the resulting region.  @i[Region] is the resulting region, and it
-has permanent marks into the buffer.  @i[Mark-or-region] is a region without
-marks into the buffer (for example, the result of @f[copy-region]).  As a
-result of calling this, a first invocation of @hid[Undo] deletes @i[region],
-saving it, and inserts @i[mark-or-region] where @i[region] used to be.  The
-undo method sets up for a second invocation of @hid[Undo] that will undo the
-effect of the undo; that is, after two calls, the buffer is exactly as it was
-after invoking the command.  This activity is repeatable any number of times.
-This establishes a cleanup method that deletes the two permanent marks into the
-buffer used to locate the modified region.
-
-@kwd[insert]@\
-Use this kind when a command has deleted a region, and the undo information
-indicates how to re-insert the region.  @i[Region] is the deleted and saved
-region, and it does not contain marks into any buffer.  @i[Mark-or-region] is a
-permanent mark into the buffer where the undo method should insert @i[region].
-As a result of calling this, a first invocation of @hid[Undo] inserts
-@i[region] at @i[mark-or-region] and forms a region around the inserted text
-with permanent marks into the buffer.  This allows a second invocation of
-@hid[Undo] to undo the effect of the undo; that is, after two calls, the buffer
-is exactly as it was after invoking the command.  This activity is repeatable
-any number of times.  This establishes a cleanup method that deletes either the
-permanent mark into the buffer or the two permanent marks of the region,
-depending on how many times the user used @hid[Undo].
-
-@kwd[delete]@\
-Use this kind when a command has inserted a block of text, and the undo
-information indicates how to delete the region.  @i[Region] has permanent marks
-into the buffer and surrounds the inserted text.  Leave @i[Mark-or-region]
-unspecified.  As a result of calling this, a first invocation of @hid[Undo]
-deletes @i[region], saving it, and establishes a permanent mark into the buffer
-to remember where the @i[region] was.  This allows a second invocation of
-@hid[Undo] to undo the effect of the undo; that is, after two calls, the buffer
-is exactly as it was after invoking the command.  This activity is repeatable
-any number of times.  This establishes a cleanup method that deletes either the
-permanent mark into the buffer or the two permanent marks of the region,
-depending on how many times the user used @hid[Undo].
-@end[description]
-
-@blankspace(1 line)
-@i[Name] in all cases is an appropriate string indicating what the command did.
-This is used by @hid[Undo] when prompting the user for confirmation before
-calling the undo method.  The string used by @hid[Undo] alternates between this
-argument and something to indicate that the user is undoing an undo.
-@enddefun
-
-
-
-@chapter (Miscellaneous)
-This chapter is somewhat of a catch-all for comments and features that don't
-fit well anywhere else.
-
-
-@section (Generic Pointer Up)
-@hid[Generic Pointer Up] is a @hemlock command bound to mouse up-clicks.  It
-invokes a function supplied with the interface described in this section.  This
-command allows different commands to be bound to the same down-click in various
-modes with one command bound to the corresponding up-click.
-
-@defun[fun {supply-generic-pointer-up-function}, args {@i[function]}]
-@index[Generic Pointer Up]
-This function supplies a function that @hid[Generic Pointer Up] invokes the
-next time it executes.
-@enddefun
-
-
-@section (Using View Mode)
-@hid[View] mode supports scrolling through files automatically terminating the
-buffer at end-of-file as well as commands for quitting the mode and popping
-back to the buffer that spawned the @hid[View] mode buffer.  Modes such as
-@hid[Dired] and @hid[Lisp-Lib] use this to view files and description of
-library entries.
-
-Modes that want similar commands should use @f[view-file-command] to view a
-file and get a handle on the view buffer.  To allow the @hid[View Return] and
-@hid[View Quit] commands to return to the originating buffer, you must set the
-variable @hid[View Return Function] in the viewing buffer to a function that
-knows how to do this.  Furthermore, since you now have a reference to the
-originating buffer, you must add a buffer local delete hook to it that will
-clear the view return function's reference.  This needs to happen for two
-reasons in case the user deletes the originating buffer:
-@Begin[Enumerate]
-You don't want the return function to go to a non-existing, invalid buffer.
-
-Since the viewing buffer still exists, its @hid[View Return Function] buffer
-local variable still exists.  This means the function still references the
-deleted originating buffer, and garbage collection cannot reclaim the memory
-locked down by the deleted buffer.
-@End[Enumerate]
-
-The following is a piece of code that could implement part of @hid[Dired View
-File] that uses two closures to accomplish that described above:
-@Begin[ProgramExample]
-(let* ((dired-buf (current-buffer))
-       (buffer (view-file-command nil pathname)))
-  (push #'(lambda (buffer)
-	    (declare (ignore buffer))
-	    (setf dired-buf nil))
-	(buffer-delete-hook dired-buf))
-  (setf (variable-value 'view-return-function :buffer buffer)
-	#'(lambda ()
-	    (if dired-buf
-		(change-to-buffer dired-buf)
-		(dired-from-buffer-pathname-command nil)))))
-@End[ProgramExample]
-
-The @hid[Dired] buffer's delete hook clears the return function's reference to
-the @hid[Dired] buffer.  The return function tests the variable to see if it
-still holds a buffer when the function executes.
-
-
-
-@comment[@chapter (Auxiliary Systems)]
-@include(aux-sys)
diff --git a/docs/hem/hem-docs.log b/docs/hem/hem-docs.log
deleted file mode 100644
index 25528a02ec961d09ec75b75e10fde41a4ef6e139..0000000000000000000000000000000000000000
--- a/docs/hem/hem-docs.log
+++ /dev/null
@@ -1,43 +0,0 @@
-/usr1/lisp/scribe/hem/user/lisp.mss, 01-Sep-89 10:27:47, Edit by Chiles.
-  Modifying slave interaction description.
-
-/usr1/lisp/scribe/hem/cim/cim.mss, 01-Sep-89 10:25:15, Edit by Chiles.
-  Added description of LOUD-MESSAGE.
-
-/usr1/lisp/scribe/hem/cim/aux-sys.mss, 01-Sep-89 10:22:22, Edit by Chiles.
-  Updating slave Lisp interaction functions.
-
-/usr1/lisp/scribe/hem/cim.mss, 27-Jun-89 15:19:47, Edit by Chiles.
-  Moved "Auxiliary Systems" chapter into its own file, and qualified lots of
-  the described symbols with their home package.
-
-/usr1/lisp/scribe/hem/hemimpl.mss, 22-Jun-89 12:56:23, Edit by Chiles.
-  Added new WITH-POP-UP-DISPLAY.
-
-  Updated all the English in the prompting functions section.
-
-  Added the "Keep" logical character description.
-
-
-/usr1/lisp/scribe/hem/hemuser.mss, 22-Jun-89 12:55:03, Edit by Chiles.
-  Added new pop-up windows section.
-
-  Modified modelines section, talked about status line.
-
-  Added completion section.
-
-
-/usr1/lisp/scribe/hem/hemuser.mss, 20-May-89 18:03:57, Edit by Chiles.
-  Modified example after "Name Keyboard Macro".  Scribe was screwing up a paren
-  in the @binding.  I changed it to a programexample, but check the result.
-
-/usr1/lisp/scribe/hemimpl.mss, 18-May-89 13:00:09, Edit by Chiles.
-  Addes sections to miscellaneous chapter for View mode interaction and
-  SUPPLY-GENERIC-POINTER-UP-FUNCTION
-
-/usr1/lisp/scribe/hemimpl.mss, 15-May-89 17:40:09, Edit by Chiles.
-  Added new Miscellaneous chapter.
-
-/usr1/lisp/scribe/hemuser.mss, 15-May-89 14:14:37, Edit by Chiles.
-  Modified "View" mode section.
-
diff --git a/docs/hem/hem.dict b/docs/hem/hem.dict
deleted file mode 100644
index 312c9d2258d3ffbe0e90d757a7d0f5db82d345fc..0000000000000000000000000000000000000000
--- a/docs/hem/hem.dict
+++ /dev/null
@@ -1,446 +0,0 @@
-NEWLINE
-WHITESPACE
-MISINTERPRETED
-ENDCOMMANDS
-RUBOUT
-COMMANDBODY
-DEFCOMMAND
-ENDDEFCOMMAND
-ALT
-BF
-LINEFEED
-TRANSPOSITION
-SPICETITLEPAGE
-CONTENTSMACROS
-TIMESROMANKERN
-NEWFACECODE
-COPYFONT
-PRESSFILE
-BINDINGFONT
-TIMESROMAN
-SUBSTITUTECHAR
-ASSOCFONT
-SETFONTINFO
-STANDARDR
-STANDARDBBI
-SSF
-HELVETICA
-BOLDPAGENO
-PAGENO
-BEGINENTRY
-TABCLEAR
-TABSET
-EXTRALEFTMARGIN
-ENDENTRY
-ININIT
-COMMANDENV
-CM
-COMMANDTEXT
-LEFTMARGIN
-RIGHTMARGIN
-ARGS
-TABDIVIDE
-CHPGNO
-NCONV
-CHAPTERNO
-CHAPID
-PAGEHEADING
-BORDERSTYLE
-SPICETP
-MACLACHLAN
-ABS
-WHIZZY
-SCREENFULL
-REF
-RIGHTDOWN
-LEFTDOWN
-MIDDLEDOWN
-MIDDLEUP
-BIZZARE
-FORMFEED
-NEWLINES
-UN
-YANKS
-YANKED
-OOPS
-TYPOS
-LOWERCASE
-UPPERCASE
-TRANSPOSING
-TRANSPOSE
-EMACS
-UNINITIATED
-TRANSPOSITIONS
-TRANSPOSES
-LF
-PAREN
-COMMANDEND
-BOYER
-MOORE
-UNREADING
-FOO
-FILENAME
-BUFFER'S
-SYS
-TECO
-PROGRAMEXAMPLE
-TRASHED
-SEMI
-PATHNAME
-UPD
-SRCCOM
-LOSSAGE
-DEFUN
-PARENS
-DEFSTRUCT
-DEFMACRO
-UNREADABLE
-ED
-RECOMPILATION
-RECOMPILE
-SFASL
-EVAL
-UNDAMAGED
-NEWPAGE
-INDEXINCLUDE
-NLM
-EMS
-RLM
-CENUMERATE
-LEFTMPOSN
-BULLETPOSN
-NRM
-CDESCRIPTION
-RRM
-DEFHVAR
-ENDDEFHVAR
-HVAR
-SLISP
-PICE
-ISP
-CLISP
-OMMON
-MACS
-DOC
-PORTED
-ZWEI
-'S
-BLOTCH
-PERQ
-META
-KEYPAD
-LEFTUP
-COMMAND
-'S
-FACECODE
-VARS
-SOS
-MODELESS
-MODELINE
-MSS
-UNDERRATED
-MALCOORDINATION
-RIGHTARROW
-LEFTARROW
-DOWNARROW
-UPARROW
-SPASTIC
-EOF
-PATHNAMES
-GAZONK
-DEL
-IO
-INOPERATIVE
-TYPESCRIPT
-KEYTRAN
-REDIRECTED
-BACKTRACE
-CONDITIONALIZE
-INIT
-'HEMLOCK
-SETV
-DEFINDENT
-ABBREVIATORY
-NEUTRALIZES
-UNEXPAND
-RESYNCHRONIZING
-FORMFEEDS
-COMMAND'S
-HEMLOCKMAN
-READDEFS
-RESHAPE
-IDIOM
-CURVACEOUS
-PERCENTAGEWISE
-ABBREVS
-ABBREV
-PROB
-BINARIES
-ENDDEFVAR
-FEEP
-KWD
-DEFUNS
-VAL
-DEFCOM
-ENDDEFCOM
-LLISP
-REBINDS
-TYPESCRIPTS
-SYNTAXES
-COMREF
-MAKUNBOUND
-DEFVAR
-ENDDEFUN
-VAR
-ARGS
-DEFUN
-DEFVAR
-ENDDEFVAR
-CHECKIN
-EXT
-GETSTRING
-CLRSTRING
-HASHTABLES
-TYPEOUT
-ERRORP
-REPROMPT
-DOLIST
-CURSORPOS
-RECENTERING
-MACREF
-ZEROP
-UNSHADOW
-MOD
-DEFATTRIBUTE
-ADA
-INTERNING
-MOREKEYS
-CLEANUP
-DEFMODE
-FUNCALLS
-MGROUP
-HLET
-ENDDEFCON
-DEFCON
-UPCASE
-'STRING
-UPPERCASED
-NINSERT
-FUNLABEL
-EQ
-VARREF
-TRUENAME
-HVARREF
-FUNREF
-ENDLISP
-MIN
-ENDDEFMAC
-MOPT
-POS
-MSTAR
-DEFMAC
-'TH
-MARK'S
-CHARPOS
-EQL
-LINE'S
-REMF
-PUTF
-GETF
-PLIST
-SETF
-MULTICS
-WHOLEY
-SKEF
-UTTIR
-SINGLESIDED
-HYPHENATION
-NAMESTRING
-NAMESTRINGS
-FASL
-DEF
-DEFANYTHING
-CRYPTIC
-WILDCARDS
-FILESYSTEM
-PAGEREF
-XTERM
-TERMCAP
-UNIX
-LIB
-MISC
-VERBATIM
-MODELINES
-PIXELS
-BITMAP
-WORKSTATION
-USR
-COM
-PREFIXING
-HYPER
-CRUFT
-LIBRARYFILE
-FONTFAMILY
-STRINGMAX
-BEEPING
-AUTORAISE
-TELNET
-SLAVE'S
-SERVER'S
-PREPENDING
-OFFLOADING
-ICONIFY
-LPR
-INFO
-CHECKPOINTED
-ROBERT
-MUNGING
-DEACTIVATED
-EPHEMERALLY
-DEACTIVATE
-HQB
-MODELINEP
-RINGP
-SUBTYPES
-SUBTYPE
-MSTAR'
-WINDOWP
-COMMANDP
-MOR
-GTR
-GEQ
-NEQ
-LEQ
-LSS
-FIELD'S
-WINDOWS'
-BUFFERS'
-BUFFERP
-DEACTIVATES
-REGIONP
-MARKP
-LINEP
-COMMANDSTRING
-DOD
-RESEARCHCREDIT
-CS
-CMU
-CHILES
-BLANKSPACE
-TITLEBOX
-TITLEPAGE
-REPORTTITLE
-ARPACREDIT
-DOUBLESIDED
-UNDOABLE
-LISPS
-CLX
-SPEC
-DISASSOCIATED
-MAILERS
-RAND
-AFS
-SUPFILE
-STEPPENWOLF
-GPA
-CRYPT
-HOSTBASE
-LOGIN
-RT'S
-FRAME'S
-ARPANET
-SETENV
-FORWCOMPS
-REPLCOMPS
-RMMPROC
-RM
-FORMFILE
-NOCC
-FCC
-REPL
-PREVS
-RFSLINK
-HOSTNAME
-XBIFF
-RFS
-GROUPNAME
-ACCOUNTNAME
-BLURBS
-WORKSTATION'S
-PROFILENAME
-USERNAME
-MAILDROP
-MACHINENAME
-WORKSTATIONS
-HEADERS'
-LISPY
-FIELDS'
-INBOX
-ANNO
-NOTATING
-MH
-ID
-MH'S
-MSGS
-EXP
-CC
-DATEFIELD
-BB
-MSG
-FOLDER'S
-COMP
-FORW
-DRAFTFOLDER
-DRAFTMESSAGE
-INC
-HEMLOCKDELETED
-RMM
-NOTATED
-UNDELETE
-ID'S
-RMF
-REFILE
-REFILING
-REFILED
-DEACTIVATING
-UNKILL
-ZERO'TH
-DIR
-VS
-KEYSYM
-KEYCODE
-XLIB
-KEYSYM'S
-FORWARDP
-HI
-ISPELL
-LEN
-LISP'S
-TWIDDLE
-RIGHTUP
-HEMUSER
-MACROEXPAND
-UNPROVIDED
-DIRED
-WILDCARD
-UNDELETING
-TXT
-PATHNAME'S
-SUBDIRECTORIES
-SUBDIRECTORY
-FILENAMES
-BUFED
-HINIT
-WINDOWING
-UNSUPPLIED
-CALLABLE
-'ABLE
-OP
-FORGOES
-AUX
-'RESCHEDULE
-'CHECK
-'REMOVE
-BITCHFUCKSALL
-SUBPROCESS
-KEYSYMS
diff --git a/docs/hem/user/commands.mss b/docs/hem/user/commands.mss
deleted file mode 100644
index 7d547bd04f4a89a5f4db8050f4d6b4eb07a12192..0000000000000000000000000000000000000000
--- a/docs/hem/user/commands.mss
+++ /dev/null
@@ -1,822 +0,0 @@
-@comment{-*- Dictionary: hem; Mode: spell; Package: Hemlock -*-}
-@chap[Basic Commands]
-@section[Motion Commands]
-
-@index[commands, basic]@index[motion]There is a fairly small number of
-basic commands for moving around in the buffer.  While there are many other
-more complex motion commands, these are by far the most commonly used and
-the easiest to learn.
-
-@defcom[com "Forward Character", bind (C-f, Rightarrow)]
-@defcom1[com "Backward Character", bind (C-b, Leftarrow)]
-@index[character, motion]
-@hid[Forward Character] moves the point forward by one character.  If a prefix
-argument is supplied, then the point is moved by that many characters.
-@hid[Backward Character] is identical, except that it moves the point
-backwards.
-@enddefcom
-
-@defcom[com "Forward Word", bind {M-f}]
-@defcom1[com "Backward Word", bind {M-b}]
-@index[word, motion]These commands move the point forward and backward
-over words.  The point is always left between the last word and first
-non-word character in the direction of motion.  This means that after moving
-backward the cursor appears on the first character of the word, while after
-moving forward, the cursor appears on the delimiting character.  Supplying
-a prefix argument moves the point by that many words.
-@enddefcom
-
-@defcom[com "Next Line", bind (C-n, Downarrow)]
-@defcom1[com "Previous Line", bind (C-p, Uparrow)]
-@defcom1[com "Goto Absolute Line"]
-@index[line, motion]
-@hid[Next Line] and @hid[Previous Line] move to adjacent lines, while remaining
-the same distance within a line.  Note that this motion is by logical lines,
-each of which may take up many lines on the screen if it wraps.  If a prefix
-argument is supplied, then the point is moved by that many lines.
-
-The position within the line at the start is recorded, and each successive
-use of @binding[C-p] or @binding[C-n] attempts to move the point to that
-position on the new line.  If it is not possible to move to the recorded
-position because the line is shorter, then the point is left at the end of
-the line.
-
-@hid[Goto Absolute Line] moves to the indicated line, as if you counted them
-starting at the beginning of the buffer with number one.  If the user supplies
-a prefix argument, it is the line number; otherwise, @Hemlock prompts the user
-for the line.
-@enddefcom
-
-@defcom[com "End of Line", bind {C-e}]
-@defcom1[com "Beginning of Line", bind {C-a}]
-@hid[End of Line] moves the point to the end of the current line, while 
-@hid[Beginning of Line] moves to the beginning.  If a prefix argument is
-supplied, then the point is moved to the end or beginning of the line that
-many lines below the current one.
-@enddefcom
-
-@defcom[com "Scroll Window Down", bind {C-v}]
-@defcom1[com "Scroll Window Up", bind {M-v}]
-@index[scrolling]
-@hid[Scroll Window Down] moves forward in the buffer by one screenful of text,
-the exact amount being determined by the size of the window.  If a prefix
-argument is supplied, then this scrolls the screen that many lines.  When this
-action scrolls the line with the point off the screen, it this command moves
-the point to the vertical center of the window.  @hid[Scroll Window Up] is
-identical to @hid[Scroll Window Down], except that it moves backwards.
-@enddefcom
-
-@defhvar[var "Scroll Overlap", val {2}]
-This variable is used by @hid[Scroll Window Down] and @hid[Scroll Window Up] to
-determine the number of lines by which the new and old screen should overlap.
-@enddefhvar
-
-@defcom[com "End of Buffer", bind (M-<)]
-@defcom1[com "Beginning of Buffer", bind (@bf[M->])]
-These commands are used to conveniently get to the very beginning and end of the
-text in a buffer.  Before the point is moved, its position is saved by
-pushing it on the mark stack (see page @pageref[marks]).
-@enddefcom
-
-@defcom[com "Top of Window", bind (M-,)]
-@defcom1[com "Bottom of Window", bind (M-.)]
-@index[window, motion]@hid[Top of Window] moves the point to the beginning of
-the first line displayed in the current window.  @hid[Bottom of Window] moves
-to the beginning of the last line displayed.
-@enddefcom
-
-
-@section[The Mark and The Region]
-
-@label[marks]@index[marks]@index[region]@index[selection]Each buffer has a
-distinguished position known as the @i[mark].  The mark initially points to the
-beginning of the buffer.  The area between the mark and the point is known as
-the @i[region].  Many @hemlock commands which manipulate large pieces of text
-use the text in the region.  To use these commands, one must first use some
-command to mark the region.
-
-@index[active regions]Although the mark is always pointing somewhere (initially
-to the beginning of the buffer), region commands insist that the region be made
-@i[active] before it can be used.  This prevents accidental use of a region
-command from mysteriously mangling large amounts of text.
-
-@defhvar[var "Active Regions Enabled", val {t}]
-When this variable is true, region commands beep unless the region is active.
-This may be set to @false for more traditional @emacs region semantics.
-@enddefhvar
-
-Once a marking command makes the region active, it remains active until:
-@begin[itemize]
-a command uses the region,
-
-a command modifies the buffer,
-
-a command changes the current window or buffer,
-
-a command signals an editor error,
-
-or the user types @binding[C-g].
-@end[itemize]
-Motion commands have the effect of redefining the region, since they move the
-point and leave the region active.
-
-@index[ephemerally active regions]Commands that insert a large chunk of
-text into the buffer usually set an @i[ephemerally active] region around
-the inserted text.  An ephemerally active region is always deactivated by
-the next command, regardless of the kind of command.  The ephemerally
-active region allows an immediately following region command to manipulate
-the inserted text, but doesn't persist annoyingly.  This is also very
-useful with active region highlighting, since it visibly marks the inserted
-text.
-
-
-@defhvar[var "Highlight Active Region", val {t}]
-@defhvar1[var "Active Region Highlighting Font", val {nil}]
-When @hid[Highlight Active Region] is true, @hemlock displays the text in the
-region in a different font whenever the region is active.  This provides a
-visible indication of what text will be manipulated by a region command.
-Active region highlighting is only supported under @windows.
-
-@hid[Active Region Highlighting Font] is the name of the font to use for active
-region highlighting.  If unspecified, @hemlock uses an underline font.
-@enddefhvar
-
-
-@defcom[com "Set/Pop Mark", bind (C-@@)]
-This command moves the mark to the point (saving the old mark on the mark
-stack) and activates the region.  After using this command to mark one end of
-the region, use motion commands to move to the other end, then do the region
-command.  This is the traditional @emacs marking command; when running under a
-windowing system with mouse support, it is usually easier to use the mouse with
-the @comref[Point to Here] and @comref[Generic Pointer Up].
-
-For historical reasons, the prefix argument causes this command to do things
-that are distinct commands in @Hemlock.  A prefix argument of four does
-@hid[Pop and Goto Mark], and a prefix argument of @f[16] does
-@hid[Pop Mark].
-@enddefcom
-
-@defcom[com "Mark Whole Buffer", bind (C-x h)]
-@defcom1[com "Mark to Beginning of Buffer", bind (C-<)]
-@defcom1[com "Mark to End of Buffer", bind (C->)]
-@hid[Mark Whole Buffer] sets the region around the whole buffer, with the point
-at the beginning and the mark at the end.  If a prefix argument is supplied,
-then the mark is put at the beginning and the point at the end.  The mark is
-pushed on the mark stack beforehand, so popping the stack twice will restore
-it.
-
-@hid[Mark to Beginning of Buffer] sets the current region from point to the
-beginning of the buffer.
-
-@hid[Mark to End of Buffer] sets the current region from the end of the buffer
-to point.
-@enddefcom
-
-@defcom[com "Activate Region", bind (C-x C-Space, C-x C-@@)]
-This command makes the region active, using whatever the current position of
-the mark happens to be.  This is useful primarily when the region is
-accidentally deactivated.
-@enddefcom
-
-
-@subsection[The Mark Stack]
-
-@index[mark stack]As was hinted at earlier, each buffer has a @i[mark stack],
-providing a history of positions in that buffer.  The current mark is the mark
-on the top of the stack; earlier values are recovered by popping the stack.
-Since commands that move a long distance save the old position on the mark
-stack, the mark stack commands are useful for jumping to interesting places in
-a buffer without having to do a search.
-
-@defcom[com "Pop Mark", bind (C-M-Space)]
-@defcom1[com "Pop and Goto Mark", bind (M-@@, M-Space)]
-@hid[Pop Mark] pops the mark stack, restoring the current mark to the next most
-recent value.  @hid[Pop and Goto Mark] also pops the mark stack, but instead of
-discarding the current mark, it moves the point to that position.  Both
-commands deactivate the region.
-@enddefcom
-
-@defcom[com "Exchange Point and Mark", bind (C-x C-x)]
-This command interchanges the position of the point and the mark, thus moving
-to where the mark was, and leaving the mark where the point was.  This command
-can be used to switch between two positions in a buffer, since repeating it
-undoes its effect.  The old mark isn't pushed on the mark stack, since it is
-saved in the point.
-@enddefcom
-
-
-@subsection[Using The Mouse]
-
-@index[mouse]It can be convenient to use the mouse to point to positions in
-text, especially when moving large distances.  @hemlock defines several
-commands for using the mouse.  These commands can only be used when running
-under @windows (see page @pageref[using-x].)
-
-@defcom[com "Here to Top of Window", bind (Rightdown)]
-@defcom1[com "Top Line to Here", bind (Leftdown)]
-@index[window, motion]@hid[Here to Top of Window] scrolls the window so as to
-move the line which is under the mouse cursor to the top of the window.  This
-has the effect of moving forward in the buffer by the distance from the top of
-the window to the mouse cursor.  @hid[Top Line to Here] is the inverse
-operation, it scrolls backward, moving current the top line underneath the
-mouse.
-
-If the mouse is near the left edge of a window, then these commands do smooth
-scrolling.  @hid[Here To Top of Window] repeatedly scrolls the window up by one
-line until the mouse button is released.  Similarly, @hid[Top Line to Here]
-smoothly scrolls down.
-@enddefcom
-
-@defcom[com "Point to Here", bind (Middledown, S-Leftdown)]
-This command moves the point to the position of the mouse, changing to a
-different window if necessary.
-
-When used in a window's modeline, this moves the point of the window's buffer
-to the position within the file that is the same percentage, start to end, as
-the horizontal position of the mouse within the modeline.  This also makes this
-window current if necessary.
-
-This command supplies a function @hid[Generic Pointer Up] invokes if it runs
-without any intervening generic pointer up predecessors executing.  If the
-position of the pointer is different than the current point when the user
-invokes @hid[Generic Pointer Up], then this function pushes a buffer mark at
-point and moves point to the pointer's position.  This allows the user to mark
-off a region with the mouse.
-@enddefcom
-
-@defcom[com "Generic Pointer Up", bind (Middleup, S-Leftup)]
-Other commands determine this command's action by supplying functions that
-this command invokes.  The following built-in commands supply the following
-generic up actions:
-@Begin[Description]
-@hid[Point to Here]@\
- When the position of the pointer is different than the current point, the
-action pushes a buffer mark at point and moves point to the pointer's position.
-
-@hid[Bufed Goto and Quit]@\
- The action is a no-op.
-@End[Description]
-@enddefcom
-
-@defcom[com "Insert Kill Buffer", bind (S-Rightdown)]
-This command is a combination of @hid[Point to Here] and @comref[Un-Kill].  It
-moves the point to the mouse location and inserts the most recently killed
-text.
-@enddefcom
-
-
-@section[Modification Commands]
-@index[commands, modification]
-
-There is a wide variety of basic text-modification commands, but once again the
-simplest ones are the most often used.
-
-@subsection[Inserting Characters]
-@index[character, insertion]
-@index[insertion, character]
-
-In @hemlock, you can insert characters with graphic representations by typing
-the corresponding key-event which you normally generate with the obvious
-keyboard key.  You can only insert characters whose codes correspond to ASCII
-codes.  To insert those without graphic representations, use @hid[Quoted
-Insert].
-
-@defcom[com "Self Insert"]
-@hid[Self Insert] inserts into the buffer the character corresponding to the
-key-event typed to invoke the command.  This command is normally bound to all
-such key-events @binding[Space].  If a prefix argument is supplied, then this
-inserts the character that many times.
-@enddefcom
-
-@defcom[com "New Line", bind (Return)]
-This command, which has roughly the same effect as inserting a @bf[Newline],
-is used to move onto a new blank line.  If there are at least two blank
-lines beneath the current one then @binding[Return] cleans off any
-whitespace on the next line and uses it, instead of inserting a newline.
-This behavior is desirable when inserting in the middle of text, because
-the bottom half of the screen does not scroll down each time @hid[New Line]
-is used.
-@enddefcom
-
-@defcom[com "Quoted Insert", bind {C-q}]
-Many key-events have corresponding ASCII characters, but these key-events are
-bound to commands other than @hid[Self Insert].  Sometimes they are otherwise
-encumbered such as with @binding[C-g].  @hid[Quoted Insert] prompts for a
-key-event, without any command interpretation semantics, and inserts the
-corresponding character.  If the appropriate character has some code other than
-an ASCII code, this will beep and abort the command.  A common use for this
-command is inserting a @bf[Formfeed] by typing @binding[C-q C-l].  If a prefix
-argument is supplied, then the character is inserted that many times.
-@enddefcom
-
-@defcom[com "Open Line", bind {C-o}]
-This command inserts a newline into the buffer without moving the point.
-This command may also be given a prefix argument to insert a number of
-newlines, thus opening up some room to work in the middle of a screen of
-text.  See also @comref[Delete Blank Lines].
-@enddefcom
-
-
-@subsection[Deleting Characters]
-@index[deletion, character]
-@index[character, deletion]
-There are a number of commands for deleting characters as well.
-
-@defhvar[var "Character Deletion Threshold", val {5}]
-If more than this many characters are deleted by a character deletion command,
-then the deleted text is placed in the kill ring.
-@enddefhvar
-
-@defcom[com "Delete Next Character", bind {C-d}]
-@defcom1[com "Delete Previous Character", bind (Delete, Backspace)]
-@hid[Delete Next Character] deletes the character immediately following the
-point, that is, the character which appears under the cursor.  When given a
-prefix argument, @binding[C-d] deletes that many characters after the
-point.  @hid[Delete Previous Character] is identical, except that it
-deletes characters before the point.
-@enddefcom
-
-@defcom[com "Delete Previous Character Expanding Tabs"]
-@hid[Delete Previous Character Expanding Tabs] is identical to
-@hid[Delete Previous Character], except that it treats tabs as the
-equivalent number of spaces.  Various language modes that use tabs for
-indentation bind @binding[Delete] to this command.
-@enddefcom
-
-
-@subsection[Killing and Deleting]
-
-@index[killing]@index[cutting]@index[pasting]@index[kill ring]@hemlock has many
-commands which kill text.  Killing is a variety of deletion which saves the
-deleted text for later retrieval.  The killed text is saved in a ring buffer
-known as the @i[kill ring].  Killing has two main advantages over deletion:
-@begin[enumerate]
-If text is accidentally killed, a not uncommon occurrence, then it can be
-restored.
-
-Text can be moved from one place to another by killing it and then
-restoring it in the new location.
-@end[enumerate]
-
-Killing is not the same as deleting.  When a command is said to delete
-text, the text is permanently gone and is not pushed on the kill ring.
-Commands which delete text generally only delete things of little
-importance, such as single characters or whitespace.
-
-@subsection[Kill Ring Manipulation]
-@defcom[com "Un-Kill", bind {C-y}]
-@index[kill ring, manipulation]This command "yanks" back the most
-recently killed piece of text, leaving the mark before the inserted text
-and the point after.  If a prefix argument is supplied, then the text that
-distance back in the kill ring is yanked.
-@enddefcom
-
-@defcom[com "Rotate Kill Ring", bind {M-y}]
-This command rotates the kill ring forward, replacing the most recently
-yanked text with the next most recent text in the kill ring. @binding[M-y]
-may only be used immediately after a use of @binding[C-y] or a previous
-use of @binding[M-y].  This command is used to step back through the text
-in the kill ring if the desired text was not the most recently killed, and
-thus could not be retrieved directly with a @binding[C-y].  If a prefix
-argument is supplied, then the kill ring is rotated that many times.
-@enddefcom
-
-@defcom[com "Kill Region", bind {C-w}]
-@index[region, killing]This command kills the text between the point and
-mark, pushing it onto the kill ring.  This command is usually the best way
-to move or remove large quantities of text.
-@enddefcom
-
-@defcom[com "Save Region", bind {M-w}]
-This command pushes the text in the region on the kill ring, but doesn't
-actually kill it, giving an effect similar to typing @binding[C-w C-y].
-This command is useful for duplicating large pieces of text.
-@enddefcom
-
-@subsection[Killing Commands]
-
-@index[commands, killing]Most commands which kill text append into the
-kill ring, meaning that consecutive uses of killing commands will insert
-all text killed into the top entry in the kill ring.  This allows large
-pieces of text to be killed by repeatedly using a killing command.
-
-@defcom[com "Kill Line", bind {C-k}]
-@defcom1[com "Backward Kill Line"]
-@index[line, killing]@hid[Kill Line] kills the text from the point to the
-end of the current line, deleting the line if it is empty.  If a prefix
-argument is supplied, then that many lines are killed.  Note that a prefix
-argument is not the same as a repeat count.
-
-@hid[Backward Kill Line] is similar, except that it kills from the point to the
-beginning of the line.  If it is called at the beginning of the line, it kills
-the newline and any trailing whitespace on the previous line.  With a prefix
-argument, this command is the same as @hid[Kill Line] with a negated argument.
-@enddefcom
-
-@defcom[com "Kill Next Word", bind {M-d}]
-@defcom1[com "Kill Previous Word", bind (M-Backspace, M-Delete)]
-@index[word, killing]@hid[Kill Next Word] kills from the point to the end
-of the current or next word.  If a prefix argument is supplied, then that
-many words are killed.  @hid[Kill Previous Word] is identical, except that
-it kills backward.
-@enddefcom
-
-@subsection[Case Modification Commands]
-
-@index[case modification]@hemlock provides a few case modification
-commands, which are often useful for correcting typos.
-
-@defcom[com "Capitalize Word", bind {M-c}]
-@defcom1[com "Lowercase Word", bind {M-l}]
-@defcom1[com "Uppercase Word", bind {M-u}]
-@index[word, case modification]These commands modify the case of the
-characters from the point to the end of the current or next word, leaving
-the point after the end of the word affected.  A positive prefix argument
-modifies that many words, moving forward.  A negative prefix argument
-modifies that many words before the point, but leaves the point unmoved.
-@enddefcom
-
-@defcom[com "Lowercase Region", bind (C-x C-l)]
-@defcom1[com "Uppercase Region", bind (C-x C-u)]
-@index[region, case modification]These commands case-fold the text in the
-region.  Since these commands can damage large amounts of text, they ask for
-confirmation before modifying large regions and can be undone with @hid[Undo].
-@enddefcom
-
-@subsection[Transposition Commands]
-
-@index[transposition]@index[commands, transposition]@hemlock provides a
-number of transposition commands.  A transposition command swaps the
-"things" before and after the point and moves forward one "thing".  Just
-how a "thing" is defined depends on the particular transposition command.
-Transposition commands, particularly
-@hid[Transpose Characters] and @hid[Transpose Words], are useful for
-correcting typos.  More obscure transposition commands can be used to amaze
-your friends and demonstrate your immense knowledge of exotic @emacs
-commands.
-
-To the uninitiated, the behavior of transposition commands may seem mysterious;
-this has led some implementors to attempt to improve the definition of
-transposition, but right-thinking people will accept no substitutes.  The
-@emacs transposition definition used in @hemlock has two useful properties:
-@begin[enumerate]
-Repeated applications of a transposition command have a useful effect.  The
-way to visualize this effect is that each use of the transposition command
-drags the previous thing over the next thing.  It is possible to correct
-double transpositions easily using @hid[Transpose Characters].
-
-Transposition commands move backward with a negative prefix argument, thus
-undoing the effect of the equivalent positive argument.
-@end[enumerate]
-
-@defcom[com "Transpose Characters", bind {C-t}]
-@index[character, transposition]This command exchanges the characters on
-either side of the point and moves forward, unless at the end of a line, in
-which case it transposes the previous two characters without moving.
-@enddefcom
-
-@defcom[com "Transpose Lines", bind (C-x C-t)]
-@index[line, transposition]This command transposes the previous and
-current line, moving down to the next line.  With a zero argument, it
-transposes the current line and the line the mark is on.
-@enddefcom
-
-@defcom[com "Transpose Words", bind {M-t}]
-@index[word, transposition]This command transposes the previous word and
-the current or next word.
-@enddefcom
-
-
-@defcom[com "Transpose Regions", bind (C-x t)]
-This command transposes two regions with endpoints defined by the mark stack
-and point.  To use this command, place three marks (in order) at the start and
-end of the first region, and at the start of the second region, then place the
-point at the end of the second region.  Unlike the other transposition
-commands, a second use will simply undo the effect of the first use, and to do
-even this, you must reactivate the current region.
-@enddefcom
-
-
-@subsection[Whitespace Manipulation]
-These commands change the amount of space between words.  See also the
-indentation commands in section @ref[indentation].
-
-@defcom[com "Just One Space", bind (M-|)]
-@index[whitespace, manipulation]@index[indentation, manipulation]This
-command deletes all whitespace characters before and after the point and then
-inserts one space.  If a prefix argument is supplied, then that number of
-spaces is inserted.
-@enddefcom
-
-@defcom[com "Delete Horizontal Space", bind (M-\)]
-This command deletes all blank characters around the point.
-@enddefcom
-
-@defcom[com "Delete Blank Lines", bind (C-x C-o)]
-This command deletes all blank lines surrounding the current line, leaving the
-point on a single blank line.  If the point is already on a single blank line,
-then that line is deleted.  If the point is on a non-blank line, then all blank
-lines immediately following that line are deleted.  This command is often used
-to clean up after @comref[Open Line].
-@enddefcom
-
-@section[Filtering]
-
-@i[Filtering] is a simple way to perform a fairly arbitrary transformation
-on text.  Filtering text replaces the string in each line with the result
-of applying a @llisp function of one argument to that string.  The function must 
-neither destructively modify the argument nor the return value.  It is an
-error for the function to return a string containing newline characters.
-
-@defcom[com "Filter Region"]
-This function prompts for an expression which is evaluated to obtain a
-function to be used to filter the text in the region.  For example, to
-capitalize all the words in the region one could respond:
-@begin[programexample]
-Function: #'@comment<>string-capitalize
-@end[programexample]
-Since the function may be called many times, it should probably be
-compiled.  Functions for one-time use can be compiled using the compile
-function as in the following example which removes all the semicolons on any line
-which contains the string "@f[PASCAL]":
-@begin[programexample]
-Function: (compile nil '(lambda (s)
-			  (if (search "PASCAL" s)
-			      (remove #\; s)
-			      s)))
-@end[programexample]
-@enddefcom
-
-@section[Searching and Replacing]
-@index[searching]@index[replacing]
-Searching for some string known to appear in the text is a commonly used method
-of moving long distances in a file.  Replacing occurrences of one pattern with
-another is a useful way to make many simple changes to text.  @hemlock provides
-powerful commands for doing both of these operations.
-
-@defhvar[var "String Search Ignore Case", val {t}]
-@index[case sensitivity]
-This variable determines the kind of search done by searching and replacing
-commands.  
-@enddefhvar
-
-@defcom[com "Incremental Search", bind {C-s}]
-@defcom1[com "Reverse Incremental Search", bind {C-r}]
-@hid[Incremental Search] searches for an occurrence of a string after the
-current point.  It is known as an incremental search because it reads
-key-events form the keyboard one at a time and immediately searches for the
-pattern of corresponding characters as you type.  This is useful because
-it is possible to initially type in a very short pattern and then add more
-characters if it turns out that this pattern has too many spurious matches.
-
-This command dispatches on the following key-events as sub-commands:
-@begin[description]
-@binding[C-s]@\
- Search forward for an occurrence of the current pattern.  This can be used
-repeatedly to skip from one occurrence of the pattern to the next, or it can be
-used to change the direction of the search if it is currently a reverse search.
-If @binding[C-s] is typed when the search string is empty, then a search is
-done for the string that was used by the last searching command.
-
-@binding[C-r]@\
- Similar to @binding[C-s], except that it searches backwards.
-
-@binding[Delete, Backspace]@\
- Undoes the effect of the last key-event typed.  If that key-event simply added
-to the search pattern, then this removes the character from the pattern, moving
-back to the last match found before entering the removed character.  If the
-character was a @binding[C-s] or @binding[C-r], then this moves back to the
-previous match and possibly reverses the search direction.
-
-@binding[C-g]@\
- If the search is currently failing, meaning that there is no occurrence of the
-search pattern in the direction of search, then @binding[C-g] deletes enough
-characters off the end of the pattern to make it successful.  If the search
-is currently successful, then @binding[C-g] causes the search to be aborted,
-leaving the point where it was when the search started.  Aborting the search
-inhibits the saving of the current search pattern as the last search string.
-
-@binding[Escape]@\
- Exit at the current position in the text, unless the search string is empty,
-in which case a non-incremental string search is entered.
-
-@binding[C-q]@\
- Search for the character corresponding to the next key-event, rather than
-treating it as a command.
-@end[description]
-Any key-event not corresponding to a graphic character, except those just
-described, causes the search to exit.  @hemlock then uses the key-event in it
-normal command interpretation.
-
-For example, typing @binding[C-a] will exit the search @i[and] go to the
-beginning of the current line.  When either of these commands successfully
-exits, they push the starting position (before the search) on the mark stack.
-If the current region was active when the search started, this foregoes pushing
-a mark.
-@enddefcom
-
-@defcom[com "Forward Search", bind (M-s)]
-@defcom1[com "Reverse Search", bind (M-r)]
-These commands do a normal dumb string search, prompting for the search
-string in a normal dumb fashion.  One reason for using a non-incremental
-search is that it may be faster since it is possible to specify a long
-search string from the very start.  Since @hemlock uses the Boyer--Moore
-search algorithm, the speed of the search increases with the size of the
-search string.
-When either of these commands successfully exits, they push the starting
-position (before the search) on the mark stack.  This is inhibited when the
-current region is active.
-@enddefcom
-
-@defcom[com "Query Replace", bind (M-%)]
-This command prompts in the echo area for a target string and a replacement
-string.  It then searches for an occurrence of the target after the point.
-When it finds a match, it prompts for a key-event indicating what action to
-take.  The following are valid responses:
-@begin[description]
-@binding[Space, y]@\
- Replace this occurrence of the target with the replacement string, and search
-again.
-
-@binding[Delete, Backspace, n]@\
- Do not replace this occurrence, but continue the search.
-
-@binding[!]@\
- Replace this and all remaining occurrences without prompting again.
-
-@binding[.]@\
- Replace this occurrence and exit.
-
-@binding[C-r]@\
- Go into a recursive edit (see page @pageref[recursive-edits]) at the current
-location.  The search will be continued from wherever the point is left when
-the recursive edit is exited.  This is useful for handling more complicated
-cases where a simple replacement will not achieve the desired effect.
-
-@binding[Escape]@\
- Exit without doing any replacement.
-
-@binding[Home, C-_, ?, h]@\
- Print a list of all the options available.
-@end[description]
-Any other key-event causes the command to exit, returning the key-event to the
-input stream; thus, @hemlock will interpret it normally for a command binding.
-
-When the current region is active, this command uses it instead of the region
-from point to the end of the buffer.  This is especially useful when you expect
-to use the @binding[!] option.
-
-If the replacement string is all lowercase, then a heuristic is used that
-attempts to make the case of the replacement the same as that of the
-particular occurrence of the target pattern.  If "@f[foo]" is being
-replaced with "@f[bar]" then "@f[Foo]" is replaced with "@f[Bar]" and
-"@f[FOO]" with "@f[BAR]".
-
-This command may be undone with @hid[Undo], but its undoing may not be undone.
-On a successful exit from this command, the starting position (before the
-search) is pushed on the mark stack.
-@enddefcom
-
-@defhvar[var "Case Replace", val {t}]
-@index[case sensitivity]
-If this variable is true then the case preserving heuristic in
-@hid[Query Replace] is enabled, otherwise all replacements are done with
-the replacement string exactly as specified.
-@enddefhvar
-
-@defcom[com "Replace String"]
-This command is the same as @hid[Query Replace] except it operates without ever
-querying the user before making replacements.  After prompting for a target and
-replacement string, it replaces all occurrences of the target string following
-the point.  If a prefix argument is specified, then only that many occurrences
-are replaced.  When the current region is active, this command uses it instead
-of the region from point to the end of the buffer.
-@enddefcom
-
-@defcom[com "List Matching Lines"]
-This command prompts for a search string and displays in a pop-up window all
-the lines containing the string that are after the point.  If a prefix argument
-is specified, then this displays that many lines before and after each matching
-line.  When the current region is active, this command uses it instead of the
-region from point to the end of the buffer.
-@enddefcom
-
-@defcom[com "Delete Matching Lines"]
-@defcom1[com "Delete Non-Matching Lines"]
-@hid[Delete Matching Lines] prompts for a search string and deletes all lines
-containing the string that are after the point.  Similarly, @hid[Delete
-Non-Matching Lines] deletes all lines following the point that do not contain
-the specified string.  When the current region is active, these commands uses
-it instead of the region from point to the end of the buffer.
-@enddefcom
-
-
-@section[Page Commands]
-@index[page commands]
-Another unit of text recognized by @hemlock is the page.  A @i[page] is a piece
-of text delimited by formfeeds (@f[^L]'s.)  The first non-blank line after the
-page marker is the @i[page title].  The page commands are quite useful when
-logically distinct parts of a file are put on separate pages.  See also
-@comref[Count Lines Page].  These commands only recognize @f[^L]'s at the
-beginning of a lines, so those quoted in string literals do not get in the way.
-
-@defcom[com "Previous Page", bind (C-x @bf<]>)]
-@defcom1[com "Next Page", bind (C-x [)]
-@hid[Previous Page] moves the point to the previous page delimiter, while
-@hid[Next Page] moves to the next one.  Any page delimiters next to the point
-are skipped.  The prefix argument is a repeat count.
-@enddefcom
-
-@defcom[com "Mark Page", bind (C-x C-p)]
-This command puts the point at the beginning of the current page and the mark
-at the end.  If given a prefix argument, marks the page that many pages from the
-current one.
-@enddefcom
-
-@defcom[com "Goto Page"]
-This command does various things, depending on the prefix argument:
-@begin[description]
-@i[no argument]@\goes to the next page.
-
-@i[positive argument]@\goes to an absolute page number, moving that many pages
-from the beginning of the file.
-
-@i[zero argument]@\prompts for string and goes to the page with that string in
-its title.  Repeated invocations in this manner continue searching from the
-point of the last find, and a first search with a particular pattern pushes a
-buffer mark.
-
-@i[negative argument]@\moves backward by that many pages, if possible.
-@end[description]
-@enddefcom
-
-@defcom[com "View Page Directory"]
-@defcom1[com "Insert Page Directory"]
-@hid[View Page Directory] uses a pop-up window to display the number and title
-of each page in the current buffer.  @hid[Insert Page Directory] is the same
-except that it inserts the text at the beginning of the buffer.  With a prefix
-argument, @hid[Insert Page Directory] inserts at the point.
-@enddefcom
-
-
-@section[Counting Commands]
-
-@defcom[com "Count Words"]
-This command counts the number of words from the current point to the end of
-the buffer, displaying a message in the echo area.  When the current region is
-active, this uses it instead of the region from the point to the end of the
-buffer.  Word delimiters are determined by the current major mode.
-@enddefcom
-
-@defcom[com "Count Lines"]
-This command counts the number of lines from the current point to the end of
-the buffer, displaying a message in the echo area.  When the current region is
-active, this uses it instead of the region from the point to the end of the
-buffer.  
-@enddefcom
-
-@defcom[com "Count Lines Page", bind (C-x l)]
-This command displays the number of lines in the current page and the number of
-lines before and after the point within that page.  If given a prefix argument,
-the entire buffer is counted instead of just the current page.
-@enddefcom
-
-@defcom[com "Count Occurrences"]
-This command prompts for a search string and displays the number of occurrences
-of that string in the text from the point to the end of the buffer.  When the
-current region is active, this uses it instead of the region from the point to
-the end of the buffer.
-@enddefcom
-
-
-@section[Registers]
-@index[registers]
-Registers allow you to save a text position or chunk of text associated with a
-key-event.  This is a convenient way to repeatedly access a commonly-used
-location or text fragment.  The concept and key bindings should be familiar to
-TECO users.
-
-@defcom[com "Save Position", bind (C-x s)]
-@defcom1[com "Jump to Saved Position", bind (C-x j)]
-These commands manipulate registers containing textual positions.  
-@hid[Save Position] prompts for a register and saves the location of the
-current point in that register.  @hid[Jump to Saved Position] prompts for a
-register and moves the point to the position saved in that register.  If the
-saved position is in a different buffer, then that buffer is made current.
-@enddefcom
-
-@defcom[com "Put Register", bind (C-x x)]
-@defcom1[com "Get Register", bind (C-x g)]
-These commands manipulate registers containing text.  @hid[Put Register]
-prompts for a register and puts the text in the current region into the
-register.  @hid[Get Register] prompts for a register and inserts the text in
-that register at the current point.
-@enddefcom
-
-@defcom[com "List Registers"]
-@defcom1[com "Kill Register"]
-@hid[List Registers] displays a list of all the currently defined registers in
-a pop-up window, along with a brief description of their contents.  
-@hid[Kill Register] prompts for the name of a register and deletes that
-register.
-@enddefcom
diff --git a/docs/hem/user/intro.mss b/docs/hem/user/intro.mss
deleted file mode 100644
index 3ee6ceeac039c0005d16d4470e31336d742126f5..0000000000000000000000000000000000000000
--- a/docs/hem/user/intro.mss
+++ /dev/null
@@ -1,1127 +0,0 @@
-@comment{-*- Dictionary: target:scribe/hem/hem; Mode: spell; Package: Hemlock -*-}
-@chap[Introduction]
-
-@hemlock is a text editor which follows in the tradition of @emacs
-and the Lisp Machine editor ZWEI.  In its basic form, @hemlock has almost
-the same command set as ITS/TOPS-20 @emacs@foot[In this document, "Emacs"
-refers to this, the original version, rather than to any of the large
-numbers of text editors inspired by it which may go by the same name.],
-and similar features such as multiple windows and extended commands, as
-well as built in documentation features.  The reader should bear in mind
-that whenever some powerful feature of @hemlock is described, it has
-probably been directly inspired by @emacs.
-
-This manual describes @hemlock@comment{}'s commands and other user visible
-features and then goes on to tell how to make simple customizations.  For
-complete documentation of the @hemlock primitives with which commands are
-written, the @i[Hemlock Command Implementor's Manual] is also available.
-
-
-
-@section[The Point and The Cursor]
-
-@index[point]
-@index[cursor]
-The @i[point] is the current focus of editing activity.  Text typed in by the
-user is inserted at the point.  Nearly all commands use the point as a
-indication of what text to examine or modify.  Textual positions in @hemlock
-are between characters.  This may seem a bit curious at first, but it is
-necessary since text must be inserted between characters.  Although the point
-points between characters, it is sometimes said to point @i[at] a character, in
-which case the character after the point is referred to.
-
-The @i[cursor] is the visible indication of the current focus of attention: a
-rectangular blotch under @windows, or the hardware cursor on a terminal.  The
-cursor is usually displayed on the character which is immediately after the
-point, but it may be displayed in other places.  Wherever the cursor is
-displayed it indicates the current focus of attention.  When input is being
-prompted for in the echo area, the cursor is displayed where the input is to
-go.  Under @windows the cursor is only displayed when @hemlock is waiting
-for input.
-
-
-@section[Notation]
-
-There are a number of notational conventions used in this manual which need
-some explanation.
-
-
-@subsection[Key-events]
-
-@label[key-events]
-@index[key-events, notation]
-@index[bits, key-event]
-@index[modifiers, key-event]
-The canonical representation of editor input is a @i[key-event].  When you type
-on the keyboard, @hemlock receives key-events.  Key-events have names for their
-basic form, and we refer to this name as a @i[keysym].  This manual displays
-keysyms in a @bf[Bold] font.  For example, @bf[a] and @bf[b] are the keys that
-normally cause the editor to insert the characters @i[a] and @i[b].
-
-Key-events have @i[modifiers] or @i[bits] indicating a special interpretation
-of the root key-event.  Although the keyboard places limitations on what
-key-events you can actually type, @hemlock understands arbitrary combinations
-of the following modifiers: @i[Control], @i[Meta], @i[Super], @i[Hyper],
-@i[Shift], and @i[Lock].  This manual represents the bits in a key-event by
-prefixing the keysym with combinations of @bf[C-], @bf[M-], @bf[S-], @bf[H-],
-@bf[Shift-], and @bf[Lock].  For example, @bf[a] with both the control and meta
-bits set appears as @bf[C-M-a].  In general, ignore the shift and lock
-modifiers since this manual never talks about keysyms that explicitly have
-these bits set; that is, it may talk about the key-event @bf[A], but it would
-never mention @bf[Shift-a].  These are actually distinct key-events, but
-typical input coercion turns presents @hemlock with the former, not the latter.
-
-Key-event modifiers are totally independent of the keysym.  This may be new to
-you if you are used to thinking in terms of ASCII character codes.  For
-example, with key-events you can distinctly identify both uppercase and
-lowercase keysyms with the control bit set; therefore, @bf[C-a] and @bf[C-A]
-may have different meanings to @hemlock.
-
-Some keysyms' names consist of more than a single character, and these usually
-correspond to the legend on the keyboard.  For example, some keyboards let you
-enter @bf[Home], @bf[Return], @bf[F9], etc.
-
-In addition to a keyboard, you may have a mouse or pointer device.  Key-events
-also represent this kind of input.  For example, the down and up transitions of
-the @i[left button] correspond to the @bf[Leftdown] and @bf[Leftup] keysyms.
-
-See sections @ref[key-bindings], @ref[using-x], @ref[using-terminals]
-
-
-@subsection[Commands]
-
-@index[commands]@label[commands]Nearly everything that can be done in
-@hemlock is done using a command.  Since there are many things worth
-doing, @hemlock provides many commands, currently nearly two hundred.
-Most of this manual is a description of what commands exist, how they are
-invoked, and what they do.  This is the format of a command's
-documentation:
-
-@defcom[com "Sample Command", bind (C-M-q, C-`)]
-@begin[quotation, facecode i, leftmargin 8ems, rightmargin 3.5ems,
-below 0.8 lines]
-This command's name is @hid[Sample Command], and it is bound to
-@w(@bf(C-M-q)) and @bf[C-`], meaning that typing either of these will
-invoke it.  After this header comes a description of what the command does:
-@end[quotation]
-
-This command replaces all occurrences following the point of the string
-"@f[Pascal]" with the string "@f[Lisp]".  If a prefix argument is supplied,
-then it is interpreted as the maximum number of occurrences to replace.  If
-the prefix argument is negative then the replacements are done backwards
-from the point.
-@comment<
-@begin[quotation, facecode i, leftmargin 8ems, rightmargin 3.5ems,
-above 0.8 lines, below 0.8 lines]
-Toward the end of the description there may be information primarily of
-interest to customizers and command implementors.  If you don't understand
-this information, don't worry, the writer probably forgot to speak English.
-@end[quotation]
-
-@b[Arguments:]
-@begin[description]
-@i[target]@\The string to replace with "@f[Lisp]".
-
-@i[buffer]@\The buffer to do the replacement in.  If this is @f[:all] then
-the replacement is done in all buffers.
-@end[description]>
-@enddefcom
-
-
-@subsection[Hemlock Variables]
-
-@index[variables, hemlock]@hemlock variables supply a simple
-customization mechanism by permitting commands to be parameterized.  For
-details see page @pageref[vars].
-
-@defhvar[var "Sample Variable", val {36}]
-@begin[quotation, facecode i, leftmargin 8ems, below 0.8 lines]
-The name of this variable is @hid[Sample Variable] and its initial value is
-36.
-@end[quotation]
-This variable sets a lower limit on the number of replacements that be done
-by @hid[Sample Command].  If the prefix argument is supplied, and smaller
-in absolute value than @hid[Sample Variable], then the user is prompted as
-to whether that small a number of occurrences should be replaced, so as to
-avoid a possibly disastrous error.
-@enddefhvar
-
-
-@section[Invoking Commands]
-@index[invocation, command]
-In order to get a command to do its thing, it must be invoked.  The user can do
-this two ways, by typing the @i[key] to which the command is @i[bound] or by
-using an @i[extended command].  Commonly used commands are invoked via their
-key bindings since they are faster to type, while less used commands are
-invoked as extended commands since they are easier to remember.
-
-
-@subsection[Key Bindings]
-@index[bindings, key]
-@index[key bindings]
-@label[key-bindings]
-A key is a sequence of key-events (see section @ref[key-events]) typed on the
-keyboard, usually only one or two in length.  Sections @ref[using-x] and
-@ref[using-terminals] contain information on particular input devices.
-
-When a command is bound to a key, typing the key causes @hemlock to invoke the
-command.  When the command completes its job, @hemlock returns to reading
-another key, and this continually repeats.
-
-Some commands read key-events interpreting them however each command desires.
-When commands do this, key bindings have no effect, but you can usually abort
-@hemlock whenever it is waiting for input by typing @binding[C-g] (see section
-@ref[aborting]).  You can usually find out what options are available by typing
-@binding[C-_] or @binding[Home] (see section @ref[help]).
-
-The user can easily rebind keys to different commands, bind new keys to
-commands, or establish bindings for commands never bound before (see section
-@ref[binding-keys]).
-
-In addition to the key bindings explicitly listed with each command, there are
-some implicit bindings created by using key translations@foot[Key translations
-are documented in the @i[Hemlock Command Implementor's Manual].].  These
-bindings are not displayed by documentation commands such as @hid[Where Is].
-By default, there are only a few key translations.  The modifier-prefix
-characters @bf[C-^], @bf[Escape], @bf[C-z], or @bf[C-c] may be used when typing
-keys to convert the following key-event to a control, meta, control-meta, or
-hyper key-event.  For example, @bf[C-x Escape b] invokes the same commands as
-@bf[C-x M-b], and @bf[C-z u] is the same as @bf[C-M-u].  This allows user to
-type more interesting keys on limited keyboards that lack control, meta, and
-hyper keys.
-@index[bit-prefix key-events]
-
-
-@defhvar[var "Key Echo Delay", val {1.0}]
-A key binding may be composed of several key-events, especially when you enter
-it using modifier-prefix key-events.  @hemlock provides feedback for partially
-entered keys by displaying the typed key-events in the echo area.  In order to
-avoid excessive output and clearing of the echo area, this display is delayed
-by @hid[Key Echo Delay] seconds.  If this variable is set to @nil, then
-@hemlock foregoes displaying initial subsequences of keys.
-@enddefhvar
-
-
-@subsection[Extended Commands]
-
-@index[commands, extended]A command is invoked as an extended command by
-typing its name to the @hid[Extended Command] command, which is invoked
-using its key binding, @binding[M-x].
-
-@defcom[com "Extended Command", bind {M-x}]
-This command prompts in the echo area for the name of a command, and then
-invokes that command.  The prefix argument is passed through to the command
-invoked.  The command name need not be typed out in full, as long as enough
-of its name is supplied to uniquely identify it.  Completion is available
-using @binding[Escape] and @binding[Space], and a list of possible completions
-is given by @binding[Home] or @binding[C-_].
-@enddefcom
-
-
-@section[The Prefix Argument]
-
-@index[prefix argument]The prefix argument is an integer argument which
-may be supplied to a command.  It is known as the prefix argument because
-it is specified by invoking some prefix argument setting command
-immediately before the command to be given the argument.  The following
-statements about the interpretation of the prefix argument are true:
-@begin[itemize]
-When it is meaningful, most commands interpret the prefix argument as a
-repeat count, causing the same effect as invoking the command that many
-times.
-
-When it is meaningful, most commands that use the prefix argument interpret
-a negative prefix argument as meaning the same thing as a positive
-argument, but the action is done in the opposite direction.
-
-Most commands treat the absence of a prefix argument as meaning the same
-thing as a prefix argument of one.
-
-Many commands ignore the prefix argument entirely.
-
-Some commands do none of the above.
-@end[itemize]
-The following commands are used to set the prefix argument:
-
-@defcom[com "Argument Digit", stuff (bound to all control or meta digits)]
-Typing a number using this command sets the prefix argument to that number,
-for example, typing @binding[M-1 M-2] sets the prefix argument to twelve.
-@enddefcom
-
-@defcom[com "Negative Argument", bind {M--}]
-This command negates the prefix argument, or if there is none, sets it to
-negative one.  For example, typing @binding[M-- M-7] sets the prefix
-argument to negative seven.
-@enddefcom
-
-@defcom[com "Universal Argument", bind {C-u}]
-@defhvar1[var "Universal Argument Default", val {4}]
-This command sets the prefix argument or multiplies it by four.  If digits
-are typed immediately afterward, they are echoed in the echo area, and the
-prefix argument is set to the specified number.  If no digits are typed
-then the prefix argument is multiplied by four.  @binding[C-u - 7] sets the
-prefix argument to negative seven.  @binding[C-u C-u] sets the prefix
-argument to sixteen.  @binding[M-4 M-2 C-u] sets the prefix argument to one
-hundred and sixty-eight.  @binding[C-u M-0] sets the prefix argument to
-forty.
-
-@hid[Universal Argument Default] determines the default value and multiplier
-for the @hid[Universal Argument] command.
-@enddefcom
-
-
-@section[Modes]
-
-@label[modes]@index[modes]A mode provides a way to change @hemlock@comment{}'s
-behavior by specifying a modification to current key bindings, values of
-variables, and other things.  Modes are typically used to adjust @hemlock
-to suit a particular editing task, e.g. @hid[Lisp] mode is used for editing
-@llisp code.
-
-Modes in @hemlock are not like modes in most text editors; @hemlock is really a
-"modeless" editor.  There are two ways that the @hemlock mode concept differs
-from the conventional one:
-@begin[enumerate]
-Modes do not usually alter the environment in a very big way, i.e. replace
-the set of commands bound with another totally disjoint one.  When a mode
-redefines what a key does, it is usually redefined to have a slightly
-different meaning, rather than a totally different one.  For this reason,
-typing a given key does pretty much the same thing no matter what modes are
-in effect.  This property is the distinguishing characteristic of a
-modeless editor.
-
-Once the modes appropriate for editing a given file have been chosen, they
-are seldom, if ever, changed.  One of the advantages of modeless editors is
-that time is not wasted changing modes.
-@end[enumerate]
-
-@index[major mode]A @i[major mode] is used to make some big change in the
-editing environment.  Language modes such as @hid[Pascal] mode are major
-modes.  A major mode is usually turned on by invoking the command
-@i{mode-name}@hid[ Mode] as an extended command.  There is only one major
-mode present at a time.  Turning on a major mode turns off the one that is
-currently in effect.
-
-@index[minor mode]A @i[minor mode] is used to make a small change in the
-environment, such as automatically breaking lines if they get too long.
-Unlike major modes, any number of minor modes may be present at once.
-Ideally minor modes should do the "right thing" no matter what major and
-minor modes are in effect, but this is may not be the case when key
-bindings conflict.
-
-Modes can be envisioned as switches, the major mode corresponding to one big
-switch which is thrown into the correct position for the type of editing being
-done, and each minor mode corresponding to an on-off switch which controls
-whether a certain characteristic is present.
-
-@defcom[com "Fundamental Mode"]
-This command puts the current buffer into @hid[Fundamental] mode.
-@hid[Fundamental] mode is the most basic major mode: it's the next best thing
-to no mode at all.
-@enddefcom
-
-
-@section[Display Conventions]
-@index[display conventions]
-There are two ways that @hemlock displays information on the screen; one is
-normal @i[buffer display], in which the text being edited is shown on the
-screen, and the other is a @i[pop-up window].
-
-
-@subsection[Pop-Up Windows]
-@index[pop-up windows]
-@index[random typeout]
-@label[pop-up]
-Some commands print out information that is of little permanent value, and
-these commands use a @i[pop-up] window to display the information.  It is known
-as a @i[pop-up] window because it temporarily appears on the screen overlaying
-text already displayed.  Most commands of this nature can generate their output
-quickly, but in case there is a lot of output, or the user wants to repeatedly
-refer to the same output while editing, @hemlock saves the output in a buffer.
-Different commands may use different buffers to save their output, and we refer
-to these as @i[random typeout] buffers.
-
-If the amount of output exceeds the size of the pop-up window, @Hemlock
-displays the message @w<"@f[--More--]"> after each window full.  The following
-are valid responses to this prompt:
-@Begin[Description]
-@bf[Space], @bf[y]@\
- Display the next window full of text.
-
-@bf[Delete], @bf[Backspace], @bf[n]@\
- Abort any further output.
-
-@bf[Escape], @bf[!]@\
- Remove the window and continue saving any further output in the buffer.
-
-@bf[k]@\
- This is the same as @bf[!] or @bf[escape], but @hemlock makes a normal window
-over the pop-up window.  This only works on bitmap devices.
-@End[Description]
-Any other input causes the system to abort using the key-event to determine
-the next command to execute.
-
-When the output is complete, @hemlock displays the string @w<"@f[--Flush--]">
-in the pop-up window's modeline, indicating that the user may flush the
-temporary display.  Typing any of the key-events described above removes the
-pop-up window, but typing @bf[k] still produces a window suitable for normal
-editing.  Any other input also flushes the display, but @hemlock uses the
-key-event to determine the next command to invoke.
-
-@defcom[com "Select Random Typeout Buffer", bind {H-t}]
-This command makes the most recently used random typeout buffer the current
-buffer in the current window.
-@enddefcom
-
-Random typeout buffers are always in @hid[Fundamental] mode.
-
-
-@subsection[Buffer Display]
-@index[buffer, display]
-@index[display, buffer]
-
-If a line of text is too long to fit within the screen width it is @i[wrapped],
-with @hemlock displaying consecutive pieces of the text line on as many screen
-lines as needed to hold the text.  @hemlock indicates a wrapped line by placing
-a line-wrap character in the last column of each screen line.  Currently, the
-line-wrap character is an exclamation point (@f[!]).  It is possible for a line
-to wrap off the bottom of the screen or on to the top.
-
-@hemlock wraps screen lines when the line is completely full regardless of the
-line-wrap character.  Most editors insert the line-wrap character and wrap a
-single character when a screen line would be full if the editor had avoided
-wrapping the line.  In this situation, @hemlock would leave the screen line
-full.  This means there are always at least two characters on the next screen
-line if @hemlock wraps a line of display.  When the cursor is at the end of a
-line which is the full width of the screen, it is displayed in the last column,
-since it cannot be displayed off the edge.
-
-@hemlock displays most characters as themselves, but it treats some
-specially:
-@begin[itemize]
-Tabs are treated as tabs, with eight character tab-stops.
-
-Characters corresponding to ASCII control characters are printed as
-@f[^]@i[char]; for example, a formfeed is @f[^L].
-
-Characters with the most-significant bit on are displayed as
-@f[<]@i[hex-code]@f[>]; for example, @f[<E2>].
-@end[itemize]
-Since a character may be displayed using more than one printing character,
-there are some positions on the screen which are in the middle of a character.
-When the cursor is on a character with a multiple-character representation,
-@hemlock always displays the cursor on the first character.
-
-
-@subsection[Recentering Windows]
-@index[recentering windows]
-@index[windows, recentering]
-
-When redisplaying the current window, @hemlock makes sure the current point is
-visible.  This is the behavior you see when you are entering text near the
-bottom of the window, and suddenly redisplay shifts your position to the
-window's center.
-
-Some buffers receive input from streams and other processes, and you might have
-windows displaying these.  However, if those windows are not the current
-window, the output will run off the bottom of the windows, and you won't be
-able to see the output as it appears in the buffers.  You can change to a
-window in which you want to track output and invoke the following command to
-remedy this situation.
-
-@defcom[com "Track Buffer Point"]
-This command makes the current window track the buffer's point.  This means
-that each time Hemlock redisplays, it will make sure the buffer's point is
-visible in the window.  This is useful for windows that are not current and
-that display buffer's that receive output from streams coming from other
-processes.
-@enddefcom
-
-
-@subsection[Modelines]
-@label[modelines]
-@index[modeline]
-A modeline is the line displayed at the bottom of each window where @hemlock
-shows information about the buffer displayed in that window.  Here is a typical
-modeline:
-@begin[programexample]
-Hemlock USER: (Fundamental Fill)  /usr/slisp/hemlock/user.mss
-@end[programexample]
-This tells us that the file associated with this buffer is
-"@f[/usr/slisp/hemlock/user.mss]", and the @hid[Current Package] for Lisp
-interaction commands is the @f["USER"] package.  The modes currently present
-are @hid[Fundamental] and @hid[Fill]; the major mode is always displayed first,
-followed by any minor modes.  If the buffer has no associated file, then the
-buffer name will be present instead:
-@begin[programexample]
-Hemlock PLAY: (Lisp)  Silly:
-@end[programexample]
-In this case, the buffer is named @hid[Silly] and is in @hid[Lisp] mode.  The
-user has set @hid[Current Package] for this buffer to @f["PLAY"].
-
-@defhvar[var "Maximum Modeline Pathname Length", val {nil}]
-This variable controls how much of a pathname @hemlock displays in a modeline.
-Some distributed file systems can have very long pathnames which leads to the
-more particular information in a pathname running off the end of a modeline.
-When set, the system chops off leading directories until the name is less than
-the integer value of this variable.  Three dots, @f[...], indicate a truncated
-name.  The user can establish this variable buffer locally with the
-@hid[Defhvar] command.
-@enddefhvar
-
-If the user has modified the buffer since the last time it was read from or
-save to a file, then the modeline contains an asterisk (@f[*]) between the
-modes list and the file or buffer name:
-@begin[programexample]
-Hemlock USER: (Fundamental Fill)  * /usr/slisp/hemlock/user.mss
-@end[programexample]
-This serves as a reminder that the buffer should be saved eventually.
-
-@index[status line]
-There is a special modeline known as the @i[status line] which appears as the
-@hid[Echo Area]'s modeline.  @Hemlock and user code use this area to display
-general information not particular to a buffer @dash recursive edits, whether
-you just received mail, etc.
-
-
-@section[Use with X Windows]
-@label[using-x]
-@index[X windows, use with]
-You should use @hemlock on a workstation with a bitmap display and a windowing
-system since @hemlock makes good use of a non-ASCII device, mouse, and the
-extra modifier keys typically associated with workstations.  This section
-discusses using @hemlock under X windows, the only supported windowing system.
-
-
-@subsection[Window Groups]
-@index[window management]
-@label[groups]
-@hemlock manages windows under X in groups.  This allows @hemlock to be more
-sophisticated in its window management without being rude in the X paradigm of
-screen usage.  With window groups, @hemlock can ignore where the groups are,
-but within a group, it can maintain the window creation and deletion behavior
-users expect in editors without any interference from window managers.
-
-Initially there are two groups, a main window and the @hid[Echo Area].  If you
-keep a pop-up display, see section @ref[pop-up], @hemlock puts the window it
-creates in its own group.  There are commands for creating new groups.
-
-@hemlock only links windows within a group for purposes of the @hid[Next
-Window], @hid[Previous Window], and @hid[Delete Next Window] commands.  To move
-between groups, you must use the @hid[Point to Here] command bound to the
-mouse.  
-
-Window manager commands can reshape and move groups on the screen.
-
-
-@subsection[Event Translation]
-@index[keyboard use under X]
-@index[translation of keys under X]
-Each X key event is translated into a canonical input representation, a
-key-event.  The X key event consists of a scan-code and modifier bits, and
-these translate to an X keysym.  This keysym and the modifier bits map to a
-key-event.
-
-If you type a key with a shift key held down, this typically maps to a distinct
-X keysym.  For example, the shift of @bf[3] is @bf[#], and these have different
-X keysyms.  Some keys map to the same X keysym regardless of the shift bit,
-such as @bf[Tab], @bf[Space], @bf[Return], etc.  When the X lock bit is on, the
-system treats this as a caps-lock, only mapping keysyms for lowercase letters
-to shifted keysyms.
-
-The key-event has a keysym and a field of bits.  The X keysyms map directly to
-the key-event keysyms.  There is a distinct mapping for each CLX modifier bit
-to a key-event bit.  This tends to eliminate shift and lock modifiers, so
-key-events usually only have control, meta, hyper, and super bits on.  Hyper
-and super usually get turned on with prefix key-events that set them on the
-following key-event, but you can turn certain keys on the keyboard into hyper
-and super keys.  See the X manuals and the @i[Hemlock Command Implementor's
-Manual] for details.
-
-The system also maps mouse input to key-events.  Each mouse button has distinct
-key-event keysyms for whether the user pressed or released it.  For
-convenience, @hemlock makes use of an odd property of converting mouse events
-to key-events.  If you enter a mouse event with the shift key held down,
-@hemlock sees the key-event keysym for the mouse event, but the key-event has
-the super bit turned on.  For example, if you press the left button with the
-shift key pressed, @hemlock sees @bf[S-Leftdown].
-
-Note that with the two button mouse on the IBM RT PC, the only way to to send
-@bf[Middledown] is to press both the left and right buttons simultaneously.
-This is awkward, and it often confuses the X server.  For this reason, the
-commands bound to the middle button are also bound to the shifted left button,
-@bf[S-Leftdown], which is much easier to type.
-
-
-@subsection[Cut Buffer Commands]
-@index[cutting]@index[pasting] These commands allow the X cut buffer to be
-used from @hemlock .  Although @hemlock can cut arbitrarily large regions,
-a bug in the standard version 10 xterm prevents large regions from being
-pasted into an xterm window.
-
-@defcom[com "Region to Cut Buffer", bind {M-Insert}]
-@defcom1[com "Insert Cut Buffer", bind {Insert}]
-These commands manipulate the X cut buffer.  @hid[Region to Cut Buffer] puts
-the text in the region into the cut buffer.  @hid[Insert Cut Buffer] inserts
-the contents of the cut buffer at the point.
-@enddefcom
-
-@subsection[Redisplay and Screen Management]
-
-These variables control a number of the characteristics of @hemlock bitmap
-screen management.
-
-@defhvar[var "Bell Style", val {:border-flash}]
-@defhvar1[var "Beep Border Width", val {20}]
-@hid[Bell Style] determines what beeps do in @hemlock.  Acceptable values are
-@kwd[border-flash], @kwd[feep], @kwd[border-flash-and-feep], @kwd[flash],
-@kwd[flash-and-feep], and @nil (do nothing).
-
-@hid[Beep Border Width] is the width in pixels of the border flashed by border
-flash beep styles.
-@enddefhvar
-
-@defhvar[var "Reverse Video", val {nil}]
-If this variable is true, then @hemlock paints white on black in window
-bodies, black on white in modelines.
-@enddefhvar
-
-@defhvar[var "Thumb Bar Meter", val {t}]
-If this variable is true, then windows will be created to be displayed with a
-ruler in the bottom border of the window.
-@enddefhvar
-
-@defhvar[var "Set Window Autoraise", val {:echo-only}]
-When true, changing the current window will automatically raise the new current
-window.  If the value is @kwd[echo-only], then only the echo area window will
-be raised automatically upon becoming current.
-@enddefhvar
-
-@defhvar[var "Default Initial Window Width", val {80}]
-@defhvar1[var "Default Initial Window Height", val {24}]
-@defhvar1[var "Default Initial Window X"]
-@defhvar1[var "Default Initial Window Y"]
-@defhvar1[var "Default Window Height", val {24}]
-@defhvar1[var "Default Window Width", val {80}]
-@index[window placement]
-@Hemlock uses the variables with "@hid[Initial]" in their names when it first
-starts up to make its first window.  The width and height are specified in
-character units, but the x and y are specified in pixels.  The other variables
-determine the width and height for interactive window creation, such as making
-a window with @comref[New Window].
-@enddefhvar
-
-@defhvar[var "Cursor Bitmap File", val {"library:hemlock.cursor"}]
-This variable determines where the mouse cursor bitmap is read from when
-@hemlock starts up.  The mask is found by merging this name with "@f[.mask]".
-This has to be a full pathname for the C routine.
-@enddefhvar
-
-
-@defhvar[var "Default Font"]
-This variable holds the string name of the font to be used for normal text
-display: buffer text, modelines, random typeout, etc.  The font is loaded at
-initialization time, so this variable must be set before entering @hemlock.
-When @nil, the display type is used to choose a font.
-@enddefhvar
-
-
-@section[Use With Terminals]
-@label[using-terminals]@index[terminals, use with] @hemlock can also be used
-with ASCII terminals and terminal emulators.  Capabilities that depend on
-@windows (such as mouse commands) are not available, but nearly everything else
-can be done.
-
-@subsection[Terminal Initialization]
-
-@index[terminal speed]
-@index[speed, terminal]
-@index[slow terminals]
-@index[incremental redisplay]
-For best redisplay performance, it is very important to set the terminal speed:
-@lisp
-stty 2400
-@endlisp
-Often when running @hemlock using TTY redisplay, Hemlock will actually be
-talking to a PTY whose speed is initialized to infinity.  In reality, the
-terminal will be much slower, resulting in @hemlock's output getting way ahead
-of the terminal.  This prevents @hemlock from briefly stopping redisplay to
-allow the terminal to catch up.  See also @hvarref<Scroll Redraw Ratio>.
-
-The terminal control sequences are obtained from the termcap database using the
-normal Unix conventions.  The @f["TERM"] environment variable holds the
-terminal type.  The @f["TERMCAP"] environment variable can be used to override
-the default termcap database (in @f["/etc/termcap"]).  The size of the terminal
-can be altered from the termcap default through the use of:
-@lisp
-stty rows @i{height} columns @i{width}
-@endlisp
-
-@subsection[Terminal Input]
-@index[ASCII keyboard translation]
-@index[bit-prefix key-events]
-@index[prefix key-events]
-@index[key-event, prefix]
-The most important limitation of a terminal is its input capabilities.  On a
-workstation with function keys and independent control, meta, and shift
-modifiers, it is possible to type 800 or so distinct single keystrokes.
-Although by default, @hemlock uses only a fraction of these combinations, there
-are many more than the 128 key-events available in ASCII.
-
-On a terminal, @hemlock attempts to translate ASCII control characters into the
-most useful key-event:
-@begin[itemize]
-On a terminal, control does not compose with shift.  If the control key is down
-when you type a letter keys, the terminal always sends one code regardless of
-whether the shift key is held.  Since @hemlock primarily binds commands to
-key-events with keysyms representing lowercase letters regardless of what bits
-are set in the key-event, the system translates the ASCII control codes to a
-keysym representing the appropriate lowercase characters.  This keysym then
-forms a key-event with the control bit set.  Users can type @bf[C-c] followed
-by an uppercase character to form a key-event with a keysym representing an
-uppercase character and bits with the control bit set.
-
-On a terminal, some of the named keys generate an ASCII control code.  For
-example, @f[Return] usually sends a @f[C-m].  The system translates these ASCII
-codes to a key-event with an appropriate keysym instead of the keysym named by
-the character which names the ASCII code.  In the above example, typing the
-@f[Return] key would generate a key-event with the @bf[Return] keysym and no
-bits.  It would NOT translate to a key-event with the @bf[m] keysym and the
-control bit.
-@end[itemize]
-
-Since terminals have no meta key, you must use the @bf[Escape] and @bf[C-Z]
-modifier-prefix key-events to invoke commands bound to key-events with the meta
-bit or meta and control bits set.  ASCII terminals cannot generate all
-key-events which have the control bit on, so you can use the @bf[C-^]
-modifier-prefix.  The @bf[C-c] prefix sets the hyper bit on the next key-event
-typed.
-
-When running @hemlock from a terminal @f[^\] is the interrupt key-event.
-Typing this will place you in the Lisp debugger.
-
-When using a terminal, pop-up output windows cannot be retained after the
-completion of the command.
-
-
-@subsection[Terminal Redisplay]
-
-Redisplay is substantially different on a terminal.  @Hemlock uses different
-algorithms, and different parameters control redisplay and screen management.
-
-Terminal redisplay uses the Unix termcap database to find out how to use a
-terminal.  @hemlock is useful with terminals that lack capabilities for
-inserting and deleting lines and characters, and some terminal emulators
-implement these operations very inefficiently (such as xterm).
-If you realize poor performance when scrolling, create a termcap entry that
-excludes these capabilities.
-
-@defhvar[var "Scroll Redraw Ratio", val {nil}]
-This is a ratio of "inserted" lines to the size of a window.  When this ratio
-is exceeded, insert/delete line terminal optimization is aborted, and every
-altered line is simply redrawn as efficiently as possible.  For example,
-setting this to 1/4 will cause scrolling commands to redraw the entire window
-instead of moving the bottom two lines of the window to the top (typically 3/4
-of the window is being deleted upward and inserted downward, hence a redraw);
-however, commands like @hid[New Line] and @hid[Open Line] will still work
-efficiently, inserting a line and moving the rest of the window's text
-downward.
-@enddefhvar
-
-
-@section[The Echo Area]
-
-@index[echo area]
-@index[prompting]
-The echo area is the region which occupies the bottom few lines on the screen.
-It is used for two purposes: displaying brief messages to the user and
-prompting.
-
-When a command needs some information from the user, it requests it by
-displaying a @i[prompt] in the echo area.  The following is a typical prompt:
-@begin[programexample]
-Select Buffer: [hemlock-init.lisp /usr/foo/]
-@end[programexample]
-The general format of a prompt is a one or two word description of the input
-requested, possibly followed by a @i[default] in brackets.  The default is a
-standard response to the prompt that @hemlock uses if you type @bf[Return]
-without giving any other input.
-
-There are four general kinds of prompts: @comment<Key prompts?>
-@begin[description]
-@i[key-event]@\
- The response is a single key-event and no confirming @binding[Return] is
-needed.
-
-@i[keyword]@\
- The response is a selection from one of a limited number of choices.
-Completion is available using @binding[Space] and @binding[Escape], and you
-only need to supply enough of the keyword to distinguish it from any other
-choice.  In some cases a keyword prompt accepts unknown input, indicating the
-prompter should create a new entry.  If this is the case, then you must enter
-the keyword fully specified or completed using @binding[Escape]; this
-distinguishes entering an old keyword from making a new keyword which is a
-prefix of an old one since the system completes partial input automatically.
-
-@i[file]@\
- The response is the name of a file, which may have to exist.  Unlike other
-prompts, the default has some effect even after the user supplies some input:
-the system @i[merges] the default with the input filename.  See page
-@pageref(merging) for a description of filename merging.  @bf[Escape] and
-@bf[Space] complete the input for a file parse.
-
-@i[string]@\
- The response is a string which must satisfy some property, such as being the
-name of an existing file.
-@end[description]
-
-@index[history, echo area]
-These key-events have special meanings when prompting:
-@begin[description]
-@binding[Return]@\
- Confirm the current parse.  If no input has been entered, then use the
-default.  If for some reason the input is unacceptable, @hemlock does two
-things:
-@Begin[enumerate]
-beeps, if the variable @hid[Beep on Ambiguity] set, and
-
-moves the point to the end of the first word requiring disambiguation.
-@End[enumerate]
-This allows you to add to the input before confirming the it again.
-
-@binding[Home, C-_]@\
- Print some sort of help message.  If the parse is a keyword parse, then print
-all the possible completions of the current input in a pop-up window.
-
-@binding[Escape]@\
- Attempt to complete the input to a keyword or file parse as far as possible,
-beeping if the result is ambiguous.  When the result is ambiguous, @hemlock
-moves the point to the first ambiguous field, which may be the end of the
-completed input.
-
-@binding[Space]@\
- In a keyword parse, attempt to complete the input up to the next space.  This
-is useful for completing the names of @hemlock commands and similar things
-without beeping a lot, and you can continue entering fields while leaving
-previous fields ambiguous.  For example, you can invoke @hid[Forward Word] as
-an extended command by typing @binding[M-X f Space w Return].  Each time the
-user enters space, @Hemlock attempts to complete the current field and all
-previous fields.
-
-@binding[C-i, Tab]@\
- In a string or keyword parse, insert the default so that it may be edited.
-
-@binding[C-p]@\
- Retrieve the text of the last string input from a history of echo area inputs.
-Repeating this moves to successively earlier inputs.
-
-@binding[C-n]@\
- Go the other way in the echo area history.
-
-@binding[C-q]@\
- Quote the next key-event so that it is not interpreted as a command.
-@end[description]
-
-@defhvar[var "Ignore File Types"]
-This variable is a list of file types (or extensions), represented as a string
-without the dot, e.g. @f["fasl"].  Files having any of the specified types will
-be considered nonexistent for completion purposes, making an unambiguous
-completion more likely.  The initial value contains most common binary and
-output file types.
-@enddefhvar
-
-
-@section[Online Help]
-
-@label[help]
-@index[online help]
-@index[documentation, hemlock]
-@hemlock has a fairly good online documentation facility.  You can get brief
-documentation for every command, variable, character attribute, and key
-by typing a key.
-
-@defcom[com "Help", bind (Home, C-_)]
-This command prompt for a key-event indicating one of a number of other
-documentation commands.  The following are valid responses:
-@begin[description]
-@bf[a]@\
- List commands and other things whose names contain a specified keyword.
-
-@bf[d]@\
- Give the documentation and bindings for a specified command.
-
-@bf[g]@\
- Give the documentation for any @hemlock thing.
-
-@bf[v]@\
- Give the documentation for a @hemlock variable and its values.
-
-@bf[c]@\
- Give the documentation for a command bound to some key.
-
-@bf[l]@\
- List the last sixty key-events typed.
-
-@bf[m]@\
- Give the documentation for a mode followed by a short description of its
-mode-specific bindings.
-
-@bf[p]@\
- Give the documentation and bindings for commands that have at least one
-binding involving a mouse/pointer key-event.
-
-@bf[w]@\
- List all the key bindings for a specified command.
-
-@bf[t]@\
- Describe a @llisp object.
-
-@binding[q]@\
- Quit without doing anything.
-
-@binding[Home, C-_, ?, h]@\
- List all of the options and what they do.
-@end[description]
-@enddefcom
-
-@defcom[com "Apropos", bind (Home a, C-_ a)]
-This command prints brief documentation for all commands, variables, and
-character attributes whose names match the input.  This performs a prefix match
-on each supplied word separately, intersecting the names in each word's result.
-For example, giving @hid[Apropos] "@f[f m]" causes it to tersely describe
-following commands and variables:
-@Begin[Itemize]   
-@hid[Auto Fill Mode]
-
-@hid[Fundamental Mode]
-
-@hid[Mark Form]
-
-@hid[Default Modeline Fields]
-
-@hid[Fill Mode Hook]
-
-@hid[Fundamental Mode Hook]
-@End[Itemize]
-Notice @hid[Mark Form] demonstrates that the "@f[f]" words may follow the
-"@f[m]" order of the fields does not matter for @hid[Apropos].
-
-The bindings of commands and values of variables are printed with the
-documentation.
-@enddefcom
-
-@defcom[com "Describe Command", bind (Home d, C-_ d)]
-This command prompts for a command and prints its full documentation and all
-the keys bound to it.
-@enddefcom
-
-@defcom[com "Describe Key", bind (Home c, C-_ c, M-?)]
-This command prints full documentation for the command which is bound to
-the specified key in the current environment.
-@enddefcom
-
-@defcom[com "Describe Mode", bind (Home m, C-_ m)]
-This command prints the documentation for a mode followed by a short
-description of each of its mode-specific bindings.
-@enddefcom
-
-@defcom[com "Show Variable"]
-@defcom1[com "Describe and Show Variable"]
-@hid[Show Variable] prompts for the name of a variable and displays
-the global value of the variable, the value local to the current buffer (if
-any), and the value of the variable in all defined modes that have it as a
-local variable.  @hid[Describe and Show Variable] displays the variable's
-documentation in addition to the values.
-@enddefcom
-
-@defcom[com "What Lossage", bind (Home l, C-_ l)]
-This command displays the last sixty key-events typed.  This can be useful
-if, for example, you are curious what the command was that you typed by
-accident.
-@enddefcom
-
-@defcom[com "Describe Pointer"]
-This command displays the documentation and bindings for commands that have
-some binding involving a mouse/pointer key-event.  It will not show the
-documentation for the @hid[Illegal] command regardless of whether it has a
-pointer binding.
-@enddefcom
-
-@defcom[com "Where Is", bind (Home w, C-_ w)]
-This command prompts for the name of a command and displays its key
-bindings in a pop-up window.  If a key binding is not global, the
-environment in which it is available is displayed.
-@enddefcom
-
-@defcom[com "Generic Describe", bind (Home g, C-_ g)]
-This command prints full documentation for any thing that has
-documentation.  It first prompts for the kind of thing to document, the
-following options being available:
-@begin[description]
-@i[attribute]@\Describe a character attribute, given its name.
-
-@i[command]@\Describe a command, given its name.
-
-@i[key]@\Describe a command, given a key to which it is bound.
-
-@i[variable]@\Describe a variable, given its name.  This is the default.
-@end[description]
-@enddefcom
-
-
-@section[Entering and Exiting]
-
-@index[entering hemlock]@hemlock is entered by using the @clisp @f[ed]
-function.  Simply typing @f[(ed)] will enter @hemlock, leaving you in the state
-that you were in when you left it.  If @hemlock has never been entered before
-then the current buffer will be @hid[Main].  The @f[-edit] command-line switch
-may also be used to enter @hemlock: see page @pageref[edit-switch].
-
-@f[ed] may optionally be given a file name or a symbol argument.  Typing 
-@f[(ed @i[filename])] will cause the specified file to be read into @hemlock,
-as though by @hid[Find File].  Typing @w<@f[(ed @i[symbol])]> will pretty-print
-the definition of the symbol into a buffer whose name is obtained by adding
-"@f[Edit ]" to the beginning of the symbol's name.
-
-@defcom[com "Exit Hemlock", bind (C-c, C-x C-z)]
-@defcom1[com "Pause Hemlock"]
-@index[exiting hemlock]@hid[Exit Hemlock] exits @hemlock, returning @f[t].
-@hid[Exit Hemlock] does not by default save modified buffers, or do
-anything else that you might think it should do; it simply exits.  At any time
-after exiting you may reenter by typing @f[(ed)] to @llisp without losing
-anything.  Before you quit from @llisp using @f[(quit)], you should
-save any modified files that you want to be saved.
-
-@hid[Pause Hemlock] is similar, but it suspends the @llisp process and returns
-control to the shell.  When the process is resumed, it will still be running
-@hemlock.
-@enddefcom
-
-
-@section[Helpful Information]
-
-@label[aborting]
-@index[aborting]
-@index[undoing]
-@index[error recovery]
-This section contains assorted helpful information which may be useful in
-staying out of trouble or getting out of trouble.
-
-@begin[itemize]
-It is possible to get some sort of help nearly everywhere by typing
-@binding[Home] or @binding[C-_].
-
-Various commands take over the keyboard and insist that you type the key-events
-that they want as input.  If you get in such a situation and want to get out,
-you can usually do so by typing @bf[C-g] some small number of times.  If this
-fails you can try typing @binding[C-x C-z] to exit @hemlock and then "@f[(ed)]"
-to re-enter it.
-
-Before you quit, make sure you have saved all your changes.  @binding[C-u C-x
-C-b] will display a list of all modified buffers.  If you exit using @bf[C-x
-M-z], then @hemlock will save all modified buffers with associated files.
-
-If you lose changes to a file due to a crash or accidental failure to save,
-look for backup ("@i[file]@f[.BAK]") or checkpoint ("@i[file]@f[.CKP]") files
-in the same directory where the file was.
-
-If the screen changes unexpectedly, you may have accidentally typed an
-incorrect command.  Use @binding[Home l] to see what it was.  If you are
-not familiar with the command, use @binding[Home c] to see what it is so that
-you know what damage has been done.  Many interesting commands can be found
-in this fashion.  This is an example of the much-underrated learning
-technique known as "Learning by serendipitous malcoordination".  Who would
-ever think of looking for a command that deletes all files in the current
-directory?
-
-If you accidentally type a "killing" command such as @binding[C-w], you can
-get the lost text back using @binding[C-y].  The @hid[Undo] command is also
-useful for recovering from this sort of problem.
-@end[itemize]
-
-@defhvar[var "Region Query Size", val {30}]
-@index[large region]
-Various commands ask for confirmation before modifying a region containing more
-than this number of lines.  If this is @nil, then these commands refrain from
-asking, no matter how large the region is.
-@enddefhvar
-
-@defcom[com "Undo"]
-This command undoes the last major modification.  Killing commands and some
-other commands save information about their modifications, so accidental uses
-may be retracted.  This command displays the name of the operation to be undone
-and asks for confirmation.  If the affected text has been modified between the
-invocations of @hid[Undo] and the command to be undone, then the result may be
-somewhat incorrect but useful.  Often @hid[Undo] itself can be undone by
-invoking it again.
-@enddefcom
-
-
-@section[Recursive Edits]
-@label[recursive-edits]
-@index[recursive edits]
-Some sophisticated commands, such as @hid[Query Replace], can place you in a
-@i[recursive edit].  A recursive edit is simply a recursive invocation of
-@hemlock done within a command.  A recursive edit is useful because it allows
-arbitrary editing to be done during the execution of a command without losing
-any state that the command might have.  When the user exits a recursive edit,
-the command that entered it proceeds as though nothing happened.  @Hemlock
-notes recursive edits in the @hid[Echo Area] modeline, or status line.  A
-counter reflects the number of pending recursive edits.
-
-@defcom[com "Exit Recursive Edit", bind (C-M-z)]
-This command exits the current recursive edit, returning @nil.  If invoked when
-not in a recursive edit, then this signals an user error.
-@enddefcom
-
-@defcom[com "Abort Recursive Edit", bind (@bf<C-]>)]
-This command causes the command which invoked the recursive edit to get an
-error.  If not in a recursive edit, this signals an user error.
-@enddefcom
-
-
-@section[User Errors]
-@index[beeping]
-@index[errors, user]
-When in the course of editing, @hemlock is unable to do what it thinks you want
-to do, then it brings this to your attention by a beep or a screen flash
-(possibly accompanied by an explanatory echo area message such as @w<"@f[No
-next line.]">.)  Although the exact attention-getting mechanism may vary on the
-output device and variable settings, this is always called @i[beeping].
-
-Whatever the circumstances, you had best try something else since @hemlock,
-being far more stupid than you, is far more stubborn.  @hemlock is an
-extensible editor, so it is always possible to change the command that
-complained to do what you wanted it to do.
-
-@section[Internal Errors]
-
-@index[errors, internal]A message of this form may appear in the echo
-area, accompanied by a beep:
-@begin[programexample]
-Internal error:
-Wrong type argument, NIL, should have been of type SIMPLE-VECTOR.
-@end[programexample]
-If the error message is a file related error such as the following, then
-you have probably done something illegal which @hemlock did not catch,
-but was detected by the file system:
-@begin[programexample]
-Internal error:
-No access to "/lisp2/emacs/teco.mid"
-@end[programexample]
-Otherwise, you have found a bug.  Try to avoid the behavior that resulted
-in the error and report the problem to your system maintainer.  Since @llisp
-has fairly robust error recovery mechanisms, probably no damage has been
-done.
-
-If a truly abominable error from which @hemlock cannot recover occurs,
-then you will be thrown into the @llisp debugger.  At this point it would be
-a good idea to save any changes with @f[save-all-buffers] and then start
-a new @llisp.
-
-@index[save-all-buffers, function]The @llisp function @f[save-all-buffers] may
-be used to save modified buffers in a seriously broken @hemlock.  To use this,
-type "@f[(save-all-buffers)]" to the top-level ("@f[* ]") or debugger
-("@f<1] >") prompt and confirm saving of each buffer that should be saved.
-Since this function will prompt in the "@f[Lisp]" window, it isn't very useful
-when called inside of @hemlock.
diff --git a/docs/hem/user/lisp.mss b/docs/hem/user/lisp.mss
deleted file mode 100644
index fc749caa9313f9e06f51ccbceb3bb99987156583..0000000000000000000000000000000000000000
--- a/docs/hem/user/lisp.mss
+++ /dev/null
@@ -1,822 +0,0 @@
-@comment{-*- Dictionary: /afs/cs/project/clisp/scribe/hem/hem; Mode: spell; Package: Hemlock -*-}
-@chap[Interacting With Lisp]
-@index[lisp, interaction with]
-
-Lisp encourages highly interactive programming environments by requiring
-decisions about object type and function definition to be postponed until run
-time.  @hemlock supports interactive programming in @llisp by providing
-incremental redefinition and environment examination commands.  @hemlock also
-uses Unix TCP sockets to support multiple Lisp processes, each of which may be
-on any machine.
-
-
-@section[Eval Servers]
-@label[eval-servers]
-@index[eval servers]
-
-@hemlock runs in the editor process and interacts with other Lisp processes
-called @i[eval servers].  A user's Lisp program normally runs in an eval
-server process.  The separation between editor and eval server has several
-advantages:
-@begin[itemize]
-The editor is protected from any bad things which may happen while debugging a
-Lisp program.
-
-Editing may occur while running a Lisp program.
-
-The eval server may be on a different machine, removing the load from the
-editing machine.
-
-Multiple eval servers allow the use of several distinct Lisp environments.
-@end[itemize]
-Instead of providing an interface to a single Lisp environment, @hemlock
-coordinates multiple Lisp environments.
-
-
-@subsection[The Current Eval Server]
-@index[current eval server]
-Although @hemlock can be connected to several eval servers simultaneously, one
-eval server is designated as the @i[current eval server].  This is the eval
-server used to handle evaluation and compilation requests.  Eval servers are
-referred to by name so that there is a convenient way to discriminate between
-servers when the editor is connected to more than one.  The current eval server
-is normally globally specified, but it may also be shadowed locally in specific
-buffers.
-
-@defcom[com "Set Eval Server"]
-@defcom1[com "Set Buffer Eval Server"]
-@defcom1[com "Current Eval Server"]
-@hid[Set Eval Server] prompts for the name of an eval server and makes it the
-the current eval server.  @hid[Set Buffer Eval Server] is the same except that
-is sets the eval server for the current buffer only.  @hid[Current Eval Server]
-displays the name of the current eval server in the echo area, taking any
-buffer eval server into consideration.  See also @comref[Set Compile Server].
-@enddefcom
-
-
-@subsection[Slaves]
-@index[slave buffers]
-@index[slaves]
-For now, all eval servers are @i[slaves].  A slave is a Lisp process that uses
-a typescript (see page @pageref[typescripts]) to run its top-level
-@f[read-eval-print] loop in a @hemlock buffer.  We refer to the buffer that a
-slave uses for I/O as its @i[interactive] or @i[slave] buffer.  The name of the
-interactive buffer is the same as the eval server's name.
-
-@index[background buffers]
-@hemlock creates a @i[background] buffer for each eval server.  The background
-buffer's name is @w<@hid[Background ]@i{name}>, where @i[name] is the name of
-the eval server.  Slaves direct compiler warning output to the background
-buffer to avoid cluttering up the interactive buffer.
-
-@hemlock locally sets @hid[Current Eval Server] in interactive and background
-buffers to their associated slave.  When in a slave or background buffer, eval
-server requests will go to the associated slave, regardless of the global value
-of @hid[Current Eval Server].
-
-@defcom[com "Select Slave", bind (C-M-c)]
-This command changes the current buffer to the current eval server's
-interactive buffer.  If the current eval server is not a slave, then it beeps.
-If there is no current eval server, then this creates a slave (see section
-@ref[slave-creation]).  If a prefix argument is supplied, then this creates a
-new slave regardless of whether there is a current eval server.  This command
-is the standard way to create a slave.
-
-The slave buffer is a typescript (see page @pageref[typescripts]) the slave
-uses for its top-level @f[read-eval-print] loop.
-@enddefcom
-
-@defcom[com "Select Background", bind (C-M-C)]
-This command changes the current buffer to the current eval server's background
-buffer.  If there is no current eval server, then it beeps.
-@enddefcom
-
-
-@subsection[Slave Creation and Destruction]
-@label[slave-creation]
-When @hemlock first starts up, there is no current eval server.  If there is no
-a current eval server, commands that need to use the current eval server will
-create a slave as the current eval server.
-
-If an eval server's Lisp process terminates, then we say the eval server is
-dead.  @hemlock displays a message in the echo area, interactive, and
-background buffers whenever an eval server dies.  If the user deletes an
-interactive or background buffer, the associated eval server effectively
-becomes impotent, but @hemlock does not try to kill the process.  If a command
-attempts to use a dead eval server, then the command will beep and display a
-message.
-
-@defhvar[var "Confirm Slave Creation", val {t}]
-If this variable is true, then @hemlock always prompts the user for
-confirmation before creating a slave.
-@enddefhvar
-
-@defhvar[var "Ask About Old Servers", val {t}]
-If this variable is true, and some slave already exists, @hemlock prompts the
-user for the name of an existing server when there is no current server,
-instead of creating a new one.
-@enddefhvar
-
-@defcom[com "Editor Server Name"]
-This command echos the editor server's name, the machine and port of the
-editor, which is suitable for use with the Lisp processes -slave switch.
-See section @ref[slave-switch].
-@enddefcom
-
-@defcom[com "Accept Slave Connections"]
-This command cause @hemlock to accept slave connections, and it displays the
-editor server's name, which is suitable for use with the Lisp processes -slave
-switch.  See section @ref[slave-switch].  Supplying an argument causes this
-command to inhibit slave connections.
-@enddefcom
-
-@defhvar[var "Slave Utility", val {"/usr/misc/.lisp/bin/lisp"}]
-@defhvar1[var "Slave Utility Switches"]
-A slave is started by running the program @hid[Slave Utility Name] with
-arguments specified by the list of strings @hid[Slave Utility Switches].  This
-is useful primarily when running customized Lisp systems.  For example,
-setting @hid[Slave Utility Switches] to @f[("-core" "my.core")] will cause
-"@f[/usr/hqb/my.core]" to be used instead of the default core image.
-
-The @f[-slave] switch and the editor name are always supplied as arguments, and
-should remain unspecified in @hid[Slave Utility Switches].
-@enddefhvar
-
-@defcom[com "Kill Slave"]
-@defcom1[com "Kill Slave and Buffers"]
-@hid[Kill Slave] prompts for a slave name, aborts any operations in the slave,
-tells the slave to @f[quit], and shuts down the connection to the specified
-eval server.  This makes no attempt to assure the eval server actually dies.
-
-@hid[Kill Slave and Buffers] is the same as @hid[Kill Slave], but it also
-deletes the interactive and background buffers.
-@enddefcom
-
-
-@subsection[Eval Server Operations]
-
-@label[operations]
-@index[eval server operations]@index[operations, eval server]
-@hemlock handles requests for compilation or evaluation by queuing an
-@i[operation] on the current eval server.  Any number of operations may be
-queued, but each eval server can only service one operation at a time.
-Information about the progress of operations is displayed in the echo area.
-
-@defcom[com "Abort Operations", bind (C-c a)]
-This command aborts all operations on the current eval server, either queued or
-in progress.  Any operations already in the @f[Aborted] state will be flushed.
-@enddefcom
-
-@defcom[com "List Operations", bind (C-c l)]
-This command lists all operations which have not yet completed.  Along with a
-description of the operation, the state and eval server is displayed.  The
-following states are used:
-@begin[description]
-@f[Unsent]@\The operation is in local queue in the editor, and hasn't been sent
-yet.
-
-@f[Pending]@\The operation has been sent, but has not yet started execution.
-
-@f[Running]@\The operation is currently being processed.
-
-@f[Aborted]@\The operation has been aborted, but the eval server has not yet
-indicated termination.
-@end[description]
-@enddefcom
-
-
-@section[Typescripts]
-@label[typescripts]
-@index[typescripts]
-
-Both slave buffers and background buffers are typescripts.  The typescript
-protocol allows other processes to do stream-oriented interaction in a @hemlock
-buffer similar to that of a terminal.  When there is a typescript in a buffer,
-the @hid[Typescript] minor mode is present.  Some of the commands described in
-this section are also used by @hid[Eval] mode (page @pageref[eval-mode].)
-
-Typescripts are simple to use.  @hemlock inserts output from the process into
-the buffer.  To give the process input, use normal editing to insert the input
-at the end of the buffer, and then type @bf[Return] to confirm sending the
-input to the process.
-
-@defcom[com "Confirm Typescript Input", 
-        stuff (bound to @bf[Return] in @hid[Typescript] mode)]
-@defhvar1[var "Unwedge Interactive Input Confirm", val {t}]
-This command sends text that has been inserted at the end of the current buffer
-to the process reading on the buffer's typescript.  Before sending the text,
-@hemlock moves the point to the end of the buffer and inserts a newline.
-
-Input may be edited as much as is desired before it is confirmed; the result
-of editing input after it has been confirmed is unpredictable.  For this reason,
-it is desirable to postpone confirming of input until it is actually complete.
-The @hid[Indent New Line] command is often useful for inserting newlines
-without confirming the input.
-
-If the process reading on the buffer's typescript is not waiting for input,
-then the text is queued instead of being sent immediately.  Any number of
-inputs may be typed ahead in this fashion.  @hemlock makes sure that the inputs
-and outputs get interleaved correctly so that when all input has been read, the
-buffer looks the same as it would have if the input had not been typed ahead.
-
-If the buffer's point is before the start of the input area, then various
-actions can occur.  When set, @hid[Unwedge Interactive Input Confirm] causes
-@hemlock to ask the user if it should fix the input buffer which typically
-results in ignoring any current input and refreshing the input area at the end
-of the buffer.  This also has the effect of throwing the slave Lisp to top
-level, which aborts any pending operations or queued input.  This is the only
-way to be sure the user is cleanly set up again after messing up the input
-region.  When this is @nil, @hemlock simply beeps and tells the user in the
-@hid[Echo Area] that the input area is invalid.
-@enddefcom
-
-@defcom[com "Kill Interactive Input", 
-    stuff (bound to @bf[M-i] in @hid[Typescript] and @hid[Eval] modes)]
-This command kills any input that would have been confirmed by @bf[Return].
-@enddefcom
-
-@defcom[com "Next Interactive Input",  
-        stuff (bound to @bf[M-n] in @hid[Typescript] and @hid[Eval] modes)]
-@defcom1[com "Previous Interactive Input",
-        stuff (bound to @bf[M-p] in @hid[Typescript] and @hid[Eval] modes)]
-@defcom1[com "Search Previous Interactive Input",
-	stuff (bound to @bf[M-P] in @hid[Typescript] and @hid[Eval] modes)]
-@defhvar1[var "Interactive History Length", val {10}]
-@defhvar1[var "Minimum Interactive Input Length", val {2}]
-@index[history, typescript]
-@Hemlock maintains a history of interactive inputs.  @hid[Next Interactive
-Input] and @hid[Previous Interactive Input] step forward and backward in the
-history, inserting the current entry in the buffer.  The prefix argument is
-used as a repeat count.
-
-@hid[Search Previous Interactive Input] searches backward through the
-interactive history using the current input as a search string.  Consecutive
-invocations repeat the previous search.
-
-@hid[Interactive History Length] determines the number of entries with which
-@hemlock creates the buffer-specific histories.  @Hemlock only adds an input
-region to the history if its number of characters exceeds @hid[Minimum
-Interactive Input Length].
-@enddefcom
-
-@defcom[com "Reenter Interactive Input",
-	stuff (bound to @bf[C-Return] in @hid[Typescript] and @hid[Eval] modes)]
- This copies to the end of the buffer the form to the left of the buffer's
-point.  When the current region is active, this copies it instead.  This is
-sometimes easier to use to get a previous input that is either so far back that
-it has fallen off the history or is visible and more readily @i[yanked] than
-gotten with successive invocations of the history commands.
-@enddefcom
-
-@defcom[com "Interactive Beginning of Line", 
-        stuff (bound to @bf[C-a] in @hid[Typescript] and @hid[Eval] modes)]
-This command is identical to @hid[Beginning of Line] unless there is no
-prefix argument and the point is on the same line as the start of the current
-input; then it moves to the beginning of the input.  This is useful since it
-skips over any prompt which may be present.
-@enddefcom
-
-@defhvar[var "Input Wait Alarm", val {:loud-message}]
-@defhvar1[var "Slave GC Alarm", val {:message}]
-@hid[Input Wait Alarm] determines what action to take when a slave Lisp goes
-into an input wait on a typescript that isn't currently displayed in any
-window.  @hid[Slave GC Alarm] determines what action to take when a slave
-notifies that it is GC'ing.
-
-The following are legal values:
-@begin[description]
-@kwd[loud-message]@\Beep and display a message in the echo area indicating
-which buffer is waiting for input.
-
-@kwd[message]@\Display a message, but don't beep.
-
-@nil@\Don't do anything.
-@end[description]
-@enddefhvar
-
-@defcom[com "Typescript Slave BREAK", bind (Typescript: H-b)]
-@defcom1[com "Typescript Slave to Top Level", bind (Typescript: H-g)]
-@defcom1[com "Typescript Slave Status", bind (Typescript: H-s)]
-Some typescripts have associated information which these commands access
-allowing @hemlock to control the process which uses the typescript.
-
-@hid[Typescript Slave BREAK] puts the current process in a break loop so that
-you can be debug it.  This is similar in effect to an interrupt signal (@f[^C]
-or @f[^\] in the editor process).
-
-@hid[Typescript Slave to Top Level] causes the current process to throw to the
-top-level @f[read-eval-print] loop.  This is similar in effect to a quit signal
-(@f[^\]).
-
-@hid[Typescript Slave Status] causes the current process to print status
-information on @var[error-output]:
-@lisp
-; Used 0:06:03, 3851 faults.  In: SYSTEM:SERVE-EVENT
-@endlisp
-The message displays the process run-time, the total number of page faults and
-the name of the currently running function.   This command is useful for
-determining whether the slave is in an infinite loop, waiting for input, or
-whatever.
-@enddefcom
-
-
-@section[The Current Package]
-@label[lisp-package]
-@index[package]
-The current package is the package which Lisp interaction commands use.  The
-current package is specified on a per-buffer basis, and defaults to "@f[USER]".
-If the current package does not exist in the eval server, then it is created.
-If evaluation is being done in the editor process and the current package
-doesn't exist, then the value of @f[*package*] is used.  The current package is
-displayed in the modeline (see section @ref[modelines].)  Normally the package
-for each file is specified using the @f[Package] file option (see page
-@pageref[file-options].)
-
-When in a slave buffer, the current package is controlled by the value of
-@var[package] in that Lisp process.  Modeline display of the current package
-is inhibited in this case.
-
-@defcom[com "Set Buffer Package"]
-This command prompts for the name of a package to make the local package in the
-current buffer.  If the current buffer is a slave, background, or eval buffer,
-then this sets the current package in the associated eval server or editor
-Lisp.  When in an interactive buffer, do not use @f[in-package]; use this
-command instead.
-@enddefcom
-
-
-@section[Compiling and Evaluating Lisp Code]
-
-@index[compilation]@index[evaluation]These commands can greatly speed up
-the edit/debug cycle since they enable incremental reevaluation or
-recompilation of changed code, avoiding the need to compile and load an
-entire file.  
-
-@defcom[com "Evaluate Expression", bind (M-Escape)]
-This command prompts for an expression and prints the result of its evaluation
-in the echo area.  If an error happens during evaluation, the evaluation is
-simply aborted, instead of going into the debugger.  This command doesn't
-return until the evaluation is complete.
-@enddefcom
-
-@defcom[com "Evaluate Defun", bind (C-x C-e)]
-@defcom1[com "Evaluate Region"]
-@defcom1[com "Evaluate Buffer"]
-These commands evaluate text out of the current buffer, reading the current
-defun, the region and the entire buffer, respectively.  The result of the
-evaluation of each form is displayed in the echo area.  If the region is
-active, then @hid[Evaluate Defun] evaluates the current region, just like 
-@hid[Evaluate Region].
-@enddefcom
-
-@defcom[com "Macroexpand Expression", bind (C-M)]
-This command shows the macroexpansion of the next expression in the null
-environment in a pop-up window.  With an argument, it uses @f[macroexpand]
-instead of @f[macroexpand-1].
-@enddefcom
-
-@defcom[com "Re-evaluate Defvar"]
-This command is similar to @hid[Evaluate Defun].  It is used for force the
-re-evaluation of a @f[defvar] init form.  If the current top-level form is a
-@f[defvar], then it does a @f[makunbound] on the variable, and evaluates the
-form.
-@enddefcom
-
-@defcom[com "Compile Defun", bind (C-x C-c)]
-@defcom1[com "Compile Region"]
-These commands compile the text in the current defun and the region,
-respectively.  If the region is active, then @hid[Compile Defun] compiles the
-current region, just like @hid[Compile Region].
-@enddefcom
-
-@defcom[com "Load File"]
-@defhvar1[var "Load Pathname Defaults", val {nil}]
-This command prompts for a file and loads it into the current eval server using
-@f[load].  @hid[Load Pathname Defaults] contains the default pathname for this
-command.  This variable is set to the file loaded; if it is @nil, then there is
-no default.  This command also uses the @hid[Remote Compile File] variable.
-@enddefcom
-
-
-@section[Compiling Files]
-These commands are used to compile source ("@f[.lisp]") files, producing binary
-("@f[.fasl]") output files.  Note that unlike the other compiling and evalating
-commands, this does not have the effect of placing the definitions in the
-environment; to do so, the binary file must be loaded.
-
-@defcom[com "Compile Buffer File", bind (C-x c)]
-@defhvar1[var "Compile Buffer File Confirm", val {t}]
-This command asks for confirmation, then saves the current buffer (when
-modified) and compiles the associated file.  The confirmation prompt indicates
-intent to save and compile or just compile.  If the buffer wasn't modified, and
-a comparison of the write dates for the source and corresponding binary
-("@f[.fasl]") file suggests that recompilation is unnecessary, the confirmation
-also indicates this.  A prefix argument overrides this test and forces
-recompilation.  Since there is a complete log of output in the background
-buffer, the creation of the normal error output ("@f[.err]") file is inhibited.
-
-Setting @hid[Compile Buffer File Confirm] to @nil inhibits confirmation, except
-when the binary is up to date and a prefix argument is not supplied.
-@enddefcom
-
-@defcom[com "Compile File"]
-This command prompts for a file and compiles that file, providing a convenient
-way to compile a file that isn't in any buffer.  Unlike 
-@hid[Compile Buffer File], this command doesn't do any consistency checks such
-as checking whether the source is in a modified buffer or the binary is up to
-date.
-@enddefcom
-
-@defcom[com "Compile Group"]
-@defcom1[com "List Compile Group"]
-@label[compile-group-command]@index[group, compilation]@hid[Compile Group] does
-a @hid[Save All Files] and then compiles every "@f[.lisp]" file for which the
-corresponding "@f[.fasl]" file is older or nonexistent.  The files are compiled
-in the order in which they appear in the group definition.  A prefix argument
-forces compilation of all "@f[.lisp]" files.
-
-@hid[List Compile Group] lists any files that would be compiled by
-@hid[Compile Group].  All Modified files are saved before checking to generate
-a consistent list.
-@enddefcom 
-
-@defcom[com "Set Compile Server"]
-@defcom1[com "Set Buffer Compile Server"]
-@defcom1[com "Current Compile Server"]
-These commands are analogous to @hid[Set Eval Server], @comref[Set Buffer Eval
-Server] and @hid[Current Eval Server], but they determine the eval server used
-for file compilation requests.  If the user specifies a compile server, then
-the file compilation commands send compilation requests to that server instead
-of the current eval server.
-
-Having a separate compile server makes it easy to do compilations in the
-background while continuing to interact with your eval server and editor.  The
-compile server can also run on a remote machine relieving your active
-development machine of the compilation effort.
-@enddefcom
-
-@defcom[com "Next Compiler Error", bind (H-n)]
-@defcom1[com "Previous Compiler Error", bind (H-p)]
-These commands provides a convenient way to inspect compiler errors.  First it
-splits the current window if there is only one window present.  @hemlock
-positions the current point in the first window at the erroneous source code
-for the next (or previous) error.  Then in the second window, it displays the
-error beginning at the top of the window.  Given an argument, this command
-skips that many errors.
-@enddefcom
-
-@defcom[com "Flush Compiler Error Information"]
-This command relieves the current eval server of all infomation about errors
-encountered while compiling.  This is convenient if you have been compiling a
-lot, but you were ignoring errors and warnings.  You don't want to step through
-all the old errors, so you can use this command immediately before compiling a
-file whose errors you intend to edit.
-@enddefcom
-
-
-@defhvar[var "Remote Compile File", val {nil}]
-When true, this variable causes file compilations to be done using the RFS
-remote file system mechanism by prepending "@f[/../]@i[host]" to the file being
-compiled.  This allows the compile server to be run on a different machine, but
-requires that the source be world readable.  If false, commands use source
-filenames directly.  Do NOT use this to compile files in AFS.
-@enddefhvar
-
-
-@section[Querying the Environment]
-@index[documentation, lisp]
-These commands are useful for obtaining various random information from the
-Lisp environment.
-
-@defcom[com "Describe Function Call", bind (C-M-A)]
-@defcom1[com "Describe Symbol", bind (C-M-S)]
-@hid[Describe Function Call] uses the current eval server to describe the
-symbol found at the head of the currently enclosing list, displaying the output
-in a pop-up window.  @hid[Describe Symbol] is the same except that it describes
-the symbol at or before the point.  These commands are primarily useful for
-finding the documentation for functions and variables.  If there is no
-currently valid eval server, then this command uses the editor Lisp's
-environment instead of trying to spawn a slave.
-@enddefcom
-
-
-@section[Editing Definitions]
-The Lisp compiler annotates each compiled function object with the source
-file that the function was originally defined from.  The definition editing
-commands use this information to locate and edit the source for functions
-defined in the environment.
-
-@defcom[com "Edit Definition"]
-@defcom1[com "Goto Definition", bind (C-M-F)]
-@defcom1[com "Edit Command Definition"]
-@hid[Edit Definition] prompts for the name of a function, and then uses the
-current eval server to find out in which file the function is defined.  If
-something other than @f[defun] or @f[defmacro] defined the function, then this
-simply reads in the file, without trying to find its definition point within
-the file.  If the function is uncompiled, then this looks for it in the current
-buffer.  If there is no currently valid eval server, then this command uses the
-editor Lisp's environment instead of trying to spawn a slave.
-
-@hid[Goto Definition] edits the definition of the symbol at the beginning of
-the current list.
-
-@hid[Edit Command Definition] edits the definition of a @hemlock command.  By
-default, this command does a keyword prompt for the command name (as in an
-extended command).  If a prefix argument is specified, then instead prompt for
-a key and edit the definition of the command bound to that key.
-@enddefcom
-
-@defcom[com "Add Definition Directory Translation"]
-@defcom1[com "Delete Definition Directory Translation"]
-The defining file is recorded as an absolute pathname.  The definition editing
-commands have a directory translation mechanism that allow the sources to be
-found when they are not in the location where compilation was originally done.
-@hid[Add Definition Directory Translation] prompts for two directory
-namestrings and causes the first to be mapped to the second.  Longer (more
-specific) directory specifications are matched before shorter (more general)
-ones.
-
-@hid[Delete Definition Directory Translation] prompts for a directory
-namestring and deletes it from the directory translation table.
-@enddefcom
-
-@defhvar[var "Editor Definition Info", val {nil}]
-When this variable is true, the editor Lisp is used to determine definition
-editing information, otherwise the current eval server is used.  This variable
-is true in @hid[Eval] and @hid[Editor] modes.
-@enddefhvar
-
-
-@section[Debugging]
-These commands manipulate the slave when it is in the debugger and provide
-source editing based on the debugger's current frame.  These all affect the
-@hid[Current Eval Server].
-
-
-@subsection[Changing Frames]
-
-@defcom[com "Debug Down", bind (C-M-H-d)]
-This command moves down one debugger frame.
-@enddefcom
-
-@defcom[com "Debug Up", bind (C-M-H-u)]
-This command moves up one debugger frame.
-@enddefcom
-
-@defcom[com "Debug Top", bind (C-M-H-t)]
-This command moves to the top of the debugging stack.
-@enddefcom
-
-@defcom[com "Debug Bottom", bind (C-M-H-b)]
-This command moves to the bottom of the debugging stack.
-@enddefcom
-
-@defcom[com "Debug Frame", bind (C-M-H-f)]
-This command moves to the absolute debugger frame number indicated by the
-prefix argument.
-@enddefcom
-
-
-@subsection[Getting out of the Debugger]
-
-@defcom[com "Debug Quit", bind (C-M-H-q)]
-This command throws to top level out of the debugger in the @hid[Current Eval
-Server].
-@enddefcom
-
-@defcom[com "Debug Go", bind (C-M-H-g)]
-This command tries the @f[continue] restart in the @hid[Current Eval Server].
-@enddefcom
-
-@defcom[com "Debug Abort", bind (C-M-H-a)]
-This command executes the ABORT restart in the @hid[Current Eval Server].
-@enddefcom
-
-@defcom[com "Debug Restart", bind (C-M-H-r)]
-This command executes the restart indicated by the prefix argument in the
-@hid[Current Eval Server].  The debugger enumerates the restart cases upon
-entering it.
-@enddefcom
-
-
-@subsection[Getting Information]
-
-@defcom[com "Debug Help", bind (C-M-H-h)]
-This command in prints the debugger's help text.
-@enddefcom
-
-@defcom[com "Debug Error", bind (C-M-H-e)]
-This command prints the error condition and restart cases displayed upon
-entering the debugger.
-@enddefcom
-
-@defcom[com "Debug Backtrace", bind (C-M-H-B)]
-This command executes the debugger's @f[backtrace] command.
-@enddefcom
-
-@defcom[com "Debug Print", bind (C-M-H-p)]
-This command prints the debugger's current frame in the same fashion as the
-frame motion commands.
-@enddefcom
-
-@defcom[com "Debug Verbose Print", bind (C-M-H-P)]
-This command prints the debugger's current frame without elipsis.
-@enddefcom
-
-@defcom[com "Debug Source", bind (C-M-H-s)]
-This command prints the source form for the debugger's current frame.
-@enddefcom
-
-@defcom[com "Debug Verbose Source"]
-This command prints the source form for the debugger's current frame with
-surrounding forms for context.
-@enddefcom
-
-@defcom[com "Debug List Locals", bind (C-M-H-l)]
-This prints the local variables for the debugger's current frame.
-@enddefcom
-
-
-@subsection[Editing Sources]
-
-@defcom[com "Debug Edit Source", bind (C-M-H-S)]
-This command attempts to place you at the source location of the debugger's
-current frame.  Not all debugger frames represent function's that were compiled
-with the appropriate debug-info policy.  This beeps with a message if it is
-unsuccessful.
-@enddefcom
-
-
-@subsection[Miscellaneous]
-
-@defcom[com "Debug Flush Errors", bind (C-M-H-F)]
-This command toggles whether the debugger ignores errors or recursively enters
-itself.
-@enddefcom
-
-
-
-
-@section[Manipulating the Editor Process]
-When developing @hemlock customizations, it is useful to be able to manipulate
-the editor Lisp environment from @hemlock.
-
-@defcom[com "Editor Describe", bind (Home t, C-_ t)]
-This command prompts for an expression, and then evaluates and describes it
-in the editor process.
-@enddefcom
-
-@defcom[com "Room"]
-Call the @f[room] function in the editor process, displaying information
-about allocated storage in a pop-up window.
-@enddefcom
-
-@defcom[com "Editor Load File"]
-This command is analogous to @comref[Load File], but loads the file into the
-editor process.
-@enddefcom
-
-
-@subsection[Editor Mode]
-When @hid[Editor] mode is on, alternate versions of the Lisp interaction
-commands are bound in place of the eval server based commands.  These commands
-manipulate the editor process instead of the current eval server.  Turning on
-editor mode in a buffer allows incremental development of code within the
-running editor.
-
-@defcom[com "Editor Mode"]
-This command turns on @hid[Editor] minor mode in the current buffer.  If it is
-already on, it is turned off.  @hid[Editor] mode may also be turned on using
-the @f[Mode] file option (see page @pageref[file-options].)
-@enddefcom
-
-@defcom[com "Editor Compile Defun",
-	stuff (bound to @bf[C-x C-c] in @hid[Editor] mode)]
-@defcom1[com "Editor Compile Region"]
-@defcom1[com "Editor Evaluate Buffer"]
-@defcom1[com "Editor Evaluate Defun",
-	stuff (bound to @bf[C-x C-e] in @hid[Editor] mode)]
-@defcom1[com "Editor Evaluate Region"]
-@defcom1[com "Editor Macroexpand Expression", bind (Editor: C-M)]
-@defcom1[com "Editor Re-evaluate Defvar"]
-@defcom1[com "Editor Describe Function Call",
-	stuff (bound to @bf[C-M-A] in @hid[Editor] mode)]
-@defcom1[com "Editor Describe Symbol",
-	stuff (bound to @bf[C-M-S] in @hid[Editor] mode)]
-These commands are similar to the standard commands, but modify or examine the
-Lisp process that @hemlock is running in.  Terminal I/O is done on the
-initial window for the editor's Lisp process.  Output is directed to a pop-up
-window or the editor's window instead of to the background buffer.
-@enddefcom
-
-@defcom[com "Editor Compile Buffer File"]
-@defcom1[com "Editor Compile File"]
-@defcom1[com "Editor Compile Group"]
-In addition to compiling in the editor process, these commands differ from the
-eval server versions in that they direct output to the the 
-@hid[Compiler Warnings] buffer.
-@enddefcom
-
-@defcom[com "Editor Evaluate Expression",
-     stuff (bound to @bf[M-Escape] in @hid[Editor] mode and @bf[C-M-Escape])] 
-This command prompts for an expression and evaluates it in the editor process.
-The results of the evaluation are displayed in the echo area.
-@enddefcom
-
-
-@subsection[Eval Mode]
-@label[eval-mode]
-@index[modes, eval]@hid[Eval] mode is a minor mode that simulates a @f[read]
-@f[eval] @f[print] loop running within the editor process.  Since Lisp
-program development is usually done in a separate eval server process (see page
-@pageref[eval-servers]), @hid[Eval] mode is used primarily for debugging code
-that must run in the editor process.  @hid[Eval] mode shares some commands with
-@hid[Typescript] mode: see section @ref[typescripts].
-
-@hid[Eval] mode doesn't completely support terminal I/O: it binds
-@var[standard-output] to a stream that inserts into the buffer and
-@var[standard-input] to a stream that signals an error for all operations.
-@hemlock cannot correctly support the interactive evaluation of forms that read
-from the @hid[Eval] interactive buffer.
-
-@defcom[com "Select Eval Buffer"]
-This command changes to the @hid[Eval] buffer, creating one if it doesn't
-already exist.  The @hid[Eval] buffer is created with @hid[Lisp] as the major
-mode and @hid[Eval] and @hid[Editor] as minor modes. 
-@enddefcom
-
-@defcom[com "Confirm Eval Input",
-        stuff (bound to @bf[Return] in @hid[Eval] mode)]
-This command evaluates all the forms between the end of the last output and
-the end of the buffer, inserting the results of their evaluation in the buffer.
-This beeps if the form is incomplete.  Use @binding[Linefeed] to insert line
-breaks in the middle of a form.
-
-This command uses @hid[Unwedge Interactive Input Confirm] in the same way
-@hid[Confirm Interactive Input] does.
-@enddefcom
-
-@defcom[com "Abort Eval Input", 
-        stuff (bound to @bf[M-i] in @hid[Eval] mode)]
-This command moves the the end of the buffer and prompts, ignoring any
-input already typed in.
-@enddefcom
-
-
-@subsection[Error Handling]
-@index[error handling]
-When an error happens inside of @hemlock, @hemlock will trap the error and
-display the error message in the echo area, possibly along with the
-"@f[Internal error:]" prefix.  If you want to debug the error, type @bf[?].
-This causes the prompt "@f[Debug:]" to appear in the echo area.  The following
-commands are recognized:
-@begin[description]
-@bf[d]@\Enter a break-loop so that you can use the Lisp debugger.
-Proceeding with "@f[go]" will reenter @hemlock and give the "@f[Debug:]"
-prompt again.
-
-@bf[e]@\Display the original error message in a pop-up window.
-
-@bf[b]@\Show a stack backtrace in a pop-up window.
-
-@bf[q, Escape]@\Quit from this error to the nearest command loop.
-
-@bf[r]@\Display a list of the restart cases and prompt for the number of a
-@f[restart-case] with which to continue.  Restarting may result in prompting in
-the window in which Lisp started.
-@end[description]
-
-Only errors within the editor process are handled in this way.  Errors during
-eval server operations are handled using normal terminal I/O on a typescript in
-the eval server's slave buffer or background buffer (see page
-@pageref[operations]).  Errors due to interaction in a slave buffer will cause
-the debugger to be entered in the slave buffer.
-
-
-@section[Command Line Switches]
-@label[slave-switch]
-Two command line switches control the initialization of editor and eval servers
-for a Lisp process:
-@begin[description]
-@f<-edit>@\
-@label[edit-switch]
-This switch starts up @hemlock.  If there is a non-switch command line word
-immediately following the program name, then the system interprets it as a file
-to edit.  For example, given
-@Begin[ProgramExample]
-lisp file.txt -edit
-@End[ProgramExample]
-Lisp will go immediately into @hemlock finding the file @f[file.txt].
-
-@f<-slave [>@i[name]@f<]>@\
- This switch causes the Lisp process to become a slave of the editor process
-@i[name].  An editor Lisp determines @i[name] when it allows connections from
-slaves.  Once the editor chooses a name, it keeps the same name until the
-editor's Lisp process terminates.  Since the editor can automatically create
-slaves on its own machine, this switch is useful primarily for creating slaves
-that run on a different machine.  @f[hqb]'s machine is @f[ME.CS.CMU.EDU], and
-he wants want to run a slave on @f[SLAVE.CS.CMU.EDU], then he should use the
-@hid[Accept Slave Connections] command, telnet to the machine, and invoke Lisp
-supplying @f[-slave] and the editor's name.  The command displays the editor's
-name.
-@end[description]
diff --git a/docs/hem/user/mail.mss b/docs/hem/user/mail.mss
deleted file mode 100644
index 6d1c7a7b9a62768093fd0bd939bdcaab4f901e67..0000000000000000000000000000000000000000
--- a/docs/hem/user/mail.mss
+++ /dev/null
@@ -1,1343 +0,0 @@
-@comment{-*- Dictionary: /afs/cs/project/clisp/scribe/hem/hem; Mode: spell; Package: Hemlock -*-}
-@chap[The Mail Interface]
-@section[Introduction to Mail in Hemlock]
-
-@index[MH interface]@label[introduction]
-@hemlock provides an electronic mail handling facility via an interface to the
-public domain @i[Rand MH Message Handling System].  This chapter assumes that
-the user is familiar with the basic features and operation of @mh, but it
-attempts to make allowances for beginners.  Later sections of this chapter
-discuss setting up @mh, profile components and special files for formatting
-outgoing mail headers, and backing up protected mail directories on a
-workstation.  For more information on @mh, see the @i[Rand MH Message Handling
-System Tutorial] and the @i[Rand MH Message Handling System Manual].
-
-The @hemlock interface to @mh provides a means for generating header (@f[scan])
-lines for messages and displaying these headers in a @hid[Headers] buffer.
-This allows the user to operate on the @i[current message] as indicated by the
-position of the cursor in the @hid[Headers] buffer.  The user can read, reply
-to, forward, refile, or perform various other operations on the current
-message.  A user typically generates a @hid[Headers] buffer with the commands
-@hid[Message Headers] or @hid[Incorporate and Read New Mail], and multiple such
-buffers may exist simultaneously.
-
-Reading a message places its text in a @hid[Message] buffer.  In a manner
-similar to a @hid[Headers] buffer, this allows the user to operate on that
-message.  Most @hid[Headers] buffer commands behave the same in a @hid[Message]
-buffer.  For example, the @hid[Reply to Message] command has the same effect in
-both @hid[Headers] mode and @hid[Message] mode.  It creates a @hid[Draft]
-buffer and makes it the current buffer so that the user may type a reply to the
-current message.
-
-The @hid[Send Message] command originates outgoing mail.  It generates a
-@hid[Draft] buffer in which the user composes a mail message.  Each @hid[Draft]
-buffer has an associated pathname, so the user can save the buffer to a file as
-necessary.  Invoking @hid[Send Message] in a @hid[Headers] or @hid[Message]
-buffer associates the @hid[Draft] buffer with a @hid[Message] buffer.  This
-allows the user to easily refer to the message being replied to with the
-command @hid[Goto Message Buffer].  After the user composes a draft message, he
-can deliver the message by invoking the @hid[Deliver Message] command in the
-@hid[Draft] buffer (which deletes both the this buffer and any associated
-@hid[Message] buffer), or he can delay this action.  Invoking @hid[Deliver
-Message] when not in a @hid[Draft] buffer causes it to prompt for a draft
-message ID, allowing previously composed and saved messages to be delivered
-(even across distinct Lisp invocations).
-
-@index[virtual message deletion]
-The @hemlock mail system provides a mechanism for @i[virtual message deletion].
-That is, the @hid[Delete Message] command does not immediately delete a message
-but merely flags the message for future deletion.  This allows the user to
-undelete the messages with the @hid[Undelete Message] command.  The
-@hid[Expunge Messages] command actually removes messages flagged for deletion.
-After expunging a deleted message, @hid[Undelete Messages] can no longer
-retrieve it.  Commands that read messages by sequencing through a @hid[Headers]
-buffer typically ignore those marked for deletion, which makes for more fluid
-reading if a first pass has been made to delete uninteresting messages.
-
-After handling messages in a @hid[Headers] buffer, there may be messages
-flagged for deletion and possibly multiple @hid[Message] buffers lying around.
-There is a variety of commands that help @i[terminate] a mail session.
-@hid[Expunge Messages] will flush the messages to be deleted, leaving the
-buffer in an updated state.  @hid[Delete Headers Buffer and Message Buffers]
-will delete the @hid[Headers] buffer and its corresponding @hid[Message]
-buffers.  @hid[Quit Headers] is a combination of these two commands in that it
-first expunges messages and then deletes all the appropriate buffers.
-
-One does not have to operate only on messages represented in a @hid[Headers]
-buffer.  This is merely the nominal mode of interaction.  There are commands
-that prompt for a folder, an @mh message specification (for example, "@f[1 3 6
-last]", "@f[1-3 5 6]", "@f[all]", "@f[unseen]"), and possibly a @f[pick]
-expression.  @f[Pick] expressions allow messages to be selected based on header
-field pattern matching, body text searching, and date comparisons; these can be
-specified using either a Unix shell-like/switch notation or a Lisp syntax,
-according to one's preference.  See section @ref[scanning] for more details.
-
-A @i[mail-drop] is a file where a Unix-based mail system stores all messages a
-user receives.  The user's mail handling program then fetches these from the
-mail-drop, allowing the user to operate on them.  Traditionally one locates his
-mail-drop and mail directory on a mainframe machine because the information on
-mainframes is backed up on magnetic tape at least once per day.  Since @hemlock
-only runs under CMU @clisp on workstations, and one's mail directory is not
-usually world writable, it is not possible to adhere to a standard arrangement.
-Since @mh provides for a remote mail-drop, and CMU's Remote File System has a
-feature allowing authentication across a local area network, one can use
-@hemlock to fetch his mail from a mainframe mail-drop (where it is backed up
-before @hemlock grabs it) and store it on his workstation.  Reading mail on a
-workstation is often much faster and more comfortable because typically it is a
-single user machine.  Section @ref[backing-up] describes how to back up one's
-mail directory from a workstation to a mainframe.
-
-
-@section[Constraints on MH to use Hemlock's Interface]
-
-@index[constraints for mail interface]@label[constraints]
-There are a couple constaints placed on the user of the @hemlock interface to
-@mh.  The first is that there must be a draft folder specified in one's @mh
-profile to use any command that sends mail.  Also, to read new mail, there must
-be an @f[Unseen-Sequence:] component in one's @mh profile.  The default @mh
-profile does not specify these components, so they must be added by the user.
-The next section of this chapter describes how to add these components.
-Another constraint is that @hemlock requires its own @f[scan] line format to
-display headers lines in a @hid[Headers] buffer.  See the description of the
-variable @hid[MH Scan Line Form] for details.
-
-
-@section[Setting up MH]
-
-@index[setting up the mail interface]@label[setting-up]
-@index[mail profile]@index[MH profile]
-Get an @mh default profile and mail directory by executing the @mh @f[folder]
-utility in a Unix shell.  When it asks if it should make the "@f[inbox]"
-folder, answer "@b[yes]".  This creates a file called "@f[.mh_profile]" in the
-user's home directory and a directory named "@f[Mail]".
-
-Edit the "@f[.mh_profile]" file inserting two additional lines.  To send mail
-in @hemlock, the user must indicate a draft folder by adding a
-@f[Draft-Folder:] line with a draft folder name @dash "@f[drafts]" is a common
-name:
-@begin[example]
-Draft-Folder: drafts
-@end[example]
-
-Since the mail-drop exists on a remote machine, the following line must
-also be added:
-@begin[example]
-MailDrop: /../<hostname>/usr/spool/mail/<username>
-@end[example]
-
-Since the user's mail-drop is on a separate machine from his mail directory
-(and where the user runs @hemlock), it is necessary to issue the following
-command from the Unix shell (on the workstation).  This only needs to be done
-once.
-@begin[programexample]
-/usr/cs/etc/rfslink -host <hostname> /usr/spool/mail/<username>
-@end[programexample]
-Note that @b[<hostname>] is not a full ARPANET domain-style name.  Use an
-abbreviated CMU host name (for example, "@b[spice]" not
-"@b[spice.cs.cmu.edu]").
-
-
-@section[Profile Components and Customized Files]
-
-@subsection[Profile Components]
-
-@label[Profile] 
-The following are short descriptions about profile components that are either
-necessary to using @hemlock's interface to @mh or convenient for using @mh in
-general:
-
-@begin[description]
-@f[Path:]@\
-This specifies the user's mail directory.  It can be either a full pathname or
-a pathname relative to the user's home directory.  This component is
-@i[necessary] for using @mh.
-
-@f[MailDrop:]@\
-This is used to specify one's remote mail-drop.  It is @i[necessary] for
-@hemlock only when using a mail-drop other than "@f[/usr/spool/mail/<user>]" on
-the local machine.
-
-@f[Folder-Protect:], @f[Msg-Protect:]@\
-These are set to 700 and 600 respectively to keep others from reading one's
-mail.  At one time the default values were set for public visibility of mail
-folders.  Though this is no longer true, these can be set for certainty.  The
-700 protection allows only user read, write, and execute (list access for
-directories), and 600 allows only user read and write.  These are not necessary
-for either @mh or the @hemlock interface.
-
-@f[Unseen-Sequence:]@\
-When mail is incorporated, new messages are added to this sequence, and as
-these messages are read they are removed from it.  This allows the user at any
-time to invoke an @mh program on all the unseen messges of a folder easily.  An
-example definition is:
-@begin[example]
-Unseen-Sequence: unseen
-@end[example]
-Specifying an unseen-sequence is @i[necessary] to use @hemlock's
-interface to @mh.
-
-@f[Alternate-Mailboxes:]@\
-This is not necessary for either @mh or the @hemlock interface.  This
-component tells @mh which addresses that it should recognize as the user.  This
-is used for @f[scan] output formatting when the mail was sent by the user.  It
-is also used by @f[repl] when it sets up headers to know who the user is for
-inclusion or exclusion from @b[cc]: lists.  This is case sensitive and takes
-wildcards.  One example is:
-@begin[example]
-Alternate-Mailboxes: *FRED*, *Fred*, *fred*
-@end[example]
-
-@f[Draft-Folder:]@\
-This makes multiple draft creation possible and trivial to use.  Just supply a
-folder name (for example, "@f[drafts]").  Specifying a draft-folder is
-@i[necessary] to use @hemlock's interface to @mh.
-
-@f[repl: -cc all -nocc me -fcc out-copy]@\
-This tells the @f[repl] utility to include everyone but the user in the
-@b[cc:] list when replying to mail.  It also makes @f[repl] keep an copy of the
-message the user sends.  This is mentioned because one probably wants to reply
-to everyone receiving a piece of mail except oneself.  Unlike other utilities
-that send mail, @f[repl] stores personal copies of outgoing mail based on a
-command line switch.  Other @mh utilities use different mechanisms.  This line
-is not necessary to use either @mh or the @hemlock interface.
-
-@f[rmmproc: /usr/cs/bin/rm]@\
-This is not necessary to use @hemlock's interface to @mh, but due to
-@hemlock's virtual message deletion feature, this causes messages to be deleted
-from folder directories in a cleaner fashion when they actually get removed.
-Note that setting this makes @f[rmm] more treacherous if used in the Unix
-shell.
-@end[description]
-@;
-
-
-@subsection[Components Files]
-@index[components]
-@label[components-files]
-@i[Components] files are templates for outgoing mail header fields that specify
-position and sometimes values for specified fields.  Example files are shown
-for each one discussed here.  These should exist in the user's mail directory.
-
-For originating mail there is a components file named "@f[components]", and it
-is used by the @mh utility @f[comp].  An example follows:
-@begin[example]
-   To: 
-   cc: 
-   fcc: out-copy
-   Subject: 
-   --------
-@end[example]
-This example file differs from the default by including the @f[fcc:] line.
-This causes @mh to keep a copy of the outgoing draft message.  Also, though it
-isn't visible here, the @f[To:], @f[cc:], and @f[Subject:] lines have a space
-at the end.
-
-@index[forwarding components]
-The "@f[forwcomps]" components file is a template for the header fields of any
-forwarded message.  Though it may be different, our example is the same as the
-previous one.  These are distinct files for @mh's purposes, and it is more
-flexible since the user might not want to keep copies of forwarded messages.
-
-@index[reply components]
-The "@f[replcomps]" components file is a template for the header fields of any
-draft message composed when replying to a message.  An example
-follows:
-@begin[example]
-   %(lit)%(formataddr %<{reply-to}%|%<{from}%|%{sender}%>%>)\
-   %<(nonnull)%(void(width))%(putaddr To: )\n%>\
-   %(lit)%(formataddr{to})%(formataddr{cc})%(formataddr(me))\
-   %(formataddr{resent-to})\
-   %<(nonnull)%(void(width))%(putaddr cc: )\n%>\
-   %<{fcc}Fcc: %{fcc}\n%>\
-   %<{subject}Subject: Re: %{subject}\n%>\
-   %<{date}In-reply-to: Your message of \
-   %<(nodate{date})%{date}%|%(tws{date})%>.%<{message-id}
-		%{message-id}%>\n%>\
-   --------
-@end[example]
-This example file differs from the default by including the @b[resent-to:]
-field (in addition to the @b[to:] and @b[cc:] fields) of the message being
-replied to in the @b[cc:] field of the draft.  This is necessary for replying
-to all recipients of a distributed message.  Keeping a copy of the outgoing
-draft message works a little differently with reply components.  @mh expects a
-switch which the user can put in his profile (see section @ref[Profile] of this
-chapter), and using the @mh formatting language, this file tests for the
-@f[fcc] value as does the standard file.
-
-
-@section[Backing up the Mail Directory]
-@index[backing up mail directories]
-@label[backing-up]
-The easiest method of backing up a protected mail directory is to copy it into
-an Andrew File System (AFS) directory since these are backed up daily as with
-mainframes.  The only problem with this is that the file servers may be down
-when one wants to copy his mail directory since, at the time of this writing,
-these servers are still under active development; however, they are becoming
-more robust daily.  One can read about the current AFS status in the file
-@f[/../fac/usr/gripe/doc/vice/status].
-
-Using AFS, one could keep his actual mail directory (not a copy thereof) in his
-AFS home directory which eliminates the issue of backing it up.  This is
-additionally beneficial if the user does not use the same workstation everyday
-(that is, he does not have his own but shares project owned machines).  Two
-problems with this arrangement result from the AFS being a distributed file
-system.  Besides the chance that the server will be down when the user wants to
-read mail, performance degrades since messages must always be referenced across
-the local area network.
-
-Facilities' official mechanism for backing up protected directories is called
-@f[sup].  This is awkward to use and hard to set up, but a subsection here
-describes a particular arrangement suitable for the user's mail directory.
-
-
-@subsection[Andrew File System]
-If the user choses to use AFS, he should get copies of @i[Getting Started with
-the Andrew File System] and @i[Protecting AFS files and directories].  To use
-AFS, send mail to Gripe requesting an account.  When Gripe replies with a
-password, change it to be the same as the account's password on the
-workstation.  This causes the user to be authenticated into AFS when he logs
-into his workstation (that is, he is automatically logged into his AFS
-account).  To change the password, first log into the AFS account:
-@begin[programexample]
-log <AFS userid>
-@end[programexample]
-Then issue the @f[vpasswd] command.
-
-All of the example command lines in this section assume the user has
-@f[/usr/misc/bin] on his Unix shell @f[PATH] environment variable.
-
-@paragraph[Copy into AFS:]
-
-Make an AFS directory to copy into:
-@begin[programexample]
-mkdir /afs/cs.cmu.edu/user/<AFS userid>/mail-backup
-@end[programexample]
-
-This will be readable by everyone, so protect it with the following:
-@begin[programexample]
-fs sa /afs/cs.cmu.edu/user/<AFSuserid>/mail-backup System:AnyUser none
-@end[programexample]
-
-Once the AFS account and directory to backup into have been established, the
-user needs a means to recursively copy his mail directory updating only those
-file that have changed and deleting those that no longer exist.  To do this,
-issue the following command:
-@begin[programexample]
-copy -2 -v -R <mail directory> <AFS backup directory>
-@end[programexample]
-Do not terminate either of these directory specifications with a @f[/].  The
-@f[-v] switch causes @f[copy] to output a line for copy and deletion, so this
-may be eliminated if the user desires.
-
-@paragraph[Mail Directory Lives in AFS:]
-
-Assuming the AFS account has been established, and the user has followed the
-directions in @ref[setting-up], now make an AFS directory to serve as the mail
-directory:
-@begin[programexample]
-mkdir /afs/cs.cmu.edu/user/<AFS userid>/Mail
-@end[programexample]
-
-This will be readable by everyone, so protect it with the following:
-@begin[programexample]
-fs sa /afs/cs.cmu.edu/user/<AFSuserid>/Mail System:AnyUser none
-@end[programexample]
-
-Tell @mh where the mail directory is by modifying the profile's
-"@f[.mh_profile]" (see section @ref[setting-up]) @f[Path:] component (see
-section @ref[Profile]):
-@begin[programexample]
-Path: /afs/cs.cmu.edu/user/<AFS userid>/Mail
-@end[programexample]
-
-
-@subsection[Sup to a Mainframe]
-To use @f[sup] the user must set up a directory named "@f[sup]" on the
-workstation in the user's home directory.  This contains different directories
-for the various trees that will be backed up, so there will be a "@f[Mail]"
-directory.  This directory will contain two files: "@f[crypt]" and "@f[list]".
-The "@f[crypt]" file contains one line, terminated with a new line, that
-contains a single word @dash an encryption key.  "@f[list]" contains one line,
-terminated with a new line, that contains two words @dash "@b[upgrade Mail]".
-
-On the user's mainframe, a file must be created that will be supplied to the
-@f[sup] program.  It should contain the following line to backup the mail
-directory:
-
-@begin[example]
-Mail delete host=<workstation> hostbase=/usr/<user> base=/usr/<user> \
-crypt=WordInCryptFile login=<user> password=LoginPasswordOnWorkstation
-@end[example]
-Warning: @i[This file contains the user's password and should be
-protected appropriately.] 
-
-The following Unix shell command issued on the mainframe will backup the
-mail directory:
-
-@begin[programexample]
-   sup <name of the sup file used in previous paragraph>
-@end[programexample]
-
-As a specific example, assume user "@f[fred]" has a workstation called
-"@f[fred]", and his mainframe is the "@f[gpa]" machine where he has another
-user account named "@f[fred]".  The password on his workstation is
-"@f[purple]".  On his workstation, he creates the directory
-"@f[/usr/fred/sup/Mail/]" with the two files "@f[crypt]" and "@f[list]".
-The file "@f[/usr/fred/sup/Mail/crypt]" contains only the encryption key:
-@programexample[steppenwolf]
-The file "@f[/usr/fred/sup/Mail/list]" contains the command to upgrade the
-"@f[Mail]" directory:
-@programexample[upgrade Mail]
-
-On the "@f[gpa]" machine, the file "@f[/usr/fred/supfile]" contains the
-following line:
-@begin[programexample]
-Mail delete host=fred hostbase=/usr/fred base=/usr/fred \
-crypt=steppenwolf login=fred password=purple
-@end[programexample]
-This file is protected on "@f[gpa]", so others cannot see @f[fred's] password
-on his workstation.
-
-On the gpa-vax, issuing
-@begin[programexample]
-   sup /usr/fred/supfile
-@end[programexample]
-to the Unix shell will update the @mh mail directory from @f[fred's]
-workstation deleting any files that exist on the gpa that do not exist on the
-workstation.
-
-For a more complete description of the features of @f[sup], see the @i[UNIX
-Workstation Owner's Guide] and @i[The SUP Software Upgrade Protocol].
-
-@section[Introduction to Commands and Variables]
-
-@index[mail commands]@index[mail variables]@label[mhcommands]
-Unless otherwise specified, any command which prompts for a folder name will
-offer the user a default.  Usually this is @mh's idea of the current folder,
-but sometimes it is the folder name associated with the current buffer if there
-is one.  When prompting for a message, any valid @mh message expression may be
-entered (for example, "@f[1 3 6]", "@f[1-3 5 6]", "@f[unseen]", "@f[all]").
-Unless otherwise specified, a default will be offered (usually the current
-message).
-
-Some commands mention specific @mh utilities, so the user knows how the
-@hemlock command affects the state of @mh and what profile components and
-special formatting files will be used.  @hemlock runs the @mh utility programs
-from a directory indicated by the following variable:
-
-@defhvar[var "MH Utility Pathname", val {"/usr/misc/.mh/bin/"}]
-@mh utility names are merged with this pathname to find the executable
-files. 
-@enddefhvar
-
-
-@section[Scanning and Picking Messages]
-@label[scanning]
-As pointed out in the introduction of this chapter, users typically generate
-headers or @f[scan] listings of messages with @hid[Message Headers], using
-commands that operate on the messages represented by the headers.  @hid[Pick
-Headers] (bound to @bf[h] in @hid[Headers] mode) can be used to narrow down (or
-further select over) the headers in the buffer.
-
-A @f[pick] expression may be entered using either a Lisp syntax or a Unix
-shell-like/switch notation as described in the @mh documentation.  The Lisp
-syntax is as follows:
-
-@begin[example]
-   <exp>       ::=  {(not <exp>) | (and <exp>*) | (or <exp>*)
-		    | (cc <pattern>) | (date <pattern>)
-		    | (from <pattern>) | (search <pattern>)
-		    | (subject <pattern>) | (to <pattern>)
-		    | (-- <component> <pattern>)
-		    | (before <date>) | (after <date>)
-		    | (datefield <field>)}
-
-   <pattern>   ::=  {<string> | <symbol>}
-
-   <component> ::=  {<string> | <symbol>}
-
-   <date>      ::=  {<string> | <symbol> | <number>}
-
-   <field>     ::=  <string>
-@end[example]
-
-Anywhere the user enters a @f[<symbol>], its symbol name is used as a string.
-Since @hemlock @f[read]s the expression without evaluating it, single quotes
-("@bf[']") are unnecessary.  From the @mh documentation,
-
-@begin[itemize]
-   A @f[<pattern>] is a Unix @f[ed] regular expression.  When using a string to
-   input these, remember that @f[\] is an escape character in Common Lisp.
-
-   A @f[<component>] is a header field name (for example, @b[reply-to] or
-   @b[resent-to]).
-
-   A @f[<date>] is an @i[822]-style specification, a day of the week,
-   "@b[today]", "@b[yesterday]", "@b[tomorrow]", or a number indicating @i[n]
-   days ago.  The @i[822] standard is basically:
-   @begin[example]
-   dd mmm yy hh:mm:ss zzz
-   @end[example]
-   which is a two digit day, three letter month (first letter capitalized), two
-   digit year, two digit hour (@f[00] through @f[23]), two digit minute, two
-   digit second (this is optional), and a three letter zone (all capitalized).
-   For
-   example:
-   @begin[example]
-   21 Mar 88 16:00 EST
-   @end[example]
-   
-   A @f[<field>] is an alternate @f[Date:] field to use with @f[(before
-   <date>)] and @f[(after <date>)] such as @f[BB-Posted:] or
-   @f[Delivery-Date:].
-
-   Using @f[(before <date>)] and @f[(after <date>)] causes date field parsing,
-   while @f[(date <pattern>)] does string pattern matching.
-@end[itemize]
-
-Since a @f[<pattern>] may be a symbol or string, it should be noted that the
-symbol name is probably all uppercase characters, and @mh will match these
-only against upper case.  @mh will match lowercase characters against lower
-and upper case.  Some examples are:
-@begin[example]
-   ;;; All messages to Gripe.
-   (to "gripe")
-
-   ;;; All messages to Gripe or about Hemlock.
-   (or (to "gripe") (subject "hemlock"))
-
-   ;;; All messages to Gripe with "Hemlock" in the body.
-   (and (to "gripe") (search "hemlock"))
-@end[example]
-
-Matching of @f[<component>] fields is case sensitive, so this example will
-@f[pick] over all messages that have been replied to.
-@example[(or (-- "replied" "") (-- "Replied" ""))]
-
-
-@defhvar[var "MH Scan Line Form", val {"library:mh-scan"}]
-This is a pathname of a file containing an @mh format expression used for
-header lines.
-
-The header line format must display the message ID as the first non-whitespace
-item.  If the user uses the virtual message deletion feature which is on by
-default, there must be a space three characters to the right of the message ID.
-This location is used on header lines to note that a message is flagged for
-deletion.  The second space after the message ID is used for notating answered
-or replied-to messages.
-@enddefhvar
-
-@defcom[com "Message Headers", bind (C-x r)]
-This command prompts for a folder, message (defaulting to "@b[all]"), and an
-optional @f[pick] expression.  Typically this will simply be used to generate
-headers for an entire folder or sequence, and the @f[pick] expression will not
-be used.  A new @hid[Headers] buffer is made, and the output of @f[scan] on the
-messages indicated is inserted into the buffer.  The current window is used,
-the buffer's point is moved to the first header, and the @hid[Headers] buffer
-becomes current.  The current value of the @hemlock @hid[Fill Column] variable
-is supplied to @f[scan] as the @f[-width] switch.  The buffer name is set to a
-string of the form @w<"@f[Headers <folder> <msgs> <pick expression>]">, so the
-modeline will show what is in the buffer.  If no @f[pick] expression was
-supplied, none will be shown in the buffer's name.  As described in the
-introduction to this section, the expression may be entered using either a Lisp
-syntax or a Unix shell-like/switch notation.
-@enddefcom
-
-@defhvar[var "MH Lisp Expression", val {t}]
-When this is set, @mh expression prompts are read in a Lisp syntax.  Otherwise,
-the input is of the form of a Unix shell-like/switch notation as described in
-the @mh documentation.
-@enddefhvar
-
-@defcom[com "Pick Headers", stuff (bound to @bf[h] in @hid[Headers] mode) ]
-This command is only valid in a @hid[Headers] buffer.  It prompts for a
-@f[pick] expression, and the messages shown in the buffer are supplied to
-@f[pick] with the expression.  The resulting messages are @f[scan]'ed, deleting
-the previous contents of the buffer.  The current value of @hid[Fill Column] is
-used for the @f[scan]'ing.  The buffer's point is moved to the first header.
-The buffer's name is set to a string of the form @w<"@f[Headers <folder> <msgs
-picked over> <pick expression>]">, so the modeline will show what is in the
-buffer.  As described in the introduction to this section, the expression may
-be entered using either a Lisp syntax or a Unix shell-like/switch notation.
-@enddefcom
-
-@defcom[com "Headers Help", bind (Headers: ?)]
-This command displays documentation on @hid[Headers] mode.
-@enddefcom
-
-
-@section[Reading New Mail]
-
-@index[reading new mail]@label[reading-new-mail]
-
-@defcom[com "Incorporate and Read New Mail", stuff (bound to @bf[C-x i] globally and @bf[i] in @hid[Headers] and @hid[Message] modes) ]
-This command incorporates new mail into @hid[New Mail Folder] and creates a
-@hid[Headers] buffer with the new messages.  An unseen-sequence must be define
-in the user's @mh profile to use this.  Any headers generated due to
-@hid[Unseen Headers Message Spec] are inserted as well.  The buffer's point is
-positioned on the headers line representing the first unseen message of the
-newly incorporated mail.
-@enddefcom
-
-@defcom[com "Incorporate New Mail" ]
-This command incorporates new mail into @hid[New Mail Folder], displaying
-@f[inc] output in a pop-up window.  This is similar to @hid[Incorporate and
-Read New Mail] except that no @hid[Headers] buffer is generated.
-@enddefcom
-
-@defhvar[var "New Mail Folder", val {"+inbox"}]
-This is the folder into which @mh incorporates new mail.
-@enddefhvar
-
-@defhvar[var "Unseen Headers Message Spec", val {nil}]
-This is an @mh message specification that is suitable for any message prompt.
-When incorporating new mail and after expunging messages, @hemlock uses this
-specification in addition to the unseen-sequence name that is taken from the
-user's @mh profile to generate headers for the unseen @hid[Headers] buffer.
-This value is a string.
-@enddefhvar
-
-@defhvar[var "Incorporate New Mail Hook", val {nil}]
-This is a list of functions which are invoked immediately after new mail is
-incorporated.  The functions should take no arguments.
-@enddefhvar
-
-@defhvar[var "Store Password", val {nil}]
-When this is set, the user is only prompted once for his password, and the
-password is stored for future use.
-@enddefhvar
-
-@defhvar[var "Authenticate Incorporation", val {nil}]
-@defhvar1[var "Authentication User Name", val {nil}]
-When @hid[Authenticate Incorporation] is set, incorporating new mail prompts
-for a password to access a remote mail-drop.
-
-When incorporating new mail accesses a remote mail-drop, @hid[Authentication
-User Name] is the user name supplied for authentication on the remote machine.
-If this is @nil, @hemlock uses the local name.
-@enddefhvar
-
-
-@section[Reading Messages]
-@index[reading messages]
-@label[reading-messages]
-This section describes basic commands that show the current, next, and previous
-messages, as well as a couple advanced commands.  @hid[Show Message] (bound to
-@bf[SPACE] in @hid[Headers] mode) will display the message represented by the
-@f[scan] line the @hemlock cursor is on.  Deleted messages are considered
-special, and the more conveniently bound commands for viewing the next and
-previous messages (@hid[Next Undeleted Message] bound to @bf[n] and
-@hid[Previous Undeleted Message] bound to @bf[p], both in @hid[Headers] and
-@hid[Message] modes) will ignore them.  @hid[Next Message] and @hid[Previous
-Message] (bound to @bf[M-n] and @bf[M-p] in @hid[Headers] and @hid[Message]
-modes) may be invoked if reading a message is desired regardless of whether it
-has been deleted.
-
-
-@defcom[com "Show Message", stuff (bound to @bf[SPACE] and @bf[.] in @hid[Headers] mode) ]
- This command, when invoked in a @hid[Headers] buffer, displays the current
-message (the message the cursor is on), by replacing any previous message that
-has not been preserved with @hid[Keep Message].  The current message is also
-removed from the unseen sequence.  The @hid[Message] buffer becomes the current
-buffer using the current window.  The buffer's point will be moved to the
-beginning of the buffer, and the buffer's name will be set to a string of the
-form @w<"@f[Message <folder> <msg-id>]">.
-
-The @hid[Message] buffer is read-only and may not be modified.  The command
-@hid[Goto Headers Buffer] issued in the @hid[Message] buffer makes the
-associated @hid[Headers] buffer current.
-
-When not in a @hid[Headers] buffer, this command prompts for a folder and
-message.  A unique @hid[Message] buffer is obtained, and its name is set to a
-string of the form @w<"@f[Message <folder> <msg-id>]">.  The buffer's point is
-moved to the beginning of the buffer, and the current window is used to display
-the message.
-
-Specifying multiple messages inserts all the messages into the same buffer.  If
-the user wishes to show more than one message, it is expected that he will
-generate a @hid[headers] buffer with the intended messages, and then use the
-message sequencing commands described below.
-@enddefcom
-
-@defcom[com "Next Message", stuff (bound to @bf[M-n] in @hid[Headers] and @hid[Message] modes) ]
- This command is only meaningful in a @hid[Headers] buffer or a @hid[Message]
-buffer associated with a @hid[Headers] buffer.  In a @hid[Headers] buffer, the
-point is moved to the next message, and if there is one, it is shown as
-described in the @hid[Show Message] command.
-
-In a @hid[Message] buffer, the message after the currently visible message is
-displayed.  This clobbers the buffer's contents.  Note, if the @hid[Message]
-buffer is associated with a @hid[Draft] buffer, invoking this command breaks
-that association.  Using @hid[Keep Message] preserves the @hid[Message] buffer
-and any association with a @hid[Draft] buffer.
-
-The @hid[Message] buffer's name is set as described in the @hid[Show Message]
-command.
-@enddefcom
-
-@defcom[com "Previous Message", stuff (bound to @bf[M-p] in @hid[Headers] and @hid[Message] modes) ]
- This command is only meaningful in a @hid[Headers] buffer or a @hid[Message]
-buffer associated with a @hid[Headers] buffer.  In a @hid[Headers] buffer, the
-point is moved to the previous message, and if there is one, it is shown as
-described in the @hid[Show Message] command.
-
-In a @hid[Message] buffer, the message before the currently visible message is
-displayed.  This clobbers the buffer's contents.  Note, if the @hid[Message]
-buffer is associated with a @hid[Draft] buffer, invoking this command breaks
-that association.  Using @hid[Keep Message] preserves the @hid[Message] buffer
-and any association with a @hid[Draft] buffer.
-
-The @hid[Message] buffer's name is set as described in the @hid[Show Message]
-command.
-@enddefcom
-
-@defcom[com "Next Undeleted Message", stuff (bound to @bf[n] in @hid[Headers] and @hid[Message] modes) ]
- This command is only meaningful in a @hid[Headers] buffer or a @hid[Message]
-buffer associated with a @hid[Headers] buffer.  In a @hid[Headers] buffer, the
-point is moved to the next undeleted message, and if there is one, it is shown
-as described in the @hid[Show Message] command.
-
-In a @hid[Message] buffer, the first undeleted message after the currently
-visible message is displayed.  This clobbers the buffer's contents.  Note, if
-the @hid[Message] buffer is associated with a @hid[Draft] buffer, invoking this
-command breaks that association.  The @hid[Keep Message] command preserves the
-@hid[Message] buffer and any association with a @hid[Draft] buffer.
-
-The @hid[Message] buffer's name is set as described in the @hid[Show Message]
-command.
-@enddefcom
-
-@defcom[com "Previous Undeleted Message", stuff (bound to @bf[p] in @hid[Headers] and @hid[Message] modes) ]
- This command is only meaningful in a @hid[Headers] buffer or a @hid[Message]
-buffer associated with a @hid[Headers] buffer.  In a @hid[Headers] buffer, the
-point is moved to the previous undeleted message, and if there is one, it is
-shown as described in the @hid[Show Message] command.
-
-In a @hid[Message] buffer, the first undeleted message before the currently
-visible message is displayed.  This clobbers the buffer's contents.  Note, if
-the @hid[Message] buffer is associated with a @hid[Draft] buffer, invoking this
-command breaks that association.  The @hid[Keep Message] command preserves the
-@hid[Message] buffer and any association with a @hid[Draft] buffer.
-
-The @hid[Message] buffer's name is set as described in the @hid[Show Message]
-command.
-@enddefcom
-
-@defcom[com "Scroll Message", stuff (bound to @bf[SPACE] and @bf[C-v] in @hid[Message] mode) ]
-@defhvar1[var "Scroll Message Showing Next", val {t}]
- This command scrolls the current window down through the current message.  If
-the end of the message is visible and @hid[Scroll Message Showing Next] is not
-@nil, then show the next undeleted message.
-@enddefcom
-
-@defcom[com "Keep Message" ]
-This command can only be invoked in a @hid[Message] buffer.  It causes the
-@hid[Message] buffer to continue to exist when the user invokes commands to
-view other messages either within the kept @hid[Message] buffer or its
-associated @hid[Headers] buffer.  This is useful for getting two messages into
-different buffers.  It is also useful for retaining @hid[Message] buffers which
-would otherwise be deleted when an associated draft message is delivered.
-@enddefcom
-
-@defcom[com "Message Help", bind (Message: ?)]
-This command displays documentation on @hid[Message] mode.
-@enddefcom
-
-
-@section[Sending Messages]
-@index[sending messages]
-@label[sending-messages]
-The most useful commands for sending mail are @hid[Send Message] (bound to
-@bf[m] and @bf[s] in @hid[Headers] and @hid[Message] modes), @hid[Reply to
-Message] (bound to @bf[r] in @hid[Headers] mode), and @hid[Reply to Message in
-Other Window] (bound to @bf[r] in @hid[Message] mode).  These commands set up a
-@hid[Draft] buffer and associate a @hid[Message] buffer with the draft when
-possible.  To actually deliver the message to its recipient(s), use
-@hid[Deliver Message] (bound to @bf[H-s] in @hid[Draft] mode).  To abort
-sending mail, use @hid[Delete Draft and Buffer] (bound to @bf[H-q] in
-@hid[Draft] mode).  If one wants to temporarily stop composing a draft with the
-intention of finishing it later, then the @hid[Save File] command (bound to
-@bf[C-x C-s]) will save the draft to the user's draft folder.
-
-@hid[Draft] buffers have a special @hemlock minor mode called @hid[Draft] mode.
-The major mode of a @hid[Draft] buffer is taken from the @hid[Default Modes]
-variable.  The user may wish to arrange that @hid[Text] mode (and possibly
-@hid[Fill] mode or @hid[Save] mode) be turned on whenever @hid[Draft] mode is
-set.  For a further description of how to manipulate modes in @hemlock see the
-@i[Hemlock Command Implementor's Manual].
-
-
-@defcom[com "Send Message", stuff (bound to @bf[s] and @bf[m] in @hid[Headers] and @hid[Message] modes and @bf[C-x m] globally) ]
- This command, when invoked in a @hid[Headers] buffer, creates a unique
-@hid[Draft] buffer and a unique @hid[Message] buffer.  The current message is
-inserted in the @hid[Message] buffer, and the @hid[Draft] buffer is displayed
-in the current window.  The @hid[Draft] buffer's point is moved to the end of
-the line containing @f[To:] if it exists.  The name of the draft message file
-is used to produce the buffer's name.  A pathname is associated with the
-@hid[Draft] buffer so that @hid[Save File] can be used to incrementally save a
-composition before delivering it.  The @f[comp] utility will be used to
-allocate a draft message in the user's @mh draft folder and to insert the
-proper header components into the draft message.  Both the @hid[Draft] and
-@hid[Message] buffers are associated with the @hid[Headers] buffer, and the
-@hid[Draft] buffer is associated with the @hid[Message] buffer.
-
-When invoked in a @hid[Message] buffer, a unique @hid[Draft] buffer is created,
-and these two buffers are associated.  If the @hid[Message] buffer is
-associated with a @hid[Headers] buffer, this association is propagated to the
-@hid[Draft] buffer.  Showing other messages while in this @hid[Headers] buffer
-will not affect this @hid[Message] buffer.
-
-When not in a @hid[Headers] or @hid[Message] buffer, this command does the same
-thing as described in the previous two cases, but there are no @hid[Message] or
-@hid[Headers] buffer manipulations.
-
-@hid[Deliver Message] will deliver the draft to its intended recipient(s).
-
-The @hid[Goto Headers Buffer] command, when invoked in a @hid[Draft] or
-@hid[Message] buffer, makes the associated @hid[Headers] buffer current.  The
-@hid[Goto Message Buffer] command, when invoked in a @hid[Draft] buffer, makes
-the associated @hid[Message] buffer current.
-@enddefcom
-
-@defcom[com "Reply to Message", stuff (bound to @bf[r] in @hid[Headers] mode) ]
-@defcom1[com "Reply to Message in Other Window", stuff (bound to @bf[r] in @hid[Message] mode) ]
-@defhvar1[var "Reply to Message Prefix Action"]
- @hid[Reply to Message], when invoked in a @hid[Headers] buffer, creates a
-unique @hid[Draft] buffer and a unique @hid[Message] buffer.  The current
-message is inserted in the @hid[Message] buffer, and the @hid[Draft] buffer is
-displayed in the current window.  The draft components are set up in reply to
-the message, and the @hid[Draft] buffer's point is moved to the end of the
-buffer.  The name of the draft message file is used to produce the buffer's
-name.  A pathname is associated with the @hid[Draft] buffer so that @hid[Save
-File] can be used to incrementally save a composition before delivering it.
-The @f[repl] utility will be used to allocate a draft message file in the
-user's @mh draft folder and to insert the proper header components into the
-draft message.  Both the @hid[Draft] and @hid[Message] buffers are associated
-with the @hid[Headers] buffer, and the @hid[Draft] buffer is associated with
-the @hid[Message] buffer.
-
-When invoked in a @hid[Message] buffer, a unique @hid[Draft] buffer is set up
-using the message in the buffer as the associated message.  Any previous
-association between the @hid[Message] buffer and a @hid[Draft] buffer is
-removed.  Any association of the @hid[Message] buffer with a @hid[Headers]
-buffer is propagated to the @hid[Draft] buffer.
-
-When not in a @hid[Headers] buffer or @hid[Message] buffer, this command
-prompts for a folder and message to reply to.  This message is inserted into a
-unique @hid[Message] buffer, and a unique @hid[Draft] buffer is created as in
-the previous two cases.  There is no association of either the @hid[Message]
-buffer or the @hid[Draft] buffer with a @hid[Headers] buffer.
-
-When a prefix argument is supplied, @hid[Reply to Message Prefix Action] is
-considered with respect to supplying carbon copy switches to @f[repl].  This
-variable's value is one of @b[:cc-all], :@b[no-cc-all], or @nil.  See section
-@ref[Styles] for examples of how to use this.
-
-@hid[Reply to Message in Other Window] is identical to @hid[Reply to Message],
-but the current window is split showing the @hid[Draft] buffer in the new
-window.  The split window displays the @hid[Message] buffer.
-
-@hid[Deliver Message] will deliver the draft to its intended recipient(s).
-
-The @hid[Goto Headers Buffer] commmand, when invoked in a @hid[Draft] or
-@hid[Message] buffer, makes the associated @hid[Headers] buffer current.  The
-@hid[Goto Message Buffer] command, when invoked in a @hid[Draft] buffer, makes
-the associated @hid[Message] buffer current.
-@enddefcom
-
-@defcom[com "Forward Message", stuff (bound to @bf[f] in @hid[Headers] and @hid[Message] modes) ]
- This command, when invoked in a @hid[Headers] buffer, creates a unique
-@hid[Draft] buffer.  The current message is inserted in the draft by using the
-@f[forw] utility, and the @hid[Draft] buffer is shown in the current window.
-The name of the draft message file is used to produce the buffer's name.  A
-pathname is associated with the @hid[Draft] buffer so that @hid[Save File] can
-be used to incrementally save a composition before delivering it.  The
-@hid[Draft] buffer is associated with the @hid[Headers] buffer, but no
-@hid[Message] buffer is created since the message is already a part of the
-draft.
-
-When invoked in a @hid[Message] buffer, a unique @hid[Draft] buffer is set up
-inserting the message into the @hid[Draft] buffer.  The @hid[Message] buffer is
-not associated with the @hid[Draft] buffer because the message is already a
-part of the draft.  However, any association of the @hid[Message] buffer with a
-@hid[Headers] buffer is propagated to the @hid[Draft] buffer.
-
-When not in a @hid[Headers] buffer or @hid[Message] buffer, this command
-prompts for a folder and message to forward.  A @hid[Draft] buffer is created
-as described in the previous two cases.
-
-@hid[Deliver Message] will deliver the draft to its intended recipient(s).
-@enddefcom
-
-@defcom[com "Deliver Message", stuff (bound to @bf[H-s] and @bf[H-c] in @hid[Draft] mode) ]
-@defhvar1[var "Deliver Message Confirm", val {nil}]
- This command, when invoked in a @hid[Draft] buffer, saves the file and uses
-the @mh @f[send] utility to deliver the draft.  If the draft is a reply to some
-message, then @f[anno] is used to annotate that message with a "@f[replied]"
-component.  Any @hid[Headers] buffers containing the replied-to message are
-updated with an "@b[A]" placed in the appropriate headers line two characters
-after the message ID.  Before doing any of this, confirmation is asked for
-based on @hid[Deliver Message Confirm].
-
-When not in a @hid[Draft] buffer, this prompts for a draft message ID and
-invokes @f[send] on that draft message to deliver it.  Sending a draft in this
-way severs any association that draft may have had with a message being replied
-to, so no annotation will occur.
-@enddefcom
-
-@defcom[com "Delete Draft and Buffer", stuff (bound to @bf[H-q] in @hid[Draft] mode) ]
-This command, when invoked in a @hid[Draft] buffer, deletes the draft message
-file and the buffer.  This also deletes any associated message buffer unless
-the user preserved it with @hid[Keep Message].
-@enddefcom
-
-@defcom[com "Remail Message", stuff (bound to @bf[H-r] in @hid[Headers] and @hid[Message] modes) ]
- This command, when invoked in a @hid[Headers] or @hid[Message] buffer, prompts
-for resend @f[To:] and resend @f[Cc:] addresses, remailing the current message.
-When invoked in any other kind of buffer, this command prompts for a folder and
-message as well.  @mh's @f[dist] sets up a draft folder message which is then
-modified.  The above mentioned addresses are inserted on the @f[Resent-To:] and
-@f[Resent-Cc:] lines.  Then the message is delivered.
-
-There is no mechanism for annotating messages as having been remailed.
-@enddefcom
-
-@defcom[com "Draft Help", bind (Draft: H-?)]
-This command displays documentation on @hid[Draft] mode.
-@enddefcom
-
-
-@section[Convenience Commands for Message and Draft Buffers]
-@index[message buffer commands]
-@index[draft buffer commands]
-@index[convenience commands for mail interface]
-@label[convenience-coms] 
-This section describes how to switch from a @hid[Message] or @hid[Draft] buffer
-to its associated @hid[Headers] buffer, or from a @hid[Draft] buffer to its
-associated @hid[Message] buffer.  There are also commands for various styles of
-inserting text from a @hid[Message] buffer into a @hid[Draft] buffer.
-
-@defcom[com "Goto Headers Buffer", stuff (bound to @bf[^] in @hid[Message] mode and @bf[H-^] in @hid[Draft] mode) ] 
-This command, when invoked in a @hid[Message] or @hid[Draft] buffer with an
-associated @hid[Headers] buffer, places the associated @hid[Headers] buffer in
-the current window.
-
-The cursor is moved to the headers line of the associated message.
-@enddefcom
-
-@defcom[com "Goto Message Buffer", stuff (bound to @bf[H-m] in @hid[Draft] mode) ]
-This command, when invoked in a @hid[Draft] buffer with an associated
-@hid[Message] buffer, places the associated @hid[Message] buffer in the current
-window.
-@enddefcom
-
-@defcom[com "Insert Message Region", stuff (bound to @bf[H-y] in appropriate modes) ]
-@defhvar1[var "Message Insertion Prefix", val {"   "}]
-@defhvar1[var "Message Insertion Column", val {75}]
-This command, when invoked in a @hid[Message] or @hid[News-Message] (where it
-is bound) buffer that has an associated @hid[Draft] or @hid[Post] buffer,
-copies the current active region into the @hid[Draft] or @hid[Post] buffer.  It
-is filled using @hid[Message Insertion Prefix] (which defaults to three spaces)
-and @hid[Message Insertion Column].  If an argument is supplied, the filling is
-inhibited.
-@enddefcom
-
-@defcom[com "Insert Message Buffer", stuff (bound to @bf[H-y] in appropriate modes) ]
-@defhvar1[var "Message Buffer Insertion Prefix", val {"    "}]
-This command, when invoked in a @hid[Draft] or @hid[Post] (where it is bound)
-buffer with an associated @hid[Message] or @hid[News-Message] buffer, or when
-in a @hid[Message] (or @hid[News-Message]) buffer that has an associated
-@hid[Draft] buffer, inserts the @hid[Message] buffer into the @hid[Draft] (or
-@hid[Post]) buffer.  Each inserted line is modified by prefixing it with
-@hid[Message Buffer Insertion Prefix] (which defaults to four spaces) .  If an
-argument is supplied, the prefixing is inhibited.
-@enddefcom
-
-@defcom[com "Edit Message Buffer", stuff (bound to @bf[e] in @hid[Message] mode) ]
-This command puts the current @hid[Message] buffer in @hid[Text] mode and makes
-it writable (@hid[Message] buffers are normally read-only).  The pathname of
-the file which the message is in is associated with the buffer making saving
-possible.  A recursive edit is entered, and the user is allowed to make changes
-to the message.  When the recursive edit is exited, if the buffer is modified,
-the user is asked if the changes should be saved.  The buffer is marked
-unmodified, and the pathname is disassociated from the buffer.  The buffer
-otherwise returns to its previous state as a @hid[Message] buffer.  If the
-recursive edit is aborted, the user is not asked to save the file, and the
-buffer remains changed though it is marked unmodified.
-@enddefcom
-
-
-@section[Deleting Messages]
-@index[deleting messages]
-@label[deleting]
-The main command described in this section is @hid[Headers Delete Message]
-(bound to @bf[k] in @hid[Headers] and @hid[Message] modes).  A useful command
-for reading new mail is @hid[Delete Message and Show Next] (bound to @bf[d] in
-@hid[Message] mode) which deletes the current message and shows the next
-undeleted message.
-
-Since messages are by default deleted using a virtual message deletion
-mechanism, @hid[Expunge Messages] (bound to @bf[!] in @hid[Headers] mode)
-should be mentioned here.  This is described in section @ref[terminating].
-
-
-@defhvar[var "Virtual Message Deletion", val {t}]
-When set, @hid[Delete Message] adds a message to the "@f[hemlockdeleted]"
-sequence; otherwise, @f[rmm] is invoked on the message immediately.
-@enddefhvar
-
-@defcom[com "Delete Message" ]
-This command prompts for a folder, messages, and an optional @f[pick]
-expression.  When invoked in a @hid[Headers] buffer of the specified folder,
-the prompt for a message specification will default to the those messages in
-that @hid[Headers] buffer.
-
-When the variable @hid[Virtual Message Deletion] is set, this command merely
-flags the messages for deletion by adding them to the "@f[hemlockdeleted]"
-sequence.  Then this updates any @hid[Headers] buffers representing the folder.
-It notates each headers line referring to a deleted message with a "@b[D]" in
-the third character position after the message ID.
-
-When @hid[Virtual Message Deletion] is not set, @f[rmm] is invoked on the
-message, and each headers line referring to the deleted message is deleted from
-its buffer
-@enddefcom
-
-@defcom[com "Headers Delete Message", stuff (bound to @bf[k] in @hid[Headers] and @hid[Message] modes) ]
-This command, when invoked in a @hid[Headers] buffer, deletes the message on
-the current line as described in @hid[Delete Message].
-
-When invoked in a @hid[Message] buffer, the message displayed in it is deleted
-as described in @hid[Delete Message].
-@enddefcom
-
-@defcom[com "Delete Message and Show Next", stuff (bound to @bf[k] in @hid[Headers] and @hid[Message] modes) ]
-This command is only valid in a @hid[Headers] buffer or a @hid[Message] buffer
-associated with some @hid[Headers] buffer.  The current message is deleted as
-with the @hid[Delete Message] command.  Then the next message is shown as with
-@hid[Next Undeleted Message].
-@enddefcom
-
-@defcom[com "Delete Message and Down Line", stuff (bound to @bf[d] in @hid[Headers mode])]
-This command, when invoked in a @hid[Headers] buffer, deletes the message on
-the current line.  Then the point is moved to the next non-blank line.
-@enddefcom
-
-@defcom[com "Undelete Message" ]
-This command is only meaningful when @hid[Virtual Message Deletion] is set.
-This prompts for a folder, messages, and an optional @f[pick] expression.  When
-in a @hid[Headers] buffer of the specified folder, the messages prompt defaults
-to those messages in the buffer.  All @hid[Headers] buffers representing the
-folder are updated.  Each headers line referring to an undeleted message is
-notated by replacing the "@b[D]" in the third character position after the
-message ID with a space.
-@enddefcom
-
-@defcom[com "Headers Undelete Message", stuff (bound to @bf[u] in @hid[Headers] and @hid[Message] modes) ]
-This command is only meaningful when @hid[Virtual Message Deletion] is set.
-When invoked in a @hid[Headers] buffer, the message on the current line is
-undeleted as described in @hid[Undelete Message].
-
-When invoked in a @hid[Message] buffer, the message displayed in it is
-undeleted as described in @hid[Undelete Message].
-@enddefcom
-
-
-@section[Folder Operations]
-
-@index[folder operations]@label[folder]
-@defcom[com "List Folders" ]
-This command displays a list of all current mail folders in the user's
-top-level mail directory in a @hemlock pop-up window.
-@enddefcom
-
-@defcom[com "Create Folder"]
-This command prompts for and creates a folder.  If the folder already exists,
-an error is signaled.
-@enddefcom
-
-@defcom[com "Delete Folder" ]
-This command prompts for a folder and uses @f[rmf] to delete it.  Note that no
-confirmation is asked for.
-@enddefcom
-
-
-@section[Refiling Messages]
-
-@index[refiling messages]@label[refiling]
-@defcom[com "Refile Message" ]
-This command prompts for a folder, messages, an optional @f[pick] expression,
-and a destination folder.  When invoked in a @hid[Headers] buffer of the
-specified folder, the message prompt offers a default of those messages in the
-buffer.  If the destination folder does not exist, the user is asked to create
-it.  The resulting messages are refiled with the @f[refile] utility.  All
-@hid[Headers] buffers for the folder are updated.  Each line referring to a
-refiled message is deleted from its buffer.
-@enddefcom
-
-@defcom[com "Headers Refile Message", stuff (bound to @bf[o] in @hid[Headers] and @hid[Message] modes) ]
-This command, when invoked in a @hid[Headers] buffer, prompts for a destination
-folder, refiling the message on the current line with @f[refile].  If the
-destination folder does not exist, the user is asked to create it.  Any
-@hid[Headers] buffers containing messages for that folder are updated.  Each
-headers line referring to the refiled message is deleted from its buffer.
-
-When invoked in a @hid[Message] buffer, that message is refiled as described
-above.
-@enddefcom
-
-
-@section[Marking Messages]
-@index[marking messages]
-@label[marking]
-@defcom[com "Mark Message" ]
-This command prompts for a folder, message, and sequence and adds (deletes) the
-message specification to (from) the sequence.  By default this adds the
-message, but if an argument is supplied, this deletes the message.  When
-invoked in a @hid[Headers] buffer or @hid[Message] buffer, this only prompts
-for a sequence and uses the current message.
-@enddefcom
-
-
-@section[Terminating Headers Buffers]
-@label[terminating]
-The user never actually @i[exits] the mailer.  He can leave mail buffers lying
-around while conducting other editing tasks, selecting them and continuing his
-mail handling whenever.  There still is a need for various methods of
-terminating or cleaning up @hid[Headers] buffers.  The two most useful commands
-in this section are @hid[Expunge Messages] and @hid[Quit Headers].
-
-
-@defhvar[var "Expunge Messages Confirm", val {t}]
-When this is set, @hid[Quit Headers] and @hid[Expunge Messages] will ask for
-confirmation before expunging messages and packing the folder's message ID's.
-@enddefhvar
-
-@defhvar[var "Temporary Draft Folder", val {nil}]
-This is a folder name where @mh @f[fcc:] messages are kept with the intention
-that this folder's messages will be deleted and expunged whenever messages from
-any folder are expunged (for example, when @hid[Expunge Messages] or @hid[Quit
-Headers] is invoked.
-@enddefhvar
-
-@defcom[com "Expunge Messages", stuff (bound to @bf[!] in @hid[Headers] mode) ]
-This command deletes messages @f[mark]'ed for deletion, and compacts the
-folder's message ID's.  If there are messages to expunge, ask the user for
-confirmation, displaying the folder name.  This can be inhibited by setting
-@hid[Expunge Messages Confirm] to @nil.  When @hid[Temporary Draft Folder] is
-not @nil, this command deletes and expunges that folder's messages regardless
-of the folder in which the user invokes it, and a negative response to the
-request for confirmation inhibits this.
-
-When invoked in a @hid[Headers] buffer, the messages in that folder's
-"@f[hemlockdeleted]" sequence are deleted by invoking @f[rmm].  Then the ID's
-of the folder's remaining messages are compacted using the @f[folder] utility.
-Since headers must be regenerated due to renumbering or reassigning message
-ID's, and because @hid[Headers] buffers become inconsistent after messages are
-deleted, @hemlock must regenerate all the headers for the folder.  Multiple
-@hid[Headers] buffers for the same folder are then collapsed into one buffer,
-deleting unnecessary duplicates.  Any @hid[Message] buffers associated with
-these @hid[Headers] buffers are deleted.
-
-If there is an unseen @hid[Headers] buffer for the folder, it is handled
-separately from the @hid[Headers] buffers described above.  @hemlock tries to
-update it by filling it only with remaining unseen message headers.
-Additionally, any headers generated due to @hid[Unseen Headers Message Spec]
-are inserted.  If there are no headers, unseen or otherwise, the buffer is left
-blank.
-
-Any @hid[Draft] buffer set up as a reply to a message in the folder is affected
-as well since the associated message has possibly been deleted.  When a draft
-of this type is delivered, no message will be annotated as having been replied
-to.
-
-When invoked in a @hid[Message] buffer, this uses its corresponding folder as
-the folder argument.  The same updating as described above occurs.
-
-In any other type of buffer, a folder is prompted for.
-@enddefcom
-
-@defcom[com "Quit Headers", stuff (bound to @bf[q] in @hid[Headers] and @hid[Message] modes) ]
-This command affects the current @hid[Headers] buffer.  When there are deleted
-messages, ask the user for confirmation on expunging the messages and packing
-the folder's message ID's.  This prompting can be inhibited by setting
-@hid[Expunge Messages Confirm] to @nil.  After deleting and packing, this
-deletes the buffer and all its associated @hid[Message] buffers.
-
-Other @hid[Headers] buffers regarding the same folder are handled as described
-in @hid[Expunge Messages], but the buffer this command is invoked in is always
-deleted.
-
-When @hid[Temporary Draft Folder] is not @nil, this folder's messages are
-deleted and expunged regardless of the folder in which the user invokes this
-command.  A negative response to the above mentioned request for confirmation
-inhibits this.
-@enddefcom
-
-@defcom[com "Delete Headers Buffer and Message Buffers" ]
-This command prompts for a @hid[Headers] buffer to delete along with its
-associated @hid[Message] buffers.  Any associated @hid[Draft] buffers are left
-intact, but their corresponding @hid[Message] buffers will be deleted.  When
-invoked in a @hid[Headers] buffer or a @hid[Message] buffer associated with a
-@hid[Headers] buffer, that @hid[Headers] buffer is offered as a default.
-@enddefcom
-
-
-@section[Miscellaneous Commands]
-@label[miscellaneous mail commands]
-@label[miscellaneous]
-
-@defcom[com "List Mail Buffers", stuff (bound to @bf[l] in @hid[Headers] and @hid[Message] modes @bf[H-l] in @hid[Draft] mode) ]
-This command shows a list of all mail @hid[Message], @hid[Headers], and
-@hid[Draft] buffers.
-
-If a @hid[Message] buffer has an associated @hid[Headers] buffer, it is
-displayed to the right of the @hid[Message] buffer's name.
-
-If a @hid[Draft] buffer has an associated @hid[Message] buffer, it is displayed
-to the right of the @hid[Draft] buffer's name.  If a @hid[Draft] buffer has no
-associated @hid[Message] buffer, but it is associated with a @hid[Headers]
-buffer, then the name of the @hid[Headers] buffer is displayed to the right of
-the @hid[Draft] buffer.
-
-For each buffer listed, if it is modified, then an asterisk is displayed before
-the name of the buffer.
-@enddefcom
-
-
-@section[Styles of Usage]
-@index[styles of mail interface usage]
-@label[Styles]
-This section discusses some styles of usage or ways to make use of some of the
-features of @hemlock's interface to @mh that might not be obvious.  In each
-case, setting some variables and/or remembering an extra side effect of a
-command will lend greater flexibility and functionality to the user.
-
-@subsection[Unseen Headers Message Spec]
-The unseen @hid[Headers] buffer by default only shows unseen headers which is
-adequate for one folder, simple mail handling.  Some people use their @hid[New
-Mail Folder] only for incoming mail, refiling or otherwise dispatching a
-message immediately.  Under this mode it is easy to conceive of the user not
-having time to respond to a message, but he would like to leave it in this
-folder to remind him to take care of it.  Using the @hid[Unseen Headers Message
-Spec] variable, the user can cause all the messages the @hid[New Mail Folder] to
-be inserted into the unseen @hid[Headers] buffer whenever just unseen headers
-would be.  This way he sees all the messages that require immediate attention.
-
-To achieve the above effect, @hid[Unseen Headers Message Spec] should be set to
-the string @f["all"].  This variable can be set to any general @mh message
-specification (see section @ref[mhcommands] of this chapter), so the user can
-include headers of messages other than those that have not been seen without
-having to insert all of them.  For example, the user could set the variable to
-@f["flagged"] and use the @hid[Mark Message] command to add messages he's
-concerned about to the @f["flagged"] sequence.  Then the user would see new
-mail and interesting mail in his unseen @hid[Headers] buffer, but he doesn't
-have to see everything in his @hid[New Mail Folder].
-
-
-@subsection[Temporary Draft Folder]
-Section @ref[components-files] of this chapter discusses how to make @mh keep
-personal copies of outgoing mail.  The method described will cause a copy of
-every outgoing message to be saved forever and requires the user to go through
-his @f[Fcc:] folder, weeding out those he does not need.  The @hid[Temporary
-Draft Folder] variable can name a folder whose messages will be deleted and
-expunged whenever any folder's messages are expunged.  By naming this folder in
-the @mh profile and components files, copies of outgoing messages can be saved
-temporarily.  They will be cleaned up automatically, but the user still has a
-time frame in which he can permanently save a copy of an outgoing message.
-This folder can be visited with @hid[Message Headers], and messages can be
-refiled just like any other folder.
-
-
-@subsection[Reply to Message Prefix Action]
-Depending on the kinds of messages one tends to handle, the user may find
-himself usually replying to everyone who receives a certain message, or he may
-find that this is only desired occasionally.  In either case, the user
-can set up his @mh profile to do one thing by default, using the @hid[Reply
-to Message Prefix Action] variable in combination with a prefix argument to the
-@hid[Reply to Message] command to get the other effect.
-
-For example, the following line in one's @mh profile will cause @mh to reply to
-everyone receiving a certain message (except for the user himself since he
-saves personal copies with the @f[-fcc] switch):
-@begin[programexample]
-repl: -cc all -nocc me -fcc out-copy
-@end[programexample]
-This user can set @hid[Reply to Message Prefix Action] to be @f[:no-cc-all].
-Then whenever he invokes @hid[Reply to Message] with a prefix argument, instead
-of replying to everyone, the draft will be set up in reply only to the person
-who sent the mail.
-
-As an alternative example, not specifying anything in one's @mh profile and
-setting this variable to @f[:cc-all] will have a default effect of replying
-only to the sender of a piece of mail.  Then invoking @hid[Reply to Message]
-with a prefix argument will cause everyone who received the mail to get a copy
-of the reply.  If the user does not want a @f[cc:] copy, then he can add
-@f[-nocc me] as a default switch and value in his @mh profile.
-
-
-@newpage
-@section[Wallchart]
-
-@tabclear
-@tabdivide(3)
-
-@begin[format, spacing 1.5]
-
-@Begin[Center] @b[Global bindings:] @End[Center]
-
-@hid[Incorporate and Read New Mail]@\@\@bf[C-x i]
-@hid[Send Message]@\@\@bf[C-x m]
-@hid[Message Headers]@\@\@bf[C-x r]
-
-
-@Begin[Center] @b[Headers and Message modes bindings:] @End[Center]
-
-@hid[Next Undeleted Message]@\@\@bf[n]
-@hid[Previous Undeleted Message]@\@\@bf[p]
-@hid[Send Message]@\@\@bf[s], @bf[m]
-@hid[Forward Message]@\@\@bf[f]
-@hid[Headers Delete Message]@\@\@bf[k]
-@hid[Headers Undelete Message]@\@\@bf[u]
-@hid[Headers Refile Message]@\@\@bf[o]
-@hid[List Mail Buffers]@\@\@bf[l]
-@hid[Quit Headers]@\@\@bf[q]
-@hid[Incorporate and Read New Mail]@\@\@bf[i]
-@hid[Next Message]@\@\@bf[M-n]
-@hid[Previous Message]@\@\@bf[M-p]
-@hid[Beginning of Buffer]@\@\@bf[<]
-@hid[End of Buffer]@\@\@bf[>]
-
-
-@Begin[Center] @b[Headers mode bindings:] @End[Center]
-
-@hid[Delete Message and Down Line]@\@\@bf[d]
-@hid[Pick Headers]@\@\@bf[h]
-@hid[Show Message]@\@\@bf[space], @bf[.]
-@hid[Reply to Message]@\@\@bf[r]
-@hid[Expunge Messages]@\@\@bf[!]
-
-
-@Begin[Center] @b[Message mode bindings:] @End[Center]
-
-@hid[Delete Message and Show Next]@\@\@bf[d]
-@hid[Goto Headers Buffer]@\@\@bf[^]
-@hid[Scroll Message]@\@\@bf[space]
-@hid[Scroll Message]@\@\@bf[C-v]
-@hid[Scroll Window Up]@\@\@bf[backspace], @bf[delete]
-@hid[Reply to Message in Other Window]@\@bf[r]
-@hid[Edit Message Buffer]@\@\@bf[e]
-@hid[Insert Message Region]@\@\@bf[H-y]
-
-
-@Begin[Center] @b[Draft mode bindings:] @End[Center]
-
-@hid[Goto Headers Buffer]@\@\@bf[H-^]
-@hid[Goto Message Buffer]@\@\@bf[H-m]
-@hid[Deliver Message]@\@\@bf[H-s], @bf[H-c]
-@hid[Insert Message Buffer]@\@\@bf[H-y]
-@hid[Delete Draft and Buffer]@\@\@bf[H-q]
-@hid[List Mail Buffers]@\@\@bf[H-l]
-
-@end[format]
-@tabclear
diff --git a/docs/hem/user/netnews.mss b/docs/hem/user/netnews.mss
deleted file mode 100644
index cc3b2d59da3c19b4a678b029b569a865904873e2..0000000000000000000000000000000000000000
--- a/docs/hem/user/netnews.mss
+++ /dev/null
@@ -1,488 +0,0 @@
-@comment{-*- Dictionary: /afs/cs/project/clisp/docs/hem/hem; Mode: spell; Package: Hemlock -*-}
-
-@chap[The Hemlock Netnews Interface]
-@section[Introduction to Netnews in Hemlock]
-
-
-@hemlock provides a facility for reading bulletin boards through the
-NetNews Transfer Protocol (NNTP).  You can easily read Netnews, reply to
-news posts, post messages, etc.  The news reading interface is consistent
-with that of the @hemlock mailer, and most Netnews commands function in the
-same manner as their mailer counterparts.
-
-Netnews can be read in one of two different modes.  The first mode, invoked
-by the @hid(Netnews) command, allows the user to read new messages in
-groups which the user has specified.  This method of reading netnews will
-track the highest numbered message in each newsgroup and only show new
-messages which have arrived since then.  The @hid(Netnews Browse) command
-invokes the other method of reading netnews.  This mode displays a list of
-all newsgroups, and the user may choose to read messages in any of them.
-By default, the news reader will not track the latest message read when
-browsing, and it will always display the last few messages.
-
-
-@section[Setting Up Netnews]
-
-To start reading bulletin boards from @hemlock you probably need to create a
-file containing the newsgroups you want to read.
-
-@defhvar[var "Netnews Group File", val {".hemlock-groups"}]
-   When you invoke the @hid(Netnews) command, @hemlock merges the value of
-   this variable with your home directory and looks there for a list of
-   groups (one per line) to read.
-@enddefhvar
-
-@defhvar[var "Netnews Database File", val{".hemlock-netnews"}]
-When you invoke the @hid(Netnews) command, @hemlock merges the value of
-this variable with your home directory.  This file maintains a pointer to
-the highest numbered message read in each group in @hid(Netnews Group
-File).
-@enddefhvar
-
-@defcom[com "List All Groups"]
-   When you invoke this command, @hemlock creates a buffer called
-   @hid(Netnews Groups) and inserts the names of all accessible Netnews
-   groups into it alphabetically.  You may find this useful if you choose to set
-   up your @hid(Netnews Group File) manually.
-@enddefcom
-
-@defhvar[var "Netnews NNTP Server", val{"netnews.srv.cs.cmu.edu"}]
-This variable stores the host name of the machine which @hemlock will use
-as the NNTP server.
-@enddefhvar
-
-@defhvar[var "Netnews NNTP Timeout Period", val{30}]
-This is the number of seconds @hemlock will wait trying to connect to the
-NNTP server.  If a connection is not made within this time period, the
-connection will time out and an error will be signalled.
-@enddefhvar
-
-@subsection[News-Browse Mode]
-
-   @hid(News-Browse) mode provides an easy method of adding groups to
-   your @hid(Netnews Group File).
-
-@defcom[com "Netnews Browse"]
-   This command sets up a buffer in @hid{News-Browse} mode with all
-   available groups listed one per line.  Groups may be read or added
-   to your group file using various commands in this mode.
-@enddefcom
-
-@defcom[com "Netnews Browse Add Group To File", stuff (bound to @bf[a] in @hid[News-Browse] mode)]
-@defcom1[com "Netnews Browse Pointer Add Group to File"]
-@hid(Netnews Browse Add Group to File) adds the group under the point to
-your group file, and @hid(Netnews Browse Pointer Add Group To File) adds
-the group under the mouse pointer without moving the point.
-@enddefcom
-
-@defcom[com "Netnews Browse Read Group", stuff (bound to @bf[space] in @hid[News-Browse] mode)]
-@defcom1[com "Netnews Browse Pointer Read Group"]
-@hid(Netnews Browse Read Group) and @hid(Netnews Browse Pointer Read Group)
-read the group under the cursor and the group under the mouse pointer,
-respectively.  These commands neither use nor modify the contents of your
-@hid(Netnews Database File); they will always present the last few messages
-in the newsgroup, regardless of the last message read.  @hid(Netnews Browse
-Pointer Read Group) does not modify the position of the point.
-@enddefcom
-
-@defcom[com "Netnews Quit Browse"]
-   This command exits @hid(News-Browse) mode.
-@enddefcom
-
-The @hid(Next Line) and @hid(Previous Line) commands are conveniently bound to
-@bf[n] and @bf[p] in this mode.
-
-@section[Starting Netnews]
-
-Once your @hid(Netnews Group File) is set up, you may begin reading netnews.
-
-@defcom[com "Netnews"]
-   This command is the main entry point for reading bulletin boards in
-   @hemlock.  Without an argument, the system looks for what bulletin boards to
-   read in the value of @hid(Netnews Group File) and reads each of them in
-   succession.  @hemlock keeps a pointer to the last message you read in each
-   of these groups in your @hid(Netnews Database File).  Bulletin boards may
-   be added to your @hid(Netnews Group File) manually or by using
-   the @hid(Netnews Browse) facility.  With an argument, @hemlock prompts the 
-   user for the name of a bulletin board and reads it.
-@enddefcom
-
-@defcom[com "Netnews Look at Group"]
-   This command prompts for a group and reads it, ignoring the information
-   in your @hid(Netnews Database File).
-@enddefcom
-
-When you read a group, @hemlock creates a buffer that contains important
-header information for the messages in that group.  There are four fields
-in each header, one each for the @i(date), @i(lines), @i(from), and
-@i(subject).  The @i(date) field shows when the message was sent, the
-@i(lines) field displays how long the message is in lines, the @i(from)
-field shows who sent the message, and the @i(subject) field displays the
-subject of this message.  If a field for a message is not available, @f(NA)
-will appear instead.  You may alter the length of each of these fields by
-modifying the following @hemlock variables:
-
-@defhvar[var "Netnews Before Date Field Pad", val 1]
-   How many spaces should be inserted before the date in @hid(News-Headers)
-   buffers.
-@enddefhvar
-
-@defhvar[var "Netnews Date Field Length", val 6]
-@defhvar1[var "Netnews Line Field Length", val 3]
-@defhvar1[var "Netnews From Field Length", val 20]
-@defhvar1[var "Netnews Subject Field Length", val 43]
-   These variables control how long the @i(date), @i(line), @i(from), and
-   @i(subject) fields should be in @hid{News-Headers} buffers.
-@enddefhvar
-
-@defhvar[var "Netnews Field Padding", val 2]
-   How many spaces should be left between the Netnews @i(date), @i(from), 
-   @i(lines), and @i(subject) fields after padding to the required length.
-@enddefhvar
-
-For increased speed, @hemlock only inserts headers for a subset of the
-messages in each group.  If you have never read a certain group, and the
-value of @hid(Netnews New Group Style) is @f(:from-end) (the default),
-@hemlock inserts some number of the last messages in the group, determined
-by the value of @hid(Netnews Batch Count).  If the value of @hid(Netnews
-New Group Style) is @f(:from-start), @hemlock will insert the first batch
-of messages in the group.  If you have read a group before, @hemlock will
-insert the batch of messages following the highest numbered message that
-you had read previously.
-
-@defhvar[var "Netnews Start Over Threshold", val {350}]
-   If the number of new messages in a group exceeds the value of this
-   variable and @hid(Netnews New Group Style) is @f(:from-end), @hemlock asks
-   if you would like to start reading this group from the end.
-@enddefhvar
-
-You may at any time go beyond the messages that are visible using the 
-@hid(Netnews Next Line), @hid(Netnews Previous Line),
-@hid(Netnews Headers Scroll Window Up), and
-@hid(Netnews Headers Scroll Down) commands in @hid(News-Headers) mode,
-or the @hid(Netnews Next Article) and @hid(Netnews Previous Article)
-commands in @hid(News-Message) mode.
-
-@defhvar[var "Netnews Fetch All Headers", val {nil}]
-This variable determines whether Netnews will fetch all headers immediately
-upon entering a new group.
-@enddefhvar
-
-@defhvar[var "Netnews Batch Count", val {50}]
-   This variable determines how many headers the Netnews facility will fetch
-   at a time.
-@enddefhvar
-
-@defhvar[var "Netnews New Group Style", val {:from-end}]
-This variable determines what happens when you read a group that you have
-never read before.  When it is @f(:from-start), the @hid(Netnews) command
-will read from the beginning of a new group forward.  When it is @f(:from-end),
-the default, @hid(Netnews) will read the group from the end backward.
-@enddefhvar
-
-@section[Reading Messages]
-
-From a @hid{News-Headers} buffer, you may read messages, reply to messages
-via the @hemlock mailer, or reply to messages via post.  Some commands are
-also bound to ease getting from one header to another.
-
-@defcom[com "Netnews Show Article", stuff (bound to @bf[space] in @hid{News-Headers} mode)]
-@defhvar1[var "Netnews Read Style", val {:multiple}]
-@defhvar1[var "Netnews Headers Proportion", val {0.25}]
-This command puts the body of the message header under the current point
-into a @hid{News-Message} buffer.  If the value of @hid(Netnews Read
-Style) is @f(:single), @hemlock changes to the @hid{News-Message}
-buffer.  If it is @f(:multiple), then @hemlock splits the current window
-into two windows, one for headers and one for message bodies.  The headers
-window takes up a proportion of the current window based on the value of
-@hid(Netnews Headers Proportion).  If the window displaying the
-@hid(News-Headers) buffer has already been split, and the message
-currently displayed in the @hid(News-Message) window is the same as the
-one under the current point, this command behaves just like @hid(Netnews
-Message Scroll Down).
-@enddefcom
-
-@defhvar[var "Netnews Message Header Fields", val {nil}]
-   When this variable is @nil, all available fields are displayed in the
-   header of a message.  Otherwise, this variable should containt a list of
-   fields to include in message headers.  If an element of this
-   list is an atom, then it should be the string name of a field.  If it is
-   a cons, then the car should be the string name of a field, and the cdr
-   should be the length to which this field should be limited.  Any string
-   name is acceptable, and fields that do not exist are ignored.
-@enddefhvar   
-
-@defcom[com "Netnews Show Whole Header", stuff (bound to @bf[w] in @hid{News-Headers} and @hid{News-Message} modes.)]
-This command displays the entire header for the message currently being
-read.  This is to undo the effects of @hid{Netnews Message Header Fields}
-for the current message.
-@enddefcom
-
-@defcom[com "Netnews Next Line", stuff (bound to @bf[C-n] and @bf[Downarrow] in @hid{News-Headers} mode)]
-@defhvar1[var "Netnews Last Header Style", val {:next-headers}]
-This command moves the current point to the next line.  If you are on the
-last visible message, and there are more in the current group, headers for
-these messages will be inserted.  If you are on the last header and there
-are no more messages in this group, then @hemlock will take some action
-based on the value of @hid(Netnews Last Header Style).  If the value of
-this variable is @f(:feep), @hemlock feeps you indicating there are no
-more messages.  If the value is @f(:next-headers), @hemlock reads in the
-headers for the next group in your @hid(Netnews Group File).  If the value
-is @f(:next-article), @hemlock goes on to the next group and shows you
-the first unread message.
-@enddefcom
-					 
-@defcom[com "Netnews Previous Line", stuff (bound to @bf[C-p] and @bf[Uparrow] in @hid{News-Headers} mode)]
-This command moves the current point to the previous line.  If you are on
-the first visible header, and there are more previous messages, @hemlock
-inserts the headers for these messages.
-@enddefcom
-
-@defcom[com "Netnews Headers Scroll Window Down", stuff (bound to @bf[C-v] in @hid{News-Headers} mode)]
-@defcom1[com "Netnews Headers Scroll Window Up", stuff (bound to @bf[M-v] in @hid{News-Headers} mode)]
-   These commands scroll the headers window up or down one screenfull.  If the
-   end of the buffer is visible, @hemlock inserts the next batch of headers.
-@enddefcom
-
-@defcom[com "Netnews Next Article", stuff (bound to @bf[n] in @hid{News-Message} and @hid{News-Headers} modes)]
-@defcom1[com "Netnews Previous Article", stuff (bound to @bf[p] in @hid{News-Message} and @hid{News-Headers} modes)]
-   These commands insert the next or previous message into a message buffer.
-@enddefcom
-
-@defcom[com "Netnews Message Scroll Down", stuff (bound to @bf[space] in @hid{News-Message} mode)]
-@defhvar1[var "Netnews Scroll Show Next Message", val {t}]
-If the end of the current message is visible, @hemlock feeps the user if
-the value of @hid(Netnews Scroll Show Next Message) is non-@nil, or it
-inserts the next message into this message buffer if that variable is @nil.
-If the end of the message is not visible, then @hemlock shows the next
-screenfull of the current message.
-@enddefcom
-
-@defcom[com "Netnews Message Quit", stuff (bound to @bf[q] in @hid{News-Message} mode)]
-   This command deletes the current message buffer and makes the associated
-   @hid{News-Headers} buffer current.
-@enddefcom
- 
-@defcom[com "Netnews Goto Headers Buffer", stuff (bound to @bf[H-h] in @hid{News-Message} mode)]
-   This command, when invoked from a @hid(News-Message) buffer with an
-   associated @hid(News-Headers) buffer, places the associated 
-   @hid(News-Headers) buffer into the current window.
-@enddefcom
-
-@defcom[com "Netnews Message Keep Buffer", stuff (bound to @bf[k] in @hid{News-Message} mode)]
-   By default, @hemlock uses one buffer to display all messages in a group,
-   one at a time.  This command tells @hemlock to keep the current message
-   buffer intact and start reading messages in another buffer.
-@enddefcom
-
-@defcom[com "Netnews Select Message Buffer", stuff (bound to @bf[H-m] in @hid{News-Headers} and @hid{Post} modes.)]
-   In @hid{News-Headers} mode, this command selects the buffer
-   containing the last message read.  In @hid{Post} mode, it selects the
-   associated @hid{News-Message} buffer, if there is one.
-@enddefcom
-
-@defcom[com "Netnews Append to File", stuff (bound to @bf[a] in @hid{News-Headers} and @hid{News-Message} modes.)]
-@defhvar1[var "Netnews Message File", val {"netnews-messages.txt"}]
-This command prompts for a file which the current message will be appended
-to.  The default file is the value of @hid(Netnews Message File) merged
-with your home directory.
-@enddefcom
-
-@defcom[com "Netnews Headers File Message", stuff (bound to @bf[o] in @hid{News-Headers} mode)]
-This command prompts for a mail folder and files the message under the
-point into it.  If the folder does not exist, @hemlock will ask if it should
-be created.
-@enddefcom
-
-@defcom[com "Netnews Message File Message", stuff (bound to @bf[o] in @hid{News-Message} mode)]
-This command prompts for a mail folder and files the current message there.
-If the folder does not exist, @hemlock will ask if it should be created.
-@enddefcom
-
-@defcom[com "Fetch All Headers", stuff (bound to @bf[f] in @hid{Netnews Headers} mode)]
-   In a forward reading @hid(Netnews headers) buffer, this command inserts
-   all headers after the last visible one into the headers buffer.  If
-   @hemlock is reading this group backward, the system inserts all headers
-   before the first visible one into the headers buffer.
-@enddefcom
-
-@defcom[com "Netnews Go to Next Group", stuff (bound to @bf[g] in @hid{News-Headers} and @hid{News-Message} modes.)]
-This command goes to the next group in your @hid(Netnews Group File).
-Before going on, it sets the group pointer in @hid(Netnews Database
-Filename) to the last message you read.  With an argument, the command does
-not modify the group pointer for the current group.
-@enddefcom
-
-@defcom[com "Netnews Quit Starting Here", stuff (bound to @bf[.] in @hid{News-Headers} and @hid{News-Message} modes)]
-   This command goes to the next group in your @hid(Netnews Group File), 
-   setting the netnews pointer for this group to the message before the one
-   under the current point, so the next time you read this group, the message
-   indicated by the point will appear first.
-@enddefcom
-
-@defcom[com "Netnews Group Punt Messages", stuff (bound to @bf[G] in @hid{News-Headers} mode)]
-   This command goes on to the next bulletin board in your group
-   file.  Without an argument, the system sets the pointer for the current
-   group to the last message.  With an argument, @hemlock sets the
-   pointer to the last visible message in the group.
-@enddefcom
-
-@defcom[com "Netnews Exit", stuff (bound to @bf[q] in @hid{News-Headers} mode)]
-@defhvar1[var "Netnews Exit Confirm", val {t}]
-   This command cleans up and deletes the @hid(News-Headers) buffer and
-   all associated @hid(News-Message) buffers.  If the value of
-   @hid(Netnews Exit Confirm) is @nil, then @hemlock will not prompt before
-   exiting.
-@enddefcom
-
-@section[Replying to Messages]
-
-The @hemlock Netnews interface also provides an easy way of replying to
-messages through the @hemlock Mailer or via @hid{Post} mode.
-
-@defcom[com "Netnews Reply to Sender"]
-   When you invoke this command, @hemlock creates a @hid(Draft) buffer and
-   tries to fill in the @i(to) and @i(subject) fields of the draft.  For
-   the @i(to) field, @hemlock looks at the @i(reply-to) field of the
-   message you are replying to, or failing that, the @i(from) field.  If
-   the @i(subject) field does not start with @f(Re:), @hemlock inserts this
-   string, signifying that this is a reply.
-@enddefcom
-
-@defcom[com "Netnews Reply to Sender in Other Window", stuff (bound to @bf[r] in @hid{News-Headers} and @hid{News-Message}.)]
-This command splits the current window, placing the message you are
-replying to in the top window and a new @hid{Draft} buffer in the bottom
-one.  This command fills in the header fields in the same manner as
-@hid(Netnews Reply to Sender).
-@enddefcom
-
-@defcom[com "Netnews Reply to Group"]
-This command creates a @hid{Post} buffer with the @i(newsgroups) field set
-to the current group and the @i(subject) field constructed in the same way
-as in @hid(Netnews Reply to Sender).
-@enddefcom
-
-@defcom[com "Netnews Reply to Group in Other Window", stuff (bound to @bf[R] in @hid{News-Headers} and @hid{News-Message}.)]
-   This command splits the current window, placing the message you are
-   replying to in the top window and a new @hid{Post} buffer in the bottom
-   one.  This command will fill in the header fields in the same manner as
-   @hid(Netnews Reply to Group).
-@enddefcom
-
-@defcom[com "Netnews Post Message", stuff (bound to @bf[C-x P])]
-   This command creates a @hid{Post} buffer.  If you are in a 
-   @hid(News-Headers) or @hid{News-Message} buffer, @hemlock fills in the
-   @i(newsgroups) field with the current group.
-@enddefcom
-
-@defcom[com "Netnews Forward Message", stuff (bound to @bf[f] in @hid{News-Headers} and @hid{News-Message} modes.)]
-This command creates a @hid{Post} buffer.  If you are in a @hid{Netnews
-Headers} or @hid{News-Message} buffer, @hemlock will put the text of the
-current message into the buffer along with lines delimiting the forwarded
-message.
-@enddefcom
-
-@defcom[com "Netnews Goto Post Buffer", stuff (bound to @bf[H-p] in @hid{News-Message} mode)]
-   This command, when invoked in a @hid(News-Message) or @hid(Draft) buffer
-   with an associated @hid(News-Headers) buffer, places the associated
-   @hid(News-Headers) buffer into the current window.
-@enddefcom
-
-@defcom[com "Netnews Goto Draft Buffer", stuff (bound to @bf[H-d] in @hid{News-Message} mode)]
-   This command, when invoked in a @hid(News-Message) buffer with an 
-   associated @hid(Draft) buffer, places the @hid(Draft) buffer into the 
-   current window.
-@enddefcom
-
-@section[Posting Messages]
-
-@defcom[com "Netnews Deliver Post", stuff (bound to @bf[H-s] in @hid{Post} mode)]
-@defhvar1[var "Netnews Deliver Post Confirm", val "t"]
-This command delivers the contents of a @hid(Post) buffer to the NNTP
-server.  If @hid(Netnews Deliver Post Confirm) is @f(t), @hemlock will ask for
-confirmation before posting the message.  @hemlock feeps you if NNTP does
-not accept the message.
-@enddefcom
-
-@defcom[com "Netnews Abort Post", stuff (bound to @bf[H-q] in @hid{Post} mode)]
-   This command deletes the current @hid(Post) buffer.
-@enddefcom
-
-
-As in the mailer, when replying to a message you can be excerpt sections of
-it using @hid(Insert Message Buffer) and @hid(Insert Message Region) in
-@hid(Post) and @hid(News-Message) modes, respectively.  You can also use
-these commands when replying to a message via mail in a @hid(Draft) buffer.
-In all cases, the same binding is used: @bf[H-y].
-
-@newpage
-@section[Wallchart]
-
-@tabclear
-@tabdivide(5)
-
-@begin[format, spacing 1.5]
-
-
-@Begin[Center] @b[Global bindings:] @End[Center]
-
-@hid[Netnews Post Message]@\@\@bf[C-x P]
-
-
-@Begin[Center] @b[News-Headers and News-Message modes bindings:] @End[Center]
-
-@hid[Netnews Next Article]@\@\@\@bf[n]
-@hid[Netnews Previous Article]@\@\@bf[p]
-@hid[Netnews Go to Next Group]@\@\@bf[g]
-@hid[Netnews Group Punt Messages]@\@\@bf[G]
-@hid[List All Groups]@\@\@\@bf[l]
-@hid[Netnews Append to File]@\@\@bf[a]
-@hid[Netnews Forward Message]@\@\@bf[f]
-@hid[Netnews Reply to Sender in Other Window]@\@\@bf[r]
-@hid[Netnews Reply to Group in Other Window]@\@\@bf[R]
-@hid[Netnews Quit Starting Here]@\@\@bf[.]
-
-@Begin[Center] @b[News-Headers mode bindings:] @End[Center]
-
-@hid[Netnews Show Article]@\@\@bf[Space]
-@hid[Netnews Previous Line]@\@\@bf[C-p], @bf[Uparrow]
-@hid[Netnews Next Line]@\@\@\@bf[C-n], @bf[Downarrow]
-@hid[Netnews Headers Scroll Window Down]@\@\@bf[C-v]
-@hid[Netnews Headers Scroll Window Up]@\@\@bf[M-v]
-@hid[Netnews Select Message Buffer]@\@\@bf[H-m]
-@hid[Netnews Exit]@\@\@\@bf[q]
-@hid[Netnews Headers File Message]@\@\@bf[o]
-
-
-@Begin[Center] @b[News-Message mode bindings:] @End[Center]
-
-@hid[Netnews Message Scroll Down]@\@\@bf[Space]
-@hid[Scroll Window Up]@\@\@\@bf[Backspace]
-@hid[Netnews Goto Headers Buffer]@\@\@bf[H-h], @bf[^]
-@hid[Netnews Message Keep Buffer]@\@\@bf[k]
-@hid[Netnews Message Quit]@\@\@bf[q]
-@hid[Netnews Message File Message]@\@\@bf[o]
-@hid[Netnews Goto Post Buffer]@\@\@bf[H-p]
-@hid[Netnews Goto Draft Buffer]@\@\@bf[H-d]
-@hid[Insert Message Region]@\@\@bf[H-y]
-
-
-@Begin[Center] @b[Post mode bindings:] @End[Center]
-
-@hid[Netnews Select Message Buffer]@\@\@bf[H-m]
-@hid[Netnews Deliver Post]@\@\@bf[H-s]
-@hid[Netnews Abort Post]@\@\@\@bf[H-q]
-@hid[Insert Message Buffer]@\@\@bf[H-y]
-
-
-@Begin[Center] @b[News-Browse mode bindings:] @End[Center]
-
-@hid[Netnews Quit Browse]@\@\@bf[q]
-@hid[Netnews Browse Add Group To File]@\@\@bf[a]
-@hid[Netnews Browse Read Group]@\@\@bf[Space]
-@hid[Next Line]@\@\@\@bf[n]
-@hid[Previous Line]@\@\@\@bf[p]
-
-
-@end[format]
-@tabclear
diff --git a/docs/hem/user/special-modes.mss b/docs/hem/user/special-modes.mss
deleted file mode 100644
index 262b44bf8f93ea28f5c31ebdb089eda6b1c4846c..0000000000000000000000000000000000000000
--- a/docs/hem/user/special-modes.mss
+++ /dev/null
@@ -1,738 +0,0 @@
-@comment{-*- Dictionary: bld:scribe/hem/hem; Mode: spell; Package: Hemlock -*-}
-@chap[Special Modes]
-
-@section[Dired Mode]
-@label[dired]
-@index[directory editing]
-
-@hemlock provides a directory editing mechanism.  The user can flag files and
-directories for deletion, undelete flagged files, and with a keystroke read in
-files and descend into directories.  In some implementations, it also supports
-copying, renaming, and a simple wildcard feature.
-
-
-@subsection[Inspecting Directories]
-@defcom[com "Dired", bind (C-x C-M-d)]
-This command prompts for a directory and fills a buffer with a verbose listing
-of that directory.  When the prefix argument is supplied, this includes Unix
-dot files.  If a dired buffer already exists for the directory, this switches
-to the buffer and makes sure it displays dot files if appropriate.
-@enddefcom
-
-@defcom[com "Dired with Pattern", bind (C-x C-M-d)]
-This command prompts for a directory and a pattern that may contain at most one
-wildcard, an asterisk, and it fills a buffer with a verbose listing of the
-files in the directory matching the pattern.  When the prefix argument is
-supplied, this includes Unix dot files.  If a dired buffer already exists for
-this directory, this switches to the buffer and makes sure it displays dot
-files if appropriate.
-@enddefcom
-
-@defcom[com "Dired from Buffer Pathname"]
-This command invokes @hid[Dired] on the directory name of the current buffer's
-pathname.
-@enddefcom
-
-@defcom[com "Dired Help", bind (Dired: ?)]
-This command pops up a help window listing the various @hid[Dired] commands.
-@enddefcom
-
-@defcom[com "Dired View File", bind (Dired: Space)]
-@defcom1[com "Dired Edit File", bind (Dired: e)]
-These command read in the file on the current line with the point.  If the line
-describes a directory instead of a file, then this command effectively invokes
-@hid[Dired] on the specification.  This associates the file's buffer with the
-@hid[Dired] buffer.
-
-@hid[Dired View File] reads in the file as if by @hid[View File], and
-@hid[Dired Edit File] as if by @hid[Find File].
-
-@hid[Dired View File] always reads into a newly created buffer, warning if the
-file already exists in some buffer.
-@enddefcom
-
-@defcom[com "Dired Up Directory", bind (Dired: ^)]
-This command invokes @hid[Dired] on the directory up one level from the current
-@hid[Dired] buffer.  This is useful for going backwards after repeatedly
-invoking @hid[Dired View File] and descending into a series of subdirectories.
-Remember, @hid[Dired] only generates directory listings when no buffer contains
-a dired for the specified directory.
-@enddefcom
-
-@defcom[com "Dired Update Buffer", bind (Dired: H-u)]
-This command is useful when the user knows the directory in the current
-@hid[Dired] buffer has changed.  @hemlock cannot know the directory structure
-has changed, but the user can explicitly update the buffer with this command
-instead of having to delete it and invoke @hid[Dired] again.
-@enddefcom
-
-@defcom[com "Dired Next File"]
-@defcom1[com "Dired Previous File"]
-These commands move to next or previous undeleted file.
-@enddefcom
-
-
-@subsection[Deleting Files]
-@defcom[com "Dired Delete File and Down Line", bind (Dired: d)]
-This command marks for deletion the file on the current line with the point and
-moves point down a line.
-@enddefcom
-
-@defcom[com "Dired Delete File with Pattern", bind (Dired: D)]
-This command prompts for a name pattern that may contain at most one wildcard,
-an asterisk, and marks for deletion all the names matching the pattern.
-@enddefcom
-
-@defcom[com "Dired Delete File", bind (Dired: C-d)]
-This command marks for deletion the file on the current line with the point
-without moving the point.
-@enddefcom
-
-
-@subsection[Undeleting Files]
-@defcom[com "Dired Undelete File and Down Line", bind (Dired: u)]
-This command unmarks for deletion the file on the current line with the point
-and moves point down a line.
-@enddefcom
-
-@defcom[com "Dired Undelete File with Pattern", bind (Dired: U)]
-This command prompts for a name pattern that may contain at most one wildcard,
-an asterisk, and unmarks for deletion all the names matching the pattern.
-@enddefcom
-
-@defcom[com "Dired Undelete File", bind (Dired: C-u)]
-This command unmarks for deletion the file on the current line with the point
-without moving the point.
-@enddefcom
-
-
-@subsection[Expunging and Quitting]
-@defcom[com "Dired Expunge Files", bind (Dired: !)]
-@defhvar1[var "Dired File Expunge Confirm", val {t}]
-@defhvar1[var "Dired Directory Expunge Confirm", val {t}]
-This command deletes files marked for deletion, asking the user for
-confirmation once for all the files flagged.  It recursively deletes any marked
-directories, asking the user for confirmation once for all those marked.
-@hid[Dired File Expunge Confirm] and @hid[Dired Directory Expunge Confirm] when
-set to @nil individually inhibit the confirmation prompting for the appropriate
-deleting.
-@enddefcom
-
-@defcom[com "Dired Quit", bind (Dired: q)]
-This command expunges any marked files or directories as if by @hid[Expunge
-Dired Files] before deleting the @hid[Dired] buffer.
-@enddefcom
-
-
-@subsection[Copying Files]
-@defcom[com "Dired Copy File", bind (Dired: c)]
-This command prompts for a destination specification and copies the file on the
-line with the point.  When prompting, the current line's specification is the
-default, which provides some convenience in supplying the destination.  The
-destination is either a directory specification or a file name, and when it is
-the former, the source is copied into the directory under its current file name
-and extension.
-@enddefcom
-
-@defcom[com "Dired Copy with Wildcard", bind (Dired: C)]
-This command prompts for a name pattern that may contain at most one wildcard,
-an asterisk, and copies all the names matching the pattern.  When prompting for
-a destination, this provides the @hid[Dired] buffer's directory as a default.
-The destination is either a directory specification or a file name with a
-wildcard.  When it is the former, all the source files are copied into the
-directory under their current file names and extensions.  When it is the later,
-each sources file's substitution for the wildcard causing it to match the first
-pattern replaces the wildcard in the destination pattern; for example, you
-might want to copy @f["*.txt"] to @f["*.text"].
-@enddefcom
-
-@defhvar[var "Dired Copy File Confirm", val {t}]
-@label[copy-confirm]
-This variable controls interaction with the user when it is not obvious what
-the copying process should do.  This takes one of the following values:
-@Begin[Description]
-@true@\
-When the destination specification exists, the copying process stops and asks
-the user if it should overwrite the destination.
-
-@nil@\
-The copying process always copies the source file to the destination
-specification without interacting with the user.
-
-@kwd[update]@\
-When the destination specification exists, and its write date is newer than
-the source's write date, then the copying process stops and asks the user if it
-should overwrite the destination.
-@End[Description]
-@enddefhvar
-
-
-@subsection[Renaming Files]
-@defcom[com "Dired Rename File", bind (Dired: r)]
-Rename the file or directory under the point
-@enddefcom
-
-@defcom[com "Dired Rename with Wildcard", bind (Dired: R)]
-Rename files that match a pattern containing ONE wildcard.
-@enddefcom
-
-@defhvar[var "Dired Rename File Confirm", val {t}]
-When non-nil, @hid[Dired] will query before clobbering an existing file.
-@enddefhvar
-
-
-@section[View Mode]
-@hid[View] mode provides for scrolling through a file read-only, terminating
-the buffer upon reaching the end.
-
-@defcom[com "View File"]
-This command reads a file into a new buffer as if by "Visit File", but
-read-only.  Bindings exist for scrolling and backing up in a single key stroke.
-@enddefcom
-
-@defcom[com "View Help", bind (View: ?)]
-This command shows a help message for @hid[View] mode.
-@enddefcom
-
-@defcom[com "View Edit File", bind (View: e)]
-This commands makes a buffer in @hid[View] mode a normal editing buffer,
-warning if the file exists in another buffer simultaneously.
-@enddefcom
-
-@defcom[com "View Scroll Down", bind (View: Space)]
-@defhvar1[var "View Scroll Deleting Buffer", val {t}]
-This command scrolls the current window down through its buffer.  If the end of
-the file is visible, then this deletes the buffer if @hid[View Scroll Deleting
-Buffer] is set.  If the buffer is associated with a @hid[Dired] buffer, this
-returns there instead of to the previous buffer.
-@enddefcom
-
-@defcom[com "View Return", bind (View: ^)]
-@defcom1[com "View Quit", bind (View: q)]
-These commands invoke a function that returns to the buffer that created the
-current buffer in @hid[View] mode.  Sometimes this function does nothing, but
-it is useful for returning to @hid[Dired] buffers and similar @hemlock
-features.
-
-After invoking the viewing return function if there is one, @hid[View Quit]
-deletes the buffer that is current when the user invokes it.
-@enddefcom
-
-Also, bound in @hid[View] mode are the following commands:
-@Begin[Description]
-@binding[backspace], @binding[delete]@\Scrolls the window up.
-
-@binding[<]@\Goes to the beginning of the buffer.
-
-@binding[>]@\Goes to the end of the buffer.
-@End[Description]
-
-
-@section[Process Mode]
-@Label[process]
-@Index[shells]
-@Index[processes]
-
-@hid[Process] mode allows the user to execute a Unix process within a @hemlock
-buffer.  These commands and default bindings cater to running Unix shells in
-buffers.  For example, @hid[Stop Buffer Subprocess] is bound to @binding[H-z]
-to stop the process you are running in the shell instead of binding @hid[Stop
-Main Process] to this key which would stop the shell itself.
-
-@defcom[com "Shell", bind (C-M-s)]
-@defhvar1[var "Shell Utility", val {"/bin/csh"}]
-@defhvar1[var "Shell Utility Switches", val {@nil}]
-@defhvar1[var "Current Shell"]
-@defhvar1[var "Ask about Old Shells"]
-This command executes the process determined by the values of @hid(Shell
-Utility) and @hid(Shell Utility Switches) in a new buffer named @f["Shell n"]
-where @f["n"] is some distinguishing integer.
-
-@hid[Current Shell] is a @hemlock variable that holds to the current shell
-buffer.  When @hid[Shell] is invoked, if there is a @hid[Current Shell], the
-command goes to that buffer.
-
-When there is no @hid[Current Shell], but shell buffers do exist, if @hid[Ask
-about Old Shells] is set, the @hid[Shell] command prompts for one of them,
-setting @hid[Current Shell] to the indicated shell, and goes to the buffer.
-
-Invoking @hid[Shell] with an argument forces the creation of a new shell
-buffer.
-
-@hid[Shell Utility] is the string name of the process to execute.
-
-@hid[Shell Utility Switches] is a string containing the default command line
-arguments to @hid[Shell Utility].  This is a string since the utility is
-typically @f["/bin/csh"], and this string can contain I/O redirection and other
-shell directives.
-@enddefcom
-
-@defcom[com "Shell Command Line in Buffer"]
-This command prompts for a buffer and a shell command line.  It then runs a
-shell, giving it the command line, in the buffer.
-@enddefcom
-
-@defcom[com "Set Current Shell"]
-This command sets the value of @hid[Current Shell].
-@enddefcom
-
-@defcom[com "Stop Main Process"]
-This command stops the process running in the current buffer by sending a
-@f[:SIGTSTP] to that process.  With an argument, stops the process using
-@f[:SIGSTOP].
-@enddefcom
-
-@defcom[com "Continue Main Process"]
-If the process in the current buffer is stopped, this command continues it.
-@enddefcom
-
-@defcom[com "Kill Main Process"]
-@defhvar1[var "Kill Process Confirm", val {t}]
-This command prompts for confirmation and kills the process running in the
-current buffer.
-
-Setting this variable to @nil inhibits @hemlock's prompting for confirmation.
-@enddefcom
-
-@defcom[com "Stop Buffer Subprocess", stuff (bound to @bf[H-z] in @hid[Process] mode)]
-This command stops the foreground subprocess of the process in the current
-buffer, similar to the effect of @binding[C-Z] in a shell.
-@enddefcom
-
-@defcom[com "Kill Buffer Subprocess"]
-This command kills the foreground subprocess of the process in the current
-buffer.
-@enddefcom
-
-@defcom[com "Interrupt Buffer Subprocess", stuff (bound to  @bf[H-c] in @hid[Process] mode)]
-This command interrupts the foreground subprocess of the process in the
-current buffer, similar to the effect of @binding[C-C] in a shell.
-@enddefcom
-
-@defcom[com "Quit Buffer Subprocess", stuff (bound to @bf[H-\] in @hid[Process] mode)]
-This command dumps the core of the foreground subprocess of the processs in
-the current buffer, similar to the effect of @binding[C-\] in a shell.
-@enddefcom
-
-@defcom[com "Send EOF to Process", stuff (bound to @bf[H-d] in @hid[Process] mode)]
-This command sends the end of file character to the process in the current
-buffer, similar to the effect of @binding[C-D] in a shell.
-@enddefcom
-
-@defcom[com "Confirm Process Input", stuff (bound to @bf[Return] in @hid[Process] mode)]
-This command sends the text the user has inserted at the end of a process
-buffer to the process in that buffer.  Resulting output is inserted at the end
-of the process buffer.
-@enddefcom
-
-The user may edit process input using commands that are shared with
-@hid[Typescript] mode, see section @ref[typescripts].
-
-
-@section[Bufed Mode]
-@hemlock provides a mechanism for managing buffers as an itemized list.
-@hid[Bufed] supports conveniently deleting several buffers at once, saving
-them, going to one, etc., all in a key stroke.
-
-@defcom[com "Bufed", bind (C-x C-M-b)]
-This command creates a list of buffers in a buffer supporting operations such
-as deletion, saving, and selection.  If there already is a @hid[Bufed] buffer,
-this just goes to it.
-@enddefcom
-
-@defcom[com "Bufed Help"]
-This command pops up a display of @hid[Bufed] help.
-@enddefcom
-
-@defcom[com "Bufed Delete", bind (Bufed: C-d, C-D, D, d)]
-@defhvar1[var "Virtual Buffer Deletion", val {t}]
-@defhvar1[var "Bufed Delete Confirm", val {t}]
-@hid[Bufed Delete] deletes the buffer on the current line.
-
-When @hid[Virtual Buffer Deletion] is set, this merely flags the buffer for
-deletion until @hid[Bufed Expunge] or @hid[Bufed Quit] executes.
-
-Whenever these commands actually delete a buffer, if @hid[Bufed Delete Confirm]
-is set, then @hemlock prompts the user for permission; if more than one buffer
-is flagged for deletion, this only prompts once.  For each modified buffer,
-@hemlock asks to save the buffer before deleting it.
-@enddefcom
-
-@defcom[com "Bufed Undelete", bind (Bufed: U, u)]
-This command undeletes the buffer on the current line.
-@enddefcom
-
-@defcom[com "Bufed Expunge", bind (Bufed: !)]
-This command expunges any buffers marked for deletion regarding @hid[Bufed
-Delete Confirm].
-@enddefcom
-
-@defcom[com "Bufed Quit", bind (Bufed: q)]
-This command kills the @hid[Bufed] buffer, expunging any buffers marked for
-deletion.
-@enddefcom
-
-@defcom[com "Bufed Goto", bind (Bufed: Space)]
-This command selects the buffer on the current line, switching to it.
-@enddefcom
-
-@defcom[com "Bufed Goto and Quit", bind (Bufed: S-leftdown)]
-This command goes to the buffer under the pointer, quitting @hid[Bufed].  It
-supplies a function for @hid[Generic Pointer Up] which is a no-op.
-@enddefcom
-
-@defcom[com "Bufed Save File", bind (Bufed: s)]
-This command saves the buffer on the current line.
-@enddefcom
-
-
-@section[Completion]
-This is a minor mode that saves words greater than three characters in length,
-allowing later completion of those words.  This is very useful for the often
-long identifiers used in Lisp programs.  As you type a word, such as a Lisp
-symbol when in @hid[Lisp] mode, and you progress to typing the third letter,
-@hemlock displays a possible completion in the status line.  You can then
-rotate through the possible completions or type some more letters to narrow
-down the possibilities.  If you choose a completion, you can also rotate
-through the possibilities in the buffer instead of in the status line.
-Choosing a completion or inserting a character that delimits words moves the
-word forward in the ring of possible completions, so the next time you enter
-its initial characters, @hemlock will prefer it over less recently used
-completions.
-
-@defcom[com "Completion Mode"]
-This command toggles @hid[Completion] mode in the current buffer.
-@enddefcom
-
-@defcom[com "Completion Self Insert"]
-This command is like @hid[Self Insert], but it also checks for possible
-completions displaying any result in the status line.  This is bound to most of
-the key-events with corresponding graphic characters.
-@enddefcom
-
-@defcom[com "Completion Complete Word", bind (Completion: End)]
-This command selects the currently displayed completion if there is one,
-guessing the case of the inserted text as with @hid[Query Replace].  Invoking
-this immediately in succession rotates through possible completions in the
-buffer.  If there is no currently displayed completion on a first invocation,
-this tries to find a completion from text immediately before the point and
-displays the completion if found.
-@enddefcom
-
-@defcom[com "Completion Rotate Completions", bind (Completion: M-End)]
-This command displays the next possible completion in the status line.  If
-there is no currently displayed completion, this tries to find a completion
-from text immediately before the point and displays the completion if found.
-@enddefcom
-
-@defcom[com "List Possible Completions"]
-This command lists all the possible completions for the text immediately before
-the point in a pop-up display.  Sometimes this is more useful than rotating
-through several completions to see if what you want is available.
-@enddefcom
-
-@defhvar[var "Completion Bucket Size", val {20}]
-Completions are stored in buckets determined by the first three letters of a
-word. This variable limits the number of completions saved for each combination
-of the first three letters of a word.  If you have many identifier in some
-module beginning with the same first three letters, you'll need increase this
-variable to accommodate all the names.
-@enddefhvar
-
-
-@defcom[com "Save Completions"]
-@defcom1[com "Read Completions"]
-@defhvar1[var "Completion Database Filename", val {nil}]
-@hid[Save Completions] writes the current completions to the file
-@hid[Completion Database Filename].  It writes them, so @hid[Read Completions]
-can read them back in preserving the most-recently-used order.  If the user
-supplies an argument, then this prompts for a pathname.
-
-@hid[Read Completions] reads completions saved in @hid[Completion Database
-Filename].  It moves any current completions to a less-recently-used status,
-and it removes any in a given bucket that exceed the limit @hid[Completion
-Bucket Size].
-@enddefcom
-
-@defcom[com "Parse Buffer for Completions"]
-This command passes over the current buffer putting each valid completion word
-into the database.  This is a good way of picking up many useful completions
-upon visiting a new file for which there are no saved completions.
-@enddefcom
-
-
-@section[CAPS-LOCK Mode]
-
-@hid[CAPS-LOCK] is a minor mode in which @hemlock that inserts all alphabetic
-characters as uppercase letters.
-
-@defcom[com "Caps Lock Mode"]
-This command toggles @hid[CAPS-LOCK] mode for the current buffer; it is most
-useful when bound to a key, so you can enter and leave @hid[CAPS-LOCK] mode
-casually.
-@enddefcom
-
-@defcom[com "Self Insert Caps Lock"]
-This command inserts the uppercase version of the character corresponding to
-the last key-event typed.
-@enddefcom
-
-
-
-@section[Overwrite Mode]
-
-@hid[Overwrite] mode is a minor mode which is useful for creating figures and
-tables out of text.  In this mode, typing a key-event with a corresponding
-graphic character replaces the character at the point instead of inserting the
-character.  @hid[Quoted Insert] can be used to insert characters normally.
-
-@defcom[com "Overwrite Mode"]
-This command turns on @hid[Overwrite] mode in the current buffer.  If it is
-already on, then it is turned off.  A positive argument turns @hid[Overwrite]
-mode on, while zero or a negative argument turns it off.
-@enddefcom
-
-@defcom[com "Self Overwrite"]
-This command replaces the next character with the character corresponding to
-the key-event used to invoke the command.  After replacing the character, this
-moves past it.  If the next character is a tab, this first expands the tab into
-the appropriate number of spaces, replacing just the next space character.
-At the end of the line, it inserts the
-character instead of clobbering the newline.
-
-This is bound to key-events with corresponding graphic characters in
-@hid[Overwrite] mode.
-@enddefcom
-
-@defcom[com "Overwrite Delete Previous Character",
-       stuff (bound to @bf[Delete] and @bf[Backspace] in @hid[Overwrite] mode)]
-This command replaces the previous character with a space and moves backwards.
-This deletes tabs and newlines.
-@enddefcom
-
-
-@section[Word Abbreviation]
-@index[word abbreviation]
-Word abbreviation provides a way to speed the typing of frequently used words
-and phrases.  When in @hid[Abbrev] mode, typing a word delimiter causes the
-previous word to be replaced with its @i[expansion] if there is one currently
-defined.  The expansion for an abbrev may be any string, so this mode can be
-used for abbreviating programming language constructs and other more obscure
-uses.  For example, @hid[Abbrev] mode can be used to automatically correct
-common spelling mistakes and to enforce consistent capitalization of
-identifiers in programs.
-
-@i[Abbrev] is an abbreviation for @i[abbreviation], which is used for
-historical reasons.  Obviously the original writer of @hid[Abbrev] mode hated
-to type long words and could hardly use @hid[Abbrev] mode while writing
-@hid[Abbrev] mode. 
-
-A word abbrev can be either global or local to a major mode.  A global word
-abbrev is defined no matter what the current major mode is, while a mode word
-abbrev is only defined when its mode is the major mode in the current buffer.
-Mode word abbrevs can be used to prevent abbrev expansion in inappropriate
-contexts.
-
-
-@subsection[Basic Commands]
-
-@defcom[com "Abbrev Mode"]
-This command turns on @hid[Abbrev] mode in the current buffer.  If @hid[Abbrev]
-mode is already on, it is turned off.  @hid[Abbrev] mode must be on for the
-automatic expansion of word abbrevs to occur, but the abbreviation commands are
-bound globally and may be used at any time.
-@enddefcom
-
-@defcom[com "Abbrev Expand Only", 
-        stuff (bound to word-delimiters in @hid[Abbrev] mode)]
-This is the word abbrev expansion command.  If the word before the point is a
-defined word abbrev, then it is replaced with its expansion.  The replacement
-is done using the same case-preserving heuristic as is used by
-@hid[Query Replace].  This command is globally bound to @binding[M-Space] so
-that abbrevs can be expanded when @hid[Abbrev] mode is off.  An undesirable
-expansion may be inhibited by using @binding[C-q] to insert the delimiter.
-@enddefcom
-
-@defcom[com "Inverse Add Global Word Abbrev", bind (C-x -)]
-@defcom1[com "Inverse Add Mode Word Abbrev", bind (C-x C-h, C-x Backspace)]
-@hid[Inverse Add Global Word Abbrev] prompts for a string and makes it the
-global word abbrev expansion for the word before the point.
-
-@hid[Inverse Add Mode Word Abbrev] is identical to 
-@hid[Inverse Add Global Word Abbrev] except that it defines an expansion which
-is local to the current major mode.
-@enddefcom
-
-@defcom[com "Make Word Abbrev"]
-This command defines an arbitrary word abbreviation.  It prompts for the mode,
-abbreviation and expansion.  If the mode @f["Global"] is specified, then it
-makes a global abbrev.
-@enddefcom
-
-@defcom[com "Add Global Word Abbrev", bind (C-x +)]
-@defcom1[com "Add Mode Word Abbrev", bind (C-x C-a)]
-@hid[Add Global Word Abbrev] prompts for a word and defines it to be a global
-word abbreviation.  The prefix argument determines which text is used as the
-expansion:
-@begin[description]
-@i[no prefix argument]@\The word before the point is used as the expansion of
-the abbreviation.
-
-@i[zero prefix argument]@\The text in the region is used as the expansion of the
-abbreviation.
-
-@i[positive prefix argument]@\That many words before the point are made the
-expansion of the abbreviation.
-
-@i[negative prefix argument]@\Do the same thing as 
-@hid[Delete Global Word Abbrev] instead of defining an abbreviation.
-@end[description]
-
-@hid[Add Mode Word Abbrev] is identical to @hid[Add Global Word Abbrev] except
-that it defines or deletes mode word abbrevs in the current major mode.
-@enddefcom
-
-@defcom[com "Word Abbrev Prefix Mark", bind (M-")]
-This command allows @hid[Abbrev Expand Only] to recognize abbreviations when
-they have prefixes attached.  First type the prefix, then use this command.  A
-hyphen (@f[-]) will be inserted in the buffer.  Now type the abbreviation and
-the word delimiter.  @hid[Abbrev Expand Only] will expand the abbreviation and
-remove the hyphen.
-
-Note that there is no need for a suffixing command, since 
-@hid[Abbrev Expand Only] may be used explicitly by typing @binding[M-Space].
-@enddefcom
-
-@defcom[com "Unexpand Last Word", bind (C-x u)]
-This command undoes the last word abbrev expansion.  If repeated, undoes its
-own effect.
-@enddefcom
-
-
-@subsection[Word Abbrev Files]
-A word abbrev file is a file which holds word abbrev definitions.  Word abbrev
-files allow abbrevs to be saved so that they may be used across many editing
-sessions.
-
-@defhvar[var "Abbrev Pathname Defaults", val {(pathname "abbrev.defns")}]
-This is sticky default for the following commands.  When they prompt for a file
-to write, they offer this and set it for the next time one of them executes.
-@enddefhvar
-
-@defcom[com "Read Word Abbrev File"]
-This command reads in a word abbrev file, adding all the definitions to those
-currently defined.  If a definition in the file is different from the current
-one, the current definition is replaced.
-@enddefcom
-
-@defcom[com "Write Word Abbrev File"]
-This command prompts for a file and writes all currently defined word abbrevs
-out to it.
-@enddefcom
-
-@defcom[com "Append to Word Abbrev File"]
-This command prompts for a word abbrev file and appends any new definitions to
-it.  An abbrev is new if it has been defined or redefined since the last use of
-this command.  Definitions made by reading word abbrev files are not
-considered.
-@enddefcom
-
-
-@subsection[Listing Word Abbrevs]
-@defcom[com "List Word Abbrevs"]
-@defcom1[com "Word Abbrev Apropos"]
-@hid[List Word Abbrevs] displays a list of each defined word abbrev, with its
-mode and expansion.
-
-@hid[Word Abbrev Apropos] is similar, except that it only displays abbrevs
-which contain a specified string, either in the definition, expansion or mode.
-@enddefcom
-
-@subsection[Editing Word Abbrevs]
-Word abbrev definition lists are edited by editing the text representation
-of the definitions.  Word abbrev files may be edited directly, like any other
-text file.  The set of abbrevs currently defined in @hemlock may be edited
-using the commands described in this section.
-
-The text representation of a word abbrev is fairly simple.  Each definition
-begins at the beginning of a line.  Each line has three fields which are
-separated by ASCII tab characters.  The fields are the abbreviation, the mode
-of the abbreviation and the expansion.  The mode is represented as the mode
-name inside of parentheses.  If the abbrev is global, then the mode field is
-empty.  The expansion is represented as a quoted string since it may contain
-any character.  The string is quoted with double-quotes (@f["]); double-quotes
-in the expansion are represented by doubled double-quotes.  The expansion may
-contain newline characters, in which case the definition will take up more than
-one line.
-
-@defcom[com "Edit Word Abbrevs"]
-This command inserts the current word abbrev definitions into the 
-@hid[Edit Word Abbrevs] buffer and then enters a recursive edit on the buffer.
-When the recursive edit is exited, the definitions in the buffer become the new
-current abbrev definitions.
-@enddefcom
-
-@defcom[com "Insert Word Abbrevs"]
-This command inserts at the point the text representation of the currently
-defined word abbrevs.
-@enddefcom
-
-@defcom[com "Define Word Abbrevs"]
-This command interprets the text of the current buffer as a word abbrev
-definition list, adding all the definitions to those currently defined.
-@enddefcom
-
-
-@subsection[Deleting Word Abbrevs]
-The user may delete word abbrevs either individually or collectively.
-Individual abbrev deletion neutralizes single abbrevs which have outlived their
-usefulness; collective deletion provides a clean slate from which to initiate
-abbrev definitions.
-
-@defcom[com "Delete All Word Abbrevs"]
-This command deletes all word abbrevs which are currently defined.
-@enddefcom
-
-@defcom[com "Delete Global Word Abbrev"]
-@defcom1[com "Delete Mode Word Abbrev"]
-@hid[Delete Global Word Abbrev] prompts for a word abbreviation and deletes its
-global definition.  If given a prefix argument, deletes all global abbrev
-definitions.
-
-@hid[Delete Mode Word Abbrev] is identical to @hid[Delete Global Word Abbrev]
-except that it deletes definitions in the current major mode.
-@enddefcom
-
-
-@section[Lisp Library]
-This is an implementation dependent feature.  The Lisp library is a collection
-of local hacks that users can submit and share that is maintained by the Lisp
-group.  These commands help peruse the catalog or description files and figure
-out how to load the entries.
-
-@defcom[com "Lisp Library"]
-This command finds all the library entries and lists them in a buffer.  The
-following commands describe and load those entries.
-@enddefcom
-
-@defcom[com "Describe Library Entry", bind (Lisp-Lib: space)]
-@defcom1[com "Describe Pointer Library Entry", bind (Lisp-Lib: leftdown)]
-@defcom1[com "Load Library Entry", bind (Lisp-Lib: rightdown)]
-@defcom1[com "Load Pointer Library Entry", bind (Lisp-Lib: l)]
-@defcom1[com "Editor Load Library Entry"]
-@defcom1[com "Editor Load Pointer Library Entry"]
-@hid[Load Library Entry] and @hid[Load Pointer Library Entry] load the library
-entry indicated by the line on which the point lies or where the user clicked
-the pointer, respectively.  These load the entry into the current slave Lisp.
-
-@hid[Editor Load Library Entry] and @hid[Editor Load Pointer Library Entry] are
-the same, but they load the entry into the editor Lisp.
-@enddefcom
-
-@defcom[com "Exit Lisp Library", bind (Lisp-Lib: q)]
-This command deletes the @hid[Lisp Library] buffer.
-@enddefcom
-
-@defcom[com "Lisp Library Help", bind (Lisp-Lib: ?)]
-This command pops up a help window listing @hid[Lisp-Lib] commands.
-@enddefcom
diff --git a/docs/hem/user/user.mss b/docs/hem/user/user.mss
deleted file mode 100644
index b7c2bd6ec2a11abb4990594944c5bff86e198da1..0000000000000000000000000000000000000000
--- a/docs/hem/user/user.mss
+++ /dev/null
@@ -1,2003 +0,0 @@
-@make[Manual] @comment{-*- Dictionary: /afs/cs/project/clisp/scribe/hem/hem; Mode: spell; Package: Hemlock -*-}
-@Device[postscript]
-@Style(Spacing = 1.2 lines)
-@Style(StringMax = 5000)
-@Use(Database "/afs/cs/project/clisp/docs/database/")
-@Style(FontFamily=TimesRoman)
-@Style(Date="March 1952")
-@style(DOUBLESIDED)
-@Libraryfile[ArpaCredit]
-@libraryfile[hem]
-@Libraryfile[Spice]
-@Libraryfile[Uttir]
-
-@String(REPORTTITLE "Hemlock User's Manual")
-
-@comment<@begin[TitlePage]
-@begin[TitleBox]
->
-@blankspace(1.3inches)
-@heading[Hemlock User's Manual]
-
-@center[@b<Bill Chiles>
-@b<Robert A. MacLachlan>
-
-
-@b<@value[date]>
-
-@b<CMU-CS-89-133-R1>
-]
-@comment<@end[TitleBox]>
-@blankspace(2lines)
-@begin[Center]
-School of Computer Science
-Carnegie Mellon University
-Pittsburgh, PA 15213
-@end[Center]
-@blankspace[2lines]
-
-@begin[Center]
-This is a revised version of Technical Report CMU-CS-87-158.
-@end[Center]
-
-@heading<Abstract>
-@begin(Text, indent 0)
-This document describes the @Hemlock text editor, version M3.2.  @Hemlock is a
-customizable, extensible text editor whose initial command set closely
-resembles that of ITS/TOPS-20 @Emacs.  @Hemlock is written in CMU Common Lisp
-and has been ported to other implementations.
-@end(Text)
-
-@begin[ResearchCredit]
-@ArpaCredit[Contract=Basic87-90]
-@end[ResearchCredit]
-@comment<@end[TitlePage]>
-
-
-@commandstring(mh = "@f1(MH)")
-@commandstring(dash = "@Y[M]")
-
-@comment[This tabclear is necessary since the definition macros don't
-	 take care of the own tabbing needs]
-@tabclear
-
-
-@comment[@chap (Introduction)]
-@include(intro)
-
-
-@comment[@chap (Basic Commands)]
-@include(commands)
-
-
-
-@chap[Files, Buffers, and Windows]
-
-@section[Introduction]
-
-@index[files]
-@index[buffers]
-@index[windows]
-@hemlock provides three different abstractions which are used in combination to
-solve the text-editing problem, while other editors tend to mash these ideas
-together into two or even one.
-@begin[description]
-File@\A file provides permanent storage of text.  @hemlock has commands
-to read files into buffers and write buffers out into files.
-
-Buffer@\A buffer provides temporary storage of text and a capability to
-edit it.  A buffer may or may not have a file associated with it; if it
-does, the text in the buffer need bear no particular relation to the text
-in the file.  In addition, text in a buffer may be displayed in any number
-of windows, or may not be displayed at all.
-
-Window@\A window displays some portion of a buffer on the screen.  There
-may be any number of windows on the screen, each of which may display any
-position in any buffer.  It is thus possible, and often useful, to have
-several windows displaying different places in the same buffer.
-@end[description]
-
-
-@section[Buffers]
-In addition to some text, a buffer has several other user-visible attributes:
-@begin[description]
-A name@\
-A buffer is identified by its name, which allows it to be selected, destroyed,
-or otherwise manipulated.
-
-A collection of modes@\
-The modes present in a buffer alter the set of commands available and
-otherwise alter the behavior of the editor.  For details see page
-@pageref[modes].
-
-A modification flag @\
-This flag is set whenever the text in a buffer is modified.  It is often
-useful to know whether a buffer has been changed, since if it has it should
-probably be saved in its associated file eventually.
-
-A write-protect flag @\
-If this flag is true, then any attempt to modify the buffer will result in an
-error.
-@end[description]
-
-@defcom[com "Select Buffer", bind (C-x b)]
-This command prompts for the name of a existing buffer and makes that buffer
-the @i[current buffer].  The newly selected buffer is displayed in the
-current window, and editing commands now edit the text in that buffer.
-Each buffer has its own point, thus the point will be in the place it was
-the last time the buffer was selected.  When prompting for the buffer, the
-default is the buffer that was selected before the current one.
-@enddefcom
-
-@defcom[com "Select Previous Buffer", bind (C-M-l)]
-@defcom1[com "Circulate Buffers", bind (C-M-L)]
-With no prefix argument, @hid[Select Previous Buffer] selects the buffer that
-has been selected most recently, similar to @binding[C-x b Return].  If given a
-prefix argument, then it does the same thing as @hid[Circulate Buffers].
-
-@hid[Circulate Buffers] moves back into successively earlier buffers in the
-buffer history.  If the previous command was not @hid[Circulate Buffers] or
-@hid[Select Previous Buffer], then it does the same thing as
-@hid[Select Previous Buffer], otherwise it moves to the next most recent
-buffer.  The original buffer at the start of the excursion is made the previous
-buffer, so @hid[Select Previous Buffer] will always take you back to where you
-started.
-
-These commands are generally used together.  Often @hid[Select Previous Buffer]
-will take you where you want to go.  If you don't end up there, then using
-@hid[Circulate Buffers] will do the trick.
-@enddefcom
-
-@defcom[com "Create Buffer", bind (C-x M-b)]
-This command is very similar to @hid[Select Buffer], but the buffer need not
-already exist.  If the buffer does not exist, a new empty buffer is created
-with the specified name.
-@enddefcom
-
-@defcom[com "Kill Buffer", bind (C-x k)]
-This command is used to make a buffer go away.  There is no way to restore
-a buffer that has been accidentally deleted, so the user is given a chance
-to save the hapless buffer if it has been modified.  This command is poorly
-named, since it has nothing to do with killing text.
-@enddefcom
-
-@defcom[com "List Buffers", bind (C-x C-b)]
-This command displays a list of all existing buffers in a pop-up window.  A
-"@f[*]" is displayed before the name of each modified buffer.  A buffer with no
-associated file is represented by the buffer name followed by the number of
-lines in the buffer.  A buffer with an associated file are is represented by
-the name and type of the file, a space, and the device and directory.  If the
-buffer name doesn't match the associated file, then the buffer name is also
-displayed.  When given a prefix argument, this command lists only the modified
-buffers.
-@enddefcom
-
-@defcom[com "Buffer Not Modified", bind (M-~)]
-This command resets the current buffer's modification flag @dash @i[it does not
-save any changes].  This is primarily useful in cases where a user accidentally
-modifies a buffer and then undoes the change.  Resetting the modified flag
-indicates that the buffer has no changes that need to be written out.
-@enddefcom
-
-@defcom[com "Check Buffer Modified", bind (C-x ~)]
-This command displays a message indicating whether the current buffer is modified.
-@enddefcom
-
-@defcom[com "Set Buffer Read-Only"]
-This command changes the flag that allows the current buffer to be modified.
-If a buffer is read-only, any attempt to modify it will result in an error.  The
-buffer may be made writable again by repeating this command.
-@enddefcom
-
-@defcom[com "Set Buffer Writable"]
-This command ensures the current buffer is modifiable.
-@enddefcom
-
-@defcom[com "Insert Buffer"]
-This command prompts for the name of a buffer and inserts its contents at the
-point, pushing a buffer mark before inserting.  The buffer inserted is
-unaffected.
-@enddefcom  
-
-@defcom[com "Rename Buffer"]
-This command prompts for a new name for the current buffer, which defaults
-to a name derived from the associated filename.
-@enddefcom
-
-
-@section[Files]
-@index[files]
-These commands either read a file into the current buffer or write it out to
-some file.  Various other bookkeeping operations are performed as well.
-
-@defcom[com "Find File", bind (C-x C-f)]
-This is the command normally used to get a file into @hemlock.  It prompts
-for the name of a file, and if that file has already been read in, selects
-that buffer; otherwise, it reads file into a new buffer whose name is
-derived from the name of the file.  If the file does not exist, then the
-buffer is left empty, and @w<"@f[(New File)]"> is displayed in the echo area;
-the file may then be created by saving the buffer.
-
-The buffer name created is in the form @w<"@i[name] @i[type] @i[directory]">.
-This means that the filename "@f[/sys/emacs/teco.mid]" has
-@w<"@f[Teco Mid /Sys/Emacs/]"> as its the corresponding buffer name.  The
-reason for rearranging the fields in this fashion is that it facilitates
-recognition since the components most likely to differ are placed first.  If
-the buffer cannot be created because it already exists, but has another file in
-it (an unlikely occurrence), then the user is prompted for the buffer to use,
-as by @hid[Create Buffer].
-
-@hid[Find File] takes special action if the file has been modified on disk
-since it was read into @hemlock.  This usually happens when several people are
-simultaneously editing a file, an unhealthy circumstance.  If the buffer is
-unmodified, @hid[Find File] just asks for confirmation before reading in the
-new version.  If the buffer is modified, then @hid[Find File] beeps and prompts
-for a single key-event to indicate what action to take.  It recognizes
-the following key-events:
-@begin[description]
-@binding[Return, Space, y]@\
- Prompt for a file in which to save the current buffer and then read in the
-file found to be modified on disk.
-
-@binding[Delete, Backspace, n]@\
- Forego reading the file.
-
-@binding[r]@\
- Read the file found to be modified on disk into the buffer containing the
-earlier version with modifications.  This loses all changes you had in the
-buffer.
-@end[description]
-@enddefcom
-
-@defcom[com "Save File", bind (C-x C-s)]
-This command writes the current buffer out to its associated file and
-resets the buffer modification flag.  If there is no associated file, then
-the user is prompted for a file, which is made the associated file.  If
-the buffer is not modified, then the user is asked whether to actually
-write it or not.
-
-If the file has been modified on disk since the last time it was read,
-@hid[Save File] prompts for confirmation before overwriting the file.
-@enddefcom
-
-@defcom[com "Save All Files", bind (C-x C-m)]
-@defcom1[com "Save All Files and Exit", bind (C-x M-z)]
-@defhvar1[var "Save All Files Confirm", val {t}]
-@hid[Save All Files] does a @hid[Save File] on all buffers which have an
-associated file.  @hid[Save All Files and Exit] does the same thing and then
-exits @hemlock.
-
-When @hid[Save All Files Confirm] is true, these commands will ask for
-confirmation before saving a file.
-@enddefcom
-
-@defcom[com "Visit File", bind (C-x C-v)]
-This command prompts for a file and reads it into the current buffer,
-setting the associated filename.  Since the old contents of the buffer are
-destroyed, the user is given a chance to save the buffer if it is modified.
-As for @hid[Find File], the file need not actually exist.  This command warns
-if some other buffer also contains the file.
-@enddefcom
-
-@defcom[com "Write File", bind (C-x C-w)] This command prompts for a file
-and writes the current buffer out to it, changing the associated filename
-and resetting the modification flag.  When the buffer's associated file is
-specified this command does the same thing as @hid[Save File].  @enddefcom
-
-@defcom[com "Backup File"]
-This command is similar to @hid[Write File], but it neither sets the
-associated filename nor clears the modification flag.  This is useful for
-saving the current state somewhere else, perhaps on a reliable machine.
-
-Since @hid[Backup File] doesn't update the write date for the buffer,
-@hid[Find File] and @hid[Save File] will get all upset if you back up
-a buffer on any file that has been read into @hemlock.
-@enddefcom
-
-@defcom[com "Revert File"]
-@defhvar1[var "Revert File Confirm", val {t}]
-This command replaces the text in the current buffer with the contents of the
-associated file or the checkpoint file for that file, whichever is more recent.
-The point is put in approximately the same place that it was before the file
-was read.  If the original file is reverted to, then clear the modified flag,
-otherwise leave it set.  If a prefix argument is specified, then always revert
-to the original file, ignoring any checkpoint file.
-
-If the buffer is modified and @hid[Revert File Confirm] is true, then the user
-is asked for confirmation.
-@enddefcom
-
-@defcom[com "Insert File", bind (C-x C-r)]
-This command prompts for a file and inserts it at the point, pushing a buffer
-mark before inserting.
-@enddefcom
-
-@defcom[com "Write Region"]
-This command prompts for a file and writes the text in the region out to it.
-@enddefcom
-
-@defhvar[var "Add Newline at EOF on Writing File", val {:ask-user}]
-This variable controls whether some file writing commands add a newline at the
-end of the file if the last line is non-empty.
-@begin[description]
-@f[:ask-user]@\Ask the user whether to add a newline.
-
-@f[t]@\Automatically add a newline and inform the user.
-
-@nil@\Never add a newline and do not ask.
-@end[description]
-Some programs will lose the text on the last line or get an
-error when the last line does not have a newline at the end.
-@enddefhvar
-
-@defhvar[var "Keep Backup Files", val {nil}]
-Whenever a file is written by @hid[Save File] and similar commands, the old
-file is renamed by appending "@f[.BAK]" to the name, ensuring that some version
-of the file will survive a system crash during the write.  If set to true, this
-backup file will not deleted even when the write successfully completes.
-@enddefhvar
-
-
-@subsection[Auto Save Mode]
-
-@hid[Save] mode protects against loss of work in system crashes by periodically
-saving modified buffers in checkpoint files.
-
-@defcom[com "Auto Save Mode"]
-This command turns on @hid[Save] mode if it is not on, and turns off when it is
-on.  @hid[Save] mode is on by default.
-@enddefcom
-
-@defhvar[var "Auto Save Checkpoint Frequency", val {120}]
-@defhvar1[var "Auto Save Key Count Threshold", val {256}]
-These variables determine how often modified buffers in @hid[Save] mode will be
-checkpointed.  Checkpointing is done after
-@hid[Auto Save Checkpoint Frequency] seconds, or after
-@hid[Auto Save Key Count Threshold] keystrokes that modify the buffer
-(whichever comes first).  Either kind of checkpointing may be disabled by
-setting the corresponding variable to @nil.
-@enddefhvar
-
-@defhvar[var "Auto Save Cleanup Checkpoints", val {t}]
-If this variable is true, then any checkpoint file for a buffer will be deleted
-when the buffer is successfully saved in its associated file.
-@enddefhvar
-
-@defhvar[var "Auto Save Filename Pattern", val {"~A~A.CKP"}]
-@defhvar1[var "Auto Save Pathname Hook", val {make-unique-save-pathname}]
-These variables determine the naming of checkpoint files.
-@hid[Auto Save Filename Pattern] is a format string used to name the checkpoint
-files for buffers with associated files.  Format is called with two arguments:
-the directory and file namestrings of the associated file.
-
-@hid[Auto Save Pathname Hook] is a function called by @hid[Save] mode to get a
-checkpoint pathname when there is no pathname associated with a buffer.  It
-should take a buffer as its argument and return either a pathname or @nil.  If
-a pathname is returned, then it is used as the name of the checkpoint file.  If
-the function returns @nil, or if the hook variable is @nil, then @hid[Save]
-mode is turned off in the buffer.  The default value for this variable returns
-a pathname in the default directory of the form "@w<@f[save-]@i[number]>",
-where @i[number] is a number used to make the file unique.
-@enddefhvar
-
-
-@subsection[Filename Defaulting and Merging]
-@index[merging, filename]
-@index[defaulting, filename]
-@index[filename defaulting]
-@label[merging]
-@index[pathnames]
-When @hemlock prompts for the name of a file, it always offers a default.
-Except for a few commands that have their own defaults, filename defaults are
-computed in a standard way.  If it exists, the associated file for the current
-buffer is used as the default, otherwise a more complex mechanism creates a
-default.
-
-@defhvar[var "Pathname Defaults", val {(pathname "gazonk.del")}]
-@defhvar1[var "Last Resort Pathname Defaults Function"]
-@defhvar1[var "Last Resort Pathname Defaults", val {(pathname "gazonk")}]
-These variables control the computation of default filename defaults when the
-current buffer has no associated file.
-
-@hid[Pathname Defaults] holds a "sticky" filename default.  Commands that
-prompt for files set this to the file specified, and the value is used as a
-basis for filename defaults.  It is undesirable to offer the unmodified value
-as a default, since it is usually the name of an existing file that we don't
-want to overwrite.  If the current buffer's name is all alphanumeric, then the
-default is computed by substituting the buffer name for the the name portion of
-@hid[Pathname Defaults].  Otherwise, the default is computed by calling
-@hid[Last Resort Pathname Defaults Function] with the buffer as an argument.
-
-The default value of @hid[Last Resort Pathname Defaults Function] merges 
-@hid[Last Resort Pathname Defaults] with @hid[Pathname Defaults].
-Unlike @hid[Pathname Defaults], @hid[Last Resort Pathname Defaults] is not
-modified by file commands, so setting it to a silly name ensures that real
-files aren't inappropriately offered as defaults.
-@enddefhvar
-
-When a default is present in the prompt for a file, @hemlock @i[merges] the
-given input with the default filename.  The semantics of merging, described in
-the Common Lisp manual, is somewhat involved, but @hemlock has a few rules it
-uses:
-@begin[enumerate]
-If @hemlock can find the user's input as a file on the @f["default:"] search
-list, then it forgoes merging with the displayed default.  Basically, the
-system favors the files in your current working directory over those found by
-merging with the defaults offered in the prompt.
-
-Merging comes in two flavors, just merge with the displayed default's directory
-or just merge with the displayed default's @f[file-namestring].  If the user
-only responds with a directory specification, without any name or type
-information, then @hemlock merges the default's @f[file-namestring].  If the
-user responds with any name or type information, then @hemlock only merges with
-the default's directory.  Specifying relative directories in this second
-situation coordinates with the displayed defaults, not the current working
-directory.
-@end[enumerate]
-
-
-@subsection[Type Hooks and File Options]
-@index[mode comment]
-@index[type hooks]
-When a file is read either by @hid[Find File] or @hid[Visit File], @hemlock
-attempts to guess the correct mode in which to put the buffer, based on the
-file's @i[type] (the part of the filename after the last dot).  Any default
-action may be overridden by specifying the mode in the file's @i[file
-options].@index[modes]@index[package]
-
-@label[file-options]@index[file options] 
-The user specifies file options with a special syntax on the first line of a
-file.  If the first line contains the string "@f[-*-]", then @hemlock
-interprets the text between the first such occurrence and the second, which
-must be contained in one line , as a list of @w{"@f<@i[option]: @i[value]>"}
-pairs separated by semicolons.  The following is a typical example:
-@begin[programexample]
-;;; -*- Mode: Lisp, Editor; Package: Hemlock -*-
-@end[programexample]
-
-These options are currently defined:
-@begin[description]
-Dictionary@\The argument is the filename of a spelling dictionary associated
-with this file.  The handler for this option merges the argument with the
-name of this file.  See @comref[Set Buffer Spelling Dictionary].
-
-Log@\The argument is the name of the change log file associated with this file
-(see page @pageref[log-files]).  The handler for this option merges the
-argument with the name of this file.
-
-Mode@\The argument is a comma-separated list of the names of modes to turn on
-in the buffer that the file is read into.
-
-Package@\The argument is the name of the package to be used for reading code in
-the file.  This is only meaningful for Lisp code (see page
-@pageref[lisp-package].)
-
-Editor@\The handler for this option ignores its argument and turns on
-@hid[Editor] mode (see @comref[Editor Mode]).
-
-@end[description]
-If the option list contains no "@f[:]" then the entire string is used as
-the name of the major mode for the buffer.
-
-@defcom[com "Process File Options"]
-This command processes the file options in the current buffer as described
-above.  This is useful when the options have been changed or when a file is
-created.
-@enddefcom
-
-
-@section[Windows]
-@index[windows]
-
-@hemlock windows display a portion of a buffer's text.  See the section on
-@i[window groups], @ref[groups], for a discussion of managing windows on bitmap
-device.
-
-@defcom[com "New Window", bind (C-x C-n)]
-This command prompts users for a new window which they can place anywhere on
-the screen.  This window is in its own group.  This only works with bitmap
-devices.
-@enddefcom
-
-@defcom[com "Split Window", bind (C-x 2)]
-This command splits the current window roughly in half to make two windows.  If
-the current window is too small to be split, the command signals a user error.
-@enddefcom
-
-@defcom[com "Next Window", bind (C-x n)]
-@defcom1[com "Previous Window", bind (C-x p)]
-These commands make the next or previous window the new current window, often
-changing the current buffer in the process.  When a window is created, it is
-arbitrarily made the next window of the current window.  The location of the
-next window is, in general, unrelated to that of the current window.
-@enddefcom
-
-@defcom[com "Delete Window", bind (C-x C-d, C-x d)]
-@defcom1[com "Delete Next Window", bind (C-x 1)]
-@hid[Delete Window] makes the current window go away, making the next window
-current.  @hid[Delete Next Window] deletes the next window, leaving the current
-window unaffected.
-
-On bitmap devices, if there is only one window in the group, either command
-deletes the group, making some window in another group the current window.  If
-there are no other groups, they signal a user error.
-@enddefcom
-
-@defcom[com "Go to One Window"]
-This command deletes all window groups leaving one with the @hid[Default
-Initial Window X], @hid[Default Initial Window Y], @hid[Default Initial Window
-Width], and @hid[Default Initial Window Height].  This remaining window
-retains the contents of the current window.
-@enddefcom
-
-@defcom[com "Line to Top of Window", bind (M-!)]
-@defcom1[com "Line to Center of Window", bind (M-#)]
-@index[scrolling]@hid[Line to Top of Window] scrolls the current window up
-until the current line is at the top of the screen.
-
-@hid[Line to Center of Window] attempts to scroll the current window so that
-the current line is vertically centered.
-@enddefcom
-
-@defcom[com "Scroll Next Window Down", bind (C-M-v)]
-@defcom1[com "Scroll Next Window Up", bind (C-M-V)]
-These commands are the same as @hid[Scroll Window Up] and
-@hid[Scroll Window Down] except that they operate on the next window.
-@enddefcom
-
-@defcom[com "Refresh Screen", bind {C-l}]
-This command refreshes all windows, which is useful if the screen got trashed,
-centering the current window about the current line.  When the user supplies a
-positive argument, it scrolls that line to the top of the window.  When the
-argument is negative, the line that far from the bottom of the window is moved
-to the bottom of the window.  In either case when an argument is supplied, this
-command only refreshes the current window.
-@enddefcom
-
-
-@chap[Editing Documents]
-@index[documents, editing]
-Although @hemlock is not dedicated to editing documents as word processing
-systems are, it provides a number of commands for this purpose.  If @hemlock is
-used in conjunction with a text-formatting program, then its lack of complex
-formatting commands is no liability.
-
-
-@defcom[com "Text Mode"]
-This commands puts the current buffer into "Text" mode.
-@enddefcom
-
-
-@section[Sentence Commands]
-@index[sentence commands]
-A sentence is defined as a sequence of characters ending with a period,
-question mark or exclamation point, followed by either two spaces or a newline.
-A sentence may also be terminated by the end of a paragraph.  Any number of
-closing delimiters, such as brackets or quotes, may be between the punctuation
-and the whitespace.  This somewhat complex definition of a sentence is used so
-that periods in abbreviations are not misinterpreted as sentence ends.
-
-@defcom[com "Forward Sentence", bind {M-a}]
-@defcom1[com "Backward Sentence", bind {M-e}]
-@index[motion, sentence]@hid[Forward Sentence] moves the point forward
-past the next sentence end. @hid[Backward Sentence] moves to the beginning
-of the current sentence. A prefix argument may be used as a repeat count.
-@enddefcom
-
-@defcom[com "Forward Kill Sentence", bind {M-k}]
-@defcom1[com "Backward Kill Sentence", bind (C-x Delete, C-x Backspace)]
-@index[killing, sentence]@hid[Forward Kill Sentence] kills text from the
-point through to the end of the current sentence.  @hid[Backward Kill Sentence]
-kills from the point to the beginning of the current sentence.  A
-prefix argument may be used as a repeat count.
-@enddefcom
-
-@defcom[com "Mark Sentence"]
-This command puts the point at the beginning and the mark at the end of the
-next or current sentence.
-@enddefcom
-
-
-@section[Paragraph Commands]
-
-@index[paragraph commands]A paragraph may be delimited by a blank line or a
-line beginning with "@f[']" or "@f[.]", in which case the delimiting line is
-not part of the paragraph.  Other characters may be paragraph delimiters in
-some modes.  A line with at least one leading whitespace character may also
-introduce a paragraph and is considered to be part of the paragraph.  Any
-fill-prefix which is present on a line is disregarded for the purpose of
-locating a paragraph boundary.
-
-@defcom[com "Forward Paragraph", bind (@bf<M-]>)]
-@defcom1[com "Backward Paragraph", bind (M-[)]
-@index[motion, paragraph]@index[paragraph, motion]@hid[Forward Paragraph]
-moves to the end of the current or next paragraph. @hid[Backward Paragraph]
-moves to the beginning of the current or previous paragraph.  A prefix
-argument may be used as a repeat count.
-@enddefcom
-
-@defcom[com "Mark Paragraph", bind {M-h}]
-This command puts the point at the beginning and the mark at the end of the
-current paragraph.
-@enddefcom
-
-@defhvar[var "Paragraph Delimiter Function", val {default-para-delim-function}]
-This variable holds a function that takes a mark as its argument and returns
-true when the line it points to should break the paragraph.
-@enddefhvar
-
-@section[Filling]
-
-@index[filling]@index[formatting]Filling is a coarse text-formatting
-process which attempts to make all the lines roughly the same length, but
-doesn't vary the amount of space between words.  Editing text may leave
-lines with all sorts of strange lengths; filling this text will return it
-to a moderately aesthetic form.
-
-@defcom[com "Set Fill Column", bind (C-x f)]
-This command sets the fill column to the column that the point is currently at,
-or the one specified by the absolute value of prefix argument, if it is
-supplied.  The fill column is the column past which no text is permitted to
-extend.
-@enddefcom
-
-@defcom[com "Set Fill Prefix", bind (C-x .)]
-This command sets the fill prefix to the text from the beginning of the
-current line to the point.  The fill-prefix is a string which filling commands
-leave at the beginning of every line filled.  This feature is useful for
-filling indented text or comments.
-@enddefcom
-
-@defhvar[var "Fill Column", val {75}]
-@defhvar1[var "Fill Prefix", val {nil}]
-These variables hold the value of the fill prefix and fill column, thus
-setting these variables will change the way filling is done.  If
-@hid[Fill Prefix] is @nil, then there is no fill prefix.
-@enddefcom
-
-@defcom[com "Fill Paragraph", bind {M-q}]
-@index[paragraph, filling]This command fills the text in the current or next
-paragraph.  The point is not moved.
-@enddefcom
-
-@defcom[com "Fill Region", bind {M-g}]
-@index[region, filling]This command fills the text in the region.  Since
-filling can mangle a large quantity of text, this command asks for confirmation
-before filling a large region (see @hid[Region Query Size].)
-@enddefcom
-
-
-@defcom[com "Auto Fill Mode"]
-@index[modes, auto fill]This command turns on or off the @hid[Fill]
-minor mode in the current buffer.  When in @hid[Fill] mode, @bf[Space],
-@bf[Return] and @bf[Linefeed] are rebound to commands that check whether
-the point is past the fill column and fill the current line if it is.
-This enables typing text without having to break the lines manually.
-
-If a prefix argument is supplied, then instead of toggling, the sign
-determines whether @hid[Fill] mode is turned off; a positive argument
-argument turns in on, and a negative one turns it off.
-@enddefcom
-
-@defcom[com "Auto Fill Linefeed", stuff (bound to @bf[Linefeed] in @hid[Fill] mode)]
-@defcom1[com "Auto Fill Return", stuff (bound to @bf[Return] in @hid[Fill] mode)]
-@hid[Auto Fill Linefeed] fills the current line if it needs it and then goes to
-a new line and inserts the fill prefix.  @hid[Auto Fill Return] is similar, but
-does not insert the fill prefix on the new line.
-@enddefcom
-
-@defcom[com "Auto Fill Space", stuff (bound to @bf[Space] in @hid[Fill] mode)]
-If no prefix argument is supplied, this command inserts a space and
-fills the current line if it extends past the fill column.  If the argument is
-zero, then it fills the line if needed, but does not insert a space.  If the
-argument is positive, then that many spaces are inserted without filling.
-@enddefcom
-
-@defhvar[var "Auto Fill Space Indent", val {nil}]
-This variable determines how lines are broken by the auto fill commands.  If it
-is true, new lines are created using the @hid[Indent New Comment Line] command,
-otherwise the @hid[New Line] command is used.  Language modes should define
-this variable to be true so that auto fill mode can be used on code.
-@enddefhvar
-
-
-@section[Scribe Mode]
-
-@hid[Scribe] mode provides a number of facilities useful for editing Scribe
-documents.  It is also sufficiently parameterizable to be adapted to other
-similar syntaxes.
-
-@defcom[com "Scribe Mode"]
-@index[modes, scribe]This command puts the current buffer in @hid[Scribe] mode.
-Except for special Scribe commands, the only difference between @hid[Scribe]
-mode and @hid[Text] mode is that the rules for determining paragraph breaks are
-different.  In @hid[Scribe] mode, paragraphs delimited by Scribe commands are
-normally placed on their own line, in addition to the normal paragraph breaks.
-The main reason for doing this is that it prevents @hid[Fill Paragraph] from
-mashing these commands into the body of a paragraph.
-@enddefcom
-
-@defcom[com "Insert Scribe Directive", stuff (@bf[C-h] in @hid[Scribe] mode)]
-This command prompts for a key-event to determine which Scribe directive to
-insert.  Directives are inserted differently depending on their kind:
-@begin[description]
-@i[environment]@\
-The current or next paragraph is enclosed in a begin-end pair:
-@f<@@begin[@i{directive}]> @i[paragraph] @f<@@end[@i{directive}]>.  If the
-current region is active, then this command encloses the region instead of the
-paragraph it would otherwise chose.
-
-@i[command]@\
-The previous word is enclosed by @f<@@@i[directive][@i[word]]>.  If the
-previous word is already enclosed by a use of the same command, then the
-beginning of the command is extended backward by one word.
-@end[description]
-
-Typing @bf[Home] or @bf[C-_] to this command's prompt will display a list of
-all the defined key-events on which it dispatches.
-@enddefcom
-
-@defcom[com "Add Scribe Directive"]
-This command adds to the database of directives recognized by the 
-@hid[Insert Scribe Directive] command.  It prompts for the directive's name,
-the kind of directive (environment or command) and the key-event on which to
-dispatch.
-@enddefcom
-
-@defcom[com "Add Scribe Paragraph Delimiter"]
-@defcom1[com "List Scribe Paragraph Delimiters"]
-@hid[Add Scribe Paragraph Delimiter] prompts for a string to add to the list of
-formatting commands that delimit paragraphs in @hid[Scribe] mode.  If the user
-supplies a prefix argument, then this command removes the string as a
-delimiter.
-
-@hid[List Scribe Paragraph Delimiters] displays in a pop-up window the Scribe
-commands that delimit paragraphs.
-@enddefcom
-
-@defhvar[var "Escape Character", val {#\@@}]
-@defhvar1[var "Close Paren Character", val {#\]}]
-@defhvar1[var "Open Paren Character", val {#\[}]
-These variables determine the characters used when a Scribe directive is
-inserted.
-@enddefhvar
-
-@defcom[com "Scribe Insert Bracket"]
-@defhvar1[var "Scribe Bracket Table"]
-@hid[Scribe Insert Bracket] inserts a bracket (@bf[>], @bf[}], @bf[)], or
-@bf<]>), that caused its invocation, and then shows the matching bracket.
-
-@hid[Scribe Bracket Table] holds a @f[simple-vector] indexed by character
-codes.  If a character is a bracket, then the entry for its @f[char-code]
-should be the opposite bracket.  If a character is not a bracket, then the
-entry should be @nil.
-@enddefcom
-
-
-@section[Spelling Correction]
-@index[spelling correction]
-@hemlock has a spelling correction facility based on the dictionary for the ITS
-spell program.  This dictionary is fairly small, having only 45,000 word or so,
-which means it fits on your disk, but it also means that many reasonably common
-words are not in the dictionary.  A correct spelling for a misspelled word will
-be found if the word is in the dictionary and is only erroneous in that it has
-a wrong character, a missing character, an extra character or a transposition
-of two characters.
-
-
-@defcom[com "Check Word Spelling", bind (M-$)]
-This command looks up the previous or current word in the dictionary and
-attempts to correct the spelling if it is misspelled.  There are four possible
-results of invoking this command:
-@begin[enumerate]
-This command displays the message "@f[Found it.]" in the echo area.  This means
-it found the word in the dictionary exactly as given.
-
-This command displays the message "@f[Found it because of @i[word].]", where
-@i[word] is some other word with the same root but a different ending.  The
-word is no less correct than if the first message is given, but an additional
-piece of useless information is supplied to make you feel like you are using a
-computer.
-
-The command prompts with "@f[Correction choice:]" in the echo area and lists
-possible correct spellings associated with numbers in a pop-up display.  Typing
-a number selects the corresponding correction, and the command replaces the
-erroneous word, preserving case as though by @hid[Query Replace].  Typing
-anything else rejects all the choices.
-
-This commands displays the message "@f[Word not found.]".  The word is not in
-the dictionary and possibly spelled correctly anyway.  Furthermore, no
-similarly spelled words were found to offer as possible corrections.  If this
-happens, it is worth trying some alternate spellings since one of them might
-be close enough to some known words that this command could display.
-@end[enumerate]
-@enddefcom
-
-@defcom[com "Correct Buffer Spelling"]
-This command scans the entire buffer looking for misspelled words and offers to
-correct them.  It creates a window into the @hid[Spell Corrections] buffer, and
-in this buffer it maintains a log of any actions taken by the user.  When this
-finds an unknown word, it prompts for a key-event.  The user has the following
-options:
-@begin[description]
-@bf[a]@\
- Ignore this word.  If the command finds the word again, it will prompt again.
-
-@bf[i]@\
- Insert this word in the dictionary.
-
-@bf[c]@\
- Choose one of the corrections displayed in the @hid[Spell Corrections] window
-by specifying the correction number.  If the same misspelling is encountered
-again, then the command will make the same correction automatically, leaving a
-note in the log window.
-
-@bf[r]@\
- Prompt for a word to use instead of the misspelled one, remembering the
-correction as with @bf[c].
-
-@binding[C-r]@\
- Go into a recursive edit at the current position, and resume checking when the
-recursive edit is exited.
-@end[description]
-After this command completes, it deletes the log window leaving the buffer
-around for future reference.
-@enddefcom
-
-@defhvar[var "Spell Ignore Uppercase", val {nil}]
-@index[case sensitivity]
-If this variable is true, then @hid[Auto Check Word Spelling] and @hid[Correct
-Buffer Spelling] will ignore unknown words that are all uppercase.  This is
-useful for acronyms and cryptic formatter directives.
-@enddefhvar
-
-@defcom[com "Add Word to Spelling Dictionary", bind (C-x $)]
-This command adds the previous or current word to the spelling dictionary.
-@enddefcom
-
-@defcom[com "Remove Word from Spelling Dictionary"]
-This command prompts for a word to remove from the spelling dictionary.  Due to
-the dictionary representation, removal of a word in the initial spelling
-dictionary will remove all words with the same root.  The user is asked for
-confirmation before removing a root word with valid suffix flags.
-@enddefcom
-
-@defcom[com "List Incremental Spelling Insertions"]
-This command displays the incremental spelling insertions for the current
-buffer's associated spelling dictionary file.
-@enddefcom
-
-@defcom[com "Read Spelling Dictionary"]
-This command adds some words from a file to the spelling dictionary.  The
-format of the file is a list of words, one on each line.
-@enddefcom
-
-@defcom[com "Save Incremental Spelling Insertions"]
-This command appends incremental dictionary insertions to a file.  Any words
-added to the dictionary since the last time this was done will be appended to
-the file.  Except for @hid[Augment Spelling Dictionary], all the commands that
-add words to the dictionary put their insertions in this list.  The file is
-prompted for unless @hid[Set Buffer Spelling Dictionary] has been executed in
-the buffer.
-@enddefcom
-
-@defcom[com "Set Buffer Spelling Dictionary"]
-This command Prompts for the dictionary file to associate with the current
-buffer.  If the specified dictionary file has not been read for any other
-buffer, then it is read.  Incremental spelling insertions from this buffer
-can be appended to this file with @hid[Save Incremental Spelling
-Insertions].  If a buffer has an associated spelling dictionary, then
-saving the buffer's associated file also saves any incremental dictionary
-insertions.  The @w<"@f[Dictionary: ]@i[file]"> file option may also be
-used to specify the dictionary for a buffer (see section
-@ref[file-options]).
-@enddefcom
-
-@defhvar[var "Default User Spelling Dictionary", val {nil}]
-This variable holds the pathname of a dictionary to read the first time
-@hid[Spell] mode is entered in a given editing session.  When
-@hid[Set Buffer Spelling Dictionary] or the "@f[dictionary]" file option is
-used to specify a dictionary, this default one is read also.  It defaults to
-nil.
-@enddefhvar
-
-
-@subsection[Auto Spell Mode]
-@hid[Auto Spell Mode] checks the spelling of each word as it is typed.
-When an unknown word is typed the user is notified and allowed to take a
-number of actions to correct the word.
-
-@defcom[com "Auto Spell Mode"]
-This command turns @hid[Spell] mode on or off in the current buffer.
-@enddefcom
-
-@defcom[com "Auto Check Word Spelling",
-	stuff (bound to word delimiters in @hid[Spell] mode)]
-@defhvar1[var "Check Word Spelling Beep", val {t}]
-@defhvar1[var "Correct Unique Spelling Immediately", val {t}]
-This command checks the spelling of the word before the point, doing nothing if
-the word is in the dictionary.  If the word is misspelled but has a known
-correction previously supplied by the user, then this command corrects the
-spelling.  If there is no correction, then this displays a message in the echo
-area indicating the word is unknown.  An unknown word detected by this command
-may be corrected using the @hid[Correct Last Misspelled Word] command.  This
-command executes in addition to others bound to the same key; for example, if
-@hid[Fill] mode is on, any of its commands bound to the same keys as this
-command also run.
-
-If @hid[Check Word Spelling Beep] is true, then this command will beep when an
-unknown word is found.  If @hid[Correct Unique Spelling Immediately] is true,
-then this command will immediately attempt to correct any unknown word,
-automatically making the correction if there is only one possible.
-@enddefhvar
-
-@defcom[com "Undo Last Spelling Correction", bind (C-x a)]
-@defhvar1[var "Spelling Un-Correct Prompt for Insert", val {nil}]
-@hid[Undo Last Spelling Correction] undoes the last incremental spelling
-correction.  The "correction" is replaced with the old word, and the old word
-is inserted in the dictionary.  Any automatic replacement for the old word is
-eliminated.  When @hid[Spelling Un-Correct Prompt for Insert] is true, the user
-is asked to confirm the insertion into the dictionary.
-@enddefcom
-
-@defcom[com "Correct Last Misspelled Word", bind (M-:)]
-This command places the cursor after the last misspelled word detected by the
-@hid[Auto Check Word Spelling] command and then prompts for a key-event on
-which it dispatches:
-@begin[description]
-@bf[c]@\
- Display possible corrections in a pop-up window, and prompt for the one to
-make according to the corresponding displayed digit or letter.
-
-@i[any digit]@\
- Similar to @bf[c] @i[digit], but immediately makes the correction, dispensing
-with display of the possible corrections.  This is shorter, but only works when
-there are less than ten corrections.
-
-@bf[i]@\
- Insert the word in the dictionary.
-
-@bf[r]@\
- Replace the word with another.
-
-@binding[Backspace, Delete, n]@\
- Skip this word and try again on the next most recently misspelled word.
-
-@binding[C-r]@\
- Enter a recursive edit at the word, exiting the command when the recursive
-edit is exited.
-
-@binding[Escape]@\
- Exit and forget about this word.
-@end[description]
-As in @hid[Correct Buffer Spelling], the @bf[c] and @bf[r] commands add the
-correction to the known corrections.
-@enddefcom
-
-
-
-@chap[Managing Large Systems]
-
-@hemlock provides three tools which help to manage large systems:
-@begin[enumerate]
-File groups, which provide several commands that operate on all the files
-in a possibly large collection, instead of merely on a single buffer.
-
-A source comparison facility with semi-automatic merging, which can be used
-to compare and merge divergent versions of a source file.
-
-A change log facility, which maintains a single file containing a record of the
-edits done on a system.
-@end[enumerate]
-
-
-@section[File Groups]
-
-@index[file groups]@index[searching, group]@index[replacing, group]
-A file group is a set of files, upon which various editing operations can be
-performed.  The files in a group are specified by a file in the following
-format:
-@begin[itemize]
-Any line which begins with one "@f[@@]" is ignored.
-
-Any line which does not begin with an "@f[@@]" is the name of a file in the
-group.
-
-A line which begins with "@f[@@@@]" specifies another file having this
-syntax, which is recursively examined to find more files in the group.
-@end[itemize]
-This syntax is used for historical reasons.  Although any number of file groups
-may be read into @hemlock, there is only one @i[active group], which is the
-file group implicitly used by all of the file group commands.  
-Page @pageref[compile-group-command] describes the @hid[Compile Group] command.
-
-@defcom[com "Select Group"]
-This command prompts for the name of a file group to make the active group.
-If the name entered is not the name of a group whose definition has been
-read, then the user is prompted for the name of a file to read the group
-definition from.  The name of the default pathname is the name of the
-group, and the type is "@f[upd]".
-@enddefcom
-
-@defcom[com "Group Query Replace"]
-This command prompts for target and replacement strings and then executes an
-interactive string replace on each file in the active group.  This reads in
-each file as if @hid[Find File] were used and processes it as if @hid[Query
-Replace] were executing.
-@enddefcom
-
-@defcom[com "Group Replace"]
-This is like @hid[Group Query Replace] except that it executes a
-non-interactive replacement, similar to @hid[Replace String].
-@enddefcom
-
-@defcom[com "Group Search"]
-This command prompts for a string and then searches for it in each file in the
-active group.  This reads in each file as if @hid[Find File] were used.  When
-it finds an occurrence, it prompts the user for a key-event indicating what
-action to take.  The following commands are defined:
-@begin[description]
-@binding[Escape, Space, y]@\
- Exit @hid[Group Search].
-
-@binding[Delete, Backspace, n]@\
- Continue searching for the next occurrence of the string.
-
-@binding[!]@\
- Continue the search at the beginning of the next file, skipping the remainder
-of the current file.
-
-@binding[C-r]@\
- Go into a recursive edit at the current location, and continue the search when
-it is exited.
-@end[description]
-@enddefcom
-
-@defhvar[var "Group Find File", val {nil}]
-The group searching and replacing commands read each file into its own buffer
-using @hid[Find File].  Since this may result in large amounts of memory being
-consumed by unwanted buffers, this variable controls whether to delete the
-buffer after processing it.  When this variable is false, the default, the
-commands delete the buffer if it did not previously exist; however, regardless
-of this variable, if the user leaves the buffer modified, the commands will not
-delete it.
-@enddefhvar
-
-@defhvar[var "Group Save File Confirm", val {t}]
-If this variable is true, the group searching and replacing commands ask for
-confirmation before saving any modified file.  The commands attempt to save
-each file processed before going on to the next one in the group.
-@enddefhvar
-
-
-@section[Source Comparison]
-@index[buffer, merging]
-@index[buffer, comparison]
-@index[source comparison]
-
-These commands can be used to find exactly how the text in two buffers differs,
-and to generate a new version that combines features of both versions.
-
-@defhvar[var "Source Compare Default Destination", val {"Differences"}]
-This is a sticky default buffer name to offer when comparison commands prompt
-for a buffer in which to insert the results.
-@enddefhvar
-
-@defcom[com "Compare Buffers"]
-This command prompts for three buffers and then does a buffer comparison.
-The first two buffers must exist, as they are the buffers to be compared.
-The last buffer, which is created if it does not exist, is the buffer to
-which output is directed.  The output buffer is selected during the
-comparison so that its progress can be monitored.  There are various variables
-that control exactly how the comparison is done.
-
-If a prefix argument is specified, then only only the lines in the the regions
-of the two buffers are compared.
-@enddefcom
-
-@defcom[com "Buffer Changes"]
-This command compares the contents of the current buffer with the disk version
-of the associated file.  It reads the file into the buffer 
-@hid[Buffer Changes File], and generates the comparison in the buffer
-@hid[Buffer Changes Result].  As with @hid[Compare Buffers], the output buffer
-is displayed in the current window.
-@enddefcom
-
-@defcom[com "Merge Buffers"]
-This command functions in a very similar fashion to @hid[Compare Buffers], the
-difference being that a version which is a combination of the two buffers being
-compared is generated in the output buffer.  This copies text that is identical
-in the two comparison buffers to the output buffer.  When it encounters a
-difference, it displays the two differing sections in the output buffer and
-prompts the user for a key-event indicating what action to take.  The following
-commands are defined:
-@begin[description]
-@bf[1]@\
- Use the first version of the text.
-
-@bf[2]@\
- Use the second version.
-
-@bf[b]@\
- Insert the string @w<"@f[**** MERGE LOSSAGE ****]"> followed by both versions.
-This is useful if the differing sections are too complex, or it is unclear
-which is the correct version.  If you cannot make the decision conveniently at
-this point, you can later search for the marking string above.
-
-@binding[C-r]@\
- Do a recursive edit and ask again when the edit is exited.
-@end[description]
-@enddefcom
-
-
-@defhvar[var "Source Compare Ignore Case", val {nil}]
-@index[case sensitivity]
-If this variable is non-@nil, @hid[Compare Buffers] and @hid[Merge Buffers]
-will do comparisons case-insensitively.
-@enddefhvar
-
-@defhvar[var "Source Compare Ignore Indentation", val {nil}] 
-If this variable is non-@nil, @hid[Compare Buffers] and @hid[Merge Buffers]
-ignore initial whitespace when comparing lines.
-@enddefhvar
-
-@defhvar[var "Source Compare Ignore Extra Newlines", val {t}]
-If this variable is true, @hid[Compare Buffers] and @hid[Merge Buffers]
-will treat all groups of newlines as if they were a single newline.
-@enddefhvar
-
-@defhvar[var "Source Compare Number of Lines", val {3}]
-This variable controls the number of lines @hid[Compare Buffers] and
-@hid[Merge Buffers] will compare when resynchronizing after a difference
-has been encountered.
-@enddefhvar
-
-
-@section[Change Logs]
-@label[log-files]
-@index[edit history]
-@index[change log]
-
-The @hemlock change log facility encourages the recording of changes to a
-system by making it easy to do so.  The change log is kept in a separate file
-so that it doesn't clutter up the source code.  The name of the log for a file
-is specified by the @f[Log] file option (see page @pageref[file-options].)
-
-@defcom[com "Log Change"]
-@defhvar1[var "Log Entry Template"]
-@hid[Log Change] makes a new entry in the change log associated with the file.
-Any changes in the current buffer are saved, and the associated log file is
-read into its own buffer.  The name of the log file is determined by merging
-the name specified in the @f[Log] option with the current buffer's file name,
-so it is not usually necessary to put the full name there.  After inserting a
-template for the log entry at the beginning of the buffer, the command enters a
-recursive edit (see page @pageref[recursive-edits]) so that the text of the
-entry may be filled in.  When the user exits the recursive edit, the log file
-is saved.
-
-The variable @hid[Log Entry Template] determines the format of the change log
-entry.  Its value is a @clisp @f[format] control string.  The format string is
-passed three string arguments: the full name of the file, the creation date for
-the file and the name of the file author.  If the creation date is not
-available, the current date is used.  If the author is not available then @nil
-is passed.  If there is an @f[@@] in the template, then it is deleted and the
-point is left at that position.
-@enddefcom
-
-
-
-@comment[@chap (Special Modes)]
-@include(special-modes)
-
-
-
-@chap[Editing Programs]
-
-
-@section[Comment Manipulation]
-@index[comment manipulation]
-@hemlock has commenting commands which can be used in almost any language.  The
-behavior of these commands is determined by several @hemlock variables which
-language modes should define appropriately.
-
-@defcom[com "Indent for Comment", bind (M-;)]
-@index[indentation, comment]@label[comment-indentation]
-This is the most basic commenting command.  If there is already a comment on
-the current line, then this moves the point to the start of the comment.  If
-there no comment, this creates an empty one.
-
-This command normally indents the comment to start at @hid[Comment Column].
-The comment indents differently in the following cases:
-@begin[enumerate]
-If the comment currently starts at the beginning of the line, or if the last
-character in the @hid[Comment Start] appears three times, then the comment
-remains unmoved.
-
-If the last character in the @hid[Comment Start] appears two times, then the
-comment is indented like a line of code.
-
-If text on the line prevents the comment occurring in the desired position,
-this places the comment at the end of the line, separated from the text by a
-space.
-@end[enumerate]
-Although the rules about replication in the comment start are oriented toward
-Lisp commenting styles, you can exploit these properties in other languages.
-
-When given a prefix argument, this command indents any existing comment on that
-many consecutive lines.  This is useful for fixing up the indentation of a
-group of comments.
-@enddefcom
-
-@defcom[com "Indent New Comment Line", bind {M-j, M-Linefeed}]
-This commend ends the current comment and starts a new comment on a blank line,
-indenting the comment the same way that @hid[Indent for Comment] does.
-When not in a comment, this command is the same as @hid[Indent New Line].
-@enddefcom
-
-@defcom[com "Up Comment Line", bind {M-p}]
-@defcom1[com "Down Comment Line", bind {M-n}]
-These commands are similar to @hid[Previous Line] or @hid[Next Line]
-followed by @hid[Indent for Comment].  Any empty comment on the current line is
-deleted before moving to the new line.
-@enddefcom
-
-@defcom[com "Kill Comment", bind (C-M-;)]
-This command kills any comment on the current line.  When given a prefix
-argument, it kills comments on that many consecutive lines.  @hid[Undo] will
-restore the unmodified text.
-@enddefcom
-
-@defcom[com "Set Comment Column", bind (C-x ;)]
-This command sets the comment column to its prefix argument.  If used without a
-prefix argument, it sets the comment column to the column the point is at.
-@enddefcom
-
-@defhvar[var "Comment Start", val {nil}]
-@defhvar1[var "Comment End", val {nil}]
-@defhvar1[var "Comment Begin", val {nil}]
-@defhvar1[var "Comment Column", val {0}]
-These variables determine the behavior of the comment commands.
-@begin[description]
-@hid[Comment Start]@\The string which indicates the start of a comment.  If
-this is @nil, then there is no defined comment syntax.
-
-@hid[Comment End]@\The string which ends a comment.  If this is @nil, then
-the comment is terminated by the end of the line.
-
-@hid[Comment Begin]@\The string inserted to begin a new comment.
-
-@hid[Comment Column]@\The column that normal comments start at.
-@end[description]
-@enddefcom
-
-
-@section[Indentation]
-@label[indentation]
-@index[indentation]
-Nearly all programming languages have conventions for indentation or leading
-whitespace at the beginning of lines.  The @hemlock indentation facility is
-integrated into the command set so that it interacts well with other features
-such as filling and commenting.
-
-@defcom[com "Indent", bind (Tab, C-i)]
-This command indents the current line.  With a prefix argument, indents that
-many lines and moves down.  Exactly what constitutes indentation depends on the
-current mode (see @hid[Indent Function]).
-@enddefcom
-
-@defcom[com "Indent New Line", bind (Linefeed)]
-This command starts a new indented line.  Deletes any whitespace before the
-point and inserts indentation on a blank line.  The effect of this is similar
-to @binding[Return] followed by @binding[Tab].  The prefix argument is passed
-to @hid[New Line], which is used to insert the blank line.
-@enddefcom
-
-@defcom[com "Indent Region", bind (C-M-\)]
-This command indents every line in the region.  It may be undone with
-@hid[Undo].
-@enddefcom
-
-@defcom[com "Back to Indentation", bind {M-m, C-M-m}]
-@index[motion, indentation]
-This command moves point to the first non-whitespace character on the current
-line.
-@enddefcom
-
-@defcom[com "Delete Indentation", bind (M-^, C-M-^)]
-@hid[Delete Indentation] joins the current line with the previous one, deleting
-excess whitespace.  This operation is the inverse of the @bf[Linefeed] command
-in most modes.  Usually this leaves one space between the two joined lines, but
-there are several exceptions.
-
-The non-whitespace immediately surrounding the deleted line break determine the
-amount of space inserted.
-@begin[enumerate]
-If the preceding character is an "@f[(]" or the following character is a
-"@f[)]", then this inserts no space.
-
-If the preceding character is a newline, then this inserts no space.  This will
-happen if the previous line was blank.
-
-If the preceding character is a sentence terminator, then this inserts two
-spaces.
-@end[enumerate]
-
-When given a prefix argument, this command joins the current and next lines,
-rather than the previous and current lines.
-@enddefcom
-
-@defcom[com "Quote Tab", bind (M-Tab)]
-This command inserts a tab character.
-@enddefcom
-
-@defcom[com "Indent Rigidly", bind (C-x Tab, C-x C-i)]
-This command changes the indentation of all the lines in the region.  Each
-line is moved to the right by the number of spaces specified by the prefix
-argument, which defaults to eight.  A negative prefix argument moves lines
-left.
-@enddefcom
-
-@defcom[com "Center Line"]
-This indents the current line so that it is centered between the left margin
-and @hvarref[Fill Column].  If a prefix argument is supplied, then it is used
-as the width instead of @hid[Fill Column].
-@enddefcom
-
-@defhvar[var "Indent Function", val {tab-to-tab-stop}]
-The value of this variable determines how indentation is done, and it is a
-function which is passed a mark as its argument.  The function should indent
-the line which the mark points to.  The function may move the mark around on
-the line.  The mark will be @f[:left-inserting].  The default simply inserts a
-tab character at the mark.
-@enddefhvar
-
-@defhvar[var "Indent with Tabs", val {indent-using-tabs}]
-@defhvar1[var "Spaces per Tab", val {8}]
-@hid[Indent with Tabs] holds a function that takes a mark and a number of
-spaces.  The function will insert a maximum number of tabs and a minimum number
-of spaces at mark to move the specified number of columns.  The default
-definition uses @hid[Spaces per Tab] to determine the size of a tab.  @i[Note,]
-@hid[Spaces per Tab] @i[is not used everywhere in @hemlock yet, so changing
-this variable could have unexpected results.]
-@enddefhvar
-
-
-@section[Language Modes]
-
-@hemlock@comment{}'s language modes are currently fairly crude, but probably
-provide better programming support than most non-extensible editors.
-
-@defcom[com "Pascal Mode"]
-@index[indentation, pascal]@index[modes, pascal]This command sets the current
-buffer's major mode to @hid[Pascal].  @hid[Pascal] mode borrows parenthesis
-matching from Scribe mode and indents lines under the previous line.
-@enddefcom
-
-
-@chap[Editing Lisp]
-@index[lisp, editing]
-@hemlock provides a large number of powerful commands for editing Lisp code.
-It is possible for a text editor to provide a much higher level of support for
-editing Lisp than ordinary programming languages, since its syntax is much
-simpler.
-
-
-@section[Lisp Mode]
-@index[lisp mode]
-@index[modes, lisp]
-@hid[Lisp] mode is a major mode used for editing Lisp code.  Although most
-Lisp specific commands are globally bound, @hid[Lisp] mode is necessary to
-enable Lisp indentation, commenting, and parenthesis-matching.  Whenever the
-user or some @hemlock mechanism turns on @hid[Lisp] mode, the mode's setup
-includes locally setting @hid[Current Package] (see section @ref[lisp-package])
-in that buffer if its value is non-existent there; the value used is
-@f["USER"].
-
-@defcom[com "Lisp Mode"]
-This command sets the major mode of the current buffer to @hid[Lisp].
-@enddefcom
-
-
-@section[Form Manipulation]
-@index[form manipulation]
-These commands manipulate Lisp forms, the printed representations of Lisp
-objects.  A form is either an expression balanced with respect to parentheses
-or an atom such as a symbol or string.
-
-@defcom[com "Forward Form", bind (C-M-f)]
-@defcom1[com "Backward Form", bind (C-M-b)]
-@index[motion, form]@hid[Forward Form] moves to the end of the current or
-next form, while @hid[Backward Form] moves to the beginning of the current
-or previous form.  A prefix argument is treated as a repeat count.
-@enddefcom
-
-@defcom[com "Forward Kill Form", bind (C-M-k)]
-@defcom1[com "Backward Kill Form", bind (C-M-Delete, C-M-Backspace)]
-@index[killing, form]@hid[Forward Kill Form] kills text from the point to
-the end of the current form.  If at the end of a list, but inside the close
-parenthesis, then kill the close parenthesis.  @hid[Backward Kill Form] is
-the same, except it goes in the other direction.  A prefix argument is
-treated as a repeat count.
-@enddefcom
-
-@defcom[com "Mark Form", bind (C-M-@@)]
-This command sets the mark at the end of the current or next form.
-@enddefcom
-
-@defcom[com "Transpose Forms", bind (C-M-t)]
-This command transposes the forms before and after the point and moves
-forward.  A prefix argument is treated as a repeat count.  If the prefix
-argument is negative, then the point is moved backward after the
-transposition is done, reversing the effect of the equivalent positive
-argument.
-@enddefcom
-
-@defcom[com "Insert ()", bind {M-(}]
-This command inserts an open and a close parenthesis, leaving the point
-inside the open parenthesis.  If a prefix argument is supplied, then the
-close parenthesis is put at the end of the form that many forms from the
-point.
-@enddefcom
-
-@defcom[com "Extract Form"]
-This command replaces the current containing list with the next form.  The
-entire affected area is pushed onto the kill ring.  If an argument is supplied,
-that many upward levels of list nesting is replaced by the next form.  This is
-similar to @hid[Extract List], but this command is more generally useful since
-it works on any kind of form; it is also more intuitive since it operates on
-the next form as many @hid[Lisp] mode commands do.
-@enddefcom
-
-
-@section[List Manipulation]
-
-@index[list manipulation]List commands are similar to form commands, but
-they only pay attention to lists, ignoring any atomic objects that may
-appear.  These commands are useful because they can skip over many symbols
-and move up and down in the list structure.
-
-@defcom[com "Forward List", bind (C-M-n)]
-@defcom1[com "Backward List", bind (C-M-p)]
-@index[motion, list]@hid[Forward List] moves the point to immediately
-after the end of the next list at the current level of list structure.  If
-there is not another list at the current level, then it moves up past
-the end of the containing list.
-@hid[Backward List] is identical, except that it moves backward and leaves
-the point at the beginning of the list.  The prefix argument is used as a
-repeat count.
-@enddefcom
-
-@defcom[com "Forward Up List", bind {C-M-@bf<)>}]
-@defcom1[com "Backward Up List", bind (C-M-@bf<(>, C-M-u)]
-@hid[Forward Up List] moves to after the end of the enclosing list.
-@hid[Backward Up List] moves to the beginning.  The prefix argument is used
-as a repeat count.
-@enddefcom
-
-@defcom[com "Down List", bind (C-M-d)]
-This command moves to just after the beginning of the next list.  The
-prefix argument is used as a repeat count.
-@enddefcom
-
-@defcom[com "Extract List", bind (C-M-x)]
-This command "extracts" the current list from the list which contains it.
-The outer list is deleted, leaving behind the current list.  The entire
-affected area is pushed on the kill ring, so that this possibly catastrophic
-operation can be undone.  The prefix argument is used as a repeat count.
-@enddefcom
-
-
-
-@section[Defun Manipulation]
-
-@index[defun manipulation]A @i[defun] is a list whose open parenthesis is
-against the left margin.  It is called this because an occurrence of the
-@f[defun] top level form usually satisfies this definition, but
-other top level forms such as a @f[defstruct] and @f[defmacro] work just as
-well.
-
-@defcom[com "End of Defun", bind (@bf<C-M-e, C-M-]>)]
-@defcom1[com "Beginning of Defun", bind (C-M-a, C-M-[)]
-@index[motion, defun]@hid[End of Defun] moves to the end of the current
-or next defun. @hid[Beginning of Defun] moves to the beginning of the
-current or previous defun.  @hid[End of Defun] will not work if the
-parentheses are not balanced.
-@enddefcom
-
-@defcom[com "Mark Defun", bind (C-M-h)]
-This command puts the point at the beginning and the mark at the end of the
-current or next defun.
-@enddefcom
-
-
-
-@section[Indentation]
-
-@index[indentation, lisp]
-One of the most important features provided by @hid[Lisp] mode is automatic
-indentation of Lisp code.  Since unindented Lisp is unreadable, poorly indented
-Lisp is hard to manage, and inconsistently indented Lisp is subtly misleading.
-See section @ref[indentation] for a description of the general-purpose
-indentation commands.  @hid[Lisp] mode uses these indentation rules:
-@begin[itemize]
-If in a semicolon (@f[;]) comment, then use the standard comment indentation
-rules.  See page @pageref[comment-indentation].
-
-If in a quoted string, then indent to the column one greater than the column
-containing the opening double quote.  This is exactly what you want in function
-documentation strings and wrapping @f[error] strings.
-
-If there is no enclosing list, then use no indentation.
-
-If enclosing list resembles a call to a known macro or special-form, then the
-first few arguments are given greater indentation and the first body form is
-indented two spaces.  If the first special argument is on the same line as the
-beginning of the form, then following special arguments will be indented to the
-start of the first special argument, otherwise all special arguments are
-indented four spaces.
-
-If the previous form starts on its own line, then the indentation is copied
-from that form.  This rule allows the default indentation to be overridden:
-once a form has been manually indented to the user's satisfaction, subsequent
-forms will be indented in the same way.
-
-If the enclosing list has some arguments on the same line as the form start,
-then subsequent arguments will be indented to the start of the first argument.
-
-If the enclosing list has no argument on the same line as the form start, then
-arguments will be indented one space.
-@end[itemize]
-
-
-@defcom[com "Indent Form", bind (C-M-q)]
-This command indents all the lines in the current form, leaving the point
-unmoved.  This is undo-able.
-@enddefcom
-
-@defcom[com "Fill Lisp Comment Paragraph",
-	stuff <bound to @bf[M-q] in @hid[Lisp] mode>]
-@defhvar1[var "Fill Lisp Comment Paragraph Confirm", val {t}]
-This fills a flushleft or indented Lisp comment.  This also fills Lisp string
-literals using the proper indentation as a filling prefix.  When invoked
-outside of a comment or string, this tries to fill all contiguous lines
-beginning with the same initial, non-empty blankspace.  When filling a comment,
-the current line is used to determine a fill prefix by taking all the initial
-whitespace on the line, the semicolons, and any whitespace following the
-semicolons.
-
-When invoked outside of a comment or string, this command prompts for
-confirmation before filling.  It is useful to use this for filling long
-@f[export] lists or other indented text or symbols, but since this is a less
-common use, this command tries to make sure that is what you wanted.  Setting
-@hid[Fill Lisp Comment Paragraph Confirm] to @nil inhibits the confirmation
-prompt.
-@enddefcom
-
-@defcom[com "Defindent", bind (C-M-#)]
-This command prompts for the number of special arguments to associate with
-the symbol at the beginning of the current or containing list.
-@enddefcom
-
-@defhvar[var "Indent Defanything", val {2}]
-This is the number of special arguments implicitly assumed to be supplied in
-calls to functions whose names begin with "@f[def]".  If set to @nil, this
-feature is disabled.
-@enddefhvar
-
-@defcom[com "Move Over )", bind {M-)}]
-This command moves past the next close parenthesis and then does the equivalent
-of @hid[Indent New Line].
-@enddefcom       
-
-
-@section[Parenthesis Matching]
-
-@index[parenthesis matching]Another very important facility provided by
-@hid[Lisp] mode is @i[parenthesis matching].  Two different styles of
-parenthesis matching are supported: highlighting and pausing.
-
-@defhvar[var "Highlight Open Parens", val {t}]
-@defhvar1[var "Open Paren Highlighting Font", val {nil}]
-When @hid[Highlight Open Parens] is true, and a close paren is immediately
-before the point, then @hemlock displays the matching open paren in @hid[Open
-Paren Highlighting Font].
-
-@hid[Open Paren Highlighting Font] is the string name of the font used for
-paren highlighting.  Only the "@f[(]" character is used in this font.  If null,
-then a reasonable default is chosen.  The highlighting font is read at
-initialization time, so this variable must be set before the editor is first
-entered to have any effect.
-@enddefhvar
-
-@defcom[com "Lisp Insert )", stuff <bound to @bf[)] in @hid[Lisp] mode>]
-@defhvar1[var "Paren Pause Period", val {0.5}]
-This command inserts a close parenthesis and then attempts to display the
-matching open parenthesis by placing the cursor on top of it for
-@hid[Paren Pause Period] seconds.  If there is no matching parenthesis then
-beep.  If the matching parenthesis is off the top of the screen, then the line
-on which it appears is displayed in the echo area.  Paren pausing may be
-disabled by setting @hid[Paren Pause Period] to @nil. 
-@enddefcom
-
-The initial values shown for @hid[Highlight Open Parens] and @hid[Paren Pause
-Period] are only approximately correct.  Since paren highlighting is only
-meaningful in Lisp mode, @hid[Highlight Open Parens] is false globally, and
-has a mode-local value of @true in Lisp mode.  It it redundant to do both
-kinds of paren matching, so there is also a binding of @hid[Paren Pause Period]
-to @false in Lisp mode.
-
-Paren highlighting is only supported under @windows, so the above defaults are
-conditional on the device type.  If @hemlock is started on a terminal, the
-initialization code makes Lisp mode bindings of @false and @f[0.5] for
-@hid[Highlight Open Parens] and @hid[Paren Pause Period].  Since these
-alternate default bindings are made at initialization time, the only way to
-affect them is to use the @f[after-editor-initializations] macro.
-
-
-@section[Parsing Lisp]
-Lisp mode has a fairly complete knowledge of Lisp syntax, but since it does
-not use the reader, and must work incrementally, it can be confused by legal
-constructs.  Lisp mode totally ignores the read-table, so user-defined read
-macros have no effect on the editor.  In some cases, the values the @hid[Lisp
-Syntax] character attribute can be changed to get a similar effect.
-
-Lisp commands consistently treat semicolon (@f[;]) style comments as
-whitespace when parsing, so a Lisp command used in a comment will affect the
-next (or previous) form outside of the comment.  Since @f[#| ... |#] comments
-are not recognized, they can used to comment out code, while still allowing
-Lisp editing commands to be used.
-
-Strings are parsed similarly to symbols.  When within a string, the next form
-is after the end of the string, and the previous form is the beginning of the
-string.
-
-
-@defhvar[var "Defun Parse Goal", val {2}]
-@defhvar1[var "Maximum Lines Parsed", val {500}]
-@defhvar1[var "Minimum Lines Parsed", val {50}]
-In order to save time, Lisp mode does not parse the entire buffer every time
-a Lisp command is used.  Instead, it uses a heuristic to guess the region of
-the buffer that is likely to be interesting.  These variables control the
-heuristic.
-
-Normally, parsing begins and ends on defun boundaries (an open parenthesis at
-the beginning of a line).  @hid[Defun Parse Goal] specifies the number of
-defuns before and after the point to parse.  If this parses fewer lines than
-@hid[Minimum Lines Parsed], then parsing continues until this lower limit is
-reached.  If we cannot find enough defuns within @hid[Maximum Lines Parsed]
-lines then we stop on the farthest defun found, or at the point where we
-stopped if no defuns were found.
-
-When the heuristic fails, and does not parse enough of the buffer, then
-commands usually act as though a syntax error was detected.  If the parse
-starts in a bad place (such as in the middle of a string), then Lisp commands
-will be totally confused.  Such problems can usually be eliminated by
-increasing the values of some of these variables.
-@enddefhvar
-
-@defhvar[var "Parse Start Function", val {start-of-parse-block}]
-@defhvar1[var "Parse End Function", val {end-of-parse-block}]
-These variables determine the region of the buffer parsed.  The values are
-functions that take a mark and move it to the start or end of the parse region.
-The default values implement the heuristic described above.
-@enddefhvar
-
-
-
-@comment[@chap(Interacting With Lisp)]
-@include(lisp)
-
-
-@comment[@chap(Mail Interface)]
-@include(mail)
-
-
-@comment[@chap(Netnews Interface)]
-@include(netnews)
-
-
-
-@chap[System Interface]
-
-@hemlock provides a number of commands that access operating system resources
-such as the filesystem and print servers.  These commands offer an alternative
-to leaving the editor and using the normal operating system command language
-(such as the Unix shell), but they are implementation dependent.  Therefore,
-they might not even exist in some implementations.
-
-
-@section[File Utility Commands]
-This section describes some general file operation commands and quick directory
-commands. 
-
-See section @ref[dired] for a description @hemlock's directory editing
-mechanism, @hid[Dired] mode.
-
-@defcom[com "Copy File"]
-This command copies a file, allowing one wildcard in the filename.  It prompts
-for source and destination specifications.
-
-If these are both directories, then the copying process is recursive on the
-source, and if the destination is in the subdirectory structure of the source,
-the recursion excludes this portion of the directory tree.  Use
-@f[dir-spec-1/*] to copy only the files in a source directory without
-recursively descending into subdirectories.
-
-If the destination specification is a directory, and the source is a file, then
-it is copied into the destination with the same filename.
-
-The copying process copies files maintaining the source's write date.
-
-See the description of @hid[Dired Copy File Confirm], page
-@pageref[copy-confirm], for controlling user interaction when the destination
-exists.
-@enddefcom
-
-@defcom[com "Rename File"]
-This command renames a file, allowing one wildcard in the filename.  It prompts
-for source and destination specifications.
-
-If the destination is a directory, then the renaming process moves file(s)
-indicated by the source into the directory with their original filenames.
-
-For Unix-based implementations, if you want to rename a directory, do not
-specify the trailing slash in the source specification.
-@enddefcom
-
-@defcom[com "Delete File"]
-This command prompts for the name of a file and deletes it.
-@enddefcom
-
-@defcom[com "Directory", bind (C-x C-d)]
-@defcom1[com "Verbose Directory", bind (C-x C-D)]
-These commands prompt for a pathname (which may contain wildcards), and display
-a directory listing in a pop-up window.  If a prefix argument is supplied, then
-normally hidden files such as Unix dot-files will also be displayed.  
-@hid[Directory] uses a compact, multiple-column format; 
-@hid[Verbose Directory] displays one file on a line, with information about
-protection, size, etc.
-@enddefcom
-
-
-@section[Printing]
-
-@defcom[com "Print Region"]
-@defcom1[com "Print Buffer"]
-@defcom1[com "Print File"]
-@hid[Print Region] and @hid[Print Buffer] print the contents of the current
-region and the current buffer, respectively.  @hid[Print File] prompts for a
-the name of a file and prints that file.  Any error messages will be displayed
-in the echo area.
-@enddefcom
-
-@defhvar[var "Print Utility", val {"/usr/cs/bin/lpr"}]
-@defhvar1[var "Print Utility Switches", val {()}]
-@hid[Print Utility] is the program the print commands use to send files to the
-printer.  The program should act like @f[lpr]: if a filename is given as an
-argument, it should print that file, and if no name appears, standard input
-should be assumed.  @hid[Print Utility Switches] is a list of strings
-specifying the options to pass to the program.
-@enddefhvar
-
-
-@section[Scribe]
-@defcom[com "Scribe Buffer File",
-	stuff (bound to @bf[C-x c] in @hid[Scribe] mode)]
-@defhvar1[var "Scribe Buffer File Confirm", val {t}]
-@defcom1[com "Scribe File"]
-@hid[Scribe Buffer File] invokes @hid[Scribe Utility] on the file associated
-with the current buffer.  That process's default directory is the directory of
-the file.  The process sends its output to the @hid[Scribe Warnings] buffer.
-Before doing anything, this asks the user to confirm saving and formatting the
-file.  This prompting can be inhibited with "Scribe Buffer File Confirm".
-
-@hid[Scribe File] invokes @hid[Scribe Utility] on a file supplied by the user
-in the same manner as describe above.
-@enddefcom
-
-@defhvar[var "Scribe Utility", val {"/usr/misc/bin/scribe"}]
-@defhvar1[var "Scribe Utility Switches"]
-@hid[Scribe Utility] is the program the Scribe commands use to compile the text
-formatting.  @hid[Scribe Utility Switches] is a list of strings whose contents
-would be contiguous characters, other than space, had the user invoked this
-program on a command line outside of @hemlock.  Do not include the name of the
-file to compile in this variable; the Scribe commands supply this.
-@enddefhvar
-
-@defcom[com "Select Scribe Warnings", bind (Scribe: C-M-C)]
-This command makes the @hid[Scribe Warnings] buffer current if it exists.
-@enddefcom
-
-
-@section[Miscellaneous]
-
-@defcom[com "Manual Page"]
-This command displays a Unix manual page in a buffer which is in @hid[View]
-mode.  When given an argument, this puts the manual page in a pop-up display.
-@enddefcom
-
-@defcom[com "Unix Filter Region"]
-This command prompts for a UNIX program and then passes the current region to
-the program as standard input.  The standard output from the program is used to
-replace the region.  This command is undoable.
-@enddefcom
-
-
-
-@chap[Simple Customization]
-
-@index[customization]@hemlock can be customized and extended to a very
-large degree, but in order to do much of this a knowledge of Lisp is
-required.  These advanced aspects of customization are discussed in the
-@i[Hemlock Command Implementor's Manual], while simpler methods of
-customization are discussed here.
-
-
-@section[Keyboard Macros]
-@index[keyboard macros]
-Keyboard macros provide a facility to turn a sequence of commands into one
-command.
-
-@defcom[com "Define Keyboard Macro", bind {C-x (}]
-@defcom1[com "End Keyboard Macro", bind {C-x )}]
-@hid[Define Keyboard Macro] starts the definition of a keyboard macro.  The
-commands which are invoked up until @hid[End Keyboard Macro] is invoked
-become the definition for the keyboard macro, thus replaying the keyboard
-macro is synonymous with invoking that sequence of commands.
-@enddefcom
-
-@defcom[com "Last Keyboard Macro", bind (C-x e)]
-This command is the keyboard macro most recently defined; invoking it will
-replay the keyboard macro.  The prefix argument is used as a repeat count.
-@enddefcom
-
-@defcom[com "Define Keyboard Macro Key", bind (C-x M-(; )]
-@defhvar1[var "Define Keyboard Macro Key Confirm", val {t}]
-This command prompts for a key before going into a mode for defining keyboard
-macros.  After defining the macro @hemlock binds it to the key.  If the key is
-already bound, @hemlock asks for confirmation before clobbering the binding;
-this prompting can be inhibited by setting @hid[Define Keyboard Macro Key
-Confirm] to @nil.
-@enddefcom
-
-@defcom[com "Keyboard Macro Query", bind (C-x q)]
-This command conditionalizes the execution of a keyboard macro.  When invoked
-during the definition of a macro, it does nothing.  When the macro replays, it
-prompts the user for a key-event indicating what action to take.  The following
-commands are defined:
-@begin[description]
-@binding[Escape]@\
- Exit all repetitions of this keyboard macro.  More than one may have been
-specified using a prefix argument.
-
-@binding[Space, y]@\
- Proceed with the execution of the keyboard macro.
-
-@binding[Delete, Backspace, n]@\
- Skip the remainder of the keyboard macro and go on to the next repetition, if
-any.
-
-@binding[!]@\
- Do all remaining repetitions of the keyboard macro without prompting.
-
-@binding[.]@\
- Complete this repetition of the macro and then exit without doing any of the
-remaining repetitions.
-
-@binding[C-r]@\
- Do a recursive edit and then prompt again.
-@end[description]
-@enddefcom
-
-@defcom[com "Name Keyboard Macro"]
-This command prompts for the name of a command and then makes the
-definition for that command the same as @hid[Last Keyboard Macro]'s current
-definition.  The command which results is not clobbered when another
-keyboard macro is defined, so it is possible to keep several keyboard
-macros around at once.  The resulting command may also be bound to a key
-using @hid[Bind Key], in the same way any other command is.
-@enddefcom
-
-Many keyboard macros are not for customization, but rather for one-shot
-use, a typical example being performing some operation on each line of a file.
-To add "@f[del ]" to the beginning and "@f[.*]" to the end of every line in
-in a buffer, one could do this:
-@begin[programexample]
-C-x ( d e l Space C-e . * C-n C-a C-x ) C-u 9 9 9 C-x e
-@end[programexample]
-First a keyboard macro is defined which performs the desired operation on
-one line, and then the keyboard macro is invoked with a large prefix
-argument.  The keyboard macro will not actually execute that many times;
-when the end of the buffer is reached the @binding[C-n] will get an error
-and abort the execution.
-
-
-@section[Binding Keys]
-@index[key bindings]
-@label[binding-keys]
-
-@defcom[com "Bind Key"]
-This command prompts for a command, a key and a kind of binding to make,
-and then makes the specified binding.  The following kinds of bindings are
-allowed:
-@begin[description]
-@i[buffer]@\Prompts for a buffer and then makes a key binding which is
-only present when that buffer is the current buffer.
-
-@i[mode]@\Prompts for the name of a mode and then makes a key binding which
-is only in present when that mode is active in the current buffer.
-
-@i[global]@\Makes a global key binding which is in effect when there is
-no applicable mode or buffer key binding.  This is the default.
-@end[description]
-@enddefcom
-
-@defcom[com "Delete Key Binding"]
-This command prompts for a key binding the same way that @hid[Bind Key]
-does and makes the specified binding go away.
-@enddefcom
-
-@section[Hemlock Variables]
-
-@label[vars]@index[variables, hemlock]@index[hemlock variables]A number
-of commands use @hemlock variables as flags to control their behavior.  Often
-you can get a command to do what you want by setting a variable.  Generally the
-default value for a variable is chosen to be the safest value for novice users.
-
-@defcom[com "Set Variable"]
-This command prompts for the name of a @hemlock variable and an expression,
-then sets the current value of the variable to the result of the evaluation of
-the expression.
-@enddefcom
-
-
-@defcom[com "Defhvar"]
-Like @hid[Set Variable], this command prompts for the name of a @hemlock
-variable and an expression.  Like @hid[Bind Key], this command prompts for a
-place: mode, buffer or local.  The result of evaluating the expression is
-defined to be the value of the named variable in the specified place.
-
-This command is most useful for making mode or buffer local bindings of
-variables.  Redefining a variable in a mode or buffer will create a
-customization that takes effect only when in that mode or buffer.
-
-Unlike @hid[Set Variable], the variable name need not be the name of an
-existing variable: new variables may be defined.  If the variable is already
-defined in the current environment, @hemlock copies the documentation and hooks
-to the new definition.
-@enddefcom
-
-
-@section[Init Files]
-@index[init files]
-@hemlock customizations are normally put in @hemlock's initialization file,
-"@f[hemlock-init.lisp]", or when compiled "@f[hemlock-init.fasl]".  When
-starting up Lisp, use the @f[-hinit] switch to indicate a particular file.  The
-contents of the init file must be Lisp code, but there is a fairly
-straightforward correspondence between the basic customization commands and the
-equivalent Lisp code.  Rather than describe these functions in depth here, a
-brief example follows:
-@begin[programexample]
-;;; -*- Mode: Lisp; Package: Hemlock -*-
-
-;;; It is necessary to specify that the customizations go in
-;;; the hemlock package.
-(in-package 'hemlock)
-
-;;; Bind @hid[Kill Previous Word] to @binding[M-h].
-(bind-key "Kill Previous Word" '#(#\m-h))
-;;;
-;;; Bind @hid[Extract List] to @binding[C-M-?] when in @hid[Lisp] mode.
-(bind-key "Extract List" '#(#\c-m-?) :mode "Lisp")
-
-;;; Make @binding[C-w] globally unbound.
-(delete-key-binding '#(#\c-w))
-
-;;; Make string searches case-sensitive.
-(setv string-search-ignore-case nil)
-;;;
-;;; Make "Query Replace" replace strings literally.
-(setv case-replace nil)
-@end[programexample]
-For a detailed description of these functions, see the @i[Hemlock Command
-Implementor's Manual].
diff --git a/docs/internals/architecture.tex b/docs/internals/architecture.tex
deleted file mode 100644
index cbee09078d60c0ddcc77496982fa9d9cf285077d..0000000000000000000000000000000000000000
--- a/docs/internals/architecture.tex
+++ /dev/null
@@ -1,306 +0,0 @@
-\part{System Architecture}% -*- Dictionary: int:design -*-
-
-\chapter{Package and File Structure}
-
-\section{RCS and build areas}
-
-The CMU CL sources are maintained using RCS in a hierarchical directory
-structure which supports:
-\begin{itemize}
-\item    shared RCS config file across a build area, 
-
-\item    frozen sources for multiple releases, and 
-
-\item    separate system build areas for different architectures.
-\end{itemize}
-
-Since this organization maintains multiple copies of the source, it is somewhat
-space intensive.  But it is easy to delete and later restore a copy of the
-source using RCS snapshots.
-
-There are three major subtrees of the root \verb|/afs/cs/project/clisp|:
-\begin{description}
-\item[rcs] holds the RCS source (suffix \verb|,v|) files.
-
-\item[src] holds ``checked out'' (but not locked) versions of the source files,
-and is subdivided by release.  Each release directory in the source tree has a
-symbolic link named ``{\tt RCS}'' which points to the RCS subdirectory of the
-corresponding directory in the ``{\tt rcs} tree.  At top-level in a source tree
-is the ``{\tt RCSconfig}'' file for that area.  All subdirectories also have a
-symbolic link to this RCSconfig file, allowing the configuration for an area to
-be easily changed.
-
-\item[build] compiled object files are placed in this tree, which is subdivided
-by machine type and version.  The CMU CL search-list mechanism is used to allow
-the source files to be located in a different tree than the object files.  C
-programs are compiled by using the \verb|tools/dupsrcs| command to make
-symbolic links to the corresponding source tree.
-\end{description}
-
-On order to modify an file in RCS, it must be checked out with a lock to
-produce a writable working file.  Each programmer checks out files into a
-personal ``play area'' subtree of \verb|clisp/hackers|.  These tree duplicate
-the structure of source trees, but are normally empty except for files actively
-being worked on.
-
-See \verb|/afs/cs/project/clisp/pmax_mach/alpha/tools/| for
-various tools we use for RCS hacking:
-\begin{description}
-\item[rcs.lisp] Hemlock (editor) commands for RCS file manipulation
-
-\item[rcsupdate.c] Program to check out all files in a tree that have been
-modified since last checkout.
-
-\item[updates] Shell script to produce a single listing of all RCS log
- entries in a tree since a date.
-
-\item[snapshot-update.lisp] Lisp program to generate a shell script which
-generates a listing of updates since a particular RCS snapshot ({\tt RCSSNAP})
-file was created.
-\end{description}
-
-You can easily operate on all RCS files in a subtree using:
-\begin{verbatim}
-find . -follow -name '*,v' -exec <some command> {} \;
-\end{verbatim}
-
-\subsection{Configuration Management}
-
-config files are useful, especially in combinarion with ``{\tt snapshot}''.  You
-can shapshot any particular version, giving an RCSconfig that designates that
-configuration.  You can also use config files to specify the system as of a
-particular date.  For example:
-\begin{verbatim}
-<3-jan-91
-\end{verbatim}
-in the the config file will cause the version as of that 3-jan-91 to be checked
-out, instead of the latest version.
-
-\subsection{RCS Branches}
-
-Branches and named revisions are used together to allow multiple paths of
-development to be supported.  Each separate development has a branch, and each
-branch has a name.  This project uses branches in two somewhat different cases
-of divergent development:
-\begin{itemize}
-\item For systems that we have imported from the outside, we generally assign a
-``{\tt cmu}'' branch for our local modifications.  When a new release comes
-along, we check it in on the trunk, and then merge our branch back in.
-
-\item For the early development and debugging of major system changes, where
-the development and debugging is expected to take long enough that we wouldn't
-want the trunk to be in an inconsistent state for that long.
-\end{itemize}
-
-\section{Releases}
-
-We name releases according to the normal alpha, beta, default convention.
-Alpha releases are frequent, intended primarily for internal use, and are thus
-not subject to as high high documentation and configuration management
-standards.  Alpha releases are designated by the date on which the system was
-built; the alpha releases for different systems may not be in exact
-correspondence, since they are built at different times.
-
-Beta and default releases are always based on a snapshot, ensuring that all
-systems are based on the same sources.  A release name is an integer and a
-letter, like ``15d''.  The integer is the name of the source tree which the
-system was built from, and the letter represents the release from that tree:
-``a'' is the first release, etc.  Generally the numeric part increases when
-there are major system changes, whereas changes in the letter represent
-bug-fixes and minor enhancements.
-
-\section{Source Tree Structure}
-
-A source tree (and the master ``{\tt rcs}'' tree) has subdirectories for each
-major subsystem:
-\begin{description}
-\item[{\tt assembly/}] Holds the CMU CL source-file assembler, and has machine
-specific subdirectories holding assembly code for that architecture.
-
-\item[{\tt clx/}] The CLX interface to the X11 window system.
-
-\item[{\tt code/}] The Lisp code for the runtime system and standard CL
-utilities.
-
-\item[{\tt compiler/}] The Python compiler.  Has architecture-specific
-subdirectories which hold backends for different machines.  The {\tt generic}
-subdirectory holds code that is shared across most backends.
-
-\item[{\tt hemlock/}] The Hemlock editor.
-
-\item[{\tt ldb/}] The C runtime system code and low-level ``Lisp DeBugger''.
-
-\item[{\tt pcl/}] CMU version of the PCL implementation of CLOS.
-
-\item[{\tt tools/}] System building command files and source management tools.
-\end{description}
-
-
-\section{Package structure}
-
-Goals: with the single exception of LISP, we want to be able to export from the
-package that the code lives in.
-
-\begin{description}
-\item[Mach, CLX...] --- These Implementation-dependent system-interface
-packages provide direct access to specific features available in the operating
-system environment, but hide details of how OS communication is done.
-
-\item[system] contains code that must know about the operating system
-environment: I/O, etc.  Hides the operating system environment.  Provides OS
-interface extensions such as {\tt print-directory}, etc.
-
-\item[kernel] hides state and types used for system integration: package
-system, error system, streams (?), reader, printer.  Also, hides the VM, in
-that we don't export anything that reveals the VM interface.  Contains code
-that needs to use the VM and SYSTEM interface, but is independent of OS and VM
-details.  This code shouldn't need to be changed in any port of CMU CL, but
-won't work when plopped into an arbitrary CL.  Uses SYSTEM, VM, EXTENSIONS.  We
-export "hidden" symbols related to implementation of CL: setf-inverses,
-possibly some global variables.
-
-The boundary between KERNEL and VM is fuzzy, but this fuzziness reflects the
-fuzziness in the definition of the VM.  We can make the VM large, and bring
-everything inside, or we make make it small.  Obviously, we want the VM to be
-as small as possible, subject to efficiency constraints.  Pretty much all of
-the code in KERNEL could be put in VM.  The issue is more what VM hides from
-KERNEL: VM knows about everything.
-
-\item[lisp]  Originally, this package had all the system code in it.  The
-current ideal is that this package should have {\it no} code in it, and only
-exist to export the standard interface.  Note that the name has been changed by
-x3j13 to common-lisp.
-
-\item[extensions] contains code that any random user could have written: list
-operations, syntactic sugar macros.  Uses only LISP, so code in EXTENSIONS is
-pure CL.  Exports everything defined within that is useful elsewhere.  This
-package doesn't hide much, so it is relatively safe for users to use
-EXTENSIONS, since they aren't getting anything they couldn't have written
-themselves.  Contrast this to KERNEL, which exports additional operations on
-CL's primitive data structures: PACKAGE-INTERNAL-SYMBOL-COUNT, etc.  Although
-some of the functionality exported from KERNEL could have been defined in CL,
-the kernel implementation is much more efficient because it knows about
-implementation internals.  Currently this package contains only extensions to
-CL, but in the ideal scheme of things, it should contain the implementations of
-all CL functions that are in KERNEL (the library.)
-
-\item[VM] hides information about the hardware and data structure
-representations.  Contains all code that knows about this sort of thing: parts
-of the compiler, GC, etc.  The bulk of the code is the compiler back-end.
-Exports useful things that are meaningful across all implementations, such as
-operations for examining compiled functions, system constants.  Uses COMPILER
-and whatever else it wants.  Actually, there are different {\it machine}{\tt
--VM} packages for each target implementation.  VM is a nickname for whatever
-implementation we are currently targeting for.
-
-
-\item[compiler] hides the algorithms used to map Lisp semantics onto the
-operations supplied by the VM.  Exports the mechanisms used for defining the
-VM.  All the VM-independent code in the compiler, partially hiding the compiler
-intermediate representations.  Uses KERNEL.
-
-\item[eval] holds code that does direct execution of the compiler's ICR.  Uses
-KERNEL, COMPILER.  Exports debugger interface to interpreted code.
-
-\item[debug-internals] presents a reasonable, unified interface to
-manipulation of the state of both compiled and interpreted code.  (could be in
-KERNEL) Uses VM, INTERPRETER, EVAL, KERNEL.
-
-\item[debug] holds the standard debugger, and exports the debugger 
-\end{description}
-
-\chapter{System Building}
-
-It's actually rather easy to build a CMU CL core with exactly what you want in
-it.  But to do this you need two things: the source and a working CMU CL.
-
-Basically, you use the working copy of CMU CL to compile the sources,
-then run a process call ``genesis'' which builds a ``kernel'' core.
-You then load whatever you want into this kernel core, and save it.
-
-In the \verb|tools/| directory in the sources there are several files that
-compile everything, and build cores, etc.  The first step is to compile the C
-startup code.
-
-{\bf Note:} {\it the various scripts mentioned below have hard-wired paths in
-them set up for our directory layout here at CMU.  Anyone anywhere else will
-have to edit them before they will work.}
-
-\section{Compiling the C Startup Code}
-
-There is a circular dependancy between ldb/lisp.h and ldb/ldb.map that causes
-bootstrapping problems.  To the easiest way to get around this problem is to
-make a fake ldb.map file that has nothing in it by a version number:
-\begin{verbatim}
-	% echo "Map file for ldb version 0" > ldb.map
-\end{verbatim}
-and then run genesis with NIL for the list of files:
-\begin{verbatim}
-	* (load ".../compiler/generic/genesis")
-	* (lisp::genesis nil ".../ldb/ldb.map" "/dev/null"
-		".../ldb/lisp.map" ".../ldb/lisp.h")
-\end{verbatim}
-It will generate
-a whole bunch of warnings about things being undefined, but ignore
-that, because it will also generate a correct lisp.h.  You can then
-compile ldb producing a correct ldb.map:
-\begin{verbatim}
-	% make
-\end{verbatim}
-and the use \verb|tools/do-worldbuild| and \verb|tools/mk-lisp| to build
-\verb|kernel.core| and \verb|lisp.core| (see section \ref[building-cores].)
-
-\section{Compiling the Lisp Code}
-
-The \verb|tools| directory contains various lisp and C-shell utilities for
-building CMU CL:
-\begin{description}
-\item[compile-all*] Will compile lisp files and build a kernel core.  It has
-numerous command-line options to control what to compile and how.  Try -help to
-see a description.  It runs a separate Lisp process to compile each
-subsystem.  Error output is generated in files with ``{\tt .log}'' extension in
-the root of the build area.
-
-\item[setup.lisp] Some lisp utilities used for compiling changed files in batch
-mode and collecting the error output Sort of a crude defsystem.  Loads into the
-``user'' package.  See {\tt with-compiler-log-file} and {\tt comf}.
-
-\item[{\it foo}com.lisp] Each system has a ``\verb|.lisp|'' file in
-\verb|tools/| which compiles that system.
-\end{description}
-
-\section{Building Core Images}
-\label{building-cores}
-Both the kernel and final core build are normally done using shell script
-drivers:
-\begin{description}
-\item[do-worldbuild*] Builds a kernel core for the current machine.  The
-version to build is indicated by an optional argument, which defaults to
-``alpha''.  The \verb|kernel.core| file is written either in the \verb|ldb/|
-directory in the build area, or in \verb|/usr/tmp/|.  The directory which
-already contains \verb|kernel.core| is chosen.  You can create a dummy version
-with e.g. ``touch'' to select the initial build location.
-
-\item[mk-lisp*] Builds a full core, with conditional loading of subsystems.
-The version is the first argument, which defaults to ``alpha''.  Any additional
-arguments are added to the \verb|*features*| list, which controls system
-loading (among other things.)  The \verb|lisp.core| file is written in the
-current working directory.
-\end{description}
-
-These scripts load Lisp command files.  When \verb|tools/worldbuild.lisp| is
-loaded, it calls genesis with the correct arguments to build a kernel core.
-Similarly, \verb|worldload.lisp|
-builds a full core.  Adding certain symbols to \verb|*features*| before
-loading worldload.lisp suppresses loading of different parts of the
-system.  These symbols are:
-\begin{description}
-\item[:no-compiler] don't load the compiler.
-\item[:no-clx] don't load CLX.
-\item[:no-hemlock] don't load hemlock.
-\item[:no-pcl] don't load PCL.
-\end{description}
-
-Note: if you don't load the compiler, you can't (successfully) load the
-pretty-printer or pcl.  And if you compiled hemlock with CLX loaded, you can't
-load it without CLX also being loaded.
diff --git a/docs/internals/back.tex b/docs/internals/back.tex
deleted file mode 100644
index edeff4674c11d0942a52cb924adcbe972e3c5537..0000000000000000000000000000000000000000
--- a/docs/internals/back.tex
+++ /dev/null
@@ -1,725 +0,0 @@
-% -*- Dictionary: design -*-
-
-\chapter{Copy propagation}
-
-File: {\tt copyprop}
-
-This phase is optional, but should be done whenever speed or space is more
-important than compile speed.  We use global flow analysis to find the reaching
-definitions for each TN.  This information is used here to eliminate
-unnecessary TNs, and is also used later on by loop invariant optimization.
-
-In some cases, VMR conversion will unnecessarily copy the value of a TN into
-another TN, since it may not be able to tell that the initial TN has the same
-value at the time the second TN is referenced.  This can happen when ICR
-optimize is unable to eliminate a trivial variable binding, or when the user
-does a setq, or may also result from creation of expression evaluation
-temporaries during VMR conversion.  Whatever the cause, we would like to avoid
-the unnecessary creation and assignment of these TNs.
-
-What we do is replace TN references whose only reaching definition is a Move
-VOP with a reference to the TN moved from, and then delete the Move VOP if the
-copy TN has no remaining references.  There are several restrictions on copy
-propagation:
-\begin{itemize}
-\item The TNs must be ``ordinary'' TNs, not restricted or otherwise
-unusual.  Extending the life of restricted (or wired) TNs can make register
-allocation impossible.  Some other TN kinds have hidden references.
-
-\item We don't want to defeat source-level debugging by replacing named
-variables with anonymous temporaries.
-
-\item We can't delete moves that representation selected might want to change
-into a representation conversion, since we need the primitive types of both TNs
-to select a conversion.
-\end{itemize}
-
-Some cleverness reduces the cost of flow analysis.  As for lifetime analysis,
-we only need to do flow analysis on global packed TNs.  We can't do the real
-local TN assignment pass before this, since we allocate TNs afterward, so we do
-a pre-pass that marks the TNs that are local for our purposes.  We don't care
-if block splitting eventually causes some of them to be considered global.
-
-Note also that we are really only are interested in knowing if there is a
-unique reaching definition, which we can mash into our flow analysis rules by
-doing an intersection.  Then a definition only appears in the set when it is
-unique.  We then propagate only definitions of TNs with only one write, which
-allows the TN to stand for the definition.
-
-
-\chapter{Representation selection}
-
-File: {\tt represent}
-
-Some types of object (such as {\tt single-float}) have multiple possible
-representations.  Multiple representations are useful mainly when there is a
-particularly efficient non-descriptor representation.  In this case, there is
-the normal descriptor representation, and an alternate non-descriptor
-representation.
-
-This possibility brings up two major issues:
-\begin{itemize}
-\item The compiler must decide which representation will be most efficient for
-any given value, and
-
-\item Representation conversion code must be inserted where the representation
-of a value is changed.
-\end{itemize}
-First, the representations for TNs are selected by examining all the TN
-references and attempting to minimize reference costs.  Then representation
-conversion code is introduced.
-
-This phase is in effect a pre-pass to register allocation.  The main reason for
-its existence is that representation conversions may be farily complex (e.g.
-involving memory allocation), and thus must be discovered before register
-allocation.
-
-
-VMR conversion leaves stubs for representation specific move operations.
-Representation selection recognizes {\tt move} by name.  Argument and return
-value passing for call VOPs is controlled by the {\tt :move-arguments} option
-to {\tt define-vop}.
-
-Representation selection is also responsible for determining what functions use
-the number stack.  If any representation is chosen which could involve packing
-into the {\tt non-descriptor-stack} SB, then we allocate the NFP register
-throughout the component.  As an optimization, permit the decision of whether a
-number stack frame needs to be allocated to be made on a per-function basis.
-If a function doesn't use the number stack, and isn't in the same tail-set as
-any function that uses the number stack, then it doesn't need a number stack
-frame, even if other functions in the component do.
-
-
-\chapter{Lifetime analysis}
-
-File: {\tt life}
-
-This phase is a preliminary to Pack.  It involves three passes:
- -- A pre-pass that computes the DEF and USE sets for live TN analysis, while
-    also assigning local TN numbers, splitting blocks if necessary.  \#\#\# But
-not really...
- -- A flow analysis pass that does backward flow analysis on the
-    component to find the live TNs at each block boundary.
- -- A post-pass that finds the conflict set for each TN.
-
-\#|
-Exploit the fact that a single VOP can only exhaust LTN numbers when there are
-large more operands.  Since more operand reference cannot be interleaved with
-temporary reference, the references all effectively occur at the same time.
-This means that we can assign all the more args and all the more results the
-same LTN number and the same lifetime info.
-|\#
-
-
-\section{Flow analysis}
-
-It seems we could use the global-conflicts structures during compute the
-inter-block lifetime information.  The pre-pass creates all the
-global-conflicts for blocks that global TNs are referenced in.  The flow
-analysis pass just adds always-live global-conflicts for the other blocks the
-TNs are live in.  In addition to possibly being more efficient than SSets, this
-would directly result in the desired global-conflicts information, rather that
-having to create it from another representation.
-
-The DFO sorted per-TN global-conflicts thread suggests some kind of algorithm
-based on the manipulation of the sets of blocks each TN is live in (which is
-what we really want), rather than the set of TNs live in each block.
-
-If we sorted the per-TN global-conflicts in reverse DFO (which is just as good
-for determining conflicts between TNs), then it seems we could scan though the
-conflicts simultaneously with our flow-analysis scan through the blocks.
-
-The flow analysis step is the following:
-    If a TN is always-live or read-before-written in a successor block, then we
-    make it always-live in the current block unless there are already
-    global-conflicts recorded for that TN in this block.
-
-The iteration terminates when we don't add any new global-conflicts during a
-pass.
-
-We may also want to promote TNs only read within a block to always-live when
-the TN is live in a successor.  This should be easy enough as long as the
-global-conflicts structure contains this kind of info.
-
-The critical operation here is determining whether a given global TN has global
-conflicts in a given block.  Note that since we scan the blocks in DFO, and the
-global-conflicts are sorted in DFO, if we give each global TN a pointer to the
-global-conflicts for the last block we checked the TN was in, then we can
-guarantee that the global-conflicts we are looking for are always at or after
-that pointer.  If we need to insert a new structure, then the pointer will help
-us rapidly find the place to do the insertion.]
-
-
-\section{Conflict detection}
-
-[\#\#\# Environment, :more TNs.]
-
-This phase makes use of the results of lifetime analysis to find the set of TNs
-that have lifetimes overlapping with those of each TN.  We also annotate call
-VOPs with information about the live TNs so that code generation knows which
-registers need to be saved.
-
-The basic action is a backward scan of each block, looking at each TN-Ref and
-maintaining a set of the currently live TNs.  When we see a read, we check if
-the TN is in the live set.  If not, we:
- -- Add the TN to the conflict set for every currently live TN,
- -- Union the set of currently live TNs with the conflict set for the TN, and
- -- Add the TN to the set of live TNs.
-
-When we see a write for a live TN, we just remove it from the live set.  If we
-see a write to a dead TN, then we update the conflicts sets as for a read, but
-don't add the TN to the live set.  We have to do this so that the bogus write
-doesn't clobber anything.
-
-[We don't consider always-live TNs at all in this process, since the conflict
-of always-live TNs with other TNs in the block is implicit in the
-global-conflicts structures.
-
-Before we do the scan on a block, we go through the global-conflicts structures
-of TNs that change liveness in the block, assigning the recorded LTN number to
-the TN's LTN number for the duration of processing of that block.]
- 
-
-Efficiently computing and representing this information calls for some
-cleverness.  It would be prohibitively expensive to represent the full conflict
-set for every TN with sparse sets, as is done at the block-level.  Although it
-wouldn't cause non-linear behavior, it would require a complex linked structure
-containing tens of elements to be created for every TN.  Fortunately we can
-improve on this if we take into account the fact that most TNs are "local" TNs:
-TNs which have all their uses in one block.
-
-First, many global TNs will be either live or dead for the entire duration of a
-given block.  We can represent the conflict between global TNs live throughout
-the block and TNs local to the block by storing the set of always-live global
-TNs in the block.  This reduces the number of global TNs that must be
-represented in the conflicts for local TNs.
-
-Second, we can represent conflicts within a block using bit-vectors.  Each TN
-that changes liveness within a block is assigned a local TN number.  Local
-conflicts are represented using a fixed-size bit-vector of 64 elements or so
-which has a 1 for the local TN number of every TN live at that time.  The block
-has a simple-vector which maps from local TN numbers to TNs.  Fixed-size
-vectors reduce the hassle of doing allocations and allow operations to be
-open-coded in a maximally tense fashion.
-
-We can represent the conflicts for a local TN by a single bit-vector indexed by
-the local TN numbers for that block, but in the global TN case, we need to be
-able to represent conflicts with arbitrary TNs.  We could use a list-like
-sparse set representation, but then we would have to either special-case global
-TNs by using the sparse representation within the block, or convert the local
-conflicts bit-vector to the sparse representation at the block end.  Instead,
-we give each global TN a list of the local conflicts bit-vectors for each block
-that the TN is live in.  If the TN is always-live in a block, then we record
-that fact instead.  This gives us a major reduction in the amount of work we
-have to do in lifetime analysis at the cost of some increase in the time to
-iterate over the set during Pack.
-
-Since we build the lists of local conflict vectors a block at a time, the
-blocks in the lists for each TN will be sorted by the block number.  The
-structure also contains the local TN number for the TN in that block.  These
-features allow pack to efficiently determine whether two arbitrary TNs
-conflict.  You just scan the lists in order, skipping blocks that are in only
-one list by using the block numbers.  When we find a block that both TNs are
-live in, we just check the local TN number of one TN in the local conflicts
-vector of the other.
-
-In order to do these optimizations, we must do a pre-pass that finds the
-always-live TNs and breaks blocks up into small enough pieces so that we don't
-run out of local TN numbers.  If we can make a block arbitrarily small, then we
-can guarantee that an arbitrarily small number of TNs change liveness within
-the block.  We must be prepared to make the arguments to unbounded arg count
-VOPs (such as function call) always-live even when they really aren't.  This is
-enabled by a panic mode in the block splitter: if we discover that the block
-only contains one VOP and there are still too many TNs that aren't always-live,
-then we promote the arguments (which we'd better be able to do...).
-
-This is done during the pre-scan in lifetime analysis.  We can do this because
-all TNs that change liveness within a block can be found by examining that
-block: the flow analysis only adds always-live TNs.
-
-
-When we are doing the conflict detection pass, we set the LTN number of global
-TNs.  We can easily detect global TNs that have not been locally mapped because
-this slot is initially null for global TNs and we null it out after processing
-each block.  We assign all Always-Live TNs to the same local number so that we
-don't need to treat references to them specially when making the scan.
-
-We also annotate call VOPs that do register saving with the TNs that are live
-during the call, and thus would need to be saved if they are packed in
-registers.
-
-We adjust the costs for TNs that need to be saved so that TNs costing more to
-save and restore than to reference get packed on the stack.  We would also like
-more often saved TNs to get higher costs so that they are packed in more
-savable locations.
-
-
-\chapter{Packing}
-
-File: {\tt pack}
-
-\#|
-
-Add lifetime/pack support for pre-packed save TNs.
-
-Fix GTN/VMR conversion to use pre-packed save TNs for old-cont and return-PC.
-(Will prevent preference from passing location to save location from ever being
-honored?)
-
-We will need to make packing of passing locations smarter before we will be
-able to target the passing location on the stack in a tail call (when that is
-where the callee wants it.)  Currently, we will almost always pack the passing
-location in a register without considering whether that is really a good idea.
-Maybe we should consider schemes that explicitly understand the parallel
-assignment semantics, and try to do the assignment with a minimum number of
-temporaries.  We only need assignment temps for TNs that appear both as an
-actual argument value and as a formal parameter of the called function.  This
-only happens in self-recursive functions.
-
-Could be a problem with lifetime analysis, though.  The write by a move-arg VOP
-would look like a write in the current env, when it really isn't.  If this is a
-problem, then we might want to make the result TN be an info arg rather than a
-real operand.  But this would only be a problem in recursive calls, anyway.
-[This would prevent targeting, but targeting across passing locations rarely
-seems to work anyway.]  [\#\#\# But the :ENVIRONMENT TN mechanism would get
-confused.  Maybe put env explicitly in TN, and have it only always-live in that
-env, and normal in other envs (or blocks it is written in.)  This would allow
-targeting into environment TNs.  
-
-I guess we would also want the env/PC save TNs normal in the return block so
-that we can target them.  We could do this by considering env TNs normal in
-read blocks with no successors.  
-
-ENV TNs would be treated totally normally in non-env blocks, so we don't have
-to worry about lifetime analysis getting confused by variable initializations.
-Do some kind of TN costing to determine when it is more trouble than it is
-worth to allocate TNs in registers.
-
-Change pack ordering to be less pessimal.  Pack TNs as they are seen in the LTN
-map in DFO, which at least in non-block compilations has an effect something
-like packing main trace TNs first, since control analysis tries to put the good
-code first.  This could also reduce spilling, since it makes it less likely we
-will clog all registers with global TNs.
-
-If we pack a TN with a specified save location on the stack, pack in the
-specified location.
-
-Allow old-cont and return-pc to be kept in registers by adding a new "keep
-around" kind of TN.  These are kind of like environment live, but are only
-always-live in blocks that they weren't referenced in.  Lifetime analysis does
-a post-pass adding always-live conflicts for each "keep around" TN to those
-blocks with no conflict for that TN.  The distinction between always-live and
-keep-around allows us to successfully target old-cont and return-pc to passing
-locations.  MAKE-KEEP-AROUND-TN (ptype), PRE-PACK-SAVE-TN (tn scn offset).
-Environment needs a KEEP-AROUND-TNS slot so that conflict analysis can find
-them (no special casing is needed after then, they can be made with :NORMAL
-kind).  VMR-component needs PRE-PACKED-SAVE-TNS so that conflict analysis or
-somebody can copy conflict info from the saved TN.
-
-
-
-Note that having block granularity in the conflict information doesn't mean
-that a localized packing scheme would have to do all moves at block boundaries
-(which would clash with the desire the have saving done as part of this
-mechanism.)  All that it means is that if we want to do a move within the
-block, we would need to allocate both locations throughout that block (or
-something).
-
-
-
-
-
-Load TN pack:
-
-A location is out for load TN packing if: 
-
-The location has TN live in it after the VOP for a result, or before the VOP
-for an argument, or
-
-The location is used earlier in the TN-ref list (after) the saved results ref
-or later in the TN-Ref list (before) the loaded argument's ref.
-
-To pack load TNs, we advance the live-tns to the interesting VOP, then
-repeatedly scan the vop-refs to find vop-local conflicts for each needed load
-TN.  We insert move VOPs and change over the TN-Ref-TNs as we go so the TN-Refs
-will reflect conflicts with already packed load-TNs.
-
-If we fail to pack a load-TN in the desired SC, then we scan the Live-TNs for
-the SB, looking for a TN that can be packed in an unbounded SB.  This TN must
-then be repacked in the unbounded SB.  It is important the load-TNs are never
-packed in unbounded SBs, since that would invalidate the conflicts info,
-preventing us from repacking TNs in unbounded SBs.  We can't repack in a finite
-SB, since there might have been load TNs packed in that SB which aren't
-represented in the original conflict structures.
-
-Is it permissible to "restrict" an operand to an unbounded SC?  Not impossible
-to satisfy as long as a finite SC is also allowed.  But in practice, no
-restriction would probably be as good.
-
-We assume all locations can be used when an sc is based on an unbounded sb.
-
-]
-
-
-TN-Refs are be convenient structures to build the target graph out of.  If we
-allocated space in every TN-Ref, then there would certainly be enough to
-represent arbitrary target graphs.  Would it be enough to allocate a single
-Target slot?  If there is a target path though a given VOP, then the Target of
-the write ref would be the read, and vice-versa.  To find all the TNs that
-target us, we look at the TN for the target of all our write refs.
-
-We separately chain together the read refs and the write refs for a TN,
-allowing easy determination of things such as whether a TN has only a single
-definition or has no reads.  It would also allow easier traversal of the target
-graph.
- 
-Represent per-location conflicts as vectors indexed by block number of
-per-block conflict info.  To test whether a TN conflicts on a location, we
-would then have to iterate over the TNs global-conflicts, using the block
-number and LTN number to check for a conflict in that block.  But since most
-TNs are local, this test actually isn't much more expensive than indexing into
-a bit-vector by GTN numbers.
-
-The big win of this scheme is that it is much cheaper to add conflicts into the
-conflict set for a location, since we never need to actually compute the
-conflict set in a list-like representation (which requires iterating over the
-LTN conflicts vectors and unioning in the always-live TNs).  Instead, we just
-iterate over the global-conflicts for the TN, using BIT-IOR to combine the
-conflict set with the bit-vector for that block in that location, or marking
-that block/location combination as being always-live if the conflict is
-always-live.
-
-Generating the conflict set is inherently more costly, since although we
-believe the conflict set size to be roughly constant, it can easily contain
-tens of elements.  We would have to generate these moderately large lists for
-all TNs, including local TNs.  In contrast, the proposed scheme does work
-proportional to the number of blocks the TN is live in, which is small on
-average (1 for local TNs).  This win exists independently from the win of not
-having to iterate over LTN conflict vectors.
-
-
-[\#\#\# Note that since we never do bitwise iteration over the LTN conflict
-vectors, part of the motivation for keeping these a small fixed size has been
-removed.  But it would still be useful to keep the size fixed so that we can
-easily recycle the bit-vectors, and so that we could potentially have maximally
-tense special primitives for doing clear and bit-ior on these vectors.]
-
-This scheme is somewhat more space-intensive than having a per-location
-bit-vector.  Each vector entry would be something like 150 bits rather than one
-bit, but this is mitigated by the number of blocks being 5-10x smaller than the
-number of TNs.  This seems like an acceptable overhead, a small fraction of the
-total VMR representation.
-
-The space overhead could also be reduced by using something equivalent to a
-two-dimensional bit array, indexed first by LTN numbers, and then block numbers
-(instead of using a simple-vector of separate bit-vectors.)  This would
-eliminate space wastage due to bit-vector overheads, which might be 50% or
-more, and would also make efficient zeroing of the vectors more
-straightforward.  We would then want efficient operations for OR'ing LTN
-conflict vectors with rows in the array.
-
-This representation also opens a whole new range of allocation algorithms: ones
-that store allocate TNs in different locations within different portions of the
-program.  This is because we can now represent a location being used to hold a
-certain TN within an arbitrary subset of the blocks the TN is referenced in.
-
-
-
-
-
-
-
-
-
-Pack goals:
-
-Pack should:
-
-Subject to resource constraints:
- -- Minimize use costs
-     -- "Register allocation"
-         Allocate as many values as possible in scarce "good" locations,
-         attempting to minimize the aggregate use cost for the entire program.
-     -- "Save optimization"
-         Don't allocate values in registers when the save/restore costs exceed
-         the expected gain for keeping the value in a register.  (Similar to
-         "opening costs" in RAOC.)  [Really just a case of representation
-         selection.]
-
- -- Minimize preference costs
-    Eliminate as many moves as possible.
-
-
-"Register allocation" is basically an attempt to eliminate moves between
-registers and memory.  "Save optimization" counterbalances "register
-allocation" to prevent it from becoming a pessimization, since saves can
-introduce register/memory moves.
-
-Preference optimization reduces the number of moves within an SC.  Doing a good
-job of honoring preferences is important to the success of the compiler, since
-we have assumed in many places that moves will usually be optimized away.
-
-The scarcity-oriented aspect of "register allocation" is handled by a greedy
-algorithm in pack.  We try to pack the "most important" TNs first, under the
-theory that earlier packing is more likely to succeed due to fewer constraints.
-
-The drawback of greedy algorithms is their inability to look ahead.  Packing a
-TN may mess up later "register allocation" by precluding packing of TNs that
-are individually "less important", but more important in aggregate.  Packing a
-TN may also prevent preferences from being honored.
-
-
-
-Initial packing:
-
-
-Pack all TNs restricted to a finite SC first, before packing any other TNs.
-
-One might suppose that Pack would have to treat TNs in different environments
-differently, but this is not the case.  Pack simply assigns TNs to locations so
-that no two conflicting TNs are in the same location.  In the process of
-implementing call semantics in conflict analysis, we cause TNs in different
-environments not to conflict.  In the case of passing TNs, cross environment
-conflicts do exist, but this reflects reality, since the passing TNs are
-live in both the caller and the callee.  Environment semantics has already been
-implemented at this point.
-
-This means that Pack can pack all TNs simultaneously, using one data structure
-to represent the conflicts for each location.  So we have only one conflict set
-per SB location, rather than separating this information by environment
-environment.
-
-
-Load TN packing:
-
-We create load TNs as needed in a post-pass to the initial packing.  After TNs
-are packed, it may be that some references to a TN will require it to be in a
-SC other than the one it was packed in.  We create load-TNs and pack them on
-the fly during this post-pass.  
-
-What we do is have an optional SC restriction associated with TN-refs.  If we
-pack the TN in an SC which is different from the required SC for the reference,
-then we create a TN for each such reference, and pack it into the required SC.
-
-In many cases we will be able to pack the load TN with no hassle, but in
-general we may need to spill a TN that has already been packed.  We choose a
-TN that isn't in use by the offending VOP, and then spill that TN onto the
-stack for the duration of that VOP.  If the VOP is a conditional, then we must
-insert a new block interposed before the branch target so that the value TN
-value is restored regardless of which branch is taken.
-
-Instead of remembering lifetime information from conflict analysis, we rederive
-it.  We scan each block backward while keeping track of which locations have
-live TNs in them.  When we find a reference that needs a load TN packed, we try
-to pack it in an unused location.  If we can't, we unpack the currently live TN
-with the lowest cost and force it into an unbounded SC.
-
-The per-location and per-TN conflict information used by pack doesn't
-need to be updated when we pack a load TN, since we are done using those data
-structures.
-
-We also don't need to create any TN-Refs for load TNs.  [??? How do we keep
-track of load-tn lifetimes?  It isn't really that hard, I guess.  We just
-remember which load TNs we created at each VOP, killing them when we pass the
-loading (or saving) step.  This suggests we could flush the Refs thread if we
-were willing to sacrifice some flexibility in explicit temporary lifetimes.
-Flushing the Refs would make creating the VMR representation easier.]
-
-The lifetime analysis done during load-TN packing doubles as a consistency
-check.  If we see a read of a TN packed in a location which has a different TN
-currently live, then there is a packing bug.  If any of the TNs recorded as
-being live at the block beginning are packed in a scarce SB, but aren't current
-in that location, then we also have a problem.
-
-The conflict structure for load TNs is fairly simple, the load TNs for
-arguments and results all conflict with each other, and don't conflict with
-much else.  We just try packing in targeted locations before trying at random.
-
-
-
-\chapter{Code generation}
-
-This is fairly straightforward.  We translate VOPs into instruction sequences
-on a per-block basis.
-
-After code generation, the VMR representation is gone.  Everything is
-represented by the assembler data structures.
-
-
-\chapter{Assembly}
-
-In effect, we do much of the work of assembly when the compiler is compiled.
-
-The assembler makes one pass fixing up branch offsets, then squeezes out the
-space left by branch shortening and dumps out the code along with the load-time
-fixup information.  The assembler also deals with dumping unboxed non-immediate
-constants and symbols.  Boxed constants are created by explicit constructor
-code in the top-level form, while immediate constants are generated using
-inline code.
-
-[\#\#\# The basic output of the assembler is:
-    A code vector
-    A representation of the fixups along with indices into the code vector for
-      the fixup locations
-    A PC map translating PCs into source paths
-
-This information can then be used to build an output file or an in-core
-function object.
-]
-
-The assembler is table-driven and supports arbitrary instruction formats.  As
-far as the assembler is concerned, an instruction is a bit sequence that is
-broken down into subsequences.  Some of the subsequences are constant in value,
-while others can be determined at assemble or load time.
-
-Assemble Node Form*
-    Allow instructions to be emitted during the evaluation of the Forms by
-    defining Inst as a local macro.  This macro caches various global
-    information in local variables.  Node tells the assembler what node
-    ultimately caused this code to be generated.  This is used to create the
-    pc=>source map for the debugger.
-
-Assemble-Elsewhere Node Form*
-    Similar to Assemble, but the current assembler location is changed to
-    somewhere else.  This is useful for generating error code and similar
-    things.  Assemble-Elsewhere may not be nested.
-
-Inst Name Arg*
-    Emit the instruction Name with the specified arguments.
-
-Gen-Label
-Emit-Label (Label)
-    Gen-Label returns a Label object, which describes a place in the code.
-    Emit-Label marks the current position as being the location of Label.
-
-
-
-\chapter{Dumping}
-
-So far as input to the dumper/loader, how about having a list of Entry-Info
-structures in the VMR-Component?  These structures contain all information
-needed to dump the associated function objects, and are only implicitly
-associated with the functional/XEP data structures.  Load-time constants that
-reference these function objects should specify the Entry-Info, rather than the
-functional (or something).  We would then need to maintain some sort of
-association so VMR conversion can find the appropriate Entry-Info.
-Alternatively, we could initially reference the functional, and then later
-clobber the reference to the Entry-Info.
-
-We have some kind of post-pass that runs after assembly, going through the
-functions and constants, annotating the VMR-Component for the benefit of the
-dumper:
-    Resolve :Label load-time constants.
-    Make the debug info.
-    Make the entry-info structures.
-
-Fasl dumper and in-core loader are implementation (but not instruction set)
-dependent, so we want to give them a clear interface.
-
-open-fasl-file name => fasl-file
-    Returns a "fasl-file" object representing all state needed by the dumper.
-    We objectify the state, since the fasdumper should be reentrant.  (but
-    could fail to be at first.)
-
-close-fasl-file fasl-file abort-p
-    Close the specified fasl-file.
-
-fasl-dump-component component code-vector length fixups fasl-file
-    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.  Fixups is a list of conses (offset . fixup)
-    describing the locations and things that need to be fixed up at load time.
-    If the component is a top-level component, then the top-level lambda will
-    be called after the component is loaded.
-
-load-component component code-vector length fixups
-    Like Fasl-Dump-Component, but directly installs the code in core, running
-    any top-level code immediately.  (???) but we need some way to glue
-    together the componenents, since we don't have a fasl table.
-
-
-
-Dumping:
-
-Dump code for each component after compiling that component, but defer dumping
-of other stuff.  We do the fixups on the code vectors, and accumulate them in
-the table.
-
-We have to grovel the constants for each component after compiling that
-component so that we can fix up load-time constants.  Load-time constants are
-values needed my the code that are computed after code generation/assembly
-time.  Since the code is fixed at this point, load-time constants are always
-represented as non-immediate constants in the constant pool.  A load-time
-constant is distinguished by being a cons (Kind . What), instead of a Constant
-leaf.  Kind is a keyword indicating how the constant is computed, and What is
-some context.
-
-Some interesting load-time constants:
-
-    (:label . <label>)
-        Is replaced with the byte offset of the label within the code-vector.
-
-    (:code-vector . <component>)
-        Is replaced by the component's code-vector.
-
-    (:entry . <function>)
-    (:closure-entry . <function>)
-	Is replaced by the function-entry structure for the specified function.
-	:Entry is how the top-level component gets a handle on the function
-	definitions so that it can set them up.
-
-We also need to remember the starting offset for each entry, although these
-don't in general appear as explicit constants.
-
-We then dump out all the :Entry and :Closure-Entry objects, leaving any
-constant-pool pointers uninitialized.  After dumping each :Entry, we dump some
-stuff to let genesis know that this is a function definition.  Then we dump all
-the constant pools, fixing up any constant-pool pointers in the already-dumped
-function entry structures.
-
-The debug-info *is* a constant: the first constant in every constant pool.  But
-the creation of this constant must be deferred until after the component is
-compiled, so we leave a (:debug-info) placeholder.  [Or maybe this is
-implicitly added in by the dumper, being supplied in a VMR-component slot.]
-
-
-    Work out details of the interface between the back-end and the
-    assembler/dumper.
-
-    Support for multiple assemblers concurrently loaded?  (for byte code)
-    
-    We need various mechanisms for getting information out of the assembler.
-
-    We can get entry PCs and similar things into function objects by making a
-    Constant leaf, specifying that it goes in the closure, and then
-    setting the value after assembly.
-
-    We have an operation Label-Value which can be used to get the value of a
-    label after assembly and before the assembler data structures are
-    deallocated.
-
-    The function map can be constructed without any special help from the
-    assembler.  Codegen just has to note the current label when the function
-    changes from one block to the next, and then use the final value of these
-    labels to make the function map.
-
-    Probably we want to do the source map this way too.  Although this will
-    make zillions of spurious labels, we would have to effectively do that
-    anyway.
-
-    With both the function map and the source map, getting the locations right
-    for uses of Elsewhere will be a bit tricky.  Users of Elsewhere will need
-    to know about how these maps are being built, since they must record the
-    labels and corresponding information for the elsewhere range.  It would be
-    nice to have some cooperation from Elsewhere so that this isn't necessary,
-    otherwise some VOP writer will break the rules, resulting in code that is
-    nowhere.
-
-    The Debug-Info and related structures are dumped by consing up the
-    structure and making it be the value of a constant.
-
-    Getting the code vector and fixups dumped may be a bit more interesting.  I
-    guess we want a Dump-Code-Vector function which dumps the code and fixups
-    accumulated by the current assembly, returning a magic object that will
-    become the code vector when it is dumped as a constant.
-]
diff --git a/docs/internals/compiler-overview.tex b/docs/internals/compiler-overview.tex
deleted file mode 100644
index 74182cd550d07d7bc187912d94d722f0792c5a7a..0000000000000000000000000000000000000000
--- a/docs/internals/compiler-overview.tex
+++ /dev/null
@@ -1,540 +0,0 @@
-\chapter{Compiler Overview} % -*- Dictionary: design -*-
-
-The structure of the compiler may be broadly characterized by describing the
-compilation phases and the data structures that they manipulate.  The steps in
-the compilation are called phases rather than passes since they don't
-necessarily involve a full pass over the code.  The data structure used to
-represent the code at some point is called an {\it intermediate
-representation.}
-
-Two major intermediate representations are used in the compiler:
-\begin{itemize}
-
-\item The Implicit Continuation Representation (ICR) represents the lisp-level
-semantics of the source code during the initial phases.  Partial evaluation and
-semantic analysis are done on this representation.  ICR is roughly equivalent
-to a subset of Common Lisp, but is represented as a flow-graph rather than a
-syntax tree.  Phases which only manipulate ICR comprise the "front end".  It
-would be possible to use a different back end such as one that directly
-generated code for a stack machine.
-
-\item The Virtual Machine Representation (VMR) represents the implementation of
-the source code on a virtual machine.  The virtual machine may vary depending
-on the the target hardware, but VMR is sufficiently stylized that most of the
-phases which manipulate it are portable.
-\end{itemize}
-
-Each phase is briefly described here.  The phases from ``local call analysis''
-to ``constraint propagation'' all interact; for maximum optimization, they
-are generally repeated until nothing new is discovered.  The source files which
-primarily contain each phase are listed after ``Files: ''.
-\begin{description}
-
-\item[ICR conversion]
-Convert the source into ICR, doing macroexpansion and simple source-to-source
-transformation.  All names are resolved at this time, so we don't have to worry
-about name conflicts later on.  Files: {\tt ir1tran, srctran, typetran}
-
-\item[Local call analysis] Find calls to local functions and convert them to
-local calls to the correct entry point, doing keyword parsing, etc.  Recognize
-once-called functions as lets.  Create {\it external entry points} for
-entry-point functions.  Files: {\tt locall}
-
-\item[Find components]
-Find flow graph components and compute depth-first ordering.  Separate
-top-level code from run-time code, and determine which components are top-level
-components.  Files: {\tt dfo}
-
-\item[ICR optimize] A grab-bag of all the non-flow ICR optimizations.  Fold
-constant functions, propagate types and eliminate code that computes unused
-values.  Special-case calls to some known global functions by replacing them
-with a computed function.  Merge blocks and eliminate IF-IFs.  Substitute let
-variables.  Files: {\tt ir1opt, ir1tran, typetran, seqtran, vm/vm-tran}
-
-\item[Type constraint propagation]
-Use global flow analysis to propagate information about lexical variable
-types.   Eliminate unnecessary type checks and tests.  Files: {\tt constraint}
-
-\item[Type check generation]
-Emit explicit ICR code for any necessary type checks that are too complex to be
-easily generated on the fly by the back end.  Files: {\tt checkgen}
-
-\item[Event driven operations]
-Various parts of ICR are incrementally recomputed, either eagerly on
-modification of the ICR, or lazily, when the relevant information is needed.
-\begin{itemize}
-\item Check that type assertions are satisfied, marking places where type
-checks need to be done.
-
-\item Locate let calls.
-
-\item Delete functions and variables with no references
-\end{itemize}
-Files: {\tt ir1util}, {\tt ir1opt}
-
-\item[ICR finalize]
-This phase is run after all components have been compiled.  It scans the
-global variable references, looking for references to undefined variables
-and incompatible function redefinitions.  Files: {\tt ir1final}, {\tt main}.
-
-\item[Environment analysis]
-Determine which distinct environments need to be allocated, and what
-context needed to be closed over by each environment.  We detect non-local
-exits and set closure variables.  We also emit cleanup code as funny
-function calls.  This is the last pure ICR pass.  Files: {\tt envanal}
-
-\item[Global TN allocation (GTN)]
-Iterate over all defined functions, determining calling conventions
-and assigning TNs to local variables.  Files: {\tt gtn}
-
-\item[Local TN allocation (LTN)]
-Use type and policy information to determine which VMR translation to use
-for known functions, and then create TNs for expression evaluation
-temporaries.  We also accumulate some random information needed by VMR
-conversion.  Files: {\tt ltn}
-
-\item[Control analysis]
-Linearize the flow graph in a way that minimizes the number of branches.  The
-block-level structure of the flow graph is basically frozen at this point.
-Files: {\tt control}
-
-\item[Stack analysis]
-Maintain stack discipline for unknown-values continuation in the presence
-of local exits.  Files: {\tt stack}
-
-\item[Entry analysis]
-Collect some back-end information for each externally callable function.
-
-\item[VMR conversion] Convert ICR into VMR by translating nodes into VOPs.
-Emit type checks.  Files: {\tt ir2tran, vmdef}
-
-\item[Copy propagation] Use flow analysis to eliminate unnecessary copying of
-TN values.  Files: {\tt copyprop}
-
-\item[Representation selection]
-Look at all references to each TN to determine which representation has the
-lowest cost.  Emit appropriate move and coerce VOPS for that representation.
-
-\item[Lifetime analysis]
-Do flow analysis to find the set of TNs whose lifetimes 
-overlap with the lifetimes of each TN being packed.  Annotate call VOPs with
-the TNs that need to be saved.  Files: {\tt life}
-
-\item[Pack]
-Find a legal register allocation, attempting to minimize unnecessary moves.
-Files: {\tt pack}
-
-\item[Code generation]
-Call the VOP generators to emit assembly code.  Files: {\tt codegen}
-
-\item[Pipeline reorganization] On some machines, move memory references
-backward in the code so that they can overlap with computation.  On machines
-with delayed branch instructions, locate instructions that can be moved into
-delay slots.  Files: {\tt assem-opt}
-
-\item[Assembly]
-Resolve branches and convert in to object code and fixup information.
-Files: {\tt assembler}
-
-\item[Dumping] Convert the compiled code into an object file or in-core
-function.  Files: {\tt debug-dump}, {\tt dump}, {\tt vm/core}
-
-\end{description}
-
-\chapter{The Implicit Continuation Representation}
-
-The set of special forms recognized is exactly that specified in the Common
-Lisp manual.  Everything that is described as a macro in CLTL is a macro.
-
-Large amounts of syntactic information are thrown away by the conversion to an
-anonymous flow graph representation.  The elimination of names eliminates the
-need to represent most environment manipulation special forms.  The explicit
-representation of control eliminates the need to represent BLOCK and GO, and
-makes flow analysis easy.  The full Common Lisp LAMBDA is implemented with a
-simple fixed-arg lambda, which greatly simplifies later code.
-      
-The elimination of syntactic information eliminates the need for most of the
-"beta transformation" optimizations in Rabbit.  There are no progns, no
-tagbodys and no returns.  There are no "close parens" which get in the way of
-determining which node receives a given value.
-
-In ICR, computation is represented by Nodes.  These are the node types:
-\begin{description}
-\item[if]  Represents all conditionals.
-
-\item[set] Represents a {\tt setq}.
-
-\item[ref] Represents a constant or variable reference.
-
-\item[combination] Represents a normal function call.
-
-\item[MV-combination] Represents a {\tt multiple-value-call}.  This is used to
-implement all multiple value receiving forms except for {\tt
-multiple-value-prog1}, which is implicit.
-
-\item[bind]
-This represents the allocation and initialization of the variables in
-a lambda.
-
-\item[return]
-This collects the return value from a lambda and represents the
-control transfer on return.
-
-\item[entry] Marks the start of a dynamic extent that can have non-local exits
-to it.  Dynamic state can be saved at this point for restoration on re-entry.
-
-\item[exit] Marks a potentially non-local exit.  This node is interposed
-between the non-local uses of a continuation and the {\tt dest} so that code to
-do a non-local exit can be inserted if necessary.
-\end{description}
-
-Some slots are shared between all node types (via defstruct inheritance.)  This
-information held in common between all nodes often makes it possible to avoid
-special-casing nodes on the basis of type.  This shared information is
-primarily concerned with the order of evaluation and destinations and
-properties of results.  This control and value flow is indicated in the node
-primarily by pointing to continuations.
-
-The {\tt continuation} structure represents information sufficiently related
-to the normal notion of a continuation that naming it so seems sensible.
-Basically, a continuation represents a place in the code, or alternatively the
-destination of an expression result and a transfer of control.  These two
-notions are bound together for the same reasons that they are related in the
-standard functional continuation interpretation.
-
-A continuation may be deprived of either or both of its value or control
-significance.  If the value of a continuation is unused due to evaluation for
-effect, then the continuation will have a null {\tt dest}.  If the {\tt next}
-node for a continuation is deleted by some optimization, then {\tt next} will
-be {\tt :none}.
-
-  [\#\#\# Continuation kinds...]
-
-The {\tt block} structure represents a basic block, in the the normal sense.
-Control transfers other than simple sequencing are represented by information
-in the block structure.  The continuation for the last node in a block
-represents only the destination for the result.
-
-It is very difficult to reconstruct anything resembling the original source
-from ICR, so we record the original source form in each node.  The location of
-the source form within the input is also recorded, allowing for interfaces such
-as "Edit Compiler Warnings".  See section \ref{source-paths}.
-
-Forms such as special-bind and catch need to have cleanup code executed at all
-exit points from the form.  We represent this constraint in ICR by annotating
-the code syntactically within the form with a Cleanup structure describing what
-needs to be cleaned up.  Environment analysis determines the cleanup locations
-by watching for a change in the cleanup between two continuations.  We can't
-emit cleanup code during ICR conversion, since we don't know which exits will
-be local until after ICR optimizations are done.
-
-Special binding is represented by a call to the funny function %Special-Bind.
-The first argument is the Global-Var structure for the variable bound and the
-second argument is the value to bind it to.
-
-Some subprimitives are implemented using a macro-like mechanism for translating
-%PRIMITIVE forms into arbitrary lisp code.  Subprimitives special-cased by VMR
-conversion are represented by a call to the funny function %%Primitive.  The
-corresponding Template structure is passed as the first argument.
-
-We check global function calls for syntactic legality with respect to any
-defined function type function.  If the call is illegal or we are unable to
-tell if it is legal due to non-constant keywords, then we give a warning and
-mark the function reference as :notinline to force a full call and cause
-subsequent phases to ignore the call.  If the call is legal and is to a known
-function, then we annotate the Combination node with the Function-Info
-structure that contains the compiler information for the function.
-
-
-\section{Tail sets}
-\#|
-Probably want to have a GTN-like function result equivalence class mechanism
-for ICR type inference.  This would be like the return value propagation being
-done by Propagate-From-Calls, but more powerful, less hackish, and known to
-terminate.  The ICR equivalence classes could probably be used by GTN, as well.
-
-What we do is have local call analysis eagerly maintain the equivalence classes
-of functions that return the same way by annotating functions with a Tail-Info
-structure shared between all functions whose value could be the value of this
-function.  We don't require that the calls actually be tail-recursive, only
-that the call deliver its value to the result continuation.  [\#\#\# Actually
-now done by ICR-OPTIMIZE-RETURN, which is currently making ICR optimize
-mandatory.]
-
-We can then use the Tail-Set during ICR type inference.  It would have a type
-that is the union across all equivalent functions of the types of all the uses
-other than in local calls.  This type would be recomputed during optimization
-of return nodes.  When the type changes, we would propagate it to all calls to
-any of the equivalent functions.  How do we know when and how to recompute the
-type for a tail-set?  Recomputation is driven by type propagation on the result
-continuation.
-
-This is really special-casing of RETURN nodes.  The return node has the type
-which is the union of all the non-call uses of the result.  The tail-set is
-found though the lambda.  We can then recompute the overall union by taking the
-union of the type per return node, rather than per-use.
-
-
-How do result type assertions work?  We can't intersect the assertions across
-all functions in the equivalence class, since some of the call combinations may
-not happen (or even be possible).  We can intersect the assertion of the result
-with the derived types for non-call uses.
-
-When we do a tail call, we obviously can't check that the returned value
-matches our assertion.  Although in principle, we would like to be able to
-check all assertions, to preserve system integrity, we only need to check
-assertions that we depend on.  We can afford to lose some assertion information
-as long as we entirely lose it, ignoring it for type inference as well as for
-type checking.
-
-Things will work out, since the caller will see the tail-info type as the
-derived type for the call, and will emit a type check if it needs a stronger
-result.
-
-A remaining question is whether we should intersect the assertion with
-per-RETURN derived types from the very beginning (i.e. before the type check
-pass).  I think the answer is yes.  We delay the type check pass so that we can
-get our best guess for the derived type before we decide whether a check is
-necessary.  But with the function return type, we aren't committing to doing
-any type check when we intersect with the type assertion; the need to type
-check is still determined in the type check pass by examination of the result
-continuation.
-
-What is the relationship between the per-RETURN types and the types in the
-result continuation?  The assertion is exactly the Continuation-Asserted-Type
-(note that the asserted type of result continuations will never change after
-ICR conversion).  The per-RETURN derived type is different than the
-Continuation-Derived-Type, since it is intersected with the asserted type even
-before Type Check runs.  Ignoring the Continuation-Derived-Type probably makes
-life simpler anyway, since this breaks the potential circularity of the
-Tail-Info-Type will affecting the Continuation-Derived-Type, which affects...
-
-When a given return has no non-call uses, we represent this by using
-*empty-type*.  This consistent with the interpretation that a return type of
-NIL means the function can't return.
-
-
-\section{Hairy function representation}
-
-Non-fixed-arg functions are represented using Optional-Dispatch.  An
-Optional-Dispatch has an entry-point function for each legal number of
-optionals, and one for when extra args are present.  Each entry point function
-is a simple lambda.  The entry point function for an optional is passed the
-arguments which were actually supplied; the entry point function is expected to
-default any remaining parameters and evaluate the actual function body.
-
-If no supplied-p arg is present, then we can do this fairly easily by having
-each entry point supply its default and call the next entry point, with the
-last entry point containing the body.  If there are supplied-p args, then entry
-point function is replaced with a function that calls the original entry
-function with T's inserted at the position of all the supplied args with
-supplied-p parameters.
-
-We want to be a bit clever about how we handle arguments declared special when
-doing optional defaulting, or we will emit really gross code for special
-optionals.  If we bound the arg specially over the entire entry-point function,
-then the entry point function would be caused to be non-tail-recursive.  What
-we can do is only bind the variable specially around the evaluation of the
-default, and then read the special and store the final value of the special
-into a lexical variable which we then pass as the argument.  In the common case
-where the default is a constant, we don't have to special-bind at all, since
-the computation of the default is not affected by and cannot affect any special
-bindings.
-
-Keyword and rest args are both implemented using a LEXPR-like "more args"
-convention.  The More-Entry takes two arguments in addition to the fixed and
-optional arguments: the argument context and count.  (ARG <context> <n>)
-accesses the N'th additional argument.  Keyword args are implemented directly
-using this mechanism.  Rest args are created by calling %Listify-Rest-Args with
-the context and count.
-
-The More-Entry parses the keyword arguments and passes the values to the main
-function as positional arguments.  If a keyword default is not constant, then
-we pass a supplied-p parameter into the main entry and let it worry about
-defaulting the argument.  Since the main entry accepts keywords in parsed form,
-we can parse keywords at compile time for calls to known functions.  We keep
-around the original parsed lambda-list and related information so that people
-can figure out how to call the main entry.
-
-
-\section{ICR representation of non-local exits}
-
-All exits are initially represented by EXIT nodes:
-How about an Exit node:
-    (defstruct (exit (:include node))
-      value)
-The Exit node uses the continuation that is to receive the thrown Value.
-During optimization, if we discover that the Cont's home-lambda is the same is
-the exit node's, then we can delete the Exit node, substituting the Cont for
-all of the Value's uses.
-
-The successor block of an EXIT is the entry block in the entered environment.
-So we use the Exit node to mark the place where exit code is inserted.  During
-environment analysis, we need only insert a single block containing the entry
-point stub.
-
-We ensure that all Exits that aren't for a NLX don't have any Value, so that
-local exits never require any value massaging.
-
-The Entry node marks the beginning of a block or tagbody:
-    (defstruct (entry (:include node))
-      (continuations nil :type list)) 
-
-It contains a list of all the continuations that the body could exit to.  The
-Entry node is used as a marker for the the place to snapshot state, including
-the control stack pointer.  Each lambda has a list of its Entries so
-that environment analysis can figure out which continuations are really being
-closed over.  There is no reason for optimization to delete Entry nodes,
-since they are harmless in the degenerate case: we just emit no code (like a
-no-var let).
-
-
-We represent CATCH using the lexical exit mechanism.  We do a transformation
-like this:
-   (catch 'foo xxx)  ==>
-   (block \#:foo
-     (%catch \#'(lambda () (return-from \#:foo (%unknown-values))) 'foo)
-     (%within-cleanup :catch
-       xxx))
-
-%CATCH just sets up the catch frame which points to the exit function.  %Catch
-is an ordinary function as far as ICR is concerned.  The fact that the catcher
-needs to be cleaned up is expressed by the Cleanup slots in the continuations
-in the body.  %UNKNOWN-VALUES is a dummy function call which represents the
-fact that we don't know what values will be thrown.  
-
-%WITHIN-CLEANUP is a special special form that instantiates its first argument
-as the current cleanup when converting the body.  In reality, the lambda is
-also created by the special special form %ESCAPE-FUNCTION, which gives the
-lambda a special :ESCAPE kind so that the back end knows not to generate any
-code for it.
-
-
-We use a similar hack in Unwind-Protect to represent the fact that the cleanup
-forms can be invoked at arbitrarily random times.
-    (unwind-protect p c)  ==>
-    (flet ((\#:cleanup () c))
-      (block \#:return
-	(multiple-value-bind
-	    (\#:next \#:start \#:count)
-	    (block \#:unwind
-	      (%unwind-protect \#'(lambda (x) (return-from \#:unwind x)))
-	      (%within-cleanup :unwind-protect
-		(return-from \#:return p)))
-	  (\#:cleanup)
-	  (%continue-unwind \#:next \#:start \#:count))))
-
-We use the block \#:unwind to represent the entry to cleanup code in the case
-where we are non-locally unwound.  Calling of the cleanup function in the
-drop-through case (or any local exit) is handled by cleanup generation.  We
-make the cleanup a function so that cleanup generation can add calls at local
-exits from the protected form.  \#:next, \#:start and \#:count are state used in
-the case where we are unwound.  They indicate where to go after doing the
-cleanup and what values are being thrown.  The cleanup encloses only the
-protected form.  As in CATCH, the escape function is specially tagged as
-:ESCAPE.  The cleanup function is tagged as :CLEANUP to inhibit let conversion
-(since references are added in environment analysis.)
-
-Notice that implementing these forms using closures over continuations
-eliminates any need to special-case ICR flow analysis.  Obviously we don't
-really want to make heap-closures here.  In reality these functions are
-special-cased by the back-end according to their KIND.
-
-
-\section{Block compilation}
-
-One of the properties of ICR is that supports "block compilation" by allowing
-arbitrarily large amounts of code to be converted at once, with actual
-compilation of the code being done at will.
-
-
-In order to preserve the normal semantics we must recognize that proclamations
-(possibly implicit) are scoped.  A proclamation is in effect only from the time
-of appearance of the proclamation to the time it is contradicted.  The current
-global environment at the end of a block is not necessarily the correct global
-environment for compilation of all the code within the block.  We solve this
-problem by closing over the relevant information in the ICR at the time it is
-converted.  For example, each functional variable reference is marked as
-inline, notinline or don't care.  Similarly, each node contains a structure
-known as a Cookie which contains the appropriate settings of the compiler
-policy switches.
-
-We actually convert each form in the file separately, creating a separate
-"initial component" for each one.  Later on, these components are merged as
-needed.  The main reason for doing this is to cause EVAL-WHEN processing to be
-interleaved with reading. 
-
-
-\section{Entry points}
-
-\#|
-
-Since we need to evaluate potentially arbitrary code in the XEP argument forms
-(for type checking), we can't leave the arguments in the wired passing
-locations.  Instead, it seems better to give the XEP max-args fixed arguments,
-with the passing locations being the true passing locations.  Instead of using
-%XEP-ARG, we reference the appropriate variable.
-
-Also, it might be a good idea to do argument count checking and dispatching
-with explicit conditional code in the XEP.  This would simplify both the code
-that creates the XEP and the VMR conversion of XEPs.  Also, argument count
-dispatching would automatically benefit from any cleverness in compilation of
-case-like forms (jump tables, etc).  On the downside, this would push some
-assumptions about how arg dispatching is done into ICR.  But then we are
-currently violating abstraction at least as badly in VMR conversion, which is
-also supposed to be implementation independent.
-|\#
-
-As a side-effect of finding which references to known functions can be
-converted to local calls, we find any references that cannot be converted.
-References that cannot be converted to a local call must evaluate to a
-"function object" (or function-entry) that can be called using the full call
-convention.  A function that can be called from outside the component is called
-an "entry-point".
-
-Lots of stuff that happens at compile-time with local function calls must be
-done at run-time when an entry-point is called.
-
-It is desirable for optimization and other purposes if all the calls to every
-function were directly present in ICR as local calls.  We cannot directly do
-this with entry-point functions, since we don't know where and how the
-entry-point will be called until run-time.
-
-What we do is represent all the calls possible from outside the component by
-local calls within the component.  For each entry-point function, we create a
-corresponding lambda called the external entry point or XEP.  This is a
-function which takes the number of arguments passed as the first argument,
-followed by arguments corresponding to each required or optional argument.
-
-If an optional argument is unsupplied, the value passed into the XEP is
-undefined.  The XEP is responsible for doing argument count checking and
-dispatching.  
-
-In the case of a fixed-arg lambda, we emit a call to the %VERIFY-ARGUMENT-COUNT
-funny function (conditional on policy), then call the real function on the
-passed arguments.  Even in this simple case, we benefit several ways from
-having a separate XEP:
- -- The argument count checking is factored out, and only needs to be done in
-    full calls.
- -- Argument type checking happens automatically as a consequence of passing
-    the XEP arguments in a local call to the real function.  This type checking
-    is also only done in full calls.
- -- The real function may use a non-standard calling convention for the benefit
-    of recursive or block-compiled calls.  The XEP converts arguments/return
-    values to/from the standard convention.  This also requires little
-    special-casing of XEPs.
-
-If the function has variable argument count (represented by an
-OPTIONAL-DISPATCH), then the XEP contains a COND which dispatches off of the
-argument count, calling the appropriate entry-point function (which then does
-defaulting).  If there is a more entry (for keyword or rest args), then the XEP
-obtains the more arg context and count by calling the %MORE-ARG-CONTEXT funny
-function.
-
-All non-local-call references to functions are replaced with references to the
-corresponding XEP.  ICR optimization may discover a local call that was
-previously a non-local reference.  When we delete the reference to the XEP, we
-may find that it has no references.  In this case, we can delete the XEP,
-causing the function to no longer be an entry-point.
-
-
\ No newline at end of file
diff --git a/docs/internals/compiler.tex b/docs/internals/compiler.tex
deleted file mode 100644
index 4f8372a52ee4ba4e77fc442c7bd441efb1cb0d9f..0000000000000000000000000000000000000000
--- a/docs/internals/compiler.tex
+++ /dev/null
@@ -1,6 +0,0 @@
-\part{Compiler Organization}
-\include{compiler-overview}
-\include{front}
-\include{middle}
-\include{back}
-\include{interface}
diff --git a/docs/internals/debugger.tex b/docs/internals/debugger.tex
deleted file mode 100644
index baeeaa46edf2c4e1d948ba1f3e11988c9fbc3718..0000000000000000000000000000000000000000
--- a/docs/internals/debugger.tex
+++ /dev/null
@@ -1,537 +0,0 @@
-%  					-*- Dictionary: design; Package: C -*-
-
-\#|
-\chapter{Debugger Information}
-\index{debugger information}
-\label{debug-info}
-
-Although the compiler's great freedom in choice of function call conventions
-and variable representations has major efficiency advantages, it also has
-unfortunate consequences for the debugger.  The debug information that we need
-is even more elaborate than for conventional "compiled" languages, since we
-cannot even do a simple backtrace without some debug information.  However,
-once having gone this far, it is not that difficult to go the extra distance,
-and provide full source level debugging of compiled code.
-
-Full debug information has a substantial space penalty, so we allow different
-levels of debug information to be specified.  In the extreme case, we can
-totally omit debug information.
-
-
-\section{The Debug-Info Structure}
-\index{debug-info structure}
-
-The Debug-Info structure directly represents information about the
-source code, and points to other structures that describe the layout of
-run-time data structures.
-
-
-Make some sort of minimal debug-info format that would support at least the
-common cases of level 1 (since that is what we would release), and perhaps
-level 0.  Actually, it seems it wouldn't be hard to crunch nearly all of the
-debug-function structure and debug-info function map into a single byte-vector.
-We could have an uncrunch function that restored the current format.  This
-would be used by the debugger, and also could be used by purify to delete parts
-of the debug-info even when the compiler dumps it in crunched form.
-[Note that this isn't terribly important if purify is smart about
-debug-info...]
-|\#
-
-
-Compiled source map representation:
-
-[\#\#\# store in debug-function PC at which env is properly initialized, i.e.
-args (and return-pc, etc.) in internal locations.  This is where a
-:function-start breakpoint would break.]
-
-[\#\#\# Note that that we can easily cache the form-number => source-path or
-form-number => form translation using a vector indexed by form numbers that we
-build during a walk.]
-
-
-
-
-Instead of using source paths in the debug-info, use "form numbers".  The form
-number of a form is the number of forms that we walk to reach that form when
-doing a pre-order walk of the source form.  [Might want to use a post-order
-walk, as that would more closely approximate evaluation order.]
-
-
-We probably want to continue using source-paths in the compiler, since they are
-quick to compute and to get you to a particular form.  [\#\#\# But actually, I
-guess we don't have to precompute the source paths and annotate nodes with
-them: instead we could annotate the nodes with the actual original source form.
-Then if we wanted to find the location of that form, we could walk the root
-source form, looking that original form.  But we might still need to enter all
-the forms in a hashtable so that we can tell during IR1 conversion that a given
-form appeared in the original source.]
-
-
-Note that form numbers have an interesting property: it is quite efficient to
-determine whether an arbitrary form is a subform of some other form, since the
-form number of B will be > than A's number and < A's next sibling's number iff
-B is a subform of A.  
-
-This should be quite useful for doing the source=>pc mapping in the debugger,
-since that problem reduces to finding the subset of the known locations that
-are for subforms of the specified form.
-
-
-Assume a byte vector with a standard variable-length integer format, something
-like this:
-    0..253 => the integer
-    254 => read next two bytes for integer
-    255 => read next four bytes for integer
-
-Then a compiled debug block is just a sequence of variable-length integers in a
-particular order, something like this:
-    number of successors
-    ...offsets of each successor in the function's blocks vector...
-    first PC
-    [offset of first top-level form (in forms) (only if not component default)]
-    form number of first source form
-    first live mask (length in bytes determined by number of VARIABLES)
-    ...more <PC, top-level form offset, form-number, live-set> tuples...
-
-We determine the number of locations recorded in a block by the finding the
-start of the next compiled debug block in the blocks vector.
-
-[\#\#\# Actually, only need 2 bits for number of successors {0,1,2}.  We might
-want to use other bits in the first byte to indicate the kind of location.]
-[\#\#\# We could support local packing by having a general concept of "alternate
-locations" instead of just regular and save locations.  The location would have
-a bit indicating that there are alternate locations, in which case we read the
-number of alternate locations and then that many more SC-OFFSETs.  In the
-debug-block, we would have a second bit mask with bits set for TNs that are in
-an alternate location.  We then read a number for each such TN, with the value
-being interpreted as an index into the Location's alternate locations.]
-
-
-
-It looks like using structures for the compiled-location-info is too bulky.
-Instead we need some packed binary representation.
-
-First, let's represent a SC/offset pair with an "SC-Offset", which is an
-integer with the SC in the low 5 bits and the offset in the remaining bits:
-    ----------------------------------------------------
-    | Offset (as many bits as necessary) | SC (5 bits) |
-    ----------------------------------------------------
-Probably the result should be constrained to fit in a fixnum, since it will be
-more efficient and gives more than enough possible offsets.
-
-We can the represent a compiled location like this:
-    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)]
-
-
-
-
-But for a whizzy breakpoint facility, we would need a good source=>code map.
-Dumping a complete code=>source map might be as good a way as any to represent
-this, due to the one-to-many relationship between source and code locations.
-
-We might be able to get away with just storing the source locations for the
-beginnings of blocks and maintaining a mapping from code ranges to blocks.
-This would be fine both for the profiler and for the "where am I running now"
-indication.  Users might also be convinced that it was most interesting to
-break at block starts, but I don't really know how easily people could develop
-an understanding of basic blocks.
-
-It could also be a bit tricky to map an arbitrary user-designated source
-location to some "closest" source location actually in the debug info.
-This problem probably exists to some degree even with a full source map, since
-some forms will never appear as the source of any node.  It seems you might
-have to negotiate with the user.  He would mouse something, and then you would
-highlight some source form that has a common prefix (i.e. is a prefix of the
-user path, or vice-versa.)  If they aren't happy with the result, they could
-try something else.  In some cases, the designated path might be a prefix of
-several paths.  This ambiguity might be resolved by picking the shortest path
-or letting the user choose.
-
-At the primitive level, I guess what this means is that the structure of source
-locations (i.e. source paths) must be known, and the source=>code operation
-should return a list of <source,code> pairs, rather than just a list of code
-locations.  This allows the debugger to resolve the ambiguity however it wants.
-
-I guess the formal definition of which source paths we would return is:
-    All source paths in the debug info that have a maximal common prefix with
-    the specified path.  i.e. if several paths have the complete specified path
-    as a prefix, we return them all.  Otherwise, all paths with an equally
-    large common prefix are returned: if the path with the most in common
-    matches only the first three elements, then we return all paths that match
-    in the first three elements.  As a degenerate case (which probably
-    shouldn't happen), if there is no path with anything in common, then we
-    return *all* of the paths.
-
-
-
-In the DEBUG-SOURCE structure we may ultimately want a vector of the start
-positions of each source form, since that would make it easier for the debugger
-to locate the source.  It could just open the file, FILE-POSITION to the form,
-do a READ, then loop down the source path.  Of course, it could read each form
-starting from the beginning, but that might be too slow.
-
-
-Do XEPs really need Debug-Functions?  The only time that we will commonly end
-up in the debugger on an XEP is when an argument type check fails.  But I
-suppose it would be nice to be able to print the arguments passed...
-
-
-Note that assembler-level code motion such as pipeline reorganization can cause
-problems with our PC maps.  The assembler needs to know that debug info markers
-are different from real labels anyway, so I suppose it could inhibit motion
-across debug markers conditional on policy.  It seems unworthwhile to remember
-the node for each individual instruction.
-
-
-For tracing block-compiled calls:
-    Info about return value passing locations?
-    Info about where all the returns are?
-
-We definitely need the return-value passing locations for debug-return.  The
-question is what the interface should be.  We don't really want to have a
-visible debug-function-return-locations operation, since there are various
-value passing conventions, and we want to paper over the differences.
-
-
-Probably should be a compiler option to initialize stack frame to a special
-uninitialized object (some random immediate type).  This would aid debugging,
-and would also help GC problems.  For the latter reason especially, this should
-be locally-turn-onable (off of policy?  the new debug-info quality?).
-
-
-What about the interface between the evaluator and the debugger? (i.e. what
-happens on an error, etc.)  Compiler error handling should be integrated with
-run-time error handling.  Ideally the error messages should look the same.
-Practically, in some cases the run-time errors will have less information.  But
-the error should look the same to the debugger (or at least similar).
-
-
-
-;;;; Debugger interface:
-
-How does the debugger interface to the "evaluator" (where the evaluator means
-all of native code, byte-code and interpreted IR1)?  It seems that it would be
-much more straightforward to have a consistent user interface to debugging
-all code representations if there was a uniform debugger interface to the
-underlying stuff, and vice-versa.  
-
-Of course, some operations might not be supported by some representations, etc.
-For example, fine-control stepping might not be available in native code.
-In other cases, we might reduce an operation to the lowest common denominator,
-for example fetching lexical variables by string and admitting the possibility
-of ambiguous matches.  [Actually, it would probably be a good idea to store the
-package if we are going to allow variables to be closed over.]
-
-Some objects we would need:
-Location:
-	The constant information about the place where a value is stored,
-        everything but which particular frame it is in.  Operations:
-        location name, type, etc.
-        location-value frame location (setf'able)
-	monitor-location location function
-            Function is called whenever location is set with the location,
-            frame and old value.  If active values aren't supported, then we
-            dummy the effect using breakpoints, in which case the change won't
-            be noticed until the end of the block (and intermediate changes
-            will be lost.)
-debug info:
-        All the debug information for a component.
-Frame:
-	frame-changed-locations frame => location*
-            Return a list of the locations in frame that were changed since the
-            last time this function was called.  Or something.  This is for
-            displaying interesting state changes at breakpoints.
-	save-frame-state frame => frame-state
-	restore-frame-state frame frame-state
-	    These operations allow the debugger to back up evaluation, modulo
-	    side-effects and non-local control transfers.  This copies and
-	    restores all variables, temporaries, etc, local to the frame, and
-	    also the current PC and dynamic environment (current catch, etc.)
-
-	    At the time of the save, the frame must be for the running function
-	    (not waiting for a call to return.)  When we restore, the frame
-	    becomes current again, effectively exiting from any frames on top.
-	    (Of course, frame must not already be exited.)
-       
-Thread:
-        Representation of which stack to use, etc.
-Block:
-        What successors the block has, what calls there are in the block.
-        (Don't need to know where calls are as long as we know called function,
-        since can breakpoint at the function.)  Whether code in this block is
-        wildly out of order due to being the result of loop-invariant
-        optimization, etc.  Operations:
-        block-successors block => code-location*
-        block-forms block => (source-location code-location)*
-            Return the corresponding source locations and code locations for
-            all forms (and form fragments) in the block.
-
-
-Variable maps:
-
-There are about five things that the debugger might want to know about a
-variable:
-
-    Name
-	Although a lexical variable's name is "really" a symbol (package and
-	all), in practice it doesn't seem worthwhile to require all the symbols
-	for local variable names to be retained.  There is much less VM and GC
-	overhead for a constant string than for a symbol.  (Also it is useful
-	to be able to access gensyms in the debugger, even though they are
-	theoretically ineffable).
-
-    ID
-	Which variable with the specified name is this?  It is possible to have
-	multiple variables with the same name in a given function.  The ID is
-	something that makes Name unique, probably a small integer.  When
-	variables aren't unique, we could make this be part of the name, e.g.
-	"FOO\#1", "FOO\#2".  But there are advantages to keeping this separate,
-	since in many cases lifetime information can be used to disambiguate,
-	making qualification unnecessary.
-
-    SC
-	When unboxed representations are in use, we must have type information
-	to properly read and write a location.  We only need to know the
-	SC for this, which would be amenable to a space-saving
-	numeric encoding.
-
-    Location
-	Simple: the offset in SC.  [Actually, we need the save location too.]
-
-    Lifetime
-	In what parts of the program does this variable hold a meaningful
-	value?  It seems prohibitive to record precise lifetime information,
-	both in space and compiler effort, so we will have to settle for some
-	sort of approximation.
-
-	The finest granularity at which it is easy to determine liveness is the
-	the block: we can regard the variable lifetime as the set of blocks
-	that the variable is live in.  Of course, the variable may be dead (and
-	thus contain meaningless garbage) during arbitrarily large portions of
-	the block.
-
-	Note that this subsumes the notion of which function a variable belongs
-	to.  A given block is only in one function, so the function is
-	implicit.
-
-
-The variable map should represent this information space-efficiently and with
-adequate computational efficiency.
-
-The SC and ID can be represented as small integers.  Although the ID can in
-principle be arbitrarily large, it should be <100 in practice.  The location
-can be represented by just the offset (a moderately small integer), since the
-SB is implicit in the SC.
-
-The lifetime info can be represented either as a bit-vector indexed by block
-numbers, or by a list of block numbers.  Which is more compact depends both on
-the size of the component and on the number of blocks the variable is live in.
-In the limit of large component size, the sparse representation will be more
-compact, but it isn't clear where this crossover occurs.  Of course, it would
-be possible to use both representations, choosing the more compact one on a
-per-variable basis.  Another interesting special case is when the variable is
-live in only one block: this may be common enough to be worth picking off,
-although it is probably rarer for named variables than for TNs in general.
-
-If we dump the type, then a normal list-style type descriptor is fine: the
-space overhead is small, since the shareability is high.
-
-We could probably save some space by cleverly representing the var-info as
-parallel vectors of different types, but this would be more painful in use.
-It seems better to just use a structure, encoding the unboxed fields in a
-fixnum.  This way, we can pass around the structure in the debugger, perhaps
-even exporting it from the the low-level debugger interface.
-
-[\#\#\# We need the save location too.  This probably means that we need two slots
-of bits, since we need the save offset and save SC.  Actually, we could let the
-save SC be implied by the normal SC, since at least currently, we always choose
-the same save SC for a given SC.  But even so, we probably can't fit all that
-stuff in one fixnum without squeezing a lot, so we might as well split and
-record both SCs.
-
-In a localized packing scheme, we would have to dump a different var-info
-whenever either the main location or the save location changes.  As a practical
-matter, the save location is less likely to change than the main location, and
-should never change without the main location changing.
-
-One can conceive of localized packing schemes that do saving as a special case
-of localized packing.  If we did this, then the concept of a save location
-might be eliminated, but this would require major changes in the IR2
-representation for call and/or lifetime info.  Probably we will want saving to
-continue to be somewhat magical.]
-
-
-How about:
-
-(defstruct var-info
-  ;;
-  ;; This variable's name. (symbol-name of the symbol)
-  (name nil :type simple-string)
-  ;;
-  ;; The SC, ID and offset, encoded as bit-fields.
-  (bits nil :type fixnum)
-  ;;
-  ;; The set of blocks this variable is live in.  If a bit-vector, then it has
-  ;; a 1 when indexed by the number of a block that it is live in.  If an
-  ;; I-vector, then it lists the live block numbers.  If a fixnum, then that is
-  ;; the number of the sole live block.
-  (lifetime nil :type (or vector fixnum))
-  ;;
-  ;; The variable's type, represented as list-style type descriptor.
-  type)
-
-Then the debug-info holds a simple-vector of all the var-info structures for
-that component.  We might as well make it sorted alphabetically by name, so
-that we can binary-search to find the variable corresponding to a particular
-name.
-
-We need to be able to translate PCs to block numbers.  This can be done by an
-I-Vector in the component that contains the start location of each block.  The
-block number is the index at which we find the correct PC range.  This requires
-that we use an emit-order block numbering distinct from the IR2-Block-Number,
-but that isn't any big deal.  This seems space-expensive, but it isn't too bad,
-since it would only be a fraction of the code size if the average block length
-is a few words or more.
-
-An advantage of our per-block lifetime representation is that it directly
-supports keeping a variable in different locations when in different blocks,
-i.e. multi-location packing.  We use a different var-info for each different
-packing, since the SC and offset are potentially different.  The Name and ID
-are the same, representing the fact that it is the same variable.  It is here
-that the ID is most significant, since the debugger could otherwise make
-same-name variables unique all by itself.
-
-
-
-Stack parsing:
-
-[\#\#\# Probably not worth trying to make the stack parseable from the bottom up.
-There are too many complications when we start having variable sized stuff on
-the stack.  It seems more profitable to work on making top-down parsing robust.
-Since we are now planning to wire the bottom-up linkage info, scanning from the
-bottom to find the top frame shouldn't be too inefficient, even when there was
-a runaway recursion.  If we somehow jump into hyperspace, then the debugger may
-get confused, but we can debug this sort of low-level system lossage using
-ADB.]
-
-
-There are currently three relevant context pointers:
-  -- The PC.  The current PC is wired (implicit in the machine).  A saved
-     PC (RETURN-PC) may be anywhere in the current frame.
-  -- The current stack context (CONT).  The current CONT is wired.  A saved
-     CONT (OLD-CONT) may be anywhere in the current frame.
-  -- The current code object (ENV).  The current ENV is wired.  When saved,
-     this is extra-difficult to locate, since it is saved by the caller, and is
-     thus at an unknown offset in OLD-CONT, rather than anywhere in the current
-     frame.
-
-We must have all of these to parse the stack.
-
-With the proposed Debug-Function, we parse the stack (starting at the top) like
-this:
- 1] Use ENV to locate the current Debug-Info
- 2] Use the Debug-Info and PC to determine the current Debug-Function.
- 3] Use the Debug-Function to find the OLD-CONT and RETURN-PC.
- 4] Find the old ENV by searching up the stack for a saved code object
-    containing the RETURN-PC.
- 5] Assign old ENV to ENV, OLD-CONT to CONT, RETURN-PC to PC and goto 1.
-
-If we changed the function representation so that the code and environment were
-a single object, then the location of the old ENV would be simplified.  But we
-still need to represent ENV as separate from PC, since interrupts and errors
-can happen when the current PC isn't positioned at a valid return PC.
-
-It seems like it might be a good idea to save OLD-CONT, RETURN-PC and ENV at
-the beginning of the frame (before any stack arguments).  Then we wouldn't have
-to search to locate ENV, and we also have a hope of parsing the stack even if
-it is damaged.  As long as we can locate the start of some frame, we can trace
-the stack above that frame.  We can recognize a probable frame start by
-scanning the stack for a code object (presumably a saved ENV).
-
- Probably we want some fairly general
-mechanism for specifying that a TN should be considered to be live for the
-duration of a specified environment.  It would be somewhat easier to specify
-that the TN is live for all time, but this would become very space-inefficient
-in large block compilations.
-
-This mechanism could be quite useful for other debugger-related things.  For
-example, when debuggability is important, we could make the TNs holding
-arguments live for the entire environment.  This would guarantee that a
-backtrace would always get the right value (modulo setqs).  
-
-Note that in this context, "environment" means the Environment structure (one
-per non-let function).  At least according to current plans, even when we do
-inter-routine register allocation, the different functions will have different
-environments: we just "equate" the environments.  So the number of live
-per-environment TNs is bounded by the size of a "function", and doesn't blow up
-in block compilation.
-
-The implementation is simple: per-environment TNs are flagged by the
-:Environment kind.  :Environment TNs are treated the same as :Normal TNs by
-everyone except for lifetime/conflict analysis.  An environment's TNs are also
-stashed in a list in the IR2-Environment structure.  During during the conflict
-analysis post-pass, we look at each block's environment, and make all the
-environment's TNs always-live in that block.
-
-We can implement the "fixed save location" concept needed for lazy frame
-creation by allocating the save TNs as wired TNs at IR2 conversion time.  We
-would use the new "environment lifetime" concept to specify the lifetimes of
-the save locations.  There isn't any run-time overhead if we never get around
-to using the save TNs.  [Pack would also have to notice TNs with pre-allocated
-save TNs, packing the original TN in the stack location if its FSC is the
-stack.]
-
-
-We want a standard (recognizable) format for an "escape" frame.  We must make
-an escape frame whenever we start running another function without the current
-function getting a chance to save its registers.  This may be due either to a
-truly asynchronous event such as a software interrupt, or due to an "escape"
-from a miscop.  An escape frame marks a brief conversion to a callee-saves
-convention.
-
-Whenever a miscop saves registers, it should make an escape frame.  This
-ensures that the "current" register contents can always be located by the
-debugger.  In this case, it may be desirable to be able to indicate that only
-partial saving has been done.  For example, we don't want to have to save all
-the FP registers just so that we can use a couple extra general registers.
-
-When when the debugger see an escape frame, it knows that register values are
-located in the escape frame's "register save" area, rather than in the normal
-save locations.
-
-It would be nice if there was a better solution to this internal error concept.
-One problem is that it seems there is a substantial space penalty for emitting
-all that error code, especially now that we don't share error code between
-errors because we want to preserve the source context in the PC.  But this
-probably isn't really all that bad when considered as a fraction of the code.
-For example, the check part of a type check is 12 bytes, whereas the error part
-is usually only 6.  In this case, we could never reduce the space overhead for
-type checks by more than 1/3, thus the total code size reduction would be
-small.  This will be made even less important when we do type check
-optimizations to reduce the number of type checks.
-
-Probably we should stick to the same general internal error mechanism, but make
-it interact with the debugger better by allocating linkage registers and
-allowing proceedable errors.  We could support shared error calls and
-non-proceedable errors when space is more important than debuggability, but
-this is probably more complexity than is worthwhile.
-
-We jump or trap to a routine that saves the context (allocating at most the
-return PC register).  We then encode the error and context in the code
-immediately following the jump/trap.  (On the MIPS, the error code can be
-encoded in the trap itself.)  The error arguments would be encoded as
-SC-offsets relative to the saved context.  This could solve both the
-arg-trashing problem and save space, since we could encode the SC-offsets more
-tersely than the corresponding move instructions.
diff --git a/docs/internals/design.tex b/docs/internals/design.tex
deleted file mode 100644
index 114d7d993ff83144f5704afdd42a7fa48a07d37d..0000000000000000000000000000000000000000
--- a/docs/internals/design.tex
+++ /dev/null
@@ -1,18 +0,0 @@
-\documentstyle[cmu-titlepage]{report} % -*- Dictionary: design -*-
-\title{Design of CMU Common Lisp}
-\author{Robert A. MacLachlan (ed)}
-\trnumber{CMU-CS-91-???}
-\abstract{This report documents internal details of the CMU Common Lisp
-compiler and run-time system.  CMU Common Lisp is a public domain
-implementation of Common Lisp that runs on various Unix workstations.}
-
-\begin{document}
-\maketitle
-\tableofcontents
-\include{architecture}
-\include{compiler}
-\include{retargeting}
-\include{run-time}
-\appendix
-\include{glossary}
-\end{document}
diff --git a/docs/internals/environment.tex b/docs/internals/environment.tex
deleted file mode 100644
index e46f48f8ee791fc9df5e5b3086065c998380330d..0000000000000000000000000000000000000000
--- a/docs/internals/environment.tex
+++ /dev/null
@@ -1,3 +0,0 @@
-\chapter{The Type System}
-
-\chapter{The Info Database}
diff --git a/docs/internals/fasl.tex b/docs/internals/fasl.tex
deleted file mode 100644
index b0ad30512c849dd9a53fdef27cf40a7f6b47bc58..0000000000000000000000000000000000000000
--- a/docs/internals/fasl.tex
+++ /dev/null
@@ -1,584 +0,0 @@
-\chapter{Fasload File Format}% -*- Dictionary: design -*-
-\section{General}
-
-The purpose of Fasload files is to allow concise storage and rapid
-loading of Lisp data, particularly function definitions.  The intent
-is that loading a Fasload file has the same effect as loading the
-ASCII file from which the Fasload file was compiled, but accomplishes
-the tasks more efficiently.  One noticeable difference, of course, is
-that function definitions may be in compiled form rather than
-S-expression form.  Another is that Fasload files may specify in what
-parts of memory the Lisp data should be allocated.  For example,
-constant lists used by compiled code may be regarded as read-only.
-
-In some Lisp implementations, Fasload file formats are designed to
-allow sharing of code parts of the file, possibly by direct mapping
-of pages of the file into the address space of a process.  This
-technique produces great performance improvements in a paged
-time-sharing system.  Since the Mach project is to produce a
-distributed personal-computer network system rather than a
-time-sharing system, efficiencies of this type are explicitly {\it not}
-a goal for the CMU Common Lisp Fasload file format.
-
-On the other hand, CMU Common Lisp is intended to be portable, as it will
-eventually run on a variety of machines.  Therefore an explicit goal
-is that Fasload files shall be transportable among various
-implementations, to permit efficient distribution of programs in
-compiled form.  The representations of data objects in Fasload files
-shall be relatively independent of such considerations as word
-length, number of type bits, and so on.  If two implementations
-interpret the same macrocode (compiled code format), then Fasload
-files should be completely compatible.  If they do not, then files
-not containing compiled code (so-called "Fasdump" data files) should
-still be compatible.  While this may lead to a format which is not
-maximally efficient for a particular implementation, the sacrifice of
-a small amount of performance is deemed a worthwhile price to pay to
-achieve portability.
-
-The primary assumption about data format compatibility is that all
-implementations can support I/O on finite streams of eight-bit bytes.
-By "finite" we mean that a definite end-of-file point can be detected
-irrespective of the content of the data stream.  A Fasload file will
-be regarded as such a byte stream.
-
-\section{Strategy}
-
-A Fasload file may be regarded as a human-readable prefix followed by
-code in a funny little language.  When interpreted, this code will
-cause the construction of the encoded data structures.  The virtual
-machine which interprets this code has a {\it stack} and a {\it table},
-both initially empty.  The table may be thought of as an expandable
-register file; it is used to remember quantities which are needed
-more than once.  The elements of both the stack and the table are
-Lisp data objects.  Operators of the funny language may take as
-operands following bytes of the data stream, or items popped from the
-stack.  Results may be pushed back onto the stack or pushed onto the
-table.  The table is an indexable stack that is never popped; it is
-indexed relative to the base, not the top, so that an item once
-pushed always has the same index.
-
-More precisely, a Fasload file has the following macroscopic
-organization.  It is a sequence of zero or more groups concatenated
-together.  End-of-file must occur at the end of the last group.  Each
-group begins with a series of seven-bit ASCII characters terminated
-by one or more bytes of all ones \verb|#xFF|; this is called the
-{\it header}.  Following the bytes which terminate the header is the
-{\it body}, a stream of bytes in the funny binary language.  The body
-of necessity begins with a byte other than \verb|#xFF|.  The body is
-terminated by the operation {\tt FOP-END-GROUP}.
-
-The first nine characters of the header must be "{\tt FASL FILE}" in
-upper-case letters.  The rest may be any ASCII text, but by
-convention it is formatted in a certain way.  The header is divided
-into lines, which are grouped into paragraphs.  A paragraph begins
-with a line which does {\it not} begin with a space or tab character,
-and contains all lines up to, but not including, the next such line.
-The first word of a paragraph, defined to be all characters up to but
-not including the first space, tab, or end-of-line character, is the
-{\it name} of the paragraph.  A Fasload file header might look something like
-this:
-\begin{verbatim}
-FASL FILE >SteelesPerq>User>Guy>IoHacks>Pretty-Print.Slisp
-Package Pretty-Print
-Compiled 31-Mar-1988 09:01:32 by some random luser
-Compiler Version 1.6, Lisp Version 3.0.
-Functions: INITIALIZE DRIVER HACK HACK1 MUNGE MUNGE1 GAZORCH
-	   MINGLE MUDDLE PERTURB OVERDRIVE GOBBLE-KEYBOARD
-	   FRY-USER DROP-DEAD HELP CLEAR-MICROCODE
-	    %AOS-TRIANGLE %HARASS-READTABLE-MAYBE
-Macros:    PUSH POP FROB TWIDDLE
-\end{verbatim}
-{\it one or more bytes of \verb|#xFF|}
-
-The particular paragraph names and contents shown here are only intended as
-suggestions.
-
-\section{Fasload Language}
-
-Each operation in the binary Fasload language is an eight-bit
-(one-byte) opcode.  Each has a name beginning with "{\tt FOP-}".  In	
-the following descriptions, the name is followed by operand
-descriptors.  Each descriptor denotes operands that follow the opcode
-in the input stream.  A quantity in parentheses indicates the number
-of bytes of data from the stream making up the operand.  Operands
-which implicitly come from the stack are noted in the text.  The
-notation "$\Rightarrow$ stack" means that the result is pushed onto the
-stack; "$\Rightarrow$ table" similarly means that the result is added to the
-table.  A construction like "{\it n}(1) {\it value}({\it n})" means that
-first a single byte {\it n} is read from the input stream, and this
-byte specifies how many bytes to read as the operand named {\it value}.
-All numeric values are unsigned binary integers unless otherwise
-specified.  Values described as "signed" are in two's-complement form
-unless otherwise specified.  When an integer read from the stream
-occupies more than one byte, the first byte read is the least
-significant byte, and the last byte read is the most significant (and
-contains the sign bit as its high-order bit if the entire integer is
-signed).
-
-Some of the operations are not necessary, but are rather special
-cases of or combinations of others.  These are included to reduce the
-size of the file or to speed up important cases.  As an example,
-nearly all strings are less than 256 bytes long, and so a special
-form of string operation might take a one-byte length rather than a
-four-byte length.  As another example, some implementations may
-choose to store bits in an array in a left-to-right format within
-each word, rather than right-to-left.  The Fasload file format may
-support both formats, with one being significantly more efficient
-than the other for a given implementation.  The compiler for any
-implementation may generate the more efficient form for that
-implementation, and yet compatibility can be maintained by requiring
-all implementations to support both formats in Fasload files.
-
-Measurements are to be made to determine which operation codes are
-worthwhile; little-used operations may be discarded and new ones
-added.  After a point the definition will be "frozen", meaning that
-existing operations may not be deleted (though new ones may be added;
-some operations codes will be reserved for that purpose).
-
-\begin{description}
-\item[0:] \hspace{2em} {\tt FOP-NOP} \\
-No operation.  (This is included because it is recognized
-that some implementations may benefit from alignment of operands to some
-operations, for example to 32-bit boundaries.  This operation can be used
-to pad the instruction stream to a desired boundary.)
-
-\item[1:] \hspace{2em} {\tt FOP-POP} \hspace{2em} $\Rightarrow$ \hspace{2em} table \\
-One item is popped from the stack and added to the table.
-
-\item[2:] \hspace{2em} {\tt FOP-PUSH} \hspace{2em} {\it index}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-Item number {\it index} of the table is pushed onto the stack.
-The first element of the table is item number zero.
-
-\item[3:] \hspace{2em} {\tt FOP-BYTE-PUSH} \hspace{2em} {\it index}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-Item number {\it index} of the table is pushed onto the stack.
-The first element of the table is item number zero.
-
-\item[4:] \hspace{2em} {\tt FOP-EMPTY-LIST} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The empty list ({\tt ()}) is pushed onto the stack.
-
-\item[5:] \hspace{2em} {\tt FOP-TRUTH} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The standard truth value ({\tt T}) is pushed onto the stack.
-
-\item[6:] \hspace{2em} {\tt FOP-SYMBOL-SAVE} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
-The four-byte operand {\it n} specifies the length of the print name
-of a symbol.  The name follows, one character per byte,
-with the first byte of the print name being the first read.
-The name is interned in the default package,
-and the resulting symbol is both pushed onto the stack and added to the table.
-
-\item[7:] \hspace{2em} {\tt FOP-SMALL-SYMBOL-SAVE} \hspace{2em} {\it n}(1) \hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
-The one-byte operand {\it n} specifies the length of the print name
-of a symbol.  The name follows, one character per byte,
-with the first byte of the print name being the first read.
-The name is interned in the default package,
-and the resulting symbol is both pushed onto the stack and added to the table.
-
-\item[8:] \hspace{2em} {\tt FOP-SYMBOL-IN-PACKAGE-SAVE} \hspace{2em} {\it index}(4)
-\hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
-The four-byte {\it index} specifies a package stored in the table.
-The four-byte operand {\it n} specifies the length of the print name
-of a symbol.  The name follows, one character per byte,
-with the first byte of the print name being the first read.
-The name is interned in the specified package,
-and the resulting symbol is both pushed onto the stack and added to the table.
-
-\item[9:] \hspace{2em} {\tt FOP-SMALL-SYMBOL-IN-PACKAGE-SAVE}  \hspace{2em} {\it index}(4)
-\hspace{2em} {\it n}(1) \hspace{2em} {\it name}({\it n}) \hspace{2em}
-$\Rightarrow$ \hspace{2em} stack \& table\\
-The four-byte {\it index} specifies a package stored in the table.
-The one-byte operand {\it n} specifies the length of the print name
-of a symbol.  The name follows, one character per byte,
-with the first byte of the print name being the first read.
-The name is interned in the specified package,
-and the resulting symbol is both pushed onto the stack and added to the table.
-
-\item[10:] \hspace{2em} {\tt FOP-SYMBOL-IN-BYTE-PACKAGE-SAVE} \hspace{2em} {\it index}(1)
-\hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
-The one-byte {\it index} specifies a package stored in the table.
-The four-byte operand {\it n} specifies the length of the print name
-of a symbol.  The name follows, one character per byte,
-with the first byte of the print name being the first read.
-The name is interned in the specified package,
-and the resulting symbol is both pushed onto the stack and added to the table.
-
-\item[11:]\hspace{2em} {\tt FOP-SMALL-SYMBOL-IN-BYTE-PACKAGE-SAVE} \hspace{2em} {\it index}(1)
-\hspace{2em} {\it n}(1) \hspace{2em} {\it name}({\it n}) \hspace{2em}
-$\Rightarrow$ \hspace{2em} stack \& table\\
-The one-byte {\it index} specifies a package stored in the table.
-The one-byte operand {\it n} specifies the length of the print name
-of a symbol.  The name follows, one character per byte,
-with the first byte of the print name being the first read.
-The name is interned in the specified package,
-and the resulting symbol is both pushed onto the stack and added to the table.
-
-\item[12:] \hspace{2em} {\tt FOP-UNINTERNED-SYMBOL-SAVE} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
-Like {\tt FOP-SYMBOL-SAVE}, except that it creates an uninterned symbol.
-
-\item[13:] \hspace{2em} {\tt FOP-UNINTERNED-SMALL-SYMBOL-SAVE} \hspace{2em} {\it n}(1)
-\hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack
-\& table\\
-Like {\tt FOP-SMALL-SYMBOL-SAVE}, except that it creates an uninterned symbol.
-
-\item[14:] \hspace{2em} {\tt FOP-PACKAGE} \hspace{2em} $\Rightarrow$ \hspace{2em} table \\
-An item is popped from the stack; it must be a symbol.	The package of
-that name is located and pushed onto the table.
-
-\item[15:] \hspace{2em} {\tt FOP-LIST} \hspace{2em} {\it length}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The unsigned operand {\it length} specifies a number of
-operands to be popped from the stack.  These are made into a list
-of that length, and the list is pushed onto the stack.
-The first item popped from the stack becomes the last element of
-the list, and so on.  Hence an iterative loop can start with
-the empty list and perform "pop an item and cons it onto the list"
-{\it length} times.
-(Lists of length greater than 255 can be made by using {\tt FOP-LIST*}
-repeatedly.)
-
-\item[16:] \hspace{2em} {\tt FOP-LIST*} \hspace{2em} {\it length}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-This is like {\tt FOP-LIST} except that the constructed list is terminated
-not by {\tt ()} (the empty list), but by an item popped from the stack
-before any others are.	Therefore {\it length}+1 items are popped in all.
-Hence an iterative loop can start with
-a popped item and perform "pop an item and cons it onto the list"
-{\it length}+1 times.
-
-\item[17-24:] \hspace{2em} {\tt FOP-LIST-1}, {\tt FOP-LIST-2}, ..., {\tt FOP-LIST-8} \\
-{\tt FOP-LIST-{\it k}} is like {\tt FOP-LIST} with a byte containing {\it k}
-following it.  These exist purely to reduce the size of Fasload files.
-Measurements need to be made to determine the useful values of {\it k}.
-
-\item[25-32:] \hspace{2em} {\tt FOP-LIST*-1}, {\tt FOP-LIST*-2}, ..., {\tt FOP-LIST*-8} \\
-{\tt FOP-LIST*-{\it k}} is like {\tt FOP-LIST*} with a byte containing {\it k}
-following it.  These exist purely to reduce the size of Fasload files.
-Measurements need to be made to determine the useful values of {\it k}.
-
-\item[33:] \hspace{2em} {\tt FOP-INTEGER} \hspace{2em} {\it n}(4) \hspace{2em} {\it value}({\it n}) \hspace{2em}
-$\Rightarrow$ \hspace{2em} stack \\
-A four-byte unsigned operand specifies the number of following
-bytes.	These bytes define the value of a signed integer in two's-complement
-form.  The first byte of the value is the least significant byte.
-
-\item[34:] \hspace{2em} {\tt FOP-SMALL-INTEGER} \hspace{2em} {\it n}(1) \hspace{2em} {\it value}({\it n})
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-A one-byte unsigned operand specifies the number of following
-bytes.	These bytes define the value of a signed integer in two's-complement
-form.  The first byte of the value is the least significant byte.
-
-\item[35:] \hspace{2em} {\tt FOP-WORD-INTEGER} \hspace{2em} {\it value}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-A four-byte signed integer (in the range $-2^{31}$ to $2^{31}-1$) follows the
-operation code.  A LISP integer (fixnum or bignum) with that value
-is constructed and pushed onto the stack.
-
-\item[36:] \hspace{2em} {\tt FOP-BYTE-INTEGER} \hspace{2em} {\it value}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-A one-byte signed integer (in the range -128 to 127) follows the
-operation code.  A LISP integer (fixnum or bignum) with that value
-is constructed and pushed onto the stack.
-
-\item[37:] \hspace{2em} {\tt FOP-STRING} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The four-byte operand {\it n} specifies the length of a string to
-construct.  The characters of the string follow, one per byte.
-The constructed string is pushed onto the stack.
-
-\item[38:] \hspace{2em} {\tt FOP-SMALL-STRING} \hspace{2em} {\it n}(1) \hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The one-byte operand {\it n} specifies the length of a string to
-construct.  The characters of the string follow, one per byte.
-The constructed string is pushed onto the stack.
-
-\item[39:] \hspace{2em} {\tt FOP-VECTOR} \hspace{2em} {\it n}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The four-byte operand {\it n} specifies the length of a vector of LISP objects
-to construct.  The elements of the vector are popped off the stack;
-the first one popped becomes the last element of the vector.
-The constructed vector is pushed onto the stack.
-
-\item[40:] \hspace{2em} {\tt FOP-SMALL-VECTOR} \hspace{2em} {\it n}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The one-byte operand {\it n} specifies the length of a vector of LISP objects
-to construct.  The elements of the vector are popped off the stack;
-the first one popped becomes the last element of the vector.
-The constructed vector is pushed onto the stack.
-
-\item[41:] \hspace{2em} {\tt FOP-UNIFORM-VECTOR} \hspace{2em} {\it n}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The four-byte operand {\it n} specifies the length of a vector of LISP objects
-to construct.  A single item is popped from the stack and used to initialize
-all elements of the vector.  The constructed vector is pushed onto the stack.
-
-\item[42:] \hspace{2em} {\tt FOP-SMALL-UNIFORM-VECTOR} \hspace{2em} {\it n}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The one-byte operand {\it n} specifies the length of a vector of LISP objects
-to construct.  A single item is popped from the stack and used to initialize
-all elements of the vector.  The constructed vector is pushed onto the stack.
-
-\item[43:] \hspace{2em} {\tt FOP-INT-VECTOR} \hspace{2em} {\it len}(4) \hspace{2em}
-{\it size}(1) \hspace{2em} {\it data}($\left\lceil len*count/8\right\rceil$)
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The four-byte operand {\it n} specifies the length of a vector of
-unsigned integers to be constructed.   Each integer is {\it size}
-bits long, and is packed according to the machine's native byte ordering.
-{\it size} must be a directly supported i-vector element size.  Currently
-supported values are 1,2,4,8,16 and 32.
-
-\item[44:] \hspace{2em} {\tt FOP-UNIFORM-INT-VECTOR} \hspace{2em} {\it n}(4) \hspace{2em} {\it size}(1) \hspace{2em}
-{\it value}(@ceiling<{\it size}/8>) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The four-byte operand {\it n} specifies the length of a vector of unsigned
-integers to construct.
-Each integer is {\it size} bits big, and is initialized to the value
-of the operand {\it value}.
-The constructed vector is pushed onto the stack.
-
-\item[45:] Unused
-
-\item[46:] \hspace{2em} {\tt FOP-SINGLE-FLOAT} \hspace{2em} {\it data}(4) \hspace{2em}
-$\Rightarrow$ \hspace{2em} stack \\
-The {\it data} bytes are read as an integer, then turned into an IEEE single
-float (as though by {\tt make-single-float}).
-
-\item[47:] \hspace{2em} {\tt FOP-DOUBLE-FLOAT} \hspace{2em} {\it data}(8) \hspace{2em}
-$\Rightarrow$ \hspace{2em} stack \\
-The {\it data} bytes are read as an integer, then turned into an IEEE double
-float (as though by {\tt make-double-float}).
-
-\item[48:] \hspace{2em} {\tt FOP-STRUCT} \hspace{2em} {\it n}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The four-byte operand {\it n} specifies the length structure to construct.  The
-elements of the vector are popped off the stack; the first one popped becomes
-the last element of the structure.  The constructed vector is pushed onto the
-stack.
-
-\item[49:] \hspace{2em} {\tt FOP-SMALL-STRUCT} \hspace{2em} {\it n}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The one-byte operand {\it n} specifies the length structure to construct.  The
-elements of the vector are popped off the stack; the first one popped becomes
-the last element of the structure.  The constructed vector is pushed onto the
-stack.
-
-\item[50-52:] Unused
-
-\item[53:] \hspace{2em} {\tt FOP-EVAL} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-Pop an item from the stack and evaluate it (give it to {\tt EVAL}).
-Push the result back onto the stack.
-
-\item[54:] \hspace{2em} {\tt FOP-EVAL-FOR-EFFECT} \\
-Pop an item from the stack and evaluate it (give it to {\tt EVAL}).
-The result is ignored.
-
-\item[55:] \hspace{2em} {\tt FOP-FUNCALL} \hspace{2em} {\it nargs}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-Pop {\it nargs}+1 items from the stack and apply the last one popped
-as a function to
-all the rest as arguments (the first one popped being the last argument).
-Push the result back onto the stack.
-
-\item[56:] \hspace{2em} {\tt FOP-FUNCALL-FOR-EFFECT} \hspace{2em} {\it nargs}(1) \\
-Pop {\it nargs}+1 items from the stack and apply the last one popped
-as a function to
-all the rest as arguments (the first one popped being the last argument).
-The result is ignored.
-
-\item[57:] \hspace{2em} {\tt FOP-CODE-FORMAT} \hspace{2em} {\it implementation}(1)
-\hspace{2em} {\it version}(1) \\
-This FOP specifiers the code format for following code objects.  The operations
-{\tt FOP-CODE} and its relatives may not occur in a group until after {\tt
-FOP-CODE-FORMAT} has appeared; there is no default format.  The {\it
-implementation} is an integer indicating the target hardware and environment.
-See {\tt compiler/generic/vm-macs.lisp} for the currently defined
-implementations.  {\it version} for an implementation is increased whenever
-there is a change that renders old fasl files unusable.
-
-\item[58:] \hspace{2em} {\tt FOP-CODE} \hspace{2em} {\it nitems}(4) \hspace{2em} {\it size}(4) \hspace{2em}
-{\it code}({\it size}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-A compiled function is constructed and pushed onto the stack.
-This object is in the format specified by the most recent
-occurrence of {\tt FOP-CODE-FORMAT}.
-The operand {\it nitems} specifies a number of items to pop off
-the stack to use in the "boxed storage" section.  The operand {\it code}
-is a string of bytes constituting the compiled executable code.
-
-\item[59:] \hspace{2em} {\tt FOP-SMALL-CODE} \hspace{2em} {\it nitems}(1) \hspace{2em} {\it size}(2) \hspace{2em}
-{\it code}({\it size}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-A compiled function is constructed and pushed onto the stack.
-This object is in the format specified by the most recent
-occurrence of {\tt FOP-CODE-FORMAT}.
-The operand {\it nitems} specifies a number of items to pop off
-the stack to use in the "boxed storage" section.  The operand {\it code}
-is a string of bytes constituting the compiled executable code.
-
-\item[60-61:] Unused
-
-\item[62:] \hspace{2em} {\tt FOP-VERIFY-TABLE-SIZE} \hspace{2em} {\it size}(4) \\
-If the current size of the table is not equal to {\it size},
-then an inconsistency has been detected.  This operation
-is inserted into a Fasload file purely for error-checking purposes.
-It is good practice for a compiler to output this at least at the
-end of every group, if not more often.
-
-\item[63:] \hspace{2em} {\tt FOP-VERIFY-EMPTY-STACK} \\
-If the stack is not currently empty,
-then an inconsistency has been detected.  This operation
-is inserted into a Fasload file purely for error-checking purposes.
-It is good practice for a compiler to output this at least at the
-end of every group, if not more often.
-
-\item[64:] \hspace{2em} {\tt FOP-END-GROUP} \\
-This is the last operation of a group.	If this is not the
-last byte of the file, then a new group follows; the next
-nine bytes must be "{\tt FASL FILE}".
-
-\item[65:] \hspace{2em} {\tt FOP-POP-FOR-EFFECT} \hspace{2em} stack \hspace{2em} $\Rightarrow$ \hspace{2em} \\
-One item is popped from the stack.
-
-\item[66:] \hspace{2em} {\tt FOP-MISC-TRAP} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-A trap object is pushed onto the stack.
-
-\item[67:] Unused
-
-\item[68:] \hspace{2em} {\tt FOP-CHARACTER} \hspace{2em} {\it character}(3) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-The three bytes are read as an integer then converted to a character.  This FOP
-is currently rather useless, as extended characters are not supported.
-
-\item[69:] \hspace{2em} {\tt FOP-SHORT-CHARACTER} \hspace{2em} {\it character}(1) \hspace{2em}
-$\Rightarrow$ \hspace{2em} stack \\
-The one byte specifies the code of a Common Lisp character object.  A character
-is constructed and pushed onto the stack.
-
-\item[70:] \hspace{2em} {\tt FOP-RATIO} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-Creates a ratio from two integers popped from the stack.
-The denominator is popped first, the numerator second.
-
-\item[71:] \hspace{2em} {\tt FOP-COMPLEX} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
-Creates a complex number from two numbers popped from the stack.
-The imaginary part is popped first, the real part second.
-
-\item[72-73:] Unused
-
-\item[74:] \hspace{2em} {\tt FOP-FSET} \hspace{2em} \\
-Except in the cold loader (Genesis), this is a no-op with two stack arguments.
-In the initial core this is used to make DEFUN functions defined at cold-load
-time so that global functions can be called before top-level forms are run
-(which normally installs definitions.)  Genesis pops the top two things off of
-the stack and effectively does (SETF SYMBOL-FUNCTION).
-
-\item[75:] \hspace{2em} {\tt FOP-LISP-SYMBOL-SAVE} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
-Like {\tt FOP-SYMBOL-SAVE}, except that it creates a symbol in the LISP
-package.
-
-\item[76:] \hspace{2em} {\tt FOP-LISP-SMALL-SYMBOL-SAVE} \hspace{2em} {\it n}(1)
-\hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack
-\& table\\
-Like {\tt FOP-SMALL-SYMBOL-SAVE}, except that it creates a symbol in the LISP
-package.
-
-\item[77:] \hspace{2em} {\tt FOP-KEYWORD-SYMBOL-SAVE} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
-Like {\tt FOP-SYMBOL-SAVE}, except that it creates a symbol in the
-KEYWORD package.
-
-\item[78:] \hspace{2em} {\tt FOP-KEYWORD-SMALL-SYMBOL-SAVE} \hspace{2em} {\it n}(1)
-\hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack
-\& table\\
-Like {\tt FOP-SMALL-SYMBOL-SAVE}, except that it creates a symbol in the
-KEYWORD package.
-
-\item[79-80:] Unused
-
-\item[81:] \hspace{2em} {\tt FOP-NORMAL-LOAD}\\
-This FOP is used in conjunction with the cold loader (Genesis) to read
-top-level package manipulation forms.  These forms are to be read as though by
-the normal loaded, so that they can be evaluated at cold load time, instead of
-being dumped into the initial core image.  A no-op in normal loading.
-
-\item[82:] \hspace{2em} {\tt FOP-MAYBE-COLD-LOAD}\\
-Undoes the effect of {\tt FOP-NORMAL-LOAD}. 
-
-\item[83:] \hspace{2em} {\tt FOP-ARRAY} \hspace{2em} {\it rank}(4)
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
-This operation creates a simple array header (used for simple-arrays with rank
-/= 1).  The data vector is popped off of the stack, and then {\it rank}
-dimensions are popped off of the stack (the highest dimensions is on top.)
-
-\item[84-139:] Unused
-
-\item[140:] \hspace{2em} {\tt FOP-ALTER-CODE} \hspace{2em} {\it index}(4)\\
-This operation modifies the constants part of a code object (necessary for
-creating certain circular function references.)  It pops the new value and code
-object are off of the stack, storing the new value at the specified index.
-
-\item[141:] \hspace{2em} {\tt FOP-BYTE-ALTER-CODE} \hspace{2em} {\it index}(1)\\
-Like {\tt FOP-ALTER-CODE}, but has only a one byte offset.
-
-\item[142:] \hspace{2em} {\tt FOP-FUNCTION-ENTRY} \hspace{2em} {\it index}(4)
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
-Initializes a function-entry header inside of a pre-existing code object, and
-returns the corresponding function descriptor.  {\it index} is the byte offset
-inside of the code object where the header should be plunked down.  The stack
-arguments to this operation are the code object, function name, function debug
-arglist and function type.
-
-\item[143:] Unused
-
-\item[144:] \hspace{2em} {\tt FOP-ASSEMBLER-CODE} \hspace{2em} {\it length}(4)
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
-This operation creates a code object holding assembly routines.  {\it length}
-bytes of code are read and placed in the code object, and the code object
-descriptor is pushed on the stack.  This FOP is only recognized by the cold
-loader (Genesis.)
-
-\item[145:] \hspace{2em} {\tt FOP-ASSEMBLER-ROUTINE} \hspace{2em} {\it offset}(4)
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
-This operation records an entry point into an assembler code object (for use
-with {\tt FOP-ASSEMBLER-FIXUP}).  The routine name (a symbol) is on stack top.
-The code object is underneath.  The entry point is defined at {\it offset}
-bytes inside the code area of the code object, and the code object is left on
-stack top (allowing multiple uses of this FOP to be chained.)  This FOP is only
-recognized by the cold loader (Genesis.)
-
-\item[146:] Unused
-
-\item[147:] \hspace{2em} {\tt FOP-FOREIGN-FIXUP} \hspace{2em} {\it len}(1)
-\hspace{2em} {\it name}({\it len})
-\hspace{2em} {\it offset}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
-This operation resolves a reference to a foreign (C) symbol.  {\it len} bytes
-are read and interpreted as the symbol {\it name}.  First the {\it kind} and the
-code-object to patch are popped from the stack.  The kind is a target-dependent
-symbol indicating the instruction format of the patch target (at {\it offset}
-bytes from the start of the code area.)  The code object is left on
-stack top (allowing multiple uses of this FOP to be chained.)
-
-\item[148:] \hspace{2em} {\tt FOP-ASSEMBLER-FIXUP} \hspace{2em} {\it offset}(4)
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
-This operation resolves a reference to an assembler routine.  The stack args
-are ({\it routine-name}, {\it kind} and {\it code-object}).  The kind is a
-target-dependent symbol indicating the instruction format of the patch target
-(at {\it offset} bytes from the start of the code area.)  The code object is
-left on stack top (allowing multiple uses of this FOP to be chained.)
-
-\item[149-199:] Unused
-
-\item[200:] \hspace{2em} {\tt FOP-RPLACA} \hspace{2em} {\it table-idx}(4)
-\hspace{2em} {\it cdr-offset}(4)\\
-
-\item[201:] \hspace{2em} {\tt FOP-RPLACD} \hspace{2em} {\it table-idx}(4)
-\hspace{2em} {\it cdr-offset}(4)\\
-These operations destructively modify a list entered in the table.  {\it
-table-idx} is the table entry holding the list, and {\it cdr-offset} designates
-the cons in the list to modify (like the argument to {\tt nthcdr}.)  The new
-value is popped off of the stack, and stored in the {\tt car} or {\tt cdr},
-respectively.
-
-\item[202:] \hspace{2em} {\tt FOP-SVSET} \hspace{2em} {\it table-idx}(4)
-\hspace{2em} {\it vector-idx}(4)\\
-Destructively modifies a {\tt simple-vector} entered in the table.  Pops the
-new value off of the stack, and stores it in the {\it vector-idx} element of
-the contents of the table entry {\it table-idx.}
-
-\item[203:] \hspace{2em} {\tt FOP-NTHCDR} \hspace{2em} {\it cdr-offset}(4)
-\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
-Does {\tt nthcdr} on the top-of stack, leaving the result there.
-
-\item[204:] \hspace{2em} {\tt FOP-STRUCTSET} \hspace{2em} {\it table-idx}(4)
-\hspace{2em} {\it vector-idx}(4)\\
-Like {\tt FOP-SVSET}, except it alters structure slots.
-
-\item[255:] \hspace{2em} {\tt FOP-END-HEADER} \\ Indicates the end of a group header,
-as described above.
-\end{description}
diff --git a/docs/internals/front.tex b/docs/internals/front.tex
deleted file mode 100644
index b55d41904aec977e89bd51af3eae93140c4c1d22..0000000000000000000000000000000000000000
--- a/docs/internals/front.tex
+++ /dev/null
@@ -1,943 +0,0 @@
-\chapter{ICR conversion} % -*- Dictionary: design -*-
-
-
-
-\section{Canonical forms}
-
-\#|
-
-Would be useful to have a Freeze-Type proclamation.  Its primary use would to
-be say that the indicated type won't acquire any new subtypes in the future.
-This allows better open-coding of structure type predicates, since the possible
-types that would satisfy the predicate will be constant at compile time, and
-thus can be compiled as a skip-chain of EQ tests.  
-
-Of course, this is only a big win when the subtypes are few: the most important
-case is when there are none.  If the closure of the subtypes is much larger
-than the average number of supertypes of an inferior, then it is better to grab
-the list of superiors out of the object's type, and test for membership in that
-list.
-
-Should type-specific numeric equality be done by EQL rather than =?  i.e.
-should = on two fixnums become EQL and then convert to EQL/FIXNUM?
-Currently we transform EQL into =, which is complicated, since we have to prove
-the operands are the class of numeric type before we do it.  Also, when EQL
-sees one operand is a FIXNUM, it transforms to EQ, but the generator for EQ
-isn't expecting numbers, so it doesn't use an immediate compare.
-
-
-Array hackery:
-
-
-Array type tests are transformed to %array-typep, separation of the
-implementation-dependent array-type handling.  This way we can transform
-STRINGP to:
-     (or (simple-string-p x)
-	 (and (complex-array-p x)
-	      (= (array-rank x) 1)
-	      (simple-string-p (%array-data x))))
-
-In addition to the similar bit-vector-p, we also handle vectorp and any type
-tests on which the a dimension isn't wild.
-[Note that we will want to expand into frobs compatible with those that
-array references expand into so that the same optimizations will work on both.]
-
-These changes combine to convert hairy type checks into hairy typep's, and then
-convert hairyp typeps into simple typeps.
-
-
-Do we really need non-VOP templates?  It seems that we could get the desired
-effect through implementation-dependent ICR transforms.  The main risk would be
-of obscuring the type semantics of the code.  We could fairly easily retain all
-the type information present at the time the tranform is run, but if we
-discover new type information, then it won't be propagated unless the VM also
-supplies type inference methods for its internal frobs (precluding the use of
-%PRIMITIVE, since primitives don't have derive-type methods.)  
-
-I guess one possibility would be to have the call still considered "known" even
-though it has been transformed.  But this doesn't work, since we start doing
-LET optimizations that trash the arglist once the call has been transformed
-(and indeed we want to.)
-
-Actually, I guess the overhead for providing type inference methods for the
-internal frobs isn't that great, since we can usually borrow the inference
-method for a Common Lisp function.  For example, in our AREF case:
-    (aref x y)
-==>
-    (let ((\#:len (array-dimension x 0)))
-      (%unchecked-aref x (%check-in-bounds y \#:len)))
-
-Now in this case, if we made %UNCHECKED-AREF have the same derive-type method
-as AREF, then if we discovered something new about X's element type, we could
-derive a new type for the entire expression.
-
-Actually, it seems that baring this detail at the ICR level is beneficial,
-since it admits the possibly of optimizing away the bounds check using type
-information.  If we discover X's dimensions, then \#:LEN becomes a constant that
-can be substituted.  Then %CHECK-IN-BOUNDS can notice that the bound is
-constant and check it against the type for Y.  If Y is known to be in range,
-then we can optimize away the bounds check.
-
-Actually in this particular case, the best thing to do would be if we
-discovered the bound is constant, then replace the bounds check with an
-implicit type check.  This way all the type check optimization mechanisms would
-be brought into the act.
-
-So we actually want to do the bounds-check expansion as soon as possible,
-rather than later than possible: it should be a source-transform, enabled by
-the fast-safe policy.
-
-With multi-dimensional arrays we probably want to explicitly do the index
-computation: this way portions of the index computation can become loop
-invariants.  In a scan in row-major order, the inner loop wouldn't have to do
-any multiplication: it would only do an addition.  We would use normal
-fixnum arithmetic, counting on * to cleverly handle multiplication by a
-constant, and appropriate inline expansion.
-
-Note that in a source transform, we can't make any assumptions the type of the
-array.  If it turns out to be a complex array without declared dimensions, then
-the calls to ARRAY-DIMENSION will have to turn into a VOP that can be affected.
-But if it is simple, then the VOP is unaffected, and if we know the bounds, it
-is constant.  Similarly, we would have %ARRAY-DATA and %ARRAY-DISPLACEMENT
-operations.  %ARRAY-DISPLACEMENT would optimize to 0 if we discover the array
-is simple.  [This is somewhat inefficient when the array isn't eventually
-discovered to be simple, since finding the data and finding the displacement
-duplicate each other.  We could make %ARRAY-DATA return both as MVs, and then
-optimize to (VALUES (%SIMPLE-ARRAY-DATA x) 0), but this would require
-optimization of trivial VALUES uses.]
-
-Also need (THE (ARRAY * * * ...) x) to assert correct rank.
-
-|\#
-
-A bunch of functions have source transforms that convert them into the
-canonical form that later parts of the compiler want to see.  It is not legal
-to rely on the canonical form since source transforms can be inhibited by a
-Notinline declaration.  This shouldn't be a problem, since everyone should keep
-their hands off of Notinline calls.
-
-Some transformations:
-
-Endp  ==>  (NULL (THE LIST ...))
-(NOT xxx) or (NULL xxx) => (IF xxx NIL T)
-
-(typep x '<simple type>) => (<simple predicate> x)
-(typep x '<complex type>) => ...composition of simpler operations...
-TYPEP of AND, OR and NOT types turned into conditionals over multiple TYPEP
-calls.  This makes hairy TYPEP calls more digestible to type constraint
-propagation, and also means that the TYPEP code generators don't have to deal
-with these cases.  [\#\#\# In the case of union types we may want to do something
-to preserve information for type constraint propagation.]
-
-
-    (apply \#'foo a b c)
-==>
-    (multiple-value-call \#'foo (values a) (values b) (values-list c))
-
-This way only MV-CALL needs to know how to do calls with unknown numbers of
-arguments.  It should be nearly as efficient as a special-case VMR-Convert
-method could be.
-
-
-Make-String => Make-Array
-N-arg predicates associated into two-arg versions.
-Associate N-arg arithmetic ops.
-Expand CxxxR and FIRST...nTH
-Zerop, Plusp, Minusp, 1+, 1-, Min, Max, Rem, Mod
-(Values x), (Identity x) => (Prog1 x)
-
-All specialized aref functions => (aref (the xxx) ...)
-
-Convert (ldb (byte ...) ...) into internal frob that takes size and position as
-separate args.  Other byte functions also...
-
-Change for-value primitive predicates into (if <pred> t nil).  This isn't
-particularly useful during ICR phases, but makes life easy for VMR conversion.
-
-This last can't be a source transformation, since a source transform can't tell
-where the form appears.  Instead, ICR conversion special-cases calls to known
-functions with the Predicate attribute by doing the conversion when the
-destination of the result isn't an IF.  It isn't critical that this never be
-done for predicates that we ultimately discover to deliver their value to an
-IF, since IF optimizations will flush unnecessary IFs in a predicate.
-
-
-\section{Inline functions}
-
-[\#\#\# Inline expansion is especially powerful in the presence of good lisp-level
-optimization ("partial evaluation").  Many "optimizations" usually done in Lisp
-compilers by special-case source-to-source transforms can be had simply by
-making the source of the general case function available for inline expansion.
-This is especially helpful in Common Lisp, which has many commonly used
-functions with simple special cases but bad general cases (list and sequence
-functions, for example.)
-
-Inline expansion of recursive functions is allowed, and is not as silly as it
-sounds.  When expanded in a specific context, much of the overhead of the
-recursive calls may be eliminated (especially if there are many keyword
-arguments, etc.)
-
-[Also have MAYBE-INLINE]
-]
-
-We only record a function's inline expansion in the global environment when the
-function is in the null lexical environment, since it the expansion must be
-represented as source.
-
-We do inline expansion of functions locally defined by FLET or LABELS even when
-the environment is not null.  Since the appearances of the local function must
-be nested within the desired environment, it is possible to expand local
-functions inline even when they use the environment.  We just stash the source
-form and environments in the Functional for the local function.  When we
-convert a call to it, we just reconvert the source in the saved environment.
-
-An interesting alternative to the inline/full-call dichotomy is "semi-inline"
-coding.  Whenever we have an inline expansion for a function, we can expand it
-only once per block compilation, and then use local call to call this copied
-version.  This should get most of the speed advantage of real inline coding
-with much less code bloat.  This is especially attractive for simple system
-functions such as Read-Char.
-
-The main place where true inline expansion would still be worth doing is where
-large amounts of the function could be optimized away by constant folding or
-other optimizations that depend on the exact arguments to the call.
-
-
-
-\section{Compilation policy}
-
-We want more sophisticated control of compilation safety than is offered in CL,
-so that we can emit only those type checks that are likely to discover
-something (i.e. external interfaces.)
-
-\#|
-
-
-\section{Notes}
-
-Generalized back-end notion provides dynamic retargeting?  (for byte code)
-
-The current node type annotations seem to be somewhat unsatisfactory, since we
-lose information when we do a THE on a continuation that already has uses, or
-when we convert a let where the actual result continuation has other uses.  
-
-But the case with THE isn't really all that bad, since the test of whether
-there are any uses happens before conversion of the argument, thus THE loses
-information only when there are uses outside of the declared form.  The LET
-case may not be a big deal either.
-
-Note also that losing user assertions isn't really all that bad, since it won't
-damage system integrity.  At worst, it will cause a bug to go undetected.  More
-likely, it will just cause the error to be signaled in a different place (and
-possibly in a less informative way).  Of course, there is an efficiency hit for
-losing type information, but if it only happens in strange cases, then this
-isn't a big deal.
-
-
-\chapter{Local call analysis}
-
-All calls to local functions (known named functions and LETs) are resolved to
-the exact LAMBDA node which is to be called.  If the call is syntactically
-illegal, then we emit a warning and mark the reference as :notinline, forcing
-the call to be a full call.  We don't even think about converting APPLY calls;
-APPLY is not special-cased at all in ICR.  We also take care not to convert
-calls in the top-level component, which would join it to normal code.  Calls to
-functions with rest args and calls with non-constant keywords are also not
-converted.
-
-We also convert MV-Calls that look like MULTIPLE-VALUE-BIND to local calls,
-since we know that they can be open-coded.  We replace the optional dispatch
-with a call to the last optional entry point, letting MV-Call magically default
-the unsupplied values to NIL.
-
-When ICR optimizations discover a possible new local call, they explicitly
-invoke local call analysis on the code that needs to be reanalyzed. 
-
-[\#\#\# Let conversion.  What is means to be a let.  Argument type checking done
-by caller.  Significance of local call is that all callers are known, so
-special call conventions may be used.]
-A lambda called in only one place is called a "let" call, since a Let would
-turn into one.
-
-In addition to enabling various ICR optimizations, the let/non-let distinction
-has important environment significance.  We treat the code in function and all
-of the lets called by that function as being in the same environment.  This
-allows exits from lets to be treated as local exits, and makes life easy for
-environment analysis.  
-
-Since we will let-convert any function with only one call, we must be careful
-about cleanups.  It is possible that a lexical exit from the let function may
-have to clean up dynamic bindings not lexically apparent at the exit point.  We
-handle this by annotating lets with any cleanup in effect at the call site.
-The cleanup for continuations with no immediately enclosing cleanup is the
-lambda that the continuation is in.  In this case, we look at the lambda to see
-if any cleanups need to be done.
-
-Let conversion is disabled for entry-point functions, since otherwise we might
-convert the call from the XEP to the entry point into a let.  Then later on, we
-might want to convert a non-local reference into a local call, and not be able
-to, since once a function has been converted to a let, we can't convert it
-back.
-
-
-A function's return node may also be deleted if it is unreachable, which can
-happen if the function never returns normally.  Such functions are not lets.
-
-
-\chapter{Find components}
-
-This is a post-pass to ICR conversion that massages the flow graph into the
-shape subsequent phases expect.  Things done:
-  Compute the depth-first ordering for the flow graph.
-  Find the components (disconnected parts) of the flow graph.
-
-This pass need only be redone when newly converted code has been added to the
-flow graph.  The reanalyze flag in the component structure should be set by
-people who mess things up.
-
-We create the initial DFO using a variant of the basic algorithm.  The initial
-DFO computation breaks the ICR up into components, which are parts that can be
-compiled independently.  This is done to increase the efficiency of large block
-compilations.  In addition to improving locality of reference and reducing the
-size of flow analysis problems, this allows back-end data structures to be
-reclaimed after the compilation of each component.
-
-ICR optimization can change the connectivity of the flow graph by discovering
-new calls or eliminating dead code.  Initial DFO determination splits up the
-flow graph into separate components, but does so conservatively, ensuring that
-parts that might become joined (due to local call conversion) are joined from
-the start.  Initial DFO computation also guarantees that all code which shares
-a lexical environment is in the same component so that environment analysis
-needs to operate only on a single component at a time.
-
-[This can get a bit hairy, since code seemingly reachable from the
-environment entry may be reachable from a NLX into that environment.  Also,
-function references must be considered as links joining components even though
-the flow graph doesn't represent these.]
-
-After initial DFO determination, components are neither split nor joined.  The
-standard DFO computation doesn't attempt to split components that have been
-disconnected.
-
-
-\chapter{ICR optimize}
-
-{\bf Somewhere describe basic ICR utilities: continuation-type,
-constant-continuation-p, etc.  Perhaps group by type in ICR description?}
-
-We are conservative about doing variable-for-variable substitution in ICR
-optimization, since if we substitute a variable with a less restrictive type,
-then we may prevent use of a "good" representation within the scope of the
-inner binding.
-
-Note that variable-variable substitutions aren't really crucial in ICR, since
-they don't create opportunities for new optimizations (unlike substitution of
-constants and functions).  A spurious variable-variable binding will show up as
-a Move operation in VMR.  This can be optimized away by reaching-definitions
-and also by targeting.  [\#\#\# But actually, some optimizers do see if operands
-are the same variable.]
-
-\#|
-
-The IF-IF optimization can be modeled as a value driven optimization, since
-adding a use definitely is cause for marking the continuation for
-reoptimization.  [When do we add uses?  Let conversion is the only obvious
-time.]  I guess IF-IF conversion could also be triggered by a non-immediate use
-of the test continuation becoming immediate, but to allow this to happen would
-require Delete-Block (or somebody) to mark block-starts as needing to be
-reoptimized when a predecessor changes.  It's not clear how important it is
-that IF-IF conversion happen under all possible circumstances, as long as it
-happens to the obvious cases.
-
-[\#\#\# It isn't totally true that code flushing never enables other worthwhile
-optimizations.  Deleting a functional reference can cause a function to cease
-being an XEP, or even trigger let conversion.  It seems we still want to flush
-code during ICR optimize, but maybe we want to interleave it more intimately
-with the optimization pass.  
-
-Ref-flushing works just as well forward as backward, so it could be done in the
-forward pass.  Call flushing doesn't work so well, but we could scan the block
-backward looking for any new flushable stuff if we flushed a call on the
-forward pass.
-
-When we delete a variable due to lack of references, we leave the variable
-in the lambda-list so that positional references still work.  The initial value
-continuation is flushed, though (replaced with NIL) allowing the initial value
-for to be deleted (modulo side-effects.)
-
-Note that we can delete vars with no refs even when they have sets.  I guess
-when there are no refs, we should also flush all sets, allowing the value
-expressions to be flushed as well.
-
-Squeeze out single-reference unset let variables by changing the dest of the
-initial value continuation to be the node that receives the ref.  This can be
-done regardless of what the initial value form is, since we aren't actually
-moving the evaluation.  Instead, we are in effect using the continuation's
-locations in place of the temporary variable.  
-
-Doing this is of course, a wild violation of stack discipline, since the ref
-might be inside a loop, etc.  But with the VMR back-end, we only need to
-preserve stack discipline for unknown-value continuations; this ICR
-transformation must be already be inhibited when the DEST of the REF is a
-multiple-values receiver (EXIT, RETURN or MV-COMBINATION), since we must
-preserve the single-value semantics of the let-binding in this case.
-
-The REF and variable must be deleted as part of this operation, since the ICR
-would otherwise be left in an inconsistent state; we can't wait for the REF to
-be deleted due to bing unused, since we have grabbed the arg continuation and
-substituted it into the old DEST.
-
-The big reason for doing this transformation is that in macros such as INCF and
-PSETQ, temporaries are squeezed out, and the new value expression is evaluated
-directly to the setter, allowing any result type assertion to be applied to the
-expression evaluation.  Unlike in the case of substitution, there is no point
-in inhibiting this transformation when the initial value type is weaker than
-the variable type.  Instead, we intersect the asserted type for the old REF's
-CONT with the type assertion on the initial value continuation.  Note that the
-variable's type has already been asserted on the initial-value continuation.
-
-Of course, this transformation also simplifies the ICR even when it doesn't
-discover interesting type assertions, so it makes sense to do it whenever
-possible.  This reduces the demands placed on register allocation, etc.
-
-|\#
-
-There are three dead-code flushing rules:
- 1] Refs with no DEST may be flushed.
- 2] Known calls with no dest that are flushable may be flushed.  We null the
-    DEST in all the args.
- 3] If a lambda-var has no refs, then it may be deleted.  The flushed argument
-    continuations have their DEST nulled.
-
-These optimizations all enable one another.  We scan blocks backward, looking
-for nodes whose CONT has no DEST, then type-dispatching off of the node.  If we
-delete a ref, then we check to see if it is a lambda-var with no refs.  When we
-flush an argument, we mark the blocks for all uses of the CONT as needing to be
-reoptimized.
-
-
-\section{Goals for ICR optimizations}
-
-\#|
-
-When an optimization is disabled, code should still be correct and not
-ridiculously inefficient.  Phases shouldn't be made mandatory when they have
-lots of non-required stuff jammed into them.
-
-|\#
-
-This pass is optional, but is desirable if anything is more important than
-compilation speed.
-
-This phase is a grab-bag of optimizations that concern themselves with the flow
-of values through the code representation.  The main things done are type
-inference, constant folding and dead expression elimination.  This phase can be
-understood as a walk of the expression tree that propagates assertions down the
-tree and propagates derived information up the tree.  The main complication is
-that there isn't any expression tree, since ICR is flow-graph based.
-
-We repeat this pass until we don't discover anything new.  This is a bit of
-feat, since we dispatch to arbitrary functions which may do arbitrary things,
-making it hard to tell if anything really happened.  Even if we solve this
-problem by requiring people to flag when they changed or by checking to see if
-they changed something, there are serious efficiency problems due to massive
-redundant computation, since in many cases the only way to tell if anything
-changed is to recompute the value and see if it is different from the old one.
-
-We solve this problem by requiring that optimizations for a node only depend on
-the properties of the CONT and the continuations that have the node as their
-DEST.  If the continuations haven't changed since the last pass, then we don't
-attempt to re-optimize the node, since we know nothing interesting will happen.
-
-We keep track of which continuations have changed by a REOPTIMIZE flag that is
-set whenever something about the continuation's value changes.
-
-When doing the bottom up pass, we dispatch to type specific code that knows how
-to tell when a node needs to be reoptimized and does the optimization.  These
-node types are special-cased: COMBINATION, IF, RETURN, EXIT, SET.
-
-The REOPTIMIZE flag in the COMBINATION-FUN is used to detect when the function
-information might have changed, so that we know when where are new assertions
-that could be propagated from the function type to the arguments.
-
-When we discover something about a leaf, or substitute for leaf, we reoptimize
-the CONT for all the REF and SET nodes. 
-
-We have flags in each block that indicate when any nodes or continuations in
-the block need to be re-optimized, so we don't have to scan blocks where there
-is no chance of anything happening.
-
-It is important for efficiency purposes that optimizers never say that they did
-something when they didn't, but this by itself doesn't guarantee timely
-termination.  I believe that with the type system implemented, type inference
-will converge in finite time, but as a practical matter, it can take far too
-long to discover not much.  For this reason, ICR optimization is terminated
-after three consecutive passes that don't add or delete code.  This premature
-termination only happens 2% of the time.
-
-
-\section{Flow graph simplification}
-
-Things done:
-    Delete blocks with no predecessors.
-    Merge blocks that can be merged.
-    Convert local calls to Let calls.
-    Eliminate degenerate IFs.
-
-We take care not to merge blocks that are in different functions or have
-different cleanups.  This guarantees that non-local exits are always at block
-ends and that cleanup code never needs to be inserted within a block.
-
-We eliminate IFs with identical consequent and alternative.  This would most
-likely happen if both the consequent and alternative were optimized away.
-
-[Could also be done if the consequent and alternative were different blocks,
-but computed the same value.  This could be done by a sort of cross-jumping
-optimization that looked at the predecessors for a block and merged code shared
-between predecessors.  IFs with identical branches would eventually be left
-with nothing in their branches.]
-
-We eliminate IF-IF constructs:
-    (IF (IF A B C) D E) ==>
-    (IF A (IF B D E) (IF C D E))
-
-In reality, what we do is replicate blocks containing only an IF node where the
-predicate continuation is the block start.  We make one copy of the IF node for
-each use, leaving the consequent and alternative the same.  If you look at the
-flow graph representation, you will see that this is really the same thing as
-the above source to source transformation.
-
-
-\section{Forward ICR optimizations}
-
-In the forward pass, we scan the code in forward depth-first order.  We
-examine each call to a known function, and:
-
-\begin{itemize}
-\item Eliminate any bindings for unused variables.
-
-\item Do top-down type assertion propagation.  In local calls, we propagate
-asserted and derived types between the call and the called lambda.
-
-\item
-    Replace calls of foldable functions with constant arguments with the
-    result.  We don't have to actually delete the call node, since Top-Down
-    optimize will delete it now that its value is unused.
- 
-\item
-   Run any Optimizer for the current function.  The optimizer does arbitrary
-    transformations by hacking directly on the IR.  This is useful primarily
-    for arithmetic simplification and similar things that may need to examine
-    and modify calls other than the current call.  The optimizer is responsible
-    for recording any changes that it makes.  An optimizer can inhibit further
-    optimization of the node during the current pass by returning true.  This
-    is useful when deleting the node.
-
-\item
-   Do ICR transformations, replacing a global function call with equivalent
-    inline lisp code.
-
-\item
-    Do bottom-up type propagation/inferencing.  For some functions such as
-    Coerce we will dispatch to a function to find the result type.  The
-    Derive-Type function just returns a type structure, and we check if it is
-    different from the old type in order to see if there was a change.
-
-\item
-    Eliminate IFs with predicates known to be true or false.
-
-\item
-    Substitute the value for unset let variables that are bound to constants,
-    unset lambda variables or functionals.
-
-\item
-    Propagate types from local call args to var refs.
-\end{itemize}
-
-We use type info from the function continuation to find result types for
-functions that don't have a derive-type method.
-
-
-ICR transformation:
-
-ICR transformation does "source to source" transformations on known global
-functions, taking advantage of semantic information such as argument types and
-constant arguments.  Transformation is optional, but should be done if speed or
-space is more important than compilation speed.  Transformations which increase
-space should pass when space is more important than speed.
-
-A transform is actually an inline function call where the function is computed
-at compile time.  The transform gets to peek at the continuations for the
-arguments, and computes a function using the information gained.  Transforms
-should be cautious about directly using the values of constant continuations,
-since the compiler must preserve eqlness of named constants, and it will have a
-hard time if transforms go around randomly copying constants.
-
-The lambda that the transform computes replaces the original function variable
-reference as the function for the call.  This lets the compiler worry about
-evaluating each argument once in the right order.  We want to be careful to
-preserve type information when we do a transform, since it may be less than
-obvious what the transformed code does.
-
-There can be any number of transforms for a function.  Each transform is
-associated with a function type that the call must be compatible with.  A
-transform is only invoked if the call has the right type.  This provides a way
-to deal with the common case of a transform that only applies when the
-arguments are of certain types and some arguments are not specified.  We always
-use the derived type when determining whether a transform is applicable.  Type
-check is responsible for setting the derived type to the intersection of the
-asserted and derived types.
-
-If the code in the expansion has insufficient explicit or implicit argument
-type checking, then it should cause checks to be generated by making
-declarations.
-
-A transformation may decide to pass if it doesn't like what it sees when it
-looks at the args.  The Give-Up function unwinds out of the transform and deals
-with complaining about inefficiency if speed is more important than brevity.
-The format args for the message are arguments to Give-Up.  If a transform can't
-be done, we just record the message where ICR finalize can find it.  note.  We
-can't complain immediately, since it might get transformed later on.
-
-
-\section{Backward ICR optimizations}
-
-In the backward pass, we scan each block in reverse order, and
-eliminate any effectless nodes with unused values.  In ICR this is the
-only way that code is deleted other than the elimination of unreachable blocks.
-
-
-\chapter{Type checking}
-
-[\#\#\# Somehow split this section up into three parts:
- -- Conceptual: how we know a check is necessary, and who is responsible for
-    doing checks.
- -- Incremental: intersection of derived and asserted types, checking for
-    non-subtype relationship.
- -- Check generation phase.
-]
-
-
-We need to do a pretty good job of guessing when a type check will ultimately
-need to be done.  Generic arithmetic, for example: In the absence of
-declarations, we will use use the safe variant, but if we don't know this, we
-will generate a check for NUMBER anyway.  We need to look at the fast-safe
-templates and guess if any of them could apply.
-
-We compute a function type from the VOP arguments
-and assertions on those arguments.  This can be used with Valid-Function-Use
-to see which templates do or might apply to a particular call.  If we guess
-that a safe implementation will be used, then we mark the continuation so as to
-force a safe implementation to be chosen.  [This will happen if ICR optimize
-doesn't run to completion, so the icr optimization after type check generation
-can discover new type information.  Since we won't redo type check at that
-point, there could be a call that has applicable unsafe templates, but isn't
-type checkable.]
-
-[\#\#\# A better and more general optimization of structure type checks: in type
-check conversion, we look at the *original derived* type of the continuation:
-if the difference between the proven type and the asserted type is a simple
-type check, then check for the negation of the difference.  e.g. if we want a
-FOO and we know we've got (OR FOO NULL), then test for (NOT NULL).  This is a
-very important optimization for linked lists of structures, but can also apply
-in other situations.]
-
-If after ICR phases, we have a continuation with check-type set in a context
-where it seems likely a check will be emitted, and the type is too 
-hairy to be easily checked (i.e. no CHECK-xxx VOP), then we do a transformation
-on the ICR equivalent to:
-  (... (the hair <foo>) ...)
-==>
-  (... (funcall \#'(lambda (\#:val)
-		    (if (typep \#:val 'hair)
-			\#:val
-			(%type-check-error \#:val 'hair)))
-		<foo>)
-       ...)
-This way, we guarantee that VMR conversion never has to emit type checks for
-hairy types.
-
-[Actually, we need to do a MV-bind and several type checks when there is a MV
-continuation.  And some values types are just too hairy to check.  We really
-can't check any assertion for a non-fixed number of values, since there isn't
-any efficient way to bind arbitrary numbers of values.  (could be done with
-MV-call of a more-arg function, I guess...)
-]
-
-[Perhaps only use CHECK-xxx VOPs for types equivalent to a ptype?  Exceptions
-for CONS and SYMBOL?  Anyway, no point in going to trouble to implement and
-emit rarely used CHECK-xxx vops.]
-
-One potential lose in converting a type check to explicit conditionals rather
-than to a CHECK-xxx VOP is that VMR code motion optimizations won't be able to
-do anything.  This shouldn't be much of an issue, though, since type constraint
-propagation has already done global optimization of type checks.
-
-
-This phase is optional, but should be done if anything is more important than
-compile speed.  
-
-Type check is responsible for reconciling the continuation asserted and derived
-types, emitting type checks if appropriate.  If the derived type is a subtype
-of the asserted type, then we don't need to do anything.
-
-If there is no intersection between the asserted and derived types, then there
-is a manifest type error.  We print a warning message, indicating that
-something is almost surely wrong.  This will inhibit any transforms or
-generators that care about their argument types, yet also inhibits further
-error messages, since NIL is a subtype of every type.
-
-If the intersection is not null, then we set the derived type to the
-intersection of the asserted and derived types and set the Type-Check flag in
-the continuation.  We always set the flag when we can't prove that the type
-assertion is satisfied, regardless of whether we will ultimately actually emit
-a type check or not.  This is so other phases such as type constraint
-propagation can use the Type-Check flag to detect an interesting type
-assertion, instead of having to duplicate much of the work in this phase.  
-[\#\#\# 7 extremely random values for CONTINUATION-TYPE-CHECK.]
-
-Type checks are generated on the fly during VMR conversion.  When VMR
-conversion generates the check, it prints an efficiency note if speed is
-important.  We don't flame now since type constraint progpagation may decide
-that the check is unnecessary.  [\#\#\# Not done now, maybe never.]
-
-In local function call, it is the caller that is in effect responsible for
-checking argument types.  This happens in the same way as any other type check,
-since ICR optimize propagates the declared argument types to the type
-assertions for the argument continuations in all the calls.
-
-Since the types of arguments to entry points are unknown at compile time, we
-want to do runtime checks to ensure that the incoming arguments are of the
-correct type.  This happens without any special effort on the part of type
-check, since the XEP is represented as a local call with unknown type
-arguments.  These arguments will be marked as needing to be checked.
-
-
-\chapter{Constraint propagation}
-
-\#|
-New lambda-var-slot:
-
-constraints: a list of all the constraints on this var for either X or Y.
-
-How to maintain consistency?  Does it really matter if there are constraints
-with deleted vars lying around?  Note that whatever mechanism we use for
-getting the constraints in the first place should tend to keep them up to date.
-Probably we would define optimizers for the interesting relations that look at
-their CONT's dest and annotate it if it is an IF.
-
-But maybe it is more trouble then it is worth trying to build up the set of
-constraints during ICR optimize (maintaining consistency in the process).
-Since ICR optimize iterates a bunch of times before it converges, we would be
-wasting time recomputing the constraints, when nobody uses them till constraint
-propagation runs.  
-
-It seems that the only possible win is if we re-ran constraint propagation
-(which we might want to do.)  In that case, we wouldn't have to recompute all
-the constraints from scratch.  But it seems that we could do this just as well
-by having ICR optimize invalidate the affected parts of the constraint
-annotation, rather than trying to keep them up to date.  This also fits better
-with the optional nature of constraint propagation, since we don't want ICR
-optimize to commit to doing a lot of the work of constraint propagation.  
-
-For example, we might have a per-block flag indicating that something happened
-in that block since the last time constraint propagation ran.  We might have
-different flags to represent the distinction between discovering a new type
-assertion inside the block and discovering something new about an if
-predicate, since the latter would be cheaper to update and probably is more
-common.
-
-It's fairly easy to see how we can build these sets of restrictions and
-propagate them using flow analysis, but actually using this information seems
-a bit more ad-hoc.  
-
-Probably the biggest thing we do is look at all the refs.  If have proven that
-the value is EQ (EQL for a number) to some other leaf (constant or lambda-var),
-then we can substitute for that reference.  In some cases, we will want to do
-special stuff depending on the DEST.  If the dest is an IF and we proved (not
-null), then we can substitute T.  And if the dest is some relation on the same
-two lambda-vars, then we want to see if we can show that relation is definitely
-true or false.
-
-Otherwise, we can do our best to invert the set of restrictions into a type.
-Since types hold only constant info, we have to ignore any constraints between
-two vars.  We can make some use of negated type restrictions by using
-TYPE-DIFFERENCE to remove the type from the ref types.  If our inferred type is
-as good as the type assertion, then the continuation's type-check flag will be
-cleared.
-
-It really isn't much of a problem that we don't infer union types on joins,
-since union types are relatively easy to derive without using flow information.
-The normal bottom-up type inference done by ICR optimize does this for us: it
-annotates everything with the union of all of the things it might possibly be.
-Then constraint propagation subtracts out those types that can't be in effect
-because of predicates or checks.
-
-
-
-This phase is optional, but is desirable if anything is more important than
-compilation speed.  We use an algorithm similar to available expressions to
-propagate variable type information that has been discovered by implicit or
-explicit type tests, or by type inference.
-
-We must do a pre-pass which locates set closure variables, since we cannot do
-flow analysis on such variables.  We set a flag in each set closure variable so
-that we can quickly tell that it is losing when we see it again.  Although this
-may seem to be wastefully redundant with environment analysis, the overlap
-isn't really that great, and the cost should be small compared to that of the
-flow analysis that we are preparing to do.  [Or we could punt on set
-variables...]
-
-A type constraint is a structure that includes sset-element and has the type
-and variable.  
-[\#\#\# Also a not-p flag indicating whether the sense is negated.]
-  Each variable has a list of its type constraints.  We create a
-type constraint when we see a type test or check.  If there is already a
-constraint for the same variable and type, then we just re-use it.  If there is
-already a weaker constraint, then we generate both the weak constraints and the
-strong constraint so that the weak constraints won't be lost even if the strong
-one is unavailable.
-
-We find all the distinct type constraints for each variable during the pre-pass
-over the lambda nesting.  Each constraint has a list of the weaker constraints
-so that we can easily generate them.
-
-Every block generates all the type constraints in it, but a constraint is
-available in a successor only if it is available in all predecessors.  We
-determine the actual type constraint for a variable at a block by intersecting
-all the available type constraints for that variable.
-
-This isn't maximally tense when there are constraints that are not
-hierarchically related, e.g. (or a b) (or b c).  If these constraints were
-available from two predecessors, then we could infer that we have an (or a b c)
-constraint, but the above algorithm would come up with none.  This probably
-isn't a big problem.
-
-[\#\#\# Do we want to deal with (if (eq <var> '<foo>) ...) indicating singleton
-member type?]
-
-We detect explicit type tests by looking at type test annotation in the IF
-node.  If there is a type check, the OUT sets are stored in the node, with
-different sets for the consequent and alternative.  Implicit type checks are
-located by finding Ref nodes whose Cont has the Type-Check flag set.  We don't
-actually represent the GEN sets, we just initialize OUT to it, and then form
-the union in place.
-
-When we do the post-pass, we clear the Type-Check flags in the continuations
-for Refs when we discover that the available constraints satisfy the asserted
-type.  Any explicit uses of typep should be cleaned up by the ICR optimizer for
-typep.  We can also set the derived type for Refs to the intersection of the
-available type assertions.  If we discover anything, we should consider redoing
-ICR optimization, since better type information might enable more
-optimizations.
-
-
-\chapter{ICR finalize} % -*- Dictionary: design -*-
-
-This pass looks for interesting things in the ICR so that we can forget about
-them.  Used and not defined things are flamed about.
-
-We postpone these checks until now because the ICR optimizations may discover
-errors that are not initially obvious.  We also emit efficiency notes about
-optimizations that we were unable to do.  We can't emit the notes immediately,
-since we don't know for sure whether a repeated attempt at optimization will
-succeed.
-
-We examine all references to unknown global function variables and update the
-approximate type accordingly.  We also record the names of the unknown
-functions so that they can be flamed about if they are never defined.  Unknown
-normal variables are flamed about on the fly during ICR conversion, so we
-ignore them here.
-
-We check each newly defined global function for compatibility with previously
-recorded type information.  If there is no :defined or :declared type, then we
-check for compatibility with any approximate function type inferred from
-previous uses.
-	
-\chapter{Environment analysis}
-\#|
-
-A related change would be to annotate ICR with information about tail-recursion
-relations.  What we would do is add a slot to the node structure that points to
-the corresponding Tail-Info when a node is in a TR position.  This annotation
-would be made in a final ICR pass that runs after cleanup code is generated
-(part of environment analysis).  When true, the node is in a true TR position
-(modulo return-convention incompatibility).  When we determine return
-conventions, we null out the tail-p slots in XEP calls or known calls where we
-decided not to preserve tail-recursion. 
-
-
-In this phase, we also check for changes in the dynamic binding environment
-that require cleanup code to be generated.  We just check for changes in the
-Continuation-Cleanup on local control transfers.  If it changes from
-an inner dynamic context to an outer one that is in the same environment, then
-we emit code to clean up the dynamic bindings between the old and new
-continuation.  We represent the result of cleanup detection to the back end by
-interposing a new block containing a call to a funny function.  Local exits
-from CATCH or UNWIND-PROTECT are detected in the same way.
-
-
-|\#
-
-The primary activity in environment analysis is the annotation of ICR with
-environment structures describing where variables are allocated and what values
-the environment closes over.
-
-Each lambda points to the environment where its variables are allocated, and
-the environments point back.  We always allocate the environment at the Bind
-node for the sole non-let lambda in the environment, so there is a close
-relationship between environments and functions.  Each "real function" (i.e.
-not a LET) has a corresponding environment.
-
-We attempt to share the same environment among as many lambdas as possible so
-that unnecessary environment manipulation is not done.  During environment
-analysis the only optimization of this sort is realizing that a Let (a lambda
-with no Return node) cannot need its own environment, since there is no way
-that it can return and discover that its old values have been clobbered.
-
-When the function is called, values from other environments may need to be made
-available in the function's environment.  These values are said to be "closed
-over".
-
-Even if a value is not referenced in a given environment, it may need to be
-closed over in that environment so that it can be passed to a called function
-that does reference the value.  When we discover that a value must be closed
-over by a function, we must close over the value in all the environments where
-that function is referenced.  This applies to all references, not just local
-calls, since at other references we must have the values on hand so that we can
-build a closure.  This propagation must be applied recursively, since the value
-must also be available in *those* functions' callers.
-
-If a closure reference is known to be "safe" (not an upward funarg), then the
-closure structure may be allocated on the stack.
-
-Closure analysis deals only with closures over values, while Common Lisp
-requires closures over variables.  The difference only becomes significant when
-variables are set.  If a variable is not set, then we can freely make copies of
-it without keeping track of where they are.  When a variable is set, we must
-maintain a single value cell, or at least the illusion thereof.  We achieve
-this by creating a heap-allocated "value cell" structure for each set variable
-that is closed over.  The pointer to this value cell is passed around as the
-"value" corresponding to that variable.  References to the variable must
-explicitly indirect through the value cell.
-
-When we are scanning over the lambdas in the component, we also check for bound
-but not referenced variables.
-
-Environment analysis emits cleanup code for local exits and markers for
-non-local exits.
-
-A non-local exit is a control transfer from one environment to another.  In a
-non-local exit, we must close over the continuation that we transfer to so that
-the exiting function can find its way back.  We indicate the need to close a
-continuation by placing the continuation structure in the closure and also
-pushing it on a list in the environment structure for the target of the exit.
-[\#\#\# To be safe, we would treat the continuation as a set closure variable so
-that we could invalidate it when we leave the dynamic extent of the exit point.
-Transferring control to a meaningless stack pointer would be apt to cause
-horrible death.]
-
-Each local control transfer may require dynamic state such as special bindings
-to be undone.  We represent cleanup actions by funny function calls in a new
-block linked in as an implicit MV-PROG1.
-
diff --git a/docs/internals/glossary.tex b/docs/internals/glossary.tex
deleted file mode 100644
index 1befb2191c32a92062858ef6f420aa4b9b8c6644..0000000000000000000000000000000000000000
--- a/docs/internals/glossary.tex
+++ /dev/null
@@ -1,411 +0,0 @@
-\chapter{Glossary}% -*- Dictionary: int:design -*-
-
-% Note: in an entry, any word that is also defined should be \it
-% should entries have page references as well?
-
-\begin{description}
-\item[assert (a type)]
-In Python, all type checking is done via a general type assertion
-mechanism.  Explicit declarations and implicit assertions (e.g. the arg to
-+ is a number) are recorded in the front-end (implicit continuation)
-representation.  Type assertions (and thus type-checking) are "unbundled"
-from the operations that are affected by the assertion.  This has two major
-advantages:
-\begin{itemize}
-\item Code that implements operations need not concern itself with checking
-operand types.
-
-\item Run-time type checks can be eliminated when the compiler can prove that
-the assertion will always be satisfied.
-\end{itemize}
-See also {\it restrict}.
-
-\item[back end] The back end is the part of the compiler that operates on the
-{\it virtual machine} intermediate representation.  Also included are the
-compiler phases involved in the conversion from the {\it front end}
-representation (or {\it ICR}).
-
-\item[bind node] This is a node type the that marks the start of a {\it lambda}
-body in {\it ICR}.  This serves as a placeholder for environment manipulation
-code.
-
-\item[IR1] The first intermediate representation, also known as {\it ICR}, or
-the Implicit Continuation Represenation.
-
-\item[IR2] The second intermediate representation, also known as {\it VMR}, or
-the Virtual Machine Representation.
-
-\item[basic block] A basic block (or simply "block") has the pretty much the
-usual meaning of representing a straight-line sequence of code.  However, the
-code sequence ultimately generated for a block might contain internal branches
-that were hidden inside the implementation of a particular operation.  The type
-of a block is actually {\tt cblock}.  The {\tt block-info} slot holds an 
-{\tt VMR-block} containing backend information.
-
-\item[block compilation] Block compilation is a term commonly used to describe
-the compile-time resolution of function names.  This enables many
-optimizations.
-
-\item[call graph]
-Each node in the call graph is a function (represented by a {\it flow graph}.)
-The arcs in the call graph represent a possible call from one function to
-another.  See also {\it tail set}.
-
-\item[cleanup]
-A cleanup is the part of the implicit continuation representation that
-retains information scoping relationships.  For indefinite extent bindings
-(variables and functions), we can abandon scoping information after ICR
-conversion, recovering the lifetime information using flow analysis.  But
-dynamic bindings (special values, catch, unwind protect, etc.) must be
-removed at a precise time (whenever the scope is exited.)  Cleanup
-structures form a hierarchy that represents the static nesting of dynamic
-binding structures.  When the compiler does a control transfer, it can use
-the cleanup information to determine what cleanup code needs to be emitted.
-
-\item[closure variable]
-A closure variable is any lexical variable that has references outside of
-its {\it home environment}.  See also {\it indirect value cell}.
-
-\item[closed continuation] A closed continuation represents a {\tt tagbody} tag
-or {\tt block} name that is closed over.  These two cases are mostly
-indistinguishable in {\it ICR}.
-
-\item[home] Home is a term used to describe various back-pointers.  A lambda
-variable's "home" is the lambda that the variable belongs to.  A lambda's "home
-environment" is the environment in which that lambda's variables are allocated.
-
-\item[indirect value cell]
-Any closure variable that has assignments ({\tt setq}s) will be allocated in an
-indirect value cell.  This is necessary to ensure that all references to
-the variable will see assigned values, since the compiler normally freely
-copies values when creating a closure.
-
-\item[set variable] Any variable that is assigned to is called a "set
-variable".  Several optimizations must special-case set variables, and set
-closure variables must have an {\it indirect value cell}.
-
-\item[code generator] The code generator for a {\it VOP} is a potentially
-arbitrary list code fragment which is responsible for emitting assembly code to
-implement that VOP.
-
-\item[constant pool] The part of a compiled code object that holds pointers to
-non-immediate constants.
-
-\item[constant TN]
-A constant TN is the {\it VMR} of a compile-time constant value.  A
-constant may be immediate, or may be allocated in the {\it constant pool}.
-
-\item[constant leaf]
-A constant {\it leaf} is the {\it ICR} of a compile-time constant value.
-
-\item[combination]
-A combination {\it node} is the {\it ICR} of any fixed-argument function
-call (not {\tt apply} or {\tt multiple-value-call}.)  
-
-\item[top-level component]
-A top-level component is any component whose only entry points are top-level
-lambdas.
-
-\item[top-level lambda]
-A top-level lambda represents the execution of the outermost form on which
-the compiler was invoked.  In the case of {\tt compile-file}, this is often a
-truly top-level form in the source file, but the compiler can recursively
-descend into some forms ({\tt eval-when}, etc.) breaking them into separate
-compilations.
-
-\item[component] A component is basically a sequence of blocks.  Each component
-is compiled into a separate code object.  With {\it block compilation} or {\it
-local functions}, a component will contain the code for more than one function.
-This is called a component because it represents a connected portion of the
-call graph.  Normally the blocks are in depth-first order ({\it DFO}).
-
-\item[component, initial] During ICR conversion, blocks are temporarily
-assigned to initial components.  The "flow graph canonicalization" phase
-determines the true component structure.
-
-\item[component, head and tail]
-The head and tail of a component are dummy blocks that mark the start and
-end of the {\it DFO} sequence.  The component head and tail double as the root
-and finish node of the component's flow graph.
-
-\item[local function (call)]
-A local function call is a call to a function known at compile time to be
-in the same {\it component}.  Local call allows compile time resolution of the
-target address and calling conventions.  See {\it block compilation}.
-
-\item[conflict (of TNs, set)]
-Register allocation terminology.  Two TNs conflict if they could ever be
-live simultaneously.  The conflict set of a TN is all TNs that it conflicts
-with.
-
-\item[continuation]
-The ICR data structure which represents both:
-\begin{itemize}
-\item The receiving of a value (or multiple values), and
-
-\item A control location in the flow graph.
-\end{itemize}
-In the Implicit Continuation Representation, the environment is implicit in the
-continuation's BLOCK (hence the name.)  The ICR continuation is very similar to
-a CPS continuation in its use, but its representation doesn't much resemble (is
-not interchangeable with) a lambda.
-
-\item[cont] A slot in the {\it node} holding the {\it continuation} which
-receives the node's value(s).  Unless the node ends a {\it block}, this also
-implicitly indicates which node should be evaluated next.
-
-\item[cost] Approximations of the run-time costs of operations are widely used
-in the back end.  By convention, the unit is generally machine cycles, but the
-values are only used for comparison between alternatives.  For example, the
-VOP cost is used to determine the preferred order in which to try possible
-implementations.
-    
-\item[CSP, CFP] See {\it control stack pointer} and {\it control frame
-pointer}.
-
-\item[Control stack] The main call stack, which holds function stack frames.
-All words on the control stack are tagged {\it descriptors}.  In all ports done
-so far, the control stack grows from low memory to high memory.  The most
-recent call frames are considered to be ``on top'' of earlier call frames.
-
-\item[Control stack pointer] The allocation pointer for the {\it control
-stack}.  Generally this points to the first free word at the top of the stack.
-
-\item[Control frame pointer] The pointer to the base of the {\it control stack}
-frame for a particular function invocation.  The CFP for the running function
-must be in a register.
-
-\item[Number stack] The auxiliary stack used to hold any {\it non-descriptor}
-(untagged) objects.  This is generally the same as the C call stack, and thus
-typically grows down.
-
-\item[Number stack pointer] The allocation pointer for the {\it number stack}.
-This is typically the C stack pointer, and is thus kept in a register.
-
-\item[NSP, NFP] See {\it number stack pointer}, {\it number frame pointer}.
-
-\item[Number frame pointer] The pointer to the base of the {\it number stack}
-frame for a particular function invocation.  Functions that don't use the
-number stack won't have an NFP, but if an NFP is allocated, it is always
-allocated in a particular register.  If there is no variable-size data on the
-number stack, then the NFP will generally be identical to the NSP.
-
-\item[Lisp return address] The name of the {\it descriptor} encoding the
-"return pc" for a function call.
-
-\item[LRA] See {\it lisp return address}.  Also, the name of the register where
-the LRA is passed.
-
-
-\item[Code pointer] A pointer to the header of a code object.  The code pointer
-for the currently running function is stored in the {\tt code} register.
-
-\item[Interior pointer] A pointer into the inside of some heap-allocated
-object.  Interior pointers confuse the garbage collector, so their use is
-highly constrained.  Typically there is a single register dedicated to holding
-interior pointers.
-
-\item[dest]
-A slot in the {\it continuation} which points the the node that receives this
-value.  Null if this value is not received by anyone.
-
-\item[DFN, DFO] See {\it Depth First Number}, {\it Depth First Order}.
-
-\item[Depth first number] Blocks are numbered according to their appearance in
-the depth-first ordering (the {\tt block-number} slot.)  The numbering actually
-increases from the component tail, so earlier blocks have larger numbers.
-
-\item[Depth first order] This is a linearization of the flow graph, obtained by
-a depth-first walk.  Iterative flow analysis algorithms work better when blocks
-are processed in DFO (or reverse DFO.)
-
-
-\item[Object] In low-level design discussions, an object is one of the
-following:
-\begin{itemize}
-\item a single word containing immediate data (characters, fixnums, etc)
-\item a single word pointing to an object (structures, conses, etc.)
-\end{itemize}
-These are tagged with three low-tag bits as described in the section
-\ref{tagging} This is synonymous with {\it descriptor}.
-In other parts of the documentation, may be used more loosely to refer to a
-{\it lisp object}.
-
-\item[Lisp object]
-A Lisp object is a high-level object discussed as a data type in the Common
-Lisp definition.
-
-\item[Data-block]
-A data-block is a dual-word aligned block of memory that either manifests a
-Lisp object (vectors, code, symbols, etc.) or helps manage a Lisp object on
-the heap (array header, function header, etc.).
-
-\item[Descriptor]
-A descriptor is a tagged, single-word object.  It either contains immediate
-data or a pointer to data.  This is synonymous with {\it object}.  Storage
-locations that must contain descriptors are referred to as descriptor
-locations.
-
-\item[Pointer descriptor]
-A descriptor that points to a {\it data block} in memory (i.e. not an immediate
-object.)
-
-\item[Immediate descriptor]
-A descriptor that encodes the object value in the descriptor itself; used for
-characters, fixnums, etc.
-
-\item[Word]
-A word is a 32-bit quantity.
-
-\item[Non-descriptor]
-Any chunk of bits that isn't a valid tagged descriptor.  For example, a
-double-float on the number stack.  Storage locations that are not scanned by
-the garbage collector (and thus cannot contain {\it pointer descriptors}) are
-called non-descriptor locations.  {\it Immediate descriptors} can be stored in
-non-descriptor locations.
-
-
-\item[Entry point] An entry point is a function that may be subject to
-``unpredictable'' control transfers.  All entry points are linked to the root
-of the flow graph (the component head.)  The only functions that aren't entry
-points are {\it let} functions.  When complex lambda-list syntax is used,
-multiple entry points may be created for a single lisp-level function.
-See {\it external entry point}.
-
-\item[External entry point] A function that serves as a ``trampoline'' to
-intercept function calls coming in from outside of the component.  The XEP does
-argument syntax and type checking, and may also translate the arguments and
-return values for a locally specialized calling calling convention.
-
-\item[XEP] An {\it external entry point}.
-
-\item[lexical environment] A lexical environment is a structure that is used
-during VMR conversion to represent all lexically scoped bindings (variables,
-functions, declarations, etc.)  Each {\tt node} is annotated with its lexical
-environment, primarily for use by the debugger and other user interfaces.  This
-structure is also the environment object passed to {\tt macroexpand}.
-
-\item[environment] The environment is part of the ICR, created during
-environment analysis.  Environment analysis apportions code to disjoint
-environments, with all code in the same environment sharing the same stack
-frame.  Each environment has a ``{\it real}'' function that allocates it, and
-some collection {\tt let} functions.   Although environment analysis is the
-last ICR phase, in earlier phases, code is sometimes said to be ``in the
-same/different environment(s)''.  This means that the code will definitely be
-in the same environment (because it is in the same real function), or that is
-might not be in the same environment, because it is not in the same function.
-
-\item[fixup]  Some sort of back-patching annotation.  The main sort encountered
-are load-time {\it assembler fixups}, which are a linkage annotation mechanism.
-
-\item[flow graph] A flow graph is a directed graph of basic blocks, where each
-arc represents a possible control transfer.  The flow graph is the basic data
-structure used to represent code, and provides direct support for data flow
-analysis.  See component and ICR.
-
-\item[foldable] An attribute of {\it known functions}.  A function is foldable
-if calls may be constant folded whenever the arguments are compile-time
-constant.  Generally this means that it is a pure function with no side
-effects.
-
-
-FSC
-full call
-function attribute
-function
-	"real" (allocates environment)
-	meaning function-entry
-	more vague (any lambda?)
-funny function
-GEN (kill and...)
-global TN, conflicts, preference
-GTN (number)
-IR ICR VMR  ICR conversion, VMR conversion (translation)
-inline expansion, call
-kill (to make dead)
-known function
-LAMBDA
-leaf
-let call
-lifetime analysis, live (tn, variable)
-load tn
-LOCS (passing, return locations)
-local call
-local TN, conflicts, (or just used in one block)
-location (selection)
-LTN (number)
-main entry
-mess-up (for cleanup)
-more arg (entry)
-MV
-non-local exit
-non-packed SC, TN
-non-set variable
-operand (to vop)
-optimizer (in icr optimize)
-optional-dispatch
-pack, packing, packed
-pass (in a transform)
-passing 
-	locations (value)
-	conventions (known, unknown)
-policy (safe, fast, small, ...)
-predecessor block
-primitive-type
-reaching definition
-REF
-representation
-	selection
-	for value
-result continuation (for function)
-result type assertion (for template) (or is it restriction)
-restrict
-	a TN to finite SBs
-	a template operand to a primitive type (boxed...)
-	a tn-ref to particular SCs
-
-return (node, vops)
-safe, safety
-saving (of registers, costs)
-SB
-SC (restriction)
-semi-inline
-side-effect
-	in ICR
-	in VMR
-sparse set
-splitting (of VMR blocks)
-SSET
-SUBPRIMITIVE
-successor block
-tail recursion
-	tail recursive
-	tail recursive loop
-	user tail recursion
-
-template
-TN
-TNBIND
-TN-REF
-transform (source, ICR)
-type
-	assertion
-	inference
-		top-down, bottom-up
-	assertion propagation
-        derived, asserted
-	descriptor, specifier, intersection, union, member type
-        check
-type-check (in continuation)
-UNBOXED (boxed) descriptor
-unknown values continuation
-unset variable
-unwind-block, unwinding
-used value (dest)
-value passing
-VAR
-VM
-VOP
-XEP
-
-\end{description}
diff --git a/docs/internals/interface.tex b/docs/internals/interface.tex
deleted file mode 100644
index 8a036452f2b6c0a344f366faab684fa3e3cc2c7e..0000000000000000000000000000000000000000
--- a/docs/internals/interface.tex
+++ /dev/null
@@ -1,6 +0,0 @@
-\chapter{User Interface}
-
-\section{Error Message Utilities}
-
-\section{Source Paths}
-
diff --git a/docs/internals/internal-design.txt b/docs/internals/internal-design.txt
deleted file mode 100644
index 071e1d93aaad705eee7fcf945110ccaf0c955f67..0000000000000000000000000000000000000000
--- a/docs/internals/internal-design.txt
+++ /dev/null
@@ -1,694 +0,0 @@
-
-
-;;;; Terminology.
-
-OBJECT
-   An object is one of the following:
-      a single word containing immediate data (characters, fixnums, etc)
-      a single word pointing to an object     (structures, conses, etc.)
-   These are tagged with three low-tag bits as described in the section
-   "Tagging".  This is synonymous with DESCRIPTOR.
-
-LISP OBJECT
-   A Lisp object is a high-level object discussed as a data type in Common
-   Lisp: The Language.
-
-DATA-BLOCK
-   A data-block is a dual-word aligned block of memory that either manifests a
-   Lisp object (vectors, code, symbols, etc.) or helps manage a Lisp object on
-   the heap (array header, function header, etc.).
-
-DESCRIPTOR
-   A descriptor is a tagged, single-word object.  It either contains immediate
-   data or a pointer to data.  This is synonymous with OBJECT.
-
-WORD
-   A word is a 32-bit quantity.
-
-
-
-;;;; Tagging.
-
-The following is a key of the three bit low-tagging scheme:
-   000 even fixnum
-   001 function pointer
-   010 other-immediate (header-words, characters, symbol-value trap value, etc.)
-   011 list pointer
-   100 odd fixnum
-   101 structure pointer
-   110 unused
-   111 other-pointer to data-blocks (other than conses, structures,
-   				     and functions)
-
-This taging scheme forces a dual-word alignment of data-blocks on the heap, but
-this can be pretty negligible:
-   RATIOS and COMPLEX must have a header-word anyway since they are not a
-      major type.  This wastes one word for these infrequent data-blocks since
-      they require two words for the data.
-   BIGNUMS must have a header-word and probably contain only one other word
-      anyway, so we probably don't waste any words here.  Most bignums just
-      barely overflow fixnums, that is by a bit or two.
-   Single and double FLOATS?
-      no waste
-      one word wasted
-   SYMBOLS are dual-word aligned with the header-word.
-   Everything else is vector-like including code, so these probably take up
-      so many words that one extra one doesn't matter.
-
-
-
-;;;; GC Comments.
-
-Data-Blocks comprise only descriptors, or they contain immediate data and raw
-bits interpreted by the system.  GC must skip the latter when scanning the
-heap, so it does not look at a word of raw bits and interpret it as a pointer
-descriptor.  These data-blocks require headers for GC as well as for operations
-that need to know how to interpret the raw bits.  When GC is scanning, and it
-sees a header-word, then it can determine how to skip that data-block if
-necessary.  Header-Words are tagged as other-immediates.  See the sections
-"Other-Immediates" and "Data-Blocks and Header-Words" for comments on
-distinguishing header-words from other-immediate data.  This distinction is
-necessary since we scan through data-blocks containing only descriptors just as
-we scan through the heap looking for header-words introducing data-blocks.
-
-Data-Blocks containing only descriptors do not require header-words for GC
-since the entire data-block can be scanned by GC a word at a time, taking
-whatever action is necessary or appropriate for the data in that slot.  For
-example, a cons is referenced by a descriptor with a specific tag, and the
-system always knows the size of this data-block.  When GC encounters a pointer
-to a cons, it can transport it into the new space, and when scanning, it can
-simply scan the two words manifesting the cons interpreting each word as a
-descriptor.  Actually there is no cons tag, but a list tag, so we make sure the
-cons is not nil when appropriate.  A header may still be desired if the pointer
-to the data-block does not contain enough information to adequately maintain
-the data-block.  An example of this is a simple-vector containing only
-descriptor slots, and we attach a header-word because the descriptor pointing
-to the vector lacks necessary information -- the type of the vector's elements,
-its length, etc.
-
-There is no need for a major tag for GC forwarding pointers.  Since the tag
-bits are in the low end of the word, a range check on the start and end of old
-space tells you if you need to move the thing.  This is all GC overhead.
-
-
-
-;;;; Structures.
-
-Structures comprise a word for each slot in the definition in addition to one
-word, a type slot which is a pointer descriptor.  This points to a structure
-describing the data-block as a structure, a defstruct-descriptor object.  When
-operating on a structure, doing a structure test can be done by simply checking
-the tag bits on the pointer descriptor referencing it.  As described in section
-"GC Comments", data-blocks such as those representing structures may avoid
-having a header-word since they are GC-scanable without any problem.  This
-saves two words for every structure instance.
-
-
-
-;;;; Fixnums.
-
-A fixnum has one of the following formats in 32 bits:
-    -------------------------------------------------------
-    |        30 bit 2's complement even integer   | 0 0 0 |
-    -------------------------------------------------------
-or
-    -------------------------------------------------------
-    |        30 bit 2's complement odd integer    | 1 0 0 |
-    -------------------------------------------------------
-
-Effectively, there is one tag for immediate integers, two zeros.  This buys one
-more bit for fixnums, and now when these numbers index into simple-vectors or
-offset into memory, they point to word boundaries on 32-bit, byte-addressable
-machines.  That is, no shifting need occur to use the number directly as an
-offset.
-
-This format has another advantage on byte-addressable machines when fixnums are
-offsets into vector-like data-blocks, including structures.  Even though we
-previously mentioned data-blocks are dual-word aligned, most indexing and slot
-accessing is word aligned, and so are fixnums with effectively two tag bits.
-
-Two tags also allow better usage of special instructions on some machines that
-can deal with two low-tag bits but not three.
-
-Since the two bits are zeros, we avoid having to mask them off before using the
-words for arithmetic, but division and multiplication require special shifting.
-
-
-
-;;;; Other-immediates.
-
-An other-immediate has the following format:
-   ----------------------------------------------------------------
-   |   Data (24 bits)        | Type (8 bits with low-tag) | 0 1 0 |
-   ----------------------------------------------------------------
-
-The system uses eight bits of type when checking types and defining system
-constants.  This allows allows for 32 distinct other-immediate objects given
-the three low-tag bits tied down.
-
-The system uses this format for characters, SYMBOL-VALUE unbound trap value,
-and header-words for data-blocks on the heap.  The type codes are laid out to
-facilitate range checks for common subtypes; for example, all numbers will have
-contiguous type codes which are distinct from the contiguous array type codes.
-See section "Data-Blocks and Other-immediates Typing" for details.
-
-
-
-;;;; Data-Blocks and Header-Word Format.
-
-Pointers to data-blocks have the following format:
-   ----------------------------------------------------------------
-   |      Dual-word address of data-block (29 bits)       | 1 1	1 |
-   ----------------------------------------------------------------
-
-The word pointed to by the above descriptor is a header-word, and it has the
-same format as an other-immediate:
-   ----------------------------------------------------------------
-   |   Data (24 bits)        | Type (8 bits with low-tag) | 0 1 0 |
-   ----------------------------------------------------------------
-
-This is convenient for scanning the heap when GC'ing, but it does mean that
-whenever GC encounters an other-immediate word, it has to do a range check on
-the low byte to see if it is a header-word or just a character (for example).
-This is easily acceptable performance hit for scanning.
-
-The system interprets the data portion of the header-word for non-vector
-data-blocks as the word length excluding the header-word.  For example, the
-data field of the header for ratio and complex numbers is two, one word each
-for the numerator and denominator or for the real and imaginary parts.
-
-For vectors and data-blocks representing Lisp objects stored like vectors, the
-system ignores the data portion of the header-word:
-   ----------------------------------------------------------------
-   | Unused Data (24 bits)   | Type (8 bits with low-tag) | 0 1 0 |
-   ----------------------------------------------------------------
-   |           Element Length of Vector (30 bits)           | 0 0 | 
-   ----------------------------------------------------------------
-
-Using a separate word allows for much larger vectors, and it allows LENGTH to
-simply access a single word without masking or shifting.  Similarly, the header
-for complex arrays and vectors has a second word, following the header-word,
-the system uses for the fill pointer, so computing the length of any array is
-the same code sequence.
-
-
-
-;;;; Data-Blocks and Other-immediates Typing.
-
-These are the other-immediate types.  We specify them including all low eight
-bits, including the other-immediate tag, so we can think of the type bits as
-one type -- not an other-immediate major type and a subtype.  Also, fetching a
-byte and comparing it against a constant is more efficient than wasting even a
-small amount of time shifting out the other-immediate tag to compare against a
-five bit constant.
-
-	   Number   (< 30)
-00000 010      bignum						10
-00000 010      ratio						14
-00000 010      single-float					18
-00000 010      double-float					22
-00000 010      complex						26
-
-	   Array   (>= 30 code 86)
-	      Simple-Array   (>= 20 code 70)
-00000 010	    simple-array				30
-	         Vector  (>= 34 code 82)
-00000 010	    simple-string				34
-00000 010	    simple-bit-vector				38
-00000 010	    simple-vector				42
-00000 010	    (simple-array (unsigned-byte 2) (*))	46
-00000 010	    (simple-array (unsigned-byte 4) (*))	50
-00000 010	    (simple-array (unsigned-byte 8) (*))	54
-00000 010	    (simple-array (unsigned-byte 16) (*))	58
-00000 010	    (simple-array (unsigned-byte 32) (*))	62
-00000 010	    (simple-array single-float (*))		66
-00000 010	    (simple-array double-float (*))		70
-00000 010	 complex-string					74
-00000 010	 complex-bit-vector				78
-00000 010	 (array * (*))   -- general complex vector.	82
-00000 010     complex-array					86
-
-00000 010  code-header-type					90
-00000 010  function-header-type					94
-00000 010  closure-header-type					98
-00000 010  funcallable-instance-header-type			102
-00000 010  unused-function-header-1-type			106
-00000 010  unused-function-header-2-type			110
-00000 010  unused-function-header-3-type			114
-00000 010  closure-function-header-type				118
-00000 010  return-pc-header-type				122
-00000 010  value-cell-header-type				126
-00000 010  symbol-header-type					130
-00000 010  base-character-type					134
-00000 010  system-area-pointer-type (header type)		138
-00000 010  unbound-marker					142
-00000 010  weak-pointer-type					146
-
-
-
-;;;; Strings.
-
-All strings in the system are C-null terminated.  This saves copying the bytes
-when calling out to C.  The only time this wastes memory is when the string
-contains a multiple of eight characters, and then the system allocates two more
-words (since Lisp objects are dual-word aligned) to hold the C-null byte.
-Since the system will make heavy use of C routines for systems calls and
-libraries that save reimplementation of higher level operating system
-functionality (such as pathname resolution or current directory computation),
-saving on copying strings for C should make C call out more efficient.
-
-The length word in a string header, see section "Data-Blocks and Header-Word
-Format", counts only the characters truly in the Common Lisp string.
-Allocation and GC will have to know to handle the extra C-null byte, and GC
-already has to deal with rounding up various objects to dual-word alignment.
-
-
-
-;;;; Symbols and NIL.
-
-Symbol data-block has the following format:
-    -------------------------------------------------------
-    |     5 (data-block words)     | Symbol Type (8 bits) |
-    -------------------------------------------------------
-    |   		Value Descriptor		  |
-    -------------------------------------------------------
-    |			Function Pointer 		  |
-    -------------------------------------------------------
-    |		      Raw Function Address 		  |
-    -------------------------------------------------------
-    |			 Setf Function	 		  |
-    -------------------------------------------------------
-    |			 Property List			  |
-    -------------------------------------------------------
-    |			   Print Name			  |
-    -------------------------------------------------------
-    |			    Package			  |
-    -------------------------------------------------------
-
-Most of these slots are self-explanatory given what symbols must do in Common
-Lisp, but a couple require comments.  We added the Raw Function Address slot to
-speed up named call which is the most common calling convention.  This is a
-non-descriptor slot, but since objects are dual word aligned, the value
-inherently has fixnum low-tag bits.  The GC method for symbols must know to
-update this slot.  The Setf Function slot is currently unused, but we had an
-extra slot due to adding Raw Function Address since objects must be dual-word
-aligned.
-
-The issues with nil are that we want it to act like a symbol, and we need list
-operations such as CAR and CDR to be fast on it.  CMU Common Lisp solves this
-by putting nil as the first object in static space, where other global values
-reside, so it has a known address in the system:
-    -------------------------------------------------------  <-- start static
-    |				0			  |      space
-    -------------------------------------------------------
-    |     5 (data-block words)     | Symbol Type (8 bits) |
-    -------------------------------------------------------  <-- nil
-    |			    Value/CAR			  |
-    -------------------------------------------------------
-    |			  Definition/CDR		  |
-    -------------------------------------------------------
-    |		       Raw Function Address 		  |
-    -------------------------------------------------------
-    |			  Setf Function	 		  |
-    -------------------------------------------------------
-    |			  Property List			  |
-    -------------------------------------------------------
-    |			    Print Name			  |
-    -------------------------------------------------------
-    |			     Package			  |
-    -------------------------------------------------------
-    |			       ...			  |
-    -------------------------------------------------------
-In addition, we make the list typed pointer to nil actually point past the
-header word of the nil symbol data-block.  This has usefulness explained below.
-The value and definition of nil are nil.  Therefore, any reference to nil used
-as a list has quick list type checking, and CAR and CDR can go right through
-the first and second words as if nil were a cons object.
-
-When there is a reference to nil used as a symbol, the system adds offsets to
-the address the same as it does for any symbol.  This works due to a
-combination of nil pointing past the symbol header-word and the chosen list and
-other-pointer type tags.  The list type tag is four less than the other-pointer
-type tag, but nil points four additional bytes into its symbol data-block.
-
-
-
-;;;; Array Headers.
-
-The array-header data-block has the following format:
-   ----------------------------------------------------------------
-   | Header Len (24 bits) = Array Rank +5   | Array Type (8 bits) |
-   ----------------------------------------------------------------
-   |               Fill Pointer (30 bits)                   | 0 0 | 
-   ----------------------------------------------------------------
-   |               Available Elements (30 bits)             | 0 0 | 
-   ----------------------------------------------------------------
-   |               Data Vector (29 bits)                  | 1 1 1 | 
-   ----------------------------------------------------------------
-   |               Displacement (30 bits)                   | 0 0 | 
-   ----------------------------------------------------------------
-   |               Displacedp (29 bits) -- t or nil       | 1 1 1 | 
-   ----------------------------------------------------------------
-   |               Range of First Index (30 bits)           | 0 0 | 
-   ----------------------------------------------------------------
-				  .
-				  .
-				  .
-
-The array type in the header-word is one of the eight-bit patterns from section
-"Data-Blocks and Other-immediates Typing", indicating that this is a complex
-string, complex vector, complex bit-vector, or a multi-dimensional array.  The
-data portion of the other-immediate word is the length of the array header
-data-block.  Due to its format, its length is always five greater than the
-array's number of dimensions.  The following words have the following
-interpretations and types:
-   Fill Pointer
-      This is a fixnum indicating the number of elements in the data vector
-      actually in use.  This is the logical length of the array, and it is
-      typically the same value as the next slot.  This is the second word, so
-      LENGTH of any array, with or without an array header, is just four bytes
-      off the pointer to it.
-   Available Elements
-      This is a fixnum indicating the number of elements for which there is
-      space in the data vector.  This is greater than or equal to the logical
-      length of the array when it is a vector having a fill pointer.
-   Data Vector
-      This is a pointer descriptor referencing the actual data of the array.
-      This a data-block whose first word is a header-word with an array type as
-      described in sections "Data-Blocks and Header-Word Format" and
-      "Data-Blocks and Other-immediates Typing"
-   Displacement
-      This is a fixnum added to the computed row-major index for any array.
-      This is typically zero.
-   Displacedp
-      This is either t or nil.  This is separate from the displacement slot, so
-      most array accesses can simply add in the displacement slot.  The rare
-      need to know if an array is displaced costs one extra word in array
-      headers which probably aren't very frequent anyway.
-   Range of First Index
-      This is a fixnum indicating the number of elements in the first dimension
-      of the array.  Legal index values are zero to one less than this number
-      inclusively.  IF the array is zero-dimensional, this slot is
-      non-existent.
-   ... (remaining slots)
-      There is an additional slot in the header for each dimension of the
-      array.  These are the same as the Range of First Index slot.
-
-
-
-;;;; Bignums.
-
-Bignum data-blocks have the following format:
-    -------------------------------------------------------
-    |      Length (24 bits)        | Bignum Type (8 bits) |
-    -------------------------------------------------------
-    |   	      least significant bits		  |
-    -------------------------------------------------------
-				.
-				.
-				.
-
-The elements contain the two's complement representation of the integer with
-the least significant bits in the first element or closer to the header.  The
-sign information is in the high end of the last element.
-
-
-
-
-;;;; Code Data-Blocks.
-
-A code data-block is the run-time representation of a "component".  A component
-is a connected portion of a program's flow graph that is compiled as a single
-unit, and it contains code for many functions.  Some of these functions are
-callable from outside of the component, and these are termed "entry points".
-
-Each entry point has an associated user-visible function data-block (of type
-FUNCTION).  The full call convention provides for calling an entry point
-specified by a function object.
-
-Although all of the function data-blocks for a component's entry points appear
-to the user as distinct objects, the system keeps all of the code in a single
-code data-block.  The user-visible function object is actually a pointer into
-the middle of a code data-block.  This allows any control transfer within a
-component to be done using a relative branch.
-
-Besides a function object, there are other kinds of references into the middle
-of a code data-block.  Control transfer into a function also occurs at the
-return-PC for a call.  The system represents a return-PC somewhat similarly to
-a function, so GC can also recognize a return-PC as a reference to a code
-data-block.
-
-It is incorrect to think of a code data-block as a concatenation of "function
-data-blocks".  Code for a function is not emitted in any particular order with
-respect to that function's function-header (if any).  The code following a
-function-header may only be a branch to some other location where the
-function's "real" definition is.
-
-
-The following are the three kinds of pointers to code data-blocks:
-   Code pointer (labeled A below):
-      A code pointer is a descriptor, with other-pointer low-tag bits, pointing
-      to the beginning of the code data-block.  The code pointer for the
-      currently running function is always kept in a register (CODE).  In
-      addition to allowing loading of non-immediate constants, this also serves
-      to represent the currently running function to the debugger.
-   Return-PC (labeled B below):
-      The return-PC is a descriptor, with other-pointer low-tag bits, pointing
-      to a location for a function call.  Note that this location contains no
-      descriptors other than the one word of immediate data, so GC can treat
-      return-PC locations the same as instructions.
-   Function (labeled C below):
-      A function is a descriptor, with function low-tag bits, that is user
-      callable.  When a function header is referenced from a closure or from
-      the function header's self-pointer, the pointer has other-pointer low-tag
-      bits, instead of function low-tag bits.  This ensures that the internal
-      function data-block associated with a closure appears to be uncallable
-      (although users should never see such an object anyway).
-
-      Information about functions that is only useful for entry points is kept
-      in some descriptors following the function's self-pointer descriptor.
-      All of these together with the function's header-word are known as the
-      "function header".  GC must be able to locate the function header.  We
-      provide for this by chaining together the function headers in a NIL
-      terminated list kept in a known slot in the code data-block.
-
-
-A code data-block has the following format:
-   ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++  <-- A
-   |  Header-Word count (24 bits)	  |  %Code-Type (8 bits)  |
-   ----------------------------------------------------------------
-   |  Number of code words (fixnum tag)				  |
-   ----------------------------------------------------------------
-   |  Pointer to first function header (other-pointer tag)	  |
-   ----------------------------------------------------------------
-   |  Debug information (structure tag)				  |
-   ----------------------------------------------------------------
-   |  First constant (a descriptor)				  |
-   ----------------------------------------------------------------
-   |  ...                       				  |
-   ----------------------------------------------------------------
-   |  Last constant (and last word of code header)           	  |
-   ----------------------------------------------------------------
-   |  Some instructions (non-descriptor)			  |
-   ----------------------------------------------------------------
-   |     (pad to dual-word boundary if necessary)		  |
-   ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++  <-- B
-   |  Word offset from code header (24)	  |  %Return-PC-Type (8)  |
-   ----------------------------------------------------------------
-   |  First instruction after return				  |
-   ----------------------------------------------------------------
-   |  ... more code and return-PC header-words			  |
-   ----------------------------------------------------------------
-   |     (pad to dual-word boundary if necessary)	  	  |
-   ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++  <-- C
-   |  Offset from code header (24)  |  %Function-Header-Type (8)  |
-   ----------------------------------------------------------------
-   |  Self-pointer back to previous word (with other-pointer tag) |
-   ----------------------------------------------------------------
-   |  Pointer to next function (other-pointer low-tag) or NIL	  |
-   ----------------------------------------------------------------
-   |  Function name (a string or a symbol)			  |
-   ----------------------------------------------------------------
-   |  Function debug arglist (a string)				  |
-   ----------------------------------------------------------------
-   |  Function type (a list-style function type specifier)	  |
-   ----------------------------------------------------------------
-   |  Start of instructions for function (non-descriptor)	  |
-   ----------------------------------------------------------------
-   |  More function headers and instructions and return PCs,	  |
-   |  until we reach the total size of header-words + code	  |
-   |  words.							  |
-   ----------------------------------------------------------------
-
-
-The following are detailed slot descriptions:
-   Code data-block header-word:
-      The immediate data in the code data-block's header-word is the number of
-      leading descriptors in the code data-block, the fixed overhead words plus
-      the number of constants.  The first non-descriptor word, some code,
-      appears at this word offset from the header.
-   Number of code words:
-      The total number of non-header-words in the code data-block.  The total
-      word size of the code data-block is the sum of this slot and the
-      immediate header-word data of the previous slot.  The system accesses
-      this slot with the system constant, %Code-Code-Size-Slot, offset from the
-      header-word.
-   Pointer to first function header:
-      A NIL-terminated list of the function headers for all entry points to
-      this component.  The system accesses this slot with the system constant,
-      %Code-Entry-Points-Slot, offset from the header-word.
-   Debug information:
-      The DEBUG-INFO structure describing this component.  All information that
-      the debugger wants to get from a running function is kept in this
-      structure.  Since there are many functions, the current PC is used to
-      locate the appropriate debug information.  The system keeps the debug
-      information separate from the function data-block, since the currently
-      running function may not be an entry point.  There is no way to recover
-      the function object for the currently running function, since this
-      data-block may not exist.  The system accesses this slot with the system
-      constant, %Code-Debug-Info-Slot, offset from the header-word.
-   First constant ... last constant:
-      These are the constants referenced by the component, if there are any.
-      The system accesses the first constant slot with the system constant,
-      %Code-Constants-Offset, offset from the header-word.
-
-   Return-PC header word:
-      The immediate header-word data is the word offset from the enclosing code
-      data-block's header-word to this word.  This allows GC and the debugger
-      to easily recover the code data-block from a return-PC.  The code at the
-      return point restores the current code pointer using a subtract immediate
-      of the offset, which is known at compile time.
-
-   Function entry point header-word:
-      The immediate header-word data is the word offset from the enclosing code
-      data-block's header-word to this word.  This is the same as for the
-      retrun-PC header-word.
-   Self-pointer back to header-word:
-      In a non-closure function, this self-pointer to the previous header-word
-      allows the call sequence to always indirect through the second word in a
-      user callable function.  See section "Closure Format".  With a closure,
-      indirecting through the second word gets you a function header-word.  The
-      system ignores this slot in the function header for a closure, since it
-      has already indirected once, and this slot could be some random thing
-      that causes an error if you jump to it.  This pointer has an
-      other-pointer tag instead of a function pointer tag, indicating it is not
-      a user callable Lisp object.  The system accesses this slot with the
-      system constant, %Function-Code-Slot, offset from the function
-      header-word.
-   Pointer to next function:
-      This is the next link in the thread of entry point functions found in
-      this component.  This value is NIL when the current header is the last
-      entry point in the component.  The system accesses this slot with the
-      system constant, %Function-Header-Next-Slot, offset from the function
-      header-word.
-   Function name:
-      This function's name (for printing).  If the user defined this function
-      with DEFUN, then this is the defined symbol, otherwise it is a
-      descriptive string.  The system accesses this slot with the system
-      constant, %Function-Header-Name-Slot, offset from the function
-      header-word.
-   Function debug arglist:
-      A printed string representing the function's argument list, for human
-      readability.  If it is a macroexpansion function, then this is the
-      original DEFMACRO arglist, not the actual expander function arglist.  The
-      system accesses this slot with the system constant,
-      %Function-Header-Debug-Arglist-Slot, offset from the function
-      header-word.
-   Function type:
-      A list-style function type specifier representing the argument signature
-      and return types for this function.  For example,
-         (FUNCTION (FIXNUM FIXNUM FIXNUM) FIXNUM)
-      or
-	 (FUNCTION (STRING &KEY (:START UNSIGNED-BYTE)) STRING)
-      This information is intended for machine readablilty, such as by the
-      compiler.  The system accesses this slot with the system constant,
-      %Function-Header-Type-Slot, offset from the function header-word.
-
-
-
-;;;; Closure Format.
-
-A closure data-block has the following format:
-   ----------------------------------------------------------------
-   |  Word size (24 bits)	         | %Closure-Type (8 bits) |
-   ----------------------------------------------------------------
-   |  Pointer to function header (other-pointer low-tag)	  |
-   ----------------------------------------------------------------
-   |				  .				  |
-   |	               Environment information                    |
-   |				  .				  |
-   ----------------------------------------------------------------
-
-
-A closure descriptor has function low-tag bits.  This means that a descriptor
-with function low-tag bits may point to either a function header or to a
-closure.  The idea is that any callable Lisp object has function low-tag bits.
-Insofar as call is concerned, we make the format of closures and non-closure
-functions compatible.  This is the reason for the self-pointer in a function
-header.  Whenever you have a callable object, you just jump through the second
-word, offset some bytes, and go.
-
-
-
-;;;; Function call.
-
-Due to alignment requirements and low-tag codes, it is not possible to use a
-hardware call instruction to compute the return-PC.  Instead the return-PC
-for a call is computed by doing an add-immediate to the start of the code
-data-block.
-
-An advantage of using a single data-block to represent both the descriptor and
-non-descriptor parts of a function is that both can be represented by a
-single pointer.  This reduces the number of memory accesses that have to be
-done in a full call.  For example, since the constant pool is implicit in a
-return-PC, a call need only save the return-PC, rather than saving both the
-return PC and the constant pool.
-
-
-
-;;;; Memory Layout.
-
-CMU Common Lisp has four spaces, read-only, static, dynamic-0, and dynamic-1.
-Read-only contains objects that the system never modifies, moves, or reclaims.
-Static space contains some global objects necessary for the system's runtime or
-performance (since they are located at a known offset at a know address), and
-the system never moves or reclaims these.  However, GC does need to scan static
-space for references to moved objects.  Dynamic-0 and dynamic-1 are the two
-heap areas for stop-and-copy GC algorithms.
-
-What global objects are at the head of static space???
-   NIL
-   eval::*top-of-stack*
-   lisp::*current-catch-block*
-   lisp::*current-unwind-protect*
-   FLAGS (RT only)
-   BSP (RT only)
-   HEAP (RT only)
-
-In addition to the above spaces, the system has a control stack, binding stack,
-and a number stack.  The binding stack contains pairs of descriptors, a symbol
-and its previous value.  The number stack is the same as the C stack, and the
-system uses it for non-Lisp objects such as raw system pointers, saving
-non-Lisp registers, parts of bignum computations, etc.
-
-
-
-;;;; System Pointers.
-
-The system pointers reference raw allocated memory, data returned by foreign
-function calls, etc.  The system uses these when you need a pointer to a
-non-Lisp block of memory, using an other-pointer.  This provides the greatest
-flexibility by relieving contraints placed by having more direct references
-that require descriptor type tags.
-
-A system area pointer data-block has the following format:
-    -------------------------------------------------------
-    |     1 (data-block words)        | SAP Type (8 bits) |
-    -------------------------------------------------------
-    |   	      system area pointer		  |
-    -------------------------------------------------------
-
-"SAP" means "system area pointer", and much of our code contains this naming
-scheme.  We don't currently restrict system pointers to one area of memory, but
-if they do point onto the heap, it is up to the user to prevent being screwed
-by GC or whatever.
diff --git a/docs/internals/interpreter.tex b/docs/internals/interpreter.tex
deleted file mode 100644
index c3d1c31812fb8842f8d71914d32228a1de7bbb70..0000000000000000000000000000000000000000
--- a/docs/internals/interpreter.tex
+++ /dev/null
@@ -1,191 +0,0 @@
-%  					-*- Dictionary: design; Package: C -*-
-
-May be worth having a byte-code representation for interpreted code.  This way,
-an entire system could be compiled into byte-code for debugging (the
-"check-out" compiler?).
-
-Given our current inclination for using a stack machine to interpret IR1, it
-would be straightforward to layer a byte-code interpreter on top of this.
-
-
-Interpreter:
-
-Instead of having no interpreter, or a more-or-less conventional interpreter,
-or byte-code interpreter, how about directly executing IR1?
-
-We run through the IR1 passes, possibly skipping optional ones, until we get
-through environment analysis.  Then we run a post-pass that annotates IR1 with
-information about where values are kept, i.e. the stack slot.
-
-We can lazily convert functions by having FUNCTION make an interpreted function
-object that holds the code (really a closure over the interpreter).  The first
-time that we try to call the function, we do the conversion and processing.
-Also, we can easily keep track of which interpreted functions we have expanded
-macros in, so that macro redefinition automatically invalidates the old
-expansion, causing lazy reconversion.
-
-Probably the interpreter will want to represent MVs by a recognizable structure
-that is always heap-allocated.  This way, we can punt the stack issues involved
-in trying to spread MVs.  So a continuation value can always be kept in a
-single cell.
-
-The compiler can have some special frobs for making the interpreter efficient,
-such as a call operation that extracts arguments from the stack
-slots designated by a continuation list.  Perhaps 
-    (values-mapcar fun . lists)
-<==>
-    (values-list (mapcar fun . lists))
-This would be used with MV-CALL.
-
-
-This scheme seems to provide nearly all of the advantages of both the compiler
-and conventional interpretation.  The only significant disadvantage with
-respect to a conventional interpreter is that there is the one-time overhead of
-conversion, but doing this lazily should make this quite acceptable.
-
-With respect to a conventional interpreter, we have major advantages:
- + Full syntax checking: safety comparable to compiled code.
- + Semantics similar to compiled code due to code sharing.  Similar diagnostic
-   messages, etc.  Reduction of error-prone code duplication.
- + Potential for full type checking according to declarations (would require
-   running IR1 optimize?)
- + Simplifies debugger interface, since interpreted code can look more like
-   compiled code: source paths, edit definition, etc.
-
-For all non-run-time symbol annotations (anything other than SYMBOL-FUNCTION
-and SYMBOL-VALUE), we use the compiler's global database.  MACRO-FUNCTION will
-use INFO, rather than vice-versa.
-
-When doing the IR1 phases for the interpreter, we probably want to suppress
-optimizations that change user-visible function calls:
- -- Don't do local call conversion of any named functions (even lexical ones).
-    This is so that a call will appear on the stack that looks like the call in
-    the original source.  The keyword and optional argument transformations
-    done by local call mangle things quite a bit.  Also, note local-call
-    converting prevents unreferenced arguments from being deleted, which is
-    another non-obvious transformation.
- -- Don't run source-transforms, IR1 transforms and IR1 optimizers.  This way,
-    TRACE and BACKTRACE will show calls with the original arguments, rather
-    than the "optimized" form, etc.  Also, for the interpreter it will
-    actually be faster to call the original function (which is compiled) than
-    to "inline expand" it.  Also, this allows implementation-dependent
-    transforms to expand into %PRIMITIVE uses.
-
-There are some problems with stepping, due to our non-syntactic IR1
-representation.  The source path information is the key that makes this
-conceivable.  We can skip over the stepping of a subform by quietly evaluating
-nodes whose source path lies within the form being skipped.
-
-One problem with determining what value has been returned by a form.  With a
-function call, it is theoretically possible to precisely determine this, since
-if we complete evaluation of the arguments, then we arrive at the Combination
-node whose value is synonymous with the value of the form.  We can even detect
-this case, since the Node-Source will be EQ to the form.  And we can also
-detect when we unwind out of the evaluation, since we will leave the form
-without having ever reached this node.
-
-But with macros and special-forms, there is no node whose value is the value of
-the form, and no node whose source is the macro call or special form.  We can
-still detect when we leave the form, but we can't be sure whether this was a
-normal evaluation result or an explicit RETURN-FROM.  
-
-But does this really matter?  It seems that we can print the value returned (if
-any), then just print the next form to step.  In the rare case where we did
-unwind, the user should be able to figure it out.  
-
-[We can look at this as a side-effect of CPS: there isn't any difference
-between a "normal" return and a non-local one.]
-
-[Note that in any control transfer (normal or otherwise), the stepper may need
-to unwind out of an arbitrary number of levels of stepping.  This is because a
-form in a TR position may yield its to a node arbitrarily far our.]
-
-Another problem is with deciding what form is being stepped.  When we start
-evaluating a node, we dive into code that is nested somewhere down inside that
-form.  So we actually have to do a loop of asking questions before we do any
-evaluation.  But what do we ask about?
-
-If we ask about the outermost enclosing form that is a subform of the the last
-form that the user said to execute, then we might offer a form that isn't
-really evaluated, such as a LET binding list.  
-
-But once again, is this really a problem?  It is certainly different from a
-conventional stepper, but a pretty good argument could be made that it is
-superior.  Haven't you ever wanted to skip the evaluation of all the
-LET bindings, but not the body?  Wouldn't it be useful to be able to skip the
-DO step forms?
-
-All of this assumes that nobody ever wants to step through the guts of a
-macroexpansion.  This seems reasonable, since steppers are for weenies, and
-weenies don't define macros (hence don't debug them).  But there are probably
-some weenies who don't know that they shouldn't be writing macros.
-
-We could handle this by finding the "source paths" in the expansion of each
-macro by sticking some special frob in the source path marking the place where
-the expansion happened.  When we hit code again that is in the source, then we
-revert to the normal source path.  Something along these lines might be a good
-idea anyway (for compiler error messages, for example).  
-
-The source path hack isn't guaranteed to work quite so well in generated code,
-though, since macros return stuff that isn't freshly consed.  But we could
-probably arrange to win as long as any given expansion doesn't return two EQ
-forms.
-
-It might be nice to have a command that skipped stepping of the form, but
-printed the results of each outermost enclosed evaluated subform, i.e. if you
-used this on the DO step-list, it would print the result of each new-value
-form.  I think this is implementable.  I guess what you would do is print each
-value delivered to a DEST whose source form is the current or an enclosing
-form.  Along with the value, you would print the source form for the node that
-is computing the value.
-
-The stepper can also have a "back" command that "unskips" or "unsteps".  This
-would allow the evaluation of forms that are pure (modulo lexical variable
-setting) to be undone.  This is useful, since in stepping it is common that you
-skip a form that you shouldn't have, or get confused and want to restart at
-some earlier point.
-
-What we would do is remember the current node and the values of all local
-variables.  heap before doing each step or skip action.  We can then back up
-the state of all lexical variables and the "program counter".  To make this
-work right with set closure variables, we would copy the cell's value, rather
-than the value cell itself.
-
-[To be fair, note that this could easily be done with our current interpreter:
-the stepper could copy the environment alists.]
-
-We can't back up the "program counter" when a control transfer leaves the
-current function, since this state is implicitly represented in the
-interpreter's state, and is discarded when we exit.  We probably want to ask
-for confirmation before leaving the function to give users a chance to "unskip"
-the forms in a TR position.
-
-Another question is whether the conventional stepper is really a good thing to
-imitate...  How about an editor-based mouse-driven interface?  Instead of
-"skipping" and "stepping", you would just designate the next form that you
-wanted to stop at.  Instead of displaying return values, you replace the source
-text with the printed representation of the value.
-
-It would show the "program counter" by highlighting the *innermost* form that
-we are about to evaluate, i.e. the source form for the node that we are stopped
-at.  It would probably also be useful to display the start of the form that was
-used to designate the next stopping point, although I guess this could be
-implied by the mouse position.
-
-
-Such an interface would be a little harder to implement than a dumb stepper,
-but it would be much easier to use.  [It would be impossible for an evalhook
-stepper to do this.]
-
-
-%PRIMITIVE usage:
-
-Note: %PRIMITIVE can only be used in compiled code.  It is a trapdoor into the
-compiler, not a general syntax for accessing "sub-primitives".  It's main use
-is in implementation-dependent compiler transforms.  It saves us the effort of
-defining a "phony function" (that is not really defined), and also allows
-direct communication with the code generator through codegen-info arguments.
-
-Some primitives may be exported from the VM so that %PRIMITIVE can be used to
-make it explicit that an escape routine or interpreter stub is assuming an
-operation is implemented by the compiler.
diff --git a/docs/internals/lowlev.tex b/docs/internals/lowlev.tex
deleted file mode 100644
index 7e6f13f357b2531612f7c6bd7a240a2c53fa2359..0000000000000000000000000000000000000000
--- a/docs/internals/lowlev.tex
+++ /dev/null
@@ -1,10 +0,0 @@
-\chapter{Memory Management}
-\section{Stacks and Globals}
-\section{Heap Layout}
-\section{Garbage Collection}
-
-\chapter{Interface to C and Assembler}
-
-\chapter{Low-level debugging}
-
-\chapter{Core File Format}
diff --git a/docs/internals/middle.tex b/docs/internals/middle.tex
deleted file mode 100644
index 7adc018170dc5b520db4bc2ee93b5ef3cb60a09d..0000000000000000000000000000000000000000
--- a/docs/internals/middle.tex
+++ /dev/null
@@ -1,649 +0,0 @@
-% -*- Dictionary: design -*-
-
-
-\chapter{Virtual Machine Representation Introduction}
-
-
-\chapter{Global TN assignment}
-
-[\#\#\# Rename this phase so as not to be confused with the local/global TN
-representation.]
-
-The basic mechanism for closing over values is to pass the values as additional
-implicit arguments in the function call.  This technique is only applicable
-when:
- -- the calling function knows which values the called function wants to close
-    over, and
- -- the values to be closed over are available in the calling environment.
-
-The first condition is always true of local function calls.  Environment
-analysis can guarantee that the second condition holds by closing over any
-needed values in the calling environment.
-
-If the function that closes over values may be called in an environment where
-the closed over values are not available, then we must store the values in a
-"closure" so that they are always accessible.  Closures are called using the
-"full call" convention.  When a closure is called, control is transferred to
-the "external entry point", which fetches the values out of the closure and
-then does a local call to the real function, passing the closure values as
-implicit arguments.
-
-In this scheme there is no such thing as a "heap closure variable" in code,
-since the closure values are moved into TNs by the external entry point.  There
-is some potential for pessimization here, since we may end up moving the values
-from the closure into a stack memory location, but the advantages are also
-substantial.  Simplicity is gained by always representing closure values the
-same way, and functions with closure references may still be called locally
-without allocating a closure.  All the TN based VMR optimizations will apply
-to closure variables, since closure variables are represented in the same way
-as all other variables in VMR.  Closure values will be allocated in registers
-where appropriate.
-
-Closures are created at the point where the function is referenced, eliminating
-the need to be able to close over closures.  This lazy creation of closures has
-the additional advantage that when a closure reference is conditionally not
-done, then the closure consing will never be done at all.  The corresponding
-disadvantage is that a closure over the same values may be created multiple
-times if there are multiple references.  Note however, that VMR loop and common
-subexpression optimizations can eliminate redundant closure consing.  In any
-case, multiple closures over the same variables doesn't seem to be that common.
-
-\#|
-Having the Tail-Info would also make return convention determination trivial.
-We could just look at the type, checking to see if it represents a fixed number
-of values.  To determine if the standard return convention is necessary to
-preserve tail-recursion, we just iterate over the equivalent functions, looking
-for XEPs and uses in full calls.
-|\#
-
-The Global TN Assignment pass (GTN) can be considered a post-pass to
-environment analysis.  This phase assigns the TNs used to hold local lexical
-variables and pass arguments and return values and determines the value-passing
-strategy used in local calls.
-
-To assign return locations, we look at the function's tail-set.
-
-If the result continuation for an entry point is used as the continuation for a
-full call, then we may need to constrain the continuation's values passing
-convention to the standard one.  This is not necessary when the call is known
-not to be part of a tail-recursive loop (due to being a known function).
-
-Once we have figured out where we must use the standard value passing strategy,
-we can use a more flexible strategy to determine the return locations for local
-functions.  We determine the possible numbers of return values from each
-function by examining the uses of all the result continuations in the
-equivalence class of the result continuation.
-
-If the tail-set type is for a fixed number of
-values, then we return that fixed number of values from all the functions whose
-result continuations are equated.  If the number of values is not fixed, then
-we must use the unknown-values convention, although we are not forced to use
-the standard locations.  We assign the result TNs at this time.
-
-We also use the tail-sets to see what convention we want to use.  What we do is
-use the full convention for any function that has a XEP its tail-set, even if
-we aren't required to do so by a tail-recursive full call, as long as there are
-no non-tail-recursive local calls in the set.  This prevents us from
-gratuitously using a non-standard convention when there is no reason to.
-
-
-\chapter{Local TN assignment}
-
-[Want a different name for this so as not to be confused with the different
-local/global TN representations.  The really interesting stuff in this phase is
-operation selection, values representation selection, return strategy, etc.
-Maybe this phase should be conceptually lumped with GTN as "implementation
-selection", since GTN determines call strategies and locations.]
-
-\#|
-
-[\#\#\# I guess I believe that it is OK for VMR conversion to dick the ICR flow
-graph.  An alternative would be to give VMR its very own flow graph, but that
-seems like overkill.
-
-In particular, it would be very nice if a TR local call looked exactly like a
-jump in VMR.  This would allow loop optimizations to be done on loops written
-as recursions.  In addition to making the call block transfer to the head of
-the function rather than to the return, we would also have to do something
-about skipping the part of the function prolog that moves arguments from the
-passing locations, since in a TR call they are already in the right frame.
-
-
-In addition to directly indicating whether a call should be coded with a TR
-variant, the Tail-P annotation flags non-call nodes that can directly return
-the value (an "advanced return"), rather than moving the value to the result
-continuation and jumping to the return code.  Then (according to policy), we
-can decide to advance all possible returns.  If all uses of the result are
-Tail-P, then LTN can annotate the result continuation as :Unused, inhibiting
-emission of the default return code.
-
-[\#\#\# But not really.  Now there is a single list of templates, and a given
-template has only one policy.]
-
-In LTN, we use the :Safe template as a last resort even when the policy is
-unsafe.  Note that we don't try :Fast-Safe; if this is also a good unsafe
-template, then it should have the unsafe policies explicitly specified.
-
-With a :Fast-Safe template, the result type must be proven to satisfy the
-output type assertion.  This means that a fast-safe template with a fixnum
-output type doesn't need to do fixnum overflow checking.  [\#\#\# Not right to
-just check against the Node-Derived-Type, since type-check intersects with
-this.]
-
-It seems that it would be useful to have a kind of template where the args must
-be checked to be fixnum, but the template checks for overflow and signals an
-error.  In the case where an output assertion is present, this would generate
-better code than conditionally branching off to make a bignum, and then doing a
-type check on the result.
-
-    How do we deal with deciding whether to do a fixnum overflow check?  This
-    is perhaps a more general problem with the interpretation of result type
-    restrictions in templates.  It would be useful to be able to discriminate
-    between the case where the result has been proven to be a fixnum and where
-    it has simply been asserted to be so.
-
-    The semantics of result type restriction is that the result must be proven
-    to be of that type *except* for safe generators, which are assumed to
-    verify the assertion.  That way "is-fixnum" case can be a fast-safe
-    generator and the "should-be-fixnum" case is a safe generator.  We could
-    choose not to have a safe "should-be-fixnum" generator, and let the
-    unrestricted safe generator handle it.  We would then have to do an
-    explicit type check on the result.
-
-    In other words, for all template except Safe, a type restriction on either
-    an argument or result means "this must be true; if it is not the system may
-    break."  In contrast, in a Safe template, the restriction means "If this is
-    not true, I will signal an error."
-
-    Since the node-derived-type only takes into consideration stuff that can be
-    proved from the arguments, we can use the node-derived-type to select
-    fast-safe templates.  With unsafe policies, we don't care, since the code
-    is supposed to be unsafe.
-
-|\#
-
-Local TN assignment (LTN) assigns all the TNs needed to represent the values of
-continuations.  This pass scans over the code for the component, examining each
-continuation and its destination.  A number of somewhat unrelated things are
-also done at the same time so that multiple passes aren't necessary.
- -- Determine the Primitive-Type for each continuation value and assigns TNs
-    to hold the values.
- -- Use policy information to determine the implementation strategy for each
-    call to a known function.
- -- Clear the type-check flags in continuations whose destinations have safe
-    implementations.
- -- Determine the value-passing strategy for each continuation: known or
-    unknown.
- -- Note usage of unknown-values continuations so that stack analysis can tell
-    when stack values must be discarded.
- 
-If safety is more important that speed and space, then we consider generating
-type checks on the values of nodes whose CONT has the Type-Check flag set.  If
-the destinatation for the continuation value is safe, then we don't need to do
-a check.  We assume that all full calls are safe, and use the template
-information to determine whether inline operations are safe.
-
-This phase is where compiler policy switches have most of their effect.  The
-speed/space/safety tradeoff can determine which of a number of coding
-strategies are used.  It is important to make the policy choice in VMR
-conversion rather than in code generation because the cost and storage
-requirement information which drives TNBIND will depend strongly on what actual
-VOP is chosen.  In the case of +/FIXNUM, there might be three or more
-implementations, some optimized for speed, some for space, etc.  Some of these
-VOPS might be open-coded and some not.
-
-We represent the implementation strategy for a call by either marking it as a
-full call or annotating it with a "template" representing the open-coding
-strategy.  Templates are selected using a two-way dispatch off of operand
-primitive-types and policy.  The general case of LTN is handled by the
-LTN-Annotate function in the function-info, but most functions are handled by a
-table-driven mechanism.  There are four different translation policies that a
-template may have:
-\begin{description}
-\item[Safe]
-        The safest implementation; must do argument type checking.
-
-\item[Small]
-        The (unsafe) smallest implementation.
-
-\item[Fast]
-        The (unsafe) fastest implementation.
-
-\item[Fast-Safe]
-        An implementation optimized for speed, but which does any necessary
-        checks exclusive of argument type checking.  Examples are array bounds
-        checks and fixnum overflow checks.
-\end{description}
-
-Usually a function will have only one or two distinct templates.  Either or
-both of the safe and fast-safe templates may be omitted; if both are specified,
-then they should be distinct.  If there is no safe template and our policy is
-safe, then we do a full call.
-
-We use four different coding strategies, depending on the policy:
-\begin{description}
-\item[Safe:]  safety $>$ space $>$ speed, or
-we want to use the fast-safe template, but there isn't one.
-
-\item[Small:] space $>$ (max speed safety)
-
-\item[Fast:] speed $>$ (max space safety)
-
-\item[Fast-Safe (and type check):] safety $>$ speed $>$ space, or we want to use
-the safe template, but there isn't one.
-\end{description}
-
-``Space'' above is actually the maximum of space and cspeed, under the theory
-that less code will take less time to generate and assemble.  [\#\#\# This could
-lose if the smallest case is out-of-line, and must allocate many linkage
-registers.]
-
-
-\chapter{Control optimization}
-
-In this phase we annotate blocks with drop-throughs.  This controls how code
-generation linearizes code so that drop-throughs are used most effectively.  We
-totally linearize the code here, allowing code generation to scan the blocks
-in the emit order.
-
-There are basically two aspects to this optimization:
- 1] Dynamically reducing the number of branches taken v.s. branches not
-    taken under the assumption that branches not taken are cheaper.
- 2] Statically minimizing the number of unconditional branches, saving space
-    and presumably time.
-
-These two goals can conflict, but if they do it seems pretty clear that the
-dynamic optimization should get preference.  The main dynamic optimization is
-changing the sense of a conditional test so that the more commonly taken branch
-is the fall-through case.  The problem is determining which branch is more
-commonly taken.
-
-The most clear-cut case is where one branch leads out of a loop and the other
-is within.  In this case, clearly the branch within the loop should be
-preferred.  The only added complication is that at some point in the loop there
-has to be a backward branch, and it is preferable for this branch to be
-conditional, since an unconditional branch is just a waste of time.
-
-In the absence of such good information, we can attempt to guess which branch
-is more popular on the basis of difference in the cost between the two cases.
-Min-max strategy suggests that we should choose the cheaper alternative, since
-the percentagewise improvement is greater when the branch overhead is
-significant with respect to the cost of the code branched to.  A tractable
-approximation of this is to compare only the costs of the two blocks
-immediately branched to, since this would avoid having to do any hairy graph
-walking to find all the code for the consequent and the alternative.  It might
-be worthwhile discriminating against ultra-expensive functions such as ERROR.
-
-For this to work, we have to detect when one of the options is empty.  In this
-case, the next for one branch is a successor of the other branch, making the
-comparison meaningless.  We use dominator information to detect this situation.
-When a branch is empty, one of the predecessors of the first block in the empty
-branch will be dominated by the first block in the other branch.  In such a
-case we favor the empty branch, since that's about as cheap as you can get.
-
-Statically minimizing branches is really a much more tractable problem, but
-what literature there is makes it look hard.  Clearly the thing to do is to use
-a non-optimal heuristic algorithm.
-
-A good possibility is to use an algorithm based on the depth first ordering.
-We can modify the basic DFO algorithm so that it chooses an ordering which
-favors any drop-thrus that we may choose for dynamic reasons.  When we are
-walking the graph, we walk the desired drop-thru arc last, which will place it
-immediately after us in the DFO unless the arc is a retreating arc.
-
-We scan through the DFO and whenever we find a block that hasn't been done yet,
-we build a straight-line segment by setting the drop-thru to the unreached
-successor block which has the lowest DFN greater than that for the block.  We
-move to the drop-thru block and repeat the process until there is no such
-block.  We then go back to our original scan through the DFO, looking for the
-head of another straight-line segment.
-
-This process will automagically implement all of the dynamic optimizations
-described above as long as we favor the appropriate IF branch when creating the
-DFO.  Using the DFO will prevent us from making the back branch in a loop the
-drop-thru, but we need to be clever about favoring IF branches within loops
-while computing the DFO.  The IF join will be favored without any special
-effort, since we follow through the most favored path until we reach the end.
-
-This needs some knowledge about the target machine, since on most machines
-non-tail-recursive calls will use some sort of call instruction.  In this case,
-the call actually wants to drop through to the return point, rather than
-dropping through to the beginning of the called function.
-
-
-\chapter{VMR conversion}
-
-\#|
-Single-use let var continuation substitution not really correct, since it can
-cause a spurious type error.  Maybe we do want stuff to prove that an NLX can't
-happen after all.  Or go back to the idea of moving a combination arg to the
-ref location, and having that use the ref cont (with its output assertion.)
-This lossage doesn't seem very likely to actually happen, though.
-[\#\#\# must-reach stuff wouldn't work quite as well as combination substitute in
-psetq, etc., since it would fail when one of the new values is random code
-(might unwind.)]
-
-Is this really a general problem with eager type checking?  It seems you could
-argue that there was no type error in this code:
-    (+ :foo (throw 'up nil))
-But we would signal an error.
-
-
-Emit explicit you-lose operation when we do a move between two non-T ptypes,
-even when type checking isn't on.  Can this really happen?  Seems we should
-treat continuations like this as though type-check was true.  Maybe LTN should
-leave type-check true in this case, even when the policy is unsafe.  (Do a type
-check against NIL?)
-
-At continuation use time, we may in general have to do both a coerce-to-t and a
-type check, allocating two temporary TNs to hold the intermediate results.
-
-
-VMR Control representation:
-
-We represent all control transfer explicitly.  In particular, :Conditional VOPs
-take a single Target continuation and a Not-P flag indicating whether the sense
-of the test is negated.  Then an unconditional Branch VOP will be emitted
-afterward if the other path isn't a drop-through.
-
-So we linearize the code before VMR-conversion.  This isn't a problem,
-since there isn't much change in control flow after VMR conversion (none until
-loop optimization requires introduction of header blocks.)  It does make
-cost-based branch prediction a bit ucky, though, since we don't have any cost
-information in ICR.  Actually, I guess we do have pretty good cost information
-after LTN even before VMR conversion, since the most important thing to know is
-which functions are open-coded.
-
-|\#
-
-VMR preserves the block structure of ICR, but replaces the nodes with a target
-dependent virtual machine (VM) representation.  Different implementations may
-use different VMs without making major changes in the back end.  The two main
-components of VMR are Temporary Names (TNs) and Virtual OPerations (VOPs).  TNs
-represent the locations that hold values, and VOPs represent the operations
-performed on the values.
-
-A "primitive type" is a type meaningful at the VM level.  Examples are Fixnum,
-String-Char, Short-Float.  During VMR conversion we use the primitive type of
-an expression to determine both where we can store the result of the expression
-and which type-specific implementations of an operation can be applied to the
-value.  [Ptype is a set of SCs == representation choices and representation
-specific operations]
-
-The VM specific definitions provide functions that do stuff like find the
-primitive type corresponding to a type and test for primitive type subtypep.
-Usually primitive types will be disjoint except for T, which represents all
-types.
-
-The primitive type T is special-cased.  Not only does it overlap with all the
-other types, but it implies a descriptor ("boxed" or "pointer") representation.
-For efficiency reasons, we sometimes want to use
-alternate representations for some objects such as numbers.  The majority of
-operations cannot exploit alternate representations, and would only be
-complicated if they had to be able to convert alternate representations into
-descriptors.  A template can require an operand to be a descriptor by
-constraining the operand to be of type T.
-
-A TN can only represent a single value, so we bare the implementation of MVs at
-this point.  When we know the number of multiple values being handled, we use
-multiple TNs to hold them.  When the number of values is actually unknown, we
-use a convention that is compatible with full function call.
-
-Everything that is done is done by a VOP in VMR.  Calls to simple primitive
-functions such as + and CAR are translated to VOP equivalents by a table-driven
-mechanism.  This translation is specified by the particular VM definition; VMR
-conversion makes no assumptions about which operations are primitive or what
-operand types are worth special-casing.  The default calling mechanisms and
-other miscellaneous builtin features are implemented using standard VOPs that
-must implemented by each VM.
-
-Type information can be forgotten after VMR conversion, since all type-specific
-operation selections have been made.
-
-Simple type checking is explicitly done using CHECK-xxx VOPs.  They act like
-innocuous effectless/unaffected VOPs which return the checked thing as a
-result.  This allows loop-invariant optimization and common subexpression
-elimination to remove redundant checks.  All type checking is done at the time
-the continuation is used.
-
-Note that we need only check asserted types, since if type inference works, the
-derived types will also be satisfied.  We can check whichever is more
-convenient, since both should be true.
-
-Constants are turned into special Constant TNs, which are wired down in a SC
-that is determined by their type.  The VM definition provides a function that
-returns constant a TN to represent a Constant Leaf. 
-
-Each component has a constant pool.  There is a register dedicated to holding
-the constant pool for the current component.  The back end allocates
-non-immediate constants in the constant pool when it discovers them during
-translation from ICR.
-
-[\#\#\# Check that we are describing what is actually implemented.  But this
-really isn't very good in the presence of interesting unboxed
-representations...] 
-Since LTN only deals with values from the viewpoint of the receiver, we must be
-prepared during the translation pass to do stuff to the continuation at the
-time it is used.
- -- If a VOP yields more values than are desired, then we must create TNs to
-    hold the discarded results.  An important special-case is continuations
-    whose value is discarded.  These continuations won't be annotated at all.
-    In the case of a Ref, we can simply skip evaluation of the reference when
-    the continuation hasn't been annotated.  Although this will eliminate
-    bogus references that for some reason weren't optimized away, the real
-    purpose is to handle deferred references.
- -- If a VOP yields fewer values than desired, then we must default the extra
-    values to NIL.
- -- If a continuation has its type-check flag set, then we must check the type
-    of the value before moving it into the result location.  In general, this
-    requires computing the result in a temporary, and having the type-check
-    operation deliver it in the actual result location.
- -- If the template's result type is T, then we must generate a boxed
-    temporary to compute the result in when the continuation's type isn't T.
-
-
-We may also need to do stuff to the arguments when we generate code for a
-template.  If an argument continuation isn't annotated, then it must be a
-deferred reference.  We use the leaf's TN instead.  We may have to do any of
-the above use-time actions also.  Alternatively, we could avoid hair by not
-deferring references that must be type-checked or may need to be boxed.
-
-
-\section{Stack analysis}
-
-Think of this as a lifetime problem: a values generator is a write and a values
-receiver is a read.  We want to annotate each VMR-Block with the unknown-values
-continuations that are live at that point.  If we do a control transfer to a
-place where fewer continuations are live, then we must deallocate the newly
-dead continuations.
-
-We want to convince ourselves that values deallocation based on lifetime
-analysis actually works.  In particular, we need to be sure that it doesn't
-violate the required stack discipline.  It is clear that it is impossible to
-deallocate the values before they become dead, since later code may decide to
-use them.  So the only thing we need to ensure is that the "right" time isn't
-later than the time that the continuation becomes dead.
-
-The only reason why we couldn't deallocate continuation A as soon as it becomes
-dead would be that there is another continuation B on top of it that isn't dead
-(since we can only deallocate the topmost continuation).
-
-The key to understanding why this can't happen is that each continuation has
-only one read (receiver).  If B is on top of A, then it must be the case that A
-is live at the receiver for B.  This means that it is impossible for B to be
-live without A being live.
-
-
-The reason that we don't solve this problem using a normal iterative flow
-analysis is that we also need to know the ordering of the continuations on the
-stack so that we can do deallocation.  When it comes time to discard values, we
-want to know which discarded continuation is on the bottom so that we can reset
-SP to its start.  
-
-[I suppose we could also decrement SP by the aggregate size of the discarded
-continuations.]  Another advantage of knowing the order in which we expect
-continuations to be on the stack is that it allows us to do some consistency
-checking.  Also doing a localized graph walk around the values-receiver is
-likely to be much more efficient than doing an iterative flow analysis problem
-over all the code in the component (not that big a consideration.)
-
-
-
-\#|
-Actually, what we do is do a backward graph walk from each unknown-values
-receiver.   As we go, we mark each walked block with ther ordered list of
-continuations we believe are on the stack.  Starting with an empty stack, we:
- -- When we encounter another unknown-values receiver, we push that
-    continuation on our simulated stack.
- -- When we encounter a receiver (which had better be for the topmost
-    continuation), we pop that continuation.
- -- When we pop all continuations, we terminate our walk.
-
-[\#\#\# not quite right...  It seems we may run into "dead values" during the
-graph walk too.  It seems that we have to check if the pushed continuation is
-on stack top, and if not, add it to the ending stack so that the post-pass will
-discard it.]
-
-
-
-[\#\#\# Also, we can't terminate our walk just because we hit a block previously
-walked.  We have to compare the the End-Stack with the values received along
-the current path: if we have more values on our current walk than on the walk
-that last touched the block, then we need to re-walk the subgraph reachable
-from from that block, using our larger set of continuations.  It seems that our
-actual termination condition is reaching a block whose End-Stack is already EQ
-to our current stack.]
-
-
-
-
-
-If at the start, the block containing the values receiver has already been
-walked, the we skip the walk for that continuation, since it has already been
-handled by an enclosing values receiver.  Once a walk has started, we
-ignore any signs of a previous walk, clobbering the old result with our own,
-since we enclose that continuation, and the previous walk doesn't take into
-consideration the fact that our values block underlies its own.
-
-When we are done, we have annotated each block with the stack current both at
-the beginning and at the end of that block.  Blocks that aren't walked don't
-have anything on the stack either place (although they may hack MVs
-internally).  
-
-We then scan all the blocks in the component, looking for blocks that have
-predecessors with a different ending stack than that block's starting stack.
-(The starting stack had better be a tail of the predecessor's ending stack.)
-We insert a block intervening between all of these predecessors that sets SP to
-the end of the values for the continuation that should be on stack top.  Of
-course, this pass needn't be done if there aren't any global unknown MVs.
-
-Also, if we find any block that wasn't reached during the walk, but that USEs
-an outside unknown-values continuation, then we know that the DEST can't be
-reached from this point, so the values are unused.  We either insert code to
-pop the values, or somehow mark the code to prevent the values from ever being
-pushed.  (We could cause the popping to be done by the normal pass if we
-iterated over the pushes beforehand, assigning a correct END-STACK.)
-
-[\#\#\# But I think that we have to be a bit clever within blocks, given the
-possibility of blocks being joined.  We could collect some unknown MVs in a
-block, then do a control transfer out of the receiver, and this control
-transfer could be squeezed out by merging blocks.  How about:
-
-    (tagbody
-      (return
-       (multiple-value-prog1 (foo)
-	 (when bar
-	   (go UNWIND))))
-
-     UNWIND
-      (return
-       (multiple-value-prog1 (baz)
-	 bletch)))
-
-But the problem doesn't happen here (can't happen in general?) since a node
-buried within a block can't use a continuation outside of the block.  In fact,
-no block can have more then one PUSH continuation, and this must always be be
-last continuation.  So it is trivially (structurally) true that all pops come
-before any push.
-
-[\#\#\# But not really: the DEST of an embedded continuation may be outside the
-block.  There can be multiple pushes, and we must find them by iterating over
-the uses of MV receivers in LTN.  But it would be hard to get the order right
-this way.  We could easily get the order right if we added the generators as we
-saw the uses, except that we can't guarantee that the continuations will be
-annotated at that point.  (Actually, I think we only need the order for
-consistency checks, but that is probably worthwhile).  I guess the thing to do
-is when we process the receiver, add the generator blocks to the
-Values-Generators, then do a post-pass that re-scans the blocks adding the
-pushes.]
-
-I believe that above concern with a dead use getting mashed inside a block
-can't happen, since the use inside the block must be the only use, and if the
-use isn't reachable from the push, then the use is totally unreachable, and
-should have been deleted, which would prevent the prevent it from ever being
-annotated.
-]
-]
-|\#
-
-We find the partial ordering of the values globs for unknown values
-continuations in each environment.  We don't have to scan the code looking for
-unknown values continuations since LTN annotates each block with the
-continuations that were popped and not pushed or pushed and not popped.  This
-is all we need to do the inter-block analysis.
-
-After we have found out what stuff is on the stack at each block boundary, we
-look for blocks with predecessors that have junk on the stack.  For each such
-block, we introduce a new block containing code to restore the stack pointer.
-Since unknown-values continuations are represented as <start, count>, we can
-easily pop a continuation using the Start TN.
-
-Note that there is only doubt about how much stuff is on the control stack,
-since only it is used for unknown values.  Any special stacks such as number
-stacks will always have a fixed allocation.
-
-
-\section{Non-local exit}
-
-
-If the starting and ending continuations are not in the same environment, then
-the control transfer is a non-local exit.  In this case just call Unwind with
-the appropriate stack pointer, and let the code at the re-entry point worry
-about fixing things up.
-
-It seems like maybe a good way to organize VMR conversion of NLX would be to
-have environment analysis insert funny functions in new interposed cleanup
-blocks.  The thing is that we need some way for VMR conversion to:
- 1] Get its hands on the returned values.
- 2] Do weird control shit.
- 3] Deliver the values to the original continuation destination.
-I.e. we need some way to interpose arbitrary code in the path of value
-delivery.
-
-What we do is replace the NLX uses of the continuation with another
-continuation that is received by a MV-Call to %NLX-VALUES in a cleanup block
-that is interposed between the NLX uses and the old continuation's block.  The
-MV-Call uses the original continuation to deliver it's values to.  
-
-[Actually, it's not really important that this be an MV-Call, since it has to
-be special-cased by LTN anyway.  Or maybe we would want it to be an MV call.
-If did normal LTN analysis of an MV call, it would force the returned values
-into the unknown values convention, which is probably pretty convenient for use
-in NLX.
-
-Then the entry code would have to use some special VOPs to receive the unknown
-values.  But we probably need special VOPs for NLX entry anyway, and the code
-can share with the call VOPs.  Also we probably need the technology anyway,
-since THROW will use truly unknown values.]
-
-
-On entry to a dynamic extent that has non-local-exists into it (always at an
-ENTRY node), we take a complete snapshot of the dynamic state:
-    the top pointers for all stacks
-    current Catch and Unwind-Protect
-    current special binding (binding stack pointer in shallow binding)
-
-We insert code at the re-entry point which restores the saved dynamic state.
-All TNs live at a NLX EP are forced onto the stack, so we don't have to restore
-them, and we don't have to worry about getting them saved.
-
diff --git a/docs/internals/object.tex b/docs/internals/object.tex
deleted file mode 100644
index a043f3479bf36770c15ee4a473cfd27c73e43054..0000000000000000000000000000000000000000
--- a/docs/internals/object.tex
+++ /dev/null
@@ -1,713 +0,0 @@
-\chapter{Object Format}
-
-
-\section{Tagging}
-
-The following is a key of the three bit low-tagging scheme:
-\begin{description}
-   \item[000] even fixnum
-   \item[001] function pointer
-   \item[010] even other-immediate (header-words, characters, symbol-value trap value, etc.)
-   \item[011] list pointer
-   \item[100] odd fixnum
-   \item[101] structure pointer
-   \item[110] odd other immediate
-  \item[111] other-pointer to data-blocks (other than conses, structures,
-                                     and functions)
-\end{description}
-
-This tagging scheme forces a dual-word alignment of data-blocks on the heap,
-but this can be pretty negligible: 
-\begin{itemize}
-\item   RATIOS and COMPLEX must have a header-word anyway since they are not a
-      major type.  This wastes one word for these infrequent data-blocks since
-      they require two words for the data.
-
-\item BIGNUMS must have a header-word and probably contain only one other word
-      anyway, so we probably don't waste any words here.  Most bignums just
-      barely overflow fixnums, that is by a bit or two.
-
-\item   Single and double FLOATS?
-      no waste, or
-      one word wasted
-
-\item   SYMBOLS have a pad slot (current called the setf function, but unused.)
-\end{itemize}
-Everything else is vector-like including code, so these probably take up
-so many words that one extra one doesn't matter.
-
-
-
-\section{GC Comments}
-
-Data-Blocks comprise only descriptors, or they contain immediate data and raw
-bits interpreted by the system.  GC must skip the latter when scanning the
-heap, so it does not look at a word of raw bits and interpret it as a pointer
-descriptor.  These data-blocks require headers for GC as well as for operations
-that need to know how to interpret the raw bits.  When GC is scanning, and it
-sees a header-word, then it can determine how to skip that data-block if
-necessary.  Header-Words are tagged as other-immediates.  See the sections
-"Other-Immediates" and "Data-Blocks and Header-Words" for comments on
-distinguishing header-words from other-immediate data.  This distinction is
-necessary since we scan through data-blocks containing only descriptors just as
-we scan through the heap looking for header-words introducing data-blocks.
-
-Data-Blocks containing only descriptors do not require header-words for GC
-since the entire data-block can be scanned by GC a word at a time, taking
-whatever action is necessary or appropriate for the data in that slot.  For
-example, a cons is referenced by a descriptor with a specific tag, and the
-system always knows the size of this data-block.  When GC encounters a pointer
-to a cons, it can transport it into the new space, and when scanning, it can
-simply scan the two words manifesting the cons interpreting each word as a
-descriptor.  Actually there is no cons tag, but a list tag, so we make sure the
-cons is not nil when appropriate.  A header may still be desired if the pointer
-to the data-block does not contain enough information to adequately maintain
-the data-block.  An example of this is a simple-vector containing only
-descriptor slots, and we attach a header-word because the descriptor pointing
-to the vector lacks necessary information -- the type of the vector's elements,
-its length, etc.
-
-There is no need for a major tag for GC forwarding pointers.  Since the tag
-bits are in the low end of the word, a range check on the start and end of old
-space tells you if you need to move the thing.  This is all GC overhead.
-
-
-
-\section{Structures}
-
-A structure descriptor has the structure lowtag type code, making 
-{\tt structurep} a fast operation.  A structure
-data-block has the following format:
-\begin{verbatim}
-    -------------------------------------------------------
-    |   length (24 bits) | Structure header type (8 bits) |
-    -------------------------------------------------------
-    |   structure type name (a symbol)                    |
-    -------------------------------------------------------
-    |   structure slot 0                                  |
-    -------------------------------------------------------
-    |   ... structure slot length - 2                     |
-    -------------------------------------------------------
-\end{verbatim}
-
-The header word contains the structure length, which is the number of words
-(other than the header word.)  The length is always at least one, since the
-first word of the structure data is the structure type name.
-
-
-\section{Fixnums}
-
-A fixnum has one of the following formats in 32 bits:
-\begin{verbatim}
-    -------------------------------------------------------
-    |        30 bit 2's complement even integer   | 0 0 0 |
-    -------------------------------------------------------
-\end{verbatim}
-or
-\begin{verbatim}
-    -------------------------------------------------------
-    |        30 bit 2's complement odd integer    | 1 0 0 |
-    -------------------------------------------------------
-\end{verbatim}
-
-Effectively, there is one tag for immediate integers, two zeros.  This buys one
-more bit for fixnums, and now when these numbers index into simple-vectors or
-offset into memory, they point to word boundaries on 32-bit, byte-addressable
-machines.  That is, no shifting need occur to use the number directly as an
-offset.
-
-This format has another advantage on byte-addressable machines when fixnums are
-offsets into vector-like data-blocks, including structures.  Even though we
-previously mentioned data-blocks are dual-word aligned, most indexing and slot
-accessing is word aligned, and so are fixnums with effectively two tag bits.
-
-Two tags also allow better usage of special instructions on some machines that
-can deal with two low-tag bits but not three.
-
-Since the two bits are zeros, we avoid having to mask them off before using the
-words for arithmetic, but division and multiplication require special shifting.
-
-
-
-\section{Other-immediates}
-
-As for fixnums, there are two different three-bit lowtag codes for
-other-immediate, allowing 64 other-immediate types:
-\begin{verbatim}
-----------------------------------------------------------------
-|   Data (24 bits)        | Type (8 bits with low-tag)   | 1 0 |
-----------------------------------------------------------------
-\end{verbatim}
-
-The type-code for an other-immediate type is considered to include the two
-lowtag bits.  This supports the concept of a single "type code" namespace for
-all descriptors, since the normal lowtag codes are disjoint from the
-other-immediate codes.
-
-For other-pointer objects, the full eight bits of the header type code are used
-as the type code for that kind of object.  This is why we use two lowtag codes
-for other-immediate types: each other-pointer object needs a distinct
-other-immediate type to mark its header.
-
-The system uses the other-immediate format for characters, 
-the {\tt symbol-value} unbound trap value, and header-words for data-blocks on
-the heap.  The type codes are laid out to facilitate range checks for common
-subtypes; for example, all numbers will have contiguous type codes which are
-distinct from the contiguous array type codes.  See section
-\ref{data-blocks-and-o-i} for details.
-
-
-\section{Data-Blocks and Header-Word Format}
-
-Pointers to data-blocks have the following format:
-\begin{verbatim}
-----------------------------------------------------------------
-|      Dual-word address of data-block (29 bits)       | 1 1    1 |
-----------------------------------------------------------------
-\end{verbatim}
-
-The word pointed to by the above descriptor is a header-word, and it has the
-same format as an other-immediate:
-\begin{verbatim}
-----------------------------------------------------------------
-|   Data (24 bits)        | Type (8 bits with low-tag) | 0 1 0 |
-----------------------------------------------------------------
-\end{verbatim}
-This is convenient for scanning the heap when GC'ing, but it does mean that
-whenever GC encounters an other-immediate word, it has to do a range check on
-the low byte to see if it is a header-word or just a character (for example).
-This is easily acceptable performance hit for scanning.
-
-The system interprets the data portion of the header-word for non-vector
-data-blocks as the word length excluding the header-word.  For example, the
-data field of the header for ratio and complex numbers is two, one word each
-for the numerator and denominator or for the real and imaginary parts.
-
-For vectors and data-blocks representing Lisp objects stored like vectors, the
-system ignores the data portion of the header-word:
-\begin{verbatim}
-----------------------------------------------------------------
-| Unused Data (24 bits)   | Type (8 bits with low-tag) | 0 1 0 |
-----------------------------------------------------------------
-|           Element Length of Vector (30 bits)           | 0 0 | 
-----------------------------------------------------------------
-\end{verbatim}
-
-Using a separate word allows for much larger vectors, and it allows {\tt
-length} to simply access a single word without masking or shifting.  Similarly,
-the header for complex arrays and vectors has a second word, following the
-header-word, the system uses for the fill pointer, so computing the length of
-any array is the same code sequence.
-
-
-
-\section{Data-Blocks and Other-immediates Typing}
-
-\label{data-blocks-and-o-i}
-These are the other-immediate types.  We specify them including all low eight
-bits, including the other-immediate tag, so we can think of the type bits as
-one type -- not an other-immediate major type and a subtype.  Also, fetching a
-byte and comparing it against a constant is more efficient than wasting even a
-small amount of time shifting out the other-immediate tag to compare against a
-five bit constant.
-\begin{verbatim}
-Number   (< 30)
-  bignum                                        10
-    ratio                                       14
-    single-float                                18
-    double-float                                22
-    complex                                     26
-
-Array   (>= 30 code 86)
-   Simple-Array   (>= 20 code 70)
-         simple-array                           30
-      Vector  (>= 34 code 82)
-         simple-string                          34
-         simple-bit-vector                      38
-         simple-vector                          42
-         (simple-array (unsigned-byte 2) (*))   46
-         (simple-array (unsigned-byte 4) (*))   50
-         (simple-array (unsigned-byte 8) (*))   54
-         (simple-array (unsigned-byte 16) (*))  58
-         (simple-array (unsigned-byte 32) (*))  62
-         (simple-array single-float (*))        66
-         (simple-array double-float (*))        70
-      complex-string                            74
-      complex-bit-vector                        78
-      (array * (*))   -- general complex vector. 82
-   complex-array                                86
-
-code-header-type                                90
-function-header-type                            94
-closure-header-type                             98
-funcallable-instance-header-type                102
-unused-function-header-1-type                   106
-unused-function-header-2-type                   110
-unused-function-header-3-type                   114
-closure-function-header-type                    118
-return-pc-header-type (a.k.a LRA)               122
-value-cell-header-type                          126
-symbol-header-type                              130
-base-character-type                             134
-system-area-pointer-type (header type)          138
-unbound-marker                                  142
-weak-pointer-type                               146
-structure-header-type                           150
-\end{verbatim}
-
-\section{Strings}
-
-All strings in the system are C-null terminated.  This saves copying the bytes
-when calling out to C.  The only time this wastes memory is when the string
-contains a multiple of eight characters, and then the system allocates two more
-words (since Lisp objects are dual-word aligned) to hold the C-null byte.
-Since the system will make heavy use of C routines for systems calls and
-libraries that save reimplementation of higher level operating system
-functionality (such as pathname resolution or current directory computation),
-saving on copying strings for C should make C call out more efficient.
-
-The length word in a string header, see section "Data-Blocks and Header-Word
-Format", counts only the characters truly in the Common Lisp string.
-Allocation and GC will have to know to handle the extra C-null byte, and GC
-already has to deal with rounding up various objects to dual-word alignment.
-
-
-
-\section{Symbols and NIL}
-
-Symbol data-block has the following format:
-\begin{verbatim}
--------------------------------------------------------
-|     7 (data-block words)     | Symbol Type (8 bits) |
--------------------------------------------------------
-|               Value Descriptor                      |
--------------------------------------------------------
-|                       Function Pointer              |
--------------------------------------------------------
-|                     Raw Function Address            |
--------------------------------------------------------
-|                        Setf Function                |
--------------------------------------------------------
-|                        Property List                |
--------------------------------------------------------
-|                          Print Name                 |
--------------------------------------------------------
-|                           Package                   |
--------------------------------------------------------
-\end{verbatim}
-
-Most of these slots are self-explanatory given what symbols must do in Common
-Lisp, but a couple require comments.  We added the Raw Function Address slot to
-speed up named call which is the most common calling convention.  This is a
-non-descriptor slot, but since objects are dual word aligned, the value
-inherently has fixnum low-tag bits.  The GC method for symbols must know to
-update this slot.  The Setf Function slot is currently unused, but we had an
-extra slot due to adding Raw Function Address since objects must be dual-word
-aligned.
-
-The issues with nil are that we want it to act like a symbol, and we need list
-operations such as CAR and CDR to be fast on it.  CMU Common Lisp solves this
-by putting nil as the first object in static space, where other global values
-reside, so it has a known address in the system:
-\begin{verbatim}
--------------------------------------------------------  <-- space
-|                               0                     |      start
--------------------------------------------------------
-|     7 (data-block words)     | Symbol Type (8 bits) |
--------------------------------------------------------  <-- nil
-|                           Value/CAR                 |
--------------------------------------------------------
-|                         Definition/CDR              |
--------------------------------------------------------
-|                      Raw Function Address           |
--------------------------------------------------------
-|                         Setf Function               |
--------------------------------------------------------
-|                         Property List               |
--------------------------------------------------------
-|                           Print Name                |
--------------------------------------------------------
-|                            Package                  |
--------------------------------------------------------
-|                              ...                    |
--------------------------------------------------------
-\end{verbatim}
-In addition, we make the list typed pointer to nil actually point past the
-header word of the nil symbol data-block.  This has usefulness explained below.
-The value and definition of nil are nil.  Therefore, any reference to nil used
-as a list has quick list type checking, and CAR and CDR can go right through
-the first and second words as if nil were a cons object.
-
-When there is a reference to nil used as a symbol, the system adds offsets to
-the address the same as it does for any symbol.  This works due to a
-combination of nil pointing past the symbol header-word and the chosen list and
-other-pointer type tags.  The list type tag is four less than the other-pointer
-type tag, but nil points four additional bytes into its symbol data-block.
-
-
-
-;;;; Array Headers.
-
-The array-header data-block has the following format:
-\begin{verbatim}
-----------------------------------------------------------------
-| Header Len (24 bits) = Array Rank +5   | Array Type (8 bits) |
-----------------------------------------------------------------
-|               Fill Pointer (30 bits)                   | 0 0 | 
-----------------------------------------------------------------
-|               Available Elements (30 bits)             | 0 0 | 
-----------------------------------------------------------------
-|               Data Vector (29 bits)                  | 1 1 1 | 
-----------------------------------------------------------------
-|               Displacement (30 bits)                   | 0 0 | 
-----------------------------------------------------------------
-|               Displacedp (29 bits) -- t or nil       | 1 1 1 | 
-----------------------------------------------------------------
-|               Range of First Index (30 bits)           | 0 0 | 
-----------------------------------------------------------------
-                              .
-                              .
-                              .
-
-\end{verbatim}
-The array type in the header-word is one of the eight-bit patterns from section
-"Data-Blocks and Other-immediates Typing", indicating that this is a complex
-string, complex vector, complex bit-vector, or a multi-dimensional array.  The
-data portion of the other-immediate word is the length of the array header
-data-block.  Due to its format, its length is always five greater than the
-array's number of dimensions.  The following words have the following
-interpretations and types:
-\begin{description}
-   \item[Fill Pointer:]
-      This is a fixnum indicating the number of elements in the data vector
-      actually in use.  This is the logical length of the array, and it is
-      typically the same value as the next slot.  This is the second word, so
-      LENGTH of any array, with or without an array header, is just four bytes
-      off the pointer to it.
-   \item[Available Elements:]
-      This is a fixnum indicating the number of elements for which there is
-      space in the data vector.  This is greater than or equal to the logical
-      length of the array when it is a vector having a fill pointer.
-   \item[Data Vector:]
-      This is a pointer descriptor referencing the actual data of the array.
-      This a data-block whose first word is a header-word with an array type as
-      described in sections "Data-Blocks and Header-Word Format" and
-      "Data-Blocks and Other-immediates Typing"
-   \item[Displacement:]
-      This is a fixnum added to the computed row-major index for any array.
-      This is typically zero.
-   \item[Displacedp:]
-      This is either t or nil.  This is separate from the displacement slot, so
-      most array accesses can simply add in the displacement slot.  The rare
-      need to know if an array is displaced costs one extra word in array
-      headers which probably aren't very frequent anyway.
-   \item[Range of First Index:]
-      This is a fixnum indicating the number of elements in the first dimension
-      of the array.  Legal index values are zero to one less than this number
-      inclusively.  IF the array is zero-dimensional, this slot is
-      non-existent.
-   \item[... (remaining slots):]
-      There is an additional slot in the header for each dimension of the
-      array.  These are the same as the Range of First Index slot.
-\end{description}
-
-
-\section{Bignums}
-
-Bignum data-blocks have the following format:
-\begin{verbatim}
--------------------------------------------------------
-|      Length (24 bits)        | Bignum Type (8 bits) |
--------------------------------------------------------
-|             least significant bits                  |
--------------------------------------------------------
-                            .
-                            .
-                            .
-\end{verbatim}
-The elements contain the two's complement representation of the integer with
-the least significant bits in the first element or closer to the header.  The
-sign information is in the high end of the last element.
-
-
-
-
-\section{Code Data-Blocks}
-
-A code data-block is the run-time representation of a "component".  A component
-is a connected portion of a program's flow graph that is compiled as a single
-unit, and it contains code for many functions.  Some of these functions are
-callable from outside of the component, and these are termed "entry points".
-
-Each entry point has an associated user-visible function data-block (of type
-{\tt function}).  The full call convention provides for calling an entry point
-specified by a function object.
-
-Although all of the function data-blocks for a component's entry points appear
-to the user as distinct objects, the system keeps all of the code in a single
-code data-block.  The user-visible function object is actually a pointer into
-the middle of a code data-block.  This allows any control transfer within a
-component to be done using a relative branch.
-
-Besides a function object, there are other kinds of references into the middle
-of a code data-block.  Control transfer into a function also occurs at the
-return-PC for a call.  The system represents a return-PC somewhat similarly to
-a function, so GC can also recognize a return-PC as a reference to a code
-data-block.  This representation is known as a Lisp Return Address (LRA).
-
-It is incorrect to think of a code data-block as a concatenation of "function
-data-blocks".  Code for a function is not emitted in any particular order with
-respect to that function's function-header (if any).  The code following a
-function-header may only be a branch to some other location where the
-function's "real" definition is.
-
-
-The following are the three kinds of pointers to code data-blocks:
-\begin{description}
-   \item[Code pointer (labeled A below):]
-      A code pointer is a descriptor, with other-pointer low-tag bits, pointing
-      to the beginning of the code data-block.  The code pointer for the
-      currently running function is always kept in a register (CODE).  In
-      addition to allowing loading of non-immediate constants, this also serves
-      to represent the currently running function to the debugger.
-   \item[LRA (labeled B below):]
-      The LRA is a descriptor, with other-pointer low-tag bits, pointing
-      to a location for a function call.  Note that this location contains no
-      descriptors other than the one word of immediate data, so GC can treat
-      LRA locations the same as instructions.
-   \item[Function (labeled C below):]
-      A function is a descriptor, with function low-tag bits, that is user
-      callable.  When a function header is referenced from a closure or from
-      the function header's self-pointer, the pointer has other-pointer low-tag
-      bits, instead of function low-tag bits.  This ensures that the internal
-      function data-block associated with a closure appears to be uncallable
-      (although users should never see such an object anyway).
-
-      Information about functions that is only useful for entry points is kept
-      in some descriptors following the function's self-pointer descriptor.
-      All of these together with the function's header-word are known as the
-      "function header".  GC must be able to locate the function header.  We
-      provide for this by chaining together the function headers in a NIL
-      terminated list kept in a known slot in the code data-block.
-\end{description}
-
-A code data-block has the following format:
-\begin{verbatim}
-A -->
-****************************************************************
-|  Header-Word count (24 bits)    |   Code-Type (8 bits)       |
-----------------------------------------------------------------
-|  Number of code words (fixnum tag)                           |
-----------------------------------------------------------------
-|  Pointer to first function header (other-pointer tag)        |
-----------------------------------------------------------------
-|  Debug information (structure tag)                           |
-----------------------------------------------------------------
-|  First constant (a descriptor)                               |
-----------------------------------------------------------------
-|  ...                                                         |
-----------------------------------------------------------------
-|  Last constant (and last word of code header)                |
-----------------------------------------------------------------
-|  Some instructions (non-descriptor)                          |
-----------------------------------------------------------------
-|     (pad to dual-word boundary if necessary)                 |
-
-B -->
-****************************************************************
-|  Word offset from code header (24)   |   Return-PC-Type (8)  |
-----------------------------------------------------------------
-|  First instruction after return                              |
-----------------------------------------------------------------
-|  ... more code and LRA header-words                          |
-----------------------------------------------------------------
-|     (pad to dual-word boundary if necessary)                 |
-
-C -->
-****************************************************************
-|  Offset from code header (24)  |   Function-Header-Type (8)  |
-----------------------------------------------------------------
-|  Self-pointer back to previous word (with other-pointer tag) |
-----------------------------------------------------------------
-|  Pointer to next function (other-pointer low-tag) or NIL     |
-----------------------------------------------------------------
-|  Function name (a string or a symbol)                        |
-----------------------------------------------------------------
-|  Function debug arglist (a string)                           |
-----------------------------------------------------------------
-|  Function type (a list-style function type specifier)        |
-----------------------------------------------------------------
-|  Start of instructions for function (non-descriptor)         |
-----------------------------------------------------------------
-|  More function headers and instructions and return PCs,      |
-|  until we reach the total size of header-words + code        |
-|  words.                                                      |
-----------------------------------------------------------------
-\end{verbatim}
-
-The following are detailed slot descriptions:
-\begin{description}
-   \item[Code data-block header-word:]
-      The immediate data in the code data-block's header-word is the number of
-      leading descriptors in the code data-block, the fixed overhead words plus
-      the number of constants.  The first non-descriptor word, some code,
-      appears at this word offset from the header.
-   \item[Number of code words:]
-      The total number of non-header-words in the code data-block.  The total
-      word size of the code data-block is the sum of this slot and the
-      immediate header-word data of the previous slot.
-      header-word.
-   \item[Pointer to first function header:]
-      A NIL-terminated list of the function headers for all entry points to
-      this component.
-   \item[Debug information:]
-      The DEBUG-INFO structure describing this component.  All information that
-      the debugger wants to get from a running function is kept in this
-      structure.  Since there are many functions, the current PC is used to
-      locate the appropriate debug information.  The system keeps the debug
-      information separate from the function data-block, since the currently
-      running function may not be an entry point.  There is no way to recover
-      the function object for the currently running function, since this
-      data-block may not exist.
-   \item[First constant ... last constant:]
-      These are the constants referenced by the component, if there are any.
-\vspace{1ex}
-   \item[LRA header word:]
-      The immediate header-word data is the word offset from the enclosing code
-      data-block's header-word to this word.  This allows GC and the debugger
-      to easily recover the code data-block from a LRA.  The code at the
-      return point restores the current code pointer using a subtract immediate
-      of the offset, which is known at compile time.
-\vspace{1ex}
-   \item[Function entry point header-word:]
-      The immediate header-word data is the word offset from the enclosing code
-      data-block's header-word to this word.  This is the same as for the
-      retrun-PC header-word.
-   \item[Self-pointer back to header-word:]
-      In a non-closure function, this self-pointer to the previous header-word
-      allows the call sequence to always indirect through the second word in a
-      user callable function.  See section "Closure Format".  With a closure,
-      indirecting through the second word gets you a function header-word.  The
-      system ignores this slot in the function header for a closure, since it
-      has already indirected once, and this slot could be some random thing
-      that causes an error if you jump to it.  This pointer has an
-      other-pointer tag instead of a function pointer tag, indicating it is not
-      a user callable Lisp object.
-   \item[Pointer to next function:]
-      This is the next link in the thread of entry point functions found in
-      this component.  This value is NIL when the current header is the last
-      entry point in the component.
-   \item[Function name:]
-      This function's name (for printing).  If the user defined this function
-      with DEFUN, then this is the defined symbol, otherwise it is a
-      descriptive string.
-   \item[Function debug arglist:]
-      A printed string representing the function's argument list, for human
-      readability.  If it is a macroexpansion function, then this is the
-      original DEFMACRO arglist, not the actual expander function arglist.
-   \item[Function type:]
-      A list-style function type specifier representing the argument signature
-      and return types for this function.  For example,
-      \begin{verbatim}
-(function (fixnum fixnum fixnum) fixnum)
-      \end{verbatim}
-      or
-      \begin{verbatim}
-(function (string &key (:start unsigned-byte)) string)
-      \end{verbatim}
-      This information is intended for machine readablilty, such as by the
-      compiler.
-\end{description}
-
-
-\section{Closure Format}
-
-A closure data-block has the following format:
-\begin{verbatim}
-----------------------------------------------------------------
-|  Word size (24 bits)           |  Closure-Type (8 bits)      |
-----------------------------------------------------------------
-|  Pointer to function header (other-pointer low-tag)          |
-----------------------------------------------------------------
-|                                 .                            |
-|                      Environment information                 |
-|                                 .                            |
-----------------------------------------------------------------
-\end{verbatim}
-
-A closure descriptor has function low-tag bits.  This means that a descriptor
-with function low-tag bits may point to either a function header or to a
-closure.  The idea is that any callable Lisp object has function low-tag bits.
-Insofar as call is concerned, we make the format of closures and non-closure
-functions compatible.  This is the reason for the self-pointer in a function
-header.  Whenever you have a callable object, you just jump through the second
-word, offset some bytes, and go.
-
-
-
-\section{Function call}
-
-Due to alignment requirements and low-tag codes, it is not possible to use a
-hardware call instruction to compute the LRA.  Instead the LRA
-for a call is computed by doing an add-immediate to the start of the code
-data-block.
-
-An advantage of using a single data-block to represent both the descriptor and
-non-descriptor parts of a function is that both can be represented by a
-single pointer.  This reduces the number of memory accesses that have to be
-done in a full call.  For example, since the constant pool is implicit in a
-LRA, a call need only save the LRA, rather than saving both the
-return PC and the constant pool.
-
-
-
-\section{Memory Layout}
-
-CMU Common Lisp has four spaces, read-only, static, dynamic-0, and dynamic-1.
-Read-only contains objects that the system never modifies, moves, or reclaims.
-Static space contains some global objects necessary for the system's runtime or
-performance (since they are located at a known offset at a know address), and
-the system never moves or reclaims these.  However, GC does need to scan static
-space for references to moved objects.  Dynamic-0 and dynamic-1 are the two
-heap areas for stop-and-copy GC algorithms.
-
-What global objects are at the head of static space???
-\begin{verbatim}
-   NIL
-   eval::*top-of-stack*
-   lisp::*current-catch-block*
-   lisp::*current-unwind-protect*
-   FLAGS (RT only)
-   BSP (RT only)
-   HEAP (RT only)
-\end{verbatim}
-
-In addition to the above spaces, the system has a control stack, binding stack,
-and a number stack.  The binding stack contains pairs of descriptors, a symbol
-and its previous value.  The number stack is the same as the C stack, and the
-system uses it for non-Lisp objects such as raw system pointers, saving
-non-Lisp registers, parts of bignum computations, etc.
-
-
-
-\section{System Pointers}
-
-The system pointers reference raw allocated memory, data returned by foreign
-function calls, etc.  The system uses these when you need a pointer to a
-non-Lisp block of memory, using an other-pointer.  This provides the greatest
-flexibility by relieving contraints placed by having more direct references
-that require descriptor type tags.
-
-A system area pointer data-block has the following format:
-\begin{verbatim}
--------------------------------------------------------
-|     1 (data-block words)        | SAP Type (8 bits) |
--------------------------------------------------------
-|             system area pointer                     |
--------------------------------------------------------
-\end{verbatim}
-
-"SAP" means "system area pointer", and much of our code contains this naming
-scheme.  We don't currently restrict system pointers to one area of memory, but
-if they do point onto the heap, it is up to the user to prevent being screwed
-by GC or whatever.
diff --git a/docs/internals/outline.txt b/docs/internals/outline.txt
deleted file mode 100644
index 690781c9223d02b02bed9b4a96c5ba99da88d798..0000000000000000000000000000000000000000
--- a/docs/internals/outline.txt
+++ /dev/null
@@ -1,120 +0,0 @@
-Todo:
-fasl.tex
-In good shape.
-
-object.tex
-Fairly good, but should probably be integrated with description of primitives
-in vm.tex.
-
-front.tex
-Needs updating cleanup scan.  Not too bad.
-
-middle.tex
-Need VMR overview.  New names for GTN/LTN?  Needs general cleanup, but not too
-bad.  NLX and stack are the worst. 
-
-back.tex
-Pack and assembler need more info.  General cleanup.
-
-
-compiler-overview.tex
-Adapt introductory material from /../fred/usr/ram/comp.mss, pap:talk.mss
-Division between ICR overview and ICR convert needs work.
-
-debugger.tex
-Needs much work.  Merge much info from debug-info and debug-int.  Duplicating a
-fair amount of stuff in the source may make sense where, since this is a part
-of the system that is generally interesting.  And also, a part that people
-building on CMU CL might want to understand.
-
-glossary.tex
-Finish, integrate w/ main text?
-
-interpreter.tex
-Very sketchy and tentative.  Needs to be fleshed out from the code.
-
-retargeting.tex
-Very rough.  Needs to be merged with parts of vm.tex (call vops).  Needs some
-additional text.  Documentation of assembler, and all other exported
-interfaces.  (Generate defined VOP descriptions from the core, keyed to files?)
-
-vm.tex
-This file should probably cease to exist, going into object, retargeting and
-introductory material.  [Also other scrap in stuff/]
-
-
-[VMR and ICR overview also needed...]
-
-architecture.tex
-Missing sections on startup code, compiling, building.
-
-environment.tex
-Needs to be written: type system and info database interfaces.
-
-interface.tex
-Needs to be written: source paths and error message utilities.
-
-lowlev.tex
-Needs to be written.  All manner of low-level stuff: memory layout and
-management, core file format, C interface, low-level debugging (and ldb.)
-
-
-Several different audiences:
- -- Curious compiler implementors (not a big priority.  Downplay academic
-    aspects, i.e. comparisons to other techniques, analysis of limitations,
-    future work...)  Compiler part can be more academic, and include some
-    justifications of other design decisions.
- -- System maintainers.
- -- People retargeting the compiler.
- -- People bringing up the system in a new environment.
-
-Sys arch part:
-    Package + file structure [system.txt]
-    system building [compiling.txt]
-        bootstrapping & cross compiling
-
-Compiler design:
-    Overview (mirror structure of rest of the part)
-    ICR data structure
-    Front end [front.tex]
-    Basic VMR data structures (no back-end stuff)
-    Middle end [middle.tex]
-    Back end + data structures [back.tex]
-
-    Error system interface
-    Source tracking
-
-Compiler retargeting:
-    VM definition concepts [porting.txt, mail.txt, retargeting.tex]
-        SCs, SBs, primitive-types
-    Defining VOPS
-        time specification
-    defining 
-    and using the assembler
-    Required VOPs [internal.txt, lowlev.txt, vm.mss]
-    Standard primitives [vm.mss] (broken down by type, parallels object format
-    section structure.)
-    Customizing VMR conversion
-        multiple hardware
-        constant operands
-        VM specific transforms
-        special-case IR2 convert methods
-
-Run-time system:
-    type system
-    info database
-    Data format [object.tex]
-    Debugger:
-	Info format [debug.txt]
-	Stack parsing [debug.txt]
-	Breakpoints
-	Internal errors
-	Signals
-    Memory management: [William]
-        heap Layout
-        stacks
-        GC
-    misc implementation stuff: foreign call, assembly routines [lowlev.txt]
-    LDB and low-level debugging
-    core file format  [William]
-    fasl format [fasl.tex]
diff --git a/docs/internals/retargeting.tex b/docs/internals/retargeting.tex
deleted file mode 100644
index 82ab04391196232bbce654994e58b8e9ee7595de..0000000000000000000000000000000000000000
--- a/docs/internals/retargeting.tex
+++ /dev/null
@@ -1,1082 +0,0 @@
-\part{Compiler Retargeting}
-
-[\#\#\#
-
-In general, it is a danger sign if a generator references a TN that isn't an
-operand or temporary, since lifetime analysis hasn't been done for that use.
-We are doing weird stuff for the old-cont and return-pc passing locations,
-hoping that the conflicts at the called function have the desired effect.
-Other stuff?  When a function returns unknown values, we don't reference the
-values locations when a single-value return is done.  But nothing is live at a
-return point anyway.
-
-
-
-Have a way for template conversion to special-case constant arguments?  
-How about:
-    If an arg restriction is (:satisfies [<predicate function>]), and the
-    corresponding argument is constant, with the constant value satisfying the
-    predicate, then (if any other restrictions are satisfied), the template
-    will be emitted with the literal value passed as an info argument.  If the
-    predicate is omitted, then any constant will do.
-
-    We could sugar this up a bit by allowing (:member <object>*) for
-    (:satisfies (lambda (x) (member x '(<object>*))))
-
-We could allow this to be translated into a Lisp type by adding a new Constant
-type specifier.  This could only appear as an argument to a function type.
-To satisfy (Constant <type>), the argument must be a compile-time constant of
-the specified type.  Just Constant means any constant (i.e. (Constant *)).
-This would be useful for the type constraints on ICR transforms.
-
-
-Constant TNs: we count on being able to indirect to the leaf, and don't try to
-wedge the information into the offset.  We set the FSC to an appropriate
-immediate SC.
-
-    Allow "more operands" to VOPs in define-vop.  You can't do much with the
-    more operands: define-vop just fills in the cost information according to
-    the loading costs for a SC you specify.  You can't restrict more operands,
-    and you can't make local preferences.  In the generator, the named variable
-    is bound to the TN-ref for the first extra operand.  This should be good
-    enough to handle all the variable arg VOPs (primarily function call and
-    return).  Usually more operands are used just to get TN lifetimes to work
-    out; the generator actually ignores them.
-
-    Variable-arg VOPs can't be used with the VOP macro.  You must use VOP*.
-    VOP* doesn't do anything with these extra operand except stick them on the
-    ends of the operand lists passed into the template.  VOP* is often useful
-    within the convert functions for non-VOP templates, since it can emit a VOP
-    using an already prepared TN-Ref list.
-    
-
-    It is pretty basic to the whole primitive-type idea that there is only one
-    primitive-type for a given lisp type.  This is really the same as saying
-    primitive types are disjoint.  A primitive type serves two somewhat
-    unrelated purposes:
-     -- It is an abstraction a Lisp type used to select type specific
-        operations.  Originally kind of an efficiency hack, but it lets a
-        template's type signature be used both for selection and operand
-        representation determination.
-     -- It represents a set of possible representations for a value (SCs).  The
-        primitive type is used to determine the legal SCs for a TN, and is also
-        used to determine which type-coercion/move VOP to use.
-
-]
-
-There are basically three levels of target dependence:
-
- -- Code in the "front end" (before VMR conversion) deals only with Lisp
-    semantics, and is totally target independent.
-
- -- Code after VMR conversion and before code generation depends on the VM,
-    but should work with little modification across a wide range of
-    "conventional" architectures.
-
- -- Code generation depends on the machine's instruction set and other
-    implementation details, so it will have to be redone for each
-    implementation.  Most of the work here is in defining the translation into
-    assembly code of all the supported VOPs.
-
-
-
-\chapter{Storage bases and classes}
-New interface: instead of CURRENT-FRAME-SIZE, have CURRENT-SB-SIZE <name> which
-returns the current element size of the named SB.
-
-How can we have primitive types that overlap, i.e. (UNSIGNED-BYTE 32),
-(SIGNED-BYTE 32), FIXNUM?
-Primitive types are used for two things:
-    Representation selection: which SCs can be used to represent this value?
-	For this purpose, it isn't necessary that primitive types be disjoint,
-	since any primitive type can choose an arbitrary set of
-	representations.  For moves between the overlapping representations,
-	the move/load operations can just be noops when the locations are the
-	same (vanilla MOVE), since any bad moves should be caught out by type
-	checking.
-    VOP selection:
-	Is this operand legal for this VOP?  When ptypes overlap in interesting
-	ways, there is a problem with allowing just a simple ptype restriction,
-	since we might want to allow multiple ptypes.  This could be handled
-	by allowing "union primitive types", or by allowing multiple primitive
-	types to be specified (only in the operand restriction.)  The latter
-	would be long the lines of other more flexible VOP operand restriction
-	mechanisms, (constant, etc.)
-
-
-
-Ensure that load/save-operand never need to do representation conversion.
-
-The PRIMITIVE-TYPE more/coerce info would be moved into the SC.  This could
-perhaps go along with flushing the TN-COSTS.  We would annotate the TN with
-best SC, which implies the representation (boxed or unboxed).  We would still
-need represent the legal SCs for restricted TNs somehow, and also would have to
-come up with some other way for pack to keep track of which SCs we have already
-tried.
-
-A SC would have a list of "alternate" SCs and a boolean SAVE-P value that
-indicates it needs to be saved across calls in some non-SAVE-P SC.  A TN is
-initially given its "best" SC.  The SC is annotated with VOPs that are used for
-moving between the SC and its alternate SCs (load/save operand, save/restore
-register).  It is also annotated with the "move" VOPs used for moving between
-this SC and all other SCs it is possible to move between.  We flush the idea
-that there is only c-to-t and c-from-t.
-
-But how does this mesh with the idea of putting operand load/save back into the
-generator?  Maybe we should instead specify a load/save function?  The
-load/save functions would also differ from the move VOPs in that they would
-only be called when the TN is in fact in that particular alternate SC, whereas
-the move VOPs will be associated with the primary SC, and will be emitted
-before it is known whether the TN will be packed in the primary SC or an
-alternate.
-
-I guess a packed SC could also have immediate SCs as alternate SCs, and
-constant loading functions could be associated with SCs using this mechanism.
-
-So given a TN packed in SC X and a SC restriction for Y and Z, how do we know
-which load function to call?  There would be ambiguity if X was an alternate
-for both Y and Z and they specified different load functions.  This seems
-unlikely to arise in practice, though, so we could just detect the ambiguity
-and give an error at define-vop time.  If they are doing something totally
-weird, they can always inhibit loading and roll their own.
-
-Note that loading costs can be specified at the same time (same syntax) as
-association of loading functions with SCs.  It seems that maybe we will be
-rolling DEFINE-SAVE-SCS and DEFINE-MOVE-COSTS into DEFINE-STORAGE-CLASS.
-
-Fortunately, these changes will affect most VOP definitions very little.
-
-
-A Storage Base represents a physical storage resource such as a register set or
-stack frame.  Storage bases for non-global resources such as the stack are
-relativized by the environment that the TN is allocated in.  Packing conflict
-information is kept in the storage base, but non-packed storage resources such
-as closure environments also have storage bases.
-Some storage bases:
-    General purpose registers
-    Floating point registers
-    Boxed (control) stack environment
-    Unboxed (number) stack environment
-    Closure environment
-
-A storage class is a potentially arbitrary set of the elements in a storage
-base.  Although conceptually there may be a hierarchy of storage classes such
-as "all registers", "boxed registers", "boxed scratch registers", this doesn't
-exist at the implementation level.  Such things can be done by specifying
-storage classes whose locations overlap.  A TN shouldn't have lots of
-overlapping SC's as legal SC's, since time would be wasted repeatedly
-attempting to pack in the same locations.
-
-There will be some SC's whose locations overlap a great deal, since we get Pack
-to do our representation analysis by having lots of SC's.  A SC is basically a
-way of looking at a storage resource.  Although we could keep a fixnum and an
-unboxed representation of the same number in the same register, they correspond
-to different SC's since they are different representation choices.
-
-TNs are annotated with the primitive type of the object that they hold:
-    T: random boxed object with only one representation.
-    Fixnum, Integer, XXX-Float: Object is always of the specified numeric type.
-    String-Char: Object is always a string-char.
-
-When a TN is packed, it is annotated with the SC it was packed into.  The code
-generator for a VOP must be able to uniquely determine the representation of
-its operands from the SC. (debugger also...)
-
-Some SCs:
-    Reg: any register (immediate objects)
-    Save-Reg: a boxed register near r15 (registers easily saved in a call)
-    Boxed-Reg: any boxed register (any boxed object)
-    Unboxed-Reg: any unboxed register (any unboxed object)
-    Float-Reg, Double-Float-Reg: float in FP register.
-    Stack: boxed object on the stack (on cstack)
-    Word: any 32bit unboxed object on nstack.
-    Double: any 64bit unboxed object on nstack.
-
-We have a number of non-packed storage classes which serve to represent access
-costs associated with values that are not allocated using conflicts
-information.  Non-packed TNs appear to already be packed in the appropriate
-storage base so that Pack doesn't get confused.  Costs for relevant non-packed
-SC's appear in the TN-Ref cost information, but need not ever be summed into
-the TN cost vectors, since TNs cannot be packed into them.
-
-There are SCs for non-immediate constants and for each significant kind of
-immediate operand in the architecture.  On the RT, 4, 8 and 20 bit integer SCs
-are probably worth having.
-
-Non-packed SCs:
-    Constant
-    Immediate constant SCs:
-        Signed-Byte-<N>, Unsigned-Byte-<N>, for various architecture dependent
-	    values of <N>
-	String-Char
-	XXX-Float
-	Magic values: T, NIL, 0.
-
-
-\chapter{Type system parameterization}
-
-The main aspect of the VM that is likely to vary for good reason is the type
-system:
-
- -- Different systems will have different ways of representing dynamic type
-    information.  The primary effect this has on the compiler is causing VMR
-    conversion of type tests and checks to be implementation dependent.
-    Rewriting this code for each implementation shouldn't be a big problem,
-    since the portable semantics of types has already been dealt with.
-
- -- Different systems will have different specialized number and array types,
-    and different VOPs specialized for these types.  It is easy add this kind
-    of knowledge without affecting the rest of the compiler.  All you have to
-    do is define the VOPs and translations.
-
- -- Different systems will offer different specialized storage resources
-    such as floating-point registers, and will have additional kinds of
-    primitive-types.  The storage class mechanism handles a large part of this,
-    but there may be some problem in getting VMR conversion to realize the
-    possibly large hidden costs in implicit moves to and from these specialized
-    storage resources.  Probably the answer is to have some sort of general
-    mechanism for determining the primitive-type for a TN given the Lisp type,
-    and then to have some sort of mechanism for automatically using specialized
-    Move VOPs when the source or destination has some particular primitive-type.
-
-\#|
-How to deal with list/null(symbol)/cons in primitive-type structure?  Since
-cons and symbol aren't used for type-specific template selection, it isn't
-really all that critical.  Probably Primitive-Type should return the List
-primitive type for all of Cons, List and Null (indicating when it is exact).
-This would allow type-dispatch for simple sequence functions (such as length)
-to be done using the standard template-selection mechanism.  [Not a wired
-assumption] 
-|\#
-
-
-
-\chapter{VOP Definition}
-
-Before the operand TN-refs are passed to the emit function, the following
-stuff is done:
- -- The refs in the operand and result lists are linked together in order using
-    the Across slot.  This list is properly NIL terminated.
- -- The TN slot in each ref is set, and the ref is linked into that TN's refs
-    using the Next slot.
- -- The Write-P slot is set depending on whether the ref is an argument or
-    result.
- -- The other slots have the default values.
-
-The template emit function fills in the Vop, Costs, Cost-Function,
-SC-Restriction and Preference slots, and links together the Next-Ref chain as
-appropriate.
-
-
-\section{Lifetime model}
-
-\#|
-Note in doc that the same TN may not be used as both a more operand and as any
-other operand to the same VOP, to simplify more operand LTN number coalescing.
-|\#
-
-It seems we need a fairly elaborate model for intra-VOP conflicts in order to
-allocate temporaries without introducing spurious conflicts.  Consider the
-important case of a VOP such as a miscop that must have operands in certain
-registers.  We allocate a wired temporary, create a local preference for the
-corresponding operand, and move to (or from) the temporary.  If all temporaries
-conflict with all arguments, the result will be correct, but arguments could
-never be packed in the actual passing register.  If temporaries didn't conflict
-with any arguments, then the temporary for an earlier argument might get packed
-in the same location as the operand for a later argument; loading would then
-destroy an argument before it was read.
-
-A temporary's intra-VOP lifetime is represented by the times at which its life
-starts and ends.  There are various instants during the evaluation that start
-and end VOP lifetimes.  Two TNs conflict if the live intervals overlap.
-Lifetimes are open intervals: if one TN's lifetime begins at a point where
-another's ends, then the TNs don't conflict.
-
-The times within a VOP are the following:
-
-:Load
-    This is the beginning of the argument's lives, as far as intra-vop
-    conflicts are concerned.  If load-TNs are allocated, then this is the
-    beginning of their lives.
-
-(:Argument <n>)
-    The point at which the N'th argument is read for the last time (by this
-    VOP).  If the argument is dead after this VOP, then the argument becomes
-    dead at this time, and may be reused as a temporary or result load-TN.
-
-(:Eval <n>)
-    The N'th evaluation step.  There may be any number of evaluation steps, but
-    it is unlikely that more than two are needed.
-
-(:Result <n>) 
-    The point at which the N'th result is first written into.  This is the
-    point at which that result becomes live.
-
-:Save
-    Similar to :Load, but marks the end of time.  This is point at which result
-    load-TNs are stored back to the actual location.
-
-In any of the list-style time specifications, the keyword by itself stands for
-the first such time, i.e.
-    :argument  <==>  (:argument 0)
-
-
-Note that argument/result read/write times don't actually have to be in the
-order specified, but they must *appear* to happen in that order as far as
-conflict analysis is concerned.  For example, the arguments can be read in any
-order as long no TN is written that has a life beginning at or after
-(:Argument <n>), where N is the number of an argument whose reading was
-postponed.
-
-[\#\#\# (???)
-
-We probably also want some syntactic sugar in Define-VOP for automatically
-moving operands to/from explicitly allocated temporaries so that this kind of
-thing is somewhat easy.  There isn't really any reason to consider the
-temporary to be a load-TN, but we want to compute costs as though it was and
-want to use the same operand loading routines.
-
-We also might consider allowing the lifetime of an argument/result to be
-extended forward/backward.  This would in many cases eliminate the need for
-temporaries when operands are read/written out of order.
-]
-
-
-\section{VOP Cost model}
-
-Note that in this model, if a operand has no restrictions, it has no cost.
-This makes make sense, since the purpose of the cost is to indicate the
-relative value of packing in different SCs.  If the operand isn't required to
-be in a good SC (i.e. a register), then we might as well leave it in memory.
-The SC restriction mechanism can be used even when doing a move into the SC is
-too complex to be generated automatically (perhaps requiring temporary
-registers), since Define-VOP allows operand loading to be done explicitly.
-
-
-\section{Efficiency notes}
-
-  In addition to
-being used to tell whether a particular unsafe template might get emitted, we
-can also use it to give better efficiency notes:
- -- We can say what is wrong with the call types, rather than just saying we
-    failed to open-code.
- -- We can tell whether any of the "better" templates could possibly apply,
-    i.e. is the inapplicability of a template because of inadequate type
-    information or because the type is just plain wrong.  We don't want to
-    flame people when a template that couldn't possibly match doesn't match,
-    e.g. complaining that we can't use fixnum+ when the arguments are known to
-    be floats.
-
-
-This is how we give better efficiency notes:
-
-The Template-Note is a short noun-like string without capitalization or
-punctuation that describes what the template "does", i.e. we say
-"Unable to do ~A, doing ~A instead."
-
-The Cost is moved from the Vop-Info to the Template structure, and is used to
-determine the "goodness" of possibly applicable templates.  [Could flush
-Template/Vop-Info distinction]  The cost is used to choose the best applicable
-template to emit, and also to determine what better templates we might have
-been able to use.
-
-A template is possibly applicable if there is an intersection between all of
-the arg/result types and the corresponding arg/result restrictions, i.e. the
-template is not clearly impossible: more declarations might allow it to be
-emitted.
-
-
-\chapter{Assembler Retargeting}
-
-
-\chapter{Writing Assembly Code}
-
-VOP writers expect:
-   MOVE
-      You write when you port the assembler.)
-   EMIT-LABEL
-      Assembler interface like INST.  Takes a label you made and says "stick it
-      here."
-   GEN-LABEL
-      Returns a new label suitable for use with EMIT-LABEL exactly once and
-      for referencing as often as necessary.
-   INST
-      Recognizes and dispatches to instructions you defined for assembler.
-   ALIGN
-      This takes the number of zero bits you want in the low end of the address
-      of the next instruction.
-   ASSEMBLE
-   ASSEMBLE-ELSEWHERE
-      Get ready for assembling stuff.  Takes a VOP and arbitrary PROGN-style
-      body.  Wrap these around instruction emission code announcing the first
-      pass of our assembler.
-   CURRENT-NFP-TN
-      This returns a TN for the NFP if the caller uses the number stack, or
-      nil.
-   SB-ALLOCATED-SIZE
-      This returns the size of some storage based used by the currently
-      compiling component.
-   ...
-
-;;;
-;;; VOP idioms
-;;;
-
-STORE-STACK-TN
-LOAD-STACK-TN
-   These move a value from a register to the control stack, or from the
-   control stack to a register.  They take care of checking the TN types,
-   modifying offsets according to the address units per word, etc.
-
-
-\chapter{Required VOPS}
-
-
-Note: the move VOP cannot have any wired temps.  (Move-Argument also?)  This is
-so we can move stuff into wired TNs without stepping on our toes.
-
-
-We create set closure variables using the Value-Cell VOP, which takes a value
-and returns a value cell containing the value.  We can basically use this
-instead of a Move VOP when initializing the variable.  Value-Cell-Set and
-Value-Cell-Ref are used to access the value cell.  We can have a special effect
-for value cells so that value cells references can be discovered to be common
-subexpressions or loop invariants.
-
-
-
-
-Represent unknown-values continuations as (start, count).  Unknown values
-continuations are always outside of the current frame (on stack top).  Within a
-function, we always set up and receive values in the standard passing
-locations.  If we receive stack values, then we must BLT them down to the start
-of our frame, filling in any unsupplied values.  If we generate unknown values
-(i.e. PUSH-VALUES), then we set the values up in the standard locations, then
-BLT them to stack top.  When doing a tail-return of MVs, we just set them up in
-the standard locations and decrement SP: no BLT is necessary.
-
-Unknown argument call (MV-CALL) takes its arguments on stack top (is given a
-base pointer).  If not a tail call, then we just set the arg pointer to the
-base pointer and call.  If a tail call, we must BLT the arguments down to the
-beginning of the current frame.
-
-
-Implement more args by BLT'ing the more args *on top* of the current frame.
-This solves two problems:
- -- Any register more arguments can be made uniformly accessibly by copying
-    them into memory.  [We can't store the registers in place, since the
-    beginning of the frame gets double use for storing the old-cont, return-pc
-    and env.]
- -- It solves the deallocation problem: the arguments will be deallocated when
-    the frame is returned from or a tail full call is done out of it.  So
-    keyword args will be properly tail-recursive without any special mechanism
-    for squeezing out the more arg once the parsing is done.  Note that a tail
-    local call won't blast the more arg, since in local call the callee just
-    takes the frame it is given (in this case containing the more arg).
-
-More args in local call???  Perhaps we should not attempt local call conversion
-in this case.  We already special-case keyword args in local call.  It seems
-that the main importance of more args is primarily related to full call: it is
-used for defining various kinds of frobs that need to take arbitrary arguments:
- -- Keyword arguments
- -- Interpreter stubs
- -- "Pass through" applications such as dispatch functions
-
-Given the marginal importance of more args in local call, it seems unworth
-going to any implementation difficulty.  In fact, it seems that it would cause
-complications both at the VMR level and also in the VM definition.  This being
-the case, we should flush it.
-
-
-\section{Function Call}
-
-
-
-\subsection{Registers and frame format}
-
-These registers are used in function call and return:
-
-A0..A{\it n}
-    In full call, the first three arguments.  In unknown values return, the
-    first three return values.
-
-CFP
-    The current frame pointer.  In full call, this initially points to a
-    partial frame large enough to hold the passed stack arguments (zero-length
-    if none).
-
-CSP
-    The current control stack top pointer. 
-
-OCFP
-    In full call, the passing location for the frame to return to.
-
-    In unknown-values return of other than one value, the pointer to returned
-    stack values.  In such a return, OCFP is always initialized to point to
-    the frame returned from, even when no stack values are returned.  This
-    allows OCFP to be used to restore CSP.
-
-LRA
-    In full call, the passing location for the return PC.
-
-NARGS
-    In full call, the number of arguments passed.  In unknown-values return of
-    other than one value, the number of values returned.
-
-
-\subsection{Full call}
-
-What is our usage of CFP, OCFP and CSP?  
-
-It is an invariant that CSP always points after any useful information so that
-at any time an interrupt can come and allocate stuff in the stack.
-
-TR call is also a constraint: we can't deallocate the caller's frame before the
-call, since it holds the stack arguments for the call.  
-
-What we do is have the caller set up CFP, and have the callee set CSP to CFP
-plus the frame size.  The caller leaves CSP alone: the callee is the one who
-does any necessary stack deallocation.
-
-In a TR call, we don't do anything: CFP is left as CFP, and CSP points to the
-end of the frame, keeping the stack arguments from being trashed.
-
-In a normal call, CFP is set to CSP, causing the callee's frame to be allocated
-after the current frame.
-
-
-\subsection{Unknown values return}
-
-The unknown values return convention is always used in full call, and is used
-in local call when the compiler either can't prove that a fixed number of
-values are returned, or decides not to use the fixed values convention to allow
-tail-recursive XEP calls.
-
-The unknown-values return convention has variants: single value and variable
-values.  We make this distinction to optimize the important case of a returner
-whose knows exactly one value is being returned.  Note that it is possible to
-return a single value using the variable-values convention, but it is less
-efficient.
-
-We indicate single-value return by returning at the return-pc+4; variable value
-return is indicated by returning at the return PC.
-
-Single-value return makes only the following guarantees:
-    A0 holds the value returned.
-    CSP has been reset: there is no garbage on the stack.
-
-In variable value return, more information is passed back:
-    A0..A2 hold the first three return values.  If fewer than three values are
-    returned, then the unused registers are initialized to NIL.
-
-    OCFP points to the frame returned from.  Note that because of our
-    tail-recursive implementation of call, the frame receiving the values is
-    always immediately under the frame returning the values.  This means that
-    we can use OCFP to index the values when we access them, and to restore
-    CSP when we want to discard them.
-
-    NARGS holds the number of values returned.
-
-    CSP is always (+ OCFP (* NARGS 4)), i.e. there is room on the stack
-    allocated for all returned values, even if they are all actually passed in
-    registers.
-
-
-\subsection{External Entry Points}
-
-Things that need to be done on XEP entry:
- 1] Allocate frame
- 2] Move more arg above the frame, saving context
- 3] Set up env, saving closure pointer if closure
- 4] Move arguments from closure to local home
-    Move old-cont and return-pc to the save locations
- 5] Argument count checking and dispatching
-
-XEP VOPs:
-
-Allocate-Frame
-Copy-More-Arg <nargs-tn> 'fixed {in a3} => <context>, <count>
-Setup-Environment
-Setup-Closure-Environment => <closure>
-Verify-Argument-Count <nargs-tn> 'count {for fixed-arg lambdas}
-Argument-Count-Error <nargs-tn> {Drop-thru on hairy arg dispatching}
-Use fast-if-=/fixnum and fast-if-</fixnum for dispatching.
-
-Closure vops:
-make-closure <fun entry> <slot count> => <closure>
-closure-init <closure> <values> 'slot
-
-
-Things that need to be done on all function entry:
- -- Move arguments to the variable home (consing value cells as necessary)
- -- Move environment values to the local home
- -- Move old-cont and return-pc to the save locations
-
-
-\section{Calls}
-
-Calling VOP's are a cross product of the following sets (with some members
-missing):
-   Return values
-      multiple (all values)
-      fixed (calling with unknown values conventions, wanting a certain
-             number.)
-      known (only in local call where caller/callee agree on number of
-      	     values.)
-      tail (doesn't return but does tail call)
-   What function
-      local
-      named (going through symbol, like full but stash fun name for error sys)
-      full (have a function)
-   Args
-      fixed (number of args are known at compile-time)
-      variable (MULTIPLE-VALUE-CALL and APPLY)
-
-Note on all jumps for calls and returns that we want to put some instruction
-in the jump's delay slot(s).
-
-Register usage at the time of the call:
-
-LEXENV
-   This holds the lexical environment to use during the call if it's a closure,
-   and it is undefined otherwise.
-
-CNAME
-   This holds the symbol for a named call and garbage otherwise.
-
-OCFP
-   This holds the frame pointer, which the system restores upon return.  The
-   callee saves this if necessary; this is passed as a pseudo-argument.
-
-A0 ... An
-   These holds the first n+1 arguments.
-
-NARGS
-   This holds the number of arguments, as a fixnum.
-
-LRA
-   This holds the lisp-return-address object which indicates where to return.
-   For a tail call, this retains its current value.  The callee saves this
-   if necessary; this is passed as a pseudo-argument.
-
-CODE
-   This holds the function object being called.
-
-CSP
-   The caller ignores this.  The callee sets it as necessary based on CFP.
-
-CFP
-   This holds the callee's frame pointer.  Caller sets this to the new frame
-   pointer, which it remembered when it started computing arguments; this is
-   CSP if there were no stack arguments.  For a tail call CFP retains its
-   current value.
-
-NSP
-   The system uses this within a single function.  A function using NSP must
-   allocate and deallocate before returning or making a tail call.
-
-Register usage at the time of the return for single value return, which
-goes with the unknown-values convention the caller used.
-
-A0
-   The holds the value.
-
-CODE
-   This holds the lisp-return-address at which the system continues executing.
-
-CSP
-   This holds the CFP.  That is, the stack is guaranteed to be clean, and there
-   is no code at the return site to adjust the CSP.
-
-CFP
-   This holds the OCFP.
-
-Additional register usage for multiple value return:
-
-NARGS
-   This holds the number of values returned.
-
-A0 ... An
-   These holds the first n+1 values, or NIL if there are less than n+1 values.
-
-CSP
-   Returner stores CSP to hold its CFP + NARGS * <address units per word>
-
-OCFP
-   Returner stores this as its CFP, so the returnee has a handle on either
-   the start of the returned values on the stack.
-
-
-ALLOCATE FULL CALL FRAME.
-
-If the number of call arguments (passed to the VOP as an info argument)
-indicates that there are stack arguments, then it makes some callee frame for
-arguments:
-   VOP-result <- CSP
-   CSP <- CSP + value of VOP info arg times address units per word.
-
-In a call sequence, move some arguments to the right places.
-
-There's a variety of MOVE-ARGUMENT VOP's.
-
-FULL CALL VOP'S
-(variations determined by whether it's named, it's a tail call, there
-is a variable arg count, etc.)
-
-  if variable number of arguments
-    NARGS <- (CSP - value of VOP argument) shift right by address units per word.
-    A0...An <- values off of VOP argument (just fill them all)
-  else
-    NARGS <- value of VOP info argument (always a constant)
-
-  if tail call
-    OCFP <- value from VOP argument
-    LRA <- value from VOP argument
-    CFP stays the same since we reuse the frame
-    NSP <- NFP
-  else
-    OCFP <- CFP
-    LRA <- compute LRA by adding an assemble-time determined constant to
-    	   CODE.
-    CFP <- new frame pointer (remembered when starting to compute args)
-           This is CSP if no stack args.
-    when (current-nfp-tn VOP-self-pointer)
-      stack-temp <- NFP
-
-  if named
-    CNAME <- function symbol name
-    the-fun <- function object out of symbol
-
-  LEXENV <- the-fun (from previous line or VOP argument)
-  CODE <- function-entry (the first word after the-fun)
-  LIP <- calc first instruction addr (CODE + constant-offset)
-  jump and run off temp
-
-  <emit Lisp return address data-block>
-  <default and move return values OR receive return values>
-  when (current-nfp-tn VOP-self-pointer)
-    NFP <- stack-temp
-
-Callee:
-
-XEP-ALLOCATE-FRAME
-  emit function header (maybe initializes offset back to component start,
-  			but other pointers are set up at load-time.  Pads
-			to dual-word boundary.)
-  CSP <- CFP + compile-time determined constant (frame size)
-  if the function uses the number stack
-    NFP <- NSP
-    NSP <- NSP + compile-time determined constant (number stack frame size)
-
-SETUP-ENVIRONMENT
-(either use this or the next one)
-
-CODE <- CODE - assembler-time determined offset from function-entry back to
-	       the code data-block address.
-
-SETUP-CLOSURE-ENVIRONMENT
-(either use this or the previous one)
-After this the CLOSURE-REF VOP can reference closure variables.
-
-VOP-result <- LEXENV
-CODE <- CODE - assembler-time determined offset from function-entry back to
-	       the code data-block address.
-
-Return VOP's
-RETURN and RETURN-MULTIPLE are for the unknown-values return convention.
-For some previous caller this is either it wants n values (and it doesn't
-know how many are coming), or it wants all the values returned (and it 
-doesn't know how many are coming).
-
-
-RETURN
-(known fixed number of values, used with the unknown-values convention
- in the caller.)
-When compiler invokes VOP, all values are already where they should be;
-just get back to caller.
-
-when (current-nfp-tn VOP-self-pointer)
-  ;; The number stack grows down in memory.
-  NSP <- NFP + number stack frame size for calls within the currently
-                  compiling component
-	       times address units per word
-CODE <- value of VOP argument with LRA
-if VOP info arg is 1 (number of values we know we're returning)
-  CSP <- CFP
-  LIP <- calc target addr
-          (CODE + skip over LRA header word + skip over address units per branch)
-	  (The branch is in the caller to skip down to the MV code.)
-else
-  NARGS <- value of VOP info arg
-  nil out unused arg regs
-  OCFP <- CFP  (This indicates the start of return values on the stack,
-  		but you leave space for those in registers for convenience.)
-  CSP <- CFP + NARGS * address-units-per-word
-  LIP <- calc target addr (CODE + skip over LRA header word)
-CFP <- value of VOP argument with OCFP
-jump and run off LIP
-
-RETURN-MULTIPLE
-(unknown number of values, used with the unknown-values convention in
- the caller.)
-When compiler invokes VOP, it gets TN's representing a pointer to the
-values on the stack and how many values were computed.
-
-when (current-nfp-tn VOP-self-pointer)
-  ;; The number stack grows down in memory.
-  NSP <- NFP + number stack frame size for calls within the currently
-                  compiling component
-	       times address units per word
-NARGS <- value of VOP argument
-copy the args to the beginning of the current (returner's) frame.
-   Actually some go into the argument registers.  When putting the rest at
-   the beginning of the frame, leave room for those in the argument registers.
-CSP <- CFP + NARGS * address-units-per-word
-nil out unused arg regs
-OCFP <- CFP  (This indicates the start of return values on the stack,
-	      but you leave space for those in registers for convenience.)
-CFP <- value of VOP argument with OCFP
-CODE <- value of VOP argument with LRA
-LIP <- calc target addr (CODE + skip over LRA header word)
-jump and run off LIP
-
-
-Returnee
-The call VOP's call DEFAULT-UNKNOWN-VALUES or RECEIVE-UNKNOWN-VALUES after
-spitting out transfer control to get stuff from the returner.
-
-DEFAULT-UNKNOWN-VALUES
-(We know what we want and we got something.)
-If returnee wants one value, it never does anything to deal with a shortage
-of return values.  However, if start at PC, then it has to adjust the stack
-pointer to dump extra values (move OCFP into CSP).  If it starts at PC+N,
-then it just goes along with the "want one value, got it" case.
-If the returnee wants multiple values, and there's a shortage of return
-values, there are two cases to handle.  One, if the returnee wants fewer
-values than there are return registers, and we start at PC+N, then it fills
-in return registers A1..A<desired values necessary>; if we start at PC,
-then the returnee is fine since the returning conventions have filled in
-the unused return registers with nil, but the returnee must adjust the
-stack pointer to dump possible stack return values (move OCFP to CSP).
-Two, if the returnee wants more values than the number of return registers,
-and it starts at PC+N (got one value), then it sets up returnee state as if
-an unknown number of values came back:
-   A0 has the one value
-   A1..An get nil
-   NARGS gets 1
-   OCFP gets CSP, so general code described below can move OCFP into CSP
-If we start at PC, then branch down to the general "got k values, wanted n"
-code which takes care of the following issues:
-   If k < n, fill in stack return values of nil for shortage of return
-      values and move OCFP into CSP
-   If k >= n, move OCFP into CSP
-This also restores CODE from LRA by subtracting an assemble-time constant.
-
-RECEIVE-UKNOWN-VALUES
-(I want whatever I get.)
-We want these at the end of our frame.  When the returnee starts starts at
-PC, it moves the return value registers to OCFP..OCFP[An] ignoring where
-the end of the stack is and whether all the return value registers had
-values.  The returner left room on the stack before the stack return values
-for the register return values.  When the returnee starts at PC+N, bump CSP
-by 1 and copy A0 there.
-This also restores CODE from LRA by subtracting an assemble-time constant.
-
-
-Local call
-
-There are three flavors:
-   1] KNOWN-CALL-LOCAL
-      Uses known call convention where caller and callee agree where all
-      the values are, and there's a fixed number of return values.
-   2] CALL-LOCAL
-      Uses the unknown-values convention, but we expect a particular
-      number of values in return.
-   3] MULTIPLE-CALL-LOCAL
-      Uses the unknown-values convention, but we want all values returned.
-
-ALLOCATE-FRAME
-
-If the number of call arguments (passed to the VOP as an info argument)
-indicates that there are stack arguments, then it makes some callee frame for
-arguments:
-   VOP-result1 <- CSP
-   CSP <- CSP + control stack frame size for calls within the currently
-   		   compiling component
-   		times address units per word.
-   when (callee-nfp-tn <VOP info arg holding callee>)
-     ;; The number stack grows down.
-     ;; May have to round to dual-word boundary if machines C calling
-     ;;    conventions demand this.
-     NSP <- NSP - number stack frame size for calls within the currently
-     		     compiling component
-		  times address units per word
-     VOP-result2 <- NSP
-
-KNOWN-CALL-LOCAL, CALL-LOCAL, MULTIPLE-CALL-LOCAL
-KNOWN-CALL-LOCAL has no need to affect CODE since CODE is the same for the
-caller/returnee and the returner.  This uses KNOWN-RETURN.
-With CALL-LOCAL and MULTIPLE-CALL-LOCAL, the caller/returnee must fixup
-CODE since the callee may do a tail full call.  This happens in the code
-emitted by DEFAULT-UNKNOWN-VALUES and RECEIVE-UNKNOWN-VALUES.  We use these
-return conventions since we don't know what kind of values the returner
-will give us.  This could happen due to a tail full call to an unknown
-function, or because the callee had different return points that returned
-various numbers of values.
-
-when (current-nfp-tn VOP-self-pointer)   ;Get VOP self-pointer with
-					 ;DEFINE-VOP switch :vop-var.
-  stack-temp <- NFP
-CFP <- value of VOP arg
-when (callee-nfp-tn <VOP info arg holding callee>)
-  <where-callee-wants-NFP-tn>  <-  value of VOP arg
-<where-callee-wants-LRA-tn>  <-  compute LRA by adding an assemble-time
-				 determined constant to CODE.
-jump and run off VOP info arg holding start instruction for callee
-
-<emit Lisp return address data-block>
-<case call convention
-  known: do nothing
-  call: default and move return values
-  multiple: receive return values
->
-when (current-nfp-tn VOP-self-pointer)   
-  NFP <- stack-temp
-
-KNOWN-RETURN
-
-CSP <- CFP
-when (current-nfp-tn VOP-self-pointer)
-  ;; number stack grows down in memory.
-  NSP <- NFP + number stack frame size for calls within the currently
-                  compiling component
-	       times address units per word
-LIP <- calc target addr (value of VOP arg + skip over LRA header word)
-CFP <- value of VOP arg
-jump and run off LIP
-
-
-
-
-\chapter{Standard Primitives}
-
-
-\chapter{Customizing VMR Conversion}
-
-Another way in which different implementations differ is in the relative cost
-of operations.  On machines without an integer multiply instruction, it may be
-desirable to convert multiplication by a constant into shifts and adds, while
-this is surely a bad idea on machines with hardware support for multiplication.
-Part of the tuning process for an implementation will be adding implementation
-dependent transforms and disabling undesirable standard transforms.
-
-When practical, ICR transforms should be used instead of VMR generators, since
-transforms are more portable and less error-prone.  Note that the Lisp code
-need not be implementation independent: it may contain all sorts of
-sub-primitives and similar stuff.  Generally a function should be implemented
-using a transform instead of an VMR translator unless it cannot be implemented
-as a transform due to being totally evil or it is just as easy to implement as
-a translator because it is so simple.
-
-
-\section{Constant Operands}
-
-If the code emitted for a VOP when an argument is constant is very different
-than the non-constant case, then it may be desirable to special-case the
-operation in VMR conversion by emitting different VOPs.  An example would be if
-SVREF is only open-coded when the index is a constant, and turns into a miscop
-call otherwise.  We wouldn't want constant references to spuriously allocate
-all the miscop linkage registers on the off chance that the offset might not be
-constant.  See the :constant feature of VOP primitive type restrictions.
-
-
-\section{Supporting Multiple Hardware Configurations}
-
-
-A winning way to change emitted code depending on the hardware configuration,
-i.e. what FPA is present is to do this using primitive types.  Note that the
-Primitive-Type function is VM supplied, and can look at any appropriate
-hardware configuration switches.  Short-Float can become 6881-Short-Float,
-AFPA-Short-Float, etc.  There would be separate SBs and SCs for the registers
-of each kind of FP hardware, with the each hardware-specific primitive type
-using the appropriate float register SC.  Then the hardware specific templates
-would provide AFPA-Short-Float as the argument type restriction.
-
-Primitive type changes:
-
-The primitive-type structure is given a new %Type slot, which is the CType
-structure that is equivalent to this type.  There is also a Guard slot, with,
-if true is a function that control whether this primitive type is allowed (due
-to hardware configuration, etc.)  
-
-We add new :Type and :Guard keywords to Def-Primitive-Type.  Type is the type
-specifier that is equivalent (default to the primitive-type name), and Guard is
-an expression evaluated in the null environment that controls whether this type
-applies (default to none, i.e. constant T).
-
-The Primitive-Type-Type function returns the Lisp CType corresponding to a
-primitive type.  This is the %Type unless there is a guard that returns false,
-in which case it is the empty type (i.e. NIL).
-
-[But this doesn't do what we want it to do, since we will compute the
-function type for a template at load-time, so they will correspond to whatever
-configuration was in effect then.  Maybe we don't want to dick with guards here
-(if at all).  I guess we can defer this issue until we actually support
-different FP configurations.  But it would seem pretty losing to separately
-flame about all the different FP configurations that could be used to open-code
-+ whenever we are forced to closed-code +.
-
-If we separately report each better possibly applicable template that we
-couldn't use, then it would be reasonable to report any conditional template
-allowed by the configuration.  
-
-But it would probably also be good to give some sort of hint that perhaps it
-would be a good time to make sure you understand how to tell the compiler to
-compile for a particular configuration.  Perhaps if there is a template that
-applies *but for the guard*, then we could give a note.  This way, if someone
-thinks they are being efficient by throwing in lots of declarations, we can let
-them know that they may have to do more.
-
-I guess the guard should be associated with the template rather than the
-primitive type.  This would allow LTN and friends to easily tell whether a
-template applies in this configuration.  It is also probably more natural for
-some sorts of things: with some hardware variants, it may be that the SBs and
-representations (SCs) are really the same, but there some different allowed
-operations.  In this case, we could easily conditionalize VOPs without the
-increased complexity due to bogus SCs.  If there are different storage
-resources, then we would conditionalize Primitive-Type as well.
-
-
-
-\section{Special-case VMR convert methods}
-
-    (defun continuation-tn (cont \&optional (check-p t))
-      ...)
-Return the TN which holds Continuation's first result value.  In general
-this may emit code to load the value into a TN.  If Check-P is true, then
-when policy indicates, code should be emitted to check that the value satisfies
-the continuation asserted type.
-
-    (defun result-tn (cont)
-      ...)
-Return the TN that Continuation's first value is delivered in.  In general,
-may emit code to default any additional values to NIL.
-
-    (defun result-tns (cont n)
-      ...)
-Similar to Result-TN, except that it returns a list of N result TNs, one
-for each of the first N values.
-
-
-Nearly all open-coded functions should be handled using standard template
-selection.  Some (all?) exceptions:
- -- List, List* and Vector take arbitrary numbers of arguments.  Could
-    implement Vector as a source transform.  Could even do List in a transform
-    if we explicitly represent the stack args using %More-Args or something.
- -- %Typep varies a lot depending on the type specifier.  We don't want to
-    transform it, since we want %Typep as a canonical form so that we can do
-    type optimizations.
- -- Apply is weird.
- -- Funny functions emitted by the compiler: %Listify-Rest-Args, Arg,
-    %More-Args, %Special-Bind, %Catch, %Unknown-Values (?), %Unwind-Protect,
-    %Unwind, %%Primitive.
diff --git a/docs/internals/run-time.tex b/docs/internals/run-time.tex
deleted file mode 100644
index eb21e1cf8b0b5ca4ebe33f13fa5196704385a862..0000000000000000000000000000000000000000
--- a/docs/internals/run-time.tex
+++ /dev/null
@@ -1,7 +0,0 @@
-\part{Run-Time system}
-\include{environment}
-\include{interpreter}
-\include{debugger}
-\include{object}
-\include{lowlev}
-\include{fasl}
diff --git a/docs/internals/vm.tex b/docs/internals/vm.tex
deleted file mode 100644
index b1e1c2fe8418f384a49871fbb5843ef8865068ac..0000000000000000000000000000000000000000
--- a/docs/internals/vm.tex
+++ /dev/null
@@ -1,1454 +0,0 @@
-\chapter{Introduction} % -*- Dictionary: design -*-
-
-(defun gvp (f)
-  (with-open-file (s f :direction :output :if-exists :supersede)
-    (maphash \#'(lambda (k v)
-		 (declare (ignore v))
-		 (format s "~A~%" k))
-	     (c::backend-template-names c::*backend*))))
-
-
-\section{Scope and Purpose}
-
-This document describes the Virtual Machine that serves as the basis for the
-portable implementation of \ccl.  The Virtual Machine (hereafter referred to as
-the VM) provides a layer of abstraction that hides low-level details of
-hardware and implementation strategy, while still revealing enough of the
-implementation so that most of the system can be written at the VM level or
-above.
-
-\begin{comment}
-
-{\#\#\# Shouldn't specify VOPs.  Instead, should specify which \clisp functions
-are primitive and which subprimitives exist.  Isn't really anyone's business
-which VOPs actually exist.  Each primitive function or subprimitive is
-implemented either as a VOP or as expansion into Lisp code, at the particular
-implementation's discretion.
-
-From this point of view, the document is expressing the contract that the Lisp
-level code outside of the compiler must satisfy.  All functions must ultimately
-be defined in terms of primitive functions and sub-primitives.  
-
-The responsibility of the compiler is to implement these primitive operations,
-and also to implement special forms, variables and function calling.
-
-VOPs emitted by the hard-wired translators for non-function nodes are a
-somewhat different story.  Each implementation will presumably implement all
-these VOPs in order to avoid having to rewrite IR2 translation.  We also need
-to spend quite a bit of time discussing the semantics of these operations,
-since they don't just correspond to some \clisp function with type constraints.
-
-Hard-wired stuff:
-
-function call
-variable access:
-  global
-  function
-  constant
-  closure
-  local
-closure creation
-non-local exit
-special binding/unbinding
-TN hacking:
-  move VOPs
-  TN address (???)
-Conditionals:
-  Basic conditionals: EQ, ...
-  Interface to generation of other conditional VOPs.
-
-Some VOPs don't need to be implemented at all:
-  VOPs to delimit the lifetimes of big stack TNs such as catch blocks
-  Others?  Move VOPs might be defined in terms of an implementation supplied
-  move routine, since we probably also need this info outside of VOP generators
-  so that implicit moves can be generated.
-
-
-Type testing/checking (somehow)
-
-}
-
-What this document talks about:
-
-Interface between compiler front-end and back end. (VOPs)
-   Primitive \clisp operations directly supported by the VM.
-   Support for complex language features such as function call.
-
-Sub-primitives that allow system code to do things not possible in \clisp.
-
-Descriptions of how the current \ccl system uses VM facilities, especially
-non-standard ones accessed through sub-primitives.
-
-Notes about known portability problems.
-
-Guidelines for writing portable \ccl system code.  To some degree these
-guidelines are implied by statements that certain things are true of \ccl
-system code.
-
-Descriptions of data structures that are not directly used by the VM, such as
-debug information and Core files.
-
-Descriptions of data structures that are directly used by the VM, such as
-symbols and arrays.
-
-
-Who should read it:
-
-People who want to port \ccl.
-People who want to understand the compiler.
-People who want to understand how \ccl works.
-People who need to write portable \ccl system code.
-People such as debugger writers who need to access \ccl\t()'s internal data
-structures.
-
-What it won't do:
-
-Tell you things that are obviously implementation dependent, such as type
-systems or memory management disciplines.  See the the various implementation
-VM documents.
-
-Tell you only what you need to know.  Programmers shouldn't exploit properties
-of the VM documented here unless there is no way to do the same thing in
-portable \clisp.
-
-Tell you how the compiler works.  In order to understand some of the subtleties
-of VOP descriptions, you will have to understand the IR2 representation and how
-it fits into the rest of the compiler.
-
-Tell you anything about \clisp semantics.  When some part of the VM has a
-direct relationship to \clisp semantics, the relationship will be directly
-stated using \clisp terminology, since a restatement of the semantics is likely
-to be inaccurate or misleading.  Exceptions will be made only when some
-implication of the \clisp semantics is non-obvious.
-
-Tell you everything about how \ccl works.  This document only offers
-information that is likely to be needed by programmers doing a port or writing
-system code; portable, self-contained parts of the system are totally ignored.
-This document deliberately avoids replicating information that is easily
-available in the system sources, since such replicated information is always
-incorrect somewhere.  In some cases, a forwarding pointer to the appropriate
-source will be given.
-
-
-Things the VM won't do:
-
-The VM specification does not totally solve the problem of porting \ccl, since
-it is inevitable that it will not map cleanly to all possible combinations of
-hardware and operating systems.  The VM should not be regarded as being cast in
-concrete, since changes in many characteristics would only affect a tiny
-fraction of the system sources.
-
-One current major problem with porting is that large pieces of functionality
-are entirely within the VM, and would need to be reimplemented for each port.
-A major goal for future work on the system is moving code out of the VM, both
-by supporting a "fast-call" convention that allows reasonable use of Lisp in
-the out of line implementation of VOPs, and by having a "bugout" mechanism that
-allows the VM to call Lisp functions to implement the hard cases in some VOPs.
-
-The VM is designed to support conventional, untagged, general register
-architectures.  Suitably lobotomized, it could be mapped to less flexible
-hardware such as "Lisp machines", but the compiler would have serious
-difficulties supporting stack architectures.
-
-The VM does not support concurrent lightweight processes.  Locking primitives
-and deep-binding of specials would be needed.
-
-The VM does not deal with operating systems interface issues at all.  A minimal
-port would require implementing at least file and terminal I/O streams.  \ccl
-implements system interfaces using Aliens and other facilities built on top of
-them.
-
-\end{comment}
-
-
-
-Major components:
-\begin{itemize}
-Specific virtual operations implemented by the VM (VOPs).  VOPs are primarily
-the concern of the compiler, since it translates Lisp code into VOPs and then
-translates VOPs into the implementation.
-
-Sub-primitives that are used by Lisp code needing to perform operations
-below the Lisp level.  The compiler implements some sub-primitives directly
-using VOPs, while others are translated into Lisp code.  Sub-primitives provide
-a layer of insulation between the Lisp system code and the VM, since the Lisp
-code may assume the existence of operations that are not implemented directly
-by the VM.  Only sub-primitives with fairly portable semantics are documented
-here.  Others are in implementation-specific VM documentation.
-\end{itemize}
-
-\comment<Not all sub-primitives are VOPs, and most VOPs are not sub-primitives.>
-
-
-
-\subsection{VOP base name rules}
-
-The names of VOPs that implement functions are based on the function name.
-Other VOPs may use any base that doesn't conflict with a function name.  There
-are some rules used to obtain the base name for related operations.
-
-To get the name of a setting operation, replace the string "{\tt ref}" in the name
-with "{\tt set}".  If "{\tt ref}" doesn't appear in the name, add the prefix "{\tt set-}" to the
-base name.  For example, {\tt svref} becomes {\tt svset}, and {\tt symbol-value}
-becomes {\tt set-symbol-value}.
-
-To get the name of a conditional VOP from the name of a predicate, add the
-prefix "{\tt if-}" to the predicate name.  For example, {\tt eq} becomes {\tt if-eq}.
-{\tt eq} by itself would be a VOP that returned true or false value.
-
-Some operations check for some error condition, magically signalling the error
-through an implicit control transfer.  These operations are prefixed with
-"{\tt check-}", as in {\tt check-fixnum} and {\tt check-bound}.
-
-
-
-\subsection{VOP name prefixes and suffixes}
-
-Prefixes and suffixes are added to the base to get the names of variant
-versions of the VOP.  The fully general VOP name looks like this:
-\begin{format}
-   {"{\tt small-}" | "{\tt fast-}"} {\it name}{"{\tt -c}" {\it info}}{"{\tt /}" {\it type}{"{\tt =>}" {\it result-type}}
-\end{format}
-The "{\tt small-}" and "{\tt fast-}" prefixes indicates that the VOP does minimal
-safety checking and is optimized for space or speed, respectively.  The absence
-of a prefix indicates the safest (or only) version.  Usually if the "{\tt small-}"
-VOP exists, it will be a synonym for either the fast version or the safe
-version, depending on which is smaller.
-
-The "{\tt -c}" suffix indicates that the some info that is passed as a normal
-argument to the base version of the VOP is passed as Codegen-Info in this
-version.  A typical use would be for VOPs where it is important to use a
-different version when one of the arguments is a compile time constant.
-{\it info} is some (possibly null) string that indicates which "{\tt -c}" variant
-is involved.
-
-The "{\tt /}{\it type}" suffix asserts that all operands that could be of {\it type} are.
-For example, {\tt +/fixnum} adds two fixnums returning a fixnum, while
-{\tt length/simple-vector} finds the length of a simple vector, but the result isn't
-a simple vector.
-
-The "{\tt =>}{\it result-type}" suffix supplies a result type assertion on the
-operation.
-
-A not totally silly example of all these modifiers simultaneously is
- {\tt fast-+-c/fixnum=>integer}.  This operation would this operation adds two
-fixnums, one of which is a constant passed as codegen info, resulting in an
-integer.  The implementation is optimized for speed at the expense of space and
-safety.
-
-
-
-\chapter{Data Types and Storage Resources}
-
-
-\section{Lisp Objects}
-\index{Lisp objects}
-
-A Lisp object is fixed-size data structure that is organized in a way mandated
-by the VM implementation.  The fixed format allows the VM to determine the type
-of the object.  \comment<Virtual type?  VM type?  Implementation type?
-...provides the VM enough information about the type of the object for the VM
-to implement the VM-level semantics...  ...supports the "dynamic types"...>
-
-Lisp objects are stored in locations known as cells. 
-
-
-Has major types: immediate and non-immediate.
-Non-immediate objects may have a subtype.
-Non-immediate types:
-  symbol (nil may be weird)
-  cons 
-  ratio
-  complex
-  some float types
-  g-vector
-  i-vector
-  string
-  bit-vector
-  environment (always has subtype)
-  array header
-  bignum
-  structure
-  pc (code vector)
-  stack closure (control stack pointer)
-
-Non-immediate objects are allocated in "type spaces".  The type space of an
-object is characterized by a small integer known as the type code.  Any two
-objects of one of the above boxed types will always have the same type code.
-{But not really...  Some types might be allocated in different type spaces at
-different times. (?)}
-
-The type code doesn't totally describe the object.  In general, subtype
-information may be involved.
-
-
-Immediate types:
-  character
-  fixnum
-  unbound trap
-  short float
-
-
-
-\section{Type VOPs}
-
-We consider control transfer to be the fundamental result of comparison, rather
-than anything such as a condition code.  Although most compilers with whizzy
-register allocation seem to explicitly allocate and manipulate the condition
-codes, it seems that any benefit is small in our case.  This is partly because
-our VOPs are at a somewhat higher level, making it difficult to tell which VOPs
-do and don't trash the the CC.  Explicitly incorporating condition codes in our
-VM also introduces another architecture dependency.
-
-At the IR2 level, we have a class of IF-XXX VOPs which transfer control to one
-of two places on the basis of some test on the operands.  When generating code
-for a predicate, we peek at the destination IF node to find where to transfer
-control to.
-			
-The exact representation of type tests in IR2 will be fairly implementation
-dependent, since it will depend on the specific type system for the given
-implementation.  For example, if an implementation can test some types with a
-simple tag check, but other types require reading a field from the object in
-addition, then the two different kinds of checks should be distinct at the VOP
-level, since this will allow the VOP cost and storage information to be more
-accurate.  Generation of type tests should be factored out of code which would
-otherwise be more portable.  Probably the IR2 translator for TYPEP and the type
-check generation code are the only places that should know about how type tests
-are represented in IR2.
-
-if-type (object)
-if-type-range
-    If-Type Tests whether Object has the type code that is passed in the
-    codegen info.  If-Type-Range tests for a range of type codes.
-
-{small, fast} if-vector-type (object)
-    Test that Object is either of the specified type code, or is a 1d array
-    header with data having the specified type code.
-
-if-vector-subtype (object)
-    Test the subtype field of a vector-like object.  It is assumed that the
-    object has already been determined to be vector-like.
-
-if-fixnump (object)
-if-short-float-p
-if-characterp
-    The rationale behind having these as separate VOPs is that they are likely
-    to be immediate types, and thus may have bizzare type schemes.
-
-if-consp (object)
-if-listp
-    We have distinct operations for these predicates since one or the other
-    isn't a simple tag test, but we don't know which one.
-
-if-rationalp (object)
-if-floatp
-if-integerp
-if-numberp
-if-vectorp
-if-functionp
-    The rationale behind having these operations is that they may take a lot of
-    code, so it is reasonable to put them out of line.
-
-
-
-\section{Type Sub-primitives}
-
-change-type (object) => result
-    Change the type of an object according to codegen info.  The meaning of
-    this is highly type-system dependent, but it doesn't matter, since the
-    compiler will never emit this VOP directly.  The only way that it can show
-    up is through %Primitive.
-get-type
-
-
-Storage resources:
-
-Boxed and unboxed locations:
-Non-immediate objects may not be stored in unboxed locations.
-Things not lisp objects may not be stored in boxed locations.
-
-Control stack is boxed.
-Optional number stack is unboxed.
-Heap environment is boxed.
-Fixed number of registers, some boxed and some unboxed.
-
-PCs may be stored on the control stack or in boxed registers, subject to the
-constraint that a corresponding environment is also stored.  Locations
-containing PCs don't need to be zeroed when they are no longer used; nothing
-bad will happen if an old PC is unaccompanied by an environment.
-
-
-\item[Trap]Illegal object trap.  This value is used in symbols to signify an
-undefined value or definition.
-
-
-\chapter{Characters}
-
-
-Character is an immediate type.  Characters are manipulated primarily by
-converting into an integer and accessing these fields:
-\begin{description}
-\item[{\tt %character-code-byte}]The character code.  This is effectively required to
-start at bit 0, since \cl equates {\tt char-int} to {\tt char-code} when there is
-no bits or font.  All current \ccl systems use ASCII for the character codes,
-and define {\tt \#\newline} to be a linefeed, but system code should not count on
-this.
-
-\item[{\tt %character-control-byte}]The character bits.  Character bits are used by
-Hemlock to describe modifiers in keyboard events, but there is no assumption of
-any general portable significance of character bits.
-
-{\tt %character-font-byte}\\The character font.  This is not used by \ccl, and is
-not particularly useful.
-\end{description}
-
-Characters should be converted to and from integers by using the \clisp
-{\tt char-int} and {\tt int-char} functions, which the compiler translates into
-these VOPs:
-\begin{example}
-char-int (char) => int
-int-char (int) => char
-\end{example}
-In the common case where Char is known to be a {\tt string-char}, these
-operations are equivalent to {\tt char-code} and {\tt code-char}.  In addition to
-providing a portable interface to character conversion, the VOP representation
-of this type conversion allows the compiler to avoid unnecessary boxing and
-unboxing of character objects.
-
-Existing code explicitly converts fixnums to characters by using the
-Make-Immediate-Type sub-primitive with %Character-Type.  Currently conversion
-of characters to fixnums is rather confused.  Originally, characters were a
-subtype of the Misc type code, and the result of the Make-Fixnum sub-primitive
-had to be masked with {\tt %character-int-mask}; some code still does this, while
-other code may not.
-
-Character comparisons could be implemented by doing numeric comparisons on the
-result of {\tt char-int}, or by using {\tt eq} in the case of {\tt char=}, but this
-can result in unnecessary type conversions.  Instead, the compiler uses these
-conditional VOPs:
-\begin{example}
-if-char= (x y)
-if-char< (x y)
-if-char> (x y)
-\end{example}
-
-
-\chapter{Symbols}
-
-
-Symbols are currently fairly boring in \ccl, containing only the obvious slots:
-\begin{description}
-{\tt %symbol-value-slot}\\The current dynamic value of this symbol.  If the
-symbol is currently unbound, then the value of this slot is the unbound marker.
-
-{\tt %symbol-function-slot}\\The global function function definition of this
-symbol.  If the symbol is not fbound, then this slot holds the unbound marker.
-
-\multiple{
-{\tt %symbol-plist-slot} \*
-{\tt %symbol-name-slot} \*
-{\tt %symbol-package-slot}
-}\\The property list, print name and package for this symbol.
-\end{description}
-
-
-
-\section{Sub-primitives}
-
-The {\tt alloc-symbol} sub-primitive allocates a new symbol object.  {\it name} is
-the simple-string that is to be the name of the symbol.
-\begin{example}
-alloc-symbol (name) => symbol
-\end{example}
-
-The {\tt set-symbol-package} sub-primitive is used by system code that must set
-the symbol package.
-\begin{example}
-set-symbol-package (symbol new-value)
-\end{example}
-
-
-
-\section{Accessor VOPs}
-
-These VOPs read the global symbol value and definition cells.  {\tt constant-ref}
-may only be used on symbols that have been defined to be constants.  Since a
-constant cannot change in value and cannot be dynamically bound, the compiler
-may be able to compile uses of {\tt constant-ref} more efficiently.  Unsafe
-versions of these VOPs may not check for the slot being unbound, which the
-corresponding \clisp functions are required to do.
-\begin{example}
-{small, fast} symbol-value (symbol) => value
-{small, fast} constant-ref (symbol) => value
-{small, fast} symbol-function (symbol) => value
-\end{example}
-
-These VOPs set the global symbol value and definition cells.  {\tt makunbound}
-and {\tt fmakunbound} are implemented by setting the value to the unbound marker.
-\begin{example}
-{small, fast} set-symbol-value (symbol new-value)
-{small, fast} set-symbol-function (symbol new-value)
-\end{example}
-
-The \clisp accessors for other symbol slots are translated into uses of the
-{\tt slot-ref} and {\tt slot-set} VOPs.
-
-
-
-\section{Special Binding}
-
-These VOPs implement dynamic binding of special variables using shallow
-binding.  {\tt bind} binds {\it symbol} to the specified {\it value}, while
-{\tt unbind} undoes the most recent {\it count} special bindings on the binding
-stack.
-\begin{example}
-bind (symbol value)
-unbind (count)
-\end{example}
-
-
-\section{Property Lists}
-
-The {\tt get} VOP implements the corresponding \clisp function, while {\tt put}
-implements its setf-inverse.
-\begin{example}
-get (symbol indicator default) => value
-put (symbol indicator value)
-\end{example}
-
-
-\chapter{Lists}
-
-
-cons
-
-list<n> (elt0 ... elt<n-1>) => list
-list (elt0 ... elt<n-1> more-elts) => list
-    For some small N, we have fixed-arg versions of List.  For larger lists, we
-    pass in additional elements in a stack TN (possibly required to be on stack
-    top).  List* is similar.
-
-
-These VOPs implement the corresponding \clisp functions:
-\begin{example}
-{small, fast} car (list) => value 
-{small, fast} cdr (list) => value 
-\end{example}
-
-These VOPs set the car or cdr of a cons:
-\begin{example}
-{small, fast} set-car (cons new-value)
-{small, fast} set-cdr (cons new-value)
-\end{example}
-
-These VOPs implement the \clisp {\tt assoc} and {\tt member} functions with test
-functions of {\tt eql} and {\tt eq}:
-\begin{example}
-assoc (item alist) => cons-or-nil
-assq (item alist) => cons-or-nil
-member (item list) => cons-or-nil
-memq (item list) => cons-or-nil
-\end{example}
-
-
-{\tt getf} implements the corresponding \clisp function, while {\tt putf} is used
-to implement its setf-inverse.  {\tt putf} returns the new value for the list so
-that it may stored back into the place.
-\begin{example}
-getf (list indicator default) => value
-putf (list indicator new-value) => list
-\end{example}
-
-
-\chapter{Numbers}
-
-\index{Fixnum format}
-Fixnum\\An N-bit two's complement integer.
-
-\index{Short float format}
-Short-Float\\An immediate float format.
-
-\index{Bignum format}
-\label{Bignums}
-Bignum\\Bignums are infinite-precision integers, represented somehow.
-
-\index{Flonum format}
-\index{Floating point formats}
-Floats\\Floats are stored as consecutive words of bits.
-
-\index{Ratio format}
-Ratio\\Ratios are stored as two consecutive words of Lisp objects, which should
-both be integers.
-
-\index{Complex number format}
-Complex\\Complex numbers are stored as two consecutive words of Lisp objects,
-which should both be numbers.
-
-
-
-\section{Number VOPs}
-
-integer-length
-{small, fast} integer-length/fixnum
-
-float=>xxx-float
-
-realpart
-lmagpart
-numerator
-denominator
-decode-float
-{small, fast} decode-float/xxx-float
-scale-float
-{small, fast} scale-float/xxx-float
-
-if-= (x y)
-{small, fast} if-=/fixnum
-{small, fast} if-=/xxx-float
-    Do numeric comparison of X and Y.  The codegen-info contains the
-    continuations to transfer to in the true and false cases.  Same for <, >.
-
-+ (x y) => z
-{small, fast} +/fixnum
-{small, fast} +/fixnum=>integer
-{small, fast} +/xxx-float
-    Same for -, *.   Fixnum multiplication by a constant power of 2 (or near
-    power of 2) can be done by a transform.
-
-/ (x y) => z
-{small, fast} //xxx-float
-
-negate
-{small, fast} negate/fixnum
-{small, fast} negate/fixnum=>integer
-{small, fast} negate/xxx-float
-    Ditto for Abs.
-
-truncate (x y) => q r
-{small, fast} truncate/fixnum
-
-logand (x y) => z
-{small, fast} logand/fixnum
-    Ditto for logior, logxor.
-    
-lognot (n) => z
-{small, fast} lognot/fixnum
-
-ash (n x) => z
-{small, fast} ash/fixnum
-{small, fast} ash-c/fixnum
-
-ldb
-dpb
-mask-field
-deposit-field
-    These will only be used as a last resort.  There should be transforms that
-    turn fixnum operations with constant byte-specifiers into standard logical
-    operations.
-
-
-\section{Number Sub-primitives}
-
-
-alloc-bignum
-make-complex
-make-ratio
-lsh
-logldb
-logdpb
-
-
-
-\chapter{Arrays}
-
-\cl arrays can be represented in a few different ways in \rtccl --
-different representations have different performance advantages.  Simple
-general vectors, simple vectors of integers, and simple strings are basic \rtccl
- data types, and access to these structures is quicker than access to
-non-simple (or ``complex'') arrays.  However, all multi-dimensional arrays in
-\rtccl are complex arrays, so references to these are always through a
-header structure.
-
-
-Once a vector has been allocated, it is possible to reduce its length by using
-the Shrink-Vector sub-primitive, but never to increase its length, even back to
-the original size, since the space freed by the reduction may have been
-reclaimed.
-
-
-
-\subsection{Arrays}
-\label{Arrays}
-\index{Arrays}
-
-An array header is identical in form to a G-Vector.  At present, the following
-subtype codes are defined:
-\begin{itemize, spread 0, spacing 1}
-0 Normal.
-1 Array is displaced to another array (which may be simple).
-\end{itemize}
-The entries in the header-vector are interpreted as follows:
-
-\index{Array header format}
-\begin{description}
-0 Data Vector \\This is a pointer to the I-Vector, G-Vector, or string that
-contains the actual data of the array.	In a multi-dimensional array, the
-supplied indices are converted into a single 1-D index which is used to access
-the data vector in the usual way.  If the array is displaced, then this is
-the array displaced to, which may be an array header.  In general, array
-access must loop until it finds an actual data vector.
-
-1 Number of Elements \\This is a fixnum indicating the number of elements for
-which there is space in the data vector.
-
-2 Fill Pointer \\This is a fixnum indicating how many elements of the data
-vector are actually considered to be in use.  Normally this is initialized to
-the same value as the Number of Elements field, but in some array applications
-it will be given a smaller value.  Any access beyond the fill pointer is
-illegal.
-
-3 Displacement \\This fixnum value is added to the final code-vector index
-after the index arithmetic is done but before the access occurs.  Used for
-mapping a portion of one array into another.  For most arrays, this is 0.
-
-4 Range of First Index \\This is the number of index values along the first
-dimension, or one greater than the largest legal value of this index (since the
-arrays are always zero-based).	A fixnum in the range 0 to 2\+{24}-1.  If any
-of the indices has a range of 0, the array is legal but will contain no data
-and accesses to it will always be out of range.  In a 0-dimension array, this
-entry will not be present.
-
-5 - N  Ranges of Subsequent Dimensions
-\end{description}
-
-The number of dimensions of an array can be determined by looking at the length
-of the array header.  The rank will be this number minus 6.  The maximum array
-rank is 65535 - 6, or 65529.
-
-The ranges of all indices are checked on every access, during the conversion to
-a single data-vector index.  In this conversion, each index is added to the
-accumulating total, then the total is multiplied by the range of the following
-dimension, the next index is added in, and so on.  In other words, if the data
-vector is scanned linearly, the last array index is the one that varies most
-rapidly, then the index before it, and so on.
-
-
-
-\section{Array VOPs}
-
-alloc-bit-vector
-alloc-i-vector
-alloc-string
-alloc-g-vector
-    Initialized and uninitialized versions?
-
-
-length (sequence) => size
-{small, fast} length/vector
-{small, fast} length/simple-vector
-{small, fast} length/simple-string
-{small, fast} length/simple-bit-vector
-
-aref1 (vector index) => value
-{small, fast} aref1/simple-vector
-{small, fast} aref1/simple-string
-{small, fast} aref1/simple-bit-vector
-{small, fast} aref1/simple-array-XXX-float
-
-aset1 (vector index new-value)
-{small, fast} aset1/simple-vector
-{small, fast} aset1/simple-string
-{small, fast} aset1/simple-bit-vector
-{small, fast} aset1/simple-array-XXX-float
-
-{small, fast} aref1/simple-array-unsigned-byte (vector index) => value
-{small, fast} aset1/simple-array-unsigned-byte (vector index new-value)
-    Byte size is codegen info.
-
-aref<N> (array index0 ... index<n-1>) => value
-aset<N> (array index0 ... index<n-1> new-value)
-    For some small value of N.  Of course, higher dimensional arrays can also
-    be specialized in seven different ways....  Multi-dimensional simple array
-    reference with known dimensions can be open-coded using a transform (useful
-    for benchmarks.)
-
-
-
-\section{Array Sub-primitives}
-
-alloc-array
-vector-subtype
-set-vector-subtype
-vector-access-code
-set-vector-access-code
-shrink-vector
-
-typed-vref
-typed-vset
-
-header-length (header) => size
-header-ref (header index) => value
-header-set (header index new-value)
-
-bit-bash
-byte-blt
-{reverse-}find-character
-{reverse-}find-character-with-attribute
-{reverse-}string-compare
-sxhash-simple-string
-sxhash-simple-substring
-
-
-\chapter{Structures}
-
-{small, fast} structure-ref (s) => value
-{small, fast} structure-set (s new-value)
-    Read and write structure slots.  Defstruct slot description is in codegen
-    info.
-
-alloc-structure
-
-
-\chapter{Runtime Environment}
-\index{Runtime Environment}
-\label{Runtime}
-
-
-\section{Register Allocation}
-\index{Register allocation}
-
-The main idea is to globally allocate only those registers with global
-significance.
-
-We permanently dedicate the CONT register to point to the current control stack
-environment.  This is the "frame pointer" in standard terminology.  It isn't
-possible to get pack to allocate this register on an as-needed basis due to the
-classic phase-ordering problem.  We need to know if TNs are allocated on the
-stack before we can determine tell how badly we need a frame pointer register.
-This is of little significance with the control stack environment, since we
-almost always need one, and if there are any stack TNs, we must allocate the
-frame pointer in a register, since there is nowhere else to put it.  The
-problem is more severe with a number stack environment pointer.  We can't
-dedicate a register to it, since we usually don't have any TNs on the number
-stack.  The only easy solution is to always allocate the number stack
-environment pointer on the control stack.  This really isn't too bad, when you
-compare the cost of doing an extra memory reference to get at the number stack
-to the cost of number-consing.
-
-We also dedicate the ENV register to the current constant pool.  It would be
-possible to explicitly allocate the constant pointer as needed if we explicitly
-represented non-immediate constant access by a VOP, but this would be extra
-work, and there are major advantages to representing all constants using TNs.
-Another potential efficiency advantage is since the same constant pool is
-shared by all the code in a component, we need only initialize ENV on entry to
-the component.  When we make local calls, we don't have to do anything to make
-the constants available to the callee.
-
-Since the constant pool will also contain the code vector and the debug info,
-having it in a known place may make life easier for GC and the debugger.  We
-may not be able to count on it too much, though, since ENV holds other things
-will calls are in progress, and might be pretty random if we jumped into
-hyperspace.
-
-
-Runtime environment:
-
-CONT: the current control stack context.
-PC is assumed to be accessible to the debugger when an error happens.
-Current-Catch: pointer to the current catch frame.  Format of frame is assumed.
-Current-Unwind-Protect: current unwind protect frame.  Similar to catch.
-
-If shallow-bind, binding stack and binding stack pointer.
-If deep-bind, current special binding.  Format of binding frame assumed.
-
-Everything depends on the current environment, which is CONT.
-
-
-PC
-OLD-CONT
-ENV
-A<n>
-CONT
-CS
-
-
-\section{Other Dynamic State}
-
-There are some dynamic state variables that are stored in known memory
-locations, rather than having a dedicated register:
-\begin{description}
-binding stack pointer\\The current pointer to the top of the binding stack.
-
-current catch\\The pointer to the current catch block.
-
-current unwind-protect\\The pointer to the current unwind-protect block.
-\end{description}
-
-
-
-
-\section{Control-Stack Format}
-\label{Control-Stack-Format}
-\index{Control-stack format}
-
-
-The control stack contains only Lisp objects.  Every object pointed to by an
-entry on this stack is kept alive.
-
-The \rtccl control stack does not have a rigid frame structure.  The compiler
-is allowed a large amount of freedom in the use of the stack so that it choose
-the best calling sequences.  Mostly the compiler is the only system that cares
-how the stack is laid out, so this isn't a big problem.  See chapter
-\ref{debug-info} for a description of the structures which allow the debugger
-to parse the stack.
-
-
-
-\section{Values Passing Conventions}
-
-
-The first {\it nregs} arguments are passed in registers, where nregs is an
-implementation dependent constant.  Any additional arguments are the block of
-storage between CONT and CS on the control stack.  The first nregs locations in
-this block of storage are unused so that register more-args can be stored on
-the stack without having to BLT the stack values up.
-
-Returning unknown values are passed in a similar way, but the stack values
-block is between OLD-CONT and CS.  There isn't any underneath the values: on
-return OLD-CONT is always what CS was when the function was called.  The
-function returned to must copy the values into the desired location in its
-frame and deallocate excess stuff on the top of the stack.
-
-More args are represented by a pointer to the block of values and a count.  The
-function that originally created the more arg must allocate and deallocate this
-stuff somehow.  In the case of a local call to a more arg entry, we can just
-allocate it as a TN.  The external entry point for a more arg entry is more
-magical.
-
-
-
-The caller allocates the environment for the called function, stores the
-arguments into it, and jumps to the function.  The caller makes the called
-environment current, passing in the return OLD-CONT and PC as explicit arguments.
-
-When returning values, the returner directly stores the return values into the
-frame being returned to.  This works even though the caller doesn't know what
-function it is returning to, since the same return locations are allocated in
-all frames.
-
-In a tail-recursive call, we can destructively modify the current frame and
-jump right to the callee, rather than allocating a new frame.  We can do this
-because TNBind globally allocates frame locations; all frames are the same size
-and have the same TNs in the same place.
-
-
-\section{Binding-Stack Format}
-\index{Binding stack format}
-\comment<In a symbol chapter?>
-
-
-The special binding stack is used to hold previous values of special variables
-that have been bound.  It grows and shrinks with the depth of the binding
-environment, as reflected in the control stack. This stack contains
-symbol-value pairs, with only boxed Lisp objects present.
-
-Each entry of the binding-stack consists of two boxed (32-bit) words.  Pushed
-first is a pointer to the symbol being bound.  Pushed second is the symbol's
-old value (any boxed item) that is to be restored when the binding stack is
-popped.
-
-
-\chapter{Functions}
-
-Function calling is a way of life.  
-
-every function is a closure.  pointer to current closure is passed in ENV
-unless it isn't (in local call may be elsewhere).
-
-The description of the representation of functions and the function calling
-conventions is a large part of the VM description, since:
-    Function calling is one of the most complicated facilities provided by the
-    VM.
-
-    Everything that happens, happens in a function, so all parts of the system
-    tend to get dragged in.
-
-
-Aspects of function call:
-    Control
-    Environment CONT, ENV
-    Argument/value passing
-    Argument/value count dispatching
-
-
-
-
-\section{Function Object Format}
-\label{Fn-Format}
-
-The old notion of a "function object" is now broken down into four different
-parts:
-\begin{description}
-Function entry\\A function entry is a structure that holds the information
-that we need to call a function.  This is the user visible function object.
-
-Environment\\The environment is stuff that a function needs when it runs.
-This includes constants computed at load time and variables closed over at run
-time.  Environment information may be allocated in the function entry structure
-after the required linkage information.
-
-Entry information\\This is information about a specific function entry that is
-occasionally referenced at run time, but need not be immediately accessible.
-Entry information will be either allocated in the function entry
-or in the environment that it points to.
-
-Debug information\\This is information about a function that isn't normally
-needed at run time.  Debug information can be found by poking around in
-environment objects.
-\end{description}
-See chapter \ref{control-conventions} for a description of how function objects
-are used.
-
-
-\section{Environment Object Sub-primitives}
-
-alloc-code ?
-alloc-closure?
-
-
-\subsection{Debug Information Location}
-
-If present, debug information is stored immediately following any fixed
-information in the environment object.  It may be necessary to chain up
-multiple levels of environments to find the debug information.  The debug
-information can be recognized because it is represented by a defstruct
-structure.  See chapter \ref{debug-info} for a description of the debug
-information.
-
-		
-\section{Function Calls}
-\index{function call}
-
-\ccl supports three major calling conventions.  The convention used
-depends on the amount of information available at compile time:
-\begin{description}
-Local\\Local call is used when the call and the called function are
-compiled at the same time.  Using the term "convention" to describe this
-call mechanism is somewhat of a misnomer, since the compiler can do
-whatever it wants.
-
-Named\\Named call is used when the call is to a global function whose name
-is known at compile time.
-
-Anonymous\\Anonymous call is used when the function called is unknown until
-run time.
-\end{description}
-
-\#|
-IR2 function call:
-
-Environment manipulation code is always emitted at the location of the Bind or
-Return node for a Lambda. 
-
-Implicit args to functions in IR2:
-  old-cont: cont to restore on return
-  return-pc: pc to return to
-  env: pointer to current closure (if heap)
-  closure<n>: closed values for current closure (if stack)
-
-Other info needed for IR2 conversion of functions:
-    base pointers for all heap closures consed by this function
-    also have passing locs for each explicit arg
-    return strategy (known or unknown) and return locs
-
-All arguments including implicit ones must have both a passing TN and a
-permanent TN.  Passing locs for let calls can be the actual TN that holds the
-variable in the case of local variables.  Set closure variables must still have
-a separate passing TN.
-
-If we know the values counts for the argument continuations, then we compile
-local mv-calls by moving the TNs for the values continuations into the argument
-passing locations.  Other mv-calls must be compiled using various hairy
-stack-hacking VOPs and unknown argument count call VOPs.
-
-For now, we will create the callee's frame just before the call, instead of
-creating it before the evaluation of the first argument.  If we created the
-environment early, then we would be able to move the argument values directly
-into the frame, instead of having to store them somewhere else for a while.
-The problem with early creation is that lifetime analysis gets confused because
-there is more than one instance of the same TN present simultaneously in the
-case where there are nested calls to the same function.
-
-It turns out that there isn't a problem with a simple self-call, because the TN
-in the called frame is really the "same" TN as the one in the current frame,
-due to the restricted way in which we use the passing TNs.
-
-We emit code for external entry points during IR2 conversion.  The external
-entry point is the place where we start running in a full call from a
-function-entry.  It does arg count checking and dispatching, moves the
-arguments into the passing locations for the for the lambda being called, and
-calls the lambda, moving the results into the standard locations if there
-aren't there already.
-|\#
-
-
-In IR2, the environment manipulation semantics of function call are decoupled
-from the control semantics.  When allocating closure variables for a Let, it is
-possible to do environment manipulation with only the normal sequential control
-flow.  In the case of a Let call with the same environment, we neither
-manipulate the environment nor transfer control; we merely initialize the
-variables with Move VOPs.
-
-If a local function returns a known number of values which is less than the
-number expected by the caller, then additional code must be inserted at the
-return site which sets the unused values to NIL.
-
-The full function call mechanism must effectively be a subset of the local call
-mechanism, since the two mechanisms must mesh at entry points and full function
-calls.  A full call turns into some kind of full call VOP.  There are different
-VOPs for calling named functions and closures.  We also have tail-recursive
-full call VOPs.  Arguments are set up using Move VOPs, just as for local call.
-The only difference is that the passing locations and conventions are
-restricted to the standard ones.
-
-The gory details of arg count checking and dispatching are buried in the
-Function-Entry VOP, which takes a functional and a list of continuations, one
-pointing to each external entry.
-
-
-\subsection{Local Call}
-\index{local call}
-
-Named and anonymous call are called full calls, to distinguish them from
-local call.  When making full calls, the compiler must make many worst-case
-assumptions that aren't necessary in a local call.  The advantage of local
-call is that the compiler can choose to use only those parts of the full
-call sequence that are actually necessary. 
-
-In local call, we always know the function being called, so we never have
-to do argument count checking, and can always use an immediate branch for
-the control transfer.  If the function doesn't return to more than one
-place, then can just use a simple branch, or even drop through.
-
-The argument passing TNs may be allocated anywhere.  The caller allocates the
-stack frame for the called function, moving any non-register arguments into the
-passing locations in the callee's frame.
-
-If we are calling a local function that doesn't always return the same
-number of values, then we must use the same values returning mechanism that
-is used in full call, but we don't have to use the standard registers.
-
-A tail-recursive local call doesn't require any call VOP.  We just use Move
-VOPs to put the arguments into the passing locations and then jump to the the
-start of the code for the function.  We don't have to do any stack hackery
-since we use the same stack frame format for all the functions compiled at the
-same time.  In many cases tail-recursive local calls can be entirely optimized
-away, since they involve only some moves and a branch.  We preference the
-argument values to the passing locations of the called function, making it
-likely that no move will be necessary.  Often the control transfer can be done
-by simply dropping through.
-
-We have to do some funny stuff with local calls in order to get the lifetimes
-for the passing locations right, since lifetime analysis skips directly from
-the return point to the call point, ignoring the uses of the passing locations
-in the called function.  Similarly, we pretend that a block ending in a return
-has no successors.
-
-call-local (arg*) "fun" => value
-multiple-call-local (arg*) "fun" => start end val0 ... val<n>
-    Call-Local is used for calls to local functions that are forced to use the
-    unknown-values passing convention.  Value is the first return value
-    register; we don't really do anything to it, but we specify it as a result
-    to represent the assignment done by the calling function.
-
-    Multiple-Call-Local is similar, but specifies all the values used by the
-    unknown-values convention.  Default-Values may be used to receive a
-    specific number of values.
-
-known-call-local (arg*) "fun" => value*
-    This VOP is used for local calls to functions where we can determine at
-    compile time that the number of values returned is always the same.  In
-    this case, we don't need to indicate the number of values, and can pass
-    them in separate TNs.  The Values are the actual return locations.  We
-    don't really do anything to the return values; we just specify them as
-    results to represent the assignment done by the called function.
-
-known-return (return-pc value*) "fun"
-    This VOP is used for returning from local calls using the known return
-    values convention.  The specified return Values are moved into the passing
-    locations in the caller's frame.
-
-
-If we know that the function we are calling is non-recursive, then we can
-compile it much like a tail-recursive call.  We must have a call VOP to compute
-the return PC, but we don't need to allocate a frame or save registers.  We
-just set up the arguments in the frame and do the call.
-
-We require simple functions to use the known-values convention.  It would be
-possible to support unknown values, but it would potentially require BLT'ing
-return values out of the frame and on to the top of the stack.  Supporting
-unknown values would also require a bunch more VOPs, since we need different
-call and return VOPs for simple call.
-
-Known values return causes no problems, since the callee knows how many values
-are wanted.  We store the values directly into the current frame, since it is
-also the caller's frame.
-
-known-call-simple () "fun" => return-pc
-known-return-simple (return-pc) "fun"
-    Similar to the non-simple VOPs, but don't allocate or deallocate frames,
-    and assume that argument and value passing is done with explicit Move VOPs.
-
-
-\subsection{Full Call}
-\index{full call}
-
-Both named and anonymous call are optimized for calls where the number of
-arguments is known at compile time.  Unknown argument calls are a
-pathological case of anonymous call; this case will be ignored in the main
-discussion.  The difference between named and anonymous calls is in the
-argument count dispatching mechanism.
-
-Named call allows an arbitrary number of entry points, with start PCs at
-arbitrary locations in the code vector.  The link-table mechanism described
-below allows named calls to jump directly to the actual entry point without any
-run-time argument count or type checking checking.
-
-Anonymous call has a fixed number of entry points, with start PCs at fixed
-locations in the code vector.  This allows calls to be made without knowing
-what function is being called, but has more run-time overhead.  The object
-called must be checked to be a valid function-entry object.  The entry PC must
-be computed from the function entry, and argument count checking must be done
-if there are more than three required or optional arguments.
-
-Argument passing in full call is conceptually similar to local call, but the
-caller can't allocate the entire frame for the callee, since it doesn't know
-how much stack is needed.  Instead we allocate the frame in two parts.  The
-caller only allocates the beginning of the frame, which contains the stack
-arguments in fixed locations.  We leave the first <n> locations unused so that
-the called function can move register more args onto the stack without having
-to BLT down any stack arguments.
-
-The place in the code where a full call jumps in is called an external entry
-point.  The external entry point allocates the rest of the stack frame and then
-does a local call to the actual entry-point function, fetching the arguments
-from the standard passing locations.  Usually we can do a tail-recursive local
-call.  
-
-There are two main cases where the call from the external entry point cannot be
-tail-recursive:
- -- It is desirable to use the known-values convention for calling the
-    entry-point function if the entry-point is used in other local calls
-    (perhaps because of recursion).  In this case, the called function stores
-    the return values back into the frame allocated by the external entry point
-    and then returns back to it.  The external entry point must then return
-    these values using the standard unknown-values convention.
- -- In a more-arg entry point we don't know how many stack arguments there are
-    at the beginning of the frame, so we can't really use the frame allocated
-    by the external entry point at all.  Instead we do a local call to the
-    more-arg entry point, passing in a pointer to the first extra value.  When
-    the function returns, we deallocate the crap on the stack and then return
-    the values.  It is still o.k. to use the known-values return convention
-    from the more-arg entry since the extra arg values are no longer needed by
-    the time the returning function stores the return values back into the
-    external entry point frame.
-
-
-In full call we must always use the unknown-values convention for return.  The
-first <n> values are passed in the standard argument registers.  The Old-Cont
-register holds the Start of the values block and SP points to the End.
-
-
-{small, fast} call (function arg0 ... arg<n>) "nargs" => value
-{small, fast} call-named (arg0 ... arg<n>) "nargs" "name" => value
-    Call-Closure calls Function with the specified register arguments,
-    returning the first value as the result.  "nargs" is the total number of
-    arguments passed.  Only the register arguments actually passed should be
-    specified as operands.
-
-    Call-Named is similar, but calls a global function specified at compile
-    time by "name".
-
-{small, fast} tail-call (function pc arg0 ... arg<n>) "nargs"
-{small, fast} tail-call-named (pc arg0 ... arg<n>) "nargs" "name"
-    Similar to the standard call VOPs, but passes PC as the return PC, rather
-    than returning to the call site.  These VOPs have no results since they
-    don't return.
-
-{small, fast} multiple-call (function arg0 ... arg<n>) "nargs"
-                                    => start end val0 ... val<n>
-{small, fast} multiple-call-named (arg0 ... arg<n>) "nargs" "name"
-                                  => start end val0 ... val<n>
-    These VOPs are similar to the standard call VOPs, but allow any number of 
-    values to be received by returning all the value passing registers as
-    results.  A specific number of values may be received by using
-    Default-Values. 
-
-call-unknown (function count arg0 ... arg<n>) => start end val0 ... val<n>
-tail-call-unknown (function pc count arg0 ... arg<n>)
-    Call a function with an unknown number of arguments.  Used for apply and
-    hairy multiple-value-call.
-
-Function-Entry () "function" => env return-pc old-cont arg*
-    This marks the place where we jump into a component for an external
-    entry point.  It represents whatever magic is necessary to do argument
-    count checking and dispatching.  The external entry points for each
-    argument count will be successors of the entry-vector block (might be in
-    the same block if only one?)
-
-    Function-Entry also represents argument passing by specifying the actual
-    external passing locations as results, thus marking the beginning of their
-    lifetimes.  All passing locations actually used by any entry point are
-    specified as Args, including stack arguments.
-   {\#\#\# Do we really need this?  If we do, then we probably also need similar
-    entry markers for local functions.  The lifetimes don't really need to be
-    explicitly bounded, since an entry point is effectively "the end of the
-    world."}
-
-
-\section(Returning from a Function Call)
-\label(Return)
-\index(Return)
-
-
-return (return-pc value)
-multiple-return (return-pc start end val0 ... val<n>)
-    Return Value from the current function, jumping back to the location
-    specified by Return-PC. {Perhaps allow to return any fixed, known number
-    of values.}
-
-    Multiple-Return is similar, but allows an arbitrary number of values to be
-    returned.  End - Start is the total number of values returned.  Start
-    points to the beginning of the block of return values, but the first <n>
-    values val0 ... val<n> are actually returned in registers.
-
-default-values (start end val0 ... val<n>) => val0 ... val<j>
-    This VOP is used when we want to receive exactly J values.  If fewer than J
-    values were supplied, then missing values are defaulted to NIL.  As a
-    side-effect, this VOP pops off any returned stack values.
-
-
-\section{Saving and Restoring Registers}
-
-We use a caller-saves convention.  The caller explicitly emits saving and
-restoring code.  Tail-recursive calls don't need
-any register saving since we never come back.
-
-
-
-\chapter{Non-local exits}
-
-
-\subsection{Unwind Blocks}
-\index{Catch}
-\index{Catch frames}
-
-There is one aspect of the control stack format that is fixed, and which
-concerns us at this level.  This is the format of the "frames" which mark the
-destination of non-local exits, such as for BLOCK and CATCH.  These frames are
-collectively known as unwind blocks.  The basic unwind block is used for
-lexical exists such as BLOCK, and for UNWIND-PROTECT.  Its format is the
-following:
-\begin{verbatim}
-0   Pointer to current unwind-protect.
-1   Control stack context to restore on entry.
-2   PC to enter at.
-\end{verbatim}
-
-The unwind block for CATCH is identical except for additional cells
-containing the catch tag and previous catch.
-\begin{verbatim}
-0   Pointer to current unwind-protect.
-1   Control stack context to restore on entry.
-2   PC to enter at.
-3   Catch tag.
-4   Previous catch.
-\end{verbatim}
-
-The conventions used to manipulate unwind blocks are described in chapter
-\ref{Control-Conventions}.
-
-
-
-\section{Non-Local Exits}
-\label{Catch}
-\index{Catch}
-\index{Throw}
-\index{Unwinding}
-\index{Unwind-Protect}
-\index{Non-Local Exits}
-
-In the normal flow of control, each function that is called executes until it
-reaches a return point; under these conditions no special effort is needed to
-restore the environment as long as each function undoes any change that it
-makes to the dynamic state before it returns.  When we make a non-local
-transfer, we skip a potentially arbitrary collection of these cleanup actions.
-Since we cannot in general know what changes have been made to the dynamic
-environment below us on the stack, we must restore a snapshot of the dynamic
-environment at the re-entry point.
-
-We represent the closed continuation by the pointer to the unwind-block for the
-reentry point.  At the exit point, we just pass this stack pointer to the
-Unwind VOP, which deals with processing any unwind-protects.  When Unwind is
-done, it grabs the re-entry PC out of the location at the stack pointer and
-jumps in.
-
-Catch and Unwind-Protect work in pretty much the same way.  We make a stack TN
-to hold the catch frame or whatever, allocate TNs in them to represent the
-slots, and then initialize them.  The frame can be explicitly linked in by TN
-manipulations, since the active catch and whatnot are represented by TNs.
-Since allocation of the frame is decoupled from linking and unlinking, some of
-this stuff could be moved out of loops.  We will need a VOP for loading the PC
-for an arbitrary continuation so that we can set up the reentry PC.  This can
-be done using the Call VOP.  Using a call instruction is probably a good way to
-get a PC on most architectures anyway.
-
-These TNs are allocated by Pack like any others; we use special alloc and
-dealloc VOPs to delimit the aggregate lifetimes.
-
-In the non-local case, the the Block, Catch and Unwind-Protect special forms
-are implemented using unwind blocks.  The unwind blocks are built by move
-operations emitted inline by the compiler.  The compiler adds and removes
-catches and unwind protects by explicit moves to the locations that hold the
-current catch and unwind protect blocks.  The entry PC is loaded using the Call
-VOP.
-
-The Unwind miscop is the basis non-local exits.  It takes the address of an
-unwind block and processes unwind-protects until the current unwind-protect is
-the one recorded in the unwind block, then jumps in at the entry in the unwind
-block.  The entry for the unwind block is responsible for restoring any state
-other than the current unwind-protect.  
-
-Unwind is used directly to implement non-local Return-From.  The address of the
-unwind block is stored in a closure variable.
-
-Catch just does a scan up the chain of Catch blocks, starting at the current
-catch.  When it finds the right one, it calls unwind on it.
-
-Unwind-protects are represented by unwind blocks linked into the current
-unwind-protect chain.  The cleanup code is entered just like any other any
-other unwind entry.  As before, the entry is responsible for establishing the
-correct dynamic environment for the cleanup code.  The target unwind block is
-passed in some non-argument register.  When the cleanup code is done, it
-just calls Unwind with the block passed in.  The cleanup code must be careful
-not to trash the argument registers or CS, since there may be multiple values
-lurking out there.
-
-With Catch/Throw, we always use the variable values return value passing convention,
-since we don't know how many values the catch wants.  With Block/Return-From,
-we can do whatever we want, since the returner and receiver know each other.
-
-If a Block or Catch receives stack values, it must call a VOP that BLT's the
-values down the stack, squeezing out any intermediate crud.
-
-
-unwind (context)
-throw (tag)
-    Unwind does a non-local exit, unwinding to the place indicated by Context.
-    Context is a pointer to a block of storage allocated on the control stack,
-    containing the entry PC, current environment and current unwind-protect.
-    We scan up the stack, processing unwind-protects until we reach the entry
-    point.  The values being returned are passed in the standard locations.
-    Throw is similar, but does a dynamic lookup for the Tag to determine what
-    context to unwind to.
-
diff --git a/docs/rtguts.mss b/docs/rtguts.mss
deleted file mode 100644
index 38f08e396776e027dbba559dcaa59d9555ff95ad..0000000000000000000000000000000000000000
--- a/docs/rtguts.mss
+++ /dev/null
@@ -1,4150 +0,0 @@
-@make [Manual]
-@device [PostScript]
-@use (database "/usr/lisp/scribe/database/")
-@libraryfile [Mathematics10]
-@libraryfile [ArpaCredit]
-@libraryfile [table]
-@libraryfile [spice] 
-@style(FontFamily=TimesRoman)
-@style(Date="March 1952")
-
-@commandstring(pusharrow = "@jsym<L>")
-@define(f, facecode f)
-
-@commandstring(InstrSection = "@tabclear@tabset[.5 in, 3.0 in]")
-@form(Instr = "@*@\@Parm[name]@\")
-@form(BInstr ="@*@\@Parm[name]@+[*]@\")
-@string(DinkyMachine = "IBM RT PC")
-@begin[TitlePage]
-@begin[TitleBox]
-@blankspace(0.25in)
-@heading[Internal Design of CMU Common Lisp 
-on the IBM RT PC]
-@begin[Center]
-@b{David B. McDonald
-Scott E. Fahlman
-Skef Wholey
-
-@value[Date]
-
-CMU-CS-87-157
-}
-@end[Center]
-@end[TitleBox]
-@center[@b<Abstract>]
-@begin[Text]
-CMU Common Lisp is an implementation of Common Lisp that currently runs on
-the IBM RT PC under Mach, a Berkeley Unix 4.3 binary compatible operating
-system.  This document describes low level
-details of the implementation.  In particular, it describes the data
-formats used for all Lisp objects, the assembler language routines
-(miscops) used to support compiled code, the function call and return
-mechanism, and other design information necessary to understand the
-underlying structure of the CMU Common Lisp implementation on the IBM RT PC
-under the Mach operating system.
-@end[Text]
-
-@begin[ResearchCredit]
-@ArpaCredit[Contract=Strategic87-90]
-@end[ResearchCredit]
-@end[TitlePage]
-
-@heading [Acknowledgments]
-
-This document is based heavily on the document @i[Revised Internal Design
-of Spice Lisp] by Skef Wholey, Scott Fahlman, and Joseph Ginder.
-
-The FASL file format was designed by Guy L. Steele Jr. and Walter van
-Roggen, and the appendix on this subject is their document with very few
-modifications.
-
-@chapter [Introduction]
-
-@section [Scope and Purpose]
-
-This document describes a new implementation of CMU Common Lisp (nee Spice
-Lisp) as it is implemented on the @value(DinkyMachine) running Mach, a
-Berkeley Unix 4.3 binary compatible operating system.  This design is
-undergoing rapid change, and for the present is not guaranteed to
-accurately describe any past, present, or future implementation of CMU
-Common Lisp.  All questions and comments on this material should be
-directed to David B. McDonald (David.McDonald@@CS.CMU.EDU).
-
-This document specifies the hand-coded assembler routines (miscops) and
-virtual memory architecture of the @value(DinkyMachine) CMU Common Lisp system.
-This is a working document, and it will change frequently as the system is
-developed and maintained.  If some detail of the system does not agree with
-what is specified here, it is to be considered a bug.
-
-@section [Notational Conventions]
-@index [Bit numbering]
-@index [Byte numbering]
-CMU Common Lisp objects are 32 bits long.  The high-order bit of each word is
-numbered 0; the low-order bit is numbered 31.  If a word is broken into smaller
-units, these are packed into the word from left to right.  For example, if we
-break a word into bytes, byte 0 would occupy bits 0-7, byte 1 would occupy
-8-15, byte 2 would occupy 16-23, and byte 3 would occupy 24-31.
-
-All CMU Common Lisp documentation uses decimal as the default radix; other
-radices will be indicated by a subscript (as in 77@-[8]) or by a clear
-statement of what radix is in use.
-
-@chapter [Data Types and Object Formats]
-
-@section [Lisp Objects]
-@index [Lisp objects]
-
-Lisp objects are 32 bits long.	They come in 32 basic types, divided into three
-classes: immediate data types, pointer types, and forwarding pointer types.
-The storage formats are as follows:
-
-@index [Immediate object format]
-@index [Pointer object format]
-@begin [verbatim, group]
-
-@b[Immediate Data Types:]
- 0	       4 5						     31
-------------------------------------------------------------------------
-| Type Code (5) |	       Immediate Data (27)		       |
-------------------------------------------------------------------------
-
-@b[Pointer and Forwarding Types:]
- 0	       4 5	        6 7			29	     31
-------------------------------------------------------------------------
-| Type Code (5) | Space Code (2) |    Pointer (23)	  | Unused (2) |
-------------------------------------------------------------------------
-@end [verbatim]
-
-@section [Table of Type Codes]
-@index [Type codes]
-
-@begin [verbatim, group]
-
-Code	Type		Class		Explanation
-----	----		-----		-----------
-0	+ Fixnum	Immediate	Positive fixnum, miscop code, etc.
-1	GC-Forward	Pointer 	GC forward pointer, used during GC.
-4	Bignum		Pointer 	Bignum.
-5	Ratio		Pointer 	Two words: numerator, denominator.
-6	+ Short Float	Immediate	Positive short flonum.
-7	- Short Float	Immediate	Negative short flonum.
-8	Single Float	Pointer 	Single precision float.
-9	Double Float	Pointer 	Double precision float (?).
-9	Long Float	Pointer 	Long float.
-10	Complex 	Pointer 	Two words: real, imaginary parts.
-11	String		Pointer 	Character string.
-12	Bit-Vector	Pointer 	Vector of bits
-13	Integer-Vector	Pointer 	Vector of integers
-14	General-Vector	Pointer 	Vector of Lisp objects.
-15	Array		Pointer 	Array header.
-16	Function	Pointer 	Compiled function header.
-17	Symbol		Pointer 	Symbol.
-18	List		Pointer 	Cons cell.
-20	C. S. Pointer	Pointer 	Pointer into control stack.
-21	B. S. Pointer	Pointer 	Pointer into binding stack.
-26	Interruptible	Immediate	Marks a miscop as interruptible.
-27	Character	Immediate	Character object.
-28	Values-Marker	Immediate	Multiple values marker.
-29	Catch-All	Immediate	Catch-All object.
-30	Trap		Immediate	Illegal object trap.
-31	- Fixnum	Immediate	Negative fixnum.
-@end [verbatim]
-
-@section [Table of Space Codes]
-@index [Space codes]
-
-@begin [verbatim, group]
-
-Code	Space		Explanation
-----	-----		-----------
-0	Dynamic-0	Storage normally garbage collected, space 0.
-1	Dynamic-1	Storage normally garbage collected, space 1.
-2	Static		Permanent objects, never moved or reclaimed.
-3	Read-Only	Objects never moved, reclaimed, or altered.
-@end [verbatim]
-
-@section [Immediate Data Type Descriptions]
-
-@begin [description]
-
-@index [Fixnum format]
-Fixnum@\A 28-bit two's complement integer.  The sign bit is stored redundantly
-in the top 5 bits of the word.
-
-@index [Short float format]
-Short-Float@\The sign bit is stored as part of the type code,
-allowing a 28 bit signed short float format.  The format of short floating
-point numbers is:
-@begin [verbatim]
- 0	       3     4	    5           12 13		    31
----------------------------------------------------------------
-| Type code (4) | Sign (1) | Exponent (8) |   Mantissa (19)   |
----------------------------------------------------------------
-@end [verbatim]
-The floating point number is the same format as the @value(DinkyMachine)
-supports for single precision numbers, except it has been shifted right
-by four bits for the type code.  The result of any operation is therefore
-truncated.  Long floating point numbers are also available if you need
-more accuracy and better error propagation properties.
-
-@index [Character object]
-Character@\A character object holding a character code, control bits, and font
-in the following format:
-@begin [verbatim, group]
- 0	       4 6	   7  8       15 16	 23 24	    31
----------------------------------------------------------------
-| Type code (5) | Unused (3) | Font (8) | Bits (8) | Code (8) |
----------------------------------------------------------------
-@end [verbatim]
-
-@index [Values-Marker]
-Values-Marker@\Used to mark the presence of multiple values on the stack.  The
-low 16 bits indicate how many values are being returned.  Note that only 65535
-values can be returned from a multiple-values producing form.  These are pushed
-onto the stack in order, and the Values-Marker is returned in register A0.
-
-@index [Catch-All object]
-Catch-All@\Object used as the catch tag for unwind-protects.  Special things
-happen when a catch frame with this as its tag is encountered during a throw.
-See section @ref[Catch] for details.
-
-@index[Trap]
-@index[Illegal object trap]
-Trap@\Illegal object trap.  This value is used in symbols to signify an
-undefined value or definition.
-
-@index[Interruptible Marker]
-Interruptible-Marker@\Object used to mark a miscop as interruptible.  This
-object is put in one of the registers and signals to the interrupt handler
-that the miscop can be interrupted safely.  Only miscops that can take a long
-time (e.g., length when passed a circular list, system call miscops that
-may wait indefinitely) are marked this way.
-@end [description]
-
-@section [Pointer-Type Objects and Spaces]
-@index [Pointer object format]
-@index [Virtual memory]
-
-Each of the pointer-type lisp objects points into a different space in virtual
-memory.  There are separate spaces for Bit-Vectors, Symbols, Lists, and so on.
-The 5-bit type-code provides the high-order virtual address bits for the
-object, followed by the 2-bit space code, followed by the 25-bit pointer
-address.  This gives a 30-bit virtual address to a 32-bit word; since the
-@value(DinkyMachine) is a byte-addressed machine, the two low-order
-bits are 0.  In effect we have carved a 30-bit space into a fixed set
-of 23-bit subspaces, not all of which are used.
-
-@index [Space codes]
-The space code divides each of the type spaces into four sub-spaces,
-as shown in the table above.  At any given time, one of the dynamic
-spaces is considered newspace, while the other is oldspace.
-During a stop and copy garbage collection, a ``flip'' can be done, turning the
-old newspace into the new oldspace.  All type-spaces are flipped at once.
-Allocation of new dynamic objects always occurs in newspace.
-
-@index [Static space]
-@index [Read-only space]
-Optionally, the user (or system functions) may allocate objects in
-static or read-only space.  Such objects are never reclaimed once they
-are allocated -- they occupy the space in which they were initially
-allocated for the lifetime of the Lisp process.  The advantage of
-static allocation is that the GC never has to move these objects,
-thereby saving a significant amount of work, especially if the objects
-are large.  Objects in read-only space are static, in that they are
-never moved or reclaimed; in addition, they cannot be altered once
-they are set up.  Pointers in read-only space may only point to
-read-only or static space, never to dynamic space.  This saves even
-more work, since read-only space does not need to be scavenged, and
-pages of read-only material do not need to be written back onto the
-disk during paging.
-
-Objects in a particular type-space will contain either pointers to
-garbage-collectible objects or words of raw non-garbage-collectible bits, but
-not both.  Similarly, a space will contain either fixed-length objects or
-variable-length objects, but not both.	A variable-length object always
-contains a 24-bit length field right-justified in the first word, with
-the positive fixnum type-code in the high-order five bits.  The remaining three
-bits can be used for sub-type information.  The length field gives the
-size of the object in 32-bit words, including the header word.	The
-garbage collector needs this information when the object is moved, and
-it is also useful for bounds checking.
-
-The format of objects in each space are as follows:
-
-@begin [description]
-@index [Symbol]
-@index [Value cell]
-@index [Definition cell]
-@index [Property list cell]
-@index [Plist cell]
-@index [Print name cell]
-@index [Pname cell]
-@index [Package cell]
-Symbol@\Each symbol is represented as a
-fixed-length block of boxed Lisp cells.  The number of cells
-per symbol is 5, in the following order:
-@begin [verbatim, group]
-0  Value cell for shallow binding.
-1  Definition cell: a function or list.
-2  Property list: a list of attribute-value pairs.
-3  Print name: a string.
-4  Package: the obarray holding this symbol.
-@end [verbatim]
-
-@index [List cell]
-List@\A fixed-length block of two boxed Lisp cells, the CAR and the CDR.
-
-@index [General-Vector format]
-@index [G-Vector format]
-@index [Vector format]
-General-Vector@\Vector of lisp objects, any length.  The first word is a fixnum
-giving the number of words allocated for the vector (up to 24 bits).  The
-highest legal index is this number minus 2.  The second word is vector entry 0,
-and additional entries are allocated contiguously in virtual memory.  General
-vectors are sometimes called G-Vectors.  (See section @ref[Vectors] for further
-details.)
-
-@index [Integer-Vector format]
-@index [I-Vector format]
-@index [Vector format]
-Integer-Vector@\Vector of integers, any length.  The 24 low bits of the first
-word give the allocated length in 32-bit words.  The low-order 28 bits of the
-second word gives the length of the vector in entries, whatever the length of
-the individual entries may be.	The high-order 4 bits of the second word
-contain access-type information that yields, among other things, the number of
-bits per entry.  Entry 0 is left-justified in the third word of the vector.
-Bits per entry will normally be powers of 2, so they will fit neatly into
-32-bit words, but if necessary some empty space may be left at the low-order
-end of each word.  Integer vectors are sometimes called I-Vectors.  (See
-section @ref[Vectors] for details.)
-
-@index [Bit-Vector format]
-@index [Vector format]
-Bit-Vector@\Vector of bits, any length.  Bit-Vectors are represented in a form
-identical to I-Vectors, but live in a different space for efficiency reasons.
-
-@index [Bignum format]
-@label [Bignums]
-Bignum@\Bignums are infinite-precision integers, represented in a format
-identical to G-Vectors.  Each bignum is stored as a series of 32-bit words,
-with the low-order word stored first.  The representation is two's complement,
-but the sign of the number is redundantly encoded in the type field of the
-fixnum in the header word.  If this fixnum is non-negative, then so is the
-bignum, if it is negative, so is the bignum.
-
-@index [Flonum format]
-@index [Flonum formats]
-@index [Floating point formats]
-Floats@\Floats are stored as two or more consecutive words of bits, in the
-following format:
-@begin [verbatim, group]
----------------------------------------------------------------
-|  Header word, used only for GC forward pointers.	      |
----------------------------------------------------------------
-|  Appropriate number of 32-bit words in machine format	      |
----------------------------------------------------------------
-@end [verbatim]
-The number of words used to represent a floating point number is one plus the
-size of the floating point number being stored.  The floating point numbers
-will be represented in whatever format the @value(DinkyMachine) expects.  The
-extra header word is needed so that a valid floating point number is not
-mistaken for a gc-forward pointer during a garbage collection.
-
-@index [Ratio format]
-Ratio@\Ratios are stored as two consecutive words of Lisp objects, which should
-both be integers.
-
-@index [Complex number format]
-Complex@\Complex numbers are stored as two consecutive words of Lisp objects,
-which should both be numbers.
-
-@index [Array format]
-Array@\This is actually a header which holds the accessing and
-other information about the array.  The actual array contents are held in a
-vector (either an I-Vector or G-Vector) pointed to by an entry in
-the header.  The header is identical in format to a G-Vector.  For
-details on what the array header contains, see section @ref[Arrays].
-
-@index [String format]
-String@\A vector of bytes.  Identical in form to I-Vectors with the access type
-always 8-Bit.  However, instead of accepting and returning fixnums, string
-accesses accept and return character objects.  Only the 8-bit code field is
-actually stored, and the returned character object always has bit and font
-values of 0.
-
-@index [Function object format]
-Function @\A compiled CMU Common Lisp function consists of both lisp
-objects and raw bits for the code.  The Lisp objects are stored in
-the Function space in a format identical to that used for general
-vectors, with a 24-bit length field in the first word.  This object
-contains assorted parameters needed by the calling machinery, a
-pointer to an 8-bit I-Vector containing the compiled code, a number
-of pointers to symbols used as special variables within the function,
-and a number of lisp objects used as constants by the function.
-@end [description]
-
-@section [Forwarding Pointers]
-@index [Forwarding pointers]
-
-@begin [description]
-@index [GC-Forward pointer]
-GC-Forward@\When a data structure is transported into newspace, a GC-Forward
-pointer is left behind in the first word of the oldspace object.  This points
-to the same type-space in which it is found.  For example, a GC-Forward in
-G-Vector space points to a structure in the G-Vector newspace.	GC-Forward
-pointers are only found in oldspace.
-@end [description]
-
-@section [System and Stack Spaces]
-@index [System table space]
-@index [Stack spaces]
-@index [Control stack space]
-@index [Binding stack space]
-@index [Special binding stack space]
-
-The virtual addresses below 08000000@-[16] are not occupied by Lisp objects,
-since Lisp objects with type code 0 are positive fixnums.  Some of this space
-is used for other purposes by Lisp.  A couple of pages (4096 byte pages)
-at address 00100000@-[16] contain tables that Lisp needs to access
-frequently.  These include the allocation table, the active-catch-frame,
-information to link to C routines, etc.  Memory at location 00200000@-[16]
-contains code for various miscops.  Also, any C code loaded into a running
-Lisp process is loaded after the miscops.  The format of the allocation
-table is described in chapter @ref[Alloc-Chapter].
-
-The control stack grows upward (toward higher addresses) in memory,
-and is a framed stack.  It contains only general Lisp objects (with
-some random things encoded as fixnums).  Every object
-pointed to by an entry on this stack is kept alive.  The frame for a
-function call contains an area for the function's arguments, an area
-for local variables, a pointer to the caller's frame, and a pointer
-into the binding stack.  The frame for a Catch form contains similar
-information.  The precise stack format can be found in chapter
-@ref[Runtime].
-
-The special binding stack grows downward.  This stack is used to hold
-previous values of special variables that have been bound.  It grows and
-shrinks with the depth of the binding environment, as reflected in the
-control stack.	This stack contains symbol-value pairs, with only boxed
-Lisp objects present.
-
-All Lisp objects are allocated on word boundaries, since the
-@value(DinkyMachine) can only access words on word boundaries.
-
-@section [Vectors and Arrays]
-@label [Vectors]
-@index [Vectors]
-
-Common Lisp arrays can be represented in a few different ways in CMU Common
-Lisp -- different representations have different performance advantages.
-Simple general vectors, simple vectors of integers, and simple strings are
-basic CMU Common Lisp data types, and access to these structures is quicker
-than access to non-simple (or ``complex'') arrays.  However, all
-multi-dimensional arrays in CMU Common Lisp are complex arrays, so
-references to these are always through a header structure.
-
-@subsection [General Vectors]
-@index [General-Vector format]
-
-G-Vectors contain Lisp objects.  The format is as follows:
-
-@begin [verbatim, group]
-------------------------------------------------------------------
-|  Fixnum code (5) | Subtype (3) |   Allocated length (24)	 |
-------------------------------------------------------------------
-|  Vector entry 0   (Additional entries in subsequent words)	 |
-------------------------------------------------------------------
-@end [verbatim]
-
-The first word of the vector is
-a header indicating its length; the remaining words hold the boxed entries of
-the vector, one entry per 32-bit word.	The header word is of type fixnum.  It
-contains a 3-bit subtype field, which is used to indicate several special types
-of general vectors.  At present, the following subtype codes are defined:
-
-@index [DEFSTRUCT]
-@index [Hash tables]
-@begin [itemize, spread 0, spacing 1]
-0 Normal.  Used for assorted things.
-
-1 Named structure created by DEFSTRUCT, with type name in entry 0.
-
-2 EQ Hash Table, last rehashed in dynamic-0 space.
-
-3 EQ Hash Table, last rehashed in dynamic-1 space.
-
-4 EQ Hash Table, must be rehashed.
-@end [itemize]
-
-Following the subtype is a 24-bit field indicating how many 32-bit words are
-allocated for this vector, including the header word.  Legal indices into the
-vector range from zero to the number in the allocated length field minus 2,
-inclusive.  Normally, the index is checked on every access to the vector.
-Entry 0 is stored in the second word of the vector, and subsequent entries
-follow contiguously in virtual memory.
-
-Once a vector has been allocated, it is possible to reduce its length by using
-the Shrink-Vector miscop, but never to increase its length, even back to
-the original size, since the space freed by the reduction may have been
-reclaimed.  This reduction simply stores a new smaller value in the length
-field of the header word.
-
-It is not an error to create a vector of length 0, though it will always be an
-out-of-bounds error to access such an object.  The maximum possible length for
-a general vector is 2@+[24]-2 entries, and that can't fit in the available
-space.	The maximum length is 2@+[23]-2 entries, and that is only possible if
-no other general vectors are present in the space.
-
-@index [Bignum Format]
-Bignums are identical in format to G-Vectors although each entry is a 32-bit
-integer, and thus only assembler routines should ever access an entry.
-
-@index [Function object format]
-@index [Array format]
-Objects of type Function and Array are identical in format to
-general vectors, though they have their own spaces.
-
-@subsection [Integer Vectors]
-@index [Integer-Vector format]
-
-I-Vectors contain unboxed items of data, and their format is more complex.  The
-data items come in a variety of lengths, but are of constant length within a
-given vector.  Data going to and from an I-Vector are passed as Fixnums, right
-justified.  Internally these integers are stored in packed form, filling 32-bit
-words without any type-codes or other overhead.  The format is as follows:
-
-@begin [verbatim, group]
-----------------------------------------------------------------
-| Fixnum code (5) | Subtype (3) |  Allocated length (24)       |
-----------------------------------------------------------------
-| Access type (4) | Number of entries (28)		       |
-----------------------------------------------------------------
-| Entry 0 left justified				       |
-----------------------------------------------------------------
-@end [verbatim]
-
-The first word of an I-Vector
-contains the Fixnum type-code in the top 5 bits, a 3-bit subtype code in the
-next three bits, and the total allocated length of the vector (in 32-bit words)
-in the low-order 24 bits.  At present, the following subtype codes are defined:
-@begin [itemize, spread 0, spacing 1]
-0 Normal.  Used for assorted things.
-
-1 Code.  This is the code-vector for a function object.
-@end [itemize]
-
-The second word of the vector is the one that is looked at every
-time the vector is accessed.  The low-order 28 bits of this word
-contain the number of valid entries in the vector, regardless of how
-long each entry is.  The lowest legal index into the vector is always
-0; the highest legal index is one less than this number-of-entries
-field from the second word.  These bounds are checked on every access.
-Once a vector is allocated, it can be reduced in size but not increased.
-The Shrink-Vector miscop changes both the allocated length field
-and the number-of-entries field of an integer vector.
-
-@index [Access-type codes]
-The high-order 4 bits of the second word contain an access-type code
-which indicates how many bits are occupied by each item (and therefore
-how many items are packed into a 32-bit word).	The encoding is as follows:
-@begin [verbatim, group]
-0   1-Bit			8   Unused
-1   2-Bit			9   Unused
-2   4-Bit			10  Unused
-3   8-Bit			11  Unused
-4   16-Bit			12  Unused
-5   32-Bit			13  Unused
-6   Unused			14  Unused
-7   Unused			15  Unused
-@end [verbatim]
-
-In I-Vectors, the data items are packed into the third and subsequent
-words of the vector.  Item 0 is left justified in the third word,
-item 1 is to its right, and so on until the allocated number of items
-has been accommodated.  All of the currently-defined access types
-happen to pack neatly into 32-bit words, but if this should not be
-the case, some unused bits would remain at the right side of each
-word.  No attempt will be made to split items between words to use up
-these odd bits.  When allocated, an I-Vector is initialized to all
-0's.
-
-As with G-Vectors, it is not an error to create an I-Vector of length
-0, but it will always be an error to access such a vector.  The
-maximum possible length of an I-Vector is 2@+[28]-1 entries or
-2@+[23]-3 words, whichever is smaller.
-
-@index [String format]
-Objects of type String are identical in format to I-Vectors, though they have
-their own space.  Strings always have subtype 0 and access-type 3 (8-Bit).
-Strings differ from normal I-Vectors in that the accessing miscops accept
-and return objects of type Character rather than Fixnum.
-
-@subsection [Arrays]
-@label [Arrays]
-@index [Arrays]
-
-An array header is identical in form to a G-Vector.  Like any G-Vector, its
-first word contains a fixnum type-code, a 3-bit subtype code, and a 24-bit
-total length field (this is the length of the array header, not of the vector
-that holds the data).  At present, the subtype code is always 0.  The entries
-in the header-vector are interpreted as follows:
-
-@index [Array header format]
-@begin [description]
-0 Data Vector @\This is a pointer to the I-Vector, G-Vector, or string that
-contains the actual data of the array.	In a multi-dimensional array, the
-supplied indices are converted into a single 1-D index which is used to access
-the data vector in the usual way.
-
-1 Number of Elements @\This is a fixnum indicating the number of elements for
-which there is space in the data vector.
-
-2 Fill Pointer @\This is a fixnum indicating how many elements of the data
-vector are actually considered to be in use.  Normally this is initialized to
-the same value as the Number of Elements field, but in some array applications
-it will be given a smaller value.  Any access beyond the fill pointer is
-illegal.
-
-3 Displacement @\This fixnum value is added to the final code-vector index
-after the index arithmetic is done but before the access occurs.  Used for
-mapping a portion of one array into another.  For most arrays, this is 0.
-
-4 Range of First Index @\This is the number of index values along the first
-dimension, or one greater than the largest legal value of this index (since the
-arrays are always zero-based).	A fixnum in the range 0 to 2@+[24]-1.  If any
-of the indices has a range of 0, the array is legal but will contain no data
-and accesses to it will always be out of range.  In a 0-dimension array, this
-entry will not be present.
-
-5 - N  Ranges of Subsequent Dimensions
-@end [description]
-
-The number of dimensions of an array can be determined by looking at the length
-of the array header.  The rank will be this number minus 6.  The maximum array
-rank is 65535 - 6, or 65529.
-
-The ranges of all indices are checked on every access, during the conversion to
-a single data-vector index.  In this conversion, each index is added to the
-accumulating total, then the total is multiplied by the range of the following
-dimension, the next index is added in, and so on.  In other words, if the data
-vector is scanned linearly, the last array index is the one that varies most
-rapidly, then the index before it, and so on.
-
-@section [Symbols Known to the Assembler Routines]
-@label [Known-Objects]
-
-A large number of symbols will be pre-defined when a CMU Common Lisp system
-is fired up.  A few of these are so fundamental to the operation of the
-system that their addresses have to be known to the assembler routines.
-These symbols are listed here.  All of these symbols are in static space,
-so they will not move around.
-
-@begin [description]
-@index [NIL]
-NIL @\94000000@-[16] The value of NIL is always NIL; it is an error
-to alter it.  The plist of NIL is always NIL; it is an error to alter
-it.  NIL is unique among symbols in that it is stored in Cons cell
-space and thus you can take its CAR and CDR, yielding NIL in either
-case.  NIL has been placed in Cons cell space so that the more common
-operations on lists will yield the desired results.  This slows down
-some symbol operations but this should be insignificant compared to
-the savings in list operations.  A test for NIL for the
-@value(DinkyMachine) is:
-@begin(Example)
-	xiu	R0,P,X'9400'
-	bz	IsNIL	or bnz	IsNotNIL
-@end(Example)
-
-@index [T]
-T @\8C000000@-[16]  The value of T is always T; it is an error
-to alter it.  A similar sequence of code as for NIL above can test for T,
-if necessary.
-
-@index [%SP-Internal-Apply]
-%SP-Internal-Apply @\8C000014@-[16] The function stored in the definition cell
-of this symbol is called by an assembler routine whenever compiled code calls
-an interpreted function.
-
-@index [%SP-Internal-Error]
-%SP-Internal-Error @\8C000028@-[16] The function stored in the definition cell
-of this symbol is called whenever an error is detected during the execution of
-an assembler routine.  See section @ref[Errors] for details.
-
-@index [%SP-Software-Interrupt-Handler]
-%SP-Software-Interrupt-Handler @\8C00003C@-[16] The function stored in the
-definition cell of this symbol is called whenever a software interrupt occurs.
-See section @ref[Interrupts] for details.
-
-@index [%SP-Internal-Throw-Tag]
-%SP-Internal-Throw-Tag @\8C000050@-[16] This symbol is bound to the tag being
-thrown when a Catch-All frame is encountered on the stack.  See section
-@ref[Catch] for details.
-
-@index [%Initial-function]
-%Initial-function@\8c000064@-[16] This symbol's function cell should contain
-a function that is called when the initial core image is started.  This
-function should initialize all the data structures that Lisp needs to run.
-
-@index [%Link-table-header]
-%Link-table-header@\8c000078@-[16] This symbol's value cell contains a pointer
-to the link table information.
-
-@index [Current-allocation-space]
-Current-allocation-space@\8c00008c@-[16] This symbol's value cell contains
-an encoded form of the current space that new lisp objects are to be allocated
-in.
-
-@index [%SP-bignum/fixnum]
-%SP-bignum/fixnum@\8c0000a0@-[16] This function is invoked by the miscops
-when a division of a bignum by a fixnum results in a ratio.
-
-@index [%SP-fixnum/bignum]
-%SP-bignum/bignum@\8c0000b4@-[16] This
-function is invoked by the miscops when a division of a fixnum by a
-bignum results in a ratio.
-
-@index [%SP-bignum/bignum]
-%SP-bignum/bignum@\8c0000c8@-[16] This function is invoked by the miscops
-when a division of a bignum by a bignum results in a ratio.
-
-@index [%SP-abs-ratio]
-%SP-abs-ratio@\8c0000dc@-[16] This function is invoked by the miscops
-when the absolute value of a ratio is taken.
-
-@index [%SP-abs-complex]
-%SP-abs-complex@\8c0000f0@-[16] This function is invoked by the miscops
-when the absolute value of a complex is taken.
-
-@index [%SP-negate-ratio]
-%SP-negate-ratio@\8c000104@-[16] This function is invoked by the miscops
-when a ratio is to be negated.
-
-@index [%SP-negate-complex]
-%SP-negate-ratio@\8c000118@-[16] This function is invoked by the miscops
-when a complex is to be negated.
-
-@index[%SP-integer+ratio]
-%SP-integer+ratio@\8c00012c@-[16] This function is invoked by the miscops
-when a fixnum or bignum is added to a ratio.
-
-@index[%SP-ratio+ratio]
-%SP-ratio+ratio@\8c000140@-[16] This function is invoked by the miscops
-when a ratio is added to a ratio.
-
-@index[%SP-complex+number]
-%SP-complex+number@\8c000154@-[16] This function is invoked by the miscops
-when a complex is added to a number.
-
-@index[%SP-number+complex]
-%SP-number+complex@\8c000168@-[16] This function is invoked by the miscops
-when a number is added to a complex.
-
-@index[%SP-complex+complex]
-%SP-complex+complex@\8c00017c@-[16] This function is invoked by the miscops
-when a number is added to a complex.
-
-@index[%SP-1+ratio]
-%SP-1+ratio@\8c000190@-[16] This function is invoked by the miscops when
-1 is added to a ratio.
-
-@index[%SP-1+complex]
-%SP-1+complex@\8c000190@-[16] This function is invoked by the miscops when
-1 is added to a complex.
-
-@index[%SP-ratio-integer]
-%SP-ratio-integer@\8c0001b8@-[16] This function is invoked by the miscops
-when an integer is subtracted from a ratio.
-
-@index[%SP-ratio-ratio]
-%SP-ratio-ratio@\8c0001cc@-[16] This function is invoked by the miscops
-when an ratio is subtracted from a ratio.
-
-@index[%SP-complex-number]
-%SP-complex-number@\8c0001e0@-[16] This function is invoked by the miscops
-when a complex is subtracted from a number.
-
-@index[%SP-number-complex]
-%SP-number-complex@\8c0001f4@-[16] This function is invoked by the miscops
-when a number is subtracted from a complex.
-
-@index[%SP-complex-complex]
-%SP-complex-complex@\8c000208@-[16] This function is invoked by the miscops
-when a complex is subtracted from a complex.
-
-@index[%SP-1-complex]
-%SP-1-complex@\8c000230@-[16] This function is invoked by the miscops when
-1 is subtracted from a complex.
-
-@index[%SP-ratio*ratio]
-%SP-ratio*ratio@\8c000244@-[16] This function is invoked by the miscops to
-multiply two ratios.
-
-@index[%SP-number*complex]
-%SP-number*complex@\8c000258@-[16] This function is invoked by the miscops to
-multiply a number by a complex.
-
-@index[%SP-complex*number]
-%SP-complex*number@\8c00026c@-[16] This function is invoked by the miscops to
-multiply a complex by a number.
-
-@index[%SP-complex*complex]
-%SP-complex*complex@\8c000280@-[16] This function is invoked by the miscops
-to multiply a complex by a complex.
-
-@index[%SP-integer/ratio]
-%SP-integer/ratio@\8c000294@-[16] This function is invoked by the miscops to
-divide an integer by a ratio.
-
-@index[%SP-ratio/integer]
-%SP-ratio/integer@\8c0002a8@-[16] This function is invoked by the miscops to
-divide a ratio by an integer.
-
-@index[%SP-ratio/ratio]
-%SP-ratio/ratio@\8c0002bc@-[16] This function is invoked by the miscops to
-divide a ratio by a ratio.
-
-@index[%SP-number/complex]
-%SP-number/complex@\8c0002d0@-[16] This function is invoked by the miscops to
-divide a number by a complex.
-
-@index[%SP-complex/number]
-%SP-complex/number@\8c0002e4@-[16] This function is invoked by the miscops to
-divide a complex by a number.
-
-@index[%SP-complex/complex]
-%SP-complex/complex@\8c0002f8@-[16] This function is invoked by the miscops
-to divide a complex by a complex.
-
-@index[%SP-integer-truncate-ratio]
-%SP-integer-truncate-ratio@\8c00030c@-[16] This function is invoked by the
-miscops to truncate an integer by a ratio.
-
-@index[%SP-ratio-truncate-integer]
-%SP-ratio-truncate-integer@\8c000320@-[16] This function is invoked by the
-miscops to truncate a ratio by an integer.
-
-@index[%SP-ratio-truncate-ratio]
-%SP-ratio-truncate-ratio@\8c000334@-[16] This function is invoked by the
-miscops to truncate a ratio by a ratio.
-
-@index[%SP-number-truncate-complex]
-%SP-number-truncate-complex@\8c000348@-[16] This function is invoked by the
-miscops to truncate a number by a complex.
-
-@index[%SP-complex-truncate-number]
-%SP-complex-truncate-number@\8c00035c@-[16] This function is invoked by the
-miscops to truncate a complex by a number.
-
-@index[%SP-complex-truncate-complex]
-%SP-complex-truncate-complex@\8c000370@-[16] This function is invoked by
-the miscops to truncate a complex by a complex.
-
-@index[maybe-gc]
-Maybe-GC@\8c000384@-[16] This function may be invoked by any miscop that
-does allocation.  This function determines whether it is time to garbage
-collect or not.  If it is it performs a garbage collection.  Whether it
-invokes a garbage collection or not, it returns the single argument passed
-to it.
-
-@index[Lisp-environment-list]
-Lisp-environment-list@\8c000398@-[16] The value of this symbol is
-set to the a list of the Unix environment strings passed into the Lisp
-process.  This list by Lisp to obtain various environment information, such
-as the user's home directory, etc.
-
-@index[Call-lisp-from-c]
-Call-lisp-from-C@\8c0003ac@-[16] This function is called whenever a
-C function called by Lisp tries to call a Lisp function.
-
-@index[Lisp-command-line-list]
-Lisp-command-line-list@\8c0003c0@-[16] The value of this symbol is
-set to the list of strings passed into the Lisp process as the command
-line.
-
-@index[*Nameserverport*]
-*Nameserverport*@\8c0003d4@-[16] The value of this symbol is set to
-the C global variable name_server_port.  This allows Lisp to access the
-name server.
-
-@index[*Ignore-Floating-Point-Underflow*]
-*Ignore-Floating-Point-Underflow*@\8c0003e8@-[16] If the the value of this
-symbol is NIL then an error is signalled when floating point underflow
-occurs, otherwise the operation quietly returns zero.
-@End[description]
-
-@chapter [Runtime Environment]
-@index [Runtime Environment]
-@label [Runtime]
-
-@section [Register Allocation]
-@index [Register allocation]
-To describe the assembler support routines in chapter @ref[Instr-Chapter] and
-the complicated
-control conventions in chapter @ref[Control-Conventions] requires that we talk
-about the allocation of the 16 32-bit general purpose registers provided
-by the @value(DinkyMachine).
-@begin [description]
-@index [Program-Counter register]
-Program-Counter (PC) [R15]@\This register contains an index into the current
-code vector when a Lisp function is about to be called.  When a miscop is
-called, it contains the return address.  It may be used as a super temporary
-between miscop and function calls.
-
-@index [Active-Function-Pointer register]
-Active-Function-Pointer (AF) [R14]@\This register contains a pointer to the
-active function object.  It is used to access the symbol and constant area for
-the currently running function.
-
-@index [Active-Frame-Pointer register]
-Active-Frame-Pointer (FP) [R13]@\This register contains a pointer to the
-current active frame on the control stack.  It is used to access the arguments
-and local variables stored on the control stack.
-
-@index [Binding-Stack-Pointer register]
-Binding-Stack-Pointer (BS) [R12]@\This register contains the current binding
-stack pointer.	The binding stack is a downward growing stack and follows
-a decrement-write/increment-read discipline.
-
-@index [Local registers]
-Local registers (L0-L4) [R7-R11]@\These registers contain locals and saved
-arguments for the currently executing function.  Functions may use these
-registers, so that stack accesses can be reduced, since a stack access is
-relatively expensive compared to a register access.
-
-@index [Argument registers]
-Argument register (A0, A1, A2) [R1, R3, R5]@\These registers contain arguments
-to a function or miscop that has just been called.  On entry to a function
-or miscop, they contain the first three arguments.  The first thing a function
-does is to move the contents of these registers into the local registers.
-
-@index [Miscop argument register]
-Miscop argument register (A3) [R4]@\This register is used to pass a fourth
-argument to miscops requiring four or more arguments.  It is also used as a
-super temporary by the compiler.
-
-@index [Control-Stack-Pointer register]
-Control-Stack-Pointer (CS) [R6]@\The stack pointer for the control stack, an
-object of type Control-Stack-Pointer.  Points to the last used word in
-Control-Stack space; this upward growing stack uses a
-increment-write/read-decrement discipline.
-
-@index [Non-Lisp temporary registers]
-Non-Lisp temporary registers (NL0, NL1) [R0, R2]@\These registers are used to
-contain non-Lisp values.  They will normally be used during miscop calls, but
-may also be used in in-line code to contain temporary data.  These are the only
-two registers never examined by the garbage collector, so no pointers to Lisp
-objects should be stored here (since they won't get updated during a garbage
-collection).
-@end [description]
-
-@section [Function Object Format]
-@label [Fn-Format]
-
-Each compiled function is represented in the machine as a Function
-Object.  This is identical in form to a G-Vector of lisp objects, and
-is treated as such by the garbage collector, but it exists in a
-special function space.  (There is no particular reason for this
-distinction.  We may decide later to store these things in G-Vector
-space, if we become short on spaces or have some reason to believe
-that this would improve paging behavior.)  Usually, the function
-objects and code vectors will be kept in read-only space, but nothing
-should depend on this; some applications may create, compile, and
-destroy functions often enough to make dynamic allocation of function
-objects worthwhile.
-
-@index [Code vector]
-@index [Constants in code] The function object contains a vector of
-header information needed by the function-calling mechanism: a
-pointer to the I-Vector that holds the actual code.  Following this
-is the so-called ``symbols and constants'' area.  The first few
-entries in this area are fixnums that give the offsets into the code
-vector for various numbers of supplied arguments.  Following this
-begin the true symbols and constants used by the function.  Any
-symbol used by the code as a special variable.
-Fixnum constants can be generated faster
-with in-line code than they can be accessed from the function-object,
-so they are not stored in the constants area.
-
-The subtype of the G-Vector header indicates the type of the function:
-@begin(Itemize, spacing 1, spread 0)
-0 - A normal function (expr).
-
-1 - A special form (fexpr).
-
-2 - A defmacro macroexpansion function.
-
-3 - An anonymous expr.  The name is the name of the parent function.
-
-4 - A compiled top-level form.
-@end(Itemize)
-Only the fexpr information has any real meaning to the system.  The rest
-is there for the printer and anyone else who cares.
-
-
-After the one-word G-Vector header, the entries of the function object
-are as follows:
-
-@begin [verbatim, group]
-0  Name of the innermost enclosing named function.
-1  Pointer to the unboxed Code vector holding the instructions.
-2  A fixnum with bit fields as follows:
-   24  - 31: The minimum legal number of args (0 to 255).
-   16  - 23: The maximum number of args, not counting &rest (0 to 255).
-	The fixnum has a negative type code, if the function accepts a &rest
-	arg and a positive one otherwise.
-3  A string describing the source file from which the function was defined.
-   See below for a description of the format.
-4  A string containing a printed representation of the argument list, for
-   documentation purposes.  If the function is a defmacro macroexpansion
-   function, the argument list will be the one originally given to defmacro
-   rather than the actual arglist to the expansion function.
-5  The symbols and constants area starts here.
-   This word is entry 0 of the symbol/constant area.
-   The first few entries in this area are fixnums representing the
-   code-vector entry points for various numbers of optional arguments.
-@end [verbatim]
-
-@section [Defined-From String Format]
-@label [Defined-From-String-Format]
-@index [Defined-From String Format]
-
-The defined-from string may have any of three different formats, depending
-on which of the three compiling functions compiled it:
-@begin(Description)
-compile-file "@i[filename user-time universal-time]"@\  The @i[filename] is
-the namestring of the truename of the file the function was defined from.
-The time is the file-write-date of the file.
-
-compile "Lisp on @i[user-time], machine @i[machine universal-time]"@\
-The time is the time that the function was compiled.  @i[Machine] is the
-machine-instance of the machine on which the compilation was done.
-
-compile-from-stream "@i[stream] on @i[user-time], machine @i[machine-instance
-universal-time]"@\@i[Stream] is the printed representation of the stream
-compiled from.  The time is the time the compilation started.
-@end(Description)
-
-An example of the format of @i[user-time] is 6-May-86 1:04:44.  The
-@i[universal-time] is the same time represented as a decimal integer.
-It should be noted that in each case, the universal time is the last
-thing in the string.
-
-@section [Control-Stack Format]
-@label [Control-Stack-Format]
-@index [Control-stack format]
-
-The CMU Common Lisp control stack is a framed stack.  Call frames, which hold
-information for function calls, are intermixed with catch frames, which hold
-information used for non-local exits.  In addition, the control stack is used
-as a scratchpad for random computations.
-
-@subsection [Call Frames]
-@index [Open frame]
-@index [Active frame]
-
-At any given time, the machine contains pointers to the current top
-of the control stack and the start of the current active frame (in
-which the current function is executing).  In addition, there is a
-pointer to the current top of the special binding stack.  CMU Common Lisp
-on the Perq also has a pointer to an open frame.  An open frame is
-one which has been partially built, but which is still having
-arguments for it computed.  When all the arguments have been computed
-and saved on the frame, the function is then started.  This means
-that the call frame is completed, becomes the current active frame,
-and the function is executed.  At this time, special variables may be
-bound and the old values are saved on the binding stack.  Upon
-return, the active frame is popped away and the result is either sent
-as an argument to some previously opened frame or goes to some other
-destination.  The binding stack is popped and old values are
-restored.
-
-On the @value(DinkyMachine), open frames still exist, however, no register is
-allocated to point at the most recent one.  Instead, a count of the arguments
-to the function is kept.  In most cases, a known fixed number of arguments are
-passed to a function, and this is all that is needed to calculate the correct
-place to set the active frame pointer.
-In some cases, it is not as simple, and runtime calculations are necessary to
-set up the frame pointer.  These calculations are simple except in some very
-strange cases.
-
-The active frame contains pointers to the previously-active frame and
-to the point to which the binding stack will be popped
-on exit, among other things.  Following this is a vector of storage locations
-for the function's arguments and local variables.  Space is allocated for the
-maximum number of arguments that the function can take, regardless of how many
-are actually supplied.
-
-In an open frame, stack space is allocated up to the point where the arguments
-are stored.  Nothing is stored in the frame
-at this time.	Thus, as arguments are computed, they can simply be pushed on
-the stack.  Since the first three arguments are passed in registers, it is
-sometimes necessary to save these values when succeeding arguments are
-complicated.  When the function is finally started, the remainder of the frame
-is built (including storing all the
-registers that must be saved).	A call frame looks like this:
-@begin [verbatim, group]
-0   Saved local 0 register.
-1   Saved local 1 register.
-2   Saved local 2 register.
-3   Saved local 3 register.
-4   Saved local 4 register.
-5   Pointer to previous binding stack.
-6   Pointer to previous active frame.
-7   Pointer to previous active function.
-8   Saved PC of caller.  A fixnum.
-9   Args-and-locals area starts here.  This is entry 0.
-@end [verbatim]
-The first slot is pointed to by the Active-Frame register if this frame is
-currently active.
-
-@subsection [Catch Frames]
-@index [Catch]
-@index [Catch frames]
-
-Catch frames contain much of the same information that call frames
-do, and have a very similar format.  A catch frame holds the function
-object for the current function, a stack pointer to the current
-active frame, a pointer to the current top of the binding stack, and
-a pointer to the previous catch frame.  When a Throw occurs, an
-operation similar to returning from this catch frame (as if it
-were a call frame) is performed, and the stacks are unwound to the
-proper place for continued execution in the current function.  A
-catch frame looks like this:
-@begin [verbatim, group]
-0   Pointer to current binding stack.
-1   Pointer to current active frame.
-2   Pointer to current function object.
-3   Destination PC for a Throw.
-4   Tag caught by this catch frame.
-5   Pointer to previous catch frame.
-@end [verbatim]
-The conventions used to manipulate call and catch frames are described in
-chapter @ref[Control-Conventions].
-
-@section [Binding-Stack Format]
-@index [Binding stack format]
-
-Each entry of the binding-stack consists of two boxed (32-bit) words.  Pushed
-first is a pointer to the symbol being bound.  Pushed second is the symbol's
-old value (any boxed item) that is to be restored when the binding stack is
-popped.
-
-@chapter [Storage Management]
-@index [Storage management]
-@index [Garbage Collection]
-@label [Alloc-Chapter]
-
-@index [Free-Storage pointer]
-@index [Clean-Space pointer]
-New objects are allocated from the lowest unused addresses within the specified
-space.	Each allocation call specifies how many words are wanted, and a
-Free-Storage pointer is incremented by that amount.  There is one of these
-Free-Storage pointers for each space, and it points to the lowest free address
-in the space.  There is also a Clean-Space pointer associated with each space
-that is used during garbage collection.  These pointers are stored in a table
-which is indexed by the type and space code.  The
-address of the Free-Storage pointer for a given space is
-@begin[verbatim]
-	(+ alloc-table-base (lsh type 5) (lsh space 3)).
-@end[verbatim]
-The address of the Clean-Space pointer is
-@begin[verbatim]
-	(+ alloc-table-base (lsh type 5) (lsh space 3) 4).
-@end[verbatim]
-
-Common Lisp on the @value(DinkyMachine) uses a stop-and-copy garbage collector
-to reclaim storage.  The Collect-Garbage miscop performs a full GC.  The
-algorithm used is a degenerate form of Baker's incremental garbage collection
-scheme.  When the Collect-Garbage miscop is executed, the following
-happens:
-@begin[enumerate]
-The current newspace becomes oldspace, and the current oldspace becomes
-newspace.
-
-The newspace Free-Storage and Clean-Space pointers are initialized to point to
-the beginning of their spaces.
-
-The objects pointed at by contents of all the registers containing Lisp objects
-are transported if necessary.
-
-The control stack and binding stack are scavenged.
-
-Each static pointer space is scavenged.
-
-Each new dynamic space is scavenged.  The scavenging of the dynamic spaces
-continues until an entire pass through all of them does not result in anything
-being transported.  At this point, every live object is in newspace.
-@end[enumerate]
-A Lisp-level GC function returns the oldspace pages to Mach.
-
-@index [Transporter]
-@section [The Transporter]
-The transporter moves objects from oldspace to newspace.  It is given an
-address @i[A], which contains the object to be transported, @i[B].  If @i[B] is
-an immediate object, a pointer into static space, a pointer into read-only
-space, or a pointer into newspace, the transporter does nothing.
-
-If @i[B] is a pointer into oldspace, the object it points to must be
-moved.  It may, however, already have been moved.  Fetch the first
-word of @i[B], and call it @i[C].  If @i[C] is a GC-forwarding
-pointer, we form a new pointer with the type code of @i[B] and the
-low 27 bits of @i[C].  Write this into @i[A].
-
-If @i[C] is not a GC-forwarding pointer, we must copy the object that
-@i[B] points to.  Allocate a new object of the same size in newspace,
-and copy the contents.  Replace @i[C] with a GC-forwarding pointer to
-the new structure, and write the address of the new structure back
-into @i[A].
-
-Hash tables maintained with an EQ relation need special treatment by the
-transporter.  Whenever a G-Vector with subtype 2 or 3 is transported to
-newspace, its subtype code is changed to 4.  The Lisp-level hash-table
-functions will see that the subtype code has changed, and re-hash the entries
-before any access is made.
-
-@index [Scavenger]
-@section [The Scavenger] The scavenger looks through an area of
-pointers for pointers into oldspace, transporting the objects they
-point to into newspace.  The stacks and static spaces need to be
-scavenged once, but the new dynamic spaces need to be scavenged
-repeatedly, since new objects will be allocated while garbage
-collection is in progress.  To keep track of how much a dynamic space
-has been scavenged, a Clean-Space pointer is maintained.  The
-Clean-Space pointer points to the next word to be scavenged.  Each
-call to the scavenger scavenges the area between the Clean-Space
-pointer and the Free-Storage pointer.  The Clean-Space pointer is
-then set to the Free-Storage pointer.  When all Clean-Space pointers
-are equal to their Free-Storage pointers, GC is complete.
-
-To maintain (and create) locality of list structures, list space is
-treated specially.  When a list cell is transported, if the cdr points
-to oldspace, it is immediately transported to newspace.  This continues until
-the end of the list is encountered or a non-oldspace pointer occurs in the cdr
-position.  This linearizes lists in the cdr direction which should
-improve paging performance.
-
-@section [Purification]
-@index [Purification]
-@label [PURIFY]
-
-Garbage is created when the files that make up a CMU Common Lisp system are
-loaded.  Many functions are needed only for initialization and
-bootstrapping (e.g. the ``one-shot'' functions produced by the compiler for
-random forms between function definitions), and these can be thrown away
-once a full system is built.  Most of the functions in the system, however,
-will be used after initialization.  Rather than bend over backwards to make
-the compiler dump some functions in read-only space and others in dynamic
-space (which involves dumping their constants in the proper spaces, also),
-@i[everything] is dumped into dynamic space.  A purify miscop is provided
-that does a garbage collection and moves accessible information in dynamic
-space into read-only or static space.
-
-@chapter [Assembler Support Routines]
-@label [Instr-Chapter]
-@index [Assembler Support Routines]
-
-To support compiled Common Lisp code many hand coded assembler
-language routines (miscops) are required.  These routines accept
-arguments in the three argument registers, the special miscop
-argument register, and in a very few cases on the stack.  The current
-register assignments are:
-@begin(Itemize, spread 0, spacing 1)
-A0 contains the first argument.
-
-A1 contains the second argument.
-
-A2 contains the third argument.
-
-A3 contains the fourth argument.
-@end(itemize)
-The rest of the arguments are passed on the stack with the last
-argument at the end of the stack.  All arguments on the stack must be
-popped off the stack by the miscop.  All miscops return their
-values in register A0.  A few miscops return two or three values,
-these are all placed in the argument registers.  The main return
-value is stored in register A0, the others in A1 and A2.  The
-compiler must generate code to use the multiple values correctly,
-i.e., place the return values on the stack and put a values marker in
-register A0 if multiple-values are wanted.  Otherwise the compiler
-can use the value(s) it needs and ignore the rest.  NB: Most of the
-miscops follow this scheme, however, a few do not.  Any
-discrepancies are explained in the description of particular
-miscops.
-
-Several of the instructions described in the Perq Internal Design Document do
-not have associated miscops, rather they have been code directly in-line.
-Examples of these instructions include push, pop, bind, bind-null, many of the
-predicates, and a few other instructions.  Most of these instructions can be
-performed in 4 or fewer @value(DinkyMachine) instructions and the overhead of
-calling a miscop seemed overly expensive.  Some instructions are encoded
-in-line or as a miscop call depending on settings of compiler optimization
-switches.  If space is more important than speed, then some Perq instructions
-are compiled as calls to out of line miscops rather than generating in-line
-code.
-
-@section [Miscop Descriptions]
-@label[macro-codes]
-
-There are 10 classes of miscops: allocation, stack manipulation,
-list manipulation, symbol manipulation, array manipulation, type predicate,
-arithmetic and logical, function call and return,
-miscellaneous, and system hacking.
-
-@subsection [Allocation]
-@instrsection
-All non-immediate objects are allocated in the ``current allocation space,''
-which is dynamic space, static space, or read-only space.  The current
-allocation space is initially dynamic space, but can be changed by using the
-Set-Allocation-Space miscop below.  The current allocation space can be
-determined by using the Get-Allocation-Space miscop.  One usually wants to
-change the allocation space around some section of code; an unwind protect
-should be used to insure that the allocation space is restored to some safe
-value.
-
-@begin(Description)
-@index [Get-Allocation-Space]
-Get-Allocation-Space (@i[])@\returns 0, 2, or 3 if the current allocation
-space is dynamic, static, or read-only, respectively.
-
-@index [Set-Allocation-Space]
-Set-Allocation-Space (@i[X])@\sets the current allocation space to dynamic,
-static, or read-only if @i[X] is 0, 2, or 3 respectively.  Returns @i[X].
-
-@index [Alloc-Bit-Vector]
-Alloc-Bit-Vector (Length)@\returns a new bit-vector @i[Length] bits long,
-which is allocated in the current allocation space.  @i[Length] must be a
-positive fixnum.
-
-@index [Alloc-I-Vector]
-Alloc-I-Vector (@i[Length A])@\returns a new I-Vector @i[Length]
-bytes long, with the access code specified by @i[A].  @i[Length] and
-@i[A] must be positive fixnums.
-
-@index [Alloc-String]
-Alloc-String (@i[Length])@\ returns a new string @i[Length] characters long.
-@i[Length] must be a fixnum.
-
-@index [Alloc-Bignum]
-Alloc-Bignum (@i[Length])@\returns a new bignum @i[Length] 32-bit words long.
-@i[Length] must be a fixnum.
-
-@index [Make-Complex]
-Make-Complex (@i[Realpart Imagpart])@\returns a new complex number with the
-specified @i[Realpart] and @i[Imagpart].  @i[Realpart] and @i[Imagpart] should
-be the same type of non-complex number.
-
-@index [Make-Ratio]
-Make-Ratio (@i[Numerator Denominator])@\returns a new ratio with the
-specified @i[Numerator] and @i[Denominator].  @i[Numerator] and
-@i[Denominator] should be integers.
-
-@index [Alloc-G-Vector]
-Alloc-G-Vector (@i[Length Initial-Element])@\returns a new G-Vector
-with @i[Length] elements initialized to @i[Initial-Element].
-@i[Length] should be a fixnum.
-
-@index [Static-Alloc-G-Vector]
-Static-G-Vector (@i[Length Initial-Element])@\returns a new G-Vector in
-static allocation space with @i[Length] elements initialized to
-@i[Initial-Element].
-
-@index [Vector]
-Vector (@i[Elt@-[0] Elt@-[1] ... Elt@-[Length - 1] Length])@\returns a new
-G-Vector containing the specified @i[Length] elements.	@i[Length] should be a
-fixnum and is passed in register A0.  The rest of the arguments are passed on
-the stack.
-
-@index [Alloc-Function]
-Alloc-Function (@i[Length])@\returns a new function with @i[Length] elements.
-@i[Length] should be a fixnum.
-
-@index [Alloc-Array]
-Alloc-Array (@i[Length])@\returns a new array with @i[Length] elements.
-@i[Length] should be a fixnum.
-
-@index [Alloc-Symbol]
-Alloc-Symbol (@i[Print-Name])@\returns a new symbol with the print-name as
-@i[Print-Name].  The value is initially Trap, the definition is Trap,
-the property list and the package are initially NIL.  The symbol is
-not interned by this operation -- that is done in Lisp code.
-@i[Print-Name] should be a simple-string.
-
-@index [Cons]
-Cons (@i[Car Cdr])@\returns a new cons with the specified @i[Car] and @i[Cdr].
-
-@index [List]
-List (@i[Elt@-[0] Elt@-[1] ... Elt@-[CE - 1] Length])@\returns a new list
-containing the @i[Length] elements.  @i[Length] should be fixnum and is
-passed in register NL0.  The first three arguments are passed in A0, A1, and
-A2.  The rest of the arguments are passed on the stack.
-
-@index [List*]
-List* (@i[Elt@-[0] Elt@-[1] ... Elt@-[CE - 1] Length])@\returns a list* formed
-by the @i[Length-1] elements.  The last element is placed in the cdr of the
-last element of the new list formed.  @i[Length] should be a fixnum and is
-passed in register NL0.  The first three arguments are passed in A0, A1, and
-A2.  The rest of the arguments are passed on the stack.
-
-@index[mv-list]
-MV-List (@i[Elt@-<0> Elt@-<1> ... Elt@-<CE - 1> Length])@\returns a list
-formed from the elements, all of which are on the stack.  @i[Length] is
-passed in register A0.  This miscop is invoked when multiple values from
-a function call are formed into a list.
-@end(Description)
-
-@subsection [Stack Manipulation]
-@instrsection
-
-@begin(Description)
-@index [Push]
-Push (@i[E])@\pushes E on to the control stack.
-
-@index [Pop]
-Pop (@i[E])@\pops the top item on the control stack into @i[E].
-
-@index [NPop]
-NPop (@i[N])@\If @i[N] is positive, @i[N] items are popped off of the stack.
-If @i[N] is negative, NIL is pushed onto the stack -@i[N] times.  @i[N] must be
-a fixnum.
-
-@index [Bind-Null]
-Bind-Null (@i[E])@\pushes @i[E] (which must be a symbol) and its current value
-onto the binding stack, and sets the value of @i[E] to NIL.  Returns NIL.
-
-@index [Bind]
-Bind (Value Symbol)@\pushes @i[Symbol] (which must be a symbol) and its current
-value onto the binding stack, and sets the value cell of @i[Symbol] to
-@i[Value].  Returns @i[Symbol].
-
-@index [Unbind]
-Unbind (@i[N])@\undoes the top @i[N] bindings on the binding stack.
-@end(Description)
-
-@subsection [List Manipulation]
-@instrsection
-
-@begin(Description)
-@index [Car]
-@index [Cdr]
-@index [Caar]
-@index [Cadr]
-@index [Cdar]
-@index [Cddr]
-Car, Cdr, Caar, Cadr, Cdar, Cddr (@i[E])@\returns the car, cdr, caar, cadr,
-cdar, or cddr of @i[E] respectively.
-
-@index [Set-Cdr]
-@index [Set-Cddr]
-Set-Cdr, Set-Cddr (@i[E])@\The cdr or cddr of the contents of @i[E] is stored
-in @i[E]. The contents of @i[E] should be either a list or NIL.
-
-@index [Set-Lpop]
-Set-Lpop (@i[E])@\The car of the contents of @i[E] is returned;
-the cdr of the contents of @i[E] is stored in @i[E].  The contents of @i[E]
-should be a list or NIL.
-
-@index [Spread]
-Spread (@i[E])@\pushes the elements of the list @i[E] onto the stack in
-left-to-right order.
-
-@index [Replace-Car]
-@index [Replace-Cdr]
-Replace-Car, Replace-Cdr (@i[List Value])@\sets the car or cdr of the @i[List]
-to @i[Value] and returns @i[Value].
-
-@index [Endp]
-Endp (X)@\sets the condition code eq bit to 1 if @i[X] is NIL, or 0 if @i[X] is
-a cons cell.  Otherwise an error is signalled.
-
-@index [Assoc]
-@index [Assq]
-Assoc, Assq (@i[List Item])@\returns the first cons in the association-list
-@i[List] whose car is EQL to @i[Item].  If the = part of the EQL comparison
-bugs out (and it can if the numbers are too complicated), a Lisp-level Assoc
-function is called with the current cdr of the @i[List].  Assq returns the
-first cons in the association-list @i[List] whose car is EQ to @i[Item].
-
-@index [Member]
-@index [Memq] Member, Memq (@i[List Item])@\returns the first cons in
-the list @i[List] whose car is EQL to @i[Item].  If the = part of the
-EQL comparison bugs out, a Lisp-level Member function is called with
-the current cdr of the @i[List].  Memq returns the first cons in
-@i[List] whose car is EQ to the @i[Item].
-
-@index [GetF]
-
-GetF (@i[List Indicator Default])@\searches for the @i[Indicator] in
-the list @i[List], cddring down as the Common Lisp form GetF would.
-If @i[Indicator] is found, its associated value is returned,
-otherwise @i[Default] is returned.
-@end(Description)
-
-@subsection [Symbol Manipulation]
-@instrsection
-
-Most of the symbol manipulation miscops are compiled in-line rather than
-actual calls.
-
-@begin(Description)
-@index [Get-Value]
-Get-Value (@i[Symbol])@\returns the value of @i[Symbol] (which must be a
-symbol).  An error is signalled if @i[Symbol] is unbound.
-
-@index [Set-Value]
-Set-Value (@i[Symbol Value])@\sets the value cell of the symbol @i[Symbol] to
-@i[Value].  @i[Value] is returned.
-
-@index [Get-Definition]
-Get-Definition (@i[Symbol])@\returns the definition of the symbol
-@i[Symbol].  If @i[Symbol] is undefined, an error is signalled.
-
-@index [Set-Definition]
-Set-Definition (@i[Symbol Definition])@\sets the definition of the symbol
-@i[Symbol] to @i[Definition].  @i[Definition] is returned.
-
-@index [Get-Plist]
-Get-Plist (@i[Symbol])@\returns the property list of the symbol @i[Symbol].
-
-@index [Set-Plist] 
-Set-Plist (@i[Symbol Plist])@\sets the property
-list of the symbol @i[Symbol] to
-@i[Plist].  @i[Plist] is returned.
-
-@index [Get-Pname]
-Get-Pname (@i[Symbol])@\returns the print name of the symbol @i[Symbol].
-
-@index [Get-Package]
-Get-Package (@i[Symbol])@\returns the package cell of the symbol @i[Symbol].
-
-@index [Set-Package]
-Set-Package (@i[Symbol Package])@\sets the package cell of the symbol
-@i[Symbol] to @i[Package].  @i[Package] is returned.
-
-@index [Boundp]
-Boundp (@i[Symbol])@\sets the eq condition code bit to 1 if the symbol
-@i[Symbol] is bound; sets it to 0 otherwise.
-
-@index [FBoundp]
-FBoundp (@i[Symbol])@\sets the eq condition code bit to 1 if the symbol
-@i[Symbol] is defined; sets it to 0 otherwise.
-
-@index [Get]
-Get (@i[Symbol] @i[Indicator] @i[Default])@\searches the property list of
-@i[Symbol] for @i[Indicator] and returns the associated value.  If
-@i[Indicator] is not found, @i[Default] is returned.
-
-@index [Put]
-Put (@i[Symbol] @i[Indicator] @i[Value])@\searches the property list of
-@i[Symbol] for @i[Indicator] and replaces the associated value with @i[Value].
-If @i[Indicator] is not found, the @i[Indicator] @i[Value] pair are consed onto
-the front of the property list.
-@end(Description)
-
-@subsection [Array Manipulation]
-@instrsection
-
-Common Lisp arrays have many manifestations in CMU Common Lisp.  The CMU
-Common Lisp data types Bit-Vector, Integer-Vector, String, General-Vector,
-and Array are used to implement the collection of data types the Common
-Lisp manual calls ``arrays.''
-
-In the following miscop descriptions, ``simple-array'' means an array
-implemented in CMU Common Lisp as a Bit-Vector, I-Vector, String, or
-G-Vector.  ``Complex-array'' means an array implemented as a CMU Common Lisp
-Array object.  ``Complex-bit-vector'' means a bit-vector implemented as a
-CMU Common Lisp array; similar remarks apply for ``complex-string'' and so
-forth.
-
-@begin(Description)
-@index [Vector-Length] @index [G-Vector-Length] @index
-[Simple-String-Length] @index [Simple-Bit-Vector-Length] Vector-Length
-(@i[Vector])@\returns the length of the one-dimensional Common Lisp array
-@i[Vector].  G-Vector-Length, Simple-String-Length, and
-Simple-Bit-Vector-Length return the lengths of G-Vectors, CMU Common Lisp
-strings, and CMU Common Lisp Bit-Vectors respectively.  @i[Vector] should
-be a vector of the appropriate type.
-
-@index [Get-Vector-Subtype]
-Get-Vector-Subtype (@i[Vector])@\returns the subtype field of the vector
-@i[Vector] as an integer.  @i[Vector] should be a vector of some sort.
-
-@index [Set-Vector-Subtype]
-Set-Vector-Subtype (@i[Vector A])@\sets the subtype field of the vector
-@i[Vector] to @i[A], which must be a fixnum.
-
-@index [Get-Vector-Access-Code]
-Get-Vector-Access-Code (@i[Vector])@\returns the access code of the I-Vector
-(or Bit-Vector) @i[Vector] as a fixnum.
-
-@index [Shrink-Vector]
-Shrink-Vector (@i[Vector Length])@\sets the length field and the
-number-of-entries field of the vector @i[Vector] to @i[Length].  If the vector
-contains Lisp objects, entries beyond the new end are set to Trap.
-Returns the shortened vector.  @i[Length] should be a fixnum.  One cannot
-shrink array headers or function headers.
-
-@index [Typed-Vref]
-Typed-Vref (@i[A Vector I])@\returns the @i[I]'th element of the I-Vector
-@i[Vector] by indexing into it as if its access-code were @i[A].  @i[A] and
-@i[I] should be fixnums.
-
-@index [Typed-Vset]
-Typed-Vset (@i[A Vector I Value])@\sets the @i[I]'th element of the I-Vector
-@i[Vector] to @i[Value] indexing into @i[Vector] as if its access-code were
-@i[A].	@i[A], @i[I], and @i[Value] should be fixnums.	@i[Value] is returned.
-
-@index [Header-Length]
-Header-Length (@i[Object])@\returns the number of Lisp objects in the header of
-the function or array @i[Object].  This is used to find the number of
-dimensions of an array or the number of constants in a function.
-
-@index [Header-Ref]
-Header-Ref (@i[Object I])@\returns the @i[I]'th element of the function or
-array header @i[Object].  @i[I] must be a fixnum.
-
-@index [Header-Set]
-Header-Set (@i[Object I Value])@\sets the @i[I]'th element of the function of
-array header @i[Object] to @i[Value], and pushes @i[Value].  @i[I] must be a
-fixnum.
-@end(Description)
-
-The names of the miscops used to reference and set elements of arrays are
-based somewhat on the Common Lisp function names.  The SVref, SBit, and SChar
-miscops perform the same operation as their Common Lisp namesakes --
-referencing elements of simple-vectors, simple-bit-vectors, and simple-strings
-respectively.  Aref1 references any kind of one dimensional array.
-The names of setting functions are derived by replacing ``ref'' with ``set'',
-``char'' with ``charset'', and ``bit'' with ``bitset.''
-
-@begin(Description)
-@index [Aref1]
-@index [SVref]
-@index [SChar]
-@index [SBit]
-Aref1, SVref, SChar, SBit (@i[Array I])@\returns the @i[I]'th element of the
-one-dimensional
-array @i[Array].  SVref pushes an element of a G-Vector; SChar an element of a
-string; Sbit an element of a Bit-Vector.  @i[I] should be a fixnum.
-
-@index [Aset1]
-@index [SVset]
-@index [SCharset]
-@index [SBitset]
-Aset1, SVset, SCharset, SBitset (@i[Array I Value])@\sets the @i[I]'th element
-of the one-dimensional
-array @i[Array] to @i[Value].  SVset sets an element of a G-Vector; SCharset an
-element of a string; SBitset an element of a Bit-Vector.  @i[I] should be a
-fixnum and @i[Value] is returned.
-
-@index [CAref2]
-@index [CAref3]
-CAref2, CAref3 (@i[Array I1 I2])@\returns the element (@i[I1], @i[I2]) of the
-two-dimensional array @i[Array].  @i[I1] and @i[I2] should be
-fixnums.  CAref3 pushes the element (@i[I1], @i[I2], @i[I3]).
-
-@index [CAset2]
-@index [CAset3]
-CAset2, CAset3 (@i[Array I1 I2 Value]) @\sets the element (@i[I1], @i[I2]) of
-the two-dimensional array @i[Array] to @i[Value] and returns @i[Value].
-@i[I1] and @i[I2] should be fixnums.  CAset3 sets the element (@i[I1], @i[I2],
-@i[I3]).
-
-@index [Bit-Bash]
-Bit-Bash (@i[V1 V2 V3 Op])@\@i[V1], @i[V2], and @i[V3] should be bit-vectors
-and @i[Op] should be a fixnum.	The elements of the bit vector @i[V3] are
-filled with the result of @i[Op]'ing the corresponding elements of @i[V1] and
-@i[V2].  @i[Op] should be a Boole-style number (see the Boole miscop in
-section @ref[Boole-Section]).
-@end(Description)
-
-The rest of the miscops in this section implement special cases of sequence or
-string operations.	Where an operand is referred to as a string, it may
-actually be an 8-bit I-Vector or system area pointer.
-
-@begin(Description)
-@index [Byte-BLT]
-Byte-BLT (@i[Src-String Src-Start Dst-String Dst-Start Dst-End])@\
-moves bytes from @i[Src-String] into @i[Dst-String] between @i[Dst-Start]
-(inclusive) and @i[Dst-End] (exclusive).  @i[Dst-Start] - @i[Dst-End] bytes are
-moved.	If the substrings specified overlap, ``the right thing happens,'' i.e.
-all the characters are moved to the right place.  This miscop corresponds
-to the Common Lisp function REPLACE when the sequences are simple-strings.
-
-@index [Find-Character]
-Find-Character (@i[String Start End Character])@\
-searches @i[String] for the @i[Character] from @i[Start] to @i[End].  If the
-character is found, the corresponding index into @i[String] is returned,
-otherwise NIL is returned.  This miscop corresponds to the Common Lisp
-function FIND when the sequence is a simple-string.
-
-@index [Find-Character-With-Attribute]
-Find-Character-With-Attribute (@i[String Start End Table Mask])@\
-The codes of the characters of @i[String] from @i[Start] to @i[End] are used as
-indices into the @i[Table], which is an I-Vector of 8-bit bytes.  When the
-number picked up from the table bitwise ANDed with @i[Mask] is non-zero, the
-current index into the @i[String] is returned.
-
-@index [SXHash-Simple-String]
-SXHash-Simple-String (@i[String Length])@\Computes the hash code of the first
-@i[Length] characters of @i[String] and pushes it on the stack.  This
-corresponds to the Common Lisp function SXHASH when the object is a
-simple-string.	The @i[Length] operand can be Nil, in which case the length of
-the string is calculated in assembler.
-@end(Description)
-
-@subsection [Type Predicates]
-@instrsection
-
-Many of the miscops described in this sub-section can be coded in-line rather
-than as miscops.  In particular, all the predicates on basic types are coded
-in-line with default optimization settings in the compiler.  Currently, all of
-these predicates set the eq condition code bit to return an indication of
-whether the predicate is true or false.  This is so that the
-@value(DinkyMachine) branch instructions can be used directly without having to
-test for NIL.  However, this only works if the value of the predicate is needed
-for a branching decision.  In the cases where the value is actually needed, T
-or NIL is generated in-line according to whether the predicate is true or
-false.  At some point it might be worthwhile having two versions of these
-predicates, one which sets the eq condition code bit, and one which returns T
-or NIL.  This is especially true if space becomes an issue.
-
-@begin(Description)
-@index [Bit-Vector-P]
-Bit-Vector-P (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is
-a Common Lisp bit-vector or 0 if it is not.
-
-@index [Simple-Bit-Vector-P]
-Simple-Bit-Vector-P (@i[Object])@\sets the eq condition code bit to 1 if
-@i[Object] is a CMU Common Lisp bit-vector or 0 if it is not.
-
-@index [Simple-Integer-Vector-P]
-Simple-Integer-Vector-P (@i[Object])@\sets the eq condition code bit to 1
-if @i[Object] is a CMU Common Lisp I-Vector or 0 if it is not.
-
-@index [StringP]
-StringP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
-Common Lisp string or 0 if it is not.
-
-@index [Simple-String-P]
-Simple-String-P (@i[Object])@\sets the eq condition code bit to 1 if
-@i[Object] is a CMU Common Lisp string or 0 if it is not.
-
-@index [BignumP]
-BignumP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
-bignum or 0 if it is not.
-
-@index [Long-Float-P]
-Long-Float-P (@i[Object])@\sets the eq condition code bit to 1 if
-@i[Object] is a long-float or 0 if it is not.
-
-@index [ComplexP]
-ComplexP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
-complex number or 0 if it is not.
-
-@index [RatioP]
-RatioP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
-ratio or 0 if it is not.
-
-@index [IntegerP]
-IntegerP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
-fixnum or bignum or 0 if it is not.
-
-@index [RationalP]
-RationalP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
-fixnum, bignum, or ratio or 0 if it is not.
-
-@index [FloatP]
-FloatP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
-short-float or long-float or 0 if it is not.
-
-@index [NumberP]
-NumberP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
-number or 0 if it is not.
-
-@index [General-Vector-P]
-General-Vector-P (@i[Object])@\sets the eq condition code bit to 1 if
-@i[Object] is a Common Lisp general vector or 0 if it is not.
-
-@index [Simple-Vector-P]
-Simple-Vector-P (@i[Object])@\sets the eq condition code bit to 1 if @i[Object]
-is a CMU Common Lisp G-Vector or 0 if it is not.
-
-@index [Compiled-Function-P]
-Compiled-Function-P (@i[Object])@\sets the eq condition code bit to 1 if
-@i[Object] is a compiled function or 0 if it is not.
-
-@index [ArrayP]
-ArrayP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
-Common Lisp array or 0 if it is not.
-
-@index [VectorP]
-VectorP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
-Common Lisp vector of 0 if it is not.
-
-@index [Complex-Array-P]
-Complex-Array-P (@i[Object])@\sets the eq condition code bit to 1 if @i[Object]
-is a CMU Common Lisp array or 0 if it is not.
-
-@index [SymbolP]
-SymbolP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
-symbol or 0 if it is not.
-
-@index [ListP]
-ListP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a cons
-or NIL or 0 if it is not.
-
-@index [ConsP]
-ConsP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a cons
-or 0 if it is not.
-
-@index [FixnumP]
-FixnumP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
-fixnum or 0 if it is not.
-
-@index [Single-Float-P]
-Single-Float-P (@i[Object])@\sets the eq condition code bit to 1 if @i[Object]
-is a single-float or 0 if it is not.
-
-@index [CharacterP]
-CharacterP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is
-a character or 0 if it is not.
-@end(Description)
-
-@subsection [Arithmetic]
-@instrsection
-
-@begin(Description)
-@index [Integer-Length]
-Integer-Length (@i[Object])@\returns the integer-length (as defined in the
-Common Lisp manual) of the integer @i[Object].
-
-@index [Logcount]
-Logcount (@i[Object])@\returns the number of 1's if @i[object] is a
-positive integer, the number of 0's if @i[object] is a negative integer,
-and signals an error otherwise.
-
-@index [Float-Short]
-Float-Short (@i[Object])@\returns a short-float corresponding to the number
-@i[Object].
-
-@index [Float-Long]
-Float-Long (@i[Number])@\returns a long float formed by coercing @i[Number] to
-a long float.  This corresponds to the Common Lisp function Float when given a
-long float as its second argument.
-
-@index [Realpart]
-Realpart (@i[Number])@\returns the realpart of the @i[Number].
-
-@index [Imagpart]
-Imagpart (@i[Number])@\returns the imagpart of the @i[Number].
-
-@index [Numerator]
-Numerator (@i[Number])@\returns the numerator of the rational @i[Number].
-
-@index [Denominator]
-Denominator (@i[Number])@\returns the denominator of the rational @i[Number].
-
-@index [Decode-Float]
-Decode-Float (@i[Number])@\performs the Common Lisp Decode-Float function,
-returning 3 values.
-
-@index [Scale-Float]
-Scale-Float (@i[Number X])@\performs the Common Lisp Scale-Float function,
-returning the result.
-
-@index[=]
-= (@i[X Y])@\sets the condition codes according to whether @i[X] is equal
-to @i[Y].  Both @i[X] and @i[Y] must be numbers, otherwise an error is
-signalled.  If a rational is compared with a flonum, the rational is
-converted to a flonum of the same type first.  If a short flonum is compared
-with a long flonum, the short flonum is converted to a long flonum.
-Flonums must be exactly equal (after conversion) for the condition codes to
-be set to equality.  This miscop also deals with complex numbers.
-
-@index [Compare]
-Compare (@i[X Y])@\sets the condition codes according to
-whether @i[X] is less than, equal to, or greater than @i[Y].  @i[X]
-and @i[Y] must be numbers.  Conversions as described in = above are done
-as necessary.  This miscop replaces the < and > instructions on the Perq,
-so that the branch on condition instructions can be used more
-effectively.  The value of < and > as defined for the Perq are
-only generated if necessary, i.e., the result is saved.  If @i[X] or @i[Y]
-is a complex number, an error is signalled.
-
-@index [Truncate]
-Truncate (@i[N X])@\performs the Common Lisp TRUNCATE operation.  There are 3
-cases depending on @i[X]:
-@Begin[Itemize]
-If @i[X] is fixnum 1, return two items: a fixnum or bignum
-representing the integer part of @i[N] (rounded toward 0), then either 0 if
-@i[N] was already an integer or the fractional part of @i[N] represented as a
-flonum or ratio with the same type as @i[N].
-
-If @i[X] and @i[N] are both fixnums or bignums and @i[X] is not 1, divide
-@i[N] by @i[X].  Return two items: the integer quotient (a fixnum or
-bignum) and the integer remainder.
-
-If either @i[X] or @i[N] is a flonum or ratio, return a fixnum or bignum
-quotient (the true quotient rounded toward 0), then a flonum or ratio
-remainder.  The type of the remainder is determined by the same type-coercion
-rules as for +.  The value of the remainder is equal to @i[N] - @i[X] *
-@i[Quotient].
-@End[Itemize]
-On the @value(DinkyMachine), the integer part is returned in register A0, and
-the remainder in A1.
-
-@index [+]
-@index [-]
-@index [*]
-@index [/]
-+, -, *, / (@i[N X])@\returns  @i[N] + @i[X].  -, *, and / are similar.
-
-@index [Fixnum*Fixnum]
-@index [Fixnum/Fixnum]
-Fixnum*Fixnum, Fixnum/Fixnum (@i[N X])@\returns @i[N] * @i[X], where
-both @i[N] and @i[X] are fixnums.  Fixnum/ is similar.
-
-@index [1+]
-1+ (@i[E])@\returns @i[E] + 1.
-
-@index [1-]
-1- (@i[E])@\returns @i[E] - 1.
-
-@index [Negate]
-Negate (@i[N])@\returns -@i[N].
-
-@index [Abs]
-Abs (@i[N])@\returns |@i[N]|.
-
-@index [GCD]
-GCD (@i[N X])@\returns the greatest common divisor of the integers @i[N] and @i[X].
-
-@index [Logand]
-@index [Logior]
-@index [Logxor]
-Logand (@i[N X])@\returns the bitwise and of the integers @i[N] and @i[X].
-Logior and Logxor are analogous.
-
-@index [Lognot]
-Lognot (@i[N])@\returns the bitwise complement of @i[N].
-
-@index [Boole]
-@label [Boole-Section]
-Boole (@i[Op X Y])@\performs the Common Lisp Boole operation @i[Op] on @i[X],
-and @i[Y].  The Boole constants for CMU Common Lisp are these:
-@begin [verbatim, group]
-	boole-clr	0
-	boole-set	1
-	boole-1 	2
-	boole-2 	3
-	boole-c1	4
-	boole-c2	5
-	boole-and	6
-	boole-ior	7
-	boole-xor	8
-	boole-eqv	9
-	boole-nand	10
-	boole-nor	11
-	boole-andc1	12
-	boole-andc2	13
-	boole-orc1	14
-	boole-orc2	15
-@end [verbatim]
-
-@index [Ash]
-Ash (@i[N X])@\performs the Common Lisp ASH operation on @i[N] and @i[X].
-
-@index [Ldb]
-Ldb (@i[S P N])@\All args are integers; @i[S] and @i[P] are non-negative.
-Performs the Common Lisp LDB operation with @i[S] and @i[P] being the size and
-position of the byte specifier.
-
-@index [Mask-Field]
-Mask-Field (@i[S P N])@\performs the Common Lisp Mask-Field operation with
-@i[S] and @i[P] being the size and position of the byte specifier.
-
-@index [Dpb]
-Dpb (@i[V S P N])@\performs the Common Lisp DPB operation with @i[S] and @i[P]
-being the size and position of the byte specifier.
-
-@index [Deposit-Field]
-Deposit-Field (@i[V S P N])@\performs the Common Lisp Deposit-Field operation
-with @i[S] and @i[P] as the size and position of the byte specifier.
-
-@index [Lsh]
-Lsh (@i[N X])@\returns a fixnum that is @i[N] shifted left by @i[X] bits, with
-0's shifted in on the right.  If @i[X] is negative, @i[N] is shifted to the
-right with 0's coming in on the left.  Both @i[N] and @i[X] should be fixnums.
-
-@index [Logldb]
-Logldb (@i[S P N])@\All args are fixnums.  @i[S] and @i[P] specify a ``byte''
-or bit-field of any length within @i[N].  This is extracted and is returned
-right-justified as a fixnum.  @i[S] is the length of the field in bits; @i[P]
-is the number of bits from the right of @i[N] to the beginning of the
-specified field.  @i[P] = 0 means that the field starts at bit 0 of @i[N], and
-so on.	It is an error if the specified field is not entirely within the 26
-bits of @i[N]
-
-@index [Logdpb]
-Logdpb (@i[V S P N])@\All args are fixnums.  Returns a number equal to @i[N],
-but with the field specified by @i[P] and @i[S] replaced by the @i[S] low-order
-bits of @i[V].	It is an error if the field does not fit into the 26 bits of
-@i[N].
-
-@index[Sin]@index[Cos]@index[Tan]@index[Atan]
-Sin(@i[X]), Cos(@i[X]), Tan(@i[X]), and Atan(@i[X])@\accept a single number
-@i[X] as argument and return the sine, cosine, tangent, and arctangent of
-the number respectively.  These miscops take advantage of the hardware
-support provided on the IBM RT PC if it is available, otherwise they escape
-to Lisp code to calculate the appropriate result.
-
-@index[Log]
-Log(@i[X])@\returns the natural log of the number @i[X].  This miscop uses
-the hardware operation if it is available, otherwise it escapes to Lisp
-code to calculate the result.
-
-@index[Exp]
-Exp(@i[X])@\returns e raised to the power @i[X].  This miscop uses the
-hardware operation if it is available, otherwise it escapes to Lisp code to
-calculate the result.
-
-@index[Sqrt]
-Sqrt(@i[X])@\returns the square root of @i[X].  This miscop uses the
-hardware operation if it is available, otherwise it escapes to Lisp code to
-calculate the result.
-@end(Description)
-
-@subsection [Branching]
-All branching is done with @value(DinkyMachine) branch instructions.
-Instructions are generated to set the condition code bits appropriately, and
-a branch which tests the appropriate condition code bit is generated.
-
-@subsection [Function Call and Return]
-@instrsection
-
-@begin(Description)
-@index [Call]
-Call()@\A call frame for a function is opened.	This is explained in
-more detail in the next chapter.
-
-@index [Call-0]
-Call-0 (@i[F])@\@i[F] must be an executable function, but is a
-function of 0 arguments.  Thus, there is no need to collect arguments.	The
-call frame is opened and activated in a single miscop.
-
-@index [Call-Multiple]
-Call-Multiple ()@\Just like a Call miscop, but it marks the frame
-to indicate that multiple values will be accepted.  See
-section @ref[Multi].
-
-@index[Set-Up-Apply-Args]
-Set-Up-Apply-Args ()@\is called to handle the last argument of a
-function called by apply.  All the other arguments will have been
-properly set up by this time.  Set-up-apply-args places the values of
-the list passed as the last argument to apply in their proper
-locations, whether they belong in argument registers or on the stack.
-It updates the NArgs register with the actual count of the arguments
-being passed to the function.  When Set-up-apply-args returns, all the
-arguments to the function being applied are in their correct
-locations, and the function can be invoked normally.
-
-@index[Start-Call-Interpreter]
-Start-Call-Interpreter (@i[NArgs])@\is called from the interpreter to
-start a function call.  It accepts the number of arguments that are
-pushed on the stack in register A0.  Just below the arguments is the
-function to call; just below the function is the area to store the
-preserved registers.  This miscop sets up the argument registers
-correctly, moves any other arguments down on the stack to their
-proper place, and invokes the function.
-
-@index[Invoke1]
-Invoke1 (@i[Function] @i[Argument])@\is similar to Start-Call-Interpreter,
-but is simpler, since the @i[Function] is being called with only a
-single @i[Argument].
-
-@index[Invoke1*]
-Invoke1* (@i[Function] @i[Argument])@\is similar to Invoke1, but the
-@i[Function] being called is called for one value, rather than multiple ones.
-
-@index [Start-call-mc]
-Start-call-mc ()@\is called when the compiler generates code for the
-form multiple-value-call.  Register A0 contains the function to be
-called, A1 contains a 0 if the call if for a single value, and 1
-otherwise, NArgs contains the number of arguments that are stored on
-the stack.  The argument registers are set up correctly, and the
-excess values moved down on the stack if necessary.  Finally, the
-function is actually invoked.
-
-@index [Push-Last]
-Push-Last ()@\closes the currently open call frame, and initiates a function
-call.
-
-@index [Return]
-Return (@i[X])@\Return from the current function call.	After the current
-frame is popped off the stack, @i[X] is returned in register A0 as the result
-Being returned. See section @ref[Return] for more details.
-
-@index [Return-From]
-Return-From (@i[X] @i[F])@\is similar to Return, except it accepts the frame
-to return from as an additional argument.
-
-@index [Return-1-Value-Any-Bind]
-Return-1-Value-Any-Bind (@i[X])@\is similar to return, except only
-one value is returned.  Any number of bindings are undone during the
-return operation.
-
-@index [Return-Mult-Value-0-Bind]
-Return-Mult-Value-0-Bind (@i[X])@\is similar to return, except multiple values
-may be returned, but the binding stack does not have to be popped.
-
-@index [Link-Address-Fixup]
-Link-Address-Fixup (@i[Symbol NArgs Code-Vector Offset])@\finds the
-correct link table entry for @i[Symbol] with @i[NArgs] (@i[NArgs]
-specifies the fixed number of arguments and a flag if more may be
-passed).  It smashes the @i[Code-Vector] at @i[Offset] to generate
-code to point at the absolute address of the link table entry.
-
-@index [Miscop-Fixup]
-Miscop-Fixup (@i[Code-Vector Offset Index])@\smashes @i[Code-Vector] at
-@i[Offset] with the correct value for the miscop specified by @i[Index] in a
-transfer vector of all the miscops.
-
-@index [Make-Compiled-Closure]
-Make-Compiled-Closure (@i[env fcn offset])@\returns a new function object
-that is a copy of the function object @i[fcn] which has the @i[env]
-information stored at @i[offset].  Compiled lexical closures are now
-represented as real function objects rather than as lists.  This miscop is
-necessary to support this change.
-
-@index [Reset-link-table]
-Reset-link-table (@i[function])@\resets all the link table entries for
-@i[function] to the default action.  This is necessary because Portable
-Commonloops updates generic function objects by copying new information
-into the function object.  The link table must be updated to reflect this
-or the wrong function will be called.
-
-@index[Interrupt-Handler]
-@begin[Multiple]
-Interrupt-Handler (@i[Signal Code Signal-Context])@\gets the first
-indication that a Unix signal has occurred.  This miscop does not follow
-the normal Lisp calling conventions at all.  Instead it follows the
-standard IBM RT PC calling conventions for C or other algorithmic
-languages.  On entry the registers are as follows:
-@begin(Description)
-R0@\Pointer to C data area for Interrupt-Handler.  Currently this data area
-only holds a pointer to the entry point for Interrupt-Handler and nothing
-else.
-
-R1@\Pointer to a C stack that contains information about the signal.
-
-R2@\Contains the @i[Signal] number that caused the interrupt to happen.
-
-R3@\Contains the @i[Code] that further specifies what caused the interrupt
-(if necessary).
-
-R4@\Contains a pointer to the @i[signal-context] which contains
-information about where the interrupt occurred, the saved registers, etc.
-
-R5-R14@\Contain unknown values.
-
-R15@\is the return PC which will return from the interrupt handler and
-restart the computation.
-@end(Description)
-Interrupt-Handler determines whether it is safe to take the interrupt now,
-i.e., it is executing in Lisp code, C code,  or an interruptible miscop.  An
-interruptible miscop is one that has been specially written to make sure
-that it is safe to interrupt it at any point and is possible that it will
-never return of its own accord (e.g., length which could be passed a
-circular list, some of the system call miscops, etc.).  If it is safe to
-take the interrupt, the signal-context is modified so that control will
-transfer to the miscop interrupt-routine when the interrupt-handler returns
-normally (i.e., after the kernel has done the necessary bookkeeping).  If
-it is unsafe to take the interrupt (i.e., it is executing in an
-non-interruptible miscop), then the return PC of the miscop is modified to
-be interrupt-routine and interrupt-handler returns to the kernel.  In
-either case interrupts are disabled and information is stored in a global
-Lisp data area, so that the interrupt-routine miscop can retrieve the
-important information about the interrupt.
-@end[Multiple]
-
-Interrupt-Routine ()@\gets control when it is safe to take an interrupt.
-It saves the current state of the computation on the appropriate stack (on
-the C stack if it was executing in C or on the Lisp stack if in Lisp)
-including all the registers, some control information specifying whether
-the computation was in C code, Lisp code, whether it should form a PC in
-register R15.  When a PC has to be formed in R15, R14 will contain a pointer
-to the active function and R15 will contain an index into the code vector
-associated with the active function.  Reforming the PC is necessary so
-it is possible to restart a computation even after a garbage collection
-may have moved the function.  Once this information is stored,
-interrupt-routine invokes the Lisp function %sp-software-interrupt-routine
-which moves the processing of the interrupt to Lisp code.
-
-@index [Break-Return]
-Break-Return (@i[])@\returns from a function called by the
-interrupt-routine miscop.  The only function that should ever do this is
-%sp-software-interrupt-routine.  This miscop expects the stack to be in a
-format that is generated during an interrupt and should not be used for
-anything else.
-
-@index [Catch]
-Catch (@i[Tag PC])@\builds a catch frame.  @i[Tag] is the tag caught by this
-catch frame, @i[PC] is a saved-format PC (i.e., an index into the current code
-vector).  See section @ref[Catch] for details.
-
-@index [Catch-Multiple]
-Catch-Multiple (@i[Tag PC])@\builds a multiple-value catch frame.  @i[Tag] is
-the tag caught by this catch frame, and @i[PC] is a saved-format PC.  See
-section @ref[Catch] for details.
-
-@index [Catch-All]
-Catch-All (@i[PC])@\builds a catch frame whose tag is the special Catch-All
-object.  @i[PC] is the saved-format PC, which is the address to branch to if
-this frame is thrown through.  See section @ref[Catch] for details.
-
-@index [Throw]
-Throw (@i[X Tag])@\@i[Tag] is the throw-tag, normally a symbol.  @i[X] is the
-value to be returned.  See section @ref[Catch] for a description of how this
-miscop works.
-
-@index[Rest-Entry-0]@index[Rest-Entry-1]@index[Rest-Entry-2]@index[Rest-Entry]
-Rest-Entry-0, Rest-Entry-1, Rest-Entry-2, Rest-Entry@\are miscops
-that do the processing for a function at its &rest entry point.
-Rest-Entry-@i[i] are miscops that are invoked by functions that have
-0, 1, or 2 arguments before the &rest argument.  Rest-entry is
-invoked for all other cases, and is passed an additional argument in
-A3 which is the number of non-&rest arguments.  These miscops form
-the &rest arg list and set up all the registers to have the
-appropriate values.  In particular, the non-&rest arguments are copied
-into preserved registers, and the &rest arg list is built and stored
-in the appropriate preserved register or on the stack as appropriate.
-
-@index[Call-Foreign]
-Call-Foreign (@i[C-Function Arguments NArgs])@\establishes the C
-environment so that C code can be called correctly.  @i[C-Function] is a
-pointer to the data area for a C function, the first word of which is a
-pointer to the entry point of the C function.  @i[Arguments] is a block of
-storage that contains the @i[NArgs] arguments to be passed to the C
-function.  The first four of these arguments are passed in registers R2
-through R5 respectively, the rest are moved onto the C stack in the proper
-location.  When the C function returns, Call-Foreign restores the Lisp
-environment and returns as its value the integer in R2.
-
-@index[Call-Lisp]
-Call-Lisp (@i[Arg@-<1> ... Arg@-<2>])@\is a Lisp miscop that gets control
-when a C function needs to call a Lisp function.  Lisp provides a mechanism
-for setting up an object that looks like a C procedure pointer.  The code
-pointer in this object always points at Call-Lisp.  Additional data in this
-procedure pointer is the Lisp function to call and the number of arguments
-that it should be called with.  Call-Lisp restores the Lisp environment,
-saves the state of the C computation, moves the C arguments into the
-correct places for a call to a Lisp function and then invokes the special
-Lisp function call-lisp-from-c.  This Lisp function actually invokes the
-correct Lisp function.  Call-Lisp never regains control.
-
-@index[Return-To-C]
-Return-To-C (@i[C-Stack-Pointer Value])@\is used in the
-function call-lisp-from-c to return control to C from a Lisp function
-called by C.  @i[C-Stack-Pointer] is the C stack pointer when the call-lisp
-miscop got control.  The C stack pointer argument is used to restore the C
-environment to what it was at the time the call to Lisp was made.
-@i[Value] is the value returned from Lisp and is passed back to C in
-register R2.  Currently, it is not possible to return other than a single
-32 bit quantity.
-
-@index[Reset-C-Stack]
-Reset-C-Stack ()@\is invoked when a Lisp function called by C throws out
-past where it should return to C.  Reset-C-Stack restores the C stack to
-what it was before the original call to C happened.  This is so that in the
-future, the C stack will not contain any garbage that should not be there.
-
-@index[Set-C-Procedure-Pointer]
-Set-C-Procedure-Pointer (@i[Sap] @i[I] @I[Proc])@\sets the @i[I/2]'th
-element of @i[sap] to be the data part of the statically allocated g-vector
-@i[Proc].  This is used to set up a C procedure argument in the argument
-block that is passed to call-foreign.
-
-@end(Description)
-
-@subsection [Miscellaneous]
-@instrsection
-
-@begin(Description)
-@index [Eq]
-Eq (@i[X Y])@\sets the eq condition code bit to 1 if @i[X] and @i[Y] are the
-same object, 0 otherwise.
-
-@index [Eql]
-Eql (@i[X Y])@\sets the eq condition code bit to 1 if @i[X] and @i[Y] are the
-same object or if
-@i[X] and @i[Y] are numbers of the same type with the same value, 0 otherwise.
-
-@index [Make-Predicate]
-Make-Predicate (@i[X])@\returns NIL if @i[X] is NIL or T if it is not.
-
-@index [Not-Predicate]
-Not-Predicate (@i[X])@\returns T if @i[X] is NIL or NIL if it is not.
-
-@index [Values-To-N]
-Values-To-N (@i[V])@\@i[V] must be a Values-Marker.  Returns the number
-of values indicated in the low 24 bits of @i[V] as a fixnum.
-
-@index [N-To-Values]
-N-To-Values (@i[N])@\@i[N] is a fixnum.  Returns a Values-Marker with the
-same low-order 24 bits as @i[N].
-
-@index [Force-Values]
-Force-Values (@i[VM])@\If the @i[VM] is a Values-Marker, do
-nothing; if not, push @i[VM] and return a Values-Marker 1.
-
-@index [Flush-Values]
-Flush-Values (@i[])@\is a no-op for the @value(DinkyMachine), since the only
-time that a Flush-Values miscop is generated is in some well-defined cases
-where all the values are wanted on the stack.
-@end(Description)
-
-@subsection [System Hacking]
-@label [System-Hacking-Instructions]
-@instrsection
-
-@begin(Description)
-@index [Get-Type]
-Get-Type (@i[Object])@\returns the five type bits of the @i[Object] as a
-fixnum.
-
-@index [Get-Space]
-Get-Space (@i[Object])@\returns the two space bits of @i[Object] as a
-fixnum.
-
-@index [Make-Immediate-Type]
-Make-Immediate-Type (@i[X A])@\returns an object whose type bits are the
-integer @i[A] and whose other bits come from the immediate object or pointer
-@i[X].	@i[A] should be an immediate type code.
-
-@index [8bit-System-Ref]
-8bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer, returns
-the @i[I]'th byte of @i[X], indexing into @i[X] directly.  @i[I]
-must be a fixnum.
-
-@index [8bit-System-Set]
-8bit-System-Set (@i[X I V])@\@i[X] must be a system area pointer, sets the
-@i[I]'th element of @i[X] to @i[V], indexing into @i[X] directly.
-
-@index [16bit-System-Ref]
-16bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer, returns the
-@i[I]'th 16-bit word of @i[X], indexing into @i[X] directly.
-
-@index [Signed-16bit-System-Ref]
-Signed-16bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer,
-returns the @i[I]'th 16-bit word of @i[X] extending the high order bit as
-the sign bit.
-
-@Index [16bit-System-Set]
-16bit-System-Set (@i[X I V])@\@i[X] must be a system area pointer, sets the
-@i[I]'th element of @i[X] to @i[V], indexing into @i[X] directly.
-
-@Index [Signed-32bit-System-Ref]
-Signed-32bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer and
-@i[I] an even fixnum, returns the @i[I]/2'th 32 bit word as a signed
-quantity.
-
-@Index [Unsigned-32bit-System-Ref]
-Unsigned-32bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer and
-@i[I] an even fixnum, returns the @i[I]/2'th 32 bit word as an unsigned
-quantity.
-
-@Index [Signed-32bit-System-Set]
-Signed-32bit-System-Set (@i[X I V])@\@i[X] must be a system area pointer,
-@i[I] an even fixnum, and @i[V] an integer, sets the @i[I]/2'th element of
-@i[X] to @i[V].
-
-@index[Sap-System-Ref]
-Sap-System-Ref (@i[X I])@\@i[X] must be a system area pointer and @i[I] and
-even fixnum, returns the @i[I]/2'th element of @i[X] as a system area
-pointer.
-
-@index[Sap-System-Set]
-Sap-System-Set (@i[X I V])@\@i[X] and @i[V] must be a system area pointers
-and @i[I] an even fixnum, sets the @i[I]/2'th element of @i[X] to @i[V].
-
-@index[Pointer-System-Set]
-Pointer-System-Set (@i[X I])@\@i[X] must be a system area pointer, @i[I] an
-even fixnum, and @i[V] a pointer (either system area pointer or Lisp
-pointer), sets the @i[I]/2'th element of @i[X] to the pointer @i[V].  If
-the pointer is a Lisp pointer, the pointer stored is to the first word of
-data (i.e., the header word(s) are bypassed).
-
-@index[Sap-Int]
-Sap-Int (@i[X])@\@i[X] should be a system area pointer, returns a Lisp
-integer containing the system area pointer.  This miscop is useful when it
-is necessary to do arithmetic on system area pointers.
-
-@index[Int-Sap]
-Int-Sap (@i[X])@\@i[X] should be an integer (fixnum or bignum), returns a
-system area pointer.  This miscop performs the inverse operation of sap-int.
-
-@index[Check-<=]
-Check-<= (@i[X] @i[Y])@\checks to make sure that @i[X] is less than or
-equal to @i[Y].  If not, then check-<= signals an error, otherwise it just
-returns.
-
-@index [Collect-Garbage]
-Collect-Garbage (@i[])@\causes a stop-and-copy GC to be performed.
-
-@index [Purify]
-Purify (@i[])@\is similar to collect-garbage, except it copies Lisp objects
-into static or read-only space.  This miscop needs Lisp level code to get
-the process started by putting some root structures into the correct space.
-
-@index [Newspace-Bit]
-Newspace-Bit (@i[])@\returns 0 if newspace is currently space 0 or 1 if it is
-1.
-
-@index [Save]
-Save (@i[*current-alien-free-pointer*] @i[Checksum] @I[memory])@\Save takes
-a snap short of the current state of the Lisp computation.  The value of
-the symbol *Current-alien-free-pointer* must be passed to save, so that it
-can save the static alien data structures.  The parameter @i[checksum]
-specifies whether a checksum should be generated for the saved image.
-Currently, this parameter is ignored and no checksum is generated.  The
-parameter @i[memory] should be be a pointer to a block of memory where the
-saved core image will be stored.  Save returns the size of the core image
-generated.
-
-@index [Syscall0]
-@index [Syscall1]
-@index [Syscall2]
-@index [Syscall3]
-@index [Syscall4]
-@index [Syscall]
-Syscall0 Syscall1 Syscall2 Syscall3 Syscall4 Syscall (@i[number]
-@i[arg@-<1> ... arg@-<n>])@\is for making syscalls to the Mach kernel.  The
-argument @i[number] should be the number of the syscall.  Syscall0 accepts
-no arguments to the syscall; syscall1 accepts one argument to the syscall,
-etc.  Syscall accepts five or more arguments to the syscall.
-
-@index[Unix-write]
-Unix-Write (@i[fd buffer offset length])@\performs a Unix write syscall to
-the file descriptor @i[fd].  @i[Buffer] should contain the data to be
-written;  @i[Offset] should be an offset into buffer from which to start
-writing; and @i[length] is the number of bytes of data to write.
-
-@index[Unix-fork]
-Unix-Fork ()@\performs a Unix fork operation returning one or two values.
-If an error occurred, the value -1 and the error code is returned.  If no
-error occurred, 0 is returned in the new process and the process id of the
-child process is returned in the parent process.
-
-@index [Arg-In-Frame] Arg-In-Frame (@i[N F])@\@i[N] is a fixnum, @i[F] is a
-control stack pointer as returned by the Active-Call-Frame miscop.  It
-returns the item in slot @i[N] of the args-and-locals area of call frame
-@i[F].
-
-@index [Active-Call-Frame]
-Active-Call-Frame (@i[])@\returns a control-stack pointer to the start of the
-currently active call frame.  This will be of type Control-Stack-Pointer.
-
-@index [Active-Catch-Frame]
-Active-Catch-Frame (@i[])@\returns the control-stack pointer to the start of
-the currently active catch frame.  This is Nil if there is no active catch.
-
-@index [Set-Call-Frame]
-Set-Call-Frame (@i[P])@\@i[P] must be a control stack pointer.	This becomes
-the current active call frame pointer.
-
-@index [Current-Stack-Pointer]
-Current-Stack-Pointer (@i[])@\returns the Control-Stack-Pointer that points
-to the current top of the stack (before the result of this operation is
-pushed).  Note: by definition, this points to the
-to the last thing pushed.
-
-@index [Current-Binding-Pointer]
-Current-Binding-Pointer (@i[])@\returns a Binding-Stack-Pointer that points
-to the first word above the current top of the binding stack.
-
-@index [Read-Control-Stack]
-Read-Control-Stack (@i[F])@\@i[F] must be a control stack pointer.  Returns
-the Lisp object that resides at this location.	If the addressed object is
-totally outside the current stack, this is an error.
-
-@index [Write-Control-Stack]
-Write-Control-Stack (@i[F V])@\@i[F] is a stack pointer, @i[V] is any Lisp
-object.  Writes @i[V] into the location addressed.  If the addressed cell is
-totally outside the current stack, this is an error.  Obviously, this should
-only be used by carefully written and debugged system code, since you can
-destroy the world by using this miscop.
-
-@index [Read-Binding-Stack]
-Read-Binding-Stack (@i[B])@\@i[B] must be a binding stack pointer.  Reads and
-returns the Lisp object at this location.  An error if the location specified
-is outside the current binding stack.
-
-@index [Write-Binding-Stack]
-Write-Binding-Stack (@i[B V])@\@i[B] must be a binding stack pointer.  Writes
-@i[V] into the specified location.  An error if the location specified is
-outside the current binding stack.
-@end(Description)
-
-@chapter [Control Conventions]
-@label [Control-Conventions]
-@index [Hairy stuff]
-
-@section [Function Calls]
-@index [Call]
-@index [Call-0]
-@index [Call-Multiple]
-
-On the Perq function calling is done by micro-coded instructions.  The
-instructions perform a large number of operations, including determining
-whether the function being called is compiled or interpreted, determining that
-a legal number of arguments are passed, and branching to the correct entry
-point in the function.  To do all this on the @value(DinkyMachine) would
-involve a large amount of computation.	In the general case, it is necessary to
-do all this, but in some common cases, it is possible to short circuit most of
-this work.
-
-To perform a function call in the general case, the following steps occur:
-@begin(Enumerate)
-
-Allocate space on the control stack for the fix-sized part of a call
-frame.  This space will be used to store all the registers that must
-be preserved across a function call.
-
-Arguments to the function are now evaluated.  The first three
-arguments are stored in the argument registers A0, A1, and A2.  The
-rest of the arguments are stored on the stack as they are evaluated.
-Note that during the evaluation of arguments, the argument registers
-may be used and may have to be stored in local variables and restored
-just before the called function is invoked.
-
-Load R0 with the argument count.
-
-Load the PC register with the offset into the current code vector of
-the place to return to when the function call is complete.
-
-If this call is for multiple values, mark the frame as accepting
-multiple values, by making the fixnum offset above negative by oring
-in the negative fixnum type code.
-
-Store all the registers that must be preserved over the function call in the
-current frame.
-@end(Enumerate)
-
-At this point, all the arguments are set up and all the registers have been
-saved.	All the code to this point is done inline.  If the object being called
-as a function is a symbol, we get the definition from the definition cell of
-the symbol.  If this definition is the trap object, an undefined symbol error
-is generated.  The function calling mechanism diverges at this point depending
-on the type of function being called, i.e., whether it is a compiled function
-object or a list.
-
-If we have a compiled function object, the following steps are performed (this
-code is out of line):
-@begin(Enumerate)
-Load the active function register with a pointer to the compiled function
-object.
-
-The active frame register is set to the start of the current frame.
-
-Note the number of arguments evaluated.  Let this be K.  The correct
-entry point in the called function's code vector must be computed as
-a function of K and the number of arguments the called function
-wants:
-@begin(Enumerate, spread 0, spacing 1)
-If K < minimum number of arguments, signal an error.
-
-If K > maximum number of arguments and there is no &rest argument,
-signal an error.
-
-If K > maximum number of arguments and there is a &rest argument,
-start at offset 0 in the code vector.  This entry point must collect
-the excess arguments into a list and leave the &rest argument in the
-appropriate argument register or on the stack as appropriate.
-
-If K is between the minimum and maximum arguments (inclusive), get
-the starting offset from the appropriate slot of the called
-function's function object.  This is stored as a fixnum in slot K -
-MIN + 6 of the function object.
-@end(Enumerate)
-
-Load one of the Non-Lisp temporary registers with the address of the
-code vector and add in the offset calculated above.  Then do a branch
-register instruction with this register as the operand.  The called
-function is now executing at the appropriate place.
-@end(enumerate)
-
-If the function being called is a list, %SP-Internal-Apply must be called to
-interpret the function with the given arguments.  Proceed as follows:
-@begin(Enumerate)
-Note the number of arguments evaluated for the current open frame (call this N)
-and the frame pointer for the frame (call it F).  Also remember the lambda
-expression in this frame (call it L).
-
-Load the active function register with the list L.
-
-Load the PC register with 0.
-
-Allocate a frame on the control stack for the call to %SP-Internal-Apply.
-
-Move the contents of the argument registers into the local registers L0, L1,
-and L2 respectively.
-
-Store all the preserved registers in the frame.
-
-Place N, F, and L into argument registers A0, A1, and A2 respectively.
-
-Do the equivalent of a start call on %SP-Internal-Apply.
-@end(Enumerate) %SP-Internal-Apply, a function of three arguments,
-now evaluates the call to the lambda-expression or interpreted
-lexical closure L, obtaining the arguments from the frame pointed to
-by F.  The first three arguments must be obtained from the frame that
-%SP-Internal-Apply runs in, since they are stored in its stack frame
-and not on the stack as the rest of the arguments are. Prior to
-returning %SP-Internal-Apply sets the Active-Frame register to F, so
-that it returns from frame F.
-
-The above is the default calling mechanism.  However, much of the
-overhead can be reduced.  Most of the overhead is incurred by having
-to check the legality of the function call everytime the function is
-called.  In many situations where the function being called is a
-symbol, this checking can be done only once per call site by
-introducing a data structure called a link table.  The one exception
-to this rule is when the function apply is used with a symbol.  In
-this situation, the argument count checks are still necessary, but
-checking for whether the function is a list or compiled function
-object can be bypassed.
-
-The link table is a hash table whose key is based on the name of the
-function, the number of arguments supplied to the call and a flag
-specifying whether the call is done through apply or not.  Each entry
-of the link table consists of two words:
-@begin(Enumerate)
-The address of the function object associated with the symbol being
-called.  This is here, so that double indirection is not needed to
-access the function object which must be loaded into the active
-function register.  Initially, the symbol is stored in this slot.
-
-The address of the instruction in the function being called to start
-executing when this table entry is used.  Initially, this points to
-an out of line routine that checks the legality of the call and
-calculates the correct place to jump to in the called function.  This
-out of line routine replaces the contents of this word with the
-correct address it calculated.  In the case when the call is caused
-by apply, this will often be an out of line routine that checks the
-argument count and calculates where to jump.  In the case where the
-called function accepts &rest arguments and the minimum number of
-arguments passed is guaranteed to be greater than the maximum number
-of arguments, then a direct branch to the &rest arg entry point is
-made.
-@end(Enumerate)
-
-When a compiled file is loaded into the lisp environment, all the
-entries for the newly loaded functions will be set to an out of line
-routine mentioned above.  Also, during a garbage collection the
-entries in this table must be updated when a function object for a
-symbol is moved.
-
-The @value(DinkyMachine) code to perform a function call using the link table
-becomes:
-@begin(Example)
-	cal	CS,CS,%Frame-Size	; Alloc. space on control st.
-
-	<Code to evaluate arguments to the function>
-
-	cau	NL1,0,high-half-word(lte(function nargs flag))
-	oil	NL1,0,low-half-word(lte(function nargs flag))
-	cal	PC,0,return-tag 	; Offset into code vector.
-       <oiu	PC,PC,#xF800		; Mark if call-multiple frame>
-	stm	L0,CS,-(%Frame-Size-4)	; Save preserved regs.
-	lm	AF,NL1,0 		; Link table entry contents.
-	bnbrx	pz,R15			; Branch to called routine.
-	cal	FP,CS,-(%Frame-Size-4)	; Get pointer to frame.
-return-tag:
-@end(Example)
-The first two instructions after the arguments are evaled get the
-address of the link table entry into a register.  The two 16-bit half
-word entries are filled in at load time.  The rest of the
-instructions should be fairly straight forward.
-
-@section(Returning from a Function Call)
-@label(Return)
-@index(Return)
-
-Returning from a function call on the Perq is done by a micro-coded
-instruction.  On the @value(DinkyMachine), return has to do the following:
-@begin(enumerate)
-Pop the binding stack back to the binding stack pointer stored in the frame
-we're returning from.  For each symbol/value pair popped of the binding stack,
-restore that value for the symbol.
-
-Save the current value of the frame pointer in a temporary registers.  This
-will be used to restore the control stack pointer at the end.
-
-Restore all the registers that are preserved across a function call.
-
-Get a pointer to the code vector for the function we're returning to.  This is
-retrieved from the code slot of what is now the active function.
-
-Make sure the relative PC (which is now in a register) is positive and add it
-to the code vector pointer above, giving the address of the instruction to
-return to.
-
-If the function is returning multiple values do a block transfer of all the
-return values down over the stack frame just released, i.e., the first return
-value should be stored where the temporarily saved frame pointer points to.
-In effect the return values can be pushed onto the stack using the saved frame
-pointer above as a stack pointer that is incremented everytime a value is
-pushed.   Register A0 can be examined to determine the number of values that
-must be transferred.
-
-Set the control stack register to the saved frame pointer above.  NB: it may
-have been updated if multiple values are being returned.
-
-Resume execution of the calling function.
-@end(enumerate)
-
-Again, it is not always necessary to use the general return code.  At compile
-time it is often possible to determine that no special symbols have to be
-unbound and/or only one value is being returned.  For example the code to
-perform a return when only one value is returned and it is unnecessary to
-unbind any special symbols is:
-@begin(Example)
-	cas	NL1,FP,0		; Save frame register.
-	lm	L0,FP,0			; Restore all preserved regs.
-	ls	A3,AF,%function-code	; Get pointer to code vector.
-	niuo	PC,PC,#x07FF		; Make relative PC positive.
-	cas	PC,A3,PC		; Get addr. of instruction
-	bnbrx	pz,PC			; to return to and do so while
-	cas	CS,NL1,0		; updating control stack reg.
-@end(Example)
-
-
-@subsection [Returning Multiple-Values]
-@label [Multi]
-@index [Multiple values]
-
-If the current frame can accept multiple values and a values marker is in
-register A0 indicating N values on top of the stack, it is necessary to copy
-the N return values down to the top of the control stack after the current
-frame is popped off.  Thus returning multiple values is similar to the
-above, but a block transfer is necessary to move the returned values down to
-the correct location on the control stack.
-
-In tail recursive situations, such as in the last form of a PROGN, one
-function, FOO, may want to call another function, BAR, and return ``whatever
-BAR returns.''  Call-Multiple is used in this case.  If BAR returns multiple
-values, they will all be passed to FOO.  If FOO's caller wants multiple values,
-the values will be returned.  If not, FOO's Return instruction will see that
-there are multiple values on the stack, but that multiple values will not be
-accepted by FOO's caller.  So Return will return only the first value.
-
-@section [Non-Local Exits]
-@label [Catch]
-@index [Catch]
-@index [Throw]
-@index [Catch-All object]
-@index [Unwind-Protect]
-@index [Non-Local Exits]
-
-The Catch and Unwind-Protect special forms are implemented using
-catch frames.  Unwind-Protect builds a catch frame whose tag is the
-Catch-All object.  The Catch miscop creates a catch frame for a
-given tag and PC to branch to in the current instruction.  The Throw
-miscop looks up the stack by following the chain of catch frames
-until it finds a frame with a matching tag or a frame with the
-Catch-All object as its tag.  If it finds a frame with a matching
-tag, that frame is ``returned from,'' and that function is resumed.
-If it finds a frame with the Catch-All object as its tag, that frame
-is ``returned from,'' and in addition, %SP-Internal-Throw-Tag is set
-to the tag being searched for.  So that interrupted cleanup forms
-behave correctly, %SP-Internal-Throw-Tag should be bound to the
-Catch-All object before the Catch-All frame is built.  The protected
-forms are then executed, and if %SP-Internal-Throw-Tag is not the
-Catch-All object, its value is thrown to.  Exactly what we do is
-this:
-@begin [enumerate]
-Put the contents of the Active-Catch register into a register, A.
-Put NIL into another register, B.
-
-If A is NIL, the tag we seek isn't on the stack.  Signal an
-Unseen-Throw-Tag error.
-
-Look at the tag for the catch frame in register A.  If it's the tag
-we're looking for, go to step 4.  If it's the Catch-All object and B
-is NIL, copy A to B.  Set A to the previous catch frame and go back
-to step 2.
-
-If B is non-NIL, we need to execute some cleanup forms.  Return into
-B's frame and bind %SP-Internal-Throw-Tag to the tag we're searching
-for.  When the cleanup forms are finished executing, they'll throw to
-this tag again.
-
-If B is NIL, return into this frame, pushing the return value (or
-BLTing the multiple values if this frame accepts multiple values and
-there are multiple values).
-@end [enumerate]
-
-If no form inside of a Catch results in a Throw, the catch frame
-needs to be removed from the stack before execution of the function
-containing the throw is resumed.  For now, the value produced by the
-forms inside the Catch form are thrown to the tag.  Some sort of
-specialized miscop could be used for this, but right now we'll
-just go with the throw.  The branch PC specified by a Catch
-miscop is part of the constants area of the function object,
-much like the function's entry points.
-
-@section [Escaping to Lisp code]
-@label [Escape]
-@index [Escape to Lisp code convention]
-
-Escaping to Lisp code is fairly straight forward.  If a miscop discovers that
-it needs to call a Lisp function, it creates a call frame on the control
-stack and sets it up so that the called function returns to the function that
-called the miscop.  This means it is impossible to return control to a miscop
-from a Lisp function.
-
-@section [Errors]
-@label [Errors]
-@index [Errors]
-
-When an error occurs during the execution of a miscop, a call
-to %SP-Internal-Error is performed.  This call is a break-type call,
-so if the error is proceeded (with a Break-Return instruction), no
-value will be returned.
-
-
-%SP-Internal-Error is passed a fixnum error code as its first
-argument.  The second argument is a fixnum offset into the current
-code vector that points to the location immediately following the
-instruction that encountered the trouble.  From this offset, the
-Lisp-level error handler can reconstruct the PC of the losing
-instruction, which is not readily available in the micro-machine.
-Following the offset, there may be 0 - 2 additional arguments that
-provide information of possible use to the error handler.  For
-example, an unbound-symbol error will pass the symbol in question as
-the third arg.
-
-The following error codes are currently defined.  Unless otherwise
-specified, only the error code and the code-vector offset are passed
-as arguments.
-
-@begin 
-[description]
-1  Object Not List@\The object is passed as the third argument.
-
-2  Object Not Symbol@\The object is passed as the third argument.
-
-3  Object Not Number@\The object is passed as the third argument.
-
-4  Object Not Integer@\The object is passed as the third argument.
-
-5  Object Not Ratio@\The object is passed as the third argument.
-
-6  Object Not Complex@\The object is passed as the third argument.
-
-7  Object Not Vector@\The object is passed as the third argument.
-
-8  Object Not Simple Vector@\The object is passed as the third argument.
-
-9  Illegal Function Object@\The object is passed as the third argument.
-
-10  Object Not Header@\The object (which is not an array or function header)
-is passed as the third argument.
-
-11  Object Not I-Vector@\The object is passed as the third argument.
-
-12  Object Not Simple Bit Vector@\The object is passed as the third argument.
-
-13  Object Not Simple String@\The object is passed as the third argument.
-
-14  Object Not Character@\The object is passed as the third argument.
-
-15  Object Not Control Stack Pointer@\The object is passed as the third
-argument.
-
-16  Object Not Binding Stack Pointer@\The object is passed as the third
-argument.
-
-17  Object Not Array@\The object is passed as the third argument.
-
-18  Object Not Non-negative Fixnum@\The object is passed as the third
-argument.
-
-19  Object Not System Area Pointer@\The object is passed as the third
-argument.
-
-20  Object Not System Pointer@\The object is passed as the third argument.
-
-21  Object Not Float@\The object is passed as the third argument.
-
-22  Object Not Rational@\The object is passed as the third argument.
-
-23  Object Not Non-Complex Number@\A complex number has been passed to
-the comparison routine for < or >.  The complex number is passed as the
-third argument.
-
-25  Unbound Symbol @\Attempted access to the special value of an unbound
-symbol.  Passes the symbol as the third argument to %Sp-Internal-Error.
-
-26  Undefined Symbol @\Attempted access to the definition cell of an undefined
-symbol.  Passes the symbol as the third argument to %Sp-Internal-Error.
-
-27 Altering NIL @\Attempt to bind or setq the special value of NIL.
-
-28 Altering T @\Attempt to bind or setq the special value of T.
-
-30 Illegal Vector Access Type @\The specified access type is returned as the
-third argument.
-
-31 Illegal Vector Size @\Attempt to allocate a vector with negative size or
-size too large for vectors of this type.  Passes the requested size as the
-third argument.
-
-32 Vector Index Out of Range @\The specified index is out of bounds for
-this vector.  The bad index is passed as the third argument.
-
-33 Illegal Vector Index@\The specified index is not a positive fixnum.  The
-bad index is passed as the third argument.
-
-34 Illegal Shrink Vector Value@\The specified value to shrink a vector to is
-not a positive fixnum.  The bad value is passed as the third argument.
-
-35 Not A Shrink@\The specified value is greater than the current size of the
-vector being shrunk.  The bad value is passed as the third argument.
-
-36  Illegal Data Vector@\The data vector of an array is illegal.  The bad
-vector is passed as the third value.
-
-37  Array has Too Few Indices@\An attempt has been made to access
-an array as a two or three dimensional array when it has fewer than two
-or three dimensions, respectively.
-
-38  Array has Too Many Indices@\An attempt has been made to access an array
-as a two or three dimensional array when it has more than two or three
-dimensions, respectively.
-
-40  Illegal Byte Specifier@\A bad byte specifier has been passed to one
-of the byte manipulation miscops.  The offending byte specifier is passed
-as the third argument.
-
-41  Illegal Position in Byte Specifier@\A bad position has been given in a
-byte specifier that has been passed to one of the byte manipulation
-miscops.  The offending byte specifier is passed as the third
-argument.
-
-42  Illegal Size in Byte Specifier@\A bad size has been given in a
-byte specifier that has been passed to one of the byte manipulation
-miscops.  The offending byte specifier is passed as the third
-argument.
-
-43  Illegal Shift Count@\A shift miscop has encountered non fixnum shift
-count.  The offending shift count is passed as the third argument.
-
-44  Illegal Boole Operation@\The operation code passed to the boole miscop
-is either not a fixnum or is out of range.  The operation code is passed as
-the third argument.
-
-50  Too Few Arguments@\Too few arguments have been passed to a function.  The
-number of arguments actually passed is passed as the third argument, and the
-function is passed as the fourth.
-
-51  Too Many Arguments@\Too many arguments have been passed to a function.
-The number of arguments actually passed is passed as the third argument, and
-the function is passed as the fourth.
-
-52  Last Apply Arg Not a List@\The last argument to a function being
-invoked by apply is not a list.  The last argument is passed as the third
-argument.
-
-53  Deleted Link Table Entry@\An attempt has been made to call a function
-through a link table entry which no longer exists.  This is a serious
-internal error and should never happen.
-
-55  Error Not <=@\The check-<= miscop will invoke this error if the condition
-is false.  The two arguments are passed as the third and fourth arguments
-to %SP-internal-error.
-
-60  Divide by 0@\An division operation has done a division by zero.  The
-two operands are passed as the third and fourth arguments.
-
-61  Unseen Throw Tag@\An attempt has been made to throw to a tag that is
-not in the current catch hierarchy.  The offending tag is passed as the
-third argument.
-
-62  Short Float Underflow@\A short float operation has resulted in
-underflow.  The two arguments to the operation are passed as the third
-and fourth arguments.
-
-63  Short Float Overflow@\A short float operation has resulted in
-overflow.  The two arguments to the operation are passed as the third
-and fourth arguments.
-
-64  Single Float Underflow@\A single float operation has resulted in
-underflow.  The two arguments to the operation are passed as the third
-and fourth arguments.
-
-65  Single Float Overflow@\A single float operation has resulted in
-overflow.  The two arguments to the operation are passed as the third
-and fourth arguments.
-
-66  Long Float Underflow@\A long float operation has resulted in
-underflow.  The two arguments to the operation are passed as the third
-and fourth arguments.
-
-67  Long Float Overflow@\A long float operation has resulted in
-overflow.  The two arguments to the operation are passed as the third
-and fourth arguments.
-
-68  Monadic Short Float Underflow@\A short float operation has resulted in
-underflow.  The argument to the operation is passed as the third argument.
-
-69  Monadic Short Float Overflow@\A short float operation has resulted in
-overflow.  The argument to the operation is passed as the third argument.
-
-70  Monadic Long Float Underflow@\A long float operation has resulted in
-underflow.  The argument to the operation is passed as the third argument.
-
-71  Monadic Long Float Overflow@\A long float operation has resulted in
-overflow.  The argument to the operation is passed as the third argument.
-@end [description]
-
-@section [Trapping to the Mach Kernel]
-@label [Trap]
-@index [Trapping to the kernel]
-@index [Kernel traps]
-
-Trapping to the Mach kernel is done through one of the syscall0, syscall1,
-syscall2, syscall3, syscall4, or syscall miscops.  The first argument to
-these miscops is the number of the Unix syscall that is to be invoked.  Any
-other arguments the syscall requires are passed in order after the first
-one.  Syscall0 accepts only the syscall number and no other arguments;
-syscall1 accepts the syscall number and a single argument to the syscall;
-etc.  Syscall accepts the syscall number and five or more arguments to the
-Unix syscall.  These syscalls generally return two values: the result twice
-if the syscall succeeded and a -1 and the Unix error code if the syscall
-failed.
-
-@section [Interrupts]
-@label [Interrupts]
-@index [Interrupts]
-
-An interface has been built to the general signal mechanism defined by the
-Unix operating system.  As mentioned in the section on function call and
-return miscops, several miscops are defined that support the lowest level
-interface to the Unix signal mechanism.  The manual @I[CMU Common Lisp
-User's Manual, Mach/IBM RT PC Edition] contains descriptions of functions
-that allow a user to set up interrupt handlers for any of the Unix signals
-from within Lisp.
-
-@appendix [Fasload File Format]
-@section [General]
-
-The purpose of Fasload files is to allow concise storage and rapid
-loading of Lisp data, particularly function definitions.  The intent
-is that loading a Fasload file has the same effect as loading the
-ASCII file from which the Fasload file was compiled, but accomplishes
-the tasks more efficiently.  One noticeable difference, of course, is
-that function definitions may be in compiled form rather than
-S-expression form.  Another is that Fasload files may specify in what
-parts of memory the Lisp data should be allocated.  For example,
-constant lists used by compiled code may be regarded as read-only.
-
-In some Lisp implementations, Fasload file formats are designed to
-allow sharing of code parts of the file, possibly by direct mapping
-of pages of the file into the address space of a process.  This
-technique produces great performance improvements in a paged
-time-sharing system.  Since the Mach project is to produce a
-distributed personal-computer network system rather than a
-time-sharing system, efficiencies of this type are explicitly @i[not]
-a goal for the CMU Common Lisp Fasload file format.
-
-On the other hand, CMU Common Lisp is intended to be portable, as it will
-eventually run on a variety of machines.  Therefore an explicit goal
-is that Fasload files shall be transportable among various
-implementations, to permit efficient distribution of programs in
-compiled form.  The representations of data objects in Fasload files
-shall be relatively independent of such considerations as word
-length, number of type bits, and so on.  If two implementations
-interpret the same macrocode (compiled code format), then Fasload
-files should be completely compatible.  If they do not, then files
-not containing compiled code (so-called "Fasdump" data files) should
-still be compatible.  While this may lead to a format which is not
-maximally efficient for a particular implementation, the sacrifice of
-a small amount of performance is deemed a worthwhile price to pay to
-achieve portability.
-
-The primary assumption about data format compatibility is that all
-implementations can support I/O on finite streams of eight-bit bytes.
-By "finite" we mean that a definite end-of-file point can be detected
-irrespective of the content of the data stream.  A Fasload file will
-be regarded as such a byte stream.
-
-@section [Strategy]
-
-A Fasload file may be regarded as a human-readable prefix followed by
-code in a funny little language.  When interpreted, this code will
-cause the construction of the encoded data structures.  The virtual
-machine which interprets this code has a @i[stack] and a @i[table],
-both initially empty.  The table may be thought of as an expandable
-register file; it is used to remember quantities which are needed
-more than once.  The elements of both the stack and the table are
-Lisp data objects.  Operators of the funny language may take as
-operands following bytes of the data stream, or items popped from the
-stack.  Results may be pushed back onto the stack or pushed onto the
-table.  The table is an indexable stack that is never popped; it is
-indexed relative to the base, not the top, so that an item once
-pushed always has the same index.
-
-More precisely, a Fasload file has the following macroscopic
-organization.  It is a sequence of zero or more groups concatenated
-together.  End-of-file must occur at the end of the last group.  Each
-group begins with a series of seven-bit ASCII characters terminated
-by one or more bytes of all ones (FF@-(16)); this is called the
-@i[header].  Following the bytes which terminate the header is the
-@i[body], a stream of bytes in the funny binary language.  The body
-of necessity begins with a byte other than FF@-(16).  The body is
-terminated by the operation @f[FOP-END-GROUP].
-
-The first nine characters of the header must be "@f[FASL FILE]" in
-upper-case letters.  The rest may be any ASCII text, but by
-convention it is formatted in a certain way.  The header is divided
-into lines, which are grouped into paragraphs.  A paragraph begins
-with a line which does @i[not] begin with a space or tab character,
-and contains all lines up to, but not including, the next such line.
-The first word of a paragraph, defined to be all characters up to but
-not including the first space, tab, or end-of-line character, is the
-@i[name] of the paragraph.  A Fasload file header might look something like
-this:
-@begin(verbatim)
-FASL FILE >SteelesPerq>User>Guy>IoHacks>Pretty-Print.Slisp
-Package Pretty-Print
-Compiled 31-Mar-1988 09:01:32 by some random luser
-Compiler Version 1.6, Lisp Version 3.0.
-Functions: INITIALIZE DRIVER HACK HACK1 MUNGE MUNGE1 GAZORCH
-	   MINGLE MUDDLE PERTURB OVERDRIVE GOBBLE-KEYBOARD
-	   FRY-USER DROP-DEAD HELP CLEAR-MICROCODE
-	    %AOS-TRIANGLE %HARASS-READTABLE-MAYBE
-Macros:    PUSH POP FROB TWIDDLE
-@r[<one or more bytes of FF@-(16)>]
-@end(verbatim)
-The particular paragraph names and contents shown here are only intended as
-suggestions.
-
-@section [Fasload Language]
-
-Each operation in the binary Fasload language is an eight-bit
-(one-byte) opcode.  Each has a name beginning with "@f[FOP-]".  In
-the following descriptions, the name is followed by operand
-descriptors.  Each descriptor denotes operands that follow the opcode
-in the input stream.  A quantity in parentheses indicates the number
-of bytes of data from the stream making up the operand.  Operands
-which implicitly come from the stack are noted in the text.  The
-notation "@PushArrow stack" means that the result is pushed onto the
-stack; "@PushArrow table" similarly means that the result is added to the
-table.  A construction like "@i[n](1) @i[value](@i[n])" means that
-first a single byte @i[n] is read from the input stream, and this
-byte specifies how many bytes to read as the operand named @i[value].
-All numeric values are unsigned binary integers unless otherwise
-specified.  Values described as "signed" are in two's-complement form
-unless otherwise specified.  When an integer read from the stream
-occupies more than one byte, the first byte read is the least
-significant byte, and the last byte read is the most significant (and
-contains the sign bit as its high-order bit if the entire integer is
-signed).
-
-Some of the operations are not necessary, but are rather special
-cases of or combinations of others.  These are included to reduce the
-size of the file or to speed up important cases.  As an example,
-nearly all strings are less than 256 bytes long, and so a special
-form of string operation might take a one-byte length rather than a
-four-byte length.  As another example, some implementations may
-choose to store bits in an array in a left-to-right format within
-each word, rather than right-to-left.  The Fasload file format may
-support both formats, with one being significantly more efficient
-than the other for a given implementation.  The compiler for any
-implementation may generate the more efficient form for that
-implementation, and yet compatibility can be maintained by requiring
-all implementations to support both formats in Fasload files.
-
-Measurements are to be made to determine which operation codes are
-worthwhile; little-used operations may be discarded and new ones
-added.  After a point the definition will be "frozen", meaning that
-existing operations may not be deleted (though new ones may be added;
-some operations codes will be reserved for that purpose).
-
-@begin(description)
-0 @f[ ] @f[FOP-NOP] @\
-No operation.  (This is included because it is recognized
-that some implementations may benefit from alignment of operands to some
-operations, for example to 32-bit boundaries.  This operation can be used
-to pad the instruction stream to a desired boundary.)
-
-1 @f[ ] @f[FOP-POP] @f[ ] @PushArrow @f[ ] table @\
-One item is popped from the stack and added to the table.
-
-2 @f[ ] @f[FOP-PUSH] @f[ ] @i[index](4) @f[ ] @PushArrow @f[ ] stack @\
-Item number @i[index] of the table is pushed onto the stack.
-The first element of the table is item number zero.
-
-3 @f[ ] @f[FOP-BYTE-PUSH] @f[ ] @i[index](1) @f[ ] @PushArrow @f[ ] stack @\
-Item number @i[index] of the table is pushed onto the stack.
-The first element of the table is item number zero.
-
-4 @f[ ] @f[FOP-EMPTY-LIST] @f[ ] @PushArrow @f[ ] stack @\
-The empty list (@f[()]) is pushed onto the stack.
-
-5 @f[ ] @f[FOP-TRUTH] @f[ ] @PushArrow @f[ ] stack @\
-The standard truth value (@f[T]) is pushed onto the stack.
-
-6 @f[ ] @f[FOP-SYMBOL-SAVE] @f[ ] @i[n](4) @f[ ] @i[name](@i[n])
-@f[ ] @PushArrow @f[ ] stack & table@\
-The four-byte operand @i[n] specifies the length of the print name
-of a symbol.  The name follows, one character per byte,
-with the first byte of the print name being the first read.
-The name is interned in the default package,
-and the resulting symbol is both pushed onto the stack and added to the table.
-
-7 @f[ ] @f[FOP-SMALL-SYMBOL-SAVE] @f[ ] @i[n](1) @f[ ] @i[name](@i[n]) @f[ ] @PushArrow @f[ ] stack & table@\
-The one-byte operand @i[n] specifies the length of the print name
-of a symbol.  The name follows, one character per byte,
-with the first byte of the print name being the first read.
-The name is interned in the default package,
-and the resulting symbol is both pushed onto the stack and added to the table.
-
-8 @f[ ] @f[FOP-SYMBOL-IN-PACKAGE-SAVE] @f[ ] @i[index](4)
-@f[ ] @i[n](4) @f[ ] @i[name](@i[n])
-@f[ ] @PushArrow @f[ ] stack & table@\
-The four-byte @i[index] specifies a package stored in the table.
-The four-byte operand @i[n] specifies the length of the print name
-of a symbol.  The name follows, one character per byte,
-with the first byte of the print name being the first read.
-The name is interned in the specified package,
-and the resulting symbol is both pushed onto the stack and added to the table.
-
-9 @f[ ] @f[FOP-SMALL-SYMBOL-IN-PACKAGE-SAVE]  @f[ ] @i[index](4)
-@f[ ] @i[n](1) @f[ ] @i[name](@i[n]) @f[ ]
-@PushArrow @f[ ] stack & table@\
-The four-byte @i[index] specifies a package stored in the table.
-The one-byte operand @i[n] specifies the length of the print name
-of a symbol.  The name follows, one character per byte,
-with the first byte of the print name being the first read.
-The name is interned in the specified package,
-and the resulting symbol is both pushed onto the stack and added to the table.
-
-10 @f[ ] @f[FOP-SYMBOL-IN-BYTE-PACKAGE-SAVE] @f[ ] @i[index](1)
-@f[ ] @i[n](4) @f[ ] @i[name](@i[n])
-@f[ ] @PushArrow @f[ ] stack & table@\
-The one-byte @i[index] specifies a package stored in the table.
-The four-byte operand @i[n] specifies the length of the print name
-of a symbol.  The name follows, one character per byte,
-with the first byte of the print name being the first read.
-The name is interned in the specified package,
-and the resulting symbol is both pushed onto the stack and added to the table.
-
-11@f[ ] @f[FOP-SMALL-SYMBOL-IN-BYTE-PACKAGE-SAVE] @f[ ] @i[index](1)
-@f[ ] @i[n](1) @f[ ] @i[name](@i[n]) @f[ ]
-@PushArrow @f[ ] stack & table@\
-The one-byte @i[index] specifies a package stored in the table.
-The one-byte operand @i[n] specifies the length of the print name
-of a symbol.  The name follows, one character per byte,
-with the first byte of the print name being the first read.
-The name is interned in the specified package,
-and the resulting symbol is both pushed onto the stack and added to the table.
-
-12 Unused.
-
-13 @f[ ] @f[FOP-DEFAULT-PACKAGE] @f[ ] @i[index](4) @\
-A package stored in the table entry specified by @i[index] is made
-the default package for future @f[FOP-SYMBOL] and @f[FOP-SMALL-SYMBOL]
-interning operations. (These package FOPs may change or disappear
-as the package system is determined.)
-
-14 @f[ ] @f[FOP-PACKAGE] @f[ ] @PushArrow @f[ ] table @\
-An item is popped from the stack; it must be a symbol.	The package of
-that name is located and pushed onto the table.
-
-15 @f[ ] @f[FOP-LIST] @f[ ] @i[length](1) @f[ ] @PushArrow @f[ ] stack @\
-The unsigned operand @i[length] specifies a number of
-operands to be popped from the stack.  These are made into a list
-of that length, and the list is pushed onto the stack.
-The first item popped from the stack becomes the last element of
-the list, and so on.  Hence an iterative loop can start with
-the empty list and perform "pop an item and cons it onto the list"
-@i[length] times.
-(Lists of length greater than 255 can be made by using @f[FOP-LIST*]
-repeatedly.)
-
-16 @f[ ] @f[FOP-LIST*] @f[ ] @i[length](1) @f[ ] @PushArrow @f[ ] stack @\
-This is like @f[FOP-LIST] except that the constructed list is terminated
-not by @f[()] (the empty list), but by an item popped from the stack
-before any others are.	Therefore @i[length]+1 items are popped in all.
-Hence an iterative loop can start with
-a popped item and perform "pop an item and cons it onto the list"
-@i[length]+1 times.
-
-17-24 @f[ ] @f[FOP-LIST-1], @f[FOP-LIST-2], ..., @f[FOP-LIST-8] @\
-@f[FOP-LIST-@i{k}] is like @f[FOP-LIST] with a byte containing @i[k]
-following it.  These exist purely to reduce the size of Fasload files.
-Measurements need to be made to determine the useful values of @i[k].
-
-25-32 @f[ ] @f[FOP-LIST*-1], @f[FOP-LIST*-2], ..., @f[FOP-LIST*-8] @\
-@f[FOP-LIST*-@i{k}] is like @f[FOP-LIST*] with a byte containing @i[k]
-following it.  These exist purely to reduce the size of Fasload files.
-Measurements need to be made to determine the useful values of @i[k].
-
-33 @f[ ] @f[FOP-INTEGER] @f[ ] @i[n](4) @f[ ] @i[value](@i[n]) @f[ ]
-@PushArrow @f[ ] stack @\
-A four-byte unsigned operand specifies the number of following
-bytes.	These bytes define the value of a signed integer in two's-complement
-form.  The first byte of the value is the least significant byte.
-
-34 @f[ ] @f[FOP-SMALL-INTEGER] @f[ ] @i[n](1) @f[ ] @i[value](@i[n])
-@f[ ] @PushArrow @f[ ] stack @\
-A one-byte unsigned operand specifies the number of following
-bytes.	These bytes define the value of a signed integer in two's-complement
-form.  The first byte of the value is the least significant byte.
-
-35 @f[ ] @f[FOP-WORD-INTEGER] @f[ ] @i[value](4) @f[ ] @PushArrow @f[ ] stack @\
-A four-byte signed integer (in the range -2@+[31] to 2@+[31]-1) follows the
-operation code.  A LISP integer (fixnum or bignum) with that value
-is constructed and pushed onto the stack.
-
-36 @f[ ] @f[FOP-BYTE-INTEGER] @f[ ] @i[value](1) @f[ ] @PushArrow @f[ ] stack @\
-A one-byte signed integer (in the range -128 to 127) follows the
-operation code.  A LISP integer (fixnum or bignum) with that value
-is constructed and pushed onto the stack.
-
-37 @f[ ] @f[FOP-STRING] @f[ ] @i[n](4) @f[ ] @i[name](@i[n])
-@f[ ] @PushArrow @f[ ] stack @\
-The four-byte operand @i[n] specifies the length of a string to
-construct.  The characters of the string follow, one per byte.
-The constructed string is pushed onto the stack.
-
-38 @f[ ] @f[FOP-SMALL-STRING] @f[ ] @i[n](1) @f[ ] @i[name](@i[n]) @f[ ] @PushArrow @f[ ] stack @\
-The one-byte operand @i[n] specifies the length of a string to
-construct.  The characters of the string follow, one per byte.
-The constructed string is pushed onto the stack.
-
-39 @f[ ] @f[FOP-VECTOR] @f[ ] @i[n](4) @f[ ] @PushArrow @f[ ] stack @\
-The four-byte operand @i[n] specifies the length of a vector of LISP objects
-to construct.  The elements of the vector are popped off the stack;
-the first one popped becomes the last element of the vector.
-The constructed vector is pushed onto the stack.
-
-40 @f[ ] @f[FOP-SMALL-VECTOR] @f[ ] @i[n](1) @f[ ] @PushArrow @f[ ] stack @\
-The one-byte operand @i[n] specifies the length of a vector of LISP objects
-to construct.  The elements of the vector are popped off the stack;
-the first one popped becomes the last element of the vector.
-The constructed vector is pushed onto the stack.
-
-41 @f[ ] @f[FOP-UNIFORM-VECTOR] @f[ ] @i[n](4) @f[ ] @PushArrow @f[ ] stack @\
-The four-byte operand @i[n] specifies the length of a vector of LISP objects
-to construct.  A single item is popped from the stack and used to initialize
-all elements of the vector.  The constructed vector is pushed onto the stack.
-
-42 @f[ ] @f[FOP-SMALL-UNIFORM-VECTOR] @f[ ] @i[n](1) @f[ ] @PushArrow @f[ ] stack @\
-The one-byte operand @i[n] specifies the length of a vector of LISP objects
-to construct.  A single item is popped from the stack and used to initialize
-all elements of the vector.  The constructed vector is pushed onto the stack.
-
-43 @f[ ] @f[FOP-INT-VECTOR] @f[ ] @i[n](4) @f[ ] @i[size](1) @f[ ] @i[count](1) @f[ ]
-@i[data](@ceiling<@i[n]/@i[count]>@ceiling<@i[size]*@i[count]/8>) @f[ ]
-@PushArrow @f[ ] stack @\
-The four-byte operand @i[n] specifies the length of a vector of
-unsigned integers to be constructed.   Each integer is @i[size]
-bits big, and are packed in the data stream in sections of
-@i[count] apiece.  Each section occupies an integral number of bytes.
-If the bytes of a section are lined up in a row, with the first
-byte read at the right, and successive bytes placed to the left,
-with the bits within a byte being arranged so that the low-order bit
-is to the right, then the integers of the section are successive
-groups of @i[size] bits, starting from the right and running across
-byte boundaries.  (In other words, this is a consistent
-right-to-left convention.)  Any bits wasted at the left end of
-a section are ignored, and any wasted groups in the last section
-are ignored.
-It is permitted for the loading implementation to use a vector
-format providing more precision than is required by @i[size].
-For example, if @i[size] were 3, it would be permitted to use a vector
-of 4-bit integers, or even vector of general LISP objects filled
-with integer LISP objects.  However, an implementation is expected
-to use the most restrictive format that will suffice, and is expected
-to reconstruct objects identical to those output if the Fasload file
-was produced by the same implementation.
-(For the PERQ U-vector formats, one would have
-@i[size] an element of {1, 2, 4, 8, 16}, and @i[count]=32/@i[size];
-words could be read directly into the U-vector.
-This operation provides a very general format whereby almost
-any conceivable implementation can output in its preferred packed format,
-and another can read it meaningfully; by checking at the beginning
-for good cases, loading can still proceed quickly.)
-The constructed vector is pushed onto the stack.
-
-44 @f[ ] @f[FOP-UNIFORM-INT-VECTOR] @f[ ] @i[n](4) @f[ ] @i[size](1) @f[ ]
-@i[value](@ceiling<@i[size]/8>) @f[ ] @PushArrow @f[ ] stack @\
-The four-byte operand @i[n] specifies the length of a vector of unsigned
-integers to construct.
-Each integer is @i[size] bits big, and is initialized to the value
-of the operand @i[value].
-The constructed vector is pushed onto the stack.
-
-45 @f[ ] @f[FOP-FLOAT] @f[ ] @i[n](1) @f[ ] @i[exponent](@ceiling<@i[n]/8>) @f[ ]
-@i[m](1) @f[ ] @i[mantissa](@ceiling<@i[m]/8>) @f[ ] @PushArrow @f[ ] stack @\
-The first operand @i[n] is one unsigned byte, and describes the number of
-@i[bits] in the second operand @i[exponent], which is a signed
-integer in two's-complement format.  The high-order bits of
-the last (most significant) byte of @i[exponent] shall equal the sign bit.
-Similar remarks apply to @i[m] and @i[mantissa].  The value denoted by these
-four operands is @i[mantissa]@f[x]2@+{@i[exponent]-length(@i[mantissa])}.
-A floating-point number shall be constructed which has this value,
-and then pushed onto the stack.  That floating-point format should be used
-which is the smallest (most compact) provided by the implementation which
-nevertheless provides enough accuracy to represent both the exponent
-and the mantissa correctly.
-
-46-51 Unused
-
-52 @f[ ] @f[FOP-ALTER] @f[ ] @i[index](1) @\
-Two items are popped from the stack; call the first @i[newval] and
-the second @i[object].	The component of @i[object] specified by
-@i[index] is altered to contain @i[newval].  The precise operation
-depends on the type of @i[object]:
-@begin(description)
-List @\ A zero @i[index] means alter the car (perform @f[RPLACA]),
-and @i[index]=1 means alter the cdr (@f[RPLACD]).
-
-Symbol @\ By definition these indices have the following meaning,
-and have nothing to do with the actual representation of symbols
-in a given implementation:
-@begin(description)
-0 @\ Alter value cell.
-
-1 @\ Alter function cell.
-
-2 @\ Alter property list (!).
-@end(description)
-
-Vector (of any kind) @\ Alter component number @i[index] of the vector.
-
-String @\ Alter character number @i[index] of the string.
-@end(description)
-
-53 @f[ ] @f[FOP-EVAL] @f[ ] @PushArrow @f[ ] stack @\
-Pop an item from the stack and evaluate it (give it to @f[EVAL]).
-Push the result back onto the stack.
-
-54 @f[ ] @f[FOP-EVAL-FOR-EFFECT] @\
-Pop an item from the stack and evaluate it (give it to @f[EVAL]).
-The result is ignored.
-
-55 @f[ ] @f[FOP-FUNCALL] @f[ ] @i[nargs](1) @f[ ] @PushArrow @f[ ] stack @\
-Pop @i[nargs]+1 items from the stack and apply the last one popped
-as a function to
-all the rest as arguments (the first one popped being the last argument).
-Push the result back onto the stack.
-
-56 @f[ ] @f[FOP-FUNCALL-FOR-EFFECT] @f[ ] @i[nargs](1) @\
-Pop @i[nargs]+1 items from the stack and apply the last one popped
-as a function to
-all the rest as arguments (the first one popped being the last argument).
-The result is ignored.
-
-57 @f[ ] @f[FOP-CODE-FORMAT] @f[ ] @i[id](1) @\
-The operand @i[id] is a unique identifier specifying the format
-for following code objects.  The operations @f[FOP-CODE]
-and its relatives may not
-occur in a group until after @f[FOP-CODE-FORMAT] has appeared;
-there is no default format.  This is provided so that several
-compiled code formats may co-exist in a file, and so that a loader
-can determine whether or not code was compiled by the correct
-compiler for the implementation being loaded into.
-So far the following code format identifiers are defined:
-@begin(description)
-0 @\ PERQ
-
-1 @\ VAX
-
-3 @\ @value(DinkyMachine)
-@end(description)
-
-58 @f[ ] @f[FOP-CODE] @f[ ] @i[nitems](4) @f[ ] @i[size](4) @f[ ]
-@i[code](@i[size]) @f[ ] @PushArrow @f[ ] stack @\
-A compiled function is constructed and pushed onto the stack.
-This object is in the format specified by the most recent
-occurrence of @f[FOP-CODE-FORMAT].
-The operand @i[nitems] specifies a number of items to pop off
-the stack to use in the "boxed storage" section.  The operand @i[code]
-is a string of bytes constituting the compiled executable code.
-
-59 @f[ ] @f[FOP-SMALL-CODE] @f[ ] @i[nitems](1) @f[ ] @i[size](2) @f[ ]
-@i[code](@i[size]) @f[ ] @PushArrow @f[ ] stack @\
-A compiled function is constructed and pushed onto the stack.
-This object is in the format specified by the most recent
-occurrence of @f[FOP-CODE-FORMAT].
-The operand @i[nitems] specifies a number of items to pop off
-the stack to use in the "boxed storage" section.  The operand @i[code]
-is a string of bytes constituting the compiled executable code.
-
-60 @f[ ] @f[FOP-STATIC-HEAP] @\
-Until further notice operations which allocate data structures
-may allocate them in the static area rather than the dynamic area.
-(The default area for allocation is the dynamic area; this
-default is reset whenever a new group is begun.
-This command is of an advisory nature; implementations with no
-static heap can ignore it.)
-
-61 @f[ ] @f[FOP-DYNAMIC-HEAP] @\
-Following storage allocation should be in the dynamic area.
-
-62 @f[ ] @f[FOP-VERIFY-TABLE-SIZE] @f[ ] @i[size](4) @\
-If the current size of the table is not equal to @i[size],
-then an inconsistency has been detected.  This operation
-is inserted into a Fasload file purely for error-checking purposes.
-It is good practice for a compiler to output this at least at the
-end of every group, if not more often.
-
-63 @f[ ] @f[FOP-VERIFY-EMPTY-STACK] @\
-If the stack is not currently empty,
-then an inconsistency has been detected.  This operation
-is inserted into a Fasload file purely for error-checking purposes.
-It is good practice for a compiler to output this at least at the
-end of every group, if not more often.
-
-64 @f[ ] @f[FOP-END-GROUP] @\
-This is the last operation of a group.	If this is not the
-last byte of the file, then a new group follows; the next
-nine bytes must be "@f[FASL FILE]".
-
-65 @f[ ] @f[FOP-POP-FOR-EFFECT] @f[ ] stack @f[ ] @PushArrow @f[ ] @\
-One item is popped from the stack.
-
-66 @f[ ] @f[FOP-MISC-TRAP] @f[ ] @PushArrow @f[ ] stack @\
-A trap object is pushed onto the stack.
-
-67 @f[ ] @f[FOP-READ-ONLY-HEAP] @\
-Following storage allocation may be in a read-only heap.
-(For symbols, the symbol itself may not be in a read-only area,
-but its print name (a string) may be.
-This command is of an advisory nature; implementations with no
-read-only heap can ignore it, or use a static heap.)
-
-68 @f[ ] @f[FOP-CHARACTER] @f[ ] @i[character](3) @f[ ] @PushArrow @f[ ] stack @\
-The three bytes specify the 24 bits of a CMU Common Lisp character object.
-The bytes, lowest first, represent the code, control, and font bits.
-A character is constructed and pushed onto the stack.
-
-69 @f[ ] @f[FOP-SHORT-CHARACTER] @f[ ] @i[character](1) @f[ ]
-@PushArrow @f[ ] stack @\
-The one byte specifies the lower eight bits of a CMU Common Lisp character
-object (the code).  A character is constructed with zero control
-and zero font attributes and pushed onto the stack.
-
-70 @f[ ] @f[FOP-RATIO] @f[ ] @PushArrow @f[ ] stack @\
-Creates a ratio from two integers popped from the stack.
-The denominator is popped first, the numerator second.
-
-71 @f[ ] @f[FOP-COMPLEX] @f[ ] @PushArrow @f[ ] stack @\
-Creates a complex number from two numbers popped from the stack.
-The imaginary part is popped first, the real part second.
-
-72 @f[ ] @f[FOP-LINK-ADDRESS-FIXUP] @f[ ] @i[nargs](1) @f[ ] @i[restp](1)
-@f[ ] @i[offset](4) @f[ ] @PushArrow @f[ ] stack @\
-Valid only for when FOP-CODE-FORMAT corresponds to the Vax or the
-@value(DinkyMachine).
-This operation pops a symbol and a code object from the stack and pushes
-a modified code object back onto the stack according to the needs of the
-runtime code linker on the Vax or @value(DinkyMachine).
-
-73 @f[ ] @f[FOP-LINK-FUNCTION-FIXUP] @f[ ] @i[offset](4) @f[ ]
-@PushArrow @f[ ] stack @\
-Valid only for when FOP-CODE-FORMAT corresponds to the Vax or the
-@value(DinkyMachine).
-This operation pops a symbol and a code object from the stack and pushes
-a modified code object back onto the stack according to the needs of the
-runtime code linker on the Vax or the @value(DinkyMachine).
-
-74 @f[ ] @f[FOP-FSET] @f[ ] @\
-Pops the top two things off of the stack and uses them as arguments to FSET
-(i.e. SETF of SYMBOL-FUNCTION).
-
-128 @f[ ] @f[FOP-LINK-ADDRESS-FIXUP] @f[ ] @i[nargs] @f[ ] @i[flag] @f[ ]
-@i[offset] @f[ ]@\Valid only when FOP-CODE-FORMAT corresponds to the
-@value(DinkyMachine).  This operation pops a symbol and a function object
-off the stack.  The code vector in the function object is modified
-according to the needs of the runtime code linker of the @value(DinkyMachine)
-and pushed back on the stack.  This FOP links in calls to other functions.
-
-129 @f[ ] @f[FOP-MISCOP-FIXUP] @f[ ] @i[index](2) @f[ ] @i[offset](4) @f[ ]@\
-Valid only when FOP-CODE-FORMAT corresponds to the @value(DinkyMachine).
-This operation pops a code object from the stack and pushes a
-modified code object back onto the stack according to the needs of
-the runtime code linker on the @value(DinkyMachine).  This FOP links in
-calls to the assembler language support routines.
-
-130 @f[ ] @f[FOP-ASSEMBLER-ROUTINE] @f[ ] @i[code-length] @f[ ] @\
-Valid only when FOP-CODE-FORMAT corresponds to the @value(DinkyMachine).
-This operation loads assembler code into the assembler code space of the
-currently running Lisp.
-
-131 @f[ ] @f[FOP-FIXUP-MISCOP-ROUTINE] @f[ ]@\Valid only when FOP-CODE-FORMAT
-corresponds to the @value(DinkyMachine).  This operation pops a list of
-external references, a list of external labels defined, the name, and the
-code address off the stack.  This information is saved, so that after
-everything is loaded, all the external references can be resolved.
-
-132 @f[ ] @f[FOP-FIXUP-ASSEMBLER-ROUTINE] @f[ ]@\is similar to
-FOP-FIXUP-MISCOP-ROUTINE, except it is for internal assembler routines
-rather than ones visible to Lisp.
-
-133 @f[ ] @f[FOP-FIXUP-USER-MISCOP-ROUTINE] @f[ ]@\is similar to
-FOP-FIXUP-MISCOP-ROUTINE, except it is for routines written by users who
-have an extremely good understanding of the system internals.
-
-134 @f[ ] @f[FOP-USER-MISCOP-FIXUP] @f[ ] @i[offset](4) @f[ ]@\is similar
-to FOP-MISCOP-FIXUP, but is used to link in user defined miscops.
-
-255 @f[ ] @f[FOP-END-HEADER] @\ Indicates the end of a group header, as described above.
-@end(description)
-
-@Appendix[Building CMU Common Lisp]
-
-@section(Introduction)
-This document explains how to build a working Common Lisp from source code on
-the IBM RT PC under the Mach operating system.  You should already have a
-working Common Lisp running on an IBM RT PC before trying to build a new Common
-Lisp.
-
-Throughout this document the following terms are used:
-@begin(Description)
-Core file@\A core file is a file containing an image of a Lisp system.  The
-core file contains header information describing where the data in the rest of
-the file should be placed in memory.  There is a simple C program which reads a
-core file into memory at the correct locations and then jumps to a location
-determined by the contents of the core file.  The C code includes the X
-window system version 10 release 4 which may be called from Lisp.
-
-
-Cold core file @\A cold core file contains enough of the Lisp system to make it
-possible to load in the rest of the code necessary to generate a full Common
-Lisp.  A cold core file is generated by the program Genesis.
-
-Miscops@\Miscops are assembler language routines that are used to support
-compiled Lisp code.  A Lisp macro assembler provides a
-convenient mechanism for writing these assembler language routines.
-
-Matchmaker@\Matchmaker is a program developed to automatically generate
-remote procedure call interfaces between programs.  Matchmaker accepts
-a description of a remote procedure call interface and generates code
-that implements it.
-@end(Description)
-
-There are many steps required to go from sources to a working Common Lisp
-system.  Each step will be explained in detail in the following sections.
-It is possible to perform more than one step with one invocation of Lisp.
-However, I recommend that each step be started with a fresh Lisp.  There
-is some small chance that something done in one step will adversely affect
-a following step if the same Lisp is used.  The scripts for each
-step assume that you are in the user package which is the default when
-Lisp first starts up.  If you change to some other package, some of these
-steps may not work correctly.
-
-In many of the following steps, there are lines setting up search lists so that
-command files know where to find the sources.  What I have done is create a
-init.lisp file that sets up these search lists for me.  This file is
-automatically loaded from the user's home directory (as determined by the
-@b[HOME] environment variable) when you start up Lisp.  Note that my init.lisp
-file is included with the sources.  You may have to modify it, if you change
-where the lisp sources are.
-
-@section(Installing Source Code)
-With this document, you should also have received a tape cartridge in tar
-format containing the complete Common Lisp source code.  You should create
-some directory where you want to put the source code.  For the following
-discussion, I will assume that the source code lives in the directory
-/usr/lisp.  To install the source code on your machine, issue the following
-commands:
-@begin(Example)
-cd /usr/lisp
-tar xvf <tape device>
-@end(Example)
-The first command puts you into the directory where you want the source code,
-and the second extracts all the files and sub-directories from the tape into
-the current directory.  <Tape device> should be the name of the tape device on
-your machine, usually /dev/st0.
-
-The following sub-directories will be created by tar:
-@begin(Description)
-bin@\contains a single executable file, lisp, which is a C program
-used to start up Common Lisp.
-
-clc@\contains the Lisp source code for the Common Lisp compiler and assembler.
-
-code@\contains the Lisp source code that corresponds to all the functions,
-variables, macros, and special forms described in @i[Common Lisp: The Language]
-by Guy L. Steele Jr., as well as some Mach specific files.
-
-hemlock@\contains the Lisp source code for Hemlock, an emacs-like editor
-written completely in Common Lisp.
-
-icode@\contains Matchmaker generated code for interfaces to Inter Process
-Communication (IPC) routines.  This code is used to communicate with other
-processes using a remote procedure call mechanism.  Under Mach, all the
-facilities provided by Mach beyond the normal Berkeley Unix 4.3 system
-calls are accessed from Lisp using this IPC mechanism.  Currently, the
-code for the Mach, name server, Lisp typescript, and Lisp eval server
-interfaces reside in this directory.
-
-idefs@\contains the Matchmaker definition files used to generate the Lisp
-code in the icode directory.
-
-lib@\contains files needed to run Lisp.  The file lisp.core is known as a
-Lisp core file and is loaded into memory by the lisp program mentioned
-above in the entry for the bin directory.  This file has a format which
-allows it to be mapped into memory at the correct locations.  The files
-spell-dictionary.text and spell-dictionary.bin are the text and binary
-form of a dictionary, respectively, used by Hemlock's spelling checker and
-corrector.  The two files hemlock.cursor and hemlock.mask are used by
-Hemlock when running under the X window system.
-
-miscops@\contains the Lisp assembler source code for all the miscops
-that support low level Lisp functions, such as storage allocation,
-complex operations that can not performed in-line, garbage collection, and
-other operations.  These routines are written in assembler, so that they
-are as efficient as possible.  These routines use a very short calling
-sequence, so calling them is very cheap compared to a normal Lisp
-function call.
-
-mm@\contains the Lisp source code for the Matchmaker program.  This program
-is used to generate the Lisp source code files in icode from the corresponding
-matchmaker definitions in idefs.
-
-pcl@\contains the Lisp source code for a version of the Common Lisp Object
-System (originally Portable Common Loops),
-an object oriented programming language built on top of Common Lisp.
-
-X@\contains the C object files for X version 10 release 4 C library
-routines.  These are linked with the lisp startup code, so that X is
-available from Lisp.
-
-scribe@\contains Scribe source and postscript output for the manuals
-describing various aspects of the CMU Common Lisp implementation.
-
-demos@\contains the Lisp source code for various demonstration programs.
-This directory contains the Gabriel benchmark set (bmarks.lisp) and
-a sub-directory containing the Soar program which is also used for
-benchmarking purposes.  There may be other programs and/or sub-directories
-here that you may look at.
-@end(Description)
-These directories contain source files as well as Lisp object files.
-This means it is not necessary to go through all the steps to
-build a new a Common Lisp, only those steps that are affected by
-a modification to the sources.  For example, modifying the compiler
-will require recompiling everything.  Modifying a miscop file should
-require only reassembling that particular file and rebuilding the
-cold core file and full core file.
-
-As well as the directories mentioned above, there are also several files
-contained in the top-level directory.  These are:
-@begin(Description)
-init.lisp@\is a Lisp init file I use.  This sets up some standard search
-lists, as well as defines a Hemlock mode for editing miscop
-source files.
-
-lisp.c@\contains the C code used to start up the lisp core image under Mach.
-
-lispstart.s@\contains some assembler language code that is invoked by lisp.c
-to finish the process of starting up the lisp process.
-
-makefile@\contains make definitions for compiling lisp.c and lispstart.s
-into the lisp program.
-
-rg@\contains some adb commands that can be read into adb while debugging a lisp
-process.  It prints out all the registers, the name of the currently
-executing Lisp function, and sets an adb variable to the current stack frame
-which is used by the following file.
-
-st@\contains some adb commands that can be read into adb while debugging
-a lisp process.  It prints out a Lisp stack frame and the name of the
-function associated with the stack frame.  It also updates the adb variable
-mentioned above to point to the next stack frame.  Repeatedly reading this
-file into adb will produce a backtrace of all the active call frames
-on the Lisp stack.
-
-ac@\contains some adb commands that print out the current values of the
-active catch pointer.  This points to the head of a list of catch frames
-that exist on the control stack.
-
-cs@\contains some adb commands that print out the contents of a catch
-frame.  Reading cs into adb several times in a row (after reading ac once)
-will print out the catch frames in order.
-@end(Description)
-
-@section(Compiling the Lisp Startup Program)
-To compile the lisp start up program, you should be in the top level directory
-of the sources (/usr/lisp) and type:
-@begin(Example)
-make lisp
-@end(Example)
-This will compile the file lisp.c, assemble the file lispstart.s and produce
-an executable file lisp.  Currently the default location for the lisp core
-file is /usr/misc/.lisp/lib/lisp.core.  If you want to change this default
-location, edit the file lisp.c and change the line
-@begin(Example)
-#define COREFILE "/usr/misc/.lisp/lib/lisp.core"
-@end(Example)
-to refer to the file where you intend to put the core file.
-
-This step takes a few seconds.
-
-@section(Assembling Assembler routines)
-The standard core image includes a Lisp macro assembler.  To assemble all
-the miscops, the following steps should be performed:
-@begin(Example)
-(compile-file "/usr/lisp/clc/miscasm.lisp")
-(load "/usr/lisp/clc/miscasm.fasl")
-(setf (search-list "msc:") '("/usr/lisp/miscops/"))
-(clc::asm-files)
-@end(Example)
-The first line compiles a file that contains a couple of functions used to
-assemble miscop source files.  The second line loads the resulting compiled
-file into the currently executing core image.  The third line defines the
-msc search list which is used by the function clc::asm-files to locate
-the miscop sources.  The terminal will display information as each file
-is assembled.  For each file a .fasl, a .list, and an .err file will be
-generated in /usr/lisp/miscops.
-
-This step takes about half an hour.
-
-@section(Compiling the Compiler)
-
-To compile the compiler is simple:
-@begin(Example)
-(setf (search-list "clc:") '("/usr/lisp/clc/"))
-(load "clc:compclc.lisp")
-@end(Example)
-The first line just sets up a search list variable clc, so that the file
-compclc.lisp can find the compiler sources.  The terminal will display
-information as each file is assembled.  For each file a .fasl and an .err file
-will be generated.  A log of the compiler output is also displayed on the
-terminal.
-
-This step takes about forty-five minutes.
-
-@section(Compiling the Lisp Sources)
-
-Compiling the Lisp source code is also easy:
-@begin(Example)
-(setf (search-list "code:") '("/usr/lisp/code/"))
-(load "code:worldcom.lisp")
-@end(Example)
-Again, the first line defines a search list variable, so that the file
-worldcom.lisp can find the Lisp sources.  As each file is compiled, the
-name of the file is printed on the terminal.  For each file a .fasl will be
-generated.  Also, a single error log will be generated in the file
-code:compile-lisp.log.
-
-This step takes about an hour and a half.
-
-@section(Compiling Hemlock)
-
-Compiling the Hemlock source code is done as follows:
-@begin(Example)
-(setf (search-list "hem:") '("/usr/lisp/hemlock/"))
-(load "hem:ctw.lisp")
-@end(Example)
-Again, the first line defines a search list variable, so that ctw.lisp can
-find the Hemlock sources.  As each file is compiled, the name of the file is
-printed on the terminal.  For each file a .fasl will be generated.  Also, a
-single error log will be generated in the file hem:lossage.log.
-
-This step takes about forty-five minutes.
-
-@section(Compiling Matchmaker)
-Compiling the matchmaker sources is done as follows:
-@begin(Example)
-(setf (search-list "mm:") '("/usr/lisp/mm"))
-(compile-file "mm:mm.lisp")
-(load "mm:mm.fasl")
-(compile-mm)
-@end(Example)
-The first line sets up a search list, so that the matchmaker sources can be
-found.  The second line compiles the file containing a function for compiling
-the matchmaker sources.  The third line loads the file just
-compiled, and the final line invokes the function compile-mm which compiles the
-matchmaker sources.  For each file, a .fasl and .err file is generated.  Also,
-a log of the compiler output is printed to the terminal.
-
-This step takes about 15 minutes
-
-@section(Generating Lisp Source Files from Matchmaker Definition Files)
-The following sequence of commands is necessary to generate the Lisp
-files for the Mach interface:
-@begin(Example)
-(setf (search-list "mm:") '("/usr/lisp/mm/"))
-(setf (search-list "idefs:") '("/usr/lisp/idefs/"))
-(setf (search-list "icode:") '("/usr/lisp/icode/"))
-(setf (search-list "code:") '("/usr/lisp/code/"))
-(setf (default-directory) "/usr/lisp/icode/")
-(load "code:mm-interfaces.lisp")
-@end(Example)
-The first four lines set up search lists for mm (matchmaker sources), idefs
-(matchmaker interface definition files), icode (Lisp matchmaker interface
-sources), and code (Lisp code sources).  The fifth line changes the current
-working directory to be /usr/lisp/icode.  This is where the output from
-matchmaker will be placed.  And finally, the last line invokes matchmaker on
-the matchmaker definition files for all the interfaces.
-
-Matchmaker generates three files for each interface XXX:
-@begin(Description)
-XXXdefs.lisp@\contains constants and record definitions for the interface.
-
-XXXmsgdefs.lisp@\contains definitions of offsets to important fields in the
-messages that are sent to and received from the interface.
-
-XXXuser.lisp@\contains code for each remote procedure, that sends a message
-to the server and receives the reply from the server (if appropriate).
-Each of these functions returns one or more values.  The first value
-returned is a general return which specifies whether the remote procedure
-call succeeded or gives an indication of why it failed.  Other values may
-be returned depending on the particular remote procedure.  These values are
-returned using the multiple value mechanism of Common Lisp.
-@end(Description)
-
-This step takes about five minutes.
-
-@section(Compiling Matchmaker Generated Lisp Files)
-To compile the matchmaker generated Lisp files the following steps should
-be performed:
-@begin(Example)
-(setf (search-list "code:") '("/usr/lisp/code/"))
-(setf (search-list "icode:") '("/usr/lisp/icode/"))
-(load "code:comutil.lisp")
-@end(Example)
-The first two lines set up search lists for the code and icode directory.
-The final line loads a command file that compiles the Mach interface
-definition in the correct order.  Note that once the files are compiled,
-the XXXmsgdefs files are no longer needed.  The file
-/usr/lisp/icode/lossage.log contains a listing of all the error messages
-generated by the compiler.
-
-This step takes about fifteen minutes.
-
-@section(Compiling the Common Lisp Object System)
-
-To compile the Common Lisp Object System (CLOS) do the following:
-@begin(Example)
-(setf (search-list "pcl:") '("/usr/lisp/pcl/"))
-(rename-package (find-package "CLOS") "OLD-CLOS")
-(compile-file "pcl:defsys.lisp")
-(load "pcl:defsys.fasl")
-(clos::compile-pcl)
-@end(Example)
-The first line sets up a search list as usual.  The second line renames the
-CLOS package to be the OLD-CLOS package.  This is so that the current version
-of CLOS doesn't interfere with the compilation process. The third line
-compiles a file containing some functions for building CLOS.  The fourth
-line loads in the result of the previous compilation.  The final line
-compiles all the CLOS files necessary for a working CLOS system. 
-
-The file /usr/lisp/pcl/test.lisp is a file that contains some test functions.
-To run it through CLOS build a new Lisp and start up a fresh Lisp
-resulting from the build and do the following:
-@begin(Example)
-(in-package 'clos)
-(compile-file "/usr/lisp/pcl/test.lisp")
-(load "/usr/lisp/pcl/test.fasl")
-@end(Example)
-This sequence of function calls puts you in the CLOS package, compiles the
-test file and then loads it.  As the test file is loaded, it executes several
-tests.  It will print out a message specifying whether each test passed or
-failed.
-
-Currently, CLOS is built into the standard core.
-
-This step takes about 30 minutes.
-
-@section(Compiling Genesis)
-To compile genesis do the following:
-@begin(Example)
-(compile-file "/usr/lisp/clc/genesis.lisp")
-@end(Example)
-Genesis is used to build a cold core file.  Compiling Genesis takes about five
-minutes.
-
-@section(Building a Cold Core File)
-Once all the files have been assembled or compiled as described above, it is
-necessary to build a cold core file as follows:
-@begin(Example)
-(setf (search-list "code:") '("/usr/lisp/code/"))
-(setf (search-list "icode:") '("/usr/lisp/icode/"))
-(setf (search-list "msc:") '("/usr/lisp/miscops/"))
-(load "/usr/lisp/clc/genesis.fasl")
-(load "code:worldbuild.lisp")
-@end(Example)
-The first three lines set up search lists for the code, icode, and miscops
-subdirectories.  The fourth line loads in the program Genesis which builds
-the cold core file.  The last line calls Genesis on a list of the files that
-are necessary to build the cold core file.  As each file is being processed,
-its name is printed to the terminal.  Genesis generates two files:
-/usr/lisp/ilisp.core and /usr/lisp/lisp.map.  Ilisp.core is the cold core
-file and lisp.map is a file containing the location of all the functions
-and miscops in the cold core file.  Lisp.map is useful for debugging the
-cold core file.
-
-This step takes from about fifteen minutes.
-
-@section(Building a Full Common Lisp)
-The cold core file built above does not contain some of the more useful
-programs such as the compiler and hemlock.  To build these into a core, it is
-necessary to do the following:
-@begin(Example)
-lisp -c /usr/lisp/ilisp.core
-(in-package "USER")
-(load (open "/usr/lisp/code/worldload.lisp"))
-@end(Example)
-The first line invokes the lisp startup program specifying the cold core
-file just built as the core file to load.  This cold core file is set up
-to do a significant amount of initialization and it is quite possible that
-some bug will occur during this initialization process.  After about a
-minute, you should get a prompt of the form:
-@begin(Example)
-CMU Common Lisp kernel core image 2.7(?).
-[You are in the Lisp Package.]
-*
-@end(Example)
-The following two lines should then be entered.  The first of these puts
-you into the User package which is the package you should be in when the
-full core is first started up.  It is necessary to add this line, because
-the current package is rebound while a file is loaded.  The last line loads
-in a file that loads in the compiler, hemlock, and some other files not yet
-loaded.  The open call is @b[essential] otherwise when the full core is
-started up, load will try to close the file and probably invalidate memory
-that is needed.  When load is passed a stream, it does not automatically
-close the stream.  With a file name it now does after a recent bug fix.
-This file prompts for the versions of the Lisp system, the compiler, and
-hemlock.  You should enter versions that make sense for your installation.
-It then purifies the core image.  Up to this point most of the Lisp system
-has been loaded into dynamic space.  Only a few symbols and some other data
-structures are in static space.  The process of purification moves Lisp
-objects into static and read-only space, leaving very little in dynamic
-space.  Having the Lisp system in static and read-only space reduces the
-amount of work the garbage collector has to do.  Only those objects needed
-in the final core file are retained.  Finally, a new core file is generated
-and is written to the file /usr/lisp/nlisp.core.  Also, the currently
-running Lisp should go through the default initialization process, finally
-prompting for input with an asterisk.  At this point you have successfully
-built a new core file containing a complete Common Lisp implementation.
-
-This step takes about thirty minutes.
-
-@section(Debugging)
-Debugging Lisp code is much easier with a fully functional Lisp.  However, it
-is quite possible that a change made in the system can cause a bug to happen
-while running the cold core file.  If this happens, it is best to use adb to
-track down the problem.  Unfortunately, the core file (i.e., the
-remains of a process normally created by Unix when a process dies) generated by
-such a bug will be of no use.  To get some useful information, follow these
-steps:
-@begin(Enumerate)
-Look at the file /usr/lisp/lisp.map and find the entry points for the
-miscop routines error0, error1, and error2.  These entry points are
-used to invoke the Lisp error system from the miscops.  Write down
-the numbers beside these names.  They are the addresses (in hex) of where
-the miscops are located when the cold core file is loaded into memory.
-
-Run adb on the lisp file, i.e.:
-@begin(example)
-adb lisp
-@end(Example)
-
-Set a breakpoint at the lispstart entry point:
-@begin(Example)
-lispstart:b
-@end(Example)
-
-Start the lisp program running, telling it to use ilisp.core (I'm
-assuming you're in /usr/lisp):
-@begin(Example)
-:r -c ilisp.core
-@end(Example)
-
-After a while, you will hit the lispstart breakpoint.  The core file has been
-mapped into memory, but control is still in the C startup code.  At this point,
-you should enter breakpoints for all the error entry points described above.
-
-Continue running the program by typing :c.  Shortly after this, the C lisp
-program will give up control to Lisp proper.  Lisp will start doing its
-initialization and will probably hit one of the error break points.
-At that point you can look around at the state and try and discover
-what has gone wrong.  Note that the two files rg and st are useful at this
-point.  Also, you should look at the document @i[Internal Design of Common
-Lisp on the IBM RT PC] by David B. McDonald, Scott E. Fahlman, and Skef
-Wholey so that you know the internal data structures.
-@end(Enumerate)
-
-@section(Running the Soar Benchmark)
-To compile the soar benchmark, you should do the following:
-@begin(Example)
-(compile-file "/usr/lisp/demos/soar/soar.lisp")
-@end(Example)
-
-To run the benchmark, you should start up a fresh Lisp and do the following:
-@begin(Example)
-(load "/usr/lisp/demos/soar/soar.fasl")
-(load "/usr/lisp/demos/soar/default.soar")
-(load "/usr/lisp/demos/soar/eight.soar")
-(user-select 'first)
-(init-soar)
-(time (run))
-@end(Example)
-The first two lines load in the standard Soar system.  The third line loads in
-information about the eight puzzle which is a standard Soar puzzle that has
-been run on several different machines.  The fourth line sets up the puzzle
-conditions so that it will select a goal to work on automatically.  The fifth
-line initializes Soar's working memory, etc.  The final line is the one that
-actually runs the benchmark.  Soar prints out a fair amount of information as
-it solves the puzzle.  The final state should be numbered 143 when it finishes.
-The time macro prints out information about information various resources after
-the eight puzzle has run.
-
-@section(Summary)
-I have tried to present sufficient information here to allow anyone to be
-able to build a Common Lisp system under Mach from the sources.  I am sure
-there are many tricks that I have learned to use to reduce the amount of grief
-necessary to build a system.  My best recommendation is to go slowly.  Start
-by building a system from the sources provided on the tape.  Make sure you
-are comfortable doing that before you try modifying anything.
-
-Some hints on building the system which you may find useful:
-@begin(Itemize)
-If you change the compiler, you will have to recompile all the sources before
-the change is reflected in a system.  Changing the compiler is probably the
-most dangerous change you can make, since an error here means that
-nothing will work.  In particular, this is the time you are going to need
-to get familiar with adb and the internal structure of the Lisp, since a
-serious error in the compiler will show up during the initialization of the
-cold core file.
-
-Changing the miscops should be done with care.  They follow a fairly rigid
-convention and you should understand all the information provided in
-@i[Internal Design of Common Lisp on the IBM RT PC] before making any changes
-to miscops.  You will probably need to get familiar with adb to debug some of
-the changes.  Note that this requires building a new cold core file and a final
-core file before the change is reflected in the system.
-
-Changing sources in the code directory should be fairly straight forward.  The
-only time this will cause trouble is if you change something that a lot of 
-files depend on in which case you will have to recompile everything and build
-a new cold core file and a core file.
-
-Changing hemlock should have no adverse effect on system integrity.
-
-If you make a fairly major change, it is a good idea to go through the complete
-process of building a core file at least two or three times.  If things are
-still working at the end of this, your change is probably correct and shouldn't
-cause any serious trouble.
-
-Finally, always keep at least one backup copy of a good core image around.
-If you build a bad core file over an existing one and can't back up, it is
-possible that you may not be able to recover from a serious error.
-@end(Itemize)
diff --git a/general-info/alpha-notes-thru-92.txt b/general-info/alpha-notes-thru-92.txt
deleted file mode 100644
index 2ac0f4ae524b3a40940cde9c07a26aed01ccf98b..0000000000000000000000000000000000000000
--- a/general-info/alpha-notes-thru-92.txt
+++ /dev/null
@@ -1,3056 +0,0 @@
-11/23/92 to 12/5/92:
-
-Code:
-
-Minor fixes to LOOP and DELETE-PACKAGE.
-
-Low level support for various subtypes of function for use with Dylan.
-
-
-
-10/21/92 to 11/23/92:
-
-Code:
-
-Fixed ``enum'' alien types to always use up 32 bits to be compatable with
-the various C compilers on the machines we are using.
-
-Fixed a bug in the ~<...~:> FORMAT directive where ~^ would blow out of
-whatever the ~<...~:> was inside instead of just the ~<...~:>.
-
-Extended hash tables to allow user defined :tests.  There is now a function
-DEFINE-HASH-TABLE-TEST that takes three arguments: the symbol name of the
-hash table test, the test function, and the hash function.  It registers
-the name, test function, and hash function so that MAKE-HASH-TABLE can be
-called with either the name or the test function for the :test argument.
-The hash function should take one argument (the object) and return a
-positive fixnum hash value.
-
-Delete-package function added according to X3J13/92 specification.
-
-Fixed pprint-lambda-list to print a space before the dot when the tail of
-the lambda list is shared.  In other words, print (foo . #1=(bar baz))
-instead of (foo. #1=(bar baz)).
-
-The newest implementation of LOOP employs a recursive descent parser with
-an intermediate representation in terms of variable, clause and loop
-structures.  After the entire expression is parsed the loop template is
-filled according to a set of rules determined by the clause operator.  Parts
-of this system are based on code in Peter Norvig's book Paradigm's of 
-Artificial Intelligence Programming: Case Studies in Common Lisp (Ch 24.5).
-The complete implementation satisfies all the test cases in the MIT test 
-suite and in the less complete ANSI Loop specification.
-
-
-Compiler:
-
-Fixed FIND-RESULT-TYPE to correctly handle assignment conversion.
-
-Only try to generate a disassembly when making a trace file if the
-disassembler has been set up for the backend we are using.
-
-Added a ``variable-lenght'' instruction attribute that indicates that the
-instruction can be a variable length, and hence cannot be used in a branch
-delay slot.
-
-
-C Support Code:
-
-[SPARC only] Fixed a bug were it would sometimes not save the floating
-point state on a signal.  This was causing all sorts of lossage.
-
-
-Tools:
-
-Added clmcom.lisp, as script to compile the clm stuff.  And added stuff to
-compile-all to invoke it.
-
-
-
-10/9/92 to 10/21/92:
-
-Compiler:
-
-Changed %MORE-ARG-CONTEXT to be a :translate instead of a def-source-
-transform to get rid of one more use of %primitive.
-
-Changed MOVE-FROM-mumble-FLOAT to do the st[d]f after the pseudo-atomic so
-that if we take a trap, we won't try to handle it while pseudo-atomic is
-active.  [Sparc only]
-
-Removed definitions for primitive types random and interior because they
-arn't needed anymore.
-
-Couple patches from Miles to make the disassembler work better when
-disassembling into a trace file during a compile-file.
-
-
-C Runtime Support:
-
-When we get a trap_PendingInterrupt, skip over the breakpoint instruction.
-Otherwise, we will try to handle the signal again and again.
-
-When done fixing up after a pseudo-atomic-interrupted, skip past the
-tagged-add instruction.  Otherwise, we turn pseudo-atomic off twice, which
-results in it being left on, which confuses the garbage collector.  [Sparc
-only.]
-
-
-9/29/92 to 10/9/92
-
-Added arch specific routine SANCTIFY-FOR-EXECUTION that is suppowed to do
-whatever cache magic is necessary to make it so we can execute newly
-created code objects, and changed load and in-core compile to call it.
-[This is needed for the HP port.]
-
-
-9/25/92 to 9/29/92
-
-Compiler fix to inline expansion of functions in non-null environments.
-Recompiled CLX with this fix so that it works again.
-Fix to the MAKE-LOAD-FORM for hash-tables to actually work.
-
-
-9/7/92 to 9/25/92
-
-Code changes:
- -- Various C code changes.
- -- Changed PROFILE argument count determination to parse the function type and
-    look at it, instead of trying to fake it.  Among other things, this allows
-    efficient profiling of functions with FTYPE declarations even when
-    compilation policy has caused the function-object's type to be dropped.
- -- In SERVE-EVENT, fixed WAIT-UNTIL-FD-USABLE to correctly borrow from the
-    timeout seconds when computing the new value for the timeout microseconds
-    and it is negative.
- -- Added interpreter stub for VALUE-CELL-REF (for interpreted
-    LOAD-TIME-VALUE).
- -- Fixed MAKE-INTERPRETED-FUNCTION to pass the arglist in so that it is
-    available to DESCRIBE.
-
-Compiler:
-
-It is now possible to inline expand global functions which are defined in a a
-not-completely-empty environment information (containing local macros, etc.)
-Inline expansion now works for local and block-compiled functions.  Now
-local-call conversion is responsible for copying lambdas for copy-per-call
-inlining.
-
-DEFUN handling has been totally rewritten.  Semi-inline expansion now has
-exactly the same semantics as introducing a non-entry-point copy of the
-function into the current compilation block.  A new DEFINED-FUNCTION leaf is
-entered in *FREE-FUNCTIONS* to represent functions which either have inline
-expansions or are defined in the current compilation block.  This allowed the
-implementation of block compilation and inline expansion to be cleaned up.
-
-The new variable EXT:*INLINE-EXPANSION-LIMIT* controls the maximum number of
-inline expansions done in a given function (or block compilation.)  This serves
-to keep inline expansions of recursive functions from crashing the compiler.
-
-Added block compilation declarations to ir1 conversion and optimization.  Moved
-some stuff around to get better locality.  Substantially revamped known call
-reoptimization so that more code is sharable with ir1-conversion.  Formerly
-some stuff (like inline expansion) only happend at ir1-conversion time.
-Some other minor compile speed tweaks such as declaring some simple utilities
-inline.
-
-Compiler bug fixes:
- -- Added a hack to IF-IF optimization to prevent some spurious unreachable
-    code notes.
- -- Fixed the code which converts "assignment" lets to ordinary lets to
-    actually work.
- -- Merged William's change to load-time-value to not include make-value-cell
-    in the name.
- -- Don't compile load-time-value lambdas if they've already been compiled
-    because they ended up in a non-top-level component.
- -- Don't run the back-end(s) on components with no code.
- -- Fixed START-BLOCK, END-BLOCK and recognized declarations to be ignored in
-    %PROCLAIM (they only make it that far when called by the interpreter.
-    Changed the unrecognized proclamation error to be a warning.
- -- instruction scheduler fixes.
-
-
-8/17/92 to 9/7/92  [PMAX only]
-
-Code:
-
-Changed the way continuing from breakpoints is implemented.  It should work
-in more cases, and be easier to port to other machines now.
-
-When printing the initial frame in the debugger, ignore errors that occur
-while looking for the source.
-
-Changed DOLIST not to introduce the spurious let around the result form when
-there is no result form.  Also, just read the var in the spurious let, instead
-of using IGNORABLE, since the var might be special.
-
-
-Compiler:
-
-Re-worked some aspects of how the various compiler backends are defined in
-order to make the compiler more compact.
-
-Fixed several bugs left over from the pmax ``improvements.''
-
-Picked up several disassembler fixes from Miles.
-
-
-
-8/4/92 to 8/17/92
-
-Many low level interal improvements for the pmax.  None of this is user
-visable, except that allocation should be faster.  *** Note: these internal
-changes require all files to be recompiled.  If you try to load an old fasl
-file, you will get an error message to this effect.
-
-
-Code:
-
-Changed backq-list, etc., from being inline functions to compiler-macros, since
-although the optimizer does eventually get the right code, it has to work awful
-hard.
-
-When groveling a defmacro lambda list, check to see if some part is a LIST
-before checking to see if it is a SYMBOL, because we want NIL to act like
-the empty list, and not an attempt to bind NIL.
-
-Fixed quote-string to stop at the fill pointer for strings with fill
-pointers.
-
-In %defsetf, don't bother creating temp vars for constants.  This is
-necessary so that keywords stay keywords, and are not changed to gensyms.
-
-Set *ENVIRONMENT-LIST* to NIL before we start to push things on it in
-ENVIRONMENT-INIT so that we don't keep around the old values.
-
-Changed GET-INTERNAL-RUN-TIME to use UNIX-FAST-GETRUSAGE to avoid
-number-consing and generic arithmetic.  Also, rearranged the computation so
-that the time is correctly computed for up to 457 days, instead of only 71
-minutes.
-
-Added UNIX-FAST-GETRUSAGE which is inline, only returns the system and user
-time, and returns them as seconds and microseconds.
-
-
-Compiler:
-
-Fixed a problem with conflict analysis of :more TNs (which are created
-when a single vop has ~>= 50 operands.)
-
-
-PCL:
-
-Don't clobber DEFINE-COMPILER-MACRO, because we have it now.
-
-
-
-7/31/92 to 8/4/92
-
-[SPARC only]
-
-Fixes to bit-bash and compiler to get bit-bash to stop consing.
-
-July 92 beta PCL.  Mostly MOP and ANSI enhancements, and some tweaks to
-structure-class support.
-
-Fixed debugger VPRINT command to actually be verbose again.
-
-Flushed old-assembler stuff, and import new-assem stuff directly into the C
-package.  Various tweaks for the byte compiler and instruction scheduler.
-
-If we discover a FUNCALL to an inline function, convert it (unless it is a SETF
-function.)
-
-Gag bound-but-not-referenced warnings when brevity = 3.
-
-
-7/24/92 to 7/31/92
-
-[SunOS SPARC only]
-
-Code:
-
-Fixed OUTPUT-SYMBOL to no longer call CHECK-FOR-CIRCULARITY now that
-OUTPUT-OBJECT does it for us.  This was causing gensyms to print as #1=#1#
-when *PRINT-CIRCLE* was T.
-
-In FORCE-PRETTY-OUTPUT, EXPAND-TABS before outputing the output buffer.
-
-Fixed RUN-PROGRAM to know that UNIX-FORK returns NIL, not -1, when it
-fails.
-
-Hacked over unix-select to actually work with nfds>32 and to be more
-effecient in that case.
-
-Fixed UNIX-FORK to actually return the error code when it fails.
-
-
-Compiler:
-
-Flushed old assembler.
-
-Changed NATIVE-COMPILE-COMPONENT to output the disassembly to the trace
-file, and added DISASSEM:DISASSEMBLE-BLOCKS, which actually does it.
-
-Moved the (compiler-mumble "~&") from native-compile-component to compile-
-component, so it happens when byte compiling also.
-
-Added stream argument to two write-char's in DISASSEM's
-PRINT-CURRENT-ADDRESS where it was left out.
-
-Several changes to the new assembler in preperation to running the
-instruction scheduler and supporting the disassembler.
-
-
-
-7/7/92 to 7/24/92
-
-[SunOS SPARC only.]
-
-Code:
-
-Many improvements to the debugger:
-- Exported variables *use-block-starts-only* and *print-code-location-kind*
-which control the verbosity of LIST-LOCATIONS.
-- Imroved source file organization.
-- Changed PRINT-FRAME-CALL to print the source if verbosity >= 2 and the
-source is available. 
-- Removed mentions of *current-code-location*, which was only set, never read.
-- Changed source location printing to cache information so that it is much
-faster when many locations in the same function are printed.
-- The source file is now only printed when the file changes from one 
-printing to the next.
-- The format of LIST-LOCATIONS is now more readable.  The number: comes
-before the form, and consecutive locations with the same souce print as
-ranges, not as multiple lines.
-
-Changed BREAK to accept a condition as well as a format string.
-
-Changed default base file name for LOAD-FOREIGN to be the name used to run
-lisp, and not "lisp".
-
-Changed INSPECT::PLAN-DISPLAY-OBJECT to use WITH-SLOTS instead of
-accessors, since those accessors don't seem to exist anymore.
-
-Added code to support CONNECT-TO-UNIX-SOCKET so that Unix domain sockets
-are available for connecting to other processes.
-
-Changed timeout handling in SERVE-EVENT to work for non-integer timeouts.
-Moved WAIT-UNTIL-FD-USABLE into the SERVE-EVENT block so that it could
-share timeout hackery.  Compiled with efficiency notes & tweaked
-declarations.  Broke SERVE-EVENT into a couple of functions for
-readability.
-
-Changed #a reader to allow arbitrary sequences instead of just lists.
-
-Merged Olssons fix to WITH-ENABLED-INTERRUPTS now that it doesn't change
-interrupt characters anymore.
-
-Changed NTRACE to use PRINT-FRAME-CALL instead of the internal
-PRINT-CALL-FRAME-1.
-
-Added new SYSCALL* macro which signals an error instead of returing errno.
-Changed gettimeofday and rusage to use this version.  Changed timeval slots to
-be long, not unsigned-long, since they really are, and this simplifies
-representation problems.
-
-Fixed unix-select to shift the masks by -32 instead of shifting -32 by the
-masks.
-
-
-Compiler:
-
-Code generation changed to use the new assembler.
-
-Don't call CONTINUATION-CHECK-TYPES if PROBABLE-TYPE-CHECK-P returns NIL.
-This lets type checking assume that the continuation does have a DEST,
-and also avoids some unnecessary work.
-
-Fixed dump-1-location to also take integer positions directly, instead of
-always requiring labels.
-
-Added checking for potentially TR local calls with different tail sets.  Added
-BARF restart which allows conditional ignoring of particular error messages.
-
-Fixed IR2-CONVERT-ENTRY to correctly handle tagbodies with more than one tag
-that is non-locally exited to.
-
-MERGE-TAIL-SETS before potential let-conversion so that we will
-correctly recognize all tail calls.  Make the analogous change to
-CONVERT-MV-CALL.
-
-Fixed DUMP-DATA-MAYBE-BYTE-SWAPPING to work.  [Needed for cross compiling.]
-
-In the new assembler, fixed FORGET-OUTPUT-BLOCKS to also reset
-*ALL-OUTPUT-BLOCKS*.  When using ADJUST-ARRAY to extent the vector of
-OUTPUT-BLOCKS, spec the initial-element as nil so it doesn't just leave the
-0's behind.
-
-
-Tools:
-
-Change $* to $@ in sample-wrapper.
-
-When compiling the compiler, keep a bit more safety and debug-info when
-#-small.
-
-
-CLX:
-
-Fixed fast pixarray functions to return T when they do something.
-
-Fixed copy-bit-rect to correctly compute indices for bit-bash-copy
-so that it will actually work.
-
-Fixed ANGLEP to test for being a real before it assumes it is.
-
-Fixed several places where values that could really be negative were 
-declared to be array-indices.
-
-
-Documentation, etc.
-
-Clarified that CMUCL_EMPTYFILE must be a file in sunos-README.
-
-Update for new TR number, use cmu-titlepage style.
-
-Added new debugger breakpoint commands and new trace documentation.
-
-Ran spell checker.
-
-Fixed various minor formatting problems, especially w.r.t description
-environments.
-
-Updated debugger documentation to describe the prefix-completing command
-parser (which has been in for quite a while.)
-
-Incorporated Paul's suggested improvements in the debugger and aliens
-chapters.
-
-Updated indexing to make much greater use of subindexing.
-
-
-
-6/22/92 to 7/7/92
-
-Code:
-
-Added debugger commands to manipulate breakpoints.  See the debugger help
-string for details.
-
-Changed the type of *TOTAL-BYTES-CONSED* from fixnum to integer because it
-is very easy to cons more than most-positive-fixnum bytes.  It just takes a
-while.
-
-Added some type declarations so that a call to make-array in
-make-hash-table gets open coded.
-
-Removed *task-data* and *task-notify* because they aren't used, and I have
-no idea what they should be changed to under mach 3.0.
-
-
-Compiler:
-
-Fixed MAKE-LOAD-TIME-CONSTANT-TN to quit looking once it found an matching
-constant, so that it actually uses the same constant slot for the same
-value.
-
-
-
-6/15/92 to 6/22/92
-
-Code:
-
-Fixed PACKAGE-ERROR to have a PACKAGE slot instead of a PATHNAME slot. 
-
-Two changes to DEBUG-INTERNALS to support breakpoint debugger commands:
-- Added CODE-LOCATION-KIND.
-- Changed HANDLE-BREAKPOINT-AUX to correctly handle the case in which all
-breakpoints at a location are deactivated and then at least one is
-activated within the hook functions.
-
-
-Compiler:
-
-Changed the defknown for PACKAGE-NAME to include NIL as a possible result,
-because that is what it is supposed to return after the package is fed
-to DELETE-PACKAGE.
-
-More internal changes to for the HP PA-RISC 1.1 port.
-
-
-
-6/12/92 to 6/15/92
-
-Code:
-
-Reworked the internals of circularity detection and depth abbreviation.
-Structure print-functions that use PPRINT-LOGICAL-BLOCK will no longer be
-counted as as two levels against *PRINT-LEVEL*, and will no longer be
-printed as #1=#1# when *PRINT-CIRCLE* is set.  Also, printing various
-condition structures (for example, TYPE-ERROR) will no longer flame out
-when *PRINT-CIRCLE* is set.
-
-Note: any uses of PPRINT-LOGICAL-BLOCK will have to be recompiled.
-
-
-
-6/3/92 to 6/12/92
-
-Code:
-
-Don't destructively modify the breakpoint list in SUB-ACTIVATE-BREAKPOINT so
-that any breakpoints activated while we are already at this location will not
-be processed this time around.
-
-Fixed dispatch macro characters to be case-insensitive, and to disallow digits
-as sub-characters.
-
-
-Compiler:
-
-Moved the page size into the backend structure.
-
-Changed not to barf if a block has no predecessors.  This really shouldn't
-happen, since we do DFO before constraint if it is needed, and that should
-flush any blocks with no predecessors (or that are otherwise unreachable), but
-it is happening...
-
-Moved tail-set merging out of IR1-OPTIMIZE-RETURN into LTN.  Changed
-MAYBE-DELETE-EXIT to call MERGE-TAIL-SETS.
-
-Set COMPONENT-REANALYZE in MAYBE-TERMINATE-BLOCK if we do terminate.
-
-Added setting of COMPONENT-REANALYZE all places where we do UNLINK-BLOCKS and
-might create dead code.
-
-Changed CONVERT-CALL-IF-POSSIBLE to not attempt to convert when the call is in
-a deleted function or a delete-p block.
-
-Moved tail-set merging here from IR1-OPTIMIZE-RETURN, since it wasn't being
-triggered reliably (and required IR1 optimization to run to completion for
-correctness.)  Now we merge tail sets whenever we convert a local call that
-delivers its value to a return (regardless of whether it is truly TR.)  This
-liberalization actually improves type inference: previously non-TR calls would
-mess up type inference.
-
-Now MERGE-TAIL-SETS must be called whenever IR1 is modified so that a local
-call is changed to be potentially tail recursive (i.e. deliver its value to a
-return.)  It seems that the only such place is in MAYBE-DELETE-EXIT in ir1opt.
-
-Changed to bind *features* to (backend-features *target-backend*) just
-before doing the read instead of binding *features* to (backend-features
-*backend*) for the duration of the compile.  This way, the compiler can use
-(backend-featurep :foo) to tell how to compile, and cross compilers can be
-compiled correctly with respect to #+foo.
-
-Fixed RANDOM derive-type method when the class is NIL, or is FLOAT and FORMAT
-is specified (need to get the right type of zero.)
-
-
-Hemlock:
-
-Couple fixes to dired:
-- Updated function merge-dirs to reflect updated pathname-directory returns a 
-list rather than a simple vector and amended its use of make-pathname to
-set :device argument to :unspecific rather than :absolute.
-- In set-write-date spliced in the *utimes-buffer* list into the
-unix:unix-utimes function call.
-
-
-CLX:
-
-Fixed ANGLE to handle ratios.  In now discards all unnecessary precision
-when doing the bounds check.
-
-
-PCL:
-
-Fixed function environment hackery to work even when *LEXICAL-ENVIRONMENT* is
-NIL (i.e. we aren't in the compiler.)
-
-
-
-5/25/92 to 6/3/92
-
-New PCL, version March 92 2a.  Supposed to have many bug fixes and some
-performance enhancements.
-
-Code:
-
-Merged Mile's fix to MAKE-PATHNAME so that it knows the difference between
-an arg being NIL and being unsupplied.
-
-Fixed ACTIVATE-BREAKPOINT to build the breakpoints list in forward order to
-preserve the desired hook invocation order.
-
-Made function-end breakpoints for known-return functions signal an error, since
-they aren't implemented.
-
-Defined new parameterized PRINT-HERALD, exported *HERALD-ITEMS*.  Doc for
-*herald-items*:
-   Determines what PRINT-HERALD prints (the system startup banner.)  This is a
-   database which can be augmented by each loaded system.  The format is a
-   property list which maps from subsystem names to the banner information for
-   that system.  This list can be manipulated with GETF -- entries are printed
-   in, reverse order, so the newest entry is printed last.  Usually the system
-   feature keyword is used as the system name.  A given banner is a list of
-   strings and functions (or function names).  Strings are printed, and
-   functions are called with an output stream argument.
-
-Trace has been substantially rewritten, and has a new syntax as well as new
-functionality.  It now subsumes the old encapsulation-based trace via the
-:ENCAPSULATE option.  Interpreted functions and generic functions are traced
-via encapsulation by default, which works.  Conditional stuff works much
-better.  *debug-print-level* is used instead of a separate
-*trace-print-level*.  Here is the new doc string:
-   TRACE {Option Global-Value}* {Name {Option Value}*}*
-   TRACE is a debugging tool that prints information when specified functions
-   are called.  In its simplest form:
-       (trace Name-1 Name-2 ...)
-
-   TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named
-   functions is entered or returns (the Names are not evaluated.)  The output
-   is indented according to the number of pending traced calls, and this trace
-   depth is printed at the beginning of each line of output.
-
-   Options allow modification of the default behavior.  Each option is a pair
-   of an option keyword and a value form.  Options may be interspersed with
-   function names.  Options only affect tracing of the function whose name they
-   appear immediately after.  Global options are specified before the first
-   name, and affect all functions traced by a given use of TRACE.
-
-   The following options are defined:
-
-   :CONDITION Form
-   :CONDITION-AFTER Form
-   :CONDITION-ALL Form
-       If :CONDITION is specified, then TRACE does nothing unless Form
-       evaluates to true at the time of the call.  :CONDITION-AFTER is
-       similar, but suppresses the initial printout, and is tested when the
-       function returns.  :CONDITION-ALL tries both before and after.
-
-   :WHEREIN Names
-       If specified, Names is a function name or list of names.  TRACE does
-       nothing unless a call to one of those functions encloses the call to
-       this function (i.e. it would appear in a backtrace.)  Anonymous
-       functions have string names like "DEFUN FOO".
-
-   :BREAK Form
-   :BREAK-AFTER Form
-   :BREAK-ALL Form
-       If specified, and Form evaluates to true, then the debugger is invoked
-       at the start of the function, at the end of the function, or both,
-       according to the respective option.
-
-   :PRINT Form
-   :PRINT-AFTER Form
-   :PRINT-ALL Form
-       In addition to the usual prinout, he result of evaluating Form is
-       printed at the start of the function, at the end of the function, or
-       both, according to the respective option.  Multiple print options cause
-       multiple values to be printed.
-
-   :FUNCTION Function-Form
-       This is a not really an option, but rather another way of specifying
-       what function to trace.  The Function-Form is evaluated immediately,
-       and the resulting function is traced.
-
-   :ENCAPSULATE {:DEFAULT | T | NIL}
-       If T, the tracing is done via encapsulation (redefining the function
-       name) rather than by modifying the function.  :DEFAULT is the default,
-       and means to use encapsulation for interpreted functions and funcallable
-       instances, breakpoints otherwise.  When encapsulation is used, forms are
-       *not* evaluated in the function's lexical environment, but DEBUG:ARG can
-       still be used.
-
-   :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment
-   of the called function; DEBUG:VAR and DEBUG:ARG can be used.  The -AFTER and
-   -ALL forms are evaluated in the null environment.
-
-
-Compiler:
-
-Fixed several uses of FIND to use EQUAL instead of EQL to compare function
-names, because (SETF mumble) is now a valid function name, and isn't
-necessarily EQL.
-
-More stuff in preperation for more ports and the byte-compiler.
-
-Changed NEW-BACKEND to call DEFINE-STANDARD-TYPE-PREDICATES to fill in
-the BACKEND-TYPE-PREDICATES and BACKEND-PREDICATE-TYPES slots.
-
-Fixed some bugs revealed by the new PCL and William's hackery.  Support for
-"assignments" (local functions used for iteration) was rather proken, and still
-has at least one problem.
-
-
-5/17/92 to 5/25/92
-
-Code:
-
-Lots of internal fixes to how breakpoints are handled.  There currently is
-nothing that uses this stuff, but it works better now.
-
-Fixed DEFPACKAGE not to loose when the :use option is specified.
-
-
-Compiler:
-
-More internal changes to help facilitate future ports.
-
-Internal changes to support the above mentioned breakpoint improvements.
-
-
-PCL
-
-Fixed a bug in WALK-ARGLIST where it would ignore the rest of the current
-arglist if the current arg destructured.  This was causing it to compile
-forms like:
-	(macrolet ((foo ((a b) c) ...)) ...)
-as:
-	(macrolet ((foo ((a b)) ...)) ...)
-note the loss of the arg c.
-
-
-Other:
-
-The loading of CLX and Hemlock has been changed to more easily allow
-loading them into cores originally built without them.
-
-
-
-4/30/92 to 5/17/92
-
-Code:
-
-Inline expand %MAKE-ALIEN and FREE-ALIEN to avoid spurious Alien-value consing.
-
-Changed DESCRIBE to allow T or NIL as the stream argument.
-
-Rewrote most of the hash table support:
-- MAKE-HASH-TABLE now conforms to the ANSI spec.
-- EQL hash tables now work with complex numbers, and better in general.
-- HASH-TABLE-mumble accessors now exist.
-
-Changed several uses of DEFINE-CONDITION to use the new syntax.
-
-Removed several extra )'s
-
-Changed several setfs of arguments that were inhibiting the compiler from
-using all the argument type information available for list and sequence
-functions.
-
-Changed IN-PACKAGE to conform to the new definition.  But if you use an
-old-style IN-PACKAGE, it will use the old behavior.
-
-Rewrote DEFPACKAGE to tell you about inconsistencies between the package
-and the DEFPACKAGE form.
-
-Rewrote the DO-mumble-SYMBOLS iterators in order to stamp out more uses of
-prog.  They now wrap the user body in an flet and then just use regular
-looping constructs to grovel through the packages.
-
-Several fixes to the new TRACE:
-- Fixed to actually allow tracing anonymous function objects.
-- Changed to allow tracing of macros.
-- When tracing an already traced function, untrace and retrace it, instead
-of ignoring the second request.
-- Moved the undefined error for UNTRACE to the UNTRACE-1 subfunction,
-instead of signalling it at macroexpand time.
-- In TRACE-1, added an assertion that there isn't already an entry in the
-trace breakpoint table, since sometimes we seem to be forgetting about
-breakpoints.
-
-
-Compiler:
-
-Several internal changes in preperation for supporting future ports.
-
-
-CLX:
-
-READ-BITMAP-FILE modified to decrement the indexed property :x-hot only if 
-non-nil and positive. If already negative, it is left unchanged to indicate
-that the bitmap has no hotspot.
-
-
-
-
-4/7/92 to 4/30/92
-
-**** FASL files have been incompatibly changed in this release.  You must
-recompile all your fasl files.
-
-
-Big Change:
-
-Function call is now different.  Specifically, named-call has been changed
-so that it can be used for both regular functions and setf functions.
-Named calls to setf functions are now just as efficient as named calls to
-regular functions.
-
-
-
-Code:
-
-Changed the handler-bind in debug-loop to not invoke the debugger directly.
-Otherwise, debug:*stack-top-hint* never gets set for errors received while
-debugging.
-
-Fixed MACROEXPAND-1 to pass the environment into MACRO-FUNCTION when
-checking to see if the form has a macro defintion.  Otherwise,
-macroexpanding macrolets doesn't work.
-
-Fixed doc string for maphash to indicate that it returns NIL instead of T.
-
-Changed the undefined-symbol-error handler to use fdefn-name to extract out
-the name from the fdefn object when its really a fdefn object that was
-undefined instead of a symbol.
-
-Added function-subtype and (setf function-subtype).  These functions can be
-used to retrieve and set the header type for functions and closures.
-
-Moved lots of exports from lispinit.lisp into the files that contain the
-thing being exported.  Moved the object-set stuff into serve-event.lisp.
-
-Added a call to GC-INIT to REINIT to facilitate making sure set-auto-gc-
-trigger gets called.
-
-Added the start of stuff necessary to support byte compiled functions.
-
-Export REALP from LISP now that it's a real function.  Minor tweek to
-bounds testing in %%typep of complex numbers.
-
-Chagned the unmatched close parenthesis warning to include the file
-position so that it is easier to track them down.
-
-
-Compiler:
-
-Lots of changes to support the new function call, and to fix bugs exposed
-by these changes.
-
-On the SPARC, fixed sap+ not to flame out when the second argument is an
-immediate that doesn't fit in a signed-byte 13 offset.
-
-Don't substitute out LET variables when the initial value is a reference to a
-:NOTINLINE functional.  The inlinep information must be retained, since we
-count on :NOTLININE calls never being local call converted.
-
-Removed some debugger code that accedently got left behind.
-
-Fixed SOURCE-TRANSFORM-STRUCTURE-TYPEP to return T-or-NIL in the frozen
-included case, and not some random non-null lists.
-
-
-
-3/29/92 to 4/7/92
-
-Code:
-
-Changed the default structure printer to print slot names as keywords
-instead of unqualified symbols as per X3J13 cleanup STRUCTURE-READ-PRINT-
-SYNTAX:KEYWORDS.
-
-Added COMPILER-MACRO-FUNCTION, COMPILER-MACROEXPAND, COMPILER-
-MACROEXPAND-1, and DEFINE-COMPILER-MACRO.
-
-Fixed things that invoke *MACROEXPAND-HOOK* to coerce it to a function
-before calling it as per X3J13 cleanup FUNCTION-TYPE:X3J13- MARCH-88 by
-introducing KERNEL:INVOKE-MACROEXPAND-HOOK, which does that and then
-funcalls it.
-
-Fixed MACRO-FUNCTION to take an environment argument as per X3J13 cleanup
-MACRO-FUNCTION-ENVIRONMENT:YES.
-
-Added BYTES-CONSED-BETWEEN-GCS, a function that returns (and sets when 
-used with setf) *BYTES-CONSED-BETWEEN-GCS*.  Additionally, it changes
-*GC-TRIGGER* immediately to reflect the new values of *bytes-consed...*.
-
-Changed GET-SETF-METHOD-MULTIPLE-VALUE to try to macroexpand-1 the form
-when it's an atom in case it's a symbol-macro as per the X3J13 cleanup
-SYMBOL-MACROLET-SEMANTICS:SPECIAL-FORM.  Now you can safely INCF, etc.
-symbol macros where the macroexpansion has side effects.
-
-Fixed SETF of GETF to evaluate the various parts in the correct order as
-per X3J13 cleanup SETF-SUB-METHODS:DELAYED-ACCESS-STORES.
-
-Fixed bug in NTH-VALUE where it expanded into bogus code unless ``n'' was a
-constant integer.
-
-X3J13 cleanup SETF-MULTIPLE-STORE-VARIABLES:
-
-  Extend the semantics of the macros SETF, PSETF, SHIFTF, ROTATEF, and
-  ASSERT to allow "places" whose SETF methods have more than one "store
-  variable".  In such cases, the macros accept as many values from the
-  newvalue form as there are store variables.  As usual, extra values
-  are ignored and missing values default to NIL.
-
-  Extend the long form of DEFSETF to allow the specification of more
-  than one "store variable", with the obvious semantics.
-
-  Clarify that GET-SETF-METHOD signals an error if there would be more
-  than one store-variable.
-
-Added real support for the REAL type.
-
-Export REALP from LISP now that it's a real function.  Minor tweek to
-bounds testing in %%typep of complex numbers.
-
-Changed the return value of SET-SYNTAX-FROM-CHAR from NIL to T as per X3J13
-cleanup RETURN-VALUES-UNSPECIFIED:SPECIFY.  [Hard to believe nobody has
-complained about not conforming to this one.]
-
-Removed the :enable-gc from save-lisp option, as it's no longer needed.
-
-Allow SHADOW to take strings in addition to symbols as per X3J13 cleanup
-SHADOW-ALREADY-PRESENT:WORKS.
-
-
-Compiler:
-
-Fixed a bug in DEFAULT-UNKNOWN-VALUES where it wasn't resetting the stack
-if between 2 and 6 (inclusive) values were expected.  Also, spiffed up the
-case where > 6 values were expected.  [On the RT, change 6 to 3]
-
-Fixed NUMERIC-CONTAGION with respect to (COMPLEX RATIONAL).
-
-Fixed the ``fold identity operation'' for *, /, and EXPT to no longer
-consider #C(0 1) identity.
-
-BARF is not return type NIL, since it calls CERROR.
-Fixed function consistency checking to work better on deleted functions.
-Added a condition handler in PRINT-ALL-BLOCKS.
-
-Fixed RETURN-VALUE-EFFICENCY-NOTE not to flame out when some functions in the
-tail set have no RETURN.
-
-Changed SUBSTITUTE-SINGLE-USE-CONTINUATION to not substitute if the
-continuation type assertions conflict.
-
-Added optimization which deletes MV-BINDS when all variables have been deleted.
-
-Minor tweeks to conform to X3J13 cleanup MACRO-DECLARATIONS:MAKE-EXPLICIT.
-
-Added noise to support compiler-macros.  Removed #+/- new-compiler
-conditialization.
-
-Fixed SYMBOL-MACROLET to allow declarations as per X3J13 cleanup SYMBOL-
-MACROLET-DECLARE:ALLOW.  When declaring things about symbol macros, type
-declarations just wrap (the type ...) around the expansion, special
-declarations signal an error, and ignore/ignorable declarations are
-ignored.
-
-Apply global function type declarations to calls and definitions of global
-inline functions.
-
-Changed CONVERT-AND-MAYBE-COMPILE to temporarily increate *bytes-consed-
-between-gcs* by a factor of 4 instead of turning off all garbage
-collection.
-
-
-Construction Tools:
-
-Changed the way the garbage collector gets turned on.
-
-
-
-
-3/23/92 to 3/29/92
-
-Code:
-
-Adjust-array has been updated to be ANSI compliant by allowing arrays which
-were not created with :adjustable non-nil to be adjusted to new dimensions.
-
-Adjustable-array-p has been updated to ANSI standards. It returns T if adjust
-ADJUST-ARRAY would return an EQ array.
-
-Fixed DESCRIBE of alien variables.
-
-Fixed EVAL of alien variables.  We just hand it off to the real
-interpreter.
-
-Fixed DEFINE-CONDITION to clean up the slot description before handing it
-to defstruct now that defstruct is less forgiving.
-
-Added EXT:BYTES-CONSED-BETWEEN-GCS, a function that returns (and sets when 
-used with setf) *BYTES-CONSED-BETWEEN-GCS*.  Additionally, it changes
-*GC-TRIGGER* immediately to reflect the new values of *bytes-consed...*.
-
-Added GC-INIT to facilitate making sure set-auto-gc-trigger.
-
-Changed ROOM-MINIMAL-INFO to print everything that doesn't use
-map-allocated-objects and also to indicate whether or not the garbage
-collector is currenty on or off.
-
-Fixed FIND-INTERRUPTED-FRAME to FLUSH-FRAMES-ABOVE before returning the
-frame.
-
-Changed PURIFY to bind *INTERNAL-GC* and then invoke the garbage collector
-so all the auxiliary stuff (hooks, etc.) gets handled correctly.
-
-Removed the :ENABLE-GC option from SAVE-LISP, as it's no longer needed.
-
-
-Compiler:
-
-Rewrote the way pseudo-atomic works for the SPARCs.  Hence, all sparc fasl
-files will have to be recompiled.  An error will be signaled if you try to
-load an old fasl file.  [SPARC only]
-
-Fixed {alloc,dealloc}-number-stack-space to work with large amounts.
-
-Changed CONVERT-AND-MAYBE-COMPILE to temporarily increate *bytes-consed-
-between-gcs* by a factor of 4 instead of turning off all garbage
-collection.
-
-Rewrote the ub-32 logcount vop.  The new version uses an O(log2 32) algo.
-resulting in 30 cycles (no branches).  The old version used an O(n) algo.
-where n was the integer-length of the argument, resulting in somewhere
-between 4 and 130 cycles.  [MIPS only]
-
-
-
-3/7/92 to 3/23/92
-
-Code:
-
-Several debugger improvements:
-- The debugger now checks a new special DEBUG:*STACK-TOP-HINT* for a hint
-as to what it should use for the top of the stack.  INTERNAL-ERROR, ERROR,
-BREAK, etc. all bind this before calling INVOKE-DEBUGGER so that there are
-not zillions of irrelevent stack frames at the top of the stack.
-- Fixed def-debugger-command to remove the old definition when a command
-is redefined.
-- Merged Miles' changes that allow the use of restart names as debugger
-commands.
-- Added ``DESCRIBE'' debugger command, which calls DESCRIBE on the function
-in the current frame.
-
-Two fixes/changes to the new breakpoint based trace facility:
-- Protected function-end-cookie-valid-p against running across interpreted
-frames.  This was causing it to flame out.
-- Don't bother warning about dynamic flow of control, because it is obvious
-from the call depth numbers and the warning can happen at real confusing
-times.
-
-More DEFSTRUCT changes:
-- Make stuff work when conc-names make a subtype slot accessor have the
-same name as the supertype accessor.
-- Fixed PARSE-1-DSD to correctly recognize conc-name accessor duplication
-when there is multi-level inheritance.  Now we look at the ACCESSOR-FOR
-info and see if it is an accessor for the same slot.
-- In PARSE-1-DSD, don't blow away the accessor when we are just redefining
-the same structure.  For shadowing to be a problem, the accessor must be of
-a supertype.
-- In DSD-NAME, intern the symbol in *PACKAGE* if the accessor is NIL.  
-- In DEFAULT-STRUCTURE-PRINT, directly use DSD-%NAME, rather than messing
-around creating a symbol.
-
-A few more improvements to the new aliens stuff.
-
-Declare the BACKQ-mumble's INLINE to avoid gratuitous pessimization.
-
-Fixed define-condition to clean up the slot description before handing it
-to defstruct now that defstruct is less forgiving.
-
-Added partial support for FDEFN objects.
-
-Export FEATUREP from EXT.
-
-Changed WITH-SYMBOL package hashtable lookup to not repeated call REM when
-going down a collision chain.
-
-In TIME, fixed display of consing and page faults in the case where no GC time
-is displayed.
-
-Added SEARCH-LIST-DEFINED-P, a predicate that tells if the search list is
-currently defined.
-
-
-Compiler:
-
-Redid the way compiler backend specific data structures are accessed to
-simplify changing the set of backend specific data structures.
-
-
-Hemlock:
-
-Fixed GET-EDITOR-TTY-INPUT to read the data into an c-call:unsigned-char
-buffer instead of a c-call:char so that when we access the elements from
-it, we don't get negative numbers, which make code-char unhappy.
-
-
-C runtime support code:
-
-Fixed a bug in os_allocate_at that was causing load-foreign to lose.
-
-
-Construction scripts:
-
-Changed ``mk-lisp'' to pause for 5 minutes before actually building the
-core to allow people to clear out.  This can be overridden by supplying
-``-now'' as the first argument.
-
-
-
-
-3/4/92 to 3/7/92
-
-Code:
-
-Several new-aliens changes:
-- Export SYSTEM-AREA-POINTER from ALIEN for consistency.
-- Export MAKE-ALIEN and FREE-ALIEN from ALIEN.
-- Export ALIEN-VALUE-TYPE from ALIEN-INTERNALS so that TYPE-OF can use it.
-- Changed ALIEN-VALUE printer to be less verbose.
-- Implemented %MAKE-ALIEN and FREE-ALIEN using malloc/free.  Changed MAKE-ALIEN
-to accept an alien-type object as well as an Alien type descriptor.
-- Now that we've implemented FREE-ALIEN, finalize the Aliens created by
-interpreted WITH-ALIEN. 
-- Added an (OPTIMIZE-INTERFACE (SAFETY 2)) declaration on %CAST so that we get
-a better type error message.
-- Added NULL-ALIEN and many doc-strings.
-- Allow (* char) in the c-string lisp-rep as well.
-- Allow storing of (* char) in c-strings so that we can initialize c-string
-variables and slots.
-- Added support in TYPE-OF for alien-value structures.
-
-Added compiled-debug-function branch to DI:DEBUG-FUNCTION-FUNCTION.
-
-Changed a few places where ESCAPE-REGISTER was left over to
-VM:SIGCONTEXT-REGISTER.  This was causing function-end breakpoints
-to die.
-
-Added Miles' changes to keep errors and warnings on one line if they fit.
-
-Added Miles' stuff to use the same stream for input and output if they are
-the same file descriptor.  This makes CHAR-POS work after input.
-
-Changed LOAD-FOREIGN to be exported from ALIEN.  Changed it have keyword args
-instead of optionals.  Deleted obsolete linker argument.
-
-Added Miles' stuff to diddle the child's pgrp for better signal handling in
-EXT:RUN-PROGRAM.
-
-Fixed UNIX-IOCTL to not flame out of the cmd is a ub-32 instead of a sb-32.
-
-Added Miles' UNIX:TCSETPGRP, UNIX:TCGETPGRP, and UNIX:TTY-PROCESS-GROUP.
-
-
-Compiler:
-
-Picked up a SPARC specific assembly routine call improvement from Miles.
-
-Miles' fixes to make disassembling [mc][tf]c1 work on the PMAX.
-
-
-Hemlock:
-
-Fixed GET-EDITOR-TTY-INPUT to read the data into an c-call:unsigned-char
-buffer instead of a c-call:char so that when we access the elements from
-it, we don't get negative numbers, which make code-char unhappy.
-
-
-C Runtime Support:
-
-Fixed function-end breakpoints for the sparc.
-
-
-
-3/2/92 to 3/4/92  [16a]
-
-Code:
-
-Fixed a major bug in def-alien-type where the macroexpansion wouldn't
-include the code to define the type if the type was defined at compile
-time.
-
-Allow LISP:AND, LISP:OR, and LISP:NOT in features lists in addition to
-:AND, :OR, and :NOT.  This makes FEATUREP useful outside of #+ and #-.
-
-Added ``:verbose nil'' to the load of site-init.lisp.
-
-
-C Runtime support:
-
-Whenever we allocate a chunk of memory, set the protections to include
-VM_PROT_EXECUTE so that we can execute code on it.
-
-
-
-2/24/92 to 3/2/92
-
-Code:
-
-Added some dimension type checking to parsing of alien array types.
-
-Fixed a bug where the size of single-floats and double-floats wasn't know
-by the new aliens stuff.
-
-Really make sure compute-time-overhead-ax has function type info in
-profile.
-
-Reworked the SETQ branch of EVAL to pass more cases (like setting alien
-vars or constants) off to the real interpreter.
-
-Fixed FMAKUNBOUND to return the symbol instead of T.
-
-Moved OS-INIT into mumble-os.lisp, so that different OSes can do different
-things for initialization.
-
-SET now protects against setting T, NIL, and keywords.  (SETF
-SYMBOL-FUNCTION) now expands into FSET, which protects against defining
-NIL.  %SET-SYMBOL-PACKAGE is a new function that sets the symbol package.
-%SP-SET-PLIST has been renamed %SET-SYMBOL-PLIST.
-
-Fixed the ``mumble doesn't start with a search-list'' error message.
-
-Fixed the MIPS disassembler OR control to look at the RT field instead of
-the RD field.
-
-
-Compiler:
-
-Weakened component kind type assertion in JOIN-COMPONENTS.
-
-Changed the %DEFCONSTANT transform to protect against trying to change T,
-NIL, or keywords.
-
-Changed LET* and &AUX to allow duplicate variable names.
-
-Re-wrote the SAP-REF-mumble VOPs for better immediate support.
-
-
-CLX:
-
-Don't try to set char-bits for CMU, because we don't have any.
-
-
-C runtime support:
-
-Instead of using os_zero to zero the control stack after a GC, fill it with
-zeros ourselves.
-
-Whenever we allocate a chunk of memory, set the protections to include
-VM_PROT_EXECUTE so that we can execute code on it.  This is so we can run
-under MACH 3.0.
-
-
-
-2/18/92 to 2/23/92
-
-Code:
-
-Several bug fixes to the new alien stuff.
-
-All SAP-REF-mumble functions now uniformly take the offset argument in
-bytes.
-
-Changed *LOAD-VERBOSE* initial value to T.
-
-Added *GC-RUN-TIME* accounting.  Added some declarations, primarily for the
-benefit of GET-BYTES-CONSED.
-
-Changed TIME to use *GC-RUN-TIME* to print the amount of time spent in GC.
-
-Allow search-lists to expand into relative pathnames by quietly merging
-them with ``default:''.
-
-
-Compiler:
-
-Added a new DEFTRANSFORM keyword, :IMPORTANT, which means an failed
-transform efficiency note should be generated when brevity<=speed, not just
-brevity<speed.
-
-Added an assertion that we don't join components with random kinds.
-
-Bind *PRINT-LINES* around compiler error output to *ERROR-PRINT-LINES*.
-
-Make DELETE-COMPONENT set COMPONENT-KIND to :DELETED so that we can detect
-inconsistencies more easily.
-
-When checking if the call we are about to convert is going to be deleted, look
-at the block holding the combination, not the ref, since the combination may be
-deleted when the ref isn't.
-
-
-
-
-2/12/92 to 2/18/92
-
-Aliens and the foreign function call interface have been totally
-re-designed and re-written.  Therefore, anything using aliens will have to
-be re-written.  Complete docs are forthcomming.
-
-Additional changes are as follows:
-
-Code:
-
-The USER package has been renamed COMMON-LISP-USER (with USER as a
-nickname) to go along with the LISP->COMMON-LISP rename.
-
-Unix system calls are no longer in the MACH package, but in a new package
-named UNIX.
-
-UNIX-DUP now returns the new FD as the first return value instead of the
-second to be more consistent with the other system calls.
-
-You can no longer pass UNIX-READ a string (or any other vector).  If you
-really want to do this, do something like:
-	(system:without-gcing
-	 (unix:unix-read fd (system:vector-sap string) ...))
-Before, if someone interrupted the read, GCed, and then restarted the read,
-it would have read into the wrong place.
-
-Fixed FORMAT to print the floating point exponent in decimal irrespective
-of *PRINT-BASE*.
-
-The initial value of *LOAD-VERBOSE* is now T.  Additional, LOAD no longer
-always binds *LOAD-VERBOSE* and *LOAD-PRINT-STUFF*.  Now it only binds them
-when :verbose or :print are explicity supplied.  Therefore, you can set
-either of these in your init file and it will take effect.
-
-LOAD is less verbose when *LOAD-VERBOSE* is T.  Specifically, it just
-prints the filename that was loaded (if it can be figured out).
-
-Added ANSI features *LOAD-TRUENAME*, *LOAD-PATHNAME* and *LOAD-PRINT*.
-
-As per ANSI, bind *READTABLE* to itself to make assignments file-local.
-
-Added new variables EXT:*SOURCE-FILE-TYPES* and EXT:*OBJECT-FILE-TYPES*.  When
-no file type is specified, LOAD tries the types in these lists to locate the
-source and object files.  LOAD now recognizes source types "l", "cl" and "lsp"
-in addition to "lisp".
-
-The compiler OPTIMIZE policy is now bound during load, so proclamations in a
-file don't leave the global policy clobbered when the load is finished.
-
-Changed the :IF-SOURCE-NEWER option to signal an error and use restarts, rather
-than PROMPT-FOR-Y-OR-N.  Fixed the load source case to actually load the
-source, rather than loading the object as a source file...
-
-Changed load to deal with source files having NIL type more reasonably.
-
-Added support for wild pathnames in load.
-
-Improved handling of nonexistent files, in particular, don't always assume
-that missing files are source files.  Added condition restarts for missing
-files.
-
-Improved formatting of error and warning messages.
-
-PRINT-UNREADABLE-OBJECT returns NIL, not #\>
-
-Changed FLONUM-TO-STRING to consider widths < 1 to be 1 to prevent infinite
-looping in those cases.
-
-Print the package name instead of NIL when we can't find a package in symbol
-reading.  Also, read |LISP|::cons as CONS, not |cons|.
-
-Replaces {alloc,realloc,dealloc}ate-system-memory with versions that use
-the routines exported by os.c instead of MACH specific vm_allocate.
-
-Changed pointer< and pointer> to sap< and sap>.
-
-
-Compiler:
-
-Fixed a bug that caused an internal error when a never-referenced function
-(e.g. from FLET) had non-local exit code in it.
-
-Fixed spelling of "efficency" in several function names.
-
-Print a error summary even when *compile-verbose* is false.  (This is only
-printed when there are errors, so this doesn't seem a violation of the spirit
-of the spec.)
-
-
-Hemlock:
-
-Removed all RFS authentication stuff from the MH interface, because
-kerberose handles it for us now.
-
-
-
-2/3/92 to 2/12/92
-
-Code:
-
-Several changes to the reader.  Specifically:
-- READTABLE-CASE is now supported.
-- Several bugs with respect to #+, #-, #n=, and #n# have been fixed.
-- The reader now signals the correct type of error when things go wrong
-instead of always signaling a simple-error.
-- Export new variable *ignore-extra-close-parentheses* if true (the
-default), extra close parens are only a warning, not an error.  They used
-to be quietly ignored.
-- # is now a non-terminating macro character, so foo#bar is read as a
-symbol.
-- Added Ted's changes to make INTERNAL-READ-EXTENDED-TOKEN work when there
-are `|' escapes.  The main significance of this is that #+nil '|foo;bar|
-and #:|foobar| now work properly.  Also change this function to recognize
-unquoted colons so that #:foo:bar will error, but not #:foo\:bar.
-
-Print unbound-markers to the correct stream instead of always printing them
-to *standard-output*.
-
-Added UPGRADED-COMPLEX-PART-TYPE and UPGRADED-ARRAY-ELEMENT-TYPE.
-
-Fixed (typep x '(and ...)) to not always return NIL.
-
-When restarting a core, process the command line before printing the herald
-so that we can eval some form and quit without printing anything.
-
-Added exports for LEAST-NEGATIVE-NORMALIZED-mumble-FLOAT.
-
-The ``LISP'' package has been renamed ``COMMON-LISP'' with the nicknames
-``LISP'' and ``CL.''
-
-
-Compiler:
-
-Don't look at the LAMBDA-TAIL-SET of deleted functions to find out the result
-type, because there isn't any.
-
-Changed LET* and &AUX to allow duplicate variable names.
-
-Properly qualify kernel::*values-specifier-type-cache-vector* in BOUNDP check
-in %NOTE-TYPE-DEFINED.  We were never clearing the cache.
-
-More tweaking of arithmetic identities.   (* x 0) transform is also
-rational-specific.  Include CONSTANT-ARGUMENT in various arg type restrictions
-so that we don't get silly efficiency notes.
-
-Changed multiplier recoding to left-associate the sum so that we are less
-likely to run out of non-descriptor registers.
-
-
-
-1/26/92 to 2/3/92
-
-Fixed filename parsing to correctly handle "/foo".
-
-Changed NCONC to signal an error if a non-null ATOM appears other than as the
-last argument.
-
-Fixed PPRINT to call OUT-SYNONYM-OF on it's stream argument so that it will
-actually work for the ``streams'' T and NIL.
-
-Fixed profile to work again now that argument information may be omitted (due
-to low debug info.)  First of all, don't seg-fault on functions w/o arg info;
-print a warning instead, and assume arbitrary args.  Also, determine the
-precise arg counts for closures and funcallable instances (generic functions.)
-
-Fixed some DIRED bugs resulting from the new pathname changes.
-
-Compiler:
-
-[Sparc:] Fixed integer comparison VOPs to be appropriately prioritized by cost.
-
-In %DEFTRANSFORM, when determining wither to replace a transform or add a new
-one, check that it has the same note as well as the same type.  This provides a
-way to have more than one transform with the same type signature.
-
-Fixed (- x) to expand directly to (%negate x), rather than going by the
-intermediate of (- 0 x), since this is not a correct transformation.  (- 0 0.0)
-is 0.0, not -0.0.  Fixed the (- 0 x) transform to be restricted to rational
-args.
-
-Changed COMMUTATIVE-ARG-SWAP to actually splice in the constant arg, so that
-variable substitution can't swap it back again.
-
-Fixed multiply recoding to include many TRULY-THE's in the expansion so that
-the resulting shift-and-add code would actually open coded.
-
-Added comprehensive handling of arithmetic and logical identities when an arg
-is -1, 0 or +1.
-
-
-1/17/92 to 1/26/92
-
-Fixed the multi-dim array printer to use aref on the data vector instead
-of svref, because despite being simple and being a vector, it's not a
-simple-vector.
-
-Fixed compiler error context stuff to know that the source-info-name for a file
-is now the namestring and not the pathname.  This allows filenames to be
-printed in error context once again.
-
-Fixed a bug in Purify that was manifesting on the RT.
-
-
-12/22/91 to 1/17/92
-
-	Mostly minor bug fixes and cosmetic improvements.
-
-Code:
-
-The MIPS disassembler now supports all the bells and whistles of the SPARC
-version.  [Courtesy of Miles]
-
-The pretty printer now ``unparses'' the results of backquote expressions
-and rebuilds the original backquote-comma expression.  This makes reading
-macro definitions, etc. much easier.  [Also courtesy of Miles]
-
-Fixed a few minor bugs in debug-int.lisp:
-- When computing interpreted debug blocks, ignore successors to the component
-tail or other functions.
-- Compute the correct result for DEBUG-FUNCTION-START-LOCATION with
-interpreted debug functions.
-- In parse-debug-blocks, fix typecase to look for I-D-FUNCTION, not BLOCK.
-
-Fixed FORMAT-JUSTIFICATION to assume the charpos is 0 if we can't tell from
-the stream.  This was causing (FORMAT (MAKE-BROADCAST-STREAM) ...) to fail.
-The compiler sometimes binds *ERROR-OUTPUT* to (MAKE-BROADCAST-STREAM) when
-it wants to suppress error output.
-
-Fixed OUTPUT-VECTOR to not consider *PRINT-ARRAY* in string printing.
-
-Changed FEATUREP to barf if it is passed a list form with a strange CAR.
-
-Changed the default list pretty-printer to only print lists that start with
-symbols as function calls if the symbol is fboundp.
-
-Fixed MERGE-DIRECTORIES to correctly handle the case when the second
-directory spec is NIL.  In this case it should just use the first directory
-verbatim.  This fixes (MERGE-PATHNAMES "foo/bar" "").
-
-Changed WITH-PATHNAME to call PARSE-NAMESTRING on the result of FILE-NAME.
-
-
-Compiler:
-
-When we have a :SAFE VOP, flush result type checks when the result has only a
-single use.
-
-In COMPILE-FILE use PATHNAME of the output stream rather than TRUENAME of the
-output-file.  It seems that sometimes the file doesn't appear in the file
-system until some time after we close the file.
-
-When computing costs for references by MOVE VOPs, don't signal an error if a
-cost is missing.
-
-Several minor fixes to the SPARC code generators:
-- Fixed result type assertion on the :SAFE (tagged add) VOPs.  The result type
-must be FIXNUM (when with :SAFE VOPs need not be proven type, only asserted.)
-- Added GENERIC-EQL/FIXNUM VOPs (with higher costs) to prevent spurious
-representation number-consing when a fixnum and a word-integer are compared
-(e.g. in ZEROP.)
-- Added notes for character move/coerce VOPs.
-- Added notes for float move/coerce VOPs.
-- Updated the integer move/coerce VOPs to correspond to the MIPS version. 
-The fixnum cases are split off so that we have a better idea of the cost (for
-efficiency notes.)  Added notes to these VOPs.
-- Added notes for SAP coercion VOPs.  Fixed cost for MOVE-FROM-SAP.
-
-
-Hemlock:
-
-Fixed REVERT-PATHNAME not to call FILE-WRITE-DATE on NIL if there it no
-checkpoint file.
-
-Don't call NAMESTRING on NIL in REGION-COMPILE.
-
-Deleted EVAL-WHEN (COMPILE) around DEFINE-SEARCH-KIND and 
-SEARCH-ONCE-{FORWARD,BACKWARD}-MACRO so that we don't have to compile this file
-to compile search2.
-
-
-CLX:
-
-Fixed DEFTYPE for CHAR-INFO-VEC.  It is not in fact always length six (in
-fact, I believe it never will be.)
-
-Fixed ordering of some forms that got trashed in the last merge.
-
-
-
-12/19/91 to 12/22/91
-
-Various fixes in the new pathname code.  Following is some clarification of the
-nature of the new pathname support.
-
-Programs that actually conform to the CLtL1 pathname spec will have very few
-problems.  However, the CLtL1 spec was extremely vague, and CMU CL did not make
-use of much of the allowed flexibility, so many technically non-portable
-programs previously worked under CMU CL.
-
-The main incompatible changes from CLtL1 to CLtL2:
- -- Symbols are no longer acceptable filenames.
- -- PATHNAME-HOST may be any object.
- -- :UNSPECIFIC is now a legal pathname component.
- -- MERGE-PATHNAMES now recognizes relative pathnames and treats them
-    specially. 
-
-The format of directories is now specified (to be a list in a certain format.)
-This required an incompatible change from the previous practice of using a
-vector PATHNAME-DIRECTORY and using "DEFAULT" or :ABSOLUTE in the
-PATHNAME-DEVICE to indicate relative and absolute pathnames.
-
-In a related change, the CMU SEARCH-LIST extension was changed so that the
-search-list now appears in the PATHNAME-DIRECTORY as 
-    (:ABSOLUTE #<Search-list "name"> ...)
-
-A consequence of this change is that search-list definitions can now only
-contain directories (and other search lists); the component pathnames cannot
-have name or type specified.  Other changes to search-lists:
- -- (SETF SEARCH-LIST) now accepts a string or pathname, and converts it into
-    a one-element list.
- -- Search-list elements are now canonicalized to pathnames rather than to
-    strings. 
-
-New features which are now supported:
- -- Wildcard pathnames are now fully supported.  In addition to allowing :WILD
-    in any pathname component, "extended wildcards" such as "foo*.*" are also
-    supported.  A consequence of this is that PATTERN objects may appear in
-    wildcard pathname components instead of strings.  See PATHNAME-MATCH-P and
-    TRANSLATE-PATHNAME.
- -- As a CMU CL extension, a wildcard pathname may be used as the argument to
-    any filesystem interface (like OPEN) as long as it matches only one file.
- -- The pathname :COMMON case mechanism provides a way around the problems of
-    portably specifying string pathname components in the presence of operating
-    systems with differing preferred case in their filesystem.  An uppercase
-    string "LISP" is mapped to the "customary case" (lowercase on unix.)  
-    Lowercase is also inverted: "readme" becomes "README".  Mixed case is left
-    alone.  Note that this mechanism is explicitly enabled by supplying :CASE
-    :COMMON to functions such as MAKE-PATHNAME.  The default is the old
-    behavior (:CASE :LOCAL).
-
-Also, DIRECTORY now actually returns the TRUENAME of each file (as it was
-always supposed to do.)  If a matched file is a symbolic link, the truename may
-be a file in some other directory that doesn't even match the pattern.  The old
-behavior can be obtained by specifying :FOLLOW-LINKS NIL.
-
-The new wildcard pathname mechanism has not yet been used to replace the old
-single-wildcard matching in Hemlock DIRED, etc.
-
-Other bug-fixes:
- -- PURIFY now places indirect value cells and funcallable instances in static
-    space.  Purified code that contained closures or generic functions as
-    function constants could have experienced bad pointer problems.
- -- The compiler now correctly compiles dynamic scope binding forms such as
-    CATCH and special binding even when there is no code the scope.
- -- Fixed a bug in the FASL dumper's byte-swapping.  This affects only
-    implementors who do cross-compilation.
-
-Also, a new heap-groveling tools was used to locate a major reason for the
-spurious retention of deleted Hemlock buffers.  This has now been fixed.  Stay
-tuned for more memory leaks.
-
-
-12/13/91 to 12/19/91
-
-Code:
-
-All pathname support has been rewritten to conform to X3J13.  (Except logical
-pathnames haven't been written yet).  Any code that makes assumptions about
-the format for pathnames (e.g. pathname-device being the search-list, or
-pathname-directory being a simple-vector) will have to be rewritten.
-
-Changed SHOW-RESTARTS to also display the restart name (but only if it's
-not shadowed by a higher priority restart).  Changed the restart command to
-look for restarts by name if a symbol is typed.
-
-Substantially rearranged function describing to make it more consistent, and
-added support for describing interpreted functions.
-
-Changed the FORMATTER stuff to use positional args where possible instead
-of always extracting elements from the rest arg.
-
-The control stack is now zeroed between top level forms to reduce the
-number of dangling pointers.
-
-Fixed pprint-logical-block :suffixes and *print-line* abbreviations to work
-together.
-
-
-Compiler:
-
-Dumping of constant structures has been fixed to conform to X3J13, except
-that the generic function MAKE-LOAD-FORM isn't really used.  Instead, a new
-defstruct option, :make-load-form-fun, has been added that can be used to
-specify a function that acts like a MAKE-LOAD-FORM method.  When we have a
-CLOS that supports STRUCTURE-CLASS, the default method for MAKE-LOAD-FORM
-will use this information instead of having the compiler use it directly.
-
-When the INHIBIT-WARNINGS optimize policy is 3, suppress warnings about
-undefined functions and variables.
-
-
-PCL:
-
-Fixed SET-FUNCTION-NAME to correctly set interpreted function names.
-
-
-
-12/12/91 to 12/13/91
-
-Code:
-
-The printer now goes to extra care to make sure structures only count as
-one level against *print-level* and are handled correctly with respect to
-*print-circle*.
-
-Several fixes to the pretty printer:
-
-- Actually store the change in the suffix length in the pretty-stream
-structure (was causing suffixes to be ignored with line abbrevs).
-
-- Fixed an off-by-one error in desciding when to use line abbrevs.
-
-- Fixed output-line to make sure the buffer is large enough to fit
-the prefix before we copy it in.
-
-- Added several new keywords to pprint-logical-block to allow better
-support for pretty printing non-list objects.
-
-- Changed pprint-function-call to put a fill-style newline between the
-the function and the first arg instead of a miser style newline.
-
-- Printing lists when *print-circle* and *print-pretty* are both T now
-works.
-
-
-
-12/5/91 to 12/12/91
-
-Code:
-
-Added automatic closing of opened FD-streams when they become garbage.
-
-Fixed the interpretive indexing conditional (~[...~]) to take into account
-the list of sections is reversed.  Also, check to see if zero is less than
-or equal the index, not the index less than or equal zero.
-
-Added doc strings for pretty-printer defvars.  Added a descend-into for
-print-vector.  Added an export for *print-pprint-dispatch*.
-
-Changed the dispatch for cons to pprint-fill and added a dispatch for
-(cons symbol) to pprint-function-call.  This way the results of
-(list-all-packages) won't show up as a function call.
-
-Bind *current-level* to 0, *print-readably* to nil, and *read-eval* to T
-when entering the debugger to make sure things print as expected.
-
-Picked up Miles' latest disassembler changes (source printing.)
-
-Changed reader to ignore undefined macro characters when *read-suppress* is T
-(i.e. in #+/- conditionals.)
-
-
-Compiler:
-
-Fixed various places where the result type of a node was spuriously being
-inferred to be NIL, causing spurious code deletion. 
-
-Give a warning in DERIVE-NODE-TYPE when we prove inconsistent types.  This 
-is probably always a bug, but I don't want to use ASSERT until all 
-the problems are fixed.
-
-The compiler now recognizes a new class of local functions and compiles them
-more efficiently.  Basically, in many cases local functions with more than one
-call can share the same stack frame with the caller as long as there is only
-one place that the function ever returns to (all other calls must be
-tail-recursive.)  This compiles recursion-loops much more like setq/go loops.
-
-Fixed various bugs related to dead code deletion which were revealed by the new
-optimizations.
-
-Fixed a bug in the implementation of tail-recursive calls which could cause
-functions to use the number stack without a frame having been allocated.  One
-effect of this bug was that a segment violation would always kill lisp.
-
-If we undefine a structure type because of incompatible redefinition, then
-unfreeze it also.
-
-Really fixed named constant referencing to preserve EQL-ness.
-
-
-Startup code:
-
-Fixed to install the correct instruction on non-mips machines instead of
-always installing a mips break instruction.
-
-
-Hemlock:
-
-Fixed indentation for FLET&c to check that we are actually in the first arg
-form before doing funny indentation.
-
-Set the typescript stream character position to zero whenever the user presses
-enter.
-
-
-11/27/91 to 12/5/91
-
-Code:
-
-Almost all of the printing code has been rewritten/restructured to support
-all of the printing features added to the language.  Some highlights:
-
-    *PRINT-READABLY* is now supported.
-
-    *PRINT-CIRCLE* works irrespective of *PRINT-PRETTY*.
-
-    *PRINT-LEVEL* abbreviation now works automatically inside structure
-    printers.
-
-    XP has been replaced with a native pretty printer that is fully
-    integrated with the rest of the system.
-
-    The macros WITH-STANDARD-IO-SYNTAX and PRINT-UNREADABLE-OBJECT have
-    been added.
-
-    The FORMATTER macro has been written, and FORMAT extended to accept
-    a function instead of a control string.
-
-DATA-VECTOR-SET, the internal function responsible for doing the work of
-(SETF (AREF ...) ...), has been fixed to type-check the value.
-
-The FASL loader has been changed so that you can concatenate fasl files
-together and load the result.
-
-Added *READ-EVAL*, which when set to NIL causes #. to signal an error
-instead of evaluating the next form.
-
-
-Compiler:
-
-You can now (DECLARE (IGNORE #'FUN)) as per an ANSI cleanup.
-
-IGNORABLE, as in (DECLARE (IGNORABLE ...)) is now exported from the LISP
-package as ANSI adopted it.
-
-Fixed TYPES-INTERSECT to consider any supertype of T to definitely intersect
-with anything.
-
-
-
-11/25/19 to 11/27/91
-
-Code:
-
-Made TRACE and UNTRACE handle function objects as well as function names.
-
-Made calling UNTRACE while with a BREAK from TRACE'ing work fine.  No output
-occurs at the end of the call even though there was TRACE output at the
-beginning of the call before going into the BREAK loop.
-
-Modified HANDLE-BREAKPOINT-AUX to test whether any user hook deactivated any
-breakpoints at the current code location.  When there are no longer any
-breakpoints at this location, it foregoes setting an after breakpoint to
-re-establish the break instruction at this code location.  There is no reason
-to plan to re-establish the break instruction since there are no longer any
-active breakpoints at the location.
-
-Modified SUB-DEACTIVATE-BREAKPOINT to only remove the break instruction from
-the code when there are no longer any active breakpoints at the code location.
-
-
-Compiler:
-
-Picked up a large number of changes for Miles' disassembler.
-
-Miles' disassembler is now used on the PMAX in addition to the SPARC.
-
-Fixed named constant dumping to allow direct references to interned symbols.
-
-
-
-11/19/91 to 11/25/91
-
-Compiler:
-
-The new special form LOAD-TIME-VALUE now exists.  See CLtL2 for information
-on how to use it.
-
-Handling of constants has been cleaned up.  When using COMPILE and
-COMPILE-FROM-STREAM, anything is allowed as a constant.  When using
-COMPILE-FILE, dumping of arrays has been brought up to spec with respect to
-X3J13.  Specifically:
- - displaced or adjustable arrays and vectors with fill pointers are
-converted to a simple-array duplicate during the dump.
- - arrays of floats are left as arrays of floats instead of being converted
-into arrays of element-type T that just so happen to hold a bunch of
-floats.
-
-The type declarations for DOCUMENTATION and (SETF DOCUMENTATION) have been
-fixed to allow any symbol for the document kind.
-
-If we see a reference to a named constant that isn't a number or charcter,
-then convert it as SYMBOL-VALUE.  This is so that DEFCONSTANT'ed values
-remain EQL.
-
-
-Hemlock:
-
-Added wm-hints for pop-up display windows.  This will be necessary to receive
-input in OpenLook windowing systems, but we also thought this might be be MWM
-bug that prevents pop-up windows from receiving input.  It was unlikely this
-was the problem since other Hemlock windows could receive input without the new
-wm-hint we set to get input in OpenLook windowing systems.
-
-Delete SET-WINDOW-ROOT-Y since it is no longer used since we installed window
-groups.
-
-
-
-10/14/91 to 11/19/91
-
-CLX: updated to CLX R5.  Please report any new X lossage.  X applications
-should probably be recompiled.
-
-PCL: merged with the lastest PCL version.  PCL/CLOS applications must be
-recompiled.
-
-Note: although some problems with the existing Alien code have been fixed,
-many problems remain.  In particular, interpreted Alien code doesn't work.
-We are currently implementing a new Alien interface with much greater
-functionality (as well as fewer bugs.)
-
-Cleanups:
- -- The types BASE-CHARACTER and EXTENDED-CHARACTER have been renamed to
-    BASE-CHAR and EXTENDED-CHAR as per the CHARACTER-VS-CHAR cleanup.
- -- Added syntax checking on the DEFSTRUCT :CONC-NAME option, and also, allow
-    it to be a string as well as a symbol.
-
-Enhancements:
- -- Modified DESCRIBE-FUNCTION-COMPILED to better output function documentation
-    relative to displaying arguments.  The format now is as follows:
-
-       Function:
-	 <printed representation of function object>
-       Function Arguments:
-	 <printed representation of function object>
-       Function Documentation:
-	 ...
- -- Added EXT:*TOP-LEVEL-AUTO-DECLARE*.  This variable allows control over how
-    the interpreter treats SETQ's of undeclared variables.
- -- Modified EXT:COMPLETE-FILE to correctly complete files relative to the
-    defaults.  This fixes a long standing Hemlock problem: you could find files
-    relative to the defaults with subdirectory specs, but you could not
-    complete them.
- -- Added definition of SYSTEM:FOREIGN-SYMBOL-ADDRESS, which returns the SAP
-    corresponding to a loaded foreign symbol.
- -- NTH-VALUE now no longer cones for it now doesn't cons for non-constant N
-    less than 3.
- -- Added :UNIX to the features list.
-
-Bug fixes:
- -- Changed inspector font specs to use point size instead of pixel size so
-    that they will work on 100dpi devices.
- -- FDEFINITION should now signal undefined function errors when appropriate,
-    instead of returning a trap object.
- -- EXPT now handles the SINGLE-FLOAT x SINGLE-FLOAT arg type combination.
- -- TRUNCATE now handles the single-float/double-float case.
- -- Bignum printing now works with base 36.
- -- Fixed DIRECTORY to no longer signal errors.  It's job is to return a list
-    of files matching its argument, and it should return nil when the spec is
-    inaccurate.
-
-Debug Internals interface:
-    Changed name of DI:DO-BLOCKS to DI:DO-DEBUG-FUNCTION-BLOCKS.
-
-    Wrote DI:FUNCTION-END-COOKIE-VALID-P which takes a frame and a
-    function-end-cookie.  It returns whether the cookie is still valid.  This
-    provides a way for function-end breakpoint users to detect that the
-    function end breakpoint was never run due to a THROW (or other non-local
-    exit.)
-
-    Wrote DEBUG-FUNCTION-START-LOCATION which takes a debug-function; it
-    returns a code-location before the body of a function and after all the
-    arguments are in place.  If this cannot determine that location due to a
-    lack of debug information, it returns nil.
-
-Fdefinition.lisp is all new, and it contains the following interface routines:
-   EXT:ENCAPSULATED-DEFINITION
-      Returns whatever definition is stored for name, regardless of whether it
-      is encapsulated.  This is SETF'able.
-   EXT:ENCAPSULATE
-      Replaces the definition of name with a function that binds name's
-      arguments a variable named argument-list, binds name's definition to a
-      variable named basic-definition, and EVAL's body in that context.  Type
-      is whatever you would like to associate with this encapsulation for
-      identification in case you need multiple encapsuations of the same name.
-   EXT:UNENCAPSULATE
-      Removes name's most recent encapsulation of the specified type.
-   EXT:ENCAPSULATED-P
-      Returns t if name has an encapsulation of the given type, otherwise nil.
-
-The old encapsulation-based tracer has been replaced with a new one based on
-breakpoints.  The new traced is exported from DEBUG, using the same name and
-interface as the old one.  The old tracer is still exported from EXTENSIONS as:
-   ext:*old-trace-print-level*
-   ext:*old-trace-print-length*
-   ext:*old-traced-function-list*
-   ext:*max-old-trace-indentation*
-   EXT:OLD-TRACE
-   EXT:OLD-UNTRACE
-
-Miles's retargetable disassebler should now be available on the SPARC.
-
-
-Compiler:
-
-The compiler now recognizes function calls that never return, and takes this
-into consideration when determining the possible control flows.  A function can
-be declared not to return by declaring its result type to be NIL (not to be
-confused with NULL).  If a function declared NIL does return, and error will be
-signalled.
-
-Optimizations:
- -- Fixed some problems where the compiler would unnecessarily number-cons
-    because it wasn't taking into consideration the advantages of keeping a
-    descriptor representation.
- -- The CLOS FUNCALLABLE-INSTANCE-P is now a primitive predicate.
- -- Loop rotation is now done, eliminating the unconditional branch at the
-    bottom of while loops.
- -- Control flow determination now recognizes code that doesn't return (error
-    traps, throws, etc.) so as to minimize unconditional branches in code
-    containing error checks.
- -- Added derive-type methods for ASIN, ACOS, ACOSH, ATANH and SQRT which figure
-    out whether the result type is real on the basis of the argument range.  
-    Added inference methods on irrational functions whose result is real
-    when the args are.
- -- Many previously defined optimizations are now being triggered more
-    consistently when they are applicable.
- -- Improved inline expansion of the set functions by causing implicit MEMBER
-    calls to be inlined as well.
-
-Enhancements/big fixes:
- -- Suppress argument assignment warning if the function type doesn't give us
-    any new information.
- -- The compiler now recognizes that the second value of INTERN can be NIL.
- -- Lambdas with &key but no specified keywords are now correctly parsed.
- -- Fixed a block compilation / FTYPE declaration interaction.
- -- Fixed TAGBODY not to consider NIL to be a tag.
- -- PCL defmethods now have qualifiers and specializers in their names.
- -- Fixed a number of problems with dead code deletion, now that more dead code
-    is being detected.
- -- FTYPE proclamations on structure accessors are now quietly ignored, instead
-    of causing the structure to be undefined.
- -- Added a RANDOM derive-type method.
- -- Added multiplier recoding for ub-32 * ub-32 => ub-32.
-
-SPARC:
- -- Fixed decode-float for long-floats (fixing long float printing, etc.)
- -- CHECK-STRUCTURE now uses a conditional trap, reducing code size.
-
-
-Hemlock:
-
-Modified CREATE-WINDOW-WITH-PROPERTIES to supply :input :on to allow silly
-OpenLook pseudo-X11 Sun servers to do the right thing.
-
-Added termcap parsing for things like begin/end bold, underline, etc.
-
-Fixed a redisplay problem  that often caused subprocess output to not be
-displayed until some input event came along.
-
-There's a new "Buffer Modified Hook" function that raises the "Echo Area"
-window when it becomes modified.  You can control this with the Hemlock
-variable: "Raise Echo Area When Modified".  It isn't good enough to set "Set
-Window Autoraise" to :echo-only because output appears in the echo area at
-times when the echo area is not set as the current window.  The only
-malfunction of setting this new variable is sometimes Hemlock clears the echo
-area, which modifies it, and then does not output any text; in this situation,
-Hemlock would raise the echo area, but it doesn't need to do so.  This cannot
-be eliminated due to the nature of the "Buffer Modified Hook".
-
-Fixed the :file branch of "Help on Parse" to trim leading directory
-components off the pathname if it wouldn't otherwise fit on the screen.
-
-Before doing directory translations, try a probe-file of the source file
-first.  This way, you don't have to have 400 different translations
-for ever conceivable source path.
-
-Fixed "Load File" to correspond with the manual by making it regard "Remote
-Compile File".  It was always going through RFS when it should do so
-conditionally.
-
-Generalized FLET-style indentation to reference the variable
-"Lisp Indentation Local Definers", and also to recognize LABELS (as well as
-MACROLET and FLET.)
-
-Added DEFINDENT's for the "WIRE" package.
-
-Fixed name of mail drop MH profile component from mail-drop to MailDrop
-
-"Insert Message Buffers" now handles multiple windows appropriately when
-inserting text into a Netnews Post buffer.
-
-Changed Hemlock window flashing to be less spastic in the presence of net delays.
-
-Netnews:
-
-The binding #k"r" has changed to "Netnews Reply to Sender in Other Window" in
-"News-Headers" and "News-Message modes.
-
-The binding #k"R" has changed to "Netnews Reply to Group in Other Window" in
-"News-Headers" and "News-Message" modes.
-
-Changed NN-REPLY-CLEANUP-SPLIT-WINDOWS to delete the message-window instead of
-the reply-window.
-
-Split CONNECT-TO-NNTP into two: RAW-CONNECT-TO-NNTP and CONNECT-TO-NNTP.  The
-first is the same as the original with the addition of specifying a timeout
-value to MAKE-FD-STREAM.  The second binds a handler for the IO-TIMEOUT
-condition and gives the user an error message.
-
-Added Hemlock variable "Netnews NNTP Timeout Period" to control how long
-Netnews will wait (while connecting to NNTP) before timing out.
-
-Changed *nntp-server* into Hemlock variable "Netnews NNTP Server".
-
-Added command "Netnews Reply to Sender in Other Window".
-
-Added functions NN-SETUP-FOR-REPLY-BY-MAIL and NN-REPLY-TO-SENDER to hold
-common code for "Netnews Forward Message", "Netnews Reply to Sender", and
-"Netnews Reply to Sender in Other Window".
-
-Changed default bindings to use "Netnews Reply to Group in Other Window" and
-"Netnews Reply to Sender in Other Window"
-
-
-10/8/91 to 10/14/91
-
-This is version 15b (destined for beta release.)
-
-Debugger:
-    Fixed to use SYMBOL-MACROLET instead of "SYMBOL-MACRO-LET."
-    Updated documentation on MAKE-BREAKPOINT and ACTIVATE-BREAKPOINT.
-
-    The latest alpha test breakpoint interface is available as described in the
-    Debugging Tools Programmer's Interface.  Also, support for setting
-    breakpoints from the editor has been changed to use the "WIRE" package
-    directly.  There is a new interface for deleting breakpoints set by the
-    editor.  This is all alpha test code.
-
-    Added an optional argument to PRINT-FRAME-CALL-1, an internal function, to
-    control whether it precedes its output with a newline.
-
-Hemlock:
-    Added a form to SERVER-DIED to clean up breakpoint-infos for that server.
-    Added a missing ~ in slave compilation the echo area message.  Oops...
-
-    Changed hemlock init file loading to accept .hemlock-init as well as
-    hemlock-init.  Fixed ED doc string.
-
-    Modified TTY-DELETE-WINDOW to be consistent with TTY-MAKE-WINDOW's creation
-    policy; that is, if the latter makes window by putting the new one after
-    some hunk it shrunk to make room, then the former should prefer to grow the
-    previous hunk, not the next.  This was the intended behavior.
-    
-    The "Debug Breakpoint" and "Debug Delete Breakpoints" commands are ready
-    for alpha testing, which they need a lot.  Some other bugs have been fixed
-    too, but those were long enough ago, I don't remember them.
-
-
-9/18/91 to 10/8/91
-
-Code:
-
-Changed ordering of CHAR-NAME-ALIST to prefer NEWLINE, ESCAPE and DELETE to
-LINEFEED, ALTMODE and RUBOUT (when printing.)
-
-Changed the internal directory support functions to use the C routines
-opendir, readdir, and closedir, so that directory works under sunos.
-
-In RUN-PROGRAM, don't set XTABS on the pty so that tabs will be passed
-through to as is.  This allows better tab support in Hemlock shell buffers.
-
-Added :KEY argument to REDUCE.
-
-Fixed SUBSTITUTE & friends to pass arguments to the TEST in the right order.
-
-Fixed SUBSTITUTE not to randomly apply the KEY to the OLD value.
-
-Changed LIST NSUBSTITUTE & friends to work in the :FROM-END case.
-
-Added export of remote-object, the name of a type, from the "WIRE" package.
-
-Added WIRE-{OUTPUT,GET}-BIGNUM and extended WIRE-{OUTPUT,GET}-OBJECT to use
-them.
-
-
-Compiler:
-
-Fixed bug in FIND-REFERENCE-FUNCTIONS introduced by the last change.  Ignoring
-of top-level references was effectively disabled, causing top-level code to
-normally be incorporated in real function components.
-
-Fix to make unreferenced arguments in local call work.  We were correctly 
-only popping (into the INTERNAL-APPLY arglist) the number of referenced
-args, but INTERNAL-APPLY was assuming that all arguments were present
-in the list.  Added a flag to INTERNAL-APPLY to control this behavior. 
-This was breaking full call to interpreted functions as well, since the
-XEP did a local call to the main entry.
-
-Changed NOTE-FAILED-OPTIMIZATION to print the transform note explaining what
-the transform was trying to do.
-
-Fixed lossage concerning the following compiler output:
-   Definition has N args, but the previous definition had M.
-This used to be a note, but it should be a warning.
-
-If it is a warning that users change the definitions of structures, then it
-should be a warning when users change the definitions of functions.  In both
-cases, code might be lying around assuming an incorrect interface.  I think
-this is equally dangerous.  Also, changing the redefinition of arg counts to a
-warning makes it more compatible with the warning that someone supposedly
-called a routine with the wrong number of args.
-
-Changed SYMBOL-MACRO-LET to SYMBOL-MACROLET.
-
-
-Hemlock:
-
-Added "Typescript Slave Status", with binding H-s.
-
-Added font support for the TTY.  Allow active region highlighting and open
-paren highlighting when on the TTY, as they now work.
-
-Changed the compile-in-slave utilities to count notes and display in
-completion message.  Also fixed not to print echo area messages "Error in
-NIL ..."
-
-Fixed "Move Over )" to use a permanent mark instead of a temporary mark
-because it deletes text.
-
-Adjusted length of the :hemlock-banner modeline-field to prevent the
-*truncated-field-character* from appearing after the date.
-
-Fixed sentence-offset-forward to work at the end of the buffer.
-
-Added noise to skip over comments in /etc/termcap, which start with a # and
-end on the end of the line.  This was necessary in order to bring Hemlock
-up under SunOS, because the SunOS /etc/termcap file has comments in it.
-
-Deleted unused function TTY-FIND-BIGGEST-HUNK.
-
-Modified TTY-DELETE-WINDOW to be consistent with TTY-MAKE-WINDOW's creation
-policy; that is, if the latter makes window by putting the new one after some
-hunk it shrunk to make room, then the former should prefer to grow the previous
-hunk, not the next.  This was the intended behavior.
-
-Modified %SET-MODELINE-FIELD-FUNCTION to allow its function argument to be a
-symbol or function since the purpose is to FUNCALL the thing.  Since the new
-system is up to spec on the disjointedness of functions, this needed to be
-fixed for usefulness.
-
-
-C Support:
-
-Moved the heap around to free up 0x0f000000...0x0fffffff, cause Mach 3.0
-wants to use that range.
-
-
-
-9/13/91 to 9/18/91
-
-Hemlock:
-
-Removed some old bindings for some netnews commands that no longer exist.
-
-The Netnews post delivery code no longer adds a DATE field to the message.  The
-lower level transport mechanism does this.
-
-Modified MH-PROFILE-PATHNAME and MH-DIRECTORY-PATHNAME to use TRUENAME on the
-result of USER-HOMEDIR-PATHNAME now that it returns a logical name instead of
-an absolute pathname.
-
-
-
-8/29/91 to 9/13/91
-
-Code:
-
-Changed all places absolute pathnames were used to indirect search-lists,
-mostly library:.  The library: search-list is built from the CMUCLLIB
-environemnt variable if it exists, and defaults to /usr/misc/.cmucl/lib/ if
-not.
-
-Moved OS specific functions into the new files mach-os.lisp and
-sunos-os.lisp.  Also, added some routines to abstract some OS operations,
-like get-page-size.
-
-Optimized the TIME macro to keep the consing overhead of using it zero.
-
-
-Compiler:
-
-Fixed a bug where the compiler would flame out when it came across an
-NLX-INFO structure when it was expecting a LEAF.
-
-Fixed VALUES declaration to work correctly when zero values are specified.
-
-Fixed FORMAT transform to warn if there are to many or too few args.
-
-
-Hemlock:
-
-Changed the default value of "Slave Utility" to just "lisp" which hopefully
-will be found on path:.  If you don't have lisp on your path, you need to
-set "Slave Utility" to the full pathname of lisp, /usr/misc/.cmucl/bin/lisp
-on MACH machines.
-
-"Netnews Show Whole Header" is bound to #k"w" in "News-Headers" and
-"News-Message" modes.
-
-"Netnews Show All Headers" is bound to #k"h" in "News-Headers" and
-"News-Messages" modes.
-
-"Netnews Show Whole Header" replaces the command, in name only, "Netnews Show
-All Headers".
-
-The Netnews interface is more polished and consistent in naming.  We fixed one
-or two small bugs.
-
-
-C startup code:
-
-Search the CMUCLLIB search path for the core file instead of always
-assuming that /usr/misc/.cmucl/lib is going to hold it.
-
-
-
-
-8/9/91 to 8/29/91
-
-Changed EVAL to use the recorded CONSTANT-VALUE when evaluating constants so
-that interpreting references to constants in the compiler environment works
-better.  Now (defconstant a 3) (defconstant b (+ a 4)) works again.
-Make all non-symbol atoms self-evaluate (an X3J13 cleanup.)
-
-Fixed one-off error in list remove-duplicates :from-end.
-
-Added #P pathname read syntax, and changed the pathname printer to use it.
-Fixed all recursive READ calls in sharp-macros to specify eof-error-p T, so
-that EOF errors are signalled when appropriate.
-
-Added code to compile the argument to TIME when possible, and print a warning
-when it isn't.
-
-Fixed compiler problems with maybe-inline functions and defmethods that use
-&allow-other-keys.  Also fixed some problems with block compilation and unused
-function deletion.
-
-Fixed a problem with Netnews's startup header window proportions.
-
-Added new command, "Netnews Show All Headers".
-
-
-7/16/91 to 8/9/91
-
-Code:
-
-Merged Simon Leinen's fix to OUTPUT-SYMBOL.  This amounted to deleting an
-incorrect and questionably optimal optimization of printing package qualifiers.
-
-Lots of changes to the time parsing and printing extensions including bug
-fixes.
-
-Modified DESCRIBE-FUNCTION-COMPILED and DESCRIBE-SYMBOL to print function and
-macro doc strings before arg and result info.
-
-
-Hemlock:
-
-Modified "Fill Lisp Comment Paragraph" to fill strings with the appropriate
-indentation as a fill prefix.  When invoked outside a comment or string, this
-fills contiguous lines with the same, non-empty intial whitespace.  Before
-executing this last case, the command prompts for confirmation, but you can
-inhibit this prompting by setting "Fill Lisp Comment Paragraph Confirm" to nil.
-This last case is useful for filling long EXPORT lists or other length listings
-of symbols or indented text.
-
-Added some prototype netnews support.  Details to be anounced later.
-
-Modified "Delete Draft and Buffer" and DELIVER-DRAFT-BUFFER-MESSAGE to work
-with Netnews drafts.
-
-Modified "Insert Message Region" and "Insert Message Buffer" to work with
-Netnews message and post buffers.
-
-Added a "Manual Page" command, which runs man(1) in a shell buffer.
-
-
-Hemlock-internals:
-
-CREATE-WINDOW-FROM-CURRENT now creates a window according to its new proportion
-argument instead of simply splitting the current window in two.  It returns nil
-without doing anything if either window is too small.
-
-WINDOW-GROUP-CHANGED no longer unifies the sizes of window when the user
-resizes a group.  It now tries to distribute the new size of the group
-according to the proportions of the old size consumed by the windows.
-
-Changed ARRAY-ELEMENT-FROM-MARK to use AREF for the Netnews stuff.  I
-documented this to be an internal interface since a few other modes use it.
-
-WRITE-FILE now takes an :append argument.
-
-
-
-
-6/4/91 to 7/16/91
-
-Code:
-
-Fixed make-array to allow :initial-contents to be built out of any kind
-of sequence, not just lists.
-
-Fixed vector-push and vector-push-extend to return the original fill
-pointer, not the new fill pointer.
-
-Fixed vector-pop to return the value indexed by the new fill pointer, not
-the original fill pointer.
-
-Fixed two bugs in the truncation code.
-
-When using the form offset to find the source form, bind *read-suppress* to
-T to keep the reader from barfing on stuff that will no longer read (e.g.
-#.foo in the wrong package, etc.).
-
-Fixed a typo in an error message in defstruct.
-
-Fixed FORMAT-PRINT-NUMBER to correctly insert commas for negative numbers
-(don't print -,123).
-
-Fixed get-setf-method to only inhibit for local functions, not local macros
-too.
-
-Fixed COPY-DESCRIPTOR-TO-STREAM to set a flag when it closes the descriptor
-and to check this flag before it selects.  This way, if we recursively
-enter the handler (due to write-string calling something that calls
-serve-event), then we won't blow out when we unwind.
-
-Merged old system changes.  Added noise to SETUP-CHILD to try execing
-/bin/sh if the original exec didn't work because of a bad magic number.
-
-Tweaked PRINT-HERALD to print the backend version, and to say to send mail to
-cmucl-bugs.
-
-
-Compiler:
-
-Fixed the compiler function database to list that the MAKE-ARRAY
-:INITIAL-CONTENTS argument can be anything, because if the array has zero
-dimensions, then the :initial-contents keyword is used as is.
-
-Made the default for COMPILE-FILE's :error-file argument be nil.  It is a dated
-notion and never desired to expect compilation to defaultly produce an error
-output file.  You always compile in the editor catching the output or in a
-system building utility that saves all the compiler's output.
-
-Fixed a problem in EMIT-ARG-MOVES.  If we do a coercion + move-arg, then the
-coercion would be inserted after the ALLOCATE-FRAME VOP, which caused register
-save computation to get confused.
-
-Fixed the make-array derive type optimizer to only spec the dimensions
-if the created array is known to be simple.  Otherwise, someone might
-adjust it, which would cause the type to be wrong.
-
-
-Hemlock:
-
-Raised the *hemlock-version* to 3.5 (.1 greater than the last old RT core.)
-
-"Shell Complete Filename" is a new command that attempts to complete the
-filename immediately before point.  The commands that start "Process" buffers
-with shells establish a stream with the shell that tries to track the current
-working directory of the shell.  It uses the variable "Current Working
-Directory" to do this.  For it to work, you should add the following to your
-.cshrc file:
-   if ($term == emacs) then
-      alias cd 'cd \!* ; echo ""`pwd`"/"'
-      alias popd 'popd \!* ; echo ""`pwd`"/"'
-      alias pushd 'pushd \!* ; echo ""`pwd`"/"'
-   endif
-
-Added binding, M-escape, for "Shell Complete Filename" in "Process" mode.
-
-Removed the definitions of command-char-bits-limit, command-char-code-limit,
-KEY-CHAR-BITS, and KEY-CHAR-CODE.  These are no longer used anywhere in the
-system.
-
-Fixed some syntax constants to make 8-bit chars work.
-
-Modified "Visit File" to issue a loud message whenever another buffer already
-contains the file visited.  The quiet message often went unnoticed defeating
-its purpose.
-
-Fixed a bug in "Center Line" which caused an internal error when invoked on the
-last line of the buffer with the buffer end at the end of the line.
-
-Commented LISP-INDENTATION to explain what it is looking for when it determines
-how to indent.  Added LISP-INDENTATION-CHECK-FOR-LOCAL-DEF and used it in
-LISP-INDENTATION to check for FLET or MACROLET syntax, so we could correctly
-indent local definitions.  They used to appear as normal forms in function call
-syntax, but now they indent as definitions.
-
-Added DEFINDENT's for the "DEBUG-INTERNALS" interface.
-
-Modified LISP-GENERIC-INDENTATION to check if the mark in was in a string
-context.  If it is, then we return the column one greater than the opening
-double quote.  Otherwise, we use the first preceding non-blank line's
-indentation.  This fixes the problem with doc strings and ERROR strings which
-got indented respectively at the beginning of the line and under the paren for
-the ERROR call.
-
-Added "Fill Lisp Comment Paragraph" to core.  This also works for strings,
-except for the first line of the string.
-
-Added binding for "Fill Lisp Comment Paragraph" to M-q in "Lisp" mode.
-
-Added a doc string to EXT:SAVE-ALL-BUFFERS.
-
-Added a doc string to HI:DIRECTORYP.
-
-
-Release 14c to beta....
-
-
-5/24/91 to 6/4/91
-
-Further space reductions from compiler policy tweaks.  This core is 19.1 meg.
-
-Tuned bignum code and added declarations and to reduce number consing.
-
-Added :TIMEOUT argument to MAKE-FD-STREAM.  The SYSTEM:IO-TIMEOUT condition is
-signalled if a timeout is specified and exceeded.
-
-Added :PACKAGE context declaration.
-
-Changed a null test in LOOP into an endp test.
-
-If we enter trace recursively (due to the printer calling the traced function),
-then just quietly call the function, instead of signalling an annoying "unable
-to trace" error.
-
-
-5/16/91 to 5/24/91
-
-
-CLX:
-
-Fixed the CLX X interface to be much more efficient, as well as fixing some
-bugs.  The low-level I/O to the server is now faster and conses much less.
-Enabled "fast" pixarray read/write for CMU.  Code that uses X must be
-recompiled.  The X inspector now works reliably with both the PMAX and RT X
-servers.
-
-
-Code:
-
-Made SYSTEM:BITS, BYTES, etc., be defined in the null environment so that they
-can be inline expanded.  This was causing spurious consing in various system
-code.
-
-Some tuning and bug fixes to FD-STREAMS (file descriptor streams) which are
-used for file I/O (and now for communication with the X server.)  Also, now in
-OPEN complains if you try to open a non-writable file for output with :RENAME
-or :RENAME-AND-DELETE.  Previously this would succeed as long as the directory
-was writable.  SYSTEM:READ-N-BYTES on FD streams is now more efficient, but
-does *not* wait using SERVE-EVENT; it blocks instead.  Fixed a problem with
-LISTEN at EOF on FD-STREAMS.  Made *standard-output* a two-way stream so that
-reading *standard-input* will force output on standard output.
-
-Fixed CONNECT-TO-INET-SOCKET to check that we successfully looked up the name
-so that we don't get segment violations on unknown hosts.
-
-Fixed sequence functions that have output type specifiers to correctly handle
-DEFTYPE types and other complex type specifiers.
-
-Some tuning in SERVE-EVENT which reduces consing and speeds up Hemlock and
-terminal I/O.
-
-
-Compiler:
-
-Representation conversion of a SAP (system area pointer) to a pointer
-representation now results in an efficiency note.
-
-[PMAX] Fixed TRUNCATE on floats to truncate instead of rounding.
-
-If debug-info is < 1, then don't dump debug-args or function type.
-
-Fixed a problem that could cause type checks to be spuriously deleted in some
-contexts where there is a local change in the SAFETY optimization policy.
-
-When doing inline expansion of recursive functions, respect NOTINLINE
-declarations.
-
-Changed declaration processing to treat a FUNCTION declaration as an ordinary
-variably type declaration (as proposed by X3J13).  The old semantics is still
-obtained when the second arg to the declaration is a list (as it always would
-be in the old usage.)
-
-Added support for the EXT:CONSTANT-FUNCTION declaration (already in the
-documentation.)
-
-When a DEFUN is compiled and the name has a FTYPE declaration, then a note is
-printed if any arguments to the function are assigned to (i.e. SETQ) in the
-body, as this inhibits application of the FTYPE declaration to the argument
-variables.
-
-&AUX bindings are now compiled with the EXT:OPTIMIZE-INTERFACE policy, mainly
-so that proper type checking is done for hairy keyword args.
-
-(<mumble>-P x) structure predicates are now just as efficient as 
-(TYPEP x '<mumble>).
-
-
-4/28/91 to 5/16/91
-
-New packages:
-
-Changed the windowing inspector to use standard fonts (courier) and to
-generally work under the new-compiler system.  Also, made the help window
-bigger.
-
-An improved version of the profile package (previously in the library) is now
-in the core.  It now compensates for recursive calls or nested calls, and
-interacts better with trace and function redefinition.
-
-Code:
-
-Now almost all Common Lisp functions which are SETFable have a (SETF name)
-function.   The exceptions are functions where it makes no sense (LDB, GETF),
-and a few other functions (GET, GETHASH.)  Now SETF of APPLY works for any
-function which has a setf function.
-
-Changed GET-SETF-METHOD to ignore setf macros (always global) when there is a
-local macro or function of the place function.  [An x3j13 cleanup]
-
-Some fixes to DI: condition report methods, and a preliminary version of
-breakpoints.
-
-MACROEXPAND now expands symbol macros.
-
-Fixed the new (sequential) ONCE-ONLY to deal properly with things like
-(once-only ((a (somefun a))) ...).
-
-ROOM is now much more verbose, displaying a breakdown of memory usage by object
-type.
-
-In the Unix interface, extended the length of pathnames from 64 to 1024.
-
-Fixed sequence functions with output type specifiers to handle DEFTYPE'ed types
-and other complex types correctly.  COERCE is still broken.
-
-Compiler:
-
-The compiler will now print a note whenever there is a FTYPE declaration for a
-function, and an argument is assigned to.
-
-If debug-info is < 1, then don't dump debug-args or function type.
-
-&aux bindings are now compiled with the interface policy.  Fixed a few places
-where complex keyword arguments were not being correctly checked according to
-the interface policy.
-
-Fixed block compilation stuff to ignore START-BLOCK declarations if
-:BLOCK-COMPILE is NIL.
-
-The compiler now ignores assignments to special variables when determining
-which representation to use for a variable.  Also, we don't print
-representation selection efficiency notes about coercion that are due to
-error checking code.
-
-Changed the type system to consider #(:foo :bar) to be a subtype of 
-(vector keyword).  In other words, array subtype relations are determined
-according to the specialized element types actually present in this
-implementation, rather than assuming that all element types can be
-discriminated.
-
-Hemlock:
-
-Fixed a bug in completion mode (didn't previously work in the new-compiler
-system.)
-
-Made the slave switch demon set debug:*help-line-scroll-count* to
-most-positive-fixnum, since the editor can do the scrolling for us.
-
-CLX:
-
-Merged in a bug-fix to EVENT-LISTEN to make it return the right number of
-events when called when there is a current event (i.e. in an EVENT-CASE.)
-
-4/25/91 to 4/28/91
-
-Release mainly to fix a problem with in-core compilation introduced in the 3/27
-release (the usual symptom was flaming out during the compilation with a type
-error about an illegal object.)
-
-Also, Hemlock has a new command "Set Buffer Writable", and the obsolete command
-"Connect to Registered Eval Server" has been removed.
-
-
-4/21/91 to 4/25/91
-
-Some minor space reductions from leaving out compiler databases that users
-don't need, and from reducing the initial allocation size of Hemlock string
-tables.  Some major space reductions from compiling with debug-info 1, and
-reduced safety.  The core is currently 18.8 meg, which is 2.5 meg smaller than
-the last alpha release and 7.3 meg smaller than the current beta release.
-
-Major parts of the system are now compiled with no error checking.  Users
-should not notice any reduction in safety, since user visible interfaces are
-supposed to be fully checked.  Standard functions that users can cause to get
-unbound symbol or array index errors needed to be changed to either do explicit
-error checks or locally use a safe policy.  Some of these cases may have been
-missed.  Let us know if you get any less-than-informative error messages
-(segmentation violation) inside standard functions.
-
-Code:
-
-Argument type checking for Common Lisp functions is now driven by the
-compiler's function type database.  This means that some type errors might be
-detected that were previously unnoticed.
-
-Added a CONTINUE restart in LOAD that returns NIL.  Fixed up the code that was
-trying to prevent you from loading zero-length fasl files (from AFS lossage).
-Now if you try to load a file with a fasl file type, but that doesn't have a
-valid fasl header, then you will get an error (proceeding loads as a source
-file.) 
-
-The non-destructive string functions now accept characters as well as strings
-and symbols.  This is an x3j13 change.
-
-Changed the internal WITH-ARRAY-DATA macro to do bounds checking.  This causes
-various string functions to give better error messages when an :END arg is out
-of bounds or :START is greater than :END.
-
-Added type inference methods for sequence functions, and various functions that
-return an argument as their result value.
-
-Hemlock:
-
-Added "Slave GC Alarm" variable (default :MESSAGE) which controls how obnoxious
-the slave GC notification is.  Other values are like for "Input Wait Alarm",
-:LOUD-MESSAGE and NIL.
-
-Extensions:
-
-ONCE-ONLY now does sequential variable binding.  This can't cause any problems,
-since all names are gensyms, and is often useful.
-
-4/10/91 to 4/21/91
-
-Code:
-
-Fixed some bugs in control of garbage collection that should solve some
-problems with GC failing to be triggered automatically.  Also, GC no longer
-implicitly reenables automatic GC if it has been disabled with GC-OFF.
-
-Changed the default GC notify function to not beep.  The old behavior can still
-be obtained by setting *GC-VERBOSE* to :BEEP.  Note that this only affects use
-on TTYs, since slave GC notification works differently.
-
-Changed the printer to print the name of code objects and the value of value
-cells.
-
-Compiler:
-
-Added the OPTIMIZE-INTERFACE declaration, which is just like OPTIMIZE, but
-specifies the policy for parsing the arguments to defined functions and
-checking of any declared argument types, allowing it to be distinct from the
-general compilation policy.  This allows debugged code to be compiled with
-lowered safety in its "guts", while still doing checking on the arguments that
-users may supply (incorrectly.)  Any quality not separately specified defaults
-to the normal OPTIMIZE quality.
-
-Fixed WITH-COMPILATION-UNIT keyword to be :OVERRIDE instead of :FORCE.
-Also, added :OPTIMIZE and :OPTIMIZE-INTERFACE for changing the "global"
-compilation policy within the dynamic extent.
-	
-Added :CONTEXT-DECLARATIONS, which provides a way to insert declarations
-conditional on pattern matching of the context in which the definition
-appears.  So you can compile all external functions safe, or whatever.
-See the doc string for WITH-COMPILATION-UNIT.
-
-Fixed a bug in accessors for 1,2, and 4 bit arrays that was causing #* to
-generate incorrect bit vectors.
-
-
-4/8/91 to 4/10/91
-
-In addition to William's fix to LOAD :IF-DOES-NOT-EXIST NIL, and a few fixes in
-compiler internal error messages, this core is also 1.6 meg smaller than the
-last core, which makes it 2.8 meg smaller than the current beta.  (A mere 23.4
-meg)
-
-This space reduction came from compiling the compiler VM definition with
-debug-info 1 and safety 0.
-
-
-3/27/91 to 4/8/91
-
-Code:
-
-Changed load to look at the file contents for the "FASL FILE" header to
-determine whether to fasload or slow load, instead of forcing use of a single
-fasl file type.  Also, when the given filename doesn't exist and doesn't have a
-type, try ``fasl'' in addition to the machine specific fasl file type.
-
-When the loader prints comments about loading progress, the number of leading
-semicolons is now the depth of recursive loading.
-
-Compiler:
-
-Reduced the size of debug information for OPTIMIZE DEBUG-INFO less than 1.
-
-Compiled Hemlock with minimal debug debug, reducing the core size 1 meg.
-
-Added new START-BLOCK and END-BLOCK declarations to allow portions of a file to
-be block compiled (instead of only entire files.)  This mechanism also allows
-the entry points to a block to be specified, allowing improved compilation of
-non-entry-point functions.  Fixed many bugs that appeared once block
-compilation was actually used.
-
-COMPILE-FILE now has :ENTRY-POINTS and :BLOCK-COMPILE keywords.  :BLOCK-COMPILE
-NIL will totally inhibit compile-time resolution of function names (including
-self-calls.)  The default (:SPECIFIED) allows compile time resolution, but
-still one top-level form at a time, preventing local calls between top-level
-forms.  In this mode, a (BLOCK-START Entry-Point*) declaration will start block
-compilation.  Block compilation is terminated by BLOCK-END, or the BLOCK-START
-of the next block.
-
-See also the COMPILE-FILE doc string.
-
-Also, the ANSI :VERBOSE and :PRINT keyword arguments are now supported.  The
-:PROGRESS keyword is a CMU extensions that provides an even higher level of
-verbosity.  The *COMPILE-VERBOSE*, etc., variables are also now supported.
-
-Made forms within a LOCALLY be recognized as "top-level" so that subforms can
-be compiled separately.
-
-
-3/14/91 to 3/27/91
-
-Highlights:
-
-** The FASL file format has changed, so all files must be recompiled. **
-
-
-Code:
-
-Modified EXT:OPEN-CLX-DISPLAY to set XLIB:DISPLAY-DEFAULT-SCREEN to the
-screen specified by the user before returning the display.
-
-Fixed DOCUMENTATION to retun only one value.
-
-Fixed typep of (satisfies (lambda (obj) ...)) to coerce the form into a
-function instead of just assuming that it could be funcalled.
-
-Wrapped a without-interrupts around the guts of maybe-gc so that the
-notify messages and state updates don't get seperated from the actual
-gc.
-
-Removed the icache flushing stuff from GC, because it was unneeded (and
-sometimes printed annoying messages that it didn't work).
-
-
-Compiler:
-
-Fixed CHECK-KEYWORDS not to print "zeroth".
-
-Fixed a bug introduced in the previous core in which special bindings would
-not be undone if the function doing the binding tail-called some other
-function.
-
-An additional slot has been added to the header of code objects.  This slot
-holds the offset of an optional ``trace-table'' that contains information
-about where function prologues and epilogues, call sites, and other random
-things occure.  This will allow more reliable backtracing from interrupts.
-
-
-Hemlock:
-
-Added *in-redisplay* flag which inhibits recursive invocations of redisplay
-from doing anything.  Recursive invocations can happen in TTY redisplay, since
-LISTEN serves events.  Also, made REDISPLAY-WINDOW-FROM-MARK check that we are
-in the editor before doing anything.
-
-Modified MAKE-BUFFERS-FOR-TYPESCRIPT to make sure the user supplied slave-name
-is free for use, so we don't clobber currently existing slaves.
-
-
-
-3/11/91 to 3/14/91
-
-Code:
-
-Fixed FUNCTION-DEBUG-FUNCTION (though it still returns the XEP.)
-
-Fixed a bug in RENAME-PACKAGE that happened when the new name was one of the
-old nicknames.
-
-Added support for the TIOCGWINSZ and TIOCSWINSZ ioctls.
-
-Compiler:
-
-Some compiler debug fixes that will hopefully eliminate spurious
-undefined-function warnings.  In particular, definitions of functions in
-non-null lexical environments will be noticed.
-
-Also, now if a function is defined incompatibly with previous calls, the
-warning will have proper source context.
-
-The compiler note count is no longer incremented when notes are suppressed by
-INHIBIT-WARNINGS 3.
-
-Hemlock:
-
-Several changes to allow redisplay to be delayed until process output (i.e. in
-a shell buffer) is complete.  This allows the editor to catch up with output by
-only displaying the final state of the shell buffer, instead of forcing every
-line of output to be displayed.  This is very nice with slow terminals or large
-outputs.
-
-Changed TTY redisplay to get the terminal size and speed from Unix using the
-appropriate "ioctl" calls.  The speed of a PTY (and hence any telnet or MCN
-connection) is infinite by default.  For best results with TTY redisplay, it is
-crucial to set the terminal speed with the Unix "stty" command:
-    stty 2400
-    stty 9600
-etc.
-
-Setting the speed allows the editor to keep in synch with the terminal so that
-typing a command can abort redisplay until the screen stabilizes.  
-This way, if you type C-v C-v in succession, output of the first screen will
-stop when you type the second C-v.
-
-Fixed several bugs in TTY redisplay.  "Unexpected zero transition delta" is
-gone.  Also, fixed some problems with the screen not being updated properly
-after redisplay has been aborted.  (When you type several commands in quick
-succession.)
-
-REDISPLAY now returns T, NIL or :EDITOR-INPUT.  T is returned when redisplay
-changed the screen.  NIL is returned when there was no change.  :EDITOR-INPUT
-is returned when redisplay tried to update the screen, but was aborted due to
-pending editor input.
-
-Changed the editor input loop calling redisplay until it indicates no change.
-This insures that any text modifications happening concurrently with redisplay
-(such as process output) will be noticed before we go into a read wait.
-
-
-3/4/91 through 3/11/91
-
-Only Compiler fixes:
-
-Fixed a number of bugs in the handling of closures over top-level variables.
-
-Fixed a problem with semi-inline functions.
-
-Fixed a problem with local call conversion of functions with both optionals and
-more args.
-
-Disabled the compiler's internal consistency checking by default.  These phases
-are only useful for locating compiler bugs.
-
-
-2/3/91 through 3/4/91
-
-General system code:
-
-Merged fix to DEFSTRUCT constructor parsing that allows multiple default
-constructors, or none at all.  You will need to recompile uses of DEFSTRUCT for
-the #S reader to work correctly.
-
-Fixed bit-copy assembly routine to correctly handle overlapping source and
-destination. 
-
-standard-char-p no longer returns T for #\return
-
-Fixed default-structure-print to work when *print-circle* is T.
-
-Fixed a bug in format regarding ~@*.
-
-Fixed the read-eval-print loop to frob +, ++, +++ correctly.
-
-Changed fasl loader to eliminate the "feature" whereby zero-length fasl files
-were considered to be valid (doing nothing).
-
-Changed DEFPACKAGE to expand into stuff that will have the package effect at
-compile time as well as at load time.
-
-Fixed DEFPACKAGE to deal more correctly with finding symbols that must exist.
-
-Fixed package system code to not destructively modify the USE, USED-BY and 
-SHADOWING-SYMBOLS lists so that they don't get retroactively modified when
-we hand them off to the user.
-
-Also, in SHADOW, when symbols is NIL, shadow no symbols, not NIL.
-
-Fixed a bug in Y-OR-N-P.  It was calling WHITESPACEP on a symbol.
-
-Fixed READ-QUOTE to call READ with t for eof-errorp which it previously failed
-to do.  fixed READ-PRESERVING-WHITESPACE to no longer screw with eof-errorp
-based on recursivep
-
-Fixed the LOOP THEREIS keyword.
-
-Tweaked handling of LISTEN a bit to allow READ-CHAR-NO-HANG to work correctly.
-Fixed the listen method for concatenated streams.  It failed to step to the
-next stream when the current one hit eof.
-
-Make two-way streams force-output on the output side before passing any
-input requests on to the input side.  This eliminates the need for explicit
-calls for FORCE-OUTPUT when prompting.
-
-Changed GET-INTERNAL-REAL-TIME to subtract out the time of the first
-call to minimize the probability of bignum results.  Also some other tuning
-that reduced the consing of this function to 0.
-
-Changed TRACE to use FORCE-OUTPUT instead of FINISH-OUTPUT to prevent
-gratuitous slowdowns when running in a slave.
-
-Compiler:
-
-Fixed EQL (and =) on integers to not unnecessarily cons a word-integer argument
-just because one argument is known to be a fixnum.
-
-A number of improvements to register allocation.
-
-New version of the assembly with instruction scheduling (no-op deletion)
-support.  This reduced the size of the core by 1.3 meg, and makes everything
-run faster too.
-
-Fixed incorrect argument type information for some standard Common Lisp
-functions.
-
-Added a new optimization of MULTIPLE-VALUE-CALL which converts MV calls having
-a known number of arguments into MULTIPLE-VALUE-BIND/FUNCALL.  Combined with
-some other existing optimizations, this allows functions like:
-    (defun foo (&rest x)
-      (apply #'glorp x))
-
-to be efficiently inline expanded (i.e. the APPLY turns to a FUNCALL.)
-
-Fixed PROCLAIM to work correctly when the argument isn't a constant.
-
-Eliminated some problems that could cause spurious undefined function
-warnings.
-
-Fixed the compiler to not flame out if it sees a SATISFIES type specifier where
-the predicate function is undefined, and generally to deal better with testing
-whether a compile-time constant is of some type that may not be properly
-defined yet.
-
-Fixes to copy propagation and register allocated to reduce spurious moves.
-
-Hemlock:
-
-Changed typescript streams to cache the line length.  This greatly speeds up
-slave output.
-
-CLX:
-
-Eliminated redundant type checking.
-Fixed some broken declarations.
diff --git a/general-info/beta-release-notes.txt b/general-info/beta-release-notes.txt
deleted file mode 100644
index 2b177e4282578b62273a7e58fd8164e3ea880835..0000000000000000000000000000000000000000
--- a/general-info/beta-release-notes.txt
+++ /dev/null
@@ -1,766 +0,0 @@
-	    Release notes for CMU Common Lisp 16f, 11 December 92
-
-The changes between 16e and 16f are almost exclusively bug-fixes.  When we
-announce a version 17 beta, 16f will probably become the default release
-(replacing 15e).  The PCL has been upgraded from "March 92 (2a)" to 
-"March 92 (2c)", which provides some bug-fixes; also, all of the patches in
-the March-92-PCL-bugs file have been applied.
-
-Enhancements:
- -- PROVIDE & REQUIRE are now back in the system, since proposed ANSI CL has
-    reinstated them as deprecated features.  See the doc strings for these
-    functions and EXT:DEFMODULE.
- -- The SPARC dynamic heap size limit has been doubled from 64meg to 128meg.
-
-Pretty printer:
- -- Fixed a bug in pprint-let that caused to to barf on (let (nil) ...).
- -- Fixed pprint-lambda-list to print a space before the dot when the tail of
-    the lambda list is shared.  In other words, print (foo . #1=(bar baz))
-    instead of (foo. #1=(bar baz)).
- -- Added an additional use of ~^ in pprint-flet so that (flet (nil) ...)
-    doesn't flame out.
- -- Make pretty printer properly process pprint tabs when output is forced.
- -- In format pprint logical blocks, fixed ~^ to act like
-    PPRINT-EXIT-IF-LIST-EXHAUSTED instead of blowing out to some containing
-    directive.
-
-Compiler:
- -- Fixed compiler internal error with dead-code deletion of top-level code.
- -- Bind *gensym-counter* instead of setting it so that compiling doesn't
-    globally reset the gensym counter.
- -- Fixed problem with interpreted LOAD-TIME-VALUE causing undefined function
-    VALUE-CELL-REF errors.
- -- Preserve the arglist in interpreted functions for DESCRIBE, etc.
- -- Gag bound-but-not-referenced warnings when the EXT:INHIBIT-WARNINGS
-    optimize quality is 3.
- -- Fixed a problem with register allocation conflict analysis which appeared
-    when a function was called with ~>= 50 arguments.
- -- Fixed bug with optimization of tail local calls.
- -- Fixed interpreted PROCLAIM/DECLAIM to ignore
-    START-BLOCK, END-BLOCK and declared DECLARATION declarations.
-    Changed the unrecognized proclamation error to be a warning.
- -- Fixed float heap allocation to not wedge when the store causes a trap
-    (SPARC only.)
-
-Trace:
- -- Added pretty-printer directives so that arg lists and results print better.
- -- Fixed UNTRACE not to flame out when untracing untraced functions.
- -- Fixed bug with redefining function traced with encapsulation (e.g.
-    interpreted functions.
-
-Misc bug fixes:
- -- Fixed I/O timeout handling (e.g. for CLX) to correctly borrow from the
-    timeout seconds when computing the new value for the timeout microseconds.
- -- Restored proper (prompt) handling of queued CLX events in SERVE-EVENT
- -- Alien enums always take up an int to be compatable with C.  Also,
-    sort the from-alist so that enum aliens are unparsed in a canonical
-    format.
- -- When doing macro destructuring, check to see if some part of a lambda-list
-    is a LIST before checking to see if it is a SYMBOL, because we want NIL to
-    act like the empty list, and not an attempt to bind NIL.  
- -- Fixed PACKAGE-ERROR to have a PACKAGE slot instead of a PATHNAME slot.
- -- Changed DOLIST not to introduce the spurious let around the result form
-    when there is no result form.  Also, just read the var in the spurious
-    let, instead of using IGNORABLE, since the var might be special.
- -- In complex DEFSETF, don't bother creating temp vars for constants.  This
-    is necessary so that keywords stay keywords, and are not changed to
-    gensyms.
-
-Enhancements:
- -- Changed the backquote expanded functions (backq-list, ...) from being
-    inline functions to compiler-macros, since although the optimizer does
-    eventually get the right code, it has to work awful hard.  Changed BREAK
-    to accept a condition as well as a format string.
- -- Exported EXT:CONNECT-TO-UNIX-SOCKET and EXT:CREATE-UNIX-SOCKET, which had
-    been forgotten before.  Added code to CONNECT-TO-UNIX-SOCKET so that Unix
-    domain sockets are available for connecting to other processes.
- -- Removed sys:*task-data* and sys:*task-notify* because they aren't used
-    even under Mach.
-
-
-
-	    Release notes for CMU Common Lisp 16e, 5 August 92
-
-16e is primarily a bug-fix release.  The main changes from 16d are:
- -- CLOS support is from March 92 PCL (2a).  This is a new version of PCL
-    developed by Richard Harris which incorporates many bug-fixes and ANSI
-    compliance cleanups.  He has also back-merged the CMU changes into his
-    sources so that we can release future PCLs without time-consuming merging.
-    On the downside, there are a couple of new bugs (discrimination on 
-    pcl::structure-object doesn't always work; generic functions which contain
-    methods which discriminate on both null and list sometimes do not work).
-    Patches for these bugs are available in March-92-PCL-bugs in the CMU CL
-    release area and by anonymous ftp from host parcftp.xerox.com 
-    (13.1.64.94), in the directory pub/pcl/.
- -- TRACE has been reimplemented, has a new syntax and new features.
- -- The hardcopy and info documentation has been updated.  Note that it
-    describes some debugger capabilities (breakpoints) which won't appear
-    until version 17.
-
-The fasl file format is the same as for 16d, but some code may need to be
-recompiled.  In particular, the expansion of PPRINT-LOGICAL-BLOCK has changed.
-
-
-March 92 PCL highlights:  (see notes.text in the sources for details)
- -- This version of PCL is much closer than previous versions of PCL to the
-    metaobject protocol specified in "The Art of the Metaobject Protocol",
-    chapters 5 and 6, by Gregor Kiczales, Jim des Riveres, and Daniel G.
-    Bobrow.
- -- You can use structure-class as a metaclass to create new classes.
-    Classes created this way create and evaluate defstruct forms which
-    have generated symbols for the structure accessors and constructor.
- -- Various optimization of instance variable access, both inside and outside
-    of methods.
- -- More work (lookups and precompilation) is done at compile and load time,
-    rather than run-time.
-
-
-New TRACE:
-
-Trace has been substantially rewritten, and has a new syntax as well as new
-functionality:
- -- Tracing of compiled functions is now implemented using breakpoints.
-    Breakpoints destructively modify the code object, causing all calls to the
-    function to be trapped, instead of only those calls that indirect through
-    the symbol.  This makes TRACE more useful for debugging programs that use
-    data structures containing function values, since you can now trace
-    anonymous functions and macros.  Also, the breakpoint stops the function
-    after the arguments have been parsed, so arguments can accessed by name in
-    the debugger or in TRACE options.
- -- Depending on the ENCAPSULATE option and DEBUG:*TRACE-ENCAPSULATE-DEFAULT*,
-    encapsulation may be used instead.  This is the default for closures,
-    generic functions and interpreted functions.
- -- TRACE options are no longer set off by extra parens, and you can specify
-    global trace options which affect all functions traced by a particular
-    call to TRACE.
- -- Conditional breakpoints now work much better than before.
- -- *DEBUG-PRINT-LEVEL*, -LENGTH* are used instead of a separate
-    *TRACE-PRINT-LEVEL*, etc.
-
-Here is the documentation string (see also the hardcopy/info documentation):
-   TRACE {Option Global-Value}* {Name {Option Value}*}*
-   TRACE is a debugging tool that prints information when specified functions
-   are called.  In its simplest form:
-       (trace Name-1 Name-2 ...)
-
-   TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named
-   functions is entered or returns (the Names are not evaluated.)  The output
-   is indented according to the number of pending traced calls, and this trace
-   depth is printed at the beginning of each line of output.
-
-   Options allow modification of the default behavior.  Each option is a pair
-   of an option keyword and a value form.  Options may be interspersed with
-   function names.  Options only affect tracing of the function whose name they
-   appear immediately after.  Global options are specified before the first
-   name, and affect all functions traced by a given use of TRACE.
-
-   The following options are defined:
-
-   :CONDITION Form
-   :CONDITION-AFTER Form
-   :CONDITION-ALL Form
-       If :CONDITION is specified, then TRACE does nothing unless Form
-       evaluates to true at the time of the call.  :CONDITION-AFTER is
-       similar, but suppresses the initial printout, and is tested when the
-       function returns.  :CONDITION-ALL tries both before and after.
-
-   :WHEREIN Names
-       If specified, Names is a function name or list of names.  TRACE does
-       nothing unless a call to one of those functions encloses the call to
-       this function (i.e. it would appear in a backtrace.)  Anonymous
-       functions have string names like "DEFUN FOO".
-
-   :BREAK Form
-   :BREAK-AFTER Form
-   :BREAK-ALL Form
-       If specified, and Form evaluates to true, then the debugger is invoked
-       at the start of the function, at the end of the function, or both,
-       according to the respective option.
-
-   :PRINT Form
-   :PRINT-AFTER Form
-   :PRINT-ALL Form
-       In addition to the usual prinout, he result of evaluating Form is
-       printed at the start of the function, at the end of the function, or
-       both, according to the respective option.  Multiple print options cause
-       multiple values to be printed.
-
-   :FUNCTION Function-Form
-       This is a not really an option, but rather another way of specifying
-       what function to trace.  The Function-Form is evaluated immediately,
-       and the resulting function is traced.
-
-   :ENCAPSULATE {:DEFAULT | T | NIL}
-       If T, the tracing is done via encapsulation (redefining the function
-       name) rather than by modifying the function.  :DEFAULT is the default,
-       and means to use encapsulation for interpreted functions and funcallable
-       instances, breakpoints otherwise.  When encapsulation is used, forms are
-       *not* evaluated in the function's lexical environment, but DEBUG:ARG can
-       still be used.
-
-   :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment
-   of the called function; DEBUG:VAR and DEBUG:ARG can be used.  The -AFTER and
-   -ALL forms are evaluated in the null environment.
-
-
-Assorted bug fixes and enhancements:
-
-System code:
- -- Changed default base file name for LOAD-FOREIGN to be argv[0] rather than
-    being hard-wired to "lisp".
- -- Fixed a bad declaration which caused garbage collection to fail if more
-    than MOST-POSITIVE-FIXNUM bytes had been consed since process creation.
- -- Changed GET-INTERNAL-RUN-TIME to use UNIX-FAST-GETRUSAGE to avoid
-    number-consing and generic arithmetic.  Also, rearranged the computation
-    so that the time is correctly computed for up to 457 days, instead of only
-    71 minutes.
- -- Merged Miles' fix to MAKE-PATHNAME so that it knows the difference between 
-    an arg being NIL and being unsupplied.
- -- Some partial fixes to circular printing (the #1=#1# bug).
-    PPRINT-LOGICAL-BLOCK no longer checks the list argument for CAR
-    circularity, now that OUTPUT-OBJECT does it for us.
- -- Fixed reader dispatch macro characters to be case-insensitive, and to
-    disallow digits as sub-characters.
- -- Changed #A reader to allow arbitrary sequences instead of just lists.
- -- RUN-PROGRAM now gives a proper error message when "fork" fails (i.e. too
-    many processes.)
- -- Fixed a bug in initialization of saved cores which caused the old
-    environment to be left on the end of EXT:*ENVIRONMENT-LIST*.  One symptom
-    was that RUN-PROGRAM would run programs with strange environment values
-    based on those in effect at the time the core was saved.  In particular,
-    Lisp subprocesses (i.e. Hemlock slaves) might get the wrong value of
-    CMUCLLIB, which caused the slave to die before connecting.
- -- SYSTEM:SERVE-EVENT (and XLIB:EVENT-CASE, etc.) now correctly handle
-    non-integer timeouts.  Added declarations to improve the efficiency of
-    event handling.
- -- Fixed some bugs in UNIX-SELECT which could cause Lisp to hang when more
-    than 32 files were open.  Also, improved efficiency in this case.
- -- Merged Olssons fix to WITH-ENABLED-INTERRUPTS to not try to change
-    interrupt characters anymore.
- -- A number of bug-fixes for breakpoint support in compiled code (but there
-    are still problems with arbitrary breakpoints.)
- -- Fixed DI:FRAME-CATCHES
-
-CLX:
- -- Fixed the implementation-dependent pixarray copying routines (for
-    GET-IMAGE, etc.) so that they don't occasionally trash memory, and are
-    actually faster.
- -- Fixed the definition of the ANGLE type (used by DRAW-ARC, etc.) to work
-    regardless of the kind of real number (single or double float, rational,
-    etc.)
- -- Fixed several places in image operations where values that could really
-    be negative were declared to be non-negative.
-
-Compiler:
- -- Fixed a bug which caused an internal error whenever a call to random
-    was compiled and the argument type wasn't known to be either a float or
-    an integer.
- -- Fixed a bug which caused an internal compiler error when a value that
-    wasn't used had an unproven type assertion.
- -- Fixed some more dead-code deletion bugs.
- -- Fixed a problem with the new "assignment" optimization of local function
-    call where the compiler could get assertion failures such as tail-sets not
-    being equal.
- -- Fixed a few places where reoptimization wasn't being triggered when it
-    should have been.
- -- You can now have a TAGBODY with more than one tag that is non-locally
-    exited to.  Evidently this never worked...
- -- Some changes in debug-info format related to breakpoint support.
-
-Misc:
- -- Fixed some Hemlock Dired commands to know that PATHNAME-DIRECTORY is
-    now a list, not a vector.
- -- Fixed the bin/sample-wrapper script to use "$@" instead of $* so that
-    arguments are properly passed through.
-
-
-	    Release notes for CMU Common Lisp 16d, 30 May 92
-
-16d is our first version 16 general release, and incorporates many changes not
-present in the 15 series.  It is currently fairly close to our current
-internal development (alpha) systems, and is thus less stable.  The major
-changes are:
-    New Aliens
-    New pathnames
-    New pretty printer
-    New format
-    R5.0 CLX.  
-    5/1/90  May Day PCL (REV 4b)
-    Revised manual
-
-The fasl file format is nominally compatible with version 15, but the pathname
-change affects any pathname constants in fasl files, which includes the
-defined-from information present in every fasl file.  It is probably a good
-idea to recompile everything.
-
-CLX and Hemlock are now optional.  When CMU CL is installed, the maintainer can
-elect not to load CLX and Hemlock -- this saves 7 megabytes of disk and
-improves memory usage somewhat.  See the installation section of the README
-file for details.
-
-The ``CMU Common Lisp User's Manual'' has been updated to be more helpful for
-non-CMU users.  The new manual also documents the new Alien facility for
-foreign function calls and data structure access.  The manual is now formatted
-with Mike Clarkson's LaTeXinfo package, so a consistent version of the
-documentation is available online in Gnu info format.  See `doc/cmu-user.ps'
-and `doc/cmu-user.info'.
- 
-
-General system code:
-
-ANSI cleanups:
- -- ANSI Compiler macros are now implemented: see COMPILER-MACRO-FUNCTION,
-    COMPILER-MACROEXPAND, COMPILER-MACROEXPAND-1 and DEFINE-COMPILER-MACRO.
- -- Fixed things that invoke *MACROEXPAND-HOOK* to coerce it to a function
-    before calling it.
- -- Fixed MACRO-FUNCTION to take an environment argument.
- -- SYMBOL-MACROLET now accepts declarations.
- -- SHADOW now accepts strings in addition to symbols.
- -- Added UPGRADED-ARRAY-ELEMENT-TYPE and UPGRADED-COMPLEX-PART-TYPE.
- -- IGNORABLE is now in the LISP package instead of the EXT package.
- -- ADJUST-ARRAY has been updated to allow adjusting of arrays which were
-    not created with :adjustable non-nil to be adjusted to new dimensions.
- -- ADJUSTABLE-ARRAY-P has been updated correspondingly. It returns T if
-    adjust ADJUST-ARRAY would return an EQ array.
- -- The BASE-CHARACTER type has been renamed to BASE-CHAR.
- -- The REAL type and REALP function are now implemented.
- -- Changed the default structure printer to print slot names as keywords
-    instead of unqualified symbols.
-
-Enhancements:
- -- Added MAYBE-INLINE declaration for GET, PUT, etc., so that these
-    functions can be inline expanded according to the compilation policy.
- -- Added some type declarations so that GET-INTERNAL-REAL-TIME doesn't cons.
- -- Process the command line before printing the herald so that we can eval
-    some form and quit without printing anything.
- -- SET now protects against setting T, NIL, and keywords.  (SETF
-    SYMBOL-FUNCTION) now expands into FSET, which protects against defining
-    NIL.
- -- Substantially rearranged function describing to make it more consistent,
-    and added support for describing interpreted functions.
- -- PURIFY is now called multiple times during system building to improve
-    locality.  
- -- (EVAL-WHEN (EVAL) ...) is now actually eval'ed.
-
-Bug fixes:
- -- Fixed bug in NTH-VALUE where it expanded into bogus code unless ``n'' was
-    a constant integer.
- -- Fixed FMAKUNBOUND to return the symbol instead of T.
- -- Allocate memory as executable so that the OS knows to maintain cache
-    consistency.
- -- Changed DESCRIBE to allow T or NIL as the stream argument.
-
-Load enhancements and cleanups:
- -- The initial value of *LOAD-VERBOSE* is now T.  Additionally, LOAD no
-    longer always binds *LOAD-VERBOSE* and *LOAD-PRINT*.  Now it only
-    binds them when :VERBOSE or :PRINT are explicity supplied.  Therefore, you
-    can set either of these in your init file and it will take effect.
- -- Normally when *LOAD-VERBOSE* is T, only the file name is printed.
-    Formerly, the loaded stream was always printed, whereas now a stream is
-    printed only when the stream is not a file stream.
- -- Added ANSI features *LOAD-TRUENAME*, *LOAD-PATHNAME* and *LOAD-PRINT*.
- -- As per ANSI, bind *READTABLE* to itself to make assignments file-local.
- -- Added new variables EXT:*SOURCE-FILE-TYPES* and EXT:*OBJECT-FILE-TYPES*.
-    When no file type is specified, LOAD tries the types in these lists to
-    locate the source and object files.  LOAD now recognizes source types "l",
-    "cl" and "lsp" in addition to "lisp".
- -- The compiler OPTIMIZE policy is now bound during load, so proclamations in
-    a file don't leave the global policy clobbered when the load is finished.
- -- Changed the :IF-SOURCE-NEWER option to signal an error and use restarts,
-    rather than PROMPT-FOR-Y-OR-N.  Fixed the load source case to actually
-    load the source, rather than loading the object as a source file...
- -- Changed load to deal with source files having NIL type more reasonably.
- -- If a wild pathname is given to LOAD, all files matched will be loaded.
- -- Proceeding from nonexistent file errors has been improved.  It is no longer
-    assumed that missing files are always source files.  Added condition
-    restarts for missing files.
- -- Improved formatting of error and warning messages.
-
-
-Garbage collection:
- -- Changed the minimal ROOM output to include all easily computed information
-    including whether GC is disabled.  The verbose ROOM now conses less.
- -- Removed the :ENABLE-GC SAVE-LISP option, as it's no longer needed.
-    Garbage collection is now correctly enabled in cores which have been saved
-    and then restarted.
- -- Added EXT:BYTES-CONSED-BETWEEN-GCS, a function that returns (and sets when
-    used with setf) *BYTES-CONSED-BETWEEN-GCS*.  Additionally, it changes
-    *GC-TRIGGER* immediately to reflect the new values of *bytes-consed...*.
- -- TIME now displays the GC run-time.
- -- Added EXT:*GC-RUN-TIME* with accumulates the INTERNAL-RUN-TIME spent doing
-    garbage collection.  Added declarations to make EXT:GET-BYTES-CONSED more
-    efficient.
- -- The top-level REP loop now zeros the unused non-zero portion of the
-    control stack to discourage spurious garbage retention.
- -- The garbage collector now closes open file streams when it reclaims them.
-
-
-Packages:
- -- The LISP and USER packages have been renamed to COMMON-LISP and
-    COMMON-LISP-USER.  LISP and USER are nicknames, so they can still be used.
- -- The LISP package namespace has been cleaned up somewhat.  For example,
-    *DESCRIBE-PRINT-LEVEL* is no longer exported from LISP.
- -- The Mach/Unix division in the package system has been clarified a great
-    deal.  Unix specific features have been moved from the MACH package to the
-    UNIX package.  Mach specific features have been left in (or moved to) the
-    MACH package.  For example, all standard Unix syscalls are related
-    definitions are un UNIX, whereas vm_statistics remains in MACH and GR-CALL
-    has been moved to MACH.
-
-SETF cleanups:
- -- Changed GET-SETF-METHOD-MULTIPLE-VALUE to try to macroexpand-1 the form
-    when it's an atom in case it's a symbol-macro as per the X3J13 cleanup
-    SYMBOL-MACROLET-SEMANTICS:SPECIAL-FORM.  Now you can safely INCF, etc.
-    symbol macros where the macroexpansion has side effects.
- -- Fixed SETF of GETF to evaluate the various parts in the correct order as
-    per X3J13 cleanup SETF-SUB-METHODS:DELAYED-ACCESS-STORES.
- -- X3J13 cleanup SETF-MULTIPLE-STORE-VARIABLES:
-    Extend the semantics of the macros SETF, PSETF, SHIFTF, ROTATEF, and
-    ASSERT to allow "places" whose SETF methods have more than one "store
-    variable".  In such cases, the macros accept as many values from the
-    newvalue form as there are store variables.  As usual, extra values
-    are ignored and missing values default to NIL.
- -- Extended the long form of DEFSETF to allow the specification of more
-    than one "store variable", with the obvious semantics.
- -- GET-SETF-METHOD signals an error if there would be more than one
-    store-variable. 
-
-
-Printer:
-
-Almost all of the printing code has been rewritten/restructured to support
-all of the printing features added to the language.  Some highlights:
- -- *PRINT-READABLY* is now supported.
- -- *PRINT-CIRCLE* works irrespective of *PRINT-PRETTY*.  Note: the default
-    structure printer currently does not work when *PRINT-CIRCLE* is true: you
-    get #1=#1#.
- -- *PRINT-LEVEL* abbreviation now works automatically inside structure
-    printers.
- -- XP has been replaced with a native pretty printer that is fully
-    integrated with the rest of the system.  This Supports the ANSI
-    pretty-printing interface instead of the old Waters XP interface.  Existing
-    uses of the old interface will need to be updated to use the new names.
- -- The pretty-printer now unparses backquote forms on printing.  To retain
-    this information, the backqoute read macro no longer expands into LIST,
-    CONS, etc.  Internal functions are used instead.
- -- The macros WITH-STANDARD-IO-SYNTAX and PRINT-UNREADABLE-OBJECT have
-    been added.
- -- All new format.  Supports the FORMATTER macro and all the pretty-printing
-    directives.  FORMAT has extended to accept a function as the format control
-    (as an alternative to a string.)
- -- Added support for READTABLE-CASE in symbol printing.  Printing when
-    *PRINT-CASE* is :CAPITALIZE and *PRINT-ESCAPE* is NIL is now slightly
-    different than before.  Added some missing array type declarations in
-    symbol printing.
-
-Bug fixes:
- -- Fixed a bug which caused some float printing format directives to
-    infinitely loop when a fixed-width field overflowed.
- -- Specify stream when printing unbound marker.
- -- Fixed FORMAT to override printer control variables when printing float
-    exponents so that they are always printed in decimal, etc.
-
-
-Reader:
-
-ANSI Cleanups:
- -- *READ-EVAL* is now supported.  If a #. is encountered while *READ-EVAL*
-    is NIL (default T), an error is signaled.  This intended to allow
-    ``secure'' READ-based command interfaces to be written.
- -- READTABLE-CASE is now supported.
- -- The reader now signals the correct type of error when things go wrong
-    instead of always signaling a simple-error.
- -- Changed the return value of SET-SYNTAX-FROM-CHAR from NIL to T as per X3J13
-    cleanup RETURN-VALUES-UNSPECIFIED:SPECIFY.  [Hard to believe nobody has
-    complained about not conforming to this one.]
-
-Bug fixes:
- -- Fixes to several bugs with respect to #+, #-.  In particular, stacked
-    conditionals like "#+foo #-bar baz" now work 
- -- #n= and #n# now detect more error conditions and work on structures.
- -- # is now a non-terminating macro character, so foo#bar is read as a
-    symbol.
- -- Added Ted's changes to make INTERNAL-READ-EXTENDED-TOKEN work when there
-    are `|' escapes.  The main significance of this is that #+nil '|foo;bar|
-    and #:|foobar| now work properly.  Also changed this function to recognize
-    unquoted colons so that #:foo:bar will error, but not #:foo\:bar.
-
-Enhancement:
- -- Export new variable *ignore-extra-close-parentheses* if true (the default),
-    extra close parens are only a warning, not an error.  Previously unmatched
-    close parens were quietly ignored.
-
-
-Pathnames:
-
-This release supports all the new CltL2 pathname features except for logical
-pathnames.  Following is an overview of the new pathname support.
-
-Programs that actually conform to the CLtL1 pathname spec will have very few
-problems.  However, the CLtL1 spec was extremely vague, and CMU CL did not
-make use of much of the allowed flexibility, so many technically non-portable
-programs previously worked under CMU CL.
-
-The main incompatible changes from CLtL1 to CLtL2:
- -- Symbols are no longer acceptable filenames.
- -- PATHNAME-HOST may be any object.
- -- :UNSPECIFIC is now a legal pathname component.
- -- MERGE-PATHNAMES now recognizes relative pathnames and treats them
-    specially. 
-
-The format of directories is now specified (to be a list in a certain format.)
-This required an incompatible change from the previous practice of using a
-vector PATHNAME-DIRECTORY and using "DEFAULT" or :ABSOLUTE in the
-PATHNAME-DEVICE to indicate relative and absolute pathnames.
-
-In a related change, the CMU SEARCH-LIST extension was changed so that the
-search-list now appears in the PATHNAME-DIRECTORY as:
-    (:ABSOLUTE #<Search-list "name"> ...)
-
-Other changes to search-lists:
- -- (SETF SEARCH-LIST) now accepts a string or pathname, and converts it into
-    a one-element list.
- -- Search-list elements are now canonicalized to pathnames rather than to
-    strings. 
- -- Instead of returning NIL, SEARCH-LIST now signals an error when it is
-    called on an undefined search list. 
- -- SEARCH-LIST-DEFINED-P is a predicate that tells if the search list is
-    currently defined.
-
-New features which are now supported:
- -- Wildcard pathnames are now fully supported.  In addition to allowing :WILD
-    in any pathname component, "extended wildcards" such as "foo*.*" are also
-    supported.  A consequence of this is that PATTERN objects may appear in
-    wildcard pathname components instead of strings.  See PATHNAME-MATCH-P and
-    TRANSLATE-PATHNAME.
- -- As a CMU CL extension, a wildcard pathname may be used as the argument to
-    any filesystem interface (like OPEN) as long as it matches only one file.
- -- The pathname :COMMON case mechanism provides a way around the problems of
-    portably specifying string pathname components in the presence of operating
-    systems with differing preferred case in their filesystem.  An uppercase
-    string "LISP" is mapped to the "customary case" (lowercase on unix.)  
-    Lowercase is also inverted: "readme" becomes "README".  Mixed case is left
-    alone.  Note that this mechanism is explicitly enabled by supplying :CASE
-    :COMMON to functions such as MAKE-PATHNAME.  The default is the old
-    behavior (:CASE :LOCAL).
-
-Also, DIRECTORY now actually returns the TRUENAME of each file (as it was
-always supposed to do.)  If a matched file is a symbolic link, the truename may
-be a file in some other directory that doesn't even match the pattern.  The old
-behavior can be obtained by specifying :FOLLOW-LINKS NIL.
-
-The new wildcard pathname mechanism has not yet been used to replace the old
-single-wildcard matching in Hemlock DIRED, etc.
-
-
-Debugger:
- -- Added Miles' changes to keep errors and warnings on one line if they fit.
- -- The debugger now starts up with the error frame as the current frame, so
-    it is no longer necessary to manually skip over internal frames resulting
-    from the error system invocation.
- -- Fixed some debugger bugs that appeared when debugging interpreted code.
- -- Added ``DESCRIBE'' debugger command.
- -- Merged Miles' changes that allow the use of restart names as debugger
-    commands.
- -- Changed SHOW-RESTARTS to also display the restart name (but only if it's
-    not shadowed by a higher priority restart).  Changed the restart command
-    to look for restarts by name if a symbol is typed.
- -- Bind *CURRENT-LEVEL* to 0, *PRINT-READABLY* to nil, and *READ-EVAL* to T
-    when entering the debugger to make sure things print as expected.
-
-The debugger programmer (DEBUG-INTERNALS) interface is now documented in the
-User's Manual.  This interface allows the coding of debuggers and debugger
-extensions without requiring an intimate understanding of the compiler and
-run-time system.  Be warned that DI features (such as breakpoints) not used by
-the current debugger may not work very well (wait for version 17.)
-
-Debug internals changes:
- -- DI:DEBUG-FUNCTION-FUNCTION is now implemented.
- -- Added DI:FLUSH-FRAMES-ABOVE for cleaning up frames to be bound to
-    DEBUG:*STACK-TOP-HINT*.
-
-
-Defstruct:
-
-Various fixes and enhancements to defstruct slot parsing and inclusion.   
-It now works to define structures such as:
-    (defstruct super a)
-    (defstruct (sub1 (:conc-name super)) one)
-    (defstruct (sub2 (:conc-name super)) two)
-    (super-a (make-sub1))
-
-previously, a definition such as for SUB2 would define SUPER-A to be a
-SUB2-specific function, which could then no longer be used on other types.  The
-spec doesn't clearly say that such a construct is legal, but its use seems
-fairly common.
-
-Also, slot parsing is now more rigorous.  Unrecognized slot options cause an
-error, as does a slot spec like: (defstruct foo (a :type t))
-
-Fasl dumping of constant structures has been fixed to conform to X3J13.  The
-main significance of this is that DEFSTRUCT structures are no longer dumpable
-by default.  However, the generic function MAKE-LOAD-FORM isn't really used.
-Instead, a new defstruct option, :MAKE-LOAD-FORM-FUN, has been added that can
-be used to specify a function that acts like a MAKE-LOAD-FORM method.  When we
-have a CLOS that supports STRUCTURE-CLASS, the default method for
-MAKE-LOAD-FORM will use this information instead of having the compiler use it
-directly.  The old behavior can be enabled on a structure by structure basis by
-using the :MAKE-LOAD-FORM-FUN defstruct option:
-    (defstruct (foo (:make-load-form-fun :just-dump-it-normally))
-      ...)
-
-
-Compiler:
-
-Cleanups:
- -- Added the LOAD-TIME-VALUE support special form.
- -- Displaced or adjustable arrays and vectors with fill pointers can now be
-    dumped in fasl files, but are converted to simple array with the same
-    elements.
- -- Arrays of floats are left as arrays of floats instead of being
-    converted into arrays of element-type T that just so happen to hold a
-    bunch of floats.
- -- Changed IGNORE and IGNORABLE to recognize #'fn-name for declaring that
-    local functions are not used.  Exported IGNORABLE from LISP.
-
-New optimizations:
- -- Iterations written using tail recursion are now optimized through a
-    special-casing of local functions where all calls but one are
-    tail-recursive self-calls.  Such functions are compiled with no
-    environment manipulation, resulting in the same code as explicit
-    iteration.
- -- Loop rotation (Knuth "while" loop optimization) been added.  This is the
-    optimization that negates the loop exit test and places it at the end of
-    the loop, and then jumps there at loop entry.  Note that this is part of
-    control optimization, and not simply a recoding of certain iteration
-    macros.  In fact, for historical reasons DO, etc. already had the exit
-    test negated, but the compiler was cleverly un-negating the test.
- -- Flow analysis now recognizes function calls and special forms which do
-    not yield any value because they unwind or signal an error.  This results
-    in improved code for error checks, since the compiler can get by with
-    fewer unconditional branches.  A function can be declared not to return by
-    declaring its result type to be NIL (not to be confused with NULL).  If a
-    function declared NIL does return, an error will be signalled.
- -- Added derive-type methods for ASIN, ACOS, ACOSH, ATANH and SQRT which
-    figure out whether the result type is real on the basis of the argument
-    range.  Also, the result of ATAN is always real, so we don't need a result
-    type assertion.
- -- Added optimization which deletes MULTIPLE-VALUE-BINDs when all
-    variables have been deleted.
- -- Eliminated some spurious checking of the result types of safe VOPs (such
-    as the SPARC tadd for fixnum arithmetic.)
- -- Transform uses of the SEARCH generic sequence function on simple strings
-    into a call to a more efficient string-specific function.
- -- Added multiplier recoding of (UNSIGNED-BYTE 32) multiplication.  This
-    converts 32 bit (or smaller) unsigned multiplication by any compile-time
-    constant into a shift-add sequence.  This is much faster when the constant
-    is a near power of two or when general multiplication is slow (as on the
-    SPARC.)
- -- Added comprehensive handling of arithmetic and logical identities when
-    an arg is -1, 0 or +1.
- -- Added a RANDOM derive-type method: (random 13) is (integer 0 12).
-
-
-Enhancements:
- -- Changed the compiler to temporarily increase *BYTES-CONSED-
-    BETWEEN-GCS* by a factor of 4 during compilation of each top-level form,
-    instead of turning off all garbage collection.
- -- Bind *PRINT-LINES* around compiler error output to
-    *ERROR-PRINT-LINES*.
- -- Do not warn about undefined variables, functions or types when the
-    INHIBIT-WARNINGS OPTIMIZE quality is 3.
- -- Some optimizations are now considered "important"; failure of important
-    optimizations causes an efficiency note even when speed=inhibit-warnings
-    (i.e. by default.)
- -- Print a error summary even when *COMPILE-VERBOSE* is false.  (This is only
-    printed when there are errors, so this doesn't seem a violation of the
-    spirit of the spec.)
-
-Bug fixes:
- -- Merged Miles' fix to disassembly of the MIPS coprocessor move instructions.
- -- Fixed spelling of "efficency" in exported variables such as
-    *EFFICIENCY-NOTE-COST-THRESHOLD*
- -- Fixed some cases where incomplete optimization could happen.
- -- Fixed some arithmetic "identities" that failed to preserve the sign of
-    -0.0.
- -- Fixed TYPES-INTERSECT to consider any supertype of T to definitely
-    intersect with anything (even an unknown type.)
- -- Fixed a problem where inconsistent declarations could fail to be detected
-    at compile time.
- -- Fixed the VALUES transform (which discards unused subforms) to work
-    on (VALUES).
- -- More bug fixes to dead code deletion.
- -- Fixed a problem where a special binding would not be removed on exit from
-    the scope if there was no code in the scope (e.g. it had all been
-    deleted.)
- -- Fixed handling of named (DEFCONSTANT) constants so that EQ
-    relationships are properly preserved.
-
-
-Extensions:
-
- -- Export FEATUREP from EXT.  This takes a feature expression and tests it
-    against the value of *FEATURES*.  Allow LISP:AND, LISP:OR, and LISP:NOT in
-    features lists in addition to :AND, :OR, and :NOT.  This makes featurep
-    useful outside of #+ and #-.
- -- The encapsulation mechanism (similar to advise facilities) has been
-    revamped to work on SETF function names as well as symbols.
-    EXT:ENCAPSULATED-DEFINITION
-       Returns whatever definition is stored for name, regardless of whether
-       it is encapsulated.  Unlike FDEFINITION, this does not strip off the
-       encapsulation.  This is SETF'able.
-    EXT:ENCAPSULATE
-       Replaces the definition of name with a function that binds name's
-       arguments a variable named argument-list, binds name's definition to a
-       variable named basic-definition, and EVAL's body in that context.  Type
-       is whatever you would like to associate with this encapsulation for
-       identification in case you need multiple encapsuations of the same
-       name.
-    EXT:UNENCAPSULATE
-       Removes name's most recent encapsulation of the specified type.
-    EXT:ENCAPSULATED-P
-       Returns t if name has an encapsulation of the given type, otherwise
-       nil.
-    EXT:*SETF-FDEFINITION-HOOK*
-       A list of functions invoked by (SETF FDEFINITION) before storing the
-       new value.  Each hook function must take the function name and the
-       new-value.
-
-Hemlock:
- -- Fixed the :FILE branch of "Help on Parse" to trim leading directory
-    components off the pathname if it wouldn't otherwise fit on the screen.
- -- Fixed GET-EDITOR-TTY-INPUT to not assume that UNIX-READ will always work.
- -- When we reallocate string table vectors to grow them, clear the old vector
-    so that it won't hold onto garbage (in case the vector was in static space,
-    but pointed to dynamic values.)  This was a major cause of memory leakage
-    in Hemlock.
- -- Added a (setf (ts-stream-char-pos stream) 0) to the accept-input function
-    so that char-pos will be reset to zero whenever the user presses enter.
-
-PCL:
- -- The version has been updated to "5/1/90  May Day PCL (REV 4b)".
- -- The Code walker now understands the real SYMBOL-MACROLET, and the PCL macro
-    definition is no longer used.
- -- Fixed a bug in WALK-ARGLIST where it would ignore the rest of the current
-    arglist if the current arg destructured.  This was causing it to compile
-    forms like:
-	    (macrolet ((foo ((a b) c) ...)) ...)
-    as:
-	    (macrolet ((foo ((a b)) ...)) ...)
-    note the loss of the arg c.
-
-
-System:
-
- -- All the SAP-REF-<n> functions now take byte offsets.  Previously, the
-    16 and 32bit versions were scaled by the element size.
- -- Fixed UNIX-IOCTL to not flame out of the cmd is a ub-32 instead of a sb-32.
- -- Added Miles' TCSETPGRP, TCGETPGRP, and TTY-PROCESS-GROUP.
- -- Unix syscalls are now more restrictive in the kind of arguments that they
-    accept.  In particular, UNIX:UNIX-READ, etc., no longer automatically
-    accept a vector (or string) argument.  You must use VECTOR-SAP to convert
-    the vector to a system area pointer.  Note that WITHOUT-GCING should be
-    wrapped around any syscall which is passed a pointer to the Lisp heap,
-    since the object might otherwise move doing the syscall.
- -- Changed LOAD-FOREIGN to be exported from ALIEN.  Changed it have keyword
-    args instead of optionals.  Deleted obsolete linker argument.
diff --git a/general-info/bugs.txt b/general-info/bugs.txt
deleted file mode 100644
index e1b4a1a11515ed98840889bc56fc50d2dd3c4b2b..0000000000000000000000000000000000000000
--- a/general-info/bugs.txt
+++ /dev/null
@@ -1,20 +0,0 @@
-;;; -*- Mode: Text, Spell, Fill -*-
-
-
-
-;;;; Randomness
-
-The results of (machine-type) are not machine-type specific.
-
-
-
-;;;; Garbage Collector
-
-GC doesn't fix the LIP correctly if it is a raw function address and nobody
-else has a handle on the real function object.  (This can happen during
-call.)  GC needs to check to see if any of the descriptor objects are a
-symbol with the same value as the LIP for the raw-function address.
-
-When GC is trying to find the descriptor object the LIP points into, it
-should verify that the LIP points before the end, not just after the start.
-
diff --git a/general-info/cmu-README.txt b/general-info/cmu-README.txt
deleted file mode 100644
index 5e2f3a0c70e61d0ab35f5b228a9ec0d293997df3..0000000000000000000000000000000000000000
--- a/general-info/cmu-README.txt
+++ /dev/null
@@ -1,38 +0,0 @@
-To get CMU Common Lisp, run:
-    /usr/cs/etc/modmisc - cs.misc.cmucl
-
-This establishes /usr/misc/.cmucl as a symbolic link to the release area.
-In your .login, add CMU CL to your path:
-    setpath -i /usr/misc/.cmucl
-
-Then run "lisp".  Note that the first time you run Lisp, it will take AFS
-several minutes to copy the image into its local cache.  Subsequent starts
-will be much faster.
-
-Or, you can run directly out of the AFS release area (which may be necessary on
-SunOS machines).  Put this in your .login shell script:
-    setenv CMUCLLIB "/afs/cs/misc/cmucl/@sys/beta/lib"
-    setpath -i /afs/cs/misc/cmucl/@sys/beta
-
-After setting your path, "man cmucl" will give an introduction to CMU CL and 
-"man lisp" will describe command line options.  For SunOS installation notes,
-see the README file in the SunOS release area. 
-
-See /usr/misc/.cmucl/doc for release notes and documentation.  Rather old
-hardcopy documentation is available as tech reports in the document room.
-
-Send bug reports and questions to cmucl-bugs@cs.cmu.edu.  If you send a bug
-report to gripe, they will just forward it to this mailing list.
-
-Running CMU CL:
-
-Run "lisp".  Try also "lisp -edit", which starts Hemlock.  Hemlock will use X
-if the DISPLAY environment variable is defined, otherwise it will use terminal
-i/o based on TERM and /etc/termcap.
-
-Source availability:
-
-Lisp and documentation sources are publicly readable in /afs/cs/project/clisp.
-All CMU written code is public domain, but CMU CL also makes use of several
-imported packages: PCL, CLX and XP.  Although these packages are copyrighted,
-they may be freely distributed without any licensing agreement or fee.
diff --git a/general-info/cmucl.1 b/general-info/cmucl.1
deleted file mode 100644
index 42d5b7469164196685abafe825abd9c1bd6a6a05..0000000000000000000000000000000000000000
--- a/general-info/cmucl.1
+++ /dev/null
@@ -1,322 +0,0 @@
-.\" -*- Mode: Text -*-
-.\"
-.\" **********************************************************************
-.\" 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 or slisp-group@cs.cmu.edu.
-.\"
-.\"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/general-info/cmucl.1,v 1.9 1992/05/29 13:59:41 ram Exp $
-.\"
-.\" **********************************************************************
-.\"
-.\"  Man page introduction to CMU CL.
-
-.TH CMUCL 1 "October 15, 1991"
-.AT 3
-.SH NAME
-CMU Common Lisp
-
-.SH DESCRIPTION
-
-CMU Common Lisp is public domain "industrial strength" Common Lisp programming
-environment.  Many of the X3j13 changes have been incorporated into CMU CL.
-Wherever possible, this has been done so as to transparently allow use of
-either CLtL1 or proposed ANSI CL.  Probably the new features most interesting
-to users are SETF functions, LOOP and the WITH-COMPILATION-UNIT macro.
-
-.SH HARDWARE REQUIREMENTS
-
-CMU CL is currently available for Sparcstations and DECstations (pmaxes)
-running Mach (or OSF/1).  We are beta-testing a SunOS SPARC version and an IBM
-RT Mach version.  At least 16 megabytes of memory and 25 megabytes of disk
-space are recommended.  As usual, more is better.
-
-.SH OVERVIEW
-When compared other Common Lisp implementations, CMU CL has
-two broad advantages:
-.TP 3
-\--
-The new CMU CL compiler (Python) is more sophisticated than other
-Common Lisp compilers.  It both produces better code and is easier to use.
-.TP 3
-\--
-The programming environment based on the Hemlock editor is better
-integrated than gnu-emacs based environments.  (Though you can still use
-GNU if you want.)
-.PP
-
-CMU CL also has significant non-technical advantages:
-.TP 3
-\--
-It has good local support for CMU users, and is well integrated with the
-CMU CS environment.
-.TP 3
-\--
-It is public domain, and is freely available to non-CMU sites that aren't
-able to afford a site-license for a commercial Lisp.
-
-
-.SH COMPILER FEATURES
-
-The `Advanced Compiler' chapter of the User's manual extensively discusses
-Python's optimization capabilities (See DOCUMENTATION below.)  Here are a few
-high points:
-.TP 3
-\--
-Good efficiency and type-checking 
-.I at the same time.
-Compiling code safe gives a 2x speed reduction at worst.
-.TP 3
-\--
-In safe code, type declarations are verified, allowing declarations to
-be debugged in safe code.  When you go to compile unsafe, you know the
-declarations are right.
-.TP 3
-\--
-Full source level debugging of compiled code, including display of the
-exact call that got an error.
-.TP 3
-\--
-Good efficiency notes that tell you why an operation can't be open coded
-or where you are number-consing, and that provide unprecedented source context
-.TP 3
-\--
-Block compilation, partial evaluation, lightweight functions and proper
-tail-recursion allow low-cost use of function call abstraction.
-.PP
-
-.SH TYPE SUPPORT
-
-.B Important note:
-Even debugged programs may contain type errors that remain undetected by
-other compilers.  When compiled with type checking suppressed using the
-CMU Common Lisp compiler, these type errors may cause said debugged
-programs to die strangely.  If type checking is not suppressed, these
-programs will die with an explicit type error. 
-
-The most visible way in which Python differs from previous Common Lisp
-compilers is that it has a greater knowledge about types and a different
-approach to type checking.  In particular, Python implements type checking
-which is `eager' and `precise':
-.TP 3
-\--
-Eager in the sense that type checking is done immediately whenever there is
-a declaration, rather than being delayed until the the value is actually
-used.  For example:
-.nf
-    (let ((x ...))
-.br
-      (declare (fixnum x))
-.br
-      ...)
-.br
-.fi
-Here, the type of the initial value of X must be a FIXNUM or an error will
-be signalled.
-.TP 3
-\--
-Precise in the sense that the exact type specified is checked.  For
-example, if a variable is declared to be of type (integer 3 7), then the
-value must always be an integer between 3 and 7.
-.PP
-
-Since Python does more type checking, programs that work fine when compiled
-with other compilers may get type errors when compiled with Python.  It is
-important to initially compile programs with the default (safe) policy, and
-then test this version.  If a program with an erroneous declaration is compiled
-with type checking suppressed (due to the SAFETY optimize quality being
-reduced), then the type error may cause obscure errors or infinite looping.
-See the section `Getting Existing Programs to Run' (6.6) in the compiler
-chapter of the user manual.
-
-CMU CL adheres to the X3J13 function type cleanup, which means that quoted
-lambda-lists are not of type FUNCTION, and are no longer directly callable.
-Use COERCE with the FUNCTION result type.
-
-.SH OPTIMIZATION
-
-Python does many optimizations that are absent or less general in other
-Common Lisp compilers:
-Proper tail recursion, lightweight function call, block compilation,
-inter-procedural type inference, global flow analysis, dynamic type
-inference, global register allocation, stack number allocation, control
-optimization, integer range analysis, enhanced inline expansion, multiple
-value optimization and source-to-source transforms.
-
-Optimization and type-checking are controlled by the OPTIMIZE declaration.  The
-default compilation policy is type-safe.
-
-.SH NUMERIC SUPPORT
-
-Python is particular good at number crunching:
-.TP 3
-\--
-Good inline coding of float and 32 bit integer operations, with no
-number consing.  This includes all the hardware primitives ROUND,
-TRUNCATE, COERCE, as well as important library routines such as
-SCALE-FLOAT and DECODE-FLOAT.  Results that don't fit in registers go
-on a special number stack.
-.TP 3
-\--
-Full support for IEEE single and double (denorms, +-0, etc.)
-.TP 3
-\--
-In block compiled code, numbers are passed as function arguments and
-return values in registers (and without number consing.)
-.TP 3
-\--
-Calls to library functions (SIN, ...) are optimized to a direct call to
-the C library routine (with no number consing.)  On hardware with
-direct support for such functions, these operations can easily be
-open-coded.
-.TP 3
-\--
-
-Substantially better bignum performance than commercial implementations
-(2x-4x).  Bignums implemented in lisp using word integers, so you can roll your
-own.
-.PP
-
-Python's compiler warnings and efficiency notes are especially valuable in
-numeric code.  50+ pages in the user manual describe Python's capabilities in
-more detail.
-
-
-.SH THE DEBUGGER
-
-In addition to a basic command-line interface, the debugger also has several
-powerful new features:
-.TP 3
-\--
-The "source" and "vsource" commands print the *precise* original source
-form responsible for the error or pending function call.  It is no longer
-necessary to guess which call to CAR caused some "not a list" error.
-.TP 3
-\--
-Variables in compiled code can be accessed by name, so the debugger always
-evaluates forms in the lexical environment of the current frame.  This 
-variable access is robust in the presence of compiler optimization ---
-although higher levels of optimization may make variable values unavailable
-at some locations in the variable's scope, the debugger always errs on the
-side of discretion, refusing to display possibly incorrect values.
-.TP 3
-\--
-Integration with the Hemlock editor.  In a slave, the "edit" command causes the
-editor edit the source for the current code location.  The editor can also send
-non-line-mode input to the debugger using C-M-H bindings.  Try apropos "debug"
-in Hemlock.
-.PP
-See the debugger chapter in the user manual for more details.  We are working
-on integrating the debugger with Hemlock and X windows.
-
-.SH THE INTERPRETER
-
-As far as Common Lisp semantics are concerned, there is no interpreter; this is
-effectively a compile-only implementation.  Forms typed to the read-eval-print
-loop or passed to EVAL are in effect compiled before being run.  In
-implementation, there is an interpreter, but it operates on the internal
-representation produced by the compiler's font-end.
-
-It is not recommended that programs be debugged by running the whole program
-interpreted, since Python and the debugger eliminate the main reasons for
-debugging using the interpreter:
-.TP 3
-\--
-Compiled code does much more error checking than interpreted code.
-.TP 3
-\--
-It is as easy to debug compiled code as interpreted code.
-.PP
-
-Note that the debugger does not currently support single-stepping.  Also, the
-interpreter's pre-processing freezes in the macro definitions in effect at the
-time an interpreted function is defined.  Until we implement automatic
-reprocessing when macros are redefined, it is necessary to re-evaluate the
-definition of an interpreted function to cause new macro definitions to be
-noticed.
-
-.SH DOCUMENTATION
-
-The CMU CL documentation is printed as tech reports, and is available (at CMU)
-in the document room:
-.IP "" .2i
-.br
-CMU Common Lisp User's Manual
-.br
-Hemlock User's Manual
-.br
-Hemlock Command Implementor's Manual
-.PP
-
-Non-CMU users may get documentation from the doc/ directory in the binary
-distribution:
-.TP 10n
-.BR cmu-user.info
-CMU CL User's Manual in Gnu Info format.  The ``cmu-user.info-<N>'' files
-are subfiles.  You can either have your EMACS
-maintainer install this in the info root, or you can use the info 
-``g(...whatever.../doc/cmu-user.info)'' command.
-.TP
-.BR cmu-user.ps
-The CMU CL User's Manual (148 pages) in postscript format.  LaTeX source and
-DVI versions are also available.
-.TP
-.BR release-notes.txt
-Information on the changes between releases.
-.TP
-.BR hemlock-user.ps
-Postscript version of the Hemlock User's Manual (124 pages.)
-.TP
-.BR hemlock-cim.ps
-Postscript version of the Hemlock Command Implementor's Manual (96 pages).
-.PP
-\
-
-.SH SUPPORT
-
-Bug reports should be sent to cmucl-bugs@cs.cmu.edu.  Please consult
-your local CMU CL maintainer or Common Lisp expert to verify that 
-the problem really is a bug before sending to this list.
-
-We have insufficient staffing to provide extensive support to people outside of
-CMU.  We are looking for university and industrial affiliates to help us with
-porting and maintenance for hardware and software that is not widely used at
-CMU.
-
-.SH DISTRIBUTION
-
-CMU Common Lisp is a public domain implementation of Common Lisp.  Both sources
-and executables are freely available via anonymous FTP; this software is 
-"as is", and has no warranty of any kind.  CMU and the authors assume no
-responsibility for the consequences of any use of this software.  See the
-README file in the distribution for FTP instructions.
-
-.SH ABOUT THE CMU COMMON LISP PROJECT
-
-Organizationally, CMU Common Lisp is a small, mostly autonomous part within the
-Mach operating system project.  CMU CL is more of a tool development effort
-than a research project.  The project started out as Spice Lisp, which provided
-a modern Lisp implementation for use in the CMU community.  CMU CL has been
-under continuous development since the early 1980's (concurrent with the Common
-Lisp standardization effort.)
-
-CMU CL is funded by DARPA under CMU's "Research on Parallel Computing"
-contract.  Rather than doing pure research on programming languages and
-environments, our emphasis has been on developing practical programming tools.
-Sometimes this has required new technology, but much of the work has been in
-creating a Common Lisp environment that incorporates state-of-the-art features
-from existing systems (both Lisp and non-Lisp.)
-
-Because sources are freely available, CMU Common Lisp has been ported to
-experimental hardware, and used as a basis for research in programming language
-and environment construction.
-
-.SH SEE ALSO
-lisp(1), README
-.br
-The ``CMU Common Lisp User's Manual'',
-.br
-the ``Hemlock User's Manual'', and 
-.br
-the ``Hemlock Command Implementor's Manual''
diff --git a/general-info/lisp.1 b/general-info/lisp.1
deleted file mode 100644
index 4414c75d8103688013756966908924733fb7b2e1..0000000000000000000000000000000000000000
--- a/general-info/lisp.1
+++ /dev/null
@@ -1,175 +0,0 @@
-.\" -*- Mode: Text -*-
-.\"
-.\" **********************************************************************
-.\" 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 or slisp-group@cs.cmu.edu.
-.\"
-.\"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/general-info/lisp.1,v 1.3 1991/12/09 17:02:39 ram Exp $
-.\"
-.\" **********************************************************************
-.\"
-.\" Man page for CMU CL.
-
-.TH LISP 1 "October 15, 1991"
-.AT 3
-.SH NAME
-lisp \- CMU Common Lisp programming environment
-.SH SYNOPSIS
-.B lisp
-[input-files] [switch-list]
-.SH DESCRIPTION
-.I lisp
-Starts up CMU Common Lisp.  If
-.I switch-list
-is empty, then Lisp will enter a read-eval-print loop using stdin, stdout and
-stderr.  The optional 
-.I input-files
-provide operands for some switches.  These switches are defined:
-
-.TP 10n
-.BR \-core " filename"
-Specifies the suspended Lisp image (or `core file') to start up.  The default
-is `lib/lisp.core'.
-.TP
-.BR \-edit
-Causes Lisp to enter the 
-.I Hemlock
-editor.
-A file to edit may be specified by
-placing the name of the file between the program name (usually `lisp') and
-the first switch.
-.TP
-.BR \-eval " expression"
-Evaluates the specified Lisp
-.I expression
-during the start up sequence.  The value of the form will not be printed unless
-it is wrapped in a form that does output.
-.TP
-.BR \-init " filename"
-Specifies the name of a file containing user customizations that is to be
-loaded each time Lisp starts up (default ~/init or ~/.cmucl-init.)  The loader
-loads any existing compiled binary, or the ".lisp" source if none.
-.TP
-.BR \-hinit " filename"
-Similar to \-init, but specifies the name of the
-.I Hemlock
-init file (default `~/hemlock-init' or ~/.hemlock-init), which is loaded only
-when
-.I Hemlock
-is started.
-.TP
-.BR \-noinit
-Suppresses loading of the init file, and also prevents \-edit from loading the
-.I Hemlock
-init file.
-.TP
-.BR \-load " filename"
-Loads the specified file into Lisp before entering Lisp's read-eval-print loop.
-.TP
-.BR \-slave " editor-name"
-Specifies that Lisp should start up as a 
-.I slave
-Lisp and try to
-connect to an editor Lisp.  The name of the editor to connect to must be
-specified.  To find the editor's name, use the
-.I Hemlock
-`Accept Slave Connections' command.  
-.I editor-name
-is of the form `machine-name:socket', where
-.I machine-name 
-is the
-internet host name for the machine and
-.I socket
-is the decimal number of the socket to connect to.
-.PP
-
-.SH ENVIRONMENT
-
-.TP 10n
-.BR CMUCLLIB
-This variable points to the `lib/' directory holding `lisp.core' and other
-files used by Lisp at run-time.  The default is `/usr/misc/.cmucl/lib'.
-.TP
-.BR CMUCL_EMPTYFILE
-If `df /tmp' shows `swap' as the filesystem for the `/tmp' directory, then you
-have a "tmpfs" filesystem.  In this case, you must setenv CMUCL_EMPTYFILE to
-point into a pathname on a non-TMPFS filesystem that can be used instead of
-`/tmp/empty'.
-.PP
-
-.SH FILES
-
-The following pathnames are specified relative to the directory where CMU CL is
-installed.
-
-.TP 10n
-.BR doc/*
-Various postscript and text documentation files.
-.TP
-.BR bin/lisp
-The lisp startup program.  This directory should be in PATH.
-.TP
-.BR lib/lisp.core
-The suspended Lisp image.
-.TP
-.BR lib/site-init.lisp
-Site specific initialization (see README file.)
-.TP
-.BR lib/hemlock11.*, lib/mh-scan, lib/spell-dictionary.bin
-Hemlock files.
-.TP
-.BR lib/inspect*
-Inspector files.
-.TP
-.BR lib/fonts/ 
-X11 fonts for Hemlock and the inspector.
-.TP
-.BR lib/load-foreign.csh
-Script used by LOAD-FOREIGN to run "ld".
-.TP
-.BR ~/init.lisp,~/.cmucl-init.lisp
-User customization files loaded at lisp startup; either name is acceptable.
-Init files can be compiled.
-.TP
-.BR ~/hemlock-init.lisp, ~/.hemlock-init.lisp
-Hemlock initialization file, loaded when Hemlock starts.
-.PP
-
-.SH SEE ALSO
-cmucl(1), README
-.br
-The ``CMU Common Lisp User's Manual'',
-.br
-the ``Hemlock User's Manual'', and 
-.br
-the ``Hemlock Command Implementor's Manual''
-
-.SH BUGS
-
-Bug reports should be sent to cmucl-bugs@cs.cmu.edu.  Please consult
-your local CMU CL maintainer or Common Lisp expert to verify that 
-the problem really is a bug before sending to this list.
-
-Known problems with this version:
-.TP 3
---
-Detection of stack overflow is not very graceful.   You get many "map
-failure" errors on stderr.
-.TP 3
---
-If file descriptors are used up, then Lisp will die.  The garbage collector
-does
-.I not
-close garbage streams.
-.TP 3
-\--
-Several proposed ANSI Common Lisp (CLtL II) features are not implemented:
-MAKE-LOAD-FORM and LOAD-TIME-EVAL, any CLOS features not implemented by PCL,
-Pathname enhancements (wildcards and logical pathnames.)
-.TP 3
-\--
-The interpreter's pre-processing freezes in the macro definitions in effect at
-the time an interpreted function is defined.
-.PP
diff --git a/general-info/net-README.txt b/general-info/net-README.txt
deleted file mode 100644
index 10f57ae95e9fa26d7840b3d5a3e2d320a50b9be3..0000000000000000000000000000000000000000
--- a/general-info/net-README.txt
+++ /dev/null
@@ -1,149 +0,0 @@
-CMU Common Lisp is a public domain implementation of Common Lisp.  Both
-sources and executables are freely available via anonymous FTP; this software
-is "as is", and has no warranty of any kind.  CMU and the authors assume no
-responsibility for the consequences of any use of this software.  See
-doc/release-notes.txt for a description of the state of the release you have.
-
-The CMU Common Lisp project's goal is to develop a high quality public domain
-system, so we want your bug reports, bug fixes and enhancements.  However,
-staff limitations prevent us from providing extensive support to people outside
-of CMU.  We are looking for university and industrial affiliates to help us
-with porting and maintenance for hardware and software that is not widely used
-at CMU.
-
-See "man cmucl" (man/man1/cmucl.1) for other general information.
-
-Distribution:
-
-CMU Common Lisp is only available via anonymous FTP.  We don't have the
-manpower to make tapes.  These are our distribution machines:
-    lisp-rt1.slisp.cs.cmu.edu (128.2.217.9)
-    lisp-rt2.slisp.cs.cmu.edu (128.2.217.10)
-
-Log in with the user "anonymous" and "username@host" as password (i.e. your
-EMAIL address.)  When you log in, the current directory should be set to the
-CMU CL release area.  If you have any trouble with FTP access, please send mail
-to slisp@cs.cmu.edu.
-
-The release area holds compressed tar files with names of the form:
-    <version>-<machine>_<os>.tar.Z
-    <version>-extra-<machine>_<os>.tar.Z
-
-FTP compressed tar archives in binary mode.  To extract, "cd" to the
-directory that is to be the root of the tree, then type:
-    uncompress <file.tar.Z | tar xf - .
-
-As of 12/11/92, the latest SunOS Sparc release is:
-    16f-sun4c_41.tar.Z (6.8 meg)
-    16f-extra-sun4c_41.tar.Z (3.5 meg)
-
-The first file holds binaries and documentation for the basic Lisp system,
-while the second `-extra' file contains the Hemlock editor, the graphical
-inspector and the CLX interface to X11.  The basic configuration takes 16
-megabytes of disk space; adding the extras takes another 8 megabytes.  For
-installation directions, see the section "site initialization" in the README
-file at the root of the tree.
-
-If poor network connections make it difficult to transfer a 10 meg file, the
-release is also available split into 2 megabyte chunks, suffixed `.0', `.1',
-etc.  To extract from multiple files, use:
-    cat file.tar.Z.* | uncompress | tar xf - .
-
-The release area also contains source distributions and other binary
-distributions.  A listing of the current contents of the release area is in
-FILES.  Major release announcements will be made to comp.lang.lisp until there
-is enough volume to warrant a comp.lang.lisp.cmu.
-
-SunOS credit:
-
-The SunOS support was written by Miles Bader and Ted Dunning.
-
-Site initialization:
-
-To run CMU CL, place bin/ in PATH and setenv CMUCLLIB to point to lib/.  The
-file lib/site-init.lisp contains site-specific initialization, such as setting
-of the site name.  Any site-specific initialization should be placed in this
-file; this file can be compiled.  See bin/sample-wrapper for a shell script
-template that sets up environment variables and then runs CMU CL.  You may
-want to have your EMACS maintainer place doc/cmu-user.info in the info root, or
-you can setenv INFOPATH to include the doc/ directory.
-
-To load in Hemlock or CLX and save an augmented Lisp image, run lib/config.
-This runs `lisp' on `lib/config.lisp', which uses an interactive dialog to
-determine what systems to load and where to save the result.  The default
-output is to overwrite library:lisp.core.  To avoid overwriting the running
-Lisp image, any existing image is renamed to `lisp.core.BAK'; this file may be
-manually deleted to save disk space.
-
-SunOS/SPARC Notes:
-
-Note: CMU CL does not currently run on SPARC 10 systems, since the stack has
-been moved.  This problem should be fixed in version 17.
-
-At least 16 meg of memory is recommended, and more is better.  Your system
-maintainer may need to configure extra paging space for large Lisp application.
-
-It is not possible to mmap a file in a tmpfs filesystem.  If /tmp is a "tmpfs"
-filesystem, then you must setenv CMUCL_EMPTYFILE to the pathname of some file
-(in a normal filesystem) that can be used instead of /tmp/empty.  The "df"
-command will show tmpfs filesystems as mounted on "swap".  If this problem
-exists on your system, lisp will get an error like:
-    mapin: mmap: Invalid argument
-    ensure_space: Failed to validate 67108864 bytes at 0x01000000
-
-
-Running CMU CL:
-
-Run "lisp".  If Hemlock is loaded, you can also "lisp -edit".  Hemlock will
-use X if the DISPLAY environment variable is defined, otherwise it will use
-terminal i/o based on TERM and /etc/termcap.
-
-Source availability:
-
-Lisp and documentation sources are available via anonymous FTP ftp to any CMU
-CS machine.  [See the "Distribution" section for FTP instructions.]  All CMU
-written code is public domain, but CMU CL also makes use of two imported
-packages: PCL and CLX.  Although these packages are copyrighted, they may be
-freely distributed without any licensing agreement or fee.
-
-The release area contains a source distribution, which is an image of all the
-".lisp" source files used to build version 16f:
-    16f-source.tar.Z (3.6 meg)
-
-All of our files (including the release area) are actually in the AFS file
-system.  On the release machines, the FTP server's home is the release
-directory: /afs/cs.cmu.edu/project/clisp/release.  The actual working source
-areas are in other subdirectories of "clisp", and you can directly "cd" to
-those directories if you know the name.  Due to the way anonymous FTP
-access control is done, it is important to "cd" to the source directory with a
-single command, and then do a "get" operation.
-
-Totally machine-independent compiler code:
-    /afs/cs/project/clisp/src/beta/compiler/*.lisp
-See especially node.lisp and ir1tran.lisp for the front end.  vop.lisp,
-vmdef.lisp and ir2tran.lisp for the back end.
-
-Stuff that is dependent on our choice of object format, but not
-particularly machine-dependent:
-    /afs/cs/project/clisp/src/beta/compiler/generic/*.lisp
-
-Compiler back-end for the PMAX and SPARC:
-    /afs/cs/project/clisp/src/beta/compiler/mips/*.lisp
-    /afs/cs/project/clisp/src/beta/compiler/sparc/*.lisp
-
-Miscellaneous Lisp run-time code:
-    /afs/cs/project/clisp/src/beta/code/*.lisp
-
-C run-time code:
-    /afs/cs/project/clisp/src/beta/ldb/*
-
-A very drafty version of an internal design document: (160 pages) Some of
-the "tex" files may be more humanly readable, since many formatting
-commands need to be added.  There is some inaccurate (dated) material in
-the compiler description.
-    /afs/cs/project/clisp/hackers/ram/docs/internals/*.tex
-    /afs/cs/project/clisp/hackers/ram/docs/internals/design.ps
-
-See hackers/ram/docs/internals/architecture.tex (the System Architecture
-chapter in the internals document) for more information on the source tree
-organization.
diff --git a/general-info/omega-release-notes.txt b/general-info/omega-release-notes.txt
deleted file mode 100644
index 7058742cec070e5c751efa6b8387634d34660469..0000000000000000000000000000000000000000
--- a/general-info/omega-release-notes.txt
+++ /dev/null
@@ -1,777 +0,0 @@
-	    Release notes for CMU Common Lisp 15e, 25 February 92
-
-
-15e is mainly a bug-fix release; it will probably be the last version 15
-release, and is thus the most stable system you're going to see for a while.
-We're reluctant to call it a "default" release because some things are stably
-broken:
- -- There still isn't any good stack overflow detection.  Probably stack
-    overflow detection won't appear until the C code rewrite associated with
-    generational GC comes out (version 17 or later.)
- -- The Alien/foreign function call mechanism is fairly broken.  It doesn't
-    work at all in interpreted code, and DEF-C-ROUTINE doesn't work properly
-    for many argument type signatures.  We've redesigned and reimplemented
-    our foreign interface for version 16.
-
-We are now distributing the CMU CL user manual in Gnu Info format (in
-doc/cmu-user.info.)  You can either have your EMACS maintainer install this in
-the info root, or you can use the info "g(<cmucl root dir>/doc/cmu-user.info)"
-command.  Many thanks to Mike Clarkson (the LaTeXinfo maintainer) who
-volunteered to convert our Scribe documents.
-
-Changes:
- -- Improved recursive error handling.  Errors during reporting of errors are
-    detected and suppressed.  Other recursive errors are eventually detected,
-    and hopefully recovered from.  This should eliminate some "recursive map
-    failure (stack overflow?)" errors.
- -- Fixed a bad declaration in CLX which caused an array index error on
-    font attribute queries (such as CHAR-WIDTH.)
- -- Fixed interpreted (typep x '(and ...)) to not always return NIL.
- -- Fixed interpreted CLOS methods to work once again.
- -- Fixed PROFILE to work again, now that argument count information may be
-    missing.
- -- Changed NCONC to signal an error if a non-null ATOM appears other than
-    as the last argument.
- -- Changed FEATUREP to signal an error if it is passed a list form with a
-    strange CAR.
- -- Do type checking on the arguments to %PUTHASH so that
-    (setf (gethash foo 'bar) x) doesn't get a bus error.
- -- Changed LET* and &AUX to allow duplicate variable names.
- -- Fixed DEFTYPE to properly invalidate type system caches so that type
-    redefinitions predictably take effect.
- -- Improvements to MIPS disassembler database.
-
-
-	    Release notes for CMU Common Lisp 15d, 2 February 92
-
-These release notes cover changes since the beta release of version 15b on 6
-June 91.  Execpt for Miles Bader's portable disassembler and a few minor
-performance enhancements, this is mostly a bug-fix release.  We've been
-working on ANSI complaince, foreign function interface and more advanced
-compiler optimizations, but we're not going to inflict that on the general
-public just yet.
-
-
-			     GENERAL SYSTEM CODE
-
-Bug fixes:
- -- (SETF AREF) now checks to make sure that the new value is of the correct
-    type.
- -- Improved checking for invalid syntax in DEFSTRUCT.  In some cases, syntax
-    errors would cause cryptic internal errors due to inadequate type
-    checking.
- -- DRIBBLE now monitors *ERROR-OUTPUT* (in addition to *STANDARD-OUTPUT*).
- -- Bignum printing now works correctly in base 36.
- -- Fixed EXPT to deal with SINGLE-FLOAT x SINGLE-FLOAT arg type combination.
- -- Fixed TRUNCATE to handle the SINGLE-FLOAT/DOUBLE-FLOAT case.
- -- The PROFILE package works once again.
-
-Enhancements:
- -- A new retargetable disassembler provides DISASSEMBLE support on the SPARC,
-    and also greatly improved disassembly on the MIPS.  The output is
-    annotated with source-code correspondences if debug-info permits.
- -- Added INLINE MEMBER declarations in definitions of the set functions
-    (UNION, etc.) so that when the set functions are inlined, the MEMBER calls
-    will also.
- -- Merged Lange's improved type declarations for nthcdr/butlast/nbutlast.
-    Also, NTH-VALUE now doesn't cons for non-constant N less than 3.
- -- The loader now supports appending fasl files.  You can:
-    	cat a.fasl b.fasl c.fasl >all.fasl
- -- Added :UNIX to the features list.
-
-The new variable EXT:*TOP-LEVEL-AUTO-DECLARE* controls whether assignments to
-unknown variables at top-level (or in any other call to EVAL of SETQ) will
-implicitly declare the variable SPECIAL.  These values are meaningful:
-     :WARN  -- Print a warning, but declare the variable special (the default.)
-      T     -- Quietly declare the variable special.
-      NIL   -- Never declare the variable, giving warnings on each use. (The
-               old behavior.) 
-
-The reader now ignores undefined read macro errors when *read-suppress* is T.
-All reader character lookup tables are now CHAR-CODE-LIMIT in size.  Formerly,
-some where only 128.  In the standard readtable, these additional characters
-are all undefined.
-
-There are various changes in the DEBUG-INTERNALS interface related to
-breakpoint support, but we haven't yet implemented a satisfactory user
-interface to breakpoints.  Changed name of DI:DO-BLOCKS to
-DI:DO-DEBUG-FUNCTION-BLOCKS.  Added DI:FUNCTION-END-COOKIE-VALID-P and
-DI:DEBUG-FUNCTION-START-LOCATION.
-
-This release fixes a few problems with Aliens, but they are still pretty
-broken.  In particular, Alien and C interface operations don't work at all in
-interpreted code.  We are in the process of integrating a new-and-improved
-implementation of Aliens that works much more smoothly with C.
-
-
-				 COMPILER
-
-Enhancements:
- -- Various SPARC-specific reductions in spurious type checks and coercions.
- -- FTYPE declarations on local functions are now propagated to the variables
-    of the local definition.
- -- Improved representation selection by not totally ignoring references by
-    move VOPs.  This is particularly useful for avoiding spurious number
-    consing of float arguments that are passed on as arguments.
- -- The warning about assignments to the arguments of functions having FTYPE
-    declarations is now suppressed when the FTYPE declaration gives no useful
-    information.
- -- Improved readability of *COMPILE-PROGRESS* output.
- -- Fixed TYPES-INTERSECT to consider any supertype of T to definitely
-    intersect with anything (including unknown or not-yet-defined types.)
-
-Bug fixes:
- -- Fixed some bugs in dead code deletion.
- -- Lambdas with &KEY and no specified keywords are now compiled correctly
-    (instead of the &KEY being ignored.)
- -- The compiler now knows that INTERN can return NIL as its second value.
- -- Global FTYPE declarations on DEFSTRUCT slot accessors are now quietly
-    ignored, instead of causing the structure definition to be removed.
- -- Fixed a problem with resulting from an interaction between block
-    compilation and global FTYPE declarations.
- -- Fixed TAGBODY not to consider NIL to be a tag.
- -- Fixed an internal error during register allocation which could happen when
-    compilation-speed > speed.
- -- If we undefine a structure type, unfreeze it also.
- -- Fixed TYPEP SATISFIES to always return T-or-NIL, regardless of what the
-    predicate returns.
-
-PCL/CLOS:
- -- Added generalized source context parsing with EXT:DEF-SOURCE-CONTEXT.
-    Added a parser for DEFMETHOD that gets qualifiers and specializers.
- -- FUNCALLABLE-INSTANCE-P is now compiled much more efficiently.
- -- Fixed SET-FUNCTION-NAME to correctly set the name of interpreted methods,
-    instead of clobbering the name of an internal interpreter function.
-
-
-				  HEMLOCK
-
-Bug fixes:
- -- Changed X font specs in the generic site-init file to use point size
-    instead of pixel size so that they work on 100dpi devices. 
- -- Added :INPUT :ON wm-hints to Hemlock windows, which is necessary to
-    receive input in OpenLook windowing systems.
- -- Fixed Lisp mode indentation for FLET&c to check that we are actually in
-    the first arg form before doing funny indentation.  Generalized to
-    reference the variable "Lisp Indentation Local Definers", and also to
-    recognize LABELS (as well as MACROLET and FLET.)
- -- When we reallocate string-table vectors to grow them, clear the old vector
-    so that it won't hold onto garbage (in case the vector was in static
-    space, but pointed to dynamic values.)  This was a major cause of memory
-    leakage in Hemlock.
- -- Fixed sentence motion to work at the end of the buffer.
-
-Enhancements:
- -- The site file now contains a template for file directory translation (for
-    "Edit Definition"), and some of the comments have been improved.
- -- There's a new "Buffer Modified Hook" function that raises the "Echo Area"
-    window when it becomes modified.  You can control this with the Hemlock
-    variable: "Raise Echo Area When Modified".
- -- In "Edit Definition" and related commands, before doing directory
-    translations, try a probe-file of the source file first.  This can reduce
-    the number of translations needed.
- -- Added DEFINDENT's for the "WIRE" package.
- -- Made the X visual bell look less spastic by adding a finish-output.
- -- The termcap parser now recognizes entries for things like begin/end bold,
-    underline, etc.  Fixed a problem with font halding in TTY redisplay.
- -- The MH interface now uses the correct name for the MailDrop profile
-    component.
- -- The netnews interface has been improved in various ways, including the
-    addition of server timeouts, but should still be considered experimental.
-
-
-	    Release notes for CMU Common Lisp 15b, 19 October 91
-
-These release notes cover changes since the beta release of version 14c on 6
-June 91.  SPARCstations and Sun4's are now supported under SunOS (as well as
-Mach), which makes CMU CL more usable outside of the CMU environment.  CMU CL
-also runs on Mach (or OSF/1) DECstations, and IBM RT support is coming real
-soon now.
-
-
-			    GENERAL SYSTEM CODE
-
-Bug fixes:
- -- MAKE-ARRAY now to allows :INITIAL-CONTENTS any kind of of sequence, not
-    just a list.
- -- VECTOR-PUSH and VECTOR-PUSH-EXTEND now return the original fill
-    pointer, not the new fill pointer.
- -- VECTOR-POP now returns the value indexed by the new fill pointer, not
-    the original fill pointer.
- -- Fixed two bugs in bignum division.
- -- FORMAT-PRINT-NUMBER now correctly inserts commas for negative numbers
-    (don't print -,123).
- -- Fixed GET-SETF-METHOD to only inhibit setf macros when there is a local
-    function, not also when there is a local macro.
- -- Changed the debugger to use *READ-SUPPRESS* when skipping over top-level
-    forms in the source file to prevent spurious read errors.
- -- In the printer, deleted an incorrect and questionably optimal
-    optimization of symbol package qualification.
- -- When printing characters, prefer the semi-standard character-names
-    NEWLINE, ESCAPE and DELETE to the old LINEFEED, ALTMODE and RUBOUT.
- -- Fixed one-off error in list REMOVE-DUPLICATES :FROM-END.  Fixed
-    SUBSTITUTE & friends to pass arguments to the TEST in the right order.
-    Fixed SUBSTITUTE not to randomly apply the KEY to the OLD value.  Changed
-    LIST NSUBSTITUTE & friends to work in the :FROM-END case.
- -- Several bug-fixes to RUN-PROGRAM and subprocess I/O.
- -- Fixed all recursive READ calls in sharp-macros to specify eof-error-p T, so
-    that EOF errors are signalled when appropriate.
- -- The REMOTE RPC protocol (used for slave control) can now send bignums.
- -- Passing of unused arguments to interpreted functions now works.  Previously
-    the variables would be bound to the wrong arguments.
- -- Many fixes to the time parsing and printing extensions.
-
-X3J13 cleanups:
- -- Added #P pathname read syntax, and changed the pathname printer to use it.
- -- Added :KEY argument to REDUCE.
-
-Enhancements:
- -- Added code to compile the argument to TIME when possible, and print a
-    warning when it isn't.  Optimized the TIME macro to keep the consing
-    overhead of using it zero.
- -- Changed all places absolute pathnames were used to indirect search-lists,
-    mostly library:.  "lisp" must now be findable on your PATH for Hemlock to
-    be able to start slaves.
- -- Increased readability of DESCRIBE function output by printing function and
-    macro doc strings before arg and result info.
- -- The CMUCLLIB search path environment variable is now used to find lisp.core
-    and other library files, instead of always assuming the path
-    /usr/misc/.cmucl/lib.
-
-
-				 COMPILER
-
-Bug fixes:
- -- EVAL now uses the constant value recorded in the compiler environment
-    that compile-time references to constants works better.  Now
-    (defconstant a 3) (defconstant b (+ a 4)) works again.
- -- Don't try to infer the bounds of non-simple arrays, since they can change.
- -- Fixed some problems with block compilation, maybe-inline functions and
-    unused function deletion.
- -- DEFMETHODs can now use &ALLOW-OTHER-KEYS without killing the compiler.
- -- Fixed VALUES declaration to work correctly when zero values are specified.
- -- The FORMAT transform now warns if there are to many or too few args.
- -- Changed SYMBOL-MACRO-LET to SYMBOL-MACROLET.
-
-X3J13 cleanups:
- -- Make all non-symbol atoms self-evaluate.
-
-Enhancements:
- -- Made the default for COMPILE-FILE's :error-file argument be nil.
- -- Changed notes about incompatible changes in function arguments lists to be
-    a warning rather than a note.
- -- Source-level optimization efficiency notes now print out a
-    transform-specific string to describe what the transform was trying to do,
-    instead of just saying "unable to optimize."
-
-
-				  HEMLOCK
-
-This is version 3.5.
-
-Note: The default value of "Slave Utility" is now just "lisp" which hopefully
-will be found on path:.  If you don't have lisp on your path, you need to set
-"Slave Utility" to the full pathname of lisp, /usr/misc/.cmucl/bin/lisp on CMU
-machines.
-
-Bug fixes:
- -- Under TTY screen management, a MAKE-WINDOW - DELETE-WINDOW sequence now
-    leaves the screen unchanged.
- -- Fixed some character attribute constants to make 8-bit chars work.
- -- "Center Line" now works when invoked on the last line of the buffer.
- -- Fixed "Move Over )" to use a permanent mark instead of a temporary mark
-    because it deletes text.
- -- Fixed sentence motion to be able to move to the end of the buffer.
- -- Fixed the hemlock banner in the status line to not have "!" after
-    the date.
-
-Enhancements:
- -- Removed the definitions of the obsolete COMMAND-CHAR-BITS-LIMIT and
-    COMMAND-CHAR-CODE-LIMIT.
- -- Modified "Visit File" to issue a loud message whenever another buffer
-    already contains the file visited. The quiet message often went unnoticed,
-    defeating its purpose.
- -- The definitions in FLET, LABELS and MACROLET are now indented correctly.
- -- Added DEFINDENT's for the "DEBUG-INTERNALS" interface.
- -- Modified Lisp indentation to check if the mark in was in a string context.
-    If it is, then we go to the column after the opening double quote.
-    Otherwise, we use the first preceding non-blank line's indentation.  This
-    fixes the problem with doc strings and ERROR strings which got indented
-    respectively at the beginning of the line and under the paren for the ERROR
-    call.
- -- Added some prototype netnews support.  Details to be anounced later.
- -- Added font support for the TTY.  Allow active region highlighting and open
-    paren highlighting when on the TTY, as they now work.
- -- Changed the compile-in-slave utilities to count notes and display in
-    completion message.  Also fixed not to print echo area messages "Error in
-    NIL ..."
-
-New commands:
-
-"Fill Lisp Comment Paragraph"	Lisp: M-q
-   Fills a flushleft or indented Lisp comment, or lines all beginning with the
-   same initial, non-empty blankspace.  When filling a comment, the current
-   line is used to determine a fill prefix by scanning for the first semicolon,
-   skipping any others, and finding the first non-whitespace character;
-   otherwise, the initial whitespace is used.
-
-"Shell Complete Filename"	Process: M-Escape
-    In a shell buffer, attempts to complete the filename immediately before
-    point.  The commands that start "Process" buffers with shells establish a
-    stream with the shell that tries to track the current working directory of
-    the shell.  It uses the variable "Current Working Directory" to do this.
-    For it to work, you should add the following to your .cshrc file:
-       if ($term == emacs) then
-	  alias cd 'cd \!* ; echo ""`pwd`"/"'
-	  alias popd 'popd \!* ; echo ""`pwd`"/"'
-	  alias pushd 'pushd \!* ; echo ""`pwd`"/"'
-       endif
-
-"Manual Page"
-    Runs man(1) in a scratch buffer and displays it in the current window.
-
-"Typescript Slave Status"	Typescript: H-s
-   Interrupt the slave and cause it to print status information.
-
-
-Hemlock-internals changes:
- -- CREATE-WINDOW-FROM-CURRENT now creates a window according to its new
-    proportion argument instead of simply splitting the current window in two.
-    It returns nil without doing anything if either window is too small.
- -- WINDOW-GROUP-CHANGED no longer unifies the sizes of window when the
-    user resizes a group.  It now tries to distribute the new size of the group
-    according to the proportions of the old size consumed by the windows.
- -- Changed ARRAY-ELEMENT-FROM-MARK to use AREF for the Netnews stuff.  I
-    documented this to be an internal interface since a few other modes use it.
- -- WRITE-FILE now takes an :append argument.
- -- Modified %SET-MODELINE-FIELD-FUNCTION to allow its function argument to be
-    a symbol or function since the purpose is to FUNCALL the thing.  Since the
-    new system is up to spec on the disjointedness of functions, this needed to
-    be fixed for usefulness.
-
-
-	Release notes for CMU Common Lisp 14c, 6 June 91
-
-  ** The FASL file format has changed, so all files must be recompiled. **
-
-These notes describe changes since the beta release of 3 February 91.  This is
-the first CMU CL release to run on Mach SPARCs as well as on PMAXen (DECstation
-3100 or 5000).  Version 14c will go out to both beta and default, since there
-is currently no default release.
-
-This release has a substantial space reduction due to compiling with debug-info
-1 and reduced safety.  The core is currently 19.2 meg, which is 7 meg smaller
-than the last beta release (despite added functionality.)
-
-Major parts of the system are now compiled with no error checking.  Users
-should not notice any reduction in safety, since user visible interfaces are
-supposed to be fully checked.  Standard functions that users can cause to get
-unbound symbol or array index errors needed to be changed to either do explicit
-error checks or locally use a safe policy.  Some of these cases may have been
-missed.  Let us know if you get any less-than-informative error messages
-(segmentation violation) inside standard functions.
-
-
-New packages:
-
-The X based graphical inspector is now available.  It now uses standard
-fonts (courier) and has a bigger help window.
-
-An improved version of the profile package (previously in the library) is now
-in the core.  It now compensates for recursive calls or nested calls, and
-interacts better with TRACE and function redefinition.  The old profile
-documentation is in:
-    /afs/cs/project/clisp/library/profile/profile.doc
-
-
-Code:
-
-Argument type checking for Common Lisp functions is now driven by the
-compiler's function type database (the types reported by DESCRIBE.)  This means
-that some type errors might be detected that were previously unnoticed.
-
-Changed the internal WITH-ARRAY-DATA macro to do bounds checking.  This causes
-various string functions to give better error messages when an :END arg is out
-of bounds or :START is greater than :END.
-
-Tuning:
-    Some tuning in SYSTEM:SERVE-EVENT which reduces consing and speeds up
-    Hemlock and terminal I/O.
-
-    Changed GET-INTERNAL-REAL-TIME to subtract out the time of the first
-    call to minimize the probability of bignum results.  Also some other tuning
-    that reduced the consing of this function to 0.
-
-    Tuned bignum code and added declarations to reduce number consing.
-
-
-DEFSTRUCT:
-    Fixed default-structure-print to work when *print-circle* is T.
-    Merged fix to DEFSTRUCT constructor parsing that allows multiple default
-    constructors, or none at all.
-
-Merged bug fixes from old RT system:
-    STANDARD-CHAR-P no longer returns T for #\return.
-
-    Fixed a bug in format regarding ~@*.
-
-    Fixed the read-eval-print loop to frob +, ++, +++ correctly.
-
-    Fixed a bug in Y-OR-N-P.  It was calling WHITESPACEP on a symbol.
-
-    Fixed READ-QUOTE to call READ with t for eof-errorp which it previously
-    failed to do.  fixed READ-PRESERVING-WHITESPACE to no longer screw with
-    eof-errorp based on recursivep
-
-Package system:
-    Changed DEFPACKAGE to expand into stuff that will have the package effect
-    at compile time as well as at load time.
-
-    Fixed DEFPACKAGE to deal more correctly with finding symbols that must
-    exist.
-
-    Fixed package system code to not destructively modify the USE, USED-BY and
-    SHADOWING-SYMBOLS lists so that they don't get retroactively modified when
-    we hand them off to the user.
-
-    Also, in SHADOW, when symbols is NIL, shadow no symbols, not NIL.
-
-    Fixed a bug in RENAME-PACKAGE that happened when the new name was one of
-    the old nicknames.
-
-Streams:
-    Tweaked handling of LISTEN a bit to allow READ-CHAR-NO-HANG to work
-    correctly.  Fixed the listen method for concatenated streams.  It failed to
-    step to the next stream when the current one hit eof.
-
-    Make two-way streams force-output on the output side before passing any
-    input requests on to the input side.  Made *standard-output* a two-way
-    stream so that reading *standard-input* will force output on standard
-    output.  This eliminates the need for explicit calls for FORCE-OUTPUT when
-    prompting.
-
-    Some tuning and bug fixes to FD-STREAMS (file descriptor streams) which are
-    used for file I/O (and now for communication with the X server.)  Also, now
-    OPEN complains if you try to open a non-writable file for output with
-    :RENAME or :RENAME-AND-DELETE.  Previously this would succeed as long as
-    the directory was writable.  SYSTEM:READ-N-BYTES on FD streams is now more
-    efficient, but does *not* wait using SERVE-EVENT; it blocks instead.
-
-TRACE:
-    Use FORCE-OUTPUT instead of FINISH-OUTPUT to prevent gratuitous slowdowns
-    when running in a slave.
-
-    If we enter trace recursively (due to the printer calling the traced
-    function), then just quietly call the function, instead of signalling an
-    annoying "unable to trace" error.
-
-LOAD:
-    Changed load to look at the file contents for the "FASL FILE" header to
-    determine whether to fasload or slow load, instead of forcing use of a
-    single fasl file type.  Also, when the given filename doesn't exist and
-    doesn't have a type, try ``fasl'' in addition to the machine specific fasl
-    file type.  Eliminated the "feature" whereby zero-length fasl files were
-    considered to be valid (doing nothing).  Now if you try to load a file with
-    a fasl file type, but that doesn't have a valid fasl header, then you will
-    get an error (proceeding loads as a source file.)
-
-    When the loader prints comments about loading progress, the number of
-    leading semicolons is now the depth of recursive loading.
-
-    Added a CONTINUE restart in LOAD that returns NIL. 
-
-GC:
-    Fixed some bugs in control of garbage collection that should solve some
-    problems with GC failing to be triggered automatically.  Also, GC no longer
-    implicitly reenables automatic GC if it has been disabled with GC-OFF.
-
-    Changed the default GC notify function to not beep.  The old behavior can
-    still be obtained by setting *GC-VERBOSE* to :BEEP.  Note that this only
-    affects use on TTYs, since slave GC notification works differently.
-
-    Wrapped a without-interrupts around the guts of maybe-gc so that the notify
-    messages and state updates don't get seperated from the actual gc.
-
-    Removed the icache flushing stuff from GC, because it was unneeded (and
-    sometimes printed annoying messages that it didn't work).
-
-X3J13 cleanups:
-    The non-destructive string functions now accept characters as well as
-    strings and symbols.
-
-    MACROEXPAND now expands symbol macros.
-
-    Now almost all Common Lisp functions which are SETFable have a (SETF name)
-    function.  The exceptions are functions where it makes no sense (LDB,
-    GETF), and a few other functions (GET, GETHASH.)  Now SETF of APPLY works
-    for any function which has a setf function.
-
-    Changed GET-SETF-METHOD to ignore setf macros (always global) when there is
-    a local macro or function of the place function.  [An x3j13 cleanup]
-
-    Fixed the LOOP THEREIS keyword.  Changed a null test in LOOP into an endp
-    test.
-
-Other bug fixes:
-    Fixed sequence functions with output type specifiers to handle DEFTYPE'ed
-    types and other complex types correctly.  (COERCE still can't hack
-    DEFTYPEs, though.)
-
-    Fixed typep of (satisfies (lambda (obj) ...)) to coerce the form into a
-    function so that "object not function" errors don't result.
-
-    Fixed DOCUMENTATION to return only one value.
-
-Enhancements:
-    ROOM is now much more verbose, displaying a breakdown of memory usage by
-    object type.
-
-    Changed the printer to print the name of code objects and the value of
-    value cells.
-
-
-CLX:
-
-Modified EXT:OPEN-CLX-DISPLAY to set XLIB:DISPLAY-DEFAULT-SCREEN to the
-screen specified by the user before returning the display.
-
-Merged in a bug-fix to EVENT-LISTEN to make it return the right number of
-events when called when there is a current event (i.e. in an EVENT-CASE.)
-
-Fixed the CLX X interface to be much more efficient, as well as fixing some
-bugs.  The low-level I/O to the server is now faster and conses much less.
-Enabled some code speeds up pixarray read/write (though it could still be much
-better.)  Also, eliminated redundant type checking and fixed some broken
-declarations.  This fixes problems with CLX sometimes not working with some X
-servers (like the RT server.)
-
-
-Compiler:
-
-Bug fixes:
-    Fixed incorrect argument type information for some standard Common Lisp
-    functions.
-
-    Fixed PROCLAIM to work correctly when the argument isn't a constant.
-
-    Fixed the DEBUG optimize quality to be called DEBUG instead of DEBUG-INFO.
-
-    Fixed the compiler to not flame out if it sees a SATISFIES type specifier
-    where the predicate function is undefined, and generally to deal better
-    with testing whether a compile-time constant is of some type that may not
-    be properly defined yet.
-
-    Fixed a number of bugs in the handling of closures over top-level
-    variables.
-
-    Fixed a problem with semi-inline functions.
-
-    The compiler note count is no longer incremented when notes are suppressed
-    by INHIBIT-WARNINGS 3.
-
-    Some fixes that should eliminate spurious undefined-function warnings.  In
-    particular, definitions of functions in non-null lexical environments will
-    be noticed.
-
-    Also, now if a function is defined incompatibly with previous calls, the
-    warning will have proper source context.
-
-    Fixed a bug in accessors for 1,2, and 4 bit arrays that was causing #* to
-    generate incorrect bit vectors.
-
-    Changed the type system to consider #(:foo :bar) to be a subtype of 
-    (vector keyword).  In other words, array subtype relations are determined
-    according to the specialized element types actually present in this
-    implementation, rather than assuming that all element types can be
-    discriminated.
-
-    Fixed a problem that could cause type checks to be spuriously deleted in
-    some contexts where there is a local change in the SAFETY optimization
-    policy.
-
-DECStation (PMAX) specific changes:
-
-    Representation conversion of a SAP (system area pointer) to a pointer
-    representation now results in an efficiency note.
-
-    Fixed EQL (and =) on integers to not unnecessarily cons a word-integer
-    argument just because one argument is known to be a fixnum.
-
-    New version of the assembler with instruction scheduling (no-op deletion)
-    support.  This reduced the size of the core by 1.3 meg, and makes
-    everything run faster too.
-
-    Fixed TRUNCATE on floats to truncate instead of rounding.
-
-SPARC notes:
-    The SPARC port is not yet as highly tuned as the PMAX port.  In particular,
-    no instruction scheduling is done yet.  This is probably a 10% performance
-    penalty.
-
-Enhancements:
-    Made forms within a LOCALLY be recognized as "top-level" so that subforms
-    can be compiled separately.
-
-    The compiler now ignores assignments to special variables when determining
-    which representation to use for a variable.  Also, we don't print
-    representation selection efficiency notes about coercion that are due to
-    error checking code.
-
-    Added support for the EXT:CONSTANT-FUNCTION declaration (already in the
-    documentation.)
-
-    When a DEFUN is compiled and the name has a FTYPE declaration, then a note
-    is printed if any arguments to the function are assigned to (i.e. SETQ) in
-    the body, as this inhibits application of the FTYPE declaration to the
-    argument variables.
-
-    (<mumble>-P x) structure predicates are now just as efficient as
-    (TYPEP x '<mumble>).
-
-    Added type inference methods for sequence functions, and various functions
-    that return an argument as their result value.
-
-    A number of improvements to register allocation.
-
-    Added a new optimization of MULTIPLE-VALUE-CALL which converts MV calls
-    having a known number of arguments into MULTIPLE-VALUE-BIND/FUNCALL.
-    Combined with some other existing optimizations, this allows functions like
-    to be efficiently inline expanded (i.e. the APPLY turns to a FUNCALL):
-	(defun foo (&rest x)
-	  (apply #'glorp x))
-
-    Reduced the size of debug information for OPTIMIZE DEBUG <= to 1.
-    If debug-info is < 1, then don't dump debug-args or function type.
-
-    Disabled the compiler's internal consistency checking by default.  These
-    phases are only useful for locating compiler bugs.
-
-X3J13 cleanups:
-    The :VERBOSE and :PRINT keyword arguments are now supported by
-    COMPILE-FILE.  The :PROGRESS keyword is a CMU extension that provides an
-    even higher level of verbosity.  The *COMPILE-VERBOSE*, etc., variables are
-    also now supported.
-
-    Changed declaration processing to treat FUNCTION declarations as ordinary
-    variably type declarations.  The old semantics is still obtained when the
-    second arg to the declaration is a list (as it always would be in the old
-    usage.)
-
-Block compilation:
-    Added new START-BLOCK and END-BLOCK declarations to allow portions of a
-    file to be block compiled (instead of only entire files.)  This mechanism
-    also allows the entry points to a block to be specified, allowing improved
-    compilation of non-entry-point functions.  Fixed many bugs that appeared
-    once block compilation was actually used.
-
-    COMPILE-FILE now has :ENTRY-POINTS and :BLOCK-COMPILE keywords.
-    :BLOCK-COMPILE NIL will totally inhibit compile-time resolution of function
-    names (including self-calls.)  The default (:SPECIFIED) allows compile time
-    resolution, but still compiles one top-level form at a time, preventing
-    local calls between top-level forms.  In this mode, a
-        (BLOCK-START Entry-Point*)
-    declaration will start block compilation.  Block compilation is terminated
-    by BLOCK-END, or the BLOCK-START of the next block.
-
-    See also the COMPILE-FILE doc string.
-
-
-Context sensitive declarations:
-    Added the OPTIMIZE-INTERFACE declaration, which is just like OPTIMIZE, but
-    specifies the policy for function argument syntax checking and checking of
-    any declared argument types, allowing it to be distinct from the general
-    compilation policy.  This allows debugged code to be compiled with lowered
-    safety in its "guts", while still doing checking on the arguments that
-    users may supply (incorrectly.)  Any quality not separately specified
-    defaults to the normal OPTIMIZE quality.
-
-    Fixed WITH-COMPILATION-UNIT keyword to be :OVERRIDE instead of :FORCE.
-    Also, added :OPTIMIZE and :OPTIMIZE-INTERFACE for changing the "global"
-    compilation policy within the dynamic extent.
-
-    Added :CONTEXT-DECLARATIONS, which provides a way to insert declarations
-    conditional on pattern matching of the context in which the definition
-    appears.  So you can compile all external functions safe, or whatever.  See
-    the doc string for WITH-COMPILATION-UNIT.
-
-
-Hemlock:
-
-Tuning:
-    Changed typescript streams to cache the line length.  This greatly speeds
-    up slave output.
-
-    Several changes to allow redisplay to be delayed until process output (i.e.
-    in a shell buffer) is complete.  This allows the editor to catch up with
-    output by only displaying the final state of the shell buffer, instead of
-    forcing every line of output to be displayed.  This is very nice with slow
-    terminals or large outputs.
-
-TTY redisplay:
-    Changed TTY redisplay to get the terminal size and speed from Unix using
-    the appropriate "ioctl" calls.  The speed of a PTY (and hence any telnet or
-    MCN connection) is infinite by default.  For best results with TTY
-    redisplay, it is crucial to set the terminal speed with the Unix "stty"
-    command:
-    	stty 2400
-    	stty 9600 etc.
-
-    Setting the speed allows the editor to keep in synch with the terminal so
-    that typing a command will temporarily abort redisplay until until there is
-    no typeahead.  This way, if you type C-v C-v in succession, output of the
-    first screen will stop when you type the second C-v.
-
-    Fixed several bugs in TTY redisplay.  "Unexpected zero transition delta" is
-    gone.  Also, fixed some problems with the screen not being updated properly
-    after redisplay has been aborted.  (When you type several commands in quick
-    succession.)
-
-    REDISPLAY now returns T, NIL or :EDITOR-INPUT.  T is returned when
-    redisplay changed the screen.  NIL is returned when there was no change.
-    :EDITOR-INPUT is returned when redisplay tried to update the screen, but
-    was aborted due to pending editor input.
-
-    Fixed REDISPLAY-WINDOWS-FROM-MARK so that process output won't cause
-    redisplay when we aren't in Hemlock.
-
-Bug fixes:
-    Modified MAKE-BUFFERS-FOR-TYPESCRIPT to make sure the user supplied
-    slave-name is free for use, so we don't clobber currently existing slaves.
-
-    Fixed a bug in completion mode (didn't previously work in the new-compiler
-    system.)
-
-Enhancements:
-    There is a new command "Set Buffer Writable", and the obsolete
-    command "Connect to Registered Eval Server" has been removed.
-
-    Added "Slave GC Alarm" variable (default :MESSAGE) which controls how
-    obnoxious the slave GC notification is.  Other values are like for "Input
-    Wait Alarm", :LOUD-MESSAGE and NIL.
-
-    Made the slave switch demon set debug:*help-line-scroll-count* to
-    most-positive-fixnum, since the editor can do the scrolling for us.
-
-
-SYSTEM, EXTENSIONS:
-
-Made SYSTEM:BITS, BYTES, etc., be defined in the null environment so that they
-can be inline expanded.  This was causing spurious consing in various system
-code.
-
-Fixed EXT:CONNECT-TO-INET-SOCKET to check that we successfully looked up the
-name so that we don't get segment violations on unknown hosts.
-
-Fixed DI:FUNCTION-DEBUG-FUNCTION (though it still returns the XEP.)  
-Some fixes to DI: condition report methods
-
-Added support for the MACH:TIOCGWINSZ and MACH:TIOCSWINSZ ioctls.
-In the Unix interface, extended the length of pathnames from 64 to 1024.
-
-EXT:ONCE-ONLY now does sequential variable binding.  This can't cause any
-problems, since all names are gensyms, and is often useful.
-
-Added :TIMEOUT argument to SYSTEM:MAKE-FD-STREAM.  The SYSTEM:IO-TIMEOUT
-condition is signalled if a timeout is specified and exceeded.
-
-----------
diff --git a/general-info/tech-report.txt b/general-info/tech-report.txt
deleted file mode 100644
index a3dd61f9c6f8f8036f7833eb38d91391e0e0143f..0000000000000000000000000000000000000000
--- a/general-info/tech-report.txt
+++ /dev/null
@@ -1,6 +0,0 @@
-
-In addition to the documentation pointers below, the CMU CL documentation
-is also available as tech reports:
-    Hemlock Command Implementor's Manual: CMU-CS-89-134-R1
-    Hemlock User's Manual: CMU-CS-89-133-R1
-    CMU Common Lisp User's Manual: CMU-CS-91-108 (hot off the press)
diff --git a/hemlock/abbrev.lisp b/hemlock/abbrev.lisp
deleted file mode 100644
index 9ce843d0f836d000eb63652cabb5fc6857f1185c..0000000000000000000000000000000000000000
--- a/hemlock/abbrev.lisp
+++ /dev/null
@@ -1,685 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/abbrev.lisp,v 1.1.1.4 1991/11/09 03:05:25 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;		     Hemlock Word Abbreviation Mode
-;;;		          by Jamie W. Zawinski
-;;;		           24 September 1985
-;;;
-(in-package "HEMLOCK")
-
-;;;; These Things are Here:
-
-;;; C-X C-A    Add Mode Word Abbrev 
-;;;               Define a mode abbrev for the word before point.
-;;; C-X +      Add Global Word Abbrev 
-;;;               Define a global abbrev for the word before point.
-;;; C-X C-H    Inverse Add Mode Word Abbrev
-;;;               Define expansion for mode abbrev before point.
-;;; C-X -      Inverse Add Global Word Abbrev
-;;;               Define expansion for global abbrev before point.
-;;; Alt Space  Abbrev Expand Only
-;;;               Expand abbrev without inserting anything.
-;;; M-'        Word Abbrev Prefix Mark
-;;;               Mark a prefix to be glued to an abbrev following.
-;;; C-X U      Unexpand Last Word
-;;;               Unexpands last abbrev or undoes C-X U.
-
-;;; List Word Abbrevs                 Shows definitions of all word abbrevs.
-;;; Edit Word Abbrevs                 Lets you edit the definition list directly.
-;;; Read Word Abbrev File <filename>  Define word abbrevs from a definition file.
-;;; Write Word Abbrev File            Make a definition file from current abbrevs.
-
-;;; Make Word Abbrev <abbrev><expansion><mode> More General form of C-X C-A, etc.
-;;; Delete All Word Abbrevs                      Wipes them all.
-;;; Delete Mode Word Abbrev                      Kills all Mode abbrev.
-;;; Delete Global Word Abbrev                    Kills all Global abbrev.
-
-;;; Insert Word Abbrevs          Inserts a list of current definitions in the
-;;;                                format that Define Word Abbrevs uses.
-;;; Define Word Abbrevs          Defines set of abbrevs from a definition list in 
-;;;                                the buffer.
-;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev,
-;;;                                definition, or mode.
-
-;;; Append Incremental Word Abbrev File           Appends to a file changed abbrev
-;;;                                                 definitions since last dumping.
-
-(defmode "Abbrev" :major-p nil :transparent-p t :precedence 2.0)
-
-
-(defvar *Global-Abbrev-Table* (make-hash-table :test #'equal)
-  "Hash table holding global abbrev definitions.")
-
-(defhvar "Abbrev Pathname Defaults"
-  "Holds the name of the last Abbrev-file written."
-  :value (pathname "abbrev.defns"))
-
-(defvar *new-abbrevs* ()
- "holds a list of abbrevs (and their definitions and modes) changed since saving.")
-
-
-;;; C-X C-H    Inverse Add Mode Word Abbrev 
-;;;               Define a mode expansion for the word before point.
-
-(defcommand "Inverse Add Mode Word Abbrev" (p)
-  "Defines a mode word abbrev expansion for the word before the point."
-  "Defines a mode word abbrev expansion for the word before the point."
-  (declare (ignore p))
-  (let ((word (prev-word 1 (current-point)))
-	(mode (buffer-major-mode (current-buffer))))
-    (make-word-abbrev-command nil word nil mode)))
-
-
-;;; C-X C-A    Add Mode Word Abbrev
-;;;               Define mode abbrev for word before point.
-
-(defcommand "Add Mode Word Abbrev" (p)
-  "Defines a mode word abbrev for the word before the point.
-  With a positive argument, uses that many preceding words as the expansion.
-  With a zero argument, uses the region as the expansion.  With a negative
-  argument, prompts for a word abbrev to delete in the current mode."
-  "Defines or deletes a mode word abbrev."
-  (if (and p (minusp p))
-      (delete-mode-word-abbrev-command nil)
-      (let* ((val (if (eql p 0)
-		      (region-to-string (current-region nil))
-		      (prev-word (or p 1) (current-point))))
-	     (mode (buffer-major-mode (current-buffer))))
-	(make-word-abbrev-command nil nil val mode))))
-
-
-
-;;; C-X -    Inverse Add Global Word Abbrev
-;;;               Define global expansion for word before point.
-
-(defcommand "Inverse Add Global Word Abbrev" (p)
-  "Defines a Global expansion for the word before point."
-  "Defines a Global expansion for the word before point."
-  (declare (ignore p))
-  (let ((word (prev-word 1 (current-point))))
-    (make-word-abbrev-command nil word nil "Global")))
-
-
-
-;;; C-X +      Add Global Word Abbrev
-;;;               Define global Abbrev for word before point.
-
-(defcommand "Add Global Word Abbrev" (p)
-  "Defines a global word abbrev for the word before the point.
-  With a positive argument, uses that many preceding words as the expansion.
-  With a zero argument, uses the region as the expansion.  With a negative
-  argument, prompts for a global word abbrev to delete."
-  "Defines or deletes a global word abbrev."
-  (if (and p (minusp p))
-      (delete-global-word-abbrev-command nil)
-      (let ((val (if (eql p 0)
-		     (region-to-string (current-region nil))
-		     (prev-word (or p 1) (current-point)))))
-	(make-word-abbrev-command nil nil val "Global"))))
-
-
-;;;; Defining Abbrevs
-
-;;; Make Word Abbrev <abbrev><expansion><mode>  More General form of C-X C-A, etc.
-
-(defvar *global-abbrev-string-table*
-  (make-string-table :initial-contents '(("Global" . nil))))
-
-(defcommand "Make Word Abbrev" (p &optional abbrev expansion mode)
-  "Defines an arbitrary word abbreviation.
-  Prompts for abbrev, expansion, and mode."
-  "Makes Abbrev be a word abbreviation for Expansion when in Mode.  If
-  mode is \"Global\" then make a global abbrev."
-  (declare (ignore p))
-  (unless mode
-    (setq mode
-	  (prompt-for-keyword
-	   (list *mode-names* *global-abbrev-string-table*)
-	   :prompt "Mode of abbrev to add: "
-	   :default "Global"
-	   :help 
-	   "Type the mode of the Abbrev you want to add, or confirm for Global.")))
-  (let ((globalp (string-equal mode "Global")))
-    (unless (or globalp (mode-major-p mode))
-      (editor-error "~A is not a major mode." mode))
-    (unless abbrev
-      (setq abbrev
-	    (prompt-for-string
-	     :trim t
-	     :prompt
-	     (list "~A abbreviation~@[ of ~S~]: " mode expansion)
-	     :help
-	     (list "Define a ~A word abbrev." mode))))
-    (when (zerop (length abbrev))
-      (editor-error "Abbreviation must be at least one character long."))
-    (unless (every #'(lambda (ch)
-		       (zerop (character-attribute :word-delimiter ch)))
-		   (the simple-string abbrev))
-      (editor-error "Word Abbrevs must be a single word."))
-    (unless expansion
-      (setq expansion
-	    (prompt-for-string
-	     :prompt (list "~A expansion for ~S: " mode abbrev)
-	     :help (list "Define the ~A expansion of ~S." mode abbrev))))
-    (setq abbrev (string-downcase abbrev))
-    (let* ((table (cond (globalp *global-abbrev-table*)
-			((hemlock-bound-p 'Mode-Abbrev-Table :mode mode)
-			 (variable-value 'Mode-Abbrev-Table :mode mode))
-			(t
-			 (let ((new (make-hash-table :test #'equal)))
-			   (defhvar "Mode Abbrev Table"
-			     "Hash Table of Mode Abbrevs"
-			     :value new :mode mode)
-			   new))))
-	   (old (gethash abbrev table)))
-      (when (or (not old)
-		(prompt-for-y-or-n
-		 :prompt
-		 (list "Current ~A definition of ~S is ~S.~%Redefine?"
-		       mode abbrev old)
-		 :default t
-		 :help (list "Redefine the expansion of ~S." abbrev)))
-	(setf (gethash abbrev table) expansion)
-	(push (list abbrev expansion (if globalp nil mode))
-	      *new-abbrevs*)))))
-
-
-;;; Alt Space  Abbrev Expand Only
-;;;               Expand abbrev without inserting anything.
-
-(defcommand "Abbrev Expand Only" (p)
-  "This command expands the word before point into its abbrev definition 
-  (if indeed it has one)."
-  "This command expands the word before point into its abbrev definition 
-  (if indeed it has one)."
-  (declare (ignore p))
-  (let* ((word (prev-word 1 (current-point)))
-	 (glob (gethash (string-downcase word) *global-abbrev-table*))
-	 (mode (if (hemlock-bound-p 'Mode-Abbrev-Table)
-		   (gethash (string-downcase word)
-			    (value Mode-Abbrev-Table))))
-	 (end-word (reverse-find-attribute (copy-mark (current-point)
-						      :right-inserting)
-					   :word-delimiter #'zerop))
-	 (result (if mode mode glob)))
-    (when (or mode glob)
-      (delete-characters end-word (- (length word)))
-      (cond ((equal word (string-capitalize word))
-	     (setq result (string-capitalize result)))
-	    ((equal word (string-upcase word))
-	     (setq result (string-upcase result))))
-      (insert-string end-word result)
-      (unless (hemlock-bound-p 'last-expanded)
-	(defhvar "last expanded"
-            "Holds a mark, the last expanded abbrev, and its expansion in a list."
-            :buffer (current-buffer)))
-      (setf (value last-expanded)
-	    (list (copy-mark (current-point) :right-inserting)
-		  word result)))
-    (delete-mark end-word))
-  (when (and (hemlock-bound-p 'prefix-mark)
-	     (value prefix-mark))
-    (delete-characters (value prefix-mark) 1)
-    (delete-mark (value prefix-mark))
-    (setf (value prefix-mark) nil)))
-
-
-
-;;; This function returns the n words immediately before the mark supplied.
-
-(defun prev-word (n mark)
-  (let* ((mark-1 (reverse-find-attribute (copy-mark mark :temporary)
-					 :word-delimiter #'zerop))
-	 (mark-2 (copy-mark mark-1)))
-    (dotimes (x n (region-to-string (region mark-2 mark-1)))
-      (reverse-find-attribute (mark-before mark-2) :word-delimiter))))
-
-
-
-;;; M-'        Word Abbrev Prefix Mark
-;;;               Mark a prefix to be glued to an abbrev following.
-
-;;; When "Abbrev Expand Only" expands the abbrev (because #\- is an expander)
-;;; it will see that prefix-mark is non-nil, and will delete the #\- immediately
-;;; after prefix-mark.
-
-(defcommand "Word Abbrev Prefix Mark" (p)
-  "Marks a prefix to be glued to an abbrev following." 
-  "Marks a prefix to be glued to an abbrev following."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'prefix-mark)
-    (defhvar "prefix mark"
-             "Holds a mark (or not) pointing to the current Prefix Mark."
-             :buffer (current-buffer)))
-  (when (value prefix-mark)
-    (delete-mark (value prefix-mark)))
-  (setf (value prefix-mark) (copy-mark (current-point) :right-inserting))
-  (insert-character (value prefix-mark) #\-))
-
-
-;;; C-X U     Unexpand Last Word
-;;;              Unexpands last abbrev or undoes last C-X U.
-
-(defcommand "Unexpand Last Word" (p)
-  "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\".
-  Only one abbrev may be undone."
-  "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\"."
-  (declare (ignore p))
-  (unless (or (not (hemlock-bound-p 'last-expanded))
-	      (value last-expanded))
-    (editor-error "Nothing to Undo."))
-  (let ((mark (car (value last-expanded)))
-	(word1 (second (value last-expanded)))
-	(word2 (third (value last-expanded))))
-    (unless (string= word2
-		     (region-to-string
-		      (region (character-offset (copy-mark mark :temporary)
-						(- (length word2)))
-			      mark)))
-      (editor-error "The last expanded Abbrev has been altered in the text."))
-    (delete-characters mark (- (length word2)))
-    (insert-string mark word1)
-    (character-offset mark (length word1))
-    (setf (value last-expanded) (list mark word2 word1))))
-
- 
-  
-;;; Delete Mode Word Abbrev                       Kills some Mode abbrevs.
-
-(defcommand "Delete Mode Word Abbrev"
-	    (p &optional abbrev
-	       (mode (buffer-major-mode (current-buffer))))
-  "Prompts for a word abbrev and deletes the mode expansion in the current mode.
-  If called with a prefix argument, deletes all word abbrevs define in the
-  current mode."
-  "Deletes Abbrev in Mode, or all abbrevs in Mode if P is true."
-  (let ((boundp (hemlock-bound-p 'Mode-Abbrev-Table :mode mode)))
-    (if p
-	(when boundp
-	  (delete-variable 'Mode-Abbrev-Table :mode mode))
-	(let ((down
-	       (string-downcase
-		(or abbrev
-		    (prompt-for-string
-		     :prompt (list "~A abbrev to delete: " mode)
-		     :help
- (list "Give the name of a ~A mode word abbrev to delete." mode)
-		     :trim t))))
-	      (table (and boundp (variable-value 'mode-abbrev-table :mode mode))))
-	  (unless (and table (gethash down table))
-	    (editor-error "~S is not the name of an abbrev in ~A mode."
-			  down mode))
-	  (remhash down table)))))
-
-
-;;; Delete Global Word Abbrevs                    Kills some Global abbrevs.
-
-(defcommand "Delete Global Word Abbrev" (p &optional abbrev)
-  "Prompts for a word abbrev and delete the global expansion.
-  If called with a prefix argument, deletes all global abbrevs."
-  "Deletes the global word abbreviation named Abbrev.  If P is true,
-  deletes all global abbrevs."
-  (if p
-      (setq *global-abbrev-table* (make-hash-table :test #'equal))
-      (let ((down 
-	     (string-downcase
-	      (or abbrev
-		  (prompt-for-string
-		   :prompt "Global abbrev to delete: "
-		   :help "Give the name of a global word abbrev to delete."
-		   :trim t)))))
-	(unless (gethash down *global-abbrev-table*)
-	  (editor-error "~S is not the name of a global word abbrev." down))
-	(remhash down *global-abbrev-table*))))
-	
-;;; Delete All Word Abbrevs                       Wipes them all.
-
-(defcommand "Delete All Word Abbrevs" (p)
-  "Deletes all currently defined Word Abbrevs"
-  "Deletes all currently defined Word Abbrevs"
-  (declare (ignore p))
-  (Delete-Global-Word-Abbrev-Command 1)
-  (Delete-Mode-Word-Abbrev-Command 1))
-
-
-;;;; Abbrev I/O
-
-;;; List Word Abbrevs                 Shows definitions of all word abbrevs.
-
-(defcommand "List Word Abbrevs" (p)
-  "Lists all of the currently defined Word Abbrevs."
-  "Lists all of the currently defined Word Abbrevs."
-  (word-abbrev-apropos-command p ""))
-
-
-;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev,
-;;;                                definition, or mode.
-
-(defcommand "Word Abbrev Apropos" (p &optional search-string)
-  "Lists all of the currently defined Word Abbrevs which contain a given string
-  in their abbrev. definition, or mode."
-  "Lists all of the currently defined Word Abbrevs which contain a given string
-  in their abbrev. definition, or mode."
-  (declare (ignore p))
-  (unless search-string
-    (setq search-string
-	  (string-downcase
-	   (prompt-for-string
-	    :prompt "Apropos string: "
-	    :help "The string to search word abbrevs and definitions for."))))
-  (multiple-value-bind (count mode-tables) (count-abbrevs)
-    (with-pop-up-display (s :height (min (1+ count) 30))
-      (unless (zerop (hash-table-count *global-abbrev-table*))
-	(maphash #'(lambda (key val)
-		     (when (or (search search-string (string-downcase key))
-			       (search search-string (string-downcase val)))
-		       (write-abbrev key val nil s t)))
-		 *global-abbrev-table*))
-      (dolist (modename mode-tables)
-	(let ((table (variable-value 'Mode-Abbrev-Table :mode modename)))
-	  (if (search search-string (string-downcase modename))
-	      (maphash #'(lambda (key val)
-			   (write-abbrev key val modename s t))
-		       table)
-	      (maphash #'(lambda (key val)
-			   (when (or (search search-string (string-downcase key))
-				     (search search-string (string-downcase val)))
-			     (write-abbrev key val modename s t)))
-		       table))))
-      (terpri s))))
-
-
-
-(defun count-abbrevs ()
-  (let* ((count (hash-table-count *global-abbrev-table*))
-	 (mode-tables nil))
-    (do-strings (which x *mode-names*)
-      (declare (ignore x))
-      (when (hemlock-bound-p 'Mode-Abbrev-Table :mode which)
-	(let ((table-count (hash-table-count (variable-value 'Mode-Abbrev-Table
-							     :mode which))))
-	  (unless (zerop table-count)
-	    (incf count table-count)
-	    (push which mode-tables)))))
-    (values count mode-tables)))
-
-
-;;; Edit Word Abbrevs                 Lets you edit the definition list directly.
-
-(defcommand "Edit Word Abbrevs" (p)
-  "Allows direct editing of currently defined Word Abbrevs."
-  "Allows direct editing of currently defined Word Abbrevs."
-  (declare (ignore p))
-  (when (getstring "Edit Word Abbrevs" *buffer-names*)
-    (delete-buffer (getstring "Edit Word Abbrevs" *buffer-names*)))
-  (let ((old-buf (current-buffer))
-	(new-buf (make-buffer "Edit Word Abbrevs")))
-    (change-to-buffer new-buf)
-    (unwind-protect
-      (progn
-       (insert-word-abbrevs-command nil)
-       (do-recursive-edit)
-       (unless (equal #\newline (previous-character (buffer-end (current-point))))
-	 (insert-character (current-point) #\newline))
-       (delete-all-word-abbrevs-command nil)
-       (define-word-abbrevs-command nil))
-      (progn
-       (change-to-buffer old-buf)
-       (delete-buffer new-buf)))))
-
-
-
-;;; Insert Word Abbrevs          Inserts a list of current definitions in the
-;;;                                format that Define Word Abbrevs uses.
-
-(defcommand "Insert Word Abbrevs" (p)
-  "Inserts into the current buffer a list of all currently defined abbrevs in the
-  format used by \"Define Word Abbrevs\"."
-  "Inserts into the current buffer a list of all currently defined abbrevs in the
-  format used by \"Define Word Abbrevs\"."
-  
-  (declare (ignore p))
-  (multiple-value-bind (x mode-tables)
-		       (count-abbrevs)
-    (declare (ignore x))
-    (with-output-to-mark (stream (current-point) :full)
-      (maphash #'(lambda (key val)
-		   (write-abbrev key val nil stream))
-	       *global-abbrev-table*)
-      
-      (dolist (mode mode-tables)
-	(let ((modename (if (listp mode) (car mode) mode)))
-	  (maphash #'(lambda (key val)
-		       (write-abbrev key val modename stream))
-		   (variable-value 'Mode-Abbrev-Table :mode modename)))))))
-
-
-
-;;; Define Word Abbrevs          Defines set of abbrevs from a definition list in 
-;;;                                the buffer.
-
-(defcommand "Define Word Abbrevs" (p)
-  "Defines Word Abbrevs from the definition list in the current buffer.  The 
-  definition list must be in the format produced by \"Insert Word Abbrevs\"."
-  "Defines Word Abbrevs from the definition list in the current buffer.  The
-  definition list must be in the format produced by \"Insert Word Abbrevs\"."
-  
-  (declare (ignore p))
-  (with-input-from-region (file (buffer-region (current-buffer)))
-    (read-abbrevs file)))
-
-
-;;; Read Word Abbrev file <filename>   Define word abbrevs from a definition file.
-
-;;; Ignores all lines less than 4 characters, i.e. blankspace or errors. That is
-;;; the minimum number of characters possible to define an abbrev.  It thinks the 
-;;; current abbrev "wraps" if there is no #\" at the end of the line or there are
-;;; two #\"s at the end of the line (unless that is the entire definition string,
-;;; i.e, a null-abbrev).
-
-;;; The format of the Abbrev files is 
-;;;
-;;;                   ABBREV<tab><tab>"ABBREV DEFINITION"
-;;;
-;;; for Global Abbrevs, and
-;;;
-;;;                   ABBREV<tab>(MODE)<tab>"ABBREV DEFINITION"
-;;;
-;;; for Modal Abbrevs.  
-;;; Double-quotes contained within the abbrev definition are doubled.  If the first
-;;; line of an abbrev definition is not closed by a single double-quote, then
-;;; the subsequent lines are read in until a single double-quote is found.
-
-(defcommand "Read Word Abbrev File" (p &optional filename)
-  "Reads in a file of previously defined abbrev definitions."
-  "Reads in a file of previously defined abbrev definitions."
-  (declare (ignore p))
-  (setf (value abbrev-pathname-defaults)
-	(if filename
-	    filename
-	    (prompt-for-file
-	     :prompt "Name of abbrev file: "
-	     :help "The name of the abbrev file to load."
-	     :default (value abbrev-pathname-defaults)
-	     :must-exist nil)))
-  (with-open-file (file (value abbrev-pathname-defaults) :direction :input
-			:element-type 'base-char :if-does-not-exist :error)
-    (read-abbrevs file)))
-
-
-;;; Does the actual defining of abbrevs from a given stream, expecting tabs and
-;;; doubled double-quotes.
-
-(defun read-abbrevs (file)
-  (do ((line (read-line file nil nil)
-	     (read-line file nil nil)))
-      ((null line))
-    (unless (< (length line) 4)
-      (let* ((tab (position #\tab line))
-	     (tab2 (position #\tab line :start (1+ tab)))
-	     (abbrev (subseq line 0 tab))
-	     (modename (subseq line (1+ tab) tab2))
-	     (expansion (do* ((last (1+ (position #\" line))
-				    (if found (min len (1+ found)) 0))
-			      (len (length line))
-			      (found (if (position #\" line :start last)
-					 (1+ (position #\" line :start last)))
-				     (if (position #\" line :start last)
-					 (1+ (position #\" line :start last))))
-			      (expansion (subseq line last (if found found len))
-					 (concatenate 'simple-string expansion
-						      (subseq line last
-							      (if found found
-								  len)))))
-			     ((and (or (null found) (= found len))
-				   (equal #\" (char line (1- len)))
-				   (or (not (equal #\" (char line (- len 2))))
-				       (= (- len 3) tab2)))
-			      (subseq expansion 0 (1- (length expansion))))
-			  
-			  (when (null found)
-			    (setq line (read-line file nil nil)
-				  last 0
-				  len (length line)
-				  found (if (position #\" line)
-					    (1+ (position #\" line)))
-				  expansion (format nil "~A~%~A" expansion
-						    (subseq line 0 (if found
-								       found
-								       0))))))))
-	
-	(cond ((equal modename "")
-	       (setf (gethash abbrev *global-abbrev-table*)
-		     expansion))
-	      (t (setq modename (subseq modename 1 (1- (length modename))))
-		 (unless (hemlock-bound-p 'Mode-Abbrev-Table
-					  :mode modename)
-		   (defhvar "Mode Abbrev Table"
-    			    "Hash Table of Mode Abbrevs"
-    			    :value (make-hash-table :test #'equal)
-  			    :mode modename))
-		 (setf (gethash abbrev (variable-value
-					'Mode-Abbrev-Table :mode modename))
-		       expansion)))))))
-
-
-;;; Write Word Abbrev File            Make a definition file from current abbrevs.
-
-(defcommand "Write Word Abbrev File" (p &optional filename)
-  "Saves the currently defined Abbrevs to a file."
-  "Saves the currently defined Abbrevs to a file."
-  (declare (ignore p))
-  (unless filename
-    (setq filename
-	  (prompt-for-file
-	   :prompt "Write abbrevs to file: "
-	   :default (value abbrev-pathname-defaults)
-	   :help "Name of the file to write current abbrevs to."
-	   :must-exist nil)))
-  (with-open-file (file filename :direction :output
-			:element-type 'base-char :if-exists :supersede
-			:if-does-not-exist :create)
-    (multiple-value-bind (x mode-tables) (count-abbrevs)
-      (declare (ignore x))
-      (maphash #'(lambda (key val)
-		   (write-abbrev key val nil file))
-	       *global-abbrev-table*)
-      
-      (dolist (modename mode-tables)
-	(let ((mode (if (listp modename) (car modename) modename)))
-	  (maphash #'(lambda (key val)
-		       (write-abbrev key val mode file))
-		   (variable-value 'Mode-Abbrev-Table :mode mode))))))
-  (let ((tn (truename filename)))
-    (setf (value abbrev-pathname-defaults) tn)
-    (message "~A written." (namestring tn))))
-
-
-
-;;; Append to Word Abbrev File          Appends to a file changed abbrev 
-;;;                                     definitions since last dumping.
-
-(defcommand "Append to Word Abbrev File" (p &optional filename)
-  "Appends Abbrevs defined or redefined since the last save to a file."
-  "Appends Abbrevs defined or redefined since the last save to a file."
-  (declare (ignore p))
-  (cond
-   (*new-abbrevs*
-    (unless filename
-      (setq filename
-	    (prompt-for-file
-	     :prompt
-	     "Append incremental abbrevs to file: "
-	     :default (value abbrev-pathname-defaults)
-	     :must-exist nil
-	     :help "Filename to append recently defined Abbrevs to.")))
-    (write-incremental :append filename))
-   (t
-    (message "No Abbrev definitions have been changed since the last write."))))
-
-
-(defun write-incremental (mode filename)
-  (with-open-file (file filename :direction :output
-			:element-type 'base-char
-			:if-exists mode :if-does-not-exist :create)
-    (dolist (def *new-abbrevs*)
-      (let ((abb (car def))
-	    (val (second def))
-	    (mode (third def)))
-	(write-abbrev abb val mode file))))
-  (let ((tn (truename filename)))
-    (setq *new-abbrevs* nil)
-    (setf (value abbrev-pathname-defaults) tn)
-    (message "~A written." (namestring tn))))
-
-
-;;; Given an Abbrev, expansion, mode (nil for Global), and stream, this function
-;;; writes to the stream with doubled double-quotes and stuff.
-;;; If the flag is true, then the output is in a pretty format (like "List Word
-;;; Abbrevs" uses), otherwise output is in tabbed format (like "Write Word 
-;;; Abbrev File" uses).
-
-(defun write-abbrev (abbrev expansion modename file &optional flag)
-  (if flag
-      (if modename
-	  (format file "~5t~A~20t(~A)~35t\"" abbrev modename); pretty format
-	  (format file "~5t~A~35t\"" abbrev))                ; pretty format
-      (cond (modename
-	     (write-string abbrev file)
-	     (write-char #\tab file)
-	     (format file "(~A)" modename)                   ; "~A<tab>(~A)<tab>\""
-	     (write-char #\tab file)
-	     (write-char #\" file))
-	    (t
-	     (write-string abbrev file)
-	     (write-char #\tab file)                         ; "~A<tab><tab>\""
-	     (write-char #\tab file)
-	     (write-char #\" file))))
-  (do* ((prev 0 found)
-	(found (position #\" expansion)
-	       (position #\" expansion :start found)))
-       ((not found)
-	(write-string expansion file :start prev)
-	(write-char #\" file)
-	(terpri file))
-    (incf found)
-    (write-string expansion file :start prev :end found)
-    (write-char #\" file)))
-
-
-(defcommand "Abbrev Mode" (p)
-  "Put current buffer in Abbrev mode." 
-  "Put current buffer in Abbrev mode."  
-  (declare (ignore p))
-  (setf (buffer-minor-mode (current-buffer) "Abbrev")
-	(not (buffer-minor-mode (current-buffer) "Abbrev"))))
diff --git a/hemlock/auto-save.lisp b/hemlock/auto-save.lisp
deleted file mode 100644
index 4c773c81e5ced9b3ace88ed8d8b7251f5d312283..0000000000000000000000000000000000000000
--- a/hemlock/auto-save.lisp
+++ /dev/null
@@ -1,396 +0,0 @@
-;;; -*- Package: Hemlock; Log: hemlock.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/auto-save.lisp,v 1.3 1992/03/24 00:38:45 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;; 
-;;; Auto-Save Mode
-;;; Written by Christopher Hoover
-;;;
-
-(in-package 'hemlock)
-
-
-;;;; Per Buffer State Information
-
-;;; 
-;;; The auto-save-state structure is used to store the state information for
-;;; a particular buffer in "Save" mode, namely the buffer-signature at the last
-;;; key stroke, the buffer-signature at the time of the last checkpoint, a count
-;;; of the number of destructive keystrokes which have occured since the time of
-;;; the last checkpoint, and the pathname used to write the last checkpoint.  It
-;;; is generally kept in a buffer-local hvar called "Auto Save State".
-;;; 
-(defstruct (auto-save-state
-	    (:conc-name save-state-)
-	    (:print-function print-auto-save-state))
-  "Per buffer state for auto-save"
-  (buffer nil)				   ; buffer this state is for; for printing
-  (key-signature 0 :type fixnum)	   ; buffer-signature at last keystroke
-  (last-ckp-signature 0 :type fixnum)	   ; buffer-signature at last checkpoint
-  (key-count 0 :type fixnum)		   ; # destructive keystrokes since ckp
-  (pathname nil))			   ; pathname used to write last ckp file
-
-(defun print-auto-save-state (auto-save-state stream depth)
-  (declare (ignore depth))
-  (format stream "#<Auto Save Buffer State for buffer ~A>"
-	  (buffer-name (save-state-buffer auto-save-state))))
-
-
-;;; GET-AUTO-SAVE-STATE tries to get the auto-save-state for the buffer.  If
-;;; the buffer is not in "Save" mode then this function returns NIL.
-;;;
-(defun get-auto-save-state (buffer)
-  (if (hemlock-bound-p 'auto-save-state :buffer buffer)
-       (variable-value 'auto-save-state :buffer buffer)))
-
-;;; RESET-AUTO-SAVE-STATE resets the auto-save-state of the buffer making it
-;;; look as if the buffer was just checkpointed.  This is in fact how
-;;; checkpoint-buffer updates the state.  If the buffer is not in "Save" mode
-;;; this function punts the attempt and does nothing.
-;;;
-(defun reset-auto-save-state (buffer)
-  (let ((state (get-auto-save-state buffer)))
-    (when state
-      (let ((signature (buffer-signature buffer)))
-	(setf (save-state-key-signature state)
-	      signature)
-	(setf (save-state-last-ckp-signature state)
-	      signature)
-	(setf (save-state-key-count state)
-	      0)))))
-
-
-
-;;;; Checkpoint Pathname Interface/Internal Routines
-
-;;; GET-CHECKPOINT-PATHNAME -- Interface
-;;;
-;;; Returns the pathname of the checkpoint file for the specified
-;;; buffer;  Returns NIL if no checkpoints have been written thus
-;;; far or if the buffer isn't in "Save" mode.
-;;; 
-(defun get-checkpoint-pathname (buffer)
-  "Returns the pathname of the checkpoint file for the specified buffer.
-   If no checkpoints have been written thus far, or if the buffer is not in
-   \"Save\" mode, return nil."
-  (let ((state (get-auto-save-state buffer)))
-    (if state
-	(save-state-pathname state))))
-
-;;; MAKE-UNIQUE-SAVE-PATHNAME is used as the default value for "Auto Save
-;;; Pathname Hook" and is mentioned in the User's manual, so it gets a doc
-;;; doc string.
-;;;
-(defun make-unique-save-pathname (buffer)
-  "Returns a pathname for a non-existing file in DEFAULT-DIRECTORY.  Uses
-   GENSYM to for a file name: save-GENSYM.CKP."
-  (declare (ignore buffer))
-  (let ((def-dir (default-directory)))
-    (loop
-      (let* ((sym (gensym))
-	     (f (merge-pathnames (format nil "save-~A.CKP" sym) def-dir)))
-	(unless (probe-file f)
-	  (return f))))))
-    
-(defhvar "Auto Save Pathname Hook"
-  "This hook is called by Auto Save to get a checkpoint pathname when there
-   is no pathname associated with a buffer.  If this value is NIL, then
-   \"Save\" mode is turned off in the buffer.  Otherwise, the function
-   will be called. It should take a buffer as its argument and return either
-   NIL or a pathname.  If NIL is returned, then \"Save\" mode is turned off
-   in the buffer;  else the pathname returned is used as the checkpoint
-   pathname for the buffer."
-  :value #'make-unique-save-pathname)
-
-
-;;; MAKE-BUFFER-CKP-PATHNAME attempts to form a pathname by using the buffer's
-;;; associated pathname (from buffer-pathname).  If there isn't a pathname
-;;; associated with the buffer, the function returns nil.  Otherwise, it uses
-;;; the "Auto Save Filename Pattern" and FORMAT to make the checkpoint
-;;; pathname.
-;;;
-(defun make-buffer-ckp-pathname (buffer)
-  (let ((buffer-pn (buffer-pathname buffer)))
-    (if buffer-pn
-	(pathname (format nil
-			  (value auto-save-filename-pattern)
-			  (directory-namestring buffer-pn)
-			  (file-namestring buffer-pn))))))
-
-
-
-;;;; Buffer-level Checkpoint Routines
-
-;;;
-;;; write-checkpoint-file -- Internal
-;;;
-;;; Does the low-level write of the checkpoint.  Returns T if it succeeds
-;;; and NIL if it fails.  Echoes winnage or lossage to the luser.
-;;;
-(defun write-checkpoint-file (pathname buffer)
-  (let ((ns (namestring pathname)))
-    (cond ((file-writable pathname)
-	   (message "Saving ~A" ns)
-	   (handler-case (progn
-			   (write-file (buffer-region buffer) pathname
-				       :keep-backup nil
-				       :access #o600) ;read/write by owner.
-			   t)
-	     (error (condition)
-	       (loud-message "Auto Save failure: ~A" condition)
-	       nil)))
-	  (t
-	   (message "Can't write ~A" ns)
-	   nil))))
-
-
-;;;
-;;; To save, or not to save... and to save as what?
-;;;
-;;; First, make-buffer-ckp-pathname is called. It will return either NIL or
-;;; a pathname formed by using buffer-pathname in conjunction with the hvar
-;;; "Auto Save Filename Pattern".  If there isn't an associated pathname or
-;;; make-buffer-ckp-pathname returns NIL, then we use the pathname we used
-;;; the last time we checkpointed the buffer.  If we've never checkpointed
-;;; the buffer, then we check "Auto Save Pathname Hook".  If it is NIL then
-;;; we turn Save mode off for the buffer, else we funcall the function on
-;;; the hook with the buffer as an argument.  The function on the hook should
-;;; return either NIL or a pathname. If it returns NIL, we toggle Save mode
-;;; off for the buffer;  otherwise, we use the pathname it returned.
-;;;
-
-;;; 
-;;; checkpoint-buffer -- Internal
-;;;
-;;; This functions takes a buffer as its argument and attempts to write a
-;;; checkpoint for that buffer.  See the notes at the beginning of this page
-;;; for how it determines what pathname to use as the checkpoint pathname.
-;;; Note that a checkpoint is not necessarily written -- instead "Save"
-;;; mode may be turned off for the buffer.
-;;;
-(defun checkpoint-buffer (buffer)
-  (let* ((state (get-auto-save-state buffer))
-	 (buffer-ckp-pn (make-buffer-ckp-pathname buffer))
-	 (last-pathname (save-state-pathname state)))
-    (cond (buffer-ckp-pn
-	   (when (write-checkpoint-file buffer-ckp-pn buffer)
-	     (reset-auto-save-state buffer)
-	     (setf (save-state-pathname state) buffer-ckp-pn)
-	     (when (and last-pathname
-			(not (equal last-pathname buffer-ckp-pn))
-			(probe-file last-pathname))
-	       (delete-file last-pathname))))
-	  (last-pathname
-	   (when (write-checkpoint-file last-pathname buffer)
-	     (reset-auto-save-state buffer)))
-	  (t
-	   (let* ((save-pn-hook (value auto-save-pathname-hook))
-		  (new-pn (if save-pn-hook
-			      (funcall save-pn-hook buffer))))
-	     (cond ((or (not new-pn)
-			(zerop (length
-				(the simple-string (namestring new-pn)))))
-		    (setf (buffer-minor-mode buffer "Save") nil))
-		   (t
-		    (when (write-checkpoint-file new-pn buffer)
-		      (reset-auto-save-state buffer)
-		      (setf (save-state-pathname state) new-pn)))))))))
-
-;;;
-;;; checkpoint-all-buffers -- Internal
-;;; 
-;;; This function looks through the buffer list and checkpoints
-;;; each buffer that is in "Save" mode that has been modified since
-;;; its last checkpoint. 
-;;; 
-(defun checkpoint-all-buffers (elapsed-time)
-  (declare (ignore elapsed-time))
-  (dolist (buffer *buffer-list*)
-    (let ((state (get-auto-save-state buffer)))
-      (when (and state
-		 (buffer-modified buffer)
-		 (not (eql
-		       (save-state-last-ckp-signature state)
-		       (buffer-signature buffer))))
-	(checkpoint-buffer buffer)))))
-
-
-;;;; Random Hooks: cleanup, buffer-modified, change-save-freq.
-
-;;;
-;;; cleanup-checkpoint -- Internal
-;;; 
-;;; Cleans up checkpoint file for a given buffer if Auto Save Cleanup
-;;; Checkpoints is non-NIL.  This is called via "Write File Hook"
-;;; 
-(defun cleanup-checkpoint (buffer)
-  (let ((ckp-pathname (get-checkpoint-pathname buffer)))
-    (when (and (value auto-save-cleanup-checkpoints)
-	       ckp-pathname
-	       (probe-file ckp-pathname))
-      (delete-file ckp-pathname))))
-
-(add-hook write-file-hook 'cleanup-checkpoint)
-
-;;;
-;;; notice-buffer-modified -- Internal
-;;;
-;;; This function is called on "Buffer Modified Hook" to reset
-;;; the Auto Save state.  It makes the buffer look like it has just
-;;; been checkpointed.
-;;;
-(defun notice-buffer-modified (buffer flag)
-  ;; we care only when the flag has gone to false
-  (when (not flag)
-    (reset-auto-save-state buffer)))
-
-(add-hook buffer-modified-hook 'notice-buffer-modified)
-
-;;;
-;;; change-save-frequency -- Internal
-;;; 
-;;; This keeps us scheduled at the proper interval.  It is stuck on
-;;; the hook list for the hvar "Auto Save Checkpoint Frequency" and
-;;; is therefore called whenever this value is set.
-;;; 
-(defun change-save-frequency (name kind where new-value)
-  (declare (ignore name kind where))
-  (setq new-value (truncate new-value))
-  (remove-scheduled-event 'checkpoint-all-buffers)
-  (when (and new-value
-	     (plusp new-value))
-    (schedule-event new-value 'checkpoint-all-buffers t)))
-
-
-;;; "Save" mode is in "Default Modes", so turn it off in these modes.
-;;;
-
-(defun interactive-modes (buffer on)
-  (when on (setf (buffer-minor-mode buffer "Save") nil)))
-
-(add-hook typescript-mode-hook 'interactive-modes)
-(add-hook eval-mode-hook 'interactive-modes)
-
-
-
-;;;; Key Count Routine for Input Hook
-
-;;; 
-;;; auto-save-count-keys -- Internal
-;;;
-;;; This function sits on the Input Hook to eat cycles.  If the current
-;;; buffer is not in Save mode or if the current buffer is the echo area
-;;; buffer, it does nothing.  Otherwise, we check to see if we have exceeded
-;;; the key count threshold (and write a checkpoint if we have) and we
-;;; increment the key count for the buffer.
-;;;
-(defun auto-save-count-keys ()
-  (declare (optimize speed))
-  (let ((buffer (current-buffer)))
-    (unless (eq buffer *echo-area-buffer*)
-      (let ((state (value auto-save-state))
-	    (threshold (value auto-save-key-count-threshold)))
-	(when (and state threshold)
-	  (let ((signature (buffer-signature buffer)))
-	    (declare (fixnum signature))
-	    (when (not (eql signature
-			    (save-state-key-signature state)))
-	      ;; see if we exceeded threshold last time...
-	      (when (>= (save-state-key-count state)
-			(the fixnum threshold))
-		(checkpoint-buffer buffer))
-	      ;; update state
-	      (setf (save-state-key-signature state) signature)
-	      (incf (save-state-key-count state)))))))))
-
-(add-hook input-hook 'auto-save-count-keys)
-
-
-;;;; Save Mode Hemlock Variables
-
-;;; 
-;;; Hemlock variables/parameters for Auto-Save Mode
-;;;
-
-(defhvar "Auto Save Filename Pattern"
-  "This control-string is used with format to make the filename of the
-  checkpoint file.  Format is called with two arguments, the first
-  being the directory namestring and the second being the file
-  namestring of the default buffer pathname."
-  :value "~A~A.CKP")
-
-(defhvar "Auto Save Key Count Threshold"
-  "This value is the number of destructive/modifying keystrokes that will
-  automatically trigger an checkpoint.  This value may be NIL to turn this
-  feature off."
-  :value 256)
-
-(defhvar "Auto Save Cleanup Checkpoints"
-  "This variable controls whether or not \"Save\" mode will delete the
-  checkpoint file for a buffer after it is saved.  If this value is
-  non-NIL then cleanup will occur."
-  :value t)
-
-(defhvar "Auto Save Checkpoint Frequency"
-  "All modified buffers (in \"Save\" mode) will be checkpointed after this
-  amount of time (in seconds).  This value may be NIL (or non-positive)
-  to turn this feature off."
-  :value (* 2 60)
-  :hooks '(change-save-frequency))
-
-(defhvar "Auto Save State"
-  "Shadow magic.  This variable is seen when in buffers that are not
-  in \"Save\" mode.  Do not change this value or you will lose."
-  :value nil)
-
-
-;;;; "Save" mode
-
-(defcommand "Auto Save Mode" (p)
-  "If the argument is zero or negative, turn \"Save\" mode off.  If it
-  is positive turn \"Save\" mode on.  If there is no argument, toggle
-  \"Save\" mode in the current buffer.  When in \"Save\" mode, files
-  are automatically checkpointed every \"Auto Save Checkpoint Frequency\"
-  seconds or every \"Auto Save Key Count Threshold\" destructive
-  keystrokes.  If there is a pathname associated with the buffer, the
-  filename used for the checkpoint file is controlled by the hvar \"Auto
-  Save Filename Pattern\".  Otherwise, the hook \"Auto Save Pathname Hook\"
-  is used to generate a checkpoint pathname.  If the buffer's pathname
-  changes between checkpoints, the checkpoint file will be written under
-  the new name and the old checkpoint file will be deleted if it exists.
-  When a buffer is written out, the checkpoint will be deleted if the
-  hvar \"Auto Save Cleanup Checkpoints\" is non-NIL."
-  "Turn on, turn off, or toggle \"Save\" mode in the current buffer."
-  (setf (buffer-minor-mode (current-buffer) "Save")
-	(if p
-	    (plusp p)
-	    (not (buffer-minor-mode (current-buffer) "Save")))))
-
-(defun setup-auto-save-mode (buffer)
-  (let* ((signature (buffer-signature buffer))
-	 (state (make-auto-save-state
-		 :buffer buffer
-		 :key-signature (the fixnum signature)
-		 :last-ckp-signature (the fixnum signature))))
-    ;; shadow the global value with a variable which will
-    ;; contain our per buffer state information
-    (defhvar "Auto Save State"
-      "This is the \"Save\" mode state information for this buffer."
-      :buffer buffer
-      :value state)))
-
-(defun cleanup-auto-save-mode (buffer)
-  (delete-variable 'auto-save-state
-		   :buffer buffer))
-
-(defmode "Save"
-  :setup-function 'setup-auto-save-mode
-  :cleanup-function 'cleanup-auto-save-mode)
diff --git a/hemlock/bindings.lisp b/hemlock/bindings.lisp
deleted file mode 100644
index 0a0734ac293f2d6aa77ec087cff14287543e7f40..0000000000000000000000000000000000000000
--- a/hemlock/bindings.lisp
+++ /dev/null
@@ -1,770 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;; Some bindings:
-;;;
-
-(in-package "HEMLOCK")
-
-
-
-;;;; Default key translations:
-
-;;; This page defines prefix characters that set specified modifier bits on
-;;; the next character typed.
-;;;
-(setf (key-translation #k"escape") '(:bits :meta))
-(setf (key-translation #k"control-z") '(:bits :control :meta))
-(setf (key-translation #k"control-Z") '(:bits :control :meta))
-(setf (key-translation #k"control-^") '(:bits :control))
-(setf (key-translation #k"control-c") '(:bits :hyper))
-(setf (key-translation #k"control-C") '(:bits :hyper))
-
-
-
-;;;; Most every binding.
-
-;;; Self insert letters:
-;;;
-(do-alpha-key-events (key-event :both)
-  (bind-key "Self Insert" key-event))
-
-(bind-key "Beginning of Line" #k"control-a")
-(bind-key "Delete Next Character" #k"control-d")
-(bind-key "End of Line" #k"control-e")
-(bind-key "Forward Character" #k"control-f")
-(bind-key "Forward Character" #k"rightarrow")
-(bind-key "Backward Character" #k"control-b")
-(bind-key "Backward Character" #k"leftarrow")
-(bind-key "Kill Line" #k"control-k")
-(bind-key "Refresh Screen" #k"control-l")
-(bind-key "Next Line" #k"control-n")
-(bind-key "Next Line" #k"downarrow")
-(bind-key "Previous Line" #k"control-p")
-(bind-key "Previous Line" #k"uparrow")
-(bind-key "Query Replace" #k"meta-%")
-(bind-key "Reverse Incremental Search" #k"control-r")
-(bind-key "Incremental Search" #k"control-s")
-(bind-key "Forward Search" #k"meta-s")
-(bind-key "Reverse Search" #k"meta-r")
-(bind-key "Transpose Characters" #k"control-t")
-(bind-key "Universal Argument" #k"control-u")
-(bind-key "Scroll Window Down" #k"control-v")
-(bind-key "Scroll Window Up" #k"meta-v")
-(bind-key "Scroll Next Window Down" #k"control-meta-v")
-(bind-key "Scroll Next Window Up" #k"control-meta-V")
-
-(bind-key "Help" #k"home")
-(bind-key "Help" #k"control-_")
-(bind-key "Describe Key" #k"meta-?")
-
-
-(bind-key "Here to Top of Window" #k"leftdown")
-(bind-key "Do Nothing" #k"leftup")
-(bind-key "Top Line to Here" #k"rightdown")
-(bind-key "Do Nothing" #k"rightup")
-(bind-key "Point to Here" #k"middledown")
-(bind-key "Point to Here" #k"super-leftdown")
-(bind-key "Generic Pointer Up" #k"middleup")
-(bind-key "Generic Pointer Up" #k"super-leftup")
-(bind-key "Do Nothing" #k"super-rightup")
-(bind-key "Insert Kill Buffer" #k"super-rightdown")
-
-
-(bind-key "Insert File" #k"control-x control-r")
-(bind-key "Save File" #k"control-x control-s")
-(bind-key "Visit File" #k"control-x control-v")
-(bind-key "Write File" #k"control-x control-w")
-(bind-key "Find File" #k"control-x control-f")
-(bind-key "Backup File" #k"control-x meta-b")
-(bind-key "Save All Files" #k"control-x control-m")
-(bind-key "Save All Files" #k"control-x return")
-(bind-key "Save All Files and Exit" #k"control-x meta-z")
-
-(bind-key "List Buffers" #k"control-x control-b")
-(bind-key "Buffer Not Modified" #k"meta-~")
-(bind-key "Check Buffer Modified" #k"control-x ~")
-(bind-key "Select Buffer" #k"control-x b")
-(bind-key "Select Previous Buffer" #k"control-meta-l")
-(bind-key "Circulate Buffers" #k"control-meta-L")
-(bind-key "Create Buffer" #k"control-x meta-b")
-(bind-key "Kill Buffer" #k"control-x k")
-(bind-key "Select Random Typeout Buffer" #k"hyper-t")
-
-(bind-key "Next Window" #k"control-x n")
-(bind-key "Next Window" #k"control-x o")
-(bind-key "Previous Window" #k"control-x p")
-(bind-key "Split Window" #k"control-x 2")
-(bind-key "New Window" #k"control-x control-n")
-(bind-key "Delete Window" #k"control-x d")
-(bind-key "Delete Next Window" #k"control-x 1")
-(bind-key "Line to Top of Window" #k"meta-!")
-(bind-key "Line to Center of Window" #k"meta-#")
-(bind-key "Top of Window" #k"meta-,")
-(bind-key "Bottom of Window" #k"meta-.")
-
-(bind-key "Exit Hemlock" #k"control-x control-z")
-(bind-key "Exit Recursive Edit" #k"control-meta-z")
-(bind-key "Abort Recursive Edit" #k"control-]")
-
-(bind-key "Delete Previous Character" #k"delete")
-(bind-key "Delete Previous Character" #k"backspace")
-(bind-key "Kill Next Word" #k"meta-d")
-(bind-key "Kill Previous Word" #k"meta-delete")
-(bind-key "Kill Previous Word" #k"meta-backspace")
-(bind-key "Exchange Point and Mark" #k"control-x control-x")
-(bind-key "Mark Whole Buffer" #k"control-x h")
-(bind-key "Set/Pop Mark" #k"control-@")
-(bind-key "Set/Pop Mark" #k"control-space")
-(bind-key "Pop and Goto Mark" #k"meta-space")
-(bind-key "Pop and Goto Mark" #k"meta-@")
-(bind-key "Pop Mark" #k"control-meta-space")  ;#k"control-meta-@" = "Mark Form".
-(bind-key "Kill Region" #k"control-w")
-(bind-key "Save Region" #k"meta-w")
-(bind-key "Un-Kill" #k"control-y")
-(bind-key "Rotate Kill Ring" #k"meta-y")
-
-(bind-key "Forward Word" #k"meta-f")
-(bind-key "Backward Word" #k"meta-b")
-
-(bind-key "Forward Paragraph" #k"meta-]")
-(bind-key "Forward Sentence" #k"meta-e")
-(bind-key "Backward Paragraph" #k"meta-[")
-(bind-key "Backward Sentence" #k"meta-a")
-
-(bind-key "Mark Paragraph" #k"meta-h")
-
-(bind-key "Forward Kill Sentence" #k"meta-k")
-(bind-key "Backward Kill Sentence" #k"control-x delete")
-(bind-key "Backward Kill Sentence" #k"control-x backspace")
-
-(bind-key "Beginning of Buffer" #k"meta-\<")
-(bind-key "End of Buffer" #k"meta-\>")
-(bind-key "Mark to Beginning of Buffer" #k"control-\<")
-(bind-key "Mark to End of Buffer" #k"control-\>")
-
-(bind-key "Extended Command" #k"meta-x")
-
-(bind-key "Uppercase Word" #k"meta-u")
-(bind-key "Lowercase Word" #k"meta-l")
-(bind-key "Capitalize Word" #k"meta-c")
-
-(bind-key "Previous Page" #k"control-x ["))
-(bind-key "Next Page" #k"control-x ]"))
-(bind-key "Mark Page" #k"control-x control-p")
-(bind-key "Count Lines Page" #k"control-x l")
-
-
-
-;;;; Argument Digit and Negative Argument.
-
-(bind-key "Negative Argument" #k"meta-\-")
-(bind-key "Argument Digit" #k"meta-0")
-(bind-key "Argument Digit" #k"meta-1")
-(bind-key "Argument Digit" #k"meta-2")
-(bind-key "Argument Digit" #k"meta-3")
-(bind-key "Argument Digit" #k"meta-4")
-(bind-key "Argument Digit" #k"meta-5")
-(bind-key "Argument Digit" #k"meta-6")
-(bind-key "Argument Digit" #k"meta-7")
-(bind-key "Argument Digit" #k"meta-8")
-(bind-key "Argument Digit" #k"meta-9")
-(bind-key "Negative Argument" #k"control-\-")
-(bind-key "Argument Digit" #k"control-0")
-(bind-key "Argument Digit" #k"control-1")
-(bind-key "Argument Digit" #k"control-2")
-(bind-key "Argument Digit" #k"control-3")
-(bind-key "Argument Digit" #k"control-4")
-(bind-key "Argument Digit" #k"control-5")
-(bind-key "Argument Digit" #k"control-6")
-(bind-key "Argument Digit" #k"control-7")
-(bind-key "Argument Digit" #k"control-8")
-(bind-key "Argument Digit" #k"control-9")
-(bind-key "Negative Argument" #k"control-meta-\-")
-(bind-key "Argument Digit" #k"control-meta-0")
-(bind-key "Argument Digit" #k"control-meta-1")
-(bind-key "Argument Digit" #k"control-meta-2")
-(bind-key "Argument Digit" #k"control-meta-3")
-(bind-key "Argument Digit" #k"control-meta-4")
-(bind-key "Argument Digit" #k"control-meta-5")
-(bind-key "Argument Digit" #k"control-meta-6")
-(bind-key "Argument Digit" #k"control-meta-7")
-(bind-key "Argument Digit" #k"control-meta-8")
-(bind-key "Argument Digit" #k"control-meta-9")
-
-
-;;;; Self Insert and Quoted Insert.
-
-(bind-key "Quoted Insert" #k"control-q")
-
-(bind-key "Self Insert" #k"space")
-(bind-key "Self Insert" #k"!")
-(bind-key "Self Insert" #k"@")
-(bind-key "Self Insert" #k"#")
-(bind-key "Self Insert" #k"$")
-(bind-key "Self Insert" #k"%")
-(bind-key "Self Insert" #k"^")
-(bind-key "Self Insert" #k"&")
-(bind-key "Self Insert" #k"*")
-(bind-key "Self Insert" #k"(")
-(bind-key "Self Insert" #k")")
-(bind-key "Self Insert" #k"_")
-(bind-key "Self Insert" #k"+")
-(bind-key "Self Insert" #k"~")
-(bind-key "Self Insert" #k"1")
-(bind-key "Self Insert" #k"2")
-(bind-key "Self Insert" #k"3")
-(bind-key "Self Insert" #k"4")
-(bind-key "Self Insert" #k"5")
-(bind-key "Self Insert" #k"6")
-(bind-key "Self Insert" #k"7")
-(bind-key "Self Insert" #k"8")
-(bind-key "Self Insert" #k"9")
-(bind-key "Self Insert" #k"0")
-(bind-key "Self Insert" #k"[")
-(bind-key "Self Insert" #k"]")
-(bind-key "Self Insert" #k"\\")
-(bind-key "Self Insert" #k"|")
-(bind-key "Self Insert" #k":")
-(bind-key "Self Insert" #k";")
-(bind-key "Self Insert" #k"\"")
-(bind-key "Self Insert" #k"'")
-(bind-key "Self Insert" #k"\-")
-(bind-key "Self Insert" #k"=")
-(bind-key "Self Insert" #k"`")
-(bind-key "Self Insert" #k"\<")
-(bind-key "Self Insert" #k"\>")
-(bind-key "Self Insert" #k",")
-(bind-key "Self Insert" #k".")
-(bind-key "Self Insert" #k"?")
-(bind-key "Self Insert" #k"/")
-(bind-key "Self Insert" #k"{")
-(bind-key "Self Insert" #k"}")
-
-
-
-;;;; Echo Area.
-
-;;; Basic echo-area commands.
-;;; 
-(bind-key "Help on Parse" #k"home" :mode "Echo Area")
-(bind-key "Help on Parse" #k"control-_" :mode "Echo Area")
-
-(bind-key "Complete Keyword" #k"escape" :mode "Echo Area")
-(bind-key "Complete Field" #k"space" :mode "Echo Area")
-(bind-key "Confirm Parse" #k"return" :mode "Echo Area")
-
-;;; Rebind some standard commands to behave better.
-;;; 
-(bind-key "Kill Parse" #k"control-u" :mode "Echo Area")
-(bind-key "Insert Parse Default" #k"control-i" :mode "Echo Area")
-(bind-key "Insert Parse Default" #k"tab" :mode "Echo Area")
-(bind-key "Echo Area Delete Previous Character" #k"delete" :mode "Echo Area")
-(bind-key "Echo Area Delete Previous Character" #k"backspace" :mode "Echo Area")
-(bind-key "Echo Area Kill Previous Word" #k"meta-h" :mode "Echo Area")
-(bind-key "Echo Area Kill Previous Word" #k"meta-delete" :mode "Echo Area")
-(bind-key "Echo Area Kill Previous Word" #k"meta-backspace" :mode "Echo Area")
-(bind-key "Echo Area Kill Previous Word" #k"control-w" :mode "Echo Area")
-(bind-key "Beginning of Parse" #k"control-a" :mode "Echo Area")
-(bind-key "Beginning of Parse" #k"meta-\<" :mode "Echo Area")
-(bind-key "Echo Area Backward Character" #k"control-b" :mode "Echo Area")
-(bind-key "Echo Area Backward Word" #k"meta-b" :mode "Echo Area")
-(bind-key "Next Parse" #k"control-n" :mode "Echo Area")
-(bind-key "Previous Parse" #k"control-p" :mode "Echo Area")
-
-;;; Remove some dangerous standard bindings.
-;;; 
-(bind-key "Illegal" #k"control-x" :mode "Echo Area")
-(bind-key "Illegal" #k"control-meta-c" :mode "Echo Area")
-(bind-key "Illegal" #k"control-meta-s" :mode "Echo Area")
-(bind-key "Illegal" #k"control-meta-l" :mode "Echo Area")
-(bind-key "Illegal" #k"meta-x" :mode "Echo Area")
-(bind-key "Illegal" #k"control-s" :mode "Echo Area")
-(bind-key "Illegal" #k"control-r" :mode "Echo Area")
-(bind-key "Illegal" #k"hyper-t" :mode "Echo Area")
-(bind-key "Illegal" #k"middledown" :mode "Echo Area")
-(bind-key "Do Nothing" #k"middleup" :mode "Echo Area")
-(bind-key "Illegal" #k"super-leftdown" :mode "Echo Area")
-(bind-key "Do Nothing" #k"super-leftup" :mode "Echo Area")
-(bind-key "Illegal" #k"super-rightdown" :mode "Echo Area")
-(bind-key "Do Nothing" #k"super-rightup" :mode "Echo Area")
-
-
-
-;;;; Eval and Editor Modes.
-
-(bind-key "Confirm Eval Input" #k"return" :mode "Eval")
-(bind-key "Previous Interactive Input" #k"meta-p" :mode "Eval")
-(bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Eval")
-(bind-key "Next Interactive Input" #k"meta-n" :mode "Eval")
-(bind-key "Kill Interactive Input" #k"meta-i" :mode "Eval")
-(bind-key "Abort Eval Input" #k"control-meta-i" :mode "Eval")
-(bind-key "Interactive Beginning of Line" #k"control-a" :mode "Eval")
-(bind-key "Reenter Interactive Input" #k"control-return" :mode "Eval")
-
-(bind-key "Editor Evaluate Expression" #k"control-meta-escape")
-(bind-key "Editor Evaluate Expression" #k"meta-escape"  :mode "Editor")
-(bind-key "Editor Evaluate Defun" #k"control-x control-e" :mode "Editor")
-(bind-key "Editor Compile Defun" #k"control-x control-c" :mode "Editor")
-(bind-key "Editor Compile Defun" #k"control-x control-C" :mode "Editor")
-(bind-key "Editor Macroexpand Expression" #k"control-m" :mode "Editor")
-(bind-key "Editor Describe Function Call" #k"control-meta-A" :mode "Editor")
-(bind-key "Editor Describe Symbol" #k"control-meta-S" :mode "Editor")
-
-
-
-;;;; Typescript.
-
-(bind-key "Confirm Typescript Input" #k"return" :mode "Typescript")
-(bind-key "Interactive Beginning of Line" #k"control-a" :mode "Typescript")
-(bind-key "Kill Interactive Input" #k"meta-i" :mode "Typescript")
-(bind-key "Previous Interactive Input" #k"meta-p" :mode "Typescript")
-(bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Typescript")
-(bind-key "Next Interactive Input" #k"meta-n" :mode "Typescript")
-(bind-key "Reenter Interactive Input" #k"control-return" :mode "Typescript")
-(bind-key "Typescript Slave Break" #k"hyper-b" :mode "Typescript")
-(bind-key "Typescript Slave to Top Level" #k"hyper-g" :mode "Typescript")
-(bind-key "Select Slave" #k"control-meta-\c")
-(bind-key "Select Background" #k"control-meta-C")
-
-(bind-key "Abort Operations" #k"hyper-a")
-(bind-key "List Operations" #k"hyper-l")
-
-(bind-key "Next Compiler Error" #k"hyper-n")
-(bind-key "Previous Compiler Error" #k"hyper-p")
-
-
-
-;;;; Lisp (some).
-
-(bind-key "Indent Form" #k"control-meta-q")
-(bind-key "Defindent" #k"control-meta-#")
-(bind-key "Beginning of Defun" #k"control-meta-[")
-(bind-key "End of Defun" #k"control-meta-]")
-(bind-key "Beginning of Defun" #k"control-meta-a")
-(bind-key "End of Defun" #k"control-meta-e")
-(bind-key "Forward Form" #k"control-meta-f")
-(bind-key "Backward Form" #k"control-meta-b")
-(bind-key "Forward List" #k"control-meta-n")
-(bind-key "Backward List" #k"control-meta-p")
-(bind-key "Transpose Forms" #k"control-meta-t")
-(bind-key "Forward Kill Form" #k"control-meta-k")
-(bind-key "Backward Kill Form" #k"control-meta-backspace")
-(bind-key "Backward Kill Form" #k"control-meta-delete")
-(bind-key "Mark Form" #k"control-meta-@")
-(bind-key "Mark Defun" #k"control-meta-h")
-(bind-key "Insert ()" #k"meta-(")
-(bind-key "Move over )" #k"meta-)")
-(bind-key "Backward Up List" #k"control-meta-(")
-(bind-key "Backward Up List" #k"control-meta-u")
-(bind-key "Forward Up List" #k"control-meta-)")
-(bind-key "Down List" #k"control-meta-d")
-(bind-key "Extract List" #k"control-meta-x")
-(bind-key "Lisp Insert )" #k")" :mode "Lisp")
-(bind-key "Delete Previous Character Expanding Tabs" #k"backspace" :mode "Lisp")
-(bind-key "Delete Previous Character Expanding Tabs" #k"delete" :mode "Lisp")
-
-(bind-key "Evaluate Expression" #k"meta-escape")
-(bind-key "Evaluate Defun" #k"control-x control-e")
-(bind-key "Compile Defun" #k"control-x control-c")
-(bind-key "Compile Buffer File" #k"control-x c")
-(bind-key "Macroexpand Expression" #k"control-M")
-
-(bind-key "Describe Function Call" #k"control-meta-A")
-(bind-key "Describe Symbol" #k"control-meta-S")
-
-(bind-key "Goto Definition" #k"control-meta-F")
-
-
-
-;;;; More Miscellaneous bindings.
-
-(bind-key "Open Line" #k"Control-o")
-(bind-key "New Line" #k"return")
-
-(bind-key "Transpose Words" #k"meta-t")
-(bind-key "Transpose Lines" #k"control-x control-t")
-(bind-key "Transpose Regions" #k"control-x t"))
-
-(bind-key "Uppercase Region" #k"control-x control-u")
-(bind-key "Lowercase Region" #k"control-x control-l")
-
-(bind-key "Delete Indentation" #k"meta-^")
-(bind-key "Delete Indentation" #k"control-meta-^")
-(bind-key "Delete Horizontal Space" #k"meta-\\")
-(bind-key "Delete Blank Lines" #k"control-x control-o" :global)
-(bind-key "Just One Space" #k"meta-\|")
-(bind-key "Back to Indentation" #k"meta-m")
-(bind-key "Back to Indentation" #k"control-meta-m")
-(bind-key "Indent Rigidly" #k"control-x tab")
-(bind-key "Indent Rigidly" #k"control-x control-i")
-
-(bind-key "Indent New Line" #k"linefeed")
-(bind-key "Indent" #k"tab")
-(bind-key "Indent" #k"control-i")
-(bind-key "Indent Region" #k"control-meta-\\")
-(bind-key "Quote Tab" #k"meta-tab")
-
-(bind-key "Directory" #k"control-x control-\d")
-(bind-key "Verbose Directory" #k"control-x control-D")
-
-(bind-key "Activate Region" #k"control-x control-@")
-(bind-key "Activate Region" #k"control-x control-space")
-
-(bind-key "Save Position" #k"control-x s")
-(bind-key "Jump to Saved Position" #k"control-x j")
-(bind-key "Put Register" #k"control-x x")
-(bind-key "Get Register" #k"control-x g")
-
-(bind-key "Delete Previous Character Expanding Tabs" #k"backspace"
-	  :mode "Pascal")
-(bind-key "Delete Previous Character Expanding Tabs" #k"delete" :mode "Pascal")
-(bind-key "Scribe Insert Bracket" #k")" :mode "Pascal")
-(bind-key "Scribe Insert Bracket" #k"]" :mode "Pascal")
-(bind-key "Scribe Insert Bracket" #k"}" :mode "Pascal")
-
-
-;;;; Auto Fill Mode.
-
-(bind-key "Fill Paragraph" #k"meta-q")
-(bind-key "Fill Region" #k"meta-g")
-(bind-key "Set Fill Prefix" #k"control-x ."))
-(bind-key "Set Fill Column" #k"control-x f")
-(bind-key "Auto Fill Return" #k"return" :mode "Fill")
-(bind-key "Auto Fill Space" #k"space" :mode "Fill")
-(bind-key "Auto Fill Linefeed" #k"linefeed" :mode "Fill")
-
-
-
-;;;; Keyboard macro bindings.
-
-(bind-key "Define Keyboard Macro" #k"control-x (")
-(bind-key "Define Keyboard Macro Key" #k"control-x meta-(")
-(bind-key "End Keyboard Macro" #k"control-x )")
-(bind-key "End Keyboard Macro" #k"control-x hyper-)")
-(bind-key "Last Keyboard Macro" #k"control-x e")
-(bind-key "Keyboard Macro Query" #k"control-x q")
-
-
-
-;;;; Spell bindings.
-
-(bind-key "Check Word Spelling" #k"meta-$")
-(bind-key "Add Word to Spelling Dictionary" #k"control-x $")
-
-(dolist (info (command-bindings (getstring "Self Insert" *command-names*)))
-  (let* ((key (car info))
-	 (key-event (svref key 0))
-	 (character (key-event-char key-event)))
-    (unless (or (alpha-char-p character) (eq key-event #k"'"))
-      (bind-key "Auto Check Word Spelling" key :mode "Spell"))))
-(bind-key "Auto Check Word Spelling" #k"return" :mode "Spell")
-(bind-key "Auto Check Word Spelling" #k"tab" :mode "Spell")
-(bind-key "Auto Check Word Spelling" #k"linefeed" :mode "Spell")
-(bind-key "Correct Last Misspelled Word" #k"meta-:")
-(bind-key "Undo Last Spelling Correction" #k"control-x a")
-
-
-
-;;;; Overwrite Mode.
-
-(bind-key "Overwrite Delete Previous Character" #k"delete" :mode "Overwrite")
-(bind-key "Overwrite Delete Previous Character" #k"backspace" :mode "Overwrite")
-
-;;; Do up the printing characters ...
-(do ((i 33 (1+ i)))
-    ((= i 126))
-  (let ((key-event (char-key-event (code-char i))))
-    (bind-key "Self Overwrite" key-event :mode "Overwrite")))
-
-(bind-key "Self Overwrite" #k"space" :mode "Overwrite")
-
-
-
-;;;; Comment bindings.
-
-(bind-key "Indent for Comment" #k"meta-;")
-(bind-key "Set Comment Column" #k"control-x ;")
-(bind-key "Kill Comment" #k"control-meta-;")
-(bind-key "Down Comment Line" #k"meta-n")
-(bind-key "Up Comment Line" #k"meta-p")
-(bind-key "Indent New Comment Line" #k"meta-j")
-(bind-key "Indent New Comment Line" #k"meta-linefeed")
-
-
-;;;; Word Abbrev Mode.
-
-(bind-key "Add Mode Word Abbrev" #k"control-x control-a")
-(bind-key "Add Global Word Abbrev" #k"control-x +")
-(bind-key "Inverse Add Mode Word Abbrev" #k"control-x control-h")
-(bind-key "Inverse Add Global Word Abbrev" #k"control-x \-")
-;; Removed in lieu of "Pop and Goto Mark".
-;;(bind-key "Abbrev Expand Only" #k"meta-space")
-(bind-key "Word Abbrev Prefix Mark" #k"meta-\"")
-(bind-key "Unexpand Last Word" #k"control-x u")
-
-(dolist (key (list #k"!" #k"~" #k"@" #k"#" #k";" #k"$" #k"%" #k"^" #k"&" #k"*"
-		   #k"\-" #k"_" #k"=" #k"+" #k"[" #k"]" #k"(" #k")" #k"/" #k"|"
-		   #k":" #k"'" #k"\"" #k"{" #k"}" #k"," #k"\<" #k"." #k"\>"
-		   #k"`" #k"\\" #k"?" #k"return" #k"newline" #k"tab" #k"space"))
-  (bind-key "Abbrev Expand Only" key :mode "Abbrev"))
-
-
-
-;;;; Scribe Mode.
-
-(dolist (key (list #k"]" #k")" #k"}" #k"\>"))
-  (bind-key "Scribe Insert Bracket" key :mode "Scribe"))
-
-(bind-key "Scribe Buffer File" #k"control-x c" :mode "Scribe")
-(bind-key "Select Scribe Warnings" #k"control-meta-C" :mode "Scribe")
-
-(bind-key "Insert Scribe Directive" #k"hyper-i" :mode "Scribe")
-
-
-
-;;;; X commands:
-
-(bind-key "Insert Cut Buffer" #k"insert")
-(bind-key "Region to Cut Buffer" #k"meta-insert")
-
-
-
-;;;; Mailer commands.
-
-(do-alpha-key-events (key-event :both)
-  (bind-key "Illegal" key-event :mode "Headers")
-  (bind-key "Illegal" key-event :mode "Message"))
-
-
-;;; Global.
-
-(bind-key "Incorporate and Read New Mail" #k"control-x i")
-(bind-key "Send Message" #k"control-x m")
-(bind-key "Message Headers" #k"control-x r")
-
-
-;;; Both Headers and Message modes.
-;;;
-;;; The bindings in these two blocks should be the same, one for "Message" mode
-;;; and one for "Headers" mode.
-;;;
-
-(bind-key "Next Message" #k"meta-n" :mode "Message")
-(bind-key "Previous Message" #k"meta-p" :mode "Message")
-(bind-key "Next Undeleted Message" #k"n" :mode "Message")
-(bind-key "Previous Undeleted Message" #k"p" :mode "Message")
-(bind-key "Send Message" #k"s" :mode "Message")
-(bind-key "Send Message" #k"m" :mode "Message")
-(bind-key "Forward Message" #k"f" :mode "Message")
-(bind-key "Headers Delete Message" #k"k" :mode "Message")
-(bind-key "Headers Undelete Message" #k"u" :mode "Message")
-(bind-key "Headers Refile Message" #k"o" :mode "Message")
-(bind-key "List Mail Buffers" #k"l" :mode "Message")
-(bind-key "Quit Headers" #k"q" :mode "Message")
-(bind-key "Incorporate and Read New Mail" #k"i" :mode "Message")
-(bind-key "Beginning of Buffer" #k"\<" :mode "Message")
-(bind-key "End of Buffer" #k"\>" :mode "Message")
-
-(bind-key "Next Message" #k"meta-n" :mode "Headers")
-(bind-key "Previous Message" #k"meta-p" :mode "Headers")
-(bind-key "Next Undeleted Message" #k"n" :mode "Headers")
-(bind-key "Previous Undeleted Message" #k"p" :mode "Headers")
-(bind-key "Send Message" #k"s" :mode "Headers")
-(bind-key "Send Message" #k"m" :mode "Headers")
-(bind-key "Forward Message" #k"f" :mode "Headers")
-(bind-key "Headers Delete Message" #k"k" :mode "Headers")
-(bind-key "Headers Undelete Message" #k"u" :mode "Headers")
-(bind-key "Headers Refile Message" #k"o" :mode "Headers")
-(bind-key "List Mail Buffers" #k"l" :mode "Headers")
-(bind-key "Quit Headers" #k"q" :mode "Headers")
-(bind-key "Incorporate and Read New Mail" #k"i" :mode "Headers")
-(bind-key "Beginning of Buffer" #k"\<" :mode "Headers")
-(bind-key "End of Buffer" #k"\>" :mode "Headers")
-
-
-;;; Headers mode.
-
-(bind-key "Delete Message and Down Line" #k"d" :mode "Headers")
-(bind-key "Pick Headers" #k"h" :mode "Headers")
-(bind-key "Show Message" #k"space" :mode "Headers")
-(bind-key "Show Message" #k"." :mode "Headers")
-(bind-key "Reply to Message" #k"r" :mode "Headers")
-(bind-key "Expunge Messages" #k"!" :mode "Headers")
-(bind-key "Headers Help" #k"?" :mode "Headers")
-
-
-;;; Message mode.
-
-(bind-key "Delete Message and Show Next" #k"d" :mode "Message")
-(bind-key "Goto Headers Buffer" #k"^" :mode "Message")
-(bind-key "Scroll Message" #k"space" :mode "Message")
-(bind-key "Scroll Message" #k"control-v" :mode "Message")
-(bind-key "Scroll Window Up" #k"backspace" :mode "Message")
-(bind-key "Scroll Window Up" #k"delete" :mode "Message")
-(bind-key "Reply to Message in Other Window" #k"r" :mode "Message")
-(bind-key "Edit Message Buffer" #k"e" :mode "Message")
-(bind-key "Insert Message Region" #k"hyper-y" :mode "Message")
-(bind-key "Message Help" #k"?" :mode "Message")
-
-
-;;; Draft mode.
-
-(bind-key "Goto Headers Buffer" #k"hyper-^" :mode "Draft")
-(bind-key "Goto Message Buffer" #k"hyper-m" :mode "Draft")
-(bind-key "Deliver Message" #k"hyper-s" :mode "Draft")
-(bind-key "Deliver Message" #k"hyper-c" :mode "Draft")
-(bind-key "Insert Message Buffer" #k"hyper-y" :mode "Draft")
-(bind-key "Delete Draft and Buffer" #k"hyper-q" :mode "Draft")
-(bind-key "List Mail Buffers" #k"hyper-l" :mode "Draft")
-(bind-key "Draft Help" #k"hyper-?" :mode "Draft")
-
-
-
-;;;; Process (Shell).
-
-(bind-key "Confirm Process Input" #k"return" :mode "Process")
-(bind-key "Shell" #k"control-meta-s")
-(bind-key "Interrupt Buffer Subprocess" #k"hyper-c" :mode "Process")
-(bind-key "Stop Buffer Subprocess" #k"hyper-z" :mode "Process")
-(bind-key "Quit Buffer Subprocess" #k"hyper-\\")
-(bind-key "Send EOF to Process" #k"hyper-d")
-
-(bind-key "Previous Interactive Input" #k"meta-p" :mode "Process")
-(bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Process")
-(bind-key "Interactive Beginning of Line" #k"control-a" :mode "Process")
-(bind-key "Kill Interactive Input" #k"meta-i" :mode "Process")
-(bind-key "Next Interactive Input" #k"meta-n" :mode "Process")
-(bind-key "Reenter Interactive Input" #k"control-return" :mode "Process")
-
-
-
-;;;; Bufed.
-
-(bind-key "Bufed" #k"control-x control-meta-b"))
-(bind-key "Bufed Delete" #k"d" :mode "Bufed")
-(bind-key "Bufed Delete" #k"control-d" :mode "Bufed")
-(bind-key "Bufed Undelete" #k"u" :mode "Bufed")
-(bind-key "Bufed Expunge" #k"!" :mode "Bufed")
-(bind-key "Bufed Quit" #k"q" :mode "Bufed")
-(bind-key "Bufed Goto" #k"space" :mode "Bufed")
-(bind-key "Bufed Goto and Quit" #k"super-leftdown" :mode "Bufed")
-(bind-key "Bufed Save File" #k"s" :mode "Bufed")
-(bind-key "Next Line" #k"n" :mode "Bufed")
-(bind-key "Previous Line" #k"p" :mode "Bufed")
-
-
-(bind-key "Bufed Help" #k"?" :mode "Bufed")
-
-
-
-;;;; Dired.
-
-(bind-key "Dired" #k"control-x control-meta-d"))
-
-(bind-key "Dired Delete File and Down Line" #k"d" :mode "Dired")
-(bind-key "Dired Delete File with Pattern" #k"D" :mode "Dired")
-(bind-key "Dired Delete File" #k"control-d" :mode "Dired")
-(bind-key "Dired Delete File" #k"k" :mode "Dired")
-
-(bind-key "Dired Undelete File and Down Line" #k"u" :mode "Dired")
-(bind-key "Dired Undelete File with Pattern" #k"U" :mode "Dired")
-(bind-key "Dired Undelete File" #k"control-u" :mode "Dired")
-
-(bind-key "Dired Expunge Files" #k"!" :mode "Dired")
-(bind-key "Dired Update Buffer" #k"hyper-u" :mode "Dired")
-(bind-key "Dired View File" #k"space" :mode "Dired")
-(bind-key "Dired Edit File" #k"e" :mode "Dired")
-(bind-key "Dired Up Directory" #k"^" :mode "Dired")
-(bind-key "Dired Quit" #k"q" :mode "Dired")
-(bind-key "Dired Help" #k"?" :mode "Dired")
-
-(bind-key "Dired Copy File" #k"c" :mode "Dired")
-(bind-key "Dired Copy with Wildcard" #k"C" :mode "Dired")
-(bind-key "Dired Rename File" #k"r" :mode "Dired")
-(bind-key "Dired Rename with Wildcard" #k"R" :mode "Dired")
-
-(bind-key "Next Line" #k"n" :mode "Dired")
-(bind-key "Previous Line" #k"p" :mode "Dired")
-
-
-
-;;;; View Mode.
-
-(bind-key "View Scroll Down" #k"space" :mode "View")
-(bind-key "Scroll Window Up" #k"b" :mode "View")
-(bind-key "Scroll Window Up" #k"backspace" :mode "View")
-(bind-key "Scroll Window Up" #k"delete" :mode "View")
-(bind-key "View Return" #k"^" :mode "View")
-(bind-key "View Quit" #k"q" :mode "View")
-(bind-key "View Edit File" #k"e" :mode "View")
-(bind-key "View Help" #k"?" :mode "View")
-(bind-key "Beginning of Buffer" #k"\<" :mode "View")
-(bind-key "End of Buffer" #k"\>" :mode "View")
-
-
-
-;;;; Lisp Library.
-
-
-(bind-key "Describe Pointer Library Entry" #k"leftdown" :mode "Lisp-Lib")
-(bind-key "Load Pointer Library Entry" #k"rightdown" :mode "Lisp-Lib")
-(bind-key "Describe Library Entry" #k"space" :mode "Lisp-Lib")
-(bind-key "Load Library Entry" #k"l" :mode "Lisp-Lib")
-(bind-key "Exit Lisp Library" #k"q" :mode "Lisp-Lib")
-(bind-key "Lisp Library Help" #k"?" :mode "Lisp-Lib")
-
-
-
-;;;; Completion mode.
-
-(dolist (c (command-bindings (getstring "Self Insert" *command-names*)))
-  (bind-key "Completion Self Insert" (car c) :mode "Completion"))
-
-(bind-key "Completion Self Insert" #k"space" :mode "Completion")
-(bind-key "Completion Self Insert" #k"tab" :mode "Completion")
-(bind-key "Completion Self Insert" #k"return" :mode "Completion")
-(bind-key "Completion Self Insert" #k"linefeed" :mode "Completion")
-
-(bind-key "Completion Complete Word" #k"end")
-(bind-key "Completion Rotate Completions" #k"meta-end")
-
-
-
-;;;; Caps-Lock mode.
-
-(do-alpha-key-events (key-event :lower)
-  (bind-key "Self Insert Caps Lock" key-event :mode "CAPS-LOCK"))
-
-
-
-;;;; Logical characters.
-
-(setf (logical-key-event-p #k"control-s" :forward-search) t)
-(setf (logical-key-event-p #k"control-r" :backward-search) t)
-(setf (logical-key-event-p #k"control-r" :recursive-edit) t)
-(setf (logical-key-event-p #k"delete" :cancel) t)
-(setf (logical-key-event-p #k"backspace" :cancel) t)
-(setf (logical-key-event-p #k"control-g" :abort) t)
-(setf (logical-key-event-p #k"escape" :exit) t)
-(setf (logical-key-event-p #k"y" :yes) t)
-(setf (logical-key-event-p #k"space" :yes) t)
-(setf (logical-key-event-p #k"n" :no) t)
-(setf (logical-key-event-p #k"backspace" :no) t)
-(setf (logical-key-event-p #k"delete" :no) t)
-(setf (logical-key-event-p #k"!" :do-all) t)
-(setf (logical-key-event-p #k"." :do-once) t)
-(setf (logical-key-event-p #k"home" :help) t)
-(setf (logical-key-event-p #k"h" :help) t)
-(setf (logical-key-event-p #k"?" :help) t)
-(setf (logical-key-event-p #k"control-_" :help) t)
-(setf (logical-key-event-p #k"return" :confirm) t)
-(setf (logical-key-event-p #k"control-q" :quote) t)
-(setf (logical-key-event-p #k"k" :keep) t)
diff --git a/hemlock/bit-display.lisp b/hemlock/bit-display.lisp
deleted file mode 100644
index 78817db727573eaae4515608c0b0f8c7b1528e38..0000000000000000000000000000000000000000
--- a/hemlock/bit-display.lisp
+++ /dev/null
@@ -1,293 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/bit-display.lisp,v 1.2 1991/02/08 16:32:53 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Rob MacLachlan
-;;;    Modified by Bill Chiles to run under X on IBM RT's.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(redisplay redisplay-all))
-
-
-
-;;; prepare-window-for-redisplay  --  Internal
-;;;
-;;;    Called by make-window to do whatever redisplay wants to set up
-;;; a new window.
-;;;
-(defun prepare-window-for-redisplay (window)
-  (setf (window-old-lines window) 0))
-
-
-
-;;;; Dumb window redisplay.
-
-;;; DUMB-WINDOW-REDISPLAY redraws an entire window using dumb-line-redisplay.
-;;; This assumes the cursor has been lifted if necessary.
-;;;
-(defun dumb-window-redisplay (window)
-  (let* ((hunk (window-hunk window))
-	 (first (window-first-line window)))
-    (hunk-reset hunk)
-    (do ((i 0 (1+ i))
-	 (dl (cdr first) (cdr dl)))
-	((eq dl the-sentinel)
-	 (setf (window-old-lines window) (1- i)))
-      (dumb-line-redisplay hunk (car dl)))
-    (setf (window-first-changed window) the-sentinel
-	  (window-last-changed window) first)
-    (when (window-modeline-buffer window)
-      (hunk-replace-modeline hunk)
-      (setf (dis-line-flags (window-modeline-dis-line window))
-	    unaltered-bits))
-    (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))))
-
-
-;;; DUMB-LINE-REDISPLAY is used when the line is known to be cleared already.
-;;;
-(defun dumb-line-redisplay (hunk dl)
-  (hunk-write-line hunk dl)
-  (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0))
-
-
-
-;;;; Smart window redisplay.
-
-;;; We scan through the changed dis-lines, and condense the information
-;;; obtained into five categories: Unchanged lines moved down, unchanged
-;;; lines moved up, lines that need to be cleared, lines that are in the
-;;; same place (but changed), and new or moved-and-changed lines to write.
-;;; Each such instance of a thing that needs to be done is remembered be
-;;; throwing needed information on a stack specific to the thing to be
-;;; done.  We cannot do any of these things right away because each may
-;;; confict with the previous.
-;;; 
-;;; Each stack is represented by a simple-vector big enough to hold the
-;;; worst-case number of entries and a pointer to the next free entry.  The
-;;; pointers are local variables returned from COMPUTE-CHANGES and used by
-;;; SMART-WINDOW-REDISPLAY.  Note that the order specified in these tuples
-;;; is the order in which they were pushed.
-;;; 
-(defvar *display-down-move-stack* (make-array (* hunk-height-limit 2))
-  "This is the vector that we stash info about which lines moved down in
-  as (Start, End, Count) triples.")
-(defvar *display-up-move-stack* (make-array (* hunk-height-limit 2))
-  "This is the vector that we stash info about which lines moved up in
-  as (Start, End, Count) triples.")
-(defvar *display-erase-stack* (make-array hunk-height-limit)
-  "This is the vector that we stash info about which lines need to be erased
-  as (Start, Count) pairs.")
-(defvar *display-write-stack* (make-array hunk-height-limit)
-  "This is the vector that we stash dis-lines in that need to be written.")
-(defvar *display-rewrite-stack* (make-array hunk-height-limit)
-  "This is the vector that we stash dis-lines in that need to be written.
-  with clear-to-end.")
-
-;;; Accessor macros to push and pop on the stacks:
-;;;
-(eval-when (compile eval)
-
-(defmacro spush (thing stack stack-pointer)
-  `(progn
-    (setf (svref ,stack ,stack-pointer) ,thing)
-    (incf ,stack-pointer)))
-
-(defmacro spop (stack stack-pointer)
-  `(svref ,stack (decf ,stack-pointer)))
-
-(defmacro snext (stack stack-pointer)
-  `(prog1 (svref ,stack ,stack-pointer) (incf ,stack-pointer)))
-
-); eval-when (compile eval)
-
-
-;;; SMART-WINDOW-REDISPLAY only re-writes lines which may have been changed,
-;;; and updates them with smart-line-redisplay if not very much has changed.
-;;; Lines which have moved are copied.  We must be careful not to redisplay
-;;; the window with the cursor down since it is not guaranteed to be out of
-;;; the way just because we are in redisplay; LIFT-CURSOR is called just before
-;;; the screen may be altered, and it takes care to know whether the cursor
-;;; is lifted already or not.  At the end, if the cursor had been down,
-;;; DROP-CURSOR puts it back; it doesn't matter if LIFT-CURSOR was never called
-;;; since it does nothing if the cursor is already down.
-;;; 
-(defun smart-window-redisplay (window)
-  (let* ((hunk (window-hunk window))
-	 (liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*)))
-    (when (bitmap-hunk-trashed hunk)
-      (when liftp (lift-cursor))
-      (dumb-window-redisplay window)
-      (when liftp (drop-cursor))
-      (return-from smart-window-redisplay nil))
-    (let ((first-changed (window-first-changed window))
-	  (last-changed (window-last-changed window)))
-      ;; Is there anything to do?
-      (unless (eq first-changed the-sentinel)
-	(when liftp (lift-cursor))
-	(if (and (eq first-changed last-changed)
-		 (zerop (dis-line-delta (car first-changed))))
-	    ;; One line changed.
-	    (smart-line-redisplay hunk (car first-changed))
-	    ;; More than one line changed.
-	    (multiple-value-bind (up down erase write rewrite)
-				 (compute-changes first-changed last-changed)
-	      (do-down-moves hunk down)
-	      (do-up-moves hunk up)
-	      (do-erases hunk erase)
-	      (do-writes hunk write)
-	      (do-rewrites hunk rewrite)))
-	;; Set the bounds so we know we displayed...
-	(setf (window-first-changed window) the-sentinel
-	      (window-last-changed window) (window-first-line window))))
-    ;;
-    ;; Clear any extra lines at the end of the window.
-    (let ((pos (dis-line-position (car (window-last-line window)))))
-      (when (< pos (window-old-lines window))
-	(when liftp (lift-cursor))
-	(hunk-clear-lines hunk (1+ pos) (- (window-height window) pos 1)))
-      (setf (window-old-lines window) pos))
-    ;;
-    ;; Update the modeline if needed.
-    (when (window-modeline-buffer window)
-      (when (/= (dis-line-flags (window-modeline-dis-line window))
-		unaltered-bits)
-	(hunk-replace-modeline hunk)
-	(setf (dis-line-flags (window-modeline-dis-line window))
-	      unaltered-bits)))
-    ;;
-    (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))
-    (when liftp (drop-cursor))))
-
-;;; COMPUTE-CHANGES is used once in smart-window-redisplay, and it scans
-;;; through the changed dis-lines in a window, computes the changes needed
-;;; to bring the screen into corespondence, and throws the information
-;;; needed to do the change onto the apropriate stack.  The pointers into
-;;; the stacks (up, down, erase, write, and rewrite) are returned.
-;;; 
-;;; The algorithm is as follows:
-;;; 1] If the line is moved-and-changed or new then throw the line on
-;;; the write stack and increment the clear count.  Repeat until no more
-;;; such lines are found.
-;;; 2] If the line is moved then flush any pending clear, find how many
-;;; consecutive lines are moved the same amount, and put the numbers
-;;; on the correct move stack.
-;;; 3] If the line is changed and unmoved throw it on a write stack.
-;;; If a clear is pending throw it in the write stack and bump the clear
-;;; count, otherwise throw it on the rewrite stack.
-;;; 4] The line is unchanged, do nothing.
-;;;
-(defun compute-changes (first-changed last-changed)
-  (let* ((dl first-changed)
-	 (flags (dis-line-flags (car dl)))
-	 (up 0) (down 0) (erase 0) (write 0) (rewrite 0) ;return values.
-	 (clear-count 0)
-	 prev clear-start)
-    (declare (fixnum up down erase write rewrite clear-count))
-    (loop
-      (cond
-       ;; Line moved-and-changed or new.
-       ((> flags moved-bit)
-	(when (zerop clear-count)
-	  (setq clear-start (dis-line-position (car dl))))
-	(loop
-	  (setf (dis-line-delta (car dl)) 0)
-	  (spush (car dl) *display-write-stack* write)
-	  (incf clear-count)
-	  (setq prev dl  dl (cdr dl)  flags (dis-line-flags (car dl)))
-	  (when (<= flags moved-bit) (return nil))))
-       ;; Line moved, unchanged.
-       ((= flags moved-bit)
-	(unless (zerop clear-count)
-	  (spush clear-count *display-erase-stack* erase)
-	  (spush clear-start *display-erase-stack* erase)
-	  (setq clear-count 0))
-	(do ((delta (dis-line-delta (car dl)))
-	     (end (dis-line-position (car dl)))
-	     (count 1 (1+ count)))
-	    (())
-	  (setf (dis-line-delta (car dl)) 0
-		(dis-line-flags (car dl)) unaltered-bits)
-	  (setq prev dl  dl (cdr dl)  flags (dis-line-flags (car dl)))
-	  (when (or (/= (dis-line-delta (car dl)) delta) (/= flags moved-bit))
-	    ;; We push in different order because we pop in different order.
-	    (cond
-	     ((minusp delta)
-	      (spush (- end delta) *display-up-move-stack* up)
-	      (spush end *display-up-move-stack* up)
-	      (spush count *display-up-move-stack* up))
-	     (t
-	      (spush count *display-down-move-stack* down)
-	      (spush end *display-down-move-stack* down)
-	      (spush (- end delta) *display-down-move-stack* down)))
-	    (return nil))))
-       ;; Line changed, unmoved.
-       ((= flags changed-bit)
-	(cond ((zerop clear-count)
-	       (spush (car dl) *display-rewrite-stack* rewrite))
-	      (t
-	       (spush (car dl) *display-write-stack* write)
-	       (incf clear-count)))
-	(setq prev dl  dl (cdr dl)  flags (dis-line-flags (car dl))))
-       ;; Line unmoved, unchanged.
-       (t
-	(unless (zerop clear-count)
-	  (spush clear-count *display-erase-stack* erase)
-	  (spush clear-start *display-erase-stack* erase)
-	  (setq clear-count 0))
-	(setq prev dl  dl (cdr dl)  flags (dis-line-flags (car dl)))))
-     
-     (when (eq prev last-changed)
-       ;; If done flush any pending clear.
-       (unless (zerop clear-count)
-	 (spush clear-count *display-erase-stack* erase)
-	 (spush clear-start *display-erase-stack* erase))
-       (return (values up down erase write rewrite))))))
-
-(defun do-up-moves (hunk up)
-  (do ((i 0))
-      ((= i up))
-    (hunk-copy-lines hunk (snext *display-up-move-stack* i)
-		     (snext *display-up-move-stack* i)
-		     (snext *display-up-move-stack* i))))
-
-(defun do-down-moves (hunk down)
-  (do ()
-      ((zerop down))
-    (hunk-copy-lines hunk (spop *display-down-move-stack* down)
-		     (spop *display-down-move-stack* down)
-		     (spop *display-down-move-stack* down))))
-
-(defun do-erases (hunk erase)
-  (do ()
-      ((zerop erase))
-    (hunk-clear-lines hunk (spop *display-erase-stack* erase)
-		      (spop *display-erase-stack* erase))))
-
-(defun do-writes (hunk write)
-  (do ((i 0))
-      ((= i write))
-    (dumb-line-redisplay hunk (snext *display-write-stack* i))))
-
-(defun do-rewrites (hunk rewrite)
-  (do ()
-      ((zerop rewrite))
-    (smart-line-redisplay hunk (spop *display-rewrite-stack* rewrite))))
-
-
-;;; SMART-LINE-REDISPLAY is called when the screen is mostly the same,
-;;; clear to eol after we write it to avoid annoying flicker.
-;;;
-(defun smart-line-redisplay (hunk dl)
-  (hunk-replace-line hunk dl)
-  (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0))
diff --git a/hemlock/bit-screen.lisp b/hemlock/bit-screen.lisp
deleted file mode 100644
index 6f24bd135e2406572447252bfc98ebeed9f8542c..0000000000000000000000000000000000000000
--- a/hemlock/bit-screen.lisp
+++ /dev/null
@@ -1,1809 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/bit-screen.lisp,v 1.13 1991/11/23 21:48:32 chiles Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Screen allocation functions.
-;;;
-;;; This is the screen management and event handlers for Hemlock under X.
-;;;
-;;; Written by Bill Chiles, Rob MacLachlan, and Blaine Burks.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(make-xwindow-like-hwindow *create-window-hook* *delete-window-hook*
-	  *random-typeout-hook* *create-initial-windows-hook*))
-
-
-(proclaim '(special *echo-area-window*))
-
-;;; We have an internal notion of window groups on bitmap devices.  Every
-;;; Hemlock window has a hunk slot which holds a structure with information
-;;; about physical real-estate on some device.  Bitmap-hunks have an X window
-;;; and a window-group.  The X window is a child of the window-group's window.
-;;; The echo area, pop-up display window, and the initial window are all in
-;;; their own group.
-;;;
-;;; MAKE-WINDOW splits the current window which is some child window in a group.
-;;; If the user supplied an X window, it becomes the parent window of some new
-;;; group, and we make a child for the Hemlock window.  If the user supplies
-;;; ask-user, we prompt for a group/parent window.  We link the hunks for
-;;; NEXT-WINDOW and PREVIOUS-WINDOW only within a group, so the group maintains
-;;; a stack of windows that always fill the entire group window.
-;;;
-
-;;; This is the object set for Hemlock windows.  All types of incoming
-;;; X events on standard editing windows have the same handlers via this set.
-;;; We also include the group/parent windows in here, but they only handle
-;;; :configure-notify events.
-;;;
-(defvar *hemlock-windows*
-  (system:make-object-set "Hemlock Windows" #'ext:default-clx-event-handler))
-
-
-
-;;;; Some window making parameters.
-
-;;; These could be parameters, but they have to be set after the display is
-;;; opened.  These are set in INIT-BITMAP-SCREEN-MANAGER.
-
-(defvar *default-background-pixel* nil
-  "Default background color.  It defaults to white.")
-  
-(defvar *default-foreground-pixel* nil
-  "Default foreground color.  It defaults to black.")
-
-(defvar *foreground-background-xor* nil
-  "The LOGXOR of *default-background-pixel* and *default-foreground-pixel*.")
-
-(defvar *default-border-pixmap* nil
-  "This is the default color of X window borders.  It defaults to a
-  grey pattern.")
-
-(defvar *highlight-border-pixmap* nil
-  "This is the color of the border of the current window when the mouse
-  cursor is over any Hemlock window.")
-
-
-
-;;;; Exposed region handling.
-
-;;; :exposure events are sent because we selected them.  :graphics-exposure
-;;; events are generated because of a slot in our graphics contexts.  These are
-;;; generated from using XLIB:COPY-AREA when the source could not be generated.
-;;; Also, :no-exposure events are sent when a :graphics-exposure event could
-;;; have been sent but wasn't.
-;;;
-#|
-;;; This is an old handler that doesn't do anything clever about multiple
-;;; exposures.
-(defun hunk-exposed-region (hunk &key y height &allow-other-keys)
-  (if (bitmap-hunk-lock hunk)
-      (setf (bitmap-hunk-trashed hunk) t)
-      (let ((liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*)))
-	(when liftp (lift-cursor))
-	;; (hunk-draw-top-border hunk)
-	(let* ((font-family (bitmap-hunk-font-family hunk))
-	       (font-height (font-family-height font-family))
-	       (co (font-family-cursor-y-offset font-family))
-	       (start (truncate (- y hunk-top-border) font-height))
-	       (end (ceiling (- (+ y height) hunk-top-border) font-height))
-	       (start-bit (+ (* start font-height) co hunk-top-border))
-	       (nheight (- (* (- end start) font-height) co))
-	       (end-line (bitmap-hunk-end hunk)))
-	  (declare (fixnum font-height co start end start-bit nheight))
-	  (xlib:clear-area (bitmap-hunk-xwindow hunk) :x 0 :y start-bit
-			   :width (bitmap-hunk-width hunk) :height nheight)
-	  (do ((dl (bitmap-hunk-start hunk) (cdr dl))
-	       (i 0 (1+ i)))
-	      ((or (eq dl end-line) (= i start))
-	       (do ((i i (1+ i))
-		    (dl dl (cdr dl)))
-		   ((or (eq dl end-line) (= i end)))
-		 (declare (fixnum i))
-		 (hunk-write-line hunk (car dl) i)))
-	    (declare (fixnum i)))
-	  (when (and (bitmap-hunk-modeline-pos hunk)
-		     (>= (the fixnum (+ nheight start-bit))
-			 (the fixnum (bitmap-hunk-modeline-pos hunk))))
-	    (hunk-replace-modeline hunk)))
-	(when liftp (drop-cursor)))))
-|#
-
-;;; HUNK-EXPOSED-REGION redisplays the appropriate rectangle from the hunk
-;;; dis-lines.  Don't do anything if the hunk is trashed since redisplay is
-;;; probably about to fix everything; specifically, this keeps new windows
-;;; from getting drawn twice (once for the exposure and once for being trashed).
-;;;
-;;; Exposure and graphics-exposure events pass in a different number of
-;;; arguments, with some the same but in a different order, so we just bind
-;;; and ignore foo, bar, baz, and quux.
-;;;
-(defun hunk-exposed-region (hunk event-key event-window x y width height
-				 foo bar &optional baz quux)
-  (declare (ignore event-key event-window x width foo bar baz quux))
-  (unless (bitmap-hunk-trashed hunk)
-    (let ((liftp (and (eq *cursor-hunk* hunk) *cursor-dropped*))
-	  (display (bitmap-device-display (device-hunk-device hunk))))
-      (when liftp (lift-cursor))
-      (multiple-value-bind (y-peek height-peek)
-			   (exposed-region-peek-event display
-						      (bitmap-hunk-xwindow hunk))
-	(if y-peek
-	    (let ((n (coelesce-exposed-regions hunk display
-					       y height y-peek height-peek)))
-	      (write-n-exposed-regions hunk n))
-	    (write-one-exposed-region hunk y height)))
-      (xlib:display-force-output display)
-      (when liftp (drop-cursor)))))
-;;;
-(ext:serve-exposure *hemlock-windows* #'hunk-exposed-region)
-(ext:serve-graphics-exposure *hemlock-windows* #'hunk-exposed-region)
-
-
-;;; HUNK-NO-EXPOSURE handles this bullshit event that gets sent without its
-;;; being requested.
-;;;
-(defun hunk-no-exposure (hunk event-key event-window major minor send-event-p)
-  (declare (ignore hunk event-key event-window major minor send-event-p))
-  t)
-;;;
-(ext:serve-no-exposure *hemlock-windows* #'hunk-no-exposure)
-
-
-;;; EXPOSED-REGION-PEEK-EVENT returns the position and height of an :exposure
-;;; or :graphics-exposure event on win if one exists.  If there are none, then
-;;; nil and nil are returned.
-;;; 
-(defun exposed-region-peek-event (display win)
-  (xlib:display-finish-output display)
-  (let ((result-y nil)
-	(result-height nil))
-    (xlib:process-event
-     display :timeout 0
-     :handler #'(lambda (&key event-key event-window window y height
-			      &allow-other-keys)
-		  (cond ((and (or (eq event-key :exposure)
-				  (eq event-key :graphics-exposure))
-			      (or (eq event-window win) (eq window win)))
-			 (setf result-y y)
-			 (setf result-height height)
-			 t)
-			(t nil))))
-    (values result-y result-height)))
-
-;;; COELESCE-EXPOSED-REGIONS insert sorts exposed region events from the X
-;;; input queue into *coelesce-buffer*.  Then the regions are merged into the
-;;; same number or fewer regions that are vertically distinct
-;;; (non-overlapping).  When this function is called, one event has already
-;;; been popped from the queue, the first event that caused HUNK-EXPOSED-REGION
-;;; to be called.  That information is passed in as y1 and height1.  There is
-;;; a second event that also has already been popped from the queue, the
-;;; event resulting from peeking for multiple "exposure" events.  That info
-;;; is passed in as y2 and height2.
-;;;
-(defun coelesce-exposed-regions (hunk display y1 height1 y2 height2)
-  (let ((len 0))
-    (declare (fixnum len))
-    ;;
-    ;; Insert sort the exposeevents as we pick them off the event queue.
-    (let* ((font-family (bitmap-hunk-font-family hunk))
-	   (font-height (font-family-height font-family))
-	   (co (font-family-cursor-y-offset font-family))
-	   (xwindow (bitmap-hunk-xwindow hunk)))
-      ;;
-      ;; Insert the region the exposedregion handler was called on.
-      (multiple-value-bind (start-line start-bit end-line expanded-height)
-			   (exposed-region-bounds y1 height1 co font-height)
-	(setf len
-	      (coelesce-buffer-insert start-bit start-line
-				      expanded-height end-line len)))
-      ;;
-      ;; Peek for exposedregion events on xwindow, inserting them into
-      ;; the buffer.
-      (let ((y y2)
-	    (height height2))
-	(loop
-	  (multiple-value-bind (start-line start-bit end-line expanded-height)
-			       (exposed-region-bounds y height co font-height)
-	    (setf len
-		  (coelesce-buffer-insert start-bit start-line
-					  expanded-height end-line len)))
-	  (multiple-value-setq (y height)
-	    (exposed-region-peek-event display xwindow))
-	  (unless y (return)))))
-    (coelesce-exposed-regions-merge len)))
-
-;;; *coelesce-buffer* is a vector of records used to sort exposure events on a
-;;; single hunk, so we can merge them into fewer, larger regions of exposure.
-;;; COELESCE-BUFFER-INSERT places elements in this buffer, and each element
-;;; is referenced with COELESCE-BUFFER-ELT.  Each element of the coelescing
-;;; buffer has the following accessors defined:
-;;;    COELESCE-BUFFER-ELT-START	in pixels.
-;;;    COELESCE-BUFFER-ELT-START-LINE	in dis-lines.
-;;;    COELESCE-BUFFER-ELT-HEIGHT	in pixels.
-;;;    COELESCE-BUFFER-ELT-END-LINE	in dis-lines.
-;;; These are used by COELESCE-BUFFER-INSERT, COELESCE-EXPOSED-REGIONS-MERGE,
-;;; and WRITE-N-EXPOSED-REGIONS.
-
-(defvar *coelesce-buffer-fill-ptr* 25)
-(defvar *coelesce-buffer* (make-array *coelesce-buffer-fill-ptr*))
-(dotimes (i *coelesce-buffer-fill-ptr*)
-  (setf (svref *coelesce-buffer* i) (make-array 4)))
-
-(defmacro coelesce-buffer-elt-start (elt)
-  `(svref ,elt 0))
-(defmacro coelesce-buffer-elt-start-line (elt)
-  `(svref ,elt 1))
-(defmacro coelesce-buffer-elt-height (elt)
-  `(svref ,elt 2))
-(defmacro coelesce-buffer-elt-end-line (elt)
-  `(svref ,elt 3))
-(defmacro coelesce-buffer-elt (i)
-  `(svref *coelesce-buffer* ,i))
-
-;;; COELESCE-BUFFER-INSERT inserts an exposed region record into
-;;; *coelesce-buffer* such that start is less than all successive
-;;; elements.  Returns the new length of the buffer.
-;;; 
-(defun coelesce-buffer-insert (start start-line height end-line len)
-  (declare (fixnum start start-line height end-line len))
-  ;;
-  ;; Add element if len is to fill pointer.  If fill pointer is to buffer
-  ;; length, then grow buffer.
-  (when (= len (the fixnum *coelesce-buffer-fill-ptr*))
-    (when (= (the fixnum *coelesce-buffer-fill-ptr*)
-	     (the fixnum (length (the simple-vector *coelesce-buffer*))))
-      (let ((new (make-array (ash (length (the simple-vector *coelesce-buffer*))
-				  1))))
-	(replace (the simple-vector new) (the simple-vector *coelesce-buffer*)
-		 :end1 *coelesce-buffer-fill-ptr*
-		 :end2 *coelesce-buffer-fill-ptr*)
-	(setf *coelesce-buffer* new)))
-    (setf (coelesce-buffer-elt len) (make-array 4))
-    (incf *coelesce-buffer-fill-ptr*))
-  ;;
-  ;; Find point to insert record: start, start-line, height, and end-line.
-  (do ((i 0 (1+ i)))
-      ((= i len)
-       ;; Start is greater than all previous starts.  Add it to the end.
-       (let ((region (coelesce-buffer-elt len)))
-	 (setf (coelesce-buffer-elt-start region) start)
-	 (setf (coelesce-buffer-elt-start-line region) start-line)
-	 (setf (coelesce-buffer-elt-height region) height)
-	 (setf (coelesce-buffer-elt-end-line region) end-line)))
-    (declare (fixnum i))
-    (when (< start (the fixnum
-			(coelesce-buffer-elt-start (coelesce-buffer-elt i))))
-      ;;
-      ;; Insert new element at i, using storage allocated at element len.
-      (let ((last (coelesce-buffer-elt len)))
-	(setf (coelesce-buffer-elt-start last) start)
-	(setf (coelesce-buffer-elt-start-line last) start-line)
-	(setf (coelesce-buffer-elt-height last) height)
-	(setf (coelesce-buffer-elt-end-line last) end-line)
-	;;
-	;; Shift elements after i (inclusively) to the right.
-	(do ((j (1- len) (1- j))
-	     (k len j)
-	     (terminus (1- i)))
-	    ((= j terminus))
-	  (declare (fixnum j k terminus))
-	  (setf (coelesce-buffer-elt k) (coelesce-buffer-elt j)))
-	;;
-	;; Stash element to insert at i.
-	(setf (coelesce-buffer-elt i) last))
-      (return)))
-  (1+ len))
-
-
-;;; COELESCE-EXPOSED-REGIONS-MERGE merges/coelesces the regions in
-;;; *coelesce-buffer*.  It takes the number of elements and returns the new
-;;; number of elements.  The regions are examined one at a time relative to
-;;; the current one.  The current region remains so, with next advancing
-;;; through the buffer, until a next region is found that does not overlap
-;;; and is not adjacent.  When this happens, the current values are stored
-;;; in the current region, and the buffer's element after the current element
-;;; becomes current.  The next element that was found not to be in contact
-;;; the old current element is stored in the new current element by copying
-;;; its values there.  The buffer's elements always stay in place, and their
-;;; storage is re-used.  After this process which makes the next region be
-;;; the current region, the next pointer is incremented.
-;;;
-(defun coelesce-exposed-regions-merge (len)
-    (let* ((current 0)
-	   (next 1)
-	   (current-region (coelesce-buffer-elt 0))
-	   (current-height (coelesce-buffer-elt-height current-region))
-	   (current-end-line (coelesce-buffer-elt-end-line current-region))
-	   (current-end-bit (+ (the fixnum
-				    (coelesce-buffer-elt-start current-region))
-			       current-height)))
-      (declare (fixnum current next current-height
-		       current-end-line current-end-bit))
-      (loop
-	(let* ((next-region (coelesce-buffer-elt next))
-	       (next-start (coelesce-buffer-elt-start next-region))
-	       (next-height (coelesce-buffer-elt-height next-region))
-	       (next-end-bit (+ next-start next-height)))
-	  (declare (fixnum next-start next-height next-end-bit))
-	  (cond ((<= next-start current-end-bit)
-		 (let ((extra-height (- next-end-bit current-end-bit)))
-		   (declare (fixnum extra-height))
-		   ;; Maybe the next region is contained in the current.
-		   (when (plusp extra-height)
-		     (incf current-height extra-height)
-		     (setf current-end-bit next-end-bit)
-		     (setf current-end-line
-			   (coelesce-buffer-elt-end-line next-region)))))
-		(t
-		 ;;
-		 ;; Update current record since next does not overlap
-		 ;; with current.
-		 (setf (coelesce-buffer-elt-height current-region)
-		       current-height)
-		 (setf (coelesce-buffer-elt-end-line current-region)
-		       current-end-line)
-		 ;;
-		 ;; Move to new distinct region, copying data from next region.
-		 (incf current)
-		 (setf current-region (coelesce-buffer-elt current))
-		 (setf (coelesce-buffer-elt-start current-region) next-start)
-		 (setf (coelesce-buffer-elt-start-line current-region)
-		       (coelesce-buffer-elt-start-line next-region))
-		 (setf current-height next-height)
-		 (setf current-end-bit next-end-bit)
-		 (setf current-end-line
-		       (coelesce-buffer-elt-end-line next-region)))))
-	(incf next)
-	(when (= next len)
-	  (setf (coelesce-buffer-elt-height current-region) current-height)
-	  (setf (coelesce-buffer-elt-end-line current-region) current-end-line)
-	  (return)))
-      (1+ current)))
-
-;;; EXPOSED-REGION-BOUNDS returns as multiple values the first line affected,
-;;; the first possible bit affected (accounting for the cursor), the end line
-;;; affected, and the height of the region.
-;;; 
-(defun exposed-region-bounds (y height cursor-offset font-height)
-  (declare (fixnum y height cursor-offset font-height))
-  (let* ((start (truncate (the fixnum (- y hunk-top-border))
-			  font-height))
-	 (end (ceiling (the fixnum (- (the fixnum (+ y height))
-				      hunk-top-border))
-		       font-height)))
-    (values
-     start
-     (+ (the fixnum (* start font-height)) cursor-offset hunk-top-border)
-     end
-     (- (the fixnum (* (the fixnum (- end start)) font-height))
-	cursor-offset))))
-
-
-(defun write-n-exposed-regions (hunk n)
-  (declare (fixnum n))
-  (let* (;; Loop constants.
-	 (end-dl (bitmap-hunk-end hunk))
-	 (xwindow (bitmap-hunk-xwindow hunk))
-	 (hunk-width (bitmap-hunk-width hunk))
-	 ;; Loop variables.
-	 (dl (bitmap-hunk-start hunk))
-	 (i 0)
-	 (region (coelesce-buffer-elt 0))
-	 (start-line (coelesce-buffer-elt-start-line region))
-	 (start (coelesce-buffer-elt-start region))
-	 (height (coelesce-buffer-elt-height region))
-	 (end-line (coelesce-buffer-elt-end-line region))
-	 (region-idx 0))
-    (declare (fixnum i start start-line height end-line region-idx))
-    (loop
-      (xlib:clear-area xwindow :x 0 :y start :width hunk-width :height height)
-      ;; Find this regions first line.
-      (loop
-	(when (or (eq dl end-dl) (= i start-line))
-	  (return))
-	(incf i)
-	(setf dl (cdr dl)))
-      ;; Write this region's lines.
-      (loop
-	(when (or (eq dl end-dl) (= i end-line))
-	  (return))
-	(hunk-write-line hunk (car dl) i)
-	(incf i)
-	(setf dl (cdr dl)))
-      ;; Get next region unless we're done.
-      (when (= (incf region-idx) n) (return))
-      (setf region (coelesce-buffer-elt region-idx))
-      (setf start (coelesce-buffer-elt-start region))
-      (setf start-line (coelesce-buffer-elt-start-line region))
-      (setf height (coelesce-buffer-elt-height region))
-      (setf end-line (coelesce-buffer-elt-end-line region)))
-    ;;
-    ;; Check for modeline exposure.
-    (setf region (coelesce-buffer-elt (1- n)))
-    (setf start (coelesce-buffer-elt-start region))
-    (setf height (coelesce-buffer-elt-height region))
-    (when (and (bitmap-hunk-modeline-pos hunk)
-	       (> (+ start height)
-		  (- (bitmap-hunk-modeline-pos hunk)
-		     (bitmap-hunk-bottom-border hunk))))
-      (hunk-replace-modeline hunk)
-      (hunk-draw-bottom-border hunk))))
-
-(defun write-one-exposed-region (hunk y height)
-  (let* ((font-family (bitmap-hunk-font-family hunk))
-	 (font-height (font-family-height font-family))
-	 (co (font-family-cursor-y-offset font-family))
-	 (start-line (truncate (- y hunk-top-border) font-height))
-	 (end-line (ceiling (- (+ y height) hunk-top-border) font-height))
-	 (start-bit (+ (* start-line font-height) co hunk-top-border))
-	 (nheight (- (* (- end-line start-line) font-height) co))
-	 (hunk-end-line (bitmap-hunk-end hunk)))
-    (declare (fixnum font-height co start-line end-line start-bit nheight))
-    (xlib:clear-area (bitmap-hunk-xwindow hunk) :x 0 :y start-bit
-		     :width (bitmap-hunk-width hunk) :height nheight)
-    (do ((dl (bitmap-hunk-start hunk) (cdr dl))
-	 (i 0 (1+ i)))
-	((or (eq dl hunk-end-line) (= i start-line))
-	 (do ((i i (1+ i))
-	      (dl dl (cdr dl)))
-	     ((or (eq dl hunk-end-line) (= i end-line)))
-	   (declare (fixnum i))
-	   (hunk-write-line hunk (car dl) i)))
-      (declare (fixnum i)))
-    (when (and (bitmap-hunk-modeline-pos hunk)
-	       (> (+ start-bit nheight)
-		  (- (bitmap-hunk-modeline-pos hunk)
-		     (bitmap-hunk-bottom-border hunk))))
-      (hunk-replace-modeline hunk)
-      (hunk-draw-bottom-border hunk))))
-
-
-
-;;;; Resized window handling.
-
-;;; :configure-notify events are sent because we select :structure-notify.
-;;; This buys us a lot of events we have to write dummy handlers to ignore.
-;;;
-
-;;; HUNK-RECONFIGURED -- Internal.
-;;;
-;;; This must note that the hunk changed to prevent certain redisplay problems
-;;; with recentering the window that caused bogus lines to be drawn after the
-;;; actual visible text in the window.  We must also indicate the hunk is
-;;; trashed to eliminate exposure event handling that comes after resizing.
-;;; This also causes a full redisplay on the window which is the easiest and
-;;; generally best looking thing.
-;;;
-(defun hunk-reconfigured (object event-key event-window window x y width
-				 height border-width above-sibling
-				 override-redirect-p send-event-p)
-  (declare (ignore event-key event-window window x y border-width
-		   above-sibling override-redirect-p send-event-p))
-  (typecase object
-    (bitmap-hunk
-     (when (or (/= width (bitmap-hunk-width object))
-	       (/= height (bitmap-hunk-height object)))
-       (hunk-changed object width height nil)
-       ;; Under X11, don't redisplay since an exposure event is coming next.
-       (setf (bitmap-hunk-trashed object) t)))
-    (window-group
-     (let ((old-width (window-group-width object))
-	   (old-height (window-group-height object)))
-       (when (or (/= width old-width) (/= height old-height))
-	 (window-group-changed object width height))))))
-;;;
-(ext:serve-configure-notify *hemlock-windows* #'hunk-reconfigured)
-
-
-;;; HUNK-IGNORE-EVENT ignores the following unrequested events.  They all take
-;;; at least five arguments, but then there are up to four more optional.
-;;;
-(defun hunk-ignore-event (hunk event-key event-window window one
-			       &optional two three four five)
-  (declare (ignore hunk event-key event-window window one two three four five))
-  t)
-;;;
-(ext:serve-destroy-notify *hemlock-windows* #'hunk-ignore-event)
-(ext:serve-unmap-notify *hemlock-windows* #'hunk-ignore-event)
-(ext:serve-map-notify *hemlock-windows* #'hunk-ignore-event)
-(ext:serve-reparent-notify *hemlock-windows* #'hunk-ignore-event)
-(ext:serve-gravity-notify *hemlock-windows* #'hunk-ignore-event)
-(ext:serve-circulate-notify *hemlock-windows* #'hunk-ignore-event)
-
-
-
-;;;; Interface to X input events.
-
-;;; HUNK-KEY-INPUT and HUNK-MOUSE-INPUT.
-;;; Each key and mouse event is turned into a character via
-;;; EXT:TRANSLATE-CHARACTER or EXT:TRANSLATE-MOUSE-CHARACTER, either of which
-;;; may return nil.  Nil is returned for input that is considered uninteresting
-;;; input; for example, shift and control.
-;;;
-
-(defun hunk-key-input (hunk event-key event-window root child same-screen-p x y
-		       root-x root-y modifiers time key-code send-event-p)
-  (declare (ignore event-key event-window root child same-screen-p root-x
-		   root-y time send-event-p))
-  (hunk-process-input hunk
-		      (ext:translate-key-event
-		       (bitmap-device-display (device-hunk-device hunk))
-		       key-code modifiers)
-		      x y))
-;;;
-(ext:serve-key-press *hemlock-windows* #'hunk-key-input)
-
-(defun hunk-mouse-input (hunk event-key event-window root child same-screen-p x y
-			 root-x root-y modifiers time key-code send-event-p)
-  (declare (ignore event-window root child same-screen-p root-x root-y
-		   time send-event-p))
-  (hunk-process-input hunk
-		      (ext:translate-mouse-key-event key-code modifiers
-						     event-key)
-		      x y))
-;;;
-(ext:serve-button-press *hemlock-windows* #'hunk-mouse-input)
-(ext:serve-button-release *hemlock-windows* #'hunk-mouse-input)
-
-(defun hunk-process-input (hunk char x y)
-  (when char
-    (let* ((font-family (bitmap-hunk-font-family hunk))
-	   (font-width (font-family-width font-family))
-	   (font-height (font-family-height font-family))
-	   (ml-pos (bitmap-hunk-modeline-pos hunk))
-	   (height (bitmap-hunk-height hunk))
-	   (width (bitmap-hunk-width hunk))
-	   (handler (bitmap-hunk-input-handler hunk))
-	   (char-width (bitmap-hunk-char-width hunk)))
-      (cond ((not (and (< -1 x width) (< -1 y height)))
-	     (funcall handler hunk char nil nil))
-	    ((and ml-pos (> y (- ml-pos (bitmap-hunk-bottom-border hunk))))
-	     (funcall handler hunk char
-		      ;; (/ width x) doesn't handle ends of thumb bar
-		      ;; and eob right, so do a bunch of truncating.
-		      (min (truncate x (truncate width char-width))
-			   (1- char-width))
-		      nil))
-	    (t
-	     (let* ((cx (truncate (- x hunk-left-border) font-width))
-		    (temp (truncate (- y hunk-top-border) font-height))
-		    (char-height (bitmap-hunk-char-height hunk))
-		    ;; Extra bits below bottom line and above modeline and
-		    ;; thumb bar are considered part of the bottom line since
-		    ;; we have already picked off the y=nil case.
-		    (cy (if (< temp char-height) temp (1- char-height))))
-	       (if (and (< -1 cx char-width)
-			(< -1 cy))
-		   (funcall handler hunk char cx cy)
-		   (funcall handler hunk char nil nil))))))))
-
-
-
-;;;; Handling boundary crossing events.
-
-;;; Entering and leaving a window are handled basically the same except that it
-;;; is possible to get an entering event under X without getting an exiting
-;;; event; specifically, when the mouse is in a Hemlock window that is over
-;;; another window, and someone buries the top window, Hemlock only gets an
-;;; entering event on the lower window (no exiting event for the buried
-;;; window).
-;;;
-;;; :enter-notify and :leave-notify events are sent because we select
-;;; :enter-window and :leave-window events.
-;;;
-
-(defun hunk-mouse-entered (hunk event-key event-window root child same-screen-p
-			   x y root-x root-y state time mode kind send-event-p)
-  (declare (ignore event-key event-window child root same-screen-p
-		   x y root-x root-y state time mode kind send-event-p))
-  (when (and *cursor-dropped* (not *hemlock-listener*))
-    (cursor-invert-center))
-  (setf *hemlock-listener* t)
-  (let ((current-hunk (window-hunk (current-window))))
-    (unless (and *current-highlighted-border*
-		 (eq *current-highlighted-border* current-hunk))
-      (setf (xlib:window-border (window-group-xparent
-				 (bitmap-hunk-window-group current-hunk)))
-	    *highlight-border-pixmap*)
-      (xlib:display-force-output
-       (bitmap-device-display (device-hunk-device current-hunk)))
-      (setf *current-highlighted-border* current-hunk)))
-  (let ((window (bitmap-hunk-window hunk)))
-    (when window (invoke-hook ed::enter-window-hook window))))
-;;;
-(ext:serve-enter-notify *hemlock-windows* #'hunk-mouse-entered)
-
-(defun hunk-mouse-left (hunk event-key event-window root child same-screen-p
-			x y root-x root-y state time mode kind send-event-p)
-  (declare (ignore event-key event-window child root same-screen-p
-		   x y root-x root-y state time mode kind send-event-p))
-  (setf *hemlock-listener* nil)
-  (when *cursor-dropped* (cursor-invert-center))
-  (when *current-highlighted-border*
-    (setf (xlib:window-border (window-group-xparent
-			       (bitmap-hunk-window-group
-				*current-highlighted-border*)))
-	  *default-border-pixmap*)
-    (xlib:display-force-output
-     (bitmap-device-display (device-hunk-device *current-highlighted-border*)))
-    (setf *current-highlighted-border* nil))
-  (let ((window (bitmap-hunk-window hunk)))
-    (when window (invoke-hook ed::exit-window-hook window))))
-;;;
-(ext:serve-leave-notify *hemlock-windows* #'hunk-mouse-left)
-
-
-
-;;;; Making a Window.
-
-(defparameter minimum-window-height 100
-  "If the window created by splitting a window would be shorter than this,
-  then we create an overlapped window the same size instead.")
-
-;;; The width must be that of a tab for the screen image builder, and the
-;;; height must be one line (two with a modeline).
-;;; 
-(defconstant minimum-window-lines 1
-  "Windows must have at least this many lines.")
-(defconstant minimum-window-columns 8
-  "Windows must be at least this many characters wide.")
-
-(eval-when (compile eval load)
-(defconstant xwindow-border-width 2 "X border around X windows")
-(defconstant xwindow-border-width*2 (* xwindow-border-width 2))
-); eval-when
-
-;;; We must name windows (set the "name" property) to get around a bug in
-;;; awm and twm.  They will not handle menu clicks without a window having
-;;; a name.  We set the name to this silly thing.
-;;;
-(defvar *hemlock-window-count* 0)
-;;;
-(defun new-hemlock-window-name ()
-  (let ((*print-base* 10))
-    (format nil "Hemlock ~S" (incf *hemlock-window-count*))))
-
-(proclaim '(inline surplus-window-height surplus-window-height-w/-modeline))
-;;;
-(defun surplus-window-height (thumb-bar-p)
-  (+ hunk-top-border (if thumb-bar-p
-			 hunk-thumb-bar-bottom-border
-			 hunk-bottom-border)))
-;;;
-(defun surplus-window-height-w/-modeline (thumb-bar-p)
-  (+ (surplus-window-height thumb-bar-p)
-     hunk-modeline-top
-     hunk-modeline-bottom))
-
-
-;;; DEFAULT-CREATE-WINDOW-HOOK -- Internal.
-;;;
-;;; This is the default value for *create-window-hook*.  It makes an X window
-;;; for a new group/parent on the given display possibly prompting the user.
-;;;
-(defun default-create-window-hook (display x y width height name font-family
-				   &optional modelinep thumb-bar-p)
-  (maybe-prompt-user-for-window
-   (xlib:screen-root (xlib:display-default-screen display))
-   x y width height font-family modelinep thumb-bar-p name))
-
-;;; MAYBE-PROMPT-USER-FOR-WINDOW -- Internal.
-;;;
-;;; This makes an X window and sets its standard properties according to
-;;; supplied values.  When some of these are nil, the window manager should
-;;; prompt the user for those missing values when the window gets mapped.  We
-;;; use this when making new group/parent windows.  Returns the window without
-;;; mapping it.
-;;;
-(defun maybe-prompt-user-for-window (root x y width height font-family
-				     modelinep thumb-bar-p icon-name)
-  (let ((font-height (font-family-height font-family))
-	(font-width (font-family-width font-family))
-	(extra-y (surplus-window-height thumb-bar-p))
-	(extra-y-w/-modeline (surplus-window-height-w/-modeline thumb-bar-p)))
-    (create-window-with-properties
-     root x y
-     (if width (+ (* width font-width) hunk-left-border))
-     (if height
-	 (if modelinep
-	     (+ (* (1+ height) font-height) extra-y-w/-modeline)
-	     (+ (* height font-height) extra-y)))
-     font-width font-height icon-name
-     (+ (* minimum-window-columns font-width) hunk-left-border)
-     (if modelinep
-	 (+ (* (1+ minimum-window-lines) font-height) extra-y-w/-modeline)
-	 (+ (* minimum-window-lines font-height) extra-y))
-     t)))
-
-(defvar *create-window-hook* #'default-create-window-hook
-  "Hemlock calls this function when it makes a new X window for a new group.
-   It passes as arguments the X display, x (from MAKE-WINDOW), y (from
-   MAKE-WINDOW), width (from MAKE-WINDOW), height (from MAKE-WINDOW), a name
-   for the window's icon-name, font-family (from MAKE-WINDOW), modelinep (from
-   MAKE-WINDOW), and whether the window will have a thumb-bar meter.  The
-   function returns a window or nil.")
- 
-;;; BITMAP-MAKE-WINDOW -- Internal.
-;;; 
-(defun bitmap-make-window (device start modelinep window font-family
-				  ask-user x y width-arg height-arg proportion)
-  (let* ((display (bitmap-device-display device))
-	 (thumb-bar-p (value ed::thumb-bar-meter))
-	 (hunk (make-bitmap-hunk
-		:font-family font-family
-		:end the-sentinel  :trashed t
-		:input-handler #'window-input-handler
-		:device device
-		:thumb-bar-p (and modelinep thumb-bar-p))))
-    (multiple-value-bind
-	(xparent xwindow)
-	(maybe-make-x-window-and-parent window display start ask-user x y
-					width-arg height-arg font-family
-					modelinep thumb-bar-p proportion)
-      (unless xwindow (return-from bitmap-make-window nil))
-      (let ((window-group (make-window-group xparent
-					     (xlib:drawable-width xparent)
-					     (xlib:drawable-height xparent))))
-	(setf (bitmap-hunk-xwindow hunk) xwindow)
-	(setf (bitmap-hunk-window-group hunk) window-group)
-	(setf (bitmap-hunk-gcontext hunk)
-	      (default-gcontext xwindow font-family))
-	;;
-	;; Select input and enable event service before showing the window.
-	(setf (xlib:window-event-mask xwindow) child-interesting-xevents-mask)
-	(setf (xlib:window-event-mask xparent) group-interesting-xevents-mask)
-	(add-xwindow-object xwindow hunk *hemlock-windows*)
-	(add-xwindow-object xparent window-group *hemlock-windows*))
-      (when xparent (xlib:map-window xparent))
-      (xlib:map-window xwindow)
-      (xlib:display-finish-output display)
-      ;; A window is not really mapped until it is viewable.  It is said to be
-      ;; mapped if a map request has been sent whether it is handled or not.
-      (loop (when (and (eq (xlib:window-map-state xwindow) :viewable)
-		       (eq (xlib:window-map-state xparent) :viewable))
-	      (return)))
-      ;;
-      ;; Find out how big it is...
-      (xlib:with-state (xwindow)
-	(set-hunk-size hunk (xlib:drawable-width xwindow)
-		       (xlib:drawable-height xwindow) modelinep)))
-    (setf (bitmap-hunk-window hunk)
-	  (window-for-hunk hunk start modelinep))
-    ;; If window is non-nil, then it is a new group/parent window, so don't
-    ;; link it into the current window's group.  When ask-user is non-nil,
-    ;; we make a new group too.
-    (cond ((or window ask-user)
-	   ;; This occurs when we make the world's first Hemlock window.
-	   (unless *current-window*
-	     (setq *current-window* (bitmap-hunk-window hunk)))
-	   (setf (bitmap-hunk-previous hunk) hunk)
-	   (setf (bitmap-hunk-next hunk) hunk))
-	  (t
-	   (let ((h (window-hunk *current-window*)))
-	     (shiftf (bitmap-hunk-next hunk) (bitmap-hunk-next h) hunk)
-	     (setf (bitmap-hunk-previous (bitmap-hunk-next hunk)) hunk)
-	     (setf (bitmap-hunk-previous hunk) h))))
-    (push hunk (device-hunks device))
-    (bitmap-hunk-window hunk)))
-
-;;; MAYBE-MAKE-X-WINDOW-AND-PARENT -- Internal.
-;;;
-;;; BITMAP-MAKE-WINDOW calls this.  If xparent is non-nil, we clear it and
-;;; return it with a child that fills it.  If xparent is nil, and ask-user is
-;;; non-nil, then we invoke *create-window-hook* to get a parent window and
-;;; return it with a child that fills it.  By default, we make a child in the
-;;; CURRENT-WINDOW's parent.
-;;;
-(defun maybe-make-x-window-and-parent (xparent display start ask-user x y width
-				       height font-family modelinep thumb-p
-				       proportion)
-  (let ((icon-name (buffer-name (line-buffer (mark-line start)))))
-    (cond (xparent
-	   (check-type xparent xlib:window)
-	   (let ((width (xlib:drawable-width xparent))
-		 (height (xlib:drawable-height xparent)))
-	     (xlib:clear-area xparent :width width :height height)
-	     (modify-parent-properties :set xparent modelinep thumb-p
-				       (font-family-width font-family)
-				       (font-family-height font-family))
-	     (values xparent (xwindow-for-xparent xparent icon-name))))
-	  (ask-user
-	   (let ((xparent (funcall *create-window-hook*
-				   display x y width height icon-name
-				   font-family modelinep thumb-p)))
-	     (values xparent (xwindow-for-xparent xparent icon-name))))
-	  (t
-	   (let ((xparent (window-group-xparent
-			   (bitmap-hunk-window-group
-			    (window-hunk (current-window))))))
-	     (values xparent
-		     (create-window-from-current
-		      proportion font-family modelinep thumb-p xparent
-		      icon-name)))))))
-
-;;; XWINDOW-FOR-XPARENT -- Internal.
-;;;
-;;; This returns a child of xparent that completely fills that parent window.
-;;; We supply the font-width and font-height as nil because these are useless
-;;; for child windows.
-;;;
-(defun xwindow-for-xparent (xparent icon-name)
-  (xlib:with-state (xparent)
-    (create-window-with-properties xparent 0 0
-				   (xlib:drawable-width xparent)
-				   (xlib:drawable-height xparent)
-				   nil nil icon-name)))
-
-;;; CREATE-WINDOW-FROM-CURRENT -- Internal.
-;;;
-;;; This makes a child window on parent by splitting the current window.  If
-;;; the result will be too small, this returns nil.  If the current window's
-;;; height is odd, the extra pixel stays with it, and the new window is one
-;;; pixel smaller.
-;;;
-(defun create-window-from-current (proportion font-family modelinep thumb-p
-				   parent icon-name)
-  (let* ((cur-hunk (window-hunk *current-window*))
-	 (cwin (bitmap-hunk-xwindow cur-hunk)))
-    ;; Compute current window's height and take a proportion of it.
-    (xlib:with-state (cwin)
-      (let* ((cw (xlib:drawable-width cwin))
-	     (ch (xlib:drawable-height cwin))
-	     (cy (xlib:drawable-y cwin))
-	     (new-ch (truncate (* ch (- 1 proportion))))
-	     (font-height (font-family-height font-family))
-	     (font-width (font-family-width font-family))
-	     (cwin-min (minimum-window-height
-			(font-family-height
-			 (bitmap-hunk-font-family cur-hunk))
-			(bitmap-hunk-modeline-pos cur-hunk)
-			(bitmap-hunk-thumb-bar-p cur-hunk)))
-	     (new-min (minimum-window-height font-height modelinep
-					     thumb-p)))
-	(declare (fixnum cw cy ch new-ch))
-	;; See if we have room for a new window.  This should really
-	;; check the current window and the new one against their
-	;; relative fonts and the minimal window columns and line
-	;; (including whether there is a modeline).
-	(if (and (> new-ch cwin-min)
-		 (> (- ch new-ch) new-min))
-	    (let ((win (create-window-with-properties
-			parent 0 (+ cy new-ch)
-			cw (- ch new-ch) font-width font-height
-			icon-name)))
-	      ;; No need to reshape current Hemlock window structure here
-	      ;; since this call will send an appropriate event.
-	      (setf (xlib:drawable-height cwin) new-ch)
-	      ;; Set hints on parent, so the user can't resize it to be
-	      ;; smaller than what will hold the current number of
-	      ;; children.
-	      (modify-parent-properties :add parent modelinep
-					thumb-p
-					(font-family-width font-family)
-					font-height)
-	      win)
-	    nil)))))
-
-
-;;; MAKE-XWINDOW-LIKE-HWINDOW -- Interface.
-;;;
-;;; The window name is set to get around an awm and twm bug that inhibits menu
-;;; clicks unless the window has a name; this could be used better.
-;;;
-(defun make-xwindow-like-hwindow (window)
-  "This returns an group/parent xwindow with dimensions suitable for making a
-   Hemlock window like the argument window.  The new window's position should
-   be the same as the argument window's position relative to the root.  When
-   setting standard properties, we set x, y, width, and height to tell window
-   managers to put the window where we intend without querying the user."
-  (let* ((hunk (window-hunk window))
-	 (font-family (bitmap-hunk-font-family hunk))
-	 (xwin (bitmap-hunk-xwindow hunk)))
-    (multiple-value-bind (x y)
-			 (window-root-xy xwin)
-      (create-window-with-properties
-       (xlib:screen-root (xlib:display-default-screen
-			  (bitmap-device-display (device-hunk-device hunk))))
-       x y (bitmap-hunk-width hunk) (bitmap-hunk-height hunk)
-       (font-family-width font-family)
-       (font-family-height font-family)
-       (buffer-name (window-buffer window))
-       ;; When the user hands this window to MAKE-WINDOW, it will set the
-       ;; minimum width and height properties.
-       nil nil
-       t))))
-
-
-
-;;;; Deleting a window.
-
-;;; DEFAULT-DELETE-WINDOW-HOOK -- Internal.
-;;;
-(defun default-delete-window-hook (xparent)
-  (xlib:destroy-window xparent))
-;;;
-(defvar *delete-window-hook* #'default-delete-window-hook
-  "Hemlock calls this function to delete an X group/parent window.  It passes
-   the X window as an argument.")
-
-
-;;; BITMAP-DELETE-WINDOW  --  Internal
-;;;
-;;;
-(defun bitmap-delete-window (window)
-  (let* ((hunk (window-hunk window))
-	 (xwindow (bitmap-hunk-xwindow hunk))
-	 (xparent (window-group-xparent (bitmap-hunk-window-group hunk)))
-	 (display (bitmap-device-display (device-hunk-device hunk))))
-    (remove-xwindow-object xwindow)
-    (setq *window-list* (delete window *window-list*))
-    (when (eq *current-highlighted-border* hunk)
-      (setf *current-highlighted-border* nil))
-    (when (and (eq *cursor-hunk* hunk) *cursor-dropped*) (lift-cursor))
-    (xlib:display-force-output display)
-    (bitmap-delete-and-reclaim-window-space xwindow window)
-    (loop (unless (deleting-window-drop-event display xwindow) (return)))
-    (let ((device (device-hunk-device hunk)))
-      (setf (device-hunks device) (delete hunk (device-hunks device))))
-    (cond ((eq hunk (bitmap-hunk-next hunk))
-	   ;; Is this the last window in the group?
-	   (remove-xwindow-object xparent)
-	   (xlib:display-force-output display)
-	   (funcall *delete-window-hook* xparent)
-	   (loop (unless (deleting-window-drop-event display xparent)
-		   (return)))
-	   (let ((window (find-if-not #'(lambda (window)
-					  (eq window *echo-area-window*))
-				      *window-list*)))
-	     (setf (current-buffer) (window-buffer window)
-		   (current-window) window)))
-	  (t
-	   (modify-parent-properties :delete xparent
-				     (bitmap-hunk-modeline-pos hunk)
-				     (bitmap-hunk-thumb-bar-p hunk)
-				     (font-family-width
-				      (bitmap-hunk-font-family hunk))
-				     (font-family-height
-				      (bitmap-hunk-font-family hunk)))
-	   (let ((next (bitmap-hunk-next hunk))
-		 (prev (bitmap-hunk-previous hunk)))
-	     (setf (bitmap-hunk-next prev) next)
-	     (setf (bitmap-hunk-previous next) prev))))
-    (let ((buffer (window-buffer window)))
-      (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))))
-  nil)
-
-;;; BITMAP-DELETE-AND-RECLAIM-WINDOW-SPACE -- Internal.
-;;;
-;;; This destroys the X window after obtaining its necessary state information.
-;;; If the previous or next window (in that order) is "stacked" over or under
-;;; the target window, then it is grown to fill in the newly opened space.  We
-;;; fetch all the necessary configuration data up front, so we don't have to
-;;; call XLIB:DESTROY-WINDOW while in the XLIB:WITH-STATE.
-;;;
-(defun bitmap-delete-and-reclaim-window-space (xwindow hwindow)
-  (multiple-value-bind (y height)
-		       (xlib:with-state (xwindow)
-			 (values (xlib:drawable-y xwindow)
-				 (xlib:drawable-height xwindow)))
-    (xlib:destroy-window xwindow)
-    (let ((hunk (window-hunk hwindow)))
-      (xlib:free-gcontext (bitmap-hunk-gcontext hunk))
-      (unless (eq hunk (bitmap-hunk-next hunk))
-	(unless (maybe-merge-with-previous-window hunk y height)
-	  (merge-with-next-window hunk y height))))))
-
-;;; MAYBE-MERGE-WITH-PREVIOUS-WINDOW -- Internal.
-;;;
-;;; This returns non-nil when it grows the previous hunk to include the
-;;; argument hunk's screen space.
-;;;
-(defun maybe-merge-with-previous-window (hunk y h)
-  (declare (fixnum y h))
-  (let* ((prev (bitmap-hunk-previous hunk))
-	 (prev-xwin (bitmap-hunk-xwindow prev)))
-    (xlib:with-state (prev-xwin)
-      (if (< (xlib:drawable-y prev-xwin) y)
-	  (incf (xlib:drawable-height prev-xwin) h)))))
-
-;;; MERGE-WITH-NEXT-WINDOW -- Internal.
-;;;
-;;; This trys to grow the next hunk's window to make use of the space created
-;;; by deleting hunk's window.  If this is possible, then we must also move the
-;;; next window up to where hunk's window was.
-;;;
-;;; When we reconfigure the window, we must set the hunk trashed.  This is a
-;;; hack since twm is broken again and is sending exposure events before
-;;; reconfigure notifications.  Hemlock relies on the protocol's statement that
-;;; reconfigures come before exposures to set the hunk trashed before getting
-;;; the exposure.  For now, we'll do it here too.
-;;;
-(defun merge-with-next-window (hunk y h)
-  (declare (fixnum y h))
-  (let* ((next (bitmap-hunk-next hunk))
-	 (next-xwin (bitmap-hunk-xwindow next)))
-    ;; Fetch height before setting y to save an extra round trip to the X
-    ;; server.
-    (let ((next-h (xlib:drawable-height next-xwin)))
-      (setf (xlib:drawable-y next-xwin) y)
-      (setf (xlib:drawable-height next-xwin) (+ next-h h)))
-    (setf (bitmap-hunk-trashed next) t)
-    (let ((hints (xlib:wm-normal-hints next-xwin)))
-      (setf (xlib:wm-size-hints-y hints) y)
-      (setf (xlib:wm-normal-hints next-xwin) hints))))
-
-
-;;; DELETING-WINDOW-DROP-EVENT -- Internal.
-;;;
-;;; This checks for any events on win.  If there is one, remove it from the
-;;; queue and return t.  Otherwise, return nil.
-;;;
-(defun deleting-window-drop-event (display win)
-  (xlib:display-finish-output display)
-  (let ((result nil))
-    (xlib:process-event
-     display :timeout 0
-     :handler #'(lambda (&key event-window window &allow-other-keys)
-		  (if (or (eq event-window win) (eq window win))
-		      (setf result t)
-		      nil)))
-    result))
-
-
-;;; MODIFY-PARENT-PROPERTIES -- Internal.
-;;;
-;;; This adds or deletes from xparent's min-height and min-width hints, so the
-;;; window manager will hopefully prevent users from making a window group too
-;;; small to hold all the windows in it.  We add to the height when we split
-;;; windows making additional ones, and we delete from it when we delete a
-;;; window.
-;;;
-;;; NOTE, THIS FAILS TO MAINTAIN THE WIDTH CORRECTLY.  We need to maintain the
-;;; width as the MAX of all the windows' minimal widths.  A window's minimal
-;;; width is its font's width multiplied by minimum-window-columns.
-;;;
-(defun modify-parent-properties (type xparent modelinep thumb-p
-				 font-width font-height)
-  (let ((hints (xlib:wm-normal-hints xparent)))
-    (xlib:set-wm-properties
-     xparent
-     :resource-name "Hemlock"
-     :x (xlib:wm-size-hints-x hints)
-     :y (xlib:wm-size-hints-y hints)
-     :width (xlib:drawable-width xparent)
-     :height (xlib:drawable-height xparent)
-     :user-specified-position-p t
-     :user-specified-size-p t
-     :width-inc (xlib:wm-size-hints-width-inc hints)
-     :height-inc (xlib:wm-size-hints-height-inc hints)
-     :min-width (or (xlib:wm-size-hints-min-width hints)
-		    (+ (* minimum-window-columns font-width) hunk-left-border))
-     :min-height
-     (let ((delta (minimum-window-height font-height modelinep thumb-p)))
-       (ecase type
-	 (:delete (- (xlib:wm-size-hints-min-height hints) delta))
-	 (:add (+ (or (xlib:wm-size-hints-min-height hints) 0)
-		  delta))
-	 (:set delta))))))
-
-;;; MINIMUM-WINDOW-HEIGHT -- Internal.
-;;;
-;;; This returns the minimum height necessary for a window given some of its
-;;; parameters.  This is the number of lines times font-height plus any extra
-;;; pixels for aesthetics.
-;;;
-(defun minimum-window-height (font-height modelinep thumb-p)
-  (if modelinep
-      (+ (* (1+ minimum-window-lines) font-height)
-	 (surplus-window-height-w/-modeline thumb-p))
-      (+ (* minimum-window-lines font-height)
-	 (surplus-window-height thumb-p))))
-
-
-
-;;;; Next and Previous windows.
-
-(defun bitmap-next-window (window)
-  "Return the next window after Window, wrapping around if Window is the
-  bottom window."
-  (check-type window window)
-  (bitmap-hunk-window (bitmap-hunk-next (window-hunk window))))
-
-(defun bitmap-previous-window (window)
-  "Return the previous window after Window, wrapping around if Window is the
-  top window."
-  (check-type window window)
-  (bitmap-hunk-window (bitmap-hunk-previous (window-hunk window))))
-
-
-
-;;;; Setting window width and height.
-
-;;; %SET-WINDOW-WIDTH  --  Internal
-;;;
-;;;    Since we don't support non-full-width windows, this does nothing.
-;;;
-(defun %set-window-width (window new-value)
-  (declare (ignore window))
-  new-value)
-
-;;; %SET-WINDOW-HEIGHT  --  Internal
-;;;
-;;;    Can't change window height either.
-;;;
-(defun %set-window-height (window new-value)
-  (declare (ignore window))
-  new-value)
-
-
-
-;;;; Random Typeout
-
-;;; Random typeout is done to a bitmap-hunk-output-stream
-;;; (Bitmap-Hunk-Stream.Lisp).  These streams have an associated hunk
-;;; that is used for its font-family, foreground and background color,
-;;; and X window pointer.  The hunk is not associated with any Hemlock
-;;; window, and the low level painting routines that use hunk dimensions
-;;; are not used for output.  The X window is resized as necessary with
-;;; each use, but the hunk is only registered for input and boundary
-;;; crossing event service; therefore, it never gets exposure or changed
-;;; notifications. 
-
-;;; These are set in INIT-BITMAP-SCREEN-MANAGER.
-;;; 
-(defvar *random-typeout-start-x* 0
-  "Where we put the the random typeout window.")
-(defvar *random-typeout-start-y* 0
-  "Where we put the the random typeout window.")
-(defvar *random-typeout-start-width* 0
-  "How wide the random typeout window is.")
-
-
-;;; DEFAULT-RANDOM-TYPEOUT-HOOK  --  Internal
-;;;
-;;;    The default hook-function for random typeout.  Nothing very fancy
-;;; for now.  If not given a window, makes one on top of the initial
-;;; Hemlock window using specials set in INIT-BITMAP-SCREEN-MANAGER.  If
-;;; given a window, we will change the height subject to the constraint
-;;; that the bottom won't be off the screen.  Any resulting window has
-;;; input and boundary crossing events selected, a hemlock cursor defined,
-;;; and is mapped.
-;;; 
-(defun default-random-typeout-hook (device window height)
-  (declare (fixnum height))
-    (let* ((display (bitmap-device-display device))
-	   (root (xlib:screen-root (xlib:display-default-screen display)))
-	   (full-height (xlib:drawable-height root))
-	   (actual-height (if window
-			      (multiple-value-bind (x y) (window-root-xy window)
-				(declare (ignore x) (fixnum y))
-				(min (- full-height y xwindow-border-width*2)
-				     height))
-			      (min (- full-height *random-typeout-start-y*
-				      xwindow-border-width*2)
-				   height)))
-	   (win (cond (window
-		       (setf (xlib:drawable-height window) actual-height)
-		       window)
-		      (t
-		       (let ((win (xlib:create-window
-				   :parent root
-				   :x *random-typeout-start-x*
-				   :y *random-typeout-start-y*
-				   :width *random-typeout-start-width*
-				   :height actual-height
-				   :background *default-background-pixel*
-				   :border-width xwindow-border-width
-				   :border *default-border-pixmap*
-				   :event-mask random-typeout-xevents-mask
-				   :override-redirect :on :class :input-output
-				   :cursor *hemlock-cursor*)))
-			 (xlib:set-wm-properties
-			  win :name "Pop-up Display" :icon-name "Pop-up Display"
-			  :resource-name "Hemlock"
-			  :x *random-typeout-start-x*
-			  :y *random-typeout-start-y*
-			  :width *random-typeout-start-width*
-			  :height actual-height
-			  :user-specified-position-p t :user-specified-size-p t
-			  ;; Tell OpenLook pseudo-X11 server we want input.
-			  :input :on)
-			 win))))
-	   (gcontext (if (not window) (default-gcontext win))))
-      (values win gcontext)))
-
-(defvar *random-typeout-hook* #'default-random-typeout-hook
-  "This function is called when a window is needed to display random typeout.
-   It is called with the Hemlock device, a pre-existing window or NIL, and the
-   number of pixels needed to display the number of lines requested in
-   WITH-RANDOM-TYPEOUT.  It should return a window, and if a new window was
-   created, then a gcontext must be returned as the second value.")
-
-;;; BITMAP-RANDOM-TYPEOUT-SETUP  --  Internal
-;;;
-;;;    This function is called by the with-random-typeout macro to
-;;; to set things up.  It calls the *Random-Typeout-Hook* to get a window
-;;; to work with, and then adjusts the random typeout stream's data-structures
-;;; to match.
-;;;
-(defun bitmap-random-typeout-setup (device stream height)
-  (let* ((*more-prompt-action* :empty)
-	 (hwin-exists-p (random-typeout-stream-window stream))
-	 (hwindow (if hwin-exists-p
-		      (change-bitmap-random-typeout-window hwin-exists-p height)
-		      (setf (random-typeout-stream-window stream)
-			    (make-bitmap-random-typeout-window
-			     device
-			     (buffer-start-mark
-			      (line-buffer
-			       (mark-line (random-typeout-stream-mark stream))))
-			     height)))))
-    (let ((xwindow (bitmap-hunk-xwindow (window-hunk hwindow)))
-	  (display (bitmap-device-display device)))
-      (xlib:display-finish-output display)
-      (loop
-	(unless (xlib:event-case (display :timeout 0)
-		  (:exposure (event-window)
-		    (eq event-window xwindow))
-		  (t () nil))
-	  (return))))))
-
-(defun change-bitmap-random-typeout-window (hwindow height)
-  (update-modeline-field (window-buffer hwindow) hwindow :more-prompt)
-  (let* ((hunk (window-hunk hwindow))
-	 (xwin (bitmap-hunk-xwindow hunk)))
-    ;;
-    ;; *random-typeout-hook* sets the window's height to the right value.
-    (funcall *random-typeout-hook* (device-hunk-device hunk) xwin
-	     (+ (* height (font-family-height (bitmap-hunk-font-family hunk)))
-		hunk-top-border (bitmap-hunk-bottom-border hunk)
-		hunk-modeline-top hunk-modeline-bottom))
-    (xlib:with-state (xwin)
-      (hunk-changed hunk (xlib:drawable-width xwin) (xlib:drawable-height xwin)
-		    nil))
-    ;;
-    ;; We push this on here because we took it out the last time we cleaned up.
-    (push hwindow (buffer-windows (window-buffer hwindow)))
-    (setf (bitmap-hunk-trashed hunk) t)
-    (xlib:map-window xwin)
-    (setf (xlib:window-priority xwin) :above))
-  hwindow)
-  
-(defun make-bitmap-random-typeout-window (device mark height)
-  (let* ((display (bitmap-device-display device))
-	 (hunk (make-bitmap-hunk
-		:font-family *default-font-family*
-		:end the-sentinel :trashed t
-		:input-handler #'window-input-handler
-		:device device :thumb-bar-p nil)))
-    (multiple-value-bind
-	(xwindow gcontext)
-	(funcall *random-typeout-hook*
-		 device (bitmap-hunk-xwindow hunk)
-		 (+ (* height (font-family-height *default-font-family*))
-		    hunk-top-border (bitmap-hunk-bottom-border hunk)
-		hunk-modeline-top hunk-modeline-bottom))
-      ;;
-      ;; When gcontext, we just made the window, so tie some stuff together.
-      (when gcontext
-	(setf (xlib:gcontext-font gcontext)
-	      (svref (font-family-map *default-font-family*) 0))
-	(setf (bitmap-hunk-xwindow hunk) xwindow)
-	(setf (bitmap-hunk-gcontext hunk) gcontext)
-	;;
-	;; Select input and enable event service before showing the window.
-	(setf (xlib:window-event-mask xwindow) random-typeout-xevents-mask)
-	(add-xwindow-object xwindow hunk *hemlock-windows*))
-      ;;
-      ;; Put the window on the screen so it's visible and we can know the size.
-      (xlib:map-window xwindow)
-      (xlib:display-finish-output display)
-      ;; A window is not really mapped until it is viewable (not visible).
-      ;; It is said to be mapped if a map request has been sent whether it
-      ;; is handled or not.
-      (loop (when (eq (xlib:window-map-state xwindow) :viewable)
-	      (return)))
-      (xlib:with-state (xwindow)
-	(set-hunk-size hunk (xlib:drawable-width xwindow)
-		       (xlib:drawable-height xwindow) t))
-      ;;
-      ;; Get a Hemlock window and hide it from the rest of Hemlock.
-      (let ((hwin (window-for-hunk hunk mark *random-typeout-ml-fields*)))
-	(update-modeline-field (window-buffer hwin) hwin :more-prompt)
-	(setf (bitmap-hunk-window hunk) hwin)
-	(setf *window-list* (delete hwin *window-list*))
-	hwin))))
-
-  
-;;; RANDOM-TYPEOUT-CLEANUP  --  Internal
-;;;
-;;;    Clean up after random typeout.  This just removes the window from
-;;; the screen and sets the more-prompt action back to normal.
-;;;
-(defun bitmap-random-typeout-cleanup (stream degree)
-  (when degree
-    (xlib:unmap-window (bitmap-hunk-xwindow
-			(window-hunk (random-typeout-stream-window stream))))))
-
-
-
-;;;; Initialization.
-
-;;; DEFAULT-CREATE-INITIAL-WINDOWS-HOOK makes the initial windows, main and
-;;; echo.  The main window is made according to "Default Initial Window X",
-;;; "Default Initial Window Y", "Default Initial Window Width", and "Default
-;;; Initial Window Height", prompting the user for any unspecified components.
-;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO is called to return the location and
-;;; size of the echo area including how big its font is, and the main xwindow
-;;; is potentially modified by this function.  The window name is set to get
-;;; around an awm and twm bug that inhibits menu clicks unless the window has a
-;;; name; this could be used better.
-;;;
-(defun default-create-initial-windows-hook (device)
-  (let ((root (xlib:screen-root (xlib:display-default-screen
-				 (bitmap-device-display device)))))
-    (let* ((xwindow (maybe-prompt-user-for-window
-		     root
-		     (value ed::default-initial-window-x)
-		     (value ed::default-initial-window-y)
-		     (value ed::default-initial-window-width)
-		     (value ed::default-initial-window-height)
-		     *default-font-family*
-		     t ;modelinep
-		     (value ed::thumb-bar-meter)
-		     "Hemlock")))
-      (setf (xlib:window-border xwindow) *highlight-border-pixmap*)
-      (let ((main-win (make-window (buffer-start-mark *current-buffer*)
-				   :device device
-				   :window xwindow)))
-	(multiple-value-bind
-	    (echo-x echo-y echo-width echo-height)
-	    (default-create-initial-windows-echo
-		(xlib:drawable-height root)
-		(window-hunk main-win))
-	  (let ((echo-xwin (make-echo-xwindow root echo-x echo-y echo-width
-					      echo-height)))
-	    (setf *echo-area-window*
-		  (hlet ((ed::thumb-bar-meter nil))
-		    (make-window
-		     (buffer-start-mark *echo-area-buffer*)
-		     :device device :modelinep t
-		     :window echo-xwin)))))
-	(setf *current-window* main-win)))))
-
-;;; DEFAULT-CREATE-INITIAL-WINDOWS-ECHO makes the echo area window as wide as
-;;; the main window and places it directly under it.  If the echo area does not
-;;; fit on the screen, we change the main window to make it fit.  There is
-;;; a problem in computing main-xwin's x and y relative to the root window
-;;; which is where we line up the echo and main windows.  Some losing window
-;;; managers (awm and twm) reparent the window, so we have to make sure
-;;; main-xwin's x and y are relative to the root and not some false parent.
-;;;
-(defun default-create-initial-windows-echo (full-height hunk)
-  (declare (fixnum full-height))
-  (let ((font-family (bitmap-hunk-font-family hunk))
-	(xwindow (bitmap-hunk-xwindow hunk))
-	(xparent (window-group-xparent (bitmap-hunk-window-group hunk))))
-    (xlib:with-state (xwindow)
-      (let ((w (xlib:drawable-width xwindow))
-	    (h (xlib:drawable-height xwindow)))
-	(declare (fixnum w h))
-	(multiple-value-bind (x y)
-			     (window-root-xy xwindow
-					     (xlib:drawable-x xwindow)
-					     (xlib:drawable-y xwindow))
-	  (declare (fixnum x y))
-	  (let* ((ff-height (font-family-height font-family))
-		 (ff-width (font-family-width font-family))
-		 (echo-height (+ (* ff-height 4)
-				 hunk-top-border hunk-bottom-border
-				 hunk-modeline-top hunk-modeline-bottom)))
-	    (declare (fixnum echo-height))
-	    (if (<= (+ y h echo-height xwindow-border-width*2) full-height)
-		(values x (+ y h xwindow-border-width*2)
-			w echo-height ff-width ff-height)
-		(let* ((newh (- full-height y echo-height xwindow-border-width*2
-				;; Since y is really the outside y, subtract
-				;; two more borders, so the echo area's borders
-				;; both appear on the screen.
-				xwindow-border-width*2)))
-		  (setf (xlib:drawable-height xparent) newh)
-		  (values x (+ y newh xwindow-border-width*2)
-			  w echo-height ff-width ff-height)))))))))
-
-(defvar *create-initial-windows-hook* #'default-create-initial-windows-hook
-  "Hemlock uses this function when it initializes the screen manager to make
-   the first windows, typically the main and echo area windows.  It takes a
-   Hemlock device as a required argument.  It sets *current-window* and
-   *echo-area-window*.")
-
-(defun make-echo-xwindow (root x y width height)
-  (let* ((font-width (font-family-width *default-font-family*))
-	 (font-height (font-family-height *default-font-family*)))
-    (create-window-with-properties root x y width height
-				   font-width font-height
-				   "Echo Area" nil nil t)))
-
-(defun init-bitmap-screen-manager (display)
-  ;;
-  ;; Setup stuff for X interaction.
-  (cond ((value ed::reverse-video)
-	 (setf *default-background-pixel*
-	       (xlib:screen-black-pixel (xlib:display-default-screen display)))
-	 (setf *default-foreground-pixel*
-	       (xlib:screen-white-pixel (xlib:display-default-screen display)))
-	 (setf *cursor-background-color* (make-black-color))
-	 (setf *cursor-foreground-color* (make-white-color))
-	 (setf *hack-hunk-replace-line* nil))
-	(t (setf *default-background-pixel*
-		 (xlib:screen-white-pixel (xlib:display-default-screen display)))
-	   (setf *default-foreground-pixel*
-		 (xlib:screen-black-pixel (xlib:display-default-screen display)))
-	   (setf *cursor-background-color* (make-white-color))
-	   (setf *cursor-foreground-color* (make-black-color))
-	   (setf *hack-hunk-replace-line* t)))
-  (setf *foreground-background-xor*
-	(logxor *default-foreground-pixel* *default-background-pixel*))
-  (setf *highlight-border-pixmap* *default-foreground-pixel*)
-  (setf *default-border-pixmap* (get-hemlock-grey-pixmap display))
-  (get-hemlock-cursor display)
-  (add-hook ed::make-window-hook 'define-window-cursor)
-  ;;
-  ;; Make the device for the rest of initialization.
-  (let ((device (make-default-bitmap-device display)))
-    ;;
-    ;; Create initial windows.
-    (funcall *create-initial-windows-hook* device)
-    ;;
-    ;; Setup random typeout over the user's main window.
-    (let ((xwindow (bitmap-hunk-xwindow (window-hunk *current-window*))))
-      (xlib:with-state (xwindow)
-	(multiple-value-bind (x y)
-			     (window-root-xy xwindow (xlib:drawable-x xwindow)
-					     (xlib:drawable-y xwindow))
-	  (setf *random-typeout-start-x* x)
-	  (setf *random-typeout-start-y* y))
-	(setf *random-typeout-start-width* (xlib:drawable-width xwindow)))))
-  (add-hook ed::window-buffer-hook 'set-window-name-for-window-buffer)
-  (add-hook ed::buffer-name-hook 'set-window-name-for-buffer-name)
-  (add-hook ed::set-window-hook 'set-window-hook-raise-fun)
-  (add-hook ed::buffer-modified-hook 'raise-echo-area-when-modified))
-
-(defun make-default-bitmap-device (display)
-  (make-bitmap-device
-   :name "Windowed Bitmap Device"
-   :init #'init-bitmap-device
-   :exit #'exit-bitmap-device
-   :smart-redisplay #'smart-window-redisplay
-   :dumb-redisplay #'dumb-window-redisplay
-   :after-redisplay #'bitmap-after-redisplay
-   :clear nil
-   :note-read-wait #'frob-cursor
-   :put-cursor #'hunk-show-cursor
-   :show-mark #'bitmap-show-mark
-   :next-window #'bitmap-next-window
-   :previous-window #'bitmap-previous-window
-   :make-window #'bitmap-make-window
-   :delete-window #'bitmap-delete-window
-   :force-output #'bitmap-force-output
-   :finish-output #'bitmap-finish-output
-   :random-typeout-setup #'bitmap-random-typeout-setup
-   :random-typeout-cleanup #'bitmap-random-typeout-cleanup
-   :random-typeout-full-more #'do-bitmap-full-more
-   :random-typeout-line-more #'update-bitmap-line-buffered-stream
-   :beep #'bitmap-beep
-   :display display))
-
-(defun init-bitmap-device (device)
-  (let ((display (bitmap-device-display device)))
-    (ext:flush-display-events display)
-    (hemlock-window display t)))
-
-(defun exit-bitmap-device (device)
-  (hemlock-window (bitmap-device-display device) nil))
-
-(defun bitmap-finish-output (device window)
-  (declare (ignore window))
-  (xlib:display-finish-output (bitmap-device-display device)))
-
-(defun bitmap-force-output ()
-  (xlib:display-force-output
-   (bitmap-device-display (device-hunk-device (window-hunk (current-window))))))
-
-(defun bitmap-after-redisplay (device)
-  (let ((display (bitmap-device-display device)))
-    (loop (unless (ext:object-set-event-handler display) (return)))))
-
-
-
-;;;; Miscellaneous.
-
-;;; HUNK-RESET is called in redisplay to make sure the hunk is up to date.
-;;; If the size is wrong, or it is trashed due to font changes, then we
-;;; call HUNK-CHANGED.  We also clear the hunk.
-;;;
-(defun hunk-reset (hunk)
-  (let ((xwindow (bitmap-hunk-xwindow hunk))
-	(trashed (bitmap-hunk-trashed hunk)))
-    (when trashed
-      (setf (bitmap-hunk-trashed hunk) nil)
-      (xlib:with-state (xwindow)
-	(let ((w (xlib:drawable-width xwindow))
-	      (h (xlib:drawable-height xwindow)))
-	  (when (or (/= w (bitmap-hunk-width hunk))
-		    (/= h (bitmap-hunk-height hunk))
-		    (eq trashed :font-change))
-	    (hunk-changed hunk w h nil)))))
-    (xlib:clear-area xwindow :width (bitmap-hunk-width hunk)
-		     :height (bitmap-hunk-height hunk))
-    (hunk-draw-bottom-border hunk)))
-
-;;; HUNK-CHANGED -- Internal.
-;;;
-;;; HUNK-RESET and the changed window handler call this.  Don't go through
-;;; REDISPLAY-WINDOW-ALL since the window changed handler updates the window
-;;; image.
-;;;
-(defun hunk-changed (hunk new-width new-height redisplay)
-  (set-hunk-size hunk new-width new-height)
-  (funcall (bitmap-hunk-changed-handler hunk) hunk)
-  (when redisplay (dumb-window-redisplay (bitmap-hunk-window hunk))))
-
-;;; WINDOW-GROUP-CHANGED -- Internal.
-;;;
-;;; HUNK-RECONFIGURED calls this when the hunk was a window-group.  This finds
-;;; the windows in the changed group, sorts them by their vertical stacking
-;;; order, and tries to resize the windows proportioned by their old sizes
-;;; relative to the old group size.  If that fails, this tries to make all the
-;;; windows the same size, dividing up the new group's size.
-;;;
-(defun window-group-changed (window-group new-width new-height)
-  (let ((xparent (window-group-xparent window-group))
-	(affected-windows nil)
-	(count 0)
-	(old-xparent-height (window-group-height window-group)))
-    (setf (window-group-width window-group) new-width)
-    (setf (window-group-height window-group) new-height)
-    (dolist (window *window-list*)
-      (let ((test (window-group-xparent (bitmap-hunk-window-group
-					 (window-hunk window)))))
-	(when (eq test xparent)
-	  (push window affected-windows)
-	  (incf count))))
-    ;; Probably shoulds insertion sort them, but I'm lame.
-    ;;
-    (xlib:with-state (xparent)
-      (sort affected-windows #'<
-	    :key #'(lambda (window)
-		     (xlib:drawable-y
-		      (bitmap-hunk-xwindow (window-hunk window))))))
-    (let ((start 0))
-      (declare (fixnum start))
-      (do ((windows affected-windows (cdr windows)))
-	  ((endp windows))
-	(let* ((xwindow (bitmap-hunk-xwindow (window-hunk (car windows))))
-	       (new-child-height (round
-				  (* new-height
-				     (/ (xlib:drawable-height xwindow)
-					old-xparent-height))))
-	       (hunk (window-hunk (car windows))))
-	  ;; If there is not enough room for one of the windows, space them out
-	  ;; evenly so there will be room.
-	  ;; 
-	  (when (< new-child-height (minimum-window-height
-				     (font-family-height
-				      (bitmap-hunk-font-family hunk))
-				     (bitmap-hunk-modeline-pos hunk)
-				     (bitmap-hunk-thumb-bar-p hunk)))
-	    (reconfigure-windows-evenly affected-windows new-width new-height)
-	    (return))
-	  (xlib:with-state (xwindow)
-	    (setf (xlib:drawable-y xwindow) start
-		  ;; Make the last window absorb or lose the number of pixels
-		  ;; lost in rounding.
-		  ;;
-		  (xlib:drawable-height xwindow) (if (cdr windows)
-						     new-child-height
-						     (- new-height start))
-		  (xlib:drawable-width xwindow) new-width
-		  start (+ start new-child-height 1))))))))
-
-(defun reconfigure-windows-evenly (affected-windows new-width new-height)
-  (let ((count (length affected-windows)))
-    (multiple-value-bind
-	(pixels-per-window remainder)
-	(truncate new-height count)
-      (let ((count-1 (1- count)))
-	(do ((windows affected-windows (cdr windows))
-	     (i 0 (1+ i)))
-	    ((endp windows))
-	  (let ((xwindow (bitmap-hunk-xwindow (window-hunk (car windows)))))
-	    (setf (xlib:drawable-y xwindow) (* i pixels-per-window))
-	    (setf (xlib:drawable-width xwindow) new-width)
-	    (if (= i count-1)
-		(return (setf (xlib:drawable-height
-			       (bitmap-hunk-xwindow
-				(window-hunk (car windows))))
-			      (+ pixels-per-window remainder)))
-		(setf (xlib:drawable-height xwindow) pixels-per-window))))))))
-
-;;; SET-HUNK-SIZE  --  Internal
-;;;
-;;;    Given a pixel size for a bitmap hunk, set the char size.  If the window
-;;; is too small, we refuse to admit it; if the user makes unreasonably small
-;;; windows, our only responsibity is to not blow up.  X will clip any stuff
-;;; that doesn't fit.
-;;;
-(defun set-hunk-size (hunk w h &optional modelinep)
-  (let* ((font-family (bitmap-hunk-font-family hunk))
-	 (font-width (font-family-width font-family))
-	 (font-height (font-family-height font-family)))
-    (setf (bitmap-hunk-height hunk) h)
-    (setf (bitmap-hunk-width hunk) w)
-    (setf (bitmap-hunk-char-width hunk)
-	  (max (truncate (- w hunk-left-border) font-width)
-	       minimum-window-columns))
-    (let* ((h-minus-borders (- h hunk-top-border
-			       (bitmap-hunk-bottom-border hunk)))
-	   (hwin (bitmap-hunk-window hunk))
-	   (modelinep (or modelinep (and hwin (window-modeline-buffer hwin)))))
-      (setf (bitmap-hunk-char-height hunk)
-	    (max (if modelinep
-		     (1- (truncate (- h-minus-borders
-				      hunk-modeline-top hunk-modeline-bottom)
-				   font-height))
-		     (truncate h-minus-borders font-height))
-		 minimum-window-lines))
-      (setf (bitmap-hunk-modeline-pos hunk)
-	    (if modelinep (- h font-height
-			     hunk-modeline-top hunk-modeline-bottom))))))
-
-;;; BITMAP-HUNK-BOTTOM-BORDER -- Internal.
-;;;
-(defun bitmap-hunk-bottom-border (hunk)
-  (if (bitmap-hunk-thumb-bar-p hunk)
-      hunk-thumb-bar-bottom-border
-      hunk-bottom-border))
-
-
-;;; DEFAULT-GCONTEXT is used when making hunks.
-;;;
-(defun default-gcontext (drawable &optional font-family)
-  (xlib:create-gcontext
-   :drawable drawable
-   :foreground *default-foreground-pixel*
-   :background *default-background-pixel*
-   :font (if font-family (svref (font-family-map font-family) 0))))
-
-
-;;; WINDOW-ROOT-XY returns the x and y coordinates for a window relative to
-;;; its root.  Some window managers reparent Hemlock's window, so we have
-;;; to mess around possibly to get this right.  If x and y are supplied, they
-;;; are relative to xwin's parent.
-;;;
-(defun window-root-xy (xwin &optional x y)
-  (multiple-value-bind (children parent root)
-		       (xlib:query-tree xwin)
-    (declare (ignore children))
-    (if (eq parent root)
-	(if (and x y)
-	    (values x y)
-	    (xlib:with-state (xwin)
-	      (values (xlib:drawable-x xwin) (xlib:drawable-y xwin))))
-	(multiple-value-bind
-	    (tx ty)
-	    (if (and x y)
-		(xlib:translate-coordinates parent x y root)
-		(xlib:with-state (xwin)
-		  (xlib:translate-coordinates
-		   parent (xlib:drawable-x xwin) (xlib:drawable-y xwin) root)))
-	  (values (- tx xwindow-border-width)
-		  (- ty xwindow-border-width))))))
-
-;;; CREATE-WINDOW-WITH-PROPERTIES makes an X window with parent.  X, y, w, and
-;;; h are possibly nil, so we supply zero in this case.  This would be used
-;;; for prompting the user.  Some standard properties are set to keep window
-;;; managers in line.  We name all windows because awm and twm window managers
-;;; refuse to honor menu clicks over windows without names.  Min-width and
-;;; min-height are optional and only used for prompting the user for a window.
-;;;
-(defun create-window-with-properties (parent x y w h font-width font-height
-				      icon-name
-				      &optional min-width min-height
-				      window-group-p)
-  (let* ((win (xlib:create-window
-	       :parent parent :x (or x 0) :y (or y 0)
-	       :width (or w 0) :height (or h 0)
-	       :background (if window-group-p :none *default-background-pixel*)
-	       :border-width (if window-group-p xwindow-border-width 0)
-	       :border (if window-group-p *default-border-pixmap* nil)
-	       :class :input-output)))
-    (xlib:set-wm-properties
-     win :name (new-hemlock-window-name) :icon-name icon-name
-     :resource-name "Hemlock"
-     :x x :y y :width w :height h
-     :user-specified-position-p t :user-specified-size-p t
-     :width-inc font-width :height-inc font-height
-     :min-width min-width :min-height min-height
-     ;; Tell OpenLook pseudo-X11 server we want input.
-     :input :on)
-    win))
-
-
-;;; SET-WINDOW-HOOK-RAISE-FUN is a "Set Window Hook" function controlled by
-;;; "Set Window Autoraise".  When autoraising, check that it isn't only the
-;;; echo area window that we autoraise; if it is only the echo area window,
-;;; then see if window is the echo area window.
-;;; 
-(defun set-window-hook-raise-fun (window)
-  (let ((auto (value ed::set-window-autoraise)))
-    (when (and auto
-	       (or (not (eq auto :echo-only))
-		   (eq window *echo-area-window*)))
-      (let* ((hunk (window-hunk window))
-	     (win (window-group-xparent (bitmap-hunk-window-group hunk))))
-	(xlib:map-window win)
-	(setf (xlib:window-priority win) :above)
-	(xlib:display-force-output
-	 (bitmap-device-display (device-hunk-device hunk)))))))
-
-
-;;; REVERSE-VIDEO-HOOK-FUN is called when the variable "Reverse Video" is set.
-;;; If we are running on a windowed bitmap, we first setup the default
-;;; foregrounds and backgrounds.  Having done that, we get a new cursor.  Then
-;;; we do over all the hunks, updating their graphics contexts, cursors, and
-;;; backgrounds.  The current window's border is given the new highlight pixmap.
-;;; Lastly, we update the random typeout hunk and redisplay everything.
-;;;
-(defun reverse-video-hook-fun (name kind where new-value)
-  (declare (ignore name kind where))
-  (when (windowed-monitor-p)
-    (let* ((current-window (current-window))
-	   (current-hunk (window-hunk current-window))
-	   (device (device-hunk-device current-hunk))
-	   (display (bitmap-device-display device)))
-      (cond
-       (new-value
-	(setf *default-background-pixel*
-	      (xlib:screen-black-pixel (xlib:display-default-screen display)))
-	(setf *default-foreground-pixel*
-	      (xlib:screen-white-pixel (xlib:display-default-screen display)))
-	(setf *cursor-background-color* (make-black-color))
-	(setf *cursor-foreground-color* (make-white-color))
-	(setf *hack-hunk-replace-line* nil))
-       (t (setf *default-background-pixel*
-		(xlib:screen-white-pixel (xlib:display-default-screen display)))
-	  (setf *default-foreground-pixel*
-		(xlib:screen-black-pixel (xlib:display-default-screen display)))
-	  (setf *cursor-background-color* (make-white-color))
-	  (setf *cursor-foreground-color* (make-black-color))
-	  (setf *hack-hunk-replace-line* t)))
-      (setf *highlight-border-pixmap* *default-foreground-pixel*)
-      (get-hemlock-cursor display)
-      (dolist (hunk (device-hunks device))
-	(reverse-video-frob-hunk hunk))
-      (dolist (rt-info *random-typeout-buffers*)
-	(reverse-video-frob-hunk
-	 (window-hunk (random-typeout-stream-window (cdr rt-info)))))
-      (setf (xlib:window-border (bitmap-hunk-xwindow current-hunk))
-	    *highlight-border-pixmap*))
-    (redisplay-all)))
-
-(defun reverse-video-frob-hunk (hunk)
-  (let ((gcontext (bitmap-hunk-gcontext hunk)))
-    (setf (xlib:gcontext-foreground gcontext) *default-foreground-pixel*)
-    (setf (xlib:gcontext-background gcontext) *default-background-pixel*))
-  (let ((xwin (bitmap-hunk-xwindow hunk)))
-    (setf (xlib:window-cursor xwin) *hemlock-cursor*)
-    (setf (xlib:window-background xwin) *default-background-pixel*)))
diff --git a/hemlock/bit-stream.lisp b/hemlock/bit-stream.lisp
deleted file mode 100644
index 051b06fd12c8770526d0eea2f5173ea39632acdc..0000000000000000000000000000000000000000
--- a/hemlock/bit-stream.lisp
+++ /dev/null
@@ -1,149 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/bit-stream.lisp,v 1.1.1.3 1991/11/09 03:05:30 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Some stuff to make streams that write out on bitmap hunks.
-;;;
-;;; Written by Rob MacLachlan.
-;;; Modified by Bill Chiles to run under X on the IBM RT.
-;;;
-(in-package 'hemlock-internals)
-
-
-;;; These streams have an associated bitmap-hunk that is used for its
-;;; font-family, foreground and background color, and X window pointer.
-;;; The hunk need not be associated with any Hemlock window, and the low
-;;; level painting routines that use hunk dimensions are not used for
-;;; output.  Only BITMAP-HUNK-WRITE-STRING is used.  The hunk is not
-;;; registered for any event service, so resizing the associated X window
-;;; does not invoke the exposed/changed handler in Bit-Screen.Lisp; also, the
-;;; hunk's input and changed handler slots are not set.
-;;;
-(defstruct (bitmap-hunk-output-stream (:include stream
-						(out #'bitmap-hunk-out)
-						(sout #'bitmap-hunk-sout)
-						(misc #'bitmap-hunk-misc))
-				      (:constructor
-				       make-bitmap-hunk-output-stream (hunk)))
-  hunk			; bitmap-hunk we display on.
-  (cursor-x 0)		; Character position of output cursor.
-  (cursor-y 0)
-  (buffer (make-string hunk-width-limit) :type simple-string)
-  (old-bottom 0))	; # of lines of scrolling before next "--More--" prompt.
-
-;;; Bitmap-Hunk-Stream-Newline  --  Internal
-;;;
-;;;    Flush the stream's output buffer and then move the cursor down
-;;; or scroll the window up if there is no room left.
-;;;
-(defun bitmap-hunk-stream-newline (stream)
-  (let* ((hunk (bitmap-hunk-output-stream-hunk stream))
-	 (height (bitmap-hunk-char-height hunk))
-	 (y (bitmap-hunk-output-stream-cursor-y stream)))
-    (when (zerop (bitmap-hunk-output-stream-old-bottom stream))
-      (hunk-write-string hunk 0 y "--More--" 0 8)
-      (let ((device (device-hunk-device hunk)))
-	(when (device-force-output device)
-	  (funcall (device-force-output device))))
-      (wait-for-more)
-      (hunk-clear-lines hunk y 1)
-      (setf (bitmap-hunk-output-stream-old-bottom stream) (1- height)))
-    (hunk-write-string hunk 0 y (bitmap-hunk-output-stream-buffer stream) 0 
-		       (bitmap-hunk-output-stream-cursor-x stream))
-    (setf (bitmap-hunk-output-stream-cursor-x stream) 0)
-    (decf (bitmap-hunk-output-stream-old-bottom stream))
-    (incf y)
-    (when (= y height)
-      (decf y)
-      (hunk-copy-lines hunk 1 0 y)
-      (hunk-clear-lines hunk y 1))
-    (setf (bitmap-hunk-output-stream-cursor-y stream) y)))
-
-;;; Bitmap-Hunk-Misc  --  Internal
-;;;
-;;;    This is the misc method for bitmap-hunk-output-streams.  It just
-;;; writes out the contents of the buffer, and does the element type.
-;;;
-(defun bitmap-hunk-misc (stream operation &optional arg1 arg2)
-  (declare (ignore arg1 arg2))
-  (case operation
-    (:charpos
-     (values (bitmap-hunk-output-stream-cursor-x stream)
-	     (bitmap-hunk-output-stream-cursor-y stream)))
-    ((:finish-output :force-output)
-     (hunk-write-string (bitmap-hunk-output-stream-hunk stream)
-			0 (bitmap-hunk-output-stream-cursor-y stream) 
-			(bitmap-hunk-output-stream-buffer stream) 0
-			(bitmap-hunk-output-stream-cursor-x stream))
-     (let ((device (device-hunk-device (bitmap-hunk-output-stream-hunk stream))))
-       (when (device-force-output device)
-	 (funcall (device-force-output device)))))
-    (:line-length
-     (bitmap-hunk-char-width (bitmap-hunk-output-stream-hunk stream)))
-    (:element-type 'base-char)))
-
-
-;;; Bitmap-Hunk-Out  --  Internal
-;;;
-;;;    Throw a character in a bitmap-hunk-stream's buffer.  If we wrap or hit a 
-;;; newline then call bitmap-hunk-stream-newline.
-;;;
-(defun bitmap-hunk-out (stream character)
-  (let ((hunk (bitmap-hunk-output-stream-hunk stream))
-	(x (bitmap-hunk-output-stream-cursor-x stream)))
-    (cond ((char= character #\newline)
-	   (bitmap-hunk-stream-newline stream)
-	   (return-from bitmap-hunk-out nil))
-	  ((= x (bitmap-hunk-char-width hunk))
-	   (setq x 0)
-	   (bitmap-hunk-stream-newline stream)))
-    (setf (schar (bitmap-hunk-output-stream-buffer stream) x) character)
-    (setf (bitmap-hunk-output-stream-cursor-x stream) (1+ x))))
-
-
-;;; Bitmap-Hunk-Sout  --  Internal
-;;;
-;;;    Write a string out to a bitmap-hunk, calling ourself recursively if the
-;;; string contains newlines.
-;;;
-(defun bitmap-hunk-sout (stream string start end)
-  (let* ((hunk (bitmap-hunk-output-stream-hunk stream))
-	 (buffer (bitmap-hunk-output-stream-buffer stream))
-	 (x (bitmap-hunk-output-stream-cursor-x stream))
-	 (dst-end (+ x (- end start)))
-	 (width (bitmap-hunk-char-width hunk)))
-    (cond ((%primitive find-character string start end #\newline)
-	   (do ((current (%primitive find-character string start end #\newline)
-			 (%primitive find-character string (1+ current)
-				     end #\newline))
-		(previous start (1+ current)))
-	       ((null current)
-		(bitmap-hunk-sout stream string previous end))
-	     (bitmap-hunk-sout stream string previous current)
-	     (bitmap-hunk-stream-newline stream)))
-	  ((> dst-end width)
-	   (let ((new-start (+ start (- width x))))
-	     (%primitive byte-blt string start buffer x width)
-	     (setf (bitmap-hunk-output-stream-cursor-x stream) width)
-	     (bitmap-hunk-stream-newline stream)
-	     (do ((idx (+ new-start width) (+ idx width))
-		  (prev new-start idx))
-		 ((>= idx end)
-		  (let ((dst-end (- end prev)))
-		    (%primitive byte-blt string prev buffer 0 dst-end)
-		    (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end)))
-	       (%primitive byte-blt string prev buffer 0 width)
-	       (setf (bitmap-hunk-output-stream-cursor-x stream) width)
-	       (bitmap-hunk-stream-newline stream))))
-	  (t
-	   (%primitive byte-blt string start buffer x dst-end)
-	   (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end)))))
diff --git a/hemlock/bufed.lisp b/hemlock/bufed.lisp
deleted file mode 100644
index e4b03fcffb7e77c2d7fb7e01cbd159656ffd8650..0000000000000000000000000000000000000000
--- a/hemlock/bufed.lisp
+++ /dev/null
@@ -1,288 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/bufed.lisp,v 1.2 1991/02/08 16:33:08 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains Bufed (Buffer Editing) code.
-;;;
-
-(in-package "HEMLOCK")
-
-
-
-;;;; Representation of existing buffers.
-
-;;; This is the array of buffers in the bufed buffer.  Each element is a cons,
-;;; where the CAR is the buffer, and the CDR indicates whether the buffer
-;;; should be deleted (t deleted, nil don't).
-;;;
-(defvar *bufed-buffers* nil)
-(defvar *bufed-buffers-end* nil)
-;;;
-(defmacro bufed-buffer (x) `(car ,x))
-(defmacro bufed-buffer-deleted (x) `(cdr ,x))
-(defmacro make-bufed-buffer (buffer) `(list ,buffer))
-
-
-;;; This is the bufed buffer if it exists.
-;;;
-(defvar *bufed-buffer* nil)
-
-;;; This is the cleanup method for deleting *bufed-buffer*.
-;;;
-(defun delete-bufed-buffers (buffer)
-  (when (eq buffer *bufed-buffer*)
-    (setf *bufed-buffer* nil)
-    (setf *bufed-buffers* nil)))
-
-
-
-;;;; Commands.
-
-(defmode "Bufed" :major-p t
-  :documentation
-  "Bufed allows the user to quickly save, goto, delete, etc., his buffers.")
-
-(defhvar "Virtual Buffer Deletion"
-  "When set, \"Bufed Delete\" marks a buffer for deletion instead of immediately
-   deleting it."
-  :value t)
-
-(defhvar "Bufed Delete Confirm"
-  "When set, \"Bufed\" commands that actually delete buffers ask for
-   confirmation before taking action."
-  :value t)
-
-(defcommand "Bufed Delete" (p)
-  "Delete the buffer.
-   Any windows displaying this buffer will display some other buffer."
-  "Delete the buffer indicated by the current line.  Any windows displaying this
-   buffer will display some other buffer."
-  (declare (ignore p))
-  (let* ((point (current-point))
-	 (buf-info (array-element-from-mark point *bufed-buffers*)))
-    (if (and (not (value virtual-buffer-deletion))
-	     (or (not (value bufed-delete-confirm))
-		 (prompt-for-y-or-n :prompt "Delete buffer? " :default t
-				    :must-exist t :default-string "Y")))
-	(delete-bufed-buffer (bufed-buffer buf-info))
-	(with-writable-buffer (*bufed-buffer*)
-	  (setf (bufed-buffer-deleted buf-info) t)
-	  (with-mark ((point point))
-	    (setf (next-character (line-start point)) #\D))))))
-
-(defcommand "Bufed Undelete" (p)
-  "Undelete the buffer.
-   Any windows displaying this buffer will display some other buffer."
-  "Undelete the buffer.  Any windows displaying this buffer will display some
-   other buffer."
-  (declare (ignore p))
-  (with-writable-buffer (*bufed-buffer*)
-    (setf (bufed-buffer-deleted (array-element-from-mark
-				 (current-point) *bufed-buffers*))
-	  nil)
-    (with-mark ((point (current-point)))
-      (setf (next-character (line-start point)) #\space))))
-
-(defcommand "Bufed Expunge" (p)
-  "Expunge buffers marked for deletion."
-  "Expunge buffers marked for deletion."
-  (declare (ignore p))
-  (expunge-bufed-buffers))
-
-(defcommand "Bufed Quit" (p)
-  "Kill the bufed buffer, expunging any buffer marked for deletion."
-  "Kill the bufed buffer, expunging any buffer marked for deletion."
-  (declare (ignore p))
-  (expunge-bufed-buffers)
-  (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*)))
-
-;;; EXPUNGE-BUFED-BUFFERS deletes the marked buffers in the bufed buffer,
-;;; signalling an error if the current buffer is not the bufed buffer.  This
-;;; returns t if it deletes some buffer, otherwise nil.  We build a list of
-;;; buffers before deleting any because the BUFED-DELETE-HOOK moves elements
-;;; around in *bufed-buffers*.
-;;;
-(defun expunge-bufed-buffers ()
-  (unless (eq *bufed-buffer* (current-buffer))
-    (editor-error "Not in the Bufed buffer."))
-  (let (buffers)
-    (dotimes (i *bufed-buffers-end*)
-      (let ((buf-info (svref *bufed-buffers* i)))
-	(when (bufed-buffer-deleted buf-info)
-	  (push (bufed-buffer buf-info) buffers))))
-    (if (and buffers
-	     (or (not (value bufed-delete-confirm))
-		 (prompt-for-y-or-n :prompt "Delete buffers? " :default t
-				    :must-exist t :default-string "Y")))
-	(dolist (b buffers t) (delete-bufed-buffer b)))))
-
-(defun delete-bufed-buffer (buf)
-  (when (and (buffer-modified buf)
-	     (prompt-for-y-or-n :prompt (list "~A is modified.  Save it first? "
-					      (buffer-name buf))))
-    (save-file-command nil buf))
-  (delete-buffer-if-possible buf))
-
-
-(defcommand "Bufed Goto" (p)
-  "Change to the buffer."
-  "Change to the buffer."
-  (declare (ignore p))
-  (change-to-buffer
-   (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*))))
-
-(defcommand "Bufed Goto and Quit" (p)
-  "Change to the buffer quitting Bufed.
-   This supplies a function for \"Generic Pointer Up\" which is a no-op."
-  "Change to the buffer quitting Bufed."
-  (declare (ignore p))
-  (expunge-bufed-buffers)
-  (point-to-here-command nil)
-  (change-to-buffer
-   (bufed-buffer (array-element-from-pointer-pos *bufed-buffers*
-		 "No buffer on that line.")))
-  (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*))
-  (supply-generic-pointer-up-function #'(lambda () nil)))
-
-(defcommand "Bufed Save File" (p)
-  "Save the buffer."
-  "Save the buffer."
-  (declare (ignore p))
-  (save-file-command
-   nil
-   (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*))))
-
-(defcommand "Bufed" (p)
-  "Creates a list of buffers in a buffer supporting operations such as deletion
-   and selection.  If there already is a bufed buffer, just go to it."
-  "Creates a list of buffers in a buffer supporting operations such as deletion
-   and selection.  If there already is a bufed buffer, just go to it."
-  (declare (ignore p))
-  (let ((buf (or *bufed-buffer*
-		 (make-buffer "Bufed" :modes '("Bufed")
-			      :delete-hook (list #'delete-bufed-buffers)))))
-
-    (unless *bufed-buffer*
-      (setf *bufed-buffer* buf)
-      (setf *bufed-buffers-end*
-	    ;; -1 echo, -1 bufed.
-	    (- (length (the list *buffer-list*)) 2))
-      (setf *bufed-buffers* (make-array *bufed-buffers-end*))
-      (setf (buffer-writable buf) t)
-      (with-output-to-mark (s (buffer-point buf))
-	(let ((i 0))
-	  (do-strings (n b *buffer-names*)
-	    (declare (simple-string n))
-	    (unless (or (eq b *echo-area-buffer*)
-			(eq b buf))
-	      (bufed-write-line b n s)
-	      (setf (svref *bufed-buffers* i) (make-bufed-buffer b))
-	      (incf i)))))
-      (setf (buffer-writable buf) nil)
-      (setf (buffer-modified buf) nil)
-      (let ((fields (buffer-modeline-fields *bufed-buffer*)))
-	(setf (cdr (last fields))
-	      (list (or (modeline-field :bufed-cmds)
-			(make-modeline-field
-			 :name :bufed-cmds :width 18
-			 :function
-			 #'(lambda (buffer window)
-			     (declare (ignore buffer window))
-			     "  Type ? for help.")))))
-	(setf (buffer-modeline-fields *bufed-buffer*) fields))
-      (buffer-start (buffer-point buf)))
-    (change-to-buffer buf)))
-
-(defun bufed-write-line (buffer name s
-		         &optional (buffer-pathname (buffer-pathname buffer)))
-  (let ((modified (buffer-modified buffer)))
-    (write-string (if modified " *" "  ") s)
-    (if buffer-pathname
-	(format s "~A  ~A~:[~50T~A~;~]~%"
-		(file-namestring buffer-pathname)
-		(directory-namestring buffer-pathname)
-		(string= (pathname-to-buffer-name buffer-pathname) name)
-		name)
-	(write-line name s))))
-
-
-(defcommand "Bufed Help" (p)
-  "Show this help."
-  "Show this help."
-  (declare (ignore p))
-  (describe-mode-command nil "Bufed"))
-
-
-
-;;;; Maintenance hooks.
-
-(eval-when (compile eval)
-(defmacro with-bufed-point ((point buffer &optional pos) &rest body)
-  (let ((pos (or pos (gensym))))
-    `(when (and *bufed-buffers*
-		(not (eq *bufed-buffer* ,buffer))
-		(not (eq *echo-area-buffer* ,buffer)))
-       (let ((,pos (position ,buffer *bufed-buffers* :key #'car
-			     :test #'eq :end *bufed-buffers-end*)))
-	 (unless ,pos (error "Unknown Bufed buffer."))
-	 (let ((,point (buffer-point *bufed-buffer*)))
-	   (unless (line-offset (buffer-start ,point) ,pos 0)
-	     (error "Bufed buffer not displayed?"))
-	   (with-writable-buffer (*bufed-buffer*) ,@body))))))
-) ;eval-when
-
-
-(defun bufed-modified-hook (buffer modified)
-  (with-bufed-point (point buffer)
-    (setf (next-character (mark-after point)) (if modified #\* #\space))))
-;;;
-(add-hook buffer-modified-hook 'bufed-modified-hook)
-
-(defun bufed-make-hook (buffer)
-  (declare (ignore buffer))
-  (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*)))
-;;;
-(add-hook make-buffer-hook 'bufed-make-hook)
-
-(defun bufed-delete-hook (buffer)
-  (with-bufed-point (point buffer pos)
-    (with-mark ((temp point :left-inserting))
-      (line-offset temp 1)
-      (delete-region (region point temp)))
-    (let ((len-1 (1- *bufed-buffers-end*)))
-      (replace *bufed-buffers* *bufed-buffers*
-	       :start1 pos :end1 len-1
-	       :start2 (1+ pos) :end1 *bufed-buffers-end*)
-      (setf (svref *bufed-buffers* len-1) nil)
-      (setf *bufed-buffers-end* len-1))))
-;;;
-(add-hook delete-buffer-hook 'bufed-delete-hook)
-
-(defun bufed-name-hook (buffer name)
-  (with-bufed-point (point buffer)
-    (with-mark ((temp point :left-inserting))
-      (line-offset temp 1)
-      (delete-region (region point temp)))
-    (with-output-to-mark (s point)
-      (bufed-write-line buffer name s))))
-;;;
-(add-hook buffer-name-hook 'bufed-name-hook)
-
-(defun bufed-pathname-hook (buffer pathname)
-  (with-bufed-point (point buffer)
-    (with-mark ((temp point :left-inserting))
-      (line-offset temp 1)
-      (delete-region (region point temp)))
-    (with-output-to-mark (s point)
-      (bufed-write-line buffer (buffer-name buffer) s pathname))))
-;;;
-(add-hook buffer-pathname-hook 'bufed-pathname-hook)
diff --git a/hemlock/buffer.lisp b/hemlock/buffer.lisp
deleted file mode 100644
index 8874328a7f96b88b17f61735bceb1c32e43dbb64..0000000000000000000000000000000000000000
--- a/hemlock/buffer.lisp
+++ /dev/null
@@ -1,630 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/buffer.lisp,v 1.3 1991/02/08 16:33:11 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Rob MacLachlan
-;;;
-;;; This file contains functions for changing modes and buffers.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(buffer-modified buffer-region buffer-name buffer-pathname
-	  buffer-major-mode buffer-minor-mode buffer-modeline-fields
-	  buffer-modeline-field-p current-buffer current-point
-	  in-recursive-edit exit-recursive-edit abort-recursive-edit
-	  recursive-edit defmode mode-major-p mode-variables mode-documentation
-	  make-buffer delete-buffer with-writable-buffer buffer-start-mark
-	  buffer-end-mark *buffer-list*))
-
-
-
-;;;; Some buffer structure support.
-
-(defun buffer-writable (buffer)
-  "Returns whether buffer may be modified."
-  (buffer-%writable buffer))
-
-(defun %set-buffer-writable (buffer value)
-  (invoke-hook ed::buffer-writable-hook buffer value)
-  (setf (buffer-%writable buffer) value))
-
-;;; BUFFER-MODIFIED uses the buffer modification tick which is for redisplay.
-;;; We can never set this down to "unmodify" a buffer, so we keep an
-;;; unmodification tick.  The buffer is modified only if this is less than the
-;;; modification tick.
-;;;
-(defun buffer-modified (buffer)
-  "Return T if Buffer has been modified, NIL otherwise.  Can be set with Setf."
-  (unless (bufferp buffer) (error "~S is not a buffer." buffer))
-  (> (buffer-modified-tick buffer) (buffer-unmodified-tick buffer)))
-
-(defun %set-buffer-modified (buffer sense)
-  "If true make the buffer modified, if NIL unmodified."
-  (unless (bufferp buffer) (error "~S is not a buffer." buffer))  
-  (invoke-hook ed::buffer-modified-hook buffer sense)
-  (if sense
-      (setf (buffer-modified-tick buffer) (tick))
-      (setf (buffer-unmodified-tick buffer) (tick)))
-  sense)
-
-
-(proclaim '(inline buffer-name buffer-pathname buffer-region))
-
-(defun buffer-region (buffer)
-  "Return the region which contains Buffer's text."
-  (buffer-%region buffer))
-
-(defun %set-buffer-region (buffer new-region)
-  (let ((old (buffer-region buffer)))
-    (delete-region old)
-    (ninsert-region (region-start old) new-region)
-    old))
-
-(defun buffer-name (buffer)
-  "Return Buffer's string name."
-  (buffer-%name buffer))
-
-(proclaim '(special *buffer-names*))
-
-(defun %set-buffer-name (buffer name)
-  (multiple-value-bind (entry foundp) (getstring name *buffer-names*)
-    (cond ((or (not foundp) (eq entry buffer))
-	   (invoke-hook ed::buffer-name-hook buffer name)
-	   (delete-string (buffer-%name buffer) *buffer-names*)
-	   (setf (getstring name *buffer-names*) buffer)
-	   (setf (buffer-%name buffer) name))
-	  (t (error "Cannot rename buffer ~S to ~S.  Name already in use."
-		    buffer name)))))
-
-(defun buffer-pathname (buffer)
-  "Return a pathname for the file in Buffer.  This is the truename
-  of the file as of the last time it was read or written."
-  (buffer-%pathname buffer))
-
-
-(defun %set-buffer-pathname (buffer pathname)
-  (invoke-hook ed::buffer-pathname-hook buffer pathname)
-  (setf (buffer-%pathname buffer) pathname))
-
-(defun buffer-modeline-fields (window)
-  "Return a copy of the buffer's modeline fields list."
-  (do ((finfos (buffer-%modeline-fields window) (cdr finfos))
-       (result () (cons (ml-field-info-field (car finfos)) result)))
-      ((null finfos) (nreverse result))))
-
-(defun %set-buffer-modeline-fields (buffer fields)
-  (check-type fields list)
-  (check-type buffer buffer "a Hemlock buffer")
-  (sub-set-buffer-modeline-fields buffer fields)
-  (dolist (w (buffer-windows buffer))
-    (update-modeline-fields buffer w)))
-
-(defun sub-set-buffer-modeline-fields (buffer modeline-fields)
-  (unless (every #'modeline-field-p modeline-fields)
-    (error "Fields must be a list of modeline-field objects."))
-  (setf (buffer-%modeline-fields buffer)
-	(do ((fields modeline-fields (cdr fields))
-	     (res nil (cons (make-ml-field-info (car fields))
-			    res)))
-	    ((null fields) (nreverse res)))))
-
-(defun buffer-modeline-field-p (buffer field)
-  "If field, a modeline-field or the name of one, is in buffer's list of
-   modeline-fields, it is returned; otherwise, nil."
-  (let ((finfo (internal-buffer-modeline-field-p buffer field)))
-    (if finfo (ml-field-info-field finfo))))
-
-(defun internal-buffer-modeline-field-p (buffer field)
-  (let ((fields (buffer-%modeline-fields buffer)))
-    (if (modeline-field-p field)
-	(find field fields :test #'eq :key #'ml-field-info-field)
-	(find field fields
-	      :key #'(lambda (f)
-		       (modeline-field-name (ml-field-info-field f)))))))
-
-
-
-;;;; Variable binding -- winding and unwinding.
-
-(eval-when (compile eval)
-
-(defmacro unbind-variable-bindings (bindings)
-  `(do ((binding ,bindings (binding-across binding)))
-       ((null binding))
-     (setf (car (binding-cons binding))
-	   (variable-object-down (binding-object binding)))))
-
-(defmacro bind-variable-bindings (bindings)
-  `(do ((binding ,bindings (binding-across binding)))
-       ((null binding))
-     (let ((cons (binding-cons binding))
-	   (object (binding-object binding)))
-       (setf (variable-object-down object) (car cons)
-	     (car cons) object))))
-
-) ;eval-when
-
-;;; UNWIND-BINDINGS  --  Internal
-;;;
-;;;    Unwind buffer variable bindings and all mode bindings up to and
-;;; including mode.  Return a list of the modes unwound in reverse order.
-;;; (buffer-mode-objects *current-buffer*) is clobbered.  If "mode" is NIL
-;;; unwind all bindings.
-;;;
-(defun unwind-bindings (mode)
-  (unbind-variable-bindings (buffer-var-values *current-buffer*))
-  (do ((curmode (buffer-mode-objects *current-buffer*))
-       (unwound ()) cw)
-      (())
-    (setf cw curmode  curmode (cdr curmode)  (cdr cw) unwound  unwound cw)
-    (unbind-variable-bindings (mode-object-var-values (car unwound)))
-    (when (or (null curmode) (eq (car unwound) mode))
-      (setf (buffer-mode-objects *current-buffer*) curmode)
-      (return unwound))))
-
-;;; WIND-BINDINGS  --  Internal
-;;;
-;;;    Add "modes" to the mode bindings currently in effect.
-;;;
-(defun wind-bindings (modes)
-  (do ((curmode (buffer-mode-objects *current-buffer*)) cw)
-      ((null modes) (setf (buffer-mode-objects *current-buffer*) curmode))
-    (bind-variable-bindings (mode-object-var-values (car modes)))
-    (setf cw modes  modes (cdr modes)  (cdr cw) curmode  curmode cw))
-  (bind-variable-bindings (buffer-var-values *current-buffer*)))
-
-
-
-;;;; BUFFER-MAJOR-MODE.
-
-(eval-when (compile eval)
-(defmacro with-mode-and-buffer ((name major-p buffer) &body forms)
-  `(let ((mode (get-mode-object name)))
-    (setq ,name (mode-object-name mode))
-    (,(if major-p 'unless 'when) (mode-object-major-p mode)
-      (error "~S is not a ~:[Minor~;Major~] Mode." ,name ,major-p))
-    (check-type ,buffer buffer)
-    ,@forms))
-) ;eval-when
-
-;;; BUFFER-MAJOR-MODE  --  Public
-;;;
-;;;    The major mode is the first on the list, so just return that.
-;;;
-(defun buffer-major-mode (buffer)
-  "Return the name of Buffer's major mode.  To change tha major mode
-  use Setf."
-  (check-type buffer buffer)
-  (car (buffer-modes buffer)))
-
-;;; %SET-BUFFER-MAJOR-MODE  --  Public
-;;;
-;;;    Unwind all modes in effect and add the major mode specified.
-;;;Note that BUFFER-MODE-OBJECTS is in order of invocation in buffers
-;;;other than the current buffer, and in the reverse order in the
-;;;current buffer.
-;;;
-(defun %set-buffer-major-mode (buffer name)
-  "Set the major mode of some buffer to the Name'd mode."
-  (with-mode-and-buffer (name t buffer)
-    (invoke-hook ed::buffer-major-mode-hook buffer name)
-    (cond
-     ((eq buffer *current-buffer*)
-      (let ((old-mode (car (last (buffer-mode-objects buffer)))))
-	(invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
-	(funcall (mode-object-cleanup-function old-mode) buffer)
-	(swap-char-attributes old-mode)
-	(wind-bindings (cons mode (cdr (unwind-bindings old-mode))))
-	(swap-char-attributes mode)))
-     (t
-      (let ((old-mode (car (buffer-mode-objects buffer))))
-	(invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
-	(funcall (mode-object-cleanup-function old-mode) buffer))
-      (setf (car (buffer-mode-objects buffer)) mode)))
-    (setf (car (buffer-modes buffer)) name)
-    (funcall (mode-object-setup-function mode) buffer)
-    (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
-  nil)
-
-
-
-;;;; BUFFER-MINOR-MODE.
-
-;;; BUFFER-MINOR-MODE  --  Public
-;;;
-;;;    Check if the mode-object is in the buffer's mode-list.
-;;;
-(defun buffer-minor-mode (buffer name)
-  "Return true if the minor mode named Name is active in Buffer.
-  A minor mode can be turned on or off with Setf."
-  (with-mode-and-buffer (name nil buffer)
-    (not (null (memq mode (buffer-mode-objects buffer))))))
-    
-(proclaim '(special *mode-names*))
-
-;;; %SET-BUFFER-MINOR-MODE  --  Public
-;;;
-;;;    Activate or deactivate a minor mode, with due respect for
-;;; bindings.
-;;;
-(defun %set-buffer-minor-mode (buffer name new-value)
-  (let ((objects (buffer-mode-objects buffer)))    
-    (with-mode-and-buffer (name nil buffer)
-      (invoke-hook ed::buffer-minor-mode-hook buffer name new-value)
-      (cond
-       ;; Already there or not there, nothing to do.
-       ((if (memq mode (buffer-mode-objects buffer)) new-value (not new-value)))
-       ;; Adding a new mode.
-       (new-value
-	(cond
-	 ((eq buffer *current-buffer*)
-	  ;;
-	  ;; Unwind bindings having higher precedence, cons on the new
-	  ;; mode and then wind them back on again.
-	  (do ((m objects (cdr m))
-	       (prev nil (car m)))
-	      ((or (null (cdr m))
-		   (< (mode-object-precedence (car m))
-		      (mode-object-precedence mode)))
-	       (wind-bindings
-		(cons mode (if prev
-			       (unwind-bindings prev)
-			       (unbind-variable-bindings
-				(buffer-var-values *current-buffer*))))))))
-	 (t
-	  (do ((m (cdr objects) (cdr m))
-	       (prev objects m))
-	      ((or (null m)
-		   (>= (mode-object-precedence (car m))
-		       (mode-object-precedence mode)))
-	       (setf (cdr prev) (cons mode m))))))
-	;;
-	;; Add the mode name.
-	(let ((bm (buffer-modes buffer)))
-	  (setf (cdr bm)
-		(merge 'list (cdr bm) (list name) #'<  :key
-		       #'(lambda (x)
-			   (mode-object-precedence (getstring x *mode-names*))))))
-
-	(funcall (mode-object-setup-function mode) buffer)
-	(invoke-hook (%value (mode-object-hook-name mode)) buffer t))
-       (t
-	;; Removing an active mode.
-	(invoke-hook (%value (mode-object-hook-name mode)) buffer nil)
-	(funcall (mode-object-cleanup-function mode) buffer)
-	;; In the current buffer, unwind buffer and any mode bindings on top
-	;; pop off the mode and wind the rest back on.
-	(cond ((eq buffer *current-buffer*)
-	       (wind-bindings (cdr (unwind-bindings mode))))
-	      (t
-	       (setf (buffer-mode-objects buffer)
-		     (delq mode (buffer-mode-objects buffer)))))
-	;; We always use the same string, so we can delq it (How Tense!)
-	(setf (buffer-modes buffer) (delq name (buffer-modes buffer))))))
-  new-value))
-
-
-
-;;;; CURRENT-BUFFER, CURRENT-POINT, and buffer using setup and cleanup.
-
-(proclaim '(inline current-buffer))
-
-(defun current-buffer () "Return the current buffer object." *current-buffer*)
-
-(defun current-point ()
-  "Return the Buffer-Point of the current buffer."
-  (buffer-point *current-buffer*))
-
-;;; %SET-CURRENT-BUFFER  --  Internal
-;;;
-;;;    Undo previous buffer and mode specific variables and character 
-;;;attributes and set up the new ones.  Set *current-buffer*.
-;;;
-(defun %set-current-buffer (buffer)
-  (let ((old-buffer *current-buffer*))
-    (check-type buffer buffer)
-    (invoke-hook ed::set-buffer-hook buffer)
-    ;; Undo old bindings.
-    (setf (buffer-mode-objects *current-buffer*)
-	  (unwind-bindings nil))
-    (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
-    (setq *current-buffer* buffer)
-    (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
-    ;; Make new bindings.
-    (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil))
-    (invoke-hook ed::after-set-buffer-hook old-buffer))
-  buffer)
-
-;;; USE-BUFFER-SET-UP  --  Internal
-;;;
-;;;    This function is called by the use-buffer macro to wind on the
-;;; new buffer's variable and key bindings and character attributes.
-;;;
-(defun use-buffer-set-up (old-buffer)
-  (unless (eq old-buffer *current-buffer*)
-    ;; Let new char attributes overlay old ones.
-    (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
-    ;; Wind on bindings of new current buffer.
-    (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil))))
-
-;;; USE-BUFFER-CLEAN-UP  --  Internal
-;;;
-;;;    This function is called by use-buffer to clean up after it is done.
-;;;
-(defun use-buffer-clean-up (old-buffer)
-  (unless (eq old-buffer *current-buffer*)
-    ;; When we leave, unwind the bindings,
-    (setf (buffer-mode-objects *current-buffer*) (unwind-bindings nil))
-    ;; Restore the character attributes,
-    (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))))
-
-
-
-;;;; Recursive editing.
-
-(defvar *in-a-recursive-edit* nil "True if we are in a recursive edit.")
-
-(proclaim '(inline in-recursive-edit))
-
-(defun in-recursive-edit ()
-  "Returns whether the calling point is dynamically within a recursive edit
-   context."
-  *in-a-recursive-edit*)
-
-;;; RECURSIVE-EDIT  --  Public
-;;;
-;;;    Call the command interpreter recursively, winding on new state as 
-;;; necessary. 
-;;;
-(defun recursive-edit (&optional (handle-abort t))
-  "Call the command interpreter recursively.  If Handle-Abort is true
-  then an abort caused by a control-g or a lisp error does not cause
-  the recursive edit to be aborted."
-  (invoke-hook ed::enter-recursive-edit-hook)
-  (multiple-value-bind (flag args)
-		       (let ((*in-a-recursive-edit* t))
-			 (catch 'leave-recursive-edit
-			   (if handle-abort
-			       (loop (catch 'editor-top-level-catcher
-				       (%command-loop)))
-			       (%command-loop))))
-    (case flag
-      (:abort (apply #'editor-error args))
-      (:exit (values-list args))
-      (t (error "Bad thing ~S thrown out of recursive edit." flag)))))
-
-;;; EXIT-RECURSIVE-EDIT is intended to be called within the dynamic context
-;;; of RECURSIVE-EDIT, causing return from that function with values returned
-;;; as multiple values.  When not in a recursive edit, signal an error.
-;;; 
-(defun exit-recursive-edit (&optional values)
-  "Exit from a recursive edit.  Values is a list of things which are
-   to be the return values from Recursive-Edit."
-  (unless *in-a-recursive-edit*
-    (error "Not in a recursive edit!"))
-  (invoke-hook ed::exit-recursive-edit-hook values)
-  (throw 'leave-recursive-edit (values :exit values)))
-
-;;; ABORT-RECURSIVE-EDIT is intended to be called within the dynamic context
-;;; of RECURSIVE-EDIT, causing EDITOR-ERROR to be called on args.  When not
-;;; in a recursive edit, signal an error.
-;;; 
-(defun abort-recursive-edit (&rest args)
-  "Abort a recursive edit, causing an Editor-Error with the args given in
-   the calling context."
-  (unless *in-a-recursive-edit* 
-    (error "Not in a recursive edit!"))
-  (invoke-hook ed::abort-recursive-edit-hook args)
-  (throw 'leave-recursive-edit (values :abort args)))
-
-
-
-;;;; WITH-WRITABLE-BUFFER
-
-;;; This list indicates recursive use of WITH-WRITABLE-BUFFER on the same
-;;; buffer.
-;;;
-(defvar *writable-buffers* ())
-
-(defmacro with-writable-buffer ((buffer) &body body)
-  "Executes body in a scope where buffer is writable.  After body executes,
-   this sets the buffer's modified and writable status to nil."
-  (let ((buf (gensym))
-	(no-unwind (gensym)))
-    `(let* ((,buf ,buffer)
-	    (,no-unwind (member ,buf *writable-buffers* :test #'eq))
-	    (*writable-buffers* (if ,no-unwind
-				    *writable-buffers*
-				    (cons ,buf *writable-buffers*))))
-       (unwind-protect
-	   (progn
-	     (setf (buffer-writable ,buf) t)
-	     ,@body)
-	 (unless ,no-unwind
-	   (setf (buffer-modified ,buf) nil)
-	   (setf (buffer-writable ,buf) nil))))))
-
-
-
-;;;; DEFMODE.
-
-(defun defmode (name &key (setup-function #'identity) 
-		     (cleanup-function #'identity) major-p transparent-p
-		     precedence documentation)
-  "Define a new mode, specifying whether it is a major mode, and what the
-   setup and cleanup functions are.  Precedence, which defaults to 0.0, and is
-   any integer or float, determines the order of the minor modes in a buffer.
-   A minor mode having a greater precedence is always considered before a mode
-   with lesser precedence when searching for key-bindings and variable values.
-   If Transparent-p is true, then all key-bindings local to the defined mode
-   are transparent, meaning that they do not shadow other bindings, but rather
-   are executed in addition to them.  Documentation is used as introductory
-   text for mode describing commands."
-  (let ((hook-str (concatenate 'string name " Mode Hook"))
-	(mode (getstring name *mode-names*)))
-    (cond
-     (mode
-      (when (if major-p
-		(not (mode-object-major-p mode))
-		(mode-object-major-p mode))
-	(cerror "Let bad things happen"
-		"Mode ~S is being redefined as a ~:[Minor~;Major~] mode ~
-		where it was ~%~
-		previously a ~:*~:[Major~;Minor~] mode." name major-p))
-      (warn "Mode ~S is being redefined, variables and bindings will ~
-	    be preserved." name)
-      (setq name (mode-object-name mode)))
-     (t
-      (defhvar hook-str
-	       (concatenate 'string "This is the mode hook variable for "
-	       name " Mode."))
-      (setq mode (make-mode-object
-		  :variables (make-string-table)
-		  :bindings (make-hash-table)
-		  :hook-name (getstring hook-str *global-variable-names*)))
-      (setf (getstring name *mode-names*) mode)))
-
-    (if precedence
-	(if major-p
-	    (error "Precedence ~S is meaningless for a major mode." precedence)
-	    (check-type precedence number))
-	(setq precedence 0))
-    
-    (setf (mode-object-major-p mode) major-p
-	  (mode-object-documentation mode) documentation
-	  (mode-object-transparent-p mode) transparent-p
-	  (mode-object-precedence mode) precedence
-	  (mode-object-setup-function mode) setup-function
-	  (mode-object-cleanup-function mode) cleanup-function
-	  (mode-object-name mode) name))
-  nil)
-
-(defun mode-major-p (name)
-  "Returns T if Name is the name of a major mode, or NIL if is the name of
-  a minor mode."
-  (mode-object-major-p (get-mode-object name)))
-
-(defun mode-variables (name)
-  "Return the string-table that contains the names of the modes variables."
-  (mode-object-variables (get-mode-object name)))
-
-(defun mode-documentation (name)
-  "Returns the documentation for mode with name."
-  (mode-object-documentation (get-mode-object name)))
-
-
-
-;;;; Making and Deleting buffers.
-
-(defvar *buffer-list* () "A list of all the buffer objects.")
-
-(defvar *current-buffer* ()
-  "Internal variable which might contain the current buffer." )
-
-(defun make-buffer (name &key (modes (value ed::default-modes))
-			      (modeline-fields
-			       (value ed::default-modeline-fields))
-			      delete-hook)
-  "Creates and returns a buffer with the given Name if a buffer with Name does
-   not already exist, otherwise returns nil.  Modes is a list of mode names,
-   and Modeline-fields is a list of modeline field objects.  Delete-hook is a
-   list of functions that take a buffer as the argument."
-  (cond ((getstring name *buffer-names*) nil)
-	(t
-	 (unless (listp delete-hook)
-	   (error ":delete-hook is a list of functions -- ~S." delete-hook))
-	 (let* ((region (make-empty-region))
-		(object (getstring "Fundamental" *mode-names*))
-		(buffer (internal-make-buffer
-			 :%name name
-			 :%region region
-			 :modes (list (mode-object-name object))
-			 :mode-objects (list object)
-			 :bindings (make-hash-table)
-			 :point (copy-mark (region-end region))
-			 :display-start (copy-mark (region-start region))
-			 :delete-hook delete-hook
-			 :variables (make-string-table))))
-	   (sub-set-buffer-modeline-fields buffer modeline-fields)
-	   (setf (line-%buffer (mark-line (region-start region))) buffer)
-	   (push buffer *buffer-list*)
-	   (setf (getstring name *buffer-names*) buffer)
-	   (unless (equalp modes '("Fundamental"))
-	     (setf (buffer-major-mode buffer) (car modes))
-	     (dolist (m (cdr modes))
-	       (setf (buffer-minor-mode buffer m) t)))
-	   (invoke-hook ed::make-buffer-hook buffer)
-	   buffer))))
-
-(defun delete-buffer (buffer)
-  "Deletes a buffer.  If buffer is current, or if it is displayed in any
-   windows, an error is signaled."
-  (when (eq buffer *current-buffer*)
-    (error "Cannot delete current buffer ~S." buffer))
-  (when (buffer-windows buffer)
-    (error "Cannot delete buffer ~S, which is displayed in ~R window~:P."
-	   buffer (length (buffer-windows buffer))))
-  (invoke-hook (buffer-delete-hook buffer) buffer)
-  (invoke-hook ed::delete-buffer-hook buffer)
-  (setq *buffer-list* (delq buffer *buffer-list*))
-  (delete-string (buffer-name buffer) *buffer-names*)
-  nil)
-
-
-
-;;;; Buffer start and end marks.
-
-(defun buffer-start-mark (buffer)
-  "Returns the buffer-region's start mark."
-  (region-start (buffer-region buffer)))
-
-(defun buffer-end-mark (buffer)
-  "Returns the buffer-region's end mark."
-  (region-end (buffer-region buffer)))
-
-
-
-;;;; Setting up initial buffer.
-
-;;; SETUP-INITIAL-BUFFER  --  Internal
-;;;
-;;;    Create the buffer "Main" and the mode "Fundamental".  We make a
-;;; dummy fundamental mode before we make the buffer Main, because
-;;; "make-buffer" wants fundamental to be defined when it is called, and we
-;;; can't make the real fundamental mode until there is a current buffer
-;;; because "defmode" wants to invoke it's mode definition hook.  Also,
-;;; when creating the "Main" buffer, "Default Modeline Fields" is not yet
-;;; defined, so we supply this argument to MAKE-BUFFER as nil.  This is
-;;; fine since firing up the editor in a core must set the "Main" buffer's
-;;; modeline according to this variable in case the user changed it in his
-;;; init file.  After the main buffer is created we then define the real
-;;; fundamental mode and bash it into the buffer.
-;;;
-(defun setup-initial-buffer ()
-  ;; Make it look like the mode is there so make-buffer doesn't die.
-  (setf (getstring "Fundamental" *mode-names*)
-	(make-mode-object :major-p t))
-  ;; Make it look like there is a make-buffer-hook...
-  (setf (get 'ed::make-buffer-hook 'hemlock-variable-value)
-	(make-variable-object "foo" "bar"))
-  (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental")
-				      :modeline-fields nil))
-  ;; Make the bogus variable go away...
-  (remf (symbol-plist 'ed::make-buffer-hook) 'hemlock-variable-value)
-  ;; Make it go away so defmode doesn't die.
-  (setf (getstring "Fundamental" *mode-names*) nil)
-  (defmode "Fundamental" :major-p t)
-  ;; Bash the real mode object into the buffer.
-  (let ((obj (getstring "Fundamental" *mode-names*)))
-    (setf (car (buffer-mode-objects *current-buffer*)) obj
-	  (car (buffer-modes *current-buffer*)) (mode-object-name obj))))
diff --git a/hemlock/charmacs.lisp b/hemlock/charmacs.lisp
deleted file mode 100644
index 8f21fc1710aecace44f7e8192220c34f975e83bb..0000000000000000000000000000000000000000
--- a/hemlock/charmacs.lisp
+++ /dev/null
@@ -1,118 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;; Implementation specific character-hacking macros and constants.
-;;;
-(in-package 'hemlock-internals)
-(export ' (syntax-char-code-limit command-char-bits-limit
-	   command-char-code-limit search-char-code-limit
-	   do-alpha-chars))
-
-;;; This file contains various constants and macros which are
-;;; implementation or ASCII dependant.  In particular it contains
-;;; all the character implementation parameters such as
-;;; Command-Char-Bits-Limit, and contains various versions
-;;; of char-code which don't check types and omit the top bit
-;;; so that various structures can be allocated 128 long instead
-;;; of 256, and we don't get errors if a loser visits a binary file.
-
-;;; There are so many different constants and macros that do the same
-;;; thing because in principle the char-code-limit for the syntax
-;;; functions is independant of that for the searching functions, etc.
-
-;;; This file also contains code which adds any implementation specific
-;;; character names to the char file's Char-Name-Alist so that there
-;;; is a reasonable read-syntax and print-representation for all
-;;; characters a user might run across.
-
-
-;;;; Stuff for the Syntax table functions (syntax)
-
-(defconstant syntax-char-code-limit 128
-  "The highest char-code which a character argument to the syntax
-  table functions may have.")
-(defconstant syntax-char-code-mask #x+7f
-  "Mask we AND with characters given to syntax table functions to blow away
-  bits we don't want.")
-(defmacro syntax-char-code (char)
-  `(logand syntax-char-code-mask (lisp::%sp-make-fixnum ,char)))
-
-;;;; Stuff for the command interpreter (interp)
-;;;
-;;;    On the Perq we have bits for command bindings, on the VAX there 
-;;; aren't.  The code to interpret them is conditionally compiled
-;;; so that the VAX isnt't slowed down.
-;;;
-;;; Make command-char-code-limit 256 instead of 128 for X keyboard scan-codes.
-(defconstant command-char-code-limit 256
-  "The upper bound on character codes supported for key bindings.")
-(defconstant command-char-bits-limit 16
-  "The maximum value of character bits supported for key bindings.")
-(defmacro key-char-bits (char)
-  `(ash (logand #x+F00 (lisp::%sp-make-fixnum ,char)) -8))
-(defmacro key-char-code (char)
-  `(char-code ,char))
-;;; `(logand #x+7f (lisp::%sp-make-fixnum ,char))) can't use with X scan-codes.
-
-
-;;;; Stuff used by the searching primitives (search)
-;;;
-(defconstant search-char-code-limit 128
-  "The exclusive upper bound on significant char-codes for searching.")
-(defmacro search-char-code (ch)
-  `(logand (lisp::%sp-make-fixnum ,ch) #x+7F))
-;;;
-;;;    search-hash-code must be a function with the following properties:
-;;; given any character it returns a number between 0 and 
-;;; search-char-code-limit, and the same hash code must be returned 
-;;; for the upper and lower case forms of each character.
-;;;    In ASCII this is can be done by ANDing out the 5'th bit.
-;;;
-(defmacro search-hash-code (ch)
-  `(logand (lisp::%sp-make-fixnum ,ch) #x+5F))
-
-;;; Doesn't do anything special, but it should fast and not waste any time
-;;; checking type and whatnot.
-(defmacro search-char-upcase (ch)
-  `(lisp::fast-char-upcase ,ch))
-
-
-
-;;;; DO-ALPHA-CHARS.
-
-;;; ALPHA-CHARS-LOOP loops from start-char through end-char binding var
-;;; to the alphabetic characters and executing body.  Note that the manual
-;;; guarantees lower and upper case char codes to be separately in order,
-;;; but other characters may be interspersed within that ordering.
-(defmacro alpha-chars-loop (var start-char end-char result body)
-  (let ((n (gensym))
-	(end-char-code (gensym)))
-    `(do ((,n (char-code ,start-char) (1+ ,n))
-	  (,end-char-code (char-code ,end-char)))
-	 ((> ,n ,end-char-code) ,result)
-       (let ((,var (code-char ,n)))
-	 (when (alpha-char-p ,var)
-	   ,@body)))))
-
-(defmacro do-alpha-chars ((var kind &optional result) &rest forms)
-  "(do-alpha-chars (var kind [result]) . body).  Kind is one of
-   :lower, :upper, or :both, and var is bound to each character in
-   order as specified under character relations in the manual.  When
-   :both is specified, lowercase letters are processed first."
-  (case kind
-    (:both
-     `(progn (alpha-chars-loop ,var #\a #\z nil ,forms)
-	     (alpha-chars-loop ,var #\A #\Z ,result ,forms)))
-    (:lower
-     `(alpha-chars-loop ,var #\a #\z ,result ,forms))
-    (:upper
-     `(alpha-chars-loop ,var #\A #\Z ,result ,forms))
-    (t (error "Kind argument not one of :lower, :upper, or :both -- ~S."
-	      kind))))
diff --git a/hemlock/command.lisp b/hemlock/command.lisp
deleted file mode 100644
index dd2722f4616d0afdf616a36989b732d3baac9cd4..0000000000000000000000000000000000000000
--- a/hemlock/command.lisp
+++ /dev/null
@@ -1,490 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/command.lisp,v 1.6 1991/05/22 14:45:32 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the definitions for the basic Hemlock commands.
-;;;
-
-(in-package "HEMLOCK")
-
-
-;;; Make a mark for buffers as they're consed:
-
-(defun hcmd-new-buffer-hook-fun (buff)
-  (let ((ring (make-ring 10 #'delete-mark)))
-    (defhvar "Buffer Mark Ring" 
-      "This variable holds this buffer's mark ring."
-      :buffer buff
-      :value ring)
-    (ring-push (copy-mark (buffer-point buff) :right-inserting) ring)))
-
-(add-hook make-buffer-hook #'hcmd-new-buffer-hook-fun)
-(dolist (buff *buffer-list*) (hcmd-new-buffer-hook-fun buff)))
-
-(defcommand "Exit Hemlock" (p)
-  "Exit hemlock returning to the Lisp top-level read-eval-print loop."
-  "Exit hemlock returning to the Lisp top-level read-eval-print loop."
-  (declare (ignore p))
-  (exit-hemlock))
-
-(defcommand "Pause Hemlock" (p)
-  "Pause the Hemlock/Lisp process returning to the process that invoked the
-   Lisp."
-  "Pause the Hemlock/Lisp process returning to the process that invoked the
-   Lisp."
-  (declare (ignore p))
-  (pause-hemlock))
-
-
-
-;;;; Simple character manipulation:
-
-(defcommand "Self Insert" (p)
-  "Insert the last character typed.
-  With prefix argument insert the character that many times."
-  "Implements ``Self Insert'', calling this function is not meaningful."
-  (let ((char (ext:key-event-char *last-key-event-typed*)))
-    (unless char (editor-error "Can't insert that character."))
-    (if (and p (> p 1))
-	(insert-string
-	 (current-point)
-	 (make-string p :initial-element char))
-	(insert-character (current-point) char))))
-
-(defcommand "Quoted Insert" (p)
-  "Read a character from the terminal and insert it.
-  With prefix argument, insert the character that many times."
-  "Reads a key-event from *editor-input* and inserts it at the point."
-  (let ((char (ext:key-event-char (get-key-event *editor-input* t)))
-	(point (current-point)))
-    (unless char (editor-error "Can't insert that character."))
-    (if (and p (> p 1))
-	(insert-string point (make-string p :initial-element char))
-	(insert-character point char))))
-
-(defcommand "Forward Character" (p)
-  "Move the point forward one character.
-   With prefix argument move that many characters, with negative argument
-   go backwards."
-  "Move the point of the current buffer forward p characters."
-  (let ((p (or p 1)))
-    (cond ((character-offset (current-point) p))
-	  ((= p 1)
-	   (editor-error "No next character."))
-	  ((= p -1)
-	   (editor-error "No previous character."))
-	  (t
-	   (if (plusp p)
-	       (buffer-end (current-point))
-	       (buffer-start (current-point)))
-	   (editor-error "Not enough characters.")))))
-
-(defcommand "Backward Character" (p)
-  "Move the point backward one character.
-  With prefix argument move that many characters backward."
-  "Move the point p characters backward."
-  (forward-character-command (if p (- p) -1)))
-
-#|
-(defcommand "Delete Next Character" (p)
-  "Deletes the character to the right of the point.
-  With prefix argument, delete that many characters to the right
-  (or left if prefix is negative)."
-  "Deletes p characters to the right of the point."
-  (unless (delete-characters (current-point) (or p 1))
-    (buffer-end (current-point))
-    (editor-error "No next character.")))
-
-(defcommand "Delete Previous Character" (p)
-  "Deletes the character to the left of the point.
-  With prefix argument, delete that many characters to the left 
-  (or right if prefix is negative)."
-  "Deletes p characters to the left of the point."
-  (unless (delete-characters (current-point) (if p (- p) -1))
-    (editor-error "No previous character.")))
-|#
-
-(defcommand "Delete Next Character" (p)
-  "Deletes the character to the right of the point.
-   With prefix argument, delete that many characters to the right
-  (or left if prefix is negative)."
-  "Deletes p characters to the right of the point."
-  (cond ((kill-characters (current-point) (or p 1)))
-	((and p (minusp p))
-	 (editor-error "Not enough previous characters."))
-	(t
-	 (editor-error "Not enough next characters."))))
-
-(defcommand "Delete Previous Character" (p)
-  "Deletes the character to the left of the point.
-   Will push characters from successive deletes on to the kill ring."
-  "Deletes the character to the left of the point.
-   Will push characters from successive deletes on to the kill ring."
-  (delete-next-character-command (- (or p 1))))
-
-(defcommand "Transpose Characters" (p)
-  "Exchanges the characters on either side of the point and moves forward
-  With prefix argument, does this that many times.  A negative prefix
-  argument causes the point to be moved backwards instead of forwards."
-  "Exchanges the characters on either side of the point and moves forward."
-  (let ((arg (or p 1))
-	(point (current-point)))
-    (dotimes (i (abs arg))
-      (when (or (minusp arg) (end-line-p point)) (mark-before point))
-      (let ((prev (previous-character point))
-	    (next (next-character point)))
-	(cond ((not prev) (editor-error "No previous character."))
-	      ((not next) (editor-error "No next character."))
-	      (t
-	       (setf (previous-character point) next)
-	       (setf (next-character point) prev))))
-      (when (plusp arg) (mark-after point)))))
-
-;;;; Word hacking commands:
-
-;;; WORD-OFFSET 
-;;;
-;;;    Move a mark forward/backward some words.
-;;;
-(defun word-offset (mark offset)
-  "Move Mark by Offset words."
-  (if (minusp offset)
-      (do ((cnt offset (1+ cnt)))
-	  ((zerop cnt) mark)
-	(cond
-	 ((null (reverse-find-attribute mark :word-delimiter #'zerop))
-	  (return nil))
-	 ((reverse-find-attribute mark :word-delimiter))
-	 (t
-	  (move-mark
-	   mark (buffer-start-mark (line-buffer (mark-line mark)))))))
-      (do ((cnt offset (1- cnt)))
-	  ((zerop cnt) mark)
-	(cond
-	 ((null (find-attribute mark :word-delimiter #'zerop))
-	  (return nil))
-	 ((null (find-attribute mark :word-delimiter))
-	  (return nil))))))
-
-(defcommand "Forward Word" (p)
-  "Moves forward one word.
-  With prefix argument, moves the point forward over that many words."
-  "Moves the point forward p words."
-  (cond ((word-offset (current-point) (or p 1)))
-	((and p (minusp p))
-	 (buffer-start (current-point))
-	 (editor-error "No previous word."))
-	(t
-	 (buffer-end (current-point))
-	 (editor-error "No next word."))))
-
-(defcommand "Backward Word" (p)
-  "Moves forward backward word.
-  With prefix argument, moves the point back over that many words."
-  "Moves the point backward p words."
-  (forward-word-command (- (or p 1))))
-
-
-
-;;;; Moving around:
-
-(defvar *target-column* 0)
-
-(defun set-target-column (mark)
-  (if (eq (last-command-type) :line-motion)
-      *target-column*
-      (setq *target-column* (mark-column mark))))
-
-(defcommand "Next Line" (p)
-  "Moves the point to the next line.
-   With prefix argument, moves the point that many lines down (or up if
-   the prefix is negative)."
-  "Moves the down p lines."
-  (let* ((point (current-point))
-	 (target (set-target-column point)))
-    (unless (line-offset point (or p 1))
-      (cond ((not p)
-	     (when (same-line-p point (buffer-end-mark (current-buffer)))
-	       (line-end point))
-	     (insert-character point #\newline))
-	    ((minusp p)
-	     (buffer-start point)
-	     (editor-error "No previous line."))
-	    (t
-	     (buffer-end point)
-	     (when p (editor-error "No next line.")))))
-    (unless (move-to-column point target) (line-end point))
-    (setf (last-command-type) :line-motion)))
-
-
-(defcommand "Previous Line" (p)
-  "Moves the point to the previous line.
-  With prefix argument, moves the point that many lines up (or down if
-  the prefix is negative)."
-  "Moves the point up p lines."
-  (next-line-command (- (or p 1))))
-
-(defcommand "Mark to End of Buffer" (p)
-  "Sets the current region from point to the end of the buffer."
-  "Sets the current region from point to the end of the buffer."
-  (declare (ignore p))
-  (push-buffer-mark (buffer-end (copy-mark (current-point))) t))
-
-(defcommand "Mark to Beginning of Buffer" (p)
-  "Sets the current region from the beginning of the buffer to point."
-  "Sets the current region from the beginning of the buffer to point."
-  (declare (ignore p))
-  (push-buffer-mark (buffer-start (copy-mark (current-point))) t))
-
-(defcommand "Beginning of Buffer" (p)
-  "Moves the point to the beginning of the current buffer."
-  "Moves the point to the beginning of the current buffer."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (push-buffer-mark (copy-mark point))
-    (buffer-start point)))
-
-(defcommand "End of Buffer" (p)
-  "Moves the point to the end of the current buffer."
-  "Moves the point to the end of the current buffer."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (push-buffer-mark (copy-mark point))
-    (buffer-end point)))
-
-(defcommand "Beginning of Line" (p)
-  "Moves the point to the beginning of the current line.
-  With prefix argument, moves the point to the beginning of the prefix'th
-  next line."
-  "Moves the point down p lines and then to the beginning of the line."
-  (let ((point (current-point)))
-    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
-    (line-start point)))
-
-(defcommand "End of Line" (p)
-  "Moves the point to the end of the current line.
-  With prefix argument, moves the point to the end of the prefix'th next line."
-  "Moves the point down p lines and then to the end of the line."
-  (let ((point (current-point)))
-    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
-    (line-end point)))
-
-(defhvar "Scroll Overlap"
-  "The \"Scroll Window\" commands leave this much overlap between screens."
-  :value 2)
-
-(defhvar "Scroll Redraw Ratio"
-  "This is a ratio of \"inserted\" lines to the size of a window.  When this
-   ratio is exceeded, insert/delete line terminal optimization is aborted, and
-   every altered line is simply redrawn as efficiently as possible.  For example,
-   setting this to 1/4 will cause scrolling commands to redraw the entire window
-   instead of moving the bottom two lines of the window to the top (typically
-   3/4 of the window is being deleted upward and inserted downward, hence a
-   redraw); however, commands line \"New Line\" and \"Open Line\" will still
-   efficiently, insert a line moving the rest of the window's text downward."
-  :value nil)
-
-  "This is a cut-off point at which the insert/delete line terminal optimization
-   will not be used (in number of lines).  For example, if the value is non-nil,
-   and that number (or more) of lines wants to be inserted or deleted from the
-   screen, then redisplay will simply paint the entire screen from the first
-   altered line down."
-  :value nil)
-
-(defcommand "Scroll Window Down" (p &optional (window (current-window)))
-  "Move down one screenfull.
-  With prefix argument scroll down that many lines."
-  "If P is NIL then scroll Window, which defaults to the current
-  window, down one screenfull.  If P is supplied then scroll that
-  many lines."
-  (if p
-      (scroll-window window p)      
-      (let ((height (window-height window))
-	    (overlap (value scroll-overlap)))
-	(scroll-window window (if (<= height overlap) 
-				  height (- height overlap))))))
-
-(defcommand "Scroll Window Up" (p &optional (window (current-window)))
-  "Move up one screenfull.
-  With prefix argument scroll up that many lines."
-  "If P is NIL then scroll Window, which defaults to the current
-  window, up one screenfull.  If P is supplied then scroll that
-  many lines."
-  (if p
-      (scroll-window window (- p))
-      (let ((height (- (window-height window)))
-	    (overlap (- (value scroll-overlap))))
-	(scroll-window window (if (>= height overlap) 
-				  height (- height overlap))))))
-
-(defcommand "Scroll Next Window Down" (p)
-  "Do a \"Scroll Window Down\" on the next window."
-  "Do a \"Scroll Window Down\" on the next window."
-  (let ((win (next-window (current-window))))
-    (when (eq win (current-window)) (editor-error "Only one window."))
-    (scroll-window-down-command p win)))
-
-(defcommand "Scroll Next Window Up" (p)
-  "Do a \"Scroll Window Up\" on the next window."
-  "Do a \"Scroll Window Up\" on the next window."
-  (let ((win (next-window (current-window))))
-    (when (eq win (current-window)) (editor-error "Only one window."))
-    (scroll-window-up-command p win)))
-
-(defcommand "Top of Window" (p)
-  "Move the point to the top of the current window.
-  The point is left before the first character displayed in the window."
-  "Move the point to the top of the current window."
-  (declare (ignore p))
-  (move-mark (current-point) (window-display-start (current-window))))
-
-(defcommand "Bottom of Window" (p)
-  "Move the point to the bottom of the current window.
-  The point is left at the start of the bottom line."
-  "Move the point to the bottom of the current window."
-  (declare (ignore p))
-  (line-start (current-point)
-	      (mark-line (window-display-end (current-window)))))
-
-;;;; Kind of miscellaneous commands:
-
-;;; "Refresh Screen" may not be right with respect to wrapping lines in
-;;; the case where an argument is supplied due the use of
-;;; WINDOW-DISPLAY-START instead of SCROLL-WINDOW, but using the latter
-;;; messed with point and did other hard to predict stuff.
-;;; 
-(defcommand "Refresh Screen" (p)
-  "Refreshes everything in the window, centering current line.
-   Given an argument, scroll that many lines."
-  "Refreshes everything in the window, centering current line.
-   Given an argument, scroll that many lines."
-  (let ((window (current-window)))
-    (cond ((not p) (center-window window (current-point)))
-	  ((zerop p) (line-to-top-of-window-command nil))
-	  ((line-offset (window-display-start window) 
-			(if (plusp p) (1- p) (1+ p))
-			0))
-	  (t (editor-error "Not enough lines."))))
-  (unless p (redisplay-all)))
-
-
-(defcommand "Track Buffer Point" (p)
-  "Make the current window track the buffer's point.
-   This means that each time Hemlock redisplays, it will make sure the buffer's
-   point is visible in the window.  This is useful for windows into buffer's
-   that receive output from streams coming from other processes."
-  "Make the current window track the buffer's point."
-  (declare (ignore p))
-  (setf (window-display-recentering (current-window)) t))
-;;;
-(defun reset-window-display-recentering (window &optional buffer)
-  (declare (ignore buffer))
-  (setf (window-display-recentering window) nil))
-;;;
-(add-hook window-buffer-hook #'reset-window-display-recentering)
-
-
-(defcommand "Extended Command" (p)
-  "Prompts for and executes an extended command."
-  "Prompts for and executes an extended command.  The prefix argument is
-  passed to the command."
-  (let* ((name (prompt-for-keyword (list *command-names*)
-				   :prompt "Extended Command: "
-				   :help "Name of a Hemlock command"))
-	 (function (command-function (getstring name *command-names*))))
-    (funcall function p)))
-
-(defhvar "Universal Argument Default"
-  "Default value for \"Universal Argument\" command."
-  :value 4)
-
-(defcommand "Universal Argument" (p)
-  "Sets prefix argument for next command.
-  Typing digits, regardless of any modifier keys, specifies the argument.
-  Optionally, you may first type a sign (- or +).  While typing digits, if you
-  type C-U or C-u, the digits following the C-U form a number this command
-  multiplies by the digits preceding the C-U.  The default value for this
-  command and any number following a C-U is the value of \"Universal Argument
-  Default\"."
-  "You probably don't want to use this as a function."
-  (declare (ignore p))
-  (clear-echo-area)
-  (write-string "C-U " *echo-area-stream*)
-  (let* ((key-event (get-key-event *editor-input*))
-	 (char (ext:key-event-char key-event)))
-    (if char
-	(case char
-	  (#\-
-	   (write-char #\- *echo-area-stream*)
-	   (universal-argument-loop (get-key-event *editor-input*) -1))
-	  (#\+
-	   (write-char #\+ *echo-area-stream*)
-	   (universal-argument-loop (get-key-event *editor-input*) -1))
-	  (t
-	   (universal-argument-loop key-event 1)))
-	(universal-argument-loop key-event 1))))
-
-(defcommand "Negative Argument" (p)
-  "This command is equivalent to invoking \"Universal Argument\" and typing
-   a minus sign (-).  It waits for more digits and a command to which to give
-   the prefix argument."
-  "Don't call this as a function."
-  (when p (editor-error "Must type minus sign first."))
-  (clear-echo-area)
-  (write-string "C-U -" *echo-area-stream*)
-  (universal-argument-loop (get-key-event *editor-input*) -1))
-
-(defcommand "Argument Digit" (p)
-  "This command is equivalent to invoking \"Universal Argument\" and typing
-   the digit used to invoke this command.  It waits for more digits and a
-   command to which to give the prefix argument."
-  "Don't call this as a function."
-  (declare (ignore p))
-  (clear-echo-area)
-  (write-string "C-U " *echo-area-stream*)
-  (universal-argument-loop *last-key-event-typed* 1))
-
-(defun universal-argument-loop (key-event sign &optional (multiplier 1))
-  (flet ((prefix (sign multiplier read-some-digit-p result)
-	   ;; read-some-digit-p and (zerop result) are not
-	   ;; equivalent if the user invokes this and types 0.
-	   (* sign multiplier
-	      (if read-some-digit-p
-		  result
-		  (value universal-argument-default)))))
-    (let* ((stripped-key-event (if key-event (ext:make-key-event key-event)))
-	   (char (ext:key-event-char stripped-key-event))
-	   (digit (if char (digit-char-p char)))
-	   (result 0)
-	   (read-some-digit-p nil))
-      (loop
-	(cond (digit
-	       (setf read-some-digit-p t)
-	       (write-char char *echo-area-stream*)
-	       (setf result (+ digit (* 10 result)))
-	       (setf key-event (get-key-event *editor-input*))
-	       (setf stripped-key-event (if key-event
-					    (ext:make-key-event key-event)))
-	       (setf char (ext:key-event-char stripped-key-event))
-	       (setf digit (if char (digit-char-p char))))
-	      ((or (eq key-event #k"C-u") (eq key-event #k"C-U"))
-	       (write-string " C-U " *echo-area-stream*)
-	       (universal-argument-loop
-		(get-key-event *editor-input*) 1
-		(prefix sign multiplier read-some-digit-p result))
-	       (return))
-	      (t
-	       (unget-key-event key-event *editor-input*)
-	       (setf (prefix-argument)
-		     (prefix sign multiplier read-some-digit-p result))
-	       (return))))))
-  (setf (last-command-type) (last-command-type)))
diff --git a/hemlock/comments.lisp b/hemlock/comments.lisp
deleted file mode 100644
index 2368132a9cdb9531b8430c96b73ec88afba94310..0000000000000000000000000000000000000000
--- a/hemlock/comments.lisp
+++ /dev/null
@@ -1,410 +0,0 @@
-;;; -*- Log: Hemlock.Log; Package: Hemlock -*-
-;;; 
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/comments.lisp,v 1.2 1991/02/08 16:33:22 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles
-;;;
-;;; This file contains the implementation of comment commands.
-
-(in-package 'hemlock)
-
-
-
-;;;; -- Variables --
-
-(defhvar "Comment Column"
-  "Colmun to start comments in."
-  :value 0)
-
-(defhvar "Comment Start"
-  "String that indicates the start of a comment."
-  :value nil)
-
-(defhvar "Comment End"
-  "String that ends comments.  Nil indicates #\newline termination."
-  :value nil)
-
-(defhvar "Comment Begin"
-  "String that is inserted to begin a comment."
-  :value nil)
-
-
-;;;; -- Internal Specials --
-
-;;; For the search pattern state specials, we just use " " as the comment
-;;; start and end if none exist, so we are able to make search patterns.
-;;; This is reasonable since any use of these will cause the patterns to be
-;;; made consistent with the actual start and end strings.
-
-(defvar *comment-start-pattern*
-  (new-search-pattern :string-insensitive :forward (or (value comment-start) " "))
-  "Search pattern to keep around for looking for comment starts.")
-
-(defvar *last-comment-start*
-  (or (value comment-start) " ")
-  "Previous comment start used to make *comment-start-pattern*.")
-
-(defvar *comment-end-pattern*
-  (new-search-pattern :string-insensitive :forward (or (value comment-end) " "))
-  "Search pattern to keep around for looking for comment ends.")
-
-(defvar *last-comment-end*
-  (or (value comment-end) " ")
-  "Previous comment end used to make *comment-end-pattern*.")
-
-
-(eval-when (compile eval)
-(defmacro get-comment-pattern (string kind) ;kind is either :start or :end
-  (let (pattern-var last-var)
-    (cond ((eq kind :start)
-	   (setf pattern-var '*comment-start-pattern*)
-	   (setf last-var '*last-comment-start*))
-	  (t (setf pattern-var '*comment-end-pattern*)
-	     (setf last-var '*last-comment-end*)))
-    `(cond ((string= (the simple-string ,string) (the simple-string ,last-var))
-	    ,pattern-var)
-	   (t (setf ,last-var ,string)
-	      (new-search-pattern :string-insensitive :forward
-				  ,string ,pattern-var)))))
-) ;eval-when
-
-
-
-;;;;  -- Commands --
-
-(defcommand "Set Comment Column" (p)
-  "Set Comment Column to current column or argument.
-   If argument is provided use its absolute value."
-  "Set Comment Column to current column or argument.
-   If argument is provided use its absolute value."
-  (let ((new-column (or (and p (abs p))
-			(mark-column (current-point)))))
-    (defhvar "Comment Column" "This buffer's column to start comments."
-      :value new-column  :buffer (current-buffer))
-    (message "Comment Column = ~D" new-column)))
-
-
-(defcommand "Indent for Comment" (p)
-  "Move to or create a comment.  Moves to the start of an existing comment
-   and indents it to start in Comment Column.  An existing double semicolon
-   comment is aligned like a line of code.  An existing triple semicolon
-   comment or any that start in column 0 is not moved.  With argument,
-   aligns any comments on the next argument lines but does not create any.
-   If characters extend past comment column, a space is added before
-   starting comment."
-  "Create comment or move to beginning of existing one aligning it."
-  (let* ((column (value comment-column))
-	 (start (value comment-start))
-	 (begin (value comment-begin))
-	 (end (value comment-end)))
-    (unless (stringp start) (editor-error "No comment start string -- ~S." start))
-    (indent-for-comment (current-point) column start begin end (or p 1))))
-
-
-(defcommand "Up Comment Line" (p)
-  "Equivalent to Previous Line followed by Indent for Comment (C-P ALT-;)."
-  "Equivalent to Previous Line followed by Indent for Comment (C-P ALT-;)."
-  (let ((column (value comment-column))
-	(start (value comment-start))
-	(begin (value comment-begin))
-	(end (value comment-end)))
-    (unless (stringp start) (editor-error "No comment start string -- ~S." start))
-    (change-comment-line (current-point) column start
-			 begin end (or (and p (- p)) -1))))
-
-(defcommand "Down Comment Line" (p)
-  "Equivalent to Next Line followed by Indent for Comment (C-N ALT-;)."
-  "Equivalent to Next Line followed by Indent for Comment (C-N ALT-;)."
-  (let ((column (value comment-column))
-	(start (value comment-start))
-	(begin (value comment-begin))
-	(end (value comment-end)))
-    (unless (stringp start) (editor-error "No comment start string -- ~S." start))
-    (change-comment-line (current-point) column start begin end (or p 1))))
-
-
-(defcommand "Kill Comment" (p)
-  "Kills the comment (if any) on the current line.
-   With argument, applies to specified number of lines, and moves past them."
-  "Kills the comment (if any) on the current line.
-   With argument, applies to specified number of lines, and moves past them."
-  (let ((start (value comment-start)))
-    (when start
-      (if (not (stringp start))
-	  (editor-error "Comment start not string or nil -- ~S." start))
-      (kill-comment (current-point) start (or p 1)))))
-
-
-(defcommand "Indent New Comment Line" (p)
-  "Inserts comment end and then starts a comment on a new line.
-   The indentation and number of additional comment-start characters are
-   copied from the previous line's comment.  Acts like Linefeed, when done
-   while not inside a comment, assuming a comment is the last thing on a line."
-  "complete a current comment and start another a new line, copying indentation
-   and start characters.  If no comment, call Linefeed command."
-  (let ((start (value comment-start))
-	(begin (value comment-begin))
-	(end (value comment-end))
-	(point (current-point)))
-    (with-mark ((tmark point :left-inserting))
-      (if start
-	  (cond ((not (stringp start))
-		 (editor-error "Comment start not string or nil -- ~S." start))
-		((and (to-line-comment tmark start) (mark> point tmark))
-		 (with-mark ((emark tmark))
-		   (let ((endp (if end (to-comment-end emark end))))
-		     (cond ((and endp (mark= emark point))
-			    (insert-string point end)
-			    (indent-new-comment-line point tmark start begin end))
-			   ((and endp
-				 (character-offset emark endp)
-				 (mark>= point emark))
-			    (indent-new-line-command p))
-			   (t (delete-horizontal-space point)
-			      (if end (insert-string point end))
-			      (indent-new-comment-line point tmark
-						       start begin end))))))
-		(t (indent-new-line-command p)))
-	  (indent-new-line-command p)))))
-
-
-
-;;;; -- Support Routines --
-
-(eval-when (compile eval)
-(defmacro %do-comment-lines ((var number) mark1 &rest forms)
-  (let ((next-line-p (gensym)))
-    `(do ((,var (if (plusp ,number) ,number 0) (1- ,var))
-	  (,next-line-p t))
-	 ((or (zerop ,var) (not ,next-line-p))
-	  (zerop ,var))
-       ,@forms
-       (setf ,next-line-p (line-offset ,mark1 1)))))
-) ;eval-when
-
-
-;;; CHANGE-COMMENT-LINE closes any comment on the current line, deleting
-;;; an empty comment.  After offsetting by lines, a comment is either
-;;; aligned or created.
-(defun change-comment-line (mark column start begin end lines)
-  (with-mark ((tmark1 mark :left-inserting)
-	      (tmark2 mark))
-    (let ((start-len (to-line-comment mark start))
-	  end-len)
-      (when start-len
-	(if end
-	    (setf end-len (to-comment-end (move-mark tmark1 mark) end))
-	    (line-end tmark1))
-	(character-offset (move-mark tmark2 mark) start-len)
-	(find-attribute tmark2 :whitespace #'zerop)
-	(cond ((mark>= tmark2 tmark1)
-	       (if end-len (character-offset tmark1 end-len))
-	       ;; even though comment is blank, the line might not be blank
-	       ;; after it in languages that have comment terminators.
-	       (when (blank-after-p tmark1)
-		 (reverse-find-attribute mark :whitespace #'zerop)
-		 (if (not (same-line-p mark tmark1))
-		     (line-start mark (mark-line tmark1)))
-		 (delete-region (region mark tmark1))))
-	      ((and end (not end-len)) (insert-string tmark1 end))))
-      (if (line-offset mark lines)
-	  (indent-for-comment mark column start begin end 1)
-	  (editor-error)))))
-
-
-(defun indent-for-comment (mark column start begin end times)
-  (with-mark ((tmark mark :left-inserting))
-    (if (= times 1)
-	(let ((start-len (to-line-comment tmark start)))
-	  (cond (start-len
-		 (align-comment tmark start start-len column)
-		 (character-offset (move-mark mark tmark) start-len))
-		(t (comment-line mark column start begin end))))
-	(unless (%do-comment-lines (n times) mark
-		  (let ((start-len (to-line-comment mark start)))
-		    (if start-len (align-comment mark start start-len column))))
-	  (buffer-end mark)
-	  (editor-error)))))
-
-
-;;; KILL-COMMENT assumes a comment is the last thing on a line, so it does
-;;; not deal with comment-end.  The Tao of EMACS.
-(defun kill-comment (mark start times)
-  (with-mark ((tmark mark :left-inserting))
-    (if (= times 1)
-	(when (to-line-comment mark start)
-	  (with-mark ((u-start mark)
-		      (u-end (line-end (move-mark tmark mark))))
-	    (rev-scan-char u-start :whitespace nil)
-	    (let ((undo-region (copy-region (region u-start u-end))))
-	      (ring-push (delete-and-save-region (region mark tmark))
-			 *kill-ring*)
-	      (delete-horizontal-space mark)
-	      (make-region-undo :insert "Kill Comment" undo-region
-				(copy-mark mark :left-inserting)))))
-	(let* ((kill-region (delete-and-save-region (region mark tmark)))
-	       (insert-mark (region-end kill-region))
-	       ;; don't delete u-start and u-end since undo stuff handles that.
-	       (u-start (line-start (copy-mark mark :left-inserting)))
-	       (u-end (copy-mark mark :left-inserting))
-	       (undo-region (copy-region (region u-start
-						 (if (line-offset u-end times)
-						     (line-start u-end)
-						     (buffer-end u-end)))))
-	       (n-times-p
-		(%do-comment-lines (n times) mark
-		  (when (to-line-comment mark start)
-		    (line-end (move-mark tmark mark))
-		    (ninsert-region insert-mark
-				    (delete-and-save-region (region mark tmark)))
-		    (insert-character insert-mark #\newline)
-		    (delete-horizontal-space mark)))))
-	  (ring-push kill-region *kill-ring*)
-	  (make-region-undo :twiddle "Kill Comment"
-			    (region u-start u-end) undo-region)
-	  (unless n-times-p
-	    (buffer-end mark)
-	    (editor-error))))))
-
-(defun comment-line (point column start begin end)
-  (let* ((open (or begin start))
-	 (open-len (length (the simple-string open)))
-	 (end-len (if end (length (the simple-string end)) 0))
-	 (insert-len (+ open-len end-len)))
-    (line-end point)
-    (insert-string point open)
-    (if end (insert-string point end))
-    (character-offset point (- insert-len))
-    (adjust-comment point column)
-    (character-offset point open-len)))
-
-
-(eval-when (compile eval)
-(defmacro count-extra-last-chars (mark start-len start-char)
-  (let ((count (gensym))
-	(tmark (gensym)))
-    `(with-mark ((,tmark ,mark))
-       (character-offset ,tmark ,start-len)
-       (do ((,count 0 (1+ ,count)))
-	   ((char/= (next-character ,tmark) ,start-char) ,count)
-	 (mark-after ,tmark)))))
-)
-
-
-;;; ALIGN-COMMENT sets a comment starting at mark to start in column
-;;; column.  If the comment starts at the beginning of the line, it is not
-;;; moved.  If the comment start is a single character and duplicated, then
-;;; it is indented as if it were code, and if it is triplicated, it is not
-;;; moved.  If the comment is to be moved to column, then we check to see
-;;; if it is already there and preceded by whitespace.
-
-(defun align-comment (mark start start-len column)
-  (unless (start-line-p mark)
-    (case (count-extra-last-chars mark start-len (schar start (1- start-len)))
-      (1 (funcall (value indent-function) mark))
-      (2 )
-      (t (if (or (/= (mark-column mark) column)
-		 (zerop (character-attribute
-			 :whitespace (previous-character mark))))
-	     (adjust-comment mark column))))))
-
-
-;;; ADJUST-COMMENT moves the comment starting at mark to start in column
-;;; column, inserting a space if the line extends past column.
-(defun adjust-comment (mark column)
-  (delete-horizontal-space mark)
-  (let ((current-column (mark-column mark))
-	(spaces-per-tab (value spaces-per-tab))
-	tabs spaces next-tab-pos)
-    (cond ((= current-column column)
-	   (if (/= column 0) (insert-character mark #\space)))
-	  ((> current-column column) (insert-character mark #\space))
-	  (t (multiple-value-setq (tabs spaces)
-	       (floor current-column spaces-per-tab))
-	     (setf next-tab-pos
-		   (if (zerop spaces)
-		       current-column
-		       (+ current-column (- spaces-per-tab spaces))))
-	     (cond ((= next-tab-pos column)
-		    (insert-character mark #\tab))
-		   ((> next-tab-pos column)
-		    (dotimes (i (- column current-column))
-		      (insert-character mark #\space)))
-		   (t (multiple-value-setq (tabs spaces)
-			(floor (- column next-tab-pos) spaces-per-tab))
-		      (dotimes (i (if (= current-column next-tab-pos)
-				      tabs
-				      (1+ tabs)))
-			(insert-character mark #\tab))
-		      (dotimes (i spaces)
-			(insert-character mark #\space))))))))
-
-
-;;; INDENT-NEW-COMMENT-LINE makes a new line at point starting a comment
-;;; in the same way as the one at start-mark.
-(defun indent-new-comment-line (point start-mark start begin end)
-  (new-line-command nil)
-  (insert-string point (gen-comment-prefix start-mark start begin))
-  (if end
-      (when (not (to-comment-end (move-mark start-mark point) end))
-	(insert-string start-mark end)
-	(if (mark= start-mark point)
-	    ;; This occurs when nothing follows point on the line and
-	    ;; both marks are left-inserting.
-	    (character-offset
-	     point (- (length (the simple-string end))))))))
-
-
-;;; GEN-COMMENT-PREFIX returns a string suitable for beginning a line
-;;; with a comment lined up with mark and starting the same as the comment
-;;; immediately following mark.  This is used in the auto filling stuff too.
-(defun gen-comment-prefix (mark start begin)
-  (let* ((start-len (length (the simple-string start)))
-	 (last-char (schar start (1- start-len)))
-	 (extra-start-chars (count-extra-last-chars mark start-len last-char))
-	 (spaces-per-tab (value spaces-per-tab))
-	 (begin-end (if begin
-			(subseq begin start-len (length (the simple-string begin)))
-			"")))
-    (multiple-value-bind (tabs spaces) (floor (mark-column mark) spaces-per-tab)
-      (concatenate 'simple-string
-		   (make-string tabs :initial-element #\tab)
-		   (make-string spaces :initial-element #\space)
-		   start
-		   (make-string extra-start-chars :initial-element last-char)
-		   begin-end))))
-
-
-;;; TO-LINE-COMMENT moves mark to the first comment start character on its
-;;; line if there is a comment and returns the length of start, otherwise
-;;; nil is returned.  Start must be a string.  This is used by the auto
-;;; filling stuff too.
-(defun to-line-comment (mark start)
-  (with-mark ((tmark mark))
-    (line-start tmark)
-    (let ((start-len (find-pattern tmark (get-comment-pattern start :start))))
-      (when (and start-len (same-line-p mark tmark))
-	(move-mark mark tmark)
-	start-len))))
-
-
-;;; TO-COMMENT-END moves mark to the first comment end character on its
-;;; line if end is there and returns the length of comment end, otherwise
-;;; mark is moved to the end of the line returning nil.  This is used by
-;;; the auto filling stuff too.
-(defun to-comment-end (mark end)
-  (with-mark ((tmark mark))
-    (let ((end-len (find-pattern tmark (get-comment-pattern end :end))))
-      (cond ((and end-len (same-line-p mark tmark))
-	     (move-mark mark tmark)
-	     end-len)
-	    (t (line-end mark) nil)))))
diff --git a/hemlock/compilation.order b/hemlock/compilation.order
deleted file mode 100644
index 0bbab12c63a33f62636cc2d4d06675218981d7a2..0000000000000000000000000000000000000000
--- a/hemlock/compilation.order
+++ /dev/null
@@ -1,250 +0,0 @@
-; Definitions of structures intended for use within the HEMLOCK-INTERNALS
-; package.
-Struct
-; Definitions of structures intended for use within the HEMLOCK package.
-Struct-ed
-; Code specific to CMU Common Lisp on the IBM RT/PC under Mach.
-rompsite
-; Implementation dependant character hacking macros.
-Charmacs
-; This is implementation dependent code for canonical input event
-; representation.  It also provides a interface for converting X11 codes
-; and bits to an input event.
-Key-event
-Keysym-defs
-; Implementation independent code to support input to Hemlock, based on
-; keytran.lisp and keytrandefs.lisp.
-Input
-; Random macros needed in the compiler.
-Macros
-; Implementation dependant line structure definition.
-Line
-
-; Ring-Buffer data-type primitives.
-Ring
-; String-Table primitives.
-Table
- 
-; Text manipulation primitives.
-Htext1
-Htext2
-Htext3
-Htext4
-
-; Searching and replacing primitives.
-Search1 ;String searches.
-Search2 ;Character searches, uses %sp-[reverse-]find-character-with-attribute.
-
-; Stuff that depends on the current line-image building scheme, and
-; thus %SP-Find-Character-With-Attribute.
-; Build line images.
-Linimage
-; Cursor-positioning and recentering stuff.
-Cursor
-
-; Uses %SP-Find-Character-With-Attribute, but is independent of line-image
-; stuff.
-; Syntax table primitives.
-Syntax
-
-; Window image building stuff.
-Winimage
-
-; Implementation dependent redisplay code for running under X.
-Hunk-Draw
-
-; Implementation independent interface to Unix style termcap files.
-Termcap
-
-; Implementation independent redisplay entry points.
-Display
-
-; Implementation dependent redisplay.
-Bit-display ;for bitmap displays under X.
-
-; Implementation dependent redisplay code for running with a terminal.
-Tty-disp-rt
-
-; Implementation independent redisplay code for running with a terminal.
-Tty-display
-
-; Implementation dependent code for random typeout/pop-up displays on the
-; bitmap and tty.
-pop-up-stream
-
-; Implementation independent screen management.
-Screen
-
-; Implementation dependent screen management.
-Bit-screen ;for bitmap display under X.
-
-; Implementation independent screen management code for running with a terminal.
-Tty-screen
-
-; Implementation independent code for Hemlock window primitives and
-; some other redisplay stuff.
-Window
-
-; Implementation independent interface to fonts.
-Font
-
-; The command interpreter.
-Interp
-
-; Hemlock variable access functions.
-Vars
-
-; Buffer and mode manipulation functions
-Buffer
-
-; Implementation dependent file primitives.
-Files
-
-; Implemention dependent stream primitives.
-Streams
-
-; echo-area prompting functions.
-Echo
-
-; Random top-level user functions and implementation independant initilization
-; stuff.
-Main
-
-; Echo-Area commands.
-EchoComs
-
-; Some character attribute definitions.
-Defsyn
-
-; Basic commands
-Command
-MoreComs
-
-; Stuff for undoing stuff.
-Undo
-
-; Killing and un-killing commands.  Mark ring primitives and commands.
-KillComs
-
-; Searching and replacing commands.
-SearchComs
-
-; File and buffer manipulating commands.
-Filecoms
-
-; Indentation commands
-Indent
-
-; Commands for lisp mode.
-Lispmode
-
-; Comment-hacking commands.
-Comments
-
-; Auto Fill Mode and filling commands.
-Fill
-
-; Text primitives and commands (paragraphs, sentences, etc.)
-Text
-
-; Documentation commands.
-Doccoms
-
-; Commands for buffer comparison and stuff.
-Srccom
-
-; Commands for manipulating groups of files.
-Group
-
-; Implementation dependent spell code.
-Spell-RT
-; Spelling correction interface implementation.
-Spell-Corr
-; Spell interface to incrementally add to the dictionary.
-Spell-Aug
-; Nearly implementation independent code to build binary dictionary.
-Spell-Build
-; User interface commands.
-Spellcoms
-
-; Word abbreviation commands.
-Abbrev
-
-; Overwrite mode, for making text pictures and stuff.
-Overwrite
-
-; Gosling Emacs bindings and twiddle chars command.  Lots of other
-;differences.
-gosmacs
-
-; a typescript server in Hemlock.  Client Lisp's *terminal-io* streams are
-; set to typescript streams which send message requests to typescript servers
-; for input and output, so this is how client Lisps can do full I/O inside
-; a Hemlock buffer.
-Ts-buf
-Ts-stream
-
-; commands for interacting with client Lisp environments and REP loops.
-eval-server
-Lispeval
-
-; commands for evaling and running a REP loop in a buffer.
-Lispbuf
-
-; Keyboard macros and stuff.
-Kbdmac
-
-; Hackish thing to italicize comments.
-Icom
-
-; Stuff to check buffer integrity.
-Integrity
-
-; Scribe Mode
-Scribe
-
-; Definition editing/function definition finding
-Edit-Defs
-
-; auto-save mode.
-auto-save
-
-; register code.  stuff for stashing marks and regions in "registers".
-register
-
-; commands pertinent only to the X windowing system.
-xcoms
-
-; implements Unix specific commands for Hemlock.
-unixcoms
-
-; mail interface to MH.
-mh
-
-; highlighting parens and active regions.
-highlight
-
-; directory editing; implementation dependent.
-dired
-diredcoms
-
-; buffer hacking mode.
-bufed
-
-; lisp library browser mode; implementation dependent.
-lisp-lib
-
-; completion mode to save key strokes for long Lisp identifiers.
-completion
-
-; "Process" mode, primarily implements Unix shells in Hemlock buffers.
-shell
-
-; stuff for talking to slave Lisps to do debugging.
-debug
-
-; site dependent NNTP interface for reading Netnews.
-netnews
-
-; File that sets up all the default key bindings; implementation dependant.
-Bindings
diff --git a/hemlock/completion.lisp b/hemlock/completion.lisp
deleted file mode 100644
index cd2b10f96188e2eecd83ad5829c71143ab23532b..0000000000000000000000000000000000000000
--- a/hemlock/completion.lisp
+++ /dev/null
@@ -1,519 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/completion.lisp,v 1.4 1991/05/16 17:40:58 mbb Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Skef Wholey and Blaine Burks.
-;;; General idea stolen from Jim Salem's TMC LISPM completion code.
-;;;
-
-(in-package "HEMLOCK")
-
-
-
-;;;; The Completion Database.
-
-;;; The top level structure here is an array that gets indexed with the
-;;; first three characters of the word to be completed.  That will get us to
-;;; a list of the strings with that prefix sorted in most-recently-used order.
-;;; The number of strings in any given bucket will never exceed
-;;; Completion-Bucket-Size-Limit.  Strings are stored in the database in
-;;; lowercase form always.
-
-(defconstant completion-table-size 991)
-
-(defvar *completions* (make-array completion-table-size :initial-element nil))
-
-(defhvar "Completion Bucket Size"
-  "This limits the number of completions saved for a particular combination of
-   the first three letters of any word."
-  :value 20)
-
-
-;;; Mapping strings into buckets.
-
-;;; The characters that are considered parts of "words" change from mode
-;;; to mode.
-;;;
-(defattribute "Completion Wordchar"
-  "1 for characters we consider to be constituents of words.")
-
-(defconstant default-other-wordchars
-  '(#\- #\* #\' #\_))
-
-(do-alpha-chars (char :both)
-  (setf (character-attribute :completion-wordchar char) 1))
-
-(dolist (char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
-  (setf (character-attribute :completion-wordchar char) 1))
-
-(dolist (char default-other-wordchars)
-  (setf (character-attribute :completion-wordchar char) 1))
-
-
-;;; The difference between Lisp mode and the other modes is pretty radical in
-;;; this respect.  These are interesting too, but they're on by default: #\*,
-;;; #\-, and #\_.  #\' is on by default too, but it's uninteresting in "Lisp"
-;;; mode.
-;;;
-(defconstant default-lisp-wordchars
-  '(#\~ #\! #\@ #\$ #\% #\^ #\& #\+ #\= #\: #\< #\> #\. #\/ #\?))
-
-(dolist (char default-lisp-wordchars)
-  (shadow-attribute :completion-wordchar char 1 "Lisp"))
-
-(shadow-attribute :completion-wordchar #\' 0 "Lisp")
-
-(defmacro completion-char-p (char)
-  `(= (the fixnum (character-attribute :completion-wordchar ,char)) 1))
-
-;;; COMPLETION-BUCKET-FOR returns the Completion-Bucket that might hold a
-;;; completion for the given String.  With optional Value, sets the bucket.
-;;;
-(defun completion-bucket-for (string length &optional (value nil value-p))
-  (declare (simple-string string)
-	   (fixnum length))
-  (when (and (>= length 3)
-	     (completion-char-p (char string 0))
-	     (completion-char-p (char string 1))
-	     (completion-char-p (char string 2)))
-    (let ((index (mod (logxor (ash
-			       (logxor
-				(ash (hi::search-hash-code (schar string 0))
-				     5)
-				(hi::search-hash-code (schar string 1)))
-			       3)
-			      (hi::search-hash-code (schar string 2)))
-		      completion-table-size)))
-      (declare (fixnum index))
-      (if value-p
-	  (setf (svref *completions* index) value)
-	  (svref *completions* index)))))
-
-(defsetf completion-bucket-for completion-bucket-for)
-
-
-;;; FIND-COMPLETION returns the most recent string matching the given
-;;; Prefix, or Nil if nothing appropriate is in the database.  We assume
-;;; the Prefix is passed to us in lowercase form so we can use String=.  If
-;;; we find something appropriate, we bring it to the front of the list.
-;;; Prefix-Length, if supplied restricts us to look at just the start of
-;;; the string...
-;;;
-(defun find-completion (prefix &optional (prefix-length (length prefix)))
-  (declare (simple-string prefix)
-	   (fixnum prefix-length))
-  (let ((bucket (completion-bucket-for prefix prefix-length)))
-    (do ((list bucket (cdr list)))
-	((null list))
-      (let ((completion (car list)))
-	(declare (simple-string completion))
-	(when (and (>= (length completion) prefix-length)
-		   (string= prefix completion
-			    :end1 prefix-length
-			    :end2 prefix-length))
-	  (unless (eq list bucket)
-	    (rotatef (car list) (car bucket)))
-	  (return completion))))))
-
-;;; RECORD-COMPLETION saves string in the completion database as the first item
-;;; in the bucket, that's the most recently used completion.  If the bucket is
-;;; full, drop the oldest item in the list.  If string is already in the
-;;; bucket, simply move it to the front.  The way we move an element to the
-;;; front requires a full bucket to be at least three elements long.
-;;;
-(defun record-completion (string)
-  (declare (simple-string string))
-  (let ((string-length (length string)))
-    (declare (fixnum string-length))
-    (when (> string-length 3)
-      (let ((bucket (completion-bucket-for string string-length))
-	    (limit (value completion-bucket-size)))
-	(do ((list bucket (cdr list))
-	     (last nil list)
-	     (length 1 (1+ length)))
-	    ((null list)
-	     (setf (completion-bucket-for string string-length)
-		   (cons string bucket)))
-	  (cond ((= length limit)
-		 (setf (car list) string)
-		 (setf (completion-bucket-for string string-length) list)
-		 (setf (cdr list) bucket)
-		 (setf (cdr last) nil)
-		 (return))
-		((string= string (the simple-string (car list)))
-		 (unless (eq list bucket)
-		   (rotatef (car list) (car bucket)))
-		 (return))))))))
-
-;;; ROTATE-COMPLETIONS rotates the completion bucket for the given Prefix.
-;;; We just search for the first thing in the bucket with the Prefix, then
-;;; move that to the end of the list.  If there ain't no such thing there,
-;;; or if it's already at the end, we do nothing.
-;;;
-(defun rotate-completions (prefix &optional (prefix-length (length prefix)))
-  (declare (simple-string prefix))
-  (let ((bucket (completion-bucket-for prefix prefix-length)))
-    (do ((list bucket (cdr list))
-	 (prev nil list))
-	((null list))
-      (let ((completion (car list)))
-	(declare (simple-string completion))
-	(when (and (>= (length completion) prefix-length)
-		   (string= prefix completion
-			    :end1 prefix-length :end2 prefix-length))
-	  (when (cdr list)
-	    (if prev
-		(setf (cdr prev) (cdr list))
-		(setf (completion-bucket-for prefix prefix-length) (cdr list)))
-	    (setf (cdr (last list)) list)
-	    (setf (cdr list) nil))
-	  (return nil))))))
-
-
-
-;;;; Hemlock interface.
-
-(defmode "Completion" :transparent-p t :precedence 10.0
-  :documentation
-  "This is a minor mode that saves words greater than three characters in length,
-   allowing later completion of those words.  This is very useful for often
-   long identifiers used in Lisp code.  All words with the same first three
-   letters are in one list sorted by most recently used.  \"Completion Bucket
-   Size\" limits the number of completions saved in each list.")
-
-(defcommand "Completion Mode" (p)
-  "Toggles Completion Mode in the current buffer."
-  "Toggles Completion Mode in the current buffer."
-  (declare (ignore p))
-  (setf (buffer-minor-mode (current-buffer) "Completion")
-	(not (buffer-minor-mode (current-buffer) "Completion"))))
-
-
-;;; Consecutive alphanumeric keystrokes that start a word cause a possible
-;;; completion to be displayed in the echo area's modeline, the status line.
-;;; Since most insertion is building up a word that was already started, we
-;;; keep track of the word in *completion-prefix* that the user is typing.  The
-;;; length of the thing is kept in *completion-prefix-length*.
-;;;
-(defconstant completion-prefix-max-size 100)
-
-(defvar *completion-prefix* (make-string completion-prefix-max-size))
-
-(defvar *completion-prefix-length* 0)
-
-
-;;; "Completion Self Insert" does different stuff depending on whether or
-;;; not the thing to be inserted is Completion-Char-P.  If it is, then we
-;;; try to come up with a possible completion, using Last-Command-Type to
-;;; tense things up a bit.  Otherwise, if Last-Command-Type says we were
-;;; just doing a word, then we record that word in the database.
-;;;
-(defcommand "Completion Self Insert" (p)
-  "Insert the last character typed, showing possible completions.  With prefix
-   argument insert the character that many times."
-  "Implements \"Completion Self Insert\". Calling this function is not
-   meaningful."
-  (let ((char (ext:key-event-char *last-key-event-typed*)))
-    (unless char (editor-error "Can't insert that character."))
-    (cond ((completion-char-p char)
-	   ;; If start of word not already in *completion-prefix*, put it 
-	   ;; there.
-	   (unless (eq (last-command-type) :completion-self-insert)
-	     (set-completion-prefix))
-	   ;; Then add new stuff.
-	   (cond ((and p (> p 1))
-		  (fill *completion-prefix* (char-downcase char)
-			:start *completion-prefix-length*
-			:end (+ *completion-prefix-length* p))
-		  (incf *completion-prefix-length* p))
-		 (t
-		  (setf (schar *completion-prefix* *completion-prefix-length*)
-			(char-downcase char))
-		  (incf *completion-prefix-length*)))
-	   ;; Display possible completion, if any.
-	   (display-possible-completion *completion-prefix*
-					*completion-prefix-length*)
-	   (setf (last-command-type) :completion-self-insert))
-	  (t
-	   (when (eq (last-command-type) :completion-self-insert)
-	     (record-completion (subseq *completion-prefix*
-					0 *completion-prefix-length*)))))))
-
-;;; SET-COMPLETION-PREFIX grabs any completion-wordchars immediately before
-;;; point and stores these into *completion-prefix*.
-;;;
-(defun set-completion-prefix ()
-  (let* ((point (current-point))
-	 (point-line (mark-line point)))
-    (cond ((and (previous-character point)
-		(completion-char-p (previous-character point)))
-	   (with-mark ((mark point))
-	     (reverse-find-attribute mark :completion-wordchar #'zerop)
-	     (unless (eq (mark-line mark) point-line)
-	       (editor-error "No completion wordchars on this line!"))
-	     (let ((insert-string (nstring-downcase
-				   (region-to-string
-				    (region mark point)))))
-	       (replace *completion-prefix* insert-string)
-	       (setq *completion-prefix-length* (length insert-string)))))
-	  (t
-	   (setq *completion-prefix-length* 0)))))
-
-
-(defcommand "Completion Complete Word" (p)
-  "Complete the word if we've got a completion, fixing up the case.  Invoking
-   this immediately in succession rotates through possible completions in the
-   buffer.  If there is no currently displayed completion, this tries to choose
-   a completion from text immediately before the point and displays the
-   completion if found."
-  "Complete the word if we've got a completion, fixing up the case."
-  (declare (ignore p))
-  (let ((last-command-type (last-command-type)))
-    ;; If the user has been cursoring around and then tries to complete,
-    ;; let him.
-    ;;
-    (unless (member last-command-type '(:completion-self-insert :completion))
-      (set-completion-prefix)
-      (setf last-command-type :completion-self-insert))
-    (case last-command-type
-      (:completion-self-insert
-       (do-completion))
-      (:completion
-       (rotate-completions *completion-prefix* *completion-prefix-length*)
-       (do-completion))))
-  (setf (last-command-type) :completion))
-
-(defcommand "List Possible Completions" (p)
-  "List all possible completions of the prefix the user has typed."
-  "List all possible completions of the prefix the user has typed."
-  (declare (ignore p))
-  (let ((last-command-type (last-command-type)))
-    (unless (member last-command-type '(:completion-self-insert :completion))
-      (set-completion-prefix))
-    (let* ((prefix *completion-prefix*)
-	   (prefix-length *completion-prefix-length*)
-	   (bucket (completion-bucket-for prefix prefix-length)))
-      (with-pop-up-display (s)
-	(dolist (completion bucket)
-	  (when (and (> (length completion) prefix-length)
-		     (string= completion prefix
-			      :end1 prefix-length
-			      :end2 prefix-length))
-	    (write-line completion s))))))
-  ;; Keep the redisplay hook from clearing any possibly displayed completion.
-  (setf (last-command-type) :completion-self-insert))
-
-(defvar *last-completion-mark* nil)
-
-(defun do-completion ()
-  (let ((completion (find-completion *completion-prefix*
-				     *completion-prefix-length*))
-	(point (current-point)))
-    (when completion
-      (if *last-completion-mark*
-	  (move-mark *last-completion-mark* point)
-	  (setq *last-completion-mark* (copy-mark point :temporary)))
-      (let ((mark *last-completion-mark*))
-	(reverse-find-attribute mark :completion-wordchar #'zerop)
-	(let* ((region (region mark point))
-	       (string (region-to-string region)))
-	  (declare (simple-string string))
-	  (delete-region region)
-	  (let* ((first (position-if #'alpha-char-p string))
-		 (next (if first (position-if #'alpha-char-p string
-					      :start (1+ first)))))
-	    ;; Often completions start with asterisks when hacking on Lisp
-	    ;; code, so we look for alphabetic characters.
-	    (insert-string point
-			   ;; Leave the cascading IF's alone.
-			   ;; Writing this as a COND, using LOWER-CASE-P as
-			   ;; the test is not equivalent to this code since
-			   ;; numbers (and such) are nil for LOWER-CASE-P and
-			   ;; UPPER-CASE-P.
-			   (if (and first (upper-case-p (schar string first)))
-			       (if (and next
-					(upper-case-p (schar string next)))
-				   (string-upcase completion)    
-				   (word-capitalize completion))
-			       completion))))))))
-
-
-;;; WORD-CAPITALIZE is like STRING-CAPITALIZE except that it treats apostrophes
-;;; the Right Way.
-;;;
-(defun word-capitalize (string)
-  (let* ((length (length string))
-	 (strung (make-string length)))
-    (do  ((i 0 (1+ i))
-	  (new-word t))
-	 ((= i length))
-      (let ((char (schar string i)))
-	(cond ((or (alphanumericp char)
-		   (char= char #\'))
-	       (setf (schar strung i)
-		     (if new-word (char-upcase char) (char-downcase char)))
-	       (setq new-word nil))
-	      (t
-	       (setf (schar strung i) char)
-	       (setq new-word t)))))
-    strung))
-
-(defcommand "Completion Rotate Completions" (p)
-  "Show another possible completion in the status line, if there is one.
-   If there is no currently displayed completion, this tries to choose a
-   completion from text immediately before the point and displays the
-   completion if found.  With an argument, rotate the completion ring that many
-   times."
-  "Show another possible completion in the status line, if there is one.
-   With an argument, rotate the completion ring that many times."
-  (unless (eq (last-command-type) :completion-self-insert)
-    (set-completion-prefix)
-    (setf (last-command-type) :completion-self-insert))
-  (dotimes (i (or p 1))
-    (rotate-completions *completion-prefix* *completion-prefix-length*))
-  (display-possible-completion *completion-prefix* *completion-prefix-length*)
-  (setf (last-command-type) :completion-self-insert))
-
-
-;;;; Nifty database and parsing machanisms.
-
-(defhvar "Completion Database Filename"
-  "The file that \"Save Completions\" and \"Read Completions\" will
-   respectively write and read the completion database to and from."
-  :value nil)
-
-(defvar *completion-default-default-database-filename*
-  "hemlock-completions.txt"
-  "The file that will be defaultly written to and read from by \"Save
-   Completions\" and \"Read Completions\".")
-
-(defcommand "Save Completions" (p)
-  "Writes the current completion database to a file, defaultly the value of
-   \"Completion Database Filename\".  With an argument, prompts for a
-   filename."
-  "Writes the current completion database to a file, defaultly the value of
-   \"Completion Database Filename\".  With an argument, prompts for a
-   filename."
-  (let ((filename (or (and (not p) (value completion-database-filename))
-		      (prompt-for-file
-		       :must-exist nil
-		       :default *completion-default-default-database-filename*
-		       :prompt "File to write completions to: "))))
-    (with-open-file (s filename
-		       :direction :output
-		       :if-exists :rename-and-delete
-		       :if-does-not-exist :create)
-      (message "Saving completions...")
-      (dotimes (i (length *completions*))
-	(let ((bucket (svref *completions* i)))
-	  (when bucket
-	    (write i :stream s :base 10 :radix 10)
-	    (write-char #\newline s)
-	    (dolist (completion bucket)
-	      (write-line completion s))
-	    (terpri s))))
-      (message "Done."))))
-
-(defcommand "Read Completions" (p)
-  "Reads some completions from a file, defaultly the value of \"Completion
-   Database File\".  With an argument, prompts for a filename."
-  "Reads some completions from a file, defaultly the value of \"Completion
-   Database File\".  With an argument, prompts for a filename."
-  (let ((filename (or (and (not p) (value completion-database-filename))
-		      (prompt-for-file
-		       :must-exist nil
-		       :default *completion-default-default-database-filename*
-		       :prompt "File to read completions from: ")))
-	(index nil)
-	(completion nil))
-    (with-open-file (s filename :if-does-not-exist :error)
-      (message "Reading in completions...")
-      (loop
-	(let ((new-completions '()))
-	  (unless (setf index (read-preserving-whitespace s nil nil))
-	    (return))
-	  ;; Zip past the newline that I know is directly after the number.
-	  ;; All this to avoid consing.  I love it.
-	  (read-char s)
-	  (loop
-	    (setf completion (read-line s))
-	    (when (string= completion "") (return))
-	    (unless (member completion (svref *completions* index))
-	      (push completion new-completions)))
-	  (let ((new-bucket (nconc (nreverse new-completions)
-					    (svref *completions* index))))
-	    (setf (svref *completions* index) new-bucket)
-	    (do ((completion new-bucket (cdr completion))
-		 (end (1- (value completion-bucket-size)))
-		 (i 0 (1+ i)))
-		((endp completion))
-	      (when (= i end) (setf (cdr completion) nil))))))
-      (message "Done."))))
-
-(defcommand "Parse Buffer for Completions" (p)
-  "Zips over a buffer slamming everything that is a valid completion word
-   into the completion hashtable."
-  "Zips over a buffer slamming everything that is a valid completion word
-   into the completion hashtable."
-  (declare (ignore p))
-  (let ((buffer (prompt-for-buffer :prompt "Buffer to parse: "
-				   :must-exist t
-				   :default (current-buffer)
-				   :default-string (buffer-name
-						    (current-buffer)))))
-    (with-mark ((word-start (buffer-start-mark buffer) :right-inserting)
-		(word-end (buffer-start-mark buffer) :left-inserting)
-		(buffer-end-mark (buffer-start-mark buffer)))
-      (message "Starting parse of ~S..." (buffer-name buffer))
-      (loop
-	(unless (find-attribute word-start :completion-wordchar) (return))
-	(record-completion
-	 (region-to-string (region word-start
-				   (or (find-attribute
-					(move-mark word-end word-start)
-					:completion-wordchar #'zerop)
-				       buffer-end-mark))))
-	(move-mark word-start word-end))
-      (message "Done."))))
-
-
-
-;;;; Modeline hackery:
-
-(defvar *completion-mode-possibility* "")
-
-(defvar *completion-modeline-field* (modeline-field :completion))
-
-(defun display-possible-completion (prefix
-				    &optional (prefix-length (length prefix)))
-  (let ((old *completion-mode-possibility*))
-    (setq *completion-mode-possibility*
-	  (or (find-completion prefix prefix-length) ""))
-    (unless (eq old *completion-mode-possibility*)
-      (update-modeline-field *echo-area-buffer* *echo-area-window*
-			     *completion-modeline-field*))))
-
-(defun clear-completion-display ()
-  (unless (= (length (the simple-string *completion-mode-possibility*)) 0)
-    (setq *completion-mode-possibility* "")
-    (update-modeline-field *echo-area-buffer* *echo-area-window*
-			   *completion-modeline-field*)))
-
-
-;;; COMPLETION-REDISPLAY-FUN erases any completion displayed in the status line.
-;;;
-(defun completion-redisplay-fun (window)
-  (declare (ignore window))
-  (unless (eq (last-command-type) :completion-self-insert)
-    (clear-completion-display)))
-;;;
-(add-hook redisplay-hook #'completion-redisplay-fun)
diff --git a/hemlock/cursor.lisp b/hemlock/cursor.lisp
deleted file mode 100644
index 4b9d6b0ee26b1baff7b5d3969797db4f74f6457c..0000000000000000000000000000000000000000
--- a/hemlock/cursor.lisp
+++ /dev/null
@@ -1,423 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/cursor.lisp,v 1.1.1.4 1991/03/16 02:18:57 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Rob MacLachlan
-;;;
-;;; Cursor: Routines for cursor positioning and recentering
-;;;
-(in-package 'hemlock-internals)
-(export '(mark-to-cursorpos center-window displayed-p scroll-window
-			    mark-column cursorpos-to-mark move-to-column))
-
-
-;;;; Mark-To-Cursorpos
-;;;
-;;; Since performance analysis showed that HALF of the time in the editor
-;;; was being spent in this function, I threw all of the tricks in the
-;;; book at it to try and make it tenser.
-;;;
-;;; The algorithm is roughly as follows:
-;;;
-;;;    1) Eliminate the annoying boundry condition of the mark being
-;;; off the end of the window, if it is return NIL now.
-;;;    2) If the charpos is on or immediately after the last character
-;;; in the line, then find the last dis-line on which the line is
-;;; displayed.  We know that the mark is at the end of this dis-line
-;;; because it is known to be on the screen.  X position is trivially
-;;; derived from the dis-line-length.
-;;;    3) Call Real-Line-Length or Cached-Real-Line-Length to get the
-;;; X position and number of times wrapped.
-
-(proclaim '(special the-sentinel))
-
-(eval-when (compile eval)
-;;; find-line
-;;;
-;;;    Find a dis-line which line is displayed on which starts before
-;;; charpos, setting ypos and dis-line to the dis-line and it's index.
-;;; Offset is expected to be the mark-charpos of the display-start for
-;;; the window initially, and is set to offset within line that
-;;; Dis-Line begins.  Charpos is the mark-charpos of the mark we want
-;;; to find.  Check if same as *redisplay-favorite-line* and then scan
-;;; if not.
-;;;
-(defmacro find-line (line offset charpos ypos dis-lines dis-line)
-  (declare (ignore charpos))
-  `(cond
-    ;; No lines at all, fail.
-    ((eq ,dis-lines the-sentinel) nil)
-    ;; On the first line, offset is already set, so just set dis-line and
-    ;; ypos and fall through.
-    ((eq (dis-line-line (car ,dis-lines)) ,line)
-     (setq ,dis-line ,dis-lines  ,ypos 0))
-    ;; Look farther down. 
-    ((do ((l (cdr ,dis-lines) (cdr l)))
-	 ((eq l the-sentinel))
-       (when (eq (dis-line-line (car l)) ,line)
-	 (setq ,dis-line l  ,ypos (dis-line-position (car l)) ,offset 0)
-	 (return t))))
-    (t
-     (error "Horrible flaming lossage, Sorry Man."))))
-
-;;; find-last 
-;;;
-;;;    Find the last dis-line on which line is displayed, set ypos and 
-;;; dis-line.
-;;;
-(defmacro find-last (line ypos dis-line)
-  `(do ((trail ,dis-line dl)
-	(dl (cdr ,dis-line) (cdr dl)))
-       ((not (eq (dis-line-line (car dl)) ,line))
-	(setq ,dis-line (car trail)  ,ypos (dis-line-position ,dis-line)))))
-
-;;; find-charpos
-;;;
-;;;    Special-Case mark at end of line, if not punt out to real-line-length 
-;;; function.  Return the correct values.
-;;;
-(defmacro find-charpos (line offset charpos length ypos dis-line width
-			     fun chars)
-  (declare (ignore chars))
-  `(cond
-    ((= ,charpos ,length)
-     (find-last ,line ,ypos ,dis-line)
-     (values (min (dis-line-length ,dis-line) (1- ,width)) ,ypos))
-    ((= ,charpos (1- ,length))
-     (multiple-value-bind (x dy)
-			  (,fun ,line (1- ,width) ,offset ,charpos)
-       (if (and (not (zerop dy)) (zerop x))
-	   (values (1- ,width) (1- (+ ,ypos dy)))
-	   (values x (+ ,ypos dy)))))
-    (t
-     (multiple-value-bind (x dy)
-			  (,fun ,line (1- ,width) ,offset ,charpos)
-	  (values x (+ ,ypos dy))))))
-
-); eval-when (compile eval)
-
-;;; real-line-length 
-;;;
-;;;    Return as values the X position and the number of times wrapped if
-;;; one to display the characters from Start to End of Line starting at an
-;;; X position of 0 wrapping Width wide.
-;;; %SP-Find-Character-With-Attribute is used to find charaters 
-;;; with funny representation much as in Compute-Line-Image.
-;;;
-(defun real-line-length (line width start end)
-  (declare (fixnum width start end))
-  (do ((xpos 0)
-       (ypos 0)
-       (chars (line-chars line))
-       (losing 0)
-       (dy 0))
-      ((= start end) (values xpos ypos))
-    (declare (fixnum xpos ypos dy) (simple-string chars)
-	     (type (or fixnum null) losing))
-    (setq losing (%fcwa chars start end losing-char))
-    (when (null losing)
-      (multiple-value-setq (dy xpos) (truncate (+ xpos (- end start)) width))
-      (return (values xpos (+ ypos dy))))
-    (multiple-value-setq (dy xpos) (truncate (+ xpos (- losing start)) width))
-    (setq ypos (+ ypos dy)  start losing)
-    (do ((last (or (%fcwa chars start end winning-char) end)) str)
-	((= start last))
-      (declare (fixnum last))
-      (setq str (get-rep (schar chars start)))
-      (incf start)
-      (unless (simple-string-p str) (setq str (funcall str xpos)))
-      (multiple-value-setq (dy xpos) (truncate (+ xpos (strlen str)) width))
-      (setq ypos (+ ypos dy)))))
-
-;;; cached-real-line-length
-;;;
-;;;    The same as Real-Line-Length, except does it for the cached line.
-;;; the line argument is ignored, but present to make the arglists the
-;;; same.
-;;;
-(defun cached-real-line-length (line width start end)
-  (declare (fixnum width start end) (ignore line))
-  (let ((offset (- right-open-pos left-open-pos))
-	(bound 0))
-    (declare (fixnum offset bound))
-    (cond
-     ((>= start left-open-pos)
-      (setq start (+ start offset)  bound (setq end (+ end offset))))
-     ((> end left-open-pos)
-      (setq bound left-open-pos  end (+ end offset)))
-     (t
-      (setq bound end)))
-    
-    (do ((xpos 0)
-	 (ypos 0)
-	 (losing 0)
-	 (dy 0))
-	(())
-      (declare (fixnum xpos ypos dy)
-	       (type (or fixnum null) losing))
-      (when (= start bound)
-	(when (= start end) (return (values xpos ypos)))
-	(setq start right-open-pos  bound end))
-      (setq losing (%fcwa open-chars start bound losing-char))
-      (cond
-       (losing
-	(multiple-value-setq (dy xpos)
-	  (truncate (+ xpos (- losing start)) width))
-	(setq ypos (+ ypos dy)  start losing)
-	(do ((last (or (%fcwa open-chars start bound winning-char) bound)) str)
-	    ((= start last))
-	  (declare (fixnum last))
-	  (setq str (get-rep (schar open-chars start)))
-	  (incf start)
-	  (unless (simple-string-p str) (setq str (funcall str xpos)))
-	  (multiple-value-setq (dy xpos)
-	    (truncate (+ xpos (strlen str)) width))
-	  (setq ypos (+ ypos dy))))
-       (t
-	(multiple-value-setq (dy xpos)
-	  (truncate (+ xpos (- bound start)) width))
-	(setq ypos (+ ypos dy)  start bound))))))
-
-;;; mark-to-cursorpos  --  Public
-;;;
-;;;    Return as multiple values the x and y position within window of
-;;; mark.  NIL is returned if the mark is not displayed in the window given
-;;;
-;;;
-(defun mark-to-cursorpos (mark window)
-  "Return the (x, y) position of mark within window, or NIL if not displayed."
-  (maybe-update-window-image window)
-  (let* ((line (mark-line mark))
-	 (number (line-number line))
-	 (charpos (mark-charpos mark))
-	 (dis-lines (cdr (window-first-line window)))
-	 (width (window-width window))
-	 (start (window-display-start window))
-	 (offset (mark-charpos start))
-	 (start-number (line-number (mark-line start)))
-	 (end (window-display-end window))
-	 (end-number (line-number (mark-line end)))
-	 (ypos 0)
-	 dis-line)
-    (declare (fixnum width charpos ypos number end-number))
-    (cond
-     ((or (< number start-number)
-	  (and (= number start-number) (< charpos offset))
-	  (> number end-number)
-	  (and (= number end-number) (> charpos (mark-charpos end)))) nil)
-     (t
-      (find-line line offset charpos ypos dis-lines dis-line)
-      (cond
-       ((eq line open-line)
-	(let ((len (- line-cache-length (- right-open-pos left-open-pos))))
-	  (declare (fixnum len))
-	  (find-charpos line offset charpos len ypos dis-line width
-			cached-real-line-length open-chars)))
-       (t
-	(let* ((chars (line-chars line))
-	       (len (strlen chars)))
-	  (declare (fixnum len) (simple-string chars))
-	  (find-charpos line offset charpos len ypos dis-line width
-			real-line-length chars))))))))
-
-;;; Dis-Line-Offset-Guess  --  Internal
-;;;
-;;;    Move Mark by Offset display lines.  The mark is assumed to be at the
-;;; beginning of a display line, and we attempt to leave it at one.  We assume
-;;; all characters print one wide.  Width is the width of the window we are
-;;; displaying in.
-;;;
-(defun dis-line-offset-guess (mark offset width)
-  (let ((w (1- width)))
-    (if (minusp offset)
-	(dotimes (i (- offset) t)
-	  (let ((pos (mark-charpos mark)))
-	    (if (>= pos w)
-		(character-offset mark (- w))
-		(let ((prev (line-previous (mark-line mark))))
-		  (unless prev (return nil))
-		  (multiple-value-bind
-		      (lines chars)
-		      (truncate (line-length prev) w)
-		    (move-to-position mark
-				      (cond ((zerop lines) 0)
-					    ((< chars 2)
-					     (* w (1- lines)))
-					    (t
-					     (* w lines)))
-				      prev))))))
-	(dotimes (i offset t)
-	  (let ((left (- (line-length (mark-line mark))
-			 (mark-charpos mark))))
-	    (if (> left width)
-		(character-offset mark w)
-		(unless (line-offset mark 1 0)
-		  (return nil))))))))
-
-;;; maybe-recenter-window  --  Internal
-;;;
-;;;     Update the dis-lines for Window and recenter if the point is off
-;;; the screen.
-;;;
-(defun maybe-recenter-window (window)
-  (unless (%displayed-p (buffer-point (window-buffer window)) window)
-    (center-window window (buffer-point (window-buffer window)))
-    t))
-
-;;; center-window  --  Public
-;;;
-;;;    Try to move the start of window so that Mark is on a line in the 
-;;; center.
-;;;
-(defun center-window (window mark)
-  "Adjust the start of Window so that Mark is displayed on the center line."
-  (let ((height (window-height window))
-	(start (window-display-start window)))
-    (move-mark start mark)
-    (unless (dis-line-offset-guess start (- (truncate height 2))
-				   (window-width window))
-      (move-mark start (buffer-start-mark (window-buffer window))))
-    (update-window-image window)
-    ;; If that doesn't work, panic and make the start the point.
-    (unless (%displayed-p mark window)
-      (move-mark start mark)
-      (update-window-image window))))
-
-
-;;; %Displayed-P  --  Internal
-;;;
-;;;    If Mark is within the displayed bounds in Window, then return true,
-;;; otherwise false.  We assume the window image is up to date.
-;;;
-(defun %displayed-p (mark window)
-  (let ((start (window-display-start window))
-	(end (window-display-end window)))
-    (not (or (mark< mark start) (mark> mark end)
-	     (if (mark= mark end)
-		 (let ((ch (next-character end)))
-		   (and ch (char/= ch #\newline)))
-		 nil)))))
-
-
-;;; Displayed-p  --  Public
-;;;
-;;;    Update the window image and then check if the mark is displayed.
-;;;
-(defun displayed-p (mark window)
-  "Return true if Mark is displayed on Window, false otherwise."
-  (maybe-update-window-image window)
-  (%displayed-p mark window))
-
-
-;;; scroll-window  --  Public
-;;;
-;;;    This is not really right, since it uses dis-line-offset-guess.
-;;; Probably if there is any screen overlap then we figure it out
-;;; exactly.
-;;;
-(defun scroll-window (window n)
-  "Scroll Window down N lines, up if negative."
-  (let ((start (window-display-start window))
-	(point (window-point window))
-	(width (window-width window))
-	(height (window-height window)))
-    (cond ((dis-line-offset-guess start n width))
-	  ((minusp n)
-	   (buffer-start start))
-	  (t
-	   (buffer-end start)
-	   (let ((fraction (- (truncate height 3) height)))
-	     (dis-line-offset-guess start fraction width))))
-    (update-window-image window)
-    (let ((iscurrent (eq window *current-window*))
-	  (bpoint (buffer-point (window-buffer window))))
-      (when iscurrent (move-mark point bpoint))
-      (unless (%displayed-p point window)
-	(move-mark point start)
-	(dis-line-offset-guess point (truncate (window-height window) 2)
-			       width)
-      (when iscurrent (move-mark bpoint point)))))
-  t)
-
-;;; Mark-Column  --  Public
-;;;
-;;;    Find the X position of a mark supposing that it were displayed
-;;; in an infinitely wide screen.
-;;;
-(defun mark-column (mark)
-  "Find the X position at which Mark would be displayed if it were on
-  an infinitely wide screen.  This takes into account tabs and control
-  characters."
-  (let ((charpos (mark-charpos mark))
-	(line (mark-line mark)))
-    (if (eq line open-line)
-	(values (cached-real-line-length line 10000 0 charpos))
-	(values (real-line-length line 10000 0 charpos)))))
-
-;;; Find-Position  --  Internal
-;;;
-;;;    Return the charpos which corresponds to the specified X position
-;;; within Line.  If there is no such position between Start and End then
-;;; rutne NIL.
-;;;
-(defun find-position (line position start end width)
-  (do* ((cached (eq line open-line))
-	(lo start)
-	(hi (1- end))
-	(probe (truncate (+ lo hi) 2) (truncate (+ lo hi) 2)))
-       ((> lo hi)
-	(if (= lo end) nil hi))
-    (let ((val (if cached
-		   (cached-real-line-length line width start probe)
-		   (real-line-length line width start probe))))
-      (cond ((= val position) (return probe))
-	    ((< val position) (setq lo (1+ probe)))
-	    (t (setq hi (1- probe)))))))
-
-;;; Cursorpos-To-Mark  --  Public
-;;;
-;;;    Find the right dis-line, then zero in on the correct position
-;;; using real-line-length.
-;;;
-(defun cursorpos-to-mark (x y window)
-  (check-type window window)
-  (let ((width (window-width window))
-	(first (window-first-line window)))
-    (when (>= x width)
-      (return-from cursorpos-to-mark nil))
-    (do* ((prev first dl)
-	  (dl (cdr first) (cdr dl))
-	  (ppos (mark-charpos (window-display-start window))
-		(if (eq (dis-line-line (car dl)) (dis-line-line (car prev)))
-		    (dis-line-end (car prev)) 0)))
-	((eq dl the-sentinel)
-	 (copy-mark (window-display-end window) :temporary))
-      (when (= (dis-line-position (car dl)) y)
-	(let* ((line (dis-line-line (car dl)))
-	       (end (dis-line-end (car dl))))
-	  (return (mark line (or (find-position line x ppos end width) end))))))))
-
-;;; Move-To-Column  --  Public
-;;;
-;;;    Just look up the charpos using find-position...
-;;;
-(defun move-to-column (mark column &optional (line (mark-line mark)))
-  "Move Mark to the specified Column on Line.  This function is analogous
-  to Move-To-Position, but it deals with the physical screen position
-  as returned by Mark-Column; the mark is moved to before the character
-  which would be displayed in Column if the line were displayed on
-  an infinitely wide screen.  If the column specified is greater than
-  the column of the last character, then Nil is returned and the mark
-  is not modified."
-  (let ((res (find-position line column 0 (line-length line) 10000)))
-    (if res
-	(move-to-position mark res line))))
diff --git a/hemlock/debug.lisp b/hemlock/debug.lisp
deleted file mode 100644
index a2ac91eab4ea2b14fafb30bc71f68be97e255a9c..0000000000000000000000000000000000000000
--- a/hemlock/debug.lisp
+++ /dev/null
@@ -1,532 +0,0 @@
-;;; -*- Mode: Lisp; Package: ED; Log: hemlock.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/debug.lisp,v 1.4 1991/10/12 20:57:29 chiles Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This contains commands for sending debugger commands to slaves in the
-;;; debugger.
-;;;
-;;; Written by Bill Chiles.
-;;;
-
-(in-package "HEMLOCK")
-
-
-
-;;;; DEFINE-DEBUGGER-COMMAND.
-
-(defmacro define-debugger-command (name doc cmd &key uses-argument)
-  `(defcommand ,(concatenate 'simple-string "Debug " name) (p)
-     ,doc ,doc
-     ,@(if uses-argument
-	   nil
-	   '((declare (ignore p))))
-     (let* ((server-info (get-current-eval-server t))
-	    (wire (server-info-wire server-info)))
-       (wire:remote wire
-	 (ts-stream-accept-input
-	  (ts-data-stream (server-info-slave-info server-info))
-	  ,(if uses-argument
-	       `(list ,cmd p)
-	       cmd)))
-       (wire:wire-force-output wire))))
-
-
-
-;;;; Frame changing commands.
-
-(define-debugger-command "Up"
-  "Moves the \"Current Eval Server\" up one debugger frame."
-  :up)
-
-(define-debugger-command "Down"
-  "Moves the \"Current Eval Server\" down one debugger frame."
-  :down)
-
-(define-debugger-command "Top"
-  "Moves the \"Current Eval Server\" to the top of the debugging stack."
-  :top)
-
-(define-debugger-command "Bottom"
-  "Moves the \"Current Eval Server\" to the bottom of the debugging stack."
-  :bottom)
-
-(define-debugger-command "Frame"
-  "Moves the \"Current Eval Server\" to the absolute debugger frame number
-   indicated by the prefix argument."
-  :frame
-  :uses-argument t)
-
-
-
-;;;; In and Out commands.
-
-(define-debugger-command "Quit"
-  "In the \"Current Eval Server\", throws to top level out of the debugger."
-  :quit)
-
-(define-debugger-command "Go"
-  "In the \"Current Eval Server\", tries the CONTINUE restart."
-  :go)
-
-(define-debugger-command "Abort"
-  "In the \"Current Eval Server\", execute the previous ABORT restart."
-  :abort)
-
-(define-debugger-command "Restart"
-  "In the \"Current Eval Server\", executes the restart indicated by the
-   prefix argument."
-  :restart
-  :uses-argument t)
-
-
-
-;;;; Information commands.
-
-(define-debugger-command "Help"
-  "In the \"Current Eval Server\", prints the debugger's help text."
-  :help)
-
-(define-debugger-command "Error"
-  "In the \"Current Eval Server\", print the error condition and restart cases
-   upon entering the debugger."
-  :error)
-
-(define-debugger-command "Backtrace"
-  "Executes the debugger's BACKTRACE command."
-  :backtrace)
-
-(define-debugger-command "Print"
-  "In the \"Current Eval Server\", prints a representation of the debugger's
-   current frame."
-  :print)
-
-(define-debugger-command "Verbose Print"
-  "In the \"Current Eval Server\", prints a representation of the debugger's
-   current frame without elipsis."
-  :vprint)
-
-(define-debugger-command "List Locals"
-  "In the \"Current Eval Server\", prints the local variables for the debugger's
-   current frame."
-  :list-locals)
-
-(define-debugger-command "Source"
-  "In the \"Current Eval Server\", prints the source form for the debugger's
-   current frame."
-  :source)
-
-(define-debugger-command "Verbose Source"
-  "In the \"Current Eval Server\", prints the source form for the debugger's
-   current frame with surrounding forms for context."
-  :vsource)
-
-
-
-;;;; Source editing.
-
-;;; "Debug Edit Source" -- Command.
-;;;
-;;; The :edit-source command in the slave debugger initiates a synchronous RPC
-;;; into the editor via the wire in *terminal-io*, a typescript stream.  This
-;;; routine takes the necessary values, a file and source-path, and changes the
-;;; editor's state to display that location.
-;;;
-;;; This command has to wait on SERVE-EVENT until some special is set by the
-;;; RPC routine saying it is okay to return to the editor's top level.
-;;;
-(defvar *debug-editor-source-data* nil)
-
-(defcommand "Debug Edit Source" (p)
-  "Given the \"Current Eval Server\"'s current debugger frame, place the user
-   at the location's source in the editor."
-  "Given the \"Current Eval Server\"'s current debugger frame, place the user
-   at the location's source in the editor."
-  (declare (ignore p))
-  (let* ((server-info (get-current-eval-server t))
-	 (wire (server-info-wire server-info)))
-    ;;
-    ;; Tell the slave to tell the editor some source info.
-    (wire:remote wire
-      (ts-stream-accept-input
-       (ts-data-stream (server-info-slave-info server-info))
-       :edit-source))
-    (wire:wire-force-output wire)
-    ;;
-    ;; Wait for the source info.
-    (let ((*debug-editor-source-data* nil))
-      (loop
-	(system:serve-event)
-	(when *debug-editor-source-data* (return))))))
-
-;;; EDIT-SOURCE-LOCATION -- Internal Interface.
-;;;
-;;; The slave calls this in the editor when the debugger gets an :edit-source
-;;; command.  This receives the information necessary to take the user in
-;;; Hemlock to the source location, and does it.
-;;;
-(defun edit-source-location (name source-created-date tlf-offset
-			     local-tlf-offset char-offset form-number)
-  (let ((pn (pathname name)))
-    (unless (probe-file pn)
-      (editor-error "Source file no longer exists: ~A." name))
-    (multiple-value-bind (buffer newp) (find-file-buffer pn)
-      (let ((date (buffer-write-date buffer))
-	    (point (buffer-point buffer)))
-	(when newp (push-buffer-mark (copy-mark point) nil))
-	(buffer-start point)
-	;;
-	;; Get to the top-level form in the buffer.
-	(cond ((buffer-modified buffer)
-	       (loud-message "Buffer has been modified.  Using form offset ~
-			      instead of character position.")
-	       (dotimes (i local-tlf-offset) 
-		 (pre-command-parse-check point)
-		 (form-offset point 1)))
-	      ((not date)
-	       (loud-message "Cannot compare write dates.  Assuming source ~
-			      has not been modified -- ~A."
-			     name)
-	       (character-offset point char-offset))
-	      ((= source-created-date date)
-	       (character-offset point char-offset))
-	      (t
-	       (loud-message "File has been modified since reading the source.  ~
-			      Using form offset instead of character position.")
-	       (dotimes (i local-tlf-offset) 
-		 (pre-command-parse-check point)
-		 (form-offset point 1))))
-	;;
-	;; Read our form, get form-number translations, get the source-path,
-	;; and make it usable.
-	(let ((path (nreverse
-		     (butlast
-		      (cdr
-		       (svref (di:form-number-translations
-			       (with-input-from-region
-				   (s (region point (buffer-end-mark buffer)))
-				 (read s))
-			       tlf-offset)
-			      form-number))))))
-	  ;;
-	  ;; Walk down to the form.  Change to buffer in case we get an error
-	  ;; while finding the form.
-	  (change-to-buffer buffer)
-	  (mark-to-debug-source-path point path)))))
-  (setf *debug-editor-source-data* t)
-  ;;
-  ;; While Hemlock was setting up the source edit, the user could have typed
-  ;; while looking at a buffer no longer current when the commands execute.
-  (clear-editor-input *editor-input*))
-
-;;; CANNOT-EDIT-SOURCE-LOCATION -- Interface.
-;;;
-;;; The slave calls this when the debugger command "EDIT-SOURCE" runs, and the
-;;; slave cannot give the editor source information.
-;;;
-(defun cannot-edit-source-location ()
-  (throw 'editor-top-level nil))
-
-
-
-;;;; Breakpoints.
-
-;;;
-;;; Breakpoint information for editor management.
-;;;
-
-;;; This holds all the stuff we might want to know about a breakpoint in some
-;;; slave.
-;;;
-(defstruct (breakpoint-info (:print-function print-breakpoint-info)
-			    (:constructor make-breakpoint-info
-					  (slave buffer remote-object name)))
-  (slave nil :type server-info)
-  (buffer nil :type buffer)
-  (remote-object nil :type wire:remote-object)
-  (name nil :type simple-string))
-;;;
-(defun print-breakpoint-info (obj str n)
-  (declare (ignore n))
-  (format str "#<Breakpoint-Info for ~S>" (breakpoint-info-name obj)))
-
-(defvar *breakpoints* nil)
-
-(macrolet ((frob (name accessor)
-	     `(defun ,name (key)
-		(let ((res nil))
-		  (dolist (bpt-info *breakpoints* res)
-		    (when (eq (,accessor bpt-info) key)
-		      (push bpt-info res)))))))
-  (frob slave-breakpoints breakpoint-info-slave)
-  (frob buffer-breakpoints breakpoint-info-buffer))
-
-(defun delete-breakpoints-buffer-hook (buffer)
-  (let ((server-info (value current-eval-server)))
-    (when server-info
-      (let ((bpts (buffer-breakpoints buffer))
-	    (wire (server-info-wire server-info)))
-	(dolist (b bpts)
-	  (setf *breakpoints* (delete b *breakpoints*))
-	  (wire:remote wire
-	    (di:delete-breakpoint (breakpoint-info-remote-object b))))
-	(wire:wire-force-output wire)))))
-;;;
-(add-hook delete-buffer-hook 'delete-breakpoints-buffer-hook)
-
-;;;
-;;; Setting breakpoints.
-;;;
-
-;;; "Debug Breakpoint" uses this to prompt for :function-end and
-;;; :function-start breakpoints.
-;;;
-(defvar *function-breakpoint-strings*
-  (make-string-table :initial-contents
-		     '(("Start" . :function-start) ("End" . :function-end))))
-;;;
-;;; Maybe this should use the wire level directly and hold onto remote-objects
-;;; identifying the breakpoints.  Then we could write commands to show where
-;;; the breakpoints were and to individually deactivate or delete them.  As it
-;;; is now we probably have to delete all for a given function.  What about
-;;; setting user supplied breakpoint hook-functions, or Hemlock supplying a
-;;; nice set such as something to simply print all locals at a certain
-;;; location.
-;;;
-(defcommand "Debug Breakpoint" (p)
-  "This tries to set a breakpoint in the \"Current Eval Server\" at the
-   location designated by the current point.  If there is no known code
-   location at the point, then this moves the point to the closest location
-   before the point.  With an argument, this sets a breakpoint at the start
-   or end of the function, prompting the user for which one to use."
-  "This tries to set a breakpoint in the \"Current Eval Server\" at the
-   location designated by the current point.  If there is no known code
-   location at the point, then this moves the point to the closest location
-   before the point.  With an argument, this sets a breakpoint at the start
-   or end of the function, prompting the user for which one to use."
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (let ((name (find-defun-for-breakpoint point)))
-      (if p
-	  (multiple-value-bind (str place)
-			       (prompt-for-keyword
-				(list *function-breakpoint-strings*)
-				:prompt "Set breakpoint at function: "
-				:default :start :default-string "Start")
-	    (declare (ignore str))
-	    (set-breakpoint-in-slave (get-current-eval-server t) name place))
-	  (let* ((path (find-path-for-breakpoint point))
-		 (server-info (get-current-eval-server t))
-		 (res (set-breakpoint-in-slave server-info name path)))
-	    (cond ((not res)
-		   (message "No code locations correspond with point."))
-		  ((wire:remote-object-p res)
-		   (push (make-breakpoint-info server-info (current-buffer)
-					       res name)
-			 *breakpoints*)
-		   (message "Breakpoint set."))
-		  (t
-		   (resolve-ambiguous-breakpoint-location server-info
-							  name res))))))))
-
-;;; FIND-PATH-FOR-BREAKPOINT -- Internal.
-;;;
-;;; This walks up from point to the beginning of its containing DEFUN to return
-;;; the pseudo source-path (no form-number, no top-level form offset, and in
-;;; descent order from start of the DEFUN).
-;;;
-(defun find-path-for-breakpoint (point)
-  (with-mark ((m point)
-	      (end point))
-    (let ((path nil))
-      (top-level-offset end -1)
-      (with-mark ((containing-form m))
-	(loop
-	  (when (mark= m end) (return))
-	  (backward-up-list containing-form)
-	  (do ((count 0 (1+ count)))
-	      ((mark= m containing-form)
-	       ;; Count includes moving from the first form inside the
-	       ;; containing-form paren to the outside of the containing-form
-	       ;; paren -- one too many.
-	       (push (1- count) path))
-	    (form-offset m -1))))
-      path)))
-
-;;; SET-BREAKPOINT-IN-SLAVE -- Internal.
-;;;
-;;; This tells the slave to set a breakpoint for name.  Path is a modified
-;;; source-path (with no form-number or top-level-form offset) or a symbol
-;;; (:function-start or :function-end).  If the server dies while evaluating
-;;; form, then this signals an editor-error.
-;;;
-(defun set-breakpoint-in-slave (server-info name path)
-  (when (server-info-notes server-info)
-    (editor-error "Server ~S is currently busy.  See \"List Operations\"."
-		  (server-info-name server-info)))
-  (multiple-value-bind (res error)
-		       (wire:remote-value (server-info-wire server-info)
-			 (di:set-breakpoint-for-editor (value current-package)
-						       name path))
-    (when error (editor-error "The server died before finishing."))
-    res))
-
-;;; RESOLVE-AMBIGUOUS-BREAKPOINT-LOCATION -- Internal.
-;;;
-;;; This helps the user select an ambiguous code location for "Debug
-;;; Breakpoint".
-;;;
-(defun resolve-ambiguous-breakpoint-location (server-info name locs)
-  (declare (list locs))
-  (let ((point (current-point))
-	(loc-num (length locs))
-	(count 1)
-	(cur-loc locs))
-    (flet ((show-loc ()
-	     (top-level-offset point -1)
-	     (mark-to-debug-source-path point (cdar cur-loc))))
-      (show-loc)
-      (command-case (:prompt `("Ambiguous location ~D of ~D: " ,count ,loc-num)
-		      :help "Pick a location to set a breakpoint."
-		      :change-window nil)
-	(#\space "Move point to next possible location."
-	  (setf cur-loc (cdr cur-loc))
-	  (cond (cur-loc
-		 (incf count))
-		(t
-		 (setf cur-loc locs)
-		 (setf count 1)))
-	  (show-loc)
-	  (reprompt))
-	(:confirm "Choose the current location."
-	  (let ((res (wire:remote-value (server-info-wire server-info)
-		       (di:set-location-breakpoint-for-editor (caar cur-loc)))))
-	    (unless (wire:remote-object-p res)
-	      (editor-error "Couldn't set breakpoint from location?"))
-	    (push (make-breakpoint-info server-info (current-buffer) res name)
-		  *breakpoints*))
-	  (message "Breakpoint set."))))))
-
-;;; MARK-TO-DEBUG-SOURCE-PATH -- Internal.
-;;;
-;;; This takes a mark at the beginning of a top-level form and modified debugger
-;;; source-path.  Path has no form number or top-level-form offset element, and
-;;; it has been reversed to actually be usable.
-;;;
-(defun mark-to-debug-source-path (mark path)
-  (let ((quote-or-function nil))
-    (pre-command-parse-check mark)
-    (dolist (n path)
-      (when quote-or-function
-	(editor-error
-	 "Apparently settled on the symbol QUOTE or FUNCTION via their ~
-	  read macros, which is odd, but furthermore there seems to be ~
-	  more source-path left."))
-      (unless (form-offset mark 1)
-	;; Want to use the following and delete the next FORM-OFFSET -1.
-	;; (scan-direction-valid mark t (or :open-paren :prefix))
-	(editor-error
-	 "Ran out of text in buffer with more source-path remaining."))
-      (form-offset mark -1)
-      (ecase (next-character mark)
-	(#\(
-	 (mark-after mark)
-	 (form-offset mark n))
-	(#\'
-	 (case n
-	   (0 (setf quote-or-function t))
-	   (1 (mark-after mark))
-	   (t (editor-error "Next form is QUOTE, but source-path index ~
-			     is other than zero or one."))))
-	(#\#
-	 (case (next-character (mark-after mark))
-	   (#\'
-	    (case n
-	      (0 (setf quote-or-function t))
-	      (1 (mark-after mark))
-	      (t (editor-error "Next form is FUNCTION, but source-path ~
-				index is other than zero or one."))))
-	   (t (editor-error
-	       "Can only parse ' and #' read macros."))))))
-    ;; Get to the beginning of the form.
-    (form-offset mark 1)
-    (form-offset mark -1)))
-
-;;;
-;;; Deleting breakpoints.
-;;;
-
-(defhvar "Delete Breakpoints Confirm"
-  "This determines whether \"Debug Delete Breakpoints\" should ask for
-   confirmation before deleting breakpoints."
-  :value t)
-
-(defcommand "Debug Delete Breakpoints" (p)
-  "This deletes all breakpoints for the named DEFUN containing the point.
-   This affects the \"Current Eval Server\"."
-  "This deletes all breakpoints for the named DEFUN containing the point.
-   This affects the \"Current Eval Server\"."
-  (declare (ignore p))
-  (let* ((server-info (get-current-eval-server t))
-	 (wire (server-info-wire server-info))
-	 (name (find-defun-for-breakpoint (current-point)))
-	 (bpts (slave-breakpoints server-info)))
-    (cond ((not bpts)
-	   (message "No breakpoints recorded for ~A." name))
-	  ((or (not (value delete-breakpoints-confirm))
-	       (prompt-for-y-or-n :prompt `("Delete breakpoints for ~A? " ,name)
-				  :default t
-				  :default-string "Y"))
-	   (dolist (b bpts)
-	     (when (string= name (breakpoint-info-name b))
-	       (setf *breakpoints* (delete b *breakpoints*))
-	       (wire:remote wire
-		 (di:delete-breakpoint-for-editor
-		  (breakpoint-info-remote-object b)))))
-	   (wire:wire-force-output wire)))))
-
-;;;
-;;; Breakpoint utilities.
-;;;
-
-;;; FIND-DEFUN-FOR-BREAKPOINT -- Internal.
-;;;
-;;; This returns as a string the name of the DEFUN containing point.  It
-;;; signals any errors necessary to ensure "we are in good form".
-;;;
-(defun find-defun-for-breakpoint (point)
-  (with-mark ((m1 point)
-	      (m2 point))
-    (unless (top-level-offset m2 -1)
-      (editor-error "Must be inside a DEFUN."))
-    ;;
-    ;; Check for DEFUN.
-    (mark-after (move-mark m1 m2))
-    (unless (find-attribute m1 :whitespace #'zerop)
-      (editor-error "Must be inside a DEFUN."))
-    (word-offset (move-mark m2 m1) 1)
-    (unless (string-equal (region-to-string (region m1 m2)) "defun")
-      (editor-error "Must be inside a DEFUN."))
-    ;;
-    ;; Find name.
-    (unless (find-attribute m2 :whitespace #'zerop)
-      (editor-error "Function unnamed?"))
-    (form-offset (move-mark m1 m2) 1)
-    (region-to-string (region m2 m1))))
-
-
-
-;;;; Miscellaneous commands.
-
-(define-debugger-command "Flush Errors"
-  "In the \"Current Eval Server\", toggles whether the debugger ignores errors
-   or recursively enters itself."
-  :flush)
diff --git a/hemlock/defsyn.lisp b/hemlock/defsyn.lisp
deleted file mode 100644
index 641cce0fc2670eaa8f3c718996e431167a5a4ca2..0000000000000000000000000000000000000000
--- a/hemlock/defsyn.lisp
+++ /dev/null
@@ -1,160 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/defsyn.lisp,v 1.2 1991/02/08 16:33:45 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains definitions of various character attributes.
-;;;
-(in-package 'hemlock)
-
-(defattribute "Whitespace"
-  "A value of 1 for this attribute indicates that the corresponding character
-  should be considered as whitespace.  This is used by the Blank-Line-P
-  function.")
-
-(setf (character-attribute :whitespace #\space) 1)
-(setf (character-attribute :whitespace #\linefeed) 1)
-(setf (character-attribute :whitespace #\tab) 1)
-(setf (character-attribute :whitespace #\newline) 1)
-
-(defattribute "Word Delimiter"
-  "A value of 1 for this attribute indicates that the corresponding character
-  separates words.  This is used by the word manipulating commands.")
-
-(setf (character-attribute :word-delimiter nil) 1)
-(setf (character-attribute :word-delimiter #\!) 1)
-(setf (character-attribute :word-delimiter #\@) 1)
-(setf (character-attribute :word-delimiter #\#) 1)
-(setf (character-attribute :word-delimiter #\$) 1)
-(setf (character-attribute :word-delimiter #\%) 1)
-(setf (character-attribute :word-delimiter #\^) 1)
-(setf (character-attribute :word-delimiter #\&) 1)
-(setf (character-attribute :word-delimiter #\*) 1)
-(setf (character-attribute :word-delimiter #\() 1)
-(setf (character-attribute :word-delimiter #\)) 1)
-(setf (character-attribute :word-delimiter #\-) 1)
-(setf (character-attribute :word-delimiter #\_) 1)
-(setf (character-attribute :word-delimiter #\=) 1)
-(setf (character-attribute :word-delimiter #\+) 1)
-(setf (character-attribute :word-delimiter #\[) 1)
-(setf (character-attribute :word-delimiter #\]) 1)
-(setf (character-attribute :word-delimiter #\\) 1)
-(setf (character-attribute :word-delimiter #\|) 1)
-(setf (character-attribute :word-delimiter #\;) 1)
-(setf (character-attribute :word-delimiter #\:) 1)
-(setf (character-attribute :word-delimiter #\') 1)
-(setf (character-attribute :word-delimiter #\") 1)
-(setf (character-attribute :word-delimiter #\{) 1)
-(setf (character-attribute :word-delimiter #\}) 1)
-(setf (character-attribute :word-delimiter #\,) 1)
-(setf (character-attribute :word-delimiter #\.) 1)
-(setf (character-attribute :word-delimiter #\<) 1)
-(setf (character-attribute :word-delimiter #\>) 1)
-(setf (character-attribute :word-delimiter #\/) 1)
-(setf (character-attribute :word-delimiter #\?) 1)
-(setf (character-attribute :word-delimiter #\`) 1)
-(setf (character-attribute :word-delimiter #\~) 1)
-(setf (character-attribute :word-delimiter #\space) 1)
-(setf (character-attribute :word-delimiter #\linefeed) 1)
-(setf (character-attribute :word-delimiter #\formfeed) 1)
-(setf (character-attribute :word-delimiter #\tab) 1)
-(setf (character-attribute :word-delimiter #\newline) 1)
-
-(shadow-attribute :word-delimiter #\. 0 "Fundamental")
-(shadow-attribute :word-delimiter #\' 0 "Text")
-(shadow-attribute :word-delimiter #\backspace 0 "Text")
-(shadow-attribute :word-delimiter #\_ 0 "Text")
-
-(defattribute "Page Delimiter"
-  "This attribute is 1 for characters that separate pages, 0 otherwise.")
-(setf (character-attribute :page-delimiter nil) 1)
-(setf (character-attribute :page-delimiter #\page) 1)
-
-
-(defattribute "Lisp Syntax"
-  "These character attribute is used by the lisp mode commands, and possibly
-  other people.  The value of ths attribute is always a symbol.  Currently
-  defined values are:
-   NIL - No interesting properties.
-   :space - Acts like whitespace, should not include newline.
-   :newline - Newline, man.
-   :open-paren - An opening bracket.
-   :close-paren - A closing bracket.
-   :prefix - A character that is a part of any form it appears before.
-   :string-quote - The character that quotes a string.
-   :char-quote - The character that escapes a single character.
-   :comment - The character that comments out to end of line.
-   :constituent - Things that make up symbols."
-  'symbol nil)
-
-(setf (character-attribute :lisp-syntax #\space) :space)
-(setf (character-attribute :lisp-syntax #\tab) :space)
-
-(setf (character-attribute :lisp-syntax #\() :open-paren)
-(setf (character-attribute :lisp-syntax #\)) :close-paren)
-(setf (character-attribute :lisp-syntax #\') :prefix)
-(setf (character-attribute :lisp-syntax #\`) :prefix)  
-(setf (character-attribute :lisp-syntax #\#) :prefix)
-(setf (character-attribute :lisp-syntax #\,) :prefix)
-(setf (character-attribute :lisp-syntax #\") :string-quote)
-(setf (character-attribute :lisp-syntax #\\) :char-quote)
-(setf (character-attribute :lisp-syntax #\;) :comment)
-(setf (character-attribute :lisp-syntax #\newline) :newline)
-(setf (character-attribute :lisp-syntax nil) :newline)
-
-(do-alpha-chars (ch :both)
-  (setf (character-attribute :lisp-syntax ch) :constituent))
-
-(setf (character-attribute :lisp-syntax #\0) :constituent)
-(setf (character-attribute :lisp-syntax #\1) :constituent)
-(setf (character-attribute :lisp-syntax #\2) :constituent)
-(setf (character-attribute :lisp-syntax #\3) :constituent)
-(setf (character-attribute :lisp-syntax #\4) :constituent)
-(setf (character-attribute :lisp-syntax #\5) :constituent)
-(setf (character-attribute :lisp-syntax #\6) :constituent)
-(setf (character-attribute :lisp-syntax #\7) :constituent)
-(setf (character-attribute :lisp-syntax #\8) :constituent)
-(setf (character-attribute :lisp-syntax #\9) :constituent)
-
-(setf (character-attribute :lisp-syntax #\!) :constituent)
-(setf (character-attribute :lisp-syntax #\{) :constituent)
-(setf (character-attribute :lisp-syntax #\}) :constituent)
-(setf (character-attribute :lisp-syntax #\[) :constituent)
-(setf (character-attribute :lisp-syntax #\]) :constituent)
-(setf (character-attribute :lisp-syntax #\/) :constituent)
-(setf (character-attribute :lisp-syntax #\@) :constituent)
-(setf (character-attribute :lisp-syntax #\-) :constituent)
-(setf (character-attribute :lisp-syntax #\_) :constituent)
-(setf (character-attribute :lisp-syntax #\+) :constituent)
-(setf (character-attribute :lisp-syntax #\%) :constituent)
-(setf (character-attribute :lisp-syntax #\*) :constituent)
-(setf (character-attribute :lisp-syntax #\$) :constituent)
-(setf (character-attribute :lisp-syntax #\^) :constituent)
-(setf (character-attribute :lisp-syntax #\&) :constituent)
-(setf (character-attribute :lisp-syntax #\~) :constituent)
-(setf (character-attribute :lisp-syntax #\=) :constituent)
-(setf (character-attribute :lisp-syntax #\<) :constituent)
-(setf (character-attribute :lisp-syntax #\>) :constituent)
-(setf (character-attribute :lisp-syntax #\?) :constituent)
-(setf (character-attribute :lisp-syntax #\.) :constituent)
-(setf (character-attribute :lisp-syntax #\:) :constituent)
-
-
-(defattribute "Sentence Terminator"
-  "Used for terminating sentences -- ., !, ?.
-   Possibly could make type (mod 3) and use the value of 2 and 1 for spaces
-   to place after chacter."
-  '(mod 2)
-  0)
-
-(setf (character-attribute :sentence-terminator #\.) 1)
-(setf (character-attribute :sentence-terminator #\!) 1)
-(setf (character-attribute :sentence-terminator #\?) 1)
diff --git a/hemlock/dired.lisp b/hemlock/dired.lisp
deleted file mode 100644
index 17155e212da54ca8afb2f27d33370ec84d1a3c77..0000000000000000000000000000000000000000
--- a/hemlock/dired.lisp
+++ /dev/null
@@ -1,697 +0,0 @@
-;;; -*- Log: hemlock.log; Package: dired -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/dired.lisp,v 1.1.1.5 1992/06/05 19:28:07 phg Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains site dependent code for dired.
-;;; Written by Bill Chiles.
-;;;
-
-(in-package "DIRED")
-
-(shadow '(rename-file delete-file))
-
-(export '(copy-file rename-file find-file delete-file make-directory
-	  *update-default* *clobber-default* *recursive-default*
-	  *report-function* *error-function* *yesp-function*
-	  pathnames-from-pattern))
-
-
-
-;;;; Exported parameters.
-
-(defparameter *update-default* nil
-  "Update arguments to utilities default to this value.")
-
-(defparameter *clobber-default* t
-  "Clobber arguments to utilities default to this value.")
-
-(defparameter *recursive-default* nil
-  "Recursive arguments to utilities default to this value.")
-
-
-
-;;;; WILDCARDP
-
-(defconstant wildcard-char #\*
-  "Wildcard designator for file names will match any substring.")
-
-(defmacro wildcardp (file-namestring)
-  `(position wildcard-char (the simple-string ,file-namestring) :test #'char=))
-
-
-
-;;;; User interaction functions, variable declarations, and their defaults.
-
-(defun default-error-function (string &rest args)
-  (apply #'error string args))
-;;;
-(defvar *error-function* #'default-error-function
-  "This function is called when an error is encountered in dired code.")
-
-(defun default-report-function (string &rest args)
-  (apply #'format t string args))
-;;;
-(defvar *report-function* #'default-report-function
-  "This function is called when the user needs to be informed of something.")
-
-(defun default-yesp-function (string &rest args)
-  (apply #'format t string args)
-  (let ((answer (nstring-downcase (string-trim '(#\space #\tab) (read-line)))))
-    (declare (simple-string answer))
-    (or (string= answer "")
-	(string= answer "y")
-	(string= answer "yes")
-	(string= answer "ye"))))
-;;;
-(defvar *yesp-function* #'default-yesp-function
-  "Function to query the user about clobbering an already existent file.")
-
-
-
-;;;; Copy-File
-
-;;; WILD-MATCH objects contain information about wildcard matches.  File is the
-;;; Sesame namestring of the file matched, and substitute is a substring of the
-;;; file-namestring of file.
-;;;
-(defstruct (wild-match (:print-function print-wild-match)
-		       (:constructor make-wild-match (file substitute)))
-  file
-  substitute)
-
-(defun print-wild-match (obj str n)
-  (declare (ignore n))
-  (format str "#<Wild-Match  ~S  ~S>"
-	  (wild-match-file obj) (wild-match-substitute obj)))
-
-
-(defun copy-file (spec1 spec2 &key (update *update-default*)
-				   (clobber *clobber-default*)
-				   (directory () directoryp))
-  "Copy file spec1 to spec2.  A single wildcard is acceptable, and directory
-   names may be used.  If spec1 and spec2 are both directories, then a
-   recursive copy is done of the files and subdirectory structure of spec1;
-   if spec2 is in the subdirectory structure of spec1, the recursion will
-   not descend into it.  Use spec1/* to copy only the files in spec1 to
-   directory spec2.  If spec2 is a directory, and spec1 is a file, then
-   spec1 is copied into spec2 with the same pathname-name.  Files are
-   copied maintaining the source's write date.  If :update is non-nil, then
-   files are only copied if the source is newer than the destination, still
-   maintaining the source's write date; the user is not warned if the
-   destination is newer (not the same write date) than the source.  If
-   :clobber and :update are nil, then if any file spec2 already exists, the
-   user will be asked whether it should be overwritten or not."
-  (cond
-   ((not directoryp)
-    (let* ((ses-name1 (ext:unix-namestring spec1 t))
-	   (exists1p (unix:unix-file-kind ses-name1))
-	   (ses-name2 (ext:unix-namestring spec2 nil))
-	   (pname1 (pathname ses-name1))
-	   (pname2 (pathname ses-name2))
-	   (dirp1 (directoryp pname1))
-	   (dirp2 (directoryp pname2))
-	   (wildp1 (wildcardp (file-namestring pname1)))
-	   (wildp2 (wildcardp (file-namestring pname2))))
-      (when (and dirp1 wildp1)
-	(funcall *error-function*
-		 "Cannot have wildcards in directory names -- ~S." pname1))
-      (when (and dirp2 wildp2)
-	(funcall *error-function*
-		 "Cannot have wildcards in directory names -- ~S." pname2))
-      (when (and dirp1 (not dirp2))
-	(funcall *error-function*
-		 "Cannot handle spec1 being a directory and spec2 a file."))
-      (when (and wildp2 (not wildp1))
-	(funcall *error-function*
-		 "Cannot handle destination having wildcards without ~
-		 source having wildcards."))
-      (when (and wildp1 (not wildp2) (not dirp2))
-	(funcall *error-function*
-		 "Cannot handle source with wildcards and destination ~
-		 without, unless destination is a directory."))
-      (cond ((and dirp1 dirp2)
-	     (unless (directory-existsp ses-name1)
-	       (funcall *error-function*
-			"Directory does not exist -- ~S." pname1))
-	     (unless (directory-existsp ses-name2)
-	       (enter-directory ses-name2))
-	     (recursive-copy pname1 pname2 update clobber pname2
-			     ses-name1 ses-name2))
-	    (dirp2
-	     ;; merge pname2 with pname1 to pick up a similar file-namestring.
-	     (copy-file-1 pname1 wildp1 exists1p
-			  (merge-pathnames pname2 pname1)
-			  wildp1 update clobber))
-	    (t (copy-file-1 pname1 wildp1 exists1p
-			    pname2 wildp2 update clobber)))))
-    (directory
-     (when (pathname-directory spec1)
-       (funcall *error-function*
-		"Spec1 is just a pattern when supplying directory -- ~S."
-		spec1))
-     (let* ((pname2 (pathname (ext:unix-namestring spec2 nil)))
-	    (dirp2 (directoryp pname2))
-	    (wildp1 (wildcardp spec1))
-	    (wildp2 (wildcardp (file-namestring pname2))))
-       (unless wildp1
-	 (funcall *error-function*
-		  "Pattern, ~S, does not contain a wildcard."
-		  spec1))
-       (when (and (not wildp2) (not dirp2))
-	 (funcall *error-function*
-		  "Cannot handle source with wildcards and destination ~
-		   without, unless destination is a directory."))
-       (copy-wildcard-files spec1 wildp1
-			    (if dirp2 (merge-pathnames pname2 spec1) pname2)
-			    (if dirp2 wildp1 wildp2)
-			    update clobber directory))))
-  (values))
-
-;;; RECURSIVE-COPY takes two pathnames that represent directories, and
-;;; the files in pname1 are copied into pname2, recursively descending into
-;;; subdirectories.  If a subdirectory of pname1 does not exist in pname2,
-;;; it is created.  Pname1 is known to exist.  Forbidden-dir is originally
-;;; the same as pname2; this keeps us from infinitely recursing if pname2
-;;; is in the subdirectory structure of pname1.  Returns t if some file gets
-;;; copied.
-;;; 
-(defun recursive-copy (pname1 pname2 update clobber
-		       forbidden-dir ses-name1 ses-name2)
-  (funcall *report-function* "~&~S  ==>~%  ~S~%" ses-name1 ses-name2)
-  (dolist (spec (directory (directory-namestring pname1)))
-    (let ((spec-ses-name (namestring spec)))
-      (if (directoryp spec)
-	  (unless (equal (pathname spec-ses-name) forbidden-dir)
-	    (let* ((dir2-pname (merge-dirs spec pname2))
-		   (dir2-ses-name (namestring dir2-pname)))
-	      (unless (directory-existsp dir2-ses-name)
-		(enter-directory dir2-ses-name))
-	      (recursive-copy spec dir2-pname update clobber forbidden-dir
-			      spec-ses-name dir2-ses-name)
-	      (funcall *report-function* "~&~S  ==>~%  ~S~%" ses-name1
-		       ses-name2)))
-	  (copy-file-2 spec-ses-name
-		       (namestring (merge-pathnames pname2 spec))
-		       update clobber)))))
-
-;;; MERGE-DIRS picks out the last directory name in the pathname pname1 and
-;;; adds it to the end of the sequence of directory names from pname2, returning
-;;; a pathname.
-;;;
-#|
-(defun merge-dirs (pname1 pname2)
-  (let* ((dirs1 (pathname-directory pname1))
-	 (dirs2 (pathname-directory pname2))
-	 (dirs2-len (length dirs2))
-	 (new-dirs2 (make-array (1+ dirs2-len))))
-    (declare (simple-vector dirs1 dirs2 new-dirs2))
-    (replace new-dirs2 dirs2)
-    (setf (svref new-dirs2 dirs2-len)
-	  (svref dirs1 (1- (length dirs1))))
-    (make-pathname :directory new-dirs2 :device :absolute)))
-|#
-
-(defun merge-dirs (pname1 pname2)
-  (let* ((dirs1 (pathname-directory pname1))
-	 (dirs2 (pathname-directory pname2))
-	 (dirs2-len (length dirs2))
-	 (new-dirs2 (make-list (1+ dirs2-len))))
-    (replace new-dirs2 dirs2)
-    (setf (nth dirs2-len new-dirs2)
-	  (nth (1- (length dirs1)) dirs1))
-    (make-pathname :directory new-dirs2 :device :unspecific)))
-
-;;; COPY-FILE-1 takes pathnames which either both contain a single wildcard
-;;; or none.  Wildp1 and Wildp2 are either nil or indexes into the
-;;; file-namestring of pname1 and pname2, respectively, indicating the position
-;;; of the wildcard character.  If there is no wildcard, then simply call
-;;; COPY-FILE-2; otherwise, resolve the wildcard and copy those matching files.
-;;;
-(defun copy-file-1 (pname1 wildp1 exists1p pname2 wildp2 update clobber)
-  (if wildp1 
-      (copy-wildcard-files pname1 wildp1 pname2 wildp2 update clobber)
-      (let ((ses-name1 (namestring pname1)))
-	(unless exists1p (funcall *error-function*
-				  "~S does not exist." ses-name1))
-	(copy-file-2 ses-name1 (namestring pname2) update clobber))))
-
-(defun copy-wildcard-files (pname1 wildp1 pname2 wildp2 update clobber
-				   &optional directory)
-  (multiple-value-bind (dst-before dst-after)
-		       (before-wildcard-after (file-namestring pname2) wildp2)
-    (dolist (match (resolve-wildcard pname1 wildp1 directory))
-      (copy-file-2 (wild-match-file match)
-		   (namestring (concatenate 'simple-string
-					    (directory-namestring pname2)
-					    dst-before
-					    (wild-match-substitute match)
-					    dst-after))
-		   update clobber))))
-
-;;; COPY-FILE-2 copies ses-name1 to ses-name2 depending on the values of update
-;;; and clobber, with respect to the documentation of COPY-FILE.  If ses-name2
-;;; doesn't exist, then just copy it; otherwise, if update, then only copy it
-;;; if the destination's write date precedes the source's, and if not clobber
-;;; and not update, then ask the user before doing the copy.
-;;;
-(defun copy-file-2 (ses-name1 ses-name2 update clobber)
-  (let ((secs1 (get-write-date ses-name1)))
-    (cond ((not (probe-file ses-name2))
-	   (do-the-copy ses-name1 ses-name2 secs1))
-	  (update
-	   (let ((secs2 (get-write-date ses-name2)))
-	     (cond (clobber
-		    (do-the-copy ses-name1 ses-name2 secs1))
-		   ((and (> secs2 secs1)
-			 (funcall *yesp-function*
-				  "~&~S  ==>  ~S~%  ~
-				  ** Destination is newer than source.  ~
-				  Overwrite it? "
-				  ses-name1 ses-name2))
-		    (do-the-copy ses-name1 ses-name2 secs1))
-		   ((< secs2 secs1)
-		    (do-the-copy ses-name1 ses-name2 secs1)))))
-	  ((not clobber)
-	   (when (funcall *yesp-function*
-			  "~&~S  ==>  ~S~%  ** Destination already exists.  ~
-			  Overwrite it? "
-			  ses-name1 ses-name2)
-	     (do-the-copy ses-name1 ses-name2 secs1)))
-	  (t (do-the-copy ses-name1 ses-name2 secs1)))))
-
-(defun do-the-copy (ses-name1 ses-name2 secs1)
-  (let* ((fd (open-file ses-name1)))
-    (unwind-protect
-	(multiple-value-bind (data byte-count mode)
-			     (read-file fd ses-name1)
-	  (unwind-protect (write-file ses-name2 data byte-count mode)
-	    (system:deallocate-system-memory data byte-count)))
-      (close-file fd)))
-  (set-write-date ses-name2 secs1)
-  (funcall *report-function* "~&~S  ==>~%  ~S~%" ses-name1 ses-name2))
-
-
-;;;; Rename-File
-
-(defun rename-file (spec1 spec2 &key (clobber *clobber-default*)
-			  (directory () directoryp))
-  "Rename file spec1 to spec2.  A single wildcard is acceptable, and spec2 may
-   be a directory with the result spec being the merging of spec2 with spec1.
-   If clobber is nil and spec2 exists, then the user will be asked to confirm
-   the renaming.  As with Unix mv, if you are renaming a directory, don't
-   specify the trailing slash."
-  (cond
-   ((not directoryp)
-    (let* ((ses-name1 (ext:unix-namestring spec1 t))
-	   (exists1p (unix:unix-file-kind ses-name1))
-	   (ses-name2 (ext:unix-namestring spec2 nil))
-	   (pname1 (pathname ses-name1))
-	   (pname2 (pathname ses-name2))
-	   (dirp2 (directoryp pname2))
-	   (wildp1 (wildcardp (file-namestring pname1)))
-	   (wildp2 (wildcardp (file-namestring pname2))))
-      (if (and dirp2 wildp2)
-	  (funcall *error-function*
-		   "Cannot have wildcards in directory names -- ~S." pname2))
-      (if (and wildp2 (not wildp1))
-	  (funcall *error-function*
-		   "Cannot handle destination having wildcards without ~
-		   source having wildcards."))
-      (if (and wildp1 (not wildp2) (not dirp2))
-	  (funcall *error-function*
-		   "Cannot handle source with wildcards and destination ~
-		   without, unless destination is a directory."))
-      (if dirp2
-	  (rename-file-1 pname1 wildp1 exists1p (merge-pathnames pname2
-								 pname1)
-			 wildp1 clobber)
-	  (rename-file-1 pname1 wildp1 exists1p pname2 wildp2 clobber))))
-    (directory
-     (when (pathname-directory spec1)
-       (funcall *error-function*
-		"Spec1 is just a pattern when supplying directory -- ~S."
-		spec1))
-
-     (let* ((pname2 (pathname (ext:unix-namestring spec2 nil)))
-	    (dirp2 (directoryp pname2))
-	    (wildp1 (wildcardp spec1))
-	    (wildp2 (wildcardp (file-namestring pname2))))
-       (unless wildp1
-	 (funcall *error-function*
-		  "Pattern, ~S, does not contain a wildcard."
-		  spec1))
-       (when (and (not wildp2) (not dirp2))
-	 (funcall *error-function*
-		  "Cannot handle source with wildcards and destination ~
-		   without, unless destination is a directory."))
-       (rename-wildcard-files spec1 wildp1
-			      (if dirp2 (merge-pathnames pname2 spec1) pname2)
-			      (if dirp2 wildp1 wildp2)
-			      clobber directory))))
-  (values))
-
-;;; RENAME-FILE-1 takes pathnames which either both contain a single wildcard
-;;; or none.  Wildp1 and Wildp2 are either nil or indexes into the
-;;; file-namestring of pname1 and pname2, respectively, indicating the position
-;;; of the wildcard character.  If there is no wildcard, then simply call
-;;; RENAME-FILE-2; otherwise, resolve the wildcard and rename those matching files.
-;;;
-(defun rename-file-1 (pname1 wildp1 exists1p pname2 wildp2 clobber)
-  (if wildp1
-      (rename-wildcard-files pname1 wildp1 pname2 wildp2 clobber)
-      (let ((ses-name1 (namestring pname1)))
-	(unless exists1p (funcall *error-function*
-				  "~S does not exist." ses-name1))
-	(rename-file-2 ses-name1 (namestring pname2) clobber))))
-
-(defun rename-wildcard-files (pname1 wildp1 pname2 wildp2 clobber
-				   &optional directory)
-  (multiple-value-bind (dst-before dst-after)
-		       (before-wildcard-after (file-namestring pname2) wildp2)
-    (dolist (match (resolve-wildcard pname1 wildp1 directory))
-      (rename-file-2 (wild-match-file match)
-		     (namestring (concatenate 'simple-string
-					      (directory-namestring pname2)
-					      dst-before
-					      (wild-match-substitute match)
-					      dst-after))
-		     clobber))))
-
-(defun rename-file-2 (ses-name1 ses-name2 clobber)
-  (cond ((and (probe-file ses-name2) (not clobber))
-	 (when (funcall *yesp-function*
-			"~&~S  ==>  ~S~%  ** Destination already exists.  ~
-			Overwrite it? "
-			ses-name1 ses-name2)
-	   (sub-rename-file ses-name1 ses-name2)
-	   (funcall *report-function* "~&~S  ==>~%  ~S~%" ses-name1 ses-name2)))
-	(t (sub-rename-file ses-name1 ses-name2)
-	   (funcall *report-function* "~&~S  ==>~%  ~S~%" ses-name1 ses-name2))))
-
-
-
-;;;; Find-File
-
-(defun find-file (file-name &optional (directory "")
-			    (find-all-p nil find-all-suppliedp))
-  "Find the file with file-namestring file recursively looking in directory.
-   If find-all-p is non-nil, then do not stop searching upon finding the first
-   occurance of file.  File may contain a single wildcard, which causes
-   find-all-p to default to t instead of nil."
-  (let* ((file (coerce file-name 'simple-string))
-	 (wildp (wildcardp file))
-	 (find-all-p (if find-all-suppliedp find-all-p wildp)))
-    (declare (simple-string file))
-    (catch 'found-file
-      (if wildp
-	  (multiple-value-bind (before after)
-			       (before-wildcard-after file wildp)
-	    (find-file-aux file directory find-all-p before after))
-	  (find-file-aux file directory find-all-p))))
-  (values))
-
-(defun find-file-aux (the-file directory find-all-p &optional before after)
-  (declare (simple-string the-file))
-  (dolist (spec (directory directory))
-    (let* ((spec-ses-name (namestring spec))
-	   (spec-file-name (file-namestring spec-ses-name)))
-      (declare (simple-string spec-ses-name spec-file-name))
-      (if (directoryp spec)
-	  (find-file-aux the-file spec find-all-p before after)
-	  (when (if before
-		    (find-match before after spec-file-name :no-cons)
-		    (string-equal the-file spec-file-name))
-	    (print spec-ses-name)
-	    (unless find-all-p (throw 'found-file t)))))))
-
-
-
-;;;; Delete-File
-
-;;; DELETE-FILE
-;;;    If spec is a directory, but recursive is nil, just pass the directory
-;;; down through, letting LISP:DELETE-FILE signal an error if the directory
-;;; is not empty.
-;;; 
-(defun delete-file (spec &key (recursive *recursive-default*)
-			      (clobber *clobber-default*))
-  "Delete spec asking confirmation on each file if clobber is nil.  A single
-   wildcard is acceptable.  If recursive is non-nil, then a directory spec may
-   be given to recursively delete the entirety of the directory and its
-   subdirectory structure.  An empty directory may be specified without
-   recursive being non-nil.  When specifying a directory, the trailing slash
-   must be included."
-  (let* ((ses-name (ext:unix-namestring spec t))
-	 (pname (pathname ses-name)) 
-	 (wildp (wildcardp (file-namestring pname)))
-	 (dirp (directoryp pname)))
-    (if dirp
-	(if recursive
-	    (recursive-delete pname ses-name clobber)
-	    (delete-file-2 ses-name clobber))
-	(delete-file-1 pname ses-name wildp clobber)))
-  (values))
-
-(defun recursive-delete (directory dir-ses-name clobber)
-  (dolist (spec (directory (directory-namestring directory)))
-    (let ((spec-ses-name (namestring spec)))
-      (if (directoryp spec)
-	  (recursive-delete (pathname spec-ses-name) spec-ses-name clobber)
-	  (delete-file-2 spec-ses-name clobber))))
-  (delete-file-2 dir-ses-name clobber))
-
-(defun delete-file-1 (pname ses-name wildp clobber)
-  (if wildp
-      (dolist (match (resolve-wildcard pname wildp))
-	(delete-file-2 (wild-match-file match) clobber))
-      (delete-file-2 ses-name clobber)))
-
-(defun delete-file-2 (ses-name clobber)
-  (when (or clobber (funcall *yesp-function* "~&Delete ~S? " ses-name))
-    (if (directoryp ses-name)
-	(delete-directory ses-name)
-	(lisp:delete-file ses-name))
-    (funcall *report-function* "~&~A~%" ses-name)))
-
-
-
-;;;; Wildcard resolution
-
-(defun pathnames-from-pattern (pattern files)
-  "Return a list of pathnames from files whose file-namestrings match
-   pattern.  Pattern must be a non-empty string and contains only one
-   asterisk.  Files contains no directories."
-  (declare (simple-string pattern))
-  (when (string= pattern "")
-    (funcall *error-function* "Must be a non-empty pattern."))
-  (unless (= (count wildcard-char pattern :test #'char=) 1)
-    (funcall *error-function* "Pattern must contain one asterisk."))
-  (multiple-value-bind (before after)
-		       (before-wildcard-after pattern (wildcardp pattern))
-    (let ((result nil))
-      (dolist (f files result)
-	(let* ((ses-namestring (namestring f))
-	       (f-namestring (file-namestring ses-namestring))
-	       (match (find-match before after f-namestring)))
-	  (when match (push f result)))))))
-
-
-;;; RESOLVE-WILDCARD takes a pathname with a wildcard and the position of the
-;;; wildcard character in the file-namestring and returns a list of wild-match
-;;; objects.  When directory is supplied, pname is just a pattern, or a
-;;; file-namestring.  It is an error for directory to be anything other than
-;;; absolute pathnames in the same directory.  Each wild-match object contains
-;;; the Sesame namestring of a file in the same directory as pname, or
-;;; directory, and a simple-string representing what the wildcard matched.
-;;;
-(defun resolve-wildcard (pname wild-pos &optional directory)
-  (multiple-value-bind (before after)
-		       (before-wildcard-after (if directory
-						  pname
-						  (file-namestring pname))
-					      wild-pos)
-    (let (result)
-      (dolist (f (or directory (directory (directory-namestring pname)))
-		 (nreverse result))
-	(unless (directoryp f)
-	  (let* ((ses-namestring (namestring f))
-		 (f-namestring (file-namestring ses-namestring))
-		 (match (find-match before after f-namestring)))
-	    (if match
-		(push (make-wild-match ses-namestring match) result))))))))
-
-;;; FIND-MATCH takes a "before wildcard" and "after wildcard" string and a
-;;; file-namestring.  If before and after match a substring of file-namestring
-;;; and are respectively left bound and right bound, then anything left in
-;;; between is the match returned.  If no match is found, nil is returned.
-;;; NOTE: if version numbers ever really exist, then this code will have to be
-;;; changed since the file-namestring of a pathname contains the version number.
-;;; 
-(defun find-match (before after file-namestring &optional no-cons)
-  (declare (simple-string before after file-namestring))
-  (let ((before-len (length before))
-	(after-len (length after))
-	(name-len (length file-namestring)))
-    (if (>= name-len (+ before-len after-len))
-	(let* ((start (if (string= before file-namestring
-				   :end1 before-len :end2 before-len)
-			  before-len))
-	       (end (- name-len after-len))
-	       (matchp (and start
-			    (string= after file-namestring :end1 after-len
-				     :start2 end :end2 name-len))))
-	  (if matchp
-	      (if no-cons
-		  t
-		  (subseq file-namestring start end)))))))
-
-(defun before-wildcard-after (file-namestring wild-pos)
-  (declare (simple-string file-namestring))
-  (values (subseq file-namestring 0 wild-pos)
-	  (subseq file-namestring (1+ wild-pos) (length file-namestring))))
-
-
-
-;;;; Miscellaneous Utilities (e.g., MAKEDIR).
-
-(defun make-directory (name)
-  "Creates directory name.  If name exists, then an error is signaled."
-  (let ((ses-name (ext:unix-namestring name nil)))
-    (when (unix:unix-file-kind ses-name)
-      (funcall *error-function* "Name already exists -- ~S" ses-name))
-    (enter-directory ses-name))
-  t)
-
-
-
-;;;; Mach Operations
-
-(defun open-file (ses-name)
-  (multiple-value-bind (fd err)
-		       (unix:unix-open ses-name unix:o_rdonly 0)
-    (unless fd
-      (funcall *error-function* "Opening ~S failed: ~A." ses-name err))
-    fd))
-
-(defun close-file (fd)
-  (unix:unix-close fd))
-
-(defun read-file (fd ses-name)
-  (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size)
-		       (unix:unix-fstat fd)
-    (declare (ignore ino nlink uid gid rdev))
-    (unless winp (funcall *error-function*
-			  "Opening ~S failed: ~A."  ses-name dev-or-err))
-    (let ((storage (system:allocate-system-memory size)))
-      (multiple-value-bind (read-bytes err)
-			   (unix:unix-read fd storage size)
-	(when (or (null read-bytes) (not (= size read-bytes)))
-	  (system:deallocate-system-memory storage size)
-	  (funcall *error-function*
-		   "Reading file ~S failed: ~A." ses-name err)))
-      (values storage size mode))))
-
-(defun write-file (ses-name data byte-count mode)
-  (multiple-value-bind (fd err) (unix:unix-creat ses-name #o644)
-    (unless fd
-      (funcall *error-function* "Couldn't create file ~S: ~A"
-	       ses-name (unix:get-unix-error-msg err)))
-    (multiple-value-bind (winp err) (unix:unix-write fd data 0 byte-count)
-      (unless winp
-	(funcall *error-function* "Writing file ~S failed: ~A"
-	       ses-name
-	       (unix:get-unix-error-msg err))))
-    (unix:unix-fchmod fd (logand mode #o777))
-    (unix:unix-close fd)))
-
-(defvar *utimes-buffer* (make-list 4 :initial-element 0))
-
-(defun set-write-date (ses-name secs)
-  (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size atime)
-		       (unix:unix-stat ses-name)
-    (declare (ignore ino mode nlink uid gid rdev size))
-    (unless winp (funcall *error-function*
-			  "Couldn't stat file ~S failed: ~A."  ses-name
-			  dev-or-err))
-    (setf (car *utimes-buffer*) atime)
-    (setf (caddr *utimes-buffer*) secs))
-  (multiple-value-bind (winp err)
-		       `(unix:unix-utimes ses-name ,@*utimes-buffer*)
-    (unless winp
-      (funcall *error-function* "Couldn't set write date of file ~S: ~A"
-	       ses-name
-	       (unix:get-unix-error-msg err)))))
-
-(defun get-write-date (ses-name)
-  (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size
-			atime mtime)
- 		       (unix:unix-stat ses-name)
-    (declare (ignore ino mode nlink uid gid rdev size atime))
-    (unless winp (funcall *error-function* "Couldn't stat file ~S failed: ~A."
-			  ses-name dev-or-err))
-    mtime))
-
-;;; SUB-RENAME-FILE must exist because we can't use Common Lisp's RENAME-FILE.
-;;; This is because it merges the new name with the old name to pick up
-;;; defaults, and this conflicts with Unix-oid names.  For example, renaming
-;;; "foo.bar" to ".baz" causes a result of "foo.baz"!  This routine doesn't
-;;; have this problem.
-;;;
-(defun sub-rename-file (ses-name1 ses-name2)
-  (multiple-value-bind (res err) (unix:unix-rename ses-name1 ses-name2)
-    (unless res
-      (funcall *error-function* "Failed to rename ~A to ~A: ~A."
-	       ses-name1 ses-name2 (unix:get-unix-error-msg err)))))
-
-(defun directory-existsp (ses-name)
-  (eq (unix:unix-file-kind ses-name) :directory))
-
-(defun enter-directory (ses-name)
-  (declare (simple-string ses-name))
-  (let* ((length-1 (1- (length ses-name)))
-	 (name (if (= (position #\/ ses-name :test #'char= :from-end t)
-		      length-1)
-		   (subseq ses-name 0 (1- (length ses-name)))
-		   ses-name)))
-    (multiple-value-bind (winp err) (unix:unix-mkdir name #o755)
-      (unless winp
-	(funcall *error-function* "Couldn't make directory ~S: ~A"
-		 name
-		 (unix:get-unix-error-msg err))))))
-
-(defun delete-directory (ses-name)
-  (declare (simple-string ses-name))
-  (multiple-value-bind (winp err)
-		       (unix:unix-rmdir (subseq ses-name 0
-						(1- (length ses-name))))
-    (unless winp
-      (funcall *error-function* "Couldn't delete directory ~S: ~A"
-	       ses-name
-	       (unix:get-unix-error-msg err)))))
-
-
-
-;;;; Misc. Utility Utilities
-
-;;; NSEPARATE-FILES destructively returns a list of file specs from listing.
-(defun nseparate-files (listing)
-  (do (files hold)
-      ((null listing) files)
-    (setf hold (cdr listing))
-    (unless (directoryp (car listing))
-      (setf (cdr listing) files)
-      (setf files listing))
-    (setf listing hold)))
-
-
-(defun directoryp (p)
-  (not (or (pathname-name p) (pathname-type p))))
diff --git a/hemlock/diredcoms.lisp b/hemlock/diredcoms.lisp
deleted file mode 100644
index 6c427ed6b635e95c1e42a3eb960acc090be3ebfd..0000000000000000000000000000000000000000
--- a/hemlock/diredcoms.lisp
+++ /dev/null
@@ -1,896 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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).
-;;; **********************************************************************
-;;;
-;;; Simple directory editing support.
-;;; This file contains site dependent calls.
-;;;
-;;; Written by Blaine Burks and Bill Chiles.
-;;;
-
-(in-package "HEMLOCK")
-
-
-(defmode "Dired" :major-p t
-  :documentation
-  "Dired permits convenient directory browsing and file operations including
-   viewing, deleting, copying, renaming, and wildcard specifications.")
-
-
-(defstruct (dired-information (:print-function print-dired-information)
-			      (:conc-name dired-info-))
-  pathname		; Pathname of directory.
-  pattern		; FILE-NAMESTRING with wildcard possibly.
-  dot-files-p		; Whether to include UNIX dot files. 
-  write-date		; Write date of directory.
-  files			; Simple-vector of dired-file structures.
-  file-list)		; List of pathnames for files, excluding directories.
-
-(defun print-dired-information (obj str n)
-  (declare (ignore n))
-  (format str "#<Dired Info ~S>" (namestring (dired-info-pathname obj))))
-
-
-(defstruct (dired-file (:print-function print-dired-file)
-		       (:constructor make-dired-file (pathname)))
-  pathname
-  (deleted-p nil)
-  (write-date nil))
-
-(defun print-dired-file (obj str n)
-  (declare (ignore n))
-  (format str "#<Dired-file ~A>" (namestring (dired-file-pathname obj))))
-
-
-
-;;;; "Dired" command.
-     
-;;; *pathnames-to-dired-buffers* is an a-list mapping directory namestrings to
-;;; buffers that display their contents.
-;;;
-(defvar *pathnames-to-dired-buffers* ())
-
-(make-modeline-field
- :name :dired-cmds :width 20
- :function
- #'(lambda (buffer window)
-     (declare (ignore buffer window))
-     "  Type ? for help.  "))
-
-(defcommand "Dired" (p &optional directory)
-  "Prompts for a directory and edits it.  If a dired for that directory already
-   exists, go to that buffer, otherwise create one.  With an argument, include
-   UNIX dot files."
-  "Prompts for a directory and edits it.  If a dired for that directory already
-   exists, go to that buffer, otherwise create one.  With an argument, include
-   UNIX dot files."
-  (let ((info (if (hemlock-bound-p 'dired-information)
-		  (value dired-information))))
-    (dired-guts nil
-		;; Propagate dot-files property to subdirectory edits.
-		(or (and info (dired-info-dot-files-p info))
-		    p)
-		directory)))
-
-(defcommand "Dired with Pattern" (p)
-  "Do a dired, prompting for a pattern which may include a single *.  With an
-   argument, include UNIX dit files."
-  "Do a dired, prompting for a pattern which may include a single *.  With an
-   argument, include UNIX dit files."
-  (dired-guts t p nil))
-
-(defun dired-guts (patternp dot-files-p directory)
-  (let* ((dpn (value pathname-defaults))
-	 (directory (dired-directorify
-		     (or directory
-			 (prompt-for-file
-			  :prompt "Edit Directory: "
-			  :help "Pathname to edit."
-			  :default (make-pathname
-				    :device (pathname-device dpn)
-				    :directory (pathname-directory dpn))
-			  :must-exist nil))))
-	 (pattern (if patternp
-		      (prompt-for-string
-		       :prompt "Filename pattern: "
-		       :help "Type a filename with a single asterisk."
-		       :trim t)))
-	 (full-name (namestring (if pattern
-				    (merge-pathnames directory pattern)
-				    directory)))
-	 (name (concatenate 'simple-string "Dired " full-name))
-	 (buffer (cdr (assoc full-name *pathnames-to-dired-buffers*
-			     :test #'string=))))
-    (declare (simple-string full-name))
-    (setf (value pathname-defaults) (merge-pathnames directory dpn))
-    (change-to-buffer
-     (cond (buffer
-	    (when (and dot-files-p
-		       (not (dired-info-dot-files-p
-			     (variable-value 'dired-information
-					     :buffer buffer))))
-	      (setf (dired-info-dot-files-p (variable-value 'dired-information
-							    :buffer buffer))
-		    t)
-	      (update-dired-buffer directory pattern buffer))
-	    buffer)
-	   (t
-	    (let ((buffer (make-buffer
-			   name :modes '("Dired")
-			   :modeline-fields
-			   (append (value default-modeline-fields)
-				   (list (modeline-field :dired-cmds)))
-			   :delete-hook (list 'dired-buffer-delete-hook))))
-	      (unless (initialize-dired-buffer directory pattern
-					       dot-files-p buffer)
-		(delete-buffer-if-possible buffer)
-		(editor-error "No entries for ~A." full-name))
-	      (push (cons full-name buffer) *pathnames-to-dired-buffers*)
-	      buffer))))))
-
-;;; INITIALIZE-DIRED-BUFFER gets a dired in the buffer and defines some
-;;; variables to make it usable as a dired buffer.  If there are no file
-;;; satisfying directory, then this returns nil, otherwise t.
-;;;
-(defun initialize-dired-buffer (directory pattern dot-files-p buffer)
-  (multiple-value-bind (pathnames dired-files)
-		       (dired-in-buffer directory pattern dot-files-p buffer)
-    (if (zerop (length dired-files))
-	nil
-	(defhvar "Dired Information"
-	  "Contains the information neccessary to manipulate dired buffers."
-	  :buffer buffer
-	  :value (make-dired-information :pathname directory
-					 :pattern pattern
-					 :dot-files-p dot-files-p
-					 :write-date (file-write-date directory)
-					 :files dired-files
-					 :file-list pathnames)))))
-
-;;; CALL-PRINT-DIRECTORY gives us a nice way to report PRINT-DIRECTORY errors
-;;; to the user and to clean up the dired buffer.
-;;;
-(defun call-print-directory (directory mark dot-files-p)
-  (handler-case (with-output-to-mark (s mark :full)
-		  (print-directory directory s
-				   :all dot-files-p :verbose t :return-list t))
-    (error (condx)
-      (delete-buffer-if-possible (line-buffer (mark-line mark)))
-      (editor-error "~A" condx))))
-
-;;; DIRED-BUFFER-DELETE-HOOK is called on dired buffers upon deletion.  This
-;;; removes the buffer from the pathnames mapping, and it deletes and buffer
-;;; local variables referring to it.
-;;;
-(defun dired-buffer-delete-hook (buffer)
-  (setf *pathnames-to-dired-buffers*
-	(delete buffer *pathnames-to-dired-buffers* :test #'eq :key #'cdr)))
-
-
-
-;;;; Dired deletion and undeletion.
-
-(defcommand "Dired Delete File" (p)
-  "Marks a file for deletion; signals an error if not in a dired buffer.
-   With an argument, this prompts for a pattern that may contain at most one
-   wildcard, an asterisk, and all names matching the pattern will be flagged
-   for deletion."
-  "Marks a file for deletion; signals an error if not in a dired buffer."
-  (dired-frob-deletion p t))
-
-(defcommand "Dired Undelete File" (p)
-  "Removes a mark for deletion; signals and error if not in a dired buffer.
-   With an argument, this prompts for a pattern that may contain at most one
-   wildcard, an asterisk, and all names matching the pattern will be unflagged
-   for deletion."
-  "Removes a mark for deletion; signals and error if not in a dired buffer."
-  (dired-frob-deletion p nil))
-
-(defcommand "Dired Delete File and Down Line" (p)
-  "Marks file for deletion and moves down a line.
-   See \"Dired Delete File\"."
-  "Marks file for deletion and moves down a line.
-   See \"Dired Delete File\"."
-  (declare (ignore p))
-  (dired-frob-deletion nil t)
-  (dired-down-line (current-point)))
-
-(defcommand "Dired Undelete File and Down Line" (p)
-  "Marks file undeleted and moves down a line.
-   See \"Dired Delete File\"."
-  "Marks file undeleted and moves down a line.
-   See \"Dired Delete File\"."
-  (declare (ignore p))
-  (dired-frob-deletion nil nil)
-  (dired-down-line (current-point)))
-
-(defcommand "Dired Delete File with Pattern" (p)
-  "Prompts for a pattern and marks matching files for deletion.
-   See \"Dired Delete File\"."
-  "Prompts for a pattern and marks matching files for deletion.
-   See \"Dired Delete File\"."
-  (declare (ignore p))
-  (dired-frob-deletion t t)
-  (dired-down-line (current-point)))
-
-(defcommand "Dired Undelete File with Pattern" (p)
-  "Prompts for a pattern and marks matching files undeleted.
-   See \"Dired Delete File\"."
-  "Prompts for a pattern and marks matching files undeleted.
-   See \"Dired Delete File\"."
-  (declare (ignore p))
-  (dired-frob-deletion t nil)
-  (dired-down-line (current-point)))
-
-;;; DIRED-FROB-DELETION takes arguments indicating whether to prompt for a
-;;; pattern and whether to mark the file deleted or undeleted.  This uses
-;;; CURRENT-POINT and CURRENT-BUFFER, and if not in a dired buffer, signal
-;;; an error.
-;;; 
-(defun dired-frob-deletion (patternp deletep)
-  (unless (hemlock-bound-p 'dired-information)
-    (editor-error "Not in Dired buffer."))
-  (with-mark ((mark (current-point) :left-inserting))
-    (let* ((dir-info (value dired-information))
-	   (files (dired-info-files dir-info))
-	   (del-files
-	    (if patternp
-		(dired:pathnames-from-pattern
-		 (prompt-for-string
-		  :prompt "Filename pattern: "
-		  :help "Type a filename with a single asterisk."
-		  :trim t)
-		 (dired-info-file-list dir-info))
-		(list (dired-file-pathname
-		       (array-element-from-mark mark files)))))
-	   (note-char (if deletep #\D #\space)))
-      (with-writable-buffer ((current-buffer))
-	(dolist (f del-files)
-	  (let* ((pos (position f files :test #'equal
-				:key #'dired-file-pathname))
-		 (dired-file (svref files pos)))
-	    (buffer-start mark)
-	    (line-offset mark pos 0)
-	    (setf (dired-file-deleted-p dired-file) deletep)
-	    (if deletep
-		(setf (dired-file-write-date dired-file)
-		      (file-write-date (dired-file-pathname dired-file)))
-		(setf (dired-file-write-date dired-file) nil))
-	    (setf (next-character mark) note-char)))))))
-
-(defun dired-down-line (point)
-  (line-offset point 1)
-  (when (blank-line-p (mark-line point))
-    (line-offset point -1)))
-
-
-
-;;;; Dired file finding and going to dired buffers.
-
-(defcommand "Dired Edit File" (p)
-  "Read in file or recursively \"Dired\" a directory."
-  "Read in file or recursively \"Dired\" a directory."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (when (blank-line-p (mark-line point)) (editor-error "Not on a file line."))
-    (let ((pathname (dired-file-pathname
-		     (array-element-from-mark
-		      point (dired-info-files (value dired-information))))))
-      (if (directoryp pathname)
-	  (dired-command nil (directory-namestring pathname))
-	  (change-to-buffer (find-file-buffer pathname))))))
-
-(defcommand "Dired View File" (p)
-  "Read in file as if by \"View File\" or recursively \"Dired\" a directory.
-   This associates the file's buffer with the dired buffer."
-  "Read in file as if by \"View File\".
-   This associates the file's buffer with the dired buffer."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (when (blank-line-p (mark-line point)) (editor-error "Not on a file line."))
-    (let ((pathname (dired-file-pathname
-		     (array-element-from-mark
-		      point (dired-info-files (value dired-information))))))
-      (if (directoryp pathname)
-	  (dired-command nil (directory-namestring pathname))
-	  (let* ((dired-buf (current-buffer))
-		 (buffer (view-file-command nil pathname)))
-	    (push #'(lambda (buffer)
-		      (declare (ignore buffer))
-		      (setf dired-buf nil))
-		  (buffer-delete-hook dired-buf))
-	    (setf (variable-value 'view-return-function :buffer buffer)
-		  #'(lambda ()
-		      (if dired-buf
-			  (change-to-buffer dired-buf)
-			  (dired-from-buffer-pathname-command nil)))))))))
-
-(defcommand "Dired from Buffer Pathname" (p)
-  "Invokes \"Dired\" on the directory part of the current buffer's pathname.
-   With an argument, also prompt for a file pattern within that directory."
-  "Invokes \"Dired\" on the directory part of the current buffer's pathname.
-   With an argument, also prompt for a file pattern within that directory."
-  (let ((pathname (buffer-pathname (current-buffer))))
-    (if pathname
-	(dired-command p (directory-namestring pathname))
-	(editor-error "No pathname associated with buffer."))))
-
-(defcommand "Dired Up Directory" (p)
-  "Invokes \"Dired\" on the directory up one level from the current Dired
-   buffer."
-  "Invokes \"Dired\" on the directory up one level from the current Dired
-   buffer."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'dired-information)
-    (editor-error "Not in Dired buffer."))
-  (let ((dirs (pathname-directory
-	       (dired-info-pathname (value dired-information)))))
-    (declare (simple-vector dirs))
-    (dired-command nil
-		   (make-pathname
-		    :device :absolute
-		    :directory (subseq dirs 0 (1- (length dirs)))))))
-
-
-
-;;;; Dired misc. commands -- update, help, line motion.
-
-(defcommand "Dired Update Buffer" (p)
-  "Recompute the contents of a dired buffer.
-   This maintains delete flags for files that have not been modified."
-  "Recompute the contents of a dired buffer.
-   This maintains delete flags for files that have not been modified."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'dired-information)
-    (editor-error "Not in Dired buffer."))
-  (let ((buffer (current-buffer))
-	(dir-info (value dired-information)))
-    (update-dired-buffer (dired-info-pathname dir-info)
-			 (dired-info-pattern dir-info)
-			 buffer)))
-
-;;; UPDATE-DIRED-BUFFER updates buffer with a dired of directory, deleting
-;;; whatever is in the buffer already.  This assumes buffer was previously
-;;; used as a dired buffer having necessary variables bound.  The new files
-;;; are compared to the old ones propagating any deleted flags if the name
-;;; and the write date is the same for both specifications.
-;;;
-(defun update-dired-buffer (directory pattern buffer)
-  (with-writable-buffer (buffer)
-    (delete-region (buffer-region buffer))
-    (let ((dir-info (variable-value 'dired-information :buffer buffer)))
-      (multiple-value-bind (pathnames new-dired-files)
-			   (dired-in-buffer directory pattern
-					    (dired-info-dot-files-p dir-info)
-					    buffer)
-	(let ((point (buffer-point buffer))
-	      (old-dired-files (dired-info-files dir-info)))
-	  (declare (simple-vector old-dired-files))
-	  (dotimes (i (length old-dired-files))
-	    (let ((old-file (svref old-dired-files i)))
-	      (when (dired-file-deleted-p old-file)
-		(let ((pos (position (dired-file-pathname old-file)
-				     new-dired-files :test #'equal
-				     :key #'dired-file-pathname)))
-		  (when pos
-		    (let* ((new-file (svref new-dired-files pos))
-			   (write-date (file-write-date
-					(dired-file-pathname new-file))))
-		      (when (= (dired-file-write-date old-file) write-date)
-			(setf (dired-file-deleted-p new-file) t)
-			(setf (dired-file-write-date new-file) write-date)
-			(setf (next-character
-			       (line-offset (buffer-start point) pos 0))
-			      #\D))))))))
-	  (setf (dired-info-files dir-info) new-dired-files)
-	  (setf (dired-info-file-list dir-info) pathnames)
-	  (setf (dired-info-write-date dir-info)
-		(file-write-date directory))
-	  (move-mark point (buffer-start-mark buffer)))))))
-
-;;; DIRED-IN-BUFFER inserts a dired listing of directory in buffer returning
-;;; two values: a list of pathnames of files only, and an array of dired-file
-;;; structures.  This uses FILTER-REGION to insert a space for the indication
-;;; of whether the file is flagged for deletion.  Then we clean up extra header
-;;; and trailing lines known to be in the output (into every code a little
-;;; slime must fall).
-;;;
-(defun dired-in-buffer (directory pattern dot-files-p buffer)
-  (let ((point (buffer-point buffer)))
-    (with-writable-buffer (buffer)
-      (let* ((pathnames (call-print-directory
-			 (if pattern
-			     (merge-pathnames directory pattern)
-			     directory)
-			 point
-			 dot-files-p))
-	     (dired-files (make-array (length pathnames))))
-	(declare (list pathnames) (simple-vector dired-files))
-	(filter-region #'(lambda (str)
-			   (concatenate 'simple-string "  " str))
-		       (buffer-region buffer))
-	(delete-characters point -2)
-	(delete-region (line-to-region (mark-line (buffer-start point))))
-	(delete-characters point)
-	(do ((p pathnames (cdr p))
-	     (i 0 (1+ i)))
-	    ((null p))
-	  (setf (svref dired-files i) (make-dired-file (car p))))
-	(values (delete-if #'directoryp pathnames) dired-files)))))
-
-
-(defcommand "Dired Help" (p)
-  "How to use dired."
-  "How to use dired."
-  (declare (ignore p))
-  (describe-mode-command nil "Dired"))
-
-(defcommand "Dired Next File" (p)
-  "Moves to next undeleted file."
-  "Moves to next undeleted file."
-  (declare (ignore p))
-  (unless (dired-line-offset (current-point) (or p 1))
-    (editor-error "Not enough lines.")))
-
-(defcommand "Dired Previous File" (p)
-  "Moves to previous undeleted file."
-  "Moves to next undeleted file."
-  (declare (ignore p))
-  (unless (dired-line-offset (current-point) (or p -1))
-    (editor-error "Not enough lines.")))
-
-;;; DIRED-LINE-OFFSET moves mark n undeleted file lines, returning mark.  If
-;;; there are not enough lines, mark remains unmoved, this returns nil.
-;;;
-(defun dired-line-offset (mark n)
-  (with-mark ((m mark))
-    (let ((step (if (plusp n) 1 -1)))
-      (dotimes (i (abs n) (move-mark mark m))
-	(loop
-	  (unless (line-offset m step 0)
-	    (return-from dired-line-offset nil))
-	  (when (blank-line-p (mark-line m))
-	    (return-from dired-line-offset nil))
-	  (when (char= (next-character m) #\space)
-	    (return)))))))
-
-
-
-;;;; Dired user interaction functions.
-
-(defun dired-error-function (string &rest args)
-  (apply #'editor-error string args))
-
-(defun dired-report-function (string &rest args)
-  (clear-echo-area)
-  (apply #'message string args))
-
-(defun dired-yesp-function (string &rest args)
-  (prompt-for-y-or-n :prompt (cons string args) :default t))
-
-
-
-;;;; Dired expunging and quitting.
-
-(defcommand "Dired Expunge Files" (p)
-  "Expunges files marked for deletion.
-   Query the user if value of \"Dired File Expunge Confirm\" is non-nil.  Do
-   the same with directories and the value of \"Dired Directory Expunge
-   Confirm\"."
-  "Expunges files marked for deletion.
-   Query the user if value of \"Dired File Expunge Confirm\" is non-nil.  Do
-   the same with directories and the value of \"Dired Directory Expunge
-   Confirm\"."
-  (declare (ignore p)) 
-  (when (expunge-dired-files)
-    (dired-update-buffer-command nil))
-  (maintain-dired-consistency))
-
-(defcommand "Dired Quit" (p)
-  "Expunges the files in a dired buffer and then exits."
-  "Expunges the files in a dired buffer and then exits."
-  (declare (ignore p))
-  (expunge-dired-files)
-  (delete-buffer-if-possible (current-buffer)))
-
-(defhvar "Dired File Expunge Confirm"
-  "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask
-   for confirmation before deleting the marked files."
-  :value t)
-
-(defhvar "Dired Directory Expunge Confirm"
-  "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask
-   for confirmation before deleting each marked directory."
-  :value t)
-
-(defun expunge-dired-files ()
-  (multiple-value-bind (marked-files marked-dirs) (get-marked-dired-files)
-    (let ((dired:*error-function* #'dired-error-function)
-	  (dired:*report-function* #'dired-report-function)
-	  (dired:*yesp-function* #'dired-yesp-function)
-	  (we-did-something nil))
-      (when (and marked-files
-		 (or (not (value dired-file-expunge-confirm))
-		     (prompt-for-y-or-n :prompt "Really delete files? "
-					:default t
-					:must-exist t
-					:default-string "Y")))
-	(setf we-did-something t)
-	(dolist (file-info marked-files)
-	  (let ((pathname (car file-info))
-		(write-date (cdr file-info)))
-	    (if (= write-date (file-write-date pathname))
-		(dired:delete-file (namestring pathname) :clobber t
-				   :recursive nil)
-		(message "~A has been modified, it remains unchanged."
-			 (namestring pathname))))))
-      (when marked-dirs
-	(dolist (dir-info marked-dirs)
-	  (let ((dir (car dir-info))
-		(write-date (cdr dir-info)))
-	    (if (= write-date (file-write-date dir))
-		(when (or (not (value dired-directory-expunge-confirm))
-			  (prompt-for-y-or-n
-			   :prompt (list "~a is a directory. Delete it? "
-					 (directory-namestring dir))
-			   :default t
-			   :must-exist t
-			   :default-string "Y"))
-		  (dired:delete-file (directory-namestring dir) :clobber t
-				     :recursive t)
-		  (setf we-did-something t))
-		(message "~A has been modified, it remains unchanged.")))))
-      we-did-something)))
-
-
-
-;;;; Dired copying and renaming.
-
-(defhvar "Dired Copy File Confirm"
-  "Can be either t, nil, or :update.  T means always query before clobbering an
-   existing file, nil means don't query before clobbering an existing file, and
-   :update means only ask if the existing file is newer than the source."
-  :value T)
-
-(defhvar "Dired Rename File Confirm"
-  "When non-nil, dired will query before clobbering an existing file."
-  :value T)
-
-(defcommand "Dired Copy File" (p)
-  "Copy the file under the point"
-  "Copy the file under the point"
-  (declare (ignore p))
-  (let* ((point (current-point))
-	 (confirm (value dired-copy-file-confirm))
-	 (source (dired-file-pathname
-		  (array-element-from-mark
-		   point (dired-info-files (value dired-information)))))
-	 (dest (prompt-for-file
-		:prompt (if (directoryp source)
-			    "Destination Directory Name: "
-			    "Destination Filename: ")
-		:help "Name of new file."
-		:default source
-		:must-exist nil))
-	 (dired:*error-function* #'dired-error-function)
-	 (dired:*report-function* #'dired-report-function)
-	 (dired:*yesp-function* #'dired-yesp-function))
-    (dired:copy-file source dest :update (if (eq confirm :update) t nil)
-		     :clobber (not confirm)))
-  (maintain-dired-consistency))
-
-(defcommand "Dired Rename File" (p)
-  "Rename the file or directory under the point"
-  "Rename the file or directory under the point"
-  (declare (ignore p))
-  (let* ((point (current-point))
-	 (source (dired-namify (dired-file-pathname
-				(array-element-from-mark
-				 point
-				 (dired-info-files (value dired-information))))))
-	 (dest (prompt-for-file
-		:prompt "New Filename: "
-		:help "The new name for this file."
-		:default source
-		:must-exist nil))
-	 (dired:*error-function* #'dired-error-function)
-	 (dired:*report-function* #'dired-report-function)
-	 (dired:*yesp-function* #'dired-yesp-function))
-    ;; ARRAY-ELEMENT-FROM-MARK moves mark to line start.
-    (dired:rename-file source dest :clobber (value dired-rename-file-confirm)))
-  (maintain-dired-consistency))
-
-(defcommand "Dired Copy with Wildcard" (p)
-  "Copy files that match a pattern containing ONE wildcard."
-  "Copy files that match a pattern containing ONE wildcard."
-  (declare (ignore p))
-  (let* ((dir-info (value dired-information))
-	 (confirm (value dired-copy-file-confirm))
-	 (pattern (prompt-for-string
-		   :prompt "Filename pattern: "
-		   :help "Type a filename with a single asterisk."
-		   :trim t))
-	 (destination (namestring
-		       (prompt-for-file
-			:prompt "Destination Spec: "
-			:help "Destination spec.  May contain ONE asterisk."
-			:default (dired-info-pathname dir-info)
-			:must-exist nil)))
-	 (dired:*error-function* #'dired-error-function)
-	 (dired:*yesp-function* #'dired-yesp-function)
-	 (dired:*report-function* #'dired-report-function))
-    (dired:copy-file pattern destination :update (if (eq confirm :update) t nil)
-		     :clobber (not confirm)
-		     :directory (dired-info-file-list dir-info)))
-  (maintain-dired-consistency))
-
-(defcommand "Dired Rename with Wildcard" (p)
-  "Rename files that match a pattern containing ONE wildcard."
-  "Rename files that match a pattern containing ONE wildcard."
-  (declare (ignore p))
-  (let* ((dir-info (value dired-information))
-	 (pattern (prompt-for-string
-		   :prompt "Filename pattern: "
-		   :help "Type a filename with a single asterisk."
-		   :trim t))
-	 (destination (namestring
-		       (prompt-for-file
-			:prompt "Destination Spec: "
-			:help "Destination spec.  May contain ONE asterisk."
-			:default (dired-info-pathname dir-info)
-			:must-exist nil)))
-	 (dired:*error-function* #'dired-error-function)
-	 (dired:*yesp-function* #'dired-yesp-function)
-	 (dired:*report-function* #'dired-report-function))
-    (dired:rename-file pattern destination
-		       :clobber (not (value dired-rename-file-confirm))
-		       :directory (dired-info-file-list dir-info)))
-  (maintain-dired-consistency))
-
-(defcommand "Delete File" (p)
-  "Delete a file.  Specify directories with a trailing slash."
-  "Delete a file.  Specify directories with a trailing slash."
-  (declare (ignore p))
-  (let* ((spec (namestring
-		(prompt-for-file
-		 :prompt "Delete File: "
-		 :help '("Name of File or Directory to delete.  ~
-			  One wildcard is permitted.")
-		 :must-exist nil)))
-	 (directoryp (directoryp spec))
-	 (dired:*error-function* #'dired-error-function)
-	 (dired:*report-function* #'dired-report-function)
-	 (dired:*yesp-function* #'dired-yesp-function))
-    (when (or (not directoryp)
-	      (not (value dired-directory-expunge-confirm))
-	      (prompt-for-y-or-n
-	       :prompt (list "~A is a directory. Delete it? "
-			     (directory-namestring spec))
-	       :default t :must-exist t :default-string "Y")))
-    (dired:delete-file spec :recursive t
-		       :clobber (or directoryp
-				    (value dired-file-expunge-confirm))))
-  (maintain-dired-consistency))
-
-(defcommand "Copy File" (p)
-  "Copy a file, allowing ONE wildcard."
-  "Copy a file, allowing ONE wildcard."
-  (declare (ignore p))
-  (let* ((confirm (value dired-copy-file-confirm))
-	 (source (namestring
-		  (prompt-for-file
-		   :prompt "Source Filename: "
-		   :help "Name of File to copy.  One wildcard is permitted."
-		   :must-exist nil)))
-	 (dest (namestring
-		(prompt-for-file
-		 :prompt (if (directoryp source)
-			     "Destination Directory Name: "
-			     "Destination Filename: ")
-		 :help "Name of new file."
-		 :default source
-		 :must-exist nil)))
-	 (dired:*error-function* #'dired-error-function)
-	 (dired:*report-function* #'dired-report-function)
-	 (dired:*yesp-function* #'dired-yesp-function))
-    (dired:copy-file source dest :update (if (eq confirm :update) t nil)
-		     :clobber (not confirm)))
-  (maintain-dired-consistency))
-
-(defcommand "Rename File" (p)
-  "Rename a file, allowing ONE wildcard."
-  "Rename a file, allowing ONE wildcard."
-  (declare (ignore p))
-  (let* ((source (namestring
-		  (prompt-for-file
-		   :prompt "Source Filename: "
-		   :help "Name of file to rename.  One wildcard is permitted."
-		   :must-exist nil)))
-	 (dest (namestring
-		(prompt-for-file
-		 :prompt (if (directoryp source)
-			     "Destination Directory Name: "
-			     "Destination Filename: ")
-		 :help "Name of new file."
-		 :default source
-		 :must-exist nil)))
-	 (dired:*error-function* #'dired-error-function)
-	 (dired:*report-function* #'dired-report-function)
-	 (dired:*yesp-function* #'dired-yesp-function))
-    (dired:rename-file source dest
-		       :clobber (not (value dired-rename-file-confirm))))
-  (maintain-dired-consistency))
-
-(defun maintain-dired-consistency ()
-  (dolist (info *pathnames-to-dired-buffers*)
-    (let* ((directory (directory-namestring (car info)))
-	   (buffer (cdr info))
-	   (dir-info (variable-value 'dired-information :buffer buffer))
-	   (write-date (file-write-date directory)))
-      (unless (= (dired-info-write-date dir-info) write-date)
-	(update-dired-buffer directory (dired-info-pattern dir-info) buffer)))))
-
-
-
-;;;; Dired utilities.
-
-;;; GET-MARKED-DIRED-FILES returns as multiple values a list of file specs
-;;; and a list of directory specs that have been marked for deletion.  This
-;;; assumes the current buffer is a "Dired" buffer.
-;;;
-(defun get-marked-dired-files ()
-  (let* ((files (dired-info-files (value dired-information)))
-	 (length (length files))
-	 (marked-files ())
-	 (marked-dirs ()))
-    (unless files (editor-error "Not in Dired buffer."))
-    (do ((i 0 (1+ i)))
-	((= i length) (values (nreverse marked-files) (nreverse marked-dirs)))
-      (let* ((thing (svref files i))
-	     (pathname (dired-file-pathname thing)))
-	(when (dired-file-deleted-p thing)
-	  (if (directoryp pathname)
-	      (push (cons pathname (file-write-date pathname)) marked-dirs)
-	      (push (cons pathname (file-write-date pathname))
-		    marked-files)))))))
-
-;;; ARRAY-ELEMENT-FROM-MARK counts the lines between it and the beginning
-;;; of the buffer.  The number is used to index vector as if each line
-;;; mapped to an element starting with the zero'th element (lines are
-;;; numbered starting at 1).
-;;;
-(defun array-element-from-mark (mark vector
-				&optional (error-msg "Invalid line."))
-  (when (blank-line-p (mark-line mark)) (editor-error error-msg))
-  (svref vector
-	 (1- (count-lines (region
-			   (buffer-start-mark (line-buffer (mark-line mark)))
-			   mark)))))
-
-;;; DIRED-NAMIFY and DIRED-DIRECTORIFY are implementation dependent slime.
-;;;
-(defun dired-namify (pathname)
-  (let* ((string (namestring pathname))
-	 (last (1- (length string))))
-    (if (char= (schar string last) #\/)
-	(subseq string 0 last)
-	string)))
-;;;
-;;; This is necessary to derive a canonical representation for directory
-;;; names, so "Dired" can map various strings naming one directory to that
-;;; one directory.
-;;;
-(defun dired-directorify (pathname)
-  (let ((directory (lisp::predict-name pathname t)))
-    (if (directoryp directory)
-	directory
-	(pathname (concatenate 'simple-string (namestring directory) "/")))))
-
-
-
-;;;; View Mode.
-
-(defmode "View" :major-p nil
-  :setup-function 'setup-view-mode
-  :cleanup-function 'cleanup-view-mode
-  :precedence 5.0
-  :documentation
-  "View mode scrolls forwards and backwards in a file with the buffer read-only.
-   Scrolling off the end optionally deletes the buffer.")
-
-(defun setup-view-mode (buffer)
-  (defhvar "View Return Function"
-    "Function that gets called when quitting or returning from view mode."
-    :value nil
-    :buffer buffer)
-  (setf (buffer-writable buffer) nil))
-;;;
-(defun cleanup-view-mode (buffer)
-  (delete-variable 'view-return-function :buffer buffer)
-  (setf (buffer-writable buffer) t))
-
-(defcommand "View File" (p &optional pathname)
-  "Reads a file in as if by \"Find File\", but read-only.  Commands exist
-   for scrolling convenience."
-  "Reads a file in as if by \"Find File\", but read-only.  Commands exist
-   for scrolling convenience."
-  (declare (ignore p))
-  (let* ((pn (or pathname
-		 (prompt-for-file 
-		  :prompt "View File: " :must-exist t
-		  :help "Name of existing file to read into its own buffer."
-		  :default (buffer-default-pathname (current-buffer)))))
-	 (buffer (make-buffer (format nil "View File ~A" (gensym)))))
-    (visit-file-command nil pn buffer)
-    (setf (buffer-minor-mode buffer "View") t)
-    (change-to-buffer buffer)
-    buffer))
-
-(defcommand "View Return" (p)
-  "Return to a parent buffer, if it exists."
-  "Return to a parent buffer, if it exists."
-  (declare (ignore p))
-  (unless (call-view-return-fun)
-    (editor-error "No View return method for this buffer.")))
-
-(defcommand "View Quit" (p)
-  "Delete a buffer in view mode."
-  "Delete a buffer in view mode, invoking VIEW-RETURN-FUNCTION if it exists for
-   this buffer."
-  (declare (ignore p))
-  (let* ((buf (current-buffer))
-	 (funp (call-view-return-fun)))
-    (delete-buffer-if-possible buf)
-    (unless funp (editor-error "No View return method for this buffer."))))
-
-;;; CALL-VIEW-RETURN-FUN returns nil if there is no current
-;;; view-return-function.  If there is one, it calls it and returns t.
-;;;
-(defun call-view-return-fun ()
-  (if (hemlock-bound-p 'view-return-function)
-      (let ((fun (value view-return-function)))
-	(cond (fun
-	       (funcall fun)
-	       t)))))
-
-
-(defhvar "View Scroll Deleting Buffer"
-  "When this is set, \"View Scroll Down\" deletes the buffer when the end
-   of the file is visible."
-  :value t)
-
-(defcommand "View Scroll Down" (p)
-  "Scroll the current window down through its buffer.
-   If the end of the file is visible, then delete the buffer if \"View Scroll
-   Deleting Buffer\" is set.  If the buffer is associated with a dired buffer,
-   this returns there instead of to the previous buffer."
-  "Scroll the current window down through its buffer.
-   If the end of the file is visible, then delete the buffer if \"View Scroll
-   Deleting Buffer\" is set.  If the buffer is associated with a dired buffer,
-   this returns there instead of to the previous buffer."
-  (if (and (not p)
-	   (displayed-p (buffer-end-mark (current-buffer))
-			(current-window))
-	   (value view-scroll-deleting-buffer))
-      (view-quit-command nil)
-      (scroll-window-down-command p)))
-
-(defcommand "View Edit File" (p)
-  "Turn off \"View\" mode in this buffer."
-  "Turn off \"View\" mode in this buffer."
-  (declare (ignore p))
-  (let ((buf (current-buffer)))
-    (setf (buffer-minor-mode buf "View") nil)
-    (warn-about-visit-file-buffers buf)))
-
-(defcommand "View Help" (p)
-  "Shows \"View\" mode help message."
-  "Shows \"View\" mode help message."
-  (declare (ignore p))
-  (describe-mode-command nil "View"))
diff --git a/hemlock/display.lisp b/hemlock/display.lisp
deleted file mode 100644
index e0c70c842f5dace8dc80419c7726544850093202..0000000000000000000000000000000000000000
--- a/hemlock/display.lisp
+++ /dev/null
@@ -1,312 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/display.lisp,v 1.8 1991/11/11 18:12:44 chiles Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Bill Chiles.
-;;;
-;;; This is the device independent redisplay entry points for Hemlock.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(redisplay redisplay-all))
-
-
-
-;;;; Main redisplay entry points.
-
-(defvar *things-to-do-once* ()
-  "This is a list of lists of functions and args to be applied to.  The 
-  functions are called with args supplied at the top of the command loop.")
-
-(defvar *screen-image-trashed* ()
-  "This variable is set to true if the screen has been trashed by some screen
-   manager operation, and thus should be totally refreshed.  This is currently
-   only used by tty redisplay.")
-
-;;; True if we are in redisplay, and thus don't want to enter it recursively.
-;;;
-(defvar *in-redisplay* nil)
-
-(proclaim '(special *window-list*))
-
-(eval-when (compile eval)
-
-;;; REDISPLAY-LOOP -- Internal.
-;;;
-;;; This executes internal redisplay routines on all windows interleaved with
-;;; checking for input, and if any input shows up we punt returning
-;;; :editor-input.  Special-fun is for windows that the redisplay interface
-;;; wants to recenter to keep the window's buffer's point visible.  General-fun
-;;; is for other windows.
-;;;
-;;; Whenever we invoke one of the internal routines, we keep track of the
-;;; non-nil return values, so we can return t when we are done.  Returning t
-;;; means redisplay should run again to make sure it converged.  To err on the
-;;; safe side, if any window had any changed lines, then let's go through
-;;; redisplay again; that is, return t.
-;;;
-;;; After checking each window, we put the cursor in the appropriate place and
-;;; force output.  When we try to position the cursor, it may no longer lie
-;;; within the window due to buffer modifications during redisplay.  If it is
-;;; out of the window, return t to indicate we need to finish redisplaying.
-;;;
-;;; Then we check for the after-redisplay method.  Routines such as REDISPLAY
-;;; and REDISPLAY-ALL want to invoke the after method to make sure we handle
-;;; any events generated from redisplaying.  There wouldn't be a problem with
-;;; handling these events if we were going in and out of Hemlock's event
-;;; handling, but some user may loop over one of these interface functions for
-;;; a long time without going through Hemlock's input loop; when that happens,
-;;; each call to redisplay may not result in a complete redisplay of the
-;;; device.  Routines such as INTERNAL-REDISPLAY don't want to worry about this
-;;; since Hemlock calls them while going in and out of the input/event-handling
-;;; loop.
-;;;
-;;; Around all of this, we establish the 'redisplay-catcher tag.  Some device
-;;; redisplay methods throw to this to abort redisplay in addition to this
-;;; code.
-;;;
-(defmacro redisplay-loop (general-fun special-fun &optional (afterp t))
-  (let* ((device (gensym)) (point (gensym)) (hunk (gensym)) (n-res (gensym))
-	 (win-var (gensym))
-	 (general-form (if (symbolp general-fun)
-			   `(,general-fun ,win-var)
-			   `(funcall ,general-fun ,win-var)))
-	 (special-form (if (symbolp special-fun)
-			   `(,special-fun ,win-var)
-			   `(funcall ,special-fun ,win-var))))
-    `(let ((,n-res nil)
-	   (*in-redisplay* t))
-       (catch 'redisplay-catcher
-	 (when (listen-editor-input *real-editor-input*)
-	   (throw 'redisplay-catcher :editor-input))
-	 (let ((,win-var *current-window*))
-	   (when ,special-form (setf ,n-res t)))
-	 (dolist (,win-var *window-list*)
-	   (unless (eq ,win-var *current-window*)
-	     (when (listen-editor-input *real-editor-input*)
-	       (throw 'redisplay-catcher :editor-input))
-	     (when (if (window-display-recentering ,win-var)
-		       ,special-form
-		       ,general-form)
-	        (setf ,n-res t))))
-	 (let* ((,hunk (window-hunk *current-window*))
-		(,device (device-hunk-device ,hunk))
-		(,point (window-point *current-window*)))
-	   (move-mark ,point (buffer-point (window-buffer *current-window*)))
-	   (multiple-value-bind (x y)
-				(mark-to-cursorpos ,point *current-window*)
-	     (if x
-		 (funcall (device-put-cursor ,device) ,hunk x y)
-		 (setf ,n-res t)))
-	   (when (device-force-output ,device)
-	     (funcall (device-force-output ,device)))
-	   ,@(if afterp
-		 `((when (device-after-redisplay ,device)
-		     (funcall (device-after-redisplay ,device) ,device)
-		     ;; The after method may have queued input that the input
-		     ;; loop won't see until the next input arrives, so check
-		     ;; here to return the correct value as per the redisplay
-		     ;; contract.
-		     (when (listen-editor-input *real-editor-input*)
-		       (setf ,n-res :editor-input)))))
-	   ,n-res)))))
-
-) ;eval-when
-
-
-;;; REDISPLAY -- Public.
-;;;
-;;; This function updates the display of all windows which need it.  It assumes
-;;; it's internal representation of the screen is accurate and attempts to do
-;;; the minimal amount of output to bring the screen into correspondence.
-;;; *screen-image-trashed* is only used by terminal redisplay.
-;;;
-(defun redisplay ()
-  "The main entry into redisplay; updates any windows that seem to need it."
-  (when *things-to-do-once*
-    (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing)))
-    (setf *things-to-do-once* nil))
-  (cond (*in-redisplay* t)
-	(*screen-image-trashed*
-	 (when (eq (redisplay-all) t)
-	   (setf *screen-image-trashed* nil)
-	   t))
-	(t
-	 (redisplay-loop redisplay-window redisplay-window-recentering))))
-
-
-;;; REDISPLAY-ALL -- Public.
-;;;
-;;; Update the screen making no assumptions about its correctness.  This is
-;;; useful if the screen gets trashed, or redisplay gets lost.  Since windows
-;;; may be on different devices, we have to go through the list clearing all
-;;; possible devices.  Always returns T or :EDITOR-INPUT, never NIL.
-;;;
-(defun redisplay-all ()
-  "An entry into redisplay; causes all windows to be fully refreshed."
-  (let ((cleared-devices nil))
-    (dolist (w *window-list*)
-      (let* ((hunk (window-hunk w))
-	     (device (device-hunk-device hunk)))
-	(unless (member device cleared-devices :test #'eq)
-	  (when (device-clear device)
-	    (funcall (device-clear device) device))
-	  ;;
-	  ;; It's cleared whether we did clear it or there was no method.
-	  (push device cleared-devices)))))
-  (redisplay-loop
-   redisplay-window-all
-   #'(lambda (window)
-       (setf (window-tick window) (tick))
-       (update-window-image window)
-       (maybe-recenter-window window)
-       (funcall (device-dumb-redisplay
-		 (device-hunk-device (window-hunk window)))
-		window)
-       t)))
-
-
-
-;;;; Internal redisplay entry points.
-
-(defun internal-redisplay ()
-  "The main internal entry into redisplay.  This is just like REDISPLAY, but it
-   doesn't call the device's after-redisplay method."
-  (when *things-to-do-once*
-    (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing)))
-    (setf *things-to-do-once* nil))
-  (cond (*in-redisplay* t)
-	(*screen-image-trashed*
-	 (when (eq (redisplay-all) t)
-	   (setf *screen-image-trashed* nil)
-	   t))
-	(t
-	 (redisplay-loop redisplay-window redisplay-window-recentering))))
-
-;;; REDISPLAY-WINDOWS-FROM-MARK -- Internal Interface.
-;;;
-;;; hemlock-output-stream methods call this to update the screen.  It only
-;;; redisplays windows which are displaying the buffer concerned and doesn't
-;;; deal with making the cursor track the point.  *screen-image-trashed* is
-;;; only used by terminal redisplay.  This must call the device after-redisplay
-;;; method since stream output may occur without ever returning to the
-;;; Hemlock input/event-handling loop.
-;;;
-(defun redisplay-windows-from-mark (mark)
-  (when *things-to-do-once*
-    (dolist (thing *things-to-do-once*) (apply (car thing) (cdr thing)))
-    (setf *things-to-do-once* nil))
-  (cond ((or *in-redisplay* (not *in-the-editor*)) t)
-	((listen-editor-input *real-editor-input*) :editor-input)
-	(*screen-image-trashed*
-	 (when (eq (redisplay-all) t)
-	   (setf *screen-image-trashed* nil)
-	   t))
-	(t
-	 (catch 'redisplay-catcher
-	   (let ((buffer (line-buffer (mark-line mark))))
-	     (when buffer
-	       (flet ((frob (win)
-			(let* ((device (device-hunk-device (window-hunk win)))
-			       (force (device-force-output device))
-			       (after (device-after-redisplay device)))
-			  (when force (funcall force))
-			  (when after (funcall after device)))))
-		 (let ((windows (buffer-windows buffer)))
-		   (when (member *current-window* windows :test #'eq)
-		     (redisplay-window-recentering *current-window*)
-		     (frob *current-window*))
-		   (dolist (window windows)
-		     (unless (eq window *current-window*)
-		       (redisplay-window window)
-		       (frob window)))))))))))
-
-;;; REDISPLAY-WINDOW -- Internal.
-;;;
-;;; Return t if there are any changed lines, nil otherwise.
-;;;
-(defun redisplay-window (window)
-  "Maybe updates the window's image and calls the device's smart redisplay
-   method.  NOTE: the smart redisplay method may throw to
-   'hi::redisplay-catcher to abort redisplay."
-  (maybe-update-window-image window)
-  (prog1
-      (not (eq (window-first-changed window) the-sentinel))
-    (funcall (device-smart-redisplay (device-hunk-device (window-hunk window)))
-	     window)))
-
-(defun redisplay-window-all (window)
-  "Updates the window's image and calls the device's dumb redisplay method."
-  (setf (window-tick window) (tick))
-  (update-window-image window)
-  (funcall (device-dumb-redisplay (device-hunk-device (window-hunk window)))
-	   window)
-  t)
-
-(defun random-typeout-redisplay (window)
-  (catch 'redisplay-catcher
-    (maybe-update-window-image window)
-    (let* ((device (device-hunk-device (window-hunk window)))
-	   (force (device-force-output device)))
-      (funcall (device-smart-redisplay device) window)
-      (when force (funcall force)))))
-
-
-;;;; Support for redisplay entry points.
-
-;;; REDISPLAY-WINDOW-RECENTERING -- Internal.
-;;;
-;;; This tries to be clever about updating the window image unnecessarily,
-;;; recenters the window if the window's buffer's point moved off the window,
-;;; and does a smart redisplay.  We call the redisplay method even if we didn't
-;;; update the image or recenter because someone else may have modified the
-;;; window's image and already have updated it; if nothing happened, then the
-;;; smart method shouldn't do anything anyway.  NOTE: the smart redisplay
-;;; method may throw to 'hi::redisplay-catcher to abort redisplay.
-;;;
-;;; This return t if there are any changed lines, nil otherwise.
-;;; 
-(defun redisplay-window-recentering (window)
-  (setup-for-recentering-redisplay window)
-  (invoke-hook ed::redisplay-hook window)
-  (setup-for-recentering-redisplay window)
-  (prog1
-      (not (eq (window-first-changed window) the-sentinel))
-    (funcall (device-smart-redisplay (device-hunk-device (window-hunk window)))
-	     window)))
-
-(defun setup-for-recentering-redisplay (window)
-  (let* ((display-start (window-display-start window))
-	 (old-start (window-old-start window)))
-    ;;
-    ;; If the start is in the middle of a line and it wasn't before,
-    ;; then move the start there.
-    (when (and (same-line-p display-start old-start)
-	       (not (start-line-p display-start))
-	       (start-line-p old-start))
-      (line-start display-start))
-    (maybe-update-window-image window)
-    (maybe-recenter-window window)))
-
-
-;;; MAYBE-UPDATE-WINDOW-IMAGE only updates if the text has changed or the
-;;; display start.
-;;; 
-(defun maybe-update-window-image (window)
-  (when (or (> (buffer-modified-tick (window-buffer window))
-	       (window-tick window))
-	    (mark/= (window-display-start window)
-		    (window-old-start window)))
-    (setf (window-tick window) (tick))
-    (update-window-image window)
-    t))
diff --git a/hemlock/doccoms.lisp b/hemlock/doccoms.lisp
deleted file mode 100644
index 189c87ab3787a37867bd73067fe117afeee8c278..0000000000000000000000000000000000000000
--- a/hemlock/doccoms.lisp
+++ /dev/null
@@ -1,429 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/doccoms.lisp,v 1.3 1991/02/08 16:34:02 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Hemlock Documentation and Help commands.
-;;; Written by Rob MacLachlan and Bill Chiles.
-;;;
-
-(in-package "HEMLOCK")
-
-
-
-;;;; Help.
-
-(defcommand "Help" (p)
-  "Give helpful information.
-  This command dispatches to a number of other documentation commands,
-  on the basis of a character command."
-  "Prompt for a single character command to dispatch to another helping
-  function."
-  (declare (ignore p))
-  (command-case (:prompt "Doc (Help for Help): "
-		 :help "Type a Help option to say what kind of help you want:")
-    (#\a "List all commands, variables and attributes Apropos a keyword."
-     (apropos-command nil))
-    (#\d "Describe a command, given its name."
-     (describe-command-command nil))
-    (#\g "Generic describe, any Hemlock thing (e.g., variables, keys, attributes)."
-     (generic-describe-command nil))
-    (#\v "Describe variable and show its values."
-     (describe-and-show-variable-command nil))
-    (#\c "Describe the command bound to a Character."
-     (describe-key-command nil))
-    (#\l "List the last 60 characters typed."
-     (what-lossage-command nil))
-    (#\m "Describe a mode."
-     (describe-mode-command nil))
-    (#\p "Describe commands with mouse/pointer bindings."
-     (describe-pointer-command nil))
-    (#\w "Find out Where a command is bound."
-     (where-is-command nil))
-    (#\t "Describe a Lisp object."
-     (editor-describe-command nil))
-    ((#\q :no) "Quits, You don't really want help.")))
-
-(defcommand "Where Is" (p)
-  "Find what key a command is bound to.
-   Prompts for the command to look for, and says what environment it is
-   available in."
-  "List places where a command is bound."
-  (declare (ignore p))
-  (multiple-value-bind (nam cmd)
-		       (prompt-for-keyword (list *command-names*)
-					   :prompt "Command: "
-					   :help "Name of command to look for.")
-    (let ((bindings (command-bindings cmd)))
-      (with-pop-up-display (s)
-	(cond
-	 ((null bindings)
-	  (format s "~S may only be invoked as an extended command.~%" nam))
-	 (t
-	  (format s "~S may be invoked in the following ways:~%" nam)
-	  (print-command-bindings bindings s)))))))
-
-
-
-;;;; Apropos.
-
-(defcommand "Apropos" (p)
-  "List things whose names contain a keyword."
-  "List things whose names contain a keyword."
-  (declare (ignore p))
-  (let* ((str (prompt-for-string
-		:prompt "Apropos keyword: "
-		:help
- "String to look for in command, variable and attribute names."))
-	 (coms (find-containing str *command-names*))
-	 (vars (mapcar #'(lambda (table)
-			   (let ((res (find-containing str table)))
-			     (if res (cons table res))))
-		       (current-variable-tables)))
-	 (attr (find-containing str *character-attribute-names*)))
-    (if (or coms vars attr)
-	(apropos-command-output str coms vars attr)
-	(with-pop-up-display (s :height 1)
-	  (format s "No command, attribute or variable name contains ~S."
-		  str)))))
-
-(defun apropos-command-output (str coms vars attr)
-  (declare (list coms vars attr))
-  (with-pop-up-display (s)
-    (when coms
-      (format s "Commands with ~S in their names:~%" str)
-      (dolist (com coms)
-	(let ((obj (getstring com *command-names*)))
-	  (write-string com s)
-	  (write-string "   " s)
-	  (print-command-bindings (command-bindings obj) s)
-	  (terpri s)
-	  (print-short-doc (command-documentation obj) s))))
-    (when vars
-      (when coms (terpri s))
-      (format s "Variables with ~S in their names:~%" str)
-      (dolist (stuff vars)
-	(let ((table (car stuff)))
-	  (dolist (var (cdr stuff))
-	    (let ((obj (getstring var table)))
-	      (write-string var s)
-	      (write-string "   " s)
-	      (let ((*print-level* 2) (*print-length* 3))
-		(prin1 (variable-value obj) s))
-	      (terpri s)
-	      (print-short-doc (variable-documentation obj) s))))))
-    (when attr
-      (when (or coms vars) (terpri s))
-      (format s "Attributes with ~S in their names:~%" str)
-      (dolist (att attr)
-	(let ((obj (getstring att *character-attribute-names*)))
-	  (write-line att s)
-	  (print-short-doc (character-attribute-documentation obj) s))))))
-
-;;; PRINT-SHORT-DOC takes doc, a function or string, and gets it out on stream.
-;;; If doc is a string, this only outputs up to the first newline.  All output
-;;; is preceded by two spaces.
-;;;
-(defun print-short-doc (doc stream)
-  (let ((str (typecase doc
-	       (function (funcall doc :short))
-	       (simple-string
-		(let ((nl (position #\newline (the simple-string doc))))
-		  (subseq doc 0 (or nl (length doc)))))
-	       (t
-		(error "Bad documentation: ~S" doc)))))
-    (write-string "  " stream)
-    (write-line str stream)))
-
-
-
-;;;; Describe command, key, pointer.
-
-(defcommand "Describe Command" (p)
-  "Describe a command.
-  Prompts for a command and then prints out it's full documentation."
-  "Print out the command documentation for a command which is prompted for."
-  (declare (ignore p))
-  (multiple-value-bind (nam com)
-		       (prompt-for-keyword
-			(list *command-names*)
-			:prompt "Describe command: "
-			:help "Name of a command to document.")
-    (let ((bindings (command-bindings com)))
-      (with-pop-up-display (s)
-	(format s "Documentation for ~S:~%   ~A~%"
-		nam (command-documentation com))
-	(cond ((not bindings)
-	       (write-line
-		"This can only be invoked as an extended command." s))
-	      (t
-	       (write-line
-		"This can be invoked in the following ways:" s)
-	       (write-string "   " s)
-	       (print-command-bindings bindings s)
-	       (terpri s)))))))
-
-(defcommand "Describe Key" (p)
-  "Prompt for a sequence of characters.  When the first character is typed that
-   terminates a key binding in the current context, describe the command bound
-   to it.  When the first character is typed that no longer allows a correct
-   key to be entered, tell the user that this sequence is not bound to
-   anything."
-  "Print out the command documentation for a key
-  which is prompted for."
-  (declare (ignore p))
-  (let ((old-window (current-window)))
-    (unwind-protect
-	(progn
-	  (setf (current-window) hi::*echo-area-window*)
-	  (hi::display-prompt-nicely "Describe key: " nil)
-	  (setf (fill-pointer hi::*prompt-key*) 0)
-	  (loop
-	    (let ((key-event (get-key-event hi::*editor-input*)))
-	      (vector-push-extend key-event hi::*prompt-key*)
-	      (let ((res (get-command hi::*prompt-key* :current)))
-		(ext:print-pretty-key-event key-event *echo-area-stream*)
-		(write-char #\space *echo-area-stream*)
-		(cond ((commandp res)
-		       (with-pop-up-display (s)
-			 (print-pretty-key (copy-seq hi::*prompt-key*) s)
-			 (format s " is bound to ~S.~%" (command-name res))
-			 (format s "Documentation for this command:~%   ~A"
-				 (command-documentation res)))
-		       (return))
-		      ((not (eq res :prefix))
-		       (with-pop-up-display (s :height 1)
-			 (print-pretty-key (copy-seq hi::*prompt-key*) s)
-			 (write-string " is not bound to anything." s))
-		       (return)))))))
-      (setf (current-window) old-window))))
-
-(defcommand "Describe Pointer" (p)
-  "Describe commands with any key binding that contains a \"mouse\" character
-   (modified or not).  Does not describe the command \"Illegal\"."
-  "Describe commands with any key binding that contains a \"mouse\" character
-   (modified or not).  Does not describe the command \"Illegal\"."
-  (declare (ignore p))
-  (let ((illegal-command (getstring "Illegal" *command-names*)))
-    (with-pop-up-display (s)
-      (dolist (cmd (get-mouse-commands))
-	(unless (eq cmd illegal-command)
-	  (format s "Documentation for ~S:~%   ~A~%"
-		  (command-name cmd)
-		  (command-documentation cmd))
-	  (write-line
-	   "This can be invoked in the following ways:" s)
-	  (write-string "   " s)
-	  (print-command-bindings (command-bindings cmd) s)
-	  (terpri s) (terpri s))))))
-
-(defun get-mouse-commands ()
-  (let ((result nil))
-    (do-strings (name cmd *command-names* result)
-      (declare (ignore name))
-      (dolist (b (command-bindings cmd))
-        (let ((key (car b)))
-          (declare (simple-vector key))
-	  (when (dotimes (i (length key) nil)
-		  (when (member (ext:make-key-event (svref key i))
-				(list #k"Leftdown" #k"Leftup" #k"Middledown"
-				      #k"Middleup" #k"Rightdown" #k"Rightup"))
-		    (push cmd result)
-		    (return t)))
-	    (return)))))))
-
-
-
-;;;; Generic describe variable, command, key, attribute.
-
-(defvar *generic-describe-kinds*
-  (list (make-string-table :initial-contents
-			   '(("Variable" . :variable)
-			     ("Command" . :command)
-			     ("Key" . :key)
-			     ("Attribute" . :attribute)))))
-
-(defcommand "Generic Describe" (p)
-  "Describe some Hemlock thing.
-  First prompt for the kind of thing, then prompt for the thing to describe.
-  Currently supported kinds of things are variables, commands, keys and
-  character attributes."
-  "Prompt for some Hemlock thing to describe."
-  (declare (ignore p))
-  (multiple-value-bind (ignore kwd)
-		       (prompt-for-keyword *generic-describe-kinds*
-					   :default "Variable"
-					   :help "Kind of thing to describe."
-					   :prompt "Kind: ")
-    (declare (ignore ignore))
-    (case kwd
-      (:variable
-       (describe-and-show-variable-command nil))
-      (:command (describe-command-command ()))
-      (:key (describe-key-command ()))
-      (:attribute
-       (multiple-value-bind (name attr)
-			    (prompt-for-keyword
-			     (list *character-attribute-names*)
-			     :help "Name of character attribute to describe."
-			     :prompt "Attribute: ")
-	 (print-full-doc name (character-attribute-documentation attr)))))))
-
-;;; PRINT-FULL-DOC displays whole documentation string in a pop-up window.
-;;; Doc may be a function that takes at least one arg, :short or :full.
-;;;
-(defun print-full-doc (nam doc)
-  (typecase doc
-    (function (funcall doc :full))
-    (simple-string
-     (with-pop-up-display (s)
-       (format s "Documentation for ~S:~%  ~A" nam doc)))
-    (t (error "Bad documentation: ~S" doc))))
-
-
-
-;;;; Describing and show variables.
-
-(defcommand "Show Variable" (p)
-  "Display the values of a Hemlock variable."
-  "Display the values of a Hemlock variable."
-  (declare (ignore p))
-  (multiple-value-bind (name var)
-		       (prompt-for-variable
-			:help "Name of variable to describe."
-			:prompt "Variable: ")
-    (with-pop-up-display (s)
-      (show-variable s name var))))
-
-(defcommand "Describe and Show Variable" (p)
-  "Describe in full and show all of variable's value.
-   Variable is prompted for."
-  "Describe in full and show all of variable's value."
-  (declare (ignore p))
-  (multiple-value-bind (name var)
-		       (prompt-for-variable
-			:help "Name of variable to describe."
-			:prompt "Variable: ")
-    (with-pop-up-display (s)
-      (format s "Documentation for ~S:~%  ~A~&~%"
-	      name (variable-documentation var))
-      (show-variable s name var))))
-
-(defun show-variable (s name var)
-  (when (hemlock-bound-p var :global)
-    (format s "Global value of ~S:~%  ~S~%"
-	    name (variable-value var :global)))
-  (let ((buffer (current-buffer)))
-    (when (hemlock-bound-p var :buffer (current-buffer))
-      (format s "Value of ~S in buffer ~A:~%  ~S~%"
-	      name (buffer-name buffer)
-	      (variable-value var :buffer buffer))))
-  (do-strings (mode-name val *mode-names*)
-    (declare (ignore val))
-    (when (hemlock-bound-p var :mode mode-name)
-      (format s "Value of ~S in ~S Mode:~%  ~S~%"
-	      name mode-name
-	      (variable-value var :mode mode-name)))))
-
-
-
-;;;; Describing modes.
-
-(defvar *describe-mode-ignore* (list "Illegal" "Do Nothing"))
-
-(defcommand "Describe Mode" (p &optional name)
-  "Describe a mode showing special bindings for that mode."
-  "Describe a mode showing special bindings for that mode."
-  (declare (ignore p))
-  (let ((name (or name
-		  (prompt-for-keyword (list *mode-names*)
-				      :prompt "Mode: "
-				      :help "Enter mode to describe."
-				      :default
-				      (car (buffer-modes (current-buffer)))))))
-    (with-pop-up-display (s)
-      (format s "~A mode description:~%" name)
-      (let ((doc (mode-documentation name)))
-	(when doc
-	  (write-line doc s)
-	  (terpri s)))
-      (map-bindings 
-       #'(lambda (key cmd)
-	   (unless (member (command-name cmd)
-			   *describe-mode-ignore*
-			   :test #'string-equal)
-	     (let ((str (key-to-string key)))
-	       (cond ((= (length str) 1)
-		      (write-string str s)
-		      (write-string "  - " s))
-		     (t (write-line str s)
-			(write-string "   - " s)))
-	       (print-short-doc (command-documentation cmd) s))))
-       :mode name))))
-		    
-(defun key-to-string (key)
-  (with-output-to-string (s)
-    (print-pretty-key key s)))
-
-
-
-;;;; Printing bindings and last N characters typed.
-
-(defcommand "What Lossage" (p)
-  "Display the last 60 characters typed."
-  "Display the last 60 characters typed."
-  (declare (ignore p))
-  (with-pop-up-display (s :height 7)
-    (let ((num (ring-length *key-event-history*)))
-      (format s "The last ~D characters typed:~%" num)
-      (do ((i (1- num) (1- i)))
-	  ((minusp i))
-	(ext:print-pretty-key-event (ring-ref *key-event-history* i) s)
-	(write-char #\space s)))))
-
-(defun print-command-bindings (bindings stream)
-  (let ((buffer ())
-	(mode ())
-	(global ()))
-    (dolist (b bindings)
-      (case (second b)
-	(:global (push (first b) global))
-	(:mode
-	 (let ((m (assoc (third b) mode :test #'string=)))
-	   (if m
-	       (push (first b) (cdr m))
-	       (push (list (third b) (first b)) mode))))
-	(t
-	 (let ((f (assq (third b) buffer)))
-	   (if f
-	       (push (first b) (cdr f))
-	       (push (list (third b) (first b)) buffer))))))
-    (when global
-      (print-some-keys global stream)
-      (write-string "; " stream))
-    (dolist (b buffer)
-      (format stream "Buffer ~S: " (buffer-name (car b)))
-      (print-some-keys (cdr b) stream)
-      (write-string "; " stream))
-    (dolist (m mode)
-      (write-string (car m) stream)
-      (write-string ": " stream)
-      (print-some-keys (cdr m) stream)
-      (write-string "; " stream))))
-
-;;; PRINT-SOME-KEYS prints the list of keys onto Stream.
-;;;
-(defun print-some-keys (keys stream)
-  (do ((key keys (cdr key)))
-      ((null (cdr key))
-       (print-pretty-key (car key) stream))
-    (print-pretty-key (car key) stream)
-    (write-string ", " stream)))
diff --git a/hemlock/echo.lisp b/hemlock/echo.lisp
deleted file mode 100644
index 5a6c675187dd874f28fa110662e21daa7977a501..0000000000000000000000000000000000000000
--- a/hemlock/echo.lisp
+++ /dev/null
@@ -1,743 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/echo.lisp,v 1.6 1991/12/18 11:44:07 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Hemlock Echo Area stuff.
-;;; Written by Skef Wholey and Rob MacLachlan.
-;;; Modified by Bill Chiles.
-;;;
-(in-package "HEMLOCK-INTERNALS")
-(export '(*echo-area-buffer* *echo-area-stream* *echo-area-window*
-	  *parse-starting-mark* *parse-input-region*
-	  *parse-verification-function* *parse-string-tables*
-	  *parse-value-must-exist* *parse-default* *parse-default-string*
-	  *parse-prompt* *parse-help* clear-echo-area message loud-message
-	  prompt-for-buffer prompt-for-file prompt-for-integer
-	  prompt-for-keyword prompt-for-expression prompt-for-string
-	  prompt-for-variable prompt-for-yes-or-no prompt-for-y-or-n
-	  prompt-for-key-event prompt-for-key *logical-key-event-names*
-	  logical-key-event-p logical-key-event-documentation
-	  logical-key-event-name logical-key-event-key-events
-	  define-logical-key-event *parse-type* current-variable-tables))
-
-
-(defmode "Echo Area" :major-p t)
-(defvar *echo-area-buffer* (make-buffer "Echo Area" :modes '("Echo Area"))
-  "Buffer used to hack text for the echo area.")
-(defvar *echo-area-region* (buffer-region *echo-area-buffer*)
-  "Internal thing that's the *echo-area-buffer*'s region.")
-(defvar *echo-area-stream*
-  (make-hemlock-output-stream (region-end *echo-area-region*) :full)
-  "Buffered stream that prints into the echo area.")
-(defvar *echo-area-window* ()
-  "Window used to display stuff in the echo area.")
-(defvar *parse-starting-mark*
-  (copy-mark (buffer-point *echo-area-buffer*) :right-inserting)
-  "Mark that points to the beginning of the text that'll be parsed.")
-(defvar *parse-input-region*
-  (region *parse-starting-mark* (region-end *echo-area-region*))
-  "Region that contains the text typed in.")
-
-
-
-;;;; Variables that control parsing:
-
-(defvar *parse-verification-function* '%not-inside-a-parse
-  "Function that verifies what's being parsed.")
-
-;;; %Not-Inside-A-Parse  --  Internal
-;;;
-;;;    This function is called if someone does stuff in the echo area when
-;;; we aren't inside a parse.  It tries to put them back in a reasonable place.
-;;;
-(defun %not-inside-a-parse (quaz)
-  "Thing that's called when somehow we get called to confirm a parse that's
-  not in progress."
-  (declare (ignore quaz))
-  (let* ((bufs (remove *echo-area-buffer* *buffer-list*))
-	 (buf (or (find-if #'buffer-windows bufs)
-		  (car bufs)
-		  (make-buffer "Main"))))
-    (setf (current-buffer) buf)
-    (dolist (w *window-list*)
-      (when (and (eq (window-buffer w) *echo-area-buffer*)
-		 (not (eq w *echo-area-window*)))
-	(setf (window-buffer w) buf)))
-    (setf (current-window)
-	  (or (car (buffer-windows buf))
-	      (make-window (buffer-start-mark buf)))))
-  (editor-error "Wham!  We tried to confirm a parse that wasn't in progress?"))
-
-(defvar *parse-string-tables* ()
-  "String tables being used in the current parse.")
-
-(defvar *parse-value-must-exist* ()
-  "You know.")
-
-(defvar *parse-default* ()
-  "When the user attempts to default a parse, we call the verification function
-  on this string.  This is not the :Default argument to the prompting function,
-  but rather a string representation of it.")
-
-(defvar *parse-default-string* ()
-  "String that we show the user to inform him of the default.  If this
-  is NIL then we just use *Parse-Default*.")
-
-(defvar *parse-prompt* ()
-  "Prompt for the current parse.")
-
-(defvar *parse-help* ()
-  "Help string for the current parse.")
-
-(defvar *parse-type* :string "A hack. :String, :File or :Keyword.") 
-
-
-
-;;;; MESSAGE and CLEAR-ECHO-AREA:
-
-(defhvar "Message Pause" "The number of seconds to pause after a Message."
-  :value 0.5s0)
-
-(defvar *last-message-time* 0
-  "Internal-Real-Time the last time we displayed a message.") 
-
-(defun maybe-wait ()
-  (let* ((now (get-internal-real-time))
-	 (delta (/ (float (- now *last-message-time*))
-		   (float internal-time-units-per-second)))
-	 (pause (value ed::message-pause)))
-    (when (< delta pause)
-      (sleep (- pause delta)))))
-
-(defun clear-echo-area ()
-  "You guessed it."
-  (maybe-wait)
-  (delete-region *echo-area-region*)
-  (setf (buffer-modified *echo-area-buffer*) nil))
-
-;;; Message  --  Public
-;;;
-;;;    Display the stuff on *echo-area-stream* and then wait.  Editor-Sleep
-;;; will do a redisplay if appropriate.
-;;;
-(defun message (string &rest args)
-  "Nicely display a message in the echo-area.
-  Put the message on a fresh line and wait for \"Message Pause\" seconds
-  to give the luser a chance to see it.  String and Args are a format 
-  control string and format arguments, respectively."
-  (maybe-wait)
-  (cond ((eq *current-window* *echo-area-window*)
-	 (let ((point (buffer-point *echo-area-buffer*)))
-	   (with-mark ((m point :left-inserting))
-	     (line-start m)
-	     (with-output-to-mark (s m :full)
-	       (apply #'format s string args)
-	       (fresh-line s)))))
-	(t
-	 (let ((mark (region-end *echo-area-region*)))
-	   (cond ((buffer-modified *echo-area-buffer*)
-		  (clear-echo-area))
-		 ((not (zerop (mark-charpos mark)))
-		  (insert-character mark #\newline)
-		  (unless (displayed-p mark *echo-area-window*)
-		    (clear-echo-area))))
-	   (apply #'format *echo-area-stream* string args)
-	   (setf (buffer-modified *echo-area-buffer*) nil))))
-  (force-output *echo-area-stream*)
-  (setq *last-message-time* (get-internal-real-time))
-  nil)
-
-
-;;; LOUD-MESSAGE -- Public.
-;;;
-;;; Like message, only more provocative.
-;;;
-(defun loud-message (&rest args)
-  "This is the same as MESSAGE, but it beeps and clears the echo area before
-   doing anything else."
-  (beep)
-  (clear-echo-area)
-  (apply #'message args))
-
-
-(defhvar "Raise Echo Area When Modified"
-  "When set, Hemlock raises the echo area window when output appears there."
-  :value nil)
-
-;;; RAISE-ECHO-AREA-WHEN-MODIFIED -- Internal.
-;;;
-;;; INIT-BITMAP-SCREEN-MANAGER in bit-screen.lisp adds this hook when
-;;; initializing the bitmap screen manager.
-;;;
-(defun raise-echo-area-when-modified (buffer modified)
-  (when (and (value ed::raise-echo-area-when-modified)
-	     (eq buffer *echo-area-buffer*)
-	     modified)
-    (let* ((hunk (window-hunk *echo-area-window*))
-	   (win (window-group-xparent (bitmap-hunk-window-group hunk))))
-      (xlib:map-window win)
-      (setf (xlib:window-priority win) :above)
-      (xlib:display-force-output
-       (bitmap-device-display (device-hunk-device hunk))))))
-
-
-
-;;;; DISPLAY-PROMPT-NICELY and PARSE-FOR-SOMETHING.
-
-(defun display-prompt-nicely (&optional (prompt *parse-prompt*)
-					(default (or *parse-default-string*
-						     *parse-default*)))
-  (clear-echo-area)
-  (let ((point (buffer-point *echo-area-buffer*)))
-    (if (listp prompt)
-	(apply #'format *echo-area-stream* prompt)
-	(insert-string point prompt))
-    (when default
-      (insert-character point #\[)
-      (insert-string point default)
-      (insert-string point "] "))))
-
-(defun parse-for-something ()
-  (display-prompt-nicely)
-  (let ((start-window (current-window)))
-    (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*))
-    (setf (current-window) *echo-area-window*)
-    (unwind-protect
-     (use-buffer *echo-area-buffer*
-       (recursive-edit nil))
-     (setf (current-window) start-window))))
-
-
-
-;;;; Buffer prompting.
-
-(defun prompt-for-buffer (&key ((:must-exist *parse-value-must-exist*) t)
-			       default
-			       ((:default-string *parse-default-string*))
-			       ((:prompt *parse-prompt*) "Buffer: ")
-			       ((:help *parse-help*) "Type a buffer name."))
-  "Prompts for a buffer name and returns the corresponding buffer.  If
-   :must-exist is nil, then return the input string.  This refuses to accept
-   the empty string as input when no default is supplied.  :default-string
-   may be used to supply a default buffer name even when :default is nil, but
-   when :must-exist is non-nil, :default-string must be the name of an existing
-   buffer."
-    (let ((*parse-string-tables* (list *buffer-names*))
-	  (*parse-type* :keyword)
-	  (*parse-default* (cond
-			    (default (buffer-name default))
-			    (*parse-default-string*
-			     (when (and *parse-value-must-exist*
-					(not (getstring *parse-default-string*
-							*buffer-names*)))
-			       (error "Default-string must name an existing ~
-				       buffer when must-exist is non-nil -- ~S."
-				      *parse-default-string*))
-			     *parse-default-string*)
-			    (t nil)))
-	  (*parse-verification-function* #'buffer-verification-function))
-      (parse-for-something)))
-
-(defun buffer-verification-function (string)
-  (declare (simple-string string))
-  (cond ((string= string "") nil)
-	(*parse-value-must-exist*
-	 (multiple-value-bind
-	     (prefix key value field ambig)
-	     (complete-string string *parse-string-tables*)
-	   (declare (ignore field))
-	   (ecase key
-	     (:none nil)
-	     ((:unique :complete)
-	      (list value))
-	     (:ambiguous
-	      (delete-region *parse-input-region*)
-	      (insert-string (region-start *parse-input-region*) prefix)
-	      (let ((point (current-point)))
-		(move-mark point (region-start *parse-input-region*))
-		(unless (character-offset point ambig)
-		  (buffer-end point)))
-	      nil))))
-	(t
-	 (list (or (getstring string *buffer-names*) string)))))
-
-
-
-;;;; File Prompting.
-
-(defun prompt-for-file (&key ((:must-exist *parse-value-must-exist*) t)
-			     default
-			     ((:default-string *parse-default-string*))
-			     ((:prompt *parse-prompt*) "Filename: ")
-			     ((:help *parse-help*) "Type a file name."))
-  "Prompts for a filename."
-  (let ((*parse-verification-function* #'file-verification-function)
-	(*parse-default* (if default (namestring default)))
-	(*parse-type* :file))
-    (parse-for-something)))
-
-(defun file-verification-function (string)
-  (let ((pn (pathname-or-lose string)))
-    (if pn
-	(let ((merge
-	       (cond ((not *parse-default*) nil)
-		     ((directoryp pn)
-		      (merge-pathnames pn *parse-default*))
-		     (t
-		      (merge-pathnames pn
-				       (directory-namestring
-					*parse-default*))))))
-	  (cond ((probe-file pn) (list pn))
-		((and merge (probe-file merge)) (list merge))
-		((not *parse-value-must-exist*) (list (or merge pn)))
-		(t nil))))))
-
-;;; PATHNAME-OR-LOSE tries to convert string to a pathname using
-;;; PARSE-NAMESTRING.  If it succeeds, this returns the pathname.  Otherwise,
-;;; this deletes the offending characters from *parse-input-region* and signals
-;;; an editor-error.
-;;;
-(defun pathname-or-lose (string)
-  (declare (simple-string string))
-  (multiple-value-bind (pn idx)
-		       (parse-namestring string nil *default-pathname-defaults*
-					 :junk-allowed t)
-    (cond (pn)
-	  (t (delete-characters (region-end *echo-area-region*)
-				(- idx (length string)))
-	     nil))))
-
-
-
-;;;; Keyword and variable prompting.
-
-(defun prompt-for-keyword (*parse-string-tables* 
-			   &key
-			   ((:must-exist *parse-value-must-exist*) t)
-			   ((:default *parse-default*))
-			   ((:default-string *parse-default-string*))
-			   ((:prompt *parse-prompt*) "Keyword: ")
-			   ((:help *parse-help*) "Type a keyword."))
-  "Prompts for a keyword using the String Tables."
-  (let ((*parse-verification-function* #'keyword-verification-function)
-	(*parse-type* :keyword))
-    (parse-for-something)))
-
-(defun prompt-for-variable (&key ((:must-exist *parse-value-must-exist*) t)
-				 ((:default *parse-default*))
-				 ((:default-string *parse-default-string*))
-				 ((:prompt *parse-prompt*) "Variable: ")
-				 ((:help *parse-help*)
-				  "Type the name of a variable."))
-  "Prompts for a variable defined in the current scheme of things."
-  (let ((*parse-string-tables* (current-variable-tables))
-	(*parse-verification-function* #'keyword-verification-function)
-	(*parse-type* :keyword))
-    (parse-for-something)))
-
-(defun current-variable-tables ()
-  "Returns a list of all the variable tables currently established globally,
-   by the current buffer, and by any modes for the current buffer."
-  (do ((tables (list (buffer-variables *current-buffer*)
-		     *global-variable-names*)
-	       (cons (mode-object-variables (car mode)) tables))
-       (mode (buffer-mode-objects *current-buffer*) (cdr mode)))
-      ((null mode) tables)))
-
-(defun keyword-verification-function (string)
-  (declare (simple-string string))
-  (multiple-value-bind
-      (prefix key value field ambig)
-      (complete-string string *parse-string-tables*)
-    (declare (ignore field))
-    (cond (*parse-value-must-exist*
-	   (ecase key
-	     (:none nil)
-	     ((:unique :complete)
-	      (list prefix value))
-	     (:ambiguous
-	      (delete-region *parse-input-region*)
-	      (insert-string (region-start *parse-input-region*) prefix)
-	      (let ((point (current-point)))
-		(move-mark point (region-start *parse-input-region*))
-		(unless (character-offset point ambig)
-		  (buffer-end point)))
-	      nil)))
-	  (t
-	   ;; HACK: If it doesn't have to exist, and the completion does not
-	   ;; add anything, then return the completion's capitalization,
-	   ;; instead of the user's input.
-	   (list (if (= (length string) (length prefix)) prefix string))))))
-
-
-
-;;;; Integer, expression, and string prompting.
-
-(defun prompt-for-integer (&key ((:must-exist *parse-value-must-exist*) t)
-				default
-				((:default-string *parse-default-string*))
-				((:prompt *parse-prompt*) "Integer: ")
-				((:help *parse-help*) "Type an integer."))
-  "Prompt for an integer.  If :must-exist is Nil, then we return as a string
-  whatever was input if it is not a valid integer."
-  (let ((*parse-verification-function*
-	 #'(lambda (string)
-	     (let ((number (parse-integer string  :junk-allowed t)))
-	       (if *parse-value-must-exist*
-		   (if number (list number))
-		   (list (or number string))))))
-	(*parse-default* (if default (write-to-string default :base 10))))
-    (parse-for-something)))
-
-
-(defvar hemlock-eof '(())
-  "An object that won't be EQ to anything read.")
-
-(defun prompt-for-expression (&key ((:must-exist *parse-value-must-exist*) t)
-				   (default nil defaultp)
-				   ((:default-string *parse-default-string*))
-				   ((:prompt *parse-prompt*) "Expression: ")
-				   ((:help *parse-help*)
-				    "Type a Lisp expression."))
-  "Prompts for a Lisp expression."
-  (let ((*parse-verification-function*
-         #'(lambda (string)
-	     (let ((expr (with-input-from-region (stream *parse-input-region*)
-			   (handler-case (read stream nil hemlock-eof)
-			     (error () hemlock-eof)))))
-	       (if *parse-value-must-exist*
-		   (if (not (eq expr hemlock-eof)) (values (list expr) t))
-		   (if (eq expr hemlock-eof)
-		       (list string) (values (list expr) t))))))
-	(*parse-default* (if defaultp (prin1-to-string default))))
-      (parse-for-something)))
-
-
-(defun prompt-for-string (&key ((:default *parse-default*))
-			       ((:default-string *parse-default-string*))
-			       (trim ())
-			       ((:prompt *parse-prompt*) "String: ")
-			       ((:help *parse-help*) "Type a string."))
-  "Prompts for a string.  If :trim is t, then leading and trailing whitespace
-   is removed from input, otherwise it is interpreted as a Char-Bag argument
-   to String-Trim."
-  (let ((*parse-verification-function*
-	 #'(lambda (string)
-	     (list (string-trim (if (eq trim t) '(#\space #\tab) trim)
-				string)))))
-    (parse-for-something)))
-
-
-
-;;;; Yes-or-no and y-or-n prompting.
-
-(defvar *yes-or-no-string-table*
-  (make-string-table :initial-contents '(("Yes" . t) ("No" . nil))))
-
-(defun prompt-for-yes-or-no (&key ((:must-exist *parse-value-must-exist*) t)
-				  (default nil defaultp)
-				  ((:default-string *parse-default-string*))
-				  ((:prompt *parse-prompt*) "Yes or No? ")
-				  ((:help *parse-help*) "Type Yes or No."))
-  "Prompts for Yes or No."
-  (let* ((*parse-string-tables* (list *yes-or-no-string-table*))
-	 (*parse-default* (if defaultp (if default "Yes" "No")))
-	 (*parse-verification-function*
-	  #'(lambda (string)
-	      (multiple-value-bind
-		  (prefix key value field ambig)
-		  (complete-string string *parse-string-tables*)
-		(declare (ignore prefix field ambig))
-		(let ((won (or (eq key :complete) (eq key :unique))))
-		  (if *parse-value-must-exist*
-		      (if won (values (list value) t))
-		      (list (if won (values value t) string)))))))
-	 (*parse-type* :keyword))
-    (parse-for-something)))
-
-(defun prompt-for-y-or-n (&key ((:must-exist must-exist) t)
-			       (default nil defaultp)
-			       default-string
-			       ((:prompt prompt) "Y or N? ")
-			       ((:help *parse-help*) "Type Y or N."))
-  "Prompts for Y or N."
-  (let ((old-window (current-window)))
-    (unwind-protect
-	(progn
-	  (setf (current-window) *echo-area-window*)
-	  (display-prompt-nicely prompt (or default-string
-					    (if defaultp (if default "Y" "N"))))
-	  (loop
-	    (let ((key-event (get-key-event *editor-input*)))
-	      (cond ((or (eq key-event #k"y")
-			 (eq key-event #k"Y"))
-		     (return t))
-		    ((or (eq key-event #k"n")
-			 (eq key-event #k"N"))
-		     (return nil))
-		    ((logical-key-event-p key-event :confirm)
-		     (if defaultp
-			 (return default)
-			 (beep)))
-		    ((logical-key-event-p key-event :help)
-		     (ed::help-on-parse-command ()))
-		    (t
-		     (unless must-exist (return key-event))
-		     (beep))))))
-      (setf (current-window) old-window))))
-
-
-
-;;;; Key-event and key prompting.
-
-(defun prompt-for-key-event (&key (prompt "Key-event: ") (change-window t))
-  "Prompts for a key-event."
-  (prompt-for-key-event* prompt change-window))
-
-(defun prompt-for-key-event* (prompt change-window)
-  (let ((old-window (current-window)))
-    (unwind-protect
-	(progn
-	  (when change-window
-	    (setf (current-window) *echo-area-window*))
-	  (display-prompt-nicely prompt)
-	  (get-key-event *editor-input* t))
-      (when change-window (setf (current-window) old-window)))))
-
-(defvar *prompt-key* (make-array 10 :adjustable t :fill-pointer 0))
-(defun prompt-for-key (&key ((:must-exist must-exist) t)
-			    default default-string
-			    (prompt "Key: ")
-			    ((:help *parse-help*) "Type a key."))
-  (let ((old-window (current-window))
-	(string (if default
-		    (or default-string
-			(let ((l (coerce default 'list)))
-			  (format nil "~:C~{ ~:C~}" (car l) (cdr l)))))))
-
-    (unwind-protect
-	(progn
-	  (setf (current-window) *echo-area-window*)
-	  (display-prompt-nicely prompt string)
-	  (setf (fill-pointer *prompt-key*) 0)
-	  (prog ((key *prompt-key*) key-event)
-		(declare (vector key))
-		TOP
-		(setf key-event (get-key-event *editor-input*))
-		(cond ((logical-key-event-p key-event :quote)
-		       (setf key-event (get-key-event *editor-input* t)))
-		      ((logical-key-event-p key-event :confirm)
-		       (cond ((and default (zerop (length key)))
-			      (let ((res (get-command default :current)))
-				(unless (commandp res) (go FLAME))
-				(return (values default res))))
-			     ((and (not must-exist) (plusp (length key)))
-			      (return (copy-seq key)))
-			     (t 
-			      (go FLAME))))
-		      ((logical-key-event-p key-event :help)
-		       (ed::help-on-parse-command ())
-		       (go TOP)))
-		(vector-push-extend key-event key)	 
-		(when must-exist
-		  (let ((res (get-command key :current)))
-		    (cond ((commandp res)
-			   (ext:print-pretty-key-event key-event
-						       *echo-area-stream*
-						       t)
-			   (write-char #\space *echo-area-stream*)
-			   (return (values (copy-seq key) res)))
-			  ((not (eq res :prefix))
-			   (vector-pop key)
-			   (go FLAME)))))
-		(print-pretty-key key-event *echo-area-stream* t)
-		(write-char #\space *echo-area-stream*)
-		(go TOP)
-		FLAME
-		(beep)
-		(go TOP)))
-      (force-output *echo-area-stream*)
-      (setf (current-window) old-window))))
-
-
-
-;;;; Logical key-event stuff.
-
-(defvar *logical-key-event-names* (make-string-table)
-  "This variable holds a string-table from logical-key-event names to the
-   corresponding keywords.")
-
-(defvar *real-to-logical-key-events* (make-hash-table :test #'eql)
-  "A hashtable from real key-events to their corresponding logical
-   key-event keywords.")
-
-(defvar *logical-key-event-descriptors* (make-hash-table :test #'eq)
-  "A hashtable from logical-key-events to logical-key-event-descriptors.")
-
-(defstruct (logical-key-event-descriptor
-	    (:constructor make-logical-key-event-descriptor ()))
-  name
-  key-events
-  documentation)
-
-;;; LOGICAL-KEY-EVENT-P  --  Public
-;;;
-(defun logical-key-event-p (key-event keyword)
-  "Return true if key-event has been defined to have Keyword as its
-   logical key-event.  The relation between logical and real key-events
-   is defined by using SETF on LOGICAL-KEY-EVENT-P.  If it is set to
-   true then calling LOGICAL-KEY-EVENT-P with the same key-event and
-   Keyword, will result in truth.  Setting to false produces the opposite
-   result.  See DEFINE-LOGICAL-KEY-EVENT and COMMAND-CASE."
-  (not (null (memq keyword (gethash key-event *real-to-logical-key-events*)))))
-
-;;; GET-LOGICAL-KEY-EVENT-DESC  --  Internal
-;;;
-;;;    Return the descriptor for the logical key-event keyword, or signal
-;;; an error if it isn't defined.
-;;;
-(defun get-logical-key-event-desc (keyword)
-  (let ((res (gethash keyword *logical-key-event-descriptors*)))
-    (unless res
-      (error "~S is not a defined logical-key-event keyword." keyword))
-    res))
-
-;;; %SET-LOGICAL-KEY-EVENT-P  --  Internal
-;;;
-;;;    Add or remove a logical key-event link by adding to or deleting from
-;;; the list in the from-char hashtable and the descriptor.
-;;;
-(defun %set-logical-key-event-p (key-event keyword new-value)
-  (let ((entry (get-logical-key-event-desc keyword)))
-    (cond
-     (new-value
-      (pushnew keyword (gethash key-event *real-to-logical-key-events*))
-      (pushnew key-event (logical-key-event-descriptor-key-events entry)))
-     (t
-      (setf (gethash key-event *real-to-logical-key-events*)
-	    (delete keyword (gethash key-event *real-to-logical-key-events*)))
-      (setf (logical-key-event-descriptor-key-events entry)
-	    (delete keyword (logical-key-event-descriptor-key-events entry))))))
-  new-value)
-
-;;; LOGICAL-KEY-EVENT-DOCUMENTATION, NAME, KEY-EVENTS  --  Public
-;;;
-;;;    Grab the right field out of the descriptor and return it.
-;;;
-(defun logical-key-event-documentation (keyword)
-  "Return the documentation for the logical key-event Keyword."
-  (logical-key-event-descriptor-documentation
-   (get-logical-key-event-desc keyword)))
-;;;
-(defun logical-key-event-name (keyword)
-  "Return the string name for the logical key-event Keyword."
-  (logical-key-event-descriptor-name (get-logical-key-event-desc keyword)))
-;;;
-(defun logical-key-event-key-events (keyword)
-  "Return the list of key-events for which Keyword is the logical key-event."
-  (logical-key-event-descriptor-key-events
-   (get-logical-key-event-desc keyword)))
-
-;;; DEFINE-LOGICAL-KEY-EVENT  --  Public
-;;;
-;;;    Make the entries in the two hashtables and the string-table.
-;;;
-(defun define-logical-key-event (name documentation)
-  "Define a logical key-event having the specified Name and Documentation.
-  See LOGICAL-KEY-EVENT-P and COMMAND-CASE."
-  (check-type name string)
-  (check-type documentation (or string function))
-  (let* ((keyword (string-to-keyword name))
-	 (entry (or (gethash keyword *logical-key-event-descriptors*)
-		    (setf (gethash keyword *logical-key-event-descriptors*)
-			  (make-logical-key-event-descriptor)))))
-    (setf (logical-key-event-descriptor-name entry) name)
-    (setf (logical-key-event-descriptor-documentation entry) documentation)
-    (setf (getstring name *logical-key-event-names*) keyword)))
-
-
-
-;;;; Some standard logical-key-events:
-
-(define-logical-key-event "Forward Search"
-  "This key-event is used to indicate that a forward search should be made.")
-(define-logical-key-event "Backward Search"
-  "This key-event is used to indicate that a backward search should be made.")
-(define-logical-key-event "Recursive Edit"
-  "This key-event indicates that a recursive edit should be entered.")
-(define-logical-key-event "Cancel"
-  "This key-event is used  to cancel a previous key-event of input.")
-(define-logical-key-event "Abort"
-  "This key-event is used to abort the command in progress.")
-(define-logical-key-event "Exit"
-  "This key-event is used to exit normally the command in progress.")
-(define-logical-key-event "Yes"
-  "This key-event is used to indicate a positive response.")
-(define-logical-key-event "No"
-  "This key-event is used to indicate a negative response.")
-(define-logical-key-event "Do All"
-  "This key-event means do it as many times as you can.")
-(define-logical-key-event "Do Once"
-  "This key-event means, do it this time, then exit.")
-(define-logical-key-event "Help"
-  "This key-event is used to ask for help.")
-(define-logical-key-event "Confirm"
-  "This key-event is used to confirm some choice.")
-(define-logical-key-event "Quote"
-  "This key-event is used to quote the next key-event of input.")
-(define-logical-key-event "Keep"
-  "This key-event means exit but keep something around.")
-
-
-
-;;;; COMMAND-CASE help message printing.
-
-(defvar *my-string-output-stream* (make-string-output-stream))
-
-(defun chars-to-string (chars)
-  (do ((s *my-string-output-stream*)
-       (chars chars (cdr chars)))
-      ((null chars)
-       (get-output-stream-string s))
-    (let ((char (car chars)))
-      (if (characterp char)
-	  (write-char char s)
-	  (do ((key-events
-		(logical-key-event-key-events char)
-		(cdr key-events)))
-	      ((null key-events))
-	    (ext:print-pretty-key (car key-events) s)
-	    (unless (null (cdr key-events))
-	      (write-string ", " s))))
-      (unless (null (cdr chars))
-	(write-string ", " s)))))
-
-;;; COMMAND-CASE-HELP  --  Internal
-;;;
-;;;    Print out a help message derived from the options in a
-;;; random-typeout window.
-;;;
-(defun command-case-help (help options)
-  (let ((help (if (listp help)
-		  (apply #'format nil help) help)))
-    (with-pop-up-display (s)
-      (write-string help s)
-      (fresh-line s)
-      (do ((o options (cdr o)))
-	  ((null o))
-	(let ((string (chars-to-string (caar o))))
-	  (declare (simple-string string))
-	  (if (= (length string) 1)
-	      (write-char (char string 0) s)
-	      (write-line string s))
-	  (write-string "  - " s)
-	  (write-line (cdar o) s))))))
diff --git a/hemlock/echocoms.lisp b/hemlock/echocoms.lisp
deleted file mode 100644
index ab47e05fe86f3ff56fb67de7d00f950b758af035..0000000000000000000000000000000000000000
--- a/hemlock/echocoms.lisp
+++ /dev/null
@@ -1,318 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;; Echo area commands.
-;;;
-;;; Written by Rob MacLachlan and Skef Wholey.
-;;;
-(in-package 'hemlock)
-
-(defhvar "Beep on Ambiguity"
-  "If non-NIL, beep when completion of a parse is ambiguous."
-  :value t)
-
-(defhvar "Ignore File Types"
-  "File types to ignore when trying to complete a filename."
-  :value
-  (list "fasl" "err"			    ; Lisp
-	"BAK" "CKP"			    ; Backups & Checkpoints
-	"PS" "ps" "press" "otl" "dvi" "toc" ; Formatting
-	"bbl" "lof" "idx" "lot" "aux"	    ; Formatting
-	"mo" "elc"			    ; Other editors
-	"bin" "lbin"			    ; Obvious binary extensions.
-	"o" "a" "aout"			    ; UNIXY stuff
-	"bm" "onx" "snf"		    ; X stuff
-	"UU" "uu" "arc" "Z" "tar"	    ; Binary encoded files
-	))
-
-
-;;; Field separator characters separate fields for TOPS-20 ^F style 
-;;; completion.
-(defattribute "Parse Field Separator"
-  "A value of 1 for this attribute indicates that the corresponding character
-  should be considered to be a field separator by the prompting commands.")
-(setf (character-attribute :parse-field-separator #\space) 1)
-
-
-;;; Find-All-Completions  --  Internal
-;;;
-;;;    Return as a list of all the possible completions of String in the
-;;; list of string-tables Tables.
-;;;
-(defun find-all-completions (string tables)
-  (do ((table tables (cdr table))
-       (res () 
-	    (merge 'list (find-ambiguous string (car table)) 
-		   res #'string-lessp)))
-      ((null table) res)))
-
-(defcommand "Help on Parse" (p)
-  "Display help for parse in progress.
-  If there are a limited number of options then display them."
-  "Display the *Parse-Help* and any possibly completions of the current
-  input."
-  (declare (ignore p))
-  (let ((help (typecase *parse-help*
-		(list (unless *parse-help* (error "There is no parse help."))
-		      (apply #'format nil *parse-help*))
-		(string *parse-help*)
-		(t (error "Parse help is not a string or list: ~S" *parse-help*))))
-	(input (region-to-string *parse-input-region*)))
-    (cond
-     ((eq *parse-type* :keyword)
-      (let ((strings (find-all-completions input *parse-string-tables*)))
-	(with-pop-up-display (s :height (+ (length strings) 2))
-	  (write-line help s)
-	  (cond (strings
-		 (write-line "Possible completions of what you have typed:" s)
-		 (dolist (string strings)
-		   (write-line string s)))
-		(t
-		 (write-line 
- "There are no possible completions of what you have typed." s))))))
-     ((and (eq *parse-type* :file) (not (zerop (length input))))
-      (let ((pns (ambiguous-files (region-to-string *parse-input-region*)
-				  *parse-default*)))
-	(declare (list pns))
-	(with-pop-up-display(s :height (+ (length pns) 2))
-	  (write-line help s)
-	  (cond (pns
-		 (write-line "Possible completions of what you have typed:" s)
-		 (dolist (pn pns)
-		   (format s " ~A~25T ~A~%" (file-namestring pn)
-			   (directory-namestring pn))))
-		(t
-		 (write-line 
- "There are no possible completions of what you have typed." s))))))
-     (t
-      (with-mark ((m (buffer-start-mark *echo-area-buffer*) :left-inserting))
-	(insert-string m help)
-	(insert-character m #\newline))))))
-
-(defun file-completion-action (typein)
-  (declare (simple-string typein))
-  (when (zerop (length typein)) (editor-error))
-  (multiple-value-bind
-      (result win)
-      (complete-file typein
-		     :defaults (directory-namestring *parse-default*)
-		     :ignore-types (value ignore-file-types))
-    (when result
-      (delete-region *parse-input-region*)
-      (insert-string (region-start *parse-input-region*)
-		     (namestring result)))
-    (when (and (not win) (value beep-on-ambiguity))
-      (editor-error))))
-
-(defcommand "Complete Keyword" (p)
-  "Trys to complete the text being read in the echo area as a string in
-  *parse-string-tables*"
-  "Complete the keyword being parsed as far as possible.
-  If it is ambiguous and ``Beep On Ambiguity'' true beep."
-  (declare (ignore p))
-  (let ((typein (region-to-string *parse-input-region*)))
-    (declare (simple-string typein))
-    (case *parse-type*
-      (:keyword
-       (multiple-value-bind
-	   (prefix key value field ambig)
-	   (complete-string typein *parse-string-tables*)
-	 (declare (ignore value field))
-	 (when prefix
-	   (delete-region *parse-input-region*)
-	   (insert-string (region-start *parse-input-region*) prefix)
-	   (when (eq key :ambiguous)
-	     (let ((point (current-point)))
-	       (move-mark point (region-start *parse-input-region*))
-	       (unless (character-offset point ambig)
-		 (buffer-end point)))))
-	 (when (and (or (eq key :ambiguous) (eq key :none))
-		    (value beep-on-ambiguity))
-	   (editor-error))))
-      (:file
-       (file-completion-action typein))
-      (t
-       (editor-error "Cannot complete input for this prompt.")))))
-
-(defun field-separator-p (x)
-  (plusp (character-attribute :parse-field-separator x)))
-
-(defcommand "Complete Field" (p)
-  "Complete a field in a parse.
-  Fields are defined by the :field separator attribute,
-  the text being read in the echo area as a string in *parse-string-tables*"
-  "Complete a field in a keyword.
-  If it is ambiguous and ``Beep On Ambiguity'' true beep.  Fields are
-  separated by characters having a non-zero :parse-field-separator attribute,
-  and this command should only be bound to characters having that attribute."
-  (let ((typein (region-to-string *parse-input-region*)))
-    (declare (simple-string typein))
-    (case *parse-type*
-      (:string
-       (self-insert-command p))
-      (:file
-       (file-completion-action typein))
-      (:keyword
-       (let ((point (current-point)))
-	 (unless (blank-after-p point)
-	   (insert-character point
-			     (ext:key-event-char *last-key-event-typed*))))
-       (multiple-value-bind
-	   (prefix key value field ambig)
-	   (complete-string typein *parse-string-tables*)
-	 (declare (ignore value ambig))
-	 (when (eq key :none) (editor-error "No possible completion."))
-	 (delete-region *parse-input-region*)
-	 (let ((new-typein (if (and (eq key :unique) (null field))
-			       (subseq prefix 0 field)
-			       (concatenate 'string
-					    (subseq prefix 0 field)
-					    (string
-					     (ext:key-event-char
-					      *last-key-event-typed*))))))
-	   (insert-string (region-start *parse-input-region*) new-typein))))
-      (t
-       (editor-error "Cannot complete input for this prompt.")))))
-
-
-(defvar *echo-area-history* (make-ring 10)
-  "This ring-buffer contains strings which were previously input in the
-  echo area.")
-
-(defvar *echo-history-pointer* 0
-  "This is our current position to the ring during a historical exploration.")
-
-(defcommand "Confirm Parse" (p)
-  "Terminate echo-area input.
-  If the input is invalid then an editor-error will signalled."
-  "If no input has been given, exits the recursive edit with the default,
-  otherwise calls the verification function."
-  (declare (ignore p))
-  (let* ((string (region-to-string *parse-input-region*))
-	 (empty (zerop (length string))))
-    (declare (simple-string string))
-    (if empty
-	(when *parse-default* (setq string *parse-default*))
-	(when (or (zerop (ring-length *echo-area-history*))
-		  (string/= string (ring-ref *echo-area-history* 0)))
-	  (ring-push string *echo-area-history*)))
-    (multiple-value-bind (res flag)
-			 (funcall *parse-verification-function* string)
-      (unless (or res flag) (editor-error))
-      (exit-recursive-edit res))))
-
-(defcommand "Previous Parse" (p)
-  "Rotate the echo-area history forward.
-  If current input is non-empty and different from what is on the top
-  of the ring then push it on the ring before inserting the new input."
-  "Pop the *echo-area-history* ring buffer."
-  (let ((length (ring-length *echo-area-history*))
-	(p (or p 1)))
-    (declare (simple-string current))
-    (when (zerop length) (editor-error))
-    (cond
-     ((eq (last-command-type) :echo-history)
-      (let ((base (mod (+ *echo-history-pointer* p) length)))
-	(delete-region *parse-input-region*)
-	(insert-string (region-end *parse-input-region*)
-		       (ring-ref *echo-area-history* base))
-	(setq *echo-history-pointer* base)))
-     (t
-      (let ((current (region-to-string *parse-input-region*))
-	    (base (mod (if (minusp p) p (1- p)) length)))
-	(delete-region *parse-input-region*)
-	(insert-string (region-end *parse-input-region*)
-		       (ring-ref *echo-area-history* base))	
-	(when (and (plusp (length current))
-		   (string/= (ring-ref *echo-area-history* 0) current))
-	  (ring-push current *echo-area-history*)
-	  (incf base))
-	(setq *echo-history-pointer* base))))
-    (setf (last-command-type) :echo-history)))
-
-(defcommand "Next Parse" (p)
-  "Rotate the echo-area history backward.
-  If current input is non-empty and different from what is on the top
-  of the ring then push it on the ring before inserting the new input."
-  "Push the *echo-area-history* ring buffer."
-  (previous-parse-command (- (or p 1))))
-
-(defcommand "Illegal" (p)
-  "This signals an editor-error.
-  It is useful for making commands locally unbound."
-  "Just signals an editor-error."
-  (declare (ignore p))
-  (editor-error))
-
-(defcommand "Beginning Of Parse" (p)
-  "Moves to immediately after the prompt when in the echo area."
-  "Move the point of the echo area buffer to *parse-starting-mark*."
-  (declare (ignore p))
-  (move-mark (buffer-point *echo-area-buffer*) *parse-starting-mark*))
-
-(defcommand "Echo Area Delete Previous Character" (p)
-  "Delete the previous character.
-  Don't let the luser rub out the prompt."
-  "Signal an editor-error if we would nuke the prompt,
-  otherwise do a normal delete."
-  (with-mark ((tem (buffer-point *echo-area-buffer*)))
-    (unless (character-offset tem (- (or p 1))) (editor-error))
-    (when (mark< tem *parse-starting-mark*) (editor-error))
-    (delete-previous-character-command p)))
-
-(defcommand "Echo Area Kill Previous Word" (p)
-  "Kill the previous word.
-  Don't let the luser rub out the prompt."
-  "Signal an editor-error if we would mangle the prompt, otherwise
-  do a normal kill-previous-word."
-  (with-mark ((tem (buffer-point *echo-area-buffer*)))
-    (unless (word-offset tem (- (or p 1))) (editor-error))
-    (when (mark< tem *parse-starting-mark*) (editor-error))
-    (kill-previous-word-command p)))
-
-(proclaim '(special *kill-ring*))
-
-(defcommand "Kill Parse" (p)
-  "Kills any input so far."
-  "Kills *parse-input-region*."
-  (declare (ignore p))
-  (if (end-line-p (current-point))
-      (kill-region *parse-input-region* :kill-backward)
-      (ring-push (delete-and-save-region *parse-input-region*)
-		 *kill-ring*)))
-
-(defcommand "Insert Parse Default" (p)
-  "Inserts the default for the parse in progress.
-  The text is inserted at the point."
-  "Inserts *parse-default* at the point of the *echo-area-buffer*.
-  If there is no default an editor-error is signalled."
-  (declare (ignore p))
-  (unless *parse-default* (editor-error))
-  (insert-string (buffer-point *echo-area-buffer*) *parse-default*))
-
-(defcommand "Echo Area Backward Character" (p)
-  "Go back one character.
-  Don't let the luser move into the prompt."
-  "Signal an editor-error if we try to go into the prompt, otherwise
-  do a backward-character command."
-  (backward-character-command p)
-  (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*)
-    (beginning-of-parse-command ())
-    (editor-error)))
-
-(defcommand "Echo Area Backward Word" (p)
-  "Go back one word.
-  Don't let the luser move into the prompt."
-  "Signal an editor-error if we try to go into the prompt, otherwise
-  do a backward-word command."
-  (backward-word-command p)
-  (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*)
-    (beginning-of-parse-command ())
-    (editor-error)))
diff --git a/hemlock/ed-integrity.lisp b/hemlock/ed-integrity.lisp
deleted file mode 100644
index 02d6ef06f7af81b769b0ea260c365531ee52a4ab..0000000000000000000000000000000000000000
--- a/hemlock/ed-integrity.lisp
+++ /dev/null
@@ -1,167 +0,0 @@
-;;; -*- Package: hemlock; Log: hemlock.log; Mode: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/ed-integrity.lisp,v 1.2 1991/02/14 00:25:30 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This stuff can be used for testing tty redisplay.  There are four
-;;; commands that, given "Setup Tty Buffer", that test
-;;; HI::COMPUTE-TTY-CHANGES: "Two Deletes", "Two Inserts", "One Delete One
-;;; Insert", and "One Insert One Delete.  Each can be called with an
-;;; argument to generate a grand total of eight screen permutations.
-;;; "Setup Tty Buffer" numbers the lines of the main window 0 through 19
-;;; inclusively.
-;;; 
-;;; "Setup for Debugging" and "Cleanup for Debugging" were helpful in
-;;; conjunction with some alternate versions of COMPUTE-TTY-CHANGES and
-;;; TTY-SMART-WINDOW-REDISPLAY.  When something went wrong with on
-
-(in-package 'ed)
-
-
-(proclaim '(special hemlock-internals::*debugging-tty-redisplay*
-		    hemlock-internals::*testing-delete-queue*
-		    hemlock-internals::*testing-insert-queue*
-		    hemlock-internals::*testing-moved*
-		    hemlock-internals::*testing-writes*))
-
-
-(defcommand "Setup Tty Buffer" (p)
-  "Clear buffer and insert numbering strings 0..19."
-  "Clear buffer and insert numbering strings 0..19."
-  (declare (ignore p))
-  (delete-region (buffer-region (current-buffer)))
-  (let ((point (current-point)))
-    (dotimes (i 20)
-      (insert-string point (prin1-to-string i))
-      (insert-character point #\newline))
-    (buffer-start point)))
-
-(defcommand "Setup for Debugging" (p)
-  "Set *debugging-tty-redisplay* to t, and some other stuff to nil."
-  "Set *debugging-tty-redisplay* to t, and some other stuff to nil."
-  (declare (ignore p))
-  (setf hi::*debugging-tty-redisplay* t)
-  (setf hi::*testing-delete-queue* nil)
-  (setf hi::*testing-insert-queue* nil)
-  (setf hi::*testing-moved* nil)
-  (setf hi::*testing-writes* nil))
-
-(defcommand "Cleanup for Debugging" (p)
-  "Set *debugging-tty-redisplay* to nil."
-  "Set *debugging-tty-redisplay* to nil."
-  (declare (ignore p))
-  (setf hi::*debugging-tty-redisplay* nil))
-
-;;; Given "Setup Tty Buffer", deletes lines numbered 3, 4, 5, 10, 11, 12,
-;;; 13, and 14.  With argument, 3..7 and 12..14.
-;;; 
-(defcommand "Two Deletes" (p)
-  "At line 3, delete 3 lines.  At line 3+4, delete 5 lines.
-   With an argument, switch the number deleted."
-  "At line 3, delete 3 lines.  At line 3+4, delete 5 lines.
-   With an argument, switch the number deleted."
-  (multiple-value-bind (dnum1 dnum2)
-		       (if p (values 5 3) (values 3 5))
-    (let ((point (current-point)))
-      (move-mark point (window-display-start (current-window)))
-      (line-offset point 3)
-      (with-mark ((end point :left-inserting))
-	(line-offset end dnum1)
-	(delete-region (region point end))
- 	(line-offset point 4)
-	(line-offset (move-mark end point) dnum2)
-	(delete-region (region point end))))))
-
-
-;;; Given "Setup Tty Buffer", opens two blank lines between 2 and 3, and
-;;; opens four blank lines between 6 and 7, leaving line numbered 13 at
-;;; the bottom.  With argument, four lines between 2 and 3, two lines
-;;; between 6 and 7, and line 13 at the bottom of the window.
-;;; 
-(defcommand "Two Inserts" (p)
-  "At line 3, open 2 lines.  At line 3+2+4, open 4 lines.
-   With an argument, switch the number opened."
-  "At line 3, open 2 lines.  At line 3+2+4, open 4 lines.
-   With an argument, switch the number opened."
-  (multiple-value-bind (onum1 onum2)
-		       (if p (values 4 2) (values 2 4))
-    (let ((point (current-point)))
-      (move-mark point (window-display-start (current-window)))
-      (line-offset point 3)
-      (dotimes (i onum1)
-	(insert-character point #\newline))
-      (line-offset point 4)
-      (dotimes (i onum2)
-	(insert-character point #\newline)))))
-
-
-;;; Given "Setup Tty Buffer", deletes lines numbered 3, 4, and 5, and
-;;; opens five lines between lines numbered 9 and 10, leaving line numbered
-;;; 17 on the bottom.  With an argument, deletes lines numbered 3, 4, 5, 6,
-;;; and 7, and opens three lines between 11 and 12, creating two blank lines
-;;; at the end of the screen.
-;;; 
-(defcommand "One Delete One Insert" (p)
-  "At line 3, delete 3 lines.  At line 3+4, open 5 lines.
-   With an argument, switch the number of lines affected."
-  "At line 3, delete 3 lines.  At line 3+4, open 5 lines.
-   With an argument, switch the number of lines affected."
-  (multiple-value-bind (dnum onum)
-		       (if p (values 5 3) (values 3 5))
-    (let ((point (current-point)))
-      (move-mark point (window-display-start (current-window)))
-      (line-offset point 3)
-      (with-mark ((end point :left-inserting))
-	(line-offset end dnum)
-	(delete-region (region point end))
- 	(line-offset point 4)
-	(dotimes (i onum)
-	  (insert-character point #\newline))))))
-
-;;; Given "Setup Tty Buffer", opens three blank lines between lines numbered
-;;; 2 and 3, and deletes lines numbered 7, 8, 9, 10, and 11, leaving two
-;;; blank lines at the bottom of the window.  With an argument, opens five
-;;; blank lines between lines numbered 2 and 3, and deletes lines 7, 8, and
-;;; 9, leaving line 17 at the bottom of the window.
-;;; 
-(defcommand "One Insert One Delete" (p)
-  "At line 3, open 3 lines.  At line 3+3+4, delete 5 lines.
-   With an argument, switch the number of lines affected."
-  "At line 3, open 3 lines.  At line 3+3+4, delete 5 lines.
-   With an argument, switch the number of lines affected."
-  (multiple-value-bind (onum dnum)
-		       (if p (values 5 3) (values 3 5))
-    (let ((point (current-point)))
-      (move-mark point (window-display-start (current-window)))
-      (line-offset point 3)
-      (dotimes (i onum)
-	(insert-character point #\newline))
-      (line-offset point 4)
-      (with-mark ((end point :left-inserting))
-	(line-offset end dnum)
-	(delete-region (region point end))))))
-
-
-;;; This could be thrown away, but I'll leave it here.  When I was testing
-;;; the problem of generating EQ screen image lines due to faulty
-;;; COMPUTE-TTY-CHANGES, this was a convenient command to get the editor
-;;; back under control.
-;;; 
-(defcommand "Fix Screen Image Lines" (p)
-  ""
-  ""
-  (declare (ignore p))
-  (let* ((device (hi::device-hunk-device (hi::window-hunk (current-window))))
-	 (lines (hi::tty-device-lines device))
-	 (columns (hi::tty-device-columns device))
-	 (screen-image (hi::tty-device-screen-image device)))
-    (dotimes (i lines)
-      (setf (svref screen-image i) (hi::make-si-line columns)))))
diff --git a/hemlock/edit-defs.lisp b/hemlock/edit-defs.lisp
deleted file mode 100644
index d2f3f6947c038851dd8adb5707d5ace1968bf3cb..0000000000000000000000000000000000000000
--- a/hemlock/edit-defs.lisp
+++ /dev/null
@@ -1,312 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/edit-defs.lisp,v 1.4 1991/12/18 22:36:30 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Editing DEFMACRO and DEFUN definitions.  Also, has directory translation
-;;; code for moved and/or different sources.
-;;;
-
-(in-package 'hemlock)
-
-
-;;; Directory translation for definition editing commands.
-
-(defvar *definition-directory-translation-table*
-  (make-string-table)
-  "Hemlock string table for translating directory namestrings to other ones, so
-   a function defined in /x/y/z/.../file.ext will actually be looked for in
-   /whatever/.../file.ext.")
-
-(defun add-definition-dir-translation (dir1 dir2)
-  "Takes two directory namestrings and causes the first to be mapped to
-   the second.  This is used in commands like \"Edit Definition\".
-   Successive uses of this push into a list of translations that will
-   be tried in order of traversing the list."
-  (push (pathname dir2)
-	(getstring (directory-namestring dir1)
-		   *definition-directory-translation-table*)))
-
-(defun delete-definition-dir-translation (directory)
-  "Deletes the mapping of directory to all other directories for definition
-   editing commands."
-  (delete-string (directory-namestring directory)
-		 *definition-directory-translation-table*))
-
-
-(defcommand "Add Definition Directory Translation" (p)
-  "Prompts for two directory namestrings and causes the first to be mapped to
-   the second for definition editing commands.  Longer (more specific) directory
-   specifications are match before shorter (more general) ones.  Successive
-   uses of this push into a list of translations that will be tried in order
-   of traversing the list."
-  "Prompts for two directory namestrings and causes the first to be mapped to
-   the second for definition editing commands."
-  (declare (ignore p))
-  (let* ((dir1 (prompt-for-file :prompt "Preimage dir1: "
-				:help "directory namestring."
-				:must-exist nil))
-	 (dir2 (prompt-for-file :prompt "Postimage dir2: "
-				:help "directory namestring."
-				:must-exist nil)))
-    (add-definition-dir-translation dir1 dir2)))
-
-(defcommand "Delete Definition Directory Translation" (p)
-  "Prompts for a directory namestring and deletes it from the directory
-   translation table for the definition editing commands."
-  "Prompts for a directory namestring and deletes it from the directory
-   translation table for the definition editing commands."
-  (declare (ignore p))
-  (delete-definition-dir-translation
-   (prompt-for-file :prompt "Directory: "
-		    :help "directory namestring."
-		    :must-exist nil)))
-
-
-
-;;; Definition Editing Commands.
-
-;;; These commands use a slave Lisp to determine the file the function is
-;;; defined in.  They do a synchronous evaluation of DEFIITION-EDITING-INFO.
-;;; Then, in the editor Lisp, GO-TO-DEFINITION possibly translates the file
-;;; name, finds the file, and tries to search for the defining form.
-
-
-;;; For the "Go to Definition" search pattern, we just use " " as the initial
-;;; pattern, so we can make a search pattern.  Invocation of the command alters
-;;; the search pattern.
-
-(defvar *go-to-def-pattern*
-  (new-search-pattern :string-insensitive :forward " "))
-
-(defvar *last-go-to-def-string* "")
-(proclaim '(simple-string *last-go-to-def-string*))
-  
-;;; GET-DEFINITION-PATTERN takes a type and a name.  It returns a search
-;;; pattern for finding the defining form for name using
-;;; *go-to-def-pattern* and *last-go-to-def-string* destructively.  The
-;;; pattern contains a trailing space to avoid finding functions earlier
-;;; in the file with the function's name as a prefix.  This is not necessary
-;;; with type :command since the name is terminated with a ".
-;;; 
-(defun get-definition-pattern (type name)
-  (declare (simple-string name))
-  (let ((string (case type
-		  ((:function :unknown-function)
-		   (concatenate 'simple-string "(defun " name " "))
-		  ((:macro :unknown-macro)
-		   (concatenate 'simple-string "(defmacro " name " "))
-		  (:command
-		   (concatenate 'simple-string
-				"(defcommand \""
-				(nsubstitute #\space #\-
-					     (subseq name 0 (- (length name) 8))
-					     :test #'char=)
-				"\"")))))
-    (declare (simple-string string))
-    (cond ((string= string *last-go-to-def-string*)
-	   *go-to-def-pattern*)
-	  (t (setf *last-go-to-def-string* string)
-	     (new-search-pattern :string-insensitive :forward
-				 string *go-to-def-pattern*)))))
-
-(defhvar "Editor Definition Info"
-  "When this is non-nil, the editor Lisp is used to determine definition
-   editing information; otherwise, the slave Lisp is used."
-  :value nil)
-
-(defcommand "Goto Definition" (p)
-  "Go to the current function/macro's definition.  If it isn't defined by a
-   DEFUN or DEFMACRO form, then the defining file is simply found.  If the
-   function is not compiled, then it is looked for in the current buffer."
-  "Go to the current function/macro's definition."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((mark1 point)
-		(mark2 point))
-      (unless (backward-up-list mark1) (editor-error))
-      (form-offset (move-mark mark2 (mark-after mark1)) 1)
-      (let ((fun-name (region-to-string (region mark1 mark2))))
-	(get-def-info-and-go-to-it fun-name)))))
-
-(defcommand "Edit Definition" (p)
-  "Prompts for function/macro's definition name and goes to it for editing."
-  "Prompts for function/macro's definition name and goes to it for editing."
-  (declare (ignore p))
-  (let ((fun-name (prompt-for-string
-		   :prompt "Name: "
-		   :help "Symbol name of function.")))
-    (get-def-info-and-go-to-it fun-name)))
-
-(defun get-def-info-and-go-to-it (fun-name)
-  (let ((in-editor-p (value editor-definition-info))
-	(info (value current-eval-server)))
-    (if (or in-editor-p
-	    (not info))
-	(multiple-value-bind (pathname type name)
-			     (in-lisp
-			      (definition-editing-info fun-name))
-	  (unless in-editor-p
-	    (message "Editing definition from editor Lisp ..."))
-	  (go-to-definition pathname type name))
-	(let ((results (eval-form-in-server
-			info
-			(format nil "(ed::definition-editing-info ~S)"
-				fun-name))))
-	  (go-to-definition (read-from-string (first results)) ;file
-			    (read-from-string (second results)) ;type
-			    (read-from-string (third results))))))) ;name
-
-;;; "Edit Command Definition" is a hack due to creeping evolution in
-;;; GO-TO-DEFINITION.  We specify :function type and a name with "-COMMAND"
-;;; instead of :command type and the real command name because this causes
-;;; the right pattern to be created for searching.  We could either specify
-;;; that you always edit command definitions with this command (breaking
-;;; "Go to Definition" for commands called as functions), fixing the code,
-;;; or we can hack this command so everything works.
-;;;
-(defcommand "Edit Command Definition" (p)
-  "Prompts for command definition name and goes to it for editing."
-  "Prompts for command definition name and goes to it for editing."
-  (multiple-value-bind
-      (name command)
-      (if p
-	  (multiple-value-bind (key cmd)
-			       (prompt-for-key :prompt "Edit command bound to: ")
-	    (declare (ignore key))
-	    (values (command-name cmd) cmd))
-	  (prompt-for-keyword (list *command-names*)
-			      :prompt "Command to edit: "))
-    (go-to-definition (fun-defined-from-pathname (command-function command))
-		      :function
-		      (concatenate 'simple-string name "-COMMAND"))))
-
-;;; GO-TO-DEFINITION tries to find name in file with a search pattern based
-;;; on type (defun or defmacro).  File may be translated to another source
-;;; file, and if type is a function that cannot be found, we try to find a
-;;; command by an appropriate name.
-;;; 
-(defun go-to-definition (file type name)
-  (let ((pattern (get-definition-pattern type name)))
-    (cond
-     (file
-      (setf file (go-to-definition-file file))
-      (let* ((buffer (find-file-command nil file))
-	     (point (buffer-point buffer))
-	     (name-len (length name)))
-	(declare (fixnum name-len))
-	(with-mark ((def-mark point))
-	  (buffer-start def-mark)
-	  (unless (find-pattern def-mark pattern)
-	    (if (and (or (eq type :function) (eq type :unknown-function))
-		     (> name-len 7)
-		     (string= name "COMMAND" :start1 (- name-len 7)))
-		(let ((prev-search-str *last-go-to-def-string*))
-		  (unless (find-pattern def-mark
-					(get-definition-pattern :command name))
-		    (editor-error "~A is not defined with ~S or ~S, ~
-				   but this is the defined-in file."
-				  (string-upcase name) prev-search-str
-				  *last-go-to-def-string*)))
-		(editor-error "~A is not defined with ~S, ~
-			       but this is the defined-in file."
-			      (string-upcase name) *last-go-to-def-string*)))
-	  (if (eq buffer (current-buffer))
-	      (push-buffer-mark (copy-mark point)))
-	  (move-mark point def-mark))))
-     (t
-      (when (or (eq type :unknown-function) (eq type :unknown-macro))
-	(with-mark ((m (buffer-start-mark (current-buffer))))
-	  (unless (find-pattern m pattern)
-	    (editor-error
-	     "~A is not compiled and not defined in current buffer with ~S"
-	     (string-upcase name) *last-go-to-def-string*))
-	  (let ((point (current-point)))
-	    (push-buffer-mark (copy-mark point))
-	    (move-mark point m))))))))
-
-;;; GO-TO-DEFINITION-FILE takes a pathname and translates it to another
-;;; according to "Add Definition Directory Translation".  Take the first
-;;; probe-able translation, or probe file if no translations are found.
-;;; If no existing file is found, an editor error is signaled.
-;;; 
-(defun go-to-definition-file (file)
-  (multiple-value-bind (unmatched-dir new-dirs file-name)
-		       (maybe-translate-definition-file file)
-    (loop
-      (when (null new-dirs)
-	(unless (probe-file file)
-	  (if unmatched-dir
-	      (editor-error "Cannot find file ~S or any of its translations."
-			    file)
-	      (editor-error "Cannot find file ~S." file)))
-	(return file))
-      (let ((f (translate-definition-file unmatched-dir (pop new-dirs)
-					  file-name)))
-	(when (probe-file f)
-	  (setf file f)
-	  (return f))))))
-
-;;; MAYBE-TRANSLATE-DEFINITION-FILE tries each directory subsequence from
-;;; the most specific to the least looking a user defined translation.
-;;; This returns the portion of the input directory sequence that was not
-;;; matched (to be merged with the mapping of the matched portion), the
-;;; list of post image directories, and the file name.
-;;; 
-(defun maybe-translate-definition-file (file)
-  (let* ((pathname (pathname file))
-	 (maybe-truename (or (probe-file pathname) pathname))
-	 (dirs (pathname-directory maybe-truename))
-	 (len (length dirs))
-	 (i len))
-    (declare (fixnum len i))
-    (loop
-      (when (<= i 1) (return nil))
-      (let ((new-dirs (getstring (directory-namestring
-				 (make-pathname :defaults "/"
-						:directory (subseq dirs 0 i)))
-				*definition-directory-translation-table*)))
-	(when new-dirs
-	  (return (values (subseq dirs i len) new-dirs
-			  (file-namestring maybe-truename)))))
-      (decf i))))
-
-;;; TRANSLATE-DEFINITION-FILE creates a directory sequence from unmatched-dir
-;;; and new-dir, creating a translated pathname for GO-TO-DEFINITION.
-;;; 
-(defun translate-definition-file (unmatched-dir new-dir file-name)
-  (make-pathname :defaults "/"
-		 :directory (append (pathname-directory new-dir)
-				    unmatched-dir)
-		 :name file-name))
-
-
-;;; DEFINITION-EDITING-INFO runs in a slave Lisp and returns the pathname
-;;; that the global definition of the symbol whose name is string is defined
-;;; in.
-;;; 
-(defun definition-editing-info (string)
-  (let ((symbol (read-from-string string)))
-    (check-type symbol symbol)
-    (let ((macro (macro-function symbol))
-	  (name (symbol-name symbol)))
-      (if macro
-	  (let ((file (fun-defined-from-pathname macro)))
-	    (if file
-		(values file :macro name)
-		(values nil :unknown-macro name)))
-	  (if (fboundp symbol)
-	      (let ((file (fun-defined-from-pathname symbol)))
-		(if file
-		    (values file :function name)
-		    (values nil :unknown-function name)))
-	      (error "~S is not a function." symbol))))))
diff --git a/hemlock/eval-server.lisp b/hemlock/eval-server.lisp
deleted file mode 100644
index 7231ebbdec8bc903d48a7e3820480d5140fa7db2..0000000000000000000000000000000000000000
--- a/hemlock/eval-server.lisp
+++ /dev/null
@@ -1,1033 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/eval-server.lisp,v 1.1.1.13 1992/02/15 01:05:57 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains code for connecting to eval servers and some command
-;;; level stuff too.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "HEMLOCK")
-
-
-
-;;;; Structures.
-
-(defstruct (server-info (:print-function print-server-info))
-  name			      ; String name of this server.
-  wire			      ; Wire connected to this server.
-  notes			      ; List of note objects for operations
-			      ;  which have not yet completed.
-  slave-info		      ; Ts-Info used in "Slave Lisp" buffer
-			      ;  (formerly the "Lisp Listener" buffer).
-  slave-buffer		      ; "Slave Lisp" buffer for slave's *terminal-io*.
-  background-info	      ; Ts-Info structure of typescript we use in
-			      ;  "background" buffer.
-  background-buffer	      ; Buffer "background" typescript is in.
-  (errors		      ; Array of errors while compiling
-   (make-array 16 :adjustable t :fill-pointer 0))
-  error-index)		      ; Index of current error.
-;;;
-(defun print-server-info (obj stream n)
-  (declare (ignore n))
-  (format stream "#<Server-info for ~A>" (server-info-name obj)))
-
-
-(defstruct (error-info (:print-function print-error-info))
-  buffer		      ; Buffer this error is for.
-  message		      ; Error Message
-  line			      ; Pointer to message in log buffer.
-  region)		      ; Region of faulty text
-;;;
-(defun print-error-info (obj stream n)
-  (declare (ignore n))
-  (format stream "#<Error: ~A>" (error-info-message obj)))
-
-
-(defvar *server-names* (make-string-table)
-  "A string-table of the name of all Eval servers and their corresponding
-   server-info structures.")
-
-(defvar *abort-operations* nil
-  "T iff we should ignore any operations sent to us.")
-
-(defvar *inside-operation* nil
-  "T iff we are currenly working on an operation. A catcher for the tag 
-   abort-operation will be established whenever this is T.")
-
-(defconstant *slave-connect-wait* 300)
-
-;;; Used internally for communications.
-;;;
-(defvar *newly-created-slave* nil)
-(defvar *compiler-wire* nil)
-(defvar *compiler-error-stream* nil)
-(defvar *compiler-note* nil)
-
-
-
-;;;; Hemlock Variables
-
-(defhvar "Current Eval Server"
-  "The Server-Info object for the server currently used for evaluation and
-   compilation."
-  :value nil)
-
-(defhvar "Current Compile Server"
-  "The Server-Info object for the server currently used for compilation
-   requests."
-  :value nil)
-
-(defhvar "Current Package"
-  "This variable holds the name of the package currently used for Lisp
-   evaluation and compilation.  If it is Nil, the value of *Package* is used
-   instead."
-  :value nil)
-
-(defhvar "Slave Utility"
-  "This is the pathname of the utility to fire up slave Lisps.  It defaults
-   to \"lisp\"."
-  :value "lisp")
-
-(defhvar "Slave Utility Switches"
-  "These are additional switches to pass to the Slave Utility.
-   For example, (list \"-core\" <core-file-name>).  The -slave
-   switch and the editor name are always supplied, and they should
-   not be present in this variable."
-  :value nil)
-
-(defhvar "Ask About Old Servers"
-  "When set (the default), Hemlock will prompt for an existing server's name
-   in preference to prompting for a new slave's name and creating it."
-  :value t)
-
-(defhvar "Confirm Slave Creation"
-  "When set (the default), Hemlock always confirms a slave's creation for
-   whatever reason."
-  :value t)
-
-
-(defhvar "Slave GC Alarm"
-  "Determines that is done when the slave notifies that it is GCing.
-  :MESSAGE prints a message in the echo area, :LOUD-MESSAGE beeps as well.
-  NIL does nothing."
-  :value :message)
-
-
-;;;; Slave destruction.
-
-;;; WIRE-DIED -- Internal.
-;;;
-;;; The routine is called whenever a wire dies.  We roll through all the
-;;; servers looking for any that use this wire and nuke them with server-died.
-;;;
-(defun wire-died (wire)
-  (let ((servers nil))
-    (do-strings (name info *server-names*)
-      (declare (ignore name))
-      (when (eq wire (server-info-wire info))
-	(push info servers)))
-    (dolist (server servers)
-      (server-died server))))
-
-;;; SERVER-DIED -- Internal.
-;;;
-;;; Clean up the server. Remove any references to it from variables, etc.
-;;;
-(defun server-died (server)
-  (let ((name (server-info-name server)))
-    (delete-string name *server-names*)
-    (message "Server ~A just died." name))
-  (when (server-info-wire server)
-    (let ((fd (wire:wire-fd (server-info-wire server))))
-      (system:invalidate-descriptor fd)
-      (unix:unix-close fd))
-    (setf (server-info-wire server) nil))
-  (when (server-info-slave-info server)
-    (ts-buffer-wire-died (server-info-slave-info server))
-    (setf (server-info-slave-info server) nil))
-  (when (server-info-background-info server)
-    (ts-buffer-wire-died (server-info-background-info server))
-    (setf (server-info-background-info server) nil))
-  (clear-server-errors server)
-  (when (eq server (variable-value 'current-eval-server :global))
-    (setf (variable-value 'current-eval-server :global) nil))
-  (when (eq server (variable-value 'current-compile-server :global))
-    (setf (variable-value 'current-compile-server :global) nil))
-  (dolist (buffer *buffer-list*)
-    (dolist (var '(current-eval-server current-compile-server server-info))
-      (when (and (hemlock-bound-p var :buffer buffer)
-		 (eq (variable-value var :buffer buffer) server))
-	(delete-variable var :buffer buffer))))
-  (setf *breakpoints* (delete-if #'(lambda (b)
-				     (eq (breakpoint-info-slave b) server))
-				 *breakpoints*)))
-
-;;; SERVER-CLEANUP -- Internal.
-;;;
-;;; This routine is called as a buffer delete hook.  It takes care of any
-;;; per-buffer cleanup that is necessary.  It clears out all references to the
-;;; buffer from server-info structures and that any errors that refer to this
-;;; buffer are finalized.
-;;;
-(defun server-cleanup (buffer)
-  (let ((info (if (hemlock-bound-p 'server-info :buffer buffer)
-		  (variable-value 'server-info :buffer buffer))))
-    (when info
-      (when (eq buffer (server-info-slave-buffer info))
-	(setf (server-info-slave-buffer info) nil)
-	(setf (server-info-slave-info info) nil))
-      (when (eq buffer (server-info-background-buffer info))
-	(setf (server-info-background-buffer info) nil)
-	(setf (server-info-background-info info) nil))))
-  (do-strings (string server *server-names*)
-    (declare (ignore string))
-    (clear-server-errors server
-			 #'(lambda (error)
-			     (eq (error-info-buffer error) buffer)))))
-;;;
-(add-hook delete-buffer-hook 'server-cleanup)
-
-;;; CLEAR-SERVER-ERRORS -- Public.
-;;;
-;;; Clears all known errors for the given server and resets it so more can
-;;; accumulate.
-;;;
-(defun clear-server-errors (server &optional test-fn)
-  "This clears compiler errors for server cleaning up any pointers for GC
-   purposes and allowing more errors to register."
-  (let ((array (server-info-errors server))
-	(current nil))
-    (dotimes (i (fill-pointer array))
-      (let ((error (aref array i)))
-	(when (or (null test-fn)
-		  (funcall test-fn error))
-	  (let ((region (error-info-region error)))
-	    (when (regionp region)
-	      (delete-mark (region-start region))
-	      (delete-mark (region-end region))))
-	  (setf (aref array i) nil))))
-    (let ((index (server-info-error-index server)))
-      (when index
-	(setf current
-	      (or (aref array index)
-		  (find-if-not #'null array
-			       :from-end t
-			       :end current)))))
-    (delete nil array)
-    (setf (server-info-error-index server)
-	  (position current array))))
-
-
-
-;;;; Slave creation.
-
-;;; INITIALIZE-SERVER-STUFF -- Internal.
-;;;
-;;; Reinitialize stuff when a core file is saved.
-;;;
-(defun initialize-server-stuff ()
-  (clrstring *server-names*))
-
-
-(defvar *editor-name* nil "Name of this editor.")
-(defvar *accept-connections* nil
-  "When set, allow slaves to connect to the editor.")
-
-;;; GET-EDITOR-NAME -- Internal.
-;;;
-;;; Pick a name for the editor.  Names consist of machine-name:port-number.  If
-;;; in ten tries we can't get an unused port, choak.  We don't save the result
-;;; of WIRE:CREATE-REQUEST-SERVER because we don't think the editor needs to
-;;; ever kill the request server, and we can always inhibit connection with
-;;; "Accept Connections".
-;;;
-(defun get-editor-name ()
-  (if *editor-name*
-      *editor-name*
-      (let ((random-state (make-random-state t)))
-	(dotimes (tries 10 (error "Could not create an internet listener."))
-	  (let ((port (+ 2000 (random 10000 random-state))))
-	    (when (handler-case (wire:create-request-server
-				 port
-				 #'(lambda (wire addr)
-				     (declare (ignore addr))
-				     (values *accept-connections*
-					     #'(lambda () (wire-died wire)))))
-		    (error () nil))
-	      (return (setf *editor-name*
-			    (format nil "~A:~D" (machine-instance) port)))))))))
-
-
-;;; MAKE-BUFFERS-FOR-TYPESCRIPT -- Internal.
-;;;
-;;; This function returns no values because it is called remotely for value by
-;;; connecting slaves.  Though we know the system will propagate nil back to
-;;; the slave, we indicate here that nil is meaningless.
-;;;
-(defun make-buffers-for-typescript (slave-name background-name)
-  "Make the interactive and background buffers slave-name and background-name.
-   If either is nil, then prompt the user."
-  (multiple-value-bind (slave-name background-name)
-		       (cond ((not (and slave-name background-name))
-			      (pick-slave-buffer-names))
-			     ((getstring slave-name *server-names*)
-			      (multiple-value-bind
-				  (new-sn new-bn)
-				  (pick-slave-buffer-names)
-				(message "~S is already an eval server; ~
-					  using ~S instead."
-					 slave-name new-sn)
-				(values new-sn new-bn)))
-			     (t (values slave-name background-name)))
-    (let* ((slave-buffer (or (getstring slave-name *buffer-names*)
-			     (make-buffer slave-name :modes '("Lisp"))))
-	   (background-buffer (or (getstring background-name *buffer-names*)
-				  (make-buffer background-name
-					       :modes '("Lisp"))))
-	   (server-info (make-server-info :name slave-name
-					  :wire wire:*current-wire*
-					  :slave-buffer slave-buffer
-					  :background-buffer background-buffer))
-	   (slave-info (typescriptify-buffer slave-buffer server-info
-					     wire:*current-wire*))
-	   (background-info (typescriptify-buffer background-buffer server-info
-						  wire:*current-wire*)))
-      (setf (server-info-slave-info server-info) slave-info)
-      (setf (server-info-background-info server-info) background-info)
-      (setf (getstring slave-name *server-names*) server-info)
-      (unless (variable-value 'current-eval-server :global)
-	(setf (variable-value 'current-eval-server :global) server-info))
-      (wire:remote-value
-       wire:*current-wire*
-       (made-buffers-for-typescript (wire:make-remote-object slave-info)
-				    (wire:make-remote-object background-info)))
-      (setf *newly-created-slave* server-info)
-      (values))))
-
-
-;;; CREATE-SLAVE -- Public.
-;;;
-(defun create-slave (&optional name)
-  "This creates a slave that tries to connect to the editor.  When the slave
-   connects to the editor, this returns a slave-information structure.  Name is
-   the name of the interactive buffer.  If name is nil, this generates a name.
-   If name is supplied, and a buffer with that name already exists, this
-   signals an error.  In case the slave never connects, this will eventually
-   timeout and signal an editor-error."
-  (when (and name (getstring name *buffer-names*))
-    (editor-error "Buffer ~A is already in use." name))
-  (multiple-value-bind (slave background)
-		       (if name
-			   (values name (format nil "Background ~A" name))
-			   (pick-slave-buffer-names))
-    (when (value confirm-slave-creation)
-       (setf slave (prompt-for-string
-		    :prompt "New slave name? "
-		    :help "Enter the name to use for the newly created slave."
-		    :default slave
-		    :default-string slave))
-       (setf background (format nil "Background ~A" slave))
-       (when (getstring slave *buffer-names*)
-	 (editor-error "Buffer ~A is already in use." slave))
-       (when (getstring background *buffer-names*)
-	 (editor-error "Buffer ~A is already in use." background)))
-    (message "Spawning slave ... ")
-    (let ((proc
-	   (ext:run-program (value slave-utility)
-			    `("-slave" ,(get-editor-name)
-			      ,@(if slave (list "-slave-buffer" slave))
-			      ,@(if background
-				    (list "-background-buffer" background))
-			      ,@(value slave-utility-switches))
-			    :wait nil
-			    :output "/dev/null"
-			    :if-output-exists :append))
-	  (*accept-connections* t)
-	  (*newly-created-slave* nil))
-      (unless proc
-	(editor-error "Could not start slave."))
-      (dotimes (i *slave-connect-wait*
-		  (editor-error "Client Lisp is still unconnected.  ~
-				 You must use \"Accept Slave Connections\" to ~
-				 allow the slave to connect at this point."))
-	(system:serve-event 1)
-	(case (ext:process-status proc)
-	  (:exited
-	   (editor-error "The slave lisp exited before connecting."))
-	  (:signaled
-	   (editor-error "The slave lisp was kill before connecting.")))
-	(when *newly-created-slave*
-	  (message "DONE")
-	  (return *newly-created-slave*))))))
-
-;;; MAYBE-CREATE-SERVER -- Internal interface.
-;;;
-(defun maybe-create-server ()
-  "If there is an existing server and \"Ask about Old Servers\" is set, then
-   prompt for a server's name and return that server's info.  Otherwise,
-   create a new server."
-  (if (value ask-about-old-servers)
-      (multiple-value-bind (first-server-name first-server-info)
-			   (do-strings (name info *server-names*)
-			     (return (values name info)))
-	(if first-server-info
-	    (multiple-value-bind
-		(name info)
-		(prompt-for-keyword (list *server-names*)
-				    :prompt "Existing server name: "
-				    :default first-server-name
-				    :default-string first-server-name
-				    :help
-				    "Enter the name of an existing eval server."
-				    :must-exist t)
-	      (declare (ignore name))
-	      (or info (create-slave)))
-	    (create-slave)))
-      (create-slave)))
-
-
-(defvar *next-slave-index* 0
-  "Number to use when creating the next slave.")
-
-;;; PICK-SLAVE-BUFFER-NAMES -- Internal.
-;;;
-;;; Return two unused names to use for the slave and background buffers.
-;;;
-(defun pick-slave-buffer-names ()
-  (loop
-    (let ((slave (format nil "Slave ~D" (incf *next-slave-index*)))
-	  (background (format nil "Background Slave ~D" *next-slave-index*)))
-      (unless (or (getstring slave *buffer-names*)
-		  (getstring background *buffer-names*))
-	(return (values slave background))))))
-
-
-
-;;;; Slave selection.
-
-;;; GET-CURRENT-EVAL-SERVER -- Public.
-;;;
-(defun get-current-eval-server (&optional errorp)
-  "Returns the server-info struct for the current eval server.  If there is
-   none, and errorp is non-nil, then signal an editor error.  If there is no
-   current server, and errorp is nil, then create one, prompting the user for
-   confirmation.  Also, set the current server to be the newly created one."
-  (let ((info (value current-eval-server)))
-    (cond (info)
-	  (errorp
-	   (editor-error "No current eval server."))
-	  (t
-	   (setf (value current-eval-server) (maybe-create-server))))))
-
-;;; GET-CURRENT-COMPILE-SERVER -- Public.
-;;;
-;;; If a current compile server is defined, return it, otherwise return the
-;;; current eval server using get-current-eval-server.
-;;;
-(defun get-current-compile-server (&optional errorp)
-  "Returns the server-info struct for the current compile server. If there is
-   no current compile server, return the current eval server."
-  (or (value current-compile-server)
-      (get-current-eval-server errorp)))
-
-
-
-;;;; Server Manipulation commands.
-
-(defcommand "Select Slave" (p)
-  "Switch to the current slave's buffer.  When given an argument, create a new
-   slave."
-  "Switch to the current slave's buffer.  When given an argument, create a new
-   slave."
-  (let* ((info (if p (create-slave) (get-current-eval-server)))
-	 (slave (server-info-slave-buffer info)))
-    (unless slave
-      (editor-error "The current eval server doesn't have a slave buffer!"))
-    (change-to-buffer slave)))
-
-(defcommand "Select Background" (p)
-  "Switch to the current slave's background buffer. When given an argument, use
-   the current compile server instead of the current eval server."
-  "Switch to the current slave's background buffer. When given an argument, use
-   the current compile server instead of the current eval server."
-  (let* ((info (if p
-		 (get-current-compile-server t)
-		 (get-current-eval-server t)))
-	 (background (server-info-background-buffer info)))
-    (unless background
-      (editor-error "The current ~A server doesn't have a background buffer!"
-		    (if p "compile" "eval")))
-    (change-to-buffer background)))
-
-(defcommand "Kill Slave" (p)
-  "This aborts any operations in the slave, tells the slave to QUIT, and shuts
-   down the connection to the specified eval server.  This makes no attempt to
-   assure the eval server actually dies."
-  "This aborts any operations in the slave, tells the slave to QUIT, and shuts
-   down the connection to the specified eval server.  This makes no attempt to
-   assure the eval server actually dies."
-  (declare (ignore p))
-  (let ((default (and (value current-eval-server)
-		      (server-info-name (value current-eval-server)))))
-    (multiple-value-bind
-	(name info)
-	(prompt-for-keyword
-	 (list *server-names*)
-	 :prompt "Kill Slave: "
-	 :help "Enter the name of the eval server you wish to destroy."
-	 :must-exist t
-	 :default default
-	 :default-string default)
-      (declare (ignore name))
-      (let ((wire (server-info-wire info)))
-	(when wire
-	  (ext:send-character-out-of-band (wire:wire-fd wire) #\N)
-	  (wire:remote wire (ext:quit))
-	  (wire:wire-force-output wire)))
-      (server-died info))))
-
-(defcommand "Kill Slave and Buffers" (p)
-  "This is the same as \"Kill Slave\", but it also deletes the slaves
-   interaction and background buffers."
-  "This is the same as \"Kill Slave\", but it also deletes the slaves
-   interaction and background buffers."
-  (declare (ignore p))
-  (let ((default (and (value current-eval-server)
-		      (server-info-name (value current-eval-server)))))
-    (multiple-value-bind
-	(name info)
-	(prompt-for-keyword
-	 (list *server-names*)
-	 :prompt "Kill Slave: "
-	 :help "Enter the name of the eval server you wish to destroy."
-	 :must-exist t
-	 :default default
-	 :default-string default)
-      (declare (ignore name))
-      (let ((wire (server-info-wire info)))
-	(when wire
-	  (ext:send-character-out-of-band (wire:wire-fd wire) #\N)
-	  (wire:remote wire (ext:quit))
-	  (wire:wire-force-output wire)))
-      (let ((buffer (server-info-slave-buffer info)))
-	(when buffer (delete-buffer-if-possible buffer)))
-      (let ((buffer (server-info-background-buffer info)))
-	(when buffer (delete-buffer-if-possible buffer)))
-      (server-died info))))
-
-(defcommand "Accept Slave Connections" (p)
-  "This causes Hemlock to accept slave connections and displays the port of
-   the editor's connections request server.  This is suitable for use with the
-   Lisp's -slave switch.  Given an argument, this inhibits slave connections."
-  "This causes Hemlock to accept slave connections and displays the port of
-   the editor's connections request server.  This is suitable for use with the
-   Lisp's -slave switch.  Given an argument, this inhibits slave connections."
-  (let ((accept (not p)))
-    (setf *accept-connections* accept)
-    (message "~:[Inhibiting~;Accepting~] connections to ~S"
-	     accept (get-editor-name))))
-
-
-
-;;;; Slave initialization junk.
-
-(defvar *original-beep-function* nil
-  "Handle on original beep function.")
-
-(defvar *original-gc-notify-before* nil
-  "Handle on original before-GC notification function.")
-
-(defvar *original-gc-notify-after* nil
-  "Handle on original after-GC notification function.")
-
-(defvar *original-terminal-io* nil
-  "Handle on original *terminal-io* so we can restore it.")
-
-(defvar *original-standard-input* nil
-  "Handle on original *standard-input* so we can restore it.")
-
-(defvar *original-standard-output* nil
-  "Handle on original *standard-output* so we can restore it.")
-
-(defvar *original-error-output* nil
-  "Handle on original *error-output* so we can restore it.")
-
-(defvar *original-debug-io* nil
-  "Handle on original *debug-io* so we can restore it.")
-
-(defvar *original-query-io* nil
-  "Handle on original *query-io* so we can restore it.")
-
-(defvar *original-trace-output* nil
-  "Handle on original *trace-output* so we can restore it.")
-
-(defvar *background-io* nil
-  "Stream connected to the editor's background buffer in case we want to use it
-  in the future.")
-
-;;; CONNECT-STREAM -- internal
-;;;
-;;; Run in the slave to create a new stream and connect it to the supplied
-;;; buffer.  Returns the stream.
-;;; 
-(defun connect-stream (remote-buffer)
-  (let ((stream (make-ts-stream wire:*current-wire* remote-buffer)))
-    (wire:remote wire:*current-wire*
-      (ts-buffer-set-stream remote-buffer
-			    (wire:make-remote-object stream)))
-    stream))
-
-;;; MADE-BUFFERS-FOR-TYPESCRIPT -- Internal Interface.
-;;;
-;;; Run in the slave by the editor with the two buffers' info structures,
-;;; actually remote-objects in the slave.  Does any necessary stream hacking.
-;;; Return nil to make sure no weird objects try to go back over the wire
-;;; since the editor calls this in the slave for value.  The editor does this
-;;; for synch'ing, not for values.
-;;;
-(defun made-buffers-for-typescript (slave-info background-info)
-  (macrolet ((frob (symbol new-value)
-	       `(setf ,(intern (concatenate 'simple-string
-					    "*ORIGINAL-"
-					    (subseq (string symbol) 1)))
-		      ,symbol
-		      ,symbol ,new-value)))
-    (let ((wire wire:*current-wire*))
-      (frob system:*beep-function*
-	    #'(lambda (&optional stream)
-		(declare (ignore stream))
-		(wire:remote-value wire (beep))))
-      (frob ext:*gc-notify-before*
-	    #'(lambda (bytes-in-use)
-		(wire:remote wire
-		  (slave-gc-notify-before
-		   slave-info
-		   (format nil
-			   "~%[GC threshold exceeded with ~:D bytes in use.  ~
-			   Commencing GC.]~%"
-			   bytes-in-use)))
-		(wire:wire-force-output wire)))
-      (frob ext:*gc-notify-after*
-	    #'(lambda (bytes-retained bytes-freed new-trigger)
-		(wire:remote wire
-		  (slave-gc-notify-after
-		   slave-info
-		   (format nil
-			   "[GC completed with ~:D bytes retained and ~:D ~
-			   bytes freed.]~%[GC will next occur when at least ~
-			   ~:D bytes are in use.]~%"
-			   bytes-retained bytes-freed new-trigger)))
-		(wire:wire-force-output wire))))
-    (frob *terminal-io* (connect-stream slave-info))
-    (frob *standard-input* (make-synonym-stream '*terminal-io*))
-    (frob *standard-output* *standard-input*)
-    (frob *error-output* *standard-input*)
-    (frob *debug-io* *standard-input*)
-    (frob *query-io* *standard-input*)
-    (frob *trace-output* *standard-input*))
-  (setf *background-io* (connect-stream background-info))
-  nil)
-
-;;; SLAVE-GC-NOTIFY-BEFORE and SLAVE-GC-NOTIFY-AFTER -- internal
-;;;
-;;; These two routines are run in the editor by the slave's gc notify routines.
-;;; 
-(defun slave-gc-notify-before (remote-ts message)
-  (let ((ts (wire:remote-object-value remote-ts)))
-    (ts-buffer-output-string ts message t)
-    (when (value slave-gc-alarm)
-      (message "~A is GC'ing." (buffer-name (ts-data-buffer ts)))
-      (when (eq (value slave-gc-alarm) :loud-message)
-	(beep)))))
-
-(defun slave-gc-notify-after (remote-ts message)
-  (let ((ts (wire:remote-object-value remote-ts)))
-    (ts-buffer-output-string ts message t)
-    (when (value slave-gc-alarm)
-      (message "~A is done GC'ing." (buffer-name (ts-data-buffer ts)))
-      (when (eq (value slave-gc-alarm) :loud-message)
-	(beep)))))
-
-;;; EDITOR-DIED -- internal
-;;;
-;;; Run in the slave when the editor goes belly up.
-;;; 
-(defun editor-died ()
-  (macrolet ((frob (symbol)
-	       (let ((orig (intern (concatenate 'simple-string
-						"*ORIGINAL-"
-						(subseq (string symbol) 1)))))
-		 `(when ,orig
-		    (setf ,symbol ,orig)))))
-    (frob system:*beep-function*)
-    (frob ext:*gc-notify-before*)
-    (frob ext:*gc-notify-after*)
-    (frob *terminal-io*)
-    (frob *standard-input*)
-    (frob *standard-output*)
-    (frob *error-output*)
-    (frob *debug-io*)
-    (frob *query-io*)
-    (frob *trace-output*))
-  (setf *background-io* nil)
-  (format t "~2&Connection to editor died.~%")
-  (ext:quit))
-
-;;; START-SLAVE -- internal
-;;;
-;;; Initiate the process by which a lisp becomes a slave.
-;;; 
-(defun start-slave (editor)
-  (declare (simple-string editor))
-  (let ((seperator (position #\: editor :test #'char=)))
-    (unless seperator
-      (error "Editor name ~S invalid. ~
-              Must be of the form \"MachineName:PortNumber\"."
-	     editor))
-    (let ((machine (subseq editor 0 seperator))
-	  (port (parse-integer editor :start (1+ seperator))))
-      (format t "Connecting to ~A:~D~%" machine port)
-      (connect-to-editor machine port))))
-
-
-;;; PRINT-SLAVE-STATUS  --  Internal
-;;;
-;;;    Print out some useful information about what the slave is up to.
-;;;
-(defun print-slave-status ()
-  (ignore-errors
-    (multiple-value-bind (sys user faults)
-			 (system:get-system-info)
-      (let* ((seconds (truncate (+ sys user) 1000000))
-	     (minutes (truncate seconds 60))
-	     (hours (truncate minutes 60))
-	     (days (truncate hours 24)))
-	(format *error-output* "~&; Used ~D:~2,'0D:~2,'0D~V@{!~}, "
-		hours (rem minutes 60) (rem seconds 60) days))
-      (format *error-output* "~D fault~:P.  In: " faults)
-	    
-      (do ((i 0 (1+ i))
-	   (frame (di:top-frame) (di:frame-down frame)))
-	  ((= i 3)
-	   (prin1 (di:debug-function-name (di:frame-debug-function frame))
-		  *error-output*))
-	(unless frame (return)))
-      (terpri *error-output*)
-      (force-output *error-output*)))
-  (values))
-
-
-;;; CONNECT-TO-EDITOR -- internal
-;;;
-;;; Do the actual connect to the editor.
-;;; 
-(defun connect-to-editor (machine port
-			  &optional
-			  (slave (find-eval-server-switch "slave-buffer"))
-			  (background (find-eval-server-switch
-				       "background-buffer")))
-  (let ((wire (wire:connect-to-remote-server machine port 'editor-died)))
-    (ext:add-oob-handler (wire:wire-fd wire)
-			  #\B
-			  #'(lambda ()
-			      (system:without-hemlock
-			       (system:with-interrupts
-				(break "Software Interrupt")))))
-    (ext:add-oob-handler (wire:wire-fd wire)
-			  #\T
-			  #'(lambda ()
-			      (when lisp::*in-top-level-catcher*
-				(throw 'lisp::top-level-catcher nil))))
-    (ext:add-oob-handler (wire:wire-fd wire)
-			  #\A
-			  #'abort)
-    (ext:add-oob-handler (wire:wire-fd wire)
-			  #\N
-			  #'(lambda ()
-			      (setf *abort-operations* t)
-			      (when *inside-operation*
-				(throw 'abort-operation
-				       (if debug::*in-the-debugger*
-					   :was-in-debugger)))))
-    (ext:add-oob-handler (wire:wire-fd wire) #\S #'print-slave-status)
-
-    (wire:remote-value wire
-      (make-buffers-for-typescript slave background))))
-
-
-;;;; Eval server evaluation functions.
-
-(defvar *eval-form-stream*
-  (make-two-way-stream
-   (lisp::make-stream
-    :in #'(lambda (&rest junk)
-	    (declare (ignore junk))
-	    (error "You cannot read when handling an eval_form request.")))
-   (make-broadcast-stream)))
-
-;;; SERVER-EVAL-FORM -- Public.
-;;;   Evaluates the given form (which is a string to be read from in the given
-;;; package) and returns the results as a list.
-;;;
-(defun server-eval-form (package form)
-  (declare (type (or string null) package) (simple-string form))
-  (handler-bind
-      ((error #'(lambda (condition)
-		  (wire:remote wire:*current-wire*
-			       (eval-form-error (format nil "~A~&" condition)))
-		  (return-from server-eval-form nil))))
-    (let ((*package* (if package
-			 (lisp::package-or-lose package)
-			 *package*))
-	  (*terminal-io* *eval-form-stream*))
-      (stringify-list (multiple-value-list (eval (read-from-string form)))))))
-
-
-;;; DO-OPERATION -- Internal.
-;;;   Checks to see if we are aborting operations. If not, do the operation
-;;; wrapping it with operation-started and operation-completed calls. Also
-;;; deals with setting up *terminal-io* and *package*.
-;;;
-(defmacro do-operation ((note package terminal-io) &body body)
-  `(let ((aborted t)
-	 (*terminal-io* (if ,terminal-io
-			  (wire:remote-object-value ,terminal-io)
-			  *terminal-io*))
-	 (*package* (maybe-make-package ,package)))
-     (unwind-protect
-	 (unless *abort-operations*
-	   (when (eq :was-in-debugger
-		     (catch 'abort-operation
-		       (let ((*inside-operation* t))
-			 (wire:remote wire:*current-wire*
-				      (operation-started ,note))
-			 (wire:wire-force-output wire:*current-wire*)
-			 ,@body
-			 (setf aborted nil))))
-	     (format t
-		     "~&[Operation aborted.  ~
-		      You are no longer in this instance of the debugger.]~%")))
-       (wire:remote wire:*current-wire*
-	 (operation-completed ,note aborted))
-       (wire:wire-force-output wire:*current-wire*))))
-
-
-;;; unique-thingie is a unique eof-value for READ'ing.  Its a parameter, so
-;;; we can reload the file.
-;;;
-(defparameter unique-thingie (gensym)
-  "Used as eof-value in reads to check for the end of a file.")
-
-;;; SERVER-EVAL-TEXT -- Public.
-;;;
-;;;   Evaluate all the forms read from text in the given package, and send the
-;;; results back.  The error handler bound does not handle any errors.  It
-;;; simply notifies the client that an error occurred and then returns.
-;;;
-(defun server-eval-text (note package text terminal-io)
-  (do-operation (note package terminal-io)
-    (with-input-from-string (stream text)
-      (let ((last-pos 0))
-	(handler-bind
-	    ((error
-	      #'(lambda (condition)
-		  (wire:remote wire:*current-wire*
-			       (lisp-error note last-pos
-					   (file-position stream)
-					   (format nil "~A~&" condition))))))
-	  (loop
-	    (let ((form (read stream nil unique-thingie)))
-	      (when (eq form unique-thingie)
-		(return nil))
-	      (let* ((values (stringify-list (multiple-value-list (eval form))))
-		     (pos (file-position stream)))
-		(wire:remote wire:*current-wire*
-		  (eval-text-result note last-pos pos values))
-		(setf last-pos pos)))))))))
-
-(defun stringify-list (list)
-  (mapcar #'prin1-to-string list))
-#|
-(defun stringify-list (list)
-  (mapcar #'(lambda (thing)
-	      (with-output-to-string (stream)
-		(write thing
-		       :stream stream :radix nil :base 10 :circle t
-		       :pretty nil :level nil :length nil :case :upcase
-		       :array t :gensym t)))
-	  list))
-|#
-
-
-;;;; Eval server compilation stuff.
-
-;;; DO-COMPILER-OPERATION -- Internal.
-;;;
-;;; Useful macro that does the operation with *compiler-note* and
-;;; *compiler-wire* bound.
-;;;
-(defmacro do-compiler-operation ((note package terminal-io error) &body body)
-  `(let ((*compiler-note* ,note)
-	 (*compiler-error-stream* ,error)
-	 (*compiler-wire* wire:*current-wire*)
-	 (c:*compiler-notification-function* #'compiler-note-in-editor))
-     (do-operation (*compiler-note* ,package ,terminal-io)
-		   (unwind-protect
-		       (handler-bind ((error #'compiler-error-handler))
-			 ,@body)
-		     (when *compiler-error-stream*
-		       (force-output *compiler-error-stream*))))))
-
-;;; COMPILER-NOTE-IN-EDITOR -- Internal.
-;;;
-;;; DO-COMPILER-OPERATION binds c:*compiler-notification-function* to this, so
-;;; interesting observations in the compilation can be propagated back to the
-;;; editor.  If there is a notification point defined, we send information
-;;; about the position and kind of error.  The actual error text is written out
-;;; using typescript operations.
-;;;
-;;; Start and End are the compiler's best guess at the file position where the
-;;; error occurred.  Function is some string describing where the error was.
-;;;
-(defun compiler-note-in-editor (severity function name pos)
-  (declare (ignore name))
-  (when *compiler-wire*
-    (force-output *compiler-error-stream*)
-    (wire:remote *compiler-wire*
-      (compiler-error *compiler-note* pos pos function severity)))
-    (wire:wire-force-output *compiler-wire*))
-
-
-;;; COMPILER-ERROR-HANDLER -- Internal.
-;;;
-;;;    The error handler function for the compiler interfaces.
-;;; DO-COMPILER-OPERATION binds this as an error handler while evaluating the
-;;; compilation form.
-;;;
-(defun compiler-error-handler (condition)
-  (declare (ignore condition))
-  (when *compiler-wire*
-    (wire:remote *compiler-wire*
-      (lisp-error *compiler-note* nil nil
-		  (format nil "~A~&" condition)))))
-
-
-;;; SERVER-COMPILE-TEXT -- Public.
-;;;
-;;;    Similar to server-eval-text, except that the stuff is compiled.
-;;;
-(defun server-compile-text (note package text defined-from
-			    terminal-io error-output)
-  (let ((error-output (if error-output
-			(wire:remote-object-value error-output))))
-    (do-compiler-operation (note package terminal-io error-output)
-      (with-input-from-string (input-stream text)
-	(terpri error-output)
-	(c::compile-from-stream input-stream
-				:error-stream error-output
-				:source-info defined-from)))))
-
-;;; SERVER-COMPILE-FILE -- Public.
-;;;
-;;;    Compiles the file sending error info back to the editor.
-;;;
-(defun server-compile-file (note package input output error trace
-			    load terminal background)
-  (macrolet ((frob (x)
-	       `(if (wire:remote-object-p ,x)
-		  (wire:remote-object-value ,x)
-		  ,x)))
-    (let ((error-stream (frob background)))
-      (do-compiler-operation (note package terminal error-stream)
-	(compile-file (frob input)
-		      :output-file (frob output)
-		      :error-file (frob error)
-		      :trace-file (frob trace)
-		      :load load
-		      :error-output error-stream)))))
-
-
-;;;; Other random eval server stuff.
-
-;;; MAYBE-MAKE-PACKAGE -- Internal.
-;;;
-;;; Returns a package for a name.  Creates it if it doesn't already exist.
-;;;
-(defun maybe-make-package (name)
-  (cond ((null name) *package*)
-	((find-package name))
-	(t
-	 (wire:remote-value (ts-stream-wire *terminal-io*)
-	   (ts-buffer-output-string
-	    (ts-stream-typescript *terminal-io*)
-	    (format nil "~&Creating package ~A.~%" name)
-	    t))
-	 (make-package name))))
-
-;;; SERVER-SET-PACKAGE -- Public.
-;;;
-;;;   Serves package setting requests.  It simply sets
-;;; *package* to an already existing package or newly created one.
-;;;
-(defun server-set-package (package)
-  (setf *package* (maybe-make-package package)))
-
-;;; SERVER-ACCEPT-OPERATIONS -- Public.
-;;;
-;;;   Start accepting operations again.
-;;;
-(defun server-accept-operations ()
-  (setf *abort-operations* nil))
-
-
-
-;;;; Command line switches.
-
-;;; FIND-EVAL-SERVER-SWITCH -- Internal.
-;;;
-;;; This is special to the switches supplied by CREATE-SLAVE and fetched by
-;;; CONNECT-EDITOR-SERVER, so we can use STRING=.
-;;;
-(defun find-eval-server-switch (string)
-  (let ((switch (find string ext:*command-line-switches*
-		      :test #'string=
-		      :key #'ext:cmd-switch-name)))
-    (if switch
-	(or (ext:cmd-switch-value switch)
-	    (car (ext:cmd-switch-words switch))))))
-
-
-(defun slave-switch-demon (switch)
-  (let ((editor (ext:cmd-switch-arg switch)))
-    (unless editor
-      (error "Editor to connect to unspecified."))
-    (start-slave editor)
-    (setf debug:*help-line-scroll-count* most-positive-fixnum)))
-;;;
-(defswitch "slave" 'slave-switch-demon)
-(defswitch "slave-buffer")
-(defswitch "background-buffer")
-
-
-(defun edit-switch-demon (switch)
-  (declare (ignore switch))
-#|  (let ((arg (or (ext:cmd-switch-value switch)
-		 (car (ext:cmd-switch-words switch)))))
-    (when (stringp arg) (setq *editor-name* arg)))|#
-  (let ((initp (not (ext:get-command-line-switch "noinit"))))
-    (if (stringp (car ext:*command-line-words*))
-	(ed (car ext:*command-line-words*) :init initp)
-	(ed nil :init initp))))
-;;;
-(defswitch "edit" 'edit-switch-demon)
diff --git a/hemlock/filecoms.lisp b/hemlock/filecoms.lisp
deleted file mode 100644
index 599a9b1eb178103af736e3a1e5ba28b18bb419c8..0000000000000000000000000000000000000000
--- a/hemlock/filecoms.lisp
+++ /dev/null
@@ -1,1058 +0,0 @@
-;;; -*- Package: Hemlock; Log: hemlock.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 contains file/buffer manipulating commands.
-;;;
-(in-package "HEMLOCK")
-
-
-
-;;;; PROCESS-FILE-OPTIONS.
-
-(defvar *mode-option-handlers* ()
-  "Do not modify this; use Define-File-Option instead.")
-
-(defvar *file-type-hooks* ()
-  "Do not modify this; use Define-File-Type-Hook instead.")  
-
-(defun trim-subseq (string start end)
-  (declare (simple-string string))
-  (string-trim '(#\Space #\Tab) (subseq string start end)))
-
-;;; PROCESS-FILE-OPTIONS checks the first line of buffer for the file options
-;;; indicator "-*-".  IF it finds this, then it enters a do-file-options block.
-;;; If any parsing errors occur while picking out options, we return from this
-;;; block.  Staying inside this function at this point, allows us to still set
-;;; a major mode if no file option specified one.
-;;;
-;;; We also cater to old style mode comments:
-;;;    -*- Lisp -*-
-;;;    -*- Text -*-
-;;; This kicks in if we find no colon on the file options line.
-;;;
-(defun process-file-options (buffer &optional
-				    (pathname (buffer-pathname buffer)))
-  "Checks for file options and invokes handlers if there are any.  If no
-   \"Mode\" mode option is specified, then this tries to invoke the appropriate
-   file type hook."
-  (let* ((string
-	  (line-string (mark-line (buffer-start-mark buffer))))
-	 (found (search "-*-" string))
-	 (no-major-mode t)
-	 (type (if pathname (pathname-type pathname))))
-    (declare (simple-string string))
-    (when found
-      (block do-file-options
-	(let* ((start (+ found 3))
-	       (end (search "-*-" string :start2 start)))
-	  (unless end
-	    (loud-message "No closing \"-*-\".  Aborting file options.")
-	    (return-from do-file-options))
-	  (cond
-	   ((find #\: string :start start :end end)
-	    (do ((opt-start start (1+ semi)) colon semi)
-		(nil)
-	      (setq colon (position #\: string :start opt-start :end end))
-	      (unless colon
-		(loud-message "Missing \":\".  Aborting file options.")
-		(return-from do-file-options))
-	      (setq semi (or (position #\; string :start colon :end end) end))
-	      (let* ((option (nstring-downcase
-			      (trim-subseq string opt-start colon)))
-		     (handler (assoc option *mode-option-handlers*
-				     :test #'string=)))
-		(declare (simple-string option))
-		(cond
-		 (handler
-		  (let ((result (funcall (cdr handler) buffer
-					 (trim-subseq string (1+ colon) semi))))
-		    (when (string= option "mode")
-		      (setq no-major-mode (not result)))))
-		 (t (message "Unknown file option: ~S" option)))
-		(when (= semi end) (return nil)))))
-	   (t
-	    ;; Old style mode comment.
-	    (setq no-major-mode nil)
-	    (funcall (cdr (assoc "mode" *mode-option-handlers* :test #'string=))
-		     buffer (trim-subseq string start end)))))))
-    (when (and no-major-mode type)
-      (let ((hook (assoc (string-downcase type) *file-type-hooks*
-			 :test #'string=)))
-	(when hook (funcall (cdr hook) buffer type))))))
-
-
-
-;;;; File options and file type hooks.
-
-(defmacro define-file-option (name lambda-list &body body)
-  "Define-File-Option Name (Buffer Value) {Form}*
-   Defines a new file option to be user in the -*- line at the top of a file.
-   The body is evaluated with Buffer bound to the buffer the file has been read
-   into and Value to the string argument to the option."
-  (let ((name (string-downcase name)))
-    `(setf (cdr (or (assoc ,name *mode-option-handlers*  :test #'string=)
-		    (car (push (cons ,name nil) *mode-option-handlers*))))
-	   #'(lambda ,lambda-list ,@body))))
-
-(define-file-option "Mode" (buffer str)
-  (let ((seen-major-mode-p nil)
-	(lastpos 0))
-    (loop
-      (let* ((pos (position #\, str :start lastpos))
-	     (substr (trim-subseq str lastpos pos)))
-	(cond ((getstring substr *mode-names*)
-	       (cond ((mode-major-p substr)
-		      (when seen-major-mode-p
-			(loud-message
-			 "Major mode already processed. Using ~S now."
-			 substr))
-		      (setf seen-major-mode-p t)
-		      (setf (buffer-major-mode buffer) substr))
-		     (t
- 		      (setf (buffer-minor-mode buffer substr) t))))
-	      (t
-	       (loud-message "~S is not a defined mode -- ignored." substr)))
-	(unless pos
-	  (return seen-major-mode-p))
-	(setf lastpos (1+ pos))))))
-
-
-(defmacro define-file-type-hook (type-list (buffer type) &body body)
-  "Define-File-Type-Hook ({Type}*) (Buffer Type) {Form}*
-  Define some code to be evaluated when a file having one of the specified
-  Types is read by a file command.  Buffer is bound to the buffer the
-  file is in, and Type is the actual type read."
-  (let ((fun (gensym)) (str (gensym)))
-    `(flet ((,fun (,buffer ,type) ,@body))
-       (dolist (,str ',(mapcar #'string-downcase type-list))
-	 (setf (cdr (or (assoc ,str *file-type-hooks*  :test #'string=)
-			(car (push (cons ,str nil) *file-type-hooks*))))
-	       #',fun)))))
-
-(define-file-type-hook ("pas" "pasmac" "macro" "defs" "spc" "bdy")
-  		       (buffer type)
-  (declare (ignore type))
-  (setf (buffer-major-mode buffer) "Pascal"))
-
-(define-file-type-hook ("lisp" "slisp" "l" "lsp" "mcl") (buffer type)
-  (declare (ignore type))
-  (setf (buffer-major-mode buffer) "Lisp"))
-
-(define-file-type-hook ("txt" "text" "tx") (buffer type)
-  (declare (ignore type))
-  (setf (buffer-major-mode buffer) "Text"))
-
-
-
-;;;; Support for file hacking commands:
-
-(defhvar "Pathname Defaults"
-  "This variable contains a pathname which is used to supply defaults
-   when we don't have anything better."
-  :value (pathname "gazonk.del"))
-
-(defhvar "Last Resort Pathname Defaults"
-  "This variable contains a pathname which is used to supply defaults when
-   we don't have anything better, but unlike \"Pathname Defaults\", this is
-   never set to some buffer's pathname."
-  :value (pathname "gazonk"))
-
-(defhvar "Last Resort Pathname Defaults Function"
-  "This variable contains a function that is called when a default pathname is
-   needed, the buffer has no pathname, and the buffer's name is not entirely
-   composed of alphanumerics.  The default value is a function that simply
-   returns \"Last Resort Pathname Defaults\".  The function must take a buffer
-   as an argument, and it must return some pathname."
-  :value #'(lambda (buffer)
-	     (declare (ignore buffer))
-	     (merge-pathnames (value last-resort-pathname-defaults)
-			      (value pathname-defaults))))
-
-(defun buffer-default-pathname (buffer)
-  "Returns \"Buffer Pathname\" if it is bound.  If it is not, and buffer's name
-   is composed solely of alphnumeric characters, then return a pathname formed
-   from the buffer's name.  If the buffer's name has other characters in it,
-   then return the value of \"Last Resort Pathname Defaults Function\" called
-   on buffer."
-  (or (buffer-pathname buffer)
-      (if (every #'alphanumericp (the simple-string (buffer-name buffer)))
-	  (merge-pathnames (make-pathname :name (buffer-name buffer))
-			   (value pathname-defaults))
-	  (funcall (value last-resort-pathname-defaults-function) buffer))))
-
-
-(defun pathname-to-buffer-name (pathname)
-  "Returns a simple-string using components from pathname."
-  (let ((pathname (pathname pathname)))
-    (concatenate 'simple-string
-		 (file-namestring pathname)
-		 " "
-		 (directory-namestring pathname))))
-
-
-
-;;;; File hacking commands.
-
-(defcommand "Process File Options" (p)
-  "Reprocess this buffer's file options."
-  "Reprocess this buffer's file options."
-  (declare (ignore p))
-  (process-file-options (current-buffer)))
-
-(defcommand "Insert File" (p &optional pathname (buffer (current-buffer)))
-  "Inserts a file which is prompted for into the current buffer at the point.
-  The prefix argument is ignored."
-  "Inserts the file named by Pathname into Buffer at the point."
-  (declare (ignore p))
-  (let* ((pn (or pathname
-		 (prompt-for-file :default (buffer-default-pathname buffer)
-				  :prompt "Insert File: "
-				  :help "Name of file to insert")))
-	 (point (buffer-point buffer))
-	 ;; start and end will be deleted by undo stuff
-	 (start (copy-mark point :right-inserting))
-	 (end (copy-mark point :left-inserting))
-	 (region (region start end)))
-    (setv pathname-defaults pn)
-    (push-buffer-mark (copy-mark end))
-    (read-file pn end)
-    (make-region-undo :delete "Insert File" region)))
-
-(defcommand "Write Region" (p &optional pathname)
-  "Writes the current region to a file. "
-  "Writes the current region to a file. "
-  (declare (ignore p))
-  (let ((region (current-region))
-	(pn (or pathname
-		(prompt-for-file :prompt "File to Write: "
-				 :help "The name of the file to write the region to. "
-				 :default (buffer-default-pathname
-					   (current-buffer))
-				 :must-exist nil))))
-    (write-file region pn)
-    (message "~A written." (namestring (truename pn)))))
-
-
-
-;;;; Visiting and reverting files.
-
-(defcommand "Visit File" (p &optional pathname (buffer (current-buffer)))
-  "Replaces the contents of Buffer with the file Pathname.  The prefix
-   argument is ignored.  The buffer is set to be writable, so its region
-   can be deleted."
-  "Replaces the contents of the current buffer with the text in the file
-   which is prompted for.  The prefix argument is, of course, ignored p times."
-  (declare (ignore p))
-  (when (and (buffer-modified buffer)
-	     (prompt-for-y-or-n :prompt "Buffer is modified, save it? "))
-    (save-file-command () buffer))
-  (let ((pn (or pathname
-		(prompt-for-file :prompt "Visit File: "
-				 :must-exist nil
-				 :help "Name of file to visit."
-				 :default (buffer-default-pathname buffer)))))
-    (setf (buffer-writable buffer) t)
-    (read-buffer-file pn buffer)
-    (let ((n (pathname-to-buffer-name (buffer-pathname buffer))))
-      (unless (getstring n *buffer-names*)
-	(setf (buffer-name buffer) n))
-      (warn-about-visit-file-buffers buffer))))
-
-(defun warn-about-visit-file-buffers (buffer)
-  (let ((buffer-pn (buffer-pathname buffer)))
-    (dolist (b *buffer-list*)
-      (unless (eq b buffer)
-	(let ((bpn (buffer-pathname b)))
-	  (when (equal bpn buffer-pn)
-	    (message "Buffer ~A also contains ~A."
-		     (buffer-name b) (namestring buffer-pn))
-	    (return)))))))
-
-
-(defhvar "Revert File Confirm"
-  "If this is true, Revert File will prompt before reverting."
-  :value t)
-
-(defcommand "Revert File" (p)
-  "Unless in Save Mode, reads in the last saved version of the file in
-  the current buffer. When in Save Mode, reads in the last checkpoint or
-  the last saved version, whichever is more recent. An argument will always
-  force Revert File to use the last saved version. In either case, if the
-  buffer has been modified and \"Revert File Confirm\" is true, then Revert
-  File will ask for confirmation beforehand. An attempt is made to maintain
-  the point's relative position."
-  "With an argument reverts to the last saved version of the file in the
-  current buffer. Without, reverts to the last checkpoint or last saved
-  version, whichever is more recent."
-  (let* ((buffer (current-buffer))
-	 (buffer-pn (buffer-pathname buffer))
-	 (point (current-point))
-	 (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
-    (multiple-value-bind (revert-pn used-checkpoint)
-			 (if p buffer-pn (revert-pathname buffer))
-      (unless revert-pn
-	(editor-error "No file associated with buffer to revert to!"))
-      (when (or (not (value revert-file-confirm))
-		(not (buffer-modified buffer))
-		(prompt-for-y-or-n
-		 :prompt
-		 "Buffer contains changes, are you sure you want to revert? "
-		 :help (list
- "Reverting the file will undo any changes by reading in the last ~
- ~:[saved version~;checkpoint file~]." used-checkpoint)
-		 :default t))
-	(read-buffer-file revert-pn buffer)
-	(when used-checkpoint
-	  (setf (buffer-modified buffer) t)
-	  (setf (buffer-pathname buffer) buffer-pn)
-	  (message "Reverted to checkpoint file ~A." (namestring revert-pn)))
-	(unless (line-offset point lines)
-	  (buffer-end point))))))
-
-;;; REVERT-PATHNAME -- Internal
-;;;
-;;; If in Save Mode, return either the checkpoint pathname or the buffer
-;;; pathname whichever is more recent. Otherwise return the buffer-pathname
-;;; if it exists. If neither file exists, return NIL.
-;;; 
-(defun revert-pathname (buffer)
-  (let* ((buffer-pn (buffer-pathname buffer))
-	 (buffer-pn-date (file-write-date buffer-pn))
-	 (checkpoint-pn (get-checkpoint-pathname buffer))
-	 (checkpoint-pn-date (file-write-date checkpoint-pn)))
-    (cond (checkpoint-pn-date
-	   (if (> checkpoint-pn-date (or buffer-pn-date 0))
-	       (values checkpoint-pn t)
-	       (values buffer-pn nil)))
-	  (buffer-pn-date (values buffer-pn nil))
-	  (t (values nil nil)))))
-
-
-
-;;;; Find file.
-
-(defcommand "Find File" (p &optional pathname)
-  "Visit a file in its own buffer.
-  If the file is already in some buffer, select that buffer,
-  otherwise make a new buffer with the same name as the file and
-  read the file into it."
-  "Make a buffer containing the file Pathname current, creating a buffer
-  if necessary.  The buffer is returned."
-  (declare (ignore p))
-  (let* ((pn (or pathname
-		 (prompt-for-file 
-		  :prompt "Find File: "
-		  :must-exist nil
-		  :help "Name of file to read into its own buffer."
-		  :default (buffer-default-pathname (current-buffer)))))
-	 (buffer (find-file-buffer pn)))
-    (change-to-buffer buffer)
-    buffer))
-
-(defun find-file-buffer (pathname)
-  "Return a buffer assoicated with the file Pathname, reading the file into a
-   new buffer if necessary.  The second value is T if we created a buffer, NIL
-   otherwise.  If the file has already been read, we check to see if the file
-   has been modified on disk since it was read, giving the user various
-   recovery options."
-  (let* ((pathname (pathname pathname))
-	 (trial-pathname (or (probe-file pathname)
-			     (merge-pathnames pathname (default-directory))))
-	 (found (find trial-pathname (the list *buffer-list*)
-		     :key #'buffer-pathname :test #'equal)))
-    (cond ((not found)
-	   (let* ((name (pathname-to-buffer-name trial-pathname))
-		  (buffer (getstring name *buffer-names*))
-		  (use (if buffer
-			   (prompt-for-buffer
-			    :prompt "Buffer to use: "
-			    :help
-  "Buffer name in use; give another buffer name, or confirm to reuse."
-			    :default buffer :must-exist nil)
-			   (make-buffer name)))
-		  (buffer (if (stringp use) (make-buffer use) use)))
-	     (when (and (buffer-modified buffer)
-			(prompt-for-y-or-n :prompt
-					   "Buffer is modified, save it? "))
-	       (save-file-command () buffer))
-	     (read-buffer-file pathname buffer)
-	     (values buffer (stringp use))))
-	  ((check-disk-version-consistent pathname found)
-	   (values found nil))
-	  (t
-	   (read-buffer-file pathname found)
-	   (values found nil)))))
-
-;;; Check-Disk-Version-Consistent  --  Internal
-;;;
-;;;    Check that Buffer contains a valid version of the file Pathname,
-;;; harrassing the user if not.  We return true if the buffer is O.K., and
-;;; false if the file should be read. 
-;;;
-(defun check-disk-version-consistent (pathname buffer)
-  (let ((ndate (file-write-date pathname))
-	(odate (buffer-write-date buffer)))
-    (cond ((not (and ndate odate (/= ndate odate)))
-	   t)
-	  ((buffer-modified buffer)
-	   (beep)
-	   (clear-input)
-	   (command-case (:prompt (list
- "File has been changed on disk since it was read and you have made changes too!~
- ~%Read in the disk version of ~A? [Y] " (namestring pathname))
-			  :help
- "The file in disk has been changed since Hemlock last saved it, meaning that
- someone else has probably overwritten it.  Since the version read into Hemlock
- has been changed as well, the two versions may have inconsistent changes.  If
- this is the case, it would be a good idea to save your changes in another file
- and compare the two versions.
- 
- Type one of the following commands:")
-	     ((:confirm :yes)
- "Prompt for a file to write the buffer out to, then read in the disk version."
-	      (write-buffer-file
-	       buffer
-	       (prompt-for-file
-		:prompt "File to save changes in: "
-		:help (list "Save buffer ~S to this file before reading ~A."
-			    (buffer-name buffer) (namestring pathname))
-		:must-exist nil
-		:default (buffer-default-pathname buffer)))
-	      nil)
-	     (:no
-	      "Change to the buffer without reading the new version."
-	      t)
-	     (#\r
-	      "Read in the new version, clobbering the changes in the buffer."
-	      nil)))
-	   (t
-	    (not (prompt-for-yes-or-no :prompt
-				       (list
- "File has been changed on disk since it was read.~
- ~%Read in the disk version of ~A? "
-					(namestring pathname))
-				       :help
- "Type Y to read in the new version or N to just switch to the buffer."
-				       :default t))))))
-
-
-(defhvar "Read File Hook"
-  "These functions are called when a file is read into a buffer.  Each function
-   must take two arguments -- the buffer the file was read into and whether the
-   file existed (non-nil) or not (nil).")
-
-(defun read-buffer-file (pathname buffer)
-  "Delete the buffer's region, and uses READ-FILE to read pathname into it.
-   If the file exists, set the buffer's write date to the file's; otherwise,
-   MESSAGE that this is a new file and set the buffer's write date to nil.
-   Move buffer's point to the beginning, set the buffer unmodified.  If the
-   file exists, set the buffer's pathname to the probed pathname; else, set it
-   to pathname merged with DEFAULT-DIRECTORY.  Set \"Pathname Defaults\" to the
-   same thing.  Process the file options, and then invoke \"Read File Hook\"."
-  (delete-region (buffer-region buffer))
-  (let* ((pathname (pathname pathname))
-	 (probed-pathname (probe-file pathname)))
-    (cond (probed-pathname
-	   (read-file probed-pathname (buffer-point buffer))
-	   (setf (buffer-write-date buffer) (file-write-date probed-pathname)))
-	  (t
-	   (message "(New File)")
-	   (setf (buffer-write-date buffer) nil)))
-    (buffer-start (buffer-point buffer))
-    (setf (buffer-modified buffer) nil)
-    (let ((stored-pathname (or probed-pathname
-			       (merge-pathnames pathname (default-directory)))))
-      (setf (buffer-pathname buffer) stored-pathname)
-      (setf (value pathname-defaults) stored-pathname)
-      (process-file-options buffer stored-pathname)
-      (invoke-hook read-file-hook buffer probed-pathname))))
-
-
-
-;;;; File writing.
-
-(defhvar "Add Newline at EOF on Writing File"
-  "This controls whether WRITE-BUFFER-FILE adds a newline at the end of the
-   file when it ends at the end of a non-empty line.  When set, this may be
-   :ask-user and WRITE-BUFFER-FILE will prompt; otherwise, just add one and
-   inform the user.  When nil, never add one and don't ask."
-  :value :ask-user)
-
-(defhvar "Keep Backup Files"
-  "When set, .BAK files will be saved upon file writing.  This defaults to nil."
-  :value nil)
-
-(defhvar "Write File Hook"
-  "These functions are called when a buffer has been written.  Each function
-   must take the buffer as an argument.")
-
-(defun write-buffer-file (buffer pathname)
-  "Write's buffer to pathname.  This assumes pathname is somehow related to
-   the buffer's pathname, and if the buffer's write date is not the same as
-   pathname's, then this prompts the user for confirmation before overwriting
-   the file.  This consults \"Add Newline at EOF on Writing File\" and
-   interacts with the user if necessary.  This sets \"Pathname Defaults\", and
-   the buffer is marked unmodified.  The buffer's pathname and write date are
-   updated, and the buffer is renamed according to the new pathname if possible.
-   This invokes \"Write File Hook\"."
-  (let ((buffer-pn (buffer-pathname buffer)))
-    (let ((date (buffer-write-date buffer))
-	  (file-date (when (probe-file pathname) (file-write-date pathname))))
-      (when (and buffer-pn date file-date
-		 (equal (make-pathname :version nil :defaults buffer-pn)
-			(make-pathname :version nil :defaults pathname))
-		 (/= date file-date))
-	(unless (prompt-for-yes-or-no :prompt (list
- "File has been changed on disk since it was read.~%Overwrite ~A anyway? "
- (namestring buffer-pn))
-				      :help
-				      "Type No to abort writing the file or Yes to overwrite the disk version."
-				      :default nil)
-	  (editor-error "Write aborted."))))
-    (let ((val (value add-newline-at-eof-on-writing-file)))
-      (when val
-	(let ((end (buffer-end-mark buffer)))
-	  (unless (start-line-p end)
-	    (when (if (eq val :ask-user)
-		      (prompt-for-y-or-n
-		       :prompt
-		       (list "~A~%File does not have a newline at EOF, add one? "
-			     (buffer-name buffer))
-		       :default t)
-		      t)
-	      (insert-character end #\newline)
-	      (message "Added newline at EOF."))))))
-    (setv pathname-defaults pathname)
-    (write-file (buffer-region buffer) pathname)
-    (let ((tn (truename pathname)))
-      (message "~A written." (namestring tn))
-      (setf (buffer-modified buffer) nil)
-      (unless (equal tn buffer-pn)
-	(setf (buffer-pathname buffer) tn))
-      (setf (buffer-write-date buffer) (file-write-date tn))
-      (let ((name (pathname-to-buffer-name tn)))
-	(unless (getstring name *buffer-names*)
-	  (setf (buffer-name buffer) name)))))
-  (invoke-hook write-file-hook buffer))
- 
-(defcommand "Write File" (p &optional pathname (buffer (current-buffer)))
-  "Writes the contents of Buffer, which defaults to the current buffer to
-  the file named by Pathname.  The prefix argument is ignored."
-  "Prompts for a file to write the contents of the current Buffer to.
-  The prefix argument is ignored."
-  (declare (ignore p))
-  (write-buffer-file
-   buffer
-   (or pathname
-       (prompt-for-file :prompt "Write File: "
-			:must-exist nil
-			:help "Name of file to write to"
-			:default (buffer-default-pathname buffer)))))
-
-(defcommand "Save File" (p &optional (buffer (current-buffer)))
-  "Writes the contents of the current buffer to the associated file.  If there
-  is no associated file, once is prompted for."
-  "Writes the contents of the current buffer to the associated file."
-  (declare (ignore p))
-  (when (or (buffer-modified buffer)
-	    (prompt-for-y-or-n 
-	     :prompt "Buffer is unmodified, write it anyway? "
-	     :default t))
-    (write-buffer-file
-     buffer
-     (or (buffer-pathname buffer)
-	 (prompt-for-file :prompt "Save File: "
-			  :help "Name of file to write to"
-			  :default (buffer-default-pathname buffer)
-			  :must-exist nil)))))
-
-(defhvar "Save All Files Confirm"
-  "When non-nil, prompts for confirmation before writing each modified buffer."
-  :value t)
-
-(defcommand "Save All Files" (p)
-  "Saves all modified buffers in their associated files.
-  If a buffer has no associated file it is ignored even if it is modified.."
-  "Saves each modified buffer that has a file."
-  (declare (ignore p))
-  (let ((saved-count 0))
-    (dolist (b *buffer-list*)
-      (let ((pn (buffer-pathname b))
-	    (name (buffer-name b)))
-	(when
-	    (and (buffer-modified b)
-		 pn
-		 (or (not (value save-all-files-confirm))
-		     (prompt-for-y-or-n
-		      :prompt (list
-			       "Write ~:[buffer ~A as file ~S~;file ~*~S~], ~
-			       Y or N: "
-			       (string= (pathname-to-buffer-name pn) name)
-			       name (namestring pn))
-		      :default t)))
-	  (write-buffer-file b pn)
-	  (incf saved-count))))
-    (if (zerop saved-count)
-	(message "No files were saved.")
-	(message "Saved ~S file~:P." saved-count))))
-
-(defcommand "Save All Files and Exit" (p)
-  "Save all modified buffers in their associated files and exit;
-  a combination of \"Save All Files\" and \"Exit Hemlock\"."
-  "Do a save-all-files-command and then an exit-hemlock."
-  (declare (ignore p))
-  (save-all-files-command ())
-  (exit-hemlock))
-
-(defcommand "Backup File" (p)
-  "Write the buffer to a file without changing the associated name."
-  "Write the buffer to a file without changing the associated name."
-  (declare (ignore p))
-  (let ((file (prompt-for-file :prompt "Backup to File: "
-			       :help
- "Name of a file to backup the current buffer in."
-			       :default (buffer-default-pathname (current-buffer))
-			       :must-exist nil)))
-    (write-file (buffer-region (current-buffer)) file)
-    (message "~A written." (namestring (truename file)))))
-
-
-
-;;;; Buffer hacking commands:
-
-(defvar *buffer-history* ()
-  "A list of buffers, in order from most recently to least recently selected.")
-
-(defun previous-buffer ()
-  "Returns some previously selected buffer that is not the current buffer.
-   Returns nil if no such buffer exists."
-  (let ((b (car *buffer-history*)))
-    (or (if (eq b (current-buffer)) (cadr *buffer-history*) b)
-	(find-if-not #'(lambda (x)
-			 (or (eq x (current-buffer))
-			     (eq x *echo-area-buffer*)))
-		     (the list *buffer-list*)))))
-
-;;; ADD-BUFFER-HISTORY-HOOK makes sure every buffer will be visited by
-;;; "Circulate Buffers" even if it has never been before.
-;;;
-(defun add-buffer-history-hook (buffer)
-  (let ((ele (last *buffer-history*))
-	(new-stuff (list buffer)))
-    (if ele
-	(setf (cdr ele) new-stuff)
-	(setf *buffer-history* new-stuff))))
-;;;
-(add-hook make-buffer-hook 'add-buffer-history-hook)
-
-;;; DELETE-BUFFER-HISTORY-HOOK makes sure we never end up in a dead buffer.
-;;;
-(defun delete-buffer-history-hook (buffer)
-  (setq *buffer-history* (delq buffer *buffer-history*)))
-;;;
-(add-hook delete-buffer-hook 'delete-buffer-history-hook)
-  
-(defun change-to-buffer (buffer)
-  "Switches to buffer in the current window maintaining *buffer-history*."
-  (setq *buffer-history*
-	(cons (current-buffer) (delq (current-buffer) *buffer-history*)))
-  (setf (current-buffer) buffer)
-  (setf (window-buffer (current-window)) buffer))
-
-(defun delete-buffer-if-possible (buffer)
-  "Deletes a buffer if at all possible.  If buffer is the only buffer, other
-   than the echo area, signals an error.  Otherwise, find some recently current
-   buffer, and make all of buffer's windows display this recent buffer.  If
-   buffer is current, set the current buffer to be this recently current
-   buffer."
-  (let ((new-buf (flet ((frob (b)
-			  (or (eq b buffer) (eq b *echo-area-buffer*))))
-		   (or (find-if-not #'frob (the list *buffer-history*))
-		       (find-if-not #'frob (the list *buffer-list*))))))
-    (unless new-buf
-      (error "Cannot delete only buffer ~S." buffer))
-    (dolist (w (buffer-windows buffer))
-      (setf (window-buffer w) new-buf))
-    (when (eq buffer (current-buffer))
-      (setf (current-buffer) new-buf)))
-  (delete-buffer buffer))
-
-
-(defvar *create-buffer-count* 0)
-
-(defcommand "Create Buffer" (p &optional buffer-name)
-  "Create a new buffer.  If a buffer with the specified name already exists,
-   then go to it."
-  "Create or go to the buffer with the specifed name."
-  (declare (ignore p))
-  (let ((name (or buffer-name
-		  (prompt-for-buffer :prompt "Create Buffer: "
-				     :default-string
-				     (format nil "Buffer ~D"
-					     (incf *create-buffer-count*))
-				     :must-exist nil))))
-    (if (bufferp name)
-	(change-to-buffer name)
-	(change-to-buffer (or (getstring name *buffer-names*)
-			      (make-buffer name))))))
-
-(defcommand "Select Buffer" (p)
-  "Select a different buffer.
-   The buffer to go to is prompted for."
-  "Select a different buffer.
-   The buffer to go to is prompted for."
-  (declare (ignore p))
-  (let ((buf (prompt-for-buffer :prompt "Select Buffer: "
-				:default (previous-buffer))))
-    (when (eq buf *echo-area-buffer*)
-      (editor-error "Cannot select Echo Area buffer."))
-    (change-to-buffer buf)))
-
-
-(defvar *buffer-history-ptr* ()
-  "The successively previous buffer to the current buffer.")
-
-(defcommand "Select Previous Buffer" (p)
-  "Select the buffer selected before this one.  If called repeatedly
-   with an argument, select the successively previous buffer to the
-   current one leaving the buffer history as it is."
-  "Select the buffer selected before this one."
-  (if p
-      (circulate-buffers-command nil)
-      (let ((b (previous-buffer)))
-	(unless b (editor-error "No previous buffer."))
-	(change-to-buffer b)
-	;;
-	;; If the pointer goes to nil, then "Circulate Buffers" will keep doing
-	;; "Select Previous Buffer".
-	(setf *buffer-history-ptr* (cddr *buffer-history*))
-	(setf (last-command-type) :previous-buffer))))
-
-(defcommand "Circulate Buffers" (p)
-  "Advance through buffer history, selecting successively previous buffer."
-  "Advance through buffer history, selecting successively previous buffer."
-  (declare (ignore p))
-  (if (and (eq (last-command-type) :previous-buffer)
-	   *buffer-history-ptr*) ;Possibly nil if never CHANGE-TO-BUFFER.
-      (let ((b (pop *buffer-history-ptr*)))
-	(when (eq b (current-buffer))
-	  (setf b (pop *buffer-history-ptr*)))
-	(unless b
-	  (setf *buffer-history-ptr*
-		(or (cdr *buffer-history*) *buffer-history*))
-	  (setf b (car *buffer-history*)))
-	(setf (current-buffer) b)
-	(setf (window-buffer (current-window)) b)
-	(setf (last-command-type) :previous-buffer))
-      (select-previous-buffer-command nil)))
-  
-
-(defcommand "Buffer Not Modified" (p)
-  "Make the current buffer not modified."
-  "Make the current buffer not modified."
-  (declare (ignore p))
-  (setf (buffer-modified (current-buffer)) nil)
-  (message "Buffer marked as unmodified."))
-
-(defcommand "Check Buffer Modified" (p)
-  "Say whether the buffer is modified or not."
-  "Say whether the current buffer is modified or not."
-  (declare (ignore p))
-  (clear-echo-area)
-  (message "Buffer ~S ~:[is not~;is~] modified."
-	   (buffer-name (current-buffer)) (buffer-modified (current-buffer))))
-
-(defcommand "Set Buffer Read-Only" (p)
-  "Toggles the read-only flag for the current buffer."
-  "Toggles the read-only flag for the current buffer."
-  (declare (ignore p))
-  (let ((buffer (current-buffer)))
-    (message "Buffer ~S is now ~:[read-only~;writable~]."
-	     (buffer-name buffer)
-	     (setf (buffer-writable buffer) (not (buffer-writable buffer))))))
-
-(defcommand "Kill Buffer" (p &optional buffer-name)
-  "Prompts for a buffer to delete.
-  If the buffer is modified, then let the user save the file before doing so.
-  When deleting the current buffer, prompts for a new buffer to select.  If
-  a buffer other than the current one is deleted then any windows into it
-  are deleted."
-  "Delete buffer Buffer-Name, doing sensible things if the buffer is displayed
-  or current."
-  (declare (ignore p))
-  (let ((buffer (if buffer-name
-		    (getstring buffer-name *buffer-names*)
-		    (prompt-for-buffer :prompt "Kill Buffer: "
-				       :default (current-buffer)))))
-    (if (not buffer)
-	(editor-error "No buffer named ~S" buffer-name))
-    (if (and (buffer-modified buffer)
-	     (prompt-for-y-or-n :prompt "Save it first? "))
-	(save-file-command () buffer))
-    (if (eq buffer (current-buffer))
-	(let ((new (prompt-for-buffer :prompt "New Buffer: "
-				      :default (previous-buffer)
- :help "Buffer to change to after the current one is killed.")))
-	  (when (eq new buffer)
-	    (editor-error "You must select a different buffer."))
-	  (dolist (w (buffer-windows buffer))
-	    (setf (window-buffer w) new))
-	  (setf (current-buffer) new))
-	(dolist (w (buffer-windows buffer))
-	  (delete-window w)))
-    (delete-buffer buffer)))
-
-(defcommand "Rename Buffer" (p)
-  "Change the current buffer's name.
-  The name, which is prompted for, defaults to the name of the associated
-  file."
-  "Change the name of the current buffer."
-  (declare (ignore p))
-  (let* ((buf (current-buffer))
-	 (pn (buffer-pathname buf))
-	 (name (if pn (pathname-to-buffer-name pn) (buffer-name buf)))
-	 (new (prompt-for-string :prompt "New Name: "
-				 :help "Give a new name for the current buffer"
-				 :default name)))
-    (multiple-value-bind (entry foundp) (getstring new *buffer-names*)
-      (cond ((or (not foundp) (eq entry buf))
-	     (setf (buffer-name buf) new))
-	    (t (editor-error "Name ~S already in use." new))))))
-
-
-(defcommand "Insert Buffer" (p)
-  "Insert the contents of a buffer.
-  The name of the buffer to insert is prompted for."
-  "Prompt for a buffer to insert at the point."
-  (declare (ignore p))
-  (let ((point (current-point))
-	(region (buffer-region (prompt-for-buffer
-				:default (previous-buffer) 
-				:help 
-				"Type the name of a buffer to insert."))))
-    ;;
-    ;; start and end will be deleted by undo stuff
-    (let ((save (region (copy-mark point :right-inserting)
-			(copy-mark point :left-inserting))))
-      (push-buffer-mark (copy-mark point))
-      (insert-region point region)
-      (make-region-undo :delete "Insert Buffer" save))))
-
-
-
-;;;; File utility commands:
-
-(defcommand "Directory" (p)
-  "Do a directory into a pop-up window.  If an argument is supplied, then
-   dot files are listed too (as with ls -a).  Prompts for a pathname which
-   may contain wildcards in the name and type."
-  "Do a directory into a pop-up window."
-  (let* ((dpn (value pathname-defaults))
-	 (pn (prompt-for-file
-	      :prompt "Directory: "
-	      :help "Pathname to do directory on."
-	      :default (make-pathname :device (pathname-device dpn)
-				      :directory (pathname-directory dpn))
-	      :must-exist nil)))
-    (setf (value pathname-defaults) (merge-pathnames pn dpn))
-    (with-pop-up-display (s)
-      (print-directory pn s :all p))))
-
-(defcommand "Verbose Directory" (p)
-  "Do a directory into a pop-up window.  If an argument is supplied, then
-   dot files are listed too (as with ls -a).  Prompts for a pathname which
-   may contain wildcards in the name and type."
-  "Do a directory into a pop-up window."
-  (let* ((dpn (value pathname-defaults))
-	 (pn (prompt-for-file
-	      :prompt "Verbose Directory: "
-	      :help "Pathname to do directory on."
-	      :default (make-pathname :device (pathname-device dpn)
-				      :directory (pathname-directory dpn))
-	      :must-exist nil)))
-    (setf (value pathname-defaults) (merge-pathnames pn dpn))
-    (with-pop-up-display (s)
-      (print-directory pn s :verbose t :all p))))
-
-
-
-;;;; Change log stuff:
-
-(define-file-option "Log" (buffer value)
-  (defhvar "Log File Name"
-    "The name of the file for the change log for the file in this buffer."
-    :buffer buffer  :value value))
-
-(defhvar "Log Entry Template"
-  "The format string used to generate the template for a change-log entry.
-  Three arguments are given: the file, the date (create if available, now
-  otherwise) and the file author, or NIL if not available.  The last \"@\"
-  is deleted and the point placed where it was."
-  :value "~A, ~A, Edit by ~:[???~;~:*~:(~A~)~].~%  @~2%")
-
-(defmode "Log"
-  :major-p t
-  :setup-function
-  #'(lambda (buffer)
-      (setf (buffer-minor-mode buffer "Fill") t))
-  :cleanup-function
-  #'(lambda (buffer)
-      (setf (buffer-minor-mode buffer "Fill") nil)))
-
-(defhvar "Fill Prefix" "The fill prefix in Log mode."
-  :value "  "  :mode "Log")
-
-(define-file-type-hook ("log") (buffer type)
-  (declare (ignore type))
-  (setf (buffer-major-mode buffer) "Log"))
-
-(defun universal-time-to-string (ut)
-  (multiple-value-bind (sec min hour day month year)
-		       (decode-universal-time ut)
-    (format nil "~2,'0D-~A-~2,'0D ~2,'0D:~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)))
-
-(defvar *back-to-@-pattern* (new-search-pattern :character :backward #\@))
-(defcommand "Log Change" (p)
-  "Make an entry in the change-log file for this buffer.
-  Saves the file in the current buffer if it is modified, then finds the file
-  specified in the \"Log\" file option, adds the template for a change-log
-  entry at the beginning, then does a recursive edit, saving the log file on
-  exit."
-  "Find the change-log file as specified by \"Log File Name\" and edit it."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'log-file-name)
-    (editor-error "No log file defined."))
-  (let* ((buffer (current-buffer))
-	 (pathname (buffer-pathname buffer)))
-    (when (or (buffer-modified buffer) (null pathname))
-      (save-file-command ()))
-    (unwind-protect
-	(progn
-	  (find-file-command nil (merge-pathnames
-				  (value log-file-name)
-				  (buffer-default-pathname buffer)))
-	  (let ((point (current-point)))
-	    (buffer-start point)
-	    (with-output-to-mark (s point :full)
-	      (format s (value log-entry-template)
-		      (namestring pathname)
-		      (universal-time-to-string
-		       (or (file-write-date pathname)
-			   (get-universal-time)))
-		      (file-author pathname)))
-	    (when (find-pattern point *back-to-@-pattern*)
-	      (delete-characters point 1)))
-	  (do-recursive-edit)
-	  (when (buffer-modified (current-buffer)) (save-file-command ())))
-      (if (member buffer *buffer-list* :test #'eq)
-	  (change-to-buffer buffer)
-	  (editor-error "Old buffer has been deleted.")))))
-
-
-
-;;;; Window hacking commands:
-
-(defcommand "Next Window" (p)
-  "Change the current window to be the next window and the current buffer
-  to be it's buffer."
-  "Go to the next window.
-  If the next window is the bottom window then wrap around to the top window."
-  (declare (ignore p))
-  (let* ((next (next-window (current-window)))
-	 (buffer (window-buffer next)))
-    (setf (current-buffer) buffer  (current-window) next)))
-
-(defcommand "Previous Window" (p)
-  "Change the current window to be the previous window and the current buffer
-  to be it's buffer."
-  "Go to the previous window.
-  If the Previous window is the top window then wrap around to the bottom."
-  (declare (ignore p))
-  (let* ((previous (previous-window (current-window)))
-	 (buffer (window-buffer previous)))
-    (setf (current-buffer) buffer  (current-window) previous)))
-
-(defcommand "Split Window" (p)
-  "Make a new window by splitting the current window.
-   The new window is made the current window and displays starting at
-   the same place as the current window."
-  "Create a new window which displays starting at the same place
-   as the current window."
-  (declare (ignore p))
-  (let ((new (make-window (window-display-start (current-window)))))
-    (unless new (editor-error "Could not make a new window."))
-    (setf (current-window) new)))
-
-(defcommand "New Window" (p)
-  "Make a new window and go to it.
-   The window will display the same buffer as the current one."
-  "Create a new window which displays starting at the same place
-   as the current window."
-  (declare (ignore p))
-  (let ((new (make-window (window-display-start (current-window))
-			  :ask-user t)))
-    (unless new (editor-error "Could not make a new window."))
-    (setf (current-window) new)))
-
-(defcommand "Delete Window" (p)
-  "Delete the current window, going to the previous window."
-  "Delete the window we are in, going to the previous window."
-  (declare (ignore p))
-  (when (= (length *window-list*) 2)
-    (editor-error "Cannot delete only window."))
-  (let ((window (current-window)))
-    (previous-window-command nil)  
-    (delete-window window)))
-
-(defcommand "Line to Top of Window" (p)
-  "Move current line to top of window."
-  "Move current line to top of window."
-  (declare (ignore p))
-  (with-mark ((mark (current-point)))
-    (move-mark (window-display-start (current-window)) (line-start mark))))
-
-(defcommand "Delete Next Window" (p)
-  "Deletes the next window on display."
-  "Deletes then next window on display."
-  (declare (ignore p))
-  (if (<= (length *window-list*) 2)
-      (editor-error "Cannot delete only window")
-      (delete-window (next-window (current-window)))))
-
-(defcommand "Go to One Window" (p)
-  "Deletes all windows leaving one with the \"Default Initial Window X\",
-   \"Default Initial Window Y\", \"Default Initial Window Width\", and
-   \"Default Initial Window Height\"."
-  "Deletes all windows leaving one with the \"Default Initial Window X\",
-   \"Default Initial Window Y\", \"Default Initial Window Width\", and
-   \"Default Initial Window Height\"."
-  (declare (ignore p))
-  (let ((win (make-window (window-display-start (current-window))
-			  :ask-user t
-			  :x (value default-initial-window-x)
-			  :y (value default-initial-window-y)
-			  :width (value default-initial-window-width)
-			  :height (value default-initial-window-height))))
-    (setf (current-window) win)
-    (dolist (w *window-list*)
-      (unless (or (eq w win)
-		  (eq w *echo-area-window*))
-	(delete-window w)))))
-
-(defcommand "Line to Center of Window" (p)
-  "Moves current line to the center of the window."
-  "Moves current line to the center of the window."
-  (declare (ignore p))
-  (center-window (current-window) (current-point)))
diff --git a/hemlock/files.lisp b/hemlock/files.lisp
deleted file mode 100644
index 14167a352e044e92baf33e63ccca6320c5ad3041..0000000000000000000000000000000000000000
--- a/hemlock/files.lisp
+++ /dev/null
@@ -1,202 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;; Hemlock File manipulation functions.
-;;; Written by Skef Wholey, Horribly Hacked by Rob MacLachlan.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(read-file write-file))
-
-
-
-;;; Read-File:
-
-(defun read-file (pathname mark)
-  "Inserts the contents of the file named by Pathname at the Mark."
-  (with-mark ((mark mark :left-inserting))
-    (let* ((tn (truename pathname))
-	   (name (namestring tn))
-	   (alien ())
-	   (size 0))
-      (declare (fixnum size))
-      (multiple-value-bind (fd err) (mach:unix-open name mach:o_rdonly 0)
-	(if (not (null fd))
-	    (multiple-value-bind (res dev ino mode nlnk uid gid rdev len)
-				 (mach:unix-fstat fd)
-	      (declare (ignore ino mode nlnk uid gid rdev))
-	      (setq err ())
-	      (if (null res)
-		  (setq err dev)
-		  (multiple-value-bind (gr addr)
-				       (mach::vm_allocate lisp::*task-self*
-							  0 len t)
-		    (gr-error 'mach::vm_allocate gr 'read-file)
-		    (setq alien (lisp::fixnum-to-sap addr))
-		    (setq size len)
-		    (multiple-value-bind
-			(bytes err3)
-			(mach:unix-read fd (lisp::fixnum-to-sap addr) len)
-		      (if (or (null bytes) (not (eq len bytes)))
-			  (setq err err3)))))
-	      (mach:unix-close fd)))
-	(if err (error "Reading file ~A, unix error ~A."
-		       name (mach:get-unix-error-msg err)))
-	(when (zerop size) (return-from read-file nil))
-	(let* ((sap alien)
-	       (first-line (mark-line mark))
-	       (buffer (line-%buffer first-line))
-	       (index (%primitive find-character sap 0 size #\newline)))
-	  (modifying-buffer buffer)
-	  (let* ((len (or index size))
-		 (chars (make-string len)))
-	    (%primitive byte-blt sap 0 chars 0 len)
-	    (insert-string mark chars))
-	  (when index
-	    (insert-character mark #\newline)
-	    (do* ((old-index (1+ (the fixnum index)) (1+ (the fixnum index)))
-		  (index (%primitive find-character sap old-index size
-				     #\newline)
-			 (%primitive find-character sap old-index size
-				     #\newline))
-		  (number (+ (line-number first-line) line-increment)
-			  (+ number line-increment))
-		  (previous first-line))
-		 ((not index)
-		  (let* ((length (- size old-index))
-			 (chars (make-string length))
-			 (line (mark-line mark)))
-		    (declare (fixnum length))
-		    (%primitive byte-blt sap old-index chars 0 length)
-		    (insert-string mark chars)
-		    (setf (line-next previous) line)
-		    (setf (line-previous line) previous)
-		    (do ((line line (line-next line))
-			 (number number (+ number line-increment)))
-			((null line))
-		      (declare (fixnum number))
-		      (setf (line-number line) number))))
-	      (declare (fixnum number old-index))
-	      (let ((line (make-line
-			   :previous previous
-			   :%buffer buffer
-			   :number number
-			   :chars (%primitive sap+ sap old-index)
-			   :buffered-p
-			   (the fixnum (- (the fixnum index) old-index)))))
-		(setf (line-next previous) line)
-		(setq previous line))) nil))))))
-
-
-;;; Hackish stuff for disgusting speed:
-
-(defun read-buffered-line (line)
-  (let* ((len (line-buffered-p line))
-  	 (chars (make-string len)))
-    (%primitive byte-blt (line-%chars line) 0 chars 0 len)
-    (setf (line-buffered-p line) nil)
-    (setf (line-chars line) chars)))
-
-
-
-;;; Write-File:
-
-(defun write-file (region pathname &key
-			  (keep-backup (value ed::keep-backup-files))
-			  access)
-  "Writes the characters in the Region to the file named by Pathname.
-   Region is written using a stream opened with :if-exists :rename-and-delete,
-   but keep-backup, when supplied as non-nil, causes :rename to be supplied
-   instead of :rename-and-delete.  Access is an implementation dependent value
-   that is suitable for setting pathname's access or protection bits."
-  (let ((if-exists-action (if keep-backup
-			      :rename
-			      :rename-and-delete)))
-    (with-open-file (file pathname :direction :output :element-type 'string-char
-			  :if-exists if-exists-action)
-      (close-line)
-      (fast-write-file region file))
-    (when access
-      (multiple-value-bind
-	  (winp code)
-	  ;; Must do a TRUENAME in case the file has never been written.
-	  ;; It may have Common Lisp syntax that Unix can't handle.
-	  ;; If this is ever moved to the beginning of this function to use
-	  ;; Unix CREAT to create the file protected initially, they TRUENAME
-	  ;; will signal an error, and LISP::PREDICT-NAME will have to be used.
-	  (mach:unix-chmod (namestring (truename pathname)) access)
-	(unless winp
-	  (error "Could not set access code: ~S"
-		 (mach:get-unix-error-msg code)))))))
-
-(proclaim '(special vm_page_size))
-
-(ext:def-c-variable "vm_page_size" int)
-
-(defvar *vm-page-size* (system:alien-access vm_page_size)
-  "Size, in bytes, of each VM page.")
-
-(defun fast-write-file (region file)
-  (let* ((start (region-start region))
-	 (start-line (mark-line start))
-	 (start-charpos (mark-charpos start))
-	 (end (region-end region))
-	 (end-line (mark-line end))
-	 (end-charpos (mark-charpos end)))
-    (if (eq start-line end-line)
-      (write-string (line-chars start-line) file
-		    :start start-charpos :end end-charpos)
-      (let* ((first-length (- (line-length start-line) start-charpos))
-	     (length (+ first-length end-charpos 1)))
-	(do ((line (line-next start-line) (line-next line)))
-	    ((eq line end-line))
-	  (incf length (1+ (line-length line))))
-	(let ((bytes (* *vm-page-size*
-			(ceiling length *vm-page-size*))))
-	  (system:gr-bind (address)
-			  (mach:vm_allocate system:*task-self* 0 bytes t)
-	    (unwind-protect
-		(let ((sap (system:int-sap address)))
-		  (macrolet ((chars (line)
-				    `(if (line-buffered-p ,line)
-				       (line-%chars ,line)
-				       (line-chars ,line))))
-		    (system:%primitive byte-blt
-				       (chars start-line) start-charpos
-				       sap 0 first-length)
-		    (system:%primitive 8bit-system-set
-				       sap first-length #\newline)
-		    (let ((offset (1+ first-length)))
-		      (do ((line (line-next start-line)
-				 (line-next line)))
-			  ((eq line end-line))
-			(let ((end (+ offset (line-length line))))
-			  (system:%primitive byte-blt
-					     (chars line) 0
-					     sap offset end)
-			  (system:%primitive 8bit-system-set
-					     sap end #\newline)
-			  (setf offset (1+ end))))
-		      (unless (zerop end-charpos)
-			(system:%primitive byte-blt
-					   (chars end-line) 0
-					   sap offset
-					   (+ offset end-charpos)))))
-		  (multiple-value-bind
-		      (okay errno)
-		      (mach:unix-write (system:fd-stream-fd file)
-				       sap 0 length)
-		    (unless okay
-		      (error "Could not write ~S: ~A"
-			     file
-			     (mach:get-unix-error-msg errno))))
-		  (system:gr-call mach:vm_deallocate system:*task-self*
-				  address bytes)))))))))
diff --git a/hemlock/fill.lisp b/hemlock/fill.lisp
deleted file mode 100644
index c609f764a7b92aa26708ca85307085aed4ffba65..0000000000000000000000000000000000000000
--- a/hemlock/fill.lisp
+++ /dev/null
@@ -1,738 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles
-;;;
-;;; This file contains the implementation of Auto Fill Mode.  Also,
-;;;   paragraph and region filling stuff is here.
-;;;
-
-(in-package "HEMLOCK")
-
-
-;;; Fill Mode should be defined with some transparent bindings (linefeed and
-;;; return) but with some that are not (space), so until this is possible, we
-;;; kludge this effect by altering Auto Fill Linefeed and Auto Fill Return.
-(defmode "Fill")
-
-
-
-;;;; -- Variables --
-
-(defhvar "Fill Column"
-  "Used to determine at what column to force text to the next line."
-  :value 75)
-
-(defhvar "Fill Prefix"
-  "String to put before each line when filling."
-  :value ())
-
-(defhvar "Auto Fill Space Indent"
-  "When non-nil, uses \"Indent New Comment Line\" to break lines instead of
-   \"New Line\".  However, if there is a fill prefix, it is still preferred."
-  :value nil)
-
-
-
-;;;; -- New Attributes --
-
-(defattribute "Paragraph Delimiter"
-  "is a character that delimits a paragraph by beginning a line."
-  '(mod 2)
-  0)
-
-
-;;; (setf (character-attribute :paragraph-delimiter #\@) 1)
-;;; (setf (character-attribute :paragraph-delimiter #\\) 1)
-;;; (setf (character-attribute :paragraph-delimiter #\/) 1)
-;;; (setf (character-attribute :paragraph-delimiter #\-) 1)
-;;; (setf (character-attribute :paragraph-delimiter #\') 1)
-;;; (setf (character-attribute :paragraph-delimiter #\.) 1)
-;;;    These are useful for making certain text formatting command lines
-;;; delimit paragraphs.  Anyway, this is what EMACS documentation states,
-;;; and #\' and #\. are always paragraph delimiters (don't ask me).
-
-(setf (character-attribute :paragraph-delimiter #\space) 1)
-(setf (character-attribute :paragraph-delimiter #\linefeed) 1)
-(setf (character-attribute :paragraph-delimiter #\formfeed) 1)
-(setf (character-attribute :paragraph-delimiter #\tab) 1)
-(setf (character-attribute :paragraph-delimiter #\newline) 1)
-
-
-
-(defattribute "Sentence Closing Char"
-  "is a delimiting character that may follow a sentence terminator
-   such as quotation marks and parentheses."
-  '(mod 2)
-  0)
-
-
-(setf (character-attribute :sentence-closing-char #\") 1)
-(setf (character-attribute :sentence-closing-char #\') 1)
-(setf (character-attribute :sentence-closing-char #\)) 1)
-(setf (character-attribute :sentence-closing-char #\]) 1)
-(setf (character-attribute :sentence-closing-char #\|) 1)
-(setf (character-attribute :sentence-closing-char #\>) 1)
-
-
-
-;;;; -- Commands --
-
-(defcommand "Auto Fill Mode" (p)
-  "Breaks lines between words at the right margin.
-   A positive argument turns Fill mode on, while zero or a negative
-   argument turns it off.  With no arguments, it is toggled.  When space
-   is typed, text that extends past the right margin is put on the next
-   line.  The right column is controlled by Fill Column."
-  "Determine if in Fill mode or not and set the mode accordingly."
-  (setf (buffer-minor-mode (current-buffer) "Fill")
-	(if p
-	    (plusp p)
-	    (not (buffer-minor-mode (current-buffer) "Fill")))))
-
-
-;;; This command should not have a transparent binding since it sometimes does
-;;; not insert a spaces, and transparency would propagate to "Self Insert".
-(defcommand "Auto Fill Space" (p)
-  "Insert space and a CRLF if text extends past margin.
-   If arg is 0, then may break line but will not insert the space.
-   If arg is positive, then inserts that many spaces without filling."
-  "Insert space and CRLF if text extends past margin.
-   If arg is 0, then may break line but will not insert the space.
-   If arg is positive, then inserts that many spaces without filling."
-  (let ((point (current-point)))
-    (check-fill-prefix (value fill-prefix) (value fill-column) point)
-    (cond ((and p (plusp p))
-	   (dotimes (x p) (insert-character point #\space)))
-	  ((and p (zerop p)) (%auto-fill-space point nil))
-	  (t (%auto-fill-space point t)))))
-
-
-(defcommand "Auto Fill Linefeed" (p)
-  "Does an immediate CRLF inserting Fill Prefix if it exists."
-  "Does an immediate CRLF inserting Fill Prefix if it exists."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (check-fill-prefix (value fill-prefix) (value fill-column) point)
-    (%auto-fill-space point nil)
-    ;; The remainder of this function should go away when
-    ;; transparent key bindings are per binding instead of
-    ;; per mode.
-    (multiple-value-bind (command t-bindings)
-			 (get-command #k"Linefeed" :current)
-      (declare (ignore command)) ;command is this one, so don't invoke it
-      (dolist (c t-bindings) (funcall *invoke-hook* c p)))
-    (indent-new-line-command nil)))
-
-
-
-(defcommand "Auto Fill Return" (p)
-  "Does an Auto Fill Space with a prefix argument of 0
-   followed by a newline."
-  "Does an Auto Fill Space with a prefix argument of 0
-   followed by a newline."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (check-fill-prefix (value fill-prefix) (value fill-column) point)
-    (%auto-fill-space point nil)
-    ;; The remainder of this function should go away when
-    ;; transparent key bindings are per binding instead of
-    ;; per mode.
-    (multiple-value-bind (command t-bindings)
-			 (get-command #k"Return" :current)
-      (declare (ignore command)) ;command is this one, so don't invoke it
-      (dolist (c t-bindings) (funcall *invoke-hook* c p)))
-    (new-line-command nil)))
-
-
-
-(defcommand "Fill Paragraph" (p)
-  "Fill this or next paragraph.
-   Point stays fixed, but text may move past it due to filling.
-   A paragraph is delimited by a blank line, a line beginning with a
-   special character (@,\,-,',and .), or it is begun with a line with at
-   least one whitespace character starting it.  Prefixes are ignored or
-   skipped over before determining if a line starts or delimits a
-   paragraph."
-  "Fill this or next paragraph.
-   Point stays fixed, but text may move past it due to filling."
-  (let* ((prefix (value fill-prefix))
-	 (prefix-len (length prefix))
-	 (column (if p (abs p) (value fill-column)))
-	 (point (current-point)))
-    (with-mark ((m point))
-      (let ((paragraphp (paragraph-offset m 1)))
-	(unless (or paragraphp
-		    (and (last-line-p m)
-			 (end-line-p m)
-			 (not (blank-line-p (mark-line m)))))
-	  (editor-error))
-	;;
-	;; start and end get deleted by the undo cleanup function
-	(let ((start (copy-mark m :right-inserting))
-	      (end (copy-mark m :left-inserting)))
-	  (%fill-paragraph-start start prefix prefix-len)
-	  (let* ((region (region start end))
-		 (undo-region (copy-region region)))
-	    (fill-region region prefix column)
-	    (make-region-undo :twiddle "Fill Paragraph" region undo-region)))))))
-
-
-(defcommand "Fill Region" (p)
-  "Fill text from point to mark."
-  "Fill text from point to mark."
-  (declare (ignore p))
-  (let* ((region (current-region))
-	 (prefix (value fill-prefix))
-	 (column (if p (abs p) (value fill-column))))
-    (check-fill-prefix prefix column (current-point))
-    (check-region-query-size region)
-    (fill-region-by-paragraphs region prefix column)))
-
-
-
-(defcommand "Set Fill Column" (p)
-  "Set Fill Column to current column or argument.
-   If argument is provided use its absolute value."
-  "Set Fill Column to current column or argument.
-   If argument is provided use its absolute value."
-  (let ((new-column (or (and p (abs p))
-			(mark-column (current-point)))))
-    (defhvar "Fill Column" "This buffer's fill column"
-      :value new-column  :buffer (current-buffer))
-    (message "Fill Column = ~D" new-column)))
-
-
-(defcommand "Set Fill Prefix" (p) 
-  "Define Fill Prefix from the current line.
-   All of the current line up to point is the prefix.  This may be
-   turned off by placing point at the beginning of a line when setting."
-  "Define Fill Prefix from the current line.
-   All of the current line up to point is the prefix.  This may be
-   turned off by placing point at the beginning of a line when setting."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (with-mark ((mark point))
-      (line-start mark)
-      (let ((val (if (mark/= mark point) (region-to-string (region mark point)))))
-	(defhvar "Fill Prefix" "This buffer's fill prefix"
-	  :value val  :buffer (current-buffer))
-	(message "Fill Prefix now ~:[empty~;~:*~S~]" val)))))
-
-
-;;;; -- Auto Filling --
-
-;;;      %AUTO-FILL-SPACE takes a point and an argument indicating
-;;; whether it should insert a space or not.  If point is past Fill
-;;; Column then text is filled. Usually  the else clause of the if
-;;; will be executed.  If the then clause is executed, then the first
-;;; branch of the COND will usually be executed.  The first branch
-;;; handles the case of the end of a word extending past Fill Column
-;;; while the second handles whitespace preceded by non-whitespace
-;;; extending past the Fill Column.  The last branch is for those who
-;;; like to whitespace out a blank line.
-
-(defun %auto-fill-space (point insertp)
-  "Insert space, but CRLF if text extends past margin.
-   If arg is 0, then may break line but will not insert the space.
-   If arg is positive, then inserts that many spaces without filling."
-  (if (> (mark-column point) (value fill-column))
-      (with-mark ((mark1 point :left-inserting))
-	(let ((not-all-blank (reverse-find-attribute mark1 :whitespace #'zerop))
-	      (prefix (value fill-prefix))
-	      (column (value fill-column)))
-	  (cond ((and not-all-blank (mark= point mark1))
-		 (%auto-fill-word-past-column point mark1 insertp prefix column))
-		((and not-all-blank (same-line-p mark1 point))
-		 (delete-region (region mark1 point))
-		 (if (> (mark-column point) column)
-		     (%auto-fill-word-past-column point mark1 insertp prefix column)
-		     (%filling-set-next-line point nil prefix)))
-		(t
-		 (line-start mark1 (mark-line point))
-		 (delete-region (region mark1 point))
-		 (%filling-set-next-line point nil prefix)))))
-      (if insertp (insert-character point #\space))))
-
-
-
-;;;      %AUTO-FILL-WORD-PAST-COLUMN takes a point, a second mark that is
-;;; mark= at the end of some word, and an indicator of whether a space
-;;; should be inserted or not.  First, point is moved before the previous
-;;; "word."  If the word is effectively the only word on the line, it
-;;; should not be moved down to the next line as it will leave a blank
-;;; line.  The third branch handles when the typing began in the middle of
-;;; some line (that is, right in front of some word).  Note that the else
-;;; clause is the usual case.
-
-(defun %auto-fill-word-past-column (point mark1 insertp prefix column)
-  (let ((point-moved-p (reverse-find-attribute point :whitespace)))
-    (with-mark ((mark2 point :left-inserting))
-      (cond ((or (not point-moved-p)
-		 (%auto-fill-blank-before-p point prefix))
-	     (move-mark point mark1)
-	     (%filling-set-next-line point nil prefix))
-	    ((%auto-fill-line-as-region-p point mark2 column)
-	     (if (and insertp
-		      (not (or (end-line-p mark1)
-			       (whitespace-attribute-p (next-character mark1)))))
-		 (insert-character mark1 #\space))
-	     (auto-fill-line-as-region point (move-mark mark2 point) prefix column)
-	     (move-mark point mark1)
-	     (if (and insertp (end-line-p point))
-		 (insert-character point #\space)))
-	    ((not (or (end-line-p mark1)
-		      (whitespace-attribute-p (next-character mark1))))
-	     (insert-character mark1 #\space)
-	     (%filling-set-next-line point nil prefix)
-	     (mark-after point)
-	     (%auto-fill-clean-previous-line mark1 mark2))
-	    (t
-	     (%filling-set-next-line point insertp prefix)
-	     (%auto-fill-clean-previous-line mark1 mark2))))))
-
-
-
-;;; AUTO-FILL-LINE-AS-REGION basically grabs a line as a region and fills
-;;; it.  However, it knows about comments and makes auto filling a comment
-;;; line as a region look the same as a typical "back up a word and break
-;;; the line."  When there is a comment, then region starts where the
-;;; comment starts instead of the beginning of the line, but the presence
-;;; of a prefix overrides all this.
-
-(defun auto-fill-line-as-region (point mark prefix column)
-  (let* ((start (value comment-start))
-	 (begin (value comment-begin))
-	 (end (value comment-end)))
-    (line-start mark)
-    (cond ((and (not prefix) start (to-line-comment mark start))
-	   (fill-region (region mark (line-end point))
-			(gen-comment-prefix mark start begin)
-			column)
-	   (when end
-	     (line-start point)
-	     (do ()
-		 ((mark>= mark point))
-	       (if (not (to-comment-end mark end)) (insert-string mark end))
-	       (line-offset mark 1 0))))	   
-	  (t (fill-region (region mark (line-end point)) prefix column)))))
-
-
-
-(defun %auto-fill-blank-before-p (point prefix)
-  "is true if whitespace only precedes point except for the prefix."
-  (or (blank-before-p point)
-      (with-mark ((temp point))
-	(reverse-find-attribute temp :whitespace #'zerop)
-	(<= (mark-column temp) (length prefix)))))
-
-
-
-;;;      %AUTO-FILL-LINE-AS-REGION-P determines if the line point and mark2
-;;; sit on is so long that it might as well be filled as if it were a
-;;; region.  Mark2 is mark= to point at the beginning of the last word on
-;;; the line and is then moved over the whitespace before point.  If the
-;;; word end prior the last word on the line is on the same line and not
-;;; before column, then fill the line as a region.
-
-(defun %auto-fill-line-as-region-p (point mark2 column)
-  (reverse-find-attribute mark2 :whitespace #'zerop)
-  (and (same-line-p mark2 point)
-       (> (mark-column mark2) column)))
-
-
-
-(defun %auto-fill-clean-previous-line (mark1 mark2)
-  (when (line-offset mark1 -1)
-    (line-end mark1)
-    (move-mark mark2 mark1)
-    (unless (and (reverse-find-attribute mark1 :whitespace #'zerop)
-		 (same-line-p mark1 mark2))
-      (line-start mark1 (mark-line mark2)))
-    (delete-region (region mark1 mark2))))
-
-
-
-;;; %FILLING-SET-NEXT-LINE gets a new blank line and sets it up with the
-;;; prefix and places the point correctly.  The argument point must alias
-;;; (current-point).
-
-(defun %filling-set-next-line (point insertp prefix)
-  (cond ((and (value auto-fill-space-indent) (not prefix))
-	 (indent-new-comment-line-command nil))
-	(t (new-line-command nil)
-	   (if prefix (insert-string point prefix))))
-  (if (not (find-attribute point :whitespace)) (line-end point))
-  (if insertp (insert-character point #\space)))
-
-
-
-;;;; -- Paragraph Filling --
-
-
-;;;      %FILL-PARAGRAPH-START takes a mark that has just been moved
-;;; forward over some paragraph.  After moving to the beginning of it, we
-;;; place the mark appropriately for filling the paragraph as a region.
-
-(defun %fill-paragraph-start (mark prefix prefix-len)
-  (paragraph-offset mark -1)
-  (skip-prefix-if-here mark prefix prefix-len)
-  (if (text-blank-line-p mark)
-      (line-offset mark 1 0)
-      (line-start mark)))
-
-
-
-;;;; -- Region Filling --
-
-
-;;;      FILL-REGION-BY-PARAGRAPHS finds paragraphs and uses region filling
-;;; primitives to fill them.  Tmark2 is only used for the first paragraph; we
-;;; need a mark other than start in case start is in the middle of a paragraph
-;;; instead of between two.
-;;;
-(defun fill-region-by-paragraphs (region &optional
-					 (prefix (value fill-prefix))
-					 (column (value fill-column)))
-  "Finds paragraphs in region and fills them as distinct regions using
-   FILL-REGION."
-  (with-mark ((start (region-start region) :left-inserting))
-    (with-mark ((tmark1 start :left-inserting)
-		(tmark2 start :left-inserting)) ;only used for first para.
-      (let ((region (region (copy-mark (region-start region)) ;deleted by undo.
-			    (copy-mark (region-end region))))
-	    (undo-region (copy-region region))
-	    (end (region-end region))
-	    (prefix-len (length prefix))
-	    (paragraphp (paragraph-offset tmark1 1)))
-	(when paragraphp
-	  (%fill-paragraph-start (move-mark tmark2 tmark1) prefix prefix-len)
-	  (if (mark>= tmark2 start) (move-mark start tmark2))
-	  (cond ((mark>= tmark1 end)
-		 (fill-region-aux start end prefix prefix-len column))
-		(t
-		 (fill-region-aux start tmark1 prefix prefix-len column)
-		 (do ((paragraphp (mark-paragraph start tmark1)
-				  (mark-paragraph start tmark1)))
-		     ((not paragraphp))
-		   (if (mark> start end)
-		       (return)
-		       (cond ((mark>= tmark1 end)
-			      (fill-region-aux start end prefix
-					       prefix-len column)
-			      (return))
-			     (t (fill-region-aux start tmark1
-						 prefix prefix-len column))))))))
-	(make-region-undo :twiddle "Fill Region" region undo-region)))))
-
-(defun fill-region (region &optional
-			   (prefix (value fill-prefix))
-			   (column (value fill-column)))
-  "Fills a region using the given prefix and column."
-  (let ((prefix (if (and prefix (string= prefix "")) () prefix)))
-    (with-mark ((start (region-start region) :left-inserting))
-      (check-fill-prefix prefix column start)
-      (fill-region-aux start (region-end region)
-		       prefix (length prefix) column))))
-
-
-
-;;;      FILL-REGION-AUX grinds over a region between fill-mark and
-;;; end-mark deleting blank lines and filling lines.  For each line, the
-;;; extra whitespace between words is collapsed to one space, and at the
-;;; end and beginning of the line it is deleted.  We do not return after
-;;; realizing that fill-mark is after end-mark if the line needs to be
-;;; broken; it may be the case that there are several filled line lengths
-;;; of material before end-mark on the current line.
-
-(defun fill-region-aux (fill-mark end-mark prefix prefix-len column)
-  (if (and (start-line-p fill-mark) prefix)
-      (fill-region-prefix-line fill-mark prefix prefix-len))
-  (with-mark ((mark1 fill-mark :left-inserting)
-	      (cmark fill-mark :left-inserting))
-    (do ((collapse-p t))
-	(nil)
-      (line-end fill-mark)
-      (line-start (move-mark mark1 fill-mark))
-      (skip-prefix-if-here mark1 prefix prefix-len)
-      (cond ((mark>= fill-mark end-mark)
-	     (if (mark= fill-mark end-mark)
-		 (fill-region-clear-eol fill-mark))
-	     (cond ((> (mark-column end-mark) column)
-		    (when collapse-p
-		      (fill-region-collapse-whitespace cmark end-mark)
-		      (setf collapse-p nil))
-		    (fill-region-break-line fill-mark prefix
-					    prefix-len end-mark column))
-		   (t (return))))
-	    ((blank-after-p mark1)
-	     (fill-region-delete-blank-lines fill-mark end-mark prefix prefix-len)
-	     (cond ((mark< fill-mark end-mark)
-		    (if prefix
-			(fill-region-prefix-line fill-mark prefix prefix-len))
-		    (fill-region-clear-bol fill-mark)
-		    (move-mark cmark fill-mark))
-		   (t (return)))
-	     (setf collapse-p t))
-	    (t (fill-region-clear-eol fill-mark)
-	       (if collapse-p (fill-region-collapse-whitespace cmark fill-mark))
-	       (cond ((> (mark-column fill-mark) column)
-		      (fill-region-break-line fill-mark prefix
-					      prefix-len end-mark column)
-		      (setf collapse-p nil))
-		     (t (fill-region-get-next-line fill-mark column
-						   prefix prefix-len end-mark)
-			(move-mark cmark fill-mark)
-			(setf collapse-p t))))))
-    (move-mark fill-mark end-mark)))
-
-
-
-;;;      FILL-REGION-BREAK-LINE breaks lines as close to the low side
-;;; column as possible.  The first branch handles a word lying across
-;;; column while the second takes care of whitespace passing column.  If
-;;; FILL-REGION-WORD-PAST-COLUMN encountered a single word stretching over
-;;; column, it would leave an extra opened line that needs to be cleaned up
-;;; or filled up.
-
-(defun fill-region-break-line (fill-mark prefix prefix-length
-					  end-mark column)
-  (with-mark ((mark1 fill-mark :left-inserting))
-    (move-to-column mark1 column)
-    (cond ((not (whitespace-attribute-p (next-character mark1)))
-	   (if (not (find-attribute mark1 :whitespace))
-	       (line-end mark1))
-	   (move-mark fill-mark mark1)
-	   (if (eq (fill-region-word-past-column fill-mark mark1 prefix)
-		   :handled-oversized-word)
-	       (if (mark>= fill-mark end-mark)
-		   (delete-characters (line-start fill-mark)
-				      prefix-length)
-		   (delete-characters fill-mark 1))))
-	  (t (move-mark fill-mark mark1)
-	     (unless (and (reverse-find-attribute mark1 :whitespace #'zerop)
-			  (same-line-p mark1 fill-mark))
-	       (line-start mark1 (mark-line fill-mark)))
-	     ;; forward find must move mark because of cond branch we are in.
-	     (find-attribute fill-mark :whitespace #'zerop)
-	     (unless (same-line-p mark1 fill-mark)
-	       (line-end fill-mark (mark-line mark1)))
-	     (delete-region (region mark1 fill-mark))
-	     (insert-character fill-mark #\newline)
-	     (if prefix (insert-string fill-mark prefix))))))
-
-
-
-;;;      FILL-REGION-WORD-PAST-COLUMN takes a point and a second mark that
-;;; is mark= at the end of some word.  First, point is moved before the
-;;; previous "word."  If the word is effectively the only word on the line,
-;;; it should not be moved down to the next line as it will leave a blank
-;;; line.
-
-(defun fill-region-word-past-column (point mark1 prefix)
-  (with-mark ((mark2 (copy-mark point :left-inserting)))
-    (let ((point-moved-p (reverse-find-attribute point :whitespace))
-	  (hack-for-fill-region :handled-normal-case))
-      (cond ((or (not point-moved-p)
-		 (%auto-fill-blank-before-p point prefix))
-	     (setf hack-for-fill-region :handled-oversized-word)
-	     (move-mark point mark1)
-	     (fill-region-set-next-line point prefix))
-	    (t (fill-region-set-next-line point prefix)
-	       (%auto-fill-clean-previous-line mark1 mark2)))
-      hack-for-fill-region)))
-
-(defun fill-region-set-next-line (point prefix)
-  (insert-character point #\newline)
-  (if prefix (insert-string point prefix))
-  (if (not (find-attribute point :whitespace)) (line-end point)))
-
-
-
-;;;      FILL-REGION-GET-NEXT-LINE gets another line when the current one
-;;; is short of the fill column.  It cleans extraneous whitespace from the
-;;; beginning of the next line to fill.  To save typical redisplay the
-;;; length of the first word is added to the ending column of the current
-;;; line to see if it extends past the fill column; if it does, then the
-;;; fill-mark is left on the new line instead of merging the new line with
-;;; the current one.  The fill-mark is left after a prefix (if there is one)
-;;; on a new line, before the first word brought up to the current line, or
-;;; after the end mark.
-
-(defun fill-region-get-next-line (fill-mark column prefix prefix-len end-mark)
-  (let ((prev-end-pos (mark-column fill-mark))
-	(two-spaces-p (fill-region-insert-two-spaces-p fill-mark)))
-    (with-mark ((tmark fill-mark :left-inserting))
-      (fill-region-find-next-line fill-mark prefix prefix-len end-mark)
-      (move-mark tmark fill-mark)
-      (cond ((mark< fill-mark end-mark)
-	     (skip-prefix-if-here tmark prefix prefix-len)
-	     (fill-region-clear-bol tmark)
-	     (let ((beginning-pos (mark-column tmark)))
-	       (find-attribute tmark :whitespace)
-	       (cond ((> (+ prev-end-pos (if two-spaces-p 2 1)
-			    (- (mark-column tmark) beginning-pos))
-			 column)
-		      (if prefix
-			  (fill-region-prefix-line fill-mark prefix prefix-len)))
-		     (t
-		      (if (and prefix
-			       (%line-has-prefix-p fill-mark prefix prefix-len))
-			  (delete-characters fill-mark prefix-len))
-		      (delete-characters fill-mark -1)
-		      (insert-character fill-mark #\space)
-		      (if two-spaces-p (insert-character fill-mark #\space))))))
-	    (t
-	     (mark-after fill-mark))))))
-
-
-
-;;;      FILL-REGION-FIND-NEXT-LINE finds the next non-blank line, modulo
-;;; fill prefixes, and deletes the intervening lines.  Fill-mark is left at
-;;; the beginning of the next line.
-
-(defun fill-region-find-next-line (fill-mark prefix prefix-len end-mark)
-  (line-offset fill-mark 1 0)
-  (when (mark< fill-mark end-mark)
-    (skip-prefix-if-here fill-mark prefix prefix-len)
-    (if (blank-after-p fill-mark)
-	(fill-region-delete-blank-lines fill-mark end-mark prefix prefix-len)
-	(line-start fill-mark))))
-
-
-
-;;;      FILL-REGION-DELETE-BLANK-LINES deletes the blank line mark is on
-;;; and all successive blank lines.  Mark is left at the beginning of the
-;;; first non-blank line by virtue of its placement and region deletions.
-
-(defun fill-region-delete-blank-lines (mark end-mark prefix prefix-len)
-  (line-start mark)
-  (with-mark ((tmark mark :left-inserting))
-    (do ((linep (line-offset tmark 1 0) (line-offset tmark 1 0)))
-	((not linep)
-	 (move-mark tmark end-mark)
-	 (delete-region (region mark tmark)))
-      (skip-prefix-if-here tmark prefix prefix-len)
-      (when (mark>= tmark end-mark)
-	(move-mark tmark end-mark)
-	(delete-region (region mark tmark))
-	(return))
-      (unless (blank-after-p tmark)
-	(line-start tmark)
-	(delete-region (region mark tmark))
-	(return)))))
-
-
-
-;;;      FILL-REGION-CLEAR-BOL clears the initial whitespace on a line
-;;; known to be non-blank.  Note that the fill prefix is not considered, so
-;;; the mark must have been moved over it already if there is one.
-
-(defun fill-region-clear-bol (mark)
-  (with-mark ((tmark mark :left-inserting))
-    (find-attribute tmark :whitespace #'zerop)
-    (unless (mark= mark tmark)
-      (delete-region (region mark tmark)))))
-
-
-
-;;;      FILL-REGION-COLLAPSE-WHITESPACE deletes extra whitespace between
-;;; blocks of non-whitespace characters from mark1 to mark2.  Tabs are
-;;; converted into a single space.  Mark2 must be on the same line as mark1
-;;; since there is no concern of newlines, prefixes on a new line, blank
-;;; lines between blocks of non-whitespace characters, etc.
-
-(defun fill-region-collapse-whitespace (mark1 mark2)
-  (with-mark ((tmark mark1 :left-inserting))
-    ;; skip whitespace at beginning of line or single space between words
-    (find-attribute mark1 :whitespace #'zerop)
-    (unless (mark>= mark1 mark2)
-      (do ()
-	  (nil)
-	(if (not (find-attribute mark1 :whitespace)) ;not end of buffer
-	    (return))
-	(if (mark>= mark1 mark2) (return))
-	(if (char/= (next-character mark1) #\space)
-	    ;; since only on one line, must be tab or space
-	    (setf (next-character mark1) #\space))
-	(move-mark tmark mark1)
-	(if (mark= (mark-after mark1) mark2) (return))
-	(let ((char (next-character mark1)))
-	  (when (and (fill-region-insert-two-spaces-p tmark)
-		     (char= char #\space))
-	    ;; if at the end of a sentence, don't blow away the second space
-	    (if (mark= (mark-after mark1) mark2)
-		(return)
-		(setf char (next-character mark1))))
-	  (when (whitespace-attribute-p char) ;more whitespace than necessary
-	    (find-attribute (move-mark tmark mark1) :whitespace #'zerop)
-	    (if (mark>= tmark mark2) (move-mark tmark mark2))
-	    (delete-region (region mark1 tmark))))))))
-
-
-
-;;;      FILL-REGION-CLEAR-EOL must check the result of
-;;; REVERSE-FIND-ATTRIBUTE because if fill-mark did not move, then we are
-;;; only whitespace away from the beginning of the buffer.
-
-(defun fill-region-clear-eol (fill-mark)
-  (with-mark ((mark1 fill-mark :left-inserting))
-    (unless (and (reverse-find-attribute mark1 :whitespace #'zerop)
-		 (same-line-p mark1 fill-mark))
-      (line-start mark1 (mark-line fill-mark)))
-    (delete-region (region mark1 fill-mark))))
-
-
-
-(defun fill-region-prefix-line (fill-mark prefix prefix-length)
-  (if (%line-has-prefix-p fill-mark prefix prefix-length)
-      (character-offset fill-mark prefix-length)
-      (insert-string fill-mark prefix)))
-
-
-
-(defun %line-has-prefix-p (mark prefix prefix-length)
-  (declare (simple-string prefix))
-  (if (>= (line-length (mark-line mark)) prefix-length)
-      (string= prefix (the simple-string (line-string (mark-line mark)))
-	       :end2 prefix-length)))
-
-
-
-;;;      FILL-REGION-INSERT-TWO-SPACES-P returns true if a sentence
-;;; terminator is followed by any number of "closing characters" such as
-;;; ",',),etc.  If there is a sentence terminator at the end of the current
-;;; line, it must be assumed to be the end of a sentence as opposed to an
-;;; abbreviation.  Why?  Because EMACS does, and besides, what would Lisp
-;;; code be without heuristics.
-
-(defun fill-region-insert-two-spaces-p (mark)
-  (do ((n 0 (1+ n)))
-      ((not (sentence-closing-char-attribute-p (previous-character mark)))
-       (cond ((sentence-terminator-attribute-p (previous-character mark))
-	      (character-offset mark n))
-	     (t (character-offset mark n) nil)))
-    (mark-before mark)))
-
-
-
-(defun check-fill-prefix (prefix column mark)
-  (when prefix
-    (insert-character mark #\newline)
-    (insert-character mark #\newline)
-    (mark-before mark)
-    (insert-string mark prefix)
-    (let ((pos (mark-column mark)))
-      (declare (simple-string prefix))
-      (mark-after mark)
-      (delete-characters mark (- (+ (length prefix) 2)))
-      (if (>= pos column)
-	  (editor-error
-	   "The fill prefix length is longer than the fill column.")))))
diff --git a/hemlock/font.lisp b/hemlock/font.lisp
deleted file mode 100644
index 21e2899a59c0e4bd03d6809dde2984080018b717..0000000000000000000000000000000000000000
--- a/hemlock/font.lisp
+++ /dev/null
@@ -1,122 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/font.lisp,v 1.2 1991/02/08 16:34:42 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Rob MacLachlan
-;;; Modified by Bill Chiles toward Hemlock running under X.
-;;;
-;;;    This file contains various functions that make up the user interface to
-;;; fonts.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(font-mark delete-font-mark delete-line-font-marks move-font-mark
-		    window-font))
-;;; Default-font used to be in the above list, but when I cleaned up the way
-;;; Hemlock compiles, a name conflict occurred because "Default Font" is a
-;;; Hemlock variable.  It is now exported by the export list in rompsite.lisp.
-
-(defvar *default-font-family* (make-font-family))
-
-
-
-;;;; Creating, Deleting, and Moving.
-
-(defun font-mark (line charpos font &optional (kind :right-inserting))
-  "Returns a font on line at charpos with font.  Font marks must be permanent
-   marks."
-  (unless (or (eq kind :right-inserting) (eq kind :left-inserting))
-    (error "A Font-Mark must be :left-inserting or :right-inserting."))
-  (unless (and (>= font 0) (< font font-map-size))
-    (error "Font number ~S out of range." font))
-  (let ((new (internal-make-font-mark line charpos kind font)))
-    (new-font-mark new line)
-    (push new (line-marks line))
-    new))
-
-(defun delete-font-mark (font-mark)
-  "Deletes a font mark."
-  (check-type font-mark font-mark)
-  (let ((line (mark-line font-mark)))
-    (when line
-      (setf (line-marks line) (delq font-mark (line-marks line)))
-      (nuke-font-mark font-mark line)
-      (setf (mark-line font-mark) nil))))
-
-(defun delete-line-font-marks (line)
-  "Deletes all font marks on line."
-  (dolist (m (line-marks line))
-    (when (fast-font-mark-p m)
-      (delete-font-mark m))))
-
-(defun move-font-mark (font-mark new-position)
-  "Moves font mark font-mark to location of mark new-position."
-  (check-type font-mark font-mark)
-  (let ((old-line (mark-line font-mark))
-	(new-line (mark-line new-position)))
-    (nuke-font-mark font-mark old-line)
-    (move-mark font-mark new-position)
-    (new-font-mark font-mark new-line)
-    font-mark))
-
-(defun nuke-font-mark (mark line)
-  (new-font-mark mark line))
-
-(defun new-font-mark (mark line)
-  (declare (ignore mark))
-  (let ((buffer (line-%buffer line))
-	(number (line-number line)))
-    (when (bufferp buffer)
-      (dolist (w (buffer-windows buffer))
-	(setf (window-tick w) (1- (buffer-modified-tick buffer)))
-	(let ((first (cdr (window-first-line w))))
-	  (unless (or (> (line-number (dis-line-line (car first))) number)
-		      (> number
-			 (line-number
-			  (dis-line-line (car (window-last-line w))))))
-	    (do ((dl first (cdr dl)))
-		((or (null dl)
-		     (eq (dis-line-line (car dl)) line))
-		 (when dl
-		   (setf (dis-line-old-chars (car dl)) :font-change))))))))))
-
-
-
-;;;; Referencing and setting font ids.
-
-(defun window-font (window font)
-  "Returns a font id for window and font."
-  (svref (font-family-map (bitmap-hunk-font-family (window-hunk window))) font))
-
-(defun %set-window-font (window font font-object)
-  (unless (and (>= font 0) (< font font-map-size))
-    (error "Font number ~S out of range." font))
-  (setf (bitmap-hunk-trashed (window-hunk window)) :font-change)
-  (let ((family (bitmap-hunk-font-family (window-hunk window))))
-    (when (eq family *default-font-family*)
-      (setq family (copy-font-family family))
-      (setf (font-family-map family) (copy-seq (font-family-map family)))
-      (setf (bitmap-hunk-font-family (window-hunk window)) family))
-    (setf (svref (font-family-map family) font) font-object)))
-
-(defun default-font (font)
-  "Returns the font id for font out of the default font family."
-  (svref (font-family-map *default-font-family*) font))
-
-(defun %set-default-font (font font-object)
-  (unless (and (>= font 0) (< font font-map-size))
-    (error "Font number ~S out of range." font))
-  (dolist (w *window-list*)
-    (when (eq (bitmap-hunk-font-family (window-hunk w)) *default-font-family*)
-      (setf (bitmap-hunk-trashed (window-hunk w)) :font-change)))
-  (setf (svref (font-family-map *default-font-family*) font) font-object))
diff --git a/hemlock/gosmacs.lisp b/hemlock/gosmacs.lisp
deleted file mode 100644
index 2296bfe5d0a5a9168c69a71a3f38bc611bc8e1ba..0000000000000000000000000000000000000000
--- a/hemlock/gosmacs.lisp
+++ /dev/null
@@ -1,35 +0,0 @@
-;;; -*- Package: Hemlock; Log: Hemlock.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/gosmacs.lisp,v 1.3 1991/02/14 00:25:34 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Stuff in this file provides some degree of upward compatibility
-;;; for incurable Gosling Emacs users.
-;;;
-(in-package "HEMLOCK")
-
-(defcommand "Gosmacs Permute Characters" (p)
-  "Transpose the two characters before the point."
-  "Transpose the two characters before the point."
-  (declare (ignore p))
-  (with-mark ((m (current-point) :left-inserting))
-    (unless (and (mark-before m) (previous-character m))
-      (editor-error "NIB     You have addressed a character not in the buffer?"))
-    (rotatef (previous-character m) (next-character m))))
-
-(bind-key "Gosmacs Permute Characters" #k"control-t")
-(bind-key "Kill Previous Word" #k"meta-h")
-(bind-key "Replace String" #k"meta-r")
-(bind-key "Query Replace" #k"meta-q")
-(bind-key "Fill Paragraph" #k"meta-j")
-(bind-key "Visit File" #k"control-x control-r")
-(bind-key "Find File" #k"control-x control-v")
-(bind-key "Insert File" #k"control-x control-i")
diff --git a/hemlock/group.lisp b/hemlock/group.lisp
deleted file mode 100644
index d03c6714a1e4b6726575e17434b11d6db2c33023..0000000000000000000000000000000000000000
--- a/hemlock/group.lisp
+++ /dev/null
@@ -1,237 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/group.lisp,v 1.1.1.2 1991/02/08 16:34:45 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; File group stuff for Hemlock.
-;;; Written by Skef Wholey and Rob MacLachlan.
-;;;
-;;;    The "Compile Group" and "List Compile Group" commands in lispeval
-;;;    also know about groups.
-;;;
-;;; This file provides Hemlock commands for manipulating groups of files
-;;; that make up a larger system.  A file group is a set of files whose
-;;; names are listed in some other file.  At any given time one group of
-;;; files is the Active group.  The Select Group command makes a group the
-;;; Active group, prompting for the name of a definition file if the group
-;;; has not been selected before.  Once a group has been selected once, the
-;;; name of the definition file associated with that group is retained.  If
-;;; one wishes to change the name of the definition file after a group has
-;;; been selected, one should call Select Group with a prefix argument.
-
-(in-package 'hemlock)
-
-(defvar *file-groups* (make-string-table)
-  "A string table of file groups.")
-
-(defvar *active-file-group* ()
-  "The list of files in the currently active group.")
-
-(defvar *active-file-group-name* ()
-  "The name of the currently active group.")
-
-
-
-;;;; Selecting the active group.
-
-(defcommand "Select Group" (p)
-  "Makes a group the active group.  With a prefix argument, changes the
-  definition file associated with the group."
-  "Makes a group the active group."
-  (let* ((group-name
-	  (prompt-for-keyword
-	   (list *file-groups*)
-	   :must-exist nil
-	   :prompt "Select Group: "
-	   :help
-	   "Type the name of the file group you wish to become the active group."))
-	 (old (getstring group-name *file-groups*))
-	 (pathname
-	  (if (and old (not p))
-	      old
-	      (prompt-for-file :must-exist t
-			       :prompt "From File: "
-			       :default (merge-pathnames
-					 (make-pathname
-					  :name group-name
-					  :type "upd")
-					 (value pathname-defaults))))))
-    (setq *active-file-group-name* group-name)
-    (setq *active-file-group* (nreverse (read-file-group pathname nil)))
-    (setf (getstring group-name *file-groups*) pathname)))
-
-
-;;; READ-FILE-GROUP reads an Update format file and returns a list of pathnames
-;;; of the files named in that file.  This guy knows about @@ indirection and
-;;; ignores empty lines and lines that begin with @ but not @@.  A simpler
-;;; scheme could be used for non-Spice implementations, but all this hair is
-;;; probably useful, so Update format may as well be a standard for this sort
-;;; of thing.
-;;;
-(defun read-file-group (pathname tail)
-  (with-open-file (file pathname)
-    (do* ((name (read-line file nil nil) (read-line file nil nil))
-	  (length (if name (length name)) (if name (length name))))
-	 ((null name) tail)
-      (declare (type (or simple-string null) name))
-      (cond ((zerop length))
-	    ((char= (char name 0) #\@)
-	     (when (and (> length 1) (char= (char name 1) #\@))
-	       (setq tail (read-file-group
-			   (merge-pathnames (subseq name 2)
-					    pathname)
-			   tail))))
-	    (t
-	     (push (merge-pathnames (pathname name) pathname) tail))))))
-
-
-
-;;;; DO-ACTIVE-GROUP.
-
-(defhvar "Group Find File"
-  "If true, group commands use \"Find File\" to read files, otherwise
-  non-resident files are read into the \"Group Search\" buffer."
-  :value nil)
-
-(defhvar "Group Save File Confirm"
-  "If true, then the group commands will ask for confirmation before saving
-  a modified file." :value t)
-
-(defmacro do-active-group (&rest forms)
-  "This iterates over the active file group executing forms once for each
-   file.  When forms are executed, the file will be in the current buffer,
-   and the point will be at the start of the file."
-  (let ((n-buf (gensym))
-	(n-start-buf (gensym))
-	(n-save (gensym)))
-    `(progn
-       (unless *active-file-group*
-	 (editor-error "There is no active file group."))
-
-       (let ((,n-start-buf (current-buffer))
-	     (,n-buf nil))
-	 (unwind-protect
-	     (dolist (file *active-file-group*)
-	       (catch 'file-not-found
-		 (setq ,n-buf (group-read-file file ,n-buf))
-		 (with-mark ((,n-save (current-point) :right-inserting))
-		   (unwind-protect
-		       (progn
-			 (buffer-start (current-point))
-			 ,@forms)
-		     (move-mark (current-point) ,n-save)))
-		 (group-save-file)))
-	   (if (member ,n-start-buf *buffer-list*)
-	       (setf (current-buffer) ,n-start-buf
-		     (window-buffer (current-window)) ,n-start-buf)
-	       (editor-error "Original buffer deleted!")))))))
-
-;;; GROUP-READ-FILE reads in files for the group commands via DO-ACTIVE-GROUP.
-;;; We use FIND-FILE-BUFFER, which creates a new buffer when the file hasn't
-;;; already been read, to get files in, and then we delete the buffer if it is
-;;; newly created and "Group Find File" is false.  This lets FIND-FILE-BUFFER
-;;; do all the work.  We don't actually use the "Find File" command, so the
-;;; buffer history isn't affected.
-;;;
-;;; Search-Buffer is any temporary search buffer left over from the last file
-;;; that we want deleted.  We don't do the deletion if the buffer is modified.
-;;;
-(defun group-read-file (name search-buffer)
-  (unless (probe-file name)
-    (message "File ~A not found." name)
-    (throw 'file-not-found nil))
-  (multiple-value-bind (buffer created-p)
-		       (find-file-buffer name)
-    (setf (current-buffer) buffer)
-    (setf (window-buffer (current-window)) buffer)
-
-    (when (and search-buffer (not (buffer-modified search-buffer)))
-      (dolist (w (buffer-windows search-buffer))
-	(setf (window-buffer w) (current-buffer)))
-      (delete-buffer search-buffer))
-
-    (if (and created-p (not (value group-find-file)))
-	(current-buffer) nil)))
-
-;;; GROUP-SAVE-FILE is used by DO-ACTIVE-GROUP.
-;;;
-(defun group-save-file ()
-  (let* ((buffer (current-buffer))
-	 (pn (buffer-pathname buffer))
-	 (name (namestring pn)))
-    (when (and (buffer-modified buffer)
-	       (or (not (value group-save-file-confirm))
-		   (prompt-for-y-or-n
-		    :prompt (list "Save changes in ~A? " name)
-		    :default t)))
-      (save-file-command ()))))
-
-
-
-;;;; Searching and Replacing commands.
-
-(defcommand "Group Search" (p)
-  "Searches the active group for a specified string, which is prompted for."
-  "Searches the active group for a specified string."
-  (declare (ignore p))
-  (let ((string (prompt-for-string :prompt "Group Search: "
-				   :help "String to search for in active file group"
-				   :default *last-search-string*)))
-    (get-search-pattern string :forward)
-    (do-active-group
-     (do ((won (find-pattern (current-point) *last-search-pattern*)
-	       (find-pattern (current-point) *last-search-pattern*)))
-	 ((not won))
-       (character-offset (current-point) won)
-       (command-case
-	   (:prompt "Group Search: "
-		    :help "Type a character indicating the action to perform."
-		    :change-window nil)
-	 (:no "Search for the next occurrence.")
-	 (:do-all "Go on to the next file in the group."
-	  (return nil))
-	 ((:exit :yes) "Exit the search."
-	  (return-from group-search-command))
-	 (:recursive-edit "Enter a recursive edit."
-	  (do-recursive-edit)
-	  (get-search-pattern string :forward)))))
-    (message "All files in group ~S searched." *active-file-group-name*)))
-
-(defcommand "Group Replace" (p)
-  "Replaces one string with another in the active file group."
-  "Replaces one string with another in the active file group."
-  (declare (ignore p))
-  (let* ((target (prompt-for-string :prompt "Group Replace: "
-				    :help "Target string"
-				    :default *last-search-string*))
-	 (replacement (prompt-for-string :prompt "With: "
-					 :help "Replacement string")))
-    (do-active-group
-     (query-replace-function nil target replacement
-			     "Group Replace on previous file" t))
-    (message "Replacement done in all files in group ~S."
-	     *active-file-group-name*)))
-
-(defcommand "Group Query Replace" (p)
-  "Query Replace for the active file group."
-  "Query Replace for the active file group."
-  (declare (ignore p))
-  (let ((target (prompt-for-string :prompt "Group Query Replace: "
-				   :help "Target string"
-				   :default *last-search-string*)))
-    (let ((replacement (prompt-for-string :prompt "With: "
-					  :help "Replacement string")))
-      (do-active-group
-       (unless (query-replace-function
-		nil target replacement "Group Query Replace on previous file")
-	 (return nil)))
-      (message "Replacement done in all files in group ~S."
-	       *active-file-group-name*))))
diff --git a/hemlock/hacks.lisp b/hemlock/hacks.lisp
deleted file mode 100644
index df924a48d4318e8eb5de7be48d5f8eee1b14dc43..0000000000000000000000000000000000000000
--- a/hemlock/hacks.lisp
+++ /dev/null
@@ -1,25 +0,0 @@
-(in-package "HI")
-
-(defun %sp-byte-blt (src start dest dstart end)
-  (%primitive byte-blt src start dest dstart end))
-
-(defun lisp::sap-to-fixnum (x) (sap-int x))
-(defun lisp::fixnum-to-sap (x) (int-sap x))
-(defun lisp::%sp-make-fixnum (x) (%primitive make-fixnum x))
-(defun lisp::fast-char-upcase (x) (char-upcase x))
-
-;;; prepare-window-for-redisplay  --  Internal
-;;;
-;;;    Called by make-window to do whatever redisplay wants to set up
-;;; a new window.
-;;;
-(defun prepare-window-for-redisplay (window)
-  (setf (window-old-lines window) 0))
-
-(defparameter hunk-width-limit 256)
-(defparameter minimum-window-lines 2)
-(defparameter minimum-window-columns 10)
-(defparameter font-map-size 16)
-
-(defun reverse-video-hook-fun (&rest foo)
-  (declare (ignore foo)))
diff --git a/hemlock/hemlock.log b/hemlock/hemlock.log
deleted file mode 100644
index 3441e3baf037867c8510e87259f71291d01e54c6..0000000000000000000000000000000000000000
--- a/hemlock/hemlock.log
+++ /dev/null
@@ -1,4514 +0,0 @@
-.../systems-work/hemlock/mh.lisp, 18-Oct-90 13:41:38, Edit by Chiles.
-  MAYBE-DELETE-EXTRA-DRAFT-WINDOW modified to correctly delete another window
-  if one exists when a draft is a split window draft.  This had to be modified
-  to handle separate, unstacked windows correctly.
-
-.../systems-work/hemlock/bindings.lisp, 06-Sep-90 16:59:32, Edit by Chiles.
-  We failed to avoid binding "Auto Check Word Spelling" to #k"'" when we added
-  the new key-event stuff.  Actually, Blaine did.
-
-.../systems-work/hemlock/bindings.lisp, 24-Aug-90 14:04:34, Edit by Chiles.
-  Bound C-M-s (typically "Shell") to "Illegal" in the echo area.
-
-.../systems-work/hemlock/bit-screen.lisp, 06-Aug-90 13:48:10, Edit by Chiles.
-  I modified CREATE-WINDOW-FROM-CURRENT to correctly determin if there is
-  enough room to split the current window to make the new window.
-
-.../systems-work/hemlock/bit-screen.lisp, 06-Aug-90 12:59:40, Edit by Chiles.
-  Made SET-WINDOW-HOOK-RAISE-FUN frob the windows group X window, instead of
-  the child X window.
-
-.../systems-work/hemlock/hunk-draw.lisp, 05-Aug-90 12:57:21, Edit by Chiles.
-  Fixed DROP-CURSOR to beat on the parent borders instead of the non-existent
-  child borders.
-
-.../systems-work/hemlock/bit-screen.lisp, 05-Aug-90 11:58:46, Edit by Chiles.
-  Removed exports for MAKE-WINDOW, DELETE-WINDOW, NEXT-WINDOW, and
-  PREVIOUS-WINDOW since they're in screen.lisp.
-
-  Modified HUNK-RECONFIGURED to realize it object arg is either a hunk (for a
-  child changing) or a window-group (for a group/parent window changing).
-
-  Modified HUNK-MOUSE-ENTERED and HUNK-MOUSE-LEFT to frob the group window's
-  border instead of the child's border.
-
-  Totally redefined *create-window-hook* and *delete-window-hook*.  This
-  affected most of the arrangement of creation and deletion functionality.
-
-  Made the random-typeout window made from keeping a pop-up display, adhere to
-  the minimum resizing parameters Hemlock windows like to try to keep users
-  from screwing themselves.
-
-  Made MAYBE-MAKE-X-WINDOW-AND-PARENT set window manager hints for supplied
-  parents as if Hemlock had made the parent window.
-
-  Made code correctly handle font-family parameters instead of dropping into
-  lower-level code that incorrectly assumed *default-font-family*.
-
-  Consolidated some code, notably MODIFY-PARENT-PROPERTIES.
-
-
-.../systems-work/hemlock/xcoms.lisp, 01-Aug-90 14:00:43, Edit by Chiles.
-  Blew away "Stack Window".
-
-.../systems-work/hemlock/input.lisp, 01-Aug-90 13:49:27, Edit by Chiles.
-  Blaine modified MAYBE-KEEP-RANDOM-TYPEOUT-WINDOW in accordance with the new
-  bitmap window group stuff.
-
-.../systems-work/hemlock/filecoms.lisp, 01-Aug-90 11:23:07, Edit by Chiles.
-  Blaine modified "Delete Window" and "Delete Next Window" in accordance with
-  the new bitmap window group stuff.  They now test the length of *window-list*
-  to determine if they can delete the window instead of using next and previous
-  window commands and primitives and testing against the CURRENT-WINDOW.
-
-.../systems-work/hemlock/screen.lisp, 01-Aug-90 10:15:53, Edit by Chiles.
-  Blaine modified DELETE-WINDOW to test for *window-list* having length two or
-  less, signalling an error if so.  This allows the bitmap window deletion
-  method to delete the current window by changing to another group.  The
-  "Delete Window" command cannot tell there are other windows, and it already
-  tries to make the previous window the current one before calling the
-  DELETE-WINDOW primitive.  With the new bitmap window groups, this doesn't
-  work.  We still have a problem if a programmer calls DELETE-WINDOW on the
-  current window which will break Hemlock.
-
-.../systems-work/hemlock/rompsite.lisp, 01-Aug-90 09:33:02, Edit by Chiles.
-  Blaine modified the X events masks and the raising and lowering of Hemlock
-  windows upon entering and leaving in accordance with the new bitmap window
-  groups.
-
-.../systems-work/hemlock/struct.lisp, 01-Aug-90 09:07:25, Edit by Chiles.
-  Blaine added window-group structure and the window-group slot to
-  bitmap-hunks for the new bitmap window groups.
-
-.../systems-work/hemlock/keysym-defs.lisp, 04-Jul-90 12:14:09, Edit by Chiles.
-  Added a few key-event to character translations at the end of the file to
-  make quoting characters work better when running under X.
-
-/usr2/mbb/lisp/work/diredcoms.lisp, 02-Jul-90 10:12:28, Edit by Mbb.
-  Fixed a bug in "Dired" where it was incorrectly assuming that the current
-  buffer was a DIRED buffer.
-
-.../systems-work/hemlock/searchcoms.lisp, 27-Jun-90 18:27:38, Edit by Chiles.
-.../systems-work/hemlock/kbdmac.lisp, 27-Jun-90 18:19:09, Edit by Chiles.
-  Fixed "Keyboard Macro Query" to realize the :bind arg to COMMAND-CASE is a
-  key-event, not a charcter.
-
-.../systems-work/hemlock/macros.lisp, 27-Jun-90 18:04:12, Edit by Chiles.
-  Fixed COMMAND-CASE to bind key-events, not characters.  It also doesn't make
-  N calls to mapping functions everytime someone was to map one way or the
-  other.  It also no longer makes erroneous assumptions about characters and
-  key-events having a one-to-one mapping.
-
-.../systems-work/hemlock/key-event.lisp, 27-Jun-90 17:34:57, Edit by Chiles.
-  Fixed bugs in character/key-event mapping that allowed bogus typed objects to
-  fall through as if they mapped to meaningful values.
-
-.../systems-work/hemlock/interp.lisp, 26-Jun-90 09:54:52, Edit by Chiles.
-  Fixed some documentation.
-
-  Fixed a bug in KEY-TRANSLATION.  Someone changed a type-spec from '(or
-  simple-vector null) to '(simple-vector null).
-
-  Fixed a bug in TRANSLATE-KEY.  It returned the wrong thing and by accident
-  didn't go into an infinite loop if there were any key translations to
-  multiple key-event keys.
-
-
-.../systems-work/hemlock/echo.lisp, 25-Jun-90 11:44:05, Edit by Chiles.
-  Fixed default prompt of PROMPT-FOR-KEY-EVENT to be "Key-event: ", not
-  "Character: ".
-
-.../systems-work/hemlock/interp.lisp, 24-Jun-90 12:28:02, Edit by Chiles.
-  Removed silly KEYIFY definition, and I put Blaine's name on the file since he
-  modified half of the contents to get the new key tables stuff to work.
-
-.../systems-work/hemlock/input.lisp, 21-Jun-90 19:52:01, Edit by Chiles.
-  Added doc strings to public routines.  Documented some code.  Moved some
-  silly things around.
-
-.../systems-work/hemlock/srccom.lisp, 21-Jun-90 18:53:46, Edit by Chiles.
-.../systems-work/hemlock/spellcoms.lisp, 21-Jun-90 18:52:56, Edit by Chiles.
-.../systems-work/hemlock/macros.lisp, 21-Jun-90 18:51:19, Edit by Chiles.
-.../systems-work/hemlock/filecoms.lisp, 21-Jun-90 18:49:14, Edit by Chiles.
-.../systems-work/hemlock/doccoms.lisp, 21-Jun-90 18:45:55, Edit by Chiles.
-  Made COMMAND-CASE specify lowercase letters.
-
-.../systems-work/hemlock/key-event.lisp, 20-Jun-90 23:11:18, Edit by Chiles.
-  Fixed a bug in TRANSLATE-KEY-EVENT.
-
-.../systems-work/hemlock/bindings.lisp, 20-Jun-90 23:03:22, Edit by Chiles.
-  Bound #k"H-t" to "Illegal" in the echo area.  This is normally bound to a
-  command that makes the current window display the most recently used
-  random-typeout buffer.
-
-.../systems-work/hemlock/macros.lisp, 20-Jun-90 20:45:07, Edit by Chiles.
-  Fixed an extra paren bug that prevented successful compilation.  That's what
-  I get for Blaine's failure to use "Extract Form".
-
-.../systems-work/hemlock/lispmode.lisp, 20-Jun-90 20:47:57, Edit by Chiles.
-  Added "Extract Form", a more useful and intuitive and consistent command to
-  use instead of "Extract List" which is archaic, confusing, erroneously bound
-  by default, and bound to old Lisp ideals that lists are something to focus
-  on.
-
-.../hemlock/ts-buf.lisp, 20-Jun-90 17:40:51, Edit by Wlott.
-  Made typescript commands more robust in light of the possibility of being
-  executed while in a buffer other than the slave buffer.
-
-.../systems-work/hemlock/key-event.lisp, 20-Jun-90 17:00:33, Edit by Chiles.
-  Totally rewrote mouse translation code.  Fixed multiple bugs MAKE-KEY-EVENT.
-
-.../systems-work/hemlock/macros.lisp, 20-Jun-90 13:55:48, Edit by Chiles.
-  Removed :character argument to COMMAND-CASE.  Stopped case-folding and
-  eliminated variables used for that.
-
-.../systems-work/hemlock/fill.lisp, 16-Jun-90 14:07:48, Edit by Chiles.
-  Fixed "Auto Fill Linefeed" and "Auto Fill Return" to use #k syntax instead of
-  characters for keys.
-
-.../systems-work/hemlock/key-event.lisp, 16-Jun-90 13:59:23, Edit by Chiles.
-  Added missing exports.
-
-  Fixed a couple bugs with DEFINE-KEY-EVENT-MODIFIER.  It was using EQL to
-  compare strings.  Stuck an UNWIND-PROTECT in there to keep things consistent.
-  Added restart for already defined modifiers allowing the user to go on
-  blowing it off; this helps reloading the file.
-
-
-.../systems-work/hemlock/echo.lisp, 16-Jun-90 11:11:17, Edit by Chiles.
-  Fixed two GET-KEY-EVENT calls to ignore abort attempts in PROMPT-FOR-KEY
-  and PROMPT-FOR-KEY-EVENT.
-
-.../systems-work/hemlock/keysym-defs.lisp, 15-Jun-90 18:17:38, Edit by Chiles.
-  This file used to be called keytrandefs.lisp.
-
-.../systems-work/hemlock/key-event.lisp, 15-Jun-90 18:34:10, Edit by Chiles.
-  This file used to be called keytran.lisp.  It now implements key-events in
-  the "EXTENSIONS" package.
-
-.../systems-work/hemlock/bit-screen.lisp, 14-Jun-90 14:28:58, Edit by Chiles.
-  Replaced calls to EXT:TRANSLATE-CHARACTER and EXT:TRANSLATE-MOUSE-CHARACTER
-  with EXT:TRANSLATE-KEY-EVENT and EXT:TRANSLATE-MOUSE-KEY-EVENT.
-
-.../systems-work/hemlock/shell.lisp, 15-Jun-90 16:27:42, Edit by Chiles.
-  Picked up Blaine's new shell hacks and documented them.  Added "Current
-  Shell" and "Ask about Old Shells" variables.  Changed "Shell" to be more like
-  "Select Slave" and wrote "Shell Command Line in Buffer".
-
-/usr2/mbb/lisp/work/doccoms.lisp, 14-Jun-90 21:19:46, Edit by Mbb.
-  Made a quoted list of #k mouse-keys be a call to LIST on the mouse-keys
-  instead so they would get evaluated.
-
-/usr2/mbb/lisp/work/input.lisp, 12-Jun-90 21:00:12, Edit by Mbb.
-  input.lisp is a new file.  It contains code to implement input to
-  hemlock.  Similar code previously resided in rompsite.lisp
-
-/usr2/mbb/lisp/work/icom.lisp, 12-Jun-90 16:15:00, Edit by Mbb.
-/usr2/mbb/lisp/work/gosmacs.lisp, 12-Jun-90 16:15:00, Edit by Mbb.
-  Changed BIND-KEY calls to use #k format instead of characters.
-
-.../systems-work/hemlock/filecoms.lisp, 13-Jun-90 15:17:06, Edit by Chiles.
-  Wrote "Go to One Window" which makes a default initial window and deletes all
-  other windows.  This is useful with losing window managers like twm, and it
-  is useful in case you ever resize or move the main Hemlock window which
-  happens by accident to some people.
-
-/usr2/mbb/lisp/work/keytran.lisp, 13-Jun-90 14:01:58, Edit by Mbb.
-  Changed all the BIND-KEY forms in this file to use #k format.
-
-/usr2/mbb/lisp/work/files.lisp, 12-Jun-90 10:26:58, Edit by Mbb.
-  Inserted the form (proclaim '(special vm_page_size)) so the compiler
-  wouldn't whine about vm_page_size not being declared or bound. 
-
-/usr2/mbb/lisp/work/buffer.lisp, 11-Jun-90 11:58:39, Edit by Mbb.
-  Modified DEFMODE -- The default mode-bindings slot is now a hash-table
-  whereas it used to be a key-table.  Did the same for buffer-bindings in
-  MAKE-BUFFER.
-
-/usr2/mbb/lisp/work/keytrandefs.lisp, 11-Jun-90 13:17:59, Edit by Mbb.
-  Made all calls to "EXTENSIONS" use an ext: prefix.
-
-/usr2/mbb/lisp/work/scribe.lisp, 08-Jun-90 17:33:31, Edit by Mbb.
-/usr2/mbb/lisp/work/register.lisp, 08-Jun-90 17:29:23, Edit by Mbb.
-/usr2/mbb/lisp/work/interp.lisp, 08-Jun-90 17:27:44, Edit by Mbb.
-  Changed all calls to PRINT-PRETTY-CHARACTER to calls to
-  PRINT-PRETTY-KEY-EVENT. 
-
-/usr2/mbb/lisp/work/kbdmac.lisp, 08-Jun-90 17:25:50, Edit by Mbb.
-  Made all calls to SUB-PRINT-KEY be calls to PRINT-PRETTY-KEY.
-
-/usr2/mbb/lisp/work/doccoms.lisp, 08-Jun-90 17:15:46, Edit by Mbb.
-  Removed SUB-PRINT-KEY in favor of PRINT-PRETTY-KEY.
-
-/usr2/mbb/lisp/work/searchcoms.lisp, 08-Jun-90 14:38:55, Edit by Mbb.
-/usr2/mbb/lisp/work/overwrite.lisp, 08-Jun-90 14:38:38, Edit by Mbb.
-/usr2/mbb/lisp/work/morecoms.lisp, 08-Jun-90 14:37:43, Edit by Mbb.
-/usr2/mbb/lisp/work/completion.lisp, 08-Jun-90 14:37:10, Edit by Mbb.
-/usr2/mbb/lisp/work/command.lisp, 08-Jun-90 14:36:12, Edit by Mbb.
-  Changed all calls to TEXT-CHARACTER to calls to KEY-EVENT-CHAR.
-
-/usr2/mbb/lisp/work/rompsite.lisp, 08-Jun-90 12:15:17, Edit by Mbb.
-/usr2/mbb/lisp/work/termcap.lisp, 08-Jun-90 12:15:17, Edit by Mbb.
-  Commented out CL-TERMCAP-CHAR as it is no longer needed.  
-  GET-TERMCAP-STRING-CHAR does the conversion to a character now.
-
-/usr2/mbb/lisp/work/doccoms.lisp, 08-Jun-90 11:08:09, Edit by Mbb.
-  Removed from GET-MOUSE-COMMANDS a call to MAKE-CHAR in favor of
-  MAKE-KEY-EVENT and also fixed a list to use the new #k"foo" format.
-
-/usr2/mbb/lisp/work/bindings.lisp, 08-Jun-90 10:44:49, Edit by Mbb.
-  Chnaged all bindings to #k"foo" format.
-
-/usr2/mbb/lisp/work/charmacs.lisp, 07-Jun-90 14:44:36, Edit by Mbb.
-  Removed the declaration of the constant all-bit-names, as bit names are
-  no longer supported in Common Lisp.
-
-/usr2/mbb/lisp/work/charmacs.lisp, 07-Jun-90 14:41:23, Edit by Mbb.
-  Changed ALPHA-CHAR-LOOP and DO-ALPHA-CHARS to ALPHA-KEY-EVENTS-LOOP and
-  DO-ALPHA-KEY-EVENTS respectively.
-
-/usr2/mbb/lisp/work/tty-display.lisp, 06-Jun-90 10:38:07, Edit by Mbb.
-/usr2/mbb/lisp/work/searchcoms.lisp, 06-Jun-90 10:36:39, Edit by Mbb.
-/usr2/mbb/lisp/work/searchcoms.lisp, 06-Jun-90 10:21:58, Edit by Mbb.
-/usr2/mbb/lisp/work/rompsite.lisp, 06-Jun-90 10:09:11, Edit by Mbb.
-/usr2/mbb/lisp/work/morecoms.lisp, 06-Jun-90 10:16:52, Edit by Mbb.
-/usr2/mbb/lisp/work/mh.lisp, 06-Jun-90 10:14:12, Edit by Mbb.
-/usr2/mbb/lisp/work/doccoms.lisp, 06-Jun-90 10:04:45, Edit by Mbb.
-/usr2/mbb/lisp/work/macros.lisp, 05-Jun-90 15:11:03, Edit by Mbb.
-/usr2/mbb/lisp/work/kbdmac.lisp, 05-Jun-90 15:08:37, Edit by Mbb.
-/usr2/mbb/lisp/work/interp.lisp, 05-Jun-90 11:02:59, Edit by Mbb.
-/usr2/mbb/lisp/work/echo.lisp, 05-Jun-90 10:58:55, Edit by Mbb.
-/usr2/mbb/lisp/work/doccoms.lisp, 05-Jun-90 15:05:40, Edit by Mbb.
-/usr2/mbb/lisp/work/command.lisp, 05-Jun-90 15:02:21, Edit by Mbb.
-  Fixed all references to *editor-input*.
-
-/usr2/mbb/lisp/work/main.lisp, 06-Jun-90 10:07:41, Edit by Mbb.
-  *editor-input* used to be exported from this file, event though it is
-  also exported in input.lisp.  Removed export from main.lisp.
-
-/usr2/mbb/lisp/work/rompsite.lisp, 05-Jun-90 14:31:55, Edit by Mbb.
-  Changed reference to *character-history* in SITE-INIT to
-  *key-event-history*.
-
-/usr2/mbb/lisp/work/mh.lisp, 05-Jun-90 14:30:28, Edit by Mbb.
-  Changed a reference to *character-history* to *key-event-history*.
-
-/usr2/mbb/lisp/work/main.lisp, 05-Jun-90 14:27:23, Edit by Mbb.
-  Removed export of *character-history* from this file in favor of putting
-  it in input.lisp and changing the name to *key-event-history*.
-
-/usr2/mbb/lisp/work/doccoms.lisp, 05-Jun-90 14:19:41, Edit by Mbb.
-  Made "What Lossage" command reference *key-event-history* instead of
-  *character-history*.
-
-/usr2/mbb/lisp/work/streams.lisp, 05-Jun-90 14:10:43, Edit by Mbb.
-  Made KBDMAC-GET use *last-key-event-typed* instead of
-  *last-character-typed*.  Also changed stream definition of kbdmac-stream
-  to coincide with the new editor-input like streams.
-
-/usr2/mbb/lisp/work/spellcoms.lisp, 05-Jun-90 14:08:57, Edit by Mbb.
-  Made SUB-CORRECT-LAST-MISSPELLED-WORD work with *last-key-event-typed*.
-
-/usr2/mbb/lisp/work/scribe.lisp, 05-Jun-90 14:07:23, Edit by Mbb.
-  Fixed "Scribe Insert bracket" to work with *last-key-event-typed*.
-
-/usr2/mbb/lisp/work/rompsite.lisp, 05-Jun-90 13:59:46, Edit by Mbb.
-  Removed all Input queue management and Random Typeout input routines and
-  put them in a input.lisp, a new hemlock file.
-
-/usr2/mbb/lisp/work/rompsite.lisp, 05-Jun-90 13:45:23, Edit by Mbb.
-  Changed DEFVAR of *last-character-typed* to *last-key-event-typed*.  Also
-  fixed setting of *last-character-typed* in DQ-EVENT.  For some reason,
-  *last-character-typed* was exported from both main.lisp and
-  rompsite.lisp.  This remains under the new name.
-
-/usr2/mbb/lisp/work/overwrite.lisp, 05-Jun-90 13:43:23, Edit by Mbb.
-  Made "Self Overwrite" use *last-key-event-typed* instead of
-  *last-character-typed*.
-
-/usr2/mbb/lisp/work/morecoms.lisp, 05-Jun-90 13:41:58, Edit by Mbb.
-  Made "Self Insert Caps Lock" deal with *last-key-event-typed* instead of
-  *last-character-typed*.
-
-/usr2/mbb/lisp/work/main.lisp, 05-Jun-90 13:40:48, Edit by Mbb.
-  Changed export of *last-character-typed* to *last-key-event-typed*.
-
-/usr2/mbb/lisp/work/kbdmac.lisp, 05-Jun-90 13:37:38, Edit by Mbb.
-  Made DEFAULT-KBDMAC-TRANSFORM and SELF-INSERT-KBDMAC-TRANSFORM use
-  *last-key-event-typed* instead of *last-character-typed*.
-
-/usr2/mbb/lisp/work/echocoms.lisp, 05-Jun-90 13:34:52, Edit by Mbb.
-  Made "Complete Field" work with *last-key-event-typed*.
-/usr2/mbb/lisp/work/completion.lisp, 05-Jun-90 13:28:07, Edit by Mbb.
-  Made "Completion Self Insert" deal with *last-key-event-typed* instead of
-  *last-character-typed*.
-
-/usr2/mbb/lisp/work/command.lisp, 05-Jun-90 13:24:55, Edit by Mbb.
-  Changed UNIVERSAL-ARGUMENT-LOOP to deal with *last-key-event-typed*
-  instead of *last-character-typed*.  Also made "Self Insert" do the same.
-
-/usr2/mbb/lisp/work/spellcoms.lisp, 05-Jun-90 12:58:02, Edit by Mbb.
-  Changed calls to PROMPT-FOR-CHARACTER to calls to PROMPT-FOR-KEY-EVENT.
-  Since what we wanted was the number of the correction choice, simply wrap
-  a call to KEY-EVENT-CHAR around the PROMPT-FOR-KEY-EVENT.
-
-/usr2/mbb/lisp/work/scribe.lisp, 05-Jun-90 11:59:46, Edit by Mbb.
-  Made ADD-SCRIBE-DIRECTIVE and INSERT-SCRIBE-DIRECTIVE use PROMPT-FOR-KEY
-  instead of PROMPT-FOR-CHARACTER.  They used to HASH on the result of
-  PROMPT-FOR-CHARACTER, so key-events will work just as well.
-
-/usr2/mbb/lisp/work/scribe.lisp, 05-Jun-90 11:59:46, Edit by Mbb.
-  Changed all top-level ADD-SCRIBE-DIRECTIVE-COMMAND calls to use #k syntax
-  when binding dispatches.
-
-/usr2/mbb/lisp/work/struct.lisp, 05-Jun-90 11:08:20, Edit by Mbb.
-  Changed DEFSETF for %SET-LOGICAL-CHAR= to %SET-LOGICAL-KEY-EVENT-P in
-  order to maintain consistency.
-
-/usr2/mbb/lisp/work/macros.lisp, 05-Jun-90 09:23:41, Edit by Mbb.
-  Fixed COMMAND-CASE to bind key-events instead of characters.
-
-/usr2/mbb/lisp/work/register.lisp, 05-Jun-90 09:31:41, Edit by Mbb.
-  Made PROMPT-FOR-REGISTER return a key-event instead of a character.  The
-  rest of the code code just hashes on what PROMPT-FOR-REGISTER returns, so
-  since key-events are unique, nothing else had to be changed.
-
-/usr2/mbb/lisp/work/keytrandefs.lisp, 04-Jun-90 13:16:13, Edit by Mbb.
-  Completely changed this file to conform to new key syntax.
-
-/usr2/mbb/lisp/work/charmacs.lisp, 04-Jun-90 13:10:55, Edit by Mbb.
-  Removed all pushes into lisp::char-name-alist.
-
-.../systems-work/hemlock/completion.lisp, 29-May-90 13:54:48, Edit by Chiles.
-  Changed test in DO-COMPLETION to explicitly test for uppercase characters.
-  Testing for lowercase characters caused ID's to be uppercased when they began
-  with non-alphabetic characters (such as digit-chars).
-
-.../systems-work/hemlock/bindings.lisp, 21-May-90 10:22:28, Edit by Chiles.
-.../systems-work/hemlock/morecoms.lisp, 21-May-90 10:19:13, Edit by Chiles.
-  Added "CAPS-LOCK" mode, "Caps Lock Mode" and "Caps Lock Self Insert".
-
-  Added bindings for lowercase letters.
-
-
-.../systems-work/hemlock/bindings.lisp, 21-May-90 10:14:10, Edit by Chiles.
-.../systems-work/hemlock/diredcoms.lisp, 21-May-90 10:03:16, Edit by Chiles.
-  Wrote "Dired Up Directory" and added binding to #\^ in "Dired" mode.
-
-.../systems-work/hemlock/diredcoms.lisp, 08-May-90 15:38:28, Edit by Chiles.
-  Fixed :help string in file prompt for "Delete File".
-
-.../hemlock/ts-stream.lisp, 26-Apr-90 17:14:10, Edit by Wlott.
-  Make %ts-stream-listen try calling server before finally saying that
-  there is no more input available.
-
-.../hemlock/files.lisp, 26-Apr-90 18:43:29, Edit by Wlott.
-  Fixed a bug in write-file in which the first line was being extended with
-  garbage if it didn't start at the first character.
-
-.../systems-work/hemlock/lispeval.lisp, 16-Apr-90 14:03:10, Edit by Chiles.
-  Modified OPERATION-STARTED, OPERATION-COMPLETED, and "List Operations" to
-  preserve the case of context strings when MESSAGE'ing.  I added "The"'s to
-  sentences which previously capitalized the first word of the context and
-  lowered the remaining parts of the string.  I added periods to sentences in
-  all these routines.  I stopped operation listing from forcing the entire
-  string to lowercase.  The user should get his context as he supplied it.
-  Many users complained about file names reporting as incorrect due to the old
-  state of the code.
-
-.../systems-work/hemlock/lispbuf.lisp, 16-Apr-90 13:41:05, Edit by Chiles.
-  Fixed doc string for "Current Package" in "package" file option handler.
-
-/usr2/ch/lisp/lispeval.lisp, 15-Apr-90 19:14:38, Edit by Christopher Hoover.
-  Sometimes the defined "Current Package" does not exist in the slave, and
-  sometimes "Current Package" is defined as nil.  "Describe Function Call"
-  points out which reason led to using the default package in the slave.
-
-.../systems-work/hemlock/shell.lisp, 24-Mar-90 11:58:10, Edit by Chiles.
-  New file.
-
-.../systems-work/hemlock/bindings.lisp, 24-Mar-90 11:57:31, Edit by Chiles.
-  Added bindings for new "Process" mode.
-
-.../systems-work/hemlock/main.lisp, 22-Mar-90 16:03:27, Edit by Blaine.
-  Added new hook "Buffer Writable Hook".
-
-.../systems-work/hemlock/buffer.lisp, 22-Mar-90 15:45:51, Edit by Blaine.
-  Write BUFFER-WRITABLE and %SET-BUFFER-WRITABLE.
-
-.../systems-work/hemlock/struct.lisp, 22-Mar-90 15:40:31, Edit by Blaine.
-  Renamed the writable slot to %writable.  Added DEFSETF for BUFFER-WRITABLE.
-
-.../systems-work/hemlock/completion.lisp, 22-Mar-90 14:51:00, Edit by Chiles.
-  Picked up Blaine's "Save Completions", "Read Completions", and "Parse Buffer
-  for Completions".
-
-  I added documentation to "Completion" mode and made the parameter
-  completion-bucket-size-limit be a Hemlock variable "Completion Bucket Size".
-
-
-.../systems-work/hemlock/buffer.lisp, 19-Mar-90 16:45:01, Edit by Chiles.
-  Made the BUFFER-MODIFIED SETF'er return the value stored.
-
-.../systems-work/hemlock/table.lisp, 12-Mar-90 12:43:13, Edit by Chiles.
-  Made BI-SVPOSITION stop calling IDENTITY on every element.  There already was
-  a test for the key argument being nil, but the author allowed the argument to
-  default to IDENTITY.  Also, it is never called without a key argument anyway
-  -- gratuitous generality maladjusted.
-
-.../systems-work/hemlock/mh.lisp, 09-Mar-90 09:03:28, Edit by Chiles.
-  Fixed bug in REMAIL-MESSAGE resulting from recent changes to the environment
-  code that made my MH env vars become capitalized when they should have been
-  lowercase.
-
-.../systems-work/hemlock/lispeval.lisp, 27-Feb-90 15:03:31, Edit by Chiles.
-  Modified EVAL-FORM-IN-SERVER to optionally take a package name.  It uses the
-  value of "Current Package" as a default, which it previously always supplied.
-  EVAL-FORM-IN-SERVER-1 accordingly takes a package argument now.  "Describe
-  Function Call" now first asks the server if the value of "Current Package"
-  names a package, and if it does not, then this command describes the function
-  call by reading the name into *package* in the slave.  This reasonably
-  handles the problem of describing a function call with a buffer package that
-  does not exist in the slave.
-
-.../systems-work/hemlock/screen.lisp, 27-Feb-90 13:18:16, Edit by Mbb.
-  Made pop-up displays better count lines when fully buffered.
-
-.../systems-work/hemlock/lispeval.lisp, 22-Feb-90 11:20:03, Edit by Chiles.
-  Picked up Williams change to "Lisp Operations", and I documented his peculiar
-  queue implementation.
-
-.../systems-work/hemlock/srccom.lisp, 21-Feb-90 13:52:45, Edit by Chiles.
-  Added "Source Compare Ignore Indentation" and wrote a macro to generate the
-  line comparison routines that *srccom-line-=* holds.
-
-.../systems-work/hemlock/searchcoms.lisp, 15-Feb-90 10:17:40, Edit by Chiles.
-  Fixed a bug in undo'ing replacements.  IF two were immediately adjacent, the
-  second would not be undone.
-
-.../systems-work/hemlock/command.lisp, 14-Feb-90 14:15:38, Edit by Chiles.
-  Fixed "Forward Character".
-
-.../systems-work/hemlock/eval-server.lisp, 10-Feb-90 12:07:29, Edit by Chiles.
-  Made editor MESSAGE what slave is GC'ing when dumping GC messages behind the
-  prompt.  Also, moved the global frobbing into the two routines that setup and
-  cleanup stream variables.
-
-.../systems-work/hemlock/mh.lisp, 09-Feb-90 17:02:43, Edit by Chiles.
-  Finally fixed bug in PICK-MESSAGES that allowed MH pick to screw us.  MH pick
-  would output "0" when no messages matched a specification, so PICK-MESSAGES
-  now tests the result of calling MH to invoke "pick".  It returns nil whenever
-  MH returns other than t for correct completion.
-
-.../systems-work/hemlock/termcap.lisp, 08-Feb-90 20:07:01, Edit by Chiles.
-  The new fd-streams, which correctly implement unreading characters, pointed
-  out that this code relied on multiply unreading characters.  It no longer
-  does.
-
-.../systems-work/hemlock/lisp-lib.lisp, 07-Feb-90 15:50:50, Edit by Chiles.
-  Modified MERGE-PATHNAMES calls that used strings with dots to merge in types.
-  This no longer works with the new NAMESTRING/PARSE-NAMESTRING stuff.
-
-.../systems-work/hemlock/command.lisp, 07-Feb-90 13:52:10, Edit by Chiles.
-  "Next Line" was opening newlines in the middle of the buffer's last line of
-  text when the buffer wasn't newline terminated.
-
-/usr2/mbb/lisp/work/macros.lisp, 07-Feb-90 12:22:54, Edit by Mbb.
-  Changed how WITH-POP-UP-DISPLAY determines whether to cleanup.  It 
-  shouldn't have been cleaning up unless something had really happened, but
-  it was.
-
-.../systems-work/hemlock/files.lisp, 31-Jan-90 11:58:15, Edit by Chiles.
-  Modifed all occurrances of "fdstream" to "fd-stream" to be consistent with
-  new interface.
-
-.../systems-work/hemlock/mh.lisp, 26-Jan-90 12:41:47, Edit by Chiles.
-  Fixed bug leaving a file open every time I called MH-PROFILE-COMPONENT, and
-  closed the process in MH.
-
-.../systems-work/hemlock/command.lisp, 24-Jan-90 11:06:13, Edit by Chiles.
-  Changed "Next Line", "Previous Line", "Next Word", "Previous Word",
-  "Forward Character", "Backward Character", "Delete Next Character", and
-  "Delete Previous Character" to work with correctly negative arguments.
-
-.../systems-work/hemlock/macros.lisp, 24-Jan-90 10:40:00, Edit by Chiles.
-  Modified WITH-POP-UP-DISPLAY to have a doc string other than "Do Some Shit."
-
-.../systems-work/hemlock/lispbuf.lisp, 22-Jan-90 15:17:49, Edit by Chiles.
-  Modified code around *prompt* to adhere to new semantics of its values.
-
-.../hemlock/mh.lisp, 19-Jan-90 21:00:28, Edit by Wlott.
-  Changed to use new RUN-PROGRAM return values.
-
-.../systems-work/hemlock/eval-server.lisp, 19-Jan-90 12:07:06, Edit by Chiles.
-  Modified DO-OPERATION and the thing that aborts operations to handshake on
-  whether we were in the debugger when we aborted.  If we were, output a
-  message trying to inform the user that the output in his typescript can be
-  ignored; he is no longer really in the debugger.
-
-.../systems-work/hemlock/lispeval.lisp, 18-Jan-90 23:21:55, Edit by Chiles.
-  Fixed "Abort Operations" to really abort the operations (one more time).
-
-.../systems-work/hemlock/eval-server.lisp, 18-Jan-90 16:45:24, Edit by Chiles.
-  Made the -slave switch handler setup *gc-notify-before* and *gc-notify-after*
-  to do gratuitous output to the editor.
-
-.../systems-work/hemlock/ts-stream.lisp, 18-Jan-90 16:08:00, Edit by Chiles.
-  Fixed a bug in WAIT-FOR-TYPESCRIPT-INPUT that incorrectly reported input when
-  the function was re-entered by handling an event in SERVE-EVENT.
-
-.../systems-work/hemlock/ts-buf.lisp, 18-Jan-90 12:14:40, Edit by Chiles.
-  Modified TS-BUFFER-OUTPUT-STRING to take a gratuitous-p optional indicating
-  output should go behind the prompt.
-
-.../systems-work/hemlock/morecoms.lisp, 17-Jan-90 21:21:53, Edit by Chiles.
-  Modified DO-RECURSIVE-EDIT to update the modeline field before possibly
-  signalling an error in the cleanup forms of the UNWIND-PROTECT.
-
-.../systems-work/hemlock/ts-buf.lisp, 17-Jan-90 15:25:18, Edit by Chiles.
-  Removed weird disappearing prompt stuff.  Added stuff to help users unwedge
-  themselves when they get behind the prompt.
-
-.../systems-work/hemlock/streams.lisp, 16-Jan-90 13:42:19, Edit by William.
-  Made Hemlock output streams make sure the mark is :left-inserting, but only
-  when actually doing the output.
-
-.../systems-work/hemlock/morecoms.lisp, 15-Jan-90 09:07:31, Edit by Chiles.
-  Modified "Count Lines" and "Count Words" to report lines counted as being in
-  the active region or after the point.
-
-.../systems-work/hemlock/eval-server.lisp, 15-Jan-90 13:09:19, Edit by Wlott.
-  Changed occurances of SYSTEM:SERVER to SYSTEM:SERVE-EVENT.
-
-  Added tweeking of *standard-output* and friends in addition to
-  *terminal-io* when connecting to a slave.
-
-
-.../systems-work/hemlock/lispeval.lisp, 15-Jan-90 14:13:56, Edit by Wlott.
-  Made FILE-COMPILE pay attention to "Remote Compile File". (I must have been
-  brain-dead the first time through that code...)
-
-.../systems-work/hemlock/files.lisp, 15-Jan-90 15:21:36, Edit by Wlott.
-  Changed write-file to be faster.
-
-.../systems-work/hemlock/srccom.lisp, 13-Jan-90 14:42:07, Edit by Chiles.
-  Made "Merge Buffers" have an (A)lign window with start of difference display
-  option in the command loop.  I often had to use recursive edit to be able to
-  position the window to see the difference that was otherwise not visible due
-  to normal scrolling and redisplay centering the mark.
-
-.../systems-work/hemlock/srccom.lisp, 13-Jan-90 14:00:25, Edit by Chiles.
-  Fixed "Compare Buffers" and "Merge Buffers" to test for a nil result when
-  calling LINE-OFFSET.  When buffers weren't terminated with newlines, the old
-  code would infinitely loop.
-
-.../systems-work/hemlock/lispmode.lisp, 12-Jan-90 18:29:20, Edit by Chiles.
-  Modified SCAN-DIRECTION-VALID to check for the ignore region falling off the
-  end of the line which caused %FORM-OFFSET to infinitely loop.
-
-.../systems-work/hemlock/ts-stream.lisp, 12-Jan-90 12:47:37, Edit by Wlott.
-  Changed occurances of SYSTEM:SERVER to SYSTEM:SERVE-EVENT.
-
-.../systems-work/hemlock/tty-disp-rt.lisp, 11-Jan-90 19:31:46, Edit by Wlott.
-  Changed to work with fdstreams.
-
-.../systems-work/hemlock/rompsite.lisp, 11-Jan-90 16:42:02, Edit by Wlott.
-  Changed occurances of SYSTEM:SERVER to SYSTEM:SERVE-EVENT.
-
-.../systems-work/hemlock/tty-screen.lisp, 09-Jan-90 14:27:17, Edit by Chiles.
-  When we make a random typeout window, we no longer say the screen image is
-  trashed.  Some uses of pop up displays do output and then prompt inside the
-  form, and this prompting was causing the main window to be redisplayed since
-  we said the screen image was trashed.  This drew over our pop up display.
-
-.../systems-work/hemlock/indent.lisp, 08-Jan-90 10:20:48, Edit by Mbb.
-  Made "Center Line" use the active region.
-
-.../systems-work/hemlock/bit-screen.lisp, 05-Jan-90 17:07:23, Edit by Mbb.
-  REVERSE-VIDEO-HOOK-FUN was calling the wrong function.
-
-.../systems-work/hemlock/eval-server.lisp, 01-Dec-89 17:58:53, Edit by Chiles.
-  Fixed a bug in SERVER-DIED that prevented it from deleting variables
-  referencing dead server-infos.
-
-.../systems-work/hemlock/ts-buf.lisp, 01-Dec-89 17:06:22, Edit by Chiles.
-  Modified and documented TYPESCRIPTIFY-BUFFER to make a local "Current Eval
-  Server" variable.
-
-.../systems-work/hemlock/eval-server.lisp, 01-Dec-89 16:29:25, Edit by Chiles.
-  GET-CURRENT-EVAL-SERVER cleaned up.  "Select Slave" rewritten to no longer
-  set current eval server.
-
-.../systems-work/hemlock/eval-server.lisp, 22-Nov-89 15:51:42, Edit by Mbb.
-  Just someone forgetting the result argument to THROW.  The old defmacro
-  compiler stuff didn't catch this, so it used to pass (and amazingly, work).
-
-.../systems-work/hemlock/morecoms.lisp, 22-Nov-89 15:31:29, Edit by Mbb.
-  Somehow, the old "Count Lines" worked.  How, I don't know.  It had an IF
-  without a THEN clause, which is required by ClTM.  The new DEFMACRO stuff
-  caught it.
-
-.../systems-work/hemlock/mh.lisp, 27-Oct-89 11:49:25, Edit by Chiles.
-  After recently eliminating recursive folder support, "List Folders" continued
-  to claim it would list all folders recursively.  Removed useless code and
-  bogus doc string.
-
-.../systems-work/hemlock/diredcoms.lisp, 25-Oct-89 16:15:29, Edit by Chiles.
-  Picked up Blaine's changes to make "Dired" and "Dired with Pattern" do dot
-  files with an argument.  This propagates to subdirectories.
-
-.../systems-work/hemlock/lisp-lib.lisp, 25-Oct-89 15:59:19, Edit by Chiles.
-  Made browser look in new library location.
-
-.../systems-work/hemlock/lispeval.lisp, 29-Sep-89 15:52:50, Edit by Chiles.
-  Fixed a bug in "Abort Operations" and documented how it works.
-
-.../systems-work/hemlock/mh.lisp, 28-Sep-89 15:37:39, Edit by Chiles.
-  Modified "Headers Delete Message" to be prepared to deal with a list of
-  message ID's when in a message buffer.
-
-.../systems-work/hemlock/eval-server.lisp, 22-Sep-89 11:28:02, Edit by Chiles.
-  Made SERVER-COMPILE-TEXT do a TERPRI on error-output since the background
-  buffer was incredibly hard to read when compiling single defuns.
-
-.../systems-work/hemlock/rompsite.lisp, 20-Sep-89 00:39:06, Edit by Chiles.
-  Installed WITHOUT-HEMLOCK from code:lispinit.lisp.  This had to be part of
-  Hemlock, as it should have been, so expansions of it during compilation of
-  Hemlock would no longer cause hardwired references to bogus "OLD-HI" symbols.
-
-.../systems-work/hemlock/doccoms.lisp, 19-Sep-89 20:15:26, Edit by Chiles.
-.../clisp-1/systems-work/hemlock/echo.lisp, 19-Sep-89 20:06:56, Edit by Chiles.
-  Replaced ~C FORMAT directives with ~:C to adhere to new standard.
-
-/usr2/ch/lisp/echocoms.lisp, 11-Sep-89 21:21:46, Edit by Christopher Hoover.
-  Made "Complete Field" and "Complete Keyword" do the same thing for
-  parse types of :file.
-
-/usr1/lisp/hemlock/searchcoms.lisp, 18-Sep-89 12:56:33, Edit by Chiles.
-  When we fixed QUERY-REPLACE-LOOP to use a permanent marker for the end mark,
-  we destroyed the current region effect when the current mark was before the
-  current point.  I fixed this to be a permanent mark that is a copy of the end
-  mark of the region within which we replace things.
-
-/usr1/lisp/hemlock/mh.lisp, 15-Sep-89 11:30:56, Edit by Chiles.
-  Blew away "-recurse" from CHECK-FOLDER-NAME-TABLE.
-
-/usr1/lisp/hemlock/macros.lisp, 14-Sep-89 12:18:47, Edit by Chiles.
-  Fixed bug in DO-STRINGS introduced with the new string table stuff a few
-  months ago.  It spliced the result form after a DOTIMES instead inside it, so
-  RETURN's inside the DO-STRING's returned the result form instead of the
-  returned values.
-
-/usr/lisp/hemlock/ts-stream.lisp, 13-Sep-89 19:07:27, Edit by Wlott.
-  Fixed bug in %TS-STREAM-SOUT that caused the character position to become
-  confused.
-
-/usr1/lisp/hemlock/lispeval.lisp, 08-Sep-89 11:59:16, Edit by Chiles.
-  Changed "Forget Compiler ..." to "Flush ...".
-
-/usr1/lisp/hemlock/diredcoms.lisp, 03-Sep-89 17:39:07, Edit by Chiles.
-  Stopped DIRED-DOWN-LINE from moving the mark to the beginning of the line.
-
-/usr1/lisp/hemlock/macros.lisp, 01-Sep-89 10:50:03, Edit by Chiles.
-  Proclaimed *buffer-names* special.
-
-/usr1/lisp/hemlock/rompsite.lisp, 27-Aug-89 12:26:44, Edit by Chiles.
-  Removed BUILD-HEMLOCK.  Created load-hem.lisp.
-
-/usr1/lisp/nhem/rompsite.lisp, 25-Aug-89 11:17:01, Edit by Chiles.
-  Added LOAD's for new TCP/eval server files.
-
-  Removed old eval server stuff.
-
-
-/usr1/lisp/nhem/eval-server.lisp, 25-Aug-89 11:16:29, Edit by Chiles.
-  This is a new file.
-
-/usr1/lisp/nhem/ts-stream.lisp, 25-Aug-89 09:56:46, Edit by Chiles.
-  This is a new file.
-
-/usr1/lisp/nhem/ts.lisp, 24-Aug-89 16:35:30, Edit by Chiles.
-  Basically a new file for interfacing to the new typescript streams.
-
-/usr1/lisp/nhem/lispeval.lisp, 24-Aug-89 16:16:25, Edit by Chiles.
-  This is effectively a new file for use with TCP eval servers.
-
-/usr1/lisp/nhem/lispbuf.lisp, 24-Aug-89 16:07:34, Edit by Chiles.
-  Added "Editor" mode to this file.
-
-/usr1/lisp/nhem/edit-defs.lisp, 24-Aug-89 15:57:28, Edit by Chiles.
-  Updated definition fetching code to use DO-EVAL-FORM instead of
-  EVAL_FORM-IN-CLIENT.
-
-/usr1/lisp/nhem/echo.lisp, 24-Aug-89 15:54:00, Edit by Chiles.
-  Moved LOUD-MESSAGE here from lispeval.lisp and exported it.
-
-/usr1/lisp/nhem/bindings.lisp, 24-Aug-89 15:51:31, Edit by Chiles.
-  Commented out binding for "Abort Typescript Input".
-
-  Added bindings for "Next Compiler Error" and "Previous Compiler Error".
-
-  Changed some names "Process Control ..." to "Typescript Slave ...".
-
-
-/usr1/lisp/hemlock/struct.lisp, 16-Aug-89 15:09:14, Edit by Chiles.
-  Removed
-     (:print-function ...)
-  forms for structures that included another structure and explicitly
-  specified the included functions print fucntion.  It is now in the standard
-  and our system that these should automatically be inherited.
-
-/usr1/lisp/nhem/bit-screen.lisp, 28-Jul-89 14:42:20, Edit by Chiles.
-  Blaine fixed his fix to the "Reverse Video" hook for the new pop-up displays.
-
-/usr1/lisp/nhem/morecoms.lisp, 28-Jul-89 13:45:33, Edit by Chiles.
-  Restored old definition of "Capitalize Word" and made it loop until it finds
-  the first alphabetic character in the word instead of assuming the first
-  character is capitalizable.
-
-/usr1/lisp/nhem/filecoms.lisp, 27-Jul-89 10:09:56, Edit by Chiles.
-  Blaine made "Log Change" check that the initial buffer still exists before
-  going to it.
-
-/usr1/lisp/nhem/command.lisp, 26-Jul-89 17:49:32, Edit by Chiles.
-  Rewrote "Universal Argument", "Argument Digit", "Negative Argument".  This
-  fixes the bug M-- M-1 M-2 yielding -8 instead of -12.  Now "Universal
-  Argument" strips bits off every character it reads, and it no longer goes
-  through the command loop on repeated C-U input.  The other two commands
-  basically setup to jump into "Universal Argument".  This means to things:
-     1] You no longer can type minus signs after every C-u.
-     2] When typing digits, you cannot invoke any commands bound to
-        a first digit with modifier bits.  This should be no big deal.
-
-/usr1/lisp/hemlock/syntax.lisp, 14-Jul-89 15:26:51, Edit by Chiles.
-/usr1/lisp/hemlock/buffer.lisp, 14-Jul-89 15:17:25, Edit by Chiles.
-/usr1/lisp/hemlock/vars.lisp, 14-Jul-89 14:31:34, Edit by Chiles.
-/usr1/lisp/hemlock/main.lisp, 14-Jul-89 14:33:27, Edit by Chiles.
-  Moved *global-variable-names* back to main.lisp from vars.lisp since vars is
-  loaded before table.lisp which defines MAKE-STRING-TABLE.
-
-  Moved *buffer-names* and *mode-names* back to main.lisp for above reason.
-
-  *command-names* from interp.
-
-  *character-attribute-names from syntax.
-
-
-/usr1/lisp/nhem/font.lisp, 11-Jul-89 15:49:59, Edit by Chiles.
-  Modified NEW-FONT-MARK to terminate a loop correctly and to stop calling
-  DIS-LINE-LINE on nil.
-
-/../victoria/usr2/lisp/hemlock/bit-screen.lisp, 09-Jul-89 15:51:46, Edit by Mbb.
-  Made REVERSE-VIDEO-HOOK-FUN do the right thing for random typeout
-  windows.  I, uhhhh.., kind of missed this.
-
-  Removed an extraneaous variable binding that was causing a "Bound but not
-  referenced error."
-
-
-/usr1/lisp/nhem/completion.lisp, 07-Jul-89 13:00:47, Edit by Chiles.
-  #\' is no longer a completion-wordchar in "Lisp" mode.  Just an oversight.
-
-/usr/lisp/hemlock/rompsite.lisp, 07-Jul-89 16:18:51, Edit by Mbb.
-  Replaced call to INVOKE-HOOK with DOLIST since this is compiled before
-  macros.lisp, analogous to using VARIABLE-VALUE instead of VALUE.
-
-/usr/lisp/hemlock/htext1.lisp, 07-Jul-89 16:06:08, Edit by Mbb.
-/usr/lisp/hemlock/htext4.lisp, 07-Jul-89 16:06:08, Edit by Mbb.
-  Frobbed MOVE-SOME-MARKS in htext1.lisp to allow declarations within the
-  body.  Added declarations using this macro in htext4.  Also gratuitously
-  changed the indentation in htext4 of MOVE-SOME-MARKS (To screw file
-  comparison.)
-
-/usr/lisp/hemlock/tty-screen.lisp, 07-Jul-89 14:29:53, Edit by Mbb.
-  Renamed MAKE-DEVICE to MAKE-TTY-DEVICE.
-
-/usr/lisp/hemlock/struct.lisp, 07-Jul-89 14:19:16, Edit by Mbb.
-/usr/lisp/hemlock/bit-display.lisp, 07-Jul-89 14:15:42, Edit by Mbb.
-/usr/lisp/hemlock/tty-display.lisp, 07-Jul-89 14:20:47, Edit by Mbb.
-  Moved device and hunk stuff into struct.lisp.
-
-/usr/lisp/hemlock/echo.lisp, 07-Jul-89 11:19:23, Edit by Mbb.
-  Made PROMPTING-MERGE-PATHNAMES work.  It used to choke if
-  pathname-defaults was NIL.
-
-  Moved definition of hemlock-eof from main.lisp to echo.lisp, where it
-  belongs.
-
-
-/usr/lisp/hemlock/rompsite.lisp, 06-Jul-89 16:20:13, Edit by Mbb.
-  Moved constant definition of font-map-size from font.lisp to
-  rompsite.lisp because SETUP-FONT-FAMILY assumed that it was a special.
-
-/usr/lisp/hemlock/rompsite.lisp, 06-Jul-89 13:21:21, Edit by Mbb.
-  Moved definitions of *editor-input*, *last-character-typed*, and
-  *character-history* from main.lisp to rompsite.lisp, where they belong,
-  and exported them.
-
-/usr/lisp/hemlock/window.lisp, 06-Jul-89 13:16:55, Edit by Mbb.
-  Moved definitions of *current-window* and *window-list* from main.lisp to
-  window.lisp, exporting *window-list*.
-
-/usr/lisp/hemlock/interp.lisp, 06-Jul-89 13:09:29, Edit by Mbb.
-  Moved definitions of *command-names*, *prefix-argument-supplied*, and
-  *prefix-argument* from main.lisp to interp.lisp, exporting *command-names*.
-
-/usr/lisp/hemlock/buffer.lisp, 06-Jul-89 12:59:36, Edit by Mbb.
-  Moved definitions of *buffer-names*, *buffer-list*, *current-buffer*, and
-  *mode-names* from main.lisp to buffer.lisp, exporting all but
-  *current-buffer*.
-
-/usr/lisp/hemlock/vars.lisp, 06-Jul-89 12:09:46, Edit by Mbb.
-  Moved definition of *global-variable-names* from main.lisp to vars.lisp,
-  where it belongs, and exported it.
-
-/usr/lisp/hemlock/syntax.lisp, 06-Jul-89 11:57:48, Edit by Mbb.
-  Moved *last-character-attibute-requested*, *character-attribute-names*,
-  *value-of-last-character-attribute-requested*, and *character-attributes*
-  from main.lisp to syntax.lisp, exporting *character-attribute-names*.
-
-  Proclaimed the following variables special:
-  (*mode-names* *current-buffer* *last-character-attribute-requested*
-   *value-of-last-character-attribute-requested*).
-
-
-/usr/lisp/hemlock/struct.lisp, 06-Jul-89 11:48:59, Edit by Mbb.
-  Removed definitions of now-tick and TICK and put them in htext1.lisp,
-  exporting now-tick.
-
-/usr/lisp/hemlock/killcoms.lisp, 06-Jul-89 09:40:29, Edit by Mbb.
-  Proclaimed the following variable special:  *delete-char-region*.  
-
-/usr/lisp/hemlock/echocoms.lisp, 06-Jul-89 09:33:57, Edit by Mbb.
-  Proclaimed the following variable special:  *kill-ring*.
-
-/usr/lisp/hemlock/window.lisp, 05-Jul-89 16:39:31, Edit by Mbb.
-  Proclaimed the following variable special:  *buffer-list*.
-
-/usr/lisp/hemlock/tty-screen.lisp, 05-Jul-89 16:37:06, Edit by Mbb.
-  Proclaimed the following variable special:  *parse-starting-mark*.
-
-/usr/lisp/hemlock/screen.lisp, 05-Jul-89 16:30:31, Edit by Mbb.
-  Proclaimed the following variable special:  *echo-area-buffer*.  
-
-/usr/lisp/hemlock/display.lisp, 05-Jul-89 16:28:18, Edit by Mbb.
-  Proclaimed the following variable special:  *window-list*.  
-
-  Moved device and hunk structure definitions to struct.lisp.
-
-
-/usr/lisp/hemlock/hunk-draw.lisp, 05-Jul-89 16:24:18, Edit by Mbb.
-  Proclaimed the following variables special:
-  (*default-border-pixmap* *highlight-border-pixmap*).  
-
-/usr/lisp/hemlock/cursor.lisp, 05-Jul-89 16:15:50, Edit by Mbb.
-  Proclaimed the following variable special:  the-sentinel.  
-
-/usr/lisp/hemlock/linimage.lisp, 05-Jul-89 16:12:41, Edit by Mbb.
-  Proclaimed the following variable special:  *character-attributes*.  
-
-/usr/lisp/hemlock/macros.lisp, 05-Jul-89 16:10:00, Edit by Mbb.
-  Proclaimed the following variable special:  *echo-area-stream*.
-
-/usr/lisp/hemlock/rompsite.lisp, 05-Jul-89 16:02:53, Edit by Mbb.
-  Proclaimed the following variables special:
-  (FONT-MAP-SIZE *DEFAULT-FONT-FAMILY* *CURRENT-WINDOW* *INPUT-TRANSCRIPT*
-   *FOREGROUND-BACKGROUND-XOR* *ECHO-AREA-WINDOW* *BUFFER-NAMES*
-   HEMLOCK::*CREATED-SLAVE-CONNECTED* *CHARACTER-HISTORY*
-   *SCREEN-IMAGE-TRASHED*).
-
-/usr/lisp/hemlock/struct-ed.lisp, 05-Jul-89 15:42:36, Edit by Mbb.
-/usr/lisp/hemlock/lispeval.lisp, 05-Jul-89 15:42:36, Edit by Mbb.
-  Created this file for structures that are only used in the HEMLOCK
-  package.  Moved SERVER-INFO structure from lispeval.lisp to this file.
-
-/usr/lisp/hemlock/rompsite.lisp, 05-Jul-89 15:34:21, Edit by Mbb.
-  Moved the package initialization stuff from rompsite.lisp to ctw.lisp, as
-  this is where it should be.
-
-/usr2/lisp/hemlock/pop-up-stream.lisp, 05-Jul-89 14:07:55, Edit by Mbb.
-/usr2/lisp/hemlock/struct.lisp, 05-Jul-89 14:07:55, Edit by Mbb.
-  Moved the POP-UP-STREAM structure to struct.lisp.
-
-/usr1/mbb/lisp/work/screen.lisp, 03-Jul-89 17:05:58, Edit by Mbb.
-  Made RANDOM-TYPEOUT-CLEANUP clean up the modeline field instead of doing
-  it in both the tty and bitmap cleanup methods.
-
-/usr1/mbb/lisp/work/pop-up-stream.lisp, 03-Jul-89 15:53:13, Edit by Mbb.
-  Made misc methods for line-buffered and full-buffered streams distinct.
-  FORCE-OUTPUT and FINISH-OUTPUT are now no-ops for full-buffered streams.
-
-/usr1/mbb/lisp/work/macros.lisp, 03-Jul-89 15:43:19, Edit by Mbb.
-  Made GET-RANDOM-TYPEOUT-INFO assign distinct misc methods to
-  full-buffered and line-buffered random-typeout streams.
-
-/usr1/lisp/nhem/window.lisp, 02-Jul-89 15:54:40, Edit by Chiles.
-  Added "Maximum Modeline Pathname Length" which defaults to nil.  Wrote
-  BUFFER-PATHNAME-ML-FIELD-FUN.
-
-/usr1/lisp/nhem/morecoms.lisp, 02-Jul-89 16:09:45, Edit by Chiles.
-  Made "Defhvar" propagate any existing hooks as well.
-
-/usr1/lisp/nhem/vars.lisp, 02-Jul-89 15:04:33, Edit by Chiles.
-/usr1/lisp/nhem/syntax.lisp, 02-Jul-89 15:02:25, Edit by Chiles.
-/usr1/lisp/nhem/main.lisp, 02-Jul-89 14:55:14, Edit by Chiles.
-/usr1/lisp/nhem/display.lisp, 02-Jul-89 14:43:59, Edit by Chiles.
-/usr1/lisp/nhem/buffer.lisp, 02-Jul-89 14:38:55, Edit by Chiles.
-  Replaced occurrences of DOLIST used to invoke hook functions with the new
-  INVOKE-HOOK.
-
-/usr1/lisp/nhem/window.lisp, 02-Jul-89 15:06:35, Edit by Chiles.
-/usr1/lisp/nhem/vars.lisp, 02-Jul-89 15:04:33, Edit by Chiles.
-/usr1/lisp/nhem/syntax.lisp, 02-Jul-89 15:02:25, Edit by Chiles.
-/usr1/lisp/nhem/searchcoms.lisp, 02-Jul-89 14:59:43, Edit by Chiles.
-/usr1/lisp/nhem/screen.lisp, 02-Jul-89 14:58:52, Edit by Chiles.
-/usr1/lisp/nhem/rompsite.lisp, 02-Jul-89 14:57:44, Edit by Chiles.
-/usr1/lisp/nhem/mh.lisp, 02-Jul-89 14:56:23, Edit by Chiles.
-/usr1/lisp/nhem/main.lisp, 02-Jul-89 14:55:14, Edit by Chiles.
-/usr1/lisp/nhem/interp.lisp, 02-Jul-89 14:52:04, Edit by Chiles.
-/usr1/lisp/nhem/htext1.lisp, 02-Jul-89 14:49:28, Edit by Chiles.
-/usr1/lisp/nhem/filecoms.lisp, 02-Jul-89 14:41:23, Edit by Chiles.
-/usr1/lisp/nhem/buffer.lisp, 02-Jul-89 14:36:54, Edit by Chiles.
-/usr1/lisp/nhem/bit-screen.lisp, 02-Jul-89 14:33:21, Edit by Chiles.
-  Replaced occurrences of
-     "invoke-hook* '"
-  with
-     "invoke-hook ".
-
-  Replaced occurrences of
-     "invoke-hook '"
-  with
-     "invoke-hook ".
-
-
-/usr1/lisp/nhem/vars.lisp, 02-Jul-89 14:30:55, Edit by Chiles.
-  Deleted function definition for INVOKE-HOOK.
-
-/usr1/lisp/nhem/macros.lisp, 02-Jul-89 13:45:37, Edit by Chiles.
-  Wrote macro INVOKE-HOOK that replaces INVOKE-HOOK* and is exported.
-
-/usr1/lisp/nhem/bit-screen.lisp, 29-Jun-89 11:26:19, Edit by Chiles.
-  Fixed INIT-BITMAP-DEVICE to drop any pending events on the floor, so
-  accidental input while not in Hemlock is ignored.
-
-/usr1/lisp/nhem/lispeval.lisp, 29-Jun-89 10:54:17, Edit by Chiles.
-  Made default value for "Remote Compile File" be nil.
-
-/usr1/lisp/nhem/window.lisp, 29-Jun-89 10:43:26, Edit by Chiles.
-  Moved the :modifiedp modeline-field to be between the modes and buffer name.
-  Modified the :modifiedp and :buffer-pathname update functions accordingly.
-
-/usr1/lisp/nhem/macros.lisp, 29-Jun-89 10:12:25, Edit by Chiles.
-  Fixed GET-RANDOM-TYPEOUT-INFO: it now supplies "Fundamental" only for the
-  random typeout buffer's modes, and the delete hook is now a compiled function
-  instead of interpreted.
-
-/usr1/lisp/nhem/pop-up-stream.lisp, 28-Jun-89 16:41:56, Edit by Chiles.
-  Fixed a bug in RANDOM-TYPEOUT-MISC that called redisplay on the pop-up window
-  when it didn't exist.  When the stream is full-buffered, and no previous
-  random typeout has occurred for a given buffer, the window slot in the stream
-  is nil.  This should be fixed better than I have done.
-
-/usr1/lisp/nhem/lispmode.lisp, 28-Jun-89 16:38:40, Edit by Chiles.
-  Added DEFINDENT for WITH-POP-UP-DISPLAY.
-
-/usr1/mbb/lisp/work/bit-screen.lisp, 22-Jun-89 20:11:59, Edit by Mbb.
-  The device dependant random-typeout-cleanup methods were fixing up the
-  modeline, but this is device independant, so I moved it to screen.lisp.
-
-/usr1/mbb/lisp/work/screen.lisp, 22-Jun-89 19:58:08, Edit by Mbb.
-  RANDOM-TYPEOUT-CLEANUP now sets the Random Typeout buffer's modeline
-  field to :normal.  Before it lost on a Keep character in a more.
-
-/usr1/mbb/lisp/work/pop-up-stream.lisp, 22-Jun-89 19:48:12, Edit by Mbb.
-  Fixed NO-TEXT-PAST-BOTTOM-P to work.  It previously choked when there
-  were no newlines in the buffer.
-
-/usr1/mbb/lisp/work/rompsite.lisp, 22-Jun-89 19:45:54, Edit by Mbb.
-  Made END-RANDOM-TYPEOUT do a more-prompt, in case the user didn't give us
-  a newline on his last line of output.  This was previously a bug.
-
-/usr1/mbb/lisp/work/morecoms.lisp, 22-Jun-89 16:21:43, Edit by Mbb.
-  Made "Capitalize Word" consistent with "Uppercase Word" and "Lowercase
-  Word".  Someone failed to see how easy this was.
-
-/usr1/mbb/lisp/work/diredcoms.lisp, 22-Jun-89 13:15:07, Edit by Mbb.
-/usr1/mbb/lisp/work/rompsite.lisp, 22-Jun-89 13:18:00, Edit by Mbb.
-  Moved DIRECTORYP from diredcoms.lisp to rompsite.lisp.  This is a
-  generally useful function.
-
-/usr1/lisp/nhem/searchcoms.lisp, 22-Jun-89 16:29:05, Edit by Chiles.
-  Fixed a bug in the termination test of the replacement loop.  It used to use
-  a temporary mark to hold onto the end of the region which lost with multiple
-  replacements on the last line with the end of the region at the end of the
-  line.
-
-/usr1/lisp/nhem/bufed.lisp, 22-Jun-89 16:26:59, Edit by Chiles.
-  Made DELETE-BUFED-BUFFERS a buffer local hook for the bufed buffer.
-
-/usr1/mbb/lisp/work/filecoms.lisp, 22-Jun-89 10:43:51, Edit by Mbb.
-  PATHNAME-TO-BUFFER-NAME now returns a string in the form of
-  <file-namestring pathname> <directory-namestring> pathname.
-
-  Deleted *name/type-separator-character*.
-
-
-/usr1/mbb/lisp/work/echocoms.lisp, 21-Jun-89 17:05:36, Edit by Mbb.
-  "Complete Keyword" now only merges with the directory of the default, as
-  opposed to the whole thing.  This makes completion look more like the new
-  confirmation.
-
-/usr1/mbb/lisp/work/morecoms.lisp, 21-Jun-89 21:45:05, Edit by Mbb.
-  Made "List Buffers" tabulate it's output.  It looks better that way.
-
-/usr1/mbb/lisp/work/echo.lisp, 21-Jun-89 15:50:43, Edit by Mbb.
-  Made FILE-VERIFICATION-FUNCTION allow merging of relative pathnames and
-  nearly honest-to-goodness UNIX pathnames.  Eliminated all file-name and
-  file-type merging, only merging with default directory.  However, if the user
-  only inputs a directory spec, then he could only mean to pick up the
-  file-namestring from the defaults.
-
-/usr1/mbb/lisp/work/mh.lisp, 21-Jun-89 11:36:24, Edit by Mbb.
-/usr1/mbb/lisp/work/rompsite.lisp, 21-Jun-89 11:41:52, Edit by Mbb.
-  I moved MERGE-RELATIVE-PATHNAMES from mh.lisp to rompsite.lisp and
-  exported it for its general usefulness.
-
-/usr1/lisp/hemlock/bindings.lisp, 21-Jun-89 13:44:07, Edit by Chiles.
-  Added bindings for "Completion" mode.
-
-/usr1/lisp/nhem/mh.lisp, 19-Jun-89 18:58:03, Edit by Chiles.
-  Modified MH once again to supply nil and nil for the group and account
-  information to RFS-AUTHENTICATE.
-
-/usr1/lisp/nhem/bindings.lisp, 19-Jun-89 16:28:48, Edit by Chiles.
-  Changed binding of "Select Random Typeout Buffer".
-
-/usr1/lisp/nhem/morecoms.lisp, 19-Jun-89 16:26:21, Edit by Chiles.
-  "List Buffers" no longer shows random typeout buffers.
-
-/usr1/mbb/lisp/work/pop-up-stream.lisp, 19-Jun-89 14:02:04, Edit by Mbb.
-  Made line-buffered-moreing work.  A last minute fix before I it went into
-  the last core broke this.
-
-/usr1/mbb/lisp/work/pop-up-stream.lisp, 18-Jun-89 13:26:12, Edit by Mbb.
-  Added :charpos feature to the RANDOM-TYPEOUT-MISC method because format
-  uses it to implement tabbing.
-
-/usr1/mbb/lisp/work/lispbuf.lisp, 18-Jun-89 12:19:52, Edit by Mbb.
-  Made "Editor Describe Function Call" not supply a height to
-  WITH-POP-UP-DISPLAY.
-
-/usr1/mbb/lisp/work/spellcoms.lisp, 16-Jun-89 17:47:30, Edit by Mbb.
-  Added a height specification to the WITH-POP-UP-DISPLAY call in
-  GET-WORD-CORRECTION so the stream would be line-buffered, and thus visible.
-
-/usr1/mbb/lisp/work/macros.lisp, 16-Jun-89 17:27:38, Edit by Mbb.
-/usr1/mbb/lisp/work/pop-up-stream.lisp, 16-Jun-89 17:27:08, Edit by Mbb.
-  Added FORCE-OUTPUT and FINISH-OUTPUT functionality to Random Typeout
-  Streams.
-
-/usr1/mbb/lisp/work/morecoms.lisp, 16-Jun-89 17:24:15, Edit by Mbb.
-  Made "Point to here" issue the traditional "I'm afraid I can't let you do
-  that Dave." message when the usere tries to make the special Random
-  Typeout window current.
-
-/usr1/lisp/hemlock/diredcoms.lisp, 16-Jun-89 01:20:44, Edit by Chiles.
-  Fixed "Copy File" and "Rename File" to no longer think they run in dired
-  buffers.
-
-/usr1/lisp/hemlock/bindings.lisp, 16-Jun-89 01:07:54, Edit by Chiles.
-  Added binding for "Select Random Typeout Buffer".
-
-/usr1/lisp/hemlock/bindings.lisp, 15-Jun-89 16:59:15, Edit by Chiles.
-  Defined #\K to be a :keep logical character.
-
-/usr1/lisp/hemlock/echo.lisp, 15-Jun-89 16:43:16, Edit by Chiles.
-  Added definition for "Keep" logical character.
-
-/usr1/lisp/nhem/mh.lisp, 15-Jun-89 13:14:00, Edit by Chiles.
-  Modified INCORPORATE-NEW-MAIL to better detect mistyped passwords with new MH
-  error messages.
-
-/usr/lisp/hemlock/lisp-lib.lisp, 12-Jun-89 14:55:16, Edit by Mbb.
-  Made "Lisp Library Help" consistent with "Bufed" and other modes that now
-  use the mode-description mechanism.
-
-/usr/lisp/hemlock/window.lisp, 07-Jun-89 16:56:02, Edit by Mbb.
-  Fixed a bug in WINDOW-FOR-HUNK that prevented anyone from making a window
-  1 character high.
-
-/usr/lisp/hemlock/pop-up-stream.lisp, 07-Jun-89 19:10:17, Edit by Mbb.
-  This file replaces tty-stream.lisp and bit-stream.lisp and does essentially
-  the same thing, but in a completely different way.
-
-/usr/lisp/hemlock/display.lisp, 07-Jun-89 18:32:56, Edit by Mbb.
-  Added two slots to the device structure: random-typeout-full-more and
-  random-typeout-line-more.  These are called from the random typeout
-  stream output methods to give users a neat scrolling effect on a bitmap, and
-  on the tty they just clear the window and draw some more lines from the top.
-
-/usr/lisp/hemlock/display.lisp, 07-Jun-89 18:32:56, Edit by Mbb.
-  Made %PRINT-DEVICE-HUNK not choke when the hunk has no associated window.
-
-/usr/lisp/hemlock/mh.lisp, 07-Jun-89 18:30:05, Edit by Mbb.
-  Made the NEW-MAIL-BUF-DELETE-HOOK ignore buffer so the compiler doesn't
-  warn that it was "bound but not referenced".
-
-/usr/lisp/hemlock/bit-screen.lisp, 07-Jun-89 14:52:45, Edit by Mbb.
-  Made BITMAP-RANDOM-TYPEOUT-SETUP create a psuedo-window to display a random
-  typeout buffer.  Also made BITMAP-RANDOM-TYPEOUT-CLEANUP do the right
-  thing.  Two functions were added to deal with the pseudo-window:
-  MAKE-TTY-RANDOM-TYPEOUT-WINDOW and CHANGE-TTY-RANDOM-TYPEOUT-WINDOW.
-
-/usr/lisp/hemlock/tty-screen.lisp, 07-Jun-89 14:26:48, Edit by Mbb.
-  Made TTY-RANDOM-TYPEOUT-SETUP create a psuedo-window to display a random
-  typeout-buffer.  Also made TTY-RANDOM-TYPEOUT-CLEANUP do the right thing.
-  Two functions were added to deal with the psuedo-window :
-  MAKE-BITMAP-RANDOM-TYPEOUT-WINDOW and CHANGE-BITMAP-RANDOM-TYPEOUT-WINDOW.
-
-/usr/lisp/hemlock/screen.lisp, 07-Jun-89 15:07:50, Edit by Mbb.
-  Modified PREPARE-FOR-RANDOM-TYPEOUT and RANDOM-TYPEOUT-CLEANUP to
-  implement the new mechanism.  Also added the modeline field definitions
-  for random typeout buffers.
-
-/usr1/lisp/nhem/keytran.lisp, 05-Jun-89 12:53:12, Edit by Chiles.
-  Fixed a bugt in DEFINE-KEYSYM that alwyas ignores shifted characters.
-
-/usr1/lisp/nhem/rompsite.lisp, 02-Jun-89 11:54:20, Edit by Chiles.
-  Made FUN-DEFINED-FROM-PATHNAME not string-downcase the file.
-
-/usr/lisp/hemlock/spellcoms.lisp, 31-May-89 20:46:54, Edit by Mbb.
-/usr/lisp/hemlock/searchcoms.lisp, 31-May-89 20:44:59, Edit by Mbb.
-/usr/lisp/hemlock/scribe.lisp, 31-May-89 20:44:14, Edit by Mbb.
-/usr/lisp/hemlock/register.lisp, 31-May-89 20:42:46, Edit by Mbb.
-/usr/lisp/hemlock/morecoms.lisp, 31-May-89 20:41:30, Edit by Mbb.
-/usr/lisp/hemlock/mh.lisp, 07-Jun-89 18:30:05, Edit by Mbb.
-/usr/lisp/hemlock/lispeval.lisp, 31-May-89 20:36:12, Edit by Mbb.
-/usr/lisp/hemlock/lispbuf.lisp, 31-May-89 20:30:34, Edit by Mbb.
-/usr/lisp/hemlock/lisp-lib.lisp, 12-Jun-89 14:55:16, Edit by Mbb.
-/usr/lisp/hemlock/filecoms.lisp, 31-May-89 20:21:59, Edit by Mbb.
-/usr/lisp/hemlock/echocoms.lisp, 31-May-89 20:19:14, Edit by Mbb.
-/usr/lisp/hemlock/echo.lisp, 05-Jun-89 15:58:14, Edit by Mbb.
-/usr/lisp/hemlock/doccoms.lisp, 31-May-89 20:13:38, Edit by Mbb.
-/usr/lisp/hemlock/abbrev.lisp, 31-May-89 19:55:20, Edit by Mbb.
-  Changed occurences of WITH-RANDOM-TYPEOUT to WITH-POP-UP-DISPLAY.
-
-/usr1/lisp/nhem/bit-screen.lisp, 31-May-89 21:41:02, Edit by Chiles.
-  The following functions were modified to accomodate using the extra space at
-  the bottom of a window when there is no thumb bar:
-     WRITE-N-EXPOSED-REGIONS
-     WRITE-ONE-EXPOSED-REGION
-     HUNK-PROCESS-INPUT
-     MAYBE-PROMPT-USER-FOR-WINDOW
-     BITMAP-RANDOM-TYPEOUT-SETUP   *** Merge with Blaine.
-     DEFAULT-CREATE-WINDOW-HOOK
-     DEFAULT-CREATE-INITIAL-WINDOWS-HOOK
-     BITMAP-MAKE-WINDOW
-     SET-HUNK-SIZE
-
-/usr/lisp/hemlock/macros.lisp, 31-May-89 19:29:21, Edit by Mbb.
-  Defined the macro WITH-POP-UP-DISPLAY that replaces WITH-RANDOM-TYPEOUT.
-  The new machanism stuffs output into a real hemlock buffer and a pseudo
-  window so users can get to it if they need to.
-
-/usr/lisp/hemlock/rompsite.lisp, 31-May-89 15:35:11, Edit by Mbb.
-  Rewrote WAIT-FOR-MORE and END-RANDOM-TYPEOUT, and added
-  MAYBE-KEEP-RANDOM-TYPEOUT-WINDOW, that will finish output and keep the
-  random typeout window if we're on a bitmap-device.
-
-  Added random-typeout-xevents-mask constant.
-
-
-/usr1/lisp/nhem/hunk-draw.lisp, 31-May-89 14:19:46, Edit by Chiles.
-  Introduced hunk-thumb-bar-bottom-border, 10, and set hunk-bottom-border to 3.
-  Modified hunk-draw-bottom-border accordingly.
-
-/usr1/lisp/nhem/bit-screen.lisp, 31-May-89 10:00:56, Edit by Chiles.
-  Modified HUNK-PROCESS-INPUT to use extra bits below bottom line and above
-  thumb bar as part of the bottom line.  This should eliminate problems with
-  mouse scrolling and point-to-here functionality which otherwise would beep
-  causing the user to move the mouse up a tiny bit.
-
-/usr1/lisp/nhem/lispbuf.lisp, 26-May-89 14:21:11, Edit by Chiles.
-  Made "Select Eval Buffer" supply a buffer local delete hook that sets the
-  special to nil, so Hemlock doesn't hold onto that memory.
-
-/usr1/lisp/nhem/buffer.lisp, 26-May-89 14:18:50, Edit by Chiles.
-  Modified MAKE-BUFFER to check the type of the :delete-hook arg.
-
-/usr1/ch/lisp/complete/table.lisp, 17-Apr-89 18:41:11, Edit by Hoover.
-  Exported STRING-TABLE-SEPARATOR.
-
-  Fixed a bug in FIND-LONGEST-COMPLETION which made COMPLETE-STRING
-  think some :COMPLETE completions were :UNIQUE.
-
-
-/usr1/lisp/nhem/mh.lisp, 19-May-89 17:36:03, Edit by Chiles.
-/usr1/lisp/nhem/dired.lisp, 19-May-89 17:34:35, Edit by Chiles.
-  Replaced all %SES-NAMESTRING uses with NAMESTRING.
-
-/usr1/lisp/nhem/unixcoms.lisp, 17-May-89 11:53:05, Edit by Chiles.
-  Made SCRIBE-FILE move the buffer's point to the end of the buffer.  This
-  still does not do everything you want:
-     Queue multiple scribe requests.
-     Leave a stream around all the time that gets cleaned up when the
-        buffer is deleted, so it can have a disjoint mark from the buffer's
-        point.  The stream is made whenever the buffer is made.
-
-/usr1/lisp/nhem/diredcoms.lisp, 15-May-89 17:04:50, Edit by Chiles and MBB.
-  Added "Dired Information" variable and structure instead of N buffer local
-  variables.  Fixed a couple bugs.  Modified "Dired" to correctly handle
-  file-namestring patterns ... prompts separately with argument.  Must prompt
-  separately because cannot know user's intent and must canonicalize names for
-  uniqueness when looking up dired buffers.
-
-/usr1/lisp/nhem/xcoms.lisp, 12-May-89 11:35:24, Edit by Chiles.
-  Fixed bug in "Stack Window", paren mismatched.
-
-/usr1/lisp/nhem/struct.lisp, 11-May-89 13:41:38, Edit by Chiles.
-  Modified font-mark printing to use double quotes instead of ``''.
-
-/usr1/lisp/nhem/interp.lisp, 11-May-89 13:40:05, Edit by Chiles.
-  Modified command printing to use double quotes instead of ``''.
-
-/usr1/lisp/nhem/htext2.lisp, 11-May-89 13:37:22, Edit by Chiles.
-  Modified line, mark, region, and buffer print functions to use double quotes
-  instead of Scribe ligatures, ``''.  Fixed a bug in mark printing that wrote
-  its last string to *standard-output* instead of the given stream.
-
-/usr1/lisp/hemlock/mh.lisp, 05-May-89 17:01:39, Edit by DBM.
-  Wrote "Message Help", "Headers Help", and "Draft Help".
-
-/usr1/lisp/hemlock/bindings.lisp, 05-May-89 17:03:56, Edit by Chiles.
-  Added bindings for "Message Help", "Headers Help", and "Draft Help".
-
-/usr1/lisp/nhem/dired.lisp, 02-May-89 14:20:43, Edit by Chiles.
-  Fixed a bug in RENAME-FILE not handling a pattern and directory spec
-  combination correctly.
-
-/usr1/lisp/nhem/mh.lisp, 26-Apr-89 14:48:45, Edit by Chiles.
-  Modified doc strings to work better with "Describe Mode".
-
-/usr1/lisp/nhem/echo.lisp, 25-Apr-89 15:21:21, Edit by Chiles.
-  Modified PROMPT-FOR-VAR to call CURRENT-VARIABLE-TABLES.  Modified
-  PROMPT-FOR-FILE to look for the typein in the default directory before
-  merging with the defaults and taking that potentially non-existent file.
-  Re-order a bunch of stuff and cleaned up page titles.
-
-/usr1/lisp/nhem/bindings.lisp, 25-Apr-89 13:18:42, Edit by Chiles.
-  Removed binding (bind-key "Do Nothing" #\super-leftup :mode "Bufed").
-
-/usr1/lisp/nhem/bindings.lisp, 24-Apr-89 15:44:17, Edit by Chiles.
-  Added "View" mode bindings similar to "Message" mode bindings.
-
-/usr1/lisp/nhem/morecoms.lisp, 24-Apr-89 14:46:36, Edit by Chiles.
-  Modified "Generic Pointer Up" and "Point to Here".
-
-/usr1/lisp/nhem/bufed.lisp, 24-Apr-89 14:41:51, Edit by Chiles.
-  Modified "Bufed Goto and Quit".
-
-/usr1/lisp/nhem/interp.lisp, 24-Apr-89 14:09:41, Edit by Chiles.
-  Modified BIND-KEY to provide a restart before signalling an non-existent
-  command error.
-
-/usr1/lisp/nhem/searchcoms.lisp, 20-Apr-89 18:35:53, Edit by Chiles.
-  Rewrote QUERY-REPLACE-FUNCTION, modifying REPLACE-THAT-CASE and creating
-  QUERY-REPLACE-LOOP, to clean things up.  Fixed bug in return values that
-  broke "Group Query Replace".
-
-/usr1/lisp/nhem/spellcoms.lisp, 19-Apr-89 14:40:36, Edit by Chiles.
-  Modified CORRECT-BUFFER-WORD-END to return values other than nil when end and
-  start were only one character apart.
-
-/usr1/lisp/hemlock/diredcoms.lisp, 18-Apr-89 14:23:38, Edit by Chiles.
-  Modified ARRAY-ELEMENT-FROM-MARK to no longer move the mark argument
-  since it can correctly count the number of lines in the region anyway.
-
-/usr1/lisp/nhem/diredcoms.lisp, 18-Apr-89 11:11:21, Edit by Chiles.
-  Rewrote "View Return" and "View Quit" since they didn't interact correctly.
-
-/usr1/lisp/nhem/xcoms.lisp, 17-Apr-89 15:48:58, Edit by Chiles.
-  Fixed bug in "Stack Window".  It now signals an editor-error unless the
-  device is a hi::bitmap-device.  This command probably should be deleted since
-  it is somewhat silly and written only for one person.
-
-/usr1/lisp/nhem/filecoms.lisp, 12-Apr-89 15:19:52, Edit by Chiles.
-  Made "Revert File" keep buffer's pathname when reverting to checkpoint file.
-
-/usr1/lisp/nhem/bindings.lisp, 12-Apr-89 14:48:52, Edit by Chiles.
-  Added binding for "Select Scribe Warnings".
-
-  Deleted bindings of "Goto Dired Buffer" and "Goto Dired Buffer Quitting".
-  Added "View" mode bindings for "View Return" and "View Quit".
-
-
-/usr1/lisp/nhem/struct.lisp, 12-Apr-89 14:14:12, Edit by Chiles.
-  Exported and provided a doc string for BUFFER-DELETE-HOOK.
-
-/usr1/mbb/lisp/nhem/searchcoms.lisp, 11-Apr-89 13:44:13, Edit by Blaine.
-  Made "Query Replace" and "Replace String" echo how many occurrences are
-  replaced.
-
-/usr1/mbb/lisp/nhem/searchcoms.lisp, 11-Apr-89 13:44:13, Edit by Blaine.
-  Made the doc-strings for "List Matching Lines", "Delete Matcing Lines",
-  "Delete Non-matching Lines", "Count Occurrences", "Replace String", and
-  "Query Replace" indicate that they are sensitive to the active-region.
-
-/usr1/mbb/lisp/nhem/scribe.lisp, 10-Apr-89 22:30:25, Edit by Blaine.
-  Wrote the "Select Scribe Warnings", which goes to the buffer named "Scribe
-  Warnings" if it exists.
-
-/usr1/mbb/lisp/nhem/lisp-lib.lisp, 10-Apr-89 21:39:51, Edit by Blaine.
-  Made "Describe Library Entry" and "Desribe Pointer Library Entry" put the
-  user in view mode instead of normal editing mode.  Also added the command
-  ARRAY-ELEMENT-FROM-POINTER-Y-POS which returns an array element whose index
-  is determined by the y position, in lines, of the pointer.
-
-/usr1/mbb/lisp/nhem/bufed.lisp, 10-Apr-89 21:29:20, Edit by Blaine.
-  Fixed a few bugs in Bufed.  Made "Bufed Undelete" replace #\D with #\space.
-  Made "Bufed Goto and Quit" use the pointer location instead of the
-  current-point.  Also made bufed not move the current-point.
-
-/usr1/mbb/lisp/nhem/diredcoms.lisp, 11-Apr-89 13:22:44, Edit by Blaine.
-  Fixed bug in UPDATE-DIRED-BUFFER.  I was setting "Dired Buffer Files" inside
-  of a dotimes when it should have been outside.
-
-  Deleted commands "Goto Dired Buffer" and "Goto Dired Buffer Quitting" in lieu
-  of "View REturn" and "View Quit".
-
-  Wrote "Dired from Buffer Pathname".
-
-
-/usr1/lisp/nhem/mh.lisp, 10-Apr-89 10:20:42, Edit by Chiles.
-  Modified SUB-WRITE-MH-SEQUENCE to bind *print-base* to 10 when writing
-  message ID's.
-
-/usr1/ch/lisp/spell/spell-build.lisp, 08-Apr-89 16:55:52, Edit by Hoover.
-  Increased max-entry-count-estimate to 15600 in order to build the new
-  dictionary.  Updated filenames in comments and added a line specifying
-  compilation dependencies.
-
-  Picked up the latest ispell dictionary and merged in local favorites.
-  This dictionary is available via anonymous ftp from celray.cs.yale.edu
-  (128.36.0.25) and locally as /../m/usr/misc/.ispell/src/dict.191.
-
-/usr1/lisp/nhem/lispmode.lisp, 07-Apr-89 16:25:51, Edit by Chiles.
-  Added DEFINDENT for WITH-WRITABLE-BUFFER.
-
-/usr1/lisp/nhem/diredcoms.lisp, 07-Apr-89 16:22:05, Edit by Chiles.
-  Modifed INITIALIZE-DIRED-BUFFER and "Dired" to beep and blow off the dired
-  when no entries satisfy the spec.
-
-/usr1/lisp/nhem/echocoms.lisp, 07-Apr-89 10:49:09, Edit by Chiles.
-  Added "ps" to "Ignore File Types".
-
-/usr1/lisp/nhem/mh.lisp, 04-Apr-89 00:16:54, Edit by Chiles.
-  Wrote GET-STORABLE-MSG-BUF-NAME and used it inside SHOW-HEADERS-MESSAGE and
-  SHOW-MESSAGE-OFFSET-MSG-BUF.
-
-  Removed variable "Deliver Message Deleting Buffers".  I modified
-  DELIVER-DRAFT-BUFFER-MESSAGE to ignore it.  This now also always deletes the
-  draft buffer, regardless of whether this variable is re-installed.  Now the
-  message buffer is always deleted unless it is kept.  "Delete Draft and
-  Buffer" now also always deletes the message buffer unless it is kept.  IF the
-  variable is re-installed this deletion will be guarded by it as well.
-
-
-/usr1/lisp/nhem/bindings.lisp, 03-Apr-89 12:21:51, Edit by Chiles.
-  Changed binding of "Define Keyboard Macro Key" to C-x M-(.
-
-/usr1/lisp/nhem/bindings.lisp, 02-Apr-89 16:44:54, Edit by Chiles.
-  Fixed mail bindings that got switched up or something, "Next Message", "Next
-  Undeleted Message", "Previous Message", "Previous Undeleted Message".
-
-/usr1/lisp/nhem/bindings.lisp, 01-Apr-89 16:38:10, Edit by Chiles.
-  Bound "Bufed" to C-x C-M-b, and changed some c-'s to control-'s.
-
-/usr1/lisp/nhem/morecoms.lisp, 31-Mar-89 18:24:30, Edit by Chiles.
-  Wrote "Generic Pointer Up" to replace "Push Mark/Point to Here" and added
-  ADD-GENERIC-POINTER-UP-FUNCTION.  Modified "Point to Here" in accordance.
-
-/usr1/lisp/nhem/bufed.lisp, 31-Mar-89 18:34:40, Edit by Chiles.
-  Fixed "Bufed Goto and Quit".  Modified "Bufed" to move point to the beginning
-  of the buffer.
-
-/usr1/lisp/nhem/bindings.lisp, 31-Mar-89 18:27:02, Edit by Chiles.
-  Changed bindings of "Push Mark/Point to Here" to "Generic Pointer Up".
-
-/usr1/lisp/nhem/mh.lisp, 31-Mar-89 13:40:46, Edit by Chiles.
-  Fixed a bug in SETUP-REMAIL-DRAFT-BUFFER recently introduced by tweaking
-  cleanup hooks.  THis now makes a dummy "Draft Information" variable.
-
-/usr1/lisp/nhem/macros.lisp, 29-Mar-89 22:19:57, Edit by Chiles.
-  Changed error handler to take r and R for restarts instead of P.
-
-/usr1/lisp/nhem/dired.lisp, 29-Mar-89 21:41:04, Edit by Chiles.
-  Renamed MAKEDIR to MAKE-DIRECTORY.
-
-/usr1/lisp/nhem/diredcoms.lisp, 29-Mar-89 17:04:51, Edit by Chiles.
-  Modified some doc strings and rewrote "Dired Help" to use "Describe Mode".
-
-/usr1/lisp/nhem/bufed.lisp, 29-Mar-89 16:53:06, Edit by Chiles.
-  Fixed some documentation and rewrote "Bufed Help" to use "Describe Mode".
-
-/usr1/lisp/nhem/bindings.lisp, 29-Mar-89 16:45:08, Edit by Chiles.
-  Added binding for "Bufed Help".
-
-/usr1/lisp/nhem/bufed.lisp, 29-Mar-89 16:36:53, Edit by Chiles.
-  Added documentation to mode "Bufed".
-
-/usr1/lisp/nhem/doccoms.lisp, 29-Mar-89 15:52:11, Edit by Chiles.
-  Wrote "Describe Mode" and hooked it into "Help".
-
-/usr1/lisp/nhem/buffer.lisp, 29-Mar-89 11:24:19, Edit by Chiles.
-  Wrote MODE-DOCUMENTATION and exported it.
-
-/usr1/lisp/nhem/filecoms.lisp, 28-Mar-89 17:24:47, Edit by Chiles.
-  Removed "Rename File" and "Delete File".
-
-/usr1/lisp/nhem/dired.lisp, 28-Mar-89 16:42:27, Edit by Chiles.
-  Removed "[Yes]" from DELETE-FILE-2
-
-/usr1/lisp/nhem/diredcoms.lisp, 28-Mar-89 16:03:16, Edit by Chiles.
-  Moved "Delete File" here and made it consistent with the new "Copy File" and
-  "Rename File" in that it calls out to the dired package.
-
-/usr1/lisp/hemlock/bindings.lisp, 28-Mar-89 11:32:03, Edit by DBM.
-  Names for a couple of bindings were incorrect and have been
-  fixed.
-
-/usr1/lisp/nhem/diredcoms.lisp, 28-Mar-89 11:19:50, Edit by Chiles.
-  Modified "View File" to name buffers better.
-
-/usr1/lisp/nhem/bindings.lisp, 27-Mar-89 13:01:14, Edit by Chiles.
-  Forgot a copy and rename dired bindings.
-
-/usr1/lisp/nhem/mh.lisp, 27-Mar-89 11:46:28, Edit by Chiles.
-  Fixed :delete-hook arg that was not a list.
-
-/usr1/lisp/nhem/lispeval.lisp, 25-Mar-89 09:44:46, Edit by Chiles.
-  Wrote "Editor Server Name".
-
-/usr1/lisp/nhem/rompsite.lisp, 25-Mar-89 09:37:57, Edit by Chiles.
-  Modified INIT-EDITOR-SERVER to include process ID in editor server name for
-  same user, same machine, multiple instance protection.
-
-/usr1/lisp/nhem/lispbuf.lisp, 24-Mar-89 23:19:56, Edit by Chiles.
-/usr1/lisp/nhem/lispbuf.lisp, 24-Mar-89 23:12:48, Edit by Chiles.
-  "Reenter Interactive Input" must copy the region when it is active since
-  moving the point changed the input region.  There also was a bug that it
-  checked for the value of buffer-input-mark, but this has no global binding.
-  It now checks for a binding instead of a non-nil value.
-
-/usr1/lisp/nhem/spellcoms.lisp, 24-Mar-89 21:44:36, Edit by Chiles.
-  Made CORRECT-BUFFER-SPELLING and SPELL-PREVIOUS-WORD always ignore trailing
-  apostrophe s's on words.
-
-/usr1/lisp/nhem/bindings.lisp, 23-Mar-89 20:51:16, Edit by Chiles.
-  Added Bufed bindings.
-
-/usr1/lisp/nhem/bufed.lisp, 23-Mar-89 20:52:48, Edit by Chiles.
-  New file.
-
-/usr1/lisp/nhem/ts.lisp, 22-Mar-89 17:04:44, Edit by Chiles.
-/usr1/lisp/nhem/srccom.lisp, 22-Mar-89 17:04:02, Edit by Chiles.
-/usr1/lisp/nhem/spellcoms.lisp, 22-Mar-89 17:03:17, Edit by Chiles.
-/usr1/lisp/nhem/register.lisp, 22-Mar-89 17:00:37, Edit by Chiles.
-/usr1/lisp/nhem/morecoms.lisp, 22-Mar-89 16:59:49, Edit by Chiles.
-/usr1/lisp/nhem/mh.lisp, 22-Mar-89 16:59:08, Edit by Chiles.
-/usr1/lisp/nhem/lispeval.lisp, 22-Mar-89 16:58:16, Edit by Chiles.
-/usr1/lisp/nhem/lisp-lib.lisp, 22-Mar-89 16:57:31, Edit by Chiles.
-/usr1/lisp/nhem/killcoms.lisp, 22-Mar-89 15:27:23, Edit by Chiles.
-/usr1/lisp/nhem/htext2.lisp, 22-Mar-89 15:24:23, Edit by Chiles.
-/usr1/lisp/nhem/hi-integrity.lisp, 22-Mar-89 15:23:12, Edit by Chiles.
-/usr1/lisp/nhem/filecoms.lisp, 22-Mar-89 15:22:19, Edit by Chiles.
-/usr1/lisp/nhem/edit-defs.lisp, 22-Mar-89 15:21:01, Edit by Chiles.
-/usr1/lisp/nhem/echocoms.lisp, 22-Mar-89 14:59:18, Edit by Chiles.
-/usr1/lisp/nhem/echo.lisp, 22-Mar-89 14:57:55, Edit by Chiles.
-/usr1/lisp/nhem/diredcoms.lisp, 22-Mar-89 14:13:31, Edit by Chiles.
-/usr1/lisp/nhem/cursor.lisp, 22-Mar-89 14:11:46, Edit by Chiles.
-/usr1/lisp/nhem/command.lisp, 22-Mar-89 14:09:36, Edit by Chiles.
-/usr1/lisp/nhem/bit-screen.lisp, 22-Mar-89 14:08:27, Edit by Chiles.
-  Replaced idioms with BUFFER-START-MARK and BUFFER-END-MARK.
-
-/usr1/lisp/nhem/buffer.lisp, 22-Mar-89 14:05:29, Edit by Chiles.
-  Wrote BUFFER-START-MARK and BUFFER-END-MARK.
-
-/usr1/lisp/nhem/lisp-lib.lisp, 21-Mar-89 14:32:14, Edit by Chiles.
-  Modified all Lisp Library commands to signal an editor-error when not in a
-  library buffer.
-
-/usr1/lisp/nhem/morecoms.lisp, 21-Mar-89 14:22:02, Edit by Mbb.
-  Made "Count Occurrences" use the active region when it exists, otherwise
-  point to end of buffer.  "Count Lines Region" became "Count Lines", and
-  "Count Words Region" became "Count Words".  These two use the active region
-  now too.
-
-/usr1/lisp/nhem/searchcoms.lisp, 21-Mar-89 14:19:17, Edit by Mbb.
-  Made QUERY-REPLACE-FUNCTION use the active region if it exists, otherwise
-  point to end of buffer.  Also, "List Matching Lines", "Delete Matching
-  Lines", and "Delete Non-Matching Lines" handle the active region similarly.
-
-/usr1/lisp/nhem/spellcoms.lisp, 20-Mar-89 15:17:19, Edit by Chiles.
-  Made CORRECT-BUFFER-SPELLING and SPELL-PREVIOUS-WORD ignore apostrophes
-  following words.
-
-/usr1/lisp/nhem/mh.lisp, 17-Mar-89 11:16:13, Edit by Chiles.
-  Replaced MODIFYING-MAIL-BUF with WITH-WRITABLE-BUFFER.
-
-/usr1/lisp/nhem/buffer.lisp, 17-Mar-89 11:07:41, Edit by Chiles.
-  Wrote WITH-WRITABLE-BUFFER.
-
-/usr1/lisp/nhem/window.lisp, 16-Mar-89 11:13:41, Edit by Chiles.
-  Made MAKE-MODELINE-FIELD have a restart that clobbers the existing defintion
-  of a modeline field name.
-
-/usr1/lisp/nhem/display.lisp, 14-Mar-89 23:19:27, Edit by Chiles.
-  Made REDISPLAY-WINDOWS-FROM-MARK invoke *things-to-do-once*.  Some commands
-  were making buffers, using line buffered output streams
-  (WITH-OUTPUT-TO-MARK), and when redisplaying from the mark.  This didn't
-  allow the chance for the buffer's modeline info object's start fields to get
-  initialized via UPDATE-MODELINE-FIELDS.
-
-/usr1/ch/lisp/complete/table.lisp, 14-Mar-89 19:46:09, Edit by Hoover.
-  Fixed a bogus declaration in COMPUTE-FIELD-POS.
-
-/usr1/lisp/nhem/echo.lisp, 14-Mar-89 14:07:56, Edit by Chiles.
-  Wrote BUFFER-VERIFICATION-FUNCTION which now moves the point around for
-  ambiguous shit.
-
-/usr1/lisp/nhem/echocoms.lisp, 14-Mar-89 13:22:31, Edit by Chiles.
-  Made "Complete Keyword" move the point in the echo area to the first
-  ambiguous field for :keyword completion (when the prefix is ambiguous of
-  course).
-
-/usr1/lisp/nhem/filecoms.lisp, 14-Mar-89 11:04:49, Edit by Chiles.
-  Modified PROCESS-FILE-OPTIONS to LOUD-MESSAGE and abort file options on
-  parsing errors.  It still goes on to try to set a major mode.
-
-/usr1/lisp/nhem/table.lisp, 13-Mar-89 13:17:32, Edit by Chiles.
-  Eliminated optional argument to COMPLETE-STRING.  Entered code for signalling
-  an error if the tables did not contain the same separator character, but
-  commented it out.
-
-/usr1/lisp/nhem/bindings.lisp, 09-Mar-89 16:19:19, Edit by Chiles.
-  Added more page titles.  Voided some character translations and made up for
-  the few commands that needed to be duplicated.
-
-/usr1/lisp/nhem/window.lisp, 07-Mar-89 16:37:18, Edit by Chiles.
-  Added print function for modeline field info objects.
-
-/usr1/lisp/nhem/edit-defs.lisp, 07-Mar-89 10:59:30, Edit by Chiles.
-  Made GO-TO-DEFINITION use name-len instead of calculating it again.
-
-/usr1/lisp/nhem/mh.lisp, 06-Mar-89 21:37:11, Edit by Chiles.
-  Now make new mail buffer with delete-hook NEW-MAIL-BUF-DELETE-HOOK.  Delete
-  old CLEANUP-NEW-MAIL-BUF-DELETION.
-
-  Made CLEANUP-HEADERS-BUFFER, CLEANUP-MESSAGE-BUFFER, and CLEANUP-DRAFT-BUFFER
-  no longer check for their appropriate information structure.  Made
-  MAYBE-MAKE-MH-BUFFER set buffer local deletion hooks for these functions.
-
-
-/usr1/lisp/nhem/buffer.lisp, 06-Mar-89 21:25:54, Edit by Chiles.
-  MAKE-BUFFER now takes a :delete-hook argument, and DELETE-BUFFER now invokes
-  these functions.
-
-/usr1/lisp/nhem/struct.lisp, 06-Mar-89 21:19:05, Edit by Chiles.
-  Made buffer structure have a local delete hooks list.
-
-/usr1/lisp/nhem/highlight.lisp, 06-Mar-89 17:54:46, Edit by Chiles.
-  Made HIGHLIGHT-ACTIVE-REGION no longer do anything on the tty.
-
-/usr1/lisp/nhem/filecoms.lisp, 03-Mar-89 18:02:19, Edit by Chiles.
-  Fixed some recently lost functionality in "Create Buffer".
-
-/usr1/lisp/nhem/dired.lisp, 01-Mar-89 11:07:46, Edit by Chiles.
-  Modified ARRAY-ELEMENT-FROM-MARK to take an error message.
-
-/usr1/lisp/nhem/dired.lisp, 27-Feb-89 15:03:49, Edit by Chiles.
-  DELETE-FILE-AUX no longer outputs deleted file names on standard output.
-
-/usr1/lisp/nhem/kbdmac.lisp, 23-Feb-89 10:36:37, Edit by Chiles.
-  Changed "Define Keyboard Macro Key" message.
-
-/usr1/lisp/hemlock/rompsite.lisp, 07-Mar-89 17:33:05, Edit by DBM.
-  Modified the Hemlock GC notify functions to conform with the new
-  format for the messages.
-
-/usr1/lisp/nhem/dired.lisp, 27-Feb-89 15:03:49, Edit by Chiles.
-  DELETE-FILE-AUX no longer outputs deleted file names on standard output.
-
-/usr1/lisp/nhem/kbdmac.lisp, 23-Feb-89 10:36:37, Edit by Chiles.
-  Changed "Define Keyboard Macro Key" message.
-
-/usr1/lisp/nhem/complete/bindings.lisp, 22-Feb-89 14:31:11, Edit by Chiles.
-  Added new keyboard macro bindings.
-
-/usr1/lisp/nhem/complete/kbdmac.lisp, 22-Feb-89 14:22:01, Edit by Chiles.
-  Added new command "Define Keyboard Macro Key".
-
-/usr1/lisp/nhem/complete/scribe.lisp, 21-Feb-89 12:52:19, Edit by Chiles.
-/usr1/lisp/nhem/complete/morecoms.lisp, 21-Feb-89 12:50:45, Edit by Chiles.
-/usr1/lisp/nhem/complete/doccoms.lisp, 21-Feb-89 12:46:15, Edit by Chiles.
-/usr1/lisp/nhem/complete/abbrev.lisp, 21-Feb-89 12:42:26, Edit by Chiles.
-  Modified MAKE-STRING-TABLE call.
-
-/usr1/lisp/nhem/complete/echo.lisp, 21-Feb-89 12:37:06, Edit by Chiles.
-  Modified for new string tables.
-
-/usr1/lisp/nhem/complete/echocoms.lisp, 21-Feb-89 11:50:59, Edit by Chiles.
-  Modified stuff for new string tables.
-
-/usr1/lisp/nhem/complete/struct.lisp, 21-Feb-89 11:43:26, Edit by Chiles.
-  Added new setf method for string tables.
-
-/usr1/lisp/nhem/complete/complete.lisp, 21-Feb-89 11:46:04, Edit by Chiles.
-  New file.
-
-/usr1/lisp/nhem/complete/macros.lisp, 21-Feb-89 11:45:10, Edit by Chiles.
-  Added new DO-STRINGS.
-
-/usr1/lisp/hemlock/dired.lisp, 22-Feb-89 16:36:49, Edit by DBM.
-  Fixed "Dired Help" string.
-
-/usr1/lisp/hemlock/mh.lisp, 21-Feb-89 14:25:42, Edit by Chiles.
-  Added delete-buffer-hook to set *new-mail-buffer* to nil.
-
-/usr1/lisp/nhem/rompsite.lisp, 20-Feb-89 16:54:11, Edit by Chiles.
-  Added load for hem:lisp-lib.fasl.
-
-/usr1/lisp/nhem/lisp-lib.lisp, 20-Feb-89 16:51:19, Edit by Chiles.
-  This is a new file.
-
-/usr1/lisp/nhem/bindings.lisp, 20-Feb-89 16:50:13, Edit by Chiles.
-  Added "Lisp-Lib" bindings.
-
-/usr1/lisp/nhem/dired.lisp, 15-Feb-89 15:20:25, Edit by Chiles.
-  This is a new file.
-
-/usr1/lisp/nhem/bindings.lisp, 15-Feb-89 15:20:03, Edit by Chiles.
-  Added Dired bindings.
-
-/usr1/lisp/nhem/rompsite.lisp, 14-Feb-89 18:04:46, Edit by Chiles.
-  Added load for dired.fasl.
-
-/usr1/lisp/nhem/srccom.lisp, 14-Feb-89 16:16:11, Edit by Chiles.
-  Fixed some silly coding.
-
-/usr1/lisp/nhem/rompsite.lisp, 14-Feb-89 16:06:28, Edit by Chiles.
-  Removed tty MESSAGE of GC info.
-
-/usr1/lisp/nhem/scribe.lisp, 14-Feb-89 11:08:53, Edit by Chiles.
-  Made "Insert Scribe Directive" use the active region for environments.
-
-/usr1/lisp/nhem/group.lisp, 13-Feb-89 16:19:57, Edit by Chiles.
-  Put back routine I accidently deleted.
-
-/usr1/lisp/nhem/struct.lisp, 10-Feb-89 16:45:23, Edit by Chiles.
-  Deleted export of COPY-MODELINE-FIELD.
-
-/usr1/ch/lisp/rompsite.lisp, 02-Feb-89 16:49:42, Edit by Christopher Hoover.
-  Changed font path support to use EXT:CAREFULLY-ADD-FONT-PATHS.  Made
-  Hemlock look first on the local machine and then in AFS for fonts.
-
-/usr1/lisp/nhem/searchcoms.lisp, 31-Jan-89 11:00:10, Edit by Chiles.
-  Installed "String Search Ignore Case" and removed "Default Search Kind".
-
-/usr1/lisp/nhem/rompsite.lisp, 30-Jan-89 15:17:12, Edit by Chiles.
-  Changed underline font variable values and set up to really use X11 font
-  paths.
-
-/usr1/lisp/nhem/bindings.lisp, 27-Jan-89 13:31:13, Edit by Chiles.
-  Removed "Typescript" mode local binding of "Process Control invoke EXT:ABORT"
-  to #\hyper-a.
-
-/usr1/lisp/nhem/macros.lisp, 20-Jan-89 16:11:18, Edit by Chiles.
-  Fixed bug in LISP-ERROR-ERROR-HANDLER that allowed logical characters in
-  COMMAND-CASE to throw us into the debugger with a recursive error.
-
-/usr1/lisp/nhem/doccoms.lisp, 16-Jan-89 19:04:03, Edit by Chiles.
-  Fixed doc string for "Help" p.
-
-/usr1/lisp/nhem/macros.lisp, 11-Jan-89 23:03:10, Edit by Chiles.
-  Deleted export of IGNORE-EDITOR-ERRORS which no longer exists.
-
-/usr1/lisp/nhem/htext1.lisp, 11-Jan-89 22:54:14, Edit by Chiles.
-  Exported LINE> and LINES-RELATED.
-
-/usr1/lisp/nhem/window.lisp, 11-Jan-89 22:45:22, Edit by Chiles.
-  Removed some bogus exports dirtying the system with "nonexistent" symbols.
-
-/usr1/lisp/nhem/filecoms.lisp, 11-Jan-89 13:37:41, Edit by Chiles.
-  Fixed bug in READ-BUFFER-FILE invoking hook on wrong pathname (not probed
-  one).
-
-/usr1/lisp/nhem/filecoms.lisp, 10-Jan-89 18:03:38, Edit by Chiles.
-  Fixed bug in PATHNAME-TO-BUFFER-NAME.
-
-/usr1/lisp/nhem/lispeval.lisp, 05-Jan-89 17:21:54, Edit by Chiles.
-  Made "Describe Symbol" use MARK-SYMBOL
-
-/usr1/lisp/nhem/lispbuf.lisp, 05-Jan-89 17:20:12, Edit by Chiles.
-  Wrote MARK-SYMBOL and made "Editor Describe Symbol" use it.
-
-/usr1/lisp/nhem/scribe.lisp, 05-Jan-89 15:55:23, Edit by Chiles.
-  Made INSERT-SCRIBE-DIRECTIVE use the next word if the mark is immediately
-  before it, instead of the previous word.  Cleaned up the code some and
-  documented it (oh no!).
-
-/usr1/lisp/nhem/spellcoms.lisp, 05-Jan-89 15:32:32, Edit by Chiles.
-  Made SPELL-PREVIOUS-WORD return the next word when the mark is immediately
-  before the next word, such that the cursor is displayed within that word.
-  Renamed "Correct Word Spelling" to "Check Word Spelling" and "Check Word
-  Spelling" to "Auto Check Word Spelling".
-
-/usr1/lisp/nhem/rompsite.lisp, 03-Jan-89 11:37:50, Edit by Chiles.
-  Made INVOKE-SCHEDULED-EVENTS bind *time-queue* to nil around invoking event
-  function.
-
-/usr1/lisp/nhem/hunk-draw.lisp, 02-Jan-89 15:53:58, Edit by Chiles.
-  Fixed problem with underline font leaving dots at the end of lines.  I was
-  copying the pixmap onto the screen one pixel short of the appropriate length.
-
-/usr1/lisp/nhem/lispeval.lisp, 23-Dec-88 15:13:07, Edit by Chiles.
-  Rewrote "Compile Defun", "Evaluate Defun", and "Re-evaluate Defvar" to
-  use DEFUN-REGION.
-
-/usr1/lisp/nhem/lispbuf.lisp, 23-Dec-88 15:04:46, Edit by Chiles.
-  Wrote DEFUN-REGION and rewrote "Editor Compile Defun", "Editor Evaluate
-  Defun", and "Editor Re-evaluate Defvar" to use it.
-
-/usr1/lisp/nhem/lispmode.lisp, 22-Dec-88 23:43:33, Edit by Chiles.
-  Wrote MARK-TOP-LEVEL-FORM.  Rewrote "Mark Defun" and "End of Defun" to use
-  it.  Added doc strings to START-DEFUN-P and INSIDE-DEFUN-P.
-
-/usr1/lisp/nhem/keytran.lisp, 22-Dec-88 17:39:21, Edit by Chiles.
-  Fixed a bug in TRANSLATE-MOUSE-CHARACTER that would have tried to set the
-  :lock bit for a character which our system doesn't support.
-
-/usr1/lisp/nhem/mh.lisp, 21-Dec-88 14:26:09, Edit by Chiles.
-  Replaced occurrences of FILL-REGION-COMMAND-AUX with
-  FILL-REGION-BY-PARAGRAHPS.
-
-/usr1/lisp/nhem/fill.lisp, 21-Dec-88 13:59:36, Edit by Chiles.
-  Renamed FILL-REGION-COMMAND-AUX to FILL-REGION-BY-PARAGRAHPS.  Made some
-  arguments optional.
-
-/usr1/lisp/nhem/morecoms.lisp, 20-Dec-88 17:31:29, Edit by Chiles.
-  Modified PAGE-DIRECTORY to clean it up and made it pull control-l's off the
-  line strings if it occurred as the first characters.
-
-/usr1/lisp/nhem/window.lisp, 19-Dec-88 13:52:23, Edit by Chiles.
-  Modified WINDOW-CHANGED to update the modeline's dis-line length.
-
-/usr1/lisp/nhem/unixcoms.lisp, 17-Dec-88 10:53:54, Edit by Chiles.
-/usr1/lisp/nhem/mh.lisp, 17-Dec-88 10:53:13, Edit by Chiles.
-/usr1/lisp/nhem/lispeval.lisp, 17-Dec-88 10:52:09, Edit by Chiles.
-/usr1/lisp/nhem/lispbuf.lisp, 17-Dec-88 10:51:08, Edit by Chiles.
-  Changed instances of WRITE-DA-FILE to WRITE-BUFFER-FILE.
-
-/usr1/lisp/nhem/killcoms.lisp, 14-Dec-88 23:32:02, Edit by Chiles.
-  Fixed a bug in the KILL-REGION/KILL-CHARACTER interaction code -- needed to
-  set the *delete-char-region* to nil when the previous command type was a
-  region kill.
-
-/usr1/lisp/nhem/echo.lisp, 14-Dec-88 22:40:43, Edit by Chiles.
-  Modified PROMPT-FOR-BUFFER to disallow input of the empty string when no
-  default is offered.  This now permits defaults to be specified with
-  :default-string even when :default is nil, but when :must-exist is non-nil,
-  :default-string must name an existing buffer.
-
-/usr1/lisp/nhem/filecoms.lisp, 14-Dec-88 22:13:17, Edit by Chiles.
-  Rewrote "Create Buffer".  It now offers a default of "Buffer n".
-
-  Added doc strings for BUFFER-DEFAULT-PATHNAME and PATHNAME-TO-BUFFER-NAME.
-  Changed what PATHNAME-TO-BUFFER-NAME does.  When there is a type but no name,
-  it inserts *name/type-separator-character* before the type.
-
-  Renamed WRITE-DA-FILE to WRITE-BUFFER-FILE, and READ-DA-FILE to
-  READ-BUFFER-FILE.  Modified FIND-FILE-BUFFER and "Visit File".  Hope they're
-  right.
-
-  "Process File Options" no longer complains about a missing pathname.
-  PROCESS-FILE-OPTIONS is willing to handle a buffer without an associated
-  pathname.
-
-
-/usr1/lisp/nhem/echo.lisp, 14-Dec-88 22:05:31, Edit by Chiles.
-  PROMPT-FOR-BUFFER does not allow the empty string to be supplied anymore.
-
-/usr1/lisp/nhem/srccom.lisp, 14-Dec-88 21:56:53, Edit by Chiles.
-  Made the prompt for a destination buffer offer a sticky-default,
-  "Source Compare Default Destination".
-
-/usr1/lisp/nhem/mh.lisp, 14-Dec-88 13:19:01, Edit by Chiles.
-  Updated modeline stuff to use MODELINE-FIELD.
-
-/usr1/lisp/nhem/main.lisp, 13-Dec-88 13:52:20, Edit by Chiles.
-  Modified MAKE-MODELINE-FIELD calls.
-
-/usr1/lisp/nhem/morecoms.lisp, 13-Dec-88 13:50:07, Edit by Chiles.
-  Updated DO-RECURSIVE-EDIT to use MODELINE-FIELD.
-
-/usr1/lisp/nhem/struct.lisp, 13-Dec-88 12:47:22, Edit by Chiles.
-  Renamed modeline-field-name to %name.  Defined setf'er.
-
-/usr1/lisp/nhem/window.lisp, 13-Dec-88 13:40:45, Edit by Chiles.
-  Modified modeline stuff to make names first class.  Renamed some modelien
-  field objects.  Wrote MODELINE-FIELD, MODELINE-FIELD-NAME, and a setf'er.
-
-/usr1/lisp/nhem/bit-screen.lisp, 13-Dec-88 11:41:32, Edit by Chiles.
-  Uncommented hook additions for WINDOW-BUFFER and BUFFER-NAME icon naming.
-
-/usr1/lisp/nhem/rompsite.lisp, 13-Dec-88 11:42:28, Edit by Chiles.
-  Updated window icon naming for X11.  Someone wanted it.
-
-/usr1/lisp/nhem/killcoms.lisp, 12-Dec-88 12:30:23, Edit by Chiles.
-  Made PUSH-BUFFER-MARK signal a Lisp error.
-
-/usr1/lisp/nhem/rompsite.lisp, 10-Dec-88 20:50:06, Edit by Chiles.
-  Added doc strings for TEXT-CHARACTER and PRINT-PRETTY-CHARACTER.
-
-/usr1/lisp/nhem/auto-save.lisp, 10-Dec-88 14:26:52, Edit by Chiles.
-  Added some documentation and removed some bogus "interface" claims as per
-  Rob's understanding of what "interface" means in a function's comments.
-
-/usr1/lisp/nhem/macros.lisp, 08-Dec-88 13:49:04, Edit by Chiles.
-  Modified doc string for EDITOR-ERROR.  It also now signals an error if the
-  editor-error condition goes unhandled.
-
-/usr1/lisp/nhem/interp.lisp, 08-Dec-88 13:37:02, Edit by Chiles.
-  Established editor-error condition handler around command invocation.
-  Editor-error's were being handled by the "internal:" error handler
-  established in ED since these conditions are a subtype of error.
-
-/usr1/lisp/nhem/filecoms.lisp, 06-Dec-88 14:29:26, Edit by Chiles.
-  Wrote DELETE-BUFFER-IF-POSSIBLE.  Added doc string for CHANGE-TO-BUFFER.
-
-/usr1/lisp/nhem/buffer.lisp, 06-Dec-88 13:51:58, Edit by Chiles.
-  Modified page title and doc string for DELETE-BUFFER.
-
-/usr1/lisp/nhem/mh.lisp, 06-Dec-88 13:45:19, Edit by Chiles.
-  Moved DELETE-MH-BUFFER and replaced calls with DELETE-BUFFER-IF-POSSIBLE.
-
-/usr1/lisp/nhem/xcoms.lisp, 30-Nov-88 17:36:43, Edit by Chiles.
-  Here it is -- "Stack Window".
-
-/usr1/lisp/nhem/filecoms.lisp, 30-Nov-88 17:36:19, Edit by Chiles.
-  Moved "Stack Window".
-
-/usr1/lisp/nhem/fill.lisp, 29-Nov-88 11:59:51, Edit by Chiles.
-  Changed occurrences of %MARK-PARAGRAPH to MARK-PARAGRAPH.
-
-/usr1/lisp/nhem/text.lisp, 29-Nov-88 11:58:01, Edit by Chiles.
-  Changed %MARK-PARAGRAPH to MARK-PARAGRAPH.
-
-/usr1/lisp/hemlock/mh.lisp, 28-Nov-88 16:21:44, Edit by DBM.
-  Modified CLEANUP-HEADERS-REFERENCE to set the message/draft-hdrs-mark to
-  nil.  This is necessary if someone deletes the headers buffer before the
-  message buffer.
-
-/usr1/lisp/nhem/macros.lisp, 27-Nov-88 15:59:21, Edit by Chiles.
-  Rewrote EDITOR-ERROR.  Created an editor-error condition with accesses
-  EDITOR-ERROR-FORMAT-STRING and EDITOR-ERROR-FORMAT-ARGUMENTS.
-
-/usr1/lisp/nhem/main.lisp, 26-Nov-88 14:56:25, Edit by Chiles.
-  Deleted bogus export of *current-package*.
-
-/usr1/lisp/nhem/text.lisp, 26-Nov-88 12:28:30, Edit by Chiles.
-  Replaced occurrence of %KILL-REGION with KILL-REGION.
-
-/usr1/lisp/nhem/lispmode.lisp, 26-Nov-88 12:27:12, Edit by Chiles.
-  Replaced occurrence of %KILL-REGION with KILL-REGION.
-
-/usr1/lisp/nhem/lispbuf.lisp, 26-Nov-88 12:26:07, Edit by Chiles.
-  Replaced occurrence of %KILL-REGION with KILL-REGION.
-
-/usr1/lisp/nhem/echocoms.lisp, 26-Nov-88 12:25:25, Edit by Chiles.
-  Replaced occurrence of %KILL-REGION with KILL-REGION.
-
-/usr1/lisp/nhem/morecoms.lisp, 25-Nov-88 20:55:18, Edit by Chiles.
-  Modified "Delete Previous Character Expanding Tabs" to call KILL-CHARACTERS.
-
-/usr1/lisp/nhem/command.lisp, 25-Nov-88 21:27:07, Edit by Chiles.
-  Modified "Delete Next Character" and "Delete Previous Character" to call
-  KILL-CHARACTERS.
-
-/usr1/lisp/nhem/killcoms.lisp, 25-Nov-88 21:58:39, Edit by Chiles.
-  Wrote KILL-CHARACTERS and modified KILL-REGION (used to be %KILL-REGION).
-
-/usr1/lisp/nhem/icom.lisp, 25-Nov-88 16:04:48, Edit by Chiles.
-  Removed italicize comments file option.  Changed package spec to string.
-
-/usr1/lisp/nhem/mh.lisp, 22-Nov-88 16:06:53, Edit by Chiles.
-  Made SHOW-PROMPTED-MESSAGE normalize message ID strings.
-
-/usr1/lisp/nhem/bit-screen.lisp, 21-Nov-88 16:22:30, Edit by Chiles.
-  DEFAULT-DELETE-WINDOW-HOOK-NEXT-MERGE now sets the next hunk trashed since we
-  are somehow getting exposure events out of order with configure
-  notifications.  We should be able to remove this when facilities fixes the
-  new software it just released.
-
-/usr1/lisp/nhem/lispeval.lisp, 18-Nov-88 13:54:01, Edit by Chiles.
-  Made CREATE-SLAVE correctly get the name of the slave that just connected.
-
-/usr1/lisp/nhem/rompsite.lisp, 18-Nov-88 13:52:21, Edit by Chiles.
-  Made EDITOR_CONNECT-HANDLER set the name of the editor that just connected.
-
-/usr1/lisp/nhem/hunk-draw.lisp, 17-Nov-88 09:08:04, Edit by Chiles.
-  Made HUNK-REPLACE-LINE-ON-PIXMAP set gcontext :exposures nil.  Fixed the
-  macro it uses to no longer require binding gcontext each time around the
-  loop.
-
-/usr1/lisp/nhem/mh.lisp, 15-Nov-88 21:25:50, Edit by Chiles.
-  Added page of code for message buffer modeline fields.  Wrote
-  MARK-TO-NOTE-REPLIED-MSG.  Created "Default Message Modeline Fields".
-  Modified DELETE-MESSAGE and UNDELETE-MESSAGE.  Modified MAYBE-MAKE-MH-BUFFER.
-  Modified "Deliver Message" and wrote DELIVER-DRAFT-BUFFER-MESSAGE.
-
-/usr1/lisp/nhem/struct.lisp, 16-Nov-88 13:25:17, Edit by Chiles.
-  Export MODELINE-FIELD-NAME instead ML-FIELD-NAME.
-
-/usr1/lisp/nhem/rompsite.lisp, 16-Nov-88 13:32:48, Edit by Chiles.
-  Wrote EDITOR-DESCRIBE-FUNCTION.
-
-/usr1/lisp/nhem/lispbuf.lisp, 16-Nov-88 13:39:41, Edit by Chiles.
-  Wrote FUNCTION-TO-DESCRIBE and modified "Editor Describe Function Call".
-
-/usr1/lisp/nhem/lispeval.lisp, 16-Nov-88 13:50:14, Edit by Chiles.
-  Made DESCRIBE-FUNCTION-CALL-AUX use EDITOR-DESCRIBE-FUNCTION and
-  FUNCTION-TO-DESCRIBE.
-
-/usr1/lisp/nhem/mh.lisp, 15-Nov-88 20:46:02, Edit by Chiles.
-  Added message buffer modeline stuff.  Modified MAYBE-MAKE-MH-BUFFER for the
-  creation of the message buffer.  Modified DELETE-MESSAGE
-
-  Maybe D shouldn't be fixed width?
-
-/usr1/lisp/nhem/window.lisp, 15-Nov-88 13:34:41, Edit by Chiles.
-  Modified %SET-MODELINE-FIELD-WIDTH to not allow zero width fields.  Modified
-  MAKE-MODELINE-FIELD to check constraints too.
-
-  Fixed a bug in the :buffer-name modeline-field.
-
-
-/usr1/lisp/nhem/rompsite.lisp, 15-Nov-88 12:30:32, Edit by Chiles.
-  Replaced "nmmonitor" with "nm_active".
-
-/usr1/lisp/nhem/display.lisp, 15-Nov-88 12:40:25, Edit by Chiles.
-  Fixed REDISPLAY-WINDOWS-FOR-MARK to force output and so on.
-
-/usr1/lisp/hemlock/buffer.lisp, 14-Nov-88 15:14:34, Edit by DBM.
-  Made SETUP-INITIAL-BUFFER supply :modeline-fields nil.  This gets set
-  when the editor fires up.
-
-/usr1/lisp/nhem/tty-display.lisp, 10-Nov-88 16:23:04, Edit by Chiles.
-  Modified occurrences of WINDOW-MODELINE-STRING to be WINDOW-MODELINE-BUFFER.
-  Made dumb redisplay method set the window's dis-line flags to unaltered.
-
-/usr1/lisp/nhem/bit-display.lisp, 10-Nov-88 16:20:40, Edit by Chiles.
-  Modified occurrences of WINDOW-MODELINE-STRING to be WINDOW-MODELINE-BUFFER.
-
-/usr1/lisp/nhem/main.lisp, 10-Nov-88 16:07:07, Edit by Chiles.
-  Added "Default Status Line Fields" along with DEFVAR's and PROCLAIM's for
-  recursive edit and completion mode fields.
-
-  Modified "Default Modeline Fields".
-
-/usr1/lisp/nhem/bit-screen.lisp, 10-Nov-88 13:11:49, Edit by Chiles.
-  Modified BITMAP-MAKE-WINDOW to take modelinep.  Modified
-  DEFAULT-CREATE-INITIAL-WINDOWS-ECHO to supply :modelinep t to MAKE-WINDOW.
-  Modified SET-HUNK-SIZE to determine if the window displays modelines by
-  checking WINDOW-MODELINE-BUFFER.
-
-/usr1/lisp/nhem/screen.lisp, 10-Nov-88 13:02:34, Edit by Chiles.
-  MAKE-WINDOW now takes a :modelinep argument.
-
-  Added sets for echo and main BUFFER-MODELINE-FIELDS.
-
-/usr1/lisp/nhem/mh.lisp, 09-Nov-88 11:43:45, Edit by Chiles.
-  Modified a few MAKE-BUFFER calls.  The modeline fields for mail buffer should
-  be redesigned when this stuff goes into the core.
-
-/usr1/lisp/nhem/lispeval.lisp, 09-Nov-88 11:38:19, Edit by Chiles.
-  Modified MAKE-BUFFER call.  Made "Set Buffer Package" do over buffer's
-  windows calling UPDATE-MODELINE-FIELD on :package.
-
-/usr1/lisp/nhem/echo.lisp, 09-Nov-88 11:31:34, Edit by Chiles.
-  Modified MAKE-BUFFER call.
-
-/usr1/lisp/nhem/tty-screen.lisp, 09-Nov-88 11:02:14, Edit by Chiles.
-  Made main-lines be one less for status line.  Made echo :text-position be one
-  less for status line.  Modified calls to SETUP-MODELINE-IMAGE.
-
-  Made TTY-MAKE-WINDOW refer to modelinep argument and modified its
-  SETUP-MODELINE-IMAGE call.
-
-/usr1/lisp/nhem/struct.lisp, 08-Nov-88 21:52:14, Edit by Chiles.
-  Added modeline-fields slot to buffer structure.
-
-  Deleted window structure slots: main-pane, text-pane, modeline-pane,
-  font-map, modeline-line, and modeline-width.  Added modeline-buffer and
-  modeline-buffer-len slots.
-
-  Added DEFSETF for BUFFER-MODELINE-FIELDS.
-
-  Added modeline-field and modeline-field-info structures.
-
-
-/usr1/lisp/nhem/buffer.lisp, 05-Nov-88 17:30:52, Edit by Chiles.
-  Added page titles.
-
-  Modified MAKE-BUFFER to initialize the %modeline-fields slot with a list of
-  ml-field-info objects.  Now it takes keyword arguments.  Modified call in
-  SETUP-INITIAL-BUFFER.
-
-  Wrote BUFFER-MODELINE-FIELDS, %SET-BUFFER-MODELINE-FIELDS, and
-  SUB-SET-BUFFER-MODELINE-FIELDS, BUFFER-MODELINE-FIELD-P.
-
-/usr1/lisp/nhem/bit-display.lisp, 27-Oct-88 21:09:46, Edit by Chiles.
-  Removed calls to UPDATE-MODELINE-IMAGE.
-
-/usr1/lisp/nhem/winimage.lisp, 27-Oct-88 20:51:21, Edit by Chiles.
-  Deleted UPDATE-MODELINE-IMAGE.
-
-/usr1/lisp/nhem/display.lisp, 30-Oct-88 19:47:04, Edit by Chiles.
-  Stopped REDISPLAY-WINDOW and REDISPLAY-WINDOW-ALL from forcing output and
-  calling the after methods.  This was causing INTERNAL-REDISPLAY to queue
-  input events for the editor that weren't seen before going into SYSTEM:SERVER
-  with a non-zero timeout.  This means SYSTEM:SERVER had to timeout, or another
-  character had to be entered, before the unseen one was revealed.
-
-/usr1/lisp/nhem/display.lisp, 27-Oct-88 15:10:58, Edit by Chiles.
-  Wrote INTERNAL-REDISPLAY and made REDISPLAY-LOOP optionally splice in calling
-  the device's after-redisplay function.
-
-/usr1/lisp/nhem/rompsite.lisp, 27-Oct-88 15:12:02, Edit by Chiles.
-  Replaced calls to REDISPLAY with INTERNAL-REDISPLAY.
-
-/usr1/lisp/nhem/morecoms.lisp, 26-Oct-88 15:50:43, Edit by Chiles.
-  Wrote "Goto Absolute Line".
-
-/usr1/lisp/nhem/hunk-draw.lisp, 26-Oct-88 15:32:22, Edit by Chiles.
-  Made HUNK-REPLACE-LINE dispatch on *hack-hunk-replace-line*.
-
-/usr1/lisp/nhem/display.lisp, 26-Oct-88 15:15:47, Edit by Chiles.
-  Added an after-redisplay slot to the basic display structure.  Made
-  REDISPLAY-LOOP, REDISPLAY-WINDOWS-FROM-MARK, REDISPLAY-WINDOW, and
-  REDISPLAY-WINDOW-ALL use this.
-
-/usr1/lisp/nhem/bit-screen.lisp, 26-Oct-88 15:03:05, Edit by Chiles.
-  MAKE-DEFAULT-BITMAP-DEVICE now sets the :after-redisplay slot.
-  REVERSE-VIDEO-HOOK-FUN now sets *hack-hunk-replace-line*.
-
-/usr1/lisp/hemlock/macros.lisp, 25-Oct-88 15:14:49, Edit by DBM.
-  Fixed the restart case in lisp-error-error-handler.
-
-/usr1/lisp/nhem/hunk-draw.lisp, 23-Oct-88 18:12:12, Edit by Chiles.
-  Fixed pixmap creation to be root depth instead of 1, so color stuff works.
-  When inverting areas, now use boole-xor instead of boole-c2 and a foreground
-  that is the xor of the foreground and background.  This makes color inversion
-  work.  If A is the foreground, and B is the background, then A xor B is AxB.
-  This value has the property that A xor AxB is B, and B xor AxB is A, thus
-  inverting in color the region.
-
-/usr1/lisp/nhem/bit-screen.lisp, 23-Oct-88 16:26:43, Edit by Chiles.
-  Modified BITMAP-MAKE-WINDOW to make the gcontext after we definitely have a
-  window.  Made sure that where I destroy an xwindow, that I free the gcontext
-  for that hunk.  Added a DEFVAR for *foreground-background-xor*, which is
-  initialized in INIT-BITMAP-SCREEN-MANAGER.  This function also has corrected
-  calls to GET-HEMLOCK-GREY-PIXMAP and GET-HEMLOCK-CURSOR.  Made
-  REVERSE-VIDEO-HOOK-FUN deal with rthunk correctly for new strategy, and it
-  calls GET-HEMLOCK-CURSOR now.
-
-/usr1/lisp/nhem/rompsite.lisp, 23-Oct-88 14:17:19, Edit by Chiles.
-  Modified FLASH-WINDOW-BORDER and FLASH-WINDOW to use an xor function and a
-  pixel value that is the xor of foreground and background.  This allows
-  inversion in a color window, that is for any pixel values including 1 and 0.
-  Changed the cursor fetching code to no longer save the pixmaps hot spots.
-  These are now generated each time you fetch a new Hemlock cursor, and this
-  code now uses distinct graphics contexts for each pixmap (cursor and mask) to
-  accomodate the color monitor.  This also seemed more correct in general.  The
-  grey pixmap generation has been changed to not use XLIB:PUT-RAW-IMAGE since
-  this required Hemlock to know every server/monitor's preferences for raw
-  data.  Fixed pixmap creation to be the root depth instead of 1 when not
-  making cursors.
-
-/usr1/lisp/nhem/hunk-draw.lisp, 22-Oct-88 20:06:02, Edit by Chiles.
-  Made HUNK-REPLACE-LINE-PIXMAP call XLIB:CREATE-PIXMAP with a depth of
-  XLIB:SCREEN-ROOT-DEPTH instead of 1.
-
-/usr1/lisp/nhem/buffer.lisp, 22-Oct-88 16:09:32, Edit by Chiles.
-  Modified %SET-BUFFER-NAME to do the right thing if the name supplied was
-  already in use but for the buffer being affected.  This allows the buffer to
-  be renamed to the same name, but with different casing for display effect.
-
-/usr1/lisp/nhem/filecoms.lisp, 22-Oct-88 16:37:45, Edit by Chiles.
-  Modified "Rename Buffer" to allow users to rename a buffer to the same
-  name,but with different casing for visual effect.
-
-/usr1/lisp/nhem/lispeval.lisp, 21-Oct-88 18:40:11, Edit by Chiles.
-  Made CREATE-SLAVE not mess with the value of "Current Eval Server".  It now
-  uses a special *create-slave-wait* that is set by the connect handler.
-
-/usr1/lisp/nhem/rompsite.lisp, 21-Oct-88 18:08:42, Edit by Chiles.
-  Made EDITOR_CONNECT-HANDLER only affect the :global value of "Current Eval
-  Server".  It also not sets ed::*create-slave-wait* to nil.
-
-/usr1/lisp/nhem/window.lisp, 21-Oct-88 02:26:40, Edit by Chiles.
-  Modified %SET-WINDOW-BUFFER to move the window's display start and ends to
-  the new display-start slot buffers have.
-
-/usr1/lisp/nhem/buffer.lisp, 21-Oct-88 02:25:07, Edit by Chiles.
-  Added initialization for :display-start slot of new buffer.
-
-/usr1/lisp/nhem/struct.lisp, 21-Oct-88 02:23:11, Edit by Chiles.
-  Added display-start slot to the buffer structure.
-
-/usr1/lisp/nhem/lispeval.lisp, 20-Oct-88 22:13:53, Edit by Chiles.
-  MAYBE-QUEUE-OPERATION-REQUEST now informs the user whether the operation is
-  queued to be sent or being sent.
-
-/usr1/lisp/nhem/killcoms.lisp, 17-Oct-88 13:34:26, Edit by Chiles.
-  Made "Set/Pop Mark" only MESSAGE when interactive.
-
-/usr1/lisp/nhem/filecoms.lisp, 17-Oct-88 12:16:08, Edit by Chiles.
-  Installed new "Save All Files" that tells how many files it saved.
-
-/usr1/lisp/nhem/mh.lisp, 14-Oct-88 13:56:45, Edit by Chiles.
-  Made EXPUNGE-MESSAGES-FIX-UNSEEN-HEADERS always set the name back in case the
-  user used "Pick Headers".  Broke off part of it to form
-  MAYBE-GET-NEW-MAIL-MSG-HDRS which is now also called in PICK-MESSAGE-HEADERS.
-  Made "Incorporate and Read New Mail" set the unseen mail buffer's name when
-  it already existed just in case someone used "Pick Headers".
-  PICK-MESSAGE-HEADERS now checks for the new mail buffer, and when the pick
-  expression is empty, it uses MAYBE-GET-NEW-MAIL-MSG-HDRS.
-
-/usr1/lisp/nhem/mh.lisp, 13-Oct-88 11:31:13, Edit by Chiles.
-  PROMPT-FOR-FOLDER was not giving must-exist to PROMPT-FOR-KEYWORD.  It was
-  always passing nil.
-
-/usr1/lisp/nhem/bit-screen.lisp, 12-Oct-88 15:09:10, Edit by Chiles.
-  Reinstalled the better window deletion next merger code.  Commented out the
-  hack in case we run into another asinine window manager.
-
-/usr1/lisp/nhem/lispbuf.lisp, 10-Oct-88 14:03:41, Edit by Chiles.
-  Modified commands that redirected *standard-output* for compiler warnings to
-  now redirect *error-output* to adhere to new compiler
-
-/usr1/lisp/nhem/lispbuf.lisp, 09-Oct-88 16:54:18, Edit by Chiles.
-  Made "Package" file option not choke when it couldn't stringify the thing.
-
-/usr1/lisp/nhem/bindings.lisp, 05-Oct-88 20:24:21, Edit by Chiles.
-  Eliminated bogus BIND-KEY in "Eval" mode for "Confirm Eval Input".
-
-/usr1/lisp/nhem/morecoms.lisp, 04-Oct-88 20:13:34, Edit by Chiles.
-  Made "Uppercase Region" and "Lowercase Region" insist on the region being
-  active.  Made TWIDDLE-REGION, which implements above, take a region instead
-  of two marks.
-
-/usr1/lisp/nhem/htext4.lisp, 04-Oct-88 19:57:55, Edit by Chiles.
-  Modified FILTER-REGION doc string.  Added page titles.
-
-/usr1/lisp/hemlock/bit-display.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/keytrandefs.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/tty-screen.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/bit-screen.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/font.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/window.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/bit-stream.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/hunk-draw.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/main.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/xcoms.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/charmacs.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/rompsite.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/keytran.lisp, 03-October-88, Edit by Chiles.
-/usr1/lisp/hemlock/screen.lisp, 03-October-88, Edit by Chiles.
-  Modified to support X11 using CLX.
-
-/usr1/lisp/nhem/scribe.lisp, 30-Sep-88 14:45:41, Edit by Chiles.
-  Broke up long FORMAT string into several lines of code.  Fixed bug in
-  DIRECTIVE-HELP.
-
-/usr1/lisp/nhem/filecoms.lisp, 27-Sep-88 11:48:10, Edit by Chiles.
-  Added a "Make Buffer Hook" to add all new buffers to the history.  Added some
-  doc and a page title.
-
-/usr1/lisp/nhem/bindings.lisp, 22-Sep-88 22:46:30, Edit by Chiles.
-  Added binding for "Insert Scribe Directive".  Deleted lots of other "Scribe"
-  bindings.
-
-/usr1/lisp/nhem/scribe.lisp, 21-Sep-88 22:48:46, Edit by Chiles.
-  Added new code to dispatch on a character and either insert a Scribe command
-  or environment, instead of having 30 similar commands.  Deleted the following
-  commands entirely:
-     "Scribe Appendix"
-     "Scribe AppendixSection"
-     "Scribe Chapter"
-     "Scribe Heading"
-     "Scribe MajorHeading"
-     "Scribe Paragraph"
-     "Scribe PrefaceSection"
-     "Scribe Section"
-     "Scribe SubHeading"
-     "Scribe SubSection"
-     "Scribe UnNumbered"
-     "Scribe Verbatim"
-     "Scribe Verse"
-  Introduced "List Scribe Paragraph Delimiters".
-  Cleaned up code.
-  Got the stuff working.
-
-/usr1/lisp/nhem/lispmode.lisp, 15-Sep-88 14:31:53, Edit by Chiles.
-  Modified LISP-INDENT-REGION to do it undoably.  It takes an optional argument
-  for the undo text.  "Indent Form" supplies its name when calling this.
-  Documented INDENT-FOR-LISP.  Modified some page boundaries.
-
-/usr1/lisp/nhem/bindings.lisp, 07-Sep-88 16:44:35, Edit by Chiles.
-  Changed "Eval Input" bindings to "Confirm Eval Input".
-
-/usr1/lisp/nhem/lispbuf.lisp, 07-Sep-88 16:43:34, Edit by Chiles.
-  Renamed "Eval Input" to "Confirm Eval Input".
-
-/usr1/lisp/nhem/mh.lisp, 07-Sep-88 13:08:04, Edit by Chiles.
-  Modified DELETE-AND-EXPUNGE-TEMP-DRAFTS one more time.  Now it makes use of
-  MH's :errorp arguement to squelch errors.
-
-/usr1/lisp/hemlock/lispeval.lisp, 30-Aug-88 11:32:53, Edit by DBM.
-  Changed references to slave-utility-name to slave-utility and
-  slave-arguments to slave-utility-switches.
-
-/usr1/lisp/nhem/ts.lisp, 19-Aug-88 21:47:12, Edit by Chiles.
-  Fixed "Unwedge Interactive Input String" according to mail I sent.
-
-/usr1/lisp/nhem/bindings.lisp, 15-Aug-88 12:30:05, Edit by Chiles.
-  Added binding for "Scribe Buffer File".
-
-/usr1/lisp/nhem/lispeval.lisp, 15-Aug-88 11:11:10, Edit by Chiles.
-  Renamed "Slave Utility Name" to "Slave Utility" and
-          "Slave Arguments" to "Slave Utility Switches".
-
-/usr1/lisp/nhem/unixcoms.lisp, 15-Aug-88 11:09:48, Edit by Chiles.
-  Renamed "Print Utility Options" to "Print Utility Switches".  Added Scribe
-  stuff.
-
-/usr1/lisp/nhem/mh.lisp, 09-Aug-88 23:16:09, Edit by Chiles.
-  Made "Expunge Messages" and "Quit Headers" doc strings mention "Temporary
-  Draft Folder".  Modified DELETE-AND-EXPUNGE-TEMPORARY-DRAFTS to do a
-  directory to realize if there were really any messages to blow away.
-
-/usr1/lisp/nhem/doccoms.lisp, 09-Aug-88 22:57:13, Edit by Chiles.
-  Modified "Apropos" to use CURRENT-VARIABLE-TABLES, and cleaned up this moby
-  growing command.
-
-/usr1/lisp/nhem/echo.lisp, 09-Aug-88 22:26:46, Edit by Chiles.
-  Wrote CURRENT-VARIABLE-TABLES, and exported it.  Modified PROMPT-FOR-VARIABLE
-  to use it.
-
-/usr1/lisp/nhem/mh.lisp, 07-Aug-88 04:03:13, Edit by Chiles.
-  "Remail Message".
-
-/usr1/lisp/nhem/filecoms.lisp, 04-Aug-88 22:20:23, Edit by Chiles.
-  Made "Insert File" and "Insert Buffer" push a buffer mark before inserting.
-
-/usr1/lisp/nhem/lispbuf.lisp, 04-Aug-88 21:31:10, Edit by Chiles.
-  Fixed default binding and doc string of "Unwedge Interactive Input Confirm".
-
-/usr1/lisp/nhem/mh.lisp, 30-Jul-88 22:09:59, Edit by Chiles.
-  Fixed a bug with "Reply to Message Prefix Action".  Made "Reply to M in O
-  Window", when invoked in the headers buffer, put the message in the "current"
-  window.
-
-/usr1/lisp/nhem/highlight.lisp, 26-Jul-88 17:26:32, Edit by Chiles.
-  Did away with HIGHLIGHT-ACTIVE-REGION-P.  Replaced calls with
-  REGION-ACTIVE-P.  Made MAYBE-HIGHLIGHT-OPEN-PARENS check the value of
-  "Highlight Active Region" and REGION-ACTIVE-P instead of just the latter.
-
-/usr1/lisp/nhem/killcoms.lisp, 26-Jul-88 17:21:36, Edit by Chiles.
-  Made REGION-ACTIVE-P check for the last command type being a member of
-  *ephemerally-active-command-types*.  Modified "Kill Region" and "Save Region"
-  to call CURRENT-REGION normally.
-
-/usr1/lisp/nhem/lispbuf.lisp, 19-Jul-88 22:35:22, Edit by Chiles.
-  Fixed bug in "Eval Input".
-
-/usr1/lisp/hemlock/linimage.lisp, 27-Jul-88 11:09:17, Edit by DBM.
-/usr1/lisp/hemlock/line.lisp, 27-Jul-88 10:56:33, Edit by DBM.
-  Removed some old Perq cruft.  
-
-/usr1/lisp/nhem/lispbuf.lisp, 19-Jul-88 22:35:22, Edit by Chiles.
-  Fixed bug in "Eval Input".
-
-/usr1/lisp/nhem/filecoms.lisp, 11-Jul-88 12:55:48, Edit by Chiles.
-  Fixed bug in "Visit File" telling the user that the file is already in some
-  buffer.
-
-/usr1/lisp/nhem/doccoms.lisp, 06-Jul-88 23:14:13, Edit by Chiles.
-  Added "Describe Pointer" command and frobbed "Help".
-
-/usr1/lisp/nhem/bindings.lisp, 05-Jul-88 16:34:31, Edit by Chiles.
-  Added bindings for new commands in Commands.Lisp.
-
-  Added initial value for *describe-pointer-keylist*.
-
-/usr1/lisp/nhem/command.lisp, 05-Jul-88 16:36:40, Edit by Chiles.
-  Added "Mark to Beginning of Buffer" "Mark to End of Buffer".
-
-/usr1/lisp/nhem/ts.lisp, 04-Jul-88 15:46:46, Edit by Chiles.
-  Broke "Process Control" up into separate commands.
-
-/usr1/lisp/nhem/filecoms.lisp, 01-Jul-88 23:40:00, Edit by Chiles.
-  made "Visit File" MESSAGE when another buffer also contains the pathname.
-
-/usr1/lisp/nhem/mh.lisp, 29-Jun-88 23:33:40, Edit by Chiles.
-  Wrote "Delete Message and Down Line".
-
-  Made "Deliver Message" say "Delivering draft ...".
-
-  Deleted GET-MESSAGE-HEADERS-SEQ.  Made SET-MESSAGE-HEADERS-IDS optionally
-  return an MH sequence.  These were identical but for this difference.
-
-  Made "Refile Message" and "Delete Message" maintain consistency.
-
-  Made SHOW-MESSAGE-OFFSET-MARK return nil when it couldn't place the mark
-  instead of signalling an error.  Wrote SHOW-MESSAGE-OFFSET-MSG-BUG, and
-  renamed SHOW-MESSAGE-OFFSET-HEADERS to SHOW-MESSAGE-OFFSET-HDRS-BUF.  In a
-  message buffer, we move back to the headers buffer and delete the message
-  buffer.
-
-  Added "Reply to Message Prefix Action" which controls prefix argument actions
-  in "Reply to Message".
-  
-  Removed "Automatic Current Message" feature.
-  Removed DEFHVAR just after "Headers Information".
-  Removed when...show from:
-     "Message Headers"
-     "Pick Headers"
-     INSERT-NEW-MAIL-MESSAGE-HEADERS
-  Modified REVAMP-HEADERS-BUFFER and CLEANUP-HEADERS-BUFFER to always take care
-  of the main message buffer.
-
-
-/usr1/lisp/nhem/bindings.lisp, 27-Jun-88 13:45:22, Edit by Chiles.
-  Added bindings for macroexpansion and reenter input stuff.
-
-  Added new bindings for "Process Control" break up.
-
-
-/usr1/lisp/nhem/lispbuf.lisp, 27-Jun-88 13:34:56, Edit by Chiles.
-  Added "Editor Macroexpand Expression".
-
-  Added "Reenter Interactive Input".
-
-
-/usr1/lisp/nhem/lispeval.lisp, 27-Jun-88 13:33:11, Edit by Chiles.
-  Added "Macroexpand Expression".
-
-/usr1/lisp/nhem/bindings.lisp, 26-Jun-88 20:02:02, Edit by Chiles.
-  Uncommented binding for "Delete Message and Down Line".
-
-/usr1/lisp/nhem/bindings.lisp, 24-Jun-88 16:11:37, Edit by Chiles.
-  Fixed C-c bindings messed up by making C-c a hyper prefix.  Made all c-, m-,
-  and s- bindings be spelled out for consistency.
-
-/usr1/lisp/nhem/mh.lisp, 16-Jun-88 15:02:40, Edit by Chiles.
-  Made "Delete Draft and Buffer" cleanup after split window drafts.
-
-/usr1/lisp/nhem/spellcoms.lisp, 16-Jun-88 12:54:08, Edit by Chiles.
-  Made corrections based on previous corrections undoable and changed message
-  to say "corrected" instead of "replaced".
-
-/usr1/lisp/nhem/mh.lisp, 15-Jun-88 20:04:23, Edit by Chiles.
-  Added MESSAGE's to INCORPORATE-NEW-MAIL.
-
-/usr1/lisp/nhem/lispeval.lisp, 13-Jun-88 19:28:48, Edit by Chiles.
-  Made #\c for "Edit Compiler Errors" center the window around the current
-  error.
-
-/usr1/lisp/nhem/mh.lisp, 10-Jun-88 16:16:58, Edit by Chiles.
-  Fixed a bug in "Headers Refile Message".  It wasn't supplying
-  *refile-default-destination* to PROMPT-FOR-FOLDER when in a message buffer.
-
-/usr1/lisp/nhem/mh.lisp, 10-Jun-88 13:21:55, Edit by Chiles.
-  Made CLEANUP-HEADERS-REFERENCE, when the info is TYPEP 'draft-info, set the
-  replied-to folder and msg to nil.
-
-/usr1/lisp/nhem/lispbuf.lisp, 09-Jun-88 20:17:30, Edit by Chiles.
-  Fixed bug in warning message for "List Compile Group".
-
-/usr1/ch/lisp/files.lisp, 06-Jun-88 23:44:01, Edit by Christopher Hoover.
-   Fixed a bug which caused WRITE-FILE to sometimes lose when given an
-   "access" value.
-
-/usr1/ch/lisp/unixcoms.lisp, 03-Jun-88 15:54:46, Edit by Christopher Hoover.
-  Wrote the command "Unix Filter Region".
-
-/usr1/ch/lisp/auto-save.lisp, 16-May-88 02:31:07, Edit by Christopher Hoover.
-  Fixed the code so that "Auto Save Checkpoint Frequency" is always
-  truncated to an integer to keep (very) bad things from happening.
-
-/usr1/lisp/nhem/spellcoms.lisp, 01-Jun-88 10:46:45, Edit by Chiles.
-  Made "Check Word Spelling" show close words regardless of "Correct Unique
-  Spelling Immediately".
-
-/usr1/lisp/nhem/bindings.lisp, 31-May-88 15:25:23, Edit by Chiles.
-  Bound all alpha chars to "Illegal" in "Headers" and "Message" modes.
-
-/usr1/lisp/nhem/mh.lisp, 25-May-88 11:42:13, Edit by Chiles.
-  Created "Temporary Draft Folder" variable, wrote
-  DELETE-AND-EXPUNGE-TEMP-DRAFTS, and modified "Quit Headers"and "Expunge
-  Messages".
-
-/usr1/lisp/nhem/edit-defs.lisp, 25-May-88 11:09:51, Edit by Chiles.
-  Made "Edit Definition" and "Goto Definition" (which has a new name) use
-  editor Lisp if there is no currently valid slave.
-
-/usr1/lisp/nhem/lispeval.lisp, 25-May-88 02:39:37, Edit by Chiles.
-  Made "Describe Function Call" and "Describe Symbol" use the editor Lisp when
-  the current eval server doesn't exist is invalid.
-
-/usr1/lisp/nhem/mh.lisp, 24-May-88 14:57:36, Edit by Chiles.
-  Changed PROMPT-FOR-MESSAGE to take keyword args adding prompt.  Changed all
-  the call sites.  Made "Message Headers", "Delete Message", "Undelete
-  Message", and "Refile Message" supply particular prompt messages.
-
-  Changed "Quit Headers Confirm" to "Expunge Messages Confirm".
-
-/usr1/lisp/nhem/mh.lisp, 19-May-88 12:14:27, Edit by Chiles.
-  Wrote BREAKUP-MESSAGE-SPEC and added the variable, "Unseen Headers Message
-  Spec".  This affected "Incorporate and Show New Mail" and "Expunge Message".
-
-/usr1/lisp/nhem/mh.lisp, 15-May-88 15:40:24, Edit by Chiles.
-  Made MH-PROFILE-COMPONENT take an optional error-on-open argument, so when
-  this is used for sequence files, and the sequence file is not there or
-  readable, then the command can continue ... assuming the sequence file
-  operation is insignificant if the file cannot be opened.  Made
-  MH-SEQUENCE-LIST use this argument.
-
-  Made MARK-ONE-MESSAGE not write the file on :delete unless the message was
-  really in the sequence before deletion.
-
-/usr1/lisp/nhem/lispmode.lisp, 12-May-88 15:11:15, Edit by Chiles.
-  Added mailer and xlib DEFINDENT forms.
-
-/usr1/lisp/nhem/mh.lisp, 12-May-88 10:45:02, Edit by Chiles.
-  Fixed documentation for "Reply to Message in Other Window".
-
-/usr1/lisp/nhem/mh.lisp, 11-May-88 14:03:29, Edit by Chiles.
-  Wrote "Edit Message Buffer".  Made a bunch of (subseq folder 1) calls be
-  calls to STRIP-FOLDER-NAME for consistency.
-
-/usr1/lisp/nhem/mh.lisp, 11-May-88 10:33:23, Edit by Chiles.
-  Made "Insert Message Region" know about split-window drafts.
-
-/usr1/lisp/hemlock/edit-defs.lisp, 10-May-88 17:11:28, Edit by Chiles.
-  Made "Edit Command Definition" on an argument prompt for a key instead of
-  prompting for a command name.
-
-/usr1/lisp/nhem/mh.lisp, 10-May-88 12:37:40, Edit by Chiles.
-  Made DELETE-HEADERS-LINE-REFERENCES delete message buffers if they are
-  not associated with a draft buffer.  If they are, then it cleans up the
-  reference.
-
-  Wrote "Reply to Message in Other Window" which splits the current window
-  when replying to a message.  Made "Insert Message Buffer" try to delete a
-  window if the draft is a split-window draft.  Made "Deliver Message"
-  delete a window if there are a couple lieing around and the draft is a
-  split-window draft.
-
-/usr1/lisp/nhem/command.lisp, 10-May-88 11:19:21, Edit by Chiles.
-  Added doc strings to "Exit Hemlock" and "Pause Hemlock".
-
-/usr1/lisp/nhem/files.lisp, 09-May-88 16:57:39, Edit by Chiles.
-  Made WRITE-FILE take keywords keep-backup (previously optional) and access.
-  When access is supplied non-nil, it is used as Unix modes with
-  MACH:UNIX-CHMOD.
-
-/usr1/lisp/nhem/doccoms.lisp, 10-May-88 08:27:39, Edit by Chiles.
-  Made "Describe Command" show bindings.  Fixed bindings printing.
-
-/usr1/lisp/nhem/auto-save.lisp, 09-May-88 17:28:05, Edit by Chiles.
-  Made WRITE-CHECKPOINT-FILE call WRITE-FILE the new correct way supplying
-  :access #o600 for read/write by owner only.
-
-/usr1/lisp/nhem/spellcoms.lisp, 09-May-88 10:09:13, Edit by Chiles.
-  Made "Set Buffer Spelling Dictionary" hash on the namestring of the true name
-  instead of what was given.  Made it also add the write hook instead of the
-  "Dictionary" file option.  Stopped modifying "Write File Hook" buffer
-  specifically, using ADD-HOOK now.  Made "Dictionary" file option LOUD-MESSAGE
-  if it couldn't find the dictionary file, blowing the whole thing off.
-  Changed "Message Buffer Insertion Prefix" to four spaces.
-
-/usr1/lisp/nhem/mh.lisp, 09-May-88 09:34:43, Edit by Chiles.
-  Fixed a bug in SETUP-HEADERS-MESSAGE-DRAFT that associated the draft with the
-  headers buffer which caused CLEANUP-DRAFT-BUFFER to try to delete a nil
-  headers mark into the headers buffer.
-
-/usr1/lisp/nhem/mh.lisp, 06-May-88 10:06:23, Edit by Chiles.
-  Renamed SETUP-MSG-BUF-REPLY-DRAFT to SETUP-MESSAGE-BUFFER-DRAFT, modifying it
-  to take a message buffer, message info, and a type.  The type is one of
-  :reply, :compose, or :forward.  It does the right thing.
-
-/usr1/lisp/nhem/tty-display.lisp, 05-May-88 17:26:08, Edit by Chiles.
-  Rewrote CM-OUTPUT-COORDINATE to not use TRUNCATE on floats or LOG.  Changed
-  it from a macro to a function too.  Now it builds the characters in a buffer,
-  using DEVICE-WRITE-STRING to send the chars out.
-
-/usr1/lisp/nhem/mh.lisp, 03-May-88 14:41:30, Edit by Chiles.
-  New Hemlock file.  Ta dah!
-
-/usr1/lisp/nhem/bindings.lisp, 03-May-88 14:55:46, Edit by Chiles.
-  Added new mailer bindings.
-
-/usr1/lisp/nhem/display.lisp, 18-Apr-88 14:30:41, Edit by Chiles.
-  Added DEFVAR for *screen-image-trashed* which was lost due to old bitmap code
-  tossing.
-
-/usr1/lisp/nhem/window.lisp, 19-Apr-88 12:01:26, Edit by Chiles.
-  Inserted code from Owindow.Lisp (previously thrown away due to old bitmap
-  code tossing) that was still necessary for tty redisplay.
-
-/usr1/lisp/nhem/rompsite.lisp, 18-Apr-88 11:02:05, Edit by Chiles.
-  Made HEMLOCK-WINDOW test *hemlock-window-mngt* for being non-nil.
-
-  Removed OBITMAP-SHOW-MARK.
-
-  Removed loading old bitmap files from BUILD-HEMLOCK.
-
-/usr1/lisp/nhem/rompsite.lisp, 06-Apr-88 12:44:22, Edit by Chiles.
-  Made the editer server name default to "[<machine-name>:<user-name>]Editor".
-
-/usr1/lisp/nhem/display.lisp, 04-Apr-88 09:47:08, Edit by Chiles.
-  Removed some references to old bitmap redisplay in comments.
-
-/usr1/lisp/nhem/filecoms.lisp, 04-Apr-88 09:09:45, Edit by Chiles.
-  Changed the default of "Keep Backup Files" and the doc string.
-
-/usr1/lisp/hemlock/obit-display.lisp, 01-Apr-88 16:27:00, Edit by Chiles
-/usr1/lisp/hemlock/obit-screen.lisp, 01-Apr-88 16:27:00, Edit by Chiles
-/usr1/lisp/hemlock/ofont.lisp, 01-Apr-88 16:27:00, Edit by Chiles
-/usr1/lisp/hemlock/owindow.lisp, 01-Apr-88 16:27:00, Edit by Chiles
-/usr1/lisp/hemlock/pane-stream.lisp, 01-Apr-88 16:27:00, Edit by Chiles
-/usr1/lisp/hemlock/pane.lisp, 01-Apr-88 16:27:00, Edit by Chiles
-/usr1/lisp/hemlock/keyboard_codes.lisp, 01-Apr-88 16:27:00, Edit by Chiles
-  These files have been removed from the sources.
-
-/usr1/lisp/nhem/screen.lisp, 01-Apr-88 16:25:47, Edit by Chiles.
-  Made %INIT-SCREEN-MANAGER not regard CONSOLEP.
-
-/usr1/lisp/nhem/rompsite.lisp, 01-Apr-88 16:04:09, Edit by Chiles.
-  Rewrote (that is, mostly blew away a lot of code) GET-EDITOR-TTY-INPUT.  Blew
-  away TRANSLATE-CHAR definition.
-
-  Blew away all console character translation variables.
-
-  Cleaned out console specific code in SETUP-INPUT and RESET-INPUT.
-
-  Blew away use of *editor-console-input*.
-
-  Blew away CONSOLEP.
-
-
-/usr1/lisp/nhem/morecoms.lisp, 30-Mar-88 14:19:12, Edit by Chiles.
-  Removed unnecessary (null b) check in "List Buffers".
-
-/usr1/lisp/nhem/undo.lisp, 25-Mar-88 14:33:23, Edit by Chiles.
-  Massively documented this stuff.
-
-/usr0/ram/group.lisp, 21-Mar-88 13:58:49, Edit by Ram.
-  Changed Do-Active-Group to save and restore the Buffer-Point around the code
-  that hacks on the buffer.  This means that group commands no longer trash the
-  point (which usually left you at the beginning of the buffer).
-
-/usr1/ch/lisp/echocoms.lisp, 21-Mar-88 13:33:57, Edit by Christopher Hoover.
-  Frobbed "Ignore File Types" -- deleted unknowns and added a few common
-  binary formats.
-
-/usr1/ch/lisp/auto-save.lisp, 16-Mar-88 16:54:00, Edit by Christopher Hoover.
-  Made the call to write-region in Auto Save supply NIL as the optional
-  argument for keeping backup files so that the luser does not end up
-  with .CKP.BAK files.
-
-/usr1/ch/lisp/files.lisp, 16-Mar-88 15:59:18, Edit by Christopher Hoover.
-  Made write-region take an optional argument which tells it whether or
-  not to do ":if-exist :rename" or ":if-exist :rename-and-delete".
-  If the argument is not supplied, it looks at the hvar "Keep Backup
-  Files".
-
-/usr1/ch/lisp/filecoms.lisp, 16-Mar-88 15:20:00, Edit by Christopher Hoover.
-  Added the hvar "Keep Backup Files".  This variable controls whether
-  write region deletes .BAK files.
-
-/usr1/ch/lisp/filecoms.lisp, 14-Mar-88 22:14:47, Edit by Christopher Hoover.
-  Removed "c" and "h" from the file type hook which invokes Pascal mode
-  since Pascal mode is worse than Fundamental mode for editing C code.
-  Someday, there will be a real electric C mode.
-
-/usr1/lisp/nhem/rompsite.lisp, 15-Mar-88 21:00:11, Edit by Chiles.
-  Wrote RE-INIT-EDITOR-SERVER to be the port death handler instead of
-  INIT-EDITOR-SERVER.
-
-/usr1/lisp/nhem/morecoms.lisp, 15-Mar-88 16:25:44, Edit by Chiles.
-  Installed Naeem's mods to "Delete Previous Character Expanding Tabs" that
-  saves on the kill ring after some threshold.
-
-/usr1/lisp/nhem/command.lisp, 15-Mar-88 16:24:09, Edit by Chiles.
-  Installed Naeem's mods to "Delete Previous Character" and "Delete Next
-  Character" that saves on the kill ring after some threshold.
-
-/usr1/ch/lisp/echocoms.lisp, 14-Mar-88 21:50:47, Edit by Christopher Hoover
-  Deleted the hvar "Help Show Options" since it is not used anywhere.
-  Added a real doc string for the hvar "Beep on Ambiguity".
-
-  Fixed Complete Keyword for files to use the new whizzy complete-file.
-  Added the hvar "Ignore File Types" to control which file types to
-  ignore.
-
-/usr1/lisp/nhem/morecoms.lisp, 10-Mar-88 20:59:36, Edit by Chiles.
-  Installed "Defhvar" command.
-
-/usr1/lisp/nhem/filecoms.lisp, 10-Mar-88 15:48:57, Edit by Chiles.
-  Modified PROCESS-FILE-OPTIONS to invoke the file type hook when no major mode
-  had been seen, even though some mode option had been specified.  Modified the
-  "Mode" file option handler to return whether it had seen a major mode.
-
-/usr1/lisp/nhem/bit-screen.lisp, 08-Mar-88 14:57:10, Edit by Chiles.
-  Made REVERSE-VIDEO-HOOK-FUN make sure there is an X window for the random
-  typeout stream before trying to set its background.
-
-/usr1/lisp/nhem/fill.lisp, 06-Mar-88 21:28:51, Edit by Chiles.
-  Made %FILLING-SET-NEXT-LINE not call INDENT-NEW-COMMENT-LINE-COMMAND when
-  there is a fill prefix.
-
-/usr1/lisp/nhem/bit-display.lisp, 06-Mar-88 14:15:17, Edit by Chiles.
-  Fixed redisplay bug concerning excessive counting of lines to clear.
-  Otherwise case now stops counting cleared lines and packages off one clear
-  operations if we are currently counting.
-
-/usr1/lisp/nhem/font.lisp, 06-Mar-88 12:46:24, Edit by Chiles.
-  Made *default-font-family* have a default value so MAKE-WINDOW and things
-  trying to look at it under tty redisplay don't choke.
-
-/usr1/lisp/nhem/main.lisp, 02-Mar-88 22:03:26, Edit by Chiles.
-  Changed EXPORT of after-initializations to AFTER-EDITOR-INITIALIZATIONS which
-  is really what the macro is called.
-
-/usr1/lisp/nhem/font.lisp, 02-Mar-88 19:53:10, Edit by Chiles.
-  Rearranged some functions.  Added doc strings for exported stuff.  Deleted
-  hardwired structures.  Moved two parameters to Rompsite.Lisp.  Added logical
-  pages.
-
-/usr1/lisp/nhem/lispbuf.lisp, 02-Mar-88 14:12:30, Edit by Chiles.
-  Made SETUP-EVAL-MODE make a local binding of "Current Package" to nil.
-
-/usr1/lisp/nhem/lispeval.lisp, 02-Mar-88 13:42:49, Edit by Chiles.
-  Modified "Set Buffer Package" to set *package* when in the eval buffer.
-
-/usr1/lisp/nhem/bit-screen.lisp, 01-Mar-88 16:00:24, Edit by Chiles.
-  Made HUNK-MOUSE-ENTERED invoke the "Enter Window Hook" and made
-  HUNK-MOUSE-LEFT invoke the "Exit Window Hook".  Fixed REVERSE-VIDEO-HOOK-FUN
-  to change the background pixmap for a window, so you don't get a flash of
-  white before Hemlock paints black when the window is exposed.
-
-/usr1/lisp/nhem/filecoms.lisp, 24-Feb-88 12:26:07, Edit by Chiles.
-  Changed "Last Resort Pathname Defaults" and "Last Resort Pathname Defaults
-  Function".
-
-/usr1/lisp/nhem/rompsite.lisp, 01-Mar-88 15:29:32, Edit by Chiles.
-  Made SITE-INIT define "Enter Window Hook" and "Exit Window Hook".  Wrote
-  ENTER-WINDOW-AUTORAISE as example hook for losers into autoraising.
-
-  Put in DEFHVAR in SITE-INIT for "Default Font".  Modified INIT-RAW-IO,
-  SETUP-FONT-FAMILY, and OPEN-FONT in conjunction with supporting this new
-  variable.
-
-/usr1/chiles/work/temp-hem/rompsite.lisp, 22-Feb-88 21:07:14, Edit by Chiles.
-  Changed GET-HEMLOCK-CURSOR to not use ".mask" as a pathname, but to use
-  MAKE-PATHNAME :type "mask" ... instead.
-
-/usr1/chiles/work/temp-hem/lispeval.lisp, 22-Feb-88 21:01:49, Edit by Chiles.
-  Changed CLEANUP-COMPILE-NOTIFICATION to not use ".fasl" as a pathname, but to
-  use MAKE-PATHNAME :type "fasl" ... instead.
-
-/usr1/lisp/nhem/filecoms.lisp, 22-Feb-88 17:15:35, Edit by Chiles.
-  Introduced "Last Resort Pathname Defaults" and "Last Resort Pathname Defaults
-  Function" and modified BUFFER-DEFAULT-PATHNAME.
-
-/usr1/lisp/nhem/spellcoms.lisp, 22-Feb-88 16:50:33, Edit by Chiles.
-  Made "Check Word Spelling" output digits with possible correct spellings.
-  Made "Correct Last Misspelled Word" take 0-9 in the command loop as the
-  numbered word to use as a correct spelling.
-
-/usr1/lisp/nhem/morecoms.lisp, 22-Feb-88 13:13:54, Edit by Chiles.
-  Frobbed control flow in "Goto Page" and made it drop a mark when searching
-  page titles a first time.
-
-/usr1/lisp/nhem/auto-save.lisp, 18-Feb-88 17:25:10, Edit by Chiles.
-  Made "Save" mode turn off automatically in "Typescript" and "Eval" modes.
-
-/usr1/lisp/nhem/main.lisp, 18-Feb-88 17:11:12, Edit by Chiles.
-  Put "Save" mode in "Default Modes".
-
-/usr1/lisp/nhem/indent.lisp, 16-Feb-88 14:41:34, Edit by Chiles.
-  Fixed bug "Indent" being called with a zero argument.
-
-/usr1/lisp/nhem/searchcoms.lisp, 16-Feb-88 14:14:32, Edit by Chiles.
-  Made THE four searching commands only drop a mark if the region is not
-  active.  Also, make i-search ^G invoke the abort-hook.  Made incremental
-  searching commands set the last command type to nil since each letter typed
-  does not go through the command loop, and ephemerally active regions were
-  staying highlighted throughout the search.
-
-/usr1/lisp/nhem/lispmode.lisp, 14-Feb-88 20:34:03, Edit by Chiles.
-  Added DEFINDENT's for some CLOS stuff.  Added one for "frob" for Rob and me.
-  Added a few for system calls.
-
-/usr1/lisp/nhem/lispeval.lisp, 11-Feb-88 13:58:31, Edit by Chiles.
-  Made FILE-COMPILE look at a new variable "Remote File Compile".
-
-/usr1/lisp/nhem/lispeval.lisp, 10-Feb-88 20:08:04, Edit by Chiles.
-  Made OLDER-OR-NON-EXISTENT-FASL-P's second argument optional.
-
-/usr1/lisp/nhem/lispbuf.lisp, 10-Feb-88 20:11:14, Edit by Chiles.
-  Made "List Compile Group" use OLDER-OR-NON-EXISTENT-FASL-P.
-
-/usr1/lisp/nhem/highlight.lisp, 10-Feb-88 19:52:50, Edit by Chiles.
-  Modified HIGHLIGHT-ACTIVE-REGION to not do anything when the window is the
-  echo area window.
-
-/usr1/lisp/nhem/killcoms.lisp, 10-Feb-88 15:55:19, Edit by Chiles.
-  Augmented the active region flag with an active region buffer variable to
-  circumvent echo area interactions.
-
-/usr1/lisp/nhem/main.lisp, 10-Feb-88 15:46:29, Edit by Chiles.
-  Made SAVE-ALL-BUFFERS optionally list unmodified buffers.
-
-/usr1/lisp/nhem/highlight.lisp, 08-Feb-88 13:49:37, Edit by Chiles.
-  Implemented highlighting active regions.  Renamed a bunch of open paren
-  highlighting stuff, and frobbed it to interact with region highlighting.
-
-/usr1/lisp/nhem/killcoms.lisp, 08-Feb-88 13:30:20, Edit by Chiles.
-  Made CURRENT-REGION take another option to not deactivate the region.
-
-/usr1/lisp/nhem/rompsite.lisp, 06-Feb-88 16:23:45, Edit by Chiles.
-  Fixed bug in PRETTY-PRINT-CHARACTER that was created by INSERT-CHARACTER
-  checking the type of its arguments.
-
-/usr1/lisp/nhem/lispmode.lisp, 06-Feb-88 16:17:20, Edit by Chiles.
-  Fixed Scan-Direction-Valid to return NIL when it hits the end of the buffer.
-
-/usr1/lisp/nhem/killcoms.lisp, 06-Feb-88 10:11:35, Edit by Chiles.
-  Made "Exchange Point and Mark" no longer activate the region.
-
-/usr1/lisp/nhem/fill.lisp, 06-Feb-88 09:53:14, Edit by Chiles.
-  Made "Fill Paragraph" and "Fill Region" use p as the column if supplied.
-
-/usr1/lisp/nhem/rompsite.lisp, 04-Feb-88 15:33:11, Edit by Chiles.
-  Fixed the font stuff in initialization to not call TRUENAME on the font
-  names.  This was wrong.  Fixed the font stuff to be aware of a font not
-  opening, signalling an error if it is the default font and warning if it was
-  the highlighting font.
-
-/usr1/lisp/nhem/htext3.lisp, 04-Feb-88 16:02:41, Edit by Chiles.
-  Made INSERT-CHARACTER check the type of its argument.
-
-/usr1/lisp/nhem/searchcoms.lisp, 04-Feb-88 15:46:24, Edit by Chiles.
-  Fixed bug in i-search that allowed non-text characters to be searched for.
-  Also in the C-q case, nil was trying to be inserted into a buffer which
-  crashed Lisp.
-
-/usr1/lisp/nhem/command.lisp, 04-Feb-88 14:21:10, Edit by Chiles.
-  Provided error message for TEXT-CHARACTER nil result in "Self Insert" and
-  "Quoted Insert"
-
-/usr1/lisp/nhem/overwrite.lisp, 04-Feb-88 14:17:32, Edit by Chiles.
-  Protected use of TEXT-CHARACTER, testing for nil result.
-
-/usr1/lisp/nhem/lispeval.lisp, 03-Feb-88 11:57:33, Edit by Chiles.
-/usr1/lisp/nhem/lispbuf.lisp, 03-Feb-88 11:57:33, Edit by Chiles.
-  Modified "Compile Buffer File", "Editor Compile Buffer File", "Compile
-  Group", and "Editor Compile Group".  Deleted MAYBE-COMPILE-FILE and
-  MAYBE-COMPILE-EDITOR-FILE.  Wrote OLDER-OR-NON-EXISTENT-FASL-P.
-
-/usr1/lisp/nhem/icom.lisp, 01-Feb-88 16:21:37, Edit by Chiles.
-  Merged Scott's hack to the comment hack to keep highlighted parens clean.
-
-/usr1/lisp/nhem/obit-screen.lisp, 01-Feb-88 16:08:35, Edit by Chiles.
-  Modified OBITMAP-MAKE-WINDOW and OBITMAP-DELETE-WINDOW to invalidate the
-  currently selected hunk.
-
-/usr1/lisp/nhem/tty-screen.lisp, 01-Feb-88 15:56:53, Edit by Chiles.
-  Modified TTY-MAKE-WINDOW and TTY-DELETE-WINDOW to invalidate the currently
-  selected hunk.
-
-/usr1/lisp/nhem/spellcoms.lisp, 01-Feb-88 08:28:09, Edit by Chiles.
-  Fixed MAYBE-READ-DEFAULT-USER-SPELLING-DICTIONARY.
-
-/usr1/lisp/nhem/bindings.lisp, 28-Jan-88 20:46:09, Edit by Chiles.
-  Deleted binding for "Compile Buffer File" in "Editor" mode.
-
-/usr1/lisp/nhem/interp.lisp, 28-Jan-88 11:18:47, Edit by Chiles.
-  Fixed problem with clearing prefix characters from the echo area when a bad
-  sequence is typed.
-
-/usr0/ram/lispmode.lisp, 27-Jan-88 17:21:48, Edit by Ram.
-  Wrote Find-Ignore-Region and used it to implement Valid-Spot and the new
-  Scan-Direction-Valid macro, which efficiently scans for a valid character
-  having the specified properties of its attribute.  Used Scan-Direction-Valid
-  to substantially rewrite %Form-Offset.  It now correctly handles character
-  literals (and as a side-effect, symbols with slashed characters).  Also
-  changed form offset to skip over prefix characters when moving backward over
-  a list.  Users will probably notice this, and hopefully like it.
-
-/usr0/ram/highlight.lisp, 27-Jan-88 17:15:35, Edit by Ram.
-  Changed Form-Offset to List-Offset in Maybe-Highlight-Open-Parens.  Now that
-  backward form offset on lists include prefix characters, Form-Offset is no
-  longer correct.  Directly doing List-Offset is slightly more efficient
-  anyway.
-
-/usr1/lisp/nhem/highlight.lisp, 27-Jan-88 15:29:50, Edit by Chiles.
-  Turned "Highlight Open Parens" off by default.
-
-/usr1/lisp/nhem/lispmode.lisp, 27-Jan-88 15:32:12, Edit by Chiles.
-  Turned "Paren Pause Period" and "Highlight Open Parens" on in "Lisp" mode.
-  Set "Paren Pause Period" to 0.5 by default.
-
-/usr1/lisp/nhem/tty-screen.lisp, 27-Jan-88 15:32:57, Edit by Chiles.
-  Made INIT-TTY-SCREEN-MANAGER make "Paren Pause Period" and "Highlight Open
-  Parens" be off in "Lisp" mode for tty's since we don't have highlighting
-  fonts for tty's.
-
-/usr1/lisp/hemlock/highlight.lisp, 25-Jan-88 16:19:49, Edit by DBM.
-  Chanded default for "Highlight Open Parens" to T.
-
-/usr1/lisp/nhem/newer/rompsite.lisp, 25-Jan-88 11:30:43, Edit by Chiles.
-  Made SLEEP-FOR-TIME deal with noting a read wait (dropping and lifting the
-  cursor).
-
-/usr1/lisp/nhem/main.lisp, 25-Jan-88 11:11:10, Edit by Chiles.
-  Entered DEFHVAR for "Key Echo Delay".
-
-/usr1/lisp/nhem/newer/interp.lisp, 25-Jan-88 11:06:01, Edit by Chiles.
-  Frobbed %COMMAND-LOOP to try to echo keys after some typing delay.
-
-/usr1/lisp/nhem/newer/lispeval.lisp, 24-Jan-88 19:43:50, Edit by Chiles.
-  Made DELETE-SERVER look for all bindings of "Current Eval Server", setting
-  them to nil if they referenced the argument info object.  Also made it delete
-  the "Server Information" variable in the slave buffer if there was one.
-
-/usr1/lisp/nhem/newer/rompsite.lisp, 24-Jan-88 19:10:52, Edit by Chiles.
-  Modified EDITOR_CONNECT-HANDLER to define "Server Information" in the slave
-  buffer.
-
-/usr1/lisp/nhem/newer/command.lisp, 24-Jan-88 15:33:09, Edit by Chiles.
-  Installed Shareef's "Refresh Screen" that knows about arguments.
-
-/usr1/lisp/nhem/newer/lispmode.lisp, 24-Jan-88 15:27:06, Edit by Chiles.
-  Fixed bug in "Lisp Insert )" to make it echo the closing paren if it is not
-  DISPLAYED-P regardless of "Paren Pause Period".
-
-/usr1/lisp/nhem/highlight.lisp, 23-Jan-88 15:43:59, Edit by Chiles.
-  New file.
-
-/usr1/lisp/nhem/scribe.lisp, 23-Jan-88 15:42:11, Edit by Chiles.
-  Modified SCRIBE-INSERT-PAREN to know about "Paren Pause Period" possibly
-  being nil.
-
-/usr1/lisp/nhem/lispmode.lisp, 23-Jan-88 15:40:57, Edit by Chiles.
-  Modified "Lisp Insert )" to know about "Paren Pause Period" possibly being
-  nil.
-
-/usr1/lisp/nhem/morecoms.lisp, 23-Jan-88 15:36:22, Edit by Chiles.
-  Fixed "Mark Page" when point is at buffer-end.
-
-/usr1/lisp/nhem/srccom.lisp, 23-Jan-88 15:26:40, Edit by Chiles.
-  Put "Buffer Changes" from my init file into the core.
-
-/usr1/lisp/nhem/filecoms.lisp, 23-Jan-88 15:21:36, Edit by Chiles.
-  Modified "Revert File" to be more aware of whether it was backing up to the
-  checkpoint file or the saved file.
-
-/usr1/lisp/nhem/display.lisp, 23-Jan-88 14:01:50, Edit by Chiles.
-  Changed REDISPLAY-LOOP and REDISPLAY-WINDOWS-FROM-MARK to do the current
-  window first if it is going to get done, so the redisplay-hook effects could
-  be seen in other windows into the same buffer.
-
-/usr1/lisp/nhem/edit-defs.lisp, 23-Jan-88 14:47:28, Edit by Chiles.
-  Modified DEFINITION-EDITING-INFO to correspond to the new
-  FUN-DEFINED-FROM-PATHNAME ability to deal with encapsulations.
-
-/usr1/lisp/nhem/rompsite.lisp, 23-Jan-88 14:36:33, Edit by Chiles.
-  Modified FUN-DEFINED-FROM-PATHNAME, now deals with encapsulations.
-
-/usr1/lisp/nhem/indent.lisp, 23-Jan-88 13:42:43, Edit by Chiles.
-  Added Shareef's "Center Line" command.
-
-/usr1/lisp/nhem/files.lisp, 23-Jan-88 12:42:10, Edit by Chiles.
-  Made WRITE-FILE supply :if-exists :rename-and-delete.
-
-/usr1/lisp/nhem/lispeval.lisp, 23-Jan-88 12:28:13, Edit by Chiles.
-  Made "Compile File" signal an error when buffer has no associated pathname.
-
-/usr1/ch/lisp/filecoms.lisp, 22-Jan-88 11:48:49, Edit by Christopher Hoover
-  Fixed write-region to call (current-region) before prompting for filename.
-  This makes it work better with active regions.
-
-/usr1/chiles/work/modeline/window.lisp, 19-Jan-88 09:58:24, Edit by Chiles.
-  Modified DEFAULT-MODELINE-FUNCTION-FUNCTION and wrote
-  UPDATE-BUFFER-MODELINES, which is exported.
-
-/usr1/chiles/work/modeline/main.lisp, 19-Jan-88 10:10:27, Edit by Chiles.
-  Changed the value of "Default Modeline String".
-
-/usr1/chiles/work/modeline/lispmode.lisp, 19-Jan-88 10:05:31, Edit by Chiles.
-  Wrote SETUP-LISP-MODE to make a "Current Package" if there wasn't one already.
-
-/usr1/chiles/work/modeline/lispeval.lisp, 19-Jan-88 09:49:29, Edit by Chiles.
-  Made "Set Buffer Package" use PROMPT-FOR-EXPRESSION, using STRING on the
-  result.  It also now calls UPDATE-BUFFER-MODELINES.  When in a slave's
-  interactive buffer's, do NOT set "Current Package", but change *package* in
-  the slave.  Modified sites of (value current-package) to supply "" instead of
-  the editor's *package*.
-
-/usr1/lisp/nhem/lispbuf.lisp, 18-Jan-88 12:50:34, Edit by Chiles.
-  Modified "package" file option to do a STRING of a READ-FROM-STRING.
-
-/usr1/lisp/nhem/ts.lisp, 17-Jan-88 20:53:13, Edit by Chiles.
-  Made MAKE-TYPESCRIPT use "Interactive History Length" when setting up
-  "Interactive History".
-
-/usr1/lisp/nhem/lispbuf.lisp, 17-Jan-88 20:51:25, Edit by Chiles.
-  Moved some stuff around.  Created "Interactive History Length" used to setup
-  "Interactive History" when "Eval" mode is turned on.
-
-/usr1/lisp/nhem/spellcoms.lisp, 16-Jan-88 16:58:31, Edit by Chiles.
-  Introduced "Default User Spelling Dictionary".  When set, this is loaded upon
-  entering "Spell" mode and when "Set Buffer Spelling Dictionary" (or
-  "dictionary" file option) runs.  Also, "Save Incremental Spelling Insertions"
-  doesn't prompt for a file if this is set.
-
-  Made SAVE-DICTIONARY-ON-WRITE make sure 'spell-information is bound in the
-  buffer.
-
-/usr1/ch/lisp/auto-save.lisp, 12-Jan-88 16:28:56, Edit by Christopher Hoover
-  Wrapped a condition-case around the write-file in Auto Save.  This will cause
-  Auto Save to graceful handle write failures.
-
-/usr1/lisp/nhem/spellcoms.lisp, 06-Jan-88 22:14:14, Edit by Chiles.
-  Made incremental insertions dictionary specific with a global default for
-  upward compatability.
-    Commands with new names:
-      "Append to Spelling Dictionary" --> "Save Incremental Spelling Insertions"
-      "Augment Spelling Dictionary" --> "Read Spelling Dictionary"
-    New commands:
-      "Set Buffer Spelling Dictionary"
-      "Remove Word from Spelling Dictionary"
-      "List Incremental Spelling Insertions"
-  AND there is a "dictionary" file option that read a dictionary if necessary,
-  makes it the buffer's dictionary, and causes the incremental insertions for
-  this dictionary to be written when the buffer is.
-
-  Added "Spelling Un-Correct Prompt for Insert" that makes "Undo Last Spelling
-  Correction" prompt before inserting word into dictionary.
-
-/usr1/lisp/nhem/doccoms.lisp, 22-Dec-87 15:42:26, Edit by Chiles.
-  Changed #\S help to #\V, "Describe and show Variable".  Rewrote some code to
-  do this and added the command "Describe and show Variable".
-
-/usr1/lisp/nhem/spell-augment.lisp, 17-Dec-87 21:05:37, Edit by Chiles.
-  Added SPELL-ROOT-FLAGS, which returns a list of the letter flags a root entry
-  has, and SPELL-REMOVE-ENTRY, which removes an entry by clearing a flag if
-  appropriate or setting the dictionary element to -1.
-
-/usr1/lisp/nhem/spell-correct.lisp, 17-Dec-87 20:34:09, Edit by Chiles.
-  Made TRY-WORD-ENDINGS return the flag mask when a flag was used instead of
-  just t.  Modified lookup hashing to know about deleted elements.
-
-/usr1/lisp/nhem/echo.lisp, 16-Dec-87 21:25:58, Edit by Chiles.
-  MAYBE-WAIT should really do a SLEEP instead of EDITOR-SLEEP to make sure
-  nothing happens while the user is trying to see the message.
-
-/usr1/lisp/nhem/active/text.lisp, 14-Dec-87 01:25:42, Edit by Chiles.
-  Made "Mark Paragraph" and "Mark Sentence" use PUSH-BUFFER-MARK, so it will
-  activate the region.
-
-/usr1/lisp/nhem/active/lispmode.lisp, 14-Dec-87 01:25:03, Edit by Chiles.
-  Made "Mark Defun" and "Mark Form" use PUSH-BUFFER-MARK, so it will activate
-  the region.
-
-/usr1/lisp/nhem/active/morecoms.lisp, 13-Dec-87 20:45:48, Edit by Chiles.
-  Modified "Insert Page Directory" to insert the listing at the curren point if
-  invoked with an argument.
-
-/usr1/lisp/nhem/active/lispeval.lisp, 12-Dec-87 13:15:04, Edit by Chiles.
-  Defined "Slave Utility Name" and "Slave Arguments" and made CREATE-SLAVE use
-  these to spawn Lisps.
-
-/usr1/lisp/nhem/active/main.lisp, 11-Dec-87 07:24:44, Edit by Chiles.
-  Defined and invoked "Reset Hook".
-
-/usr1/lisp/nhem/active/xcommand.lisp, 11-Dec-87 05:37:26, Edit by Chiles.
-  Made "Region to Cut Buffer" use CURRENT-REGION, insisting it be active.
-
-/usr1/lisp/nhem/active/lispbuf.lisp, 11-Dec-87 05:16:46, Edit by Chiles.
-  Made commands use CURRENT-REGION, insisting it be active.  Changed the
-  semantics of "Editor Compile Defun" "Editor Evaluate Defun".
-
-/usr1/lisp/nhem/active/indent.lisp, 11-Dec-87 03:49:08, Edit by Chiles.
-  Made "Indent Region" and "Indent Rigidly" use CURRENT-REGION, insisting it be
-  active.
-
-/usr1/lisp/nhem/active/fill.lisp, 11-Dec-87 03:16:15, Edit by Chiles.
-  Made "Fill Region" use CURRENT-REGION, insisting it be active.
-
-/usr1/lisp/nhem/active/filecoms.lisp, 11-Dec-87 03:12:25, Edit by Chiles.
-  Made "Write Region" use CURRENT-REGION, insisting it be active.
-
-/usr1/lisp/nhem/active/abbrev.lisp, 11-Dec-87 03:05:12, Edit by Chiles.
-  Modified commands to use CURRENT-REGION, not insisting it be active.
-
-/usr1/lisp/nhem/active/morecoms.lisp, 11-Dec-87 02:40:31, Edit by Chiles.
-  Changed calls to PUSH-BUFFER-MARK that shouldn't activate the region.  Made
-  "Count Lines Region" and "Count Words Region" use CURRENT-REGION, not
-  insisting it be active (for now).  "Insert Page Directory" sets the command
-  type to :ephemerally-active, so "Kill Region" can kill the inserted text.
-
-/usr1/lisp/nhem/active/lispeval.lisp, 11-Dec-87 01:52:20, Edit by Chiles.
-  Made "Edit Compiler Errors" not activate the region when it calls
-  PUSH-BUFFER-MARK.  Made commands use CURRENT-REGION, insisting it be active.
-  Changed the semantics of "Compile Defun" and "Evaluate Defun".  Fixed bug in
-  FILE-COMPILE-TEMP-FILE.
-
-/usr1/lisp/nhem/active/edit-defs.lisp, 11-Dec-87 01:32:31, Edit by Chiles.
-  Made GO-TO-DEFINITION not activate the region when it calls
-  PUSH-BUFFER-MARK.
-
-/usr1/lisp/nhem/active/command.lisp, 11-Dec-87 01:25:22, Edit by Chiles.
-  Made "Beginning of Buffer" and "End of Buffer" not activate the region when
-  they call PUSH-BUFFER-MARK.
-
-/usr1/lisp/nhem/active/register.lisp, 11-Dec-87 01:01:22, Edit by Chiles.
-  Fixed bug in cleanup for deleted buffers -- should free register when its a
-  mark since you cannot list it.  Made "Get Register" set LAST-COMMAND-TYPE to
-  :ephemerally-active, so "Kill Region" can kill the inserted text.
-
-/usr1/lisp/nhem/active/bindings.lisp, 10-Dec-87 23:41:40, Edit by Chiles.
-  Added bindings for "Activate Region", "Pop and Goto Mark", and "Pop Mark".
-  Bound "Verbose Directory" to ^X^D and destroyed translation for ^D, so I
-  duplicated bindings for "Delete Next Character" and "Scribe Display".
-
-/usr1/lisp/nhem/macros.lisp, 10-Dec-87 16:49:39, Edit by Chiles.
-  Made ADD-HOOK	use PUSHNEW.
-
-/usr1/lisp/nhem/register.lisp, 10-Dec-87 00:08:00, Edit by Chiles.
-  New Register hacking code.
-
-/usr1/lisp/nhem/bindings.lisp, 09-Dec-87 13:55:22, Edit by Chiles.
-  Made bindings for "Transpose Regions" and "Directory".
-  Added default bindings for register stuff.
-
-/usr1/lisp/nhem/morecoms.lisp, 09-Dec-87 13:36:55, Edit by Chiles.
-  Added "Transpose Regions".
-
-/usr1/lisp/nhem/doccoms.lisp, 09-Dec-87 13:20:28, Edit by Chiles.
-  Wrote "Show Variable".
-
-/usr1/lisp/nhem/echo.lisp, 09-Dec-87 13:04:50, Edit by Chiles.
-  Modified PROMPT-FOR-VARIABLE and wrote VARIABLE-VERIFICATION-FUNCTION to
-  notice when a variable completion lost due to multiple entries of the same
-  variable.
-
-/usr1/lisp/nhem/spellcoms.lisp, 09-Dec-87 01:05:57, Edit by Chiles.
-  Made "Append to Spelling Dictionary" take an optional file argument.
-
-/usr1/lisp/nhem/edit-defs.lisp, 08-Dec-87 18:18:44, Edit by Chiles.
-  Merged with lost sources to get back the preference translation functionality
-  where one directory can be mapped to an ordered list of translations.
-
-/usr1/lisp/nhem/lispeval.lisp, 08-Dec-87 22:54:12, Edit by Chiles.
-  Modifed eval-notification structure, EVAL-OPERATION_COMPLETE, REGION-EVAL,
-  and FILE-COMPILE-TEMP-FILE.  Wrote PATHNAME-FOR-REMOTE-ACCESS and STRING-EVAL
-  and the command "Load File".
-
-/usr1/lisp/nhem/lispbuf.lisp, 08-Dec-87 19:48:43, Edit by Chiles.
-  Renamed "Load File" to be "Editor Load File".
-
-/usr1/lisp/nhem/main.lisp, 05-Dec-87 18:14:19, Edit by Chiles.
-  Defined "Redisplay Hook".
-
-/usr1/lisp/nhem/display.lisp, 05-Dec-87 15:37:53, Edit by Chiles.
-  Put a redisplay hook into REDISPLAY-WINDOW-RECENTERING.
-
-/usr1/lisp/nhem/rompsite.lisp, 04-Dec-87 21:10:14, Edit by Chiles.
-  Made SITE-WRAPPER-MACRO bind *standard-input* to a stream that disallows
-  reads.  This is to keep people from losing in "Eval" mode.
-
-/usr1/lisp/nhem/filecoms.lisp, 04-Dec-87 15:00:50, Edit by Chiles.
-  Made "Visit File" set buffer-writable, so the buffer's region could be
-  deleted when the buffer was read only.
-
-/usr1/lisp/nhem/edit-defs.lisp, 04-Dec-87 14:54:21, Edit by Chiles.
-  Created "Editor Definition Info" variable to control where "Edit
-  Definition" and "Go to Definition" get their defined from information,
-  the editor Lisp or the slave Lisp.
-
-/usr1/lisp/nhem/lispbuf.lisp, 04-Dec-87 13:52:46, Edit by Chiles.
-  Made "Editor Definition Info" t in "Eval" mode.
-
-/usr1/lisp/nhem/lispeval.lisp, 04-Dec-87 13:53:20, Edit by Chiles.
-  Made "Editor Definition Info" t in "Editor" mode.
-
-/usr1/lisp/hemlock/lispeval.lisp, 02-Dec-87 13:23:27, Edit by DBM.
-  Mofified for new name server.
-
-/usr1/lisp/hemlock/rompsite.lisp, 02-Dec-87 13:22:10, Edit by DBM.
-  Modified for new name server.
-
-/usr1/lisp/nhem/bit-screen.lisp, 29-Nov-87 22:55:03, Edit by Chiles.
-  Made BITMAP-DELETE-WINDOW call REMOVE-XWINDOW-OBJECT on the X window
-  instead of the Hemlock window.
-
-/usr1/lisp/nhem/auto-save.lisp, 23-Nov-87 15:59:36, Edit by Chiles.
-  Picked up Chris' latest version.  Tweaked a defvar into a defhvar.
-  Changed its reference and made "Save" mode be turned off when nil or an
-  empty pathname is returned.
-
-/usr1/lisp/nhem/lispeval.lisp, 23-Nov-87 14:33:19, Edit by Chiles.
-  Fixed logic error in GET-CURRENT-SERVER.
-
-/usr1/lisp/nhem/lispeval.lisp, 20-Nov-87 14:17:52, Edit by Chiles.
-  Wrote CALL-EVAL_FORM that makes sure the server isn't busy, binds and
-  error handler, and binds a server death handler.  EVAL_FORM-IN-CLIENT and
-  "Re-Evaluate Defvar" use this.
-
-/usr1/lisp/nhem/rompsite.lisp, 20-Nov-87 13:22:23, Edit by Chiles.
-  Made GET-HEMLOCK-CURSOR do a TRUENAME on the cursor bitmap file variable.
-
-/usr1/lisp/nhem/searchcoms.lisp, 20-Nov-87 11:56:35, Edit by Chiles.
-  "Delete Matching Lines" modified and new "Delete Non-Matching Lines" by
-  Chris. 
-
-/usr1/lisp/nhem/killcoms.lisp, 20-Nov-87 11:58:26, Edit by Chiles.
-  "Delete Blank Lines" added by Chris.
-
-/usr1/lisp/nhem/bindings.lisp, 20-Nov-87 12:06:58, Edit by Chiles.
-  Added binding for "Delete Blank Lines".
-
-/usr1/lisp/nhem/morecoms.lisp, 20-Nov-87 12:10:21, Edit by Chiles.
-  Added Chris' "Count Words Region".
-
-/usr1/lisp/nhem/bit-screen.lisp, 19-Nov-87 00:02:04, Edit by Chiles.
-  Fixed problem with flushing random typeout with the mouse over the
-  typeout window.  Apparently when X buries a window, you do not get an
-  exit event, but Hemlock was getting an entered event and causing the
-  cursor to get out of sync.
-
-/usr1/lisp/nhem/lispeval.lisp, 18-Nov-87 22:39:54, Edit by Chiles.
-  Rewrote CHECK-SERVER-INFO, SUB-CHECK-SERVER-INFO, and GET-CURRENT-SERVER.
-  Added MAYBE-CREATE-SLAVE in the process.  Now when the current eval
-  server dies, the next Lisp interaction command does not signal an error
-  but tries to get a valid slave for the user.
-
-/usr1/lisp/nhem/rompsite.lisp, 18-Nov-87 01:07:02, Edit by Chiles.
-  Wrote EDITOR-INPUT-METHOD-MACRO to replace the bodies of EDITOR-TTY-IN
-  and EDITOR-WINDOW-IN.  Added to the macro a test for re-entering a
-  Hemlock input method, signalling an error if this happens.  Added a
-  binding of an error condition handler that exits Hemlock and goes into
-  the debugger.
-
-/usr1/lisp/hemlock/bit-screen.lisp, 17-Nov-87 17:03:15, Edit by Chiles.
-  Made enter and exit window event handlers call CURSOR-INVERT-CENTER when
-  the cursor is dropped.
-
-/usr1/lisp/nhem/lispeval.lisp, 17-Nov-87 15:40:42, Edit by Chiles.
-  Made CREATE-SLAVE not call INIT-EDITOR-SERVER since we presumably catch
-  nameserver crashes now.
-
-/usr1/lisp/nhem/lispbuf.lisp, 15-Nov-87 20:30:20, Edit by Chiles.
-  Made "Compile File" do an update compilation.
-
-/usr1/lisp/nhem/lispeval.lisp, 15-Nov-87 20:11:12, Edit by Chiles.
-  Made "Compile File" do an update compilation.
-
-/usr1/lisp/nhem/main.lisp, 15-Nov-87 18:20:19, Edit by Chiles.
-  Fixed doc string of ED to escape some "'s.
-
-/usr1/lisp/nhem/morecoms.lisp, 15-Nov-87 17:27:12, Edit by Chiles.
-  Made "Exit Recursive Edit" and "Abort Recursive Edit" call
-  IN-RECURSIVE-EDIT, signalling an error when nil.
-
-/usr1/lisp/nhem/buffer.lisp, 15-Nov-87 16:48:01, Edit by Chiles.
-  Made EXIT-RECURSIVE-EDIT and ABORT-RECURSIVE-EDIT signal an error when
-  not in a recursive edit.  Wrote IN-RECURSIVE-EDIT.
-
-/usr1/lisp/nhem/lispbuf.lisp, 15-Nov-87 13:45:32, Edit by Chiles.
-  Made "Load File" supply (or load default buffer pathname default) for
-  :default to PROMPT-FOR-FILE.
-
-/usr1/lisp/nhem/, 15-Nov-87 13:24:00, Edit by Chiles.
-  Renamed Integrity.Lisp to Hi-Integrity.Lisp.  Created Ed-Integrity.Lisp
-  that currently includes tty redisplay testing code.  Modified Ctw.Lisp to
-  conform with these two changes.
-
-/usr1/lisp/nhem/tty-display.lisp, 15-Nov-87 12:35:09, Edit by Chiles.
-  Generally added major gobs of documentation.
-  Modified:
-     COMPUTE-TTY-CHANGES
-        Introduced cum-inserts.
-        Changed computation of line deletions location.
-        Changed where deletions are done for the modeline due to excessive
-           insertion above it.
-     DO-SEMI-DUMB-LINE-WRITES
-        Commented out a somewhat bogus optimization that was causing
-           TTY-SMART-WINDOW-REDISPLAY to lose when "Scroll Redraw Ration"
-           kicked in.
-     DELETE-SI-LINES
-     INSERT-SI-LINES
-        Changed variable names.
-
-/usr1/lisp/nhem/filecoms.lisp, 14-Nov-87 13:38:42, Edit by Chiles.
-  Made "Write Region" use BUFFER-PATHNAME-DEFAULTS.
-
-/usr1/lisp/nhem/lispeval.lisp, 11-Nov-87 21:54:53, Edit by Chiles.
-  Modified "Edit Compiler Errors" to not switch to errors buffer unless it
-  has too.  This fixes spurious redisplay when there are no errors to edit.
-
-/usr1/lisp/nhem/main.lisp, 10-Nov-87 19:19:13, Edit by Chiles.
-  Removed DEFHVAR's for "Timer Hook" and "Timer Hook Interval".
-
-/usr1/lisp/nhem/rompsite.lisp, 10-Nov-87 19:15:25, Edit by Chiles.
-  Added page title "Time queue".  This is used in editor input stream in
-  methods in conjunction with user interfaces SCHEDULE-EVENT and
-  REMOVE-SCHEDULED-EVENT to all the user to have functions invoked
-  periodically.
-
-/usr1/lisp/nhem/main.lisp, 09-Nov-87 21:23:37, Edit by Chiles.
-  Added AFTER-EDITOR-INITIALIZATIONS macro.  Made ED funcall stuff on
-  *after-editor-initializations-funs* put there by the macro.
-
-/usr1/lisp/nhem/filecoms.lisp, 06-Nov-87 00:59:21, Edit by Chiles.
-  Modified WRITE-DA-FILE and READ-DA-FILE to invoke the "Write File Hook"
-  and "Read File Hook" hooks.  eh!
-
-/usr2/lisp/nhem/lispeval.lisp, 26-Oct-87 11:36:35, Edit by Chiles.
-  Put back in feature of restoring previous buffer in "Edit Compiler
-  Errors" that was lost somehow.
-
-/usr2/lisp/nhem/filecoms.lisp, 25-Oct-87 17:13:04, Edit by Chiles.
-  ROB: Split two subfunctions off of "Find File".  FIND-FILE-BUFFER does
-  all the work, returning the buffer and a flag indicating whether it
-  created a buffer.  Fixed some :prompt values.
-
-/usr2/lisp/nhem/edit-defs.lisp, 25-Oct-87 16:42:00, Edit by Chiles.
-  Fixed bug in GET-DEFINITION-PATTERN for type :command.
-
-/usr0/ram/group.lisp, 04-Oct-87 15:10:49, Edit by Ram.
-  Changed Group-Read-File to use Find-File-Buffer instead of Find-File-Command,
-  eliminating the need for gruesome hacks to tell whether a buffer was created.
-  This also has the beneficial side-effect of making it easy for group commands
-  to leave to buffer history intact.  Changed Do-Active-Group to restore the
-  buffer that was current at the time the command was done.
-
-/usr1/lisp/hemlock/hunk-draw.lisp, 23-Oct-87 15:45:14, Edit by Chiles.
-  Wrote CURSOR-INVERT-CENTER to hollow out the center of the cursor.  THis
-  is used when Hemlock is not the listener to corresspond with Xterm
-  behaviour.  Modified DROP-CURSOR and LIFT-CURSOR to use this new fun too
-  when Hemlock is not the listener, so we don't get little black squares or
-  empty boxes when we should.
-
-/usr2/lisp/nhem/filecoms.lisp, 23-Oct-87 15:36:25, Edit by Chiles.
-  Inserted Chris Hoover's "Revert File" and "Mode" file option definitions.
-
-/usr2/lisp/nhem/hunk-draw.lisp, 23-Oct-87 15:24:36, Edit by Chiles.
-  Fixed documentation for DRAW-HUNK-BOTTOM-BORDER and HUNK-REPLACE-MODELINE,
-  stating dependencies on BITMAP-HUNK-MODELINE-POS not returning nil.
-
-/usr2/lisp/nhem/bit-screen.lisp, 23-Oct-87 15:16:40, Edit by Chiles.
-  Fixed a usage of BITMAP-HUNK-MODELINE-POS that was assuming it was never
-  nil.
-
-/usr1/lisp/hemlock/lispeval.lisp, 23-Oct-87 12:10:09, Edit by DBM.
-  File-compile, Region-eval, and region-compile were passing a
-  structure as a port to the servers.
-
-/usr2/lisp/nhem/bindings.lisp, 23-Oct-87 11:58:45, Edit by Chiles.
-  Killed bindings for c-m-c and c-m-\c in "Echo Area".
-
-/usr2/lisp/nhem/bit-screen.lisp, 22-Oct-87 15:43:08, Edit by Chiles.
-  Fixed BITMAP-MAKE-WINDOW to set the thumb-bar-p slot to (and
-  modeline-string (value thumb-bar-meter)) instead of just the Hvar's
-  value.  Windows without modelines were get a nil not number error.
-
-/usr2/lisp/nhem/lispbuf.lisp, 16-Oct-87 14:04:38, Edit by Chiles.
-  Made DESCRIBE-SYMBOL-AUX slightly better with respect to (quote <symbol>)
-  (function <symbol>).
-
-/usr2/lisp/nhem/lispeval.lisp, 15-Oct-87 22:22:13, Edit by Chiles.
-  Made DESCRIBE-SYMBOL-AUX slightly better with respect to (quote <symbol>)
-  (function <symbol>).
-
-/usr2/lisp/nhem/edit-defs.lisp, 15-Oct-87 21:02:29, Edit by Chiles.
-  Added a hack to catch command definitions when looking for the name of a
-  function, and the last sever letters of the function name are "COMMAND".
-
-/usr2/lisp/nhem/bit-screen.lisp, 15-Oct-87 16:33:54, Edit by Chiles.
-  Made HUNK-EXPOSED-OR-CHANGED take a width and height argument since the X
-  exposedwindow handler is supposed to now and eliminated the call to
-  FULL-WINDOW-STATE.
-
-/usr1/lisp/hemlock/rompsite.lisp, 12-Oct-87 16:56:14, Edit by DBM.
-  Added auto-save.fasl to list of files loaded.
-
-/usr1/lisp/hemlock/auto-save.lisp, 12-Oct-87 16:49:34, Edit by DBM.
-  Added to the hemlock sources.
-
-/usr2/lisp/nhem/lispeval.lisp, 06-Oct-87 00:18:25, Edit by Chiles.
-  Modified "Edit Compiler Errors" to save a pointer to the previous buffer
-  when moving to the background buffer, and to use this before EDITOR-ERROR
-  calls to restore the user's position.
-
-/usr2/lisp/nhem/edit-defs.lisp, 01-Oct-87 14:06:00, Edit by Chiles.
-  Rewrote translation stuff and GO-TO-DEFINITION to handle a list of
-  translations for a given match.  This allows me to first look on
-  vancouver, then wb1, then lisp-rt1, then fred, etc. for sources depending
-  on which machines are down.
-
-/usr2/lisp/nhem/filecoms.lisp, 01-Oct-87 12:20:46, Edit by Chiles.
-  Modified "Save All Files" to show the file it is going to write when
-  prompting, and when the buffer name is not derived from the pathname, it
-  shows both.
-
-/usr2/lisp/nhem/bit-screen.lisp, 30-Sep-87 22:39:37, Edit by Chiles.
-  Rewrote BITMAP-DELETE-WINDOW to not lose when a window is made and then
-  deleted right away.  Created DELETING-WINDOW-DROP-EVENT that drops
-  pending events for a window that is about to be deleted.  Also, made
-  BITMAP-DELETE-WINDOW lift the cursor when the window being deleted
-  displayed the cursor.
-
-/usr2/lisp/nhem/ts.lisp, 30-Sep-87 21:57:18, Edit by Chiles.
-  Made PROCESS_OPERATION_CONTROL-HANDLER test for *in-top-level-catcher*
-  before throwing to top level.
-
-/usr2/lisp/nhem/tty-display.lisp, 29-Sep-87 15:40:22, Edit by Chiles.
-  Modified TTY-SMART-CLEAR-TO-EOW and TTY-DUMB-WINDOW-REDISPLAY to clear
-  screen image lines properly ... had some off-by-one problems.
-
-/usr2/lisp/nhem/lispbuf.lisp, 28-Sep-87 12:59:25, Edit by Chiles.
-  Made "Editor Compile Defun" and "Editor Compile Region" call
-  COMPILE-FROM-STREAM with :defined-from-pathname supplied as the buffer's
-  pathname. 
-
-/usr2/lisp/nhem/rompsite.lisp, 28-Sep-87 11:21:07, Edit by Chiles.
-  Made FUN-DEFINED-FROM-PATHNAME test for "/..", clipping it and the
-  machine name if it is present in the defining file name.
-
-/usr2/lisp/nhem/lispeval.lisp, 25-Sep-87 11:42:25, Edit by Chiles.
-  Modified "Set Eval Buffer" to set the global eval server always.
-  Modified "Set Compile Server" to set the global compile server always.
-  Rewrote or added support routines SELECT-CURRENT-SERVER,
-  SELECT-GLOBAL-SERVER, SELECT-CURRENT-COMPILE-SERVER,
-  SELECT-GLOBAL-COMPILE-SERVER, GET-CURRENT-SERVER, CHECK-SERVER-INFO.
-  Modified "Select Background" to try for the current compile server's
-  background with a prefix argument.  Modified "Edit Compiler Errors" to
-  look for a compile server before using the current eval server.  Added
-  commands "Current Eval Server" and "Current Compile Server".  Introduced
-  "Prompt for Current Server", so CHECK-SERVER-INFO does not prompt for
-  creating a new slave but prompts for an already known server instead.
-
-/usr2/lisp/nhem/morecoms.lisp, 24-Sep-87 23:12:42, Edit by Chiles.
-  Modified "List Buffers" to show both buffer name and pathname when the
-  are different and both exist.
-
-/usr2/lisp/nhem/hunk-draw.lisp, 25-Sep-87 09:48:17, Edit by Chiles.
-  Made HUNK-DRAW-BOTTOM-BORDER enhance the 80'th notch it draws.
-
-/usr2/lisp/nhem/defsyn.lisp, 24-Sep-87 23:32:57, Edit by Chiles.
-  Made #\formfeed no longer is a whitespace character.
-
-/usr2/lisp/nhem/bindings.lisp, 24-Sep-87 23:28:26, Edit by Chiles.
-  Did some "Argument Digit" binding.
-
-/usr2/lisp/nhem/lispmode.lisp, 24-Sep-87 23:24:29, Edit by Chiles.
-  "Minimum Lines Parsed" and "Maximum Lines Parsed" now default to 50 and
-  500.
-
-/usr2/lisp/nhem/searchcoms.lisp, 24-Sep-87 23:22:41, Edit by Chiles.
-  Made "Count Occurrences" use echo area for result instead of random
-  typeout.
-
-/usr2/lisp/nhem/filecoms.lisp, 24-Sep-87 22:16:48, Edit by Chiles.
-  Made default for "Save All Files Confirm" be t.
-
-/usr2/lisp/nhem/bindings.lisp, 24-Sep-87 22:11:20, Edit by Chiles.
-  Made binding for "Select Background", C-M-C.
-
-/usr2/lisp/nhem/lispbuf.lisp, 24-Sep-87 22:02:32, Edit by Chiles.
-  Changed "Lisp Describe" to "Editor Describe".
-
-/usr2/lisp/nhem/doccoms.lisp, 24-Sep-87 21:56:40, Edit by Chiles.
-  Replaced instance of LISP-DESCRIBE-COMMAND with EDITOR-DESCRIBE-COMMAND.
-
-/usr2/lisp/nhem/lispbuf.lisp, 24-Sep-87 21:48:36, Edit by Chiles.
-  Removed "Eval Mode" command.
-
-/usr2/lisp/nhem/lispeval.lisp, 24-Sep-87 00:21:19, Edit by Chiles.
-  Fixed "Set Buffer Package" to not try to access nil when there isn't a
-  current eval server.  Also, made it test for the server being valid
-  before trying to use it.
-
-/usr2/lisp/nhem/lispeval.lisp, 23-Sep-87 22:49:32, Edit by Chiles.
-  Modified GET-CURRENT-SERVER and CREATE-SERVER to use
-  MAYBE-GET-SLAVE-NAME.
-
-/usr2/lisp/nhem/rompsite.lisp, 23-Sep-87 22:27:38, Edit by Chiles.
-  Modified EDITOR_CONNECT-handler to handler name argument differently.
-  Added definition of "Thumb Bar Meter" to SITE-INIT.
-
-/usr2/lisp/nhem/bit-screen.lisp, 23-Sep-87 15:03:12, Edit by Chiles.
-  Made HUNK-EXPOSED-REGION and HUNK-RESET call HUNK-DRAW-BOTTOM-BORDER.
-
-/usr2/lisp/nhem/hunk-draw.lisp, 23-Sep-87 14:56:44, Edit by Chiles.
-  Renamed HUNK-DRAW-TOP-BORDER to HUNK-DRAW-BOTTOM-BORDER and made it do it
-  to the bottom.  Made hunk-bottom-border be 10 instead of 3.
-
-/usr2/lisp/nhem/bindings.lisp, 21-Sep-87 17:13:39, Edit by Chiles.
-  Made "Compile File" be the default binding for "Editor" mode.
-
-/usr2/lisp/nhem/rompsite.lisp, 21-Sep-87 12:55:58, Edit by Chiles.
-  Modified EDITOR-WINDOW-IN to not use VARIABLE-VALUE four times in a loop.
-  Likewise for EDITOR-TTY-IN.
-
-/usr2/lisp/nhem/edit-defs.lisp, 20-Sep-87 23:57:08, Edit by Chiles.
-  Rewrote GET-DEFINTION-FILE and wrote MAYBE-TRANSLATE-DEFINITION-FILE to
-  have definition directory translation done in the editor instead of the
-  client.
-
-/usr2/lisp/nhem/bindings.lisp, 15-Sep-87 16:44:28, Edit by Chiles.
-  Made prefix key translation for #\control-^ to be :control.
-
-/usr2/lisp/nhem/lispeval.lisp, 14-Sep-87 22:09:42, Edit by chiles.
-  Modified "Set Buffer Package" to use new TL:SET_PACKAGE interface.
-
-/usr2/lisp/nhem/htext4.lisp, 14-Sep-87 17:27:44, Edit by chiles.
-  Modified DELETE-CHARACTERS to do nothing and return t when n = 0.
-  Modified DELETE-REGION to do nothing when the region is empty.
-  Modified DELETE-AND-SAVE-REGION to just return an empty region when its
-  argument is empty.
-
-/usr2/lisp/nhem/htext3.lisp, 14-Sep-87 17:12:52, Edit by chiles.
-  Modified INSERT-STRING to not modify buffer when the string is empty.
-  INSERT-CHARACTER always modifies the buffer.
-  INSERT-REGION wins on empty regions because of INSERT-STRING.
-
-/usr2/lisp/nhem/display.lisp, 14-Sep-87 17:14:52, Edit by chiles.
-  Added some documentation to REDISPLAY-WINDOW-RECENTERING.  Modified
-  MAYBE-UPDATE-WINDOW-IMAGE to return to or nil based on whether it updated
-  the window image.
-
-/usr2/lisp/nhem/cursor.lisp, 14-Sep-87 16:59:56, Edit by chiles.
-  Modified MAYBE-RECENTER-WINDOW to return t or nil based on whether it
-  recentered.
-
-/usr2/lisp/nhem/filecoms.lisp, 13-Sep-87 18:37:15, Edit by Chiles.
-  Made "Log Entry Template" capitalize file author.
-
-/usr2/lisp/nhem/lispeval.lisp, 13-Sep-87 17:59:15, Edit by Chiles.
-  Modified server-info structure, removing the ll-buffer slot in favor of a
-  slave-ts slot.  Modified CREATE-SLAVE to pass the -slave switch the name
-  of the editor server in case two people are on the same machine (in which
-  case they must use -edit differently), and instead of using EDITOR-SLEEP,
-  it now uses SERVER (it was returning immediately on input with
-  EDITOR-SLEEP).  Modified REGION-EVAL, REGION-COMPILE, and FILE-COMPILE to
-  pass the slave-ts slot of the server-info structure of the notification,
-  so terminal-io will happen in the interactive buffer for the server
-  instead of the background buffer.
-
-/usr2/lisp/nhem/main.lisp, 13-Sep-87 14:32:47, Edit by Chiles.
-  Added DEFHVAR's for "Input Hook", "Timer Hook", and "Timer Hook
-  Interval".  Added code in ED to handle Hemlock specific init files.
-
-/usr2/lisp/nhem/ts.lisp, 13-Sep-87 15:34:09, Edit by Chiles.
-  Modified READ-OR-HANG to message about input waits that occur while a
-  buffer is not visible.  Introduced variable "Input Wait Alarm".
-
-/usr2/lisp/nhem/rompsite.lisp, 13-Sep-87 14:41:27, Edit by Chiles.
-  Made editor input stream methods deal with "Input Hook", "Timer Hook",
-  and "Timer Hook Interval".  Modified EDITOR_CONNECT-HANDLER to correspond
-  with new server-info structure.
-
-/usr1/lisp/hemlock/rompsite.lisp, 10-Sep-87 14:38:14, Edit by DBM.
-  Now that Lisp no longer diddles the interrupt characters, the bare
-  console has to be modified so that it doesn't send one of the standard
-  control characters as part of the encoding for control characters.
-
-/usr0/ram/htext1.lisp, 10-Sep-87 13:29:50, Edit by Ram
-  Added a without-interrupts in Close-Line and some warnings about exclusion
-  elsewhere. 
-
-/usr2/lisp/nhem/lispbuf.lisp, 09-Sep-87 22:09:00, Edit by Chiles.
-  Wrote "Select Eval Buffer" command.
-
-/usr2/lisp/nhem/lispeval.lisp, 09-Sep-87 21:47:46, Edit by Chiles.
-  Rewrote the local queuing of :unsent notifications.  This involved
-  deleting all the old stuff and changing KILL-NOTIFICATION and
-  MAYBE-QUEUE-OPERATION-REQUEST.
-
-/usr2/lisp/nhem/filecoms.lisp, 09-Sep-87 18:17:34, Edit by Chiles.
-  Changed "Log Entry Template".
-
-/usr2/lisp/nhem/rompsite.lisp, 09-Sep-87 18:06:39, Edit by Chiles.
-  Made MORE-READ-CHAR call REDISPLAY while looping on SERVER.
-
-/usr2/lisp/nhem/tty-display-rt.lisp, 09-Sep-87 16:00:26, Edit by Chiles.
-  Modified INIT-TTY-DEVICE and EXIT-TTY-DEVICE to not assume that
-  system:*file-input-handlers* had an association for Unix stdin (0).
-
-/usr2/lisp/nhem/lispbuf.lisp, 08-Sep-87 14:04:00, Edit by Chiles.
-  Replaced appropriate occurrences of "top-level" and "top level" with
-  "eval".
-
-/usr2/lisp/nhem/lispeval.lisp, 07-Sep-87 20:56:39, Edit by Chiles.
-  Replaced occurrences of "lisp listener" with "slave lisp" or "lisp
-  interaction".  Renamed things to to with "anonymous client lisp" to
-  "slave".
-
-/usr2/lisp/nhem/tty-display-rt.lisp, 06-Sep-87 18:47:02, Edit by Chiles.
-  Added some documentation to the exit method.
-
-/usr2/lisp/nhem/filecoms.lisp, 03-Sep-87 16:12:28, Edit by Chiles.
-  Made "Directory" list Unix dot files if the prefix is supplied and made
-  the random typeout window have the right number of lines for each
-  listing.  Made a "Verbose Directory" command like "Directory" but based
-  on the new :verbose argument to PRINT-DIRECTORY.
-
-/usr2/lisp/nhem/rompsite.lisp, 06-Sep-87 18:07:40, Edit by Chiles.
-  Fixed INIT-RAW-IO again to not push into system:*file-input-handlers*.
-  Modified EDITOR_CONNECT-HANDLER to make "Slave Lisp <n>" buffer names
-  instead of "Lisp Listener <n>" buffer names.
-
-/usr2/lisp/nhem/tty-display.lisp, 06-Sep-87 16:54:18, Edit by Chiles.
-  Fixed TTY-SMART-CLEAR-TO-EOW boundary condition -- when clearing last
-  line of window to eow, needed >= test instead of = test.
-
-/usr2/lisp/nhem/bindings.lisp, 05-Sep-87 15:52:11, Edit by Chiles.
-  Deleted binding of "Exit Hemlock" to C-c since it is later used for
-  "Process Control".  Changed binding of "Select Lisp Listener" to be a
-  binding for "Select Slave Lisp".  Replaced occurrences of "top-level"
-  with "eval".
-
-/usr2/lisp/nhem/morecoms.lisp, 05-Sep-87 14:08:32, Edit by Chiles.
-  Made "List Buffers" print pathnames with the FILE-NAMESTRING first
-  followed by two spaces and the DIRECTORY-NAMESTRING.
-
-/usr2/lisp/nhem/hunk-draw.lisp, 01-Sep-87 15:02:57, Edit by Chiles.
-  Made CURSOR-INVERT do an X:XFLUSH.
-
-/usr2/lisp/nhem/bindings.lisp, 01-Sep-87 15:00:47, Edit by Chiles.
-  Fixed merge lossage from re-integration with sources.
-
-/usr2/lisp/nhem/bindings.lisp, 28-Aug-87 17:05:12, Edit by Chiles.
-  Fixed some bindings for "Editor" mode and put them on the right page.
-
-/usr2/lisp/nhem/lispeval.lisp, 28-Aug-87 19:05:14, Edit by Chiles.
-  Fixed bug in CREATE-ANONYMOUS-CLIENT-LISP and "Select Lisp Listener".
-  Made "Set Eval Server" really define a buffer local variable when a
-  prefix was supplied.
-
-/usr1/ram/charmacs.lisp, 25-Aug-87 19:59:00, Edit by Ram
-  Flushed Alt and Oops character names.  Added Escape as a name to shadow
-  the initial Altmode name.  Added Enter and Action as alternate names for
-  Return and Linefeed.
-
-/usr1/ram/keytran.lisp, 25-Aug-87 19:44:24, Edit by Ram
-  Changed delete to translate to delete rather than oops.  Made all random
-  named keys translate to a super character when shifted.  Made keypad keys
-  always translate to super characters.
-
-/usr1/ram/bindings.lisp, 25-Aug-87 19:15:10, Edit by Ram
-  Frobbed bindings to allow rational documentation.  Case-Insensitivize now
-  translates to lowercase.  Use of Insert as an Escape standin had been
-  flushed.  Insert is now used for X cut buffer operations.  Bindings to Oops
-  have been flushed.  Interactive input kill/abort is now M-i/C-M-i.  Flushed
-  redundant extra bindings of mouse commands to super-clicks (except for S-left
-  being the same as middle).  Made S-Left and S-Right be illegal in the echo
-  area.  Made illegal upclicks do nothing so that you don't get annoying double
-  errors.  Made C-_ be a :Help character.  Flushed M-_ binding for Help and
-  Help on Parse.  Made redundant bindings to backspace and return for C-h and
-  C-m so that TTYs can win.  (Scribe mode is still wedged pending intallation
-  of the new Scribe insertion command.)  Use Delete character name instead of
-  Rubout.
-
-/usr2/lisp/nnhem/searchcoms.lisp, 24-Aug-87 09:17:00, Edit by Chiles
-  Added Chris Hoover's "List Matching Lines", "Delete Matching Lines", and
-  "Count Occurrences".  Redid page breaks.
-
-/usr2/lisp/nnhem/lispeval.lisp, 23-Aug-87 18:53:42, Edit by Chiles
-  Rewrote "Select Lisp Listener" and wrote CREATE-ANONYMOUS-CLIENT-LISP to
-  be used in the command and GET-CURRENT-SERVER.
-
-/usr2/lisp/nnhem/tty-screen.lisp, 23-Aug-87 10:15:58, Edit by Chiles
-  TTY-RANDOM-TYPEOUT-CLEANUP now calls REDISPLAY-WINDOW-ALL instead of
-  funcall'ing DEVICE-DUMB-REDISPLAY directly.
-
-/usr2/lisp/nnhem/font.lisp, 22-Aug-87 14:10:06, Edit by Chiles
-  SETF methods for changing a window's font set the hunk's trashed slot to
-  :font-change instead of t.
-
-/usr2/lisp/nnhem/window.lisp, 21-Aug-87 19:59:19, Edit by Chiles
-  Replaced numeric constants with symbolic ones.  WINDOW-CHANGED no longer
-  redisplays, but it does update the window image (recentering if current
-  window).
-
-/usr2/lisp/nhem/pane.lisp, 19-Aug-87 22:34:12, Edit by Chiles
-  Wrote OFROB-CURSOR to be the note-read-wait method for old bitmap
-  displays.  Rewrote PANE-SHOW-CURSOR.  Titled pages.  Documented cursor
-  stuff.
-
-/usr2/lisp/nhem/obit-screen.lisp, 19-Aug-87 22:28:24, Edit by Chiles
-  Added an initialization for the note-read-wait slot of the default old
-  bitmap device to #'ofrob-cursor.  OBITMAP-RANDOM-TYPEOUT-CLEANUP now
-  calls REDISPLAY-WINDOW-ALL instead of ODUMB-WINDOW-REDISPLAY.
-
-/usr2/lisp/nhem/hunk-draw.lisp, 19-Aug-87 18:53:14, Edit by Chiles
-  Rewrote HUNK-SHOW-CURSOR.  Added FROB-CURSOR.  Tweaked DROP-CURSOR and
-  LIFT-CURSOR.
-
-/usr2/lisp/nhem/bit-screen.lisp, 19-Aug-87 18:49:23, Edit by Chiles
-  Initialized note-read-wait slot of default bitmap device to #'frob-cursor
-  which is new in Hunk-Draw.Lisp.  Modified SET-WINDOW-HOOK-RAISE-FUN.  Put
-  DEFHVAR in SITE-INIT.  Removed all references to BITMAP-HUNK-LOCK.
-  Additionally modified HUNK-RESET, HUNK-EXPOSED-OR-CHANGED, and
-  HUNK-CHANGED.  HUNK-EXPOSED-OR-CHANGED now calls REDISPLAY-WINDOW-ALL
-  instead of DUMB-WINDOW-REDISPLAY.
-
-/usr2/lisp/nhem/display.lisp, 19-Aug-87 18:46:16, Edit by Chiles
-  Added device structure slot note-read-wait which is a function that
-  somehow notes on the display that input is expected.  This will simply be
-  dropping the cursor for now on the RT.  Rewrote REDISPLAY-LOOP to take a
-  window variable to bind and two forms for general window redisplay and
-  current window redisplay.  Added REDISPLAY-WINDOW, REDISPLAY-WINDOW-ALL,
-  MAYBE-UPDATE-WINDOW-IMAGE, and REDISPLAY-WINDOW-RECENTERING.  Modified
-  REDISPLAY-WINDOWS-FROM-MARK to use REDISPLAY-WINDOW-RECENTERING (which is
-  also used by REDISPLAY).
-
-/usr2/lisp/nhem/bit-display.lisp, 19-Aug-87 14:44:03, Edit by Chiles
-  Reorganized pages some: put smart redisplay structure definitions on the
-  smart window redisplay page, and retitle/titled other pages.  Did away
-  with most macros, making them functions and moving their definitions
-  below their uses.  Modified some call sites and argument passing of what
-  were macros and now are functions.  Removed code from
-  SMART-WINDOW-REDISPLAY and DUMB-WINDOW-REDISPLAY that is now encorporated
-  into the REDISPLAY and REDISPLAY-ALL loops.  Removed references and sets
-  to BITMAP-HUNK-LOCK.
-
-/usr2/lisp/nhem/obit-display.lisp, 19-Aug-87 14:44:14, Edit by Chiles
-  Moved definition of *current-font* from Bit-Display.Lisp to the only file
-  using it, this one.  Removed recenterp argument from
-  OSMART-WINDOW-REDISPLAY and ODUMB-WINDOW-REDISPLAY.  Also removed window
-  image building code from these functions since it is now taken care of
-  higher up in the redisplay calls.
-
-/usr2/lisp/nhem/tty-display-rt.lisp, 19-Aug-87 12:26:13, Edit by Chiles
-  Modified INIT-TTY-DEVICE and EXIT-TTY-DEVICE to destructively modify
-  system:*file-input-handlers*.  Now the standard input file descriptor
-  used for terminal streams is associated with an editor input handler
-  instead of the editor having its own file descriptor.
-
-/usr2/lisp/nhem/rompsite.lisp, 18-Aug-87 15:29:01, Edit by Chiles
-  Modified INIT-RAW-IO to not open the tty device.  Now, it simply assumes
-  Unix standard input.  Modified TTY-BEEP to not write to the editor's file
-  descriptor which is Unix standard input but to write to 1 (Unix standard
-  output).  Put DEFHVAR for "Set Window Autoraise" in SITE-INIT.  Modified
-  SHOW-MARK to call REDISPLAY-WINDOW instead of calling the smart redisplay
-  method out of the device.  Made editor connect handler store lisp
-  listener buffer in server-info slot.
-
-/usr2/lisp/nhem/tty-display.lisp, 18-Aug-87 15:13:41, Edit by Chiles
-  Moved INIT-TTY-DEVICE and EXIT-TTY-DEVICE to Tty-Display-Rt.Lisp.
-  Deleted code from TTY-SMART-WINDOW-REDISPLAY and
-  TTY-SEMI-DUMB-WINDOW-REDISPLAY that was folded into the REDISPLAY and
-  REDISPLAY-ALL loops.  Likewise for TTY-DUMB-WINDOW-REDISPLAY.  Also
-  deleted recenterp arguments from all these functions.
-
-/usr2/lisp/nhem/rompsite.lisp, 18-Aug-87 14:13:43, Edit by Chiles
-  Made EDITOR-TTY-IN and EDITOR-WINDOW-IN drop and lift the cursor at most
-  once, not each time SERVER is called.
-
-/usr2/lisp/nhem/vars.lisp, 18-Aug-87 13:29:37, Edit by Chiles
-  Fixed error form for GET-MODE-OBJECT to say the argument is not a defined
-  mode instead of saying NIL isn't.
-
-/usr2/lisp/nhem/buffer.lisp, 18-Aug-87 13:28:01, Edit by Chiles
-  Fixed MODE-MAJOR-P to return MODE-OBJECT-MAJOR-P instead of
-  MODE-OBJECT-NAME.
-
-/usr2/lisp/nhem/morecoms.lisp, 11-Aug-87 12:03:46, Edit by Chiles
-  JR fixed "List Buffers" to print the pathname of the buffer unless there
-  was not one or the buffer names was not derived from it.  Otherwise,
-  print the buffer name.
-
-/usr2/lisp/nhem/bindings.lisp, 30-Jul-87 15:26:08, Edit by Chiles
-  Added binding for C-M-\L to "Illegal" in "Echo Area" mode.
-
-/usr2/lisp/nhem/line.lisp, 29-Jul-87 15:28:41, Edit by Chiles
-  Rob documented the line defstruct, eliminating the chars slot in favor of
-  always having the %chars slot.  Added a macro for LINE-%CHARS instead of
-  symbol-function and symbol-plist hackery.
-
-/usr2/lisp/nhem/struct.lisp, 29-Jul-87 15:31:55, Edit by Chiles
-  Fixed documentation on COMMANDP.
-
-/usr2/lisp/nhem/echo.lisp, 28-Jul-87 16:26:44, Edit by Chiles
-  Merged some code from the Perq to fix up current buffer and window when
-  trying to confirm a non-existent parse.
-
-/usr2/lisp/nhem/bit-screen.lisp, 26-Jul-87 20:13:05, Edit by Chiles
-  Made SET-WINDOW-HOOK-RAISE-FUN look at the value of "Set Window Autoraise".
-
-/usr2/lisp/nhem/rompsite.lisp, 26-Jul-87 19:59:31, Edit by Chiles
-  Made EDITOR-SLEEP loop around SERVER using its timeout functionality
-  instead of busy looping.
-
-/usr2/lisp/nhem/lispeval.lisp, 26-Jul-87 20:04:08, Edit by Chiles
-  Made loop waiting for anonymous client lisp use EDITOR-SLEEP which loops
-  around SERVER.  Before, the client Lisp could never connect since SERVER
-  was never being called.
-
-  Wrote "Select Lisp Listener" command.
-
-/usr2/lisp/nhem/tty-display.lisp, 26-Jul-87 18:56:41, Edit by Chiles
-  Fixed display bug involving lines that are both new and changed (seen
-  often in the echo area for some reason).
-
-/usr2/lisp/nhem/filecoms.lisp, 25-Jul-87 19:37:16, Edit by Chiles
-  Fixed "Select Previous Buffer" to not call "Circulate Buffer" since it
-  doesn't exist.
-
-/usr2/lisp/nhem/macros.lisp, 25-Jul-87 18:30:59, Edit by Chiles
-  Made LISP-ERROR-ERROR-HANDLER have an E command that reports the
-  condition it was called on in a pop-up window.
-
-/usr2/lisp/nhem/lispeval.lisp, 25-Jul-87 19:28:23, Edit by Chiles
-  Made FILE-COMPILE use a temporary output file for compiler output when
-  its ouput-file argument is not t.  This temporary file is publicly
-  writeable in case the eval server is running on another machine.
-
-/usr2/lisp/nhem/edit-defs.lisp, 25-Jul-87 19:25:32, Edit by Chiles
-  Made "Go to Definition" and "Edit Definition" use the client Lisp to
-  determine where something is defined.  Had to restructure the code
-  significantly, but it can be put back to non-eval-server functionality
-  easily and cleanly.
-
-/usr2/lisp/nhem/bindings.lisp, 23-Jul-87 11:07:22, Edit by Chiles
-  Added bindings for "Process Control", "Editor Evaluate Expression", and
-  "Select Lisp Listener".
-
-Rompsite.Lisp, while doing eval-server, Edit by Chiles
-  Tty streams now loop over SERVER for input, so the eval-server stuff can
-  be used on terminals.  There are a couple new functions for connection to
-  editor servers.
-
-Lispeval.Lisp, while doing eval-server, Edit by Chiles
-  This is a new file replacing a lot of commands in Lispbuf.Lisp with
-  similar commands that use the eval server interface.  New in this file
-  from the Perq implementation is function description.
-
-Ts.Lisp, while doing eval-server, Edit by Chiles
-  This is a new file that implements the server side of the typescript
-  protocol.
-
-Morecoms.Lisp, while doing eval-server, Edit by Chiles
-  Made "Do Nothing", typically bound to up mouse clicks, propagate the last
-  command type (as if nothing happened).  This was needed to make
-  super-rightup keep the command type of super-rightdown ("Insert Kill Buffer").
-
-Keytran.Lisp, while doing eval-server, Edit by Chiles
-  Made shift-mouseclicks send super-mouseclick.
-
-Bindings.Lisp, while doing eval-server, Edit by Chiles
-  Addeds lots of new bindings and changed a few with respect to the
-  eval-server stuff going in.
-
-Bit-Screen.Lisp, while doing eval-server, Edit by Chiles
-  Fixed initial windows hook to keep echo area border visible on the screen
-  by hacking in another -2 pixels.  This might be because X has by default
-  moves windows down from the top, so the top borders will show.
-
-/usr1/ram/lispmode.lisp, 01-Jul-87 12:04:59, Edit by Ram
-  Fixed Quest-For-Balancing-Paren to use the net-open and net-close information
-  correctly.  It's silly to go to the trouble of computing this information,
-  and then (incorrectly) compute a paren balance by subtracting the two.
-
-/usr2/lisp/nhem/streams.lisp, 19-Jun-87 18:02:55, Edit by Chiles
-  Merged in some fixes from old Perq version.
-
-/usr2/lisp/nhem/lispbuf.lisp, 19-Jun-87 17:54:25, Edit by Chiles
-  Changed the following command names to be prefixed by "Editor ":
-     "Editor Evaluate Defun"
-     "Editor Re-evaluate Defvar"
-     "Editor Evaluate Expression"
-     "Editor Compile Defun"
-     "Editor Compile Region"
-     "Editor Evaluate Region"
-     "Editor Evaluate Buffer"
-     "Editor Compile File"
-     "Editor Compile Group"
-     "Editor Describe Function Call"
-     "Editor Describe Symbol".
-  Removed old reference to KILL-TOP-LEVEL-INPUT-COMMAND in "Top-Level Eval".
-
-/usr2/lisp/nhem/killcoms.lisp, 19-Jun-87 17:39:34, Edit by Chiles
-  Wrote BUFFER-MARK which is to CURRENT-MARK as BUFFER-POINT is to
-  CURRENT-POINT.
-
-/usr2/lisp/nhem/filecoms.lisp, 16-Jun-87 23:25:52, Edit by Chiles
-  Removed the definition of the "Package" file option, placing a new
-  version in Lispbuf.Lisp.
-
-/usr2/lisp/nhem/srccom.lisp, 18-Jun-87 10:23:01, Edit by Chiles
-  Made "Compare Buffers" and "Merge Buffers" only handle the current region
-  in each buffer when the prefix argument is supplied.
-
-/usr2/lisp/nhem/bindings.lisp, 16-Jun-87 14:09:20, Edit by Chiles
-  Added bindings for super-<mouseclick> characters.  Added binding for
-  "Exit Hemlock".  Added binding for "Circulate Buffer".
-
-/usr2/lisp/nhem/morecoms.lisp, 15-Jun-87 22:18:26, Edit by Chiles
-  Made "Do Nothing" set the last command type to its current value.
-  Added "Insert Kill Buffer".
-
-/usr2/lisp/nhem/echocoms.lisp, 15-Jun-87 13:47:15, Edit by Chiles
-  Made "Help on Parse" check for *parse-help* being nil.
-
-/usr2/lisp/nhem/bit-screen.lisp, 08-Jun-87 12:20:39, Edit by Chiles
-  Modified DEFAULT-CREATE-INITIAL-WINDOWS-HOOK to added in a couple more
-  border widths, so the echo area's bottom border is visible.
-
-*************************
-
-/usr1/lisp/hemlock/rompsite.lisp, 03-Jun-87 10:09:24, Edit by DBM.
-  All references to the accint package have been changed to Mach.
-
-/usr1/lisp/hemlock/obit-screen.lisp, 03-Jun-87 10:05:34, Edit by DBM.
-  All references to the accint package have been changed to Mach.
-
-/usr2/lisp/nhem/tty-display.lisp, 01-Jun-87 21:25:15, Edit by Chiles
-  Modified TTY-SMART-WINDOW-REDISPLAY to punt insert/delete line
-  optimizations in favor of redrawing every altered line when "Scroll
-  Redraw Ratio" is exceeded.
-
-/usr2/lisp/nhem/command.lisp, 01-Jun-87 21:12:21, Edit by Chiles
-  "Scroll Redraw Ratio" is a new Hemlock variable that controls the
-  abortion of insert/delete line optimization in terminal redisplay in
-  favor of redrawing all altered lines.  This is used in Tty-Display.Lisp.
-
-/usr2/lisp/nhem/tty-display.lisp, 27-May-87 14:38:50, Edit by Chiles
-  Wrote TTY-SMART-CLEAR-TO-EOW to use the internal screen image instead of
-  TTY-SEMI-DUMB-WINDOW-REDISPLAY and TTY-SMART-WINDOW-REDISPLAY using the
-  clear-to-eow method that clears every line disregarding internal
-  information.
-
-/usr2/lisp/nhem/rompsite.lisp, 26-May-87 16:14:27, Edit by Chiles
-  Modified EDITOR-TTY-IN to detect lowercase control g's.
-
-/usr2/lisp/nhem/bit-screen.lisp, 25-May-87 17:40:30, Edit by Chiles
-  Modified arguments to X window event handlers as per the changes in
-  X.Lisp.
-
-/usr1/ram/spellcoms.lisp, 22-May-87 04:02:19, Edit by Ram
-  Fixed Fix-Word to bump the mark in the all uppercase case even when the word
-  is already in the hashtable.
-
-/usr1/ram/echo.lisp, 14-May-87 13:07:07, Edit by Ram
-  Changed Message to use displayed-p on the buffer end to tell whether the echo
-  area needs to be cleared rather than just counting the lines.  This works
-  much better in the presence of wrapped lines.
-
-/usr1/ram/cursor.lisp, 14-May-87 13:02:09, Edit by Ram
-  Changed renamed Display-P to %Displayed-P, and wrote Displayed-P which does
-  an update-window-iamge before calling %Displayed-P.
-
-/usr2/lisp/xhem/xcommand.lisp, 12-May-87 16:00:16, Edit by Chiles
-  This is a new file of X specific commands.  Currently it only contains
-  "Insert Cut Buffer" and "Region to Cut Buffer".
-
-/usr2/lisp/xhem/keyboard_codes.lisp, 12-May-87 15:55:42, Edit by Chiles
-  Modified some translations to work better with the new key bindings.
-
-/usr2/lisp/xhem/lispbuf.lisp, 12-May-87 14:43:15, Edit by Chiles
-  Added "List Compile File" and "Re-evaluate Defvar".
-
-/usr2/lisp/xhem/command.lisp, 12-May-87 14:07:11, Edit by Chiles
-  Modified "Self Insert" and "Quoted Insert" to handler new TEXT-CHARACTER
-  in Rompsite.Lisp.
-
-/usr2/lisp/xhem/morecoms.lisp, 12-May-87 14:01:29, Edit by Chiles
-  Made "List Buffers" on a prefix argument list only modified buffers.
-
-/usr2/lisp/xhem/main.lisp, 12-May-87 12:55:51, Edit by Chiles
-  Stopped ED from calling REDISPLAY-ALL when the editor has been entered
-  already and moved this into the device init methods that require this.
-
-/usr2/lisp/xhem/lispmode.lisp, 12-May-87 12:53:32, Edit by Chiles
-  Blasted a couple bogus type declarations on some DEFSTRUCT slots.
-  Inserted a few lines to LISP-INDENTATION from my init file.
-
-/usr2/lisp/xhem/indent.lisp, 12-May-87 12:48:29, Edit by Chiles
-  Replaced a couple SCAN-CHAR and REV-SCAN-CHAR uses with FIND-ATTRIBUTE
-  and REVERSE-FIND-ATTRIBUTE, so compilation in a Lisp without Hemlock
-  wouldn't lose.
-
-/usr2/lisp/xhem/filecoms.lisp, 12-May-87 12:42:08, Edit by Chiles
-  Renamed "New Window" to "Split Window", and made "New Window" prompt the
-  user for a window.
-
-/usr2/lisp/xhem/charmacs.lisp, 12-May-87 12:24:05, Edit by Chiles
-  Modified character name a-list.  Rob Flushed addition of the command-bits
-  feature and added the all-bit-names constant. 
-
-/usr2/lisp/xhem/window.lisp, 12-May-87 11:47:35, Edit by Chiles
-  This contains the stuff we still need from Owindow.Lisp and some new
-  stuff brought over from the Perq.
-
-/usr2/lisp/xhem/tty-screen.lisp, 12-May-87 11:43:55, Edit by Chiles
-  Modified to fit the new device independent structure, adding beep and
-  finish-output methods.  Creating and Deleting window methods now set
-  *screen-image-trashed since not all devices need this.  Random typeout
-  methods got an extra argument that we ignore.
-
-/usr2/lisp/xhem/struct.lisp, 12-May-87 11:37:25, Edit by Chiles
-  Modified window, dis-line, and font structures.  When the old bitmap
-  stuff goes away, so will a few slots of windows.  Also, some old setf
-  stuff for old font information will go away.
-
-/usr2/lisp/xhem/screen.lisp, 12-May-87 11:34:06, Edit by Chiles
-  Modified to be once-again device independent with respect to the addition
-  of Hemlock running under X windows.  MAKE-WINDOW and DELETE-WINDOW no
-  longer set *screen-image-trashed* since this isn't necessary for all
-  devices.
-
-/usr2/lisp/xhem/rompsite.lisp, 12-May-87 00:56:01, Edit by Chiles
-  SITE-INIT is all new and defines some Hemlock variables for controlling
-  some of the X activity.  INIT-RAW-IO is much bigger now for initializing
-  stuff when we are running under X.  *editor-windowed-input* is set to t
-  when we are running under X, and WINDOWED-MONITOR-P returns the value of
-  this variable for use is other files.  
-
-  BEEP was moved to Code:Machio.Lisp, and there's a couple different
-  beeping methods in here now that get called as a result of
-  *beep-function* being bound by SITE-WRAPPER-MACRO.  HEMLOCK-WINDOW calls
-  *hemlock-window-mngt* when *current-window* is bound, which happens going
-  in and out of Hemlock.
-
-  The X scan code translation mechanism lives here, but the initialization
-  is in Keytran.Lisp.  Terminal translation now downcases control
-  characters to interact more smoothly with the new Hemlock key translation
-  and binding scheme.
-
-  There are now different types of editor input streams that all a head and
-  tail pointer into an input queue of events.  One is used for terminals
-  and flat bitmap screens, and the other uses SERVER for windowed input
-  under X.  TEXT-CHARACTER is new and now more correct.
-
-  There is a page of X support: getting a Hemlock cursor, setting up a grey
-  pixmap for border frobbing, cut buffer manipulation, and naming windows.
-
-/usr2/lisp/xhem/owindow.lisp, 12-May-87 00:52:54, Edit by Chiles
-  This file used to be Window.Lisp.  It now contains only the old bitmap
-  related code for setting up a windows image.
-
-/usr2/lisp/xhem/ofont.lisp, 12-May-87 00:51:35, Edit by Chiles
-  This file used to be Font.Lisp.  It now contains only the few things
-  necessary for old bitmap font interfacing.
-
-/usr2/lisp/xhem/obit-screen.lisp, 12-May-87 00:43:50, Edit by Chiles
-  This file used to be Screen-Bit.Lisp.  Shared stuff has been moved to
-  the new file by the old name.  Window creation and deletion methods now
-  set *screen-image-trashed* since this is not meaningful across all
-  devices.
-
-/usr2/lisp/xhem/obit-display.lisp, 12-May-87 00:40:35, Edit by Chiles
-  This file used to be Bit-Display.Lisp.  Shared stuff has been moved to
-  the new file by the old name.
-
-/usr2/lisp/xhem/macros.lisp, 12-May-87 00:35:30, Edit by Chiles
-  WITH-RANDOM-TYPEOUT has been modified to handle new termination
-  functionality involved with running Hemlock under X.
-  LISP-ERROR-ERROR-HANDLER no longer calls REDISPLAY after returning from a
-  BREAK.  This is the responsibility of the device's init method if it is
-  necessary.
-
-/usr2/lisp/xhem/keytran.lisp, 12-May-87 00:30:18, Edit by Chiles
-  This is a new file.  It contains the initialization of the keyboard
-  translations for Hemlock running under X.  These were too numerous to
-  leave in Rompsite since there is no hack for generating the translations.
-
-/usr2/lisp/xhem/hunk-draw.lisp, 12-May-87 00:28:02, Edit by Chiles
-  This is a new file, a kin to Pane.Lisp.  It contains screen painting
-  routines for Hemlock running under X windows.  This includes cursor and
-  border manipulation.
-
-/usr2/lisp/xhem/font.lisp, 12-May-87 00:12:10, Edit by Chiles
-  This is a new file, replacing the currently named Ofont.Lisp.  It
-  contains the pseudo-independent Hemlock font information implementation.
-  This includes stuff particular for running Hemlock under X windows and
-  stuff that is used by the other bitmap redisplay/screen manager code.
-
-/usr2/lisp/xhem/display.lisp, 12-May-87 00:09:23, Edit by Chiles
-  The device structure has been modified to handle new methods, such as
-  beeping and finishing output.  The device-clear method is now optional.
-  The entry points into redisplay have been modified to encorporate the
-  needs of Hemlock running under X windows.
-
-/usr2/lisp/xhem/bit-screen.lisp, 11-May-87 23:16:26, Edit by Chiles
-  This is a new file, replacing the currently named Obit-Screen.Lisp.  It
-  contains the event handlers for selected events on Hemlock windows, the
-  screen management methods for Hemlock running under X windows, the random
-  typeout methods, and screen manager initialization.
-
-/usr2/lisp/xhem/bit-hunk-stream.lisp, 11-May-87 22:43:36, Edit by Chiles
-  This is a new file.  It contains the bitmap-hunk-output-stream structure
-  definition and the associated methods.  This is used for random typeout.
-
-/usr2/lisp/xhem/bit-display.lisp, 11-May-87 22:38:47, Edit by Chiles
-  This is a new file, replacing the currently named Obit-Display.Lisp.  It
-  contains the bitmap-hunk structure and the X related redisplay methods.d 
-
-/usr1/ram/cursor.lisp, 08-May-87 05:02:09, Edit by Ram
-  Totally rewrote dis-line-offset-guess, making it dramatically simpler and
-  more correct by making it do only what is needed for the scrolling functions,
-  rather than attempting to make it preserve position within the line.
-
-/../chiles/usr/lisp/hemlock/bindings.lisp, 29-Apr-87 23:33:27, Edit by Ram
-  Massively revised bindings now that we have key-translations and a real meta
-  key.  C-Z and Escape are now handled as bit-prefix characters, so all
-  explicit bindings containing these have been flushed.  Key translations are
-  used to make things case-insensitive, so duplicate bindings for different
-  case have been flushed.
-
-  All the C-<punctuation>/Escape <punctuation> bindings pairs have been
-  replaced with M-<punctuation>.  This is the main user-interface change.  Also
-  the commands previously bound to C-Z M-<char> have been rebound to C-M-<CHAR>
-  (i.e. control meta shift).  This is necessary since C-Z M-<char> is just
-  C-M-<char> due to the bit prefix mechanism.  We selectively flush the
-  uppercasing translation for the control meta chars used in this way.
-
-  In a more rt-specific change, uses of Help have been replaced with Home.
-
-/usr/ram/interp.lisp, 30-Apr-87 00:36:04, Edit by Ram
-  New Key-Translation mechanism replaces key links.  A key translation
-  specifies a substitution that is done one key arguments to the bindings
-  functions.  When the translated-from key appears as a subsequence of the key
-  to be translated, that subsequence is replaced with the translation.  There
-  is also a mechanism for defining bit-prefix characters.
-
-  The key-table code has been changed a fair amount.  Key-tables are now
-  structures.  The conditionalization off of the commands-bits feature has been
-  flushed.  Keys are no longer internally assumed to be simple-vectors so that
-  we can use vectors with fill-pointers as internal buffers.
-
-  Also put in a few doc strings and made crunch-key allow any seqence and check
-  that the components are characters.  The type check was in the PERQ version
-  but got lost.
-
-/usr/ram/spellcoms.slisp, 12-Apr-87 10:57:44, Edit by Ram
-  Fixed Spell-Replace-Word not to consider words beginning with #\' to be
-  capitalized.
-
-/../wb1/usr/chiles/nhem/lispmode.slisp, 04-Apr-87 22:44:36, Edit by Chiles
-  Modified "Transpose Forms" such that
-     (form1)       ;comment
-     (form2)
-  became
-     (form2)       ;comment
-     (form1)
-  instead of
-     ;comment
-     (form2)       (form1)
-
-/../wb1/usr/chiles/nhem/tty-display.slisp, 26-Mar-87 18:51:40, Edit by Chiles
-  Fixed bug in TTY-SEMI-DUMB-WINDOW-REDISPLAY and
-  TTY-SMART-WINDOW-REDISPLAY that came up when writing the modeline.  Put
-  in an UNWIND-PROTECT around TTY-SMART-LINE-REDISPLAY since it can throw
-  out of redisplay leaving the terminal in standout mode.
-
-/../wb1/usr/chiles/nhem/htext1.slisp, 26-Mar-87 18:10:15, Edit by Chiles
-  Modified MODIFYING-BUFFER to invoke new "Buffer Modified Hook" when the
-  buffer went from unmodified to modified.
-
-/../wb1/usr/chiles/nhem/main.slisp, 26-Mar-87 17:49:12, Edit by Chiles
-  Added definition for "Buffer Modified Hook" and changed definition for
-  "Default Modeline String".
-
-/../wb1/usr/chiles/nhem/window.slisp, 26-Mar-87 17:37:32, Edit by Chiles
-  Made %INIT-REDISPLAY add QUEUE-BUFFER-CHANGES to new "Buffer Modified Hook".
-  Made DEFAULT-MODELINE-FUNCTION-FUNCTION return one more value, whether
-  the buffer is modified.
-
-/../wb1/usr/chiles/nhem/buffer.slisp, 26-Mar-87 18:14:08, Edit by Chiles
-  Made %SET-BUFFER-MODIFIED to invoke new "Buffer Modified Hook" on sense.
-
-/usr1/ram/group.slisp, 20-Mar-87 14:10:56, Edit by Ram
-  Changed the "Group Search" commands to feel more like the "Query Replace"
-  commands.  :Yes now exits instead of skipping, skipping is moved to :No and
-  skipping the rest of the file is move to :Do-All.
-
-/usr/ram/searchcoms.slisp, 19-Mar-87 00:04:09, Edit by Ram
-  Changed query-replace-function to set up the search pattern itself.  Also
-  made it error if the count is specified and negative, rather than trying to
-  do replacement backwards and getting it wrong.  Also restore the search
-  pattern after a recursive edit.
-
-/usr/ram/group.slisp, 19-Mar-87 00:31:13, Edit by Ram
-  Fixed up a bunch of things.  Indirect filespecs are parsed normally; it is no
-  longer assumed that the rest of the line is the name of the file.  The
-  default file name is no longer capitalized.  Temporary search buffers are no
-  longer renamed to "Group Search", making exiting from searches more
-  well-defined.  "Group Search" restores the search pattern after a recursive
-  edit.
-
-/usr/lisp/nhem/lispmode.slisp, 12-Mar-87 16:05:30, Edit by Chiles
-  Rewrote TOP-LEVEL-OFFSET to be correct and to not move the mark unless it
-  could really do the offset.  Modified INSIDE-DEFUN-P to not return t when
-  point is between a top level form and the beginning of the buffer.  Added
-  START-DEFUN-P to be used in heavily modified versions of "End of Defun"
-  and "Mark Defun" commands.
-
-/../wb1/usr/chiles/nhem/lispmode.slisp, 03-Mar-87 17:33:05, Edit by Chiles
-  Fixed LISP-INDENTATION to do a "generic" indent instead of simply
-  returning 0.  This fixes doc strings.
-
-/../wb1/usr/chiles/nhem/indent.slisp, 27-Feb-87 14:18:59, Edit by Chiles
-  Fixed "Indent" command to only affect argument number of lines (instead
-  of one too many) when the prefix argument is supplied.  Rewrote
-  INDENT-REGION-FOR-COMMANDS to be much simpler, fixing a couple
-  irritatingly buggy special cases.
-
-/../wb1/usr/chiles/nhem/fill.slisp, 27-Feb-87 12:18:50, Edit by Chiles
-  Fixed "Fill Paragrah" command's undoability.  When a prefix was added to
-  the first line, it was ignored by the undo region do to a :left-inserting
-  mark.
-
-/usr1/ram/text.slisp, 23-Feb-87 11:00:53, Edit by Ram
-  The "Paragraph Delimiter Function" variable is now used to determine whether
-  a line is a paragraph break.  This is used by Scribe mode.
-
-/usr1/ram/spellcoms.slisp, 23-Feb-87 10:52:18, Edit by Ram
-  "Spell Correct Unique Spelling Immediately" (on by default) causes an unknown
-  word with only one correction to be corrected immediately in auto-spell mode,
-  rather than requiring "Correct Last Misspelled Word" to be done.
-
-  The "Undo Last Spelling Correction" command undoes the last incremental
-  spelling correction and places the word in the dictionary.
-
-  "Spell Ignore Uppercase" (off by default) causes all-uppercase unknown words
-  to be ignored.
-
-/usr1/ram/defsyn.slisp, 23-Feb-87 10:50:01, Edit by Ram
-  Changed definition of "Lisp Syntax" attribute for new Lisp mode primitives.
-
-/usr1/ram/lispbuf.slisp, 23-Feb-87 10:48:54, Edit by Ram
-  Changed to use new Lisp mode primitives. 
-
-/usr1/ram/htext1.slisp, 23-Feb-87 10:19:19, Edit by Ram
-  Deleted old line-plist support.  The user directly accesses the Plist slot
-  now that he is responsible for keeping treack of when it changes. 
-
-/usr1/ram/line.slisp, 23-Feb-87 10:17:30, Edit by Ram
-  Merged in code to implement the documented line-plist/line-signature
-  semantics.  This code somehow never got merged in from the PERQ version.
-
-/usr1/ram/scribe.slisp, 20-Feb-87 16:25:07, Edit by Ram
-  A real Scribe mode.  Has general bracket balancing, and knows about paragraph
-  boundaries.  Also various commands for inserting Scribe directives bound to
-  C-H mumble.
-
-/usr1/ram/bindings.slisp, 20-Feb-87 14:22:45, Edit by Ram
-  New bindings for "Undo Last Spelling Correction" and Scribe mode commands.
-
-/usr1/ram/lispmode.slisp, 18-Feb-87 11:42:22, Edit by Ram
-  New Lisp mode primitives, courtesy of Ivan (Crash and burn like an unblanced
-  paren Vazquez.  These primitives know about Lisp commenting and quotation
-  conventions, and ignoring meaningless parens and quotes.  This is done by
-  pre-parsing the lines in the buffer, annotating them with information about
-  the quoted areas on the line.  Forward-Form and Backward-Form are gone,
-  replaced by Form-Offset.  Similarly, Forward-List and Backward-List are
-  replaced by List-Offset.
-
-  All users of these Lisp parsing primitives must call Pre-Command-Parse-Check
-  or equivalent to ensure that the buffer is properly annotated.  This function
-  calls the values of "Parse Start Function" and "Parse End Function" to
-  determine the area of the buffer to parse.  The default parse start and end
-  functions use "Minimum Lines Parsed", "Maximum Lines Parsed" and
-  "Defun Parse Goal" to determine how much stuff to parse.
-
-  I also reimplemented Lisp indentation.  Other than general cleanup, use of
-  newly avilable syntax information, and bug fixes, the major changes are:
-   -- Unless there is a reason otherwise, indentation for a form will be copied
-      from the previous form.
-   -- If no special args appear on the same line with the form name, then the
-      special args are indented four spaces.  This is useful with
-      Unwind-Protect and Multiple-Value-Bind.
-   -- DEFxxx is now uniformly treated as a two-arg special form, rather than
-      being bizzarely special-cased.  "Indent Defanything" controls this
-      behavior.
-   -- Lines in the middle of a quoted string are not indented, rather than
-      being indented as though they were lines of code.  This eliminates
-      spurious whitespace in multi-line strings.
-
-/usr/lisp/hemlock/termcap.slisp, 17-Feb-87 12:04:32, Edit by Chiles
-  Made GET-TERMCAP handle TERMCAP environment variable.
-
-/usr/lisp/hemlock/rompsite.slisp, 17-Feb-87 11:48:16, Edit by Chiles
-  Modified SITE-WRAPPER-MACRO to call init/exit methods out of the device.
-  EDITOR-LISTEN now loops a parameter number of times which can be set when
-  using a slow line to make sure the editor listens for input before
-  wasting redisplay effort.
-
-/usr/lisp/hemlock/tty-display.slisp, 16-Feb-87 17:05:01, Edit by Chiles
-  Added "semi dumb" terminal redisplay.  This is used for terminals without
-  add line and delete line.  Made INIT-TTY-DEVICE (renamed) and
-  EXIT-TTY-DEVICE (renamed) call standard init/exit function from
-  Rompsite.Slisp.
-
-/usr/lisp/hemlock/macros.slisp, 14-Feb-87 01:33:08, Edit by Chiles
-  Made LISP-ERROR-ERROR-HANDLER call init/exit methods out of the device
-  when going in and out of Hemlock.
-
-/usr/lisp/hemlock/bit-screen.slisp, 14-Feb-87 01:08:15, Edit by Chiles
-  Added INIT-BITMAP-DEVICE and EXIT-BITMAP-DEVICE.  Now whenever the editor
-  is exited or entered there is a method to be called in the device
-  structure.
-
-/usr/lisp/hemlock/main.slisp, 14-Feb-87 00:27:47, Edit by Chiles
-  Made ED reflect new SITE-WRAPPER-MACRO in Rompsite.Slisp.
-
-/usr/lisp/hemlock/tty-screen.slisp, 14-Feb-87 00:13:44, Edit by Chiles
-  Modified MAKE-DEVICE to reflect new "semi dumb" redisplay ability.
-
-/usr/lisp/hemlock/rompsite.slisp, 12-Feb-87 13:02:40, Edit by DBM.
-  A bug in get-editor-input was causing Hemlock to drop characters.
-  There used to be a (setq *events* before the (rplacd (last *events*...
-
-/usr/lisp/hemlock/rompsite.slisp, 10-Feb-87 15:58:23, Edit by DBM.
-  Modified all the unix package specifiers to be mach.
-
-/usr/lisp/hemlock/tty-display-rt.slisp, 10-Feb-87 15:54:04, Edit by DBM.
-  Modified all the unix package specifiers to be mach.
-
-/usr/lisp/hemlock/spell-rt.slisp, 10-Feb-87 15:52:41, Edit by DBM.
-  Modified all the unix package specifiers to be mach.
-
-/usr/lisp/hemlock/macros.slisp, 10-Feb-87 15:51:58, Edit by DBM.
-  Modified all the unix package specifiers to be mach.
-
-/usr/lisp/hemlock/files.slisp, 10-Feb-87 15:49:03, Edit by DBM.
-  Modified all the unix package specifiers to be mach.
-
-/usr/lisp/hemlock/rompsite.slisp, 14-Jan-87 14:20:03, Edit by DBM.
-  Wrapped a catch of redisplay-catcher around the redisplay form
-  in show-mark -- otherwise sometimes a bad throw would happen.
-
-/usr/lisp/hemlock/rompsite.slisp, 14-Jan-87 14:05:30, Edit by DBM.
-  Export pause-hemlock, so that the command works.
-
-/usr/lisp/hemlock/tty-hunk-stream.slisp, 14-Jan-87 11:58:52, Edit by Chiles
-  Fixed scrolling for random typeout -- forgot to local variable to line 0
-  TTY-HUNK-STREAM-NEWLINE.
-
-/usr/lisp/hemlock/bit-screen.slisp, 13-Jan-87 16:45:31, Edit by DBM.
-  Modified bitmap-make-window so that it creates a bitmap-hunk
-  instead of device-hunk to describe the device.  Also added the
-  arguments :device, :text-pane, and :modeline-pane to the call.
-
-/usr/lisp/hemlock/macros.slisp, 12-Jan-87 12:56:43, Edit by DBM.
-  Changed device-random-output-stream to device-random-typeout-stream.
-
-/usr/lisp/hemlock/tty-screen.slisp, 11-Jan-87 17:03:35, Edit by Chiles
-  This is a new file.  It contains terminal screen management
-  initialization, device methods for window operations, and device methods
-  for random typeout.
-
-/usr/lisp/hemlock/tty-hunk-stream.slisp, 11-Jan-87 16:58:52, Edit by Chiles
-  This is a new file.  It contains stream-hunk and tty-hunk-stream
-  structure definitions and stream operations.  This is used for random
-  typeout.
-
-/usr/lisp/hemlock/tty-display.slisp, 10-Jan-87 15:35:09, Edit by Chiles
-  This is a new file.  It contains terminal device structures, hunk
-  structures, and other structures needed for terminal redisplay methods.
-
-/usr/lisp/hemlock/tty-display-rt.slisp, 31-Dec-86 01:12:12, Edit by Chiles
-  This is a new file.  It contains RT specific, terminal redisplay code.
-
-/usr/lisp/hemlock/termcap.slisp, 11-Jan-87 16:36:33, Edit by Chiles
-  This is a new file.  It contains code for building a representation of
-  terminal capabilities from Unix termcap files.
-
-/usr/lisp/hemlock/screen.slisp, 11-Jan-87 16:30:31, Edit by Chiles
-  This is a new file.  The previous contents are now in Bit-Screen.Slisp --
-  see log entry below.  This file contains new %INIT-SCREEN-MANAGER,
-  PREPARE-FOR-RANDOM-TYPEOUT, and RANDOM-TYPEOUT-CLEANUP functions, and it
-  contains new window operations that dispatch off the device structure --
-  MAKE-WINDOW, NEXT-WINDOW, PREVIOUS-WINDOW, and DELETE-WINDOW.
-
-/usr/lisp/hemlock/rompsite.slisp, 11-Jan-87 16:06:26, Edit by Chiles
-  Organized file into logical partitions with page markers.  Added
-  *editor-console-input* to be used in GET-EDITOR-INPUT, which should go
-  away when we are on a window system -- maybe a device method for
-  translating input characters or even getting them.  Modified INIT-RAW-IO
-  to set *editor-console-input*.  Modified SITE-WRAPPER-MACRO, so it does
-  not signal an error if it cannot find a bitmap device.  Added terminal
-  character translation tables and TTY-TRANSLATE-CHAR.  Added
-  SLEEP-FOR-TIME to be used in input stuff and SHOW-MARK.  Rewrote
-  SHOW-MARK code to dispatch off of device.  Added functions CONSOLEP and
-  GET-TERMINAL-NAME for use in Screen.Slisp.  Modified BUILD-HEMLOCK to be
-  consistent with new files.
-
-/usr/lisp/hemlock/main.slisp, 11-Jan-87 16:00:36, Edit by Chiles
-  Modified ED to call any device init or exit function going in or out of
-  ED.
-
-/usr/lisp/hemlock/display.slisp, 11-Jan-87 14:35:16, Edit by Chiles
-  This is a new file.  The previous contents are now in Bit-Display.Slisp --
-  see log entry below.  This file contains device structure definitions for
-  redisplay methods and device-hunk structure definitions for claiming
-  areas of the screens.  It contains the entry points into redisplay.
-
-/usr/lisp/hemlock/bit-screen.slisp, 11-Jan-87 15:03:07, Edit by Chiles
-  Created from old Screen.Slisp.  Removed functions MAKE-WINDOW,
-  NEXT-WINDOW, PREVIOUS-WINDOW, DELETE-WINDOW, PREPARE-FOR-RANDOM-TYPEOUT,
-  and RANDOM-TYPEOUT-CLEANUP putting them in the new Screen.Slisp.  Added
-  bitmap device funs, bitmap-hunk structure definition, new initialization
-  function for bitmap screen management, new bitmap window operation
-  methods (make, delete, next, previous), and new random typeout setup and
-  cleanup for bitmaps.  Deleted screen-hunk structure definition.
-
-/usr/lisp/hemlock/bit-display.slisp, 11-Jan-87 14:50:38, Edit by Chiles
-  Created file from old Display.Slisp.  Removed functions REDISPLAY,
-  REDISPLAY-ALL, and REDISPLAY-WINDOWS-FROM-MARK putting them in the new
-  Display.Slisp.
-
-/usr/lisp/hemlock/window.slisp, 28-Dec-86 21:46:17, Edit by Chiles
-  Modified %REDISPLAY-INIT to initialize the device before calling
-  REDISPLAY-ALL.
-
-/usr/lisp/hemlock/macros.slisp, 18-Dec-86 17:14:25, Edit by Chiles
-  Rewrote WITH-RANDOM-TYPEOUT to grab the random typeout stream from the
-  device structure gotten from the current window.
-
-/usr/slisp/hemlock/macros.slisp, 22-Oct-86 22:11:22, Edit by Chiles
-  Error-error handler calls BREAK on the condition instead of the string
-  "Hemlock Debug".
-
-/usr/slisp/hemlock/rompsite.slisp, 22-Oct-86 22:01:22, Edit by Chiles
-  Setup for spell files.
-
-/usr/slisp/hemlock/spell-build.slisp, 22-Oct-86 17:48:02, Edit by Chiles
-/usr/slisp/hemlock/spellcoms.slisp, 22-Oct-86 17:47:04, Edit by Chiles
-/usr/slisp/hemlock/spell-augment.slisp, 22-Oct-86 17:46:21, Edit by Chiles
-/usr/slisp/hemlock/spell-correct.slisp, 22-Oct-86 17:45:29, Edit by Chiles
-  The spelling correction stuff has been rewritten substantially.  This is
-  the RT implementation.  These files should be implementation independent,
-  modulo their use of Spell-Rt.Slisp.  
-
-/usr/slisp/hemlock/spell-rt.slisp, 22-Oct-86 17:38:27, Edit by Chiles
-  Created this file to contain implementation dependent spelling code.
-
-/usr/slisp/hemlock/bindings.slisp, 22-Oct-86 17:35:48, Edit by Chiles
-  Used the new DO-ALPHA-CHARS macro from Charmacs.Slisp to do key linking.
-  Also, uncommented the spelling bindings.
-
-/usr/slisp/hemlock/edit-defs.slisp, 11-Oct-16 16:56:45, Edit by Chiles
-  Created this file to contain the stuff just removed from Lispmode.Slisp.
-
-/usr/slisp/hemlock/lispmode.slisp, 10-Oct-16 12:53:41, Edit by Chiles
-  Rewrote GET-DEFINITION-FILE to match longer, more specific directory
-  specification before matching shorter, less specific specifications.
-  Before it only matched whole directory namestrings.
-
-  Removed all of the definition editing code form Lispmode.slisp.
-
-/sys/slisp/hemlock/echo.slisp#1, 08-Sep-86 01:15:37, Edit by Chiles
-/sys/slisp/hemlock/macros.slisp#1, 08-Sep-86 01:15:37, Edit by Chiles
-  Made error handling stuff use the new error system.
-
-/sys/slisp/hemlock/morecoms.slisp#1, 27-Aug-86 10:51:27, Edit by Chiles
-  Modified "View Page Directory" and "Insert Page Directory" to be smarter
-  when creating a pop-up window and to be more general with respect to a
-  :page-delimiter character that is not also a :whitespace character.
-
-/sys/slisp/hemlock/filecoms.slisp#1, 26-Aug-86 16:18:09, Edit by Chiles
-  Modified WRITE-DA-FILE to display the buffer's name when prompting about
-  tacking a newline at the end of the file.
-
-/sys/slisp/hemlock/filecoms.slisp#1, 05-Aug-86 18:17:17, Edit by Chiles
-  Added *buffer-history-ptr* and modified "Select Previous Buffer" to walk
-  down *buffer-history* (when called repeatedly with an argument), selecting
-  successively previous buffers while leaving *buffer-history* unchanged.
-
-/sys/slisp/hemlock/Bindings.slisp#1, 26-Jul-86 10:57:47, Edit by Chiles
-  Added bindings:
-     (bind-key "Kill Previous Word" #\meta-backspace)
-     (bind-key "Echo Area Kill Previous Word" #\meta-backspace)
-     (bind-key "Complete Keyword" #\altmode :mode "Echo Area")
-  The last one is added in case you hit Esc, see nothing happened, and hit
-  it again.  It doesn't hurt to bind this even if you have to hit Esc Esc
-  to get it to work.
-
-/sys/slisp/hemlock/lispmode.slisp#1, 25-Jul-86 11:49:43, Edit by Chiles
-  Fixed bug involving a comment starting after a function name and the
-  first argument being lined up with the comment instead of under the
-  function name; for example:
-     (cond (special-arg-p ; comment this cond branch
-                          (first-thing-in-branch arg)
-			  ...)
-     becomes
-     (cond (special-arg-p ; comment this cond branch
-            (first-thing-in-branch arg)
-	    ...)
-  Note, this is somewhat kludged since a #|...|# comment will still
-  generate bogus indentation, but the whole LISP-INDENTATION algorithm
-  needs to be revamped anyway.
-
-/sys/slisp/hemlock/lispmode.slisp#1, 24-Jul-86 13:22:30, Edit by Chiles
-  "End of Defun" never worked since it was believed that MARK-AFTER was
-  enough to cause NEXT-TOP-LEVEL to move its argument mark, but actually
-  the use of LINE-OFFSET is required.
-
-/sys/slisp/hemlock/lispmode.slisp#1, 23-Jul-86 10:20:29, Edit by Chiles
-  Made LISP-INDENTATION check that the paren was on the start of a line
-  before doing the "DEF" hack with *indent-defanything*.
-
-/sys/slisp/hemlock/echo.slisp#1, 15-Jul-86 12:10:21, Edit by Chiles
-  Missed :trim argument to PROMPT-FOR-STRING while merging.
-
-08-Jul-86
-  Merged most of Hemlock's changes on the Perq since the fall of 85.
-  Didn't try to pick up anything having to do with the eval server/
-  two Lisps.  The files things were taken from were:
-       abbrev.slisp
-       bindings.slisp
-       command.slisp
-       comments.slisp        
-       echo.slisp
-       filecoms.slisp
-       fill.slisp
-       group.slisp
-       indent.slisp
-       kbdmac.slisp
-       killcoms.slisp
-       lispbuf.slisp
-       lispeval.slisp
-       lispmode.slisp
-       main.slisp
-       morecoms.slisp
-       overwrite.slisp
-       perqsite.slisp
-       scribe.slisp
-       searchcoms.slisp
-       text.slisp
-       undo.slisp
-       vars.slisp
-       window.slisp
diff --git a/hemlock/hemlock.upd b/hemlock/hemlock.upd
deleted file mode 100644
index 52faa0c642185bfc3b7e4121fe070082b281cafd..0000000000000000000000000000000000000000
--- a/hemlock/hemlock.upd
+++ /dev/null
@@ -1,104 +0,0 @@
-struct.lisp
-struct-ed.lisp
-rompsite.lisp
-charmacs.lisp
-key-event.lisp
-keysym-defs.lisp
-input.lisp
-macros.lisp
-line.lisp
-ring.lisp
-table.lisp
-htext1.lisp
-htext2.lisp
-htext3.lisp
-htext4.lisp
-search1.lisp
-search2.lisp
-linimage.lisp
-cursor.lisp
-syntax.lisp
-winimage.lisp
-hunk-draw.lisp
-@!bit-stream.lisp
-termcap.lisp
-display.lisp
-bit-display.lisp
-tty-disp-rt.lisp
-tty-display.lisp
-@!tty-stream.lisp
-pop-up-stream.lisp
-screen.lisp
-bit-screen.lisp
-tty-screen.lisp
-window.lisp
-font.lisp
-interp.lisp
-vars.lisp
-buffer.lisp
-files.lisp
-streams.lisp
-echo.lisp
-main.lisp
-echocoms.lisp
-defsyn.lisp
-command.lisp
-morecoms.lisp
-undo.lisp
-killcoms.lisp
-searchcoms.lisp
-filecoms.lisp
-indent.lisp
-lispmode.lisp
-comments.lisp
-fill.lisp
-text.lisp
-doccoms.lisp
-srccom.lisp
-group.lisp
-spell-rt.lisp
-spell-corr.lisp
-spell-aug.lisp
-spell-build.lisp
-spellcoms.lisp
-abbrev.lisp
-overwrite.lisp
-gosmacs.lisp
-ts-buf.lisp
-ts-stream.lisp
-eval-server.lisp
-lispeval.lisp
-lispbuf.lisp
-kbdmac.lisp
-icom.lisp
-scribe.lisp
-pascal.lisp
-edit-defs.lisp
-auto-save.lisp
-register.lisp
-xcoms.lisp
-unixcoms.lisp
-mh.lisp
-highlight.lisp
-dired.lisp
-diredcoms.lisp
-bufed.lisp
-lisp-lib.lisp
-completion.lisp
-shell.lisp
-debug.lisp
-netnews.lisp
-bindings.lisp
-compilation.order
-things-to-do.txt
-
-@! Files that don't get compiled, but you'd expect to be listed in a .upd file.
-@!
-@! .../tools/hemcom.lisp
-@! .../tools/hemload.lisp
-@! ed-integrity.lisp
-@! hi-integrity.lisp
-@! hemlock.log
-@! perq-hemlock.log
-@! hemlock.upd
-@! 
diff --git a/hemlock/hi-integrity.lisp b/hemlock/hi-integrity.lisp
deleted file mode 100644
index 06531a1979292038441e1317ecfbde7b2e3481dc..0000000000000000000000000000000000000000
--- a/hemlock/hi-integrity.lisp
+++ /dev/null
@@ -1,54 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/hi-integrity.lisp,v 1.2 1991/02/08 16:34:57 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Skef Wholey
-;;;
-;;; Hack to check a buffer's integrity.
-;;;
-(in-package 'hemlock-internals)
-
-(defun checkit (&optional (buffer (current-buffer)))
-  "Returns NIL if the buffer's region is OK, or a losing line if it ain't.
-  If a malformed mark is found in the mark list it is returned as the 
-  second value."
-  (do ((line (mark-line (buffer-start-mark buffer)) (line-next line))
-       (previous nil line)
-       (lines nil (cons line lines)))
-      ((null line) nil)
-    (unless (eq (line-%buffer line) buffer)
-      (format t "~%Oh, Man!  It's in the wrong buffer!~%")
-      (return line))
-    (when (member line lines)
-      (format t "~%Oh, Man!  It's circular!~%")
-      (return line))
-    (unless (eq previous (line-previous line))
-      (format t "~%Oh, Man!  A back-pointer's screwed up!~%")
-      (return line))
-    (when (and previous (>= (line-number previous) (line-number line)))
-      (format t "~%Oh, Man!  A line number is screwed up!~%")
-      (return line))
-    (let ((res
-	   (do ((m (line-marks line) (cdr m)))
-	       ((null m) nil)
-	     (unless (<= 0 (mark-charpos (car m)) (line-length line))
-	       (format t "~%Oh, Man!  A mark is pointing into hyperspace!~%")
-	       (return (car m)))
-	     (unless (memq (mark-%kind (car m))
-			   '(:left-inserting :right-inserting))
-	       (format t "~%Oh, Man!  A mark's type is bogus!.~%")
-	       (return (car m)))
-	     (unless (eq (mark-line (car m)) line)
-	       (format t "~%Oh, Man!  A mark's line pointer is messed up!~%")
-	       (return (car m))))))
-      (when res
-	(return (values line res))))))
diff --git a/hemlock/highlight.lisp b/hemlock/highlight.lisp
deleted file mode 100644
index 84e21472fc26deed97c5bfa6f2037f0836c9e059..0000000000000000000000000000000000000000
--- a/hemlock/highlight.lisp
+++ /dev/null
@@ -1,221 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/highlight.lisp,v 1.4 1991/10/27 08:28:24 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Highlighting paren and some other good stuff.
-;;;
-;;; Written by Bill Chiles and Jim Healy.
-;;;
-
-(in-package "HEMLOCK")
-
-
-
-;;;; Open parens.
-
-(defhvar "Highlight Open Parens"
-  "When non-nil, causes open parens to be displayed in a different font when
-   the cursor is directly to the right of the corresponding close paren."
-  :value nil)
-
-(defhvar "Open Paren Finder Function"
-  "Should be a function that takes a mark for input and returns either NIL
-   if the mark is not after a close paren, or two (temporary) marks
-   surrounding the corresponding open paren."
-  :value 'lisp-open-paren-finder-function)
-
-(defhvar "Open Paren Highlighting Font"
-  "The string name of the font to be used for highlighting open parens.
-   The font is loaded when initializing Hemlock."
-  :value nil)
-
-
-(defvar *open-paren-font-marks* nil
-  "The pair of font-marks surrounding the currently highlighted open-
-   paren or nil if there isn't one.")
-
-(defvar *open-paren-highlight-font* 2
-  "The index into the font-map for the open paren highlighting font.")
-
-
-;;; MAYBE-HIGHLIGHT-OPEN-PARENS is a redisplay hook that matches parens by
-;;; highlighting the corresponding open-paren after a close-paren is
-;;; typed.
-;;; 
-(defun maybe-highlight-open-parens (window)
-  (declare (ignore window))
-  (when (value highlight-open-parens)
-    (if (and (value highlight-active-region) (region-active-p))
-	(kill-open-paren-font-marks)
-	(multiple-value-bind
-	    (start end)
-	    (funcall (value open-paren-finder-function)
-		     (current-point))
-	  (if (and start end)
-	      (set-open-paren-font-marks start end)
-	      (kill-open-paren-font-marks))))))
-;;;
-(add-hook redisplay-hook 'maybe-highlight-open-parens)
-
-(defun set-open-paren-font-marks (start end)
-  (if *open-paren-font-marks*
-      (flet ((maybe-move (dst src)
-	       (unless (mark= dst src)
-		 (move-font-mark dst src))))
-	(declare (inline maybe-move))
-	(maybe-move (region-start *open-paren-font-marks*) start)
-	(maybe-move (region-end *open-paren-font-marks*) end))
-      (let ((line (mark-line start)))
-	(setf *open-paren-font-marks*
-	      (region
-	       (font-mark line (mark-charpos start)
-			  *open-paren-highlight-font*)
-	       (font-mark line (mark-charpos end) 0))))))
-
-(defun kill-open-paren-font-marks ()
-  (when *open-paren-font-marks*
-    (delete-font-mark (region-start *open-paren-font-marks*))
-    (delete-font-mark (region-end *open-paren-font-marks*))
-    (setf *open-paren-font-marks* nil)))
-
-
-
-
-;;;; Active regions.
-
-(defhvar "Active Region Highlighting Font"
-  "The string name of the font to be used for highlighting active regions.
-   The font is loaded when initializing Hemlock."
-  :value nil)
-
-(defvar *active-region-font-marks* nil)
-(defvar *active-region-highlight-font* 3
-  "The index into the font-map for the active region highlighting font.")
-
-
-;;; HIGHLIGHT-ACTIVE-REGION is a redisplay hook for active regions.
-;;; Since it is too hard to know how the region may have changed when it is
-;;; active and already highlighted, if it does not check out to being exactly
-;;; the same, we just delete all the font marks and make new ones.  When
-;;; the current window is the echo area window, just pretend everything is
-;;; okay; this keeps the region highlighted while we're in there.
-;;;
-(defun highlight-active-region (window)
-  (unless (eq window *echo-area-window*)
-    (when (value highlight-active-region)
-      (cond ((region-active-p)
-	     (cond ((not *active-region-font-marks*)
-		    (set-active-region-font-marks))
-		   ((check-active-region-font-marks))
-		   (t (kill-active-region-font-marks)
-		      (set-active-region-font-marks))))
-	    (*active-region-font-marks*
-	     (kill-active-region-font-marks))))))
-;;;
-(add-hook redisplay-hook 'highlight-active-region)
-
-(defun set-active-region-font-marks ()
-  (flet ((stash-a-mark (m &optional (font *active-region-highlight-font*))
-	   (push (font-mark (mark-line m) (mark-charpos m) font)
-		 *active-region-font-marks*)))
-    (let* ((region (current-region nil nil))
-	   (start (region-start region))
-	   (end (region-end region)))
-      (with-mark ((mark start))
-	(unless (mark= mark end)
-	  (loop
-	    (stash-a-mark mark)
-	    (unless (line-offset mark 1 0) (return))
-	    (when (mark>= mark end) (return)))
-	  (unless (start-line-p end) (stash-a-mark end 0))))))
-  (setf *active-region-font-marks* (nreverse *active-region-font-marks*)))
-
-(defun kill-active-region-font-marks ()
-  (dolist (m *active-region-font-marks*)
-    (delete-font-mark m))
-  (setf *active-region-font-marks* nil))
-
-;;; CHECK-ACTIVE-REGION-FONT-MARKS returns t if the current region is the same
-;;; as that what is highlighted on the screen.  This assumes
-;;; *active-region-font-marks* is non-nil.  At the very beginning, our start
-;;; mark must not be at the end; it must be at the first font mark; and the
-;;; font marks must be in the current buffer.  We don't make font marks if the
-;;; start is at the end, so if this is the case, then they just moved together.
-;;; We return nil in this case to kill all the font marks and make new ones, but
-;;; no new ones will be made.
-;;;
-;;; Sometimes we hack the font marks list and return t because we can easily
-;;; adjust the highlighting to be correct.  This keeps all the font marks from
-;;; being killed and re-established.  In the loop, if there are no more font
-;;; marks, we either ended a region already highlighted on the next line down,
-;;; or we have to revamp the font marks.  Before returning here, we see if the
-;;; region ends one more line down at the beginning of the line.  If this is
-;;; true, then the user is simply doing "Next Line" at the beginning of the
-;;; line.
-;;;
-;;; Each time through the loop we look at the top font mark, move our roving
-;;; mark down one line, and see if they compare.  If they are not equal, the
-;;; region may still be the same as that highlighted on the screen.  If this
-;;; is the last font mark, not at the beginning of the line, and it is at the
-;;; region's end, then this last font mark is in the middle of a line somewhere
-;;; changing the font from the highlighting font to the default font.  Return
-;;; t.
-;;;
-;;; If our roving mark is not at the current font mark, but it is at or after
-;;; the end of the active region, then the end of the active region has moved
-;;; before its previous location.
-;;;
-;;; Otherwise, move on to the next font mark.
-;;;
-;;; If our roving mark never moved onto a next line, then the buffer ends on the
-;;; previous line, and the last font mark changes from the highlighting font to
-;;; the default font.
-;;;
-(defun check-active-region-font-marks ()
-  (let* ((region (current-region nil nil))
-	 (end (region-end region)))
-    (with-mark ((mark (region-start region)))
-      (let ((first-active-mark (car *active-region-font-marks*))
-	    (last-active-mark (last *active-region-font-marks*)))
-	(if (and (mark/= mark end)
-		 (eq (current-buffer)
-		     (line-buffer (mark-line first-active-mark)))
-		 (mark= first-active-mark mark))
-	    (let ((marks (cdr *active-region-font-marks*)))
-	      (loop
-		(unless marks
-		  (let ((res (and (line-offset mark 1 0)
-				  (mark= mark end))))
-		    (when (and (not res)
-			       (line-offset mark 1 0)
-			       (mark= mark end)
-			       (start-line-p (car last-active-mark)))
-		      (setf (cdr last-active-mark)
-			    (list (font-mark (line-previous (mark-line mark))
-					     0
-					     *active-region-highlight-font*)))
-		      (return t))
-		    (return res)))
-		(let ((fmark (car marks)))
-		  (if (line-offset mark 1 0)
-		      (cond ((mark/= mark fmark)
-			     (return (and (not (cdr marks))
-					  (not (start-line-p fmark))
-					  (mark= fmark end))))
-			    ((mark>= mark end)
-			     (return nil))
-			    (t (setf marks (cdr marks))))
-
-		      (return (and (not (cdr marks))
-				   (not (start-line-p fmark))
-				   (mark= fmark end))))))))))))
-
diff --git a/hemlock/htext1.lisp b/hemlock/htext1.lisp
deleted file mode 100644
index 0a359922901a02fb94e673c058b72ec240a7f657..0000000000000000000000000000000000000000
--- a/hemlock/htext1.lisp
+++ /dev/null
@@ -1,648 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/htext1.lisp,v 1.2 1991/02/08 16:35:02 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Hemlock Text-Manipulation functions.
-;;; Written by Skef Wholey.
-;;;
-;;; The code in this file implements the functions in the "Representation
-;;; of Text," "Buffers," and "Predicates" chapters of the Hemlock design
-;;; document.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(line-length line-buffer line-string line-character mark mark-kind
-	  copy-mark delete-mark move-to-position region make-empty-region
-	  start-line-p end-line-p empty-line-p blank-line-p blank-before-p
-	  blank-after-p same-line-p mark< mark<= mark> mark>= mark= mark/=
-	  line< line<= line> line>= first-line-p last-line-p buffer-signature
-	  lines-related))
-
-
-
-;;;; Representation of Text:
-
-;;; Line cache mechanism.
-;;;
-;;; The "open line" is used when inserting and deleting characters from a line.
-;;; It acts as a cache that provides a more flexible (but more expensive)
-;;; representation of the line for multiple insertions and deletions.  When a
-;;; line is open, it is represented as a vector of characters and two indices:
-;;;
-;;; +-----------------------------------------------------------+
-;;; | F | O | O |   | B | x | x | x | x | x | x | x | x | A | R |
-;;; +-----------------------------------------------------------+
-;;;			  ^			          ^
-;;;		      Left Pointer		     Right Pointer
-;;;
-;;; The open line is represented by 4 special variables:
-;;;	Open-Line: the line object that is opened
-;;;	Open-Chars: the vector of cached characters
-;;;	Left-Open-Pos: index of first free character in the gap
-;;;	Right-Open-Pos: index of first used character after the gap
-;;;
-;;; Note:
-;;;    Any modificiation of the line cache must be protected by
-;;; Without-Interrupts.  This is done automatically by modifying-buffer; other
-;;; users beware.
-
-(defvar line-cache-length 200
-  "Length of Open-Chars.")
-
-(defvar open-line ()
-  "Line open for hacking on.")
-
-(defvar open-chars  (make-string line-cache-length)
-  "Vector of characters for hacking on.")
-
-(defvar left-open-pos 0
-  "Index to first free character to left of mark in Open-Chars.")
-
-(defvar right-open-pos 0
-  "Index to first used character to right of mark in Open-Chars.")
-
-(defun grow-open-chars (&optional (new-length (* line-cache-length 2)))
-  "Grows Open-Chars to twice its current length, or the New-Length if
-  specified."
-  (let ((new-chars (make-string new-length))
-	(new-right (- new-length (- line-cache-length right-open-pos))))
-    (%sp-byte-blt open-chars 0 new-chars 0 left-open-pos)
-    (%sp-byte-blt open-chars right-open-pos new-chars new-right new-length)
-    (setq right-open-pos new-right)
-    (setq open-chars new-chars)
-    (setq line-cache-length new-length)))
-
-(defun close-line ()
-  "Stuffs the characters in the currently open line back into the line they
-  came from, and sets open-line to Nil."
-  (when open-line
-    (without-interrupts
-      (let* ((length (+ left-open-pos (- line-cache-length right-open-pos)))
-	     (string (make-string length)))
-	(%sp-byte-blt open-chars 0 string 0 left-open-pos)
-	(%sp-byte-blt open-chars right-open-pos string left-open-pos length)
-	(setf (line-chars open-line) string)
-	(setf open-line nil)))))
-
-;;; We stick decrementing fixnums in the line-chars slot of the open line
-;;; so that whenever the cache is changed the chars are no longer eq.
-;;; They decrement so that they will be distinct from positive fixnums,
-;;; which might mean something else.
-;;;
-(defvar *cache-modification-tick* -1
-  "The counter for the fixnums we stick in the chars of the cached line.")
-
-(defun open-line (line mark)
-  "Closes the current Open-Line and opens the given Line at the Mark.
-  Don't call this, use modifying-line instead."
-  (cond ((eq line open-line)
-	 (let ((charpos (mark-charpos mark)))
-	   (cond ((< charpos left-open-pos)	; BLT 'em right!
-		  (let ((right-start (- right-open-pos
-					(- left-open-pos charpos))))
-		    (%sp-byte-blt open-chars charpos
-				  open-chars right-start
-				  right-open-pos)
-		    (setq left-open-pos charpos)
-		    (setq right-open-pos right-start)))
-		 ((> charpos left-open-pos)	; BLT 'em left!
-		  (%sp-byte-blt open-chars right-open-pos
-				open-chars left-open-pos
-				charpos)
-		  (setq right-open-pos
-			(+ right-open-pos (- charpos left-open-pos)))
-		  (setq left-open-pos charpos)))))
-
-	(t
-	 (close-line)
-	 (let* ((chars (line-chars line))
-		(len (length chars)))
-	   (declare (simple-string chars))
-	   (when (> len line-cache-length)
-	     (setq line-cache-length (* len 2))
-	     (setq open-chars (make-string line-cache-length)))
-	   (setq open-line line)
-	   (setq left-open-pos (mark-charpos mark))
-	   (setq right-open-pos
-		 (- line-cache-length (- (length chars) left-open-pos)))
-	   (%sp-byte-blt chars 0 open-chars 0 left-open-pos)
-	   (%sp-byte-blt chars left-open-pos open-chars right-open-pos
-			 line-cache-length)))))
-
-;;;; Some macros for Text hacking:
-
-
-(defmacro modifying-line (line mark)
-  "Checks to see if the Line is already opened at the Mark, and calls Open-Line
-  if not.  Sticks a tick in the open-line's chars.  This must be called within
-  the body of a Modifying-Buffer form."
-  `(progn
-    (unless (and (= (mark-charpos ,mark) left-open-pos) (eq ,line open-line))
-      (open-line ,line ,mark))
-    (setf (line-chars open-line) (decf *cache-modification-tick*))))
-
-;;; Now-Tick tells us when now is and isn't.
-;;;
-(defvar now-tick 0 "Current tick.")
-
-(defmacro tick ()
-  "Increments the ``now'' tick."
-  `(incf now-tick))
-
-
-;;; Yeah, the following is kind of obscure, but at least it doesn't
-;;; call Bufferp twice.  The without-interrupts is just to prevent
-;;; people from being screwed by interrupting when the buffer structure
-;;; is in an inconsistent state.
-;;;
-(defmacro modifying-buffer (buffer &body forms)
-  "Does groovy stuff for modifying buffers."
-  `(progn
-     (when (bufferp ,buffer)
-       (unless (buffer-writable ,buffer)
-	 (error "Buffer ~S is read only." (buffer-name ,buffer)))
-       (when (< (buffer-modified-tick ,buffer)
-		(buffer-unmodified-tick ,buffer))
-	 (invoke-hook ed::buffer-modified-hook ,buffer t))
-       (setf (buffer-modified-tick ,buffer) (tick)))
-     (without-interrupts ,@forms)))
-
-(defmacro always-change-line (mark new-line)
-  (let ((scan (gensym))
-	(prev (gensym))
-	(old-line (gensym)))
-    `(let ((,old-line (mark-line ,mark)))
-       (when (not (eq (mark-%kind ,mark) :temporary))
-	 (do ((,scan (line-marks ,old-line) (cdr ,scan))
-	      (,prev () ,scan))
-	     ((eq (car ,scan) ,mark)
-	      (if ,prev
-		  (setf (cdr ,prev) (cdr ,scan))
-		  (setf (line-marks ,old-line) (cdr ,scan)))
-	      (setf (cdr ,scan) (line-marks ,new-line)
-		    (line-marks ,new-line) ,scan))))
-       (setf (mark-line ,mark) ,new-line))))
-
-(defmacro change-line (mark new-line)
-  (let ((scan (gensym))
-	(prev (gensym))
-	(old-line (gensym)))
-    `(let ((,old-line (mark-line ,mark)))
-       (unless (or (eq (mark-%kind ,mark) :temporary)
-		   (eq ,old-line ,new-line))
-	 (do ((,scan (line-marks ,old-line) (cdr ,scan))
-	      (,prev () ,scan))
-	     ((eq (car ,scan) ,mark)
-	      (if ,prev
-		  (setf (cdr ,prev) (cdr ,scan))
-		  (setf (line-marks ,old-line) (cdr ,scan)))
-	      (setf (cdr ,scan) (line-marks ,new-line)
-		    (line-marks ,new-line) ,scan))))
-       (setf (mark-line ,mark) ,new-line))))
-
-;;; MOVE-SOME-MARKS  --  Internal
-;;;
-;;;    Move all the marks from the line Old to New, performing some
-;;; function on their charpos'es.  Charpos is bound to the charpos of
-;;; the mark, and the result of the evaluation of the last form in 
-;;; the body should be the new charpos for the mark.  If New is
-;;; not supplied then the marks are left on the old line.
-;;;
-(defmacro move-some-marks ((charpos old &optional new) &body body)
-  (let ((last (gensym)) (mark (gensym)) (marks (gensym)))
-    (if new
-	`(let ((,marks (line-marks ,old)))
-	   (do ((,mark ,marks (cdr ,mark))
-		(,last nil ,mark))
-	       ((null ,mark)
-		(when ,last
-		  (shiftf (cdr ,last) (line-marks ,new) ,marks))
-		(setf (line-marks ,old) nil))
-	     (setf (mark-line (car ,mark)) ,new)
-	     (setf (mark-charpos (car ,mark))
-		   (let ((,charpos (mark-charpos (car ,mark))))
-		     ,@body))))
-	`(dolist (,mark (line-marks ,old))
-	   (setf (mark-charpos ,mark)
-		 (let ((,charpos (mark-charpos ,mark)))
-		   ,@body))))))
-
-;;; Maybe-Move-Some-Marks  --  Internal
-;;;
-;;;    Like Move-Some-Marks, but only moves the mark if the 
-;;; charpos is greater than the bound, OR the charpos equals the bound
-;;; and the marks %kind is :left-inserting.
-;;;
-(defmacro maybe-move-some-marks ((charpos old &optional new) bound &body body)
-  (let ((mark (gensym)) (marks (gensym)) (prev (gensym)))
-    (if new
-	`(do ((,mark (line-marks ,old))
-	      (,marks (line-marks ,new))
-	      (,prev ()))
-	     ((null ,mark)
-	      (setf (line-marks ,new) ,marks))
-	   (let ((,charpos (mark-charpos (car ,mark))))
-	     (cond
-	       ((or (> ,charpos ,bound)
-		    (and (= ,charpos ,bound) 
-			 (eq (mark-%kind (car ,mark)) :left-inserting)))
-		(setf (mark-line (car ,mark)) ,new)
-		(setf (mark-charpos (car ,mark)) (progn ,@body))
-		(if ,prev
-		    (setf (cdr ,prev) (cdr ,mark))
-		    (setf (line-marks ,old) (cdr ,mark)))
-		(rotatef (cdr ,mark) ,marks ,mark))
-	       (t
-		(setq ,prev ,mark  ,mark (cdr ,mark))))))
-	`(dolist (,mark (line-marks ,old))
-	   (let ((,charpos (mark-charpos ,mark)))
-	     (when (or (> ,charpos ,bound)
-		       (and (= ,charpos ,bound)
-			    (eq (mark-%kind ,mark) :left-inserting)))
-	       (setf (mark-charpos ,mark) (progn ,@body))))))))
-
-
-;;; Maybe-Move-Some-Marks*  --  Internal
-;;;
-;;;    Like Maybe-Move-Some-Marks, but ignores the mark %kind.
-;;;
-(defmacro maybe-move-some-marks* ((charpos old &optional new) bound &body body)
-  (let ((mark (gensym)) (marks (gensym)) (prev (gensym)))
-    (if new
-	`(do ((,mark (line-marks ,old))
-	      (,marks (line-marks ,new))
-	      (,prev ()))
-	     ((null ,mark)
-	      (setf (line-marks ,new) ,marks))
-	   (let ((,charpos (mark-charpos (car ,mark))))
-	     (cond
-	       ((> ,charpos ,bound)
-		(setf (mark-line (car ,mark)) ,new)
-		(setf (mark-charpos (car ,mark)) (progn ,@body))
-		(if ,prev
-		    (setf (cdr ,prev) (cdr ,mark))
-		    (setf (line-marks ,old) (cdr ,mark)))
-		(rotatef (cdr ,mark) ,marks ,mark))
-	       (t
-		(setq ,prev ,mark  ,mark (cdr ,mark))))))
-	`(dolist (,mark (line-marks ,old))
-	   (let ((,charpos (mark-charpos ,mark)))
-	     (when (> ,charpos ,bound)
-	       (setf (mark-charpos ,mark) (progn ,@body))))))))
-
-;;;; Lines.
-
-(defun line-length (line)
-  "Returns the number of characters on the line."
-  (if (linep line)
-      (line-length* line)
-      (error "~S is not a line!" line)))
-
-(defun line-buffer (line)
-  "Returns the buffer with which the Line is associated.  If the line is
-  not in any buffer then Nil is returned."
-  (let ((buffer (line-%buffer line)))
-    (if (bufferp buffer) buffer)))
-
-(defun line-string (line)
-  "Returns the characters in the line as a string.  The resulting string
-  must not be destructively modified.  This may be set with Setf."
-  (if (eq line open-line)
-      (close-line))
-  (line-chars line))
-
-(defun %set-line-string (line string)
-  (let ((buffer (line-%buffer line)))
-    (modifying-buffer buffer
-      (unless (simple-string-p string) 
-	(setq string (coerce string 'simple-string)))
-      (when (eq line open-line) (setq open-line nil))
-      (let ((length (length (the simple-string string))))
-	(dolist (m (line-marks line))
-	  (if (eq (mark-%kind m) :left-inserting)
-	      (setf (mark-charpos m) length)
-	      (setf (mark-charpos m) 0))))
-      (setf (line-chars line) string))))
-
-(defun line-character (line index)
-  "Return the Index'th character in Line.  If the index is the length of the
-  line then #\newline is returned."
-  (if (eq line open-line)
-      (if (< index left-open-pos)
-	  (schar open-chars index)
-	  (let ((index (+ index (- right-open-pos left-open-pos))))
-	    (if (= index line-cache-length)
-		#\newline
-		(schar open-chars index))))
-      (let ((chars (line-chars line)))
-	(declare (simple-string chars))
-	(if (= index (length chars))
-	    #\newline
-	    (schar chars index)))))
-
-;;;; Marks.
-
-(defun mark (line charpos &optional (kind :temporary))
-  "Returns a mark to the Charpos'th character of the Line.  Kind is the
-  kind of mark to make, one of :temporary (the default), :left-inserting
-  or :right-inserting."
-  (let ((mark (internal-make-mark line charpos kind)))
-    (if (not (eq kind :temporary))
-	(push mark (line-marks line)))
-    mark))
-
-(defun mark-kind (mark)
-  "Returns the kind of the given Mark, :Temporary, :Left-Inserting, or
-  :Right-Inserting.  This may be set with Setf."
-  (mark-%kind mark))
-
-(defun %set-mark-kind (mark kind)
-  (let ((line (mark-line mark)))
-    (cond ((eq kind :temporary)
-	   (setf (line-marks line) (delq mark (line-marks line)))
-	   (setf (mark-%kind mark) kind))
-	  ((or (eq kind :left-inserting) (eq kind :right-inserting))
-	   (if (not (memq mark (line-marks line)))
-	       (push mark (line-marks line)))
-	   (setf (mark-%kind mark) kind))
-	  (t
-	   (error "~S is an invalid mark type." kind)))))
-
-(defun copy-mark (mark &optional (kind (mark-%kind mark)))
-  "Returns a new mark pointing to the same position as Mark.  The kind
-  of mark created may be specified by Kind, which defaults to the
-  kind of the copied mark."
-  (let ((mark (internal-make-mark (mark-line mark) (mark-charpos mark) kind)))
-    (if (not (eq kind :temporary))
-	(push mark (line-marks (mark-line mark))))
-    mark))
-
-(defun delete-mark (mark)
-  "Deletes the Mark.  This should be done to any mark that may not be
-  temporary which is no longer needed."
-  (if (not (eq (mark-%kind mark) :temporary))
-      (let ((line (mark-line mark)))
-	(when line
-	  (setf (line-marks line) (delq mark (line-marks line))))
-	nil))
-  (setf (mark-line mark) nil))
-
-(defun move-to-position (mark charpos &optional (line (mark-line mark)))
-  "Changes the Mark to point to the given character position on the Line,
-  which defaults to the line the mark is currently on."
-  (change-line mark line)
-  (setf (mark-charpos mark) charpos)
-  mark)
-
-;;;; Regions.
-
-(defun region (start end)
-  "Returns a region constructed from the marks Start and End."
-  (let ((l1 (mark-line start))
-	(l2 (mark-line end)))
-    (unless (eq (line-%buffer l1) (line-%buffer l2))
-      (error "Can't make a region with lines of different buffers."))
-    (unless (if (eq l1 l2)
-		(<= (mark-charpos start) (mark-charpos end))
-		(< (line-number l1) (line-number l2)))
-      (error "Start ~S is after end ~S." start end)))
-  (internal-make-region start end))
-
-;;; The *Disembodied-Buffer-Counter* exists to give that are not in any buffer
-;;; unique buffer slots.
-
-(defvar *Disembodied-Buffer-Counter* 0
-  "``Buffer'' given to lines in regions not in any buffer.")
-
-(defun make-empty-region ()
-  "Returns a region with start and end marks pointing to the start of one empty
-  line.  The start mark is right-inserting and the end mark is left-inserting."
-  (let* ((line (make-line :chars ""  :number 0
-			  :%buffer (incf *disembodied-buffer-counter*)))
-	 (start (mark line 0 :right-inserting))
-	 (end (mark line 0 :left-inserting)))
-    (internal-make-region start end)))
-
-;;; Line-Increment is the default difference for line numbers when we don't
-;;; know any better.
-
-(defconstant line-increment 256 "Default difference for line numbers.")
-
-;;; Renumber-Region is used internally to keep line numbers in ascending order.
-;;; The lines in the region are numbered starting with the given Start value
-;;; by increments of the given Step value.  It returns the region.
-
-(defun renumber-region (region &optional (start 0) (step line-increment))
-  (do ((line (mark-line (region-start region)) (line-next line))
-       (last-line (mark-line (region-end region)))
-       (number start (+ number step)))
-      ((eq line last-line)
-       (setf (line-number line) number)
-       region)
-    (setf (line-number line) number))
-  region)
-
-;;; Renumber-Region-Containing renumbers the region containing the given line.
-
-(defun renumber-region-containing (line)
-  (cond ((line-buffer line)
-	 (renumber-region (buffer-region (line-%buffer line))))
-	(t
-	 (do ((line line (line-previous line))
-	      (number 0 (- number line-increment)))
-	     ((null line))
-	   (setf (line-number line) number))
-	 (do ((line (line-next line) (line-next line))
-	      (number line-increment (+ number line-increment)))
-	     ((null line))
-	   (setf (line-number line) number)))))
-  
-
-;;; Number-Line numbers a newly created line.  The line has to have a previous
-;;; line.
-(defun number-line (line)
-  (let ((prev (line-number (line-previous line)))
-	(next (line-next line)))
-    (if (null next)
-	(setf (line-number line) (+ prev line-increment))
-	(let ((new (+ prev (truncate (- (line-number next) prev) 2))))
-	  (if (= new prev)
-	      (renumber-region-containing line)
-	      (setf (line-number line) new))))))
-
-
-
-;;;; Buffers.
-
-;;; BUFFER-SIGNATURE is the exported interface to the internal function,
-;;; BUFFER-MODIFIED-TICK
-;;; 
-(defun buffer-signature (buffer)
-  "Returns an arbitrary number which reflects the buffers current
-  \"signature.\" The value returned by buffer-signature is guaranteed
-  to be eql to the value returned by a previous call of buffer-signature
-  iff the buffer has not been modified between the calls."
-  (unless (bufferp buffer)
-    (error "~S is not a buffer." buffer))
-  (buffer-modified-tick buffer))
-
-
-
-;;;; Predicates:
-
-
-(defun start-line-p (mark)
-  "Returns T if the Mark points before the first character in a line, Nil
-  otherwise."
-  (= (mark-charpos mark) 0))
-
-(defun end-line-p (mark)
-  "Returns T if the Mark points after the last character in a line, Nil
-  otherwise."
-  (= (mark-charpos mark) (line-length (mark-line mark))))
-
-(defun empty-line-p (mark)
-  "Returns T if the line pointer to by Mark contains no characters, Nil 
-  or otherwise."
-  (let ((line (mark-line mark)))
-    (if (eq line open-line)
-	(and (= left-open-pos 0) (= right-open-pos line-cache-length))
-	(= (length (line-chars line)) 0))))
-
-;;; blank-between-positions  --  Internal
-;;;
-;;;    Check if a line is blank between two positions.  Used by blank-XXX-p.
-;;;
-(eval-when (compile eval)
-(defmacro check-range (chars start end)
-  `(do ((i ,start (1+ i)))
-       ((= i ,end) t)
-     (when (zerop (character-attribute :whitespace (schar ,chars i)))
-       (return nil)))))
-;;;
-(defun blank-between-positions (line start end)
-  (if (eq line open-line)
-      (let ((gap (- right-open-pos left-open-pos)))
-	(cond ((>= start left-open-pos)
-	       (check-range open-chars (+ start gap) (+ end gap)))
-	      ((<= end left-open-pos)
-	       (check-range open-chars start end))
-	      (t
-	       (and (check-range open-chars start left-open-pos)
-		    (check-range open-chars right-open-pos (+ end gap))))))
-      (let ((chars (line-chars line)))
-	(check-range chars start end))))
-
-(defun blank-line-p (line)
-  "True if line contains only characters with a :whitespace attribute of 1."
-  (blank-between-positions line 0 (line-length line)))
-
-(defun blank-before-p (mark)
-  "True is all of the characters before Mark on the line it is on have a
-  :whitespace attribute of 1."
-  (blank-between-positions (mark-line mark) 0 (mark-charpos mark)))
-
-(defun blank-after-p (mark)
-  "True if all characters on the part part of the line after Mark have
-  a :whitespace attribute of 1."
-  (let ((line (mark-line mark)))
-    (blank-between-positions line (mark-charpos mark)
-			     (line-length line))))
-  
-(defun same-line-p (mark1 mark2)
-  "Returns T if Mark1 and Mark2 point to the same line, Nil otherwise."
-  (eq (mark-line mark1) (mark-line mark2)))
-
-(defun mark< (mark1 mark2)
-  "Returns T if Mark1 points to a character before Mark2, Nil otherwise."
-  (if (not (eq (line-%buffer (mark-line mark1))
-	       (line-%buffer (mark-line mark2))))
-      (error "Marks in different buffers have no relation."))
-  (or (< (line-number (mark-line mark1)) (line-number (mark-line mark2)))
-      (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2)))
-	   (< (mark-charpos mark1) (mark-charpos mark2)))))
-
-(defun mark<= (mark1 mark2)
-  "Returns T if Mark1 points to a character at or before Mark2, Nil otherwise."
-  (if (not (eq (line-%buffer (mark-line mark1))
-	       (line-%buffer (mark-line mark2))))
-      (error "Marks in different buffers have no relation."))
-  (or (< (line-number (mark-line mark1)) (line-number (mark-line mark2)))
-      (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2)))
-	   (<= (mark-charpos mark1) (mark-charpos mark2)))))
-
-(defun mark> (mark1 mark2)
-  "Returns T if Mark1 points to a character after Mark2, Nil otherwise."
-  (if (not (eq (line-%buffer (mark-line mark1))
-	       (line-%buffer (mark-line mark2))))
-      (error "Marks in different buffers have no relation."))
-  (or (> (line-number (mark-line mark1)) (line-number (mark-line mark2)))
-      (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2)))
-	   (> (mark-charpos mark1) (mark-charpos mark2)))))
-
-(defun mark>= (mark1 mark2)
-  "Returns T if Mark1 points to a character at or after Mark2, Nil otherwise."
-  (if (not (eq (line-%buffer (mark-line mark1))
-	       (line-%buffer (mark-line mark2))))
-      (error "Marks in different buffers have no relation."))
-  (or (> (line-number (mark-line mark1)) (line-number (mark-line mark2)))
-      (and (= (line-number (mark-line mark1)) (line-number (mark-line mark2)))
-	   (>= (mark-charpos mark1) (mark-charpos mark2)))))
-
-(defun mark= (mark1 mark2)
-  "Returns T if both marks point to the same position, Nil otherwise."
-  (and (eq (mark-line mark1) (mark-line mark2))
-       (= (mark-charpos mark1) (mark-charpos mark2))))
-
-(defun mark/= (mark1 mark2)
-  "Returns T if both marks point to different positions, Nil otherwise."
-  (not (and (eq (mark-line mark1) (mark-line mark2))
-	    (= (mark-charpos mark1) (mark-charpos mark2)))))
-
-(defun line< (line1 line2)
-  "Returns T if Line1 comes before Line2, NIL otherwise."
-  (if (neq (line-%buffer line1) (line-%buffer line2))
-      (error "Lines in different buffers have no relation."))
-  (< (line-number line1) (line-number line2)))
-
-(defun line<= (line1 line2)
-  "Returns T if Line1 comes before or is the same as Line2, NIL otherwise."
-  (if (neq (line-%buffer line1) (line-%buffer line2))
-      (error "Lines in different buffers have no relation."))
-  (<= (line-number line1) (line-number line2)))
-
-(defun line>= (line1 line2)
-  "Returns T if Line1 comes after or is the same as Line2, NIL otherwise."
-  (if (neq (line-%buffer line1) (line-%buffer line2))
-      (error "Lines in different buffers have no relation."))
-  (>= (line-number line1) (line-number line2)))
-
-(defun line> (line1 line2)
-  "Returns T if Line1 comes after Line2, NIL otherwise."
-  (if (neq (line-%buffer line1) (line-%buffer line2))
-      (error "Lines in different buffers have no relation."))
-  (> (line-number line1) (line-number line2)))
-
-(defun lines-related (line1 line2)
-  "Returns T if an order relation exists between Line1 and Line2."
-  (eq (line-%buffer line1) (line-%buffer line2)))
-
-(defun first-line-p (mark)
-  "Returns T if the line pointed to by mark has no previous line,
-  Nil otherwise."
-  (null (line-previous (mark-line mark))))
-
-(defun last-line-p (mark)
-  "Returns T if the line pointed to by mark has no next line,
-  Nil otherwise."
-  (null (line-next (mark-line mark))))
diff --git a/hemlock/htext2.lisp b/hemlock/htext2.lisp
deleted file mode 100644
index 0294632f06cfec6c7c4011481bd7627aad707daf..0000000000000000000000000000000000000000
--- a/hemlock/htext2.lisp
+++ /dev/null
@@ -1,500 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/htext2.lisp,v 1.1.1.2 1991/02/08 16:35:07 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; More Hemlock Text-Manipulation functions.
-;;; Written by Skef Wholey.
-;;;
-;;; The code in this file implements the non-insert/delete functions in the
-;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(region-to-string string-to-region line-to-region
-			   previous-character next-character count-lines
-			   count-characters line-start line-end buffer-start
-			   buffer-end move-mark mark-before mark-after
-			   character-offset line-offset region-bounds
-			   set-region-bounds *print-region*))
-
-
-
-(defun region-to-string (region)
-  "Returns a string containing the characters in the given Region."
-  (close-line)
-  (let* ((dst-length (count-characters region))
-	 (string (make-string dst-length))
-	 (start-mark (region-start region))
-	 (end-mark (region-end region))
-	 (start-line (mark-line start-mark))
-	 (end-line (mark-line end-mark))
-	 (start-charpos (mark-charpos start-mark)))
-    (declare (simple-string string))
-    (if (eq start-line end-line)
-	(%sp-byte-blt (line-chars start-line) start-charpos string 0
-		      dst-length)
-	(let ((index ()))
-	  (let* ((line-chars (line-chars start-line))
-		 (dst-end (- (length line-chars) start-charpos)))
-	    (declare (simple-string line-chars))
-	    (%sp-byte-blt line-chars start-charpos string 0 dst-end)
-	    (setf (char string dst-end) #\newline)
-	    (setq index (1+ dst-end)))
-	  (do* ((line (line-next start-line) (line-next line))
-		(chars (line-chars line) (line-chars line)))
-	       ((eq line end-line)
-		(%sp-byte-blt (line-chars line) 0 string index dst-length))
-	    (declare (simple-string chars))
-	    (%sp-byte-blt (line-chars line) 0 string index
-			  (incf index (length chars)))
-	    (setf (char string index) #\newline)
-	    (setq index (1+ index)))))
-    string))
-
-(defun string-to-region (string)
-  "Returns a region containing the characters in the given String."
-  (let* ((string (if (simple-string-p string)
-		     string (coerce string 'simple-string)))
-	 (end (length string)))
-    (declare (simple-string string))
-    (do* ((index 0)
-	  (buffer (incf *disembodied-buffer-counter*))
-	  (previous-line)
-	  (line (make-line :%buffer buffer))
-	  (first-line line))
-	 (())
-      (let ((right-index (%sp-find-character string index end #\newline)))
-	(cond (right-index
-	       (let* ((length (- right-index index))
-		      (chars (make-string length)))
-		 (%sp-byte-blt string index chars 0 length)
-		 (setf (line-chars line) chars))
-	       (setq index (1+ right-index))
-	       (setq previous-line line)
-	       (setq line (make-line :%buffer buffer))
-	       (setf (line-next previous-line) line)
-	       (setf (line-previous line) previous-line))
-	      (t
-	       (let* ((length (- end index))
-		      (chars (make-string length)))
-		 (%sp-byte-blt string index chars 0 length)
-		 (setf (line-chars line) chars))
-	       (return (renumber-region
-			(internal-make-region
-			 (mark first-line 0 :right-inserting)
-			 (mark line (length (line-chars line))
-			       :left-inserting))))))))))
-
-(defun line-to-region (line)
-  "Returns a region containing the specified line."
-  (internal-make-region (mark line 0 :right-inserting)
-			(mark line (line-length* line) :left-inserting)))
-
-(defun previous-character (mark)
-  "Returns the character immediately before the given Mark."
-  (let ((line (mark-line mark))
-	(charpos (mark-charpos mark)))
-    (if (= charpos 0)
-	(if (line-previous line)
-	    #\newline
-	    nil)
-	(if (eq line open-line)
-	    (char (the simple-string open-chars)
-		  (if (<= charpos left-open-pos)
-		      (1- charpos)
-		      (1- (+ right-open-pos (- charpos left-open-pos)))))
-	    (schar (line-chars line) (1- charpos))))))
-
-(defun next-character (mark)
-  "Returns the character immediately after the given Mark."
-  (let ((line (mark-line mark))
-	(charpos (mark-charpos mark)))
-    (if (eq line open-line)
-	(if (= charpos (- line-cache-length (- right-open-pos left-open-pos)))
-	    (if (line-next line)
-		#\newline
-		nil)
-	    (schar open-chars
-		   (if (< charpos left-open-pos)
-		       charpos
-		       (+ right-open-pos (- charpos left-open-pos)))))
-	(let ((chars (line-chars line)))
-	  (if (= charpos (strlen chars))
-	      (if (line-next line)
-		  #\newline
-		  nil)
-	      (schar chars charpos))))))
-
-;;; %Set-Next-Character  --  Internal
-;;;
-;;;    This is the setf form for Next-Character.  Since we may change a
-;;; character to or from a newline, we must be prepared to split and
-;;; join lines.  We cannot just delete  a character and insert the new one
-;;; because the marks would not be right.
-;;;
-(defun %set-next-character (mark character)
-  (let* ((line (mark-line mark))
-	 (buffer (line-%buffer line))
-	 (next (line-next line)))
-    (modifying-buffer buffer
-      (modifying-line line mark)
-      (cond ((= right-open-pos line-cache-length)
-	     ;; The mark is at the end of the line.
-	     (unless next
-	       (error "~S has no next character, so it cannot be set." mark))
-	     (unless (char= character #\newline)
-	       ;; If the character is no longer a newline then mash two
-	       ;; lines together.
-	       (let ((chars (line-chars next)))
-		 (declare (simple-string chars))
-		 (setq right-open-pos (- line-cache-length (length chars)))
-		 (when (<= right-open-pos left-open-pos)
-		   (grow-open-chars (* (+ (length chars) left-open-pos 1) 2)))
-		 (%sp-byte-blt chars 0 open-chars right-open-pos 
-			       line-cache-length)
-		 (setf (schar open-chars left-open-pos) character)
-		 (incf left-open-pos))
-	       (move-some-marks (charpos next line) 
-				(+ charpos left-open-pos))
-	       (setq next (line-next next))
-	       (setf (line-next line) next)
-	       (when next (setf (line-previous next) line))))
-	    ((char= character #\newline)
-	     ;; The char is being changed to a newline, so we must split lines.
-	     (incf right-open-pos)
-	     (let* ((len (- line-cache-length right-open-pos))	   
-		    (chars (make-string len))
-		    (new (make-line :chars chars  :previous line 
-				    :next next  :%buffer buffer)))
-	       (%sp-byte-blt open-chars right-open-pos chars 0 len)
-	       (maybe-move-some-marks* (charpos line new) left-open-pos
-				       (- charpos left-open-pos 1))
-	       (setf (line-next line) new)
-	       (when next (setf (line-previous next) new))
-	       (setq right-open-pos line-cache-length)
-	       (number-line new)))
-	    (t
-	     (setf (char (the simple-string open-chars) right-open-pos)
-		   character)))))
-  character)
-
-;;; %Set-Previous-Character  --  Internal
-;;;
-;;;    The setf form for Previous-Character.  We just Temporarily move the
-;;; mark back one and call %Set-Next-Character.
-;;;
-(defun %set-previous-character (mark character)
-  (unless (mark-before mark)
-    (error "~S has no previous character, so it cannot be set." mark))
-  (%set-next-character mark character)
-  (mark-after mark)
-  character)
-
-(defun count-lines (region)
-  "Returns the number of lines in the region, first and last lines inclusive."
-  (do ((line (mark-line (region-start region)) (line-next line))
-       (count 1 (1+ count))
-       (last-line (mark-line (region-end region))))
-      ((eq line last-line) count)))
-
-(defun count-characters (region)
-  "Returns the number of characters in the region."
-  (let* ((start (region-start region))
-	 (end (region-end region))
-	 (first-line (mark-line start))
-	 (last-line (mark-line end)))
-    (if (eq first-line last-line)
-	(- (mark-charpos end) (mark-charpos start))
-	(do ((line (line-next first-line) (line-next line))
-	     (count (1+ (- (line-length* first-line) (mark-charpos start)))))
-	    ((eq line last-line)
-	     (+ count (mark-charpos end)))
-	  (setq count (+ 1 count (line-length* line)))))))
-
-(defun line-start (mark &optional line)
-  "Changes the Mark to point to the beginning of the Line and returns it.
-  Line defaults to the line Mark is on."
-  (when line
-    (change-line mark line))
-  (setf (mark-charpos mark) 0)
-  mark)
-
-(defun line-end (mark &optional line)
-  "Changes the Mark to point to the end of the line and returns it.
-  Line defaults to the line Mark is on."
-  (if line
-      (change-line mark line)
-      (setq line (mark-line mark)))
-  (setf (mark-charpos mark) (line-length* line))
-  mark)
-
-(defun buffer-start (mark &optional (buffer (line-buffer (mark-line mark))))
-  "Change Mark to point to the beginning of Buffer, which defaults to
-  the buffer Mark is currently in."
-  (unless buffer (error "Mark ~S does not point into a buffer."))
-  (move-mark mark (buffer-start-mark buffer)))
-
-(defun buffer-end (mark &optional (buffer (line-buffer (mark-line mark))))
-  "Change Mark to point to the end of Buffer, which defaults to
-  the buffer Mark is currently in."
-  (unless buffer (error "Mark ~S does not point into a buffer."))
-  (move-mark mark (buffer-end-mark buffer)))
-
-(defun move-mark (mark new-position)
-  "Changes the Mark to point to the same position as New-Position."
-  (let ((line (mark-line new-position)))
-    (change-line mark line))
-  (setf (mark-charpos mark) (mark-charpos new-position))
-  mark)
-
-(defun mark-before (mark)
-  "Changes the Mark to point one character before where it currently points.
-  NIL is returned if there is no previous character."
-  (let ((charpos (mark-charpos mark)))
-    (cond ((zerop charpos)
-	   (let ((prev (line-previous (mark-line mark))))
-	     (when prev
-	       (always-change-line mark prev)
-	       (setf (mark-charpos mark) (line-length* prev))
-	       mark)))
-	  (t
-	   (setf (mark-charpos mark) (1- charpos))
-	   mark))))
-
-(defun mark-after (mark)
-  "Changes the Mark to point one character after where it currently points.
-  NIL is returned if there is no previous character."
-  (let ((line (mark-line mark))
-	(charpos (mark-charpos mark)))
-    (cond ((= charpos (line-length* line))
-	   (let ((next (line-next line)))
-	     (when next
-	       (always-change-line mark next)
-	       (setf (mark-charpos mark) 0)
-	       mark)))
-	  (t
-	   (setf (mark-charpos mark) (1+ charpos))
-	   mark))))
-
-(defun character-offset (mark n)
-  "Changes the Mark to point N characters after (or -N before if N is negative)
-  where it currently points.  If there aren't N characters before (or after)
-  the mark, Nil is returned."
-  (let ((charpos (mark-charpos mark)))
-    (if (< n 0)
-	(let ((n (- n)))
-	  (if (< charpos n)
-	      (do ((line (line-previous (mark-line mark)) (line-previous line))
-		   (n (- n charpos 1)))
-		  ((null line) nil)
-		(let ((length (line-length* line)))
-		  (cond ((<= n length)
-			 (always-change-line mark line)
-			 (setf (mark-charpos mark) (- length n))
-			 (return mark))
-			(t
-			 (setq n (- n (1+ length)))))))
-	      (progn (setf (mark-charpos mark) (- charpos n))
-		     mark)))
-	(let* ((line (mark-line mark))
-	       (length (line-length* line)))
-	  (if (> (+ charpos n) length)
-	      (do ((line (line-next line) (line-next line))
-		   (n (- n (1+ (- length charpos)))))
-		  ((null line) nil)
-		(let ((length (line-length* line)))
-		  (cond ((<= n length)
-			 (always-change-line mark line)
-			 (setf (mark-charpos mark) n)
-			 (return mark))
-			(t
-			 (setq n (- n (1+ length)))))))
-	      (progn (setf (mark-charpos mark) (+ charpos n))
-		     mark))))))
-
-(defun line-offset (mark n &optional charpos)
-  "Changes to Mark to point N lines after (-N before if N is negative) where
-  it currently points.  If there aren't N lines after (or before) the Mark,
-  Nil is returned."
-  (if (< n 0)
-      (do ((line (mark-line mark) (line-previous line))
-	   (n n (1+ n)))
-	  ((null line) nil)
-	(when (= n 0)
-	  (always-change-line mark line)
-	  (setf (mark-charpos mark)
-		(if charpos
-		    (min (line-length line) charpos)
-		    (min (line-length line) (mark-charpos mark))))
-	  (return mark)))
-      (do ((line (mark-line mark) (line-next line))
-	   (n n (1- n)))
-	  ((null line) nil)
-	(when (= n 0)
-	  (change-line mark line)
-	  (setf (mark-charpos mark)
-		(if charpos
-		    (min (line-length line) charpos)
-		    (min (line-length line) (mark-charpos mark))))
-	  (return mark)))))
-
-;;; region-bounds  --  Public
-;;;
-(defun region-bounds (region)
-  "Return as multiple-value the start and end of Region."
-  (values (region-start region) (region-end region)))
-
-(defun set-region-bounds (region start end)
-  "Set the start and end of Region to the marks Start and End."
-  (let ((sl (mark-line start))
-	(el (mark-line end)))
-    (when (or (neq (line-%buffer sl) (line-%buffer el))
-	      (> (line-number sl) (line-number el))
-	      (and (eq sl el) (> (mark-charpos start) (mark-charpos end))))
-      (error "Marks ~S and ~S cannot be made into a region." start end))
-    (setf (region-start region) start  (region-end region) end))
-  region)
-
-
-;;;; Debugging stuff.
-
-(defun slf (string)
-  "For a good time, figure out what this function does, and why it was written."
-  (delete #\linefeed (the simple-string string)))
-
-(defun %print-whole-line (structure stream)
-  (cond ((eq structure open-line)
-	 (write-string open-chars stream :end left-open-pos)
-	 (write-string open-chars stream :start right-open-pos
-		       :end line-cache-length))
-	(t
-	 (write-string (line-chars structure) stream))))
-
-(defun %print-before-mark (mark stream)
-  (if (mark-line mark)
-      (let* ((line (mark-line mark))
-	     (chars (line-chars line))
-	     (charpos (mark-charpos mark))
-	     (length (line-length line)))
-	(declare (simple-string chars))
-	(cond ((or (> charpos length) (< charpos 0))
-	       (write-string "{bad mark}" stream))
-	      ((eq line open-line)
-	       (cond ((< charpos left-open-pos)
-		      (write-string open-chars stream :end charpos))
-		     (t
-		      (write-string open-chars stream :end left-open-pos)
-		      (let ((p (+ charpos (- right-open-pos left-open-pos))))
-			(write-string open-chars stream  :start right-open-pos
-				      :end p)))))
-	      (t
-	       (write-string chars stream :end charpos))))
-      (write-string "{deleted mark}" stream)))
-
-
-(defun %print-after-mark (mark stream)
-  (if (mark-line mark)
-      (let* ((line (mark-line mark))
-	     (chars (line-chars line))
-	     (charpos (mark-charpos mark))
-	     (length (line-length line)))
-	(declare (simple-string chars))
-	(cond ((or (> charpos length) (< charpos 0))
-	       (write-string "{bad mark}" stream))
-	      ((eq line open-line)
-	       (cond ((< charpos left-open-pos)
-		      (write-string open-chars stream  :start charpos
-				    :end left-open-pos)
-		      (write-string open-chars stream  :start right-open-pos
-				    :end line-cache-length))
-		     (t
-		      (let ((p (+ charpos (- right-open-pos left-open-pos))))
-			(write-string open-chars stream :start p
-				      :end line-cache-length)))))
-	      (t
-	       (write-string chars stream  :start charpos  :end length))))
-      (write-string "{deleted mark}" stream)))
-
-(defun %print-hline (structure stream d)
-  (declare (ignore d))
-  (write-string "#<Hemlock Line \"" stream)
-  (%print-whole-line structure stream)
-  (write-string "\">" stream))
-
-(defun %print-hmark (structure stream d)
-  (declare (ignore d))
-  (write-string "#<Hemlock Mark \"" stream)
-  (%print-before-mark structure stream)
-  (write-string "/\\" stream)
-  (%print-after-mark structure stream)
-  (write-string "\">" stream))  
-
-(defvar *print-region* 10
-  "The number of lines to print out of a region, or NIL if none.")
-
-(defun %print-hregion (region stream d)
-  (declare (ignore d))
-  (write-string "#<Hemlock Region \"" stream)
-  (let* ((start (region-start region))
-	 (end (region-end region))
-	 (first-line (mark-line start))
-	 (last-line (mark-line end)))
-    (cond
-     ((not (and (linep first-line) (linep last-line)
-		(eq (line-%buffer first-line) (line-%buffer last-line))
-		(mark<= start end)))
-      (write-string "{bad region}" stream))
-     (*print-region*
-      (cond ((eq first-line last-line)
-	     (let ((cs (mark-charpos start))
-		   (ce (mark-charpos end))
-		   (len (line-length first-line)))
-	       (cond
-		((or (< cs 0) (> ce len))
-		 (write-string "{bad region}" stream))
-		((eq first-line open-line)
-		 (let ((gap (- right-open-pos left-open-pos)))
-		   (cond
-		    ((<= ce left-open-pos)
-		     (write-string open-chars stream  :start cs  :end ce))
-		    ((>= cs left-open-pos)
-		     (write-string open-chars stream  :start (+ cs gap)
-				   :end (+ ce gap)))
-		    (t
-		     (write-string open-chars stream :start cs
-				   :end left-open-pos)
-		     (write-string open-chars stream :start right-open-pos
-				   :end (+ gap ce))))))
-		(t
-		 (write-string (line-chars first-line) stream  :start cs
-			       :end ce)))))
-	    (t
-	     (%print-after-mark start stream)
-	     (write-char #\/ stream)
-	     (do ((line (line-next first-line) (line-next line))
-		  (last-line (mark-line end))
-		  (cnt *print-region* (1- cnt)))
-		 ((or (eq line last-line)
-		      (when (zerop cnt) (write-string "..." stream) t))
-		  (%print-before-mark end stream))
-	       (%print-whole-line line stream)
-	       (write-char #\/ stream)))))
-     (t
-      (write-string "{mumble}" stream))))
-  (write-string "\">" stream))
-
-(defun %print-hbuffer (structure stream d)
-  (declare (ignore d))
-  (write-string "#<Hemlock Buffer \"" stream)
-  (write-string (buffer-name structure) stream)
-  (write-string "\">" stream))
diff --git a/hemlock/htext3.lisp b/hemlock/htext3.lisp
deleted file mode 100644
index 9f40787392016618dfb9c51231cf3121e34577a9..0000000000000000000000000000000000000000
--- a/hemlock/htext3.lisp
+++ /dev/null
@@ -1,238 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/htext3.lisp,v 1.1.1.3 1991/11/09 03:05:36 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; More Hemlock Text-Manipulation functions.
-;;; Written by Skef Wholey.
-;;;
-;;; The code in this file implements the insert functions in the
-;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(insert-character insert-string insert-region ninsert-region))
-
-
-
-(defun insert-character (mark character)
-  "Inserts the Character at the specified Mark."
-  (declare (type base-char character))
-  (let* ((line (mark-line mark))
-	 (buffer (line-%buffer line)))
-    (modifying-buffer buffer
-      (modifying-line line mark)
-      (cond ((char= character #\newline)
-	     (let* ((next (line-next line))
-		    (new-chars (subseq (the simple-string open-chars)
-				       0 left-open-pos))
-		    (new-line (make-line :%buffer buffer
-					 :chars (decf *cache-modification-tick*)
-					 :previous line
-					 :next next)))
-	       (maybe-move-some-marks (charpos line new-line) left-open-pos
-				      (- charpos left-open-pos))
-	       (setf (line-%chars line) new-chars)
-	       (setf (line-next line) new-line)
-	       (if next (setf (line-previous next) new-line))
-	       (number-line new-line)
-	       (setq open-line new-line  left-open-pos 0)))
-	    (t
-	     (if (= right-open-pos left-open-pos)
-		 (grow-open-chars))
-	     
-	     (maybe-move-some-marks (charpos line) left-open-pos
-				    (1+ charpos))
-	     
-	     (cond
-	      ((eq (mark-%kind mark) :right-inserting)
-	       (decf right-open-pos)
-	       (setf (char (the simple-string open-chars) right-open-pos)
-		     character))
-	      (t
-	       (setf (char (the simple-string open-chars) left-open-pos)
-		     character)
-	       (incf left-open-pos))))))))
-
-
-(defun insert-string (mark string &optional (start 0) (end (length string)))
-  "Inserts the String at the Mark.  Do not use Start and End unless you
-  know what you're doing!"
-  (let* ((line (mark-line mark))
-	 (buffer (line-%buffer line))
-	 (string (coerce string 'simple-string)))
-    (declare (simple-string string))
-    (unless (zerop (- end start))
-      (modifying-buffer buffer
-	(modifying-line line mark)
-	(if (%sp-find-character string start end #\newline)
-	    (with-mark ((mark mark :left-inserting))
-	      (do ((left-index start (1+ right-index))
-		   (right-index
-		    (%sp-find-character string start end #\newline)
-		    (%sp-find-character string (1+ right-index) end #\newline)))
-		  ((null right-index)
-		   (if (/= left-index end)
-		       (insert-string mark string left-index end)))
-		(insert-string mark string left-index right-index)
-		(insert-character mark #\newline)))
-	    (let ((length (- end start)))
-	      (if (<= right-open-pos (+ left-open-pos end))
-		  (grow-open-chars (* (+ line-cache-length end) 2)))
-	      
-	      (maybe-move-some-marks (charpos line) left-open-pos
-				     (+ charpos length))
-	      (cond
-	       ((eq (mark-%kind mark) :right-inserting)
-		(let ((new (- right-open-pos length)))
-		  (%sp-byte-blt string start open-chars new right-open-pos)
-		  (setq right-open-pos new)))
-	       (t
-		(let ((new (+ left-open-pos length)))
-		  (%sp-byte-blt string start open-chars left-open-pos new)
-		  (setq left-open-pos new))))))))))
-
-
-(defconstant line-number-interval-guess 8
-  "Our first guess at how we should number an inserted region's lines.")
-
-(defun insert-region (mark region)
-  "Inserts the given Region at the Mark."
-  (let* ((start (region-start region))
-	 (end (region-end region))
-	 (first-line (mark-line start))
-	 (last-line (mark-line end))
-	 (first-charpos (mark-charpos start))
-	 (last-charpos (mark-charpos end)))
-    (cond
-     ((eq first-line last-line)
-      ;; simple case -- just BLT the characters in with insert-string
-      (if (eq first-line open-line) (close-line))
-      (insert-string mark (line-chars first-line) first-charpos last-charpos))
-     (t
-      (close-line)
-      (let* ((line (mark-line mark))
-	     (next (line-next line))
-	     (charpos (mark-charpos mark))
-	     (buffer (line-%buffer line))
-	     (old-chars (line-chars line)))
-	(declare (simple-string old-chars))
-	(modifying-buffer buffer
-	  ;;hack marked line's chars
-	  (let* ((first-chars (line-chars first-line))
-		 (first-length (length first-chars))
-		 (new-length (+ charpos (- first-length first-charpos)))
-		 (new-chars (make-string new-length)))
-	    (declare (simple-string first-chars new-chars))
-	    (%sp-byte-blt old-chars 0 new-chars 0 charpos)
-	    (%sp-byte-blt first-chars first-charpos new-chars charpos new-length)
-	    (setf (line-chars line) new-chars))
-	  
-	  ;; Copy intervening lines.  We don't link the lines in until we are
-	  ;; done in case the mark is within the region we are inserting.
-	  (do* ((this-line (line-next first-line) (line-next this-line))
-		(number (+ (line-number line) line-number-interval-guess)
-			(+ number line-number-interval-guess))
-		(first (%copy-line this-line  :previous line
-				   :%buffer buffer  :number number))
-		(previous first)
-		(new-line first (%copy-line this-line  :previous previous
-					    :%buffer buffer  :number number)))
-	       ((eq this-line last-line)
-		;;make last line
-		(let* ((last-chars (line-chars new-line))
-		       (old-length (length old-chars))
-		       (new-length (+ last-charpos (- old-length charpos)))
-		       (new-chars (make-string new-length)))
-		  (%sp-byte-blt last-chars 0 new-chars 0 last-charpos)
-		  (%sp-byte-blt old-chars charpos new-chars last-charpos
-				new-length)
-		  (setf (line-next line) first)
-		  (setf (line-chars new-line) new-chars)
-		  (setf (line-next previous) new-line)
-		  (setf (line-next new-line) next)
-		  (when next
-		    (setf (line-previous next) new-line)
-		    (if (<= (line-number next) number)
-			(renumber-region-containing new-line)))
-		  ;;fix up the marks
-		  (maybe-move-some-marks (this-charpos line new-line) charpos
-		    (+ last-charpos (- this-charpos charpos)))))
-	    (setf (line-next previous) new-line  previous new-line))))))))
-
-(defun ninsert-region (mark region)
-  "Inserts the given Region at the Mark, possibly destroying the Region.
-  Region may not be a part of any buffer's region."
-  (let* ((start (region-start region))
-	 (end (region-end region))
-	 (first-line (mark-line start))
-	 (last-line (mark-line end))
-	 (first-charpos (mark-charpos start))
-	 (last-charpos (mark-charpos end)))
-    (cond
-     ((eq first-line last-line)
-      ;; Simple case -- just BLT the characters in with insert-string.
-      (if (eq first-line open-line) (close-line))
-      (insert-string mark (line-chars first-line) first-charpos last-charpos))
-     (t
-      (when (bufferp (line-%buffer first-line))
-	(error "Region is linked into Buffer ~S." (line-%buffer first-line)))
-      (close-line)
-      (let* ((line (mark-line mark))
-	     (second-line (line-next first-line))
-	     (next (line-next line))
-	     (charpos (mark-charpos mark))
-	     (buffer (line-%buffer line))
-	     (old-chars (line-chars line)))
-	(declare (simple-string old-chars))
-	(modifying-buffer buffer
-	  ;; Make new chars for first and last lines.
-	  (let* ((first-chars (line-chars first-line))
-		 (first-length (length first-chars))
-		 (new-length (+ charpos (- first-length first-charpos)))
-		 (new-chars (make-string new-length)))
-	    (declare (simple-string first-chars new-chars))
-	    (%sp-byte-blt old-chars 0 new-chars 0 charpos)
-	    (%sp-byte-blt first-chars first-charpos new-chars charpos
-			  new-length)
-	    (setf (line-chars line) new-chars))
-	  (let* ((last-chars (line-chars last-line))
-		 (old-length (length old-chars))
-		 (new-length (+ last-charpos (- old-length charpos)))
-		 (new-chars (make-string new-length)))
-	    (%sp-byte-blt last-chars 0 new-chars 0 last-charpos)
-	    (%sp-byte-blt old-chars charpos new-chars last-charpos new-length)
-	    (setf (line-chars last-line) new-chars))
-	  
-	  ;;; Link stuff together.
-	  (setf (line-next last-line) next)
-	  (setf (line-next line) second-line)
-	  (setf (line-previous second-line) line)
-
-	  ;;Number the inserted stuff and mash any marks.
-	  (do ((line second-line (line-next line))
-	       (number (+ (line-number line) line-number-interval-guess)
-		       (+ number line-number-interval-guess)))
-	      ((eq line next)
-	       (when next
-		 (setf (line-previous next) last-line)	       
-		 (if (<= (line-number next) number)
-		     (renumber-region-containing last-line))))
-	    (when (line-marks line)
-	      (dolist (m (line-marks line))
-		(setf (mark-line m) nil))
-	      (setf (line-marks line) nil))
-	    (setf (line-number line) number  (line-%buffer line) buffer))
-	  
-	  ;; Fix up the marks in the line inserted into.
-	  (maybe-move-some-marks (this-charpos line last-line) charpos
-	    (+ last-charpos (- this-charpos charpos)))))))))
diff --git a/hemlock/htext4.lisp b/hemlock/htext4.lisp
deleted file mode 100644
index fcf4fba9c06c03efe558202817f006b9401719c7..0000000000000000000000000000000000000000
--- a/hemlock/htext4.lisp
+++ /dev/null
@@ -1,419 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/htext4.lisp,v 1.2 1991/02/08 16:35:14 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; More Hemlock Text-Manipulation functions.
-;;; Written by Skef Wholey and Rob MacLachlan.
-;;; Modified by Bill Chiles.
-;;; 
-;;; The code in this file implements the delete and copy functions in the
-;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(delete-characters delete-region delete-and-save-region copy-region
-			    filter-region))
-
-
-
-;;;; DELETE-CHARACTERS.
-
-(defvar *internal-temp-region* (make-empty-region))
-(defvar *internal-temp-mark* (internal-make-mark nil nil :temporary))
-
-(defun delete-characters (mark &optional (n 1))
-  "Deletes N characters after the mark (or -N before if N is negative)."
-  (let* ((line (mark-line mark))
-	 (charpos (mark-charpos mark))
-	 (length (line-length* line)))
-    (cond
-     ((zerop n) t)
-     ;; Deleting chars on one line, just bump the pointers.
-     ((<= 0 (+ charpos n) length)
-      (modifying-buffer (line-%buffer line)
-	(modifying-line line mark)
-	(cond
-	 ((minusp n)
-	  (setq left-open-pos (+ left-open-pos n))
-	  (move-some-marks (pos line)
-	    (if (> pos left-open-pos)
-		(if (<= pos charpos) left-open-pos (+ pos n))
-		pos)))
-	 
-	 (t
-	  (setq right-open-pos (+ right-open-pos n))
-	  (let ((bound (+ charpos n)))
-	    (move-some-marks (pos line)
-	      (if (> pos charpos)
-		  (if (<= pos bound) left-open-pos (- pos n))
-		  pos))))) t))
-
-     ;; Deleting some newlines, punt out to delete-region.
-     (t
-      (setf (mark-line *internal-temp-mark*) line
-	    (mark-charpos *internal-temp-mark*) charpos)
-      (let ((other-mark (character-offset *internal-temp-mark* n)))
-	(cond
-	 (other-mark
-	  (if (< n 0)
-	      (setf (region-start *internal-temp-region*) other-mark
-		    (region-end *internal-temp-region*) mark)
-	      (setf (region-start *internal-temp-region*) mark
-		    (region-end *internal-temp-region*) other-mark))
-	  (delete-region *internal-temp-region*) t)
-	 (t nil)))))))
-
-
-
-;;;; DELETE-REGION.
-
-(defun delete-region (region)
-  "Deletes the Region."
-  (let* ((start (region-start region))
-	 (end (region-end region))
-	 (first-line (mark-line start))
-	 (last-line (mark-line end))
-	 (first-charpos (mark-charpos start))
-	 (last-charpos (mark-charpos end))
-	 (buffer (line-%buffer first-line)))
-    (unless (and (eq first-line last-line)
-		 (= first-charpos last-charpos))
-      (modifying-buffer buffer
-	(cond ((eq first-line last-line)
-	       ;; Simple case -- just skip over the characters:
-	       (modifying-line first-line start)
-	       (let ((num (- last-charpos first-charpos)))
-		 (setq right-open-pos (+ right-open-pos num))
-		 ;; and fix up any marks in there:
-		 (move-some-marks (charpos first-line)
-		   (if (> charpos first-charpos)
-		       (if (<= charpos last-charpos) 
-			   first-charpos
-			   (- charpos num))
-		       charpos))))
-	      (t
-	       ;; hairy case -- squish lines together:
-	       (close-line)
-	       (let* ((first-chars (line-chars first-line))
-		      (last-chars (line-chars last-line))
-		      (last-length (length last-chars)))
-		 (declare (simple-string last-chars first-chars))
-		 ;; Cons new chars for the first line.
-		 (let* ((length (+ first-charpos (- last-length last-charpos)))
-			(new-chars (make-string length)))
-		   (%sp-byte-blt first-chars 0 new-chars 0 first-charpos)
-		   (%sp-byte-blt last-chars last-charpos new-chars first-charpos
-				 length)
-		   (setf (line-chars first-line) new-chars))
-		 ;; fix up the first line's marks:
-		 (move-some-marks (charpos first-line)
-		   (if (> charpos first-charpos)
-		       first-charpos
-		       charpos))
-		 ;; fix up the marks of the lines in the middle and mash
-		 ;;line-%buffer:
-		 (do* ((line (line-next first-line) (line-next line))
-		       (count (incf *disembodied-buffer-counter*)))
-		      ((eq line last-line)
-		       (setf (line-%buffer last-line) count))
-		   (setf (line-%buffer line) count)
-		   (move-some-marks (ignore line first-line)
-		     (declare (ignore ignore))
-		     first-charpos))
-		 ;; and fix up the last line's marks:
-		 (move-some-marks (charpos last-line first-line)
-		   (if (<= charpos last-charpos)
-		       first-charpos
-		       (+ (- charpos last-charpos)
-			  first-charpos)))
-		 ;; And splice the losers out:
-		 (let ((next (line-next last-line)))
-		   (setf (line-next first-line) next)
-		   (when next (setf (line-previous next) first-line))))))))))
-
-
-
-;;;; DELETE-AND-SAVE-REGION.
-
-(defun delete-and-save-region (region)
-  "Deletes Region and returns a region containing the deleted characters."
-  (let* ((start (region-start region))
-	 (end (region-end region))
-	 (first-line (mark-line start))
-	 (last-line (mark-line end))
-	 (first-charpos (mark-charpos start))
-	 (last-charpos (mark-charpos end))
-	 (buffer (line-%buffer first-line)))
-    (cond
-     ((and (eq first-line last-line)
-	   (= first-charpos last-charpos))
-      (make-empty-region))
-     (t
-      (modifying-buffer buffer
-	(cond ((eq first-line last-line)
-	       ;; simple case -- just skip over the characters:
-	       (modifying-line first-line start)
-	       (let* ((num (- last-charpos first-charpos))
-		      (new-right (+ right-open-pos num))
-		      (new-chars (make-string num))
-		      (new-line (make-line
-				 :chars new-chars  :number 0
-				 :%buffer (incf *disembodied-buffer-counter*))))
-		 (declare (simple-string new-chars))
-		 (%sp-byte-blt open-chars right-open-pos new-chars 0 num) 
-		 (setq right-open-pos new-right)
-		 ;; and fix up any marks in there:
-		 (move-some-marks (charpos first-line)
-		   (if (> charpos first-charpos)
-		       (if (<= charpos last-charpos)
-			   first-charpos
-			   (- charpos num))
-		       charpos))
-		 ;; And return the region with the nuked characters:
-		 (internal-make-region (mark new-line 0 :right-inserting)
-				       (mark new-line num :left-inserting))))
-	      (t
-	       ;; hairy case -- squish lines together:
-	       (close-line)
-	       (let* ((first-chars (line-chars first-line))
-		      (last-chars (line-chars last-line))
-		      (first-length (length first-chars))
-		      (last-length (length last-chars))
-		      (saved-first-length (- first-length first-charpos))
-		      (saved-first-chars (make-string saved-first-length))
-		      (saved-last-chars (make-string last-charpos))
-		      (count (incf *disembodied-buffer-counter*))
-		      (saved-line (make-line :chars saved-first-chars
-					     :%buffer count)))
-		 (declare (simple-string first-chars last-chars
-					 saved-first-chars saved-last-chars))
-		 ;; Cons new chars for victim line.
-		 (let* ((length (+ first-charpos (- last-length last-charpos)))
-			(new-chars (make-string length)))
-		   (%sp-byte-blt first-chars 0 new-chars 0 first-charpos)
-		   (%sp-byte-blt last-chars last-charpos new-chars first-charpos
-				 length)
-		   (setf (line-chars first-line) new-chars))
-		 ;; Make a region with all the lost stuff:
-		 (%sp-byte-blt first-chars first-charpos saved-first-chars 0
-			       saved-first-length)
-		 (%sp-byte-blt last-chars 0 saved-last-chars 0 last-charpos)
-		 ;; Mash the chars and buff of the last line.
-		 (setf (line-chars last-line) saved-last-chars
-		       (line-%buffer last-line) count)
-		 ;; fix up the marks of the lines in the middle and mash
-		 ;;line-%buffer:
-		 (do ((line (line-next first-line) (line-next line)))
-		     ((eq line last-line)
-		      (setf (line-%buffer last-line) count))
-		   (setf (line-%buffer line) count)
-		   (move-some-marks (ignore line first-line)
-		     (declare (ignore ignore))
-		     first-charpos))
-		 ;; And splice the losers out:
-		 (let ((next (line-next first-line))
-		       (after (line-next last-line)))
-		   (setf (line-next saved-line) next
-			 (line-previous next) saved-line
-			 (line-next first-line) after)
-		   (when after
-		     (setf (line-previous after) first-line
-			   (line-next last-line) nil)))
-		 
-		 ;; fix up the first line's marks:
-		 (move-some-marks (charpos first-line)
-		   (if (> charpos first-charpos)
-		       first-charpos
-		       charpos))
-		 ;; and fix up the last line's marks:
-		 (move-some-marks (charpos last-line first-line)
-		   (if (<= charpos last-charpos)
-		       first-charpos
-		       (+ (- charpos last-charpos)
-			  first-charpos)))
-		 ;; And return the region with the nuked characters:
-		 (renumber-region
-		  (internal-make-region
-		   (mark saved-line 0 :right-inserting)
-		   (mark last-line last-charpos :left-inserting)))))))))))
-
-
-
-;;;; COPY-REGION.
-
-(defun copy-region (region)
-  "Returns a region containing a copy of the text within Region."
-  (let* ((start (region-start region))
-	 (end (region-end region))
-	 (first-line (mark-line start))
-	 (last-line (mark-line end))
-	 (first-charpos (mark-charpos start))
-	 (last-charpos (mark-charpos end))
-	 (count (incf *disembodied-buffer-counter*)))
-    (cond
-     ((eq first-line last-line)
-      (when (eq first-line open-line) (close-line))
-      (let* ((length (- last-charpos first-charpos))
-	     (chars (make-string length))
-	     (line (make-line :chars chars  :%buffer count  :number 0)))
-	(%sp-byte-blt (line-chars first-line) first-charpos chars 0 length)
-	(internal-make-region (mark line 0 :right-inserting)
-			      (mark line length :left-inserting))))
-     (t
-      (close-line)
-      (let* ((first-chars (line-chars first-line))
-	     (length (- (length first-chars) first-charpos))
-	     (chars (make-string length))
-	     (first-copied-line (make-line :chars chars  :%buffer count
-					   :number 0)))
-	(declare (simple-string first-chars))
-	(%sp-byte-blt first-chars first-charpos chars 0 length)
-	(do ((line (line-next first-line) (line-next line))
-	     (previous first-copied-line)
-	     (number line-increment (+ number line-increment)))
-	    ((eq line last-line)
-	     (let* ((chars (make-string last-charpos))
-		    (last-copied-line (make-line :chars chars
-						 :number number
-						 :%buffer count
-						 :previous previous)))
-	       (%sp-byte-blt (line-chars last-line) 0 chars 0 last-charpos)
-	       (setf (line-next previous) last-copied-line)
-	       (internal-make-region
-		(mark first-copied-line 0 :right-inserting)
-		(mark last-copied-line last-charpos :left-inserting))))
-	  (let* ((new-line (%copy-line line :%buffer count
-				       :number number
-				       :previous previous)))
-	    (setf (line-next previous) new-line)
-	    (setq previous new-line))))))))
-
-
-
-;;;; FILTER-REGION.
-
-(eval-when (compile eval)
-(defmacro fcs (fun str)
-  `(let ((rs (funcall ,fun ,str)))
-     (if (simple-string-p rs) rs
-	 (coerce rs 'simple-string))))
-); eval-when (compile eval)
-
-;;; FILTER-REGION  --  Public
-;;;
-;;;    After we deal with the nasty boundry conditions of the first and
-;;; last lines, we just scan through lines in the region replacing their
-;;; chars with the result of applying the function to the chars.
-;;;
-(defun filter-region (function region)
-  "This function filters the text in a region though a Lisp function.  The
-   argument function must map from a string to a string.  It is passed each
-   line string from region in order, and each resulting string replaces the
-   original.  The function must neither destructively modify its argument nor
-   modify the result string after it is returned.  The argument will always be
-   a simple-string.  It is an error for any string returned to contain
-   newlines."
-  (let* ((start (region-start region))
-	 (start-line (mark-line start))
-	 (first (mark-charpos start))
-	 (end (region-end region))
-	 (end-line (mark-line end))
-	 (last (mark-charpos end))
-	 (marks ()))
-    (modifying-buffer (line-%buffer start-line)
-      (modifying-line end-line end)
-      (cond ((eq start-line end-line)
-	     (let* ((res (fcs function (subseq open-chars first last)))
-		    (rlen (length res))
-		    (new-left (+ first rlen))
-		    (delta (- new-left left-open-pos)))
-	       (declare (simple-string res))
-	       (when (> new-left right-open-pos)
-		 (grow-open-chars (+ new-left line-cache-length)))
-	       (%sp-byte-blt res 0 open-chars first left-open-pos)
-	       ;;
-	       ;; Move marks to start or end of region, depending on kind.
-	       (dolist (m (line-marks start-line))
-		 (let ((charpos (mark-charpos m)))
-		   (when (>= charpos first)
-		     (setf (mark-charpos m)
-			   (if (<= charpos last)
-			       (if (eq (mark-%kind m) :left-inserting)
-				   new-left first)
-			       (+ charpos delta))))))
-	       (setq left-open-pos new-left)))
-	    (t
-	     ;;
-	     ;; Do the chars for the first line.
-	     (let* ((first-chars (line-chars start-line))
-		    (first-len (length first-chars))
-		    (res (fcs function (subseq first-chars first first-len)))
-		    (rlen (length res))
-		    (nlen (+ first rlen))
-		    (new (make-string nlen)))
-	       (declare (simple-string res first-chars new))
-	       (%sp-byte-blt first-chars 0 new 0 first)
-	       (%sp-byte-blt res 0 new first nlen)
-	       (setf (line-%chars start-line) new))
-	     ;;
-	     ;; Fix up marks on the first line, saving any within the region
-	     ;; to be dealt with later.
-	     (let ((outside ()))
-	       (dolist (m (line-marks start-line))
-		 (if (<= (mark-charpos m) first)
-		     (push m outside) (push m marks)))
-	       (setf (line-marks start-line) outside))
-	     ;;
-	     ;; Do chars of intermediate lines in the region, saving their
-	     ;; marks.
-	     (do ((line (line-next start-line) (line-next line)))
-		 ((eq line end-line))
-	       (when (line-marks line)
-		 (setq marks (nconc (line-marks line) marks))
-		 (setf (line-marks line) nil))
-	       (setf (line-%chars line) (fcs function (line-chars line))))
-	     ;;
-	     ;; Do the last line, which is cached.
-	     (let* ((res (fcs function (subseq (the simple-string open-chars)
-					       0 last)))
-		    (rlen (length res))
-		    (delta (- rlen last)))
-	       (declare (simple-string res))
-	       (when (> rlen right-open-pos)
-		 (grow-open-chars (+ rlen line-cache-length)))
-	       (%sp-byte-blt res 0 open-chars 0 rlen)
-	       (setq left-open-pos rlen)
-	       ;;
-	       ;; Adjust marks after the end of the region and save ones in it.
-	       (let ((outside ()))
-		 (dolist (m (line-marks end-line))
-		   (let ((charpos (mark-charpos m)))
-		     (cond ((> charpos last)
-			    (setf (mark-charpos m) (+ charpos delta))
-			    (push m outside))
-			   (t
-			    (push m marks)))))
-		 (setf (line-marks end-line) outside))
-	       ;;
-	       ;; Scan over saved marks, moving them to the correct end of the
-	       ;; region.
-	       (dolist (m marks)
-		 (cond ((eq (mark-%kind m) :left-inserting)
-			(setf (mark-charpos m) rlen)
-			(setf (mark-line m) end-line)
-			(push m (line-marks end-line)))
-		       (t
-			(setf (mark-charpos m) first)
-			(setf (mark-line m) start-line)
-			(push m (line-marks start-line)))))))))
-    region))
diff --git a/hemlock/hunk-draw.lisp b/hemlock/hunk-draw.lisp
deleted file mode 100644
index 0dd45c698ebca07e285ab71e21fe1ae5d9b010da..0000000000000000000000000000000000000000
--- a/hemlock/hunk-draw.lisp
+++ /dev/null
@@ -1,474 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/hunk-draw.lisp,v 1.3 1991/02/08 16:35:17 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Bill Chiles and Rob MacLachlan.
-;;;
-;;; Hemlock screen painting routines for the IBM RT running X.
-;;;
-(in-package 'hemlock-internals)
-
-
-(defparameter hunk-height-limit 80 "Maximum possible height for any hunk.")
-(defparameter hunk-width-limit 200 "Maximum possible width for any hunk.")
-(defparameter hunk-top-border 2 "Clear area at beginning.")
-(defparameter hunk-left-border 1 "Clear area before first character.")
-(defparameter hunk-bottom-border 3 "Minimum Clear area at end.")
-(defparameter hunk-thumb-bar-bottom-border 10
-  "Minimum Clear area at end including room for thumb bar." )
-(defparameter hunk-modeline-top 2 "Extra black pixels above modeline chars.")
-(defparameter hunk-modeline-bottom 2 "Extra black pixels below modeline chars.")
-
-
-
-;;;; Character translations for CLX
-
-;;; HEMLOCK-TRANSLATE-DEFAULT.
-;;;
-;;; CLX glyph drawing routines allow for a character translation function.  The
-;;; default one takes a string (any kind) or a vector of numbers and slams them
-;;; into the outgoing request buffer.  When the argument is a string, it stops
-;;; processing if it sees a character that is not GRAPHIC-CHAR-P.  For each
-;;; graphical character, the function ultimately calls CHAR-CODE.
-;;;
-;;; Hemlock only passes simple-strings in, and these can only contain graphical
-;;; characters because of the line image builder, except for one case --
-;;; *line-wrap-char* which anyone can set.  Those who want to do evil things
-;;; with this should know what they are doing: if they want a funny glyph as
-;;; a line wrap char, then they should use CODE-CHAR on the font index.  This
-;;; allows the following function to translate everything with CHAR-CODE, and
-;;; everybody's happy.
-;;;
-;;; Actually, Hemlock can passes the line string when doing random-typeout which
-;;; does contain ^L's, tabs, etc.  Under X10 these came out as funny glyphs,
-;;; and under X11 the output is aborted without this function.
-;;;
-(defun hemlock-translate-default (src src-start src-end font dst dst-start)
-  (declare (simple-string src)
-	   (fixnum src-start src-end dst-start)
-	   (vector dst)
-	   (ignore font))
-  (do ((i src-start (1+ i))
-       (j dst-start (1+ j)))
-      ((>= i src-end) i)
-    (declare (fixnum i j))
-    (setf (aref dst j) (char-code (schar src i)))))
-
-(defvar *glyph-translate-function* #'xlib:translate-default)
-
-
-
-;;;; Drawing a line.
-
-(eval-when (compile eval)
-
-;;; HUNK-PUT-STRING takes a character (x,y) pair and computes at which pixel
-;;; coordinate to draw string with font from start to end.  This macros assumes
-;;; hunk and font-family to be bound by the caller.
-;;; 
-(defmacro hunk-put-string (x y font string start end)
-  (let ((gcontext (gensym)))
-    `(let ((,gcontext (bitmap-hunk-gcontext hunk)))
-       (xlib:with-gcontext (,gcontext :font ,font)
-	 (xlib:draw-image-glyphs
-	  (bitmap-hunk-xwindow hunk) ,gcontext
-	  (+ hunk-left-border (* ,x (font-family-width font-family)))
-	  (+ hunk-top-border (* ,y (font-family-height font-family))
-	     (font-family-baseline font-family))
-	  ,string :start ,start :end ,end
-	  :translate *glyph-translate-function*)))))
-
-); eval-when (compile eval)
-
-
-;;; Hunk-Write-String  --  Internal
-;;;
-;;;    A historical vestige used by bitmap hunk streams.  Use default font (0),
-;;;    and bind font-family for HUNK-PUT-STRING.
-;;;
-(defun hunk-write-string (hunk x y string start end)
-  (let* ((font-family (bitmap-hunk-font-family hunk))
-	 (font (svref (font-family-map font-family) 0)))
-    (hunk-put-string x y font string start end)))
-
-
-;;; Hunk-Write-Line  --  Internal
-;;;
-;;;    Paint a dis-line on a hunk, taking font-changes into consideration.
-;;; The area of the hunk drawn on is assumed to be cleared.  If supplied,
-;;; the line is written at Position, and the position in the dis-line
-;;; is ignored.
-;;;
-(defun hunk-write-line (hunk dl &optional
-			     (position (dis-line-position dl)))
-  (let* ((font-family (bitmap-hunk-font-family hunk))
-	 (map (font-family-map font-family))
-	 (chars (dis-line-chars dl))
-	 (length (dis-line-length dl)))
-    (let ((last 0)
-	  (last-font (svref map 0)))
-      (do ((change (dis-line-font-changes dl) (font-change-next change)))
-	  ((null change)
-	   (hunk-put-string last position last-font chars last length))
-	(let ((x (font-change-x change)))
-	  (hunk-put-string last position last-font chars last x)
-	  (setq last x  last-font (svref map (font-change-font change))))))))
-
-
-;;; We hack this since the X11 server's aren't clever about DRAW-IMAGE-GLYPHS;
-;;; that is, they literally clear the line, and then blast the new glyphs.
-;;; We don't hack replacing the line when reverse video is turned on because
-;;; this doesn't seem to work too well.  Also, hacking replace line on the
-;;; color Megapel display is SLOW!
-;;;
-(defvar *hack-hunk-replace-line* t)
-
-;;; Hunk-Replace-Line  --  Internal
-;;;
-;;;    Similar to Hunk-Write-Line, but the line need not be clear.
-;;;
-(defun hunk-replace-line (hunk dl &optional
-			       (position (dis-line-position dl)))
-  (if *hack-hunk-replace-line*
-      (hunk-replace-line-on-a-pixmap hunk dl position)
-      (old-hunk-replace-line hunk dl position)))
-
-(defun old-hunk-replace-line (hunk dl &optional
-				   (position (dis-line-position dl)))
-  (let* ((font-family (bitmap-hunk-font-family hunk))
-	 (map (font-family-map font-family))
-	 (chars (dis-line-chars dl))
-	 (length (dis-line-length dl))
-	 (height (font-family-height font-family)))
-    (let ((last 0)
-	  (last-font (svref map 0)))
-      (do ((change (dis-line-font-changes dl) (font-change-next change)))
-	  ((null change)
-	   (hunk-put-string last position last-font chars last length)
-	   (let ((dx (+ hunk-left-border
-			(* (font-family-width font-family) length))))
-	     (xlib:clear-area (bitmap-hunk-xwindow hunk)
-			      :x dx
-			      :y (+ hunk-top-border (* position height))
-			      :width (- (bitmap-hunk-width hunk) dx)
-			      :height height)))
-	(let ((x (font-change-x change)))
-	  (hunk-put-string last position last-font chars last x)
-	  (setq last x  last-font (svref map (font-change-font change))))))))
-
-(defvar *hunk-replace-line-pixmap* nil)
-
-(defun hunk-replace-line-pixmap ()
-  (if *hunk-replace-line-pixmap*
-      *hunk-replace-line-pixmap*
-      (let* ((hunk (window-hunk *current-window*))
-	     (gcontext (bitmap-hunk-gcontext hunk))
-	     (screen (xlib:display-default-screen
-		      (bitmap-device-display (device-hunk-device hunk))))
-	     (height (font-family-height *default-font-family*))
-	     (pixmap (xlib:create-pixmap
-		     :width (* hunk-width-limit
-			       (font-family-width *default-font-family*))
-		     :height height :depth (xlib:screen-root-depth screen)
-		     :drawable (xlib:screen-root screen))))
-	(xlib:with-gcontext (gcontext :function boole-1
-				      :foreground *default-background-pixel*)
-	  (xlib:draw-rectangle pixmap gcontext 0 0 hunk-left-border height t))
-	(setf *hunk-replace-line-pixmap* pixmap))))
-
-
-(eval-when (compile eval)
-
-;;; HUNK-REPLACE-LINE-STRING takes a character (x,y) pair and computes at which
-;;; pixel coordinate to draw string with font from start to end.  This macros
-;;; assumes hunk and font-family to be bound by the caller.  We draw the text
-;;; on a pixmap and later blast it out to avoid line flicker since server on
-;;; the RT is not very clever; it clears the entire line before drawing text.
-;;;
-(defmacro hunk-replace-line-string (x y font string start end)
-  (declare (ignore y))
-  `(xlib:with-gcontext (gcontext :font ,font)
-     (xlib:draw-image-glyphs
-      (hunk-replace-line-pixmap) gcontext
-      (+ hunk-left-border (* ,x (font-family-width font-family)))
-      (font-family-baseline font-family)
-      ,string :start ,start :end ,end
-      :translate *glyph-translate-function*)))
-) ;eval-when
-
-(defun hunk-replace-line-on-a-pixmap (hunk dl position)
-  (let* ((font-family (bitmap-hunk-font-family hunk))
-	 (map (font-family-map font-family))
-	 (chars (dis-line-chars dl))
-	 (length (dis-line-length dl))
-	 (height (font-family-height font-family))
-	 (last 0)
-	 (last-font (svref map 0))
-	 (gcontext (bitmap-hunk-gcontext hunk)))
-    (do ((change (dis-line-font-changes dl) (font-change-next change)))
-	((null change)
-	 (hunk-replace-line-string last position last-font chars last length)
-	 (let* ((dx (+ hunk-left-border
-		       (* (font-family-width font-family) length)))
-		(dy (+ hunk-top-border (* position height)))
-		(xwin (bitmap-hunk-xwindow hunk)))
-	   (xlib:with-gcontext (gcontext :exposures nil)
-	     (xlib:copy-area (hunk-replace-line-pixmap) gcontext
-			     0 0 dx height xwin 0 dy))
-	   (xlib:clear-area xwin :x dx :y dy
-			    :width (- (bitmap-hunk-width hunk) dx)
-			    :height height)))
-      (let ((x (font-change-x change)))
-	(hunk-replace-line-string last position last-font chars last x)
-	(setq last x  last-font (svref map (font-change-font change)))))))
-
-
-;;; HUNK-REPLACE-MODELINE sets the entire mode line to the the foreground
-;;; color, so the initial bits where no characters go also is highlighted.
-;;; Then the text is drawn background on foreground (hightlighted).  This
-;;; function assumes that BITMAP-HUNK-MODELINE-POS will not return nil;
-;;; that is, there is a modeline.  This function should assume the gcontext's
-;;; font is the default font of the hunk.  We must LET bind the foreground and
-;;; background values before entering XLIB:WITH-GCONTEXT due to a non-obvious
-;;; or incorrect implementation.
-;;; 
-(defun hunk-replace-modeline (hunk)
-  (let* ((dl (bitmap-hunk-modeline-dis-line hunk))
-	 (font-family (bitmap-hunk-font-family hunk))
-	 (default-font (svref (font-family-map font-family) 0))
-	 (modeline-pos (bitmap-hunk-modeline-pos hunk))
-	 (xwindow (bitmap-hunk-xwindow hunk))
-	 (gcontext (bitmap-hunk-gcontext hunk)))
-    (xlib:draw-rectangle xwindow gcontext 0 modeline-pos
-			 (bitmap-hunk-width hunk)
-			 (+ hunk-modeline-top hunk-modeline-bottom
-			    (font-family-height font-family))
-			 t)
-    (xlib:with-gcontext (gcontext :foreground
-				  (xlib:gcontext-background gcontext)
-				  :background
-				  (xlib:gcontext-foreground gcontext)
-				  :font default-font)
-      (xlib:draw-image-glyphs xwindow gcontext hunk-left-border
-			      (+ modeline-pos hunk-modeline-top
-				 (font-family-baseline font-family))
-			      (dis-line-chars dl)
-			      :end (dis-line-length dl)
-			      :translate *glyph-translate-function*))))
-#|
-(defun hunk-replace-modeline (hunk)
-  (let* ((dl (bitmap-hunk-modeline-dis-line hunk))
-	 (font-family (bitmap-hunk-font-family hunk))
-	 (default-font (svref (font-family-map font-family) 0))
-	 (modeline-pos (bitmap-hunk-modeline-pos hunk))
-	 (xwindow (bitmap-hunk-xwindow hunk))
-	 (gcontext (bitmap-hunk-gcontext hunk)))
-    (xlib:draw-rectangle xwindow gcontext 0 modeline-pos
-			 (bitmap-hunk-width hunk)
-			 (+ hunk-modeline-top hunk-modeline-bottom
-			    (font-family-height font-family))
-			 t)
-    (let ((foreground (xlib:gcontext-background gcontext))
-	  (background (xlib:gcontext-foreground gcontext)))
-      (xlib:with-gcontext (gcontext :foreground foreground
-				    :background background
-				    :font default-font)
-	(xlib:draw-image-glyphs xwindow gcontext hunk-left-border
-				(+ modeline-pos hunk-modeline-top
-				   (font-family-baseline font-family))
-				(dis-line-chars dl)
-				:end (dis-line-length dl)
-				:translate *glyph-translate-function*)))))
-|#
-
-
-;;;; Cursor/Border color manipulation.
-
-;;; *hemlock-listener* is set to t by default because we can't know from X
-;;; whether we come up with the pointer in our window.  There is no initial
-;;; :enter-window event.  Defaulting this to nil causes the cursor to be hollow
-;;; when the window comes up under the mouse, and you have to know how to fix
-;;; it.  Defaulting it to t causes the cursor to always come up full, as if
-;;; Hemlock is the X listener, but this recovers naturally as you move into the
-;;; window.  This also coincides with Hemlock's border coming up highlighted,
-;;; even when Hemlock is not the listener.
-;;;
-(defvar *hemlock-listener* t
-  "Highlight border when the cursor is dropped and Hemlock can receive input.")
-(defvar *current-highlighted-border* nil
-  "When non-nil, the bitmap-hunk with the highlighted border.")
-
-(defvar *hunk-cursor-x* 0 "The current cursor X position in pixels.")
-(defvar *hunk-cursor-y* 0 "The current cursor Y position in pixels.")
-(defvar *cursor-hunk* nil "Hunk the cursor is displayed on.")
-(defvar *cursor-dropped* nil) ; True if the cursor is currently displayed.
-
-;;; HUNK-SHOW-CURSOR locates the cursor at character position (x,y) in hunk.
-;;; If the cursor is currently displayed somewhere, then lift it, and display
-;;; it at its new location.
-;;; 
-(defun hunk-show-cursor (hunk x y)
-  (unless (and (= x *hunk-cursor-x*)
-	       (= y *hunk-cursor-y*)
-	       (eq hunk *cursor-hunk*))
-    (let ((cursor-down *cursor-dropped*))
-      (when cursor-down (lift-cursor))
-      (setf *hunk-cursor-x* x)
-      (setf *hunk-cursor-y* y)
-      (setf *cursor-hunk* hunk)
-      (when cursor-down (drop-cursor)))))
-
-;;; FROB-CURSOR is the note-read-wait method for bitmap redisplay.  We
-;;; show a cursor and highlight the listening window's border when waiting
-;;; for input.
-;;; 
-(defun frob-cursor (on)
-  (if on (drop-cursor) (lift-cursor)))
-
-(proclaim '(special *default-border-pixmap* *highlight-border-pixmap*))
-
-;;; DROP-CURSOR and LIFT-CURSOR are separate functions from FROB-CURSOR
-;;; because they are called a couple places (e.g., HUNK-EXPOSED-REGION
-;;; and SMART-WINDOW-REDISPLAY).  When the cursor is being dropped, since
-;;; this means Hemlock is listening in the *cursor-hunk*, make sure the
-;;; border of the window is highlighted as well.
-;;;
-(defun drop-cursor ()
-  (unless *cursor-dropped*
-    (unless *hemlock-listener* (cursor-invert-center))
-    (cursor-invert)
-    (when *hemlock-listener*
-      (cond (*current-highlighted-border*
-	     (unless (eq *current-highlighted-border* *cursor-hunk*)
-	       (setf (xlib:window-border
-		      (window-group-xparent
-		       (bitmap-hunk-window-group *current-highlighted-border*)))
-		     *default-border-pixmap*)
-	       (setf (xlib:window-border
-		      (window-group-xparent
-		       (bitmap-hunk-window-group *cursor-hunk*)))
-		     *highlight-border-pixmap*)
-	       ;; For complete gratuitous pseudo-generality, should force
-	       ;; output on *current-highlighted-border* device too.
-	       (xlib:display-force-output
-		(bitmap-device-display (device-hunk-device *cursor-hunk*)))))
-	    (t (setf (xlib:window-border
-		      (window-group-xparent
-		       (bitmap-hunk-window-group *cursor-hunk*)))
-		     *highlight-border-pixmap*)
-	       (xlib:display-force-output
-		(bitmap-device-display (device-hunk-device *cursor-hunk*)))))
-      (setf *current-highlighted-border* *cursor-hunk*))
-    (setq *cursor-dropped* t)))
-
-;;;
-(defun lift-cursor ()
-  (when *cursor-dropped*
-    (unless *hemlock-listener* (cursor-invert-center))
-    (cursor-invert)
-    (setq *cursor-dropped* nil)))
-
-
-(defun cursor-invert-center ()
-  (let ((family (bitmap-hunk-font-family *cursor-hunk*))
-	(gcontext (bitmap-hunk-gcontext *cursor-hunk*)))
-    (xlib:with-gcontext (gcontext :function boole-xor
-				  :foreground *foreground-background-xor*)
-      (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*)
-			   gcontext
-			   (+ hunk-left-border
-			      (* *hunk-cursor-x* (font-family-width family))
-			      (font-family-cursor-x-offset family)
-			      1)
-			   (+ hunk-top-border
-			      (* *hunk-cursor-y* (font-family-height family))
-			      (font-family-cursor-y-offset family)
-			      1)
-			   (- (font-family-cursor-width family) 2)
-			   (- (font-family-cursor-height family) 2)
-			   t)))
-  (xlib:display-force-output
-   (bitmap-device-display (device-hunk-device *cursor-hunk*))))
-
-(defun cursor-invert ()
-  (let ((family (bitmap-hunk-font-family *cursor-hunk*))
-	(gcontext (bitmap-hunk-gcontext *cursor-hunk*)))
-    (xlib:with-gcontext (gcontext :function boole-xor
-				  :foreground *foreground-background-xor*)
-      (xlib:draw-rectangle (bitmap-hunk-xwindow *cursor-hunk*)
-			   gcontext
-			   (+ hunk-left-border
-			      (* *hunk-cursor-x* (font-family-width family))
-			      (font-family-cursor-x-offset family))
-			   (+ hunk-top-border
-			      (* *hunk-cursor-y* (font-family-height family))
-			      (font-family-cursor-y-offset family))
-			   (font-family-cursor-width family)
-			   (font-family-cursor-height family)
-			   t)))
-  (xlib:display-force-output
-   (bitmap-device-display (device-hunk-device *cursor-hunk*))))
-
-
-
-;;;; Clearing and Copying Lines.
-
-(defun hunk-clear-lines (hunk start count)
-  (let ((height (font-family-height (bitmap-hunk-font-family hunk))))
-    (xlib:clear-area (bitmap-hunk-xwindow hunk)
-		     :x 0 :y (+ hunk-top-border (* start height))
-		     :width (bitmap-hunk-width hunk)
-		     :height (* count height))))
-
-(defun hunk-copy-lines (hunk src dst count)
-  (let ((height (font-family-height (bitmap-hunk-font-family hunk)))
-	(xwindow (bitmap-hunk-xwindow hunk)))
-    (xlib:copy-area xwindow (bitmap-hunk-gcontext hunk)
-		    0 (+ hunk-top-border (* src height))
-		    (bitmap-hunk-width hunk) (* height count)
-		    xwindow 0 (+ hunk-top-border (* dst height)))))
-
-
-
-;;;; Drawing bottom border meter.
-
-;;; HUNK-DRAW-BOTTOM-BORDER assumes eight-character-space tabs.  The LOGAND
-;;; calls in the loop are testing for no remainder when dividing by 8, 4,
-;;; and other.  This lets us quickly draw longer notches at tab stops and
-;;; half way in between.  This function assumes that
-;;; BITMAP-HUNK-MODELINE-POS will not return nil; that is, that there is a
-;;; modeline.
-;;; 
-(defun hunk-draw-bottom-border (hunk)
-  (when (bitmap-hunk-thumb-bar-p hunk)
-    (let* ((xwindow (bitmap-hunk-xwindow hunk))
-	   (gcontext (bitmap-hunk-gcontext hunk))
-	   (modeline-pos (bitmap-hunk-modeline-pos hunk))
-	   (font-family (bitmap-hunk-font-family hunk))
-	   (font-width (font-family-width font-family)))
-      (xlib:clear-area xwindow :x 0 :y (- modeline-pos
-					  hunk-thumb-bar-bottom-border)
-		       :width (bitmap-hunk-width hunk)
-		       :height hunk-bottom-border)
-      (let ((x (+ hunk-left-border (ash font-width -1)))
-	    (y7 (- modeline-pos 7))
-	    (y5 (- modeline-pos 5))
-	    (y3 (- modeline-pos 3)))
-	(dotimes (i (bitmap-hunk-char-width hunk))
-	  (cond ((zerop (logand i 7))
-		 (xlib:draw-rectangle xwindow gcontext
-				      x y7 (if (= i 80) 2 1) 7 t))
-		((zerop (logand i 3))
-		 (xlib:draw-rectangle xwindow gcontext x y5 1 5 t))
-		(t
-		 (xlib:draw-rectangle xwindow gcontext x y3 1 3 t)))
-	  (incf x font-width))))))
diff --git a/hemlock/icom.lisp b/hemlock/icom.lisp
deleted file mode 100644
index 7ae6c82372a924062e53ca73e517fb7a40e0ce0b..0000000000000000000000000000000000000000
--- a/hemlock/icom.lisp
+++ /dev/null
@@ -1,76 +0,0 @@
-;;; -*- Package: hemlock; Log: hemlock.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/icom.lisp,v 1.3 1991/02/14 00:25:37 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;   This is an italicized comment.
-
-(in-package "HEMLOCK")
-
-(defun delete-line-italic-marks (line)
-  (dolist (m (hi::line-marks line))
-    (when (and (hi::fast-font-mark-p m)
-	       (eql (hi::font-mark-font m) 1))
-      (delete-font-mark m))))
-
-(defun set-comment-font (region font)
-  (do ((line (mark-line (region-start region))
-	     (line-next line))
-       (end (line-next (mark-line (region-end region)))))
-      ((eq line end))
-    (delete-line-italic-marks line)
-    (let ((pos (position #\; (the simple-string (line-string line)))))
-      (when pos
-	(font-mark line pos font :left-inserting)))))
-
-(defun delete-italic-marks-region (region)
-  (do ((line (mark-line (region-start region))
-	     (line-next line))
-       (end (line-next (mark-line (region-end region)))))
-      ((eq line end))
-    (delete-line-italic-marks line)))
-
-
-(defmode "Italic"
-  :setup-function
-  #'(lambda (buffer) (set-comment-font (buffer-region buffer) 1))
-  :cleanup-function
-  #'(lambda (buffer) (delete-italic-marks-region (buffer-region buffer))))
-
-(define-file-option "Italicize Comments" (buffer value)
-  (declare (ignore value))
-  (setf (buffer-minor-mode buffer "Italic") t))
-
-(defcommand "Italic Comment Mode" (p)
-  "Toggle \"Italic\" mode in the current buffer.  When in \"Italic\" mode,
-  semicolon comments are displayed in an italic font."
-  "Toggle \"Italic\" mode in the current buffer."
-  (declare (ignore p))
-  (setf (buffer-minor-mode (current-buffer) "Italic")
-	(not (buffer-minor-mode (current-buffer) "Italic"))))
-
-
-(defcommand "Start Italic Comment" (p)
-  "Italicize the text in this comment."
-  "Italicize the text in this comment."
-  (declare (ignore p))
-  (let* ((point (current-point))
-	 (pos (mark-charpos point))
-	 (line (mark-line point)))
-    (delete-line-italic-marks line)
-    (insert-character point #\;)
-    (font-mark
-     line
-     (or (position #\; (the simple-string (line-string line))) pos)
-     1
-     :left-inserting)))
-
-(bind-key "Start Italic Comment" #k";" :mode "Italic")
diff --git a/hemlock/indent.lisp b/hemlock/indent.lisp
deleted file mode 100644
index abee41a3cd2ed1750421150d1d36304f91fc5456..0000000000000000000000000000000000000000
--- a/hemlock/indent.lisp
+++ /dev/null
@@ -1,287 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/indent.lisp,v 1.3 1991/06/23 15:15:26 chiles Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Hemlock indentation commands
-;;;
-;;; Written by Bill Maddox and Bill Chiles
-;;;
-(in-package "HEMLOCK")
-
-
-
-(defhvar "Spaces per Tab"
-  "The number of spaces a tab is equivalent to.  NOTE: This is not incorporated
-   everywhere in Hemlock yet, so do not change it."
-  :value 8)
-
-(defun indent-using-tabs (mark column)
-  "Inserts at mark a maximum number of tabs and a minimum number of spaces to
-   move mark to column.  This assumes mark is at the beginning of a line."
-  (multiple-value-bind (tabs spaces) (floor column (value spaces-per-tab))
-    (dotimes (i tabs) (insert-character mark #\tab))
-    (dotimes (i spaces) (insert-character mark #\space))))
-
-(defhvar "Indent with Tabs"
-  "Function that takes a mark and a number of spaces and inserts tabs and spaces
-   to indent that number of spaces using \"Spaces per Tab\"."
-  :value #'indent-using-tabs)
-
-
-(defun tab-to-tab-stop (mark)
-  (insert-character mark #\tab))
-
-(defhvar "Indent Function"
-  "Indentation function which is invoked by \"Indent\" command.
-   It takes a :left-inserting mark that may be moved."
-  :value #'tab-to-tab-stop)
-
-
-(defun generic-indent (mark)
-  (let* ((line (mark-line mark))
-	 (prev (do ((line (line-previous line) (line-previous line)))
-		   ((or (null line) (not (blank-line-p line))) line))))
-    (unless prev (editor-error))
-    (line-start mark prev)
-    (find-attribute mark :space #'zerop)
-    (let ((indentation (mark-column mark)))
-      (line-start mark line)
-      (delete-horizontal-space mark)
-      (funcall (value indent-with-tabs) mark indentation))))
-
-
-(defcommand "Indent New Line" (p)
-  "Moves point to a new blank line and indents it.
-   Any whitespace before point is deleted.  The value of \"Indent Function\"
-   is used for indentation unless there is a Fill Prefix, in which case it is
-   used.  Any argument is passed onto \"New Line\"."
-  "Moves point to a new blank line and indents it.
-   Any whitespace before point is deleted.  The value of \"Indent Function\"
-   is used for indentation unless there is a Fill Prefix, in which case it is
-   used.  Any argument is passed onto \"New Line\"."
-  (let ((point (current-point))
-	(prefix (value fill-prefix)))
-    (delete-horizontal-space point)
-    (new-line-command p)
-    (if prefix
-	(insert-string point prefix)
-	(funcall (value indent-function) point))))
-
-
-(defcommand "Indent" (p)
-  "Invokes function held by the Hemlock variable \"Indent Function\",
-   moving point past region if called with argument."
-  "Invokes function held by the Hemlock variable \"Indent Function\"
-   moving point past region if called with argument."
-  (let ((point (current-point)))
-    (with-mark ((mark point :left-inserting))
-      (cond ((or (not p) (zerop p))
-	     (funcall (value indent-function) mark))
-	    (t
-	     (if (plusp p)
-		 (unless (line-offset point (1- p))
-		   (buffer-end point))
-		 (unless (line-offset mark (1+ p))
-		   (buffer-start mark)))
-	     (indent-region-for-commands (region mark point))
-	     (find-attribute (line-start point) :whitespace #'zerop))))))
-
-(defcommand "Indent Region" (p)
-  "Invokes function held by Hemlock variable \"Indent Function\" on every
-   line between point and mark, inclusively."
-  "Invokes function held by Hemlock variable \"Indent Function\" on every
-   line between point and mark, inclusively."
-  (declare (ignore p))
-  (let* ((region (current-region)))
-    (with-mark ((start (region-start region) :left-inserting)
-		(end (region-end region) :left-inserting))
-      (indent-region-for-commands (region start end)))))
-
-(defun indent-region-for-commands (region)
-  "Indents region undoably with INDENT-REGION."
-  (let* ((start (region-start region))
-	 (end (region-end region))
-	 (undo-region (copy-region (region (line-start start) (line-end end)))))
-    (indent-region region)
-    (make-region-undo :twiddle "Indent"
-		      (region (line-start (copy-mark start :left-inserting))
-			      (line-end (copy-mark end :right-inserting)))
-		      undo-region)))
-
-(defun indent-region (region)
-  "Invokes function held by Hemlock variable \"Indent Function\" on every
-   line of region."
-  (let ((indent-function (value indent-function)))
-    (with-mark ((start (region-start region) :left-inserting)
-		(end (region-end region)))
-      (line-start start)
-      (line-start end)
-      (loop (when (mark= start end)
-	      (funcall indent-function start)
-	      (return))
-	    (funcall indent-function start)
-	    (line-offset start 1 0)))))
-
-(defcommand "Center Line" (p)
-  "Centers current line using \"Fill Column\".  If an argument is supplied,
-   it is used instead of the \"Fill Column\"."
-  "Centers current line using fill-column."
-  (let* ((indent-function (value indent-with-tabs))
-	 (region (if (region-active-p)
-		     (current-region)
-		     (region (current-point) (current-point))))
-	 (end (region-end region)))
-    (with-mark ((temp (region-start region) :left-inserting))
-      (loop
-	(when (mark> temp end) (return))
-	(delete-horizontal-space (line-end temp))
-	(delete-horizontal-space (line-start temp))
-	(let* ((len (line-length (mark-line temp)))
-	       (spaces (- (or p (value fill-column)) len)))
-	  (if (and (plusp spaces) 
-		   (not (zerop len)))
-	      (funcall indent-function temp (ceiling spaces 2)))
-	  (unless (line-offset temp 1) (return))
-	  (line-start temp))))))
-
-
-(defcommand "Quote Tab" (p)
-  "Insert tab character."
-  "Insert tab character."
-  (if (and p (> p 1))
-      (insert-string (current-point) (make-string p :initial-element #\tab))
-      (insert-character (current-point) #\tab)))
-
-
-(defcommand "Open Line" (p)
-  "Inserts a newline into the buffer without moving the point."
-  "Inserts a newline into the buffer without moving the point.
-  With argument, inserts p newlines."
-  (let ((point (current-point))
-	(count (if p p 1)))
-    (if (not (minusp count))
-	(dotimes (i count)
-	  (insert-character point #\newline)
-	  (mark-before point))
-	(editor-error))))
-
-
-(defcommand "New Line" (p)
-  "Moves the point to a new blank line.
-  A newline is inserted if the next two lines are not already blank.
-  With an argument, repeats p times."
-  "Moves the point to a new blank line."
-  (let ((point (current-point))
-	(count (if p p 1)))
-    (if (not (minusp count))
-	(do* ((next (line-next (mark-line point))
-		    (line-next (mark-line point)))
-	      (i 1 (1+ i)))
-	     ((> i count))
-	  (cond ((and (blank-after-p point)
-		      next (blank-line-p next)
-		      (let ((after (line-next next)))
-			(or (not after) (blank-line-p after))))
-		 (line-start point next)
-		 (let ((len (line-length next)))
-		   (unless (zerop len)
-		     (delete-characters point len))))
-		(t
-		 (insert-character point #\newline))))
-	(editor-error))))
-
-
-(defattribute "Space"
-  "This attribute is used by the indentation commands to determine which
-  characters are treated as space."
-  '(mod 2) 0)
-
-(setf (character-attribute :space #\space) 1)
-(setf (character-attribute :space #\tab) 1)
-
-(defun delete-horizontal-space (mark)
-  "Deletes all :space characters on either side of mark."
-  (with-mark ((start mark))
-    (reverse-find-attribute start :space #'zerop)
-    (find-attribute mark :space #'zerop)
-    (delete-region (region start mark))))
-
-
-
-(defcommand "Delete Indentation" (p)
-  "Join current line with the previous one, deleting excess whitespace.
-  All whitespace is replaced with a single space, unless it is at the beginning
-  of a line, immmediately following a \"(\", or immediately preceding a \")\",
-  in which case the whitespace is merely deleted.  If the preceeding character
-  is a sentence terminator, two spaces are left instead of one.  If a prefix
-  argument is given, the following line is joined with the current line."
-  "Join current line with the previous one, deleting excess whitespace."
-  (with-mark ((m (current-point) :right-inserting))
-    (when p (line-offset m 1))
-    (line-start m)
-    (unless (delete-characters m -1) (editor-error "No previous line."))
-    (delete-horizontal-space m)
-    (let ((prev (previous-character m)))
-      (when (and prev (char/= prev #\newline))
-	(cond ((not (zerop (character-attribute :sentence-terminator prev)))
-	       (insert-string m "  "))
-	      ((not (or (eq (character-attribute :lisp-syntax prev) :open-paren)
-			(eq (character-attribute :lisp-syntax (next-character m))
-			    :close-paren)))
-	       (insert-character m #\space)))))))
-
-
-(defcommand "Delete Horizontal Space" (p)
-  "Delete spaces and tabs surrounding the point."
-  "Delete spaces and tabs surrounding the point."
-  (declare (ignore p))
-  (delete-horizontal-space (current-point)))
-
-(defcommand "Just One Space" (p)
-  "Leave one space.
-  Surrounding space is deleted, and then one space is inserted.
-  with prefix argument insert that number of spaces."
-  "Delete surrounding space and insert P spaces."
-  (let ((point (current-point)))
-    (delete-horizontal-space point)
-    (dotimes (i (or p 1)) (insert-character point #\space))))
-
-(defcommand "Back to Indentation" (p)
-  "Move point to the first non-whitespace character on the line."
-  "Move point to the first non-whitespace character on the line."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (line-start point)
-    (find-attribute point :whitespace #'zerop)))
-
-(defcommand "Indent Rigidly" (p)
-  "Indent the region rigidly by p spaces.
-   Each line in the region is moved p spaces to the right (left if p is
-   negative).  When moving a line to the left, tabs are converted to spaces."
-  "Indent the region rigidly p spaces to the right (left if p is negative)."
-  (let ((p (or p (value spaces-per-tab)))
-	(region (current-region)))
-    (with-mark ((mark1 (region-start region) :left-inserting)
-		(mark2 (region-end region) :left-inserting))
-      (line-start mark1)
-      (line-start mark2)
-      (do ()
-	  ((mark= mark1 mark2))
-	(cond ((empty-line-p mark1))
-	      ((blank-after-p mark1)
-	       (delete-characters mark1 (line-length (mark-line mark1))))
-	      (t (find-attribute mark1 :whitespace #'zerop)
-		 (let ((new-column (+ p (mark-column mark1))))
-		   (delete-characters mark1 (- (mark-charpos mark1)))
-		   (if (plusp new-column)
-		       (funcall (value indent-with-tabs) mark1 new-column)))))
-	(line-offset mark1 1 0)))))
diff --git a/hemlock/input.lisp b/hemlock/input.lisp
deleted file mode 100644
index fa549430f77d13ba19a4758e576f45f620432940..0000000000000000000000000000000000000000
--- a/hemlock/input.lisp
+++ /dev/null
@@ -1,445 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 the code that handles input to Hemlock.
-;;;
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(get-key-event unget-key-event clear-editor-input listen-editor-input
-	  *last-key-event-typed* *key-event-history* *editor-input*
-	  *real-editor-input* input-waiting last-key-event-cursorpos))
-;;;
-;;; INPUT-WAITING is exported solely as a hack for the kbdmac definition
-;;; mechanism.
-;;;
-
-
-;;; These are public variables users hand to the four basic editor input
-;;; routines for method dispatching:
-;;;    GET-KEY-EVENT
-;;;    UNGET-KEY-EVENT
-;;;    LISTEN-EDITOR-INPUT
-;;;    CLEAR-EDITOR-INPUT
-;;;
-(defvar *editor-input* nil
-  "A structure used to do various operations on terminal input.")
-
-(defvar *real-editor-input* ()
-  "Useful when we want to read from the terminal when *editor-input* is
-   rebound.")
-
-
-
-;;;; editor-input structure.
-
-(defstruct (editor-input (:print-function
-			  (lambda (s stream d)
-			    (declare (ignore s d))
-			    (write-string "#<Editor-Input stream>" stream))))
-  get          ; A function that returns the next key-event in the queue.
-  unget        ; A function that puts a key-event at the front of the queue.
-  listen       ; A function that tells whether the queue is empty.
-  clear        ; A function that empties the queue.
-  ;;
-  ;; Queue of events on this stream.  The queue always contains at least one
-  ;; one element, which is the key-event most recently read.  If no event has
-  ;; been read, the event is a dummy with a nil key-event.
-  head
-  tail)
-
-
-;;; These are the elements of the editor-input event queue.
-;;;
-(defstruct (input-event (:constructor make-input-event ())) 
-  next		; Next queued event, or NIL if none.
-  hunk		; Screen hunk event was read from.
-  key-event     ; Key-event read.
-  x		; X and Y character position of mouse cursor.
-  y
-  unread-p)
-
-(defvar *free-input-events* ())
-
-(defun new-event (key-event x y hunk next &optional unread-p)
-  (let ((res (if *free-input-events*
-		 (shiftf *free-input-events*
-			 (input-event-next *free-input-events*))
-		 (make-input-event))))
-    (setf (input-event-key-event res) key-event)
-    (setf (input-event-x res) x)
-    (setf (input-event-y res) y)
-    (setf (input-event-hunk res) hunk)
-    (setf (input-event-next res) next)
-    (setf (input-event-unread-p res) unread-p)
-    res))
-
-;;; This is a public variable.
-;;;
-(defvar *last-key-event-typed* ()
-  "This variable contains the last key-event typed by the user and read as
-   input.")
-
-;;; This is a public variable.  SITE-INIT initializes this.
-;;;
-(defvar *key-event-history* nil
-  "This ring holds the last 60 key-events read by the command interpreter.")
-
-(proclaim '(special *input-transcript*))
-
-;;; DQ-EVENT is used in editor stream methods for popping off input.
-;;; If there is an event not yet read in Stream, then pop the queue
-;;; and return the character.  If there is none, return NIL.
-;;;
-(defun dq-event (stream)
-  (without-interrupts
-   (let* ((head (editor-input-head stream))
-	  (next (input-event-next head)))
-     (if next
-	 (let ((key-event (input-event-key-event next)))
-	   (setf (editor-input-head stream) next)
-	   (shiftf (input-event-next head) *free-input-events* head)
-	   (ring-push key-event *key-event-history*)
-	   (setf *last-key-event-typed* key-event)
-	   (when *input-transcript* 
-	     (vector-push-extend key-event *input-transcript*))
-	   key-event)))))
-
-;;; Q-EVENT is used in low level input fetching routines to add input to the
-;;; editor stream.
-;;; 
-(defun q-event (stream key-event &optional x y hunk)
-  (without-interrupts
-   (let ((new (new-event key-event x y hunk nil))
-	 (tail (editor-input-tail stream)))
-     (setf (input-event-next tail) new)
-     (setf (editor-input-tail stream) new))))
-
-(defun un-event (key-event stream)
-  (without-interrupts
-   (let* ((head (editor-input-head stream))
-	  (next (input-event-next head))
-	  (new (new-event key-event (input-event-x head) (input-event-y head)
-			  (input-event-hunk head) next t)))
-     (setf (input-event-next head) new)
-     (unless next (setf (editor-input-tail stream) new)))))
-
-
-
-;;;; Keyboard macro hacks.
-
-(defvar *input-transcript* ()
-  "If this variable is non-null then it should contain an adjustable vector
-  with a fill pointer into which all keyboard input will be pushed.")
-
-;;; INPUT-WAITING  --  Internal
-;;;
-;;;    An Evil hack that tells us whether there is an unread key-event on
-;;; *editor-input*.  Note that this is applied to the real *editor-input*
-;;; rather than to a kbdmac stream.
-;;;
-(defun input-waiting ()
-  "Returns true if there is a key-event which has been unread-key-event'ed
-   on *editor-input*.  Used by the keyboard macro stuff."
-  (let ((next (input-event-next
-	       (editor-input-head *real-editor-input*))))
-    (and next (input-event-unread-p next))))
-
-
-
-;;;; Input method macro.
-
-(defvar *in-hemlock-stream-input-method* nil
-  "This keeps us from undefined nasties like re-entering Hemlock stream
-   input methods from input hooks and scheduled events.")
-
-(proclaim '(special *screen-image-trashed*))
-
-;;; These are the characters GET-KEY-EVENT notices when it pays attention
-;;; to aborting input.  This happens via EDITOR-INPUT-METHOD-MACRO.
-;;;
-(defparameter editor-abort-key-events (list #k"Control-g" #k"Control-G"))
-
-(defmacro abort-key-event-p (key-event)
-  `(member ,key-event editor-abort-key-events))
-
-;;; EDITOR-INPUT-METHOD-MACRO  --  Internal.
-;;;
-;;; WINDOWED-GET-KEY-EVENT and TTY-GET-KEY-EVENT use this.  Somewhat odd stuff
-;;; goes on here because this is the place where Hemlock waits, so this is
-;;; where we redisplay, check the time for scheduled events, etc.  In the loop,
-;;; we call the input hook when we get a character and leave the loop.  If
-;;; there isn't any input, invoke any scheduled events whose time is up.
-;;; Unless SERVE-EVENT returns immediately and did something, (serve-event 0),
-;;; call redisplay, note that we are going into a read wait, and call
-;;; SERVE-EVENT with a wait or infinite timeout.  Upon exiting the loop, turn
-;;; off the read wait note and check for the abort character.  Return the
-;;; key-event we got.  We bind an error condition handler here because the
-;;; default Hemlock error handler goes into a little debugging prompt loop, but
-;;; if we got an error in getting input, we should prompt the user using the
-;;; input method (recursively even).
-;;;
-(eval-when (compile eval)
-(defmacro editor-input-method-macro (&optional screen-image-trashed-concern)
-  `(handler-bind ((error #'(lambda (condition)
-			     (let ((device (device-hunk-device
-					    (window-hunk (current-window)))))
-			       (funcall (device-exit device) device))
-			     (invoke-debugger condition))))
-;     (when *in-hemlock-stream-input-method*
-;       (error "Entering Hemlock stream input method recursively!"))
-     (let ((*in-hemlock-stream-input-method* t)
-	   (nrw-fun (device-note-read-wait
-		     (device-hunk-device (window-hunk (current-window)))))
-	   key-event)
-       (loop
-	 (when (setf key-event (dq-event stream))
-	   (dolist (f (variable-value 'ed::input-hook)) (funcall f))
-	   (return))
-	 (invoke-scheduled-events)
-	 (unless (system:serve-event 0)
-	   (internal-redisplay)
-	   ,@(if screen-image-trashed-concern
-		 '((when *screen-image-trashed* (internal-redisplay))))
-	   (when nrw-fun (funcall nrw-fun t))
-	   (let ((wait (next-scheduled-event-wait)))
-	     (if wait (system:serve-event wait) (system:serve-event)))))
-       (when nrw-fun (funcall nrw-fun nil))
-       (when (and (abort-key-event-p key-event)
-		  ;; ingore-abort-attempts-p must exist outside the macro.
-		  ;; in this case it is bound in GET-KEY-EVENT.
-		  (not ignore-abort-attempts-p))
-	 (beep)
-	 (throw 'editor-top-level-catcher nil))
-       key-event)))
-) ;eval-when
-
-
-
-;;;; Editor input from windowing system.
-
-(defstruct (windowed-editor-input
-	    (:include editor-input
-		      (:get #'windowed-get-key-event)
-		      (:unget #'windowed-unget-key-event)
-		      (:listen #'windowed-listen)
-		      (:clear #'windowed-clear-input))
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore s d write))
-	       (write-string "#<Editor-Window-Input stream>" stream)))
-	    (:constructor make-windowed-editor-input
-			  (&optional (head (make-input-event)) (tail head))))
-  hunks)      ; List of bitmap-hunks which input to this stream.
-
-(defun windowed-get-key-event (stream ignore-abort-attempts-p)
-  (editor-input-method-macro))
-
-(defun windowed-unget-key-event (key-event stream)
-  (un-event key-event stream))
-
-(defun windowed-clear-input (stream)
-  (loop (unless (system:serve-event 0) (return)))
-  (without-interrupts
-   (let* ((head (editor-input-head stream))
-	  (next (input-event-next head)))
-     (when next
-       (setf (input-event-next head) nil)
-       (shiftf (input-event-next (editor-input-tail stream))
-	       *free-input-events* next)
-       (setf (editor-input-tail stream) head)))))
-
-(defun windowed-listen (stream)
-  (loop (unless (system:serve-event 0)
-	  ;; If nothing is pending, check the queued input.
-	  (return (not (null (input-event-next (editor-input-head stream))))))
-    (when (input-event-next (editor-input-head stream))
-      ;; Don't service anymore events if we just got some input.
-      (return t))))
-
-
-
-;;;; Editor input from a tty.
-
-(defstruct (tty-editor-input
-	    (:include editor-input
-		      (:get #'tty-get-key-event)
-		      (:unget #'tty-unget-key-event)
-		      (:listen #'tty-listen)
-		      (:clear #'tty-clear-input))
-	    (:print-function
-	     (lambda (obj stream n)
-	       (declare (ignore obj n))
-	       (write-string "#<Editor-Tty-Input stream>" stream)))
-	    (:constructor make-tty-editor-input
-			  (fd &optional (head (make-input-event)) (tail head))))
-  fd)
-
-(defun tty-get-key-event (stream ignore-abort-attempts-p)
-  (editor-input-method-macro t))
-
-(defun tty-unget-key-event (key-event stream)
-  (un-event key-event stream))
-
-(defun tty-clear-input (stream)
-  (without-interrupts
-   (let* ((head (editor-input-head stream))
-	  (next (input-event-next head)))
-     (when next
-       (setf (input-event-next head) nil)
-       (shiftf (input-event-next (editor-input-tail stream))
-	       *free-input-events* next)
-       (setf (editor-input-tail stream) head)))))
-
-(defun tty-listen (stream)
-  (cond ((input-event-next (editor-input-head stream)) t)
-	((editor-tty-listen stream) t)
-	(t nil)))
-
-
-
-;;;; GET-KEY-EVENT, UNGET-KEY-EVENT, LISTEN-EDITOR-INPUT, CLEAR-EDITOR-INPUT.
-
-;;; GET-KEY-EVENT -- Public.
-;;;
-(defun get-key-event (editor-input &optional ignore-abort-attempts-p)
-  "This function returns a key-event as soon as it is available on
-   editor-input.  Editor-input is either *editor-input* or *real-editor-input*.
-   Ignore-abort-attempts-p indicates whether #k\"C-g\" and #k\"C-G\" throw to
-   the editor's top-level command loop; when this is non-nil, this function
-   returns those key-events when the user types them.  Otherwise, it aborts the
-   editor's current state, returning to the command loop."
-  (funcall (editor-input-get editor-input) editor-input ignore-abort-attempts-p))
-
-;;; UNGET-KEY-EVENT -- Public.
-;;;
-(defun unget-key-event (key-event editor-input)
-  "This function returns the key-event to editor-input, so the next invocation
-   of GET-KEY-EVENT will return the key-event.  If the key-event is #k\"C-g\"
-   or #k\"C-G\", then whether GET-KEY-EVENT returns it depends on its second
-   argument.  Editor-input is either *editor-input* or *real-editor-input*."
-  (funcall (editor-input-unget editor-input) key-event editor-input))
-
-;;; CLEAR-EDITOR-INPUT -- Public.
-;;;
-(defun clear-editor-input (editor-input)
-  "This function flushes any pending input on editor-input.  Editor-input
-   is either *editor-input* or *real-editor-input*."
-  (funcall (editor-input-clear editor-input) editor-input))
-
-;;; LISTEN-EDITOR-INPUT -- Public.
-;;;
-(defun listen-editor-input (editor-input)
-  "This function returns whether there is any input available on editor-input.
-   Editor-input is either *editor-input* or *real-editor-input*."
-  (funcall (editor-input-listen editor-input) editor-input))
-
-
-
-;;;; LAST-KEY-EVENT-CURSORPOS and WINDOW-INPUT-HANDLER.
-
-;;; LAST-KEY-EVENT-CURSORPOS  --  Public
-;;;
-;;; Just look up the saved info in the last read key event.
-;;;
-(defun last-key-event-cursorpos ()
-  "Return as values, the (X, Y) character position and window where the
-   last key event happened.  If this cannot be determined, Nil is returned.
-   If in the modeline, return a Y position of NIL and the correct X and window.
-   Returns nil for terminal input."
-  (let* ((ev (editor-input-head *real-editor-input*))
-	 (hunk (input-event-hunk ev))
-	 (window (and hunk (device-hunk-window hunk))))
-    (when window
-      (values (input-event-x ev) (input-event-y ev) window))))
-
-;;; WINDOW-INPUT-HANDLER  --  Internal
-;;;
-;;; This is the input-handler function for hunks that implement windows.  It
-;;; just queues the events on *real-editor-input*.
-;;;
-(defun window-input-handler (hunk char x y)
-  (q-event *real-editor-input* char x y hunk))
-
-
-
-;;;; Random typeout input routines.
-
-(defun wait-for-more (stream)
-  (let ((key-event (more-read-key-event)))
-    (cond ((logical-key-event-p key-event :yes))
-	  ((or (logical-key-event-p key-event :do-all)
-	       (logical-key-event-p key-event :exit))
-	   (setf (random-typeout-stream-no-prompt stream) t)
-	   (random-typeout-cleanup stream))
-	  ((logical-key-event-p key-event :keep)
-	   (setf (random-typeout-stream-no-prompt stream) t)
-	   (maybe-keep-random-typeout-window stream)
-	   (random-typeout-cleanup stream))
-	  ((logical-key-event-p key-event :no)
-	   (random-typeout-cleanup stream)
-	   (throw 'more-punt nil))
-	  (t
-	   (unget-key-event key-event *editor-input*)
-	   (random-typeout-cleanup stream)
-	   (throw 'more-punt nil)))))
-
-(proclaim '(special *more-prompt-action*))
-
-(defun maybe-keep-random-typeout-window (stream)
-  (let* ((window (random-typeout-stream-window stream))
-	 (buffer (window-buffer window))
-	 (start (buffer-start-mark buffer)))
-    (when (typep (hi::device-hunk-device (hi::window-hunk window))
-		 'hi::bitmap-device)
-      (let ((*more-prompt-action* :normal))
-	(update-modeline-field buffer window :more-prompt)
-	(random-typeout-redisplay window))
-      (buffer-start (buffer-point buffer))
-      (let* ((xwindow (make-xwindow-like-hwindow window))
-	     (window (make-window start :window xwindow)))
-	(unless window
-	  (xlib:destroy-window xwindow)
-	  (editor-error "Could not create random typeout window."))))))
-
-(defun end-random-typeout (stream)
-  (let ((*more-prompt-action* :flush)
-	(window (random-typeout-stream-window stream)))
-    (update-modeline-field (window-buffer window) window :more-prompt)
-    (random-typeout-redisplay window))
-  (unless (random-typeout-stream-no-prompt stream)
-    (let* ((key-event (more-read-key-event))
-	   (keep-p (logical-key-event-p key-event :keep)))
-      (when keep-p (maybe-keep-random-typeout-window stream))
-      (random-typeout-cleanup stream)
-      (unless (or (logical-key-event-p key-event :do-all)
-		  (logical-key-event-p key-event :exit)
-		  (logical-key-event-p key-event :no)
-		  (logical-key-event-p key-event :yes)
-		  keep-p)
-	(unget-key-event key-event *editor-input*)))))
-
-;;; MORE-READ-KEY-EVENT -- Internal.
-;;;
-;;; This gets some input from the type of stream bound to *editor-input*.  Need
-;;; to loop over SERVE-EVENT since it returns on any kind of event (not
-;;; necessarily a key or button event).
-;;;
-;;; Currently this does not work for keyboard macro streams!
-;;; 
-(defun more-read-key-event ()
-  (clear-editor-input *editor-input*)
-  (let ((key-event (loop
-		     (let ((key-event (dq-event *editor-input*)))
-		       (when key-event (return key-event))
-		       (system:serve-event)))))
-    (when (abort-key-event-p key-event)
-      (beep)
-      (throw 'editor-top-level-catcher nil))
-    key-event))
diff --git a/hemlock/interp.lisp b/hemlock/interp.lisp
deleted file mode 100644
index 344023c11661a9a490de094b6369d305a4a06322..0000000000000000000000000000000000000000
--- a/hemlock/interp.lisp
+++ /dev/null
@@ -1,484 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/interp.lisp,v 1.3 1991/02/08 16:35:29 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Rob MacLachlan and Blaine Burks.
-;;;
-;;; This file contains the routines which define hemlock commands and
-;;; the command interpreter.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(bind-key delete-key-binding get-command map-bindings
-	  make-command command-name command-bindings last-command-type
-	  prefix-argument exit-hemlock *invoke-hook* key-translation))
-
-
-(defun %print-hcommand (obj stream depth)
-  (declare (ignore depth))
-  (write-string "#<Hemlock Command \"" stream)
-  (write-string (command-name obj) stream)
-  (write-string "\">" stream))
-
-
-
-;;;; Key Tables:
-;;;
-;;;    A key table provides a way to translate a sequence of characters to some
-;;; lisp object.  It is currently represented by a tree of hash-tables, where
-;;; each level is a hashing from a key to either another hash-table or a value.
-
-
-;;; GET-TABLE-ENTRY returns the value at the end of a series of hashings.  For
-;;; our purposes it is presently used to look up commands and key-translations.
-;;;
-(defun get-table-entry (table key)
-  (let ((foo nil))
-    (dotimes (i (length key) foo)
-      (let ((key-event (aref key i)))
-	(setf foo (gethash key-event table))
-	(unless (hash-table-p foo) (return foo))
-	(setf table foo)))))
-
-;;; SET-TABLE-ENTRY sets the entry for key in table to val, creating new
-;;; tables as needed.  If val is nil, then use REMHASH to remove this element
-;;; from the hash-table.
-;;;
-(defun set-table-entry (table key val)
-  (dotimes (i (1- (length key)))
-    (let* ((key-event (aref key i))
-	   (foo (gethash key-event table)))
-      (if (hash-table-p foo)
-	  (setf table foo)
-	  (let ((new-table (make-hash-table)))
-	    (setf (gethash key-event table) new-table)
-	    (setf table new-table)))))
-  (if (null val)
-      (remhash (aref key (1- (length key))) table)
-      (setf (gethash (aref key (1- (length key))) table) val)))
-
-
-;;;; Key Translation:
-;;;
-;;;    Key translations are maintained using a key table.  If a value is an
-;;; integer, then it is prefix bits to be OR'ed with the next character.  If it
-;;; is a key, then we translate to that key.
-
-(defvar *key-translations* (make-hash-table))
-(defvar *translate-key-temp* (make-array 10 :fill-pointer 0 :adjustable t))
-
-
-;;; TRANSLATE-KEY  --  Internal
-;;;
-;;;    This is used internally to do key translations when we want the
-;;; canonical representation for Key.  Result, if supplied, is an adjustable
-;;; vector with a fill pointer.  We compute the output in this vector.  If the
-;;; key ends in the prefix of a translation, we just return that part
-;;; untranslated and return the second value true.
-;;;
-(defun translate-key (key &optional (result (make-array (length key)
-							:fill-pointer 0
-							:adjustable t)))
-  (let ((key-len (length key))
-	(temp *translate-key-temp*)
-	(start 0)
-	(try-pos 0)
-	(prefix 0))
-    (setf (fill-pointer temp) 0)
-    (setf (fill-pointer result) 0)
-    (loop
-      (when (= try-pos key-len) (return))
-      (let ((key-event (aref key try-pos)))
-	(vector-push-extend
-	 (ext:make-key-event key-event (logior (ext:key-event-bits key-event)
-					       prefix))
-	 temp)
-	(setf prefix 0))
-      (let ((entry (get-table-entry *key-translations* temp)))
-	(cond ((hash-table-p entry)
-	       (incf try-pos))
-	      (t
-	       (etypecase entry
-		 (null
-		  (vector-push-extend (aref temp 0) result)
-		  (incf start))
-		 (simple-vector
-		  (dotimes (i (length entry))
-		    (vector-push-extend (aref entry i) result))
-		  (setf start (1+ try-pos)))
-		 (integer
-		  (setf start (1+ try-pos))
-		  (when (= start key-len) (return))
-		  (setf prefix (logior entry prefix))))
-	       (setq try-pos start)
-	       (setf (fill-pointer temp) 0)))))
-    (dotimes (i (length temp))
-      (vector-push-extend (aref temp i) result))
-    (values result (not (zerop (length temp))))))
-
-
-;;; KEY-TRANSLATION -- Public.
-;;;
-(defun key-translation (key)
-  "Return the key translation for Key, or NIL if there is none.  If Key is a
-   prefix of a translation, then :Prefix is returned.  Whenever Key appears as a
-   subsequence of a key argument to the binding manipulation functions, that
-   portion will be replaced with the translation.  A key translation may also be
-   a list (:Bits {Bit-Name}*).  In this case, the named bits will be set in the
-   next character in the key being translated."
-  (let ((entry (get-table-entry *key-translations* (crunch-key key))))
-    (etypecase entry
-      (hash-table :prefix)
-      ((or simple-vector null) entry)
-      (integer
-       (cons :bits (ext:key-event-bits-modifiers entry))))))
-
-;;; %SET-KEY-TRANSLATION  --  Internal
-;;;
-(defun %set-key-translation (key new-value)
-  (let ((entry (cond ((and (consp new-value) (eq (car new-value) :bits))
-		      (apply #'ext:make-key-event-bits (cdr new-value)))
-		     (new-value (crunch-key new-value))
-		     (t new-value))))
-    (set-table-entry *key-translations* (crunch-key key) entry)
-    new-value))
-;;;
-(defsetf key-translation %set-key-translation
-  "Set the key translation for a key.  If set to null, deletes any
-  translation.")
-
-
-
-;;;; Interface Utility Functions:
-
-(defvar *global-command-table* (make-hash-table)
-  "The command table for global key bindings.")
-
-;;; GET-RIGHT-TABLE  --  Internal
-;;;
-;;;    Return a hash-table depending on "kind" and checking for errors.
-;;;
-(defun get-right-table (kind where)
-  (case kind
-     (:global
-      (when where
-	(error "Where argument ~S is meaningless for :global bindings."
-	       where))
-      *global-command-table*)
-     (:mode (let ((mode (getstring where *mode-names*)))
-	      (unless mode
-		(error "~S is not a defined mode." where))
-	      (mode-object-bindings mode)))
-     (:buffer (unless (bufferp where)
-		(error "~S is not a buffer." where))
-	      (buffer-bindings where))
-     (t (error "~S is not a valid binding type." kind))))
-
-
-;;; CRUNCH-KEY  --  Internal.
-;;;
-;;; Take a key in one of the various specifications and turn it into the
-;;; standard one: a simple-vector of characters.
-;;;
-(defun crunch-key (key)
-  (typecase key
-    (ext:key-event (vector key))
-    ((or list vector) ;List thrown in gratuitously.
-     (when (zerop (length key))
-       (error "A zero length key is illegal."))
-     (unless (every #'ext:key-event-p key)
-       (error "A Key ~S must contain only key-events." key))
-     (coerce key 'simple-vector))
-    (t
-     (error "Key ~S is not a key-event or sequence of key-events." key))))
-
-
-
-;;;; Exported Primitives:
-
-(proclaim '(special *command-names*))
-
-;;; BIND-KEY  --  Public.
-;;;
-(defun bind-key (name key &optional (kind :global) where)
-  "Bind a Hemlock command to some key somewhere.  Name is the string name
-   of a Hemlock command, Key is either a key-event or a vector of key-events.
-   Kind is one of :Global, :Mode or :Buffer, and where is the mode name or
-   buffer concerned.  Kind defaults to :Global."
-  (let ((cmd (getstring name *command-names*))
-	(table (get-right-table kind where))
-	(key (copy-seq (translate-key (crunch-key key)))))
-    (cond (cmd
-	   (set-table-entry table key cmd)
-	   (push (list key kind where) (command-%bindings cmd))
-	   cmd)
-	  (t
-	   (with-simple-restart (continue "Go on, ignoring binding attempt.")
-	     (error "~S is not a defined command." name))))))
-
-
-;;; DELETE-KEY-BINDING  --  Public
-;;;
-;;;    Stick NIL in the key table specified.
-;;;
-(defun delete-key-binding (key &optional (kind :global) where)
-  "Remove a Hemlock key binding somewhere.  Key is either a key-event or a
-   vector of key-events.  Kind is one of :Global, :Mode or :Buffer, andl where
-   is the mode name or buffer concerned.  Kind defaults to :Global."
-  (set-table-entry (get-right-table kind where)
-		   (translate-key (crunch-key key))
-		   nil))
-
-
-;;; GET-CURRENT-BINDING  --  Internal
-;;;
-;;;    Look up a key in the current environment.
-;;;
-(defun get-current-binding (key)
-  (let ((res (get-table-entry (buffer-bindings *current-buffer*) key)))
-    (cond
-     (res (values res nil))
-     (t
-      (do ((mode (buffer-mode-objects *current-buffer*) (cdr mode))
-	   (t-bindings ()))
-	  ((null mode)
-	   (values (get-table-entry *global-command-table* key)
-		   (nreverse t-bindings)))
-	(declare (list t-bindings))
-	(let ((res (get-table-entry (mode-object-bindings (car mode)) key)))
-	  (when res
-	    (if (mode-object-transparent-p (car mode))
-		(push res t-bindings)
-		(return (values res (nreverse t-bindings)))))))))))
-
-
-;;; GET-COMMAND -- Public.
-;;;
-(defun get-command (key &optional (kind :global) where)
-  "Return the command object for the command bound to key somewhere.
-   If key is not bound, return nil.  Key is either a key-event or a vector of
-   key-events.  If key is a prefix of a key-binding, then return :prefix.
-   Kind is one of :global, :mode or :buffer, and where is the mode name or
-   buffer concerned.  Kind defaults to :Global."
-  (multiple-value-bind (key prefix-p)
-		       (translate-key (crunch-key key))
-    (let ((entry (if (eq kind :current)
-		     (get-current-binding key)
-		     (get-table-entry (get-right-table kind where) key))))
-      (etypecase entry
-	(null (if prefix-p :prefix nil))
-	(command entry)
-	(hash-table :prefix)))))
-
-(defvar *map-bindings-key* (make-array 5 :adjustable t :fill-pointer 0))
-
-;;; MAP-BINDINGS -- Public.
-;;;
-(defun map-bindings (function kind &optional where)
-  "Map function over the bindings in some place.  The function is passed the
-   key and the command to which it is bound."
-  (labels ((mapping-fun (hash-key hash-value)
-	     (vector-push-extend hash-key *map-bindings-key*)
-	     (etypecase hash-value
-	       (command (funcall function *map-bindings-key* hash-value))
-	       (hash-table (maphash #'mapping-fun hash-value)))
-	     (decf (fill-pointer *map-bindings-key*))))
-    (setf (fill-pointer *map-bindings-key*) 0)
-    (maphash #'mapping-fun (get-right-table kind where))))
-
-;;; MAKE-COMMAND -- Public.
-;;;
-;;; If the command is already defined, then alter the command object;
-;;; otherwise, make a new command object and enter it into the *command-names*.
-;;;
-(defun make-command (name documentation function)
-  "Create a new Hemlock command with Name and Documentation which is
-   implemented by calling the function-value of the symbol Function"
-  (let ((entry (getstring name *command-names*)))
-    (cond
-     (entry
-      (setf (command-name entry) name)
-      (setf (command-documentation entry) documentation)
-      (setf (command-function entry) function))
-     (t
-      (setf (getstring name *command-names*)
-	    (internal-make-command name documentation function))))))
-
-
-;;; COMMAND-NAME, %SET-COMMAND-NAME -- Public.
-;;;
-(defun command-name (command)
-  "Returns the string which is the name of Command."
-  (command-%name command))
-;;;
-(defun %set-command-name (command new-name)
-  (check-type command command)
-  (check-type new-name string)
-  (setq new-name (coerce new-name 'simple-string))
-  (delete-string (command-%name command) *command-names*)
-  (setf (getstring new-name *command-names*) command)
-  (setf (command-%name command) new-name))
-
-
-;;; COMMAND-BINDINGS -- Public.
-;;;
-;;; Check that all the supposed bindings really exists.  Bindings which
-;;; were once made may have been overwritten.  It is easier to filter
-;;; out bogus bindings here than to catch all the cases that can make a
-;;; binding go away.
-;;;
-(defun command-bindings (command)
-  "Return a list of lists of the form (key kind where) describing
-   all the places where Command is bound."
-  (check-type command command)
-  (let (result)
-    (declare (list result))
-    (dolist (place (command-%bindings command))
-      (let ((table (case (cadr place)
-		   (:global *global-command-table*)
-		   (:mode
-		    (let ((m (getstring (caddr place) *mode-names*)))
-		      (when m (mode-object-bindings m))))
-		   (t
-		    (when (memq (caddr place) *buffer-list*)
-		      (buffer-bindings (caddr place)))))))
-	(when (and table
-		   (eq (get-table-entry table (car place)) command)
-		   (not (member place result :test #'equalp)))
-	  (push place result))))
-    result))
-
-
-(defvar *last-command-type* ()
-  "The command-type of the last command invoked.")
-(defvar *command-type-set* ()
-  "True if the last command set the command-type.")
-
-;;; LAST-COMMAND-TYPE  --  Public
-;;;
-;;;
-(defun last-command-type ()
-  "Return the command-type of the last command invoked.
-  If no command-type has been set then return NIL.  Setting this with
-  Setf sets the value for the next command."
-  *last-command-type*)
-
-;;; %SET-LAST-COMMAND-TYPE  --  Internal
-;;;
-;;;    Set the flag so we know not to clear the command-type.
-;;;
-(defun %set-last-command-type (type)
-  (setq *last-command-type* type *command-type-set* t))
-
-
-(defvar *prefix-argument* nil "The prefix argument or NIL.")
-(defvar *prefix-argument-supplied* nil
-  "Should be set by functions which supply a prefix argument.")
-
-;;; PREFIX-ARGUMENT  --  Public
-;;;
-;;;
-(defun prefix-argument ()
-  "Return the current value of prefix argument.  This can be set with SETF."
-  *prefix-argument*)
-
-;;; %SET-PREFIX-ARGUMENT  --  Internal
-;;;
-(defun %set-prefix-argument (argument)
-  "Set the prefix argument for the next command to Argument."
-  (unless (or (null argument) (integerp argument))
-    (error "Prefix argument ~S is neither an integer nor Nil." argument))
-  (setq *prefix-argument* argument  *prefix-argument-supplied* t))
-
-;;;; The Command Loop:
-
-;;; Buffers we use to read and translate keys.
-;;;
-(defvar *current-command* (make-array 10 :fill-pointer 0 :adjustable t))
-(defvar *current-translation* (make-array 10 :fill-pointer 0 :adjustable t))
-
-(defvar *invoke-hook* #'(lambda (command p)
-			  (funcall (command-function command) p))
-  "This function is called by the command interpreter when it wants to invoke a
-  command.  The arguments are the command to invoke and the prefix argument.
-  The default value just calls the Command-Function with the prefix argument.")
-
-
-;;; %COMMAND-LOOP  --  Internal
-;;;
-;;;    Read commands from the terminal and execute them, forever.
-;;;
-(defun %command-loop ()
-  (let  ((cmd *current-command*)
-	 (trans *current-translation*)
-	 (*last-command-type* nil)
-	 (*command-type-set* nil)
-	 (*prefix-argument* nil)
-	 (*prefix-argument-supplied* nil))
-    (declare (special *last-command-type* *command-type-set*
-		      *prefix-argument* *prefix-argument-supplied*))
-    (setf (fill-pointer cmd) 0)
-    (handler-bind
-	;; Bind this outside the invocation loop to save consing.
-	((editor-error #'(lambda (condx)
-			   (beep)
-			   (let ((string (editor-error-format-string condx)))
-			     (when string
-			       (apply #'message string
-				      (editor-error-format-arguments condx)))
-			     (throw 'command-loop-catcher nil)))))
-      (loop
-	(unless (eq *current-buffer* *echo-area-buffer*)
-	  (when (buffer-modified *echo-area-buffer*) (clear-echo-area))
-	  (unless (or (zerop (length cmd))
-		      (not (value ed::key-echo-delay)))
-	    (editor-sleep (value ed::key-echo-delay))
-	    (unless (listen-editor-input *editor-input*)
-	      (clear-echo-area)
-	      (dotimes (i (length cmd))
-		(ext:print-pretty-key (aref cmd i) *echo-area-stream*)
-		(write-char #\space *echo-area-stream*)))))
-	(vector-push-extend (get-key-event *editor-input*) cmd)
-	(multiple-value-bind (trans-result prefix-p)
-			     (translate-key cmd trans)
-	  (multiple-value-bind (res t-bindings)
-			       (get-current-binding trans-result)
-	    (etypecase res
-	      (command 
-	       (let ((punt t))
-		 (catch 'command-loop-catcher
-		   (dolist (c t-bindings)
-		     (funcall *invoke-hook* c *prefix-argument*))
-		   (funcall *invoke-hook* res *prefix-argument*)
-		   (setf punt nil))
-		 (when punt (invoke-hook ed::command-abort-hook)))
-	       (if *command-type-set*
-		   (setq *command-type-set* nil)
-		   (setq *last-command-type* nil))
-	       (if *prefix-argument-supplied*
-		   (setq *prefix-argument-supplied* nil)
-		   (setq *prefix-argument* nil))
-	       (setf (fill-pointer cmd) 0))
-	      (null
-	       (unless prefix-p
-		 (beep)
-		 (setq *prefix-argument* nil)
-		 (setf (fill-pointer cmd) 0)))
-	      (hash-table))))))))
-
-
-;;; EXIT-HEMLOCK  --  Public
-;;;
-(defun exit-hemlock (&optional (value t))
-  "Exit from ED, returning the specified value."
-  (throw 'hemlock-exit value))
diff --git a/hemlock/kbdmac.lisp b/hemlock/kbdmac.lisp
deleted file mode 100644
index c97a20ae32692475665ccade969436be9e5a4851..0000000000000000000000000000000000000000
--- a/hemlock/kbdmac.lisp
+++ /dev/null
@@ -1,469 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 the implementation of keyboard macros for
-;;; Hemlock.  In itself it contains nothing particularly gross or
-;;; implementation dependant, but it uses some hooks in the stream
-;;; system and other stuff.
-;;;
-
-(in-package "HEMLOCK")
-
-;;; We have "Keyboard Macro Transforms" that help in making a keyboard
-;;; macro.  What they do is turn the sequence of commands into equivalent
-;;; lisp code.  They operate under the following principles:
-;;;
-;;;    They are passed two arguments:
-;;; 1] The command invoked.
-;;; 2] A keyword, either :invoke, :start or :finish
-;;;
-;;;    If the keyword is :invoke, then the transform is expected to
-;;; invoke the command and do whatever is necessary to make the same
-;;; thing happen again when the macro is invoked.  The method does this
-;;; by pushing forms on the list *current-kbdmac* and characters to
-;;; simulate input of on *kbdmac-input*.  *current-kbdmac* is kept
-;;; in reverse order.  Each form must be a function call, and none
-;;; of the arguments are evaluated.  If the transform is unwound, 
-;;; presumably due to an error in the invoked command, then nothing
-;;; should be done at invocation time.
-;;;
-;;;    If the keyword is :finish, then nothing need be done.  This
-;;; is to facilitate compaction of repetitions of the same command
-;;; into one call.  The transform is called with :finish when a run
-;;; is broken.  Similarly, the transform is called with :start
-;;; before the first occurrence in a run.
-
-(defvar *kbdmac-transcript* (make-array 100  :fill-pointer 0 :adjustable t)
-  "The thing we bind *input-transcript* to during keyboard macro definition.")
-
-(defvar *kbdmac-input* (make-array 100  :fill-pointer 0  :adjustable t)
-  "Place where we stick input that will need to be simulated during keyboard
-  macro execution.")
-
-(defvar *current-kbdmac* () "Body of keyboard macro we are building.")
-
-(defvar *kbdmac-transforms* (make-hash-table :test #'eq)
-  "Hashtable of function that know how to do things.")
-
-(defvar *old-invoke-hook* () "Bound to *invoke-hook* by kbdmac-command-loop.")
-
-(defmacro define-kbdmac-transform (command function)
-  `(setf (gethash (getstring ,command *command-names*)
-		  *kbdmac-transforms*)
-	 ,function))
-
-(defmacro kbdmac-emit (form)
-  `(push ,form *current-kbdmac*))
-
-(defun trash-character ()
-  "Throw away a character on *editor-input*."
-  (get-key-event *editor-input*))
-
-;;; Save-Kbdmac-Input  --  Internal
-;;;
-;;;    Pushes any input read within the body on *kbdmac-input* so that
-;;; it is read again at macro invocation time.  It uses the (input-waiting)
-;;; function which is a non-standard hook into the stream system.
-;;;
-(defmacro save-kbdmac-input (&body forms)
-  (let ((slen (gensym)))
-    `(let ((,slen (- (length *kbdmac-transcript*) (if (input-waiting) 1 0))))
-       (multiple-value-prog1
-	(progn ,@forms)
-	(do ((i ,slen (1+ i))
-	     (elen (length *kbdmac-transcript*)))
-	    ((= i elen)
-	     (when (input-waiting)
-	       (kbdmac-emit '(trash-character))))	 
-	  (vector-push-extend (aref *kbdmac-transcript* i)
-			      *kbdmac-input*))))))
-
-;;;; The default transform
-;;;
-;;;    This transform is called when none is defined for a command.
-;;;
-(defun default-kbdmac-transform (command key)
-  (case key
-    (:invoke
-     (let ((fun (command-function command))
-	   (arg (prefix-argument))
-	   (lastc *last-key-event-typed*))
-       (save-kbdmac-input
-	 (let ((*invoke-hook* *old-invoke-hook*))
-	   (funcall fun arg))
-	 (kbdmac-emit `(set *last-key-event-typed* ,lastc))
-	 (kbdmac-emit `(,fun ,arg)))))))
-
-;;;; Self insert transform:
-;;;
-;;;    For self insert we accumulate the text in a string and then
-;;; insert it all at once.
-;;;
-
-(defvar *kbdmac-text* (make-array 100 :fill-pointer 0 :adjustable t))
-
-(defun insert-string-at-point (string)
-  (insert-string (buffer-point (current-buffer)) string))
-(defun insert-character-at-point (character)
-  (insert-character (buffer-point (current-buffer)) character))
-
-(defun key-vector-to-string (key-vector)
-  (let ((string (make-array (length key-vector) :element-type 'string-char)))
-    (dotimes (i (length key-vector) string)
-      (setf (aref string i) (key-event-char (aref key-vector i))))))
-
-(defun self-insert-kbdmac-transform (command key)
-  (case key
-    (:start
-     (setf (fill-pointer *kbdmac-text*) 0))
-    (:invoke
-     (let ((p (or (prefix-argument) 1)))
-       (funcall (command-function command) p)
-       (dotimes (i p)
-	 (vector-push-extend *last-key-event-typed* *kbdmac-text*))))
-    (:finish
-     (if (> (length *kbdmac-text*) 1)
-	 (kbdmac-emit `(insert-string-at-point
-			,(key-vector-to-string *kbdmac-text*)))
-	 (kbdmac-emit `(insert-character-at-point
-			,(key-event-char (aref *kbdmac-text* 0))))))))
-;;;
-(define-kbdmac-transform "Self Insert" #'self-insert-kbdmac-transform)
-(define-kbdmac-transform "Lisp Insert )" #'self-insert-kbdmac-transform)
-
-;;;; Do-Nothing transform:
-;;;
-;;;    These are useful for prefix-argument setting commands, since they have
-;;; no semantics at macro-time.
-;;;
-(defun do-nothing-kbdmac-transform (command key)
-  (case key
-    (:invoke
-     (funcall (command-function command) (prefix-argument)))))
-;;;
-(define-kbdmac-transform "Argument Digit" #'do-nothing-kbdmac-transform)
-(define-kbdmac-transform "Negative Argument" #'do-nothing-kbdmac-transform)
-(define-kbdmac-transform "Universal Argument" #'do-nothing-kbdmac-transform)
-
-;;;; Multiplicative transform
-;;;
-;;;    Repititions of many commands can be turned into a call with an
-;;; argument.
-;;;
-(defvar *kbdmac-count* 0
-  "The number of occurrences we have counted of a given command.")
-
-(defun multiplicative-kbdmac-transform (command key)
-  (case key
-    (:start
-     (setq *kbdmac-count* 0))
-    (:invoke
-     (let ((p (or (prefix-argument) 1)))
-       (funcall (command-function command) p)
-       (incf *kbdmac-count* p)))
-    (:finish
-     (kbdmac-emit `(,(command-function command) ,*kbdmac-count*)))))
-;;;
-(define-kbdmac-transform "Forward Character" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Backward Character" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Forward Word" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Backward Word" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Uppercase Word" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Lowercase Word" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Capitalize Word" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Kill Next Word" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Kill Previous Word" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Forward Kill Form" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Backward Kill Form" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Forward Form" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Backward Form" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Delete Next Character"
-  #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Delete Previous Character"
-   #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Delete Previous Character Expanding Tabs"
-   #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Next Line" #'multiplicative-kbdmac-transform)
-(define-kbdmac-transform "Previous Line" #'multiplicative-kbdmac-transform)
-
-
-;;;; Vanilla transform
-;;;
-;;;    These commands neither read input nor look at random silly variables.
-;;;
-(defun vanilla-kbdmac-transform (command key)
-  (case key
-    (:invoke
-     (let ((fun (command-function command))
-	   (p (prefix-argument)))
-       (funcall fun p)
-       (kbdmac-emit `(,fun ,p))))))
-;;;
-(define-kbdmac-transform "Beginning of Line" #'vanilla-kbdmac-transform)
-(define-kbdmac-transform "End of Line" #'vanilla-kbdmac-transform)
-(define-kbdmac-transform "Beginning of Line" #'vanilla-kbdmac-transform)
-(define-kbdmac-transform "Indent for Lisp" #'vanilla-kbdmac-transform)
-(define-kbdmac-transform "Delete Horizontal Space" #'vanilla-kbdmac-transform)
-(define-kbdmac-transform "Kill Line" #'vanilla-kbdmac-transform)
-(define-kbdmac-transform "Backward Kill Line" #'vanilla-kbdmac-transform)
-(define-kbdmac-transform "Un-Kill" #'vanilla-kbdmac-transform)
-
-;;;; MAKE-KBDMAC, INTERACTIVE, and kbdmac command loop.
-
-;;; Kbdmac-Command-Loop  --  Internal
-;;;
-;;;    Bind *invoke-hook* to call kbdmac transforms.
-;;;
-(defun kbdmac-command-loop ()
-  (let* ((last-transform nil)
-	 (last-command nil)
-	 (last-ctype nil)
-	 (*old-invoke-hook* *invoke-hook*)
-	 (*invoke-hook*
-	  #'(lambda (res p)
-	      (declare (ignore p))
-	      (when (and (not (eq last-command res)) last-transform)
-		(funcall last-transform last-command :finish))
-	      (if (last-command-type)
-		  (setq last-ctype t)
-		  (when last-ctype
-		    (kbdmac-emit '(clear-command-type))
-		    (setq last-ctype nil)))
-	      (setq last-transform 
-		    (gethash res *kbdmac-transforms* #'default-kbdmac-transform))
-	      (unless (eq last-command res)
-		(funcall last-transform res :start))
-	      (funcall last-transform res :invoke)
-	      (setq last-command res))))
-    (declare (special *invoke-hook*))
-    (setf (last-command-type) nil)
-    (recursive-edit nil)))
-
-(defun clear-command-type ()
-  (setf (last-command-type) nil))
-
-
-(defvar *defining-a-keyboard-macro* ())
-(defvar *kbdmac-stream* (make-kbdmac-stream))
-(defvar *in-a-keyboard-macro* ()
-  "True if we are currently executing a keyboard macro.")
-
-;;; Interactive  --  Public
-;;;
-;;;    See whether we are in a keyboard macro.
-;;;
-(defun interactive ()
-  "Return true if we are in a command invoked by the user.
-  This is primarily useful for commands which want to know
-  whether do something when an error happens, or just signal
-  an Editor-Error."
-  (not *in-a-keyboard-macro*))
-
-(defvar *kbdmac-done* ()
-  "Setting this causes the keyboard macro being executed to terminate
-  after the current iteration.")
-
-(defvar *kbdmac-dont-ask* ()
-  "Setting this inhibits \"Keyboard Macro Query\"'s querying.")
-
-;;; Make-Kbdmac  --  Internal
-;;;
-;;;    This guy grabs the stuff lying around in *current-kbdmac* and
-;;; whatnot and makes a lexical closure that can be used as the
-;;; definition of a command.  The prefix argument is a repitition
-;;; count.
-;;;
-(defun make-kbdmac ()
-  (let ((code (nreverse *current-kbdmac*))
-	(input (copy-seq *kbdmac-input*)))
-    (if (zerop (length input))
-	#'(lambda (p)
-	    (let ((*in-a-keyboard-macro* t)
-		  (*kbdmac-done* nil)
-		  (*kbdmac-dont-ask* nil))
-	      (setf (last-command-type) nil)
-	      (catch 'exit-kbdmac
-		(dotimes (i (or p 1))
-		  (catch 'abort-kbdmac-iteration
-		    (dolist (form code)
-		      (apply (car form) (cdr form))))
-		  (when *kbdmac-done* (return nil))))))
-	#'(lambda (p)
-	    (let* ((stream (or *kbdmac-stream* (make-kbdmac-stream)))
-		   (*kbdmac-stream* nil)
-		   (*editor-input* stream)
-		   (*in-a-keyboard-macro* t)
-		   (*kbdmac-done* nil)
-		   (*kbdmac-dont-ask* nil))
-	      (setf (last-command-type) nil)
-	      (catch 'exit-kbdmac
-		(dotimes (i (or p 1))
-		  (setq stream (modify-kbdmac-stream stream input))
-		  (catch 'abort-kbdmac-iteration
-		    (dolist (form code)
-		      (apply (car form) (cdr form))))
-		  (when *kbdmac-done* (return nil)))))))))
-	    	  
-
-
-;;;; Commands.
-
-(defmode "Def" :major-p nil)  
-
-(defcommand "Define Keyboard Macro" (p)
-  "Define a keyboard macro."
-  "Define a keyboard macro."
-  (declare (ignore p))
-  (when *defining-a-keyboard-macro*
-    (editor-error "Already defining a keyboard macro."))
-  (define-keyboard-macro))
-
-(defhvar "Define Keyboard Macro Key Confirm"
-  "When set, \"Define Keyboard Macro Key\" asks for confirmation before
-   clobbering an existing key binding."
-  :value t)
-
-(defcommand "Define Keyboard Macro Key" (p)
-  "Prompts for a key before going into a mode for defining keyboard macros.
-   The macro definition is bound to the key.  IF the key is already bound,
-   this asks for confirmation before clobbering the binding."
-  "Prompts for a key before going into a mode for defining keyboard macros.
-   The macro definition is bound to the key.  IF the key is already bound,
-   this asks for confirmation before clobbering the binding."
-  (declare (ignore p))
-  (when *defining-a-keyboard-macro*
-    (editor-error "Already defining a keyboard macro."))
-  (multiple-value-bind (key kind where)
-		       (get-keyboard-macro-key)
-    (when key
-      (setf (buffer-minor-mode (current-buffer) "Def") t)
-      (let ((name (format nil "Keyboard Macro ~S" (gensym))))
-	(make-command name "This is a user-defined keyboard macro."
-		      (define-keyboard-macro))
-	(bind-key name key kind where)
-	(message "~A bound to ~A."
-		 (with-output-to-string (s) (print-pretty-key key s))
-		 name)))))
-
-;;; GET-KEYBOARD-MACRO-KEY gets a key from the user and confirms clobbering it
-;;; if it is already bound to a command, or it is a :prefix.  This returns nil
-;;; if the user "aborts", otherwise it returns the key and location (kind
-;;; where) of the binding.
-;;;
-(defun get-keyboard-macro-key ()
-  (let* ((key (prompt-for-key :prompt "Bind keyboard macro to key: "
-			      :must-exist nil)))
-    (multiple-value-bind (kind where)
-			 (prompt-for-place "Kind of binding: "
-					   "The kind of binding to make.")
-      (let* ((cmd (get-command key kind where)))
-	(cond ((not cmd) (values key kind where))
-	      ((commandp cmd)
-	       (if (prompt-for-y-or-n
-		    :prompt `("~A is bound to ~A.  Rebind it? "
-			      ,(with-output-to-string (s)
-				 (print-pretty-key key s))
-			      ,(command-name cmd))
-		    :default nil)
-		   (values key kind where)
-		   nil))
-	      ((eq cmd :prefix)
-	       (if (prompt-for-y-or-n
-		    :prompt `("~A is a prefix for more than one command.  ~
-			       Clobber it? "
-			      ,(with-output-to-string (s)
-				 (print-pretty-key key s)))
-		    :default nil)
-		   (values key kind where)
-		   nil)))))))
-
-;;; DEFINE-KEYBOARD-MACRO gets input from the user and clobbers the function
-;;; for the "Last Keyboard Macro" command.  This returns the new function.
-;;;
-(defun define-keyboard-macro ()
-  (setf (buffer-minor-mode (current-buffer) "Def") t)
-  (unwind-protect
-    (let* ((in *kbdmac-transcript*)
-	   (*input-transcript* in)
-	   (*defining-a-keyboard-macro* t))
-      (setf (fill-pointer in) 0)
-      (setf (fill-pointer *kbdmac-input*) 0)
-      (setq *current-kbdmac* ())
-      (catch 'punt-kbdmac
-	(kbdmac-command-loop))
-      (setf (command-function (getstring "Last Keyboard Macro" *command-names*))
-	    (make-kbdmac)))
-    (setf (buffer-minor-mode (current-buffer) "Def") nil)))
-
-
-(defcommand "End Keyboard Macro" (p)
-  "End the definition of a keyboard macro."
-  "End the definition of a keyboard macro."
-  (declare (ignore p))
-  (unless *defining-a-keyboard-macro*
-    (editor-error "Not defining a keyboard macro."))
-  (throw 'punt-kbdmac ()))
-;;;
-(define-kbdmac-transform "End Keyboard Macro" #'do-nothing-kbdmac-transform)
-
-
-(defcommand "Last Keyboard Macro" (p)
-  "Execute the last keyboard macro defined.
-  With prefix argument execute it that many times."
-  "Execute the last keyboard macro P times."
-  (declare (ignore p))
-  (editor-error "No keyboard macro defined."))
-
-(defcommand "Name Keyboard Macro" (p &optional name)
-  "Name the \"Last Keyboard Macro\".
-  The last defined keboard macro is made into a named command."
-  "Make the \"Last Keyboard Macro\" a named command."
-  (declare (ignore p))
-  (unless name
-    (setq name (prompt-for-string
-		:prompt "Macro name: "
-		:help "String name of command to make from keyboard macro.")))
-  (make-command
-    name "This is a named keyboard macro."
-   (command-function (getstring "Last Keyboard Macro" *command-names*))))
-
-(defcommand "Keyboard Macro Query" (p)
-  "Keyboard macro conditional.
-  During the execution of a keyboard macro, this command prompts for
-  a single character command, similar to those of \"Query Replace\"."
-  "Prompt for action during keyboard macro execution."
-  (declare (ignore p))
-  (unless (or (interactive) *kbdmac-dont-ask*)
-    (let ((*editor-input* *real-editor-input*))
-      (command-case (:prompt "Keyboard Macro Query: "
-		     :help "Type one of these characters to say what to do:"
-		     :change-window nil
-		     :bind key-event)
-	(:exit
-	 "Exit this keyboard macro immediately."
-	 (throw 'exit-kbdmac nil))
-	(:yes
-	 "Proceed with this iteration of the keyboard macro.")
-	(:no
-       "Don't do this iteration of the keyboard macro, but continue to the next."
-	 (throw 'abort-kbdmac-iteration nil))
-	(:do-all
-	 "Do all remaining repetitions of the keyboard macro without prompting."
-	 (setq *kbdmac-dont-ask* t))
-	(:do-once
-	 "Do this iteration of the keyboard macro and then exit."
-	 (setq *kbdmac-done* t))
-	(:recursive-edit
-	 "Do a recursive edit, then ask again."
-	 (do-recursive-edit)
-	 (reprompt))
-	(t
-	 (unget-key-event key-event *editor-input*)
-	 (throw 'exit-kbdmac nil))))))
diff --git a/hemlock/key-event.lisp b/hemlock/key-event.lisp
deleted file mode 100644
index d870888fd7ed48eda9cf7c7643545f7c02d9f2ae..0000000000000000000000000000000000000000
--- a/hemlock/key-event.lisp
+++ /dev/null
@@ -1,752 +0,0 @@
-;;; -*- Log: hemlock.log; Package: extensions -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/key-event.lisp,v 1.1.1.10 1992/09/07 16:50:35 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file implements key-events for representing editor input.  It also
-;;; provides a couple routines to interface this to X11.
-;;;
-;;; Written by Blaine Burks and Bill Chiles.
-;;;
-
-;;; The following are the implementation dependent parts of this code (what
-;;; you would have to change if you weren't using X11):
-;;;    *modifier-translations*
-;;;    DEFINE-CLX-MODIFIER
-;;;    TRANSLATE-KEY-EVENT
-;;;    TRANSLATE-MOUSE-KEY-EVENT
-;;;    DEFINE-KEYSYM
-;;;    DEFINE-MOUSE-KEYSYM
-;;;    DO-ALPHA-KEY-EVENTS
-;;; If the window system didn't use a keysym mechanism to represent keys, you
-;;; would also need to write something that mapped whatever did encode the
-;;; keys to the keysyms defined with DEFINE-KEYSYM.
-;;;
-
-(in-package "EXTENSIONS")
-
-(export '( define-keysym define-mouse-keysym name-keysym keysym-names
-	   keysym-preferred-name define-key-event-modifier define-clx-modifier
-	   make-key-event-bits key-event-modifier-mask key-event-bits-modifiers
-	   *all-modifier-names* translate-key-event translate-mouse-key-event
-	   make-key-event key-event key-event-p key-event-bits key-event-keysym
-	   char-key-event key-event-char key-event-bit-p do-alpha-key-events
-	   print-pretty-key print-pretty-key-event))
-
-
-
-;;;; Keysym <==> Name translation.
-
-;;; Keysyms are named by case-insensitive names.  However, if the name
-;;; consists of a single character, the name is case-sensitive.
-;;;
-
-;;; This table maps a keysym to a list of names.  The first name is the
-;;; preferred printing name.
-;;;
-(defvar *keysyms-to-names*)
- 
-;;; This table maps all keysym names to the appropriate keysym.
-;;;
-(defvar *names-to-keysyms*)
-
-(proclaim '(inline name-keysym keysym-names keysym-preferred-name))
-
-(defun name-keysym (name)
-  "This returns the keysym named name.  If name is unknown, this returns nil."
-  (gethash (get-name-case-right name) *names-to-keysyms*))
-
-(defun keysym-names (keysym)
-  "This returns the list of all names for keysym.  If keysym is undefined,
-   this returns nil."
-  (gethash keysym *keysyms-to-names*))
-
-(defun keysym-preferred-name (keysym)
-  "This returns the preferred name for keysym, how it is typically printed.
-   If keysym is undefined, this returns nil."
-  (car (gethash keysym *keysyms-to-names*)))
-
-
-
-;;;; Character key-event stuff.
-
-;;; GET-NAME-CASE-RIGHT -- Internal.
-;;;
-;;; This returns the canonical string for a keysym name for use with
-;;; hash tables.
-;;;
-(defun get-name-case-right (string)
-  (if (= (length string) 1) string (string-downcase string)))
-
-;;; DEFINE-KEYSYM -- Public.
-;;;
-(defun define-keysym (keysym preferred-name &rest other-names)
-  "This establishes a mapping from preferred-name to keysym for purposes of
-   specifying key-events in #k syntax.  Other-names also map to keysym, but the
-   system uses preferred-name when printing key-events.  The names are
-   case-insensitive simple-strings.  Redefining a keysym or re-using names has
-   undefined effects."
-  (setf (gethash keysym *keysyms-to-names*) (cons preferred-name other-names))
-  (dolist (name (cons preferred-name other-names))
-    (setf (gethash (get-name-case-right name) *names-to-keysyms*) keysym)))
-
-;;; This is an a-list mapping CLX modifier masks to defined key-event
-;;; modifier names.  DEFINE-CLX-MODIFIER fills this in, so TRANSLATE-KEY-EVENT
-;;; and TRANSLATE-MOUSE-KEY-EVENT can work.
-;;;
-(defvar *modifier-translations*)
-
-;;; This is an ordered a-list mapping defined key-event modifier names to the
-;;; appropriate mask for the modifier.  Modifier names have a short and a long
-;;; version.  For each pair of names for the same mask, the names are
-;;; contiguous in this list, and the short name appears first.
-;;; PRINT-PRETTY-KEY-EVENT and KEY-EVENT-BITS-MODIFIERS rely on this.
-;;;
-(defvar *modifiers-to-internal-masks*)
-
-;;; TRANSLATE-KEY-EVENT -- Public.
-;;;
-#+clx
-(defun translate-key-event (display scan-code bits)
-  "Translates the X scan-code and X bits to a key-event.  First this maps
-   scan-code to an X keysym using XLIB:KEYCODE->KEYSYM looking at bits and
-   supplying index as 1 if the X shift bit is on, 0 otherwise.
-
-   If the resulting keysym is undefined, and it is not a modifier keysym, then
-   this signals an error.  If the keysym is a modifier key, then this returns
-   nil.
-
-   If the following conditions are satisfied
-      the keysym is defined
-      the X shift bit is off
-      the X lock bit is on
-      the X keysym represents a lowercase letter
-   then this maps the scan-code again supplying index as 1 this time, treating
-   the X lock bit as a caps-lock bit.  If this results in an undefined keysym,
-   this signals an error.  Otherwise, this makes a key-event with the keysym
-   and bits formed by mapping the X bits to key-event bits.
-
-   Otherwise, this makes a key-event with the keysym and bits formed by mapping
-   the X bits to key-event bits."
-  (let ((new-bits 0)
-	shiftp lockp)
-    (dolist (map *modifier-translations*)
-      (unless (zerop (logand (car map) bits))
-	(cond
-	 ((string-equal (cdr map) "Shift")
-	  (setf shiftp t))
-	 ((string-equal (cdr map) "Lock")
-	  (setf lockp t))
-	 (t (setf new-bits
-		  (logior new-bits (key-event-modifier-mask (cdr map))))))))
-    (let ((keysym (xlib:keycode->keysym display scan-code (if shiftp 1 0))))
-      (cond ((null (keysym-names keysym))
-	     nil)
-	    ((and (not shiftp) lockp (<= 97 keysym 122)) ; small-alpha-char-p
-	     (let ((keysym (xlib:keycode->keysym display scan-code 1)))
-	       (if (keysym-names keysym)
-		   (make-key-event keysym new-bits)
-		   nil)))
-	    (t
-	     (make-key-event keysym new-bits))))))
-
-
-
-;;;; Mouse key-event stuff.
-
-;;; Think of this data as a three dimensional array indexed by the following
-;;; domains:
-;;;    1-5
-;;;       for the mouse scan-codes (button numbers) delivered by X.
-;;;    :button-press or :button-release
-;;;       whether the button was pressed or released.
-;;;    :keysym or :shifted-modifier-name
-;;;       whether the X shift bit was set.
-;;; For each button, pressed and released, we store a keysym to be used in a
-;;; key-event representing the button and whether it was pressed or released.
-;;; We also store a modifier name that TRANSLATE-MOUSE-KEY-EVENT turns on
-;;; whenever a mouse event occurs with the X shift bit on.  This is basically
-;;; an archaic feature since we now can specify key-events like the following:
-;;;    #k"shift-leftdown"
-;;; Previously we couldn't, so we mapped the shift bit to a bit we could
-;;; talke about, such as super.
-;;;
-(defvar *mouse-translation-info*)
-
-(eval-when (compile eval)
-  (defmacro button-press-info (event-dispatch) `(car ,event-dispatch))
-  (defmacro button-release-info (event-dispatch) `(cdr ,event-dispatch))
-  (defmacro button-keysym (info) `(car ,info))
-  (defmacro button-shifted-modifier-name (info) `(cdr ,info))
-) ;eval-when
-
-;;; MOUSE-TRANSLATION-INFO -- Internal.
-;;;
-;;; This returns the requested information, :keysym or :shifted-modifier-name,
-;;; for the button cross event-key.  If the information is undefined, this
-;;; signals an error.
-;;;
-(defun mouse-translation-info (button event-key info)
-  (let ((event-dispatch (svref *mouse-translation-info* button)))
-    (unless event-dispatch
-      (error "No defined mouse translation information for button ~S." button))
-    (let ((data (ecase event-key
-		  (:button-press (button-press-info event-dispatch))
-		  (:button-release (button-release-info event-dispatch)))))
-      (unless data
-	(error
-	 "No defined mouse translation information for button ~S and event ~S."
-	 button event-key))
-      (ecase info
-	(:keysym (button-keysym data))
-	(:shifted-modifier-name (button-shifted-modifier-name data))))))
-
-;;; %SET-MOUSE-TRANSLATION-INFO -- Internal.
-;;;
-;;; This walks into *mouse-translation-info* the same way MOUSE-TRANSLATION-INFO
-;;; does, filling in the data structure on an as-needed basis, and stores
-;;; the value for the indicated info.
-;;;
-(defun %set-mouse-translation-info (button event-key info value)
-  (let ((event-dispatch (svref *mouse-translation-info* button)))
-    (unless event-dispatch
-      (setf event-dispatch
-	    (setf (svref *mouse-translation-info* button) (cons nil nil))))
-    (let ((data (ecase event-key
-		  (:button-press (button-press-info event-dispatch))
-		  (:button-release (button-release-info event-dispatch)))))
-      (unless data
-	(setf data
-	      (ecase event-key
-		(:button-press
-		 (setf (button-press-info event-dispatch) (cons nil nil)))
-		(:button-release
-		 (setf (button-release-info event-dispatch) (cons nil nil))))))
-      (ecase info
-	(:keysym
-	 (setf (button-keysym data) value))
-	(:shifted-modifier-name
-	 (setf (button-shifted-modifier-name data) value))))))
-;;;
-(defsetf mouse-translation-info %set-mouse-translation-info)
-
-;;; DEFINE-MOUSE-KEYSYM -- Public.
-;;;
-(defun define-mouse-keysym (button keysym name shifted-bit event-key)
-  "This defines keysym named name for the X button cross the X event-key.
-   Shifted-bit is a defined modifier name that TRANSLATE-MOUSE-KEY-EVENT sets
-   in the key-event it returns whenever the X shift bit is on."
-  (unless (<= 1 button 5)
-    (error "Buttons are number 1-5, not ~D." button))
-  (setf (gethash keysym *keysyms-to-names*) (list name))
-  (setf (gethash  (get-name-case-right name) *names-to-keysyms*) keysym)
-  (setf (mouse-translation-info button event-key :keysym) keysym)
-  (setf (mouse-translation-info button event-key :shifted-modifier-name)
-	shifted-bit))
-
-;;; TRANSLATE-MOUSE-KEY-EVENT -- Public.
-;;;
-(defun translate-mouse-key-event (scan-code bits event-key)
-  "This translates the X button code, scan-code, and modifier bits, bits, for
-   the X event-key into a key-event.  See DEFINE-MOUSE-KEYSYM."
-  (let ((keysym (mouse-translation-info scan-code event-key :keysym))
-	(new-bits 0))
-    (dolist (map *modifier-translations*)
-      (when (logtest (car map) bits)
-	(setf new-bits
-	      (if (string-equal (cdr map) "Shift")
-		  (logior new-bits
-			  (key-event-modifier-mask
-			   (mouse-translation-info
-			    scan-code event-key :shifted-modifier-name)))
-		  (logior new-bits
-			  (key-event-modifier-mask (cdr map)))))))
-    (make-key-event keysym new-bits)))
-
-
-
-;;;; Stuff for parsing #k syntax.
-
-(defstruct (key-event (:print-function %print-key-event)
-		      (:constructor %make-key-event (keysym bits)))
-  (bits nil :type fixnum)
-  (keysym nil :type fixnum))
-
-(defun %print-key-event (object stream ignore)
-  (declare (ignore ignore))
-  (write-string "#<Key-Event " stream)
-  (print-pretty-key-event object stream)
-  (write-char #\> stream))
-
-;;; This maps Common Lisp CHAR-CODE's to character classes for parsing #k
-;;; syntax.
-;;;
-(defvar *key-character-classes* (make-array char-code-limit
-					    :initial-element :other))
-
-;;; These characters are special:
-;;;    #\<  ..........  :ISO-start - Signals start of an ISO character.
-;;;    #\>  ..........  :ISO-end - Signals end of an ISO character.
-;;;    #\-  ..........  :modifier-terminator - Indicates last *id-namestring*
-;;;                                            was a modifier.
-;;;    #\"  ..........  :EOF - Means we have come to the end of the character.
-;;;    #\{a-z, A-Z} ..  :letter - Means the char is a letter.
-;;;    #\space .......  :event-terminator- Indicates the last *id-namestring*
-;;;                                        was a character name.
-;;;
-;;; Every other character has class :other.
-;;;
-(hi::do-alpha-chars (char :both)
-  (setf (svref *key-character-classes* (char-code char)) :letter))
-(setf (svref *key-character-classes* (char-code #\<)) :ISO-start)
-(setf (svref *key-character-classes* (char-code #\>)) :ISO-end)
-(setf (svref *key-character-classes* (char-code #\-)) :modifier-terminator)
-(setf (svref *key-character-classes* (char-code #\space)) :event-terminator)
-(setf (svref *key-character-classes* (char-code #\")) :EOF)
-  
-;;; This holds the characters built up while lexing a potential keysym or
-;;; modifier identifier.
-;;;
-(defvar *id-namestring*
-  (make-array 30 :adjustable t :fill-pointer 0 :element-type 'base-char))
-
-;;; PARSE-KEY-FUN -- Internal.
-;;;
-;;; This is the #k dispatch macro character reader.  It is a FSM that parses
-;;; key specifications.  It returns either a VECTOR form or a MAKE-KEY-EVENT
-;;; form.  Since key-events are unique at runtime, we cannot create them at
-;;; readtime, returning the constant object from READ.  Wherever a #k appears,
-;;; there's a for that at loadtime or runtime will return the unique key-event
-;;; or vector of unique key-events.
-;;;
-(defun parse-key-fun (stream sub-char count)
-  (declare (ignore sub-char count))
-  (setf (fill-pointer *id-namestring*) 0)
-  (prog ((bits 0)
-	 (key-event-list ())
-	 char class)
-	(unless (char= (read-char stream) #\")
-	  (error "Keys must be delimited by ~S." #\"))
-	;; Skip any leading spaces in the string.
-	(skip-whitespace stream)
-	(multiple-value-setq (char class) (get-key-char stream))
-	(ecase class
-	  ((:letter :other :escaped) (go ID))
-	  (:ISO-start (go ISOCHAR))
-	  (:ISO-end (error "Angle brackets must be escaped."))
-	  (:modifier-terminator (error "Dash must be escaped."))
-	  (:EOF (error "No key to read.")))
-	ID
-	(vector-push-extend char *id-namestring*)
-	(multiple-value-setq (char class) (get-key-char stream))
-	(ecase class
-	  ((:letter :other :escaped) (go ID))
-	  (:event-terminator (go GOT-CHAR))
-	  (:modifier-terminator (go GOT-MODIFIER))
-	  ((:ISO-start :ISO-end) (error "Angle brackets must be escaped."))
-	  (:EOF (go GET-LAST-CHAR)))
-	GOT-CHAR
-	(push `(make-key-event ,(copy-seq *id-namestring*) ,bits)
-	      key-event-list)
-	(setf (fill-pointer *id-namestring*) 0)
-	(setf bits 0)
-	;; Skip any whitespace between characters.
-	(skip-whitespace stream)
-	(multiple-value-setq (char class) (get-key-char stream))
-	(ecase class
-	  ((:letter :other :escaped) (go ID))
-	  (:ISO-start (go ISOCHAR))
-	  (:ISO-end (error "Angle brackets must be escaped."))
-	  (:modifier-terminator (error "Dash must be escaped."))
-	  (:EOF (go FINAL)))
-	GOT-MODIFIER
-	(let ((modifier-name (car (assoc *id-namestring*
-					 *modifiers-to-internal-masks*
-					 :test #'string-equal))))
-	  (unless modifier-name
-	    (error "~S is not a defined modifier." *id-namestring*))
-	  (setf (fill-pointer *id-namestring*) 0)
-	  (setf bits (logior bits (key-event-modifier-mask modifier-name))))
-	(multiple-value-setq (char class) (get-key-char stream))
-	(ecase class
-	  ((:letter :other :escaped) (go ID))
-	  (:ISO-start (go ISOCHAR))
-	  (:ISO-end (error "Angle brackets must be escaped."))
-	  (:modifier-terminator (error "Dash must be escaped."))
-	  (:EOF (error "Expected something naming a key-event, got EOF.")))
-	ISOCHAR
-	(multiple-value-setq (char class) (get-key-char stream))
-	(ecase class
-	  ((:letter :event-terminator :other :escaped)
-	   (vector-push-extend char *id-namestring*)
-	   (go ISOCHAR))
-	  (:ISO-start (error "Open Angle must be escaped."))
-	  (:modifier-terminator (error "Dash must be escaped."))
-	  (:EOF (error "Bad syntax in key specification, hit eof."))
-	  (:ISO-end (go GOT-CHAR)))
-	GET-LAST-CHAR
-	(push `(make-key-event ,(copy-seq *id-namestring*) ,bits)
-	      key-event-list)
-	FINAL
-	(return (if (cdr key-event-list)
-		    `(vector ,@(nreverse key-event-list))
-		    `,(car key-event-list)))))
-
-(set-dispatch-macro-character #\# #\k #'parse-key-fun)
-
-(defconstant key-event-escape-char #\\
-  "The escape character that #k uses.")
-
-;;; GET-KEY-CHAR -- Internal.
-;;;
-;;; This is used by PARSE-KEY-FUN.
-;;;
-(defun get-key-char (stream)
-  (let ((char (read-char stream t nil t)))
-    (cond ((char= char key-event-escape-char)
-	   (let ((char (read-char stream t nil t)))
-	     (values char :escaped)))
-	  (t (values char (svref *key-character-classes* (char-code char)))))))
-
-
-
-;;;; Code to deal with modifiers.
-
-(defvar *modifier-count* 0
-  "The number of modifiers that is currently defined.")
-
-(eval-when (compile eval load)
-
-(defconstant modifier-count-limit 6
-  "The maximum number of modifiers supported.")
-
-); eval-when
-
-;;; This is purely a list for users.
-;;;
-(defvar *all-modifier-names* ()
-  "A list of all the names of defined modifiers.")
-
-;;; DEFINE-KEY-EVENT-MODIFIER -- Public.
-;;;
-;;; Note that short-name is pushed into *modifiers-to-internal-masks* after
-;;; long-name.  PRINT-PRETTY-KEY-EVENT and KEY-EVENT-BITS-MODIFIERS rely on
-;;; this feature.
-;;;
-(defun define-key-event-modifier (long-name short-name)
-  "This establishes long-name and short-name as modifier names for purposes
-   of specifying key-events in #k syntax.  The names are case-insensitive and
-   must be strings.  If either name is already defined, this signals an error."
-  (when (= *modifier-count* modifier-count-limit)
-    (error "Maximum of ~D modifiers allowed." modifier-count-limit))
-  (let ((long-name (string-capitalize long-name))
-	(short-name (string-capitalize short-name)))
-    (flet ((frob (name)
-	     (when (assoc name *modifiers-to-internal-masks*
-			  :test #'string-equal)
-	       (restart-case
-		   (error "Modifier name has already been defined -- ~S" name)
-		 (blow-it-off ()
-		  :report "Go on without defining this modifier."
-		  (return-from define-key-event-modifier nil))))))
-      (frob long-name)
-      (frob short-name))
-    (unwind-protect
-	(let ((new-bits (ash 1 *modifier-count*)))
-	  (push (cons long-name new-bits) *modifiers-to-internal-masks*)
-	  (push (cons short-name new-bits) *modifiers-to-internal-masks*)
-	  (pushnew long-name *all-modifier-names* :test #'string-equal)
-	  ;; Sometimes the long-name is the same as the short-name.
-	  (pushnew short-name *all-modifier-names* :test #'string-equal))
-      (incf *modifier-count*))))
-
-;;;
-;;; RE-INITIALIZE-KEY-EVENTS at the end of this file defines the system
-;;; default key-event modifiers.
-;;; 
-
-;;; DEFINE-CLX-MODIFIER -- Public.
-;;;
-(defun define-clx-modifier (clx-mask modifier-name)
-  "This establishes a mapping from clx-mask to a define key-event modifier-name.
-   TRANSLATE-KEY-EVENT and TRANSLATE-MOUSE-KEY-EVENT can only return key-events
-   with bits defined by this routine."
-  (let ((map (assoc modifier-name *modifiers-to-internal-masks*
-		    :test #'string-equal)))
-    (unless map (error "~S an undefined modifier name." modifier-name))
-    (push (cons clx-mask (car map)) *modifier-translations*)))
-
-;;;
-;;; RE-INITIALIZE-KEY-EVENTS at the end of this file defines the system
-;;; default clx modifiers, mapping them to some system default key-event
-;;; modifiers.
-;;; 
-
-;;; MAKE-KEY-EVENT-BITS -- Public.
-;;;
-(defun make-key-event-bits (&rest modifier-names)
-  "This returns bits suitable for MAKE-KEY-EVENT from the supplied modifier
-   names.  If any name is undefined, this signals an error."
-  (let ((mask 0))
-    (dolist (mod modifier-names mask)
-      (let ((this-mask (cdr (assoc mod *modifiers-to-internal-masks*
-				   :test #'string-equal))))
-	(unless this-mask (error "~S is an undefined modifier name." mod))
-	(setf mask (logior mask this-mask))))))
-
-;;; KEY-EVENT-BITS-MODIFIERS -- Public.
-;;;
-(defun key-event-bits-modifiers (bits)
-  "This returns a list of key-event modifier names, one for each modifier
-   set in bits."
-  (let ((res nil))
-    (do ((map (cdr *modifiers-to-internal-masks*) (cddr map)))
-	((null map) res)
-      (when (logtest bits (cdar map))
-	(push (caar map) res)))))
-
-;;; KEY-EVENT-MODIFIER-MASK -- Public.
-;;;
-(defun key-event-modifier-mask (modifier-name)
-  "This function returns a mask for modifier-name.  This mask is suitable
-   for use with KEY-EVENT-BITS.  If modifier-name is undefined, this signals
-   an error."
-  (let ((res (cdr (assoc modifier-name *modifiers-to-internal-masks*
-			 :test #'string-equal))))
-    (unless res (error "Undefined key-event modifier -- ~S." modifier-name))
-    res))
-
-
-
-;;;; Key event lookup -- GET-KEY-EVENT and MAKE-KEY-EVENT.
-
-(defvar *keysym-high-bytes*)
-
-(defconstant modifier-bits-limit (ash 1 modifier-count-limit))
-
-;;; GET-KEY-EVENT -- Internal.
-;;;
-;;; This finds the key-event specified by keysym and bits.  If the key-event
-;;; does not already exist, this creates it.  This assumes keysym is defined,
-;;; and if it isn't, this will make a key-event anyway that will cause an
-;;; error when the system tries to print it.
-;;;
-(defun get-key-event (keysym bits)
-  (let* ((high-byte (ash keysym -8))
-	 (low-byte-vector (svref *keysym-high-bytes* high-byte)))
-    (unless low-byte-vector
-      (let ((new-vector (make-array 256 :initial-element nil)))
-	(setf (svref *keysym-high-bytes* high-byte) new-vector)
-	(setf low-byte-vector new-vector)))
-    (let* ((low-byte (ldb (byte 8 0) keysym))
-	   (bit-vector (svref low-byte-vector low-byte)))
-      (unless bit-vector
-	(let ((new-vector (make-array modifier-bits-limit
-				      :initial-element nil)))
-	  (setf (svref low-byte-vector low-byte) new-vector)
-	  (setf bit-vector new-vector)))
-      (let ((key-event (svref bit-vector bits)))
-	(if key-event
-	    key-event
-	    (setf (svref bit-vector bits) (%make-key-event keysym bits)))))))
-
-;;; MAKE-KEY-EVENT --  Public.
-;;;
-(defun make-key-event (object &optional (bits 0))
-  "This returns a key-event described by object with bits.  Object is one of
-   keysym, string, or key-event.  When object is a key-event, this uses
-   KEY-EVENT-KEYSYM.  You can form bits with MAKE-KEY-EVENT-BITS or
-   KEY-EVENT-MODIFIER-MASK."
-  (etypecase object
-    (integer
-     (unless (keysym-names object)
-       (error "~S is an undefined keysym." object))
-     (get-key-event object bits))
-    #|(character
-     (let* ((name (char-name object))
-	    (keysym (name-keysym (or name (string object)))))
-       (unless keysym
-	 (error "~S is an undefined keysym." object))
-       (get-key-event keysym bits)))|#
-    (string
-     (let ((keysym (name-keysym object)))
-       (unless keysym
-	 (error "~S is an undefined keysym." object))
-       (get-key-event keysym bits)))
-    (key-event
-     (get-key-event (key-event-keysym object) bits))))
-
-;;; KEY-EVENT-BIT-P -- Public.
-;;;
-(defun key-event-bit-p (key-event bit-name)
-  "This returns whether key-event has the bit set named by bit-name.  This
-   signals an error if bit-name is undefined."
-  (let ((mask (cdr (assoc bit-name *modifiers-to-internal-masks*
-			  :test #'string-equal))))
-    (unless mask
-      (error "~S is not a defined modifier." bit-name))
-    (not (zerop (logand (key-event-bits key-event) mask)))))
-
-
-
-;;;; KEY-EVENT-CHAR and CHAR-KEY-EVENT.
-
-;;; This maps key-events to characters.  Users modify this by SETF'ing
-;;; KEY-EVENT-CHAR.
-;;;
-(defvar *key-event-characters*)
-
-(defun key-event-char (key-event)
-  "Returns the character associated with key-event. This is SETF'able."
-  (check-type key-event key-event)
-  (gethash key-event *key-event-characters*))
-
-(defun %set-key-event-char (key-event character)
-  (check-type character character)
-  (check-type key-event key-event)
-  (setf (gethash key-event *key-event-characters*) character))
-;;;
-(defsetf key-event-char %set-key-event-char)
-
-
-;;; This maps characters to key-events.  Users modify this by SETF'ing
-;;; CHAR-KEY-EVENT.
-;;;
-(defvar *character-key-events*)
-
-(defun char-key-event (char)
-  "Returns the key-event associated with char.  This is SETF'able."
-  (check-type char character)
-  (svref *character-key-events* (char-code char)))
-
-(defun %set-char-key-event (char key-event)
-  (check-type char character)
-  (check-type key-event key-event)
-  (setf (svref *character-key-events* (char-code char)) key-event))
-;;;
-(defsetf char-key-event %set-char-key-event)
-
-
-
-;;;; DO-ALPHA-KEY-EVENTS.
-
-(defmacro alpha-key-events-loop (var start-keysym end-keysym result body)
-  (let ((n (gensym)))
-    `(do ((,n ,start-keysym (1+ ,n)))
-	 ((> ,n ,end-keysym) ,result)
-       (let ((,var (make-key-event ,n 0)))
-	 (when (alpha-char-p (key-event-char ,var))
-	   ,@body)))))
-
-(defmacro do-alpha-key-events ((var kind &optional result) &rest forms)
-  "(DO-ALPHA-KEY-EVENTS (var kind [result]) {form}*)
-   This macro evaluates each form with var bound to a key-event representing an
-   alphabetic character.  Kind is one of :lower, :upper, or :both, and this
-   binds var to each key-event in order as specified in the X11 protocol
-   specification.  When :both is specified, this processes lowercase letters
-   first."
-  (case kind
-    (:both
-     `(progn (alpha-key-events-loop ,var 97 122 nil ,forms)
-	     (alpha-key-events-loop ,var 65 90 ,result ,forms)))
-    (:lower
-     `(alpha-key-events-loop ,var 97 122 ,result ,forms))
-    (:upper
-     `(alpha-key-events-loop ,var 65 90 ,result ,forms))
-    (t (error "Kind argument not one of :lower, :upper, or :both -- ~S."
-	      kind))))
-
-
-
-;;;; PRINT-PRETTY-KEY and PRINT-PRETTY-KEY-EVENT.
-
-;;; PRINT-PRETTY-KEY -- Public.
-;;;
-(defun print-pretty-key (key &optional (stream *standard-output*) long-names-p)
-  "This prints key, a key-event or vector of key-events, to stream in a
-   user-expected fashion.  Long-names-p indicates whether modifiers should
-   print with their long or short name."
-  (etypecase key
-    (structure (print-pretty-key-event key stream long-names-p))
-    (vector
-     (let ((length-1 (1- (length key))))
-       (dotimes (i (length key))
-	 (let ((key-event (aref key i)))
-	   (print-pretty-key-event key-event stream long-names-p)
-	   (unless (= i length-1) (write-char #\space stream))))))))
-
-;;; PRINT-PRETTY-KEY-EVENT -- Public.
-;;;
-;;; Note, this makes use of the ordering in the a-list
-;;; *modifiers-to-internal-masks* by CDDR'ing down it by starting on a short
-;;; name or a long name.
-;;;
-(defun print-pretty-key-event (key-event &optional (stream *standard-output*)
-					 long-names-p)
-  "This prints key-event to stream.  Long-names-p indicates whether modifier
-   names should appear using the long name or short name."
-  (do ((map (if long-names-p
-		(cdr *modifiers-to-internal-masks*)
-		*modifiers-to-internal-masks*)
-	    (cddr map)))
-      ((null map))
-    (when (not (zerop (logand (cdar map) (key-event-bits key-event))))
-      (write-string (caar map) stream)
-      (write-char #\- stream)))
-  (let* ((name (keysym-preferred-name (key-event-keysym key-event)))
-	 (spacep (position #\space (the simple-string name))))
-    (when spacep (write-char #\< stream))
-    (write-string name stream)
-    (when spacep (write-char #\> stream))))
-
-
-
-;;;; Re-initialization.
-
-;;; RE-INITIALIZE-KEY-EVENTS -- Internal.
-;;;
-(defun re-initialize-key-events ()
-  "This blows away all data associated with keysyms, modifiers, mouse
-   translations, and key-event/characters mapping.  Then it re-establishes
-   the system defined key-event modifiers and the system defined CLX
-   modifier mappings to some of those key-event modifiers.
-
-   When recompiling this file, you should load it and call this function
-   before using any part of the key-event interface, especially before
-   defining all your keysyms and using #k syntax."
-  (setf *keysyms-to-names* (make-hash-table :test #'eql))
-  (setf *names-to-keysyms* (make-hash-table :test #'equal))
-  (setf *modifier-translations* ())
-  (setf *modifiers-to-internal-masks* ())
-  (setf *mouse-translation-info* (make-array 6 :initial-element nil))
-  (setf *modifier-count* 0)
-  (setf *all-modifier-names* ())
-  (setf *keysym-high-bytes* (make-array 256 :initial-element nil))
-  (setf *key-event-characters* (make-hash-table))
-  (setf *character-key-events*
-	(make-array char-code-limit :initial-element nil))
-  
-  (define-key-event-modifier "Hyper" "H")
-  (define-key-event-modifier "Super" "S")
-  (define-key-event-modifier "Meta" "M")
-  (define-key-event-modifier "Control" "C")
-  (define-key-event-modifier "Shift" "Shift")
-  (define-key-event-modifier "Lock" "Lock")
-
-  #+clx (define-clx-modifier (xlib:make-state-mask :shift) "Shift")
-  #+clx (define-clx-modifier (xlib:make-state-mask :mod-1) "Meta")
-  #+clx (define-clx-modifier (xlib:make-state-mask :control) "Control")
-  #+clx (define-clx-modifier (xlib:make-state-mask :lock) "Lock"))
-
-;;; Initialize stuff if not already initialized.
-;;;
-(unless (boundp '*keysyms-to-names*)
-  (re-initialize-key-events))
diff --git a/hemlock/keysym-defs.lisp b/hemlock/keysym-defs.lisp
deleted file mode 100644
index 54c55f18b42f1badf5ed8ac8c10595fde9935465..0000000000000000000000000000000000000000
--- a/hemlock/keysym-defs.lisp
+++ /dev/null
@@ -1,251 +0,0 @@
-;;; -*- Log: hemlock.log; Mode: Lisp; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/keysym-defs.lisp,v 1.2 1991/02/08 16:35:42 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file defines all the definitions of keysyms (see key-event.lisp).
-;;; These keysyms match those for X11.
-;;;
-;;; Written by Bill Chiles
-;;; Modified by Blaine Burks.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-
-;;; The IBM RT keyboard has X11 keysyms defined for the following modifier
-;;; keys, but we leave them mapped to nil indicating that they are non-events
-;;; to be ignored:
-;;;    ctrl		65507
-;;;    meta (left)	65513
-;;;    meta (right)	65514
-;;;    shift (left)	65505
-;;;    shift (right)	65506
-;;;    lock		65509
-;;;
-
-
-;;; Function keys for the RT.
-;;;
-(ext:define-keysym 65470 "F1")
-(ext:define-keysym 65471 "F2")
-(ext:define-keysym 65472 "F3")
-(ext:define-keysym 65473 "F4")
-(ext:define-keysym 65474 "F5")
-(ext:define-keysym 65475 "F6")
-(ext:define-keysym 65476 "F7")
-(ext:define-keysym 65477 "F8")
-(ext:define-keysym 65478 "F9")
-(ext:define-keysym 65479 "F10")
-(ext:define-keysym 65480 "F11" "L1")
-(ext:define-keysym 65481 "F12" "L2")
-
-;;; Function keys for the Sun (and other keyboards) -- L1-L10 and R1-R15.
-;;;
-(ext:define-keysym 65482 "F13" "L3")
-(ext:define-keysym 65483 "F14" "L4")
-(ext:define-keysym 65484 "F15" "L5")
-(ext:define-keysym 65485 "F16" "L6")
-(ext:define-keysym 65486 "F17" "L7")
-(ext:define-keysym 65487 "F18" "L8")
-(ext:define-keysym 65488 "F19" "L9")
-(ext:define-keysym 65489 "F20" "L10")
-(ext:define-keysym 65490 "F21" "R1")
-(ext:define-keysym 65491 "F22" "R2")
-(ext:define-keysym 65492 "F23" "R3")
-(ext:define-keysym 65493 "F24" "R4")
-(ext:define-keysym 65494 "F25" "R5")
-(ext:define-keysym 65495 "F26" "R6")
-(ext:define-keysym 65496 "F27" "R7")
-(ext:define-keysym 65497 "F28" "R8")
-(ext:define-keysym 65498 "F29" "R9")
-(ext:define-keysym 65499 "F30" "R10")
-(ext:define-keysym 65500 "F31" "R11")
-(ext:define-keysym 65501 "F32" "R12")
-(ext:define-keysym 65502 "F33" "R13")
-(ext:define-keysym 65503 "F34" "R14")
-(ext:define-keysym 65504 "F35" "R15")
-
-;;; Upper right key bank.
-;;;
-(ext:define-keysym 65377 "Printscreen")
-;; Couldn't type scroll lock.
-(ext:define-keysym 65299 "Pause")
-
-;;; Middle right key bank.
-;;;
-(ext:define-keysym 65379 "Insert")
-(ext:define-keysym 65535 "Delete" "Rubout" (string (code-char 127)))
-(ext:define-keysym 65360 "Home")
-(ext:define-keysym 65365 "Pageup")
-(ext:define-keysym 65367 "End")
-(ext:define-keysym 65366 "Pagedown")
-
-;;; Arrows.
-;;;
-(ext:define-keysym 65361 "Leftarrow")
-(ext:define-keysym 65362 "Uparrow")
-(ext:define-keysym 65364 "Downarrow")
-(ext:define-keysym 65363 "Rightarrow")
-
-;;; Number pad.
-;;;
-(ext:define-keysym 65407 "Numlock")
-(ext:define-keysym 65421 "Numpad\-Return" "Numpad\-Enter")	;num-pad-enter
-(ext:define-keysym 65455 "Numpad/") 				;num-pad-/
-(ext:define-keysym 65450 "Numpad*")				;num-pad-*
-(ext:define-keysym 65453 "Numpad-")				;num-pad--
-(ext:define-keysym 65451 "Numpad+")				;num-pad-+
-(ext:define-keysym 65456 "Numpad0")				;num-pad-0
-(ext:define-keysym 65457 "Numpad1")				;num-pad-1
-(ext:define-keysym 65458 "Numpad2")				;num-pad-2
-(ext:define-keysym 65459 "Numpad3")				;num-pad-3
-(ext:define-keysym 65460 "Numpad4")				;num-pad-4
-(ext:define-keysym 65461 "Numpad5")				;num-pad-5
-(ext:define-keysym 65462 "Numpad6")				;num-pad-6
-(ext:define-keysym 65463 "Numpad7")				;num-pad-7
-(ext:define-keysym 65464 "Numpad8")				;num-pad-8
-(ext:define-keysym 65465 "Numpad9")				;num-pad-9
-(ext:define-keysym 65454 "Numpad.")				;num-pad-.
-
-;;; "Named" keys.
-;;;
-(ext:define-keysym 65289 "Tab")
-(ext:define-keysym 65307 "Escape" "Altmode" "Alt")		;escape
-(ext:define-keysym 65288 "Backspace")				;backspace
-(ext:define-keysym 65293 "Return" "Enter")			;enter
-(ext:define-keysym 65512 "Linefeed" "Action" "Newline")		;action
-(ext:define-keysym 32 "Space" " ")
-
-;;; Letters.
-;;;
-(ext:define-keysym 97 "a") (ext:define-keysym 65 "A")
-(ext:define-keysym 98 "b") (ext:define-keysym 66 "B")
-(ext:define-keysym 99 "c") (ext:define-keysym 67 "C")
-(ext:define-keysym 100 "d") (ext:define-keysym 68 "D")
-(ext:define-keysym 101 "e") (ext:define-keysym 69 "E")
-(ext:define-keysym 102 "f") (ext:define-keysym 70 "F")
-(ext:define-keysym 103 "g") (ext:define-keysym 71 "G")
-(ext:define-keysym 104 "h") (ext:define-keysym 72 "H")
-(ext:define-keysym 105 "i") (ext:define-keysym 73 "I")
-(ext:define-keysym 106 "j") (ext:define-keysym 74 "J")
-(ext:define-keysym 107 "k") (ext:define-keysym 75 "K")
-(ext:define-keysym 108 "l") (ext:define-keysym 76 "L")
-(ext:define-keysym 109 "m") (ext:define-keysym 77 "M")
-(ext:define-keysym 110 "n") (ext:define-keysym 78 "N")
-(ext:define-keysym 111 "o") (ext:define-keysym 79 "O")
-(ext:define-keysym 112 "p") (ext:define-keysym 80 "P")
-(ext:define-keysym 113 "q") (ext:define-keysym 81 "Q")
-(ext:define-keysym 114 "r") (ext:define-keysym 82 "R")
-(ext:define-keysym 115 "s") (ext:define-keysym 83 "S")
-(ext:define-keysym 116 "t") (ext:define-keysym 84 "T")
-(ext:define-keysym 117 "u") (ext:define-keysym 85 "U")
-(ext:define-keysym 118 "v") (ext:define-keysym 86 "V")
-(ext:define-keysym 119 "w") (ext:define-keysym 87 "W")
-(ext:define-keysym 120 "x") (ext:define-keysym 88 "X")
-(ext:define-keysym 121 "y") (ext:define-keysym 89 "Y")
-(ext:define-keysym 122 "z") (ext:define-keysym 90 "Z")
-
-;;; Standard number keys.
-;;;
-(ext:define-keysym 49 "1") (ext:define-keysym 33 "!")
-(ext:define-keysym 50 "2") (ext:define-keysym 64 "@")
-(ext:define-keysym 51 "3") (ext:define-keysym 35 "#")
-(ext:define-keysym 52 "4") (ext:define-keysym 36 "$")
-(ext:define-keysym 53 "5") (ext:define-keysym 37 "%")
-(ext:define-keysym 54 "6") (ext:define-keysym 94 "^")
-(ext:define-keysym 55 "7") (ext:define-keysym 38 "&")
-(ext:define-keysym 56 "8") (ext:define-keysym 42 "*")
-(ext:define-keysym 57 "9") (ext:define-keysym 40 "(")
-(ext:define-keysym 48 "0") (ext:define-keysym 41 ")")
-
-;;; "Standard" symbol keys.
-;;;
-(ext:define-keysym 96 "`") (ext:define-keysym 126 "~")
-(ext:define-keysym 45 "-") (ext:define-keysym 95 "_")
-(ext:define-keysym 61 "=") (ext:define-keysym 43 "+")
-(ext:define-keysym 91 "[") (ext:define-keysym 123 "{")
-(ext:define-keysym 93 "]") (ext:define-keysym 125 "}")
-(ext:define-keysym 92 "\\") (ext:define-keysym 124 "|")
-(ext:define-keysym 59 ";") (ext:define-keysym 58 ":")
-(ext:define-keysym 39 "'") (ext:define-keysym 34 "\"")
-(ext:define-keysym 44 ",") (ext:define-keysym 60 "<")
-(ext:define-keysym 46 ".") (ext:define-keysym 62 ">")
-(ext:define-keysym 47 "/") (ext:define-keysym 63 "?")
-
-;;; Standard Mouse keysyms.
-;;;
-(ext::define-mouse-keysym 1 25601 "Leftdown" "Super" :button-press)
-(ext::define-mouse-keysym 1 25602 "Leftup" "Super" :button-release)
-
-(ext::define-mouse-keysym 2 25603 "Middledown" "Super" :button-press)
-(ext::define-mouse-keysym 2 25604 "Middleup" "Super" :button-release)
-
-(ext::define-mouse-keysym 3 25605 "Rightdown" "Super" :button-press)
-(ext::define-mouse-keysym 3 25606 "Rightup" "Super" :button-release)
-
-;;; Sun keyboard.
-;;;
-(ext:define-keysym 65387 "break")			;alternate (Sun).
-;(ext:define-keysym 65290 "linefeed")
-
-
-
-;;;; SETFs of KEY-EVANT-CHAR and CHAR-KEY-EVENT.
-
-;;; Converting ASCII control characters to Common Lisp control characters:
-;;; ASCII control character codes are separated from the codes of the
-;;; "non-controlified" characters by the code of atsign.  The ASCII control
-;;; character codes range from ^@ (0) through ^_ (one less than the code of
-;;; space).  We iterate over this range adding the ASCII code of atsign to
-;;; get the "non-controlified" character code.  With each of these, we turn
-;;; the code into a Common Lisp character and set its :control bit.  Certain
-;;; ASCII control characters have to be translated to special Common Lisp
-;;; characters outside of the loop.
-;;;    With the advent of Hemlock running under X, and all the key bindings
-;;; changing, we also downcase each Common Lisp character (where normally
-;;; control characters come in upcased) in an effort to obtain normal command
-;;; bindings.  Commands bound to uppercase modified characters will not be
-;;; accessible to terminal interaction.
-;;; 
-(let ((@-code (char-code #\@)))
-  (dotimes (i (char-code #\space))
-    (setf (ext:char-key-event (code-char i))
-	  (ext::make-key-event (string (char-downcase (code-char (+ i @-code))))
-			       (key-event-modifier-mask "control")))))
-(setf (ext:char-key-event (code-char 9)) (ext::make-key-event #k"Tab"))
-(setf (ext:char-key-event (code-char 10)) (ext::make-key-event #k"Linefeed"))
-(setf (ext:char-key-event (code-char 13)) (ext::make-key-event #k"Return"))
-(setf (ext:char-key-event (code-char 27)) (ext::make-key-event #k"Alt"))
-(setf (ext:char-key-event (code-char 8)) (ext::make-key-event #k"Backspace"))
-;;;
-;;; Other ASCII codes are exactly the same as the Common Lisp codes.
-;;; 
-(do ((i (char-code #\space) (1+ i)))
-    ((= i 128))
-  (setf (ext:char-key-event (code-char i))
-	(ext::make-key-event (string (code-char i)))))
-
-;;; This makes KEY-EVENT-CHAR the inverse of CHAR-KEY-EVENT from the start.
-;;; It need not be this way, but it is.
-;;;
-(dotimes (i 128)
-  (let ((character (code-char i)))
-    (setf (ext::key-event-char (ext:char-key-event character)) character)))
-
-;;; Since we treated these characters specially above when setting
-;;; EXT:CHAR-KEY-EVENT above, we must set these EXT:KEY-EVENT-CHAR's specially
-;;; to make quoting characters into Hemlock buffers more obvious for users.
-;;;
-(setf (ext:key-event-char #k"C-h") #\backspace)
-(setf (ext:key-event-char #k"C-i") #\tab)
-(setf (ext:key-event-char #k"C-j") #\linefeed)
-(setf (ext:key-event-char #k"C-m") #\return)
diff --git a/hemlock/keytran.lisp b/hemlock/keytran.lisp
deleted file mode 100644
index 30e4fd87c32cef92401483c2148db25f9df0b402..0000000000000000000000000000000000000000
--- a/hemlock/keytran.lisp
+++ /dev/null
@@ -1,185 +0,0 @@
-;;; -*- Log: hemlock.log; Package: extensions -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/keytran.lisp,v 1.2 1991/02/08 16:35:46 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains a default character translation mechanism for X11
-;;; scan codes, keysyms, button codes, and modifier bits.
-;;;
-;;; Written by Bill Chiles.
-;;;
-
-(in-package "EXTENSIONS")
-
-(export '(define-keysym define-mouse-code define-keyboard-modifier
-	  translate-character translate-mouse-character))
-
-
-
-;;;; Keysym to character translation.
-
-;;; Hemlock uses its own keysym to character translation since this is easier
-;;; and more versatile than the CLX design.  Also, using CLX's mechanism is no
-;;; more portable than writing our own translation based on the X11 protocol
-;;; keysym specification.
-;;;
-;;; In the first table, nil indicates a non-event which is pertinent to
-;;; ignoring modifier keys being pressed prior to pressing a key to be
-;;; modified.  In the second table, nil simply indicates that there is no
-;;; special shift translation for the keysym, and that the CLX shifted keysym
-;;; should be looked up as normal (see TRANSLATE-CHARACTER).
-;;;
-;;; This mapping is initialized with DEFINE-KEYSYM in Keytrandefs.Lisp
-;;;
-(defvar *keysym-translations* (make-hash-table))
-(defvar *shifted-keysym-translations* (make-hash-table))
-
-(defun define-keysym (keysym char &optional shifted-char)
-  "Defines a keysym for Hemlock's translation.  If shifted-char is supplied,
-   it is a character to use when the :shift modifier is on for an incoming
-   keysym.  If shifted-char is not supplied, and the :shift modifier is set,
-   then XLIB:KEYCODE->KEYSYM is called with an index of 1 instead of 0.  If
-   a :lock modifier is set, it is treated as a caps-lock.  See
-   DEFINE-KEYBOARD-MODIFIER."
-  (check-type char character)
-  (setf (gethash keysym *keysym-translations*) char)
-  (when shifted-char
-    (check-type shifted-char character)
-    (setf (gethash keysym *shifted-keysym-translations*) shifted-char))
-  t)
-
-
-;;; X modifier bits translation
-;;;
-(defvar *modifier-translations* ())
-
-(defun define-keyboard-modifier (clx-mask modifier-name)
-  "Causes clx-mask to be interpreted as modifier-name which must be one of
-   :control, :meta, :super, :hyper, :shift, or :lock."
-  (let ((map (assoc clx-mask *modifier-translations*)))
-    (if map
-	(rplacd map modifier-name)
-	(push (cons clx-mask modifier-name) *modifier-translations*))))
-
-(define-keyboard-modifier (xlib:make-state-mask :control) :control)
-(define-keyboard-modifier (xlib:make-state-mask :mod-1) :meta)
-(define-keyboard-modifier (xlib:make-state-mask :shift) :shift)
-(define-keyboard-modifier (xlib:make-state-mask :lock) :lock)
-
-
-(defun translate-character (display scan-code bits)
-  "Translates scan-code and modifier bits to a Lisp character.  The scan code
-   is first mapped to a keysym with index 0 for unshifted and index 1 for
-   shifted.  If this keysym does not map to a character, and it is not a
-   modifier key (shift, ctrl, etc.), then an error is signaled.  If the keysym
-   is a modifier key, then nil is returned.  If we do have a character, and the
-   shift bit is off, and the lock bit is on, and the character is alphabetic,
-   then we get a new keysym with index 1, mapping it to a character.  If this
-   does not result in a character, an error is signaled.  If we have a
-   character, and the shift bit is on, then we look for a special shift mapping
-   for the original keysym.  This allows for distinct characters for scan
-   codes that map to the same keysym, shifted or unshifted, (e.g., number pad
-   or arrow keys)."
-  (let ((dummy #\?)
-	shiftp lockp)
-    (dolist (ele *modifier-translations*)
-      (unless (zerop (logand (car ele) bits))
-	(case (cdr ele)
-	  (:shift (setf shiftp t))
-	  (:lock (setf lockp t))
-	  (t (setf dummy (set-char-bit dummy (cdr ele) t))))))
-    (let* ((keysym (xlib:keycode->keysym display scan-code (if shiftp 1 0)))
-	   (temp-char (gethash keysym *keysym-translations*)))
-      (cond ((not temp-char)
-	     (if (<= 65505 keysym 65518) ;modifier keys.
-		 nil
-		 (error "Undefined keysym ~S, describe EXT:DEFINE-KEYSYM."
-			keysym)))
-	    ((and (not shiftp) lockp (alpha-char-p temp-char))
-	     (let* ((keysym (xlib:keycode->keysym display scan-code 1))
-		    (char (gethash keysym *keysym-translations*)))
-	       (unless char
-		 (error "Undefined keysym ~S, describe EXT:DEFINE-KEYSYM."
-			keysym))
-	       (make-char char (logior (char-bits char) (char-bits dummy)))))
-	    (shiftp
-	     (let ((char (gethash keysym *shifted-keysym-translations*)))
-	       (if char
-		   (make-char char (logior (char-bits char) (char-bits dummy)))
-		   (make-char temp-char (logior (char-bits temp-char)
-						(char-bits dummy))))))
-	    (t (make-char temp-char (logior (char-bits temp-char)
-					    (char-bits dummy))))))))
-		   
-		   
-
-;;;; Mouse to character translations.
-		   
-;;; Mouse codes come from the server numbered one through five.  This table is
-;;; indexed by the code to retrieve a list.  The CAR is a cons of the char and
-;;; shifted char associated with a :button-press event.  The CDR is a cons of
-;;; the char and shifted char associated with a :button-release event.  Each
-;;; of these is potentially nil (not a cons at all).
-;;;
-(defvar *mouse-translations* (make-array 6 :initial-element nil))
-;;;
-(defmacro mouse-press-chars (ele) `(car ,ele))
-(defmacro mouse-release-chars (ele) `(cadr ,ele))
-
-(defun define-mouse-code (button char shifted-char event-key)
-  "Causes X button code to be interpreted as char.  Shift and Lock modifiers
-   associated with button map to shifted-char.  For the same button code,
-   event-key may be :button-press or :button-release."
-  (check-type char character)
-  (check-type shifted-char character)
-  (check-type event-key (member :button-press :button-release))
-  (let ((stuff (svref *mouse-translations* button))
-	(trans (cons char shifted-char)))
-    (if stuff
-	(case event-key
-	  (:button-press (setf (mouse-press-chars stuff) trans))
-	  (:button-release (setf (mouse-release-chars stuff) trans)))
-	(case event-key
-	  (:button-press
-	   (setf (svref *mouse-translations* button) (list trans nil)))
-	  (:button-release
-	   (setf (svref *mouse-translations* button) (list nil trans))))))
-  t)
-
-(define-mouse-code 1 #\leftdown #\super-leftdown :button-press)
-(define-mouse-code 1 #\leftup #\super-leftup :button-release)
-
-(define-mouse-code 2 #\middledown #\super-middledown :button-press)
-(define-mouse-code 2 #\middleup #\super-middleup :button-release)
-
-(define-mouse-code 3 #\rightdown #\super-rightdown :button-press)
-(define-mouse-code 3 #\rightup #\super-rightup :button-release)
-
-(defun translate-mouse-character (scan-code bits event-key)
-  "Translates X button code, scan-code, and modifier bits, bits, for event-key
-   (either :button-press or :button-release) to a Lisp character."
-  (let ((temp (svref *mouse-translations* scan-code)))
-    (unless temp (error "Unknown mouse button -- ~S." scan-code))
-    (let ((trans (ecase event-key
-		   (:button-press (mouse-press-chars temp))
-		   (:button-release (mouse-release-chars temp)))))
-      (unless trans (error "Undefined ~S characters for mouse button ~S."
-			   event-key scan-code))
-      (let ((dummy #\?)
-	    shiftp)
-	(dolist (ele *modifier-translations*)
-	  (unless (zerop (logand (car ele) bits))
-	    (let ((bit (cdr ele)))
-	      (if (or (eq bit :shift) (eq bit :lock))
-		  (setf shiftp t)
-		  (setf dummy (set-char-bit dummy bit t))))))
-	(let ((char (if shiftp (cdr trans) (car trans))))
-	  (make-char char (logior (char-bits char) (char-bits dummy))))))))
diff --git a/hemlock/keytrandefs.lisp b/hemlock/keytrandefs.lisp
deleted file mode 100644
index a27a57a137e8d7888d3f02407e42e42559a6c74d..0000000000000000000000000000000000000000
--- a/hemlock/keytrandefs.lisp
+++ /dev/null
@@ -1,186 +0,0 @@
-;;; -*- Log: hemlock.log; Mode: Lisp; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/keytrandefs.lisp,v 1.2 1991/02/08 16:35:48 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file initializes character translation that would otherwise be done
-;;; in Rompsite.Slisp, but there are no good hacks for mapping X11 keysyms
-;;; to CMU Common Lisp character codes.
-;;;
-;;; Written by Bill Chiles.
-;;; 
-
-;;; The IBM RT keyboard has X11 keysyms defined for the following modifier
-;;; keys, but we leave them mapped to nil indicating that they are non-events
-;;; to be ignored:
-;;;    ctrl		65507
-;;;    meta (left)	65513
-;;;    meta (right)	65514
-;;;    shift (left)	65505
-;;;    shift (right)	65506
-;;;    lock		65509
-
-(in-package "HEMLOCK-INTERNALS")
-
-
-;;; Function keys for the RT.
-;;;
-(define-keysym 65470 #\f1 #\s-f1)
-(define-keysym 65471 #\f2 #\s-f2)
-(define-keysym 65472 #\f3 #\s-f3)
-(define-keysym 65473 #\f4 #\s-f4)
-(define-keysym 65474 #\f5 #\s-f5)
-(define-keysym 65475 #\f6 #\s-f6)
-(define-keysym 65476 #\f7 #\s-f7)
-(define-keysym 65477 #\f8 #\s-f8)
-(define-keysym 65478 #\f9 #\s-f9)
-(define-keysym 65479 #\f10 #\s-f10)
-(define-keysym 65480 #\f11 #\s-f11)
-(define-keysym 65481 #\f12 #\s-f12)
-
-;;; Function keys for the Sun (and other keyboards) -- L1-L10 and R1-R15.
-;;;
-(define-keysym 65482 #\f13 #\s-f13)
-(define-keysym 65483 #\f14 #\s-f14)
-(define-keysym 65484 #\f15 #\s-f15)
-(define-keysym 65485 #\f16 #\s-f16)
-(define-keysym 65486 #\f17 #\s-f17)
-(define-keysym 65487 #\f18 #\s-f18)
-(define-keysym 65488 #\f19 #\s-f19)
-(define-keysym 65489 #\f20 #\s-f20)
-(define-keysym 65490 #\f21 #\s-f21)
-(define-keysym 65491 #\f22 #\s-f22)
-(define-keysym 65492 #\f23 #\s-f23)
-(define-keysym 65493 #\f24 #\s-f24)
-(define-keysym 65494 #\f25 #\s-f25)
-(define-keysym 65495 #\f26 #\s-f26)
-(define-keysym 65496 #\f27 #\s-f27)
-(define-keysym 65497 #\f28 #\s-f28)
-(define-keysym 65498 #\f29 #\s-f29)
-(define-keysym 65499 #\f30 #\s-f30)
-(define-keysym 65500 #\f31 #\s-f31)
-(define-keysym 65501 #\f32 #\s-f32)
-(define-keysym 65502 #\f33 #\s-f33)
-(define-keysym 65503 #\f34 #\s-f34)
-(define-keysym 65504 #\f35 #\s-f35)
-
-;;; Upper right key bank.
-;;;
-(define-keysym 65377 #\printscreen #\s-printscreen)
-;; Couldn't type scroll lock.
-(define-keysym 65299 #\pause #\s-pause)
-
-;;; Middle right key bank.
-;;;
-(define-keysym 65379 #\insert #\s-insert)
-(define-keysym 65535 #\delete #\delete)
-(define-keysym 65360 #\home #\s-home)
-(define-keysym 65365 #\pageup #\s-pageup)
-(define-keysym 65367 #\end #\s-end)
-(define-keysym 65366 #\pagedown #\s-pagedown)
-
-;;; Arrows.
-;;;
-(define-keysym 65361 #\leftarrow #\s-leftarrow)
-(define-keysym 65362 #\uparrow #\s-uparrow)
-(define-keysym 65364 #\downarrow #\s-downarrow)
-(define-keysym 65363 #\rightarrow #\s-rightarrow)
-
-;;; Number pad.
-;;;
-(define-keysym 65407 #\numlock #\s-numlock)
-(define-keysym 65421 #\s-return #\s-return)			;num-pad-enter
-(define-keysym 65455 #\s-/ #\s-/)				;num-pad-/
-(define-keysym 65450 #\s-* #\s-*)				;num-pad-*
-(define-keysym 65453 #\s-- #\s--)				;num-pad--
-(define-keysym 65451 #\s-+ #\s-+)				;num-pad-+
-(define-keysym 65456 #\s-0 #\s-0)				;num-pad-0
-(define-keysym 65457 #\s-1 #\s-1)				;num-pad-1
-(define-keysym 65458 #\s-2 #\s-2)				;num-pad-2
-(define-keysym 65459 #\s-3 #\s-3)				;num-pad-3
-(define-keysym 65460 #\s-4 #\s-4)				;num-pad-4
-(define-keysym 65461 #\s-5 #\s-5)				;num-pad-5
-(define-keysym 65462 #\s-6 #\s-6)				;num-pad-6
-(define-keysym 65463 #\s-7 #\s-7)				;num-pad-7
-(define-keysym 65464 #\s-8 #\s-8)				;num-pad-8
-(define-keysym 65465 #\s-9 #\s-9)				;num-pad-9
-(define-keysym 65454 #\s-. #\s-.)				;num-pad-.
-
-;;; "Named" keys.
-;;;
-(define-keysym 65289 #\tab #\tab)
-(define-keysym 65307 #\escape #\escape)				;esc
-(define-keysym 65288 #\backspace #\backspace)
-(define-keysym 65293 #\return #\return)				;enter
-(define-keysym 65512 #\linefeed #\linefeed)			;action
-(define-keysym 32 #\space #\space)
-
-;;; Letters.
-;;;
-(define-keysym 97 #\a) (define-keysym 65 #\A)
-(define-keysym 98 #\b) (define-keysym 66 #\B)
-(define-keysym 99 #\c) (define-keysym 67 #\C)
-(define-keysym 100 #\d) (define-keysym 68 #\D)
-(define-keysym 101 #\e) (define-keysym 69 #\E)
-(define-keysym 102 #\f) (define-keysym 70 #\F)
-(define-keysym 103 #\g) (define-keysym 71 #\G)
-(define-keysym 104 #\h) (define-keysym 72 #\H)
-(define-keysym 105 #\i) (define-keysym 73 #\I)
-(define-keysym 106 #\j) (define-keysym 74 #\J)
-(define-keysym 107 #\k) (define-keysym 75 #\K)
-(define-keysym 108 #\l) (define-keysym 76 #\L)
-(define-keysym 109 #\m) (define-keysym 77 #\M)
-(define-keysym 110 #\n) (define-keysym 78 #\N)
-(define-keysym 111 #\o) (define-keysym 79 #\O)
-(define-keysym 112 #\p) (define-keysym 80 #\P)
-(define-keysym 113 #\q) (define-keysym 81 #\Q)
-(define-keysym 114 #\r) (define-keysym 82 #\R)
-(define-keysym 115 #\s) (define-keysym 83 #\S)
-(define-keysym 116 #\t) (define-keysym 84 #\T)
-(define-keysym 117 #\u) (define-keysym 85 #\U)
-(define-keysym 118 #\v) (define-keysym 86 #\V)
-(define-keysym 119 #\w) (define-keysym 87 #\W)
-(define-keysym 120 #\x) (define-keysym 88 #\X)
-(define-keysym 121 #\y) (define-keysym 89 #\Y)
-(define-keysym 122 #\z) (define-keysym 90 #\Z)
-
-;;; Standard number keys.
-;;;
-(define-keysym 49 #\1) (define-keysym 33 #\!)
-(define-keysym 50 #\2) (define-keysym 64 #\@)
-(define-keysym 51 #\3) (define-keysym 35 #\#)
-(define-keysym 52 #\4) (define-keysym 36 #\$)
-(define-keysym 53 #\5) (define-keysym 37 #\%)
-(define-keysym 54 #\6) (define-keysym 94 #\^)
-(define-keysym 55 #\7) (define-keysym 38 #\&)
-(define-keysym 56 #\8) (define-keysym 42 #\*)
-(define-keysym 57 #\9) (define-keysym 40 #\()
-(define-keysym 48 #\0) (define-keysym 41 #\))
-
-;;; "Standard" symbol keys.
-;;;
-(define-keysym 96 #\`) (define-keysym 126 #\~)
-(define-keysym 45 #\-) (define-keysym 95 #\_)
-(define-keysym 61 #\=) (define-keysym 43 #\+)
-(define-keysym 91 #\[) (define-keysym 123 #\{)
-(define-keysym 93 #\]) (define-keysym 125 #\})
-(define-keysym 92 #\\) (define-keysym 124 #\|)
-(define-keysym 59 #\;) (define-keysym 58 #\:)
-(define-keysym 39 #\') (define-keysym 34 #\")
-(define-keysym 44 #\,) (define-keysym 60 #\<)
-(define-keysym 46 #\.) (define-keysym 62 #\>)
-(define-keysym 47 #\/) (define-keysym 63 #\?)
-
-
-;;; Sun keyboard.
-;;;
-(define-keysym 65387 #\break #\s-break)				;alternate (Sun).
-(define-keysym 65290 #\linefeed #\s-linefeed)
diff --git a/hemlock/killcoms.lisp b/hemlock/killcoms.lisp
deleted file mode 100644
index 5500d049d06ab62fd6a54df6ee6bcdaa8cd44a31..0000000000000000000000000000000000000000
--- a/hemlock/killcoms.lisp
+++ /dev/null
@@ -1,489 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/killcoms.lisp,v 1.1.1.2 1991/02/08 16:35:51 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Killing and unkilling things.
-;;;
-;;; Written by Bill Chiles and Rob MacLachlan.
-;;;
-
-(in-package "HEMLOCK")
-
-(defvar *kill-ring* (make-ring 10) "The Hemlock kill ring.")
-
-
-
-;;;; Active Regions.
-
-(defhvar "Active Regions Enabled"
-  "When set, some commands that affect the current region only work when the
-   region is active."
-  :value t)
-
-(defhvar "Highlight Active Region"
-  "When set, the active region will be highlighted on the display if possible."
-  :value t)
-
-
-(defvar *active-region-p* nil)
-(defvar *active-region-buffer* nil)
-(defvar *ephemerally-active-command-types* (list :ephemerally-active)
-  "This is a list of command types that permit the current region to be active
-   for the immediately following command.")
-
-(proclaim '(inline activate-region deactivate-region region-active-p))
-
-(defun activate-region ()
-  "Make the current region active."
-  (let ((buffer (current-buffer)))
-    (setf *active-region-p* (buffer-signature buffer))
-    (setf *active-region-buffer* buffer)))
-
-(defun deactivate-region ()
-  "Make the current region not active."
-  (setf *active-region-p* nil)
-  (setf *active-region-buffer* nil))
-
-(defun region-active-p ()
-  "Returns t or nil, depending on whether the current region is active."
-  (or (and *active-region-buffer*
-	   (eql *active-region-p* (buffer-signature *active-region-buffer*)))
-      (member (last-command-type) *ephemerally-active-command-types*
-	      :test #'equal)))
-
-(defun check-region-active ()
-  "Signals an error when active regions are enabled and the current region
-   is not active."
-  (when (and (value active-regions-enabled) (not (region-active-p)))
-    (editor-error "The current region is not active.")))
-
-(defun current-region (&optional (error-if-not-active t)
-				 (deactivate-region t))
-  "Returns a region formed by CURRENT-MARK and CURRENT-POINT, optionally
-   signalling an editor error if the current region is not active.  A new
-   region is cons'ed on each call.  This optionally deactivates the region."
-  (when error-if-not-active (check-region-active))
-  (when deactivate-region (deactivate-region))
-  (let ((point (current-point))
-	(mark (current-mark)))
-    (if (mark< mark point) (region mark point) (region point mark))))
-
-
-(defcommand "Activate Region" (p)
-  "Make the current region active.  ^G deactivates the region."
-  "Make the current region active."
-  (declare (ignore p))
-  (activate-region))
-
-
-;;; The following are hook functions for keeping things righteous.
-;;; 
-
-(defun set-buffer-deactivate-region (buffer)
-  (declare (ignore buffer))
-  (deactivate-region))
-;;;
-(add-hook set-buffer-hook 'set-buffer-deactivate-region)
-
-(defun set-window-deactivate-region (window)
-  (unless (or (eq window *echo-area-window*)
-	      (eq (current-window) *echo-area-window*))
-    (deactivate-region)))
-;;;
-(add-hook set-window-hook 'set-window-deactivate-region)
-
-(defun control-g-deactivate-region ()
-  (deactivate-region))
-;;;
-(add-hook abort-hook 'control-g-deactivate-region)
-
-
-
-;;;; Buffer-Mark primitives and commands.
-
-;;; See Command.Lisp for #'hcmd-make-buffer-hook-fun which makes the
-;;; stack for each buffer.
-
-(defun current-mark ()
-  "Returns the top of the current buffer's mark stack."
-  (ring-ref (value buffer-mark-ring) 0))
-
-(defun buffer-mark (buffer)
-  "Returns the top of buffer's mark stack."
-  (ring-ref (variable-value 'buffer-mark-ring :buffer buffer) 0))
-
-(defun pop-buffer-mark ()
-  "Pops the current buffer's mark stack, returning the mark.  If the stack
-   becomes empty, a mark is push on the stack pointing to the buffer's start.
-   This always makes the current region not active."
-  (let* ((ring (value buffer-mark-ring))
-	 (mark (ring-pop ring)))
-    (deactivate-region)
-    (if (zerop (ring-length ring))
-	(ring-push (copy-mark
-		    (buffer-start-mark (current-buffer)) :right-inserting)
-		   ring))
-    mark))
-
-(defun push-buffer-mark (mark &optional (activate-region nil))
-  "Pushes mark into buffer's mark ring, ensuring that the mark is in the right
-   buffer and :right-inserting.  Optionally, the current region is made active.
-   This never deactivates the current region.  Mark is returned."
-  (cond ((eq (line-buffer (mark-line mark)) (current-buffer))
-	 (setf (mark-kind mark) :right-inserting)
-	 (ring-push mark (value buffer-mark-ring)))
-	(t (error "Mark not in the current buffer.")))
-  (when activate-region (activate-region))
-  mark)
-
-(defcommand "Set/Pop Mark" (p)
-  "Set or Pop the mark ring.
-   With no C-U's, pushes point as the mark, activating the current region.
-   With one C-U's, pops the mark into point, de-activating the current region.
-   With two C-U's, pops the mark and throws it away, de-activating the current
-   region."
-  "Set or Pop the mark ring."
-  (cond ((not p)
-	 (push-buffer-mark (copy-mark (current-point)) t)
-	 (when (interactive)
-	   (message "Mark pushed.")))
-	((= p (value universal-argument-default))
-	 (pop-and-goto-mark-command nil))
-	((= p (expt (value universal-argument-default) 2))
-	 (delete-mark (pop-buffer-mark)))
-	(t (editor-error))))
-
-(defcommand "Pop and Goto Mark" (p)
-  "Pop mark into point, de-activating the current region."
-  "Pop mark into point."
-  (declare (ignore p))
-  (let ((mark (pop-buffer-mark)))
-    (move-mark (current-point) mark)
-    (delete-mark mark)))
-
-(defcommand "Pop Mark" (p)
-  "Pop mark and throw it away, de-activating the current region."
-  "Pop mark and throw it away."
-  (declare (ignore p))
-  (delete-mark (pop-buffer-mark)))
-
-(defcommand "Exchange Point and Mark" (p)
-  "Swap the positions of the point and the mark."
-  "Swap the positions of the point and the mark."
-  (declare (ignore p))
-  (let ((point (current-point))
-	(mark (current-mark)))
-    (with-mark ((temp point))
-      (move-mark point mark)
-      (move-mark mark temp))))
-
-(defcommand "Mark Whole Buffer"  (p)
-  "Set the region around the whole buffer, activating the region.
-   Pushes the point on the mark ring first, so two pops get it back.
-   With prefix argument, put mark at beginning and point at end."
-  "Put point at beginning and part at end of current buffer.
-  If P, do it the other way around."
-  (let* ((region (buffer-region (current-buffer)))
-	 (start (region-start region))
-	 (end (region-end region))
-	 (point (current-point)))
-    (push-buffer-mark (copy-mark point))
-    (cond (p (push-buffer-mark (copy-mark start) t)
-	     (move-mark point end))
-	  (t (push-buffer-mark (copy-mark end) t)
-	     (move-mark point start)))))
-
-
-
-;;;; KILL-REGION and KILL-CHARACTERS primitives.
-
-(proclaim '(special *delete-char-region*))
-
-;;; KILL-REGION first checks for any characters that may need to be added to
-;;; the region.  If there are some, we possibly push a region onto *kill-ring*,
-;;; and we use the top of *kill-ring*.  If there are no characters to deal
-;;; with, then we make sure the ring isn't empty; if it is, just push our
-;;; region.  If there is some region in *kill-ring*, then see if the last
-;;; command type was a region kill.  Otherwise, just push the region.
-;;;
-(defun kill-region (region current-type)
-  "Kills the region saving it in *kill-ring*.  Current-type is either
-   :kill-forward or :kill-backward.  When LAST-COMMAND-TYPE is one of these,
-   region is appended or prepended, respectively, to the top of *kill-ring*.
-   The killing of the region is undo-able with \"Undo\".  LAST-COMMAND-TYPE
-   is set to current-type.  This interacts with KILL-CHARACTERS."
-  (let ((last-type (last-command-type))
-	(insert-mark (copy-mark (region-start region) :left-inserting)))
-    (cond ((or (eq last-type :char-kill-forward)
-	       (eq last-type :char-kill-backward))
-	   (when *delete-char-region*
-	     (ring-push *delete-char-region* *kill-ring*)
-	     (setf *delete-char-region* nil))
-	   (setf region (kill-region-top-of-ring region current-type)))
-	  ((zerop (ring-length *kill-ring*))
-	   (setf region (delete-and-save-region region))
-	   (ring-push region *kill-ring*))
-	  ((or (eq last-type :kill-forward) (eq last-type :kill-backward))
-	   (setf region (kill-region-top-of-ring region current-type)))
-	  (t
-	   (setf region (delete-and-save-region region))
-	   (ring-push region *kill-ring*)))
-    (make-region-undo :insert "kill" (copy-region region) insert-mark)
-    (setf (last-command-type) current-type)))
-
-(defun kill-region-top-of-ring (region current-type)
-  (let ((r (ring-ref *kill-ring* 0)))
-    (ninsert-region (if (eq current-type :kill-forward)
-			(region-end r)
-			(region-start r))
-		    (delete-and-save-region region))
-    r))
-
-(defhvar "Character Deletion Threshold"
-  "When this many characters are deleted contiguously via KILL-CHARACTERS,
-   they are saved on the kill ring -- for example, \"Delete Next Character\",
-   \"Delete Previous Character\", or \"Delete Previous Character Expanding
-   Tabs\"."
-  :value 5)
-
-(defvar *delete-char-region* nil)
-(defvar *delete-char-count* 0)
-
-;;; KILL-CHARACTERS makes sure there are count characters with CHARACTER-OFFSET.
-;;; If the last command type was a region kill, we just use the top region
-;;; in *kill-ring* by making KILL-CHAR-REGION believe *delete-char-count* is
-;;; over the threshold.  We don't call KILL-REGION in this case to save making
-;;; undo's -- no good reason.  If we were just called, then increment our
-;;; global counter.  Otherwise, make an empty region to keep KILL-CHAR-REGION
-;;; happy and increment the global counter.
-;;;
-(defun kill-characters (mark count)
-  "Kills count characters after mark if positive, before mark if negative.
-   If called multiple times contiguously such that the sum of the count values
-   equals \"Character Deletion Threshold\", then the characters are saved on
-   *kill-ring*.  This relies on setting LAST-COMMAND-TYPE, and it interacts
-   with KILL-REGION.  If there are not count characters in the appropriate
-   direction, no characters are deleted, and nil is returned; otherwise, mark
-   is returned."
-  (if (zerop count)
-      mark
-      (with-mark ((temp mark :left-inserting))
-	(if (character-offset temp count)
-	    (let ((current-type (if (plusp count)
-				    :char-kill-forward
-				    :char-kill-backward))
-		  (last-type (last-command-type))
-		  (del-region (if (mark< temp mark)
-				  (region temp mark)
-				  (region mark temp))))
-	      (cond ((or (eq last-type :kill-forward)
-			 (eq last-type :kill-backward))
-		     (setf *delete-char-count*
-			   (value character-deletion-threshold))
-		     (setf *delete-char-region* nil))
-		    ((or (eq last-type :char-kill-backward)
-			 (eq last-type :char-kill-forward))
-		     (incf *delete-char-count* (abs count)))
-		    (t
-		     (setf *delete-char-region* (make-empty-region))
-		     (setf *delete-char-count* (abs count))))
-	      (kill-char-region del-region current-type)
-	      mark)
-	    nil))))
-
-(defun kill-char-region (region current-type)
-  (let ((deleted-region (delete-and-save-region region)))
-    (cond ((< *delete-char-count* (value character-deletion-threshold))
-	   (ninsert-region (if (eq current-type :char-kill-forward)
-			       (region-end *delete-char-region*)
-			       (region-start *delete-char-region*))
-			   deleted-region)
-	   (setf (last-command-type) current-type))
-	  (t
-	   (when *delete-char-region*
-	     (ring-push *delete-char-region* *kill-ring*)
-	     (setf *delete-char-region* nil))
-	   (let ((r (ring-ref *kill-ring* 0)))
-	     (ninsert-region (if (eq current-type :char-kill-forward)
-				 (region-end r)
-				 (region-start r))
-			     deleted-region))
-	   (setf (last-command-type)
-		 (if (eq current-type :char-kill-forward)
-		     :kill-forward
-		     :kill-backward))))))
-
-
-
-;;;; Commands.
-
-(defcommand "Kill Region" (p)
-  "Kill the region, pushing on the kill ring.
-   If the region is not active nor the last command a yank, signal an error."
-  "Kill the region, pushing on the kill ring."
-  (declare (ignore p))
-  (kill-region (current-region)
-		(if (mark< (current-mark) (current-point))
-		    :kill-backward
-		    :kill-forward)))
-
-(defcommand "Save Region" (p)
-  "Insert the region into the kill ring.
-   If the region is not active nor the last command a yank, signal an error."
-  "Insert the region into the kill ring."
-  (declare (ignore p))
-  (ring-push (copy-region (current-region)) *kill-ring*))
-
-(defcommand "Kill Next Word" (p)
-  "Kill a word at the point.
-  With prefix argument delete that many words.  The text killed is
-  appended to the text currently at the top of the kill ring if it was
-  next to the text being killed."
-  "Kill p words at the point"
-  (let ((point (current-point))
-	(num (or p 1)))
-    (with-mark ((mark point :temporary))
-      (if (word-offset mark num)
-	  (if (minusp num)
-	      (kill-region (region mark point) :kill-backward)
-	      (kill-region (region point mark) :kill-forward))
-	  (editor-error)))))
-
-(defcommand "Kill Previous Word" (p)
-  "Kill a word before the point.
-  With prefix argument kill that many words before the point.  The text
-  being killed is appended to the text currently at the top of the kill
-  ring if it was next to the text being killed."
-  "Kill p words before the point"
-  (kill-next-word-command (- (or p 1))))
-
-
-(defcommand "Kill Line" (p)
-  "Kills the characters to the end of the current line.
-  If the line is empty then the line is deleted.  With prefix argument,
-  deletes that many lines past the point (or before if the prefix is negative)."
-  "Kills p lines after the point."
-  (let* ((point (current-point))
-	 (line (mark-line point)))
-    (with-mark ((mark point))
-      (cond 
-       (p
-	(when (and (/= (mark-charpos point) 0) (minusp p))
-	  (incf p))
-	(unless (line-offset mark p 0)
-	  (if (plusp p)
-	      (kill-region (region point (buffer-end mark)) :kill-forward)
-	      (kill-region (region (buffer-start mark) point) :kill-backward))
-	  (editor-error))
-	(if (plusp p)
-	    (kill-region (region point mark) :kill-forward)
-	    (kill-region (region mark point) :kill-backward)))
-       (t
-	(cond ((not (blank-after-p mark))
-	       (line-end mark))
-	      ((line-next line)
-	       (line-start mark (line-next line)))
-	      ((not (end-line-p mark))
-	       (line-end mark))
-	      (t 
-	       (editor-error)))
-	(kill-region (region point mark) :kill-forward))))))
-
-(defcommand "Backward Kill Line" (p)
-  "Kill from the point to the beginning of the line.
-  If at the beginning of the line, kill the newline and any trailing space
-  on the previous line.  With prefix argument, call \"Kill Line\" with
-  the argument negated."
-  "Kills p lines before the point."
-  (if p
-      (kill-line-command (- p))
-      (with-mark ((m (current-point)))
-	(cond ((zerop (mark-charpos m))
-	       (mark-before m)
-	       (unless (reverse-find-attribute m :space #'zerop)
-		 (buffer-start m)))
-	       (t
-		(line-start m)))
-	(kill-region (region m (current-point)) :kill-backward))))
-
-
-(defcommand "Delete Blank Lines" (p)
-  "On a blank line, deletes all surrounding blank lines, leaving just
-  one. On an isolated blank line, deletes that one. On a non-blank line,
-  deletes all blank following that one."
-  "Kill blank lines around the point"
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (with-mark ((beg-mark point :left-inserting)
-		(end-mark point :right-inserting))
-      ;; handle case when the current line is blank
-      (when (blank-line-p (mark-line point))
-	;; back up to last non-whitespace character
-	(reverse-find-attribute beg-mark :whitespace #'zerop)
-	(when (previous-character beg-mark)
-	  ;; that is, we didn't back up to the beginning of the buffer
-	  (unless (same-line-p beg-mark end-mark)
-	    (line-offset beg-mark 1 0)))
-	;; if isolated, zap the line else zap the blank ones above
-	(cond ((same-line-p beg-mark end-mark)
-	       (line-offset end-mark 1 0))
-	      (t
-	       (line-start end-mark)))
-	(delete-region (region beg-mark end-mark)))
-      ;; always delete all blank lines after the current line
-      (move-mark beg-mark point)
-      (when (line-offset beg-mark 1 0)
-	(move-mark end-mark beg-mark)
-	(find-attribute end-mark :whitespace #'zerop)
-	(when (next-character end-mark)
-	  ;; that is, we didn't go all the way to the end of the buffer
-	  (line-start end-mark))
-	(delete-region (region beg-mark end-mark))))))
-
-
-(defcommand "Un-Kill" (p)
-  "Inserts the top item in the kill-ring at the point.
-  The mark is left mark before the insertion and the point after.  With prefix
-  argument inserts the prefix'th most recent item."
-  "Inserts the item with index p in the kill ring at the point, leaving 
-  the mark before and the point after."
-  (let ((idx (1- (or p 1))))
-    (cond ((> (ring-length *kill-ring*) idx -1)
-	   (let* ((region (ring-ref *kill-ring* idx))
-		  (point (current-point))
-		  (mark (copy-mark point)))
-	     (push-buffer-mark mark)
-	     (insert-region point region)
-	     (make-region-undo :delete "Un-Kill"
-			       (region (copy-mark mark) (copy-mark point))))
-	   (setf (last-command-type) :unkill))
-	  (t (editor-error)))))
-;;;
-(push :unkill *ephemerally-active-command-types*)
-
-(defcommand "Rotate Kill Ring" (p)
-  "Replace un-killed text with previously killed text.
-  Kills the current region, rotates the kill ring, and inserts the new top
-  item.  With prefix argument rotates the kill ring that many times."
-  "This function will not behave in any reasonable fashion when
-  called as a lisp function."
-  (let ((point (current-point))
-	(mark (current-mark)))
-    (cond ((or (not (eq (last-command-type) :unkill))
-	       (zerop (ring-length *kill-ring*)))
-	   (editor-error))
-	  (t (delete-region (region mark point))
-	     (rotate-ring *kill-ring* (or p 1))
-	     (insert-region point (ring-ref *kill-ring* 0))
-	     (make-region-undo :delete "Un-Kill"
-			       (region (copy-mark mark) (copy-mark point)))
-	     (setf (last-command-type) :unkill)))))
diff --git a/hemlock/line.lisp b/hemlock/line.lisp
deleted file mode 100644
index 520faf88884aa3daa8269ddae2f1ff8c2e55555d..0000000000000000000000000000000000000000
--- a/hemlock/line.lisp
+++ /dev/null
@@ -1,160 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/line.lisp,v 1.1.1.2 1991/02/08 16:35:54 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains definitions for the Line structure, and some 
-;;; functions and macros to manipulate them.
-;;;
-;;;    This stuff was allowed to become implementation dependant because
-;;; you make thousands of lines, so speed is real important.  In some
-;;; implementations (the Perq for example) it may be desirable to 
-;;; not actually cons the strings in the line objects until someone
-;;; touches them, and just keep a pointer in the line to where the file 
-;;; is mapped in memory.  Such lines are called "buffered".  This stuff
-;;; links up with the file-reading stuff and the line-image building stuff.
-;;;
-(in-package 'hemlock-internals)
-(export '(line linep line-previous line-next line-plist line-signature))
-
-(setf (documentation 'linep 'function)
-  "Returns true if its argument is a Hemlock line object, Nil otherwise.")
-(setf (documentation 'line-previous 'function)
-  "Return the Hemlock line that precedes this one, or Nil if there is no
-  previous line.")
-(setf (documentation 'line-next 'function)
-  "Return the Hemlock line that follows this one, or Nil if there is no
-  next line.")
-(setf (documentation 'line-plist 'function)
-  "Return a line's property list.  This may be manipulated with Setf and Getf.")
-
-
-;;;; The line object:
-
-(proclaim '(inline %make-line))
-(defstruct (line (:print-function %print-hline)
-		 (:constructor %make-line)
-		 (:predicate linep))
-  "A Hemlock line object.  See Hemlock design document for details."
-  ;;
-  ;; Something that represents the contents of the line.  This is
-  ;; guaranteed to change (as compared by EQL) whenver the contents of the
-  ;; line changes, but might at arbitarary other times.  There are
-  ;; currently about three different cases:
-  ;;
-  ;; Normal:
-  ;;    A simple string holding the contents of the line.
-  ;;
-  ;; A cached line:
-  ;;    The line is eq to Open-Line, and the actual contents are in the
-  ;;    line cache.  The %Chars may be either the original contents or a
-  ;;    negative fixnum.
-  ;;
-  ;; A buffered line:
-  ;;    The line hasn't been touched since it was read from a file, and the
-  ;;    actual contents are in some system I/O area.  This is indicated by
-  ;;    the Line-Buffered-P slot being true.  In buffered lines on the RT,
-  ;;    the %Chars slot contains the system-area-pointer to the beginning
-  ;;    of the characters.
-  (%chars "")
-  ;;
-  ;; Pointers to the next and previous lines in the doubly linked list of
-  ;; line structures.
-  previous
-  next
-  ;;
-  ;; A list of all the permanent marks pointing into this line.
-  (marks ())
-  ;;
-  ;; The buffer to which this line belongs, or a *disembodied-buffer-count*
-  ;; if the line is not in any buffer.
-  %buffer
-  ;;
-  ;; A non-negative integer (fixnum) that represents the ordering of lines
-  ;; within continguous range of lines (a buffer or disembuffered region).
-  ;; The number of the Line-Next is guaranteed to be strictly greater than
-  ;; our number, and the Line-Previous is guaranteed to be strictly less.
-  (number 0)
-  ;;
-  ;; The line property list, used by user code to annotate the text.
-  plist
-  ;;
-  ;; A slot that indicates whether this line is a buffered line, and if so
-  ;; contains information about how the text is stored.  On the RT, this is
-  ;; the length of the text pointed to by the Line-%Chars.
-  #+Buffered-Lines
-  (buffered-p ()))
-
-;;; Make Line-Chars the same as Line-%Chars on implementations without
-;;; buffered lines.
-;;;
-#-Buffered-Lines
-(defmacro line-chars (x)
-  `(line-%chars ,x))
-
-
-;;; If buffered lines are supported, then we create the string
-;;; representation for the characters when someone uses Line-Chars.  People
-;;; who are prepared to handle buffered lines or who just want a signature
-;;; for the contents can use Line-%chars directly.
-;;;
-#+Buffered-Lines
-(defmacro line-chars (line)
-  `(the simple-string (if (line-buffered-p ,line)
-			  (read-buffered-line ,line)
-			  (line-%chars ,line))))
-;;;
-#+Buffered-Lines
-(defsetf line-chars %set-line-chars)
-;;;
-#+Buffered-Lines
-(defmacro %set-line-chars (line chars)
-  `(setf (line-%chars ,line) ,chars))
-
-
-;;; Line-Signature  --  Public
-;;;
-;;;    We can just return the Line-%Chars.
-;;;
-(proclaim '(inline line-signature))
-(defun line-signature (line)
-  "This function returns an object which serves as a signature for a line's
-  contents.  It is guaranteed that any modification of text on the line will
-  result in the signature changing so that it is not EQL to any previous value.
-  Note that the signature may change even when the text hasn't been modified, but
-  this probably won't happen often."
-  (line-%chars line))
-
-
-;;; Return a copy of Line in buffer Buffer with the same chars.  We use
-;;; this macro where we want to copy a line because it takes care of
-;;; the case where the line is buffered.
-;;;
-(defmacro %copy-line (line &key previous number %buffer)
-  `(make-line :chars (line-%chars ,line)
-	      :previous ,previous
-	      :number ,number
-	      :%buffer ,%buffer
-	      #+Buffered-Lines :buffered-p
-	      #+Buffered-Lines (line-buffered-p ,line)))
-
-;;; Hide the fact that the slot isn't really called CHARS.
-;;;
-(defmacro make-line (&rest keys)
-  `(%make-line ,@(substitute :%chars :chars keys)))
-
-(defmacro line-length* (line)
-  "Returns the number of characters on the line, but it's a macro!"
-  `(cond ((eq ,line open-line)
-	  (+ left-open-pos (- line-cache-length right-open-pos)))
-	 ((line-buffered-p ,line))
-	 (t
-	  (length (the simple-string (line-%chars ,line))))))
diff --git a/hemlock/linimage.lisp b/hemlock/linimage.lisp
deleted file mode 100644
index cbb9e0b3817cb92a8864c4c56d0eee51ad17e5e6..0000000000000000000000000000000000000000
--- a/hemlock/linimage.lisp
+++ /dev/null
@@ -1,521 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/linimage.lisp,v 1.1.1.4 1991/02/08 16:35:57 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Rob MacLachlan
-;;;
-;;; This file contains functions related to building line images.
-;;;
-(in-package 'hemlock-internals)
-
-;;;    The code in here is factored out in this way because it is more
-;;; or less implementation dependant.  The reason this code is 
-;;; implementation dependant is not because it is not written in 
-;;; Common Lisp per se, but because it uses this thing called 
-;;; %SP-Find-Character-With-Attribute to find any characters that
-;;; are to be displayed on the line which do not print as themselves.
-;;; This permits us to have an arbitrary string or even string-valued
-;;; function to as the representation for such a "Funny" character
-;;; with minimal penalty for the normal case.  This function can be written 
-;;; in lisp, and is included commented-out below, but if this function
-;;; is not real fast then redisplay performance will suffer.
-;;;
-;;;    Theres also code in here that special-cases "Buffered" lines,
-;;; which is not exactly Common Lisp, but if you aren't on a perq,
-;;; you won't have to worry about it.
-;;;
-;(defun %sp-find-character-with-attribute (string start end table mask)
-;  (declare (type (simple-array (mod 256) char-code-max) table))
-;  (declare (simple-string string))
-;  (declare (fixnum start end))
-;  "%SP-Find-Character-With-Attribute  String, Start, End, Table, Mask
-;  The codes of the characters of String from Start to End are used as indices
-;  into the Table, which is a U-Vector of 8-bit bytes. When the number picked
-;  up from the table bitwise ANDed with Mask is non-zero, the current
-;  index into the String is returned. The corresponds to SCANC on the Vax."
-;  (do ((index start (1+ index)))
-;      ((= index end) nil)
-;    (declare (fixnum index))
-;    (if (/= (logand (aref table (char-code (elt string index))) mask) 0)
-;	(return index))))
-;
-;(defun %sp-reverse-find-character-with-attribute (string start end table
-;							  mask)
-;  (declare (type (simple-array (mod 256) char-code-max) table))
-;  (declare (simple-string string))
-;  (declare (fixnum start end))
-;  "Like %SP-Find-Character-With-Attribute, only sdrawkcaB."
-;  (do ((index (1- end) (1- index)))
-;      ((< index start) nil)
-;    (declare (fixnum index))
-;    (if (/= (logand (aref table (char-code (elt string index))) mask) 0)
-;	(return index))))
-
-(defconstant winning-char #b01 "Bit for a char that prints normally")
-(defconstant losing-char #b10 "Bit for char with funny representation.")
-(defvar *losing-character-mask*
-  (make-array char-code-limit :element-type '(mod 256)
-	      :initial-element winning-char)
-  "This is a character set used by redisplay to find funny chars.")
-(defvar *print-representation-vector* nil
-  "Redisplay's handle on the :print-representation attribute")
-
-;;;  Do a find-character-with-attribute on the *losing-character-mask*.
-(defmacro %fcwa (str start end mask)
-  `(%sp-find-character-with-attribute
-    ,str ,start ,end *losing-character-mask* ,mask))
-
-;;; Get the print-representation of a character.
-(defmacro get-rep (ch)
-  `(svref *print-representation-vector* (char-code ,ch)))
-
-
-
-(proclaim '(special *character-attributes*))
-
-;;; %init-line-image  --  Internal
-;;;
-;;;    Set up the print-representations for funny chars.  We make the
-;;; attribute vector by hand and do funny stuff so that chars > 127
-;;; will have a losing print-representation, so redisplay will not
-;;; die if you visit a binary file or do something stupid like that.
-;;;
-(defun %init-line-image ()
-  (defattribute "Print Representation"
-    "The value of this attribute determines how a character is displayed
-    on the screen.  If the value is a string this string is literally
-    displayed.  If it is a function, then that function is called with
-    the current X position to get the string to display.")
-  (setq *print-representation-vector* (make-array char-code-limit))
-  (setf (attribute-descriptor-vector
-	 (gethash :print-representation *character-attributes*))
-	*print-representation-vector*)
-  (do ((code syntax-char-code-limit (1+ code))
-       (str (make-string 4) (make-string 4)))
-      ((= code char-code-limit))
-    (setf (aref *losing-character-mask* code) losing-char)
-    (setf (aref *print-representation-vector* code) str)
-    (setf (schar str 0) #\<)
-    (setf (schar str 1) (char-upcase (digit-char (ash code -4) 16)))
-    (setf (schar str 2) (char-upcase (digit-char (logand code #x+F) 16)))
-    (setf (schar str 3) #\>))
-
-  (add-hook ed::character-attribute-hook
-	    #'redis-set-char-attribute-hook-fun)
-  (do ((i (1- (char-code #\space)) (1- i)) str)
-      ((minusp i))
-    (setq str (make-string 2))
-    (setf (elt (the simple-string str) 0) #\^)
-    (setf (elt (the simple-string str) 1)
-	  (code-char (+ i (char-code #\@))))
-    (setf (character-attribute :print-representation (code-char i)) str))
-  (setf (character-attribute :print-representation (code-char #o177)) "^?")
-  (setf (character-attribute :print-representation #\tab)
-	#'redis-tab-display-fun))
-
-;;; redis-set-char-attribute-hook-fun
-;;;
-;;;    Keep track of which characters have funny representations.
-;;;
-(defun redis-set-char-attribute-hook-fun (attribute char new-value)
-  (when (eq attribute :print-representation)
-    (cond
-     ((simple-string-p new-value)
-      (if (and (= (length (the simple-string new-value)) 1)
-	       (char= char (elt (the simple-string new-value) 0)))
-	  (setf (aref *losing-character-mask* (char-code char)) winning-char)
-	  (setf (aref *losing-character-mask* (char-code char))
-		losing-char)))
-     ((functionp new-value)
-      (setf (aref *losing-character-mask* (char-code char)) losing-char))
-     (t (error "Bad print representation: ~S" new-value)))))
-
-;;; redis-tab-display-fun
-;;;
-;;;    This function is initially the :print-representation for tab.
-;;;
-(defun redis-tab-display-fun (xpos)
-  (svref '#("        "
-	    "       "
-	    "      "
-	    "     "
-	    "    "
-	    "   "
-	    "  "
-	    " ")
-	 (logand xpos 7)))
-
-
-;;;; The actual line image computing functions.
-;;;;
-
-(eval-when (compile eval)
-;;; display-some-chars  --  internal
-;;;
-;;;    Put some characters into a window.  Characters from src-start 
-;;; to src-end in src are are put in the window's dis-line's.  Lines
-;;; are wrapped as necessary.  dst is the dis-line-chars of the dis-line 
-;;; currently being written.  Dis-lines is the window's vector of dis-lines.
-;;; dis-line is the dis-line currently being written.  Line is the index
-;;; into dis-lines of the current dis-line.  dst-start is the index to
-;;; start writing chars at.  Height and width are the height and width of the 
-;;; window.  src-start, dst, dst-start, line and dis-line are updated.
-;;; Done-P indicates whether there are more characters after this sequence.
-;;;
-(defmacro display-some-chars (src src-start src-end dst dst-start width done-p)
-  `(let ((dst-end (+ ,dst-start (- ,src-end ,src-start))))
-     (declare (fixnum dst-end))
-     (cond
-      ((>= dst-end ,width)
-       (cond 
-	((and ,done-p (= dst-end ,width))
-	 (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end)
-	 (setq ,dst-start dst-end  ,src-start ,src-end))
-	(t
-	 (let ((1-width (1- ,width)))
-	   (%sp-byte-blt ,src ,src-start ,dst ,dst-start 1-width)
-	   (setf (elt (the simple-string ,dst) 1-width) *line-wrap-char*)
-	   (setq ,src-start (+ ,src-start (- 1-width ,dst-start)))
-	   (setq ,dst-start nil)))))
-      (t (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end)
-	 (setq ,dst-start dst-end  ,src-start ,src-end)))))
-
-;;; These macros are given as args to display-losing-chars to get the
-;;; print representation of whatever is in the data vector.
-(defmacro string-get-rep (string index)
-  `(get-rep (schar ,string ,index)))
-
-(defmacro u-vec-get-rep (u-vec index)
-  `(svref *print-representation-vector*
-	  (system:sap-ref-8 ,u-vec ,index)))
-
-;;; display-losing-chars  --  Internal
-;;;
-;;;    This macro is called by the compute-line-image functions to
-;;; display a group of losing characters.
-;;;
-(defmacro display-losing-chars (line-chars index end dest xpos width
-					   string underhang access-fun
-					   &optional (done-p `(= ,index ,end)))
-  `(do ((last (or (%fcwa ,line-chars ,index ,end winning-char) ,end))
-	(len 0)
-	(zero 0)
-	str)
-       (())
-     (declare (fixnum last len zero))
-     (setq str (,access-fun ,line-chars ,index))
-     (unless (simple-string-p str) (setq str (funcall str ,xpos)))
-     (setq len (strlen str)  zero 0)
-     (incf ,index)
-     (display-some-chars str zero len ,dest ,xpos ,width ,done-p)
-     (cond ((not ,xpos)
-	    ;; We wrapped in the middle of a losing char.	       
-	    (setq ,underhang zero  ,string str)
-	    (return nil))
-	   ((= ,index last)
-	    ;; No more losing chars in this bunch.
-	    (return nil)))))
-
-(defmacro update-and-punt (dis-line length string underhang end)
-  `(progn (setf (dis-line-length ,dis-line) ,length)
-	  (return (values ,string ,underhang
-			  (setf (dis-line-end ,dis-line) ,end)))))
-
-); eval-when (compile eval)
-
-;;; compute-normal-line-image  --  Internal
-;;;
-;;;    Compute the screen representation of Line starting at Start 
-;;; putting it in Dis-Line beginning at Xpos.  Width is the width of the 
-;;; window we are displaying in.  If the line will wrap then we display 
-;;; as many chars as we can then put in *line-wrap-char*.  The values 
-;;; returned are described in Compute-Line-Image, which tail-recursively 
-;;; returns them.  The length slot in Dis-Line is updated.
-;;;
-;;; We use the *losing-character-mask* to break the line to be displayed
-;;; up into chunks of characters with normal print representation and
-;;; those with funny representations.
-;;;
-(defun compute-normal-line-image (line start dis-line xpos width)
-  (declare (fixnum start width) (type (or fixnum null) xpos))
-  (do* ((index start)
-	(line-chars (line-%chars line))
-	(end (strlen line-chars))
-	(dest (dis-line-chars dis-line))
-	(losing 0)
-	underhang string)
-       (())
-    (declare (fixnum index end)
-	     (type (or fixnum null) losing)
-	     (simple-string line-chars dest))
-    (cond
-     (underhang
-      (update-and-punt dis-line width string underhang index))
-     ((null xpos)
-      (update-and-punt dis-line width nil 0 index))
-     ((= index end)
-      (update-and-punt dis-line xpos nil nil index)))
-    (setq losing (%fcwa line-chars index end losing-char))
-    (when (null losing)
-      (display-some-chars line-chars index end dest xpos width t)
-      (if (or xpos (= index end))
-	  (update-and-punt dis-line xpos nil nil index)
-	  (update-and-punt dis-line width nil 0 index)))
-    (display-some-chars line-chars index losing dest xpos width nil)
-    (cond
-     ;; Did we wrap?
-     ((null xpos)
-      (update-and-punt dis-line width nil 0 index))
-     ;; Are we about to cause the line to wrap? If so, wrap before
-     ;; it's too late.
-     ((= xpos width)
-      (setf (char dest (1- width)) *line-wrap-char*)
-      (update-and-punt dis-line width nil 0 index))
-     (t
-      (display-losing-chars line-chars index end dest xpos width string
-			    underhang string-get-rep)))))
-
-;;; compute-buffered-line-image  --  Internal
-;;;
-;;;    Compute the line image for a "Buffered" line, that is, one whose 
-;;; chars have not been consed yet.
-
-(defun compute-buffered-line-image (line start dis-line xpos width)
-  (declare (fixnum start width) (type (or fixnum null) xpos))
-  (do* ((index start)
-	(line-chars (line-%chars line))
-	(end (line-buffered-p line))
-	(dest (dis-line-chars dis-line))
-	(losing 0)
-	underhang string)
-       (())
-    (declare (fixnum index end)
-	     (type (or fixnum null) losing)
-	     (simple-string dest))
-    (cond
-     (underhang
-      (update-and-punt dis-line width string underhang index))
-     ((null xpos)
-      (update-and-punt dis-line width nil 0 index))
-     ((= index end)
-      (update-and-punt dis-line xpos nil nil index)))
-    (setq losing (%fcwa line-chars index end losing-char))
-    (when (null losing)
-      (display-some-chars line-chars index end dest xpos width t)
-      (if (or xpos (= index end))
-	  (update-and-punt dis-line xpos nil nil index)
-	  (update-and-punt dis-line width nil 0 index)))
-    (display-some-chars line-chars index losing dest xpos width nil)
-    (cond
-     ;; Did we wrap?
-     ((null xpos)
-      (update-and-punt dis-line width nil 0 index))
-     ;; Are we about to cause the line to wrap? If so, wrap before
-     ;; it's too late.
-     ((= xpos width)
-      (setf (char dest (1- width)) *line-wrap-char*)
-      (update-and-punt dis-line width nil 0 index))
-     (t
-      (display-losing-chars line-chars index end dest xpos width string
-			    underhang u-vec-get-rep)))))
-
-;;; compute-cached-line-image  --  Internal
-;;;
-;;;    Like compute-normal-line-image, only works on the cached line.
-;;;
-(defun compute-cached-line-image (index dis-line xpos width)
-  (declare (fixnum index width) (type (or fixnum null) xpos))
-  (prog ((gap (- right-open-pos left-open-pos))
-	 (dest (dis-line-chars dis-line))
-	 (done-p (= right-open-pos line-cache-length))
-	 (losing 0)
-	 string underhang)
-    (declare (fixnum gap) (simple-string dest)
-	     (type (or fixnum null) losing))
-   LEFT-LOOP
-    (cond
-     (underhang
-      (update-and-punt dis-line width string underhang index))
-     ((null xpos)
-      (update-and-punt dis-line width nil 0 index))
-     ((>= index left-open-pos)
-      (go RIGHT-START)))
-    (setq losing (%fcwa open-chars index left-open-pos losing-char))
-    (cond
-     (losing
-      (display-some-chars open-chars index losing dest xpos width nil)
-      ;; If we we didn't wrap then display some losers...
-      (if xpos
-	  (display-losing-chars open-chars index left-open-pos dest xpos
-				width string underhang string-get-rep
-				(and done-p (= index left-open-pos)))
-	  (update-and-punt dis-line width nil 0 index)))
-     (t
-      (display-some-chars open-chars index left-open-pos dest xpos width done-p)))
-    (go LEFT-LOOP)
-
-   RIGHT-START
-    (setq index (+ index gap))
-   RIGHT-LOOP
-    (cond
-     (underhang
-      (update-and-punt dis-line width string underhang (- index gap)))
-     ((null xpos)
-      (update-and-punt dis-line width nil 0 (- index gap)))
-     ((= index line-cache-length)
-      (update-and-punt dis-line xpos nil nil (- index gap))))
-    (setq losing (%fcwa open-chars index line-cache-length losing-char))
-    (cond
-     (losing
-      (display-some-chars open-chars index losing dest xpos width nil)
-      (cond
-       ;; Did we wrap?
-       ((null xpos)
-	(update-and-punt dis-line width nil 0 (- index gap)))
-       (t
-	(display-losing-chars open-chars index line-cache-length dest xpos
-			      width string underhang string-get-rep))))
-     (t
-      (display-some-chars open-chars index line-cache-length dest xpos width t)))
-    (go RIGHT-LOOP))) 
-
-(defun make-some-font-changes ()
-  (do ((res nil (make-font-change res))
-       (i 42 (1- i)))
-      ((zerop i) res)))
-
-(defvar *free-font-changes* (make-some-font-changes)
-  "Font-Change structures that nobody's using at the moment.")
-
-(defmacro alloc-font-change (x font mark)
-  `(progn
-    (unless *free-font-changes*
-      (setq *free-font-changes* (make-some-font-changes)))
-    (let ((new-fc *free-font-changes*))
-      (setq *free-font-changes* (font-change-next new-fc))
-      (setf (font-change-x new-fc) ,x
-	    (font-change-font new-fc) ,font
-	    (font-change-next new-fc) nil
-	    (font-change-mark new-fc) ,mark)
-      new-fc)))
-		     
-;;;
-;;; compute-line-image  --  Internal
-;;;
-;;;    This function builds a full line image from some characters in
-;;; a line and from some characters which may be left over from the previous
-;;; line.
-;;;
-;;; Parameters:
-;;;    String - This is the string which contains the characters left over
-;;; from the previous line.  This is NIL if there are none.
-;;;    Underhang - Characters from here to the end of String are put at the
-;;; beginning of the line image.
-;;;    Line - This is the line to display characters from.
-;;;    Offset - This is the index of the first character to display in Line.
-;;;    Dis-Line - This is the dis-line to put the line-image in.  The only
-;;; slots affected are the chars and the length.
-;;;    Width - This is the width of the field to display in.
-;;;
-;;; Three values are returned:
-;;;    1) The new overhang string, if none this is NIL.
-;;;    2) The new underhang, if this is NIL then the entire line was
-;;; displayed.  If the entire line was not displayed, but there was no
-;;; underhang, then this is 0.
-;;;    3) The index in line after the last character displayed.
-;;;
-(defun compute-line-image (string underhang line offset dis-line width)
-  ;;
-  ;; Release any old font-changes.
-  (let ((changes (dis-line-font-changes dis-line)))
-    (when changes
-      (do ((prev changes current)
-	   (current (font-change-next changes)
-		    (font-change-next current)))
-	  ((null current)
-	   (setf (dis-line-font-changes dis-line) nil)
-	   (shiftf (font-change-next prev) *free-font-changes* changes))
-	(setf (font-change-mark current) nil))))
-  ;;
-  ;; If the line has any Font-Marks, add Font-Changes for them.
-  (let ((marks (line-marks line)))
-    (when (dolist (m marks nil)
-	    (when (fast-font-mark-p m) (return t)))
-      (let ((prev nil))
-	;;
-	;; Find the last Font-Mark with charpos less than Offset.  If there is
-	;; such a Font-Mark, then there is a font-change to this font at X = 0.
-	(let ((max -1)
-	      (max-mark nil))
-	  (dolist (m marks)
-	    (when (fast-font-mark-p m)
-	      (let ((charpos (mark-charpos m)))
-		(when (and (< charpos offset) (> charpos max))
-		  (setq max charpos  max-mark m)))))
-	  (when max-mark
-	    (setq prev (alloc-font-change 0 (font-mark-font max-mark) max-mark))
-	    (setf (dis-line-font-changes dis-line) prev)))
-	;;
-	;; Repeatedly scan through marks, adding a font-change for the
-	;; smallest Font-Mark with a charpos greater than Bound, until
-	;; we find no such mark.
-	(do ((bound (1- offset) min)
-	     (min most-positive-fixnum most-positive-fixnum)
-	     (min-mark nil nil))
-	    (())
-	  (dolist (m marks)
-	    (when (fast-font-mark-p m)
-	      (let ((charpos (mark-charpos m)))
-		(when (and (> charpos bound) (< charpos min))
-		  (setq min charpos  min-mark m)))))
-	  (unless min-mark (return nil))
-	  (let ((len (if (eq line open-line)
-			 (cached-real-line-length line 10000 offset min)
-			 (real-line-length line 10000 offset min))))
-	    (when (< len width)
-	      (let ((new (alloc-font-change
-			  (+ len
-			     (if string
-				 (- (length (the simple-string string)) underhang)
-				 0))
-			  (font-mark-font min-mark)
-			  min-mark)))
-		(if prev
-		    (setf (font-change-next prev) new)
-		    (setf (dis-line-font-changes dis-line) new))
-		(setq prev new))))))))
-  ;;
-  ;; Recompute the line image.
-  (cond
-   (string
-    (let ((len (strlen string))
-	  (chars (dis-line-chars dis-line))
-	  (xpos 0))
-      (declare (type (or fixnum null) xpos) (simple-string chars))
-      (display-some-chars string underhang len chars xpos width nil)
-      (cond
-       ((null xpos)
-	(values string underhang offset))	   
-       ((eq line open-line)
-	(compute-cached-line-image offset dis-line xpos width))
-       #+Buffered-Lines
-       ((line-buffered-p line)
-	(compute-buffered-line-image line offset dis-line xpos width))
-       (t
- 	(compute-normal-line-image line offset dis-line xpos width)))))
-   ((eq line open-line)
-    (compute-cached-line-image offset dis-line 0 width))
-   #+Buffered-Lines
-   ((line-buffered-p line)
-    (compute-buffered-line-image line offset dis-line 0 width))
-   (t
-    (compute-normal-line-image line offset dis-line 0 width))))
diff --git a/hemlock/lisp-lib.lisp b/hemlock/lisp-lib.lisp
deleted file mode 100644
index 1e888dbcd1edd7725438d9ffbd8668e78ba90d67..0000000000000000000000000000000000000000
--- a/hemlock/lisp-lib.lisp
+++ /dev/null
@@ -1,183 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lisp-lib.lisp,v 1.2 1991/02/08 16:36:02 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains code to peruse the CMU Common Lisp library of hacks.
-;;;
-;;; Written by Blaine Burks.
-;;;
-
-(in-package "HEMLOCK")
-
-
-(defmode "Lisp-Lib" :major-p t)
-
-;;; The library should be in *lisp-library-directory*
-
-(defvar *lisp-library-directory*  "/afs/cs.cmu.edu/project/clisp/library/")
-
-(defvar *selected-library-buffer* nil)
-
-
-;;;; Commands.
-
-(defcommand "Lisp Library" (p)
-  "Goto buffer in 'Lisp-Lib' mode, creating one if necessary."
-  "Goto buffer in 'Lisp-Lib' mode, creating one if necessary."
-  (declare (ignore p))
-  (when (not (and *selected-library-buffer*
-		  (member *selected-library-buffer* *buffer-list*)))
-    (when (getstring "Lisp Library" *buffer-names*)
-      (editor-error "There is already a buffer named \"Lisp Library\"."))
-    (setf *selected-library-buffer*
-	  (make-buffer "Lisp Library" :modes '("Lisp-Lib")))
-    (message "Groveling library ...")
-    (let ((lib-directory (directory *lisp-library-directory*))
-	  (lib-entries ()))
-      (with-output-to-mark (s (buffer-point *selected-library-buffer*))
-	(dolist (lib-spec lib-directory)
-	  (let* ((path-parts (pathname-directory lib-spec))
-		 (last (svref path-parts (1- (length path-parts))))
-		 (raw-pathname (merge-pathnames last lib-spec)))
-	    (when (and (directoryp lib-spec)
-		       (probe-file (merge-pathnames
-				    (make-pathname :type "catalog")
-				    raw-pathname)))
-	      (push raw-pathname lib-entries)
-	      (format s "~d~%" last)))))
-      (defhvar "Library Entries"
-	"Holds a list of library entries for the 'Lisp Library' buffer"
-	:buffer *selected-library-buffer*
-	:value (coerce (nreverse lib-entries) 'simple-vector))))
-  (setf (buffer-writable *selected-library-buffer*) nil)
-  (setf (buffer-modified *selected-library-buffer*) nil)
-  (change-to-buffer *selected-library-buffer*)
-  (buffer-start (current-point)))
-
-(defcommand "Describe Pointer Library Entry" (p)
-  "Finds the file that describes the lisp library entry indicated by the
-   pointer."
-  "Finds the file that describes the lisp library entry indicated by the
-   pointer."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (describe-library-entry (array-element-from-pointer-pos
-			   (value library-entries) "No entry on current line")))
-
-(defcommand "Describe Library Entry" (p)
-  "Find the file that describes the lisp library entry on the current line."
-  "Find the file that describes the lisp library entry on the current line."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (describe-library-entry (array-element-from-mark (current-point)
-			   (value library-entries) "No entry on current line")))
-
-(defun describe-library-entry (pathname)
-  (let ((lisp-buf (current-buffer))
-	(buffer (view-file-command
-		 nil
-		 (merge-pathnames (make-pathname :type "catalog") pathname))))
-    (push #'(lambda (buffer)
-	      (declare (ignore buffer))
-	      (setf lisp-buf nil))
-	  (buffer-delete-hook lisp-buf))
-    (setf (variable-value 'view-return-function :buffer buffer)
-	  #'(lambda () (if lisp-buf
-			   (change-to-buffer lisp-buf)
-			   (lisp-library-command nil))))))
-
-(defcommand "Load Library Entry" (p)
-  "Loads the current library entry into the current slave."
-  "Loads the current library entry into the current slave."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (string-eval (format nil "(load ~S)"
-		       (namestring (library-entry-load-file nil)))))
-
-(defcommand "Load Pointer Library Entry" (p)
-  "Loads the library entry indicated by the mouse into the current slave."
-  "Loads the library entry indicated by the mouse into the current slave."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (string-eval (format nil "(load ~S)"
-		       (namestring (library-entry-load-file t)))))
-
-(defcommand "Editor Load Library Entry" (p)
-  "Loads the current library entry into the editor Lisp."
-  "Loads the current library entry into the editor Lisp."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (in-lisp (load (library-entry-load-file nil))))
-
-(defcommand "Editor Load Pointer Library Entry" (p)
-  "Loads the library entry indicated by the mouse into the editor Lisp."
-  "Loads the library entry indicated by the mouse into the editor Lisp."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (in-lisp (load (library-entry-load-file t))))
-
-;;; LIBRARY-ENTRY-LOAD-FILE uses the mouse's position or the current point,
-;;; depending on pointerp, to return a file that will load that library entry.
-;;;
-(defun library-entry-load-file (pointerp)
-  (let* ((lib-entries (value library-entries))
-	 (error-msg "No entry on current-line")
-	 (base-name (if pointerp
-			(array-element-from-pointer-pos lib-entries error-msg)
-			(array-element-from-mark (current-point) lib-entries
-						 error-msg)))
-	 (parts (pathname-directory base-name))
-	 (load-name (concatenate 'simple-string
-				 "load-" (svref parts (1- (length parts)))))
-	 (load-pathname (merge-pathnames load-name base-name))
-	 (file-to-load
-	  (or (probe-file (merge-pathnames (make-pathname :type "fasl")
-					   load-pathname))
-	      (probe-file (merge-pathnames (make-pathname :type "lisp")
-					   load-pathname))
-	      (probe-file (merge-pathnames (make-pathname :type "fasl")
-					   base-name))
-	      (probe-file (merge-pathnames (make-pathname :type "lisp")
-					   base-name)))))
-    (unless file-to-load (editor-error "You'll have to load it yourself."))
-    file-to-load))
-
-(defcommand "Exit Lisp Library" (p)
-  "Exit Lisp-Lib Mode, deleting the buffer when possible."
-  "Exit Lisp-Lib Mode, deleting the buffer when possible."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
-    (editor-error "Not in a Lisp Library buffer."))
-  (delete-buffer-if-possible (getstring "Lisp Library" *buffer-names*)))
-
-(defcommand "Lisp Library Help" (p)
-  "Show this help."
-  "Show this help."
-  (declare (ignore p))
-  (describe-mode-command nil "Lisp-Lib"))
-
-
-;;;; Utilities
-
-(defun array-element-from-pointer-pos (vector &optional
-					      (error-msg "Invalid line."))
-  (multiple-value-bind (x y window) (last-key-event-cursorpos)
-    (declare (ignore x window))
-    (when (>= y (length vector))
-      (editor-error error-msg))
-    (svref vector y)))
diff --git a/hemlock/lispbuf.lisp b/hemlock/lispbuf.lisp
deleted file mode 100644
index c79d9734fb589b71453693d2e2487ed0fb4e9b6e..0000000000000000000000000000000000000000
--- a/hemlock/lispbuf.lisp
+++ /dev/null
@@ -1,768 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispbuf.lisp,v 1.1.1.4 1991/02/08 16:36:05 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Stuff to do a little lisp hacking in the editor's Lisp environment.
-;;;
-
-(in-package "HEMLOCK")
-
-
-(defmacro in-lisp (&body body)
-  "Evaluates body inside HANDLE-LISP-ERRORS.  *package* is bound to the package
-   named by \"Current Package\" if it is non-nil."
-  (let ((name (gensym)) (package (gensym)))
-    `(handle-lisp-errors
-      (let* ((,name (value current-package))
-	     (,package (and ,name (find-package ,name))))
-	(progv (if ,package '(*package*)) (if ,package (list ,package))
-	  ,@body)))))
-
-
-(define-file-option "Package" (buffer value)
-  (defhvar "Current Package"
-    "The package used for evaluation of Lisp in this buffer."
-    :buffer buffer
-    :value
-    (let* ((eof (list nil))
-	   (thing (read-from-string value nil eof)))
-      (when (eq thing eof) (error "Bad package file option value."))
-      (cond
-       ((stringp thing)
-	thing)
-       ((symbolp thing)
-	(symbol-name thing))
-       ((characterp thing)
-	(string thing))
-       (t
-	(message
-	 "Ignoring \"package\" file option -- cannot convert to a string."))))))
-
-
-;;;; Eval Mode Interaction.
-
-(proclaim '(special * ** *** - + ++ +++ / // /// *prompt*))
-
-(defun setup-eval-mode (buffer)
-  (let ((point (buffer-point buffer)))
-    (setf (buffer-minor-mode buffer "Eval") t)
-    (setf (buffer-minor-mode buffer "Editor") t)
-    (setf (buffer-major-mode buffer) "Lisp")
-    (buffer-end point)
-    (defhvar "Current Package"
-      "This variable holds the name of the package currently used for Lisp
-       evaluation and compilation.  If it is Nil, the value of *Package* is used
-       instead."
-      :value nil
-      :buffer buffer)
-    (unless (hemlock-bound-p 'buffer-input-mark :buffer buffer)
-      (defhvar "Buffer Input Mark"
-	"Mark used for Eval Mode input."
-	:buffer buffer
-	:value (copy-mark point :right-inserting))
-      (defhvar "Eval Output Stream"
-	"Output stream used for Eval Mode output in this buffer."
-	:buffer buffer
-	:value (make-hemlock-output-stream point))
-      (defhvar "Interactive History"
-	"A ring of the regions input to an interactive mode (Eval or Typescript)."
-	:buffer buffer
-	:value (make-ring (value interactive-history-length)))
-      (defhvar "Interactive Pointer"
-	"Pointer into \"Interactive History\"."
-	:buffer buffer
-	:value 0)
-      (defhvar "Searching Interactive Pointer"
-	"Pointer into \"Interactive History\"."
-	:buffer buffer
-	:value 0))
-    (let ((*standard-output*
-	   (variable-value 'eval-output-stream :buffer buffer)))
-      (fresh-line)
-      (princ (if (functionp *prompt*)
-		 (funcall *prompt*)
-		 *prompt*)))
-    (move-mark (variable-value 'buffer-input-mark :buffer buffer) point)))
-
-(defmode "Eval" :major-p nil :setup-function #'setup-eval-mode)
-
-(defun eval-mode-lisp-mode-hook (buffer on)
-  "Turn on Lisp mode when we go into Eval Mode."
-  (when on
-    (setf (buffer-major-mode buffer) "Lisp")))
-;;;
-(add-hook eval-mode-hook 'eval-mode-lisp-mode-hook)
-
-(defhvar "Editor Definition Info"
-  "When this is non-nil, the editor Lisp is used to determine definition
-   editing information; otherwise, the slave Lisp is used."
-  :value t
-  :mode "Eval")
-
-
-(defvar *selected-eval-buffer* nil)
-
-(defcommand "Select Eval Buffer" (p)
-  "Goto buffer in \"Eval\" mode, creating one if necessary."
-  "Goto buffer in \"Eval\" mode, creating one if necessary."
-  (declare (ignore p))
-  (unless *selected-eval-buffer*
-    (when (getstring "Eval" *buffer-names*)
-      (editor-error "There is already a buffer named \"Eval\"!"))
-    (setf *selected-eval-buffer*
-	  (make-buffer "Eval"
-		       :delete-hook
-		       (list #'(lambda (buf)
-				 (declare (ignore buf))
-				 (setf *selected-eval-buffer* nil)))))
-    (setf (buffer-minor-mode *selected-eval-buffer* "Eval") t))
-  (change-to-buffer *selected-eval-buffer*))
-
-
-(defvar lispbuf-eof '(nil))
-
-(defhvar "Unwedge Interactive Input Confirm"
-  "When set (the default), trying to confirm interactive input when the
-   point is not after the input mark causes Hemlock to ask the user if he
-   needs to be unwedged.  When not set, an editor error is signaled
-   informing the user that the point is before the input mark."
-  :value t)
-
-(defun unwedge-eval-buffer ()
-  (abort-eval-input-command nil))
-
-(defhvar "Unwedge Interactive Input Fun"
-  "Function to call when input is confirmed, but the point is not past the
-   input mark."
-  :value #'unwedge-eval-buffer
-  :mode "Eval")
-
-(defhvar "Unwedge Interactive Input String"
-  "String to add to \"Point not past input mark.  \" explaining what will
-   happen if the the user chooses to be unwedged."
-  :value "Prompt again at the end of the buffer? "
-  :mode "Eval")
-
-(defcommand "Confirm Eval Input" (p)
-  "Evaluate Eval Mode input between point and last prompt."
-  "Evaluate Eval Mode input between point and last prompt."
-  (declare (ignore p))
-  (let ((input-region (get-interactive-input)))
-    (when input-region
-      (let* ((output (value eval-output-stream))
-	     (*standard-output* output)
-	     (*error-output* output)
-	     (*trace-output* output))
-	(fresh-line)
-	(in-lisp
-	 ;; Copy the region to keep the output and input streams from interacting
-	 ;; since input-region is made of permanent marks into the buffer.
-	 (with-input-from-region (stream (copy-region input-region))
-	   (loop
-	     (let ((form (read stream nil lispbuf-eof)))
-	       (when (eq form lispbuf-eof)
-		 ;; Move the buffer's input mark to the end of the buffer.
-		 (move-mark (region-start input-region)
-			    (region-end input-region))
-		 (return))
-	       (setq +++ ++ ++ + + - - form)
-	       (let ((this-eval (multiple-value-list (eval form))))
-		 (fresh-line)
-		 (dolist (x this-eval) (prin1 x) (terpri))
-		 (princ (if (functionp *prompt*)
-			    (funcall *prompt*)
-			    *prompt*))
-		 (setq /// // // / / this-eval)
-		 (setq *** ** ** * * (car this-eval)))))))))))
-
-(defcommand "Abort Eval Input" (p)
-  "Move to the end of the buffer and prompt."
-  "Move to the end of the buffer and prompt."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (buffer-end point)
-    (insert-character point #\newline)
-    (insert-string point "Aborted.")
-    (insert-character point #\newline)
-    (insert-string point
-		   (if (functionp *prompt*)
-		       (funcall *prompt*)
-		       *prompt*))
-    (move-mark (value buffer-input-mark) point)))
-
-
-
-;;;; General interactive commands used in eval and typescript buffers.
-
-(defun get-interactive-input ()
-  "Tries to return a region.  When the point is not past the input mark, and
-   the user has \"Unwedge Interactive Input Confirm\" set, the buffer is
-   optionally fixed up, and nil is returned.  Otherwise, an editor error is
-   signalled.  When a region is returned, the start is the current buffer's
-   input mark, and the end is the current point moved to the end of the buffer."
-  (let ((point (current-point))
-	(mark (value buffer-input-mark)))
-    (cond
-     ((mark>= point mark)
-      (buffer-end point)
-      (let* ((input-region (region mark point))
-	     (string (region-to-string input-region))
-	     (ring (value interactive-history)))
-	(when (and (or (zerop (ring-length ring))
-		       (string/= string (region-to-string (ring-ref ring 0))))
-		   (> (length string) (value minimum-interactive-input-length)))
-	  (ring-push (copy-region input-region) ring))
-	input-region))
-     ((value unwedge-interactive-input-confirm)
-      (beep)
-      (when (prompt-for-y-or-n
-	     :prompt (concatenate 'simple-string
-				  "Point not past input mark.  "
-				  (value unwedge-interactive-input-string))
-	     :must-exist t :default t :default-string "yes")
-	(funcall (value unwedge-interactive-input-fun))
-	(message "Unwedged."))
-      nil)
-     (t
-      (editor-error "Point not past input mark.")))))
-
-(defhvar "Interactive History Length"
-  "This is the length used for the history ring in interactive buffers.
-   It must be set before turning on the mode."
-  :value 10)
-
-(defhvar "Minimum Interactive Input Length"
-  "When the number of characters in an interactive buffer exceeds this value,
-   it is pushed onto the interactive history, otherwise it is lost forever."
-  :value 2)
-
-
-(defvar *previous-input-search-string* "ignore")
-
-(defvar *previous-input-search-pattern*
-  ;; Give it a bogus string since you can't give it the empty string.
-  (new-search-pattern :string-insensitive :forward "ignore"))
-
-(defun get-previous-input-search-pattern (string)
-  (if (string= *previous-input-search-string* string)
-      *previous-input-search-pattern*
-      (new-search-pattern :string-insensitive :forward 
-			  (setf *previous-input-search-string* string)
-			  *previous-input-search-pattern*)))
-
-(defcommand "Search Previous Interactive Input" (p)
-  "Search backward through the interactive history using the current input as
-   a search string.  Consecutive invocations repeat the previous search."
-  "Search backward through the interactive history using the current input as
-   a search string.  Consecutive invocations repeat the previous search."
-  (declare (ignore p))
-  (let* ((mark (value buffer-input-mark))
-	 (ring (value interactive-history))
-	 (point (current-point))
-	 (just-invoked (eq (last-command-type) :searching-interactive-input)))
-    (when (mark<= point mark)
-      (editor-error "Point not past input mark."))
-    (when (zerop (ring-length ring))
-      (editor-error "No previous input in this buffer."))
-    (unless just-invoked
-      (get-previous-input-search-pattern (region-to-string (region mark point))))
-    (let ((found-it (find-previous-input ring just-invoked)))
-      (unless found-it 
-	(editor-error "Couldn't find ~a." *previous-input-search-string*))
-      (delete-region (region mark point))
-      (insert-region point (ring-ref ring found-it))
-      (setf (value searching-interactive-pointer) found-it))
-  (setf (last-command-type) :searching-interactive-input)))
-
-(defun find-previous-input (ring againp)
-  (let ((ring-length (ring-length ring))
-	(base (if againp
-		  (+ (value searching-interactive-pointer) 1)
-		  0)))
-      (loop
-	(when (= base ring-length)
-	  (if againp
-	      (setf base 0)
-	      (return nil)))
-	(with-mark ((m (region-start (ring-ref ring base))))
-	  (when (find-pattern m *previous-input-search-pattern*)
-	    (return base)))
-	(incf base))))
-
-(defcommand "Previous Interactive Input" (p)
-  "Insert the previous input in an interactive mode (Eval or Typescript).
-   If repeated, keep rotating the history.  With prefix argument, rotate
-   that many times."
-  "Pop the *interactive-history* at the point."
-  (let* ((point (current-point))
-	 (mark (value buffer-input-mark))
-	 (ring (value interactive-history))
-	 (length (ring-length ring))
-	 (p (or p 1)))
-    (when (or (mark< point mark) (zerop length)) (editor-error))
-    (cond
-     ((eq (last-command-type) :interactive-history)
-      (let ((base (mod (+ (value interactive-pointer) p) length)))
-	(delete-region (region mark point))
-	(insert-region point (ring-ref ring base))
-	(setf (value interactive-pointer) base)))
-     (t
-      (let ((base (mod (if (minusp p) p (1- p)) length))
-	    (region (delete-and-save-region (region mark point))))
-	(insert-region point (ring-ref ring base))
-	(when (mark/= (region-start region) (region-end region))
-	  (ring-push region ring)
-	  (incf base))
-	(setf (value interactive-pointer) base)))))
-  (setf (last-command-type) :interactive-history))
-
-(defcommand "Next Interactive Input" (p)
-  "Rotate the interactive history backwards.  The region is left around the
-   inserted text.  With prefix argument, rotate that many times."
-  "Call previous-interactive-input-command with negated arg."
-  (previous-interactive-input-command (- (or p 1))))
-
-(defcommand "Kill Interactive Input" (p)
-  "Kill any input to an interactive mode (Eval or Typescript)."
-  "Kill any input to an interactive mode (Eval or Typescript)."
-  (declare (ignore p))
-  (let ((point (buffer-point (current-buffer)))
-	(mark (value buffer-input-mark)))
-    (when (mark< point mark) (editor-error))
-    (kill-region (region mark point) :kill-backward)))
-
-(defcommand "Interactive Beginning of Line" (p)
-  "If on line with current prompt, go to after it, otherwise do what
-  \"Beginning of Line\" always does."
-  "Go to after prompt when on prompt line."
-  (let ((mark (value buffer-input-mark))
-	(point (current-point)))
-    (if (and (same-line-p point mark) (or (not p) (= p 1)))
-	(move-mark point mark)
-	(beginning-of-line-command p))))
-
-(defcommand "Reenter Interactive Input" (p)
-  "Copies the form to the left of point to be after the interactive buffer's
-   input mark.  When the current region is active, it is copied instead."
-  "Copies the form to the left of point to be after the interactive buffer's
-   input mark.  When the current region is active, it is copied instead."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'buffer-input-mark)
-    (editor-error "Not in an interactive buffer."))
-  (let ((point (current-point)))
-    (let ((region (if (region-active-p)
-		      ;; Copy this, so moving point doesn't affect the region.
-		      (copy-region (current-region))
-		      (with-mark ((start point)
-				  (end point))
-			(pre-command-parse-check start)
-			(unless (form-offset start -1)
-			  (editor-error "Not after complete form."))
-			(region (copy-mark start) (copy-mark end))))))
-      (buffer-end point)
-      (push-buffer-mark (copy-mark point))
-      (insert-region point region)
-      (setf (last-command-type) :ephemerally-active))))
-
-
-
-;;; Other stuff.
-
-(defmode "Editor")
-
-(defcommand "Editor Mode" (p)
-  "Turn on \"Editor\" mode in the current buffer.  If it is already on, turn it
-  off.  When in editor mode, most lisp compilation and evaluation commands
-  manipulate the editor process instead of the current eval server."
-  "Toggle \"Editor\" mode in the current buffer."
-  (declare (ignore p))
-  (setf (buffer-minor-mode (current-buffer) "Editor")
-	(not (buffer-minor-mode (current-buffer) "Editor"))))
-
-(define-file-option "Editor" (buffer value)
-  (declare (ignore value))
-  (setf (buffer-minor-mode buffer "Editor") t))
-
-(defhvar "Editor Definition Info"
-  "When this is non-nil, the editor Lisp is used to determine definition
-   editing information; otherwise, the slave Lisp is used."
-  :value t
-  :mode "Editor")
-
-(defcommand "Editor Compile Defun" (p)
-  "Compiles the current or next top-level form in the editor Lisp.
-   First the form is evaluated, then the result of this evaluation
-   is passed to compile.  If the current region is active, this
-   compiles the region."
-  "Evaluates the current or next top-level form in the editor Lisp."
-  (declare (ignore p))
-  (if (region-active-p)
-      (editor-compile-region (current-region))
-      (editor-compile-region (defun-region (current-point)) t)))
-
-(defcommand "Editor Compile Region" (p)
-  "Compiles lisp forms between the point and the mark in the editor Lisp."
-  "Compiles lisp forms between the point and the mark in the editor Lisp."
-  (declare (ignore p))
-  (editor-compile-region (current-region)))
-
-(defun defun-region (mark)
-  "This returns a region around the current or next defun with respect to mark.
-   Mark is not used to form the region.  If there is no appropriate top level
-   form, this signals an editor-error.  This calls PRE-COMMAND-PARSE-CHECK."
-  (with-mark ((start mark)
-	      (end mark))
-    (pre-command-parse-check start)
-    (cond ((not (mark-top-level-form start end))
-	   (editor-error "No current or next top level form."))
-	  (t (region start end)))))
-
-(defun editor-compile-region (region &optional quiet)
-  (unless quiet (message "Compiling region ..."))
-  (in-lisp
-   (with-input-from-region (stream region)
-     (with-pop-up-display (*error-output* :height 19)
-       (c::compile-from-stream stream
-			       :source-info
-			       (buffer-pathname (current-buffer)))))))
-
-
-(defcommand "Editor Evaluate Defun" (p)
-  "Evaluates the current or next top-level form in the editor Lisp.
-   If the current region is active, this evaluates the region."
-  "Evaluates the current or next top-level form in the editor Lisp."
-  (declare (ignore p))
-  (if (region-active-p)
-      (editor-evaluate-region-command nil)
-      (with-input-from-region (stream (defun-region (current-point)))
-	(clear-echo-area)
-	(in-lisp
-	 (message "Editor Evaluation returned ~S"
-		  (eval (read stream)))))))
-
-(defcommand "Editor Evaluate Region" (p)
-  "Evaluates lisp forms between the point and the mark in the editor Lisp."
-  "Evaluates lisp forms between the point and the mark in the editor Lisp."
-  (declare (ignore p))
-  (with-input-from-region (stream (current-region))
-    (clear-echo-area)
-    (write-string "Evaluating region in the editor ..." *echo-area-stream*)
-    (finish-output *echo-area-stream*)
-    (in-lisp
-     (do ((object (read stream nil lispbuf-eof) 
-		  (read stream nil lispbuf-eof)))
-	 ((eq object lispbuf-eof))
-       (eval object)))
-    (message "Evaluation complete.")))
-           
-(defcommand "Editor Re-evaluate Defvar" (p)
-  "Evaluate the current or next top-level form if it is a DEFVAR.  Treat the
-   form as if the variable is not bound.  This occurs in the editor Lisp."
-  "Evaluate the current or next top-level form if it is a DEFVAR.  Treat the
-   form as if the variable is not bound.  This occurs in the editor Lisp."
-  (declare (ignore p))
-  (with-input-from-region (stream (defun-region (current-point)))
-    (clear-echo-area)
-    (in-lisp
-     (let ((form (read stream)))
-       (unless (eq (car form) 'defvar) (editor-error "Not a DEFVAR."))
-       (makunbound (cadr form))
-       (message "Evaluation returned ~S" (eval form))))))
-
-(defcommand "Editor Macroexpand Expression" (p)
-  "Show the macroexpansion of the current expression in the null environment.
-   With an argument, use MACROEXPAND instead of MACROEXPAND-1."
-  "Show the macroexpansion of the current expression in the null environment.
-   With an argument, use MACROEXPAND instead of MACROEXPAND-1."
-  (let ((point (buffer-point (current-buffer))))
-    (with-mark ((start point))
-      (pre-command-parse-check start)
-      (with-mark ((end start))
-        (unless (form-offset end 1) (editor-error))
-	(in-lisp
-	 (with-pop-up-display (rts)
-	   (write-string (with-input-from-region (s (region start end))
-			   (prin1-to-string (funcall (if p
-							 'macroexpand
-							 'macroexpand-1)
-						     (read s))))
-			 rts)))))))
-
-(defcommand "Editor Evaluate Expression" (p)
-  "Prompt for an expression to evaluate in the editor Lisp."
-  "Prompt for an expression to evaluate in the editor Lisp."
-  (declare (ignore p))
-  (in-lisp
-   (multiple-value-call #'message "=> ~@{~#[~;~S~:;~S, ~]~}"
-     (eval (prompt-for-expression
-	    :prompt "Editor Eval: "
-	    :help "Expression to evaluate")))))
-
-(defcommand "Editor Evaluate Buffer" (p)
-  "Evaluates the text in the current buffer in the editor Lisp."
-  "Evaluates the text in the current buffer redirecting *Standard-Output* to
-   the echo area.  This occurs in the editor Lisp.  The prefix argument is
-   ignored."
-  (declare (ignore p))
-  (clear-echo-area)
-  (write-string "Evaluating buffer in the editor ..." *echo-area-stream*)
-  (finish-output *echo-area-stream*)
-  (with-input-from-region (stream (buffer-region (current-buffer)))
-    (let ((*standard-output* *echo-area-stream*))
-      (in-lisp
-       (do ((object (read stream nil lispbuf-eof) 
-		    (read stream nil lispbuf-eof)))
-	   ((eq object lispbuf-eof))
-	 (eval object))))
-    (message "Evaluation complete.")))
-
-
-
-;;; With-Output-To-Window  --  Internal
-;;;
-;;;
-(defmacro with-output-to-window ((stream name) &body forms)
-  "With-Output-To-Window (Stream Name) {Form}*
-  Bind Stream to a stream that writes into the buffer named Name a la
-  With-Output-To-Mark.  The buffer is created if it does not exist already
-  and a window is created to display the buffer if it is not displayed.
-  For the duration of the evaluation this window is made the current window."
-  (let ((nam (gensym)) (buffer (gensym)) (point (gensym)) 
-	(window (gensym)) (old-window (gensym)))
-    `(let* ((,nam ,name)
-	    (,buffer (or (getstring ,nam *buffer-names*) (make-buffer ,nam)))
-	    (,point (buffer-end (buffer-point ,buffer)))
-	    (,window (or (car (buffer-windows ,buffer)) (make-window ,point)))
-	    (,old-window (current-window)))
-       (unwind-protect
-	 (progn (setf (current-window) ,window)
-		(buffer-end ,point)
-		(with-output-to-mark (,stream ,point) ,@forms))
-	 (setf (current-window) ,old-window)))))
-
-(defcommand "Editor Compile File" (p)
-  "Prompts for file to compile in the editor Lisp.  Does not compare source
-   and binary write dates.  Does not check any buffer for that file for
-   whether the buffer needs to be saved."
-  "Prompts for file to compile."
-  (declare (ignore p))
-  (let ((pn (prompt-for-file :default
-			     (buffer-default-pathname (current-buffer))
-			     :prompt "File to compile: ")))
-    (with-output-to-window (*error-output* "Compiler Warnings")
-      (in-lisp (compile-file (namestring pn) :error-file nil)))))
-
-(defcommand "Editor Compile Buffer File" (p)
-  "Compile the file in the current buffer in the editor Lisp if its associated
-   binary file (of type .fasl) is older than the source or doesn't exist.  When
-   the binary file is up to date, the user is asked if the source should be
-   compiled anyway.  When the prefix argument is supplied, compile the file
-   without checking the binary file.  When \"Compile Buffer File Confirm\" is
-   set, this command will ask for confirmation when it otherwise would not."
-  "Compile the file in the current buffer in the editor Lisp if the fasl file
-   isn't up to date.  When p, always do it."
-  (let* ((buf (current-buffer))
-	 (pn (buffer-pathname buf)))
-    (unless pn (editor-error "Buffer has no associated pathname."))
-    (cond ((buffer-modified buf)
-	   (when (or (not (value compile-buffer-file-confirm))
-		     (prompt-for-y-or-n
-		      :default t :default-string "Y"
-		      :prompt (list "Save and compile file ~A? "
-				    (namestring pn))))
-	     (write-buffer-file buf pn)
-	     (with-output-to-window (*error-output* "Compiler Warnings")
-	       (in-lisp (compile-file (namestring pn) :error-file nil)))))
-	  ((older-or-non-existent-fasl-p pn p)
-	   (when (or (not (value compile-buffer-file-confirm))
-		     (prompt-for-y-or-n
-		      :default t :default-string "Y"
-		      :prompt (list "Compile file ~A? " (namestring pn))))
-	     (with-output-to-window (*error-output* "Compiler Warnings")
-	       (in-lisp (compile-file (namestring pn) :error-file nil)))))
-	  (t (when (or p
-		       (prompt-for-y-or-n
-			:default t :default-string "Y"
-			:prompt
-			"Fasl file up to date, compile source anyway? "))
-	       (with-output-to-window (*error-output* "Compiler Warnings")
-		 (in-lisp (compile-file (namestring pn) :error-file nil))))))))
-
-(defcommand "Editor Compile Group" (p)
-  "Compile each file in the current group which needs it in the editor Lisp.
-   If a file has type LISP and there is a curresponding file with type
-   FASL which has been written less recently (or it doesn't exit), then
-   the file is compiled, with error output directed to the \"Compiler Warnings\"
-   buffer.  If a prefix argument is provided, then all the files are compiled.
-   All modified files are saved beforehand."
-  "Do a Compile-File in each file in the current group that seems to need it
-   in the editor Lisp."
-  (save-all-files-command ())
-  (unless *active-file-group* (editor-error "No active file group."))
-  (dolist (file *active-file-group*)
-    (when (string-equal (pathname-type file) "lisp")
-      (let ((tn (probe-file file)))
-	(cond ((not tn)
-	       (message "File ~A not found." (namestring file)))
-	      ((older-or-non-existent-fasl-p tn p)
-	       (with-output-to-window (*error-output* "Compiler Warnings")
-		 (in-lisp (compile-file (namestring tn) :error-file nil)))))))))
-
-(defcommand "List Compile Group" (p)
-  "List any files that would be compiled by \"Compile Group\".  All Modified
-   files are saved before checking to generate a consistent list."
-  "Do a Compile-File in each file in the current group that seems to need it."
-  (declare (ignore p))
-  (save-all-files-command ())
-  (unless *active-file-group* (editor-error "No active file group."))
-  (with-pop-up-display (s)
-    (write-line "\"Compile Group\" would compile the following files:" s)
-    (force-output s)
-    (dolist (file *active-file-group*)
-      (when (string-equal (pathname-type file) "lisp")
-	(let ((tn (probe-file file)))
-	  (cond ((not tn)
-		 (format s "File ~A not found.~%" (namestring file)))
-		((older-or-non-existent-fasl-p tn)
-		 (write-line (namestring tn) s)))
-	  (force-output s))))))
-
-(defhvar "Load Pathname Defaults"
-  "The default pathname used by the load command.")
-
-(defcommand "Editor Load File" (p)
-  "Prompt for a file to load into Editor Lisp."
-  "Prompt for a file to load into the Editor Lisp."
-  (declare (ignore p))
-  (let ((name (truename (prompt-for-file
-			 :default
-			 (or (value load-pathname-defaults)
-			     (buffer-default-pathname (current-buffer)))
-			 :prompt "Editor file to load: "
-			 :help "The name of the file to load"))))
-    (setv load-pathname-defaults name)
-    (in-lisp (load name))))
-
-
-
-;;;; Lisp documentation stuff.
-
-;;; FUNCTION-TO-DESCRIBE is used in "Editor Describe Function Call" and
-;;; "Describe Function Call".
-;;;
-(defmacro function-to-describe (var error-name)
-  `(cond ((not (symbolp ,var))
-	  (,error-name "~S is not a symbol." ,var))
-	 ((macro-function ,var))
-	 ((fboundp ,var)
-	  (if (listp (symbol-function ,var))
-	      ,var
-	      (symbol-function ,var)))
-	 (t
-	  (,error-name "~S is not a function." ,var))))
-
-(defcommand "Editor Describe Function Call" (p)
-  "Describe the most recently typed function name in the editor Lisp."
-  "Describe the most recently typed function name in the editor Lisp."
-  (declare (ignore p))
-  (with-mark ((mark1 (current-point))
-	      (mark2 (current-point)))
-    (pre-command-parse-check mark1)
-    (unless (backward-up-list mark1) (editor-error))
-    (form-offset (move-mark mark2 (mark-after mark1)) 1)
-    (with-input-from-region (s (region mark1 mark2))
-      (in-lisp
-       (let* ((sym (read s))
-	      (fun (function-to-describe sym editor-error)))
-	 (with-pop-up-display (*standard-output*)
-	   (editor-describe-function fun sym)))))))
-
-
-(defcommand "Editor Describe Symbol" (p)
-  "Describe the previous s-expression if it is a symbol in the editor Lisp."
-  "Describe the previous s-expression if it is a symbol in the editor Lisp."
-  (declare (ignore p))
-  (with-mark ((mark1 (current-point))
-	      (mark2 (current-point)))
-    (mark-symbol mark1 mark2)
-    (with-input-from-region (s (region mark1 mark2))
-      (in-lisp
-       (let ((thing (read s)))
-	 (if (symbolp thing)
-	     (with-pop-up-display (*standard-output*)
-	       (describe thing))
-	     (if (and (consp thing)
-		      (or (eq (car thing) 'quote)
-			  (eq (car thing) 'function))
-		      (symbolp (cadr thing)))
-		 (with-pop-up-display (*standard-output*)
-		   (describe (cadr thing)))
-		 (editor-error "~S is not a symbol, or 'symbol, or #'symbol."
-			       thing))))))))
-
-;;; MARK-SYMBOL moves mark1 and mark2 around the previous or current symbol.
-;;; However, if the marks are immediately before the first constituent char
-;;; of the symbol name, we use the next symbol since the marks probably
-;;; correspond to the point, and Hemlock's cursor display makes it look like
-;;; the point is within the symbol name.  This also tries to ignore :prefix
-;;; characters such as quotes, commas, etc.
-;;;
-(defun mark-symbol (mark1 mark2)
-  (pre-command-parse-check mark1)
-  (with-mark ((tmark1 mark1)
-	      (tmark2 mark1))
-    (cond ((and (form-offset tmark1 1)
-		(form-offset (move-mark tmark2 tmark1) -1)
-		(or (mark= mark1 tmark2)
-		    (and (find-attribute tmark2 :lisp-syntax
-					 #'(lambda (x) (not (eq x :prefix))))
-			 (mark= mark1 tmark2))))
-	   (form-offset mark2 1))
-	  (t
-	   (form-offset mark1 -1)
-	   (find-attribute mark1 :lisp-syntax
-			   #'(lambda (x) (not (eq x :prefix))))
-	   (form-offset (move-mark mark2 mark1) 1)))))
-
-
-(defcommand "Editor Describe" (p)
-  "Call Describe on a Lisp object.
-  Prompt for an expression which is evaluated to yield the object."
-  "Prompt for an object to describe."
-  (declare (ignore p))
-  (in-lisp
-   (let* ((exp (prompt-for-expression
-		:prompt "Object: "
-		:help "Expression to evaluate to get object to describe."))
-	  (obj (eval exp)))
-     (with-pop-up-display (*standard-output*)
-       (describe obj)))))
-
-(defcommand "Filter Region" (p)
-  "Apply a Lisp function to each line of the region.
-  An expression is prompted for which should evaluate to a Lisp function
-  from a string to a string.  The function must neither modify its argument
-  nor modify the return value after it is returned."
-  "Call prompt for a function, then call Filter-Region with it and the region."
-  (declare (ignore p))
-  (let* ((exp (prompt-for-expression
-	       :prompt "Function: "
-	       :help "Expression to evaluate to get function to use as filter."))
-	 (fun (in-lisp (eval exp)))
-	 (region (current-region)))
-    (check-region-query-size region)
-    (let* ((start (copy-mark (region-start region) :left-inserting))
-	   (end (copy-mark (region-end region) :left-inserting))
-	   (region (region start end))
-	   (undo-region (copy-region region)))
-      (filter-region fun region)
-      (make-region-undo :twiddle "Filter Region" region undo-region))))
diff --git a/hemlock/lispeval.lisp b/hemlock/lispeval.lisp
deleted file mode 100644
index 7b8ad25c5ef4bb3ebe59053e606dcf98a8ab7b98..0000000000000000000000000000000000000000
--- a/hemlock/lispeval.lisp
+++ /dev/null
@@ -1,977 +0,0 @@
-;;; -*- Package: Hemlock; Log: hemlock.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispeval.lisp,v 1.1.1.10 1992/02/15 01:06:05 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains code for sending requests to eval servers and the
-;;; commands based on that code.
-;;;
-;;; Written by William Lott and Rob MacLachlan.
-;;;
-
-(in-package "HEMLOCK")
-
-
-;;; The note structure holds everything we need to know about an
-;;; operation.  Not all operations use all the available fields.
-;;;
-(defstruct (note (:print-function %print-note))
-  (state :unsent)	      ; :unsent, :pending, :running, :aborted or :dead.
-  server		      ; Server-Info for the server this op is on.
-  context		      ; Short string describing what this op is doing.
-  kind			      ; Either :eval, :compile, or :compile-file
-  buffer		      ; Buffer source came from.
-  region		      ; Region of request
-  package		      ; Package or NIL if none
-  text			      ; string containing request
-  input-file		      ; File to compile or where stuff was found
-  net-input-file	      ; Net version of above.
-  output-file		      ; Temporary output file for compiler fasl code.
-  net-output-file	      ; Net version of above
-  output-date		      ; Temp-file is created before calling compiler,
-			      ;  and this is its write date.
-  lap-file		      ; The lap file for compiles
-  error-file		      ; The file to dump errors into
-  load			      ; Load compiled file or not?
-  (errors 0)		      ; Count of compiler errors.
-  (warnings 0)		      ; Count of compiler warnings.
-  (notes 0))		      ; Count of compiler notes.
-;;;
-(defun %print-note (note stream d)
-  (declare (ignore d))
-  (format stream "#<Eval-Server-Note for ~A [~A]>"
-	  (note-context note)
-	  (note-state note)))
-
-
-
-;;;; Note support routines.
-
-;;; QUEUE-NOTE -- Internal.
-;;;
-;;; This queues note for server.  SERVER-INFO-NOTES keeps notes in stack order,
-;;; not queue order.  We also link the note to the server and try to send it
-;;; to the server.  If we didn't send this note, we tell the user the server
-;;; is busy and that we're queuing his note to be sent later.
-;;;
-(defun queue-note (note server)
-  (push note (server-info-notes server))
-  (setf (note-server note) server)
-  (maybe-send-next-note server)
-  (when (eq (note-state note) :unsent)
-    (message "Server ~A busy, ~A queued."
-	     (server-info-name server)
-	     (note-context note))))
-
-;;; MAYBE-SEND-NEXT-NOTE -- Internal.
-;;;
-;;; Loop over all notes in server.  If we see any :pending or :running, then
-;;; punt since we can't send one.  Otherwise, by the end of the list, we may
-;;; have found an :unsent one, and if we did, next will be the last :unsent
-;;; note.  Remember, SERVER-INFO-NOTES is kept in stack order not queue order.
-;;;
-(defun maybe-send-next-note (server)
-  (let ((busy nil)
-	(next nil))
-    (dolist (note (server-info-notes server))
-      (ecase (note-state note)
-	((:pending :running)
-	 (setf busy t)
-	 (return))
-	(:unsent
-	 (setf next note))
-	(:aborted :dead)))
-    (when (and (not busy) next)
-      (send-note next))))
-
-(defun send-note (note)
-  (let* ((remote (wire:make-remote-object note))
-	 (server (note-server note))
-	 (ts (server-info-slave-info server))
-	 (bg (server-info-background-info server))
-	 (wire (server-info-wire server)))
-    (setf (note-state note) :pending)
-    (message "Sending ~A." (note-context note))
-    (case (note-kind note)
-      (:eval
-       (wire:remote wire
-	 (server-eval-text remote
-			   (note-package note)
-			   (note-text note)
-			   (and ts (ts-data-stream ts)))))
-      (:compile
-       (wire:remote wire
-	 (server-compile-text remote
-			      (note-package note)
-			      (note-text note)
-			      (note-input-file note)
-			      (and ts (ts-data-stream ts))
-			      (and bg (ts-data-stream bg)))))
-      (:compile-file
-       (macrolet ((frob (x)
-		    `(if (pathnamep ,x)
-		       (namestring ,x)
-		       ,x)))
-	 (wire:remote wire
-	   (server-compile-file remote
-				(note-package note)
-				(frob (or (note-net-input-file note)
-					  (note-input-file note)))
-				(frob (or (note-net-output-file note)
-					  (note-output-file note)))
-				(frob (note-error-file note))
-				(frob (note-lap-file note))
-				(note-load note)
-				(and ts (ts-data-stream ts))
-				(and bg (ts-data-stream bg))))))
-      (t
-       (error "Unknown note kind ~S" (note-kind note))))
-    (wire:wire-force-output wire)))
-
-
-;;;; Server Callbacks.
-
-(defun operation-started (note)
-  (let ((note (wire:remote-object-value note)))
-    (setf (note-state note) :running)
-    (message "The ~A started." (note-context note)))
-  (values))
-
-(defun eval-form-error (message)
-  (editor-error message))
-
-(defun lisp-error (note start end msg)
-  (declare (ignore start end))
-  (let ((note (wire:remote-object-value note)))
-    (loud-message "During ~A: ~A"
-		  (note-context note)
-		  msg))
-  (values))
-
-(defun compiler-error (note start end function severity)
-  (let* ((note (wire:remote-object-value note))
-	 (server (note-server note))
-	 (line (mark-line
-		(buffer-end-mark
-		 (server-info-background-buffer server))))
-	 (message (format nil "~:(~A~) ~@[in ~A ~]during ~A."
-			  severity
-			  function
-			  (note-context note)))
-	 (error (make-error-info :buffer (note-buffer note)
-				 :message message
-				 :line line)))
-    (message "~A" message)
-    (case severity
-      (:error (incf (note-errors note)))
-      (:warning (incf (note-warnings note)))
-      (:note (incf (note-notes note))))
-    (let ((region (case (note-kind note)
-		    (:compile
-		     (note-region note))
-		    (:compile-file
-		     (let ((buff (note-buffer note)))
-		       (and buff (buffer-region buff))))
-		    (t
-		     (error "Compiler error in ~S?" note)))))
-      (when region
-	(let* ((region-end (region-end region))
-	       (m1 (copy-mark (region-start region) :left-inserting))
-	       (m2 (copy-mark m1 :left-inserting)))
-	  (when start
-	    (character-offset m1 start)
-	    (when (mark> m1 region-end)
-	      (move-mark m1 region-end)))
-	  (unless (and end (character-offset m2 end))
-	    (move-mark m2 region-end))
-	  
-	  (setf (error-info-region error)
-		(region m1 m2)))))
-
-    (vector-push-extend error (server-info-errors server)))
-
-  (values))
-
-(defun eval-text-result (note start end values)
-  (declare (ignore note start end))
-  (message "=> ~{~#[~;~A~:;~A, ~]~}" values)
-  (values))
-
-(defun operation-completed (note abortp)
-  (let* ((note (wire:remote-object-value note))
-	 (server (note-server note))
-	 (file (note-output-file note)))
-    (wire:forget-remote-translation note)
-    (setf (note-state note) :dead)
-    (setf (server-info-notes server)
-	  (delete note (server-info-notes server)
-		  :test #'eq))
-    (setf (note-server note) nil)
-
-    (if abortp
-	(loud-message "The ~A aborted." (note-context note))
-	(let ((errors (note-errors note))
-	      (warnings (note-warnings note))
-	      (notes (note-notes note)))
-	  (message "The ~A complete.~
-		    ~@[ ~D error~:P~]~@[ ~D warning~:P~]~@[ ~D note~:P~]"
-		   (note-context note)
-		   (and (plusp errors) errors)
-		   (and (plusp warnings) warnings)
-		   (and (plusp notes) notes))))
-
-    (let ((region (note-region note)))
-      (when (regionp region)
-	(delete-mark (region-start region))
-	(delete-mark (region-end region))
-	(setf (note-region note) nil)))
-
-    (when (and (eq (note-kind note)
-		   :compile-file)
-	       (not (eq file t))
-	       file)
-      (if (> (file-write-date file)
-	     (note-output-date note))
-	  (let ((new-name (make-pathname :type "fasl"
-					 :defaults (note-input-file note))))
-	    (rename-file file new-name)
-	    (unix:unix-chmod (namestring new-name) #o644))
-	  (delete-file file)))
-    (maybe-send-next-note server))
-  (values))
-
-
-;;;; Stuff to send noise to the server.
-
-;;; EVAL-FORM-IN-SERVER -- Public.
-;;;
-(defun eval-form-in-server (server-info form
-			    &optional (package (value current-package)))
-  "This evals form, a simple-string, in the server for server-info.  Package
-   is the name of the package in which the server reads form, and it defaults
-   to the value of \"Current Package\".  If package is nil, then the slave uses
-   the value of *package*.  If server is busy with other requests, this signals
-   an editor-error to prevent commands using this from hanging.  If the server
-   dies while evaluating form, then this signals an editor-error.  This returns
-   a list of strings which are the printed representation of all the values
-   returned by form in the server."
-  (declare (simple-string form))
-  (when (server-info-notes server-info)
-    (editor-error "Server ~S is currently busy.  See \"List Operations\"."
-		  (server-info-name server-info)))
-  (multiple-value-bind (values error)
-		       (wire:remote-value (server-info-wire server-info)
-			 (server-eval-form package form))
-    (when error
-      (editor-error "The server died before finishing"))
-    values))
-
-;;; EVAL-FORM-IN-SERVER-1 -- Public.
-;;;
-;;; We use VALUES to squelch the second value of READ-FROM-STRING.
-;;;
-(defun eval-form-in-server-1 (server-info form
-			      &optional (package (value current-package)))
-  "This calls EVAL-FORM-IN-SERVER and returns the result of READ'ing from
-   the first string EVAL-FORM-IN-SERVER returns."
-  (values (read-from-string
-	   (car (eval-form-in-server server-info form package)))))
-
-(defun string-eval (string
-		    &key
-		    (server (get-current-eval-server))
-		    (package (value current-package))
-		    (context (format nil
-				     "evaluation of ~S"
-				     string)))
-  "Queues the evaluation of string on an eval server.  String is a simple
-   string.  If package is not supplied, the string is eval'ed in the slave's
-   current package."
-  (declare (simple-string string))
-  (queue-note (make-note :kind :eval
-			 :context context
-			 :package package
-			 :text string)
-	      server)
-  (values))
-
-(defun region-eval (region
-		    &key
-		    (server (get-current-eval-server))
-		    (package (value current-package))
-		    (context (region-context region "evaluation")))
-  "Queues the evaluation of a region of text on an eval server.  If package
-   is not supplied, the string is eval'ed in the slave's current package."
-  (let ((region (region (copy-mark (region-start region) :left-inserting)
-			(copy-mark (region-end region) :left-inserting))))
-    (queue-note (make-note :kind :eval
-			   :context context
-			   :region region
-			   :package package
-			   :text (region-to-string region))
-		server))
-  (values))
-
-(defun region-compile (region
-		       &key
-		       (server (get-current-eval-server))
-		       (package (value current-package)))
-  "Queues a compilation on an eval server.  If package is not supplied, the
-   string is eval'ed in the slave's current package."
-  (let* ((region (region (copy-mark (region-start region) :left-inserting)
-			 (copy-mark (region-end region) :left-inserting)))
-	 (buf (line-buffer (mark-line (region-start region))))
-	 (pn (and buf (buffer-pathname buf)))
-	 (defined-from (if pn (namestring pn) "unknown")))
-    (queue-note (make-note :kind :compile
-			   :context (region-context region "compilation")
-			   :buffer (and region
-					(region-start region)
-					(mark-line (region-start region))
-					(line-buffer (mark-line
-						      (region-start region))))
-			   :region region
-			   :package package
-			   :text (region-to-string region)
-			   :input-file defined-from)
-		server))
-  (values))
-
-
-
-;;;; File compiling noise.
-
-(defhvar "Remote Compile File"
-  "When set (the default), this causes slave file compilations to assume the
-   compilation is occurring on a remote machine.  This means the source file
-   must be world readable.  Unsetting this, causes no file accesses to go
-   through the super root."
-  :value nil)
-
-;;; FILE-COMPILE compiles files in a client Lisp.  Because of Unix file
-;;; protection, one cannot write files over the net unless they are publicly
-;;; writeable.  To get around this, we create a temporary file that is
-;;; publicly writeable for compiler output.  This file is renamed to an
-;;; ordinary output name if the compiler wrote anything to it, or deleted
-;;; otherwise.  No temporary file is created when output-file is not t.
-;;;
-
-(defun file-compile (file
-		     &key
-		     buffer
-		     (output-file t)
-		     error-file
-		     lap-file
-		     load
-		     (server (get-current-compile-server))
-		     (package (value current-package)))
-  "Compiles file in a client Lisp.  When output-file is t, a temporary
-   output file is used that is publicly writeable in case the client is on
-   another machine.  This file is renamed or deleted after compilation.
-   Setting \"Remote Compile File\" to nil, inhibits this.  If package is not
-   supplied, the string is eval'ed in the slave's current package."
-
-  (let* ((file (truename file)) ; in case of search-list in pathname.
-	 (namestring (namestring file))
-	 (note (make-note
-		:kind :compile-file
-		:context (format nil "compilation of ~A" namestring)
-		:buffer buffer
-		:region nil
-		:package package
-		:input-file file
-		:output-file output-file
-		:error-file error-file
-		:lap-file lap-file
-		:load load)))
-
-    (when (and (value remote-compile-file)
-	       (eq output-file t))
-      (multiple-value-bind (net-infile ofile net-ofile date)
-			   (file-compile-temp-file file)
-	(setf (note-net-input-file note) net-infile)
-	(setf (note-output-file note) ofile)
-	(setf (note-net-output-file note) net-ofile)
-	(setf (note-output-date note) date)))
-
-    (clear-server-errors server
-			 #'(lambda (error)
-			     (eq (error-info-buffer error)
-				 buffer)))
-    (queue-note note server)))
-
-;;; FILE-COMPILE-TEMP-FILE creates a a temporary file that is publicly
-;;; writable in the directory file is in and with a .fasl type.  Four values
-;;; are returned -- a pathname suitable for referencing file remotely, the
-;;; pathname of the temporary file created, a pathname suitable for referencing
-;;; the temporary file remotely, and the write date of the temporary file.
-;;; 
-
-(defun file-compile-temp-file (file)
-  (let ((ofile (loop (let* ((sym (gensym))
-			    (f (merge-pathnames
-				(format nil "compile-file-~A.fasl" sym)
-				file)))
-		       (unless (probe-file f) (return f))))))
-    (multiple-value-bind (fd err)
-			 (unix:unix-open (namestring ofile)
-					 unix:o_creat #o666)
-      (unless fd
-	(editor-error "Couldn't create compiler temporary output file:~%~
-	~A" (unix:get-unix-error-msg err)))
-      (unix:unix-fchmod fd #o666)
-      (unix:unix-close fd))
-    (let ((net-ofile (pathname-for-remote-access ofile)))
-      (values (make-pathname :directory (pathname-directory net-ofile)
-			     :defaults file)
-	      ofile
-	      net-ofile
-	      (file-write-date ofile)))))
-
-(defun pathname-for-remote-access (file)
-  (let* ((machine (machine-instance))
-	 (usable-name (nstring-downcase
-		       (the simple-string
-			    (subseq machine 0 (position #\. machine))))))
-    (declare (simple-string machine usable-name))
-    (make-pathname :directory (concatenate 'simple-string
-					   "/../"
-					   usable-name
-					   (directory-namestring file))
-		   :defaults file)))
-
-;;; REGION-CONTEXT -- internal
-;;;
-;;;    Return a string which describes the code in a region.  Thing is the
-;;; thing being done to the region.  "compilation" or "evaluation"...
-
-(defun region-context (region thing)
-  (declare (simple-string thing))
-  (pre-command-parse-check (region-start region))
-  (let ((start (region-start region)))
-    (with-mark ((m1 start))
-      (unless (start-defun-p m1)
-	(top-level-offset m1 1))
-      (with-mark ((m2 m1))
-	(mark-after m2)
-	(form-offset m2 2)
-	(format nil
-		"~A of ~S"
-		thing
-		(if (eq (mark-line m1) (mark-line m2))
-		  (region-to-string (region m1 m2))
-		  (concatenate 'simple-string
-			       (line-string (mark-line m1))
-			       "...")))))))
-
-
-;;;; Commands (Gosh, wow gee!)
-
-(defcommand "Editor Server Name" (p)
-  "Echos the editor server's name which can be supplied with the -slave switch
-   to connect to a designated editor."
-  "Echos the editor server's name which can be supplied with the -slave switch
-   to connect to a designated editor."
-  (declare (ignore p))
-  (if *editor-name*
-    (message "This editor is named ~S." *editor-name*)
-    (message "This editor is not currently named.")))
-
-(defcommand "Set Buffer Package" (p)
-  "Set the package to be used by Lisp evaluation and compilation commands
-   while in this buffer.  When in a slave's interactive buffers, do NOT
-   set the editor's package variable, but changed the slave's *package*."
-  "Prompt for a package to make into a buffer-local variable current-package."
-  (declare (ignore p))
-  (let* ((name (string (prompt-for-expression
-			:prompt "Package name: "
-			:help "Name of package to associate with this buffer.")))
-	 (buffer (current-buffer))
-	 (info (value current-eval-server)))
-    (cond ((and info
-		(or (eq (server-info-slave-buffer info) buffer)
-		    (eq (server-info-background-buffer info) buffer)))
-	   (wire:remote (server-info-wire info)
-	     (server-set-package name))
-	   (wire:wire-force-output (server-info-wire info)))
-	  ((eq buffer *selected-eval-buffer*)
-	   (setf *package* (maybe-make-package name)))
-	  (t
-	   (defhvar "Current Package"
-	     "The package used for evaluation of Lisp in this buffer."
-	     :buffer buffer  :value name)))
-    (when (buffer-modeline-field-p buffer :package)
-      (dolist (w (buffer-windows buffer))
-	(update-modeline-field buffer w :package)))))
-
-(defcommand "Current Compile Server" (p)
-  "Echos the current compile server's name.  With prefix argument,
-   shows global one.  Does not signal an error or ask about creating a slave."
-  "Echos the current compile server's name.  With prefix argument,
-  shows global one."
-  (let ((info (if p
-		  (variable-value 'current-compile-server :global)
-		  (value current-compile-server))))
-    (if info
-	(message "~A" (server-info-name info))
-	(message "No ~:[current~;global~] compile server." p))))
-
-(defcommand "Set Compile Server" (p)
-  "Specifies the name of the server used globally for file compilation requests."
-  "Call select-current-compile-server."
-  (declare (ignore p))
-  (hlet ((ask-about-old-servers t))
-    (setf (variable-value 'current-compile-server :global)
-	  (maybe-create-server))))
-
-(defcommand "Set Buffer Compile Server" (p)
-  "Specifies the name of the server used for file compilation requests in
-   the current buffer."
-  "Call select-current-compile-server after making a buffer local variable."
-  (declare (ignore p))
-  (hlet ((ask-about-old-servers t))
-    (defhvar "Current Compile Server"
-      "The Server-Info object for the server currently used for compilation requests."
-      :buffer (current-buffer)
-      :value (maybe-create-server))))
-
-(defcommand "Current Eval Server" (p)
-  "Echos the current eval server's name.  With prefix argument, shows
-   global one.  Does not signal an error or ask about creating a slave."
-  "Echos the current eval server's name.  With prefix argument, shows
-   global one.  Does not signal an error or ask about creating a slave."
-  (let ((info (if p
-		  (variable-value 'current-eval-server :global)
-		  (value current-eval-server))))
-    (if info
-	(message "~A" (server-info-name info))
-	(message "No ~:[current~;global~] eval server." p))))
-
-(defcommand "Set Eval Server" (p)
-  "Specifies the name of the server used globally for evaluation and
-   compilation requests."
-  "Call select-current-server."
-  (declare (ignore p))
-  (hlet ((ask-about-old-servers t))
-    (setf (variable-value 'current-eval-server :global)
-	  (maybe-create-server))))
-
-(defcommand "Set Buffer Eval Server" (p)
-  "Specifies the name of the server used for evaluation and compilation
-   requests in the current buffer."
-  "Call select-current-server after making a buffer local variable."
-  (declare (ignore p))
-  (hlet ((ask-about-old-servers t))
-    (defhvar "Current Eval Server"
-      "The Server-Info for the eval server used in this buffer."
-      :buffer (current-buffer)
-      :value (maybe-create-server))))
-
-(defcommand "Evaluate Defun" (p)
-  "Evaluates the current or next top-level form.
-   If the current region is active, then evaluate it."
-  "Evaluates the current or next top-level form."
-  (declare (ignore p))
-  (if (region-active-p)
-      (evaluate-region-command nil)
-      (region-eval (defun-region (current-point)))))
-
-(defcommand "Re-evaluate Defvar" (p)
-  "Evaluate the current or next top-level form if it is a DEFVAR.  Treat the
-   form as if the variable is not bound."
-  "Evaluate the current or next top-level form if it is a DEFVAR.  Treat the
-   form as if the variable is not bound."
-  (declare (ignore p))
-  (let* ((form (defun-region (current-point)))
-	 (start (region-start form)))
-    (with-mark ((var-start start)
-		(var-end start))
-      (mark-after var-start)
-      (form-offset var-start 1)
-      (form-offset (move-mark var-end var-start) 1)
-      (let ((exp (concatenate 'simple-string
-			      "(makunbound '"
-			      (region-to-string (region var-start var-end))
-			      ")")))
-	(eval-form-in-server (get-current-eval-server) exp)))
-    (region-eval form)))
-
-;;; We use Prin1-To-String in the client so that the expansion gets pretty
-;;; printed.  Since the expansion can contain unreadable stuff, we can't expect
-;;; to be able to read that string back in the editor.  We shove the region
-;;; at the client Lisp as a string, so it can read from the string with the
-;;; right package environment.
-;;;
-
-(defcommand "Macroexpand Expression" (p)
-  "Show the macroexpansion of the current expression in the null environment.
-   With an argument, use MACROEXPAND instead of MACROEXPAND-1."
-  "Show the macroexpansion of the current expression in the null environment.
-   With an argument, use MACROEXPAND instead of MACROEXPAND-1."
-  (let ((point (current-point)))
-    (with-mark ((start point))
-      (pre-command-parse-check start)
-      (with-mark ((end start))
-        (unless (form-offset end 1) (editor-error))
-	(with-pop-up-display (s)
-	  (write-string
-	   (eval-form-in-server-1
-	    (get-current-eval-server)
-	    (format nil "(prin1-to-string (~S (read-from-string ~S)))"
-		    (if p 'macroexpand 'macroexpand-1)
-		    (region-to-string (region start end))))
-	   s))))))
-
-(defcommand "Evaluate Expression" (p)
-  "Prompt for an expression to evaluate."
-  "Prompt for an expression to evaluate."
-  (declare (ignore p))
-  (let ((exp (prompt-for-string
-	      :prompt "Eval: "
-	      :help "Expression to evaluate.")))
-    (message "=> ~{~#[~;~A~:;~A, ~]~}"
-	     (eval-form-in-server (get-current-eval-server) exp))))
-
-(defcommand "Compile Defun" (p)
-  "Compiles the current or next top-level form.
-   First the form is evaluated, then the result of this evaluation
-   is passed to compile.  If the current region is active, compile
-   the region."
-  "Evaluates the current or next top-level form."
-  (declare (ignore p))
-  (if (region-active-p)
-      (compile-region-command nil)
-      (region-compile (defun-region (current-point)))))
-
-(defcommand "Compile Region" (p)
-  "Compiles lisp forms between the point and the mark."
-  "Compiles lisp forms between the point and the mark."
-  (declare (ignore p))
-  (region-compile (current-region)))
-
-(defcommand "Evaluate Region" (p)
-  "Evaluates lisp forms between the point and the mark."
-  "Evaluates lisp forms between the point and the mark."
-  (declare (ignore p))
-  (region-eval (current-region)))
-           
-(defcommand "Evaluate Buffer" (p)
-  "Evaluates the text in the current buffer."
-  "Evaluates the text in the current buffer redirecting *Standard-Output* to
-  the echo area.  The prefix argument is ignored."
-  (declare (ignore p))
-  (let ((b (current-buffer)))
-    (region-eval (buffer-region b)
-		 :context (format nil
-				  "evaluation of buffer ``~A''"
-				  (buffer-name b)))))
-
-(defcommand "Load File" (p)
-  "Prompt for a file to load into the current eval server."
-  "Prompt for a file to load into the current eval server."
-  (declare (ignore p))
-  (let ((name (truename (prompt-for-file
-			 :default
-			 (or (value load-pathname-defaults)
-			     (buffer-default-pathname (current-buffer)))
-			 :prompt "File to load: "
-			 :help "The name of the file to load"))))
-    (setv load-pathname-defaults name)
-    (string-eval (format nil "(load ~S)"
-			 (namestring
-			  (if (value remote-compile-file)
-			      (pathname-for-remote-access name)
-			      name))))))
-
-(defcommand "Compile File" (p)
-  "Prompts for file to compile.  Does not compare source and binary write
-   dates.  Does not check any buffer for that file for whether the buffer
-   needs to be saved."
-  "Prompts for file to compile."
-  (declare (ignore p))
-  (let ((pn (prompt-for-file :default
-			     (buffer-default-pathname (current-buffer))
-			     :prompt "File to compile: ")))
-    (file-compile pn)))
-
-(defhvar "Compile Buffer File Confirm"
-  "When set, \"Compile Buffer File\" prompts before doing anything."
-  :value t)
-
-(defcommand "Compile Buffer File" (p)
-  "Compile the file in the current buffer if its associated binary file
-   (of type .fasl) is older than the source or doesn't exist.  When the
-   binary file is up to date, the user is asked if the source should be
-   compiled anyway.  When the prefix argument is supplied, compile the
-   file without checking the binary file.  When \"Compile Buffer File
-   Confirm\" is set, this command will ask for confirmation when it
-   otherwise would not."
-  "Compile the file in the current buffer if the fasl file isn't up to date.
-   When p, always do it."
-  (let* ((buf (current-buffer))
-	 (pn (buffer-pathname buf)))
-    (unless pn (editor-error "Buffer has no associated pathname."))
-    (cond ((buffer-modified buf)
-	   (when (or (not (value compile-buffer-file-confirm))
-		     (prompt-for-y-or-n
-		      :default t :default-string "Y"
-		      :prompt (list "Save and compile file ~A? "
-				    (namestring pn))))
-	     (write-buffer-file buf pn)
-	     (file-compile pn :buffer buf)))
-	  ((older-or-non-existent-fasl-p pn p)
-	   (when (or (not (value compile-buffer-file-confirm))
-		     (prompt-for-y-or-n
-		      :default t :default-string "Y"
-		      :prompt (list "Compile file ~A? " (namestring pn))))
-	     (file-compile pn :buffer buf)))
-	  ((or p
-	       (prompt-for-y-or-n
-		:default t :default-string "Y"
-		:prompt
-		"Fasl file up to date, compile source anyway? "))
-	   (file-compile pn :buffer buf)))))
-
-(defcommand "Compile Group" (p)
-  "Compile each file in the current group which needs it.
-  If a file has type LISP and there is a curresponding file with type
-  FASL which has been written less recently (or it doesn't exit), then
-  the file is compiled, with error output directed to the \"Compiler Warnings\"
-  buffer.  If a prefix argument is provided, then all the files are compiled.
-  All modified files are saved beforehand."
-  "Do a Compile-File in each file in the current group that seems to need it."
-  (save-all-files-command ())
-  (unless *active-file-group* (editor-error "No active file group."))
-  (dolist (file *active-file-group*)
-    (when (string-equal (pathname-type file) "lisp")
-      (let ((tn (probe-file file)))
-	(cond ((not tn)
-	       (message "File ~A not found." (namestring file)))
-	      ((older-or-non-existent-fasl-p tn p)
-	       (file-compile tn)))))))
-
-(defun older-or-non-existent-fasl-p (pathname &optional definitely)
-  (let ((obj-pn (probe-file (make-pathname :type "fasl" :defaults pathname))))
-    (or definitely
-	(not obj-pn)
-	(< (file-write-date obj-pn) (file-write-date pathname)))))
-
-
-
-;;;; Error hacking stuff.
-
-(defcommand "Flush Compiler Error Information" (p)
-  "Flushes all infomation about errors encountered while compiling using the
-   current server"
-  "Flushes all infomation about errors encountered while compiling using the
-   current server"
-  (declare (ignore p))
-  (clear-server-errors (get-current-compile-server t)))
-
-(defcommand "Next Compiler Error" (p)
-  "Move to the next compiler error for the current server.  If an argument is 
-   given, advance that many errors."
-  "Move to the next compiler error for the current server.  If an argument is 
-   given, advance that many errors."
-  (let* ((server (get-current-compile-server t))
-	 (errors (server-info-errors server))
-	 (fp (fill-pointer errors)))
-    (when (zerop fp)
-      (editor-error "There are no compiler errors."))
-    (let* ((old-index (server-info-error-index server))
-	   (new-index (+ (or old-index -1) (or p 1))))
-      (when (< new-index 0)
-	(if old-index
-	    (editor-error "Can't back up ~R, only at the ~:R compiler error."
-			  (- p) (1+ old-index))
-	    (editor-error "Not even at the first compiler error.")))
-      (when (>= new-index fp)
-	(if (= (1+ (or old-index -1)) fp)
-	    (editor-error "No more compiler errors.")
-	    (editor-error "Only ~R remaining compiler error~:P."
-			  (- fp old-index 1))))
-      (setf (server-info-error-index server) new-index)
-      ;; Display the silly error.
-      (let ((error (aref errors new-index)))
-	(let ((region (error-info-region error)))
-	  (if region
-	      (let* ((start (region-start region))
-		     (buffer (line-buffer (mark-line start))))
-		(change-to-buffer buffer)
-		(move-mark (buffer-point buffer) start))
-	      (message "Hmm, no region for this error.")))
-	(let* ((line (error-info-line error))
-	       (buffer (line-buffer line)))
-	  (if (and line (bufferp buffer))
-	      (let ((mark (mark line 0)))
-		(unless (buffer-windows buffer)
-		  (let ((window (find-if-not
-				 #'(lambda (window)
-				     (or (eq window (current-window))
-					 (eq window *echo-area-window*)))
-				 *window-list*)))
-		    (if window
-			(setf (window-buffer window) buffer)
-			(make-window mark))))
-		(move-mark (buffer-point buffer) mark)
-		(dolist (window (buffer-windows buffer))
-		  (move-mark (window-display-start window) mark)
-		  (move-mark (window-point window) mark))
-		(delete-mark mark))
-	      (message "Hmm, no line for this error.")))))))
-
-(defcommand "Previous Compiler Error" (p)
-  "Move to the previous compiler error. If an argument is given, move back
-   that many errors."
-  "Move to the previous compiler error. If an argument is given, move back
-   that many errors."
-  (next-compiler-error-command (- (or p 1))))
-
-
-
-;;;; Operation management commands:
-
-(defcommand "Abort Operations" (p)
-  "Abort all operations on current eval server connection."
-  "Abort all operations on current eval server connection."
-  (declare (ignore p))
-  (let* ((server (get-current-eval-server))
-	 (wire (server-info-wire server)))
-    ;; Tell the slave to abort the current operation and to ignore any further
-    ;; operations.
-    (dolist (note (server-info-notes server))
-      (setf (note-state note) :aborted))
-    (ext:send-character-out-of-band (wire:wire-fd wire) #\N)
-    (wire:remote-value wire (server-accept-operations))
-    ;; Synch'ing with server here, causes any operations queued at the socket or
-    ;; in the server to be ignored, and the last thing evaluated is an
-    ;; instruction to go on accepting operations.
-    (wire:wire-force-output wire)
-    (dolist (note (server-info-notes server))
-      (when (eq (note-state note) :pending)
-	;; The WIRE:REMOTE-VALUE call should have allowed a handshake to
-	;; tell the editor anything :pending was aborted.
-	(error "Operation ~S is still around after we aborted it?" note)))
-    ;; Forget anything queued in the editor.
-    (setf (server-info-notes server) nil)))
-
-(defcommand "List Operations" (p)
-  "List all eval server operations which have not yet completed."
-  "List all eval server operations which have not yet completed."
-  (declare (ignore p))
-  (let ((notes nil))
-    ;; Collect all notes, reversing them since they act like a queue but
-    ;; are not in queue order.
-    (do-strings (str val *server-names*)
-      (declare (ignore str))
-      (setq notes (nconc notes (reverse (server-info-notes val)))))
-    (if notes
-	(with-pop-up-display (s)
-	  (dolist (note notes)
-	    (format s "~@(~8A~) ~A on ~A.~%"
-		    (note-state note)
-		    (note-context note)
-		    (server-info-name (note-server note)))))
-	(message "No uncompleted operations.")))
-  (values))
-
-
-;;;; Describing in the client lisp.
-
-;;; "Describe Function Call" gets the function name from the current form
-;;; as a string.  This string is used as the argument to a call to
-;;; DESCRIBE-FUNCTION-CALL-AUX which is eval'ed in the client lisp.  The
-;;; auxiliary function's name is qualified since it is read in the client
-;;; Lisp with *package* bound to the buffer's package.  The result comes
-;;; back as a list of strings, so we read the first string to get out the
-;;; string value returned by DESCRIBE-FUNCTION-CALL-AUX in the client Lisp.
-;;;
-(defcommand "Describe Function Call" (p)
-  "Describe the current function call."
-  "Describe the current function call."
-  (let ((info (value current-eval-server)))
-    (cond
-     ((not info)
-      (message "Describing from the editor Lisp ...")
-      (editor-describe-function-call-command p))
-     (t
-      (with-mark ((mark1 (current-point))
-		  (mark2 (current-point)))
-	(pre-command-parse-check mark1)
-	(unless (backward-up-list mark1) (editor-error))
-	(form-offset (move-mark mark2 (mark-after mark1)) 1)
-	(let* ((package (value current-package))
-	       (package-exists
-		(eval-form-in-server-1
-		 info
-		 (format nil
-			 "(if (find-package ~S) t (package-name *package*))"
-			 package)
-		 nil)))
-	  (unless (eq package-exists t)
-	    (message "Using package ~S in ~A since ~
-		      ~:[there is no current package~;~:*~S does not exist~]."
-		     package-exists (server-info-name info) package))
-	  (with-pop-up-display (s)
-	    (write-string (eval-form-in-server-1
-			   info
-			   (format nil "(ed::describe-function-call-aux ~S)"
-				   (region-to-string (region mark1 mark2)))
-			   (if (eq package-exists t) package nil))
-			   s))))))))
-
-;;; DESCRIBE-FUNCTION-CALL-AUX is always evaluated in a client Lisp to some
-;;; editor, relying on the fact that the cores have the same functions.  String
-;;; is the name of a function that is read (in the client Lisp).  The result is
-;;; a string of all the output from EDITOR-DESCRIBE-FUNCTION.
-;;;
-(defun describe-function-call-aux (string)
-  (let* ((sym (read-from-string string))
-	 (fun (function-to-describe sym error)))
-    (with-output-to-string (*standard-output*)
-      (editor-describe-function fun sym))))
-
-;;; "Describe Symbol" gets the symbol name and quotes it as the argument to a
-;;; call to DESCRIBE-SYMBOL-AUX which is eval'ed in the client lisp.  The
-;;; auxiliary function's name is qualified since it is read in the client Lisp
-;;; with *package* bound to the buffer's package.  The result comes back as a
-;;; list of strings, so we read the first string to get out the string value
-;;; returned by DESCRIBE-SYMBOL-AUX in the client Lisp.
-;;;
-
-(defcommand "Describe Symbol" (p)
-  "Describe the previous s-expression if it is a symbol."
-  "Describe the previous s-expression if it is a symbol."
-  (declare (ignore p))
-  (let ((info (value current-eval-server)))
-    (cond
-     ((not info)
-      (message "Describing from the editor Lisp ...")
-      (editor-describe-symbol-command nil))
-     (t
-      (with-mark ((mark1 (current-point))
-		  (mark2 (current-point)))
-	(mark-symbol mark1 mark2)
-	(with-pop-up-display (s)
-	  (write-string (eval-form-in-server-1
-			 info
-			 (format nil "(ed::describe-symbol-aux '~A)"
-				 (region-to-string (region mark1 mark2))))
-			s)))))))
-
-(defun describe-symbol-aux (thing)
-  (with-output-to-string (*standard-output*)
-    (describe (if (and (consp thing)
-		       (or (eq (car thing) 'quote)
-			   (eq (car thing) 'function))
-		       (symbolp (cadr thing)))
-		  (cadr thing)
-		  thing))))
diff --git a/hemlock/lispmode.lisp b/hemlock/lispmode.lisp
deleted file mode 100644
index 5fab8263bb7878e75847acd506049762fd7e302b..0000000000000000000000000000000000000000
--- a/hemlock/lispmode.lisp
+++ /dev/null
@@ -1,1479 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;; Hemlock LISP Mode commands
-;;;
-;;; Written by Ivan Vazquez and Bill Maddox.
-;;;
-
-(in-package "HEMLOCK")
-
-
-
-;;;;  ####  VARIABLES  ####
-;;;
-;;; These routines are used to define, for standard LISP mode, the start and end
-;;; of a block to parse.  If these need to be changed for a minor mode that sits
-;;; on top of LISP mode, simply do a DEFHVAR with the minor mode and give the
-;;; name of the function to use instead of START-OF-PARSE-BLOCK and 
-;;; END-OF-PARSE-BLOCK.
-;;; 
-
-(defhvar "Parse Start Function"
-  "Take a mark and move it to the top of a block for paren parsing."
-  :value 'start-of-parse-block)
-
-(defhvar "Parse End Function"
-  "Take a mark and move it to the bottom of a block for paren parsing."
-  :value 'end-of-parse-block)
-
-	    
-;;;; #### STRUCTURES ####
-;;; 
-;;; LISP-INFO is the structure used to store the data about the line in its Plist.
-;;; 
-;;;     -> BEGINS-QUOTED, ENDING-QUOTED are both Boolean slots that tell whether
-;;;        or not a line's begining and/or ending are quoted.
-;;; 
-;;;     -> RANGES-TO-IGNORE is a list of cons cells, each having the form
-;;;        ( [begining-charpos] [end-charpos] ) each of these cells indicating
-;;;        a range to ignore.  End is exclusive.
-;;; 
-;;;     -> NET-OPEN-PARENS, NET-CLOSE-PARENS integers that are the number of 
-;;;        unmatched opening and closing parens that there are on a line.
-;;; 
-;;;     -> SIGNATURE-SLOT ...
-;;; 
-
-(defstruct (lisp-info (:constructor make-lisp-info ()))
-  (begins-quoted nil)		; (or t nil)
-  (ending-quoted nil)		; (or t nil)
-  (ranges-to-ignore nil)	; (or t nil)
-  (net-open-parens 0 :type fixnum)
-  (net-close-parens 0 :type fixnum)
-  (signature-slot))
-
-
-
-;;;;  ####  MACROS  ####
-;;; 
-;;; The following Macros exist to make it easy to acces the Syntax primitives
-;;; without uglifying the code.  They were originally written by Maddox.
-;;; 
-
-(defmacro scan-char (mark attribute values)
-  `(find-attribute ,mark ',attribute ,(attr-predicate values)))
-
-(defmacro rev-scan-char (mark attribute values)
-  `(reverse-find-attribute ,mark ',attribute ,(attr-predicate values)))
-
-(defmacro test-char (char attribute values)
-  `(let ((x (character-attribute ',attribute ,char)))
-     ,(attr-predicate-aux values)))
-
-(eval-when (compile load eval)
-(defun attr-predicate (values)
-  (cond ((eq values 't)
-	 '#'plusp)
-	((eq values 'nil)
-	 '#'zerop)
-	(t `#'(lambda (x) ,(attr-predicate-aux values)))))
-
-(defun attr-predicate-aux (values)
-  (cond ((eq values t)
-	 '(plusp x))
-	((eq values nil)
-	 '(zerop x))
-	((symbolp values)
-	 `(eq x ',values))
-	((and (listp values) (member (car values) '(and or not)))
-	 (cons (car values) (mapcar #'attr-predicate-aux (cdr values))))
-	(t (error "Illegal form in attribute pattern - ~S" values))))
-
-); Eval-When (Compile Load Eval)
-
-;;; 
-;;; FIND-LISP-CHAR
-
-(defmacro find-lisp-char (mark)
-  "Move MARK to next :LISP-SYNTAX character, if one isn't found, return NIL."
-  `(find-attribute ,mark :lisp-syntax
-		   #'(lambda (x)
-		       (member x '(:open-paren :close-paren :newline :comment
-					       :char-quote :string-quote))))) 
-;;; 
-;;; PUSH-RANGE
-
-(defmacro push-range (new-range info-struct)
-  "Insert NEW-RANGE into the LISP-INFO-RANGES-TO-IGNORE slot of the INFO-STRUCT."
-  `(when ,new-range
-     (setf (lisp-info-ranges-to-ignore ,info-struct) 
-	   (cons ,new-range (lisp-info-ranges-to-ignore ,info-struct)))))
-;;; 
-;;; SCAN-DIRECTION
-
-(defmacro scan-direction (mark forwardp &rest forms)
-  "Expand to a form that scans either backward or forward according to Forwardp."
-  (if forwardp
-      `(scan-char ,mark ,@forms)
-      `(rev-scan-char ,mark ,@forms)))
-;;; 
-;;; DIRECTION-CHAR
-
-(defmacro direction-char (mark forwardp)
-  "Expand to a form that returns either the previous or next character according
-  to Forwardp."
-  (if forwardp
-      `(next-character ,mark)
-      `(previous-character ,mark)))
-
-;;; 
-;;; NEIGHBOR-MARK
-
-(defmacro neighbor-mark (mark forwardp)
-  "Expand to a form that moves MARK either backward or forward one character, 
-  depending on FORWARDP."
-  (if forwardp
-      `(mark-after ,mark)
-      `(mark-before ,mark)))
-
-;;; 
-;;; NEIGHBOR-LINE
-
-(defmacro neighbor-line (line forwardp)
-  "Expand to return the next or previous line, according to Forwardp."
-  (if forwardp
-      `(line-next ,line)
-      `(line-previous ,line)))
-
-
-;;;; #### PARSING FUNCTIONS ###
-;;;
-;;; PRE-COMMAND-PARSE-CHECK
-
-(defun pre-command-parse-check (mark &optional (fer-sure-parse nil))
-  "Parse the area before the command is actually executed."
-  (with-mark ((top mark)
-	      (bottom mark))
-    (funcall (value parse-start-function) top)
-    (funcall (value parse-end-function) bottom)
-    (parse-over-block (mark-line top) (mark-line bottom) fer-sure-parse)))
-
-;;; 
-;;; PARSE-OVER-BLOCK
-
-(defun parse-over-block (start-line end-line &optional (fer-sure-parse nil))
-  "Parse over an area indicated from END-LINE to START-LINE."
-  (let ((test-line start-line)
-	prev-line-info)
-    
-    (with-mark ((mark (mark test-line 0)))
-      
-      ; Set the pre-begining and post-ending lines to delimit the range
-      ; of action any command will take.  This means set the lisp-info of the 
-      ; lines immediately before and after the block to Nil.
-      
-      (when (line-previous start-line)
-	(setf (getf (line-plist (line-previous start-line)) 'lisp-info) nil))
-      (when (line-next end-line)
-	(setf (getf (line-plist (line-next end-line)) 'lisp-info) nil))
-      
-      (loop
-       (let ((line-info (getf (line-plist test-line) 'lisp-info)))
-	 
-	 ;;    Reparse the line when any of the following are true:
-	 ;;
-	 ;;      FER-SURE-PARSE is T
-	 ;;
-	 ;;      LINE-INFO or PREV-LINE-INFO are Nil.
-	 ;;
-	 ;;      If the line begins quoted and the previous one wasn't 
-	 ;;      ended quoted.
-	 ;;
-	 ;;      The Line's signature slot is invalid (the line has changed).
-	 ;;
-	 
-	 (when (or fer-sure-parse      
-		   (not line-info)     
-		   (not prev-line-info)
-		   
-		   (not (eq (lisp-info-begins-quoted line-info) 
-			    (lisp-info-ending-quoted prev-line-info)))
-		   
-		   (not (eql (line-signature test-line)     
-			     (lisp-info-signature-slot line-info))))
-	   
-	   (move-to-position mark 0 test-line)
-	   
-	   (unless line-info
-	     (setf line-info (make-lisp-info))
-	     (setf (getf (line-plist test-line) 'lisp-info) line-info))
-	   
-	   (parse-lisp-line-info mark line-info prev-line-info))
-	 
-	 (when (eq end-line test-line)
-	   (return nil))
-	 
-	 (setq prev-line-info line-info)
-	 
-	 (setq test-line (line-next test-line)))))))
-
-
-;;;;  ####  PARSE BLOCK FINDERS  ####
-;;; 
-
-(defhvar "Minimum Lines Parsed"
-  "The minimum number of lines before and after the point parsed by Lisp mode."
-  :value 50)
-(defhvar "Maximum Lines Parsed"
-  "The maximum number of lines before and after the point parsed by Lisp mode."
-  :value 500)
-(defhvar "Defun Parse Goal"
-  "Lisp mode parses the region obtained by skipping this many defuns forward
-   and backward from the point unless this falls outside of the range specified
-   by \"Minimum Lines Parsed\" and \"Maximum Lines Parsed\"."
-  :value 2)
-
-
-(macrolet ((frob (step end)
-	     `(let ((min (value minimum-lines-parsed))
-		    (max (value maximum-lines-parsed))
-		    (goal (value defun-parse-goal))
-		    (last-defun nil))
-		(declare (fixnum min max goal))
-		(do ((line (mark-line mark) (,step line))
-		     (count 0 (1+ count)))
-		    ((null line)
-		     (,end mark))
-		  (declare (fixnum count))
-		  (when (char= (line-character line 0) #\()
-		    (setq last-defun line)
-		    (decf goal)
-		    (when (and (<= goal 0) (>= count min))
-		      (line-start mark line)
-		      (return)))
-		  (when (> count max)
-		    (line-start mark (or last-defun line))
-		    (return))))))
-
-  (defun start-of-parse-block (mark)
-    (frob line-previous buffer-start))
-
-  (defun end-of-parse-block (mark)
-    (frob line-next buffer-end)))
-
-;;; 
-;;; START-OF-SEARCH-LINE
-
-(defun start-of-search-line (line)
-  "Set LINE to the begining line of the block of text to parse."
-  (with-mark ((mark (mark line 0)))
-    (funcall (value 'Parse-Start-Function) mark)
-    (setq line (mark-line mark))))
-
-;;; 
-;;; END-OF-SEACH-LINE
-
-(defun end-of-search-line (line)
-  "Set LINE to the ending line of the block of text to parse."
-  (with-mark ((mark (mark line 0)))
-    (funcall (value 'Parse-End-Function) mark)
-    (setq line (mark-line mark))))
-
-
-;;; PARSE-LISP-LINE-INFO parses through the line doing the following things:
-;;; 
-;;;      Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS.
-;;; 
-;;;      Making all areas of the line that should be invalid (comments,
-;;;      char-quotes, and the inside of strings) and such be in
-;;;      RANGES-TO-IGNORE.
-;;;
-;;;      Set BEGINS-QUOTED and ENDING-QUOTED 
-;;; 
-
-(defun parse-lisp-line-info (mark line-info prev-line-info)
-  "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS,
-RANGES-TO-INGORE, and ENDING-QUOTED."
-  (let ((net-open-parens 0)
-	(net-close-parens 0))
-    (declare (fixnum net-open-parens net-close-parens))
-    
-    ;; Re-set the slots necessary
-    
-    (setf (lisp-info-ranges-to-ignore line-info) nil)
-    
-    ;; The only way the current line begins quoted is when there
-    ;; is a previous line and it's ending was quoted.
-    
-    (setf (lisp-info-begins-quoted line-info)
-	  (and prev-line-info 
-	       (lisp-info-ending-quoted prev-line-info)))
-    
-    (if (lisp-info-begins-quoted line-info)
-	(deal-with-string-quote mark line-info)
-	(setf (lisp-info-ending-quoted line-info) nil))
-    
-    (unless (lisp-info-ending-quoted line-info)
-      (loop 
-	(find-lisp-char mark)
-	(ecase (character-attribute :lisp-syntax (next-character mark))
-	  
-	  (:open-paren
-	   (setq net-open-parens (1+ net-open-parens))
-	   (mark-after mark))
-	  
-	  (:close-paren
-	   (if (zerop net-open-parens)
-	       (setq net-close-parens (1+ net-close-parens))
-	       (setq net-open-parens (1- net-open-parens)))
-	   (mark-after mark))
-	  
-	  (:newline
-	   (setf (lisp-info-ending-quoted line-info) nil)
-	   (return t))
-	  
-	  (:comment
-	   (push-range (cons (mark-charpos mark) (line-length (mark-line mark)))
-		       line-info)
-	   (setf (lisp-info-ending-quoted line-info) nil)
-	   (return t))
-	  
-	  (:char-quote
-	   (mark-after mark)
-	   (push-range (cons (mark-charpos mark) (1+ (mark-charpos mark)))
-		       line-info)
-	   (mark-after mark))
-	  
-	  (:string-quote
-	   (mark-after mark)
-	   (unless (deal-with-string-quote mark line-info)
-	     (setf (lisp-info-ending-quoted line-info) t)
-	     (return t))))))
-    
-    (setf (lisp-info-net-open-parens line-info) net-open-parens)
-    (setf (lisp-info-net-close-parens line-info) net-close-parens)
-    (setf (lisp-info-signature-slot line-info) 
-	  (line-signature (mark-line mark)))))
-
-;;;;  #### STRING QUOTE UTILITIES ####
-;;; 
-;;; 
- 
-;;; 
-;;; VALID-STRING-QUOTE-P
-
-(defmacro valid-string-quote-p (mark forwardp)
-  "Return T if the string-quote indicated by MARK is valid."
-  (let ((test-mark (gensym)))
-    `(with-mark ((,test-mark ,mark))
-       
-       ,(unless forwardp              ; TEST-MARK should always be right before the
-	  `(mark-before ,test-mark))   ; String-quote to be checked.
-       
-       (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote)
-	 
-	 (let ((slash-count 0))
-	   
-	   (loop
-	     (mark-before ,test-mark)
-	     (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote)
-		 (incf slash-count)
-		 (return t)))
-	   (not (oddp slash-count)))))))
-
-;;; 
-;;; FIND-VALID-STRING-QUOTE
-
-(defmacro find-valid-string-quote (mark &key forwardp (cease-at-eol nil))
-  "Expand to a form that will leave MARK before a valid string-quote character,
-  in either a forward or backward direction, according to FORWARDP.  If 
-  CEASE-AT-EOL is T then it will return nil if encountering the EOL before a
-  valid string-quote."
-  (let ((e-mark (gensym)))
-    `(with-mark ((,e-mark ,mark))
-       
-       (loop
-	(unless (scan-direction ,e-mark ,forwardp :lisp-syntax 
-				,(if cease-at-eol 
-				     `(or :newline :string-quote)
-				     `:string-quote))
-	  (return nil))
-	
-	,@(if cease-at-eol
-	      `((when (test-char (direction-char ,e-mark ,forwardp) :lisp-syntax
-				 :newline)
-		  (return nil))))
-	
-	(when (valid-string-quote-p ,e-mark ,forwardp)
-	  (move-mark ,mark ,e-mark)
-	  (return t))
-	
-	(neighbor-mark ,e-mark ,forwardp)))))
-
-;;; DEAL-WITH-STRING-QUOTE 
-;;; 
-;;; Called when a string is begun (i.e. parse hits a #\").  It checks for a
-;;; matching quote on the line that MARK points to, and puts the
-;;; appropriate area in the RANGES-TO-IGNORE slot and leaves MARK pointing
-;;; after this area.  The "appropriate area" is from MARK to the end of the
-;;; line or the matching string-quote, whichever comes first.
-
-(defun deal-with-string-quote (mark info-struct)
-  "Alter the current line's info struct as necessary as due to encountering a
-string quote character."
-  (with-mark ((e-mark mark))
-    
-    (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t)
-    
-	   ;; If matching quote is on this line then mark the area between 
-	   ;; the first quote (MARK) and the matching quote as invalid by 
-	   ;; pushing its begining and ending into the IGNORE-RANGE.
-	   
-	   (push-range (cons (mark-charpos mark) (mark-charpos e-mark))
-		       info-struct)
-		       
-	   (setf (lisp-info-ending-quoted info-struct) nil)
-	   (mark-after e-mark)
-	   (move-mark mark e-mark))
-	   
-	  ;; If the EOL has been hit before the matching quote then mark
-	  ;; the area from MARK to the EOL as invalid.
-	  
-	  (t
-	   (push-range (cons (mark-charpos mark) (1+ (line-length (mark-line mark))))
-		       info-struct)
-			 
-	   ;; The Ending is marked as still being quoted. 
-
-	   (setf (lisp-info-ending-quoted info-struct) t)
-	   (line-end mark)
-	   nil))))
-	     
-
-;;;; Character validity checking:
-
-;;; Find-Ignore-Region  --  Internal
-;;;
-;;;    If the character in the specified direction from Mark is in an ignore
-;;; region, then return the region and the line that the region is in as
-;;; values.  If there is no ignore region, then return NIL and the Mark-Line.
-;;; If the line is not parsed, or there is no character (because of being at
-;;; the buffer beginning or end), then return both values NIL.
-;;;
-(defun find-ignore-region (mark forwardp)
-  (declare (fixnum pos))
-  (flet ((scan (line pos)
-	   (declare (fixnum pos))
-	   (let ((info (getf (line-plist line) 'lisp-info)))
-	     (if info
-		 (dolist (range (lisp-info-ranges-to-ignore info)
-				(values nil line))
-		   (let ((start (car range))
-			 (end (cdr range)))
-		     (declare (fixnum start end))
-		     (when (and (>= pos start) (< pos end))
-		       (return (values range line)))))
-		 (values nil nil)))))
-    (let ((pos (mark-charpos mark))
-	  (line (mark-line mark)))
-      (declare (fixnum pos))
-      (cond (forwardp (scan line pos))
-	    ((> pos 0) (scan line (1- pos)))
-	    (t
-	     (let ((prev (line-previous line)))
-	       (if prev
-		   (scan prev (line-length prev))
-		   (values nil nil))))))))
-
-
-;;; Valid-Spot  --  Public
-;;;
-(defun valid-spot (mark forwardp)
-  "Return true if the character pointed to by Mark is not in a quoted context,
-  false otherwise.  If Forwardp is true, we use the next character, otherwise
-  we use the previous."
-  (multiple-value-bind (region line)
-		       (find-ignore-region mark forwardp)
-    (and line (not region))))
-
-
-;;; Scan-Direction-Valid  --  Internal
-;;;
-;;;    Like scan-direction, but only stop on valid characters.
-;;;
-(defmacro scan-direction-valid (mark forwardp &rest forms)
-  (let ((n-mark (gensym))
-	(n-line (gensym))
-	(n-region (gensym))
-	(n-won (gensym)))
-    `(let ((,n-mark ,mark) (,n-won nil))
-       (loop
-	 (multiple-value-bind (,n-region ,n-line)
-			      (find-ignore-region ,n-mark ,forwardp)
-	   (unless ,n-line (return nil))
-	   (if ,n-region
-	       (move-to-position ,n-mark
-				 ,(if forwardp
-				      `(cdr ,n-region) 
-				      `(car ,n-region))
-				 ,n-line)
-	       (when ,n-won (return t)))
-	   ;;
-	   ;; Peculiar condition when a quoting character terminates a line.
-	   ;; The ignore region is off the end of the line causing %FORM-OFFSET
-	   ;; to infinitely loop.
-	   (when (> (mark-charpos ,n-mark) (line-length ,n-line))
-	     (line-offset ,n-mark 1 0))
-	   (unless (scan-direction ,n-mark ,forwardp ,@forms)
-	     (return nil))
-	   (setq ,n-won t))))))
-
-
-;;;; #### LIST-OFFSETING ####
-;;; 
-;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built
-;;; with the same existing structure, with the altering of one variable.
-;;; This one variable being FORWARDP.
-;;; 
-(defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) )
-  "Expand to code that will go forward one list either backward or forward, 
-according to the FORWARDP flag."
-  (let ((mark (gensym)))
-    `(let ((paren-count ,extra-parens))
-       (declare (fixnum paren-count))
-       (with-mark ((,mark ,actual-mark))
-	 (loop
-	   (scan-direction ,mark ,forwardp :lisp-syntax
-			   (or :close-paren :open-paren :newline))
-	   (let ((ch (direction-char ,mark ,forwardp)))
-	     (unless ch (return nil))
-	     (when (valid-spot ,mark ,forwardp)
-	       (case (character-attribute :lisp-syntax ch)
-		 (:close-paren
-		  (decf paren-count)
-		  ,(when forwardp               ; When going forward, an unmatching
-		     `(when (<= paren-count 0)  ; close-paren means the end of list.
-			(neighbor-mark ,mark ,forwardp)
-			(move-mark ,actual-mark ,mark)
-			(return t))))
-		 (:open-paren
-		  (incf paren-count)
-		  ,(unless forwardp             ; Same as above only end of list
-		     `(when (>= paren-count 0)  ; is opening parens.
-			(neighbor-mark ,mark ,forwardp)
-			(move-mark ,actual-mark ,mark)
-			(return t))))
-		 
-		 (:newline 
-		  ;; When a #\Newline is hit, then the matching paren must lie on
-		  ;; some other line so drop down into the multiple line balancing
-		  ;; function:  QUEST-FOR-BALANCING-PAREN
-		  ;; If no paren seen yet, keep going.
-		  (cond ((zerop paren-count))
-			((quest-for-balancing-paren ,mark paren-count ,forwardp)
-			 (move-mark ,actual-mark ,mark)
-			 (return t))
-			(t
-			 (return nil)))))))
-	   
-	   (neighbor-mark ,mark ,forwardp))))))
-
-;;; 
-;;; QUEST-FOR-BALANCING-PAREN
-
-(defmacro quest-for-balancing-paren (mark paren-count forwardp)
-  "Expand to a form that finds the the balancing paren for however many opens or
-  closes are registered by Paren-Count."
-  `(let* ((line (mark-line ,mark)))
-     (loop
-       (setq line (neighbor-line line ,forwardp))
-       (unless line (return nil))
-       (let ((line-info (getf (line-plist line) 'lisp-info))
-	     (unbal-paren ,paren-count))
-	 (unless line-info (return nil))
-	 
-	 ,(if forwardp
-	      `(decf ,paren-count (lisp-info-net-close-parens line-info))
-	      `(incf ,paren-count (lisp-info-net-open-parens line-info)))
-	 
-	 (when ,(if forwardp
-		    `(<= ,paren-count 0)
-		    `(>= ,paren-count 0))
-	   ,(if forwardp
-		`(line-start ,mark line)
-		`(line-end ,mark line))
-	   (return (goto-correct-paren-char ,mark unbal-paren ,forwardp)))
-
-	 ,(if forwardp
-	      `(incf ,paren-count (lisp-info-net-open-parens line-info))
-	      `(decf ,paren-count (lisp-info-net-close-parens line-info)))))))
-		   
-
-;;; 
-;;; GOTO-CORRECT-PAREN-CHAR
-
-(defmacro goto-correct-paren-char (mark paren-count forwardp)
-  "Expand to a form that will leave MARK on the correct balancing paren matching 
-   however many are indicated by COUNT." 
-  `(with-mark ((m ,mark))
-     (let ((count ,paren-count))
-       (loop
-	 (scan-direction m ,forwardp :lisp-syntax 
-			 (or :close-paren :open-paren :newline))
-	 (when (valid-spot m ,forwardp)
-	   (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
-	     (:close-paren 
-	      (decf count)
-	      ,(when forwardp
-		 `(when (zerop count)
-		    (neighbor-mark m ,forwardp)
-		    (move-mark ,mark m)
-		    (return t))))
-	     
-	     (:open-paren 
-	      (incf count)
-	      ,(unless forwardp
-		 `(when (zerop count)
-		    (neighbor-mark m ,forwardp)
-		    (move-mark ,mark m)
-		    (return t))))))
-	 (neighbor-mark m ,forwardp)))))
-
-
-(defun list-offset (mark offset)
-  (if (plusp offset)
-      (dotimes (i offset t)
-	(unless (%list-offset mark t) (return nil)))
-      (dotimes (i (- offset) t)
-	(unless (%list-offset mark nil) (return nil)))))
-
-(defun forward-up-list (mark)
-  "Moves mark just past the closing paren of the immediately containing list."
-  (%list-offset mark t :extra-parens 1))
-
-(defun backward-up-list (mark)
-  "Moves mark just before the opening paren of the immediately containing list."
-  (%list-offset mark nil :extra-parens -1))
-
-
-
-;;;; Top level form location hacks (open parens beginning lines).
-
-;;; NEIGHBOR-TOP-LEVEL is used only in TOP-LEVEL-OFFSET.
-;;; 
-(eval-when (compile eval)
-(defmacro neighbor-top-level (line forwardp)
-  `(loop
-     (when (test-char (line-character ,line 0) :lisp-syntax :open-paren)
-       (return t))
-     (setf ,line ,(if forwardp `(line-next ,line) `(line-previous ,line)))
-     (unless ,line (return nil))))
-) ;eval-when
-
-(defun top-level-offset (mark offset)
-  "Go forward or backward offset number of top level forms.  Mark is
-   returned if offset forms exists, otherwise nil."
-  (declare (fixnum offset))
-  (let* ((line (mark-line mark))
-	 (at-start (test-char (line-character line 0) :lisp-syntax :open-paren)))
-    (cond ((zerop offset) mark)
-	  ((plusp offset)
-	   (do ((offset (if at-start offset (1- offset))
-			(1- offset)))
-	       (nil)
-	     (declare (fixnum offset))
-	     (unless (neighbor-top-level line t) (return nil))
-	     (when (zerop offset) (return (line-start mark line)))
-	     (unless (setf line (line-next line)) (return nil))))
-	  (t
-	   (do ((offset (if (and at-start (start-line-p mark))
-			    offset
-			    (1+ offset))
-			(1+ offset)))
-		(nil)
-	     (declare (fixnum offset))
-	     (unless (neighbor-top-level line nil) (return nil))
-	     (when (zerop offset) (return (line-start mark line)))
-	     (unless (setf line (line-previous line)) (return nil)))))))
-
-
-(defun mark-top-level-form (mark1 mark2)
-  "Moves mark1 and mark2 to the beginning and end of the current or next defun.
-   Mark1 one is used as a reference.  The marks may be altered even if
-   unsuccessful.  if successful, return mark2, else nil."
-  (let ((winp (cond ((inside-defun-p mark1)
-		     (cond ((not (top-level-offset mark1 -1)) nil)
-			   ((not (form-offset (move-mark mark2 mark1) 1)) nil)
-			   (t mark2)))
-		    ((start-defun-p mark1)
-		     (form-offset (move-mark mark2 mark1) 1))
-		    ((and (top-level-offset (move-mark mark2 mark1) -1)
-			  (start-defun-p mark2)
-			  (form-offset mark2 1)
-			  (same-line-p mark1 mark2))
-		     (form-offset (move-mark mark1 mark2) -1)
-		     mark2)
-		    ((top-level-offset mark1 1)
-		     (form-offset (move-mark mark2 mark1) 1)))))
-    (when winp
-      (when (blank-after-p mark2) (line-offset mark2 1 0))
-      mark2)))
-
-(defun inside-defun-p (mark)
-  "T if the current point is (supposedly) in a top level form."
-  (with-mark ((m mark))
-    (when (top-level-offset m -1)
-      (form-offset m 1)
-      (mark> m mark))))
-
-(defun start-defun-p (mark)
-  "Returns t if mark is sitting before an :open-paren at the beginning of a
-   line."
-  (and (start-line-p mark)
-       (test-char (next-character mark) :lisp-syntax :open-paren)))
-
-
-
-;;;; #### FORM OFFSETING ####
-
-(defmacro %form-offset (mark forwardp)
-  `(with-mark ((m ,mark))
-     (when (scan-direction-valid m ,forwardp :lisp-syntax
-				 (or :open-paren :close-paren
-				     :char-quote :string-quote
-				     :constituent))
-       (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
-	 (:open-paren
-	  (when ,(if forwardp `(list-offset m 1) `(mark-before m))
-	    ,(unless forwardp
-	       '(scan-direction m nil :lisp-syntax (not :prefix)))
-	    (move-mark ,mark m)
-	    t))
-	 (:close-paren
-	  (when ,(if forwardp `(mark-after m) `(list-offset m -1))
-	    ,(unless forwardp
-	       '(scan-direction m nil :lisp-syntax (not :prefix)))
-	    (move-mark ,mark m)
-	    t))
-	 ((:constituent :char-quote)
-	  (scan-direction-valid m ,forwardp :lisp-syntax
-				(not (or :constituent :char-quote)))
-	  ,(if forwardp
-	       `(scan-direction-valid m t :lisp-syntax
-				      (not (or :constituent :char-quote)))
-	       `(scan-direction-valid m nil :lisp-syntax
-				      (not (or :constituent :char-quote
-					       :prefix))))
-	  (move-mark ,mark m)
-	  t)
-	 (:string-quote
-	  (cond ((valid-spot m ,(not forwardp))
-		 (neighbor-mark m ,forwardp)
-		 (when (scan-direction-valid m ,forwardp :lisp-syntax
-					     :string-quote)
-		   (neighbor-mark m ,forwardp)
-		   (move-mark ,mark m)
-		   t))
-		(t (neighbor-mark m ,forwardp)
-		   (move-mark ,mark m)
-		   t)))))))
-
-
-(defun form-offset (mark offset)
-  "Move mark offset number of forms, after if positive, before if negative.
-   Mark is always moved.  If there weren't enough forms, returns nil instead of
-   mark."
-  (if (plusp offset)
-      (dotimes (i offset t)
-	(unless (%form-offset mark t) (return nil)))
-      (dotimes (i (- offset) t)
-	(unless (%form-offset mark nil) (return nil)))))
-
-
-
-;;; Table of special forms with special indenting requirements.
-
-
-(defhvar "Indent Defanything"
-  "This is the number of special arguments implicitly assumed to be supplied
-   in calls to functions whose names begin with \"DEF\".  If set to NIL, this
-   feature is disabled."
-  :value 2)
-
-(defvar *special-forms* (make-hash-table :test #'equal))
-
-(defun defindent (fname args)
-  "Define Fname to have Args special arguments.  If args is null then remove
-   any special arguments information."
-  (check-type fname string)
-  (let ((fname (string-upcase fname)))
-    (cond ((null args) (remhash fname *special-forms*))
-	  (t
-	   (check-type args integer)
-	   (setf (gethash fname *special-forms*) args)))))
-
-
-;;; Hemlock forms.
-;;; 
-(defindent "with-mark" 1)
-(defindent "with-random-typeout" 1)
-(defindent "with-pop-up-display" 1)
-(defindent "defhvar" 1)
-(defindent "hlet" 1)
-(defindent "defcommand" 2)
-(defindent "defattribute" 1)
-(defindent "command-case" 1)
-(defindent "with-input-from-region" 1)
-(defindent "with-output-to-mark" 1)
-(defindent "with-output-to-window" 1)
-(defindent "do-strings" 1)
-(defindent "save-for-undo" 1)
-(defindent "do-alpha-chars" 1)
-(defindent "do-headers-buffers" 1)
-(defindent "do-headers-lines" 1)
-(defindent "with-headers-mark" 1)
-(defindent "frob" 1) ;cover silly FLET and MACROLET names for Rob and Bill.
-(defindent "with-writable-buffer" 1)
-
-;;; Common Lisp forms.
-;;; 
-(defindent "block" 1)
-(defindent "case" 1)
-(defindent "catch" 1)
-(defindent "ccase" 1)			   
-(defindent "compiler-let" 1)
-(defindent "ctypecase" 1)
-(defindent "defconstant" 1)
-(defindent "define-setf-method" 2)
-(defindent "defmacro" 2)
-(defindent "defparameter" 1)
-(defindent "defstruct" 1)
-(defindent "deftype" 2)
-(defindent "defun" 2)
-(defindent "defvar" 1)
-(defindent "do" 2)
-(defindent "do*" 2)
-(defindent "do-all-symbols" 1)
-(defindent "do-external-symbols" 1)
-(defindent "do-symbols" 1)
-(defindent "dolist" 1)
-(defindent "dotimes" 1)
-(defindent "ecase" 1)
-(defindent "etypecase" 1)
-(defindent "eval-when" 1)
-(defindent "flet" 1)
-(defindent "labels" 1)
-(defindent "lambda" 1)
-(defindent "let" 1)
-(defindent "let*" 1)
-(defindent "loop" 0)
-(defindent "macrolet" 1)
-(defindent "multiple-value-bind" 2)
-(defindent "multiple-value-call" 1)
-(defindent "multiple-value-prog1" 1)
-(defindent "multiple-value-setq" 1)
-(defindent "prog1" 1)
-(defindent "progv" 2)
-(defindent "progn" 0)
-(defindent "typecase" 1)
-(defindent "unless" 1)
-(defindent "unwind-protect" 1)
-(defindent "when" 1)
-(defindent "with-input-from-string" 1)
-(defindent "with-open-file" 1)
-(defindent "with-open-stream" 1)
-(defindent "with-output-to-string" 1)
-
-;;; Error/condition system forms.
-;;; 
-(defindent "define-condition" 2)
-(defindent "handler-bind" 1)
-(defindent "handler-case" 1)
-(defindent "restart-bind" 1)
-(defindent "restart-case" 1)
-(defindent "with-simple-restart" 1)
-;;; These are for RESTART-CASE branch formatting.
-(defindent "store-value" 1)
-(defindent "use-value" 1)
-(defindent "muffle-warning" 1)
-(defindent "abort" 1)
-(defindent "continue" 1)
-
-;;; Xlib forms.
-;;;
-(defindent "with-gcontext" 1)
-(defindent "xlib:with-gcontext" 1)
-(defindent "with-state" 1)
-(defindent "xlib:with-state" 1)
-(defindent "with-display" 1)
-(defindent "xlib:with-display" 1)
-(defindent "with-event-queue" 1)
-(defindent "xlib:with-event-queue" 1)
-(defindent "with-server-grabbed" 1)
-(defindent "xlib:with-server-grabbed" 1)
-(defindent "event-case" 1)
-(defindent "xlib:event-case" 1)
-
-;;; CLOS forms.
-;;; 
-(defindent "with-slots" 1)
-(defindent "with-slots*" 2)
-(defindent "with-accessors*" 2)
-(defindent "defclass" 2)
-
-;;; System forms.
-;;;
-(defindent "alien-bind" 1)
-(defindent "def-c-record" 1)
-(defindent "defrecord" 1)
-
-
-
-;;; Compute number of spaces which mark should be indented according to
-;;; local context and lisp grinding conventions.
-
-(defun lisp-indentation (mark)
-  (with-mark ((m mark)
-	      (temp mark))
-    (unless (valid-spot m nil)
-      (return-from lisp-indentation
-		   (lisp-generic-indentation m)))
-    (unless (backward-up-list m)
-      (return-from lisp-indentation 0))
-    (mark-after m)
-    (with-mark ((start m))
-      (unless (and (scan-char m :lisp-syntax (not (or :space :prefix :char-quote)))
-		   (test-char (next-character m) :lisp-syntax :constituent))
-	(return-from lisp-indentation (mark-column start)))
-      (with-mark ((fstart m))
-	(scan-char m :lisp-syntax (not :constituent))
-	(let* ((fname (nstring-upcase (region-to-string (region fstart m))))
-	       (special-args (or (gethash fname *special-forms*)
-				 (and (> (length fname) 2)
-				      (string= fname "DEF" :end1 3)
-				      (value indent-defanything)))))
-	  (declare (simple-string fname))
-	  (cond (special-args
-		 (with-mark ((spec m))
-		   (cond ((and (form-offset spec special-args)
-			       (mark<= spec mark))
-			  (1+ (mark-column start)))
-			 ((skip-valid-space m)
-			  (mark-column m))
-			 (t
-			  (+ (mark-column start) 3)))))
-		((and (form-offset temp -1)
-		      (or (blank-before-p temp)
-			  (not (same-line-p temp fstart)))
-		      (not (same-line-p temp mark)))
-		 (unless (blank-before-p temp)
-		   (line-start temp)
-		   (find-attribute temp :space #'zerop))
-		 (mark-column temp))
-		((skip-valid-space m)
-		 (mark-column m))
-		(t
-		 (mark-column start))))))))
-
-(defun lisp-generic-indentation (mark)
-  (let* ((line (mark-line mark))
-	 (prev (do ((line (line-previous line) (line-previous line)))
-		   ((or (null line) (not (blank-line-p line))) line))))
-    (cond (prev 
-	   (line-start mark prev)
-	   (find-attribute mark :space #'zerop)
-	   (mark-column mark))
-	  (t 0))))
-
-;;; Skip-Valid-Space  --  Internal
-;;;
-;;;    Skip over any space on the line Mark is on, stopping at the first valid
-;;; non-space character.  If there is none on the line, return nil.
-;;;
-(defun skip-valid-space (mark)
-  (loop
-    (scan-char mark :lisp-syntax (not :space))
-    (let ((val (character-attribute :lisp-syntax
-				    (next-character mark))))
-      (cond ((eq val :newline) (return nil))
-	    ((valid-spot mark t) (return mark))))
-    (mark-after mark)))
-
-
-;;;; LISP Mode commands
-
-(defcommand "Defindent" (p)
-  "Define the Lisp indentation for the current function.
-  The indentation is a non-negative integer which is the number
-  of special arguments for the form.  Examples: 2 for Do, 1 for Dolist.
-  If a prefix argument is supplied, then delete the indentation information."
-  "Do a defindent, man!"
-  (declare (ignore p))
-  (with-mark ((m (current-point)))
-    (pre-command-parse-check m)
-    (unless (backward-up-list m) (editor-error))
-    (mark-after m)
-    (with-mark ((n m))
-      (scan-char n :lisp-syntax (not :constituent))
-      (let ((s (region-to-string (region m n))))
-	(declare (simple-string s))
-	(when (zerop (length s)) (editor-error))
-	(if p
-	    (defindent s nil)
-	    (let ((i (prompt-for-integer
-		      :prompt (format nil "Indentation for ~A: " s)
-		      :help "Number of special arguments.")))
-	      (when (minusp i)
-		(editor-error "Indentation must be non-negative."))
-	      (defindent s i))))))
-  (indent-command ()))
-
-(defcommand "Beginning of Defun" (p)
-  "Move the point to the beginning of a top-level form.
-  with an argument, skips the previous p top-level forms."
-  "Move the point to the beginning of a top-level form."
-  (let ((point (current-point))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (if (minusp count)
-	(end-of-defun-command (- count))
-	(unless (top-level-offset point (- count))
-	  (editor-error)))))
-
-;;; "End of Defun", with a positive p (the normal case), does something weird.
-;;; Get a mark at the beginning of the defun, and then offset it forward one
-;;; less top level form than we want.  This sets us up to use FORM-OFFSET which
-;;; allows us to leave the point immediately after the defun.  If we used
-;;; TOP-LEVEL-OFFSET one less than p on the mark at the end of the current
-;;; defun, point would be left at the beginning of the p+1'st form instead of
-;;; at the end of the p'th form.
-;;;
-(defcommand "End of Defun" (p)
-  "Move the point to the end of a top-level form.
-   With an argument, skips the next p top-level forms."
-  "Move the point to the end of a top-level form."
-  (let ((point (current-point))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (if (minusp count)
-	(beginning-of-defun-command (- count))
-	(with-mark ((m point)
-		    (dummy point))
-	  (cond ((not (mark-top-level-form m dummy))
-		 (editor-error "No current or next top level form."))
-		(t 
-		 (unless (top-level-offset m (1- count))
-		   (editor-error "Not enough top level forms."))
-		 ;; We might be one unparsed for away.
-		 (pre-command-parse-check m)
-		 (unless (form-offset m 1)
-		   (editor-error "Not enough top level forms."))
-		 (when (blank-after-p m) (line-offset m 1 0))
-		 (move-mark point m)))))))
-
-(defcommand "Forward List" (p)
-  "Skip over the next Lisp list.
-  With argument, skips the next p lists."
-  "Skip over the next Lisp list."
-  (let ((point (current-point))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (unless (list-offset point count) (editor-error))))
-
-(defcommand "Backward List" (p)
-  "Skip over the previous Lisp list.
-  With argument, skips the previous p lists."
-  "Skip over the previous Lisp list."
-  (let ((point (current-point))
-	(count (- (or p 1))))
-    (pre-command-parse-check point)
-    (unless (list-offset point count) (editor-error))))
-
-(defcommand "Forward Form" (p)
-  "Skip over the next Form.
-  With argument, skips the next p Forms."
-  "Skip over the next Form."
-  (let ((point (current-point))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (unless (form-offset point count) (editor-error))))
-
-(defcommand "Backward Form" (p)
-  "Skip over the previous Form.
-  With argument, skips the previous p Forms."
-  "Skip over the previous Form."
-  (let ((point (current-point))
-	(count (- (or p 1))))
-    (pre-command-parse-check point)
-    (unless (form-offset point count) (editor-error))))
-
-(defcommand "Mark Form" (p)
-  "Set the mark at the end of the next Form.
-   With a positive argument, set the mark after the following p
-   Forms. With a negative argument, set the mark before
-   the preceding -p Forms."
-  "Set the mark at the end of the next Form."
-  (with-mark ((m (current-point)))
-    (pre-command-parse-check m)
-    (let ((count (or p 1))
-	  (mark (push-buffer-mark (copy-mark m) t)))
-      (if (form-offset m count)
-	  (move-mark mark m)
-	  (editor-error)))))
-
-(defcommand "Mark Defun" (p)
-  "Puts the region around the next or containing top-level form.
-   The point is left before the form and the mark is placed immediately
-   after it."
-  "Puts the region around the next or containing top-level form."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((start point)
-		(end point))
-      (cond ((not (mark-top-level-form start end))
-	     (editor-error "No current or next top level form."))
-	    (t
-	     (move-mark point start)
-	     (move-mark (push-buffer-mark (copy-mark point) t) end))))))
-
-(defcommand "Forward Kill Form" (p)
-  "Kill the next Form.
-   With a positive argument, kills the next p Forms.
-   Kills backward with a negative argument."
-  "Kill the next Form."
-  (with-mark ((m1 (current-point))
-	      (m2 (current-point)))
-    (pre-command-parse-check m1)
-    (let ((count (or p 1)))
-      (unless (form-offset m1 count) (editor-error))
-      (if (minusp count)
-	  (kill-region (region m1 m2) :kill-backward)
-	  (kill-region (region m2 m1) :kill-forward)))))
-
-(defcommand "Backward Kill Form" (p)
-  "Kill the previous Form.
-  With a positive argument, kills the previous p Forms.
-  Kills forward with a negative argument."
-  "Kill the previous Form."
-  (forward-kill-form-command (- (or p 1))))
-
-(defcommand "Extract Form" (p)
-  "Replace the current containing list with the next form.  The entire affected
-   area is pushed onto the kill ring.  If an argument is supplied, that many
-   upward levels of list nesting is replaced by the next form."
-  "Replace the current containing list with the next form.  The entire affected
-   area is pushed onto the kill ring.  If an argument is supplied, that many
-   upward levels of list nesting is replaced by the next form."
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((form-start point :right-inserting)
-		(form-end point))
-      (unless (form-offset form-end 1) (editor-error))
-      (form-offset (move-mark form-start form-end) -1)
-      (with-mark ((containing-start form-start :left-inserting)
-		  (containing-end form-end :left-inserting))
-	(dotimes (i (or p 1))
-	  (unless (and (forward-up-list containing-end)
-		       (backward-up-list containing-start))
-	    (editor-error)))
-	(let ((r (copy-region (region form-start form-end))))
-	  (ring-push (delete-and-save-region
-		      (region containing-start containing-end))
-		     *kill-ring*)
-	  (ninsert-region point r)
-	  (move-mark point form-start))))))
-
-(defcommand "Extract List" (p)
-  "Extract the current list.
-  The current list replaces the surrounding list.  The entire affected
-  area is pushed on the kill-ring.  With prefix argument, remove that
-  many surrounding lists."
-  "Replace the P containing lists with the current one."
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((lstart point :right-inserting)
-		(lend point))
-      (if (eq (character-attribute :lisp-syntax (next-character lstart))
-	      :open-paren)
-	  (mark-after lend)
-	  (unless (backward-up-list lstart) (editor-error)))
-      (unless (forward-up-list lend) (editor-error))
-      (with-mark ((rstart lstart)
-		  (rend lend))
-	(dotimes (i (or p 1))
-	  (unless (and (forward-up-list rend) (backward-up-list rstart))
-	    (editor-error)))
-	(let ((r (copy-region (region lstart lend))))
-	  (ring-push (delete-and-save-region (region rstart rend))
-		     *kill-ring*)
-	  (ninsert-region point r)
-	  (move-mark point lstart))))))
-
-(defcommand "Transpose Forms" (p)
-  "Transpose Forms immediately preceding and following the point.
-  With a zero argument, tranposes the Forms at the point and the mark.
-  With a positive argument, transposes the Form preceding the point
-  with the p-th one following it.  With a negative argument, transposes the
-  Form following the point with the p-th one preceding it."
-  "Transpose Forms immediately preceding and following the point."
-  (let ((point (current-point))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (if (zerop count)
-	(let ((mark (current-mark)))
-	  (with-mark ((s1 mark :left-inserting)
-		      (s2 point :left-inserting))
-	    (scan-char s1 :whitespace nil)
-	    (scan-char s2 :whitespace nil)
-	    (with-mark ((e1 s1 :right-inserting)
-			(e2 s2 :right-inserting))
-	      (unless (form-offset e1 1) (editor-error))
-	      (unless (form-offset e2 1) (editor-error))
-	      (ninsert-region s1 (delete-and-save-region (region s2 e2)))
-	      (ninsert-region s2 (delete-and-save-region (region s1 e1))))))
-	(let ((fcount (if (plusp count) count 1))
-	      (bcount (if (plusp count) 1 count)))
-	  (with-mark ((s1 point :left-inserting)
-		      (e2 point :right-inserting))
-	    (dotimes (i bcount)
-	      (unless (form-offset s1 -1) (editor-error)))
-	    (dotimes (i fcount)
-	      (unless (form-offset e2 1) (editor-error)))
-	    (with-mark ((e1 s1 :right-inserting)
-			(s2 e2 :left-inserting))
-	      (unless (form-offset e1 1) (editor-error))
-	      (unless (form-offset s2 -1) (editor-error))
-	      (ninsert-region s1 (delete-and-save-region (region s2 e2)))
-	      (ninsert-region s2 (delete-and-save-region (region s1 e1)))
-	      (move-mark point s2)))))))
-
-
-(defcommand "Indent Form" (p)
-  "Indent Lisp code in the next form."
-  "Indent Lisp code in the next form."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((m point))
-      (unless (form-offset m 1) (editor-error))
-      (lisp-indent-region (region point m) "Indent Form"))))
-
-;;; LISP-INDENT-REGION indents a region of Lisp code without doing excessive
-;;; redundant computation.  We parse the entire region once, then scan through
-;;; doing indentation on each line.  We forcibly reparse each line that we
-;;; indent so that the list operations done to determine indentation of
-;;; subsequent lines will work.  This is done undoably with save1, save2,
-;;; buf-region, and undo-region.
-;;;
-(defun lisp-indent-region (region &optional (undo-text "Lisp region indenting"))
-  (check-region-query-size region)
-  (let ((start (region-start region))
-	(end (region-end region)))
-    (with-mark ((m1 start)
-		(m2 end))
-      (funcall (value parse-start-function) m1)
-      (funcall (value parse-end-function) m2)
-      (parse-over-block (mark-line m1) (mark-line m2)))
-    (let* ((first-line (mark-line start))
-	   (last-line (mark-line end))
-	   (prev (line-previous first-line))
-	   (prev-line-info
-	    (and prev (getf (line-plist prev) 'lisp-info)))
-	   (save1 (line-start (copy-mark start :right-inserting)))
-	   (save2 (line-end (copy-mark end :left-inserting)))
-	   (buf-region (region save1 save2))
-	   (undo-region (copy-region buf-region)))
-      (with-mark ((bol start :left-inserting))
-	(do ((line first-line (line-next line)))
-	    (nil)
-	  (line-start bol line)
-	  (insert-lisp-indentation bol)
-	  (let ((line-info (getf (line-plist line) 'lisp-info)))
-	    (parse-lisp-line-info bol line-info prev-line-info)
-	    (setq prev-line-info line-info))
-	  (when (eq line last-line) (return nil))))
-      (make-region-undo :twiddle undo-text buf-region undo-region))))
-
-;;; INDENT-FOR-LISP is the value of "Indent Function" for "Lisp" mode.
-;;;
-(defun indent-for-lisp (mark)
-  (line-start mark)
-  (pre-command-parse-check mark)
-  (insert-lisp-indentation mark))
-
-(defun insert-lisp-indentation (m)
-  (delete-horizontal-space m)
-  (funcall (value indent-with-tabs) m (lisp-indentation m)))
-
-
-(defcommand "Insert ()" (p)
-  "Insert a pair of parentheses ().
-   With positive argument, puts parentheses around the next p
-   Forms.  The point is positioned after the open parenthesis."
-  "Insert a pair of parentheses ()."
-  (let ((point (current-point))
-	(count (or p 0)))
-    (pre-command-parse-check point)
-    (cond ((not (minusp count))
-	   (insert-character point #\()
-	   (with-mark ((tmark point))
-	     (unless (form-offset tmark count) (editor-error))
-	     (cond ((mark= tmark point)
-		    (insert-character point #\))
-		    (mark-before point))
-		   (t (insert-character tmark #\))))))
-	  (t (editor-error)))))
-
-
-(defcommand "Move Over )" (p)
-  "Move past the next close parenthesis, and start a new line.
-  Any indentation preceding the preceding the parenthesis is deleted,
-  and the new line is indented."
-  "Move past the next close parenthesis, and start a new line."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (pre-command-parse-check point)
-    (with-mark ((m point))
-      (cond ((scan-char m :lisp-syntax :close-paren)
-	     (delete-horizontal-space m)
-	     (mark-after m)
-	     (move-mark point m)
-	     (indent-new-line-command 1))
-	    (t (editor-error))))))
-
-
-(defcommand "Forward Up List" (p)
-  "Move forward past a one containing )."
-  "Move forward past a one containing )."
-  (let ((point (current-point))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (if (minusp count)
-	(backward-up-list-command (- count))
-	(with-mark ((m point))
-	  (dotimes (i count (move-mark point m))
-	    (unless (forward-up-list m) (editor-error)))))))
-
-
-(defcommand "Backward Up List" (p)
-  "Move backward past a one containing (."
-  "Move backward past a one containing (."
-  (let ((point (current-point))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (if (minusp count)
-	(forward-up-list-command (- count))
-	(with-mark ((m point))
-	  (dotimes (i count (move-mark point m))
-	    (unless (backward-up-list m) (editor-error)))))))
-
-
-(defcommand "Down List" (p)
-  "Move down a level in list structure.
-  With argument, moves down p levels."
-  "Move down a level in list structure."
-  (let ((point (current-point))
-	(count (or p 1)))
-    (pre-command-parse-check point)
-    (with-mark ((m point))
-      (dotimes (i count (move-mark point m))
-	(unless (and (scan-char m :lisp-syntax :open-paren)
-		     (mark-after m))
-	  (editor-error))))))
-
-
-
-;;;; "Lisp Mode".
-
-(defcommand "LISP Mode" (p)
-  "Put current buffer in LISP mode." 
-  "Put current buffer in LISP mode."  
-  (declare (ignore p))
-  (setf (buffer-major-mode (current-buffer)) "LISP"))
-
-
-(defmode "Lisp" :major-p t :setup-function 'setup-lisp-mode)
-
-(defun setup-lisp-mode (buffer)
-  (unless (hemlock-bound-p 'current-package :buffer buffer)
-    (defhvar "Current Package"
-      "The package used for evaluation of Lisp in this buffer."
-      :buffer buffer
-      :value "USER")))
-
-
-
-;;;; Matching parenthesis display.
-
-(defhvar "Paren Pause Period"
-  "This is how long commands that deal with \"brackets\" shows the cursor at
-   the matching \"bracket\" for this number of seconds."
-  :value 0.5)
-
-(defcommand "Lisp Insert )" (p)
-  "Inserts a \")\" and briefly positions the cursor at the matching \"(\"."
-  "Inserts a \")\" and briefly positions the cursor at the matching \"(\"."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (insert-character point #\))
-    (pre-command-parse-check point)
-    (when (valid-spot point nil) 
-      (with-mark ((m point))
-	(if (list-offset m -1)
-	    (let ((pause (value paren-pause-period))
-		  (win (current-window)))
-	      (if pause
-		  (unless (show-mark m win pause)
-		    (clear-echo-area)
-		    (message "~A" (line-string (mark-line m))))
-		  (unless (displayed-p m (current-window))
-		    (clear-echo-area)
-		    (message "~A" (line-string (mark-line m))))))
-	    (editor-error))))))
-
-;;; Since we use paren highlighting in Lisp mode, we do not want paren
-;;; flashing too.
-;;; 
-(defhvar "Paren Pause Period"
-  "This is how long commands that deal with \"brackets\" shows the cursor at
-   the matching \"bracket\" for this number of seconds."
-  :value nil
-  :mode "Lisp")
-;;;
-(defhvar "Highlight Open Parens"
-  "When non-nil, causes open parens to be displayed in a different font when
-   the cursor is directly to the right of the corresponding close paren."
-  :value t
-  :mode "Lisp")
-
-
-
-;;;; Some mode variables to coordinate with other stuff.
-
-(defhvar "Auto Fill Space Indent"
-  "When non-nil, uses \"Indent New Comment Line\" to break lines instead of
-   \"New Line\"."
-  :mode "Lisp" :value t)
-
-(defhvar "Comment Start"
-  "String that indicates the start of a comment."
-  :mode "Lisp" :value ";")
-
-(defhvar "Comment Begin"
-  "String that is inserted to begin a comment."
-  :mode "Lisp" :value "; ")
-
-(defhvar "Indent Function"
-  "Indentation function which is invoked by \"Indent\" command.
-   It must take one argument that is the prefix argument."
-  :value 'indent-for-lisp
-  :mode "Lisp")
diff --git a/hemlock/macros.lisp b/hemlock/macros.lisp
deleted file mode 100644
index 903aeaaa9b70a7132b23e32d20753148b12d7b05..0000000000000000000000000000000000000000
--- a/hemlock/macros.lisp
+++ /dev/null
@@ -1,684 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/macros.lisp,v 1.3 1991/02/08 16:36:27 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains most of the junk that needs to be in the compiler
-;;; to compile Hemlock commands.
-;;;
-;;; Written by Rob MacLachlin and Bill Chiles.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(invoke-hook value setv hlet string-to-variable add-hook remove-hook
-	  defcommand with-mark use-buffer editor-error
-	  editor-error-format-string editor-error-format-arguments do-strings
-	  command-case reprompt with-output-to-mark with-input-from-region
-	  handle-lisp-errors with-pop-up-display *random-typeout-buffers*))
-
-
-
-;;;; Macros used for manipulating Hemlock variables.
-
-(defmacro invoke-hook (place &rest args)
-  "Call the functions in place with args.  If place is a symbol, then this
-   interprets it as a Hemlock variable rather than a Lisp variable, using its
-   current value as the list of functions."
-  (let ((f (gensym)))
-    `(dolist (,f ,(if (symbolp place) `(%value ',place) place))
-       (funcall ,f ,@args))))
-
-(defmacro value (name)
-  "Return the current value of the Hemlock variable name."
-  `(%value ',name))
-
-(defmacro setv (name new-value)
-  "Set the current value of the Hemlock variable name, calling any hook
-   functions with new-value before setting the value."
-  `(%set-value ',name ,new-value))
-
-;;; WITH-VARIABLE-OBJECT  --  Internal
-;;;
-;;;    Look up the variable object for name and bind it to obj, giving error
-;;; if there is no such variable.
-;;;
-(defmacro with-variable-object (name &body forms)
-  `(let ((obj (get ,name 'hemlock-variable-value)))
-     (unless obj (undefined-variable-error ,name))
-     ,@forms))
-
-(defmacro hlet (binds &rest forms)
-  "Hlet ({Var Value}*) {Form}*
-   Similar to Let, only it creates temporary Hemlock variable bindings.  Each
-   of the vars have the corresponding value during the evaluation of the
-   forms."
-  (let ((lets ())
-	(sets ())
-	(unsets ()))
-    (dolist (bind binds)
-      (let ((n-obj (gensym))
-	    (n-val (gensym))
-	    (n-old (gensym)))
-	(push `(,n-val ,(second bind)) lets)
-	(push `(,n-old (variable-object-value ,n-obj)) lets)
-	(push `(,n-obj (with-variable-object ',(first bind) obj)) lets)
-	(push `(setf (variable-object-value ,n-obj) ,n-val) sets)
-	(push `(setf (variable-object-value ,n-obj) ,n-old) unsets)))
-    `(let* ,lets
-       (unwind-protect
-	 (progn ,@sets nil ,@forms)
-	 ,@unsets))))
-
-
-
-;;;; A couple funs to hack strings to symbols.
-
-(eval-when (compile load eval)
-
-(defun bash-string-to-symbol (name suffix)
-  (intern (nsubstitute #\- #\space
-		       (nstring-upcase
-			(concatenate 'simple-string
-				     name (symbol-name suffix))))))
-
-;;; string-to-variable  --  Exported
-;;;
-;;;    Return the symbol which corresponds to the string name
-;;; "string".
-(defun string-to-variable (string)
-  (intern (nsubstitute #\- #\space
-		       (the simple-string (string-upcase string)))
-	  (find-package "HEMLOCK")))
-
-); eval-when (compile load eval)
-
-;;; string-to-keyword  --  Internal
-;;;
-;;;    Mash a string into a Keyword.
-;;;
-(defun string-to-keyword (string)
-  (intern (nsubstitute #\- #\space
-		       (the simple-string (string-upcase string)))
-	  (find-package "KEYWORD")))
-
-
-
-;;;; Macros to add and delete hook functions.
-
-;;; add-hook  --  Exported
-;;;
-;;;    Add a hook function to a hook, defining a variable if
-;;; necessary.
-;;;
-(defmacro add-hook (place hook-fun)
-  "Add-Hook Place Hook-Fun
-  Add Hook-Fun to the list stored in Place.  If place is a symbol then it
-  it is interpreted as a Hemlock variable rather than a Lisp variable."
-  (if (symbolp place)
-      `(pushnew ,hook-fun (value ,place))
-      `(pushnew ,hook-fun ,place)))
-
-;;; remove-hook  --  Public
-;;;
-;;;    Delete a hook-function from somewhere.
-;;;
-(defmacro remove-hook (place hook-fun)
-  "Remove-Hook Place Hook-Fun
-  Remove Hook-Fun from the list in Place.  If place is a symbol then it
-  it is interpreted as a Hemlock variable rather than a Lisp variable."
-  (if (symbolp place)
-      `(setf (value ,place) (delete ,hook-fun (value ,place)))
-      `(setf ,place (delete ,hook-fun ,place))))
-
-
-
-;;;; DEFCOMMAND.
-
-;;; Defcommand  --  Public
-;;;
-(defmacro defcommand (name lambda-list command-doc function-doc
-			   &body forms)
-  "Defcommand Name Lambda-List Command-Doc Function-Doc {Declaration}* {Form}*
-
-  Define a new Hemlock command named Name.  Lambda-List becomes the
-  lambda-list, Function-Doc the documentation, and the Forms the
-  body of the function which implements the command.  The first
-  argument, which must be present, is the prefix argument.  The name
-  of this function is derived by replacing all spaces in the name with
-  hyphens and appending \"-COMMAND\".  Command-Doc becomes the
-  documentation for the command.  See the command implementor's manual
-  for further details.
-
-  An example:
-    (defcommand \"Forward Character\" (p)
-      \"Move the point forward one character.
-       With prefix argument move that many characters, with negative argument
-       go backwards.\"
-      \"Move the point of the current buffer forward p characters.\"
-      (unless (character-offset (buffer-point (current-buffer)) (or p 1))
-        (editor-error)))"
-
-  (unless (stringp function-doc)
-    (error "Command function documentation is not a string: ~S."
-		  function-doc))
-  (when (atom lambda-list)
-    (error "Command argument list is not a list: ~S." lambda-list))
-  (let (command-name function-name)
-    (cond ((listp name)
-	   (setq command-name (car name)  function-name (cadr name))
-	   (unless (symbolp function-name)
-	     (error "Function name is not a symbol: ~S" function-name)))
-	  (t
-	   (setq command-name name
-		 function-name (bash-string-to-symbol name '-COMMAND))))
-    (unless (stringp command-name)
-      (error "Command name is not a string: ~S." name))
-    `(eval-when (load eval)
-       (defun ,function-name ,lambda-list ,function-doc ,@forms)
-       (make-command ',name ,command-doc ',function-name)
-       ',function-name)))
-
-
-
-;;;; PARSE-FORMS
-
-;;; Parse-Forms  --  Internal
-;;;
-;;;    Used for various macros to get the declarations out of a list of
-;;; forms.
-;;;
-(eval-when (compile load eval)
-(defmacro parse-forms ((decls-var forms-var forms) &body gorms)
-  "Parse-Forms (Decls-Var Forms-Var Forms) {Form}*
-  Binds Decls-Var to leading declarations off of Forms and Forms-Var
-  to what is left."
-  `(do ((,forms-var ,forms (cdr ,forms-var))
-	(,decls-var ()))
-       ((or (atom ,forms-var) (atom (car ,forms-var))
-	    (not (eq (caar ,forms-var) 'declare)))
-	,@gorms)
-     (push (car ,forms-var) ,decls-var)))
-)
-
-
-
-;;;; WITH-MARK and USE-BUFFER.
-
-(defmacro with-mark (mark-bindings &rest forms)
-  "With-Mark ({(Mark Pos [Kind])}*) {declaration}* {form}*
-  With-Mark binds a variable named Mark to a mark specified by Pos.  This
-  mark is :temporary, or of kind Kind.  The forms are then evaluated."
-  (do ((bindings mark-bindings (cdr bindings))
-       (let-slots ())
-       (cleanup ()))
-      ((null bindings)
-       (if cleanup
-	   (parse-forms (decls forms forms)
-	     `(let ,(nreverse let-slots)
-		,@decls
-		(unwind-protect
-		  (progn ,@forms)
-		  ,@cleanup)))
-	   `(let ,(nreverse let-slots) ,@forms)))
-    (let ((name (caar bindings))
-	  (pos (cadar bindings))
-	  (type (or (caddar bindings) :temporary)))
-      (cond ((not (eq type :temporary))
-	     (push `(,name (copy-mark ,pos ,type)) let-slots)
-	     (push `(delete-mark ,name) cleanup))
-	    (t
-	     (push `(,name (copy-mark ,pos :temporary)) let-slots))))))
-
-#|SAve this shit in case we want WITH-MARKto no longer cons marks.
-(defconstant with-mark-total 50)
-(defvar *with-mark-free-marks* (make-array with-mark-total))
-(defvar *with-mark-next* 0)
-
-(defmacro with-mark (mark-bindings &rest forms)
-  "WITH-MARK ({(Mark Pos [Kind])}*) {declaration}* {form}*
-   WITH-MARK evaluates each form with each Mark variable bound to a mark
-   specified by the respective Pos, a mark.  The created marks are of kind
-   :temporary, or of kind Kind."
-  (do ((bindings mark-bindings (cdr bindings))
-       (let-slots ())
-       (cleanup ()))
-      ((null bindings)
-       (let ((old-next (gensym)))
-	 (parse-forms (decls forms forms)
-	   `(let ((*with-mark-next* *with-mark-next*)
-		  (,old-next *with-mark-next*))
-	      (let ,(nreverse let-slots)
-		,@decls
-		(unwind-protect
-		    (progn ,@forms)
-		  ,@cleanup))))))
-       (let ((name (caar bindings))
-	     (pos (cadar bindings))
-	     (type (or (caddar bindings) :temporary)))
-	 (push `(,name (mark-for-with-mark ,pos ,type)) let-slots)
-	 (if (eq type :temporary)
-	     (push `(delete-mark ,name) cleanup)
-	     ;; Assume mark is on free list and drop its hold on data.
-	     (push `(setf (mark-line ,name) nil) cleanup)))))
-
-;;; MARK-FOR-WITH-MARK -- Internal.
-;;;
-;;; At run time of a WITH-MARK form, this returns an appropriate mark at the
-;;; position mark of type kind.  First it uses one from the vector of free
-;;; marks, possibly storing one in the vector if we need more marks than we
-;;; have before, and that need is still less than the total free marks we are
-;;; willing to hold onto.  If we're over the free limit, just make one for
-;;; throwing away.
-;;;
-(defun mark-for-with-mark (mark kind)
-  (let* ((line (mark-line mark))
-	 (charpos (mark-charpos mark))
-	 (mark (cond ((< *with-mark-next* with-mark-total)
-		      (let ((m (svref *with-mark-free-marks* *with-mark-next*)))
-			(cond ((markp m)
-			       (setf (mark-line m) line)
-			       (setf (mark-charpos m) charpos)
-			       (setf (mark-%kind m) kind))
-			      (t
-			       (setf m (internal-make-mark line charpos kind))
-			       (setf (svref *with-mark-free-marks*
-					    *with-mark-next*)
-				     m)))
-			(incf *with-mark-next*)
-			m))
-		     (t (internal-make-mark line charpos kind)))))
-    (unless (eq kind :temporary)
-      (push mark (line-marks (mark-line mark))))
-    mark))
-|#
-
-(defmacro use-buffer (buffer &body forms)
-  "Use-Buffer Buffer {Form}*
-  Has The effect of making Buffer the current buffer during the evaluation
-  of the Forms.  For restrictions see the manual."
-  (let ((gensym (gensym)))
-    `(let ((,gensym *current-buffer*)
-	   (*current-buffer* ,buffer))
-       (unwind-protect
-	(progn
-	 (use-buffer-set-up ,gensym)
-	 ,@forms)
-	(use-buffer-clean-up ,gensym)))))
-
-
-
-;;;; EDITOR-ERROR.
-
-(defun print-editor-error (condx s)
-    (apply #'format s (editor-error-format-string condx)
-	    (editor-error-format-arguments condx)))
-
-(define-condition editor-error (error)
-  ((format-string "")
-   (format-arguments '()))
-  (:report print-editor-error))
-;;;
-(setf (documentation 'editor-error-format-string 'function)
-      "Returns the FORMAT control string of the given editor-error condition.")
-(setf (documentation 'editor-error-format-arguments 'function)
-      "Returns the FORMAT arguments for the given editor-error condition.")
-
-(defun editor-error (&rest args)
-  "This function is called to signal minor errors within Hemlock;
-   these are errors that a normal user could encounter in the course of editing
-   such as a search failing or an attempt to delete past the end of the buffer.
-   This function SIGNAL's an editor-error condition formed from args.  Hemlock
-   invokes commands in a dynamic context with an editor-error condition handler
-   bound.  This default handler beeps or flashes (or both) the display.  If
-   args were supplied, it also invokes MESSAGE on them.  The command in
-   progress is always aborted, and this function never returns."
-  (let ((condx (make-condition 'editor-error
-			       :format-string (car args)
-			       :format-arguments (cdr args))))
-    (signal condx)
-    (error "Unhandled editor-error was signaled -- ~A." condx)))
-
-    
-
-;;;; Do-Strings
-
-(defmacro do-strings ((string-var value-var table &optional result) &body forms)
-  "Do-Strings (String-Var Value-Var Table [Result]) {declaration}* {form}*
-  Iterate over the strings in a String Table.  String-Var and Value-Var
-  are bound to the string and value respectively of each successive entry
-  in the string-table Table in alphabetical order.  If supplied, Result is
-  a form to evaluate to get the return value."
-  (let ((value-nodes (gensym))
-	(num-nodes (gensym))
-	(value-node (gensym))
-	(i (gensym)))
-    `(let ((,value-nodes (string-table-value-nodes ,table))
-	   (,num-nodes (string-table-num-nodes ,table)))
-       (dotimes (,i ,num-nodes ,result)
-	 (declare (fixnum ,i))
-	 (let* ((,value-node (svref ,value-nodes ,i))
-		(,value-var (value-node-value ,value-node))
-		(,string-var (value-node-proper ,value-node)))
-	   (declare (simple-string ,string-var))
-	   ,@forms)))))
-
-
-
-;;;; COMMAND-CASE
-
-;;; COMMAND-CASE  --  Public
-;;;
-;;;    Grovel the awful thing and spit out the corresponding Cond.  See Echo
-;;; for the definition of COMMAND-CASE-HELP and logical char stuff.
-;;;
-(eval-when (compile load eval)
-(defun command-case-tag (tag key-event char)
-  (cond ((and (characterp tag) (standard-char-p tag))
-	 `(char= ,char ,tag))
-	((and (symbolp tag) (keywordp tag))
-	 `(logical-key-event-p ,key-event ,tag))
-	(t
-	 (error "Tag in COMMAND-CASE is not a standard character or keyword: ~S"
-		tag))))
-); eval-when (compile load eval)
-;;;  
-(defmacro command-case ((&key (change-window t)
-			      (prompt "Command character: ")
-			      (help "Choose one of the following characters:")
-			      (bind (gensym)))
-			&body forms)
-  "This is analogous to the Common Lisp CASE macro.  Commands such as \"Query
-   Replace\" use this to get a key-event, translate it to a character, and
-   then to dispatch on the character to the specified case.  The syntax is
-   as follows:
-      (COMMAND-CASE ( {key value}* )
-        {( {( {tag}* )  |  tag}  help  {form}* )}*
-        )
-   Each tag is either a character or a logical key-event.  The user's typed
-   key-event is compared using either EXT:LOGICAL-KEY-EVENT-P or CHAR= of
-   EXT:KEY-EVENT-CHAR.
-
-   The legal keys of the key/value pairs are :help, :prompt, :change-window,
-   and :bind.  See the manual for details."
-  (do* ((forms forms (cdr forms))
-	(form (car forms) (car forms))
-	(cases ())
-	(bname (gensym))
-	(again (gensym))
-	(n-prompt (gensym))
-	(n-change (gensym))
-	(bind-char (gensym))
-	(docs ())
-	(t-case `(t (beep) (reprompt))))
-       ((atom forms)
-	`(macrolet ((reprompt ()
-		      `(progn
-			 (setf ,',bind
-			       (prompt-for-key-event* ,',n-prompt ,',n-change))
-			 (setf ,',bind-char (ext:key-event-char ,',bind))
-			 (go ,',AGAIN))))
-	   (block ,bname
-	     (let* ((,n-prompt ,prompt)
-		    (,n-change ,change-window)
-		    (,bind (prompt-for-key-event* ,n-prompt ,n-change))
-		    (,bind-char (ext:key-event-char ,bind)))
-	       (tagbody
-		,AGAIN
-		(return-from
-		 ,bname
-		 (cond ,@(nreverse cases)
-		       ((logical-key-event-p ,bind :abort)
-			(editor-error))
-		       ((logical-key-event-p ,bind :help)
-			(command-case-help ,help ',(nreverse docs))
-			(reprompt))
-		       ,t-case)))))))
-    
-    (cond ((atom form)
-	   (error "Malformed Command-Case clause: ~S" form))
-	  ((eq (car form) t)
-	   (setq t-case form))
-	  ((or (< (length form) 2)
-	       (not (stringp (second form))))
-	   (error "Malformed Command-Case clause: ~S" form))
-	  (t
-	   (let ((tag (car form))
-		 (rest (cddr form)))
-	     (cond ((atom tag)
-		    (push (cons (command-case-tag tag bind bind-char) rest)
-			  cases)
-		    (setq tag (list tag)))
-		   (t
-		    (do ((tag tag (cdr tag))
-			 (res ()
-			      (cons (command-case-tag (car tag) bind bind-char)
-				    res)))
-			((null tag)
-			 (push `((or ,@res) . ,rest) cases)))))
-	     (push (cons tag (second form)) docs))))))
-
-    
-
-;;;; Some random macros used everywhere.
-
-(defmacro strlen (str) `(length (the simple-string ,str)))
-(defmacro neq (a b) `(not (eq ,a ,b))))
-
-
-
-;;;; Stuff from here on is implementation dependant.
-
-
-
-;;;; WITH-INPUT & WITH-OUTPUT macros.
-
-(defvar *free-hemlock-output-streams* ()
-  "This variable contains a list of free Hemlock output streams.")
-
-(defmacro with-output-to-mark ((var mark &optional (buffered ':line))
-			       &body gorms)
-  "With-Output-To-Mark (Var Mark [Buffered]) {Declaration}* {Form}*
-  During the evaluation of Forms, Var is bound to a stream which inserts
-  output at the permanent mark Mark.  Buffered is the same as for
-  Make-Hemlock-Output-Stream."
-  (parse-forms (decls forms gorms)
-    `(let ((,var (pop *free-hemlock-output-streams*)))
-       ,@decls
-       (if ,var
-	   (modify-hemlock-output-stream ,var ,mark ,buffered)
-	   (setq ,var (make-hemlock-output-stream ,mark ,buffered)))
-       (unwind-protect
-	 (progn ,@forms)
-	 (setf (hemlock-output-stream-mark ,var) nil)
-	 (push ,var *free-hemlock-output-streams*)))))
-
-(defvar *free-hemlock-region-streams* ()
-  "This variable contains a list of free Hemlock input streams.")
-
-(defmacro with-input-from-region ((var region) &body gorms)
-  "With-Input-From-Region (Var Region) {Declaration}* {Form}*
-  During the evaluation of Forms, Var is bound to a stream which
-  returns input from Region."
-  (parse-forms (decls forms gorms)
-    `(let ((,var (pop *free-hemlock-region-streams*)))
-       ,@decls
-       (if ,var
-	   (setq ,var (modify-hemlock-region-stream ,var ,region))
-	   (setq ,var (make-hemlock-region-stream ,region)))
-       (unwind-protect
-	 (progn ,@forms)
-	 (delete-mark (hemlock-region-stream-mark ,var))
-	 (push ,var *free-hemlock-region-streams*)))))
-
-
-(defmacro with-pop-up-display ((var &key height (buffer-name "Random Typeout"))
-			       &body (body decls))
-  "Execute body in a context with var bound to a stream.  Output to the stream
-   appears in the buffer named buffer-name.  The pop-up display appears after
-   the body completes, but if you supply :height, the output is line buffered,
-   displaying any current output after each line."
-  (when (and (numberp height) (zerop height))
-    (editor-error "I doubt that you really want a window with no height"))
-  (let ((cleanup-p (gensym))
-	(stream (gensym)))
-    `(let ((,cleanup-p nil)
-	   (,stream (get-random-typeout-info ,buffer-name ,height)))
-       (unwind-protect
-	   (progn
-	     (catch 'more-punt
-	       ,(when height
-		  ;; Test height since it may be supplied, but evaluate
-		  ;; to nil.
-		  `(when ,height
-		       (prepare-for-random-typeout ,stream ,height)
-		       (setf ,cleanup-p t)))
-	       (let ((,var ,stream))
-		 ,@decls
-		 (multiple-value-prog1
-		     (progn ,@body)
-		   (unless ,height
-		     (prepare-for-random-typeout ,stream nil)
-		     (setf ,cleanup-p t)
-		     (funcall (device-random-typeout-full-more
-			       (device-hunk-device
-				(window-hunk
-				 (random-typeout-stream-window ,stream))))
-			      ,stream))
-		   (end-random-typeout ,var))))
-	     (setf ,cleanup-p nil))
-	 (when ,cleanup-p (random-typeout-cleanup ,stream))))))
-
-(proclaim '(special *random-typeout-ml-fields* *buffer-names*))
-
-(defvar *random-typeout-buffers* () "A list of random-typeout buffers.")
-
-(defun get-random-typeout-info (buffer-name line-buffered-p)
-  (let* ((buffer (getstring buffer-name *buffer-names*))
-	 (stream
-	  (cond
-	   ((not buffer)
-	    (let* ((buf (make-buffer
-			 buffer-name
-			 :modes '("Fundamental")
-			 :modeline-fields *random-typeout-ml-fields*
-			 :delete-hook
-			 (list #'(lambda (buffer)
-				   (setq *random-typeout-buffers*
-					 (delete buffer *random-typeout-buffers*
-						 :key #'car))))))
-		   (point (buffer-point buf))
-		   (stream (make-random-typeout-stream
-			    (copy-mark point :left-inserting))))
-	      (setf (random-typeout-stream-more-mark stream)
-		    (copy-mark point :right-inserting))
-	      (push (cons buf stream) *random-typeout-buffers*)
-	      stream))
-	   ((member buffer *random-typeout-buffers* :key #'car)
-	    (delete-region (buffer-region buffer))
-	    (let* ((pair (assoc buffer *random-typeout-buffers*))
-		   (stream (cdr pair)))
-	      (setf *random-typeout-buffers*
-		    (cons pair (delete pair *random-typeout-buffers*)))
-	      (setf (random-typeout-stream-first-more-p stream) t)
-	      (setf (random-typeout-stream-no-prompt stream) nil)
-	      stream))
-	   (t
-	    (error "~A is not a random typeout buffer."
-		   (buffer-name buffer))))))
-    (if line-buffered-p
-	(setf (random-typeout-stream-out stream) #'random-typeout-line-out
-	      (random-typeout-stream-sout stream) #'random-typeout-line-sout
-	      (random-typeout-stream-misc stream) #'random-typeout-line-misc)
-	(setf (random-typeout-stream-out stream) #'random-typeout-full-out
-	      (random-typeout-stream-sout stream) #'random-typeout-full-sout
-	      (random-typeout-stream-misc stream) #'random-typeout-full-misc))
-    stream))
-
-
-
-;;;; Error handling stuff.
-
-(proclaim '(special *echo-area-stream*))
-
-;;; LISP-ERROR-ERROR-HANDLER is in Macros.Lisp instead of Rompsite.Lisp because
-;;; it uses WITH-POP-UP-DISPLAY, and Macros is compiled after Rompsite.  It
-;;; binds an error condition handler to get us out of here on a recursive error
-;;; (we are already handling one if we are here).  Since COMMAND-CASE uses
-;;; EDITOR-ERROR for logical :abort characters, and this is a subtype of ERROR,
-;;; we bind an editor-error condition handler just inside of the error handler.
-;;; This keeps us from being thrown out into the debugger with supposedly
-;;; recursive errors occuring.  What we really want in this case is to simply
-;;; get back to the command loop and forget about the error we are currently
-;;; handling.
-;;;
-(defun lisp-error-error-handler (condition &optional internalp)
-  (handler-bind ((editor-error #'(lambda (condx)
-				   (declare (ignore condx))
-				   (beep)
-				   (throw 'command-loop-catcher nil)))
-		 (error #'(lambda (condition)
-			    (declare (ignore condition))
-			    (let ((device (device-hunk-device
-					   (window-hunk (current-window)))))
-			      (funcall (device-exit device) device))
-			    (invoke-debugger
-			     (make-condition
-			      'simple-condition
-			      :format-string
-			      "Error in error handler; Hemlock broken.")))))
-    (clear-echo-area)
-    (clear-editor-input *editor-input*)
-    (beep)
-    (if internalp (write-string "Internal error: " *echo-area-stream*))
-    (princ condition *echo-area-stream*)
-    (let* ((*editor-input* *real-editor-input*)
-	   (key-event (get-key-event *editor-input*)))
-      (if (eq key-event #k"?")
-	  (loop 
-	    (command-case (:prompt "Debug: "
-			   :help
-			   "Type one of the Hemlock debug command characters:")
-	      (#\d "Enter a break loop."
-	       (let ((device (device-hunk-device
-			      (window-hunk (current-window)))))
-		 (funcall (device-exit device) device)
-		 (unwind-protect
-		     (with-simple-restart
-			 (continue "Return to Hemlock's debug loop.")
-		       (invoke-debugger condition))
-		   (funcall (device-init device) device))))
-	      (#\b "Do a stack backtrace."
-		 (with-pop-up-display (*debug-io* :height 100)
-		 (debug:backtrace)))
-	      (#\e "Show the error."
-	       (with-pop-up-display (*standard-output*)
-		 (princ condition)))
-	      ((#\q :exit) "Throw back to Hemlock top-level."
-	       (throw 'editor-top-level-catcher nil))
-	      (#\r "Try to restart from this error."
-	       (let ((cases (compute-restarts)))
-		 (declare (list cases))
-		 (with-pop-up-display (s :height (1+ (length cases)))
-		   (debug::show-restarts cases s))
-		 (invoke-restart-interactively
-		  (nth (prompt-for-integer :prompt "Restart number: ")
-		       cases))))))
-	  (unget-key-event key-event *editor-input*))
-      (throw 'editor-top-level-catcher nil))))
-
-(defmacro handle-lisp-errors (&body body)
-  "Handle-Lisp-Errors {Form}*
-  If a Lisp error happens during the evaluation of the body, then it is
-  handled in some fashion.  This should be used by commands which may
-  get a Lisp error due to some action of the user."
-  `(handler-bind ((error #'lisp-error-error-handler))
-     ,@body))
diff --git a/hemlock/main.lisp b/hemlock/main.lisp
deleted file mode 100644
index 4d7e234dd750c1af4d692ffbd1f8d2522481ac52..0000000000000000000000000000000000000000
--- a/hemlock/main.lisp
+++ /dev/null
@@ -1,376 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/main.lisp,v 1.13 1992/05/25 21:38:31 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Hemlock initialization code and random debugging stuff.
-;;;
-;;; Written by Bill Chiles and Rob MacLachlan
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(*global-variable-names* *mode-names* *buffer-names*
-	  *character-attribute-names* *command-names* *buffer-list*
-	  *window-list* *last-key-event-typed* after-editor-initializations))
-
-
-(in-package "EXTENSIONS")
-(export '(save-all-buffers *hemlock-version*))
-(in-package "HEMLOCK-INTERNALS")
-
-
-
-;;;; Definition of *hemlock-version*.
-
-(defvar *hemlock-version* "3.5")
-(pushnew :hemlock *features*)
-(setf (getf ext:*herald-items* :hemlock) 
-      `("    Hemlock " ,*hemlock-version*))
-
-
-;;;; %INIT-HEMLOCK.
-
-(defvar *hemlock-initialized* nil)
-
-(defun %init-hemlock ()
-  "Initialize hemlock's internal data structures."
-  ;;
-  ;; This function is defined in Buffer.Lisp.  It creates fundamental mode
-  ;; and the buffer main.  Until this is done it is not possible to define
-  ;; or use Hemlock variables.
-  (setup-initial-buffer)
-  ;;
-  ;; Define some of the system variables.
-  (define-some-variables)
-  ;;
-  ;; Site initializations such as window system variables.
-  (site-init)
-  ;;
-  ;; Set up syntax table data structures.
-  (%init-syntax-table)
-  ;;
-  ;; Define print representations for funny characters.
-  (%init-line-image)
-  (setq *hemlock-initialized* t))
-
-
-;;;; Define some globals.
-
-;;; These globals cannot be defined in the appropriate file due to compilation
-;;; or load time constraints.
-;;;
-
-;;; The following belong in other files, but those files are loaded before
-;;; table.lisp which defines MAKE-STRING-TABLE.
-;;;
-;;; vars.lisp
-(defvar *global-variable-names* (make-string-table)
-  "A String Table of global variable names, the values are the symbol names.") 
-;;;
-;;; buffer.lisp
-(defvar *mode-names* (make-string-table) "A String Table of Mode names.")
-(defvar *buffer-names* (make-string-table)
-  "A String Table of Buffer names and their corresponding objects.")
-;;;
-;;; interp.lisp
-(defvar *command-names* (make-string-table) "String table of command names.")
-;;;
-;;; syntax.lisp
-(defvar *character-attribute-names* (make-string-table)
- "String Table of character attribute names and their corresponding keywords.")
-
-
-
-;;;; DEFINE-SOME-VARIABLES.
-
-;;; This is necessary to define "Default Status Line Fields" which belongs
-;;; beside the other modeline variables.  This DEFVAR would live in
-;;; Morecoms.Lisp, but it is compiled and loaded after this file.
-;;;
-(proclaim '(special ed::*recursive-edit-count*))
-;;;
-(make-modeline-field
- :name :edit-level :width 15
- :function #'(lambda (buffer window)
-	       (declare (ignore buffer window))
-	       (if (zerop ed::*recursive-edit-count*)
-		   ""
-		   (format nil "Edit Level: ~2,'0D "
-			   ed::*recursive-edit-count*))))
-
-;;; This is necessary to define "Default Status Line Fields" which belongs
-;;; beside the other modeline variables.  This DEFVAR would live in
-;;; Completion.Lisp, but it is compiled and loaded after this file.
-;;;
-(proclaim '(special ed::*completion-mode-possibility*))
-;;; Hack for now until completion mode is added.
-(defvar ed::*completion-mode-possibility* "")
-;;;
-(make-modeline-field
- :name :completion :width 40
- :function #'(lambda (buffer window)
-	       (declare (ignore buffer window))
-	       ed::*completion-mode-possibility*))
-
-
-(defun define-some-variables ()
-  (defhvar "Default Modes"
-    "This variable contains the default list of modes for new buffers."
-    :value '("Fundamental" "Save"))
-  (defhvar "Echo Area Height"
-    "Number of lines in the echo area window."
-    :value 3)
-  (defhvar "Make Buffer Hook"
-    "This hook is called with the new buffer whenever a buffer is created.")
-  (defhvar "Delete Buffer Hook"
-    "This hook is called with the buffer whenever a buffer is deleted.")
-  (defhvar "Enter Recursive Edit Hook"
-    "This hook is called with the new buffer when a recursive edit is
-     entered.")
-  (defhvar "Exit Recursive Edit Hook"
-    "This hook is called with the value returned when a recursive edit
-     is exited.")
-  (defhvar "Abort Recursive Edit Hook"
-    "This hook is called with the editor-error args when a recursive
-     edit is aborted.")
-  (defhvar "Buffer Major Mode Hook"
-    "This hook is called with the buffer and the new mode when a buffer's
-     major mode is changed.")
-  (defhvar "Buffer Minor Mode Hook"
-    "This hook is called a minor mode is changed.  The arguments are 
-     the buffer, the mode affected and T or NIL depending on when the
-     mode is being turned on or off.")
-  (defhvar "Buffer Writable Hook"
-    "This hook is called whenever someone sets whether the buffer is
-     writable.")
-  (defhvar "Buffer Name Hook"
-    "This hook is called with the buffer and the new name when the name of a
-     buffer is changed.")
-  (defhvar "Buffer Pathname Hook"
-    "This hook is called with the buffer and the new Pathname when the Pathname
-     associated with the buffer is changed.")
-  (defhvar "Buffer Modified Hook"
-    "This hook is called whenever a buffer changes from unmodified to modified
-     and vice versa.  It takes the buffer and the new value for modification
-     flag.")
-  (defhvar "Set Buffer Hook"
-    "This hook is called with the new buffer when the current buffer is set.")
-  (defhvar "After Set Buffer Hook"
-    "This hook is invoked with the old buffer after the current buffer has
-     been changed.")
-  (defhvar "Set Window Hook"
-    "This hook is called with the new window when the current window
-     is set.")
-  (defhvar "Make Window Hook"
-    "This hook is called with a new window when one is created.")
-  (defhvar "Delete Window Hook"
-    "This hook is called with a window before it is deleted.")
-  (defhvar "Window Buffer Hook"
-    "This hook is invoked with the window and new buffer when a window's
-     buffer is changed.")
-  (defhvar "Delete Variable Hook"
-    "This hook is called when a variable is deleted with the args to
-     delete-variable.")
-  (defhvar "Entry Hook"
-    "this hook is called when the editor is entered.")
-  (defhvar "Exit Hook"
-    "This hook is called when the editor is exited.")
-  (defhvar "Redisplay Hook"
-    "This is called on the current window from REDISPLAY after checking the
-     window display start, window image, and recentering.  After calling the
-     functions in this hook, we do the above stuff and call the smart
-     redisplay method for the device."
-    :value nil)
-  (defhvar "Key Echo Delay"
-    "Wait this many seconds before echoing keys in the command loop.  This
-     feature is inhibited when nil."
-    :value 1.0)
-  (defhvar "Input Hook"
-    "The functions in this variable are invoked each time a character enters
-     Hemlock."
-    :value nil)
-  (defhvar "Abort Hook"
-    "These functions are invoked when ^G is typed.  No arguments are passed."
-    :value nil)
-  (defhvar "Command Abort Hook"
-    "These functions get called when commands are aborted, such as with
-     EDITOR-ERROR."
-    :value nil)
-  (defhvar "Character Attribute Hook"
-    "This hook is called with the attribute, character and new value
-     when the value of a character attribute is changed.")
-  (defhvar "Shadow Attribute Hook"
-    "This hook is called when a mode character attribute is made.")
-  (defhvar "Unshadow Attribute Hook"
-    "This hook is called when a mode character attribute is deleted.")
-  (defhvar "Default Modeline Fields"
-    "The default list of modeline-fields for MAKE-WINDOW."
-    :value *default-modeline-fields*)
-  (defhvar "Default Status Line Fields"
-    "This is the default list of modeline-fields for the echo area window's
-     modeline which is used for general information."
-    :value (list (make-modeline-field
-		  :name :hemlock-banner :width 27
-		  :function #'(lambda (buffer window)
-				(declare (ignore buffer window))
-				(format nil "Hemlock ~A  "
-					*hemlock-version*)))
-		 (modeline-field :edit-level)
-		 (modeline-field :completion)))
-  (defhvar "Maximum Modeline Pathname Length"
-    "When set, this variable is the maximum length of the display of a pathname
-     in a modeline.  When the pathname is too long, the :buffer-pathname
-     modeline-field function chops off leading directory specifications until
-     the pathname fits.  \"...\" indicates a truncated pathname."
-    :value nil
-    :hooks (list 'maximum-modeline-pathname-length-hook)))
-
-
-
-;;;; ED.
-
-(defvar *editor-has-been-entered* ()
-  "True if and only if the editor has been entered.")
-(defvar *in-the-editor* ()
-  "True if we are inside the editor.  This is used to prevent ill-advised
-   \"recursive\" edits.")
-
-(defvar *after-editor-initializations-funs* nil
-  "A list of functions to be called after the editor has been initialized upon
-   entering the first time.")
-
-(defmacro after-editor-initializations (&rest forms)
-  "Causes forms to be executed after the editor has been initialized.
-   Forms supplied with successive uses of this macro will be executed after
-   forms supplied with previous uses."
-  `(push #'(lambda () ,@forms)
-	 *after-editor-initializations-funs*))
-
-(defun ed (&optional x
-	   &key (init t)
-	        (display (cdr (assoc :display ext:*environment-list*))))
-  "Invokes the editor, Hemlock.  If X is supplied and is a symbol, the
-   definition of X is put into a buffer, and that buffer is selected.  If X is
-   a pathname, the file specified by X is visited in a new buffer.  If X is not
-   supplied or Nil, the editor is entered in the same state as when last
-   exited.  When :init is supplied as t (the default), the file
-   \"hemlock-init.lisp\", or \".hemlock-init.lisp\" is loaded from the home
-   directory, but the Lisp command line switch -hinit can be used to specify a
-   different name.  Any compiled version of the source is preferred when
-   choosing the file to load.  If the argument is non-nil and not t, then it
-   should be a pathname that will be merged with the home directory."
-  (when *in-the-editor* (error "You are already in the editor, you bogon!"))
-  (let ((*in-the-editor* t)
-	(display (unless *editor-has-been-entered*
-		   (maybe-load-hemlock-init init)
-		   ;; Device dependent initializaiton.
-		   (init-raw-io display))))
-    (catch 'editor-top-level-catcher
-      (site-wrapper-macro
-       (unless *editor-has-been-entered*
-	 ;; Make an initial window, and set up redisplay's internal
-	 ;; data structures.
-	 (%init-redisplay display)
-	 (setq *editor-has-been-entered* t)
-	 ;; Pick up user initializations to be done after initialization.
-	 (invoke-hook (reverse *after-editor-initializations-funs*)))
-       (catch 'hemlock-exit
-	 (catch 'editor-top-level-catcher
-	   (cond ((and x (symbolp x))
-		  (let* ((name (nstring-capitalize
-				(concatenate 'simple-string "Edit " (string x))))
-			 (buffer (or (getstring name *buffer-names*)
-				     (make-buffer name)))
-			 (*print-case* :downcase))
-		    (delete-region (buffer-region buffer))
-		    (with-output-to-mark
-			(*standard-output* (buffer-point buffer))
-		      (eval `(grindef ,x))	; hackish, I know...
-		      (terpri)
-		      (ed::change-to-buffer buffer)
-		      (buffer-start (buffer-point buffer)))))
-		 ((or (stringp x) (pathnamep x))
-		  (ed::find-file-command () x))
-		 (x
-		  (error
-		   "~S is not a symbol or pathname.  I can't edit it!" x))))
-	 
-	 (invoke-hook ed::entry-hook)
-	 (unwind-protect
-	   (loop
-	    (catch 'editor-top-level-catcher
-	      (handler-bind ((error #'(lambda (condition)
-					(lisp-error-error-handler condition
-								  :internal))))
-		(invoke-hook ed::abort-hook)
-		(%command-loop))))
-	   (invoke-hook ed::exit-hook)))))))
-
-(defun maybe-load-hemlock-init (init)
-  (when init
-    (let* ((switch (find "hinit" *command-line-switches*
-			 :test #'string-equal
-			 :key #'cmd-switch-name))
-	   (spec-name
-	    (if (not (eq init t))
-		init
-		(and switch
-		     (or (cmd-switch-value switch)
-			 (car (cmd-switch-words switch)))))))
-      (if spec-name
-	  (load (merge-pathnames spec-name (user-homedir-pathname))
-		:if-does-not-exist nil)
-	  (or (load "home:hemlock-init" :if-does-not-exist nil)
-	      (load "home:.hemlock-init" :if-does-not-exist nil))))))
-
-
-;;;; SAVE-ALL-BUFFERS.
-
-;;; SAVE-ALL-BUFFERS -- Public.
-;;;
-(defun save-all-buffers (&optional (list-unmodified-buffers nil))
-  "This prompts users with each modified buffer as to whether they want to
-   write it out.  If the buffer has no associated file, this will also prompt
-   for a file name.  Supplying the optional argument non-nil causes this
-   to prompt for every buffer."
-  (dolist (buffer *buffer-list*)
-    (when (or list-unmodified-buffers (buffer-modified buffer))
-      (maybe-save-buffer buffer))))
-
-(defun maybe-save-buffer (buffer)
-  (let* ((modified (buffer-modified buffer))
-	 (pathname (buffer-pathname buffer))
-	 (name (buffer-name buffer))
-	 (string (if pathname (namestring pathname))))
-    (format t "Buffer ~S is ~:[UNmodified~;modified~], Save it? "
-	    name modified)
-    (force-output)
-    (when (y-or-n-p)
-      (let ((name (read-line-default "File to write" string)))
-	(format t "Writing file ~A..." name)
-	(force-output)
-	(write-file (buffer-region buffer) name)
-	(write-line "write WON")))))
-
-(defun read-line-default (prompt default)
-  (format t "~A:~@[ [~A]~] " prompt default)
-  (force-output)
-  (do ((result (read-line) (read-line)))
-      (())
-    (declare (simple-string result))
-    (when (plusp (length result)) (return result))
-    (when default (return default))
-    (format t "~A:~@[ [~A]~] " prompt default)
-    (force-output)))
-
-(unless *hemlock-initialized*
-  (%init-hemlock))
diff --git a/hemlock/mh.lisp b/hemlock/mh.lisp
deleted file mode 100644
index 05b7ea6abd0b24e963827eb144dce8493cd1794b..0000000000000000000000000000000000000000
--- a/hemlock/mh.lisp
+++ /dev/null
@@ -1,3170 +0,0 @@
-;;; -*- Package: Hemlock; Log: hemlock.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.
-;;; you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CS.CMU.EDU).
-;;; **********************************************************************
-;;; 
-;;; This is a mailer interface to MH.
-;;; 
-;;; Written by Bill Chiles.
-;;;
-
-(in-package "HEMLOCK")
-
-
-
-;;;; General stuff.
-
-(defvar *new-mail-buffer* nil)
-
-(defvar *mh-utility-bit-bucket* (make-broadcast-stream))
-
-
-(defattribute "Digit"
-  "This is just a (mod 2) attribute for base 10 digit characters.")
-;;;
-(dotimes (i 10)
-  (setf (character-attribute :digit (digit-char i)) 1))
-
-
-(defmacro number-string (number)
-  `(let ((*print-base* 10))
-     (prin1-to-string ,number)))
-
-
-(defmacro do-headers-buffers ((buffer-var folder &optional hinfo-var)
-			      &rest forms)
-  "The Forms are evaluated with Buffer-Var bound to each buffer containing
-   headers lines for folder.  Optionally Hinfo-Var is bound to the
-   headers-information structure."
-  (let ((folder-var (gensym))
-	(hinfo (gensym)))
-    `(let ((,folder-var ,folder))
-       (declare (simple-string ,folder-var))
-       (dolist (,buffer-var *buffer-list*)
-	 (when (hemlock-bound-p 'headers-information :buffer ,buffer-var)
-	   (let ((,hinfo (variable-value 'headers-information
-					 :buffer ,buffer-var)))
-	     (when (string= (the simple-string (headers-info-folder ,hinfo))
-			    ,folder-var)
-	       ,@(if hinfo-var
-		     `((let ((,hinfo-var ,hinfo))
-			 ,@forms))
-		     forms))))))))
-
-(defmacro do-headers-lines ((hbuffer &key line-var mark-var) &rest forms)
-  "Forms are evaluated for each non-blank line.  When supplied Line-Var and
-   Mark-Var are to the line and a :left-inserting mark at the beginning of the
-   line.  This works with DELETE-HEADERS-BUFFER-LINE, but one should be careful
-   using this to modify the hbuffer."
-  (let ((line-var (or line-var (gensym)))
-	(mark-var (or mark-var (gensym)))
-	(id (gensym)))
-    `(with-mark ((,mark-var (buffer-point ,hbuffer) :left-inserting))
-       (buffer-start ,mark-var)
-       (loop
-	 (let* ((,line-var (mark-line ,mark-var))
-		(,id (line-message-id ,line-var)))
-	   (unless (blank-line-p ,line-var)
-	     ,@forms)
-	   (if (or (not (eq ,line-var (mark-line ,mark-var)))
-		   (string/= ,id (line-message-id ,line-var)))
-	       (line-start ,mark-var)
-	       (unless (line-offset ,mark-var 1 0) (return))))))))
-
-(defmacro with-headers-mark ((mark-var hbuffer msg) &rest forms)
-  "Forms are executed with Mark-Var bound to a :left-inserting mark at the
-   beginning of the headers line representing msg.  If no such line exists,
-   no execution occurs."
-  (let ((line (gensym)))    
-    `(do-headers-lines (,hbuffer :line-var ,line :mark-var ,mark-var)
-       (when (string= (the simple-string (line-message-id ,line))
-		      (the simple-string ,msg))
-	 ,@forms
-	 (return)))))
-
-
-
-;;;; Headers Mode.
-
-(defmode "Headers" :major-p t)
-
-(defhvar "Headers Information"
-  "This holds the information about the current headers buffer."
-  :value nil)
-
-(defstruct (headers-info (:print-function print-headers-info))
-  buffer		;Buffer for these headers.
-  folder		;String name of folder with leading MH "+".
-  msg-seq		;MH sequence of messages in buffer.
-  msg-strings		;List of strings representing msg-seq.
-  other-msg-bufs	;List of message buffers referencing this headers buffer.
-  draft-bufs		;List of draft buffers referencing this headers buffer.
-  msg-buffer)
-
-(defun print-headers-info (obj str n)
-  (declare (ignore n))
-  (format str "#<Headers Info ~S>" (headers-info-folder obj)))
-
-(defmacro line-message-deleted (line)
-  `(getf (line-plist ,line) 'mh-msg-deleted))
-
-(defmacro line-message-id (line)
-  `(getf (line-plist ,line) 'mh-msg-id))
-
-(defun headers-current-message (hinfo)
-  (let* ((point (buffer-point (headers-info-buffer hinfo)))
-	 (line (mark-line point)))
-    (unless (blank-line-p line)
-      (values (line-message-id line)
-	      (copy-mark point)))))
-
-(defcommand "Message Headers" (p)
-  "Prompts for a folder and messages, displaying headers in a buffer in the
-   current window.  With an argument, prompt for a pick expression."
-  "Show some headers."
-  (let ((folder (prompt-for-folder)))
-    (new-message-headers
-     folder
-     (prompt-for-message :prompt (if p
-				     "MH messages to pick from: "
-				     "MH messages: ")
-			 :folder folder
-			 :messages "all")
-			 p)))
-
-(defcommand "Pick Headers" (p)
-  "Further narrow the selection of this folders headers.
-   Prompts for a pick expression to pick over the headers in the current
-   buffer.  Entering an empty expression displays all the headers for that
-   folder."
-  "Prompts for a pick expression to pick over the headers in the current
-   buffer."
-  (declare (ignore p))
-  (let ((hinfo (value headers-information)))
-    (unless hinfo
-      (editor-error "Pick Headers only works in a headers buffer."))
-    (pick-message-headers hinfo)))
-
-;;; PICK-MESSAGE-HEADERS picks messages from info's messages based on an
-;;; expression provided by the user.  If the expression is empty, we do
-;;; headers on all the messages in folder.  The buffer's name is changed to
-;;; reflect the messages picked over and the expression used.
-;;; 
-(defun pick-message-headers (hinfo)
-  (let ((folder (headers-info-folder hinfo))
-	(msgs (headers-info-msg-strings hinfo)))
-    (multiple-value-bind (pick user-pick)
-			 (prompt-for-pick-expression)
-      (let* ((hbuffer (headers-info-buffer hinfo))
-	     (new-mail-buf-p (eq hbuffer *new-mail-buffer*))
-	     (region (cond (pick
-			    (message-headers-to-region
-			     folder (pick-messages folder msgs pick)))
-			   (new-mail-buf-p
-			    (maybe-get-new-mail-msg-hdrs folder))
-			   (t (message-headers-to-region folder
-							 (list "all"))))))
-	(with-writable-buffer (hbuffer)
-	  (revamp-headers-buffer hbuffer hinfo)
-	  (when region (insert-message-headers hbuffer hinfo region)))
-	(setf (buffer-modified hbuffer) nil)
-	(buffer-start (buffer-point hbuffer))
-	(setf (buffer-name hbuffer)
-	      (cond (pick (format nil "Headers ~A ~A ~A" folder msgs user-pick))
-		    (new-mail-buf-p (format nil "Unseen Headers ~A" folder))
-		    (t (format nil "Headers ~A (all)" folder))))))))
-
-;;; NEW-MESSAGE-HEADERS picks over msgs if pickp is non-nil, or it just scans
-;;; msgs.  It is important to pick and get the message headers region before
-;;; making the buffer and info structures since PICK-MESSAGES and
-;;; MESSAGE-HEADERS-TO-REGION will call EDITOR-ERROR if they fail.  The buffer
-;;; name is chosen based on folder, msgs, and an optional pick expression.
-;;;
-(defun new-message-headers (folder msgs &optional pickp)
-  (multiple-value-bind (pick-exp user-pick)
-		       (if pickp (prompt-for-pick-expression))
-    (let* ((pick (if pick-exp (pick-messages folder msgs pick-exp)))
-	   (region (message-headers-to-region folder (or pick msgs)))
-	   (hbuffer (maybe-make-mh-buffer (format nil "Headers ~A ~A~:[~; ~S~]"
-					       folder msgs pick user-pick)
-				       :headers))
-	   (hinfo (make-headers-info :buffer hbuffer :folder folder)))
-      (insert-message-headers hbuffer hinfo region)
-      (defhvar "Headers Information"
-	"This holds the information about the current headers buffer."
-	:value hinfo :buffer hbuffer)
-      (setf (buffer-modified hbuffer) nil)
-      (setf (buffer-writable hbuffer) nil)
-      (buffer-start (buffer-point hbuffer))
-      (change-to-buffer hbuffer))))
-
-(defhvar "MH Scan Line Form"
-  "This is a pathname of a file containing an MH format expression for headers
-   lines."
-  :value (pathname "/usr/misc/.lisp/lib/mh-scan"))
-
-;;; MESSAGE-HEADERS-TO-REGION uses the MH "scan" utility output headers into
-;;; buffer for folder and msgs.
-;;;
-;;; (value fill-column) should really be done as if the buffer were current,
-;;; but Hemlock doesn't let you do this without the buffer being current.
-;;;
-(defun message-headers-to-region (folder msgs &optional width)
-  (let ((region (make-empty-region)))
-    (with-output-to-mark (*standard-output* (region-end region) :full)
-      (mh "scan"
-	  `(,folder ,@msgs
-	    "-form" ,(namestring (value mh-scan-line-form))
-	    "-width" ,(number-string (or width (value fill-column)))
-	    "-noheader")))
-    region))
-
-(defun insert-message-headers (hbuffer hinfo region)
-  (ninsert-region (buffer-point hbuffer) region)
-  (let ((seq (set-message-headers-ids hbuffer :return-seq)))
-    (setf (headers-info-msg-seq hinfo) seq)
-    (setf (headers-info-msg-strings hinfo) (mh-sequence-strings seq)))
-  (when (value virtual-message-deletion)
-    (note-deleted-headers hbuffer
-			  (mh-sequence-list (headers-info-folder hinfo)
-					    "hemlockdeleted"))))
-
-(defun set-message-headers-ids (hbuffer &optional return-seq)
-  (let ((msgs nil))
-    (do-headers-lines (hbuffer :line-var line)
-      (let* ((line-str (line-string line))
-	     (num (parse-integer line-str :junk-allowed t)))
-	(declare (simple-string line-str))
-	(unless num
-	  (editor-error "MH scan lines must contain the message id as the ~
-	                 first thing on the line for the Hemlock interface."))
-	(setf (line-message-id line) (number-string num))
-	(when return-seq (setf msgs (mh-sequence-insert num msgs)))))
-    msgs))
-
-(defun note-deleted-headers (hbuffer deleted-seq)
-  (when deleted-seq
-    (do-headers-lines (hbuffer :line-var line :mark-var hmark)
-      (if (mh-sequence-member-p (line-message-id line) deleted-seq)
-	  (note-deleted-message-at-mark hmark)
-	  (setf (line-message-deleted line) nil)))))
-
-;;; PICK-MESSAGES  --  Internal Interface.
-;;;
-;;; This takes a folder (with a + in front of the name), messages to pick
-;;; over, and an MH pick expression (in the form returned by
-;;; PROMPT-FOR-PICK-EXPRESSION).  Sequence is an MH sequence to set to exactly
-;;; those messages chosen by the pick when zerop is non-nil; when zerop is nil,
-;;; pick adds the messages to the sequence along with whatever messages were
-;;; already in the sequence.  This returns a list of message specifications.
-;;;
-(defun pick-messages (folder msgs expression &optional sequence (zerop t))
-  (let* ((temp (with-output-to-string (*standard-output*)
-		 (unless
-		     ;; If someone bound *signal-mh-errors* to nil around this
-		     ;; function, MH pick outputs bogus messages (for example,
-		     ;; "0"), and MH would return without calling EDITOR-ERROR.
-		     (mh "pick" `(,folder
-				  ,@msgs
-				  ,@(if sequence `("-sequence" ,sequence))
-				  ,@(if zerop '("-zero"))
-				  "-list"	; -list must follow -sequence.
-				  ,@expression))
-		   (return-from pick-messages nil))))
-	 (len (length temp))
-	 (start 0)
-	 (result nil))
-    (declare (simple-string temp))
-    (loop
-      (let ((end (position #\newline temp :start start :test #'char=)))
-	(cond ((not end)
-	       (return (nreverse (cons (subseq temp start) result))))
-	      ((= start end)
-	       (return (nreverse result)))
-	      (t
-	       (push (subseq temp start end) result)
-	       (when (>= (setf start (1+ end)) len)
-		 (return (nreverse result)))))))))
-
-
-(defcommand "Delete Headers Buffer and Message Buffers" (p &optional buffer)
-  "Prompts for a headers buffer to delete along with its associated message
-   buffers.  Any associated draft buffers are left alone, but their associated
-   message buffers will be deleted."
-  "Deletes the current headers buffer and its associated message buffers."
-  (declare (ignore p))
-  (let* ((default (cond ((value headers-information) (current-buffer))
-			((value message-information) (value headers-buffer))))
-	 (buffer (or buffer
-		     (prompt-for-buffer :default default
-					:default-string
-					(if default (buffer-name default))))))
-    (unless (hemlock-bound-p 'headers-information :buffer buffer)
-      (editor-error "Not a headers buffer -- ~A" (buffer-name buffer)))
-    (let* ((hinfo (variable-value 'headers-information :buffer buffer))
-	   ;; Copy list since buffer cleanup hook is destructive.
-	   (other-bufs (copy-list (headers-info-other-msg-bufs hinfo)))
-	   (msg-buf (headers-info-msg-buffer hinfo)))
-      (when msg-buf (delete-buffer-if-possible msg-buf))
-      (dolist (b other-bufs) (delete-buffer-if-possible b))
-      (delete-buffer-if-possible (headers-info-buffer hinfo)))))
-
-(defhvar "Expunge Messages Confirm"
-  "When set (the default), \"Expunge Messages\" and \"Quit Headers\" will ask
-   for confirmation before expunging messages and packing the folder's message
-   id's."
-  :value t)
-
-(defhvar "Temporary Draft Folder"
-  "This is the folder name where MH fcc: messages are kept that are intended
-   to be deleted and expunged when messages are expunged for any other
-   folder -- \"Expunge Messages\" and \"Quit Headers\"."
-  :value nil)
-
-;;; "Quit Headers" doesn't expunge or compact unless there is a deleted
-;;; sequence.  This collapses other headers buffers into the same folder
-;;; differently than "Expunge Messages" since the latter assumes there will
-;;; always be one remaining headers buffer.  This command folds all headers
-;;; buffers into the folder that are not the current buffer or the new mail
-;;; buffer into one buffer.  When the current buffer is the new mail buffer
-;;; we do not check for more unseen headers since we are about to delete
-;;; the buffer anyway.  The other headers buffers must be deleted before
-;;; making the new one due to aliasing the buffer structure and
-;;; MAYBE-MAKE-MH-BUFFER.
-;;;
-(defcommand "Quit Headers" (p)
-  "Quit headers buffer possibly expunging deleted messages.
-   This affects the current headers buffer.  When there are deleted messages
-   the user is asked for confirmation on expunging the messages and packing the
-   folder's message id's.  Then the buffer and all its associated message
-   buffers are deleted.  Setting \"Quit Headers Confirm\" to nil inhibits
-   prompting.  When \"Temporary Draft Folder\" is bound, this folder's messages
-   are deleted and expunged."
-  "This affects the current headers buffer.  When there are deleted messages
-   the user is asked for confirmation on expunging the messages and packing
-   the folder.  Then the buffer and all its associated message buffers are
-   deleted."
-  (declare (ignore p))
-  (let* ((hinfo (value headers-information))
-	 (minfo (value message-information))
-	 (hdrs-buf (cond (hinfo (current-buffer))
-			 (minfo (value headers-buffer)))))
-    (unless hdrs-buf
-      (editor-error "Not in or associated with any headers buffer."))
-    (let* ((folder (cond (hinfo (headers-info-folder hinfo))
-			 (minfo (message-info-folder minfo))))
-	   (deleted-seq (mh-sequence-list folder "hemlockdeleted")))
-      (when (and deleted-seq
-		 (or (not (value expunge-messages-confirm))
-		     (prompt-for-y-or-n
-		      :prompt (list "Expunge messages and pack folder ~A? "
-				    folder)
-		      :default t
-		      :default-string "Y")))
-	(message "Deleting messages ...")
-	(mh "rmm" (list folder "hemlockdeleted"))
-	(let ((*standard-output* *mh-utility-bit-bucket*))
-	  (message "Compacting folder ...")
-	  (mh "folder" (list folder "-fast" "-pack")))
-	(message "Maintaining consistency ...")
-	(let (hbufs)
-	  (declare (list hbufs))
-	  (do-headers-buffers (b folder)
-	    (unless (or (eq b hdrs-buf) (eq b *new-mail-buffer*))
-	      (push b hbufs)))
-	  (dolist (b hbufs)
-	    (delete-headers-buffer-and-message-buffers-command nil b))
-	  (when hbufs
-	    (new-message-headers folder (list "all"))))
-	(expunge-messages-fix-draft-buffers folder)
-	(unless (eq hdrs-buf *new-mail-buffer*)
-	  (expunge-messages-fix-unseen-headers folder))
-	(delete-and-expunge-temp-drafts)))
-    (delete-headers-buffer-and-message-buffers-command nil hdrs-buf)))
-
-;;; DELETE-AND-EXPUNGE-TEMP-DRAFTS deletes all the messages in the
-;;; temporary draft folder if there is one defined.  Any headers buffers
-;;; into this folder are deleted with their message buffers.  We have to
-;;; create a list of buffers to delete since buffer deletion destructively
-;;; modifies the same list DO-HEADERS-BUFFERS uses.  "rmm" is run without
-;;; error reporting since it signals an error if there are no messages to
-;;; delete.  This function must return; for example, "Quit Headers" would
-;;; not complete successfully if this ended up calling EDITOR-ERROR.
-;;;
-(defun delete-and-expunge-temp-drafts ()
-  (let ((temp-draft-folder (value temporary-draft-folder)))
-    (when temp-draft-folder
-      (setf temp-draft-folder (coerce-folder-name temp-draft-folder))
-      (message "Deleting and expunging temporary drafts ...")
-      (when (mh "rmm" (list temp-draft-folder "all") :errorp nil)
-	(let (hdrs)
-	  (declare (list hdrs))
-	  (do-headers-buffers (b temp-draft-folder)
-	    (push b hdrs))
-	  (dolist (b hdrs)
-	    (delete-headers-buffer-and-message-buffers-command nil b)))))))
-
-
-
-;;;; Message Mode.
-
-(defmode "Message" :major-p t)
-
-(defhvar "Message Information"
-  "This holds the information about the current message buffer."
-  :value nil)
-
-(defstruct message/draft-info
-  headers-mark)		;Mark pointing to a headers line in a headers buffer.
-
-(defstruct (message-info (:include message/draft-info)
-			 (:print-function print-message-info))
-  folder		;String name of folder with leading MH "+".
-  msgs			;List of strings representing messages to be shown.
-  draft-buf		;Possible draft buffer reference.
-  keep)			;Whether message buffer may be re-used.
-
-(defun print-message-info (obj str n)
-  (declare (ignore n))
-  (format str "#<Message Info ~S ~S>"
-	  (message-info-folder obj) (message-info-msgs obj)))
-
-
-(defcommand "Next Message" (p)
-  "Show the next message.
-   When in a message buffer, shows the next message in the associated headers
-   buffer.  When in a headers buffer, moves point down a line and shows that
-   message."
-  "When in a message buffer, shows the next message in the associated headers
-   buffer.  When in a headers buffer, moves point down a line and shows that
-   message."
-  (declare (ignore p))
-  (show-message-offset 1))
-
-(defcommand "Previous Message" (p)
-  "Show the previous message.
-   When in a message buffer, shows the previous message in the associated
-   headers buffer.  When in a headers buffer, moves point up a line and shows
-   that message."
-  "When in a message buffer, shows the previous message in the associated
-   headers buffer.  When in a headers buffer, moves point up a line and
-   shows that message."
-  (declare (ignore p))
-  (show-message-offset -1))
-
-(defcommand "Next Undeleted Message" (p)
-  "Show the next undeleted message.
-   When in a message buffer, shows the next undeleted message in the associated
-   headers buffer.  When in a headers buffer, moves point down to a line
-   without a deleted message and shows that message."
-  "When in a message buffer, shows the next undeleted message in the associated
-   headers buffer.  When in a headers buffer, moves point down to a line without
-   a deleted message and shows that message."
-  (declare (ignore p))
-  (show-message-offset 1 :undeleted))
-
-(defcommand "Previous Undeleted Message" (p)
-  "Show the previous undeleted message.
-   When in a message buffer, shows the previous undeleted message in the
-   associated headers buffer.  When in a headers buffer, moves point up a line
-   without a deleted message and shows that message."
-  "When in a message buffer, shows the previous undeleted message in the
-   associated headers buffer.  When in a headers buffer, moves point up a line
-   without a deleted message and shows that message."
-  (declare (ignore p))
-  (show-message-offset -1 :undeleted))
-
-(defun show-message-offset (offset &optional undeleted)
-  (let ((minfo (value message-information)))
-    (cond
-     ((not minfo)
-      (let ((hinfo (value headers-information)))
-	(unless hinfo (editor-error "Not in a message or headers buffer."))
-	(show-message-offset-hdrs-buf hinfo offset undeleted)))
-     ((message-info-keep minfo)
-      (let ((hbuf (value headers-buffer)))
-	(unless hbuf (editor-error "Not associated with a headers buffer."))
-	(let ((hinfo (variable-value 'headers-information :buffer hbuf))
-	      (point (buffer-point hbuf)))
-	  (move-mark point (message-info-headers-mark minfo))
-	  (show-message-offset-hdrs-buf hinfo offset undeleted))))
-     (t
-      (show-message-offset-msg-buf minfo offset undeleted)))))
-
-(defun show-message-offset-hdrs-buf (hinfo offset undeleted)
-  (unless hinfo (editor-error "Not in a message or headers buffer."))
-  (unless (show-message-offset-mark (buffer-point (headers-info-buffer hinfo))
-				    offset undeleted)
-    (editor-error "No ~:[previous~;next~] ~:[~;undeleted ~]message."
-		  (plusp offset) undeleted))
-  (show-headers-message hinfo))
-
-(defun show-message-offset-msg-buf (minfo offset undeleted)
-  (let ((msg-mark (message-info-headers-mark minfo)))
-    (unless msg-mark (editor-error "Not associated with a headers buffer."))
-    (unless (show-message-offset-mark msg-mark offset undeleted)
-      (let ((hbuf (value headers-buffer))
-	    (mbuf (current-buffer)))
-	(setf (current-buffer) hbuf)
-	(setf (window-buffer (current-window)) hbuf)
-	(delete-buffer-if-possible mbuf))
-      (editor-error "No ~:[previous~;next~] ~:[~;undeleted ~]message."
-		    (plusp offset) undeleted))
-    (move-mark (buffer-point (line-buffer (mark-line msg-mark))) msg-mark)
-    (let* ((next-msg (line-message-id (mark-line msg-mark)))
-	   (folder (message-info-folder minfo))
-	   (mbuffer (current-buffer)))
-      (with-writable-buffer (mbuffer)
-	(delete-region (buffer-region mbuffer))
-	(setf (buffer-name mbuffer) (get-storable-msg-buf-name folder next-msg))
-	(setf (message-info-msgs minfo) next-msg)
-	(read-mh-file (merge-pathnames next-msg
-				       (merge-relative-pathnames
-					(strip-folder-name folder)
-					(mh-directory-pathname)))
-		      mbuffer)
-	(let ((unseen-seq (mh-profile-component "unseen-sequence")))
-	  (when unseen-seq
-	    (mark-one-message folder next-msg unseen-seq :delete))))))
-  (let ((dbuffer (message-info-draft-buf minfo)))
-    (when dbuffer
-      (delete-variable 'message-buffer :buffer dbuffer)
-      (setf (message-info-draft-buf minfo) nil))))
-
-(defun get-storable-msg-buf-name (folder msg)
-  (let ((name (format nil "Message ~A ~A" folder msg)))
-    (if (not (getstring name *buffer-names*))
-	name
-	(let ((n 2))
-	  (loop
-	    (setf name (format nil "Message ~A ~A copy ~D" folder msg n))
-	    (unless (getstring name *buffer-names*)
-	      (return name))
-	    (incf n))))))
-
-(defun show-message-offset-mark (msg-mark offset undeleted)
-  (with-mark ((temp msg-mark))
-    (let ((winp 
-	   (cond (undeleted
-		  (loop
-		    (unless (and (line-offset temp offset 0)
-				 (not (blank-line-p (mark-line temp))))
-		      (return nil))
-		    (unless (line-message-deleted (mark-line temp))
-		      (return t))))
-		 ((and (line-offset temp offset 0)
-		       (not (blank-line-p (mark-line temp)))))
-		 (t nil))))
-      (if winp (move-mark msg-mark temp)))))
-
-
-(defcommand "Show Message" (p)
-  "Shows the current message.
-   Prompts for a folder and message(s), displaying this in the current window.
-   When invoked in a headers buffer, shows the message on the current line."
-  "Show a message."
-  (declare (ignore p))
-  (let ((hinfo (value headers-information)))
-    (if hinfo
-	(show-headers-message hinfo)
-	(let ((folder (prompt-for-folder)))
-	  (show-prompted-message folder (prompt-for-message :folder folder))))))
-
-;;; SHOW-HEADERS-MESSAGE shows the current message for hinfo.  If there is a
-;;; main message buffer, clobber it, and we don't have to deal with kept
-;;; messages or draft associations since those operations should have moved
-;;; the message buffer into the others list.  Remove the message from the
-;;; unseen sequence, and make sure the message buffer is displayed in some
-;;; window.
-;;;
-(defun show-headers-message (hinfo)
-  (multiple-value-bind (cur-msg cur-mark)
-		       (headers-current-message hinfo)
-    (unless cur-msg (editor-error "Not on a header line."))
-    (let* ((mbuffer (headers-info-msg-buffer hinfo))
-	   (folder (headers-info-folder hinfo))
-	   (buf-name (get-storable-msg-buf-name folder cur-msg))
-	   (writable nil))
-      (cond (mbuffer
-	     (setf (buffer-name mbuffer) buf-name)
-	     (setf writable (buffer-writable mbuffer))
-	     (setf (buffer-writable mbuffer) t)
-	     (delete-region (buffer-region mbuffer))
-	     (let ((minfo (variable-value 'message-information :buffer mbuffer)))
-	       (move-mark (message-info-headers-mark minfo) cur-mark)
-	       (delete-mark cur-mark)
-	       (setf (message-info-msgs minfo) cur-msg)))
-	    (t (setf mbuffer (maybe-make-mh-buffer buf-name :message))
-	       (setf (headers-info-msg-buffer hinfo) mbuffer)
-	       (defhvar "Message Information"
-		 "This holds the information about the current headers buffer."
-		 :value (make-message-info :folder folder
-					   :msgs cur-msg
-					   :headers-mark cur-mark)
-		 :buffer mbuffer)
-	       (defhvar "Headers Buffer"
-		 "This is bound in message and draft buffers to their
-		  associated headers buffer."
-		 :value (headers-info-buffer hinfo) :buffer mbuffer)))
-      (read-mh-file (merge-pathnames
-		     cur-msg
-		     (merge-relative-pathnames (strip-folder-name folder)
-					       (mh-directory-pathname)))
-		    mbuffer)
-      (setf (buffer-writable mbuffer) writable)
-      (let ((unseen-seq (mh-profile-component "unseen-sequence")))
-	(when unseen-seq (mark-one-message folder cur-msg unseen-seq :delete)))
-      (get-message-buffer-window mbuffer))))
-    
-;;; SHOW-PROMPTED-MESSAGE takes an arbitrary message spec and blasts those
-;;; messages into a message buffer.  First we pick the message to get them
-;;; individually specified as normalized message ID's -- all integers and
-;;; no funny names such as "last".
-;;;
-(defun show-prompted-message (folder msgs)
-  (let* ((msgs (pick-messages folder msgs nil))
-	 (mbuffer (maybe-make-mh-buffer (format nil "Message ~A ~A" folder msgs)
-					:message)))
-    (defhvar "Message Information"
-      "This holds the information about the current headers buffer."
-      :value (make-message-info :folder folder :msgs msgs)
-      :buffer mbuffer)
-    (let ((*standard-output* (make-hemlock-output-stream (buffer-point mbuffer)
-							 :full)))
-      (mh "show" `(,folder ,@msgs "-noshowproc" "-noheader"))
-      (setf (buffer-modified mbuffer) nil))
-    (buffer-start (buffer-point mbuffer))
-    (setf (buffer-writable mbuffer) nil)
-    (get-message-buffer-window mbuffer)))
-
-;;; GET-MESSAGE-BUFFER-WINDOW currently just changes to buffer, unless buffer
-;;; has any windows, in which case it uses the first one.  It could prompt for
-;;; a window, split the current window, split the current window or use the
-;;; next one if there is one, funcall an Hvar.  It could take a couple
-;;; arguments to control its behaviour.  Whatever.
-;;;
-(defun get-message-buffer-window (mbuffer)
-  (let ((wins (buffer-windows mbuffer)))
-    (cond (wins
-	   (setf (current-buffer) mbuffer)
-	   (setf (current-window) (car wins)))
-	  (t (change-to-buffer mbuffer)))))
-
-
-(defhvar "Scroll Message Showing Next"
-  "When this is set, \"Scroll Message\" shows the next message when the end
-   of the current message is visible."
-  :value t)
-
-(defcommand "Scroll Message" (p)
-  "Scroll the current window down through the current message.
-   If the end of the message is visible, then show the next undeleted message
-   if \"Scroll Message Showing Next\" is non-nil."
-  "Scroll the current window down through the current message."
-  (if (and (not p)
-	   (displayed-p (buffer-end-mark (current-buffer)) (current-window))
-	   (value scroll-message-showing-next))
-      (show-message-offset 1 :undeleted)
-      (scroll-window-down-command p)))
-
-
-(defcommand "Keep Message" (p)
-  "Keeps the current message buffer from being re-used.  Also, if the buffer
-   would be deleted due to a draft completion, it will not be."
-  "Keeps the current message buffer from being re-used.  Also, if the buffer
-   would be deleted due to a draft completion, it will not be."
-  (declare (ignore p))
-  (let ((minfo (value message-information)))
-    (unless minfo (editor-error "Not in a message buffer."))
-    (let ((hbuf (value headers-buffer)))
-      (when hbuf
-	(let ((mbuf (current-buffer))
-	      (hinfo (variable-value 'headers-information :buffer hbuf)))
-	  (when (eq (headers-info-msg-buffer hinfo) mbuf)
-	    (setf (headers-info-msg-buffer hinfo) nil)
-	    (push mbuf (headers-info-other-msg-bufs hinfo))))))
-    (setf (message-info-keep minfo) t)))
-
-(defcommand "Edit Message Buffer" (p)
-  "Recursively edit message buffer.
-   Puts the current message buffer into \"Text\" mode allowing modifications in
-   a recursive edit.  While in this state, the buffer is associated with the
-   pathname of the message, so saving the file is possible."
-  "Puts the current message buffer into \"Text\" mode allowing modifications in
-   a recursive edit.  While in this state, the buffer is associated with the
-   pathname of the message, so saving the file is possible."
-  (declare (ignore p))
-  (let* ((minfo (value message-information)))
-    (unless minfo (editor-error "Not in a message buffer."))
-    (let* ((msgs (message-info-msgs minfo))
-	   (mbuf (current-buffer))
-	   (mbuf-name (buffer-name mbuf))
-	   (writable (buffer-writable mbuf))
-	   (abortp t))
-      (when (consp msgs)
-	(editor-error
-	 "There appears to be more than one message in this buffer."))
-      (unwind-protect
-	  (progn
-	    (setf (buffer-writable mbuf) t)
-	    (setf (buffer-pathname mbuf)
-		  (merge-pathnames
-		   msgs
-		   (merge-relative-pathnames
-		    (strip-folder-name (message-info-folder minfo))
-		    (mh-directory-pathname))))
-	    (setf (buffer-major-mode mbuf) "Text")
-	    (do-recursive-edit)
-	    (setf abortp nil))
-	(when (and (not abortp)
-		   (buffer-modified mbuf)
-		   (prompt-for-y-or-n
-		    :prompt "Message buffer modified, save it? "
-		    :default t))
-	  (save-file-command nil mbuf))
-	(setf (buffer-modified mbuf) nil)
-	;; "Save File", which the user may have used, changes the buffer's name.
-	(unless (getstring mbuf-name *buffer-names*)
-	  (setf (buffer-name mbuf) mbuf-name))
-	(setf (buffer-writable mbuf) writable)
-	(setf (buffer-pathname mbuf) nil)
-	(setf (buffer-major-mode mbuf) "Message")))))
-
-
-
-;;;; Draft Mode.
-
-(defmode "Draft")
-
-(defhvar "Draft Information"
-  "This holds the information about the current draft buffer."
-  :value nil)
-
-(defstruct (draft-info (:include message/draft-info)
-		       (:print-function print-draft-info))
-  folder		;String name of draft folder with leading MH "+".
-  message		;String id of draft folder message.
-  pathname		;Pathname of draft in the draft folder directory.
-  delivered		;This is set when the draft was really sent.
-  replied-to-folder	;Folder of message draft is in reply to.
-  replied-to-msg)	;Message draft is in reply to.
-
-(defun print-draft-info (obj str n)
-  (declare (ignore n))
-  (format str "#<Draft Info ~A>" (draft-info-message obj)))
-
-
-(defhvar "Reply to Message Prefix Action"
-  "This is one of :cc-all, :no-cc-all, or nil.  When an argument is supplied to
-   \"Reply to Message\", this value determines how arguments passed to the
-   MH utility."
-  :value nil)
-
-(defcommand "Reply to Message" (p)
-  "Sets up a draft in reply to the current message.
-   Prompts for a folder and message to reply to.  When in a headers buffer,
-   replies to the message on the current line.  When in a message buffer,
-   replies to that message.  With an argument, regard \"Reply to Message Prefix
-   Action\" for carbon copy arguments to the MH utility."
-  "Prompts for a folder and message to reply to.  When in a headers buffer,
-   replies to the message on the current line.  When in a message buffer,
-   replies to that message."
-  (let ((hinfo (value headers-information))
-	(minfo (value message-information)))
-    (cond (hinfo
-	   (multiple-value-bind (cur-msg cur-mark)
-				(headers-current-message hinfo)
-	     (unless cur-msg (editor-error "Not on a header line."))
-	     (setup-reply-draft (headers-info-folder hinfo)
-				cur-msg hinfo cur-mark p)))
-	  (minfo
-	   (setup-message-buffer-draft (current-buffer) minfo :reply p))
-	  (t
-	   (let ((folder (prompt-for-folder)))
-	     (setup-reply-draft folder
-				(car (prompt-for-message :folder folder))
-				nil nil p))))))
-
-;;; SETUP-REPLY-DRAFT takes a folder and msg to draft a reply to.  Optionally,
-;;; a headers buffer and mark are associated with the draft.  First, the draft
-;;; buffer is associated with the headers buffer if there is one.  Then the
-;;; message buffer is created and associated with the drafter buffer and
-;;; headers buffer.  Argument may be used to pass in the argument from the
-;;; command.
-;;;
-(defun setup-reply-draft (folder msg &optional hinfo hmark argument)
-  (let* ((dbuffer (sub-setup-message-draft
-		   "repl" :end-of-buffer
-		   `(,folder ,msg
-			     ,@(if argument
-				   (case (value reply-to-message-prefix-action)
-				     (:no-cc-all '("-nocc" "all"))
-				     (:cc-all '("-cc" "all")))))))
-	 (dinfo (variable-value 'draft-information :buffer dbuffer))
-	 (h-buf (if hinfo (headers-info-buffer hinfo))))
-    (setf (draft-info-replied-to-folder dinfo) folder)
-    (setf (draft-info-replied-to-msg dinfo) msg)
-    (when h-buf
-      (defhvar "Headers Buffer"
-	"This is bound in message and draft buffers to their associated
-	headers buffer."
-	:value h-buf :buffer dbuffer)
-      (setf (draft-info-headers-mark dinfo) hmark)
-      (push dbuffer (headers-info-draft-bufs hinfo)))
-    (let ((msg-buf (maybe-make-mh-buffer (format nil "Message ~A ~A" folder msg)
-					 :message)))
-      (defhvar "Message Information"
-	"This holds the information about the current headers buffer."
-	:value (make-message-info :folder folder :msgs msg
-				  :headers-mark
-				  (if h-buf (copy-mark hmark) hmark)
-				  :draft-buf dbuffer)
-	:buffer msg-buf)
-      (when h-buf
-	(defhvar "Headers Buffer"
-	  "This is bound in message and draft buffers to their associated
-	  headers buffer."
-	  :value h-buf :buffer msg-buf)
-	(push msg-buf (headers-info-other-msg-bufs hinfo)))
-      (read-mh-file (merge-pathnames
-		     msg
-		     (merge-relative-pathnames (strip-folder-name folder)
-					       (mh-directory-pathname)))
-		    msg-buf)
-      (setf (buffer-writable msg-buf) nil)
-      (defhvar "Message Buffer"
-	"This is bound in draft buffers to their associated message buffer."
-	:value msg-buf :buffer dbuffer))
-    (get-draft-buffer-window dbuffer)))
-
-
-(defcommand "Forward Message" (p)
-  "Forward current message.
-   Prompts for a folder and message to forward.  When in a headers buffer,
-   forwards the message on the current line.  When in a message buffer,
-   forwards that message."
-  "Prompts for a folder and message to reply to.  When in a headers buffer,
-   replies to the message on the current line.  When in a message buffer,
-   replies to that message."
-  (declare (ignore p))
-  (let ((hinfo (value headers-information))
-	(minfo (value message-information)))
-    (cond (hinfo
-	   (multiple-value-bind (cur-msg cur-mark)
-				(headers-current-message hinfo)
-	     (unless cur-msg (editor-error "Not on a header line."))
-	     (setup-forward-draft (headers-info-folder hinfo)
-				  cur-msg hinfo cur-mark)))
-	  (minfo
-	   (setup-message-buffer-draft (current-buffer) minfo :forward))
-	  (t
-	   (let ((folder (prompt-for-folder)))
-	     (setup-forward-draft folder
-				  (car (prompt-for-message :folder folder))))))))
-
-;;; SETUP-FORWARD-DRAFT sets up a draft forwarding folder's msg.  When there
-;;; is a headers buffer involved (hinfo and hmark), the draft is associated
-;;; with it.
-;;;
-;;; This function is like SETUP-REPLY-DRAFT (in addition to "forw" and
-;;; :to-field), but it does not setup a message buffer.  If this is added as
-;;; something forward drafts want, then SETUP-REPLY-DRAFT should be
-;;; parameterized and renamed.
-;;;
-(defun setup-forward-draft (folder msg &optional hinfo hmark)
-  (let* ((dbuffer (sub-setup-message-draft "forw" :to-field
-					   (list folder msg)))
-	 (dinfo (variable-value 'draft-information :buffer dbuffer))
-	 (h-buf (if hinfo (headers-info-buffer hinfo))))
-    (when h-buf
-      (defhvar "Headers Buffer"
-	"This is bound in message and draft buffers to their associated
-	headers buffer."
-	:value h-buf :buffer dbuffer)
-      (setf (draft-info-headers-mark dinfo) hmark)
-      (push dbuffer (headers-info-draft-bufs hinfo)))
-    (get-draft-buffer-window dbuffer)))
-
-
-(defcommand "Send Message" (p)
-  "Setup a draft buffer.
-   Setup a draft buffer, reserving a draft folder message.  When invoked in a
-   headers buffer, the current message is available in an associated message
-   buffer."
-  "Setup a draft buffer, reserving a draft folder message.  When invoked in
-   a headers buffer, the current message is available in an associated
-   message buffer."
-  (declare (ignore p))
-  (let ((hinfo (value headers-information))
-	(minfo (value message-information)))
-    (cond (hinfo (setup-headers-message-draft hinfo))
-	  (minfo (setup-message-buffer-draft (current-buffer) minfo :compose))
-	  (t (setup-message-draft)))))
-
-(defun setup-message-draft ()
-  (get-draft-buffer-window (sub-setup-message-draft "comp" :to-field)))
-
-;;; SETUP-HEADERS-MESSAGE-DRAFT sets up a draft buffer associated with a
-;;; headers buffer and a message buffer.  The headers current message is
-;;; inserted in the message buffer which is also associated with the headers
-;;; buffer.  The draft buffer is associated with the message buffer.
-;;;
-(defun setup-headers-message-draft (hinfo)
-  (multiple-value-bind (cur-msg cur-mark)
-		       (headers-current-message hinfo)
-    (unless cur-msg (message "Draft not associated with any message."))
-    (let* ((dbuffer (sub-setup-message-draft "comp" :to-field))
-	   (dinfo (variable-value 'draft-information :buffer dbuffer))
-	   (h-buf (headers-info-buffer hinfo)))
-      (when cur-msg
-	(defhvar "Headers Buffer"
-	  "This is bound in message and draft buffers to their associated headers
-	  buffer."
-	  :value h-buf :buffer dbuffer)
-	(push dbuffer (headers-info-draft-bufs hinfo)))
-      (when cur-msg
-	(setf (draft-info-headers-mark dinfo) cur-mark)
-	(let* ((folder (headers-info-folder hinfo))
-	       (msg-buf (maybe-make-mh-buffer
-			 (format nil "Message ~A ~A" folder cur-msg)
-			 :message)))
-	  (defhvar "Message Information"
-	    "This holds the information about the current headers buffer."
-	    :value (make-message-info :folder folder :msgs cur-msg
-				      :headers-mark (copy-mark cur-mark)
-				      :draft-buf dbuffer)
-	    :buffer msg-buf)
-	  (defhvar "Headers Buffer"
-	    "This is bound in message and draft buffers to their associated
-	     headers buffer."
-	    :value h-buf :buffer msg-buf)
-	  (push msg-buf (headers-info-other-msg-bufs hinfo))
-	  (read-mh-file (merge-pathnames
-			 cur-msg
-			 (merge-relative-pathnames (strip-folder-name folder)
-						   (mh-directory-pathname)))
-			msg-buf)
-	  (setf (buffer-writable msg-buf) nil)
-	  (defhvar "Message Buffer"
-	    "This is bound in draft buffers to their associated message buffer."
-	    :value msg-buf :buffer dbuffer)))
-      (get-draft-buffer-window dbuffer))))
-
-;;; SETUP-MESSAGE-BUFFER-DRAFT takes a message buffer and its message
-;;; information.  A draft buffer is created according to type, and the two
-;;; buffers are associated.  Any previous association of the message buffer and
-;;; a draft buffer is dropped.  Any association between the message buffer and
-;;; a headers buffer is propagated to the draft buffer, and if the message
-;;; buffer is the headers buffer's main message buffer, it is moved to "other"
-;;; status.  Argument may be used to pass in the argument from the command.
-;;;
-(defun setup-message-buffer-draft (msg-buf minfo type &optional argument)
-  (let* ((msgs (message-info-msgs minfo))
-	 (cur-msg (if (consp msgs) (car msgs) msgs))
-	 (folder (message-info-folder minfo))
-	 (dbuffer
-	  (ecase type
-	    (:reply
-	     (sub-setup-message-draft
-	      "repl" :end-of-buffer
-	      `(,folder ,cur-msg
-			,@(if argument
-			      (case (value reply-to-message-prefix-action)
-				(:no-cc-all '("-nocc" "all"))
-				(:cc-all '("-cc" "all")))))))
-	    (:compose
-	     (sub-setup-message-draft "comp" :to-field))
-	    (:forward
-	     (sub-setup-message-draft "forw" :to-field
-				      (list folder cur-msg)))))
-	 (dinfo (variable-value 'draft-information :buffer dbuffer)))
-    (when (message-info-draft-buf minfo)
-      (delete-variable 'message-buffer :buffer (message-info-draft-buf minfo)))
-    (setf (message-info-draft-buf minfo) dbuffer)
-    (when (eq type :reply)
-      (setf (draft-info-replied-to-folder dinfo) folder)
-      (setf (draft-info-replied-to-msg dinfo) cur-msg))
-    (when (hemlock-bound-p 'headers-buffer :buffer msg-buf)
-      (let* ((hbuf (variable-value 'headers-buffer :buffer msg-buf))
-	     (hinfo (variable-value 'headers-information :buffer hbuf)))
-	(defhvar "Headers Buffer"
-	  "This is bound in message and draft buffers to their associated
-	  headers buffer."
-	  :value hbuf :buffer dbuffer)
-	(setf (draft-info-headers-mark dinfo)
-	      (copy-mark (message-info-headers-mark minfo)))
-	(push dbuffer (headers-info-draft-bufs hinfo))
-	(when (eq (headers-info-msg-buffer hinfo) msg-buf)
-	  (setf (headers-info-msg-buffer hinfo) nil)
-	  (push msg-buf (headers-info-other-msg-bufs hinfo)))))
-    (defhvar "Message Buffer"
-      "This is bound in draft buffers to their associated message buffer."
-      :value msg-buf :buffer dbuffer)
-    (get-draft-buffer-window dbuffer)))
-
-(defvar *draft-to-pattern*
-  (new-search-pattern :string-insensitive :forward "To:"))
-
-(defun sub-setup-message-draft (utility point-action &optional args)
-  (mh utility `(,@args "-nowhatnowproc"))
-  (let* ((folder (mh-draft-folder))
-	 (draft-msg (mh-current-message folder))
-	 (msg-pn (merge-pathnames draft-msg (mh-draft-folder-pathname)))
-	 (dbuffer (maybe-make-mh-buffer (format nil "Draft ~A" draft-msg)
-				     :draft)))
-    (read-mh-file msg-pn dbuffer)
-    (setf (buffer-pathname dbuffer) msg-pn)
-    (defhvar "Draft Information"
-      "This holds the information about the current draft buffer."
-      :value (make-draft-info :folder (coerce-folder-name folder)
-			      :message draft-msg
-			      :pathname msg-pn)
-      :buffer dbuffer)
-    (let ((point (buffer-point dbuffer)))
-      (ecase point-action
-	(:to-field
-	 (when (find-pattern point *draft-to-pattern*)
-	   (line-end point)))
-	(:end-of-buffer (buffer-end point))))
-    dbuffer))
-
-(defun read-mh-file (pathname buffer)
-  (unless (probe-file pathname)
-    (editor-error "No such message -- ~A" (namestring pathname)))
-  (read-file pathname (buffer-point buffer))
-  (setf (buffer-write-date buffer) (file-write-date pathname))
-  (buffer-start (buffer-point buffer))
-  (setf (buffer-modified buffer) nil))
-
-
-(defvar *draft-buffer-window-fun* 'change-to-buffer
-  "This is called by GET-DRAFT-BUFFER-WINDOW to display a new draft buffer.
-   The default is CHANGE-TO-BUFFER which uses the current window.")
-
-;;; GET-DRAFT-BUFFER-WINDOW is called to display a new draft buffer.
-;;;
-(defun get-draft-buffer-window (dbuffer)
-  (funcall *draft-buffer-window-fun* dbuffer))
-
-
-(defcommand "Reply to Message in Other Window" (p)
-  "Reply to message, creating another window for draft buffer.
-   Prompts for a folder and message to reply to.  When in a headers buffer,
-   replies to the message on the current line.  When in a message buffer,
-   replies to that message.  The current window is split displaying the draft
-   buffer in the new window and the message buffer in the current."
-  "Prompts for a folder and message to reply to.  When in a headers buffer,
-   replies to the message on the current line.  When in a message buffer,
-   replies to that message."
-  (let ((*draft-buffer-window-fun* #'draft-buffer-in-other-window))
-    (reply-to-message-command p)))
-
-(defun draft-buffer-in-other-window (dbuffer)
-  (when (hemlock-bound-p 'message-buffer :buffer dbuffer)
-    (let ((mbuf (variable-value 'message-buffer :buffer dbuffer)))
-      (when (not (eq (current-buffer) mbuf))
-	(change-to-buffer mbuf))))
-  (setf (current-buffer) dbuffer)
-  (setf (current-window) (make-window (buffer-start-mark dbuffer)))
-  (defhvar "Split Window Draft"
-    "Indicates window needs to be cleaned up for draft."
-    :value t :buffer dbuffer))
-
-(defhvar "Deliver Message Confirm"
-  "When set, \"Deliver Message\" will ask for confirmation before sending the
-   draft.  This is off by default since \"Deliver Message\" is not bound to
-   any key by default."
-  :value t)
-
-(defcommand "Deliver Message" (p)
-  "Save and deliver the current draft buffer.
-   When in a draft buffer, this saves the file and uses SEND to deliver the
-   draft.  Otherwise, this prompts for a draft message id, invoking SEND."
-  "When in a draft buffer, this saves the file and uses SEND to deliver the
-   draft.  Otherwise, this prompts for a draft message id, invoking SEND."
-  (declare (ignore p))
-  (let ((dinfo (value draft-information)))
-    (cond (dinfo
-	   (deliver-draft-buffer-message dinfo))
-	  (t
-	   (let* ((folder (coerce-folder-name (mh-draft-folder)))
-		  (msg (prompt-for-message :folder folder)))
-	     (mh "send" `("-draftfolder" ,folder "-draftmessage" ,@msg)))))))
-
-(defun deliver-draft-buffer-message (dinfo)
-  (when (draft-info-delivered dinfo)
-    (editor-error "This draft has already been delivered."))
-  (when (or (not (value deliver-message-confirm))
-	    (prompt-for-y-or-n :prompt "Deliver message? " :default t))
-    (let ((dbuffer (current-buffer)))
-      (when (buffer-modified dbuffer)
-	(write-buffer-file dbuffer (buffer-pathname dbuffer)))
-      (message "Delivering draft ...")
-      (mh "send" `("-draftfolder" ,(draft-info-folder dinfo)
-		   "-draftmessage" ,(draft-info-message dinfo)))
-      (setf (draft-info-delivered dinfo) t)
-      (let ((replied-folder (draft-info-replied-to-folder dinfo))
-	    (replied-msg (draft-info-replied-to-msg dinfo)))
-	(when replied-folder
-	  (message "Annotating message being replied to ...")
-	  (mh "anno" `(,replied-folder ,replied-msg "-component" "replied"))
-	  (do-headers-buffers (hbuf replied-folder)
-	    (with-headers-mark (hmark hbuf replied-msg)
-	      (mark-to-note-replied-msg hmark)
-	      (with-writable-buffer (hbuf)
-		(setf (next-character hmark) #\A))))
-	  (dolist (b *buffer-list*)
-	    (when (and (hemlock-bound-p 'message-information :buffer b)
-		       (buffer-modeline-field-p b :replied-to-message))
-	      (dolist (w (buffer-windows b))
-		(update-modeline-field b w :replied-to-message))))))
-      (maybe-delete-extra-draft-window dbuffer (current-window))
-      (let* ((mbuf (value message-buffer))
-	     (minfo (if mbuf
-			(variable-value 'message-information :buffer mbuf))))
-	(when (and minfo (not (message-info-keep minfo)))
-	  (delete-buffer-if-possible mbuf)))
-      (delete-buffer-if-possible dbuffer))))
-
-(defcommand "Delete Draft and Buffer" (p)
-  "Delete the current draft message and buffer."
-  "Delete the current draft message and buffer."
-  (declare (ignore p))
-  (let ((dinfo (value draft-information))
-	(dbuffer (current-buffer)))
-    (unless dinfo (editor-error "No draft associated with buffer."))
-    (maybe-delete-extra-draft-window dbuffer (current-window))
-    (delete-file (draft-info-pathname dinfo))
-    (let* ((mbuf (value message-buffer))
-	   (minfo (if mbuf
-		      (variable-value 'message-information :buffer mbuf))))
-      (when (and minfo (not (message-info-keep minfo)))
-	(delete-buffer-if-possible mbuf)))
-    (delete-buffer-if-possible dbuffer)))
-
-;;; MAYBE-DELETE-EXTRA-DRAFT-WINDOW takes a draft buffer and a window into it
-;;; that should not be deleted.  If "Split Window Draft" is bound in the buffer,
-;;; and there are more than two windows (two windows plus the echo area at
-;;; least), then we delete some window if it is not the dbuffer-window or the
-;;; echo area window.  Blow away the variable, so we don't think this is still
-;;; a split window draft buffer.
-;;;
-(defun maybe-delete-extra-draft-window (dbuffer dbuffer-window)
-  (when (and (hemlock-bound-p 'split-window-draft :buffer dbuffer)
-	     ;; Since we now bitmap devices have window groups, this loop is
-	     ;; more correct than testing the length of *window-list* and
-	     ;; accounting for *echo-area-window* being in there.
-	     (do ((start dbuffer-window)
-		  (count 1 (1+ count))
-		  (w (next-window dbuffer-window) (next-window w)))
-		 ((eq start w) (> count 1))))
-    (delete-window (next-window dbuffer-window))
-    (delete-variable 'split-window-draft :buffer dbuffer)))
-
-
-(defcommand "Remail Message" (p)
-  "Prompts for a folder and message to remail.  Prompts for a resend-to
-   address string and resend-cc address string.  When in a headers buffer,
-   remails the message on the current line.  When in a message buffer,
-   remails that message."
-  "Prompts for a folder and message to remail.  Prompts for a resend-to
-   address string and resend-cc address string.  When in a headers buffer,
-   remails the message on the current line.  When in a message buffer,
-   remails that message."
-  (declare (ignore p))
-  (let ((hinfo (value headers-information))
-	(minfo (value message-information)))
-    (cond (hinfo
-	   (multiple-value-bind (cur-msg cur-mark)
-				(headers-current-message hinfo)
-	     (unless cur-msg (editor-error "Not on a header line."))
-	     (delete-mark cur-mark)
-	     (remail-message (headers-info-folder hinfo) cur-msg
-			     (prompt-for-string :prompt "Resend To: ")
-			     (prompt-for-string :prompt "Resend Cc: "))))
-	  (minfo
-	   (remail-message (message-info-folder minfo)
-			   (message-info-msgs minfo)
-			   (prompt-for-string :prompt "Resend To: ")
-			   (prompt-for-string :prompt "Resend Cc: ")))
-	  (t
-	   (let ((folder (prompt-for-folder)))
-	     (remail-message folder
-			     (car (prompt-for-message :folder folder))
-			     (prompt-for-string :prompt "Resend To: ")
-			     (prompt-for-string :prompt "Resend Cc: "))))))
-  (message "Message remailed."))
-
-
-;;; REMAIL-MESSAGE claims a draft folder message with "dist".  This is then
-;;; sucked into a buffer and modified by inserting the supplied addresses.
-;;; "send" is used to deliver the draft, but it requires certain evironment
-;;; variables to make it do the right thing.  "mhdist" says the draft is only
-;;; remailing information, and "mhaltmsg" is the message to send.  "mhannotate"
-;;; must be set due to a bug in MH's "send"; it will not notice the "mhdist"
-;;; flag unless there is some message to be annotated.  This command does not
-;;; provide for annotation of the remailed message.
-;;;
-(defun remail-message (folder msg resend-to resend-cc)
-  (mh "dist" `(,folder ,msg "-nowhatnowproc"))
-  (let* ((draft-folder (mh-draft-folder))
-	 (draft-msg (mh-current-message draft-folder)))
-    (setup-remail-draft-message draft-msg resend-to resend-cc)
-    (mh "send" `("-draftfolder" ,draft-folder "-draftmessage" ,draft-msg)
-	:environment
-	`((:|mhdist| . "1")
-	  (:|mhannotate| . "1")
-	  (:|mhaltmsg| . ,(namestring
-			 (merge-pathnames msg (merge-relative-pathnames
-					       (strip-folder-name folder)
-					       (mh-directory-pathname)))))))))
-
-;;; SETUP-REMAIL-DRAFT-MESSAGE takes a draft folder and message that have been
-;;; created with the MH "dist" utility.  A buffer is created with this
-;;; message's pathname, searching for "resent-to:" and "resent-cc:", filling in
-;;; the supplied argument values.  After writing out the results, the buffer
-;;; is deleted.
-;;;
-(defvar *draft-resent-to-pattern*
-  (new-search-pattern :string-insensitive :forward "resent-to:"))
-(defvar *draft-resent-cc-pattern*
-  (new-search-pattern :string-insensitive :forward "resent-cc:"))
-
-(defun setup-remail-draft-message (msg resend-to resend-cc)
-  (let* ((msg-pn (merge-pathnames msg (mh-draft-folder-pathname)))
-	 (dbuffer (maybe-make-mh-buffer (format nil "Draft ~A" msg)
-					:draft))
-	 (point (buffer-point dbuffer)))
-    (read-mh-file msg-pn dbuffer)
-    (when (find-pattern point *draft-resent-to-pattern*)
-      (line-end point)
-      (insert-string point resend-to))
-    (buffer-start point)
-    (when (find-pattern point *draft-resent-cc-pattern*)
-      (line-end point)
-      (insert-string point resend-cc))
-    (write-file (buffer-region dbuffer) msg-pn :keep-backup nil)
-    ;; The draft buffer delete hook expects this to be bound.
-    (defhvar "Draft Information"
-      "This holds the information about the current draft buffer."
-      :value :ignore
-      :buffer dbuffer)
-    (delete-buffer dbuffer)))
-
-
-
-;;;; Message and Draft Stuff.
-
-(defhvar "Headers Buffer"
-  "This is bound in message and draft buffers to their associated headers
-   buffer."
-  :value nil)
-
-(defcommand "Goto Headers Buffer" (p)
-  "Selects associated headers buffer if it exists.
-   The headers buffer's point is moved to the appropriate line, pushing a
-   buffer mark where point was."
-  "Selects associated headers buffer if it exists."
-  (declare (ignore p))
-  (let ((h-buf (value headers-buffer)))
-    (unless h-buf (editor-error "No associated headers buffer."))
-    (let ((info (or (value message-information) (value draft-information))))
-      (change-to-buffer h-buf)
-      (push-buffer-mark (copy-mark (current-point)))
-      (move-mark (current-point) (message/draft-info-headers-mark info)))))
-
-(defhvar "Message Buffer"
-  "This is bound in draft buffers to their associated message buffer."
-  :value nil)
-
-(defcommand "Goto Message Buffer" (p)
-  "Selects associated message buffer if it exists."
-  "Selects associated message buffer if it exists."
-  (declare (ignore p))
-  (let ((msg-buf (value message-buffer)))
-    (unless msg-buf (editor-error "No associated message buffer."))
-    (change-to-buffer msg-buf)))
-
-
-(defhvar "Message Insertion Prefix"
-  "This is a fill prefix that is used when inserting text from a message buffer
-   into a draft buffer by \"Insert Message Region\".  It defaults to three
-   spaces."
-  :value "   ")
-
-(defhvar "Message Insertion Column"
-  "This is a fill column that is used when inserting text from a message buffer
-   into a draft buffer by \"Insert Message Region\"."
-  :value 75)
-
-(defcommand "Insert Message Region" (p)
-  "Copy the current region into the associated draft buffer.
-   When in a message buffer that has an associated draft buffer, the current
-   active region is copied into the draft buffer.  It is filled using \"Message
-   Insertion Prefix\" and \"Message Insertion Column\".  If an argument is
-   supplied, the filling is inhibited."
-  "When in a message buffer that has an associated draft buffer, the current
-   active region is copied into the draft buffer.  It is filled using
-   \"Message Insertion Prefix\" and \"Message Insertion Column\".  If an
-   argument is supplied, the filling is inhibited."
-  (let ((minfo (value message-information)))
-    (unless minfo (editor-error "Not in a message buffer."))
-    (let ((dbuf (message-info-draft-buf minfo)))
-      (unless dbuf
-	(editor-error "Message buffer not associated with any draft buffer."))
-      (let* ((region (copy-region (current-region)))
-	     (dbuf-point (buffer-point dbuf))
-	     (dbuf-mark (copy-mark dbuf-point)))
-	(if (and (hemlock-bound-p 'split-window-draft :buffer dbuf)
-		 (> (length (the list *window-list*)) 2)
-		 (buffer-windows dbuf))
-	    (setf (current-buffer) dbuf
-		  (current-window) (car (buffer-windows dbuf)))
-	    (change-to-buffer dbuf))
-	(push-buffer-mark dbuf-mark)
-	(ninsert-region dbuf-point region)
-	(unless p
-	  (fill-region-by-paragraphs (region dbuf-mark dbuf-point)
-				     (value message-insertion-prefix)
-				     (value message-insertion-column))))))
-  (setf (last-command-type) :ephemerally-active))
-
-
-(defhvar "Message Buffer Insertion Prefix"
-  "This is a line prefix that is inserted at the beginning of every line in
-   a message buffer when inserting those lines into a draft buffer with
-   \"Insert Message Buffer\".  It defaults to four spaces."
-  :value "    ")
-
-(defcommand "Insert Message Buffer" (p)
-  "Insert entire (associated) message buffer into (associated) draft buffer.
-   When in a draft buffer with an associated message buffer, or when in a
-   message buffer that has an associated draft buffer, the message buffer is
-   inserted into the draft buffer.  Each inserted line is modified by prefixing
-   it with \"Message Buffer Insertion Prefix\".  If an argument is supplied the
-   prefixing is inhibited."
-  "When in a draft buffer with an associated message buffer, or when in a
-   message buffer that has an associated draft buffer, the message buffer
-   is inserted into the draft buffer.  Each inserted line is modified by
-   prefixing it with \"Message Buffer Insertion Prefix\".  If an argument
-   is supplied the prefixing is inhibited."
-  (let ((minfo (value message-information))
-	(dinfo (value draft-information))
-	mbuf dbuf)
-    (cond (minfo
-	   (setf dbuf (message-info-draft-buf minfo))
-	   (unless dbuf
-	     (editor-error
-	      "Message buffer not associated with any draft buffer."))
-	   (setf mbuf (current-buffer))
-	   (change-to-buffer dbuf))
-	  (dinfo
-	   (setf mbuf (value message-buffer))
-	   (unless mbuf
-	     (editor-error
-	      "Draft buffer not associated with any message buffer."))
-	   (setf dbuf (current-buffer)))
-	  (t (editor-error "Not in a draft or message buffer.")))
-    (let* ((dbuf-point (buffer-point dbuf))
-	   (dbuf-mark (copy-mark dbuf-point)))
-      (push-buffer-mark dbuf-mark)
-      (insert-region dbuf-point (buffer-region mbuf))
-      (unless p
-	(let ((prefix (value message-buffer-insertion-prefix)))
-	  (with-mark ((temp dbuf-mark :left-inserting))
-	    (loop
-	      (when (mark>= temp dbuf-point) (return))
-	      (insert-string temp prefix)
-	      (unless (line-offset temp 1 0) (return)))))))
-    (insert-message-buffer-cleanup-split-draft dbuf mbuf))
-  (setf (last-command-type) :ephemerally-active))
-
-;;; INSERT-MESSAGE-BUFFER-CLEANUP-SPLIT-DRAFT tries to delete an extra window
-;;; due to "Reply to Message in Other Window".  Since we just inserted the
-;;; message buffer in the draft buffer, we don't need the other window into
-;;; the message buffer.
-;;;
-(defun insert-message-buffer-cleanup-split-draft (dbuf mbuf)
-  (when (and (hemlock-bound-p 'split-window-draft :buffer dbuf)
-	     (> (length (the list *window-list*)) 2))
-    (let ((win (car (buffer-windows mbuf))))
-      (cond
-       (win
-	(when (eq win (current-window))
-	  (let ((dwin (car (buffer-windows dbuf))))
-	    (unless dwin
-	      (editor-error "Couldn't fix windows for split window draft."))
-	    (setf (current-buffer) dbuf)
-	    (setf (current-window) dwin)))
-	(delete-window win))
-       (t ;; This happens when invoked with the message buffer current.
-	(let ((dwins (buffer-windows dbuf)))
-	  (when (> (length (the list dwins)) 1)
-	    (delete-window (find-if #'(lambda (w)
-					(not (eq w (current-window))))
-				    dwins)))))))
-    (delete-variable 'split-window-draft :buffer dbuf)))
-
-
-;;; CLEANUP-MESSAGE-BUFFER is called when a buffer gets deleted.  It cleans
-;;; up references to a message buffer.
-;;; 
-(defun cleanup-message-buffer (buffer)
-  (let ((minfo (variable-value 'message-information :buffer buffer)))
-    (when (hemlock-bound-p 'headers-buffer :buffer buffer)
-      (let* ((hinfo (variable-value 'headers-information
-				    :buffer (variable-value 'headers-buffer
-							    :buffer buffer)))
-	     (msg-buf (headers-info-msg-buffer hinfo)))
-	(if (eq msg-buf buffer)
-	    (setf (headers-info-msg-buffer hinfo) nil)
-	    (setf (headers-info-other-msg-bufs hinfo)
-		  (delete buffer (headers-info-other-msg-bufs hinfo)
-			  :test #'eq))))
-      (delete-mark (message-info-headers-mark minfo))
-      ;;
-      ;; Do this for MAYBE-MAKE-MH-BUFFER since it isn't necessary for GC.
-      (delete-variable 'headers-buffer :buffer buffer))
-    (when (message-info-draft-buf minfo)
-      (delete-variable 'message-buffer
-		       :buffer (message-info-draft-buf minfo)))))
-
-;;; CLEANUP-DRAFT-BUFFER is called when a buffer gets deleted.  It cleans
-;;; up references to a draft buffer.
-;;;
-(defun cleanup-draft-buffer (buffer)
-  (let ((dinfo (variable-value 'draft-information :buffer buffer)))
-    (when (hemlock-bound-p 'headers-buffer :buffer buffer)
-      (let* ((hinfo (variable-value 'headers-information
-				    :buffer (variable-value 'headers-buffer
-							    :buffer buffer))))
-	(setf (headers-info-draft-bufs hinfo)
-	      (delete buffer (headers-info-draft-bufs hinfo) :test #'eq))
-	(delete-mark (draft-info-headers-mark dinfo))))
-    (when (hemlock-bound-p 'message-buffer :buffer buffer)
-      (setf (message-info-draft-buf
-	     (variable-value 'message-information
-			     :buffer (variable-value 'message-buffer
-						     :buffer buffer)))
-	    nil))))
-
-;;; CLEANUP-HEADERS-BUFFER is called when a buffer gets deleted.  It cleans
-;;; up references to a headers buffer.
-;;; 
-(defun cleanup-headers-buffer (buffer)
-  (let* ((hinfo (variable-value 'headers-information :buffer buffer))
-	 (msg-buf (headers-info-msg-buffer hinfo)))
-    (when msg-buf
-      (cleanup-headers-reference
-       msg-buf (variable-value 'message-information :buffer msg-buf)))
-    (dolist (b (headers-info-other-msg-bufs hinfo))
-      (cleanup-headers-reference
-       b (variable-value 'message-information :buffer b)))
-    (dolist (b (headers-info-draft-bufs hinfo))
-      (cleanup-headers-reference
-       b (variable-value 'draft-information :buffer b)))))
-
-(defun cleanup-headers-reference (buffer info)
-  (delete-mark (message/draft-info-headers-mark info))
-  (setf (message/draft-info-headers-mark info) nil)
-  (delete-variable 'headers-buffer :buffer buffer)
-  (when (typep info 'draft-info)
-    (setf (draft-info-replied-to-folder info) nil)
-    (setf (draft-info-replied-to-msg info) nil)))
-
-;;; REVAMP-HEADERS-BUFFER cleans up a headers buffer for immediate re-use.
-;;; After deleting the buffer's region, there will be one line in the buffer
-;;; because of how Hemlock regions work, so we have to delete that line's
-;;; plist.  Then we clean up any references to the buffer and delete the
-;;; main message buffer.  The other message buffers are left alone assuming
-;;; they are on the "others" list because they are being used in some
-;;; particular way (for example, a draft buffer refers to one or the user has
-;;; kept it).  Then some slots of the info structure are set to nil.
-;;;
-(defun revamp-headers-buffer (hbuffer hinfo)
-  (delete-region (buffer-region hbuffer))
-  (setf (line-plist (mark-line (buffer-point hbuffer))) nil)
-  (let ((msg-buf (headers-info-msg-buffer hinfo)))
-    ;; Deleting the buffer sets the slot to nil.
-    (when msg-buf (delete-buffer-if-possible msg-buf))
-    (cleanup-headers-buffer hbuffer))
-  (setf (headers-info-other-msg-bufs hinfo) nil)
-  (setf (headers-info-draft-bufs hinfo) nil)
-  (setf (headers-info-msg-seq hinfo) nil)
-  (setf (headers-info-msg-strings hinfo) nil))
-
-
-
-;;;; Incorporating new mail.
-
-(defhvar "New Mail Folder"
-  "This is the folder new mail is incorporated into."
-  :value "+inbox")
-
-(defcommand "Incorporate New Mail" (p)
-  "Incorporates new mail into \"New Mail Folder\", displaying INC output in
-   a pop-up window."
-  "Incorporates new mail into \"New Mail Folder\", displaying INC output in
-   a pop-up window."
-  (declare (ignore p))
-  (with-pop-up-display (s)
-    (incorporate-new-mail s)))
-
-(defhvar "Unseen Headers Message Spec"
-  "This is an MH message spec suitable any message prompt.  It is used to
-   supply headers for the unseen headers buffer, in addition to the
-   unseen-sequence name that is taken from the user's MH profile, when
-   incorporating new mail and after expunging.  This value is a string."
-  :value nil)
-
-(defcommand "Incorporate and Read New Mail" (p)
-  "Incorporates new mail and generates a headers buffer.
-   Incorporates new mail into \"New Mail Folder\", and creates a headers buffer
-   with the new messages.  To use this, you must define an unseen- sequence in
-   your profile.  Each time this is invoked the unseen-sequence is SCAN'ed, and
-   the headers buffer's contents are replaced."
-  "Incorporates new mail into \"New Mail Folder\", and creates a headers
-   buffer with the new messages.  This buffer will be appended to with
-   successive uses of this command."
-  (declare (ignore p))
-  (let ((unseen-seq (mh-profile-component "unseen-sequence")))
-    (unless unseen-seq
-      (editor-error "No unseen-sequence defined in MH profile."))
-    (incorporate-new-mail)
-    (let* ((folder (value new-mail-folder))
-	   ;; Stash current message before fetching unseen headers.
-	   (cur-msg (mh-current-message folder))
-	   (region (get-new-mail-msg-hdrs folder unseen-seq)))
-      ;; Fetch message headers before possibly making buffer in case we error.
-      (when (not (and *new-mail-buffer*
-		      (member *new-mail-buffer* *buffer-list* :test #'eq)))
-	(let ((name (format nil "Unseen Headers ~A" folder)))
-	  (when (getstring name *buffer-names*)
-	    (editor-error "There already is a buffer named ~S!" name))
-	  (setf *new-mail-buffer*
-		(make-buffer name :modes (list "Headers")
-			     :delete-hook '(new-mail-buf-delete-hook)))
-	  (setf (buffer-writable *new-mail-buffer*) nil)))
-      (cond ((hemlock-bound-p 'headers-information
-			      :buffer *new-mail-buffer*)
-	     (let ((hinfo (variable-value 'headers-information
-					  :buffer *new-mail-buffer*)))
-	       (unless (string= (headers-info-folder hinfo) folder)
-		 (editor-error
-		  "An unseen headers buffer already exists but into another ~
-		   folder.  Your mail has already been incorporated into the ~
-		   specified folder."))
-	       (with-writable-buffer (*new-mail-buffer*)
-		 (revamp-headers-buffer *new-mail-buffer* hinfo))
-	       ;; Restore the name in case someone used "Pick Headers".
-	       (setf (buffer-name *new-mail-buffer*)
-		     (format nil "Unseen Headers ~A" folder))
-	       (insert-new-mail-message-headers hinfo region cur-msg)))
-	    (t
-	     (let ((hinfo (make-headers-info :buffer *new-mail-buffer*
-					     :folder folder)))
-	       (defhvar "Headers Information"
-		 "This holds the information about the current headers buffer."
-		 :value hinfo :buffer *new-mail-buffer*)
-	       (insert-new-mail-message-headers hinfo region cur-msg)))))))
-
-;;; NEW-MAIL-BUF-DELETE-HOOK is invoked whenever the new mail buffer is
-;;; deleted.
-;;;
-(defun new-mail-buf-delete-hook (buffer)
-  (declare (ignore buffer))
-  (setf *new-mail-buffer* nil))
-
-;;; GET-NEW-MAIL-MSG-HDRS takes a folder and the unseen-sequence name.  It
-;;; returns a region with the unseen message headers and any headers due to
-;;; the "Unseen Headers Message Spec" variable.
-;;;
-(defun get-new-mail-msg-hdrs (folder unseen-seq)
-  (let* ((unseen-headers-message-spec (value unseen-headers-message-spec))
-	 (other-msgs (if unseen-headers-message-spec
-			 (breakup-message-spec
-			  (string-trim '(#\space #\tab)
-				       unseen-headers-message-spec))))
-	 (msg-spec (cond ((null other-msgs)
-			  (list unseen-seq))
-			 ((member unseen-seq other-msgs :test #'string=)
-			  other-msgs)
-			 (t (cons unseen-seq other-msgs)))))
-    (message-headers-to-region folder msg-spec)))
-
-;;; INSERT-NEW-MAIL-MESSAGE-HEADERS inserts region in the new mail buffer.
-;;; Then we look for the header line with cur-msg id, moving point there.
-;;; There may have been unseen messages before incorporating new mail, and
-;;; cur-msg should be the first new message.  Then we either switch to the
-;;; new mail headers, or show the current message.
-;;;
-(defun insert-new-mail-message-headers (hinfo region cur-msg)
-  (declare (simple-string cur-msg))
-  (with-writable-buffer (*new-mail-buffer*)
-    (insert-message-headers *new-mail-buffer* hinfo region))
-  (let ((point (buffer-point *new-mail-buffer*)))
-    (buffer-start point)
-    (with-headers-mark (cur-mark *new-mail-buffer* cur-msg)
-      (move-mark point cur-mark)))
-  (change-to-buffer *new-mail-buffer*))
-
-
-(defhvar "Store Password"
-  "When this is set, the user is only prompted once for his password."
-  :value nil)
-
-(defvar *stored-password* nil)
-
-(defun get-password ()
-  (if (value store-password)
-      (or *stored-password*
-	  (setf *stored-password* (prompt-for-password)))
-      (prompt-for-password)))
-
-
-(defhvar "Authenticate Incorporation"
-  "When this is set (the default), incorporating new mail prompts for a
-   password to access a remote mail drop."
-  :value t)
-(defhvar "Authentication User Name"
-  "When incorporating new mail accesses a remote mail drop, this is the user
-   name supplied for authentication on the remote machine.  If this is nil
-   it is looked up on the local machine."
-  :value nil)
-#|
-(defhvar "Authentication Group Name"
-  "When incorporating new mail accesses a remote mail drop, this is the group
-   name supplied for authentication on the remote machine.  If this is nil
-   it is looked up on the local machine."
-  :value nil)
-(defhvar "Authentication Account Name"
-  "When incorporating new mail accesses a remote mail drop, this is the account
-   name supplied for authentication on the remote machine.  If this is nil
-   it is looked up on the local machine."
-  :value nil)
-|#
-
-(defhvar "Incorporate New Mail Hook"
-  "Functions on this hook are invoked immediately after new mail is
-   incorporated."
-  :value nil)
-
-(defun incorporate-new-mail (&optional stream)
-  "Incorporates new mail, passing INC's output to stream.  When stream is
-   nil, output is flushed."
-  (unless (new-mail-p) (editor-error "No new mail."))
-  (let ((args `(,(coerce-folder-name (value new-mail-folder))
-		,@(if stream nil '("-silent"))
-		"-form" ,(namestring (value mh-scan-line-form))
-		"-width" ,(number-string (value fill-column)))))
-    (cond ((value authenticate-incorporation)
-	   (let ((password (get-password)))
-	     ;; Since we know there is mail due to above check, look for a
-	     ;; possible password failure since MH or the rfs stuff is stupid.
-	     (multiple-value-bind
-		 (winp error-string)
-		 (let ((*standard-output* (or stream *standard-output*)))
-		   (message "Incorporating new mail ...")
-		   (mh "inc" args :errorp nil :password password
-		       :username (value authentication-user-name)))
-	       (declare (simple-string error-string))
-	       (unless winp
-		 (when (string= error-string "inc: unable to read" :end1 19)
-		   (setf *stored-password* nil)
-		   (editor-error
-		    "Couldn't read maildrop, possible mistyped password."))
-		 (editor-error "MH Error -- ~A" error-string)))))
-	  (t (message "Incorporating new mail ...")
-	     (mh "inc" args))))
-  (when (value incorporate-new-mail-hook)
-    (message "Invoking new mail hooks ..."))
-  (invoke-hook incorporate-new-mail-hook))
-
-
-
-;;;; Deletion.
-
-(defhvar "Virtual Message Deletion"
-  "When set, \"Delete Message\" merely MARK's a message into the
-   \"hemlockdeleted\" sequence; otherwise, RMM is invoked."
-  :value t)
-
-(defcommand "Delete Message and Show Next" (p)
-  "Delete message and show next undeleted message.
-   This command is only valid in a headers buffer or a message buffer
-   associated with some headers buffer.  The current message is deleted, and
-   the next undeleted one is shown."
-  "Delete the current message and show the next undeleted one."
-  (declare (ignore p))
-  (let ((hinfo (value headers-information))
-	(minfo (value message-information)))
-    (cond (hinfo
-	   (multiple-value-bind (cur-msg cur-mark)
-				(headers-current-message hinfo)
-	     (unless cur-msg (editor-error "Not on a header line."))
-	     (delete-mark cur-mark)
-	     (delete-message (headers-info-folder hinfo) cur-msg)))
-	  (minfo
-	   (delete-message (message-info-folder minfo)
-			   (message-info-msgs minfo)))
-	  (t
-	   (editor-error "Not in a headers or message buffer."))))
-  (show-message-offset 1 :undeleted))
-
-(defcommand "Delete Message and Down Line" (p)
-  "Deletes the current message, moving point to the next line.
-   When in a headers buffer, deletes the message on the current line.  Then it
-   moves point to the next non-blank line."
-  "Deletes current message and moves point down a line."
-  (declare (ignore p))
-  (let ((hinfo (value headers-information)))
-    (unless hinfo (editor-error "Not in a headers buffer."))
-    (multiple-value-bind (cur-msg cur-mark)
-			 (headers-current-message hinfo)
-      (unless cur-msg (editor-error "Not on a header line."))
-      (delete-message (headers-info-folder hinfo) cur-msg)
-      (when (line-offset cur-mark 1)
-	(unless (blank-line-p (mark-line cur-mark))
-	  (move-mark (current-point) cur-mark)))
-      (delete-mark cur-mark))))
-
-;;; "Delete Message" unlike "Headers Delete Message" cannot know for sure
-;;; which message id's have been deleted, so when virtual message deletion
-;;; is not used, we cannot use DELETE-HEADERS-BUFFER-LINE to keep headers
-;;; buffers consistent.  However, the message id's in the buffer (if deleted)
-;;; will generate MH errors if operations are attempted with them, and
-;;; if the user ever packs the folder with "Expunge Messages", the headers
-;;; buffer will be updated.
-;;;
-(defcommand "Delete Message" (p)
-  "Prompts for a folder, messages to delete, and pick expression.  When in
-   a headers buffer into the same folder specified, the messages prompt
-   defaults to those messages in the buffer; \"all\" may be entered if this is
-   not what is desired.  When \"Virtual Message Deletion\" is set, messages are
-   only MARK'ed for deletion.  See \"Expunge Messages\".  When this feature is
-   not used, headers and message buffers message id's my not be consistent
-   with MH."
-  "Prompts for a folder and message to delete.  When \"Virtual Message
-   Deletion\" is set, messages are only MARK'ed for deletion.  See \"Expunge
-   Messages\"."
-  (declare (ignore p))
-  (let* ((folder (prompt-for-folder))
-	 (hinfo (value headers-information))
-	 (temp-msgs (prompt-for-message
-		     :folder folder
-		     :messages
-		     (if (and hinfo
-			      (string= folder
-				       (the simple-string
-					    (headers-info-folder hinfo))))
-			 (headers-info-msg-strings hinfo))
-		     :prompt "MH messages to pick from: "))
-	 (pick-exp (prompt-for-pick-expression))
-	 (msgs (pick-messages folder temp-msgs pick-exp))
-	 (virtually (value virtual-message-deletion)))
-    (declare (simple-string folder))
-    (if virtually
-	(mh "mark" `(,folder ,@msgs "-sequence" "hemlockdeleted" "-add"))
-	(mh "rmm" `(,folder ,@msgs)))
-    (if virtually    
-	(let ((deleted-seq (mh-sequence-list folder "hemlockdeleted")))
-	  (when deleted-seq
-	    (do-headers-buffers (hbuf folder)
-	      (with-writable-buffer (hbuf)
-		(note-deleted-headers hbuf deleted-seq)))))
-	(do-headers-buffers (hbuf folder hinfo)
-	  (do-headers-lines (hbuf :line-var line :mark-var hmark)
-	    (when (member (line-message-id line) msgs :test #'string=)
-	      (delete-headers-buffer-line hinfo hmark)))))))
-
-(defcommand "Headers Delete Message" (p)
-  "Delete current message.
-   When in a headers buffer, deletes the message on the current line.  When
-   in a message buffer, deletes that message.  When \"Virtual Message
-   Deletion\" is set, messages are only MARK'ed for deletion.  See \"Expunge
-   Messages\"."
-  "When in a headers buffer, deletes the message on the current line.  When
-   in a message buffer, deletes that message.  When \"Virtual Message
-   Deletion\" is set, messages are only MARK'ed for deletion.  See \"Expunge
-   Messages\"."
-  (declare (ignore p))
-  (let ((hinfo (value headers-information))
-	(minfo (value message-information)))
-    (cond (hinfo
-	   (multiple-value-bind (cur-msg cur-mark)
-				(headers-current-message hinfo)
-	     (unless cur-msg (editor-error "Not on a header line."))
-	     (delete-mark cur-mark)
-	     (delete-message (headers-info-folder hinfo) cur-msg)))
-	  (minfo
-	   (let ((msgs (message-info-msgs minfo)))
-	     (delete-message (message-info-folder minfo)
-			     (if (consp msgs) (car msgs) msgs)))
-	   (message "Message deleted."))
-	  (t (editor-error "Not in a headers or message buffer.")))))
-
-;;; DELETE-MESSAGE takes a folder and message id and either flags this message
-;;; for deletion or deletes it.  All headers buffers into folder are updated,
-;;; either by flagging a headers line or deleting it.
-;;;
-(defun delete-message (folder msg)
-  (cond ((value virtual-message-deletion)
-	 (mark-one-message folder msg "hemlockdeleted" :add)
-	 (do-headers-buffers (hbuf folder)
-	   (with-headers-mark (hmark hbuf msg)
-	     (with-writable-buffer (hbuf)
-	       (note-deleted-message-at-mark hmark)))))
-	(t (mh "rmm" (list folder msg))
-	   (do-headers-buffers (hbuf folder hinfo)
-	     (with-headers-mark (hmark hbuf msg)
-	       (delete-headers-buffer-line hinfo hmark)))))
-  (dolist (b *buffer-list*)
-    (when (and (hemlock-bound-p 'message-information :buffer b)
-	       (buffer-modeline-field-p b :deleted-message))
-      (dolist (w (buffer-windows b))
-	(update-modeline-field b w :deleted-message)))))
-
-;;; NOTE-DELETED-MESSAGE-AT-MARK takes a mark at the beginning of a valid
-;;; headers line, sticks a "D" on the line, and frobs the line's deleted
-;;; property.  This assumes the headers buffer is modifiable.
-;;;
-(defun note-deleted-message-at-mark (mark)
-  (find-attribute mark :digit)
-  (find-attribute mark :digit #'zerop)
-  (character-offset mark 2)
-  (setf (next-character mark) #\D)
-  (setf (line-message-deleted (mark-line mark)) t))
-
-;;; DELETE-HEADERS-BUFFER-LINE takes a headers information and a mark on the
-;;; line to be deleted.  Before deleting the line, we check to see if any
-;;; message or draft buffers refer to the buffer because of the line.  Due
-;;; to how regions are deleted, line plists get messed up, so they have to
-;;; be regenerated.  We regenerate them for the whole buffer, so we don't have
-;;; to hack the code to know which lines got messed up.
-;;;
-(defun delete-headers-buffer-line (hinfo hmark)
-  (delete-headers-line-references hinfo hmark)
-  (let ((id (line-message-id (mark-line hmark)))
-	(hbuf (headers-info-buffer hinfo)))
-    (with-writable-buffer (hbuf)
-      (with-mark ((end (line-start hmark) :left-inserting))
-	(unless (line-offset end 1 0) (buffer-end end))
-	(delete-region (region hmark end))))
-    (let ((seq (mh-sequence-delete id (headers-info-msg-seq hinfo))))
-      (setf (headers-info-msg-seq hinfo) seq)
-      (setf (headers-info-msg-strings hinfo) (mh-sequence-strings seq)))
-    (set-message-headers-ids hbuf)
-    (when (value virtual-message-deletion)
-      (let ((deleted-seq (mh-sequence-list (headers-info-folder hinfo)
-					   "hemlockdeleted")))
-	(do-headers-lines (hbuf :line-var line)
-	  (setf (line-message-deleted line)
-		(mh-sequence-member-p (line-message-id line) deleted-seq)))))))
-
-
-;;; DELETE-HEADERS-LINE-REFERENCES removes any message buffer or draft buffer
-;;; pointers to a headers buffer or marks into the headers buffer.  Currently
-;;; message buffers and draft buffers are identified differently for no good
-;;; reason; probably message buffers should be located in the same way draft
-;;; buffers are.  Also, we currently assume only one of other-msg-bufs could
-;;; refer to the line (similarly for draft-bufs), but this might be bug
-;;; prone.  The message buffer case couldn't happen since the buffer name
-;;; would cause MAYBE-MAKE-MH-BUFFER to re-use the buffer, but you could reply
-;;; to the same message twice simultaneously.
-;;;
-(defun delete-headers-line-references (hinfo hmark)
-  (let ((msg-id (line-message-id (mark-line hmark)))
-	(main-msg-buf (headers-info-msg-buffer hinfo)))
-    (declare (simple-string msg-id))
-    (when main-msg-buf
-      (let ((minfo (variable-value 'message-information :buffer main-msg-buf)))
-	(when (string= (the simple-string (message-info-msgs minfo))
-		       msg-id)
-	  (cond ((message-info-draft-buf minfo)
-		 (cleanup-headers-reference main-msg-buf minfo)
-		 (setf (headers-info-msg-buffer hinfo) nil))
-		(t (delete-buffer-if-possible main-msg-buf))))))
-    (dolist (mbuf (headers-info-other-msg-bufs hinfo))
-      (let ((minfo (variable-value 'message-information :buffer mbuf)))
-	(when (string= (the simple-string (message-info-msgs minfo))
-		       msg-id)
-	  (cond ((message-info-draft-buf minfo)
-		 (cleanup-headers-reference mbuf minfo)
-		 (setf (headers-info-other-msg-bufs hinfo)
-		       (delete mbuf (headers-info-other-msg-bufs hinfo)
-			       :test #'eq)))
-		(t (delete-buffer-if-possible mbuf)))
-	  (return)))))
-  (dolist (dbuf (headers-info-draft-bufs hinfo))
-    (let ((dinfo (variable-value 'draft-information :buffer dbuf)))
-      (when (same-line-p (draft-info-headers-mark dinfo) hmark)
-	(cleanup-headers-reference dbuf dinfo)
-	(setf (headers-info-draft-bufs hinfo)
-	      (delete dbuf (headers-info-draft-bufs hinfo) :test #'eq))
-	(return)))))
-
-
-(defcommand "Undelete Message" (p)
-  "Prompts for a folder, messages to undelete, and pick expression.  When in
-   a headers buffer into the same folder specified, the messages prompt
-   defaults to those messages in the buffer; \"all\" may be entered if this is
-   not what is desired.  This command is only meaningful if you have
-   \"Virtual Message Deletion\" set."
-  "Prompts for a folder, messages to undelete, and pick expression.  When in
-   a headers buffer into the same folder specified, the messages prompt
-   defaults to those messages in the buffer; \"all\" may be entered if this is
-   not what is desired.  This command is only meaningful if you have
-   \"Virtual Message Deletion\" set."
-  (declare (ignore p))
-  (unless (value virtual-message-deletion)
-    (editor-error "You don't use virtual message deletion."))
-  (let* ((folder (prompt-for-folder))
-	 (hinfo (value headers-information))
-	 (temp-msgs (prompt-for-message
-		     :folder folder
-		     :messages
-		     (if (and hinfo
-			      (string= folder
-				       (the simple-string
-					    (headers-info-folder hinfo))))
-			 (headers-info-msg-strings hinfo))
-		     :prompt "MH messages to pick from: "))
-	 (pick-exp (prompt-for-pick-expression))
-	 (msgs (if pick-exp
-		   (or (pick-messages folder temp-msgs pick-exp) temp-msgs)
-		   temp-msgs)))
-    (declare (simple-string folder))
-    (mh "mark" `(,folder ,@msgs "-sequence" "hemlockdeleted" "-delete"))
-    (let ((deleted-seq (mh-sequence-list folder "hemlockdeleted")))
-      (do-headers-buffers (hbuf folder)
-	(with-writable-buffer (hbuf)
-	  (do-headers-lines (hbuf :line-var line :mark-var hmark)
-	    (when (and (line-message-deleted line)
-		       (not (mh-sequence-member-p (line-message-id line)
-						  deleted-seq)))
-	      (note-undeleted-message-at-mark hmark))))))))
-
-(defcommand "Headers Undelete Message" (p)
-  "Undelete the current message.
-   When in a headers buffer, undeletes the message on the current line.  When
-   in a message buffer, undeletes that message.  This command is only
-   meaningful if you have \"Virtual Message Deletion\" set."
-  "When in a headers buffer, undeletes the message on the current line.  When
-   in a message buffer, undeletes that message.  This command is only
-   meaningful if you have \"Virtual Message Deletion\" set."
-  (declare (ignore p))
-  (unless (value virtual-message-deletion)
-    (editor-error "You don't use virtual message deletion."))
-  (let ((hinfo (value headers-information))
-	(minfo (value message-information)))
-    (cond (hinfo
-	   (multiple-value-bind (cur-msg cur-mark)
-				(headers-current-message hinfo)
-	     (unless cur-msg (editor-error "Not on a header line."))
-	     (delete-mark cur-mark)
-	     (undelete-message (headers-info-folder hinfo) cur-msg)))
-	  (minfo
-	   (undelete-message (message-info-folder minfo)
-			     (message-info-msgs minfo))
-	   (message "Message undeleted."))
-	  (t (editor-error "Not in a headers or message buffer.")))))
-
-;;; UNDELETE-MESSAGE takes a folder and a message id.  All headers buffers into
-;;; folder are updated.
-;;;
-(defun undelete-message (folder msg)
-  (mark-one-message folder msg "hemlockdeleted" :delete)
-  (do-headers-buffers (hbuf folder)
-    (with-headers-mark (hmark hbuf msg)
-      (with-writable-buffer (hbuf)
-	(note-undeleted-message-at-mark hmark))))
-  (dolist (b *buffer-list*)
-    (when (and (hemlock-bound-p 'message-information :buffer b)
-	       (buffer-modeline-field-p b :deleted-message))
-      (dolist (w (buffer-windows b))
-	(update-modeline-field b w :deleted-message)))))
-
-;;; NOTE-UNDELETED-MESSAGE-AT-MARK takes a mark at the beginning of a valid
-;;; headers line, sticks a space on the line in place of a "D", and frobs the
-;;; line's deleted property.  This assumes the headers buffer is modifiable.
-;;;
-(defun note-undeleted-message-at-mark (hmark)
-  (find-attribute hmark :digit)
-  (find-attribute hmark :digit #'zerop)
-  (character-offset hmark 2)
-  (setf (next-character hmark) #\space)
-  (setf (line-message-deleted (mark-line hmark)) nil))
-
-
-(defcommand "Expunge Messages" (p)
-  "Expunges messages marked for deletion.
-   This command prompts for a folder, invoking RMM on the \"hemlockdeleted\"
-   sequence after asking the user for confirmation.  Setting \"Quit Headers
-   Confirm\" to nil inhibits prompting.  The folder's message id's are packed
-   with FOLDER -pack.  When in a headers buffer, uses that folder.  When in a
-   message buffer, uses its folder, updating any associated headers buffer.
-   When \"Temporary Draft Folder\" is bound, this folder's messages are deleted
-   and expunged."
-  "Prompts for a folder, invoking RMM on the \"hemlockdeleted\" sequence and
-   packing the message id's with FOLDER -pack.  When in a headers buffer,
-   uses that folder."
-  (declare (ignore p))
-  (let* ((hinfo (value headers-information))
-	 (minfo (value message-information))
-	 (folder (cond (hinfo (headers-info-folder hinfo))
-		       (minfo (message-info-folder minfo))
-		       (t (prompt-for-folder))))
-	 (deleted-seq (mh-sequence-list folder "hemlockdeleted")))
-    ;;
-    ;; Delete the messages if there are any.
-    ;; This deletes "hemlockdeleted" from sequence file; we don't have to.
-    (when (and deleted-seq
-	       (or (not (value expunge-messages-confirm))
-		   (prompt-for-y-or-n
-		    :prompt (list "Expunge messages and pack folder ~A? "
-				  folder)
-		    :default t
-		    :default-string "Y")))
-      (message "Deleting messages ...")
-      (mh "rmm" (list folder "hemlockdeleted"))
-      ;;
-      ;; Compact the message id's after deletion.
-      (let ((*standard-output* *mh-utility-bit-bucket*))
-	(message "Compacting folder ...")
-	(mh "folder" (list folder "-fast" "-pack")))
-      ;;
-      ;; Do a bunch of consistency maintenance.
-      (let ((new-buf-p (eq (current-buffer) *new-mail-buffer*)))
-	(message "Maintaining consistency ...")
-	(expunge-messages-fold-headers-buffers folder)
-	(expunge-messages-fix-draft-buffers folder)
-	(expunge-messages-fix-unseen-headers folder)
-	(when new-buf-p (change-to-buffer *new-mail-buffer*)))
-      (delete-and-expunge-temp-drafts))))
-
-;;; EXPUNGE-MESSAGES-FOLD-HEADERS-BUFFERS deletes all headers buffers into the
-;;; compacted folder.  We can only update the headers buffers by installing all
-;;; headers, so there may as well be only one such buffer.  First we get a list
-;;; of the buffers since DO-HEADERS-BUFFERS is trying to iterate over a list
-;;; being destructively modified by buffer deletions.
-;;;
-(defun expunge-messages-fold-headers-buffers (folder)
-  (let (hbufs)
-    (declare (list hbufs))
-    (do-headers-buffers (b folder)
-      (unless (eq b *new-mail-buffer*)
-	(push b hbufs)))
-    (unless (zerop (length hbufs))
-      (dolist (b hbufs)
-	(delete-headers-buffer-and-message-buffers-command nil b))
-      (new-message-headers folder (list "all")))))
-
-;;; EXPUNGE-MESSAGES-FIX-DRAFT-BUFFERS finds any draft buffer that was set up
-;;; as a reply to some message in folder, removing this relationship in case
-;;; that message id does not exist after expunge folder compaction.
-;;;
-(defun expunge-messages-fix-draft-buffers (folder)
-  (declare (simple-string folder))
-  (dolist (b *buffer-list*)
-    (when (hemlock-bound-p 'draft-information :buffer b)
-      (let* ((dinfo (variable-value 'draft-information :buffer b))
-	     (reply-folder (draft-info-replied-to-folder dinfo)))
-	(when (and reply-folder
-		   (string= (the simple-string reply-folder) folder))
-	  (setf (draft-info-replied-to-folder dinfo) nil)
-	  (setf (draft-info-replied-to-msg dinfo) nil))))))
-
-;;; EXPUNGE-MESSAGES-FIX-UNSEEN-HEADERS specially handles the unseen headers
-;;; buffer apart from the other headers buffers into the same folder when
-;;; messages have been expunged.  We must delete the associated message buffers
-;;; since REVAMP-HEADERS-BUFFER does not, and these potentially reference bad
-;;; message id's.  When doing this we must copy the other-msg-bufs list since
-;;; the delete buffer cleanup hook for them is destructive.  Then we check for
-;;; more unseen messages.
-;;;
-(defun expunge-messages-fix-unseen-headers (folder)
-  (declare (simple-string folder))
-  (when *new-mail-buffer*
-    (let ((hinfo (variable-value 'headers-information
-				 :buffer *new-mail-buffer*)))
-      (when (string= (the simple-string (headers-info-folder hinfo))
-		     folder)
-	(let ((other-bufs (copy-list (headers-info-other-msg-bufs hinfo))))
-	  (dolist (b other-bufs) (delete-buffer-if-possible b)))
-	(with-writable-buffer (*new-mail-buffer*)
-	  (revamp-headers-buffer *new-mail-buffer* hinfo)
-	  ;; Restore the name in case someone used "Pick Headers".
-	  (setf (buffer-name *new-mail-buffer*)
-		(format nil "Unseen Headers ~A" folder))
-	  (let ((region (maybe-get-new-mail-msg-hdrs folder)))
-	    (when region
-	      (insert-message-headers *new-mail-buffer* hinfo region))))))))
-
-;;; MAYBE-GET-NEW-MAIL-MSG-HDRS returns a region suitable for a new mail buffer
-;;; or nil.  Folder is probed for unseen headers, and if there are some, then
-;;; we call GET-NEW-MAIL-MSG-HDRS which also uses "Unseen Headers Message Spec".
-;;; If there are no unseen headers, we only look for "Unseen Headers Message
-;;; Spec" messages.  We go through these contortions to keep MH from outputting
-;;; errors.
-;;;
-(defun maybe-get-new-mail-msg-hdrs (folder)
-  (let ((unseen-seq-name (mh-profile-component "unseen-sequence")))
-    (multiple-value-bind (unseen-seq foundp)
-			 (mh-sequence-list folder unseen-seq-name)
-      (if (and foundp unseen-seq)
-	  (get-new-mail-msg-hdrs folder unseen-seq-name)
-	  (let ((spec (value unseen-headers-message-spec)))
-	    (when spec
-	      (message-headers-to-region
-	       folder
-	       (breakup-message-spec (string-trim '(#\space #\tab) spec)))))))))
-
-
-
-;;;; Folders.
-
-(defvar *folder-name-table* nil)
-
-(defun check-folder-name-table ()
-  (unless *folder-name-table*
-    (message "Finding folder names ...")
-    (setf *folder-name-table* (make-string-table))
-    (let* ((output (with-output-to-string (*standard-output*)
-		     (mh "folders" '("-fast"))))
-	   (length (length output))
-	   (start 0))
-      (declare (simple-string output))
-      (loop
-	(when (> start length) (return))
-	(let ((nl (position #\newline output :start start)))
-	  (unless nl (return))
-	  (unless (= start nl)
-	    (setf (getstring (subseq output start nl) *folder-name-table*) t))
-	  (setf start (1+ nl)))))))
-
-(defcommand "List Folders" (p)
-  "Pop up a list of folders at top-level."
-  "Pop up a list of folders at top-level."
-  (declare (ignore p))
-  (check-folder-name-table)
-  (with-pop-up-display (s)
-    (do-strings (f ignore *folder-name-table*)
-      (declare (ignore ignore))
-      (write-line f s))))
-
-(defcommand "Create Folder" (p)
-  "Creates a folder.  If the folder already exists, an error is signaled."
-  "Creates a folder.  If the folder already exists, an error is signaled."
-  (declare (ignore p))
-  (let ((folder (prompt-for-folder :must-exist nil)))
-    (when (folder-existsp folder)
-      (editor-error "Folder already exists -- ~S!" folder))
-    (create-folder folder)))
-
-(defcommand "Delete Folder" (p)
-  "Prompts for a folder and uses RMF to delete it."
-  "Prompts for a folder and uses RMF to delete it."
-  (declare (ignore p))
-  (let* ((folder (prompt-for-folder))
-	 (*standard-output* *mh-utility-bit-bucket*))
-    (mh "rmf" (list folder))
-		    ;; RMF doesn't recognize this documented switch.
-		    ;; "-nointeractive"))))
-    (check-folder-name-table)
-    (delete-string (strip-folder-name folder) *folder-name-table*)))
-
-
-(defvar *refile-default-destination* nil)
-
-(defcommand "Refile Message" (p)
-  "Prompts for a source folder, messages, pick expression, and a destination
-   folder to refile the messages."
-  "Prompts for a source folder, messages, pick expression, and a destination
-   folder to refile the messages."
-  (declare (ignore p))
-  (let* ((src-folder (prompt-for-folder :prompt "Source folder: "))
-	 (hinfo (value headers-information))
-	 (temp-msgs (prompt-for-message
-		     :folder src-folder
-		     :messages
-		     (if (and hinfo
-			      (string= src-folder
-				       (the simple-string
-					    (headers-info-folder hinfo))))
-			 (headers-info-msg-strings hinfo))
-		     :prompt "MH messages to pick from: "))
-	 (pick-exp (prompt-for-pick-expression))
-	 ;; Return pick result or temp-msgs individually specified in a list.
-	 (msgs (pick-messages src-folder temp-msgs pick-exp)))
-    (declare (simple-string src-folder))
-    (refile-message src-folder msgs
-		    (prompt-for-folder :must-exist nil
-				       :prompt "Destination folder: "
-				       :default *refile-default-destination*))))
-
-(defcommand "Headers Refile Message" (p)
-  "Refile the current message.
-   When in a headers buffer, refiles the message on the current line, and when
-   in a message buffer, refiles that message, prompting for a destination
-   folder."
-  "When in a headers buffer, refiles the message on the current line, and when
-   in a message buffer, refiles that message, prompting for a destination
-   folder."
-  (declare (ignore p))
-  (let ((hinfo (value headers-information))
-	(minfo (value message-information)))
-    (cond (hinfo
-	   (multiple-value-bind (cur-msg cur-mark)
-				(headers-current-message hinfo)
-	     (unless cur-msg (editor-error "Not on a header line."))
-	     (delete-mark cur-mark)
-	     (refile-message (headers-info-folder hinfo) cur-msg
-			     (prompt-for-folder
-			      :must-exist nil
-			      :prompt "Destination folder: "
-			      :default *refile-default-destination*))))
-	  (minfo
-	   (refile-message
-	    (message-info-folder minfo) (message-info-msgs minfo)
-	    (prompt-for-folder :must-exist nil
-			       :prompt "Destination folder: "
-			       :default *refile-default-destination*))
-	   (message "Message refiled."))
-	  (t
-	   (editor-error "Not in a headers or message buffer.")))))
-
-;;; REFILE-MESSAGE refiles msg from src-folder to dst-folder.  If dst-buffer
-;;; doesn't exist, the user is prompted for creating it.  All headers buffers
-;;; concerning src-folder are updated.  When msg is a list, we did a general
-;;; message prompt, and we cannot know which headers lines to delete.
-;;;
-(defun refile-message (src-folder msg dst-folder)
-  (unless (folder-existsp dst-folder)
-    (cond ((prompt-for-y-or-n
-	    :prompt "Destination folder doesn't exist.  Create it? "
-	    :default t :default-string "Y")
-	   (create-folder dst-folder))
-	  (t (editor-error "Not refiling message."))))
-  (mh "refile" `(,@(if (listp msg) msg (list msg))
-		 "-src" ,src-folder ,dst-folder))
-  (setf *refile-default-destination* (strip-folder-name dst-folder))
-  (if (listp msg)
-      (do-headers-buffers (hbuf src-folder hinfo)
-	(do-headers-lines (hbuf :line-var line :mark-var hmark)
-	  (when (member (line-message-id line) msg :test #'string=)
-	    (delete-headers-buffer-line hinfo hmark))))
-      (do-headers-buffers (hbuf src-folder hinfo)
-	(with-headers-mark (hmark hbuf msg)
-	  (delete-headers-buffer-line hinfo hmark)))))
-
-
-
-;;;; Miscellaneous commands.
-
-(defcommand "Mark Message" (p)
-  "Prompts for a folder, message, and sequence.  By default the message is
-   added, but if an argument is supplied, the message is deleted.  When in
-   a headers buffer or message buffer, only a sequence is prompted for."
-  "Prompts for a folder, message, and sequence.  By default the message is
-   added, but if an argument is supplied, the message is deleted.  When in
-   a headers buffer or message buffer, only a sequence is prompted for."
-  (let* ((hinfo (value headers-information))
-	 (minfo (value message-information)))
-    (cond (hinfo
-	   (multiple-value-bind (cur-msg cur-mark)
-				(headers-current-message hinfo)
-	     (unless cur-msg (editor-error "Not on a header line."))
-	     (delete-mark cur-mark)
-	     (let ((seq-name (prompt-for-string :prompt "Sequence name: "
-						:trim t)))
-	       (declare (simple-string seq-name))
-	       (when (string= "" seq-name)
-		 (editor-error "Sequence name cannot be empty."))
-	       (mark-one-message (headers-info-folder hinfo)
-				 cur-msg seq-name (if p :delete :add)))))
-	  (minfo
-	   (let ((msgs (message-info-msgs minfo))
-		 (seq-name (prompt-for-string :prompt "Sequence name: "
-					      :trim t)))
-	     (declare (simple-string seq-name))
-	     (when (string= "" seq-name)
-	       (editor-error "Sequence name cannot be empty."))
-	     (mark-one-message (message-info-folder minfo)
-			       (if (consp msgs) (car msgs) msgs)
-			       seq-name (if p :delete :add))))
-	  (t
-	   (let ((folder (prompt-for-folder))
-		 (seq-name (prompt-for-string :prompt "Sequence name: "
-					      :trim t)))
-	     (declare (simple-string seq-name))
-	     (when (string= "" seq-name)
-	       (editor-error "Sequence name cannot be empty."))
-	     (mh "mark" `(,folder ,@(prompt-for-message :folder folder)
-			  "-sequence" ,seq-name
-			  ,(if p "-delete" "-add"))))))))
-
-
-(defcommand "List Mail Buffers" (p)
-  "Show a list of all mail associated buffers.
-   If the buffer has an associated message buffer, it is displayed to the right
-   of the buffer name.  If there is no message buffer, but the buffer is
-   associated with a headers buffer, then it is displayed.  If the buffer is
-   modified then a * is displayed before the name."
-  "Display the names of all buffers in a with-random-typeout window."
-  (declare (ignore p))
-  (let ((buffers nil))
-    (declare (list buffers))
-    (do-strings (n b *buffer-names*)
-      (declare (ignore n))
-      (unless (eq b *echo-area-buffer*)
-	(cond ((hemlock-bound-p 'message-buffer :buffer b)
-	       ;; Catches draft buffers associated with message buffers first.
-	       (push (cons b (variable-value 'message-buffer :buffer b))
-		     buffers))
-	      ((hemlock-bound-p 'headers-buffer :buffer b)
-	       ;; Then draft or message buffers associated with headers buffers.
-	       (push (cons b (variable-value 'headers-buffer :buffer b))
-		     buffers))
-	      ((or (hemlock-bound-p 'draft-information :buffer b)
-		   (hemlock-bound-p 'message-information :buffer b)
-		   (hemlock-bound-p 'headers-information :buffer b))
-	       (push b buffers)))))
-    (with-pop-up-display (s :height (length buffers))
-      (dolist (ele (nreverse buffers))
-	(let* ((association (if (consp ele) (cdr ele)))
-	       (b (if association (car ele) ele))
-	       (buffer-pathname (buffer-pathname b))
-	       (buffer-name (buffer-name b)))
-	  (write-char (if (buffer-modified b) #\* #\space) s)
-	  (if buffer-pathname
-	      (format s "~A  ~A~:[~;~50T~:*~A~]~%"
-		      (file-namestring buffer-pathname)
-		      (directory-namestring buffer-pathname)
-		      (if association (buffer-name association)))
-	      (format s "~A~:[~;~50T~:*~A~]~%"
-		      buffer-name
-		      (if association (buffer-name association)))))))))
-
-
-(defcommand "Message Help" (p)
-  "Show this help."
-  "Show this help."
-  (declare (ignore p))
-  (describe-mode-command nil "Message"))
-
-(defcommand "Headers Help" (p)
-  "Show this help."
-  "Show this help."
-  (declare (ignore p))
-  (describe-mode-command nil "Headers"))
-
-(defcommand "Draft Help" (p)
-  "Show this help."
-  "Show this help."
-  (declare (ignore p))
-  (describe-mode-command nil "Draft"))
-
-
-
-;;;; Prompting.
-
-;;; Folder prompting.
-;;; 
-
-(defun prompt-for-folder (&key (must-exist t) (prompt "MH Folder: ")
-			       (default (mh-current-folder)))
-  "Prompts for a folder, using MH's idea of the current folder as a default.
-   The result will have a leading + in the name."
-  (check-folder-name-table)
-  (let ((folder (prompt-for-keyword (list *folder-name-table*)
-				    :must-exist must-exist :prompt prompt
-				    :default default :default-string default
-				    :help "Enter folder name.")))
-    (declare (simple-string folder))
-    (when (string= folder "") (editor-error "Must supply folder!"))
-    (let ((name (coerce-folder-name folder)))
-      (when (and must-exist (not (folder-existsp name)))
-	(editor-error "Folder does not exist -- ~S." name))
-      name)))
-
-(defun coerce-folder-name (folder)
-  (if (char= (schar folder 0) #\+)
-      folder
-      (concatenate 'simple-string "+" folder)))
-
-(defun strip-folder-name (folder)
-  (if (char= (schar folder 0) #\+)
-      (subseq folder 1)
-      folder))
-
-
-;;; Message prompting.
-;;; 
-
-(defun prompt-for-message (&key (folder (mh-current-folder))
-				(prompt "MH messages: ")
-				messages)
-   "Prompts for a message spec, using messages as a default.  If messages is
-    not supplied, then the current message for folder is used.  The result is
-    a list of strings which are the message ids, intervals, and/or sequence
-    names the user entered."
-  (let* ((cur-msg (cond ((not messages) (mh-current-message folder))
-			((stringp messages) messages)
-			((consp messages)
-			 (if (= (length (the list messages)) 1)
-			     (car messages)
-			     (format nil "~{~A~^ ~}" messages))))))
-    (breakup-message-spec (prompt-for-string :prompt prompt
-					     :default cur-msg
-					     :default-string cur-msg
-					     :trim t
-					     :help "Enter MH message id(s)."))))
-
-(defun breakup-message-spec (msgs)
-  (declare (simple-string msgs))
-  (let ((start 0)
-	(result nil))
-    (loop
-      (let ((end (position #\space msgs :start start :test #'char=)))
-	(unless end
-	  (return (if (zerop start)
-		      (list msgs)
-		      (nreverse (cons (subseq msgs start) result)))))
-	(push (subseq msgs start end) result)
-	(setf start (1+ end))))))
-
-
-;;; PICK expression prompting.
-;;; 
-
-(defhvar "MH Lisp Expression"
-  "When this is set (the default), MH expression prompts are read in a Lisp
-   syntax.  Otherwise, the input is as if it had been entered on a shell
-   command line."
-  :value t)
-
-;;; This is dynamically bound to nil for argument processing routines.
-;;; 
-(defvar *pick-expression-strings* nil)
-
-(defun prompt-for-pick-expression ()
-  "Prompts for an MH PICK-like expression that is converted to a list of
-   strings suitable for EXT:RUN-PROGRAM.  As a second value, the user's
-   expression is as typed in is returned."
-  (let ((exp (prompt-for-string :prompt "MH expression: "
-				:help "Expression to PICK over mail messages."
-				:trim t))
-	(*pick-expression-strings* nil))
-    (if (value mh-lisp-expression)
-	(let ((exp (let ((*package* *keyword-package*))
-		     (read-from-string exp))))
-	  (if exp
-	      (if (consp exp)
-		  (lisp-to-pick-expression exp)
-		  (editor-error "Lisp PICK expressions cannot be atomic."))))
-	(expand-mh-pick-spec exp))
-    (values (nreverse *pick-expression-strings*)
-	    exp)))
-
-(defun lisp-to-pick-expression (exp)
-  (ecase (car exp)
-    (:and (lpe-and/or exp "-and"))
-    (:or (lpe-and/or exp "-or"))
-    (:not (push "-not" *pick-expression-strings*)
-	  (let ((nexp (cadr exp)))
-	    (unless (consp nexp) (editor-error "Bad expression -- ~S" nexp))
-	    (lisp-to-pick-expression nexp)))
-    
-    (:cc (lpe-output-and-go exp "-cc"))
-    (:date (lpe-output-and-go exp "-date"))
-    (:from (lpe-output-and-go exp "-from"))
-    (:search (lpe-output-and-go exp "-search"))
-    (:subject (lpe-output-and-go exp "-subject"))
-    (:to (lpe-output-and-go exp "-to"))
-    (:-- (lpe-output-and-go (cdr exp)
-			    (concatenate 'simple-string
-					 "--" (string (cadr exp)))))
-
-    (:before (lpe-after-and-before exp "-before"))
-    (:after (lpe-after-and-before exp "-after"))
-    (:datefield (lpe-output-and-go exp "-datefield"))))
-
-(defun lpe-after-and-before (exp op)
-  (let ((operand (cadr exp)))
-    (when (numberp operand)
-      (setf (cadr exp)
-	    (if (plusp operand)
-		(number-string (- operand))
-		(number-string operand)))))
-  (lpe-output-and-go exp op))
-
-(defun lpe-output-and-go (exp op)
-  (push op *pick-expression-strings*)
-  (let ((operand (cadr exp)))
-    (etypecase operand
-      (string (push operand *pick-expression-strings*))
-      (symbol (push (symbol-name operand)
-		    *pick-expression-strings*)))))
-
-(defun lpe-and/or (exp op)
-  (push "-lbrace" *pick-expression-strings*)
-  (dolist (ele (cdr exp))
-    (lisp-to-pick-expression ele)
-    (push op *pick-expression-strings*))
-  (pop *pick-expression-strings*) ;Clear the extra "-op" arg.
-  (push "-rbrace" *pick-expression-strings*))
-
-;;; EXPAND-MH-PICK-SPEC takes a string of "words" assumed to be separated
-;;; by single spaces.  If a "word" starts with a quotation mark, then
-;;; everything is grabbed up to the next one and used as a single word.
-;;; Currently, this does not worry about extra spaces (or tabs) between
-;;; "words".
-;;; 
-(defun expand-mh-pick-spec (spec)
-  (declare (simple-string spec))
-  (let ((start 0))
-    (loop
-      (let ((end (position #\space spec :start start :test #'char=)))
-	(unless end
-	  (if (zerop start)
-	      (setf *pick-expression-strings* (list spec))
-	      (push (subseq spec start) *pick-expression-strings*))
-	  (return))
-	(cond ((char= #\" (schar spec start))
-	       (setf end (position #\" spec :start (1+ start) :test #'char=))
-	       (unless end (editor-error "Bad quoting syntax."))
-	       (push (subseq spec (1+ start) end) *pick-expression-strings*)
-	       (setf start (+ end 2)))
-	      (t (push (subseq spec start end) *pick-expression-strings*)
-		 (setf start (1+ end))))))))
-
-
-;;; Password prompting.
-;;;
-
-(defun prompt-for-password (&optional (prompt "Password: "))
-  "Prompts for password with prompt."
-  (let ((hi::*parse-verification-function* #'(lambda (string) (list string))))
-    (let ((hi::*parse-prompt* prompt))
-      (hi::display-prompt-nicely))
-    (let ((start-window (current-window)))
-      (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*))
-      (setf (current-window) *echo-area-window*)
-      (unwind-protect
-	  (use-buffer *echo-area-buffer*
-	    (let ((result ()))
-	      (declare (list result))
-	      (loop
-		(let ((key-event (get-key-event *editor-input*)))
-		  (ring-pop hi::*key-event-history*)
-		  (cond ((eq key-event #k"return")
-			 (return (prog1 (coerce (nreverse result)
-						'simple-string)
-				   (fill result nil))))
-			((or (eq key-event #k"control-u")
-			     (eq key-event #k"control-U"))
-			 (setf result nil))
-			(t (push (ext:key-event-char key-event) result)))))))
-	(setf (current-window) start-window)))))
-
-
-
-
-;;;; Making mail buffers.
-
-;;; MAYBE-MAKE-MH-BUFFER looks up buffer with name, returning it if it exists
-;;; after cleaning it up to a state "good as new".  Currently, we don't
-;;; believe it is possible to try to make two draft buffers with the same name
-;;; since that would mean that composition, draft folder interaction, and
-;;; draft folder current message didn't do what we expected -- or some user
-;;; was modifying the draft folder in some evil way.
-;;;
-(defun maybe-make-mh-buffer (name use)
-  (let ((buf (getstring name *buffer-names*)))
-    (cond ((not buf)
-	   (ecase use
-	     (:headers (make-buffer name
-				    :modes '("Headers")
-				    :delete-hook '(cleanup-headers-buffer)))
-
-	     (:message
-	      (make-buffer name :modes '("Message")
-			   :modeline-fields
-			   (value default-message-modeline-fields)
-			   :delete-hook '(cleanup-message-buffer)))
-
-	     (:draft
-	      (let ((buf (make-buffer
-			  name :delete-hook '(cleanup-draft-buffer))))
-		(setf (buffer-minor-mode buf "Draft") t)
-		buf))))
-	  ((hemlock-bound-p 'headers-information :buffer buf)
-	   (setf (buffer-writable buf) t)
-	   (delete-region (buffer-region buf))
-	   (cleanup-headers-buffer buf)
-	   (delete-variable 'headers-information :buffer buf)
-	   buf)
-	  ((hemlock-bound-p 'message-information :buffer buf)
-	   (setf (buffer-writable buf) t)
-	   (delete-region (buffer-region buf))
-	   (cleanup-message-buffer buf)
-	   (delete-variable 'message-information :buffer buf)
-	   buf)
-	  ((hemlock-bound-p 'draft-information :buffer buf)
-	   (error "Attempt to create multiple draft buffers to same draft ~
-	           folder message -- ~S"
-		  name)))))
-
-
-;;;; Message buffer modeline fields.
-
-(make-modeline-field
- :name :deleted-message :width 2
- :function
- #'(lambda (buffer window)
-     "Returns \"D \" when message in buffer is deleted."
-     (declare (ignore window))
-     (let* ((minfo (variable-value 'message-information :buffer buffer))
-	    (hmark (message-info-headers-mark minfo)))
-       (cond ((not hmark)
-	      (let ((msgs (message-info-msgs minfo)))
-		(if (and (value virtual-message-deletion)
-			 (mh-sequence-member-p
-			  (if (consp msgs) (car msgs) msgs)
-			  (mh-sequence-list (message-info-folder minfo)
-					    "hemlockdeleted")))
-		    "D "
-		    "")))
-	     ((line-message-deleted (mark-line hmark))
-	      "D ")
-	     (t "")))))
-
-(make-modeline-field
- :name :replied-to-message :width 1
- :function
- #'(lambda (buffer window)
-     "Returns \"A\" when message in buffer is deleted."
-     (declare (ignore window))
-     (let* ((minfo (variable-value 'message-information :buffer buffer))
-	    (hmark (message-info-headers-mark minfo)))
-       (cond ((not hmark)
-	      ;; Could do something nasty here to figure out the right value.
-	      "")
-	     (t
-	      (mark-to-note-replied-msg hmark)
-	      (if (char= (next-character hmark) #\A)
-		  "A"
-		  ""))))))
-
-;;; MARK-TO-NOTE-REPLIED-MSG moves the headers-buffer mark to a line position
-;;; suitable for checking or setting the next character with respect to noting
-;;; that a message has been replied to.
-;;;
-(defun mark-to-note-replied-msg (hmark)
-  (line-start hmark)
-  (find-attribute hmark :digit)
-  (find-attribute hmark :digit #'zerop)
-  (character-offset hmark 1))
-
-
-(defhvar "Default Message Modeline Fields"
-  "This is the default list of modeline-field objects for message buffers."
-  :value
-  (list (modeline-field :hemlock-literal) (modeline-field :package)
-	(modeline-field :modes) (modeline-field :buffer-name)
-	(modeline-field :replied-to-message) (modeline-field :deleted-message)
-	(modeline-field :buffer-pathname) (modeline-field :modifiedp)))
-
-
-
-;;;; MH interface.
-
-;;; Running an MH utility.
-;;; 
-
-(defhvar "MH Utility Pathname"
-  "MH utility names are merged with this.  The default is
-   \"/usr/misc/.mh/bin/\"."
-  :value (pathname "/usr/misc/.mh/bin/"))
-
-(defvar *signal-mh-errors* t
-  "This is the default value for whether MH signals errors.  It is useful to
-   bind this to nil when using PICK-MESSAGES with the \"Incorporate New Mail
-   Hook\".")
-
-(defvar *mh-error-output* (make-string-output-stream))
-
-(defun mh (utility args &key (errorp *signal-mh-errors*)
-		             password username environment)
-  "Runs the MH utility with the list of args (suitable for EXT:RUN-PROGRAM),
-   outputting to *standard-output*.  If password is supplied, then the MH
-   utility is run with RFS authentication.  If username is nil, this looks it
-   up on the editor's machine.  Environment is a list of strings appended with
-   ext:*environment-list*.  This returns t, unless there is an error.
-   When errorp, this reports any MH errors in the echo area as an editor error,
-   and this does not return; otherwise, nil and the error output from the MH
-   utility are returned."
-  (fresh-line)
-  (let* ((utility (namestring (truename
-			       (merge-pathnames utility
-						(value mh-utility-pathname)))))
-	 (proc (ext:run-program
-		utility args
-		:output *standard-output*
-		:error *mh-error-output*
-		:env (append environment ext:*environment-list*)
-		:before-execve
-		(if password
-		    #'(lambda ()
-			(mach:rfs-authenticate
-			 (or username
-			     (lisp::lookup-login-name (mach:unix-getuid)))
-			 nil nil password))))))
-    (fresh-line)
-    (ext:process-close proc)
-    (cond ((zerop (ext:process-exit-code proc))
-	   (values t nil))
-	  (errorp
-	   (editor-error "MH Error -- ~A"
-			 (get-output-stream-string *mh-error-output*)))
-	  (t (values nil (get-output-stream-string *mh-error-output*))))))
-
-
-
-;;; Draft folder name and pathname.
-;;; 
-
-(defun mh-draft-folder ()
-  (let ((drafts (mh-profile-component "draft-folder")))
-    (unless drafts
-      (error "There must be a draft-folder component in your profile."))
-    drafts))
-
-(defun mh-draft-folder-pathname ()
-  "Returns the pathname of the MH draft folder directory."
-  (let ((drafts (mh-profile-component "draft-folder")))
-    (unless drafts
-      (error "There must be a draft-folder component in your profile."))
-    (merge-relative-pathnames drafts (mh-directory-pathname))))
-
-
-;;; Current folder name.
-;;; 
-
-(defun mh-current-folder ()
-  "Returns the current MH folder from the context file."
-  (mh-profile-component "current-folder" (mh-context-pathname)))
-
-
-;;; Current message name.
-;;; 
-
-(defun mh-current-message (folder)
-  "Returns the current MH message from the folder's sequence file."
-  (declare (simple-string folder))
-  (let ((folder (strip-folder-name folder)))
-    (mh-profile-component
-     "cur"
-     (merge-pathnames ".mh_sequences"
-		      (merge-relative-pathnames folder
-						(mh-directory-pathname))))))
-
-
-;;; Context pathname.
-;;; 
-
-(defvar *mh-context-pathname* nil)
-
-(defun mh-context-pathname ()
-  "Returns the pathname of the MH context file."
-  (or *mh-context-pathname*
-      (setf *mh-context-pathname*
-	    (merge-pathnames (or (mh-profile-component "context") "context")
-			     (mh-directory-pathname)))))
-
-
-;;; MH directory pathname.
-;;; 
-
-(defvar *mh-directory-pathname* nil)
-
-;;; MH-DIRECTORY-PATHNAME fetches the "path" MH component and bashes it
-;;; appropriately to get an absolute directory pathname.  
-;;; 
-(defun mh-directory-pathname ()
-  "Returns the pathname of the MH directory."
-  (if *mh-directory-pathname*
-      *mh-directory-pathname*
-      (let ((path (mh-profile-component "path")))
-	(unless path (error "MH profile does not contain a Path component."))
-	(setf *mh-directory-pathname*
-	      (merge-relative-pathnames path (user-homedir-pathname))))))
-
-;;; Profile components.
-;;; 
-
-(defun mh-profile-component (name &optional (pathname (mh-profile-pathname))
-				            (error-on-open t))
-  "Returns the trimmed string value for the MH profile component name.  If
-   the component is not present, nil is returned.  This may be used on MH
-   context and sequence files as well due to their having the same format.
-   Error-on-open indicates that errors generated by OPEN should not be ignored,
-   which is the default.  When opening a sequence file, it is better to supply
-   this as nil since the file may not exist or be readable in another user's
-   MH folder, and returning nil meaning the sequence could not be found is just
-   as useful."
-  (with-open-stream (s (if error-on-open
-			   (open pathname)
-			   (ignore-errors (open pathname))))
-    (if s
-	(loop
-	  (multiple-value-bind (line eofp) (read-line s nil :eof)
-	    (when (eq line :eof) (return nil))
-	    (let ((colon (position #\: (the simple-string line) :test #'char=)))
-	      (unless colon
-		(error "Bad record ~S in file ~S." line (namestring pathname)))
-	      (when (string-equal name line :end2 colon)
-		(return (string-trim '(#\space #\tab)
-				     (subseq line (1+ colon))))))
-	    (when eofp (return nil)))))))
-
-
-;;; Profile pathname.
-;;; 
-
-(defvar *mh-profile-pathname* nil)
-
-(defun mh-profile-pathname ()
-  "Returns the pathname of the MH profile."
-  (or *mh-profile-pathname*
-      (setf *mh-profile-pathname*
-	    (merge-pathnames (or (cdr (assoc :mh ext:*environment-list*))
-				 ".mh_profile")
-			     (user-homedir-pathname)))))
-
-
-
-;;;; Sequence handling.
-
-(defun mark-one-message (folder msg sequence add-or-delete)
-  "Msg is added or deleted to the sequence named sequence in the folder's
-   \".mh_sequence\" file.  Add-or-delete is either :add or :delete."
-  (let ((seq-list (mh-sequence-list folder sequence)))
-    (ecase add-or-delete
-      (:add
-       (write-mh-sequence folder sequence (mh-sequence-insert msg seq-list)))
-      (:delete
-       (when (mh-sequence-member-p msg seq-list)
-	 (write-mh-sequence folder sequence
-			    (mh-sequence-delete msg seq-list)))))))
-
-
-(defun mh-sequence-list (folder name)
-  "Returns a list representing the messages and ranges of id's for the
-   sequence name in folder from the \".mh_sequences\" file.  A second value
-   is returned indicating whether the sequence was found or not."
-  (declare (simple-string folder))
-  (let* ((folder (strip-folder-name folder))
-	 (seq-string (mh-profile-component
-		      name
-		      (merge-pathnames ".mh_sequences"
-				       (merge-relative-pathnames
-					folder (mh-directory-pathname)))
-		      nil)))
-    (if (not seq-string)
-	(values nil nil)
-	(let ((length (length (the simple-string seq-string)))
-	      (result ())
-	      (intervalp nil)
-	      (start 0))
-	  (declare (fixnum length start))
-	  (loop
-	    (multiple-value-bind (msg index)
-				 (parse-integer seq-string
-						:start start :end length
-						:junk-allowed t)
-	      (unless msg (return))
-	      (cond ((or (= index length)
-			 (char/= (schar seq-string index) #\-))
-		     (if intervalp
-			 (setf (cdar result) msg)
-			 (push (cons msg msg) result))
-		     (setf intervalp nil)
-		     (setf start index))
-		    (t
-		     (push (cons msg nil) result)
-		     (setf intervalp t)
-		     (setf start (1+ index)))))
-	    (when (>= start length) (return)))
-	  (values (nreverse result) t)))))
-
-(defun write-mh-sequence (folder name seq-list)
-  "Writes seq-list to folder's \".mh_sequences\" file.  If seq-list is nil,
-   the sequence is removed from the file."
-  (declare (simple-string folder))
-  (let* ((folder (strip-folder-name folder))
-	 (input (merge-pathnames ".mh_sequences"
-				 (merge-relative-pathnames
-				  folder (mh-directory-pathname))))
-	 (input-dir (pathname (directory-namestring input)))
-	 (output (loop (let* ((sym (gensym))
-			      (f (merge-pathnames
-				  (format nil "sequence-file-~A.tmp" sym)
-				  input-dir)))
-			 (unless (probe-file f) (return f)))))
-	 (found nil))
-    (cond ((not (file-writable output))
-	   (loud-message "Cannot write sequence temp file ~A.~%~
-	                  Aborting output of ~S sequence."
-			 name (namestring output)))
-	  (t
-	   (with-open-file (in input)
-	     (with-open-file (out output :direction :output)
-	       (loop
-		 (multiple-value-bind (line eofp) (read-line in nil :eof)
-		   (when (eq line :eof)
-		     (return nil))
-		   (let ((colon (position #\: (the simple-string line)
-					  :test #'char=)))
-		     (unless colon
-		       (error "Bad record ~S in file ~S."
-			      line (namestring input)))
-		     (cond ((and (not found) (string-equal name line
-							   :end2 colon))
-			    (sub-write-mh-sequence
-			     out (subseq line 0 colon) seq-list)
-			    (setf found t))
-			   (t (write-line line out))))
-		   (when eofp (return))))
-	       (unless found
-		 (fresh-line out)
-		 (sub-write-mh-sequence out name seq-list))))
-	   (hacking-rename-file output input)))))
-
-(defun sub-write-mh-sequence (stream name seq-list)
-  (when seq-list
-    (write-string name stream)
-    (write-char #\: stream)
-    (let ((*print-base* 10))
-      (dolist (range seq-list)
-	(write-char #\space stream)
-	(let ((low (car range))
-	      (high (cdr range)))
-	  (declare (fixnum low high))
-	  (cond ((= low high)
-		 (prin1 low stream))
-		(t (prin1 low stream)
-		   (write-char #\- stream)
-		   (prin1 high stream))))))
-    (terpri stream)))
-
-
-;;; MH-SEQUENCE-< keeps SORT from consing rest args when FUNCALL'ing #'<.
-;;;
-(defun mh-sequence-< (x y)
-  (< x y))
-
-(defun mh-sequence-insert (item seq-list)
-  "Inserts item into an mh sequence list.  Item can be a string (\"23\"),
-   number (23), or a cons of two numbers ((23 . 23) or (3 . 5))."
-  (let ((range (typecase item
-		 (string (let ((id (parse-integer item)))
-			   (cons id id)))
-		 (cons item)
-		 (number (cons item item)))))
-    (cond (seq-list
-	   (setf seq-list (sort (cons range seq-list)
-				#'mh-sequence-< :key #'car))
-	   (coelesce-mh-sequence-ranges seq-list))
-	  (t (list range)))))
-
-(defun coelesce-mh-sequence-ranges (seq-list)
-  (when seq-list
-    (let* ((current seq-list)
-	   (next (cdr seq-list))
-	   (current-range (car current))
-	   (current-end (cdr current-range)))
-      (declare (fixnum current-end))
-      (loop
-	(unless next
-	  (setf (cdr current-range) current-end)
-	  (setf (cdr current) nil)
-	  (return))
-	(let* ((next-range (car next))
-	       (next-start (car next-range))
-	       (next-end (cdr next-range)))
-	  (declare (fixnum next-start next-end))
-	  (cond ((<= (1- next-start) current-end)
-		 ;;
-		 ;; Extend the current range since the next one overlaps.
-		 (when (> next-end current-end)
-		   (setf current-end next-end)))
-		(t
-		 ;;
-		 ;; Update the current range since the next one doesn't overlap.
-		 (setf (cdr current-range) current-end)
-		 ;;
-		 ;; Make the next range succeed current.  Then make it current.
-		 (setf (cdr current) next)
-		 (setf current next)
-		 (setf current-range next-range)
-		 (setf current-end next-end))))
-	(setf next (cdr next))))
-    seq-list))
-
-
-(defun mh-sequence-delete (item seq-list)
-  "Inserts item into an mh sequence list.  Item can be a string (\"23\"),
-   number (23), or a cons of two numbers ((23 . 23) or (3 . 5))."
-  (let ((range (typecase item
-		 (string (let ((id (parse-integer item)))
-			   (cons id id)))
-		 (cons item)
-		 (number (cons item item)))))
-    (when seq-list
-      (do ((id (car range) (1+ id))
-	   (end (cdr range)))
-	  ((> id end))
-	(setf seq-list (sub-mh-sequence-delete id seq-list)))
-      seq-list)))
-
-(defun sub-mh-sequence-delete (id seq-list)
-  (do ((prev nil seq)
-       (seq seq-list (cdr seq)))
-      ((null seq))
-    (let* ((range (car seq))
-	   (low (car range))
-	   (high (cdr range)))
-      (cond ((> id high))
-	    ((< id low)
-	     (return))
-	    ((= id low)
-	     (cond ((/= low high)
-		    (setf (car range) (1+ id)))
-		   (prev
-		    (setf (cdr prev) (cdr seq)))
-		   (t (setf seq-list (cdr seq-list))))
-	     (return))
-	    ((= id high)
-	     (setf (cdr range) (1- id))
-	     (return))
-	    ((< low id high)
-	     (setf (cdr range) (1- id))
-	     (setf (cdr seq) (cons (cons (1+ id) high) (cdr seq)))
-	     (return)))))
-  seq-list)
-
-
-(defun mh-sequence-member-p (item seq-list)
-  "Returns to or nil whether item is in the mh sequence list.  Item can be a
-   string (\"23\") or a number (23)."
-  (let ((id (typecase item
-	      (string (parse-integer item))
-	      (number item))))
-    (dolist (range seq-list nil)
-      (let ((low (car range))
-	    (high (cdr range)))
-	(when (<= low id high) (return t))))))
-
-
-(defun mh-sequence-strings (seq-list)
-  "Returns a list of strings representing the ranges and messages id's in
-   seq-list."
-  (let ((result nil))
-    (dolist (range seq-list)
-      (let ((low (car range))
-	    (high (cdr range)))
-	(if (= low high)
-	    (push (number-string low) result)
-	    (push (format nil "~D-~D" low high) result))))
-    (nreverse result)))
-
-
-
-;;;; CMU Common Lisp support.
-
-;;; HACKING-RENAME-FILE renames old to new.  This is used instead of Common
-;;; Lisp's RENAME-FILE because it merges new pathname with old pathname,
-;;; which loses when old has a name and type, and new has only a type (a
-;;; Unix-oid "dot" file).
-;;;
-(defun hacking-rename-file (old new)
-  (let ((ses-name1 (namestring old))
-	(ses-name2 (namestring new)))
-    (multiple-value-bind (res err) (mach:unix-rename ses-name1 ses-name2)
-      (unless res
-	(error "Failed to rename ~A to ~A: ~A."
-	       ses-name1 ses-name2 (mach:get-unix-error-msg err))))))
-
-
-;;; Folder existence and creation.
-;;;
-
-(defun folder-existsp (folder)
-  "Returns t if the directory for folder exists.  Folder is a simple-string
-   specifying a folder name relative to the MH mail directoy."
-  (declare (simple-string folder))
-  (let* ((folder (strip-folder-name folder))
-	 (pathname (merge-relative-pathnames folder (mh-directory-pathname)))
-	 (ses-name (namestring pathname)))
-    (multiple-value-bind (winp type)
-			 (mach:unix-subtestname ses-name)
-      (and winp (eq type :entry_directory)))))
-
-(defun create-folder (folder)
-  "Creates folder directory with default protection #o711 but considers the
-   MH profile for the \"Folder-Protect\" component.  Folder is a simple-string
-   specifying a folder name relative to the MH mail directory."
-  (declare (simple-string folder))
-  (let* ((folder (strip-folder-name folder))
-	 (pathname (merge-relative-pathnames folder (mh-directory-pathname)))
-	 (ses-name (namestring pathname))
-	 (length-1 (1- (length ses-name)))
-	 (name (if (= (position #\/ ses-name :test #'char= :from-end t)
-		      length-1)
-		   (subseq ses-name 0 (1- (length ses-name)))
-		   ses-name))
-	 (protection (mh-profile-component "folder-protect")))
-    (when protection
-      (setf protection
-	    (parse-integer protection :radix 8 :junk-allowed t)))
-    (multiple-value-bind (winp err)
-			 (mach:unix-mkdir name (or protection #o711))
-      (unless winp
-	(error "Couldn't make directory ~S: ~A"
-	       name
-	       (mach:get-unix-error-msg err)))
-      (check-folder-name-table)
-      (setf (getstring folder *folder-name-table*) t))))
-
-
-;;; Checking for mail.
-;;;
-
-(defvar *mailbox* nil)
-
-(defun new-mail-p ()
- (unless *mailbox*
-   (setf *mailbox*
-	 (probe-file (or (cdr (assoc :mail ext:*environment-list*))
-			 (cdr (assoc :maildrop ext:*environment-list*))
-			 (mh-profile-component "mail-drop")
-			 (merge-pathnames
-			  (cdr (assoc :user ext:*environment-list*))
-			  "/usr/spool/mail/")))))
-  (when *mailbox*
-    (multiple-value-bind (success dev ino mode nlink uid gid rdev size
-			  atime)
-			 (mach:unix-stat (namestring *mailbox*))
-      (declare (ignore dev ino nlink uid gid rdev atime))
-      (and success
-	   (plusp (logand mach::s_ifreg mode))
-	   (not (zerop size))))))
-
-
-
diff --git a/hemlock/morecoms.lisp b/hemlock/morecoms.lisp
deleted file mode 100644
index a07e07a234dba3aae0af546d1c9c48a6d6b83941..0000000000000000000000000000000000000000
--- a/hemlock/morecoms.lisp
+++ /dev/null
@@ -1,858 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;; Written by Bill Chiles and Rob MacLachlan.
-;;;
-;;; Even more commands...
-
-(in-package "HEMLOCK")
-
-(defhvar "Region Query Size"
-  "A number-of-lines threshold that destructive, undoable region commands
-   should ask the user about when the indicated region is too big."
-  :value 30)
-
-(defun check-region-query-size (region)
-  "Checks the number of lines in region against \"Region Query Size\" and
-   asks the user if the region crosses this threshold.  If the user responds
-   negatively, then an editor error is signaled."
-  (let ((threshold (or (value region-query-size) 0)))
-    (if (and (plusp threshold)
-	     (>= (count-lines region) threshold)
-	     (not (prompt-for-y-or-n
-		   :prompt "Region size exceeds \"Region Query Size\".  Confirm: "
-		   :must-exist t)))
-	(editor-error))))
-
-
-
-;;;; Casing commands...
-
-(defcommand "Uppercase Word" (p)
-  "Uppercase a word at point.
-   With prefix argument uppercase that many words."
-  "Uppercase p words at the point."
-  (filter-words p (current-point) #'string-upcase))
-
-(defcommand "Lowercase Word" (p)
-  "Uppercase a word at point.
-   With prefix argument uppercase that many words."
-  "Uppercase p words at the point."
-  (filter-words p (current-point) #'string-downcase))
-
-;;; FILTER-WORDS implements "Uppercase Word" and "Lowercase Word".
-;;;
-(defun filter-words (p point function)
-  (let ((arg (or p 1)))
-    (with-mark ((mark point))
-      (if (word-offset (if (minusp arg) mark point) arg)
-	  (filter-region function (region mark point))
-	  (editor-error "Not enough words.")))))
-
-;;; "Capitalize Word" is different than uppercasing and lowercasing because
-;;; the differences between Hemlock's notion of what a word is and Common
-;;; Lisp's notion are too annoying.
-;;;
-(defcommand "Capitalize Word" (p)
-  "Lowercase a word capitalizing the first character.  With a prefix
-  argument, capitalize that many words.  A negative argument capitalizes
-  words before the point, but leaves the point where it was."
-  "Capitalize p words at the point."
-  (let ((point (current-point))
-	(arg (or p 1)))
-    (with-mark ((start point :left-inserting)
-		(end point))
-      (when (minusp arg)
-	(unless (word-offset start arg) (editor-error "No previous word.")))
-      (do ((region (region start end))
-	   (cnt (abs arg) (1- cnt)))
-	  ((zerop cnt) (move-mark point end))
-	(unless (find-attribute start :word-delimiter #'zerop)
-	  (editor-error "No next word."))
-	(move-mark end start)
-	(find-attribute end :word-delimiter)
-	(loop
-	  (when (mark= start end)
-	    (move-mark point end)
-	    (editor-error "No alphabetic characters in word."))
-	  (when (alpha-char-p (next-character start)) (return))
-	  (character-offset start 1))
-	(setf (next-character start) (char-upcase (next-character start)))
-	(mark-after start)
-	(filter-region #'string-downcase region)))))
-
-(defcommand "Uppercase Region" (p)
-  "Uppercase words from point to mark."
-  "Uppercase words from point to mark."
-  (declare (ignore p))
-  (twiddle-region (current-region) #'string-upcase "Uppercase Region"))
-
-(defcommand "Lowercase Region" (p)
-  "Lowercase words from point to mark."
-  "Lowercase words from point to mark."
-  (declare (ignore p))
-  (twiddle-region (current-region) #'string-downcase "Lowercase Region"))
-
-;;; TWIDDLE-REGION implements "Uppercase Region" and "Lowercase Region".
-;;;
-(defun twiddle-region (region function name)
-  (let* (;; don't delete marks start and end since undo stuff will.
-	 (start (copy-mark (region-start region) :left-inserting))
-	 (end (copy-mark (region-end region) :left-inserting)))
-    (let* ((region (region start end))
-	   (undo-region (copy-region region)))
-      (check-region-query-size region)
-      (filter-region function region)
-      (make-region-undo :twiddle name region undo-region))))
-
-
-
-;;;; More stuff.
-
-(defcommand "Delete Previous Character Expanding Tabs" (p)
-  "Delete the previous character.
-  When deleting a tab pretend it is the equivalent number of spaces.
-  With prefix argument, do it that many times."
-  "Delete the P previous characters, expanding tabs into spaces."
-  (let ((point (current-point))
-        (n (or p 1)))
-    (when (minusp n)
-      (editor-error "Delete Previous Character Expanding Tabs only accepts ~
-                     positive arguments."))
-    (let ((errorp nil))
-      (with-mark ((mark point :left-inserting))
-	(dotimes (i n)
-	  (cond ((char= (previous-character mark) #\tab)
-		 (let ((pos (mark-column mark)))
-		   (delete-characters mark -1)
-		   (dotimes (i (- pos (mark-column mark)))
-		     (insert-character mark #\space))
-		   (mark-before mark)))
-		((mark-before mark))
-		(t (return)))))
-      (kill-characters point (- n))
-      (when errorp
-	(editor-error "There were not ~D characters before point." n)))))
-
-
-(defvar *scope-table*
-  (list (make-string-table :initial-contents
-			   '(("Global" . :global)
-			     ("Buffer" . :buffer)
-			     ("Mode" . :mode)))))
-
-(defun prompt-for-place (prompt help)
-  (multiple-value-bind (word val)
-		       (prompt-for-keyword *scope-table* :prompt prompt
-					   :help help :default "Global")
-    (declare (ignore word))
-    (case val
-      (:buffer
-       (values :buffer (prompt-for-buffer :help "Buffer to be local to."
-					  :default (current-buffer))))
-      (:mode
-       (values :mode (prompt-for-keyword 
-		      (list *mode-names*)
-		      :prompt "Mode: "
-		      :help "Mode to be local to."
-		      :default (buffer-major-mode (current-buffer)))))
-      (:global :global))))
-
-(defcommand "Bind Key" (p)
-  "Bind a command to a key.
-  The command, key and place to make the binding are prompted for."
-  "Prompt for stuff to do a bind-key."
-  (declare (ignore p))
-  (multiple-value-call #'bind-key 
-    (values (prompt-for-keyword
-	     (list *command-names*)
-	     :prompt "Command to bind: "
-	     :help "Name of command to bind to a key."))
-    (values (prompt-for-key 
-	     :prompt "Bind to: "  :must-exist nil
-	     :help "Key to bind command to, confirm to complete."))
-    (prompt-for-place "Kind of binding: "
-		      "The kind of binding to make.")))	    	    
-
-(defcommand "Delete Key Binding" (p)
-  "Delete a key binding.
-  The key and place to remove the binding are prompted for."
-  "Prompt for stuff to do a delete-key-binding."
-  (declare (ignore p))
-  (let ((key (prompt-for-key 
-	      :prompt "Delete binding: " :must-exist nil 
-	      :help "Key to delete binding from.")))
-    (multiple-value-bind (kind where)
-			 (prompt-for-place "Kind of binding: "
-					   "The kind of binding to make.")
-      (unless (get-command key kind where) 
-	(editor-error "No such binding: ~S" key))
-      (delete-key-binding key kind where))))
-
-
-(defcommand "Set Variable" (p)
-  "Prompt for a Hemlock variable and a new value."
-  "Prompt for a Hemlock variable and a new value."
-  (declare (ignore p))
-  (multiple-value-bind (name var)
-		       (prompt-for-variable
-			:prompt "Variable: "
-			:help "The name of a variable to set.")
-    (declare (ignore name))
-    (setf (variable-value var)
-	  (handle-lisp-errors
-	   (eval (prompt-for-expression
-		  :prompt "Value: "
-		  :help "Expression to evaluate for new value."))))))
-
-(defcommand "Defhvar" (p)
-  "Define a hemlock variable in some location.  If the named variable exists
-   currently, its documentation is propagated to the new instance, but this
-   never prompts for documentation."
-  "Define a hemlock variable in some location."
-  (declare (ignore p))
-  (let* ((name (nstring-capitalize (prompt-for-variable :must-exist nil)))
-	 (var (string-to-variable name))
-	 (doc (if (hemlock-bound-p var)
-		  (variable-documentation var)
-		  ""))
-	 (hooks (if (hemlock-bound-p var) (variable-hooks var)))
-	 (val (prompt-for-expression :prompt "Variable value: "
-				     :help "Value for the variable.")))
-    (multiple-value-bind
-	(kind where)
-	(prompt-for-place
-	 "Kind of binding: "
-	 "Whether the variable is global, mode, or buffer specific.")
-      (if (eq kind :global)
-	  (defhvar name doc :value val :hooks hooks)
-	  (defhvar name doc kind where :value val :hooks hooks)))))
-
-
-(defcommand "List Buffers" (p)
-  "Show a list of all buffers.
-   If the buffer is modified then a * is displayed before the name.  If there
-   is an associated file then it's name is displayed last.  With prefix
-   argument, only list modified buffers."
-  "Display the names of all buffers in a with-random-typeout window."
-  (with-pop-up-display (s)
-    (do-strings (n b *buffer-names*)
-      (declare (simple-string n))
-      (unless (or (eq b *echo-area-buffer*)
-		  (assoc b *random-typeout-buffers* :test #'eq))
-	(let ((modified (buffer-modified b))
-	      (buffer-pathname (buffer-pathname b)))
-	  (when (or (not p) modified)
-	    (write-char (if modified #\* #\space) s)
-	    (if buffer-pathname
-		(format s "~A  ~25T~A~:[~68T~A~;~]~%"
-			(file-namestring buffer-pathname)
-			(directory-namestring buffer-pathname)
-			(string= (pathname-to-buffer-name buffer-pathname) n)
-			n)
-		(format s "~A~68T~D Line~:P~%"
-			n (count-lines (buffer-region b))))))))))
-
-(defcommand "Select Random Typeout Buffer" (p)
-  "Select last random typeout buffer."
-  "Select last random typeout buffer."
-  (declare (ignore p))
-  (if *random-typeout-buffers*
-      (change-to-buffer (caar *random-typeout-buffers*))
-      (editor-error "There are no random typeout buffers.")))
-
-
-(defcommand "Room" (p)
-  "Display stats on allocated storage."
-  "Run Room into a With-Random-Typeout window."
-  (declare (ignore p))
-  (with-pop-up-display (*standard-output* :height 19)
-    (room)))
-
-
-;;; This is used by the :edit-level modeline field which is defined in Main.Lisp.
-;;;
-(defvar *recursive-edit-count* 0)
-
-(defun do-recursive-edit ()
-  "Does a recursive edit, wrapping []'s around the modeline of the current
-  window during its execution.  The current window and buffer are saved
-  beforehand and restored afterward.  If they have been deleted by the
-  time the edit is done then an editor-error is signalled."
-  (let* ((win (current-window))
-	 (buf (current-buffer)))
-    (unwind-protect
-	(let ((*recursive-edit-count* (1+ *recursive-edit-count*)))
-	  (update-modeline-field *echo-area-buffer* *echo-area-window*
-				 (modeline-field :edit-level))
-	  (recursive-edit))
-      (update-modeline-field *echo-area-buffer* *echo-area-window*
-			     (modeline-field :edit-level))
-      (unless (and (memq win *window-list*) (memq buf *buffer-list*))
-	(editor-error "Old window or buffer has been deleted."))
-      (setf (current-window) win)
-      (unless (eq (window-buffer win) buf)
-	(setf (window-buffer win) buf))
-      (setf (current-buffer) buf))))
-
-(defcommand "Exit Recursive Edit" (p)
-  "Exit a level of recursive edit.  Signals an error when not in a
-   recursive edit."
-  "Exit a level of recursive edit.  Signals an error when not in a
-   recursive edit."
-  (declare (ignore p))
-  (unless (in-recursive-edit) (editor-error "Not in a recursive edit!"))
-  (exit-recursive-edit ()))
-
-(defcommand "Abort Recursive Edit" (p)
-  "Abort the current recursive edit.  Signals an error when not in a
-   recursive edit."
-  "Abort the current recursive edit.  Signals an error when not in a
-   recursive edit."
-  (declare (ignore p))
-  (unless (in-recursive-edit) (editor-error "Not in a recursive edit!"))
-  (abort-recursive-edit "Recursive edit aborted."))
-
-
-;;; TRANSPOSE REGIONS uses CURRENT-REGION to signal an error if the current
-;;; region is not active and to get start2 and end2 in proper order.  Delete1,
-;;; delete2, and delete3 are necessary since we are possibly ROTATEF'ing the
-;;; locals end1/start1, start1/start2, and end1/end2, and we need to know which
-;;; marks to dispose of at the end of all this stuff.  When we actually get to
-;;; swapping the regions, we must delete both up front if they both are to be
-;;; deleted since we don't know what kind of marks are in start1, start2, end1,
-;;; and end2, and the marks will be moving around unpredictably as we insert
-;;; text at them.  We copy point into ipoint for insertion purposes since one
-;;; of our four marks is the point.
-;;; 
-(defcommand "Transpose Regions" (p)
-  "Transpose two regions with endpoints defined by the mark stack and point.
-   To use:  mark start of region1, mark end of region1, mark start of region2,
-   and place point at end of region2.  Invoking this immediately following
-   one use will put the regions back, but you will have to activate the
-   current region."
-  "Transpose two regions with endpoints defined by the mark stack and point."
-  (declare (ignore p))
-  (unless (>= (ring-length (value buffer-mark-ring)) 3)
-    (editor-error "Need two marked regions to do Transpose Regions."))
-  (let* ((region (current-region))
-	 (end2 (region-end region))
-	 (start2 (region-start region))
-	 (delete1 (pop-buffer-mark))
-	 (end1 (pop-buffer-mark))
-	 (delete2 end1)
-	 (start1 (pop-buffer-mark))
-	 (delete3 start1))
-    ;;get marks in the right order, to simplify the code that follows
-    (unless (mark<= start1 end1) (rotatef start1 end1))
-    (unless (mark<= start1 start2)
-      (rotatef start1 start2)
-      (rotatef end1 end2))
-    ;;order now guaranteed:  <Buffer Start> start1 end1 start2 end2 <Buffer End>
-    (unless (mark<= end1 start2)
-      (editor-error "Can't transpose overlapping regions."))
-    (let* ((adjacent-p (mark= end1 start2))
-	   (region1 (delete-and-save-region (region start1 end1)))
-	   (region2 (unless adjacent-p
-		      (delete-and-save-region (region start2 end2))))
-	   (point (current-point)))
-      (with-mark ((ipoint point :left-inserting))
-	(let ((save-end2-loc (push-buffer-mark (copy-mark end2))))
-	  (ninsert-region (move-mark ipoint end2) region1)
-	  (push-buffer-mark (copy-mark ipoint))
-	  (cond (adjacent-p
-		 (push-buffer-mark (copy-mark start2))
-		 (move-mark point save-end2-loc))
-		(t (push-buffer-mark (copy-mark end1))
-		   (ninsert-region (move-mark ipoint end1) region2)
-		   (move-mark point ipoint))))))
-    (delete-mark delete1)
-    (delete-mark delete2)
-    (delete-mark delete3)))
-
-
-(defcommand "Goto Absolute Line" (p)
-  "Goes to the indicated line, if you counted them starting at the beginning
-   of the buffer with the number one.  If a prefix argument is supplied, that
-   is the line numbe; otherwise, the user is prompted."
-  "Go to a user perceived line number."
-  (let ((p (or p (prompt-for-expression
-		  :prompt "Line number: "
-		  :help "Enter an absolute line number to goto."))))
-    (unless (and (integerp p) (plusp p))
-      (editor-error "Must supply a positive integer."))
-    (let ((point (current-point)))
-      (with-mark ((m point))
-	(unless (line-offset (buffer-start m) (1- p) 0)
-	  (editor-error "Not enough lines in buffer."))
-	(move-mark point m)))))
-
-
-
-;;;; Mouse Commands.
-
-(defcommand "Do Nothing" (p)
-  "Do nothing.
-  With prefix argument, do it that many times."
-  "Do nothing p times."
-  (dotimes (i (or p 1)))
-  (setf (last-command-type) (last-command-type)))
-
-(defun maybe-change-window (window)
-  (unless (eq window (current-window))
-    (when (or (eq window *echo-area-window*)
-	      (eq (current-window) *echo-area-window*)
-	      (member window *random-typeout-buffers*
-		      :key #'(lambda (cons)
-			       (hi::random-typeout-stream-window (cdr cons)))))
-      (supply-generic-pointer-up-function #'lisp::do-nothing)
-      (editor-error "I'm afraid I can't let you do that Dave."))
-    (setf (current-window) window)
-    (let ((buffer (window-buffer window)))
-      (unless (eq (current-buffer) buffer)
-	(setf (current-buffer) buffer)))))
-
-(defcommand "Top Line to Here" (p)
-  "Move the top line to the line the mouse is on.
-  If in the first two columns then scroll continuously until the button is
-  released."
-  "Move the top line to the line the mouse is on."
-  (declare (ignore p))
-  (multiple-value-bind (x y window)
-		       (last-key-event-cursorpos)
-    (unless y (editor-error))
-    (cond ((< x 2)
-	   (loop
-	     (when (listen-editor-input *editor-input*) (return))
-	     (scroll-window window -1)
-	     (redisplay)
-	     (editor-finish-output window)))
-	  (t
-	   (scroll-window window (- y))))))
-
-(defcommand "Here to Top of Window" (p)
-  "Move the line the mouse is on to the top of the window.
-  If in the first two columns then scroll continuously until the button is
-  released."
-  "Move the line the mouse is on to the top of the window."
-  (declare (ignore p))
-  (multiple-value-bind (x y window)
-		       (last-key-event-cursorpos)
-    (unless y (editor-error))
-    (cond ((< x 2)
-	   (loop
-	     (when (listen-editor-input *editor-input*) (return))
-	     (scroll-window window 1)
-	     (redisplay)
-	     (editor-finish-output window)))
-	  (t
-	   (scroll-window window y)))))
-
-
-(defvar *generic-pointer-up-fun* nil
-  "This is the function for the \"Generic Pointer Up\" command that defines
-   its action.  Other commands set this in preparation for this command's
-   invocation.")
-;;;
-(defun supply-generic-pointer-up-function (fun)
-  "This provides the action \"Generic Pointer Up\" command performs."
-  (check-type fun function)
-  (setf *generic-pointer-up-fun* fun))
-
-(defcommand "Generic Pointer Up" (p)
-  "Other commands determine this command's action by supplying functions that
-   this command invokes.  The following built-in commands supply the following
-   generic up actions:
-      \"Point to Here\"
-         When the position of the pointer is different than the current
-	 point, the action pushes a buffer mark at point and moves point
-         to the pointer's position.
-      \"Bufed Goto and Quit\"
-         The action is a no-op."
-  "Invoke whatever is on *generic-pointer-up-fun*."
-  (declare (ignore p))
-  (unless *generic-pointer-up-fun*
-    (editor-error "No commands have supplied a \"Generic Pointer Up\" action."))
-  (funcall *generic-pointer-up-fun*))
-
-
-(defcommand "Point to Here" (p)
-  "Move the point to the position of the mouse.
-   If in the modeline, move to the absolute position in the file indicated by
-   the position within the modeline, pushing the old position on the mark
-   stack.  This supplies a function \"Generic Pointer Up\" invokes if it runs
-   without any intervening generic pointer up predecessors running.  If the
-   position of the pointer is different than the current point when the user
-   invokes \"Generic Pointer Up\", then this function pushes a buffer mark at
-   point and moves point to the pointer's position.  This allows the user to
-   mark off a region with the mouse."
-  "Move the point to the position of the mouse."
-  (declare (ignore p))
-  (multiple-value-bind (x y window)
-		       (last-key-event-cursorpos)
-    (unless x (editor-error))
-    (maybe-change-window window)
-    (if y
-	(let ((m (cursorpos-to-mark x y window)))
-	  (unless m (editor-error))
-	  (move-mark (current-point) m))
-	(let* ((buffer (window-buffer window))
-	       (region (buffer-region buffer))
-	       (point (buffer-point buffer)))
-	  (push-buffer-mark (copy-mark point))
-	  (move-mark point (region-start region))
-	  (line-offset point (round (* (1- (count-lines region)) x)
-				    (1- (window-width window)))))))
-  (supply-generic-pointer-up-function #'point-to-here-up-action))
-
-(defun point-to-here-up-action ()
-  (multiple-value-bind (x y window)
-		       (last-key-event-cursorpos)
-    (unless x (editor-error))
-    (when y
-      (maybe-change-window window)
-      (let ((m (cursorpos-to-mark x y window)))
-	(unless m (editor-error))
-	(when (eq (line-buffer (mark-line (current-point)))
-		  (line-buffer (mark-line m)))
-	  (unless (mark= m (current-point))
-	    (push-buffer-mark (copy-mark (current-point)) t)))
-	(move-mark (current-point) m)))))
-
-
-(defcommand "Insert Kill Buffer" (p)
-  "Move current point to the mouse location and insert the kill buffer."
-  "Move current point to the mouse location and insert the kill buffer."
-  (declare (ignore p))
-  (multiple-value-bind (x y window)
-		       (last-key-event-cursorpos)
-    (unless x (editor-error))
-    (maybe-change-window window)
-    (if y
-	(let ((m (cursorpos-to-mark x y window)))
-	  (unless m (editor-error))
-	  (move-mark (current-point) m)
-	  (un-kill-command nil))
-	(editor-error "Can't insert kill buffer in modeline."))))
-
-
-
-;;;; Page commands & stuff.
-
-(defvar *goto-page-last-num* 0)
-(defvar *goto-page-last-string* "")
-
-(defcommand "Goto Page" (p)
-  "Go to an absolute page number (argument).  If no argument, then go to
-  next page.  A negative argument moves back that many pages if possible.
-  If argument is zero, prompt for string and goto page with substring
-  in title."
-  "Go to an absolute page number (argument).  If no argument, then go to
-  next page.  A negative argument moves back that many pages if possible.
-  If argument is zero, prompt for string and goto page with substring
-  in title."
-  (let ((point (current-point)))
-    (cond ((not p)
-	   (page-offset point 1))
-	  ((zerop p)
-	   (let* ((againp (eq (last-command-type) :goto-page-zero))
-		  (name (prompt-for-string :prompt "Substring of page title: "
-					   :default (if againp
-							*goto-page-last-string*
-							*parse-default*)))
-		  (dir (page-directory (current-buffer)))
-		  (i 1))
-	     (declare (simple-string name))
-	     (cond ((not againp)
-		    (push-buffer-mark (copy-mark point)))
-		   ((string-equal name *goto-page-last-string*)
-		    (setf dir (nthcdr *goto-page-last-num* dir))
-		    (setf i (1+ *goto-page-last-num*))))
-	     (loop 
-	       (when (null dir)
-		 (editor-error "No page title contains ~S." name))
-	       (when (search name (the simple-string (car dir))
-			     :test #'char-equal)
-		 (goto-page point i)
-		 (setf (last-command-type) :goto-page-zero)
-		 (setf *goto-page-last-num* i)
-		 (setf *goto-page-last-string* name)
-		 (return t))
-	       (incf i)
-	       (setf dir (cdr dir)))))
-	    ((minusp p)
-	     (page-offset point p))
-	    (t (goto-page point p)))
-    (line-start (move-mark (window-display-start (current-window)) point))))
-
-(defun goto-page (mark i)
-  (with-mark ((m mark))
-    (buffer-start m)
-    (unless (page-offset m (1- i))
-      (editor-error "No page numbered ~D." i))
-    (move-mark mark m)))
-
-			   
-(defcommand "View Page Directory" (p)
-  "Print a listing of the first non-blank line after each page mark
-   in a pop-up window."
-  "Print a listing of the first non-blank line after each page mark
-   in a pop-up window."
-  (declare (ignore p))
-  (let ((dir (page-directory (current-buffer))))
-    (declare (list dir))
-    (with-pop-up-display (s :height (1+ (the fixnum (length dir))))
-      (display-page-directory s dir))))
-
-(defcommand "Insert Page Directory" (p)
-  "Insert a listing of the first non-blank line after each page mark at
-   the beginning of the buffer.  A mark is dropped before going to the
-   beginning of the buffer.  If an argument is supplied, insert the page
-   directory at point."
-  "Insert a listing of the first non-blank line after each page mark at
-   the beginning of the buffer."
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (unless p
-      (push-buffer-mark (copy-mark point))
-      (buffer-start point))
-    (push-buffer-mark (copy-mark point))
-    (display-page-directory (make-hemlock-output-stream point :full)
-			    (page-directory (current-buffer))))
-  (setf (last-command-type) :ephemerally-active))
-
-(defun display-page-directory (stream directory)
-  "This writes the list of strings, directory, to stream, enumerating them
-   in a field of three characters.  The number and string are separated by
-   two spaces, and the first line contains headings for the numbers and
-   strings columns."
-  (write-line "Page    First Non-blank Line" stream)
-  (do ((dir directory (cdr dir))
-       (count 1 (1+ count)))
-      ((null dir))
-    (declare (fixnum count))
-    (format stream "~3D  " count)
-    (write-line (car dir) stream)))
-
-(defun page-directory (buffer)
-  "Return a list of strings where each is the first non-blank line
-   following a :page-delimiter in buffer."
-  (with-mark ((m (buffer-point buffer)))
-    (buffer-start m)
-    (let ((end-of-buffer (buffer-end-mark buffer)) result)
-      (loop ;over pages.
-	(loop ;for first non-blank line.
-	  (cond ((not (blank-after-p m))
-		 (let* ((str (line-string (mark-line m)))
-			(len (length str)))
-		   (declare (simple-string str))
-		   (push (if (and (> len 1)
-				  (= (character-attribute :page-delimiter
-							  (schar str 0))
-				     1))
-			     (subseq str 1)
-			     str)
-			 result))
-		 (unless (page-offset m 1)
-		   (return-from page-directory (nreverse result)))
-		 (when (mark= m end-of-buffer)
-		   (return-from page-directory (nreverse result)))
-		 (return))
-		((not (line-offset m 1 0))
-		 (return-from page-directory (nreverse result)))
-		((= (character-attribute :page-delimiter (next-character m))
-		    1)
-		 (push "" result)
-		 (mark-after m)
-		 (return))))))))
-
-
-(defcommand "Previous Page" (p)
-  "Move to the beginning of the current page.
-  With prefix argument move that many pages."
-  "Move backward P pages."
-  (let ((point (current-point)))
-    (unless (page-offset point (- (or p 1)))
-      (editor-error "No such page."))
-    (line-start (move-mark (window-display-start (current-window)) point))))
-
-(defcommand "Next Page" (p)
-  "Move to the beginning of the next page.
-  With prefix argument move that many pages."
-  "Move forward P pages."
-  (let ((point (current-point)))
-    (unless (page-offset point (or p 1))
-      (editor-error "No such page."))
-    (line-start (move-mark (window-display-start (current-window)) point))))
-
-(defcommand "Mark Page" (p)
-  "Put point at beginning, mark at end of current page.
-   With prefix argument, mark the page that many pages after the current one."
-  "Mark the P'th page after the current one."
-  (let ((point (current-point)))
-    (if p
-	(unless (page-offset point (1+ p)) (editor-error "No such page."))
-	(page-offset point 1)) ;If this loses, we're at buffer-end.
-    (with-mark ((m point))
-      (unless (page-offset point -1)
-	(editor-error "No such page."))
-      (push-buffer-mark (copy-mark m) t)
-      (line-start (move-mark (window-display-start (current-window)) point)))))
-
-(defun page-offset (mark n)
-  "Move mark past n :page-delimiters that are in the zero'th line position.
-   If a :page-delimiter is the immediately next character after mark in the
-   appropriate direction, then skip it before starting."
-  (cond ((plusp n)
-	 (find-attribute mark :page-delimiter #'zerop)
-	 (dotimes (i n mark)
-	   (unless (next-character mark) (return nil))
-	   (loop
-	     (unless (find-attribute mark :page-delimiter)
-	       (return-from page-offset nil))
-	     (unless (mark-after mark)
-	       (return (if (= i (1- n)) mark)))
-	     (when (= (mark-charpos mark) 1) (return)))))
-	(t
-	 (reverse-find-attribute mark :page-delimiter #'zerop)
-	 (prog1
-	  (dotimes (i (- n) mark)
-	    (unless (previous-character mark) (return nil))
-	    (loop
-	      (unless (reverse-find-attribute mark :page-delimiter)
-		(return-from page-offset nil))
-	      (mark-before mark)
-	      (when (= (mark-charpos mark) 0) (return))))
-	  (let ((buffer (line-buffer (mark-line mark))))
-	    (unless (or (not buffer) (mark= mark (buffer-start-mark buffer)))
-	      (mark-after mark)))))))
-
-
-
-;;;; Counting some stuff
-
-(defcommand "Count Lines Page" (p)
-  "Display number of lines in current page and position within page.
-   With prefix argument do on entire buffer."
-  "Count some lines, Man."
-  (let ((point (current-point)))
-    (if p
-	(let ((r (buffer-region (current-buffer))))
-	  (count-lines-function "Buffer" (region-start r) point (region-end r)))
-	(with-mark ((m1 point)
-		    (m2 point))
-	  (unless (and (= (character-attribute :page-delimiter
-					       (previous-character m1))
-			  1)
-		       (= (mark-charpos m1) 1))
-	    (page-offset m1 -1))
-	  (unless (and (= (character-attribute :page-delimiter
-					       (next-character m2))
-			  1)
-		       (= (mark-charpos m2) 0))
-	    (page-offset m2 1))
-	  (count-lines-function "Page" m1 point m2)))))
-
-(defun count-lines-function (msg start mark end)
-  (let ((before (1- (count-lines (region start mark))))
-	(after (count-lines (region mark end))))
-    (message "~A: ~D lines, ~D/~D" msg (+ before after) before after)))
-
-(defcommand "Count Lines" (p)
-  "Display number of lines in the region."
-  "Display number of lines in the region."
-  (declare (ignore p))
-  (multiple-value-bind (region activep) (get-count-region)
-    (message "~:[After point~;Active region~]: ~A lines"
-	     activep (count-lines region))))
-
-(defcommand "Count Words" (p)
-  "Prints in the Echo Area the number of words in the region
-   between the point and the mark by using word-offset. The
-   argument is ignored."
-  "Prints Number of Words in the Region"
-  (declare (ignore p))
-  (multiple-value-bind (region activep) (get-count-region)
-    (let ((end-mark (region-end region)))
-      (with-mark ((beg-mark (region-start region)))
-	(let ((word-count 0))
-	  (loop
-	    (when (mark>= beg-mark end-mark)
-	      (return))
-	    (unless (word-offset beg-mark 1)
-	      (return))
-	    (incf word-count))
-	  (message "~:[After point~;Active region~]: ~D Word~:P"
-		   activep word-count))))))
-
-;;; GET-COUNT-REGION -- Internal Interface.
-;;;
-;;; Returns the active region or the region between point and end-of-buffer.
-;;; As a second value, it returns whether the region was active.
-;;;
-;;; Some searching commands use this routine.
-;;;
-(defun get-count-region ()
-  (if (region-active-p)
-      (values (current-region) t)
-      (values (region (current-point) (buffer-end-mark (current-buffer)))
-	      nil)))
-
-
-
-;;;; Some modes:
-
-(defcommand "Fundamental Mode" (p)
-  "Put the current buffer into \"Fundamental\" mode."
-  "Put the current buffer into \"Fundamental\" mode."
-  (declare (ignore p))
-  (setf (buffer-major-mode (current-buffer)) "Fundamental"))
-
-;;;
-;;; Text mode.
-;;;
-
-(defmode "Text" :major-p t)
-
-(defcommand "Text Mode" (p)
-  "Put the current buffer into \"Text\" mode."
-  "Put the current buffer into \"Text\" mode."
-  (declare (ignore p))
-  (setf (buffer-major-mode (current-buffer)) "Text"))
-
-;;;
-;;; Caps-lock mode.
-;;;
-
-(defmode "CAPS-LOCK")
-
-(defcommand "Caps Lock Mode" (p)
-  "Simulate having a CAPS LOCK key.  Toggle CAPS-LOCK mode.  Zero or a
-   negative argument turns it off, while a positive argument turns it
-   on."
-  "Simulate having a CAPS LOCK key.  Toggle CAPS-LOCK mode.  Zero or a
-   negative argument turns it off, while a positive argument turns it
-   on."
-  (setf (buffer-minor-mode (current-buffer) "CAPS-LOCK")
-	(if p
-	    (plusp p)
-	    (not (buffer-minor-mode (current-buffer) "CAPS-LOCK")))))
-
-(defcommand "Self Insert Caps Lock" (p)
-  "Insert the last character typed, or the argument number of them.
-   If the last character was an alphabetic character, then insert its
-   capital form."
-  "Insert the last character typed, or the argument number of them.
-   If the last character was an alphabetic character, then insert its
-   capital form."
-  (let ((char (char-upcase (ext:key-event-char *last-key-event-typed*))))
-    (if (and p (> p 1))
-	(insert-string (current-point) (make-string p :initial-element char))
-	(insert-character (current-point) char))))
diff --git a/hemlock/netnews.lisp b/hemlock/netnews.lisp
deleted file mode 100644
index a98aafbf063e8faaf0ded4cd336686f55abde29c..0000000000000000000000000000000000000000
--- a/hemlock/netnews.lisp
+++ /dev/null
@@ -1,2391 +0,0 @@
-;;; -*- Package: Hemlock; Log: hemlock.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 or slisp-group@cs.cmu.edu.
-;;; **********************************************************************
-;;;
-;;; Written by Blaine Burks
-;;;
-;;; This file implements the reading of bulletin boards from within Hemlock
-;;; via a known NNTP server.  Something should probably be done so that
-;;; when the server is down Hemlock doesn't hang as I suspect it will.
-;;;
-;;; Warning:    Throughout this file, it may appear I should have bound
-;;;             the nn-info-stream and nn-info-header-stream slots instead
-;;;             of making multiple structure accesses.  This was done on
-;;;             purpose because we don't find out if NNTP timed us out until
-;;;             we make an attempt to execute another command.  This code
-;;;             recovers by resetting the header-stream and stream slots in
-;;;             the nn-info structure to new streams.  If the structure
-;;;             access were not made again and NNTP had timed us out, we
-;;;             would be making requests on a defunct stream.
-;;; 
-
-(in-package "HEMLOCK")
-
-
-
-;;;; Netnews data structures.
-
-(defparameter default-netnews-headers-length 1000
-  "How long the header-cache and message-ids arrays should be made on startup.")
-
-(defstruct (netnews-info
-	    (:conc-name nn-info-)
-	    (:print-function
-	     (lambda (nn s d)
-	       (declare (ignore nn d))
-	       (write-string "#<Netnews Info>" s))))
-  (updatep (ext:required-argument) :type (or null t))
-  (from-end-p nil :type (or null t))
-  ;;
-  ;; The string name of the current group.
-  (current (ext:required-argument) :type simple-string)
-  ;;
-  ;; The number of the latest message read in the current group.
-  (latest nil :type (or null fixnum))
-  ;;
-  ;; The cache of header info for the current group.  Each element contains
-  ;; an association list of header fields to contents of those fields.  Indexed
-  ;; by id offset by the first message in the group.
-  (header-cache nil :type (or null simple-vector))
-  ;;
-  ;; The number of HEAD requests currently waiting on the header stream.
-  (batch-count nil :type (or null fixnum))
-  ;;
-  ;; The list of newsgroups to read.
-  (groups (ext:required-argument) :type cons)
-  ;;
-  ;; A vector of message ids indexed by buffer-line for this headers buffer.
-  (message-ids nil :type (or null vector))
-  ;;
-  ;; Where to insert the next batch of headers.
-  mark
-  ;;
-  ;; The message buffer used to view article bodies.
-  buffer
-  ;;
-  ;; A list of message buffers that have been marked as undeletable by the user.
-  (other-buffers nil :type (or null cons))
-  ;;
-  ;; The window used to display buffer when \"Netnews Read Style\" is :multiple.
-  message-window
-  ;;
-  ;; The window used to display headers when \"Netnews Read Style\" is
-  ;; :multiple.
-  headers-window
-  ;;
-  ;; How long the message-ids and header-cache arrays are.  Reuse this array,
-  ;; but don't break if there are more messages than we can handle.
-  (array-length default-netnews-headers-length :type fixnum)
-  ;;
-  ;; The id of the first message in the current group.
-  (first nil :type (or null fixnum))
-  ;;
-  ;; The id of the last message in the current-group.
-  (last nil :type (or null fixnum))
-  ;;
-  ;; Article number of the first visible header.
-  (first-visible nil :type (or null fixnum))
-  ;;
-  ;; Article number of the last visible header.
-  (last-visible nil :type (or null fixnum))
-  ;;
-  ;; Number of the message that is currently displayed in buffer.  Initialize
-  ;; to -1 so I don't have to constantly check for the nullness of it.
-  (current-displayed-message -1 :type (or null fixnum))
-  ;;
-  ;; T if the last batch of headers is waiting on the header stream.
-  ;; This is needed so NN-WRITE-HEADERS-TO-MARK can set the messages-waiting
-  ;; slot to nil.
-  (last-batch-p nil :type (or null t))
-  ;;
-  ;; T if there are more headers in the current group. Nil otherwise.
-  (messages-waiting nil :type (or null t))
-  ;;
-  ;; The stream on which we request headers from NNTP.
-  header-stream
-  ;;
-  ;; The stream on which we request everything but headers from NNTP.
-  stream)
-
-(defmode "News-Headers" :major-p t)
-
-
-
-;;;; The netnews-message-info and post-info structures.
-
-(defstruct (netnews-message-info
-	    (:conc-name nm-info-)
-	    (:print-function
-	     (lambda (nn s d)
-	       (declare (ignore nn d))
-	       (write-string "#<Netnews Message Info>" s))))
-  ;; The headers buffer (if there is one) associated with this message buffer.
-  headers-buffer
-  ;; The draft buffer (if there is one) associated with this message buffer.
-  draft-buffer
-  ;; The post buffer (if there is one) associated with this message buffer.
-  post-buffer
-  ;; This is need because we want to display what message this is in the
-  ;; modeline field of a message buffer.
-  (message-number nil :type (or null fixnum))
-  ;;  Set to T when we do not want to reuse this buffer.
-  keep-p)
-
-(defstruct (post-info
-	    (:print-function
-	     (lambda (nn s d)
-	       (declare (ignore nn d))
-	       (write-string "#<Post Info>" s))))
-  ;; The NNTP stream over which to send this post.
-  stream
-  ;; When replying in another window, the reply window.
-  reply-window
-  ;; When replying in another window, the message window.
-  message-window
-  ;; The message buffer associated with this post.
-  message-buffer
-  ;; The Headers buffer associated with this post.
-  headers-buffer)
-
-
-
-;;;; Command Level Implementation of "News-Headers" mode.
-
-(defhvar "Netnews Database File"
-  "This value is merged with your home directory to get a path to your netnews
-   pointers file."
-  :value ".hemlock-netnews")
-
-(defhvar "Netnews Read Style"
-  "How you like to read netnews.  A value of :single will cause netnews
-   mode to use a single window for headers and messages, and a value of
-   :multiple will cause the current window to be split so that Headers take
-   up \"Netnews Headers Proportion\" of what was the current window, and a
-   message bodies buffer the remaining portion.  Changing the value of this
-   variable dynamically affects netnews reading."
-  :value :multiple)
-
-(unless (modeline-field :netnews-message)
-  (make-modeline-field
-   :name :netnews-message
-   :width 14
-   :function #'(lambda (buffer window)
-		 (declare (ignore window))
-		 (let* ((nm-info (variable-value 'netnews-message-info
-						 :buffer buffer))
-			(nn-info (variable-value 'netnews-info
-						 :buffer (nm-info-headers-buffer
-							  nm-info))))
-		   (format nil "~D of ~D"
-			   (nm-info-message-number nm-info)
-			   (1+ (- (nn-info-last nn-info)
-				  (nn-info-first nn-info))))))))
-
-(unless (modeline-field :netnews-header-info)
-  (make-modeline-field
-   :name :netnews-header-info
-   :width 24
-   :function
-   #'(lambda (buffer window)
-       (declare (ignore window))
-       (let ((nn-info (variable-value 'netnews-info :buffer buffer)))
-	 (format nil "~D before, ~D after"
-		 (- (nn-info-first-visible nn-info) (nn-info-first nn-info))
-		 (- (nn-info-last nn-info) (nn-info-last-visible nn-info)))))))
-
-(defvar *nn-headers-buffer* nil
-  "If \"Netnews\" was invoked without an argument an not exited, this
-   holds the headers buffer for reading netnews.")
-
-(defvar *netnews-kill-strings* nil)
-
-(defhvar "Netnews Kill File"
-  "This value is merged with your home directory to get the pathname of
-   your netnews kill file.  If any of the strings in this file (one per
-   line) appear in a subject header while reading netnews, they will have a
-   \"K\" in front of them, and \"Netnews Next Line\" and \"Netnews Previous
-   Line\" will never land you on one.  Use \"Next Line\" and \"Previous
-   Line\" to read Killed messages.  Defaults to \".hemlock-kill\"."
-  :value ".hemlock-kill")
-
-(defhvar "Netnews New Group Style"
-  "Determines what happend when you read a group that you have never read
-   before.  When :from-start, \"Netnews\" will read from the beginning of a
-   new group forward.  When :from-end, the default, \"Netnews\" will read
-   from the end backward group.  Otherwise this variable is a number
-   indicating that \"Netnews\" should start that many messages from the end
-   of the group and read forward from there."
-  :value :from-end)
-
-(defhvar "Netnews Start Over Threshold"
-  "If you have read a group before, and the number of new messages exceeds
-   this number, Hemlock asks whether you want to start reading from the end
-   of this group.  The default is 300."
-  :value 300)
-
-(defcommand "Netnews" (p &optional group-name from-end-p browse-buf (updatep t))
-  "Enter a headers buffer and read groups from \"Netnews Group File\".
-   With an argument prompts for a group and reads it."
-  "Enter a headers buffer and read groups from \"Netnews Group File\".
-   With an argument prompts for a group and reads it."
-  (cond
-   ((and *nn-headers-buffer* (not p) (not group-name))
-    (change-to-buffer *nn-headers-buffer*))
-   (t
-    (let* ((single-group (if p (prompt-for-string :prompt "Group to read: "
-						  :help "Type the name of ~
-						  the group you want ~
-						  to scan."
-						  :trim t)))
-	   (groups (cond
-		    (group-name (list group-name))
-		    (single-group (list single-group))
-		    (t
-		     (let ((group-file (merge-pathnames
-					(value netnews-group-file)
-					(user-homedir-pathname)))) 
-		       (when (probe-file group-file)
-			 (let ((res nil))
-			   (with-open-file (s group-file :direction :input)
-			     (loop
-			       (let ((group (read-line s nil nil)))
-				 (unless group (return (nreverse res)))
-				 (pushnew group res)))))))))))
-      (unless (or p groups)
-	(editor-error "No groups to read.  See \"Netnews Group File\" and ~
-	               \"Netnews Browse\"."))
-      (when updatep (nn-assure-database-exists))
-      (nn-parse-kill-file)
-      (multiple-value-bind (stream header-stream) (streams-for-nntp)
-	(multiple-value-bind
-	    (buffer-name clashp)
-	    (nn-unique-headers-name (car groups))
-	  (if (and (or p group-name) clashp)
-	      (change-to-buffer (getstring clashp *buffer-names*))
-	      (let* ((buffer (make-buffer
-			      buffer-name
-			      :modes '("News-Headers")
-			      :modeline-fields
-			      (append (value default-modeline-fields)
-				      (list (modeline-field
-					     :netnews-header-info)))
-			      :delete-hook 
-			      (list #'netnews-headers-delete-hook)))
-		     (nn-info (make-netnews-info
-			       :current (car groups)
-			       :groups groups
-			       :updatep updatep
-			       :headers-window (current-window)
-			       :mark (copy-mark (buffer-point buffer))
-			       :header-stream header-stream
-			       :stream stream)))
-		(unless (or p group-name) (setf *nn-headers-buffer* buffer))
-		(when (and clashp (not (or p group-name)))
-		  (message "Buffer ~S also contains headers for ~A"
-			   clashp (car groups)))
-		(defhvar "Netnews Info"
-		  "A structure containing the current group, a list of
-		   groups, a book-keeping mark, a stream we get headers on,
-		   and the stream on which we request articles."
-		  :buffer buffer
-		  :value nn-info)
-		(setf (buffer-writable buffer) nil)
-		(defhvar "Netnews Browse Buffer"
-		  "This variable is the associated \"News-Browse\" buffer
-		   in a \"News-Headers\" buffer created from
-		   \"News-Browse\" mode."
-		  :buffer buffer
-		  :value browse-buf)
-		(setup-group (car groups) nn-info buffer from-end-p)))))))))
-
-
-(defun nn-parse-kill-file ()
-  (let ((filename (merge-pathnames (value netnews-kill-file)
-				   (user-homedir-pathname))))
-    (when (probe-file filename)
-      (with-open-file (s filename :direction :input)
-	(loop
-	  (let ((kill-string (read-line s nil nil)))
-	    (unless kill-string (return))
-	    (pushnew kill-string *netnews-kill-strings*)))))))
-
-;;; NETNEWS-HEADERS-DELETE-HOOK closes the stream slots in netnews-info,
-;;; deletes the bookkeeping mark into buffer, sets the headers slots of any
-;;; associated post-info or netnews-message-info structures to nil so
-;;; "Netnews Go To Headers Buffer" will not land you in a buffer that does
-;;; not exist, and sets *nn-headers-buffer* to nil so next time we invoke
-;;; "Netnews" it will start over.
-;;; 
-(defun netnews-headers-delete-hook (buffer)
-  (let ((nn-info (variable-value 'netnews-info :buffer buffer)))
-    ;; Disassociate all message buffers.
-    ;; 
-    (dolist (buf (nn-info-other-buffers nn-info))
-      (setf (nm-info-headers-buffer (variable-value 'netnews-message-info
-						    :buffer buf))
-	    nil))
-    (let ((message-buffer (nn-info-buffer nn-info)))
-      (when message-buffer
-	(setf (nm-info-headers-buffer (variable-value 'netnews-message-info
-						      :buffer message-buffer))
-	      nil)))
-    (close (nn-info-stream nn-info))
-    (close (nn-info-header-stream nn-info))
-    (delete-mark (nn-info-mark nn-info))
-    (when (eq *nn-headers-buffer* buffer)
-      (setf *nn-headers-buffer* nil))))
-
-(defun nn-unique-headers-name (group-name)
-  (let ((original-name (concatenate 'simple-string "Netnews " group-name)))
-    (if (getstring original-name *buffer-names*)
-	(let ((name nil)
-	      (number 0))
-	  (loop
-	    (setf name (format nil "Netnews ~A ~D" group-name (incf number)))
-	    (unless (getstring name *buffer-names*)
-	      (return (values name original-name)))))
-	(values original-name nil))))
-
-;;; NN-ASSURE-DATABASE-EXISTS does just that.  If the file determined by the
-;;; value of "Netnews Database Filename" does not exist, then it gets
-;;; created.
-;;; 
-(defun nn-assure-database-exists ()
-  (let ((filename (merge-pathnames (value netnews-database-file)
-				   (user-homedir-pathname))))
-    (unless (probe-file filename)
-      (message "Creating netnews database file.")
-      (close (open filename :direction :output :if-does-not-exist :create)))))
-
-(defhvar "Netnews Fetch All Headers"
-  "When NIL, all netnews reading commands will fetch headers in batches for
-   increased efficiency.  Any other value will cause these commands to fetch
-   all the headers.  This will take a long time if there are a lot."
-  :value nil)
-
-(defcommand "Netnews Look at Newsgroup" (p)
-  "Prompts for the name of a newsgroup and reads it, regardless of what is
-   in and not modifying the \"Netnews Database File\"."
-  "Prompts for the name of a newsgroup and reads it, regardless of what is
-   in and not modifying the \"Netnews Database File\"."
-  (declare (ignore p))
-  (netnews-command nil (prompt-for-string :prompt "Group to look at: "
-					  :help "Type the name of ~
-					  the group you want ~
-					  to look at."
-					  :trim t)
-		   nil nil nil))
-  
-;;; SETUP-GROUP is the guts of this group reader.  It sets up a headers
-;;; buffer in buffer for group group-name.  This consists of sending a group
-;;; command to both the header-stream and normal stream and then getting the
-;;; last message read in group-name from the database file and setting the
-;;; appropriate slots in the nn-info structure.  The first batch of messages
-;;; is then requested and inserted, and room for message-ids is allocated.
-;;; 
-(defun setup-group (group-name nn-info buffer &optional from-end-p)
-  ;; Do not bind stream or header-stream because if a timeout has occurred
-  ;; before these calls are invoked, they would be bogus.
-  ;; 
-  (nntp-group group-name (nn-info-stream nn-info)
-	      (nn-info-header-stream nn-info))
-  (process-status-response (nn-info-stream nn-info) nn-info)
-  (let ((response (process-status-response (nn-info-header-stream nn-info)
-					   nn-info)))
-    (cond ((not response)
-	   (message "~A is not the name of a netnews group.~%"
-		    (nn-info-current nn-info))
-	   (change-to-next-group nn-info buffer))
-	  (t
-	   (multiple-value-bind (number first last)
-				(group-response-args response)
-	     (declare (ignore first))
-	     (message "Setting up ~A" group-name)
-	     ;; If nn-info-updatep is nil, then we fool ourselves into
-	     ;; thinking we've never read this group before by making
-	     ;; last-read nil.  We determine first here because the first
-	     ;; that NNTP gives us is way way out of line.
-	     ;;
-	     (let ((last-read (if (nn-info-updatep nn-info)
-				  (nn-last-read-message-number group-name)))
-		   (first (1+ (- last number))))
-	       ;; Make sure there is at least one new message in this group.
-	       (cond
-		((and last-read (= last-read last))
-		 (message "No new messages in ~A" group-name)
-		 (setf (nn-info-latest nn-info) last)
-		 (change-to-next-group nn-info buffer))
-		((zerop number)
-		 (message "No messages AVAILABLE in ~A" group-name)
-		 (setf (nn-info-latest nn-info) last)
-		 (change-to-next-group nn-info buffer))
-		(t
-		 (let ((latest (if (and last-read (> last-read first))
-				   last-read
-				   first)))
-		   (if (or (and (eq (value netnews-new-group-style) :from-end)
-				(or (= latest first)
-				    (and (> (- last latest)
-					    (value
-					     netnews-start-over-threshold))
-					 (prompt-for-y-or-n
-					  :prompt
-					  `("There are ~D new messages.  ~
-					     Read from the end of this ~
-					     group? " ,(- last latest))
-					  :default "Y"
-					  :default-string "Y"
-					  :help "Y starts reading from the ~
-					         end.  N starts reading where ~
-						 you left off many messages ~
-						 back."))))
-			   from-end-p)
-		       (setf (nn-info-from-end-p nn-info) t))
-
-		   (cond ((nn-info-from-end-p nn-info)
-			  (setf (nn-info-first-visible nn-info) nil)
-			  (setf (nn-info-last-visible nn-info) last))
-			 (t
-			  ; (setf (nn-info-first-visible nn-info) latest)
-			  (setf (nn-info-first-visible nn-info) (1+ latest))
-			  (setf (nn-info-last-visible nn-info) nil)))
-		   (setf (nn-info-first nn-info) first)
-		   (setf (nn-info-last nn-info) last)
-		   (setf (nn-info-latest nn-info) latest))
-		 ;;
-		 ;; Request the batch before setting message-ids so they start
-		 ;; coming before we need them.
-		 (nn-request-next-batch nn-info
-					(value netnews-fetch-all-headers))
-		 (let ((message-ids (nn-info-message-ids nn-info))
-		       (header-cache (nn-info-header-cache nn-info))
-		       (length (1+ (- last first))))
-		   (multiple-value-setq
-		       (message-ids header-cache)
-		       (cond ((> length (nn-info-array-length nn-info))
-			      (setf (nn-info-array-length nn-info) length)
-			      (values (make-array length :fill-pointer 0)
-				      (make-array length
-						  :initial-element nil)))
-			     (message-ids
-			      (setf (fill-pointer message-ids) 0)
-			      (values message-ids header-cache))
-			     (t
-			      (values (make-array (nn-info-array-length nn-info)
-						  :fill-pointer 0)
-				      (make-array (nn-info-array-length nn-info)
-						  :initial-element nil)))))
-		   (setf (nn-info-message-ids nn-info) message-ids)
-		   (setf (nn-info-header-cache nn-info) header-cache))
-		 (nn-write-headers-to-mark nn-info buffer)
-		 (change-to-buffer buffer)))))))))
-
-;;; NN-LAST-READ-MESSAGE-NUMBER reads the last read message in group-name
-;;; from the value of "Netnews Database File".  It is SETF'able and the
-;;; SETF method is %SET-LAST-READ-MESSAGE-NUMBER.
-;;; 
-(defun nn-last-read-message-number (group-name)
-  (with-open-file (s (merge-pathnames (value netnews-database-file)
-				      (user-homedir-pathname))
-		     :direction :input :if-does-not-exist :error)
-    (loop
-      (let ((read-group-name (read-line s nil nil)))
-	(unless read-group-name (return nil))
-	(when (string-equal read-group-name group-name)
-	  (let ((last-read (read-line s nil nil)))
-	    (if last-read
-		(return (parse-integer last-read))
-		(error "Should have been a message number ~
-		following ~S in database file."
-		       group-name))))))))
-
-(defun %set-nn-last-read-message-number (group-name new-value)
-  (with-open-file (s (merge-pathnames (value netnews-database-file)
-				      (user-homedir-pathname))
-		     :direction :io :if-does-not-exist :error
-		     :if-exists :overwrite)
-    (unless (loop
-	      (let ((read-group-name (read-line s nil nil)))
-		(unless read-group-name (return nil))
-		(when (string-equal read-group-name group-name)
-		  ;; File descriptor streams do not do the right thing with
-		  ;; :io/:overwrite streams, so work around it by setting it
-		  ;; explicitly.
-		  ;;
-		  (file-position s (file-position s))
-		  ;; Justify the number so that if the number of digits in it
-		  ;; changes, we won't overwrite the next group name.
-		  ;;
-		  (format s "~14D~%" new-value)
-		  (return t))))
-      (write-line group-name s)
-      (format s "~14D~%" new-value))))
-
-(defsetf nn-last-read-message-number %set-nn-last-read-message-number)
-
-(defconstant nntp-eof ".
"
-  "NNTP marks the end of a textual response with this.  NNTP also recognizes
-   this as the end of a post.")
-
-;;; This macro binds a variable to each successive line of input from NNTP
-;;; and exits when it sees the NNTP end-of-file-marker, a period by itself on
-;;; a line.
-;;;
-(defmacro with-input-from-nntp ((var stream) &body body)
-  "Body is executed with var bound to successive lines of input from nntp.
-   Exits at the end of a response, returning whatever the last execution of
-   Body returns, or nil if there was no input.
-   Take note: this is only to be used for textual responses.  Status responses
-   are of an entirely different nature."
-  (let ((return-value (gensym)))
-    `(let ((,return-value nil)
-	   (,var ""))
-       (declare (simple-string ,var))
-       (loop
-	 (setf ,var (read-line ,stream))
-	 (when (string= ,var nntp-eof) (return ,return-value))
-	 (setf ,return-value (progn ,@body))))))
-
-
-;;; Writing the date, from, and subject fields to a mark.
-
-(defhvar "Netnews Before Date Field Pad"
-  "How many spaces should be inserted before the date in Netnews.  The default
-   is 1."
-  :value 1)
-
-(defhvar "Netnews Date Field Length"
-  "How long the date field should be in \"News-Headers\" buffers.  The
-   default is 6"
-  :value 6)
-
-(defhvar "Netnews Line Field Length"
-  "How long the line field should be in \"News-Headers\" buffers. The
-   default is 3"
-  :value 3)
-
-(defhvar "Netnews From Field Length"
-  "How long the from field should be in \"News-Headers\" buffers.  The
-   default is 20."
-  :value 20)
-
-(defhvar "Netnews Subject Field Length"
-  "How long the subject field should be in \"News-Headers\" buffers.  The
-   default is 43."
-  :value 43)
-
-(defhvar "Netnews Field Padding"
-  "How many spaces should be left between the netnews date, from, lines, and
-   subject fields.  The default is 2."
-  :value 2)
-
-;;;
-(defconstant netnews-space-string
-  (make-array 70 :element-type 'string-char :initial-element #\space))
-;;;
-(defconstant missing-message (cons nil nil)
-  "Use this as a marker so nn-write-headers-to-mark doesn't try to insert
-   a message that is not really there.")
-
-;;; NN-CACHE-HEADER-INFO stashes all header information into an array for
-;;; later use.
-;;; 
-(defun nn-cache-header-info (nn-info howmany use-header-stream-p)
-  (let* ((cache (nn-info-header-cache nn-info))
-	 (message-ids (nn-info-message-ids nn-info))
-	 (stream (if use-header-stream-p
-		     (nn-info-header-stream nn-info)
-		     (nn-info-stream nn-info)))
-	 (from-end-p (nn-info-from-end-p nn-info))
-	 (old-count 0))
-    (declare (fixnum old-count))
-    (when from-end-p
-      (setf old-count (length message-ids))
-      (do ((i (length message-ids) (1- i)))
-	  ((minusp i) nil)
-	(setf (aref message-ids (+ i howmany)) (aref message-ids i)))
-      (setf (fill-pointer message-ids) 0))
-    (let ((missing-message-count 0)
-	  (offset (nn-info-first nn-info)))
-      (dotimes (i howmany)
-	(let ((response (process-status-response stream)))
-	  (if response
-	      (let* ((id (head-response-args response))
-		     (index (- id offset)))
-		(vector-push id message-ids)
-		(setf (svref cache index) nil)
-		(with-input-from-nntp (string stream)
-				      (let ((colonpos (position #\: string)))
-					(when colonpos
-					  (push (cons (subseq string 0 colonpos)
-						      (subseq string
-							      (+ colonpos 2)))
-						(svref cache index))))))
-	      (incf missing-message-count))))
-      (when from-end-p
-	(when (plusp missing-message-count)
-	  (dotimes (i old-count)
-	    (setf (aref message-ids (- (+ i howmany) missing-message-count))
-		  (aref message-ids (+ i howmany)))))
-	(setf (fill-pointer message-ids)
-	      (- (+ old-count howmany) missing-message-count))))))
-
-(defconstant netnews-field-na "NA"
-  "This string gets inserted when NNTP doesn't find a field.")
-
-(defconstant netnews-field-na-length (length netnews-field-na)
-  "The length of netnews-field-na")
-
-(defun nn-write-headers-to-mark (nn-info buffer &optional fetch-rest-p
-					 out-of-order-p)
-  (let* ((howmany (nn-info-batch-count nn-info))
-	 (from-end-p (nn-info-from-end-p nn-info))
-	 (cache (nn-info-header-cache nn-info))
-	 (old-point (copy-mark (buffer-point buffer) (if from-end-p
-							 :left-inserting
-							 :right-inserting)))
-	 (messages-waiting (nn-info-messages-waiting nn-info))
-	 (mark (nn-info-mark nn-info)))
-    (unless messages-waiting
-      (return-from nn-write-headers-to-mark nil))
-    (if from-end-p
-	(buffer-start mark)
-	(buffer-end mark))
-    (nn-cache-header-info nn-info howmany (not out-of-order-p))
-    (with-writable-buffer (buffer)
-      (with-mark ((check-point mark :right-inserting))
-	(macrolet ((mark-to-pos (mark pos)
-		     `(insert-string ,mark netnews-space-string
-				     0 (- ,pos (mark-column ,mark))))
-		   (insert-field (mark field-string field-length)
-		     `(if ,field-string
-			  (insert-string ,mark ,field-string
-					 0 (min ,field-length
-						(1- (length ,field-string))))
-			  (insert-string ,mark netnews-field-na
-					 0 (min ,field-length
-						netnews-field-na-length)))))
-	  (let* ((line-start (+ (value netnews-before-date-field-pad)
-				(value netnews-date-field-length)
-				(value netnews-field-padding)))
-		 (from-start (+ line-start
-				(value netnews-line-field-length)
-				(value netnews-field-padding)))
-		 (subject-start (+ from-start
-				   (value netnews-from-field-length)
-				   (value netnews-field-padding)))
-		 (start (- messages-waiting (nn-info-first nn-info)))
-		 (end (1- (+ start howmany))))
-	    (do ((i start (1+ i)))
-		((> i end))
-	      (let ((assoc-list (svref cache i)))
-		(unless (null assoc-list)
-		  (insert-string mark netnews-space-string
-				 0 (value netnews-before-date-field-pad))
-		  (let* ((date-field (cdr (assoc "date" assoc-list
-						 :test #'string-equal)))
-			 (universal-date (if date-field
-					     (ext:parse-time date-field
-							     :end (1- (length date-field))))))
-		    (insert-field
-		     mark
-		     (if universal-date
-			 (string-capitalize
-			  (format-universal-time nil universal-date
-						 :style :government
-						 :print-weekday nil))
-			 date-field)
-		     (value netnews-date-field-length)))
-		  (mark-to-pos mark line-start)
-		  (insert-field mark (cdr (assoc "lines" assoc-list
-						 :test #'string-equal))
-				(value netnews-line-field-length))
-		  (mark-to-pos mark from-start)
-		  (insert-field mark (cdr (assoc "from" assoc-list
-						 :test #'string-equal))
-				(value netnews-from-field-length))
-		  (mark-to-pos mark subject-start)
-		  (insert-field mark (cdr (assoc "subject" assoc-list
-						 :test #'string-equal))
-				(value netnews-subject-field-length))
-		  (insert-character mark #\newline))))))
-	(cond (out-of-order-p
-	       (setf (nn-info-first-visible nn-info) messages-waiting))
-	      (t
-	       (if (nn-info-from-end-p nn-info)
-		   (setf (nn-info-first-visible nn-info) messages-waiting)
-		   (setf (nn-info-last-visible nn-info)
-			 (1- (+ messages-waiting howmany))))
-	       (if (nn-info-last-batch-p nn-info)
-		   (setf (nn-info-messages-waiting nn-info) nil)
-		   (nn-request-next-batch nn-info fetch-rest-p))))
-	(when (mark= mark check-point)
-	  (message "All messages in last batch were missing, getting more."))
-	(move-mark (buffer-point buffer) old-point)
-	(delete-mark old-point)))))
-
-;;; NN-MAYBE-GET-MORE-HEADERS gets more headers if the point of the headers
-;;; buffer is on an empty line and there are some.  Returns whether it got more
-;;; headers, i.e., if it is time to go on to the next group.
-;;; 
-(defun nn-maybe-get-more-headers (nn-info)
-  (let ((headers-buffer (line-buffer (mark-line (nn-info-mark nn-info)))))
-    (when (empty-line-p (buffer-point headers-buffer))
-      (cond ((and (nn-info-messages-waiting nn-info)
-		  (not (nn-info-from-end-p nn-info)))
-	     (nn-write-headers-to-mark nn-info headers-buffer)
-	     t)
-	    (t :go-on)))))
-
-(defhvar "Netnews Batch Count"
-  "Determines how many headers the Netnews facility will fetch at a time.
-   The default is 50."
-  :value 50)
-
-;;; NN-REQUEST-NEXT-BATCH requests the next batch of messages in a group.
-;;; For safety, don't do anything if there is no next-batch start.
-;;; 
-(defun nn-request-next-batch (nn-info &optional fetch-rest-p)
-  (if (nn-info-from-end-p nn-info)
-      (nn-request-backward nn-info fetch-rest-p)
-      (nn-request-forward nn-info fetch-rest-p)))
-
-(defun nn-request-forward (nn-info fetch-rest-p)
-  (let* ((last-visible (nn-info-last-visible nn-info))
-	 (last (nn-info-last nn-info))
-	 (batch-start (if last-visible
-			  (1+ (nn-info-last-visible nn-info))
-			  (1+ (nn-info-latest nn-info))))
-	 (header-stream (nn-info-header-stream nn-info))
-	 (batch-end (if fetch-rest-p
-			last
-			(1- (+ batch-start (value netnews-batch-count))))))
-    ;; If this is the last batch, adjust batch-end appropriately.
-    ;;
-    (when (>= batch-end last)
-      (setf batch-end last)
-      (setf (nn-info-last-batch-p nn-info) t))
-    (setf (nn-info-batch-count nn-info) (1+ (- batch-end batch-start)))
-    (setf (nn-info-messages-waiting nn-info) batch-start)
-    (nn-send-many-head-requests header-stream batch-start batch-end nil)))
-
-(defun nn-request-backward (nn-info fetch-rest-p
-				    &optional (use-header-stream-p t))
-  (let* ((first-visible (nn-info-first-visible nn-info))
-	 (batch-end (if first-visible
-			(1- (nn-info-first-visible nn-info))
-			(nn-info-last nn-info)))
-	 (stream (if use-header-stream-p
-		     (nn-info-header-stream nn-info)
-		     (nn-info-stream nn-info)))
-	 (first (nn-info-first nn-info))
-	 (batch-start (if fetch-rest-p
-			  first
-			  (1+ (- batch-end (value netnews-batch-count))))))
-    ;; If this is the last batch, adjust batch-end appropriately.
-    ;;
-    (when (<= batch-start first)
-      (setf batch-start first)
-      (setf (nn-info-last-batch-p nn-info) t))
-    (setf (nn-info-batch-count nn-info) (1+ (- batch-end batch-start)))
-    (setf (nn-info-messages-waiting nn-info) batch-start)
-    (nn-send-many-head-requests stream batch-start batch-end
-				(not use-header-stream-p))))
-
-;;; NN-REQUEST-OUT-OF-ORDER is called when the user is reading a group normally
-;;; and decides he wants to see some messages before the first one visible.
-;;; To accomplish this without disrupting the normal flow of things, we fool
-;;; ourselves into thinking we are reading the group from the end, remembering
-;;; several slots that could be modified in requesting thesse messages.
-;;; When we are done, return state to what it was for reading a group forward.
-;;; 
-(defun nn-request-out-of-order (nn-info headers-buffer)
-  (let ((messages-waiting (nn-info-messages-waiting nn-info))
-	(batch-count (nn-info-batch-count nn-info))
-	(last-batch-p (nn-info-last-batch-p nn-info)))
-    (nn-request-backward nn-info nil nil)
-    (setf (nn-info-from-end-p nn-info) t)
-    (nn-write-headers-to-mark nn-info headers-buffer nil t)
-    (setf (nn-info-messages-waiting nn-info) messages-waiting)
-    (setf (nn-info-batch-count nn-info) batch-count)
-    (setf (nn-info-last-batch-p nn-info) last-batch-p)
-    (setf (nn-info-from-end-p nn-info) nil)))
-
-(proclaim '(special *nn-last-command-issued*))
-
-(defun nn-send-many-head-requests (stream first last out-of-order-p)
-  (do ((i first (1+ i)))
-      ((> i last))
-    (nntp-head i stream))
-  (setf *nn-last-command-issued*
-	(list (if out-of-order-p :out-of-order :header)
-	      first last out-of-order-p)))
-
-(defvar nn-minimum-header-batch-count 30
-  "The minimum number of headers to fetch at any given time.")
-
-
-
-;;;; "News-Message" mode.
-
-(defmode "News-Message" :major-p t)
-
-
-
-;;;; Commands for viewing articles.
-
-(defcommand "Netnews Show Article" (p)
-  "Show the message the point is on.  If it is the same message that is
-   already in the message buffer and \"Netnews Read Style\" is :multiple,
-   then just scroll the window down prefix argument lines"
-  "Show the message the point is on.  If it is the same message that is
-   already in the message buffer and \"Netnews Read Style\" is :multiple,
-   then just scroll the window down prefix argument lines"
-  (nn-show-article (value netnews-info) p))
-
-(defcommand "Netnews Next Article" (p)
-  "Show the next article in the current newsgroup."
-  "Shows the article on the line preceeding the point in the headers buffer."
-  (declare (ignore p))
-  (let* ((what-next (netnews-next-line-command nil (nn-get-headers-buffer))))
-    (when (and (not (eq what-next :done))
-	       (or (eq what-next t)
-		   (eq (value netnews-last-header-style) :next-article)))
-      ;; Reget the headers buffer because the call to netnews-next-line-command
-      ;; might have moved us into a different buffer.
-      ;; 
-      (nn-show-article (variable-value 'netnews-info
-				       :buffer (nn-get-headers-buffer))
-		       t))))
-
-(defcommand "Netnews Previous Article" (p)
-  "Show the previous article in the current newsgroup."
-  "Shows the article on the line after the point in the headers buffer."
-  (declare (ignore p))
-  (let ((buffer (nn-get-headers-buffer)))
-    (netnews-previous-line-command nil buffer)
-    (nn-show-article (variable-value 'netnews-info :buffer buffer) t)))
-
-;;; NN-SHOW-ARTICLE checks first to see if we need to get more headers.  If
-;;; NN-MAYBE-GET-MORE-HEADERS returns nil then don't do anything because we
-;;; changed to the next group.  Then see if the message the user has
-;;; requested is already in the message buffer.  If the it isn't, put it
-;;; there.  If it is, and maybe-scroll-down is t, then scroll the window
-;;; down p lines in :multiple mode, or just change to the buffer in :single
-;;; mode.  I use scroll-window down becuase this function is called by
-;;; "Netnews Show Article", "Netnews Next Article", and "Netnews Previous
-;;; Article".  It doesn't make sense to scroll the window down if the guy
-;;; just read a message, moved the point up one line and invoked "Netnews
-;;; Next Article".  He expects to see the article again, not the second
-;;; page of it.  Also check to make sure there is a message under the
-;;; point.  If there is not, then get some more headers.  If there are no
-;;; more headers, then go on to the next group.  I can read and write.  Hi
-;;; Bill.  Are you having fun grokking my code?  Hope so -- Dude.  Nothing
-;;; like stream of consciousness is there?  Come to think of it, this is
-;;; kind of like recursive stream of conscious because I'm writing down my
-;;; stream of conscious which is about my stream of conscious. I think I'm
-;;; insane.  In fact I know I am.
-;;;
-(defun nn-show-article (nn-info dont-scroll-down &optional p)
-  (let ((headers-buffer (nn-get-headers-buffer))
-	(message-buffer (nn-info-buffer nn-info)))
-    (cond
-     ((eq (nn-maybe-get-more-headers nn-info) :go-on)
-      (case (value netnews-last-header-style)
-	(:this-headers (change-to-buffer headers-buffer)
-		       (buffer-start (buffer-point headers-buffer))
-		       (editor-error "Last header."))
-	(:next-headers (change-to-next-group nn-info headers-buffer))
-	(:next-article (change-to-next-group nn-info headers-buffer)
-		       (netnews-show-article-command nil))))
-     (t
-      (cond ((and (not dont-scroll-down)
-		  (= (nn-info-current-displayed-message nn-info)
-		     (array-element-from-mark (buffer-point headers-buffer)
-					      (nn-info-message-ids nn-info))))
-	     (ecase (value netnews-read-style)
-	       (:single (buffer-start (buffer-point message-buffer))
-			(change-to-buffer message-buffer))
-	       (:multiple
-		(multiple-value-bind
-		    (headers-window message-window newp)
-		    (nn-assure-multi-windows nn-info)
-		  (nn-put-buffers-in-windows headers-buffer message-buffer
-					     headers-window message-window
-					     :headers)
-		  ;; If both windows were visible to start with, just scroll
-		  ;; down.  If they weren't, then show the message over
-		  ;; again.
-		  ;; 
-		  (cond (newp (buffer-start (buffer-point message-buffer))
-			      (buffer-start (window-point message-window)))
-			(t (netnews-message-scroll-down-command
-			    p message-buffer message-window)))))))
- 	    (t
-	     (nn-put-article-in-buffer nn-info headers-buffer)
-	     (setf message-buffer (nn-info-buffer nn-info))
-	     (multiple-value-bind
-		 (headers-window message-window)
-		 (ecase (value netnews-read-style) ; Only need windows in
-		   (:single (values nil nil))      ; :multiple mode.
-		   (:multiple (nn-assure-multi-windows nn-info)))
-	       (ecase (value netnews-read-style)
-		 (:multiple
-		  ;; When there is only one window displaying the headers
-		  ;; buffer, move the window point of that buffer to the
-		  ;; buffer-point.
-		  (when (= (length (buffer-windows headers-buffer)) 1)
-		    (move-mark (window-point headers-window)
-			       (buffer-point headers-buffer)))
-		  (buffer-start (window-point message-window))
-		  (nn-put-buffers-in-windows headers-buffer message-buffer
-					     headers-window message-window
-					     :headers))
-		 (:single (change-to-buffer message-buffer))))))))))
-
-(defcommand "Netnews Message Quit" (p)
-  "Destroy this message buffer, and pop back to the associated headers buffer."
-  "Destroy this message buffer, and pop back to the associated headers buffer."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'netnews-message-info)
-    (editor-error "Not in a News-Message Buffer"))
-  (let ((message-buffer (current-buffer)))
-    (change-to-buffer (nn-get-headers-buffer))
-    (delete-buffer-if-possible message-buffer)))
-
-(defhvar "Netnews Message Header Fields"
-  "When NIL, the default, all available fields are displayed in the header
-  of a message.  Otherwise, this variable should containt a list of fields
-  that should be included in the message header when a message is
-  displayed.  Any string name is acceptable.  Fields that do not exist are
-  ignored.  If an element of this list is an atom, then it should be the
-  string name of a field.  If it is a cons, then the car should be the
-  string name of a field, and the cdr should be the length to which this
-  field should be limited."
-  :value nil)
-
-
-(defcommand "Netnews Show Whole Header" (p)
-  "This command will display the entire header of the message currently
-   being read."
-  "This command will display the entire header of the message currently
-   being read."
-  (declare (ignore p))
-  (let* ((headers-buffer (nn-get-headers-buffer))
-	 (nn-info (variable-value 'netnews-info :buffer headers-buffer))
-	 (buffer (nn-get-message-buffer nn-info)))
-    (with-writable-buffer (buffer)
-      (delete-region (buffer-region buffer))
-      (nn-put-article-in-buffer nn-info headers-buffer t))))
-
-;;; NN-PUT-ARTICLE-IN-BUFFER puts the article under the point into the
-;;; associated message buffer if it is not there already.  Uses value of
-;;; "Netnews Message Header Fields" to determine what fields should appear
-;;; in the message header.  Returns the number of the article under the
-;;; point.
-;;;
-(defun nn-put-article-in-buffer (nn-info headers-buffer &optional override)
-  (let ((stream (nn-info-stream nn-info))
-	(article-number (array-element-from-mark 
-			 (buffer-point headers-buffer)
-			 (nn-info-message-ids nn-info)))
-	(message-buffer (nn-get-message-buffer nn-info)))
-    (setf (nm-info-message-number (variable-value 'netnews-message-info
-						  :buffer message-buffer))
-	  (1+ (- article-number (nn-info-first nn-info))))
-    (cond ((and (= (nn-info-current-displayed-message nn-info) article-number)
-		(not override))
-	   (buffer-start (buffer-point message-buffer)))
-	  (t
-	   ;; Request article as soon as possible to avoid waiting for reply.
-	   ;;
-	   (nntp-body article-number stream)
-	   (setf (nn-info-current-displayed-message nn-info) article-number)
-	   (process-status-response stream nn-info)
-	   (with-writable-buffer (message-buffer)
-	     (let ((point (buffer-point message-buffer))
-		   (info (svref (nn-info-header-cache nn-info)
-				(- article-number (nn-info-first nn-info))))
-		   (message-fields (value netnews-message-header-fields))
-		   key field-length)
-	       (cond ((and message-fields
-			   (not override))
-		      (dolist (ele message-fields)
-			(etypecase ele
-			  (atom (setf key ele field-length nil))
-			  (cons (setf key (car ele) field-length (cdr ele))))
-			(let ((field-string (cdr (assoc key info
-							:test #'string-equal))))
-			  (when field-string
-			    (insert-string point (string-capitalize key))
-			    (insert-string point ": ")
-			    (insert-string point field-string
-					   0
-					   (max
-					    (if field-length
-						(min field-length
-						     (1- (length field-string)))
-						(1- (length field-string)))
-					    0))
-			    (insert-character point #\newline)))))
-		     (t
-		      (dolist (ele info)
-			(insert-string point (string-capitalize (car ele)))
-			(insert-string point ": ")
-			(insert-string point (cdr ele)
-				       0 (max 0 (1- (length (cdr ele)))))
-			(insert-character point #\newline))))
-	       (insert-character point #\newline)
-	       (nntp-insert-textual-response point (nn-info-stream nn-info))))
-	   (buffer-start (buffer-point message-buffer))
-	   (when (> article-number (nn-info-latest nn-info))
-	     (setf (nn-info-latest nn-info) article-number))))
-    article-number))
-
-;;; NN-PUT-BUFFERS-IN-WINDOWS makes sure the message buffer goes in the message
-;;; window and the headers buffer in the headers window.  If which-current
-;;; is :headers, the headers buffer/window will be made current, if it is
-;;; :message, the message buffer/window will be made current.
-;;;
-(defun nn-put-buffers-in-windows (headers-buffer message-buffer headers-window
-				  message-window which-current)
-  (setf (window-buffer message-window) message-buffer
-	(window-buffer headers-window) headers-buffer)
-  (setf (current-window) (ecase which-current
-			   (:headers headers-window)
-			   (:message message-window))
-	(current-buffer) (case which-current
-			   (:headers headers-buffer)
-			   (:message message-buffer))))
-
-(defhvar "Netnews Headers Proportion"
-  "Determines how much of the current window will display headers when
-   \"Netnews Read Style\" is :multiple.  Defaults to .25"
-  :value .25)
-
-(defun nn-assure-multi-windows (nn-info)
-  (let ((newp nil))
-    (unless (and (member (nn-info-message-window nn-info) *window-list*)
-		 (member (nn-info-headers-window nn-info) *window-list*))
-      (setf newp t)
-      (setf (nn-info-message-window nn-info) (current-window)
-	    (nn-info-headers-window nn-info)
-	    (make-window (buffer-start-mark (nn-get-headers-buffer))
-			 :proportion (value netnews-headers-proportion))))
-    (values (nn-info-headers-window nn-info)
-	    (nn-info-message-window nn-info)
-	    newp)))
-
-;;; NN-GET-MESSAGE-BUFFER returns the message buffer for an nn-info structure.
-;;; If there is not one, this function makes it and sets the slot in nn-info.
-;;;
-(defun nn-get-message-buffer (nn-info)
-  (let* ((message-buffer (nn-info-buffer nn-info))
-	 (nm-info (if message-buffer
-		      (variable-value 'netnews-message-info
-				      :buffer message-buffer))))
-    (cond ((and message-buffer (not (nm-info-keep-p nm-info)))
-	   (with-writable-buffer (message-buffer)
-	     (delete-region (buffer-region message-buffer)))
-	   message-buffer)
-	  (t
-	   (let ((buf (make-buffer (nn-unique-message-buffer-name
-				    (nn-info-current nn-info))
-				   :modeline-fields
-				   (append (value default-modeline-fields)
-					   (list (modeline-field
-						  :netnews-message)))
-				   :modes '("News-Message")
-				   :delete-hook
-				   (list #'nn-message-buffer-delete-hook))))
-	     (setf (nn-info-buffer nn-info) buf)
-	     (defhvar "Netnews Message Info"
-	       "Structure that keeps track of buffers in \"News-Message\"
-	        mode."
-	       :value (make-netnews-message-info
-		       :headers-buffer (current-buffer))
-	       :buffer buf)
-	     buf)))))
-
-;;; The usual.  Clean everything up.
-;;; 
-(defun nn-message-buffer-delete-hook (buffer)
-  (let* ((headers-buffer (nm-info-headers-buffer
-			  (variable-value 'netnews-message-info
-					  :buffer buffer)))
-	 (nn-info (variable-value 'netnews-info :buffer headers-buffer))
-	 (nm-info (variable-value 'netnews-message-info :buffer buffer)))
-    (setf (nn-info-buffer nn-info) nil)
-    (setf (nn-info-current-displayed-message nn-info) -1)
-    (let ((post-buffer (nm-info-post-buffer nm-info)))
-      (when post-buffer
-	(setf (post-info-message-buffer (variable-value
-					 'post-info :buffer post-buffer))
-	      nil)))))
-
-
-;;; NN-UNIQUE-MESSAGE-BUFFER-NAME likes to have a simple name, i.e.
-;;; "Netnews Message for rec.music.synth".  When there is already a buffer
-;;; by this name, however, we start counting until the name is unique.
-;;; 
-(defun nn-unique-message-buffer-name (group)
-  (let ((name (concatenate 'simple-string "Netnews Message for " group))
-	(number 0))
-    (loop
-      (unless (getstring name *buffer-names*) (return name))
-      (setf name (format nil "Netnews Message ~D" number))
-      (incf number))))
-
-;;; INSERT-TEXTUAL-RESPONSE inserts a textual response from nntp at mark.
-;;;
-(defun nntp-insert-textual-response (mark stream)
-  (with-input-from-nntp (string stream)
-    (insert-string mark string 0 (1- (length string)))
-    (insert-character mark #\newline)))
-
-;;; NN-GET-HEADERS-BUFFER returns the headers buffer if we are in a message or
-;;; headers buffer.
-;;;
-(defun nn-get-headers-buffer ()
-  (cond ((hemlock-bound-p 'netnews-info)
-	 (current-buffer))
-	((hemlock-bound-p 'netnews-message-info)
-	 (nm-info-headers-buffer (value netnews-message-info)))
-	((hemlock-bound-p 'post-info)
-	 (post-info-headers-buffer (value post-info)))
-	(t nil)))
-
-
-(defcommand "Netnews Previous Line" (p &optional
-				       (headers-buffer (current-buffer)))
-  "Moves the point to the last header before the point that is not in your
-   kill file.  If you move off the end of the buffer and there are more
-   headers, then get them.  Otherwise go on to the next group in \"Netnews
-   Groups\"."
-  "Moves the point to the last header before the point that is not in your
-   kill file.  If you move off the end of the buffer and there are more
-   headers, then get them.  Otherwise go on to the next group in \"Netnews
-   Groups\"."
-  (declare (ignore p))
-  (let ((point (buffer-point headers-buffer))
-	(nn-info (variable-value 'netnews-info :buffer headers-buffer)))
-    (with-mark ((original-position point)
-		(start point)
-		(end point))
-      (loop
-	(unless (line-offset point -1)
-	  (cond ((and (nn-info-from-end-p nn-info)
-		      (nn-info-messages-waiting nn-info))
-		 (nn-write-headers-to-mark nn-info headers-buffer)
-		 (netnews-previous-line-command nil headers-buffer))
-		(t
-		 (cond ((= (nn-info-first-visible nn-info)
-			   (nn-info-first nn-info))
-			(move-mark point original-position)
-			(editor-error "No previous unKilled headers."))
-		       (t
-			(message "Requesting backward...")
-			(nn-request-out-of-order nn-info headers-buffer)
-			(netnews-previous-line-command nil headers-buffer))))))
-	(line-start (move-mark start point))
-	(character-offset (move-mark end start) 1)
-	(unless (string= (region-to-string (region start end)) "K")
-	  (return))))))
-
-(defhvar "Netnews Last Header Style"
-  "When you read the last message in a newsgroup, this variable determines
-   what will happen next.  Takes one of three values: :this-headers,
-   :next-headers, or :next-article.  :this-headers, the default means put me
-   in the headers buffer for this newsgroup.  :next-headers means go to the
-   next newsgroup and put me in that headers buffer.  :next-article means go
-   on to the next newsgroup and show me the first unread article."
-  :value :next-headers)
-
-(defcommand "Netnews Next Line"
-	    (p &optional (headers-buffer (current-buffer)))
-  "Moves the point to the next header that is not in your kill file.  If you
-   move off the end of the buffer and there are more headers, then get them.
-   Otherwise go on to the next group in \"Netnews Groups\"."
-  "Moves the point to the next header that is not in your kill file.  If you
-   move off the end of the buffer and there are more headers, then get them.
-   Otherwise go on to the next group in \"Netnews Groups\".
-   Returns nil if we have gone on to the next group, :done if there are no
-   more groups to read, or T if everything is normal."
-  (declare (ignore p))
-  (let* ((nn-info (variable-value 'netnews-info :buffer headers-buffer))
-	 (point (buffer-point headers-buffer)))
-    (with-mark ((start point)
-		(end point))
-      (loop
-	(line-offset point 1)
-	(cond ((eq (nn-maybe-get-more-headers nn-info) :go-on)
-	       (cond ((eq (value netnews-last-header-style) :this-headers)
-		      (let ((headers-buffer (nn-get-headers-buffer)))
-			(change-to-buffer headers-buffer))
-		      (editor-error "Last header."))
-		     (t
-		      (return (change-to-next-group nn-info headers-buffer)))))
-	      (t
-	       (line-start (move-mark start point))
-	       (character-offset (move-mark end start) 1)
-	       (unless (string= (region-to-string (region start end)) "K")
-		 (return t))))))))
-
-(defcommand "Netnews Headers Scroll Window Up" (p)
-  "Does what \"Scroll Window Up\" does, but fetches backward when the point
-   reaches the start of the headers buffer."
-  "Does what \"Scroll Window Up\" does, but fetches backward when the point
-   reaches the start of the headers buffer."
-  (scroll-window-up-command p)
-  (let ((headers-buffer (current-buffer))
-	(nn-info (value netnews-info)))
-    (when (and (displayed-p (buffer-start-mark headers-buffer)
-			    (current-window))
-	       (not (= (nn-info-first nn-info)
-		       (nn-info-first-visible nn-info))))
-      (buffer-start (current-point))
-      (netnews-previous-line-command nil))))
-	    
-(defcommand "Netnews Headers Scroll Window Down" (p)
-  "Does what \"Scroll Window Down\" does, but when the point reaches the end of
-   the headers buffer, pending headers are inserted."
-  "Does what \"Scroll Window Down\" does, but when the point reaches the end of
-   the headers buffer, pending headers are inserted."
-  (scroll-window-down-command p)
-  (let ((headers-buffer (current-buffer))
-	(nn-info (value netnews-info)))
-    (when (and (displayed-p (buffer-end-mark headers-buffer) (current-window))
-	       (not (= (nn-info-last nn-info) (nn-info-last-visible nn-info))))
-      (buffer-end (current-point))
-      (netnews-next-line-command nil))))
-
-(defcommand "Netnews Message Keep Buffer" (p)
-  "Specifies that you don't want Hemlock to reuse the current message buffer."
-  "Specifies that you don't want Hemlock to reuse the current message buffer."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'netnews-message-info)
-    (editor-error "Not in a News-Message buffer."))
-  (setf (nm-info-keep-p (value netnews-message-info)) t))
-
-(defcommand "Netnews Goto Headers Buffer" (p)
-  "From \"Message Mode\", switch to the associated headers buffer."
-  "From \"Message Mode\", switch to the associated headers buffer."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'netnews-message-info)
-    (editor-error "Not in a message buffer."))
-  (let ((headers-buffer (nm-info-headers-buffer (value netnews-message-info))))
-    (unless headers-buffer (editor-error "Headers buffer has been deleted"))
-    (change-to-buffer headers-buffer)))
-
-(defcommand "Netnews Goto Post Buffer" (p)
-  "Change to the associated \"Post\" buffer (if there is one) from a
-   \"News-Message\" buffer."
-  "Change to the associated \"Post\" buffer (if there is one) from a
-   \"News-Message\" buffer."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'netnews-message-info)
-    (editor-error "Not in a News-Message buffer."))
-  (let ((post-buffer (nm-info-post-buffer (value netnews-message-info))))
-    (unless post-buffer (editor-error "No associated post buffer."))
-    (change-to-buffer post-buffer)))
-
-(defcommand "Netnews Goto Draft Buffer" (p)
-  "Change to the associated \"Draft\" buffer (if there is one) from a
-   \"News-Message\" buffer."
-  "Change to the associated \"Draft\" buffer (if there is one) from a
-   \"News-Message\" buffer."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'netnews-message-info)
-    (editor-error "Not in a News-Message buffer."))
-  (let ((draft-buffer (nm-info-draft-buffer (value netnews-message-info))))
-    (unless draft-buffer (editor-error "No associated post buffer."))
-    (change-to-buffer draft-buffer)))
-  
-(defcommand "Netnews Select Message Buffer" (p)
-  "Change to the associated message buffer (if there is one) in \"Post\" or
-   \"News-Headers\" modes."
-  "Change to the associated message buffer (if there is one) in \"Post\" or
-   \"News-Headers\" modes."
-  (declare (ignore p))
-  (let* ((cbuf (current-buffer))
-	 (mbuf (cond ((hemlock-bound-p 'post-info :buffer cbuf)
-		      (post-info-message-buffer (value post-info)))
-		     ((hemlock-bound-p 'netnews-info :buffer cbuf)
-		      (nn-info-buffer (value netnews-info)))
-		     (t
-		      (editor-error "Not in a \"Post\" or \"News-Headers\" ~
-		                     buffer.")))))
-    (unless mbuf (editor-error "No assocated message buffer."))
-    (change-to-buffer mbuf)))
-    
-;;; CHANGE-TO-NEXT-GROUP deletes nn-info's headers buffer region and sets
-;;; up the next group in that buffer.  If there are no more groups to read,
-;;; exits gracefully.
-;;;
-(defun change-to-next-group (nn-info headers-buffer)
-  (when (nn-info-updatep nn-info)
-    (nn-update-database-file (nn-info-latest nn-info)
-			     (nn-info-current nn-info)))
-  (let ((next-group (cadr (member (nn-info-current nn-info)
-				  (nn-info-groups nn-info) :test #'string=))))
-    (cond (next-group
-	   (message "Going on to ~A" next-group)
-	   (force-output *echo-area-stream*)
-	   (let ((message-buffer (nn-info-buffer nn-info)))
-	     (when message-buffer
-	       (setf (buffer-name message-buffer)
-		     (nn-unique-message-buffer-name next-group))))
-	   (setf (buffer-name headers-buffer)
-		 (nn-unique-headers-name next-group))
-	   (setf (nn-info-current nn-info) next-group)
-	   (with-writable-buffer (headers-buffer)
-	     (delete-region (buffer-region headers-buffer)))
-	   (setup-group next-group nn-info headers-buffer)
-	   nil)
-	  (t
-	   (if (eq headers-buffer *nn-headers-buffer*)
-	       (message "This was your last group.  Exiting Netnews.")
-	       (message "Done with ~A.  Exiting Netnews."
-			(nn-info-current nn-info)))
-	   (netnews-exit-command nil t headers-buffer)
-	   :done))))
-
-(defun nn-update-database-file (latest group-name)
-  (when latest (setf (nn-last-read-message-number group-name) latest)))
-
-
-
-;;;; More commands.
-
-(defhvar "Netnews Scroll Show Next Message"
-  "When non-nil, the default, Hemlock will show the next message in a group
-   when you scroll off the end of one.  Otherwise Hemlock will editor error
-   that you are at the end of the buffer."
-  :value T)
-
-(defcommand "Netnews Message Scroll Down" (p &optional (buffer (current-buffer))
-					     (window (current-window)))
-  "Scrolls the current window down one screenful, checking to see if we need
-   to get the next message."
-  "Scrolls the current window down one screenful, checking to see if we need
-   to get the next message."
-  (if (displayed-p (buffer-end-mark buffer) window)
-      (if (value netnews-scroll-show-next-message)
-	  (netnews-next-article-command nil)
-	  (editor-error "At end of buffer."))
-      (scroll-window-down-command p window)))
-
-(defcommand "Netnews Go to Next Group" (p)
-  "Goes on to the next group in \"Netnews Group File\", setting the group
-   pointer for this group to the the latest message read.  With an argument
-   does not modify the group pointer."
-  "Goes on to the next group in \"Netnews Group File\", setting the group
-   pointer for this group to the the latest message read.  With an argument
-   does not modify the group pointer."
-  (nn-punt-headers (if p :none :latest)))
-
-(defcommand "Netnews Group Punt Messages" (p)
-  "Go on to the next group in \"Netnews Group File\" setting the netnews
-   pointer for this group to the last message.  With an argument, set the
-   pointer to the last visible message in this group."
-  "Go on to the next group in \"Netnews Group File\" setting the netnews
-   pointer for this group to the last message.  With an argument, set the
-   pointer to the last visible message in this group."
-  (nn-punt-headers (if p :last-visible :punt)))
-
-(defcommand "Netnews Quit Starting Here" (p)
-  "Go on to the next group in \"Netnews Group File\", setting the group
-   pointer for this group to the message before the currently displayed one
-   or the message under the point if none is currently displayed."
-  "Go on to the next group in \"Netnews Group File\", setting the group
-   pointer for this group to the message before the currently displayed one
-   or the message under the point if none is currently displayed."
-  (declare (ignore p))
-  (nn-punt-headers :this-one))
-
-(defun nn-punt-headers (pointer-type)
-  (let* ((headers-buffer (nn-get-headers-buffer))
-	 (nn-info (variable-value 'netnews-info :buffer headers-buffer))
-	 (stream (nn-info-header-stream nn-info)))
-    (message "Exiting ~A" (nn-info-current nn-info))
-    (setf (nn-info-latest nn-info)
-	  (ecase pointer-type
-	    (:latest (nn-info-latest nn-info))
-	    (:punt (nn-info-last nn-info))
-	    (:last-visible (nn-info-last-visible nn-info))
-	    (:this-one
-	     (1- (if (minusp (nn-info-current-displayed-message nn-info))
-		     (array-element-from-mark (buffer-point headers-buffer)
-					      (nn-info-message-ids nn-info))
-		     (nn-info-current-displayed-message nn-info))))
-	    (:none nil)))
-    ;; This clears out all headers that waiting on header-stream.
-    ;; Must process each response in case a message is not really there.
-    ;; If it isn't, then the call to WITH-INPUT-FROM-NNTP will gobble up
-    ;; the error message and the next real article.
-    ;; 
-    (when (nn-info-messages-waiting nn-info)
-      (dotimes (i (nn-info-batch-count nn-info))
-	(let ((response (process-status-response stream)))
-	  (when response (with-input-from-nntp (string stream))))))
-    (change-to-next-group nn-info headers-buffer)))
-  
-(defcommand "Fetch All Headers" (p)
-  "Fetches the rest of the headers in the current group.
-   Warning: This will take a while if there are a lot."
-  "Fetches the rest of the headers in the current group.
-   Warning: This will take a while if there are a lot."
-  (declare (ignore p))
-  (let* ((headers-buffer (nn-get-headers-buffer))
-         (nn-info (variable-value 'netnews-info :buffer headers-buffer)))
-    (if (nn-info-messages-waiting nn-info)
-        (message "Fetching the rest of the headers for ~A"
-                 (nn-info-current nn-info))
-        (editor-error "All headers are in buffer."))
-    ;; The first of these calls writes the headers that are waiting on the
-    ;; headers stream and requests the rest.  The second inserts the rest, if
-    ;; there are any.
-    ;;
-    (nn-write-headers-to-mark nn-info headers-buffer t)
-    (nn-write-headers-to-mark nn-info headers-buffer)))
-
-
-(defcommand "List All Groups" (p &optional buffer)
-  "Shows all available newsgroups in a buffer."
-  "Shows all available newsgroups in a buffer."
-  (declare (ignore p))
-  (let* ((headers-buffer (nn-get-headers-buffer))
-	 (nn-info (if headers-buffer
-		      (variable-value 'netnews-info :buffer headers-buffer)))
-	 (stream (if headers-buffer
-		     (nn-info-stream nn-info)
-		     (connect-to-nntp))))
-    (nntp-list stream)
-    (message "Fetching group list...")
-    (process-status-response stream)
-    (let* ((buffer (or buffer (make-buffer (nn-new-list-newsgroups-name))))
-	   (point (buffer-point buffer))
-	   (groups (make-array 1500 :fill-pointer 0 :adjustable t)))
-      (with-input-from-nntp (string (if headers-buffer
-					(nn-info-stream nn-info)
-					stream))
-	(vector-push-extend string groups))
-      (sort groups #'string<)
-      (dotimes (i (length groups))
-	(let ((group (aref groups i)))
-	  (multiple-value-bind (last first) (list-response-args group)
-	    (declare (ignore first))
-	    (insert-string point group 0 (position #\space group))
-	    (insert-string point (format nil ": ~D~%" last)))))
-      (setf (buffer-modified buffer) nil)
-      (buffer-start point)
-      (change-to-buffer buffer))
-    (unless headers-buffer (close stream))))
-
-(defun nn-new-list-newsgroups-name ()
-  (let ((name "Newsgroups List")
-	(number 0))
-    (declare (simple-string name)
-	     (fixnum number))
-    (loop
-      (unless (getstring name *buffer-names*) (return name))
-      (setf name (format nil "Newsgroups List ~D" number))
-      (incf number))))
-
-(defhvar "Netnews Message File"
-  "This value is merged with your home directory to get the pathname of the
-   file to which Hemlock will append messages."
-  :value "hemlock.messages")
-
-(defhvar "Netnews Exit Confirm"
-  "When non-nil, the default, \"Netnews Exit\" will ask you if you really
-   want to.  If this variable is NIL, you will not be prompted."
-  :value T)
-
-(defcommand "Netnews Exit" (p &optional no-prompt-p
-			      (headers-buf (nn-get-headers-buffer)))
-  "Exit Netnews from a netnews headers or netnews message buffer."
-  "Exit Netnews from a netnews headers or netnews message buffer."
-  (declare (ignore p))
-  (let ((browse-buffer (variable-value 'netnews-browse-buffer
-				       :buffer headers-buf)))
-    (when (or browse-buffer
-	      no-prompt-p
-	      (not (value netnews-exit-confirm))
-	      (prompt-for-y-or-n :prompt "Exit Netnews? "
-				 :default "Y"
-				 :default-string "Y"
-				 :help "Yes exits netnews mode."))
-      (let* ((nn-info (variable-value 'netnews-info :buffer headers-buf))
-	     (message-buffer (nn-info-buffer nn-info))
-	     (headers-window (nn-info-headers-window nn-info))
-	     (message-window (nn-info-message-window nn-info)))
-	(when (nn-info-updatep nn-info)
-	  (nn-update-database-file (nn-info-latest nn-info)
-				   (nn-info-current nn-info)))
-	(when (and (eq (value netnews-read-style) :multiple)
-		   (member headers-window *window-list*)
-		   (member message-window *window-list*))
-	  (delete-window message-window))
-	(when message-buffer (delete-buffer-if-possible message-buffer))
-	(delete-buffer-if-possible headers-buf)
-	(when browse-buffer (change-to-buffer browse-buffer))))))
-
-
-
-;;;; Commands to append messages to a file or file messages into mail folders.
-
-(defcommand "Netnews Append to File" (p)
-  "In a \"News-Headers\" buffer, appends the message under the point onto
-   the file named by \"Netnews Message File\".  In a \"News-Message\" buffer,
-   appends the message in the current buffer to the same file."
-  "In a \"News-Headers\" buffer, appends the message under the point onto
-   the file named by \"Netnews Message File\".  In a \"News-Message\" buffer,
-   appends the message in the current buffer to the same file."
-  (let* ((filename (merge-pathnames (value netnews-message-file)
-				    (user-homedir-pathname)))
-	 (file (prompt-for-file :prompt "Append to what file: "
-				:must-exist nil
-				:default filename
-				:default-string (namestring filename))))
-    (when (and p (probe-file file))
-      (delete-file file))
-    (message "Appending message to ~S" (namestring file))
-    (cond ((hemlock-bound-p 'netnews-info)
-	   (let* ((nn-info (value netnews-info))
-		  (stream (nn-info-stream nn-info))
-		  (article-number (array-element-from-mark
-				   (current-point)
-				   (nn-info-message-ids nn-info)
-				   "No header under point.")))
-	     (with-open-file (file file :direction :output
-				   :element-type 'string-char
-				   :if-exists :append
-				   :if-does-not-exist :create)
-	       (nntp-article article-number stream)
-	       (process-status-response stream)
-	       (with-input-from-nntp (string (nn-info-stream nn-info))
-		 (write-line string file :end (1- (length string)))))))
-	  (t
-	   (write-file (buffer-region (current-buffer)) file)))
-    ;; Put a page separator and some whitespace between messages for
-    ;; readability when printing or scanning.
-    ;; 
-    (with-open-file (f file :direction :output :if-exists :append)
-      (terpri f)
-      (terpri f)
-      (write-line "" f)
-      (terpri f))))
-
-(defcommand "Netnews Headers File Message" (p)
-  "Files the message under the point into a folder of your choice.  If the
-   folder you select does not exist, it is created."
-  "Files the message under the point into a folder of your choice.  If the
-   folder you select does not exist, it is created."
-  (declare (ignore p))
-  (nn-file-message (value netnews-info) :headers))
-
-(defcommand "Netnews Message File Message" (p)
-  "Files the message in the current buffer into a folder of your choice.  If
-   folder you select does not exist, it is created."
-  "Files the message in the current buffer into a folder of your choice.  If
-   folder you select does not exist, it is created."
-  (declare (ignore p))
-  (nn-file-message (variable-value 'netnews-info
-				   :buffer (nn-get-headers-buffer))
-		   :message))
-
-(defun nn-file-message (nn-info kind)
-  (let ((article-number (array-element-from-mark (current-point)
-						 (nn-info-message-ids nn-info)
-						 "No header under point."))
-	(folder (prompt-for-folder :prompt "MH Folder: "
-				   :must-exist nil)))
-    (unless (folder-existsp folder)
-      (if (prompt-for-y-or-n
-	   :prompt "Destination folder doesn't exist.  Create it? "
-	   :default t :default-string "Y")
-	  (create-folder folder)
-	  (editor-error "Not filing message.")))
-    (message "Filing message into ~A" folder)
-    (ecase kind
-      (:headers (nntp-article article-number (nn-info-stream nn-info))
-		(process-status-response (nn-info-stream nn-info))
-		(with-open-file (s "/tmp/temp.msg" :direction :output
-				   :if-exists :rename-and-delete
-				   :if-does-not-exist :create)
-		  (with-input-from-nntp (string (nn-info-stream nn-info))
-		    (write-line string s :end (1- (length string))))))
-      (:message (write-file (buffer-region (current-buffer)) "/tmp/temp.msg"
-			    :keep-backup nil)))
-    (mh "inc" `(,folder "-silent" "-file" "/tmp/temp.msg"))
-    (message "Done.")))
-
-
-
-;;;; "Post" Mode and supporting commands.
-
-(defmode "Post" :major-p nil)
-
-(defun nn-unique-post-buffer-name ()
-  (let ((name "Post")
-	(number 0))
-    (loop
-      (unless (getstring name *buffer-names*) (return name))
-      (setf name (format nil "Post ~D" number))
-      (incf number))))
-
-;;; We usually know what the subject and newsgroups are, so keep these patterns
-;;; around to make finding where to insert the information easy.
-;;; 
-(defvar *draft-subject-pattern*
-  (new-search-pattern :string-insensitive :forward "Subject:"))
-
-(defvar *draft-newsgroups-pattern*
-  (new-search-pattern :string-insensitive :forward "Newsgroups:"))
-
-(defcommand "Netnews Post Message" (p)
-  "Set up a buffer for posting to netnews."
-  "Set up a buffer for posting to netnews."
-  (declare (ignore p))
-  (let ((headers-buf (nn-get-headers-buffer))
-	(post-buf (nn-make-post-buffer)))
-    ;; If we're in a "News-Headers" or "News-Message" buffer, fill in the
-    ;; newsgroups: slot in the header.
-    (when headers-buf
-      (insert-string-after-pattern (buffer-point post-buf)
-				   *draft-newsgroups-pattern*
-				   (nn-info-current
-				    (variable-value
-				     'netnews-info :buffer headers-buf))))
-    (nn-post-message nil post-buf)))
-
-(defcommand "Netnews Abort Post" (p)
-  "Abort the current post."
-  "Abort the current post."
-  (declare (ignore p))
-  (delete-buffer-if-possible (current-buffer)))
-
-(defun foobie-frob (post-info buffer)
-  (declare (ignore post-info))
-  (change-to-buffer buffer))
-#|
- #'(lambda (post-info buffer)
-     (declare (ignore post-info))
-     (print :changing) (force-output)
-     (change-to-buffer buffer)
-     (print :changed) (force-output))
-|#
-(defvar *netnews-post-frob-windows-hook* #'foobie-frob
-  "This hook is FUNCALled in NN-POST-MESSAGE with a post-info structure and
-   the corresponding \"POST\" buffer before a post is done.")
-
-;;; NN-POST-MESSAGE sets up a buffer for posting.  If message buffer is
-;;; supplied, it is associated with the post-info structure for the post
-;;; buffer.
-;;; 
-(defun nn-post-message (message-buffer &optional (buffer (nn-make-post-buffer)))
-  (setf (buffer-modified buffer) nil)
-  (when message-buffer
-    (setf (nm-info-post-buffer (variable-value 'netnews-message-info
-					       :buffer message-buffer))
-	  buffer))
-  (let ((post-info (make-post-info :stream (connect-to-nntp)
-				   :headers-buffer (nn-get-headers-buffer)
-				   :message-buffer message-buffer)))
-    (defhvar "Post Info"
-      "Information needed to manipulate post buffers."
-      :buffer buffer
-      :value post-info)
-    (funcall *netnews-post-frob-windows-hook* post-info buffer)))
-
-(defun nn-make-post-buffer ()
-  (let* ((buffer (make-buffer (nn-unique-post-buffer-name)
-			      :delete-hook (list #'nn-post-buffer-delete-hook)))
-	 (stream (make-hemlock-output-stream (buffer-point buffer))))
-    (setf (buffer-minor-mode buffer "Post") t)
-    (write-line "Newsgroups: " stream)
-    (write-line "Subject: " stream)
-;   (write-string "Date: " stream)
-;   (format stream "~A~%" (string-capitalize
-;			   (format-universal-time nil (get-universal-time)
-;						  :style :government
-;						  :print-weekday nil)))
-    (write-char #\newline stream)
-    (write-char #\newline stream)
-    buffer))
-
-;;; The usual again.  NULLify the appropriate stream slots in associated
-;;; structures.  Also call NN-REPLY-CLEANUP-SPLIT-WINDOWS to see if we
-;;; need to delete one of the current windows.
-;;; 
-(defun nn-post-buffer-delete-hook (buffer)
-  (when (hemlock-bound-p 'post-info)
-    (nn-reply-cleanup-split-windows buffer)
-    (let* ((post-info (variable-value 'post-info :buffer buffer))
-	   (message-buffer (post-info-message-buffer post-info)))
-      (close (post-info-stream post-info))
-      (when message-buffer
-	(setf (nm-info-post-buffer (variable-value 'netnews-message-info
-						   :buffer message-buffer))
-	      nil)))))
-
-;;; NN-REPLY-USING-CURRENT-WINDOW makes sure there is only one window for a
-;;; normal reply.  *netnews-post-frob-windows-hook* is bound to this when
-;;; "Netnews Reply to Group" is invoked."
-;;;
-(defun nn-reply-using-current-window (post-info buffer)
-  (declare (ignore post-info))
-  ;; Make sure there is only one window in :multiple mode.
-  ;;
-  (let* ((nn-info (variable-value 'netnews-info
-				  :buffer (nn-get-headers-buffer)))
-	 (headers-window (nn-info-headers-window nn-info))
-	 (message-window (nn-info-message-window nn-info)))
-    (when (and (eq (value netnews-read-style) :multiple)
-	       (member message-window *window-list*)
-	       (member headers-window *window-list*))
-      (setf (current-window) message-window)
-      (delete-window headers-window))
-    (change-to-buffer buffer)))
-
-;;; NN-REPLY-IN-OTHER-WINDOW-HOOK does what NN-REPLY-USING-CURRENT-WINDOW
-;;; does, but in addition splits the current window in half, displaying the
-;;; message buffer on top, and the reply buffer on the bottom.  Also set some
-;;; slots in the post info structure so the cleanup function knowd to delete
-;;; one of the two windows we've created.
-;;;
-(defun nn-reply-in-other-window-hook (post-info buffer)
-  (nn-reply-using-current-window post-info buffer)
-  (let* ((message-window (current-window))
-	 (reply-window (make-window (buffer-start-mark buffer))))
-    (setf (window-buffer message-window) (post-info-message-buffer post-info)
-	  (current-window) reply-window
-	  (post-info-message-window post-info) message-window
-	  (post-info-reply-window post-info) reply-window)))
-
-;;; NN-REPLY-CLEANUP-SPLIT-WINDOWS just deletes one of the windows that
-;;; "Netnews Reply to Group in Other Window" created, if they still exist.
-;;; 
-(defun nn-reply-cleanup-split-windows (post-buffer)
-  (let* ((post-info (variable-value 'post-info :buffer post-buffer))
-	 (message-window (post-info-message-window post-info)))
-    (when (and (member (post-info-reply-window post-info) *window-list*)
-	       (member message-window *window-list*))
-      (delete-window message-window))))
-
-(defcommand "Netnews Reply to Group" (p)
-  "Set up a POST buffer and insert the proper newgroups: and subject: fields.
-   Should be invoked from a \"News-Message\" or \"News-Headers\" buffer.
-   In a message buffer, reply to the message in that buffer, in a headers
-   buffer, reply to the message under the point."
-  "Set up a POST buffer and insert the proper newgroups: and subject: fields.
-   Should be invoked from a \"News-Message\" or \"News-Headers\" buffer.
-   In a message buffer, reply to the message in that buffer, in a headers
-   buffer, reply to the message under the point."
-  (declare (ignore p))
-  (let ((*netnews-post-frob-windows-hook* #'nn-reply-using-current-window))
-    (nn-reply-to-message)))
-
-(defcommand "Netnews Reply to Group in Other Window" (p)
-  "Does exactly what \"Netnews Reply to Group\" does, but makes two windows.
-   One of the windows displays the message being replied to, and the other
-   displays the reply."
-  "Does exactly what \"Netnews Reply to Group\" does, but makes two windows.
-   One of the windows displays the message being replied to, and the other
-   displays the reply."
-  (declare (ignore p))
-  (let ((*netnews-post-frob-windows-hook* #'nn-reply-in-other-window-hook))
-    (nn-reply-to-message)))
-
-
-(defun nn-setup-for-reply-by-mail ()
-  (let* ((headers-buffer (nn-get-headers-buffer))
-	 (nn-info (variable-value 'netnews-info :buffer headers-buffer))
-	 (message-buffer (nn-info-buffer nn-info))
-	 (nm-info (variable-value 'netnews-message-info :buffer message-buffer))
-	 (draft-buffer (sub-setup-message-draft "comp" :to-field))
-	 (dinfo (variable-value 'draft-information :buffer draft-buffer)))
-    (setf (buffer-delete-hook draft-buffer)
-	  (list #'cleanup-netnews-draft-buffer))
-    (when (nm-info-draft-buffer nm-info)
-      (delete-variable 'message-buffer :buffer (nm-info-draft-buffer nm-info)))
-    (setf (nm-info-draft-buffer nm-info) draft-buffer)
-    (when headers-buffer
-      (defhvar "Headers Buffer"
-	"This is bound in message and draft buffers to their associated
-	 headers-buffer"
-	:value headers-buffer :buffer draft-buffer))
-    (setf (draft-info-headers-mark dinfo)
-	  (copy-mark (buffer-point headers-buffer)))
-    (defhvar "Message Buffer"
-      "This is bound in draft buffers to their associated message buffer."
-      :value message-buffer :buffer draft-buffer)
-    (values draft-buffer message-buffer)))
-
-
-(defcommand "Netnews Forward Message" (p)
-  "Creates a Draft buffer and places a copy of the current message in
-   it, delimited by forwarded message markers."
-  "Creates a Draft buffer and places a copy of the current message in
-   it, delimited by forwarded message markers."
-  (declare (ignore p))
-  (multiple-value-bind (draft-buffer message-buffer)
-		       (nn-setup-for-reply-by-mail)
-    (with-mark ((mark (buffer-point draft-buffer) :left-inserting))
-      (buffer-end mark)
-      (insert-string mark (format nil "~%------- Forwarded Message~%~%"))
-      (insert-string mark (format nil "~%------- End of Forwarded Message~%"))
-      (line-offset mark -2 0)
-      (insert-region mark (buffer-region message-buffer)))
-    (nn-reply-using-current-window nil draft-buffer)))
-
-
-(defun nn-reply-to-sender ()
-  (let* ((headers-buffer (nn-get-headers-buffer))
-	 (nn-info (variable-value 'netnews-info :buffer headers-buffer))
-	 (article (if (and (hemlock-bound-p 'netnews-info)
-			   (minusp (nn-info-current-displayed-message
-				    nn-info)))
-		      (nn-put-article-in-buffer nn-info headers-buffer)
-		      (nn-info-current-displayed-message nn-info))))
-    (multiple-value-bind (draft-buffer message-buffer)
-			 (nn-setup-for-reply-by-mail)
-      (let ((point (buffer-point draft-buffer))
-	    (to-field (or (nn-get-one-field nn-info "Reply-To" article)
-			  (nn-get-one-field nn-info "From" article))))
-	(insert-string-after-pattern point
-				     *draft-to-pattern*
-				     to-field
-				     :end (1- (length to-field)))
-	(let ((subject-field (nn-subject-replyify
-			      (nn-get-one-field nn-info "Subject" article))))
-	  (insert-string-after-pattern point
-				       *draft-subject-pattern*
-				       subject-field
-				       :end (1- (length subject-field)))))
-      (nn-reply-using-current-window nil draft-buffer)
-      (values draft-buffer message-buffer))))
-
-(defcommand "Netnews Reply to Sender" (p)
-  "Reply to the sender of a message via mail using the Hemlock mailer."
-  "Reply to the sender of a message via mail using the Hemlock mailer."
-  (declare (ignore p))
-  (nn-reply-to-sender))
-
-(defcommand "Netnews Reply to Sender in Other Window" (p)
-  "Reply to the sender of a message via mail using the Hemlock mailer.  The
-   screen will be split in half, displaying the post and the draft being
-   composed."
-  "Reply to the sender of a message via mail using the Hemlock mailer.  The
-   screen will be split in half, displaying the post and the draft being
-   composed."
-  (declare (ignore p))
-  (multiple-value-bind (draft-buffer message-buffer)
-		       (nn-reply-to-sender)
-    (let* ((message-window (current-window))
-	   (reply-window (make-window (buffer-start-mark draft-buffer))))
-      (defhvar "Split Window Draft"
-	"Indicates window needs to be cleaned up for draft."
-	:value t :buffer draft-buffer)
-      (setf (window-buffer message-window) message-buffer
-	    (current-window) reply-window))))
-
-;;; CLEANUP-NETNEWS-DRAFT-BUFFER replaces the normal draft buffer delete hook
-;;; because the generic one tries to set some slots in the related message-info
-;;; structure which doesn't exist.  This function just sets the draft buffer
-;;; slot of netnews-message-info to nil so it won't screw you when you try
-;;; to change to the associated draft buffer.
-;;; 
-(defun cleanup-netnews-draft-buffer (buffer)
-  (when (hemlock-bound-p 'message-buffer :buffer buffer)
-    (setf (nm-info-draft-buffer
-	   (variable-value 'netnews-message-info
-			   :buffer (variable-value 'message-buffer
-						   :buffer buffer)))
-	  nil))))
-
-;;; NN-REPLYIFY-SUBJECT simply adds "Re: " to the front of a string if it is
-;;; not already there.
-;;; 
-(defun nn-subject-replyify (subject)
-  (if (>= (length subject) 3)
-      (if (not (string= subject "Re:" :end1 3 :end2 3))
-	  (concatenate 'simple-string "Re: " subject)
-	  subject)
-      (concatenate 'simple-string "Re: " subject)))
-
-(defun insert-string-after-pattern (mark search-pattern string
-				    &key (start 0) (end (length string)))
-  (buffer-start mark)
-  (when (and (plusp end)
-	     (find-pattern mark search-pattern))
-    (insert-string (line-end mark) string start end))
-  (buffer-end mark))
-
-(defun nn-reply-to-message ()
-  (let* ((headers-buffer (nn-get-headers-buffer))
-	 (nn-info (variable-value 'netnews-info :buffer headers-buffer))
-	 (article (if (and (hemlock-bound-p 'netnews-info)
-			   (minusp (nn-info-current-displayed-message nn-info)))
-		      (nn-put-article-in-buffer nn-info headers-buffer)
-		      (nn-info-current-displayed-message nn-info)))
-	 (post-buffer (nn-make-post-buffer))
-	 (point (buffer-point post-buffer)))
-
-    (let ((groups-field (nn-get-one-field nn-info "Newsgroups" article)))
-      (insert-string-after-pattern point
-				   *draft-newsgroups-pattern*
-				   groups-field
-				   :end (1- (length groups-field))))
-    (let ((subject-field (nn-subject-replyify
-			  (nn-get-one-field nn-info "Subject" article))))
-      (insert-string-after-pattern point
-				   *draft-subject-pattern*
-				   subject-field
-				   :end (1- (length subject-field))))
-    (nn-post-message (nn-info-buffer nn-info) post-buffer)))
-
-(defun nn-get-one-field (nn-info field article)
-  (cdr (assoc field (svref (nn-info-header-cache nn-info)
-			  (- article (nn-info-first nn-info)))
-	      :test #'string-equal)))
-		     
-(defvar *nntp-timeout-handler* 'nn-recover-from-timeout
-  "This function gets FUNCALled when NNTP times out on us with the note passed
-   to PROCESS-STATUS-RESPONSE.  The default assumes the note is an NN-INFO
-   structure and tries to recover from the timeout.")
-
-(defvar *nn-last-command-issued* nil
-  "The last string issued to one of the NNTP streams.  Used to recover from
-   a nntp timeout.")
-
-;;; NN-RECOVER-FROM-POSTING-TIMEOUT is the recover method used when posting.
-;;; It just resets the value of \"NNTP Stream\" and issues the last command
-;;; again.
-;;;
-(defun nn-recover-from-posting-timeout (ignore)
-  (declare (ignore ignore))
-  (let ((stream (connect-to-nntp)))
-    (setf (post-info-stream (value post-info)) stream)
-    (write-nntp-command *nn-last-command-issued* stream :recover)
-    (process-status-response stream)))
-  
-(defhvar "Netnews Reply Address"
-  "What the From: field will be when you post messages.  If this is nil,
-   the From: field will be determined using the association of :USER
-   in *environment-list* and your machine name."
-  :value NIL)
-
-(defhvar "Netnews Signature Filename"
-  "This value is merged with your home directory to get the pathname your
-   signature, which is appended to every post you make."
-  :value ".hemlock-sig")
-
-(defhvar "Netnews Deliver Post Confirm"
-  "This determines whether Netnews Deliver Post will ask for confirmation
-   before posting the current message."
-  :value t)
-
-(defcommand "Netnews Deliver Post" (p)
-  "Deliver the current Post buffer to the NNTP server.  If the file named by
-   the value of \"Netnews Signature Filename\" exists, it is appended to the
-   end of the message after adding a newline."
-  "Deliver the current Post buffer to the NNTP server, cleaning up any windows
-   we need and landing us in the headers buffer if this was a reply."
-  (declare (ignore p))
-  (when (or (not (value netnews-deliver-post-confirm))
-	    (prompt-for-y-or-n :prompt "Post message? " :default t))
-    (let* ((*nntp-timeout-handler* #'nn-recover-from-posting-timeout)
-	   (stream (post-info-stream (value post-info))))
-      (nntp-post stream)
-      (let ((winp (process-status-response stream))
-	    ;; Rebind stream here because the stream may have been pulled out
-	    ;; from under us by an NNTP timeout.  The recover method for posting
-	    ;; resets the Hemlock Variable.
-	    (stream (post-info-stream (value post-info))))
-	(unless winp (editor-error "Posting prohibited in this group."))
-	(let ((buffer (current-buffer))
-	      (username (value netnews-reply-address)))
-	  (nn-write-line (format nil "From: ~A"
-				 (if username
-				     username
-				     (string-downcase
-				      (format nil "~A@~A"
-					      (cdr (assoc :user
-							  ext:*environment-list*))
-					      (machine-instance)))))
-			 stream)
-	  (filter-region #'(lambda (string)
-			     (when (string= string ".")
-			       (write-char #\. stream))
-			     (nn-write-line string stream))
-			 (buffer-region buffer))
-	  ;; Append signature
-	  ;;
-	  (let ((filename (merge-pathnames (value netnews-signature-filename)
-					   (user-homedir-pathname))))
-	    (when (probe-file filename)
-	      (with-open-file (istream filename :direction :input)
-		(loop
-		  (let ((line (read-line istream nil nil)))
-		    (unless line (return))
-		    (nn-write-line line stream))))))
-	  (write-line nntp-eof stream)
-	  (delete-buffer-if-possible buffer)
-	  (let ((headers-buffer (nn-get-headers-buffer)))
-	    (when headers-buffer (change-to-buffer headers-buffer)))
-	  (message "Message Posted."))))))
-
-(defun nn-write-line (line stream)
-  (write-string line stream)
-  (write-char #\return stream)
-  (write-char #\newline stream)
-  line)
-
-
-
-;;;; News-Browse mode.
-
-(defmode "News-Browse" :major-p t)
-
-(defhvar "Netnews Group File"
-  "If the value of \"Netnews Groups\" is nil, \"Netnews\" merges this
-   variable with your home directory and looks there for a list of newsgroups
-   (one per line) to read.  Groups may be added using \"Netnews Browse\ and
-   related commands, or by editing this file."
-  :value ".hemlock-groups")
-
-(defcommand "Netnews Browse" (p)
-  "Puts all netnews groups in a buffer and provides commands for reading them
-   and adding them to the file specified by the merge of \"Netnews Group File\"
-   and your home directory."
-  "Puts all netnews groups in a buffer and provides commands for reading them
-   and adding them to the file specified by the merge of \"Netnews Group File\"
-   and your home directory."
-  (declare (ignore p))
-  (let ((buffer (make-buffer "Netnews Browse")))
-    (cond (buffer
-	   (list-all-groups-command nil buffer)
-	   (setf (buffer-major-mode buffer) "News-Browse")
-	   (setf (buffer-writable buffer) nil))
-	  (t (change-to-buffer (getstring "Netnews Browse" *buffer-names*))))))
-
-(defcommand "Netnews Quit Browse" (p)
-  "Exit News-Browse Mode."
-  "Exit News-Browse Mode."
-  (declare (ignore p))
-  (delete-buffer-if-possible (current-buffer)))
-
-(defcommand "Netnews Browse Read Group" (p &optional (mark (current-point)))
-  "Read the group on the line under the current point paying no attention to
-    the \"Hemlock Database File\" entry for this group.  With an argument, use
-    and modify the database file."
-  "Read the group on the line under the current point paying no attention to
-    the \"Hemlock Database File\" entry for this group.  With an argument, use
-    and modify the database file."
-  (let ((group-info-string (line-string (mark-line mark))))
-    (netnews-command nil (subseq group-info-string
-				 0 (position #\: group-info-string))
-		     nil (current-buffer) p)))
-
-(defcommand "Netnews Browse Pointer Read Group" (p)
-  "Read the group on the line where you just clicked paying no attention to the
-   \"Hemlock Databse File\" entry for this group.  With an argument, use and
-   modify the databse file."
-  "Read the group on the line where you just clicked paying no attention to the
-   \"Hemlock Databse File\" entry for this group.  With an argument, use and
-   modify the databse file."
-  (multiple-value-bind (x y window) (last-key-event-cursorpos)
-    (unless window (editor-error "Couldn't figure out where last click was."))
-    (unless y (editor-error "There is no group in the modeline."))
-    (netnews-browse-read-group-command p (cursorpos-to-mark x y window))))
-
-(defcommand "Netnews Browse Add Group to File" (p &optional
-						      (mark (current-point)))
-  "Append the newsgroup on the line under the point to the file specified by
-   \"Netnews Group File\".  With an argument, delete all groups that were
-   there to start with."
-  "Append the newsgroup on the line under the point to the file specified by
-   \"Netnews Group File\".  With an argument, delete all groups that were
-   there to start with."
-  (declare (ignore p))
-  (let* ((group-info-string (line-string (mark-line mark)))
-	 (group (subseq group-info-string 0 (position #\: group-info-string))))
-    (with-open-file (s (merge-pathnames (value netnews-group-file)
-					(user-homedir-pathname))
-		       :direction :output
-		       :if-exists :append
-		       :if-does-not-exist :create)
-      (write-line group s))
-    (message "Adding ~S to newsgroup file." group)))
-      
-(defcommand "Netnews Browse Pointer Add Group to File" (p)
-  "Append the newsgroup you just clicked on to the file specified by
-   \"Netnews Group File\"."
-  "Append the newsgroup you just clicked on to the file specified by
-   \"Netnews Group File\"."
-  (declare (ignore p))
-  (multiple-value-bind (x y window) (last-key-event-cursorpos)
-    (unless window (editor-error "Couldn't figure out where last click was."))
-    (unless y (editor-error "There is no group in the modeline."))
-    (netnews-browse-add-group-to-file-command
-     nil (cursorpos-to-mark x y window))))
-
-
-
-;;;; Low-level stream operations.
-
-(defun streams-for-nntp ()
-  (clear-echo-area)
-  (format *echo-area-stream* "Connecting to NNTP...~%")
-  (force-output *echo-area-stream*)
-  (values (connect-to-nntp) (connect-to-nntp)))
-
-
-(defparameter *nntp-port* 119
-  "The nntp port number for NNTP as specified in RFC977.")
-
-(defhvar "Netnews NNTP Server"
-  "The hostname of the NNTP server to use for reading Netnews."
-  :value "netnews.srv.cs.cmu.edu")
-
-(defhvar "Netnews NNTP Timeout Period"
-  "The number of seconds to wait before timing out when trying to connect
-   to the NNTP server."
-  :value 30)
-
-(defun raw-connect-to-nntp ()
-  (let ((stream (system:make-fd-stream
-		 (ext:connect-to-inet-socket (value netnews-nntp-server)
-					     *nntp-port*)
-		 :input t :output t :buffering :line :name "NNTP"
-		 :timeout (value netnews-nntp-timeout-period))))
-    (process-status-response stream)
-    stream))
-
-(defun connect-to-nntp ()
-  (handler-case
-      (raw-connect-to-nntp)
-    (io-timeout ()
-      (editor-error "Connection to NNTP timed out.  Try again later."))))
-
-(defvar *nn-last-command-type* nil
-  "Used to recover from a nntp timeout.")
-
-(defun write-nntp-command (command stream type)
-  (setf *nn-last-command-type* type)
-  (setf *nn-last-command-issued* command)
-  (write-string command stream)
-  (write-char #\return stream)
-  (write-char #\newline stream)
-  (force-output stream))
-
-
-
-;;;; PROCESS-STATUS-RESPONSE and NNTP error handling.
-
-(defconstant nntp-error-codes '(#\4 #\5)
-  "These codes signal that NNTP could not complete the request you asked for.")
-
-(defvar *nntp-error-handlers* nil)
-
-;;; PROCESS-STATUS-RESPONSE makes sure a response waiting at the server is
-;;; valid.  If the response code starts with a 4 or 5, then look it up in
-;;; *nntp-error-handlers*.  If an error handler is defined, then FUNCALL it
-;;; on note.  Otherwise editor error.  If the response is not an error code,
-;;; then just return what NNTP returned to us for parsing later.
-;;;
-(defun process-status-response (stream &optional note)
-  (let ((str (read-line stream)))
-    (if (member (schar str 0) nntp-error-codes :test #'char=)
-	(let ((error-handler (cdr (assoc str *nntp-error-handlers*
-					 :test #'(lambda (string1 string2)
-						   (string= string1 string2
-							    :end1 3
-							    :end2 3))))))
-	  (unless error-handler
-	    (error "NNTP error -- ~A" (subseq str 4 (1- (length str)))))
-	  (funcall error-handler note))
-	str)))
-
-(defun nn-recover-from-timeout (nn-info)
-  (message "NNTP timed out, attempting to reconnect and continue...")
-  (let ((stream (nn-info-stream nn-info))
-	(header-stream (nn-info-header-stream nn-info)))
-    ;; If some messages are waiting on the header stream, insert them.
-    ;;
-    (when (listen header-stream)
-      (nn-write-headers-to-mark nn-info (nn-get-headers-buffer)))
-    (close stream)
-    (close header-stream)
-    (setf stream (connect-to-nntp)
-	  header-stream (connect-to-nntp)
-	  (nn-info-stream nn-info) stream
-	  (nn-info-header-stream nn-info) header-stream)
-    (let ((last-command *nn-last-command-issued*)
-	  (last-command-type *nn-last-command-type*)
-	  (current (nn-info-current nn-info)))
-      (nntp-group current stream header-stream)
-      (process-status-response stream)
-      (process-status-response header-stream)
-      (if (consp last-command)
-	  (let ((stream-type (car last-command)))
-	    (apply #'nn-send-many-head-requests
-		   (cons (if (eq stream-type :header) header-stream stream)
-			 (cdr last-command))))
-	  (ecase last-command-type
-	    ((:list :article :body)
-	     (write-nntp-command last-command stream :recover)
-	     (process-status-response stream))
-	    ((:header-group :normal-group)
-	     (write-nntp-command last-command stream :recover)
-	     (write-nntp-command last-command header-stream :recover)))))))
-
-;;; DEF-NNTP-ERROR-HANDLER takes a code and a function and associates the two
-;;; in *nntp-error-handlers*.  If while PROCESSING a STATUS RESPONSE we come
-;;; across one of these error codes, then FUNCALL the appropriate handler.
-;;; 
-(defun def-nntp-error-handler (code function)
-  (pushnew (cons (format nil "~D" code) function) *nntp-error-handlers*))
-
-;;; 503 is an NNTP timeout.  The code I wrote reconnects and recovers
-;;; completely.
-;;; 
-(def-nntp-error-handler 503 #'(lambda (note)
-				(funcall *nntp-timeout-handler* note)))
-
-;;; 400 means NNTP is cutting us of for some reason.  There is really nothing
-;;; we can do.
-;;; 
-(def-nntp-error-handler 400 #'(lambda (ignore)
-				(declare (ignore ignore))
-				(editor-error "NNTP discontinued service.  ~
-				You should probably quit netnews and try ~
-				again later.")))
-
-;;; Some functions just need to know that something went wrong so they can
-;;; do something about it, so let them know by returning nil.
-;;;
-;;; 411  -   The group you tried to read is not a netnews group.
-;;; 423  -   You requested a message that wasn't really there.
-;;; 440  -   Posting is not allowed.
-;;; 441  -   Posting is allowed, but the attempt failed for some other reason.
-;;; 
-(flet ((nil-function (ignore)
-	 (declare (ignore ignore))
-	 nil))
-  (def-nntp-error-handler 423 #'nil-function)
-  (def-nntp-error-handler 411 #'nil-function)
-  (def-nntp-error-handler 440 #'nil-function)
-  (def-nntp-error-handler 441 #'nil-function))
-
-
-
-;;;; Implementation of NNTP response argument parsing.
-
-;;; DEF-NNTP-ARG-PARSER returns a form that parses a string for arguments
-;;; corresponding to each element of types.  For instance, if types is
-;;; (:integer :string :integer :integer), this function returns a form that
-;;; parses an integer, a string, and two more integers out of an nntp status
-;;; response.
-;;;
-(defmacro def-nntp-arg-parser (types)
-  (let ((form (gensym))
-	(start (gensym))
-	(res nil))
-    (do ((type types (cdr type)))
-	((endp type) form)
-      (ecase (car type)
-	(:integer
-	 (push `(parse-integer string :start ,start
-			       :end (setf ,start
-					  (position #\space string
-						    :start (1+ ,start)))
-			       :junk-allowed t)
-	       res))
-	(:string
-	 (push `(subseq string (1+ ,start)
-			(position #\space string
-				  :start (setf ,start (1+ ,start))))
-	       res))))
-    `(let ((,start (position #\space string)))
-       (values ,@(nreverse res)))))
-
-(defun def-nntp-xhdr-arg-parser (string)
-  (let ((position (position #\space string)))
-    (values (subseq string (1+ position))
-	    (parse-integer string :start 0 :end position))))
-
-(defun xhdr-response-args (string)
-  (def-nntp-xhdr-arg-parser string))
-
-;;; GROUP-RESPONSE-ARGS, ARTICLER-RESPONSE-ARGS, HEAD-RESPONSE-ARGS,
-;;; BODY-RESPONSE-ARGS, and STAT-RESPONSE-ARGS define NNTP argument parsers
-;;; for the types of arguments each command will return.
-;;; 
-(defun group-response-args (string)
-  "Group response args are an estimate of how many messages there are, the
-   number of the first message, the number of the last message, and \"y\"
-   or \"n\", indicating whether the user has rights to post in this group."
-  (def-nntp-arg-parser (:integer :integer :integer)))
-
-(defun list-response-args (string)
-  (def-nntp-arg-parser (:integer :integer)))
-
-(defun article-response-args (string)
-  "Article response args are the message number and the message ID."
-  (def-nntp-arg-parser (:integer :string)))
-
-(defun head-response-args (string)
-  "Head response args are the message number and the message ID."
-  (def-nntp-arg-parser (:integer :string)))
-
-(defun body-response-args (string)
-  "Body response args are the message number and the message ID."
-  (def-nntp-arg-parser (:integer :string)))
-
-(defun stat-response-args (string)
-  "Stat response args are the message number and the message ID."
-  (def-nntp-arg-parser (:integer :string)))
-
-
-
-;;;; Functions that send standard NNTP commands.
-
-;;; NNTP-XHDR sends an XHDR command to the NNTP server.  We think this is a
-;;; local extension, but not using it is not pragmatic.  It takes over three
-;;; minutes to HEAD every message in a newsgroup.
-;;; 
-(defun nntp-xhdr (field start end stream)
-  (write-nntp-command (format nil "xhdr ~A ~D-~D"
-			      field
-			      (if (numberp start) start (parse-integer start))
-			      (if (numberp end) end (parse-integer end)))
-		      stream
-		      :xhdr))
-
-(defun nntp-group (group-name stream header-stream)
-  (let ((command (concatenate 'simple-string "group " group-name)))
-    (write-nntp-command command stream :normal-group)
-    (write-nntp-command command header-stream :header-group)))
-
-(defun nntp-list (stream)
-  (write-nntp-command "list" stream :list))
-
-(defun nntp-head (article stream)
-  (write-nntp-command (format nil "head ~D" article) stream :head))
-
-(defun nntp-article (number stream)
-  (write-nntp-command (format nil "article ~D" number) stream :article))
-
-(defun nntp-body (number stream)
-  (write-nntp-command (format nil "body ~D" number) stream :body))
-
-(defun nntp-post (stream)
-  (write-nntp-command "post" stream :post))
diff --git a/hemlock/notes.txt b/hemlock/notes.txt
deleted file mode 100644
index 3da86bbe711a350233e7484ee5daf7d09579d574..0000000000000000000000000000000000000000
--- a/hemlock/notes.txt
+++ /dev/null
@@ -1,27 +0,0 @@
-(defcommand "Find File From Sources" (p)
-  "" ""
-  (declare (ignore p))
-  (let ((point (current-point)))
-    (with-mark ((start point)
-		(end point))
-      (find-file-command
-       nil
-       (merge-pathnames "src:"
-			(region-to-string (region (line-start start)
-						  (line-end end))))))))
-
-* abbrev.lisp
-* doccoms.lisp
-* echo.lisp
-* echocoms.lisp
-* filecoms.lisp
-* lisp-lib.lisp  ;Blew away help command, should do describe mode.
-* lispbuf.lisp
-* lispeval.lisp  ;Maybe write MESSAGE-EVAL_FORM-RESULTS.
-* macros.lisp    <<< Already changed in WORK:
-* mh.lisp        <<< Ask Bill about INC in "Incorporate New Mail".
-* morecoms.lisp
-* register.lisp
-* scribe.lisp
-* searchcoms.lisp
-* spellcoms.lisp
diff --git a/hemlock/overwrite.lisp b/hemlock/overwrite.lisp
deleted file mode 100644
index a7a4713a1467362af9cdfff8bdd8766fa82a9b57..0000000000000000000000000000000000000000
--- a/hemlock/overwrite.lisp
+++ /dev/null
@@ -1,67 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/overwrite.lisp,v 1.3 1991/02/08 16:36:53 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles.
-;;;
-
-(in-package 'hemlock)
-
-
-(defmode "Overwrite")
-
-
-(defcommand "Overwrite Mode" (p)
-  "Printing characters overwrite characters instead of pushing them to the right.
-   A positive argument turns Overwrite mode on, while zero or a negative
-   argument turns it off.  With no arguments, it is toggled.  Use C-Q to
-   insert characters normally."
-  "Determine if in Overwrite mode or not and set the mode accordingly."
-  (setf (buffer-minor-mode (current-buffer) "Overwrite")
-	(if p
-	    (plusp p)
-	    (not (buffer-minor-mode (current-buffer) "Overwrite")))))
-
-
-(defcommand "Self Overwrite" (p)
-  "Replace the next character with the last character typed,
-   but insert at end of line.  With prefix argument, do it that many times."
-  "Implements ``Self Overwrite'', calling this function is not meaningful."
-  (let ((char (ext:key-event-char *last-key-event-typed*))
-	(point (current-point)))
-    (unless char (editor-error "Can't insert that character."))
-    (do ((n (or p 1) (1- n)))
-	((zerop n))
-      (case (next-character point)
-	(#\tab
-	 (let ((col1 (mark-column point))
-	       (col2 (mark-column (mark-after point))))
-	   (if (= (- col2 col1) 1)
-	       (setf (previous-character point) char)
-	       (insert-character (mark-before point) char))))
-	((#\newline nil) (insert-character point char))
-	(t (setf (next-character point) char)
-	   (mark-after point))))))
-
-
-(defcommand "Overwrite Delete Previous Character" (p)
-  "Replaces previous character with space, but tabs and newlines are deleted.
-   With prefix argument, do it that many times."
-  "Replaces previous character with space, but tabs and newlines are deleted."
-  (do ((point (current-point))
-       (n (or p 1) (1- n)))
-      ((zerop n))
-    (case (previous-character point)
-      ((#\newline #\tab) (delete-characters point -1))
-      ((nil) (editor-error))
-      (t (setf (previous-character point) #\space)
-	 (mark-before point)))))
diff --git a/hemlock/pascal.lisp b/hemlock/pascal.lisp
deleted file mode 100644
index f6866ffe46685575ecce0061f2c07d50c140185f..0000000000000000000000000000000000000000
--- a/hemlock/pascal.lisp
+++ /dev/null
@@ -1,48 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/pascal.lisp,v 1.2 1991/02/08 16:36:56 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Just barely enough to be a Pascal/C mode.  Maybe more some day.
-;;; 
-(in-package 'hemlock)
-
-(defmode "Pascal" :major-p t)
-(defcommand "Pascal Mode" (p)
-  "Put the current buffer into \"Pascal\" mode."
-  "Put the current buffer into \"Pascal\" mode."
-  (declare (ignore p))
-  (setf (buffer-major-mode (current-buffer)) "Pascal"))
-
-(defhvar "Indent Function"
-  "Indentation function which is invoked by \"Indent\" command.
-   It must take one argument that is the prefix argument."
-  :value #'generic-indent
-  :mode "Pascal")
-
-(defhvar "Auto Fill Space Indent"
-  "When non-nil, uses \"Indent New Comment Line\" to break lines instead of
-   \"New Line\"."
-  :mode "Pascal" :value t)
-
-(defhvar "Comment Start"
-  "String that indicates the start of a comment."
-  :mode "Pascal" :value "(*")
-
-(defhvar "Comment End"
-  "String that ends comments.  Nil indicates #\newline termination."
-  :mode "Pascal" :value " *)")
-
-(defhvar "Comment Begin"
-  "String that is inserted to begin a comment."
-  :mode "Pascal" :value "(* ")
-
-(shadow-attribute :scribe-syntax #\< nil "Pascal")
diff --git a/hemlock/perq-hemlock.log b/hemlock/perq-hemlock.log
deleted file mode 100644
index 6629d63f5b6a744b6e209b71f1679753f452da81..0000000000000000000000000000000000000000
--- a/hemlock/perq-hemlock.log
+++ /dev/null
@@ -1,146 +0,0 @@
-/Lisp2/Slisp/Hemlock/perqsite.slisp#1, 23-Mar-85 11:05:16, Edit by Ram
-  Made wait-for-more use logical-char=.
-
-/lisp2/slisp/hemlock/echocoms.slisp#1, 22-Mar-85 13:41:10, Edit by Ram
-  Made "Complete Keyword" and "Help on Parse" pass the parse default into
-  Complete-File and Ambiguous-Files, respectively.
-
-/Lisp2/Slisp/Hemlock/echocoms.slisp#1, 22-Mar-85 10:51:09, Edit by Ram
-  Updated to correspond to new prompting conventions.
-
-/Lisp2/Slisp/Hemlock/echo.slisp#1, 22-Mar-85 10:21:19, Edit by Ram
-  Changes to make defaulting work better.  *parse-default* is now a string
-  which we pretend we read when we confirm an empty parse.
-  *parse-default-string* is now only used in displaying the default, as it
-  should be.  The prompt and help can now be a list of format string and format
-  arguments.  The feature of help being a function is gone.
-
-/Lisp2/Slisp/Hemlock/echo.slisp#1, 22-Mar-85 08:00:01, Edit by Ram
-  Made Parse-For-Something specify NIL to Recursive-Edit so that C-G's will
-  blow away prompts.
-
-/Lisp2/Slisp/Hemlock/buffer.slisp#1, 22-Mar-85 07:57:49, Edit by Ram
-  Added the optional Handle-Abort argument to recursive-edit so that we can
-  have recursive-edits that aren't blown away by C-G's.
-
-/Lisp2/Slisp/Hemlock/spellcoms.slisp#1, 22-Mar-85 07:35:01, Edit by Ram
-  Made Sub-Correct-Last-Misspelled-Word delete the marks pointing to misspelled
-  words when it pops them off the ring.
-
-/lisp2/slisp/hemlock/syntax.slisp#1, 18-Mar-85 07:20:53, Edit by Ram
-  Fixed problem with the old value not being saved if a shadow-attribute was
-  dowe for a mode that is currently active.
-
-/lisp2/slisp/hemlock/defsyn.slisp#1, 14-Mar-85 09:42:53, Edit by Ram
-  Made #\. be a word delimiter by default.  For old time's sake, it is not
-  a delimiter in "Fundamental" mode.
-
-/Lisp2/Slisp/Hemlock/filecoms.slisp#1, 13-Mar-85 00:25:19, Edit by Ram
-  Changed write-da-file not to compare write dates if the file desn't exist.
-
-/Lisp2/Slisp/Hemlock/perqsite.slisp#1, 13-Mar-85 00:15:31, Edit by Ram
-  Changed emergency message stuff to divide the message size by 8.
-
-/Lisp2/Slisp/Hemlock/htext2.slisp#1, 13-Mar-85 00:07:13, Edit by Ram
-  Changed %set-next-character to use the body of Modifying-Buffer.  Made
-  string-to-region give the region a disembodied buffer count.
-
-/Lisp2/Slisp/Hemlock/htext3.slisp#1, 12-Mar-85 23:53:57, Edit by Ram
-  Changed everyone to use the body of modifying-buffer.
-
-/Lisp2/Slisp/Hemlock/htext1.slisp#1, 12-Mar-85 23:45:51, Edit by Ram
-  Made Modifying-Buffer have a body and wrap a without-interrupts around the
-  body.  Changed %set-line-string to run within the body of modifying-buffer.
-
-/Lisp2/Slisp/Hemlock/echocoms.slisp#1, 12-Mar-85 23:28:40, Edit by Ram
-  Made "Confirm Parse" push the input before calling the confirm function so
-  that if it gets an error, you don't have to type it again.  Also changed it
-  to directly return the default if there is empty input, rather than calling
-  the confirm function on the default string.  It used to be this way, and I
-  changed it, but don't remember why.
-
-/Lisp2/Slisp/Hemlock/group.slisp#1, 12-Mar-85 23:10:43, Edit by Ram
-  Made group-read-file go to the beginning of the buffer, which is useful in
-  the case where the file was already read.
-
-/Lisp2/Slisp/Hemlock/lispbuf.slisp#1, 12-Mar-85 22:58:03, Edit by Ram
-  Made "Compile File" use buffer-default-pathname to get defaults for the
-  prompt.  Added "Compile Group" command.
-
-/lisp2/slisp/hemlock/kbdmac.slisp#1, 09-Mar-85 20:53:33, Edit by Ram
-  Made default-kbdmac-transform bind *invoke-hook* so that recursive edits
-  don't try do clever stuff.
-
-/lisp2/slisp/hemlock/perqsite.slisp#1, 09-Mar-85 14:16:41, Edit by Ram
-  Changed editor-input stream to use new stream representation.  Moved
-  Input-Waiting here from Streams, changed definition to return T or NIL
-  instead of number of chars.  Made Wait-For-More not unread the character if
-  it is rubout.  Made level-1-abort handler clear input.
-
-/lisp2/slisp/hemlock/streams.slisp#1, 09-Mar-85 14:59:02, Edit by Ram
-  Changed to use new stream representation.
-
-/lisp2/slisp/hemlock/pane-stream.slisp#1, 09-Mar-85 14:51:25, Edit by Ram
-  Changed to use new stream representation.
-
-/lisp2/slisp/hemlock/lispmode.slisp#1, 05-Mar-85 11:59:15, Edit by Ram
-  Changed the "Defindent" command to go to the beginning of the line before
-  doing the backward-up-list.  This means that we always find the form
-  controlling indentation for the current line, rather than the enclosing form.
-  Do a "Indent For Lisp" after we redefine the indentation, since it presumably
-  changed.
-
-/lisp2/slisp/hemlock/spell-corr.slisp#1, 05-Mar-85 11:39:19, Edit by Ram
-  Fixed everyone to use gr-call.  Made Correct-Spelling call
-  maybe-read-spell-dictionary, rather than trying to look at
-  *spell-opeining-return*.
-
-/lisp2/slisp/hemlock/spell-augment.slisp#1, 05-Mar-85 11:53:04, Edit by Ram
-  Fixed everyone to use gr-call and friends.
-
-/Lisp2/Slisp/Hemlock/command.slisp#1, 21-Feb-85 00:56:52, Edit by Ram
-  Edited back in change to "Scroll Next Window ..." commands to make them
-  complain if there is only one window.
-
-/Lisp2/Slisp/Hemlock/filecoms.slisp#1, 21-Feb-85 00:48:00, Edit by Ram
-  Edited back in changes:
-    Make "Backup File" message the file written.
-    Make Previous-Buffer return any buffer other than the current buffer
-      and the echo area buffer it there is nothing good in the history.
-
-/Lisp2/Slisp/Hemlock/bindings.slisp#1, 21-Feb-85 00:30:48, Edit by Ram
-  Removed spurious binding of #\' to "Check Word Spelling".
-
-/Lisp2/Boot/Hemlock/spellcoms.slisp#1, 05-Feb-85 13:58:54, Edit by Ram
-  Added call to Region-To-String in "Add Word to Spelling Dictionary" so that
-  it worked.
-
-/Lisp2/Boot/Hemlock/fill.slisp#1, 31-Jan-85 12:09:01, Edit by Ram
-  Made "Set Fill Prefix" and "Set Fill Column" define a buffer local variable
-  so that the values are buffer local.
-
-/Lisp2/Boot/Hemlock/fill.slisp#1, 26-Jan-85 17:19:57, Edit by Ram
-  Made / be a paragraph delimiter.
-
-/Lisp2/Boot/Hemlock/search2.slisp#1, 26-Jan-85 17:07:37, Edit by Ram
-  Fixed the reclaim-function for set search patterns to reclaim the set instead
-  of the search-pattern structure.
-
-/Lisp2/Boot/Hemlock/group.slisp#1, 25-Jan-85 22:07:15, Edit by Ram 
-  Changed the way Group-Read-File works.  We always use "Find File" to read in
-  the file, but if "Group Find File" is false, and we created a new buffer, we
-  rename the buffer to "Group Search", nuking any old buffer of that name.  If
-  we are in the "Group Search" buffer when we finish, we nuke it and go to the
-  previous buffer.
-
-/Lisp2/Boot/Hemlock/macros.slisp#1, 25-Jan-85 22:35:26, Edit by Ram
-  Fixed Hlet so that it worked.  Evidently nobody had used it before.  
-
-/Lisp2/Boot/Hemlock/filecoms.slisp#1, 25-Jan-85 23:26:35, Edit by Ram
-  Made "Log Change" merge the buffer pathname defaults into the log file name.
-  Added the feature that the location for the point in the change log entry
-  template can be specified by placing a "@" in the template.
-
-/Lisp2/Boot/Hemlock/search2.slisp#1, 25-Jan-85 23:23:35, Edit by Ram
-  Fixed various one-off errors in the end args being passed to position and
-  %sp-find-character-with-attribute.
diff --git a/hemlock/pop-up-stream.lisp b/hemlock/pop-up-stream.lisp
deleted file mode 100644
index 3e84674709f206bcb8fd7578078926557677fd6d..0000000000000000000000000000000000000000
--- a/hemlock/pop-up-stream.lisp
+++ /dev/null
@@ -1,226 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/pop-up-stream.lisp,v 1.1.1.2 1991/02/08 16:36:58 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contatins the stream operations for pop-up-displays.
-;;;
-;;; Written by Blaine Burks.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-
-
-;;;; Line-buffered Stream Methods.
-
-(defun random-typeout-line-out (stream char)
-  (insert-character (random-typeout-stream-mark stream) char)
-  (when (and (char= char #\newline)
-	     (not (random-typeout-stream-no-prompt stream)))
-    (funcall (device-random-typeout-line-more
-	      (device-hunk-device
-	       (window-hunk (random-typeout-stream-window stream))))
-	     stream 1)))
-
-(defun random-typeout-line-sout (stream string start end)
-  (insert-string (random-typeout-stream-mark stream) string start end)
-  (unless (random-typeout-stream-no-prompt stream)
-    (let ((count (count #\newline string)))
-      (when count
-	(funcall (device-random-typeout-line-more
-		  (device-hunk-device
-		   (window-hunk (random-typeout-stream-window stream))))
-		 stream count)))))
-
-(defun random-typeout-line-misc (stream operation &optional arg1 arg2)
-  (declare (ignore arg1 arg2))
-  (case operation
-    ((:force-output :finish-output)
-     (random-typeout-redisplay (random-typeout-stream-window stream)))
-    (:charpos
-     (mark-charpos (random-typeout-stream-mark stream)))))
-
-
-;;; Bitmap line-buffered support.
-
-;;; UPDATE-BITMAP-LINE-BUFFERED-STREAM is called when anything is written to
-;;; a line-buffered-random-typeout-stream on the bitmap.  It does a lot of
-;;; checking to make sure that strings of characters longer than the width of
-;;; the window don't screw us.  The code is a little wierd, so a brief
-;;; explanation is below.
-;;;
-;;; The more-mark is how we tell when we will next need to more.  Each time
-;;; we do a more-prompt, we point the mark at the last visible character in
-;;; the random typeout window.  That way, when the mark is no longer
-;;; DISPLAYED-P, we know it's time to do another more prompt.
-;;;
-;;; If the buffer-end-mark is DISPLAYED-P, then we return, only redisplaying
-;;; if there was at least one newline in the last batch of output.  If we
-;;; haven't done a more prompt yet (indicated by a value of T for
-;;; first-more-p), then since we know the end of the buffer isn't visible, we
-;;; need to do a more-prompt.  If neither of the first two tests returns T,
-;;; then we can only need to do a more-prompt if our more-mark has scrolled
-;;; off the top of the screen.  If it hasn't, everything is peechy-keen, so
-;;; we scroll the screen one line and redisplay.
-;;;
-(defun update-bitmap-line-buffered-stream (stream newline-count)
-  (let* ((window (random-typeout-stream-window stream))
-	 (count 0))
-    (when (plusp newline-count) (random-typeout-redisplay window))
-    (loop
-      (cond ((no-text-past-bottom-p window)
-	     (return))
-	    ((or (random-typeout-stream-first-more-p stream)
-		 (not (displayed-p (random-typeout-stream-more-mark stream)
-				   window)))
-	     (do-bitmap-more-prompt stream)
-	     (return))
-	    (t
-	     (scroll-window window 1)
-	     (random-typeout-redisplay window)))
-      (when (= (incf count) newline-count) (return)))))
-
-;;; NO-TEXT-PAST-BOTTOM-P determines whether there is text left to be displayed
-;;; in the random-typeout window.  It does this by first making sure there is a
-;;; line past the WINDOW-DISPLAY-END of the window.  If there is, this line
-;;; must be empty, and BUFFER-END-MARK must be on this line.  The final test is
-;;; that the window-end is displayed within the window.  If it is not, then the
-;;; last line wraps past the end of the window, and there is text past the
-;;; bottom.
-;;;
-;;; Win-end is bound after the call to DISPLAYED-P because it updates the
-;;; window's image moving WINDOW-DISPLAY-END.  We want this updated value for
-;;; the display end.
-;;;
-(defun no-text-past-bottom-p (window)
-  (let* ((window-end (window-display-end window))
-	 (window-end-displayed-p (displayed-p window-end window)))
-    (with-mark ((win-end window-end))
-      (let ((one-after-end (line-offset win-end 1)))
-	(if one-after-end
-	    (and (empty-line-p win-end)
-		 (same-line-p win-end (buffer-end-mark (window-buffer window)))
-		 window-end-displayed-p)
-	    window-end-displayed-p)))))
-
-(defun reset-more-mark (stream)
-  (let* ((window (random-typeout-stream-window stream))
-	 (more-mark (random-typeout-stream-more-mark stream))
-	 (end (window-display-end window)))
-    (move-mark more-mark end)
-    (unless (displayed-p end window) (character-offset more-mark -1))))
-
-;;; DO-BITMAP-MORE-PROMPT is the function that atually displays the more prompt
-;;; and reacts to it.  Things are pretty clear.  The loop is neccessary because
-;;; someone could screw us by never outputting newlines.  Improbable, but
-;;; possible.
-;;;
-(defun do-bitmap-more-prompt (stream)
-  (let* ((window (random-typeout-stream-window stream))
-	 (height (window-height window)))
-    (setf (random-typeout-stream-first-more-p stream) nil)
-    (reset-more-mark stream)
-    (loop
-      (when (no-text-past-bottom-p window) (return))
-      (display-more-prompt stream)
-      (do ((i 0 (1+ i)))
-	  ((or (= i height) (no-text-past-bottom-p window)))
-	(scroll-window window 1)
-	(random-typeout-redisplay window)))
-    (unless (displayed-p (random-typeout-stream-more-mark stream) window)
-      (reset-more-mark stream))))
-
-
-;;; Tty line-buffered support.
-
-;;; UPDATE-TTY-LINE-BUFFERED-STREAM is called when anything is written to
-;;; a line-buffered-random-typeout-stream on the tty.  It just makes sure
-;;; hemlock doesn't choke on extra-long strings.
-;;;
-(defun update-tty-line-buffered-stream (stream newline-count)
-  (let ((window (random-typeout-stream-window stream)))
-    (when (plusp newline-count) (random-typeout-redisplay window))
-    (loop
-      (when (no-text-past-bottom-p window) (return))
-      (display-more-prompt stream)
-      (scroll-window window (window-height window))
-      (random-typeout-redisplay window))))
-
-
-;;;; Full-buffered Stream Methods.
-
-(defun random-typeout-full-out (stream char)
-  (insert-character (random-typeout-stream-mark stream) char))
-
-(defun random-typeout-full-sout (stream string start end)
-  (insert-string (random-typeout-stream-mark stream) string start end))
-
-(defun random-typeout-full-misc (stream operation &optional arg1 arg2)
-  (declare (ignore arg1 arg2))
-  (case operation
-    (:charpos
-     (mark-charpos (random-typeout-stream-mark stream)))))
-
-
-;;; Bitmap full-buffered support.
-
-;;; DO-BITMAP-FULL-MORE and DO-TTY-FULL-MORE scroll through the fresh text in
-;;; random typeout buffer.  The bitmap function does some checking so that
-;;; we don't overshoot the end of the buffer.
-;;;
-(defun do-bitmap-full-more (stream)
-  (let* ((window (random-typeout-stream-window stream))
-	 (buffer (window-buffer window))
-	 (height (window-height window)))
-    (with-mark ((end-check (buffer-end-mark buffer)))
-      (when (and (mark/= (buffer-start-mark buffer) end-check)
-		 (empty-line-p end-check))
-	(line-end (line-offset end-check -1)))
-      (loop
-	(when (displayed-p end-check window)
-	  (return))
-	(display-more-prompt stream)
-	(do ((i 0 (1+ i)))
-	    ((or (= i height) (displayed-p end-check window)))
-	  (scroll-window window 1)
-	  (random-typeout-redisplay window))))))
-
-
-;;; Tty full-buffered support.
-
-(defun do-tty-full-more (stream)
-  (let* ((window (random-typeout-stream-window stream))
-	 (buffer (window-buffer window)))
-    (with-mark ((end-check (buffer-end-mark buffer)))
-      (when (and (mark/= (buffer-start-mark buffer) end-check)
-		 (empty-line-p end-check))
-	(line-end (line-offset end-check -1)))
-      (loop
-	(when (displayed-p end-check window)
-	  (return))
-	(display-more-prompt stream)
-	(scroll-window window (window-height window))))))
-
-
-;;; Proclaim this special so the compiler doesn't warn me.  I hate that.
-;;;
-(proclaim '(special *more-prompt-action*))
-
-(defun display-more-prompt (stream)
-  (unless (random-typeout-stream-no-prompt stream)
-    (let ((window (random-typeout-stream-window stream))
-	  (*more-prompt-action* :more))
-      (update-modeline-field (window-buffer window) window :more-prompt)
-      (random-typeout-redisplay window)
-      (wait-for-more stream)
-      (let ((*more-prompt-action* :empty))
-	(update-modeline-field (window-buffer window) window :more-prompt)))))
diff --git a/hemlock/rcs.lisp b/hemlock/rcs.lisp
deleted file mode 100644
index 5a428634f8f0412bb5477242e134842dff19458e..0000000000000000000000000000000000000000
--- a/hemlock/rcs.lisp
+++ /dev/null
@@ -1,518 +0,0 @@
-;;; -*- Package: HEMLOCK; Mode: Lisp -*-
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rcs.lisp,v 1.27 1992/12/06 15:52:19 wlott Exp $
-;;;
-;;; Various commands for dealing with RCS under Hemlock.
-;;;
-;;; Written by William Lott and Christopher Hoover.
-;;; 
-(in-package "HEMLOCK")
-
-
-;;;;
-
-(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 *last-rcs-command-name* nil)
-(defvar *last-rcs-command-output-string* nil)
-(defvar *rcs-output-stream* (make-string-output-stream))
-
-(defmacro do-command (command &rest args)
-  `(progn
-     (setf *last-rcs-command-name* ',command)
-     (get-output-stream-string *rcs-output-stream*)
-     (let ((process (ext:run-program ',command ,@args
-				     :error *rcs-output-stream*)))
-       (setf *last-rcs-command-output-string*
-	     (get-output-stream-string *rcs-output-stream*))
-       (case (ext:process-status process)
-	 (:exited
-	  (unless (zerop (ext:process-exit-code process))
-	    (editor-error "~A aborted with an error; ~
-			   use the ``RCS Last Command Output'' command for ~
-			   more information" ',command)))
-	 (:signaled
-	  (editor-error "~A killed with signal ~A~@[ (core dumped)]."
-			',command
-			(ext:process-exit-code process)
-			(ext:process-core-dumped process)))
-	 (t
-	  (editor-error "~S still alive?" process))))))
-
-(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) (unix:unix-stat file)
-	(declare (ignore ino))
-	(cond (won
-	       (unix:unix-chmod file (logior mode unix:writeown)))
-	      (t
-	       (editor-error "UNIX:UNIX-STAT lost in RCS-LOCK-FILE: ~A"
-			     (unix: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)
-
-(defhvar "RCS Keep Around After Unlocking"
-  "If non-NIL (the default) keep the working file around after unlocking it.
-   When NIL, the working file and buffer are deleted."
-  :value t)
-
-(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 buffer keep-lock log-stream))
-		(invoke-hook rcs-check-in-file-hook buffer pathname)
-		nil)
-	  (editor-error "Someone deleted the RCS Log Entry buffer."))
-      (when (member old-buffer *buffer-list*)
-	(change-to-buffer old-buffer))
-      (setf allow-delete t)
-      (delete-buffer-if-possible log-buffer))))
-
-(defun sub-check-in-file (pathname buffer keep-lock log-stream)
-  (let* ((filename (file-namestring pathname))
-	 (rcs-filename (concatenate 'simple-string
-				    "./RCS/" filename ",v"))
-	 (keep-working-copy (or keep-lock
-				(not (hemlock-bound-p
-				      'rcs-keep-around-after-unlocking
-				      :buffer buffer))
-				(variable-value
-				 'rcs-keep-around-after-unlocking
-				 :buffer buffer))))
-    (in-directory pathname
-      (do-command "rcsci" `(,@(if keep-lock '("-l"))
-			    ,@(if keep-working-copy '("-u"))
-			    ,filename)
-		  :input log-stream)
-      (if keep-working-copy
-	  ;; 
-	  ;; 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)
-	      (unix:unix-stat rcs-filename)
-	    (declare (ignore mode nlink uid gid rdev size))
-	    (cond (dev
-		   (multiple-value-bind
-		       (wonp errno)
-		       (unix:unix-utimes filename atime 0 mtime 0)
-		     (unless wonp
-		       (editor-error "UNIX:UNIX-UTIMES failed: ~A"
-				     (unix:get-unix-error-msg errno)))))
-		  (t
-		   (editor-error "UNIX:UNIX-STAT failed: ~A"
-				 (unix:get-unix-error-msg ino)))))
-	  (delete-buffer-if-possible buffer)))))
-
-
-
-;;;; Check Out
-
-(defhvar "RCS Check Out File Hook"
-  "RCS Check Out File Hook"
-  :value nil)
-
-(defvar *translate-file-names-before-locking* nil)
-
-(defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p)
-  (when (and lock *translate-file-names-before-locking*)
-    (multiple-value-bind (unmatched-dir new-dirs file-name)
-			 (maybe-translate-definition-file pathname)
-      (when new-dirs
-	(let ((new-name (translate-definition-file unmatched-dir
-						   (car new-dirs)
-						   file-name)))
-	  (when (probe-file (directory-namestring new-name))
-	    (setf pathname new-name))))))
-  (cond
-   ((and (not always-overwrite-p)
-	 (let ((pn (probe-file pathname)))
-	   (and pn (ext:file-writable pn))))
-    ;; 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."
-       (rcs-check-out-file buffer pathname lock))
-      (:no
-       "Don't check it out after all.")
-      ((#\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)
-	 (rcs-check-out-file buffer pathname lock)))))
-   (t
-    (rcs-check-out-file buffer pathname lock)))
-  pathname)
-
-(defun rcs-check-out-file (buffer pathname lock)
-  (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock)
-  (in-directory pathname
-    (let* ((file (file-namestring pathname))
-	   (backup (if (probe-file file)
-		       (lisp::pick-backup-name file))))
-      (when backup (rename-file file backup))
-      (do-command "rcsco" `(,@(if lock '("-l")) ,file))
-      (invoke-hook rcs-check-out-file-hook buffer pathname)
-      (when backup (delete-file backup)))))
-
-
-;;;; Last Command Output
-
-(defcommand "RCS Last Command Output" (p)
-  "Print the full output of the last RCS command."
-  "Print the full output of the last RCS command."
-  (declare (ignore p))
-  (unless (and *last-rcs-command-name* *last-rcs-command-output-string*)
-    (editor-error "No RCS commands have executed!"))
-  (with-pop-up-display (s :buffer-name "*RCS Command Output*")
-    (format s "Output from ``~A'':~%~%" *last-rcs-command-name*)
-    (write-line *last-rcs-command-output-string* s)))
-
-
-;;;; Commands for Checking In / Checking Out and Locking / Unlocking 
-
-(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)))))))
-
-(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)
-    (when (member buffer *buffer-list*)
-      ;; If the buffer has not been deleted, make sure it is up to date
-      ;; with respect to the file.
-      (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.")))
-    (setf (buffer-modified buffer) nil)
-    (setf pathname (maybe-rcs-check-out-file buffer pathname p 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)))
-    (setf pathname (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)))
-
-
-;;;; Status and Modeline Frobs.
-
-(defhvar "RCS Status"
-  "RCS status of this buffer.  Either nil, :locked, :out-of-date, or
-  :unlocked."
-  :value nil)
-
-;;;
-;;; Note: This doesn't behave correctly w/r/t to branched files.
-;;; 
-(defun rcs-file-status (pathname)
-  (let* ((directory (directory-namestring pathname))
-	 (filename (file-namestring pathname))
-	 (rcs-file (concatenate 'simple-string directory
-				"RCS/" filename ",v")))
-    (if (probe-file rcs-file)
-	;; This is an RCS file
-	(let ((probe-file (probe-file pathname)))
-	  (cond ((and probe-file (file-writable probe-file))
-		 :locked)
-		((or (not probe-file)
-		     (< (file-write-date pathname)
-			(file-write-date rcs-file)))
-		 :out-of-date)
-		(t
-		 :unlocked))))))
-
-(defun rcs-update-buffer-status (buffer &optional tn)
-  (unless (hemlock-bound-p 'rcs-status :buffer buffer)
-    (defhvar "RCS Status"
-      "RCS Status of this buffer."
-      :buffer buffer
-      :value nil))
-  (let ((tn (or tn (buffer-pathname buffer))))
-    (setf (variable-value 'rcs-status :buffer buffer)
-	  (if tn (rcs-file-status tn))))
-  (hi::update-modelines-for-buffer buffer))
-;;; 
-(add-hook read-file-hook 'rcs-update-buffer-status)
-(add-hook write-file-hook 'rcs-update-buffer-status)
-
-(defcommand "RCS Update All RCS Status Variables" (p)
-  "Update the ``RCS Status'' variable for all buffers."
-  "Update the ``RCS Status'' variable for all buffers."
-  (declare (ignore p))
-  (dolist (buffer *buffer-list*)
-    (rcs-update-buffer-status buffer))
-  (dolist (window *window-list*)
-    (update-modeline-fields (window-buffer window) window)))
-
-;;; 
-;;; Action Hooks
-(defun rcs-action-hook (buffer pathname)
-  (cond (buffer
-	 (rcs-update-buffer-status buffer))
-	(t
-	 (let ((pathname (probe-file pathname)))
-	   (when pathname
-	     (dolist (buffer *buffer-list*)
-	       (let ((buffer-pathname (buffer-pathname buffer)))
-		 (when (equal pathname buffer-pathname)
-		   (rcs-update-buffer-status buffer)))))))))
-;;; 
-(add-hook rcs-check-in-file-hook 'rcs-action-hook)
-(add-hook rcs-check-out-file-hook 'rcs-action-hook)
-(add-hook rcs-lock-file-hook 'rcs-action-hook)
-(add-hook rcs-unlock-file-hook 'rcs-action-hook)
-
-
-;;;
-;;; RCS Modeline Field
-(make-modeline-field
- :name :rcs-status
- :function #'(lambda (buffer window)
-	       (declare (ignore buffer window))
-	       (ecase (value rcs-status)
-		 (:out-of-date "[OLD]  ")
-		 (:locked "[LOCKED]  ")
-		 (:unlocked "[RCS]  ")
-		 ((nil) ""))))
diff --git a/hemlock/register.lisp b/hemlock/register.lisp
deleted file mode 100644
index 89dda633c721112048b4ffb352fdb1e4d5ec066f..0000000000000000000000000000000000000000
--- a/hemlock/register.lisp
+++ /dev/null
@@ -1,181 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;; Registers for holding text and positions.
-;;;
-;;; Written by Dave Touretzky.
-;;; Modified by Bill Chiles for Hemlock consistency.
-;;;
-(in-package 'hemlock)
-
-
-
-;;;; Registers implementation.
-
-;;; Registers are named by characters.  Each register refers to a mark or
-;;; a cons of a region and the buffer it came from.
-;;; 
-(defvar *registers* (make-hash-table))
-
-(defun register-count ()
-  (hash-table-count *registers*))
-
-(defun register-value (reg-name)
-  (gethash reg-name *registers*))
-
-(defsetf register-value (reg-name) (new-value)
-  (let ((name (gensym))
-	(value (gensym))
-	(old-value (gensym)))
-    `(let* ((,name ,reg-name)
-	    (,value ,new-value)
-	    (,old-value (gethash ,name *registers*)))
-       (when (and ,old-value (markp ,old-value))
-	 (delete-mark ,old-value))
-       (setf (gethash ,name *registers*) ,value))))
-
-(defun prompt-for-register (&optional (prompt "Register: ") must-exist)
-  (let ((reg-name (prompt-for-key-event :prompt prompt)))
-    (unless (or (not must-exist) (gethash reg-name *registers*))
-      (editor-error "Register ~A is empty." reg-name))
-    reg-name))
-
-     
-(defmacro do-registers ((name value &optional sorted) &rest body)
-  (if sorted
-      (let ((sorted-regs (gensym))
-	    (reg (gensym)))
-	`(let ((,sorted-regs nil))
-	   (declare (list ,sorted-regs))
-	   (maphash #'(lambda (,name ,value)
-			(push (cons ,name ,value) ,sorted-regs))
-		    *registers*)
-	   (setf ,sorted-regs (sort ,sorted-regs #'char-lessp :key #'car))
-	   (dolist (,reg ,sorted-regs)
-	     (let ((,name (car ,reg))
-		   (,value (cdr ,reg)))
-	       ,@body))))
-      `(maphash #'(lambda (,name ,value)
-		    ,@body)
-		*registers*)))
-
-
-;;; Hook to clean things up if a buffer is deleted while registers point to it.
-;;; 
-(defun flush-reg-references-to-deleted-buffer (buffer)
-  (do-registers (name value)
-    (declare (ignore name))
-    (etypecase value
-      (mark (when (eq (line-buffer (mark-line value)) buffer)
-	      (free-register name)))
-      (cons (free-register-value value buffer)))))
-;;;
-(add-hook delete-buffer-hook 'flush-reg-references-to-deleted-buffer)
-
-
-(defun free-register (name)
-  (let ((value (register-value name)))
-    (when value (free-register-value value)))
-  (remhash name *registers*))
-
-(defun free-register-value (value &optional buffer)
-  (etypecase value
-    (mark
-     (when (or (not buffer) (eq (line-buffer (mark-line value)) buffer))
-       (delete-mark value)))
-    (cons
-     (when (and buffer (eq (cdr value) buffer))
-       (setf (cdr value) nil)))))
-
-
-
-;;;; Commands.
-
-;;; These commands all stash marks and regions with marks that point into some
-;;; buffer, and they assume that the register values have the same property.
-;;; 
-
-(defcommand "Save Position" (p)
-  "Saves the current location in a register.  Prompts for register name."
-  "Saves the current location in a register.  Prompts for register name."
-  (declare (ignore p))
-  (let ((reg-name (prompt-for-register)))
-    (setf (register-value reg-name)
-	  (copy-mark (current-point) :left-inserting))))
-
-(defcommand "Jump to Saved Position" (p)
-  "Moves the point to a location previously saved in a register."
-  "Moves the point to a location previously saved in a register."
-  (declare (ignore p))
-  (let* ((reg-name (prompt-for-register "Jump to Register: " t))
-	 (val (register-value reg-name)))
-    (unless (markp val)
-      (editor-error "Register ~A does not hold a location." reg-name))
-    (change-to-buffer (line-buffer (mark-line val)))
-    (move-mark (current-point) val)))
-
-(defcommand "Kill Register" (p)
-  "Kill a regist er.  Prompts for the name."
-  "Kill a register.  Prompts for the name."
-  (declare (ignore p))
-  (free-register (prompt-for-register "Register to kill: ")))
-
-(defcommand "List Registers" (p)
-  "Lists all registers in a pop-up window."
-  "Lists all registers in a pop-up window."
-  (declare (ignore p))
-  (with-pop-up-display (f :height (* 2 (register-count)))
-    (do-registers (name val :sorted)
-      (write-string "Reg " f)
-      (ext:print-pretty-key-event name f)
-      (write-string ":  " f)
-      (etypecase val
-	(mark
-	 (let* ((line (mark-line val))
-		(buff (line-buffer line))
-		(len (line-length line)))
-	   (format f "Line ~S, col ~S in buffer ~A~%   ~A~:[~;...~]~%"
-		   (count-lines (region (buffer-start-mark buff) val))
-		   (mark-column val)
-		   (buffer-name buff)
-		   (subseq (line-string line) 0 (min 61 len))
-		   (> len 60))))
-	(cons
-	 (let* ((str (region-to-string (car val)))
-		(nl (position #\newline str :test #'char=))
-		(len (length str))
-		(buff (cdr val)))
-	   (declare (simple-string str))
-	   (format f "Text~@[ from buffer ~A~]~%   ~A~:[~;...~]~%"
-		   (if buff (buffer-name buff))
-		   (subseq str 0 (if nl (min 61 len nl) (min 61 len)))
-		   (> len 60))))))))
-
-(defcommand "Put Register" (p)
-  "Copies a region into a register.  Prompts for register name."
-  "Copies a region into a register.  Prompts for register name."
-  (declare (ignore p))
-  (let ((region (current-region)))
-    ;; Bind the region before prompting in case the region isn't active.
-    (setf (register-value (prompt-for-register))
-	  (cons (copy-region region) (current-buffer)))))
-
-(defcommand "Get Register" (p)
-  "Copies a region from a register to the current point."
-  "Copies a region from a register to the current point."
-  (declare (ignore p))
-  (let* ((reg-name (prompt-for-register "Register from which to get text: " t))
-	 (val (register-value reg-name)))
-    (unless (and (consp val) (regionp (car val)))
-      (editor-error "Register ~A does not hold a region." reg-name))
-    (let ((point (current-point)))
-      (push-buffer-mark (copy-mark point))
-      (insert-region (current-point) (car val))))
-  (setf (last-command-type) :ephemerally-active))
diff --git a/hemlock/ring.lisp b/hemlock/ring.lisp
deleted file mode 100644
index 82925b9f0eab8c4e56d07c802b5e3843569e4609..0000000000000000000000000000000000000000
--- a/hemlock/ring.lisp
+++ /dev/null
@@ -1,208 +0,0 @@
-;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/ring.lisp,v 1.1.1.2 1991/02/08 16:37:05 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Rob MacLachlan
-;;;
-;;;  This file defines a ring-buffer type and access functions.
-;;;
-(in-package 'hemlock-internals)
-(export '(ring ringp make-ring ring-push ring-pop ring-length ring-ref
-	       rotate-ring))
-
-
-(defun %print-hring (obj stream depth)
-  (declare (ignore depth obj))
-  (write-string "#<Hemlock Ring>" stream))
-
-;;;; The ring data structure:
-;;;
-;;;    An empty ring is indicated by an negative First value.
-;;; The Bound is made (1- (- Size)) to make length work.  Things are
-;;; pushed at high indices first.
-;;;
-(defstruct (ring (:predicate ringp)
-		 (:constructor internal-make-ring)
-		 (:print-function %print-hring))
-  "Used with Ring-Push and friends to implement ring buffers."
-  (first -1 :type fixnum)	   ;The index of the first position used.
-  (bound () :type fixnum)	   ;The index after the last element.
-  delete-function		   ;The function  to be called on deletion. 
-  (vector () :type simple-vector)) ;The vector.
-
-;;; make-ring  --  Public
-;;;
-;;;    Make a new empty ring with some maximum size and type.
-;;;
-(defun make-ring (size &optional (delete-function #'identity))
-  "Make a ring-buffer which can hold up to Size objects.  Delete-Function
-  is a function which is called with each object that falls off the
-  end."
-  (unless (and (fixnump size) (> size 0))
-    (error "Ring size, ~S is not a positive fixnum." size))
-  (internal-make-ring :delete-function delete-function
-		      :vector (make-array size)
-		      :bound  (1- (- size))))
-
-;;; ring-push  --  Public
-;;;
-;;;    Decrement first modulo the maximum size, delete any old
-;;; element, and add the new one.
-;;;
-(defun ring-push (object ring)
-  "Push an object into a ring, deleting an element if necessary."
-  (let ((first (ring-first ring))
-	(vec (ring-vector ring))
-	(victim 0))
-    (declare (simple-vector vec) (fixnum first victim))
-    (cond
-     ;; If zero, wrap around to end.
-     ((zerop first)
-      (setq victim (1- (length vec))))
-     ;; If empty then fix up pointers.
-     ((minusp first)
-      (setf (ring-bound ring) 0)
-      (setq victim (1- (length vec))))
-     (t
-      (setq victim (1- first))))
-    (when (= first (ring-bound ring))
-      (funcall (ring-delete-function ring) (aref vec victim))
-      (setf (ring-bound ring) victim))
-    (setf (ring-first ring) victim)
-    (setf (aref vec victim) object)))
-
-
-;;; ring-pop  --  Public
-;;;
-;;;    Increment first modulo the maximum size.
-;;;
-(defun ring-pop (ring)
-  "Pop an object from a ring and return it."
-  (let* ((first (ring-first ring))
-	 (vec (ring-vector ring))
-	 (new (if (= first (1- (length vec))) 0 (1+ first)))
-	 (bound (ring-bound ring)))
-    (declare (fixnum first new bound) (simple-vector vec))
-    (cond
-     ((minusp bound)
-      (error "Cannot pop from an empty ring."))
-     ((= new bound)
-      (setf (ring-first ring) -1  (ring-bound ring) (1- (- (length vec)))))
-     (t
-      (setf (ring-first ring) new)))
-    (shiftf (aref vec first) nil)))
-
-
-;;; ring-length  --  Public
-;;;
-;;;    Return the current and maximum size.
-;;;
-(defun ring-length (ring)
-  "Return as values the current and maximum size of a ring."
-  (let ((diff (- (ring-bound ring) (ring-first ring)))
-	(max (length (ring-vector ring))))
-    (declare (fixnum diff max))
-    (values (if (plusp diff) diff (+ max diff)) max)))
-
-;;; ring-ref  --  Public
-;;;
-;;;    Do modulo arithmetic to find the correct element.
-;;;
-(defun ring-ref (ring index)
-  (declare (fixnum index))
-  "Return the index'th element of a ring.  This can be set with Setf."
-  (let ((first (ring-first ring)))
-    (declare (fixnum first))
-    (cond
-     ((and (zerop index) (not (minusp first)))
-      (aref (ring-vector ring) first))
-     (t
-      (let* ((diff (- (ring-bound ring) first))
-	     (sum (+ first index))
-	     (vec (ring-vector ring))
-	     (max (length vec)))
-	(declare (fixnum diff max sum) (simple-vector vec))
-	(when (or (>= index (if (plusp diff) diff (+ max diff)))
-		  (minusp index))
-	  (error "Ring index ~D out of bounds." index))
-	(aref vec (if (>= sum max) (- sum max) sum)))))))
-
-
-;;; %set-ring-ref  --  Internal
-;;;
-;;;    Setf form for ring-ref, set a ring element.
-;;;
-(defun %set-ring-ref (ring index value)
-  (declare (fixnum index))
-  (let* ((first (ring-first ring))
-	 (diff (- (ring-bound ring) first))
-	 (sum (+ first index))
-	 (vec (ring-vector ring))
-	 (max (length vec)))
-    (declare (fixnum diff first max) (simple-vector vec))
-    (when (or (>= index (if (plusp diff) diff (+ max diff))) (minusp index))
-      (error "Ring index ~D out of bounds." index))
-    (setf (aref vec (if (>= sum max) (- sum max) sum)) value)))
-
-(eval-when (compile eval)
-(defmacro 1+m (exp base)
-  `(if (= ,exp ,base) 0 (1+ ,exp)))
-(defmacro 1-m (exp base)
-  `(if (zerop ,exp) ,base (1- ,exp)))
-) ;eval-when (compile eval)
-
-;;; rotate-ring  --  Public
-;;;
-;;;    Rotate a ring, blt'ing elements as necessary.
-;;;
-(defun rotate-ring (ring offset)
-  "Rotate a ring forward, i.e. second -> first, with positive offset,
-  or backwards with negative offset."
-  (declare (fixnum offset))
-  (let* ((first (ring-first ring))
-	 (bound (ring-bound ring))
-	 (vec (ring-vector ring))
-	 (max (length vec)))
-    (declare (fixnum first bound max) (simple-vector vec))
-    (cond
-     ((= first bound)
-      (let ((new (rem (+ offset first) max)))
-	(declare (fixnum new))
-	(if (minusp new) (setq new (+ new max)))
-	(setf (ring-first ring) new)
-	(setf (ring-bound ring) new)))
-     ((not (minusp first))
-      (let* ((diff (- bound first))
-	     (1-max (1- max))
-	     (length (if (plusp diff) diff (+ max diff)))
-	     (off (rem offset length)))
-	(declare (fixnum diff length off 1-max))
-	(cond
-	 ((minusp offset)
-	  (do ((dst (1-m first 1-max) (1-m dst 1-max))
-	       (src (1-m bound 1-max) (1-m src 1-max))
-	       (cnt off (1+ cnt)))
-	      ((zerop cnt)
-	       (setf (ring-first ring) (1+m dst 1-max))
-	       (setf (ring-bound ring) (1+m src 1-max)))
-	    (declare (fixnum dst src cnt))
-	    (shiftf (aref vec dst) (aref vec src) nil)))
-	 (t
-	  (do ((dst bound (1+m dst 1-max))
-	       (src first (1+m src 1-max))
-	       (cnt off (1- cnt)))
-	      ((zerop cnt)
-	       (setf (ring-first ring) src)
-	       (setf (ring-bound ring) dst))
-	    (declare (fixnum dst src cnt))
-	    (shiftf (aref vec dst) (aref vec src) nil))))))))
-  ring)
diff --git a/hemlock/rompsite.lisp b/hemlock/rompsite.lisp
deleted file mode 100644
index d4b66d7758b8537155d5c0fff437a370ee01850b..0000000000000000000000000000000000000000
--- a/hemlock/rompsite.lisp
+++ /dev/null
@@ -1,1065 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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).
-;;; **********************************************************************
-;;;
-;;; "Site dependent" stuff for the editor while on the IBM RT PC machine.
-;;;
-
-(in-package "SYSTEM")
-
-(export '(without-hemlock))
-
-
-(in-package "HEMLOCK-INTERNALS" :nicknames '("HI"))
-
-(export '(show-mark editor-sleep *input-transcript* fun-defined-from-pathname
-	  editor-describe-function pause-hemlock store-cut-string
-	  fetch-cut-string schedule-event remove-scheduled-event
-	  enter-window-autoraise directoryp merge-relative-pathnames
-	  ;;
-	  ;; Export default-font to prevent a name conflict that occurs due to
-	  ;; the Hemlock variable "Default Font" defined in SITE-INIT below.
-	  ;;
-	  default-font))
-
-
-;;; SYSTEM:WITHOUT-HEMLOCK -- Public.
-;;;
-;;; Code:lispinit.lisp uses this for a couple interrupt handlers, and
-;;; eval-server.lisp.
-;;; 
-(defmacro system:without-hemlock (&body body)
-  "When in the editor and not in the debugger, call the exit method of Hemlock's
-   device, so we can type.  Do the same thing on exit but call the init method."
-  `(progn
-     (when (and *in-the-editor* (not debug::*in-the-debugger*))
-       (let ((device (device-hunk-device (window-hunk (current-window)))))
-	 (funcall (device-exit device) device)))
-     ,@body
-     (when (and *in-the-editor* (not debug::*in-the-debugger*))
-       (let ((device (device-hunk-device (window-hunk (current-window)))))
-	 (funcall (device-init device) device)))))
-
-
-
-;;;; SITE-INIT.
-
-;;; *key-event-history* is defined in input.lisp, but it needs to be set in
-;;; SITE-INIT, since MAKE-RING doesn't exist at load time for this file.
-;;;
-(proclaim '(special *key-event-history*))
-
-;;; SITE-INIT  --  Internal
-;;;
-;;;    This function is called at init time to set up any site stuff.
-;;;
-(defun site-init ()
-  (defhvar "Beep Border Width"
-    "Width in pixels of the border area inverted by beep."
-    :value 20)
-  (defhvar "Default Window Width"
-    "This is used to make a window when prompting the user.  The value is in
-     characters."
-    :value 80)
-  (defhvar "Default Window Height"
-    "This is used to make a window when prompting the user.  The value is in
-     characters."
-    :value 24)
-  (defhvar "Default Initial Window Width"
-    "This is used when Hemlock first starts up to make its first window.
-     The value is in characters."
-    :value 80)
-  (defhvar "Default Initial Window Height"
-    "This is used when Hemlock first starts up to make its first window.
-     The value is in characters."
-    :value 24)
-  (defhvar "Default Initial Window X"
-    "This is used when Hemlock first starts up to make its first window.
-     The value is in pixels."
-    :value nil)
-  (defhvar "Default Initial Window Y"
-    "This is used when Hemlock first starts up to make its first window.
-     The value is in pixels."
-    :value nil)
-  (defhvar "Bell Style"
-    "This controls what beeps do in Hemlock.  Acceptable values are :border-flash
-     (which is the default), :feep, :border-flash-and-feep, :flash,
-     :flash-and-feep, and NIL (do nothing)."
-    :value :border-flash)
-  (defhvar "Reverse Video"
-    "Paints white on black in window bodies, black on white in modelines."
-    :value nil
-    :hooks '(reverse-video-hook-fun))
-  (defhvar "Cursor Bitmap File"
-    "File to read to setup cursors for Hemlock windows.  The mask is found by
-     merging this name with \".mask\"."
-    :value "/usr/misc/.lisp/lib/hemlock11.cursor")
-  (defhvar "Enter Window Hook"
-    "When the mouse enters an editor window, this hook is invoked.  These
-     functions take the Hemlock Window as an argument."
-    :value nil)
-  (defhvar "Exit Window Hook"
-    "When the mouse exits an editor window, this hook is invoked.  These
-     functions take the Hemlock Window as an argument."
-    :value nil)
-  (defhvar "Set Window Autoraise"
-    "When non-nil, setting the current window will automatically raise that
-     window via a function on \"Set Window Hook\".  If the value is :echo-only
-     (the default), then only the echo area window will be raised
-     automatically upon becoming current."
-    :value :echo-only)
-  (defhvar "Default Font"
-    "The string name of the font to be used for Hemlock -- buffer text,
-     modelines, random typeout, etc.  The font is loaded when initializing
-     Hemlock."
-    :value "8x13")
-  (defhvar "Thumb Bar Meter"
-    "When non-nil (the default), windows will be created to be displayed with
-     a ruler in the bottom border of the window."
-    :value t)
-
-  (setf *key-event-history* (make-ring 60))
-  nil)
-
-
-
-;;;; Some generally useful file-system functions.
-
-;;; MERGE-RELATIVE-PATHNAMES takes a pathname that is either absolute or
-;;; relative to default-dir, merging it as appropriate and returning a definite
-;;; directory pathname.  If the component comes back with a trailing slash, we
-;;; have to remove it to get the MERGE-PATHNAMES to work correctly.  The result
-;;; must have a trailing slash.
-;;; 
-(defun merge-relative-pathnames (pathname default-directory)
-  "Merges pathname with default-directory.  If pathname is not absolute, it
-   is assumed to be relative to default-directory.  The result is always a
-   directory."
-  (setf pathname (pathname pathname))
-  (flet ((return-with-slash (pathname)
-	   (let ((ns (namestring pathname)))
-	     (declare (simple-string ns))
-	     (if (char= #\/ (schar ns (1- (length ns))))
-		 pathname
-		 (pathname (concatenate 'simple-string ns "/"))))))
-    (let ((dir (pathname-directory pathname)))
-      (if dir
-	  (let ((dev (pathname-device pathname)))
-	    (if (eq dev :absolute)
-		(return-with-slash pathname)
-		(return-with-slash
-		    (make-pathname :device (pathname-device default-directory)
-				   :directory
-				   (concatenate
-				    'simple-vector
-				    (pathname-directory default-directory)
-				    dir)
-				   :defaults pathname))))
-	  (return-with-slash (merge-pathnames pathname default-directory))))))
-
-(defun directoryp (pathname)
-  (not (or (pathname-name pathname) (pathname-type pathname))))
-
-
-
-;;;; I/O specials and initialization
-
-;;; File descriptor for the terminal.
-;;; 
-(defvar *editor-file-descriptor*)
-
-
-;;; This is a hack, so screen can tell how to initialize screen management
-;;; without re-opening the display.  It is set in INIT-RAW-IO and referenced
-;;; in WINDOWED-MONITOR-P.
-;;; 
-(defvar *editor-windowed-input* nil)
-
-
-;;; These are used for selecting X events.
-;;; 
-(defconstant group-interesting-xevents
-  '(:structure-notify))
-(defconstant group-interesting-xevents-mask
-  (apply #'xlib:make-event-mask group-interesting-xevents))
-
-(defconstant child-interesting-xevents
-  '(:key-press :button-press :button-release :structure-notify :exposure
-    :enter-window :leave-window))
-(defconstant child-interesting-xevents-mask
-  (apply #'xlib:make-event-mask child-interesting-xevents))
-
-(defconstant random-typeout-xevents
-  '(:key-press :button-press :button-release :enter-window :leave-window
-    :exposure))
-(defconstant random-typeout-xevents-mask
-  (apply #'xlib:make-event-mask random-typeout-xevents))
-
-(proclaim '(special ed::*open-paren-highlight-font*
-		    ed::*active-region-highlight-font*))
-
-(defparameter lisp-fonts-pathnames
-  '("/usr/misc/.lisp/lib/fonts/"
-    "/afs/cs.cmu.edu/unix/rt_mach/omega/usr/misc/.lisp/lib/fonts/"))
-
-
-(proclaim '(special *editor-input* *real-editor-input*))
-
-;;; INIT-RAW-IO  --  Internal
-;;;
-;;;    This function should be called whenever the editor is entered in a new
-;;; lisp.  It sets up process specific data structures.
-;;;
-(defun init-raw-io (display)
-  (setf *editor-windowed-input* nil)
-  (cond (display
-	 (setf *editor-windowed-input* (ext:open-clx-display display))
-	 (setf *editor-input* (make-windowed-editor-input))
-	 (ext:carefully-add-font-paths *editor-windowed-input*
-				       lisp-fonts-pathnames)
-	 (setup-font-family *editor-windowed-input*
-			    (variable-value 'ed::default-font)
-			    "8x13u" "8x13bold"))
-	(t ;; The editor's file descriptor is Unix standard input (0).
-	   ;; We don't need to affect system:*file-input-handlers* here
-	   ;; because the init and exit methods for tty redisplay devices
-	   ;; take care of this.
-	   ;;
-	 (setf *editor-file-descriptor* 0)
-	 (setf *editor-input* (make-tty-editor-input 0))))
-  (setf *real-editor-input* *editor-input*)
-  *editor-windowed-input*)
-
-;;; Stop flaming from compiler due to CLX macros expanding into illegal
-;;; declarations.
-;;;
-(proclaim '(declaration values))
-(proclaim '(special *default-font-family*))
-
-;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would
-;;; assume it to be special, issuing a nasty warning.
-;;;
-(defconstant font-map-size 16
-  "The number of possible fonts in a font-map.")
-
-
-;;; SETUP-FONT-FAMILY sets *default-font-family*, opening the three font names
-;;; passed in.  The font family structure is filled in from the first argument.
-;;; Actually, this ignores default-highlight-font and default-open-paren-font
-;;; in lieu of "Active Region Highlighting Font" and "Open Paren Highlighting
-;;; Font" when these are defined.
-;;;
-(defun setup-font-family (display default-font default-highlight-font
-				  default-open-paren-font)
-  (let* ((font-family (make-font-family :map (make-array font-map-size
-							 :initial-element 0)
-					:cursor-x-offset 0
-					:cursor-y-offset 0))
-	 (font-family-map (font-family-map font-family)))
-    (declare (simple-vector font-family-map))
-    (setf *default-font-family* font-family)
-    (let ((font (xlib:open-font display default-font)))
-      (unless font (error "Cannot open font -- ~S" default-font))
-      (fill font-family-map font)
-      (let ((width (xlib:max-char-width font)))
-	(setf (font-family-width font-family) width)
-	(setf (font-family-cursor-width font-family) width))
-      (let* ((baseline (xlib:font-ascent font))
-	     (height (+ baseline (xlib:font-descent font))))
-	(setf (font-family-height font-family) height)
-	(setf (font-family-cursor-height font-family) height)
-	(setf (font-family-baseline font-family) baseline)))
-    (setup-one-font display
-		    (or (variable-value 'ed::open-paren-highlighting-font)
-			default-open-paren-font)
-		    font-family-map
-		    ed::*open-paren-highlight-font*)
-    (setup-one-font display
-		    (or (variable-value 'ed::active-region-highlighting-font)
-			default-highlight-font)
-		    font-family-map
-		    ed::*active-region-highlight-font*)))
-
-;;; SETUP-ONE-FONT tries to open font-name for display, storing the result in
-;;; font-family-map at index.  XLIB:OPEN-FONT will return font stuff regardless
-;;; if the request is valid or not, so we finish the output to get synch'ed
-;;; with the server which will cause any errors to get signaled.  At this
-;;; level, we want to deal with this error here returning nil if the font
-;;; couldn't be opened.
-;;;
-(defun setup-one-font (display font-name font-family-map index)
-  (handler-case (let ((font (xlib:open-font display (namestring font-name))))
-		  (xlib:display-finish-output display)
-		  (setf (svref font-family-map index) font))
-    (xlib:name-error ()
-     (warn "Cannot open font -- ~S" font-name)
-     nil)))
-
-
-
-;;;; HEMLOCK-BEEP.
-
-(defvar *editor-bell* (make-string 1 :initial-element #\bell))
-
-;;; TTY-BEEP is used in Hemlock for beeping when running under a terminal.
-;;; Send a #\bell to unix standard output.
-;;;
-(defun tty-beep (&optional device stream)
-  (declare (ignore device stream))
-  (when (variable-value 'ed::bell-style)
-    (mach:unix-write 1 *editor-bell* 0 1)))
-
-(proclaim '(special *current-window*))
-
-;;; BITMAP-BEEP is used in Hemlock for beeping when running under windowed
-;;; input.
-;;;
-(defun bitmap-beep (display stream)
-  (declare (ignore stream))
-  (ecase (variable-value 'ed::bell-style)
-    (:border-flash
-     (flash-window-border *current-window*))
-    (:feep
-     (xlib:bell display)
-     (xlib:display-force-output display))
-    (:border-flash-and-feep
-     (xlib:bell display)
-     (xlib:display-force-output display)
-     (flash-window-border *current-window*))
-    (:flash
-     (flash-window *current-window*))
-    (:flash-and-feep
-     (xlib:bell display)
-     (xlib:display-force-output display)
-     (flash-window *current-window*))
-    ((nil) ;Do nothing.
-     )))
-
-(proclaim '(special *foreground-background-xor*))
-
-(defun flash-window-border (window)
-  (let* ((hunk (window-hunk window))
-	 (xwin (bitmap-hunk-xwindow hunk))
-	 (gcontext (bitmap-hunk-gcontext hunk))
-	 (display (bitmap-device-display (device-hunk-device hunk)))
-	 (border (variable-value 'ed::beep-border-width))
-	 (h (or (bitmap-hunk-modeline-pos hunk) (bitmap-hunk-height hunk)))
-	 (top-border (min (ash h -1) border))
-	 (w (bitmap-hunk-width hunk))
-	 (side-border (min (ash w -1) border))
-	 (top-width (max 0 (- w (ash side-border 1))))
-	 (right-x (- w side-border))
-	 (bottom-y (- h top-border)))
-    (xlib:with-gcontext (gcontext :function xlib::boole-xor
-				  :foreground *foreground-background-xor*)
-      (dotimes (i 8)
-	(xlib:draw-rectangle xwin gcontext 0 0 side-border h t)
-	(xlib:display-force-output display)
-	(xlib:draw-rectangle xwin gcontext side-border bottom-y
-			     top-width top-border t)
-	(xlib:display-force-output display)
-	(xlib:draw-rectangle xwin gcontext right-x 0 side-border h t)
-	(xlib:display-force-output display)
-	(xlib:draw-rectangle xwin gcontext side-border 0 top-width top-border t)
-	(xlib:display-force-output display)))))
-
-(defun flash-window (window)
-  (let* ((hunk (window-hunk window))
-	 (xwin (bitmap-hunk-xwindow hunk))
-	 (gcontext (bitmap-hunk-gcontext hunk))
-	 (display (bitmap-device-display (device-hunk-device hunk)))
-	 (width (bitmap-hunk-width hunk))
-	 (height (or (bitmap-hunk-modeline-pos hunk)
-		     (bitmap-hunk-height hunk))))
-    (xlib:with-gcontext (gcontext :function xlib::boole-xor
-				  :foreground *foreground-background-xor*)
-      (xlib:draw-rectangle xwin gcontext 0 0 width height t)
-      (xlib:display-force-output display)
-      (xlib:draw-rectangle xwin gcontext 0 0 width height t)
-      (xlib:display-force-output display))))
-
-
-
-(defun hemlock-beep (stream)
-  "Using the current window, calls the device's beep function on stream."
-  (let ((device (device-hunk-device (window-hunk (current-window)))))
-    (funcall (device-beep device) (bitmap-device-display device) stream)))
-
-
-
-;;;; GC messages.
-
-;;; HEMLOCK-GC-NOTIFY-BEFORE and HEMLOCK-GC-NOTIFY-AFTER both MESSAGE GC
-;;; notifications when Hemlock is not running under X11.  It cannot affect
-;;; its window's without using its display connection.  Since GC can occur
-;;; inside CLX request functions, using the same display confuses CLX.
-;;;
-
-(defun hemlock-gc-notify-before (bytes-in-use)
-  (let ((control "~%[GC threshold exceeded with ~:D bytes in use.  ~
-  		  Commencing GC.]~%"))
-    (cond ((not hi::*editor-windowed-input*)
-	   (beep)
-	   #|(message control bytes-in-use)|#)
-	  (t
-	   ;; Can't call BEEP since it would use Hemlock's display connection.
-	   (lisp::default-beep-function *standard-output*)
-	   (format t control bytes-in-use)
-	   (finish-output)))))
-
-(defun hemlock-gc-notify-after (bytes-retained bytes-freed trigger)
-  (let ((control
-	 "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%~
-	  [GC will next occur when at least ~:D bytes are in use.]~%"))
-    (cond ((not hi::*editor-windowed-input*)
-	   (beep)
-	   #|(message control bytes-retained bytes-freed)|#)
-	  (t
-	   ;; Can't call BEEP since it would use Hemlock's display connection.
-	   (lisp::default-beep-function *standard-output*)
-	   (format t control bytes-retained bytes-freed trigger)
-	   (finish-output)))))
-
-
-
-;;;; Site-Wrapper-Macro and standard device init/exit functions.
-
-(defun in-hemlock-standard-input-read (stream &rest ignore)
-  (declare (ignore ignore))
-  (error "You cannot read off this stream while in Hemlock -- ~S"
-	 stream))
-
-(defvar *illegal-read-stream*
-  (lisp::make-stream :in #'in-hemlock-standard-input-read))
-
-(defmacro site-wrapper-macro (&body body)
-  `(unwind-protect
-     (progn
-       (when *editor-has-been-entered*
-	 (let ((device (device-hunk-device (window-hunk (current-window)))))
-	   (funcall (device-init device) device)))
-       (let ((*beep-function* #'hemlock-beep)
-	     (*gc-notify-before* #'hemlock-gc-notify-before)
-	     (*gc-notify-after* #'hemlock-gc-notify-after)
-	     (*standard-input* *illegal-read-stream*)
-	     (*query-io* *illegal-read-stream*))
-	 (cond ((not *editor-windowed-input*)
-		,@body)
-	       (t
-		(ext:with-clx-event-handling
-		    (*editor-windowed-input* #'ext:object-set-event-handler)
-		  ,@body)))))
-     (let ((device (device-hunk-device (window-hunk (current-window)))))
-       (funcall (device-exit device) device))))
-
-(defun standard-device-init ()
-  (setup-input))
-
-(defun standard-device-exit ()
-  (reset-input))
-
-(proclaim '(special *echo-area-window*))
-
-;;; Maybe bury/unbury hemlock window when we go to and from Lisp.
-;;; This should do something more sophisticated when we know what that is.
-;;; 
-(defun default-hemlock-window-mngt (display on)
-  (let ((xparent (window-group-xparent
-		  (bitmap-hunk-window-group (window-hunk *current-window*))))
-	(echo-xparent (window-group-xparent
-		       (bitmap-hunk-window-group
-			(window-hunk *echo-area-window*)))))
-    (cond (on (setf (xlib:window-priority echo-xparent) :above)
-	      (clear-editor-input *editor-input*)
-	      (setf (xlib:window-priority xparent) :above))
-	  (t (setf (xlib:window-priority echo-xparent) :below)
-	     (setf (xlib:window-priority xparent) :below))))
-  (xlib:display-force-output display))
-
-(defvar *hemlock-window-mngt* #'default-hemlock-window-mngt
-  "This function is called by HEMLOCK-WINDOW, passing its arguments.  This may
-   be nil.")
-
-(defun hemlock-window (display on)
-  "Calls *hemlock-window-mngt* on the argument ON when *current-window* is
-  bound.  This is called in the device init and exit methods for X bitmap
-  devices."
-  (when (and *hemlock-window-mngt* *current-window*)
-    (funcall *hemlock-window-mngt* display on)))
-
-
-
-;;;; Line Wrap Char.
-
-(defvar *line-wrap-char* #\!
-  "The character to be displayed to indicate wrapped lines.")
-
-
-;;;; Current terminal character translation.
-
-(defconstant termcap-file "/etc/termcap")
-
-
-
-;;;; Event scheduling.
-
-;;; The time queue provides a ROUGH mechanism for scheduling events to
-;;; occur after a given amount of time has passed, optionally repeating
-;;; using the given time as an interval for rescheduling.  When the input
-;;; loop goes around, it will check the current time and process all events
-;;; that should have happened before or at this time.  The function gets
-;;; called on the number of seconds that have elapsed since it was last
-;;; called.
-;;;
-;;; NEXT-SCHEDULED-EVENT-WAIT and INVOKE-SCHEDULED-EVENTS are used in the
-;;; editor stream in methods.
-;;;
-;;; SCHEDULE-EVENT and REMOVE-SCHEDULED-EVENT are exported interfaces.
-
-(defstruct (tq-event (:print-function print-tq-event)
-		     (:constructor make-tq-event
-				   (time last-time interval function)))
-  time		; When the event should happen.
-  last-time	; When the event was scheduled.
-  interval	; When non-nil, how often the event should happen.
-  function)	; What to do.
-
-(defun print-tq-event (obj stream n)
-  (declare (ignore n))
-  (format stream "#<Tq-Event ~S>" (tq-event-function obj)))
-
-(defvar *time-queue* nil
-  "This is the time priority queue used in Hemlock input streams for event
-   scheduling.")
-
-;;; QUEUE-TIME-EVENT inserts event into the time priority queue *time-queue*.
-;;; Event is inserted before the first element that it is less than (which
-;;; means that it gets inserted after elements that are the same).
-;;; *time-queue* is returned.
-;;; 
-(defun queue-time-event (event)
-  (let ((time (tq-event-time event)))
-    (if *time-queue*
-	(if (< time (tq-event-time (car *time-queue*)))
-	    (push event *time-queue*)
-	    (do ((prev *time-queue* rest)
-		 (rest (cdr *time-queue*) (cdr rest)))
-		((or (null rest)
-		     (< time (tq-event-time (car rest))))
-		 (push event (cdr prev))
-		 *time-queue*)))
-	(push event *time-queue*))))
-
-;;; NEXT-SCHEDULED-EVENT-WAIT returns nil or the number of seconds to wait for
-;;; the next event to happen.
-;;; 
-(defun next-scheduled-event-wait ()
-  (if *time-queue*
-      (let ((wait (round (- (tq-event-time (car *time-queue*))
-			    (get-internal-real-time))
-			 internal-time-units-per-second)))
-	(if (plusp wait) wait 0))))
-
-;;; INVOKE-SCHEDULED-EVENTS invokes all the functions in *time-queue* whose
-;;; time has come.  If we run out of events, or there are none, then we get
-;;; out.  If we popped an event whose time hasn't come, we push it back on the
-;;; queue.  Each function is called on how many seconds, roughly, went by since
-;;; the last time it was called (or scheduled).  If it has an interval, we
-;;; re-queue it.  While invoking the function, bind *time-queue* to nothing in
-;;; case the event function tries to read off *editor-input*.
-;;;
-(defun invoke-scheduled-events ()
-  (let ((time (get-internal-real-time)))
-    (loop
-      (unless *time-queue* (return))
-      (let* ((event (car *time-queue*))
-	     (event-time (tq-event-time event)))
-	(cond ((>= time event-time)
-	       (let ((*time-queue* nil))
-		 (funcall (tq-event-function event)
-			  (round (- time (tq-event-last-time event))
-				 internal-time-units-per-second)))
-	       (without-interrupts
-		(let ((interval (tq-event-interval event)))
-		  (when interval
-		    (setf (tq-event-time event) (+ time interval))
-		    (setf (tq-event-last-time event) time)
-		    (pop *time-queue*)
-		    (queue-time-event event)))))
-	      (t (return)))))))
-
-(defun schedule-event (time function &optional (repeat t))
-  "This causes function to be called after time seconds have passed,
-   optionally repeating every time seconds.  This is a rough mechanism
-   since commands can take an arbitrary amount of time to run; the function
-   will be called at the first possible moment after time has elapsed.
-   Function takes the time that has elapsed since the last time it was
-   called (or since it was scheduled for the first invocation)."
-  (let ((now (get-internal-real-time))
-	(itime (* internal-time-units-per-second time)))
-    (queue-time-event (make-tq-event (+ itime now) now (if repeat itime)
-				     function))))
-
-(defun remove-scheduled-event (function)
-  "Removes function queued with SCHEDULE-EVENT."
-  (setf *time-queue* (delete function *time-queue* :key #'tq-event-function)))
-
-
-
-;;;; Editor sleeping.
-
-(defun editor-sleep (time)
-  "Sleep for approximately Time seconds."
-  (unless (or (zerop time) (listen-editor-input *editor-input*))
-    (internal-redisplay)
-    (sleep-for-time time)
-    nil))
-
-(defun sleep-for-time (time)
-  (let ((nrw-fun (device-note-read-wait
-		  (device-hunk-device (window-hunk (current-window)))))
-	(end (+ (get-internal-real-time)
-		(truncate (* time internal-time-units-per-second)))))
-    (loop
-      (when (listen-editor-input *editor-input*)
-	(return))
-      (let ((left (- end (get-internal-real-time))))
-	(unless (plusp left) (return nil))
-	(when nrw-fun (funcall nrw-fun t))
-	(system:serve-event (/ (float left)
-			       (float internal-time-units-per-second)))))
-    (when nrw-fun (funcall nrw-fun nil))))
-
-
-
-;;;; Showing a mark.
-
-(defun show-mark (mark window time)
-  "Highlights the position of Mark within Window for Time seconds,
-   possibly by moving the cursor there.  If Mark is not displayed within
-   Window return NIL.  The wait may be aborted if there is pending input."
-  (let* ((result t))
-    (catch 'redisplay-catcher
-      (redisplay-window window)
-      (setf result
-	    (multiple-value-bind (x y) (mark-to-cursorpos mark window)
-	      (funcall (device-show-mark
-			(device-hunk-device (window-hunk window)))
-		       window x y time))))
-    result))
-
-(defun tty-show-mark (window x y time)
-  (cond ((listen-editor-input *editor-input*))
-	(x (internal-redisplay)
-	   (let* ((hunk (window-hunk window))
-		  (device (device-hunk-device hunk)))
-	     (funcall (device-put-cursor device) hunk x y)
-	     (when (device-force-output device)
-	       (funcall (device-force-output device)))
-	     (sleep-for-time time))
-	   t)
-	(t nil)))
-
-(defun bitmap-show-mark (window x y time)
-  (cond ((listen-editor-input *editor-input*))
-	(x (let* ((hunk (window-hunk window))
-		  (display (bitmap-device-display (device-hunk-device hunk))))
-	     (internal-redisplay)
-	     (hunk-show-cursor hunk x y)
-	     (drop-cursor)
-	     (xlib:display-finish-output display)
-	     (sleep-for-time time)
-	     (lift-cursor)
-	     t))
-	(t nil)))
-
-
-
-;;;; Function description and defined-from.
-
-;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object.  It
-;;; returns a pathname for the file the function was defined in.  If it was
-;;; not defined in some file, then nil is returned.
-;;; 
-(defun fun-defined-from-pathname (function)
-  "Takes a symbol or function and returns the pathname for the file the function
-   was defined in.  If it was not defined in some file, nil is returned."
-  (typecase function
-    (symbol (fun-defined-from-pathname (careful-symbol-function function)))
-    (compiled-function
-     (let* ((string (%primitive header-ref function
-				system:%function-defined-from-slot))
-	    (file (subseq string 0 (position #\space string :test #'char=))))
-       (declare (simple-string file))
-       (if (or (char= #\# (schar file 0))
-	       (string-equal file "lisp"))
-	   nil
-	   (if (string= file "/.." :end1 3)
-	       (pathname (subseq file
-				 (position #\/ file :test #'char= :start 4)))
-	       (pathname file)))))
-    (t nil)))
-
-
-(defvar *editor-describe-stream*
-  (system:make-indenting-stream *standard-output*))
-
-;;; EDITOR-DESCRIBE-FUNCTION has to mess around to get indenting streams to
-;;; work.  These apparently work fine for DESCRIBE, for which they were defined,
-;;; but not in general.  It seems they don't indent initial text, only that
-;;; following a newline, so inside our use of INDENTING-FURTHER, we need some
-;;; form before the WRITE-STRING.  To get this to work, I had to remove the ~%
-;;; from the FORMAT string, and use FRESH-LINE; simply using FRESH-LINE with
-;;; the ~% caused an extra blank line.  Possibly I should not have glommed onto
-;;; this hack whose interface comes from three different packages, but it did
-;;; the right thing ....
-;;;
-;;; Also, we have set INDENTING-STREAM-STREAM to make sure the indenting stream
-;;; is based on whatever *standard-output* is when we are called.
-;;;
-(defun editor-describe-function (fun sym)
-  "Calls DESCRIBE on fun.  If fun is compiled, and its original name is not sym,
-   then this also outputs any 'function documentation for sym to
-   *standard-output*."
-  (describe fun)
-  (when (and (compiled-function-p fun)
-	     (not (eq (%primitive header-ref fun %function-name-slot) sym)))
-    (let ((doc (documentation sym 'function)))
-      (when doc
-	(format t "~&Function documentation for ~S:" sym)
-	(setf (lisp::indenting-stream-stream *editor-describe-stream*)
-	      *standard-output*)
-	(ext:indenting-further *editor-describe-stream* 2
-	  (fresh-line *editor-describe-stream*)
-	  (write-string doc *editor-describe-stream*))))))
-
-
-
-
-;;;; X Stuff.
-
-;;; Setting window cursors ...
-;;; 
-
-(proclaim '(special *default-foreground-pixel* *default-background-pixel*))
-
-(defvar *hemlock-cursor* nil "Holds cursor for Hemlock windows.")
-
-;;; DEFINE-WINDOW-CURSOR in shoved on the "Make Window Hook".
-;;; 
-(defun define-window-cursor (window)
-  (setf (xlib:window-cursor (bitmap-hunk-xwindow (window-hunk window)))
-	*hemlock-cursor*))
-
-;;; These are set in INIT-BITMAP-SCREEN-MANAGER and REVERSE-VIDEO-HOOK-FUN.
-;;;
-(defvar *cursor-foreground-color* nil)
-(defvar *cursor-background-color* nil)
-(defun make-white-color () (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))
-(defun make-black-color () (xlib:make-color :red 0.0 :green 0.0 :blue 0.0))
-
-
-;;; GET-HEMLOCK-CURSOR is used in INIT-BITMAP-SCREEN-MANAGER to load the
-;;; hemlock cursor for DEFINE-WINDOW-CURSOR.
-;;;
-(defun get-hemlock-cursor (display)
-  (when *hemlock-cursor* (xlib:free-cursor *hemlock-cursor*))
-  (let* ((cursor-file (truename (variable-value 'ed::cursor-bitmap-file)))
-	 (mask-file (probe-file (make-pathname :type "mask"
-					       :defaults cursor-file)))
-	 (root (xlib:screen-root (xlib:display-default-screen display)))
-	 (mask-pixmap (if mask-file (get-cursor-pixmap root mask-file))))
-    (multiple-value-bind (cursor-pixmap cursor-x-hot cursor-y-hot)
-			 (get-cursor-pixmap root cursor-file)
-      (setf *hemlock-cursor*
-	    (xlib:create-cursor :source cursor-pixmap :mask mask-pixmap
-				:x cursor-x-hot :y cursor-y-hot
-				:foreground *cursor-foreground-color*
-				:background *cursor-background-color*))
-      (xlib:free-pixmap cursor-pixmap)
-      (when mask-pixmap (xlib:free-pixmap mask-pixmap)))))
-
-(defun get-cursor-pixmap (root pathname)
-  (let* ((image (xlib:read-bitmap-file pathname))
-	 (pixmap (xlib:create-pixmap :width 16 :height 16
-				     :depth 1 :drawable root))
-	 (gc (xlib:create-gcontext
-	      :drawable pixmap :function boole-1
-	      :foreground *default-foreground-pixel*
-	      :background *default-background-pixel*)))
-    (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16)
-    (xlib:free-gcontext gc)
-    (values pixmap (xlib:image-x-hot image) (xlib:image-y-hot image))))
-
-
-;;; Setting up grey borders ...
-;;; 
-
-(defparameter hemlock-grey-bitmap-data
-  '(#*10 #*01))
-
-(defun get-hemlock-grey-pixmap (display)
-  (let* ((screen (xlib:display-default-screen display))
-	 (depth (xlib:screen-root-depth screen))
-	 (root (xlib:screen-root screen))
-	 (height (length hemlock-grey-bitmap-data))
-	 (width (length (car hemlock-grey-bitmap-data)))
-	 (image (apply #'xlib:bitmap-image hemlock-grey-bitmap-data))
-	 (pixmap (xlib:create-pixmap :width width :height height
-				     :depth depth :drawable root))
-	 (gc (xlib:create-gcontext :drawable pixmap
-				   :function boole-1
-				   :foreground *default-foreground-pixel*
-				   :background *default-background-pixel*)))
-    (xlib:put-image pixmap gc image
-		    :x 0 :y 0 :width width :height height :bitmap-p t)
-    (xlib:free-gcontext gc)
-    pixmap))
-
-
-;;; Cut Buffer manipulation ...
-;;;
-
-(defun store-cut-string (display string)
-  (check-type string simple-string)
-  (setf (xlib:cut-buffer display) string))
-
-(defun fetch-cut-string (display)
-  (xlib:cut-buffer display))
-
-
-;;; Window naming ...
-;;;
-(defun set-window-name-for-buffer-name (buffer new-name)
-  (dolist (ele (buffer-windows buffer))
-    (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk ele))
-				  :icon-name new-name)))
-  
-(defun set-window-name-for-window-buffer (window new-buffer)
-  (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk window))
-				:icon-name (buffer-name new-buffer)))
-
-
-
-;;;; Some hacks for supporting Hemlock under Mach.
-
-;;; WINDOWED-MONITOR-P is used by the reverse video variable's hook function
-;;; to determine if it needs to go around fixing all the windows.
-;;;
-(defun windowed-monitor-p ()
-  "This returns whether the monitor is being used with a window system.  It
-   returns the console's CLX display structure."
-  *editor-windowed-input*)
-
-(defun get-terminal-name ()
-  (cdr (assoc :term *environment-list* :test #'eq)))
-
-(defun get-termcap-env-var ()
-  (cdr (assoc :termcap *environment-list* :test #'eq)))
-
-
-
-(defvar *editor-buffer* (make-string 256))
-
-;;; GET-EDITOR-TTY-INPUT reads from stream's Unix file descriptor queuing events
-;;; in the stream's queue.
-;;;
-(defun get-editor-tty-input (fd)
-  (let* ((buf *editor-buffer*)
-	 (len (mach:unix-read fd buf 256))
-	 (i 0))
-    (declare (simple-string buf) (fixnum len i))
-    (loop
-      (when (>= i len) (return t))
-      (q-event *real-editor-input*
-	       (ext:char-key-event (schar buf i)))
-      (incf i))))
-
-;;; This is used to get listening during smart redisplay to pick up input
-;;; in between displaying each line by listening longer (or slowing down
-;;; line output depending on your model).  10-20 seems to be good for 9600
-;;; baud, and 250 seems to do it with 1200 baud.
-;;; 
-(defparameter listen-iterations-hack 1) ; 10-20 seems to really pick up input.
-
-(defun editor-tty-listen (stream)
-  (mach::with-trap-arg-block mach::int1 nc
-    (dotimes (i listen-iterations-hack nil)
-      (multiple-value-bind (val err) 
-			   (mach::Unix-ioctl (tty-editor-input-fd stream)
-					     mach::FIONREAD
-					     (lisp::alien-value-sap
-					      mach::int1))
-	(declare (ignore err))
-	(when (and val
-		   (> (alien-access (mach::int1-int (alien-value nc))) 0))
-	  (return t))))))
-
-
-
-(defvar old-flags)
-
-(defvar old-tchars)
-
-(defvar old-ltchars)
-
-(defun setup-input ()
-  (let ((fd *editor-file-descriptor*))
-    (when (mach:unix-isatty 0)
-      (mach:with-trap-arg-block mach:sgtty sg
-	(multiple-value-bind
-	    (val err)
-	    (mach:unix-ioctl fd mach:TIOCGETP
-			     (lisp::alien-value-sap mach:sgtty))
-	  (if (null val)
-	      (error "Could not get tty information, unix error ~S."
-		     (mach:get-unix-error-msg err)))
-	  (let ((flags (alien-access (mach::sgtty-flags (alien-value sg)))))
-	    (setq old-flags flags)
-	    (setf (alien-access (mach::sgtty-flags (alien-value sg)))
-		  (logand (logior flags mach::tty-cbreak)
-			  (lognot mach::tty-echo)
-			  (lognot mach::tty-crmod)))
-	    (multiple-value-bind
-		(val err)
-		(mach:unix-ioctl fd mach:TIOCSETP
-				 (lisp::alien-value-sap mach:sgtty))
-	      (if (null val)
-		  (error "Could not set tty information, unix error ~S."
-			 (mach:get-unix-error-msg err)))))))
-      (mach:with-trap-arg-block mach:tchars tc
-	(multiple-value-bind
-	    (val err)
-	    (mach:unix-ioctl fd mach:TIOCGETC
-			     (lisp::alien-value-sap mach:tchars))
-	  (if (null val)
-	      (error "Could not get tty tchars information, unix error ~S."
-		     (mach:get-unix-error-msg err)))
-	  (setq old-tchars
-		(vector (alien-access (mach::tchars-intrc (alien-value tc)))
-			(alien-access (mach::tchars-quitc (alien-value tc)))
-			(alien-access (mach::tchars-startc (alien-value tc)))
-			(alien-access (mach::tchars-stopc (alien-value tc)))
-			(alien-access (mach::tchars-eofc (alien-value tc)))
-			(alien-access (mach::tchars-brkc (alien-value tc))))))
-	(setf (alien-access (mach::tchars-intrc (alien-value tc)))
-	      (if *editor-windowed-input* -1 28))
-	(setf (alien-access (mach::tchars-quitc (alien-value tc))) -1)
-	(setf (alien-access (mach::tchars-startc (alien-value tc))) -1)
-	(setf (alien-access (mach::tchars-stopc (alien-value tc))) -1)
-	(setf (alien-access (mach::tchars-eofc (alien-value tc))) -1)
-	(setf (alien-access (mach::tchars-brkc (alien-value tc))) -1)
-	(multiple-value-bind
-	    (val err)
-	    (mach:unix-ioctl fd mach:TIOCSETC
-			     (lisp::alien-value-sap mach:tchars))
-	  (if (null val) (error "Failed to set tchars, 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 fd mach:TIOCGLTC
-			     (lisp::alien-value-sap mach:ltchars))
-	  (if (null val)
-	      (error "Could not get tty ltchars information, unix error ~S."
-		     (mach:get-unix-error-msg err)))
-	  (setq old-ltchars
-		(vector (alien-access (mach::ltchars-suspc (alien-value tc)))
-			(alien-access (mach::ltchars-dsuspc (alien-value tc)))
-			(alien-access (mach::ltchars-rprntc (alien-value tc)))
-			(alien-access (mach::ltchars-flushc (alien-value tc)))
-			(alien-access (mach::ltchars-werasc (alien-value tc)))
-			(alien-access (mach::ltchars-lnextc (alien-value tc))))))
-	(setf (alien-access (mach::ltchars-suspc (alien-value tc))) -1)
-	(setf (alien-access (mach::ltchars-dsuspc (alien-value tc))) -1)
-	(setf (alien-access (mach::ltchars-rprntc (alien-value tc))) -1)
-	(setf (alien-access (mach::ltchars-flushc (alien-value tc))) -1)
-	(setf (alien-access (mach::ltchars-werasc (alien-value tc))) -1)
-	(setf (alien-access (mach::ltchars-lnextc (alien-value tc))) -1)
-	(multiple-value-bind
-	    (val err)
-	    (mach:unix-ioctl fd mach:TIOCSLTC
-			     (lisp::alien-value-sap mach:ltchars))
-	  (if (null val) (error "Failed to set ltchars, unix error ~S."
-				(mach:get-unix-error-msg err))))))))
-
-	
-(defun reset-input ()
-  (when (mach:unix-isatty 0)
-    (if (boundp 'old-flags)
-	(let ((fd *editor-file-descriptor*))
-	  (mach:with-trap-arg-block mach:sgtty sg
-	    (multiple-value-bind
-		(val err)
-		(mach:unix-ioctl fd mach:TIOCGETP
-				 (lisp::alien-value-sap mach:sgtty))
-	      (if (null val)
-		  (error "Could not get tty information, unix error ~S."
-			 (mach:get-unix-error-msg err)))
-	      (setf (alien-access (mach::sgtty-flags (alien-value sg)))
-		    old-flags)
-	      (multiple-value-bind
-		  (val err)
-		  (mach:unix-ioctl fd mach:TIOCSETP
-				   (lisp::alien-value-sap mach:sgtty))
-		(if (null val)
-		    (error "Could not set tty information, unix error ~S."
-			   (mach:get-unix-error-msg err))))))
-	  (cond ((and (boundp 'old-tchars)
-		      (simple-vector-p old-tchars)
-		      (eq (length old-tchars) 6))
-		 (mach:with-trap-arg-block mach:tchars tc
-		   (setf (alien-access (mach::tchars-intrc (alien-value tc)))
-			 (svref old-tchars 0))
-		   (setf (alien-access (mach::tchars-quitc (alien-value tc)))
-			 (svref old-tchars 1))
-		   (setf (alien-access (mach::tchars-startc (alien-value tc)))
-			 (svref old-tchars 2))
-		   (setf (alien-access (mach::tchars-stopc (alien-value tc)))
-			 (svref old-tchars 3))
-		   (setf (alien-access (mach::tchars-eofc (alien-value tc)))
-			 (svref old-tchars 4))
-		   (setf (alien-access (mach::tchars-brkc (alien-value tc)))
-			 (svref old-tchars 5))
-		   (multiple-value-bind
-		       (val err)
-		       (mach:unix-ioctl fd mach:TIOCSETC
-					(lisp::alien-value-sap mach:tchars))
-		     (if (null val)
-			 (error "Failed to set tchars, unix error ~S."
-				(mach:get-unix-error-msg err)))))))
-	  (cond ((and (boundp 'old-ltchars)
-		      (simple-vector-p old-ltchars)
-		      (eq (length old-ltchars) 6))
-		 (mach:with-trap-arg-block mach:ltchars tc
-		   (setf (alien-access (mach::ltchars-suspc (alien-value tc)))
-			 (svref old-ltchars 0))
-		   (setf (alien-access (mach::ltchars-dsuspc (alien-value tc)))
-			 (svref old-ltchars 1))
-		   (setf (alien-access (mach::ltchars-rprntc (alien-value tc)))
-			 (svref old-ltchars 2))
-		   (setf (alien-access (mach::ltchars-flushc (alien-value tc)))
-			 (svref old-ltchars 3))
-		   (setf (alien-access (mach::ltchars-werasc (alien-value tc)))
-			 (svref old-ltchars 4))
-		   (setf (alien-access (mach::ltchars-lnextc (alien-value tc)))
-			 (svref old-ltchars 5))
-		   (multiple-value-bind
-		       (val err)
-		       (mach:unix-ioctl fd mach:TIOCSLTC
-					(lisp::alien-value-sap mach:ltchars))
-		     (if (null val)
-			 (error "Failed to set ltchars, unix error ~S."
-				(mach:get-unix-error-msg err)))))))))))
-
-
-(defun pause-hemlock ()
-  "Pause hemlock and pop out to the Unix Shell."
-  (mach:unix-kill (mach:unix-getpid) mach:sigtstp)
-  T)
diff --git a/hemlock/screen.lisp b/hemlock/screen.lisp
deleted file mode 100644
index e9251a7d90805eb721b60545d51dadc621f49c90..0000000000000000000000000000000000000000
--- a/hemlock/screen.lisp
+++ /dev/null
@@ -1,200 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles.
-;;;
-;;; Device independent screen management functions.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(make-window delete-window next-window previous-window))
-
-
-
-;;;; Screen management initialization.
-
-(proclaim '(special *echo-area-buffer*))
-
-;;; %INIT-SCREEN-MANAGER creates the initial windows and sets up the data
-;;; structures used by the screen manager.  The "Main" and "Echo Area" buffer
-;;; modelines are set here in case the user modified these Hemlock variables in
-;;; his init file.  Since these buffers don't have windows yet, these sets
-;;; won't cause any updates to occur.  This is called from %INIT-REDISPLAY.
-;;;
-(defun %init-screen-manager (display)
-  (setf (buffer-modeline-fields *current-buffer*)
-	(value ed::default-modeline-fields))
-  (setf (buffer-modeline-fields *echo-area-buffer*)
-	(value ed::default-status-line-fields))
-  (if (windowed-monitor-p)
-      (init-bitmap-screen-manager display)
-      (init-tty-screen-manager (get-terminal-name))))
-
-
-
-;;;; Window operations.
-
-(defun make-window (start &key
-			  (modelinep t)
-			  (device nil)
-			  window
-			  (font-family *default-font-family*)
-			  (ask-user nil)
-			  x y
-			  (width (value ed::default-window-width))
-			  (height (value ed::default-window-height)))
-  "Make a window that displays text starting at the mark Start.  The default
-   action is to split the current window to make room for the new window.
-
-   Modelinep specifies whether the window should display buffer modelines.
-
-   Device is the Hemlock device to make the window on.  If it is nil, then
-   the window is made on the same device as CURRENT-WINDOW.
-
-   Window is an X window to be used with the Hemlock window.  The supplied
-   window becomes the parent window for a new group of windows that behave
-   in a stack orientation as windows do on the terminal.
-
-   Font-Family is the font-family used for displaying text in the window.
-
-   If Ask-User is non-nil, Hemlock prompts the user for missing X, Y, Width,
-   and Height arguments to make a new group of windows that behave in a stack
-   orientation as windows do on the terminal.  This occurs by invoking
-   hi::*create-window-hook*.  X and Y are supplied as pixels, but Width and
-   Height are supplied in characters."
-
-  (let* ((device (or device (device-hunk-device (window-hunk (current-window)))))
-	 (window (funcall (device-make-window device)
-			  device start modelinep window font-family
-			  ask-user x y width height)))
-    (unless window (editor-error "Could not make a window."))
-    (invoke-hook ed::make-window-hook window)
-    window))
-
-(defun delete-window (window)
-  "Make Window go away, removing it from the screen.  This uses
-   hi::*delete-window-hook* to get rid of parent windows on a bitmap device
-   when you delete the last Hemlock window in a group."
-  (when (<= (length *window-list*) 2)
-    (error "Cannot kill the only window."))
-  (invoke-hook ed::delete-window-hook window)
-  (setq *window-list* (delq window *window-list*))
-  (funcall (device-delete-window (device-hunk-device (window-hunk window)))
-	   window)
-  ;;
-  ;; Since the programmer's interface fails to allow users to determine if
-  ;; they're commands delete the current window, this primitive needs to
-  ;; make sure Hemlock doesn't get screwed.  This inadequacy comes from the
-  ;; bitmap window groups and the vague descriptions of PREVIOUS-WINDOW and
-  ;; NEXT-WINDOW.
-  (when (eq window *current-window*)
-    (let ((window (find-if-not #'(lambda (w) (eq w *echo-area-window*))
-			       *window-list*)))
-      (setf (current-buffer) (window-buffer window)
-	    (current-window) window))))
-
-(defun next-window (window)
-  "Return the next window after Window, wrapping around if Window is the
-  bottom window."
-  (check-type window window)
-  (funcall (device-next-window (device-hunk-device (window-hunk window)))
-	   window))
-
-(defun previous-window (window)
-  "Return the previous window after Window, wrapping around if Window is the
-  top window."
-  (check-type window window)
-  (funcall (device-previous-window (device-hunk-device (window-hunk window)))
-	   window))
-
-
-
-;;;; Random typeout support.
-
-;;; PREPARE-FOR-RANDOM-TYPEOUT  --  Internal
-;;;
-;;; The WITH-POP-UP-DISPLAY macro calls this just before displaying output
-;;; for the user.  This goes to some effor to compute the height of the window
-;;; in text lines if it is not supplied.  Whether it is supplied or not, we
-;;; add one to the height for the modeline, and we subtract one line if the
-;;; last line is empty.  Just before using the height, make sure it is at
-;;; least two -- one for the modeline and one for text, so window making
-;;; primitives don't puke.
-;;;
-(defun prepare-for-random-typeout (stream height)
-  (let* ((buffer (line-buffer (mark-line (random-typeout-stream-mark stream))))
-	 (real-height (1+ (or height (rt-count-lines buffer))))
-	 (device (device-hunk-device (window-hunk (current-window)))))
-    (funcall (device-random-typeout-setup device) device stream
-	     (max (if (and (empty-line-p (buffer-end-mark buffer)) (not height))
-		      (1- real-height)
-		      real-height)
-		  2))))
-
-;;; RT-COUNT-LINES computes the correct height for a window.  This includes
-;;; taking wrapping line characters into account.  Take the MARK-COLUMN at
-;;; the end of each line.  This is how many characters long hemlock thinks
-;;; the line is.  When it is displayed, however, end of line characters are
-;;; added to the end of each line that wraps.  The second INCF form adds
-;;; these to the current line length.  Then INCF the current height by the
-;;; CEILING of the width of the random typeout window and the line length
-;;; (with added line-end chars).  Use CEILING because there is always at
-;;; least one line.  Finally, jump out of the loop if we're at the end of
-;;; the buffer.
-;;;
-(defun rt-count-lines (buffer)
-  (with-mark ((mark (buffer-start-mark buffer)))
-    (let ((width (window-width (current-window)))
-	  (count 0))
-	(loop
-	  (let* ((column (mark-column (line-end mark)))
-		 (temp (ceiling (incf column (floor (1- column) width))
-				width)))
-	    ;; Lines with no characters yield zero temp.
-	    (incf count (if (zerop temp) 1 temp))
-	    (unless (line-offset mark 1) (return count)))))))
-
-
-;;; RANDOM-TYPEOUT-CLEANUP  --  Internal
-;;;
-;;;    Clean up after random typeout.  This clears the area where the 
-;;; random typeout was and redisplays any affected windows.
-;;;
-(defun random-typeout-cleanup (stream &optional (degree t))
-  (let* ((window (random-typeout-stream-window stream))
-	 (buffer (window-buffer window))
-	 (device (device-hunk-device (window-hunk window)))
-	 (*more-prompt-action* :normal))
-    (update-modeline-field buffer window :more-prompt)
-    (random-typeout-redisplay window)
-    (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))
-    (funcall (device-random-typeout-cleanup device) stream degree)
-    (when (device-force-output device)
-      (funcall (device-force-output device)))))
-
-;;; *more-prompt-action* is bound in random typeout streams before
-;;; redisplaying.
-;;;
-(defvar *more-prompt-action* :normal)
-(defvar *random-typeout-ml-fields*
-  (list (make-modeline-field
-	 :name :more-prompt
-	 :function #'(lambda (buffer window)
-		       (declare (ignore buffer window))
-		       (ecase *more-prompt-action*
-			 (:more "--More--")
-			 (:flush "--Flush--")
-			 (:empty "")
-			 (:normal
-			  (concatenate 'simple-string
-				       "Random Typeout Buffer          ["
-				       (buffer-name buffer)
-				       "]")))))))
diff --git a/hemlock/scribe.lisp b/hemlock/scribe.lisp
deleted file mode 100644
index aa28a7d0182cd205b94915755691acc767668589..0000000000000000000000000000000000000000
--- a/hemlock/scribe.lisp
+++ /dev/null
@@ -1,499 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/scribe.lisp,v 1.3 1991/02/08 16:37:23 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-
-(in-package "HEMLOCK")
-
-
-
-;;;; Variables.
-
-(defvar *scribe-para-break-table* (make-hash-table :test #'equal)
-  "A table of the Scribe commands that should be paragraph delimiters.")
-;;;
-(dolist (todo '("begin" "newpage" "make" "device" "caption" "tag" "end" 
-		"chapter" "section" "appendix" "subsection" "paragraph"
-		"unnumbered" "appendixsection" "prefacesection" "heading"
-		"majorheading" "subheading")) 
-  (setf (gethash todo *scribe-para-break-table*) t))
-
-(defhvar "Open Paren Character"
-  "The open bracket inserted by Scribe commands."
-  :value #\[)
-
-(defhvar "Close Paren Character"
-  "The close bracket inserted by Scribe commands."
-  :value #\])
-
-(defhvar "Escape Character"
-  "The escape character inserted by Scribe commands."
-  :value #\@)
-
-(defhvar "Scribe Bracket Table"
-  "This table maps a Scribe brackets, open and close, to their opposing
-   brackets."
-  :value (make-array char-code-limit))
-;;;
-(mapc #'(lambda (x y)
-	  (setf (svref (value scribe-bracket-table) (char-code x)) y)
-	  (setf (svref (value scribe-bracket-table) (char-code y)) x))
-      '(#\( #\[ #\{ #\<) '(#\) #\] #\} #\>))
-;;;
-(eval-when (compile eval)
-  (defmacro opposing-bracket (bracket)
-    `(svref (value scribe-bracket-table) (char-code ,bracket)))
-) ;eval-when
-
-
-
-;;;; "Scribe Syntax" Attribute.
-
-(defattribute "Scribe Syntax" 
-  "For Scribe Syntax, Possible types are:
-   :ESCAPE           ; basically #\@.
-   :OPEN-PAREN       ; Characters that open a Scribe paren:  #\[, #\{, #\(, #\<.
-   :CLOSE-PAREN      ; Characters that close a Scribe paren:  #\], #\}, #\), #\>.
-   :SPACE            ; Delimits end of a Scribe command.
-   :NEWLINE          ; Delimits end of a Scribe command."
-  'symbol nil)
-
-(setf (character-attribute :SCRIBE-SYNTAX #\)) :CLOSE-PAREN) 
-(setf (character-attribute :SCRIBE-SYNTAX #\]) :CLOSE-PAREN) 
-(setf (character-attribute :SCRIBE-SYNTAX #\}) :CLOSE-PAREN) 
-(setf (character-attribute :SCRIBE-SYNTAX #\>) :CLOSE-PAREN) 
-
-(setf (character-attribute :SCRIBE-SYNTAX #\() :OPEN-PAREN)     
-(setf (character-attribute :SCRIBE-SYNTAX #\[) :OPEN-PAREN)
-(setf (character-attribute :SCRIBE-SYNTAX #\{) :OPEN-PAREN)
-(setf (character-attribute :SCRIBE-SYNTAX #\<) :OPEN-PAREN)
-
-(setf (character-attribute :SCRIBE-SYNTAX #\Space)   :SPACE)
-(setf (character-attribute :SCRIBE-SYNTAX #\Newline) :NEWLINE)
-(setf (character-attribute :SCRIBE-SYNTAX #\@)       :ESCAPE)
-
-
-
-;;;; "Scribe" mode and setup.
-
-(defmode "Scribe" :major-p t)
-
-(shadow-attribute :paragraph-delimiter #\@ 1 "Scribe")
-(shadow-attribute :word-delimiter #\' 0 "Scribe")		;from Text Mode
-(shadow-attribute :word-delimiter #\backspace 0 "Scribe")	;from Text Mode
-(shadow-attribute :word-delimiter #\_ 0 "Scribe")		;from Text Mode
-
-(define-file-type-hook ("mss") (buffer type)
-  (declare (ignore type))
-  (setf (buffer-major-mode buffer) "Scribe"))
-
-
-
-;;;; Commands.
-
-(defcommand "Scribe Mode" (p)
-  "Puts buffer in Scribe mode.  Sets up comment variables and has delimiter
-   matching.  The definition of paragraphs is changed to know about scribe
-   commands."
-  "Puts buffer in Scribe mode."
-  (declare (ignore p))
-  (setf (buffer-major-mode (current-buffer)) "Scribe"))
-
-(defcommand "Select Scribe Warnings" (p)
-  "Goes to the Scribe Warnings buffer if it exists."
-  "Goes to the Scribe Warnings buffer if it exists."
-  (declare (ignore p))
-  (let ((buffer (getstring "Scribe Warnings" *buffer-names*)))
-    (if buffer
-	(change-to-buffer buffer)
-	(editor-error "There is no Scribe Warnings buffer."))))
-
-(defcommand "Add Scribe Paragraph Delimiter"
-	    (p &optional
-	       (word (prompt-for-string
-		      :prompt "Scribe command: "
-		      :help "Name of Scribe command to make delimit paragraphs."
-		      :trim t)))
-  "Prompts for a name to add to the table of commands that delimit paragraphs
-   in Scribe mode.  If a prefix argument is supplied, then the command name is
-   removed from the table."
-  "Add or remove Word in the *scribe-para-break-table*, depending on P."
-  (setf (gethash word *scribe-para-break-table*) (not p)))
-
-(defcommand "List Scribe Paragraph Delimiters" (p)
-  "Pops up a display of the Scribe commands that delimit paragraphs."
-  "Pops up a display of the Scribe commands that delimit paragraphs."
-  (declare (ignore p))
-  (let (result)
-    (maphash #'(lambda (k v)
-		 (declare (ignore v))
-		 (push k result))
-	     *scribe-para-break-table*)
-    (setf result (sort result #'string<))
-    (with-pop-up-display (s :height (length result))
-      (dolist (ele result) (write-line ele s)))))
-
-(defcommand "Scribe Insert Bracket" (p)
-  "Inserts a the bracket it is bound to and then shows the matching bracket."
-  "Inserts a the bracket it is bound to and then shows the matching bracket."
-  (declare (ignore p))
-  (scribe-insert-paren (current-point)
-		       (ext:key-event-char *last-key-event-typed*)))
-
-
-(defhvar "Scribe Command Table"
-  "This is a character dispatching table indicating which Scribe command or
-   environment to use."
-  :value (make-hash-table)
-  :mode "Scribe")
-
-(defvar *scribe-directive-type-table*
-  (make-string-table :initial-contents
-		     '(("Command" . :command)
-		       ("Environment" . :environment))))
-
-(defcommand "Add Scribe Directive" (p &optional
-				      (command-name nil command-name-p)
-				      type key-event mode)
-  "Adds a new scribe function to put into \"Scribe Command Table\"."
-  "Adds a new scribe function to put into \"Scribe Command Table\"."
-  (declare (ignore p))
-  (let ((command-name (if command-name-p
-			  command-name
-			  (or command-name
-			      (prompt-for-string :help "Directive Name"
-						 :prompt "Directive: ")))))
-    (multiple-value-bind (ignore type)
-			 (if type
-			     (values nil type)
-			     (prompt-for-keyword
-			      (list *scribe-directive-type-table*)
-			      :help "Enter Command or Environment."
-			      :prompt "Command or Environment: "))
-      (declare (ignore ignore))
-      (let ((key-event (or key-event
-			   (prompt-for-key-event :prompt
-						 "Dispatch Character: "))))
-	(setf (gethash key-event
-		       (cond (mode
-			      (variable-value 'scribe-command-table :mode mode))
-			     ((hemlock-bound-p 'scribe-command-table)
-			      (value scribe-command-table))
-			     (t (editor-error
-				 "Could not find \"Scribe Command Table\"."))))
-	      (cons type command-name))))))
-
-(defcommand "Insert Scribe Directive" (p)
-  "Prompts for a character to dispatch on.  Some indicate \"commands\" versus
-   \"environments\".  Commands are wrapped around the previous or current word.
-   If there is no previous word, the command is insert, leaving point between
-   the brackets.  Environments are wrapped around the next or current
-   paragraph, but when the region is active, this wraps the environment around
-   the region.  Each uses \"Open Paren Character\" and \"Close Paren
-   Character\"."
-  "Wrap some text with some stuff."
-  (declare (ignore p))
-  (loop
-    (let ((key-event (prompt-for-key-event :prompt "Dispatch Character: ")))
-      (if (logical-key-event-p key-event :help)
-	  (directive-help)
-	  (let ((table-entry (gethash key-event (value scribe-command-table))))
-	    (ecase (car table-entry)
-	      (:command
-	       (insert-scribe-directive (current-point) (cdr table-entry))
-	       (return))
-	      (:environment
-	       (enclose-with-environment (current-point) (cdr table-entry))
-	       (return))
-	      ((nil) (editor-error "Unknown dispatch character."))))))))
-
-
-
-;;;; "Insert Scribe Directive" support.
-
-(defun directive-help ()
-  (let ((commands ())
-	(environments ()))
-    (declare (list commands environments))
-    (maphash #'(lambda (k v)
-		 (if (eql (car v) :command)
-		     (push (cons k (cdr v)) commands)
-		     (push (cons k (cdr v)) environments)))
-	     (value scribe-command-table))
-    (setf commands (sort commands #'string< :key #'cdr))
-    (setf environments (sort environments #'string< :key #'cdr))
-    (with-pop-up-display (s :height (1+ (max (length commands)
-					     (length environments))))
-      (format s "~2TCommands~47TEnvironments~%")
-      (do ((commands commands (rest commands))
-	   (environments environments (rest environments)))
-	   ((and (endp commands) (endp environments)))
-	(let* ((command (first commands))
-	       (environment (first environments))
-	       (cmd-char (first command))
-	       (cmd-name (rest command))
-	       (env-char (first environment))
-	       (env-name (rest environment)))
-	  (write-string "  " s)
-	  (when cmd-char
-	    (ext:print-pretty-key-event cmd-char s)
-	    (format s "~7T")
-	    (write-string (or cmd-name "<prompts for command name>") s))
-	  (when env-char
-	    (format s "~47T")
-	    (ext:print-pretty-key-event env-char s)
-	    (format s "~51T")
-	    (write-string (or env-name "<prompts for command name>") s))
-	  (terpri s))))))
-
-;;;
-;;; Inserting and extending :command directives.
-;;;
-
-(defhvar "Insert Scribe Directive Function"
-  "\"Insert Scribe Directive\" calls this function when the directive type
-   is :command.  The function takes four arguments: a mark pointing to the word
-   start, the formatting command string, the open-paren character to use, and a
-   mark pointing to the word end."
-  :value 'scribe-insert-scribe-directive-fun
-  :mode "Scribe")
-
-(defun scribe-insert-scribe-directive-fun (word-start command-string
-					   open-paren-char word-end)
-  (insert-character word-start (value escape-character))
-  (insert-string word-start command-string)
-  (insert-character word-start open-paren-char)
-  (insert-character word-end (value close-paren-character)))
-
-(defhvar "Extend Scribe Directive Function"
-  "\"Insert Scribe Directive\" calls this function when the directive type is
-   :command to extend the the commands effect.  This function takes a string
-   and three marks: the first on pointing before the open-paren character for
-   the directive.  The string is the command-string to selected by the user
-   which this function uses to determine if it is actually extending a command
-   or inserting a new one.  The function must move the first mark before any
-   command text for the directive and the second mark to the end of any command
-   text.  It moves the third mark to the previous word's start where the
-   command region should be.  If this returns non-nil \"Insert Scribe
-   Directive\" moves the command region previous one word, and otherwise it
-   inserts the directive."
-  :value 'scribe-extend-scribe-directive-fun
-  :mode "Scribe")
-
-(defun scribe-extend-scribe-directive-fun (command-string
-					   command-end command-start word-start)
-  (word-offset (move-mark command-start command-end) -1)
-  (when (string= (the simple-string (region-to-string
-				     (region command-start command-end)))
-		 command-string)
-    (mark-before command-start)
-    (mark-after command-end)
-    (word-offset (move-mark word-start command-start) -1)))
-
-;;; INSERT-SCRIBE-DIRECTIVE first looks for the current or previous word at
-;;; mark.  Word-p says if we found one.  If mark is immediately before a word,
-;;; we use that word instead of the previous.  This is because if mark
-;;; corresponds to the CURRENT-POINT, the Hemlock cursor is displayed on the
-;;; first character of the word making users think the mark is in the word
-;;; instead of before it.  If we find a word, then we see if it already has
-;;; the given command-string, and if it does, we extend the use of the command-
-;;; string to the previous word.  At the end, if we hadn't found a word, we
-;;; backup the mark one character to put it between the command brackets.
-;;;
-(defun insert-scribe-directive (mark &optional command-string)
-  (with-mark ((word-start mark :left-inserting)
-	      (word-end mark :left-inserting))
-    (let ((open-paren-char (value open-paren-character))
-	  (word-p (if (and (zerop (character-attribute
-				   :word-delimiter
-				   (next-character word-start)))
-			   (= (character-attribute
-			       :word-delimiter
-			       (previous-character word-start))
-			      1))
-		      word-start
-		      (word-offset word-start -1)))
-	  (command-string (or command-string
-			      (prompt-for-string
-			       :trim t :prompt "Environment: "
-			       :help "Name of environment to enclose with."))))
-      (declare (simple-string command-string))
-      (cond
-       (word-p
-	(word-offset (move-mark word-end word-start) 1)
-	(if (test-char (next-character word-end) :scribe-syntax
-		       :close-paren)
-	    (with-mark ((command-start word-start :left-inserting)
-			(command-end word-end :left-inserting))
-	      ;; Move command-end from word-end to open-paren of command.
-	      (balance-paren (mark-after command-end))
-	      (if (funcall (value extend-scribe-directive-function)
-			   command-string command-end command-start word-start)
-		  (let ((region (delete-and-save-region
-				 (region command-start command-end))))
-		    (word-offset (move-mark word-start command-start) -1)
-		    (ninsert-region word-start region))
-		  (funcall (value insert-scribe-directive-function)
-			   word-start command-string open-paren-char
-			   word-end)))
-	    (funcall (value insert-scribe-directive-function)
-		     word-start command-string open-paren-char word-end)))
-	(t
-	 (funcall (value insert-scribe-directive-function)
-		  word-start command-string open-paren-char word-end)
-	 (mark-before mark))))))
-
-;;;
-;;; Inserting :environment directives.
-;;;
-
-(defun enclose-with-environment (mark &optional environment)
-  (if (region-active-p)
-      (let ((region (current-region)))
-	(with-mark ((top (region-start region) :left-inserting)
-		    (bottom (region-end region) :left-inserting))
-	  (get-and-insert-environment top bottom environment)))
-      (with-mark ((bottom-mark mark :left-inserting))
-	(let ((paragraphp (paragraph-offset bottom-mark 1)))
-	  (unless (or paragraphp
-		      (and (last-line-p bottom-mark)
-			   (end-line-p bottom-mark)
-			   (not (blank-line-p (mark-line bottom-mark)))))
-	    (editor-error "No paragraph to enclose."))
-	  (with-mark ((top-mark bottom-mark :left-inserting))
-	    (paragraph-offset top-mark -1)
-	    (cond ((not (blank-line-p (mark-line top-mark)))
-		   (insert-character top-mark #\Newline)
-		   (mark-before top-mark))
-		  (t
-		   (insert-character top-mark #\Newline)))
-	    (cond ((and (last-line-p bottom-mark)
-			(not (blank-line-p (mark-line bottom-mark))))
-		   (insert-character bottom-mark #\Newline))
-		  (t
-		   (insert-character bottom-mark #\Newline)
-		   (mark-before bottom-mark)))
-	    (get-and-insert-environment top-mark bottom-mark environment))))))
-
-(defun get-and-insert-environment (top-mark bottom-mark environment)
-  (let ((environment (or environment
-			 (prompt-for-string
-			  :trim t :prompt "Environment: "
-			  :help "Name of environment to enclose with."))))
-    (insert-environment top-mark "begin" environment)
-    (insert-environment bottom-mark "end" environment)))
-
-(defun insert-environment (mark command environment)
-  (let ((esc-char (value escape-character))
-	(open-paren (value open-paren-character))
-	(close-paren (value close-paren-character)))
-      (insert-character mark esc-char)
-      (insert-string mark command)
-      (insert-character mark open-paren)
-      (insert-string mark environment)
-      (insert-character mark close-paren)))
-
-
-(add-scribe-directive-command nil nil :Environment #k"Control-l" "Scribe")
-(add-scribe-directive-command nil nil :Command #k"Control-w" "Scribe")
-(add-scribe-directive-command nil "Begin" :Command #k"b" "Scribe")
-(add-scribe-directive-command nil "End" :Command #k"e" "Scribe")
-(add-scribe-directive-command nil "Center" :Environment #k"c" "Scribe")
-(add-scribe-directive-command nil "Description" :Environment #k"d" "Scribe")
-(add-scribe-directive-command nil "Display" :Environment #k"Control-d" "Scribe")
-(add-scribe-directive-command nil "Enumerate" :Environment #k"n" "Scribe")
-(add-scribe-directive-command nil "Example" :Environment #k"x" "Scribe")
-(add-scribe-directive-command nil "FileExample" :Environment #k"y" "Scribe")
-(add-scribe-directive-command nil "FlushLeft" :Environment #k"l" "Scribe")
-(add-scribe-directive-command nil "FlushRight" :Environment #k"r" "Scribe")
-(add-scribe-directive-command nil "Format" :Environment #k"f" "Scribe")
-(add-scribe-directive-command nil "Group" :Environment #k"g" "Scribe")
-(add-scribe-directive-command nil "Itemize" :Environment #k"Control-i" "Scribe")
-(add-scribe-directive-command nil "Multiple" :Environment #k"m" "Scribe")
-(add-scribe-directive-command nil "ProgramExample" :Environment #k"p" "Scribe")
-(add-scribe-directive-command nil "Quotation" :Environment #k"q" "Scribe")
-(add-scribe-directive-command nil "Text" :Environment #k"t" "Scribe")
-(add-scribe-directive-command nil "i" :Command #k"i" "Scribe")
-(add-scribe-directive-command nil "b" :Command #k"Control-b" "Scribe")
-(add-scribe-directive-command nil "-" :Command #k"\-" "Scribe")
-(add-scribe-directive-command nil "+" :Command #k"+" "Scribe")
-(add-scribe-directive-command nil "u" :Command #k"Control-j" "Scribe")
-(add-scribe-directive-command nil "p" :Command #k"Control-p" "Scribe")
-(add-scribe-directive-command nil "r" :Command #k"Control-r" "Scribe")
-(add-scribe-directive-command nil "t" :Command #k"Control-t" "Scribe")
-(add-scribe-directive-command nil "g" :Command #k"Control-a" "Scribe")
-(add-scribe-directive-command nil "un" :Command #k"Control-n" "Scribe")
-(add-scribe-directive-command nil "ux" :Command #k"Control-x" "Scribe")
-(add-scribe-directive-command nil "c" :Command #k"Control-k" "Scribe")
-
-
-
-;;;; Scribe paragraph delimiter function.
-
-(defhvar "Paragraph Delimiter Function"
-  "Scribe Mode's way of delimiting paragraphs."
-  :mode "Scribe" 
-  :value 'scribe-delim-para-function)
-
-(defun scribe-delim-para-function (mark)
-  "Returns whether there is a paragraph delimiting Scribe command on the
-   current line.  Add or remove commands for this purpose with the command
-   \"Add Scribe Paragraph Delimiter\"."
-  (let ((next-char (next-character mark)))
-    (when (paragraph-delimiter-attribute-p next-char)
-      (if (eq (character-attribute :scribe-syntax next-char) :escape)
-	  (with-mark ((begin mark)
-		      (end mark))
-	    (mark-after begin)
-	    (if (scan-char end :scribe-syntax (or :space :newline :open-paren))
-		(gethash (nstring-downcase (region-to-string (region begin end)))
-			 *scribe-para-break-table*)
-		(editor-error "Unable to find Scribe command ending.")))
-	  t))))
-
-
-
-;;;; Bracket matching.
-
-(defun scribe-insert-paren (mark bracket-char)
-  (insert-character mark bracket-char)
-  (with-mark ((m mark))
-    (if (balance-paren m)
-	(when (value paren-pause-period)
-	  (unless (show-mark m (current-window) (value paren-pause-period))
-	    (clear-echo-area)
-	    (message "~A" (line-string (mark-line m)))))
-	(editor-error))))
-
-;;; BALANCE-PAREN moves the mark to the matching open paren character, or
-;;; returns nil.  The mark must be after the closing paren.
-;;;
-(defun balance-paren (mark)
-  (with-mark ((m mark))
-    (when (rev-scan-char m :scribe-syntax (or :open-paren :close-paren))
-      (mark-before m)
-      (let ((paren-count 1)
-	    (first-paren (next-character m)))
-	(loop
-	  (unless (rev-scan-char m :scribe-syntax (or :open-paren :close-paren))
-	    (return nil))
-	  (if (test-char (previous-character m) :scribe-syntax :open-paren)
-	      (setq paren-count (1- paren-count))
-	      (setq paren-count (1+ paren-count)))
-	  (when (< paren-count 0) (return nil))
-	  (when (= paren-count 0) 
-	    ;; OPPOSING-BRACKET calls VALUE (each time around the loop)
-	    (cond ((char= (opposing-bracket (previous-character m)) first-paren)
-		   (mark-before (move-mark mark m))
-		   (return t))
-		  (t (editor-error "Scribe paren mismatch."))))
-	  (mark-before m))))))
diff --git a/hemlock/search1.lisp b/hemlock/search1.lisp
deleted file mode 100644
index 8a85603a9549af8113802a7a0014862c5df445ac..0000000000000000000000000000000000000000
--- a/hemlock/search1.lisp
+++ /dev/null
@@ -1,656 +0,0 @@
-;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/search1.lisp,v 1.1.1.4 1992/01/06 16:24:15 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Searching and replacing functions for Hemlock.
-;;; Originally written by Skef Wholey, Rewritten by Rob MacLachlan.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(search-pattern search-pattern-p find-pattern replace-pattern
-			 new-search-pattern))
-
-
-
-;;; The search pattern structure is used only by simple searches, more
-;;; complex ones make structures which include it.
-
-(defstruct (search-pattern (:print-function %print-search-pattern)
-			   (:constructor internal-make-search-pattern))
-  kind			      ; The kind of pattern to search for.
-  direction		      ; The direction to search in.
-  pattern		      ; The search pattern to use.
-  search-function	      ; The function to call to search.
-  reclaim-function)	      ; The function to call to reclaim this pattern.
-
-(setf (documentation 'search-pattern-p 'function)
-  "Returns true if its argument is a Hemlock search-pattern object,
-  Nil otherwise.")
-
-(defun %print-search-pattern (object stream depth)
-  (let ((*print-level* (and *print-level* (- *print-level* depth)))
-	(*print-case* :downcase))
-    (declare (special *print-level* *print-case*))
-    (write-string "#<Hemlock " stream)
-    (princ (search-pattern-direction object) stream)
-    (write-char #\space stream)
-    (princ (search-pattern-kind object) stream)
-    (write-string " Search-Pattern for ")
-    (prin1 (search-pattern-pattern object) stream)
-    (write-char #\> stream)
-    (terpri stream)))
-
-(defvar *search-pattern-experts* (make-hash-table :test #'eq)
-  "Holds an eq hashtable which associates search kinds with the functions
-  that know how to make patterns of that kind.")
-(defvar *search-pattern-documentation* ()
-  "A list of all the kinds of search-pattern that are defined.")
-
-;;; define-search-kind  --  Internal
-;;;
-;;;    This macro is used to define a new kind of search pattern.  Kind
-;;; is the kind of search pattern to define.  Lambda-list is the argument 
-;;; list for the expert-function to be built and forms it's body.
-;;; The arguments passed are the direction, the pattern, and either
-;;; an old search-pattern of the same type or nil.  Documentation
-;;; is put on the search-pattern-documentation property of the kind
-;;; keyword.
-;;;
-(defmacro define-search-kind (kind lambda-list documentation &body forms)
-  (let ((dummy (gensym)))
-    `(progn
-      (push ,documentation *search-pattern-documentation*)
-      (defun ,dummy ()
-	(setf (gethash ,kind *search-pattern-experts*)
-	      #'(lambda ,lambda-list ,@forms)))
-      (,dummy))))
-
-;;; new-search-pattern  --  Public
-;;;
-;;;    This function deallocates any old search-pattern and then dispatches
-;;; to the correct expert.
-;;;
-(defun new-search-pattern (kind direction pattern &optional
-				result-search-pattern)
-  "Makes a new Hemlock search pattern of kind Kind to search direction
-  using Pattern.  Direction is either :backward or :forward.
-  If supplied, result-search-pattern is a pattern to destroy to make
-  the new one.  The variable *search-pattern-documentation* contains
-  documentation for each kind."
-  (unless (or (eq direction :forward) (eq direction :backward))
-    (error "~S is not a legal search direction." direction))
-  (when result-search-pattern
-    (funcall (search-pattern-reclaim-function result-search-pattern)
-	     result-search-pattern)
-    (unless (eq kind (search-pattern-kind result-search-pattern))
-      (setq result-search-pattern nil)))
-  (let ((expert (gethash kind *search-pattern-experts*)))
-    (unless expert
-      (error "~S is not a defined search pattern kind." kind))
-    (funcall expert direction pattern result-search-pattern)))
-
-;;;; stuff to allocate and de-allocate simple-vectors search-char-code-limit
-;;;; in length.
-
-(defvar *spare-search-vectors* ())
-(eval-when (compile eval)
-(defmacro new-search-vector ()
-  `(if *spare-search-vectors*
-       (pop *spare-search-vectors*)
-       (make-array search-char-code-limit)))
-
-(defmacro dispose-search-vector (vec)
-  `(push ,vec *spare-search-vectors*))
-); eval-when (compile eval)
-
-;;;; macros used by various search kinds:
-
-;;; search-once-forward-macro  --  Internal
-;;;
-;;;    Passes search-fun strings, starts and lengths to do a forward
-;;; search.  The other-args are passed through to the searching
-;;; function after after everything else  The search-fun is
-;;; expected to return NIL if nothing is found, or it index where the
-;;; match ocurred.  Something non-nil is returned if something is
-;;; found and line and start are set to where it was found.
-;;;
-(defmacro search-once-forward-macro (line start search-fun &rest other-args)
-  `(do* ((l ,line)
-	 (chars (line-chars l) (line-chars l))
-	 (len (length chars) (length chars))
-	 (start-pos ,start 0)
-	 (index 0))
-	(())
-     (declare (simple-string chars) (fixnum start-pos len)
-	      (type (or fixnum null) index))
-     (setq index (,search-fun chars start-pos len ,@other-args))
-     (when index
-       (setq ,start index  ,line l)
-       (return t))
-     (setq l (line-next l))
-     (when (null l) (return nil))))
-
-
-;;; search-once-backward-macro  --  Internal
-;;;
-;;;    Like search-once-forward-macro, except it goes backwards.  Length
-;;; is not passed to the search function, since it won't need it.
-;;;
-(defmacro search-once-backward-macro (line start search-fun &rest other-args)
-  `(do* ((l ,line)
-	 (chars (line-chars l) (line-chars l))
-	 (start-pos (1- ,start) (1- (length chars)))
-	 (index 0))
-	(())
-     (declare (simple-string chars) (fixnum start-pos)
-	      (type (or fixnum null) index))
-     (setq index (,search-fun chars start-pos ,@other-args))
-     (when index
-       (setq ,start index  ,line l)
-       (return t))
-     (setq l (line-previous l))
-     (when (null l) (return nil))))
-
-
-;;;; String Searches.
-;;;
-;;; We use the Boyer-Moore algorithm for string searches.
-;;;
-
-;;; sensitive-string-search-macro  --  Internal
-;;;
-;;;    This macro does a case-sensitive Boyer-Moore string search.
-;;;
-;;; Args:
-;;;    String - The string to search in.
-;;;    Start - The place to start searching at.
-;;;    Length - NIL if going backward, the length of String if going forward.
-;;;    Pattern - A simple-vector of characters.  A simple-vector is used 
-;;; rather than a string because it is believed that simple-vector access
-;;; will be faster in most implementations.
-;;;    Patlen - The length of Pattern.
-;;;    Last - (1- Patlen)
-;;;    Jumps - The jump vector as given by compute-boyer-moore-jumps
-;;;    +/- - The function to increment with, either + (forward) or -
-;;; (backward)
-;;;    -/+ - Like +/-, only the other way around.
-(eval-when (compile eval)
-(defmacro sensitive-string-search-macro (string start length pattern patlen
-						last jumps +/- -/+)
-  `(do ((scan (,+/- ,start ,last))
-	(patp ,last))
-       (,(if length `(>= scan ,length) '(minusp scan)))
-     (declare (fixnum scan patp))
-     (let ((char (schar ,string scan)))
-       (cond
-	((char= char (svref ,pattern patp))
-	 (if (zerop patp)
-	     (return scan)
-	     (setq scan (,-/+ scan 1)  patp (1- patp))))
-	(t
-	 ;; If mismatch consult jump table to find amount to skip.
-	 (let ((jump (svref ,jumps (search-char-code char))))
-	   (declare (fixnum jump))
-	   (if (> jump (- ,patlen patp))
-	       (setq scan (,+/- scan jump))
-	       (setq scan (,+/- scan (- ,patlen patp)))))
-	 (setq patp ,last))))))
-
-;;; insensitive-string-search-macro  --  Internal
-;;;
-;;;    This macro is very similar to the case sensitive one, except that
-;;; we do the search for a hashed string, and then when we find a match
-;;; we compare the uppercased search string with the found string uppercased
-;;; and only say we win when they match too.
-;;;
-(defmacro insensitive-string-search-macro (string start length pattern
-						  folded-string patlen last
-						  jumps  +/- -/+)
-  `(do ((scan (,+/- ,start ,last))
-	(patp ,last))
-       (,(if length `(>= scan ,length) '(minusp scan)))
-     (declare (fixnum scan patp))
-     (let ((hash (search-hash-code (schar ,string scan))))
-       (declare (fixnum hash))
-       (cond
-	((= hash (the fixnum (svref ,pattern patp)))
-	 (if (zerop patp)
-	     (if (do ((i ,last (1- i)))
-		     (())
-		   (when (char/=
-			  (search-char-upcase (schar ,string (,+/- scan i)))
-			  (schar ,folded-string i))
-		     (return nil))
-		   (when (zerop i) (return t)))
-		 (return scan)
-		 (setq scan (,+/- scan ,patlen)  patp ,last))
-	     (setq scan (,-/+ scan 1)  patp (1- patp))))
-	(t
-	 ;; If mismatch consult jump table to find amount to skip.
-	 (let ((jump (svref ,jumps hash)))
-	   (declare (fixnum jump))
-	   (if (> jump (- ,patlen patp))
-	       (setq scan (,+/- scan jump))
-	       (setq scan (,+/- scan (- ,patlen patp)))))
-	 (setq patp ,last))))))
-
-;;;; Searching for strings with newlines in them:
-;;;
-;;;    Due to the buffer representation, search-strings with embedded 
-;;; newlines need to be special-cased.  What we do is break
-;;; the search string up into lines and then searching for a line with
-;;; the correct prefix.  This is actually a faster search.
-;;; For this one we just have one big hairy macro conditionalized for
-;;; both case-sensitivity and direction.  Have fun!!
-
-;;; newline-search-macro  --  Internal
-;;;
-;;;    Do a search for a string containing newlines.  Line is the line
-;;; to start on, and Start is the position to start at.  Pattern and
-;;; optionally Pattern2, are simple-vectors of things that represent
-;;; each line in the pattern, and are passed to Test-Fun.  Pattern
-;;; must contain simple-strings so we can take the length.  Test-Fun is a
-;;; thing to compare two strings and see if they are equal.  Forward-p
-;;; tells whether to go forward or backward.
-;;;
-(defmacro newline-search-macro (line start test-fun pattern forward-p
-				     &optional pattern2)
-  `(let* ((patlen (length ,pattern))
-	  (first (svref ,pattern 0))
-	  (firstlen (length first))
-	  (l ,line)
-	  (chars (line-chars l))
-	  (len (length chars))
-	  ,@(if pattern2 `((other (svref ,pattern2 0)))))
-     (declare (simple-string first chars) (fixnum firstlen patlen len))
-     ,(if forward-p
-	  ;; If doing a forward search, go to the next line if we could not
-	  ;; match due to the start position.
-	  `(when (< (- len ,start) firstlen)
-	     (setq l (line-next l)))
-	  ;; If doing a backward search, go to the previous line if the current
-	  ;; line could not match the last line in the pattern, and then go
-	  ;; back the 1- number of lines in the pattern to avoid a possible
-	  ;; match across the starting point.
-	  `(let ((1-len (1- patlen)))
-	     (declare (fixnum 1-len))
-	     (when (< ,start (length (the simple-string
-					  (svref ,pattern 1-len))))
-	       (setq l (line-previous l)))
-	     (dotimes (i 1-len)
-	       (when (null l) (return nil))
-	       (setq l (line-previous l)))))
-     (do* ()
-	  ((null l))
-       (setq chars (line-chars l)  len (length chars))
-       ;; If the end of this line is the first line in the pattern then check
-       ;; to see if the other lines match.
-       (when (and (>= len firstlen)
-		  (,test-fun chars first other
-			     :start1 (- len firstlen) :end1 len
-			     :end2 firstlen))
-	 (when
-	  (do ((m (line-next l) (line-next m))
-	       (i 2 (1+ i))
-	       (next (svref ,pattern 1) (svref ,pattern i))
-	       ,@(if pattern2
-		     `((another (svref ,pattern2 1)
-				(svref ,pattern2 i))))
-	       (len 0)
-	       (nextlen 0)
-	       (chars ""))
-	      ((null m))
-	    (declare (simple-string next chars) (fixnum len nextlen i))
-	    (setq chars (line-chars m)  nextlen (length next)
-		  len (length chars))
-	    ;; When on last line of pattern, check if prefix of line.
-	    (when (= i patlen)
-	      (return (and (>= len nextlen)
-			   (,test-fun chars next another :end1 nextlen
-				      :end2 nextlen))))
-	    (unless (,test-fun chars next another :end1 len
-			       :end2 nextlen)
-	      (return nil)))
-	  (setq ,line l  ,start (- len firstlen))
-	  (return t)))
-       ;; If not, try the next line
-       (setq l ,(if forward-p '(line-next l) '(line-previous l))))))
-
-;;;; String-comparison macros that are passed to newline-search-macro
-
-;;; case-sensitive-test-fun  --  Internal
-;;;
-;;;    Just thows away the extra arg and calls string=.
-;;;
-(defmacro case-sensitive-test-fun (string1 string2 ignore &rest keys)
-  (declare (ignore ignore))
-  `(string= ,string1 ,string2 ,@keys))
-
-;;; case-insensitive-test-fun  --  Internal
-;;;
-;;;    First compare the characters hashed with hashed-string2 and then
-;;; only if they agree do an actual compare with case-folding.
-;;;
-(defmacro case-insensitive-test-fun (string1 string2 hashed-string2
-					     &key end1 (start1 0) end2)
-  `(when (= (- ,end1 ,start1) ,end2)
-     (do ((i 0 (1+ i)))
-	 ((= i ,end2)
-	  (dotimes (i ,end2 t)
-	    (when (char/= (search-char-upcase (schar ,string1 (+ ,start1 i)))
-			  (schar ,string2 i))
-	      (return nil))))
-       (when (/= (search-hash-code (schar ,string1 (+ ,start1 i)))
-		 (svref ,hashed-string2 i))
-	 (return nil)))))
-); eval-when (compile eval)
-
-;;; compute-boyer-moore-jumps  --  Internal
-;;;
-;;;    Compute return a jump-vector to do a Boyer-Moore search for 
-;;; the "string" of things in Vector.  Access-fun is a function
-;;; that aref's vector and returns a number.
-;;;
-(defun compute-boyer-moore-jumps (vec access-fun)
-  (declare (simple-vector vec))
-  (let ((jumps (new-search-vector))
-	(len (length vec)))
-    (declare (simple-vector jumps))
-    (when (zerop len) (error "Zero length search string not allowed."))
-    ;; The default jump is the length of the search string.
-    (dotimes (i search-char-code-limit)
-      (setf (aref jumps i) len))
-    ;; For chars in the string the jump is the distance from the end.
-    (dotimes (i len)
-      (setf (aref jumps (funcall access-fun vec i)) (- len i 1)))
-    jumps))
-
-;;;; Case insensitive searches
-
-;;; In order to avoid case folding, we do a case-insensitive hash of
-;;; each character.  We then search for string in this translated
-;;; character set, and reject false successes by checking of the found
-;;; string is string-equal the the original search string.
-;;;
-
-(defstruct (string-insensitive-search-pattern
-	    (:include search-pattern)
-	    (:conc-name string-insensitive-)
-	    (:print-function %print-search-pattern))
-  jumps
-  hashed-string
-  folded-string)
-
-;;;  Search-Hash-String  --  Internal
-;;;
-;;;    Return a simple-vector containing the search-hash-codes of the
-;;; characters in String.
-;;;
-(defun search-hash-string (string)
-  (declare (simple-string string))
-  (let* ((len (length string))
-	 (result (make-array len)))
-    (declare (fixnum len) (simple-vector result))
-    (dotimes (i len result)
-      (setf (aref result i) (search-hash-code (schar string i))))))
-
-;;; make-insensitive-newline-pattern  -- Internal
-;;;
-;;;    Make bash in fields in a string-insensitive-search-pattern to
-;;; do a search for a string with newlines in it.
-;;;
-(defun make-insensitive-newline-pattern (pattern folded-string)
-  (declare (simple-string folded-string))
-  (let* ((len (length folded-string))
-	 (num (1+ (count #\newline folded-string :end len)))
-	 (hashed (make-array num))
-	 (folded (make-array num)))
-    (declare (simple-vector hashed folded) (fixnum len num))
-    (do ((prev 0 nl)
-	 (i 0 (1+ i))
-	 (nl (position #\newline folded-string :end len)
-	     (position #\newline folded-string :start nl  :end len)))
-	((null nl)
-	 (let ((piece (subseq folded-string prev len)))
-	   (setf (aref folded i) piece)
-	   (setf (aref hashed i) (search-hash-string piece))))
-      (let ((piece (subseq folded-string prev nl)))
-	(setf (aref folded i) piece)
-	(setf (aref hashed i) (search-hash-string piece)))
-      (incf nl))
-    (setf (string-insensitive-folded-string pattern) folded
-	  (string-insensitive-hashed-string pattern) hashed)))
-
-(define-search-kind :string-insensitive (direction pattern old)
-  ":string-insensitive - Pattern is a string to do a case-insensitive
-  search for."
-  (unless old (setq old (make-string-insensitive-search-pattern)))
-  (setf (search-pattern-kind old) :string-insensitive
-	(search-pattern-direction old) direction
-	(search-pattern-pattern old) pattern)
-  (let* ((folded-string (string-upcase pattern)))
-    (declare (simple-string folded-string))
-    (cond
-     ((find #\newline folded-string)
-      (make-insensitive-newline-pattern old folded-string)
-      (setf (search-pattern-search-function old)
-	    (if (eq direction :forward)
-		#'insensitive-find-newline-once-forward-method
-		#'insensitive-find-newline-once-backward-method))
-      (setf (search-pattern-reclaim-function old) #'identity))
-     (t
-      (case direction
-	(:forward
-	 (setf (search-pattern-search-function old)
-	       #'insensitive-find-string-once-forward-method))
-	(t
-	 (setf (search-pattern-search-function old)
-	       #'insensitive-find-string-once-backward-method)
-	 (nreverse folded-string)))
-      (let ((hashed-string (search-hash-string folded-string)))
-	(setf (string-insensitive-hashed-string old) hashed-string
-	      (string-insensitive-folded-string old) folded-string)
-	(setf (string-insensitive-jumps old)
-	      (compute-boyer-moore-jumps hashed-string #'svref))
-	(setf (search-pattern-reclaim-function old)
-	      #'(lambda (p)
-		  (dispose-search-vector (string-insensitive-jumps p))))))))
-  old)
-
-(defun insensitive-find-string-once-forward-method (pattern line start)
-  (let* ((hashed-string (string-insensitive-hashed-string pattern))
-	 (folded-string (string-insensitive-folded-string pattern))
-	 (jumps (string-insensitive-jumps pattern))
-	 (patlen (length hashed-string))
-	 (last (1- patlen)))
-    (declare (simple-vector jumps hashed-string) (simple-string folded-string)
-	     (fixnum patlen last))
-    (when (search-once-forward-macro
-	   line start insensitive-string-search-macro
-	   hashed-string folded-string patlen last jumps + -)
-      (values line start patlen))))
-
-(defun insensitive-find-string-once-backward-method (pattern line start)
-  (let* ((hashed-string (string-insensitive-hashed-string pattern))
-	 (folded-string (string-insensitive-folded-string pattern))
-	 (jumps (string-insensitive-jumps pattern))
-	 (patlen (length hashed-string))
-	 (last (1- patlen)))
-    (declare (simple-vector jumps hashed-string) (simple-string folded-string)
-	     (fixnum patlen last))
-    (when (search-once-backward-macro
-	   line start insensitive-string-search-macro
-	   nil hashed-string folded-string patlen last jumps - +)
-      (values line (- start last) patlen))))
-
-(eval-when (compile eval)
-(defmacro def-insensitive-newline-search-method (name direction)
-  `(defun ,name (pattern line start)
-     (let* ((hashed (string-insensitive-hashed-string pattern))
-	    (folded-string (string-insensitive-folded-string pattern))
-	    (patlen (length (the string (search-pattern-pattern pattern)))))
-       (declare (simple-vector hashed folded-string))
-       (when (newline-search-macro line start case-insensitive-test-fun
-				   folded-string ,direction hashed)
-	 (values line start patlen)))))
-); eval-when (compile eval)
-
-(def-insensitive-newline-search-method
-  insensitive-find-newline-once-forward-method t)
-(def-insensitive-newline-search-method
-  insensitive-find-newline-once-backward-method nil)
-
-;;;; And Snore, case sensitive.
-;;;
-;;;    This is horribly repetitive, but if I introduce another level of
-;;; macroexpansion I will go Insaaaane....
-;;;
-(defstruct (string-sensitive-search-pattern
-	    (:include search-pattern)
-	    (:conc-name string-sensitive-)
-	    (:print-function %print-search-pattern))
-  string
-  jumps)
-
-;;; make-sensitive-newline-pattern  -- Internal
-;;;
-;;;    The same, only more sensitive (it hurts when you do that...)
-;;;
-(defun make-sensitive-newline-pattern (pattern string)
-  (declare (simple-vector string))
-  (let* ((string (coerce string 'simple-string))
-	 (len (length string))
-	 (num (1+ (count #\newline string :end len)))
-	 (sliced (make-array num)))
-    (declare (simple-string string) (simple-vector sliced) (fixnum len num))
-    (do ((prev 0 nl)
-	 (i 0 (1+ i))
-	 (nl (position #\newline string :end len)
-	     (position #\newline string :start nl  :end len)))
-	((null nl)
-	 (setf (aref sliced i) (subseq string prev len)))
-      (setf (aref sliced i) (subseq string prev nl))
-      (incf nl))
-    (setf (string-sensitive-string pattern) sliced)))
-
-(define-search-kind :string-sensitive (direction pattern old)
-  ":string-sensitive - Pattern is a string to do a case-sensitive
-  search for."
-  (unless old (setq old (make-string-sensitive-search-pattern)))
-  (setf (search-pattern-kind old) :string-sensitive
-	(search-pattern-direction old) direction
-	(search-pattern-pattern old) pattern)
-  (let* ((string (coerce pattern 'simple-vector)))
-    (declare (simple-vector string))
-    (cond
-     ((find #\newline string)
-      (make-sensitive-newline-pattern old string)
-      (setf (search-pattern-search-function old)
-	    (if (eq direction :forward)
-		#'sensitive-find-newline-once-forward-method
-		#'sensitive-find-newline-once-backward-method))
-      (setf (search-pattern-reclaim-function old) #'identity))
-     (t
-      (case direction
-	(:forward
-	 (setf (search-pattern-search-function old)
-	       #'sensitive-find-string-once-forward-method))
-	(t
-	 (setf (search-pattern-search-function old)
-	       #'sensitive-find-string-once-backward-method)
-	 (nreverse string)))
-      (setf (string-sensitive-string old) string)
-      (setf (string-sensitive-jumps old)
-	    (compute-boyer-moore-jumps
-	     string #'(lambda (v i) (char-code (svref v i)))))
-      (setf (search-pattern-reclaim-function old)
-	    #'(lambda (p)
-		(dispose-search-vector (string-sensitive-jumps p)))))))
-  old)
-
-(defun sensitive-find-string-once-forward-method (pattern line start)
-  (let* ((string (string-sensitive-string pattern))
-	 (jumps (string-sensitive-jumps pattern))
-	 (patlen (length string))
-	 (last (1- patlen)))
-    (declare (simple-vector jumps string) (fixnum patlen last))
-    (when (search-once-forward-macro
-	   line start sensitive-string-search-macro
-	   string patlen last jumps + -)
-      (values line start patlen))))
-
-(defun sensitive-find-string-once-backward-method (pattern line start)
-  (let* ((string (string-sensitive-string pattern))
-	 (jumps (string-sensitive-jumps pattern))
-	 (patlen (length string))
-	 (last (1- patlen)))
-    (declare (simple-vector jumps string) (fixnum patlen last))
-    (when (search-once-backward-macro
-	   line start sensitive-string-search-macro
-	   nil string patlen last jumps - +)
-      (values line (- start last) patlen))))
-
-(eval-when (compile eval)
-(defmacro def-sensitive-newline-search-method (name direction)
-  `(defun ,name (pattern line start)
-     (let* ((string (string-sensitive-string pattern))
-	    (patlen (length (the string (search-pattern-pattern pattern)))))
-       (declare (simple-vector string))
-       (when (newline-search-macro line start case-sensitive-test-fun
-				   string ,direction)
-	 (values line start patlen)))))
-); eval-when (compile eval)
-
-(def-sensitive-newline-search-method
-  sensitive-find-newline-once-forward-method t)
-(def-sensitive-newline-search-method
-  sensitive-find-newline-once-backward-method nil)
-
-(defun find-pattern (mark search-pattern)
-  "Find a match of Search-Pattern starting at Mark.  Mark is moved to
-  point before the match and the number of characters matched is returned.
-  If there is no match for the pattern then Mark is not modified and NIL
-  is returned."
-  (close-line)
-  (multiple-value-bind (line start matched)
-		       (funcall (search-pattern-search-function search-pattern)
-				search-pattern (mark-line mark)
-				(mark-charpos mark))
-    (when matched
-      (move-to-position mark start line)
-      matched)))
-
-;;; replace-pattern  --  Public
-;;;
-;;;
-(defun replace-pattern (mark search-pattern replacement &optional n)
-  "Replaces N occurrences of the Search-Pattern with the Replacement string
-  in the text starting at the given Mark.  If N is Nil, all occurrences 
-  following the Mark are replaced."
-  (close-line)
-  (do* ((replacement (coerce replacement 'simple-string))
-	(new (length (the simple-string replacement)))
-	(fun (search-pattern-search-function search-pattern))
-	(forward-p (eq (search-pattern-direction search-pattern) :forward))
-	(n (if n (1- n) -1) (1- n))
-	(m (copy-mark mark :temporary)) line start matched)
-       (())
-    (multiple-value-setq (line start matched)
-      (funcall fun search-pattern (mark-line m) (mark-charpos m)))
-    (unless matched (return m))
-    (setf (mark-line m) line  (mark-charpos m) start)
-    (delete-characters m matched)
-    (insert-string m replacement)
-    (when forward-p (character-offset m new))
-    (when (zerop n) (return m))
-    (close-line)))
diff --git a/hemlock/search2.lisp b/hemlock/search2.lisp
deleted file mode 100644
index bd03fde586f44aba5bf639f417cab6af47b1bf88..0000000000000000000000000000000000000000
--- a/hemlock/search2.lisp
+++ /dev/null
@@ -1,207 +0,0 @@
-;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/search2.lisp,v 1.2 1991/02/08 16:37:33 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;     More searching function for Hemlock.  This file contains the stuff
-;;; to implement the various kinds of character searches.
-;;;
-;;;    Written by Rob MacLachlan
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-;;;; Character and Not-Character search kinds:
-
-(eval-when (compile eval)
-(defmacro forward-character-search-macro (string start length char test)
-  `(position ,char ,string  :start ,start  :end ,length  :test ,test))
-
-(defmacro backward-character-search-macro (string start char test)
-  `(position ,char ,string  :end (1+ ,start)  :test ,test  :from-end t))
-
-(defmacro define-character-search-method (name search macro test)
-  `(defun ,name (pattern line start)
-     (let ((char (search-pattern-pattern pattern)))
-       (when (,search line start ,macro char ,test)
-	 (values line start 1)))))
-); eval-when (compile eval)
-
-(define-character-search-method find-character-once-forward-method
-  search-once-forward-macro forward-character-search-macro #'char=)
-(define-character-search-method find-not-character-once-forward-method
-  search-once-forward-macro forward-character-search-macro #'char/=)
-(define-character-search-method find-character-once-backward-method
-  search-once-backward-macro backward-character-search-macro #'char=)
-(define-character-search-method find-not-character-once-backward-method
-  search-once-backward-macro backward-character-search-macro #'char/=)
-
-(define-search-kind :character (direction pattern old)
-  ":character - Pattern is a character to search for."
-  (unless old (setq old (internal-make-search-pattern)))
-  (setf (search-pattern-kind old) :character
-	(search-pattern-direction old) direction
-	(search-pattern-pattern old) pattern
-	(search-pattern-reclaim-function old) #'identity
-	(search-pattern-search-function old)
-	(if (eq direction :forward)
-	    #'find-character-once-forward-method
-	    #'find-character-once-backward-method))
-  old)
-
-(define-search-kind :not-character (direction pattern old)
-  ":not-character - Find the first character which is not Char= to Pattern."
-  (unless old (setq old (internal-make-search-pattern)))
-  (setf (search-pattern-kind old) :not-character
-	(search-pattern-direction old) direction
-	(search-pattern-pattern old) pattern
-	(search-pattern-reclaim-function old) #'identity
-	(search-pattern-search-function old)
-	(if (eq direction :forward)
-	    #'find-not-character-once-forward-method
-	    #'find-not-character-once-backward-method))
-  old)
-
-;;;; Character set searching.
-;;;
-;;;    These functions implement the :test, :test-not, :any and :not-any
-;;; search-kinds.
-
-;;; The Character-Set abstraction is used to hide somewhat the fact that
-;;; we are using %Sp-Find-Character-With-Attribute to implement the
-;;; character set searches.
-
-(defvar *free-character-sets* ()
-  "A list of unused character-set objects for use by the Hemlock searching
-  primitives.")
-
-;;; Create-Character-Set  --  Internal
-;;;
-;;;    Create-Character-Set returns a character-set which will search
-;;; for no character.
-;;;
-(defun create-character-set ()
-  (let ((set (or (pop *free-character-sets*)
-		 (make-array 256 :element-type '(mod 256)))))
-    (declare (type (simple-array (mod 256)) set))
-    (dotimes (i search-char-code-limit)
-      (setf (aref set i) 0))
-    set))
-
-;;; Add-Character-To-Set  --  Internal
-;;;
-;;;    Modify the character-set Set to succeed for Character.
-;;;
-(proclaim '(inline add-character-to-set))
-(defun add-character-to-set (character set)
-  (setf (aref (the (simple-array (mod 256)) set)
-	      (search-char-code character))
-	1))
-
-;;; Release-Character-Set  --  Internal
-;;;
-;;;    Release the storage for the character set Set.
-;;;
-(defun release-character-set (set)
-  (push set *free-character-sets*))
-
-(eval-when (compile eval)
-;;; Forward-Set-Search-Macro  --  Internal
-;;;
-;;;    Do a search for some character in Set in String starting at Start
-;;; and ending at End.
-;;;
-(defmacro forward-set-search-macro (string start last set)
-  `(%sp-find-character-with-attribute ,string ,start ,last ,set 1))
-
-;;; Backward-Set-Search-Macro  --  Internal
-;;;
-;;;    Like forward-set-search-macro, only :from-end, and start is
-;;; implicitly 0.
-;;;
-(defmacro backward-set-search-macro (string last set)
-  `(%sp-reverse-find-character-with-attribute ,string 0 (1+ ,last) ,set 1))
-); eval-when (compile eval)
-
-(defstruct (set-search-pattern
-	    (:include search-pattern)
-	    (:print-function %print-search-pattern))
-  set)
-
-(eval-when (compile eval)
-(defmacro define-set-search-method (name search macro)
-  `(defun ,name (pattern line start)
-     (let ((set (set-search-pattern-set pattern)))
-       (when (,search line start ,macro set)
-	 (values line start 1)))))
-); eval-when (compile eval)
-
-(define-set-search-method find-set-once-forward-method
-  search-once-forward-macro forward-set-search-macro)
-
-(define-set-search-method find-set-once-backward-method
-  search-once-backward-macro backward-set-search-macro)
-
-(defun frob-character-set (pattern direction old kind)
-  (unless old (setq old (make-set-search-pattern)))
-  (setf (search-pattern-kind old) kind
-	(search-pattern-direction old) direction
-	(search-pattern-pattern old) pattern
-	(search-pattern-search-function old)
-	(if (eq direction :forward)
-	    #'find-set-once-forward-method
-	    #'find-set-once-backward-method)
-	(search-pattern-reclaim-function old)
-	#'(lambda (x) (release-character-set (set-search-pattern-set x))))
-  old)
-
-(define-search-kind :test (direction pattern old)
-  ":test - Find the first character which satisfies the test function Pattern.
-  Pattern must be a function of its argument only."
-  (setq old (frob-character-set pattern direction old :test))
-  (let ((set (create-character-set)))
-    (dotimes (i search-char-code-limit)
-      (when (funcall pattern (code-char i))
-	(add-character-to-set (code-char i) set)))
-    (setf (set-search-pattern-set old) set))
-  old)
-
-(define-search-kind :test-not (direction pattern old)
-  ":test-not - Find the first character which does not satisfy the
-  test function Pattern.  Pattern must be a function of its argument only."
-  (setq old (frob-character-set pattern direction old :test-not))
-  (let ((set (create-character-set)))
-    (dotimes (i search-char-code-limit)
-      (unless (funcall pattern (code-char i))
-	(add-character-to-set (code-char i) set)))
-    (setf (set-search-pattern-set old) set))
-  old)
-
-(define-search-kind :any (direction pattern old)
-  ":any - Find the first character which is the string Pattern."
-  (declare (string pattern))
-  (setq old (frob-character-set pattern direction old :any))
-  (let ((set (create-character-set)))
-    (dotimes (i (length pattern))
-      (add-character-to-set (char pattern i) set))
-    (setf (set-search-pattern-set old) set))
-  old)
-
-(define-search-kind :not-any (direction pattern old)
-  ":not-any - Find the first character which is not in the string Pattern."
-  (declare (string pattern))
-  (setq old (frob-character-set pattern direction old :not-any))
-  (let ((set (create-character-set)))
-    (dotimes (i search-char-code-limit)
-      (unless (find (code-char i) pattern)
-	(add-character-to-set (code-char i) set)))
-    (setf (set-search-pattern-set old) set))
-  old)
diff --git a/hemlock/searchcoms.lisp b/hemlock/searchcoms.lisp
deleted file mode 100644
index 03605599031ab1780ea462766d55a654cd038354..0000000000000000000000000000000000000000
--- a/hemlock/searchcoms.lisp
+++ /dev/null
@@ -1,643 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/searchcoms.lisp,v 1.3 1991/02/08 16:37:35 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains searching and replacing commands.
-;;;
-
-(in-package "HEMLOCK")
-
-
-
-;;;; Some global state.
-
-(defvar *last-search-string* () "Last string searched for.")
-(defvar *last-search-pattern*
-  (new-search-pattern :string-insensitive :forward "Foo")
-  "Search pattern we keep around so we don't cons them all the time.")
-
-(defhvar "String Search Ignore Case"
-  "When set, string searching commands use case insensitive."
-  :value t)
-
-(defun get-search-pattern (string direction)
-  (declare (simple-string string))
-  (when (zerop (length string)) (editor-error))
-  (setq *last-search-string* string)
-  (setq *last-search-pattern*
-	(new-search-pattern (if (value string-search-ignore-case)
-				:string-insensitive
-				:string-sensitive)
-			    direction string *last-search-pattern*)))
-
-
-
-;;;; Vanilla searching.
-
-(defcommand "Forward Search" (p &optional string)
-  "Do a forward search for a string.
-  Prompt for the string and leave the point after where it is found."
-  "Searches for the specified String in the current buffer."
-  (declare (ignore p))
-  (if (not string)
-      (setq string (prompt-for-string :prompt "Search: "
-				      :default *last-search-string*
-				      :help "String to search for")))
-  (let* ((pattern (get-search-pattern string :forward))
-	 (point (current-point))
-	 (mark (copy-mark point))
-	 (won (find-pattern point pattern)))
-    (cond (won (character-offset point won)
-	       (if (region-active-p)
-		   (delete-mark mark)
-		   (push-buffer-mark mark)))
-	  (t (delete-mark mark)
-	     (editor-error)))))
-
-(defcommand "Reverse Search" (p &optional string)
-  "Do a backward search for a string.
-  Prompt for the string and leave the point before where it is found."
-  "Searches backwards for the specified String in the current buffer."
-  (declare (ignore p))
-  (if (not string)
-      (setq string (prompt-for-string :prompt "Reverse Search: "
-				      :default *last-search-string* 
-				      :help "String to search for")))
-  (let* ((pattern (get-search-pattern string :backward))
-	 (point (current-point))
-	 (mark (copy-mark point))
-	 (won (find-pattern point pattern)))
-    (cond (won (if (region-active-p)
-		   (delete-mark mark)
-		   (push-buffer-mark mark)))
-	  (t (delete-mark mark)
-	     (editor-error)))))
-
-
-
-;;;; Incremental searching.
-
-(defun i-search-pattern (string direction)
-  (setq *last-search-pattern*
-	(new-search-pattern (if (value string-search-ignore-case)
-				:string-insensitive
-				:string-sensitive)
-			    direction string *last-search-pattern*)))
-
-;;;      %I-SEARCH-ECHO-REFRESH refreshes the echo buffer for incremental
-;;; search.
-;;;
-(defun %i-search-echo-refresh (string direction failure)
-  (when (interactive)
-    (clear-echo-area)
-    (format *echo-area-stream* 
-	    "~:[~;Failing ~]~:[Reverse I-Search~;I-Search~]: ~A"
-	    failure (eq direction :forward) string)))
-
-(defcommand "Incremental Search" (p)
-  "Searches for input string as characters are provided.
-  These are the default I-Search command characters:  ^Q quotes the
-  next character typed.  Backspace cancels the last character typed.  ^S
-  repeats forward, and ^R repeats backward.  ^R or ^S with empty string
-  either changes the direction or yanks the previous search string.
-  Altmode exits the search unless the string is empty.  Altmode with 
-  an empty search string calls the non-incremental search command.  
-  Other control characters cause exit and execution of the appropriate 
-  command.  If the search fails at some point, ^G and backspace may be 
-  used to backup to a non-failing point; also, ^S and ^R may be used to
-  look the other way.  ^G during a successful search aborts and returns
-  point to where it started."
-  "Search for input string as characters are typed in.
-  It sets up for the recursive searching and checks return values."
-  (declare (ignore p))
-  (setf (last-command-type) nil)
-  (%i-search-echo-refresh "" :forward nil)
-  (let* ((point (current-point))
-	 (save-start (copy-mark point :temporary)))
-    (with-mark ((here point))
-      (when (eq (catch 'exit-i-search
-		  (%i-search "" point here :forward nil))
-		:control-g)
-	(move-mark point save-start)
-	(invoke-hook abort-hook)
-	(editor-error))
-      (if (region-active-p)
-	  (delete-mark save-start)
-	  (push-buffer-mark save-start)))))
-
-
-(defcommand "Reverse Incremental Search" (p)
-  "Searches for input string as characters are provided.
-  These are the default I-Search command characters:  ^Q quotes the
-  next character typed.  Backspace cancels the last character typed.  ^S
-  repeats forward, and ^R repeats backward.  ^R or ^S with empty string
-  either changes the direction or yanks the previous search string.
-  Altmode exits the search unless the string is empty.  Altmode with 
-  an empty search string calls the non-incremental search command.  
-  Other control characters cause exit and execution of the appropriate 
-  command.  If the search fails at some point, ^G and backspace may be 
-  used to backup to a non-failing point; also, ^S and ^R may be used to
-  look the other way.  ^G during a successful search aborts and returns
-  point to where it started."
-  "Search for input string as characters are typed in.
-  It sets up for the recursive searching and checks return values."
-  (declare (ignore p))
-  (setf (last-command-type) nil)
-  (%i-search-echo-refresh "" :backward nil)
-  (let* ((point (current-point))
-	 (save-start (copy-mark point :temporary)))
-    (with-mark ((here point))
-      (when (eq (catch 'exit-i-search
-		  (%i-search "" point here :backward nil))
-		:control-g)
-	(move-mark point save-start)
-	(invoke-hook abort-hook)
-	(editor-error))
-      (if (region-active-p)
-	  (delete-mark save-start)
-	  (push-buffer-mark save-start)))))
-
-;;;      %I-SEARCH recursively (with support functions) searches to provide
-;;; incremental searching.  There is a loop in case the recursion is ever
-;;; unwound to some call.  curr-point must be saved since point is clobbered
-;;; with each recursive call, and the point must be moved back before a
-;;; different letter may be typed at a given call.  In the CASE at :cancel
-;;; and :control-g, if the string is not null, an accurate pattern for this
-;;; call must be provided when %I-SEARCH-CHAR-EVAL is called a second time
-;;; since it is possible for ^S or ^R to be typed.
-;;;
-(defun %i-search (string point trailer direction failure)
-  (do* ((curr-point (copy-mark point :temporary))
-	(curr-trailer (copy-mark trailer :temporary)))
-       (nil)
-    (let ((next-key-event (get-key-event *editor-input* t)))
-      (case (%i-search-char-eval next-key-event string point trailer
-				 direction failure)
-	(:cancel
-	 (%i-search-echo-refresh string direction failure)
-	 (unless (zerop (length string))
-	   (i-search-pattern string direction)))
-	(:return-cancel
-	 (unless (zerop (length string)) (return :cancel))
-	 (beep))
-	(:control-g
-	 (when failure (return :control-g))
-	 (%i-search-echo-refresh string direction nil)
-	 (unless (zerop (length string))
-	   (i-search-pattern string direction))))
-      (move-mark point curr-point)
-      (move-mark trailer curr-trailer))))
-
-;;;      %I-SEARCH-CHAR-EVAL evaluates the last character typed and takes
-;;; necessary actions.
-;;;
-(defun %i-search-char-eval (key-event string point trailer direction failure)
-  (declare (simple-string string))
-  (cond ((let ((character (key-event-char key-event)))
-	   (and character (standard-char-p character)))
-	 (%i-search-printed-char key-event string point trailer
-				 direction failure))
-	((or (logical-key-event-p key-event :forward-search)
-	     (logical-key-event-p key-event :backward-search))
-	 (%i-search-control-s-or-r key-event string point trailer
-				   direction failure))
-	((logical-key-event-p key-event :cancel) :return-cancel)
-	((logical-key-event-p key-event :abort)
-	 (unless failure
-	   (clear-echo-area)
-	   (message "Search aborted.")
-	   (throw 'exit-i-search :control-g))
-	 :control-g)
-	((logical-key-event-p key-event :quote)
-	 (%i-search-printed-char (get-key-event *editor-input* t)
-				 string point trailer direction failure))
-	((and (zerop (length string)) (logical-key-event-p key-event :exit))
-	 (if (eq direction :forward)
-	     (forward-search-command nil)
-	     (reverse-search-command nil))
-	 (throw 'exit-i-search nil))
-	(t
-	 (unless (logical-key-event-p key-event :exit)
-	   (unget-key-event key-event *editor-input*))
-	 (unless (zerop (length string))
-	   (setf *last-search-string* string))
-	 (throw 'exit-i-search nil))))
-
-;;;      %I-SEARCH-CONTROL-S-OR-R handles repetitions in the search.  Note
-;;; that there cannot be failure in the last COND branch: since the direction
-;;; has just been changed, there cannot be a failure before trying a new
-;;; direction.
-;;;
-(defun %i-search-control-s-or-r (key-event string point trailer
-					   direction failure)
-  (let ((forward-direction-p (eq direction :forward))
-	(forward-character-p (logical-key-event-p key-event :forward-search)))
-    (cond ((zerop (length string))
-	   (%i-search-empty-string point trailer direction forward-direction-p
-				   forward-character-p))
-	  ((eq forward-direction-p forward-character-p)
-	   (if failure
-	       (%i-search string point trailer direction failure)
-	       (%i-search-find-pattern string point (move-mark trailer point)
-				       direction)))
-	  (t
-	   (let ((new-direction (if forward-character-p :forward :backward)))
-	     (%i-search-echo-refresh string new-direction nil)
-	     (i-search-pattern string new-direction)
-	     (%i-search-find-pattern string point (move-mark trailer point)
-				     new-direction))))))
-
-
-;;;      %I-SEARCH-EMPTY-STRING handles the empty string case when a ^S
-;;; or ^R is typed.  If the direction and character typed do not agree,
-;;; then merely switch directions.  If there was a previous string, search
-;;; for it, else flash at the guy.
-;;;
-(defun %i-search-empty-string (point trailer direction forward-direction-p
-				     forward-character-p)
-  (cond ((eq forward-direction-p (not forward-character-p))
-	 (let ((direction (if forward-character-p :forward :backward)))
-	   (%i-search-echo-refresh "" direction nil)
-	   (%i-search "" point trailer direction nil)))
-	(*last-search-string*
-	 (%i-search-echo-refresh *last-search-string* direction nil)
-	 (i-search-pattern *last-search-string* direction)
-	 (%i-search-find-pattern *last-search-string* point trailer direction))
-	(t (beep))))
-
-
-;;;      %I-SEARCH-PRINTED-CHAR handles the case of standard character input.
-;;; If the direction is backwards, we have to be careful not to MARK-AFTER
-;;; the end of the buffer or to include the next character at the beginning
-;;; of the search.
-;;;
-(defun %i-search-printed-char (key-event string point trailer direction failure)
-  (let ((tchar (ext:key-event-char key-event)))
-    (unless tchar (editor-error "Not a text character -- ~S" (key-event-char
-							      key-event)))
-    (when (interactive)
-      (insert-character (buffer-point *echo-area-buffer*) tchar)
-      (force-output *echo-area-stream*))
-    (let ((new-string (concatenate 'simple-string string (string tchar))))
-      (i-search-pattern new-string direction)
-      (cond (failure (%i-search new-string point trailer direction failure))
-	    ((and (eq direction :backward) (next-character trailer))
-	     (%i-search-find-pattern new-string point (mark-after trailer)
-				     direction))
-	    (t
-	     (%i-search-find-pattern new-string point trailer direction))))))
-
-
-;;;      %I-SEARCH-FIND-PATTERN takes a pattern for a string and direction
-;;; and finds it, updating necessary pointers for the next call to %I-SEARCH.
-;;; If the search failed, tell the user and do not move any pointers.
-;;;
-(defun %i-search-find-pattern (string point trailer direction)
-  (let ((found-offset (find-pattern trailer *last-search-pattern*)))
-    (cond (found-offset
-	    (cond ((eq direction :forward)
-		   (character-offset (move-mark point trailer) found-offset))
-		  (t
-		   (move-mark point trailer)
-		   (character-offset trailer found-offset)))
-	    (%i-search string point trailer direction nil))
-	  (t
-	   (%i-search-echo-refresh string direction t)
-	   (if (interactive)
-	       (beep)
-	       (editor-error "I-Search failed."))
-	   (%i-search string point trailer direction t)))))
-
-
-
-;;;; Replacement commands:
-
-(defcommand "Replace String" (p &optional
-				(target (prompt-for-string
-					 :prompt "Replace String: "
-					 :help "Target string"
-					 :default *last-search-string*))
-				(replacement (prompt-for-string
-					      :prompt "With: "
-					      :help "Replacement string")))
-  "Replaces the specified Target string with the specified Replacement
-   string in the current buffer for all occurrences after the point or within
-   the active region, depending on whether it is active."
-  "Replaces the specified Target string with the specified Replacement
-   string in the current buffer for all occurrences after the point or within
-   the active region, depending on whether it is active.  The prefix argument
-   may limit the number of replacements."
-  (multiple-value-bind (ignore count)
-		       (query-replace-function p target replacement
-					       "Replace String" t)
-    (declare (ignore ignore))
-    (message "~D Occurrences replaced." count)))
-
-(defcommand "Query Replace" (p &optional
-			       (target (prompt-for-string
-					:prompt "Query Replace: "
-					:help "Target string"
-					:default *last-search-string*))
-			       (replacement (prompt-for-string
-					     :prompt "With: "
-					     :help "Replacement string")))
-  "Replaces the Target string with the Replacement string if confirmation
-   from the keyboard is given.  If the region is active, limit queries to
-   occurrences that occur within it, otherwise use point to end of buffer."
-  "Replaces the Target string with the Replacement string if confirmation
-   from the keyboard is given.  If the region is active, limit queries to
-   occurrences that occur within it, otherwise use point to end of buffer.
-   A prefix argument may limit the number of queries."
-  (let ((mark (copy-mark (current-point))))
-    (multiple-value-bind (ignore count)
-			 (query-replace-function p target replacement
-						 "Query Replace")
-      (declare (ignore ignore))
-      (message "~D Occurrences replaced." count))
-    (push-buffer-mark mark)))
-
-
-(defhvar "Case Replace"
-  "If this is true then \"Query Replace\" will try to preserve case when
-  doing replacements."
-  :value t)
-
-(defstruct (replace-undo (:constructor make-replace-undo (mark region)))
-  mark
-  region)
-
-(setf (documentation 'replace-undo-mark 'function)
-      "Return the mark where a replacement was made.")
-(setf (documentation 'replace-undo-region 'function)
-      "Return region deleted due to replacement.")
-
-(defvar *query-replace-undo-data* nil)
-
-;;; REPLACE-THAT-CASE replaces a string case-sensitively.  Lower, Cap and Upper
-;;; are the original, capitalized and uppercase replacement strings.  Mark is a
-;;; :left-inserting mark after the text to be replaced.  Length is the length
-;;; of the target string.  If dumb, then do a simple replace.  This pushes
-;;; an undo information structure into *query-replace-undo-data* which
-;;; QUERY-REPLACE-FUNCTION uses.
-;;;
-(defun replace-that-case (lower cap upper mark length dumb)
-  (character-offset mark (- length))
-  (let ((insert (cond (dumb lower)
-		      ((upper-case-p (next-character mark))
-		       (mark-after mark)
-		       (prog1 (if (upper-case-p (next-character mark)) upper cap)
-			      (mark-before mark)))
-		      (t lower))))
-    (with-mark ((undo-mark1 mark :left-inserting)
-		(undo-mark2 mark :left-inserting))
-      (character-offset undo-mark2 length)
-      (push (make-replace-undo
-	     ;; Save :right-inserting, so the INSERT-STRING at mark below
-	     ;; doesn't move the copied mark the past replacement.
-	     (copy-mark mark :right-inserting)
-	     (delete-and-save-region (region undo-mark1 undo-mark2)))
-	    *query-replace-undo-data*))
-    (insert-string mark insert)))
-
-;;; QUERY-REPLACE-FUNCTION does the work for the main replacement commands:
-;;; "Query Replace", "Replace String", "Group Query Replace", "Group Replace".
-;;; Name is the name of the command for undoing purposes.  If doing-all? is
-;;; true, this replaces all ocurrences for the non-querying commands.  This
-;;; returns t if it completes successfully, and nil if it is aborted.  As a
-;;; second value, it returns the number of replacements.
-;;;
-;;; The undo method, before undo'ing anything, makes all marks :left-inserting.
-;;; There's a problem when two replacements are immediately adjacent, such as
-;;;    foofoo
-;;; replacing "foo" with "bar".  If the marks were still :right-inserting as
-;;; REPLACE-THAT-CASE makes them, then undo'ing the first replacement would
-;;; bring the two marks together due to the DELETE-CHARACTERS.  Then inserting
-;;; the region would move the second replacement's mark to be before the first
-;;; replacement.
-;;;
-(defun query-replace-function (count target replacement name
-			       &optional (doing-all? nil))
-  (declare (simple-string replacement))
-  (let ((replacement-len (length replacement))
-	(*query-replace-undo-data* nil))
-    (when (and count (minusp count))
-      (editor-error "Replacement count is negative."))
-    (get-search-pattern target :forward)
-    (unwind-protect
-	(query-replace-loop (get-count-region) (or count -1) target replacement
-			    replacement-len (current-point) doing-all?)
-      (let ((undo-data (nreverse *query-replace-undo-data*)))
-	(save-for-undo name
-	  #'(lambda ()
-	      (dolist (ele undo-data)
-		(setf (mark-kind (replace-undo-mark ele)) :left-inserting))
-	      (dolist (ele undo-data)
-		(let ((mark (replace-undo-mark ele)))
-		  (delete-characters mark replacement-len)
-		  (ninsert-region mark (replace-undo-region ele)))))
-	  #'(lambda ()
-	      (dolist (ele undo-data)
-		(delete-mark (replace-undo-mark ele)))))))))
-
-;;; QUERY-REPLACE-LOOP is the essence of QUERY-REPLACE-FUNCTION.  The first
-;;; value is whether we completed all replacements, nil if we aborted.  The
-;;; second value is how many replacements occurred.
-;;;
-(defun query-replace-loop (region count target replacement replacement-len
-			   point doing-all?)
-  (with-mark ((last-found point)
-	      ;; Copy REGION-END before moving point to REGION-START in case
-	      ;; the end is point.  Also, make it permanent in case we make
-	      ;; replacements on the last line containing the end.
-	      (stop-mark (region-end region) :left-inserting))
-    (move-mark point (region-start region))
-    (let ((length (length target))
-	  (cap (string-capitalize replacement))
-	  (upper (string-upcase replacement))
-	  (dumb (not (and (every #'(lambda (ch) (or (not (both-case-p ch))
-						    (lower-case-p ch)))
-				 (the string replacement))
-			  (value case-replace)))))
-      (values
-       (loop
-	 (let ((won (find-pattern point *last-search-pattern*)))
-	   (when (or (null won) (zerop count) (mark> point stop-mark))
-	     (character-offset (move-mark point last-found) replacement-len)
-	     (return t))
-	   (decf count)
-	   (move-mark last-found point)
-	   (character-offset point length)
-	   (if doing-all?
-	       (replace-that-case replacement cap upper point length dumb)
-	       (command-case
-		   (:prompt
-		    "Query replace: "
-		    :help "Type one of the following single-character commands:"
-		    :change-window nil :bind key-event)
-		 (:yes "Replace this occurrence."
-		       (replace-that-case replacement cap upper point length
-					  dumb))
-		 (:no "Don't replace this occurrence, but continue.")
-		 (:do-all "Replace this and all remaining occurrences."
-			  (replace-that-case replacement cap upper point length
-					     dumb)
-			  (setq doing-all? t))
-		 (:do-once "Replace this occurrence, then exit."
-			   (replace-that-case replacement cap upper point length
-					      dumb)
-			   (return nil))
-		 (:recursive-edit
-		  "Go into a recursive edit at the current position."
-		  (do-recursive-edit)
-		  (get-search-pattern target :forward))
-		 (:exit "Exit immediately."
-			(return nil))
-		 (t (unget-key-event key-event *editor-input*)
-		    (return nil))))))
-       (length (the list *query-replace-undo-data*))))))
-
-
-
-;;;; Occurrence searching.
-
-(defcommand "List Matching Lines" (p &optional string)
-  "Prompts for a search string and lists all matching lines after the point or
-   within the current-region, depending on whether it is active or not.
-   With an argument, lists p lines before and after each matching line."
-  "Prompts for a search string and lists all matching lines after the point or
-   within the current-region, depending on whether it is active or not.
-   With an argument, lists p lines before and after each matching line."
-  (unless string
-    (setf string (prompt-for-string :prompt "List Matching: "
-				    :default *last-search-string*
-				    :help "String to search for")))
-  (let ((pattern (get-search-pattern string :forward))
-	(matching-lines nil)
-	(region (get-count-region)))
-    (with-mark ((mark (region-start region))
-		(end-mark (region-end region)))
-      (loop
-	(when (or (null (find-pattern mark pattern)) (mark> mark end-mark))
-	  (return))
-	(setf matching-lines
-	      (nconc matching-lines (list-lines mark (or p 0))))
-	(unless (line-offset mark 1 0)
-	  (return))))
-    (with-pop-up-display (s :height (length matching-lines))
-      (dolist (line matching-lines)
-	(write-line line s)))))
-
-;;; LIST-LINES creates a lists of strings containing (num) lines before the
-;;; line that the point is on, the line that the point is on, and (num)
-;;; lines after the line that the point is on. If (num) > 0, a string of
-;;; dashes will be added to make life easier for List Matching Lines.
-;;; 
-(defun list-lines (mark num)
-  (if (<= num 0)
-      (list (line-string (mark-line mark)))
-      (with-mark ((mark mark)
-		  (beg-mark mark))
-	(unless (line-offset beg-mark (- num))
-	  (buffer-start beg-mark))
-	(unless (line-offset mark num)
-	  (buffer-end mark))
-	(let ((lines (list "--------")))
-	  (loop
-	    (push (line-string (mark-line mark)) lines)
-	    (when (same-line-p mark beg-mark)
-	      (return lines))
-	    (line-offset mark -1))))))
-
-(defcommand "Delete Matching Lines" (p &optional string)
-  "Deletes all lines that match the search pattern using delete-region. If
-   the current region is active, limit the search to it. The argument is
-   ignored."
-  "Deletes all lines that match the search pattern using delete-region. If
-   the current region is active, limit the search to it. The argument is
-   ignored."
-  (declare (ignore p))
-  (unless string
-    (setf string (prompt-for-string :prompt "Delete Matching: "
-				    :default *last-search-string*
-				    :help "String to search for")))
-  (let* ((region (get-count-region))
-	 (pattern (get-search-pattern string :forward))
-	 (start-mark (region-start region))
-	 (end-mark (region-end region)))
-    (with-mark ((bol-mark start-mark :left-inserting)
-		(eol-mark start-mark :right-inserting))
-      (loop
-	(unless (and (find-pattern bol-mark pattern) (mark< bol-mark end-mark))
-	  (return))
-	(move-mark eol-mark bol-mark)
-	(line-start bol-mark)
-	(unless (line-offset eol-mark 1 0)
-	  (buffer-end eol-mark))
-	(delete-region (region bol-mark eol-mark))))))
-
-(defcommand "Delete Non-Matching Lines" (p &optional string)
-  "Deletes all lines that do not match the search pattern using delete-region.
-   If the current-region is active, limit the search to it. The argument is
-   ignored."
-  "Deletes all lines that do not match the search pattern using delete-region.
-   If the current-region is active, limit the search to it. The argument is
-   ignored."
-  (declare (ignore p))
-  (unless string
-    (setf string (prompt-for-string :prompt "Delete Non-Matching:"
-				    :default *last-search-string*
-				    :help "String to search for")))
-  (let* ((region (get-count-region))
-	 (start-mark (region-start region))
-	 (stop-mark (region-end region))
-	 (pattern (get-search-pattern string :forward)))
-    (with-mark ((beg-mark start-mark :left-inserting)
-		(end-mark start-mark :right-inserting))
-      (loop
-	(move-mark end-mark beg-mark)
-	(cond ((and (find-pattern end-mark pattern) (mark< end-mark stop-mark))
-	       (line-start end-mark)
-	       (delete-region (region beg-mark end-mark))
-	       (unless (line-offset beg-mark 1 0)
-		 (return)))
-	      (t
-	       (delete-region (region beg-mark stop-mark))
-	       (return)))))))
-
-(defcommand "Count Occurrences" (p &optional string)
-  "Prompts for a search string and counts occurrences of it after the point or
-   within the current-region, depending on whether it is active or not. The
-   argument is ignored."
-  "Prompts for a search string and counts occurrences of it after the point or
-   within the current-region, depending on whether it is active or not. The
-   argument is ignored."
-  (declare (ignore p))
-  (unless string
-    (setf string (prompt-for-string
-		  :prompt "Count Occurrences: "
-		  :default *last-search-string*
-		  :help "String to search for")))
-  (message "~D occurrence~:P"
-	   (count-occurrences-region (get-count-region) string)))
-
-(defun count-occurrences-region (region string)
-  (let ((pattern (get-search-pattern string :forward))
-	(end-mark (region-end region)))
-    (let ((occurrences 0))
-      (with-mark ((mark (region-start region)))
-	(loop
-	  (let ((won (find-pattern mark pattern)))
-	    (when (or (null won) (mark> mark end-mark))
-	      (return))
-	    (incf occurrences)
-	    (character-offset mark won))))
-      occurrences)))
diff --git a/hemlock/shell.lisp b/hemlock/shell.lisp
deleted file mode 100644
index 1ca0e0405afdf2c3f0863895fda39e47790766ef..0000000000000000000000000000000000000000
--- a/hemlock/shell.lisp
+++ /dev/null
@@ -1,395 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;; Hemlock command level support for processes.
-;;;
-;;; Written by Blaine Burks.
-;;;
-
-(in-package "HEMLOCK")
-
-
-(defun setup-process-buffer (buffer)
-  (let ((mark (copy-mark (buffer-point buffer) :right-inserting)))
-    (defhvar "Buffer Input Mark"
-      "The buffer input mark for this buffer."
-      :buffer buffer
-      :value mark)
-    (defhvar "Process Output Stream"
-      "The process structure for this buffer."
-      :buffer buffer
-      :value (make-hemlock-output-stream mark))
-    (defhvar "Interactive History"
-      "A ring of the regions input to an interactive mode (Eval or Typescript)."
-      :buffer buffer
-      :value (make-ring (value interactive-history-length)))
-    (defhvar "Interactive Pointer"
-      "Pointer into \"Interactive History\"."
-      :buffer buffer
-      :value 0)
-    (defhvar "Searching Interactive Pointer"
-      "Pointer into \"Interactive History\"."
-      :buffer buffer
-      :value 0)
-    (unless (buffer-modeline-field-p buffer :process-status)
-      (setf (buffer-modeline-fields buffer)
-	    (nconc (buffer-modeline-fields buffer)
-		   (list (modeline-field :process-status)))))))
-
-(defmode "Process" :major-p nil :setup-function #'setup-process-buffer)
-
-
-;;;; Support for handling input before the prompt in process buffers.
-
-(defun unwedge-process-buffer ()
-  (buffer-end (current-point))
-  (deliver-signal-to-process :SIGINT (value process))
-  (editor-error "Aborted."))
-
-(defhvar "Unwedge Interactive Input Fun"
-  "Function to call when input is confirmed, but the point is not past the
-   input mark."
-  :value #'unwedge-process-buffer
-  :mode "Process")
-
-(defhvar "Unwedge Interactive Input String"
-  "String to add to \"Point not past input mark.  \" explaining what will
-   happen if the the user chooses to be unwedged."
-  :value "Interrupt and throw to end of buffer?"
-  :mode "Process")
-
-
-;;;; Some Global Variables.
-
-(defhvar "Current Shell"
-  "The shell to which \"Select Shell\" goes."
-  :value nil)
-
-(defhvar "Ask about Old Shells"
-  "When set (the default), Hemlock prompts for an existing shell buffer in
-   preference to making a new one when there is no \"Current Shell\"."
-  :value t)
-  
-(defhvar "Kill Process Confirm"
-  "When set, Hemlock prompts for confirmation before killing a buffer's process."
-  :value t)
-
-(defhvar "Shell Utility"
-  "The \"Shell\" command uses this as the default command line."
-  :value "/bin/csh")
-
-(defhvar "Shell Utility Switches"
-  "This is a string containing the default command line arguments to the
-   utility in \"Shell Utility\".  This is a string since the utility is
-   typically \"/bin/csh\", and this string can contain I/O redirection and
-   other shell directives."
-  :value "")
-
-
-
-;;;; The Shell, New Shell, and Set Current Shell Commands.
-
-(defvar *shell-names* (make-string-table)
-  "A string-table of the string-name of all process buffers and corresponding
-   buffer structures.")
-
-(defcommand "Set Current Shell" (p)
-  "Sets the value of \"Current Shell\", which the \"Shell\" command uses."
-  "Sets the value of \"Current Shell\", which the \"Shell\" command uses."
-  (declare (ignore p))
-  (set-current-shell))
-
-;;; SET-CURRENT-SHELL -- Internal.
-;;;
-;;; This prompts for a known shell buffer to which it sets "Current Shell".
-;;; It signals an error if there are none.
-;;;
-(defun set-current-shell ()
-  (let ((old-buffer (value current-shell))
-	(first-old-shell (do-strings (var val *shell-names* nil)
-			   (declare (ignore var val))
-			   (return var))))
-    (when (and (not old-buffer) (not first-old-shell))
-      (editor-error "Nothing to set current shell to."))
-    (let ((default-shell (if old-buffer
-			     (buffer-name old-buffer)
-			     first-old-shell)))
-      (multiple-value-bind
-	  (new-buffer-name new-buffer) 
-	  (prompt-for-keyword (list *shell-names*)
-			      :must-exist t
-			      :default default-shell
-			      :default-string default-shell
-			      :prompt "Existing Shell: "
-			      :help "Enter the name of an existing shell.")
-	(declare (ignore new-buffer-name))
-	(setf (value current-shell) new-buffer)))))
-
-(defcommand "Shell" (p)
-  "This spawns a shell in a buffer.  If there already is a \"Current Shell\",
-   this goes to that buffer.  If there is no \"Current Shell\", there are
-   shell buffers, and \"Ask about Old Shells\" is set, this prompts for one
-   of them, setting \"Current Shell\" to that shell.  Supplying an argument
-   forces the creation of a new shell buffer."
-  "This spawns a shell in a buffer.  If there already is a \"Current Shell\",
-   this goes to that buffer.  If there is no \"Current Shell\", there are
-   shell buffers, and \"Ask about Old Shells\" is set, this prompts for one
-   of them, setting \"Current Shell\" to that shell.  Supplying an argument
-   forces the creation of a new shell buffer."
-  (let ((shell (value current-shell))
-	(no-shells-p (do-strings (var val *shell-names* t)
-		       (declare (ignore var val))
-		       (return nil))))
-    (cond (p (make-new-shell nil no-shells-p))
-	  (shell (change-to-buffer shell))
-	  ((and (value ask-about-old-shells) (not no-shells-p))
-	   (set-current-shell)
-	   (change-to-buffer (value current-shell)))
-	  (t (make-new-shell nil)))))
-
-(defcommand "Shell Command Line in Buffer" (p)
-  "Prompts the user for a process and a buffer in which to run the process."
-  "Prompts the user for a process and a buffer in which to run the process."
-  (declare (ignore p))
-  (make-new-shell t))
-
-;;; MAKE-NEW-SHELL -- Internal.
-;;;
-;;; This makes new shells for us dealing with prompting for various things and
-;;; setting "Current Shell" according to user documentation.
-;;;
-(defun make-new-shell (prompt-for-command-p &optional (set-current-shell-p t)
-		       (command-line (get-command-line) clp))
-  (let* ((command (or (and clp command-line)
-		      (if prompt-for-command-p
-			  (prompt-for-string
-			   :default command-line :trim t
-			   :prompt "Command to execute: "
-			   :help "Shell command line to execute.")
-			  command-line)))
-	 (buffer-name (if prompt-for-command-p
-			  (prompt-for-string
-			   :default
-			   (concatenate 'simple-string command " process")
-			   :trim t
-			   :prompt `("Buffer in which to execute ~A? "
-				     ,command)
-			   :help "Where output from this process will appear.")
-			  (new-shell-name)))
-	 (buffer (make-buffer
-		  buffer-name
-		  :modes '("Fundamental" "Process")
-		  :delete-hook
-		  (list #'(lambda (buffer)
-			    (when (eq (value current-shell) buffer)
-			      (setf (value current-shell) nil))
-			    (delete-string (buffer-name buffer) *shell-names*)
-			    (kill-process (variable-value 'process
-							  :buffer buffer)))))))
-    (unless buffer
-      (setf buffer (getstring buffer-name *buffer-names*))
-      (buffer-end (buffer-point buffer)))
-    (defhvar "Process"
-      "The process for Shell and Process buffers."
-      :buffer buffer
-      :value (ext::run-program "/bin/sh" (list "-c" command)
-			       :wait nil
-			       :pty (variable-value 'process-output-stream
-						    :buffer buffer)
-			       :env (frob-environment-list
-				     (car (buffer-windows buffer)))
-			       :status-hook #'(lambda (process)
-						(declare (ignore process))
-						(update-process-buffer buffer))
-			       :input t :output t))
-    (setf (getstring buffer-name *shell-names*) buffer)
-    (update-process-buffer buffer)
-    (when (and (not (value current-shell)) set-current-shell-p)
-      (setf (value current-shell) buffer))
-    (change-to-buffer buffer)))
-
-;;; GET-COMMAND-LINE -- Internal.
-;;;
-;;; This just conses up a string to feed to the shell.
-;;;
-(defun get-command-line ()
-  (concatenate 'simple-string (value shell-utility) " "
-	       (value shell-utility-switches)))
-
-;;; FROB-ENVIRONMENT-LIST -- Internal.
-;;;
-;;; This sets some environment variables so the shell will be in the proper
-;;; state when it comes up.
-;;;
-(defun frob-environment-list (window)
-  (list* (cons :termcap  (concatenate 'simple-string
-				      "emacs:co#"
-				      (if window
-					  (lisp::quick-integer-to-string
-					   (window-width window))
-					  "")
-				      ":tc=unkown:"))
-	 (cons :emacs "t") (cons :term "emacs")
-	 (remove-if #'(lambda (keyword)
-			(member keyword '(:termcap :emacs :term)
-				:test #'(lambda (cons keyword)
-					  (eql (car cons) keyword))))
-		    ext:*environment-list*)))
-
-;;; NEW-SHELL-NAME -- Internal.
-;;;
-;;; This returns a unique buffer name for a shell by incrementing the value of
-;;; *process-number* until "Process <*process-number*> is not already the name
-;;; of a buffer.  Perhaps this is being overly cautious, but I've seen some
-;;; really stupid users.
-;;;
-(defvar *process-number* 0)
-;;;
-(defun new-shell-name ()
-  (loop
-    (let ((buffer-name (format nil "Shell ~D" (incf *process-number*))))
-      (unless (getstring buffer-name *buffer-names*) (return buffer-name)))))
-
-
-;;;; Modeline support.
-
-(defun modeline-process-status (buffer window)
-  (declare (ignore window))
-  (when (hemlock-bound-p 'process :buffer buffer)
-    (let ((process (variable-value 'process :buffer buffer)))
-      (ecase (ext:process-status process)
-	(:running "running")
-	(:stopped "stopped")
-	(:signaled "killed by signal ~D" (mach:unix-signal-name
-					  (ext:process-exit-code process)))
-	(:exited (format nil "exited with status ~D"
-			 (ext:process-exit-code process)))))))
-			 
-
-(make-modeline-field :name :process-status
-		     :function #'modeline-process-status)
-
-(defun update-process-buffer (buffer)
-  (when (buffer-modeline-field-p buffer :process-status)
-    (dolist (window (buffer-windows buffer))
-      (update-modeline-field buffer window :process-status)))
-  (let ((process (variable-value 'process :buffer buffer)))
-    (unless (ext:process-alive-p process)
-      (ext:process-close process)
-      (when (eq (value current-shell) buffer)
-	(setf (value current-shell) nil)))))
-
-
-;;;; Supporting Commands.
-
-(defcommand "Confirm Process Input" (p)
-  "Evaluate Process Mode input between the point and last prompt."
-  "Evaluate Process Mode input between the point and last prompt."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'process :buffer (current-buffer))
-    (editor-error "Not in a process buffer."))
-  (let* ((process (value process))
-	 (stream (ext:process-pty process)))
-    (case (ext:process-status process)
-      (:running)
-      (:stopped (editor-error "The process has been stopped."))
-      (t (editor-error "The process is dead.")))
-    (let ((input-region (get-interactive-input)))
-      (write-line (region-to-string input-region) stream)
-      (force-output (ext:process-pty process))
-      (insert-character (current-point) #\newline)
-      ;; Move "Buffer Input Mark" to end of buffer.
-      (move-mark (region-start input-region) (region-end input-region)))))
-
-(defcommand "Kill Main Process" (p)
-  "Kills the process in the current buffer."
-  "Kills the process in the current buffer."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'process :buffer (current-buffer))
-    (editor-error "Not in a process buffer."))
-  (when (or (not (value kill-process-confirm))
-	    (prompt-for-y-or-n :default nil
-			       :prompt "Really blow away shell? "
-			       :default nil
-			       :default-string "no"))
-    (kill-process (value process))))
-
-(defcommand "Stop Main Process" (p)
-  "Stops the process in the current buffer.  With an argument use :SIGSTOP
-   instead of :SIGTSTP."
-  "Stops the process in the current buffer.  With an argument use :SIGSTOP
-  instead of :SIGTSTP."
-  (unless (hemlock-bound-p 'process :buffer (current-buffer))
-    (editor-error "Not in a process buffer."))
-  (deliver-signal-to-process (if p :SIGSTOP :SIGTSTP) (value process)))
-
-(defcommand "Continue Main Process" (p)
-  "Continues the process in the current buffer."
-  "Continues the process in the current buffer."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'process :buffer (current-buffer))
-    (editor-error "Not in a process buffer."))
-  (deliver-signal-to-process :SIGCONT (value process)))
-  
-(defun kill-process (process)
-  "Self-explanatory."
-  (deliver-signal-to-process :SIGKILL process))
-
-(defun deliver-signal-to-process (signal process)
-  "Delivers a signal to a process."
-  (ext:process-kill process signal :process-group))
-
-(defcommand "Send EOF to Process" (p)
-  "Sends a Ctrl-D to the process in the current buffer."
-  "Sends a Ctrl-D to the process in the current buffer."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'process :buffer (current-buffer))
-    (editor-error "Not in a process buffer."))
-  (let ((stream (ext:process-pty (value process))))
-    (write-char (int-char 4) stream)
-    (force-output stream)))
-
-(defcommand "Interrupt Buffer Subprocess" (p)
-  "Stop the subprocess currently executing in this shell."
-  "Stop the subprocess currently executing in this shell."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'process :buffer (current-buffer))
-    (editor-error "Not in a process buffer."))
-  (buffer-end (current-point))
-  (buffer-end (value buffer-input-mark))
-  (deliver-signal-to-subprocess :SIGINT (value process)))
-
-(defcommand "Kill Buffer Subprocess" (p)
-  "Kill the subprocess currently executing in this shell."
-  "Kill the subprocess currently executing in this shell."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'process :buffer (current-buffer))
-    (editor-error "Not in a process buffer."))  
-  (deliver-signal-to-subprocess :SIGKILL (value process)))
-
-(defcommand "Quit Buffer Subprocess" (p)
-  "Quit the subprocess currently executing int his shell."
-  "Quit the subprocess currently executing int his shell."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'process :buffer (current-buffer))
-    (editor-error "Not in a process buffer."))
-  (deliver-signal-to-subprocess :SIGQUIT (value process)))
-
-(defcommand "Stop Buffer Subprocess" (p)
-  "Stop the subprocess currently executing in this shell."
-  "Stop the subprocess currently executing in this shell."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'process :buffer (current-buffer))
-    (editor-error "Not in a process buffer."))  
-  (deliver-signal-to-subprocess (if p :SIGSTOP :SIGTSTP) (value process)))
-
-(defun deliver-signal-to-subprocess (signal process)
-  "Delivers a signal to a subprocess of a shell."
-  (ext:process-kill process signal :pty-process-group))
diff --git a/hemlock/spell-aug.lisp b/hemlock/spell-aug.lisp
deleted file mode 100644
index ed6c47d2046a879c0a1200bb8eab111b81ad81d6..0000000000000000000000000000000000000000
--- a/hemlock/spell-aug.lisp
+++ /dev/null
@@ -1,237 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Spell -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spell-aug.lisp,v 1.1.1.2 1991/02/08 16:37:44 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles
-;;;    Designed by Bill Chiles and Rob Maclachlan
-;;;
-;;; This file contains the code to grow the spelling dictionary in system
-;;; space by reading a text file of entries or adding one at a time.  This
-;;; code relies on implementation dependent code found in Spell-RT.Lisp.
-
-
-(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM"))
-
-(export '(spell-add-entry spell-read-dictionary spell-remove-entry
-	  spell-root-flags))
-
-
-;;;; Converting Flags to Masks
-
-(defconstant flag-names-to-masks
-  `((#\V . ,V-mask) (#\N . ,N-mask) (#\X . ,X-mask)
-    (#\H . ,H-mask) (#\Y . ,Y-mask) (#\G . ,G-mask)
-    (#\J . ,J-mask) (#\D . ,D-mask) (#\T . ,T-mask)
-    (#\R . ,R-mask) (#\Z . ,Z-mask) (#\S . ,S-mask)
-    (#\P . ,P-mask) (#\M . ,M-mask)))
-
-(defvar *flag-masks*
-  (make-array 128 :element-type '(unsigned-byte 16) :initial-element 0)
-  "This holds the masks for character flags, which is used when reading
-   a text file of dictionary words.  Illegal character flags hold zero.")
-
-(eval-when (compile eval)
-(defmacro flag-mask (char)
-  `(aref *flag-masks* (char-code ,char)))
-) ;eval-when
-
-(dolist (e flag-names-to-masks)
-  (let ((char (car e))
-	(mask (cdr e)))
-    (setf (flag-mask char) mask)
-    (setf (flag-mask (char-downcase char)) mask)))
-
-
-
-;;;; String and Hashing Macros
-
-(eval-when (compile eval)
-
-(defmacro string-table-replace (src-string dst-start length)
-  `(sap-replace *string-table* ,src-string 0 ,dst-start (+ ,dst-start ,length)))
-
-;;; HASH-ENTRY is used in SPELL-ADD-ENTRY to find a dictionary location for
-;;; adding a new entry.  If a location contains a zero, then it has never
-;;; been used, and no entries have ever been "hashed past" it.  If a location
-;;; contains a -1, then it once contained an entry that has since been
-;;; deleted.
-;;; 
-(defmacro hash-entry (entry entry-len)
-  (let ((loop-loc (gensym)) (loc-contents (gensym))
-	(hash (gensym)) (loc (gensym)))
-    `(let* ((,hash (string-hash ,entry ,entry-len))
-	    (,loc (rem ,hash (the fixnum *dictionary-size*)))
-	    (,loc-contents (dictionary-ref ,loc)))
-       (declare (fixnum ,loc ,loc-contents))
-       (if (or (zerop ,loc-contents) (= ,loc-contents -1))
-	   ,loc
-	   (hash2-loop (,loop-loc ,loc-contents) ,loc ,hash
-	     ,loop-loc nil t)))))
-
-) ;eval-when
-
-
-
-;;;; Top Level Stuff
-
-(defun spell-read-dictionary (filename)
-  "Add entries to dictionary from lines in the file filename."
-  (with-open-file (s filename :direction :input)
-    (loop (multiple-value-bind (entry eofp) (read-line s nil nil)
-	    (declare (type (or simple-string null) entry))
-	    (unless entry (return))
-	    (spell-add-entry entry)
-	    (if eofp (return))))))
-
-
-;;; This is used to break up an 18 bit string table index into two parts
-;;; for storage in a word descriptor unit.  See the documentation at the
-;;; top of Spell-Correct.Lisp.
-;;;
-(defconstant whole-index-low-byte (byte 16 0))
-
-(defun spell-add-entry (line &optional
-			     (word-end (or (position #\/ line :test #'char=)
-					   (length line))))
-  "Line is of the form \"entry/flag1/flag2\" or \"entry\".  It is parsed and
-   added to the spelling dictionary.  Line is desstructively modified."
-  (declare (simple-string line) (fixnum word-end))
-  (nstring-upcase line :end word-end)
-  (when (> word-end max-entry-length)
-    (return-from spell-add-entry nil))
-  (let ((entry (lookup-entry line word-end)))
-    (when entry
-      (add-flags (+ entry 2) line word-end)
-      (return-from spell-add-entry nil)))
-  (let* ((hash-loc (hash-entry line word-end))
-	 (string-ptr *string-table-size*)
-	 (desc-ptr *descriptors-size*)
-	 (desc-ptr+1 (1+ desc-ptr))
-	 (desc-ptr+2 (1+ desc-ptr+1)))
-    (declare (fixnum string-ptr))
-    (when (not hash-loc) (error "Dictionary Overflow!"))
-    (when (> 3 *free-descriptor-elements*) (grow-descriptors))
-    (when (> word-end *free-string-table-bytes*) (grow-string-table))
-    (decf *free-descriptor-elements* 3)
-    (incf *descriptors-size* 3)
-    (decf *free-string-table-bytes* word-end)
-    (incf *string-table-size* word-end)
-    (setf (dictionary-ref hash-loc) desc-ptr)
-    (setf (descriptor-ref desc-ptr)
-	  (dpb (the fixnum (ldb new-hash-byte (string-hash line word-end)))
-	       stored-hash-byte
-	       word-end))
-    (setf (descriptor-ref desc-ptr+1)
-	  (ldb whole-index-low-byte string-ptr))
-    (setf (descriptor-ref desc-ptr+2)
-	  (dpb (the fixnum (ldb whole-index-high-byte string-ptr))
-	       stored-index-high-byte
-	       0))
-    (add-flags desc-ptr+2 line word-end)
-    (string-table-replace line string-ptr word-end))
-  t)
-
-(defun add-flags (loc line word-end)
-  (declare (simple-string line) (fixnum word-end))
-  (do ((flag (1+ word-end) (+ 2 flag))
-       (line-end (length line)))
-      ((>= flag line-end))
-    (declare (fixnum flag line-end))
-    (let ((flag-mask (flag-mask (schar line flag))))
-      (declare (fixnum flag-mask))
-      (unless (zerop flag-mask)
-	(setf (descriptor-ref loc)
-	      (logior flag-mask (descriptor-ref loc)))))))
-
-;;; SPELL-REMOVE-ENTRY destructively uppercases entry in removing it from
-;;; the dictionary.  First entry is looked up, and if it is found due to a
-;;; flag, the flag is cleared in the descriptor table.  If entry is a root
-;;; word in the dictionary (that is, looked up without the use of a flag),
-;;; then the root and all its derivitives are deleted by setting its
-;;; dictionary location to -1.
-;;; 
-(defun spell-remove-entry (entry)
-  "Removes entry from the dictionary, so it will be an unknown word.  Entry
-   is a simple string and is destructively modified.  If entry is a root
-   word, then all words derived with entry and its flags will also be deleted."
-  (declare (simple-string entry))
-  (nstring-upcase entry)
-  (let ((entry-len (length entry)))
-    (declare (fixnum entry-len))
-    (when (<= 2 entry-len max-entry-length)
-      (multiple-value-bind (index flagp)
-			   (spell-try-word entry entry-len)
-	(when index
-	  (if flagp
-	      (setf (descriptor-ref (+ 2 index))
-		    (logandc2 (descriptor-ref (+ 2 index)) flagp))
-	      (let* ((hash (string-hash entry entry-len))
-		     (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash))
-					stored-hash-byte
-					(the fixnum entry-len)))
-		     (loc (rem hash (the fixnum *dictionary-size*)))
-		     (loc-contents (dictionary-ref loc)))
-		(declare (fixnum hash hash-and-len loc))
-		(cond ((zerop loc-contents) nil)
-		      ((found-entry-p loc-contents entry entry-len hash-and-len)
-		       (setf (dictionary-ref loc) -1))
-		      (t
-		       (hash2-loop (loop-loc loc-contents) loc hash
-				   nil
-				   (when (found-entry-p loc-contents entry
-							entry-len hash-and-len)
-				     (setf (dictionary-ref loop-loc) -1)
-				     (return -1))))))))))))
-
-(defun spell-root-flags (index)
-  "Return the flags associated with the root word corresponding to a
-   dictionary entry at index."
-  (let ((desc-word (descriptor-ref (+ 2 index)))
-	(result ()))
-    (declare (fixnum desc-word))
-    (dolist (ele flag-names-to-masks result)
-      (unless (zerop (logand (the fixnum (cdr ele)) desc-word))
-	(push (car ele) result)))))
-
-
-
-;;;; Growing Dictionary Structures
-
-;;; GROW-DESCRIPTORS grows the descriptors vector by 10%.
-;;;
-(defun grow-descriptors ()
-  (let* ((old-size (+ (the fixnum *descriptors-size*)
-		      (the fixnum *free-descriptor-elements*)))
-	 (new-size (truncate (* old-size 1.1)))
-	 (new-bytes (* new-size 2))
-	 (new-sap (allocate-bytes new-bytes)))
-    (declare (fixnum new-size old-size))
-    (sap-replace new-sap *descriptors* 0 0
-		 (* 2 (the fixnum *descriptors-size*)))
-    (deallocate-bytes (system-address *descriptors*) (* 2 old-size))
-    (setf *free-descriptor-elements*
-	  (- new-size (the fixnum *descriptors-size*)))
-    (setf *descriptors* new-sap)))
-
-;;; GROW-STRING-TABLE grows the string table by 10%.
-;;;
-(defun grow-string-table ()
-  (let* ((old-size (+ (the fixnum *string-table-size*)
-		      (the fixnum *free-string-table-bytes*)))
-	 (new-size (truncate (* old-size 1.1)))
-	 (new-sap (allocate-bytes new-size)))
-    (declare (fixnum new-size old-size))
-    (sap-replace new-sap *string-table* 0 0 *string-table-size*)
-    (setf *free-string-table-bytes*
-	  (- new-size (the fixnum *string-table-size*)))
-    (deallocate-bytes (system-address *string-table*) old-size)
-    (setf *string-table* new-sap)))
diff --git a/hemlock/spell-build.lisp b/hemlock/spell-build.lisp
deleted file mode 100644
index 4bc7aa287fec40447a76a62c8cfc072fdb4c1a12..0000000000000000000000000000000000000000
--- a/hemlock/spell-build.lisp
+++ /dev/null
@@ -1,248 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Spell -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spell-build.lisp,v 1.1.1.6 1991/11/09 03:05:46 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles
-;;;    Designed by Bill Chiles and Rob Maclachlan
-;;;
-
-;;; This file contains code to build a new binary dictionary file from
-;;; text in system space.  This code relies on implementation dependent
-;;; code from spell-rt.lisp.  Also, it is expected that spell-corr.lisp
-;;; and spell-aug.lisp have been loaded.  In order to compile this file,
-;;; you must first compile spell-rt, spell-corr.lisp, and spell-aug.lisp.
-
-;;; The text file must be in the following format:
-;;;      entry1/flag1/flag2/flag3
-;;;      entry2
-;;;      entry3/flag1/flag2/flag3/flag4/flag5.
-;;; The flags are single letter indicators of legal suffixes for the entry;
-;;; the available flags and their correct use may be found at the beginning
-;;; of spell-corr.lisp in the Hemlock sources.  There must be exactly one 
-;;; entry per line, and each line must be flushleft.
-
-;;; The dictionary is built in system space as three distinct 
-;;; blocks of memory: the dictionary which is a hash table whose elements
-;;; are one machine word or of type '(unsigned-byte 16); a descriptors
-;;; vector which is described below; and a string table.  After all the
-;;; entries are read in from the text file, one large block of memory is
-;;; validated, and the three structures are moved into it.  Then the file
-;;; is written.  When the large block of memory is validated, enough
-;;; memory is allocated to write the three vector such that they are page
-;;; aligned.  This is important for the speed it allows in growing the
-;;; "dictionary" when augmenting it from a user's text file (see
-;;; spell-aug.lisp).
-
-
-(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM"))
-
-
-
-;;;; Constants
-
-;;; This is an upper bound estimate of the number of stored entries in the
-;;; dictionary.  It should not be more than 21,845 because the dictionary
-;;; is a vector of type '(unsigned-byte 16), and the descriptors' vector
-;;; for the entries uses three '(unsigned-byte 16) elements per descriptor
-;;; unit.  See the beginning of Spell-Correct.Lisp.
-;;;
-(eval-when (compile load eval)
-
-(defconstant max-entry-count-estimate 15600)
-
-(defconstant new-dictionary-size 20011)
-
-(defconstant new-descriptors-size (1+ (* 3 max-entry-count-estimate)))
-
-(defconstant max-string-table-length (* 10 max-entry-count-estimate))
-
-); eval-when
-
-
-;;;; Hashing
-
-;;; These hashing macros are different from the ones in Spell-Correct.Lisp
-;;; simply because we are using separate space and global specials/constants.
-;;; Of course, they should be identical, but it doesn't seem worth cluttering
-;;; up Spell-Correct with macro generating macros for this file.
-
-(eval-when (compile eval)
-
-(defmacro new-hash2-increment (hash)
-  `(- new-dictionary-size
-      2
-      (the fixnum (rem ,hash (- new-dictionary-size 2)))))
-
-(defmacro new-hash2-loop (loc hash dictionary)
-  (let ((incr (gensym))
-	(loop-loc (gensym)))
-    `(let* ((,incr (new-hash2-increment ,hash))
-	    (,loop-loc ,loc))
-       (declare (fixnum ,incr ,loop-loc))
-       (loop (setf ,loop-loc
-		   (rem (+ ,loop-loc ,incr) new-dictionary-size))
-	     (when (zerop (the fixnum (aref ,dictionary ,loop-loc)))
-	       (return ,loop-loc))
-	     (when (= ,loop-loc ,loc) (return nil))))))
-
-(defmacro new-hash-entry (entry entry-len dictionary)
-  (let ((hash (gensym))
-	(loc (gensym)))
-    `(let* ((,hash (string-hash ,entry ,entry-len))
-	    (,loc (rem ,hash new-dictionary-size)))
-       (declare (fixnum ,loc))
-       (cond ((not (zerop (the fixnum (aref ,dictionary ,loc))))
-	      (incf *collision-count*)
-	      (new-hash2-loop ,loc ,hash ,dictionary))
-	     (t ,loc)))))
-
-) ;eval-when
-
-
-
-;;;; Build-Dictionary
-
-;;; An interesting value when building an initial dictionary.
-(defvar *collision-count* 0)
-
-(defvar *new-dictionary*)
-(defvar *new-descriptors*)
-(defvar *new-string-table*)
-
-(defun build-dictionary (input output &optional save-structures-p)
-  (let ((dictionary (make-array new-dictionary-size
-				:element-type '(unsigned-byte 16)))
-	(descriptors (make-array new-descriptors-size
-				:element-type '(unsigned-byte 16)))
-	(string-table (make-string max-string-table-length)))
-    (write-line "Reading dictionary ...")
-    (force-output)
-    (setf *collision-count* 0)
-    (multiple-value-bind (entry-count string-table-length)
-			 (read-initial-dictionary input dictionary
-						  descriptors string-table)
-      (write-line "Writing dictionary ...")
-      (force-output)
-      (write-dictionary output dictionary descriptors entry-count
-			string-table string-table-length)
-      (when save-structures-p
-	(setf *new-dictionary* dictionary)
-	(setf *new-descriptors* descriptors)
-	(setf *new-string-table* string-table))
-      (format t "~D entries processed with ~D collisions."
-	      entry-count *collision-count*))))
-
-(defun read-initial-dictionary (f dictionary descriptors string-table)
-  (let* ((filename (pathname f))
-	 (s (open filename :direction :input :if-does-not-exist nil)))
-    (unless s (error "File ~S does not exist." f))
-    (multiple-value-prog1
-     (let ((descriptor-ptr 1)
-	   (string-ptr 0)
-	   (entry-count 0))
-       (declare (fixnum descriptor-ptr string-ptr entry-count))
-       (loop (multiple-value-bind (line eofp) (read-line s nil nil)
-	       (declare (type (or null simple-string) line))
-	       (unless line (return (values entry-count string-ptr)))
-	       (incf entry-count)
-	       (when (> entry-count max-entry-count-estimate)
-		 (error "There are too many entries in text file!~%~
-			Please change constants in spell-build.lisp, ~
-			recompile the file, and reload it.~%~
-			Be sure to understand the constraints of permissible ~
-			values."))
-	       (let ((flags (or (position #\/ line :test #'char=) (length line))))
-		 (declare (fixnum flags))
-		 (cond ((> flags max-entry-length)
-			(format t "Entry ~s too long." (subseq line 0 flags))
-			(force-output))
-		       (t (let ((new-string-ptr (+ string-ptr flags)))
-			    (declare (fixnum new-string-ptr))
-			    (when (> new-string-ptr max-string-table-length)
-			      (error "Spell string table overflow!~%~
-				     Please change constants in ~
-				     spell-build.lisp, recompile the file, ~
-				     and reload it.~%~
-				     Be sure to understand the constraints ~
-				     of permissible values."))
-			    (spell-place-entry line flags
-					       dictionary descriptors string-table
-					       descriptor-ptr string-ptr)
-			    (incf descriptor-ptr 3)
-			    (setf string-ptr new-string-ptr)))))
-	       (when eofp (return (values entry-count string-ptr))))))
-     (close s))))
-
-(defun spell-place-entry (line word-end dictionary descriptors string-table
-			       descriptor-ptr string-ptr)
-  (declare (simple-string line string-table)
-	   (fixnum word-end descriptor-ptr string-ptr)
-	   (type (array (unsigned-byte 16) (*)) dictionary descriptors))
-  (nstring-upcase line :end word-end)
-  (let* ((hash-loc (new-hash-entry line word-end dictionary))
-	 (descriptor-ptr+1 (1+ descriptor-ptr))
-	 (descriptor-ptr+2 (1+ descriptor-ptr+1)))
-    (unless hash-loc (error "Dictionary Overflow!"))
-    (setf (aref dictionary hash-loc) descriptor-ptr)
-    (setf (aref descriptors descriptor-ptr)
-	  (dpb (the fixnum
-		    (ldb new-hash-byte (string-hash line word-end)))
-	       stored-hash-byte
-	       word-end))
-    (setf (aref descriptors descriptor-ptr+1)
-	  (ldb whole-index-low-byte string-ptr))
-    (setf (aref descriptors descriptor-ptr+2)
-	  (dpb (the fixnum (ldb whole-index-high-byte string-ptr))
-	       stored-index-high-byte
-	       0))
-    (new-add-flags descriptors descriptor-ptr+2 line word-end)
-    (replace string-table line :start1 string-ptr :end2 word-end)))
-
-(defun new-add-flags (descriptors loc line word-end)
-  (declare (simple-string line)
-	   (fixnum word-end)
-	   (type (array (unsigned-byte 16) (*)) descriptors))
-  (do ((flag (1+ word-end) (+ 2 flag))
-       (line-end (length line)))
-      ((>= flag line-end))
-    (declare (fixnum flag line-end))
-    (let ((flag-mask (flag-mask (schar line flag))))
-      (declare (fixnum flag-mask))
-      (if (zerop flag-mask)
-	  (format t "Illegal flag ~S on word ~S."
-		  (schar line flag) (subseq line 0 word-end))
-	  (setf (aref descriptors loc)
-		(logior flag-mask (aref descriptors loc)))))))
-
-(defun write-dictionary (f dictionary descriptors entry-count
-			   string-table string-table-length)
-  (declare (type (array (unsigned-byte 16) (*)) dictionary descriptors)
-	   (simple-string string-table)
-	   (fixnum string-table-length))
-  (let ((filename (ext:unix-namestring (pathname f) nil)))
-    (with-open-file (s filename :direction :output
-		       :element-type '(unsigned-byte 16)
-		       :if-exists :overwrite
-		       :if-does-not-exist :create)
-      (let ((descriptors-size (1+ (* 3 entry-count))))
-	(write-byte magic-file-id s)
-	(write-byte new-dictionary-size s)
-	(write-byte descriptors-size s)
-	(write-byte (ldb whole-index-low-byte string-table-length) s)
-	(write-byte (ldb whole-index-high-byte string-table-length) s)
-	(dotimes (i new-dictionary-size)
-	  (write-byte (aref dictionary i) s))
-	(dotimes (i descriptors-size)
-	  (write-byte (aref descriptors i) s))))
-    (with-open-file (s f :direction :output :element-type 'base-char
-		         :if-exists :append)
-      (write-string string-table s :end string-table-length))))
diff --git a/hemlock/spell-corr.lisp b/hemlock/spell-corr.lisp
deleted file mode 100644
index 315d960a026c0276906c2e3b4ba3785fc03995a6..0000000000000000000000000000000000000000
--- a/hemlock/spell-corr.lisp
+++ /dev/null
@@ -1,815 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Spell -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spell-corr.lisp,v 1.1.1.6 1991/09/04 14:08:30 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles
-;;;    Designed by Bill Chiles and Rob Maclachlan
-;;;
-
-;;;      This is the file that deals with checking and correcting words
-;;; using a dictionary read in from a binary file.  It has been written
-;;; from the basic ideas used in Ispell (on DEC-20's) which originated as
-;;; Spell on the ITS machines at MIT.  There are flags which have proper
-;;; uses defined for them that indicate permissible suffixes to entries.
-;;; This allows for about three times as many known words than are actually
-;;; stored.  When checking the spelling of a word, first it is looked up;
-;;; if this fails, then possible roots are looked up, and if any has the
-;;; appropriate suffix flag, then the word is considered to be correctly
-;;; spelled.  For an unknown word, the following rules define "close" words
-;;; which are possible corrections:
-;;;    1] two adjacent letters are transposed to form a correct spelling;
-;;;    2] one letter is changed to form a correct spelling;
-;;;    3] one letter is added to form a correct spelling; and/or
-;;;    4] one letter is removed to form a correct spelling. 
-;;; There are two restrictions on the length of a word in regards to its
-;;; worthiness of recognition: it must be at least more than two letters
-;;; long, and if it has a suffix, then it must be at least four letters
-;;; long.  More will be said about this when the flags are discussed.
-;;;      This is implemented in as tense a fashion as possible, and it uses
-;;; implementation dependent code from Spell-RT.Lisp to accomplish this.
-;;; In general the file I/O and structure accesses encompass the system
-;;; dependencies.
-
-;;;      This next section will discuss the storage of the dictionary
-;;; information.  There are three data structures that "are" the
-;;; dictionary: a hash table, descriptors table, and a string table.  The
-;;; hash table is a vector of type '(unsigned-byte 16), whose elements
-;;; point into the descriptors table.  This is a cyclic hash table to
-;;; facilitate dumping it to a file.  The descriptors table (also of type
-;;; '(unsigned-byte 16)) dedicates three elements to each entry in the
-;;; dictionary.  Each group of three elements has the following organization
-;;; imposed on them:
-;;;    ----------------------------------------------
-;;;    |  15..5  hash code  |      4..0 length      |
-;;;    ----------------------------------------------
-;;;    |           15..0 character index            |
-;;;    ----------------------------------------------
-;;;    |  15..14 character index  |  13..0 flags    |
-;;;    ----------------------------------------------
-;;; "Length" is the number of characters in the entry; "hash code" is some
-;;; eleven bits from the hash code to allow for quicker lookup, "flags"
-;;; indicate possible suffixes for the basic entry, and "character index"
-;;; is the index of the start of the entry in the string table.
-;;;      This was originally adopted due to the Perq's word size (can you guess?
-;;; 16 bits, that's right).  Note the constraint that is placed on the number
-;;; of the entries, 21845, because the hash table could not point to more
-;;; descriptor units (16 bits of pointer divided by three).  Since a value of
-;;; zero as a hash table element indicates an empty location, the zeroth element
-;;; of the descriptors table must be unused (it cannot be pointed to).
-
-
-;;;      The following is a short discussion with examples of the correct
-;;; use of the suffix flags.  Let # and @ be symbols that can stand for any
-;;; single letter.  Upper case letters are constants.  "..." stands for any
-;;; string of zero or more letters,  but note that no word may exist in the
-;;; dictionary which is not at least 2 letters long, so, for example, FLY
-;;; may not be produced by placing the "Y" flag on "F".  Also, no flag is
-;;; effective unless the word that it creates is at least 4 letters long,
-;;; so, for example, WED may not be produced by placing the "D" flag on
-;;; "WE".  These flags and examples are from the Ispell documentation with
-;;; only slight modifications.  Here are the correct uses of the flags:
-;;; 
-;;; "V" flag:
-;;;         ...E => ...IVE  as in  create => creative
-;;;         if # .ne. E, then  ...# => ...#IVE  as in  prevent => preventive
-;;; 
-;;; "N" flag:
-;;;         ...E => ...ION  as in create => creation
-;;;         ...Y => ...ICATION  as in  multiply => multiplication
-;;;         if # .ne. E or Y, then  ...# => ...#EN  as in  fall => fallen
-;;; 
-;;; "X" flag:
-;;;         ...E => ...IONS  as in  create => creations
-;;;         ...Y => ...ICATIONS  as in  multiply => multiplications
-;;;         if # .ne. E or Y, ...# => ...#ENS  as in  weak => weakens
-;;; 
-;;; "H" flag:
-;;;         ...Y => ...IETH  as in  twenty => twentieth
-;;;         if # .ne. Y, then  ...# => ...#TH  as in  hundred => hundredth
-;;; 
-;;; "Y" FLAG:
-;;;         ... => ...LY  as in  quick => quickly
-;;; 
-;;; "G" FLAG:
-;;;         ...E => ...ING  as in  file => filing
-;;;         if # .ne. E, then  ...# => ...#ING  as in  cross => crossing
-;;; 
-;;; "J" FLAG"
-;;;         ...E => ...INGS  as in  file => filings
-;;;         if # .ne. E, then  ...# => ...#INGS  as in  cross => crossings
-;;; 
-;;; "D" FLAG:
-;;;         ...E => ...ED  as in  create => created
-;;;         if @ .ne. A, E, I, O, or U,
-;;;            then  ...@Y => ...@IED  as in  imply => implied
-;;;         if # = Y, and @ = A, E, I, O, or U,
-;;;            then  ...@# => ...@#ED  as in  convey => conveyed
-;;;         if # .ne. E or Y, then  ...# => ...#ED  as in  cross => crossed
-;;; 
-;;; "T" FLAG:
-;;;         ...E => ...EST  as in  late => latest
-;;;         if @ .ne. A, E, I, O, or U,
-;;;            then  ...@Y => ...@IEST  as in  dirty => dirtiest
-;;;         if # = Y, and @ = A, E, I, O, or U,
-;;;            then  ...@# => ...@#EST  as in  gray => grayest
-;;;         if # .ne. E or Y, then  ...# => ...#EST  as in  small => smallest
-;;; 
-;;; "R" FLAG:
-;;;         ...E => ...ER  as in  skate => skater
-;;;         if @ .ne. A, E, I, O, or U,
-;;;            then  ...@Y => ...@IER  as in  multiply => multiplier
-;;;         if # = Y, and @ = A, E, I, O, or U,
-;;;            then ...@# => ...@#ER  as in  convey => conveyer
-;;;         if # .ne. E or Y, then  ...# => ...#ER  as in  build => builder
-;;; 
-
-;;; "Z FLAG:
-;;;         ...E => ...ERS  as in  skate => skaters
-;;;         if @ .ne. A, E, I, O, or U,
-;;;            then  ...@Y => ...@IERS  as in  multiply => multipliers
-;;;         if # = Y, and @ = A, E, I, O, or U,
-;;;            then  ...@# => ...@#ERS  as in  slay => slayers
-;;;         if # .ne. E or Y, then  ...@# => ...@#ERS  as in  build => builders
-;;; 
-;;; "S" FLAG:
-;;;         if @ .ne. A, E, I, O, or U,
-;;;            then  ...@Y => ...@IES  as in  imply => implies
-;;;         if # .eq. S, X, Z, or H,
-;;;            then  ...# => ...#ES  as in  fix => fixes
-;;;         if # .ne. S, X, Z, H, or Y,
-;;;            then  ...# => ...#S  as in  bat => bats
-;;;         if # = Y, and @ = A, E, I, O, or U,
-;;;            then  ...@# => ...@#S  as in  convey => conveys
-;;; 
-;;; "P" FLAG:
-;;;         if # .ne. Y, or @ = A, E, I, O, or U,
-;;;            then  ...@# => ...@#NESS  as in  late => lateness and
-;;;                                             gray => grayness
-;;;         if @ .ne. A, E, I, O, or U,
-;;;            then  ...@Y => ...@INESS  as in  cloudy => cloudiness
-;;; 
-;;; "M" FLAG:
-;;;         ... => ...'S  as in DOG => DOG'S
-
-
-
-(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM"))
-
-(export '(spell-try-word spell-root-word spell-collect-close-words
-	  maybe-read-spell-dictionary correct-spelling max-entry-length))
-
-
-
-;;;; Some Constants
-
-(eval-when (compile load eval)
-
-;;; The next number (using 6 bits) is 63, and that's pretty silly because
-;;; "supercalafragalistic" is less than 31 characters long.
-;;;
-(defconstant max-entry-length 31
-  "This the maximum number of characters an entry may have.")
-
-;;; These are the flags (described above), and an entry is allowed a
-;;; certain suffix if the appropriate bit is on in the third element of
-;;; its descriptor unit (described above).
-;;;
-(defconstant V-mask (ash 1 13))
-(defconstant N-mask (ash 1 12))
-(defconstant X-mask (ash 1 11))
-(defconstant H-mask (ash 1 10))
-(defconstant Y-mask (ash 1 9))
-(defconstant G-mask (ash 1 8))
-(defconstant J-mask (ash 1 7))
-(defconstant D-mask (ash 1 6))
-(defconstant T-mask (ash 1 5))
-(defconstant R-mask (ash 1 4))
-(defconstant Z-mask (ash 1 3))
-(defconstant S-mask (ash 1 2))
-(defconstant P-mask (ash 1 1))
-(defconstant M-mask 1)
-
-
-;;; These are the eleven bits of a computed hash that are stored as part of
-;;; an entries descriptor unit.  The shifting constant is how much the
-;;; eleven bits need to be shifted to the right, so they take up the upper
-;;; eleven bits of one 16-bit element in a descriptor unit.
-;;;
-(defconstant new-hash-byte (byte 11 13))
-(defconstant stored-hash-byte (byte 11 5))
-
-
-;;; The next two constants are used to extract information from an entry's
-;;; descriptor unit.  The first is the two most significant bits of 18
-;;; bits that hold an index into the string table where the entry is
-;;; located.  If this is confusing, regard the diagram of the descriptor
-;;; units above.
-;;;
-(defconstant whole-index-high-byte (byte 2 16))
-(defconstant stored-index-high-byte (byte 2 14))
-(defconstant stored-length-byte (byte 5 0))
-
-
-); eval-when (compile load eval)
-
-
-;;;; Some Specials and Accesses
-
-;;; *spell-aeiou* will have bits on that represent the capital letters
-;;; A, E, I, O, and U to be used to determine if some word roots are legal
-;;; for looking up.
-;;;
-(defvar *aeiou*
-  (make-array 128 :element-type 'bit :initial-element 0))
-
-(setf (aref *aeiou* (char-code #\A)) 1)
-(setf (aref *aeiou* (char-code #\E)) 1)
-(setf (aref *aeiou* (char-code #\I)) 1)
-(setf (aref *aeiou* (char-code #\O)) 1)
-(setf (aref *aeiou* (char-code #\U)) 1)
-
-
-;;; *sxzh* will have bits on that represent the capital letters
-;;; S, X, Z, and H to be used to determine if some word roots are legal for
-;;; looking up.
-;;;
-(defvar *sxzh*
-  (make-array 128 :element-type 'bit :initial-element 0))
-
-(setf (aref *sxzh* (char-code #\S)) 1)
-(setf (aref *sxzh* (char-code #\X)) 1)
-(setf (aref *sxzh* (char-code #\Z)) 1)
-(setf (aref *sxzh* (char-code #\H)) 1)
-
-
-;;; SET-MEMBER-P will be used with *aeiou* and *sxzh* to determine if a
-;;; character is in the specified set.
-;;;
-(eval-when (compile eval)
-(defmacro set-member-p (char set)
-  `(not (zerop (the fixnum (aref (the simple-bit-vector ,set)
-				 (char-code ,char))))))
-) ;eval-when
-
-
-(defvar *dictionary*)
-(defvar *dictionary-size*)
-(defvar *descriptors*)
-(defvar *descriptors-size*)
-(defvar *string-table*)
-(defvar *string-table-size*)
-
-
-(eval-when (compile eval)
-
-;;; DICTIONARY-REF and DESCRIPTOR-REF are references to implementation
-;;; dependent structures.  *dictionary* and *descriptors* are "system
-;;; area pointers" as a result of the way the binary file is opened for
-;;; fast access.
-;;;
-(defmacro dictionary-ref (idx)
-  `(sapref *dictionary* ,idx))
-
-(defmacro descriptor-ref (idx)
-  `(sapref *descriptors* ,idx))
-
-
-;;; DESCRIPTOR-STRING-START access an entry's (indicated by idx)
-;;; descriptor unit (described at the beginning of the file) and returns
-;;; the start index of the entry in the string table.  The second of three
-;;; words in the descriptor holds the 16 least significant bits of 18, and
-;;; the top two bits of the third word are the 2 most significant bits.
-;;; These 18 bits are the index into the string table.
-;;;
-(defmacro descriptor-string-start (idx)
-  `(dpb (the fixnum (ldb stored-index-high-byte
-			 (the fixnum (descriptor-ref (+ 2 ,idx)))))
-	whole-index-high-byte
-	(the fixnum (descriptor-ref (1+ ,idx)))))
-
-) ;eval-when
-
-
-
-;;;; Top level Checking/Correcting
-
-;;; CORRECT-SPELLING can be called from top level to check/correct a words
-;;; spelling.  It is not used for any other purpose.
-;;; 
-(defun correct-spelling (word)
-  "Check/correct the spelling of word.  Output is done to *standard-output*."
-  (setf word (coerce word 'simple-string))
-  (let ((word (string-upcase (the simple-string word)))
-	(word-len (length (the simple-string word))))
-    (declare (simple-string word) (fixnum word-len))
-    (maybe-read-spell-dictionary)
-    (when (= word-len 1)
-      (error "Single character words are not in the dictionary."))
-    (when (> word-len max-entry-length)
-      (error "~A is too long for the dictionary." word))
-    (multiple-value-bind (idx used-flag-p)
-			 (spell-try-word word word-len)
-      (if idx
-	  (format t "Found it~:[~; because of ~A~]." used-flag-p
-		  (spell-root-word idx))
-	  (let ((close-words (spell-collect-close-words word)))
-	    (if close-words
-		(format *standard-output*
-			"The possible correct spelling~[~; is~:;s are~]:~
-			~:*~[~; ~{~A~}~;~{ ~A~^ and~}~:;~
-			~{~#[~; and~] ~A~^,~}~]."
-			(length close-words)
-			close-words)
-		(format *standard-output* "Word not found.")))))))
-
-
-(defvar *dictionary-read-p* nil)
-
-;;; MAYBE-READ-SPELL-DICTIONARY  --  Public
-;;;
-(defun maybe-read-spell-dictionary ()
-  "Read the spelling dictionary if it has not be read already."
-  (unless *dictionary-read-p* (read-dictionary)))
-
-
-(defun spell-root-word (index)
-  "Return the root word corresponding to a dictionary entry at index."
-  (let* ((start (descriptor-string-start index))
-	 (len (the fixnum (ldb stored-length-byte
-			       (the fixnum (descriptor-ref index)))))
-	 (result (make-string len)))
-    (declare (fixnum start len)
-	     (simple-string result))
-    (sap-replace result (the system-area-pointer *string-table*)
-		 start 0 len)
-    result))
-
-
-(eval-when (compile eval)
-(defmacro check-closeness (word word-len closeness-list)
-  `(if (spell-try-word ,word ,word-len)
-       (pushnew (subseq ,word 0 ,word-len) ,closeness-list :test #'string=)))
-) ;eval-when
-
-(defconstant spell-alphabet
-  (list #\A #\B #\C #\D #\E #\F #\G #\H
-	#\I #\J #\K #\L #\M #\N #\O #\P
-	#\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
-
-;;; SPELL-COLLECT-CLOSE-WORDS Returns a list of all "close" correctly spelled
-;;; words.  The definition of "close" is at the beginning of the file, and
-;;; there are four sections to this function which collect each of the four
-;;; different kinds of close words.
-;;; 
-(defun spell-collect-close-words (word)
-  "Returns a list of all \"close\" correctly spelled words.  This has the
-   same contraints as SPELL-TRY-WORD, which you have probably already called
-   if you are calling this."
-  (declare (simple-string word))
-  (let* ((word-len (length word))
-	 (word-len--1 (1- word-len))
-	 (word-len-+1 (1+ word-len))
-	 (result ())
-	 (correcting-buffer (make-string max-entry-length)))
-    (declare (simple-string correcting-buffer)
-	     (fixnum word-len word-len--1 word-len-+1))
-    (replace correcting-buffer word :end1 word-len :end2 word-len)
-
-    ;; Misspelled because one letter is different.
-    (dotimes (i word-len)
-      (do ((save-char (schar correcting-buffer i))
-	   (alphabet spell-alphabet (cdr alphabet)))
-	  ((null alphabet)
-	   (setf (schar correcting-buffer i) save-char))
-	(setf (schar correcting-buffer i) (car alphabet))
-	(check-closeness correcting-buffer word-len result)))
-
-    ;; Misspelled because two adjacent letters are transposed.
-    (dotimes (i word-len--1)
-      (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i)))
-      (check-closeness correcting-buffer word-len result)
-      (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i))))
-
-    ;; Misspelled because of extraneous letter.
-    (replace correcting-buffer word
-	     :start2 1 :end1 word-len--1 :end2 word-len)
-    (check-closeness correcting-buffer word-len--1 result)
-    (dotimes (i word-len--1)
-      (setf (schar correcting-buffer i) (schar word i))
-      (replace correcting-buffer word
-	       :start1 (1+ i) :start2 (+ i 2) :end1 word-len--1 :end2 word-len)
-      (check-closeness correcting-buffer word-len--1 result))
-
-    ;; Misspelled because a letter is missing.
-    (replace correcting-buffer word
-	     :start1 1 :end1 word-len-+1 :end2 word-len)
-    (dotimes (i word-len-+1)
-      (do ((alphabet spell-alphabet (cdr alphabet)))
-	  ((null alphabet)
-	   (rotatef (schar correcting-buffer i)
-		    (schar correcting-buffer (1+ i))))
-	(setf (schar correcting-buffer i) (car alphabet))
-	(check-closeness correcting-buffer word-len-+1 result)))
-    result))
-
-;;; SPELL-TRY-WORD The literal 4 is not a constant defined somewhere since it
-;;; is part of the definition of the function of looking up words.
-;;; TRY-WORD-ENDINGS relies on the guarantee that word-len is at least 4.
-;;; 
-(defun spell-try-word (word word-len)
-  "See if the word or an appropriate root is in the spelling dicitionary.
-   Word-len must be inclusively in the range 2..max-entry-length."
-  (or (lookup-entry word word-len)
-      (if (>= (the fixnum word-len) 4)
-	  (try-word-endings word word-len))))
-
-
-
-;;;; Divining Correct Spelling
-
-(eval-when (compile eval)
-
-(defmacro setup-root-buffer (word buffer root-len)
-  `(replace ,buffer ,word :end1 ,root-len :end2 ,root-len))
-
-(defmacro try-root (word root-len flag-mask)
-  (let ((result (gensym)))
-    `(let ((,result (lookup-entry ,word ,root-len)))
-       (if (and ,result (descriptor-flag ,result ,flag-mask))
-	   (return (values ,result ,flag-mask))))))
-
-;;; TRY-MODIFIED-ROOT is used for root words that become truncated
-;;; when suffixes are added (e.g., skate => skating).  Char-idx is the last
-;;; character in the root that has to typically be changed from a #\I to a
-;;; #\Y or #\E.
-;;;
-(defmacro try-modified-root (word buffer root-len flag-mask char-idx new-char)
-  (let ((root-word (gensym)))
-    `(let ((,root-word (setup-root-buffer ,word ,buffer ,root-len)))
-       (setf (schar ,root-word ,char-idx) ,new-char)
-       (try-root ,root-word ,root-len ,flag-mask))))
-
-) ;eval-when
-
-
-(defvar *rooting-buffer* (make-string max-entry-length))
-
-;;; TRY-WORD-ENDINGS takes a word that is at least of length 4 and
-;;; returns multiple values on success (the index where the word's root's
-;;; descriptor starts and :used-flag), otherwise nil.  It looks at
-;;; characters from the end to the beginning of the word to determine if it
-;;; has any known suffixes.  This is a VERY simple finite state machine
-;;; where all of the suffixes are narrowed down to one possible one in at
-;;; most two state changes.  This is a PROG form for speed, and in some sense,
-;;; readability.  The states of the machine are the flag names that denote
-;;; suffixes.  The two points of branching to labels are the very beginning
-;;; of the PROG and the S state.  This is a fairly straight forward
-;;; implementation of the flag rules presented at the beginning of this
-;;; file, with char-idx checks, so we do not index the string below zero.
-
-(defun try-word-endings (word word-len)
-  (declare (simple-string word)
-	   (fixnum word-len))
-  (prog* ((char-idx (1- word-len))
-	  (char (schar word char-idx))
-	  (rooting-buffer *rooting-buffer*)
-	  flag-mask)
-         (declare (simple-string rooting-buffer)
-		  (fixnum char-idx))
-         (case char
-	   (#\S (go S))        ;This covers over half of the possible endings
-	                       ;by branching off the second to last character
-	                       ;to other flag states that have plural endings.
-	   (#\R (setf flag-mask R-mask)		   ;"er" and "ier"
-		(go D-R-Z-FLAG))
-	   (#\T (go T-FLAG))			   ;"est" and "iest"
-	   (#\D (setf flag-mask D-mask)		   ;"ed" and "ied"
-	        (go D-R-Z-FLAG))
-	   (#\H (go H-FLAG))			   ;"th" and "ieth"
-	   (#\N (setf flag-mask N-mask)		   ;"ion", "ication", and "en"
-		(go N-X-FLAG))
-	   (#\G (setf flag-mask G-mask)		   ;"ing"
-		(go G-J-FLAG))
-	   (#\Y (go Y-FLAG))			   ;"ly"
-	   (#\E (go V-FLAG)))			   ;"ive"
-         (return nil)
-
-    S
-         (setf char-idx (1- char-idx))
-         (setf char (schar word char-idx))
-         (if (char= char #\Y)
-	     (if (set-member-p (schar word (1- char-idx)) *aeiou*)
-		 (try-root word (1+ char-idx) S-mask)
-		 (return nil))
-	     (if (not (set-member-p char *sxzh*))
-		 (try-root word (1+ char-idx) S-mask)))
-         (case char
-	   (#\E (go S-FLAG))                    ;"es" and "ies"
-	   (#\R (setf flag-mask Z-mask)		;"ers" and "iers"
-		(go D-R-Z-FLAG))
-	   (#\G (setf flag-mask J-mask)		;"ings"
-		(go G-J-FLAG))
-	   (#\S (go P-FLAG))			;"ness" and "iness"
-	   (#\N (setf flag-mask X-mask)		;"ions", "ications", and "ens"
-		(go N-X-FLAG))
-	   (#\' (try-root word char-idx M-mask)))
-         (return nil)
-
-    S-FLAG
-         (setf char-idx (1- char-idx))
-         (setf char (schar word char-idx))
-	 (if (set-member-p char *sxzh*)
-	     (try-root word (1+ char-idx) S-mask))
-         (if (and (char= char #\I)
-		  (not (set-member-p (schar word (1- char-idx)) *aeiou*)))
-	     (try-modified-root word rooting-buffer (1+ char-idx)
-				S-mask char-idx #\Y))
-         (return nil)
-
-    D-R-Z-FLAG
-         (if (char/= (schar word (1- char-idx)) #\E) (return nil))
-         (try-root word char-idx flag-mask)
-         (if (<= (setf char-idx (- char-idx 2)) 0) (return nil))
-         (setf char (schar word char-idx))
-         (if (char= char #\Y)
-	     (if (set-member-p (schar word (1- char-idx)) *aeiou*) 
-		 (try-root word (1+ char-idx) flag-mask)
-		 (return nil))
-	     (if (char/= (schar word char-idx) #\E)
-		 (try-root word (1+ char-idx) flag-mask)))
-         (if (and (char= char #\I)
-		  (not (set-member-p (schar word (1- char-idx)) *aeiou*)))
-	     (try-modified-root word rooting-buffer (1+ char-idx)
-				flag-mask char-idx #\Y))
-         (return nil)
-
-    P-FLAG
-         (if (or (char/= (schar word (1- char-idx)) #\E)
-		 (char/= (schar word (- char-idx 2)) #\N))
-	     (return nil))
-         (if (<= (setf char-idx (- char-idx 3)) 0) (return nil))
-         (setf char (schar word char-idx))
-         (if (char= char #\Y)
-	     (if (set-member-p (schar word (1- char-idx)) *aeiou*) 
-		 (try-root word (1+ char-idx) P-mask)
-		 (return nil)))
-         (try-root word (1+ char-idx) P-mask)
-         (if (and (char= char #\I)
-		  (not (set-member-p (schar word (1- char-idx)) *aeiou*)))
-	     (try-modified-root word rooting-buffer (1+ char-idx)
-				P-mask char-idx #\Y))
-         (return nil)
-
-    G-J-FLAG
-         (if (< char-idx 3) (return nil))
-         (setf char-idx (- char-idx 2))
-         (setf char (schar word char-idx))
-         (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\N))
-	     (return nil))
-         (if (char/= (schar word (1- char-idx)) #\E)
-	     (try-root word char-idx flag-mask))
-         (try-modified-root word rooting-buffer (1+ char-idx)
-			    flag-mask char-idx #\E)
-         (return nil)
-
-    N-X-FLAG
-         (setf char-idx (1- char-idx))
-         (setf char (schar word char-idx))
-         (cond ((char= char #\E)
-		(setf char (schar word (1- char-idx)))
-		(if (and (char/= char #\Y) (char/= char #\E))
-		    (try-root word char-idx flag-mask))
-		(return nil))
-	       ((char= char #\O)
-		(if (char= (schar word (1- char-idx)) #\I)
-		    (try-modified-root word rooting-buffer char-idx
-				       flag-mask (1- char-idx) #\E)
-		    (return nil))
-		(if (< char-idx 5) (return nil))
-		(if (or (char/= (schar word (- char-idx 2)) #\T)
-			(char/= (schar word (- char-idx 3)) #\A)
-			(char/= (schar word (- char-idx 4)) #\C)
-			(char/= (schar word (- char-idx 5)) #\I))
-		    (return nil)
-		    (setf char-idx (- char-idx 4)))
-		(try-modified-root word rooting-buffer char-idx
-				   flag-mask (1- char-idx) #\Y))
-	       (t (return nil)))
-
-    T-FLAG
-         (if (or (char/= (schar word (1- char-idx)) #\S)
-		 (char/= (schar word (- char-idx 2)) #\E))
-	     (return nil)
-	     (setf char-idx (1- char-idx)))
-         (try-root word char-idx T-mask)
-         (if (<= (setf char-idx (- char-idx 2)) 0) (return nil))
-         (setf char (schar word char-idx))
-         (if (char= char #\Y)
-	     (if (set-member-p (schar word (1- char-idx)) *aeiou*) 
-		 (try-root word (1+ char-idx) T-mask)
-		 (return nil))
-	     (if (char/= (schar word char-idx) #\E)
-		 (try-root word (1+ char-idx) T-mask)))
-         (if (and (char= char #\I)
-		  (not (set-member-p (schar word (1- char-idx)) *aeiou*)))
-	     (try-modified-root word rooting-buffer (1+ char-idx)
-				T-mask char-idx #\Y))
-         (return nil)
-
-    H-FLAG
-         (setf char-idx (1- char-idx))
-         (setf char (schar word char-idx))
-         (if (char/= char #\T) (return nil))
-         (if (char/= (schar word (1- char-idx)) #\Y)
-	     (try-root word char-idx H-mask))
-         (if (and (char= (schar word (1- char-idx)) #\E)
-		  (char= (schar word (- char-idx 2)) #\I))
-	     (try-modified-root word rooting-buffer (1- char-idx)
-				H-mask (- char-idx 2) #\Y))
-         (return nil)
-
-    Y-FLAG
-         (setf char-idx (1- char-idx))
-         (setf char (schar word char-idx))
-         (if (char= char #\L)
-	     (try-root word char-idx Y-mask))
-         (return nil)
-
-    V-FLAG
-         (setf char-idx (- char-idx 2))
-         (setf char (schar word char-idx))
-         (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\V))
-	     (return nil))
-         (if (char/= (schar word (1- char-idx)) #\E)
-	     (try-root word char-idx V-mask))
-         (try-modified-root word rooting-buffer (1+ char-idx)
-			    V-mask char-idx #\E)
-         (return nil)))
-
-
-
-;;; DESCRIPTOR-FLAG returns t or nil based on whether the flag is on.
-;;; From the diagram at the beginning of the file, we see that the flags
-;;; are stored two words off of the first word in the descriptor unit for
-;;; an entry.
-;;;
-(defun descriptor-flag (descriptor-start flag-mask)
-  (not (zerop
-	(the fixnum
-	     (logand
-	      (the fixnum (descriptor-ref (+ 2 (the fixnum descriptor-start))))
-	      (the fixnum flag-mask))))))
-
-
-;;;; Looking up Trials
-
-(eval-when (compile eval)
-
-;;; SPELL-STRING= determines if string1 and string2 are the same.  Before
-;;; it is called it is known that they are both of (- end1 0) length, and
-;;; string2 is in system space.  This is used in FOUND-ENTRY-P.
-;;;
-(defmacro spell-string= (string1 string2 end1 start2)
-  (let ((idx1 (gensym))
-	(idx2 (gensym)))
-    `(do ((,idx1 0 (1+ ,idx1))
-	  (,idx2 ,start2 (1+ ,idx2)))
-	 ((= ,idx1 ,end1) t)
-       (declare (fixnum ,idx1 ,idx2))
-       (unless (= (the fixnum (char-code (schar ,string1 ,idx1)))
-		  (the fixnum (string-sapref ,string2 ,idx2)))
-	 (return nil)))))
-
-;;; FOUND-ENTRY-P determines if entry is what is described at idx.
-;;; Hash-and-length is 16 bits that look just like the first word of any
-;;; entry's descriptor unit (see diagram at the beginning of the file).  If
-;;; the word stored at idx and entry have the same hash bits and length,
-;;; then we compare characters to see if they are the same.
-;;;
-(defmacro found-entry-p (idx entry entry-len hash-and-length)
-  `(if (= (the fixnum (descriptor-ref ,idx))
-	  (the fixnum ,hash-and-length))
-      (spell-string= ,entry *string-table* ,entry-len
-		     (descriptor-string-start ,idx))))
-
-(defmacro hash2-increment (hash)
-  `(- (the fixnum *dictionary-size*)
-      2
-      (the fixnum (rem ,hash (- (the fixnum *dictionary-size*) 2)))))
-
-(defmacro hash2-loop ((location-var contents-var)
-		       loc hash zero-contents-form
-		       &optional body-form (for-insertion-p nil))
-  (let ((incr (gensym)))
-    `(let* ((,incr (hash2-increment ,hash))
-	    (,location-var ,loc)
-	    (,contents-var 0))
-	(declare (fixnum ,location-var ,contents-var ,incr))
-       (loop (setf ,location-var
-		   (rem (+ ,location-var ,incr) (the fixnum *dictionary-size*)))
-	     (setf ,contents-var (dictionary-ref ,location-var))
-	     (if (zerop ,contents-var) (return ,zero-contents-form))
-	     ,@(if for-insertion-p
-		   `((if (= ,contents-var -1) (return ,zero-contents-form))))
-	     (if (= ,location-var ,loc) (return nil))
-	     ,@(if body-form `(,body-form))))))
-
-) ;eval-when
-
-
-;;; LOOKUP-ENTRY returns the index of the first element of entry's
-;;; descriptor unit on success, otherwise nil.  
-;;;
-(defun lookup-entry (entry &optional len)
-  (declare (simple-string entry))
-  (let* ((entry-len (or len (length entry)))
-	 (hash (string-hash entry entry-len))
-	 (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash))
-			    stored-hash-byte
-			    (the fixnum entry-len)))
-	 (loc (rem hash (the fixnum *dictionary-size*)))
-	 (loc-contents (dictionary-ref loc)))
-    (declare (fixnum entry-len hash hash-and-len loc))
-    (cond ((zerop loc-contents) nil)
-	  ((found-entry-p loc-contents entry entry-len hash-and-len)
-	   loc-contents)
-	  (t
-	   (hash2-loop (loop-loc loc-contents) loc hash
-	     nil
-	     (if (found-entry-p loc-contents entry entry-len hash-and-len)
-		 (return loc-contents)))))))
-
-;;;; Binary File Reading
-
-(defparameter default-binary-dictionary
-  "library:spell-dictionary.bin")
-
-;;; This is the first thing in a spell binary dictionary file to serve as a
-;;; quick check of its proposed contents.  This particular number is
-;;; "BILLS" on a calculator held upside-down.
-;;;
-(defconstant magic-file-id 57718)
-
-;;; These constants are derived from the order things are written to the
-;;; binary dictionary in Spell-Build.Lisp.
-;;;
-(defconstant magic-file-id-loc 0)
-(defconstant dictionary-size-loc 1)
-(defconstant descriptors-size-loc 2)
-(defconstant string-table-size-low-byte-loc 3)
-(defconstant string-table-size-high-byte-loc 4)
-(defconstant file-header-bytes 10)
-
-;;; Initially, there are no free descriptor elements and string table bytes,
-;;; but when these structures are grown, they are grown by more than that
-;;; which is necessary.
-;;;
-(defvar *free-descriptor-elements* 0)
-(defvar *free-string-table-bytes* 0)
-
-;;; READ-DICTIONARY opens the dictionary and sets up the global structures
-;;; manifesting the spelling dictionary.  When computing the start addresses
-;;; of these structures, we multiply by two since their sizes are in 16bit
-;;; lengths while the RT is 8bit-byte addressable.
-;;;
-(defun read-dictionary (&optional (f default-binary-dictionary))
-  (when *dictionary-read-p*
-    (setf *dictionary-read-p* nil)
-    (deallocate-bytes (system-address *dictionary*)
-		      (* 2 (the fixnum *dictionary-size*)))
-    (deallocate-bytes (system-address *descriptors*)
-		      (* 2 (the fixnum
-				(+ (the fixnum *descriptors-size*)
-				   (the fixnum *free-descriptor-elements*)))))
-    (deallocate-bytes (system-address *string-table*)
-		      (+ (the fixnum *string-table-size*)
-			 (the fixnum *free-string-table-bytes*))))
-  (setf *free-descriptor-elements* 0)
-  (setf *free-string-table-bytes* 0)
-  (let* ((fd (open-dictionary f))
-	 (header-info (read-dictionary-structure fd file-header-bytes)))
-    (unless (= (sapref header-info magic-file-id-loc) magic-file-id)
-      (deallocate-bytes (system-address header-info) file-header-bytes)
-      (error "File is not a dictionary: ~S." f))
-    (setf *dictionary-size* (sapref header-info dictionary-size-loc))
-    (setf *descriptors-size* (sapref header-info descriptors-size-loc))
-    (setf *string-table-size* (sapref header-info string-table-size-low-byte-loc))
-    (setf (ldb (byte 12 16) (the fixnum *string-table-size*))
-	  (the fixnum (sapref header-info string-table-size-high-byte-loc)))
-    (deallocate-bytes (system-address header-info) file-header-bytes)
-    (setf *dictionary*
-	  (read-dictionary-structure fd (* 2 (the fixnum *dictionary-size*))))
-    (setf *descriptors*
-	  (read-dictionary-structure fd (* 2 (the fixnum *descriptors-size*))))
-    (setf *string-table* (read-dictionary-structure fd *string-table-size*))
-    (setf *dictionary-read-p* t)
-    (close-dictionary fd)))
diff --git a/hemlock/spell-dictionary.text b/hemlock/spell-dictionary.text
deleted file mode 100644
index e5b9274fd1e8f7db98590a2155c02378c013c169..0000000000000000000000000000000000000000
--- a/hemlock/spell-dictionary.text
+++ /dev/null
@@ -1,15505 +0,0 @@
-AAAI
-ABACK
-ABAFT
-ABANDON/D/G/S
-ABANDONMENT
-ABASE/D/G/S
-ABASEMENT/S
-ABASH/D/G/S
-ABATE/D/R/G/S
-ABATEMENT/S
-ABBE
-ABBEY/M/S
-ABBOT/M/S
-ABBREVIATE/D/G/N/X/S
-ABDOMEN/M/S
-ABDOMINAL
-ABDUCT/D/S
-ABDUCTION/M/S
-ABDUCTOR/M/S
-ABED
-ABERRANT
-ABERRATION/S
-ABET/S
-ABETTED
-ABETTER
-ABETTING
-ABETTOR
-ABEYANCE
-ABHOR/S
-ABHORRED
-ABHORRENT
-ABHORRER
-ABHORRING
-ABIDE/D/G/S
-ABILITY/M/S
-ABJECT/P/Y
-ABJECTION/S
-ABJURE/D/G/S
-ABLATE/D/G/N/V/S
-ABLAZE
-ABLE/T/R
-ABLUTE
-ABLY
-ABNORMAL/Y
-ABNORMALITY/S
-ABOARD
-ABODE/M/S
-ABOLISH/D/R/Z/G/S
-ABOLISHMENT/M/S
-ABOLITION
-ABOLITIONIST/S
-ABOMINABLE
-ABORIGINAL
-ABORIGINE/M/S
-ABORT/D/G/V/S
-ABORTION/M/S
-ABORTIVE/Y
-ABOUND/D/G/S
-ABOUT
-ABOVE
-ABOVEGROUND
-ABRADE/D/G/S
-ABRASION/M/S
-ABREACTION/S
-ABREAST
-ABRIDGE/D/G/S
-ABRIDGMENT
-ABROAD
-ABROGATE/D/G/S
-ABRUPT/P/Y
-ABSCESS/D/S
-ABSCISSA/M/S
-ABSCOND/D/G/S
-ABSENCE/M/S
-ABSENT/D/G/Y/S
-ABSENTEE/M/S
-ABSENTEEISM
-ABSENTIA
-ABSENTMINDED
-ABSINTHE
-ABSOLUTE/P/N/Y/S
-ABSOLVE/D/G/S
-ABSORB/D/R/G/S
-ABSORBENCY
-ABSORBENT
-ABSORPTION/M/S
-ABSORPTIVE
-ABSTAIN/D/R/G/S
-ABSTENTION/S
-ABSTINENCE
-ABSTRACT/P/D/G/Y/S
-ABSTRACTION/M/S
-ABSTRACTIONISM
-ABSTRACTIONIST
-ABSTRACTOR/M/S
-ABSTRUSE/P
-ABSURD/Y
-ABSURDITY/M/S
-ABUNDANCE
-ABUNDANT/Y
-ABUSE/D/G/V/S
-ABUT/S
-ABUTMENT
-ABUTTED
-ABUTTER/M/S
-ABUTTING
-ABYSMAL/Y
-ABYSS/M/S
-ACACIA
-ACADEMIA
-ACADEMIC/S
-ACADEMICALLY
-ACADEMY/M/S
-ACCEDE/D/S
-ACCELERATE/D/G/N/X/S
-ACCELERATOR/S
-ACCELEROMETER/M/S
-ACCENT/D/G/S
-ACCENTUAL
-ACCENTUATE/D/G/N/S
-ACCEPT/D/R/Z/G/S
-ACCEPTABILITY
-ACCEPTABLE
-ACCEPTABLY
-ACCEPTANCE/M/S
-ACCEPTOR/M/S
-ACCESS/D/G/S
-ACCESSIBILITY
-ACCESSIBLE
-ACCESSIBLY
-ACCESSION/M/S
-ACCESSOR/M/S
-ACCESSORY/M/S
-ACCIDENT/M/S
-ACCIDENTAL/Y
-ACCLAIM/D/G/S
-ACCLAMATION
-ACCLIMATE/D/G/S
-ACCLIMATIZATION
-ACCLIMATIZED
-ACCOLADE/S
-ACCOMMODATE/D/G/N/X/S
-ACCOMPANIMENT/M/S
-ACCOMPANIST/M/S
-ACCOMPANY/D/G/S
-ACCOMPLICE/S
-ACCOMPLISH/D/R/Z/G/S
-ACCOMPLISHMENT/M/S
-ACCORD/D/R/Z/G/S
-ACCORDANCE
-ACCORDINGLY
-ACCORDION/M/S
-ACCOST/D/G/S
-ACCOUNT/D/G/S
-ACCOUNTABILITY
-ACCOUNTABLE
-ACCOUNTABLY
-ACCOUNTANCY
-ACCOUNTANT/M/S
-ACCOUTREMENT/S
-ACCREDIT/D
-ACCREDITATION/S
-ACCRETION/M/S
-ACCRUE/D/G/S
-ACCULTURATE/D/G/N/S
-ACCUMULATE/D/G/N/X/S
-ACCUMULATOR/M/S
-ACCURACY/S
-ACCURATE/P/Y
-ACCURSED
-ACCUSAL
-ACCUSATION/M/S
-ACCUSATIVE
-ACCUSE/D/R/G/S
-ACCUSINGLY
-ACCUSTOM/D/G/S
-ACE/M/S
-ACETATE
-ACETONE
-ACETYLENE
-ACHE/D/G/S
-ACHIEVABLE
-ACHIEVE/D/R/Z/G/S
-ACHIEVEMENT/M/S
-ACHILLES
-ACID/Y/S
-ACIDIC
-ACIDITY/S
-ACIDULOUS
-ACKNOWLEDGE/D/R/Z/G/S
-ACKNOWLEDGMENT/M/S
-ACM
-ACME
-ACNE
-ACOLYTE/S
-ACORN/M/S
-ACOUSTIC/S
-ACOUSTICAL/Y
-ACOUSTICIAN
-ACQUAINT/D/G/S
-ACQUAINTANCE/M/S
-ACQUIESCE/D/G/S
-ACQUIESCENCE
-ACQUIRABLE
-ACQUIRE/D/G/S
-ACQUISITION/M/S
-ACQUISITIVENESS
-ACQUIT/S
-ACQUITTAL
-ACQUITTED
-ACQUITTER
-ACQUITTING
-ACRE/M/S
-ACREAGE
-ACRID
-ACRIMONIOUS
-ACRIMONY
-ACROBAT/M/S
-ACROBATIC/S
-ACRONYM/M/S
-ACROPOLIS
-ACROSS
-ACRYLIC
-ACT/D/G/V/S
-ACTINIUM
-ACTINOMETER/S
-ACTION/M/S
-ACTIVATE/D/G/N/X/S
-ACTIVATOR/M/S
-ACTIVELY
-ACTIVISM
-ACTIVIST/M/S
-ACTIVITY/M/S
-ACTOR/M/S
-ACTRESS/M/S
-ACTUAL/Y/S
-ACTUALITY/S
-ACTUALIZATION
-ACTUARIAL/Y
-ACTUATE/D/G/S
-ACTUATOR/M/S
-ACUITY
-ACUMEN
-ACUTE/P/Y
-ACYCLIC
-ACYCLICALLY
-AD
-ADAGE/S
-ADAGIO/S
-ADAMANT/Y
-ADAPT/D/R/Z/G/V/S
-ADAPTABILITY
-ADAPTABLE
-ADAPTATION/M/S
-ADAPTIVELY
-ADAPTOR/S
-ADD/D/R/Z/G/S
-ADDENDA
-ADDENDUM
-ADDICT/D/G/S
-ADDICTION/M/S
-ADDISON
-ADDITION/M/S
-ADDITIONAL/Y
-ADDITIVE/M/S
-ADDITIVITY
-ADDRESS/D/R/Z/G/S
-ADDRESSABILITY
-ADDRESSABLE
-ADDRESSEE/M/S
-ADDUCE/D/G/S
-ADDUCIBLE
-ADDUCT/D/G/S
-ADDUCTION
-ADDUCTOR
-ADEPT
-ADEQUACY/S
-ADEQUATE/Y
-ADHERE/D/R/Z/G/S
-ADHERENCE
-ADHERENT/M/S
-ADHESION/S
-ADHESIVE/M/S
-ADIABATIC
-ADIABATICALLY
-ADIEU
-ADJACENCY
-ADJACENT
-ADJECTIVE/M/S
-ADJOIN/D/G/S
-ADJOURN/D/G/S
-ADJOURNMENT
-ADJUDGE/D/G/S
-ADJUDICATE/D/G/S
-ADJUDICATION/M/S
-ADJUNCT/M/S
-ADJURE/D/G/S
-ADJUST/D/R/Z/G/S
-ADJUSTABLE
-ADJUSTABLY
-ADJUSTMENT/M/S
-ADJUSTOR/M/S
-ADJUTANT/S
-ADMINISTER/D/G/J/S
-ADMINISTRATION/M/S
-ADMINISTRATIVE/Y
-ADMINISTRATOR/M/S
-ADMIRABLE
-ADMIRABLY
-ADMIRAL/M/S
-ADMIRALTY
-ADMIRATION/S
-ADMIRE/D/R/Z/G/S
-ADMIRING/Y
-ADMISSIBILITY
-ADMISSIBLE
-ADMISSION/M/S
-ADMIT/S
-ADMITTANCE
-ADMITTED/Y
-ADMITTER/S
-ADMITTING
-ADMIX/D/S
-ADMIXTURE
-ADMONISH/D/G/S
-ADMONISHMENT/M/S
-ADMONITION/M/S
-ADO
-ADOBE
-ADOLESCENCE
-ADOLESCENT/M/S
-ADOPT/D/R/Z/G/V/S
-ADOPTION/M/S
-ADORABLE
-ADORATION
-ADORE/D/S
-ADORN/D/S
-ADORNMENT/M/S
-ADRENAL
-ADRENALINE
-ADRIFT
-ADROIT/P
-ADS
-ADSORB/D/G/S
-ADSORPTION
-ADULATION
-ADULT/M/S
-ADULTERATE/D/G/S
-ADULTERER/M/S
-ADULTEROUS/Y
-ADULTERY
-ADULTHOOD
-ADUMBRATE/D/G/S
-ADVANCE/D/G/S
-ADVANCEMENT/M/S
-ADVANTAGE/D/S
-ADVANTAGEOUS/Y
-ADVENT
-ADVENTIST/S
-ADVENTITIOUS
-ADVENTURE/D/R/Z/G/S
-ADVENTUROUS
-ADVERB/M/S
-ADVERBIAL
-ADVERSARY/M/S
-ADVERSE/Y
-ADVERSITY/S
-ADVERTISE/D/R/Z/G/S
-ADVERTISEMENT/M/S
-ADVICE
-ADVISABILITY
-ADVISABLE
-ADVISABLY
-ADVISE/D/R/Z/G/S
-ADVISEDLY
-ADVISEE/M/S
-ADVISEMENT/S
-ADVISOR/M/S
-ADVISORY
-ADVOCACY
-ADVOCATE/D/G/S
-AEGIS
-AERATE/D/G/N/S
-AERATOR/S
-AERIAL/M/S
-AEROACOUSTIC
-AEROBIC/S
-AERODYNAMIC/S
-AERONAUTIC/S
-AERONAUTICAL
-AEROSOL/S
-AEROSOLIZE
-AEROSPACE
-AESTHETIC/M/S
-AESTHETICALLY
-AFAR
-AFFABLE
-AFFAIR/M/S
-AFFECT/D/G/V/S
-AFFECTATION/M/S
-AFFECTINGLY
-AFFECTION/M/S
-AFFECTIONATE/Y
-AFFECTOR
-AFFERENT
-AFFIANCED
-AFFIDAVIT/M/S
-AFFILIATE/D/G/N/X/S
-AFFINITY/M/S
-AFFIRM/D/G/S
-AFFIRMATION/M/S
-AFFIRMATIVE/Y
-AFFIX/D/G/S
-AFFLICT/D/G/V/S
-AFFLICTION/M/S
-AFFLUENCE
-AFFLUENT
-AFFORD/D/G/S
-AFFORDABLE
-AFFRICATE/S
-AFFRIGHT
-AFFRONT/D/G/S
-AFGHAN/S
-AFGHANISTAN
-AFICIONADO
-AFIELD
-AFIRE
-AFLAME
-AFLOAT
-AFOOT
-AFORE
-AFOREMENTIONED
-AFORESAID
-AFORETHOUGHT
-AFOSR
-AFOUL
-AFRAID
-AFRESH
-AFRICA
-AFRICAN/S
-AFT/R
-AFTEREFFECT
-AFTERMATH
-AFTERMOST
-AFTERNOON/M/S
-AFTERSHOCK/S
-AFTERTHOUGHT/S
-AFTERWARD/S
-AGAIN
-AGAINST
-AGAPE
-AGAR
-AGATE/S
-AGE/D/R/Z/G/S
-AGELESS
-AGENCY/M/S
-AGENDA/M/S
-AGENT/M/S
-AGGLOMERATE/D/N/S
-AGGLUTINATE/D/G/N/S
-AGGLUTININ/S
-AGGRAVATE/D/N/S
-AGGREGATE/D/G/N/X/Y/S
-AGGRESSION/M/S
-AGGRESSIVE/P/Y
-AGGRESSOR/S
-AGGRIEVE/D/G/S
-AGHAST
-AGILE/Y
-AGILITY
-AGITATE/D/G/N/X/S
-AGITATOR/M/S
-AGLEAM
-AGLOW
-AGNOSTIC/M/S
-AGO
-AGOG
-AGONIZE/D/G/S
-AGONY/S
-AGRARIAN
-AGREE/D/R/Z/S
-AGREEABLE/P
-AGREEABLY
-AGREEING
-AGREEMENT/M/S
-AGRICULTURAL/Y
-AGRICULTURE
-AGUE
-AH
-AHEAD
-AI
-AID/D/G/S
-AIDE/D/G/S
-AIL/G
-AILERON/S
-AILMENT/M/S
-AIM/D/R/Z/G/S
-AIMLESS/Y
-AIR/D/R/Z/G/J/S
-AIRBAG/S
-AIRBORNE
-AIRCRAFT
-AIRDROP/S
-AIREDALE
-AIRFIELD/M/S
-AIRFLOW
-AIRFOIL/S
-AIRFRAME/S
-AIRILY
-AIRLESS
-AIRLIFT/M/S
-AIRLINE/R/S
-AIRLOCK/M/S
-AIRMAIL/S
-AIRMAN
-AIRMEN
-AIRPLANE/M/S
-AIRPORT/M/S
-AIRSHIP/M/S
-AIRSPACE
-AIRSPEED
-AIRSTRIP/M/S
-AIRWAY/M/S
-AIRY
-AISLE
-AJAR
-AKIMBO
-AKIN
-AL/M
-ALABAMA
-ALABAMIAN
-ALABASTER
-ALACRITY
-ALARM/D/G/S
-ALARMINGLY
-ALARMIST
-ALAS
-ALASKA
-ALBA
-ALBACORE
-ALBANIA
-ALBANIAN/S
-ALBEIT
-ALBUM/S
-ALBUMIN
-ALCHEMY
-ALCIBIADES
-ALCOHOL/M/S
-ALCOHOLIC/M/S
-ALCOHOLISM
-ALCOVE/M/S
-ALDEN
-ALDER
-ALDERMAN/M
-ALDERMEN
-ALE/V
-ALEE
-ALERT/P/D/R/Z/G/Y/S
-ALERTEDLY
-ALEXANDER/M
-ALFALFA
-ALFRED/M
-ALFRESCO
-ALGA
-ALGAE
-ALGAECIDE
-ALGEBRA/M/S
-ALGEBRAIC
-ALGEBRAICALLY
-ALGERIA
-ALGERIAN
-ALGINATE
-ALGOL
-ALGORITHM/M/S
-ALGORITHMIC
-ALGORITHMICALLY
-ALIAS/D/G/S
-ALIBI/M/S
-ALIEN/M/S
-ALIENATE/D/G/N/S
-ALIGHT
-ALIGN/D/G/S
-ALIGNMENT/S
-ALIKE
-ALIMENT/S
-ALIMONY
-ALKALI/M/S
-ALKALINE
-ALKALOID/M/S
-ALKYL
-ALL
-ALLAH/M
-ALLAY/D/G/S
-ALLEGATION/M/S
-ALLEGE/D/G/S
-ALLEGEDLY
-ALLEGIANCE/M/S
-ALLEGORIC
-ALLEGORICAL/Y
-ALLEGORY/M/S
-ALLEGRETTO/M/S
-ALLEGRO/M/S
-ALLELE/S
-ALLEMANDE
-ALLEN/M
-ALLERGIC
-ALLERGY/M/S
-ALLEVIATE/D/R/Z/G/N/S
-ALLEY/M/S
-ALLEYWAY/M/S
-ALLIANCE/M/S
-ALLIGATOR/M/S
-ALLITERATION/M/S
-ALLITERATIVE
-ALLOCATE/D/G/N/X/S
-ALLOCATOR/M/S
-ALLOPHONE/S
-ALLOPHONIC
-ALLOT/S
-ALLOTMENT/M/S
-ALLOTTED
-ALLOTTER
-ALLOTTING
-ALLOW/D/G/S
-ALLOWABLE
-ALLOWABLY
-ALLOWANCE/M/S
-ALLOY/M/S
-ALLUDE/D/G/S
-ALLURE/G
-ALLUREMENT
-ALLUSION/M/S
-ALLUSIVE/P
-ALLY/D/G/S
-ALMA
-ALMANAC/M/S
-ALMIGHTY
-ALMOND/M/S
-ALMONER
-ALMOST
-ALMS
-ALMSMAN
-ALNICO
-ALOE/S
-ALOFT
-ALOHA
-ALONE/P
-ALONG
-ALONGSIDE
-ALOOF/P
-ALOUD
-ALPHA
-ALPHABET/M/S
-ALPHABETIC/S
-ALPHABETICAL/Y
-ALPHABETIZE/D/G/S
-ALPHANUMERIC
-ALPINE
-ALPS
-ALREADY
-ALSO
-ALTAR/M/S
-ALTER/D/R/Z/G/S
-ALTERABLE
-ALTERATION/M/S
-ALTERCATION/M/S
-ALTERNATE/D/G/N/X/V/Y/S
-ALTERNATIVE/Y/S
-ALTERNATOR/M/S
-ALTHOUGH
-ALTITUDE/S
-ALTMODE
-ALTO/M/S
-ALTOGETHER
-ALTRUISM
-ALTRUIST
-ALTRUISTIC
-ALTRUISTICALLY
-ALUM
-ALUMINUM
-ALUMNA/M
-ALUMNAE
-ALUMNI
-ALUMNUS
-ALUNDUM
-ALVEOLAR
-ALVEOLI
-ALVEOLUS
-ALWAYS
-ALZHEIMER/M
-AM/N
-AMAIN
-AMALGAM/M/S
-AMALGAMATE/D/G/N/S
-AMANUENSIS
-AMASS/D/G/S
-AMATEUR/M/S
-AMATEURISH/P
-AMATEURISM
-AMATORY
-AMAZE/D/R/Z/G/S
-AMAZEDLY
-AMAZEMENT
-AMAZING/Y
-AMAZON/M/S
-AMBASSADOR/M/S
-AMBER
-AMBIANCE
-AMBIDEXTROUS/Y
-AMBIENT
-AMBIGUITY/M/S
-AMBIGUOUS/Y
-AMBITION/M/S
-AMBITIOUS/Y
-AMBIVALENCE
-AMBIVALENT/Y
-AMBLE/D/R/G/S
-AMBROSIAL
-AMBULANCE/M/S
-AMBULATORY
-AMBUSCADE
-AMBUSH/D/S
-AMDAHL/M
-AMELIA
-AMELIORATE/D/G
-AMENABLE
-AMEND/D/G/S
-AMENDMENT/M/S
-AMENITY/S
-AMENORRHEA
-AMERICA/M/S
-AMERICAN/M/S
-AMERICANA
-AMERICIUM
-AMIABLE
-AMICABLE
-AMICABLY
-AMID
-AMIDE
-AMIDST
-AMIGO
-AMINO
-AMISS
-AMITY
-AMMO
-AMMONIA
-AMMONIAC
-AMMONIUM
-AMMUNITION
-AMNESTY
-AMOEBA/M/S
-AMOK
-AMONG
-AMONGST
-AMORAL
-AMORALITY
-AMORIST
-AMOROUS
-AMORPHOUS/Y
-AMORTIZE/D/G/S
-AMOUNT/D/R/Z/G/S
-AMOUR
-AMP/Y/S
-AMPERE/S
-AMPERSAND/M/S
-AMPHETAMINE/S
-AMPHIBIAN/M/S
-AMPHIBIOUS/Y
-AMPHIBOLOGY
-AMPHITHEATER/M/S
-AMPLE
-AMPLIFY/D/R/Z/G/N/S
-AMPLITUDE/M/S
-AMPOULE/M/S
-AMPUTATE/D/G/S
-AMSTERDAM
-AMTRAK
-AMULET/S
-AMUSE/D/R/Z/G/S
-AMUSEDLY
-AMUSEMENT/M/S
-AMUSINGLY
-AMYL
-AN
-ANABAPTIST/M/S
-ANACHRONISM/M/S
-ANACHRONISTICALLY
-ANACONDA/S
-ANAEROBIC
-ANAESTHESIA
-ANAGRAM/M/S
-ANAL
-ANALOG
-ANALOGICAL
-ANALOGOUS/Y
-ANALOGUE/M/S
-ANALOGY/M/S
-ANALYSES
-ANALYSIS
-ANALYST/M/S
-ANALYTIC
-ANALYTICAL/Y
-ANALYTICITY/S
-ANALYZABLE
-ANALYZE/D/R/Z/G/S
-ANAPHORA
-ANAPHORIC
-ANAPHORICALLY
-ANAPLASMOSIS
-ANARCHIC
-ANARCHICAL
-ANARCHIST/M/S
-ANARCHY
-ANASTOMOSES
-ANASTOMOSIS
-ANASTOMOTIC
-ANATHEMA
-ANATOMIC
-ANATOMICAL/Y
-ANATOMY
-ANCESTOR/M/S
-ANCESTRAL
-ANCESTRY
-ANCHOR/D/G/S
-ANCHORAGE/M/S
-ANCHORITE
-ANCHORITISM
-ANCHOVY/S
-ANCIENT/Y/S
-ANCILLARY
-AND/Z/G
-ANDERSON/M
-ANDORRA
-ANDREW/M
-ANDY/M
-ANECDOTAL
-ANECDOTE/M/S
-ANECHOIC
-ANEMIA
-ANEMIC
-ANEMOMETER/M/S
-ANEMOMETRY
-ANEMONE
-ANESTHESIA
-ANESTHETIC/M/S
-ANESTHETICALLY
-ANESTHETIZE/D/G/S
-ANEW
-ANGEL/M/S
-ANGELIC
-ANGER/D/G/S
-ANGIOGRAPHY
-ANGLE/D/R/Z/G/S
-ANGLICAN/S
-ANGLICANISM
-ANGLOPHILIA
-ANGLOPHOBIA
-ANGOLA
-ANGRILY
-ANGRY/T/R
-ANGST
-ANGSTROM
-ANGUISH/D
-ANGULAR/Y
-ANHYDROUS/Y
-ANILINE
-ANIMAL/M/S
-ANIMATE/P/D/G/N/X/Y/S
-ANIMATEDLY
-ANIMATOR/M/S
-ANIMISM
-ANIMIZED
-ANIMOSITY
-ANION/M/S
-ANIONIC
-ANISE
-ANISEIKONIC
-ANISOTROPIC
-ANISOTROPY
-ANKLE/M/S
-ANNAL/S
-ANNEAL/G
-ANNEX/D/G/S
-ANNEXATION
-ANNIHILATE/D/G/N/S
-ANNIVERSARY/M/S
-ANNOTATE/D/G/N/X/S
-ANNOUNCE/D/R/Z/G/S
-ANNOUNCEMENT/M/S
-ANNOY/D/G/S
-ANNOYANCE/M/S
-ANNOYER/S
-ANNOYINGLY
-ANNUAL/Y/S
-ANNUITY
-ANNUL/S
-ANNULLED
-ANNULLING
-ANNULMENT/M/S
-ANNUM
-ANNUNCIATE/D/G/S
-ANNUNCIATOR/S
-ANODE/M/S
-ANODIZE/D/S
-ANOINT/D/G/S
-ANOMALOUS/Y
-ANOMALY/M/S
-ANOMIC
-ANOMIE
-ANON
-ANONYMITY
-ANONYMOUS/Y
-ANOREXIA
-ANOTHER/M
-ANSI
-ANSWER/D/R/Z/G/S
-ANSWERABLE
-ANT/M/S
-ANTAGONISM/S
-ANTAGONIST/M/S
-ANTAGONISTIC
-ANTAGONISTICALLY
-ANTAGONIZE/D/G/S
-ANTARCTIC
-ANTARCTICA
-ANTE
-ANTEATER/M/S
-ANTECEDENT/M/S
-ANTEDATE
-ANTELOPE/M/S
-ANTENNA/M/S
-ANTENNAE
-ANTERIOR
-ANTHEM/M/S
-ANTHER
-ANTHOLOGY/S
-ANTHONY
-ANTHRACITE
-ANTHROPOLOGICAL/Y
-ANTHROPOLOGIST/M/S
-ANTHROPOLOGY
-ANTHROPOMORPHIC
-ANTHROPOMORPHICALLY
-ANTI
-ANTIBACTERIAL
-ANTIBIOTIC/S
-ANTIBODY/S
-ANTIC/M/S
-ANTICIPATE/D/G/N/X/S
-ANTICIPATORY
-ANTICOAGULATION
-ANTICOMPETITIVE
-ANTIDISESTABLISHMENTARIANISM
-ANTIDOTE/M/S
-ANTIFORMANT
-ANTIFUNDAMENTALIST
-ANTIGEN/M/S
-ANTIHISTORICAL
-ANTIMICROBIAL
-ANTIMONY
-ANTINOMIAN
-ANTINOMY
-ANTIPATHY
-ANTIPHONAL
-ANTIPODE/M/S
-ANTIQUARIAN/M/S
-ANTIQUATE/D
-ANTIQUE/M/S
-ANTIQUITY/S
-ANTIREDEPOSITION
-ANTIRESONANCE
-ANTIRESONATOR
-ANTISEPTIC
-ANTISERA
-ANTISERUM
-ANTISLAVERY
-ANTISOCIAL
-ANTISUBMARINE
-ANTISYMMETRIC
-ANTISYMMETRY
-ANTITHESIS
-ANTITHETICAL
-ANTITHYROID
-ANTITOXIN/M/S
-ANTITRUST
-ANTLER/D
-ANUS
-ANVIL/M/S
-ANXIETY/S
-ANXIOUS/Y
-ANY
-ANYBODY
-ANYHOW
-ANYMORE
-ANYONE
-ANYPLACE
-ANYTHING
-ANYTIME
-ANYWAY
-ANYWHERE
-AORTA
-APACE
-APART
-APARTHEID
-APARTMENT/M/S
-APATHETIC
-APATHY
-APE/D/G/S
-APERIODIC
-APERIODICITY
-APERTURE
-APEX
-APHASIA
-APHASIC
-APHID/M/S
-APHONIC
-APHORISM/M/S
-APHRODITE
-APIARY/S
-APICAL
-APIECE
-APISH
-APLENTY
-APLOMB
-APOCALYPSE
-APOCALYPTIC
-APOCRYPHA
-APOCRYPHAL
-APOGEE/S
-APOLLO
-APOLLONIAN
-APOLOGETIC
-APOLOGETICALLY
-APOLOGIA
-APOLOGIST/M/S
-APOLOGIZE/D/G/S
-APOLOGY/M/S
-APOSTATE
-APOSTLE/M/S
-APOSTOLIC
-APOSTROPHE/S
-APOTHECARY
-APOTHEOSES
-APOTHEOSIS
-APPALACHIA
-APPALACHIAN/S
-APPALL/D/G
-APPALLINGLY
-APPANAGE
-APPARATUS
-APPAREL/D
-APPARENT/Y
-APPARITION/M/S
-APPEAL/D/R/Z/G/S
-APPEALINGLY
-APPEAR/D/R/Z/G/S
-APPEARANCE/S
-APPEASE/D/G/S
-APPEASEMENT
-APPELLANT/M/S
-APPELLATE
-APPEND/D/R/Z/G/S
-APPENDAGE/M/S
-APPENDICES
-APPENDICITIS
-APPENDIX/M/S
-APPERTAIN/S
-APPETITE/M/S
-APPETIZER
-APPETIZING
-APPLAUD/D/G/S
-APPLAUSE
-APPLE/M/S
-APPLEJACK
-APPLIANCE/M/S
-APPLICABILITY
-APPLICABLE
-APPLICANT/M/S
-APPLICATION/M/S
-APPLICATIVE/Y
-APPLICATOR/M/S
-APPLIQUE
-APPLY/D/R/Z/G/N/X/S
-APPOINT/D/R/Z/G/V/S
-APPOINTEE/M/S
-APPOINTMENT/M/S
-APPORTION/D/G/S
-APPORTIONMENT/S
-APPRAISAL/M/S
-APPRAISE/D/R/Z/G/S
-APPRAISINGLY
-APPRECIABLE
-APPRECIABLY
-APPRECIATE/D/G/N/X/V/S
-APPRECIATIVELY
-APPREHEND/D
-APPREHENSIBLE
-APPREHENSION/M/S
-APPREHENSIVE/P/Y
-APPRENTICE/D/S
-APPRENTICESHIP
-APPRISE/D/G/S
-APPROACH/D/R/Z/G/S
-APPROACHABILITY
-APPROACHABLE
-APPROBATE/N
-APPROPRIATE/P/D/G/N/X/Y/S
-APPROPRIATOR/M/S
-APPROVAL/M/S
-APPROVE/D/R/Z/G/S
-APPROVINGLY
-APPROXIMATE/D/G/N/X/Y/S
-APPURTENANCE/S
-APRICOT/M/S
-APRIL
-APRON/M/S
-APROPOS
-APSE
-APSIS
-APT/P/Y
-APTITUDE/S
-AQUA
-AQUARIA
-AQUARIUM
-AQUARIUS
-AQUATIC
-AQUEDUCT/M/S
-AQUEOUS
-AQUIFER/S
-ARAB/M/S
-ARABESQUE
-ARABIA
-ARABIAN/S
-ARABIC
-ARABLE
-ARACHNID/M/S
-ARBITER/M/S
-ARBITRARILY
-ARBITRARY/P
-ARBITRATE/D/G/N/S
-ARBITRATOR/M/S
-ARBOR/M/S
-ARBOREAL
-ARC/D/G/S
-ARCADE/D/M/S
-ARCANE
-ARCH/D/R/Z/G/Y/S
-ARCHAEOLOGICAL
-ARCHAEOLOGIST/M/S
-ARCHAEOLOGY
-ARCHAIC/P
-ARCHAICALLY
-ARCHAISM
-ARCHAIZE
-ARCHANGEL/M/S
-ARCHBISHOP
-ARCHDIOCESE/S
-ARCHENEMY
-ARCHEOLOGICAL
-ARCHEOLOGIST
-ARCHEOLOGY
-ARCHERY
-ARCHETYPE
-ARCHFOOL
-ARCHIPELAGO
-ARCHIPELAGOES
-ARCHITECT/M/S
-ARCHITECTONIC
-ARCHITECTURAL/Y
-ARCHITECTURE/M/S
-ARCHIVAL
-ARCHIVE/D/R/Z/G/S
-ARCHIVIST
-ARCLIKE
-ARCTIC
-ARDENT/Y
-ARDOR
-ARDUOUS/P/Y
-ARE
-AREA/M/S
-AREN'T
-ARENA/M/S
-ARGENTINA
-ARGO/S
-ARGON
-ARGONAUT/S
-ARGOT
-ARGUABLE
-ARGUABLY
-ARGUE/D/R/Z/G/S
-ARGUMENT/M/S
-ARGUMENTATION
-ARGUMENTATIVE
-ARIANISM
-ARIANIST/S
-ARID
-ARIDITY
-ARIES
-ARIGHT
-ARISE/R/G/J/S
-ARISEN
-ARISTOCRACY
-ARISTOCRAT/M/S
-ARISTOCRATIC
-ARISTOCRATICALLY
-ARISTOTELIAN
-ARISTOTLE
-ARITHMETIC/S
-ARITHMETICAL/Y
-ARITHMETIZE/D/S
-ARIZONA
-ARK
-ARKANSAS
-ARM/D/R/Z/G/S
-ARMADILLO/S
-ARMAGEDDON
-ARMAMENT/M/S
-ARMCHAIR/M/S
-ARMENIAN
-ARMFUL
-ARMHOLE
-ARMISTICE
-ARMLOAD
-ARMOR/D/R
-ARMORY
-ARMOUR
-ARMPIT/M/S
-ARMSTRONG
-ARMY/M/S
-AROMA/S
-AROMATIC
-AROSE
-AROUND
-AROUSAL
-AROUSE/D/G/S
-ARPA
-ARPANET
-ARPEGGIO/M/S
-ARRACK
-ARRAIGN/D/G/S
-ARRAIGNMENT/M/S
-ARRANGE/D/R/Z/G/S
-ARRANGEMENT/M/S
-ARRANT
-ARRAY/D/S
-ARREARS
-ARREST/D/R/Z/G/S
-ARRESTINGLY
-ARRESTOR/M/S
-ARRIVAL/M/S
-ARRIVE/D/G/S
-ARROGANCE
-ARROGANT/Y
-ARROGATE/D/G/N/S
-ARROW/D/S
-ARROWHEAD/M/S
-ARROYO/S
-ARSENAL/M/S
-ARSENIC
-ARSINE
-ARSON
-ART/M/S
-ARTEMIS
-ARTERIAL
-ARTERIOLAR
-ARTERIOLE/M/S
-ARTERIOSCLEROSIS
-ARTERY/M/S
-ARTFUL/P/Y
-ARTHOGRAM
-ARTHRITIS
-ARTHROPOD/M/S
-ARTICHOKE/M/S
-ARTICLE/M/S
-ARTICULATE/P/D/G/N/X/Y/S
-ARTICULATOR/S
-ARTICULATORY
-ARTIFACT/M/S
-ARTIFACTUALLY
-ARTIFICE/R/S
-ARTIFICIAL/P/Y
-ARTIFICIALITY/S
-ARTILLERIST
-ARTILLERY
-ARTISAN/M/S
-ARTIST/M/S
-ARTISTIC
-ARTISTICALLY
-ARTISTRY
-ARTLESS
-ARTWORK
-ARYAN
-AS
-ASBESTOS
-ASCEND/D/R/Z/G/S
-ASCENDANCY
-ASCENDANT
-ASCENDENCY
-ASCENDENT
-ASCENSION/S
-ASCENT
-ASCERTAIN/D/G/S
-ASCERTAINABLE
-ASCETIC/M/S
-ASCETICISM
-ASCII
-ASCOT
-ASCRIBABLE
-ASCRIBE/D/G/S
-ASCRIPTION
-ASEPTIC
-ASH/R/N/S
-ASHAMED/Y
-ASHMAN
-ASHORE
-ASHTRAY/M/S
-ASIA
-ASIAN/S
-ASIATIC
-ASIDE
-ASININE
-ASK/D/R/Z/G/S
-ASKANCE
-ASKEW
-ASLEEP
-ASOCIAL
-ASP/N
-ASPARAGUS
-ASPECT/M/S
-ASPERSION/M/S
-ASPHALT
-ASPHYXIA
-ASPIC
-ASPIRANT/M/S
-ASPIRATE/D/G/S
-ASPIRATION/M/S
-ASPIRATOR/S
-ASPIRE/D/G/S
-ASPIRIN/S
-ASS/M/S
-ASSAIL/D/G/S
-ASSAILANT/M/S
-ASSASSIN/M/S
-ASSASSINATE/D/G/N/X/S
-ASSAULT/D/G/S
-ASSAY/D/G
-ASSEMBLAGE/M/S
-ASSEMBLE/D/R/Z/G/S
-ASSEMBLY/M/S
-ASSENT/D/R/G/S
-ASSERT/D/R/Z/G/V/S
-ASSERTION/M/S
-ASSERTIVELY
-ASSERTIVENESS
-ASSESS/D/G/S
-ASSESSMENT/M/S
-ASSESSOR/S
-ASSET/M/S
-ASSIDUITY
-ASSIDUOUS/Y
-ASSIGN/D/R/Z/G/S
-ASSIGNABLE
-ASSIGNEE/M/S
-ASSIGNMENT/M/S
-ASSIMILATE/D/G/N/X/S
-ASSIST/D/G/S
-ASSISTANCE/S
-ASSISTANT/M/S
-ASSISTANTSHIP/S
-ASSOCIATE/D/G/N/X/V/S
-ASSOCIATIONAL
-ASSOCIATIVELY
-ASSOCIATIVITY
-ASSOCIATOR/M/S
-ASSONANCE
-ASSONANT
-ASSORT/D/S
-ASSORTMENT/M/S
-ASSUAGE/D/S
-ASSUME/D/G/S
-ASSUMPTION/M/S
-ASSURANCE/M/S
-ASSURE/D/R/Z/G/S
-ASSUREDLY
-ASSURINGLY
-ASSYRIAN
-ASSYRIOLOGY
-ASTATINE
-ASTER/M/S
-ASTERISK/M/S
-ASTEROID/M/S
-ASTEROIDAL
-ASTHMA
-ASTONISH/D/G/S
-ASTONISHINGLY
-ASTONISHMENT
-ASTOUND/D/G/S
-ASTRAL
-ASTRAY
-ASTRIDE
-ASTRINGENCY
-ASTRINGENT
-ASTRONAUT/M/S
-ASTRONAUTICS
-ASTRONOMER/M/S
-ASTRONOMICAL/Y
-ASTRONOMY
-ASTROPHYSICAL
-ASTROPHYSICS
-ASTUTE/P
-ASUNDER
-ASYLUM
-ASYMMETRIC
-ASYMMETRICALLY
-ASYMMETRY
-ASYMPTOMATICALLY
-ASYMPTOTE/M/S
-ASYMPTOTIC
-ASYMPTOTICALLY
-ASYNCHRONISM
-ASYNCHRONOUS/Y
-ASYNCHRONY
-AT
-ATAVISTIC
-ATE
-ATEMPORAL
-ATHEIST/M/S
-ATHEISTIC
-ATHENA
-ATHENIAN/S
-ATHENS
-ATHEROSCLEROSIS
-ATHLETE/M/S
-ATHLETIC/S
-ATHLETICISM
-ATLANTIC
-ATLAS
-ATMOSPHERE/M/S
-ATMOSPHERIC
-ATOLL/M/S
-ATOM/M/S
-ATOMIC/S
-ATOMICALLY
-ATOMIZATION
-ATOMIZE/D/G/S
-ATONAL/Y
-ATONE/D/S
-ATONEMENT
-ATOP
-ATROCIOUS/Y
-ATROCITY/M/S
-ATROPHIC
-ATROPHY/D/G/S
-ATTACH/D/R/Z/G/S
-ATTACHE/D/G/S
-ATTACHMENT/M/S
-ATTACK/D/R/Z/G/S
-ATTACKABLE
-ATTAIN/D/R/Z/G/S
-ATTAINABLE
-ATTAINABLY
-ATTAINMENT/M/S
-ATTEMPT/D/R/Z/G/S
-ATTEND/D/R/Z/G/S
-ATTENDANCE/M/S
-ATTENDANT/M/S
-ATTENDEE/M/S
-ATTENTION/M/S
-ATTENTIONAL
-ATTENTIONALITY
-ATTENTIVE/P/Y
-ATTENUATE/D/G/N/S
-ATTENUATOR/M/S
-ATTEST/D/G/S
-ATTIC/M/S
-ATTIRE/D/G/S
-ATTITUDE/M/S
-ATTITUDINAL
-ATTORNEY/M/S
-ATTRACT/D/G/V/S
-ATTRACTION/M/S
-ATTRACTIVELY
-ATTRACTIVENESS
-ATTRACTOR/M/S
-ATTRIBUTABLE
-ATTRIBUTE/D/G/N/X/V/S
-ATTRIBUTIVELY
-ATTRITION
-ATTUNE/D/G/S
-ATYPICAL/Y
-AUBURN
-AUCKLAND
-AUCTION
-AUCTIONEER/M/S
-AUDACIOUS/P/Y
-AUDACITY
-AUDIBLE
-AUDIBLY
-AUDIENCE/M/S
-AUDIO
-AUDIOGRAM/M/S
-AUDIOLOGICAL
-AUDIOLOGIST/M/S
-AUDIOLOGY
-AUDIOMETER/S
-AUDIOMETRIC
-AUDIOMETRY
-AUDIT/D/G/S
-AUDITION/D/M/G/S
-AUDITOR/M/S
-AUDITORIUM
-AUDITORY
-AUDUBON
-AUGER/M/S
-AUGHT
-AUGMENT/D/G/S
-AUGMENTATION
-AUGUR/S
-AUGUST/P/Y
-AUGUSTA
-AUNT/M/S
-AURA/M/S
-AURAL/Y
-AUREOLE
-AUREOMYCIN
-AURORA
-AUSCULTATE/D/G/N/X/S
-AUSPICE/S
-AUSPICIOUS/Y
-AUSTERE/Y
-AUSTERITY
-AUSTIN
-AUSTRALIA
-AUSTRALIAN
-AUSTRIA
-AUSTRIAN
-AUTHENTIC
-AUTHENTICALLY
-AUTHENTICATE/D/G/N/X/S
-AUTHENTICATOR/S
-AUTHENTICITY
-AUTHOR/D/G/S
-AUTHORITARIAN
-AUTHORITARIANISM
-AUTHORITATIVE/Y
-AUTHORITY/M/S
-AUTHORIZATION/M/S
-AUTHORIZE/D/R/Z/G/S
-AUTHORSHIP
-AUTISM
-AUTISTIC
-AUTO/M/S
-AUTOBIOGRAPHIC
-AUTOBIOGRAPHICAL
-AUTOBIOGRAPHY/M/S
-AUTOCOLLIMATOR
-AUTOCORRELATE/N
-AUTOCRACY/S
-AUTOCRAT/M/S
-AUTOCRATIC
-AUTOCRATICALLY
-AUTOFLUORESCENCE
-AUTOGRAPH/D/G
-AUTOGRAPHS
-AUTOMATA
-AUTOMATE/D/G/N/S
-AUTOMATIC
-AUTOMATICALLY
-AUTOMATON
-AUTOMOBILE/M/S
-AUTOMOTIVE
-AUTONAVIGATOR/M/S
-AUTONOMIC
-AUTONOMOUS/Y
-AUTONOMY
-AUTOPILOT/M/S
-AUTOPSY/D/S
-AUTOREGRESSIVE
-AUTOSUGGESTIBILITY
-AUTOTRANSFORMER
-AUTUMN/M/S
-AUTUMNAL
-AUXILIARY/S
-AVAIL/D/R/Z/G/S
-AVAILABILITY/S
-AVAILABLE
-AVAILABLY
-AVALANCHE/D/G/S
-AVANT
-AVARICE
-AVARICIOUS/Y
-AVE
-AVENGE/D/R/G/S
-AVENUE/M/S
-AVER/S
-AVERAGE/D/G/S
-AVERRED
-AVERRER
-AVERRING
-AVERSE/N
-AVERSION/M/S
-AVERT/D/G/S
-AVIAN
-AVIARY/S
-AVIATION
-AVIATOR/M/S
-AVID/Y
-AVIDITY
-AVIONIC/S
-AVOCADO/S
-AVOCATION/M/S
-AVOID/D/R/Z/G/S
-AVOIDABLE
-AVOIDABLY
-AVOIDANCE
-AVOUCH
-AVOW/D/S
-AWAIT/D/G/S
-AWAKE/G/S
-AWAKEN/D/G/S
-AWARD/D/R/Z/G/S
-AWARE/P
-AWASH
-AWAY
-AWE/D
-AWESOME
-AWFUL/P/Y
-AWHILE
-AWKWARD/P/Y
-AWL/M/S
-AWNING/M/S
-AWOKE
-AWRY
-AX/D/R/Z/G/S
-AXE/D/S
-AXIAL/Y
-AXIOLOGICAL
-AXIOM/M/S
-AXIOMATIC
-AXIOMATICALLY
-AXIOMATIZATION/M/S
-AXIOMATIZE/D/G/S
-AXIS
-AXLE/M/S
-AXOLOTL/M/S
-AXON/M/S
-AYE/S
-AZALEA/M/S
-AZIMUTH/M
-AZIMUTHS
-AZURE
-BABBLE/D/G/S
-BABE/M/S
-BABEL/M
-BABY/D/G/S
-BABYHOOD
-BABYISH
-BACCALAUREATE
-BACH/M
-BACHELOR/M/S
-BACILLI
-BACILLUS
-BACK/D/R/Z/G/S
-BACKACHE/M/S
-BACKARROW/S
-BACKBEND/M/S
-BACKBONE/M/S
-BACKDROP/M/S
-BACKGAMMON
-BACKGROUND/M/S
-BACKLASH
-BACKLOG/M/S
-BACKPACK/M/S
-BACKPLANE/M/S
-BACKPOINTER/M/S
-BACKPROPAGATE/D/G/N/X/S
-BACKSCATTER/D/G/S
-BACKSLASH/S
-BACKSPACE/D/S
-BACKSTAGE
-BACKSTAIRS
-BACKSTITCH/D/G/S
-BACKTRACK/D/R/Z/G/S
-BACKUP/S
-BACKWARD/P/S
-BACKWATER/M/S
-BACKWOODS
-BACKYARD/M/S
-BACON
-BACTERIA
-BACTERIAL
-BACTERIUM
-BAD/P/Y
-BADE
-BADGE/R/Z/S
-BADGER'S
-BADGERED
-BADGERING
-BADLANDS
-BADMINTON
-BAFFLE/D/R/Z/G
-BAG/M/S
-BAGATELLE/M/S
-BAGEL/M/S
-BAGGAGE
-BAGGED
-BAGGER/M/S
-BAGGING
-BAGGY
-BAGPIPE/M/S
-BAH
-BAIL/G
-BAILIFF/M/S
-BAIT/D/R/G/S
-BAKE/D/R/Z/G/S
-BAKERY/M/S
-BAKLAVA
-BALALAIKA/M/S
-BALANCE/D/R/Z/G/S
-BALCONY/M/S
-BALD/P/G/Y
-BALE/R/S
-BALEFUL
-BALK/D/G/S
-BALKAN/S
-BALKANIZE/D/G
-BALKY/P
-BALL/D/R/Z/G/S
-BALLAD/M/S
-BALLAST/M/S
-BALLERINA/M/S
-BALLET/M/S
-BALLGOWN/M/S
-BALLISTIC/S
-BALLOON/D/R/Z/G/S
-BALLOT/M/S
-BALLPARK/M/S
-BALLPLAYER/M/S
-BALLROOM/M/S
-BALLYHOO
-BALM/M/S
-BALMY
-BALSA
-BALSAM
-BALTIC
-BALUSTRADE/M/S
-BAMBOO
-BAN/M/S
-BANAL/Y
-BANANA/M/S
-BAND/D/G/S
-BANDAGE/D/G/S
-BANDIT/M/S
-BANDLIMIT/D/G/S
-BANDPASS
-BANDSTAND/M/S
-BANDWAGON/M/S
-BANDWIDTH
-BANDWIDTHS
-BANDY/D/G/S
-BANE
-BANEFUL
-BANG/D/G/S
-BANGLADESH
-BANGLE/M/S
-BANISH/D/G/S
-BANISHMENT
-BANISTER/M/S
-BANJO/M/S
-BANK/D/R/Z/G/S
-BANKRUPT/D/G/S
-BANKRUPTCY/M/S
-BANNED
-BANNER/M/S
-BANNING
-BANQUET/G/J/S
-BANSHEE/M/S
-BANTAM
-BANTER/D/G/S
-BANTU/S
-BAPTISM/M/S
-BAPTISMAL
-BAPTIST/M/S
-BAPTISTERY
-BAPTISTRY/M/S
-BAPTIZE/D/G/S
-BAR/M/S
-BARB/D/R/S
-BARBADOS
-BARBARA/M
-BARBARIAN/M/S
-BARBARIC
-BARBARITY/S
-BARBAROUS/Y
-BARBECUE/D/S/G
-BARBELL/M/S
-BARBITAL
-BARBITURATE/S
-BARD/M/S
-BARE/P/D/T/R/G/Y/S
-BAREFOOT/D
-BARFLY/M/S
-BARGAIN/D/G/S
-BARGE/G/S
-BARITONE/M/S
-BARIUM
-BARK/D/R/Z/G/S
-BARLEY
-BARN/M/S
-BARNSTORM/D/G/S
-BARNYARD/M/S
-BAROMETER/M/S
-BAROMETRIC
-BARON/M/S
-BARONESS
-BARONIAL
-BARONY/M/S
-BAROQUE/P
-BARRACK/S
-BARRAGE/M/S
-BARRED
-BARREL/M/S/D/G
-BARRELLED
-BARRELLING
-BARREN/P
-BARRICADE/M/S
-BARRIER/M/S
-BARRING/R
-BARROW
-BARTENDER/M/S
-BARTER/D/G/S
-BAS
-BASAL
-BASALT
-BASE/P/D/R/G/Y/S
-BASEBALL/M/S
-BASEBOARD/M/S
-BASELESS
-BASELINE/M/S
-BASEMAN
-BASEMENT/M/S
-BASH/D/G/S
-BASHFUL/P
-BASIC/S
-BASICALLY
-BASIL
-BASIN/M/S
-BASIS
-BASK/D/G
-BASKET/M/S
-BASKETBALL/M/S
-BASS/M/S
-BASSET
-BASSINET/M/S
-BASSO
-BASTARD/M/S
-BASTE/D/G/N/X/S
-BASTION'S
-BAT/M/S
-BATCH/D/S
-BATH
-BATHE/D/R/Z/G/S
-BATHOS
-BATHROBE/M/S
-BATHROOM/M/S
-BATHS
-BATHTUB/M/S
-BATON/M/S
-BATTALION/M/S
-BATTED
-BATTEN/S
-BATTER/D/G/S
-BATTERY/M/S
-BATTING
-BATTLE/D/R/Z/G/S
-BATTLEFIELD/M/S
-BATTLEFRONT/M/S
-BATTLEGROUND/M/S
-BATTLEMENT/M/S
-BATTLESHIP/M/S
-BAUBLE/M/S
-BAUD
-BAUXITE
-BAWDY
-BAWL/D/G/S
-BAY/D/G/S
-BAYONET/M/S
-BAYOU/M/S
-BAZAAR/M/S
-BE/D/G/Y
-BEACH/D/G/S
-BEACHHEAD/M/S
-BEACON/M/S
-BEAD/D/G/S
-BEADLE/M/S
-BEADY
-BEAGLE/M/S
-BEAK/D/R/Z/S
-BEAM/D/R/Z/G/S
-BEAN/D/R/Z/G/S
-BEAR/R/Z/G/J/S
-BEARABLE
-BEARABLY
-BEARD/D/S
-BEARDLESS
-BEARISH
-BEAST/Y/S
-BEAT/R/Z/G/N/J/S
-BEATABLE
-BEATABLY
-BEATIFIC
-BEATIFY/N
-BEATITUDE/M/S
-BEATNIK/M/S
-BEAU/M/S
-BEAUTEOUS/Y
-BEAUTIFUL/Y
-BEAUTIFY/D/R/Z/G/X/S
-BEAUTY/M/S
-BEAVER/M/S
-BECALM/D/G/S
-BECAME
-BECAUSE
-BECK
-BECKON/D/G/S
-BECOME/G/S
-BECOMINGLY
-BED/M/S
-BEDAZZLE/D/G/S
-BEDAZZLEMENT
-BEDBUG/M/S
-BEDDED
-BEDDER/M/S
-BEDDING
-BEDEVIL/D/G/S
-BEDFAST
-BEDLAM
-BEDPOST/M/S
-BEDRAGGLE/D
-BEDRIDDEN
-BEDROCK/M
-BEDROOM/M/S
-BEDSIDE
-BEDSPREAD/M/S
-BEDSPRING/M/S
-BEDSTEAD/M/S
-BEDTIME
-BEE/R/Z/G/J/S
-BEECH/R/N
-BEEF/D/R/Z/G/S
-BEEFSTEAK
-BEEFY
-BEEHIVE/M/S
-BEEN
-BEEP/S
-BEET/M/S
-BEETHOVEN
-BEETLE/D/M/G/S
-BEFALL/G/N/S
-BEFELL
-BEFIT/M/S
-BEFITTED
-BEFITTING
-BEFOG
-BEFOGGED
-BEFOGGING
-BEFORE
-BEFOREHAND
-BEFOUL/D/G/S
-BEFRIEND/D/G/S
-BEFUDDLE/D/G/S
-BEG/S
-BEGAN
-BEGET/S
-BEGETTING
-BEGGAR/Y/S
-BEGGARY
-BEGGED
-BEGGING
-BEGIN/S
-BEGINNER/M/S
-BEGINNING/M/S
-BEGOT
-BEGOTTEN
-BEGRUDGE/D/G/S
-BEGRUDGINGLY
-BEGUILE/D/G/S
-BEGUN
-BEHALF
-BEHAVE/D/G/S
-BEHAVIOR/S
-BEHAVIORAL/Y
-BEHAVIORISM
-BEHAVIORISTIC
-BEHEAD/G
-BEHELD
-BEHEST
-BEHIND
-BEHOLD/R/Z/G/N/S
-BEHOOVE/S
-BEIGE
-BEIJING
-BELABOR/D/G/S
-BELATED/Y
-BELAY/D/G/S
-BELCH/D/G/S
-BELFRY/M/S
-BELGIAN/M/S
-BELGIUM
-BELIE/D/S
-BELIEF/M/S
-BELIEVABLE
-BELIEVABLY
-BELIEVE/D/R/Z/G/S
-BELITTLE/D/G/S
-BELL/M/S
-BELLBOY/M/S
-BELLE/M/S
-BELLHOP/M/S
-BELLICOSE
-BELLICOSITY
-BELLIGERENCE
-BELLIGERENT/M/Y/S
-BELLMAN
-BELLMEN
-BELLOW/D/G/S
-BELLWETHER/M/S
-BELLY/M/S
-BELLYFUL
-BELONG/D/G/J/S
-BELOVED
-BELOW
-BELT/D/G/S
-BELYING
-BEMOAN/D/G/S
-BENCH/D/S
-BENCHMARK/M/S
-BEND/R/Z/G/S
-BENDABLE
-BENEATH
-BENEDICT
-BENEDICTINE
-BENEDICTION/M/S
-BENEFACTOR/M/S
-BENEFICENCE/S
-BENEFICIAL/Y
-BENEFICIARY/S
-BENEFIT/D/G/S
-BENEFITTED
-BENEFITTING
-BENEVOLENCE
-BENEVOLENT
-BENGAL
-BENGALI
-BENIGHTED
-BENIGN/Y
-BENT
-BENZEDRINE
-BENZENE
-BEQUEATH/D/G/S
-BEQUEST/M/S
-BERATE/D/G/S
-BEREAVE/D/G/S
-BEREAVEMENT/S
-BEREFT
-BERET/M/S
-BERIBBONED
-BERIBERI
-BERKELEY
-BERKELIUM
-BERLIN/R/Z
-BERMUDA
-BERRY/M/S
-BERTH
-BERTHS
-BERYL
-BERYLLIUM
-BESEECH/G/S
-BESET/S
-BESETTING
-BESIDE/S
-BESIEGE/D/R/Z/G
-BESMIRCH/D/G/S
-BESOTTED
-BESOTTER
-BESOTTING
-BESOUGHT
-BESPEAK/S
-BESPECTACLED
-BESSEL
-BEST/D/G/S
-BESTIAL
-BESTOW/D
-BESTOWAL
-BESTSELLER/M/S
-BESTSELLING
-BET/M/S
-BETA
-BETHESDA
-BETIDE
-BETRAY/D/R/G/S
-BETRAYAL
-BETROTH/D
-BETROTHAL
-BETTER/D/G/S
-BETTERMENT/S
-BETTING
-BETWEEN
-BETWIXT
-BEVEL/D/G/S
-BEVERAGE/M/S
-BEVY
-BEWAIL/D/G/S
-BEWARE
-BEWHISKERED
-BEWILDER/D/G/S
-BEWILDERINGLY
-BEWILDERMENT
-BEWITCH/D/G/S
-BEYOND
-BEZIER
-BIANNUAL
-BIAS/D/G/S
-BIB/M/S
-BIBBED
-BIBBING
-BIBLE/M/S
-BIBLICAL/Y
-BIBLIOGRAPHIC
-BIBLIOGRAPHICAL
-BIBLIOGRAPHY/M/S
-BIBLIOPHILE
-BICAMERAL
-BICARBONATE
-BICENTENNIAL
-BICEP/M/S
-BICKER/D/G/S
-BICONCAVE
-BICONVEX
-BICYCLE/D/R/Z/G/S
-BID/M/S
-BIDDABLE
-BIDDEN
-BIDDER/M/S
-BIDDING
-BIDDY/S
-BIDE
-BIDIRECTIONAL
-BIENNIAL
-BIENNIUM
-BIFOCAL/S
-BIG/P
-BIGGER
-BIGGEST
-BIGHT/M/S
-BIGNUM
-BIGOT/D/M/S
-BIGOTRY
-BIJECTION/M/S
-BIJECTIVE/Y
-BIKE/M/G/S
-BIKINI/M/S
-BILABIAL
-BILATERAL/Y
-BILE
-BILGE/M/S
-BILINEAR
-BILINGUAL
-BILK/D/G/S
-BILL/D/R/Z/G/J/S/M
-BILLBOARD/M/S
-BILLET/D/G/S
-BILLIARD/S
-BILLION/H/S
-BILLOW/D/S
-BIMODAL
-BIMOLECULAR
-BIMONTHLY/S
-BIN/M/S
-BINARY
-BINAURAL
-BIND/R/Z/G/J/S
-BINGE/S
-BINGO
-BINOCULAR/S
-BINOMIAL
-BINUCLEAR
-BIOCHEMICAL
-BIOCHEMISTRY
-BIOFEEDBACK
-BIOGRAPHER/M/S
-BIOGRAPHIC
-BIOGRAPHICAL/Y
-BIOGRAPHY/M/S
-BIOLOGICAL/Y
-BIOLOGIST/M/S
-BIOLOGY
-BIOMEDICAL
-BIOMEDICINE
-BIOPHYSICAL
-BIOPHYSICS
-BIOPSY/S
-BIOTECHNOLOGY
-BIPARTISAN
-BIPARTITE
-BIPED/S
-BIPLANE/M/S
-BIPOLAR
-BIRACIAL
-BIRCH/N/S
-BIRD/M/S
-BIRDBATH/M
-BIRDBATHS
-BIRDIE/D/S
-BIRDLIKE
-BIREFRINGENCE
-BIREFRINGENT
-BIRMINGHAM
-BIRTH/D
-BIRTHDAY/M/S
-BIRTHPLACE/S
-BIRTHRIGHT/M/S
-BIRTHS
-BISCUIT/M/S
-BISECT/D/G/S
-BISECTION/M/S
-BISECTOR/M/S
-BISHOP/M/S
-BISMUTH
-BISON/M/S
-BISQUE/S
-BIT/M/S
-BITCH/M/S
-BITE/G/R/S/Z
-BITINGLY
-BITMAP/S
-BITMAPPED
-BITTEN
-BITTER/P/T/R/Y/S
-BITTERSWEET
-BITUMINOUS
-BITWISE
-BIVALVE/M/S
-BIVARIATE
-BIVOUAC/S
-BIWEEKLY
-BIZARRE
-BLAB/S
-BLABBED
-BLABBERMOUTH
-BLABBERMOUTHS
-BLABBING
-BLACK/P/D/T/R/G/N/X/Y/S
-BLACKBERRY/M/S
-BLACKBIRD/M/S
-BLACKBOARD/M/S
-BLACKENED
-BLACKENING
-BLACKJACK/M/S
-BLACKLIST/D/G/S
-BLACKMAIL/D/R/Z/G/S
-BLACKOUT/M/S
-BLACKSMITH
-BLACKSMITHS
-BLADDER/M/S
-BLADE/M/S
-BLAINE
-BLAMABLE
-BLAME/D/R/Z/G/S
-BLAMELESS/P
-BLANCH/D/G/S
-BLAND/P/Y
-BLANK/P/D/T/R/G/Y/S
-BLANKET/D/R/Z/G/S
-BLARE/D/G/S
-BLASE
-BLASPHEME/D/G/S
-BLASPHEMOUS/P/Y
-BLASPHEMY/S
-BLAST/D/R/Z/G/S
-BLATANT/Y
-BLAZE/D/R/Z/G/S
-BLEACH/D/R/Z/G/S
-BLEAK/P/Y
-BLEAR
-BLEARY
-BLEAT/G/S
-BLED
-BLEED/R/G/J/S
-BLEMISH/M/S
-BLEND/D/G/S
-BLESS/D/G/J
-BLEW
-BLIGHT/D
-BLIMP/M/S
-BLIND/P/D/R/Z/G/Y/S
-BLINDFOLD/D/G/S
-BLINDINGLY
-BLINK/D/R/Z/G/S
-BLIP/M/S
-BLISS
-BLISSFUL/Y
-BLISTER/D/G/S
-BLITHE/Y
-BLITZ/M/S
-BLITZKRIEG
-BLIZZARD/M/S
-BLOAT/D/R/G/S
-BLOB/M/S
-BLOC/M/S
-BLOCK'S
-BLOCK/D/R/Z/G/S
-BLOCKADE/D/G/S
-BLOCKAGE/M/S
-BLOCKHOUSE/S
-BLOKE/M/S
-BLOND/M/S
-BLONDE/M/S
-BLOOD/D/S
-BLOODHOUND/M/S
-BLOODLESS
-BLOODSHED
-BLOODSHOT
-BLOODSTAIN/D/M/S
-BLOODSTREAM
-BLOODY/D/T
-BLOOM/D/Z/G/S
-BLOSSOM/D/S
-BLOT/M/S
-BLOTTED
-BLOTTING
-BLOUSE/M/S
-BLOW/R/Z/G/S
-BLOWFISH
-BLOWN
-BLOWUP
-BLUBBER
-BLUDGEON/D/G/S
-BLUE/P/T/R/G/S
-BLUEBERRY/M/S
-BLUEBIRD/M/S
-BLUEBONNET/M/S
-BLUEFISH
-BLUEPRINT/M/S
-BLUESTOCKING
-BLUFF/G/S
-BLUISH
-BLUNDER/D/G/J/S
-BLUNT/P/D/T/R/G/Y/S
-BLUR/M/S
-BLURB
-BLURRED
-BLURRING
-BLURRY
-BLURT/D/G/S
-BLUSH/D/G/S
-BLUSTER/D/G/S
-BLUSTERY
-BOAR
-BOARD/D/R/Z/G/S
-BOARDINGHOUSE/M/S
-BOAST/D/R/Z/G/J/S
-BOASTFUL/Y
-BOAT/R/Z/G/S
-BOATHOUSE/M/S
-BOATLOAD/M/S
-BOATMAN
-BOATMEN
-BOATSMAN
-BOATSMEN
-BOATSWAIN/M/S
-BOATYARD/M/S
-BOB/M/S
-BOBBED
-BOBBIN/M/S
-BOBBING
-BOBBY
-BOBOLINK/M/S
-BOBWHITE/M/S
-BODE/S
-BODICE
-BODILY
-BODONI
-BODY/D/S
-BODYBUILDER/M/S
-BODYBUILDING
-BODYGUARD/M/S
-BODYWEIGHT
-BOG/M/S
-BOGGED
-BOGGLE/D/G/S
-BOGUS
-BOIL/D/R/Z/G/S
-BOILERPLATE
-BOISTEROUS/Y
-BOLD/P/T/R/Y
-BOLDFACE
-BOLIVIA
-BOLL
-BOLOGNA
-BOLSHEVIK/M/S
-BOLSHEVISM
-BOLSTER/D/G/S
-BOLT/D/G/S
-BOLTZMANN
-BOMB/D/R/Z/G/J/S
-BOMBARD/D/G/S
-BOMBARDMENT
-BOMBAST
-BOMBASTIC
-BOMBPROOF
-BONANZA/M/S
-BOND/D/R/Z/G/S
-BONDAGE
-BONDSMAN
-BONDSMEN
-BONE/D/R/Z/G/S
-BONFIRE/M/S
-BONG
-BONNET/D/S
-BONNY
-BONUS/M/S
-BONY
-BOO/H/S
-BOOB
-BOOBOO
-BOOBY
-BOOK/D/R/Z/G/J/S
-BOOKCASE/M/S
-BOOKIE/M/S
-BOOKISH
-BOOKKEEPER/M/S
-BOOKKEEPING
-BOOKLET/M/S
-BOOKSELLER/M/S
-BOOKSHELF/M
-BOOKSHELVES
-BOOKSTORE/M/S
-BOOLEAN
-BOOM/D/G/S
-BOOMERANG/M/S
-BOOMTOWN/M/S
-BOON
-BOOR/M/S
-BOORISH
-BOOST/D/R/G/S
-BOOT/D/G/S
-BOOTHS
-BOOTLEG/S
-BOOTLEGGED
-BOOTLEGGER/M/S
-BOOTLEGGING
-BOOTSTRAP/M/S
-BOOTSTRAPPED
-BOOTSTRAPPING
-BOOTY
-BOOZE
-BORATE/S
-BORAX
-BORDELLO/M/S
-BORDER/D/G/J/S
-BORDERLAND/M/S
-BORDERLINE
-BORE/D/R/G/S
-BOREDOM
-BORIC
-BORN
-BORNE
-BORNEO
-BORON
-BOROUGH
-BOROUGHS
-BORROW/D/R/Z/G/S
-BOSOM/M/S
-BOSS/D/S
-BOSTON
-BOSTONIAN/M/S
-BOSUN
-BOTANICAL
-BOTANIST/M/S
-BOTANY
-BOTCH/D/R/Z/G/S
-BOTH/Z
-BOTHER/D/G/S
-BOTHERSOME
-BOTSWANA
-BOTTLE/D/R/Z/G/S
-BOTTLENECK/M/S
-BOTTOM/D/G/S
-BOTTOMLESS
-BOTULINUS
-BOTULISM
-BOUFFANT
-BOUGH/M
-BOUGHS
-BOUGHT
-BOULDER/M/S
-BOULEVARD/M/S
-BOUNCE/D/R/G/S
-BOUNCY
-BOUND/D/G/N/S
-BOUNDARY/M/S
-BOUNDLESS/P
-BOUNTEOUS/Y
-BOUNTY/M/S
-BOUQUET/M/S
-BOURBON
-BOURGEOIS
-BOURGEOISIE
-BOUT/M/S
-BOVINE/S
-BOW/D/R/Z/G/S
-BOWDLERIZE/D/G/S
-BOWEL/M/S
-BOWL/D/R/Z/G/S
-BOWLINE/M/S
-BOWMAN
-BOWSTRING/M/S
-BOX/D/R/Z/G/S
-BOXCAR/M/S
-BOXTOP/M/S
-BOXWOOD
-BOY/M/S
-BOYCOTT/D/S
-BOYFRIEND/M/S
-BOYHOOD
-BOYISH/P
-BRA/M/S
-BRACE/D/G/S
-BRACELET/M/S
-BRACKET/D/G/S
-BRACKISH
-BRAD/M
-BRAE/M/S
-BRAG/S
-BRAGGED
-BRAGGER
-BRAGGING
-BRAID/D/G/S
-BRAILLE
-BRAIN/D/G/S
-BRAINCHILD/M
-BRAINSTEM/M/S
-BRAINSTORM/M/S
-BRAINWASH/D/G/S
-BRAINY
-BRAKE/D/G/S
-BRAMBLE/M/S
-BRAMBLY
-BRAN
-BRANCH/D/G/J/S
-BRAND/D/G/S
-BRANDISH/G/S
-BRANDY
-BRASH/P/Y
-BRASS/S
-BRASSIERE
-BRASSY
-BRAT/M/S
-BRAVADO
-BRAVE/P/D/T/R/G/Y/S
-BRAVERY
-BRAVO/S
-BRAVURA
-BRAWL/R/G
-BRAWN
-BRAY/D/R/G/S
-BRAZE/D/G/S
-BRAZEN/P/Y
-BRAZIER/M/S
-BRAZIL
-BRAZILIAN
-BREACH/D/R/Z/G/S
-BREAD/D/G/H/S
-BREADBOARD/M/S
-BREADBOX/M/S
-BREADWINNER/M/S
-BREAK/R/Z/G/S
-BREAKABLE/S
-BREAKAGE
-BREAKAWAY
-BREAKDOWN/M/S
-BREAKFAST/D/R/Z/G/S
-BREAKPOINT/M/S
-BREAKTHROUGH/M/S
-BREAKTHROUGHS
-BREAKUP
-BREAKWATER/M/S
-BREAST/D/S
-BREASTWORK/M/S
-BREATH
-BREATHABLE
-BREATHE/D/R/Z/G/S
-BREATHLESS/Y
-BREATHS
-BREATHTAKING/Y
-BREATHY
-BRED
-BREECH/M/S
-BREED/R/G/S
-BREEZE/M/S
-BREEZILY
-BREEZY
-BREMSSTRAHLUNG
-BRETHREN
-BREVE
-BREVET/D/G/S
-BREVITY
-BREW/D/R/Z/G/S
-BREWERY/M/S
-BRIAN/M
-BRIAR/M/S
-BRIBE/D/R/Z/G/S
-BRICK/D/R/S
-BRICKLAYER/M/S
-BRICKLAYING
-BRIDAL
-BRIDE/M/S
-BRIDEGROOM
-BRIDESMAID/M/S
-BRIDGE/D/G/S
-BRIDGEABLE
-BRIDGEHEAD/M/S
-BRIDGEWORK/M
-BRIDLE/D/G/S
-BRIEF/P/D/T/R/Y/S
-BRIEFCASE/M/S
-BRIEFING/M/S
-BRIER
-BRIG/M/S
-BRIGADE/M/S
-BRIGADIER/M/S
-BRIGANTINE
-BRIGHT/P/T/R/X/Y
-BRIGHTEN/D/R/Z/G/S
-BRILLIANCE
-BRILLIANCY
-BRILLIANT/Y
-BRIM
-BRIMFUL
-BRIMMED
-BRINDLE/D
-BRINE
-BRING/G/R/S/Z
-BRINK
-BRINKMANSHIP
-BRISK/P/R/Y
-BRISTLE/D/G/S
-BRITAIN
-BRITCHES
-BRITISH/R
-BRITON/M/S
-BRITTLE/P
-BROACH/D/G/S
-BROAD/P/T/R/X/Y
-BROADBAND
-BROADCAST/R/Z/G/J/S
-BROADEN/D/R/Z/G/J/S
-BROADSIDE
-BROCADE/D
-BROCCOLI
-BROCHURE/M/S
-BROIL/D/R/Z/G/S
-BROKE/R/Z
-BROKEN/P/Y
-BROKERAGE
-BROMIDE/M/S
-BROMINE
-BRONCHI
-BRONCHIAL
-BRONCHIOLE/M/S
-BRONCHITIS
-BRONCHUS
-BRONZE/D/S
-BROOCH/M/S
-BROOD/R/G/S
-BROOK/D/S
-BROOKHAVEN
-BROOM/M/S
-BROOMSTICK/M/S
-BROTH/R/Z
-BROTHEL/M/S
-BROTHER'S
-BROTHERHOOD
-BROTHERLY/P
-BROUGHT
-BROW/M/S
-BROWBEAT/G/N/S
-BROWN/P/D/T/R/G/S
-BROWNIE/M/S
-BROWNISH
-BROWSE/G
-BROWSER/S
-BRUCE/M
-BRUISE/D/G/S
-BRUNCH/S
-BRUNETTE
-BRUNT
-BRUSH/D/G/S
-BRUSHFIRE/M/S
-BRUSHLIKE
-BRUSHY
-BRUSQUE/Y
-BRUTAL/Y
-BRUTALITY/S
-BRUTALIZE/D/G/S
-BRUTE/M/S
-BRUTISH
-BSD
-BUBBLE/D/G/S
-BUBBLY
-BUCK/D/G/S
-BUCKBOARD/M/S
-BUCKET/M/S
-BUCKLE/D/R/G/S
-BUCKSHOT
-BUCKSKIN/S
-BUCKWHEAT
-BUCOLIC
-BUD/M/S
-BUDDED
-BUDDING
-BUDDY/M/S
-BUDGE/D/G/S
-BUDGET/D/R/Z/G/S
-BUDGETARY
-BUFF/M/S
-BUFFALO
-BUFFALOES
-BUFFER/D/M/G/S
-BUFFERER/M/S
-BUFFET/D/G/J/S
-BUFFOON/M/S
-BUG/M/S
-BUGGED
-BUGGER/M/S
-BUGGING
-BUGGY/M/S
-BUGLE/D/R/G/S
-BUILD/R/Z/G/J/S
-BUILDUP/M/S
-BUILT
-BULB/M/S
-BULGE/D/G
-BULK/D/S
-BULKHEAD/M/S
-BULKY
-BULL/D/G/S
-BULLDOG/M/S
-BULLDOZE/D/R/G/S
-BULLET/M/S
-BULLETIN/M/S
-BULLION
-BULLISH
-BULLY/D/G/S
-BULWARK
-BUM/M/S
-BUMBLE/D/R/Z/G/S
-BUMBLEBEE/M/S
-BUMMED
-BUMMING
-BUMP/D/R/Z/G/S
-BUMPTIOUS/P/Y
-BUN/M/S
-BUNCH/D/G/S
-BUNDLE/D/G/S
-BUNGALOW/M/S
-BUNGLE/D/R/Z/G/S
-BUNION/M/S
-BUNK/R/Z/S
-BUNKER'S
-BUNKERED
-BUNKHOUSE/M/S
-BUNKMATE/M/S
-BUNNY/M/S
-BUNT/D/R/Z/G/S
-BUOY/D/S
-BUOYANCY
-BUOYANT
-BURDEN/D/G/S
-BURDENSOME
-BUREAU/M/S
-BUREAUCRACY/M/S
-BUREAUCRAT/M/S
-BUREAUCRATIC
-BURGEON/D/G
-BURGESS/M/S
-BURGHER/M/S
-BURGLAR/M/S
-BURGLARIZE/D/G/S
-BURGLARPROOF/D/G/S
-BURGLARY/M/S
-BURIAL
-BURL
-BURLESQUE/S
-BURLY
-BURN/D/R/Z/G/J/S
-BURNINGLY
-BURNISH/D/G/S
-BURNT/P/Y
-BURP/D/G/S
-BURR/M/S
-BURRO/M/S
-BURROW/D/R/G/S
-BURSA
-BURSITIS
-BURST/G/S
-BURY/D/G/S
-BUS/D/G/S
-BUSBOY/M/S
-BUSH/G/S
-BUSHEL/M/S
-BUSHWHACK/D/G/S
-BUSHY
-BUSILY
-BUSINESS/M/S
-BUSINESSLIKE
-BUSINESSMAN
-BUSINESSMEN
-BUSS/D/G/S
-BUST/D/R/S
-BUSTARD/M/S
-BUSTLE/G
-BUSY/D/T/R
-BUT
-BUTANE
-BUTCHER/D/S
-BUTCHERY
-BUTLER/M/S
-BUTT/M/S
-BUTTE/D/Z/G/S
-BUTTER/D/R/Z/G
-BUTTERFAT
-BUTTERFLY/M/S
-BUTTERNUT
-BUTTOCK/M/S
-BUTTON/D/G/S
-BUTTONHOLE/M/S
-BUTTRESS/D/G/S
-BUTYL
-BUTYRATE
-BUXOM
-BUY/G/S
-BUYER/M/S
-BUZZ/D/R/G/S
-BUZZARD/M/S
-BUZZWORD/M/S
-BUZZY
-BY/R
-BYE
-BYGONE
-BYLAW/M/S
-BYLINE/M/S
-BYPASS/D/G/S
-BYPRODUCT/M/S
-BYSTANDER/M/S
-BYTE/M/S
-BYWAY/S
-BYWORD/M/S
-CAB/M/S
-CABBAGE/M/S
-CABIN/M/S
-CABINET/M/S
-CABLE/D/G/S
-CACHE/M/S/G/D
-CACKLE/D/R/G/S
-CACTI
-CACTUS
-CADENCE/D
-CADUCEUS
-CAFE/M/S
-CAGE/D/R/Z/G/S
-CAJOLE/D/G/S
-CAKE/D/G/S
-CALAMITY/M/S
-CALCIUM
-CALCULATE/D/G/N/X/V/S
-CALCULATOR/M/S
-CALCULUS
-CALENDAR/M/S
-CALF
-CALIBER/S
-CALIBRATE/D/G/N/X/S
-CALICO
-CALIFORNIA
-CALIPH
-CALIPHS
-CALL/D/R/Z/G/S
-CALLIGRAPHY
-CALLOUS/P/D/Y
-CALM/P/D/T/R/G/Y/S
-CALMINGLY
-CALORIE/M/S
-CALVES
-CAMBRIDGE
-CAME
-CAMEL/M/S
-CAMERA/M/S
-CAMOUFLAGE/D/G/S
-CAMP/D/R/Z/G/S
-CAMPAIGN/D/R/Z/G/S
-CAMPUS/M/S
-CAN'T
-CAN/M/S
-CANADA
-CANAL/M/S
-CANARY/M/S
-CANCEL/D/G/S
-CANCELLATION/M/S
-CANCER/M/S
-CANDID/P/Y
-CANDIDATE/M/S
-CANDLE/R/S
-CANDLESTICK/M/S
-CANDOR
-CANDY/D/S
-CANE/R
-CANINE
-CANKER
-CANNED
-CANNER/M/S
-CANNIBAL/M/S
-CANNIBALIZE/D/G/S
-CANNING
-CANNISTER/M/S
-CANNON/M/S
-CANNOT
-CANOE/M/S
-CANON/M/S
-CANONICAL/Y/S
-CANONICALIZATION
-CANONICALIZE/D/G/S
-CANOPY
-CANTANKEROUS/Y
-CANTO
-CANTON/M/S
-CANTOR/M/S
-CANVAS/M/S
-CANVASS/D/R/Z/G/S
-CANYON/M/S
-CAP/M/S
-CAPABILITY/M/S
-CAPABLE
-CAPABLY
-CAPACIOUS/P/Y
-CAPACITANCE/S
-CAPACITIVE
-CAPACITOR/M/S
-CAPACITY/S
-CAPE/R/Z/S
-CAPILLARY
-CAPITA
-CAPITAL/Y/S
-CAPITALISM
-CAPITALIST/M/S
-CAPITALIZATION/S
-CAPITALIZE/D/R/Z/G/S
-CAPITOL/M/S
-CAPPED
-CAPPING
-CAPRICIOUS/P/Y
-CAPTAIN/D/G/S
-CAPTION/M/S
-CAPTIVATE/D/G/N/S
-CAPTIVE/M/S
-CAPTIVITY
-CAPTOR/M/S
-CAPTURE/D/R/Z/G/S
-CAR/M/S
-CARAVAN/M/S
-CARBOHYDRATE
-CARBOLIC
-CARBON/M/S
-CARBONATE/N/S
-CARBONIC
-CARBONIZATION
-CARBONIZE/D/R/Z/G/S
-CARCASS/M/S
-CARCINOMA
-CARD/R/S
-CARDBOARD
-CARDIAC
-CARDINAL/Y/S
-CARDINALITY/M/S
-CARDIOLOGY
-CARDIOPULMONARY
-CARE/D/G/S
-CAREER/M/S
-CAREFREE
-CAREFUL/P/Y
-CARELESS/P/Y
-CARESS/D/R/G/S
-CARET
-CARGO
-CARGOES
-CARIBOU
-CARNEGIE
-CARNIVAL/M/S
-CARNIVOROUS/Y
-CAROL/M/S
-CAROLINA/M/S
-CARPENTER/M/S
-CARPET/D/G/S
-CARRIAGE/M/S
-CARROT/M/S
-CARRY/D/R/Z/G/S
-CARRYOVER/S
-CART/D/R/Z/G/S
-CARTESIAN
-CARTOGRAPHIC
-CARTOGRAPHY
-CARTON/M/S
-CARTOON/M/S
-CARTRIDGE/M/S
-CARVE/D/R/G/J/S
-CASCADE/D/G/S
-CASE/D/G/J/S
-CASEMENT/M/S
-CASH/D/R/Z/G/S
-CASHIER/M/S
-CASK/M/S
-CASKET/M/S
-CASSEROLE/M/S
-CAST/G/M/S
-CASTE/R/S/Z
-CASTLE/D/S
-CASUAL/P/Y/S
-CASUALTY/M/S
-CAT/M/S
-CATALOG/D/R/G/S
-CATALOGUE/D/S
-CATALYST/M/S
-CATARACT
-CATASTROPHE
-CATASTROPHIC
-CATCH/G/R/S/Z
-CATCHABLE
-CATEGORICAL/Y
-CATEGORIZATION
-CATEGORIZE/D/R/Z/G/S
-CATEGORY/M/S
-CATER/D/R/G/S
-CATERPILLAR/M/S
-CATHEDRAL/M/S
-CATHERINE/M
-CATHETER/S
-CATHODE/M/S
-CATHOLIC/M/S
-CATSUP
-CATTLE
-CAUGHT
-CAUSAL/Y
-CAUSALITY
-CAUSATION/M/S
-CAUSE/D/R/G/S
-CAUSEWAY/M/S
-CAUSTIC/Y/S
-CAUTION/D/R/Z/G/J/S
-CAUTIOUS/P/Y
-CAVALIER/P/Y
-CAVALRY
-CAVE/D/G/S
-CAVEAT/M/S
-CAVERN/M/S
-CAVITY/M/S
-CAW/G
-CDR
-CEASE/D/G/S
-CEASELESS/P/Y
-CEDAR
-CEILING/M/S
-CELEBRATE/D/G/N/X/S
-CELEBRITY/M/S
-CELERY
-CELESTIAL/Y
-CELL/D/S
-CELLAR/M/S
-CELLIST/M/S
-CELLULAR
-CELSIUS
-CEMENT/D/G/S
-CEMETERY/M/S
-CENSOR/D/G/S
-CENSORSHIP
-CENSURE/D/R/S
-CENSUS/M/S
-CENT/Z/S
-CENTER/D/G/S
-CENTERPIECE/M/S
-CENTIMETER/S
-CENTIPEDE/M/S
-CENTRAL/Y
-CENTRALIZATION
-CENTRALIZE/D/G/S
-CENTRIPETAL
-CENTURY/M/S
-CEREAL/M/S
-CEREBRAL
-CEREMONIAL/P/Y
-CEREMONY/M/S
-CERTAIN/Y
-CERTAINTY/S
-CERTIFIABLE
-CERTIFICATE/N/X/S
-CERTIFY/D/R/Z/G/N/S
-CESSATION/M/S
-CHAFE/R/G
-CHAFF/R/G
-CHAGRIN
-CHAIN/D/G/S
-CHAIR/D/G/S
-CHAIRMAN
-CHAIRMEN
-CHAIRPERSON/M/S
-CHALICE/M/S
-CHALK/D/G/S
-CHALLENGE/D/R/Z/G/S
-CHAMBER/D/S
-CHAMBERLAIN/M/S
-CHAMPAGNE
-CHAMPAIGN
-CHAMPION/D/G/S
-CHAMPIONSHIP/M/S
-CHANCE/D/G/S
-CHANCELLOR
-CHANDELIER/M/S
-CHANGE/D/R/Z/G/S
-CHANGEABILITY
-CHANGEABLE
-CHANGEABLY
-CHANNEL/D/G/S
-CHANNELLED
-CHANNELLER/M/S
-CHANNELLING
-CHANT/D/R/G/S
-CHANTICLEER/M/S
-CHAOS
-CHAOTIC
-CHAP/M/S
-CHAPEL/M/S
-CHAPERON/D
-CHAPLAIN/M/S
-CHAPTER/M/S
-CHAR/S
-CHARACTER/M/S
-CHARACTERISTIC/M/S
-CHARACTERISTICALLY
-CHARACTERIZABLE
-CHARACTERIZATION/M/S
-CHARACTERIZE/D/R/Z/G/S
-CHARCOAL/D
-CHARGE/D/R/Z/G/S
-CHARGEABLE
-CHARIOT/M/S
-CHARISMA
-CHARISMATIC
-CHARITABLE/P
-CHARITY/M/S
-CHARLES
-CHARM/D/R/Z/G/S
-CHARMINGLY
-CHART/D/R/Z/G/J/S
-CHARTABLE
-CHARTERED
-CHARTERING
-CHASE/D/R/Z/G/S
-CHASM/M/S
-CHASTE/P/Y
-CHASTISE/D/R/Z/G/S
-CHAT
-CHATEAU/M/S
-CHATTER/D/R/G/S/Z
-CHAUFFEUR/D
-CHEAP/P/T/R/X/Y
-CHEAPEN/D/G/S
-CHEAT/D/R/Z/G/S
-CHECK/D/R/Z/G/S
-CHECKABLE
-CHECKBOOK/M/S
-CHECKOUT
-CHECKPOINT/M/S
-CHECKSUM/M/S
-CHEEK/M/S
-CHEER/D/R/G/S
-CHEERFUL/P/Y
-CHEERILY
-CHEERLESS/P/Y
-CHEERY/P
-CHEESE/M/S
-CHEF/M/S
-CHEMICAL/Y/S
-CHEMISE
-CHEMIST/M/S
-CHEMISTRY/S
-CHERISH/D/G/S
-CHERRY/M/S
-CHERUB/M/S
-CHERUBIM
-CHESS
-CHEST/R/S
-CHESTNUT/M/S
-CHEW/D/R/Z/G/S
-CHICK/N/X/S
-CHICKADEE/M/S
-CHIDE/D/G/S
-CHIEF/Y/S
-CHIEFTAIN/M/S
-CHIFFON
-CHILD
-CHILDHOOD
-CHILDISH/P/Y
-CHILDREN
-CHILES
-CHILL/D/R/Z/G/S
-CHILLINGLY
-CHILLY/P/R
-CHIME/M/S
-CHIMNEY/M/S
-CHIN/M/S
-CHINA
-CHINESE
-CHINK/D/S
-CHINNED
-CHINNER/S
-CHINNING
-CHINTZ
-CHIP/M/S
-CHIPMUNK/M/S
-CHIRP/D/G/S
-CHISEL/D/R/S
-CHIVALROUS/P/Y
-CHIVALRY
-CHLORINE
-CHLOROPLAST/M/S
-CHOCK/M/S
-CHOCOLATE/M/S
-CHOICE/T/S
-CHOIR/M/S
-CHOKE/D/R/Z/G/S
-CHOLERA
-CHOOSE/R/Z/G/S
-CHOP/S
-CHOPPED
-CHOPPER/M/S
-CHOPPING
-CHORAL
-CHORD/M/S
-CHORE/G/S
-CHORUS/D/S
-CHOSE
-CHOSEN
-CHRIS
-CHRISTEN/D/G/S
-CHRISTIAN/M/S
-CHRISTMAS
-CHRISTOPHER/M
-CHROMOSOME
-CHRONIC
-CHRONICLE/D/R/Z/S
-CHRONOLOGICAL/Y
-CHRONOLOGY/M/S
-CHUBBY/P/T/R
-CHUCK/M/S
-CHUCKLE/D/S
-CHUM
-CHUNK/G/D/S/M
-CHURCH/Y/S
-CHURCHMAN
-CHURCHYARD/M/S
-CHURN/D/G/S
-CHUTE/M/S
-CIDER
-CIGAR/M/S
-CIGARETTE/M/S
-CINCINNATI
-CINDER/M/S
-CINNAMON
-CIPHER/M/S
-CIRCLE/D/G/S
-CIRCUIT/M/S
-CIRCUITOUS/Y
-CIRCUITRY
-CIRCULAR/Y
-CIRCULARITY/S
-CIRCULATE/D/G/N/S
-CIRCUMFERENCE
-CIRCUMFLEX
-CIRCUMLOCUTION/M/S
-CIRCUMSPECT/Y
-CIRCUMSTANCE/M/S
-CIRCUMSTANTIAL/Y
-CIRCUMVENT/D/G/S
-CIRCUMVENTABLE
-CIRCUS/M/S
-CISTERN/M/S
-CITADEL/M/S
-CITATION/M/S
-CITE/D/G/S
-CITIZEN/M/S
-CITIZENSHIP
-CITY/M/S
-CIVIC/S
-CIVIL/Y
-CIVILIAN/M/S
-CIVILITY
-CIVILIZATION/M/S
-CIVILIZE/D/G/S
-CLAD
-CLAIM/D/G/S
-CLAIMABLE
-CLAIMANT/M/S
-CLAIRVOYANT/Y
-CLAM/M/S
-CLAMBER/D/G/S
-CLAMOR/D/G/S
-CLAMOROUS
-CLAMP/D/G/S
-CLAN
-CLANG/D/G/S
-CLAP/S
-CLARA/M
-CLARIFY/D/G/N/X/S
-CLARITY
-CLASH/D/G/S
-CLASP/D/G/S
-CLASS/D/S
-CLASSIC/S
-CLASSICAL/Y
-CLASSIFIABLE
-CLASSIFY/D/R/Z/G/N/X/S
-CLASSMATE/M/S
-CLASSROOM/M/S
-CLATTER/D/G
-CLAUSE/M/S
-CLAW/D/G/S
-CLAY/M/S
-CLEAN/P/D/T/G/Y/S
-CLEANER/M/S
-CLEANLINESS
-CLEANSE/D/R/Z/G/S
-CLEAR/P/D/T/R/Y/S
-CLEARANCE/M/S
-CLEARING/M/S
-CLEAVAGE
-CLEAVE/D/R/Z/G/S
-CLEFT/M/S
-CLENCH/D/S
-CLERGY
-CLERGYMAN
-CLERICAL
-CLERK/D/G/S
-CLEVER/P/T/R/Y
-CLICHE/M/S
-CLICK/D/G/S
-CLIENT/M/S
-CLIFF/M/S
-CLIMATE/M/S
-CLIMATIC
-CLIMATICALLY
-CLIMAX/D/S
-CLIMB/D/R/Z/G/S
-CLIME/M/S
-CLINCH/D/R/S
-CLING/G/S
-CLINIC/M/S
-CLINICAL/Y
-CLINK/D/R
-CLIP/M/S
-CLIPPED
-CLIPPER/M/S
-CLIPPING/M/S
-CLIQUE/M/S
-CLOAK/M/S
-CLOBBER/D/G/S
-CLOCK/D/R/Z/G/J/S
-CLOCKWISE
-CLOCKWORK
-CLOD/M/S
-CLOG/M/S
-CLOGGED
-CLOGGING
-CLOISTER/M/S
-CLONE/D/G/S
-CLOSE/D/T/G/Y/S
-CLOSENESS/S
-CLOSER/S
-CLOSET/D/S
-CLOSURE/M/S
-CLOT
-CLOTH
-CLOTHE/D/G/S
-CLOUD/D/G/S
-CLOUDLESS
-CLOUDY/P/T/R
-CLOUT
-CLOVE/R/S
-CLOWN/G/S
-CLUB/M/S
-CLUBBED
-CLUBBING
-CLUCK/D/G/S
-CLUE/M/S
-CLUMP/D/G/S
-CLUMSILY
-CLUMSY/P
-CLUNG
-CLUSTER/D/G/J/S
-CLUTCH/D/G/S
-CLUTTER/D/G/S
-CLX
-CLYDE/M
-CMU/M
-COACH/D/R/G/S
-COACHMAN
-COAGULATION
-COAL/S
-COALESCE/D/G/S
-COALITION
-COARSE/P/T/R/Y
-COARSEN/D
-COAST/D/R/Z/G/S
-COASTAL
-COAT/D/G/J/S
-COAX/D/R/G/S
-COBBLER/M/S
-COBOL
-COBWEB/M/S
-COCK/D/G/S
-COCKATOO
-COCKTAIL/M/S
-COCOA
-COCONUT/M/S
-COCOON/M/S
-COD
-CODE/D/R/Z/G/J/S
-CODEWORD/M/S
-CODIFICATION/M/S
-CODIFIER/M/S
-CODIFY/D/G/S
-COEFFICIENT/M/S
-COERCE/D/G/N/V/S
-COEXIST/D/G/S
-COEXISTENCE
-COFFEE/M/S
-COFFER/M/S
-COFFIN/M/S
-COGENT/Y
-COGITATE/D/G/N/S
-COGNITION
-COGNITIVE/Y
-COGNIZANCE
-COGNIZANT
-COHABIT/S
-COHABITATION/S
-COHERE/D/G/S
-COHERENCE
-COHERENT/Y
-COHESION
-COHESIVE/P/Y
-COIL/D/G/S
-COIN/D/R/G/S
-COINAGE
-COINCIDE/D/G/S
-COINCIDENCE/M/S
-COINCIDENTAL
-COKE/S
-COLD/P/T/R/Y/S
-COLLABORATE/D/G/N/X/V/S
-COLLABORATOR/M/S
-COLLAPSE/D/G/S
-COLLAR/D/G/S
-COLLATERAL
-COLLEAGUE/M/S
-COLLECT/D/G/V/S
-COLLECTIBLE
-COLLECTION/M/S
-COLLECTIVE/Y/S
-COLLECTOR/M/S
-COLLEGE/M/S
-COLLEGIATE
-COLLIDE/D/G/S
-COLLIE/R/S
-COLLISION/M/S
-COLLOQUIA
-COLOGNE
-COLON/M/S
-COLONEL/M/S
-COLONIAL/Y/S
-COLONIST/M/S
-COLONIZATION
-COLONIZE/D/R/Z/G/S
-COLONY/M/S
-COLOR/D/R/Z/G/J/S
-COLORADO
-COLORFUL
-COLORLESS
-COLOSSAL
-COLT/M/S
-COLUMBUS
-COLUMN/M/S
-COLUMNAR
-COLUMNIZE/D/G/S
-COMB/D/R/Z/G/J/S
-COMBAT/D/G/V/S
-COMBATANT/M/S
-COMBINATION/M/S
-COMBINATIONAL
-COMBINATOR/M/S
-COMBINATORIAL/Y
-COMBINATORIC/S
-COMBINE/D/G/S
-COMBUSTION
-COME/R/Z/G/Y/J/S
-COMEDIAN/M/S
-COMEDIC
-COMEDY/M/S
-COMELINESS
-COMESTIBLE
-COMET/M/S
-COMFORT/D/R/Z/G/S
-COMFORTABILITY/S
-COMFORTABLE
-COMFORTABLY
-COMFORTINGLY
-COMIC/M/S
-COMICAL/Y
-COMMA/M/S
-COMMAND'S
-COMMAND/D/R/Z/G/S
-COMMANDANT/M/S
-COMMANDINGLY
-COMMANDMENT/M/S
-COMMEMORATE/D/G/N/V/S
-COMMENCE/D/G/S
-COMMENCEMENT/M/S
-COMMEND/D/G/S
-COMMENDABLE
-COMMENDATION/M/S
-COMMENSURATE
-COMMENT/D/G/S
-COMMENTARY/M/S
-COMMENTATOR/M/S
-COMMERCE
-COMMERCIAL/P/Y/S
-COMMISSION/D/R/Z/G/S
-COMMIT/S
-COMMITMENT/M/S
-COMMITTED
-COMMITTEE/M/S
-COMMITTING
-COMMODITY/M/S
-COMMODORE/M/S
-COMMON/P/T/Y/S
-COMMONALITY/S
-COMMONER/M/S
-COMMONPLACE/S
-COMMONWEALTH
-COMMONWEALTHS
-COMMOTION
-COMMUNAL/Y
-COMMUNE/N/S
-COMMUNICANT/M/S
-COMMUNICATE/D/G/N/X/V/S
-COMMUNICATOR/M/S
-COMMUNIST/M/S
-COMMUNITY/M/S
-COMMUTATIVE
-COMMUTATIVITY
-COMMUTE/D/R/Z/G/S
-COMPACT/P/D/T/R/G/Y/S
-COMPACTOR/M/S
-COMPANION/M/S
-COMPANIONABLE
-COMPANIONSHIP
-COMPANY/M/S
-COMPARABILITY
-COMPARABLE
-COMPARABLY
-COMPARATIVE/Y/S
-COMPARATOR/M/S
-COMPARE/D/G/S
-COMPARISON/M/S
-COMPARTMENT/D/S
-COMPARTMENTALIZE/D/G/S
-COMPASS
-COMPASSION
-COMPASSIONATE/Y
-COMPATIBILITY/M/S
-COMPATIBLE
-COMPATIBLY
-COMPEL/S
-COMPELLED
-COMPELLING/Y
-COMPENDIUM
-COMPENSATE/D/G/N/X/S
-COMPENSATORY
-COMPETE/D/G/S
-COMPETENCE
-COMPETENT/Y
-COMPETITION/M/S
-COMPETITIVE/Y
-COMPETITOR/M/S
-COMPILATION/M/S
-COMPILE/D/R/Z/G/S
-COMPILER'S
-COMPLAIN/D/R/Z/G/S
-COMPLAINT/M/S
-COMPLEMENT/D/R/Z/G/S
-COMPLEMENTARY
-COMPLETE/P/D/G/N/X/Y/S
-COMPLEX/Y/S
-COMPLEXION
-COMPLEXITY/S
-COMPLIANCE
-COMPLICATE/D/G/N/X/S
-COMPLICATOR/M/S
-COMPLICITY
-COMPLIMENT/D/R/Z/G/S
-COMPLIMENTARY
-COMPLY/D/G
-COMPONENT/M/S
-COMPONENTWISE
-COMPOSE/D/R/Z/G/S
-COMPOSEDLY
-COMPOSITE/N/X/S
-COMPOSITIONAL
-COMPOSURE
-COMPOUND/D/G/S
-COMPREHEND/D/G/S
-COMPREHENSIBILITY
-COMPREHENSIBLE
-COMPREHENSION
-COMPREHENSIVE/Y
-COMPRESS/D/G/V/S
-COMPRESSIBLE
-COMPRESSION
-COMPRISE/D/G/S
-COMPROMISE/D/R/Z/G/S
-COMPROMISING/Y
-COMPTROLLER/M/S
-COMPULSION/M/S
-COMPULSORY
-COMPUNCTION
-COMPUTABILITY
-COMPUTABLE
-COMPUTATION/M/S
-COMPUTATIONAL/Y
-COMPUTE/D/R/Z/G/S
-COMPUTER'S
-COMPUTERIZE/D/G/S
-COMRADE/Y/S
-COMRADESHIP
-CONCATENATE/D/G/N/X/S
-CONCEAL/D/R/Z/G/S
-CONCEALMENT
-CONCEDE/D/G/S
-CONCEIT/D/S
-CONCEIVABLE
-CONCEIVABLY
-CONCEIVE/D/G/S
-CONCENTRATE/D/G/N/X/S
-CONCENTRATOR/S
-CONCENTRIC
-CONCEPT/M/S
-CONCEPTION/M/S
-CONCEPTUAL/Y
-CONCEPTUALIZATION/M/S
-CONCEPTUALIZE/D/G/S
-CONCERN/D/G/S
-CONCERNEDLY
-CONCERT/D/S
-CONCESSION/M/S
-CONCISE/P/Y
-CONCLUDE/D/G/S
-CONCLUSION/M/S
-CONCLUSIVE/Y
-CONCOCT
-CONCOMITANT
-CONCORD
-CONCORDANCE
-CONCRETE/P/N/Y/S
-CONCUR/S
-CONCURRED
-CONCURRENCE
-CONCURRENCY/S
-CONCURRENT/Y
-CONCURRING
-CONDEMN/D/R/Z/G/S
-CONDEMNATION/S
-CONDENSATION
-CONDENSE/D/R/G/S
-CONDESCEND/G
-CONDITION/D/R/Z/G/S
-CONDITIONAL/Y/S
-CONDONE/D/G/S
-CONDUCIVE
-CONDUCT/D/G/V/S
-CONDUCTION
-CONDUCTIVITY
-CONDUCTOR/M/S
-CONE/M/S
-CONFEDERACY
-CONFEDERATE/N/X/S
-CONFER/S
-CONFERENCE/M/S
-CONFERRED
-CONFERRER/M/S
-CONFERRING
-CONFESS/D/G/S
-CONFESSION/M/S
-CONFESSOR/M/S
-CONFIDANT/M/S
-CONFIDE/D/G/S
-CONFIDENCE/S
-CONFIDENT/Y
-CONFIDENTIAL/Y
-CONFIDENTIALITY
-CONFIDINGLY
-CONFIGURABLE
-CONFIGURATION/M/S
-CONFIGURE/D/G/S
-CONFINE/D/R/G/S
-CONFINEMENT/M/S
-CONFIRM/D/G/S
-CONFIRMATION/M/S
-CONFISCATE/D/G/N/X/S
-CONFLICT/D/G/S
-CONFORM/D/G/S
-CONFORMITY
-CONFOUND/D/G/S
-CONFRONT/D/R/Z/G/S
-CONFRONTATION/M/S
-CONFUSE/D/R/Z/G/N/X/S
-CONFUSINGLY
-CONGENIAL/Y
-CONGESTED
-CONGESTION
-CONGRATULATE/D/N/X
-CONGREGATE/D/G/N/X/S
-CONGRESS/M/S
-CONGRESSIONAL/Y
-CONGRESSMAN
-CONGRUENCE
-CONGRUENT
-CONIC
-CONJECTURE/D/G/S
-CONJOINED
-CONJUNCT/D/V/S
-CONJUNCTION/M/S
-CONJUNCTIVELY
-CONJURE/D/R/G/S
-CONNECT/D/G/S
-CONNECTEDNESS
-CONNECTICUT
-CONNECTION/M/S
-CONNECTIONIST
-CONNECTIVE/M/S
-CONNECTIVITY
-CONNECTOR/M/S
-CONNOISSEUR/M/S
-CONNOTE/D/G/S
-CONQUER/D/R/Z/G/S
-CONQUERABLE
-CONQUEROR/M/S
-CONQUEST/M/S
-CONS
-CONSCIENCE/M/S
-CONSCIENTIOUS/Y
-CONSCIOUS/P/Y
-CONSECRATE/N
-CONSECUTIVE/Y
-CONSENSUS
-CONSENT/D/R/Z/G/S
-CONSEQUENCE/M/S
-CONSEQUENT/Y/S
-CONSEQUENTIAL
-CONSEQUENTIALITY/S
-CONSERVATION/M/S
-CONSERVATIONIST/M/S
-CONSERVATISM
-CONSERVATIVE/Y/S
-CONSERVE/D/G/S
-CONSIDER/D/G/S
-CONSIDERABLE
-CONSIDERABLY
-CONSIDERATE/N/X/Y
-CONSIGN/D/G/S
-CONSIST/D/G/S
-CONSISTENCY
-CONSISTENT/Y
-CONSOLABLE
-CONSOLATION/M/S
-CONSOLE/D/R/Z/G/S
-CONSOLIDATE/D/G/N/S
-CONSOLINGLY
-CONSONANT/M/S
-CONSORT/D/G/S
-CONSORTIUM
-CONSPICUOUS/Y
-CONSPIRACY/M/S
-CONSPIRATOR/M/S
-CONSPIRE/D/S
-CONSTABLE/M/S
-CONSTANCY
-CONSTANT/Y/S
-CONSTELLATION/M/S
-CONSTERNATION
-CONSTITUENCY/M/S
-CONSTITUENT/M/S
-CONSTITUTE/D/G/N/X/V/S
-CONSTITUTIONAL/Y
-CONSTITUTIONALITY
-CONSTRAIN/D/G/S
-CONSTRAINT/M/S
-CONSTRUCT/D/G/V/S
-CONSTRUCTIBILITY
-CONSTRUCTIBLE
-CONSTRUCTION/M/S
-CONSTRUCTIVELY
-CONSTRUCTOR/M/S
-CONSTRUE/D/G
-CONSUL/M/S
-CONSULATE/M/S
-CONSULT/D/G/S
-CONSULTANT/M/S
-CONSULTATION/M/S
-CONSUMABLE
-CONSUME/D/R/Z/G/S
-CONSUMER'S
-CONSUMMATE/D/N/Y
-CONSUMPTION/M/S
-CONSUMPTIVE/Y
-CONTACT/D/G/S
-CONTAGION
-CONTAGIOUS/Y
-CONTAIN/D/R/Z/G/S
-CONTAINABLE
-CONTAINMENT/M/S
-CONTAMINATE/D/G/N/S
-CONTEMPLATE/D/G/N/X/V/S
-CONTEMPORARY/P/S
-CONTEMPT
-CONTEMPTIBLE
-CONTEMPTUOUS/Y
-CONTEND/D/R/Z/G/S
-CONTENT/D/G/Y/S
-CONTENTION/M/S
-CONTENTMENT
-CONTEST/D/R/Z/G/S
-CONTESTABLE
-CONTEXT/M/S
-CONTEXTUAL/Y
-CONTIGUITY
-CONTIGUOUS/Y
-CONTINENT/M/S
-CONTINENTAL/Y
-CONTINGENCY/M/S
-CONTINGENT/M/S
-CONTINUAL/Y
-CONTINUANCE/M/S
-CONTINUATION/M/S
-CONTINUE/D/G/S
-CONTINUITY/S
-CONTINUO
-CONTINUOUS/Y
-CONTINUUM
-CONTOUR/D/M/G/S
-CONTRACT/D/G/S
-CONTRACTION/M/S
-CONTRACTOR/M/S
-CONTRACTUAL/Y
-CONTRADICT/D/G/S
-CONTRADICTION/M/S
-CONTRADICTORY
-CONTRADISTINCTION/S
-CONTRAPOSITIVE/S
-CONTRAPTION/M/S
-CONTRARY/P
-CONTRAST/D/R/Z/G/S
-CONTRASTINGLY
-CONTRIBUTE/D/G/N/X/S
-CONTRIBUTOR/M/S
-CONTRIBUTORILY
-CONTRIBUTORY
-CONTRIVANCE/M/S
-CONTRIVE/D/R/G/S
-CONTROL/M/S
-CONTROLLABILITY
-CONTROLLABLE
-CONTROLLABLY
-CONTROLLED
-CONTROLLER/M/S
-CONTROLLING
-CONTROVERSIAL
-CONTROVERSY/M/S
-CONUNDRUM/M/S
-CONVENE/D/G/S
-CONVENIENCE/M/S
-CONVENIENT/Y
-CONVENT/M/S
-CONVENTION/M/S
-CONVENTIONAL/Y
-CONVERGE/D/G/S
-CONVERGENCE
-CONVERGENT
-CONVERSANT/Y
-CONVERSATION/M/S
-CONVERSATIONAL/Y
-CONVERSE/D/G/N/X/Y/S
-CONVERT/D/R/Z/G/S
-CONVERTIBILITY
-CONVERTIBLE
-CONVEX
-CONVEY/D/R/Z/G/S
-CONVEYANCE/M/S
-CONVICT/D/G/S
-CONVICTION/M/S
-CONVINCE/D/R/Z/G/S
-CONVINCINGLY
-CONVOLUTED
-CONVOY/D/G/S
-CONVULSION/M/S
-COO/G
-COOK/D/G/S
-COOKERY
-COOKIE/M/S
-COOKY
-COOL/P/D/T/G/Y/S
-COOLER/M/S
-COOLIE/M/S
-COON/M/S
-COOP/D/R/Z/S
-COOPERATE/D/G/N/X/V/S
-COOPERATIVELY
-COOPERATIVES
-COOPERATOR/M/S
-COORDINATE/D/G/N/X/S
-COORDINATOR/M/S
-COP/M/S
-COPE/D/G/J/S
-COPIOUS/P/Y
-COPPER/M/S
-COPSE
-COPY/D/R/Z/G/S
-COPYRIGHT/M/S
-CORAL
-CORD/D/R/S
-CORDIAL/Y
-CORE/D/R/Z/G/S
-CORK/D/R/Z/G/S
-CORMORANT
-CORN/R/Z/G/S
-CORNERED
-CORNERSTONE/M/S
-CORNFIELD/M/S
-COROLLARY/M/S
-CORONARY/S
-CORONATION
-CORONET/M/S
-COROUTINE/M/S
-CORPOCRACY/S
-CORPORAL/M/S
-CORPORATE/N/X/Y
-CORPORATION'S
-CORPS
-CORPSE/M/S
-CORPUS
-CORRECT/P/D/G/Y/S
-CORRECTABLE
-CORRECTION/S
-CORRECTIVE/Y/S
-CORRECTOR
-CORRELATE/D/G/N/X/V/S
-CORRESPOND/D/G/S
-CORRESPONDENCE/M/S
-CORRESPONDENT/M/S
-CORRESPONDINGLY
-CORRIDOR/M/S
-CORROBORATE/D/G/N/X/V/S
-CORROSION
-CORRUPT/D/R/G/S
-CORRUPTION
-CORSET
-CORTEX
-CORTICAL
-COSINE/S
-COSMETIC/S
-COSMOLOGY
-COSMOPOLITAN
-COST/D/G/Y/S
-COSTUME/D/R/G/S
-COT/M/S
-COTTAGE/R/S
-COTTON/S
-COTYLEDON/M/S
-COUCH/D/G/S
-COUGH/D/G
-COUGHS
-COULD
-COULDN'T
-COUNCIL/M/S
-COUNCILLOR/M/S
-COUNSEL/D/G/S
-COUNSELLED
-COUNSELLING
-COUNSELLOR/M/S
-COUNSELOR/M/S
-COUNT/D/Z/G/S
-COUNTABLE
-COUNTABLY
-COUNTENANCE
-COUNTER/D/G/S
-COUNTERACT/D/G/V
-COUNTERCLOCKWISE
-COUNTEREXAMPLE/S
-COUNTERFEIT/D/R/G
-COUNTERMEASURE/M/S
-COUNTERPART/M/S
-COUNTERPOINT/G
-COUNTERPRODUCTIVE
-COUNTERREVOLUTION
-COUNTESS
-COUNTLESS
-COUNTRY/M/S
-COUNTRYMAN
-COUNTRYSIDE
-COUNTY/M/S
-COUPLE/D/R/Z/G/J/S
-COUPON/M/S
-COURAGE
-COURAGEOUS/Y
-COURIER/M/S
-COURSE/D/R/G/S
-COURT/D/R/Z/G/Y/S
-COURTEOUS/Y
-COURTESY/M/S
-COURTHOUSE/M/S
-COURTIER/M/S
-COURTROOM/M/S
-COURTSHIP
-COURTYARD/M/S
-COUSIN/M/S
-COVE/Z/S
-COVENANT/M/S
-COVER/D/G/J/S
-COVERABLE
-COVERAGE
-COVERLET/M/S
-COVERT/Y
-COVET/D/G/S
-COVETOUS/P
-COW/D/Z/G/S
-COWARD/Y
-COWARDICE
-COWBOY/M/S
-COWER/D/R/Z/G/S
-COWERINGLY
-COWL/G/S
-COWSLIP/M/S
-COYOTE/M/S
-COZY/P/R
-CPU
-CRAB/M/S
-CRACK/D/R/Z/G/S
-CRACKLE/D/G/S
-CRADLE/D/S
-CRAFT/D/R/G/S
-CRAFTSMAN
-CRAFTY/P
-CRAG/M/S
-CRAM/S
-CRAMP/M/S
-CRANBERRY/M/S
-CRANE/M/S
-CRANK/D/G/S
-CRANKILY
-CRANKY/T/R
-CRASH/D/R/Z/G/S
-CRATE/R/Z/S
-CRAVAT/M/S
-CRAVE/D/G/S
-CRAVEN
-CRAWL/D/R/Z/G/S
-CRAY
-CRAZE/D/G/S
-CRAZILY
-CRAZY/P/T/R
-CREAK/D/G/S
-CREAM/D/R/Z/G/S
-CREAMY
-CREASE/D/G/S
-CREATE/D/G/N/X/V/S
-CREATIVELY
-CREATIVENESS
-CREATIVITY
-CREATOR/M/S
-CREATURE/M/S
-CREDENCE
-CREDIBILITY
-CREDIBLE
-CREDIBLY
-CREDIT/D/G/S
-CREDITABLE
-CREDITABLY
-CREDITOR/M/S
-CREDULITY
-CREDULOUS/P
-CREED/M/S
-CREEK/M/S
-CREEP/R/Z/G/S
-CREMATE/D/G/N/X/S
-CREPE
-CREPT
-CRESCENT/M/S
-CREST/D/S
-CREVICE/M/S
-CREW/D/G/S
-CRIB/M/S
-CRICKET/M/S
-CRIME/M/S
-CRIMINAL/Y/S
-CRIMSON/G
-CRINGE/D/G/S
-CRIPPLE/D/G/S
-CRISES
-CRISIS
-CRISP/P/Y
-CRITERIA
-CRITERION
-CRITIC/M/S
-CRITICAL/Y
-CRITICISE/D
-CRITICISM/M/S
-CRITICIZE/D/G/S
-CRITIQUE/G/S
-CROAK/D/G/S
-CROCHET/S
-CROOK/D/S
-CROP/M/S
-CROPPED
-CROPPER/M/S
-CROPPING
-CROSS/D/R/Z/G/Y/J/S
-CROSSABLE
-CROSSBAR/M/S
-CROSSOVER/M/S
-CROSSWORD/M/S
-CROUCH/D/G
-CROW/D/G/S
-CROWD/D/R/G/S
-CROWN/D/G/S
-CRT
-CRUCIAL/Y
-CRUCIFY/D/G/S
-CRUDE/P/T/Y
-CRUEL/T/R/Y
-CRUELTY
-CRUISE/R/Z/G/S
-CRUMB/Y/S
-CRUMBLE/D/G/S
-CRUMPLE/D/G/S
-CRUNCH/D/G/S
-CRUNCHY/T/R
-CRUSADE/R/Z/G/S
-CRUSH/D/R/Z/G/S
-CRUSHABLE
-CRUSHINGLY
-CRUST/M/S
-CRUSTACEAN/M/S
-CRUTCH/M/S
-CRUX/M/S
-CRY/D/R/Z/G/S
-CRYPTANALYSIS
-CRYPTOGRAPHIC
-CRYPTOGRAPHY
-CRYPTOLOGY
-CRYSTAL/M/S
-CRYSTALLINE
-CRYSTALLIZE/D/G/S
-CS
-CSD
-CUB/M/S
-CUBE/D/S
-CUBIC
-CUCKOO/M/S
-CUCUMBER/M/S
-CUDDLE/D
-CUDGEL/M/S
-CUE/D/S
-CUFF/M/S
-CULL/D/R/G/S
-CULMINATE/D/G/N/S
-CULPRIT/M/S
-CULT/M/S
-CULTIVATE/D/G/N/X/S
-CULTIVATOR/M/S
-CULTURAL/Y
-CULTURE/D/G/S
-CUMBERSOME
-CUMULATIVE/Y
-CUNNING/Y
-CUP/M/S
-CUPBOARD/M/S
-CUPFUL
-CUPPED
-CUPPING
-CUR/Y/S
-CURABLE
-CURABLY
-CURB/G/S
-CURD
-CURE/D/G/S
-CURFEW/M/S
-CURIOSITY/M/S
-CURIOUS/T/R/Y
-CURL/D/R/Z/G/S
-CURRANT/M/S
-CURRENCY/M/S
-CURRENT/P/Y/S
-CURRICULA
-CURRICULAR
-CURRICULUM/M/S
-CURRY/D/G/S
-CURSE/D/G/V/S
-CURSOR/M/S
-CURSORILY
-CURSORY
-CURT/P/Y
-CURTAIL/D/S
-CURTAIN/D/S
-CURTATE
-CURTSY/M/S
-CURVATURE
-CURVE/D/G/S
-CUSHION/D/G/S
-CUSP/M/S
-CUSTARD
-CUSTODIAN/M/S
-CUSTODY
-CUSTOM/R/Z/S
-CUSTOMARILY
-CUSTOMARY
-CUSTOMIZABLE
-CUSTOMIZATION/M/S
-CUSTOMIZE/D/R/Z/G/S
-CUT/M/S
-CUTE/T
-CUTOFF
-CUTTER/M/S
-CUTTING/Y/S
-CYBERNETIC
-CYCLE/D/G/S
-CYCLIC
-CYCLICALLY
-CYCLOID/M/S
-CYCLOIDAL
-CYCLONE/M/S
-CYLINDER/M/S
-CYLINDRICAL
-CYMBAL/M/S
-CYNICAL/Y
-CYPRESS
-CYST/S
-CYTOLOGY
-CZAR
-DABBLE/D/R/G/S
-DAD/M/S
-DADDY
-DAEMON/M/S
-DAFFODIL/M/S
-DAGGER
-DAILY/S
-DAINTILY
-DAINTY/P
-DAIRY
-DAISY/M/S
-DALE/M/S
-DAM/M/S
-DAMAGE/D/R/Z/G/S
-DAMASK
-DAME
-DAMN/D/G/S
-DAMNATION
-DAMP/P/R/G/N/X
-DAMSEL/M/S
-DAN/M
-DANCE/D/R/Z/G/S
-DANDELION/M/S
-DANDY
-DANGER/M/S
-DANGEROUS/Y
-DANGLE/D/G/S
-DANIEL/M
-DARE/D/R/Z/G/S
-DARESAY
-DARINGLY
-DARK/P/T/R/N/Y
-DARLING/M/S
-DARN/D/R/G/S
-DARPA
-DART/D/R/G/S
-DASH/D/R/Z/G/S
-DASHING/Y
-DATA
-DATABASE/M/S
-DATE/D/R/G/V/S
-DATUM
-DAUGHTER/Y/S
-DAUNT/D
-DAUNTLESS
-DAVE/M
-DAVID/M
-DAWN/D/G/S
-DAY/M/S
-DAYBREAK
-DAYDREAM/G/S
-DAYLIGHT/M/S
-DAYTIME
-DAZE/D
-DAZZLE/D/R/G/S
-DAZZLINGLY
-DBMS
-DEACON/M/S
-DEAD/P/N/Y
-DEADLINE/M/S
-DEADLOCK/D/G/S
-DEAF/P/T/R/N
-DEAL/R/Z/G/J/S
-DEALLOCATE/D/G/N/X/S
-DEALLOCATED
-DEALLOCATION
-DEALT
-DEAN/M/S
-DEAR/P/T/R/H/Y
-DEARTHS
-DEATH/Y
-DEATHRATE/M/S
-DEATHS
-DEBATABLE
-DEBATE/D/R/Z/G/S
-DEBBIE/M
-DEBILITATE/D/G/S
-DEBRIS
-DEBT/M/S
-DEBTOR
-DEBUG/S
-DEBUGGED
-DEBUGGER/M/S
-DEBUGGING
-DECADE/M/S
-DECADENCE
-DECADENT/Y
-DECAY/D/G/S
-DECEASE/D/G/S
-DECEIT
-DECEITFUL/P/Y
-DECEIVE/D/R/Z/G/S
-DECELERATE/D/G/N/S
-DECEMBER
-DECENCY/M/S
-DECENT/Y
-DECENTRALIZATION
-DECENTRALIZED
-DECEPTION/M/S
-DECEPTIVE/Y
-DECIDABILITY
-DECIDABLE
-DECIDE/D/G/S
-DECIDEDLY
-DECIMAL/S
-DECIMATE/D/G/N/S
-DECIPHER/D/R/G/S
-DECISION/M/S
-DECISIVE/P/Y
-DECK/D/G/J/S
-DECLARATION/M/S
-DECLARATIVE/Y/S
-DECLARE/D/R/Z/G/S
-DECLINATION/M/S
-DECLINE/D/R/Z/G/S
-DECODE/D/R/Z/G/J/S
-DECOMPOSABILITY
-DECOMPOSABLE
-DECOMPOSE/D/G/S
-DECOMPOSITION/M/S
-DECOMPRESSION
-DECONSTRUCT/D/G/S
-DECONSTRUCTION
-DECORATE/D/G/N/X/V/S
-DECORUM
-DECOUPLE/D/G/S
-DECOY/M/S
-DECREASE/D/G/S
-DECREASINGLY
-DECREE/D/S
-DECREEING
-DECREMENT/D/G/S
-DEDICATE/D/G/N/S
-DEDUCE/D/R/G/S
-DEDUCIBLE
-DEDUCT/D/G/V
-DEDUCTION/M/S
-DEED/D/G/S
-DEEM/D/G/S
-DEEMPHASIZE/D/G/S
-DEEP/T/R/N/Y/S
-DEEPEN/D/G/S
-DEER
-DEFAULT/D/R/G/S
-DEFEAT/D/G/S
-DEFECT/D/G/V/S
-DEFECTION/M/S
-DEFEND/D/R/Z/G/S
-DEFENDANT/M/S
-DEFENESTRATE/D/G/N/S
-DEFENSE/V/S
-DEFENSELESS
-DEFER/S
-DEFERENCE
-DEFERMENT/M/S
-DEFERRABLE
-DEFERRED
-DEFERRER/M/S
-DEFERRING
-DEFIANCE
-DEFIANT/Y
-DEFICIENCY/S
-DEFICIENT
-DEFICIT/M/S
-DEFILE/G
-DEFINABLE
-DEFINE/D/R/G/S
-DEFINITE/P/N/X/Y
-DEFINITION/M/S
-DEFINITIONAL
-DEFINITIVE
-DEFORMATION/M/S
-DEFORMED
-DEFORMITY/M/S
-DEFTLY
-DEFY/D/G/S
-DEGENERATE/D/G/N/V/S
-DEGRADABLE
-DEGRADATION/M/S
-DEGRADE/D/G/S
-DEGREE/M/S
-DEIGN/D/G/S
-DEITY/M/S
-DEJECTED/Y
-DELAWARE
-DELAY/D/G/S
-DELEGATE/D/G/N/X/S
-DELETE/D/R/G/N/X/S
-DELIBERATE/P/D/G/N/X/Y/S
-DELIBERATIVE
-DELIBERATOR/M/S
-DELICACY/M/S
-DELICATE/Y
-DELICIOUS/Y
-DELIGHT/D/G/S
-DELIGHTEDLY
-DELIGHTFUL/Y
-DELIMIT/D/R/Z/G/S
-DELINEATE/D/G/N/S
-DELIRIOUS/Y
-DELIVER/D/R/Z/G/S
-DELIVERABLE/S
-DELIVERANCE
-DELIVERY/M/S
-DELL/M/S
-DELTA/M/S
-DELUDE/D/G/S
-DELUGE/D/S
-DELUSION/M/S
-DELVE/G/S
-DEMAND/D/R/G/S
-DEMANDINGLY
-DEMARCATE/N/D/G/S
-DEMEANOR
-DEMISE
-DEMO/S
-DEMOCRACY/M/S
-DEMOCRAT/M/S
-DEMOCRATIC
-DEMOCRATICALLY
-DEMOGRAPHIC
-DEMOLISH/D/S
-DEMOLITION
-DEMON/M/S
-DEMONSTRABLE
-DEMONSTRATE/D/G/N/X/V/S
-DEMONSTRATIVELY
-DEMONSTRATOR/M/S
-DEMORALIZE/D/G/S
-DEMUR
-DEN/M/S
-DENDRITE/S
-DENIABLE
-DENIAL/M/S
-DENIGRATE/D/G/S
-DENMARK
-DENOMINATION/M/S
-DENOMINATOR/M/S
-DENOTABLE
-DENOTATION/M/S
-DENOTATIONAL/Y
-DENOTE/D/G/S
-DENOUNCE/D/G/S
-DENSE/P/T/R/Y
-DENSITY/M/S
-DENT/D/G/S
-DENTAL/Y
-DENTIST/M/S
-DENY/D/R/G/S
-DEPART/D/G/S
-DEPARTMENT/M/S
-DEPARTMENTAL
-DEPARTURE/M/S
-DEPEND/D/G/S
-DEPENDABILITY
-DEPENDABLE
-DEPENDABLY
-DEPENDENCE
-DEPENDENCY/S
-DEPENDENT/Y/S
-DEPICT/D/G/S
-DEPLETE/D/G/N/X/S
-DEPLORABLE
-DEPLORE/D/S
-DEPLOY/D/G/S
-DEPLOYABLE
-DEPLOYMENT/M/S
-DEPORTATION
-DEPORTMENT
-DEPOSE/D/S
-DEPOSIT/D/G/S
-DEPOSITION/M/S
-DEPOSITOR/M/S
-DEPOT/M/S
-DEPRAVE/D
-DEPRECIATE/N/S
-DEPRESS/D/G/S
-DEPRESSION/M/S
-DEPRIVATION/M/S
-DEPRIVE/D/G/S
-DEPT
-DEPTH
-DEPTHS
-DEPUTY/M/S
-DEQUEUE/D/G/S
-DERAIL/D/G/S
-DERBY
-DERIDE
-DERISION
-DERIVABLE
-DERIVATION/M/S
-DERIVATIVE/M/S
-DERIVE/D/G/S
-DESCEND/D/R/Z/G/S
-DESCENDANT/M/S
-DESCENT/M/S
-DESCRIBABLE
-DESCRIBE/D/R/G/S
-DESCRIPTION/M/S
-DESCRIPTIVE/Y/S
-DESCRIPTOR/M/S
-DESCRY
-DESELECTED
-DESERT/D/R/Z/G/S
-DESERTION/S
-DESERVE/D/G/J/S
-DESERVINGLY
-DESIDERATA
-DESIDERATUM
-DESIGN/D/R/Z/G/S
-DESIGNATE/D/G/N/X/S
-DESIGNATOR/M/S
-DESIGNER'S
-DESIRABILITY
-DESIRABLE
-DESIRABLY
-DESIRE/D/G/S
-DESIROUS
-DESK/M/S
-DESOLATE/N/X/Y
-DESPAIR/D/G/S
-DESPAIRINGLY
-DESPATCH/D
-DESPERATE/N/Y
-DESPISE/D/G/S
-DESPITE
-DESPOT/M/S
-DESPOTIC
-DESSERT/M/S
-DESTINATION/M/S
-DESTINE/D
-DESTINY/M/S
-DESTITUTE/N
-DESTROY/D/G/S
-DESTROYER/M/S
-DESTRUCTION/M/S
-DESTRUCTIVE/P/Y
-DETACH/D/R/G/S
-DETACHMENT/M/S
-DETAIL/D/G/S
-DETAIN/D/G/S
-DETECT/D/G/V/S
-DETECTABLE
-DETECTABLY
-DETECTION/M/S
-DETECTIVES
-DETECTOR/M/S
-DETENTION
-DETERIORATE/D/G/N/S
-DETERMINABLE
-DETERMINACY
-DETERMINANT/M/S
-DETERMINATE/N/X/V/Y
-DETERMINE/D/R/Z/G/S
-DETERMINISM
-DETERMINISTIC
-DETERMINISTICALLY
-DETERRENT
-DETEST/D
-DETESTABLE
-DETRACT/S
-DETRACTOR/M/S
-DETRIMENT
-DETRIMENTAL
-DEVASTATE/D/G/N/S
-DEVELOP/D/R/Z/G/S
-DEVELOPMENT/M/S
-DEVELOPMENTAL
-DEVIANT/M/S
-DEVIATE/D/G/N/X/S
-DEVICE/M/S
-DEVIL/M/S
-DEVILISH/Y
-DEVISE/D/G/J/S
-DEVOID
-DEVOTE/D/G/N/X/S
-DEVOTEDLY
-DEVOTEE/M/S
-DEVOUR/D/R/S
-DEVOUT/P/Y
-DEW
-DEWDROP/M/S
-DEWY
-DEXTERITY
-DIADEM
-DIAGNOSABLE
-DIAGNOSE/D/G/S
-DIAGNOSIS
-DIAGNOSTIC/M/S
-DIAGONAL/Y/S
-DIAGRAM/M/S
-DIAGRAMMABLE
-DIAGRAMMATIC
-DIAGRAMMATICALLY
-DIAGRAMMED
-DIAGRAMMER/M/S
-DIAGRAMMING
-DIAL/D/G/S
-DIALECT/M/S
-DIALOG/M/S
-DIALOGUE/M/S
-DIAMETER/M/S
-DIAMETRICALLY
-DIAMOND/M/S
-DIAPER/M/S
-DIAPHRAGM/M/S
-DIARY/M/S
-DIATRIBE/M/S
-DICE
-DICHOTOMIZE
-DICHOTOMY
-DICKENS
-DICKY
-DICTATE/D/G/N/X/S
-DICTATOR/M/S
-DICTATORSHIP
-DICTION
-DICTIONARY/M/S
-DICTUM/M/S
-DID
-DIDN'T
-DIE/D/S
-DIEGO
-DIELECTRIC/M/S
-DIET/R/Z/S
-DIETITIAN/M/S
-DIFFER/D/G/R/S/Z
-DIFFERENCE/M/S
-DIFFERENT/Y
-DIFFERENTIAL/M/S
-DIFFERENTIATE/D/G/N/X/S
-DIFFERENTIATORS
-DIFFICULT/Y
-DIFFICULTY/M/S
-DIFFUSE/D/R/Z/G/N/X/Y/S
-DIG/S
-DIGEST/D/G/V/S
-DIGESTIBLE
-DIGESTION
-DIGGER/M/S
-DIGGING/S
-DIGIT/M/S
-DIGITAL/Y
-DIGITIZE/S/G/D
-DIGNIFY/D
-DIGNITY/S
-DIGRESS/D/G/V/S
-DIGRESSION/M/S
-DIKE/M/S
-DILATE/D/G/N/S
-DILEMMA/M/S
-DILIGENCE
-DILIGENT/Y
-DILUTE/D/G/N/S
-DIM/P/Y/S
-DIME/M/S
-DIMENSION/D/G/S
-DIMENSIONAL/Y
-DIMENSIONALITY
-DIMINISH/D/G/S
-DIMINUTION
-DIMINUTIVE
-DIMMED
-DIMMER/M/S
-DIMMEST
-DIMMING
-DIMPLE/D
-DIN
-DINE/D/R/Z/G/S
-DINGY/P
-DINNER/M/S
-DINT
-DIODE/M/S
-DIOPHANTINE
-DIOXIDE
-DIP/S
-DIPHTHERIA
-DIPLOMA/M/S
-DIPLOMACY
-DIPLOMAT/M/S
-DIPLOMATIC
-DIPPED
-DIPPER/M/S
-DIPPING/S
-DIRE
-DIRECT/P/D/G/Y/S
-DIRECTION/M/S
-DIRECTIONAL/Y
-DIRECTIONALITY
-DIRECTIVE/M/S
-DIRECTOR/M/S
-DIRECTORY/M/S
-DIRGE/M/S
-DIRT/S
-DIRTILY
-DIRTY/P/T/R
-DISABILITY/M/S
-DISABLE/D/R/Z/G/S
-DISADVANTAGE/M/S
-DISAGREE/D/S
-DISAGREEABLE
-DISAGREEING
-DISAGREEMENT/M/S
-DISALLOW/D/G/S
-DISAMBIGUATE/D/G/N/X/S
-DISAPPEAR/D/G/S
-DISAPPEARANCE/M/S
-DISAPPOINT/D/G
-DISAPPOINTMENT/M/S
-DISAPPROVAL
-DISAPPROVE/D/S
-DISARM/D/G/S
-DISARMAMENT
-DISASSEMBLE/D/G/S
-DISASTER/M/S
-DISASTROUS/Y
-DISBAND/D/G/S
-DISBURSE/D/G/S
-DISBURSEMENT/M/S
-DISC/M/S
-DISCARD/D/G/S
-DISCERN/D/G/S
-DISCERNIBILITY
-DISCERNIBLE
-DISCERNIBLY
-DISCERNINGLY
-DISCERNMENT
-DISCHARGE/D/G/S
-DISCIPLE/M/S
-DISCIPLINARY
-DISCIPLINE/D/G/S
-DISCLAIM/D/R/S
-DISCLOSE/D/G/S
-DISCLOSURE/M/S
-DISCOMFORT
-DISCONCERT
-DISCONCERTING/Y
-DISCONNECT/D/G/S
-DISCONNECTION
-DISCONTENT/D
-DISCONTINUANCE
-DISCONTINUE/D/S
-DISCONTINUITY/M/S
-DISCONTINUOUS
-DISCORD
-DISCOUNT/D/G/S
-DISCOURAGE/D/G/S
-DISCOURAGEMENT
-DISCOURSE/M/S
-DISCOVER/D/R/Z/G/S
-DISCOVERY/M/S
-DISCREDIT/D
-DISCREET/Y
-DISCREPANCY/M/S
-DISCRETE/P/N/Y
-DISCRIMINATE/D/G/N/S
-DISCRIMINATORY
-DISCUSS/D/G/S
-DISCUSSION/M/S
-DISDAIN/G/S
-DISEASE/D/S
-DISENGAGE/D/G/S
-DISFIGURE/D/G/S
-DISGORGE
-DISGRACE/D/S
-DISGRACEFUL/Y
-DISGRUNTLED
-DISGUISE/D/S
-DISGUST/D/G/S
-DISGUSTEDLY
-DISGUSTINGLY
-DISH/D/G/S
-DISHEARTEN/G
-DISHONEST/Y
-DISHONOR/D/G/S
-DISHWASHER/S
-DISHWASHING
-DISILLUSION/D/G
-DISILLUSIONMENT/M/S
-DISINTERESTED/P
-DISJOINT/P/D
-DISJUNCT/V/S
-DISJUNCTION/S
-DISJUNCTIVELY
-DISK/M/S
-DISKETTE/S
-DISLIKE/D/G/S
-DISLOCATE/D/G/N/X/S
-DISLODGE/D
-DISMAL/Y
-DISMAY/D/G
-DISMISS/D/R/Z/G/S
-DISMISSAL/M/S
-DISMOUNT/D/G/S
-DISOBEDIENCE
-DISOBEY/D/G/S
-DISORDER/D/Y/S
-DISORGANIZED
-DISORIENTED
-DISOWN/D/G/S
-DISPARATE
-DISPARITY/M/S
-DISPATCH/D/R/Z/G/S
-DISPEL/S
-DISPELLED
-DISPELLING
-DISPENSATION
-DISPENSE/D/R/Z/G/S
-DISPERSE/D/G/N/X/S
-DISPLACE/D/G/S
-DISPLACEMENT/M/S
-DISPLAY/D/G/S
-DISPLEASE/D/G/S
-DISPLEASURE
-DISPOSABLE
-DISPOSAL/M/S
-DISPOSE/D/R/G/S
-DISPOSITION/M/S
-DISPROVE/D/G/S
-DISPUTE/D/R/Z/G/S
-DISQUALIFY/D/G/N/S
-DISQUIET/G
-DISREGARD/D/G/S
-DISRUPT/D/G/V/S
-DISRUPTION/M/S
-DISSATISFACTION/M/S
-DISSATISFIED
-DISSEMINATE/D/G/N/S
-DISSENSION/M/S
-DISSENT/D/R/Z/G/S
-DISSERTATION/M/S
-DISSERVICE
-DISSIDENT/M/S
-DISSIMILAR
-DISSIMILARITY/M/S
-DISSIPATE/D/G/N/S
-DISSOCIATE/D/G/N/S
-DISSOLUTION/M/S
-DISSOLVE/D/G/S
-DISTAL/Y
-DISTANCE/S
-DISTANT/Y
-DISTASTE/S
-DISTASTEFUL/Y
-DISTEMPER
-DISTILL/D/R/Z/G/S
-DISTILLATION
-DISTINCT/P/Y
-DISTINCTION/M/S
-DISTINCTIVE/P/Y
-DISTINGUISH/D/G/S
-DISTINGUISHABLE
-DISTORT/D/G/S
-DISTORTION/M/S
-DISTRACT/D/G/S
-DISTRACTION/M/S
-DISTRAUGHT
-DISTRESS/D/G/S
-DISTRIBUTE/D/G/N/V/S
-DISTRIBUTION/M/S
-DISTRIBUTIONAL
-DISTRIBUTIVITY
-DISTRIBUTOR/M/S
-DISTRICT/M/S
-DISTRUST/D
-DISTURB/D/R/G/S
-DISTURBANCE/M/S
-DISTURBINGLY
-DITCH/M/S
-DITTO
-DIVAN/M/S
-DIVE/D/R/Z/G/S
-DIVERGE/D/G/S
-DIVERGENCE/M/S
-DIVERGENT
-DIVERSE/N/X/Y
-DIVERSIFY/D/G/N/S
-DIVERSITY/S
-DIVERT/D/G/S
-DIVEST/D/G/S
-DIVIDE/D/R/Z/G/S
-DIVIDEND/M/S
-DIVINE/R/G/Y
-DIVINITY/M/S
-DIVISION/M/S
-DIVISOR/M/S
-DIVORCE/D
-DIVULGE/D/G/S
-DIZZY/P
-DNA
-DO/R/Z/G/J
-DOCK/D/S
-DOCTOR/D/S
-DOCTORAL
-DOCTORATE/M/S
-DOCTRINE/M/S
-DOCUMENT/D/R/Z/G/S
-DOCUMENTARY/M/S
-DOCUMENTATION/M/S
-DODGE/D/R/Z/G
-DOES
-DOESN'T
-DOG/M/S
-DOGGED/P/Y
-DOGGING
-DOGMA/M/S
-DOGMATISM
-DOLE/D/S
-DOLEFUL/Y
-DOLL/M/S
-DOLLAR/S
-DOLLY/M/S
-DOLPHIN/M/S
-DOMAIN/M/S
-DOME/D/S
-DOMESTIC
-DOMESTICALLY
-DOMESTICATE/D/G/N/S
-DOMINANCE
-DOMINANT/Y
-DOMINATE/D/G/N/S
-DOMINION
-DON'T
-DON/S
-DONALD/M
-DONATE/D/G/S
-DONE
-DONKEY/M/S
-DOOM/D/G/S
-DOOR/M/S
-DOORSTEP/M/S
-DOORWAY/M/S
-DOPE/D/R/Z/G/S
-DORMANT
-DORMITORY/M/S
-DOSE/D/S
-DOT/M/S
-DOTE/D/G/S
-DOTINGLY
-DOTTED
-DOTTING
-DOUBLE/D/R/Z/G/S
-DOUBLET/M/S
-DOUBLY
-DOUBT/D/R/Z/G/S
-DOUBTABLE
-DOUBTFUL/Y
-DOUBTLESS/Y
-DOUG/M
-DOUGH
-DOUGHNUT/M/S
-DOUGLAS
-DOVE/R/S
-DOWN/D/Z/G/S
-DOWNCAST
-DOWNFALL/N
-DOWNPLAY/D/G/S
-DOWNRIGHT
-DOWNSTAIRS
-DOWNSTREAM
-DOWNTOWN/S
-DOWNWARD/S
-DOWNY
-DOZE/D/G/S
-DOZEN/H/S
-DR
-DRAB
-DRAFT/D/R/Z/G/S
-DRAFTSMAN
-DRAFTSMEN
-DRAG/S
-DRAGGED
-DRAGGING
-DRAGON/M/S
-DRAGOON/D/S
-DRAIN/D/R/G/S
-DRAINAGE
-DRAKE
-DRAMA/M/S
-DRAMATIC/S
-DRAMATICALLY
-DRAMATIST/M/S
-DRANK
-DRAPE/D/R/Z/S
-DRAPERY/M/S
-DRASTIC
-DRASTICALLY
-DRAUGHT/M/S
-DRAW/R/Z/G/J/S
-DRAWBACK/M/S
-DRAWBRIDGE/M/S
-DRAWL/D/G/S
-DRAWN/P/Y
-DREAD/D/G/S
-DREADFUL/Y
-DREAM/D/R/Z/G/S
-DREAMILY
-DREAMY
-DREARY/P
-DREGS
-DRENCH/D/G/S
-DRESS/D/R/Z/G/J/S
-DRESSMAKER/M/S
-DREW
-DRIER/M/S
-DRIFT/D/R/Z/G/S
-DRILL/D/R/G/S
-DRILY
-DRINK/R/Z/G/S
-DRINKABLE
-DRIP/M/S
-DRIVE/R/Z/G/S
-DRIVEN
-DRIVEWAY/M/S
-DRONE/M/S
-DROOP/D/G/S
-DROP/M/S
-DROPPED
-DROPPER/M/S
-DROPPING/M/S
-DROUGHT/M/S
-DROVE/R/Z/S
-DROWN/D/G/J/S
-DROWSY/P
-DRUDGERY
-DRUG/M/S
-DRUGGIST/M/S
-DRUM/M/S
-DRUMMED
-DRUMMER/M/S
-DRUMMING
-DRUNK/R/N/Y/S
-DRUNKARD/M/S
-DRUNKENNESS
-DRY/D/T/G/Y/S
-DUAL
-DUALITY/M/S
-DUANE/M
-DUB/S
-DUBBED
-DUBIOUS/P/Y
-DUCHESS/M/S
-DUCHY
-DUCK/D/G/S
-DUE/S
-DUEL/G/S
-DUG
-DUKE/M/S
-DULL/P/D/T/R/G/S
-DULLY
-DULY
-DUMB/P/T/R/Y
-DUMBBELL/M/S
-DUMMY/M/S
-DUMP/D/R/G/S
-DUMPLING
-DUNCE/M/S
-DUNE/M/S
-DUNGEON/M/S
-DUPLICATE/D/G/N/X/S
-DUPLICATOR/M/S
-DURABILITY/S
-DURABLE
-DURABLY
-DURATION/M/S
-DURING
-DUSK
-DUSKY/P
-DUST/D/R/Z/G/S
-DUSTY/T/R
-DUTIFUL/P/Y
-DUTY/M/S
-DWARF/D/S
-DWELL/D/R/Z/G/J/S
-DWINDLE/D/G
-DYE/D/R/Z/G/S
-DYEING
-DYNAMIC/S
-DYNAMICAL
-DYNAMICALLY
-DYNAMITE/D/G/S
-DYNASTY/M/S
-EACH
-EAGER/P/Y
-EAGLE/M/S
-EAR/D/H/S
-EARL/M/S
-EARLY/P/T/R
-EARMARK/D/G/J/S
-EARN/D/T/G/J/S
-EARNER/M/S
-EARNESTLY
-EARNESTNESS
-EARRING/M/S
-EARTHEN
-EARTHENWARE
-EARTHLY/P
-EARTHQUAKE/M/S
-EARTHS
-EARTHWORM/M/S
-EASE/D/G/S
-EASEMENT/M/S
-EASILY
-EAST/R
-EASTERN/R/Z
-EASTWARD/S
-EASY/P/T/R
-EAT/R/Z/G/N/J/S
-EAVES
-EAVESDROP/S
-EAVESDROPPED
-EAVESDROPPER/M/S
-EAVESDROPPING
-EBB/G/S
-EBONY
-ECCENTRIC/M/S
-ECCENTRICITY/S
-ECCLESIASTICAL
-ECHO/D/G
-ECHOES
-ECHOIC
-ECLIPSE/D/G/S
-ECOLOGY
-ECONOMIC/S
-ECONOMICAL/Y
-ECONOMIST/M/S
-ECONOMIZE/D/R/Z/G/S
-ECONOMY/M/S
-ECSTASY
-EDDY/M/S
-EDGE/D/G/S
-EDIBLE
-EDICT/M/S
-EDIFICE/M/S
-EDIT/D/G/S
-EDITION/M/S
-EDITOR/M/S
-EDITORIAL/Y/S
-EDUCATE/D/G/N/X/S
-EDUCATIONAL/Y
-EDUCATOR/M/S
-EDWARD/M
-EEL/M/S
-EERIE
-EFFECT/D/G/V/S
-EFFECTIVELY
-EFFECTIVENESS
-EFFECTOR/M/S
-EFFECTUALLY
-EFFEMINATE
-EFFICACY
-EFFICIENCY/S
-EFFICIENT/Y
-EFFIGY
-EFFORT/M/S
-EFFORTLESS/P/Y
-EGG/D/G/S
-EGO/S
-EIGENVALUE/M/S
-EIGHT/S
-EIGHTEEN/H/S
-EIGHTH/M/S
-EIGHTY/H/S
-EITHER
-EJACULATE/D/G/N/X/S
-EJECT/D/G/S
-EKE/D/S
-EL
-ELABORATE/P/D/G/N/X/Y/S
-ELABORATORS
-ELAPSE/D/G/S
-ELASTIC
-ELASTICALLY
-ELASTICITY
-ELBOW/G/S
-ELDER/Y/S
-ELDEST
-ELECT/D/G/V/S
-ELECTION/M/S
-ELECTIVES
-ELECTOR/M/S
-ELECTORAL
-ELECTRIC
-ELECTRICAL/P/Y
-ELECTRICITY
-ELECTRIFY/G/N
-ELECTROCUTE/D/G/N/X/S
-ELECTRODE/M/S
-ELECTROLYTE/M/S
-ELECTROLYTIC
-ELECTRON/M/S
-ELECTRONIC/S
-ELECTRONICALLY
-ELEGANCE
-ELEGANT/Y
-ELEGY
-ELEMENT/M/S
-ELEMENTAL/S
-ELEMENTARY
-ELEPHANT/M/S
-ELEVATE/D/N/S
-ELEVATOR/M/S
-ELEVEN/H/S
-ELF
-ELICIT/D/G/S
-ELIGIBILITY
-ELIGIBLE
-ELIMINATE/D/G/N/X/S
-ELIMINATOR/S
-ELISION
-ELK/M/S
-ELLIPSE/M/S
-ELLIPSIS
-ELLIPSOID/M/S
-ELLIPSOIDAL
-ELLIPTIC
-ELLIPTICAL/Y
-ELM/R/S
-ELOQUENCE
-ELOQUENT/Y
-ELSE
-ELSEWHERE
-ELUCIDATE/D/G/N/S
-ELUDE/D/G/S
-ELUSIVE/P/Y
-ELVES
-ELWOOD
-EMACIATED
-EMACS
-EMANATING
-EMANCIPATION
-EMBARK/D/S
-EMBARRASS/D/G/S
-EMBARRASSING/Y
-EMBARRASSMENT
-EMBASSY/M/S
-EMBED/S
-EMBEDDED
-EMBEDDING
-EMBELLISH/D/G/S
-EMBELLISHMENT/M/S
-EMBER
-EMBLEM
-EMBODIMENT/M/S
-EMBODY/D/G/S
-EMBRACE/D/G/S
-EMBROIDER/D/S
-EMBROIDERY/S
-EMBRYO/M/S
-EMBRYOLOGY
-EMERALD/M/S
-EMERGE/D/G/S
-EMERGENCE
-EMERGENCY/M/S
-EMERGENT
-EMERY
-EMIGRANT/M/S
-EMIGRATE/D/G/N/S
-EMINENCE
-EMINENT/Y
-EMIT/S
-EMITTED
-EMOTION/M/S
-EMOTIONAL/Y
-EMPATHY
-EMPEROR/M/S
-EMPHASES
-EMPHASIS
-EMPHASIZE/D/G/S
-EMPHATIC
-EMPHATICALLY
-EMPIRE/M/S
-EMPIRICAL/Y
-EMPIRICIST/M/S
-EMPLOY/D/G/S
-EMPLOYABLE
-EMPLOYEE/M/S
-EMPLOYER/M/S
-EMPLOYMENT/M/S
-EMPOWER/D/G/S
-EMPRESS
-EMPTILY
-EMPTY/P/D/T/R/G/S
-EMULATE/D/N/X/S
-EMULATOR/M/S
-ENABLE/D/R/Z/G/S
-ENACT/D/G/S
-ENACTMENT
-ENAMEL/D/G/S
-ENCAMP/D/G/S
-ENCAPSULATE/D/G/N/S
-ENCHANT/D/R/G/S
-ENCHANTMENT
-ENCIPHER/D/G/S
-ENCIRCLE/D/S
-ENCLOSE/D/G/S
-ENCLOSURE/M/S
-ENCODE/D/R/G/J/S
-ENCOMPASS/D/G/S
-ENCOUNTER/D/G/S
-ENCOURAGE/D/G/S
-ENCOURAGEMENT/S
-ENCOURAGINGLY
-ENCRYPT/D/G/S
-ENCRYPTION
-ENCUMBER/D/G/S
-ENCYCLOPEDIA/M/S
-ENCYCLOPEDIC
-END/D/R/Z/G/J/S
-ENDANGER/D/G/S
-ENDEAR/D/G/S
-ENDEAVOR/D/G/S
-ENDLESS/P/Y
-ENDORSE/D/G/S
-ENDORSEMENT
-ENDOW/D/G/S
-ENDOWMENT/M/S
-ENDPOINT/S
-ENDURABLE
-ENDURABLY
-ENDURANCE
-ENDURE/D/G/S
-ENDURINGLY
-ENEMA/M/S
-ENEMY/M/S
-ENERGETIC
-ENERGY/S
-ENFORCE/D/R/Z/G/S
-ENFORCEMENT
-ENGAGE/D/G/S
-ENGAGEMENT/M/S
-ENGAGINGLY
-ENGENDER/D/G/S
-ENGINE/M/S
-ENGINEER/D/M/G/S
-ENGLAND/R/Z
-ENGLISH
-ENGRAVE/D/R/G/J/S
-ENGROSS/D/G
-ENHANCE/D/G/S
-ENHANCEMENT/M/S
-ENIGMATIC
-ENJOIN/D/G/S
-ENJOY/D/G/S
-ENJOYABLE
-ENJOYABLY
-ENJOYMENT
-ENLARGE/D/R/Z/G/S
-ENLARGEMENT/M/S
-ENLIGHTEN/D/G
-ENLIGHTENMENT
-ENLIST/D/S
-ENLISTMENT
-ENLIVEN/D/G/S
-ENMITY/S
-ENNOBLE/D/G/S
-ENNUI
-ENORMITY/S
-ENORMOUS/Y
-ENOUGH
-ENQUEUE/D/S
-ENQUIRE/D/R/S
-ENRAGE/D/G/S
-ENRICH/D/G/S
-ENROLL/D/G/S
-ENROLLMENT/M/S
-ENSEMBLE/M/S
-ENSIGN/M/S
-ENSLAVE/D/G/S
-ENSNARE/D/G/S
-ENSUE/D/G/S
-ENSURE/D/R/Z/G/S
-ENTAIL/D/G/S
-ENTANGLE
-ENTER/D/G/S
-ENTERPRISE/G/S
-ENTERTAIN/D/R/Z/G/S
-ENTERTAININGLY
-ENTERTAINMENT/M/S
-ENTHUSIASM/S
-ENTHUSIAST/M/S
-ENTHUSIASTIC
-ENTHUSIASTICALLY
-ENTICE/D/R/Z/G/S
-ENTIRE/Y
-ENTIRETY/S
-ENTITLE/D/G/S
-ENTITY/M/S
-ENTRANCE/D/S
-ENTREAT/D
-ENTREATY
-ENTRENCH/D/G/S
-ENTREPRENEUR/M/S
-ENTROPY
-ENTRUST/D/G/S
-ENTRY/M/S
-ENUMERABLE
-ENUMERATE/D/G/N/V/S
-ENUMERATOR/S
-ENUNCIATION
-ENVELOP/S
-ENVELOPE/D/R/G/S
-ENVIOUS/P/Y
-ENVIRON/G/S
-ENVIRONMENT/M/S
-ENVIRONMENTAL
-ENVISAGE/D/S
-ENVISION/D/G/S
-ENVOY/M/S
-ENVY/D/S
-EOF
-EPAULET/M/S
-EPHEMERAL
-EPIC/M/S
-EPIDEMIC/M/S
-EPISCOPAL
-EPISODE/M/S
-EPISTEMOLOGICAL/Y
-EPISTEMOLOGY
-EPISTLE/M/S
-EPITAPH
-EPITAPHS
-EPITAXIAL/Y
-EPITHET/M/S
-EPITOMIZE/D/G/S
-EPOCH
-EPOCHS
-EPSILON
-EQUAL/D/G/Y/S
-EQUALITY/M/S
-EQUALIZE/D/R/Z/G/S
-EQUATE/D/G/N/X/S
-EQUATOR/M/S
-EQUATORIAL
-EQUILIBRIUM/S
-EQUIP/S
-EQUIPMENT
-EQUIPPED
-EQUIPPING
-EQUITABLE
-EQUITABLY
-EQUITY
-EQUIVALENCE/S
-EQUIVALENT/Y/S
-ERA/M/S
-ERADICATE/D/G/N/S
-ERASABLE
-ERASE/D/R/Z/G/S
-ERASURE
-ERE
-ERECT/D/G/S
-ERECTION/M/S
-ERECTOR/M/S
-ERGO
-ERGONOMIC/S
-ERMINE/M/S
-ERR/D/G/S
-ERRAND
-ERRATIC
-ERRINGLY
-ERRONEOUS/P/Y
-ERROR/M/S
-ERUPTION
-ESCALATE/D/G/N/S
-ESCAPABLE
-ESCAPADE/M/S
-ESCAPE/D/G/S
-ESCAPEE/M/S
-ESCHEW/D/G/S
-ESCORT/D/G/S
-ESOTERIC
-ESPECIAL/Y
-ESPERANTO
-ESPIONAGE
-ESPOUSE/D/G/S
-ESPRIT
-ESPY
-ESQUIRE/S
-ESSAY/D/S
-ESSENCE/M/S
-ESSENTIAL/Y/S
-ESTABLISH/D/G/S
-ESTABLISHMENT/M/S
-ESTATE/M/S
-ESTEEM/D/G/S
-ESTIMATE/D/G/N/X/S
-ETA
-ETC
-ETERNAL/Y
-ETERNITY/S
-ETHER/M/S
-ETHEREAL/Y
-ETHERNET
-ETHICAL/Y
-ETHICS
-ETHNIC
-ETHNOCENTRIC
-ETIQUETTE
-ETYMOLOGICAL
-ETYMOLOGY
-EUNUCH
-EUNUCHS
-EUPHEMISM/M/S
-EUPHORIA
-EUROPE
-EUROPEAN/S
-EVACUATE/D/N
-EVADE/D/G/S
-EVALUATE/D/G/N/X/V/S
-EVALUATOR/M/S
-EVAPORATE/D/G/N/V
-EVE/R
-EVEN/P/D/Y/S
-EVENHANDED/P/Y
-EVENING/M/S
-EVENT/M/S
-EVENTFUL/Y
-EVENTUAL/Y
-EVENTUALITY/S
-EVERGREEN
-EVERLASTING/Y
-EVERMORE
-EVERY
-EVERYBODY
-EVERYDAY
-EVERYONE/M
-EVERYTHING
-EVERYWHERE
-EVICT/D/G/S
-EVICTION/M/S
-EVIDENCE/D/G/S
-EVIDENT/Y
-EVIL/Y/S
-EVINCE/D/S
-EVOKE/D/G/S
-EVOLUTE/M/S
-EVOLUTION/M/S
-EVOLUTIONARY
-EVOLVE/D/G/S
-EWE/M/S
-EXACERBATE/D/G/N/X/S
-EXACT/P/D/G/Y/S
-EXACTINGLY
-EXACTION/M/S
-EXACTITUDE
-EXAGGERATE/D/G/N/X/S
-EXALT/D/G/S
-EXAM/M/S
-EXAMINATION/M/S
-EXAMINE/D/R/Z/G/S
-EXAMPLE/M/S
-EXASPERATE/D/G/N/S
-EXCAVATE/D/G/N/X/S
-EXCEED/D/G/S
-EXCEEDINGLY
-EXCEL/S
-EXCELLED
-EXCELLENCE/S
-EXCELLENCY
-EXCELLENT/Y
-EXCELLING
-EXCEPT/D/G/S
-EXCEPTION/M/S
-EXCEPTIONAL/Y
-EXCERPT/D/S
-EXCESS/V/S
-EXCESSIVELY
-EXCHANGE/D/G/S
-EXCHANGEABLE
-EXCHEQUER/M/S
-EXCISE/D/G/N/S
-EXCITABLE
-EXCITATION/M/S
-EXCITATORY
-EXCITE/D/G/S
-EXCITEDLY
-EXCITEMENT
-EXCITINGLY
-EXCLAIM/D/R/Z/G/S
-EXCLAMATION/M/S
-EXCLUDE/D/G/S
-EXCLUSION/S
-EXCLUSIVE/P/Y
-EXCLUSIVITY
-EXCOMMUNICATE/D/G/N/S
-EXCRETE/D/G/N/X/S
-EXCURSION/M/S
-EXCUSABLE
-EXCUSABLY
-EXCUSE/D/G/S
-EXECUTABLE
-EXECUTE/D/G/N/X/V/S
-EXECUTIONAL
-EXECUTIVE/M/S
-EXECUTOR/M/S
-EXEMPLAR
-EXEMPLARY
-EXEMPLIFY/D/R/Z/G/N/S
-EXEMPT/D/G/S
-EXERCISE/D/R/Z/G/S
-EXERT/D/G/S
-EXERTION/M/S
-EXHALE/D/G/S
-EXHAUST/D/G/V/S
-EXHAUSTEDLY
-EXHAUSTIBLE
-EXHAUSTION
-EXHAUSTIVELY
-EXHIBIT/D/G/S
-EXHIBITION/M/S
-EXHIBITOR/M/S
-EXHORTATION/M/S
-EXILE/D/G/S
-EXIST/D/G/S
-EXISTENCE
-EXISTENT
-EXISTENTIAL/Y
-EXISTENTIALISM
-EXISTENTIALIST/M/S
-EXIT/D/G/S
-EXORBITANT/Y
-EXOTIC
-EXPAND/D/G/S
-EXPANDABLE
-EXPANDER/M/S
-EXPANSE/N/X/V/S
-EXPANSIONISM
-EXPECT/D/G/S
-EXPECTANCY
-EXPECTANT/Y
-EXPECTATION/M/S
-EXPECTEDLY
-EXPECTINGLY
-EXPEDIENT/Y
-EXPEDITE/D/G/S
-EXPEDITION/M/S
-EXPEDITIOUS/Y
-EXPEL/S
-EXPELLED
-EXPELLING
-EXPEND/D/G/S
-EXPENDABLE
-EXPENDITURE/M/S
-EXPENSE/V/S
-EXPENSIVELY
-EXPERIENCE/D/G/S
-EXPERIMENT/D/R/Z/G/S
-EXPERIMENTAL/Y
-EXPERIMENTATION/M/S
-EXPERT/P/Y/S
-EXPERTISE
-EXPIRATION/M/S
-EXPIRE/D/S
-EXPLAIN/D/R/Z/G/S
-EXPLAINABLE
-EXPLANATION/M/S
-EXPLANATORY
-EXPLICIT/P/Y
-EXPLODE/D/G/S
-EXPLOIT/D/R/Z/G/S
-EXPLOITABLE
-EXPLOITATION/M/S
-EXPLORATION/M/S
-EXPLORATORY
-EXPLORE/D/R/Z/G/S
-EXPLOSION/M/S
-EXPLOSIVE/Y/S
-EXPONENT/M/S
-EXPONENTIAL/Y/S
-EXPONENTIATE/D/G/S
-EXPONENTIATION/M/S
-EXPORT/D/R/Z/G/S
-EXPOSE/D/R/Z/G/S
-EXPOSITION/M/S
-EXPOSITORY
-EXPOSURE/M/S
-EXPOUND/D/R/G/S
-EXPRESS/D/G/V/Y/S
-EXPRESSIBILITY
-EXPRESSIBLE
-EXPRESSIBLY
-EXPRESSION/M/S
-EXPRESSIVELY
-EXPRESSIVENESS
-EXPULSION
-EXPUNGE/D/G/S
-EXQUISITE/P/Y
-EXTANT
-EXTEND/D/G/S
-EXTENDIBLE
-EXTENSIBILITY
-EXTENSIBLE
-EXTENSION/M/S
-EXTENSIVE/Y
-EXTENT/M/S
-EXTENUATE/D/G/N
-EXTERIOR/M/S
-EXTERMINATE/D/G/N/S
-EXTERNAL/Y
-EXTINCT
-EXTINCTION
-EXTINGUISH/D/R/G/S
-EXTOL
-EXTRA/S
-EXTRACT/D/G/S
-EXTRACTION/M/S
-EXTRACTOR/M/S
-EXTRACURRICULAR
-EXTRANEOUS/P/Y
-EXTRAORDINARILY
-EXTRAORDINARY/P
-EXTRAPOLATE/D/G/N/X/S
-EXTRAVAGANCE
-EXTRAVAGANT/Y
-EXTREMAL
-EXTREME/Y/S
-EXTREMIST/M/S
-EXTREMITY/M/S
-EXTRINSIC
-EXUBERANCE
-EXULT
-EXULTATION
-EYE/D/R/Z/G/S
-EYEBROW/M/S
-EYEGLASS/S
-EYEING
-EYELID/M/S
-EYEPIECE/M/S
-EYESIGHT
-EYEWITNESS/M/S
-FABLE/D/S
-FABRIC/M/S
-FABRICATE/D/G/N/S
-FABULOUS/Y
-FACADE/D/S
-FACE/D/G/J/S
-FACET/D/S
-FACIAL
-FACILE/Y
-FACILITATE/D/G/S
-FACILITY/M/S
-FACSIMILE/M/S
-FACT/M/S
-FACTION/M/S
-FACTO
-FACTOR/D/G/S
-FACTORIAL
-FACTORIZATION/M/S
-FACTORY/M/S
-FACTUAL/Y
-FACULTY/M/S
-FADE/D/R/Z/G/S
-FAG/S
-FAHLMAN/M
-FAHRENHEIT
-FAIL/D/G/J/S
-FAILURE/M/S
-FAIN
-FAINT/P/D/T/R/G/Y/S
-FAIR/P/T/R/G/Y/S
-FAIRY/M/S
-FAIRYLAND
-FAITH
-FAITHFUL/P/Y
-FAITHLESS/P/Y
-FAITHS
-FAKE/D/R/G/S
-FALCON/R/S
-FALL/G/N/S
-FALLACIOUS
-FALLACY/M/S
-FALLIBILITY
-FALLIBLE
-FALSE/P/Y
-FALSEHOOD/M/S
-FALSIFY/D/G/N/S
-FALSITY
-FALTER/D/S
-FAME/D/S
-FAMILIAR/P/Y
-FAMILIARITY/S
-FAMILIARIZATION
-FAMILIARIZE/D/G/S
-FAMILY/M/S
-FAMINE/M/S
-FAMISH
-FAMOUS/Y
-FAN/M/S
-FANATIC/M/S
-FANCIER/M/S
-FANCIFUL/Y
-FANCILY
-FANCY/P/D/T/G/S
-FANG/M/S
-FANNED
-FANNING
-FANTASTIC
-FANTASY/M/S
-FAR
-FARADAY/M
-FARAWAY
-FARCE/M/S
-FARE/D/G/S
-FAREWELL/S
-FARM/D/R/Z/G/S
-FARMHOUSE/M/S
-FARMINGTON
-FARMYARD/M/S
-FARTHER
-FARTHEST
-FARTHING
-FASCINATE/D/G/N/S
-FASHION/D/G/S
-FASHIONABLE
-FASHIONABLY
-FAST/P/D/T/R/G/X/S
-FASTEN/D/R/Z/G/J/S
-FAT/P/S
-FATAL/Y/S
-FATALITY/M/S
-FATE/D/S
-FATHER/D/M/Y/S
-FATHERLAND
-FATHOM/D/G/S
-FATIGUE/D/G/S
-FATTEN/D/R/Z/G/S
-FATTER
-FATTEST
-FAULT/D/G/S
-FAULTLESS/Y
-FAULTY
-FAVOR/D/R/G/S
-FAVORABLE
-FAVORABLY
-FAVORITE/S
-FAWN/D/G/S
-FEAR/D/G/S
-FEARFUL/Y
-FEARLESS/P/Y
-FEASIBILITY
-FEASIBLE
-FEAST/D/G/S
-FEAT/M/S
-FEATHER/D/R/Z/G/S
-FEATHERY
-FEATURE/D/G/S
-FEBRUARY/M/S
-FED
-FEDERAL/Y/S
-FEDERATION
-FEE/S
-FEEBLE/P/T/R
-FEEBLY
-FEED/G/J/R/S/Z
-FEEDBACK
-FEEL/R/Z/G/J/S
-FEELINGLY
-FEET
-FEIGN/D/G
-FELICITY/S
-FELINE
-FELL/D/G
-FELLOW/M/S
-FELLOWSHIP/M/S
-FELT/S
-FEMALE/M/S
-FEMININE
-FEMININITY
-FEMUR/M/S
-FEN/S
-FENCE/D/R/Z/G/S
-FERMENT/D/G/S
-FERMENTATION/M/S
-FERN/M/S
-FEROCIOUS/P/Y
-FEROCITY
-FERRITE
-FERRY/D/S
-FERTILE/Y
-FERTILITY
-FERTILIZATION
-FERTILIZE/D/R/Z/G/S
-FERVENT/Y
-FERVOR/M/S
-FESTIVAL/M/S
-FESTIVE/Y
-FESTIVITY/S
-FETCH/D/G/S
-FETCHINGLY
-FETTER/D/S
-FEUD/M/S
-FEUDAL
-FEUDALISM
-FEVER/D/S
-FEVERISH/Y
-FEW/P/T/R
-FIBER/M/S
-FIBROSITY/S
-FIBROUS/Y
-FICKLE/P
-FICTION/M/S
-FICTIONAL/Y
-FICTITIOUS/Y
-FIDDLE/R/G/S
-FIDELITY
-FIELD/D/R/Z/G/S
-FIEND
-FIERCE/P/T/R/Y
-FIERY
-FIFE
-FIFO
-FIFTEEN/H/S
-FIFTH
-FIFTY/H/S
-FIG/M/S
-FIGHT/R/Z/G/S
-FIGURATIVE/Y
-FIGURE/D/G/J/S
-FILAMENT/M/S
-FILE/D/R/M/G/J/S
-FILENAME/M/S
-FILIAL
-FILL/D/R/Z/G/J/S
-FILLABLE
-FILM/D/G/S
-FILTER/D/M/G/S
-FILTH
-FILTHY/P/T/R
-FIN/M/S
-FINAL/Y/S
-FINALITY
-FINALIZATION
-FINALIZE/D/G/S
-FINANCE/D/G/S
-FINANCIAL/Y
-FINANCIER/M/S
-FIND/R/Z/G/J/S
-FINE/P/D/T/R/G/Y/S
-FINGER/D/G/J/S
-FINISH/D/R/Z/G/S
-FINITE/P/Y
-FIR
-FIRE/D/R/Z/G/J/S
-FIREARM/M/S
-FIREFLY/M/S
-FIRELIGHT
-FIREMAN
-FIREPLACE/M/S
-FIRESIDE
-FIREWOOD
-FIREWORKS
-FIRM/P/D/T/R/G/Y/S
-FIRMAMENT
-FIRMWARE
-FIRST/Y/S
-FIRSTHAND
-FISCAL/Y
-FISH/D/R/Z/G/S
-FISHERMAN
-FISHERY
-FISSURE/D
-FIST/D/S
-FIT/P/Y/S
-FITFUL/Y
-FITTED
-FITTER/M/S
-FITTING/Y/S
-FIVE/S
-FIX/D/R/Z/G/J/S
-FIXATE/D/G/N/X/S
-FIXEDLY
-FIXEDNESS
-FIXNUM
-FIXTURE/M/S
-FLAG/M/S
-FLAGGED
-FLAGGING
-FLAGRANT/Y
-FLAKE/D/G/S
-FLAME/D/R/Z/G/S
-FLAMINGO
-FLAMMABLE
-FLANK/D/R/G/S
-FLANNEL/M/S
-FLAP/M/S
-FLARE/D/G/S
-FLASH/D/R/Z/G/S
-FLASHLIGHT/M/S
-FLASK
-FLAT/P/Y/S
-FLATTEN/D/G
-FLATTER/D/R/G
-FLATTERY
-FLATTEST
-FLAUNT/D/G/S
-FLAVOR/D/G/J/S
-FLAW/D/S
-FLAWLESS/Y
-FLAX/N
-FLEA/M/S
-FLED
-FLEDGED
-FLEDGLING/M/S
-FLEE/S
-FLEECE/M/S
-FLEECY
-FLEEING
-FLEET/P/T/G/Y/S
-FLESH/D/G/Y/S
-FLESHY
-FLEW
-FLEXIBILITY/S
-FLEXIBLE
-FLEXIBLY
-FLICK/D/R/G/S
-FLICKERING
-FLIGHT/M/S
-FLINCH/D/G/S
-FLING/M/S
-FLINT
-FLIP/S
-FLIRT/D/G/S
-FLIT
-FLOAT/D/R/G/S
-FLOCK/D/G/S
-FLOOD/D/G/S
-FLOOR/D/G/J/S
-FLOP/M/S
-FLOPPILY
-FLOPPY
-FLORA
-FLORIDA
-FLORIN
-FLOSS/D/G/S
-FLOUNDER/D/G/S
-FLOUR/D
-FLOURISH/D/G/S
-FLOW/D/Z/G/S
-FLOWCHART/G/S
-FLOWER/D/G/S
-FLOWERY/P
-FLOWN
-FLUCTUATE/G/N/X/S
-FLUENT/Y
-FLUFFY/T/R
-FLUID/Y/S
-FLUIDITY
-FLUNG
-FLURRY/D
-FLUSH/D/G/S
-FLUTE/D/G
-FLUTTER/D/G/S
-FLY/R/Z/G/S
-FLYABLE
-FLYER/M/S
-FOAM/D/G/S
-FOCAL/Y
-FOCI
-FOCUS/D/G/S
-FODDER
-FOE/M/S
-FOG/M/S
-FOGGED
-FOGGILY
-FOGGING
-FOGGY/T/R
-FOIL/D/G/S
-FOLD/D/R/Z/G/S
-FOLIAGE
-FOLK/M/S
-FOLKLORE
-FOLLOW/D/R/Z/G/J/S
-FOLLY/S
-FOND/P/R/Y
-FONDLE/D/G/S
-FONT/M/S
-FOOD/M/S
-FOODSTUFF/M/S
-FOOL/D/G/S
-FOOLISH/P/Y
-FOOLPROOF
-FOOT/D/R/Z/G
-FOOTBALL/M/S
-FOOTHOLD
-FOOTMAN
-FOOTNOTE/M/S
-FOOTPRINT/M/S
-FOOTSTEP/S
-FOR/H
-FORAGE/D/G/S
-FORAY/M/S
-FORBADE
-FORBEAR/M/S
-FORBEARANCE
-FORBES
-FORBID/S
-FORBIDDEN
-FORBIDDING
-FORCE/D/R/M/G/S
-FORCEFUL/P/Y
-FORCIBLE
-FORCIBLY
-FORD/S
-FORE/T
-FOREARM/M/S
-FOREBODING
-FORECAST/D/R/Z/G/S
-FORECASTLE
-FOREFATHER/M/S
-FOREFINGER/M/S
-FOREGO/G
-FOREGOES
-FOREGONE
-FOREGROUND
-FOREHEAD/M/S
-FOREIGN/R/Z/S
-FOREMAN
-FOREMOST
-FORENOON
-FORESEE/S
-FORESEEABLE
-FORESEEN
-FORESIGHT/D
-FOREST/D/R/Z/S
-FORESTALL/D/G/S
-FORESTALLMENT
-FORETELL/G/S
-FORETOLD
-FOREVER
-FOREWARN/D/G/J/S
-FORFEIT/D
-FORGAVE
-FORGE/D/R/G/S
-FORGERY/M/S
-FORGET/S
-FORGETFUL/P
-FORGETTABLE
-FORGETTABLY
-FORGETTING
-FORGIVABLE
-FORGIVABLY
-FORGIVE/P/G/S
-FORGIVEN
-FORGIVINGLY
-FORGOT
-FORGOTTEN
-FORK/D/G/S
-FORLORN/Y
-FORM/D/R/G/S
-FORMAL/Y
-FORMALISM/M/S
-FORMALITY/S
-FORMALIZATION/M/S
-FORMALIZE/D/G/S
-FORMANT/S
-FORMAT/V/S
-FORMATION/M/S
-FORMATIVELY
-FORMATTED
-FORMATTER/M/S
-FORMATTING
-FORMERLY
-FORMIDABLE
-FORMULA/M/S
-FORMULAE
-FORMULATE/D/G/N/X/S
-FORMULATOR/M/S
-FORNICATION
-FORSAKE/G/S
-FORSAKEN
-FORT/M/S
-FORTE
-FORTHCOMING
-FORTHWITH
-FORTIFY/D/G/N/X/S
-FORTITUDE
-FORTNIGHT/Y
-FORTRAN
-FORTRESS/M/S
-FORTUITOUS/Y
-FORTUNATE/Y
-FORTUNE/M/S
-FORTY/R/H/S
-FORUM/M/S
-FORWARD/P/D/R/G/S
-FOSSIL
-FOSTER/D/G/S
-FOUGHT
-FOUL/P/D/T/G/Y/S
-FOUND/D/R/Z/G/S
-FOUNDATION/M/S
-FOUNDERED
-FOUNDRY/M/S
-FOUNT/M/S
-FOUNTAIN/M/S
-FOUR/H/S
-FOURIER
-FOURSCORE
-FOURTEEN/H/S
-FOWL/R/S
-FOX/M/S
-FRACTION/M/S
-FRACTIONAL/Y
-FRACTURE/D/G/S
-FRAGILE
-FRAGMENT/D/G/S
-FRAGMENTARY
-FRAGRANCE/M/S
-FRAGRANT/Y
-FRAIL/T
-FRAILTY
-FRAME/D/R/G/S
-FRAMEWORK/M/S
-FRANC/S
-FRANCE/M/S
-FRANCHISE/M/S
-FRANCISCO
-FRANK/P/D/T/R/G/Y/S
-FRANTIC
-FRANTICALLY
-FRATERNAL/Y
-FRATERNITY/M/S
-FRAUD/M/S
-FRAUGHT
-FRAY/D/G/S
-FREAK/M/S
-FRECKLE/D/S
-FREE/P/D/T/R/Y/S
-FREEDOM/M/S
-FREEING/S
-FREEMAN
-FREEZE/R/Z/G/S
-FREIGHT/D/R/Z/G/S
-FRENCH
-FRENZY/D
-FREQUENCY/S
-FREQUENT/D/R/Z/G/Y/S
-FRESH/P/T/R/X/Y
-FRESHEN/D/R/Z/G/S
-FRESHMAN
-FRESHMEN
-FRET
-FRETFUL/P/Y
-FRIAR/M/S
-FRICATIVE/S
-FRICTION/M/S
-FRICTIONLESS
-FRIDAY/M/S
-FRIEND/M/S
-FRIENDLESS
-FRIENDLY/P/T/R
-FRIENDSHIP/M/S
-FRIEZE/M/S
-FRIGATE/M/S
-FRIGHT/X
-FRIGHTEN/D/G/S
-FRIGHTENINGLY
-FRIGHTFUL/P/Y
-FRILL/M/S
-FRINGE/D
-FRISK/D/G/S
-FRIVOLOUS/Y
-FROCK/M/S
-FROG/M/S
-FROLIC/S
-FROM
-FRONT/D/G/S
-FRONTAL
-FRONTIER/M/S
-FROST/D/G/S
-FROSTY
-FROTH/G
-FROWN/D/G/S
-FROZE
-FROZEN/Y
-FRUGAL/Y
-FRUIT/M/S
-FRUITFUL/P/Y
-FRUITION
-FRUITLESS/Y
-FRUSTRATE/D/G/N/X/S
-FRY/D/S
-FUDGE
-FUEL/D/G/S
-FUGITIVE/M/S
-FUGUE
-FULFILL/D/G/S
-FULFILLMENT/S
-FULL/P/T/R
-FULLY
-FUMBLE/D/G
-FUME/D/G/S
-FUN
-FUNCTION/D/M/G/S
-FUNCTIONAL/Y/S
-FUNCTIONALITY/S
-FUNCTOR/M/S
-FUND/D/R/Z/G/S
-FUNDAMENTAL/Y/S
-FUNERAL/M/S
-FUNGUS
-FUNNEL/D/G/S
-FUNNILY
-FUNNY/P/T/R
-FUR/M/S
-FURIOUS/R/Y
-FURNACE/M/S
-FURNISH/D/G/J/S
-FURNITURE
-FURROW/D/S
-FURTHER/D/G/S
-FURTHERMORE
-FURTIVE/P/Y
-FURY/M/S
-FUSE/D/G/N/S
-FUSS/G
-FUTILE
-FUTILITY
-FUTURE/M/S
-FUZZY/P/R
-GABARDINE
-GABLE/D/R/S
-GAD
-GADGET/M/S
-GAG/G/S
-GAGGED
-GAGGING
-GAIETY/S
-GAILY
-GAIN/D/R/Z/G/S
-GAIT/D/R/Z
-GALAXY/M/S
-GALE
-GALL/D/G/S
-GALLANT/Y/S
-GALLANTRY
-GALLERY/D/S
-GALLEY/M/S
-GALLON/M/S
-GALLOP/D/R/G/S
-GALLOWS
-GAMBLE/D/R/Z/G/S
-GAME/P/D/G/Y/S
-GAMMA
-GANG/M/S
-GANGRENE
-GANGSTER/M/S
-GAP/M/S
-GAPE/D/G/S
-GARAGE/D/S
-GARB/D
-GARBAGE/M/S
-GARDEN/D/R/Z/G/S
-GARGLE/D/G/S
-GARLAND/D
-GARLIC
-GARMENT/M/S
-GARNER/D
-GARNET
-GARNISH
-GARRISON/D
-GARTER/M/S
-GARY/M
-GAS/M/S
-GASEOUS/Y
-GASH/M/S
-GASOLINE
-GASP/D/G/S
-GASSED
-GASSER
-GASSING/S
-GASTRIC
-GASTROINTESTINAL
-GATE/D/G/S
-GATEWAY/M/S
-GATHER/D/R/Z/G/J/S
-GAUDY/P
-GAUGE/D/S
-GAUNT/P
-GAUZE
-GAVE
-GAY/P/T/R/Y
-GAZE/D/R/Z/G/S
-GAZORCH/D/G
-GCD
-GEAR/D/G/S
-GEESE
-GEL/M/S
-GELATIN
-GELLED
-GELLING
-GEM/M/S
-GENDER/M/S
-GENE/M/S
-GENERAL/Y/S
-GENERALIST/M/S
-GENERALITY/S
-GENERALIZATION/M/S
-GENERALIZE/D/R/Z/G/S
-GENERATE/D/G/N/S/V/X
-GENERATOR/M/S
-GENERIC
-GENERICALLY
-GENEROSITY/M/S
-GENEROUS/P/Y
-GENETIC/S
-GENETICALLY
-GENEVA
-GENIAL/Y
-GENIUS/M/S
-GENRE/M/S
-GENTEEL
-GENTLE/P/T/R
-GENTLEMAN/Y
-GENTLEWOMAN
-GENTLY
-GENTRY
-GENUINE/P/Y
-GENUS
-GEOGRAPHIC
-GEOGRAPHICAL/Y
-GEOGRAPHY
-GEOLOGICAL
-GEOLOGIST/M/S
-GEOMETRIC
-GEOMETRICAL
-GEOMETRY/S
-GEORGETOWN
-GERANIUM
-GERM/M/S
-GERMAN/M/S
-GERMANE
-GERMANY
-GERMINATE/D/G/N/S
-GESTALT
-GESTURE/D/G/S
-GET/S
-GETTER/M/S
-GETTING
-GHASTLY
-GHOST/D/Y/S
-GIANT/M/S
-GIBBERISH
-GIDDY/P
-GIFT/D/S
-GIG
-GIGANTIC
-GIGGLE/D/G/S
-GILD/D/G/S
-GILL/M/S
-GILT
-GIMMICK/M/S
-GIN/M/S
-GINGER/Y
-GINGERBREAD
-GINGHAM/S
-GIPSY/M/S
-GIRAFFE/M/S
-GIRD
-GIRDER/M/S
-GIRDLE
-GIRL/M/S
-GIRT
-GIRTH
-GIVE/R/Z/G/S
-GIVEN
-GLACIAL
-GLACIER/M/S
-GLAD/P/Y
-GLADDER
-GLADDEST
-GLADE
-GLAMOROUS
-GLAMOUR
-GLANCE/D/G/S
-GLAND/M/S
-GLARE/D/G/S
-GLARINGLY
-GLASS/D/S
-GLASSY
-GLAZE/D/R/G/S
-GLEAM/D/G/S
-GLEAN/D/R/G/J/S
-GLEE/S
-GLEEFUL/Y
-GLEN/M/S
-GLIDE/D/R/Z/S
-GLIMMER/D/G/S
-GLIMPSE/D/S
-GLINT/D/G/S
-GLISTEN/D/G/S
-GLITCH/S
-GLITTER/D/G/S
-GLOBAL/Y
-GLOBE/M/S
-GLOBULAR
-GLOBULARITY
-GLOOM
-GLOOMILY
-GLOOMY
-GLORIFY/D/N/S
-GLORIOUS/Y
-GLORY/G/S
-GLOSS/D/G/S
-GLOSSARY/M/S
-GLOSSY
-GLOTTAL
-GLOVE/D/R/Z/G/S
-GLOW/D/R/Z/G/S
-GLOWINGLY
-GLUE/D/G/S
-GLYPH/S
-GNAT/M/S
-GNAW/D/G/S
-GNU
-GO/G/J
-GOAD/D
-GOAL/M/S
-GOAT/M/S
-GOATEE/M/S
-GOBBLE/D/R/Z/S
-GOBLET/M/S
-GOBLIN/M/S
-GOD/M/Y/S
-GODDESS/M/S
-GODLIKE
-GODMOTHER/M/S
-GOES
-GOLD/G/N/S
-GOLDENLY
-GOLDENNESS
-GOLDSMITH
-GOLF/R/Z/G
-GONE/R
-GONG/M/S
-GOOD/P/Y/S
-GOODY/M/S
-GOOSE
-GORDON/M
-GORE
-GORGE/G/S
-GORGEOUS/Y
-GORILLA/M/S
-GOSH
-GOSLING/M
-GOSPEL/Z/S
-GOSSIP/D/G/S
-GOT
-GOTHIC
-GOTO
-GOTTEN
-GOUGE/D/G/S
-GOURD
-GOVERN/D/G/S
-GOVERNESS
-GOVERNMENT/M/S
-GOVERNMENTAL/Y
-GOVERNOR/M/S
-GOWN/D/S
-GRAB/S
-GRABBED
-GRABBER/M/S
-GRABBING/S
-GRACE/D/G/S
-GRACEFUL/P/Y
-GRACIOUS/P/Y
-GRAD
-GRADATION/M/S
-GRADE/D/R/Z/G/J/S
-GRADIENT/M/S
-GRADUAL/Y
-GRADUATE/D/G/N/X/S
-GRAFT/D/R/G/S
-GRAHAM/M/S
-GRAIN/D/G/S
-GRAM/S
-GRAMMAR/M/S
-GRAMMATICAL/Y
-GRANARY/M/S
-GRAND/P/T/R/Y/S
-GRANDEUR
-GRANDFATHER/M/S
-GRANDIOSE
-GRANDMA
-GRANDMOTHER/M/S
-GRANDPA
-GRANDPARENT/S/M
-GRANDSON/M/S
-GRANGE
-GRANITE
-GRANNY
-GRANT/D/R/G/S
-GRANULARITY
-GRANULATE/D/G/S
-GRAPE/M/S
-GRAPH/D/M/G
-GRAPHIC/S
-GRAPHICAL/Y
-GRAPHITE
-GRAPHS
-GRAPPLE/D/G
-GRASP/D/G/S
-GRASPABLE
-GRASPING/Y
-GRASS/D/Z/S
-GRASSY/T/R
-GRATE/D/R/G/J/S
-GRATEFUL/P/Y
-GRATIFY/D/G/N
-GRATITUDE
-GRATUITOUS/P/Y
-GRATUITY/M/S
-GRAVE/P/T/R/Y/S
-GRAVEL/Y
-GRAVITATION
-GRAVITATIONAL
-GRAVITY
-GRAVY
-GRAY/P/D/T/R/G
-GRAZE/D/R/G
-GREASE/D/S
-GREASY
-GREAT/P/T/R/Y
-GREED
-GREEDILY
-GREEDY/P
-GREEK/M/S
-GREEN/P/T/R/G/Y/S
-GREENHOUSE/M/S
-GREENISH
-GREET/D/R/G/J/S
-GRENADE/M/S
-GREW
-GREY/T/G
-GRID/M/S
-GRIEF/M/S
-GRIEVANCE/M/S
-GRIEVE/D/R/Z/G/S
-GRIEVINGLY
-GRIEVOUS/Y
-GRIFFIN
-GRILL/D/G/S
-GRIM/P/D/Y
-GRIN/S
-GRIND/R/Z/G/J/S
-GRINDSTONE/M/S
-GRIP/D/G/S
-GRIPE/D/G/S
-GRIPPED
-GRIPPING/Y
-GRIT/M/S
-GRIZZLY
-GROAN/D/R/Z/G/S
-GROCER/M/S
-GROCERY/S
-GROOM/D/G/S
-GROOVE/D/S
-GROPE/D/G/S
-GROSS/P/D/T/R/G/Y/S
-GROTESQUE/Y/S
-GROTTO/M/S
-GROUND/D/R/Z/G/S
-GROUNDWORK
-GROUP/D/G/J/S
-GROUSE
-GROVE/R/Z/S
-GROVEL/D/G/S
-GROW/R/Z/G/H/S
-GROWL/D/G/S
-GROWN
-GROWNUP/M/S
-GROWTHS
-GRUB/M/S
-GRUDGE/M/S
-GRUESOME
-GRUFF/Y
-GRUMBLE/D/G/S
-GRUNT/D/G/S
-GUARANTEE/D/R/Z/S
-GUARANTEEING
-GUARANTY
-GUARD/D/G/S
-GUARDEDLY
-GUARDIAN/M/S
-GUARDIANSHIP
-GUERRILLA/M/S
-GUESS/D/G/S
-GUEST/M/S
-GUIDANCE
-GUIDE/D/G/S
-GUIDEBOOK/M/S
-GUIDELINE/M/S
-GUILD/R
-GUILE
-GUILT
-GUILTILY
-GUILTLESS/Y
-GUILTY/P/T/R
-GUINEA
-GUISE/M/S
-GUITAR/M/S
-GULCH/M/S
-GULF/M/S
-GULL/D/G/S
-GULLY/M/S
-GULP/D/S
-GUM/M/S
-GUN/M/S
-GUNFIRE
-GUNNED
-GUNNER/M/S
-GUNNING
-GUNPOWDER
-GURGLE
-GUSH/D/R/G/S
-GUST/M/S
-GUT/S
-GUTTER/D/S
-GUY/D/G/S
-GUYER/S
-GYMNASIUM/M/S
-GYMNAST/M/S
-GYMNASTIC/S
-GYPSY/M/S
-GYROSCOPE/M/S
-HA
-HABIT/M/S
-HABITAT/M/S
-HABITATION/M/S
-HABITUAL/P/Y
-HACK/D/R/Z/G/S
-HAD
-HADN'T
-HAG
-HAGGARD/Y
-HAIL/D/G/S
-HAIR/M/S
-HAIRCUT/M/S
-HAIRDRYER/M/S
-HAIRLESS
-HAIRY/P/R
-HALE/R
-HALF
-HALFTONE
-HALFWAY
-HALL/M/S
-HALLMARK/M/S
-HALLOW/D
-HALLWAY/M/S
-HALT/D/R/Z/G/S
-HALTINGLY
-HALVE/D/Z/G/S
-HAM/M/S
-HAMBURGER/M/S
-HAMLET/M/S
-HAMMER/D/G/S
-HAMMOCK/M/S
-HAMPER/D/S
-HAND/D/G/S
-HANDBAG/M/S
-HANDBOOK/M/S
-HANDCUFF/D/G/S
-HANDFUL/S
-HANDICAP/M/S
-HANDICAPPED
-HANDILY
-HANDIWORK
-HANDKERCHIEF/M/S
-HANDLE/D/R/Z/G/S
-HANDSOME/P/T/R/Y
-HANDWRITING
-HANDWRITTEN
-HANDY/P/T/R
-HANG/D/R/Z/G/S
-HANGAR/M/S
-HANGOVER/M/S
-HAP/Y
-HAPHAZARD/P/Y
-HAPLESS/P/Y
-HAPPEN/D/G/J/S
-HAPPILY
-HAPPY/P/T/R
-HARASS/D/G/S
-HARASSMENT
-HARBOR/D/G/S
-HARD/P/T/R/N/Y
-HARDCOPY
-HARDSHIP/M/S
-HARDWARE
-HARDWIRED
-HARDY/P
-HARE/M/S
-HARK/N
-HARLOT/M/S
-HARM/D/G/S
-HARMFUL/P/Y
-HARMLESS/P/Y
-HARMONIOUS/P/Y
-HARMONIZE
-HARMONY/S
-HARNESS/D/G
-HARP/R/Z/G
-HARROW/D/G/S
-HARRY/D/R
-HARSH/P/R/Y
-HART
-HARVARD
-HARVEST/D/R/G/S
-HAS
-HASH/D/R/G/S
-HASN'T
-HASTE/J
-HASTEN/D/G/S
-HASTILY
-HASTY/P
-HAT/M/S
-HATCH/D/G
-HATCHET/M/S
-HATE/D/R/G/S
-HATEFUL/P/Y
-HATRED
-HAUGHTILY
-HAUGHTY/P
-HAUL/D/R/G/S
-HAUNCH/M/S
-HAUNT/D/R/G/S
-HAVE/G/S
-HAVEN'T
-HAVEN/M/S
-HAVOC
-HAWAII
-HAWK/D/R/Z/S
-HAY/G/S
-HAZARD/M/S
-HAZARDOUS
-HAZE/M/S
-HAZEL
-HAZY/P
-HE'D
-HE'LL
-HE/D/M/V
-HEAD/D/R/Z/G/S
-HEADACHE/M/S
-HEADGEAR
-HEADING/M/S
-HEADLAND/M/S
-HEADLINE/D/G/S
-HEADLONG
-HEADQUARTERS
-HEADWAY
-HEAL/D/R/Z/G/H/S
-HEALTHFUL/P/Y
-HEALTHILY
-HEALTHY/P/T/R
-HEALY/M
-HEAP/D/G/S
-HEAR/R/Z/G/H/J/S
-HEARD
-HEARKEN
-HEARSAY
-HEART/N/S
-HEARTILY
-HEARTLESS
-HEARTY/P/T
-HEAT/D/R/Z/G/S
-HEATABLE
-HEATEDLY
-HEATH/R/N
-HEAVE/D/R/Z/G/S
-HEAVEN/Y/S
-HEAVILY
-HEAVY/P/T/R
-HEBREW
-HEDGE/D/S
-HEDGEHOG/M/S
-HEED/D/S
-HEEDLESS/P/Y
-HEEL/D/Z/G/S
-HEIDELBERG
-HEIFER
-HEIGHT/X/S
-HEIGHTEN/D/G/S
-HEINOUS/Y
-HEIR/M/S
-HEIRESS/M/S
-HELD
-HELL/M/S
-HELLO
-HELM
-HELMET/M/S
-HELP/D/R/Z/G/S
-HELPFUL/P/Y
-HELPLESS/P/Y
-HELVETICA
-HEM/M/S
-HEMISPHERE/M/S
-HEMLOCK/M/S
-HEMOSTAT/S
-HEMP/N
-HEN/M/S
-HENCE
-HENCEFORTH
-HENCHMAN
-HENCHMEN
-HER/S
-HERALD/D/G/S
-HERB/M/S
-HERBERT/M
-HERBIVORE
-HERBIVOROUS
-HERD/D/R/G/S
-HERE/M/S
-HEREABOUT/S
-HEREAFTER
-HEREBY
-HEREDITARY
-HEREDITY
-HEREIN
-HEREINAFTER
-HERESY
-HERETIC/M/S
-HERETOFORE
-HEREWITH
-HERITAGE/S
-HERMIT/M/S
-HERO
-HEROES
-HEROIC/S
-HEROICALLY
-HEROIN
-HEROINE/M/S
-HEROISM
-HERON/M/S
-HERRING/M/S
-HERSELF
-HESITANT/Y
-HESITATE/D/G/N/X/S
-HESITATINGLY
-HETEROGENEITY
-HETEROGENEOUS/P/Y
-HEURISTIC/M/S
-HEURISTICALLY
-HEW/D/R/S
-HEX
-HEXAGONAL/Y
-HEY
-HIATUS
-HICKORY
-HID
-HIDDEN
-HIDE/G/S
-HIDEOUS/P/Y
-HIDEOUT/M/S
-HIERARCHICAL/Y
-HIERARCHY/M/S
-HIGH/T/R/Y
-HIGHLAND/R/S
-HIGHLIGHT/D/G/S
-HIGHNESS/M/S
-HIGHWAY/M/S
-HIKE/D/R/G/S
-HILARIOUS/Y
-HILL/M/S
-HILLOCK
-HILLSIDE
-HILLTOP/M/S
-HILT/M/S
-HIM
-HIMSELF
-HIND/R/Z
-HINDERED
-HINDERING
-HINDRANCE/S
-HINDSIGHT
-HINGE/D/S
-HINT/D/G/S
-HIP/M/S
-HIRE/D/R/Z/G/J/S
-HIS
-HISS/D/G/S
-HISTOGRAM/M/S
-HISTORIAN/M/S
-HISTORIC
-HISTORICAL/Y
-HISTORY/M/S
-HIT/M/S
-HITCH/D/G
-HITCHHIKE/D/R/Z/G/S
-HITHER
-HITHERTO
-HITTER/M/S
-HITTING
-HOAR
-HOARD/R/G
-HOARSE/P/Y
-HOARY/P
-HOBBLE/D/G/S
-HOBBY/M/S
-HOBBYIST/M/S
-HOCKEY
-HOE/M/S
-HOG/M/S
-HOIST/D/G/S
-HOLD/R/Z/G/N/J/S
-HOLE/D/S
-HOLIDAY/M/S
-HOLISTIC
-HOLLAND
-HOLLOW/P/D/G/Y/S
-HOLLY
-HOLOCAUST
-HOLOGRAM/M/S
-HOLY/P/S
-HOMAGE
-HOME/D/R/Z/G/Y/S
-HOMELESS
-HOMEMADE
-HOMEMAKER/M/S
-HOMEOMORPHIC
-HOMEOMORPHISM/M/S
-HOMESICK/P
-HOMESPUN
-HOMESTEAD/R/Z/S
-HOMEWARD/S
-HOMEWORK
-HOMOGENEITY/M/S
-HOMOGENEOUS/P/Y
-HOMOMORPHIC
-HOMOMORPHISM/M/S
-HONE/D/T/R/G/S
-HONESTLY
-HONESTY
-HONEY
-HONEYCOMB/D
-HONEYMOON/D/R/Z/G/S
-HONEYSUCKLE
-HONG
-HONOLULU
-HONOR/D/R/G/S
-HONORABLE/P
-HONORABLY
-HONORARY/S
-HOOD/D/S
-HOODWINK/D/G/S
-HOOF/M/S
-HOOK/D/R/Z/G/S
-HOOP/R/S
-HOOT/D/R/G/S
-HOOVER/M
-HOP/S
-HOPE/D/G/S
-HOPEFUL/P/Y/S
-HOPELESS/P/Y
-HOPPER/M/S
-HORDE/M/S
-HORIZON/M/S
-HORIZONTAL/Y
-HORMONE/M/S
-HORN/D/S
-HORNET/M/S
-HORRENDOUS/Y
-HORRIBLE/P
-HORRIBLY
-HORRID/Y
-HORRIFY/D/G/S
-HORROR/M/S
-HORSE/Y/S
-HORSEBACK
-HORSEMAN
-HORSEPOWER
-HORSESHOE/R
-HOSE/M/S
-HOSPITABLE
-HOSPITABLY
-HOSPITAL/M/S
-HOSPITALITY
-HOSPITALIZE/D/G/S
-HOST/D/G/S
-HOSTAGE/M/S
-HOSTESS/M/S
-HOSTILE/Y
-HOSTILITY/S
-HOT/P/Y
-HOTEL/M/S
-HOTTER
-HOTTEST
-HOUND/D/G/S
-HOUR/Y/S
-HOUSE/D/G/S
-HOUSEFLY/M/S
-HOUSEHOLD/R/Z/S
-HOUSEKEEPER/M/S
-HOUSEKEEPING
-HOUSETOP/M/S
-HOUSEWIFE/Y
-HOUSEWORK
-HOUSTON
-HOVEL/M/S
-HOVER/D/G/S
-HOW
-HOWARD
-HOWEVER
-HOWL/D/R/G/S
-HUB/M/S
-HUBRIS
-HUDDLE/D/G
-HUDSON
-HUE/M/S
-HUG
-HUGE/P/Y
-HUH
-HULL/M/S
-HUM/S
-HUMAN/P/Y/S
-HUMANE/P/Y
-HUMANITY/M/S
-HUMBLE/P/D/T/R/G
-HUMBLY
-HUMID/Y
-HUMIDIFY/D/R/Z/G/N/S
-HUMIDITY
-HUMILIATE/D/G/N/X/S
-HUMILITY
-HUMMED
-HUMMING
-HUMOR/D/R/Z/G/S
-HUMOROUS/P/Y
-HUMP/D
-HUNCH/D/S
-HUNDRED/H/S
-HUNG/R/Z
-HUNGER/D/G
-HUNGRILY
-HUNGRY/T/R
-HUNK/M/S
-HUNT/D/R/Z/G/S
-HUNTSMAN
-HURL/D/R/Z/G
-HURRAH
-HURRICANE/M/S
-HURRIEDLY
-HURRY/D/G/S
-HURT/G/S
-HUSBAND/M/S
-HUSBANDRY
-HUSH/D/G/S
-HUSK/D/R/G/S
-HUSKY/P
-HUSTLE/D/R/G/S
-HUT/M/S
-HYACINTH
-HYATT
-HYBRID
-HYDRAULIC
-HYDRODYNAMIC/S
-HYDROGEN/M/S
-HYGIENE
-HYMN/M/S
-HYPER
-HYPERBOLIC
-HYPERCUBE/S
-HYPERMEDIA
-HYPERTEXT
-HYPERTEXTUAL
-HYPHEN/M/S
-HYPOCRISY/S
-HYPOCRITE/M/S
-HYPODERMIC/S
-HYPOTHESES
-HYPOTHESIS
-HYPOTHESIZE/D/R/G/S
-HYPOTHETICAL/Y
-HYSTERESIS
-HYSTERICAL/Y
-I'D
-I'LL
-I'M
-I'VE
-IBM
-ICE/D/G/J/S
-ICEBERG/M/S
-ICON/S
-ICONIC
-ICONOCLASTIC
-ICY/P
-IDEA/M/S
-IDEAL/Y/S
-IDEALISM
-IDEALISTIC
-IDEALIZATION/M/S
-IDEALIZE/D/G/S
-IDENTICAL/Y
-IDENTIFIABLE
-IDENTIFIABLY
-IDENTIFY/D/R/Z/G/N/X/S
-IDENTITY/M/S
-IDEOLOGICAL/Y
-IDEOLOGY/S
-IDIOM/S
-IDIOMATIC
-IDIOSYNCRASY/M/S
-IDIOSYNCRATIC
-IDIOT/M/S
-IDIOTIC
-IDLE/P/D/T/R/G/S
-IDLERS
-IDLY
-IDOL/M/S
-IDOLATRY
-IEEE
-IF
-IGNITION
-IGNOBLE
-IGNORANCE
-IGNORANT/Y
-IGNORE/D/G/S
-III
-ILL/S
-ILLEGAL/Y
-ILLEGALITY/S
-ILLICIT/Y
-ILLINOIS
-ILLITERATE
-ILLNESS/M/S
-ILLOGICAL/Y
-ILLUMINATE/D/G/N/X/S
-ILLUSION/M/S
-ILLUSIVE/Y
-ILLUSTRATE/D/G/N/X/V/S
-ILLUSTRATIVELY
-ILLUSTRATOR/M/S
-ILLUSTRIOUS/P
-ILLY
-IMAGE/G/S
-IMAGINABLE
-IMAGINABLY
-IMAGINARY
-IMAGINATION/M/S
-IMAGINATIVE/Y
-IMAGINE/D/G/J/S
-IMBALANCE/S
-IMITATE/D/G/N/X/V/S
-IMMACULATE/Y
-IMMATERIAL/Y
-IMMATURE
-IMMATURITY
-IMMEDIACY/S
-IMMEDIATE/Y
-IMMEMORIAL
-IMMENSE/Y
-IMMERSE/D/N/S
-IMMIGRANT/M/S
-IMMIGRATE/D/G/N/S
-IMMINENT/Y
-IMMORTAL/Y
-IMMORTALITY
-IMMOVABILITY
-IMMOVABLE
-IMMOVABLY
-IMMUNE
-IMMUNITY/M/S
-IMMUTABLE
-IMP
-IMPACT/D/G/S
-IMPACTION
-IMPACTOR/M/S
-IMPAIR/D/G/S
-IMPART/D/S
-IMPARTIAL/Y
-IMPASSE/V
-IMPATIENCE
-IMPATIENT/Y
-IMPEACH
-IMPEDANCE/M/S
-IMPEDE/D/G/S
-IMPEDIMENT/M/S
-IMPEL
-IMPENDING
-IMPENETRABILITY
-IMPENETRABLE
-IMPENETRABLY
-IMPERATIVE/Y/S
-IMPERFECT/Y
-IMPERFECTION/M/S
-IMPERIAL
-IMPERIALISM
-IMPERIALIST/M/S
-IMPERIL/D
-IMPERIOUS/Y
-IMPERMANENCE
-IMPERMANENT
-IMPERMISSIBLE
-IMPERSONAL/Y
-IMPERSONATE/D/G/N/X/S
-IMPERTINENT/Y
-IMPERVIOUS/Y
-IMPETUOUS/Y
-IMPETUS
-IMPINGE/D/G/S
-IMPIOUS
-IMPLANT/D/G/S
-IMPLAUSIBLE
-IMPLEMENT/D/G/S
-IMPLEMENTABLE
-IMPLEMENTATION/M/S
-IMPLEMENTOR/M/S
-IMPLICANT/M/S
-IMPLICATE/D/G/N/X/S
-IMPLICIT/P/Y
-IMPLORE/D/G
-IMPLY/D/G/N/X/S
-IMPORT/D/R/Z/G/S
-IMPORTANCE
-IMPORTANT/Y
-IMPORTATION
-IMPOSE/D/G/S
-IMPOSITION/M/S
-IMPOSSIBILITY/S
-IMPOSSIBLE
-IMPOSSIBLY
-IMPOSTOR/M/S
-IMPOTENCE
-IMPOTENT
-IMPOVERISH/D
-IMPOVERISHMENT
-IMPRACTICABLE
-IMPRACTICAL/Y
-IMPRACTICALITY
-IMPRECISE/N/Y
-IMPREGNABLE
-IMPRESS/D/R/G/V/S
-IMPRESSION/M/S
-IMPRESSIONABLE
-IMPRESSIONIST
-IMPRESSIONISTIC
-IMPRESSIVE/P/Y
-IMPRESSMENT
-IMPRINT/D/G/S
-IMPRISON/D/G/S
-IMPRISONMENT/M/S
-IMPROBABLE
-IMPROMPTU
-IMPROPER/Y
-IMPROVE/D/G/S
-IMPROVEMENT/S
-IMPROVISATION/M/S
-IMPROVISATIONAL
-IMPROVISE/D/R/Z/G/S
-IMPUDENT/Y
-IMPULSE/N/V/S
-IMPUNITY
-IMPURE
-IMPURITY/M/S
-IMPUTE/D
-IN
-INABILITY
-INACCESSIBLE
-INACCURACY/S
-INACCURATE
-INACTIVE
-INACTIVITY
-INADEQUACY/S
-INADEQUATE/P/Y
-INADMISSIBILITY
-INADVERTENT/Y
-INADVISABLE
-INANIMATE/Y
-INAPPLICABLE
-INAPPROPRIATE/P
-INASMUCH
-INAUGURAL
-INAUGURATE/D/G/N
-INC
-INCAPABLE
-INCAPACITATING
-INCARNATION/M/S
-INCENDIARY/S
-INCENSE/D/S
-INCENTIVE/M/S
-INCEPTION
-INCESSANT/Y
-INCH/D/G/S
-INCIDENCE
-INCIDENT/M/S
-INCIDENTAL/Y/S
-INCIPIENT
-INCITE/D/G/S
-INCLINATION/M/S
-INCLINE/D/G/S
-INCLOSE/D/G/S
-INCLUDE/D/G/S
-INCLUSION/M/S
-INCLUSIVE/P/Y
-INCOHERENT/Y
-INCOME/G/S
-INCOMMENSURATE
-INCOMPARABLE
-INCOMPARABLY
-INCOMPATIBILITY/M/S
-INCOMPATIBLE
-INCOMPATIBLY
-INCOMPETENCE
-INCOMPETENT/M/S
-INCOMPLETE/P/Y
-INCOMPREHENSIBILITY
-INCOMPREHENSIBLE
-INCOMPREHENSIBLY
-INCONCEIVABLE
-INCONCLUSIVE
-INCONSEQUENTIAL/Y
-INCONSIDERATE/P/Y
-INCONSISTENCY/M/S
-INCONSISTENT/Y
-INCONVENIENCE/D/G/S
-INCONVENIENT/Y
-INCORPORATE/D/G/N/S
-INCORRECT/P/Y
-INCREASE/D/G/S
-INCREASINGLY
-INCREDIBLE
-INCREDIBLY
-INCREDULOUS/Y
-INCREMENT/D/G/S
-INCREMENTAL/Y
-INCUBATE/D/G/N/S
-INCUBATOR/M/S
-INCUR/S
-INCURABLE
-INCURRED
-INCURRING
-INDEBTED/P
-INDECISION
-INDEED
-INDEFINITE/P/Y
-INDEMNITY
-INDENT/D/G/S
-INDENTATION/M/S
-INDEPENDENCE
-INDEPENDENT/Y/S
-INDESCRIBABLE
-INDETERMINACY/M/S
-INDETERMINATE/Y
-INDEX/D/G/S
-INDEXABLE
-INDIA
-INDIAN/M/S
-INDIANA
-INDICATE/D/G/N/X/V/S
-INDICATOR/M/S
-INDICES
-INDICTMENT/M/S
-INDIFFERENCE
-INDIFFERENT/Y
-INDIGENOUS/P/Y
-INDIGESTION
-INDIGNANT/Y
-INDIGNATION
-INDIGNITY/S
-INDIGO
-INDIRECT/D/G/Y/S
-INDIRECTION/S
-INDISCRIMINATE/Y
-INDISPENSABILITY
-INDISPENSABLE
-INDISPENSABLY
-INDISTINGUISHABLE
-INDIVIDUAL/M/Y/S
-INDIVIDUALISTIC
-INDIVIDUALITY
-INDIVIDUALIZE/D/G/S
-INDIVISIBILITY
-INDIVISIBLE
-INDOCTRINATE/D/G/N/S
-INDOLENT/Y
-INDOMITABLE
-INDOOR/S
-INDUCE/D/R/G/S
-INDUCEMENT/M/S
-INDUCT/D/G/S
-INDUCTANCE/S
-INDUCTION/M/S
-INDUCTIVE/Y
-INDUCTOR/M/S
-INDULGE/D/G
-INDULGENCE/M/S
-INDUSTRIAL/Y/S
-INDUSTRIALIST/M/S
-INDUSTRIALIZATION
-INDUSTRIOUS/P/Y
-INDUSTRY/M/S
-INEFFECTIVE/P/Y
-INEFFICIENCY/S
-INEFFICIENT/Y
-INELEGANT
-INEQUALITY/S
-INERT/P/Y
-INERTIA
-INESCAPABLE
-INESCAPABLY
-INESSENTIAL
-INESTIMABLE
-INEVITABILITY/S
-INEVITABLE
-INEVITABLY
-INEXACT
-INEXCUSABLE
-INEXCUSABLY
-INEXORABLE
-INEXORABLY
-INEXPENSIVE/Y
-INEXPERIENCE/D
-INEXPLICABLE
-INFALLIBILITY
-INFALLIBLE
-INFALLIBLY
-INFAMOUS/Y
-INFANCY
-INFANT/M/S
-INFANTRY
-INFEASIBLE
-INFECT/D/G/V/S
-INFECTION/M/S
-INFECTIOUS/Y
-INFER/S
-INFERENCE/M/S
-INFERENTIAL
-INFERIOR/M/S
-INFERIORITY
-INFERNAL/Y
-INFERNO/M/S
-INFERRED
-INFERRING
-INFEST/D/G/S
-INFIDEL/M/S
-INFINITE/P/Y
-INFINITESIMAL
-INFINITIVE/M/S
-INFINITUM
-INFINITY
-INFIRMITY
-INFIX
-INFLAME/D
-INFLAMMABLE
-INFLATABLE
-INFLATE/D/G/N/S
-INFLATIONARY
-INFLEXIBILITY
-INFLEXIBLE
-INFLICT/D/G/S
-INFLUENCE/D/G/S
-INFLUENTIAL/Y
-INFLUENZA
-INFO
-INFORM/D/R/Z/G/S
-INFORMAL/Y
-INFORMALITY
-INFORMANT/M/S
-INFORMATION
-INFORMATIONAL
-INFORMATIVE/Y
-INFREQUENT/Y
-INFRINGE/D/G/S
-INFRINGEMENT/M/S
-INFURIATE/D/G/N/S
-INFUSE/D/G/N/X/S
-INGENIOUS/P/Y
-INGENUITY
-INGRATITUDE
-INGREDIENT/M/S
-INGRES
-INHABIT/D/G/S
-INHABITABLE
-INHABITANCE
-INHABITANT/M/S
-INHALE/D/R/G/S
-INHERE/S
-INHERENT/Y
-INHERIT/D/G/S
-INHERITABLE
-INHERITANCE/M/S
-INHERITOR/M/S
-INHERITRESS/M/S
-INHERITRICES
-INHERITRIX
-INHIBIT/D/G/S
-INHIBITION/M/S
-INHIBITORS
-INHIBITORY
-INHOMOGENEITY/S
-INHUMAN
-INHUMANE
-INIQUITY/M/S
-INITIAL/D/G/Y/S
-INITIALIZATION/M/S
-INITIALIZE/D/R/Z/G/S
-INITIATE/D/G/N/X/V/S
-INITIATIVE/M/S
-INITIATOR/M/S
-INJECT/D/G/V/S
-INJECTION/M/S
-INJUNCTION/M/S
-INJURE/D/G/S
-INJURIOUS
-INJURY/M/S
-INJUSTICE/M/S
-INK/D/R/Z/G/J/S
-INKLING/M/S
-INLAID
-INLAND
-INLET/M/S
-INLINE
-INMATE/M/S
-INN/R/G/J/S
-INNARDS
-INNATE/Y
-INNERMOST
-INNOCENCE
-INNOCENT/Y/S
-INNOCUOUS/P/Y
-INNOVATE/N/X/V
-INNOVATION/M/S
-INNUMERABILITY
-INNUMERABLE
-INNUMERABLY
-INORDINATE/Y
-INPUT/M/S
-INQUIRE/D/R/Z/G/S
-INQUIRY/M/S
-INQUISITION/M/S
-INQUISITIVE/P/Y
-INROAD/S
-INSANE/Y
-INSANITY
-INSCRIBE/D/G/S
-INSCRIPTION/M/S
-INSECT/M/S
-INSECURE/Y
-INSENSIBLE
-INSENSITIVE/Y
-INSENSITIVITY
-INSEPARABLE
-INSERT/D/G/S
-INSERTION/M/S
-INSIDE/R/Z/S
-INSIDIOUS/P/Y
-INSIGHT/M/S
-INSIGNIA
-INSIGNIFICANCE
-INSIGNIFICANT
-INSINUATE/D/G/N/X/S
-INSIST/D/G/S
-INSISTENCE
-INSISTENT/Y
-INSOFAR
-INSOLENCE
-INSOLENT/Y
-INSOLUBLE
-INSPECT/D/G/S
-INSPECTION/M/S
-INSPECTOR/M/S
-INSPIRATION/M/S
-INSPIRE/D/R/G/S
-INSTABILITY/S
-INSTALL/D/R/Z/G/S
-INSTALLATION/M/S
-INSTALLMENT/M/S
-INSTANCE/S
-INSTANT/R/Y/S
-INSTANTANEOUS/Y
-INSTANTIATE/D/G/N/X/S
-INSTANTIATION/M/S
-INSTEAD
-INSTIGATE/D/G/S
-INSTIGATOR/M/S
-INSTINCT/M/V/S
-INSTINCTIVELY
-INSTITUTE/D/R/Z/G/N/X/S
-INSTITUTIONAL/Y
-INSTITUTIONALIZE/D/G/S
-INSTRUCT/D/G/V/S
-INSTRUCTION/M/S
-INSTRUCTIONAL
-INSTRUCTIVELY
-INSTRUCTOR/M/S
-INSTRUMENT/D/G/S
-INSTRUMENTAL/Y/S
-INSTRUMENTALIST/M/S
-INSTRUMENTATION
-INSUFFICIENT/Y
-INSULATE/D/G/N/S
-INSULATOR/M/S
-INSULT/D/G/S
-INSUPERABLE
-INSURANCE
-INSURE/D/R/Z/G/S
-INSURGENT/M/S
-INSURMOUNTABLE
-INSURRECTION/M/S
-INTACT
-INTANGIBLE/M/S
-INTEGER/M/S
-INTEGRAL/M/S
-INTEGRATE/D/G/N/X/V/S
-INTEGRITY
-INTELLECT/M/S
-INTELLECTUAL/Y/S
-INTELLIGENCE
-INTELLIGENT/Y
-INTELLIGIBILITY
-INTELLIGIBLE
-INTELLIGIBLY
-INTEND/D/G/S
-INTENSE/V/Y
-INTENSIFY/D/R/Z/G/N/S
-INTENSITY/S
-INTENSIVELY
-INTENT/P/Y/S
-INTENTION/D/S
-INTENTIONAL/Y
-INTER
-INTERACT/D/G/V/S
-INTERACTION/M/S
-INTERACTIVELY
-INTERACTIVITY
-INTERCEPT/D/G/S
-INTERCHANGE/D/G/J/S
-INTERCHANGEABILITY
-INTERCHANGEABLE
-INTERCHANGEABLY
-INTERCITY
-INTERCOMMUNICATE/D/G/N/S
-INTERCONNECT/D/G/S
-INTERCONNECTION/M/S
-INTERCOURSE
-INTERDEPENDENCE
-INTERDEPENDENCY/S
-INTERDEPENDENT
-INTERDISCIPLINARY
-INTEREST/D/G/S
-INTERESTINGLY
-INTERFACE/D/R/G/S
-INTERFERE/D/G/S
-INTERFERENCE/S
-INTERFERINGLY
-INTERIM
-INTERIOR/M/S
-INTERLACE/D/G/S
-INTERLEAVE/D/G/S
-INTERLINK/D/S
-INTERLISP
-INTERMEDIARY
-INTERMEDIATE/M/S
-INTERMINABLE
-INTERMINGLE/D/G/S
-INTERMITTENT/Y
-INTERMIXED
-INTERMODULE
-INTERN/D/S
-INTERNAL/Y/S
-INTERNALIZE/D/G/S
-INTERNATIONAL/Y
-INTERNATIONALITY
-INTERNET
-INTERNIST
-INTERPERSONAL
-INTERPLAY
-INTERPOLATE/D/G/N/X/S
-INTERPOSE/D/G/S
-INTERPRET/D/R/Z/G/V/S
-INTERPRETABLE
-INTERPRETATION/M/S
-INTERPRETIVELY
-INTERPROCESS
-INTERRELATE/D/G/N/X/S
-INTERRELATIONSHIP/M/S
-INTERROGATE/D/G/N/X/V/S
-INTERRUPT/D/G/V/S
-INTERRUPTIBLE
-INTERRUPTION/M/S
-INTERSECT/D/G/S
-INTERSECTION/M/S
-INTERSPERSE/D/G/N/S
-INTERSTAGE
-INTERSTATE
-INTERTEXUALITY
-INTERTWINE/D/G/S
-INTERVAL/M/S
-INTERVENE/D/G/S
-INTERVENTION/M/S
-INTERVIEW/D/R/Z/G/S
-INTERWOVEN
-INTESTINAL
-INTESTINE/M/S
-INTIMACY
-INTIMATE/D/G/N/X/Y
-INTIMIDATE/D/G/N/S
-INTO
-INTOLERABLE
-INTOLERABLY
-INTOLERANCE
-INTOLERANT
-INTONATION/M/S
-INTOXICATE/D/G/N
-INTRA
-INTRACTABILITY
-INTRACTABLE
-INTRACTABLY
-INTRAMURAL
-INTRANSIGENT
-INTRANSITIVE/Y
-INTRAPROCESS
-INTRICACY/S
-INTRICATE/Y
-INTRIGUE/D/G/S
-INTRINSIC
-INTRINSICALLY
-INTRODUCE/D/G/S
-INTRODUCTION/M/S
-INTRODUCTORY
-INTROSPECT/V
-INTROSPECTION/S
-INTROVERT/D
-INTRUDE/D/R/G/S
-INTRUDER/M/S
-INTRUSION/M/S
-INTRUST
-INTUBATE/D/N/S
-INTUITION/M/S
-INTUITIONIST
-INTUITIVE/Y
-INTUITIVENESS
-INVADE/D/R/Z/G/S
-INVALID/Y/S
-INVALIDATE/D/G/N/X/S
-INVALIDITY/S
-INVALUABLE
-INVARIABLE
-INVARIABLY
-INVARIANCE
-INVARIANT/Y/S
-INVASION/M/S
-INVENT/D/G/V/S
-INVENTION/M/S
-INVENTIVELY
-INVENTIVENESS
-INVENTOR/M/S
-INVENTORY/M/S
-INVERSE/N/X/Y/S
-INVERT/D/R/Z/G/S
-INVERTEBRATE/M/S
-INVERTIBLE
-INVEST/D/G/S
-INVESTIGATE/D/G/N/X/V/S
-INVESTIGATOR/M/S
-INVESTMENT/M/S
-INVESTOR/M/S
-INVINCIBLE
-INVISIBILITY
-INVISIBLE
-INVISIBLY
-INVITATION/M/S
-INVITE/D/G/S
-INVOCABLE
-INVOCATION/M/S
-INVOICE/D/G/S
-INVOKE/D/R/G/S
-INVOLUNTARILY
-INVOLUNTARY
-INVOLVE/D/G/S
-INVOLVEMENT/M/S
-INWARD/P/Y/S
-IODINE
-ION/S
-IPC
-IQ
-IRATE/P/Y
-IRE/M/S
-IRELAND/M
-IRIS
-IRK/D/G/S
-IRKSOME
-IRON/D/G/J/S
-IRONICAL/Y
-IRONY/S
-IRRATIONAL/Y/S
-IRRECOVERABLE
-IRREDUCIBLE
-IRREDUCIBLY
-IRREFLEXIVE
-IRREFUTABLE
-IRREGULAR/Y/S
-IRREGULARITY/S
-IRRELEVANCE/S
-IRRELEVANT/Y
-IRREPRESSIBLE
-IRRESISTIBLE
-IRRESPECTIVE/Y
-IRRESPONSIBLE
-IRRESPONSIBLY
-IRREVERSIBLE
-IRRIGATE/D/G/N/S
-IRRITATE/D/G/N/X/S
-IS
-ISLAND/R/Z/S
-ISLE/M/S
-ISLET/M/S
-ISN'T
-ISOLATE/D/G/N/X/S
-ISOMETRIC
-ISOMORPHIC
-ISOMORPHICALLY
-ISOMORPHISM/M/S
-ISOTOPE/M/S
-ISRAEL
-ISSUANCE
-ISSUE/D/R/Z/G/S
-ISTHMUS
-IT/M
-ITALIAN/M/S
-ITALIC/S
-ITALICIZE/D
-ITALY
-ITCH/G/S
-ITEM/M/S
-ITEMIZATION/M/S
-ITEMIZE/D/G/S
-ITERATE/D/G/N/X/V/S
-ITERATIVE/Y
-ITERATOR/M/S
-ITS
-ITSELF
-ITT
-IV
-IVORY
-IVY/M/S
-JAB/M/S
-JABBED
-JABBING
-JACK
-JACKET/D/S
-JADE/D
-JAIL/D/R/Z/G/S
-JAM/S
-JAMES
-JAMMED
-JAMMING
-JANITOR/M/S
-JANUARY/M/S
-JAPAN
-JAPANESE
-JAR/M/S
-JARGON
-JARRED
-JARRING/Y
-JASMINE/M
-JAUNDICE
-JAUNT/M/S
-JAUNTY/P
-JAVELIN/M/S
-JAW/M/S
-JAY
-JAZZ
-JEALOUS/Y
-JEALOUSY/S
-JEAN/M/S
-JEEP/M/S
-JEER/M/S
-JELLY/M/S
-JELLYFISH
-JENNY
-JEOPARDIZE/D/G/S
-JERK/D/G/J/S
-JERKY/P
-JERSEY/M/S
-JEST/D/R/G/S
-JET/M/S
-JETTED
-JETTING
-JEWEL/D/R/S
-JEWELRY/S
-JIG/M/S
-JILL
-JIM/M
-JINGLE/D/G
-JOAN/M
-JOB/M/S
-JOCUND
-JOE/M
-JOG/S
-JOHN/M
-JOIN/D/R/Z/G/S
-JOINT/M/Y/S
-JOKE/D/R/Z/G/S
-JOLLY
-JOLT/D/G/S
-JOSE/M
-JOSTLE/D/G/S
-JOT/S
-JOTTED
-JOTTING
-JOURNAL/M/S
-JOURNALISM
-JOURNALIST/M/S
-JOURNALIZE/D/G/S
-JOURNEY/D/G/J/S
-JOUST/D/G/S
-JOY/M/S
-JOYFUL/Y
-JOYOUS/P/Y
-JOYSTICK
-JR
-JUBILEE
-JUDGE/D/G/S
-JUDGMENT/M/S
-JUDICABLE
-JUDICIAL
-JUDICIARY
-JUDICIOUS/Y
-JUDY/M
-JUG/M/S
-JUGGLE/R/Z/G/S
-JUICE/M/S
-JUICY/T
-JULY/M/S
-JUMBLE/D/S
-JUMP/D/R/Z/G/S
-JUMPY
-JUNCTION/M/S
-JUNCTURE/M/S
-JUNE
-JUNGLE/M/S
-JUNIOR/M/S
-JUNIPER
-JUNK/R/Z/S
-JURISDICTION/M/S
-JUROR/M/S
-JURY/M/S
-JUST/P/Y
-JUSTICE/M/S
-JUSTIFIABLE
-JUSTIFIABLY
-JUSTIFIER'S
-JUSTIFY/D/R/Z/G/N/X/S
-JUT
-JUVENILE/M/S
-JUXTAPOSE/D/G/S
-KAISER
-KANJI
-KEEL/D/G/S
-KEEN/P/T/R/Y
-KEEP/R/Z/G/S
-KEN
-KENNEL/M/S
-KEPT
-KERCHIEF/M/S
-KERNEL/M/S
-KERNING
-KEROSENE
-KETCHUP
-KETTLE/M/S
-KEY/D/G/S
-KEYBOARD/M/S
-KEYNOTE
-KEYPAD/M/S
-KEYSTROKE/M/S
-KEYWORD/M/S
-KICK/D/R/Z/G/S
-KID/M/S
-KIDDED
-KIDDING
-KIDNAP/S/R/D/G/M
-KIDNAPPED
-KIDNAPPER/M/S
-KIDNAPPING/M/S
-KIDNEY/M/S
-KILL/D/R/Z/G/J/S
-KILLINGLY
-KILOGRAM/S
-KILOMETER/S
-KIN
-KIND/P/T/R/Y/S
-KINDERGARTEN
-KINDHEARTED
-KINDLE/D/G/S
-KINDRED
-KING/Y/S
-KINGDOM/M/S
-KINSHIP
-KINSMAN
-KISS/D/R/Z/G/S
-KIT/M/S
-KITCHEN/M/S
-KITE/D/G/S
-KITTEN/M/S
-KITTY
-KLUDGES
-KNACK
-KNAPSACK/M/S
-KNAVE/M/S
-KNEAD/S
-KNEE/D/S
-KNEEING
-KNEEL/D/G/S
-KNELL/M/S
-KNELT
-KNEW
-KNICKERBOCKER/M/S
-KNIFE/D/G/S
-KNIGHT/D/G/Y/S
-KNIGHTHOOD
-KNIT/S
-KNIVES
-KNOB/M/S
-KNOCK/D/R/Z/G/S
-KNOLL/M/S
-KNOT/M/S
-KNOTTED
-KNOTTING
-KNOW/R/G/S
-KNOWABLE
-KNOWHOW
-KNOWINGLY
-KNOWLEDGE
-KNOWLEDGEABLE
-KNOWN
-KNUCKLE/D/S
-KONG
-KYOTO
-LAB/M/S
-LABEL/S/D/R/G/M
-LABOR/D/R/Z/G/J/S
-LABORATORY/M/S
-LABORIOUS/Y
-LABYRINTH
-LABYRINTHS
-LACE/D/G/S
-LACERATE/D/G/N/X/S
-LACK/D/G/S
-LACQUER/D/S
-LAD/G/N/S
-LADDER
-LADLE
-LADY/M/S
-LAG/R/Z/S
-LAGOON/M/S
-LAGRANGIAN
-LAID
-LAIN
-LAIR/M/S
-LAKE/M/S
-LAMB/M/S
-LAMBDA
-LAME/P/D/G/Y/S
-LAMENT/D/G/S
-LAMENTABLE
-LAMENTATION/M/S
-LAMINAR
-LAMP/M/S
-LANCE/D/R/S
-LANCHESTER
-LAND/D/R/Z/G/J/S
-LANDLADY/M/S
-LANDLORD/M/S
-LANDMARK/M/S
-LANDOWNER/M/S
-LANDSCAPE/D/G/S
-LANE/M/S
-LANGUAGE/M/S
-LANGUID/P/Y
-LANGUISH/D/G/S
-LANSING
-LANTERN/M/S
-LAP/M/S
-LAPEL/M/S
-LAPIDARY
-LAPSE/D/G/S
-LARD/R
-LARGE/P/T/R/Y
-LARK/M/S
-LARVA
-LARVAE
-LAS
-LASER/M/S
-LASH/D/G/J/S
-LASS/M/S
-LAST/D/G/Y/S
-LATCH/D/G/S
-LATE/P/T/R/Y
-LATENCY
-LATENT
-LATERAL/Y
-LATITUDE/M/S
-LATRINE/M/S
-LATTER/Y
-LATTICE/M/S
-LAUGH/D/G
-LAUGHABLE
-LAUGHABLY
-LAUGHINGLY
-LAUGHS
-LAUGHTER
-LAUNCH/D/R/G/J/S
-LAUNDER/D/R/G/J/S
-LAUNDRY
-LAURA/M
-LAUREL/M/S
-LAVA
-LAVATORY/M/S
-LAVENDER
-LAVISH/D/G/Y
-LAW/M/S
-LAWFUL/Y
-LAWLESS/P
-LAWN/M/S
-LAWRENCE/M
-LAWSUIT/M/S
-LAWYER/M/S
-LAY/G/S
-LAYER/D/G/S
-LAYMAN
-LAYMEN
-LAYOFFS
-LAYOUT/M/S
-LAZED
-LAZILY
-LAZING
-LAZY/P/T/R
-LEAD/D/R/Z/G/N/J/S
-LEADERSHIP/M/S
-LEAF/D/G
-LEAFLESS
-LEAFLET/M/S
-LEAFY/T
-LEAGUE/D/R/Z/S
-LEAK/D/G/S
-LEAKAGE/M/S
-LEAN/P/D/T/R/G/S
-LEAP/D/G/S
-LEAPT
-LEARN/D/R/Z/G/S
-LEASE/D/G/S
-LEASH/M/S
-LEAST
-LEATHER/D/S
-LEATHERN
-LEAVE/D/G/J/S
-LEAVEN/D/G
-LECTURE/D/R/Z/G/S
-LED
-LEDGE/R/Z/S
-LEE/R/S
-LEECH/M/S
-LEFT
-LEFTIST/M/S
-LEFTMOST
-LEFTOVER/M/S
-LEFTWARD
-LEG/S
-LEGACY/M/S
-LEGAL/Y
-LEGALITY
-LEGALIZATION
-LEGALIZE/D/G/S
-LEGEND/M/S
-LEGENDARY
-LEGGED
-LEGGINGS
-LEGIBILITY
-LEGIBLE
-LEGIBLY
-LEGION/M/S
-LEGISLATE/D/G/N/V/S
-LEGISLATOR/M/S
-LEGISLATURE/M/S
-LEGITIMACY
-LEGITIMATE/Y
-LEGUME/S
-LEISURE/Y
-LEMMA/M/S
-LEMON/M/S
-LEMONADE
-LEND/R/Z/G/S
-LENGTH/N/Y
-LENGTHEN/D/G/S
-LENGTHS
-LENGTHWISE
-LENGTHY
-LENIENCY
-LENIENT/Y
-LENS/M/S
-LENT/N
-LENTIL/M/S
-LEOPARD/M/S
-LEPROSY
-LESS/R
-LESSEN/D/G/S
-LESSON/M/S
-LEST/R
-LET/M/S
-LETTER/D/R/G/S
-LETTING
-LETTUCE
-LEUKEMIA
-LEVEE/M/S
-LEVEL/P/D/R/G/Y/S/T
-LEVELLED
-LEVELLER
-LEVELLEST
-LEVELLING
-LEVER/M/S
-LEVERAGE
-LEVY/D/G/S
-LEWD/P/Y
-LEXIA/S
-LEXICAL/Y
-LEXICOGRAPHIC
-LEXICOGRAPHICAL/Y
-LEXICON/M/S
-LIABILITY/M/S
-LIABLE
-LIAISON/M/S
-LIAR/M/S
-LIBERAL/Y/S
-LIBERALIZE/D/G/S
-LIBERATE/D/G/N/S
-LIBERATOR/M/S
-LIBERTY/M/S
-LIBIDO
-LIBRARIAN/M/S
-LIBRARY/M/S
-LICENSE/D/G/S
-LICHEN/M/S
-LICK/D/G/S
-LID/M/S
-LIE/D/S
-LIEGE
-LIEN/M/S
-LIEU
-LIEUTENANT/M/S
-LIFE/R
-LIFELESS/P
-LIFELIKE
-LIFELONG
-LIFESTYLE/S
-LIFETIME/M/S
-LIFT/D/R/Z/G/S
-LIGHT/P/D/T/G/N/X/Y/S
-LIGHTER/M/S
-LIGHTHOUSE/M/S
-LIGHTNING/M/S
-LIGHTWEIGHT
-LIKE/D/G/S
-LIKELIHOOD/S
-LIKELY/P/T/R
-LIKEN/D/G/S
-LIKENESS/M/S
-LIKEWISE
-LILAC/M/S
-LILY/M/S
-LIMB/R/S
-LIME/M/S
-LIMESTONE
-LIMIT/D/R/Z/G/S
-LIMITABILITY
-LIMITABLY
-LIMITATION/M/S
-LIMITLESS
-LIMP/P/D/G/Y/S
-LINDA/M
-LINDEN
-LINE'S
-LINE/D/R/Z/G/J/S
-LINEAR/Y
-LINEARITY/S
-LINEARIZABLE
-LINEARIZE/D/G/S
-LINEFEED
-LINEN/M/S
-LINGER/D/G/S
-LINGUIST/M/S
-LINGUISTIC/S
-LINGUISTICALLY
-LINK/D/R/G/S
-LINKAGE/M/S
-LINOLEUM
-LINSEED
-LION/M/S
-LIONESS/M/S
-LIP/M/S
-LIPSTICK
-LIQUEFY/D/R/Z/G/S
-LIQUID/M/S
-LIQUIDATION/M/S
-LIQUIDITY
-LIQUIFY/D/R/Z/G/S
-LISBON
-LISP/D/M/G/S
-LIST/D/R/Z/G/X/S
-LISTEN/D/R/Z/G/S
-LISTING/M/S
-LIT/R/Z
-LITERACY
-LITERAL/P/Y/S
-LITERARY
-LITERATE
-LITERATURE/M/S
-LITHE
-LITTER/D/G/S
-LITTLE/P/T/R
-LIVABLE
-LIVABLY
-LIVE/P/D/R/Z/G/Y/S
-LIVELIHOOD
-LIVERY/D
-LIZARD/M/S
-LOAD/D/R/Z/G/J/S
-LOAF/D/R
-LOAN/D/G/S
-LOATH/Y
-LOATHE/D/G
-LOATHSOME
-LOAVES
-LOBBY/D/S
-LOBE/M/S
-LOBSTER/M/S
-LOCAL/Y/S
-LOCALITY/M/S
-LOCALIZATION
-LOCALIZE/D/G/S
-LOCATE/D/G/N/X/V/S
-LOCATIVES
-LOCATOR/M/S
-LOCI
-LOCK/D/R/Z/G/J/S
-LOCKOUT/M/S
-LOCKUP/M/S
-LOCOMOTION
-LOCOMOTIVE/M/S
-LOCUS
-LOCUST/M/S
-LODGE/D/R/G/J/S
-LOFT/M/S
-LOFTY/P
-LOG/M/S
-LOGARITHM/M/S
-LOGGED
-LOGGER/M/S
-LOGGING
-LOGIC/M/S
-LOGICAL/Y
-LOGICIAN/M/S
-LOGISTIC/S
-LOIN/M/S
-LOITER/D/R/G/S
-LONDON
-LONE/R/Z
-LONELY/P/T/R
-LONESOME
-LONG/D/T/R/G/J/S
-LONGITUDE/M/S
-LOOK/D/R/Z/G/S
-LOOKAHEAD
-LOOKOUT
-LOOKUP/M/S
-LOOM/D/G/S
-LOON
-LOOP/D/G/S
-LOOPHOLE/M/S
-LOOSE/P/D/T/R/G/Y/S
-LOOSEN/D/G/S
-LOOT/D/R/G/S
-LORD/Y/S
-LORDSHIP
-LORE
-LORRY
-LOSE/R/Z/G/S
-LOSS/M/S
-LOSSAGE
-LOSSY/T/R
-LOST
-LOT/M/S
-LOTTERY
-LOUD/P/T/R/Y
-LOUDSPEAKER/M/S
-LOUNGE/D/G/S
-LOUSY
-LOVABLE
-LOVABLY
-LOVE/D/R/Z/G/S
-LOVELY/P/T/R/S
-LOVINGLY
-LOW/P/T/Y/S
-LOWER/D/G/S
-LOWERCASE
-LOWLAND/S
-LOWLIEST
-LOYAL/Y
-LOYALTY/M/S
-LTD
-LUBRICANT/M
-LUBRICATION
-LUCID
-LUCK/D/S
-LUCKILY
-LUCKLESS
-LUCKY/T/R
-LUDICROUS/P/Y
-LUGGAGE
-LUKEWARM
-LULL/D/S
-LULLABY
-LUMBER/D/G
-LUMINOUS/Y
-LUMP/D/G/S
-LUNAR
-LUNATIC
-LUNCH/D/G/S
-LUNCHEON/M/S
-LUNG/D/S
-LURCH/D/G/S
-LURE/D/G/S
-LURK/D/G/S
-LUSCIOUS/P/Y
-LUST/R/S
-LUSTILY
-LUSTROUS
-LUSTY/P
-LUTE/M/S
-LUXURIANT/Y
-LUXURIOUS/Y
-LUXURY/M/S
-LYING
-LYMPH
-LYNCH/D/R/S
-LYNX/M/S
-LYRE
-LYRIC/S
-MA'AM
-MACE/D/S
-MACH
-MACHINE/D/M/G/S
-MACHINERY
-MACLACHLAN/M
-MACRO/M/S
-MACROECONOMICS
-MACROMOLECULAR
-MACROMOLECULE/M/S
-MACROSCOPIC
-MACROSTEP/S
-MACROSTRUCTURE
-MAD/P/Y
-MADAM
-MADDEN/G
-MADDER
-MADDEST
-MADE
-MADEMOISELLE
-MADISON
-MADMAN
-MADRAS
-MAGAZINE/M/S
-MAGGOT/M/S
-MAGIC
-MAGICAL/Y
-MAGICIAN/M/S
-MAGISTRATE/M/S
-MAGNESIUM
-MAGNET
-MAGNETIC
-MAGNETISM/M/S
-MAGNIFICENCE
-MAGNIFICENT/Y
-MAGNIFY/D/R/G/N/S
-MAGNITUDE/M/S
-MAHOGANY
-MAID/N/X/S
-MAIL/D/R/G/J/S
-MAILABLE
-MAILBOX/M/S
-MAIM/D/G/S
-MAIN/Y/S
-MAINE
-MAINFRAME/M/S
-MAINLAND
-MAINSTAY
-MAINSTREAM
-MAINTAIN/D/R/Z/G/S
-MAINTAINABILITY
-MAINTAINABLE
-MAINTENANCE/M/S
-MAIZE
-MAJESTIC
-MAJESTY/M/S
-MAJOR/D/S
-MAJORITY/M/S
-MAKABLE
-MAKE/R/Z/G/J/S
-MAKESHIFT
-MAKEUP/S
-MALADY/M/S
-MALARIA
-MALE/P/M/S
-MALEFACTOR/M/S
-MALFUNCTION/D/G/S
-MALICE
-MALICIOUS/P/Y
-MALIGNANT/Y
-MALLET/M/S
-MALNUTRITION
-MALT/D/S
-MAMA
-MAMMA/M/S
-MAMMAL/M/S
-MAMMOTH
-MAN/M/Y/S
-MANAGE/D/R/Z/G/S
-MANAGEABLE/P
-MANAGEMENT/M/S
-MANAGER/M/S
-MANAGERIAL
-MANDATE/D/G/S
-MANDATORY
-MANDIBLE
-MANE/M/S
-MANEUVER/D/G/S
-MANGER/M/S
-MANGLE/D/R/G/S
-MANHOOD
-MANIAC/M/S
-MANICURE/D/G/S
-MANIFEST/D/G/Y/S
-MANIFESTATION/M/S
-MANIFOLD/M/S
-MANILA
-MANIPULABILITY
-MANIPULABLE
-MANIPULATABLE
-MANIPULATE/D/G/N/X/V/S
-MANIPULATOR/M/S
-MANIPULATORY
-MANKIND
-MANNED
-MANNER/D/Y/S
-MANNING
-MANOMETER/M/S
-MANOR/M/S
-MANPOWER
-MANSION/M/S
-MANTEL/M/S
-MANTISSA/M/S
-MANTLE/M/S
-MANUAL/M/Y/S
-MANUFACTURE/D/R/Z/G/S
-MANUFACTURER/M/S
-MANURE
-MANUSCRIPT/M/S
-MANY
-MAP/M/S
-MAPLE/M/S
-MAPPABLE
-MAPPED
-MAPPING/M/S
-MAR/S
-MARBLE/G/S
-MARC/M
-MARCH/D/R/G/S
-MARE/M/S
-MARGIN/M/S
-MARGINAL/Y
-MARIGOLD
-MARIJUANA
-MARINE/R/S
-MARIO/M
-MARITAL
-MARITIME
-MARK/D/R/Z/G/J/S
-MARKABLE
-MARKEDLY
-MARKET/D/G/J/S
-MARKETABILITY
-MARKETABLE
-MARKETPLACE/M/S
-MARKOV
-MARQUIS
-MARRIAGE/M/S
-MARROW
-MARRY/D/G/S
-MARSH/M/S
-MARSHAL/D/G/S
-MART/N/S
-MARTHA/M
-MARTIAL
-MARTIN/M
-MARTYR/M/S
-MARTYRDOM
-MARVEL/D/S/G
-MARVELLED
-MARVELLING
-MARVELOUS/P/Y
-MARVIN/M
-MARY/M
-MARYLAND
-MASCULINE/Y
-MASCULINITY
-MASH/D/G/S
-MASK/D/R/G/J/S
-MASOCHIST/M/S
-MASON/M/S
-MASONRY
-MASQUERADE/R/G/S
-MASS/D/G/V/S
-MASSACHUSETTS
-MASSACRE/D/S
-MASSAGE/G/S
-MASSIVE/Y
-MAST/D/Z/S
-MASTER/D/M/G/Y/J/S
-MASTERFUL/Y
-MASTERPIECE/M/S
-MASTERY
-MASTURBATE/D/G/N/S
-MAT/M/S
-MATCH/D/R/Z/G/J/S
-MATCHABLE
-MATCHLESS
-MATE/D/R/M/G/J/S
-MATERIAL/Y/S
-MATERIALIZE/D/G/S
-MATERNAL/Y
-MATH
-MATHEMATICAL/Y
-MATHEMATICIAN/M/S
-MATHEMATICS
-MATRICES
-MATRICULATION
-MATRIMONY
-MATRIX
-MATRON/Y
-MATTED
-MATTER/D/S
-MATTRESS/M/S
-MATURATION
-MATURE/D/G/Y/S
-MATURITY/S
-MAURICE/M
-MAX
-MAXIM/M/S
-MAXIMAL/Y
-MAXIMIZE/D/R/Z/G/S
-MAXIMUM/S
-MAY
-MAYBE
-MAYHAP
-MAYHEM
-MAYONNAISE
-MAYOR/M/S
-MAYORAL
-MAZE/M/S
-MCDONALD/M
-ME
-MEAD
-MEADOW/M/S
-MEAGER/P/Y
-MEAL/M/S
-MEAN/P/T/R/Y/S
-MEANDER/D/G/S
-MEANING/M/S
-MEANINGFUL/P/Y
-MEANINGLESS/P/Y
-MEANT
-MEANTIME
-MEANWHILE
-MEASLES
-MEASURABLE
-MEASURABLY
-MEASURE/D/R/G/S
-MEASUREMENT/M/S
-MEAT/M/S
-MECHANIC/M/S
-MECHANICAL/Y
-MECHANISM/M/S
-MECHANIZATION/M/S
-MECHANIZE/D/G/S
-MEDAL/M/S
-MEDALLION/M/S
-MEDDLE/D/R/G/S
-MEDIA
-MEDIAN/M/S
-MEDIATE/D/G/N/X/S
-MEDIC/M/S
-MEDICAL/Y
-MEDICINAL/Y
-MEDICINE/M/S
-MEDIEVAL
-MEDIOCRE
-MEDITATE/D/G/N/X/V/S
-MEDIUM/M/S
-MEDUSA
-MEEK/P/T/R/Y
-MEET/G/J/S
-MELANCHOLY
-MELLON/M
-MELLOW/P/D/G/S
-MELODIOUS/P/Y
-MELODRAMA/M/S
-MELODY/M/S
-MELON/M/S
-MELT/D/G/S
-MELTINGLY
-MEMBER/M/S
-MEMBERSHIP/M/S
-MEMBRANE
-MEMO/M/S
-MEMOIR/S
-MEMORABLE/P
-MEMORANDA
-MEMORANDUM
-MEMORIAL/Y/S
-MEMORIZATION
-MEMORIZE/D/R/G/S
-MEMORY/M/S
-MEMORYLESS
-MEN/M/S
-MENACE/D/G
-MENAGERIE
-MEND/D/R/G/S
-MENIAL/S
-MENTAL/Y
-MENTALITY/S
-MENTION/D/R/Z/G/S
-MENTIONABLE
-MENTOR/M/S
-MENU/M/S
-MERCATOR
-MERCENARY/P/M/S
-MERCHANDISE/R/G
-MERCHANT/M/S
-MERCIFUL/Y
-MERCILESS/Y
-MERCURY
-MERCY
-MERE/T/Y
-MERGE/D/R/Z/G/S
-MERIDIAN
-MERIT/D/G/S
-MERITORIOUS/P/Y
-MERRILY
-MERRIMENT
-MERRY/T
-MESH
-MESS/D/G/S
-MESSAGE/M/S
-MESSENGER/M/S
-MESSIAH
-MESSIAHS
-MESSIEURS
-MESSILY
-MESSY/P/T/R
-MET/S
-META
-METACIRCULAR
-METACIRCULARITY
-METACLASS/S
-METAL/M/S
-METALANGUAGE
-METALLIC
-METALLIZATION/S
-METALLURGY
-METAMATHEMATICAL
-METAMORPHOSIS
-METAPHOR/M/S
-METAPHORICAL/Y
-METAPHYSICAL/Y
-METAPHYSICS
-METAVARIABLE
-METE/D/R/Z/G/S
-METEOR/M/S
-METEORIC
-METEOROLOGY
-METERING
-METHOD/M/S
-METHODICAL/P/Y
-METHODIST/M/S
-METHODOLOGICAL/Y
-METHODOLOGISTS
-METHODOLOGY/M/S
-METRIC/M/S
-METRICAL
-METROPOLIS
-METROPOLITAN
-MEW/D/S
-MICA
-MICE
-MICHAEL/M
-MICHIGAN
-MICRO
-MICROBICIDAL
-MICROBICIDE
-MICROBIOLOGY
-MICROCODE/D/G/S
-MICROCOMPUTER/M/S
-MICROECONOMICS
-MICROFILM/M/S
-MICROINSTRUCTION/M/S
-MICROPHONE/G/S
-MICROPROCESSING
-MICROPROCESSOR/M/S
-MICROPROGRAM/M/S
-MICROPROGRAMMED
-MICROPROGRAMMING
-MICROSCOPE/M/S
-MICROSCOPIC
-MICROSECOND/M/S
-MICROSOFT
-MICROSTEP/S
-MICROSTORE
-MICROSTRUCTURE
-MICROSYSTEM/S
-MICROWORD/S
-MID
-MIDDAY
-MIDDLE/G/S
-MIDNIGHT/S
-MIDPOINT/M/S
-MIDST/S
-MIDSUMMER
-MIDWAY
-MIDWEST
-MIDWINTER
-MIEN
-MIGHT
-MIGHTILY
-MIGHTY/P/T/R
-MIGRATE/D/G/N/X/S
-MIKE/M
-MILANO
-MILD/P/T/R/Y
-MILDEW
-MILE/M/S
-MILEAGE
-MILESTONE/M/S
-MILITANT/Y
-MILITARILY
-MILITARISM
-MILITARY
-MILITIA
-MILK/D/R/Z/G/S
-MILKMAID/M/S
-MILKY/P
-MILL/D/R/G/S
-MILLET
-MILLIMETER/S
-MILLION/H/S
-MILLIONAIRE/M/S
-MILLIPEDE/M/S
-MILLISECOND/S
-MILLSTONE/M/S
-MIMIC/S
-MIMICKED
-MIMICKING
-MINCE/D/G/S
-MIND/D/G/S
-MINDFUL/P/Y
-MINDLESS/Y
-MINE/D/R/Z/G/N/S
-MINERAL/M/S
-MINGLE/D/G/S
-MINI
-MINIATURE/M/S
-MINIATURIZATION
-MINIATURIZE/D/G/S
-MINICOMPUTER/M/S
-MINIMA
-MINIMAL/Y
-MINIMIZATION/M/S
-MINIMIZE/D/R/Z/G/S
-MINIMUM
-MINISTER/D/M/G/S
-MINISTRY/M/S
-MINK/M/S
-MINNEAPOLIS
-MINNESOTA/M
-MINNOW/M/S
-MINOR/M/S
-MINORITY/M/S
-MINSKY/M
-MINSTREL/M/S
-MINT/D/R/G/S
-MINUS
-MINUTE/P/R/Y/S
-MIRACLE/M/S
-MIRACULOUS/Y
-MIRAGE
-MIRE/D/S
-MIRROR/D/G/S
-MIRTH
-MISBEHAVING
-MISCALCULATION/M/S
-MISCELLANEOUS/P/Y
-MISCHIEF
-MISCHIEVOUS/P/Y
-MISCONCEPTION/M/S
-MISCONSTRUE/D/S
-MISER/Y/S
-MISERABLE/P
-MISERABLY
-MISERY/M/S
-MISFIT/M/S
-MISFORTUNE/M/S
-MISGIVING/S
-MISHAP/M/S
-MISINTERPRETATION
-MISJUDGMENT
-MISLEAD/G/S
-MISLED
-MISMATCH/D/G/S
-MISNOMER
-MISPLACE/D/G/S
-MISREPRESENTATION/M/S
-MISS/D/G/V/S
-MISSILE/M/S
-MISSION/R/S
-MISSIONARY/M/S
-MISSPELL/D/G/J/S
-MIST/D/R/Z/G/S
-MISTAKABLE
-MISTAKE/G/S
-MISTAKEN/Y
-MISTRESS
-MISTRUST/D
-MISTY/P
-MISTYPE/D/G/S
-MISUNDERSTAND/R/Z/G
-MISUNDERSTANDING/M/S
-MISUNDERSTOOD
-MISUSE/D/G/S
-MIT/R/M
-MITIGATE/D/G/N/V/S
-MITTEN/M/S
-MIX/D/R/Z/G/S
-MIXTURE/M/S
-MNEMONIC/M/S
-MNEMONICALLY
-MOAN/D/S
-MOAT/M/S
-MOB/M/S
-MOCCASIN/M/S
-MOCK/D/R/G/S
-MOCKERY
-MODAL/Y
-MODALITY/M/S
-MODE/T/S
-MODEL/D/G/J/S/M
-MODEM
-MODERATE/P/D/G/N/Y/S
-MODERATOR/M/S
-MODERN/P/Y/S
-MODERNISM
-MODERNITY
-MODERNIZE/D/R/G
-MODESTLY
-MODESTY
-MODIFIABILITY
-MODIFIABLE
-MODIFY/D/R/Z/G/N/X/S
-MODULAR/Y
-MODULARITY
-MODULARIZATION
-MODULARIZE/D/G/S
-MODULATE/D/G/N/X/S
-MODULATOR/M/S
-MODULE/M/S
-MODULO
-MODULUS
-MODUS
-MOHAWK
-MOIST/P/N/Y
-MOISTURE
-MOLASSES
-MOLD/D/R/G/S
-MOLE/T/S
-MOLECULAR
-MOLECULE/M/S
-MOLEST/D/G/S
-MOLTEN
-MOMENT/M/S
-MOMENTARILY
-MOMENTARY/P
-MOMENTOUS/P/Y
-MOMENTUM
-MONARCH
-MONARCHS
-MONARCHY/M/S
-MONASTERY/M/S
-MONASTIC
-MONDAY/M/S
-MONETARY
-MONEY/D/S
-MONITOR/D/G/S
-MONK/M/S
-MONKEY/D/G/S
-MONOCHROME
-MONOGRAM/M/S
-MONOGRAPH/M/S
-MONOGRAPHS
-MONOLITHIC
-MONOPOLY/M/S
-MONOTHEISM
-MONOTONE
-MONOTONIC
-MONOTONICALLY
-MONOTONICITY
-MONOTONOUS/P/Y
-MONOTONY
-MONSTER/M/S
-MONSTROUS/Y
-MONTANA/M
-MONTH/Y
-MONTHS
-MONUMENT/M/S
-MONUMENTAL/Y
-MOOD/M/S
-MOODY/P
-MOON/D/G/S
-MOONLIGHT/R/G
-MOONLIT
-MOONSHINE
-MOOR/D/G/J/S
-MOOSE
-MOOT
-MOP/D/S
-MORAL/Y/S
-MORALE
-MORALITY/S
-MORASS
-MORBID/P/Y
-MORE/S
-MOREOVER
-MORN/G/J
-MORPHISM/S
-MORPHOLOGICAL
-MORPHOLOGY
-MORROW
-MORSEL/M/S
-MORTAL/Y/S
-MORTALITY
-MORTAR/D/G/S
-MORTGAGE/M/S
-MORTIFY/D/G/N/S
-MOSAIC/M/S
-MOSQUITO/S
-MOSQUITOES
-MOSS/M/S
-MOSSY
-MOST/Y
-MOTEL/M/S
-MOTH/Z
-MOTHER'S
-MOTHER/D/R/Z/G/Y/S
-MOTIF/M/S
-MOTION/D/G/S
-MOTIONLESS/P/Y
-MOTIVATE/D/G/N/X/S
-MOTIVATIONAL
-MOTIVE/S
-MOTLEY
-MOTOR/G/S
-MOTORCAR/M/S
-MOTORCYCLE/M/S
-MOTORIST/M/S
-MOTORIZE/D/G/S
-MOTOROLA/M
-MOTTO/S
-MOTTOES
-MOULD/G
-MOUND/D/S
-MOUNT/D/R/G/J/S
-MOUNTAIN/M/S
-MOUNTAINEER/G/S
-MOUNTAINOUS/Y
-MOURN/D/R/Z/G/S
-MOURNFUL/P/Y
-MOUSE/R/S
-MOUTH/D/G
-MOUTHFUL
-MOUTHS
-MOVABLE
-MOVE/D/R/Z/G/J/S
-MOVEMENT/M/S
-MOVIE/M/S
-MOW/D/R/S
-MR
-MRS
-MS
-MUCH
-MUCK/R/G
-MUD
-MUDDLE/D/R/Z/G/S
-MUDDY/P/D
-MUFF/M/S
-MUFFIN/M/S
-MUFFLE/D/R/G/S
-MUG/M/S
-MULBERRY/M/S
-MULE/M/S
-MULTI
-MULTICELLULAR
-MULTIDIMENSIONAL
-MULTILEVEL
-MULTINATIONAL
-MULTIPLE/M/S
-MULTIPLEX/D/G/S
-MULTIPLEXOR/M/S
-MULTIPLICAND/M/S
-MULTIPLICATIVE/S
-MULTIPLICITY
-MULTIPLY/D/R/Z/G/N/X/S
-MULTIPROCESS/G
-MULTIPROCESSOR/M/S
-MULTIPROGRAM
-MULTIPROGRAMMED
-MULTIPROGRAMMING
-MULTIPURPOSE
-MULTISTAGE
-MULTITUDE/M/S
-MULTIVARIATE
-MUMBLE/D/R/Z/G/J/S
-MUMMY/M/S
-MUNCH/D/G
-MUNDANE/Y
-MUNICIPAL/Y
-MUNICIPALITY/M/S
-MUNITION/S
-MURAL
-MURDER/D/R/Z/G/S
-MURDEROUS/Y
-MURKY
-MURMUR/D/R/G/S
-MUSCLE/D/G/S
-MUSCULAR
-MUSE/D/G/J/S
-MUSEUM/M/S
-MUSHROOM/D/G/S
-MUSHY
-MUSIC
-MUSICAL/Y/S
-MUSICIAN/Y/S
-MUSK/S
-MUSKET/M/S
-MUSKRAT/M/S
-MUSLIN
-MUSSEL/M/S
-MUST/R/S
-MUSTACHE/D/S
-MUSTARD
-MUSTY/P
-MUTABILITY
-MUTABLE/P
-MUTATE/D/G/N/X/V/S
-MUTE/P/D/Y
-MUTILATE/D/G/N/S
-MUTINY/M/S
-MUTTER/D/R/Z/G/S
-MUTTON
-MUTUAL/Y
-MUZZLE/M/S
-MY
-MYRIAD
-MYRTLE
-MYSELF
-MYSTERIOUS/P/Y
-MYSTERY/M/S
-MYSTIC/M/S
-MYSTICAL
-MYTH
-MYTHICAL
-MYTHOLOGY/M/S
-NAG/M/S
-NAIL/D/G/S
-NAIVE/P/Y
-NAIVETE
-NAKED/P/Y
-NAME/D/R/Z/G/Y/S
-NAMEABLE
-NAMELESS/Y
-NAMESAKE/M/S
-NANOSECOND/S
-NAP/M/S
-NAPKIN/M/S
-NARCISSUS
-NARCOTIC/S
-NARRATIVE/M/S
-NARROW/P/D/T/R/G/Y/S
-NASAL/Y
-NASTILY
-NASTY/P/T/R
-NATHANIEL/M
-NATION/M/S
-NATIONAL/Y/S
-NATIONALIST/M/S
-NATIONALITY/M/S
-NATIONALIZATION
-NATIONALIZE/D/G/S
-NATIONWIDE
-NATIVE/Y/S
-NATIVITY
-NATURAL/P/Y/S
-NATURALISM
-NATURALIST
-NATURALIZATION
-NATURE/D/M/S
-NAUGHT
-NAUGHTY/P/R
-NAVAL/Y
-NAVIGABLE
-NAVIGATE/D/G/N/S
-NAVIGATOR/M/S
-NAVY/M/S
-NAY
-NAZI/M/S
-NEAR/P/D/T/R/G/Y/S
-NEARBY
-NEAT/P/T/R/Y
-NEBRASKA
-NEBULA
-NECESSARILY
-NECESSARY/S
-NECESSITATE/D/G/N/S
-NECESSITY/S
-NECK/G/S
-NECKLACE/M/S
-NECKTIE/M/S
-NEE
-NEED/D/G/S
-NEEDFUL
-NEEDLE/D/R/Z/G/S
-NEEDLESS/P/Y
-NEEDLEWORK
-NEEDN'T
-NEEDY
-NEGATE/D/G/N/X/V/S
-NEGATIVELY
-NEGATIVES
-NEGATOR/S
-NEGLECT/D/G/S
-NEGLIGENCE
-NEGLIGIBLE
-NEGOTIATE/D/G/N/X/S
-NEGRO
-NEGROES
-NEIGH
-NEIGHBOR/G/Y/S
-NEIGHBORHOOD/M/S
-NEITHER
-NEOPHYTE/S
-NEPAL
-NEPHEW/M/S
-NERVE/M/S
-NERVOUS/P/Y
-NEST/D/R/G/S
-NESTLE/D/G/S
-NET/M/S
-NETHER
-NETHERLANDS
-NETMAIL
-NETNEWS
-NETTED
-NETTING
-NETTLE/D
-NETWORK/D/M/G/S
-NEUMANN/M
-NEURAL
-NEUROLOGICAL
-NEUROLOGISTS
-NEURON/M/S
-NEUROPHYSIOLOGY
-NEUROSCIENCE/S
-NEUTRAL/Y
-NEUTRALITY/S
-NEUTRALIZE/D/G
-NEUTRINO/M/S
-NEVER
-NEVERTHELESS
-NEW/P/T/R/Y/S
-NEWBORN
-NEWCOMER/M/S
-NEWLINE
-NEWSMAN
-NEWSMEN
-NEWSPAPER/M/S
-NEWTONIAN
-NEXT
-NIBBLE/D/R/Z/G/S
-NICE/P/T/R/Y
-NICHE/S
-NICK/D/R/G/S
-NICKEL/M/S
-NICKNAME/D/S
-NIECE/M/S
-NIFTY
-NIGH
-NIGHT/Y/S
-NIGHTFALL
-NIGHTGOWN
-NIGHTINGALE/M/S
-NIGHTMARE/M/S
-NIL
-NIMBLE/P/R
-NIMBLY
-NINE/S
-NINETEEN/H/S
-NINETY/H/S
-NINTH
-NIP/S
-NITROGEN
-NO
-NOBILITY
-NOBLE/P/T/R/S
-NOBLEMAN
-NOBLY
-NOBODY
-NOCTURNAL/Y
-NOD/M/S
-NODDED
-NODDING
-NODE/M/S
-NOISE/S
-NOISELESS/Y
-NOISILY
-NOISY/P/R
-NOMENCLATURE
-NOMINAL/Y
-NOMINATE/D/G/N/V
-NON
-NONBLOCKING
-NONCONSERVATIVE
-NONCYCLIC
-NONDECREASING
-NONDESCRIPT/Y
-NONDESTRUCTIVELY
-NONDETERMINACY
-NONDETERMINATE/Y
-NONDETERMINISM
-NONDETERMINISTIC
-NONDETERMINISTICALLY
-NONE
-NONEMPTY
-NONETHELESS
-NONEXISTENCE
-NONEXISTENT
-NONEXTENSIBLE
-NONFUNCTIONAL
-NONINTERACTING
-NONINTERFERENCE
-NONINTUITIVE
-NONLINEAR/Y
-NONLINEARITY/M/S
-NONLOCAL
-NONNEGATIVE
-NONORTHOGONAL
-NONORTHOGONALITY
-NONPERISHABLE
-NONPROCEDURAL/Y
-NONPROGRAMMABLE
-NONPROGRAMMER
-NONSENSE
-NONSENSICAL
-NONSPECIALIST/M/S
-NONTECHNICAL
-NONTERMINAL/M/S
-NONTERMINATING
-NONTERMINATION
-NONTRIVIAL
-NONUNIFORM
-NONZERO
-NOODLE/S
-NOOK/M/S
-NOON/S
-NOONDAY
-NOONTIDE
-NOR/H
-NORM/M/S
-NORMAL/Y/S
-NORMALCY
-NORMALITY
-NORMALIZATION
-NORMALIZE/D/G/S
-NORTHEAST/R
-NORTHEASTERN
-NORTHERN/R/Z/Y
-NORTHWARD/S
-NORTHWEST
-NORTHWESTERN
-NOSE/D/G/S
-NOSTRIL/M/S
-NOT
-NOTABLE/S
-NOTABLY
-NOTARIZE/D/G/S
-NOTATION/M/S
-NOTATIONAL
-NOTCH/D/G/S
-NOTE/D/G/N/X/S
-NOTEBOOK/M/S
-NOTEWORTHY
-NOTHING/P/S
-NOTICE/D/G/S
-NOTICEABLE
-NOTICEABLY
-NOTIFY/D/R/Z/G/N/X/S
-NOTORIOUS/Y
-NOTWITHSTANDING
-NOUN/M/S
-NOURISH/D/G/S
-NOURISHMENT
-NOVEL/M/S
-NOVELIST/M/S
-NOVELTY/M/S
-NOVEMBER
-NOVICE/M/S
-NOW
-NOWADAYS
-NOWHERE
-NSF
-NUANCES
-NUCLEAR
-NUCLEOTIDE/M/S
-NUCLEUS
-NUISANCE/M/S
-NULL/D/S
-NULLARY
-NULLIFY/D/Z/G/S
-NUMB/P/D/Z/G/Y/S
-NUMBER/D/R/G/S
-NUMBERLESS
-NUMERAL/M/S
-NUMERATOR/M/S
-NUMERIC/S
-NUMERICAL/Y
-NUMEROUS
-NUN/M/S
-NUPTIAL
-NURSE/D/G/S
-NURSERY/M/S
-NURTURE/D/G/S
-NUT/M/S
-NUTRITION
-NYMPH
-NYMPHS
-O'CLOCK
-OAK/N/S
-OAR/M/S
-OASIS
-OAT/N/S
-OATH
-OATHS
-OATMEAL
-OBEDIENCE/S
-OBEDIENT/Y
-OBEY/D/G/S
-OBJECT/D/G/M/S/V
-OBJECTION/M/S
-OBJECTIONABLE
-OBJECTIVELY
-OBJECTIVES
-OBJECTOR/M/S
-OBLIGATION/M/S
-OBLIGATORY
-OBLIGE/D/G/S
-OBLIGINGLY
-OBLIQUE/P/Y
-OBLITERATE/D/G/N/S
-OBLIVION
-OBLIVIOUS/P/Y
-OBLONG
-OBSCENE
-OBSCURE/D/R/G/Y/S
-OBSCURITY/S
-OBSERVABILITY
-OBSERVABLE
-OBSERVANCE/M/S
-OBSERVANT
-OBSERVATION/M/S
-OBSERVATORY
-OBSERVE/D/R/Z/G/S
-OBSESSION/M/S
-OBSOLESCENCE
-OBSOLETE/D/G/S
-OBSTACLE/M/S
-OBSTINACY
-OBSTINATE/Y
-OBSTRUCT/D/G/V
-OBSTRUCTION/M/S
-OBTAIN/D/G/S
-OBTAINABLE
-OBTAINABLY
-OBVIATE/D/G/N/X/S
-OBVIOUS/P/Y
-OCCASION/D/G/J/S
-OCCASIONAL/Y
-OCCLUDE/D/S
-OCCLUSION/M/S
-OCCUPANCY/S
-OCCUPANT/M/S
-OCCUPATION/M/S
-OCCUPATIONAL/Y
-OCCUPY/D/R/G/S
-OCCUR/S
-OCCURRED
-OCCURRENCE/M/S
-OCCURRING
-OCEAN/M/S
-OCTAL
-OCTAVE/S
-OCTOBER
-OCTOPUS
-ODD/P/T/R/Y/S
-ODDITY/M/S
-ODE/M/S
-ODIOUS/P/Y
-ODOR/M/S
-ODOROUS/P/Y
-ODYSSEY
-OEDIPUS
-OF
-OFF/G
-OFFEND/D/R/Z/G/S
-OFFENSE/V/S
-OFFENSIVELY
-OFFENSIVENESS
-OFFER/D/R/Z/G/J/S
-OFFICE/R/Z/S
-OFFICER'S
-OFFICIAL/Y/S
-OFFICIO
-OFFICIOUS/P/Y
-OFFSET/M/S
-OFFSPRING
-OFT/N
-OFTENTIMES
-OH
-OHIO/M
-OIL/D/R/Z/G/S
-OILCLOTH
-OILY/T/R
-OINTMENT
-OK
-OKAY
-OLD/P/T/R/N
-OLIVE/M/S
-OLIVETTI
-OMEN/M/S
-OMINOUS/P/Y
-OMISSION/M/S
-OMIT/S
-OMITTED
-OMITTING
-OMNIPRESENT
-OMNISCIENT/Y
-OMNIVORE
-ON/Y
-ONANISM
-ONBOARD
-ONCE
-ONCOLOGY
-ONE/P/M/N/X/S
-ONEROUS
-ONESELF
-ONGOING
-ONLINE
-ONSET/M/S
-ONTO
-ONWARD/S
-OOZE/D
-OPACITY
-OPAL/M/S
-OPAQUE/P/Y
-OPCODE
-OPEN/P/D/R/Z/Y/S
-OPENING/M/S
-OPERA/M/S
-OPERABLE
-OPERAND/M/S
-OPERANDI
-OPERATE/D/G/N/X/V/S
-OPERATIONAL/Y
-OPERATIVES
-OPERATOR/M/S
-OPINION/M/S
-OPIUM
-OPPONENT/M/S
-OPPORTUNE/Y
-OPPORTUNISM
-OPPORTUNISTIC
-OPPORTUNITY/M/S
-OPPOSE/D/G/S
-OPPOSITE/P/N/Y/S
-OPPRESS/D/G/V/S
-OPPRESSION
-OPPRESSOR/M/S
-OPT/D/G/S
-OPTIC/S
-OPTICAL/Y
-OPTIMAL/Y
-OPTIMALITY
-OPTIMISM
-OPTIMISTIC
-OPTIMISTICALLY
-OPTIMIZATION/M/S
-OPTIMIZE/D/R/Z/G/S
-OPTIMUM
-OPTION/M/S
-OPTIONAL/Y
-OR/M/Y
-ORACLE/M/S
-ORAL/Y
-ORANGE/M/S
-ORATION/M/S
-ORATOR/M/S
-ORATORY/M/S
-ORB
-ORBIT/D/R/Z/G/S
-ORBITAL/Y
-ORCHARD/M/S
-ORCHESTRA/M/S
-ORCHID/M/S
-ORDAIN/D/G/S
-ORDEAL
-ORDER/D/G/Y/J/S
-ORDERLIES
-ORDINAL
-ORDINANCE/M/S
-ORDINARILY
-ORDINARY/P
-ORDINATE/N/S
-ORE/M/S
-ORGAN/M/S
-ORGANIC
-ORGANISM/M/S
-ORGANIST/M/S
-ORGANIZABLE
-ORGANIZATION/M/S
-ORGANIZATIONAL/Y
-ORGANIZE/D/R/Z/G/S
-ORGY/M/S
-ORIENT/D/G/S
-ORIENTAL
-ORIENTATION/M/S
-ORIFICE/M/S
-ORIGIN/M/S
-ORIGINAL/Y/S
-ORIGINALITY
-ORIGINATE/D/G/N/S
-ORIGINATOR/M/S
-ORLEANS
-ORNAMENT/D/G/S
-ORNAMENTAL/Y
-ORNAMENTATION
-ORPHAN/D/S
-ORTHODOX
-ORTHOGONAL/Y
-ORTHOGONALITY
-ORTHOGRAPHIC
-OSAKA
-OSCILLATE/D/G/N/X/S
-OSCILLATION/M/S
-OSCILLATOR/M/S
-OSCILLATORY
-OSCILLOSCOPE/M/S
-OSTRICH/M/S
-OTHER/S
-OTHERWISE
-OTTER/M/S
-OUGHT
-OUNCE/S
-OUR/S
-OURSELF
-OURSELVES
-OUT/R/G/S
-OUTBREAK/M/S
-OUTBURST/M/S
-OUTCAST/M/S
-OUTCOME/M/S
-OUTCRY/S
-OUTDOOR/S
-OUTERMOST
-OUTFIT/M/S
-OUTGOING
-OUTGREW
-OUTGROW/G/H/S
-OUTGROWN
-OUTLAST/S
-OUTLAW/D/G/S
-OUTLAY/M/S
-OUTLET/M/S
-OUTLINE/D/G/S
-OUTLIVE/D/G/S
-OUTLOOK
-OUTPERFORM/D/G/S
-OUTPOST/M/S
-OUTPUT/M/S
-OUTPUTTING
-OUTRAGE/D/S
-OUTRAGEOUS/Y
-OUTRIGHT
-OUTRUN/S
-OUTSET
-OUTSIDE/R
-OUTSIDER/M/S
-OUTSKIRTS
-OUTSTANDING/Y
-OUTSTRETCHED
-OUTSTRIP/S
-OUTSTRIPPED
-OUTSTRIPPING
-OUTVOTE/D/G/S
-OUTWARD/Y
-OUTWEIGH/D/G
-OUTWEIGHS
-OUTWIT/S
-OUTWITTED
-OUTWITTING
-OVAL/M/S
-OVARY/M/S
-OVEN/M/S
-OVER/Y
-OVERALL/M/S
-OVERBOARD
-OVERCAME
-OVERCOAT/M/S
-OVERCOME/G/S
-OVERCROWD/D/G/S
-OVERDONE
-OVERDRAFT/M/S
-OVERDUE
-OVEREMPHASIS
-OVEREMPHASIZED
-OVERESTIMATE/D/G/N/S
-OVERFLOW/D/G/S
-OVERHANG/G/S
-OVERHAUL/G
-OVERHEAD/S
-OVERHEAR/G/S
-OVERHEARD
-OVERJOY/D
-OVERLAND
-OVERLAP/M/S
-OVERLAPPED
-OVERLAPPING
-OVERLAY/G/S
-OVERLOAD/D/G/S
-OVERLOOK/D/G/S
-OVERNIGHT/R/Z
-OVERPOWER/D/G/S
-OVERPRINT/D/G/S
-OVERPRODUCTION
-OVERRIDDEN
-OVERRIDE/G/S
-OVERRODE
-OVERRULE/D/S
-OVERRUN/S
-OVERSEAS
-OVERSEE/R/Z/S
-OVERSEEING
-OVERSHADOW/D/G/S
-OVERSHOOT
-OVERSHOT
-OVERSIGHT/M/S
-OVERSIMPLIFY/D/G/S
-OVERSTATE/D/G/S
-OVERSTATEMENT/M/S
-OVERSTOCKS
-OVERT/Y
-OVERTAKE/R/Z/G/S
-OVERTAKEN
-OVERTHREW
-OVERTHROW
-OVERTHROWN
-OVERTIME
-OVERTONE/M/S
-OVERTOOK
-OVERTURE/M/S
-OVERTURN/D/G/S
-OVERUSE
-OVERVIEW/M/S
-OVERWHELM/D/G/S
-OVERWHELMINGLY
-OVERWORK/D/G/S
-OVERWRITE/G/S
-OVERWRITTEN
-OVERZEALOUS
-OWE/D/G/S
-OWL/M/S
-OWN/D/R/Z/G/S
-OWNERSHIP/S
-OX/N
-OXFORD
-OXIDE/M/S
-OXIDIZE/D
-OXYGEN
-OYSTER/M/S
-PA/H
-PACE/D/R/Z/G/S
-PACHELBEL
-PACIFIC
-PACIFY/R/N/S
-PACK/D/R/Z/G/S
-PACKAGE/D/R/Z/G/J/S
-PACKET/M/S
-PACT/M/S
-PAD/M/S
-PADDED
-PADDING
-PADDLE
-PADDY
-PAGAN/M/S
-PAGE'S
-PAGE/D/R/Z/G/S
-PAGEANT/M/S
-PAGINATE/D/G/N/S
-PAID
-PAIL/M/S
-PAIN/D/S
-PAINFUL/Y
-PAINSTAKING/Y
-PAINT/D/R/Z/G/J/S
-PAIR/D/G/J/S
-PAIRWISE
-PAJAMA/S
-PAL/M/S
-PALACE/M/S
-PALATE/M/S
-PALE/P/D/T/R/G/Y/S
-PALETTE
-PALFREY
-PALL
-PALLIATE/V
-PALLID
-PALM/D/R/G/S
-PALPATION
-PAMPHLET/M/S
-PAN/M/S
-PANACEA/M/S
-PANCAKE/M/S
-PANDEMONIUM
-PANE/M/S
-PANEL/D/G/S
-PANELIST/M/S
-PANG/M/S
-PANIC/M/S
-PANNED
-PANNING
-PANSY/M/S
-PANT/D/G/S
-PANTHER/M/S
-PANTRY/M/S
-PANTY/S
-PAPA
-PAPAL
-PAPER'S
-PAPER/D/R/Z/G/J/S
-PAPERBACK/M/S
-PAPERWORK
-PAPRIKA
-PAR/S
-PARACHUTE/M/S
-PARADE/D/G/S
-PARADIGM/M/S
-PARADISE
-PARADOX/M/S
-PARADOXICAL/Y
-PARAFFIN
-PARAGON/M/S
-PARAGRAPH/G
-PARAGRAPHS
-PARALLEL/D/G/S
-PARALLELISM
-PARALLELIZE/D/G/S
-PARALLELLED
-PARALLELLING
-PARALLELOGRAM/M/S
-PARALYSIS
-PARALYZE/D/G/S
-PARAMETER/M/S
-PARAMETERIZABLE
-PARAMETERIZATION/M/S
-PARAMETERIZE/D/G/S
-PARAMETERLESS
-PARAMETRIC
-PARAMILITARY
-PARAMOUNT
-PARANOIA
-PARANOID
-PARAPET/M/S
-PARAPHRASE/D/G/S
-PARASITE/M/S
-PARASITIC/S
-PARCEL/D/G/S
-PARCH/D
-PARCHMENT
-PARDON/D/R/Z/G/S
-PARDONABLE
-PARDONABLY
-PARE/G/J/S
-PARENT/M/S
-PARENTAGE
-PARENTAL
-PARENTHESES
-PARENTHESIS
-PARENTHESIZED
-PARENTHETICAL/Y
-PARENTHOOD
-PARISH/M/S
-PARITY
-PARK/D/R/Z/G/S
-PARLIAMENT/M/S
-PARLIAMENTARY
-PARLOR/M/S
-PAROLE/D/G/S
-PARROT/G/S
-PARRY/D
-PARSE/D/R/Z/G/J/S
-PARSIMONY
-PARSLEY
-PARSON/M/S
-PART/D/R/Z/G/Y/J/S
-PARTAKE/R/G/S
-PARTIAL/Y
-PARTIALITY
-PARTICIPANT/M/S
-PARTICIPATE/D/G/N/S
-PARTICLE/M/S
-PARTICULAR/Y/S
-PARTISAN/M/S
-PARTITION/D/G/S
-PARTNER/D/S
-PARTNERSHIP
-PARTRIDGE/M/S
-PARTY/M/S
-PASCAL
-PASS
-PASSAGE/M/S
-PASSAGEWAY
-PASSE/D/R/Z/G/N/X/S
-PASSENGER/M/S
-PASSIONATE/Y
-PASSIVE/P/Y
-PASSIVITY
-PASSPORT/M/S
-PASSWORD/M/S
-PAST/P/M/S
-PASTE/D/G/S
-PASTEBOARD
-PASTIME/M/S
-PASTOR/M/S
-PASTORAL
-PASTRY
-PASTURE/M/S
-PAT/S
-PATCH/D/G/S
-PATCHWORK
-PATENT/D/R/Z/G/Y/S
-PATENTABLE
-PATERNAL/Y
-PATHETIC
-PATHOLOGICAL
-PATHOLOGY
-PATHOS
-PATHS
-PATHWAY/M/S
-PATIENCE
-PATIENT/Y/S
-PATRIARCH
-PATRIARCHS
-PATRICIAN/M/S
-PATRIOT/M/S
-PATRIOTIC
-PATRIOTISM
-PATROL/M/S
-PATRON/M/S
-PATRONAGE
-PATRONIZE/D/G/S
-PATTER/D/G/J/S
-PATTERN/D/G/S
-PATTY/M/S
-PAUCITY
-PAUL/M
-PAUSE/D/G/S
-PAVE/D/G/S
-PAVEMENT/M/S
-PAVILION/M/S
-PAW/G/S
-PAWN/M/S
-PAY/G/S
-PAYABLE
-PAYCHECK/M/S
-PAYER/M/S
-PAYMENT/M/S
-PAYOFF/M/S
-PAYROLL
-PC
-PDP
-PEA/M/S
-PEACE
-PEACEABLE
-PEACEFUL/P/Y
-PEACH/M/S
-PEACOCK/M/S
-PEAK/D/S
-PEAL/D/G/S
-PEANUT/M/S
-PEAR/Y/S
-PEARL/M/S
-PEASANT/M/S
-PEASANTRY
-PEAT
-PEBBLE/M/S
-PECK/D/G/S
-PECULIAR/Y
-PECULIARITY/M/S
-PEDAGOGIC
-PEDAGOGICAL
-PEDANTIC
-PEDDLER/M/S
-PEDESTAL
-PEDESTRIAN/M/S
-PEDIATRIC/S
-PEEK/D/G/S
-PEEL/D/G/S
-PEEP/D/R/G/S
-PEER/D/G/S
-PEERLESS
-PEG/M/S
-PELT/G/S
-PEN
-PENALIZE/D/G/S
-PENALTY/M/S
-PENANCE
-PENCE
-PENCIL/D/S
-PEND/D/G/S
-PENDULUM/M/S
-PENETRATE/D/G/N/X/V/S
-PENETRATINGLY
-PENETRATOR/M/S
-PENGUIN/M/S
-PENINSULA/M/S
-PENITENT
-PENITENTIARY
-PENNED
-PENNILESS
-PENNING
-PENNSYLVANIA
-PENNY/M/S
-PENS/V
-PENSION/R/S
-PENT
-PENTAGON/M/S
-PEOPLE/D/M/S
-PEP
-PEPPER/D/G/S
-PER
-PERCEIVABLE
-PERCEIVABLY
-PERCEIVE/D/R/Z/G/S
-PERCENT/S
-PERCENTAGE/S
-PERCENTILE/S
-PERCEPTIBLE
-PERCEPTIBLY
-PERCEPTION/S
-PERCEPTIVE/Y
-PERCEPTRON/S
-PERCEPTUAL/Y
-PERCH/D/G/S
-PERCHANCE
-PERCUSSION
-PERCUTANEOUS
-PEREMPTORY
-PERENNIAL/Y
-PERFECT/P/D/G/Y/S
-PERFECTION
-PERFECTIONIST/M/S
-PERFORCE
-PERFORM/D/R/Z/G/S
-PERFORMANCE/M/S
-PERFUME/D/G/S
-PERHAPS
-PERIL/M/S
-PERILOUS/Y
-PERIMETER/S
-PERIOD/M/S
-PERIODIC
-PERIODICAL/Y/S
-PERIPHERAL/Y/S
-PERIPHERY/M/S
-PERISH/D/R/Z/G/S
-PERISHABLE/M/S
-PERMANENCE
-PERMANENT/Y
-PERMEATE/D/G/N/S
-PERMISSIBILITY
-PERMISSIBLE
-PERMISSIBLY
-PERMISSION/S
-PERMISSIVE/Y
-PERMIT/M/S
-PERMITTED
-PERMITTING
-PERMUTATION/M/S
-PERMUTE/D/G/S
-PERPENDICULAR/Y/S
-PERPETRATE/D/G/N/X/S
-PERPETRATOR/M/S
-PERPETUAL/Y
-PERPETUATE/D/G/N/S
-PERPLEX/D/G
-PERPLEXITY
-PERSECUTE/D/G/N/S
-PERSECUTOR/M/S
-PERSEVERANCE
-PERSEVERE/D/G/S
-PERSIST/D/G/S
-PERSISTENCE
-PERSISTENT/Y
-PERSON/M/S
-PERSONAGE/M/S
-PERSONAL/Y
-PERSONALITY/M/S
-PERSONALIZATION
-PERSONALIZE/D/G/S
-PERSONIFY/D/G/N/S
-PERSONNEL
-PERSPECTIVE/M/S
-PERSPICUOUS/Y
-PERSPIRATION
-PERSUADABLE
-PERSUADE/D/R/Z/G/S
-PERSUASION/M/S
-PERSUASIVE/P/Y
-PERTAIN/D/G/S
-PERTINENT
-PERTURB/D
-PERTURBATION/M/S
-PERUSAL
-PERUSE/D/R/Z/G/S
-PERVADE/D/G/S
-PERVASIVE/Y
-PERVERT/D/S
-PESSIMISTIC
-PEST/R/S
-PESTILENCE
-PET/R/Z/S
-PETAL/M/S
-PETITION/D/R/G/S
-PETROLEUM
-PETTED
-PETTER/M/S
-PETTICOAT/M/S
-PETTING
-PETTY/P
-PEW/M/S
-PEWTER
-PHANTOM/M/S
-PHASE/D/R/Z/G/S
-PHEASANT/M/S
-PHENOMENA
-PHENOMENAL/Y
-PHENOMENOLOGICAL/Y
-PHENOMENOLOGY/S
-PHENOMENON
-PHILADELPHIA
-PHILOSOPHER/M/S
-PHILOSOPHIC
-PHILOSOPHICAL/Y
-PHILOSOPHIZE/D/R/Z/G/S
-PHILOSOPHY/M/S
-PHONE/D/G/S
-PHONEME/M/S
-PHONEMIC
-PHONETIC/S
-PHONOGRAPH
-PHONOGRAPHS
-PHOSPHATE/M/S
-PHOSPHORIC
-PHOTO/M/S
-PHOTOCOPY/D/G/S
-PHOTOGRAPH/D/R/Z/G
-PHOTOGRAPHIC
-PHOTOGRAPHS
-PHOTOGRAPHY
-PHOTOTYPESETTER/S
-PHRASE/D/G/J/S
-PHYLA
-PHYLUM
-PHYSIC/S
-PHYSICAL/P/Y/S
-PHYSICIAN/M/S
-PHYSICIST/M/S
-PHYSIOLOGICAL/Y
-PHYSIOLOGY
-PHYSIQUE
-PI
-PIANO/M/S
-PIAZZA/M/S
-PICAYUNE
-PICK/D/R/Z/G/J/S
-PICKET/D/R/Z/G/S
-PICKLE/D/G/S
-PICKUP/M/S
-PICKY
-PICNIC/M/S
-PICTORIAL/Y
-PICTURE/D/G/S
-PICTURESQUE/P
-PIE/R/Z/S
-PIECE/D/G/S
-PIECEMEAL
-PIECEWISE
-PIERCE/D/G/S
-PIETY
-PIG/M/S
-PIGEON/M/S
-PIGMENT/D/S
-PIKE/R/S
-PILE/D/Z/G/J/S
-PILFERAGE
-PILGRIM/M/S
-PILGRIMAGE/M/S
-PILL/M/S
-PILLAGE/D
-PILLAR/D/S
-PILLOW/M/S
-PILOT/G/S
-PIN/M/S
-PINCH/D/G/S
-PINE/D/G/N/S
-PINEAPPLE/M/S
-PING
-PINK/P/T/R/Y/S
-PINNACLE/M/S
-PINNED
-PINNING/S
-PINPOINT/G/S
-PINT/M/S
-PIONEER/D/G/S
-PIOUS/Y
-PIPE/D/R/Z/G/S
-PIPELINE/D/G/S
-PIQUE
-PIRATE/M/S
-PISTIL/M/S
-PISTOL/M/S
-PISTON/M/S
-PIT/M/S
-PITCH/D/R/Z/G/S
-PITEOUS/Y
-PITFALL/M/S
-PITH/D/G/S
-PITHY/P/T/R
-PITIABLE
-PITIFUL/Y
-PITILESS/Y
-PITTED
-PITTSBURGH/M
-PITY/D/R/Z/G/S
-PITYINGLY
-PIVOT/G/S
-PIVOTAL
-PIXEL/S
-PLACARD/M/S
-PLACE/D/R/G/S
-PLACEMENT/M/S
-PLACID/Y
-PLAGUE/D/G/S
-PLAID/M/S
-PLAIN/P/T/R/Y/S
-PLAINTIFF/M/S
-PLAINTIVE/P/Y
-PLAIT/M/S
-PLAN/M/S
-PLANAR
-PLANARITY
-PLANE'S
-PLANE/D/R/Z/G/S
-PLANET/M/S
-PLANETARY
-PLANK/G/S
-PLANNED
-PLANNER/M/S
-PLANNING
-PLANT/D/R/Z/G/J/S
-PLANTATION/M/S
-PLASMA
-PLASTER/D/R/G/S
-PLASTIC/S
-PLASTICITY
-PLATE/D/G/S
-PLATEAU/M/S
-PLATELET/M/S
-PLATEN/M/S
-PLATFORM/M/S
-PLATINUM
-PLATO
-PLATTER/M/S
-PLAUSIBILITY
-PLAUSIBLE
-PLAY/D/G/S
-PLAYABLE
-PLAYER/M/S
-PLAYFUL/P/Y
-PLAYGROUND/M/S
-PLAYMATE/M/S
-PLAYTHING/M/S
-PLAYWRIGHT/M/S
-PLAZA
-PLEA/M/S
-PLEAD/D/R/G/S
-PLEASANT/P/Y
-PLEASE/D/G/S
-PLEASINGLY
-PLEASURE/S
-PLEBEIAN
-PLEBISCITE/M/S
-PLEDGE/D/S
-PLENARY
-PLENTEOUS
-PLENTIFUL/Y
-PLENTY
-PLEURISY
-PLIGHT
-PLOD
-PLOT/M/S
-PLOTTED
-PLOTTER/M/S
-PLOTTING
-PLOUGH
-PLOUGHMAN
-PLOW/D/R/G/S
-PLOWMAN
-PLOY/M/S
-PLUCK/D/G
-PLUCKY
-PLUG/M/S
-PLUGGED
-PLUGGING
-PLUM/M/S
-PLUMAGE
-PLUMB/D/M/G/S
-PLUME/D/S
-PLUMMETING
-PLUMP/P/D
-PLUNDER/D/R/Z/G/S
-PLUNGE/D/R/Z/G/S
-PLURAL/S
-PLURALITY
-PLUS
-PLUSH
-PLY/D/Z/S
-PNEUMONIA
-POACH/R/S
-POCKET/D/G/S
-POCKETBOOK/M/S
-POD/M/S
-POEM/M/S
-POET/M/S
-POETIC/S
-POETICAL/Y
-POETRY/M/S
-POINT/D/R/Z/G/S
-POINTEDLY
-POINTLESS
-POINTY
-POISE/D/S
-POISON/D/R/G/S
-POISONOUS/P
-POKE/D/R/G/S
-POLAND
-POLAR
-POLARITY/M/S
-POLE/D/G/S
-POLEMIC/S
-POLICE/D/M/G/S
-POLICEMAN
-POLICEMEN
-POLICY/M/S
-POLISH/D/R/Z/G/S
-POLITE/P/T/R/Y
-POLITIC/S
-POLITICAL/Y
-POLITICIAN/M/S
-POLL/D/G/N/S
-POLLUTANT/S
-POLLUTE/D/G/N/S
-POLO
-POLYGON/S
-POLYGONAL
-POLYHEDRA
-POLYHEDRON
-POLYLINE
-POLYMER/M/S
-POLYMORPHIC
-POLYMORPHISM
-POLYNOMIAL/M/S
-POLYTECHNIC
-POMP
-POMPOUS/P/Y
-POND/R/S
-PONDER/D/G/S
-PONDEROUS
-PONY/M/S
-POOL/D/G/S
-POOR/P/T/R/Y
-POP/M/S
-POPLAR
-POPPED
-POPPING
-POPPY/M/S
-POPULACE
-POPULAR/Y
-POPULARITY
-POPULARIZATION
-POPULARIZE/D/G/S
-POPULATE/D/G/N/X/S
-POPULOUS/P
-PORCELAIN
-PORCH/M/S
-PORCUPINE/M/S
-PORE/D/G/S
-PORK/R
-PORNOGRAPHIC
-PORRIDGE
-PORT/R/Z/Y/S/D/G
-PORTABILITY
-PORTABLE
-PORTAL/M/S
-PORTEND/D/G/S
-PORTION/M/S
-PORTRAIT/M/S
-PORTRAY/D/G/S
-PORTUGUESE
-POSE/D/R/Z/G/S
-POSIT/D/G/S
-POSITION/D/G/S
-POSITIONAL
-POSITIVE/P/Y/S
-POSSESS/D/G/V/S
-POSSESSION/M/S
-POSSESSIONAL
-POSSESSIVE/P/Y
-POSSESSOR/M/S
-POSSIBILITY/M/S
-POSSIBLE
-POSSIBLY
-POSSUM/M/S
-POST/D/R/Z/G/S
-POSTAGE
-POSTAL
-POSTCONDITION
-POSTDOCTORAL
-POSTERIOR
-POSTERITY
-POSTMAN
-POSTMASTER/M/S
-POSTMODERNISM
-POSTOFFICE/M/S
-POSTPONE/D/G
-POSTSCRIPT/M/S
-POSTSTRUCTURALISM
-POSTSTRUCTURALIST
-POSTULATE/D/G/N/X/S
-POSTURE/M/S
-POT/M/S
-POTASH
-POTASSIUM
-POTATO
-POTATOES
-POTENT
-POTENTATE/M/S
-POTENTIAL/Y/S
-POTENTIALITY/S
-POTENTIATING
-POTENTIOMETER/M/S
-POTTED
-POTTER/M/S
-POTTERY
-POTTING
-POUCH/M/S
-POUGHKEEPSIE
-POULTRY
-POUNCE/D/G/S
-POUND/D/R/Z/G/S
-POUR/D/R/Z/G/S
-POUT/D/G/S
-POVERTY
-POWDER/D/G/S
-POWER/D/G/S
-POWERFUL/P/Y
-POWERLESS/P/Y
-POWERSET/M/S
-POX
-PRACTICABLE
-PRACTICABLY
-PRACTICAL/Y
-PRACTICALITY
-PRACTICE/D/G/S
-PRACTISE/D/G
-PRACTITIONER/M/S
-PRAGMATIC/S
-PRAGMATICALLY
-PRAIRIE
-PRAISE/D/R/Z/G/S
-PRAISINGLY
-PRANCE/D/R/G
-PRANK/M/S
-PRATE
-PRAY/D/G
-PRAYER/M/S
-PRE
-PREACH/D/R/Z/G/S
-PREAMBLE
-PREASSIGN/D/G/S
-PRECARIOUS/P/Y
-PRECAUTION/M/S
-PRECEDE/D/G/S
-PRECEDENCE/M/S
-PRECEDENT/D/S
-PRECEPT/M/S
-PRECINCT/M/S
-PRECIOUS/P/Y
-PRECIPICE
-PRECIPITATE/P/D/G/N/Y/S
-PRECIPITOUS/Y
-PRECISE/P/N/X/Y
-PRECLUDE/D/G/S
-PRECOCIOUS/Y
-PRECONCEIVE/D
-PRECONCEPTION/M/S
-PRECONDITION/D/S
-PRECURSOR/M/S
-PREDATE/D/G/S
-PREDECESSOR/M/S
-PREDEFINE/D/G/S
-PREDEFINITION/M/S
-PREDETERMINE/D/G/S
-PREDICAMENT
-PREDICATE/D/G/N/X/S
-PREDICT/D/G/V/S
-PREDICTABILITY
-PREDICTABLE
-PREDICTABLY
-PREDICTION/M/S
-PREDISPOSE/D/G
-PREDOMINANT/Y
-PREDOMINATE/D/G/N/Y/S
-PREEMPT/D/G/V/S
-PREEMPTION
-PREFACE/D/G/S
-PREFER/S
-PREFERABLE
-PREFERABLY
-PREFERENCE/M/S
-PREFERENTIAL/Y
-PREFERRED
-PREFERRING
-PREFIX/D/S
-PREGNANT
-PREHISTORIC
-PREINITIALIZE/D/G/S
-PREJUDGE/D
-PREJUDICE/D/S
-PRELATE
-PRELIMINARY/S
-PRELUDE/M/S
-PREMATURE/Y
-PREMATURITY
-PREMEDITATED
-PREMIER/M/S
-PREMISE/M/S
-PREMIUM/M/S
-PREOCCUPATION
-PREOCCUPY/D/S
-PREPARATION/M/S
-PREPARATIVE/M/S
-PREPARATORY
-PREPARE/D/G/S
-PREPOSITION/M/S
-PREPOSITIONAL
-PREPOSTEROUS/Y
-PREPROCESS/D/G
-PREPRODUCTION
-PREPROGRAMMED
-PREREQUISITE/M/S
-PREROGATIVE/M/S
-PRESBYTERIAN
-PRESCRIBE/D/S
-PRESCRIPTION/M/S
-PRESCRIPTIVE
-PRESELECT/D/G/S
-PRESENCE/M/S
-PRESENT/P/D/R/G/Y/S
-PRESENTATION/M/S
-PRESERVATION/S
-PRESERVE/D/R/Z/G/S
-PRESET
-PRESIDE/D/G/S
-PRESIDENCY
-PRESIDENT/M/S
-PRESIDENTIAL
-PRESS/D/R/G/J/S
-PRESSURE/D/G/S
-PRESSURIZE/D
-PRESTIGE
-PRESTO
-PRESUMABLY
-PRESUME/D/G/S
-PRESUMPTION/M/S
-PRESUMPTUOUS/P
-PRESUPPOSE/D/G/S
-PRESYNAPTIC
-PRETEND/D/R/Z/G/S
-PRETENSE/N/X/S
-PRETENTIOUS/P/Y
-PRETEXT/M/S
-PRETTILY
-PRETTY/P/T/R
-PREVAIL/D/G/S
-PREVAILINGLY
-PREVALENCE
-PREVALENT/Y
-PREVENT/D/G/V/S
-PREVENTABLE
-PREVENTABLY
-PREVENTION
-PREVENTIVES
-PREVIEW/D/G/S
-PREVIOUS/Y
-PREY/D/G/S
-PRICE/D/R/Z/G/S
-PRICELESS
-PRICK/D/G/Y/S
-PRIDE/D/G/S
-PRIMACY
-PRIMARILY
-PRIMARY/M/S
-PRIME/P/D/R/Z/G/S
-PRIMEVAL
-PRIMITIVE/P/Y/S
-PRIMROSE
-PRINCE/Y/S
-PRINCESS/M/S
-PRINCETON
-PRINCIPAL/Y/S
-PRINCIPALITY/M/S
-PRINCIPLE/D/S
-PRINT/D/R/Z/G/S
-PRINTABLE
-PRINTABLY
-PRINTOUT
-PRIOR
-PRIORI
-PRIORITY/M/S
-PRIORY
-PRISM/M/S
-PRISON/R/Z/S
-PRISONER'S
-PRIVACY/S
-PRIVATE/N/X/Y/S
-PRIVILEGE/D/S
-PRIVY/M/S
-PRIZE/D/R/Z/G/S
-PRO/M/S
-PROBABILISTIC
-PROBABILISTICALLY
-PROBABILITY/S
-PROBABLE
-PROBABLY
-PROBATE/D/G/N/V/S
-PROBE/D/G/J/S
-PROBLEM/M/S
-PROBLEMATIC
-PROBLEMATICAL/Y
-PROCEDURAL/Y
-PROCEDURE/M/S
-PROCEED/D/G/J/S
-PROCESS/D/M/G/S
-PROCESSION
-PROCESSOR/M/S
-PROCLAIM/D/R/Z/G/S
-PROCLAMATION/M/S
-PROCLIVITY/M/S
-PROCRASTINATE/D/G/N/S
-PROCURE/D/R/Z/G/S
-PROCUREMENT/M/S
-PRODIGAL/Y
-PRODIGIOUS
-PRODIGY
-PRODUCE/D/R/Z/G/S
-PRODUCIBLE
-PRODUCT/M/V/S
-PRODUCTION/M/S
-PRODUCTIVELY
-PRODUCTIVITY
-PROFANE/Y
-PROFESS/D/G/S
-PROFESSION/M/S
-PROFESSIONAL/Y/S
-PROFESSIONALISM
-PROFESSOR/M/S
-PROFFER/D/S
-PROFICIENCY
-PROFICIENT/Y
-PROFILE/D/G/S
-PROFIT/D/G/S/R/M/Z
-PROFITABILITY
-PROFITABLE
-PROFITABLY
-PROFITEER/M/S
-PROFOUND/T/Y
-PROG
-PROGENY
-PROGRAM/M/S
-PROGRAMMABILITY
-PROGRAMMABLE
-PROGRAMMED
-PROGRAMMER/M/S
-PROGRAMMING
-PROGRESS/D/G/V/S
-PROGRESSION/M/S
-PROGRESSIVE/Y
-PROHIBIT/D/G/V/S
-PROHIBITION/M/S
-PROHIBITIVELY
-PROJECT/D/G/V/S/M
-PROJECTION/M/S
-PROJECTIVELY
-PROJECTOR/M/S
-PROLEGOMENA
-PROLETARIAT
-PROLIFERATE/D/G/N/S
-PROLIFIC
-PROLOG
-PROLOGUE
-PROLONG/D/G/S
-PROMENADE/M/S
-PROMINENCE
-PROMINENT/Y
-PROMISE/D/G/S
-PROMONTORY
-PROMOTE/D/R/Z/G/N/X/S
-PROMOTIONAL
-PROMPT/P/D/T/R/Y/S
-PROMPTING/S
-PROMULGATE/D/G/N/S
-PRONE/P
-PRONG/D/S
-PRONOUN/M/S
-PRONOUNCE/D/G/S
-PRONOUNCEABLE
-PRONOUNCEMENT/M/S
-PRONUNCIATION/M/S
-PROOF/M/S
-PROP/R/S
-PROPAGANDA
-PROPAGATE/D/G/N/X/S
-PROPEL/S
-PROPELLED
-PROPELLER/M/S
-PROPENSITY
-PROPERLY
-PROPERNESS
-PROPERTY/D/S
-PROPHECY/M/S
-PROPHESY/D/R/S
-PROPHET/M/S
-PROPHETIC
-PROPITIOUS
-PROPONENT/M/S
-PROPORTION/D/G/S
-PROPORTIONAL/Y
-PROPORTIONATELY
-PROPORTIONMENT
-PROPOSAL/M/S
-PROPOSE/D/R/G/S
-PROPOSITION/D/G/S
-PROPOSITIONAL/Y
-PROPOUND/D/G/S
-PROPRIETARY
-PROPRIETOR/M/S
-PROPRIETY
-PROPULSION/M/S
-PROSE
-PROSECUTE/D/G/N/X/S
-PROSELYTIZE/D/G/S
-PROSODIC/S
-PROSPECT/D/G/V/S
-PROSPECTION/M/S
-PROSPECTIVELY
-PROSPECTIVES
-PROSPECTOR/M/S
-PROSPECTUS
-PROSPER/D/G/S
-PROSPERITY
-PROSPEROUS
-PROSTITUTION
-PROSTRATE/N
-PROTECT/D/G/V/S
-PROTECTION/M/S
-PROTECTIVELY
-PROTECTIVENESS
-PROTECTOR/M/S
-PROTECTORATE
-PROTEGE/M/S
-PROTEIN/M/S
-PROTEST/D/G/S/R/Z/M
-PROTESTATION/S
-PROTESTER'S
-PROTESTINGLY
-PROTESTOR/M/S
-PROTOCOL/M/S
-PROTON/M/S
-PROTOPLASM
-PROTOTYPE/D/G/S
-PROTOTYPICAL/Y
-PROTRUDE/D/G/S
-PROTRUSION/M/S
-PROVABILITY
-PROVABLE
-PROVABLY
-PROVE/D/R/Z/G/S
-PROVEN
-PROVERB/M/S
-PROVIDE/D/R/Z/G/S
-PROVIDENCE
-PROVINCE/M/S
-PROVINCIAL
-PROVINCIALISM
-PROVISION/D/G/S
-PROVISIONAL/Y
-PROVOCATION
-PROVOKE/D/S
-PROW/M/S
-PROWESS
-PROWL/D/R/Z/G
-PROXIMAL
-PROXIMATE
-PROXIMITY
-PRUDENCE
-PRUDENT/Y
-PRUNE/D/R/Z/G/S
-PRY/T/G
-PSALM/M/S
-PSEUDO
-PSYCHE/M/S
-PSYCHIATRIST/M/S
-PSYCHIATRY
-PSYCHOLOGICAL/Y
-PSYCHOLOGIST/M/S
-PSYCHOLOGY
-PSYCHOMETRIC
-PSYCHOSOCIAL
-PUB/M/S
-PUBLIC/Y
-PUBLICATION/M/S
-PUBLICITY
-PUBLICIZE/D/G/S
-PUBLISH/D/R/Z/G/S
-PUCKER/D/G/S
-PUDDING/M/S
-PUDDLE/G/S
-PUFF/D/G/S
-PULL/D/R/G/J/S
-PULLEY/M/S
-PULMONARY
-PULP/G
-PULPIT/M/S
-PULSE/D/G/S
-PUMP/D/G/S
-PUMPKIN/M/S
-PUN/M/S
-PUNCH/D/R/G/S
-PUNCTUAL/Y
-PUNCTUATION
-PUNCTURE/D/M/G/S
-PUNISH/D/G/S
-PUNISHABLE
-PUNISHMENT/M/S
-PUNITIVE
-PUNT/D/G/S
-PUNY
-PUP/M/S
-PUPA
-PUPIL/M/S
-PUPPET/M/S
-PUPPY/M/S
-PURCHASABLE
-PURCHASE/D/R/Z/G/S
-PURCHASEABLE
-PURE/T/R/Y
-PURGE/D/G/S
-PURIFY/D/R/Z/G/N/X/S
-PURITY
-PURPLE/T/R
-PURPORT/D/R/Z/G/S
-PURPORTEDLY
-PURPOSE/D/V/Y/S
-PURPOSEFUL/Y
-PURR/D/G/S
-PURSE/D/R/S
-PURSUE/D/R/Z/G/S
-PURSUIT/M/S
-PURVIEW
-PUSHDOWN
-PUSS
-PUSSY
-PUT/S
-PUTRID
-PUTTER/G/S
-PUTTING
-PUZZLE/D/R/Z/G/J/S
-PUZZLEMENT
-PYGMY/M/S
-PYRAMID/M/S
-QUACK/D/S
-QUADRANT/M/S
-QUADRATIC/S
-QUADRATICAL/Y
-QUADRATURE/M/S
-QUADRUPLE/D/G/S
-QUAGMIRE/M/S
-QUAIL/M/S
-QUAINT/P/Y
-QUAKE/D/R/Z/G/S
-QUALIFY/D/R/Z/G/N/X/S
-QUALITATIVE/Y
-QUALITY/M/S
-QUANDARY/M/S
-QUANTA
-QUANTIFIABLE
-QUANTIFY/D/R/Z/G/N/X/S
-QUANTITATIVE/Y
-QUANTITY/M/S
-QUANTIZATION
-QUANTIZE/D/G/S
-QUANTUM
-QUARANTINE/M/S
-QUARREL/D/G/S
-QUARRELSOME
-QUARRY/M/S
-QUART/Z/S
-QUARTER/D/G/Y/S
-QUARTET/M/S
-QUARTZ
-QUASH/D/G/S
-QUASI
-QUAVER/D/G/S
-QUAY
-QUEEN/M/Y/S
-QUEER/P/T/R/Y
-QUELL/G
-QUENCH/D/G/S
-QUERY/D/G/S
-QUEST/D/R/Z/G/S
-QUESTION/D/R/Z/G/J/S
-QUESTIONABLE
-QUESTIONABLY
-QUESTIONINGLY
-QUESTIONNAIRE/M/S
-QUEUE/D/R/Z/G/S
-QUICK/P/T/R/N/X/Y
-QUICKENED
-QUICKENING
-QUICKSILVER
-QUIESCENT
-QUIET/P/D/T/R/G/Y/S
-QUIETUDE
-QUILL
-QUILT/D/G/S
-QUININE
-QUIT/S
-QUITE
-QUITTER/M/S
-QUITTING
-QUIVER/D/G/S
-QUIXOTE
-QUIZ
-QUIZZED
-QUIZZES
-QUIZZING
-QUO/H
-QUOTA/M/S
-QUOTATION/M/S
-QUOTE/D/G/S
-QUOTIENT
-RABBIT/M/S
-RABBLE
-RACCOON/M/S
-RACE/D/R/Z/G/S
-RACIAL/Y
-RACK/D/G/S
-RACKET/M/S
-RACKETEER/G/S
-RADAR/M/S
-RADIAL/Y
-RADIAN/S
-RADIANCE
-RADIANT/Y
-RADIATE/D/G/N/X/S
-RADIATOR/M/S
-RADICAL/Y/S
-RADII
-RADIO/D/G/S
-RADIOLOGY
-RADISH/M/S
-RADIUS
-RADIX
-RAFT/R/Z/S
-RAG/M/S
-RAGE/D/G/S
-RAGGED/P/Y
-RAID/D/R/Z/G/S
-RAIL/D/R/Z/G/S
-RAILROAD/D/R/Z/G/S
-RAILWAY/M/S
-RAIMENT
-RAIN/D/G/S
-RAINBOW
-RAINCOAT/M/S
-RAINDROP/M/S
-RAINFALL
-RAINY/T/R
-RAISE/D/R/Z/G/S
-RAISIN
-RAKE/D/G/S
-RALLY/D/G/S
-RAM/M/S
-RAMBLE/R/G/J/S
-RAMIFICATION/M/S
-RAMP/M/S
-RAMPART
-RAN
-RANCH/D/R/Z/G/S
-RANDOLPH/M
-RANDOM/P/Y
-RANDY/M
-RANG
-RANGE/D/R/Z/G/S
-RANK/P/D/T/Y/S
-RANKER/M/S
-RANKING/M/S
-RANSACK/D/G/S
-RANSOM/R/G/S
-RANT/D/R/Z/G/S
-RAP/M/S
-RAPE/D/R/G/S
-RAPID/Y/S
-RAPIDITY
-RAPT/Y
-RAPTURE/M/S
-RAPTUROUS
-RARE/P/T/R/Y
-RARITY/M/S
-RASCAL/Y/S
-RASH/P/R/Y
-RASP/D/G/S
-RASPBERRY
-RASTER
-RASTEROP
-RAT/M/S
-RATE/D/R/Z/G/N/X/J/S
-RATHER
-RATIFY/D/G/N/S
-RATIO/M/S
-RATIONAL/Y
-RATIONALE/M/S
-RATIONALITY/S
-RATIONALIZE/D/G/S
-RATTLE/D/R/Z/G/S
-RATTLESNAKE/M/S
-RAVAGE/D/R/Z/G/S
-RAVE/D/G/J/S
-RAVEN/G/S
-RAVENOUS/Y
-RAVINE/M/S
-RAW/P/T/R/Y
-RAY/M/S
-RAZOR/M/S
-RE/D/Y/J
-REABBREVIATE/D/G/S
-REACH/D/R/G/S
-REACHABLE
-REACHABLY
-REACT/D/G/V/S
-REACTION/M/S
-REACTIONARY/M/S
-REACTIVATE/D/G/N/S
-REACTIVELY
-REACTIVITY
-REACTOR/M/S
-READ/R/Z/G/J/S
-READABILITY
-READABLE
-READILY
-READJUSTED
-READJUSTMENT
-READOUT/M/S
-READY/P/D/T/R/G/S
-REAL/P/S/T/Y
-REALIGN/D/G/S
-REALISM
-REALIST/M/S
-REALISTIC
-REALISTICALLY
-REALITY/S
-REALIZABLE
-REALIZABLY
-REALIZATION/M/S
-REALIZE/D/G/S
-REALM/M/S
-REANALYZE/G/S
-REAP/D/R/G/S
-REAPPEAR/D/G/S
-REAPPRAISAL/S
-REAR/D/G/S
-REARRANGE/D/G/S
-REARRANGEABLE
-REARRANGEMENT/M/S
-REARREST/D
-REASON/D/R/G/J/S
-REASONABLE/P
-REASONABLY
-REASSEMBLE/D/G/S
-REASSESSMENT/M/S
-REASSIGN/D/G/S
-REASSIGNMENT/M/S
-REASSURE/D/G/S
-REAWAKEN/D/G/S
-REBATE/M/S
-REBEL/M/S
-REBELLION/M/S
-REBELLIOUS/P/Y
-REBOUND/D/G/S
-REBROADCAST
-REBUFF/D
-REBUILD/G/S
-REBUILT
-REBUKE/D/G/S
-REBUTTAL
-RECALCULATE/D/G/N/X/S
-RECALL/D/G/S
-RECAPITULATE/D/N/S
-RECAPTURE/D/G/S
-RECAST/G/S
-RECEDE/D/G/S
-RECEIPT/M/S
-RECEIVABLE
-RECEIVE/D/R/Z/G/S
-RECENT/P/Y
-RECEPTACLE/M/S
-RECEPTION/M/S
-RECEPTIVE/P/Y
-RECEPTIVITY
-RECESS/D/V/S
-RECESSION
-RECIPE/M/S
-RECIPIENT/M/S
-RECIPROCAL/Y
-RECIPROCATE/D/G/N/S
-RECIPROCITY
-RECIRCULATE/D/G/S
-RECITAL/M/S
-RECITATION/M/S
-RECITE/D/R/G/S
-RECKLESS/P/Y
-RECKON/D/R/G/J/S
-RECLAIM/D/R/Z/G/S
-RECLAIMABLE
-RECLAMATION/S
-RECLASSIFY/D/G/N/S
-RECLINE/G
-RECODE/D/G/S
-RECOGNITION/M/S
-RECOGNIZABILITY
-RECOGNIZABLE
-RECOGNIZABLY
-RECOGNIZE/D/R/Z/G/S
-RECOIL/D/G/S
-RECOLLECT/D/G
-RECOLLECTION/M/S
-RECOMBINE/D/G/S
-RECOMMEND/D/R/G/S
-RECOMMENDATION/M/S
-RECOMPENSE
-RECOMPILATION
-RECOMPILE/D/G
-RECOMPUTE/D/G/S
-RECONCILE/D/R/G/S
-RECONCILIATION
-RECONFIGURABLE
-RECONFIGURATION/M/S
-RECONFIGURE/D/R/G/S
-RECONNECT/D/G/S
-RECONNECTION
-RECONSIDER/D/G/S
-RECONSIDERATION
-RECONSTRUCT/D/G/S
-RECONSTRUCTION
-RECORD/D/R/Z/G/J/S
-RECOUNT/D/G/S
-RECOURSE
-RECOVER/D/G/S
-RECOVERABLE
-RECOVERY/M/S
-RECREATE/D/G/N/X/V/S
-RECREATION/S
-RECREATIONAL
-RECRUIT/D/R/M/G/S
-RECRUITMENT
-RECTA
-RECTANGLE/M/S
-RECTANGULAR
-RECTIFY
-RECTOR/M/S
-RECTUM/M/S
-RECUR/S
-RECURRENCE/M/S
-RECURRENT/Y
-RECURRING
-RECURSE/D/G/N/S
-RECURSION/M/S
-RECURSIVE/Y
-RECYCLABLE
-RECYCLE/D/G/S
-RED/P/Y/S
-REDBREAST
-REDDEN/D
-REDDER
-REDDEST
-REDDISH/P
-REDECLARE/D/G/S
-REDEEM/D/R/Z/G/S
-REDEFINE/D/G/S
-REDEFINITION/M/S
-REDEMPTION
-REDESIGN/D/G/S
-REDEVELOPMENT
-REDIRECT/D/G
-REDIRECTING
-REDIRECTION/S
-REDISPLAY/D/G/S
-REDISTRIBUTE/D/G/S
-REDONE
-REDOUBLE/D
-REDRAW/G
-REDRAWN
-REDRESS/D/G/S
-REDUCE/D/R/Z/G/S
-REDUCIBILITY
-REDUCIBLE
-REDUCIBLY
-REDUCTION/M/S
-REDUNDANCY/S
-REDUNDANT/Y
-REED/M/S
-REEDUCATION
-REEF/R/S
-REEL/D/R/G/S
-REELECT/D/G/S
-REEMPHASIZE/D/G/S
-REENFORCEMENT
-REENTER/D/G/S
-REENTRANT
-REESTABLISH/D/G/S
-REEVALUATE/D/G/N/S
-REEXAMINE/D/G/S
-REFER/S
-REFEREE/D/S
-REFEREEING
-REFERENCE/D/R/G/S
-REFERENDUM
-REFERENT/M/S
-REFERENTIAL/Y
-REFERENTIALITY
-REFERRAL/M/S
-REFERRED
-REFERRING
-REFILL/D/G/S
-REFILLABLE
-REFINE/D/R/G/S
-REFINEMENT/M/S
-REFLECT/D/G/V/S
-REFLECTION/M/S
-REFLECTIVELY
-REFLECTIVITY
-REFLECTOR/M/S
-REFLEX/M/S
-REFLEXIVE/P/Y
-REFLEXIVITY
-REFORM/D/R/Z/G/S
-REFORMABLE
-REFORMAT/S
-REFORMATION
-REFORMATTED
-REFORMATTING
-REFORMULATE/D/G/N/S
-REFRACTORY
-REFRAIN/D/G/S
-REFRESH/D/R/Z/G/S
-REFRESHINGLY
-REFRESHMENT/M/S
-REFRIGERATOR/M/S
-REFUEL/D/G/S
-REFUGE
-REFUGEE/M/S
-REFUSAL
-REFUSE/D/G/S
-REFUTABLE
-REFUTATION
-REFUTE/D/R/G/S
-REGAIN/D/G/S
-REGAL/D/Y
-REGARD/D/G/S
-REGARDLESS
-REGENERATE/D/G/N/V/S
-REGENT/M/S
-REGIME/M/S
-REGIMEN
-REGIMENT/D/S
-REGION/M/S
-REGIONAL/Y
-REGISTER/D/G/S
-REGISTRATION/M/S
-REGRESS/D/G/V/S
-REGRESSION/M/S
-REGRET/S
-REGRETFUL/Y
-REGRETTABLE
-REGRETTABLY
-REGRETTED
-REGRETTING
-REGROUP/D/G
-REGULAR/Y/S
-REGULARITY/S
-REGULATE/D/G/N/X/V/S
-REGULATOR/M/S
-REHABILITATE/D/G/N
-REHEARSAL/M/S
-REHEARSE/D/R/G/S
-REIGN/D/G/S
-REIMBURSED
-REIMBURSEMENT/M/S
-REIMPLEMENT/D/G
-REIN/D/S
-REINCARNATE/D/N
-REINDEER
-REINFORCE/D/R/G/S
-REINFORCEMENT/M/S
-REINITIALIZE/D/G
-REINSERT/D/G/S
-REINSTATE/D/G/S
-REINSTATEMENT
-REINTERPRET/D/G/S
-REINTRODUCE/D/G/S
-REINVENT/D/G/S
-REITERATE/D/G/N/S
-REJECT/D/G/S
-REJECTION/M/S
-REJECTOR/M/S
-REJOICE/D/R/G/S
-REJOIN/D/G/S
-RELABEL/S/D/G/R/Z
-RELAPSE
-RELATE/D/R/G/N/X/S
-RELATIONAL/Y
-RELATIONSHIP/M/S
-RELATIVE/P/Y/S
-RELATIVISM
-RELATIVISTIC
-RELATIVISTICALLY
-RELATIVITY
-RELAX/D/R/G/S
-RELAXATION/M/S
-RELAY/D/G/S
-RELEARN/D/G
-RELEASE/D/G/S
-RELEGATE/D/G/S
-RELENT/D/G/S
-RELENTLESS/P/Y
-RELEVANCE/S
-RELEVANT/Y
-RELIABILITY
-RELIABLE/P
-RELIABLY
-RELIANCE
-RELIC/M/S
-RELIEF
-RELIEVE/D/R/Z/G/S
-RELIGION/M/S
-RELIGIOUS/P/Y
-RELINQUISH/D/G/S
-RELISH/D/G/S
-RELIVE/G/S
-RELOAD/D/R/G/S
-RELOCATE/D/G/N/X/S
-RELUCTANCE
-RELUCTANT/Y
-RELY/D/G/S
-REMAIN/D/G/S
-REMAINDER/M/S
-REMARK/D/G/S
-REMARKABLE/P
-REMARKABLY
-REMEDIAL
-REMEDY/D/G/S
-REMEMBER/D/G/S
-REMEMBRANCE/M/S
-REMIND/D/R/Z/G/S
-REMINISCENCE/M/S
-REMINISCENT/Y
-REMITTANCE
-REMNANT/M/S
-REMODEL/D/G/S
-REMONSTRATE/D/G/N/V/S
-REMORSE
-REMOTE/P/T/Y
-REMOVABLE
-REMOVAL/M/S
-REMOVE/D/R/G/S
-RENAISSANCE
-RENAL
-RENAME/D/G/S
-REND/Z/G/S
-RENDER/D/G/J/S
-RENDEZVOUS
-RENDITION/M/S
-RENEW/D/R/G/S
-RENEWAL
-RENOUNCE/G/S
-RENOWN/D
-RENT/D/G/S
-RENTAL/M/S
-RENUMBER/G/S
-REOPEN/D/G/S
-REORDER/D/G/S
-REORGANIZATION/M/S
-REORGANIZE/D/G/S
-REPAID
-REPAIR/D/R/G/S
-REPAIRMAN
-REPARATION/M/S
-REPAST/M/S
-REPAY/G/S
-REPEAL/D/R/G/S
-REPEAT/D/R/Z/G/S
-REPEATABLE
-REPEATEDLY
-REPEL/S
-REPENT/D/G/S
-REPENTANCE
-REPERCUSSION/M/S
-REPERTOIRE
-REPETITION/M/S
-REPETITIVE/P/Y
-REPHRASE/D/G/S
-REPINE
-REPLACE/D/R/G/S
-REPLACEABLE
-REPLACEMENT/M/S
-REPLAY/D/G/S
-REPLENISH/D/G/S
-REPLETE/P/N
-REPLICA
-REPLICATE/D/G/N/S
-REPLY/D/G/N/X/S
-REPORT/D/R/Z/G/S
-REPORTEDLY
-REPOSE/D/G/S
-REPOSITION/D/G/S
-REPOSITORY/M/S
-REPRESENT/D/G/S
-REPRESENTABLE
-REPRESENTABLY
-REPRESENTATION/M/S
-REPRESENTATIONAL/Y
-REPRESENTATIVE/P/Y/S
-REPRESS/D/G/V/S
-REPRESSION/M/S
-REPRIEVE/D/G/S
-REPRINT/D/G/S
-REPRISAL/M/S
-REPROACH/D/G/S
-REPRODUCE/D/R/Z/G/S
-REPRODUCIBILITY/S
-REPRODUCIBLE
-REPRODUCIBLY
-REPRODUCTION/M/S
-REPROGRAM/S
-REPROGRAMMED
-REPROGRAMMING
-REPROOF
-REPROVE/R
-REPTILE/M/S
-REPUBLIC/M/S
-REPUBLICAN/M/S
-REPUDIATE/D/G/N/X/S
-REPULSE/D/G/N/X/V/S
-REPUTABLE
-REPUTABLY
-REPUTATION/M/S
-REPUTE/D/S
-REPUTEDLY
-REQUEST/D/R/Z/G/S
-REQUIRE/D/G/S
-REQUIREMENT/M/S
-REQUISITE/X/S
-REQUISITION/D/G/S
-REREAD
-REROUTE/D/G/S
-RESCUE/D/R/Z/G/S
-RESEARCH/D/R/Z/G/S
-RESELECT/D/G/S
-RESEMBLANCE/M/S
-RESEMBLE/D/G/S
-RESENT/D/G/S
-RESENTFUL/Y
-RESENTMENT
-RESERVATION/M/S
-RESERVE/D/R/G/S
-RESERVOIR/M/S
-RESET/S
-RESETTING/S
-RESHAPE/D/G
-RESIDE/D/G/S
-RESIDENCE/M/S
-RESIDENT/M/S
-RESIDENTIAL/Y
-RESIDUE/M/S
-RESIGN/D/G/S
-RESIGNATION/M/S
-RESIN/M/S
-RESIST/D/G/V/S
-RESISTANCE/S
-RESISTANT/Y
-RESISTIBLE
-RESISTIBLY
-RESISTIVITY
-RESISTOR/M/S
-RESIZE/D/G
-RESOLUTE/P/N/X/Y
-RESOLVABLE
-RESOLVE/D/R/Z/G/S
-RESONANCE/S
-RESONANT
-RESORT/D/G/S
-RESOUND/G/S
-RESOURCE/M/S
-RESOURCEFUL/P/Y
-RESPECT/D/R/G/V/S
-RESPECTABILITY
-RESPECTABLE
-RESPECTABLY
-RESPECTFUL/P/Y
-RESPECTIVELY
-RESPIRATION
-RESPITE
-RESPLENDENT/Y
-RESPOND/D/R/G/S
-RESPONDENT/M/S
-RESPONSE/V/S
-RESPONSIBILITY/S
-RESPONSIBLE/P
-RESPONSIBLY
-RESPONSIVELY
-RESPONSIVENESS
-REST/D/G/V/S
-RESTART/D/G/S
-RESTATE/D/G/S
-RESTATEMENT
-RESTAURANT/M/S
-RESTFUL/P/Y
-RESTLESS/P/Y
-RESTORATION/M/S
-RESTORE/D/R/Z/G/S
-RESTRAIN/D/R/Z/G/S
-RESTRAINT/M/S
-RESTRICT/D/G/V/S
-RESTRICTION/M/S
-RESTRICTIVELY
-RESTRUCTURE/D/G/S
-RESULT/D/G/S
-RESULTANT/Y/S
-RESUMABLE
-RESUME/D/G/S
-RESUMPTION/M/S
-RESURRECT/D/G/S
-RESURRECTION/M/S
-RESURRECTOR/S
-RETAIL/R/Z/G
-RETAIN/D/R/Z/G/S
-RETAINMENT
-RETALIATION
-RETARD/D/R/G
-RETENTION/S
-RETENTIVE/P/Y
-RETHINK
-RETICLE/M/S
-RETICULAR
-RETICULATE/D/G/N/Y/S
-RETINA/M/S
-RETINAL
-RETINUE
-RETIRE/D/G/S
-RETIREMENT/M/S
-RETORT/D/S
-RETRACE/D/G
-RETRACT/D/G/S
-RETRACTION/S
-RETRAIN/D/G/S
-RETRANSMISSION/M/S
-RETRANSMIT/S
-RETRANSMITTED
-RETRANSMITTING
-RETREAT/D/G/S
-RETRIEVABLE
-RETRIEVAL/M/S
-RETRIEVE/D/R/Z/G/S
-RETROACTIVE
-RETROACTIVELY
-RETROSPECT/V
-RETROSPECTION
-RETRY/D/R/Z/G/S
-RETURN/D/R/G/S
-RETURNABLE
-RETYPE/D/G/S
-REUNION/M/S
-REUNITE/D/G
-REUSABILITY
-REUSABLE
-REUSE/D/G/S
-REVAMP/D/G/S
-REVEAL/D/G/S
-REVEL/D/R/G/S
-REVELATION/M/S
-REVELRY
-REVENGE/R
-REVENUE/Z/S
-REVERE/D/G/S
-REVERENCE
-REVEREND/M/S
-REVERENTLY
-REVERIFY/D/G/S
-REVERSAL/M/S
-REVERSE/D/R/G/N/Y/S
-REVERSIBLE
-REVERT/D/G/S
-REVIEW/D/R/Z/G/S
-REVILE/D/R/G
-REVISE/D/R/G/N/X/S
-REVISION/M/S
-REVISIT/D/G/S
-REVIVAL/M/S
-REVIVE/D/R/G/S
-REVOCATION
-REVOKE/D/R/G/S
-REVOLT/D/R/G/S
-REVOLTINGLY
-REVOLUTION/M/S
-REVOLUTIONARY/M/S
-REVOLUTIONIZE/D/R
-REVOLVE/D/R/Z/G/S
-REWARD/D/G/S
-REWARDINGLY
-REWIND/G/S
-REWORK/D/G/S
-REWOUND
-REWRITE/G/S
-REWRITTEN
-RHETORIC
-RHEUMATISM
-RHEUMATOLOGY
-RHINOCEROS
-RHUBARB
-RHYME/D/G/S
-RHYTHM/M/S
-RHYTHMIC
-RHYTHMICALLY
-RIB/M/S
-RIBBED
-RIBBING
-RIBBON/M/S
-RICE
-RICH/P/T/R/Y/S
-RICHARD/M
-RICK/M
-RICKSHAW/M/S
-RID
-RIDDEN
-RIDDLE/D/G/S
-RIDE/R/Z/G/S
-RIDGE/M/S
-RIDICULE/D/G/S
-RIDICULOUS/P/Y
-RIFLE/D/R/G/S
-RIFLEMAN
-RIFT
-RIG/M/S
-RIGGING
-RIGHT/P/D/R/G/Y/S
-RIGHTEOUS/P/Y
-RIGHTFUL/P/Y
-RIGHTMOST
-RIGHTWARD
-RIGID/Y
-RIGIDITY
-RIGOR/S
-RIGOROUS/Y
-RILL
-RIM/M/S
-RIME
-RIND/M/S
-RING/D/R/Z/G/J/S
-RINGINGLY
-RINSE/D/R/G/S
-RIOT/D/R/Z/G/S
-RIOTOUS
-RIP/N/S
-RIPE/P/Y
-RIPPED
-RIPPING
-RIPPLE/D/G/S
-RISE/R/Z/G/J/S
-RISEN
-RISK/D/G/S
-RITE/M/S
-RITUAL/Y/S
-RIVAL/D/S/G
-RIVALLED
-RIVALLING
-RIVALRY/M/S
-RIVER/M/S
-RIVERSIDE
-RIVET/R/S
-RIVULET/M/S
-ROAD/M/S
-ROADSIDE
-ROADSTER/M/S
-ROADWAY/M/S
-ROAM/D/G/S
-ROAR/D/R/G/S
-ROAST/D/R/G/S
-ROB/S/M
-ROBBED
-ROBBER/M/S
-ROBBERY/M/S
-ROBBING
-ROBE/D/G/S
-ROBERT/M
-ROBIN/M/S
-ROBOT/M/S
-ROBOTIC
-ROBOTICS
-ROBUST/P/Y
-ROCK/D/R/Z/G/S
-ROCKET/D/G/S
-ROCKY/S
-ROD/M/S
-RODE
-ROE
-ROGER/M
-ROGUE/M/S
-ROLE/M/S
-ROLL/D/R/Z/G/S
-ROMAN
-ROMANCE/R/Z/G/S
-ROMANTIC/M/S
-ROMP/D/R/G/S
-ROOF/D/R/G/S
-ROOK
-ROOM/D/R/Z/G/S
-ROOST/R/Z
-ROOT/D/R/M/G/S
-ROPE/D/R/Z/G/S
-ROSE/M/S
-ROSEBUD/M/S
-ROSY/P
-ROT/S
-ROTARY
-ROTATE/D/G/N/X/S
-ROTATOR
-ROTTEN/P
-ROUGE
-ROUGH/P/D/T/R/N/Y
-ROUND/P/D/T/R/G/Y/S
-ROUNDABOUT
-ROUNDEDNESS
-ROUNDOFF
-ROUSE/D/G/S
-ROUT
-ROUTE/D/R/Z/G/J/S
-ROUTINE/Y/S
-ROVE/D/R/G/S
-ROW/D/R/G/S
-ROY/M
-ROYAL/Y
-ROYALIST/M/S
-ROYALTY/M/S
-RUB/X/S
-RUBBED
-RUBBER/M/S
-RUBBING
-RUBBISH
-RUBBLE
-RUBLE/M/S
-RUBOUT
-RUBY/M/S
-RUDDER/M/S
-RUDDY/P
-RUDE/P/Y
-RUDIMENT/M/S
-RUDIMENTARY
-RUE
-RUEFULLY
-RUFFIAN/Y/S
-RUFFLE/D/S
-RUG/M/S
-RUGGED/P/Y
-RUIN/D/G/S
-RUINATION/M/S
-RUINOUS/Y
-RULE/D/R/Z/G/J/S
-RUM/N
-RUMBLE/D/R/G/S
-RUMOR/D/S
-RUMP/Y
-RUMPLE/D
-RUN/S
-RUNAWAY
-RUNG/M/S
-RUNNER/M/S
-RUNNING
-RUNTIME
-RUPTURE/D/G/S
-RURAL/Y
-RUSH/D/R/G/S
-RUSSELL/M
-RUSSET
-RUSSIAN/M/S
-RUST/D/G/S
-RUSTIC
-RUSTICATE/D/G/N/S
-RUSTLE/D/R/Z/G
-RUSTY
-RUT/M/S
-RUTGERS
-RUTH/M
-RUTHLESS/P/Y
-RYE
-SABER/M/S
-SABLE/M/S
-SABOTAGE
-SACK/R/G/S
-SACRED/P/Y
-SACRIFICE/D/R/Z/G/S
-SACRIFICIAL/Y
-SAD/P/Y
-SADDEN/D/S
-SADDER
-SADDEST
-SADDLE/D/S
-SADISM
-SADIST/M/S
-SADISTIC
-SADISTICALLY
-SAFE/P/T/R/Y/S
-SAFEGUARD/D/G/S
-SAFETY/S
-SAG/S
-SAGACIOUS
-SAGACITY
-SAGE/Y/S
-SAID
-SAIL/D/G/S
-SAILOR/Y/S
-SAINT/D/Y/S
-SAKE/S
-SALABLE
-SALAD/M/S
-SALARY/D/S
-SALE/M/S
-SALESMAN
-SALESMEN
-SALIENT
-SALINE
-SALIVA
-SALLOW
-SALLY/G/S
-SALMON
-SALON/M/S
-SALOON/M/S
-SALT/D/R/Z/G/S
-SALTY/P/T/R
-SALUTARY
-SALUTATION/M/S
-SALUTE/D/G/S
-SALVAGE/D/R/G/S
-SALVATION
-SALVE/R/S
-SAM/M
-SAME/P
-SAMPLE/D/R/Z/G/J/S
-SAN
-SANCTIFY/D/N
-SANCTION/D/G/S
-SANCTITY
-SANCTUARY/M/S
-SAND/D/R/Z/G/S
-SANDAL/M/S
-SANDPAPER
-SANDSTONE
-SANDWICH/S
-SANDY
-SANE/T/R/Y
-SANG
-SANGUINE
-SANITARIUM
-SANITARY
-SANITATION
-SANITY
-SANK
-SANTA/M
-SAP/M/S
-SAPLING/M/S
-SAPPHIRE
-SARCASM/M/S
-SARCASTIC
-SASH
-SAT
-SATCHEL/M/S
-SATE/D/G/S
-SATELLITE/M/S
-SATIN
-SATIRE/M/S
-SATISFACTION/M/S
-SATISFACTORILY
-SATISFACTORY
-SATISFIABILITY
-SATISFIABLE
-SATISFY/D/G/S
-SATURATE/D/G/N/S
-SATURDAY/M/S
-SATYR
-SAUCE/R/Z/S
-SAUCEPAN/M/S
-SAUCY
-SAUL/M
-SAUNA
-SAUNTER
-SAUSAGE/M/S
-SAVAGE/P/D/R/Z/G/Y/S
-SAVE/D/R/Z/G/J/S
-SAVIOR/M/S
-SAVOR/D/G/S
-SAVORY
-SAW/D/G/S
-SAWMILL/M/S
-SAWTOOTH
-SAY/R/Z/G/J/S
-SCABBARD/M/S
-SCAFFOLD/G/J/S
-SCALABLE
-SCALAR/M/S
-SCALD/D/G
-SCALE/D/G/J/S
-SCALLOP/D/S
-SCALP/M/S
-SCALY
-SCAMPER/G/S
-SCAN/S
-SCANDAL/M/S
-SCANDALOUS
-SCANNED
-SCANNER/M/S
-SCANNING
-SCANT/Y
-SCANTILY
-SCANTY/P/T/R
-SCAR/M/S
-SCARCE/P/Y
-SCARCITY
-SCARE/D/G/S
-SCARF
-SCARLET
-SCARY
-SCATTER/D/G/S
-SCENARIO/M/S
-SCENE/M/S
-SCENERY
-SCENIC
-SCENT/D/S
-SCEPTER/M/S
-SCHEDULE/D/R/Z/G/S
-SCHEMA/M/S
-SCHEMATA
-SCHEMATIC/S
-SCHEMATICALLY
-SCHEME'S
-SCHEME/D/R/Z/G/S
-SCHENLEY
-SCHIZOPHRENIA
-SCHOLAR/Y/S
-SCHOLARSHIP/M/S
-SCHOLASTIC/S
-SCHOLASTICALLY
-SCHOOL/D/R/Z/G/S
-SCHOOLBOY/M/S
-SCHOOLHOUSE/M/S
-SCHOOLMASTER/M/S
-SCHOOLMATE
-SCHOOLROOM/M/S
-SCHOONER
-SCIENCE/M/S
-SCIENTIFIC
-SCIENTIFICALLY
-SCIENTIST/M/S
-SCISSOR/D/G/S
-SCOFF/D/R/G/S
-SCOLD/D/G/S
-SCOOP/D/G/S
-SCOPE/D/G/S
-SCORCH/D/R/G/S
-SCORE/D/R/Z/G/J/S
-SCORN/D/R/G/S
-SCORNFUL/Y
-SCORPION/M/S
-SCOTLAND
-SCOTT/M
-SCOUNDREL/M/S
-SCOUR/D/G/S
-SCOURGE
-SCOUT/D/G/S
-SCOW
-SCOWL/D/G/S
-SCRAMBLE/D/R/G/S
-SCRAP/M/S
-SCRAPE/D/R/Z/G/J/S
-SCRAPPED
-SCRATCH/D/R/Z/G/S
-SCRATCHPAD/M/S
-SCRAWL/D/G/S
-SCREAM/D/R/Z/G/S
-SCREECH/D/G/S
-SCREEN/D/G/J/S
-SCREW/D/G/S
-SCRIBBLE/D/R/S
-SCRIBE/G/S
-SCRIPT/M/S
-SCRIPTURE/S
-SCROLL/D/G/S
-SCRUB
-SCRUPLE
-SCRUPULOUS/Y
-SCRUTINIZE/D/G
-SCRUTINY
-SCS
-SCUFFLE/D/G/S
-SCULPT/D/S
-SCULPTOR/M/S
-SCULPTURE/D/S
-SCURRY/D
-SCUTTLE/D/G/S
-SCYTHE/M/S
-SEA/Y/S
-SEABOARD
-SEACOAST/M/S
-SEAL/D/R/G/S
-SEALEVEL
-SEAM/D/G/N/S
-SEAMAN
-SEAN/M
-SEAPORT/M/S
-SEAR/D/G/S
-SEARCH/D/R/Z/G/J/S
-SEARCHINGLY
-SEARING/Y
-SEASHORE/M/S
-SEASIDE
-SEASON/D/R/Z/G/J/S
-SEASONABLE
-SEASONABLY
-SEASONAL/Y
-SEAT/D/G/S
-SEAWARD
-SEAWEED
-SECEDE/D/G/S
-SECLUDED
-SECLUSION
-SECOND/D/R/Z/G/Y/S
-SECONDARILY
-SECONDARY
-SECONDHAND
-SECRECY
-SECRET/Y/S
-SECRETARIAL
-SECRETARY/M/S
-SECRETE/D/G/N/X/V/S
-SECRETIVELY
-SECT/M/S
-SECTION/D/G/S
-SECTIONAL
-SECTOR/M/S
-SECULAR
-SECURE/D/G/Y/J/S
-SECURITY/S
-SEDGE
-SEDIMENT/M/S
-SEDUCE/D/R/Z/G/S
-SEDUCTIVE
-SEE/R/Z/S
-SEED/D/R/Z/G/J/S
-SEEDLING/M/S
-SEEING
-SEEK/R/Z/G/S
-SEEM/D/G/Y/S
-SEEMINGLY
-SEEN
-SEEP/D/G/S
-SEETHE/D/G/S
-SEGMENT/D/G/S
-SEGMENTATION/M/S
-SEGREGATE/D/G/N/S
-SEISMIC
-SEIZE/D/G/S
-SEIZURE/M/S
-SELDOM
-SELECT/D/G/V/S
-SELECTABLE
-SELECTION/M/S
-SELECTIVE/Y
-SELECTIVITY
-SELECTOR/M/S
-SELF
-SELFISH/P/Y
-SELFSAME
-SELL/R/Z/G/S
-SELVES
-SEMANTIC/S
-SEMANTICAL/Y
-SEMANTICIST/M/S
-SEMAPHORE/M/S
-SEMBLANCE
-SEMESTER/M/S
-SEMI
-SEMIAUTOMATED
-SEMIAUTOMATIC
-SEMICOLON/M/S
-SEMICONDUCTOR/M/S
-SEMINAL
-SEMINAR/M/S
-SEMINARY/M/S
-SEMIPERMANENT/Y
-SENATE/M/S
-SENATOR/M/S
-SEND/R/Z/G/S
-SENIOR/M/S
-SENIORITY
-SENSATION/M/S
-SENSATIONAL/Y
-SENSE/D/G/S
-SENSELESS/P/Y
-SENSIBILITY/S
-SENSIBLE
-SENSIBLY
-SENSITIVE/P/Y/S
-SENSITIVITY/S
-SENSOR/M/S
-SENSORY
-SENT
-SENTENCE/D/G/S
-SENTENTIAL
-SENTIMENT/M/S
-SENTIMENTAL/Y
-SENTINEL/M/S
-SENTRY/M/S
-SEPARABLE
-SEPARATE/P/D/G/N/X/Y/S
-SEPARATOR/M/S
-SEPTEMBER
-SEPULCHER/M/S
-SEQUEL/M/S
-SEQUENCE/D/R/Z/G/J/S
-SEQUENTIAL/Y
-SEQUENTIALITY
-SEQUENTIALIZE/D/G/S
-SEQUESTER
-SERENDIPITOUS
-SERENDIPITY
-SERENE/Y
-SERENITY
-SERF/M/S
-SERGEANT/M/S
-SERIAL/Y/S
-SERIALIZATION/M/S
-SERIALIZE/D/G/S
-SERIES
-SERIOUS/P/Y
-SERMON/M/S
-SERPENT/M/S
-SERPENTINE
-SERUM/M/S
-SERVANT/M/S
-SERVE/D/R/Z/G/J/S
-SERVICE/D/G/S
-SERVICEABLE
-SERVILE
-SERVITUDE
-SESAME
-SESSION/M/S
-SET/M/S
-SETTER/M/S
-SETTING/S
-SETTLE/D/R/Z/G/S
-SETTLEMENT/M/S
-SETUP/S
-SEVEN/H/S
-SEVENTEEN/H/S
-SEVENTY/H/S
-SEVER/S
-SEVERAL/Y
-SEVERANCE
-SEVERE/D/T/R/G/Y
-SEVERITY/M/S
-SEW/D/R/Z/G/S
-SEX/D/S
-SEXUAL/Y
-SEXUALITY
-SHABBY
-SHACK/D/S
-SHACKLE/D/G/S
-SHADE/D/G/J/S
-SHADILY
-SHADOW/D/G/S
-SHADOWY
-SHADY/P/T/R
-SHAFT/M/S
-SHAGGY
-SHAKABLE
-SHAKABLY
-SHAKE/R/Z/G/S
-SHAKEN
-SHAKY/P
-SHALE
-SHALL
-SHALLOW/P/R/Y
-SHAM/M/S
-SHAMBLES
-SHAME/D/G/S
-SHAMEFUL/Y
-SHAMELESS/Y
-SHAN'T
-SHANGHAI
-SHANTY/M/S
-SHAPE/D/R/Z/G/Y/S
-SHAPELESS/P/Y
-SHARABLE
-SHARE/D/R/Z/G/S
-SHARECROPPER/M/S
-SHAREHOLDER/M/S
-SHARK/M/S
-SHARON/M
-SHARP/P/T/R/N/X/Y
-SHARPENED
-SHARPENING
-SHATTER/D/G/S
-SHAVE/D/G/J/S
-SHAVEN
-SHAWL/M/S
-SHE'LL
-SHE/M
-SHEAF
-SHEAR/D/R/G/S
-SHEATH/G
-SHEATHS
-SHEAVES
-SHED/S
-SHEEP
-SHEER/D
-SHEET/D/G/S
-SHELF
-SHELL/D/R/G/S
-SHELTER/D/G/S
-SHELVE/D/G/S
-SHEPHERD/M/S
-SHERIFF/M/S
-SHIELD/D/G/S
-SHIFT/D/R/Z/G/S
-SHIFTILY
-SHIFTY/P/T/R
-SHILLING/S
-SHIMMER/G
-SHIN
-SHINE/D/R/Z/G/S
-SHINGLE/M/S
-SHININGLY
-SHINY
-SHIP/M/S
-SHIPBOARD
-SHIPBUILDING
-SHIPMENT/M/S
-SHIPPED
-SHIPPER/M/S
-SHIPPING
-SHIPWRECK/D/S
-SHIRK/R/G/S
-SHIRT/G/S
-SHIVER/D/R/G/S
-SHOAL/M/S
-SHOCK/D/R/Z/G/S
-SHOCKINGLY
-SHOD
-SHOE/D/S
-SHOEING
-SHOEMAKER
-SHONE
-SHOOK
-SHOOT/R/Z/G/J/S
-SHOP/M/S
-SHOPKEEPER/M/S
-SHOPPED
-SHOPPER/M/S
-SHOPPING
-SHORE/M/S
-SHORN
-SHORT/P/D/T/R/G/Y/S
-SHORTAGE/M/S
-SHORTCOMING/M/S
-SHORTCUT/M/S
-SHORTEN/D/G/S
-SHORTHAND/D
-SHOT/M/S
-SHOTGUN/M/S
-SHOULD/Z
-SHOULDER/D/G/S
-SHOULDN'T
-SHOUT/D/R/Z/G/S
-SHOVE/D/G/S
-SHOVEL/D/S
-SHOW/D/R/Z/G/J/S
-SHOWER/D/G/S
-SHOWN
-SHRANK
-SHRED/M/S
-SHREW/M/S
-SHREWD/P/T/Y
-SHRIEK/D/G/S
-SHRILL/P/D/G
-SHRILLY
-SHRIMP
-SHRINE/M/S
-SHRINK/G/S
-SHRINKABLE
-SHRIVEL/D
-SHROUD/D
-SHRUB/M/S
-SHRUBBERY
-SHRUG/S
-SHRUNK/N
-SHUDDER/D/G/S
-SHUFFLE/D/G/S
-SHUN/S
-SHUT/S
-SHUTDOWN/M/S
-SHUTTER/D/S
-SHUTTING
-SHUTTLE/D/G/S
-SHY/D/Y/S
-SHYNESS
-SIBLING/M/S
-SICK/T/R/N/Y
-SICKLE
-SICKNESS/M/S
-SIDE/D/G/J/S
-SIDEBOARD/M/S
-SIDEBURN/M/S
-SIDELIGHT/M/S
-SIDEWALK/M/S
-SIDEWAYS
-SIDEWISE
-SIEGE/M/S
-SIEMENS
-SIERRA
-SIEVE/M/S
-SIFT/D/R/G
-SIGH/D/G
-SIGHS
-SIGHT/D/G/Y/J/S
-SIGMA
-SIGN/D/R/Z/G/S
-SIGNAL/D/G/Y/S/R
-SIGNALLED
-SIGNALLER
-SIGNALLING
-SIGNATURE/M/S
-SIGNET
-SIGNIFICANCE
-SIGNIFICANT/Y/S
-SIGNIFY/D/G/N/S
-SIGNOR
-SIKKIM
-SILENCE/D/R/Z/G/S
-SILENT/Y
-SILHOUETTE/D/S
-SILICON
-SILICONE
-SILK/N/S
-SILKILY
-SILKINE
-SILKY/T/R
-SILL/M/S
-SILLY/P/T
-SILT/D/G/S
-SILVER/D/G/S
-SILVERY
-SIMILAR/Y
-SIMILARITY/S
-SIMILITUDE
-SIMMER/D/G/S
-SIMON/M
-SIMPLE/P/T/R
-SIMPLEX
-SIMPLICITY/M/S
-SIMPLIFY/D/R/Z/G/N/X/S
-SIMPLISTIC
-SIMPLY
-SIMULATE/D/G/N/X/S
-SIMULATOR/M/S
-SIMULTANEITY
-SIMULTANEOUS/Y
-SIN/M/S
-SINCE
-SINCERE/T/Y
-SINCERITY
-SINE/S
-SINEW/M/S
-SINFUL/P/Y
-SING/D/R/Z/G/Y/S
-SINGABLE
-SINGAPORE
-SINGINGLY
-SINGLE/P/D/G/S
-SINGLETON/M/S
-SINGULAR/Y
-SINGULARITY/M/S
-SINISTER
-SINK/D/R/Z/G/S
-SINNED
-SINNER/M/S
-SINNING
-SINUSITIS
-SINUSOIDAL
-SINUSOIDS
-SIP/S
-SIR/N/X/S
-SIRE/D/S
-SIRUP
-SISTER/Y/S
-SIT/S
-SITE/D/G/S
-SITTER/M/S
-SITTING/S
-SITUATE/D/G/N/X/S
-SITUATIONAL/Y
-SIX/H/S
-SIXPENCE
-SIXTEEN/H/S
-SIXTY/H/S
-SIZABLE
-SIZE/D/G/J/S
-SKATE/D/R/Z/G/S
-SKELETAL
-SKELETON/M/S
-SKEPTIC/M/S
-SKEPTICAL/Y
-SKETCH/D/G/S
-SKETCHILY
-SKETCHY
-SKEW/D/R/Z/G/S
-SKI/G/S
-SKILL/D/S
-SKILLFUL/P/Y
-SKIM/M/S
-SKIMP/D/G/S
-SKIN/M/S
-SKINNED
-SKINNER/M/S
-SKINNING
-SKIP/S
-SKIPPED
-SKIPPER/M/S
-SKIPPING
-SKIRMISH/D/R/Z/G/S
-SKIRT/D/G/S
-SKULK/D/R/G/S
-SKULL/M/S
-SKUNK/M/S
-SKY/M/S
-SKYLARK/G/S
-SKYLIGHT/M/S
-SKYSCRAPER/M/S
-SLAB
-SLACK/P/R/G/N/Y/S
-SLAIN
-SLAM/S
-SLAMMED
-SLAMMING
-SLANDER/R/S
-SLANG
-SLANT/D/G/S
-SLAP/S
-SLAPPED
-SLAPPING
-SLASH/D/G/S
-SLAT/M/S
-SLATE/D/R/S
-SLAUGHTER/D/G/S
-SLAVE/R/S
-SLAVERY
-SLAY/R/Z/G/S
-SLED/M/S
-SLEDGE/M/S
-SLEEK
-SLEEP/R/Z/G/S
-SLEEPILY
-SLEEPLESS/P/Y
-SLEEPY/P
-SLEET
-SLEEVE/M/S
-SLEIGH
-SLEIGHS
-SLENDER/R
-SLEPT
-SLEW/G
-SLICE/D/R/Z/G/S
-SLICK/R/Z/S
-SLID
-SLIDE/R/Z/G/S
-SLIGHT/P/D/T/R/G/Y/S
-SLIM/Y
-SLIME/D
-SLIMY
-SLING/G/S
-SLIP/M/S
-SLIPPAGE
-SLIPPED
-SLIPPER/M/S
-SLIPPERY/P
-SLIPPING
-SLIT/M/S
-SLOGAN/M/S
-SLOP/S
-SLOPE/D/R/Z/G/S
-SLOPPED
-SLOPPING
-SLOPPY/P
-SLOT/M/S
-SLOTH
-SLOTHS
-SLOTTED
-SLOUCH/D/G/S
-SLOW/P/D/T/R/G/Y/S
-SLUG/S
-SLUGGISH/P/Y
-SLUM/M/S
-SLUMBER/D
-SLUMP/D/S
-SLUNG
-SLUR/M/S
-SLY/Y
-SMACK/D/G/S
-SMALL/P/T/R
-SMALLPOX
-SMALLTALK
-SMART/P/D/T/R/Y
-SMASH/D/R/Z/G/S
-SMASHINGLY
-SMEAR/D/G/S
-SMELL/D/G/S
-SMELLY
-SMELT/R/S
-SMILE/D/G/S
-SMILINGLY
-SMITE
-SMITH
-SMITHS
-SMITHY
-SMITTEN
-SMOCK/G/S
-SMOG
-SMOKABLE
-SMOKE/D/R/Z/G/S
-SMOKY/S
-SMOLDER/D/G/S
-SMOOTH/P/D/T/R/G/Y/S
-SMOTE
-SMOTHER/D/G/S
-SMUGGLE/D/R/Z/G/S
-SNAIL/M/S
-SNAKE/D/S
-SNAP/S
-SNAPPED
-SNAPPER/M/S
-SNAPPILY
-SNAPPING
-SNAPPY
-SNAPSHOT/M/S
-SNARE/D/G/S
-SNARL/D/G
-SNATCH/D/G/S
-SNEAK/D/R/Z/G/S
-SNEAKILY
-SNEAKY/P/T/R
-SNEER/D/G/S
-SNEEZE/D/G/S
-SNIFF/D/G/S
-SNOOP/D/G/S
-SNORE/D/G/S
-SNORT/D/G/S
-SNOUT/M/S
-SNOW/D/G/S
-SNOWILY
-SNOWMAN
-SNOWMEN
-SNOWSHOE/M/S
-SNOWY/T/R
-SNUFF/D/R/G/S
-SNUG/P/Y
-SNUGGLE/D/G/S
-SO
-SOAK/D/G/S
-SOAP/D/G/S
-SOAR/D/G/S
-SOB/R/S
-SOBER/P/D/G/Y/S
-SOCCER
-SOCIABILITY
-SOCIABLE
-SOCIABLY
-SOCIAL/Y
-SOCIALISM
-SOCIALIST/M/S
-SOCIALIZATION
-SOCIALIZE/D/G/S
-SOCIETAL
-SOCIETY/M/S
-SOCIOLOGICAL/Y
-SOCIOLOGY
-SOCK/D/G/S
-SOCKET/M/S
-SOD/M/S
-SODA
-SODIUM
-SODOMY
-SOFA/M/S
-SOFT/P/T/R/X/Y
-SOFTEN/D/G/S
-SOFTWARE/M/S
-SOIL/D/G/S
-SOJOURN/R/Z
-SOLACE/D
-SOLAR
-SOLD/R
-SOLDIER/G/Y/S
-SOLE/Y/S
-SOLEMN/P/Y
-SOLEMNITY
-SOLICIT/D/G/S
-SOLICITOR
-SOLID/P/Y/S
-SOLIDIFY/D/G/N/S
-SOLIDITY
-SOLITAIRE
-SOLITARY
-SOLITUDE/M/S
-SOLO/M/S
-SOLUBILITY
-SOLUBLE
-SOLUTION/M/S
-SOLVABLE
-SOLVE/D/R/Z/G/S
-SOLVENT/M/S
-SOMBER/Y
-SOME
-SOMEBODY
-SOMEDAY
-SOMEHOW
-SOMEONE/M
-SOMETHING
-SOMETIME/S
-SOMEWHAT
-SOMEWHERE
-SON/M/S
-SONAR
-SONG/M/S
-SONNET/M/S
-SOON/T/R
-SOOT
-SOOTH
-SOOTHE/D/R/G/S
-SOPHIE/M
-SOPHISTICATED
-SOPHISTICATION
-SOPHOMORE/M/S
-SORCERER/M/S
-SORCERY
-SORDID/P/Y
-SORE/P/T/R/Y/S
-SORROW/M/S
-SORROWFUL/Y
-SORRY/T/R
-SORT/D/R/Z/G/S
-SOUGHT
-SOUL/M/S
-SOUND/P/D/T/R/Y/S
-SOUNDING/M/S
-SOUP/M/S
-SOUR/P/D/T/R/G/Y/S
-SOURCE/M/S
-SOUTH
-SOUTHERN/R/Z
-SOVEREIGN/M/S
-SOVIET/M/S
-SOY
-SPACE/D/R/Z/G/J/S
-SPACECRAFT/S
-SPACESHIP/M/S
-SPADE/D/G/S
-SPAGHETTI
-SPAIN
-SPAN/M/S
-SPANISH
-SPANK/D/G/S
-SPANKINGLY
-SPANNED
-SPANNER/M/S
-SPANNING
-SPARE/P/D/T/R/G/Y/S
-SPARINGLY
-SPARK/D/G/S
-SPARROW/M/S
-SPARSE/P/T/R/Y
-SPAT
-SPATE/M/S
-SPATIAL/Y
-SPATTER/D
-SPAWN/D/G/S
-SPEAK/R/Z/G/S
-SPEAKABLE
-SPEAR/D/S
-SPECIAL/Y/S
-SPECIALIST/M/S
-SPECIALIZATION/M/S
-SPECIALIZE/D/G/S
-SPECIALTY/M/S
-SPECIES
-SPECIFIABLE
-SPECIFIC/S
-SPECIFICALLY
-SPECIFICITY
-SPECIFY/D/R/Z/G/N/X/S
-SPECIMEN/M/S
-SPECK/M/S
-SPECKLE/D/S
-SPECTACLE/D/S
-SPECTACULAR/Y
-SPECTATOR/M/S
-SPECTER/M/S
-SPECTRA
-SPECTROGRAM/M/S
-SPECTRUM
-SPECULATE/D/G/N/X/V/S
-SPECULATOR/M/S
-SPED
-SPEECH/M/S
-SPEECHLESS/P
-SPEED/D/R/Z/G/S
-SPEEDILY
-SPEEDUP/M/S
-SPEEDY
-SPELL/D/R/Z/G/J/S
-SPENCER
-SPEND/R/Z/G/S
-SPENT
-SPHERE/M/S
-SPHERICAL/Y
-SPICE/D/S
-SPICY/P
-SPIDER/M/S
-SPIKE/D/S
-SPILL/D/R/G/S
-SPIN/S
-SPINACH
-SPINAL/Y
-SPINDLE/G
-SPINE
-SPINNER/M/S
-SPINNING
-SPIRAL/D/G/Y
-SPIRE/M/S
-SPIRIT/D/G/S
-SPIRITEDLY
-SPIRITUAL/Y/S
-SPIT/S
-SPITE/D/G/S
-SPITEFUL/P/Y
-SPITTING
-SPLASH/D/G/S
-SPLEEN
-SPLENDID/Y
-SPLENDOR
-SPLICE/D/R/Z/G/J/S
-SPLINE/M/S
-SPLINTER/D/S
-SPLIT/M/S
-SPLITTER/M/S
-SPLITTING
-SPOIL/D/R/Z/G/S
-SPOKE/D/S
-SPOKEN
-SPOKESMAN
-SPOKESMEN
-SPONGE/D/R/Z/G/S
-SPONSOR/D/G/S
-SPONSORSHIP
-SPONTANEOUS/Y
-SPOOK
-SPOOKY
-SPOOL/D/R/G/S
-SPOON/D/G/S
-SPORE/M/S
-SPORT/D/G/V/S
-SPORTINGLY
-SPORTSMAN
-SPOT/M/S
-SPOTLESS/Y
-SPOTTED
-SPOTTER/M/S
-SPOTTING
-SPOUSE/M/S
-SPOUT/D/G/S
-SPRANG
-SPRAWL/D/G/S
-SPRAY/D/R/G/S
-SPREAD/R/Z/G/J/S
-SPREE/M/S
-SPRIG
-SPRIGHTLY
-SPRING/R/Z/G/S
-SPRINGTIME
-SPRINGY/P/T/R
-SPRINKLE/D/R/G/S
-SPRINT/D/R/Z/G/S
-SPRITE
-SPROUT/D/G
-SPRUCE/D
-SPRUNG
-SPUN
-SPUR/M/S
-SPURIOUS
-SPURN/D/G/S
-SPURT/D/G/S
-SPUTTER/D
-SPY/G/S
-SQUABBLE/D/G/S
-SQUAD/M/S
-SQUADRON/M/S
-SQUALL/M/S
-SQUARE/P/D/T/R/G/Y/S
-SQUASH/D/G
-SQUAT/S
-SQUAWK/D/G/S
-SQUEAK/D/G/S
-SQUEAL/D/G/S
-SQUEEZE/D/R/G/S
-SQUID
-SQUINT/D/G
-SQUIRE/M/S
-SQUIRM/D/S
-SQUIRREL/D/G/S
-SR
-STAB/Y/S
-STABBED
-STABBING
-STABILITY/M/S
-STABILIZE/D/R/Z/G/S
-STABLE/D/R/G/S
-STACK/D/M/G/S
-STAFF/D/R/Z/G/S
-STAG/M/S
-STAGE/D/R/Z/G/S
-STAGECOACH
-STAGGER/D/G/S
-STAGNANT
-STAID
-STAIN/D/G/S
-STAINLESS
-STAIR/M/S
-STAIRCASE/M/S
-STAIRWAY/M/S
-STAKE/D/S
-STALE
-STALK/D/G
-STALL/D/G/J/S
-STALWART/Y
-STAMEN/M/S
-STAMINA
-STAMMER/D/R/G/S
-STAMP/D/R/Z/G/S
-STAMPEDE/D/G/S
-STANCH/T
-STAND/G/J/S
-STANDARD/Y/S
-STANDARDIZATION
-STANDARDIZE/D/G/S
-STANDBY
-STANDPOINT/M/S
-STANDSTILL
-STANFORD
-STANZA/M/S
-STAPLE/R/G/S
-STAR/M/S
-STARBOARD
-STARCH/D
-STARE/D/R/G/S
-STARFISH
-STARK/Y
-STARLIGHT
-STARRED
-STARRING
-STARRY
-START/D/R/Z/G/S
-STARTLE/D/G/S
-STARTUP/M/S
-STARVATION
-STARVE/D/G/S
-STATE/D/M/G/X/Y/S
-STATEMENT/M/S
-STATESMAN
-STATIC
-STATICALLY
-STATION/D/R/G/S
-STATIONARY
-STATISTIC/S
-STATISTICAL/Y
-STATISTICIAN/M/S
-STATUE/M/S
-STATUESQUE/P/Y
-STATURE
-STATUS/S
-STATUTE/M/S
-STATUTORILY
-STATUTORY/P
-STAUNCH/T/Y
-STAVE/D/S
-STAY/D/G/S
-STEAD
-STEADFAST/P/Y
-STEADILY
-STEADY/P/D/T/R/G/S
-STEAK/M/S
-STEAL/R/G/H/S
-STEALTHILY
-STEALTHY
-STEAM/D/R/Z/G/S
-STEAMBOAT/M/S
-STEAMSHIP/M/S
-STEED
-STEEL/D/Z/G/S
-STEEP/P/D/T/R/G/Y/S
-STEEPLE/M/S
-STEER/D/G/S
-STELLAR
-STEM/M/S
-STEMMED
-STEMMING
-STENCH/M/S
-STENCIL/M/S
-STENOGRAPHER/M/S
-STEP/M/S
-STEPHEN/M
-STEPMOTHER/M/S
-STEPPED
-STEPPING
-STEPWISE
-STEREO/M/S
-STEREOGRAPHIC
-STEREOTYPE/D/S
-STEREOTYPICAL
-STERILE
-STERILIZATION/M/S
-STERILIZE/D/R/G/S
-STERLING
-STERN/P/Y/S
-STEVE/M
-STEW/D/S
-STEWARD/M/S
-STICK/G/R/S/Z
-STICKILY
-STICKY/P/T/R
-STIFF/P/T/R/N/X/Y/S
-STIFLE/D/G/S
-STIGMA
-STILE/M/S
-STILL/P/D/T/R/G/S
-STIMULANT/M/S
-STIMULATE/D/G/N/X/V/S
-STIMULI
-STIMULUS
-STING/G/S
-STINK/R/Z/G/S
-STINT
-STIPEND/M/S
-STIPULATE/D/G/N/X/S
-STIR/S
-STIRRED
-STIRRER/M/S
-STIRRING/Y/S
-STIRRUP
-STITCH/D/G/S
-STOCHASTIC
-STOCHASTICALLY
-STOCK/D/R/Z/G/J/S
-STOCKADE/M/S
-STOCKHOLDER/M/S
-STOLE/M/S
-STOLEN
-STOMACH/D/R/G/S
-STONE/D/G/S
-STONY
-STOOD
-STOOL
-STOOP/D/G/S
-STOP/S
-STOPCOCK/S
-STOPPABLE
-STOPPAGE
-STOPPED
-STOPPER/M/S
-STOPPING
-STORAGE/M/S
-STORE/D/G/S
-STOREHOUSE/M/S
-STORK/M/S
-STORM/D/G/S
-STORMY/P/T/R
-STORY/D/S
-STOUT/P/T/R/Y
-STOVE/M/S
-STOW/D
-STRAGGLE/D/R/Z/G/S
-STRAIGHT/P/T/R/N/X
-STRAIGHTFORWARD/P/Y
-STRAIGHTWAY
-STRAIN/D/R/Z/G/S
-STRAIT/N/S
-STRAND/D/G/S
-STRANGE/P/R/Z/Y
-STRANGEST
-STRANGLE/D/R/Z/G/J/S
-STRANGULATION/M/S
-STRAP/M/S
-STRATAGEM/M/S
-STRATEGIC
-STRATEGY/M/S
-STRATIFY/D/N/X/S
-STRATUM
-STRAW/M/S
-STRAWBERRY/M/S
-STRAY/D/S
-STREAK/D/S
-STREAM/D/R/Z/G/S
-STREAMLINE/D/R/G/S
-STREET/Z/S
-STREETCAR/M/S
-STRENGTH/N
-STRENGTHEN/D/R/G/S
-STRENGTHS
-STRENUOUS/Y
-STRESS/D/G/S
-STRETCH/D/R/Z/G/S
-STREW/S
-STREWN
-STRICT/P/T/R/Y
-STRIDE/R/G/S
-STRIFE
-STRIKE/R/Z/G/S
-STRIKINGLY
-STRING'S
-STRING/D/R/Z/G/S
-STRINGENT/Y
-STRINGY/P/T/R
-STRIP/M/S
-STRIPE/D/S
-STRIPPED
-STRIPPER/M/S
-STRIPPING
-STRIVE/G/J/S
-STRODE
-STROKE/D/R/Z/G/S
-STROLL/D/R/G/S
-STRONG/T/R/Y
-STRONGHOLD
-STROVE
-STRUCK
-STRUCTURAL/Y
-STRUCTURE/D/R/G/S
-STRUGGLE/D/G/S
-STRUNG
-STRUT/S
-STUB/M/S
-STUBBLE
-STUBBORN/P/Y
-STUCK
-STUD/M/S
-STUDENT/M/S
-STUDIO/M/S
-STUDIOUS/Y
-STUDY/D/G/S
-STUFF/D/G/S
-STUFFY/T/R
-STUMBLE/D/G/S
-STUMP/D/G/S
-STUN
-STUNG
-STUNNING/Y
-STUNT/M/S
-STUPEFY/G
-STUPENDOUS/Y
-STUPID/T/Y
-STUPIDITY/S
-STUPOR
-STURDY/P
-STYLE/D/R/Z/G/S
-STYLISH/P/Y
-STYLISTIC
-STYLISTICALLY
-STYLIZED
-SUB/S
-SUBATOMIC
-SUBCLASS/M/S
-SUBCOMPONENT/M/S
-SUBCOMPUTATION/M/S
-SUBCONSCIOUS/Y
-SUBCULTURE/M/S
-SUBDIVIDE/D/G/S
-SUBDIVISION/M/S
-SUBDUE/D/G/S
-SUBEXPRESSION/M/S
-SUBFIELD/M/S
-SUBFILE/M/S
-SUBGOAL/M/S
-SUBGRAPH
-SUBGRAPHS
-SUBGROUP/M/S
-SUBINTERVAL/M/S
-SUBJECT/D/G/V/S
-SUBJECTION
-SUBJECTIVELY
-SUBJECTIVITY
-SUBLIMATION/S
-SUBLIME/D
-SUBLIST/M/S
-SUBMARINE/R/Z/S
-SUBMERGE/D/G/S
-SUBMISSION/M/S
-SUBMIT/S
-SUBMITTED
-SUBMITTING
-SUBMODE/S
-SUBMODULE/M/S
-SUBNETWORK/M/S
-SUBORDINATE/D/N/S
-SUBPROBLEM/M/S
-SUBPROGRAM/M/S
-SUBPROJECT
-SUBPROOF/M/S
-SUBRANGE/M/S
-SUBROUTINE/M/S
-SUBSCHEMA/M/S
-SUBSCRIBE/D/R/Z/G/S
-SUBSCRIPT/D/G/S
-SUBSCRIPTION/M/S
-SUBSECTION/M/S
-SUBSEGMENT/M/S
-SUBSEQUENCE/M/S
-SUBSEQUENT/Y
-SUBSET/M/S
-SUBSIDE/D/G/S
-SUBSIDIARY/M/S
-SUBSIDIZE/D/G/S
-SUBSIDY/M/S
-SUBSIST/D/G/S
-SUBSISTENCE
-SUBSPACE/M/S
-SUBSTANCE/M/S
-SUBSTANTIAL/Y
-SUBSTANTIATE/D/G/N/X/S
-SUBSTANTIVE/Y
-SUBSTANTIVITY
-SUBSTITUTABILITY
-SUBSTITUTABLE
-SUBSTITUTE/D/G/N/X/S
-SUBSTRATE/M/S
-SUBSTRING/S
-SUBSTRUCTURE/M/S
-SUBSUME/D/G/S
-SUBSYSTEM/M/S
-SUBTASK/M/S
-SUBTERRANEAN
-SUBTITLE/S
-SUBTLE/P/T/R
-SUBTLETY/S
-SUBTLY
-SUBTRACT/D/G/S/R/Z
-SUBTRACTER'S
-SUBTRACTION/S
-SUBTRAHEND/M/S
-SUBTREE/M/S
-SUBTYPE/S
-SUBUNIT/M/S
-SUBURB/M/S
-SUBURBAN
-SUBVERSION
-SUBVERT/D/R/G/S
-SUBWAY/M/S
-SUCCEED/D/G/S
-SUCCESS/V/S
-SUCCESSFUL/Y
-SUCCESSION/M/S
-SUCCESSIVELY
-SUCCESSOR/M/S
-SUCCINCT/P/Y
-SUCCOR
-SUCCUMB/D/G/S
-SUCH
-SUCK/D/R/Z/G/S
-SUCKLE/G
-SUCTION
-SUDDEN/P/Y
-SUDS/G
-SUE/D/G/S
-SUFFER/D/R/Z/G/J/S
-SUFFERANCE
-SUFFICE/D/G/S
-SUFFICIENCY
-SUFFICIENT/Y
-SUFFIX/D/R/G/S
-SUFFOCATE/D/G/N/S
-SUFFRAGE
-SUGAR/D/G/J/S
-SUGGEST/D/G/V/S
-SUGGESTIBLE
-SUGGESTION/M/S
-SUGGESTIVELY
-SUICIDAL/Y
-SUICIDE/M/S
-SUIT/M/S
-SUITABILITY
-SUITABLE/P
-SUITABLY
-SUITCASE/M/S
-SUITE/D/Z/G/S
-SUITOR/M/S
-SULK/D/G/S
-SULKY/P
-SULLEN/P/Y
-SULPHATE
-SULPHUR/D
-SULPHURIC
-SULTAN/M/S
-SULTRY
-SUM/M/S
-SUMMAND/M/S
-SUMMARIZATION/M/S
-SUMMARIZE/D/G/S
-SUMMARY/M/S
-SUMMATION/M/S
-SUMMED
-SUMMER/M/S
-SUMMING
-SUMMIT
-SUMMON/D/R/Z/G/S
-SUMMONSES
-SUMPTUOUS
-SUN/M/S
-SUNBEAM/M/S
-SUNBURN
-SUNDAY/M/S
-SUNDOWN
-SUNDRY/S
-SUNG
-SUNGLASS/S
-SUNK/N
-SUNLIGHT
-SUNNED
-SUNNING
-SUNNY
-SUNNYVALE
-SUNRISE
-SUNSET
-SUNSHINE
-SUP/R
-SUPERB/Y
-SUPERCLASS/S
-SUPERCOMPUTER/M/S
-SUPERCOMPUTING
-SUPEREGO/M/S
-SUPERFICIAL/Y
-SUPERFLUITY/M/S
-SUPERFLUOUS/Y
-SUPERHUMAN/Y
-SUPERIMPOSE/D/G/S
-SUPERINTEND
-SUPERINTENDENT/M/S
-SUPERIOR/M/S
-SUPERIORITY
-SUPERLATIVE/Y/S
-SUPERMARKET/M/S
-SUPERPOSE/D/G/S
-SUPERSCRIPT/D/G/S
-SUPERSEDE/D/G/S
-SUPERSET/M/S
-SUPERSTITION/M/S
-SUPERSTITIOUS
-SUPERVISE/D/G/N/S
-SUPERVISOR/M/S
-SUPERVISORY
-SUPPER/M/S
-SUPPLANT/D/G/S
-SUPPLE/P
-SUPPLEMENT/D/G/S
-SUPPLEMENTAL
-SUPPLEMENTARY
-SUPPLY/D/R/Z/G/N/S
-SUPPORT/D/R/Z/G/V/S
-SUPPORTABLE
-SUPPORTINGLY
-SUPPORTIVELY
-SUPPOSE/D/G/S
-SUPPOSEDLY
-SUPPOSITION/M/S
-SUPPRESS/D/G/S
-SUPPRESSION
-SUPREMACY
-SUPREME/Y/P
-SURE/P/Y
-SURETY/S
-SURF
-SURFACE/P/D/G/S
-SURGE/D/G/S
-SURGEON/M/S
-SURGERY
-SURGICAL/Y
-SURLY/P
-SURMISE/D/S
-SURMOUNT/D/G/S
-SURNAME/M/S
-SURPASS/D/G/S
-SURPLUS/M/S
-SURPRISE/D/G/S
-SURPRISINGLY
-SURRENDER/D/G/S
-SURROGATE/M/S
-SURROUND/D/G/J/S
-SURVEY/D/G/S
-SURVEYOR/M/S
-SURVIVAL/S
-SURVIVE/D/G/S
-SURVIVOR/M/S
-SUSCEPTIBLE
-SUSPECT/D/G/S
-SUSPEND/D/G/S
-SUSPENDER/M/S
-SUSPENSE/N/X/S
-SUSPICION/M/S
-SUSPICIOUS/Y
-SUSTAIN/D/G/S
-SUTURE/S
-SUZANNE/M
-SWAGGER/D/G
-SWAIN/M/S
-SWALLOW/D/G/S
-SWAM
-SWAMP/D/G/S
-SWAMPY
-SWAN/M/S
-SWAP/S
-SWAPPED
-SWAPPING
-SWARM/D/G/S
-SWARTHY
-SWATTED
-SWAY/D/G
-SWEAR/R/G/S
-SWEAT/D/R/Z/G/S
-SWEEP/R/Z/G/J/S
-SWEET/P/T/R/X/Y/S
-SWEETEN/D/R/Z/G/J/S
-SWEETHEART/M/S
-SWELL/D/G/J/S
-SWEPT
-SWERVE/D/G/S
-SWIFT/P/T/R/Y
-SWIM/S
-SWIMMER/M/S
-SWIMMING/Y
-SWINE
-SWING/R/Z/G/S
-SWIRL/D/G
-SWISH/D
-SWITCH/D/R/Z/G/J/S
-SWITCHBOARD/M/S
-SWITZERLAND
-SWOLLEN
-SWOON
-SWOOP/D/G/S
-SWORD/M/S
-SWORE
-SWORN
-SWUM
-SWUNG
-SYCAMORE
-SYLLABI
-SYLLABLE/M/S
-SYLLABUS
-SYLLOGISM/M/S
-SYMBIOSIS
-SYMBIOTIC
-SYMBOL/M/S
-SYMBOLIC
-SYMBOLICALLY
-SYMBOLISM
-SYMBOLIZATION
-SYMBOLIZE/D/G/S
-SYMMETRIC
-SYMMETRICAL/Y
-SYMMETRY/M/S
-SYMPATHETIC
-SYMPATHIZE/D/R/Z/G/S
-SYMPATHIZINGLY
-SYMPATHY/M/S
-SYMPHONY/M/S
-SYMPOSIUM/S
-SYMPTOM/M/S
-SYMPTOMATIC
-SYNAPSE/M/S
-SYNCHRONIZATION
-SYNCHRONIZE/D/R/Z/G/S
-SYNCHRONOUS/Y
-SYNCHRONY
-SYNDICATE/D/N/S
-SYNDROME/M/S
-SYNERGISM
-SYNERGISTIC
-SYNONYM/M/S
-SYNONYMOUS/Y
-SYNOPSES
-SYNOPSIS
-SYNTACTIC
-SYNTACTICAL/Y
-SYNTAX
-SYNTHESIS
-SYNTHESIZE/D/R/Z/G/S
-SYNTHETIC/S
-SYRACUSE
-SYRINGE/S
-SYRUP
-SYSTEM/M/S
-SYSTEMATIC
-SYSTEMATICALLY
-SYSTEMATIZE/D/G/S
-SYSTOLIC
-TAB/S
-TABERNACLE/M/S
-TABLE/D/G/S
-TABLEAU/M/S
-TABLECLOTH
-TABLECLOTHS
-TABLESPOON/M/S
-TABLESPOONFUL/M/S
-TABLET/M/S
-TABOO/M/S
-TABULAR
-TABULATE/D/G/N/X/S
-TABULATOR/M/S
-TACHOMETER/M/S
-TACIT/Y
-TACK/D/G
-TACKLE/M/S
-TACT
-TACTICS
-TACTILE
-TAG/M/S
-TAGGED
-TAGGING
-TAIL/D/G/S
-TAILOR/D/G/S
-TAINT/D
-TAIWAN
-TAKE/R/Z/G/J/S
-TAKEN
-TALE/M/S
-TALENT/D/S
-TALK/D/R/Z/G/S
-TALKATIVE/P/Y
-TALKIE
-TALL/P/T/R
-TALLOW
-TAME/P/D/R/G/Y/S
-TAMPER/D/G/S
-TAN
-TANDEM
-TANG
-TANGENT/M/S
-TANGENTIAL
-TANGIBLE
-TANGIBLY
-TANGLE/D
-TANGY
-TANK/R/Z/S
-TANNER/M/S
-TANTALIZING/Y
-TANTAMOUNT
-TANTRUM/M/S
-TAP/M/S
-TAPE/D/R/Z/G/J/S
-TAPERED
-TAPERING
-TAPESTRY/M/S
-TAPPED
-TAPPER/M/S
-TAPPING
-TAPROOT/M/S
-TAR
-TARDY/P
-TARGET/D/G/S
-TARIFF/M/S
-TARRY
-TART/P/Y
-TASK/D/G/S
-TASSEL/M/S
-TASTE/D/R/Z/G/S
-TASTEFUL/P/Y
-TASTELESS/Y
-TASTY
-TATTER/D
-TATTOO/D/S
-TAU
-TAUGHT
-TAUNT/D/R/G/S
-TAUT/P/Y
-TAUTOLOGICAL/Y
-TAUTOLOGY/M/S
-TAVERN/M/S
-TAWNY
-TAX/D/G/S
-TAXABLE
-TAXATION
-TAXI/D/G/S
-TAXICAB/M/S
-TAXONOMIC
-TAXONOMICALLY
-TAXONOMY
-TAXPAYER/M/S
-TEA/S
-TEACH/R/Z/G/J/S
-TEACHABLE
-TEACHER'S
-TEAHOUSE
-TEAM/D/G/S
-TEAR/D/G/S
-TEARFUL/Y
-TEASE/D/G/S
-TEASPOON/M/S
-TEASPOONFUL/M/S
-TECHNICAL/Y
-TECHNICALITY/M/S
-TECHNICIAN/M/S
-TECHNIQUE/M/S
-TECHNOLOGICAL/Y
-TECHNOLOGIST/M/S
-TECHNOLOGY/S
-TEDDY/M
-TEDIOUS/P/Y
-TEDIUM
-TEEM/D/G/S
-TEEN/S
-TEENAGE/D/R/Z
-TEETH
-TEETHE/D/G/S
-TEFLON
-TELECOMMUNICATION/S
-TELEGRAM/M/S
-TELEGRAPH/D/R/Z/G
-TELEGRAPHIC
-TELEGRAPHS
-TELEOLOGICAL/Y
-TELEOLOGY
-TELEPHONE/D/R/Z/G/S
-TELEPHONIC
-TELEPHONY
-TELESCOPE/D/G/S
-TELETYPE/M/S
-TELEVISE/D/G/N/X/S
-TELEVISOR/M/S
-TELL/R/Z/G/S
-TEMPER/D/G/S
-TEMPERAMENT/S
-TEMPERAMENTAL
-TEMPERANCE
-TEMPERATE/P/Y
-TEMPERATURE/M/S
-TEMPEST
-TEMPESTUOUS/Y
-TEMPLATE/M/S
-TEMPLE/M/S
-TEMPORAL/Y
-TEMPORARILY
-TEMPORARY/S
-TEMPT/D/R/Z/G/S
-TEMPTATION/M/S
-TEMPTINGLY
-TEN/H/S
-TENACIOUS/Y
-TENANT/M/S
-TEND/D/R/Z/G/S
-TENDENCY/S
-TENDERLY
-TENDERNESS
-TENEMENT/M/S
-TENNESSEE
-TENNIS
-TENOR/M/S
-TENSE/P/D/T/R/G/N/X/Y/S
-TENSOR
-TENT/D/G/S
-TENTACLE/D/S
-TENTATIVE/Y
-TENURE
-TERM/D/G/S
-TERMINAL/M/Y/S
-TERMINATE/D/G/N/X/S
-TERMINATOR/M/S
-TERMINOLOGY/S
-TERMINUS
-TERMWISE
-TERNARY
-TERRACE/D/S
-TERRAIN/M/S
-TERRESTRIAL
-TERRIBLE
-TERRIBLY
-TERRIER/M/S
-TERRIFIC
-TERRIFY/D/G/S
-TERRITORIAL
-TERRITORY/M/S
-TERROR/M/S
-TERRORISM
-TERRORIST/M/S
-TERRORISTIC
-TERRORIZE/D/G/S
-TERSE
-TERTIARY
-TEST/D/R/Z/G/J/S
-TESTABILITY
-TESTABLE
-TESTAMENT/M/S
-TESTICLE/M/S
-TESTIFY/D/R/Z/G/S
-TESTIMONY/M/S
-TEXAS
-TEXT/M/S
-TEXTBOOK/M/S
-TEXTILE/M/S
-TEXTUAL/Y
-TEXTURE/D/S
-THAN
-THANK/D/G/S
-THANKFUL/P/Y
-THANKLESS/P/Y
-THANKSGIVING
-THAT/M/S
-THATCH/S
-THAW/D/G/S
-THE/G/J
-THEATER/M/S
-THEATRICAL/Y/S
-THEFT/M/S
-THEIR/S
-THEM
-THEMATIC
-THEME/M/S
-THEMSELVES
-THEN
-THENCE
-THENCEFORTH
-THEOLOGICAL
-THEOLOGY
-THEOREM/M/S
-THEORETIC
-THEORETICAL/Y
-THEORETICIANS
-THEORIST/M/S
-THEORIZATION/M/S
-THEORIZE/D/R/Z/G/S
-THEORY/M/S
-THERAPEUTIC
-THERAPIST/M/S
-THERAPY/M/S
-THERE/M
-THEREABOUTS
-THEREAFTER
-THEREBY
-THEREFORE
-THEREIN
-THEREOF
-THEREON
-THERETO
-THEREUPON
-THEREWITH
-THERMAL
-THERMODYNAMIC/S
-THERMOMETER/M/S
-THERMOSTAT/M/S
-THESAURI
-THESE/S
-THESIS
-THETA
-THEY
-THEY'D
-THEY'LL
-THEY'RE
-THEY'VE
-THICK/P/T/R/N/X/Y
-THICKET/M/S
-THIEF
-THIEVE/G/S
-THIGH
-THIGHS
-THIMBLE/M/S
-THIN/P/Y
-THINK/R/Z/G/S
-THINKABLE
-THINKABLY
-THINNER
-THINNEST
-THIRD/Y/S
-THIRST/D/S
-THIRSTY
-THIRTEEN/H/S
-THIRTY/H/S
-THIS
-THISTLE
-THOMAS
-THOMPSON/M
-THONG
-THORN/M/S
-THORNY
-THOROUGH/P/Y
-THOROUGHFARE/M/S
-THOSE
-THOUGH
-THOUGHT/M/S
-THOUGHTFUL/P/Y
-THOUGHTLESS/P/Y
-THOUSAND/H/S
-THRASH/D/R/G/S
-THREAD/D/R/Z/G/S
-THREAT/N/S
-THREATEN/D/G/S
-THREE/M/S
-THREESCORE
-THRESHOLD/M/S
-THREW
-THRICE
-THRIFT
-THRIFTY
-THRILL/D/R/Z/G/S
-THRILLING/Y
-THRIVE/D/G/S
-THROAT/D/S
-THROB/S
-THROBBED
-THROBBING
-THRONE/M/S
-THRONG/M/S
-THROTTLE/D/G/S
-THROUGH
-THROUGHOUT
-THROUGHPUT
-THROW/R/G/S
-THROWN
-THRUSH
-THRUST/R/Z/G/S
-THUD/S
-THUG/M/S
-THUMB/D/G/S
-THUMP/D/G
-THUNDER/D/R/Z/G/S
-THUNDERBOLT/M/S
-THUNDERSTORM/M/S
-THURSDAY/M/S
-THUS/Y
-THWART/D/G
-THYSELF
-TICK/D/R/Z/G/S
-TICKET/M/S
-TICKLE/D/G/S
-TIDAL/Y
-TIDE/D/G/J/S
-TIDY/P/D/G
-TIE/D/R/Z/S
-TIGER/M/S
-TIGHT/P/T/R/X/Y
-TIGHTEN/D/R/Z/G/J/S
-TILDE
-TILE/D/G/S
-TILL/D/R/Z/G/S
-TILLABLE
-TILT/D/G/S
-TIMBER/D/G/S
-TIME/D/R/Z/G/Y/J/S
-TIMESHARING
-TIMETABLE/M/S
-TIMID/Y
-TIMIDITY
-TIN/M/S
-TINGE/D
-TINGLE/D/G/S
-TINILY
-TINKER/D/G/S
-TINKLE/D/G/S
-TINNILY
-TINNY/P/T/R
-TINT/D/G/S
-TINY/P/T/R
-TIP/M/S
-TIPPED
-TIPPER/M/S
-TIPPING
-TIPTOE
-TIRE/D/G/S
-TIREDLY
-TIRELESS/P/Y
-TIRESOME/P/Y
-TISSUE/M/S
-TIT/R/Z/S
-TITHE/R/S
-TITLE/D/S
-TO
-TOAD/M/S
-TOAST/D/R/G/S
-TOBACCO
-TODAY
-TOE/M/S
-TOFU
-TOGETHER/P
-TOGGLE/D/G/S
-TOIL/D/R/G/S
-TOILET/M/S
-TOKEN/M/S
-TOLD
-TOLERABILITY
-TOLERABLE
-TOLERABLY
-TOLERANCE/S
-TOLERANT/Y
-TOLERATE/D/G/N/S
-TOLL/D/S
-TOM/M
-TOMAHAWK/M/S
-TOMATO
-TOMATOES
-TOMB/M/S
-TOMOGRAPHY
-TOMORROW
-TON/M/S
-TONAL
-TONE/D/R/G/S
-TONGS
-TONGUE/D/S
-TONIC/M/S
-TONIGHT
-TONNAGE
-TONSIL
-TOO/H
-TOOK
-TOOL/D/R/Z/G/S
-TOOLKIT/S
-TOOTHBRUSH/M/S
-TOOTHPICK/M/S
-TOP/R/S
-TOPIC/M/S
-TOPICAL/Y
-TOPMOST
-TOPOGRAPHIC
-TOPOGRAPHICAL
-TOPOLOGIC
-TOPOLOGICAL
-TOPOLOGY/S
-TOPPLE/D/G/S
-TORCH/M/S
-TORE
-TORMENT/D/R/Z/G
-TORN
-TORNADO/S
-TORNADOES
-TORPEDO/S
-TORPEDOES
-TORQUE
-TORRENT/M/S
-TORRID
-TORTOISE/M/S
-TORTURE/D/R/Z/G/S
-TORUS/M/S
-TOSS/D/G/S
-TOTAL/D/G/Y/S/R/Z/M
-TOTALER'S
-TOTALITY/M/S
-TOTALLED
-TOTALLER/S/M
-TOTALLING
-TOTTER/D/G/S
-TOUCH/D/G/S
-TOUCHABLE
-TOUCHILY
-TOUCHINGLY
-TOUCHY/P/T/R
-TOUGH/P/T/R/N/Y
-TOUR/D/G/S
-TOURETZKY/M
-TOURISM
-TOURIST/M/S
-TOURNAMENT/M/S
-TOW/D/Z
-TOWARD/S
-TOWEL/G/S/D/M
-TOWELLED
-TOWELLING
-TOWER/D/G/S
-TOWN/M/S
-TOWNSHIP/M/S
-TOY/D/G/S
-TRACE/D/R/Z/G/J/S
-TRACEABLE
-TRACK/D/R/Z/G/S
-TRACT/M/V/S
-TRACTABILITY
-TRACTABLE
-TRACTOR/M/S
-TRADE/D/R/Z/G/S
-TRADEMARK/M/S
-TRADESMAN
-TRADITION/M/S
-TRADITIONAL/Y
-TRAFFIC/M/S
-TRAFFICKED
-TRAFFICKER/M/S
-TRAFFICKING
-TRAGEDY/M/S
-TRAGIC
-TRAGICALLY
-TRAIL/D/R/Z/G/J/S
-TRAIN/D/R/Z/G/S
-TRAINABLE
-TRAINEE/M/S
-TRAIT/M/S
-TRAITOR/M/S
-TRAJECTORY/M/S
-TRAMP/D/G/S
-TRAMPLE/D/R/G/S
-TRANCE/M/S
-TRANQUIL/Y
-TRANQUILITY
-TRANQUILLITY
-TRANSACT
-TRANSACTION/M/S
-TRANSCEND/D/G/S
-TRANSCENDENT
-TRANSCONTINENTAL
-TRANSCRIBE/D/R/Z/G/S
-TRANSCRIPT/M/S
-TRANSCRIPTION/M/S
-TRANSFER/M/S/D/G
-TRANSFERABLE
-TRANSFERAL/M/S
-TRANSFERRAL/M/S
-TRANSFERRED
-TRANSFERRER/M/S
-TRANSFERRING
-TRANSFINITE
-TRANSFORM/D/G/S
-TRANSFORMABLE
-TRANSFORMATION/M/S
-TRANSFORMATIONAL
-TRANSGRESS/D
-TRANSGRESSION/M/S
-TRANSIENT/Y/S
-TRANSISTOR/M/S
-TRANSIT
-TRANSITION/D/S
-TRANSITIONAL
-TRANSITIVE/P/Y
-TRANSITIVITY
-TRANSITORY
-TRANSLATABILITY
-TRANSLATABLE
-TRANSLATE/D/G/N/X/S
-TRANSLATIONAL
-TRANSLATOR/M/S
-TRANSLITERATE/N/D/G
-TRANSLUCENT
-TRANSMISSION/M/S
-TRANSMIT/S
-TRANSMITTAL
-TRANSMITTED
-TRANSMITTER/M/S
-TRANSMITTING
-TRANSMOGRIFY/N
-TRANSPARENCY/M/S
-TRANSPARENT/Y
-TRANSPIRE/D/G/S
-TRANSPLANT/D/G/S
-TRANSPORT/D/R/Z/G/S
-TRANSPORTABILITY
-TRANSPORTATION
-TRANSPOSE/D/G/S
-TRANSPOSITION
-TRAP/M/S
-TRAPEZOID/M/S
-TRAPEZOIDAL
-TRAPPED
-TRAPPER/M/S
-TRAPPING/S
-TRASH
-TRAUMA
-TRAUMATIC
-TRAVAIL
-TRAVEL/D/R/Z/G/J/S
-TRAVERSAL/M/S
-TRAVERSE/D/G/S
-TRAVESTY/M/S
-TRAY/M/S
-TREACHEROUS/Y
-TREACHERY/M/S
-TREAD/G/S
-TREASON
-TREASURE/D/R/G/S
-TREASURY/M/S
-TREAT/D/G/S
-TREATISE/M/S
-TREATMENT/M/S
-TREATY/M/S
-TREBLE
-TREE/M/S
-TREETOP/M/S
-TREK/M/S
-TREMBLE/D/G/S
-TREMENDOUS/Y
-TREMOR/M/S
-TRENCH/R/S
-TREND/G/S
-TRESPASS/D/R/Z/S
-TRESS/M/S
-TRIAL/M/S
-TRIANGLE/M/S
-TRIANGULAR/Y
-TRIBAL
-TRIBE/M/S
-TRIBUNAL/M/S
-TRIBUNE/M/S
-TRIBUTARY
-TRIBUTE/M/S
-TRICHOTOMY
-TRICK/D/G/S
-TRICKLE/D/G/S
-TRICKY/P/T/R
-TRIFLE/R/G/S
-TRIGGER/D/G/S
-TRIGONOMETRIC
-TRIGONOMETRY
-TRIHEDRAL
-TRILL/D
-TRILLION/H/S
-TRIM/P/Y/S
-TRIMMED
-TRIMMER
-TRIMMEST
-TRIMMING/S
-TRINKET/M/S
-TRIP/M/S
-TRIPLE/D/G/S
-TRIPLET/M/S
-TRIUMPH/D/G
-TRIUMPHAL
-TRIUMPHANTLY
-TRIUMPHS
-TRIVIA
-TRIVIAL/Y
-TRIVIALITY/S
-TROD
-TROLL/M/S
-TROLLEY/M/S
-TROOP/R/Z/S
-TROPHY/M/S
-TROPIC/M/S
-TROPICAL
-TROT/S
-TROUBLE/D/G/S
-TROUBLEMAKER/M/S
-TROUBLESHOOT/R/Z/G/S
-TROUBLESOME/Y
-TROUGH
-TROUSER/S
-TROUT
-TROWEL/M/S
-TRUANT/M/S
-TRUCE
-TRUCK/D/R/Z/G/S
-TRUDGE/D
-TRUE/D/T/R/G/S
-TRUISM/M/S
-TRULY
-TRUMP/D/S
-TRUMPET/R
-TRUNCATE/D/G/S
-TRUNCATION/M/S
-TRUNK/M/S
-TRUST/D/G/S
-TRUSTEE/M/S
-TRUSTFUL/P/Y
-TRUSTINGLY
-TRUSTWORTHY/P
-TRUSTY
-TRUTH
-TRUTHFUL/P/Y
-TRUTHS
-TRY/D/R/Z/G/S
-TUB/M/S
-TUBE/R/Z/G/S
-TUBERCULOSIS
-TUCK/D/R/G/S
-TUESDAY/M/S
-TUFT/M/S
-TUG/S
-TUITION
-TULIP/M/S
-TUMBLE/D/R/Z/G/S
-TUMOR/S
-TUMULT/M/S
-TUMULTUOUS
-TUNABLE
-TUNE/D/R/Z/G/S
-TUNIC/M/S
-TUNNEL/D/S
-TUPLE/M/S
-TURBAN/M/S
-TURBO
-TURBULENT/Y
-TURF
-TURING
-TURKEY/M/S
-TURMOIL/M/S
-TURN/D/R/Z/G/J/S
-TURNABLE
-TURNIP/M/S
-TURNOVER
-TURPENTINE
-TURQUOISE
-TURRET/M/S
-TURTLE/M/S
-TUTOR/D/G/S
-TUTORIAL/M/S
-TV
-TWAIN
-TWANG
-TWAS
-TWEED
-TWELFTH
-TWELVE/S
-TWENTY/H/S
-TWICE
-TWIG/M/S
-TWILIGHT/M/S
-TWILL
-TWIN/M/S
-TWINE/D/R
-TWINKLE/D/R/G/S
-TWIRL/D/R/G/S
-TWIST/D/R/Z/G/S
-TWITCH/D/G
-TWITTER/D/G
-TWO/M/S
-TWOFOLD
-TYING
-TYPE/D/M/G/S
-TYPECHECK/G/S/R
-TYPEOUT
-TYPESCRIPT/S
-TYPEWRITER/M/S
-TYPHOID
-TYPICAL/P/Y
-TYPIFY/D/G/S
-TYPIST/M/S
-TYPOGRAPHICAL/Y
-TYPOGRAPHY
-TYRANNY
-TYRANT/M/S
-UBIQUITOUS/Y
-UBIQUITY
-UGH
-UGLY/P/T/R
-UIMS
-ULCER/M/S
-ULTIMATE/Y
-UMBRELLA/M/S
-UMPIRE/M/S
-UNABATED
-UNABBREVIATED
-UNABLE
-UNACCEPTABILITY
-UNACCEPTABLE
-UNACCEPTABLY
-UNACCUSTOMED
-UNACKNOWLEDGED
-UNADULTERATED
-UNAESTHETICALLY
-UNAFFECTED/P/Y
-UNAIDED
-UNALIENABILITY
-UNALIENABLE
-UNALTERABLY
-UNALTERED
-UNAMBIGUOUS/Y
-UNAMBITIOUS
-UNANALYZABLE
-UNANIMOUS/Y
-UNANSWERED
-UNANTICIPATED
-UNARMED
-UNARY
-UNASSAILABLE
-UNASSIGNED
-UNATTAINABILITY
-UNATTAINABLE
-UNATTENDED
-UNATTRACTIVE/Y
-UNAUTHORIZED
-UNAVAILABILITY
-UNAVAILABLE
-UNAVOIDABLE
-UNAVOIDABLY
-UNAWARE/P/S
-UNBALANCED
-UNBEARABLE
-UNBELIEVABLE
-UNBIASED
-UNBLOCK/D/G/S
-UNBORN
-UNBOUND/D
-UNBREAKABLE
-UNBROKEN
-UNBUFFERED
-UNCANCELED
-UNCANCELLED
-UNCANNY
-UNCAPITALIZED
-UNCAUGHT
-UNCERTAIN/Y
-UNCERTAINTY/S
-UNCHANGEABLE
-UNCHANGED
-UNCHANGING
-UNCHARTED
-UNCLAIMED
-UNCLE/M/S
-UNCLEAN/P/Y
-UNCLEAR/D
-UNCLOSED
-UNCOMFORTABLE
-UNCOMFORTABLY
-UNCOMMITTED
-UNCOMMON/Y
-UNCOMPROMISING
-UNCOMPUTABLE
-UNCONCERNED/Y
-UNCONDITIONAL/Y
-UNCONNECTED
-UNCONSCIOUS/P/Y
-UNCONSTRAINED
-UNCONTROLLABILITY
-UNCONTROLLABLE
-UNCONTROLLABLY
-UNCONTROLLED
-UNCONVENTIONAL/Y
-UNCONVINCED
-UNCONVINCING
-UNCORRECTABLE
-UNCORRECTED
-UNCOUNTABLE
-UNCOUNTABLY
-UNCOUTH
-UNCOVER/D/G/S
-UNDAUNTED/Y
-UNDECIDABLE
-UNDECIDED
-UNDECLARED
-UNDECOMPOSABLE
-UNDEFINABILITY
-UNDEFINED
-UNDELETE
-UNDELETED
-UNDENIABLY
-UNDER
-UNDERBRUSH
-UNDERDONE
-UNDERESTIMATE/D/G/N/S
-UNDERFLOW/D/G/S
-UNDERFOOT
-UNDERGO/G
-UNDERGOES
-UNDERGONE
-UNDERGRADUATE/M/S
-UNDERGROUND
-UNDERLIE/S
-UNDERLINE/D/G/J/S
-UNDERLING/M/S
-UNDERLYING
-UNDERMINE/D/G/S
-UNDERNEATH
-UNDERPINNING/S
-UNDERPLAY/D/G/S
-UNDERSCORE/D/S
-UNDERSTAND/G/J/S
-UNDERSTANDABILITY
-UNDERSTANDABLE
-UNDERSTANDABLY
-UNDERSTANDINGLY
-UNDERSTATED
-UNDERSTOOD
-UNDERTAKE/R/Z/G/J/S
-UNDERTAKEN
-UNDERTOOK
-UNDERWAY
-UNDERWEAR
-UNDERWENT
-UNDERWORLD
-UNDERWRITE/R/Z/G/S
-UNDESIRABILITY
-UNDESIRABLE
-UNDETECTABLE
-UNDETECTED
-UNDETERMINED
-UNDEVELOPED
-UNDID
-UNDIRECTED
-UNDISCIPLINED
-UNDISCOVERED
-UNDISTORTED
-UNDISTURBED
-UNDIVIDED
-UNDO/G/J
-UNDOCUMENTED
-UNDOES
-UNDONE
-UNDOUBTEDLY
-UNDRESS/D/G/S
-UNDUE
-UNDULY
-UNEASILY
-UNEASY/P
-UNECONOMICAL
-UNEMBELLISHED
-UNEMPLOYED
-UNEMPLOYMENT
-UNENDING
-UNENLIGHTENING
-UNEQUAL/D/Y
-UNEQUIVOCAL/Y
-UNESSENTIAL
-UNEVALUATED
-UNEVEN/P/Y
-UNEVENTFUL
-UNEXCUSED
-UNEXPANDED
-UNEXPECTED/Y
-UNEXPLAINED
-UNEXPLORED
-UNEXTENDED
-UNFAIR/P/Y
-UNFAITHFUL/P/Y
-UNFAMILIAR/Y
-UNFAMILIARITY
-UNFAVORABLE
-UNFETTERED
-UNFINISHED
-UNFIT/P
-UNFLAGGING
-UNFOLD/D/G/S
-UNFORESEEN
-UNFORGEABLE
-UNFORGIVING
-UNFORMATTED
-UNFORTUNATE/Y/S
-UNFOUNDED
-UNFRIENDLY/P
-UNFULFILLED
-UNGRAMMATICAL
-UNGRATEFUL/P/Y
-UNGROUNDED
-UNGUARDED
-UNGUIDED
-UNHAPPILY
-UNHAPPY/P/T/R
-UNHEALTHY
-UNHEEDED
-UNICORN/M/S
-UNIDENTIFIED
-UNIDIRECTIONAL/Y
-UNIDIRECTIONALITY
-UNIFORM/D/Y/S
-UNIFORMITY
-UNIFY/D/R/Z/G/N/X/S
-UNILATERAL
-UNILLUMINATING
-UNIMAGINABLE
-UNIMPEDED
-UNIMPLEMENTED
-UNIMPORTANT
-UNINDENTED
-UNINFORMED
-UNINITIALIZED
-UNINTELLIGIBLE
-UNINTENDED
-UNINTENTIONAL/Y
-UNINTERESTING/Y
-UNINTERPRETED
-UNINTERRUPTED/Y
-UNION/M/S
-UNIONIZATION
-UNIONIZE/D/R/Z/G/S
-UNIQUE/P/Y
-UNISON
-UNIT/M/S
-UNITE/D/G/S
-UNITY/M/S
-UNIVALVE/M/S
-UNIVERSAL/Y/S
-UNIVERSALITY
-UNIVERSE/M/S
-UNIVERSITY/M/S
-UNIX
-UNJUST/Y
-UNJUSTIFIED
-UNKIND/P/Y
-UNKNOWABLE
-UNKNOWING/Y
-UNKNOWN/S
-UNLABELED
-UNLAWFUL/Y
-UNLEASH/D/G/S
-UNLESS
-UNLIKE/P/Y
-UNLIMITED
-UNLINK/D/G/S
-UNLOAD/D/G/S
-UNLOCK/D/G/S
-UNLUCKY
-UNMANAGEABLE
-UNMANAGEABLY
-UNMANNED
-UNMARKED
-UNMARRIED
-UNMASKED
-UNMATCHED
-UNMISTAKABLE
-UNMODIFIED
-UNMOVED
-UNNAMED
-UNNATURAL/P/Y
-UNNECESSARILY
-UNNECESSARY
-UNNEEDED
-UNNOTICED
-UNOBSERVABLE
-UNOBSERVED
-UNOBTAINABLE
-UNOCCUPIED
-UNOFFICIAL/Y
-UNOPENED
-UNOPTIMIZED
-UNORDERED
-UNPACK/D/G/S
-UNPARALLELED
-UNPARSED
-UNPLANNED
-UNPLEASANT/P/Y
-UNPOPULAR
-UNPOPULARITY
-UNPRECEDENTED
-UNPREDICTABLE
-UNPRESCRIBED
-UNPRESERVED
-UNPRIMED
-UNPROFITABLE
-UNPROJECTED
-UNPROTECTED
-UNPROVABILITY
-UNPROVABLE
-UNPROVEN
-UNPUBLISHED
-UNQUALIFIED/Y
-UNQUESTIONABLY
-UNQUESTIONED
-UNQUOTED
-UNRAVEL/D/G/S
-UNREACHABLE
-UNREADABLE
-UNREAL
-UNREALISTIC
-UNREALISTICALLY
-UNREASONABLE/P
-UNREASONABLY
-UNRECOGNIZABLE
-UNRECOGNIZED
-UNRELATED
-UNRELIABILITY
-UNRELIABLE
-UNREPORTED
-UNREPRESENTABLE
-UNRESOLVED
-UNRESPONSIVE
-UNREST
-UNRESTRAINED
-UNRESTRICTED/Y
-UNRESTRICTIVE
-UNROLL/D/G/S
-UNRULY
-UNSAFE/Y
-UNSANITARY
-UNSATISFACTORY
-UNSATISFIABILITY
-UNSATISFIABLE
-UNSATISFIED
-UNSATISFYING
-UNSCRUPULOUS
-UNSEEDED
-UNSEEN
-UNSELECTED
-UNSELFISH/P/Y
-UNSENT
-UNSETTLED
-UNSETTLING
-UNSHAKEN
-UNSHARED
-UNSIGNED
-UNSKILLED
-UNSOLVABLE
-UNSOLVED
-UNSOPHISTICATED
-UNSOUND
-UNSPEAKABLE
-UNSPECIFIED
-UNSTABLE
-UNSTEADY/P
-UNSTRUCTURED
-UNSUCCESSFUL/Y
-UNSUITABLE
-UNSUITED
-UNSUPPORTED
-UNSURE
-UNSURPRISING/Y
-UNSYNCHRONIZED
-UNTAPPED
-UNTERMINATED
-UNTESTED
-UNTHINKABLE
-UNTIDY/P
-UNTIE/D/S
-UNTIL
-UNTIMELY
-UNTO
-UNTOLD
-UNTOUCHABLE/M/S
-UNTOUCHED
-UNTOWARD
-UNTRAINED
-UNTRANSLATED
-UNTREATED
-UNTRIED
-UNTRUE
-UNTRUTHFUL/P
-UNTYING
-UNUSABLE
-UNUSED
-UNUSUAL/Y
-UNVARYING
-UNVEIL/D/G/S
-UNWANTED
-UNWELCOME
-UNWHOLESOME
-UNWIELDY/P
-UNWILLING/P/Y
-UNWIND/R/Z/G/S
-UNWISE/Y
-UNWITTING/Y
-UNWORTHY/P
-UNWOUND
-UNWRITTEN
-UP
-UPBRAID
-UPDATE/D/R/G/S
-UPGRADE/D/G/S
-UPHELD
-UPHILL
-UPHOLD/R/Z/G/S
-UPHOLSTER/D/R/G/S
-UPKEEP
-UPLAND/S
-UPLIFT
-UPON
-UPPER
-UPPERMOST
-UPRIGHT/P/Y
-UPRISING/M/S
-UPROAR
-UPROOT/D/G/S
-UPSET/S
-UPSHOT/M/S
-UPSIDE
-UPSTAIRS
-UPSTREAM
-UPTURN/D/G/S
-UPWARD/S
-URBAN
-URBANA
-URCHIN/M/S
-URGE/D/G/J/S
-URGENT/Y
-URINATE/D/G/N/S
-URINE
-URN/M/S
-US
-USA
-USABILITY
-USABLE
-USABLY
-USAGE/S
-USE/D/R/Z/G/S
-USEFUL/P/Y
-USELESS/P/Y
-USENIX
-USER'S
-USHER/D/G/S
-USUAL/Y
-USURP/D/R
-UTAH
-UTENSIL/M/S
-UTILITY/M/S
-UTILIZATION/M/S
-UTILIZE/D/G/S
-UTMOST
-UTOPIAN/M/S
-UTTER/D/G/Y/S
-UTTERANCE/M/S
-UTTERMOST
-UUCP
-UZI
-VACANCY/M/S
-VACANT/Y
-VACATE/D/G/X/S
-VACATION/D/R/Z/G/S
-VACUO
-VACUOUS/Y
-VACUUM/D/G
-VAGABOND/M/S
-VAGARY/M/S
-VAGINA/M/S
-VAGRANT/Y
-VAGUE/P/T/R/Y
-VAINLY
-VALE/M/S
-VALENCE/M/S
-VALENTINE/M/S
-VALET/M/S
-VALIANT/Y
-VALID/P/Y
-VALIDATE/D/G/N/S
-VALIDITY
-VALLEY/M/S
-VALOR
-VALUABLE/S
-VALUABLY
-VALUATION/M/S
-VALUE/D/R/Z/G/S
-VALVE/M/S
-VAN/M/S
-VANCOUVER
-VANDALIZE/D/G/S
-VANE/M/S
-VANILLA
-VANISH/D/R/G/S
-VANISHINGLY
-VANITY/S
-VANQUISH/D/G/S
-VANTAGE
-VAPOR/G/S
-VARIABILITY
-VARIABLE/P/M/S
-VARIABLY
-VARIANCE/M/S
-VARIANT/Y/S
-VARIATION/M/S
-VARIETY/M/S
-VARIOUS/Y
-VARNISH/M/S
-VARY/D/G/J/S
-VASE/M/S
-VASSAL
-VAST/P/T/R/Y
-VAT/M/S
-VAUDEVILLE
-VAULT/D/R/G/S
-VAUNT/D
-VAX
-VAXEN
-VAXES
-VEAL
-VECTOR/M/S
-VECTORIZATION
-VECTORIZING
-VEE
-VEER/D/G/S
-VEGAS
-VEGETABLE/M/S
-VEGETARIAN/M/S
-VEGETATE/D/G/N/V/S
-VEHEMENCE
-VEHEMENT/Y
-VEHICLE/M/S
-VEHICULAR
-VEIL/D/G/S
-VEIN/D/G/S
-VELOCITY/M/S
-VELVET
-VENDOR/M/S
-VENERABLE
-VENGEANCE
-VENISON
-VENOM
-VENOMOUS/Y
-VENT/D/S
-VENTILATE/D/G/N/S
-VENTRICLE/M/S
-VENTURE/D/R/Z/G/J/S
-VERACITY
-VERANDA/M/S
-VERB/M/S
-VERBAL/Y
-VERBATIM
-VERBOSE
-VERBOSITY
-VERDICT
-VERDURE
-VERGE/R/S
-VERIFIABILITY
-VERIFIABLE
-VERIFY/D/R/Z/G/N/X/S
-VERILY
-VERITABLE
-VERMIN
-VERNACULAR
-VERSA
-VERSATILE
-VERSATILITY
-VERSE/D/G/N/X/S
-VERSUS
-VERTEBRATE/M/S
-VERTEX
-VERTICAL/P/Y
-VERTICES
-VERY
-VESSEL/M/S
-VEST/D/S
-VESTIGE/M/S
-VESTIGIAL
-VETERAN/M/S
-VETERINARIAN/M/S
-VETERINARY
-VETO/D/R
-VETOES
-VEX/D/G/S
-VEXATION
-VIA
-VIABILITY
-VIABLE
-VIABLY
-VIAL/M/S
-VIBRATE/D/G/N/X
-VICE/M/S
-VICEROY
-VICINITY
-VICIOUS/P/Y
-VICISSITUDE/M/S
-VICTIM/M/S
-VICTIMIZE/D/R/Z/G/S
-VICTOR/M/S
-VICTORIA
-VICTORIOUS/Y
-VICTORY/M/S
-VICTUAL/R/S
-VIDEO
-VIDEOTAPE/M/S
-VIE/D/R/S
-VIEW/D/R/Z/G/S
-VIEWABLE
-VIEWPOINT/M/S
-VIEWPORT/S
-VIGILANCE
-VIGILANT/Y
-VIGILANTE/M/S
-VIGNETTE/M/S
-VIGOR
-VIGOROUS/Y
-VILE/P/Y
-VILIFY/D/G/N/X/S
-VILLA/M/S
-VILLAGE/R/Z/S
-VILLAIN/M/S
-VILLAINOUS/P/Y
-VILLAINY
-VINDICTIVE/P/Y
-VINE/M/S
-VINEGAR
-VINEYARD/M/S
-VINTAGE
-VIOLATE/D/G/N/X/S
-VIOLATOR/M/S
-VIOLENCE
-VIOLENT/Y
-VIOLET/M/S
-VIOLIN/M/S
-VIOLINIST/M/S
-VIPER/M/S
-VIRGIN/M/S
-VIRGINIA
-VIRGINITY
-VIRTUAL/Y
-VIRTUE/M/S
-VIRTUOSO/M/S
-VIRTUOUS/Y
-VIRUS/M/S
-VISA/S
-VISAGE
-VISCOUNT/M/S
-VISCOUS
-VISIBILITY
-VISIBLE
-VISIBLY
-VISION/M/S
-VISIONARY
-VISIT/D/G/S
-VISITATION/M/S
-VISITOR/M/S
-VISOR/M/S
-VISTA/M/S
-VISUAL/Y
-VISUALIZATION
-VISUALIZE/D/R/G/S
-VITA
-VITAE
-VITAL/Y/S
-VITALITY
-VIVID/P/Y
-VIZIER
-VLSI
-VMS
-VOCABULARY/S
-VOCAL/Y/S
-VOCATION/M/S
-VOCATIONAL/Y
-VOGUE
-VOICE/D/R/Z/G/S
-VOID/D/R/G/S
-VOLATILE
-VOLATILITY/S
-VOLCANIC
-VOLCANO/M/S
-VOLLEY
-VOLLEYBALL/M/S
-VOLT/S
-VOLTAGE/S
-VOLUME/M/S
-VOLUNTARILY
-VOLUNTARY
-VOLUNTEER/D/G/S
-VOMIT/D/G/S
-VON
-VOTE/D/R/Z/G/V/S
-VOUCH/R/Z/G/S
-VOW/D/R/G/S
-VOWEL/M/S
-VOYAGE/D/R/Z/G/J/S
-VS
-VULGAR/Y
-VULNERABILITY/S
-VULNERABLE
-VULTURE/M/S
-WADE/D/R/G/S
-WAFER/M/S
-WAFFLE/M/S
-WAFT
-WAG/S
-WAGE/D/R/Z/G/S
-WAGON/R/S
-WAIL/D/G/S
-WAIST/M/S
-WAISTCOAT/M/S
-WAIT/D/R/Z/G/S
-WAITRESS/M/S
-WAIVE/D/R/G/S
-WAIVERABLE
-WAKE/D/G/S
-WAKEN/D/G
-WALK/D/R/Z/G/S
-WALL/D/G/S
-WALLET/M/S
-WALLOW/D/G/S
-WALNUT/M/S
-WALRUS/M/S
-WALTZ/D/G/S
-WAN/Y
-WAND/Z
-WANDER/D/R/Z/G/J/S
-WANE/D/G/S
-WANG
-WANT/D/G/S
-WANTON/P/Y
-WAR/M/S
-WARBLE/D/R/G/S
-WARD/R/N/X/S
-WARDROBE/M/S
-WARE/S
-WAREHOUSE/G/S
-WARFARE
-WARILY
-WARLIKE
-WARM/D/T/G/H/Y/S
-WARMER/S
-WARN/D/R/G/J/S
-WARNINGLY
-WARP/D/G/S
-WARRANT/D/G/S
-WARRANTY/M/S
-WARRED
-WARRING
-WARRIOR/M/S
-WARSHIP/M/S
-WART/M/S
-WARY/P
-WAS
-WASH/D/R/Z/G/J/S
-WASHINGTON
-WASN'T
-WASP/M/S
-WASTE/D/G/S
-WASTEFUL/P/Y
-WATCH/D/R/Z/G/J/S
-WATCHFUL/P/Y
-WATCHMAN
-WATCHWORD/M/S
-WATER/D/G/J/S
-WATERFALL/M/S
-WATERMELON
-WATERPROOF/G
-WATERWAY/M/S
-WATERY
-WAVE/D/R/Z/G/S
-WAVEFORM/M/S
-WAVEFRONT/M/S
-WAVELENGTH
-WAVELENGTHS
-WAX/D/R/Z/G/N/S
-WAXY
-WAY/M/S
-WAYSIDE
-WAYWARD
-WE'D
-WE'LL
-WE'RE
-WE'VE
-WE/T
-WEAK/T/R/N/X/Y
-WEAKEN/D/G/S
-WEAKNESS/M/S
-WEALTH
-WEALTHS
-WEALTHY/T
-WEAN/D/G
-WEAPON/M/S
-WEAR/R/G/S
-WEARABLE
-WEARILY
-WEARISOME/Y
-WEARY/P/D/T/R/G
-WEASEL/M/S
-WEATHER/D/G/S
-WEATHERCOCK/M/S
-WEAVE/R/G/S
-WEB/M/S
-WED/S
-WEDDED
-WEDDING/M/S
-WEDGE/D/G/S
-WEDNESDAY/M/S
-WEE/D
-WEEDS
-WEEK/Y/S
-WEEKEND/M/S
-WEEP/G/R/S/Z
-WEIGH/D/G/J
-WEIGHS
-WEIGHT/D/G/S
-WEIRD/Y
-WELCOME/D/G/S
-WELD/D/R/G/S
-WELFARE
-WELL/D/G/S
-WENCH/M/S
-WENT
-WEPT
-WERE
-WEREN'T
-WESLEY
-WESTERN/R/Z
-WESTWARD/S
-WET/P/Y/S
-WETTED
-WETTER
-WETTEST
-WETTING
-WHACK/D/G/S
-WHALE/R/G/S
-WHARF
-WHARVES
-WHAT/M
-WHATEVER
-WHATSOEVER
-WHEAT/N
-WHEEL/D/R/Z/G/J/S
-WHELP
-WHEN
-WHENCE
-WHENEVER
-WHERE/M
-WHEREABOUTS
-WHEREAS
-WHEREBY
-WHEREIN
-WHEREUPON
-WHEREVER
-WHETHER
-WHICH
-WHICHEVER
-WHILE
-WHIM/M/S
-WHIMPER/D/G/S
-WHIMSICAL/Y
-WHIMSY/M/S
-WHINE/D/G/S
-WHIP/M/S
-WHIPPED
-WHIPPER/M/S
-WHIPPING/M/S
-WHIRL/D/G/S
-WHIRLPOOL/M/S
-WHIRLWIND
-WHIRR/G
-WHISK/D/R/Z/G/S
-WHISKEY
-WHISPER/D/G/J/S
-WHISTLE/D/R/Z/G/S
-WHIT/X
-WHITE/P/T/R/G/Y/S
-WHITEN/D/R/Z/G/S
-WHITESPACE
-WHITEWASH/D
-WHITTLE/D/G/S
-WHIZ
-WHIZZED
-WHIZZES
-WHIZZING
-WHO/M
-WHOEVER
-WHOLE/P/S
-WHOLEHEARTED/Y
-WHOLESALE/R/Z
-WHOLESOME/P
-WHOLLY
-WHOM
-WHOMEVER
-WHOOP/D/G/S
-WHORE/M/S
-WHORL/M/S
-WHOSE
-WHY
-WICK/D/R/S
-WICKED/P/Y
-WIDE/T/R/Y
-WIDEN/D/R/G/S
-WIDESPREAD
-WIDOW/D/R/Z/S
-WIDTH
-WIDTHS
-WIELD/D/R/G/S
-WIFE/M/Y
-WIG/M/S
-WIGWAM
-WILD/P/T/R/Y
-WILDCARD/S
-WILDCAT/M/S
-WILDERNESS
-WILDLIFE
-WILE/S
-WILL/D/G/S
-WILLFUL/Y
-WILLIAM/M
-WILLINGLY
-WILLINGNESS
-WILLOW/M/S
-WILT/D/G/S
-WILY/P
-WIN/S
-WINCE/D/G/S
-WIND/D/R/Z/G/S
-WINDMILL/M/S
-WINDOW/M/S
-WINDY
-WINE/D/R/Z/G/S
-WING/D/G/S
-WINK/D/R/G/S
-WINNER/M/S
-WINNING/Y/S
-WINTER/D/G/S
-WINTRY
-WIPE/D/R/Z/G/S
-WIRE/D/G/S
-WIRELESS
-WIRETAP/M/S
-WIRY/P
-WISCONSIN
-WISDOM/S
-WISE/D/T/R/Y
-WISH/D/R/Z/G/S
-WISHFUL
-WISP/M/S
-WISTFUL/P/Y
-WIT/M/S
-WITCH/G/S
-WITCHCRAFT
-WITH/R/Z
-WITHAL
-WITHDRAW/G/S
-WITHDRAWAL/M/S
-WITHDRAWN
-WITHDREW
-WITHHELD
-WITHHOLD/R/Z/G/J/S
-WITHIN
-WITHOUT
-WITHSTAND/G/S
-WITHSTOOD
-WITNESS/D/G/S
-WITTY
-WIVES
-WIZARD/M/S
-WOE
-WOEFUL/Y
-WOKE
-WOLF
-WOLVES
-WOMAN/M/Y
-WOMANHOOD
-WOMB/M/S
-WOMEN/M
-WON
-WON'T
-WONDER/D/G/S
-WONDERFUL/P/Y
-WONDERINGLY
-WONDERMENT
-WONDROUS/Y
-WONT/D
-WOO/D/R/G/S
-WOOD/D/N/S
-WOODCHUCK/M/S
-WOODCOCK/M/S
-WOODENLY
-WOODENNESS
-WOODLAND
-WOODMAN
-WOODPECKER/M/S
-WOODWORK/G
-WOODY
-WOOF/D/R/Z/G/S
-WOOL/N/Y/S
-WORD/D/M/G/S
-WORDILY
-WORDY/P
-WORE
-WORK/D/R/Z/G/J/S
-WORKABLE
-WORKABLY
-WORKBENCH/M/S
-WORKBOOK/M/S
-WORKHORSE/M/S
-WORKINGMAN
-WORKLOAD
-WORKMAN
-WORKMANSHIP
-WORKMEN
-WORKSHOP/M/S
-WORKSTATION/S
-WORLD/M/Y/S
-WORLDLINESS
-WORLDWIDE
-WORM/D/G/S
-WORN
-WORRISOME
-WORRY/D/R/Z/G/S
-WORRYINGLY
-WORSE
-WORSHIP/D/R/G/S
-WORSHIPFUL
-WORST/D
-WORTH
-WORTHLESS/P
-WORTHS
-WORTHWHILE/P
-WORTHY/P/T
-WOULD
-WOULDN'T
-WOUND/D/G/S
-WOVE
-WOVEN
-WRANGLE/D/R
-WRAP/M/S
-WRAPPED
-WRAPPER/M/S
-WRAPPING/S
-WRATH
-WREAK/S
-WREATH/D/S
-WRECK/D/R/Z/G/S
-WRECKAGE
-WREN/M/S
-WRENCH/D/G/S
-WREST
-WRESTLE/R/G/J/S
-WRETCH/D/S
-WRETCHEDNESS
-WRIGGLE/D/R/G/S
-WRING/R/S
-WRINKLE/D/S
-WRIST/M/S
-WRISTWATCH/M/S
-WRIT/M/S
-WRITABLE
-WRITE/R/Z/G/J/S
-WRITER'S
-WRITHE/D/G/S
-WRITTEN
-WRONG/D/G/Y/S
-WROTE
-WROUGHT
-WRUNG
-XENIX
-XEROX
-YALE
-YANK/D/G/S
-YARD/M/S
-YARDSTICK/M/S
-YARN/M/S
-YAWN/R/G
-YEA/S
-YEAR/M/Y/S
-YEARN/D/G/J
-YEAST/M/S
-YELL/D/R/G
-YELLOW/P/D/T/R/G/S
-YELLOWISH
-YELP/D/G/S
-YEOMAN
-YEOMEN
-YES
-YESTERDAY
-YET
-YIELD/D/G/S
-YOKE/M/S
-YON
-YONDER
-YORK/R/Z
-YORKTOWN
-YOU'D
-YOU'LL
-YOU'RE
-YOU'VE
-YOU/H
-YOUNG/T/R/Y
-YOUNGSTER/M/S
-YOUR/S
-YOURSELF
-YOURSELVES
-YOUTHFUL/P/Y
-YOUTHS
-YUGOSLAVIA
-ZEAL
-ZEALOUS/P/Y
-ZEBRA/M/S
-ZENITH
-ZERO/D/G/H/S
-ZEROES
-ZEST
-ZIGZAG
-ZINC
-ZODIAC
-ZONAL/Y
-ZONE/D/G/S
-ZOO/M/S
-ZOOLOGICAL/Y
-ZOOM/G
diff --git a/hemlock/spell-rt.lisp b/hemlock/spell-rt.lisp
deleted file mode 100644
index 90a31bcd5fdbe6af7d59857e80bf1dd639d9186b..0000000000000000000000000000000000000000
--- a/hemlock/spell-rt.lisp
+++ /dev/null
@@ -1,99 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Spell -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spell-rt.lisp,v 1.1.1.6 1992/02/24 04:00:32 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles
-;;;
-;;; This file contains system dependent primitives for the spelling checking/
-;;; correcting code in Spell-Correct.Lisp, Spell-Augment.Lisp, and
-;;; Spell-Build.Lisp.
-
-(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM"))
-
-
-;;;; System Area Referencing and Setting
-
-(eval-when (compile eval)
-
-;;; MAKE-SAP returns pointers that *dictionary*, *descriptors*, and
-;;; *string-table* are bound to.  Address is in the system area.
-;;;
-(defmacro make-sap (address)
-  `(system:int-sap ,address))
-
-(defmacro system-address (sap)
-  `(system:sap-int ,sap))
-
-
-(defmacro allocate-bytes (count)
-  `(system:allocate-system-memory ,count))
-
-(defmacro deallocate-bytes (address byte-count)
-  `(system:deallocate-system-memory (int-sap ,address) ,byte-count))
-
-
-(defmacro sapref (sap offset)
-  `(system:sap-ref-16 ,sap (* ,offset 2)))
-
-(defsetf sapref (sap offset) (value)
-  `(setf (system:sap-ref-16 ,sap (* ,offset 2)) ,value))
-
-
-(defmacro sap-replace (dst-string src-string src-start dst-start dst-end)
-  `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end))
-
-(defmacro string-sapref (sap index)
-  `(system:sap-ref-8 ,sap ,index))
-
-
-
-;;;; Primitive String Hashing
-
-;;; STRING-HASH employs the instruction SXHASH-SIMPLE-SUBSTRING which takes
-;;; an end argument, so we do not have to use SXHASH.  SXHASH would mean
-;;; doing a SUBSEQ of entry.
-;;;
-(defmacro string-hash (string length)
-  `(ext:truly-the lisp::index
-		  (%primitive sxhash-simple-substring
-			      ,string
-			      (the fixnum ,length))))
-
-) ;eval-when
-
-
-
-;;;; Binary Dictionary File I/O
-
-(defun open-dictionary (f)
-  (let* ((filename (ext:unix-namestring f))
-	 (kind (unix:unix-file-kind filename)))
-    (unless kind (error "Cannot find dictionary -- ~S." filename))
-    (multiple-value-bind (fd err)
-			 (unix:unix-open filename unix:o_rdonly 0)
-      (unless fd
-	(error "Opening ~S failed: ~A." filename err))
-      (multiple-value-bind (winp dev-or-err) (unix:unix-fstat fd)
-	(unless winp (error "Opening ~S failed: ~A." filename dev-or-err))
-	fd))))
-
-(defun close-dictionary (fd)
-  (unix:unix-close fd))
-
-(defun read-dictionary-structure (fd bytes)
-  (let* ((structure (allocate-bytes bytes)))
-    (multiple-value-bind (read-bytes err)
-			 (unix:unix-read fd structure bytes)
-      (when (or (null read-bytes) (not (= bytes read-bytes)))
-	(deallocate-bytes (system-address structure) bytes)
-	(error "Reading dictionary structure failed: ~A." err))
-      structure)))
diff --git a/hemlock/spellcoms.lisp b/hemlock/spellcoms.lisp
deleted file mode 100644
index 8b8d3584019972a7303eaf3b4b7a5e63c90878c1..0000000000000000000000000000000000000000
--- a/hemlock/spellcoms.lisp
+++ /dev/null
@@ -1,814 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles and Rob Maclachlan.
-;;;
-;;; This file contains the code to implement commands using the spelling
-;;; checking/correcting stuff in Spell-Corr.Lisp and the dictionary
-;;; augmenting stuff in Spell-Augment.Lisp.
-
-(in-package 'hemlock)
-
-
-
-(defstruct (spell-info (:print-function print-spell-info)
-		       (:constructor make-spell-info (pathname)))
-  pathname	;Dictionary file.
-  insertions)	;Incremental insertions for this dictionary.
-
-(defun print-spell-info (obj str n)
-  (declare (ignore n))
-  (format str "#<Spell Info ~S>" (namestring (spell-info-pathname obj))))
-
-
-(defattribute "Spell Word Character"
-  "One if the character is one that is present in the spell dictionary,
-  zero otherwise.")
-
-(do-alpha-chars (c :both)
-  (setf (character-attribute :spell-word-character c) 1))
-(setf (character-attribute :spell-word-character #\') 1)
-
-
-(defvar *spelling-corrections* (make-hash-table :test #'equal)
-  "Mapping from incorrect words to their corrections.")
-
-(defvar *ignored-misspellings* (make-hash-table :test #'equal)
-  "A hashtable with true values for words that will be quietly ignored when
-  they appear.")
-
-(defhvar "Spell Ignore Uppercase"
-  "If true, then \"Check Word Spelling\" and \"Correct Buffer Spelling\" will
-  ignore unknown words that are all uppercase.  This is useful for
-  abbreviations and cryptic formatter directives."
-  :value nil)
-
-
-
-;;;; Basic Spelling Correction Command (Esc-$ in EMACS)
-
-(defcommand "Check Word Spelling" (p)
-  "Check the spelling of the previous word and offer possible corrections
-   if the word in unknown. To add words to the dictionary from a text file see
-   the command \"Augment Spelling Dictionary\"."
-  "Check the spelling of the previous word and offer possible correct
-   spellings if the word is known to be misspelled."
-  (declare (ignore p))
-  (spell:maybe-read-spell-dictionary)  
-  (let* ((region (spell-previous-word (current-point) nil))
-	 (word (if region
-		   (region-to-string region)
-		   (editor-error "No previous word.")))
-	 (folded (string-upcase word)))
-    (message "Checking spelling of ~A." word)
-    (unless (check-out-word-spelling word folded)
-      (get-word-correction (region-start region) word folded))))
-
-
-;;;; Auto-Spell mode:
-
-(defhvar "Check Word Spelling Beep"
-  "If true, \"Auto Check Word Spelling\" will beep when an unknown word is
-   found."
-  :value t)
-
-(defhvar "Correct Unique Spelling Immediately"
-  "If true, \"Auto Check Word Spelling\" will immediately attempt to correct any
-   unknown word, automatically making the correction if there is only one
-   possible."
-  :value t)
-
-
-(defhvar "Default User Spelling Dictionary"
-  "This is the pathname of a dictionary to read the first time \"Spell\" mode
-   is entered in a given editing session.  When \"Set Buffer Spelling
-   Dictionary\" or the \"dictionary\" file option is used to specify a
-   dictionary, this default one is read also.  It defaults to nil."
-  :value nil)
-
-(defvar *default-user-dictionary-read-p* nil)
-
-(defun maybe-read-default-user-spelling-dictionary ()
-  (let ((default-dict (value default-user-spelling-dictionary)))
-    (when (and default-dict (not *default-user-dictionary-read-p*))
-      (spell:maybe-read-spell-dictionary)
-      (spell:spell-read-dictionary (truename default-dict))
-      (setf *default-user-dictionary-read-p* t))))
-
-
-(defmode "Spell"
-  :transparent-p t :precedence 1.0 :setup-function 'spell-mode-setup)
-
-(defun spell-mode-setup (buffer)
-  (defhvar "Buffer Misspelled Words"
-    "This variable holds a ring of marks pointing to misspelled words."
-    :buffer buffer  :value (make-ring 10 #'delete-mark))
-  (maybe-read-default-user-spelling-dictionary))
-
-(defcommand "Auto Spell Mode" (p)
-  "Toggle \"Spell\" mode in the current buffer.  When in \"Spell\" mode,
-  the spelling of each word is checked after it is typed."
-  "Toggle \"Spell\" mode in the current buffer."
-  (declare (ignore p))
-  (setf (buffer-minor-mode (current-buffer) "Spell")
-	(not (buffer-minor-mode (current-buffer) "Spell"))))
-
-
-(defcommand "Auto Check Word Spelling" (p)
-  "Check the spelling of the previous word and display a message in the echo
-   area if the word is not in the dictionary.  To add words to the dictionary
-   from a text file see the command \"Augment Spelling Dictionary\".  If a
-   replacement for an unknown word has previously been specified, then the
-   replacement will be made immediately.  If \"Correct Unique Spelling
-   Immediately\" is true, then this command will immediately correct words
-   which have a unique correction.  If there is no obvious correction, then we
-   place the word in a ring buffer for access by the \"Correct Last Misspelled
-   Word\" command.  If \"Check Word Spelling Beep\" is true, then this command
-   beeps when an unknown word is found, in addition to displaying the message."
-  "Check the spelling of the previous word, making obvious corrections, or
-  queuing the word in buffer-misspelled-words if we are at a loss."
-  (declare (ignore p))
-  (unless (eq (last-command-type) :spell-check)
-    (spell:maybe-read-spell-dictionary)
-    (let ((region (spell-previous-word (current-point) t)))
-      (when region
-	(let* ((word (nstring-upcase (region-to-string region)))
-	       (len (length word)))
-	  (declare (simple-string word))
-	  (when (and (<= 2 len spell:max-entry-length)
-		     (not (spell:spell-try-word word len)))
-	    (let ((found (gethash word *spelling-corrections*))
-		  (save (region-to-string region)))
-	      (cond (found
-		     (undoable-replace-word (region-start region) save found)
-		     (message "Corrected ~S to ~S." save found)
-		     (when (value check-word-spelling-beep) (beep)))
-		    ((and (value spell-ignore-uppercase)
-			  (every #'upper-case-p save))
-		     (unless (gethash word *ignored-misspellings*)
-		       (setf (gethash word *ignored-misspellings*) t)
-		       (message "Ignoring ~S." save)))
-		    (t
-		     (let ((close (spell:spell-collect-close-words word)))
-		       (cond ((and close
-				   (null (rest close))
-				   (value correct-unique-spelling-immediately))
-			      (let ((fix (first close)))
-				(undoable-replace-word (region-start region)
-						       save fix)
-				(message "Corrected ~S to ~S." save fix)))
-			     (t
-			      (ring-push (copy-mark (region-end region)
-						    :right-inserting)
-					 (value buffer-misspelled-words))
-			      (let ((nclose
-				     (do ((i 0 (1+ i))
-					  (words close (cdr words))
-					  (nwords () (cons (list i (car words))
-							   nwords)))
-					 ((null words) (nreverse nwords)))))
-				(message
-				 "Word ~S not found.~
-				  ~@[  Corrections:~:{ ~D=~A~}~]"
-				 save nclose)))))
-		     (when (value check-word-spelling-beep) (beep))))))))))
-  (setf (last-command-type) :spell-check))
-
-(defcommand "Correct Last Misspelled Word" (p)
-  "Fix a misspelling found by \"Auto Check Word Spelling\".  This prompts for
-   a single character command to determine which action to take to correct the
-   problem."
-  "Prompt for a single character command to determine how to fix up a
-   misspelling detected by Check-Word-Spelling-Command."
-  (declare (ignore p))
-  (spell:maybe-read-spell-dictionary)
-  (do ((info (value spell-information)))
-      ((sub-correct-last-misspelled-word info))))
-
-(defun sub-correct-last-misspelled-word (info)
-  (let* ((missed (value buffer-misspelled-words))
-	 (region (cond ((zerop (ring-length missed))
-			(editor-error "No recently misspelled word."))
-		       ((spell-previous-word (ring-ref missed 0) t))
-		       (t (editor-error "No recently misspelled word."))))
-	 (word (region-to-string region))
-	 (folded (string-upcase word))
-	 (point (current-point))
-	 (save (copy-mark point))
-	 (res t))
-    (declare (simple-string word))
-    (unwind-protect
-      (progn
-       (when (check-out-word-spelling word folded)
-	 (delete-mark (ring-pop missed))
-	 (return-from sub-correct-last-misspelled-word t))
-       (move-mark point (region-end region))
-       (command-case (:prompt "Action: "
-		      :change-window nil
- :help "Type a single character command to do something to the misspelled word.")
-	 (#\c "Try to find a correction for this word."
-	  (unless (get-word-correction (region-start region) word folded)
-	    (reprompt)))
-	 (#\i "Insert this word in the dictionary."
-	  (spell:spell-add-entry folded)
-	  (push folded (spell-info-insertions info))
-	  (message "~A inserted in the dictionary." word))
-	 (#\r "Prompt for a word to replace this word with."
-	  (let ((s (prompt-for-string :prompt "Replace with: "
-				      :default word
- :help "Type a string to replace occurrences of this word with.")))
-	    (delete-region region)
-	    (insert-string point s)
-	    (setf (gethash folded *spelling-corrections*) s)))
-	 (:cancel "Ignore this word and go to the previous misspelled word."
-	  (setq res nil))
-	 (:recursive-edit
-	  "Go into a recursive edit and leave when it exits."
-	  (do-recursive-edit))
-	 ((:exit #\q) "Exit and forget about this word.")
-	 ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
-	  "Choose this numbered word as the correct spelling."
-	  (let ((num (digit-char-p (ext:key-event-char *last-key-event-typed*)))
-		(close-words (spell:spell-collect-close-words folded)))
-	    (cond ((> num (length close-words))
-		   (editor-error "Choice out of range."))
-		  (t (let ((s (nth num close-words)))
-		       (setf (gethash folded *spelling-corrections*) s)
-		       (undoable-replace-word (region-start region)
-					      word s)))))))
-       (delete-mark (ring-pop missed))
-       res)
-      (move-mark point save)
-      (delete-mark save))))
-
-(defhvar "Spelling Un-Correct Prompt for Insert"
-  "When this is set, \"Undo Last Spelling Correction\" will prompt before
-   inserting the old word into the dictionary."
-  :value nil)
-
-(defcommand "Undo Last Spelling Correction" (p)
-  "Undo the last incremental spelling correction.
-   The \"correction\" is replaced with the old word, and the old word is
-   inserted in the dictionary.  When \"Spelling Un-Correct Prompt for Insert\"
-   is set, the user is asked about inserting the old word.  Any automatic
-   replacement for the old word is eliminated."
-  "Undo the last incremental spelling correction, nuking any undesirable
-   side-effects."
-  (declare (ignore p))
-  (unless (hemlock-bound-p 'last-spelling-correction-mark)
-    (editor-error "No last spelling correction."))
-  (let ((mark (value last-spelling-correction-mark))
-	(words (value last-spelling-correction-words)))
-    (unless words
-      (editor-error "No last spelling correction."))
-    (let* ((new (car words))
-	   (old (cdr words))
-	   (folded (string-upcase old)))
-      (declare (simple-string old new folded))
-      (remhash folded *spelling-corrections*)
-      (delete-characters mark (length new))
-      (insert-string mark old)
-      (setf (value last-spelling-correction-words) nil)
-      (when (or (not (value spelling-un-correct-prompt-for-insert))
-		(prompt-for-y-or-n
-		 :prompt (list "Insert ~A into spelling dictionary? " folded)
-		 :default t
-		 :default-string "Y"))
-	(push folded (spell-info-insertions (value spell-information)))
-	(spell:maybe-read-spell-dictionary)
-	(spell:spell-add-entry folded)
-	(message "Added ~S to spelling dictionary." old)))))
-
-
-;;; Check-Out-Word-Spelling  --  Internal
-;;;
-;;;    Return Nil if Word is a candidate for correction, otherwise
-;;; return T and message as to why it isn't.
-;;;
-(defun check-out-word-spelling (word folded)
-  (declare (simple-string word))
-  (let ((len (length word)))
-      (cond ((= len 1)
-	     (message "Single character words are not in the dictionary.") t)
-	    ((> len spell:max-entry-length)
-	     (message "~A is too long for the dictionary." word) t)
-	    (t
-	     (multiple-value-bind (idx flagp) (spell:spell-try-word folded len)
-	       (when idx
-		 (message "Found it~:[~; because of ~A~]." flagp
-			  (spell:spell-root-word idx))
-		 t))))))
-
-;;; Get-Word-Correction  --  Internal
-;;;
-;;;    Find all known close words to the either unknown or incorrectly
-;;; spelled word we are checking.  Word is the unmunged word, and Folded is
-;;; the uppercased word.  Mark is a mark which points to the beginning of
-;;; the offending word.  Return True if we successfully corrected the word.
-;;;
-(defun get-word-correction (mark word folded)
-  (let ((close-words (spell:spell-collect-close-words folded)))
-    (declare (list close-words))
-    (if close-words
-	(with-pop-up-display (s :height 3)
-	  (do ((i 0 (1+ i))
-	       (words close-words (cdr words)))
-	      ((null words))
-	    (format s "~36R=~A " i (car words)))
-	  (finish-output s)
-	  (let* ((key-event (prompt-for-key-event
-			     :prompt "Correction choice: "))
-		 (num (digit-char-p (ext:key-event-char key-event) 36)))
-	    (cond ((not num) (return-from get-word-correction nil))
-		  ((> num (length close-words))
-		   (editor-error "Choice out of range."))
-		  (t
-		   (let ((s (nth num close-words)))
-		     (setf (gethash folded *spelling-corrections*) s)
-		     (undoable-replace-word mark word s)))))
-	  (return-from get-word-correction t))
-	(with-pop-up-display (s :height 1)
-	  (write-line "No corrections found." s)
-	  nil))))
-
-
-;;; Undoable-Replace-Word  --  Internal
-;;;
-;;;    Like Spell-Replace-Word, but makes annotations in buffer local variables
-;;; so that "Undo Last Spelling Correction" can undo it.
-;;;
-(defun undoable-replace-word (mark old new)
-  (unless (hemlock-bound-p 'last-spelling-correction-mark)
-    (let ((buffer (current-buffer)))
-      (defhvar "Last Spelling Correction Mark"
-	"This variable holds a park pointing to the last spelling correction."
-	:buffer buffer  :value (copy-mark (buffer-start-mark buffer)))
-      (defhvar "Last Spelling Correction Words"
-	"The replacement done for the last correction: (new . old)."
-	:buffer buffer  :value nil)))
-  (move-mark (value last-spelling-correction-mark) mark)
-  (setf (value last-spelling-correction-words) (cons new old))
-  (spell-replace-word mark old new))
-
-
-;;;; Buffer Correction
-
-(defvar *spell-word-characters*
-  (make-array char-code-limit :element-type 'bit  :initial-element 0)
-  "Characters that are legal in a word for spelling checking purposes.")
-
-(do-alpha-chars (c :both)
-  (setf (sbit *spell-word-characters* (char-code c)) 1))
-(setf (sbit *spell-word-characters* (char-code #\')) 1)
-
-
-(defcommand "Correct Buffer Spelling" (p)
-  "Correct spelling over whole buffer.  A log of the found misspellings is
-   kept in the buffer \"Spell Corrections\".  For each unknown word the
-   user may accept it, insert it in the dictionary, correct its spelling
-   with one of the offered possibilities, replace the word with a user
-   supplied word, or go into a recursive edit.  Words may be added to the
-   dictionary in advance from a text file (see the command \"Augment
-   Spelling Dictionary\")."
-  "Correct spelling over whole buffer."
-  (declare (ignore p))
-  (clrhash *ignored-misspellings*)
-  (let* ((buffer (current-buffer))
-	 (log (or (make-buffer "Spelling Corrections")
-		  (getstring "Spelling Corrections" *buffer-names*)))
-	 (point (buffer-end (buffer-point log)))
-	 (*standard-output* (make-hemlock-output-stream point))
-	 (window (or (car (buffer-windows log)) (make-window point))))
-    (format t "~&Starting spelling checking of buffer ~S.~2%"
-	    (buffer-name buffer))
-    (spell:maybe-read-spell-dictionary)
-    (correct-buffer-spelling buffer window)
-    (delete-window window)
-    (close *standard-output*)))
-
-;;; CORRECT-BUFFER-SPELLING scans through buffer a line at a time, grabbing the
-;;; each line's string and breaking it up into words using the
-;;; *spell-word-characters* mask.  We try the spelling of each word, and if it
-;;; is unknown, we call FIX-WORD and resynchronize when it returns.
-;;;
-(defun correct-buffer-spelling (buffer window)
-  (do ((line (mark-line (buffer-start-mark buffer)) (line-next line))
-       (info (if (hemlock-bound-p 'spell-information :buffer buffer)
-		 (variable-value 'spell-information :buffer buffer)
-		 (value spell-information)))
-       (mask *spell-word-characters*)
-       (word (make-string spell:max-entry-length)))
-      ((null line))
-    (declare (simple-bit-vector mask) (simple-string word))
-    (block line
-      (let* ((string (line-string line))
-	     (length (length string)))
-	(declare (simple-string string))
-	(do ((start 0 (or skip-apostrophes end))
-	     (skip-apostrophes nil nil)
-	     end)
-	    (nil)
-	  ;;
-	  ;; Find word start.
-	  (loop
-	    (when (= start length) (return-from line))
-	    (when (/= (bit mask (char-code (schar string start))) 0) (return))
-	    (incf start))
-	  ;;
-	  ;; Find the end.
-	  (setq end (1+ start))
-	  (loop
-	    (when (= end length) (return))
-	    (when (zerop (bit mask (char-code (schar string end)))) (return))
-	    (incf end))
-	  (multiple-value-setq (end skip-apostrophes)
-	    (correct-buffer-word-end string start end))
-	  ;;
-	  ;; Check word.
-	  (let ((word-len (- end start)))
-	    (cond
-	     ((= word-len 1))
-	     ((> word-len spell:max-entry-length)
-	      (format t "Not checking ~S -- too long for dictionary.~2%"
-		      word))
-	     (t
-	      ;;
-	      ;; Copy the word and uppercase it.
-	      (do* ((i (1- end) (1- i))
-		    (j (1- word-len) (1- j)))
-		   ((zerop j)
-		    (setf (schar word 0) (char-upcase (schar string i))))
-		(setf (schar word j) (char-upcase (schar string i))))
-	      (unless (spell:spell-try-word word word-len)
-		(move-to-position (current-point) start line)
-		(fix-word (subseq word 0 word-len) (subseq string start end)
-			  window info)
-		(let ((point (current-point)))
-		  (setq end (mark-charpos point)
-			line (mark-line point)
-			string (line-string line)
-			length (length string))))))))))))
-
-;;; CORRECT-BUFFER-WORD-END takes a line string from CORRECT-BUFFER-SPELLING, a
-;;; start, and a end.  It places end to exclude from the word apostrophes used
-;;; for quotation marks, possessives, and funny plurals (e.g., A's and AND's).
-;;; Every word potentially can be followed by "'s", and any clown can use the
-;;; `` '' Scribe ligature.  This returns the value to use for end of the word
-;;; and the value to use as the end when continuing to find the next word in
-;;; string.
-;;;
-(defun correct-buffer-word-end (string start end)
-  (cond ((and (> (- end start) 2)
-	      (char= (char-upcase (schar string (1- end))) #\S)
-	      (char= (schar string (- end 2)) #\'))
-	 ;; Use roots of possessives and funny plurals (e.g., A's and AND's).
-	 (values (- end 2) end))
-	(t
-	 ;; Maybe backup over apostrophes used for quotation marks.
-	 (do ((i (1- end) (1- i)))
-	     ((= i start) (values end end))
-	   (when (char/= (schar string i) #\')
-	     (return (values (1+ i) end)))))))
-
-;;; Fix-Word  --  Internal
-;;;
-;;;    Handles the case where the word has a known correction.  If is does
-;;; not then call Correct-Buffer-Word-Not-Found.  In either case, the
-;;; point is left at the place to resume checking.
-;;;
-(defun fix-word (word unfolded-word window info)
-  (declare (simple-string word unfolded-word))
-  (let ((correction (gethash word *spelling-corrections*))
-	(mark (current-point)))
-    (cond (correction
-	   (format t "Replacing ~S with ~S.~%" unfolded-word correction)
-	   (spell-replace-word mark unfolded-word correction))
-	  ((and (value spell-ignore-uppercase)
-		(every #'upper-case-p unfolded-word))
-	   (character-offset mark (length word))
-	   (unless (gethash word *ignored-misspellings*)
-	     (setf (gethash word *ignored-misspellings*) t)
-	     (format t "Ignoring ~S.~%" unfolded-word)))
-	  (t
-	   (correct-buffer-word-not-found word unfolded-word window info)))))
-
-(defun correct-buffer-word-not-found (word unfolded-word window info)
-  (declare (simple-string word unfolded-word))
-  (let* ((close-words (spell:spell-collect-close-words word))
-	 (close-words-len (length (the list close-words)))
-	 (mark (current-point))
-	 (wordlen (length word)))
-    (format t "Unknown word: ~A~%" word)
-    (cond (close-words
-	   (format t "~[~;A~:;Some~]~:* possible correction~[~; is~:;s are~]: "
-		   close-words-len)
-	   (if (= close-words-len 1)
-	       (write-line (car close-words))
-	       (let ((n 0))
-		 (dolist (w close-words (terpri))
-		   (format t "~36R=~A " n w)
-		   (incf n)))))
-	  (t
-	   (write-line "No correction possibilities found.")))
-    (let ((point (buffer-point (window-buffer window))))
-      (unless (displayed-p point window)
-	(center-window window point)))
-    (command-case
-       (:prompt "Action: "
-        :help "Type a single letter command, or help character for help."
-        :change-window nil)
-      (#\i "Insert unknown word into dictionary for future lookup."
-	 (spell:spell-add-entry word)
-	 (push word (spell-info-insertions info))
-	 (format t "~S added to dictionary.~2%" word))
-      (#\c "Correct the unknown word with possible correct spellings."
-	 (unless close-words
-	   (write-line "There are no possible corrections.")
-	   (reprompt))
-	 (let ((num (if (= close-words-len 1) 0
-			(digit-char-p (ext:key-event-char
-				       (prompt-for-key-event
-					:prompt "Correction choice: "))
-				      36))))
-	   (unless num (reprompt))
-	   (when (> num close-words-len)
-	     (beep)
-	     (write-line "Response out of range.")
-	     (reprompt))
-	   (let ((choice (nth num close-words)))
-	     (setf (gethash word *spelling-corrections*) choice)
-	     (spell-replace-word mark unfolded-word choice)))
-	 (terpri))
-      (#\a "Accept the word as correct (that is, ignore it)."
-	 (character-offset mark wordlen))
-      (#\r "Replace the unknown word with a supplied replacement."
-	 (let ((s (prompt-for-string
-		   :prompt "Replacement Word: "
-		   :default unfolded-word
-		   :help "String to replace the unknown word with.")))
-	   (setf (gethash word *spelling-corrections*) s)
-	   (spell-replace-word mark unfolded-word s))
-	 (terpri))
-      (:recursive-edit
-       "Go into a recursive edit and resume correction where the point is left."
-       (do-recursive-edit)))))
-
-;;; Spell-Replace-Word  --  Internal
-;;;
-;;;    Replaces Old with New, starting at Mark.  The case of Old is used
-;;; to derive the new case.
-;;;
-(defun spell-replace-word (mark old new)
-  (declare (simple-string old new))
-  (let ((res (cond ((lower-case-p (schar old 0))
-		    (string-downcase new))
-		   ((lower-case-p (schar old 1))
-		    (let ((res (string-downcase new)))
-		      (setf (char res 0) (char-upcase (char res 0)))
-		      res))
-		   (t
-		    (string-upcase new)))))
-    (with-mark ((m mark :left-inserting))
-      (delete-characters m (length old))
-      (insert-string m res))))
-
-
-;;;; User Spelling Dictionaries.
-
-(defvar *pathname-to-spell-info* (make-hash-table :test #'equal)
-  "This maps dictionary files to spelling information.")
-
-(defhvar "Spell Information"
-  "This is the information about a spelling dictionary and its incremental
-   insertions."
-  :value (make-spell-info nil))
-
-(define-file-option "Dictionary" (buffer file)
-  (let* ((dict (merge-pathnames
-		file
-		(make-pathname :defaults (buffer-default-pathname buffer)
-			       :type "dict")))
-	 (dictp (probe-file dict)))
-    (if dictp
-	(set-buffer-spelling-dictionary-command nil dictp buffer)
-	(loud-message "Couldn't find dictionary ~A." (namestring dict)))))
-
-;;; SAVE-DICTIONARY-ON-WRITE is on the "Write File Hook" in buffers with
-;;; the "dictionary" file option.
-;;; 
-(defun save-dictionary-on-write (buffer)
-  (when (hemlock-bound-p 'spell-information :buffer buffer)
-    (save-spelling-insertions
-     (variable-value 'spell-information :buffer buffer))))
-
-
-(defcommand "Save Incremental Spelling Insertions" (p)
-  "Append incremental spelling dictionary insertions to a file.  The file
-   is prompted for unless \"Set Buffer Spelling Dictionary\" has been
-   executed in the buffer."
-  "Append incremental spelling dictionary insertions to a file."
-  (declare (ignore p))
-  (let* ((info (value spell-information))
-	 (file (or (spell-info-pathname info)
-		   (value default-user-spelling-dictionary)
-		   (prompt-for-file
-		    :prompt "Dictionary File: "
-		    :default (dictionary-name-default)
-		    :must-exist nil
-		    :help
- "Name of the dictionary file to append dictionary insertions to."))))
-    (save-spelling-insertions info file)
-    (let* ((ginfo (variable-value 'spell-information :global))
-	   (insertions (spell-info-insertions ginfo)))
-      (when (and insertions
-		 (prompt-for-y-or-n
-		  :prompt
-		  `("Global spelling insertions exist.~%~
-		     Save these to ~A also? "
-		    ,(namestring file)
-		  :default t
-		  :default-string "Y"))
-	(save-spelling-insertions ginfo file))))))
-
-(defun save-spelling-insertions (info &optional
-				      (name (spell-info-pathname info)))
-  (when (spell-info-insertions info)
-    (with-open-file (stream name
-			    :direction :output :element-type 'string-char
-			    :if-exists :append :if-does-not-exist :create)
-      (dolist (w (spell-info-insertions info))
-	(write-line w stream)))
-    (setf (spell-info-insertions info) ())
-    (message "Incremental spelling insertions for ~A written."
-	     (namestring name))))
-
-(defcommand "Set Buffer Spelling Dictionary" (p &optional file buffer)
-  "Prompts for the dictionary file to associate with the current buffer.
-   If this file has not been read for any other buffer, then it is read.
-   Incremental spelling insertions from this buffer can be appended to
-   this file with \"Save Incremental Spelling Insertions\"."
-  "Sets the buffer's spelling dictionary and reads it if necessary."
-  (declare (ignore p))
-  (maybe-read-default-user-spelling-dictionary)
-  (let* ((file (truename (or file
-			     (prompt-for-file
-			      :prompt "Dictionary File: "
-			      :default (dictionary-name-default)
-			      :help
- "Name of the dictionary file to add into the current dictionary."))))
-	 (file-name (namestring file))
-	 (spell-info-p (gethash file-name *pathname-to-spell-info*))
-	 (spell-info (or spell-info-p (make-spell-info file)))
-	 (buffer (or buffer (current-buffer))))
-    (defhvar "Spell Information"
-      "This is the information about a spelling dictionary and its incremental
-       insertions."
-      :value spell-info :buffer buffer)
-    (add-hook write-file-hook 'save-dictionary-on-write)
-    (unless spell-info-p
-      (setf (gethash file-name *pathname-to-spell-info*) spell-info)
-      (read-spelling-dictionary-command nil file))))
-
-(defcommand "Read Spelling Dictionary" (p &optional file)
-  "Adds entries to the dictionary from a file in the following format:
-   
-      entry1/flag1/flag2/flag3
-      entry2
-      entry3/flag1/flag2/flag3/flag4/flag5.
-
-   The flags are single letter indicators of legal suffixes for the entry;
-   the available flags and their correct use may be found at the beginning
-   of spell-correct.lisp in the Hemlock sources.  There must be exactly one 
-   entry per line, and each line must be flushleft."
-  "Add entries to the dictionary from a text file in a specified format."
-  (declare (ignore p))
-  (spell:maybe-read-spell-dictionary)
-  (spell:spell-read-dictionary
-   (or file
-       (prompt-for-file
-	:prompt "Dictionary File: "
-	:default (dictionary-name-default)
-	:help
-	"Name of the dictionary file to add into the current dictionary."))))
-
-(defun dictionary-name-default ()
-  (make-pathname :defaults (buffer-default-pathname (current-buffer))
-		 :type "dict"))
-
-(defcommand "Add Word to Spelling Dictionary" (p)
-  "Add the previous word to the spelling dictionary."
-  "Add the previous word to the spelling dictionary."
-  (declare (ignore p))
-  (spell:maybe-read-spell-dictionary)
-  (let ((word (region-to-string (spell-previous-word (current-point) nil))))
-    ;;
-    ;; SPELL:SPELL-ADD-ENTRY destructively uppercases word.
-    (when (spell:spell-add-entry word)
-      (message "Word ~(~S~) added to the spelling dictionary." word)
-      (push word (spell-info-insertions (value spell-information))))))
-
-(defcommand "Remove Word from Spelling Dictionary" (p)
-  "Prompts for word to remove from the spelling dictionary."
-  "Prompts for word to remove from the spelling dictionary."
-   (declare (ignore p))
-  (spell:maybe-read-spell-dictionary)
-  (let* ((word (prompt-for-string
-		:prompt "Word to remove from spelling dictionary: "
-		:trim t))
-	 (upword (string-upcase word)))
-    (declare (simple-string word))
-    (multiple-value-bind (index flagp)
-			 (spell:spell-try-word upword (length word))
-      (unless index
-	(editor-error "~A not in dictionary." upword))
-      (if flagp
-	  (remove-spelling-word upword)
-	  (let ((flags (spell:spell-root-flags index)))
-	    (when (or (not flags)
-		      (prompt-for-y-or-n
-		       :prompt
- `("Deleting ~A also removes words formed from this root and these flags: ~%  ~
-    ~S.~%~
-    Delete word anyway? "
-   ,word ,flags)
-		       :default t
-		       :default-string "Y"))
-	      (remove-spelling-word upword)))))))
-
-;;; REMOVE-SPELLING-WORD removes the uppercase word word from the spelling
-;;; dictionary and from the spelling informations incremental insertions list.
-;;; 
-(defun remove-spelling-word (word)
-  (let ((info (value spell-information)))
-    (spell:spell-remove-entry word)
-    (setf (spell-info-insertions info)
-	  (delete word (spell-info-insertions info) :test #'string=))))
-
-(defcommand "List Incremental Spelling Insertions" (p)
-  "Display the incremental spelling insertions for the current buffer's
-   associated spelling dictionary file."
-  "Display the incremental spelling insertions for the current buffer's
-   associated spelling dictionary file."
-  (declare (ignore p))
-  (let* ((info (value spell-information))
-	 (file (spell-info-pathname info))
-	 (insertions (spell-info-insertions info)))
-    (declare (list insertions))
-    (with-pop-up-display (s :height (1+ (length insertions)))
-      (if file
-	  (format s "Incremental spelling insertions for dictionary ~A:~%"
-		  (namestring file))
-	  (write-line "Global incremental spelling insertions:" s))
-      (dolist (w insertions)
-	(write-line w s)))))
-
-
-
-;;;; Utilities for above stuff.
-
-;;; SPELL-PREVIOUS-WORD returns as a region the current or previous word, using
-;;; the spell word definition.  If there is no such word, return nil.  If end-p
-;;; is non-nil, then mark ends the word even if there is a non-delimiter
-;;; character after it.
-;;;
-;;; Actually, if mark is between the first character of a word and a
-;;; non-spell-word characer, it is considered to be in that word even though
-;;; that word is after the mark.  This is because Hemlock's cursor is always
-;;; displayed over the next character, so users tend to think of a cursor
-;;; displayed on the first character of a word as being in that word instead of
-;;; before it.
-;;;
-(defun spell-previous-word (mark end-p)
-  (with-mark ((point mark)
-	      (mark mark))
-    (cond ((or end-p
-	       (zerop (character-attribute :spell-word-character
-					   (next-character point))))
-	   (unless (reverse-find-attribute mark :spell-word-character)
-	     (return-from spell-previous-word nil))
-	   (move-mark point mark)
-	   (reverse-find-attribute point :spell-word-character #'zerop))
-	  (t
-	   (find-attribute mark :spell-word-character #'zerop)
-	   (reverse-find-attribute point :spell-word-character #'zerop)))
-    (cond ((and (> (- (mark-charpos mark) (mark-charpos point)) 2)
-		(char= (char-upcase (previous-character mark)) #\S)
-		(char= (prog1 (previous-character (mark-before mark))
-			 (mark-after mark))
-		       #\'))
-	   ;; Use roots of possessives and funny plurals (e.g., A's and AND's).
-	   (character-offset mark -2))
-	  (t
-	   ;; Maybe backup over apostrophes used for quotation marks.
-	   (loop
-	     (when (mark= point mark) (return-from spell-previous-word nil))
-	     (when (char/= (previous-character mark) #\') (return))
-	     (mark-before mark))))
-    (region point mark)))
diff --git a/hemlock/srccom.lisp b/hemlock/srccom.lisp
deleted file mode 100644
index df9d6fb3a6264d84fe031db1461c7ac0dbc83f87..0000000000000000000000000000000000000000
--- a/hemlock/srccom.lisp
+++ /dev/null
@@ -1,484 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/srccom.lisp,v 1.3 1991/02/08 16:38:04 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Source comparison stuff for Hemlock.
-;;;
-;;; Written by Skef Wholey and Bill Chiles.
-;;;
-
-(in-package "HEMLOCK")
-
-(defhvar "Source Compare Ignore Extra Newlines"
-  "If T, Source Compare and Source Merge will treat all groups of newlines
-  as if they were a single newline.  The default is T."
-  :value t)
-
-(defhvar "Source Compare Ignore Case"
-  "If T, Source Compare and Source Merge will treat all letters as if they
-  were of the same case.  The default is Nil."
-  :value nil)
-
-(defhvar "Source Compare Ignore Indentation"
-  "This determines whether comparisons ignore initial whitespace on a line or
-   use the whole line."
-  :value nil)
-
-(defhvar "Source Compare Number of Lines"
-  "This variable controls the number of lines Source Compare and Source Merge
-  will compare when resyncronizing after a difference has been encountered.
-  The default is 3."
-  :value 3)
-
-(defhvar "Source Compare Default Destination"
-  "This is a sticky-default buffer name to offer when comparison commands prompt
-   for a results buffer."
-  :value "Differences")
-
-
-(defcommand "Buffer Changes" (p)
-  "Generate a comparison of the current buffer with its file on disk."
-  "Generate a comparison of the current buffer with its file on disk."
-  (declare (ignore p))
-  (let ((buffer (current-buffer)))
-    (unless (buffer-pathname buffer)
-      (editor-error "No pathname associated with buffer."))
-    (let ((other-buffer (or (getstring "Buffer Changes File" *buffer-names*)
-			    (make-buffer "Buffer Changes File")))
-	  (result-buffer (or (getstring "Buffer Changes Result" *buffer-names*)
-			     (make-buffer "Buffer Changes Result"))))
-      (visit-file-command nil (buffer-pathname buffer) other-buffer)
-      (delete-region (buffer-region result-buffer))
-      (compare-buffers-command nil buffer other-buffer result-buffer)
-      (delete-buffer other-buffer))))
-
-;;; "Compare Buffers" creates two temporary buffers when there is a prefix.
-;;; These get deleted when we're done.  Buffer-a and Buffer-b are used for
-;;; names is banners in either case.
-;;; 
-(defcommand "Compare Buffers" (p &optional buffer-a buffer-b dest-buffer)
-  "Performs a source comparison on two specified buffers.  If the prefix
-   argument is supplied, only compare the regions in the buffer."
-  "Performs a source comparison on two specified buffers, Buffer-A and
-   Buffer-B, putting the result of the comparison into the Dest-Buffer.
-   If the prefix argument is supplied, only compare the regions in the
-   buffer."
-  (srccom-choose-comparison-functions)
-  (multiple-value-bind (buffer-a buffer-b dest-point
-		        delete-buffer-a delete-buffer-b)
-		       (get-srccom-buffers "Compare buffer: " buffer-a buffer-b
-					   dest-buffer p)
-    (with-output-to-mark (log dest-point)
-      (format log "Comparison of ~A and ~A.~%~%"
-	      (buffer-name buffer-a) (buffer-name buffer-b))
-      (with-mark ((mark-a (buffer-start-mark (or delete-buffer-a buffer-a)))
-		  (mark-b (buffer-start-mark (or delete-buffer-b buffer-b))))
-	(loop
-	  (multiple-value-bind (diff-a diff-b)
-			       (srccom-find-difference mark-a mark-b)
-	    (when (null diff-a) (return nil))
-	    (format log "**** Buffer ~A:~%" (buffer-name buffer-a))
-	    (insert-region dest-point diff-a)
-	    (format log "**** Buffer ~A:~%" (buffer-name buffer-b))
-	    (insert-region dest-point diff-b)
-	    (format log "***************~%~%")
-	    (move-mark mark-a (region-end diff-a))
-	    (move-mark mark-b (region-end diff-b))
-	    (unless (line-offset mark-a 1) (return))
-	    (unless (line-offset mark-b 1) (return)))))
-	(format log "Done.~%"))
-    (when delete-buffer-a
-      (delete-buffer delete-buffer-a)
-      (delete-buffer delete-buffer-b))))
-
-
-;;; "Merge Buffers" creates two temporary buffers when there is a prefix.
-;;; These get deleted when we're done.  Buffer-a and Buffer-b are used for
-;;; names is banners in either case.
-;;; 
-(defcommand "Merge Buffers" (p &optional buffer-a buffer-b dest-buffer)
-  "Performs a source merge on two specified buffers.  If the prefix
-   argument is supplied, only compare the regions in the buffer."
-  "Performs a source merge on two specified buffers, Buffer-A and Buffer-B,
-   putting the resulting text into the Dest-Buffer.  If the prefix argument
-   is supplied, only compare the regions in the buffer."
-  (srccom-choose-comparison-functions)
-  (multiple-value-bind (buffer-a buffer-b dest-point
-		        delete-buffer-a delete-buffer-b)
-		       (get-srccom-buffers "Merge buffer: " buffer-a buffer-b
-					   dest-buffer p)
-    (with-output-to-mark (stream dest-point)
-      (let ((region-a (buffer-region (or delete-buffer-a buffer-a))))
-	(with-mark ((temp-a (region-start region-a) :right-inserting)
-		    (temp-b dest-point :right-inserting)
-		    (mark-a (region-start region-a))
-		    (mark-b (region-start
-			     (buffer-region (or delete-buffer-b buffer-b)))))
-	  (clear-echo-area)
-	  (loop
-	    (multiple-value-bind (diff-a diff-b)
-				 (srccom-find-difference mark-a mark-b)
-	      (when (null diff-a)
-		(insert-region dest-point (region temp-a (region-end region-a)))
-		(return nil))
-	      ;; Copy the part that's the same.
-	      (insert-region dest-point (region temp-a (region-start diff-a)))
-	      ;; Put both versions in the buffer, and prompt for which one to use.
-	      (move-mark temp-a dest-point)
-	      (format stream "~%**** Buffer ~A (1):~%" (buffer-name buffer-a))
-	      (insert-region dest-point diff-a)
-	      (move-mark temp-b dest-point)
-	      (format stream "~%**** Buffer ~A (2):~%" (buffer-name buffer-b))
-	      (insert-region dest-point diff-b)
-	      (command-case
-		  (:prompt "Merge Buffers: "
-		   :help "Type one of these characters to say how to merge:") 
-		(#\1 "Use the text from buffer 1."
-		     (delete-region (region temp-b dest-point))
-		     (delete-characters temp-a)
-		     (delete-region
-		      (region temp-a
-			      (line-start temp-b
-					  (line-next (mark-line temp-a))))))
-		(#\2 "Use the text from buffer 2."
-		     (delete-region (region temp-a temp-b))
-		     (delete-characters temp-b)
-		     (delete-region
-		      (region temp-b
-			      (line-start temp-a
-					  (line-next (mark-line temp-b))))))
-		(#\b "Insert both versions with **** MERGE LOSSAGE **** around them."
-		     (insert-string temp-a "
-		     **** MERGE LOSSAGE ****")
-		     (insert-string dest-point "
-		     **** END OF MERGE LOSSAGE ****"))
-		(#\a "Align window at start of difference display."
-		     (line-start
-		      (move-mark
-		       (window-display-start
-			(car (buffer-windows (line-buffer (mark-line temp-a)))))
-		       temp-a))
-		     (reprompt))
-		(:recursive-edit "Enter a recursive edit."
-				 (with-mark ((save dest-point))
-				   (do-recursive-edit)
-				   (move-mark dest-point save))
-				 (reprompt)))
-	      (redisplay)
-	      (move-mark mark-a (region-end diff-a))
-	      (move-mark mark-b (region-end diff-b))
-	      (move-mark temp-a mark-a)
-	      (unless (line-offset mark-a 1) (return))
-	      (unless (line-offset mark-b 1) (return))))))
-      (message "Done."))
-    (when delete-buffer-a
-      (delete-buffer delete-buffer-a)
-      (delete-buffer delete-buffer-b))))
-
-(defun get-srccom-buffers (first-prompt buffer-a buffer-b dest-buffer p)
-  (unless buffer-a
-    (setf buffer-a (prompt-for-buffer :prompt first-prompt
-				      :must-exist t
-				      :default (current-buffer))))
-  (unless buffer-b
-    (setf buffer-b (prompt-for-buffer :prompt "With buffer: "
-				      :must-exist t
-				      :default (previous-buffer))))
-  (unless dest-buffer
-    (setf dest-buffer
-	  (prompt-for-buffer :prompt "Putting results in buffer: "
-			     :must-exist nil
-			     :default-string
-			     (value source-compare-default-destination))))
-  (if (stringp dest-buffer)
-      (setf dest-buffer (make-buffer dest-buffer))
-      (buffer-end (buffer-point dest-buffer)))
-  (setf (value source-compare-default-destination) (buffer-name dest-buffer))
-  (change-to-buffer dest-buffer)
-  (let* ((alt-buffer-a (if p (make-buffer (prin1-to-string (gensym)))))
-	 (alt-buffer-b (if alt-buffer-a
-			   (make-buffer (prin1-to-string (gensym))))))
-    (when alt-buffer-a
-      (ninsert-region (buffer-point alt-buffer-a)
-		      (copy-region (if (mark< (buffer-point buffer-a)
-					      (buffer-mark buffer-a))
-				       (region (buffer-point buffer-a)
-					       (buffer-mark buffer-a))
-				       (region (buffer-mark buffer-a)
-					       (buffer-point buffer-a)))))
-      (ninsert-region (buffer-point alt-buffer-b)
-		      (copy-region (if (mark< (buffer-point buffer-b)
-					      (buffer-mark buffer-b))
-				       (region (buffer-point buffer-b)
-					       (buffer-mark buffer-b))
-				       (region (buffer-mark buffer-b)
-					       (buffer-point buffer-b))))))
-    (values buffer-a buffer-b (current-point) alt-buffer-a alt-buffer-b)))
-#|
-(defun get-srccom-buffers (first-prompt buffer-a buffer-b dest-buffer p)
-  (unless buffer-a
-    (setf buffer-a (prompt-for-buffer :prompt first-prompt
-				      :must-exist t
-				      :default (current-buffer))))
-  (unless buffer-b
-    (setf buffer-b (prompt-for-buffer :prompt "With buffer: "
-				      :must-exist t
-				      :default (previous-buffer))))
-  (unless dest-buffer
-    (let* ((name (value source-compare-default-destination))
-	   (temp-default (getstring name *buffer-names*))
-	   (default (or temp-default (make-buffer name))))
-      (setf dest-buffer (prompt-for-buffer :prompt "Putting results in buffer: "
-					   :must-exist nil
-					   :default default))
-      ;; Delete the default buffer if it did already exist and was not chosen.
-      (unless (or (eq dest-buffer default) temp-default)
-	(delete-buffer default))))
-  (if (stringp dest-buffer)
-      (setf dest-buffer (make-buffer dest-buffer))
-      (buffer-end (buffer-point dest-buffer)))
-  (setf (value source-compare-default-destination) (buffer-name dest-buffer))
-  (change-to-buffer dest-buffer)
-  (let* ((alt-buffer-a (if p (make-buffer (prin1-to-string (gensym)))))
-	 (alt-buffer-b (if alt-buffer-a
-			   (make-buffer (prin1-to-string (gensym))))))
-    (when alt-buffer-a
-      (ninsert-region (buffer-point alt-buffer-a)
-		      (copy-region (if (mark< (buffer-point buffer-a)
-					      (buffer-mark buffer-a))
-				       (region (buffer-point buffer-a)
-					       (buffer-mark buffer-a))
-				       (region (buffer-mark buffer-a)
-					       (buffer-point buffer-a)))))
-      (ninsert-region (buffer-point alt-buffer-b)
-		      (copy-region (if (mark< (buffer-point buffer-b)
-					      (buffer-mark buffer-b))
-				       (region (buffer-point buffer-b)
-					       (buffer-mark buffer-b))
-				       (region (buffer-mark buffer-b)
-					       (buffer-point buffer-b))))))
-    (values buffer-a buffer-b (current-point) alt-buffer-a alt-buffer-b)))
-|#
-
-
-;;;; Functions that find the differences between two buffers.
-
-(defun srccom-find-difference (mark-a mark-b)
-  "Returns as multiple values two regions of text that are different in the
-  lines following Mark-A and Mark-B.  If no difference is encountered, Nil
-  is returned."
-  (multiple-value-bind (diff-a diff-b)
-		       (srccom-different-lines mark-a mark-b)
-    (when diff-a
-      (multiple-value-bind (same-a same-b)
-			   (srccom-similar-lines diff-a diff-b)
-	(values (region diff-a same-a)
-		(region diff-b same-b))))))
-
-;;; These are set by SRCCOM-CHOOSE-COMPARISON-FUNCTIONS depending on something.
-;;;
-(defvar *srccom-line=* nil)
-(defvar *srccom-line-next* nil)
-
-(defun srccom-different-lines (mark-a mark-b)
-  "Returns as multiple values two marks pointing to the first different lines
-  found after Mark-A and Mark-B.  Nil is returned if no different lines are
-  found."
-  (do ((line-a (mark-line mark-a) (funcall *srccom-line-next* line-a))
-       (mark-a (copy-mark mark-a))
-       (line-b (mark-line mark-b) (funcall *srccom-line-next* line-b))
-       (mark-b (copy-mark mark-b)))
-      (())
-    (cond ((null line-a)
-	   (return (if line-b
-		       (values mark-a mark-b))))
-	  ((null line-b)
-	   (return (values mark-a mark-b))))
-    (line-start mark-a line-a)
-    (line-start mark-b line-b)
-    (unless (funcall *srccom-line=* line-a line-b)
-      (return (values mark-a mark-b)))))
-
-(defun srccom-similar-lines (mark-a mark-b)
-  "Returns as multiple values two marks pointing to the first similar lines
-  found after Mark-A and Mark-B."
-  (do ((line-a (mark-line mark-a) (funcall *srccom-line-next* line-a))
-       (cmark-a (copy-mark mark-a))
-       (line-b (mark-line mark-b) (funcall *srccom-line-next* line-b))
-       (cmark-b (copy-mark mark-b))
-       (temp)
-       (window-size (value source-compare-number-of-lines)))
-      (())
-    ;; If we hit the end of one buffer, then the difference extends to the end
-    ;; of both buffers.
-    (if (or (null line-a) (null line-b))
-	(return
-	 (values
-	  (buffer-end-mark (line-buffer (mark-line mark-a)))
-	  (buffer-end-mark (line-buffer (mark-line mark-b))))))
-    (line-start cmark-a line-a)
-    (line-start cmark-b line-b)
-    ;; Three cases:
-    ;;  1] Difference will be same length in A and B.  If so, Line-A = Line-B.
-    ;;  2] Difference will be longer in A.  If so, Line-A = something in B.
-    ;;  3] Difference will be longer in B.  If so, Line-B = something in A.
-    (cond ((and (funcall *srccom-line=* line-a line-b)
-		(srccom-check-window line-a line-b window-size))
-	   (return (values cmark-a cmark-b)))
-	  ((and (setq temp (srccom-line-in line-a mark-b cmark-b))
-		(srccom-check-window line-a temp window-size))
-	   (return (values cmark-a (line-start cmark-b temp))))
-	  ((and (setq temp (srccom-line-in line-b mark-a cmark-a))
-		(srccom-check-window temp line-b window-size))
-	   (return (values (line-start cmark-a temp) cmark-b))))))
-
-(defun srccom-line-in (line start end)
-  "Checks to see if there is a Line Srccom-Line= to the given Line in the
-  region delimited by the Start and End marks.  Returns that line if so, or
-  Nil if there is none."
-  (do ((current (mark-line start) (funcall *srccom-line-next* current))
-       (terminus (funcall *srccom-line-next* (mark-line end))))
-      ((eq current terminus) nil)
-    (if (funcall *srccom-line=* line current)
-	(return current))))
-
-(defun srccom-check-window (line-a line-b count)
-  "Verifies that the Count lines following Line-A and Line-B are Srccom-Line=.
-  If so, returns T.  Otherwise returns Nil."
-  (do ((line-a line-a (funcall *srccom-line-next* line-a))
-       (line-b line-b (funcall *srccom-line-next* line-b))
-       (index 0 (1+ index)))
-      ((= index count) t)
-    (if (not (funcall *srccom-line=* line-a line-b))
-	(return nil))))
-
-
-
-;;;; Functions that control the comparison of text.
-
-;;; SRCCOM-CHOOSE-COMPARISON-FUNCTIONS -- Internal.
-;;;
-;;; This initializes utility functions for comparison commands based on Hemlock
-;;; variables.
-;;;
-(defun srccom-choose-comparison-functions ()
-  (setf *srccom-line=*
-	(if (value source-compare-ignore-case)
-	    (if (value source-compare-ignore-indentation)
-		#'srccom-ignore-case-and-indentation-line=
-		#'srccom-case-insensitive-line=)
-	    (if (value source-compare-ignore-indentation)
-		#'srccom-ignore-indentation-case-sensitive-line=
-		#'srccom-case-sensitive-line=)))
-  (setf *srccom-line-next*
-	(if (value source-compare-ignore-extra-newlines)
-	    #'srccom-line-next-ignoring-extra-newlines
-	    #'line-next)))
-#|
-(defun srccom-choose-comparison-functions ()
-  "This function should be called by a ``top level'' source compare utility
-  to initialize the lower-level functions that compare text."
-  (setf *srccom-line=*
-	(if (value source-compare-ignore-case)
-	    #'srccom-case-insensitive-line=
-	    #'srccom-case-sensitive-line=))
-  (setf *srccom-line-next*
-	(if (value source-compare-ignore-extra-newlines)
-	    #'srccom-line-next-ignoring-extra-newlines
-	    #'line-next)))
-|#
-
-;;; SRCCOM-LINE-NEXT-IGNORING-EXTRA-NEWLINES -- Internal.
-;;;
-;;; This is the value of *srccom-line-next* when "Source Compare Ignore Extra
-;;; Newlines" is non-nil.
-;;;
-(defun srccom-line-next-ignoring-extra-newlines (line)
-  (if (null line) nil
-      (do ((line (line-next line) (line-next line)))
-	  ((or (null line) (not (blank-line-p line))) line))))
-
-;;; SRCCOM-IGNORE-CASE-AND-INDENTATION-LINE=	   -- Internal.
-;;; SRCCOM-CASE-INSENSITIVE-LINE=		   -- Internal.
-;;; SRCCOM-IGNORE-INDENTATION-CASE-SENSITIVE-LINE= -- Internal.
-;;; SRCCOM-CASE-SENSITIVE-LINE=			   -- Internal.
-;;;
-;;; These are the value of *srccom-line-=* depending on the orthogonal values
-;;; of "Source Compare Ignore Case" and "Source Compare Ignore Indentation".
-;;;
-(macrolet ((def-line= (name test &optional ignore-indentation)
-	     `(defun ,name (line-a line-b)
-		(or (eq line-a line-b)		; if they're both NIL
-		    (and line-a
-			 line-b
-			 (let* ((chars-a (line-string line-a))
-				(len-a (length chars-a))
-				(chars-b (line-string line-b))
-				(len-b (length chars-b)))
-			   (declare (simple-string chars-a chars-b))
-			   (cond
-			    ((and (= len-a len-b)
-				  (,test chars-a chars-b)))
-			    ,@(if ignore-indentation
-				  `((t
-				     (flet ((frob (chars len)
-					      (dotimes (i len nil)
-						(let ((char (schar chars i)))
-						  (unless
-						      (or (char= char #\space)
-							  (char= char #\tab))
-						    (return i))))))
-				       (let ((i (frob chars-a len-a))
-					     (j (frob chars-b len-b)))
-					 (if (and i j)
-					     (,test chars-a chars-b
-						    :start1 i :end1 len-a
-						    :start2 j :end2 len-b)
-					     )))))))))))))
-
-  (def-line= srccom-ignore-case-and-indentation-line= string-equal t)
-
-  (def-line= srccom-case-insensitive-line= string-equal)
-
-  (def-line= srccom-ignore-indentation-case-sensitive-line= string= t)
-
-  (def-line= srccom-case-sensitive-line= string=))
-
-#|
-;;; SRCCOM-CASE-INSENSITIVE-LINE= -- Internal.
-;;;
-;;; Returns t if line-a and line-b contain STRING-EQUAL text.
-;;;
-(defun srccom-case-insensitive-line= (line-a line-b)
-  (or (eq line-a line-b)		; if they're both NIL
-      (and line-a
-	   line-b
-	   (let ((chars-a (line-string line-a))
-		 (chars-b (line-string line-b)))
-	     (declare (simple-string chars-a chars-b))
-	     (and (= (length chars-a) (length chars-b))
-		  (string-equal chars-a chars-b))))))
-
-;;; SRCCOM-CASE-SENSITIVE-LINE= -- Internal.
-;;;
-;;; Returns t if line-a and line-b contain STRING= text.
-;;;
-(defun srccom-case-sensitive-line= (line-a line-b)
-  (or (eq line-a line-b)		; if they're both NIL
-      (and line-a
-	   line-b
-	   (let ((chars-a (line-string line-a))
-		 (chars-b (line-string line-b)))
-	     (declare (simple-string chars-a chars-b))
-	     (and (= (length chars-a) (length chars-b))
-		  (string= chars-a chars-b))))))
-|#
diff --git a/hemlock/streams.lisp b/hemlock/streams.lisp
deleted file mode 100644
index 0cfea3093e7fd296a3ce6b207bcc5c373d954584..0000000000000000000000000000000000000000
--- a/hemlock/streams.lisp
+++ /dev/null
@@ -1,297 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 definitions of various types of streams used
-;;; in Hemlock.  They are implementation dependant, but should be
-;;; portable to all implementations based on Spice Lisp with little
-;;; difficulty.
-;;;
-;;; Written by Skef Wholey and Rob MacLachlan.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(make-hemlock-output-stream
-	  hemlock-region-stream hemlock-region-stream-p
-	  hemlock-output-stream make-hemlock-region-stream
-	  hemlock-output-stream-p make-kbdmac-stream
-	  modify-kbdmac-stream))
-
-(defstruct (hemlock-output-stream
-	    (:include stream
-		      (:misc #'hemlock-output-misc))
-	    (:print-function %print-hemlock-output-stream)
-	    (:constructor internal-make-hemlock-output-stream ()))
-  ;;
-  ;; The mark we insert at.
-  mark)
-
-(defun %print-hemlock-output-stream (s stream d)
-  (declare (ignore d s))
-  (write-string "#<Hemlock output stream>" stream))
-
-(defun make-hemlock-output-stream (mark &optional (buffered :line))
-  "Returns an output stream whose output will be inserted at the Mark.
-  Buffered, which indicates to what extent the stream may be buffered
-  is one of the following:
-   :None  -- The screen is brought up to date after each stream operation.
-   :Line  -- The screen is brought up to date when a newline is written.
-   :Full  -- The screen is not updated except explicitly via Force-Output."
-  (modify-hemlock-output-stream (internal-make-hemlock-output-stream) mark
-                                buffered))
-
-
-(defun modify-hemlock-output-stream (stream mark buffered)
-  (unless (and (markp mark)
-	       (memq (mark-kind mark) '(:right-inserting :left-inserting)))
-    (error "~S is not a permanent mark." mark))
-  (setf (hemlock-output-stream-mark stream) mark)
-  (case buffered
-    (:none
-     (setf (lisp::stream-out stream) #'hemlock-output-unbuffered-out
-	   (lisp::stream-sout stream) #'hemlock-output-unbuffered-sout))
-    (:line
-     (setf (lisp::stream-out stream) #'hemlock-output-line-buffered-out
-	   (lisp::stream-sout stream) #'hemlock-output-line-buffered-sout))
-    (:full
-     (setf (lisp::stream-out stream) #'hemlock-output-buffered-out
-	   (lisp::stream-sout stream) #'hemlock-output-buffered-sout))
-    (t
-     (error "~S is a losing value for Buffered." buffered)))
-  stream)
-
-(defmacro with-left-inserting-mark ((var form) &body forms)
-  (let ((change (gensym)))
-    `(let* ((,var ,form)
-	    (,change (eq (mark-kind ,var) :right-inserting)))
-       (unwind-protect
-	   (progn
-	     (when ,change
-	       (setf (mark-kind ,var) :left-inserting))
-	     ,@forms)
-	 (when ,change
-	   (setf (mark-kind ,var) :right-inserting))))))
-
-(defun hemlock-output-unbuffered-out (stream character)
-  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
-    (insert-character mark character)
-    (redisplay-windows-from-mark mark)))
-
-(defun hemlock-output-unbuffered-sout (stream string start end)
-  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
-    (insert-string mark string start end)
-    (redisplay-windows-from-mark mark)))
-
-(defun hemlock-output-buffered-out (stream character)
-  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
-    (insert-character mark character)))
-
-(defun hemlock-output-buffered-sout (stream string start end)
-  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
-    (insert-string mark string start end)))
-
-(defun hemlock-output-line-buffered-out (stream character)
-  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
-    (insert-character mark character)
-    (when (char= character #\newline)
-      (redisplay-windows-from-mark mark))))
-
-(defun hemlock-output-line-buffered-sout (stream string start end)
-  (declare (simple-string string))
-  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
-    (insert-string mark string start end)
-    (when (find #\newline string :start start :end end)
-      (redisplay-windows-from-mark mark))))
-
-(defun hemlock-output-misc (stream operation &optional arg1 arg2)
-  (declare (ignore arg1 arg2))
-  (case operation
-    (:charpos (mark-charpos (hemlock-output-stream-mark stream)))
-    (:line-length
-     (let* ((buffer (line-buffer (mark-line (hemlock-output-stream-mark stream)))))
-       (when buffer
-	 (do ((w (buffer-windows buffer) (cdr w))
-	      (min most-positive-fixnum (min (window-width (car w)) min)))
-	     ((null w)
-	      (if (/= min most-positive-fixnum) min))))))
-    ((:finish-output :force-output)
-     (redisplay-windows-from-mark (hemlock-output-stream-mark stream)))
-    (:close (setf (hemlock-output-stream-mark stream) nil))
-    (:element-type 'string-char)))
-
-(defstruct (hemlock-region-stream
-	    (:include stream
-		      (:in #'region-in)
-		      (:misc #'region-misc)
-		      (:in-buffer (make-string lisp::in-buffer-length)))
-	    (:print-function %print-region-stream)
-	    (:constructor internal-make-hemlock-region-stream (region mark)))
-  ;;
-  ;; The region we read from.
-  region
-  ;;
-  ;; The mark pointing to the next character to read.
-  mark)
-
-(defun %print-region-stream (s stream d)
-  (declare (ignore s d))
-  (write-string "#<Hemlock region stream>" stream))
-
-(defun make-hemlock-region-stream (region)
-  "Returns an input stream that will return successive characters from the
-  given Region when asked for input."
-  (internal-make-hemlock-region-stream
-   region (copy-mark (region-start region) :right-inserting)))
-
-(defun modify-hemlock-region-stream (stream region)
-  (setf (hemlock-region-stream-region stream) region
-	(lisp::stream-in-index stream) lisp::in-buffer-length)
-  (let* ((mark (hemlock-region-stream-mark stream))
-	 (start (region-start region))
-	 (start-line (mark-line start)))
-    ;; Make sure it's dead.
-    (delete-mark mark)
-    (setf (mark-line mark) start-line  (mark-charpos mark) (mark-charpos start))
-    (push mark (line-marks start-line)))
-  stream)
-
-(defun region-readline (stream eof-errorp eof-value)
-  (close-line)
-  (let ((mark (hemlock-region-stream-mark stream))
-	(end (region-end (hemlock-region-stream-region stream))))
-    (cond ((mark>= mark end)
-	   (if eof-errorp
-	       (error "~A hit end of file." stream)
-	       (values eof-value nil)))
-	  ((eq (mark-line mark) (mark-line end))
-	   (let* ((limit (mark-charpos end))
-		  (charpos (mark-charpos mark))
-		  (dst-end (- limit charpos))
-		  (result (make-string dst-end)))
-	     (declare (simple-string result))
-	     (%sp-byte-blt (line-chars (mark-line mark)) charpos
-			   result 0 dst-end)
-	     (setf (mark-charpos mark) limit)
-	     (values result t)))
-	  ((= (mark-charpos mark) 0)
-	   (let* ((line (mark-line mark))
-		  (next (line-next line)))
-	     (always-change-line mark next)
-	     (values (line-chars line) nil)))
-	  (t
-	   (let* ((line (mark-line mark))
-		  (chars (line-chars line))
-		  (next (line-next line))
-		  (charpos (mark-charpos mark))
-		  (dst-end (- (length chars) charpos))
-		  (result (make-string dst-end)))
-	     (declare (simple-string chars result))
-	     (%sp-byte-blt chars charpos result 0 dst-end)
-	     (setf (mark-charpos mark) 0)
-	     (always-change-line mark next)
-	     (values result nil))))))
-
-(defun region-in (stream eof-errorp eof-value)
-  (close-line)
-  (let* ((mark (hemlock-region-stream-mark stream))
-	 (charpos (mark-charpos mark))
-	 (line (mark-line mark))
-	 (chars (line-chars line))
-	 (length (length chars))
-	 (last (region-end (hemlock-region-stream-region stream)))
-	 (last-line (mark-line last))
-	 (buffer (lisp::stream-in-buffer stream)) start len)
-    (declare (fixnum length charpos last-charpos start len)
-	     (simple-string chars))
-    (cond 
-     ((eq line last-line)
-      (let ((last-charpos (mark-charpos last)))
-	(setq len (- last-charpos charpos))
-	(cond
-	 ((>= charpos last-charpos)
-	  (if eof-errorp
-	      (error "~A hit end of file." stream) 
-	      (return-from region-in eof-value)))
-	 ((> len lisp::in-buffer-length)       
-	  (%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length)
-	  (setq start 0  len lisp::in-buffer-length))
-	 (t
-	  (setq start (- lisp::in-buffer-length len))
-	  (%sp-byte-blt chars charpos buffer start lisp::in-buffer-length)))))
-     ((line> line last-line)
-      (if eof-errorp
-	  (error "~a hit end of file." stream) 
-	  (return-from region-in eof-value)))
-     (t
-      (setq len (- length charpos))
-      (cond
-       ((< len lisp::in-buffer-length)
-	(let ((end (1- lisp::in-buffer-length)))
-	  (setq start (- lisp::in-buffer-length len 1))
-	  (%sp-byte-blt chars charpos buffer start end)
-	  (setf (schar buffer end) #\newline))
-	(incf len))
-       (t
-	(%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length)
-	(setq start 0  len lisp::in-buffer-length)))))
-    (setf (lisp::stream-in-index stream) (1+ start))
-    (character-offset mark len)
-    (schar buffer start)))
-
-(defun region-misc (stream operation &optional arg1 arg2)
-  (declare (ignore arg1 arg2))
-  (case operation
-    (:listen (mark< (hemlock-region-stream-mark stream)
-		    (region-end (hemlock-region-stream-region stream))))
-    (:read-line (region-readline stream arg1 arg2))
-    (:clear-input (move-mark
-                   (hemlock-region-stream-mark stream)
-                   (region-end (hemlock-region-stream-region stream))))
-    (:close
-     (delete-mark (hemlock-region-stream-mark stream))
-     (setf (hemlock-region-stream-region stream) nil))
-    (:element-type 'string-char)))
-
-;;;; Stuff to support keyboard macros.
-
-(defstruct (kbdmac-stream
-	    (:include editor-input
-		      (:get #'kbdmac-get)
-		      (:unget #'kbdmac-unget)
-		      (:listen #'kbdmac-listen))
-	    (:constructor make-kbdmac-stream ()))
-  buffer    ; The simple-vector that holds the characters.
-  index)    ; Index of the next character.
-
-(defun kbdmac-get (stream ignore-abort-attempts-p)
-  (declare (ignore ignore-abort-attempts-p))
-  (let ((index (kbdmac-stream-index stream)))
-    (setf (kbdmac-stream-index stream) (1+ index))
-    (setq *last-key-event-typed*
-	  (svref (kbdmac-stream-buffer stream) index))))
-
-(defun kbdmac-unget (ignore stream)
-  (declare (ignore ignore))
-  (if (plusp (kbdmac-stream-index stream))
-      (decf (kbdmac-stream-index stream))
-      (error "Nothing to unread.")))
-
-(defun kbdmac-listen (stream)
-  (declare (ignore stream))
-  t)
-
-;;; MODIFY-KBDMAC-STREAM  --  Internal
-;;;
-;;;    Bash the kbdmac-stream Stream so that it will return the Input.
-;;;
-(defun modify-kbdmac-stream (stream input)
-  (setf (kbdmac-stream-index stream) 0)
-  (setf (kbdmac-stream-buffer stream) input)
-  stream)
diff --git a/hemlock/struct-ed.lisp b/hemlock/struct-ed.lisp
deleted file mode 100644
index 07f692a49a7b49cb74af8a30fa12a9c8c03b0c09..0000000000000000000000000000000000000000
--- a/hemlock/struct-ed.lisp
+++ /dev/null
@@ -1,42 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/struct-ed.lisp,v 1.2 1991/02/08 16:38:13 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Structures used by constucts in the HEMLOCK package.
-;;;
-
-(in-package "HEMLOCK")
-
-;;; The server-info structure holds information about the connection to a
-;;; particular eval server.  For now, we don't separate the background I/O and
-;;; random compiler output.  The Notifications port and Terminal_IO will be the
-;;; same identical object.  This separation in the interface may be just
-;;; gratuitous pseudo-generality, but it doesn't hurt.
-;;;
-(defstruct (server-info
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (format stream "#<Server-Info for ~A>" (server-info-name s)))))
-  name			      ; String name of this server.
-  port			      ; Port we send requests to.
-			      ;  NullPort if no connection. 
-  notifications		      ; List of notification objects for operations
-			      ;  which have not yet completed.
-  ts-info		      ; Ts-Info structure of typescript we use in
-			      ;  "background" buffer.
-  buffer		      ; Buffer "background" typescript is in.
-  slave-ts		      ; Ts-Info used in "Slave Lisp" buffer
-			      ;  (formerly the "Lisp Listener" buffer).
-  slave-buffer		      ; "Slave Lisp" buffer for slave's *terminal-io*.
-  errors		      ; List of structures describing reported errors.
-  error-mark)		      ; Pointer after last error edited. 
diff --git a/hemlock/struct.lisp b/hemlock/struct.lisp
deleted file mode 100644
index 6152c4a8aaa73c568ad58691923c97580d7e3e7d..0000000000000000000000000000000000000000
--- a/hemlock/struct.lisp
+++ /dev/null
@@ -1,627 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;; Structures and assorted macros for Hemlock.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(mark mark-line mark-charpos markp region region-start region-end
-	  regionp buffer bufferp buffer-modes buffer-point buffer-writable
-	  buffer-delete-hook buffer-windows buffer-variables buffer-write-date
-	  region regionp region-start region-end window windowp window-height
-	  window-width window-display-start window-display-end window-point
-	  commandp command command-function command-documentation
-	  modeline-field modeline-field-p))
-
-
-;;;; Marks.
-
-(defstruct (mark (:print-function %print-hmark)
-		 (:predicate markp)
-		 (:copier nil)
-		 (:constructor internal-make-mark (line charpos %kind)))
-  "A Hemlock mark object.  See Hemlock Command Implementor's Manual for details."
-  line					; pointer to line
-  charpos				; character position
-  %kind)				; type of mark
-
-(setf (documentation 'markp 'function)
-  "Returns true if its argument is a Hemlock mark object, false otherwise.")
-(setf (documentation 'mark-line 'function)
-  "Returns line that a Hemlock mark points to.")
-(setf (documentation 'mark-charpos 'function)
-  "Returns the character position of a Hemlock mark.
-  A mark's character position is the index within the line of the character
-  following the mark.")
-
-(defstruct (font-mark (:print-function
-		       (lambda (s stream d)
-			 (declare (ignore d))
-			 (write-string "#<Hemlock Font-Mark \"" stream)
-			 (%print-before-mark s stream)
-			 (write-string "/\\" stream)
-			 (%print-after-mark s stream)
-			 (write-string "\">" stream)))
-		      (:include mark)
-		      (:copier nil)
-		      (:constructor internal-make-font-mark
-				    (line charpos %kind font)))
-  font)
-
-(defmacro fast-font-mark-p (s)
-  `(eq (svref ,s 0) 'font-mark))
-
-
-
-;;;; Regions, buffers, modeline fields.
-
-;;; The region object:
-;;;
-(defstruct (region (:print-function %print-hregion)
-		   (:predicate regionp)
-		   (:copier nil)
-		   (:constructor internal-make-region (start end)))
-  "A Hemlock region object.  See Hemlock Command Implementor's Manual for details."
-  start					; starting mark
-  end)					; ending mark
-
-(setf (documentation 'regionp 'function)
-  "Returns true if its argument is a Hemlock region object, Nil otherwise.")
-(setf (documentation 'region-end 'function)
-  "Returns the mark that is the end of a Hemlock region.")
-(setf (documentation 'region-start 'function)
-  "Returns the mark that is the start of a Hemlock region.")
-
-
-;;; The buffer object:
-;;;
-(defstruct (buffer (:constructor internal-make-buffer)
-		   (:print-function %print-hbuffer)
-		   (:copier nil)
-		   (:predicate bufferp))
-  "A Hemlock buffer object.  See Hemlock Command Implementor's Manual for details."
-  %name			      ; name of the buffer (a string)
-  %region		      ; the buffer's region
-  %pathname		      ; associated pathname
-  modes			      ; list of buffer's mode names
-  mode-objects		      ; list of buffer's mode objects
-  bindings		      ; buffer's command table
-  point			      ; current position in buffer
-  (%writable t)		      ; t => can alter buffer's region
-  (modified-tick -2)	      ; The last time the buffer was modified.
-  (unmodified-tick -1)	      ; The last time the buffer was unmodified
-  windows		      ; List of all windows into this buffer.
-  var-values		      ; the buffer's local variables
-  variables		      ; string-table of local variables
-  write-date		      ; File-Write-Date for pathname.
-  display-start		      ; Window display start when switching to buf.
-  %modeline-fields	      ; List of modeline-field-info's.
-  (delete-hook nil))	      ; List of functions to call upon deletion.
-
-(setf (documentation 'buffer-modes 'function)
-  "Return the list of the names of the modes active in a given buffer.")
-(setf (documentation 'buffer-point 'function)
-  "Return the mark that is the current focus of attention in a buffer.")
-(setf (documentation 'buffer-windows 'function)
-  "Return the list of windows that are displaying a given buffer.")
-(setf (documentation 'buffer-variables 'function)
-  "Return the string-table of the variables local to the specifed buffer.")
-(setf (documentation 'buffer-write-date 'function)
-  "Return in universal time format the write date for the file associated
-   with the buffer.  If the pathname is set, then this should probably
-   be as well.  Should be NIL if the date is unknown or there is no file.")
-(setf (documentation 'buffer-delete-hook 'function)
-  "This is the list of buffer specific functions that Hemlock invokes when
-   deleting this buffer.")
-
-
-;;; Modeline fields.
-;;;
-(defstruct (modeline-field (:print-function print-modeline-field)
-			   (:constructor %make-modeline-field
-					 (%name %function %width)))
-  "This is one item displayed in a Hemlock window's modeline."
-  %name		; EQL name of this field.
-  %function	; Function that returns a string for this field.
-  %width)	; Width to display this field in.
-
-(setf (documentation 'modeline-field-p 'function)
-      "Returns true if its argument is a modeline field object, nil otherwise.")
-
-(defstruct (modeline-field-info (:print-function print-modeline-field-info)
-				(:conc-name ml-field-info-)
-				(:constructor make-ml-field-info (field)))
-  field
-  (start nil)
-  (end nil))
-
-
-
-;;;; The mode object.
-
-(defstruct (mode-object (:predicate modep)
-			(:copier nil)
-			(:print-function %print-hemlock-mode))
-  name                   ; name of this mode
-  setup-function         ; setup function for this mode
-  cleanup-function       ; Cleanup function for this mode
-  bindings               ; The mode's command table.
-  transparent-p		 ; Are key-bindings transparent?
-  hook-name              ; The name of the mode hook.
-  major-p                ; Is this a major mode?
-  precedence		 ; The precedence for a minor mode.
-  character-attributes   ; Mode local character attributes
-  variables              ; String-table of mode variables
-  var-values             ; Alist for saving mode variables
-  documentation)         ; Introductory comments for mode describing commands.
-
-(defun %print-hemlock-mode (object stream depth)
-  (declare (ignore depth))
-  (write-string "#<Hemlock Mode \"" stream)
-  (write-string (mode-object-name object) stream)
-  (write-string "\">" stream))
-
-
-
-;;;; Variables.
-
-;;; This holds information about Hemlock variables, and the system stores
-;;; these structures on the property list of the variable's symbolic
-;;; representation under the 'hemlock-variable-value property.
-;;;
-(defstruct (variable-object
-	    (:print-function
-	     (lambda (object stream depth)
-	       (declare (ignore depth))
-	       (format stream "#<Hemlock Variable-Object ~S>"
-		       (variable-object-name object))))
-	    (:copier nil)
-	    (:constructor make-variable-object (documentation name)))
-  value		; The value of this variable.
-  hooks		; The hook list for this variable.
-  down		; The variable-object for the previous value.
-  documentation ; The documentation.
-  name)		; The string name.
-
-
-
-;;;; Windows, dis-lines, and font-changes.
-
-;;; The window object:
-;;;
-(defstruct (window (:constructor internal-make-window)
-		   (:predicate windowp)
-		   (:copier nil)
-		   (:print-function %print-hwindow))
-  "This structure implements a Hemlock window."
-  tick				; The last time this window was updated.
-  %buffer			; buffer displayed in this window.
-  height			; Height of window in lines.
-  width				; Width of the window in characters.
-  old-start			; The charpos of the first char displayed.
-  first-line			; The head of the list of dis-lines.
-  last-line			; The last dis-line displayed.
-  first-changed			; The first changed dis-line on last update.
-  last-changed			; The last changed dis-line.
-  spare-lines			; The head of the list of unused dis-lines
-  (old-lines 0)			; Slot used by display to keep state info
-  hunk				; The device hunk that displays this window.
-  display-start			; first character position displayed
-  display-end			; last character displayed
-  point				; Where the cursor is in this window.  
-  modeline-dis-line		; Dis-line for modeline display.
-  modeline-buffer		; Complete string of all modeline data.
-  modeline-buffer-len)		; Valid chars in modeline-buffer.
-
-(setf (documentation 'windowp 'function)
-  "Returns true if its argument is a Hemlock window object, Nil otherwise.")
-(setf (documentation 'window-height 'function)
-  "Return the height of a Hemlock window in character positions.")
-(setf (documentation 'window-width 'function)
-  "Return the width of a Hemlock window in character positions.")
-(setf (documentation 'window-display-start 'function)
-  "Return the mark which points before the first character displayed in
-  the supplied window.")
-(setf (documentation 'window-display-end 'function)
-  "Return the mark which points after the last character displayed in
-  the supplied window.")
-(setf (documentation 'window-point 'function)
-  "Return the mark that points to where the cursor is displayed in this
-  window.  When the window is made current, the Buffer-Point of this
-  window's buffer is moved to this position.  While the window is
-  current, redisplay makes this mark point to the same position as the
-  Buffer-Point of its buffer.")
-
-(defstruct (dis-line (:copier nil)
-		     (:constructor nil))
-  chars			      ; The line-image to be displayed.
-  (length 0 :type fixnum)     ; Length of line-image.
-  font-changes)		      ; Font-Change structures for changes in this line.
-
-(defstruct (window-dis-line (:copier nil)
-			    (:include dis-line)
-			    (:constructor make-window-dis-line (chars))
-			    (:conc-name dis-line-))
-  old-chars		      ; Line-Chars of line displayed.
-  line			      ; Line displayed.
-  (flags 0 :type fixnum)      ; Bit flags indicate line status.
-  (delta 0 :type fixnum)      ; # lines moved from previous position.
-  (position 0 :type fixnum)   ; Line # to be displayed on.
-  (end 0 :type fixnum))	      ; Index after last logical character displayed.
-
-(defstruct (font-change (:copier nil)
-			(:constructor make-font-change (next)))
-  x			      ; X position that change takes effect.
-  font			      ; Index into font-map of font to use.
-  next			      ; The next Font-Change on this dis-line.
-  mark)			      ; Font-Mark responsible for this change.
-
-
-
-;;;; Font family.
-
-(defstruct font-family
-  map			; Font-map for hunk.
-  height		; Height of char box includung VSP.
-  width			; Width of font.
-  baseline		; Pixels from top of char box added to Y.
-  cursor-width		; Pixel width of cursor.
-  cursor-height		; Pixel height of cursor.
-  cursor-x-offset	; Added to pos of UL corner of char box to get
-  cursor-y-offset)	; UL corner of cursor blotch.
-
-
-
-;;;; Attribute descriptors.
-
-(defstruct (attribute-descriptor
-	    (:copier nil)
-	    (:print-function %print-attribute-descriptor))
-  "This structure is used internally in Hemlock to describe a character
-  attribute."
-  name
-  keyword
-  documentation
-  vector
-  hooks
-  end-value)
-
-
-
-;;;; Commands.
-
-(defstruct (command (:constructor internal-make-command
-				  (%name documentation function))
-		    (:copier nil)
-		    (:predicate commandp)
-		    (:print-function %print-hcommand))
-  %name				   ;The name of the command
-  documentation			   ;Command documentation string or function
-  function			   ;The function which implements the command
-  %bindings)			   ;Places where command is bound
-
-(setf (documentation 'commandp 'function)
-  "Returns true if its argument is a Hemlock command object, Nil otherwise.")
-(setf (documentation 'command-documentation 'function)
-  "Return the documentation for a Hemlock command, given the command-object.
-  Command documentation may be either a string or a function.  This may
-  be set with Setf.")
-
-
-
-;;;; Random typeout streams.
-
-;;; These streams write to random typeout buffers for WITH-POP-UP-DISPLAY.
-;;;
-(defstruct (random-typeout-stream (:include stream)
-				  (:print-function print-random-typeout-stream)
-				  (:constructor
-				   make-random-typeout-stream (mark)))
-  mark		       ; The buffer point of the associated buffer.
-  window	       ; The hemlock window all this shit is in.
-  more-mark	       ; The mark that is not displayed when we need to more.
-  no-prompt	       ; T when we want to exit, still collecting output.
-  (first-more-p t))    ; T until the first time we more. Nil after.
-
-(defun print-random-typeout-stream (object stream ignore)
-  (declare (ignore ignore))
-  (format stream "#<Hemlock Random-Typeout-Stream ~S>"
-	  (buffer-name
-	   (line-buffer (mark-line (random-typeout-stream-mark object))))))
-
-
-
-;;;; Redisplay devices.
-
-;;; Devices contain monitor specific redisplay methods referenced by
-;;; redisplay independent code.
-;;;
-(defstruct (device (:print-function print-device)
-		   (:constructor %make-device))
-  name			; simple-string such as "concept" or "lnz".
-  init			; fun to call whenever going into the editor.
-			; args: device
-  exit			; fun to call whenever leaving the editor.
-			; args: device
-  smart-redisplay	; fun to redisplay a window on this device.
-			; args: window &optional recenterp
-  dumb-redisplay	; fun to redisplay a window on this device.
-			; args: window &optional recenterp
-  after-redisplay	; args: device
-			; fun to call at the end of redisplay entry points.
-  clear			; fun to clear the entire display.
-			; args: device
-  note-read-wait	; fun to somehow note on display that input is expected.
-			; args: on-or-off
-  put-cursor		; fun to put the cursor at (x,y) or (column,line).
-			; args: hunk &optional x y
-  show-mark		; fun to display the screens cursor at a certain mark.
-			; args: window x y time
-  next-window		; funs to return the next and previous window
-  previous-window	;    of some window.
-			; args: window
-  make-window		; fun to make a window on the screen.
-			; args: device start-mark
-			;       &optional modeline-string modeline-function
-  delete-window		; fun to remove a window from the screen.
-			; args: window
-  random-typeout-setup	; fun to prepare for random typeout.
-  			; args: device n
-  random-typeout-cleanup; fun to clean up after random typeout.
-  			; args: device degree
-  random-typeout-line-more ; fun to keep line-buffered streams up to date.
-  random-typeout-full-more ; fun to do full-buffered  more-prompting.
-			   ; args: # of newlines in the object just inserted
-			   ;    in the buffer.
-  force-output		; if non-nil, fun to force any output possibly buffered.
-  finish-output		; if non-nil, fun to force output and hand until done.
-  			; args: device window
-  beep			; fun to beep or flash the screen.
-  bottom-window-base    ; bottom text line of bottom window.
-  hunks)		; list of hunks on the screen.
-
-(defun print-device (obj str n)
-  (declare (ignore n))
-  (format str "#<Hemlock Device ~S>" (device-name obj)))
-
-
-(defstruct (bitmap-device #|(:print-function print-device)|#
-			  (:include device))
-  display)		      ; CLX display object.
-
-
-(defstruct (tty-device #|(:print-function print-device)|#
-		       (:constructor %make-tty-device)
-		       (:include device))
-  dumbp			; t if it does not have line insertion and deletion.
-  lines			; number of lines on device.
-  columns		; number of columns per line.
-  display-string	; fun to display a string of characters at (x,y).
-			; args: hunk x y string &optional start end 
-  standout-init         ; fun to put terminal in standout mode.
-			; args: hunk
-  standout-end          ; fun to take terminal out of standout mode.
-			; args: hunk
-  clear-lines		; fun to clear n lines starting at (x,y).
-			; args: hunk x y n
-  clear-to-eol		; fun to clear to the end of a line from (x,y).
-			; args: hunk x y
-  clear-to-eow		; fun to clear to the end of a window from (x,y).
-			; args: hunk x y
-  open-line		; fun to open a line moving lines below it down.
-			; args: hunk x y &optional n
-  delete-line		; fun to delete a line moving lines below it up.
-			; args: hunk x y &optional n
-  insert-string		; fun to insert a string in the middle of a line.
-			; args: hunk x y string &optional start end
-  delete-char		; fun to delete a character from the middle of a line.
-			; args: hunk x y &optional n
-  (cursor-x 0)		; column the cursor is in.
-  (cursor-y 0)		; line the cursor is on.
-  standout-init-string  ; string to put terminal in standout mode.
-  standout-end-string   ; string to take terminal out of standout mode.
-  clear-to-eol-string	; string to cause device to clear to eol at (x,y).
-  clear-string		; string to cause device to clear entire screen.
-  open-line-string	; string to cause device to open a blank line.
-  delete-line-string	; string to cause device to delete a line, moving
-			; lines below it up.
-  insert-init-string	; string to put terminal in insert mode.
-  insert-char-init-string ; string to prepare terminal for insert-mode character.
-  insert-char-end-string ; string to affect terminal after insert-mode character.
-  insert-end-string	; string to take terminal out of insert mode.
-  delete-init-string	; string to put terminal in delete mode.
-  delete-char-string	; string to delete a character.
-  delete-end-string	; string to take terminal out of delete mode.
-  init-string		; device init string.
-  cm-end-string		; takes device out of cursor motion mode.
-  (cm-x-add-char nil)	; char-code to unconditionally add to x coordinate.
-  (cm-y-add-char nil)	; char-code to unconditionally add to y coordinate.
-  (cm-x-condx-char nil)	; char-code threshold for adding to x coordinate.
-  (cm-y-condx-char nil)	; char-code threshold for adding to y coordinate.
-  (cm-x-condx-add-char nil) ; char-code to conditionally add to x coordinate.
-  (cm-y-condx-add-char nil) ; char-code to conditionally add to y coordinate.
-  cm-string1		; initial substring of cursor motion string.
-  cm-string2		; substring of cursor motion string between coordinates.
-  cm-string3		; substring of cursor motion string after coordinates.
-  cm-one-origin		; non-nil if need to add one to coordinates.
-  cm-reversep		; non-nil if need to reverse coordinates.
-  (cm-x-pad nil)	; nil, 0, 2, or 3 for places to pad.
-			; 0 sends digit-chars.
-  (cm-y-pad nil)	; nil, 0, 2, or 3 for places to pad.
-			; 0 sends digit-chars.
-  screen-image)		; vector device-lines long of strings
-			; device-columns long.
-
-
-
-;;;; Device screen hunks and window-group.
-
-;;; Window groups are used to keep track of the old width and height of a group
-;;; so that when a configure-notify event is sent, we can determine if the size
-;;; of the window actually changed or not.
-;;;
-(defstruct (window-group (:print-function %print-window-group)
-			 (:constructor
-			  make-window-group (xparent width height)))
-  xparent
-  width
-  height)
-
-(defun %print-window-group (object stream depth)
-  (declare (ignore object depth))
-  (format stream "#<Hemlock Window Group>"))
-
-;;; Device-hunks are used to claim a piece of the screen and for ordering
-;;; pieces of the screen.  Window motion primitives and splitting/merging
-;;; primitives use hunks.  Hunks are somewhat of an interface between the
-;;; portable and non-portable parts of screen management, between what the
-;;; user sees on the screen and how Hemlock internals deal with window
-;;; sequencing and creation.  Note: the echo area hunk is not hooked into
-;;; the ring of other hunks via the next and previous fields.
-;;;
-(defstruct (device-hunk (:print-function %print-device-hunk))
-  "This structure is used internally by Hemlock's screen management system."
-  window		; Window displayed in this hunk.
-  position		; Bottom Y position of hunk.
-  height		; Height of hunk in pixels or lines.
-  next			; Next and previous hunks.
-  previous
-  device)		; Display device hunk is on.
-
-(defun %print-device-hunk (object stream depth)
-  (declare (ignore depth))
-  (format stream "#<Hemlock Device-Hunk ~D+~D~@[, ~S~]>"
-	  (device-hunk-position object)
-	  (device-hunk-height object)
-	  (let* ((window (device-hunk-window object))
-		 (buffer (if window (window-buffer window))))
-	    (if buffer (buffer-name buffer)))))
-
-
-;;; Bitmap hunks.
-;;;
-;;; The lock field is no longer used.  If events could be handled while we
-;;; were in the middle of something with the hunk, then this could be set
-;;; for exclusion purposes.
-;;;
-(defstruct (bitmap-hunk #|(:print-function %print-device-hunk)|#
-			(:include device-hunk))
-  width			      ; Pixel width.
-  char-height	      	      ; Height of text body in characters.
-  char-width		      ; Width in characters.
-  xwindow		      ; X window for this hunk.
-  gcontext                    ; X gcontext for xwindow.
-  start			      ; Head of dis-line list (no dummy).
-  end			      ; Exclusive end, i.e. nil if nil-terminated.
-  modeline-dis-line	      ; Dis-line for modeline, or NIL if none.
-  modeline-pos		      ; Position of modeline in pixels.
-  (lock t)		      ; Something going on, set trashed if we're changed.
-  trashed 		      ; Something bad happened, recompute image.
-  font-family		      ; Font-family used in this window.
-  input-handler		      ; Gets hunk, char, x, y when char read.
-  changed-handler	      ; Gets hunk when size changed.
-  (thumb-bar-p nil)	      ; True if we draw a thumb bar in the top border.
-  window-group)		      ; The window-group to which this hunk belongs.
-
-
-;;; Terminal hunks.
-;;; 
-(defstruct (tty-hunk #|(:print-function %print-device-hunk)|#
-		     (:include device-hunk))
-  text-position		; Bottom Y position of text in hunk.
-  text-height)		; Number of lines of text.
-
-
-
-;;;; Some defsetfs:
-
-(defsetf buffer-writable %set-buffer-writable
-  "Sets whether the buffer is writable and invokes the Buffer Writable Hook.")
-(defsetf buffer-name %set-buffer-name
-  "Sets the name of a specified buffer, invoking the Buffer Name Hook.")
-(defsetf buffer-modified %set-buffer-modified
-  "Make a buffer modified or unmodified.")
-(defsetf buffer-pathname %set-buffer-pathname
-  "Sets the pathname of a buffer, invoking the Buffer Pathname Hook.")
-
-(defsetf getstring %set-string-table
-  "Sets the value for a string-table entry, making a new one if necessary.")
-
-(defsetf window-buffer %set-window-buffer
-  "Change the buffer a window is mapped to.")
-
-(lisp::define-setf-method value (var)
-  "Set the value of a Hemlock variable, calling any hooks."
-  (let ((svar (gensym)))
-    (values
-     ()
-     ()
-     (list svar)
-     `(%set-value ',var ,svar)
-     `(value ,var))))
-
-(defsetf variable-value (name &optional (kind :current) where) (new-value)
-  "Set the value of a Hemlock variable, calling any hooks."
-  `(%set-variable-value ,name ,kind ,where ,new-value))
-
-(defsetf variable-hooks (name &optional (kind :current) where) (new-value)
-  "Set the list of hook functions for a Hemlock variable."
-  `(%set-variable-hooks ,name ,kind ,where ,new-value))
-
-(defsetf variable-documentation (name &optional (kind :current) where) (new-value)
-  "Set a Hemlock variable's documentation."
-  `(%set-variable-documentation ,name ,kind ,where ,new-value))
-
-(defsetf buffer-minor-mode %set-buffer-minor-mode
-  "Turn a buffer minor mode on or off.")
-(defsetf buffer-major-mode %set-buffer-major-mode
-  "Set a buffer's major mode.")
-(defsetf previous-character %set-previous-character
-  "Sets the character to the left of the given Mark.")
-(defsetf next-character %set-next-character
-  "Sets the characters to the right of the given Mark.")
-(defsetf character-attribute %set-character-attribute
-  "Set the value for a character attribute.")
-(defsetf character-attribute-hooks %set-character-attribute-hooks
-  "Set the hook list for a Hemlock character attribute.")
-(defsetf ring-ref %set-ring-ref "Set an element in a ring.")
-(defsetf current-window %set-current-window "Set the current window.")
-(defsetf current-buffer %set-current-buffer
-  "Set the current buffer, doing necessary stuff.")
-(defsetf mark-kind %set-mark-kind "Used to set the kind of a mark.")
-(defsetf buffer-region %set-buffer-region "Set a buffer's region.")
-(defsetf command-name %set-command-name
-  "Change a Hemlock command's name.")
-(defsetf line-string %set-line-string
-  "Replace the contents of a line.")
-(defsetf last-command-type %set-last-command-type
-  "Set the Last-Command-Type for use by the next command.")
-(defsetf prefix-argument %set-prefix-argument
-  "Set the prefix argument for the next command.")
-(defsetf logical-key-event-p %set-logical-key-event-p
-  "Change what Logical-Char= returns for the specified arguments.")
-(defsetf window-font %set-window-font
-  "Change the font-object associated with a font-number in a window.")
-(defsetf default-font %set-default-font
-  "Change the font-object associated with a font-number in new windows.")
-
-(defsetf buffer-modeline-fields %set-buffer-modeline-fields
-  "Sets the buffer's list of modeline fields causing all windows into buffer
-   to be updated for the next redisplay.")
-(defsetf modeline-field-name %set-modeline-field-name
-  "Sets a modeline-field's name.  If one already exists with that name, an
-   error is signaled.")
-(defsetf modeline-field-width %set-modeline-field-width
-  "Sets a modeline-field's width and updates all the fields for all windows
-   in any buffer whose fields list contains the field.")
-(defsetf modeline-field-function %set-modeline-field-function
-  "Sets a modeline-field's function and updates this field for all windows in
-   any buffer whose fields list contains the field.")
diff --git a/hemlock/syntax.lisp b/hemlock/syntax.lisp
deleted file mode 100644
index fe69e9aad9d13d14b7e98e17f052b9a6972bc9b9..0000000000000000000000000000000000000000
--- a/hemlock/syntax.lisp
+++ /dev/null
@@ -1,571 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/syntax.lisp,v 1.1.1.4 1991/02/08 16:38:20 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Hemlock syntax table routines.
-;;;
-;;; Written by Rob MacLachlan.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(character-attribute-name
-	  defattribute character-attribute-documentation character-attribute
-	  character-attribute-hooks character-attribute-p shadow-attribute
-	  unshadow-attribute find-attribute reverse-find-attribute))
-
-;;;; Character attribute caching.
-;;;
-;;;    In order to permit the %SP-Find-Character-With-Attribute sub-primitive
-;;; to be used for a fast implementation of find-attribute and
-;;; reverse-find-attribute, there must be some way of translating 
-;;; attribute/test-function pairs into a attribute vector and a mask.
-;;;    What we do is maintain a eq-hash-cache of attribute/test-function
-;;; pairs.  If the desired pair is not in the cache then we reclaim an old
-;;; attribute bit in the bucket we hashed to and stuff it by calling the
-;;; test function on the value of the attribute for all characters.
-
-(defvar *character-attribute-cache* ()
-  "This is the cache used to translate attribute/test-function pairs to
-  attribute-vector/mask pairs for find-attribute and reverse-find-attribute.")
-
-(eval-when (compile eval)
-(defconstant character-attribute-cache-size 13
-  "The number of buckets in the *character-attribute-cache*.")
-(defconstant character-attribute-bucket-size 3
-  "The number of bits to use in each bucket of the
-  *character-attribute-cache*.")
-); eval-when (compile eval)
-
-;;;    In addition, since a common pattern in code which uses find-attribute
-;;; is to repeatedly call it with the same function and attribute, we
-;;; remember the last attribute/test-function pair that was used, and check
-;;; if it is the same pair beforehand, thus often avoiding the hastable lookup.
-;;;
-(defvar *last-find-attribute-attribute* ()
-  "The attribute which we last did a find-attribute on.")
-(defvar *last-find-attribute-function* ()
-  "The last test-function used for find-attribute.")
-(defvar *last-find-attribute-vector* ()
-  "The %SP-Find-Character-With-Attribute vector corresponding to the last
-  attribute/function pair used for find-attribute.")
-(defvar *last-find-attribute-mask* ()
-  "The the mask to use with *last-find-attribute-vector* to do a search
-  for the last attribute/test-function pair.")
-(defvar *last-find-attribute-end-wins* ()
-  "The the value of End-Wins for the last attribute/test-function pair.")
-
-
-(defvar *character-attributes* (make-hash-table :test #'eq)
-  "A hash table which translates character attributes to their values.")
-(defvar *last-character-attribute-requested* nil
-  "The last character attribute which was asked for, Do Not Bind.")
-(defvar *value-of-last-character-attribute-requested* nil
-  "The value of the most recent character attribute, Do Not Bind.")
-
-(proclaim '(special *character-attribute-names*))
-
-
-;;; Each bucket contains a list of character-attribute-bucket-size
-;;; bit-descriptors.
-;;;
-(defstruct (bit-descriptor)
-  function		      ; The test on the attribute.
-  attribute		      ; The attribute this is a test of.
-  (mask 0 :type fixnum)	      ; The mask for the corresponding bit.
-  vector		      ; The vector the bit is in.
-  end-wins)		      ; Is this test true of buffer ends?
-
-;;;
-;;; In a descriptor for an unused bit, the function is nil, preventing a
-;;; hit.  Whenever we change the value of an attribute for some character,
-;;; we need to flush the cache of any entries for that attribute.  Currently
-;;; we do this by mapping down the list of all bit descriptors.  Note that
-;;; we don't have to worry about GC, since this is just a hint.
-;;;
-(defvar *all-bit-descriptors* () "The list of all the bit descriptors.")
-
-(eval-when (compile eval)
-(defmacro allocate-bit (vec bit-num)
-  `(progn
-    (when (= ,bit-num 8)
-      (setq ,bit-num 0  ,vec (make-array 256 :element-type '(mod 256))))
-    (car (push (make-bit-descriptor
-		:vector ,vec
-		:mask (ash 1 (prog1 ,bit-num (incf ,bit-num))))
-	       *all-bit-descriptors*)))))
-;;;    
-(defun %init-syntax-table ()
-  (let ((tab (make-array character-attribute-cache-size))
-	(bit-num 8) vec)
-    (setq *character-attribute-cache* tab)
-    (dotimes (c character-attribute-cache-size)
-      (setf (svref tab c)
-	    (do ((i 0 (1+ i))
-		 (res ()))
-		((= i character-attribute-bucket-size) res)
-	      (push (allocate-bit vec bit-num) res))))))
-
-(eval-when (compile eval)
-(defmacro hash-it (attribute function)
-  `(abs (rem (logxor (ash (lisp::%sp-make-fixnum ,attribute) -3)
-		     (lisp::%sp-make-fixnum ,function))
-	     character-attribute-cache-size)))
-
-;;; CACHED-ATTRIBUTE-LOOKUP  --  Internal
-;;;
-;;;    Sets Vector and Mask such that they can be used as arguments
-;;; to %sp-find-character-with-attribute to effect a search with attribute 
-;;; Attribute and test Function.  If the function and attribute
-;;; are the same as the last ones then we just set them to that, otherwise
-;;; we do the hash-cache lookup and update the *last-find-attribute-<mumble>*
-;;;
-(defmacro cached-attribute-lookup (attribute function vector mask end-wins)
-  `(if (and (eq ,function *last-find-attribute-function*)
-	    (eq ,attribute *last-find-attribute-attribute*))
-       (setq ,vector *last-find-attribute-vector*
-	     ,mask *last-find-attribute-mask*
-	     ,end-wins *last-find-attribute-end-wins*)
-       (let ((bit (svref *character-attribute-cache*
-			 (hash-it ,attribute ,function))))
-	 ,(do ((res `(multiple-value-setq (,vector ,mask ,end-wins)
-		       (new-cache-attribute ,attribute ,function))
-		    `(let ((b (car bit)))
-		       (cond
-			((and (eq (bit-descriptor-function b)
-				  ,function)
-			      (eq (bit-descriptor-attribute b)
-				  ,attribute))
-			 (setq ,vector (bit-descriptor-vector b)
-			       ,mask (bit-descriptor-mask b)
-			       ,end-wins (bit-descriptor-end-wins b)))
-			(t
-			 (setq bit (cdr bit)) ,res))))
-	       (count 0 (1+ count)))
-	      ((= count character-attribute-bucket-size) res))
-	 (setq *last-find-attribute-attribute* ,attribute
-	       *last-find-attribute-function* ,function
-	       *last-find-attribute-vector* ,vector
-	       *last-find-attribute-mask* ,mask
-	       *last-find-attribute-end-wins* ,end-wins))))
-); eval-when (compile eval)
-
-;;; NEW-CACHE-ATTRIBUTE  --  Internal
-;;;
-;;;    Pick out an old attribute to punt out of the cache and put in the
-;;; new one.  We pick a bit off of the end of the bucket and pull it around
-;;; to the beginning to get a degree of LRU'ness.
-;;;
-(defun new-cache-attribute (attribute function)
-  (let* ((hash (hash-it attribute function))
-	 (values (or (gethash attribute *character-attributes*)
-		     (error "~S is not a defined character attribute."
-			    attribute)))
-	 (bucket (svref *character-attribute-cache* hash))
-	 (bit (nthcdr (- character-attribute-bucket-size 2) bucket))
-	 (end-wins (funcall function (attribute-descriptor-end-value values))))
-    (shiftf bit (cdr bit) nil)
-    (setf (svref *character-attribute-cache* hash) bit
-	  (cdr bit) bucket  bit (car bit))
-    (setf (bit-descriptor-attribute bit) attribute
-	  (bit-descriptor-function bit) function
-	  (bit-descriptor-end-wins bit) end-wins)
-    (setq values (attribute-descriptor-vector values))
-    (do ((mask (bit-descriptor-mask bit))
-	 (fun (bit-descriptor-function bit))
-	 (vec (bit-descriptor-vector bit))
-	 (i 0 (1+ i)))
-	((= i syntax-char-code-limit) (values vec mask end-wins))
-      (declare (type (simple-array (mod 256)) vec))
-      (if (funcall fun (aref (the simple-array values) i))
-	  (setf (aref vec i) (logior (aref vec i) mask))
-	  (setf (aref vec i) (logandc2 (aref vec i) mask))))))
-
-(defun %print-attribute-descriptor (object stream depth)
-  (declare (ignore depth))
-  (format stream "#<Hemlock Attribute-Descriptor ~S>"
-	  (attribute-descriptor-name object)))
-
-;;; DEFATTRIBUTE  --  Public
-;;;
-;;;    Make a new vector of some type and enter it in the table.
-;;;
-(defun defattribute (name documentation &optional (type '(mod 2))
-			  (initial-value 0))
-  "Define a new Hemlock character attribute with named Name with
-  the supplied Documentation, Type and Initial-Value.  Type
-  defaults to (mod 2) and Initial-Value defaults to 0."
-  (setq name (coerce name 'simple-string))
-  (let* ((attribute (string-to-keyword name))
-	 (new (make-attribute-descriptor
-	       :vector (make-array syntax-char-code-limit
-				   :element-type type
-				   :initial-element initial-value)
-	       :name name
-	       :keyword attribute
-	       :documentation documentation
-	       :end-value initial-value)))
-    (when (gethash attribute *character-attributes*)
-      (warn "Character Attribute ~S is being redefined." name))
-    (setf (getstring name *character-attribute-names*) attribute)
-    (setf (gethash attribute *character-attributes*) new))
-  name)
-
-;;; WITH-ATTRIBUTE  --  Internal
-;;;
-;;;    Bind obj to the attribute descriptor corresponding to symbol,
-;;; giving error if it is not a defined attribute.
-;;;
-(eval-when (compile eval)
-(defmacro with-attribute (symbol &body forms)
-  `(let ((obj (gethash ,symbol *character-attributes*)))
-     (unless obj
-       (error "~S is not a defined character attribute." ,symbol))
-     ,@forms))
-); eval-when (compile eval)
-
-(defun character-attribute-name (attribute)
-  "Return the string-name of the character-attribute Attribute."
-  (with-attribute attribute
-    (attribute-descriptor-name obj)))
-
-(defun character-attribute-documentation (attribute)
-  "Return the documentation for the character-attribute Attribute."
-  (with-attribute attribute
-    (attribute-descriptor-documentation obj)))
-
-(defun character-attribute-hooks (attribute)
-  "Return the hook-list for the character-attribute Attribute.  This can
-  be set with Setf."
-  (with-attribute attribute
-    (attribute-descriptor-hooks obj)))
-
-(defun %set-character-attribute-hooks (attribute new-value)
-  (with-attribute attribute
-    (setf (attribute-descriptor-hooks obj) new-value)))
-
-(proclaim '(special *last-character-attribute-requested*
-		    *value-of-last-character-attribute-requested*))
-
-;;; CHARACTER-ATTRIBUTE  --  Public
-;;;
-;;;    Return the value of a character attribute for some character.
-;;;
-(proclaim '(inline character-attribute))
-(defun character-attribute (attribute character)
-  "Return the value of the the character-attribute Attribute for Character.
-  If Character is Nil then return the end-value."
-  (if (and (eq attribute *last-character-attribute-requested*) character)
-      (aref (the simple-array *value-of-last-character-attribute-requested*)
-	    (syntax-char-code character))
-      (sub-character-attribute attribute character)))
-;;;
-(defun sub-character-attribute (attribute character)
-  (with-attribute attribute
-    (setq *last-character-attribute-requested* attribute)
-    (setq *value-of-last-character-attribute-requested*
-	  (attribute-descriptor-vector obj))
-    (if character
-	(aref (the simple-array *value-of-last-character-attribute-requested*)
-	      (syntax-char-code character))
-	(attribute-descriptor-end-value obj))))
-
-;;; CHARACTER-ATTRIBUTE-P
-;;;
-;;;    Look up attribute in table.
-;;;
-(defun character-attribute-p (symbol)
-  "Return true if Symbol is the symbol-name of a character-attribute, Nil
-  otherwise."
-  (not (null (gethash symbol *character-attributes*))))
-
-
-;;; %SET-CHARACTER-ATTRIBUTE  --  Internal
-;;;
-;;;    Set the value of a character attribute.
-;;;
-(defun %set-character-attribute (attribute character new-value)
-  (with-attribute attribute
-    (invoke-hook ed::character-attribute-hook attribute character new-value)
-    (invoke-hook (attribute-descriptor-hooks obj) attribute character new-value)
-    (cond
-     ;;
-     ;; Setting the value for a real character.
-     (character
-      (let ((value (attribute-descriptor-vector obj))
-	    (code (syntax-char-code character)))
-	(declare (type (simple-array *) value))
-	(dolist (bit *all-bit-descriptors*)
-	  (when (eq (bit-descriptor-attribute bit) attribute)
-	    (let ((vec (bit-descriptor-vector bit)))
-	      (declare (type (simple-array (mod 256)) vec))
-	      (setf (aref vec code)
-		    (if (funcall (bit-descriptor-function bit) new-value)
-			(logior (bit-descriptor-mask bit) (aref vec code))
-			(logandc1 (bit-descriptor-mask bit) (aref vec code)))))))
-	(setf (aref value code) new-value)))
-     ;;
-     ;; Setting the magical end-value.
-     (t
-      (setf (attribute-descriptor-end-value obj) new-value)
-      (dolist (bit *all-bit-descriptors*)
-	(when (eq (bit-descriptor-attribute bit) attribute)
-	  (setf (bit-descriptor-end-wins bit)
-		(funcall (bit-descriptor-function bit) new-value))))
-      new-value))))
-
-(eval-when (compile eval)
-;;; swap-one-attribute  --  Internal
-;;;
-;;;    Install the mode-local values described by Vals for Attribute, whose
-;;; representation vector is Value.
-;;;
- (defmacro swap-one-attribute (attribute value vals hooks)
-  `(progn
-    ;; Fix up any cached attribute vectors.
-    (dolist (bit *all-bit-descriptors*)
-      (when (eq ,attribute (bit-descriptor-attribute bit))
-	(let ((fun (bit-descriptor-function bit))
-	      (vec (bit-descriptor-vector bit))
-	      (mask (bit-descriptor-mask bit)))
-	  (declare (type (simple-array (mod 256)) vec)
-		   (fixnum mask))
-	  (dolist (char ,vals)
-	    (setf (aref vec (car char))
-		  (if (funcall fun (cdr char))
-		      (logior mask (aref vec (car char)))
-		      (logandc1 mask (aref vec (car char)))))))))
-    ;; Invoke the attribute-hook.
-    (dolist (hook ,hooks)
-      (dolist (char ,vals)
-	(funcall hook ,attribute (code-char (car char)) (cdr char))))
-    ;; Fix up the value vector.
-    (dolist (char ,vals)
-      (rotatef (aref ,value (car char)) (cdr char)))))
-); eval-when (compile eval)
-
-
-;;; SWAP-CHAR-ATTRIBUTES  --  Internal
-;;;
-;;;    Swap the current values of character attributes and the ones
-;;;specified by "mode".  This is used in Set-Major-Mode.
-;;;
-(defun swap-char-attributes (mode)
-  (dolist (attribute (mode-object-character-attributes mode))
-    (let* ((obj (car attribute))
-	   (sym (attribute-descriptor-keyword obj))
-	   (value (attribute-descriptor-vector obj))
-	   (hooks (attribute-descriptor-hooks obj)))
-      (declare (simple-array value))
-      (swap-one-attribute sym value (cdr attribute) hooks))))
-
-
-
-(proclaim '(special *mode-names* *current-buffer*))
-
-;;; SHADOW-ATTRIBUTE  --  Public
-;;;
-;;;    Stick mode character attribute information in the mode object.
-;;;
-(defun shadow-attribute (attribute character value mode)
-  "Make a mode specific character attribute value.  The value of
-  Attribute for Character when we are in Mode will be Value."
-  (let ((desc (gethash attribute *character-attributes*))
-	(obj (getstring mode *mode-names*)))
-    (unless desc
-      (error "~S is not a defined Character Attribute." attribute))
-    (unless obj (error "~S is not a defined Mode." mode))
-    (let* ((current (assq desc (mode-object-character-attributes obj)))
-	   (code (syntax-char-code character))
-	   (hooks (attribute-descriptor-hooks desc))
-	   (vec (attribute-descriptor-vector desc))
-	   (cons (cons code value)))
-      (declare (simple-array vec))
-      (if current
-	  (let ((old (assq code (cdr current))))
-	    (if old
-		(setf (cdr old) value  cons old)
-		(push cons (cdr current))))
-	  (push (list desc cons)
-		(mode-object-character-attributes obj)))
-      (when (memq obj (buffer-mode-objects *current-buffer*))
-	(let ((vals (list cons)))
-	  (swap-one-attribute attribute vec vals hooks)))
-      (invoke-hook ed::shadow-attribute-hook attribute character value mode)))
-  attribute)
-
-;;; UNSHADOW-ATTRIBUTE  --  Public
-;;;
-;;;    Nuke a mode character attribute.
-;;;
-(defun unshadow-attribute (attribute character mode)
-  "Make the value of Attribte for Character no longer shadowed in Mode."
-  (let ((desc (gethash attribute *character-attributes*))
-	(obj (getstring mode *mode-names*)))
-    (unless desc
-      (error "~S is not a defined Character Attribute." attribute))
-    (unless obj
-      (error "~S is not a defined Mode." mode))
-    (invoke-hook ed::shadow-attribute-hook mode attribute character)
-    (let* ((value (attribute-descriptor-vector desc))
-	   (hooks (attribute-descriptor-hooks desc))
-	   (current (assq desc (mode-object-character-attributes obj)))
-	   (char (assq (syntax-char-code character) (cdr current))))
-      (declare (simple-array value))
-      (unless char
-	(error "Character Attribute ~S is not defined for character ~S ~
-	       in Mode ~S." attribute character mode))
-      (when (memq obj (buffer-mode-objects *current-buffer*))
-	(let ((vals (list char)))
-	  (swap-one-attribute attribute value vals hooks)))
-      (setf (cdr current) (delete char (the list (cdr current))))))
-  attribute)
-
-
-;;; NOT-ZEROP, the default test function for find-attribute etc.
-;;;
-(defun not-zerop (n)
-  (not (zerop n)))
-
-;;; find-attribute  --  Public
-;;;
-;;;    Do hairy cache lookup to find a find-character-with-attribute style
-;;; vector that we can use to do the search.
-;;;
-(eval-when (compile eval)
-(defmacro normal-find-attribute (line start result vector mask)
-  `(let ((chars (line-chars ,line)))
-     (setq ,result (%sp-find-character-with-attribute
-		   chars ,start (strlen chars) ,vector ,mask))))
-;;;
-(defmacro cache-find-attribute (start result vector mask)
-  `(let ((gap (- right-open-pos left-open-pos)))
-     (declare (fixnum gap))
-     (cond
-      ((>= ,start left-open-pos)
-       (setq ,result
-	     (%sp-find-character-with-attribute
-	      open-chars (+ ,start gap) line-cache-length ,vector ,mask))
-       (when ,result (decf ,result gap)))
-      ((setq ,result (%sp-find-character-with-attribute
-		      open-chars ,start left-open-pos ,vector ,mask)))
-      (t
-       (setq ,result
-	     (%sp-find-character-with-attribute
-	      open-chars right-open-pos line-cache-length ,vector ,mask))
-       (when ,result (decf ,result gap))))))
-); eval-when (compile eval)
-;;;
-(defun find-attribute (mark attribute &optional (test #'not-zerop))
-  "Find the next character whose attribute value satisfies test."
-  (let ((charpos (mark-charpos mark))
-	(line (mark-line mark))
-	(mask 0)
-	vector end-wins)
-    (declare (type (or (simple-array (mod 256)) null) vector) (fixnum mask)
-	     (type (or fixnum null) charpos))
-    (cached-attribute-lookup attribute test vector mask end-wins)
-    (cond
-     ((cond
-       ((eq line open-line)
-	(when (cache-find-attribute charpos charpos vector mask)
-	  (setf (mark-charpos mark) charpos) mark))
-       (t
-	(when (normal-find-attribute line charpos charpos vector mask)
-	  (setf (mark-charpos mark) charpos) mark))))
-     ;; Newlines win and there is one.
-     ((and (not (zerop (logand mask (aref vector (char-code #\newline)))))
-	   (line-next line))
-      (move-to-position mark (line-length line) line))
-     ;; We can ignore newlines.
-     (t
-      (do (prev)
-	  (())
-	(setq prev line  line (line-next line))
-	(cond
-	 ((null line)
-	  (if end-wins
-	      (return (line-end mark prev))
-	      (return nil)))
-	 ((eq line open-line)
-	  (when (cache-find-attribute 0 charpos vector mask)
-	    (return (move-to-position mark charpos line))))
-	 (t
-	  (when (normal-find-attribute line 0 charpos vector mask)
-	    (return (move-to-position mark charpos line))))))))))
-
-
-;;; REVERSE-FIND-ATTRIBUTE  --  Public
-;;;
-;;;    Line find-attribute, only goes backwards.
-;;;
-(eval-when (compile eval)
-(defmacro rev-normal-find-attribute (line start result vector mask)
-  `(let ((chars (line-chars ,line)))
-     (setq ,result (%sp-reverse-find-character-with-attribute
-		    chars 0 ,(or start '(strlen chars)) ,vector ,mask))))
-;;;
-(defmacro rev-cache-find-attribute (start result vector mask)
-  `(let ((gap (- right-open-pos left-open-pos)))
-     (declare (fixnum gap))
-     (cond
-      ,@(when start
-	  `(((<= ,start left-open-pos)
-	     (setq ,result
-		   (%sp-reverse-find-character-with-attribute
-		    open-chars 0 ,start ,vector ,mask)))))
-      ((setq ,result (%sp-reverse-find-character-with-attribute
-		      open-chars right-open-pos
-		      ,(if start `(+ ,start gap) 'line-cache-length)
-		      ,vector ,mask))
-       (decf ,result gap))
-      (t
-       (setq ,result
-	     (%sp-reverse-find-character-with-attribute
-	      open-chars 0 left-open-pos ,vector ,mask))))))
-
-); eval-when (compile eval)
-;;;
-(defun reverse-find-attribute (mark attribute &optional (test #'not-zerop))
-  "Find the previous character whose attribute value satisfies test."
-  (let* ((charpos (mark-charpos mark))
-	 (line (mark-line mark)) vector mask end-wins)
-    (declare (type (or (simple-array (mod 256)) null) vector)
-	     (type (or fixnum null) charpos))
-    (cached-attribute-lookup attribute test vector mask end-wins)
-    (cond 
-     ((cond
-       ((eq line open-line)
-	(when (rev-cache-find-attribute charpos charpos vector mask)
-	  (setf (mark-charpos mark) (1+ charpos)) mark))
-       (t
-	(when (rev-normal-find-attribute line charpos charpos vector mask)
-	  (setf (mark-charpos mark) (1+ charpos)) mark))))
-     ;; Newlines win and there is one.
-     ((and (line-previous line)
-	   (not (zerop (logand mask (aref vector (char-code #\newline))))))
-      (move-to-position mark 0 line))
-     (t
-      (do (next)
-	  (())
-	(setq next line  line (line-previous line))
-	(cond
-	 ((null line)
-	  (if end-wins
-	      (return (line-start mark next))
-	      (return nil)))
-	 ((eq line open-line)
-	  (when (rev-cache-find-attribute nil charpos vector mask)
-	    (return (move-to-position mark (1+ charpos) line))))
-	 (t
-	  (when (rev-normal-find-attribute line nil charpos vector mask)
-	    (return (move-to-position mark (1+ charpos) line))))))))))
diff --git a/hemlock/table.lisp b/hemlock/table.lisp
deleted file mode 100644
index f21d6fdbcd4d80c75af3b75ca2b9d76e0988d7ef..0000000000000000000000000000000000000000
--- a/hemlock/table.lisp
+++ /dev/null
@@ -1,751 +0,0 @@
-;;; -*- Log: hemlock.log; Package: HEMLOCK-INTERNALS -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/table.lisp,v 1.1.1.5 1991/12/20 18:25:28 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Reluctantly written by Christopher Hoover
-;;; Supporting cast includes Rob and Bill.
-;;;
-;;; This file defines a data structure, analogous to a Common Lisp
-;;; hashtable, which translates strings to values and facilitates
-;;; recognition and completion of these strings.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(string-table string-table-p make-string-table
-		       string-table-separator getstring
-		       find-ambiguous complete-string find-containing
-		       delete-string clrstring do-strings))
-
-
-;;;; Implementation Details
-
-;;; String tables are a data structure somewhat analogous to Common Lisp
-;;; hashtables.  String tables are case-insensitive.  Functions are
-;;; provided to quickly look up strings, insert strings, disambiguate or
-;;; complete strings, and to provide a variety of ``help'' when
-;;; disambiguating or completing strings.
-;;; 
-;;; String tables are represented as a series of word tables which form
-;;; a tree.  Four structures are used to implement this data structure.
-;;; The first is a STRING-TABLE.  This structure has severals slots one
-;;; of which, FIRST-WORD-TABLE, points to the first word table.  This
-;;; first word table is also the root of tree.  The STRING-TABLE
-;;; structure also contains slots to keep track of the number of nodes,
-;;; the string table separator (which is used to distinguish word or
-;;; field boundaries), and a pointer to an array of VALUE-NODE's.
-;;; 
-;;; A WORD-TABLE is simply an array of pointers to WORD-ENTRY's.  This
-;;; array is kept sorted by the FOLDED slot in each WORD-ENTRY so that a
-;;; binary search can be used.  Each WORD-ENTRY contains a case-folded
-;;; string and a pointer to the next WORD-TABLE in the tree.  By
-;;; traversing the tree made up by these structures, searching and
-;;; completion can easily be done.
-;;; 
-;;; Another structure, a VALUE-NODE, is used to hold each entry in the
-;;; string table and contains both a copy of the original string and a
-;;; case-folded version of the original string along with the value.
-;;; All of these value nodes are stored in a array (pointed at by the
-;;; VALUE-NODES slot of the STRING-TABLE structure) and sorted by the
-;;; FOLDED slot in the VALUE-NODE structure so that a binary search may
-;;; be used to quickly find existing strings.
-;;;
-
-
-;;;; Structure Definitions
-
-(defparameter initial-string-table-size 20
-  "Initial size of string table array for value nodes.")
-(defparameter initial-word-table-size 2
-  "Inital size of each word table array for each tree node.")
-
-(defstruct (string-table
-	    (:constructor %make-string-table (separator))
-	    (:print-function print-string-table))
-  "This structure is used to implement the Hemlock string-table type."
-  ;; Character used to 
-  (separator #\Space :type base-char) ; character used for word separator
-  (num-nodes 0 :type fixnum)		   ; number of nodes in string table
-  (value-nodes (make-array initial-string-table-size)) ; value node array
-  (first-word-table (make-word-table)))	   ; pointer to first WORD-TABLE
-
-(defun print-string-table (table stream depth)
-  (declare (ignore table depth))
-  (format stream "#<String Table>"))
-
-(defun make-string-table (&key (separator #\Space) initial-contents)
-  "Creates and returns a Hemlock string-table.  If Intitial-Contents is
-  supplied in the form of an A-list of string-value pairs, these pairs
-  will be used to initialize the table.  If Separator, which must be a
-  base-char, is specified then it will be used to distinguish word
-  boundaries."
-  (let ((table (%make-string-table separator)))
-    (dolist (x initial-contents)
-      (setf (getstring (car x) table) (cdr x)))
-    table))
-
-
-(defstruct (word-table
-	    (:print-function print-word-table))
-  "This structure is a word-table which is part of a Hemlock string-table."
-  (num-words 0 :type fixnum)		   ; Number of words
-  (words (make-array initial-word-table-size))) ; Array of WORD-ENTRY's
-
-(defun print-word-table (table stream depth)
-  (declare (ignore table depth))
-  (format stream "#<Word Table>"))
-
-
-(defstruct (word-entry
-	    (:constructor make-word-entry (folded))
-	    (:print-function print-word-entry))
-  "This structure is an entry in a word table which is part of a Hemlock
-  string-table."
-  next-table				   ; Pointer to next WORD-TABLE
-  folded				   ; Downcased word
-  value-node)				   ; Pointer to value node or NIL
-
-(defun print-word-entry (entry stream depth)
-  (declare (ignore depth))
-  (format stream "#<Word Table Entry: \"~A\">" (word-entry-folded entry)))
-
-
-(defstruct (value-node
-	    (:constructor make-value-node (proper folded value))
-	    (:print-function print-value-node))
-  "This structure is a node containing a value in a Hemlock string-table."
-  folded				   ; Downcased copy of string
-  proper				   ; Proper copy of string entry
-  value)				   ; Value of entry
-
-(defun print-value-node (node stream depth)
-  (declare (ignore depth))
-  (format stream "<Value Node \"~A\">" (value-node-proper node)))
-
-
-;;;; Bi-SvPosition, String-Compare, String-Compare*
-
-;;; Much like the CL function POSITION; however, this is a fast binary
-;;; search for simple vectors.  Vector must be a simple vector and Test
-;;; must be a function which returns either :equal, :less, or :greater.
-;;; (The vector must be sorted from lowest index to highest index by the
-;;; Test function.)  Two values are returned: the first is the position
-;;; Item was found or if it was not found, where it should be inserted;
-;;; the second is a boolean flag indicating whether or not Item was
-;;; found.
-;;; 
-(defun bi-svposition (item vector test &key (start 0) end key)
-  (declare (simple-vector vector) (fixnum start))
-  (let ((low start)
-	(high (if end end (length vector)))
-	(mid 0))
-    (declare (fixnum low high mid))
-    (loop
-      (when (< high low) (return (values low nil)))
-      (setf mid (+ (the fixnum (ash (the fixnum (- high low)) -1)) low))
-      (let* ((array-item (svref vector mid))
-	     (test-item (if key (funcall key array-item) array-item)))
-	(ecase (funcall test item test-item)
-	  (:equal (return (values mid t)))
-	  (:less (setf high (1- mid)))
-	  (:greater (setf low (1+ mid))))))))
-
-;;; A simple-string comparison appropriate for use with BI-SVPOSITION.
-;;; 
-(defun string-compare (s1 s2 &key (start1 0) end1 (start2 0) end2)
-  (declare (simple-string s1 s2) (fixnum start1 start2))
-  (let* ((end1 (or end1 (length s1)))
-	 (end2 (or end2 (length s2)))
-	 (pos1 (string/= s1 s2
-			 :start1 start1 :end1 end1 :start2 start2 :end2 end2)))
-    (if (null pos1)
-	:equal
-	(let ((pos2 (+ (the fixnum pos1) (- start2 start1))))
-	  (declare (fixnum pos2))
-	  (cond ((= pos1 (the fixnum end1)) :less)
-		((= pos2 (the fixnum end2)) :greater)
-		((char< (schar s1 (the fixnum pos1)) (schar s2 pos2)) :less)
-		(t :greater))))))
-
-;;; Macro to return a closure to call STRING-COMPARE with the given
-;;; keys.
-;;; 
-(defmacro string-compare* (&rest keys)
-  `#'(lambda (x y) (string-compare x y ,@keys)))
-
-
-;;;; Insert-Element, Nconcf
-
-(eval-when (compile eval)
-
-;;; Insert-Element is a macro which encapsulates the hairiness of
-;;; inserting an element into a simple vector.  Vector should be a
-;;; simple vector with Num elements (which may be less than or equal to
-;;; the length of the vector) and Element is the element to insert at
-;;; Pos.  The optional argument Grow-Factor may be specified to control
-;;; the new size of the array if a new vector is necessary.  The result
-;;; of INSERT-ELEMENT must be used as a new vector may be created.
-;;; (Note that the arguments should probably be lexicals since some of
-;;; them are evaluated more than once.)
-;;;
-;;; We clear out the old vector so that it won't hold on to garbage if it
-;;; happens to be in static space.
-;;; 
-(defmacro insert-element (vector pos element num &optional (grow-factor 2))
-  `(let ((new-num (1+ ,num))
-	 (max (length ,vector)))
-     (declare (fixnum new-num max))
-     (cond ((= ,num max)
-	    ;; grow the vector
-	    (let ((new (make-array (truncate (* max ,grow-factor)))))
-	      (declare (simple-vector new))
-	      ;; Blt the new buggers into place leaving a space for
-	      ;; the new element
-	      (replace new ,vector :end1 ,pos :end2 ,pos)
-	      (replace new ,vector :start1 (1+ ,pos) :end1 new-num
-		       :start2 ,pos :end2 ,num)
-	      (fill ,vector nil)
-	      (setf (svref new ,pos) ,element)
-	      new))
-	   (t
-	    ;; move the buggers down a slot
-	    (replace ,vector ,vector :start1 (1+ ,pos) :start2 ,pos)
-	    (setf (svref ,vector ,pos) ,element)
-	    ,vector)))))
-
-(define-modify-macro nconcf (&rest args) nconc)
-
-) ; eval-when
-
-
-;;;; With-Folded-String, Do-Words
-
-;;; With-Folded-String is a macro which deals with strings from the
-;;; user.  First, if the original string is not a simple string then it
-;;; is coerced to one.  Next, the string is trimmed using the separator
-;;; character and all separators between words are collapsed to a single
-;;; separator.  The word boundaries are pushed on to a list so that the
-;;; Do-Words macro can be called anywhere within the dynamic extent of a
-;;; With-Folded-String to ``do'' over the words.
-
-(defvar *string-buffer-size* 128)
-(defvar *string-buffer* (make-string *string-buffer-size*))
-(proclaim '(simple-string *string-buffer*))
-
-(defvar *separator-positions* nil)
-
-(eval-when (compile eval)
-
-(defmacro do-words ((start-var end-var) &body (body decls))
-  (let ((sep-pos (gensym)))
-    `(dolist (,sep-pos *separator-positions*)
-       (let ((,start-var (car ,sep-pos))
-	     (,end-var (cdr ,sep-pos)))
-	 ,@decls
-	 ,@body))))
-
-(defmacro with-folded-string ((str-var len-var orig-str separator)
-			      &body (body decls))
-  `(let ((,str-var *string-buffer*))
-     (declare (simple-string ,str-var))
-     ;; make the string simple if it isn't already
-     (unless (simple-string-p ,orig-str)
-       (setq ,orig-str (coerce ,orig-str 'simple-string)))
-     ;; munge it into *string-buffer* and do the body
-     (let ((,len-var (with-folded-munge-string ,orig-str ,separator)))
-       ,@decls
-       ,@body)))
-
-) ; eval-when
-
-(defun with-folded-munge-string (str separator)
-  (declare (simple-string str) (base-char separator))
-  (let ((str-len (length str))
-	(sep-pos nil)
-	(buf-pos 0))
-    ;; Make sure we have enough room to blt the string into place.
-    (when (> str-len *string-buffer-size*)
-      (setq *string-buffer-size* (* str-len 2))
-      (setq *string-buffer* (make-string *string-buffer-size*)))
-    ;; Bash the spaces out of the string remembering where the words are.
-    (let ((start-pos (position separator str :test-not #'char=)))
-      (when start-pos
-	(loop
-	  (let* ((end-pos (position separator str
-				    :start start-pos :test #'char=))
-		 (next-start-pos (and end-pos (position separator str
-							:start end-pos
-							:test-not #'char=)))
-		 (word-len (- (or end-pos str-len) start-pos))
-		 (new-buf-pos (+ buf-pos word-len)))
-	    (replace *string-buffer* str
-		     :start1 buf-pos :start2 start-pos :end2 end-pos)
-	    (push (cons buf-pos new-buf-pos) sep-pos)
-	    (setf buf-pos new-buf-pos)
-	    (when (or (null end-pos) (null next-start-pos))
-	      (return))
-	    (setf start-pos next-start-pos)
-	    (setf (schar *string-buffer* buf-pos) separator)
-	    (incf buf-pos)))))
-    (nstring-downcase *string-buffer* :end buf-pos)
-    (setf *separator-positions* (nreverse sep-pos))
-    buf-pos))
-
-
-;;;; Getstring, Setf Method for Getstring
-
-(defun getstring (string string-table)
-  "Looks up String in String-Table.  Returns two values: the first is
-  the value of String or NIL if it does not exist; the second is a
-  boolean flag indicating whether or not String was found in
-  String-Table."
-  (with-folded-string (folded len string (string-table-separator string-table))
-    (let ((nodes (string-table-value-nodes string-table))
-	  (num-nodes (string-table-num-nodes string-table)))
-      (declare (simple-vector nodes) (fixnum num-nodes))
-      (multiple-value-bind
-	  (pos found-p)
-	  (bi-svposition folded nodes (string-compare* :end1 len)
-			 :end (1- num-nodes) :key #'value-node-folded)
-	(if found-p
-	    (values (value-node-value (svref nodes pos)) t)
-	    (values nil nil))))))
-
-(defun %set-string-table (string table value)
-  "Sets the value of String in Table to Value.  If necessary, creates
-  a new entry in the string table."
-  (with-folded-string (folded len string (string-table-separator table))
-    (when (zerop len)
-      (error "An empty string cannot be inserted into a string-table."))
-    (let ((nodes (string-table-value-nodes table))
-	  (num-nodes (string-table-num-nodes table)))
-      (declare (simple-string folded) (simple-vector nodes) (fixnum num-nodes))
-      (multiple-value-bind
-	  (pos found-p)
-	  (bi-svposition folded nodes (string-compare* :end1 len)
-			 :end (1- num-nodes) :key #'value-node-folded)
-	(cond (found-p
- 	       (setf (value-node-value (svref nodes pos)) value))
-	      (t
-	       ;; Note that a separator collapsed copy of string is NOT
-	       ;; used here ...
-	       ;; 
-	       (let ((node (make-value-node string (subseq folded 0 len) value))
-		     (word-table (string-table-first-word-table table)))
-		 ;; put in the value nodes array
-		 (setf (string-table-value-nodes table)
-		       (insert-element nodes pos node num-nodes))
-		 (incf (string-table-num-nodes table))
-		 ;; insert it into the word tree
-		 (%set-insert-words folded word-table node))))))
-    value))
-
-(defun %set-insert-words (folded first-word-table value-node)
-  (declare (simple-string folded))
-  (let ((word-table first-word-table)
-	(entry nil))
-    (do-words (word-start word-end)
-      (let ((word-array (word-table-words word-table))
-	    (num-words (word-table-num-words word-table)))
-	(declare (simple-vector word-array) (fixnum num-words))
-	;; find the entry or create a new one and insert it
-	(multiple-value-bind
-	    (pos found-p)
-	    (bi-svposition folded word-array
-			   (string-compare* :start1 word-start :end1 word-end)
-			   :end (1- num-words) :key #'word-entry-folded)
-	  (declare (fixnum pos))
-	  (cond (found-p
-		 (setf entry (svref word-array pos)))
-		(t
-		 (setf entry (make-word-entry
-			      (subseq folded word-start word-end)))
-		 (setf (word-table-words word-table)
-		       (insert-element word-array pos entry num-words))
-		 (incf (word-table-num-words word-table)))))
-	(let ((next-table (word-entry-next-table entry)))
-	  (unless next-table
-	    (setf next-table (make-word-table))
-	    (setf (word-entry-next-table entry) next-table))
-	  (setf word-table next-table))))
-    (setf (word-entry-value-node entry) value-node)))
-
-
-;;;; Find-Bound-Entries
-
-(defun find-bound-entries (word-entries)
-  (let ((res nil))
-    (dolist (entry word-entries)
-      (nconcf res (sub-find-bound-entries entry)))
-    res))
-
-(defun sub-find-bound-entries (entry)
-  (let ((bound-entries nil))
-    (when (word-entry-value-node entry) (push entry bound-entries))
-    (let ((next-table (word-entry-next-table entry)))
-      (when next-table
-	(let ((word-array (word-table-words next-table))
-	      (num-words (word-table-num-words next-table)))
-	  (declare (simple-vector word-array) (fixnum num-words))
-	  (dotimes (i num-words)
-	    (declare (fixnum i))
-	    (nconcf bound-entries
-		    (sub-find-bound-entries (svref word-array i)))))))
-    bound-entries))
-
-
-;;;; Find-Ambiguous
-
-(defun find-ambiguous (string string-table)
-  "Returns a list, in alphabetical order, of all the strings in String-Table
-  which String matches."
-  (with-folded-string (folded len string (string-table-separator string-table))
-    (find-ambiguous* folded len string-table)))
-
-(defun find-ambiguous* (folded len table)
-  (let ((word-table (string-table-first-word-table table))
-	(word-entries nil))
-    (cond ((zerop len)
-	   (setf word-entries (find-ambiguous-entries "" 0 0 word-table)))
-	  (t
-	   (let ((word-tables (list word-table)))
-	     (do-words (start end)
-	       (setf word-entries nil)
-	       (dolist (wt word-tables)
-		 (nconcf word-entries
-			 (find-ambiguous-entries folded start end wt)))
-	       (unless word-entries (return))
-	       (let ((next-word-tables nil))
-		 (dolist (entry word-entries)
-		   (let ((next-word-table (word-entry-next-table entry)))
-		     (when next-word-table
-		       (push next-word-table next-word-tables))))
-		 (unless next-word-tables (return))
-		 (setf word-tables (nreverse next-word-tables)))))))
-    (let ((bound-entries (find-bound-entries word-entries))
-	  (res nil))
-      (dolist (be bound-entries)
-	(push (value-node-proper (word-entry-value-node be)) res))
-      (nreverse res))))
-
-(defun find-ambiguous-entries (folded start end word-table)
-  (let ((word-array (word-table-words word-table))
-	(num-words (word-table-num-words word-table))
-	(res nil))
-    (declare (simple-vector word-array) (fixnum num-words))
-    (unless (zerop num-words)
-      (multiple-value-bind
-	  (pos found-p)
-	  (bi-svposition folded word-array
-			 (string-compare* :start1 start :end1 end)
-			 :end (1- num-words) :key #'word-entry-folded)
-	(declare (ignore found-p))
-	;;
-	;; Find last ambiguous string, checking for the end of the table.
-	(do ((i pos (1+ i)))
-	    ((= i num-words))
-	  (declare (fixnum i))
-	  (let* ((entry (svref word-array i))
-		 (str (word-entry-folded entry))
-		 (str-len (length str))
-		 (index (string/= folded str :start1 start :end1 end
-				  :end2 str-len)))
-	    (declare (simple-string str) (fixnum str-len))
-	    (when (and index (/= index end)) (return nil))
-	    (push entry res)))
-	(setf res (nreverse res))
-	;;
-	;; Scan back to the first string, checking for the beginning.
-	(do ((i (1- pos) (1- i)))
-	    ((minusp i))
-	  (declare (fixnum i))
-	  (let* ((entry (svref word-array i))
-		 (str (word-entry-folded entry))
-		 (str-len (length str))
-		 (index (string/= folded str :start1 start :end1 end
-				  :end2 str-len)))
-	    (declare (simple-string str) (fixnum str-len))
-	    (when (and index (/= index end)) (return nil))
-	    (push entry res)))))
-    res))
-
-
-;;;; Find-Containing
-
-(defun find-containing (string string-table)
-  "Return a list in alphabetical order of all the strings in Table which 
-  contain String as a substring."
-  (with-folded-string (folded len string (string-table-separator string-table))
-    (declare (ignore len))
-    (let ((word-table (string-table-first-word-table string-table))
-	  (words nil))
-      ;; cons up a list of the words
-      (do-words (start end)
-	(push (subseq folded start end) words))
-      (setf words (nreverse words))
-      (let ((entries (sub-find-containing words word-table))
-	    (res nil))
-	(dolist (e entries)
-	  (push (value-node-proper (word-entry-value-node e)) res))
-	(nreverse res)))))
-
-(defun sub-find-containing (words word-table)
-  (let ((res nil)
-	(word-array (word-table-words word-table))
-	(num-words (word-table-num-words word-table)))
-    (declare (simple-vector word-array) (fixnum num-words))
-    (dotimes (i num-words)
-      (declare (fixnum i))
-      (let* ((entry (svref word-array i))
-	     (word (word-entry-folded entry))
-	     (found (find word words
-			  :test #'(lambda (y x)
-				    (let ((lx (length x))
-					  (ly (length y)))
-				      (and (<= lx ly)
-					   (string= x y :end2 lx))))))
-	     (rest-words (if found
-			     (remove found words :test #'eq :count 1)
-			     words)))
-	(declare (simple-string word))
-	(cond (rest-words
-	       (let ((next-table (word-entry-next-table entry)))
-		 (when next-table
-		   (nconcf res (sub-find-containing rest-words next-table)))))
-	      (t
-	       (nconcf res (sub-find-bound-entries entry))))))
-    res))
-
-
-;;;; Complete-String
-
-(defvar *complete-string-buffer-size* 128)
-(defvar *complete-string-buffer* (make-string *complete-string-buffer-size*))
-(proclaim '(simple-string *complete-string-buffer*))
-
-(defun complete-string (string tables)
-  "Attempts to complete the string String against the string tables in the
-   list Tables.  Tables must all use the same separator character.  See the
-   manual for details on return values."
-  (let ((separator (string-table-separator (car tables))))
-    #|(when (member separator (cdr tables)
-		  :key #'string-table-separator :test-not #'char=)
-      (error "All tables must have the same separator."))|#
-    (with-folded-string (folded len string separator)
-      (let ((strings nil))
-	(dolist (table tables)
-	  (nconcf strings (find-ambiguous* folded len table)))
-	;; pick off easy case
-	(when (null strings)
-	  (return-from complete-string (values nil :none nil nil nil)))
-	;; grow complete-string buffer if necessary
-	(let ((size-needed (1+ len)))
-	  (when (> size-needed *complete-string-buffer-size*)
-	    (let* ((new-size (* size-needed 2))
-		   (new-buffer (make-string new-size)))
-	      (setf *complete-string-buffer* new-buffer)
-	      (setf *complete-string-buffer-size* new-size))))
-	(multiple-value-bind
-	    (str ambig-pos unique-p)
-	    (find-longest-completion strings separator)
-	  (multiple-value-bind (value found-p) (find-values str tables)
-	    (let ((field-pos (compute-field-pos string str separator)))
-	      (cond ((not found-p)
-		     (values str :ambiguous nil field-pos ambig-pos))
-		    (unique-p
-		     (values str :unique value field-pos nil))
-		    (t
-		     (values str :complete value field-pos ambig-pos))))))))))
-
-(defun find-values (string tables)
-  (dolist (table tables)
-    (multiple-value-bind (value found-p) (getstring string table)
-      (when found-p
-	(return-from find-values (values value t)))))
-  (values nil nil))
-
-(defun compute-field-pos (given best separator)
-  (declare (simple-string given best) (base-char separator))
-  (let ((give-pos 0)
-	(best-pos 0))
-    (loop
-      (setf give-pos (position separator given :start give-pos :test #'char=))
-      (setf best-pos (position separator best :start best-pos :test #'char=))
-      (unless (and give-pos best-pos) (return best-pos))
-      (incf (the fixnum give-pos))
-      (incf (the fixnum best-pos)))))
-
-
-;;;; Find-Longest-Completion
-
-(defun find-longest-completion (strings separator)
-  (declare (base-char separator))
-  (let ((first (car strings))
-	(rest-strings (cdr strings))
-	(punt-p nil)
-	(buf-pos 0)
-	(first-start 0)
-	(first-end -1)
-	(ambig-pos nil)
-	(maybe-unique-p nil))
-    (declare (simple-string first) (fixnum buf-pos first-start))
-    ;;
-    ;; Make room to store each string's next separator index.
-    (do ((l rest-strings (cdr l)))
-	((endp l))
-      (setf (car l) (cons (car l) -1)))
-    ;;
-    ;; Compare the rest of the strings to the first one.
-    ;; It's our de facto standard for how far we can go.
-    (loop
-      (setf first-start (1+ first-end))
-      (setf first-end
-	    (position separator first :start first-start :test #'char=))
-      (unless first-end
-	(setf first-end (length first))
-	(setf punt-p t)
-	(setf maybe-unique-p t))
-      (let ((first-max first-end)
-	    (word-ambiguous-p nil))
-	(declare (fixnum first-max))
-	;;
-	;; For each string, store the separator's next index.
-	;; If there's no separator, store nil and prepare to punt.
-	;; If the string's field is not equal to the first's, shorten the max
-	;;   expectation for this field, and declare ambiguity.
-	(dolist (s rest-strings)
-	  (let* ((str (car s))
-		 (str-last-pos (cdr s))
-		 (str-start (1+ str-last-pos))
-		 (str-end (position separator str
-				    :start str-start :test #'char=))
-		 (index (string-not-equal first str
-					  :start1 first-start :end1 first-max
-					  :start2 str-start :end2 str-end)))
-	    (declare (simple-string str) (fixnum str-last-pos str-start))
-	    (setf (cdr s) str-end)
-	    (unless str-end
-	      (setf punt-p t)
-	      (setf str-end (length str)))
-	    (when index
-	      (setf word-ambiguous-p t) ; not equal for some reason
-	      (when (< index first-max)
-		(setf first-max index)))))
-	;;
-	;; Store what we matched into the result buffer and save the
-	;; ambiguous position if its the first ambiguous field.
-	(let ((length (- first-max first-start)))
-	  (declare (fixnum length))
-	  (unless (zerop length)
-	    (unless (zerop buf-pos)
-	      (setf (schar *complete-string-buffer* buf-pos) separator)
-	      (incf buf-pos))
-	    (replace *complete-string-buffer* first
-		     :start1 buf-pos :start2 first-start :end2 first-max)
-	    (incf buf-pos length))
-	  (when (and (null ambig-pos) word-ambiguous-p)
-	    (setf ambig-pos buf-pos))
-	  (when (or punt-p (zerop length)) (return)))))
-    (values
-     (subseq *complete-string-buffer* 0 buf-pos)
-     ;; If every corresponding field in each possible completion was equal,
-     ;; our result string is an initial substring of some other completion,
-     ;; so we're ambiguous at the end.
-     (or ambig-pos buf-pos)
-     (and (null ambig-pos)
-	  maybe-unique-p
-	  (every #'(lambda (x) (null (cdr x))) rest-strings)))))
-		 
-
-;;;; Clrstring
-
-(defun clrstring (string-table)
-  "Delete all the entries in String-Table."
-  (fill (the simple-vector (string-table-value-nodes string-table)) nil)
-  (setf (string-table-num-nodes string-table) 0)
-  (let ((word-table (string-table-first-word-table string-table)))
-    (fill (the simple-vector (word-table-words word-table)) nil)
-    (setf (word-table-num-words word-table) 0))
-  t)
-
-
-;;;; Delete-String
-
-(defun delete-string (string string-table)
-  (with-folded-string (folded len string (string-table-separator string-table))
-    (when (plusp len)
-      (let* ((nodes (string-table-value-nodes string-table))
-	     (num-nodes (string-table-num-nodes string-table))
-	     (end (1- num-nodes)))
-	(declare (simple-string folded) (simple-vector nodes)
-		 (fixnum num-nodes end))
-	(multiple-value-bind
-	    (pos found-p)
-	    (bi-svposition folded nodes (string-compare* :end1 len)
-			   :end end :key #'value-node-folded)
-	  (cond (found-p
-		 (replace nodes nodes
-			  :start1 pos :end1 end :start2 (1+ pos) :end2 num-nodes)
-		 (setf (svref nodes end) nil)
-		 (setf (string-table-num-nodes string-table) end)
-		 (sub-delete-string folded string-table)
-		 t)
-		(t nil)))))))
-
-(defun sub-delete-string (folded string-table)
-  (let ((next-table (string-table-first-word-table string-table))
-	(word-table nil)
-	(node nil)
-	(entry nil)
-	(level -1)
-	last-table last-table-level last-table-pos
-	last-entry last-entry-level)
-    (declare (fixnum level))
-    (do-words (start end)
-      (when node
-	(setf last-entry entry)
-	(setf last-entry-level level))
-      (setf word-table next-table)
-      (incf level)
-      (let ((word-array (word-table-words word-table))
-	    (num-words (word-table-num-words word-table)))
-	(declare (simple-vector word-array) (fixnum num-words))
-	(multiple-value-bind
-	    (pos found-p)
-	    (bi-svposition folded word-array
-			   (string-compare* :start1 start :end1 end)
-			   :end (1- num-words) :key #'word-entry-folded)
-	  (declare (fixnum pos) (ignore found-p))
-	  (setf entry (svref word-array pos))
-	  (setf next-table (word-entry-next-table entry))
-	  (setf node (word-entry-value-node entry))
-	  (when (or (null last-table) (> num-words 1))
-	    (setf last-table word-table)
-	    (setf last-table-pos pos)
-	    (setf last-table-level level)))))
-    (cond (next-table
-	   (setf (word-entry-value-node entry) nil))
-	  ((and last-entry-level
-		(>= last-entry-level last-table-level))
-	   (setf (word-entry-next-table last-entry) nil))
-	  (t
-	   (let* ((del-word-array (word-table-words last-table))
-		  (del-num-words (word-table-num-words last-table))
-		  (del-end (1- del-num-words)))
-	     (declare (simple-vector del-word-array)
-		      (fixnum del-num-words del-end))
-	     (replace del-word-array del-word-array
-		      :start1 last-table-pos :end1 del-end
-		      :start2 (1+ last-table-pos)
-		      :end2 del-num-words)
-	     (setf (svref del-word-array del-end) nil)
-	     (setf (word-table-num-words last-table) del-end))))))
diff --git a/hemlock/termcap.lisp b/hemlock/termcap.lisp
deleted file mode 100644
index 01564d21c34108e3f4a8d8c7ebb307a3f0b49652..0000000000000000000000000000000000000000
--- a/hemlock/termcap.lisp
+++ /dev/null
@@ -1,439 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/termcap.lisp,v 1.5 1991/11/07 22:18:40 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles
-;;;
-;;; Terminal Capability
-;;;
-;;; This stuff parses a Termcap file and returns a data structure suitable
-;;; for initializing a redisplay methods device.
-;;;
-
-(in-package 'hemlock-internals)
-
-
-
-;;;; Interface for device creating code.
-
-(defun get-termcap (name)
-  "Look in TERMCAP environment variable for terminal capabilities or a
-   file to use.  If it is a file, look for name in it.  If it is a description
-   of the capabilities, use it, and don't look for name anywhere.  If TERMCAP
-   is undefined, look for name in termcap-file.  An error is signaled if it
-   cannot find the terminal capabilities."
-  (let ((termcap-env-var (get-termcap-env-var)))
-    (if termcap-env-var
-	(if (char= (schar termcap-env-var 0) #\/) ; hack for filenamep
-	    (with-open-file (s termcap-env-var)
-	      (if (find-termcap-entry name s)
-		  (parse-fields s)
-		  (error "Unknown Terminal ~S in file ~S." name termcap-env-var)))
-	    (with-input-from-string (s termcap-env-var)
-	      (skip-termcap-names s)
-	      (parse-fields s)))
-	(with-open-file (s termcap-file)
-	  (if (find-termcap-entry name s)
-	      (parse-fields s)
-	      (error "Unknown Terminal ~S in file ~S." name termcap-file))))))
-
-(proclaim '(inline termcap))
-(defun termcap (name termcap)
-  (cdr (assoc name termcap :test #'eq)))
-
-
-
-;;;; Finding the termcap entry
-
-(defun find-termcap-entry (name stream)
-  (loop
-   (let ((end-of-names (lex-termcap-name stream)))
-     (when (termcap-found-p name)
-       (unless end-of-names (skip-termcap-names stream))
-       (return t))
-     (when end-of-names
-       (unless (skip-termcap-fields stream)
-	 (return nil))))))
-
-
-;;; This buffer is used in LEX-TERMCAP-NAME and PARSE-FIELDS to
-;;; do string comparisons and build strings from interpreted termcap
-;;; characters, respectively.
-;;; 
-(defvar *termcap-string-buffer* (make-string 300))
-(defvar *termcap-string-index* 0)
-
-(eval-when (compile eval)
-
-(defmacro init-termcap-string-buffer ()
-  `(setf *termcap-string-index* 0))
-
-(defmacro store-char (char)
-  `(progn
-    (setf (schar *termcap-string-buffer* *termcap-string-index*) ,char)
-    (incf *termcap-string-index*)))
-
-(defmacro termcap-string-buffer-string ()
-  `(subseq (the simple-string *termcap-string-buffer*)
-	   0 *termcap-string-index*))
-
-) ;eval-when
-
-
-;;; LEX-TERMCAP-NAME gathers characters until the next #\|, which separate
-;;; terminal names, or #\:, which terminate terminal names for an entry.
-;;; T is returned if the end of the names is reached for the entry.
-;;; If we hit and EOF, act like we found a :. 
-;;; 
-(defun lex-termcap-name (stream)
-  (init-termcap-string-buffer)
-  (loop
-   (let ((char (read-char stream nil #\:)))
-     (case char
-       (#\# (read-line stream nil))
-       (#\| (return nil))
-       (#\: (return t))
-       (t (store-char char))))))
-
-(defun termcap-found-p (name)
-  (string= name *termcap-string-buffer* :end2 *termcap-string-index*))
-
-;;; SKIP-TERMCAP-NAMES eats characters until the next #\: which terminates
-;;; terminal names for an entry.  Stop also at EOF.
-;;; 
-(defun skip-termcap-names (stream)
-  (loop
-   (when (char= (read-char stream nil #\:) #\:)
-     (return))))
-
-;;; SKIP-TERMCAP-FIELDS skips the rest of an entry, returning nil if there
-;;; are no more entries in the file.  An entry is terminated by a #\:
-;;; followed by a #\newline (possibly by eof).
-;;; 
-(defun skip-termcap-fields (stream)
-  (loop
-   (multiple-value-bind (line eofp)
-			(read-line stream nil)
-     (let ((len (length line)))
-       (declare (simple-string line))
-       (when (and (not (zerop len))
-		  (not (char= (schar line 0) #\#))
-		  (char= (schar line (1- len)) #\:))
-	 (if eofp
-	     (return nil)
-	     (let ((char (read-char stream nil :eof)))
-	       (if (eq char :eof)
-		   (return nil)
-		   (unread-char char stream))
-	       (return t))))))))
-
-    
-
-;;;; Defining known capabilities for parsing purposes.
-
-(eval-when (compile load eval)
-(defvar *known-termcaps* ())
-) ;eval-when
-
-
-(eval-when (compile eval)
-
-;;; DEFTERMCAP makes a terminal capability known for parsing purposes.
-;;; Type is one of :string, :number, or :boolean.  Cl-name is an EQ
-;;; identifier for the capability.
-;;;
-(defmacro deftermcap (name type cl-name)
-  `(progn (push (list ,name ,type ,cl-name) *known-termcaps*)))
-
-(defmacro termcap-def (name)
-  `(cdr (assoc ,name *known-termcaps* :test #'string=)))
-
-(defmacro termcap-def-type (termcap-def)
-  `(car ,termcap-def))
-
-(defmacro termcap-def-cl-name (termcap-def)
-  `(cadr ,termcap-def))
-
-) ;eval-when
-
-
-(deftermcap "is" :string :init-string)
-(deftermcap "if" :string :init-file)
-(deftermcap "ti" :string :init-cursor-motion)
-(deftermcap "te" :string :end-cursor-motion)
-(deftermcap "al" :string :open-line)
-(deftermcap "am" :boolean :auto-margins-p)
-(deftermcap "ce" :string :clear-to-eol)
-(deftermcap "cl" :string :clear-display)
-(deftermcap "cm" :string :cursor-motion)
-(deftermcap "co" :number :columns)
-(deftermcap "dc" :string :delete-char)
-(deftermcap "dm" :string :init-delete-mode)
-(deftermcap "ed" :string :end-delete-mode)
-(deftermcap "dl" :string :delete-line)
-(deftermcap "im" :string :init-insert-mode)
-(deftermcap "ic" :string :init-insert-char)
-(deftermcap "ip" :string :end-insert-char)
-(deftermcap "ei" :string :end-insert-mode)
-(deftermcap "li" :number :lines)
-(deftermcap "so" :string :init-standout-mode)
-(deftermcap "se" :string :end-standout-mode)
-(deftermcap "tc" :string :similar-terminal)
-(deftermcap "os" :boolean :overstrikes)
-(deftermcap "ul" :boolean :underlines)
-
-;;; font related stuff, added by William
-(deftermcap "ae" :string :end-alternate-char-set)
-(deftermcap "as" :string :start-alternate-char-set)
-(deftermcap "mb" :string :start-blinking-attribute)
-(deftermcap "md" :string :start-bold-attribute)
-(deftermcap "me" :string :end-all-attributes)
-(deftermcap "mh" :string :start-half-bright-attribute)
-(deftermcap "mk" :string :start-blank-attribute)
-(deftermcap "mp" :string :start-protected-attribute)
-(deftermcap "mr" :string :start-reverse-video-attribute)
-(deftermcap "ue" :string :end-underscore-mode)
-(deftermcap "us" :string :start-underscore-mode)
-
-
-;;;; Parsing an entry.
-
-(defvar *getchar-ungetchar-buffer* nil)
-
-(eval-when (compile eval)
-
-;;; UNGETCHAR  --  Internal.
-;;;
-;;; We need this to be able to peek ahead more than one character.
-;;; This is used in PARSE-FIELDS and GET-TERMCAP-STRING-CHAR.
-;;;
-(defmacro ungetchar (char)
-  `(push ,char *getchar-ungetchar-buffer*))
-
-;;; GETCHAR  --  Internal.
-;;;
-;;; This is used in PARSE-FIELDS and GET-TERMCAP-STRING-CHAR.
-;;;
-(defmacro getchar ()
-  `(loop
-    (setf char
-	  (if *getchar-ungetchar-buffer*
-	      (pop *getchar-ungetchar-buffer*)
-	      (read-char stream nil :eof)))
-    (if (and (characterp char) (char= char #\\))
-	(let ((temp (if *getchar-ungetchar-buffer*
-			(pop *getchar-ungetchar-buffer*)
-			(read-char stream))))
-	  (when (char/= temp #\newline)
-	    (ungetchar temp)
-	    (return char)))
-	(return char))))
-
-
-;;; STORE-FIELD used in PARSE-FIELDS.
-;;; 
-(defmacro store-field (cl-name value)
-  (let ((name (gensym)))
-    `(let ((,name ,cl-name))
-       (unless (cdr (assoc ,name termcap :test #'eq))
-	 (push (cons ,name ,value) termcap)))))
-
-) ;eval-when
-
-;;; PARSE-FIELDS parses a termcap entry.  We start out in the state get-name.
-;;; Each name is looked up in *known-termcaps*, and if it is of interest, then
-;;; we dispatch to a state to pick up the value of the field; otherwise, eat
-;;; the rest of the field to get to the next name.  The name could be present
-;;; simply to have the capability negated before the entry indirects to a
-;;; similar terminal's capabilities, in which case it is followed by an #\@.
-;;; Negated fields are stored with the value :negated since we only store a
-;;; field if it does not already have a value -- this is the intent of the
-;;; sequencing built into the termcap file.  When we are done, we see if there
-;;; is a similar terminal to be parsed, and when we are really done, we replace
-;;; all the :negated's with nil's.
-;;; 
-(defun parse-fields (stream)
-  (prog ((termcap-name (make-string 2))
-	 (termcap ())
-	 char termcap-def)
-  GET-NAME
-    ;;
-    ;; This state expects char to be a #\:.
-    (case (getchar)
-      ((#\space #\tab)
-       (go GET-NAME))
-      (#\:
-       ;; This is an empty field.
-       (go GET-NAME))
-      ((#\newline :eof)
-       (go MAYBE-DONE))
-      (t
-       (setf (schar termcap-name 0) char)))
-    (setf (schar termcap-name 1) (getchar))
-    (setf termcap-def (termcap-def termcap-name))
-    (unless termcap-def (go EAT-FIELD))
-    (when (char= (getchar) #\@)
-      ;; Negation of a capability to be inherited from a similar terminal.
-      (store-field (termcap-def-cl-name termcap-def) :negated)
-      (go EAT-FIELD))
-    (case (termcap-def-type termcap-def)
-      (:number (go NUMBER))
-      (:boolean (go BOOLEAN))
-      (:string (go STRING)))
-  NUMBER
-    (unless (char= char #\#)
-      (error "Bad termcap format -- number field '#' missing."))
-    (let ((number 0)
-	  digit)
-      (loop
-       (setf digit (digit-char-p (getchar)))
-       (if digit
-	   (setf number (+ digit (* number 10)))
-	   (if (char= char #\:)
-	       (return)
-	       (error "Bad termcap format -- number field not : terminated."))))
-      (store-field (termcap-def-cl-name termcap-def) number)
-      (go GET-NAME))
-  BOOLEAN
-    (store-field (termcap-def-cl-name termcap-def) t)
-    (if (char= char #\:)
-	(go GET-NAME)
-	(error "Bad termcap format -- boolean field not : terminated."))
-  STRING
-    (unless (char= char #\=)
-      (error "Bad termcap format -- string field '=' missing."))
-    ;;
-    ;; Eat up any cost of the capability.
-    (when (digit-char-p (getchar))
-      (let ((dotp nil))
-	(loop
-	 (case (getchar)
-	   ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
-	   (#\.
-	    (when dotp (return))
-	    (setf dotp t))
-	   (t (when (char= char #\*) (getchar)) ; '*' means a per line cost
-	      (return))))))
-    ;;
-    ;; Collect the characters.
-    (let ((normal-string-p (not (eq (termcap-def-cl-name termcap-def)
-				    :cursor-motion)))
-	  xp cm-info)
-      (init-termcap-string-buffer)
-      (loop
-       (case (setf char (get-termcap-string-char stream char))
-	 (#\%
-	  (if normal-string-p
-	      (store-char #\%)
-	      (case (getchar)
-		(#\% (store-char #\%))
-		((#\d #\2 #\3)
-		 (push (if (char= char #\d) 0 (digit-char-p char))
-		       cm-info)
-		 (push (if xp :y-pad :x-pad) cm-info)
-		 (push (termcap-string-buffer-string) cm-info)
-		 (push (if xp :string2 :string1) cm-info)
-		 (init-termcap-string-buffer)
-		 (setf xp t))
-		(#\.
-		 (push (termcap-string-buffer-string) cm-info)
-		 (push (if xp :string2 :string1) cm-info)
-		 (init-termcap-string-buffer)
-		 (setf xp t))
-		(#\+
-		 (push (termcap-string-buffer-string) cm-info)
-		 (push (if xp :string2 :string1) cm-info)
-		 (push (get-termcap-string-char stream (getchar)) cm-info)
-		 (push (if xp :y-add-char :x-add-char) cm-info)
-		 (init-termcap-string-buffer)
-		 (setf xp t))
-		(#\>
-		 (push (get-termcap-string-char stream (getchar)) cm-info)
-		 (push (if xp :y-condx-char :x-condx-char) cm-info)
-		 (push (get-termcap-string-char stream (getchar)) cm-info)
-		 (push (if xp :y-condx-add-char :x-condx-add-char) cm-info))
-		(#\r
-		 (push t cm-info)
-		 (push :reversep cm-info))
-		(#\i
-		 (push t cm-info)
-		 (push :one-origin cm-info)))))
-	 (#\:
-	  (store-field (termcap-def-cl-name termcap-def)
-		       (cond (normal-string-p (termcap-string-buffer-string))
-			     (t (push (termcap-string-buffer-string) cm-info)
-				(cons :string3 cm-info))))
-	  (return))
-	 (t (store-char char)))
-       (getchar))
-      (go GET-NAME))
-  EAT-FIELD
-    (loop (when (char= (getchar) #\:) (return)))
-    (go GET-NAME)
-  MAYBE-DONE
-    (let* ((similar-terminal (assoc :similar-terminal termcap :test #'eq))
-	   (name (cdr similar-terminal)))
-      (when name
-	(file-position stream :start)
-	(setf (cdr similar-terminal) nil)
-	(if (find-termcap-entry name stream)
-	    (go GET-NAME)
-	    (error "Unknown similar terminal name -- ~S." name))))
-    (dolist (ele termcap)
-      (when (eq (cdr ele) :negated)
-	(setf (cdr ele) nil)))
-    (return termcap)))
-
-;;; GET-TERMCAP-STRING-CHAR -- Internal.
-;;;
-;;; This parses/lexes an ASCII character out of the termcap file and converts
-;;; it into the appropriate Common Lisp character.  This is a Common Lisp
-;;; character with the same CHAR-CODE code as the ASCII code, so writing the
-;;; character to the tty will have the desired effect.  If this function needs
-;;; to look ahead to determine any characters, it unreads the character.
-;;;
-(defun get-termcap-string-char (stream char)
-  (case char
-    (#\\
-     (case (getchar)
-       (#\E (code-char 27))
-       (#\n (code-char 10))
-       (#\r (code-char 13))
-       (#\t (code-char 9))
-       (#\b (code-char 8))
-       (#\f (code-char 12))
-       (#\^ #\^)
-       (#\\ #\\)
-       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
-	(let ((result 0)
-	      (digit (digit-char-p char)))
-	  (loop (setf result (+ digit (* 8 result)))
-	    (unless (setf digit (digit-char-p (getchar)))
-	      (ungetchar char)
-	      (return (code-char (ldb (byte 7 0) result)))))))
-       (t (error "Bad termcap format -- unknown backslash character."))))
-    (#\^
-     (code-char (- (char-code (char-upcase (getchar))) 64)))
-    (t char)))
-
-
-;;;; Initialization file string.
-
-(defun get-init-file-string (f)
-  (unless (probe-file f)
-    (error "File containing terminal initialization string does not exist -- ~S."
-	   f))
-  (with-open-file (s f)
-    (let* ((len (file-length s))
-	   (string (make-string len)))
-      (dotimes (i len string)
-	(setf (schar string i) (read-char s))))))
diff --git a/hemlock/text.lisp b/hemlock/text.lisp
deleted file mode 100644
index 83776da8593b5d3b0fb38c5b64f0fa11376dac44..0000000000000000000000000000000000000000
--- a/hemlock/text.lisp
+++ /dev/null
@@ -1,572 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/text.lisp,v 1.1.1.3 1991/10/03 15:16:27 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles
-;;;
-;;; This file contains stuff that operates on units of texts, such as
-;;;    paragraphs, sentences, lines, and words.
-;;;
-
-(in-package "HEMLOCK")
-
-;;;; -- New Variables --
-
-(defhvar "Paragraph Delimiter Function"
-  "The function that returns whether or not the current line should break the 
-  paragraph." 
-  :value 'default-para-delim-function)
-
-;;; The standard paragraph delimiting function is DEFAULT-PARA-DELIM-FUNCTION
-(defun default-para-delim-function (mark)
-  "Return whether or not to break on this line."
-  (paragraph-delimiter-attribute-p (next-character mark)))
-
-;;;; -- Paragraph Commands --
-
-(defcommand "Forward Paragraph" (p)
-  "moves point to the end of the current (next) paragraph."
-  "moves point to the end of the current (next) paragraph."
-  (let ((point (current-point)))
-    (unless (paragraph-offset point (or p 1))
-      (buffer-end point)
-      (editor-error))))
-
-(defcommand "Backward Paragraph" (p)
-  "moves point to the start of the current (previous) paragraph."
-  "moves point to the start of the current (previous) paragraph."
-  (let ((point (current-point)))
-    (unless (paragraph-offset point (- (or p 1)))
-      (buffer-start point)
-      (editor-error))))
-
-(defcommand "Mark Paragraph" (p)
-  "Put mark and point around current or next paragraph.
-   A paragraph is delimited by a blank line, a line beginning with a
-   special character (@,\,-,',and .), or it is begun with a line with at
-   least one whitespace character starting it.  Prefixes are ignored or
-   skipped over before determining if a line starts or delimits a
-   paragraph."
-  "Put mark and point around current or next paragraph."
-  (declare (ignore p))
-  (let* ((point (current-point))
-	 (mark (copy-mark point :temporary)))
-    (if (mark-paragraph point mark)
-	(push-buffer-mark mark t)
-	(editor-error))))
-
-(defun mark-paragraph (mark1 mark2)
-  "Mark the next or current paragraph, setting mark1 to the beginning and mark2
-   to the end.  This uses \"Fill Prefix\", and mark1 is always on the first
-   line of the paragraph.  If no paragraph is found, then the marks are not
-   moved, and nil is returned."
-  (with-mark ((tmark1 mark1)
-	      (tmark2 mark2))
-    (let* ((prefix (value fill-prefix))
-	   (prefix-len (length prefix))
-	   (paragraphp (paragraph-offset tmark2 1)))
-      (when (or paragraphp
-		(and (last-line-p tmark2)
-		     (end-line-p tmark2)
-		     (not (blank-line-p (mark-line tmark2)))))
-	(mark-before (move-mark tmark1 tmark2))
-	(%fill-paragraph-start tmark1 prefix prefix-len)
-	(move-mark mark1 tmark1)
-	(move-mark mark2 tmark2)))))
-
-
-
-(eval-when (compile eval)
-
-;;;      %MARK-TO-PARAGRAPH moves mark to next immediate (current)
-;;; paragraph in the specified direction.  Nil is returned when no
-;;; paragraph is found.  NOTE: the order of the arguments to OR within the
-;;; first branch of the COND must be as it is, and mark must be at the
-;;; beginning of the line it is on.
-(defmacro %mark-to-paragraph (mark prefix prefix-length
-				   &optional (direction :forward))
-  `(do ((skip-prefix-p)
-	(paragraph-delim-function (value paragraph-delimiter-function)))
-       (nil)
-     (setf skip-prefix-p
-	   (and ,prefix (%line-has-prefix-p ,mark ,prefix ,prefix-length)))
-     (if skip-prefix-p (character-offset ,mark ,prefix-length))
-     (let ((next-char (next-character ,mark)))
-       (cond ((and (not (blank-after-p ,mark))
-		   (or (whitespace-attribute-p next-char)
-		       (not (funcall paragraph-delim-function ,mark))))
-	      (return (if skip-prefix-p (line-start ,mark) ,mark)))
-	     (,(if (eq direction :forward)
-		   `(last-line-p ,mark)
-		   `(first-line-p ,mark))
-	      (if skip-prefix-p (line-start ,mark))
-	      (return nil)))
-       (line-offset ,mark ,(if (eq direction :forward) 1 -1) 0))))
-
-
-;;;      %PARAGRAPH-OFFSET-AUX is the inner loop of PARAGRAPH-OFFSET.  It
-;;; moves over a paragraph to find the beginning or end depending on
-;;; direction.  Prefixes on a line are ignored or skipped over before it
-;;; is determined if the line is a paragraph boundary.
-(defmacro %paragraph-offset-aux (mark prefix prefix-length
-				       &optional (direction :forward))
-  `(do ((paragraph-delim-function (value paragraph-delimiter-function))
-	(skip-prefix-p))
-       (nil)
-     (setf skip-prefix-p
-	   (and ,prefix (%line-has-prefix-p ,mark ,prefix ,prefix-length)))
-     (if skip-prefix-p (character-offset ,mark ,prefix-length))
-     (cond ((or (blank-after-p ,mark)
-		(funcall paragraph-delim-function ,mark))
-	    (return (line-start ,mark)))
-	   (,(if (eq direction :forward)
-		 `(last-line-p ,mark)
-		 `(first-line-p ,mark))
-	    (return ,(if (eq direction :forward)
-			 `(line-end ,mark)
-			 `(line-start ,mark)))))
-     (line-offset ,mark ,(if (eq direction :forward) 1 -1) 0)))
-
-); (eval-when (compile eval)
-
-
-
-;;;      PARAGRAPH-OFFSET takes a mark and a number of paragraphs to
-;;; move over.  If the specified number of paragraphs does not exist in
-;;; the direction indicated by the sign of number, then nil is
-;;; returned, otherwise the mark is returned.
-
-(defun paragraph-offset (mark number &optional (prefix (value fill-prefix)))
-  "moves mark past the specified number of paragraph, forward if the number
-   is positive and vice versa.  If the specified number of paragraphs do
-   not exist in the direction indicated by the sign of the number, then nil
-   is returned, otherwise the mark is returned."
-  (if (plusp number)
-      (%paragraph-offset-forward mark number prefix)
-      (%paragraph-offset-backward mark number prefix)))
-
-
-
-;;;      %PARAGRAPH-OFFSET-FORWARD moves mark forward over number
-;;; paragraphs.  The first branch of the COND is necessary for the side
-;;; effect provided by LINE-OFFSET.  If %MARK-TO-PARAGRAPH left tmark at
-;;; the beginning of some paragraph %PARAGRAPH-OFFSET-AUX will think it has
-;;; moved mark past a paragraph, so we make sure tmark is inside the
-;;; paragraph or after it.
-
-(defun %paragraph-offset-forward (mark number prefix)
-  (do* ((n number (1- n))
-	(tmark (line-start (copy-mark mark :temporary)))
-	(prefix-length (length prefix))
-	(paragraphp (%mark-to-paragraph tmark prefix prefix-length)
-		    (if (plusp n)
-			(%mark-to-paragraph tmark prefix prefix-length))))
-       ((zerop n) (move-mark mark tmark))
-    (cond ((and paragraphp (not (line-offset tmark 1))) ; 
-	   (if (or (> n 1) (and (last-line-p mark) (end-line-p mark)))
-	       (return nil))
-	   (return (line-end (move-mark mark tmark))))
-	  (paragraphp (%paragraph-offset-aux tmark prefix prefix-length))
-	  (t (return nil)))))
-  
-
-
-(defun %paragraph-offset-backward (mark number prefix)
-  (with-mark ((tmark1 mark)
-	      (tmark2 mark))
-    (do* ((n (abs number) (1- n))
-	  (prefix-length (length prefix))
-	  (paragraphp (%para-offset-back-find-para tmark1 prefix
-						   prefix-length mark)
-		      (if (plusp n)
-			  (%para-offset-back-find-para tmark1 prefix
-						       prefix-length tmark2))))
-	 ((zerop n) (move-mark mark tmark1))
-      (cond ((and paragraphp (first-line-p tmark1))
-	     (if (and (first-line-p mark) (start-line-p mark))
-		 (return nil)
-		 (if (> n 1) (return nil))))
-	    (paragraphp
-	     (%paragraph-offset-aux tmark1 prefix prefix-length :backward)
-	     (%para-offset-back-place-mark tmark1 prefix prefix-length))
-	    (t (return nil))))))
-
-
-
-;;;      %PARA-OFFSET-BACK-PLACE-MARK makes sure that mark is in
-;;; the right place when it has been moved backward over a paragraph.  The
-;;; "right place" is defined to be where EMACS leaves it for a given
-;;; situation or where it is necessary to ensure the mark's skipping
-;;; backward over another paragraph if PARAGRAPH-OFFSET was given an
-;;; argument with a greater magnitude than one.  I believe these two
-;;; constraints are equivalent; that is, neither changes what the other
-;;; would dictate.
-
-(defun %para-offset-back-place-mark (mark prefix prefix-length)
-  (skip-prefix-if-here mark prefix prefix-length)
-  (cond ((text-blank-line-p mark) (line-start mark))
-	((not (first-line-p mark))
-	 (line-offset mark -1 0)
-	 (skip-prefix-if-here mark prefix prefix-length)
-	 (if (text-blank-line-p mark)
-	     (line-start mark)
-	     (line-offset mark 1 0)))))
-
-
-
-(defun %para-offset-back-find-para (mark1 prefix prefix-length mark2)
-  (move-mark mark2 mark1)
-  (line-start mark1)
-  (let ((para-p (%mark-to-paragraph mark1 prefix prefix-length :backward)))
-    (cond ((and para-p (same-line-p mark1 mark2))
-	   (skip-prefix-if-here mark1 prefix prefix-length)
-	   (find-attribute mark1 :whitespace #'zerop)
-	   (cond ((mark<= mark2 mark1)
-		  (line-offset mark1 -1 0)
-		  (%mark-to-paragraph mark1 prefix prefix-length :backward))
-		 (t (line-start mark1))))
-	  (t para-p))))
-
-
-
-;;;; -- Sentence Commands --
-
-(defcommand "Forward Sentence" (p)
-  "Moves forward one sentence or the specified number.
-   A sentence terminates with a .,?, or ! followed by any number of closing
-   delimiters (such as \",',),],>,|) which are followed by either two
-   spaces or a newline."
-  "Moves forward one sentence or the specified number."
-  (unless (sentence-offset (current-point) (or p 1))
-    (editor-error)))
-
-
-
-(defcommand "Backward Sentence" (p)
-  "Moves backward one sentence or the specified number.
-   A sentence terminates with a .,?, or ! followed by any number of closing
-   delimiters (such as \",',),],>,|) which are followed by either two
-   spaces or a newline."
-  "Moves backward one sentence or the specified number."
-   (unless (sentence-offset (current-point) (- (or p 1)))
-    (editor-error)))
-
-
-
-(defcommand "Mark Sentence" (p)
-  "Put mark and point around current or next sentence.
-   A sentence terminates with a .,?, or ! followed by any number of closing
-   delimiters (such as \",',),],>,|) which are followed by either two
-   spaces or a newline."
-  "Put mark and point around current or next sentence."
-  (declare (ignore p))
-  (let* ((point (current-point))
-	 (end (copy-mark point :temporary)))
-    (unless (sentence-offset end 1) (editor-error))
-    (move-mark point end)
-    (sentence-offset point -1)
-    (push-buffer-mark end t)))
-
-
-(defcommand "Forward Kill Sentence" (p)
-  "Kill forward to end of sentence."
-  "Kill forward to end of sentence."
-  (let ((point (current-point))
-	(offset (or p 1)))
-    (with-mark ((mark point))
-      (if (sentence-offset mark offset)
-	  (if (plusp offset)
-	      (kill-region (region point mark) :kill-forward)
-	      (kill-region (region mark point) :kill-backward))
-	  (editor-error)))))
-
-(defcommand "Backward Kill Sentence" (p)
-  "Kill backward to beginning of sentence."
-  "Kill backward to beginning of sentence."
-  (forward-kill-sentence-command (- (or p 1))))
-
-;;;      SENTENCE-OFFSET-END-P returns true if mark is at the end of a
-;;; sentence.  If that the end of a sentence, it leaves mark at an
-;;; appropriate position with respect to the sentence-terminator character,
-;;; the beginning of the next sentence, and direction.  See the commands
-;;; "Forward Sentence" and "Backward Sentence" for a definition of a sentence.
-
-(eval-when (compile eval)
-(defmacro sentence-offset-end-p (mark &optional (direction :forward))
-  `(let ((start (mark-charpos ,mark)))
-     (do ()
-	 ((not (sentence-closing-char-attribute-p (next-character ,mark))))
-       (mark-after ,mark))
-     (let ((next (next-character ,mark)))
-       (cond ((or (not next)
-		  (char= next #\newline))
-	      ,(if (eq direction :forward) mark `(mark-after ,mark)))
-	     ((and (char= next #\space)
-		   (member (next-character (mark-after ,mark))
-			   '(nil #\space #\newline)))
-	      ,(if (eq direction :forward)
-		   `(mark-before ,mark)
-		   `(mark-after ,mark)))
-	     (t (move-to-position ,mark start)
-		nil)))))
-); (eval-when (compile eval)
-
-
-
-;;;      SENTENCE-OFFSET-FIND-END moves in the direction direction stopping
-;;; at sentence terminating characters until either there are not any more
-;;; such characters or one is found that defines the end of a sentence.
-;;; When looking backwards, we may be at the beginning of some sentence,
-;;; and if we are, then we must move mark before the sentence terminator;
-;;; otherwise, we would find the immediately preceding sentence terminator
-;;; and end up right where we started.
-
-(eval-when (compile eval)
-(defmacro sentence-offset-find-end (mark &optional (direction :forward))
-  `(progn
-    ,@(if (eq direction :backward)
-	  `((reverse-find-attribute ,mark :whitespace #'zerop)
-	    (when (fill-region-insert-two-spaces-p ,mark)
-	      (reverse-find-attribute ,mark :sentence-terminator)
-	      (mark-before ,mark))))
-    (do ((foundp) (endp)) (nil)
-      (setf foundp ,(if (eq direction :forward)
-			`(find-attribute ,mark :sentence-terminator)
-			`(reverse-find-attribute ,mark :sentence-terminator)))
-      (setf endp ,(if (eq direction :forward)
-		      `(if foundp (progn (mark-after ,mark)
-					 (sentence-offset-end-p ,mark)))
-		      `(if foundp (sentence-offset-end-p ,mark :backward))))
-      (if endp (return ,mark))
-      ,(if (eq direction :forward)
-	   `(unless foundp (return nil))
-	   `(if foundp (mark-before ,mark) (return nil))))))
-); (eval-when (compile eval)
-
-
-
-;;;      SENTENCE-OFFSET takes a mark and a number of paragraphs to move
-;;; over.  If the specified number of paragraphs does not exist in
-;;; the direction indicated by the sign of the number, then nil is returned,
-;;; otherwise the mark is returned.
-
-(defun sentence-offset (mark number)
-  (if (plusp number)
-      (sentence-offset-forward mark number)
-      (sentence-offset-backward mark (abs number))))
-
-
-
-;;;      SENTENCE-OFFSET-FORWARD tries to move mark forward over number
-;;; sentences.  If it can, then mark is moved and returned; otherwise, mark
-;;; remains unmoved, and nil is returned.  When tmark2 is moved to the end
-;;; of a new paragraph, we reverse find for a non-whitespace character to
-;;; bring tmark2 to the end of the previous line.  This is necessary to
-;;; detect if tmark1 is at the end of the paragraph, in which case tmark2
-;;; wants to be moved over another paragraph.
-
-(defun sentence-offset-forward (mark number)
-  (with-mark ((tmark1 mark)
-	      (tmark2 mark))
-    (do ((n number (1- n))
-	 (found-paragraph-p))
-	((zerop n) (move-mark mark tmark1))
-      (when (and (mark<= tmark2 tmark1)
-		 (setf found-paragraph-p (paragraph-offset tmark2 1)))
-	(reverse-find-attribute tmark2 :whitespace #'zerop)
-	(when (mark>= tmark1 tmark2)
-	  (line-offset tmark2 1 0)
-	  (setf found-paragraph-p (paragraph-offset tmark2 1))
-	  (reverse-find-attribute tmark2 :whitespace #'zerop)))
-      (cond ((sentence-offset-find-end tmark1)
-	     (if (mark> tmark1 tmark2) (move-mark tmark1 tmark2)))
-	    (found-paragraph-p (move-mark tmark1 tmark2))
-	    (t (return nil))))))
-
-
-
-(defun sentence-offset-backward (mark number)
-  (with-mark ((tmark1 mark)
-	      (tmark2 mark)
-	      (tmark3 mark))
-    (do* ((n number (1- n))
-	  (prefix (value fill-prefix))
-	  (prefix-length (length prefix))
-	  (found-paragraph-p
-	   (cond ((paragraph-offset tmark2 -1)
-		  (sent-back-place-para-start tmark2 prefix prefix-length)
-		  t))))
-	 ((zerop n) (move-mark mark tmark1))
-      (move-mark tmark3 tmark1)
-      (when (and (sent-back-para-start-p tmark1 tmark3 prefix prefix-length)
-		 (setf found-paragraph-p
-		       (paragraph-offset (move-mark tmark2 tmark3) -1)))
-	(paragraph-offset (move-mark tmark1 tmark2) 1)
-	(sent-back-place-para-start tmark2 prefix prefix-length))
-      (cond ((sentence-offset-find-end tmark1 :backward)
-	     (if (mark< tmark1 tmark2) (move-mark tmark1 tmark2)))
-	    (found-paragraph-p (move-mark tmark1 tmark2))
-	    (t (return nil))))))
-
-
-
-(defun sent-back-para-start-p (mark1 mark2 prefix prefix-length)
-  (skip-prefix-if-here (line-start mark2) prefix prefix-length)
-  (cond ((text-blank-line-p mark2)
-	 (line-start mark2))
-	((whitespace-attribute-p (next-character mark2))
-	 (find-attribute mark2 :whitespace #'zerop)
-	 (if (mark= mark1 mark2) (line-offset mark2 -1 0)))
-	((and (mark= mark2 mark1) (line-offset mark2 -1 0))
-	 (skip-prefix-if-here mark2 prefix prefix-length)
-	 (if (text-blank-line-p mark2)
-	     (line-start mark2)))))
-
-
-
-(defun sent-back-place-para-start (mark2 prefix prefix-length)
-  (skip-prefix-if-here mark2 prefix prefix-length)
-  (when (text-blank-line-p mark2)
-    (line-offset mark2 1 0)
-    (skip-prefix-if-here mark2 prefix prefix-length))
-  (find-attribute mark2 :whitespace #'zerop))
-
-
-
-;;;; -- Transposing Stuff --
-
-(defcommand "Transpose Words" (p)
-  "Transpose the words before and after the cursor.
-   With a positive argument it transposes the words before and after the
-   cursor, moves right, and repeats the specified number of times,
-   dragging the word to the left of the cursor right.  With a negative
-   argument, it transposes the two words to the left of the cursor, moves
-   between them, and repeats the specified number of times, exactly undoing
-   the positive argument form."
-  "Transpose the words before and after the cursor."
-  (let ((num (or p 1))
-	(point (current-point)))
-    (with-mark ((mark point :left-inserting)
-		(start point :left-inserting))
-      (let ((mark-prev (previous-character mark))
-	    (mark-next (next-character mark)))
-	(cond ((plusp num)
-	       (let ((forwardp (word-offset point num))
-		     (backwardp (if (or (word-delimiter-attribute-p mark-next)
-					(word-delimiter-attribute-p mark-prev))
-				    (word-offset mark -1)
-				    (word-offset mark -2))))
-		 (if (and forwardp backwardp)
-		     (transpose-words-forward mark point start)
-		     (editor-error))))
-	      ((minusp num)
-	       (let ((enoughp (word-offset point (1- num))))
-		 (if (word-delimiter-attribute-p mark-prev)
-		     (reverse-find-attribute mark :word-delimiter #'zerop)
-		     (find-attribute mark :word-delimiter))
-		 (if enoughp
-		     (transpose-words-backward point mark start)
-		     (editor-error))))
-	      (t (editor-error)))))))
-
-
-(defun transpose-words-forward (mark1 end mark2)
-  (with-mark ((tmark1 mark1 :left-inserting)
-	      (tmark2 mark2 :left-inserting))
-    (find-attribute tmark1 :word-delimiter)
-    (do ((region1 (delete-and-save-region (region mark1 tmark1))))
-	((mark= tmark2 end) (ninsert-region end region1))
-      (word-offset tmark2 1)
-      (reverse-find-attribute (move-mark tmark1 tmark2) :word-delimiter)
-      (ninsert-region mark1 (delete-and-save-region (region tmark1 tmark2)))
-      (move-mark mark1 tmark1))))
-
-
-(defun transpose-words-backward (start mark1 mark2)
-  (with-mark ((tmark1 mark1 :left-inserting)
-	      (tmark2 mark2 :left-inserting))
-    (reverse-find-attribute tmark1 :word-delimiter)
-    (move-mark mark2 mark1)
-    (do ((region1 (delete-and-save-region (region tmark1 mark1))))
-	((mark= tmark1 start) (ninsert-region start region1))
-      (word-offset tmark1 -1)
-      (find-attribute (move-mark tmark2 tmark1) :word-delimiter)
-      (ninsert-region mark1 (delete-and-save-region (region tmark1 tmark2)))
-      (move-mark mark1 tmark1))))
-
-(defcommand "Transpose Lines" (p)
-  "Transpose the current line with the line before the cursor.
-   With a positive argument it transposes the current line with the one
-   before, moves down a line, and repeats the specified number of times,
-   dragging the originally current line down.  With a negative argument, it
-   transposes the two lines to the prior to the current, moves up a line,
-   and repeats the specified number of times, exactly undoing the positive
-   argument form.  With a zero argument, it transposes the lines at point
-   and mark."
-  "Transpose the current line with the line before the cursor."
-  (let ((num (or p 1))
-	 (point (current-point)))
-    (with-mark ((mark point :left-inserting))
-      (cond ((plusp num)
-	     (if (and (line-offset mark -1 0)
-		      (line-offset point num 0))
-		 (transpose-lines mark point)
-		 (editor-error)))
-	    ((minusp num)
-	     (cond ((and (line-offset mark (1- num) 0)
-			 (line-offset point -1 0))
-		    (transpose-lines point mark)
-		    (move-mark point mark))
-		   (t (editor-error))))
-	    (t
-	     (rotatef (line-string (mark-line point))
-		      (line-string (mark-line (current-mark))))
-	     (line-start point))))))
-
-
-(defun transpose-lines (mark1 mark2)
-  (with-mark ((tmark1 mark1))
-    (line-offset tmark1 1)
-    (ninsert-region mark2 (delete-and-save-region (region mark1 tmark1)))))
-
-
-
-;;;; -- Utilities --
-
-(defun skip-prefix-if-here (mark prefix prefix-length)
-  (if (and prefix (%line-has-prefix-p mark prefix prefix-length))
-      (character-offset mark prefix-length)))
-
-
-
-(defun text-blank-line-p (mark)
-  (let ((next-char (next-character mark)))
-    (or (blank-after-p mark)
-	(and (funcall (value paragraph-delimiter-function) mark)
-	     (not (whitespace-attribute-p next-char))))))
-
-
-
-(defun whitespace-attribute-p (char)
-  (= (character-attribute :whitespace char) 1))
-
-(defun sentence-terminator-attribute-p (char)
-  (= (character-attribute :sentence-terminator char) 1))
-
-(defun sentence-closing-char-attribute-p (char)
-  (= (character-attribute :sentence-closing-char char) 1))
-
-(defun paragraph-delimiter-attribute-p (char)
-  (= (character-attribute :paragraph-delimiter char) 1))
-
-(defun word-delimiter-attribute-p (char)
-  (= (character-attribute :word-delimiter char) 1))
diff --git a/hemlock/things-to-do.txt b/hemlock/things-to-do.txt
deleted file mode 100644
index d0c7b4f06614575144c7bc3ed34bfcea1c0e5860..0000000000000000000000000000000000000000
--- a/hemlock/things-to-do.txt
+++ /dev/null
@@ -1,621 +0,0 @@
--*- Mode: Text; Package: Hemlock; Editor: t -*-
-
-
-
-;;;; X problems.
-
-Compute mininum width of a window group by taking the maximum of all the
-windows' font-widths, each multiplied by minimum-window-columns.  Right now it
-just uses the default font or current window.
-
-Compute minimum window split correctly: look at current window's font-height
-and new window's font-height, extra height pixels, whether each has a modeline,
-and minimum-window-lines to determine if we can split the current window.
-
-Server not implementing DRAW-IMAGE-GLYPHS correctly, so we don't have to do our
-pixmap hack.
-
-
-
-;;;; Bill and/or Rob.
-
-Make editor-error messages; that is just make many of the (editor-error)
-forms have some string to be printed.
-   Importance: often beeps and don't know why.
-   Difficulty: pervasive search for EDITOR-ERROR.
-
-Probably the ERROR for trying to modify a read-only buffer could/should be an
-EDITOR-ERROR.  Maybe the error message should be a Hemlock variable that can be
-set for certain buffers or modes.
-
-Make definition editing different.  Maybe only one command that offers some
-appropriate default, requiring confirmation.  Maybe some way to rightly know to
-edit the function named under a #'name instead of the function name in a
-function position.  Think about whizzy, general definition location logging and
-finding mechanism that is user extensible.
-
-Think about regular expression searching.
-   Importance: it would be used weekly by some and daily by others.
-
-Make illegal setting window width and height, (or support this).
-
-Think about example init file for randoms.  It should show most of the simple
-through intermediate customizations one would want to do starting to use
-Hemlock.
-  setting variables
-  file type hooks
-  hooks
-  transposing two keys
-  changing modifiers
-  
-DEFMODE should take a keyword argument for the modeline name, so "Fill"
-could be named "Auto Fill" but show "Fill" in the modeline (similarly with
-"Spell" and "Save").
-   Importance: low.
-   Difficulty: low.
-
-Optional doc strings for commands?
-   Importance: suggested by a couple people.
-   Difficulty: ???
-
-Get a real italic comment mode.
-   Importance: some people want it, like Scott.
-   Difficulty: hard to do right.
-
-Line-wrap-character a user feature?  Per device?  Per device set from Hvar?
-   Importance: a few people set this already for bitmap devices.
-   Difficulty: low.
-   Bill should just throw this in.
-
-When MESSAGE'ing the line of a matching open paren, can something be done to
-make the exact open paren more pronounced -- SUBSEQ'ing the line string?
-   Importance: low
-   Difficulty: one line frob to major echo area changes.
-
-Do something about active region highlighting and blank lines.  Consider
-changing redisplay to be able to hack some glyph onto the line, a virtual
-newline or something.
-   Importance: blank lines at the ends of the active region can be confusing.
-   Difficulty: unknown difficult changes to redisplay.
-
-Change redisplay on bitmaps to draw top down?  Currently line writes are queued
-going down the window image but the queue is written backwards.
-   Importance: low, two people commented on how it looks funny.
-   Difficulty: unknown, but probably little.
-
-Disallow tty I/O when the tty is in a bad state.  Since editor is sharing
-Unix standard input with *terminal-io*, doing reads on this is bad among
-other problems.
-   Importance: necessary or non-experienced users.
-   Difficulty: slight.  Error system wants to use *terminal-io* if you go
-               into a break loop from the editor.
-   Bill.
-
-Make Lisp indentation respect user indentation even when in a form with known
-special arguments?
-   Importance: noticeable correctness.
-   Difficulty: Lucid wrote this already with LOOP macro.
-   Rob.
-Make Lisp motion that exceeds the parsed region lose more gracefully by
-informing the user, possibly offering to enlarge the parsing parameters.
-   Importance: very deceptive as it is currently.
-   Difficulty: ???
-   Rob.
-Lisp motion fails to handle correctly vertical bar syntax; for example,
-      package:|foo|
-   Importance: correctness, not too necessary
-   Difficulty: ???
-"Editor Evaluate Defun" does not handle multiple value returns correctly
-... if we admit that this is often used to evaluate non-DEFUN top-level
-forms.
-   Importance: user convenience.
-   Difficulty: low.
-
-Super-confirm select buffer.  Super confirm means "make this be a legal
-input".  Has no interaction with prompting function interface.  More
-generally, make a *super-confirm-parse-function* that can be bound around
-prompters.  One suggestion when prompting for a buffer is to make it, but
-another suggestion is to find file some appropriate file.
-   Importance: multiple people requested.
-   Difficulty: low.
-   Bill.
-A super-confirm for a more facist "Find File" that disallowed creating buffers
-when the file didn't exist could tell the command to really create the buffer.
-
-Displayed-p shouldn't directly call update-window-image, or perhaps uwi should
-be changed to check if the ticks and whatnot indicate recomputation is needed.
-   Importance: minor efficiency hack and maybe a little cleaner.
-   Difficulty: low.
-   Bill.
-
-Fix line-length for hemlock output streams.  The following example causes lines
-to brek incorrectly in "Eval" mode but not in "Typescript" mode:
-   (defun dup (x n &aux r) (dolist (i n r) (push x r)))
-   (dup 'a 100)     ;lines wrap due to faulty line breaking
-   (dup 'aa 100)    ;lines wrap due to faulty line breaking
-   (dup 'aaa 100)   ;now lines break correctly
-   Importance: correctness.  It's not screwing anyone.
-   Difficulty: depends on what the right thing is.
-
-Termcap bug:
-   setenv TERMCAP "foobar:li#65:tc=vt102:"
-   set term = foobar
-This causes an EOF unexpectedly on the string stream.  This is because the
-the termcap parsing stuff wasn't written to go all the way back to the top
-entry point to determine what file to use when the TERMCAP variable had an
-indirection.  The code currently just goes to the beginning of the stream
-and looks for the new tty name.
-
-Make prompt text not part of input buffer.  Do some magical thing to solve
-the problem of having special echo area commands that simply get around the
-prompt text in the echo are buffer.
-   Importance: low sense problem is currently somewhat taken care of.
-	       Possibly resolve problem when new Hemlock environment stuff
-	       goes in.
-   Difficulty: Magical in origin.
-   Rob.
-
-Commonify everything.  Make everything portable that could be made so (file
-system extensions, character att. finding, string ops, etc.) and document
-our expectations of the non-portable stuff we lean on.  Provide portable
-code for stuff done in assembler.
-   Some known problems:
-      %sp- functions aren't documented and don't have portable code for
-         them.
-      semantics of initial values versus declared type.
-      :error-file to COMPILE-FILE calls.
-
-   Importance: cleanliness and portability ease for those who want our
-	       code.
-   Difficulty: identify the problems and alter some code.
-   Bill and Rob.
-
-Fix things that keep text from getting gc'ed.  Buffer local things keep
-pointer to buffer.
-   Importance: could be important, maybe nothing is wrong.
-   Difficulty: identifying problems.
-   Bill or Rob.
-
-Two reproducible window image builder bugs:
-THIS IS NUMBER ONE:
-I wrote this command:
-   (defcommand "Fetch Input" (p)
-     "Does \"Point to Here\" followed by \"Reenter Interactive Input\"."
-     "Does \"Point to Here\" followed by \"Reenter Interactive Input\"."
-     (declare (ignore p))
-     (point-to-here-command nil)
-     (reenter-interactive-input-command nil))
-I made the following bindings:
-   (bind-key "Fetch Input" #\hyper-leftdown :mode "Eval")
-   (bind-key "Fetch Input" #\hyper-leftdown :mode "Typescript")
-   (bind-key "Do Nothing" #\hyper-leftup :mode "Eval")
-   (bind-key "Do Nothing" #\hyper-leftup :mode "Typescript")
-In an interactive buffer I typed hyper-leftdown twice on the same line and
-got the following error:
-   Error in function HEMLOCK-INTERNALS::CACHED-REAL-LINE-LENGTH.
-   Vector index, 14700, out of bounds.
-This index is always the one you get no matter what line of input you try to
-enter twice.
-;;;
-THIS IS NUMBER TWO:
-Put point at the beginning of a small defun that has at least some interior
-lines in addition to the "(defun ..." line and the last line of the routine.
-Mark the defun and save the region.  Now, yank the defun, and note that the
-beginning of the second instance starts at the end of the line the yanked copy
-ends on.  Now type c-w.  You'll delete the yanked copy, and the lines that
-should not have been touched at all end up with font marks.  Interestingly the
-first line of the defun and the last don't get any font marks.
-   Importance: well, they are reproducible, and they're pretty ugly.  No one
-   	       has noticed these yet though.
-   Difficulty: Rob and I didn't conjure up the bugs after a casual inspection.
-   Bill AND Rob
-
-Consider a GNU-style undo where action is undo-able.
-   Importance: low, but people point it out as an inadequacy of Hemlock.
-   Difficulty: possibly very hard.  Have to figure out what's necessary first.
-   Bill and Rob
-
-
-;;;; Mailer stuff.
-
-Find all message-info-msgs sets and refs, changing them from possible list
-values to always be a simple-string value.  Maybe must leave a list (or make
-another slot) if I need to indicate that I can't use the value as a msg-id.
-The only problem is coming through SHOW-PROMPTED-MESSAGE.  This could pick or
-something to really know if there were more than one message or not.
-
-Write "Refile Message and Show Next".
-
-Do something about message headers when reading mail.  Suggestions include a
-list of headers components that get deleted from the buffer and simply
-scrolling the window past the "Received:" lines.
-
-Add more folder support and possibly something specific for Bovik groveling.
-For example, rehashing the cached folder names and/or adding new ones from a
-folder spec or root directory (allows adding the bovik folders).
-
-Consistency problems:
-   Expunging message should not JUST delete headers buffers and their
-   associated message buffers.  There could be independent message buffers with
-   invalid message id's.  Since these are independent, though, we might not
-   want to gratuitously delete them.
-
-   "Headers Delete Message" should check for message buffers when virtual
-   message deletion is not used, deleting them I suppose.  Instead of just
-   making headers buffers consistent.
-
-
-
-;;;; Spelling stuff.
-
-This stuff is probably for Rob or Bill, but think about undergrad
-dispatching before actually implementing it.
-
-Two apostrophes precede a punctuation character, as in:
-	``This is a very common occurrence in TeX.''
-"Correct Buffer Spelling" complains that '' is an unknown word.  The problem
-doesn't show up if the character preceding the apostrophes is alphabetic.
-
-"Correct Last Misspelled Word" should try to transpose the space on the
-ends of a word if there are more than one misspelling (adjacent?).  This
-would have to be done at the command level trying to correct different
-words formed from the buffer.
-
-Fahlman would like to see a list of words that are treated as errors, even
-though they may be in the dictionary.  These are considered common typos made
-that actually are rarely-used words.  These would be flagged as errors for the
-user to do a conscious double check on.
-
-When the spelling correction stuff cannot find any possible corrections, it
-could try inserting a space between letters that still form legal words,
-checking the two new words are in the dictionary.
-   Importance: possibly pretty useful, especially with "Spell" mode.
-   Difficulty: low to medium.
-   Bill, possibly undergrad after I looked at it.
-
-Fix "Undo Last Spelling" correction interaction with auto-fill.  When this
-command is invoked on a word that made auto-fill break the line, shit
-happens.
-   Importance: Rob noticed it.
-   Difficulty: unknown.
-   Bill or Rob.
-
-
-
-;;;; User and Implementors Manuals
-
-User Manual wall chart appendix based on systems (e.g., dired, mailer, Lisp
-editing, spelling, etc.), then modes (e.g., "Headers", "Message", and "Draft"),
-then whatever seems appropriate.
-
-Point out that "Make Buffer Hook" runs after mode setup.
-
-
-
-;;;; Things for undergrads.
-
-Create "Remote Load File" and make "Load File" use it the way "Compile File"
-uses "Remote Compile File".
-
-Make "Insert Scribe Directive" undo-able, and make the "command" insertion
-stuff use the active region.  Also, clean up terminology with respect to using
-command and environment.
-   Importance: it would be nice.
-   Difficulty: little
-
-Add a feature that notes modified or new lines, probably down in
-HI::MODIFYING-BUFFER.  Then add interfaces for moving over these lines, moving
-over text structures with these lines such as DEFUN's, paragraphs, etc.  Write
-commands that display these in some way, compile them, etc.
-
-Look at open paren highlighting and the Scribe bracket table stuff to make a
-general bracket highlighter.  Possibly have to call function based on mode or
-something since Lisp parens are found differently than Scribe brackets (Lisp
-parse groveling versus counting open and close brackets).
-
-Make hooks that are lists of function have list in the name, so users can know
-easily whether to set this to a list or function.
-   Importance: low.
-   Difficulty: low, but pervasive.  must be careful.
-
-Make FILTER-REGION not move all marks in the buffer to the end.  It should
-affect each line, letting marks stay on a line, instead of deleting the whole
-region and inserting a new one.
-   Importance: low, but described behaviour is better than current behaviour.
-   Difficulty: low.
-
-Make some "Auto Save Access" variable, so users don't have to write fully
-protected auto save files.  Possibly there could be some variable to that
-represents Hemlock's default file writing protection.
-   Importance: one person requested.
-   Difficulty: easy.
-
-Make "Save" mode on a first write or on startup check for a .CKP file.  If it
-is there and has a later write date than the file, warn the user before a save
-could overwrite this file that potentially has good stuff in it from a previous
-Lisp crash.
-   Importance: good idea, though people should know to check.
-   Difficulty: easier if done on start up.
-
-We need Lisp-like movement in Text mode -- skipping parenthetic and quoted
-expressions while ignoring some Lisp syntax stuff.  Either can write a few
-commands that do what we expect, or we can get really clever with the
-pre-command parse checking and bounds rules for Text mode.  May even be able to
-get the right thing to happen with code fragments in documents.
-   Importance: would be pretty convenient to have it work right all the time.
-   Difficulty: will take some thinking and playing around.  Rob or Bill guidance.
-
-Make "Extended Command" offer a default of the last command entered.
-
-Make "Select Group" command take an optional argument for the group
-pathname and group name.
-   Importance: convenience for init files.
-   Difficulty: low.
-
-Put in buffer percentage.
-   Importance: Lots of people want it.
-   Difficulty: Rob thinks he knows how to do it.
-   Rob will tell some undergrad how to do it.
-
-Make "Unexpand Abbrev" work when no expansion had been done -- test for
-error condition was backwards.
-
-Add modeline display of current eval server and current compile server, when
-appropriate. 
-   Importance: suggested by a couple people.  Low.
-   Difficulty: none.
-   	       Basically, just have to change string and function.
-
-Make "Corrected xxx to yyy" messages use actual case of yyy that was
-inserted into the buffer.
-   Importance: more user friendly.
-   Difficult: low.
-   Anyone could do this, but it wouldn't be very educational for an
-      undergrad. 
-
-"Find all Symbols" does a FIND-ALL-SYMBOLS on previous or current form if
-it is a symbol.  See code for "Where is Symbol" in Scott's
-Hemlock-Init.Lisp file.
-   Importance: probably quite useful.
-   Difficulty: none.
-   Anyone could grab Scott's code.
-
-Make buffer read-only when visiting unwritable file?  Bill and Scott
-vehemently disagreed with this, but thought a variable would make everyone
-happy.
-   Importance: one person suggested.
-   Difficulty: low.
-   Anyone could do this, but it wouldn't be very educational for an
-      undergrad. 
-
-Modify MAKE-BUFFER to error when buffer exists?
-   Importance: more user friendly.
-   Difficulty: none.
-   Anybody could do this, but it wouldn't be very educational for an
-      undergrad. 
-
-Warn when unable to rename a buffer according to its file.  This occurs
-when writing files.
-   Importance: more user friendly.
-   Difficulty: none.
-   Anyone could do this.
-Uniquify buffer names by tacking a roman numeral on the end?
-   Importance: I don't know why this is here.
-   Difficulty: low.
-   Anyone could do this.
-
-Automatically save word abbrevs?
-   Importance: low.
-   Difficulty: low.
-   Some undergrad could do this.
-
-Automatically save named keyboard macros?  Maybe on request?
-   Importance: other editors can do it.
-   Difficulty: this is non-trivial since our kbmacs are based on their own
-	       little interpreter.
-   Medium undergrad task.
-
-Make nested prompts work.
-   Importance: some day this might be useful.
-   Difficulty: medium.
-   Upper level undergrad could do this.
-
-Make character searches deal with newlines.
-   Importance: correctness.
-   Difficulty: medium.
-   Upper level undergrad.
-
-Put argument type checks in the Hemlock primitives.
-   Importance: low, the compiler should do this from type declaration
-	       (cool?!).
-   Difficulty: work in a lot of places.
-   Undergrad could do the things Rob or Bill say.
-
-Add a "Preferred File Types" to work in coordination with "Ignore File Types".
-   Importance: low, suggested by one user.
-   Difficulty: minimal.
-
-Write separate search and i-search commands that do case-sensitive searches, so
-user's don't have to set the Hvar for one search.
-   Importance: low.
-   Difficulty: low.
-
-Add a write-region function which writes to a stream.
-   Importance: low.
-   Difficulty: medium.
-   Undergrad.
-
-
-
-;;;; The great rewrite and cleanup.
-
-Compilation order.  Cleanup up defvars, defhvars, proclaims, etc. for clean
-compilation of Hemlock in a Lisp without one.  Rename ED and HI packages
-and start cleaning up compilation.  Defvars should go near pertinent code,
-and proclaims should do the rest.  Do something about macros, rompsite, and
-main.
-   Importance: necessary for those taking our code and sets better example.
-   Difficulty: few days of work.
-   Bill.
-
-Hemlock package cleanup -- exporting Hemlock stuff, so users don't live in
-ED package.
- Find primitives to export and describe in Command Implementor's Manual.
- Export existing command names in a separate file.
- DEFCOMMAND always interns in current package.
- Variables
-  One global table.
-  DEFHVAR only at top level.  Interns into current package.  WHAT ABOUT SITE-INIT?
-  BIND-VARIABLE, a new form, will be used at top level or in setup
-   functions to establish default values.
- Find all uses of FIND-PACKAGE, *hemlock-package*, etc. since these are
-  suspect in the new package regime.
- Put DEFVAR's (esp. from Main.Lisp) in appropriate files, putting PROCLAIM's
-   in a single file or in files with compiler warnings.
-      Importance: really needs to be done along with environment stuff.
-      Difficulty: pervasive changes to get right.
-      Bill!
-
-Generalized environments:
-  Generalize notion of environment to first-class objects.
-  can inherit stuff from other environments.  Shadowing for conflict
-  resolution.  Transparent key bindings another sort of interaction.
-  If we retain modes as a primitive concept, then how do they interact?
-  If not, how do we get the effect?  Each buffer has an environment.
-  This is normally the composition of the default environment and
-  various mode environments.
-
-  Turning modes on and off is simply adding and removing the mode's environment
-  from the buffer's environment's inherit list.  The only sticky issue is the
-  order of the inheritence.  We could assign each environment a precedence.
-
-  I guess we could punt modes as a primitive concept.  The only thing this
-  wouldn't provide that modes do is a namespace and the major/minor
-  distinction.  Setting the major mode is just frobbing the lowest precedence
-  environment in a buffer.  A major mode is distinct from a minor mode in that
-  it inherits the global environment.  An interesting question is at which
-  level precedences should be implemented.  We could have it be a property only
-  of minor modes, which determines only the order in which a buffer inherits
-  its minor modes, or we could make it a property of environments, and have it
-  determine the total order of inheritance.  Probably the former is better: it
-  simpler, and adequate.  Also, at the environment level, it is more powerful
-  to be able to specify inheritance order on a per-case basis.
-
-  Make mode-hooks be a mode-object slot rather than hemlock variables.  [a
-  random cleanup]
-
-  We change the (... &optional kind where) arguments to
-  (... &optional where).  Where can be an environment such as
-  *global-environment* (the default) or a buffer, or it can be a string, in
-  which case it is interpreted as a mode name.
-
-  Instead of having key binding transparentness be a property of modes or of
-  commands, we make it a property of binding.  Each environment has separate
-  key-tables for transparent and opaque bindings, and there is a
-  Transparent-Bind-Key function that is used to make transparent key bindings.
-  [... or something.  This would imply a delete-transparent-key-binding and
-  prehaps other functions, so we might consider passing a transparent flag to
-  the primitives.]
-
-  *current-environment* is the current environment, which is normally eq to the
-  current buffer.  Attributes and variables are implemented using deep-binding
-  and caching.  Whenever there is any change to the inheritance structure or to
-  variable or attribute bindings, then we just totally flush all the caches.
-  The most frequent operation that would cause this to happen would be changing
-  a mode in a buffer, which is rare enough so that there should be no problem.
-
-  For variables, we just have a symbol-name X environment => binding cache.
-
-  For attributes we have two caches: attribute X environment => value vector
-  and attribute X environment X test-function => search vector.  The first
-  translates an attribute and environment to a simple-vector that contains the
-  current value for each character in that environment.  This is used for
-  Character-Attribute and when the Find-Attribute cache misses.  When this
-  cache misses, we fill the vector with a magic "unspecified" object, and then
-  scan up the inheritance, filling in any bindings that are unspecified.  We
-  could optimize this by noting in the character-attribute object when an
-  attribute has no shadowings.  character-attribute hooks have to go away,
-  since they depends on shallow-binding.
-
-  Make Hemlock variables be typed.  Have a :type defhvar argument,
-  variable-type function.  In implementation, create a test function for each
-  variable so that we can efficiently check the type of each assigned value.
-  This implies defhvar should be a macro.  We could make specifying the test
-  function be an explicit feature, but the same effect could always be obtained
-  with a Satisfies type specfier.
-
-  Split binding of hvars from definition.  
-      Bind-Variable Symbol-Name Value &Optional Where
-  Creates a binding.  If :Value is specified to defhvar, then it creates a
-  global binding of that value.  If no :Value is specified, then there is no
-  global binding.  We could flush the :Mode and :Buffer options, and require an
-  explicit Bind-Variable to be done in this case, or we could still allow them.
-  It would probably be better to flush them, since it would break code that is
-  doing run-time defhvars to make buffer-local variables.  Perhaps we would
-  flush only :Buffer, since it is clearly useless, while being able to give an
-  initial mode binding may be useless.
-
-  All variable attributes except for value are global.  Hooks are global.  The
-  concept of a hook is somewhat dubious in the presence of non-global bindings.
-  It might be semi-useful to invoke the hook on each new binding in addition to
-  on each set.
-
-     Importance: Next big step for Hemlock.
-     Difficulty: Two months.
-     Bill will do this.
-
-Multiple font support:
- Figure what kind of multi-font stuff we want to do.
- Bogus to use integer constants for facecodes.  It is reasonable within the
- font mark, but the user interface should be keywords for facecodes.
-   Importance: no documented font support currently.  Really need it.
-   Difficulty: includes massively reworking redisplay data structures.
-   Bill and Rob.
-
-
-
-;;;; Things to think about.
-
-;;; These are things that have been thought of, but we don't know much more
-;;; about them.
-
-Some general facility for users to associate definition locations with kinds of
-things and/or forms.
-
-What's the right way to be in a comment in some Lisp file and have filling,
-spelling, and whatever work out just right.  Possibly regions with environment
-information.  Maybe with a whole new hierarchical text representation, this
-would fall out.
-
-Synchronization/exclusion issues:
-    Currently there are non-modification primitives that are looking into a
-    buffer assuming it will not change out from under the primitive.  We
-    need to identify these places and exactly what the nature of this
-    problem is (including whether it exists).  Probably we need to make
-    non-trivial text examination primitives use without-interrupts so that
-    they see a consistent state.
-
-    Find other places where exclusion is needed:
-        Redisplay?
-        Typescript code?
-
-Online documentation stuff: What to do and how to do it.  Rob has some
-notes on this from a year or two ago.
-   Importance: something to do.
-   Difficulty: high.
-   maybe no one.
-
-Think about general "Save My Editor State".  Can generalize notion of
-stateful things? -- Word abbrevs, keyboard macros, defindent, spelling
-stuff, etc.  This could be the last thing we ever do to Hemlock.
-   Importance: low.
-   Difficulty: very.
-   ???
-
-
-
-;;;; New Eval Servers
-
-Do something about slaves dieing in init files.  Lisps start up and first load
-init.lisp.  When a slave does this, it goes into the debugger before connecting
-to the editor.
diff --git a/hemlock/ts-buf.lisp b/hemlock/ts-buf.lisp
deleted file mode 100644
index e8b7cf59be04b905797f35245fced703e4fbd86f..0000000000000000000000000000000000000000
--- a/hemlock/ts-buf.lisp
+++ /dev/null
@@ -1,313 +0,0 @@
-;;; -*- Package: Hemlock; Log: hemlock.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/ts-buf.lisp,v 1.9 1991/10/01 17:51:05 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains code for processing input to and output from slaves
-;;; using typescript streams.  It maintains the stuff that hacks on the
-;;; typescript buffer and maintains its state.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "HEMLOCK")
-
-
-(defhvar "Input Wait Alarm"
-  "When non-nil, the user is informed when a typescript buffer goes into
-   an input wait, and it is not visible.  Legal values are :message,
-   :loud-message (the default), and nil."
-  :value :loud-message)
-
-
-
-;;;; Structures.
-
-(defstruct (ts-data
-	    (:print-function
-	     (lambda (ts s d)
-	       (declare (ignore ts d))
-	       (write-string "#<TS Data>" s)))
-	    (:constructor
-	     make-ts-data (buffer
-			   &aux
-			   (fill-mark (copy-mark (buffer-end-mark buffer)
-						 :right-inserting)))))
-  buffer		      ; The buffer we are in
-  stream		      ; Stream in the slave.
-  wire			      ; Wire to slave
-  server		      ; Server info struct.
-  fill-mark		      ; Mark where output goes.  This is actually the
-			      ;   "Buffer Input Mark" which is :right-inserting,
-			      ;   and we make sure it is :left-inserting for
-			      ;   inserting output.
-  )
-
-
-;;;; Output routines.
-
-;;; TS-BUFFER-OUTPUT-STRING --- internal interface.
-;;;
-;;; Called by the slave to output stuff in the typescript.  Can also be called
-;;; by other random parts of hemlock when they want to output stuff to the
-;;; buffer.  Since this is called for value from the slave, we have to be
-;;; careful about what values we return, so the result can be sent back.  It is
-;;; called for value only as a synchronization thing.
-;;;
-;;; Whenever the output is gratuitous, we want it to go behind the prompt.
-;;; When it's gratuitous, and we're not at the line-start, then we can output
-;;; it normally, but we also make sure we end the output in a newline for
-;;; visibility's sake.
-;;;
-(defun ts-buffer-output-string (ts string &optional gratuitous-p)
-  "Outputs STRING to the typescript described with TS. The output is inserted
-   before the fill-mark and the current input."
-  (when (wire:remote-object-p ts)
-    (setf ts (wire:remote-object-value ts)))
-  (system:without-interrupts
-    (let ((mark (ts-data-fill-mark ts)))
-      (cond ((and gratuitous-p (not (start-line-p mark)))
-	     (with-mark ((m mark :left-inserting))
-	       (line-start m)
-	       (insert-string m string)
-	       (unless (start-line-p m)
-		 (insert-character m #\newline))))
-	    (t
-	     (setf (mark-kind mark) :left-inserting)
-	     (insert-string mark string)
-	     (when (and gratuitous-p (not (start-line-p mark)))
-	       (insert-character mark #\newline))
-	     (setf (mark-kind mark) :right-inserting)))))
-  (values))
-
-;;; TS-BUFFER-FINISH-OUTPUT --- internal interface.
-;;;
-;;; Redisplays the windows. Used by ts-stream in order to finish-output.
-;;;
-(defun ts-buffer-finish-output (ts)
-  (declare (ignore ts))
-  (redisplay)
-  nil)
-
-;;; TS-BUFFER-CHARPOS --- internal interface.
-;;;
-;;; Used by ts-stream in order to find the charpos.
-;;; 
-(defun ts-buffer-charpos (ts)
-  (mark-charpos (ts-data-fill-mark (if (wire:remote-object-p ts)
-				       (wire:remote-object-value ts)
-				       ts))))
-
-;;; TS-BUFFER-LINE-LENGTH --- internal interface.
-;;;
-;;; Used by ts-stream to find out the line length.  Returns the width of the
-;;; first window, or 80 if there are no windows.
-;;; 
-(defun ts-buffer-line-length (ts)
-  (let* ((ts (if (wire:remote-object-p ts)
-		 (wire:remote-object-value ts)
-		ts))
-	 (window (car (buffer-windows (ts-data-buffer ts)))))
-    (if window
-	(window-width window)
-	80))) ; Seems like a good number to me.
-
-
-;;;; Input routines
-
-(defun ts-buffer-ask-for-input (remote)
-  (let* ((ts (wire:remote-object-value remote))
-	 (buffer (ts-data-buffer ts)))
-    (unless (buffer-windows buffer)
-      (let ((input-wait-alarm
-	     (if (hemlock-bound-p 'input-wait-alarm
-				  :buffer buffer)
-	       (variable-value 'input-wait-alarm
-			       :buffer buffer)
-	       (variable-value 'input-wait-alarm
-			       :global))))
-	(when input-wait-alarm
-	  (when (eq input-wait-alarm :loud-message)
-	    (beep))
-	  (message "Waiting for input in buffer ~A."
-		   (buffer-name buffer))))))
-  nil)
-
-(defun ts-buffer-clear-input (ts)
-  (let* ((ts (if (wire:remote-object-p ts)
-		 (wire:remote-object-value ts)
-		 ts))
-	 (buffer (ts-data-buffer ts))
-	 (mark (ts-data-fill-mark ts)))
-    (unless (mark= mark (buffer-end-mark buffer))
-      (with-mark ((start mark))
-	(line-start start)
-	(let ((prompt (region-to-string (region start mark)))
-	      (end (buffer-end-mark buffer)))
-	  (unless (zerop (mark-charpos end))
-	    (insert-character end #\Newline))
-	  (insert-string end "[Input Cleared]")
-	  (insert-character end #\Newline)
-	  (insert-string end prompt)
-	  (move-mark mark end)))))
-  nil)
-
-(defun ts-buffer-set-stream (ts stream)
-  (let ((ts (if (wire:remote-object-p ts)
-		(wire:remote-object-value ts)
-		ts)))
-    (setf (ts-data-stream ts) stream)
-    (wire:remote (ts-data-wire ts)
-      (ts-stream-set-line-length stream (ts-buffer-line-length ts))))
-  nil)
-
-
-;;;; Typescript mode.
-
-(defun setup-typescript (buffer)
-  (let ((ts (make-ts-data buffer)))
-    (defhvar "Current Package"
-      "The package used for evaluation of Lisp in this buffer."
-      :buffer buffer
-      :value nil)
-
-    (defhvar "Typescript Data"
-      "The ts-data structure for this buffer"
-      :buffer buffer
-      :value ts)
-    
-    (defhvar "Buffer Input Mark"
-      "Beginning of typescript input in this buffer."
-      :value (ts-data-fill-mark ts)
-      :buffer buffer)
-    
-    (defhvar "Interactive History"
-      "A ring of the regions input to the Hemlock typescript."
-      :buffer buffer
-      :value (make-ring (value interactive-history-length)))
-    
-    (defhvar "Interactive Pointer"
-      "Pointer into the Hemlock typescript input history."
-      :buffer buffer
-      :value 0)
-    
-    (defhvar "Searching Interactive Pointer"
-      "Pointer into \"Interactive History\"."
-      :buffer buffer
-      :value 0)))
-
-(defmode "Typescript"
-  :setup-function #'setup-typescript
-  :documentation "The Typescript mode is used to interact with slave lisps.")
-
-
-;;; TYPESCRIPTIFY-BUFFER -- Internal interface.
-;;;
-;;; Buffer creation code for eval server connections calls this to setup a
-;;; typescript buffer, tie things together, and make some local Hemlock
-;;; variables.
-;;;
-(defun typescriptify-buffer (buffer server wire)
-  (setf (buffer-minor-mode buffer "Typescript") t)
-  (let ((info (variable-value 'typescript-data :buffer buffer)))
-    (setf (ts-data-server info) server)
-    (setf (ts-data-wire info) wire)
-    (defhvar "Server Info"
-      "Server-info structure for this buffer."
-      :buffer buffer :value server)
-    (defhvar "Current Eval Server"
-      "The Server-Info object for the server currently used for evaluation and
-       compilation."
-      :buffer buffer :value server)
-    info))
-
-(defun ts-buffer-wire-died (ts)
-  (setf (ts-data-stream ts) nil)
-  (setf (ts-data-wire ts) nil)
-  (buffer-end (ts-data-fill-mark ts) (ts-data-buffer ts))
-  (ts-buffer-output-string ts (format nil "~%~%Slave died!~%")))
-
-(defun unwedge-typescript-buffer ()
-  (typescript-slave-to-top-level-command nil)
-  (buffer-end (current-point) (current-buffer)))
-
-(defhvar "Unwedge Interactive Input Fun"
-  "Function to call when input is confirmed, but the point is not past the
-   input mark."
-  :value #'unwedge-typescript-buffer
-  :mode "Typescript")
-
-(defhvar "Unwedge Interactive Input String"
-  "String to add to \"Point not past input mark.  \" explaining what will
-   happen if the the user chooses to be unwedged."
-  :value "Cause the slave to throw to the top level? "
-  :mode "Typescript")
-
-;;; TYPESCRIPT-DATA-OR-LOSE -- internal
-;;;
-;;; Return the typescript-data for the current buffer, or die trying.
-;;; 
-(defun typescript-data-or-lose ()
-  (if (hemlock-bound-p 'typescript-data)
-      (let ((ts (value typescript-data)))
-	(if ts
-	    ts
-	    (editor-error "Can't find the typescript data?")))
-      (editor-error "Not in a typescript buffer.")))
-
-(defcommand "Confirm Typescript Input" (p)
-  "Send the current input to the slave typescript."
-  "Send the current input to the slave typescript."
-  (declare (ignore p))
-  (let ((ts (typescript-data-or-lose)))
-    (let ((input (get-interactive-input)))
-      (when input
-	(let ((string (region-to-string input)))
-	  (declare (simple-string string))
-	  (insert-character (current-point) #\NewLine)
-	  (wire:remote (ts-data-wire ts)
-	    (ts-stream-accept-input (ts-data-stream ts)
-				    (concatenate 'simple-string
-						 string
-						 (string #\newline))))
-	  (wire:wire-force-output (ts-data-wire ts))
-	  (buffer-end (ts-data-fill-mark ts)
-		      (ts-data-buffer ts)))))))
-  
-(defcommand "Typescript Slave Break" (p)
-  "Interrupt the slave Lisp process associated with this interactive buffer,
-   causing it to invoke BREAK."
-  "Interrupt the slave Lisp process associated with this interactive buffer,
-   causing it to invoke BREAK."
-  (declare (ignore p))
-  (send-oob-to-slave "B"))
-
-(defcommand "Typescript Slave to Top Level" (p)
-  "Interrupt the slave Lisp process associated with this interactive buffer,
-   causing it to throw to the top level REP loop."
-  "Interrupt the slave Lisp process associated with this interactive buffer,
-   causing it to throw to the top level REP loop."
-  (declare (ignore p))
-  (send-oob-to-slave "T"))
-
-(defcommand "Typescript Slave Status" (p)
-  "Interrupt the slave and cause it to print status information."
-  "Interrupt the slave and cause it to print status information."
-  (declare (ignore p))
-  (send-oob-to-slave "S"))
-
-(defun send-oob-to-slave (string)
-  (let* ((ts (typescript-data-or-lose))
-	 (wire (ts-data-wire ts))
-	 (socket (wire:wire-fd wire)))
-    (unless socket
-      (editor-error "The slave is no longer alive."))
-    (ext:send-character-out-of-band socket (schar string 0))))
diff --git a/hemlock/ts-stream.lisp b/hemlock/ts-stream.lisp
deleted file mode 100644
index ae789326fee6a5e205e1135214629d3363238457..0000000000000000000000000000000000000000
--- a/hemlock/ts-stream.lisp
+++ /dev/null
@@ -1,378 +0,0 @@
-;;; -*- Package: Hemlock; Log: hemlock.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/ts-stream.lisp,v 1.1.1.11 1992/12/10 01:11:42 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file implements typescript streams.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "HEMLOCK")
-
-
-
-;;;; Ts-streams.
-
-(defconstant ts-stream-output-buffer-size 512)
-
-(defstruct (ts-stream
-	    (:include stream
-		      (in #'%ts-stream-in)
-		      (out #'%ts-stream-out)
-		      (sout #'%ts-stream-sout)
-		      (misc #'%ts-stream-misc))
-	    (:print-function %ts-stream-print)
-	    (:constructor make-ts-stream (wire typescript)))
-  wire
-  typescript
-  (output-buffer (make-string ts-stream-output-buffer-size)
-		 :type simple-string)
-  (output-buffer-index 0 :type fixnum)
-  ;;
-  ;; The current output character position on the line, returned by the
-  ;; :CHARPOS method.
-  (char-pos 0 :type fixnum)
-  ;;
-  ;; The current length of a line of output.  Returned by the :LINE-LENGTH
-  ;; method.
-  (line-length 80)
-  ;;
-  ;; This is a list of strings and stream-commands whose order manifests the
-  ;; input provided by remote procedure calls into the slave of
-  ;; TS-STREAM-ACCEPT-INPUT.
-  (current-input nil :type list)
-  (input-read-index 0 :type fixnum))
-
-(defun %ts-stream-print (ts stream depth)
-  (declare (ignore ts depth))
-  (write-string "#<TS Stream>" stream))
-
-
-
-;;;; Conditions.
-
-(define-condition unexpected-stream-command (error)
-  ;; Context is a string to be plugged into the report text.
-  ((context))
-  (:report (lambda (condition stream)
-	     (format stream "~&Unexpected stream-command while ~A."
-		     (unexpected-stream-command-context condition)))))
-
-
-
-;;;; Editor remote calls into slave.
-
-;;; TS-STREAM-ACCEPT-INPUT -- Internal Interface.
-;;;
-;;; The editor calls this remotely in the slave to indicate that the user has
-;;; provided input.  Input is a string, symbol, or list.  If it is a list, the
-;;; the CAR names the command, and the CDR is the arguments.
-;;;
-(defun ts-stream-accept-input (remote input)
-  (let ((stream (wire:remote-object-value remote)))
-    (system:without-interrupts
-     (system:without-gcing
-      (setf (ts-stream-current-input stream)
-	    (nconc (ts-stream-current-input stream)
-		   (list (etypecase input
-			   (string
-			    (let ((newline
-				   (position #\newline input :from-end t)))
-			      (setf (ts-stream-char-pos stream)
-				    (if newline
-					(- (length input) newline 1)
-					(length input)))
-			      input))
-			   (cons
-			    (ext:make-stream-command (car input)
-						     (cdr input)))
-			   (symbol
-			    (ext:make-stream-command input)))))))))
-  nil)
-
-;;; TS-STREAM-SET-LINE-LENGTH -- Internal Interface.
-;;;
-;;; This function is called by the editor to indicate that the line-length for
-;;; a TS stream should now be Length.
-;;;
-(defun ts-stream-set-line-length (remote length)
-  (let ((stream (wire:remote-object-value remote)))
-    (setf (ts-stream-line-length stream) length)))
-
-
-
-;;;; Stream methods.
-
-;;; %TS-STREAM-LISTEN -- Internal.
-;;;
-;;; Determine if there is any input available.  If we don't think so, process
-;;; all pending events, and look again.
-;;; 
-(defun %ts-stream-listen (stream)
-  (flet ((check ()
-	   (system:without-interrupts
-	    (system:without-gcing
-	     (loop
-	       (let* ((current (ts-stream-current-input stream))
-		      (first (first current)))
-		 (cond ((null current)
-			(return nil))
-		       ((ext:stream-command-p first)
-			(return t))
-		       ((>= (ts-stream-input-read-index stream)
-			    (length (the simple-string first)))
-			(pop (ts-stream-current-input stream))
-			(setf (ts-stream-input-read-index stream) 0))
-		       (t
-			(return t)))))))))
-    (or (check)
-	(progn
-	  (system:serve-all-events 0)
-	  (check)))))
-
-;;; %TS-STREAM-IN -- Internal.
-;;;
-;;; The READ-CHAR stream method.
-;;; 
-(defun %ts-stream-in (stream &optional eoferr eofval)
-  (declare (ignore eoferr eofval)) ; EOF's are impossible.
-  (wait-for-typescript-input stream)
-  (system:without-interrupts
-   (system:without-gcing
-    (let ((first (first (ts-stream-current-input stream))))
-      (etypecase first
-	(string
-	 (prog1 (schar first (ts-stream-input-read-index stream))
-	   (incf (ts-stream-input-read-index stream))))
-	(ext:stream-command
-	 (error 'unexpected-stream-command
-		:context "in the READ-CHAR method")))))))
-
-;;; %TS-STREAM-READ-LINE -- Internal.
-;;;
-;;; The READ-LINE stream method.  Note: here we take advantage of the fact that
-;;; newlines will only appear at the end of strings.
-;;; 
-(defun %ts-stream-read-line (stream eoferr eofval)
-  (declare (ignore eoferr eofval))
-  (macrolet
-      ((next-str ()
-	 '(progn
-	    (wait-for-typescript-input stream)
-	    (system:without-interrupts
-	     (system:without-gcing
-	      (let ((first (first (ts-stream-current-input stream))))
-		(etypecase first
-		  (string
-		   (prog1 (if (zerop (ts-stream-input-read-index stream))
-			      (pop (ts-stream-current-input stream))
-			      (subseq (pop (ts-stream-current-input stream))
-				      (ts-stream-input-read-index stream)))
-		     (setf (ts-stream-input-read-index stream) 0)))
-		  (ext:stream-command
-		   (error 'unexpected-stream-command
-			  :context "in the READ-CHAR method")))))))))
-    (do ((result (next-str) (concatenate 'simple-string result (next-str))))
-	((char= (schar result (1- (length result))) #\newline)
-	 (values (subseq result 0 (1- (length result)))
-		 nil))
-      (declare (simple-string result)))))
-
-;;; WAIT-FOR-TYPESCRIPT-INPUT -- Internal.
-;;;
-;;; Keep calling server until some input shows up.
-;;; 
-(defun wait-for-typescript-input (stream)
-  (unless (%ts-stream-listen stream)
-    (let ((wire (ts-stream-wire stream))
-	  (ts (ts-stream-typescript stream)))
-      (system:without-interrupts
-       (system:without-gcing
-	(wire:remote wire (ts-buffer-ask-for-input ts))
-	(wire:wire-force-output wire)))
-      (loop
-	(system:serve-all-events)
-	(when (%ts-stream-listen stream)
-	  (return))))))
-
-;;; %TS-STREAM-FLSBUF --- internal.
-;;;
-;;; Flush the output buffer associated with stream.  This should only be used
-;;; inside a without-interrupts and without-gcing.
-;;; 
-(defun %ts-stream-flsbuf (stream)
-  (when (and (ts-stream-wire stream)
-	     (ts-stream-output-buffer stream)
-	     (not (zerop (ts-stream-output-buffer-index stream))))
-    (wire:remote (ts-stream-wire stream)
-      (ts-buffer-output-string
-       (ts-stream-typescript stream)
-       (subseq (the simple-string (ts-stream-output-buffer stream))
-	       0
-	       (ts-stream-output-buffer-index stream))))
-    (setf (ts-stream-output-buffer-index stream) 0)))
-
-;;; %TS-STREAM-OUT --- internal.
-;;;
-;;; Output a single character to stream.
-;;;
-(defun %ts-stream-out (stream char)
-  (declare (base-char char))
-  (system:without-interrupts
-   (system:without-gcing
-    (when (= (ts-stream-output-buffer-index stream)
-	     ts-stream-output-buffer-size)
-      (%ts-stream-flsbuf stream))
-    (setf (schar (ts-stream-output-buffer stream)
-		 (ts-stream-output-buffer-index stream))
-	  char)
-    (incf (ts-stream-output-buffer-index stream))
-    (incf (ts-stream-char-pos stream))
-    (when (= (char-code char)
-	     (char-code #\Newline))
-      (%ts-stream-flsbuf stream)
-      (setf (ts-stream-char-pos stream) 0)
-      (wire:wire-force-output (ts-stream-wire stream)))
-    char)))
-
-;;; %TS-STREAM-SOUT --- internal.
-;;;
-;;; Output a string to stream.
-;;; 
-(defun %ts-stream-sout (stream string start end)
-  (declare (simple-string string))
-  (declare (fixnum start end))
-  (let ((wire (ts-stream-wire stream))
-	(newline (position #\Newline string :start start :end end :from-end t))
-	(length (- end start)))
-    (when wire
-      (system:without-interrupts
-       (system:without-gcing
-	(let ((index (ts-stream-output-buffer-index stream)))
-	  (cond ((> (+ index length)
-		    ts-stream-output-buffer-size)
-		 (%ts-stream-flsbuf stream)
-		 (wire:remote wire
-		   (ts-buffer-output-string (ts-stream-typescript stream)
-					    (subseq string start end)))
-		 (when newline
-		   (wire:wire-force-output wire)))
-		(t
-		 (replace (the simple-string (ts-stream-output-buffer stream))
-			  string
-			  :start1 index
-			  :end1 (+ index length)
-			  :start2 start
-			  :end2 end)
-		 (incf (ts-stream-output-buffer-index stream)
-		       length)
-		 (when newline
-		   (%ts-stream-flsbuf stream)
-		   (wire:wire-force-output wire)))))
-	(setf (ts-stream-char-pos stream)
-	      (if newline
-		  (- end newline 1)
-		  (+ (ts-stream-char-pos stream)
-		     length))))))))
-
-;;; %TS-STREAM-UNREAD -- Internal.
-;;;
-;;; Unread a single character.
-;;; 
-(defun %ts-stream-unread (stream char)
-  (system:without-interrupts
-   (system:without-gcing
-    (let ((first (first (ts-stream-current-input stream))))
-      (cond ((and (stringp first)
-		  (> (ts-stream-input-read-index stream) 0))
-	     (setf (schar first (decf (ts-stream-input-read-index stream)))
-		   char))
-	    (t
-	     (push (string char) (ts-stream-current-input stream))
-	     (setf (ts-stream-input-read-index stream) 0)))))))
-
-;;; %TS-STREAM-CLOSE --- internal.
-;;;
-;;; Can't do much, 'cause the wire is shared.
-;;; 
-(defun %ts-stream-close (stream abort)
-  (unless abort
-    (force-output stream))
-  (lisp::set-closed-flame stream))
-
-;;; %TS-STREAM-CLEAR-INPUT -- Internal.
-;;;
-;;; Pass the request to the editor and clear any buffered input.
-;;;
-(defun %ts-stream-clear-input (stream)
-  (system:without-interrupts
-   (system:without-gcing
-    (when (ts-stream-wire stream)
-      (wire:remote-value (ts-stream-wire stream)
-	(ts-buffer-clear-input (ts-stream-typescript stream))))
-    (setf (ts-stream-current-input stream) nil
-	  (ts-stream-input-read-index stream) 0))))
-
-;;; %TS-STREAM-MISC -- Internal.
-;;;
-;;; The misc stream method.
-;;; 
-(defun %ts-stream-misc (stream operation &optional arg1 arg2)
-  (case operation
-    (:read-line
-     (%ts-stream-read-line stream arg1 arg2))
-    (:listen
-     (%ts-stream-listen stream))
-    (:unread
-     (%ts-stream-unread stream arg1))
-    (:interactive-p t)
-    (:get-command
-     (wait-for-typescript-input stream)
-     (system:without-interrupts
-      (system:without-gcing
-       (etypecase (first (ts-stream-current-input stream))
-	 (stream-command
-	  (setf (ts-stream-input-read-index stream) 0)
-	  (pop (ts-stream-current-input stream)))
-	 (string nil)))))
-    (:close
-     (%ts-stream-close stream arg1))
-    (:clear-input
-     (%ts-stream-clear-input stream)
-     t)
-    (:finish-output
-     (when (ts-stream-wire stream)
-       (system:without-interrupts
-	(system:without-gcing
-	 (%ts-stream-flsbuf stream)
-	 ;; Note: for the return value to come back,
-	 ;; all pending RPCs must have completed.
-	 ;; Therefore, we know it has synced.
-	 (wire:remote-value (ts-stream-wire stream)
-	   (ts-buffer-finish-output (ts-stream-typescript stream))))))
-     t)
-    (:force-output
-     (when (ts-stream-wire stream)
-       (system:without-interrupts
-	(system:without-gcing
-	 (%ts-stream-flsbuf stream)
-	 (wire:wire-force-output (ts-stream-wire stream)))))
-     t)
-    (:clear-output
-     (setf (ts-stream-output-buffer-index stream) 0)
-     t)
-    (:element-type
-     'base-char)
-    (:charpos
-     (ts-stream-char-pos stream))
-    (:line-length
-     (ts-stream-line-length stream))))
diff --git a/hemlock/tty-disp-rt.lisp b/hemlock/tty-disp-rt.lisp
deleted file mode 100644
index a2bc71402f3a378e3eb7481278082d5e0593bd6e..0000000000000000000000000000000000000000
--- a/hemlock/tty-disp-rt.lisp
+++ /dev/null
@@ -1,185 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/tty-disp-rt.lisp,v 1.1.1.6 1992/02/15 01:06:24 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-
-;;;; Terminal init and exit methods.
-
-(defvar *hemlock-input-handler*)
-
-(defun init-tty-device (device)
-  (setf *hemlock-input-handler*
-	(system:add-fd-handler 0 :input #'get-editor-tty-input))
-  (standard-device-init)
-  (device-write-string (tty-device-init-string device))
-  (redisplay-all))
-
-(defun exit-tty-device (device)
-  (cursor-motion device 0 (1- (tty-device-lines device)))
-  ;; Can't call the clear-to-eol method since we don't have a hunk to
-  ;; call it on, and you can't count on the bottom hunk being the echo area.
-  ;; 
-  (if (tty-device-clear-to-eol-string device)
-      (device-write-string (tty-device-clear-to-eol-string device))
-      (dotimes (i (tty-device-columns device)
-		  (cursor-motion device 0 (1- (tty-device-lines device))))
-	(tty-write-char #\space)))
-  (device-write-string (tty-device-cm-end-string device))
-  (when (device-force-output device)
-    (funcall (device-force-output device)))
-  (when *hemlock-input-handler*
-    (system:remove-fd-handler *hemlock-input-handler*)
-    (setf *hemlock-input-handler* nil))
-  (standard-device-exit))
-
-
-;;;; Get terminal attributes:
-
-(defvar *terminal-baud-rate* nil)
-(declaim (type (or (unsigned-byte 16) null) *terminal-baud-rate*))
-
-;;; GET-TERMINAL-ATTRIBUTES  --  Interface
-;;;
-;;;    Get terminal attributes from Unix.  Return as values, the lines,
-;;; columns and speed.  If any value is inaccessible, return NIL for that
-;;; value.  We also sleazily cache the speed in *terminal-baud-rate*, since I
-;;; don't want to figure out how to get my hands on the TTY-DEVICE at the place
-;;; where I need it.  Currently, there really can only be one TTY anyway, since
-;;; the buffer is in a global.
-;;;
-(defun get-terminal-attributes (&optional (fd 1))
-  (alien:with-alien ((winsize (alien:struct unix:winsize))
-		     (sgtty (alien:struct unix:sgttyb)))
-    (let ((size-win (unix:unix-ioctl fd unix:TIOCGWINSZ
-				     (alien:alien-sap winsize)))
-	  (speed-win (unix:unix-ioctl fd unix:TIOCGETP
-				      (alien:alien-sap sgtty))))
-      (flet ((frob (val)
-	       (if (and size-win (not (zerop val)))
-		   val
-		   nil)))
-	(values
-	 (frob (alien:slot winsize 'unix:ws-row))
-	 (frob (alien:slot winsize 'unix:ws-col))
-	 (and speed-win
-	      (setq *terminal-baud-rate*
-		    (svref unix:terminal-speeds
-			   (alien:slot sgtty 'unix:sg-ospeed)))))))))
-
-;;;; Output routines and buffering.
-
-(defconstant redisplay-output-buffer-length 256)
-
-(defvar *redisplay-output-buffer*
-  (make-string redisplay-output-buffer-length))
-(proclaim '(simple-string *redisplay-output-buffer*))
-
-(defvar *redisplay-output-buffer-index* 0)
-(proclaim '(fixnum *redisplay-output-buffer-index*))
-
-;;; WRITE-AND-MAYBE-WAIT  --  Internal
-;;;
-;;;    Write the first Count characters in the redisplay output buffer.  If
-;;; *terminal-baud-rate* is set, then sleep for long enough to allow the
-;;; written text to be displayed.  We multiply by 10 to get the baud-per-byte
-;;; conversion, which assumes 7 character bits + 1 start bit + 2 stop bits, no
-;;; parity.
-;;;
-(defun write-and-maybe-wait (count)
-  (declare (fixnum count))
-  (unix:unix-write 1 *redisplay-output-buffer* 0 count)
-  (let ((speed *terminal-baud-rate*))
-    (when speed
-      (sleep (/ (* (float count) 10.0) (float speed))))))
-
-
-;;; TTY-WRITE-STRING blasts the string into the redisplay output buffer.
-;;; If the string overflows the buffer, then segments of the string are
-;;; blasted into the buffer, dumping the buffer, until the last piece of
-;;; the string is stored in the buffer.  The buffer is always dumped if
-;;; it is full, even if the last piece of the string just fills the buffer.
-;;; 
-(defun tty-write-string (string start length)
-  (declare (fixnum start length))
-  (let ((buffer-space (- redisplay-output-buffer-length
-			 *redisplay-output-buffer-index*)))
-    (declare (fixnum buffer-space))
-    (cond ((<= length buffer-space)
-	   (let ((dst-index (+ *redisplay-output-buffer-index* length)))
-	     (%primitive byte-blt string start *redisplay-output-buffer*
-			 *redisplay-output-buffer-index* dst-index)
-	     (cond ((= length buffer-space)
-		    (write-and-maybe-wait redisplay-output-buffer-length)
-		    (setf *redisplay-output-buffer-index* 0))
-		   (t
-		    (setf *redisplay-output-buffer-index* dst-index)))))
-	  (t
-	   (let ((remaining (- length buffer-space)))
-	     (declare (fixnum remaining))
-	     (loop
-	      (%primitive byte-blt string start *redisplay-output-buffer*
-			  *redisplay-output-buffer-index*
-			  redisplay-output-buffer-length)
-	      (write-and-maybe-wait redisplay-output-buffer-length)
-	      (when (< remaining redisplay-output-buffer-length)
-		(%primitive byte-blt string (+ start buffer-space)
-			    *redisplay-output-buffer* 0 remaining)
-		(setf *redisplay-output-buffer-index* remaining)
-		(return t))
-	      (incf start buffer-space)
-	      (setf *redisplay-output-buffer-index* 0)
-	      (setf buffer-space redisplay-output-buffer-length)
-	      (decf remaining redisplay-output-buffer-length)))))))
-
-
-;;; TTY-WRITE-CHAR stores a character in the redisplay output buffer,
-;;; dumping the buffer if it becomes full.
-;;; 
-(defun tty-write-char (char)
-  (setf (schar *redisplay-output-buffer* *redisplay-output-buffer-index*)
-	char)
-  (incf *redisplay-output-buffer-index*)
-  (when (= *redisplay-output-buffer-index* redisplay-output-buffer-length)
-    (write-and-maybe-wait redisplay-output-buffer-length)
-    (setf *redisplay-output-buffer-index* 0)))
-
-
-;;; TTY-FORCE-OUTPUT dumps the redisplay output buffer.  This is called
-;;; out of terminal device structures in multiple places -- the device
-;;; exit method, random typeout methods, out of tty-hunk-stream methods,
-;;; after calls to REDISPLAY or REDISPLAY-ALL.
-;;; 
-(defun tty-force-output ()
-  (unless (zerop *redisplay-output-buffer-index*)
-    (write-and-maybe-wait *redisplay-output-buffer-index*)
-    (setf *redisplay-output-buffer-index* 0)))
-
-
-;;; TTY-FINISH-OUTPUT simply dumps output.
-;;;
-(defun tty-finish-output (device window)
-  (declare (ignore window))
-  (let ((force-output (device-force-output device)))
-    (when force-output
-      (funcall force-output))))
-
-
-
-;;;; Screen image line hacks.
-
-(defmacro replace-si-line (dst-string src-string src-start dst-start dst-end)
-  `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end))
diff --git a/hemlock/tty-display.lisp b/hemlock/tty-display.lisp
deleted file mode 100644
index f555e2d163224e13cd20bebfda70a0d34343c866..0000000000000000000000000000000000000000
--- a/hemlock/tty-display.lisp
+++ /dev/null
@@ -1,1104 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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). 
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(redisplay redisplay-all))
-
-
-
-;;;; Macros.
-
-(eval-when (compile eval)
-(defmacro tty-hunk-modeline-pos (hunk)
-  `(tty-hunk-text-height ,hunk))
-) ;eval-when
-
-
-(defvar *currently-selected-hunk* nil)
-(defvar *hunk-top-line*)
-
-(proclaim '(fixnum *hunk-top-line*))
-
-(eval-when (compile eval)
-(defmacro select-hunk (hunk)
-  `(unless (eq ,hunk *currently-selected-hunk*)
-     (setf *currently-selected-hunk* ,hunk)
-     (setf *hunk-top-line*
-	   (the fixnum
-		(1+ (the fixnum
-			 (- (the fixnum
-				 (tty-hunk-text-position ,hunk))
-			    (the fixnum
-				 (tty-hunk-text-height ,hunk)))))))))
-) ;eval-when
-
-
-;;; Screen image lines.
-;;; 
-(defstruct (si-line (:print-function print-screen-image-line)
-		    (:constructor %make-si-line (chars)))
-  chars
-  (length 0))
-
-(defun make-si-line (n)
-  (%make-si-line (make-string n)))
-
-(defun print-screen-image-line (obj str n)
-  (declare (ignore n))
-  (write-string "#<Screen Image Line \"" str)
-  (write-string (si-line-chars obj) str :end (si-line-length obj))
-  (write-string "\">" str))
-
-
-(defmacro si-line (screen-image n)
-  `(svref ,screen-image ,n))
-
-
-
-;;;; Dumb window redisplay.
-
-(defmacro tty-dumb-line-redisplay (device hunk dis-line &optional y)
-  (let ((dl (gensym)) (dl-chars (gensym)) (dl-len (gensym))
-	(dl-pos (gensym)) (screen-image-line (gensym)))
-    `(let* ((,dl ,dis-line)
-	    (,dl-chars (dis-line-chars ,dl))
-	    (,dl-len (dis-line-length ,dl))
-	    (,dl-pos ,(or y `(dis-line-position ,dl))))
-       (funcall (tty-device-display-string ,device)
-		,hunk 0 ,dl-pos ,dl-chars 0 ,dl-len)
-       (setf (dis-line-flags ,dl) unaltered-bits)
-       (setf (dis-line-delta ,dl) 0)
-       (select-hunk ,hunk)
-       (let ((,screen-image-line (si-line (tty-device-screen-image ,device)
-					  (+ *hunk-top-line* ,dl-pos))))
-	 (replace-si-line (si-line-chars ,screen-image-line) ,dl-chars
-			  0 0 ,dl-len)
-	 (setf (si-line-length ,screen-image-line) ,dl-len)))))
-
-(defun tty-dumb-window-redisplay (window)
-  (let* ((first (window-first-line window))
-	 (hunk (window-hunk window))
-	 (device (device-hunk-device hunk))
-	 (screen-image (tty-device-screen-image device)))
-    (funcall (tty-device-clear-to-eow device) hunk 0 0)
-    (do ((i 0 (1+ i))
-	 (dl (cdr first) (cdr dl)))
-	((eq dl the-sentinel)
-	 (setf (window-old-lines window) (1- i))
-	 (select-hunk hunk)
-	 (do ((last (tty-hunk-text-position hunk))
-	      (i (+ *hunk-top-line* i) (1+ i)))
-	     ((> i last))
-	   (declare (fixnum i last))
-	   (setf (si-line-length (si-line screen-image i)) 0)))
-      (tty-dumb-line-redisplay device hunk (car dl) i))
-    (setf (window-first-changed window) the-sentinel
-	  (window-last-changed window) first)
-    (when (window-modeline-buffer window)
-      (let ((dl (window-modeline-dis-line window))
-	    (y (tty-hunk-modeline-pos hunk)))
-	(funcall (tty-device-standout-init device) hunk)
-	(funcall (tty-device-clear-to-eol device) hunk 0 y)
-	(tty-dumb-line-redisplay device hunk dl y)
-	(funcall (tty-device-standout-end device) hunk)
-	(setf (dis-line-flags dl) unaltered-bits)))))
-
-
-
-;;;; Dumb redisplay top n lines of a window.
-
-(defun tty-redisplay-n-lines (window n)
-  (let* ((hunk (window-hunk window))
-	 (device (device-hunk-device hunk)))
-    (funcall (tty-device-clear-lines device) hunk 0 0 n)
-    (do ((n n (1- n))
-	 (dl (cdr (window-first-line window)) (cdr dl)))
-	((or (zerop n) (eq dl the-sentinel)))
-      (tty-dumb-line-redisplay device hunk (car dl)))))
-
-
-
-;;;; Semi dumb window redisplay
-
-;;; This is for terminals without opening and deleting lines.
-
-;;; TTY-SEMI-DUMB-WINDOW-REDISPLAY is a lot like TTY-SMART-WINDOW-REDISPLAY,
-;;; but it calls different line redisplay functions.
-;;; 
-(defun tty-semi-dumb-window-redisplay (window)
-  (let* ((hunk (window-hunk window))
-	 (device (device-hunk-device hunk)))
-    (let ((first-changed (window-first-changed window))
-	  (last-changed (window-last-changed window)))
-      ;; Is there anything to do?
-      (unless (eq first-changed the-sentinel)
-	(if ;; One line-changed.
-	    (and (eq first-changed last-changed)
-		 (zerop (dis-line-delta (car first-changed))))
-	    (tty-semi-dumb-line-redisplay device hunk (car first-changed))
-	    ;; More lines changed.
-	    (do-semi-dumb-line-writes first-changed last-changed hunk))
-	;; Set the bounds so we know we displayed...
-	(setf (window-first-changed window) the-sentinel
-	      (window-last-changed window) (window-first-line window))))
-    ;;
-    ;; Clear any extra lines at the end of the window.
-    (let ((pos (dis-line-position (car (window-last-line window)))))
-      (when (< pos (window-old-lines window))
-	(tty-smart-clear-to-eow hunk (1+ pos)))
-      (setf (window-old-lines window) pos))
-    ;;
-    ;; Update the modeline if needed.
-    (when (window-modeline-buffer window)
-      (let ((dl (window-modeline-dis-line window)))
-	(when (/= (dis-line-flags dl) unaltered-bits)
-	  (funcall (tty-device-standout-init device) hunk)
-	  (unwind-protect
-	      (tty-smart-line-redisplay device hunk dl
-					(tty-hunk-modeline-pos hunk))
-	    (funcall (tty-device-standout-end device) hunk)))))))
-
-;;; NEXT-DIS-LINE is used in DO-SEMI-DUMB-LINE-WRITES and
-;;; COMPUTE-TTY-CHANGES.
-;;; 
-(eval-when (compile eval)
-(defmacro next-dis-line ()
-  `(progn 
-    (setf prev dl)
-    (setf dl (cdr dl))
-    (setf flags (dis-line-flags (car dl)))))
-) ;eval-when
-
-;;; DO-SEMI-DUMB-LINE-WRITES does what it says until it hits the last
-;;; changed line.  The commented out code was a gratuitous optimization,
-;;; especially if the first-changed line really is the first changes line.
-;;; Anyway, this had to be removed because of this function's use in
-;;; TTY-SMART-WINDOW-REDISPLAY, which was punting line moves due to
-;;; "Scroll Redraw Ratio".  However, these supposedly moved lines had their
-;;; bits set to unaltered bits in COMPUTE-TTY-CHANGES because it was
-;;; assuming TTY-SMART-WINDOW-REDISPLAY guaranteed to do line moves.
-;;; 
-(defun do-semi-dumb-line-writes (first-changed last-changed hunk)
-  (let* ((dl first-changed)
-	 flags ;(dis-line-flags (car dl))) flags bound for NEXT-DIS-LINE.
-	 prev)
-    (declare (ignore flags))
-    ;;
-    ;; Skip old, unchanged, unmoved lines.
-    ;; (loop
-    ;;  (unless (zerop flags) (return))
-    ;;  (next-dis-line))
-    ;;
-    ;; Write every remaining line.
-    (let* ((device (device-hunk-device hunk))
-	   (force-output (device-force-output device)))
-      (loop
-       (tty-semi-dumb-line-redisplay device hunk (car dl))
-       (when force-output (funcall force-output))
-       (next-dis-line)
-       (when (eq prev last-changed) (return))))))
-
-;;; TTY-SEMI-DUMB-LINE-REDISPLAY finds the first different character
-;;; comparing the display line and the screen image line, writes out the
-;;; rest of the display line, and clears to end-of-line as necessary.
-;;; 
-(defun tty-semi-dumb-line-redisplay (device hunk dl
-				     &optional (dl-pos (dis-line-position dl)))
-  (declare (fixnum dl-pos))
-  (let* ((dl-chars (dis-line-chars dl))
-	 (dl-len (dis-line-length dl)))
-    (declare (fixnum dl-len) (simple-string dl-chars))
-    (when (listen-editor-input *editor-input*)
-      (throw 'redisplay-catcher :editor-input))
-    (select-hunk hunk)
-    (let* ((screen-image-line (si-line (tty-device-screen-image device)
-				       (+ *hunk-top-line* dl-pos)))
-	   (si-line-chars (si-line-chars screen-image-line))
-	   (si-line-length (si-line-length screen-image-line))
-	   (findex (string/= dl-chars si-line-chars
-			     :end1 dl-len :end2 si-line-length)))
-      (declare (fixnum findex) (simple-string si-line-chars))
-      ;;
-      ;; When the dis-line and screen chars are not string=.
-      (when findex
-	(cond
-	 ;; See if the screen shows an initial substring of the dis-line.
-	 ((= findex si-line-length)
-	  (funcall (tty-device-display-string device)
-		   hunk findex dl-pos dl-chars findex dl-len)
-	  (replace-si-line si-line-chars dl-chars findex findex dl-len))
-	 ;; When the dis-line is an initial substring of what's on the screen.
-	 ((= findex dl-len)
-	  (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos))
-	 ;; Otherwise, blast dl-chars and clear to eol as necessary.
-	 (t (funcall (tty-device-display-string device)
-		     hunk findex dl-pos dl-chars findex dl-len)
-	    (when (< dl-len si-line-length)
-	      (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos))
-	    (replace-si-line si-line-chars dl-chars findex findex dl-len)))
-	(setf (si-line-length screen-image-line) dl-len)))
-    (setf (dis-line-flags dl) unaltered-bits)
-    (setf (dis-line-delta dl) 0)))
-
-
-
-;;;; Smart window redisplay -- operation queues and internal screen image.
-
-;;; This is used for creating temporary smart redisplay structures.
-;;; 
-(defconstant tty-hunk-height-limit 100)
-
-
-;;; Queues for redisplay operations and access macros.
-;;; 
-(defvar *tty-line-insertions* (make-array (* 2 tty-hunk-height-limit)))
-
-(defvar *tty-line-deletions* (make-array (* 2 tty-hunk-height-limit)))
-
-(defvar *tty-line-writes* (make-array tty-hunk-height-limit))
-
-(eval-when (compile eval)
-
-(defmacro queue (value queue ptr)
-  `(progn
-    (setf (svref ,queue ,ptr) ,value)
-    (the fixnum (incf (the fixnum ,ptr)))))
-
-(defmacro dequeue (queue ptr)
-  `(prog1
-    (svref ,queue ,ptr)
-    (the fixnum (incf (the fixnum ,ptr)))))
-
-) ;eval-when
-
-;;; INSERT-LINE-COUNT is used in TTY-SMART-WINDOW-REDISPLAY.  The counting is
-;;; based on calls to QUEUE in COMPUTE-TTY-CHANGES.
-;;; 
-(defun insert-line-count (ins)
-  (do ((i 1 (+ i 2))
-       (count 0 (+ count (svref *tty-line-insertions* i))))
-      ((> i ins) count)))
-
-
-;;; Temporary storage for screen-image lines and accessing macros.
-;;; 
-(defvar *screen-image-temp* (make-array tty-hunk-height-limit))
-
-(eval-when (compile eval)
-
-;;; DELETE-SI-LINES is used in DO-LINE-DELETIONS to simulate what's
-;;; happening to the screen in a device's screen-image.  At y, num
-;;; lines are deleted and saved in *screen-image-temp*; fsil is the
-;;; end of the free screen image lines saved here.  Also, we must
-;;; move lines up in the screen-image structure.  In the outer loop
-;;; we save lines in the temp storage and move lines up at the same
-;;; time.  In the termination/inner loop we move any lines that still
-;;; need to be moved up.  The screen-length is adjusted by the fsil
-;;; because any time a deletion is in progress, there are fsil bogus
-;;; lines at the bottom of the screen image from lines being moved
-;;; up previously.
-;;; 
-(defmacro delete-si-lines (screen-image y num fsil screen-length)
-  (let ((do-screen-image (gensym)) (delete-index (gensym))
-	(free-lines (gensym)) (source-index (gensym)) (target-index (gensym))
-	(n (gensym)) (do-screen-length (gensym)) (do-y (gensym)))
-    `(let ((,do-screen-image ,screen-image)
-	   (,do-screen-length (- ,screen-length fsil))
-	   (,do-y ,y))
-       (declare (fixnum ,do-screen-length ,do-y))
-       (do ((,delete-index ,do-y (1+ ,delete-index))
-	    (,free-lines ,fsil (1+ ,free-lines))
-	    (,source-index (+ ,do-y ,num) (1+ ,source-index))
-	    (,n ,num (1- ,n)))
-	   ((zerop ,n)
-	    (do ((,target-index ,delete-index (1+ ,target-index))
-		 (,source-index ,source-index (1+ ,source-index)))
-		((>= ,source-index ,do-screen-length))
-	      (declare (fixnum ,target-index ,source-index))
-	      (setf (si-line ,do-screen-image ,target-index)
-		    (si-line ,do-screen-image ,source-index))))
-	 (declare (fixnum ,delete-index ,free-lines ,source-index ,n))
-	 (setf (si-line *screen-image-temp* ,free-lines)
-	       (si-line ,do-screen-image ,delete-index))
-	 (when (< ,source-index ,do-screen-length)
-	   (setf (si-line ,do-screen-image ,delete-index)
-		 (si-line ,do-screen-image ,source-index)))))))
-
-
-;;; INSERT-SI-LINES is used in DO-LINE-INSERTIONS to simulate what's
-;;; happening to the screen in a device's screen-image.  At y, num free
-;;; lines are inserted from *screen-image-temp*; fsil is the end of the
-;;; free lines.  When copying lines down in screen-image, we must start
-;;; with the lower lines and end with the higher ones, so we don't trash
-;;; any lines.  The outer loop does all the copying, and the termination/
-;;; inner loop inserts the free screen image lines, setting their length
-;;; to zero.
-;;; 
-(defmacro insert-si-lines (screen-image y num fsil screen-length)
-  (let ((do-screen-image (gensym)) (source-index (gensym))
-	(target-index (gensym)) (target-terminus (gensym))
-	(do-screen-length (gensym)) (temp (gensym)) (do-y (gensym))
-	(insert-index (gensym)) (free-lines-index (gensym))
-	(n (gensym)))
-    `(let ((,do-screen-length ,screen-length)
-	   (,do-screen-image ,screen-image)
-	   (,do-y ,y))
-       (do ((,target-terminus (1- (+ ,do-y ,num)))	 ; (1- target-start)
-	    (,source-index (- ,do-screen-length ,fsil 1) ; (1- source-end)
-			   (1- ,source-index))
-	    (,target-index (- (+ ,do-screen-length ,num)
-			      ,fsil 1)			 ; (1- target-end)
-		(1- ,target-index)))
-	   ((= ,target-index ,target-terminus)
-	    (do ((,insert-index ,do-y (1+ ,insert-index))
-		 (,free-lines-index (1- ,fsil) (1- ,free-lines-index))
-		 (,n ,num (1- ,n)))
-		((zerop ,n))
-	      (declare (fixnum ,insert-index ,free-lines-index ,n))
-	      (let ((,temp (si-line *screen-image-temp* ,free-lines-index)))
-		(setf (si-line-length ,temp) 0)
-		(setf (si-line ,do-screen-image ,insert-index) ,temp)))
-	    (decf ,fsil ,num))
-	 (declare (fixnum ,target-terminus ,source-index ,target-index))
-	 (setf (si-line ,do-screen-image ,target-index)
-	       (si-line ,do-screen-image ,source-index))))))
-
-) ;eval-when
-
-
-
-;;;; Smart window redisplay -- the function.
-
-;;; TTY-SMART-WINDOW-REDISPLAY sees if only one line changed after
-;;; some preliminary processing.  If more than one line changed,
-;;; then we compute changes to make to the screen in the form of
-;;; line insertions, deletions, and writes.  Deletions must be done
-;;; first, so lines are not lost off the bottom of the screen by
-;;; inserting lines.
-;;; 
-(defun tty-smart-window-redisplay (window)
-  (let* ((hunk (window-hunk window))
-	 (device (device-hunk-device hunk)))
-    (let ((first-changed (window-first-changed window))
-	  (last-changed (window-last-changed window)))
-      ;; Is there anything to do?
-      (unless (eq first-changed the-sentinel)
-	(if (and (eq first-changed last-changed)
-		 (zerop (dis-line-delta (car first-changed))))
-	    ;; One line-changed.
-	    (tty-smart-line-redisplay device hunk (car first-changed))
-	    ;; More lines changed.
-	    (multiple-value-bind (ins outs writes)
-				 (compute-tty-changes
-				  first-changed last-changed
-				  (tty-hunk-modeline-pos hunk))
-	      (let ((ratio (variable-value 'ed::scroll-redraw-ratio)))
-		(cond ((and ratio
-			    (> (/ (insert-line-count ins)
-				  (tty-hunk-text-height hunk))
-			       ratio))
-		       (do-semi-dumb-line-writes first-changed last-changed
-						 hunk))
-		      (t
-		       (do-line-insertions hunk ins
-					   (do-line-deletions hunk outs))
-		       (do-line-writes hunk writes))))))
-	;; Set the bounds so we know we displayed...
-	(setf (window-first-changed window) the-sentinel
-	      (window-last-changed window) (window-first-line window))))
-    ;;
-    ;; Clear any extra lines at the end of the window.
-    (let ((pos (dis-line-position (car (window-last-line window)))))
-      (when (< pos (window-old-lines window))
-	(tty-smart-clear-to-eow hunk (1+ pos)))
-      (setf (window-old-lines window) pos))
-    ;;
-    ;; Update the modeline if needed.
-    (when (window-modeline-buffer window)
-      (let ((dl (window-modeline-dis-line window)))
-	(when (/= (dis-line-flags dl) unaltered-bits)
-	  (funcall (tty-device-standout-init device) hunk)
-	  (unwind-protect
-	      (tty-smart-line-redisplay device hunk dl
-					(tty-hunk-modeline-pos hunk))
-	    (funcall (tty-device-standout-end device) hunk)))))))
-
-
-
-;;;; Smart window redisplay -- computing changes to the display.
-
-;;; There is a lot of documentation here to help since this code is not
-;;; obviously correct.  The code is not that cryptic, but the correctness
-;;; of the algorithm is somewhat.  Most of the complexity is in handling
-;;; lines that moved on the screen which the introduction deals with.
-;;; Also, the block of documentation immediately before the function
-;;; COMPUTE-TTY-CHANGES has its largest portion dedicated to this part of
-;;; the function which is the largest block of code in the function.
-
-;;; The window image dis-lines are annotated with the difference between
-;;; their current intended locations and their previous locations in the
-;;; window.  This delta (distance moved) is negative for an upward move and
-;;; positive for a downward move.  To determine what to do with moved
-;;; groups of lines, we consider the transition (or difference in deltas)
-;;; between two adjacent groups as we look at the window's dis-lines moving
-;;; down the window image, disregarding whether they are contiguous (having
-;;; moved only by a different delta) or separated by some lines (such as
-;;; lines that are new and unmoved).
-;;;
-;;; Considering the transition between moved groups makes sense because a
-;;; given group's delta affects all the lines below it since the dis-lines
-;;; reflect the window's buffer's actual lines which are all connected in
-;;; series.  Therefore, if the previous group moved up some delta number of
-;;; lines because of line deletions, then the lines below this group (down
-;;; to the last line of the window image) moved up by the same delta too,
-;;; unless one of the following is true:
-;;;    1] The lines below the group moved up by a greater delta, possibly
-;;;       due to multiple disjoint buffer line deletions.
-;;;    2] The lines below the group moved up by a lesser delta, possibly
-;;;       due to a number (less than the previous delta) of new line
-;;;       insertions below the group that moved up.
-;;;    3] The lines below the group moved down, possibly due to a number
-;;;       (greater than the previous delta) of new line insertions below
-;;;       the group that moved up.
-;;; Similarly, if the previous group moved down some delta number of lines
-;;; because of new line insertions, then the lines below this group (down
-;;; to the last line of the window image not to fall off the window's lower
-;;; edge) moved down by the same delta too, unless one of the following is
-;;; true:
-;;;    1] The lines below the group moved down by a greater delta, possibly
-;;;       due to multiple disjoint buffer line insertions.
-;;;    2] The lines below the group moved down by a lesser delta, possibly
-;;;       due to a number (less than the previous delta) of line deletions
-;;;       below the group that moved down.
-;;;    3] The lines below the group moved up, possibly due to a number
-;;;       (greater than the previous delta) of line deletions below the
-;;;       group that moved down.
-;;;
-;;; Now we can see how the first moved group affects the window image below
-;;; it except where there is a lower group of lines that have moved a
-;;; different delta due to separate operations on the buffer's lines viewed
-;;; through a window.  We can see that this different delta is the expected
-;;; effect throughout the window image below the second group, unless
-;;; something lower down again has affected the window image.  Also, in the
-;;; case of a last group of lines that moved up, the group will never
-;;; reflect all of the lines in the window image from the first line to
-;;; move down to the bottom of the window image because somewhere down below
-;;; the group that moved up are some new lines that have just been drawn up
-;;; into the window's image.
-;;;
-
-;;; COMPUTE-TTY-CHANGES is used once in TTY-SMART-WINDOW-REDISPLAY.
-;;; It goes through all the display lines for a window recording where
-;;; lines need to be inserted, deleted, or written to make the screen
-;;; consistent with the internal image of the screen.  Pointers to
-;;; the insertions, deletions, and writes that have to be done are
-;;; returned.
-;;; 
-;;; If a line is new, then simply queue it to be written.
-;;; 
-;;; If a line is moved and/or changed, then we compute the difference
-;;; between the last block of lines that moved with the same delta and the
-;;; current block of lines that moved with the current delta.  If this
-;;; difference is positive, then some lines need to be deleted.  Since we
-;;; do all the line deletions first to prevent line insertions from
-;;; dropping lines off the bottom of the screen, we have to compute the
-;;; position of line deletions using the cumulative insertions
-;;; (cum-inserts).  Without any insertions, deletions may be done right at
-;;; the dis-line's new position.  With insertions needed above a given
-;;; deletion point combined with the fact that deletions are all done
-;;; first, the location for the deletion is higher than it would be without
-;;; the insertions being done above the deletions.  The location of the
-;;; deletion is higher by the number of insertions we have currently put
-;;; off.  When computing the position of line insertions (a negative delta
-;;; transition), we do not need to consider the cumulative insertions or
-;;; cumulative deletions since everything above the point of insertion
-;;; (both deletions and insertions) has been done.  Because of the screen
-;;; state being correct above the point of an insertion, the screen is only
-;;; off by the delta transition number of lines.  After determining the
-;;; line insertions or deletions, loop over contiguous lines with the same
-;;; delta queuing any changed ones to be written.  The delta and flag
-;;; fields are initialized according to the need to be written; since
-;;; redisplay may be interrupted by more user input after moves have been
-;;; done to the screen, we save the changed bit on, so the line will be
-;;; queued to be written after redisplay is re-entered.
-;;; 
-;;; If the line is changed or new, then queue it to be written.  Note
-;;; before that we checked the flags for equality with the new bits, and
-;;; it is possible that updating the window image will yield lines that
-;;; are both new and changed.
-;;; 
-;;; Otherwise, get the next display line, loop, and see if it's
-;;; interesting.
-;;; 
-(defun compute-tty-changes (first-changed last-changed modeline-pos)
-  (declare (fixnum modeline-pos))
-  (let* ((dl first-changed)
-	 (flags (dis-line-flags (car dl)))
-	 (ins 0) (outs 0) (writes 0)
-	 (prev-delta 0) (cum-deletes 0) (net-delta 0) (cum-inserts 0)
-	 prev)
-    (declare (fixnum flags ins outs writes prev-delta cum-deletes net-delta
-		     cum-inserts))
-    (loop
-     (cond
-      ((= flags new-bit)
-       (queue (car dl) *tty-line-writes* writes)
-       (next-dis-line))
-      ((not (zerop (the fixnum (logand flags moved-bit))))
-       (let* ((start-dl (car dl))
-	      (start-pos (dis-line-position start-dl))
-	      (curr-delta (dis-line-delta start-dl))
-	      (delta-delta (- prev-delta curr-delta))
-	      (car-dl start-dl))
-	 (declare (fixnum start-pos curr-delta delta-delta))
-	 (cond ((plusp delta-delta)
-		(queue (the fixnum (- start-pos cum-inserts))
-		       *tty-line-deletions* outs)
-		(queue delta-delta *tty-line-deletions* outs)
-		(incf cum-deletes delta-delta)
-		(decf net-delta delta-delta))
-	       ((minusp delta-delta)
-		(let ((eff-pos (the fixnum (+ start-pos delta-delta)))
-		      (num (the fixnum (- delta-delta))))
-		  (queue eff-pos *tty-line-insertions* ins)
-		  (queue num *tty-line-insertions* ins)
-		  (incf net-delta num)
-		  (incf cum-inserts num)))
-	       (t (error "Internal error -- unexpected zero transition delta ~
-			 in redisplay.")))
-	 (loop
-	  (cond ((and (zerop (the fixnum (logand flags changed-bit)))
-		      (zerop (the fixnum (logand flags new-bit))))
-		 (setf (dis-line-flags car-dl) unaltered-bits))
-		(t (queue car-dl *tty-line-writes* writes)
-		   ;; keep just the changed-bit on.
-		   (setf (dis-line-flags car-dl) changed-bit)))
-	  (setf (dis-line-delta car-dl) 0)
-	  (next-dis-line)
-	  (setf car-dl (car dl))
-	  (when (/= (the fixnum (dis-line-delta car-dl)) curr-delta)
-	    (setf prev-delta curr-delta)
-	    (return)))))
-      ((not (and (zerop (logand (the fixnum flags) changed-bit))
-		 (zerop (logand (the fixnum flags) new-bit))))
-       (queue (car dl) *tty-line-writes* writes)
-       (next-dis-line))
-      (t (next-dis-line)))
-     (when (eq prev last-changed)
-       (unless (zerop net-delta)
-	 (cond ((plusp net-delta)
-		(queue (the fixnum (- modeline-pos cum-deletes net-delta))
-		       *tty-line-deletions* outs)
-		(queue net-delta *tty-line-deletions* outs))
-	       (t (queue (the fixnum (+ modeline-pos net-delta))
-			 *tty-line-insertions* ins)
-		  (queue (the fixnum (- net-delta))
-			 *tty-line-insertions* ins))))
-       (return (values ins outs writes))))))
-
-
-
-;;;; Smart window redisplay -- operation methods.
-
-;;; TTY-SMART-CLEAR-TO-EOW clears lines y through the last text line of hunk.
-;;; It takes care not to clear a line unless it really has some characters
-;;; displayed on it.  It also maintains the device's screen image lines.
-;;; 
-(defun tty-smart-clear-to-eow (hunk y)
-  (let* ((device (device-hunk-device hunk))
-	 (screen-image (tty-device-screen-image device))
-	 (clear-to-eol (tty-device-clear-to-eol device)))
-    (select-hunk hunk)
-    (do ((y y (1+ y))
-	 (si-idx (+ *hunk-top-line* y) (1+ si-idx))
-	 (last (tty-hunk-text-position hunk)))
-	((> si-idx last))
-      (declare (fixnum y si-idx last))
-      (let ((si-line (si-line screen-image si-idx)))
-	(unless (zerop (si-line-length si-line))
-	  (funcall clear-to-eol hunk 0 y)
-	  (setf (si-line-length si-line) 0))))))
-
-;;; DO-LINE-DELETIONS pops elements off the *tty-lines-deletions* queue,
-;;; deleting lines from hunk's area of the screen.  The internal screen
-;;; image is updated, and the total number of lines deleted is returned.
-;;; 
-(defun do-line-deletions (hunk outs)
-  (declare (fixnum outs))
-  (let* ((i 0)
-	 (device (device-hunk-device hunk))
-	 (fun (tty-device-delete-line device))
-	 (fsil 0)) ;free-screen-image-lines
-    (declare (fixnum i fsil))
-    (loop
-     (when (= i outs) (return fsil))
-     (let ((y (dequeue *tty-line-deletions* i))
-	   (num (dequeue *tty-line-deletions* i)))
-       (declare (fixnum y num))
-       (funcall fun hunk 0 y num)
-       (select-hunk hunk)
-       (delete-si-lines (tty-device-screen-image device)
-			(+ *hunk-top-line* y) num fsil
-			(tty-device-lines device))
-       (incf fsil num)))))
-
-;;; DO-LINE-INSERTIONS pops elements off the *tty-line-insertions* queue,
-;;; inserting lines into hunk's area of the screen.  The internal screen
-;;; image is updated using free screen image lines pointed to by fsil.
-;;; 
-(defun do-line-insertions (hunk ins fsil)
-  (declare (fixnum ins fsil))
-  (let* ((i 0)
-	 (device (device-hunk-device hunk))
-	 (fun (tty-device-open-line device)))
-    (declare (fixnum i))
-    (loop
-     (when (= i ins) (return))
-     (let ((y (dequeue *tty-line-insertions* i))
-	   (num (dequeue *tty-line-insertions* i)))
-       (declare (fixnum y num))
-       (funcall fun hunk 0 y num)
-       (select-hunk hunk)
-       (insert-si-lines (tty-device-screen-image device)
-			(+ *hunk-top-line* y) num fsil
-			(tty-device-lines device))))))
-
-;;; DO-LINE-WRITES pops elements off the *tty-line-writes* queue, displaying
-;;; these dis-lines with TTY-SMART-LINE-REDISPLAY.  We force output after
-;;; each line, so the user can see how far we've gotten in case he chooses
-;;; to give more editor commands which will abort redisplay until there's no
-;;; more input.
-;;; 
-(defun do-line-writes (hunk writes)
-  (declare (fixnum writes))
-  (let* ((i 0)
-	 (device (device-hunk-device hunk))
-	 (force-output (device-force-output device)))
-    (declare (fixnum i))
-    (loop
-     (when (= i writes) (return))
-     (tty-smart-line-redisplay device hunk (dequeue *tty-line-writes* i))
-     (when force-output (funcall force-output)))))
-
-;;; TTY-SMART-LINE-REDISPLAY uses an auxiliary screen image structure to
-;;; try to do minimal character shipping to the terminal.  Roughly, we find
-;;; the first different character when comparing what's on the screen and
-;;; what should be there; we will start altering the line after this same
-;;; initial substring.  Then we find, from the end, the first character
-;;; that is different, blasting out characters to the lesser of the two
-;;; indexes.  If the dis-line index is lesser, we have some characters to
-;;; delete from the screen, and if the screen index is lesser, we have some
-;;; additional dis-line characters to insert.  There are a few special
-;;; cases that allow us to punt out of the above algorithm sketch.  If the
-;;; terminal doesn't have insert mode or delete mode, we have blast out to
-;;; the end of the dis-line and possibly clear to the end of the screen's
-;;; line, as appropriate.  Sometimes we don't use insert or delete mode
-;;; because of the overhead cost in characters; it simply is cheaper to
-;;; blast out characters and clear to eol.
-;;; 
-(defun tty-smart-line-redisplay (device hunk dl
-				 &optional (dl-pos (dis-line-position dl)))
-  (declare (fixnum dl-pos))
-  (let* ((dl-chars (dis-line-chars dl))
-	 (dl-len (dis-line-length dl)))
-    (declare (fixnum dl-len) (simple-string dl-chars))
-    (when (listen-editor-input *editor-input*)
-      (throw 'redisplay-catcher :editor-input))
-    (select-hunk hunk)
-    (let* ((screen-image-line (si-line (tty-device-screen-image device)
-				       (+ *hunk-top-line* dl-pos)))
-	   (si-line-chars (si-line-chars screen-image-line))
-	   (si-line-length (si-line-length screen-image-line))
-	   (findex (string/= dl-chars si-line-chars
-			      :end1 dl-len :end2 si-line-length)))
-      (declare (fixnum findex) (simple-string si-line-chars))
-      ;;
-      ;; When the dis-line and screen chars are not string=.
-      (when findex
-	(block tslr-main-body
-	  ;;
-	  ;; See if the screen shows an initial substring of the dis-line.
-	  (when (= findex si-line-length)
-	    (funcall (tty-device-display-string device)
-		     hunk findex dl-pos dl-chars findex dl-len)
-	    (replace-si-line si-line-chars dl-chars findex findex dl-len)
-	    (return-from tslr-main-body t))
-	  ;;
-	  ;; When the dis-line is an initial substring of what's on the screen.
-	  (when (= findex dl-len)
-	    (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)
-	    (return-from tslr-main-body t))
-	  ;;
-	  ;; Find trailing substrings that are the same.
-	  (multiple-value-bind (sindex dindex)
-			       (do ((sindex (1- si-line-length) (1- sindex))
-				    (dindex (1- dl-len) (1- dindex)))
-				   ((or (= sindex -1)
-					(= dindex -1)
-					(char/= (schar dl-chars dindex)
-						(schar si-line-chars sindex)))
-				    (values (1+ sindex) (1+ dindex))))
-	    (declare (fixnum sindex dindex))
-	    ;;
-	    ;; No trailing substrings -- blast and clear to eol.
-	    (when (= dindex dl-len)
-	      (funcall (tty-device-display-string device)
-		       hunk findex dl-pos dl-chars findex dl-len)
-	      (when (< dindex sindex)
-		(funcall (tty-device-clear-to-eol device)
-			 hunk dl-len dl-pos))
-	      (replace-si-line si-line-chars dl-chars findex findex dl-len)
-	      (return-from tslr-main-body t))
-	    (let ((lindex (min sindex dindex)))
-	      (cond ((< lindex findex)
-		     ;; This can happen in funny situations -- believe me!
-		     (setf lindex findex))
-		    (t
-		     (funcall (tty-device-display-string device)
-			      hunk findex dl-pos dl-chars findex lindex)
-		     (replace-si-line si-line-chars dl-chars
-				      findex findex lindex)))
-	      (cond
-	       ((= dindex sindex))
-	       ((< dindex sindex)
-		(let ((delete-char-num (- sindex dindex)))
-		  (cond ((and (tty-device-delete-char device)
-			      (worth-using-delete-mode
-			       device delete-char-num (- si-line-length dl-len)))
-			 (funcall (tty-device-delete-char device)
-				  hunk dindex dl-pos delete-char-num))
-			(t 
-			 (funcall (tty-device-display-string device)
-				  hunk dindex dl-pos dl-chars dindex dl-len)
-			 (funcall (tty-device-clear-to-eol device)
-				  hunk dl-len dl-pos)))))
-	       (t
-		(if (and (tty-device-insert-string device)
-			 (worth-using-insert-mode device (- dindex sindex)))
-		    (funcall (tty-device-insert-string device)
-			     hunk sindex dl-pos dl-chars sindex dindex)
-		    (funcall (tty-device-display-string device)
-			     hunk sindex dl-pos dl-chars sindex dl-len))))
-	      (replace-si-line si-line-chars dl-chars
-			       lindex lindex dl-len))))
-	(setf (si-line-length screen-image-line) dl-len)))
-    (setf (dis-line-flags dl) unaltered-bits)
-    (setf (dis-line-delta dl) 0)))
-
-
-
-;;;; Device methods
-
-;;; Initializing and exiting the device (DEVICE-INIT and DEVICE-EXIT functions).
-;;; These can be found in Tty-Display-Rt.Lisp.
-
-
-;;; Clearing the device (DEVICE-CLEAR functions).
-
-(defun clear-device (device)
-  (device-write-string (tty-device-clear-string device))
-  (cursor-motion device 0 0)
-  (setf (tty-device-cursor-x device) 0)
-  (setf (tty-device-cursor-y device) 0))
-
-
-;;; Moving the cursor around (DEVICE-PUT-CURSOR)
-
-;;; TTY-PUT-CURSOR makes sure the coordinates are mapped from the hunk's
-;;; axis to the screen's and determines the minimal cost cursor motion
-;;; sequence.  Currently, it does no cost analysis of relative motion
-;;; compared to absolute motion but simply makes sure the cursor isn't
-;;; already where we want it.
-;;;
-(defun tty-put-cursor (hunk x y)
-  (declare (fixnum x y))
-  (select-hunk hunk)
-  (let ((y (the fixnum (+ *hunk-top-line* y)))
-	(device (device-hunk-device hunk)))
-    (declare (fixnum y))
-    (unless (and (= (the fixnum (tty-device-cursor-x device)) x)
-		 (= (the fixnum (tty-device-cursor-y device)) y))
-      (cursor-motion device x y)
-      (setf (tty-device-cursor-x device) x)
-      (setf (tty-device-cursor-y device) y))))
-
-;;; UPDATE-CURSOR is used in device redisplay methods to make sure the
-;;; cursor is where it should be.
-;;; 
-(eval-when (compile eval)
-  (defmacro update-cursor (hunk x y)
-    `(funcall (device-put-cursor (device-hunk-device ,hunk)) ,hunk ,x ,y))
-) ;eval-when
-
-;;; CURSOR-MOTION takes two coordinates on the screen's axis,
-;;; moving the cursor to that location.  X is the column index,
-;;; and y is the line index, but Unix and Termcap believe that
-;;; the default order of indexes is first the line and then the
-;;; column or (y,x).  Because of this, when reversep is non-nil,
-;;; we send first x and then y.
-;;; 
-(defun cursor-motion (device x y)
-  (let ((x-add-char (tty-device-cm-x-add-char device))
-	(y-add-char (tty-device-cm-y-add-char device))
-	(x-condx-add (tty-device-cm-x-condx-char device))
-	(y-condx-add (tty-device-cm-y-condx-char device))
-	(one-origin (tty-device-cm-one-origin device)))
-    (when x-add-char (incf x x-add-char))
-    (when (and x-condx-add (> x x-condx-add))
-      (incf x (tty-device-cm-x-condx-add-char device)))
-    (when y-add-char (incf y y-add-char))
-    (when (and y-condx-add (> y y-condx-add))
-      (incf y (tty-device-cm-y-condx-add-char device)))
-    (when one-origin (incf x) (incf y)))
-  (device-write-string (tty-device-cm-string1 device))
-  (let ((reversep (tty-device-cm-reversep device))
-	(x-pad (tty-device-cm-x-pad device))
-	(y-pad (tty-device-cm-y-pad device)))
-    (if reversep
-	(cm-output-coordinate x x-pad)
-	(cm-output-coordinate y y-pad))
-    (device-write-string (tty-device-cm-string2 device))
-    (if reversep
-	(cm-output-coordinate y y-pad)
-	(cm-output-coordinate x x-pad))
-    (device-write-string (tty-device-cm-string3 device))))
-
-;;; CM-OUTPUT-COORDINATE outputs the coordinate with respect to the pad.  If
-;;; there is a pad, then the coordinate needs to be sent as digit-char's (for
-;;; each digit in the coordinate), and if there is no pad, the coordinate needs
-;;; to be converted into a character.  Using CODE-CHAR here is not really
-;;; portable.  With a pad, the coordinate buffer is filled from the end as we
-;;; truncate the coordinate by 10, generating ones digits.
-;;;
-(defconstant cm-coordinate-buffer-len 5)
-(defvar *cm-coordinate-buffer* (make-string cm-coordinate-buffer-len))
-;;;
-(defun cm-output-coordinate (coordinate pad)
-  (cond (pad
-	 (let ((i (1- cm-coordinate-buffer-len)))
-	   (loop
-	     (when (= i -1) (error "Terminal has too many lines!"))
-	     (multiple-value-bind (tens ones)
-				  (truncate coordinate 10)
-	       (setf (schar *cm-coordinate-buffer* i) (digit-char ones))
-	       (when (zerop tens)
-		 (dotimes (n (- pad (- cm-coordinate-buffer-len i)))
-		   (decf i)
-		   (setf (schar *cm-coordinate-buffer* i) #\0))
-		 (device-write-string *cm-coordinate-buffer* i
-				      cm-coordinate-buffer-len)
-		 (return))
-	       (decf i)
-	       (setf coordinate tens)))))
-	(t (tty-write-char (code-char coordinate)))))
-
-
-;;; Writing strings (TTY-DEVICE-DISPLAY-STRING functions)
-
-;;; DISPLAY-STRING is used to put a string at (x,y) on the device.
-;;; 
-(defun display-string (hunk x y string
-			    &optional (start 0) (end (strlen string)))
-  (declare (fixnum x y start end))
-  (update-cursor hunk x y)
-  (device-write-string string start end)
-  (setf (tty-device-cursor-x (device-hunk-device hunk))
-	(the fixnum (+ x (the fixnum (- end start))))))
-
-;;; DISPLAY-STRING-CHECKING-UNDERLINES is used for terminals that special
-;;; case underlines doing an overstrike when they don't otherwise overstrike.
-;;; Note: we do not know in this code whether the terminal can backspace (or
-;;; what the sequence is), whether the terminal has insert-mode, or whether
-;;; the terminal has delete-mode.
-;;; 
-(defun display-string-checking-underlines (hunk x y string
-						&optional (start 0)
-						          (end (strlen string)))
-  (declare (fixnum x y start end) (simple-string string))
-  (update-cursor hunk x y)
-  (let ((upos (position #\_ string :test #'char= :start start :end end))
-	(device (device-hunk-device hunk)))
-    (if upos
-	(let ((previous start)
-	      after-pos)
-	  (declare (fixnum previous after-pos))
-	  (loop (device-write-string string previous upos)
-		(setf after-pos (do ((i (1+ upos) (1+ i)))
-				    ((or (= i end)
-					 (char/= (schar string i) #\_)) i)
-				  (declare (fixnum i))))
-		(let ((ulen (the fixnum (- after-pos upos)))
-		      (cursor-x (the fixnum (+ x (the fixnum
-						      (- after-pos start))))))
-		  (declare (fixnum ulen))
-		  (dotimes (i ulen) (tty-write-char #\space))
-		  (setf (tty-device-cursor-x device) cursor-x)
-		  (update-cursor hunk upos y)
-		  (dotimes (i ulen) (tty-write-char #\_))
-		  (setf (tty-device-cursor-x device) cursor-x))
-		(setf previous after-pos)
-		(setf upos (position #\_ string :test #'char=
-				     :start previous :end end))
-		(unless upos
-		  (device-write-string string previous end)
-		  (return))))
-	(device-write-string string start end))
-    (setf (tty-device-cursor-x device)
-	  (the fixnum (+ x (the fixnum (- end start)))))))
-	   
-
-;;; DEVICE-WRITE-STRING is used to shove a string at the terminal regardless
-;;; of cursor position.
-;;; 
-(defun device-write-string (string &optional (start 0) (end (strlen string)))
-  (declare (fixnum start end))
-  (unless (= start end)
-    (tty-write-string string start (the fixnum (- end start)))))
-
-
-;;; Clearing lines (TTY-DEVICE-CLEAR-TO-EOL, DEVICE-CLEAR-LINES, and
-;;; TTY-DEVICE-CLEAR-TO-EOW functions.)
-
-(defun clear-to-eol (hunk x y)
-  (update-cursor hunk x y)
-  (device-write-string
-   (tty-device-clear-to-eol-string (device-hunk-device hunk))))
-
-(defun space-to-eol (hunk x y)
-  (declare (fixnum x))
-  (update-cursor hunk x y)
-  (let* ((device (device-hunk-device hunk))
-	 (num (- (the fixnum (tty-device-columns device))
-		 x)))
-    (declare (fixnum num))
-    (dotimes (i num) (tty-write-char #\space))
-    (setf (tty-device-cursor-x device) (+ x num))))
-
-(defun clear-lines (hunk x y n)
-  (let* ((device (device-hunk-device hunk))
-	 (clear-to-eol (tty-device-clear-to-eol device)))
-    (funcall clear-to-eol hunk x y)
-    (do ((y (1+ y) (1+ y))
-	 (count (1- n) (1- count)))
-	((zerop count)
-	 (setf (tty-device-cursor-x device) 0)
-	 (setf (tty-device-cursor-y device) (1- y)))
-      (declare (fixnum count y))
-      (funcall clear-to-eol hunk 0 y))))
-
-(defun clear-to-eow (hunk x y)
-  (declare (fixnum x y))
-  (funcall (tty-device-clear-lines (device-hunk-device hunk))
-	   hunk x y
-	   (the fixnum (- (the fixnum (tty-hunk-text-height hunk)) y))))
-
-
-;;; Opening and Deleting lines (TTY-DEVICE-OPEN-LINE and TTY-DEVICE-DELETE-LINE)
-
-(defun open-tty-line (hunk x y &optional (n 1))
-  (update-cursor hunk x y)
-  (dotimes (i n)
-    (device-write-string (tty-device-open-line-string (device-hunk-device hunk)))))
-
-(defun delete-tty-line (hunk x y &optional (n 1))
-  (update-cursor hunk x y)
-  (dotimes (i n)
-    (device-write-string (tty-device-delete-line-string (device-hunk-device hunk)))))
-
-
-;;; Insert and Delete modes (TTY-DEVICE-INSERT-STRING and TTY-DEVICE-DELETE-CHAR)
-
-(defun tty-insert-string (hunk x y string
-			   &optional (start 0) (end (strlen string)))
-  (declare (fixnum x y start end))
-  (update-cursor hunk x y)
-  (let* ((device (device-hunk-device hunk))
-	 (init-string (tty-device-insert-init-string device))
-	 (char-init-string (tty-device-insert-char-init-string device))
-	 (cis-len (if char-init-string (length char-init-string)))
-	 (char-end-string (tty-device-insert-char-end-string device))
-	 (ces-len (if char-end-string (length char-end-string)))
-	 (end-string (tty-device-insert-end-string device)))
-    (declare (simple-string char-init-string char-end-string))
-    (when init-string (device-write-string init-string))
-    (if char-init-string
-	(do ((i start (1+ i)))
-	    ((= i end))
-	  (device-write-string char-init-string 0 cis-len)
-	  (tty-write-char (schar string i))
-	  (when char-end-string
-	    (device-write-string char-end-string 0 ces-len)))
-	(device-write-string string start end))
-    (when end-string (device-write-string end-string))
-    (setf (tty-device-cursor-x device)
-	  (the fixnum (+ x (the fixnum (- end start)))))))
-
-(defun worth-using-insert-mode (device insert-char-num)
-  (let* ((init-string (tty-device-insert-init-string device))
-	 (char-init-string (tty-device-insert-char-init-string device))
-	 (char-end-string (tty-device-insert-char-end-string device))
-	 (end-string (tty-device-insert-end-string device))
-	 (cost 0))
-    (when init-string (incf cost (length (the simple-string init-string))))
-    (when char-init-string
-      (incf cost (* insert-char-num (+ (length (the simple-string
-						    char-init-string))
-				       (if char-end-string
-					   (length (the simple-string
-							char-end-string))
-					   0)))))
-    (when end-string (incf cost (length (the simple-string end-string))))
-    (< cost insert-char-num)))
-
-(defun delete-char (hunk x y &optional n)
-  (declare (fixnum x y n))
-  (update-cursor hunk x y)
-  (let* ((device (device-hunk-device hunk))
-	 (init-string (tty-device-delete-init-string device))
-	 (end-string (tty-device-delete-end-string device))
-	 (delete-char-string (tty-device-delete-char-string device)))
-    (when init-string (device-write-string init-string))
-    (dotimes (i n)
-      (device-write-string delete-char-string))
-    (when end-string (device-write-string end-string))))
-
-(defun worth-using-delete-mode (device delete-char-num clear-char-num)
-  (declare (fixnum num))
-  (let ((init-string (tty-device-delete-init-string device))
-	(end-string (tty-device-delete-end-string device))
-	(delete-char-string (tty-device-delete-char-string device))
-	(clear-to-eol-string (tty-device-clear-to-eol-string device))
-	(cost 0))
-    (declare (simple-string init-string end-string delete-char-string)
-	     (fixnum cost))
-    (when init-string (incf cost (the fixnum (length init-string))))
-    (when end-string (incf cost (the fixnum (length end-string))))
-    (incf cost (the fixnum
-		    (* (the fixnum (length delete-char-string))
-		       delete-char-num)))
-    (< cost (+ delete-char-num
-	       (if clear-to-eol-string
-		   (length clear-to-eol-string)
-		   clear-char-num)))))
-
-
-;;; Standout mode (TTY-DEVICE-STANDOUT-INIT and TTY-DEVICE-STANDOUT-END)
-
-(defun standout-init (hunk)
-  (device-write-string
-   (tty-device-standout-init-string (device-hunk-device hunk))))
-
-(defun standout-end (hunk)
-  (device-write-string
-   (tty-device-standout-end-string (device-hunk-device hunk))))
diff --git a/hemlock/tty-screen.lisp b/hemlock/tty-screen.lisp
deleted file mode 100644
index 896e6f449b69e2cabc3387c63f961735ae0ea5f6..0000000000000000000000000000000000000000
--- a/hemlock/tty-screen.lisp
+++ /dev/null
@@ -1,400 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/tty-screen.lisp,v 1.7 1991/10/08 14:45:37 chiles Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Bill Chiles, except for the code that implements random typeout,
-;;; which was done by Blaine Burks and Bill Chiles.  The code for splitting
-;;; windows was rewritten by Blaine Burks to allow more than a 50/50 split.
-;;;
-;;; Terminal device screen management functions.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-
-
-;;;; Terminal screen initialization
-
-(proclaim '(special *parse-starting-mark*))
-
-(defun init-tty-screen-manager (tty-name)
-  (setf *line-wrap-char* #\!)
-  (setf *window-list* ())
-  (let* ((device (make-tty-device tty-name))
-	 (width (tty-device-columns device))
-	 (height (tty-device-lines device))
-	 (echo-height (value ed::echo-area-height))
-	 (main-lines (- height echo-height 1)) ;-1 for echo modeline.
-	 (main-text-lines (1- main-lines)) ;also main-modeline-pos.
-	 (last-text-line (1- main-text-lines)))
-    (setf (device-bottom-window-base device) last-text-line)
-    ;;
-    ;; Make echo area.
-    (let* ((echo-hunk (make-tty-hunk :position (1- height) :height echo-height
-				     :text-position (- height 2)
-				     :text-height echo-height :device device))
-	   (echo (internal-make-window :hunk echo-hunk)))
-      (setf *echo-area-window* echo)
-      (setf (device-hunk-window echo-hunk) echo)
-      (setup-window-image *parse-starting-mark* echo echo-height width)
-      (setup-modeline-image *echo-area-buffer* echo)
-      (setf (device-hunk-previous echo-hunk) echo-hunk
-	    (device-hunk-next echo-hunk) echo-hunk)
-      (prepare-window-for-redisplay echo))
-    ;;
-    ;; Make the main window.
-    (let* ((main-hunk (make-tty-hunk :position main-text-lines
-				     :height main-lines
-				     :text-position last-text-line
-				     :text-height main-text-lines
-				     :device device))
-	   (main (internal-make-window :hunk main-hunk)))
-      (setf (device-hunk-window main-hunk) main)
-      (setf *current-window* main)
-      (setup-window-image (buffer-point *current-buffer*)
-			  main main-text-lines width)
-      (setup-modeline-image *current-buffer* main)
-      (prepare-window-for-redisplay main)
-      (setf (device-hunk-previous main-hunk) main-hunk
-	    (device-hunk-next main-hunk) main-hunk)
-      (setf (device-hunks device) main-hunk))
-    (defhvar "Paren Pause Period"
-      "This is how long commands that deal with \"brackets\" shows the cursor at
-      the matching \"bracket\" for this number of seconds."
-      :value 0.5
-      :mode "Lisp")))
-
-
-
-;;;; Building devices from termcaps.
-
-;;; MAKE-TTY-DEVICE returns a device built from a termcap.  Some function
-;;; slots are set to the appropriate function even though the capability
-;;; might not exist; in this case, we simply set the control string value
-;;; to the empty string.  Some function slots are set differently depending
-;;; on available capability.
-;;;
-(defun make-tty-device (name)
-  (let ((termcap (get-termcap name))
-	(device (%make-tty-device :name name)))
-    (when (termcap :overstrikes termcap)
-      (error "Terminal sufficiently irritating -- not currently supported."))
-    ;;
-    ;; Similar device slots.
-    (setf (device-init device) #'init-tty-device)
-    (setf (device-exit device) #'exit-tty-device)
-    (setf (device-smart-redisplay device)
-	  (if (and (termcap :open-line termcap) (termcap :delete-line termcap))
-	      #'tty-smart-window-redisplay
-	      #'tty-semi-dumb-window-redisplay))
-    (setf (device-dumb-redisplay device) #'tty-dumb-window-redisplay)
-    (setf (device-clear device) #'clear-device)
-    (setf (device-put-cursor device) #'tty-put-cursor)
-    (setf (device-show-mark device) #'tty-show-mark)
-    (setf (device-next-window device) #'tty-next-window)
-    (setf (device-previous-window device) #'tty-previous-window)
-    (setf (device-make-window device) #'tty-make-window)
-    (setf (device-delete-window device) #'tty-delete-window)
-    (setf (device-random-typeout-setup device) #'tty-random-typeout-setup)
-    (setf (device-random-typeout-cleanup device) #'tty-random-typeout-cleanup)
-    (setf (device-random-typeout-full-more device) #'do-tty-full-more)
-    (setf (device-random-typeout-line-more device)
-	  #'update-tty-line-buffered-stream)
-    (setf (device-force-output device) #'tty-force-output)
-    (setf (device-finish-output device) #'tty-finish-output)
-    (setf (device-beep device) #'tty-beep)
-    ;;
-    ;; A few useful values.
-    (setf (tty-device-dumbp device)
-	  (not (and (termcap :open-line termcap)
-		    (termcap :delete-line termcap))))
-    ;;
-    ;; Get size and speed.
-    (multiple-value-bind  (lines cols speed)
-			  (get-terminal-attributes)
-      (setf (tty-device-lines device) (or lines (termcap :lines termcap)))
-      (let ((cols (or cols (termcap :columns termcap))))
-	(setf (tty-device-columns device)
-	      (if (termcap :auto-margins-p termcap)
-		  (1- cols) cols)))
-      (setf (tty-device-speed device) speed))
-    ;;
-    ;; Some function slots.
-    (setf (tty-device-display-string device)
-	  (if (termcap :underlines termcap)
-	      #'display-string-checking-underlines
-	      #'display-string))
-    (setf (tty-device-standout-init device) #'standout-init)
-    (setf (tty-device-standout-end device) #'standout-end)
-    (setf (tty-device-open-line device)
-	  (if (termcap :open-line termcap)
-	      #'open-tty-line
-	      ;; look for scrolling region stuff
-	      ))
-    (setf (tty-device-delete-line device)
-	  (if (termcap :delete-line termcap)
-	      #'delete-tty-line
-	      ;; look for reverse scrolling stuff
-	      ))
-    (setf (tty-device-clear-to-eol device)
-	  (if (termcap :clear-to-eol termcap)
-	      #'clear-to-eol
-	      #'space-to-eol))
-    (setf (tty-device-clear-lines device) #'clear-lines)
-    (setf (tty-device-clear-to-eow device) #'clear-to-eow)
-    ;;
-    ;; Insert and delete modes.
-    (let ((init-insert-mode (termcap :init-insert-mode termcap))
-	  (init-insert-char (termcap :init-insert-char termcap))
-	  (end-insert-char (termcap :end-insert-char termcap)))
-      (when (and init-insert-mode (string/= init-insert-mode ""))
-	(setf (tty-device-insert-string device) #'tty-insert-string)
-	(setf (tty-device-insert-init-string device) init-insert-mode)
-	(setf (tty-device-insert-end-string device)
-	      (termcap :end-insert-mode termcap)))
-      (when init-insert-char
-	(setf (tty-device-insert-string device) #'tty-insert-string)
-	(setf (tty-device-insert-char-init-string device) init-insert-char))
-      (when (and end-insert-char (string/= end-insert-char ""))
-	(setf (tty-device-insert-char-end-string device) end-insert-char)))
-    (let ((delete-char (termcap :delete-char termcap)))
-      (when delete-char
-	(setf (tty-device-delete-char device) #'delete-char)
-	(setf (tty-device-delete-char-string device) delete-char)
-	(setf (tty-device-delete-init-string device)
-	      (termcap :init-delete-mode termcap))
-	(setf (tty-device-delete-end-string device)
-	      (termcap :end-delete-mode termcap))))
-    ;;
-    ;; Some string slots.
-    (setf (tty-device-standout-init-string device)
-	  (or (termcap :init-standout-mode termcap) ""))
-    (setf (tty-device-standout-end-string device)
-	  (or (termcap :end-standout-mode termcap) ""))
-    (setf (tty-device-clear-to-eol-string device)
-	  (termcap :clear-to-eol termcap))
-    (let ((clear-string (termcap :clear-display termcap)))
-      (unless clear-string
-	(error "Terminal not sufficiently powerful enough to run Hemlock."))
-      (setf (tty-device-clear-string device) clear-string))
-    (setf (tty-device-open-line-string device)
-	  (termcap :open-line termcap))
-    (setf (tty-device-delete-line-string device)
-	  (termcap :delete-line termcap))
-    (let* ((init-string (termcap :init-string termcap))
-	   (init-file (termcap :init-file termcap))
-	   (init-file-string (if init-file (get-init-file-string init-file)))
-	   (init-cm-string (termcap :init-cursor-motion termcap)))
-      (setf (tty-device-init-string device)
-	    (concatenate 'simple-string (or init-string "")
-			 (or init-file-string "") (or init-cm-string ""))))
-    (setf (tty-device-cm-end-string device)
-	  (or (termcap :end-cursor-motion termcap) ""))
-    ;;
-    ;; Cursor motion slots.
-    (let ((cursor-motion (termcap :cursor-motion termcap)))
-      (unless cursor-motion
-	(error "Terminal not sufficiently powerful enough to run Hemlock."))
-      (let ((x-add-char (getf cursor-motion :x-add-char))
-	    (y-add-char (getf cursor-motion :y-add-char))
-	    (x-condx-char (getf cursor-motion :x-condx-char))
-	    (y-condx-char (getf cursor-motion :y-condx-char)))
-	(when x-add-char
-	  (setf (tty-device-cm-x-add-char device) (char-code x-add-char)))
-	(when y-add-char
-	  (setf (tty-device-cm-y-add-char device) (char-code y-add-char)))
-	(when x-condx-char
-	  (setf (tty-device-cm-x-condx-char device) (char-code x-condx-char))
-	  (setf (tty-device-cm-x-condx-add-char device)
-		(char-code (getf cursor-motion :x-condx-add-char))))
-	(when y-condx-char
-	  (setf (tty-device-cm-y-condx-char device) (char-code y-condx-char))
-	  (setf (tty-device-cm-y-condx-add-char device)
-		(char-code (getf cursor-motion :y-condx-add-char)))))
-      (setf (tty-device-cm-string1 device) (getf cursor-motion :string1))
-      (setf (tty-device-cm-string2 device) (getf cursor-motion :string2))
-      (setf (tty-device-cm-string3 device) (getf cursor-motion :string3))
-      (setf (tty-device-cm-one-origin device) (getf cursor-motion :one-origin))
-      (setf (tty-device-cm-reversep device) (getf cursor-motion :reversep))
-      (setf (tty-device-cm-x-pad device) (getf cursor-motion :x-pad))
-      (setf (tty-device-cm-y-pad device) (getf cursor-motion :y-pad)))
-    ;;
-    ;; Screen image initialization.
-    (let* ((lines (tty-device-lines device))
-	   (columns (tty-device-columns device))
-	   (screen-image (make-array lines)))
-      (dotimes (i lines)
-	(setf (svref screen-image i) (make-si-line columns)))
-      (setf (tty-device-screen-image device) screen-image))
-    device))
-
-
-      
-;;;; Making a window
-
-(defun tty-make-window (device start modelinep window font-family
-			       ask-user x y width height proportion)
-  (declare (ignore window font-family ask-user x y width height))
-  (let* ((old-window (current-window))
-	 (victim (window-hunk old-window))
-	 (text-height (tty-hunk-text-height victim))
-	 (availability (if modelinep (1- text-height) text-height)))
-    (when (> availability 1)
-      (let* ((new-lines (truncate (* availability proportion)))
-	     (old-lines (- availability new-lines))
-	     (pos (device-hunk-position victim))
-	     (new-height (if modelinep (1+ new-lines) new-lines))
-	     (new-text-pos (if modelinep (1- pos) pos))
-	     (new-hunk (make-tty-hunk :position pos
-				      :height new-height
-				      :text-position new-text-pos
-				      :text-height new-lines
-				      :device device))
-	     (new-window (internal-make-window :hunk new-hunk)))
-	(declare (fixnum new-lines old-lines pos new-height new-text-pos))
-	(setf (device-hunk-window new-hunk) new-window)
-	(let* ((old-text-pos-diff (- pos (tty-hunk-text-position victim)))
-	       (old-win-new-pos (- pos new-height)))
-	  (declare (fixnum old-text-pos-diff old-win-new-pos))
-	  (setf (device-hunk-height victim)
-		(- (device-hunk-height victim) new-height))
-	  (setf (tty-hunk-text-height victim) old-lines)
-	  (setf (device-hunk-position victim) old-win-new-pos)
-	  (setf (tty-hunk-text-position victim)
-		(- old-win-new-pos old-text-pos-diff)))
-	(setup-window-image start new-window new-lines
-			    (window-width old-window))
-	(prepare-window-for-redisplay new-window)
-	(when modelinep
-	  (setup-modeline-image (line-buffer (mark-line start)) new-window))
-	(change-window-image-height old-window old-lines)
-	(shiftf (device-hunk-previous new-hunk)
-		(device-hunk-previous (device-hunk-next victim))
-		new-hunk)
-	(shiftf (device-hunk-next new-hunk) (device-hunk-next victim) new-hunk)
-	(setf *currently-selected-hunk* nil)
-	(setf *screen-image-trashed* t)
-	new-window))))
-
-
-
-;;;; Deleting a window
-
-(defun tty-delete-window (window)
-  (let* ((hunk (window-hunk window))
-	 (prev (device-hunk-previous hunk))
-	 (next (device-hunk-next hunk))
-	 (device (device-hunk-device hunk)))
-    (setf (device-hunk-next prev) next)
-    (setf (device-hunk-previous next) prev)
-    (let ((buffer (window-buffer window)))
-      (setf (buffer-windows buffer) (delq window (buffer-windows buffer))))
-    (let ((new-lines (device-hunk-height hunk)))
-      (declare (fixnum new-lines))
-      (cond ((eq hunk (device-hunks (device-hunk-device next)))
-	     (incf (device-hunk-height next) new-lines)
-	     (incf (tty-hunk-text-height next) new-lines)
-	     (let ((w (device-hunk-window next)))
-	       (change-window-image-height w (+ new-lines (window-height w)))))
-	    (t
-	     (incf (device-hunk-height prev) new-lines)
-	     (incf (device-hunk-position prev) new-lines)
-	     (incf (tty-hunk-text-height prev) new-lines)
-	     (incf (tty-hunk-text-position prev) new-lines)
-	     (let ((w (device-hunk-window prev)))
-	       (change-window-image-height w (+ new-lines (window-height w)))))))
-    (when (eq hunk (device-hunks device))
-      (setf (device-hunks device) next)))
-  (setf *currently-selected-hunk* nil)
-  (setf *screen-image-trashed* t))
-
-
-
-;;;; Next and Previous window operations.
-
-(defun tty-next-window (window)
-  (device-hunk-window (device-hunk-next (window-hunk window))))
-
-(defun tty-previous-window (window)
-  (device-hunk-window (device-hunk-previous (window-hunk window))))
-
-
-
-;;;; Random typeout support
-
-(defun tty-random-typeout-setup (device stream height)
-  (declare (fixnum height))
-  (let* ((*more-prompt-action* :empty)
-	 (height (min (1- (device-bottom-window-base device)) height))
-	 (old-hwindow (random-typeout-stream-window stream))
-	 (new-hwindow (if old-hwindow
-			  (change-tty-random-typeout-window old-hwindow height)
-			  (setf (random-typeout-stream-window stream)
-				(make-tty-random-typeout-window
-				 device
-				 (buffer-start-mark
-				  (line-buffer
-				   (mark-line
-				    (random-typeout-stream-mark stream))))
-				 height)))))
-    (funcall (tty-device-clear-to-eow device) (window-hunk new-hwindow) 0 0)))
-
-(defun change-tty-random-typeout-window (window height)
-  (update-modeline-field (window-buffer window) window :more-prompt)
-  (let* ((height-1 (1- height))
-	 (hunk (window-hunk window)))
-    (setf (device-hunk-position hunk) height-1
-	  (device-hunk-height hunk) height
-	  (tty-hunk-text-position hunk) (1- height-1)
-	  (tty-hunk-text-height hunk) height-1)
-    (change-window-image-height window height-1)
-    window))
-
-(defun make-tty-random-typeout-window (device mark height)
-  (let* ((height-1 (1- height))
-	 (hunk (make-tty-hunk :position height-1
-			      :height height
-			      :text-position (1- height-1)
-			      :text-height height-1
-			      :device device))
-	 (window (internal-make-window :hunk hunk)))
-    (setf (device-hunk-window hunk) window)
-    (setf (device-hunk-device hunk) device)
-    (setup-window-image mark window height-1 (tty-device-columns device))
-    (setf *window-list* (delete window *window-list*))
-    (prepare-window-for-redisplay window)
-    (setup-modeline-image (line-buffer (mark-line mark)) window)
-    (update-modeline-field (window-buffer window) window :more-prompt)
-    window))
-
-(defun tty-random-typeout-cleanup (stream degree)
-  (declare (ignore degree))
-  (let* ((window (random-typeout-stream-window stream))
-	 (stream-hunk (window-hunk window))
-	 (last-line-affected (device-hunk-position stream-hunk))
-	 (device (device-hunk-device stream-hunk))
-	 (*more-prompt-action* :normal))
-    (declare (fixnum last-line-affected))
-    (update-modeline-field (window-buffer window) window :more-prompt)
-    (funcall (tty-device-clear-to-eow device) stream-hunk 0 0)
-    (do* ((hunk (device-hunks device) (device-hunk-next hunk))
-	  (window (device-hunk-window hunk) (device-hunk-window hunk))
-	  (last (device-hunk-previous hunk)))
-	 ((>= (device-hunk-position hunk) last-line-affected)
-	  (if (= (device-hunk-position hunk) last-line-affected)
-	      (redisplay-window-all window)
-	      (tty-redisplay-n-lines window
-				     (- (+ last-line-affected
-					   (tty-hunk-text-height hunk))
-					(tty-hunk-text-position hunk)))))
-      (redisplay-window-all window)
-      (when (eq hunk last) (return)))))
diff --git a/hemlock/tty-stream.lisp b/hemlock/tty-stream.lisp
deleted file mode 100644
index 013a7df605212a3da073a4e28ca29f6a8264df17..0000000000000000000000000000000000000000
--- a/hemlock/tty-stream.lisp
+++ /dev/null
@@ -1,160 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/tty-stream.lisp,v 1.1.1.3 1991/11/09 03:06:04 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Some stuff to make streams that write out to terminal hunks.
-;;;
-;;; Written by Bill Chiles.
-;;;
-;;; This code is VERY similar to that in Pane-Stream.Lisp.  The biggest
-;;; (if only) difference is in TTY-HUNK-STREAM-NEWLINE.
-;;;
-
-(in-package 'hemlock-internals)
-
-
-
-;;;; Constants
-
-(defconstant tty-hunk-width-limit 200)
-
-
-
-;;;; Structures
-
-;;; Tty-Hunk streams are inherently buffered by line.
-
-(defstruct (stream-hunk (:print-function %print-device-hunk)
-			(:include tty-hunk))
-  (width 0 :type fixnum)
-  (point-x 0 :type fixnum)
-  (point-y 0 :type fixnum)
-  (buffer "" :type simple-string))
-
-(defstruct (tty-hunk-output-stream (:include stream
-					     (out #'hunk-out)
-					     (sout #'hunk-sout)
-					     (misc #'hunk-misc))
-				   (:constructor
-				    make-tty-hunk-output-stream ()))
-  (hunk (make-stream-hunk :buffer (make-string tty-hunk-width-limit))))
-
-
-
-;;;; Tty-hunk-output-stream methods
-
-;;; HUNK-OUT puts a character into a hunk-stream buffer.  If the character
-;;; makes the current line wrap, or if the character is a newline, then
-;;; call TTY-HUNK-NEWLINE.
-;;;
-(defun hunk-out (stream character)
-  (let* ((hunk (tty-hunk-output-stream-hunk stream))
-	 (x (stream-hunk-point-x hunk)))
-    (declare (fixnum x))
-    (cond ((char= character #\newline)
-	   (tty-hunk-stream-newline hunk)
-	   (return-from hunk-out nil))
-	  ((= x (the fixnum (stream-hunk-width hunk)))
-	   (setf x 0)
-	   (tty-hunk-stream-newline hunk)))
-    (setf (schar (stream-hunk-buffer hunk) x) character)
-    (incf (stream-hunk-point-x hunk))))
-
-;;; HUNK-MISC, when finishing or forcing output, only needs to blast
-;;; out the buffer at y from 0 to x since these streams are inherently
-;;; line buffered.  Currently, these characters will be blasted out again
-;;; since there isn't a separate buffer index from point-x, and we can't
-;;; set point-x to zero since we haven't a newline.
-;;; 
-(defun hunk-misc (stream operation &optional arg1 arg2)
-  (declare (ignore arg1 arg2))
-  (case operation
-    (:charpos
-     (let ((hunk (tty-hunk-output-stream-hunk stream)))
-       (values (stream-hunk-point-x hunk) (stream-hunk-point-y hunk))))
-    ((:finish-output :force-output)
-     (let* ((hunk (tty-hunk-output-stream-hunk stream))
-	    (device (device-hunk-device hunk)))
-       (funcall (tty-device-display-string device)
-		hunk 0 (stream-hunk-point-y hunk) (stream-hunk-buffer hunk)
-		0 (stream-hunk-point-x hunk))
-       (when (device-force-output device)
-	 (funcall (device-force-output device)))))
-    (:line-length
-     (stream-hunk-width (tty-hunk-output-stream-hunk stream)))
-    (:element-type 'base-char)))
-
-;;; HUNK-SOUT writes a byte-blt's a string to a hunk-stream's buffer.
-;;; When newlines are found, recurse on the substrings delimited by start,
-;;; end, and newlines.  If the string causes line wrapping, then we break
-;;; the string up into line-at-a-time segments calling TTY-HUNK-STREAM-NEWLINE.
-;;; 
-(defun hunk-sout (stream string start end)
-  (declare (fixnum start end))
-  (let* ((hunk (tty-hunk-output-stream-hunk stream))
-	 (buffer (stream-hunk-buffer hunk))
-	 (x (stream-hunk-point-x hunk))
-	 (dst-end (+ x (- end start)))
-	 (width (stream-hunk-width hunk))
-	 (newlinep (%sp-find-character string start end #\newline)))
-    (declare (fixnum x dst-end width))
-    (cond (newlinep
-	   (let ((previous start) (current newlinep))
-	     (declare (fixnum previous))
-	     (loop (when (null current)
-		     (hunk-sout stream string previous end)
-		     (return))
-		   (hunk-sout stream string previous current)
-		   (tty-hunk-stream-newline hunk)
-		   (setf previous (the fixnum (1+ (the fixnum current))))
-		   (setf current
-			 (%sp-find-character string previous end #\newline)))))
-	  ((> dst-end width)
-	   (let ((new-start (+ start (- width x))))
-	     (declare (fixnum new-start))
-	     (%primitive byte-blt string start buffer x width)
-	     (setf (stream-hunk-point-x hunk) width)
-	     (tty-hunk-stream-newline hunk)
-	     (do ((idx (+ new-start width) (+ idx width))
-		  (prev new-start idx))
-		 ((>= idx end)
-		  (let ((dst-end (- end prev)))
-		    (%primitive byte-blt string prev buffer 0 dst-end)
-		    (setf (stream-hunk-point-x hunk) dst-end)))
-	       (declare (fixnum prev idx))
-	       (%primitive byte-blt string prev buffer 0 width)
-	       (setf (stream-hunk-point-x hunk) width)
-	       (tty-hunk-stream-newline hunk))))
-	  (t
-	   (%primitive byte-blt string start buffer x dst-end)
-	   (setf (stream-hunk-point-x hunk) dst-end)))))
-
-;;; TTY-HUNK-STREAM-NEWLINE is the only place we display lines and affect
-;;; point-y.  We also blast out the buffer in HUNK-MISC.
-;;; 
-(defun tty-hunk-stream-newline (hunk)
-  (let* ((device (device-hunk-device hunk))
-	 (force-output-fun (device-force-output device))
-	 (y (stream-hunk-point-y hunk)))
-    (declare (fixnum y))
-    (when (= y (the fixnum (device-hunk-position hunk)))
-      (funcall (tty-device-display-string device) hunk 0 y "--More--" 0 8)
-      (when force-output-fun (funcall force-output-fun))
-      (wait-for-more)
-      (funcall (tty-device-clear-to-eow device) hunk 0 0)
-      (setf (stream-hunk-point-y hunk) 0)
-      (setf y 0))
-    (funcall (tty-device-display-string device)
-	     hunk 0 y (stream-hunk-buffer hunk) 0 (stream-hunk-point-x hunk))
-    (when force-output-fun (funcall force-output-fun))
-    (setf (stream-hunk-point-x hunk) 0)
-    (incf (stream-hunk-point-y hunk))))
diff --git a/hemlock/undo.lisp b/hemlock/undo.lisp
deleted file mode 100644
index e285008f479020da507a7da659ddeb5fe76790fb..0000000000000000000000000000000000000000
--- a/hemlock/undo.lisp
+++ /dev/null
@@ -1,225 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;; 
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/undo.lisp,v 1.2 1991/02/08 16:39:00 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Bill Chiles
-;;;
-;;; This file contains the implementation of the undo mechanism.
-
-(in-package 'hemlock)
-
-
-
-;;;; -- Constants --
-
-(defconstant undo-name "Undo")
-
-
-
-;;;; -- Variables --
-
-(defvar *undo-info* nil
-  "Structure containing necessary info to undo last undoable operation.")
-
-
-
-;;;; -- Structures --
-
-(defstruct (undo-info (:print-function %print-undo-info)
-		      (:constructor %make-undo-info
-				    (name method cleanup method-undo buffer))
-		      (:copier nil))
-  name		; string displayed for user to know what's being undone --
-		; typically a command's name.
-  (hold-name undo-name)	; holds a name for successive invocations of the
-			; "Undo" command.
-  method	; closure stored by command that undoes the command when invoked.
-  method-undo	; closure stored by command that undoes what method does.
-  cleanup	; closure stored by command that cleans up any data for method,
-		; such as permanent marks.
-  buffer)	; buffer the command was invoked in.
-
-(setf (documentation 'undo-info-name 'function)
-      "Return the string indicating what would be undone for given undo info.")
-(setf (documentation 'undo-info-method 'function)
-      "Return the closure that undoes a command when invoked.")
-(setf (documentation 'undo-info-cleanup 'function)
-      "Return the closure that cleans up data necessary for an undo method.")
-(setf (documentation 'undo-info-buffer 'function)
-      "Return the buffer that the last undoable command was invoked in.")
-(setf (documentation 'undo-info-hold-name 'function)
-      "Return the name being held since the last invocation of \"Undo\"")
-(setf (documentation 'undo-info-method-undo 'function)
-      "Return the closure that undoes what undo-info-method does.")
-      
-
-(defun %print-undo-info (obj s depth)
-  (declare (ignore depth))
-  (format s "#<Undo Info ~S>" (undo-info-name obj)))
-
-
-
-;;;; -- Commands --
-
-(defcommand "Undo" (p)
-  "Undo last major change, kill, etc.
-   Simple insertions and deletions cannot be undone.  If you change the buffer
-   in this way before you undo, you may get slightly wrong results, but this
-   is probably still useful."
-  "This is not intended to be called in Lisp code."
-  (declare (ignore p))
-  (if (not *undo-info*) (editor-error "No currently undoable command."))
-  (let ((buffer (undo-info-buffer *undo-info*))
-	(cleanup (undo-info-cleanup *undo-info*))
-	(method-undo (undo-info-method-undo *undo-info*)))
-    (if (not (eq buffer (current-buffer)))
-	(editor-error "Undo info is for buffer ~S." (buffer-name buffer)))
-    (when (prompt-for-y-or-n :prompt (format nil "Undo the last ~A? "
-					     (undo-info-name *undo-info*))
-			     :must-exist t)
-      (funcall (undo-info-method *undo-info*))
-      (cond (method-undo
-	     (rotatef (undo-info-name *undo-info*)
-		      (undo-info-hold-name *undo-info*))
-	     (rotatef (undo-info-method *undo-info*)
-		      (undo-info-method-undo *undo-info*)))
-	    (t (if cleanup (funcall cleanup))
-	       (setf *undo-info* nil))))))
-
-
-
-;;;; -- Primitives --
-
-(defun save-for-undo (name method
-		      &optional cleanup method-undo (buffer (current-buffer)))
-  "Stashes information for next \"Undo\" command invocation.  If there is
-   an undo-info object, it is cleaned up first."
-  (cond (*undo-info*
-	 (let ((old-cleanup (undo-info-cleanup *undo-info*)))
-	   (if old-cleanup (funcall old-cleanup))
-	   (setf (undo-info-name *undo-info*) name)
-	   (setf (undo-info-hold-name *undo-info*) undo-name)
-	   (setf (undo-info-method *undo-info*) method)
-	   (setf (undo-info-method-undo *undo-info*) method-undo)
-	   (setf (undo-info-cleanup *undo-info*) cleanup)
-	   (setf (undo-info-buffer *undo-info*) buffer)
-	   *undo-info*))
-	(t (setf *undo-info*
-		 (%make-undo-info name method cleanup method-undo buffer)))))
-
-
-
-(eval-when (compile eval)
-
-;;; MAKE-TWIDDLE-REGION-UNDO sets up an undo method that deletes region1,
-;;; saving the deleted region and eventually storing it in region2.  After
-;;; deleting region1, its start and end are made :right-inserting and
-;;; :left-inserting, so it will contain region2 when it is inserted at region1's
-;;; end.  This results in a method that takes region1 with permanent marks
-;;; into some buffer and results with the contents of region2 in region1 (with
-;;; permanent marks into a buffer) and the contents of region1 (from the buffer)
-;;; in region2 (a region without marks into any buffer).
-;;;
-(defmacro make-twiddle-region-undo (region1 region2)
-  `#'(lambda ()
-       (let* ((tregion (delete-and-save-region ,region1))
-	      (mark (region-end ,region1)))
-	 (setf (mark-kind (region-start ,region1)) :right-inserting)
-	 (setf (mark-kind mark) :left-inserting)
-	 (ninsert-region mark ,region2)
-	 (setf ,region2 tregion))))
-
-;;; MAKE-DELETE-REGION-UNDO sets up an undo method that deletes region with
-;;; permanent marks into a buffer, saving the region in region without any
-;;; marks into a buffer, deleting one of the permanent marks, and saving one
-;;; permanent mark in the variable mark.  This is designed to work with
-;;; MAKE-INSERT-REGION-UNDO, so mark results in the location in a buffer where
-;;; region will be inserted if this method is undone.
-;;;
-(defmacro make-delete-region-undo (region mark)
-  `#'(lambda ()
-       (let ((tregion (delete-and-save-region ,region)))
-	 (delete-mark (region-start ,region))
-	 (setf ,mark (region-end ,region))
-	 (setf ,region tregion))))
-
-;;; MAKE-INSERT-REGION-UNDO sets up an undo method that inserts region at mark,
-;;; saving in the variable region a region with permanent marks in a buffer.
-;;; This is designed to work with MAKE-DELETE-REGION-UNDO, so region can later
-;;; be deleted.
-;;;
-(defmacro make-insert-region-undo (region mark)
-  `#'(lambda ()
-       (let ((tregion (region (copy-mark ,mark :right-inserting) ,mark)))
-	 (setf (mark-kind ,mark) :left-inserting)
-	 (ninsert-region ,mark ,region)
-	 (setf ,region tregion))))
-
-) ;eval-when
-
-;;; MAKE-REGION-UNDO handles three common cases that undo'able commands often
-;;; need.  This function sets up three closures via SAVE-FOR-UNDO that do
-;;; an original undo, undo the original undo, and clean up any permanent marks
-;;; the next time SAVE-FOR-UNDO is called.  Actually, the original undo and
-;;; the undo for the original undo setup here are reversible in that each
-;;; invocation of "Undo" switches these, so an undo setup by the function is
-;;; undo'able, and the undo of the undo is undo'able, and the ....
-;;;
-;;; :twiddle
-;;;    Region has permanent marks into a buffer.  Mark-or-region is a region
-;;;    not connected to any buffer.  A first undo deletes region, saving it and
-;;;    inserting mark-or-region.  This also sets region around the inserted
-;;;    region in the buffer and sets mark-or-region to be the deleted and saved
-;;;    region.  Thus the undo and the undo of the undo are the same action.
-;;; :insert
-;;;    Region is not connected to any buffer.  Mark-or-region is a permanent
-;;;    mark into a buffer where region is to be inserted on a first undo, and
-;;;    this mark is used to form a region on the first undo that will be
-;;;    deleted upon a subsequent undo.  The cleanup method knows mark-or-region
-;;;    is a permanent mark into a buffer, but it has to determine if region
-;;;    has marks into a buffer because if a subsequent undo does occur, region
-;;;    does point into a buffer.
-;;; :delete
-;;;    Region has permanent marks into a buffer.  Mark-or-region should not
-;;;    have been supplied.  A first undo deletes region, saving the deleted
-;;;    region in region and creating a permanent mark that indicates where to
-;;;    put region back.  The permanent mark is stored in mark-or-region.  The
-;;;    cleanup method has to check that mark-or-region is a mark since it won't
-;;;    be unless there was a subsequent undo.
-;;;
-(defun make-region-undo (kind name region &optional mark-or-region)
-  (case kind
-    (:twiddle
-     (save-for-undo name
-       (make-twiddle-region-undo region mark-or-region)
-       #'(lambda ()
-	   (delete-mark (region-start region))
-	   (delete-mark (region-end region)))
-       (make-twiddle-region-undo region mark-or-region)))
-    (:insert
-     (save-for-undo name
-       (make-insert-region-undo region mark-or-region)
-       #'(lambda ()
-	   (let ((mark (region-start region)))
-	     (delete-mark mark-or-region)
-	     (when (line-buffer (mark-line mark))
-	       (delete-mark mark)
-	       (delete-mark (region-end region)))))
-       (make-delete-region-undo region mark-or-region)))
-    (:delete
-     (save-for-undo name
-       (make-delete-region-undo region mark-or-region)
-       #'(lambda ()
-	   (delete-mark (region-start region))
-	   (delete-mark (region-end region))
-	   (if (markp mark-or-region) (delete-mark mark-or-region)))
-       (make-insert-region-undo region mark-or-region)))))
diff --git a/hemlock/unixcoms.lisp b/hemlock/unixcoms.lisp
deleted file mode 100644
index abed3eab50dd43bcd931a8d952e97daba81aeeb3..0000000000000000000000000000000000000000
--- a/hemlock/unixcoms.lisp
+++ /dev/null
@@ -1,255 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/unixcoms.lisp,v 1.6 1991/09/04 14:24:07 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;
-;;; This file contains Commands useful when running on a Unix box.  Hopefully
-;;; there are no CMU Unix dependencies though there are probably CMU Common
-;;; Lisp dependencies, such as RUN-PROGRAM.
-;;;
-;;; Written by Christopher Hoover.
-
-(in-package "HEMLOCK")
-
-
-
-;;;; Region and File printing commands.
-
-(defhvar "Print Utility"
-  "UNIX(tm) program to invoke (via EXT:RUN-PROGRAM) to do printing.
-   The program should act like lpr: if a filename is given as an argument,
-   it should print that file, and if no name appears, standard input should
-   be assumed."
-  :value "lpr")
-
-(defhvar "Print Utility Switches"
-  "Switches to pass to the \"Print Utility\" program.  This should be a list
-   of strings."
-  :value ())
-
-
-;;; PRINT-SOMETHING calls RUN-PROGRAM on the utility-name and args.  Output
-;;; and error output are done to the echo area, and errors are ignored for
-;;; now.  Run-program-keys are other keywords to pass to RUN-PROGRAM in
-;;; addition to :wait, :output, and :error.
-;;; 
-(defmacro print-something (&optional (run-program-keys)
-				     (utility-name '(value print-utility))
-				     (args '(value print-utility-switches)))
-  (let ((pid (gensym))
-	(error-code (gensym)))
-    `(multiple-value-bind (,pid ,error-code)
-			  (ext:run-program ,utility-name ,args
-					   ,@run-program-keys
-					   :wait t
-					   :output *echo-area-stream*
-					   :error *echo-area-stream*)
-       (declare (ignore ,pid ,error-code))
-       (force-output *echo-area-stream*)
-       ;; Keep the echo area from being cleared at the top of the command loop.
-       (setf (buffer-modified *echo-area-buffer*) nil))))
-
-
-;;; PRINT-REGION -- Interface
-;;;
-;;; Takes a region and outputs the text to the program defined by
-;;; the hvar "Print Utility" with options form the hvar "Print
-;;; Utility Options" using PRINT-SOMETHING.
-;;; 
-(defun print-region (region)
-  (with-input-from-region (s region)
-    (print-something (:input s))))
-
-
-(defcommand "Print Buffer" (p)
-  "Prints the current buffer using the program defined by the hvar
-   \"Print Utility\" with the options from the hvar \"Print Utility
-   Options\".   Errors appear in the echo area."
-  "Prints the contents of the buffer."
-  (declare (ignore p))
-  (message "Printing buffer...~%")
-  (print-region (buffer-region (current-buffer))))
-
-(defcommand "Print Region" (p)
-  "Prints the current region using the program defined by the hvar
-   \"Print Utility\" with the options from the hvar \"Print Utility
-   Options\".  Errors appear in the echo area."
-  "Prints the current region."
-  (declare (ignore p))
-  (message "Printing region...~%")
-  (print-region (current-region)))
-
-(defcommand "Print File" (p)
-  "Prompts for a file and prints it usings the program defined by
-   the hvar \"Print Utility\" with the options from the hvar \"Print
-   Utility Options\".  Errors appear in the echo area."
-  "Prints a file."
-  (declare (ignore p))
-  (let* ((pn (prompt-for-file :prompt "File to print: "
-			      :help "Name of file to print."
-			      :default (buffer-default-pathname (current-buffer))
-			      :must-exist t))
-	 (ns (namestring (truename pn))))
-    (message "Printing file...~%")
-    (print-something () (value print-utility)
-		     (append (value print-utility-switches) (list ns)))))
-
-
-;;;; Scribe.
-
-(defcommand "Scribe File" (p)
-  "Scribe a file with the default directory set to the directory of the
-   specified file.  The output from running Scribe is sent to the
-   \"Scribe Warnings\" buffer.  See \"Scribe Utility\" and \"Scribe Utility
-   Switches\"."
-  "Scribe a file with the default directory set to the directory of the
-   specified file."
-  (declare (ignore p))
-  (scribe-file (prompt-for-file :prompt "Scribe file: "
-				:default
-				(buffer-default-pathname (current-buffer)))))
-
-(defhvar "Scribe Buffer File Confirm"
-  "When set, \"Scribe Buffer File\" prompts for confirmation before doing
-   anything."
-  :value t)
-
-(defcommand "Scribe Buffer File" (p)
-  "Scribe the file associated with the current buffer.  The default directory
-   set to the directory of the file.  The output from running Scribe is sent to
-   the \"Scribe Warnings\" buffer.  See \"Scribe Utility\" and \"Scribe Utility
-   Switches\".  Before doing anything the user is asked to confirm saving and
-   Scribe'ing the file.  This prompting can be inhibited by with \"Scribe Buffer
-   File Confirm\"."
-  "Scribe a file with the default directory set to the directory of the
-   specified file."
-  (declare (ignore p))
-  (let* ((buffer (current-buffer))
-	 (pathname (buffer-pathname buffer))
-	 (modified (buffer-modified buffer)))
-    (when (or (not (value scribe-buffer-file-confirm))
-	      (prompt-for-y-or-n
-	       :default t :default-string "Y"
-	       :prompt (list "~:[S~;Save and s~]cribe file ~A? "
-			     modified (namestring pathname))))
-      (when modified (write-buffer-file buffer pathname))
-      (scribe-file pathname))))
-
-(defhvar "Scribe Utility"
-  "Program name to invoke (via EXT:RUN-PROGRAM) to do text formatting."
-  :value "scribe")
-
-(defhvar "Scribe Utility Switches"
-  "Switches to pass to the \"Scribe Utility\" program.  This should be a list
-   of strings."
-  :value ())
-
-(defun scribe-file (pathname)
-  (let* ((pathname (truename pathname))
-	 (out-buffer (or (getstring "Scribe Warnings" *buffer-names*)
-			 (make-buffer "Scribe Warnings")))
-	 (out-point (buffer-end (buffer-point out-buffer)))
-	 (stream (make-hemlock-output-stream out-point :line)))
-    (buffer-end out-point)
-    (insert-character out-point #\newline)
-    (insert-character out-point #\newline)
-    (ext:run-program (namestring (value scribe-utility))
-		     (list* (namestring pathname)
-			    (value scribe-utility-switches))
-     :output stream :error stream
-     :wait nil
-     :before-execve
-     #'(lambda ()
-	 (setf (default-directory) (directory-namestring pathname))))))
-
-
-
-;;;; UNIX Filter Region
-
-(defcommand "Unix Filter Region" (p)
-  "Unix Filter Region prompts for a UNIX program and then passes the current
-  region to the program as standard input.  The standard output from the
-  program is used to replace the region.  This command is undo-able."
-  "UNIX-FILTER-REGION-COMMAND is not intended to be called from normal
-  Hemlock commands; use UNIX-FILTER-REGION instead."
-  (declare (ignore p))
-  (let* ((region (current-region))
-	 (filter-and-args (prompt-for-string
-			   :prompt "Filter: "
-			   :help "Unix program to filter the region through."))
-	 (filter-and-args-list (listify-unix-filter-string filter-and-args))
-	 (filter (car filter-and-args-list))
-	 (args (cdr filter-and-args-list))
-	 (new-region (unix-filter-region region filter args))
-	 (start (copy-mark (region-start region) :right-inserting))
-	 (end (copy-mark (region-end region) :left-inserting))
-	 (old-region (region start end))
-	 (undo-region (delete-and-save-region old-region)))
-    (ninsert-region end new-region)
-    (make-region-undo :twiddle "Unix Filter Region" old-region undo-region)))
-
-(defun unix-filter-region (region command args)
-  "Passes the region REGION as standard input to the program COMMAND
-  with arguments ARGS and returns the standard output as a freshly
-  cons'ed region."
-  (let ((new-region (make-empty-region)))
-    (with-input-from-region (input region)
-      (with-output-to-mark (output (region-end new-region) :full)
-	(ext:run-program command args
-			 :input input
-			 :output output
-			 :error output)))
-    new-region))
-
-(defun listify-unix-filter-string (str)
-  (declare (simple-string str))
-  (let ((result nil)
-	(lastpos 0))
-    (loop
-      (let ((pos (position #\Space str :start lastpos :test #'char=)))
-	(push (subseq str lastpos pos) result)
-	(unless pos
-	  (return))
-	(setf lastpos (1+ pos))))
-    (nreverse result)))
-
-
-
-;;;; Man pages.
-
-(defcommand "Manual Page" (p)
-  "Read the Unix manual pages in a View buffer.
-   If given an argument, this will put the man page in a Pop-up display."
-  "Read the Unix manual pages in a View buffer.
-   If given an argument, this will put the man page in a Pop-up display."
-  (let ((topic (prompt-for-string :prompt "Man topic: ")))
-    (if p
-	(with-pop-up-display (stream)
-	  (execute-man topic stream))
-	(let* ((buf-name (format nil "Man Page ~a" topic))
-	       (new-buffer (make-buffer buf-name :modes '("Fundamental" "View")))
-	       (buffer (or new-buffer (getstring buf-name *buffer-names*)))
-	       (point (buffer-point buffer)))
-	  (change-to-buffer buffer)
-	  (when new-buffer
-	    (setf (value view-return-function) #'(lambda ()))
-	    (with-writable-buffer (buffer)
-	      (with-output-to-mark (s point :full)
-		(execute-man topic s))))
-	  (buffer-start point buffer)))))
-
-(defun execute-man (topic stream)
-  (ext:run-program
-   "/bin/sh"
-   (list "-c"
-	 (format nil "man ~a|cat -s|sed -e 's/_//g' -e 's/o//g'" topic))
-   :output stream))
diff --git a/hemlock/vars.lisp b/hemlock/vars.lisp
deleted file mode 100644
index 28e19d98066fc7c57712e8c748f08b33071a5a7b..0000000000000000000000000000000000000000
--- a/hemlock/vars.lisp
+++ /dev/null
@@ -1,304 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/vars.lisp,v 1.2 1991/02/08 16:39:06 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; The file contains the routines which define Hemlock variables.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(variable-value variable-hooks variable-documentation variable-name
-	  hemlock-bound-p defhvar delete-variable))
-
-(defstruct (binding
-	    (:type vector)
-	    (:copier nil)
-	    (:constructor make-binding (cons object across symbol)))
-  cons		; The cons which holds the value for the property.
-  object	; The variable-object for the binding.
-  across        ; The next binding in this place.
-  symbol)	; The symbol name for the variable bound.
-
-
-
-;;; UNDEFINED-VARIABLE-ERROR  --  Internal
-;;;
-;;;    Complain about an undefined Hemlock variable in a helpful fashion.
-;;;
-(defun undefined-variable-error (name)
-  (if (eq (symbol-package name) (find-package "HEMLOCK"))
-      (error "Undefined Hemlock variable ~A." name)
-      (error "Hemlock variables must be in the \"HEMLOCK\" package, but~%~
-	     ~S is in the ~S package."
-	     name (package-name (symbol-package name)))))
-
-;;; GET-MODE-OBJECT  --  Internal
-;;;
-;;;    Get the mode-object corresponding to name or die trying.
-;;;
-(defun get-mode-object (name)
-  (unless (stringp name) (error "Mode name ~S is not a string." name))
-  (let ((res (getstring name *mode-names*)))
-    (unless res (error "~S is not a defined mode." name))
-    res))
-
-;;; FIND-BINDING  --  Internal
-;;;
-;;;    Return the Binding object corresponding to Name in the collection
-;;; of binding Binding, or NIL if none.
-;;;
-(defun find-binding (name binding)
-  (do ((b binding (binding-across b)))
-      ((null b) nil)
-    (when (eq (binding-symbol b) name) (return b))))
-
-;;; GET-VARIABLE-OBJECT  --  Internal
-;;;
-;;;    Get the variable-object with the specified symbol-name, kind and where,
-;;; or die trying.
-;;;
-(defun get-variable-object (name kind where)
-  (case kind
-    (:current
-     (let ((obj (get name 'hemlock-variable-value)))
-       (if obj obj (undefined-variable-error name))))
-    (:buffer
-     (check-type where buffer)
-     (let ((binding (find-binding name (buffer-var-values where))))
-       (unless binding
-	 (error "~S is not a defined Hemlock variable in buffer ~S." name where))
-       (binding-object binding)))
-    (:global
-     (do ((obj (get name 'hemlock-variable-value)
-	       (variable-object-down obj))
-	  (prev nil obj))
-	 ((symbolp obj)
-	  (unless prev (undefined-variable-error name))
-	  (unless (eq obj :global)
-	    (error "Hemlock variable ~S is not globally defined." name))
-	  prev)))
-    (:mode
-     (let ((binding (find-binding name (mode-object-var-values
-					(get-mode-object where)))))
-       (unless binding
-	 (error "~S is not a defined Hemlock variable in mode ~S." name where))
-       (binding-object binding)))
-    (t
-     (error "~S is not a defined value for Kind." kind))))
-
-;;; VARIABLE-VALUE  --  Public
-;;;
-;;;    Get the value of the Hemlock variable "name".
-;;;
-(defun variable-value (name &optional (kind :current) where)
-  "Return the value of the Hemlock variable given."
-  (variable-object-value (get-variable-object name kind where)))
-
-;;; %VALUE  --  Internal
-;;;
-;;;    This function is called by the expansion of Value.
-;;;
-(defun %value (name)
-  (let ((obj (get name 'hemlock-variable-value)))
-    (unless obj (undefined-variable-error name))
-    (variable-object-value obj)))
-
-;;; %SET-VALUE  --  Internal
-;;;
-;;;    The setf-inverse of Value, set the current value.
-;;;
-(defun %set-value (var new-value)
-  (let ((obj (get var 'hemlock-variable-value)))
-    (unless obj (undefined-variable-error var))
-    (invoke-hook (variable-object-hooks obj) var :current nil new-value)
-    (setf (variable-object-value obj) new-value)))
-
-;;; %SET-VARIABLE-VALUE  --  Internal
-;;;
-;;;   Set the Hemlock variable with the symbol name "name".
-;;;
-(defun %set-variable-value (name kind where new-value)
-  (let ((obj (get-variable-object name kind where)))
-    (invoke-hook (variable-object-hooks obj) name kind where new-value)
-    (setf (variable-object-value obj) new-value)))
-
-;;; VARIABLE-HOOKS  --  Public
-;;;
-;;;    Return the list of hooks for "name".
-;;;
-(defun variable-hooks (name &optional (kind :current) where)
-  "Return the list of hook functions for the Hemlock variable given."
-  (variable-object-hooks (get-variable-object name kind where)))
-
-;;; %SET-VARIABLE-HOOKS --  Internal
-;;;
-;;;    Set the hook-list for Hemlock variable Name.
-;;;
-(defun %set-variable-hooks (name kind where new-value)
-  (setf (variable-object-hooks (get-variable-object name kind where)) new-value))
-
-;;; VARIABLE-DOCUMENTATION  --  Public
-;;;
-;;;    Return the documentation for "name".
-;;;
-(defun variable-documentation (name &optional (kind :current) where)
-  "Return the documentation for the Hemlock variable given."
-  (variable-object-documentation (get-variable-object name kind where)))
-
-;;; %SET-VARIABLE-DOCUMENTATION  --  Internal
-;;;
-;;;    Set a variables documentation.
-;;;
-(defun %set-variable-documentation (name kind where new-value)
-  (setf (variable-object-documentation (get-variable-object name kind where))
-	new-value))
-
-;;; VARIABLE-NAME  --  Public
-;;;
-;;;    Return the String Name for a Hemlock variable.
-;;;
-(defun variable-name (name &optional (kind :current) where)
-   "Return the string name of a Hemlock variable."
-  (variable-object-name (get-variable-object name kind where)))
-
-;;; HEMLOCK-BOUND-P  --  Public
-;;;
-(defun hemlock-bound-p (name &optional (kind :current) where)
-  "Returns T Name is a Hemlock variable defined in the specifed place, or
-  NIL otherwise."
-  (case kind
-    (:current (not (null (get name 'hemlock-variable-value))))
-    (:buffer
-     (check-type where buffer)
-     (not (null (find-binding name (buffer-var-values where)))))
-    (:global
-     (do ((obj (get name 'hemlock-variable-value)
-	       (variable-object-down obj)))
-	 ((symbolp obj) (eq obj :global))))
-    (:mode
-     (not (null (find-binding name (mode-object-var-values
-				    (get-mode-object where))))))))
-
-(defun string-to-variable (string)
-  "Returns the symbol name of a Hemlock variable from the corresponding string
-   name."
-  (intern (nsubstitute #\- #\space (the simple-string (string-upcase string)))
-	  (find-package "HEMLOCK")))
-
-(proclaim '(special *global-variable-names*))
-
-;;; DEFHVAR  --  Public
-;;;
-;;;    Define a Hemlock variable somewhere.
-;;;
-(defun defhvar (name documentation &key mode buffer (hooks nil hook-p)
-		     (value nil value-p))
-  (let* ((symbol-name (string-to-variable name))
-	 (new-binding (make-variable-object documentation name))
-	 (plist (symbol-plist symbol-name))
-	 (prop (cdr (or (memq 'hemlock-variable-value plist)
-			(setf (symbol-plist symbol-name)
-			      (list* 'hemlock-variable-value nil plist)))))
-	 (kind :global) where string-table)
-    (cond
-      (mode
-       (setq kind :mode  where mode)
-       (let* ((obj (get-mode-object where))
-	      (vars (mode-object-var-values obj)))
-	 (setq string-table (mode-object-variables obj))
-	 (unless (find-binding symbol-name vars)
-	   (let ((binding (make-binding prop new-binding vars symbol-name)))
-	     (cond ((memq obj (buffer-mode-objects *current-buffer*))
-		    (let ((l (unwind-bindings obj)))
-		      (setf (mode-object-var-values obj) binding)
-		      (wind-bindings l)))
-		   (t
-		    (setf (mode-object-var-values obj) binding)))))))
-      (buffer
-       (check-type buffer buffer)
-       (setq kind :buffer  where buffer  string-table (buffer-variables buffer))
-       (let ((vars (buffer-var-values buffer)))
-	 (unless (find-binding symbol-name vars)
-	   (let ((binding (make-binding prop new-binding vars symbol-name)))
-	     (setf (buffer-var-values buffer) binding)
-	     (when (eq buffer *current-buffer*)
-	       (setf (variable-object-down new-binding) (car prop)
-		     (car prop) new-binding))))))
-      (t
-       (setq string-table *global-variable-names*)
-       (unless (hemlock-bound-p symbol-name :global)
-	 (setf (variable-object-down new-binding) :global)
-	 (let ((l (unwind-bindings nil)))
-	   (setf (car prop) new-binding)
-	   (wind-bindings l)))))
-    (setf (getstring name string-table) symbol-name)
-    (when hook-p
-      (setf (variable-hooks symbol-name kind where) hooks))
-    (when value-p
-      (setf (variable-value symbol-name kind where) value)))
-  name)
-
-;;; DELETE-BINDING  --  Internal
-;;;
-;;;    Delete a binding from a list of bindings.
-;;;
-(defun delete-binding (binding bindings)
-  (do ((b bindings (binding-across b))
-       (prev nil b))
-      ((eq b binding)
-       (cond (prev
-	      (setf (binding-across prev) (binding-across b))
-	      bindings)
-	     (t
-	      (binding-across bindings))))))
-
-;;; DELETE-VARIABLE  --  Public
-;;;
-;;; Make a Hemlock variable no longer bound, fixing up the saved
-;;;binding values as necessary.
-;;;
-(defun delete-variable (name &optional (kind :global) where)
-  "Delete a Hemlock variable somewhere."
-  (let* ((obj (get-variable-object name kind where))
-	 (sname (variable-object-name obj)))
-    (case kind
-      (:buffer
-       (let* ((values (buffer-var-values where))
-	      (binding (find-binding name values)))
-	 (invoke-hook ed::delete-variable-hook name :buffer where)
-	 (delete-string sname (buffer-variables where))
-	 (setf (buffer-var-values where) (delete-binding binding values))
-	 (when (eq where *current-buffer*)
-	   (setf (car (binding-cons binding)) (variable-object-down obj)))))
-      (:mode
-       (let* ((mode (get-mode-object where))
-	      (values (mode-object-var-values mode))
-	      (binding (find-binding name values)))
-	 (invoke-hook ed::delete-variable-hook name :mode where)
-	 (delete-string sname (mode-object-variables mode))
-	 (if (memq mode (buffer-mode-objects *current-buffer*))
-	     (let ((l (unwind-bindings mode)))
-	       (setf (mode-object-var-values mode)
-		     (delete-binding binding values))
-	       (wind-bindings l))
-	     (setf (mode-object-var-values mode)
-		   (delete-binding binding values)))))
-      (:global
-       (invoke-hook ed::delete-variable-hook name :global nil)
-       (delete-string sname *global-variable-names*)
-       (let ((l (unwind-bindings nil)))
-	 (setf (get name 'hemlock-variable-value) nil)
-	 (wind-bindings l)))
-      (t (error "Invalid variable kind: ~S" kind)))
-    nil))
diff --git a/hemlock/window.lisp b/hemlock/window.lisp
deleted file mode 100644
index 1324c78718d401280f8b3a37e04457ce51965c71..0000000000000000000000000000000000000000
--- a/hemlock/window.lisp
+++ /dev/null
@@ -1,679 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/window.lisp,v 1.3 1991/10/04 12:01:46 chiles Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    This file contains implementation independent code which implements
-;;; the Hemlock window primitives and most of the code which defines
-;;; other aspects of the interface to redisplay.
-;;;
-;;; Written by Bill Chiles and Rob MacLachlan.
-;;;
-
-(in-package "HEMLOCK-INTERNALS")
-
-(export '(current-window window-buffer modeline-field-width
-	  modeline-field-function make-modeline-field update-modeline-fields
-	  update-modeline-field modeline-field-name modeline-field
-	  editor-finish-output *window-list*))
-
-
-
-;;;; CURRENT-WINDOW.
-
-(defvar *current-window* nil "The current window object.")
-(defvar *window-list* () "A list of all window objects.")
-
-(proclaim '(inline current-window))
-
-(defun current-window ()
-  "Return the current window.  The current window is specially treated by
-  redisplay in several ways, the most important of which is that is does
-  recentering, ensuring that the Buffer-Point of the current window's
-  Window-Buffer is always displayed.  This may be set with Setf."
-  *current-window*)
-
-(defun %set-current-window (new-window)
-  (invoke-hook ed::set-window-hook new-window)
-  (move-mark (window-point *current-window*)
-	     (buffer-point (window-buffer *current-window*)))
-  (move-mark (buffer-point (window-buffer new-window))
-	     (window-point new-window))
-  (setq *current-window* new-window))
-
-
-
-;;;; Window structure support.
-
-(defun %print-hwindow (obj stream depth)
-  (declare (ignore depth))
-  (write-string "#<Hemlock Window \"" stream)
-  (write-string (buffer-name (window-buffer obj)) stream)
-  (write-string "\">" stream))
-
-
-(defun window-buffer (window)
-  "Return the buffer which is displayed in Window."
-  (window-%buffer window))
-
-(defun %set-window-buffer (window new-buffer)
-  (unless (bufferp new-buffer) (error "~S is not a buffer." new-buffer))
-  (unless (windowp window) (error "~S is not a window." window))
-  (unless (eq new-buffer (window-buffer window))
-    (invoke-hook ed::window-buffer-hook window new-buffer)
-    ;;
-    ;; Move the window's marks to the new start.
-    (let ((buffer (window-buffer window)))
-      (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))
-      (move-mark (buffer-display-start buffer) (window-display-start window))
-      (push window (buffer-windows new-buffer))
-      (move-mark (window-point window) (buffer-point new-buffer))
-      (move-mark (window-display-start window) (buffer-display-start new-buffer))
-      (move-mark (window-display-end window) (buffer-display-start new-buffer)))
-    ;;
-    ;; Delete all the dis-lines, and nil out the line and chars so they get
-    ;; gc'ed.
-    (let ((first (window-first-line window))
-	  (last (window-last-line window))
-	  (free (window-spare-lines window)))
-      (unless (eq (cdr first) the-sentinel)
-	(shiftf (cdr last) free (cdr first) the-sentinel))
-      (dolist (dl free)
-	(setf (dis-line-line dl) nil  (dis-line-old-chars dl) nil))
-      (setf (window-spare-lines window) free))
-    ;;
-    ;; Set the last line and first&last changed so we know there's nothing there.
-    (setf (window-last-line window) the-sentinel
-	  (window-first-changed window) the-sentinel
-	  (window-last-changed window) the-sentinel)
-    ;;
-    ;; Make sure the window gets updated, and set the buffer.
-    (setf (window-tick window) -3)
-    (setf (window-%buffer window) new-buffer)))
-
-
-
-;;; %INIT-REDISPLAY sets up redisplay's internal data structures.  We create
-;;; initial windows, setup some hooks to cause modeline recomputation, and call
-;;; any device init necessary.  This is called from ED.
-;;;
-(defun %init-redisplay (display)
-  (%init-screen-manager display)
-  (add-hook ed::buffer-major-mode-hook 'queue-buffer-change)
-  (add-hook ed::buffer-minor-mode-hook 'queue-buffer-change)
-  (add-hook ed::buffer-name-hook 'queue-buffer-change)
-  (add-hook ed::buffer-pathname-hook 'queue-buffer-change)
-  (add-hook ed::buffer-modified-hook 'queue-buffer-change)
-  (add-hook ed::window-buffer-hook 'queue-window-change)
-  (let ((device (device-hunk-device (window-hunk (current-window)))))
-    (funcall (device-init device) device))
-  (center-window *current-window* (current-point)))
-
-
-
-;;;; Modelines-field structure support.
-
-(defun print-modeline-field (obj stream ignore)
-  (declare (ignore ignore))
-  (write-string "#<Hemlock Modeline-field " stream)
-  (prin1 (modeline-field-%name obj) stream)
-  (write-string ">" stream))
-
-(defun print-modeline-field-info (obj stream ignore)
-  (declare (ignore ignore))
-  (write-string "#<Hemlock Modeline-field-info " stream)
-  (prin1 (modeline-field-%name (ml-field-info-field obj)) stream)
-  (write-string ">" stream))
-
-
-(defvar *modeline-field-names* (make-hash-table))
-
-(defun make-modeline-field (&key name width function)
-  "Returns a modeline-field object."
-  (unless (or (eq width nil) (and (integerp width) (plusp width)))
-    (error "Width must be nil or a positive integer."))
-  (when (gethash name *modeline-field-names*)
-    (with-simple-restart (continue
-			  "Use the new definition for this modeline field.")
-      (error "Modeline field ~S already exists."
-	     (gethash name *modeline-field-names*))))
-  (setf (gethash name *modeline-field-names*)
-	(%make-modeline-field name function width)))
-
-(defun modeline-field (name)
-  "Returns the modeline-field object named name.  If none exists, return nil."
-  (gethash name *modeline-field-names*))
-
-
-(proclaim '(inline modeline-field-name modeline-field-width
-		   modeline-field-function))
-
-(defun modeline-field-name (ml-field)
-  "Returns the name of a modeline field object."
-  (modeline-field-%name ml-field))
-
-(defun %set-modeline-field-name (ml-field name)
-  (check-type ml-field modeline-field)
-  (when (gethash name *modeline-field-names*)
-    (error "Modeline field ~S already exists."
-	   (gethash name *modeline-field-names*)))
-  (remhash (modeline-field-%name ml-field) *modeline-field-names*)
-  (setf (modeline-field-%name ml-field) name)
-  (setf (gethash name *modeline-field-names*) ml-field))
-
-(defun modeline-field-width (ml-field)
-  "Returns the width of a modeline field."
-  (modeline-field-%width ml-field))
-
-(proclaim '(special *buffer-list*))
-
-(defun %set-modeline-field-width (ml-field width)
-  (check-type ml-field modeline-field)
-  (unless (or (eq width nil) (and (integerp width) (plusp width)))
-    (error "Width must be nil or a positive integer."))
-  (unless (eql width (modeline-field-%width ml-field))
-    (setf (modeline-field-%width ml-field) width)
-    (dolist (b *buffer-list*)
-      (when (buffer-modeline-field-p b ml-field)
-	(dolist (w (buffer-windows b))
-	  (update-modeline-fields b w)))))
-  width)
-  
-(defun modeline-field-function (ml-field)
-  "Returns the function of a modeline field object.  It returns a string."
-  (modeline-field-%function ml-field))
-
-(defun %set-modeline-field-function (ml-field function)
-  (check-type ml-field modeline-field)
-  (check-type function (or symbol function))
-  (setf (modeline-field-%function ml-field) function)
-  (dolist (b *buffer-list*)
-    (when (buffer-modeline-field-p b ml-field)
-      (dolist (w (buffer-windows b))
-	(update-modeline-field b w ml-field))))
-  function)
-
-
-
-;;;; Modelines maintenance.
-
-;;; Each window stores a modeline-buffer which is a string hunk-width-limit
-;;; long.  Whenever a field is updated, we must maintain a maximally long
-;;; representation of the modeline in case the window is resized.  Updating
-;;; then first gets the modeline-buffer setup, and second blasts the necessary
-;;; portion into the window's modeline-dis-line, setting the dis-line's changed
-;;; flag.
-;;;
-
-(defun update-modeline-fields (buffer window)
-  "Recompute all the fields of buffer's modeline for window, so the next
-   redisplay will reflect changes."
-  (let ((ml-buffer (window-modeline-buffer window)))
-    (declare (simple-string ml-buffer))
-    (when ml-buffer
-      (let* ((ml-buffer-len
-	      (do ((finfos (buffer-%modeline-fields buffer) (cdr finfos))
-		   (start 0 (blt-modeline-field-buffer
-			     ml-buffer (car finfos) buffer window start)))
-		  ((null finfos) start)))
-	     (dis-line (window-modeline-dis-line window))
-	     (len (min (window-width window) ml-buffer-len)))
-	(replace (the simple-string (dis-line-chars dis-line)) ml-buffer
-		 :end1 len :end2 len)
-	(setf (window-modeline-buffer-len window) ml-buffer-len)
-	(setf (dis-line-length dis-line) len)
-	(setf (dis-line-flags dis-line) changed-bit)))))
-
-;;; UPDATE-MODELINE-FIELD must replace the entire dis-line-chars with ml-buffer
-;;; after blt'ing into buffer.  Otherwise it has to do all the work
-;;; BLT-MODELINE-FIELD-BUFFER to figure out how to adjust dis-line-chars.  It
-;;; isn't worth it.  Since things could have shifted around, after calling
-;;; BLT-MODELINE-FIELD-BUFFER, we get the last field's end to know how long
-;;; the buffer is now.
-;;;
-(defun update-modeline-field (buffer window field)
-  "Recompute the field of the buffer's modeline for window, so the next
-   redisplay will reflect the change.  Field is either a modeline-field object
-   or the name of one for buffer."
-  (let ((finfo (internal-buffer-modeline-field-p buffer field)))
-    (unless finfo
-      (error "~S is not a modeline-field or the name of one for buffer ~S."
-	     field buffer))
-    (let ((ml-buffer (window-modeline-buffer window))
-	  (dis-line (window-modeline-dis-line window)))
-      (declare (simple-string ml-buffer))
-      (blt-modeline-field-buffer ml-buffer finfo buffer window
-				 (ml-field-info-start finfo) t)
-      (let* ((ml-buffer-len (ml-field-info-end
-			     (car (last (buffer-%modeline-fields buffer)))))
-	     (dis-len (min (window-width window) ml-buffer-len)))
-	(replace (the simple-string (dis-line-chars dis-line)) ml-buffer
-		 :end1 dis-len :end2 dis-len)
-	(setf (window-modeline-buffer-len window) ml-buffer-len)
-	(setf (dis-line-length dis-line) dis-len)
-	(setf (dis-line-flags dis-line) changed-bit)))))
-
-(defvar *truncated-field-char* #\!)
-
-;;; BLT-MODELINE-FIELD-BUFFER takes a Hemlock buffer, Hemlock window, the
-;;; window's modeline buffer, a modeline-field-info object, a start in the
-;;; modeline buffer, and an optional indicating whether a variable width field
-;;; should be handled carefully.  When the field is fixed-width, this is
-;;; simple.  When it is variable, we possibly have to shift all the text in the
-;;; buffer right or left before storing the new string, updating all the
-;;; finfo's after the one we're updating.  It is an error for the
-;;; modeline-field-function to return anything but a simple-string with
-;;; standard-chars.  This returns the end of the field blasted into ml-buffer.
-;;;
-(defun blt-modeline-field-buffer (ml-buffer finfo buffer window start
-					    &optional fix-other-fields-p)
-  (declare (simple-string ml-buffer))
-  (let* ((f (ml-field-info-field finfo))
-	 (width (modeline-field-width f))
-	 (string (funcall (modeline-field-function f) buffer window))
-	 (str-len (length string)))
-    (declare (simple-string string))
-    (setf (ml-field-info-start finfo) start)
-    (setf (ml-field-info-end finfo)
-	  (cond
-	   ((not width)
-	    (let ((end (min (+ start str-len) hunk-width-limit))
-		  (last-end (ml-field-info-end finfo)))
-	      (when (and fix-other-fields-p (/= end last-end))
-		(blt-ml-field-buffer-fix ml-buffer finfo buffer window
-					 end last-end))
-	      (replace ml-buffer string :start1 start :end1 end :end2 str-len)
-	      end))
-	   ((= str-len width)
-	    (let ((end (min (+ start width) hunk-width-limit)))
-	      (replace ml-buffer string :start1 start :end1 end :end2 width)
-	      end))
-	   ((> str-len width)
-	    (let* ((end (min (+ start width) hunk-width-limit))
-		   (end-1 (1- end)))
-	      (replace ml-buffer string :start1 start :end1 end-1 :end2 width)
-	      (setf (schar ml-buffer end-1) *truncated-field-char*)
-	      end))
-	   (t
-	    (let ((buf-replace-end (min (+ start str-len) hunk-width-limit))
-		  (buf-field-end (min (+ start width) hunk-width-limit)))
-	      (replace ml-buffer string
-		       :start1 start :end1 buf-replace-end :end2 str-len)
-	      (fill ml-buffer #\space :start buf-replace-end :end buf-field-end)
-	      buf-field-end))))))
-
-;;; BLT-ML-FIELD-BUFFER-FIX shifts the contents of ml-buffer in the direction
-;;; of last-end to end.  finfo is a modeline-field-info structure in buffer's
-;;; list of these.  If there are none following finfo, then we simply store the
-;;; new end of the buffer.  After blt'ing the text around, we have to update
-;;; all the finfos' starts and ends making sure nobody gets to stick out over
-;;; the ml-buffer's end.
-;;;
-(defun blt-ml-field-buffer-fix (ml-buffer finfo buffer window end last-end)
-  (declare (simple-string ml-buffer))
-  (let ((finfos (do ((f (buffer-%modeline-fields buffer) (cdr f)))
-		    ((null f) (error "This field must be here."))
-		  (if (eq (car f) finfo)
-		      (return (cdr f))))))
-    (cond
-     ((not finfos)
-      (setf (window-modeline-buffer-len window) (min end hunk-width-limit)))
-     (t
-      (let ((buffer-len (window-modeline-buffer-len window)))
-	(replace ml-buffer ml-buffer
-		 :start1 end
-		 :end1 (min (+ end (- buffer-len last-end)) hunk-width-limit)
-		 :start2 last-end :end2 buffer-len)
-	(let ((diff (- end last-end)))
-	  (macrolet ((frob (f)
-		       `(setf ,f (min (+ ,f diff) hunk-width-limit))))
-	    (dolist (f finfos)
-	      (frob (ml-field-info-start f))
-	      (frob (ml-field-info-end f)))
-	    (frob (window-modeline-buffer-len window)))))))))
-
-
-
-;;;; Default modeline and update hooks.
-
-(make-modeline-field :name :hemlock-literal :width 8
-		     :function #'(lambda (buffer window)
-				   "Returns \"Hemlock \"."
-				   (declare (ignore buffer window))
-				   "Hemlock "))
-
-(make-modeline-field
- :name :package
- :function #'(lambda (buffer window)
-	       "Returns the value of buffer's \"Current Package\" followed
-		by a colon and two spaces, or a string with one space."
-	       (declare (ignore window))
-	       (if (hemlock-bound-p 'ed::current-package :buffer buffer)
-		   (let ((val (variable-value 'ed::current-package
-					      :buffer buffer)))
-		     (if val
-			 (format nil "~A:  " val)
-			 " "))
-		   " ")))
-
-(make-modeline-field
- :name :modes
- :function #'(lambda (buffer window)
-	       "Returns buffer's modes followed by one space."
-	       (declare (ignore window))
-	       (format nil "~A  " (buffer-modes buffer))))
-
-(make-modeline-field
- :name :modifiedp
- :function #'(lambda (buffer window)
-	       "Returns \"* \" if buffer is modified, or the empty string."
-	       (declare (ignore window))
-	       (let ((modifiedp (buffer-modified buffer)))
-		 (if modifiedp
-		     "* "
-		     ""))))
-
-(make-modeline-field
- :name :buffer-name
- :function #'(lambda (buffer window)
-	       "Returns buffer's name followed by a colon and a space if the
-		name is not derived from the buffer's pathname, or the empty
-		string."
-	       (declare (ignore window))
-	       (let ((pn (buffer-pathname buffer))
-		     (name (buffer-name buffer)))
-		 (cond ((not pn)
-			(format nil "~A: " name))
-		       ((string/= (ed::pathname-to-buffer-name pn) name)
-			(format nil "~A: " name))
-		       (t "")))))
-
-
-;;; MAXIMUM-MODELINE-PATHNAME-LENGTH-HOOK is called whenever "Maximum Modeline
-;;; Pathname Length" is set.
-;;;
-(defun maximum-modeline-pathname-length-hook (name kind where new-value)
-  (declare (ignore name new-value))
-  (if (eq kind :buffer)
-      (hi::queue-buffer-change where)
-      (dolist (buffer *buffer-list*)
-	(when (and (buffer-modeline-field-p buffer :buffer-pathname)
-		   (buffer-windows buffer))
-	  (hi::queue-buffer-change buffer)))))
-
-(defun buffer-pathname-ml-field-fun (buffer window)
-  "Returns the namestring of buffer's pathname if there is one.  When
-   \"Maximum Modeline Pathname Length\" is set, and the namestring is too long,
-   return a truncated namestring chopping off leading directory specifications."
-  (declare (ignore window))
-  (let ((pn (buffer-pathname buffer)))
-    (if pn
-	(let* ((name (namestring pn))
-	       (length (length name))
-	       ;; Prefer a buffer local value over the global one.
-	       ;; Because variables don't work right, blow off looking for
-	       ;; a value in the buffer's modes.  In the future this will
-	       ;; be able to get the "current" value as if buffer were current.
-	       (max (if (hemlock-bound-p 'ed::maximum-modeline-pathname-length
-					  :buffer buffer)
-			 (variable-value 'ed::maximum-modeline-pathname-length
-					 :buffer buffer)
-			 (variable-value 'ed::maximum-modeline-pathname-length
-					 :global))))
-	  (declare (simple-string name))
-	  (if (or (not max) (<= length max))
-	      name
-	      (let* ((extra-chars (+ (- length max) 3))
-		     (slash (or (position #\/ name :start extra-chars)
-				;; If no slash, then file-namestring is very
-				;; long, and we should include all of it:
-				(position #\/ name :from-end t
-					  :end extra-chars))))
-		(if slash
-		    (concatenate 'simple-string "..." (subseq name slash))
-		    name))))
-	"")))
-
-(make-modeline-field
- :name :buffer-pathname
- :function 'buffer-pathname-ml-field-fun)
-
-
-(defvar *default-modeline-fields*
-  (list (modeline-field :hemlock-literal)
-	(modeline-field :package)
-	(modeline-field :modes)
-	(modeline-field :modifiedp)
-	(modeline-field :buffer-name)
-	(modeline-field :buffer-pathname))
-  "This is the default value for \"Default Modeline Fields\".")
-
-
-
-;;; QUEUE-BUFFER-CHANGE is used for various buffer hooks (e.g., mode changes,
-;;; name changes, etc.), so it takes some arguments to ignore.  These hooks are
-;;; invoked at a bad time to update the actual modeline-field, and user's may
-;;; have fields that change as a function of the changes this function handles.
-;;; This makes his update easier.  It doesn't cost much update the entire line
-;;; anyway.
-;;;
-(defun queue-buffer-change (buffer &optional something-else another-else)
-  (declare (ignore something-else another-else))
-  (push (list #'update-modelines-for-buffer buffer) *things-to-do-once*))
-
-(defun update-modelines-for-buffer (buffer)
-  (unless (eq buffer *echo-area-buffer*)
-    (dolist (w (buffer-windows buffer))
-      (update-modeline-fields buffer w))))
-
-
-;;; QUEUE-WINDOW-CHANGE is used for the "Window Buffer Hook".  We ignore the
-;;; argument since this hook function is invoked before any changes are made,
-;;; and the changes must be made before the fields can be set according to the
-;;; window's buffer's properties.  Therefore, we must queue the change to
-;;; happen sometime before redisplay but after the change takes effect.
-;;;
-(defun queue-window-change (window &optional something-else)
-  (declare (ignore something-else))
-  (push (list #'update-modeline-for-window window) *things-to-do-once*))
-
-(defun update-modeline-for-window (window)
-  (update-modeline-fields (window-buffer window) window))
-
-  
-
-;;;; Bitmap setting up new windows and modifying old.
-
-(defvar dummy-line (make-window-dis-line "")
-  "Dummy dis-line that we put at the head of window's dis-lines")
-(setf (dis-line-position dummy-line) -1)
-
-
-;;; WINDOW-FOR-HUNK makes a Hemlock window and sets up its dis-lines and marks
-;;; to display starting at start.
-;;;
-(defun window-for-hunk (hunk start modelinep)
-  (check-type start mark)
-  (setf (bitmap-hunk-changed-handler hunk) #'window-changed)
-  (let ((buffer (line-buffer (mark-line start)))
-	(first (cons dummy-line the-sentinel))
-	(width (bitmap-hunk-char-width hunk))
-	(height (bitmap-hunk-char-height hunk)))
-    (when (or (< height minimum-window-lines)
-	      (< width minimum-window-columns))
-      (error "Window too small."))
-    (unless buffer (error "Window start is not in a buffer."))
-    (let ((window
-	   (internal-make-window
-	    :hunk hunk
-	    :display-start (copy-mark start :right-inserting)
-	    :old-start (copy-mark start :temporary)
-	    :display-end (copy-mark start :right-inserting)
-	    :%buffer buffer
-	    :point (copy-mark (buffer-point buffer))
-	    :height height
-	    :width width
-	    :first-line first
-	    :last-line the-sentinel
-	    :first-changed the-sentinel
-	    :last-changed first
-	    :tick -1)))
-      (push window *window-list*)
-      (push window (buffer-windows buffer))
-      ;;
-      ;; Make the dis-lines.
-      (do ((i (- height) (1+ i))
-	   (res ()
-		(cons (make-window-dis-line (make-string width)) res)))
-	  ((= i height) (setf (window-spare-lines window) res)))
-      ;;
-      ;; Make the image up to date.
-      (update-window-image window)
-      (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))
-      ;;
-      ;; If there is a modeline, set it up.
-      (when modelinep
-	(setup-modeline-image buffer window)
-	(setf (bitmap-hunk-modeline-dis-line hunk)
-	      (window-modeline-dis-line window)))
-      window)))
-
-;;; SETUP-MODELINE-IMAGE sets up the modeline-dis-line for window using the
-;;; modeline-fields list.  This is used by tty redisplay too.
-;;;
-(defun setup-modeline-image (buffer window)
-  (setf (window-modeline-buffer window) (make-string hunk-width-limit))
-  (setf (window-modeline-dis-line window)
-	(make-window-dis-line (make-string (window-width window))))
-  (update-modeline-fields buffer window))
-
-;;; Window-Changed  --  Internal
-;;;
-;;;    The bitmap-hunk changed handler for windows.  This is only called if
-;;; the hunk is not locked.  We invalidate the window image and change its
-;;; size, then do a full redisplay.
-;;;
-(defun window-changed (hunk)
-  (let ((window (bitmap-hunk-window hunk)))
-    ;;
-    ;; Nuke all the lines in the window image.
-    (unless (eq (cdr (window-first-line window)) the-sentinel)
-      (shiftf (cdr (window-last-line window))
-	      (window-spare-lines window)
-	      (cdr (window-first-line window))
-	      the-sentinel))
-    (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))
-    ;;
-    ;; Add some new spare lines if needed.  If width is greater,
-    ;; reallocate the dis-line-chars.
-    (let* ((res (window-spare-lines window))
-	   (new-width (bitmap-hunk-char-width hunk))
-	   (new-height (bitmap-hunk-char-height hunk))
-	   (width (length (the simple-string (dis-line-chars (car res))))))
-      (declare (list res))
-      (when (> new-width width)
-	(setq width new-width)
-	(dolist (dl res)
-	  (setf (dis-line-chars dl) (make-string new-width))))
-      (setf (window-height window) new-height (window-width window) new-width)
-      (do ((i (- (* new-height 2) (length res)) (1- i)))
-	  ((minusp i))
-	(push (make-window-dis-line (make-string width)) res))
-      (setf (window-spare-lines window) res)
-      ;;
-      ;; Force modeline update.
-      (let ((ml-buffer (window-modeline-buffer window)))
-	(when ml-buffer
-	  (let ((dl (window-modeline-dis-line window))
-		(chars (make-string new-width))
-		(len (min new-width (window-modeline-buffer-len window))))
-	    (setf (dis-line-old-chars dl) nil)
-	    (setf (dis-line-chars dl) chars)
-	    (replace chars ml-buffer :end1 len :end2 len)
-	    (setf (dis-line-length dl) len)
-	    (setf (dis-line-flags dl) changed-bit)))))
-    ;;
-    ;; Prepare for redisplay.
-    (setf (window-tick window) (tick))
-    (update-window-image window)
-    (when (eq window *current-window*) (maybe-recenter-window window))
-    hunk))
-
-
-
-;;; EDITOR-FINISH-OUTPUT is used to synch output to a window with the rest of the
-;;; system.
-;;; 
-(defun editor-finish-output (window)
-  (let* ((device (device-hunk-device (window-hunk window)))
-	 (finish-output (device-finish-output device)))
-    (when finish-output
-      (funcall finish-output device window))))
-
-
-
-;;;; Tty setting up new windows and modifying old.
-
-;;; setup-window-image  --  Internal
-;;;
-;;;    Set up the dis-lines and marks for Window to display starting
-;;; at Start.  Height and Width are the number of lines and columns in 
-;;; the window.
-;;;
-(defun setup-window-image (start window height width)
-  (check-type start mark)
-  (let ((buffer (line-buffer (mark-line start)))
-	(first (cons dummy-line the-sentinel)))
-    (unless buffer (error "Window start is not in a buffer."))
-    (setf (window-display-start window) (copy-mark start :right-inserting)
-	  (window-old-start window) (copy-mark start :temporary)
-	  (window-display-end window) (copy-mark start :right-inserting)
-	  (window-%buffer window) buffer
-	  (window-point window) (copy-mark (buffer-point buffer))
-	  (window-height window) height
-	  (window-width window) width
-	  (window-first-line window) first
-	  (window-last-line window) the-sentinel
-	  (window-first-changed window) the-sentinel
-	  (window-last-changed window) first
-	  (window-tick window) -1)
-    (push window *window-list*)
-    (push window (buffer-windows buffer))
-    ;;
-    ;; Make the dis-lines.
-    (do ((i (- height) (1+ i))
-	 (res ()
-	      (cons (make-window-dis-line (make-string width)) res)))
-	((= i height) (setf (window-spare-lines window) res)))
-    ;;
-    ;; Make the image up to date.
-    (update-window-image window)))
-
-;;; change-window-image-height  --  Internal
-;;;
-;;;    Milkshake.
-;;;
-(defun change-window-image-height (window new-height)
-  ;; Nuke all the lines in the window image.
-  (unless (eq (cdr (window-first-line window)) the-sentinel)
-    (shiftf (cdr (window-last-line window))
-	    (window-spare-lines window)
-	    (cdr (window-first-line window))
-	    the-sentinel))
-  ;; Add some new spare lines if needed.
-  (let* ((res (window-spare-lines window))
-	 (width (length (the simple-string (dis-line-chars (car res))))))
-    (declare (list res))
-    (setf (window-height window) new-height)
-    (do ((i (- (* new-height 2) (length res)) (1- i)))
-	((minusp i))
-      (push (make-window-dis-line (make-string width)) res))
-    (setf (window-spare-lines window) res)))
diff --git a/hemlock/winimage.lisp b/hemlock/winimage.lisp
deleted file mode 100644
index e0f378846453efda1baf23551b0ed1ab3170e21d..0000000000000000000000000000000000000000
--- a/hemlock/winimage.lisp
+++ /dev/null
@@ -1,335 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/winimage.lisp,v 1.2 1991/02/08 16:39:13 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Rob MacLachlan
-;;;
-;;; This file contains implementation independant functions that
-;;; build window images from the buffer structure.
-;;;
-(in-package "HEMLOCK-INTERNALS")
-
-(defvar the-sentinel
-  (list (make-window-dis-line ""))
-  "This dis-line, which has several interesting properties, is used to end
-  lists of dis-lines.")
-(setf (dis-line-line (car the-sentinel))
-      (make-line :number most-positive-fixnum :chars ""))
-(setf (dis-line-position (car the-sentinel)) most-positive-fixnum)
-(setf (dis-line-old-chars (car the-sentinel)) :unique-thing))
-
-
-(defconstant unaltered-bits #b000
-  "This is the value of the dis-line-flags when a line is neither moved nor
-  changed nor new.")
-(defconstant changed-bit #b001
-  "This bit is set in the dis-line-flags when a line is found to be changed.")
-(defconstant moved-bit #b010
-  "This bit is set in the dis-line-flags when a line is found to be moved.")
-(defconstant new-bit #b100
-  "This bit is set in the dis-line-flags when a line is found to be new.")
-
-
-;;; move-lines  --  Internal
-;;;
-;;;    This function is called by Maybe-Change-Window when it believes that 
-;;; a line needs to be inserted or deleted.  When called it finishes the
-;;; image-update for the entire rest of the window.  Here and many other
-;;; places the phrase "dis-line" is often used to mean a pointer into the
-;;; window's list of dis-lines.
-;;;
-;;; Window - The window whose image needs to be updated.
-;;; Changed - True if the first-changed line has already been set, if false
-;;;  we must set it.
-;;; String - The overhang string to be added to the beginning of the first
-;;;  line image we build.  If no overhang then this is NIL.
-;;; Underhang - The number of trailing chars of String to use.
-;;; Line - The line at which we are to continue building the image.  This
-;;;  may be NIL, in which case we are at the end of the buffer.
-;;; Offset - The charpos within Line to continue at.
-;;; Current - The dis-line which caused Maybe-Change-Window to choke; it
-;;;  may be the-sentinel, it may not be the dummy line at head of the
-;;;  window's dis-lines.  This is the dis-line at which Maybe-Change-Window
-;;;  turns over control, it should not be one whose image it built.
-;;; Trail - This is the dis-line which immediately precedes Current in the
-;;;  dis-line list.  It may be the dummy dis-line, it may not be the sentinel.
-;;; Width - (window-width window)
-(defun move-lines (window changed string underhang line offset trail current
-			  width)
-  
-  (do* ((delta 0)
-	(cc (car current))
-	(old-line (dis-line-line cc))
-	;; Can't use current, since might be the-sentinel.
-	(pos (1+ (dis-line-position (car trail))))
-	;; Are we on an extension line?
-	(is-wrapped (eq line (dis-line-line (car trail))))
-	(last (window-last-line window))
-	(last-line (dis-line-line (car last)))
-	(save trail)
-	(height (window-height window))
-	(spare-lines (window-spare-lines window))
-	;; Make the-sentinel in this buffer so we don't delete it.
-	(buffer (setf (line-%buffer (dis-line-line (car the-sentinel)))
-		      (window-buffer window)))
-	(start offset) new-num)
-       ((or (= pos height) (null line))
-	;;    If we have run off the bottom or run out of lines then we are
-	;; done.  At this point Trail is the last line displayed and Current is
-	;; whatever comes after it, possibly the-sentinel.
-	;;    We always say that last-changed is the last line so that we
-	;; don't have to max in the old last-changed.
-	(setf (window-last-changed window) trail)
-	;; If there are extra lines at the end that need to be deleted
-	;; and haven't been already then link them into the free-list.
-	(unless (eq last trail)
-	  ;; This test works, because if the old last line was either
-	  ;; deleted or another line was inserted after it then it's
-	  ;; cdr would be something else.
-	  (when (eq (cdr last) the-sentinel)
-	    (shiftf (cdr last) spare-lines (cdr trail) the-sentinel))
-	  (setf (window-last-line window) trail))
-	(setf (window-spare-lines window) spare-lines)
-	;;    If first-changed has not been set then we set the first-changed
-	;; to the first line we looked at if it does not come after the
-	;; new position of the old first-changed.
-	(unless changed
-	  (when (> (dis-line-position (car (window-first-changed window)))
-		   (dis-line-position (car save)))
-	    (setf (window-first-changed window) (cdr save)))))
-
-    (setq new-num (line-number line))
-    ;; If a line has been deleted, it's line-%buffer is smashed; we unlink
-    ;; any dis-line which displayed such a line.
-    (cond
-     ((neq (line-%buffer old-line) buffer)
-      (do ((ptr (cdr current) (cdr ptr))
-	   (prev current ptr))
-	  ((eq (line-%buffer (dis-line-line (car ptr))) buffer)
-	   (setq delta (- pos (1+ (dis-line-position (car prev)))))
-	   (shiftf (cdr trail) (cdr prev) spare-lines current ptr)))
-      (setq cc (car current)  old-line (dis-line-line cc)))
-     ;; If the line-number of the old line is less than the line-number
-     ;; of the line we want to display then the old line must be off the top
-     ;; of the screen - delete it.  The-Sentinel fails this test because
-     ;; it's line-number is most-positive-fixnum.
-     ((< (line-number old-line) new-num)
-      (do ((ptr (cdr current) (cdr ptr))
-	   (prev current ptr))
-	  ((>= (line-number (dis-line-line (car ptr))) new-num)
-	   (setq delta (- pos (1+ (dis-line-position (car prev)))))
-	   (shiftf (cdr trail) (cdr prev) spare-lines current ptr)))
-      (setq cc (car current)  old-line (dis-line-line cc)))
-     ;; New line comes before old line, insert it, punting when
-     ;; we hit the bottom of the screen.
-     ((neq line old-line)
-      (do ((chars (unless is-wrapped (line-%chars line)) nil) new)
-	  (())
-	(setq new (car spare-lines))
-	(setf (dis-line-old-chars new) chars
-	      (dis-line-position new) pos
-	      (dis-line-line new) line
-	      (dis-line-delta new) 0
-	      (dis-line-flags new) new-bit)
-	(setq pos (1+ pos)  delta (1+ delta))
-	(multiple-value-setq (string underhang start)
-	  (compute-line-image string underhang line start new width))
-	(rotatef (cdr trail) spare-lines (cdr spare-lines))
-	(setq trail (cdr trail))
-	(cond ((= pos height)
-	       (return nil))
-	      ((null underhang)
-	       (setq start 0  line (line-next line))
-	       (return nil))))
-      (setq is-wrapped nil))
-     ;; The line is the same, possibly moved.  We add in the delta and
-     ;; or in the moved bit so that if redisplay punts in the middle
-     ;; the information is not lost.
-     ((eq (line-%chars line) (dis-line-old-chars cc))
-      ;; If the line is the old bottom line on the screen and it has moved and
-      ;; is full length, then mash the old-chars and quit so that the image
-      ;; will be recomputed the next time around the loop, since the line might
-      ;; have been wrapped off the bottom of the screen.
-      (cond
-       ((and (eq line last-line)
-	     (= (dis-line-length cc) width)
-	     (not (zerop delta)))
-	(setf (dis-line-old-chars cc) :another-unique-thing))
-       (t
-	(do ()
-	    ((= pos height))
-	  (unless (zerop delta)
-	    (setf (dis-line-position cc) pos)
-	    (incf (dis-line-delta cc) delta)
-	    (setf (dis-line-flags cc) (logior (dis-line-flags cc) moved-bit)))
-	  (shiftf trail current (cdr current))
-	  (setq cc (car current)  old-line (dis-line-line cc)  pos (1+ pos))
-	  (when (not (eq old-line line))
-	    (setq start 0  line (line-next line))
-	    (return nil))))))
-     ;; The line is changed, possibly moved.
-     (t
-      (do ((chars (line-%chars line) nil))
-	  (())
-	(multiple-value-setq (string underhang start)
-	  (compute-line-image string underhang line start cc width))
-	(setf (dis-line-flags cc) (logior (dis-line-flags cc) changed-bit)
-	      (dis-line-old-chars cc) chars
-	      (dis-line-position cc) pos)
-	(unless (zerop delta)
-	  (incf (dis-line-delta cc) delta)
-	  (setf (dis-line-flags cc) (logior (dis-line-flags cc) moved-bit)))
-	(shiftf trail current (cdr current))
-	(setq cc (car current)  old-line (dis-line-line cc)  pos (1+ pos))
-	(cond ((= pos height)
-	       (return nil))
-	      ((null underhang)
-	       (setq start 0  line (line-next line))
-	       (return nil))
-	      ((not (eq old-line line))
-	       (setq is-wrapped t)
-	       (return nil))))))))
-
-
-;;; maybe-change-window  --  Internal
-;;;
-;;;    This macro is "Called" in update-window-image whenever it finds that 
-;;; the chars of the line and the dis-line don't match.  This may happen for
-;;; several reasons:
-;;;
-;;; 1] The previous line was unchanged, but wrapped, so the dis-line-chars
-;;; are nil.  In this case we just skip over the extension lines.
-;;;
-;;; 2] A line is changed but not moved; update the line noting whether the
-;;; next line is moved because of this, and bugging out to Move-Lines if
-;;; it is.
-;;;
-;;; 3] A line is deleted, off the top of the screen, or moved.  Bug out
-;;; to Move-Lines.
-;;;
-;;;    There are two possible results, either we return NIL, and Line,
-;;; Trail and Current are updated, or we return T, in which case
-;;; Update-Window-Image should terminate immediately.  Changed is true
-;;; if a changed line changed lines has been found.
-;;;
-(eval-when (compile eval)
-(defmacro maybe-change-window (window changed line offset trail current width)
-  `(let* ((cc (car ,current))
-	  (old-line (dis-line-line cc)))
-     (cond
-      ;; We have run into a continuation line, skip over any.
-      ((and (null (dis-line-old-chars cc))
-	    (eq old-line (dis-line-line (car ,trail))))
-       (do ((ptr (cdr ,current) (cdr ptr))
-	    (prev ,current ptr))
-	   ((not (eq (dis-line-line (car ptr)) old-line))
-	    (setq ,trail prev  ,current ptr) nil)))
-      ;; A line is changed.
-      ((eq old-line ,line)
-       (unless ,changed
-	 (when (< (dis-line-position cc)
-		  (dis-line-position (car (window-first-changed ,window))))
-	   (setf (window-first-changed ,window) ,current)
-	   (setq ,changed t)))
-       (do ((chars (line-%chars ,line) nil)
-	    (start ,offset) string underhang)
-	   (())
-	 (multiple-value-setq (string underhang start)
-	   (compute-line-image string underhang ,line start cc ,width))
-	 (setf (dis-line-flags cc) (logior (dis-line-flags cc) changed-bit))
-	 (setf (dis-line-old-chars cc) chars)
-	 (setq ,trail ,current  ,current (cdr ,current)  cc (car ,current))
-	 (cond
-	  ((eq (dis-line-line cc) ,line)
-	   (unless underhang
-	     (move-lines ,window t nil 0 (line-next ,line) 0 ,trail ,current
-			 ,width)
-	     (return t)))
-	  (underhang
-	   (move-lines ,window t string underhang ,line start ,trail
-		       ,current ,width)
-	   (return t))
-	  (t
-	   (setq ,line (line-next ,line))
-	   (when (> (dis-line-position (car ,trail))
-		    (dis-line-position (car (window-last-changed ,window))))
-	     (setf (window-last-changed ,window) ,trail))
-	   (return nil)))))
-      (t
-       (move-lines ,window ,changed nil 0 ,line ,offset ,trail ,current
-		   ,width)
-       t))))
-); eval-when (compile eval)
-
-;;; update-window-image  --  Internal
-;;;
-;;;    This is the function which redisplay calls when it wants to ensure that 
-;;; a window-image is up-to-date.  The main loop here is just to zoom through
-;;; the lines and dis-lines, bugging out to Maybe-Change-Window whenever
-;;; something interesting happens.
-;;;
-(defun update-window-image (window)
-  (let* ((trail (window-first-line window))
-	 (current (cdr trail))
-	 (display-start (window-display-start window))
-	 (line (mark-line display-start))
-	 (width (window-width window)) changed)
-    (cond
-     ;; If the first line or its charpos has changed then bug out.
-     ((cond ((and (eq (dis-line-old-chars (car current)) (line-%chars line))
-		  (mark= display-start (window-old-start window)))
-	     (setq trail current  current (cdr current)  line (line-next line))
-	     nil)
-	    (t
-	     ;; Force the line image to be invalid in case the start moved
-	     ;; and the line wrapped onto the screen.  If we started at the
-	     ;; beginning of the line then we don't need to.
-	     (unless (zerop (mark-charpos (window-old-start window)))
-	       (unless (eq current the-sentinel)
-		 (setf (dis-line-old-chars (car current)) :another-unique-thing)))
-	     (let ((start-charpos (mark-charpos display-start)))
-	       (move-mark (window-old-start window) display-start)
-	       (maybe-change-window window changed line start-charpos
-				    trail current width)))))
-     (t
-      (prog ()
-	(go TOP)
-       STEP
-	(setf (dis-line-line (car current)) line)
-	(setq trail current  current (cdr current)  line (line-next line))
-       TOP
-	(cond ((null line)
-	       (go DONE))
-	      ((eq (line-%chars line) (dis-line-old-chars (car current)))
-	       (go STEP)))
-	;;
-	;; We found a suspect line.
-	;; See if anything needs to be updated, if we bugged out, punt.
-	(when (and (eq current the-sentinel)
-		   (= (dis-line-position (car trail))
-		      (1- (window-height window))))
-	  (return nil))
-	(when (maybe-change-window window changed line 0 trail current width)
-	  (return nil))
-	(go TOP)
-
-       DONE
-	;;
-	;; We hit the end of the buffer. If lines need to be deleted bug out.
-	(unless (eq current the-sentinel)
-	  (maybe-change-window window changed line 0 trail current width))
-	(return nil))))
-    ;;
-    ;; Update the display-end mark.
-    (let ((dl (car (window-last-line window))))
-      (move-to-position (window-display-end window) (dis-line-end dl)
-			(dis-line-line dl)))))
diff --git a/hemlock/xcoms.lisp b/hemlock/xcoms.lisp
deleted file mode 100644
index 0d10dd60ce9d5502cd423ba3742fdbc8e0ea0596..0000000000000000000000000000000000000000
--- a/hemlock/xcoms.lisp
+++ /dev/null
@@ -1,42 +0,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/xcoms.lisp,v 1.3 1991/02/08 16:39:17 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains commands and support specifically for X related features.
-;;;
-;;; Written by Bill Chiles.
-;;;
-
-(in-package "HEMLOCK")
-
-
-(defcommand "Region to Cut Buffer" (p)
-  "Place the current region into the X cut buffer."
-  "Place the current region into the X cut buffer."
-  (declare (ignore p))
-  (store-cut-string (hi::bitmap-device-display
-		     (hi::device-hunk-device (hi::window-hunk (current-window))))
-		    (region-to-string (current-region))))
-
-(defcommand "Insert Cut Buffer" (p)
-  "Insert the X cut buffer at current point."
-  "Insert the X cut buffer at current point.  Returns nil when it is empty."
-  (declare (ignore p))
-  (let ((str (fetch-cut-string (hi::bitmap-device-display
-				(hi::device-hunk-device
-				 (hi::window-hunk (current-window)))))))
-    (if str
-	(let ((point (current-point)))
-	  (push-buffer-mark (copy-mark point))
-	  (insert-string (current-point) str))
-	(editor-error "X cut buffer empty.")))
-  (setf (last-command-type) :ephemerally-active))
diff --git a/interface/debug.lisp b/interface/debug.lisp
deleted file mode 100644
index b2e377fc45761e8ae9039ee1811e2286c72ee16a..0000000000000000000000000000000000000000
--- a/interface/debug.lisp
+++ /dev/null
@@ -1,446 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Debug -*-
-;;;
-
-(in-package "DEBUG")
-(use-package '("TOOLKIT" "INTERFACE"))
-
-(defvar *current-debug-display* nil)
-(defvar *debug-active-frames* nil)
-(defvar *old-display-frames* nil)
-
-
-
-;;;; Structures used by the graphical debugger
-
-(defstruct (debug-display
-	    (:conc-name dd-info-)
-	    (:print-function print-debug-display)
-	    (:constructor make-debug-display
-			  (debug-pane restarts backtrace)))
-  (debug-pane nil :type (or null widget))
-  (restarts nil :type (or null widget))
-  (backtrace nil :type (or null widget))
-  (level 0 :type fixnum)
-  (connection nil :type (or null xt::motif-connection)))
-
-(defun print-debug-display (info stream d)
-  (declare (ignore d))
-  (format stream "#<Debugger Display Info level ~d" (dd-info-level info)))
-
-
-
-;;;; Callback functions
-
-(defun quit-debugger-callback (widget call-data condition)
-  (declare (ignore widget call-data))
-  (close-motif-debugger condition)
-  (throw 'lisp::top-level-catcher nil))
-
-(defun restart-callback (widget call-data restart)
-  (declare (ignore widget call-data))
-  (invoke-restart-interactively restart))
-
-(defun stack-frame-callback (widget call-data frame)
-  (declare (ignore widget call-data))
-  (unless (assoc frame *debug-active-frames*)
-    ;; Should wrap this in a busy cursor
-    (debug-display-frame frame)))
-
-(defun ping-callback (widget call-data test)
-  (declare (ignore widget call-data))
-  (destroy-widget (car (xt::widget-children test))))
-
-(defun close-all-callback (widget call-data)
-  (declare (ignore widget call-data))
-  (dolist (info *debug-active-frames*)
-    (destroy-widget (cdr info)))
-  (setf *debug-active-frames* nil))
-
-(defun frame-view-callback (widget call-data thing)
-  (declare (ignore widget call-data))
-  ;; Should wrap this in a busy cursor
-  (inspect thing))
-
-(defun close-frame-callback (widget call-data frame)
-  (declare (ignore widget call-data))
-  (setf *debug-active-frames*
-	(delete frame *debug-active-frames*
-		:test #'(lambda (a b) (eql a (car b)))))
-  (destroy-interface-pane frame))
-
-(defun edit-source-callback (widget call-data)
-  (declare (ignore widget call-data))
-  (funcall (debug-command-p :edit-source)))
-
-(defun frame-eval-callback (widget call-data frame output)
-  (declare (ignore call-data))
-  (let* ((input (car (get-values widget :value)))
-	 (mark (text-get-last-position output))
-	 (response
-	  (format nil "Eval>> ~a~%~a--------------------~%"
-		  input
-		  (handler-case
-		      (multiple-value-bind
-			  (out val)
-			  (let ((*current-frame* frame))
-			    (grab-output-as-string
-			     (di:eval-in-frame frame (read-from-string input))))
-			(format nil "~a~s~%" out val))
-		    (error (cond)
-			   (format nil "~2&~A~2&" cond)))))
-	  (length (length response)))
-    (declare (simple-string response))
-	
-    (text-set-string widget "")
-    (text-insert output mark response)
-    ;; This is to make sure that things stay visible
-    (text-set-insertion-position output (+ length mark))))
-
-(defun source-verbosity-callback (widget call-data frame srcview delta)
-  (declare (ignore widget call-data))
-  (let* ((current (car (get-values srcview :user-data)))
-	 (new (+ current delta)))
-    (when (minusp new)
-      (setf new 0))
-    (let ((source (handler-case
-		     (grab-output-as-string
-		      (print-code-location-source-form
-		       (di:frame-code-location frame) new))
-		   (di:debug-condition (cond)
-		     (declare (ignore cond))
-		     "Source form not available."))))
-      (set-values srcview
-		  :label-string source
-		  :user-data new))))
-
-
-
-(defun debug-display-frame-locals (frame debug-fun location frame-view)
-  (let (widgets)
-    (if (di:debug-variable-info-available debug-fun)
-	(let ((any-p nil)
-	      (any-valid-p nil))
-	  (di:do-debug-function-variables (v debug-fun)
-	    (unless any-p
-	      (setf any-p t)
-	      (push (create-label-gadget frame-view "localsLabel"
-					 :font-list *header-font*
-					 :label-string "Local variables:")
-		    widgets))
-	    (when (eq (di:debug-variable-validity v location) :valid)
-	      (let ((value (di:debug-variable-value v frame))
-		    (id (di:debug-variable-id v)))
-		(setf any-valid-p t)
-		(push
-		 (create-value-box frame-view
-				   (format nil "   ~A~:[#~D~;~*~]:"
-					   (di:debug-variable-name v)
-					   (zerop id) id)
-				   value
-				   :callback 'frame-view-callback)
-		 widgets))))
-	  (cond
-	   ((not any-p)
-	    (push
-	     (create-label-gadget frame-view "noLocals"
-				  :font-list *italic-font*
-				  :label-string
-				  "   No local variables in function.")
-	     widgets))
-	   ((not any-valid-p)
-	    (push
-	     (create-label-gadget frame-view "noValidLocals"
-				  :font-list *italic-font*
-				  :label-string
-				  "   All variables have invalid values.")
-	     widgets))))
-
-	(push (create-label-gadget frame-view "noVariableInfo"
-				   :font-list *italic-font*
-				   :label-string
-				   "   No variable information available.")
-	      widgets))
-    (apply #'manage-children widgets)))
-
-(defun debug-display-frame-prompt (frame frame-view)
-  (let* ((form (create-form frame-view "promptForm"))
-	 (label (create-label-gadget form "framePrompt"
-				     :label-string "Frame Eval:"
-				     :font-list *header-font*))
-	 (entry (create-text form "frameEval"
-			     :top-attachment :attach-widget
-			     :top-widget label
-			     :left-attachment :attach-form
-			     :right-attachment :attach-form))
-	 (output (create-text form "frameOutput"
-			      :edit-mode :multi-line-edit
-			      :editable nil
-			      :rows 8
-			      :columns 40
-			      :top-attachment :attach-widget
-			      :top-widget entry
-			      :bottom-attachment :attach-form
-			      :left-attachment :attach-form
-			      :right-attachment :attach-form)))
-
-    (manage-child form)
-    (manage-children label entry output)
-    (add-callback entry :activate-callback 'frame-eval-callback
-		  frame output)))
-
-(defun debug-display-frame (frame)
-  (let* ((debug-fun (di:frame-debug-function frame))
-	 (location (di:frame-code-location frame))
-	 (name (di:debug-function-name debug-fun))
-	 (title (format nil "Stack Frame: ~A" name))
-	 (frame-shell (create-interface-pane-shell title frame))
-	 (frame-view (create-row-column frame-shell "debugFrameView"))
-	 (menu-bar (create-menu-bar frame-view "frameMenu"))
-	 (fcall (create-label-gadget frame-view "frameCall"
-				     :label-string
-				     (format nil "Frame Call: ~a"
-					     (grab-output-as-string
-					      (print-frame-call frame)))))
-	 (fbox (create-value-box frame-view "Function:"
-				 name
-				 :callback 'frame-view-callback
-				 :client-data
-				 (di:debug-function-function debug-fun)))
-	 (slabel (create-label-gadget frame-view "sourceLabel"
-				      :font-list *header-font*
-				      :label-string "Source form:"))
-	 (swindow (create-scrolled-window frame-view "frameSourceWindow"
-					  :scrolling-policy :automatic
-					  :scroll-bar-placement :bottom-right))
-
-	 (source (handler-case
-		     (grab-output-as-string
-		      (print-code-location-source-form location 0))
-		   (di:debug-condition (cond)
-		     (declare (ignore cond))
-		     "Source form not available.")))
-	 (srcview (create-label-gadget swindow "sourceForm"
-				       :alignment :alignment-beginning
-				       :user-data 0
-				       :label-string source))
-	 (cascade1
-	  (create-interface-menu menu-bar "Frame"
-	   `(("Edit Source" edit-source-callback)
-	     ("Expand Source Form" source-verbosity-callback ,frame ,srcview 1)
-	     ("Shrink Source Form" source-verbosity-callback ,frame ,srcview -1)
-	     ("Close Frame" close-frame-callback ,frame))))
-	 (cascade2 (create-cached-menu menu-bar "Debug")))
-
-    (manage-child frame-view)
-    (manage-children menu-bar fcall fbox slabel swindow)
-    (manage-child srcview)
-    (manage-children cascade1 cascade2)
-
-    (debug-display-frame-locals frame debug-fun location frame-view)
-    (debug-display-frame-prompt frame frame-view)
-
-    (popup-interface-pane frame-shell)
-    (push (cons frame frame-shell) *debug-active-frames*)))
-
-
-
-;;;; Functions to display the debugger control panel
-
-(defun debug-display-error (errmsg condition)
-  (set-values errmsg :label-string (format nil "~A" condition)))
-
-(defun debug-display-restarts (restarts)
-  (let (buttons)
-    (dolist (r *debug-restarts*)
-      (let ((button (create-highlight-button
-		     restarts "restartButton" (format nil "~A" r))))
-	(add-callback button :activate-callback 'restart-callback r)
-	(push button buttons)))
-    (apply #'manage-children buttons)))
-
-(defun debug-display-stack (backtrace)
-  (let ((buttons))
-    (do ((frame *current-frame* (di:frame-down frame)))
-	((null frame))
-      (let ((button (create-highlight-button
-		     backtrace "stackFrame"
-		     (grab-output-as-string
-		      (print-frame-call frame)))))
-	(add-callback button :activate-callback 'stack-frame-callback frame)
-	(push button buttons)))
-    (apply #'manage-children buttons)))
-
-(defun create-debugger (condition)
-  (let* ((debug-pane (create-interface-pane-shell "Debugger" condition))
-	 (frame (create-frame debug-pane "debugFrame"))
-	 (form (create-form frame "debugForm"))
-	 (menu-bar (create-menu-bar form "debugMenu"
-				    :left-attachment :attach-form
-				    :right-attachment :attach-form))
-	 (cascade (create-cached-menu
-		   menu-bar "Debug"
-		   `(("Close All Frames" close-all-callback)
-		     ("Quit Debugger" quit-debugger-callback ,condition))))
- 	 (errlabel (create-label-gadget form "errorLabel"
-					:top-attachment :attach-widget
-					:top-widget menu-bar
-					:left-attachment :attach-form
-					:font-list *header-font*
-					:label-string "Error Message:"))
-	 (errmsg (create-label-gadget form "errorMessage"
-				      :top-attachment :attach-widget
-				      :top-widget errlabel
-				      :left-attachment :attach-form
-				      :right-attachment :attach-form))
-	 (rlabel (create-label-gadget form "restartLabel"
-				      :top-attachment :attach-widget
-				      :top-widget errmsg
-				      :left-attachment :attach-form
-				      :font-list *header-font*))
-	 (restarts (create-row-column form "debugRestarts"
-				      :adjust-last nil
-				      :top-attachment :widget
-				      :top-widget rlabel
-				      :left-attachment :attach-form
-				      :right-attachment :attach-form
-				      :left-offset 10))
-	 (btlabel (create-label-gadget form "backtraceLabel"
-				       :label-string "Stack Backtrace:"
-				       :font-list *header-font*
-				       :top-attachment :attach-widget
-				       :top-widget restarts
-				       :left-attachment :attach-form))
-	 (btwindow (create-scrolled-window form "backtraceWindow"
-					   :scrolling-policy :automatic
-					   :scroll-bar-placement :bottom-right
-					   :left-attachment :attach-form
-					   :right-attachment :attach-form
-					   :left-offset 4
-					   :right-offset 4
-					   :bottom-offset 4
-					   :bottom-attachment :attach-form
-					   :top-attachment :attach-widget
-					   :top-widget btlabel))
-	 (backtrace (create-row-column btwindow "debugBacktrace"
-				       :adjust-last nil
-				       :spacing 1)))
-
-    (manage-child frame) (manage-child form)
-    (manage-children menu-bar errlabel errmsg rlabel restarts btlabel btwindow)
-    (manage-child backtrace)
-    (manage-child cascade)
-
-    (debug-display-error errmsg condition)
-    
-    (if *debug-restarts*
-	(progn
-	  (set-values rlabel :label-string "Restarts:")
-	  (debug-display-restarts restarts))
-	(set-values rlabel :label-string "No restarts available"))
-
-    (debug-display-stack backtrace)
-
-    (setf *current-debug-display*
-	  (make-debug-display debug-pane restarts backtrace))
-
-    (popup-interface-pane debug-pane)
-    debug-pane))
-    
-(defun close-motif-debugger (condition)
-  (push *current-debug-display* *old-display-frames*)
-  ;;
-  ;; Destroy all frame panes
-  (dolist (info *debug-active-frames*)
-    (destroy-widget (cdr info)))
-  (setf *debug-active-frames* nil)
-  ;;
-  ;; Destroy the restart/backtrace window
-  (setf *current-debug-display* nil)
-  (destroy-interface-pane condition)
-
-  (format t "Leaving debugger.~%"))
-
-(defun invoke-motif-debugger (condition)
-  (let* ((frame (di:top-frame))
-	 (previous-display *current-debug-display*)
-	 (*current-debug-display* nil)
-	 (*debug-active-frames* nil))
-    (declare (ignore previous-display))
-    (verify-system-server-exists)
-    (multiple-value-bind (shell connection)
-			 (create-interface-shell)
-      (declare (ignore shell))
-      (with-motif-connection (connection)
-	(let ((pane (find-interface-pane condition))
-	      (*current-frame* frame))
-	  (unless pane
-	    (setf pane (create-debugger condition)))
-	  (unless (is-managed pane)
-	    (popup-interface-pane pane))
-	  (setf (dd-info-level *current-debug-display*) *debug-command-level*)
-	  (setf (dd-info-connection *current-debug-display*) connection)
-	  (unwind-protect
-	      (handler-case
-		  (loop
-		    (system:serve-event))
-		(error (err)
-		       (if *flush-debug-errors*
-			   (interface-error (format nil "~a" err) pane)
-			   (interface-error
-			    "Do not yet support recursive debugging" pane))))
-	    (when (and connection *current-debug-display*)
-	      (with-motif-connection (connection)
-		(close-motif-debugger condition)))))))))
-
-
-
-(defun invoke-debugger (condition)
-  "The CMU Common Lisp debugger.  Type h for help."
-  (when *debugger-hook*
-    (let ((hook *debugger-hook*)
-	  (*debugger-hook* nil))
-      (funcall hook condition hook)))
-  (unix:unix-sigsetmask 0)
-  (let* ((*debug-condition* condition)
-	 (*debug-restarts* (compute-restarts))
-	 (*standard-input* *debug-io*)          ;in case of setq
-	 (*standard-output* *debug-io*)         ;''  ''  ''  ''
-	 (*error-output* *debug-io*)
-	 ;; Rebind some printer control variables.
-	 (kernel:*current-level* 0)
-	 (*print-readably* nil)
-	 (*read-eval* t))
-    (if (or (not (use-graphics-interface))
-	    (typep condition 'xti:toolkit-error))
-	(progn
-	  (format *error-output* "~2&~A~2&" *debug-condition*)
-	  (unless (typep condition 'step-condition)
-	    (show-restarts *debug-restarts* *error-output*))
-	  (internal-debug))
-	(progn
-	  (write-line "Invoking debugger...")
-	  (invoke-motif-debugger condition)))))
-
-#|
-(defun invoke-debugger (condition)
-  "The CMU Common Lisp debugger.  Type h for help."
-  (when *debugger-hook*
-    (let ((hook *debugger-hook*)
-	  (*debugger-hook* nil))
-      (funcall hook condition hook)))
-  (unix:unix-sigsetmask 0)
-  (let* ((*debug-condition* condition)
-	 (*debug-restarts* (compute-restarts))
-	 (*standard-input* *debug-io*)          ;in case of setq
-	 (*standard-output* *debug-io*)         ;''  ''  ''  ''
-	 (*error-output* *debug-io*)
-	 ;; Rebind some printer control variables.
-	 (kernel:*current-level* 0)
-	 (*print-readably* nil)
-	 (*read-eval* t))
-    (format *error-output* "~2&~A~2&" *debug-condition*)
-    (unless (typep condition 'step-condition)
-      (show-restarts *debug-restarts* *error-output*))
-    (internal-debug)))
-
-|#
diff --git a/interface/initial.lisp b/interface/initial.lisp
deleted file mode 100644
index 1dacb1207e430dc361cfcda797da830c6081c530..0000000000000000000000000000000000000000
--- a/interface/initial.lisp
+++ /dev/null
@@ -1,16 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: User -*-
-;;;
-
-(in-package "USER")
-
-(defpackage "INTERFACE"
-  (:use "TOOLKIT" "LISP" "PCL" "EXTENSIONS" "KERNEL")
-  (:export "*HEADER-FONT*" "*ITALIC-FONT*" "*ENTRY-FONT*" "*INTERFACE-STYLE*"
-	   "USE-GRAPHICS-INTERFACE" "VERIFY-SYSTEM-SERVER-EXISTS"
-	   "CREATE-INTERFACE-SHELL" "POPUP-INTERFACE-PANE"
-	   "CREATE-INTERFACE-PANE-SHELL" "FIND-INTERFACE-PANE"
-	   "DESTROY-INTERFACE-PANE" "CREATE-HIGHLIGHT-BUTTON" "CREATE-VALUE-BOX"
-	   "SET-VALUE-BOX" "WITH-WIDGET-CHILDREN" "INTERFACE-ERROR"
-	   "PRINT-FOR-WIDGET-DISPLAY" "WITH-BUSY-CURSOR"
-	   "CREATE-INTERFACE-MENU" "CREATE-CACHED-MENU"
-	   "GRAB-OUTPUT-AS-STRING" "*ALL-FONTS*" "LISP-CONTROL-PANEL"))
diff --git a/interface/inspect.lisp b/interface/inspect.lisp
deleted file mode 100644
index f8b407bfa76be375ed485ed510f131f8af65654e..0000000000000000000000000000000000000000
--- a/interface/inspect.lisp
+++ /dev/null
@@ -1,502 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Interface -*-
-;;;
-;;;
-
-(in-package "INTERFACE")
-
-
-(defvar *inspector-huge-object-threshold* 20)
-(defvar *inspector-sequence-initial-display* 5)
-
-
-
-;;;; Inspector callbacks
-
-(defun destroy-pane-callback (widget call-data object)
-  (declare (ignore widget call-data))
-  (destroy-interface-pane object))
-
-(defun inspect-object-callback (widget call-data object)
-  (declare (ignore widget call-data))
-  (inspect object))
-
-(defun inspect-eval-callback (widget call-data output shell)
-  (declare (ignore widget call-data))
-  (with-busy-cursor (shell)
-    (inspect (xti:widget-user-data output))))
-
-(defun eval-callback (widget call-data object output)
-  (declare (ignore call-data))
-  (let* ((input (car (get-values widget :value)))
-	 (mark (text-get-last-position output))
-	 (response
-	  (format nil "* ~a~%~a~%"
-		  input
-		  (handler-case
-		      (multiple-value-bind (out val)
-					   (grab-output-as-string
-					    (let ((* object))
-					      (eval (read-from-string input))))
-			(setf (xti:widget-user-data output) val)
-			(format nil "~a~s~%" out val))
-		    (error (cond)
-		      (format nil "~2&~A~2&" cond)))))
-	 (length (length response)))
-    (declare (simple-string response))
-
-    (text-set-string widget "")
-    (text-insert output mark response)
-    (text-set-insertion-position output (+ length mark))))
-
-(defun popup-eval-callback (widget call-data pane object)
-  (declare (ignore widget call-data))
-  (multiple-value-bind (form shell)
-		       (create-form-dialog pane "evalDialog")
-    (let* ((s1 (compound-string-create "Eval: " "HeaderFont"))
-	   (s2 (compound-string-create
-		(format nil "[~a]" (print-for-widget-display "~S" object))
-		"EntryFont"))
-	   (s3 (compound-string-concat s1 s2))
-	   (done (create-push-button-gadget form "evalDone"
-					    :label-string "Done"
-					    :bottom-attachment :attach-form))
-	   (inspect (create-push-button-gadget form "evalInspect"
-					       :label-string "Inspect Last"
-					       :bottom-attachment :attach-form
-					       :left-attachment :attach-widget
-					       :left-widget done))
-	   (entry (create-text form "evalEntry"
-			       :bottom-attachment :attach-widget
-			       :bottom-widget done
-			       :left-attachment :attach-form
-			       :right-attachment :attach-form))
-	   (prompt (create-label-gadget form "evalPrompt"
-					:bottom-attachment :attach-widget
-					:bottom-widget entry
-					:font-list *all-fonts*
-					:label-string s3))
-	   (output (create-text form "evalOutput"
-				:edit-mode :multi-line-edit
-				:editable nil
-				:rows 8
-				:columns 40
-				:top-attachment :attach-form
-				:bottom-attachment :attach-widget
-				:bottom-widget prompt
-				:left-attachment :attach-form
-				:right-attachment :attach-form)))
-      (compound-string-free s1)
-      (compound-string-free s2)
-
-      (set-values shell :title "Inspector Eval"
-		        :keyboard-focus-policy :pointer)
-      (add-callback entry :activate-callback 'eval-callback object output)
-      (add-callback inspect :activate-callback
-		    'inspect-eval-callback output shell)
-      (add-callback done :activate-callback #'destroy-callback shell)
-      (manage-children done inspect entry prompt output)
-      (manage-child form))))
-
-
-
-;;;; Methods for constructing the title of inspection panes
-
-(defmethod inspector-pane-title (object)
-  (typecase object
-    (pcl::std-instance
-     (format nil "Instance ~a of Class ~a"
-	     object (pcl:class-name (pcl:class-of object))))
-    (function (format nil "~a" object))
-    (structure
-     (let ((default (format nil "~a" object)))
-       (declare (simple-string default))
-       (if (and (> (length default) 2)
-		(char= (schar default 0) #\#)
-		(char= (schar default 1) #\S))
-	   (format nil "#<~a Structure>" (type-of object))
-	   default)))
-    (t
-     (format nil "~a ~a" (string-capitalize (type-of object))
-	     (print-for-widget-display "~s" object)))))
-
-(defmethod inspector-pane-title ((sym symbol))
-  (format nil "Symbol ~s" sym))
-
-(defmethod inspector-pane-title ((v vector))
-  (declare (vector v))
-  (let ((length (length v))
-	(type (type-of v)))
-    (format nil "~a of length ~a"
-	    (string-capitalize (if (listp type) (car type) type))
-	    length)))
-
-(defmethod inspector-pane-title ((a array))
-  (let ((dimensions (array-dimensions a)))
-    (format nil "Array of ~a  Dimensions = ~s"
-	    (array-element-type a) dimensions)))
-
-(defmethod inspector-pane-title ((l list))
-  (if (not (listp (cdr l)))
-      (format nil "Dotted Pair")
-      (format nil "List of length ~a" (length l))))
-
-
-
-;;;; Methods for displaying object inspection panes
-
-(defmacro with-inspector-pane ((object) &body forms)
-  `(multiple-value-bind
-       (pane is-new)
-       (create-interface-pane-shell (format nil "Inspect: ~a" (type-of ,object))
-				    ,object)
-     (when is-new
-       (let* ((frame (create-frame pane "inspectFrame"))
-	      (over-form (create-form frame "inspectForm"))
-	      (menu-bar (create-menu-bar over-form "menubar"
-					 :left-attachment :attach-form
-					 :right-attachment :attach-form))
-	      (obmenu (create-interface-menu
-		       menu-bar "Object"
-		       ,``(("Eval Expression" popup-eval-callback ,pane ,,object)
-			   ("Close Pane" destroy-pane-callback ,,object))))
-	      (title (create-label-gadget
-		      over-form "inspectTitle"
-		      :label-string (inspector-pane-title ,object)
-		      :font-list *header-font*
-		      :top-attachment :attach-widget
-		      :top-widget menu-bar
-		      :left-attachment :attach-form
-		      :right-attachment :attach-form))
-	      (form (create-form over-form "inspectForm"
-				 :left-attachment :attach-form
-				 :right-attachment :attach-form
-				 :bottom-attachment :attach-form
-				 :top-attachment :attach-widget
-				 :top-widget title)))
-
-	 ,@forms
-	 (manage-child frame)
-	 (manage-child over-form)
-	 (manage-child obmenu)
-	 (manage-children menu-bar title form)))
-     (popup-interface-pane pane)))
-
-(defmethod display-inspector-pane (object)
-  (typecase object
-    (pcl::std-instance (display-clos-pane object))
-    (function (display-function-pane object))
-    (structure (display-structure-pane object))
-    (t
-     (with-inspector-pane (object)
-       (let ((label (create-label-gadget
-		     form "label"
-		     :label-string (format nil "~s" object))))
-	 (manage-child label))))))
-
-
-(defmethod display-inspector-pane ((sym symbol))
-  (with-inspector-pane (sym)
-    (let* ((value (if (boundp sym) (symbol-value sym) "Unbound"))
-	   (function (if (fboundp sym) (symbol-function sym) "Undefined"))
-	   (plist (symbol-plist sym))
-	   (package (symbol-package sym))
-	   (rc (create-row-column form "rowColumn"))
-	   (vview (create-value-box rc "Value:" value
-				    :callback 'inspect-object-callback
-				    :activep (boundp sym)))
-	   (fview (create-value-box rc "Function:" function
-				    :callback 'inspect-object-callback
-				    :activep (fboundp sym)))
-	   (plview (create-value-box rc "PList:" plist
-				     :callback 'inspect-object-callback))
-	   (pview (create-value-box rc "Package:" package
-				    :callback 'inspect-object-callback)))
-      (manage-child rc)
-      (manage-children vview fview plview pview))))
-
-(defun is-traced (function)
-  (let ((fun (debug::trace-fdefinition function)))
-    (if (gethash fun debug::*traced-functions*) t)))
-
-(defun trace-function-callback (widget call-data function)
-  (declare (ignore widget))
-  (if (toggle-button-callback-set call-data)
-      (debug::trace-1 function (debug::make-trace-info))
-      (debug::untrace-1 function)))
-
-(defun display-function-pane (f)
-  (with-inspector-pane (f)
-    (multiple-value-bind
-	(dstring dval)
-	(grab-output-as-string (describe f))
-      (declare (ignore dval))
-      (let* ((trace (create-toggle-button-gadget form "functionTrace"
-						 :bottom-attachment :attach-form
-						 :label-string "Trace Function"
-						 :set (is-traced f)))
-	     (sep (create-separator-gadget form "separator"
-					   :left-attachment :attach-form
-					   :right-attachment :attach-form
-					   :bottom-attachment :attach-widget
-					   :bottom-widget trace))
-	     (descview (create-scrolled-window form "scrolledView"
-					       :left-attachment :attach-form
-					       :right-attachment :attach-form
-					       :bottom-attachment :attach-widget
-					       :bottom-widget sep
-					       :top-attachment :attach-form
-					       :scrolling-policy :automatic))
-	     (desc (create-label descview "functionDescription"
-				 :alignment :alignment-beginning
-				 :label-string dstring)))
-
-	(add-callback trace :value-changed-callback
-		      'trace-function-callback f)
-	(manage-child desc)
-	(manage-children trace sep descview)))))
-
-(defun display-structure-pane (s)
-  (with-inspector-pane (s)
-    (let* ((dd (info type defined-structure-info (structure-ref s 0)))
-	   (dsds (c::dd-slots dd))
-	   (viewer (when (> (length dsds) *inspector-huge-object-threshold*)
-		     (create-scrolled-window form "structureViewer"
-					     :left-attachment :attach-form
-					     :right-attachment :attach-form
-					     :top-attachment :attach-form
-					     :bottom-attachment :attach-form
-					     :scrolling-policy :automatic)))
-	   (rc (create-row-column (or viewer form) "rowColumn"))
-	   (widgets))
-      (declare (list dsds))
-      (dolist (dsd dsds)
-	(push
-	 (create-value-box rc (format nil "~A:"
-				      (string-capitalize (c::dsd-%name dsd)))
-			   (structure-ref s (c::dsd-index dsd))
-			   :callback #'inspect-object-callback)
-	 widgets))
-      (apply #'manage-children widgets)
-      (manage-child rc)
-      (when viewer (manage-child viewer)))))
-
-
-(defun sequence-redisplay-callback (widget call-data v s-text c-text view pane)
-  (declare (ignore widget call-data))
-  (handler-case
-      (let* ((start (read-from-string (car (get-values s-text :value))))
-	     (count (read-from-string (car (get-values c-text :value))))
-	     (length (length v))
-	     (widgets (reverse (xti:widget-children view)))
-	     (unused-ones)
-	     (used-ones))
-
-	(when (> (+ start count) length)
-	  (setf count (- length start))
-	  (set-values c-text :value (format nil "~a" count)))
-
-	(when (minusp start)
-	  (setf start 0)
-	  (set-values s-text :value (format nil "~a" 0)))
-
-	(dolist (widget widgets)
-	  (if (zerop count)
-	      (push widget unused-ones)
-	      (progn
-		(set-value-box widget (format nil "~a:" start) (elt v start)
-			       :callback #'inspect-object-callback)
-		(push widget used-ones)
-		(incf start)
-		(decf count))))
-
-	(dotimes (i count)
-	  (let ((pos (+ start i)))
-	    (push (create-value-box view (format nil "~a:" pos) (elt v pos)
-				    :callback #'inspect-object-callback)
-		  used-ones)))
-	(when unused-ones
-	    (apply #'unmanage-children unused-ones))
-	(apply #'manage-children used-ones))
-    (error (e)
-      (interface-error (format nil "~a" e) pane))))
-
-(defun sequence-filter-callback (widget call-data v fexp view pane)
-  (declare (ignore widget call-data))
-  (handler-case
-      (let* ((exp (read-from-string (car (get-values fexp :value))))
-	     (length (length v))
-	     (widgets (reverse (xti:widget-children view)))
-	     (used-ones))
-	(dotimes (index length)
-	  (let* ((item (elt v index))
-		 (* item)
-		 (** index))
-	    (when (eval exp)
-	      (let ((widget (pop widgets)))
-		(if widget
-		    (set-value-box widget (format nil "~a:" index) item
-				   :callback #'inspect-object-callback)
-		    (setf widget (create-value-box
-				  view (format nil "~a:" index) item
-				  :callback #'inspect-object-callback)))
-		(push widget used-ones)))))
-	(when widgets
-	  (apply #'unmanage-children widgets))
-	(apply #'manage-children used-ones))
-    (error (e)
-	   (interface-error (format nil "~a" e) pane))))
-
-(defmethod display-inspector-pane ((v sequence))
-  (with-inspector-pane (v)
-    (let* ((length (length v))
-	   (controls (create-row-column form "sequenceStartHolder"
-					:left-attachment :attach-form
-					:right-attachment :attach-form
-					:orientation :horizontal))
-	   (slabel (create-label-gadget controls "sequenceStartLabel"
-					:font-list *header-font*
-					:label-string "Start:"))
-	   (start (create-text controls "sequenceStart"
-			       :value "0"
-			       :columns 4))
-	   (clabel (create-label-gadget controls "sequenceCountLabel"
-					:font-list *header-font*
-					:label-string "Count:"))
-	   (count (create-text controls "sequenceCount"
-			       :value "5"
-			       :columns 4))
-	   (filter (create-row-column form "sequenceFilterHolder"
-				      :top-attachment :attach-widget
-				      :top-widget controls
-				      :left-attachment :attach-form
-				      :right-attachment :attach-form
-				      :orientation :horizontal))
-	   (flabel (create-label-gadget filter "sequenceFilterLabel"
-					:font-list *header-font*
-					:label-string "Filter:"))
-	   (fexp (create-text filter "sequenceFilterExp" :value "T"))
-	   (apply (create-push-button-gadget filter "sequenceFilterApply"
-					     :label-string "Apply"))
-	   (unapply (create-push-button-gadget filter "sequenceFilterUnapply"
-					       :label-string "No Filter"))
-	   (view (create-scrolled-window form "sequenceViewPort"
-					 :scrolling-policy :automatic
-					 :top-attachment :attach-widget
-					 :top-widget filter
-					 :bottom-attachment :attach-form
-					 :left-attachment :attach-form
-					 :right-attachment :attach-form))
-	   (rc (create-row-column view "sequenceView"
-				  :spacing 0))
-	   (widgets))
-
-      (manage-children slabel start clabel count)
-      (manage-children flabel fexp apply unapply)
-
-      (dotimes (i (min length *inspector-sequence-initial-display*))
-	(let ((item (elt v i)))
-	  (push (create-value-box rc (format nil "~a:" i) item
-				  :callback #'inspect-object-callback)
-		widgets)))
-
-      (apply #'manage-children widgets)
-
-      (add-callback start :activate-callback 'sequence-redisplay-callback
-		    v start count rc pane)
-      (add-callback count :activate-callback 'sequence-redisplay-callback
-		    v start count rc pane)
-      (add-callback apply :activate-callback 'sequence-filter-callback
-		    v fexp rc pane)
-      (add-callback fexp :activate-callback 'sequence-filter-callback
-		    v fexp rc pane)
-      (add-callback unapply :activate-callback
-		    #'(lambda (widget call-data)
-			(declare (ignore widget call-data))
-			(sequence-redisplay-callback
-			 nil nil v start count rc pane)))
-
-      (manage-children view controls filter)
-      (manage-child rc))))
-
-(defun show-slot-list (object slot-list view allocp label)
-  (let ((label (create-label-gadget view "slotLabel"
-				    :label-string label
-				    :font-list *header-font*))
-	(widgets))
-    (dolist (slotd slot-list)
-      (pcl:with-slots ((slot pcl::name) (allocation pcl::allocation))
-		      slotd
-	(let* ((slot-label (if allocp
-			       (format nil "~a: " slot)
-			       (format nil "~a [~a]: " slot allocation)))
-	       (slot-bound (pcl:slot-boundp object slot))
-	       (slot-value (if slot-bound
-			       (pcl:slot-value object slot)
-			       "Unbound")))
-	  (push
-	   (create-value-box view slot-label slot-value
-			     :callback #'inspect-object-callback
-			     :activep slot-bound)
-	   widgets)))
-      (apply #'manage-children label widgets))))
-
-(defun display-clos-pane (object)
-  (with-inspector-pane (object)
-    (let* ((class (pcl:class-of object))
-	   (slotds (pcl::slots-to-inspect class object))
-	   (view (create-row-column form "rowColumn"
-				    :left-attachment :attach-form
-				    :right-attachment :attach-form
-				    :top-attachment :attach-form
-				    :bottom-attachment :attach-form))
-	   instance-slots class-slots other-slots)
-
-      (dolist (slotd slotds)
-	(pcl:with-slots ((slot pcl::name) (allocation pcl::allocation))
-			slotd
-	  (case allocation
-	    (:instance (push slotd instance-slots))
-	    (:class (push slotd class-slots))
-	    (otherwise (push slotd other-slots))))
-	(when instance-slots
-	  (show-slot-list object instance-slots view t
-			  "Slots with Instance allocation:"))
-	(when class-slots
-	  (show-slot-list object class-slots view t
-			  "Slots with Class allocation:"))
-	(when other-slots
-	  (show-slot-list object other-slots view nil
-			  "Slots with Other allocation:"))))))
-
-
-
-;;;; Functions for creating the Motif inspector
-
-(defun start-motif-inspector (object)
-  (verify-system-server-exists)
-  (multiple-value-bind (shell connection)
-		       (create-interface-shell)
-    (declare (ignore shell))
-    (with-motif-connection (connection)
-      (verify-control-pane-displayed)
-      (display-inspector-pane object)
-      (inspector-add-history-item object)))
-  object)
-
-
-
-;;;; User visible INSPECT function
-
-;;; INSPECT -- Public.
-;;;
-(defun inspect (object)
-  "This function allows the user to interactively examine Lisp objects.
-   INTERFACE indicates whether this should run with a :graphics interface
-   or a :command-line oriented one; when running without X, there is no
-   choice.  Supplying :window, :windows, :graphics, :graphical, and :x gets
-   a windowing interface, and supplying :command-line or :tty gets the
-   other style."
-
-  (if (use-graphics-interface)
-      (start-motif-inspector object)
-      (inspect::tty-inspect object)))
diff --git a/interface/interface.lisp b/interface/interface.lisp
deleted file mode 100644
index 1a0e56f154a42e0460102a91364c64a5559cd70d..0000000000000000000000000000000000000000
--- a/interface/interface.lisp
+++ /dev/null
@@ -1,721 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Interface -*-
-;;;
-;;; This provides utilities used for building Lisp interface components
-;;; using the Motif toolkit.  Specifically, it is meant to be used by the
-;;; inspector and the debugger.
-
-(in-package "INTERFACE")
-
-
-
-;;;; Globally defined variables
-
-(defparameter entry-font-name "-adobe-helvetica-medium-r-normal--*-120-75-*")
-(defparameter header-font-name "-adobe-helvetica-bold-r-normal--*-120-75-*")
-(defparameter italic-font-name "-adobe-helvetica-medium-o-normal--*-120-75-*")
-
-
-(defvar *header-font*)
-(defvar *italic-font*)
-(defvar *entry-font*)
-(defvar *all-fonts*)
-
-(defvar *system-motif-server* nil)
-
-(defvar *lisp-interface-shell* nil)
-
-(defvar *lisp-interface-connection* nil)
-
-(defvar *lisp-interface-panes* nil)
-
-(defvar *lisp-interface-menus* nil)
-
-(defvar *busy-cursor*)
-
-
-;;; *INTERFACE-MODE* may be one of:
-;;;       :normal  -- normal interaction mode
-;;;       :edit    -- targetting object to edit
-;;;       :copy    -- targetting object to copy
-;;;       :paste   -- targetting object to copy into
-;;;
-(defvar *interface-mode* :normal)
-
-;;; This is where an object is stored when copied, and where paste looks to
-;;; find the value it needs to insert.
-;;;
-(defvar *copy-object* nil)
-
-(defvar *interface-style* :graphics
-  "This specifies the default interface mode for the debugger and inspector.
-   The allowable values are :GRAPHICS and :TTY.")
-
-
-
-;;;; Functions for dealing with interface widgets
-
-(defun create-interface-shell ()
-  (if *lisp-interface-shell*
-      (values *lisp-interface-shell* *lisp-interface-connection*)
-      (let ((con (xt::open-motif-connection
-		  *default-server-host* *default-display*
-		  "lisp" "Lisp"
-		  (and *system-motif-server*
-		       (ext:process-pid *system-motif-server*)))))
-	(with-motif-connection (con)
-	  (setf (xti:motif-connection-close-hook *motif-connection*)
-		#'close-connection-hook)
-	  (setf *header-font*
-		(build-simple-font-list "HeaderFont" header-font-name))
-	  (setf *italic-font*
-		(build-simple-font-list "ItalicFont" italic-font-name))
-	  (setf *entry-font*
-		(build-simple-font-list "EntryFont" entry-font-name))
-	  (setf *all-fonts*
-		(build-font-list `(("EntryFont" ,entry-font-name)
-				   ("HeaderFont" ,header-font-name)
- 				   ("ItalicFont" ,italic-font-name))))
-
-	  (let ((shell (create-application-shell
-			:default-font-list *entry-font*)))
-	    (setf *lisp-interface-panes* (make-hash-table))
-	    (setf *lisp-interface-menus* (make-hash-table :test #'equal))
-	    (setf *lisp-interface-connection* con)
-	    (setf *lisp-interface-shell* shell)
-	    (setf *busy-cursor* (xt:create-font-cursor 150))
-	    (values shell con))))))
-
-(declaim (inline popup-interface-pane))
-(defun popup-interface-pane (pane)
-  (declare (type widget pane))
-  (popup pane :grab-none))
-
-(defun create-interface-pane-shell (title tag)
-  (declare (simple-string title))
-  (let* ((shell *lisp-interface-shell*)
-	 (existing (gethash tag *lisp-interface-panes*))
-	 (pane (or existing
-		   (create-popup-shell "interfacePaneShell"
-				       :top-level-shell shell
-				       :default-font-list *entry-font*
-				       :keyboard-focus-policy :pointer
-				       :title title
-				       :icon-name title))))
-    (setf (gethash tag *lisp-interface-panes*) pane)
-    (values pane (not existing))))
-
-(defun find-interface-pane (tag)
-  (if *lisp-interface-panes*
-      (gethash tag *lisp-interface-panes*)))
-
-(defun destroy-interface-pane (tag)
-  (let ((pane (and *lisp-interface-panes*
-		   (gethash tag *lisp-interface-panes*))))
-    (when pane
-      (destroy-widget pane)
-      (remhash tag *lisp-interface-panes*))))
-
-
-
-;;;; Functions for dealing with menus
-
-;; `(("New" ,#'new-thing-callback this that)
-;;   ("Load" ,#'load-thing-callback loadee))
-
-(defun create-interface-menu (menu-bar name menu-spec)
-  (declare (simple-string name))
-  (let* ((pulldown (create-pulldown-menu menu-bar "pulldown"))
-	 (cascade (create-cascade-button menu-bar "cascade"
-					 :sub-menu-id pulldown
-					 :label-string name))
-	 (widgets))
-
-    (dolist (entry menu-spec)
-      (if (and entry (listp entry))
-	  (let ((widget (create-push-button-gadget pulldown "menuEntry"
-						   :label-string (car entry))))
-	    (when (cdr entry)
-	      (apply #'add-callback widget :activate-callback (cdr entry)))
-	    (push widget widgets))
-	  (let ((widget (create-separator-gadget pulldown "menuSeparator")))
-	    (push widget widgets))))
-    (apply #'manage-children widgets)
-    cascade))
-
-(defun create-cached-menu (menu-bar name &optional menu-spec)
-  (if menu-spec
-      (setf (gethash name *lisp-interface-menus*) menu-spec)
-      (setf menu-spec (gethash name *lisp-interface-menus*)))
-  (create-interface-menu menu-bar name menu-spec))
-
-(defun create-highlight-button (parent name label)
-  (create-push-button-gadget parent name
-			     :label-string label
-			     :highlight-on-enter t
-			     :shadow-thickness 0))
-
-
-
-;;;; Functions for making/changing value boxes
-
-(defparameter *string-cutoff* 60)
-
-(defun trim-string (string)
-  (declare (simple-string string))
-  (if (> (length string) *string-cutoff*)
-      (let ((new (make-string (+ 4 *string-cutoff*))))
-        (replace new string :end2 *string-cutoff*)
-        (replace new " ..." :start1 *string-cutoff*))
-      string))
-
-(defun print-for-widget-display (string arg)
-  (let ((*print-pretty* nil)
-	(*print-length* 20)
-	(*print-level* 2))
-    (trim-string (format nil string arg))))
-
-(defun create-value-box (parent name value
-			 &key callback client-data (activep t))
-  (let* ((rc (create-row-column parent "valueBox"
-				:margin-height 0
-				:margin-width 0
-				:orientation :horizontal))
-	 (label (create-label-gadget rc "valueLabel"
-				     :font-list *header-font*
-				     :label-string name))
-	 (button (if activep
-		     (create-highlight-button rc "valueObject"
-					      (print-for-widget-display
-					       "~S" value))
-		     (create-label-gadget rc "valueObject"
-					  :font-list *italic-font*
-					  :label-string
-					  (format nil "~A" value)))))
-    (manage-children label button)
-    (when (and callback activep)
-      (add-callback button :activate-callback
-		    callback (or client-data value)))
-    rc))
-
-(defmacro with-widget-children ((this-child widget) &rest clauses)
-  `(let ((children (xti:widget-children ,widget)))
-     (dolist (,this-child children)
-       ,(cons 'case
-	      (cons `(xti:widget-type ,this-child) clauses)))))
-
-(defun set-value-box (vbox name value &key callback client-data)
-  (with-widget-children (child vbox)
-    (:push-button-gadget
-     (set-values child :label-string
-		 (print-for-widget-display "~S" value))
-     (remove-all-callbacks child :activate-callback)
-     (when callback
-       (add-callback child :activate-callback callback (or client-data value))))
-    (:label-gadget
-     (set-values child :label-string name))))
-
-
-
-;;;; Misc. stuff
-
-(defun nuke-interface ()
-  (with-motif-connection (*lisp-interface-connection*)
-    (quit-application)))
-
-(defun interface-error (text &optional (pane *lisp-interface-shell*))
-  (declare (simple-string text))
-  (multiple-value-bind
-      (dialog shell)
-      (create-error-dialog pane "lispInterfaceError" :message-string text)
-    (set-values shell :title "Error")
-    (manage-child dialog)))
-
-(defmacro with-busy-cursor ((pane) &body forms)
-  `(let ((window (widget-window ,pane)))
-     (unwind-protect
-	 (progn
-	   (with-clx-requests (setf (xlib:window-cursor window) *busy-cursor*))
-	   ,@forms)
-       (setf (xlib:window-cursor window) :none))))
-
-(defmacro grab-output-as-string (&body forms)
-  `(let* ((stream (make-string-output-stream))
-	  (*standard-output* stream)
-	  (value (progn ,@forms)))
-     (close stream)
-     (values (get-output-stream-string stream) value)))
-
-(defun ask-for-confirmation (pane message callback)
-  (declare (simple-string message))
-  (multiple-value-bind
-      (dialog shell)
-      (create-question-dialog pane "lispConfirmation" :message-string message)
-    (set-values shell :title "Are You Sure?")
-    (add-callback dialog :ok-callback callback)
-    (manage-child dialog)))
-
-(defun use-graphics-interface (&optional (kind *interface-style*))
-  (cond
-   ((and (member kind '(:window :windows :graphics :graphical :x))
-	 (assoc :display ext:*environment-list*))
-    t)
-   ((member kind '(:command-line :tty)) nil)
-   (t
-    (error "Interface specification must be one of :window, :windows, ~%~
-	    :graphics, :graphical, :x, :command-line, or :tty -- ~%~
-	    not ~S." kind))))
-
-(defun close-connection-hook (connection)
-  (declare (ignore connection))
-  (setf *lisp-interface-panes* nil)
-  (setf *lisp-interface-menus* nil)
-  (setf *lisp-interface-connection* nil)
-  (setf *lisp-interface-shell* nil))
-
-(defun system-server-status-hook (process)
-  (let ((status (ext:process-status process)))
-    (when (or (eq status :exited)
-	      (eq status :signaled))
-      (setf *system-motif-server* nil))))
-
-(defun verify-system-server-exists ()
-  (when (and (not xt:*default-server-host*)
-	     (or (not *system-motif-server*)
-		 (and *system-motif-server*
-		      (not (ext:process-alive-p *system-motif-server*)))))
-    (let ((process (ext:run-program (merge-pathnames *clm-binary-name*
-						     *clm-binary-directory*)
-				    '("-nofork" "-local")
-				    :wait nil
-				    :status-hook #'system-server-status-hook)))
-      (unless (and process (ext:process-alive-p process))
-	(xti:toolkit-error "Could not start Motif server process."))
-      ;;
-      ;; Wait until the server has started up
-      (loop
-	(when (probe-file (format nil "/tmp/.motif_socket-p~a"
-				  (ext:process-pid process)))
-	  (return))
-	(sleep 2))
-      (setf *system-motif-server* process))))
-
-
-
-;;;; Handling of the Inspector items in the Control Panel
-
-(defconstant *history-size* 25)
-
-(defvar *inspector-history*)
-
-(defstruct (inspector-history
-	    (:print-function print-inspector-history)
-	    (:conc-name history-)
-	    (:constructor make-inspector-history (widget)))
-  (record (make-array *history-size*) :type simple-vector)
-  (head 0 :type fixnum)
-  (tail 0 :type fixnum)
-  (widget nil :type (or nil widget)))
-
-(defun print-inspector-history (hist stream d)
-  (declare (ignore hist d))
-  (write-string "#<Inspector History>" stream))
-
-(defun inspector-add-history-item (object)
-  (let* ((h *inspector-history*)
-	 (tail (history-tail h))
-	 (head (history-head h))
-	 (widget (history-widget h)))
-    ;;
-    ;; Only add new items to the history if they're not there already
-    (unless (position object (history-record h))
-      (setf (svref (history-record h) tail) object)
-      (setf tail (mod (1+ tail) *history-size*))
-      (setf (history-tail h) tail)
-      ;;
-      ;; Add new item at the top of the history list
-      (list-add-item widget (print-for-widget-display "~S" object) 1)
-      (when (= tail head)
-	(setf (history-head h) (mod (1+ head) *history-size*))
-	;;
-	;; Nuke old item at bottom of history
-	(list-delete-pos widget 0)))))
-
-(defun eval-and-inspect-callback (widget call-data pane)
-  (declare (ignore call-data))
-  (let ((input (car (get-values widget :value))))
-    (handler-case
-	(let ((object (eval (read-from-string input))))
-	  (with-busy-cursor (pane)
-	    (text-set-string widget "")
-	    (display-inspector-pane object)
-	    (inspector-add-history-item object)))
-      (error (e)
-        (interface-error (format nil "~a" e) (xti:widget-user-data widget))))))
-
-(defun inspector-history-callback (widget call-data pane)
-  (let* ((pos (list-callback-item-position call-data))
-	 (object (svref (history-record *inspector-history*)
-			(mod (- (history-tail *inspector-history*) pos)
-			     *history-size*))))
-    (with-busy-cursor (pane)
-      (update-display widget)
-      (display-inspector-pane object)
-      (list-deselect-pos widget pos))))
-
-
-
-;;;; The CLOS generic functions for the inspector
-
-(defgeneric inspector-pane-title (object)
-  (:documentation
-   "Returns a string which is meant to be the title of the inspection pane
-    displaying the given object."))
-
-(defgeneric display-inspector-pane (object)
-  (:documentation
-   "Creates a window pane which displays relevant information about the
-    given object."))
-
-
-
-;;;; Build the Lisp Control Panel
-
-(defconstant *control-cookie* (cons :lisp :control))
-
-(defvar *file-selection-hook* #'load)
-
-(defvar *file-list* nil)
-
-(defun file-selection-callback (widget call-data)
-  (declare (ignore widget))
-  (let ((string (compound-string-get-ltor
-		 (file-selection-callback-value call-data) "")))
-    (with-callback-deferred-actions
-      (funcall *file-selection-hook* string))))
-
-(defun add-file-callback (widget call-data fsel files)
-  (declare (ignore widget call-data))
-  (setf *file-selection-hook*
-	#'(lambda (fname)
-	    (let* ((base-name (pathname-name fname))
-		   (path (directory-namestring fname))
-		   (name (format nil "~a~a" path base-name))
-		   (xs (compound-string-create
-		       (format nil "~a  ~a" base-name path) "")))
-	      (list-add-item files xs 1)
-	      (push (cons name xs) *file-list*))))
-  (manage-child fsel))
-
-
-(defun remove-files-callback (widget call-data files)
-  (declare (ignore widget call-data))
-  (let ((selections (list-get-selected-pos files))
-	(items))
-    (dolist (pos selections)
-      (let ((item (elt *file-list* (1- pos))))
-	(list-delete-item files (cdr item))
-	(push item items)))
-
-    (dolist (item items)
-      (setf *file-list* (delete item *file-list*)))))
-
-(defun load-files-callback (widget call-data files)
-  (declare (ignore widget call-data))
-  (let ((selections (list-get-selected-pos files)))
-    (with-callback-deferred-actions
-      (dolist (pos selections)
-	(load (car (elt *file-list* (1- pos))))))))
-
-(defun compile-files-callback (widget call-data files)
-  (declare (ignore widget call-data))
-  (let ((selections (list-get-selected-pos files)))
-    (with-callback-deferred-actions
-      (with-compilation-unit ()
-	(dolist (pos selections)
-	  (compile-file (car (elt *file-list* (1- pos)))))))))
-
-(defun apropos-callback (widget call-data pane)
-  (declare (ignore call-data))
-  (with-busy-cursor (pane)
-    (let* ((input (car (get-values widget :value)))
-	   (results (apropos-list input)))
-      (text-set-string widget "")
-      (multiple-value-bind (form shell)
-			   (create-form-dialog pane "aproposDialog")
-	(let* ((done (create-push-button-gadget form "aproposDone"
-						:left-attachment :attach-form
-						:right-attachment :attach-form
-						:label-string "Done"))
-	       (list (create-scrolled-list form "aproposList"
-					   :visible-item-count 10
-					   :left-attachment :attach-form
-					   :right-attachment :attach-form
-					   :bottom-attachment :attach-form
-					   :top-attachment :attach-widget
-					   :top-widget done)))
-	  (set-values shell :title "Apropos Results"
-	                    :keyboard-focus-policy :pointer)
-	  (dolist (sym results)
-	    (list-add-item list (symbol-name sym) 0))
-	  (add-callback done :activate-callback #'destroy-callback shell)
-	  (add-callback list :browse-selection-callback
-			#'(lambda (w c) (declare (ignore w))
-			    (with-busy-cursor (shell)
-			      (let ((pos (list-callback-item-position c)))
-				(inspect (elt results (1- pos)))))))
-	  (manage-child done)
-	  (manage-child list)
-	  (manage-child form))))))
-
-(defun about-callback (widget call-data pane)
-  (declare (ignore widget call-data))
-  (multiple-value-bind
-      (msg shell)
-      (create-message-dialog pane "aboutDialog"
-			     :dialog-title "About Lisp"
-			     :message-string (grab-output-as-string
-					    (print-herald)))
-    (declare (ignore shell))
-    (let ((help (message-box-get-child msg :dialog-help-button))
-	  (cancel (message-box-get-child msg :dialog-cancel-button)))
-      (destroy-widget help)
-      (destroy-widget cancel)
-      (manage-child msg))))
-
-(defun set-compile-policy-callback (widget call-data speed space safety
-					   debug cspeed brevity)
-  (declare (ignore widget call-data))
-  (flet ((get-policy-value (widget)
-	   (coerce (/ (car (get-values widget :value)) 10) 'single-float)))
-    (let ((speed-val (get-policy-value speed))
-	  (space-val (get-policy-value space))
-	  (safety-val (get-policy-value safety))
-	  (debug-val (get-policy-value debug))
-	  (cspd-val (get-policy-value cspeed))
-	  (brev-val (get-policy-value brevity)))
-
-      (proclaim (list 'optimize
-		      (list 'speed speed-val)
-		      (list 'space space-val)
-		      (list 'safety safety-val)
-		      (list 'debug debug-val)
-		      (list 'compilation-speed cspd-val)
-		      (list 'ext:inhibit-warnings brev-val))))))
-
-(defun compile-policy-callback (widget call-data pane)
-  (declare (ignore widget call-data))
-  (multiple-value-bind (form shell)
-		       (create-form-dialog pane "compilationDialog")
-    (flet ((create-policy (parent title value)
-	     (create-scale parent "policy"
-			   :decimal-points 1
-			   :orientation :horizontal
-			   :maximum 30
-			   :show-value t
-			   :title-string title
-			   :value (truncate (* 10 value)))))
-      (let* ((cookie c::*default-cookie*)
-	     (rc (create-row-column form "policies"
-				    :packing :pack-column
-				    :num-columns 2))
-	     (speed (create-policy rc "Speed" (c::cookie-speed cookie)))
-	     (space (create-policy rc "Space" (c::cookie-space cookie)))
-	     (safety (create-policy rc "Safety" (c::cookie-safety cookie)))
-	     (debug (create-policy rc "Debug" (c::cookie-debug cookie)))
-	     (cspeed (create-policy rc "Compilation Speed"
-				    (c::cookie-cspeed cookie)))
-	     (brevity (create-policy rc "Inhibit Warnings"
-				     (c::cookie-brevity cookie)))
-	     (sep (create-separator-gadget form "separator"
-					   :top-attachment :attach-widget
-					   :top-widget rc
-					   :left-attachment :attach-form
-					   :right-attachment :attach-form))
-	     (done (create-push-button-gadget form "done"
-					    :label-string "Done"
-					    :top-attachment :attach-widget
-					    :top-widget sep
-					    :left-attachment :attach-position
-					    :right-attachment :attach-position
-					    :left-position 35
-					    :right-position 65)))
-	(set-values shell :title "Compilation Options"
-		    :keyboard-focus-policy :pointer)
-	(add-callback done :activate-callback
-		      'set-compile-policy-callback
-		      speed space safety debug cspeed brevity)
-	(manage-children speed space safety debug cspeed brevity)
-	(manage-children sep done rc)
-	(manage-child form)))))
-
-(defun display-control-pane ()
-  (let* ((pane (create-interface-pane-shell (lisp-implementation-type)
-					    *control-cookie*))
-	 (form (create-form pane "form"))
-	 (fsel (create-file-selection-dialog pane "lispFileSelector"
-					     :auto-unmanage t))
-	 (menu-bar (create-menu-bar form "lispMenu"
-				    :left-attachment :attach-form
-				    :right-attachment :attach-form))
-	 (lmenu (create-interface-menu
-		 menu-bar "Lisp"
-		 `(("About ..." about-callback ,pane)
-		   "-----"
-		   ("Load File" ,#'(lambda (w c)
-				     (declare (ignore w c))
-				     (setf *file-selection-hook* #'load)
-				     (manage-child fsel)))
-		   ("Compile File" ,#'(lambda (w c) (declare (ignore w c))
-					(setf *file-selection-hook*
-					      #'compile-file)
-					(manage-child fsel)))
-		   "-----"
-		   ("Close Control Panel" ,#'popdown-callback ,pane)
-		   ("Quit Lisp" ,#'(lambda (w c pane)
-				     (declare (ignore w c))
-				     (ask-for-confirmation
-				      pane "Do you really want to quit?"
-				      #'(lambda (w c) (declare (ignore w c))
-					  (xt::quit-server)
-					  (quit))))
-		    ,pane))))
-	 (fmenu (create-interface-menu
-		 menu-bar "Files"
-		 `(("Load File Group")
-		   ("Save File Group"))))
-	 (omenu (create-interface-menu
-		 menu-bar "Options"
-		 `(("Compilation policy ..." compile-policy-callback ,pane))))
-	 (vsep (create-separator form "separator"
-				 :orientation :vertical
-				 :top-attachment :attach-widget
-				 :top-widget menu-bar
-				 :bottom-attachment :attach-form
-				 :right-attachment :attach-position
-				 :right-position 50))
-	 (prompt (create-label-gadget form "inspectPrompt"
-				      :top-attachment :attach-widget
-				      :top-widget menu-bar
-				      :font-list *header-font*
-				      :label-string "Inspect new object:"))
-	 (entry (create-text form "inspectEval"
-			     :top-attachment :attach-widget
-			     :top-widget prompt
-			     :left-offset 4
-			     :right-offset 4
-			     :left-attachment :attach-form
-			     :right-attachment :attach-widget
-			     :right-widget vsep))
-	 (hlabel (create-label-gadget form "inspectHistoryLabel"
-				      :top-attachment :attach-widget
-				      :top-widget entry
-				      :font-list *header-font*
-				      :label-string "Inspector History:"))
-	 (hview (create-scrolled-list form "inspectHistory"
-				      :visible-item-count 5
-				      :left-offset 4
-				      :right-offset 4
-				      :bottom-offset 4
-				      :top-attachment :attach-widget
-				      :top-widget hlabel
-				      :left-attachment :attach-form
-				      :right-attachment :attach-widget
-				      :right-widget vsep
-				      :bottom-attachment :attach-form))
-	 (flabel (create-label-gadget form "filesLabel"
-				      :left-attachment :attach-widget
-				      :left-widget vsep
-				      :top-attachment :attach-widget
-				      :top-widget menu-bar
-				      :label-string "Files:"
-				      :font-list *header-font*))
-	 (frc (create-row-column form "filesButtons" 
-				 :packing :pack-column
-				 :num-columns 2
-				 :left-attachment :attach-widget
-				 :left-widget vsep
-				 :top-attachment :attach-widget
-				 :top-widget flabel
-				 :right-attachment :attach-form
-				 :right-offset 4))
-	 (add (create-push-button-gadget frc "fileAdd"
-					 :label-string "Add File"))
-	 (remove (create-push-button-gadget frc "fileRemove"
-					    :label-string "Remove Files"))
-	 (load (create-push-button-gadget frc "fileLoad"
-					  :label-string "Load Files"))
-	 (compile (create-push-button-gadget frc "fileCompile"
-					     :label-string "Compile Files"))
-	 (apropos (create-text form "apropos"
-			       :left-attachment :attach-widget
-			       :left-widget vsep
-			       :right-attachment :attach-form
-			       :bottom-attachment :attach-form
-			       :left-offset 4
-			       :right-offset 4
-			       :bottom-offset 4))
-	 (alabel (create-label-gadget form "aproposLabel"
-				      :label-string "Apropos:"
-				      :font-list *header-font*
-				      :left-attachment :attach-widget
-				      :left-widget vsep
-				      :bottom-attachment :attach-widget
-				      :bottom-widget apropos))
-	 (hsep (create-separator-gadget form "separator"
-					:left-attachment :attach-widget
-					:left-widget vsep
-					:right-attachment :attach-form
-					:bottom-attachment :attach-widget
-					:bottom-widget alabel))
-	 (files (create-scrolled-list form "files"
-				      :visible-item-count 5
-				      :selection-policy :multiple-select
-				      :top-attachment :attach-widget
-				      :top-widget frc
-				      :left-attachment :attach-widget
-				      :left-widget vsep
-				      :left-offset 4
-				      :right-attachment :attach-form
-				      :right-offset 4
-				      :bottom-attachment :attach-widget
-				      :bottom-widget hsep
-				      :bottom-offset 4)))
-				      
-    (manage-child form)
-    (manage-children lmenu fmenu omenu)
-    (manage-child files)
-    (manage-children menu-bar vsep prompt entry hlabel flabel frc
-		     apropos alabel hsep)
-    (manage-children add remove load compile)
-    (manage-child hview)
-    (set-values fmenu :sensitive nil)
-
-    (setf *inspector-history* (make-inspector-history hview))
-    (setf (xti:widget-user-data entry) pane)
-
-    (add-callback entry :activate-callback #'eval-and-inspect-callback pane)
-    (add-callback hview :browse-selection-callback
-		  #'inspector-history-callback pane)
-    (add-callback fsel :ok-callback 'file-selection-callback)
-    (add-callback add :activate-callback 'add-file-callback fsel files)
-    (add-callback remove :activate-callback 'remove-files-callback files)
-    (add-callback load :activate-callback 'load-files-callback files)
-    (add-callback compile :activate-callback 'compile-files-callback files)
-    (add-callback apropos :activate-callback 'apropos-callback pane)
-    (popup-interface-pane pane)
-    pane))
-
-(defun verify-control-pane-displayed ()
-  (let ((pane (find-interface-pane *control-cookie*)))
-    (unless pane
-      (setf pane (display-control-pane)))
-    (unless (is-managed pane)
-      (popup-interface-pane pane))))
-
-(defun lisp-control-panel ()
-  (verify-system-server-exists)
-  (multiple-value-bind (shell connection)
-		       (create-interface-shell)
-    (declare (ignore shell))
-    (with-motif-connection (connection)
-      (verify-control-pane-displayed))))
diff --git a/ldb/Makefile.boot b/ldb/Makefile.boot
deleted file mode 100644
index 0dd96b77d9022559bea54b4f96d094bbe3f0d228..0000000000000000000000000000000000000000
--- a/ldb/Makefile.boot
+++ /dev/null
@@ -1,8 +0,0 @@
-# Makefile for generating the real Makefile.
-# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/Makefile.boot,v 1.3 1991/11/08 00:22:04 wlott Exp $
-#
-
-Makefile: Makefile.orig
-	/usr/cs/lib/cpp < Makefile.orig > Makefile.NEW
-	mv Makefile.NEW Makefile
-	make depend
diff --git a/ldb/Makefile.orig b/ldb/Makefile.orig
deleted file mode 100644
index 55b30e5b00c7d6c674927dd90d16cbff45e2e65a..0000000000000000000000000000000000000000
--- a/ldb/Makefile.orig
+++ /dev/null
@@ -1,153 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/Makefile.orig,v 1.29 1992/03/06 12:39:06 wlott Exp $ */
-INCLS = -I. -I/usr/misc/.X11/include
-
-SRCS = ldb.c egets.c coreparse.c alloc.c monitor.c print.c \
-	os.c os-common.c arch.c vars.c assem.s parse.c interrupt.c test.c \
-	search.c validate.c gc.c globals.c dynbind.c breakpoint.c \
-	regnames.c backtrace.c bitbash.c save.c purify.c socket.c
-
-OBJS = ldb.o egets.o coreparse.o alloc.o monitor.o print.o \
-	os.o os-common.o arch.o vars.o assem.o parse.o interrupt.o test.o \
-	search.o validate.o gc.o globals.o dynbind.o breakpoint.o \
-	regnames.o backtrace.o bitbash.o save.o purify.o socket.o
-
-#ifdef mips
-CFLAGS = -O ${INCLS}
-UNDEFSYMPATTERN=&
-ASSEMFILE='mips-assem.s'
-ARCH_SRC="mips-arch.c"
-#endif
-
-#ifdef ibmrt
-CFLAGS = -g ${INCLS}
-UNDEFSYMPATTERN=_&
-ASSEMFILE='rt-assem.s'
-ARCH_SRC="rt-arch.c"
-#endif
-
-#ifdef sparc
-CFLAGS = -O ${INCLS}
-UNDEFSYMPATTERN=_&
-ASSEMFILE='sparc-assem.s'
-ARCH_SRC="sparc-arch.c"
-#endif
-
-#ifdef MACH
-OS_SRC=mach-os.c
-OS_LINK_FLAGS=
-OS_SRCS=
-OS_OBJS=
-OS_LIBS=-lmach
-CPP=/usr/cs/lib/cpp
-#else
-#ifdef sun
-OS_SRC=sunos-os.c
-OS_LINK_FLAGS=-Bstatic
-OS_SRCS=fake-mach.c
-OS_OBJS=fake-mach.o
-OS_LIBS=
-#endif
-CPP=/lib/cpp
-#endif
-
-
-all: ldb.map
-
-ldb.map: ldb
-	echo -n 'Map file for ldb version ' > ldb.map
-	cat version >> ldb.map
-	nm -gp ldb >> ldb.map
-
-
-ldb: ${OBJS} ${OS_OBJS} version undefineds
-	echo -n '1 + ' | cat - version | bc > ,version
-	mv ,version version
-	cc ${CFLAGS} -DVERSION=`cat version` -c version.c
-	cc ${OS_LINK_FLAGS} `cat undefineds` -o ,ldb \
-		${OBJS} ${OS_OBJS} version.o \
-		${OS_LIBS} -lm -lc
-	mv -f ,ldb ldb
-
-version:
-	echo 0 > version
-
-undefineds: undefineds.src
-	${CPP} undefineds.src | \
-	sed -e '/^#/d' -e '/^[ 	]*$$/d' -e 's/.*/-u ${UNDEFSYMPATTERN}/' | \
-	sort -u > ,undefineds
-	mv ,undefineds undefineds
-
-assem.s:
-	rm -f assem.s
-	ln -s ${ASSEMFILE} assem.s
-
-os.c:
-	rm -f os.c
-	ln -s ${OS_SRC} os.c
-
-arch.c:
-	rm -f arch.c
-	ln -s ${ARCH_SRC} arch.c
-
-#ifdef mips
-
-/* MIPS specific stuff. */
-
-/* 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. */
-
-arch.o: arch.c
-	cc ${CFLAGS} -G 0 -c arch.c
-interrupt.o: interrupt.c
-	cc ${CFLAGS} -G 0 -c interrupt.c
-
-assem.o: assem.s lisp.h lispregs.h globals.h
-	as -G 0 -o $@ assem.s
-
-#endif
-
-#ifdef ibmrt
-
-assem.o: assem.s
-	${CPP} assem.s | as -o assem.o
-
-#endif
-
-
-#ifdef sparc
-
-/* We need this shit because as runs the wrong preprocessor. */
-#ifdef MACH
-ASSEMDEFS=-DMACH
-#else
-ASSEMDEFS=-UMACH
-#endif
-
-assem.o: assem.s lisp.h lispregs.h globals.h
-	as -P ${ASSEMDEFS} -o $@ assem.s
-
-#endif
-
-
-socket.o: socket.c
-	cc ${CFLAGS} -DUNIXCONN -c socket.c
-
-lisp.h:
-	@echo "You must run genesis to create lisp.h!"
-	@false
-
-clean:
-	rm -f lisp.h os.c arch.c assem.s undefineds *.o ldb ldb.map
-
-depend: depends
-
-depends: os.c arch.c assem.s
-	rm -f Makefile.BAK
-	ln Makefile Makefile.BAK
-	sed -n '1,/^\/\*@/p' Makefile > Makefile.NEW
-	cc -M ${INCLS} ${SRCS} ${OS_SRCS} | egrep -v ' /usr/' >> Makefile.NEW
-	mv Makefile.NEW Makefile
-	rm Makefile.BAK
-
-/*@ Do not edit anything after this line. */
diff --git a/ldb/alloc.c b/ldb/alloc.c
deleted file mode 100644
index 32eab57741a5d659d3a7b5890e003f2d72102e6d..0000000000000000000000000000000000000000
--- a/ldb/alloc.c
+++ /dev/null
@@ -1,122 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/alloc.c,v 1.7 1991/10/22 18:36:50 wlott Exp $ */
-#include "lisp.h"
-#include "ldb.h"
-#include "alloc.h"
-#include "globals.h"
-
-#ifdef ibmrt
-#define GET_FREE_POINTER() ((lispobj *)SymbolValue(ALLOCATION_POINTER))
-#define SET_FREE_POINTER(new_value) \
-    (SetSymbolValue(ALLOCATION_POINTER,(lispobj)(new_value)))
-#define GET_GC_TRIGGER() ((lispobj *)SymbolValue(INTERNAL_GC_TRIGGER))
-#define SET_GC_TRIGGER(new_value) \
-    (SetSymbolValue(INTERNAL_GC_TRIGGER,(lispobj)(new_value)))
-#else
-#define GET_FREE_POINTER() current_dynamic_space_free_pointer
-#define SET_FREE_POINTER(new_value) \
-    (current_dynamic_space_free_pointer = (new_value))
-#define GET_GC_TRIGGER() current_auto_gc_trigger
-#define SET_GC_TRIGGER(new_value) \
-    clear_auto_gc_trigger(); set_auto_gc_trigger(new_value);
-#endif
-
-
-
-/****************************************************************
-Allocation Routines.
-****************************************************************/
-
-static lispobj *alloc(bytes)
-int bytes;
-{
-    lispobj *result;
-
-    /* Round to dual word boundry. */
-    bytes = (bytes + lowtag_Mask) & ~lowtag_Mask;
-
-    result = GET_FREE_POINTER();
-    SET_FREE_POINTER(result + (bytes / sizeof(lispobj)));
-
-    if (GET_GC_TRIGGER() && GET_FREE_POINTER() > GET_GC_TRIGGER()) {
-	SET_GC_TRIGGER((char *)GET_FREE_POINTER()
-		       - (char *)current_dynamic_space);
-    }
-
-    return result;
-}
-
-lispobj *alloc_unboxed(type, words)
-int type, words;
-{
-    lispobj *result;
-
-    result = alloc((1 + words) * sizeof(lispobj));
-
-    *result = (lispobj) (words << type_Bits) | type;
-
-    return result;
-}
-
-lispobj alloc_vector(type, length, size)
-int type, length, size;
-{
-    struct vector *result;
-
-    result = (struct vector *)alloc((2 + (length*size + 31) / 32) * sizeof(lispobj));
-
-    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;
-
-	return (lispobj) ptr | type_OtherPointer;
-    }
-}
-
-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, 1);
-
-    sap->pointer = ptr;
-
-    return (lispobj) sap | type_OtherPointer;
-}
-
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/arch.h b/ldb/arch.h
deleted file mode 100644
index cc363b0f44bbc9117b171c5e0e36b74f08bcca3b..0000000000000000000000000000000000000000
--- a/ldb/arch.h
+++ /dev/null
@@ -1,8 +0,0 @@
-#ifndef __ARCH_H__
-#define __ARCH_H__
-
-extern char *arch_init();
-extern void arch_skip_instruction();
-extern os_vm_address_t arch_get_bad_addr();
-
-#endif /* __ARCH_H__ */
diff --git a/ldb/backtrace.c b/ldb/backtrace.c
deleted file mode 100644
index 1f0b3a1faa1e0504cd517874664da31fb30e9916..0000000000000000000000000000000000000000
--- a/ldb/backtrace.c
+++ /dev/null
@@ -1,222 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/backtrace.c,v 1.7 1990/10/22 12:38:28 wlott Exp $
- *
- * Simple backtrace facility.  More or less from Rob's lisp version.
- */
-
-#include <stdio.h>
-#include <signal.h>
-#include "ldb.h"
-#include "lisp.h"
-#include "globals.h"
-#include "interrupt.h"
-#include "lispregs.h"
-
-/* Sigh ... I know what the call frame looks like and it had
-   better not change. */
-
-struct call_frame {
-	struct call_frame *old_cont;
-	lispobj saved_lra;
-        lispobj code;
-	lispobj other_state[5];
-};
-
-struct call_info {
-    struct call_frame *frame;
-    int interrupted;
-    struct code *code;
-    lispobj lra;
-    int pc; /* Note: this is the trace file offset, not the actual pc. */
-};
-
-#define HEADER_LENGTH(header) ((header)>>8)
-
-static struct code *
-code_pointer(object)
-lispobj object;
-{
-    lispobj *headerp, header;
-    int type, len;
-
-    headerp = (lispobj *) PTR(object);
-    header = *headerp;
-    type = TypeOf(header);
-
-    switch (type) {
-        case type_CodeHeader:
-            break;
-        case type_ReturnPcHeader:
-        case type_FunctionHeader:
-        case type_ClosureFunctionHeader:
-            len = HEADER_LENGTH(header);
-            if (len == 0)
-                headerp = NULL;
-            else
-                headerp -= len;
-            break;
-        default:
-            headerp = NULL;
-    }
-
-    return (struct code *) headerp;
-}
-
-static
-cs_valid_pointer_p(pointer)
-struct call_frame *pointer;
-{
-	return (((char *) control_stack <= (char *) pointer) &&
-		((char *) pointer < (char *) current_control_stack_pointer));
-}
-
-static void
-info_from_lisp_state(info)
-struct call_info *info;
-{
-    info->frame = (struct call_frame *)current_control_frame_pointer;
-    info->interrupted = 0;
-    info->code = NULL;
-    info->lra = 0;
-    info->pc = 0;
-
-    previous_info(info);
-}
-
-static void
-info_from_sigcontext(info, csp)
-struct call_info *info;
-struct sigcontext *csp;
-{
-    unsigned long pc;
-
-    info->interrupted = 1;
-    if (LowtagOf(csp->sc_regs[CODE]) == type_FunctionPointer) {
-        /* We tried to call a function, but crapped out before $CODE could be fixed up.  Probably an undefined function. */
-        info->frame = (struct call_frame *)csp->sc_regs[OCFP];
-        info->lra = (lispobj)csp->sc_regs[LRA];
-        info->code = code_pointer(info->lra);
-        pc = (unsigned long)PTR(info->lra);
-    }
-    else {
-        info->frame = (struct call_frame *)csp->sc_regs[CFP];
-        info->code = code_pointer(csp->sc_regs[CODE]);
-        info->lra = NIL;
-        pc = csp->sc_pc;
-    }
-    if (info->code != NULL)
-        info->pc = pc - (unsigned long) info->code -
-            (HEADER_LENGTH(info->code->header) * sizeof(lispobj));
-    else
-        info->pc = 0;
-}
-
-static int
-previous_info(info)
-struct call_info *info;
-{
-    struct call_frame *this_frame;
-    int free;
-    struct sigcontext *csp;
-
-    if (!cs_valid_pointer_p(info->frame)) {
-        printf("Bogus callee value (0x%08x).\n", (unsigned long)info->frame);
-        return 0;
-    }
-
-    this_frame = info->frame;
-    info->lra = this_frame->saved_lra;
-    info->frame = this_frame->old_cont;
-    info->interrupted = 0;
-
-    if (info->frame == NULL || info->frame == this_frame)
-        return 0;
-
-    if (info->lra == NIL) {
-        /* We were interrupted.  Find the correct sigcontext. */
-        free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
-        while (free-- > 0) {
-            csp = lisp_interrupt_contexts[free];
-            if ((struct call_frame *)(csp->sc_regs[CFP]) == info->frame) {
-                info_from_sigcontext(info, csp);
-                break;
-            }
-        }
-    }
-    else {
-        info->code = code_pointer(info->lra);
-        if (info->code != NULL)
-            info->pc = (unsigned long)PTR(info->lra) -
-                (unsigned long)info->code -
-                (HEADER_LENGTH(info->code->header) * sizeof(lispobj));
-        else
-            info->pc = 0;
-    }
-
-    return 1;
-}
-
-void
-backtrace(nframes)
-int nframes;
-{
-    struct call_info info;
-	
-    info_from_lisp_state(&info);
-
-    do {
-        printf("<Frame 0x%08x%s, ", (unsigned long) info.frame,
-                info.interrupted ? " [interrupted]" : "");
-        
-        if (info.code != (struct code *) 0) {
-            lispobj function;
-
-            printf("CODE: 0x%08x, ", (unsigned long) info.code | type_OtherPointer);
-
-            function = info.code->entry_points;
-            while (function != NIL) {
-                struct function_header *header;
-                lispobj name;
-
-                header = (struct function_header *) PTR(function);
-                name = header->name;
-
-                if (LowtagOf(name) == type_OtherPointer) {
-                    lispobj *object;
-
-                    object = (lispobj *) PTR(name);
-
-                    if (TypeOf(*object) == type_SymbolHeader) {
-                        struct symbol *symbol;
-
-                        symbol = (struct symbol *) object;
-                        object = (lispobj *) PTR(symbol->name);
-                    }
-                    if (TypeOf(*object) == type_SimpleString) {
-                        struct vector *string;
-
-                        string = (struct vector *) object;
-                        printf("%s, ", (char *) string->data);
-                    } else
-                        printf("(Not simple string???), ");
-                } else
-                    printf("(Not other pointer???), ");
-
-
-                function = header->next;
-            }
-        }
-        else
-            printf("CODE: ???, ");
-
-        if (info.lra != NIL)
-            printf("LRA: 0x%08x, ", (unsigned long)info.lra);
-        else
-            printf("<no LRA>, ");
-
-        if (info.pc)
-            printf("PC: 0x%x>\n", info.pc);
-        else
-            printf("PC: ???>\n");
-
-    } while (--nframes > 0 && previous_info(&info));
-}
diff --git a/ldb/bitbash.c b/ldb/bitbash.c
deleted file mode 100644
index 0e7314344896f4222fe0a748bbe99f5a7b36c1c8..0000000000000000000000000000000000000000
--- a/ldb/bitbash.c
+++ /dev/null
@@ -1,72 +0,0 @@
-
-unsigned long bit_bash_low_masks[] = {
-    0x00000000,
-    0x00000001,
-    0x00000003,
-    0x00000007,
-    0x0000000f,
-    0x0000001f,
-    0x0000003f,
-    0x0000007f,
-    0x000000ff,
-    0x000001ff,
-    0x000003ff,
-    0x000007ff,
-    0x00000fff,
-    0x00001fff,
-    0x00003fff,
-    0x00007fff,
-    0x0000ffff,
-    0x0001ffff,
-    0x0003ffff,
-    0x0007ffff,
-    0x000fffff,
-    0x001fffff,
-    0x003fffff,
-    0x007fffff,
-    0x00ffffff,
-    0x01ffffff,
-    0x03ffffff,
-    0x07ffffff,
-    0x0fffffff,
-    0x1fffffff,
-    0x3fffffff,
-    0x7fffffff,
-    0xffffffff
-};
-
-unsigned long bit_bash_high_masks[] = {
-    0x00000000,
-    0x80000000,
-    0xc0000000,
-    0xe0000000,
-    0xf0000000,
-    0xf8000000,
-    0xfc000000,
-    0xfe000000,
-    0xff000000,
-    0xff800000,
-    0xffc00000,
-    0xffe00000,
-    0xfff00000,
-    0xfff80000,
-    0xfffc0000,
-    0xfffe0000,
-    0xffff0000,
-    0xffff8000,
-    0xffffc000,
-    0xffffe000,
-    0xfffff000,
-    0xfffff800,
-    0xfffffc00,
-    0xfffffe00,
-    0xffffff00,
-    0xffffff80,
-    0xffffffc0,
-    0xffffffe0,
-    0xfffffff0,
-    0xfffffff8,
-    0xfffffffc,
-    0xfffffffe,
-    0xffffffff,
-};
diff --git a/ldb/breakpoint.c b/ldb/breakpoint.c
deleted file mode 100644
index 6e8b6841155578a347be9025e6e23b0fb911f121..0000000000000000000000000000000000000000
--- a/ldb/breakpoint.c
+++ /dev/null
@@ -1,166 +0,0 @@
-#include <stdio.h>
-#include <signal.h>
-
-#include "ldb.h"
-#include "lisp.h"
-#include "os.h"
-#include "lispregs.h"
-#include "globals.h"
-
-#ifdef ibmrt
-typedef unsigned short inst;
-#else
-typedef unsigned long inst;
-#endif
-
-#define REAL_LRA_SLOT 0
-#define KNOWN_RETURN_P_SLOT 1
-#define BOGUS_LRA_CONSTANTS 2
-
-static inst swap_insts(code_obj, pc_offset, new_inst)
-     lispobj code_obj;
-     int pc_offset;
-     inst new_inst;
-{
-    struct code *code;
-    inst *addr, old_inst;
-
-    code = (struct code *)PTR(code_obj);
-    addr = (inst *)((char *)code + HeaderValue(code->header)*sizeof(lispobj)
-		    + pc_offset);
-    old_inst = *addr;
-    *addr = new_inst;
-    os_flush_icache((os_vm_address_t)addr, sizeof(inst));
-    return old_inst;
-}
-
-inst breakpoint_install(code_obj, pc_offset)
-     lispobj code_obj;
-     int pc_offset;
-{
-    return swap_insts(code_obj, pc_offset,
-#ifdef mips
-		      (trap_Breakpoint << 16) | 0xd
-#endif
-#ifdef sparc
-		      trap_Breakpoint
-#endif
-#ifdef ibmrt
-		      0 /* hack */
-#endif
-	);
-}
-
-void breakpoint_remove(code_obj, pc_offset, orig_inst)
-     lispobj code_obj;
-     int pc_offset;
-     inst orig_inst;
-{
-    swap_insts(code_obj, pc_offset, orig_inst);
-}
-
-static lispobj find_code(scp)
-struct sigcontext *scp;
-{
-    lispobj code = scp->sc_regs[CODE];
-    lispobj header = *(lispobj *)PTR(code);
-
-    switch (TypeOf(header)) {
-      case type_CodeHeader:
-	return code;
-      case type_ReturnPcHeader:
-	return code - HeaderValue(header)*4;
-      case type_FunctionHeader:
-      case type_ClosureFunctionHeader:
-	return code - type_FunctionPointer - HeaderValue(header)*4
-	        + type_OtherPointer;
-      default:
-	crap_out("Strange thing in $CODE at breakpoint.");
-    }
-}
-
-static int calc_offset(code, pc)
-     struct code *code;
-     unsigned long pc;
-{
-    unsigned long code_start;
-    int offset;
-
-    code_start = (unsigned long)code
-	+ HeaderValue(code->header)*sizeof(lispobj);
-    if (pc < code_start)
-	return 0;
-    offset = pc - code_start;
-    if (offset >= code->code_size)
-	return 0;
-    return offset;
-}
-
-int breakpoint_after_offset(scp)
-     struct sigcontext *scp;
-{
-    struct code *code = (struct code *)PTR(find_code(scp));
-
-#ifdef sparc
-    return calc_offset(code, scp->sc_npc);
-#endif
-
-#ifdef mips
-    inst cur_inst = *(inst *)scp->sc_pc;
-    int opcode = cur_inst >> 26;
-    struct sigcontext tmp;
-
-    if (opcode == 1 || ((opcode & 0x3c) == 0x4) || ((cur_inst & 0xf00e0000) == 0x80000000)) {
-	tmp = *scp;
-	emulate_branch(&tmp, cur_inst);
-	return calc_offset(code, tmp.sc_pc);
-    }
-    else
-	return calc_offset(code, scp->sc_pc + 4);
-#endif
-}
-
-static void internal_handle_breakpoint(scp, code)
-struct sigcontext *scp;
-lispobj code;
-{
-    struct code *codeptr = (struct code *)PTR(code);
-    lispobj *args;
-
-    args = current_control_stack_pointer;
-    current_control_stack_pointer += 3;
-    args[0] = fixnum(calc_offset(codeptr, scp->sc_pc));
-    args[1] = code;
-    args[2] = alloc_sap(scp);
-    funcall_sym(HANDLE_BREAKPOINT, args, 3);
-    scp->sc_mask = sigblock(0);
-}
-
-handle_breakpoint(signal, subcode, scp)
-int signal, subcode;
-struct sigcontext *scp;
-{
-    internal_handle_breakpoint(scp, find_code(scp));
-}
-
-handle_function_end_breakpoint(signal, subcode, scp)
-int signal, subcode;
-struct sigcontext *scp;
-{
-    extern char function_end_breakpoint_guts[], function_end_breakpoint_trap[];
-
-    lispobj code = scp->sc_pc - (unsigned long)function_end_breakpoint_trap
-	+ (unsigned long)function_end_breakpoint_guts -
-	((sizeof(struct code)+((BOGUS_LRA_CONSTANTS-1)*sizeof(lispobj))+7)&~7)
-	+ type_OtherPointer;
-    struct code *codeptr = (struct code *)PTR(code);
-    lispobj lra;
-
-    internal_handle_breakpoint(scp, code);
-
-    lra = codeptr->constants[REAL_LRA_SLOT];
-    if (codeptr->constants[KNOWN_RETURN_P_SLOT] == NIL)
-	scp->sc_regs[CODE] = lra;
-    scp->sc_pc = lra - type_OtherPointer+sizeof(lispobj);
-}
-
diff --git a/ldb/core.h b/ldb/core.h
deleted file mode 100644
index 65b0133885a69a007d798d1c4b061bdccb5d7937..0000000000000000000000000000000000000000
--- a/ldb/core.h
+++ /dev/null
@@ -1,33 +0,0 @@
-#define CORE_PAGESIZE OS_VM_DEFAULT_PAGESIZE
-#define CORE_MAGIC (('C' << 24) | ('O' << 16) | ('R' << 8) | 'E')
-#define CORE_END 3840
-#define CORE_NDIRECTORY 3861
-#define CORE_VALIDATE 3845
-#define CORE_VERSION 3860
-#define CORE_MACHINE_STATE 3862
-
-#define DYNAMIC_SPACE_ID (1)
-#define STATIC_SPACE_ID (2)
-#define READ_ONLY_SPACE_ID (3)
-
-struct ndir_entry {
-	long identifier;
-	long nwords;
-	long data_page;
-	long address;
-	long page_count;
-};
-
-struct machine_state {
-    lispobj *csp;
-    lispobj *fp;
-#ifndef ibmrt
-    lispobj *bsp;
-#endif
-    char *number_stack_start;
-
-    long sigcontext_page;
-    long control_stack_page;
-    long binding_stack_page;
-    long number_stack_page;
-};
diff --git a/ldb/coreparse.c b/ldb/coreparse.c
deleted file mode 100644
index faafb50dc6141a85625ada798a23796e126eb579..0000000000000000000000000000000000000000
--- a/ldb/coreparse.c
+++ /dev/null
@@ -1,143 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/coreparse.c,v 1.8 1991/05/24 17:33:10 wlott Exp $ */
-#include <stdio.h>
-#include <sys/types.h>
-#include <sys/file.h>
-
-#include "ldb.h"
-#include "os.h"
-#include "lisp.h"
-#include "globals.h"
-#include "core.h"
-
-extern int version;
-
-static void process_directory(fd, ptr, count)
-int fd, count;
-long *ptr;
-{
-	long id, offset, len;
-	lispobj *free_pointer;
-	os_vm_address_t addr;
-	struct ndir_entry *entry;
-
-	entry = (struct ndir_entry *) ptr;
-
-	while (count-- > 0) {
-		id = entry->identifier;
-		offset = CORE_PAGESIZE * (1 + entry->data_page);
-		addr = (os_vm_address_t) (CORE_PAGESIZE * entry->address);
-		free_pointer = (lispobj *) addr + entry->nwords;
-		len = CORE_PAGESIZE * entry->page_count;
-
-		if (len != 0) {
-		    os_vm_address_t real_addr;
-#ifdef PRINTNOISE
-		    printf("Mapping %d bytes at 0x%x.\n", len, addr);
-#endif
-		    real_addr=os_map(fd, offset, addr, len);
-		    if(real_addr!=addr)
-			fprintf(stderr,
-		  "process_directory: file mapped in wrong place! (0x%08x != 0x%08x)\n",
-				real_addr,
-				addr);
-		}
-
-#if 0
-		printf("Space ID = %d, free pointer = 0x%08x.\n", id, free_pointer);
-#endif
-
-		switch (id) {
-		case DYNAMIC_SPACE_ID:
-                    if (addr != (os_vm_address_t)dynamic_0_space && addr != (os_vm_address_t)dynamic_1_space)
-                        printf("Strange ... dynamic space lossage.\n");
-                    current_dynamic_space = (lispobj *)addr;
-#ifdef ibmrt
-		    SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer);
-#else
-                    current_dynamic_space_free_pointer = free_pointer;
-#endif
-                    break;
-		case STATIC_SPACE_ID:
-			static_space = (lispobj *) addr;
-			break;
-		case READ_ONLY_SPACE_ID:
-			/* Don't care about read only space */
-			break;
-		default:
-			printf("Strange space ID: %d; ignored.\n", id);
-			break;
-		}
-		entry++;
-	}
-}
-
-boolean load_core_file(file)
-char *file;
-{
-    int fd = open(file, O_RDONLY), count;
-    long header[CORE_PAGESIZE / sizeof(long)], val, len, *ptr;
-    boolean restore_state = FALSE;
-
-    if (fd < 0) {
-	    fprintf(stderr, "Could not open file \"%s\".\n", file);
-	    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 may lose big.\n", version, *ptr);
-                }
-                break;
-
-            case CORE_VALIDATE:
-		fprintf(stderr, "Validation no longer supported; ignored.\n");
-                break;
-
-            case CORE_NDIRECTORY:
-                process_directory(fd, ptr,
-				  (len-2) / (sizeof(struct ndir_entry) / sizeof(long)));
-                break;
-
-            case CORE_MACHINE_STATE:
-                restore_state = TRUE;
-                load(fd, (struct machine_state *)ptr);
-                break;
-
-            default:
-                printf("Unknown core file entry: %d; skipping.\n", val);
-                break;
-        }
-
-        ptr += len - 2;
-    }
-
-    return restore_state;
-}
diff --git a/ldb/dynbind.c b/ldb/dynbind.c
deleted file mode 100644
index 40984eec38270f4bcb1735249470e9360b500da6..0000000000000000000000000000000000000000
--- a/ldb/dynbind.c
+++ /dev/null
@@ -1,69 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/dynbind.c,v 1.3 1991/02/16 00:59:56 wlott Exp $
- * 
- * Support for dynamic binding from C.
- */
-
-#include "ldb.h"
-#include "lisp.h"
-#include "globals.h"
-
-#ifdef ibmrt
-#define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER))
-#define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value))
-#else
-#define GetBSP() ((struct binding *)current_binding_stack_pointer)
-#define SetBSP(value) (current_binding_stack_pointer=(lispobj *)(value))
-#endif
-
-bind_variable(symbol, value)
-lispobj symbol, value;
-{
-	lispobj old_value;
-	struct binding *binding;
-
-	old_value = SymbolValue(symbol);
-	binding = GetBSP();
-	SetBSP(binding+1);
-
-	binding->value = old_value;
-	binding->symbol = symbol;
-	SetSymbolValue(symbol, value);
-}
-
-unbind()
-{
-	struct binding *binding;
-	lispobj symbol;
-	
-	binding = GetBSP() - 1;
-		
-	symbol = binding->symbol;
-
-	SetSymbolValue(symbol, binding->value);
-
-	binding->symbol = 0;
-
-	SetBSP(binding);
-}
-
-unbind_to_here(bsp)
-lispobj *bsp;
-{
-    struct binding *target = (struct binding *)bsp;
-    struct binding *binding = GetBSP();
-    lispobj symbol;
-
-    while (target < binding) {
-	binding--;
-
-	symbol = binding->symbol;
-
-	if (symbol) {
-	    SetSymbolValue(symbol, binding->value);
-	    binding->symbol = 0;
-	}
-
-    }
-    SetBSP(binding);
-}
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/fake-mach.c b/ldb/fake-mach.c
deleted file mode 100644
index 422e3e0f736a2a074ce877280d6f2282874fd222..0000000000000000000000000000000000000000
--- a/ldb/fake-mach.c
+++ /dev/null
@@ -1,53 +0,0 @@
-#include "ldb.h"
-#include "os.h"
-
-#define KERN_SUCCESS		0
-#define KERN_INVALID_ADDRESS	1
-#define KERN_PROTECTION_FAILURE	2
-#define KERN_NO_SPACE		3
-#define KERN_INVALID_ARGUMENT	4
-#define KERN_FAILURE		5
-
-int task_self()
-{
-    return 0;
-}
-
-int thread_reply()
-{
-    return 0;
-}
-
-int task_notify()
-{
-    return 0;
-}
-
-int vm_allocate(task,addr_p,len,free)
-int task;
-os_vm_address_t *addr_p;
-os_vm_size_t len;
-int free;
-{
-    *addr_p=os_validate(free ? NULL : *addr_p,len);
-    return (*addr_p)==NULL ? KERN_FAILURE : KERN_SUCCESS;
-}
-
-int vm_deallocate(task,addr,len)
-int task;
-os_vm_address_t addr;
-os_vm_size_t len;
-{
-    os_invalidate(addr,len);
-    return KERN_SUCCESS;
-}
-
-int vm_copy()
-{
-    return KERN_FAILURE;
-}
-
-int vm_statistics()
-{
-    return KERN_FAILURE;
-}
diff --git a/ldb/gc.c b/ldb/gc.c
deleted file mode 100644
index 5367707105ddad99f50b6d5d193c65aba478e611..0000000000000000000000000000000000000000
--- a/ldb/gc.c
+++ /dev/null
@@ -1,1938 +0,0 @@
-/*
- * Stop and Copy GC based on Cheney's algorithm.
- *
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/gc.c,v 1.34 1992/04/15 00:45:48 wlott Exp $
- * 
- * Written by Christopher Hoover.
- */
-
-#include <stdio.h>
-#include <sys/time.h>
-#include <sys/resource.h>
-#include <signal.h>
-#include "lisp.h"
-#include "ldb.h"
-#include "os.h"
-#include "gc.h"
-#include "globals.h"
-#include "interrupt.h"
-#include "validate.h"
-#include "lispregs.h"
-
-lispobj *from_space;
-lispobj *from_space_free_pointer;
-
-lispobj *new_space;
-lispobj *new_space_free_pointer;
-
-static int (*scavtab[256])();
-static lispobj (*transother[256])();
-static int (*sizetab[256])();
-
-static struct weak_pointer *weak_pointers;
-
-
-/* Predicates */
-
-#if defined(DEBUG_SPACE_PREDICATES)
-
-from_space_p(object)
-lispobj object;
-{
-	lispobj *ptr;
-
-	gc_assert(Pointerp(object));
-
-	ptr = (lispobj *) PTR(object);
-
-	return ((from_space <= ptr) &&
-		(ptr < from_space_free_pointer));
-}	    
-
-new_space_p(object)
-lispobj object;
-{
-	lispobj *ptr;
-
-	gc_assert(Pointerp(object));
-
-	ptr = (lispobj *) PTR(object);
-		
-	return ((new_space <= ptr) &&
-		(ptr < new_space_free_pointer));
-}	    
-
-#else
-
-#define from_space_p(ptr) \
-	((from_space <= ((lispobj *) ptr)) && \
-	 (((lispobj *) ptr) < from_space_free_pointer))
-
-#define new_space_p(ptr) \
-	((new_space <= ((lispobj *) ptr)) && \
-	 (((lispobj *) ptr) < new_space_free_pointer))
-
-#endif
-
-
-/* GC Lossage */
-
-void
-gc_lose()
-{
-	exit(1);
-}
-
-
-/* Copying Objects */
-
-static lispobj
-copy_object(object, nwords)
-lispobj object;
-int nwords;
-{
-	int tag;
-	lispobj *new;
-	lispobj *source, *dest;
-
-	gc_assert(Pointerp(object));
-	gc_assert(from_space_p(object));
-	gc_assert((nwords & 0x01) == 0);
-
-	/* get tag of object */
-	tag = LowtagOf(object);
-
-	/* allocate space */
-	new = new_space_free_pointer;
-	new_space_free_pointer += nwords;
-
-	dest = new;
-	source = (lispobj *) PTR(object);
-
-	/* copy the object */
-	while (nwords > 0) {
-            dest[0] = source[0];
-            dest[1] = source[1];
-            dest += 2;
-            source += 2;
-            nwords -= 2;
-	}
-
-	/* return lisp pointer of new object */
-	return ((lispobj) new) | tag;
-}
-
-
-/* Collect Garbage */
-
-static double tv_diff(x, y)
-struct timeval *x, *y;
-{
-    return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) -
-	    ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6));
-}
-
-#define BYTES_ZERO_BEFORE_END (1<<12)
-
-static void zero_stack()
-{
-    unsigned long *ptr = (unsigned long *)current_control_stack_pointer;
-
-  search:
-    do {
-	if (*ptr)
-	    goto fill;
-	ptr++;
-    } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1));
-    return;
-
-  fill:
-    do {
-	*ptr++ = 0;
-    } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1));
-    goto search;
-}
-
-collect_garbage()
-{
-#ifdef PRINTNOISE
-	struct timeval start_tv, stop_tv;
-	struct rusage start_rusage, stop_rusage;
-	double real_time, system_time, user_time;
-	double percent_retained, gc_rate;
-	unsigned long size_discarded;
-	unsigned long size_retained;
-#endif
-	lispobj *current_static_space_free_pointer;
-	unsigned long static_space_size;
-	unsigned long control_stack_size, binding_stack_size;
-	int oldmask;
-	
-#ifdef PRINTNOISE
-	printf("[Collecting garbage ... \n");
-
-	getrusage(RUSAGE_SELF, &start_rusage);
-	gettimeofday(&start_tv, (struct timezone *) 0);
-#endif
-
-	oldmask = sigblock(BLOCKABLE);
-
-	current_static_space_free_pointer =
-		(lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
-
-
-	/* Set up from space and new space pointers. */
-
-	from_space = current_dynamic_space;
-#ifndef ibmrt
-	from_space_free_pointer = current_dynamic_space_free_pointer;
-#else
-	from_space_free_pointer = (lispobj *)SymbolValue(ALLOCATION_POINTER);
-#endif
-
-	if (current_dynamic_space == dynamic_0_space)
-		new_space = dynamic_1_space;
-	else if (current_dynamic_space == dynamic_1_space)
-		new_space = dynamic_0_space;
-	else {
-		fprintf(stderr, "GC lossage.  Current dynamic space is bogus!\n");
-		gc_lose();
-	}
-
-	new_space_free_pointer = new_space;
-
-
-	/* Initialize the weak pointer list. */
-	weak_pointers = (struct weak_pointer *) NULL;
-
-
-	/* Scavenge all of the roots. */
-#ifdef PRINTNOISE
-	printf("Scavenging interrupt contexts ...\n");
-#endif
-	scavenge_interrupt_contexts();
-
-#ifdef PRINTNOISE
-	printf("Scavenging interrupt handlers (%d bytes) ...\n",
-	       sizeof(interrupt_handlers));
-#endif
-	scavenge((lispobj *) interrupt_handlers,
-		 sizeof(interrupt_handlers) / sizeof(lispobj));
-
-	control_stack_size = current_control_stack_pointer - control_stack;
-#ifdef PRINTNOISE
-	printf("Scavenging the control stack (%d bytes) ...\n",
-	       control_stack_size * sizeof(lispobj));
-#endif
-	scavenge(control_stack, control_stack_size);
-
-#ifndef ibmrt
-	binding_stack_size = current_binding_stack_pointer - binding_stack;
-#else
-	binding_stack_size =
-	    (lispobj *)SymbolValue(BINDING_STACK_POINTER) - binding_stack;
-#endif
-#ifdef PRINTNOISE
-	printf("Scavenging the binding stack (%d bytes) ...\n",
-	       binding_stack_size * sizeof(lispobj));
-#endif
-	scavenge(binding_stack, binding_stack_size);
-
-	static_space_size = current_static_space_free_pointer - static_space;
-#ifdef PRINTNOISE
-	printf("Scavenging static space (%d bytes) ...\n",
-	       static_space_size * sizeof(lispobj));
-#endif
-	scavenge(static_space, static_space_size);
-
-
-	/* Scavenge newspace. */
-#ifdef PRINTNOISE
-	printf("Scavenging new space (%d bytes) ...\n",
-	       (new_space_free_pointer - new_space) * sizeof(lispobj));
-#endif
-	scavenge_newspace();
-
-
-#if defined(DEBUG_PRINT_GARBAGE)
-	print_garbage(from_space, from_space_free_pointer);
-#endif
-
-	/* Scan the weak pointers. */
-#ifdef PRINTNOISE
-	printf("Scanning weak pointers ...\n");
-#endif
-	scan_weak_pointers();
-
-
-	/* Flip spaces. */
-#ifdef PRINTNOISE
-	printf("Flipping spaces ...\n");
-#endif
-
-	os_zero((os_vm_address_t) current_dynamic_space,
-		(os_vm_size_t) DYNAMIC_SPACE_SIZE);
-
-	current_dynamic_space = new_space;
-#ifndef ibmrt
-	current_dynamic_space_free_pointer = new_space_free_pointer;
-#else
-	SetSymbolValue(ALLOCATION_POINTER, (lispobj)new_space_free_pointer);
-#endif
-
-#ifdef PRINTNOISE
-	size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
-	size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
-#endif
-
-	/* Zero stack. */
-#ifdef PRINTNOISE
-	printf("Zeroing empty part of control stack ...\n");
-#endif
-	zero_stack();
-
-	(void) sigsetmask(oldmask);
-
-
-#ifdef PRINTNOISE
-	gettimeofday(&stop_tv, (struct timezone *) 0);
-	getrusage(RUSAGE_SELF, &stop_rusage);
-
-	printf("done.]\n");
-	
-	percent_retained = (((float) size_retained) /
-			     ((float) size_discarded)) * 100.0;
-
-	printf("Total of %d bytes out of %d bytes retained (%3.2f%%).\n",
-	       size_retained, size_discarded, percent_retained);
-
-	real_time = tv_diff(&stop_tv, &start_tv);
-	user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime);
-	system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime);
-
-#if 0
-	printf("Statistics:\n");
-	printf("%10.2f sec of real time\n", real_time);
-	printf("%10.2f sec of user time,\n", user_time);
-	printf("%10.2f sec of system time.\n", system_time);
-#else
-        printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n",
-               real_time, user_time, system_time);
-#endif        
-
-	gc_rate = ((float) size_retained / (float) (1<<20)) / real_time;
-
-	printf("%10.2f M bytes/sec collected.\n", gc_rate);
-#endif
-}
-
-
-/* Scavenging */
-
-static
-scavenge(start, nwords)
-lispobj *start;
-long nwords;
-{
-	while (nwords > 0) {
-		lispobj object;
-		int type, words_scavenged;
-
-		object = *start;
-		type = TypeOf(object);
-
-#if defined(DEBUG_SCAVENGE_VERBOSE)
-		printf("Scavenging object at 0x%08x, object = 0x%08x, type = %d\n",
-		       (unsigned long) start, (unsigned long) object, type);
-#endif
-
-#if 0
-		words_scavenged = (scavtab[type])(start, object);
-#else
-                if (Pointerp(object)) {
-                    /* It be a pointer. */
-                    if (from_space_p(object)) {
-                        /* It currently points to old space.  Check for a */
-                        /* forwarding pointer. */
-                        lispobj first_word;
-
-                        first_word = *((lispobj *)PTR(object));
-                        if (Pointerp(first_word) && new_space_p(first_word)) {
-                            /* Yep, there be a forwarding pointer. */
-                            *start = first_word;
-                            words_scavenged = 1;
-                        }
-                        else {
-                            /* Scavenge that pointer. */
-                            words_scavenged = (scavtab[type])(start, object);
-                        }
-                    }
-                    else {
-                        /* It points somewhere other than oldspace.  Leave */
-                        /* it alone. */
-                        words_scavenged = 1;
-                    }
-                }
-                else if ((object & 3) == 0) {
-                    /* It's a fixnum.  Real easy. */
-                    words_scavenged = 1;
-                }
-                else {
-                    /* It's some random header object. */
-                    words_scavenged = (scavtab[type])(start, object);
-                }
-#endif
-
-		start += words_scavenged;
-		nwords -= words_scavenged;
-	}
-	gc_assert(nwords == 0);
-}
-
-static
-scavenge_newspace()
-{
-    lispobj *here, *next;
-
-    here = new_space;
-    while (here < new_space_free_pointer) {
-	next = new_space_free_pointer;
-	scavenge(here, next - here);
-	here = next;
-    }
-}
-
-
-/* Scavenging Interrupt Contexts */
-
-scavenge_interrupt_contexts()
-{
-	int i, index;
-	struct sigcontext *context;
-
-	index = FIXNUM_TO_INT(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
-#if defined(DEBUG_PRINT_CONTEXT_INDEX)
-	printf("Number of active contexts: %d\n", index);
-#endif
-
-	for (i = 0; i < index; i++) {
-		context = lisp_interrupt_contexts[i];
-		scavenge_interrupt_context(context); 
-	}
-}
-
-#ifdef mips
-static int boxed_registers[] = {
-	A0, A1, A2, A3, A4, A5, CNAME, LEXENV,
-	NFP, OCFP, LRA, L0, L1, L2, CODE
-};
-#endif
-#ifdef sparc
-static int boxed_registers[] = {
-	A0, A1, A2, A3, A4, A5, OCFP, LRA,
-	CNAME, LEXENV, L0, L1, L2, CODE
-};
-#endif
-
-#ifdef ibmrt
-static int boxed_registers[] = {
-    CODE, CNAME, LEXENV, LRA, A0, A1, A2
-};
-#endif
-
-scavenge_interrupt_context(context)
-struct sigcontext *context;
-{
-	int i;
-	unsigned long lip;
-	unsigned long lip_offset;
-	int lip_register_pair;
-	unsigned long pc_code_offset;
-#ifdef sparc
-	unsigned long npc_code_offset;
-#endif
-
-	/* Find the LIP's register pair and calculate it's offset */
-	/* before we scavenge the context. */
-	lip = context->sc_regs[LIP];
-	lip_offset = 0x7FFFFFFF;
-	lip_register_pair = -1;
-	for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
-		unsigned long reg;
-		long offset;
-		int index;
-
-		index = boxed_registers[i];
-		reg = context->sc_regs[index];
-		if (PTR(reg) <= lip) {
-			offset = lip - reg;
-			if (offset < lip_offset) {
-				lip_offset = offset;
-				lip_register_pair = index;
-			}
-		}
-	}
-
-#if defined(DEBUG_LIP)
-	printf("LIP = %08x, Pair is R%d = %08x, Offset = %08x\n",
-	       context->sc_regs[LIP],
-	       lip_register_pair,
-	       context->sc_regs[lip_register_pair],
-	       lip_offset);
-#endif
-
-	/* Compute the PC's offset from the start of the CODE */
-	/* register. */
-	pc_code_offset = context->sc_pc - context->sc_regs[CODE];
-#ifdef sparc
-	npc_code_offset = context->sc_npc - context->sc_regs[CODE];
-#endif
-
-#if defined(DEBUG_PC)
-	printf("PC = %08x, CODE = %08x, Offset = %08x\n",
-	       context->sc_pc, context->sc_regs[CODE], pc_code_offset);
-#ifdef sparc
-	printf("nPC = %08x, CODE = %08x, Offset = %08x\n",
-	       context->sc_npc, context->sc_regs[CODE], npc_code_offset);
-#endif
-#endif
-	       
-	/* Scanvenge all boxed registers in the context. */
-	for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
-		int index;
-#if defined(DEBUG_SCAVENGE_REGISTERS)
-		unsigned long reg;
-#endif
-
-		index = boxed_registers[i];
-#if defined(DEBUG_SCAVENGE_REGISTERS)
-		reg = context->sc_regs[index];
-#endif
-		scavenge((lispobj *) &(context->sc_regs[index]), 1);
-#if defined(DEBUG_SCAVENGE_REGISTERS)
-		printf("Scavenged R%d: was 0x%08x now 0x%08x\n",
-		       index, reg, context->sc_regs[index]);
-#endif
-	}
-
-	/* Fix the LIP */
-	context->sc_regs[LIP] =
-		context->sc_regs[lip_register_pair] + lip_offset;
-	
-#if defined(DEBUG_LIP)
-	printf("LIP = %08x, Pair is R%d = %08x, Offset = %08x\n",
-	       context->sc_regs[LIP],
-	       lip_register_pair,
-	       context->sc_regs[lip_register_pair],
-	       lip_offset);
-#endif
-
-	/* Fix the PC if it was in from space */
-	if (from_space_p(context->sc_pc))
-		context->sc_pc = context->sc_regs[CODE] + pc_code_offset;
-#ifdef sparc
-	if (from_space_p(context->sc_npc))
-		context->sc_npc = context->sc_regs[CODE] + npc_code_offset;
-#endif
-
-#if defined(DEBUG_PC)
-	printf("PC = %08x, CODE = %08x, Offset = %08x\n",
-	       context->sc_pc, context->sc_regs[CODE], pc_code_offset);
-#ifdef sparc
-	printf("PC = %08x, CODE = %08x, Offset = %08x\n",
-	       context->sc_npc, context->sc_regs[CODE], npc_code_offset);
-#endif
-#endif
-	       
-}
-
-
-/* Debugging Code */
-
-print_garbage(from_space, from_space_free_pointer)
-lispobj *from_space, *from_space_free_pointer;
-{
-	lispobj *start;
-	int total_words_not_copied;
-
-	printf("Scanning from space ...\n");
-
-	total_words_not_copied = 0;
-	start = from_space;
-	while (start < from_space_free_pointer) {
-		lispobj object;
-		int forwardp, type, nwords;
-		lispobj header;
-
-		object = *start;
-		forwardp = Pointerp(object) && new_space_p(object);
-
-		if (forwardp) {
-			int tag;
-			lispobj *pointer;
-
-			tag = LowtagOf(object);
-
-			switch (tag) {
-			case type_ListPointer:
-				nwords = 2;
-				break;
-			case type_StructurePointer:
-				printf("Don't know about structures yet!\n");
-				nwords = 1;
-				break;
-			case type_FunctionPointer:
-				nwords = 1;
-				break;
-			case type_OtherPointer:
-				pointer = (lispobj *) PTR(object);
-				header = *pointer;
-				type = TypeOf(header);
-				nwords = (sizetab[type])(pointer);
-			}
-		} else {
-			type = TypeOf(object);
-			nwords = (sizetab[type])(start);
-			total_words_not_copied += nwords;
-			printf("%4d words not copied at 0x%08x; ",
-			       nwords, (unsigned long) start);
-			printf("Header word is 0x%08x\n", (unsigned long) object);
-		}
-		start += nwords;
-	}
-	printf("%d total words not copied.\n", total_words_not_copied);
-}
-
-
-/* Code and Code-Related Objects */
-
-static lispobj trans_function_header();
-static lispobj trans_boxed();
-
-static
-scav_function_pointer(where, object)
-lispobj *where, object;
-{
-	gc_assert(Pointerp(object));
-
-	if (from_space_p(object)) {
-		lispobj first, *first_pointer;
-
-		/* object is a pointer into from space.  check to see */
-		/* if it has been forwarded */
-		first_pointer = (lispobj *) PTR(object);
-		first = *first_pointer;
-		
-		if (!(Pointerp(first) && new_space_p(first))) {
-			int type;
-			lispobj copy;
-
-			/* must transport object -- object may point */
-			/* to either a function header, a closure */
-			/* function header, or to a closure header. */
-			
-			type = TypeOf(first);
-			switch (type) {
-			  case type_FunctionHeader:
-			  case type_ClosureFunctionHeader:
-			    copy = trans_function_header(object);
-			    break;
-			  default:
-			    copy = trans_boxed(object);
-			    break;
-			}
-
-			first = *first_pointer = copy;
-		}
-
-		gc_assert(Pointerp(first));
-		gc_assert(!from_space_p(first));
-
-		*where = first;
-	}
-	return 1;
-}
-
-static struct code *
-trans_code(code)
-struct code *code;
-{
-	struct code *new_code;
-	lispobj first, l_code, l_new_code;
-	int nheader_words, ncode_words, nwords;
-	unsigned long displacement;
-	lispobj fheaderl, *prev_pointer;
-
-#if defined(DEBUG_CODE_GC)
-	printf("\nTransporting code object located at 0x%08x.\n",
-	       (unsigned long) code);
-#endif
-
-	/* if object has already been transported, just return pointer */
-	first = code->header;
-	if (Pointerp(first) && new_space_p(first))
-		return (struct code *) PTR(first);
-	
-	gc_assert(TypeOf(first) == type_CodeHeader);
-
-	/* prepare to transport the code vector */
-	l_code = (lispobj) code | type_OtherPointer;
-
-	ncode_words = FIXNUM_TO_INT(code->code_size);
-	nheader_words = HeaderValue(code->header);
-	nwords = ncode_words + nheader_words;
-	nwords = CEILING(nwords, 2);
-
-	l_new_code = copy_object(l_code, nwords);
-	new_code = (struct code *) PTR(l_new_code);
-
-	displacement = l_new_code - l_code;
-
-#if defined(DEBUG_CODE_GC)
-	printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
-	       (unsigned long) code, (unsigned long) new_code);
-	printf("Code object is %d words long.\n", nwords);
-#endif
-
-	/* set forwarding pointer */
-	code->header = l_new_code;
-	
-	/* set forwarding pointers for all the function headers in the */
-	/* code object.  also fix all self pointers */
-
-	fheaderl = code->entry_points;
-	prev_pointer = &new_code->entry_points;
-
-	while (fheaderl != NIL) {
-		struct function_header *fheaderp, *nfheaderp;
-		lispobj nfheaderl;
-		
-		fheaderp = (struct function_header *) PTR(fheaderl);
-		gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
-
-		/* calcuate the new function pointer and the new */
-		/* function header */
-		nfheaderl = fheaderl + displacement;
-		nfheaderp = (struct function_header *) PTR(nfheaderl);
-
-		/* set forwarding pointer */
-		fheaderp->header = nfheaderl;
-		
-		/* fix self pointer */
-		nfheaderp->self = nfheaderl;
-
-		*prev_pointer = nfheaderl;
-
-		fheaderl = fheaderp->next;
-		prev_pointer = &nfheaderp->next;
-	}
-
-	return new_code;
-}
-
-static
-scav_code_header(where, object)
-lispobj *where, object;
-{
-	struct code *code;
-	int nheader_words, ncode_words, nwords;
-	lispobj fheaderl;
-	struct function_header *fheaderp;
-
-	code = (struct code *) where;
-	ncode_words = FIXNUM_TO_INT(code->code_size);
-	nheader_words = HeaderValue(object);
-	nwords = ncode_words + nheader_words;
-	nwords = CEILING(nwords, 2);
-
-#if defined(DEBUG_CODE_GC)
-	printf("\nScavening code object at 0x%08x.\n",
-	       (unsigned long) where);
-	printf("Code object is %d words long.\n", nwords);
-	printf("Scavenging boxed section of code data block (%d words).\n",
-	       nheader_words - 1);
-#endif
-
-	/* Scavenge the boxed section of the code data block */
-	scavenge(where + 1, nheader_words - 1);
-
-	/* Scavenge the boxed section of each function object in the */
-	/* code data block */
-	fheaderl = code->entry_points;
-	while (fheaderl != NIL) {
-		fheaderp = (struct function_header *) PTR(fheaderl);
-		gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
-		
-#if defined(DEBUG_CODE_GC)
-		printf("Scavenging boxed section of entry point located at 0x%08x.\n",
-		       (unsigned long) PTR(fheaderl));
-#endif
-		scavenge(&fheaderp->name, 1);
-		scavenge(&fheaderp->arglist, 1);
-		scavenge(&fheaderp->type, 1);
-		
-		fheaderl = fheaderp->next;
-	}
-	
-	return nwords;
-}
-
-static lispobj
-trans_code_header(object)
-lispobj object;
-{
-	struct code *ncode;
-
-	ncode = trans_code((struct code *) PTR(object));
-	return (lispobj) ncode | type_OtherPointer;
-}
-
-static
-size_code_header(where)
-lispobj *where;
-{
-	struct code *code;
-	int nheader_words, ncode_words, nwords;
-
-	code = (struct code *) where;
-	
-	ncode_words = FIXNUM_TO_INT(code->code_size);
-	nheader_words = HeaderValue(code->header);
-	nwords = ncode_words + nheader_words;
-	nwords = CEILING(nwords, 2);
-
-	return nwords;
-}
-
-
-static
-scav_return_pc_header(where, object)
-lispobj *where, object;
-{
-	fprintf(stderr, "GC lossage.  Should not be scavenging a ");
-	fprintf(stderr, "Return PC Header.\n");
-	fprintf(stderr, "where = 0x%08x, object = 0x%08x",
-		(unsigned long) where, (unsigned long) object);
-	gc_lose();
-}
-
-static lispobj
-trans_return_pc_header(object)
-lispobj object;
-{
-	struct function_header *return_pc;
-	unsigned long offset;
-	struct code *code, *ncode;
-	
-	return_pc = (struct function_header *) PTR(object);
-	offset = HeaderValue(return_pc->header) * 4;
-
-	/* Transport the whole code object */
-	code = (struct code *) ((unsigned long) return_pc - offset);
-	ncode = trans_code(code);
-
-	return ((lispobj) ncode + offset) | type_OtherPointer;
-}
-
-
-static
-scav_function_header(where, object)
-lispobj *where, object;
-{
-	fprintf(stderr, "GC lossage.  Should not be scavenging a ");
-	fprintf(stderr, "Function Header.\n");
-	fprintf(stderr, "where = 0x%08x, object = 0x%08x",
-		(unsigned long) where, (unsigned long) object);
-	gc_lose();
-}
-
-static lispobj
-trans_function_header(object)
-lispobj object;
-{
-	struct function_header *fheader;
-	unsigned long offset;
-	struct code *code, *ncode;
-	
-	fheader = (struct function_header *) PTR(object);
-	offset = HeaderValue(fheader->header) * 4;
-
-	/* Transport the whole code object */
-	code = (struct code *) ((unsigned long) fheader - offset);
-	ncode = trans_code(code);
-
-	return ((lispobj) ncode + offset) | type_FunctionPointer;
-}
-
-
-
-/* Structures */
-
-static
-scav_structure_pointer(where, object)
-lispobj *where, object;
-{
-    if (from_space_p(object)) {
-	lispobj first, *first_pointer;
-
-	/* object is a pointer into from space.  check to see */
-	/* if it has been forwarded */
-	first_pointer = (lispobj *) PTR(object);
-	first = *first_pointer;
-		
-	if (!(Pointerp(first) && new_space_p(first)))
-	    first = *first_pointer = trans_boxed(object);
-	*where = first;
-    }
-    return 1;
-}
-
-
-/* Lists and Conses */
-
-static lispobj trans_list();
-
-static
-scav_list_pointer(where, object)
-lispobj *where, object;
-{
-	gc_assert(Pointerp(object));
-
-	if (from_space_p(object)) {
-		lispobj first, *first_pointer;
-
-		/* object is a pointer into from space.  check to see */
-		/* if it has been forwarded */
-		first_pointer = (lispobj *) PTR(object);
-		first = *first_pointer;
-		
-		if (!(Pointerp(first) && new_space_p(first)))
-			first = *first_pointer = trans_list(object);
-
-		gc_assert(Pointerp(first));
-		gc_assert(!from_space_p(first));
-	
-		*where = first;
-	}
-	return 1;
-}
-
-static lispobj
-trans_list(object)
-lispobj object;
-{
-	lispobj new_list_pointer;
-	struct cons *cons, *new_cons;
-	
-	cons = (struct cons *) PTR(object);
-
-	/* ### Don't use copy_object here. */
-	new_list_pointer = copy_object(object, 2);
-	new_cons = (struct cons *) PTR(new_list_pointer);
-
-	/* Set forwarding pointer. */
-	cons->car = new_list_pointer;
-	
-	/* Try to linearize the list in the cdr direction to help reduce */
-	/* paging. */
-
-	while (1) {
-		lispobj cdr, new_cdr, first;
-		struct cons *cdr_cons, *new_cdr_cons;
-
-		cdr = cons->cdr;
-
-                if (LowtagOf(cdr) != type_ListPointer ||
-                    !from_space_p(cdr) ||
-                    (Pointerp(first = *(lispobj *)PTR(cdr)) &&
-                     new_space_p(first)))
-                	break;
-
-		cdr_cons = (struct cons *) PTR(cdr);
-
-		/* ### Don't use copy_object here */
-		new_cdr = copy_object(cdr, 2);
-		new_cdr_cons = (struct cons *) PTR(new_cdr);
-
-		/* Set forwarding pointer */
-		cdr_cons->car = new_cdr;
-
-		/* Update the cdr of the last cons copied into new */
-		/* space to keep the newspace scavenge from having to */
-		/* do it. */
-		new_cons->cdr = new_cdr;
-		
-		cons = cdr_cons;
-		new_cons = new_cdr_cons;
-	}
-
-	return new_list_pointer;
-}
-
-
-/* Scavenging and Transporting Other Pointers */
-
-static
-scav_other_pointer(where, object)
-lispobj *where, object;
-{
-	gc_assert(Pointerp(object));
-
-	if (from_space_p(object)) {
-		lispobj first, *first_pointer;
-
-		/* object is a pointer into from space.  check to see */
-		/* if it has been forwarded */
-		first_pointer = (lispobj *) PTR(object);
-		first = *first_pointer;
-		
-		if (!(Pointerp(first) && new_space_p(first)))
-			first = *first_pointer = 
-				(transother[TypeOf(first)])(object);
-
-		gc_assert(Pointerp(first));
-		gc_assert(!from_space_p(first));
-
-		*where = first;
-	}
-	return 1;
-}
-
-
-/* Immediate, Boxed, and Unboxed Objects */
-
-static
-size_pointer(where)
-lispobj *where;
-{
-	return 1;
-}
-
-
-static
-scav_immediate(where, object)
-lispobj *where, object;
-{
-	return 1;
-}
-
-static lispobj
-trans_immediate(object)
-lispobj object;
-{
-	fprintf(stderr, "GC lossage.  Trying to transport an immediate!?\n");
-	gc_lose();
-	return NIL;
-}
-
-static
-size_immediate(where)
-lispobj *where;
-{
-	return 1;
-}
-
-
-static
-scav_boxed(where, object)
-lispobj *where, object;
-{
-	return 1;
-}
-
-static lispobj
-trans_boxed(object)
-lispobj object;
-{
-	lispobj header;
-	unsigned long length;
-
-	gc_assert(Pointerp(object));
-
-	header = *((lispobj *) PTR(object));
-	length = HeaderValue(header) + 1;
-	length = CEILING(length, 2);
-
-	return copy_object(object, length);
-}
-
-static
-size_boxed(where)
-lispobj *where;
-{
-	lispobj header;
-	unsigned long length;
-
-	header = *where;
-	length = HeaderValue(header) + 1;
-	length = CEILING(length, 2);
-
-	return length;
-}
-
-/* Note: on the sparc we don't have to do anything special for fdefns, */
-/* cause the raw-addr has a function lowtag. */
-#ifndef sparc
-static
-scav_fdefn(where, object)
-lispobj *where, object;
-{
-    struct fdefn *fdefn;
-#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
-
-    fdefn = (struct fdefn *)where;
-    
-    if ((char *)(fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr) {
-        scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
-        fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET);
-        return sizeof(struct fdefn) / sizeof(lispobj);
-    }
-    else
-        return 1;
-}
-#endif
-
-static
-scav_unboxed(where, object)
-lispobj *where, object;
-{
-	unsigned long length;
-
-	length = HeaderValue(object) + 1;
-	length = CEILING(length, 2);
-
-	return length;
-}
-
-static lispobj
-trans_unboxed(object)
-lispobj object;
-{
-	lispobj header;
-	unsigned long length;
-
-
-	gc_assert(Pointerp(object));
-
-	header = *((lispobj *) PTR(object));
-	length = HeaderValue(header) + 1;
-	length = CEILING(length, 2);
-
-	return copy_object(object, length);
-}
-
-static
-size_unboxed(where)
-lispobj *where;
-{
-	lispobj header;
-	unsigned long length;
-
-	header = *where;
-	length = HeaderValue(header) + 1;
-	length = CEILING(length, 2);
-
-	return length;
-}
-
-
-/* Vector-Like Objects */
-
-#define NWORDS(x,y) (CEILING((x),(y)) / (y))
-
-static
-scav_string(where, object)
-lispobj *where, object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	/* NOTE: Strings contain one more byte of data than the length */
-	/* slot indicates. */
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length) + 1;
-	nwords = CEILING(NWORDS(length, 4) + 2, 2);
-
-	return nwords;
-}
-
-static lispobj
-trans_string(object)
-{
-	struct vector *vector;
-	int length, nwords;
-
-	gc_assert(Pointerp(object));
-
-	/* NOTE: Strings contain one more byte of data than the length */
-	/* slot indicates. */
-
-	vector = (struct vector *) PTR(object);
-	length = FIXNUM_TO_INT(vector->length) + 1;
-	nwords = CEILING(NWORDS(length, 4) + 2, 2);
-
-	return copy_object(object, nwords);
-}
-
-static
-size_string(where)
-lispobj *where;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	/* NOTE: Strings contain one more byte of data than the length */
-	/* slot indicates. */
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length) + 1;
-	nwords = CEILING(NWORDS(length, 4) + 2, 2);
-
-	return nwords;
-}
-
-static
-scav_vector(where, object)
-lispobj *where, object;
-{
-    if (HeaderValue(object) == subtype_VectorValidHashing)
-        *where = (subtype_VectorMustRehash<<type_Bits) | type_SimpleVector;
-
-    return 1;
-}
-
-
-static lispobj
-trans_vector(object)
-lispobj object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	gc_assert(Pointerp(object));
-
-	vector = (struct vector *) PTR(object);
-
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(length + 2, 2);
-
-	return copy_object(object, nwords);
-}
-
-static
-size_vector(where)
-lispobj *where;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(length + 2, 2);
-
-	return nwords;
-}
-
-
-static
-scav_vector_bit(where, object)
-lispobj *where, object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 32) + 2, 2);
-
-	return nwords;
-}
-
-static lispobj
-trans_vector_bit(object)
-lispobj object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	gc_assert(Pointerp(object));
-
-	vector = (struct vector *) PTR(object);
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 32) + 2, 2);
-
-	return copy_object(object, nwords);
-}
-
-static
-size_vector_bit(where)
-lispobj *where;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 32) + 2, 2);
-
-	return nwords;
-}
-
-
-static
-scav_vector_unsigned_byte_2(where, object)
-lispobj *where, object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 16) + 2, 2);
-
-	return nwords;
-}
-
-static lispobj
-trans_vector_unsigned_byte_2(object)
-lispobj object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	gc_assert(Pointerp(object));
-
-	vector = (struct vector *) PTR(object);
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 16) + 2, 2);
-
-	return copy_object(object, nwords);
-}
-
-static
-size_vector_unsigned_byte_2(where)
-lispobj *where;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 16) + 2, 2);
-
-	return nwords;
-}
-
-
-static
-scav_vector_unsigned_byte_4(where, object)
-lispobj *where, object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 8) + 2, 2);
-
-	return nwords;
-}
-
-static lispobj
-trans_vector_unsigned_byte_4(object)
-lispobj object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	gc_assert(Pointerp(object));
-
-	vector = (struct vector *) PTR(object);
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 8) + 2, 2);
-
-	return copy_object(object, nwords);
-}
-
-static
-size_vector_unsigned_byte_4(where, object)
-lispobj *where, object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 8) + 2, 2);
-
-	return nwords;
-}
-
-
-static
-scav_vector_unsigned_byte_8(where, object)
-lispobj *where, object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 4) + 2, 2);
-
-	return nwords;
-}
-
-static lispobj
-trans_vector_unsigned_byte_8(object)
-lispobj object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	gc_assert(Pointerp(object));
-
-	vector = (struct vector *) PTR(object);
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 4) + 2, 2);
-
-	return copy_object(object, nwords);
-}
-
-static
-size_vector_unsigned_byte_8(where)
-lispobj *where;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 4) + 2, 2);
-
-	return nwords;
-}
-
-
-static
-scav_vector_unsigned_byte_16(where, object)
-lispobj *where, object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 2) + 2, 2);
-
-	return nwords;
-}
-
-static lispobj
-trans_vector_unsigned_byte_16(object)
-lispobj object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	gc_assert(Pointerp(object));
-
-	vector = (struct vector *) PTR(object);
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 2) + 2, 2);
-
-	return copy_object(object, nwords);
-}
-
-static
-size_vector_unsigned_byte_16(where)
-lispobj *where;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(NWORDS(length, 2) + 2, 2);
-
-	return nwords;
-}
-
-
-static
-scav_vector_unsigned_byte_32(where, object)
-lispobj *where, object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(length + 2, 2);
-
-	return nwords;
-}
-
-static lispobj
-trans_vector_unsigned_byte_32(object)
-lispobj object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	gc_assert(Pointerp(object));
-
-	vector = (struct vector *) PTR(object);
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(length + 2, 2);
-
-	return copy_object(object, nwords);
-}
-
-static
-size_vector_unsigned_byte_32(where)
-lispobj *where;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(length + 2, 2);
-
-	return nwords;
-}
-
-
-static
-scav_vector_single_float(where, object)
-lispobj *where, object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(length + 2, 2);
-
-	return nwords;
-}
-
-static lispobj
-trans_vector_single_float(object)
-lispobj object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	gc_assert(Pointerp(object));
-
-	vector = (struct vector *) PTR(object);
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(length + 2, 2);
-
-	return copy_object(object, nwords);
-}
-
-static
-size_vector_single_float(where)
-lispobj *where;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(length + 2, 2);
-
-	return nwords;
-}
-
-
-static
-scav_vector_double_float(where, object)
-lispobj *where, object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(length * 2 + 2, 2);
-
-	return nwords;
-}
-
-static lispobj
-trans_vector_double_float(object)
-lispobj object;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	gc_assert(Pointerp(object));
-
-	vector = (struct vector *) PTR(object);
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(length * 2 + 2, 2);
-
-	return copy_object(object, nwords);
-}
-
-static
-size_vector_double_float(where)
-lispobj *where;
-{
-	struct vector *vector;
-	int length, nwords;
-
-	vector = (struct vector *) where;
-	length = FIXNUM_TO_INT(vector->length);
-	nwords = CEILING(length * 2 + 2, 2);
-
-	return nwords;
-}
-
-
-/* Weak Pointers */
-
-#define WEAK_POINTER_NWORDS \
-	CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
-
-static
-scav_weak_pointer(where, object)
-lispobj *where, object;
-{
-	/* Do not let GC scavenge the value slot of the weak pointer */
-	/* (that is why it is a weak pointer).  Note:  we could use */
-	/* the scav_unboxed method here. */
-
-	return WEAK_POINTER_NWORDS;
-}
-
-static lispobj
-trans_weak_pointer(object)
-lispobj object;
-{
-	lispobj copy;
-	struct weak_pointer *wp;
-
-	gc_assert(Pointerp(object));
-
-#if defined(DEBUG_WEAK)
-	printf("Transporting weak pointer from 0x%08x\n", object);
-#endif
-
-	/* Need to remember where all the weak pointers are that have */
-	/* been transported so they can be fixed up in a post-GC pass. */
-
-	copy = copy_object(object, WEAK_POINTER_NWORDS);
-	wp = (struct weak_pointer *) PTR(copy);
-	
-
-	/* Push the weak pointer onto the list of weak pointers. */
-	wp->next = weak_pointers;
-	weak_pointers = wp;
-
-	return copy;
-}
-
-static
-size_weak_pointer(where)
-lispobj *where;
-{
-	return WEAK_POINTER_NWORDS;
-}
-
-scan_weak_pointers()
-{
-	struct weak_pointer *wp;
-
-	for (wp = weak_pointers; wp != (struct weak_pointer *) NULL;
-	     wp = wp->next) {
-		lispobj value;
-		lispobj first, *first_pointer;
-
-		value = wp->value;
-
-#if defined(DEBUG_WEAK)
-		printf("Weak pointer at 0x%08x\n", (unsigned long) wp);
-		printf("Value: 0x%08x\n", (unsigned long) value);
-#endif		
-
-		if (!(Pointerp(value) && from_space_p(value)))
-			continue;
-
-		/* Now, we need to check if the object has been */
-		/* forwarded.  If it has been, the weak pointer is */
-		/* still good and needs to be updated.  Otherwise, the */
-		/* weak pointer needs to be nil'ed out. */
-
-		first_pointer = (lispobj *) PTR(value);
-		first = *first_pointer;
-		
-#if defined(DEBUG_WEAK)
-		printf("First: 0x%08x\n", (unsigned long) first);
-#endif		
-
-		if (Pointerp(first) && new_space_p(first))
-			wp->value = first;
-		else {
-			wp->value = NIL;
-			wp->broken = T;
-		}
-	}
-}
-
-
-
-/* Initialization */
-
-static
-scav_lose(object)
-lispobj object;
-{
-	fprintf(stderr, "GC lossage.  No scavenge function for object 0x%08x\n",
-		(unsigned long) object);
-	gc_lose();
-	return 0;
-}
-
-static lispobj
-trans_lose(object)
-lispobj object;
-{
-	fprintf(stderr, "GC lossage.  No transport function for object 0x%08x\n",
-		(unsigned long) object);
-	gc_lose();
-	return NIL;
-}
-
-static
-size_lose(where)
-lispobj *where;
-{
-	fprintf(stderr, "Size lossage.  No size function for object at 0x%08x\n",
-		(unsigned long) where);
-	fprintf(stderr, "First word of object: 0x%08x\n",
-		(unsigned long) *where);
-	return 1;
-}
-
-gc_init()
-{
-	int i;
-
-	/* Scavenge Table */
-	for (i = 0; i < 256; i++)
-		scavtab[i] = scav_lose;
-
-	for (i = 0; i < 32; i++) {
-		scavtab[type_EvenFixnum|(i<<3)] = scav_immediate;
-		scavtab[type_FunctionPointer|(i<<3)] = scav_function_pointer;
-		/* OtherImmediate0 */
-		scavtab[type_ListPointer|(i<<3)] = scav_list_pointer;
-		scavtab[type_OddFixnum|(i<<3)] = scav_immediate;
-		scavtab[type_StructurePointer|(i<<3)] = scav_structure_pointer;
-		/* OtherImmediate1 */
-		scavtab[type_OtherPointer|(i<<3)] = scav_other_pointer;
-	}
-
-	scavtab[type_Bignum] = scav_unboxed;
-	scavtab[type_Ratio] = scav_boxed;
-	scavtab[type_SingleFloat] = scav_unboxed;
-	scavtab[type_DoubleFloat] = scav_unboxed;
-	scavtab[type_Complex] = scav_boxed;
-	scavtab[type_SimpleArray] = scav_boxed;
-	scavtab[type_SimpleString] = scav_string;
-	scavtab[type_SimpleBitVector] = scav_vector_bit;
-	scavtab[type_SimpleVector] = scav_vector;
-	scavtab[type_SimpleArrayUnsignedByte2] = scav_vector_unsigned_byte_2;
-	scavtab[type_SimpleArrayUnsignedByte4] = scav_vector_unsigned_byte_4;
-	scavtab[type_SimpleArrayUnsignedByte8] = scav_vector_unsigned_byte_8;
-	scavtab[type_SimpleArrayUnsignedByte16] = scav_vector_unsigned_byte_16;
-	scavtab[type_SimpleArrayUnsignedByte32] = scav_vector_unsigned_byte_32;
-	scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float;
-	scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float;
-	scavtab[type_ComplexString] = scav_boxed;
-	scavtab[type_ComplexBitVector] = scav_boxed;
-	scavtab[type_ComplexVector] = scav_boxed;
-	scavtab[type_ComplexArray] = scav_boxed;
-	scavtab[type_CodeHeader] = scav_code_header;
-	scavtab[type_FunctionHeader] = scav_function_header;
-	scavtab[type_ClosureFunctionHeader] = scav_function_header;
-	scavtab[type_ReturnPcHeader] = scav_return_pc_header;
-	scavtab[type_ClosureHeader] = scav_boxed;
-	scavtab[type_FuncallableInstanceHeader] = scav_boxed;
-	scavtab[type_ByteCodeFunction] = scav_boxed;
-	scavtab[type_ByteCodeClosure] = scav_boxed;
-	scavtab[type_ValueCellHeader] = scav_boxed;
-        scavtab[type_SymbolHeader] = scav_boxed;
-	scavtab[type_BaseChar] = scav_immediate;
-	scavtab[type_Sap] = scav_unboxed;
-	scavtab[type_UnboundMarker] = scav_immediate;
-	scavtab[type_WeakPointer] = scav_weak_pointer;
-        scavtab[type_StructureHeader] = scav_boxed;
-#ifndef sparc
-        scavtab[type_Fdefn] = scav_fdefn;
-#else
-        scavtab[type_Fdefn] = scav_boxed;
-#endif
-
-	/* Transport Other Table */
-	for (i = 0; i < 256; i++)
-		transother[i] = trans_lose;
-
-	transother[type_Bignum] = trans_unboxed;
-	transother[type_Ratio] = trans_boxed;
-	transother[type_SingleFloat] = trans_unboxed;
-	transother[type_DoubleFloat] = trans_unboxed;
-	transother[type_Complex] = trans_boxed;
-	transother[type_SimpleArray] = trans_boxed;
-	transother[type_SimpleString] = trans_string;
-	transother[type_SimpleBitVector] = trans_vector_bit;
-	transother[type_SimpleVector] = trans_vector;
-	transother[type_SimpleArrayUnsignedByte2] = trans_vector_unsigned_byte_2;
-	transother[type_SimpleArrayUnsignedByte4] = trans_vector_unsigned_byte_4;
-	transother[type_SimpleArrayUnsignedByte8] = trans_vector_unsigned_byte_8;
-	transother[type_SimpleArrayUnsignedByte16] = trans_vector_unsigned_byte_16;
-	transother[type_SimpleArrayUnsignedByte32] = trans_vector_unsigned_byte_32;
-	transother[type_SimpleArraySingleFloat] = trans_vector_single_float;
-	transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float;
-	transother[type_ComplexString] = trans_boxed;
-	transother[type_ComplexBitVector] = trans_boxed;
-	transother[type_ComplexVector] = trans_boxed;
-	transother[type_ComplexArray] = trans_boxed;
-	transother[type_CodeHeader] = trans_code_header;
-	transother[type_FunctionHeader] = trans_function_header;
-	transother[type_ClosureFunctionHeader] = trans_function_header;
-	transother[type_ReturnPcHeader] = trans_return_pc_header;
-	transother[type_ClosureHeader] = trans_boxed;
-	transother[type_FuncallableInstanceHeader] = trans_boxed;
-	transother[type_ByteCodeFunction] = trans_boxed;
-	transother[type_ByteCodeClosure] = trans_boxed;
-	transother[type_ValueCellHeader] = trans_boxed;
-	transother[type_SymbolHeader] = trans_boxed;
-	transother[type_BaseChar] = trans_immediate;
-	transother[type_Sap] = trans_unboxed;
-	transother[type_UnboundMarker] = trans_immediate;
-	transother[type_WeakPointer] = trans_weak_pointer;
-        transother[type_StructureHeader] = trans_vector;
-	transother[type_Fdefn] = trans_boxed;
-
-	/* Size table */
-
-	for (i = 0; i < 256; i++)
-		sizetab[i] = size_lose;
-
-	for (i = 0; i < 32; i++) {
-		sizetab[type_EvenFixnum|(i<<3)] = size_immediate;
-		sizetab[type_FunctionPointer|(i<<3)] = size_pointer;
-		/* OtherImmediate0 */
-		sizetab[type_ListPointer|(i<<3)] = size_pointer;
-		sizetab[type_OddFixnum|(i<<3)] = size_immediate;
-		sizetab[type_StructurePointer|(i<<3)] = size_pointer;
-		/* OtherImmediate1 */
-		sizetab[type_OtherPointer|(i<<3)] = size_pointer;
-	}
-
-	sizetab[type_Bignum] = size_unboxed;
-	sizetab[type_Ratio] = size_boxed;
-	sizetab[type_SingleFloat] = size_unboxed;
-	sizetab[type_DoubleFloat] = size_unboxed;
-	sizetab[type_Complex] = size_boxed;
-	sizetab[type_SimpleArray] = size_boxed;
-	sizetab[type_SimpleString] = size_string;
-	sizetab[type_SimpleBitVector] = size_vector_bit;
-	sizetab[type_SimpleVector] = size_vector;
-	sizetab[type_SimpleArrayUnsignedByte2] = size_vector_unsigned_byte_2;
-	sizetab[type_SimpleArrayUnsignedByte4] = size_vector_unsigned_byte_4;
-	sizetab[type_SimpleArrayUnsignedByte8] = size_vector_unsigned_byte_8;
-	sizetab[type_SimpleArrayUnsignedByte16] = size_vector_unsigned_byte_16;
-	sizetab[type_SimpleArrayUnsignedByte32] = size_vector_unsigned_byte_32;
-	sizetab[type_SimpleArraySingleFloat] = size_vector_single_float;
-	sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float;
-	sizetab[type_ComplexString] = size_boxed;
-	sizetab[type_ComplexBitVector] = size_boxed;
-	sizetab[type_ComplexVector] = size_boxed;
-	sizetab[type_ComplexArray] = size_boxed;
-	sizetab[type_CodeHeader] = size_code_header;
-#if 0
-	/* Shouldn't see these so just lose if it happens */
-	sizetab[type_FunctionHeader] = size_function_header;
-	sizetab[type_ClosureFunctionHeader] = size_function_header;
-	sizetab[type_ReturnPcHeader] = size_return_pc_header;
-#endif
-	sizetab[type_ClosureHeader] = size_boxed;
-	sizetab[type_FuncallableInstanceHeader] = size_boxed;
-	sizetab[type_ValueCellHeader] = size_boxed;
-	sizetab[type_SymbolHeader] = size_boxed;
-	sizetab[type_BaseChar] = size_immediate;
-	sizetab[type_Sap] = size_unboxed;
-	sizetab[type_UnboundMarker] = size_immediate;
-	sizetab[type_WeakPointer] = size_weak_pointer;
-        sizetab[type_StructureHeader] = size_vector;
-	sizetab[type_Fdefn] = size_boxed;
-}
-
-
-
-/* Noise to manipulate the gc trigger stuff. */
-
-#ifndef ibmrt
-
-void set_auto_gc_trigger(dynamic_usage)
-     unsigned long dynamic_usage;
-{
-    os_vm_address_t addr=(os_vm_address_t)current_dynamic_space + dynamic_usage;
-    os_vm_size_t length=
-	DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
-
-    if(addr < (os_vm_address_t)current_dynamic_space_free_pointer) {
-	fprintf(stderr,
-	   "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %d)\n",
-		dynamic_usage,
-		(os_vm_address_t)current_dynamic_space_free_pointer
-		- (os_vm_address_t)current_dynamic_space);
-	return;
-    }
-    else if (length < 0) {
-	fprintf(stderr,
-		"set_auto_gc_trigger: tried to set gc trigger too high! (%d)\n",
-		dynamic_usage);
-	return;
-    }
-
-    addr=os_round_up_to_page(addr);
-    length=os_trunc_size_to_page(length);
-
-#ifndef MACH
-    os_invalidate(addr,length);
-#else
-    os_protect(addr, length, 0);
-#endif
-
-    current_auto_gc_trigger = (lispobj *)addr;
-}
-
-void clear_auto_gc_trigger()
-{
-    if(current_auto_gc_trigger!=NULL){
-#ifndef MACH /* don't want to force whole space into swapping mode... */
-	os_vm_address_t addr=(os_vm_address_t)current_auto_gc_trigger;
-	os_vm_size_t length=
-	    DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
-
-	os_validate(addr,length);
-#else
-	os_protect((os_vm_address_t)current_dynamic_space,
-		   DYNAMIC_SPACE_SIZE,
-		   OS_VM_PROT_ALL);
-#endif
-
-	current_auto_gc_trigger = NULL;
-    }
-}
-
-#endif
diff --git a/ldb/gc.h b/ldb/gc.h
deleted file mode 100644
index 4f4ece061a31a9febb7a5f196447b880f80e0a1f..0000000000000000000000000000000000000000
--- a/ldb/gc.h
+++ /dev/null
@@ -1,33 +0,0 @@
-/*
- * Header file for GC
- *
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/gc.h,v 1.4 1990/11/12 02:36:28 wlott Exp $
- */
-
-#if !defined(_INCLUDED_GC_H_)
-#define _INCLUDED_GC_H_
-
-#include "lisp.h"
-
-extern void gc_lose();
-
-#define gc_abort() do { \
-	fprintf(stderr, "GC invariant lost!  File \"%s\", line %d\n", \
-	__FILE__, __LINE__); \
-	gc_lose(); \
-} while (0)
-
-#if 0
-#define gc_assert(ex) do { \
-	if (!(ex)) gc_abort(); \
-} while (0)
-#else
-#define gc_assert(ex)
-#endif
-
-
-#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
-#define FIXNUM_TO_INT(x) ((x)>>2)
-#define INT_TO_FIXNUM(x) ((x)<<2)
-
-#endif
diff --git a/ldb/globals.c b/ldb/globals.c
deleted file mode 100644
index 237fcd6dfa44f434aff5d21b5e80294d08fd805c..0000000000000000000000000000000000000000
--- a/ldb/globals.c
+++ /dev/null
@@ -1,66 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/globals.c,v 1.9 1991/10/22 19:20:34 wlott Exp $ */
-
-/* Variables everybody needs to look at or frob on. */
-
-#include <stdio.h>
-
-#include "lisp.h"
-#include "ldb.h"
-#include "globals.h"
-
-char *number_stack_start;
-
-int foreign_function_call_active;
-
-#ifdef mips
-unsigned long saved_global_pointer;
-unsigned long current_flags_register;
-#endif
-
-lispobj *current_control_stack_pointer;
-lispobj *current_control_frame_pointer;
-#ifndef ibmrt
-lispobj *current_binding_stack_pointer;
-#endif
-
-lispobj *read_only_space;
-lispobj *static_space;
-lispobj *dynamic_0_space;
-lispobj *dynamic_1_space;
-lispobj *control_stack;
-lispobj *binding_stack;
-
-lispobj *current_dynamic_space;
-#ifndef ibmrt
-lispobj *current_dynamic_space_free_pointer;
-lispobj *current_auto_gc_trigger;
-#endif
-
-globals_init()
-{
-	/* Space, stack, and free pointer vars are initialized by
-	   validate() and coreparse(). */
-
-#ifdef mips
-	/* Get the current value of GP. */
-	saved_global_pointer = current_global_pointer();
-
-        /* Set the Atomic flag */
-	current_flags_register = 1<<flag_Atomic;
-#endif
-#ifndef ibmrt
-
-        /* No GC trigger yet */
-        current_auto_gc_trigger = NULL;
-#endif
-
-	/* Set foreign function call active. */
-	foreign_function_call_active = 1;
-
-	/* Initialize the current lisp state. */
-	current_control_stack_pointer = control_stack;
-	current_control_frame_pointer = (lispobj *)0;
-#ifndef ibmrt
-	current_binding_stack_pointer = binding_stack;
-#endif
-}
diff --git a/ldb/globals.h b/ldb/globals.h
deleted file mode 100644
index fc11198a5d5fdad31215117e973fd07f3cde23d0..0000000000000000000000000000000000000000
--- a/ldb/globals.h
+++ /dev/null
@@ -1,68 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/globals.h,v 1.8 1991/10/22 18:38:04 wlott Exp $ */
-
-#if !defined(_INCLUDE_GLOBALS_H_)
-#define _INCLUDED_GLOBALS_H_
-
-#include "lisp.h"
-
-#ifndef LANGUAGE_ASSEMBLY
-
-extern char *number_stack_start;
-
-extern int foreign_function_call_active;
-
-#ifdef mips
-extern unsigned long saved_global_pointer;
-extern unsigned long current_flags_register;
-#endif
-
-extern lispobj *current_control_stack_pointer;
-extern lispobj *current_control_frame_pointer;
-#ifndef ibmrt
-extern lispobj *current_binding_stack_pointer;
-#endif
-
-extern lispobj *read_only_space;
-extern lispobj *static_space;
-extern lispobj *dynamic_0_space;
-extern lispobj *dynamic_1_space;
-extern lispobj *control_stack;
-extern lispobj *binding_stack;
-
-extern lispobj *current_dynamic_space;
-#ifndef ibmrt
-extern lispobj *current_dynamic_space_free_pointer;
-extern lispobj *current_auto_gc_trigger;
-#endif
-
-#else  LANGUAGE_ASSEMBLY
-
-/* These are needed by ./assem.s */
-
-#ifdef mips
-#define EXTERN(name,bytes) .extern name bytes
-#endif
-#ifdef sparc
-#define EXTERN(name,bytes) .global _/**/name
-#endif
-#ifdef ibmrt
-#define EXTERN(name,bytes) .globl _/**/name
-#endif
-
-
-EXTERN(foreign_function_call_active, 4)
-
-EXTERN(current_control_stack_pointer, 4)
-EXTERN(current_control_frame_pointer, 4)
-#ifndef ibmrt
-EXTERN(current_binding_stack_pointer, 4)
-EXTERN(current_dynamic_space_free_pointer, 4)
-#endif
-
-#ifdef mips
-EXTERN(current_flags_register, 4)
-#endif
-
-#endif LANGUAGE_ASSEMBLY
-
-#endif _INCLUDED_GLOBALS_H_
diff --git a/ldb/interrupt.c b/ldb/interrupt.c
deleted file mode 100644
index e99352873db604fa51e361e6a1a0b088c1f2a0a1..0000000000000000000000000000000000000000
--- a/ldb/interrupt.c
+++ /dev/null
@@ -1,417 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/interrupt.c,v 1.34 1992/03/22 20:25:51 wlott Exp $ */
-
-/* Interrupt handing magic. */
-
-#include <stdio.h>
-
-#include <signal.h>
-#ifdef mips
-#include <mips/cpu.h>
-#endif
-
-#include "ldb.h"
-
-#include "os.h"
-#include "arch.h"
-#include "lisp.h"
-#include "globals.h"
-#include "lispregs.h"
-#include "interrupt.h"
-#include "validate.h"
-
-#define FIXNUM_VALUE(lispobj) (((int)lispobj)>>2)
-
-boolean internal_errors_enabled = 0;
-
-struct sigcontext *lisp_interrupt_contexts[MAX_INTERRUPTS];
-
-union interrupt_handler interrupt_handlers[NSIG];
-SIGHDLRTYPE (*interrupt_low_level_handlers[NSIG])() = {0};
-
-static int pending_signal = 0, pending_code = 0, pending_mask = 0;
-static boolean maybe_gc_pending = FALSE;
-
-
-/****************************************************************\
-* Utility routines used by various signal handlers.              *
-\****************************************************************/
-
-void fake_foreign_function_call(context)
-     struct sigcontext *context;
-{
-    int context_index;
-    lispobj oldcont;
-    
-    /* Get current LISP state from context */
-#ifndef ibmrt
-    current_dynamic_space_free_pointer = (lispobj *) context->sc_regs[ALLOC];
-    current_binding_stack_pointer = (lispobj *) context->sc_regs[BSP];
-#endif
-#ifdef mips
-    current_flags_register = context->sc_regs[FLAGS]|(1<<flag_Atomic);
-#endif
-    
-    /* Build a fake stack frame */
-    current_control_frame_pointer = (lispobj *) context->sc_regs[CSP];
-    if ((lispobj *)context->sc_regs[CFP]==current_control_frame_pointer) {
-        /* There is a small window during call where the callee's frame */
-        /* isn't built yet. */
-        if (LowtagOf(context->sc_regs[CODE]) == type_FunctionPointer) {
-            /* We have called, but not built the new frame, so
-               build it for them. */
-            current_control_frame_pointer[0] = context->sc_regs[OCFP];
-            current_control_frame_pointer[1] = context->sc_regs[LRA];
-            current_control_frame_pointer += 8;
-            /* Build our frame on top of it. */
-            oldcont = (lispobj)context->sc_regs[CFP];
-        }
-        else {
-            /* We haven't yet called, build our frame as if the
-               partial frame wasn't there. */
-            oldcont = (lispobj)context->sc_regs[OCFP];
-        }
-    }
-    /* ### We can't tell if we are still in the caller if it had to
-       allocate the stack frame due to stack arguments. */
-    /* ### Can anything strange happen during return? */
-    else
-        /* Normal case. */
-        oldcont = (lispobj)context->sc_regs[CFP];
-    
-    current_control_stack_pointer = current_control_frame_pointer + 8;
-
-    current_control_frame_pointer[0] = oldcont;
-    current_control_frame_pointer[1] = NIL;
-    current_control_frame_pointer[2] = (lispobj)context->sc_regs[CODE];
-    
-#ifdef mips
-    /* Restore the GP */
-    set_global_pointer(saved_global_pointer);
-#endif
-    
-    /* Do dynamic binding of the active interrupt context index
-       and save the context in the context array. */
-    context_index = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
-    
-    if (context_index >= MAX_INTERRUPTS) {
-        fprintf("Maximum number (%d) of interrupts exceeded.  Exiting.\n",
-                MAX_INTERRUPTS);
-        exit(1);
-    }
-    
-    bind_variable(FREE_INTERRUPT_CONTEXT_INDEX, fixnum(context_index + 1));
-    
-    lisp_interrupt_contexts[context_index] = context;
-    
-    /* No longer in Lisp now. */
-    foreign_function_call_active = 1;
-}
-
-void undo_fake_foreign_function_call(context)
-     struct sigcontext *context;
-{
-    /* Block all blockable signals */
-    sigblock(BLOCKABLE);
-    
-    /* Going back into lisp. */
-    foreign_function_call_active = 0;
-    
-    /* Undo dynamic binding. */
-    /* ### Do I really need to unbind_to_here()? */
-    unbind();
-    
-#ifndef ibmrt
-    /* Put the dynamic space free pointer back into the context. */
-    context->sc_regs[ALLOC] =
-        (unsigned long) current_dynamic_space_free_pointer;
-#endif
-}
-
-#define call_maybe_gc() \
-    funcall_sym(MAYBE_GC, current_control_stack_pointer, 0)
-
-void interrupt_internal_error(signal, code, context, continuable)
-     struct sigcontext *context;
-     boolean continuable;
-{
-    lispobj *args;
-
-    if (internal_errors_enabled) {
-	sigsetmask(context->sc_mask);
-	fake_foreign_function_call(context);
-	args = current_control_stack_pointer;
-	current_control_stack_pointer += 2;
-	args[0] = alloc_sap(context);
-	if (continuable)
-	    args[1] = T;
-	else
-	    args[1] = NIL;
-	funcall_sym(INTERNAL_ERROR, args, 2);
-	undo_fake_foreign_function_call(context);
-	if (continuable)
-	    arch_skip_instruction(context);
-    }
-    else
-	interrupt_handle_now(signal, code, context);
-}
-
-void interrupt_handle_pending(context)
-     struct sigcontext *context;
-{
-    if (foreign_function_call_active)
-	crap_out("Oh no, got a PendingInterrupt while foreign function call was active.\n");
-
-#ifdef mips
-    context->sc_regs[FLAGS] &= ~(1<<flag_Interrupted);
-#else
-#ifdef sparc
-    /* Bit 0 is the pseudo-atomic-interrupted flag, and bit 2 is the
-	pseudo-atomic-atomic flag.  Normally, p-a-a is cleared before
-	we get control, but sometimes (assembly/sparc/bit-bash.lisp)
-	it is not.  So we clear them both here. */
-    context->sc_regs[ALLOC] &= ~5;
-#else
-    SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, 0);
-#endif
-#endif
-    SetSymbolValue(INTERRUPT_PENDING, NIL);
-    if (maybe_gc_pending) {
-	maybe_gc_pending = FALSE;
-	fake_foreign_function_call(context);
-	call_maybe_gc();
-	undo_fake_foreign_function_call(context);
-    }
-    if (pending_signal) {
-	int signal, code;
-
-	signal = pending_signal;
-	code = pending_code;
-	pending_signal = 0;
-	pending_code = 0;
-	interrupt_handle_now(signal, code, context);
-    }
-    context->sc_mask = pending_mask;
-    pending_mask = 0;
-    arch_skip_instruction(context);
-}
-
-
-/****************************************************************\
-* interrupt_handle_now, maybe_now_maybe_later                    *
-*    the two main signal handlers.                               *
-\****************************************************************/
-
-SIGHDLRTYPE interrupt_handle_now(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-    int were_in_lisp;
-    union interrupt_handler handler;
-    lispobj *args;
-    lispobj function;
-    
-    handler = interrupt_handlers[signal];
-
-    if(handler.c==SIG_IGN)
-	return;
-
-    were_in_lisp = !foreign_function_call_active;
-    if (were_in_lisp)
-        fake_foreign_function_call(context);
-    
-    /* Allow signals again. */
-    sigsetmask(context->sc_mask);
-
-    if(handler.c==SIG_DFL){
-	/* This can happen if someone tries to ignore or default on of the */
-	/* signals we need for runtime support. */
-	fprintf(stderr,"interrupt_handle_now: No handler for signal %d?\n",signal);
-	printf("[exit debugger to continue]\n");
-	ldb_monitor();
-    }
-    else if (LowtagOf(handler.lisp) == type_EvenFixnum ||
-        LowtagOf(handler.lisp) == type_OddFixnum)
-        (*handler.c)(signal, code, context);
-    else {
-        args = current_control_stack_pointer;
-        current_control_stack_pointer += 3;
-        args[0] = fixnum(signal);
-        args[1] = fixnum(code);
-        args[2] = alloc_sap(context);
-	function = handler.lisp;
-        call_into_lisp(function, function, args, 3);
-    }
-    
-    if (were_in_lisp)
-        undo_fake_foreign_function_call(context);
-}
-
-static SIGHDLRTYPE maybe_now_maybe_later(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-    if (SymbolValue(INTERRUPTS_ENABLED) == NIL) {
-        pending_signal = signal;
-        pending_code = code;
-        pending_mask = context->sc_mask;
-        context->sc_mask |= BLOCKABLE;
-        SetSymbolValue(INTERRUPT_PENDING, T);
-    } else if ((!foreign_function_call_active)
-#ifdef mips
-               && (context->sc_regs[FLAGS] & (1<<flag_Atomic))
-#else
-#ifdef sparc
-	       && (context->sc_regs[ALLOC] & 4)
-#else
-	       && (SymbolValue(PSEUDO_ATOMIC_ATOMIC))
-#endif
-#endif
-               ) {
-        pending_signal = signal;
-        pending_code = code;
-        pending_mask = context->sc_mask;
-        context->sc_mask |= BLOCKABLE;
-#ifdef mips
-        context->sc_regs[FLAGS] |= (1<<flag_Interrupted);
-#else
-#ifdef sparc
-	context->sc_regs[ALLOC] |= 1;
-#else
-	SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, T);
-#endif
-#endif
-    } else
-        interrupt_handle_now(signal, code, context);
-}
-
-/****************************************************************\
-* Stuff to detect and handle hitting the gc trigger.             *
-\****************************************************************/
-
-#ifndef ibmrt
-static boolean gc_trigger_hit(context)
-     struct sigcontext *context;
-{
-
-    if (current_auto_gc_trigger == NULL)
-	return FALSE;
-    else{
-	lispobj *badaddr=(lispobj *)arch_get_bad_addr(context);
-
-	return (badaddr >= current_auto_gc_trigger &&
-		badaddr < current_dynamic_space + DYNAMIC_SPACE_SIZE);
-    }
-}
-#endif
-
-
-boolean interrupt_maybe_gc(context)
-struct sigcontext *context;
-{
-    if (!foreign_function_call_active
-#ifndef ibmrt
-		  && gc_trigger_hit(context)
-#endif
-	) {
-#ifdef mips
-	set_global_pointer(saved_global_pointer);
-#endif
-#ifndef ibmrt
-	clear_auto_gc_trigger();
-#endif
-
-	if (
-#ifdef mips
-	    context->sc_regs[FLAGS] & (1<<flag_Atomic)
-#else
-#ifdef sparc
-	    context->sc_regs[ALLOC] & 4
-#else
-	    SymbolValue(PSEUDO_ATOMIC_ATOMIC)
-#endif sparc
-#endif mips
-	    ) {
-	    maybe_gc_pending = TRUE;
-	    if (pending_signal == 0) {
-		pending_mask = context->sc_mask;
-		context->sc_mask |= BLOCKABLE;
-	    }
-#ifdef mips
-	    context->sc_regs[FLAGS] |= (1<<flag_Interrupted);
-#else
-#ifdef sparc
-	    context->sc_regs[ALLOC] |= 1;
-#else
-	    SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, T);
-#endif
-#endif
-	}
-	else {
-	    fake_foreign_function_call(context);
-	    call_maybe_gc();
-	    undo_fake_foreign_function_call(context);
-	}
-
-	return TRUE;
-    }else
-	return FALSE;
-}
-
-/****************************************************************\
-* Noise to install handlers.                                     *
-\****************************************************************/
-
-void interrupt_install_low_level_handler(signal,handler)
-int signal;
-SIGHDLRTYPE (*handler)();
-{
-    struct sigvec sv;
-
-    sv.sv_handler=handler;
-    sv.sv_mask=BLOCKABLE;
-    sv.sv_flags=0;
-
-    sigvec(signal,&sv,NULL);
-
-    interrupt_low_level_handlers[signal]=(handler==SIG_DFL ? 0 : handler);
-}
-
-unsigned long install_handler(signal, handler)
-int signal;
-SIGHDLRTYPE (*handler)();
-{
-    struct sigvec sv;
-    int oldmask;
-    union interrupt_handler oldhandler;
-
-    oldmask = sigblock(sigmask(signal));
-
-    if(interrupt_low_level_handlers[signal]==0){
-	if(handler==SIG_DFL || handler==SIG_IGN)
-	    sv.sv_handler=handler;
-	else if (sigmask(signal)&BLOCKABLE)
-	    sv.sv_handler = maybe_now_maybe_later;
-	else
-	    sv.sv_handler = interrupt_handle_now;
-
-	sv.sv_mask = BLOCKABLE;
-	sv.sv_flags = 0;
-
-	sigvec(signal, &sv, NULL);
-    }
-
-    oldhandler = interrupt_handlers[signal];
-    interrupt_handlers[signal].c = handler;
-
-    sigsetmask(oldmask);
-
-    return (unsigned long)oldhandler.lisp;
-}
-
-interrupt_init()
-{
-    int i;
-
-    for (i = 0; i < NSIG; i++)
-        interrupt_handlers[i].c = SIG_DFL;
-}
diff --git a/ldb/interrupt.h b/ldb/interrupt.h
deleted file mode 100644
index 2e62292de904f1f9e4abe7d1bb8d54f2f18b9d8f..0000000000000000000000000000000000000000
--- a/ldb/interrupt.h
+++ /dev/null
@@ -1,38 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/interrupt.h,v 1.3 1991/09/27 10:32:30 wlott Exp $ */
-
-#if !defined(_INCLUDE_INTERRUPT_H_)
-#define _INCLUDE_INTERRUPT_H_
-
-#include <signal.h>
-
-#define MAX_INTERRUPTS (4096)
-
-extern struct sigcontext *lisp_interrupt_contexts[MAX_INTERRUPTS];
-
-#ifdef SUNOS
-#define SIGHDLRTYPE void
-#else
-#define SIGHDLRTYPE int
-#endif
-
-union interrupt_handler {
-	lispobj lisp;
-	SIGHDLRTYPE (*c)();
-};
-
-extern SIGHDLRTYPE interrupt_handle_now();
-extern void interrupt_handle_pending();
-extern void interrupt_internal_error();
-
-extern union interrupt_handler interrupt_handlers[NSIG];
-
-#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))
-
-#endif
diff --git a/ldb/ldb.c b/ldb/ldb.c
deleted file mode 100644
index db70934e897752bff9c606e3183978983b324fa3..0000000000000000000000000000000000000000
--- a/ldb/ldb.c
+++ /dev/null
@@ -1,160 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/ldb.c,v 1.20 1992/05/25 14:36:43 wlott Exp $ */
-/* Lisp kernel core debugger */
-
-#include <stdio.h>
-#include <sys/types.h>
-#include <sys/file.h>
-#include <sys/param.h>
-#include <sys/stat.h>
-
-#include "ldb.h"
-#include "lisp.h"
-#include "alloc.h"
-#include "vars.h"
-#include "globals.h"
-#include "os.h"
-#include "arch.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, envp)
-int argc;
-char *argv[];
-char *envp[];
-{
-    char *arg, **argptr;
-    char *core = NULL, *default_core;
-    boolean restore_state, monitor;
-
-    number_stack_start = (char *)&monitor;
-
-    define_var("nil", NIL, TRUE);
-    define_var("t", T, TRUE);
-    monitor = FALSE;
-
-    argptr = argv;
-    while ((arg = *++argptr) != NULL) {
-        if (strcmp(arg, "-core") == 0) {
-            if (core != NULL) {
-                fprintf(stderr, "can only specify 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);
-            }
-        }
-	else if (strcmp(arg, "-monitor") == 0) {
-	    monitor = TRUE;
-	}
-    }
-
-    default_core = arch_init();
-    if (default_core == NULL)
-	default_core = "lisp.core";
-
-    /* Note: the /usr/misc/.cmucl/lib/ default path is also wired into */
-    /* the lisp code in .../code/save.lisp. */
-
-    if (core == NULL) {
-	static char buf[MAXPATHLEN];
-	extern char *getenv();
-	char *lib = getenv("CMUCLLIB");
-
-	if (lib != NULL) {
-	    char *dst;
-	    struct stat statbuf;
-
-	    do {
-		dst = buf;
-		while (*lib != '\0' && *lib != ':')
-		    *dst++ = *lib++;
-		if (dst != buf && dst[-1] != '/')
-		    *dst++ = '/';
-		strcpy(dst, default_core);
-		if (stat(buf, &statbuf) == 0) {
-		    core = buf;
-		    break;
-		}
-	    } while (*lib++ == ':');
-	}
-	if (core == NULL) {
-	    strcpy(buf, "/usr/misc/.cmucl/lib/");
-	    strcat(buf, default_core);
-	    core = buf;
-	}
-    }
-
-    os_init();
-
-#if defined(EXT_PAGER)
-    pager_init();
-#endif
-
-    gc_init();
-    
-    validate();
-
-    globals_init();
-
-    restore_state = load_core_file(core);
-
-#ifdef ibmrt
-    if (!restore_state) {
-	SetSymbolValue(BINDING_STACK_POINTER, (lispobj)binding_stack);
-	SetSymbolValue(INTERNAL_GC_TRIGGER, fixnum(-1));
-    }
-#endif
-
-    interrupt_init();
-
-    arch_install_interrupt_handlers();
-    os_install_interrupt_handlers();
-
-    /* Convert the argv and envp to something Lisp can grok. */
-    SetSymbolValue(LISP_COMMAND_LINE_LIST, alloc_str_list(argv));
-    SetSymbolValue(LISP_ENVIRONMENT_LIST, alloc_str_list(envp));
-
-#if !defined(mips) && !defined(sparc)
-    /* Turn on pseudo atomic for when we call into lisp. */
-    SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, fixnum(1));
-    SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, fixnum(0));
-#endif
-
-    /* Snag a few of the signal */
-    test_init();
-
-    if (!monitor) {
-	if (restore_state)
-            restore();
-	else
-	    funcall_sym(INITIAL_FUNCTION, current_control_stack_pointer, 0);
-	printf("%INITIAL-FUNCTION returned?");
-    }
-    while (1)
-	ldb_monitor();
-}
diff --git a/ldb/ldb.h b/ldb/ldb.h
deleted file mode 100644
index 7ee4ac054c589a2a1b9eacb4c908e49106c92723..0000000000000000000000000000000000000000
--- a/ldb/ldb.h
+++ /dev/null
@@ -1,25 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/ldb.h,v 1.4 1992/04/12 14:55:34 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 *)((sym)-type_OtherPointer))->value)
-#define SetSymbolValue(sym,val) \
-    (((struct symbol *)((sym)-type_OtherPointer))->value = (val))
-
-#define funcall(fdefn,argptr,nargs) \
-    call_into_lisp((fdefn),(fdefn)->function,argptr,nargs)
-#define funcall_sym(sym,argptr,nargs) \
-    funcall((struct fdefn *)(SymbolValue(sym)-type_OtherPointer),argptr,nargs)
-
-#define crap_out(msg) do { write(2, msg, sizeof(msg)); exit(-1); } while (0)
-
-#endif _LDB_H_
diff --git a/ldb/lispregs.h b/ldb/lispregs.h
deleted file mode 100644
index 9cd97b565ed3c191918e19d28d390446658b3ac4..0000000000000000000000000000000000000000
--- a/ldb/lispregs.h
+++ /dev/null
@@ -1,17 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/lispregs.h,v 1.8 1991/05/24 17:55:24 wlott Exp $ */
-
-#ifdef mips
-#include "mips-lispregs.h"
-#endif
-
-#ifdef sparc
-#include "sparc-lispregs.h"
-#endif
-
-#ifdef ibmrt
-#include "rt-lispregs.h"
-#endif
-
-#ifndef LANGUAGE_ASSEMBLY
-extern char *lisp_register_names[];
-#endif
diff --git a/ldb/mach-os.c b/ldb/mach-os.c
deleted file mode 100644
index 3817ff0be5d44959e2ea8acfe01b1cd7360ba00b..0000000000000000000000000000000000000000
--- a/ldb/mach-os.c
+++ /dev/null
@@ -1,180 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/mach-os.c,v 1.5 1992/04/08 03:25:15 wlott Exp $
- *
- * OS-dependent routines.  This file (along with os.h) exports an
- * OS-independent interface to the operating system VM facilities.
- * Suprisingly, this interface looks a lot like the Mach interface
- * (but simpler in some places).  For some operating systems, a subset
- * of these functions will have to be emulated.
- *
- * This is the Mach version.
- *
- */
-
-#include <stdio.h>
-#include <mach.h>
-#include "./signal.h"
-#include "ldb.h"
-#include "os.h"
-
-#define MAX_SEGS 32
-
-static struct segment {
-    vm_address_t start;
-    vm_size_t length;
-} addr_map[MAX_SEGS];
-static int segments = -1;
-
-vm_size_t os_vm_page_size;
-
-void os_init()
-{
-	os_vm_page_size = vm_page_size;
-}
-
-os_vm_address_t os_validate(addr, len)
-vm_address_t addr;
-vm_size_t len;
-{
-    kern_return_t res;
-
-#if defined(EXT_PAGER)
-    res = pager_vm_allocate(task_self(), &addr, len, addr==NULL);
-#else
-    res = vm_allocate(task_self(), &addr, len, addr==NULL);
-#endif
-
-    if (res != KERN_SUCCESS)
-	return 0;
-
-    segments = -1;
-
-    vm_protect(task_self(), addr, len, TRUE,
-	       VM_PROT_READ|VM_PROT_WRITE|VM_PROT_EXECUTE);
-
-    return addr;
-}
-
-void os_invalidate(addr, len)
-vm_address_t addr;
-vm_size_t len;
-{
-    kern_return_t res;
-
-#if defined(EXT_PAGER)
-    res = pager_vm_deallocate(task_self(), addr, len);
-#else
-    res = vm_deallocate(task_self(), addr, len);
-#endif
-
-    if (res != KERN_SUCCESS)
-        mach_error("Could not vm_allocate memory: ", res);
-
-    segments = -1;
-}
-
-vm_address_t os_map(fd, offset, addr, len)
-int fd, offset;
-vm_address_t addr;
-vm_size_t len;
-{
-    kern_return_t res;
-
-#if defined(EXT_PAGER)
-    res = pager_map_fd(fd, offset, &addr, 0, len);
-#else
-    res = map_fd(fd, offset, &addr, 0, len);
-#endif
-
-    if (res != KERN_SUCCESS)
-        mach_error("Could not map_fd memory: ", res);
-
-    segments = -1;
-
-    vm_protect(task_self(), addr, len, TRUE,
-	       VM_PROT_READ|VM_PROT_WRITE|VM_PROT_EXECUTE);
-
-    return addr;
-}
-
-void os_flush_icache(address, length)
-vm_address_t address;
-vm_size_t length;
-{
-#ifdef mips
-	vm_machine_attribute_val_t flush;
-	kern_return_t kr;
-
-	flush = MATTR_VAL_ICACHE_FLUSH;
-
-	kr = vm_machine_attribute(task_self(), address, length,
-				  MATTR_CACHE, &flush);
-	if (kr != KERN_SUCCESS)
-		mach_error("Could not flush the instruction cache", kr);
-#endif
-}
-
-void os_protect(address, length, protection)
-vm_address_t address;
-vm_size_t length;
-vm_prot_t protection;
-{
-	vm_protect(task_self(), address, length, FALSE, protection);
-}
-
-
-boolean valid_addr(test)
-vm_address_t test;
-{
-    vm_address_t addr;
-    vm_size_t size;
-    long bullshit;
-    int curseg;
-
-    if (segments == -1) {
-        addr = 0;
-        curseg = 0;
-
-        while (1) {
-            if (vm_region(task_self(), &addr, &size, &bullshit, &bullshit, &bullshit, &bullshit, &bullshit, &bullshit) != KERN_SUCCESS)
-                break;
-
-            if (curseg > 0 && addr_map[curseg-1].start + addr_map[curseg-1].length == addr)
-                addr_map[curseg-1].length += size;
-            else {
-                addr_map[curseg].start = addr;
-                addr_map[curseg].length = size;
-                curseg++;
-            }
-
-            addr += size;
-        }
-
-        segments = curseg;
-    }
-    
-    for (curseg = 0; curseg < segments; curseg++)
-        if (addr_map[curseg].start <= test && test < addr_map[curseg].start + addr_map[curseg].length)
-            return TRUE;
-    return FALSE;
-}
-
-#ifndef ibmrt
-static void sigbus_handler(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-    if(!interrupt_maybe_gc(context))
-	interrupt_handle_now(signal, code, context);
-}
-#endif
-
-void os_install_interrupt_handlers()
-{
-#ifndef ibmrt
-    interrupt_install_low_level_handler(SIGBUS,sigbus_handler);
-#endif
-#ifdef mips
-    interrupt_install_low_level_handler(SIGSEGV,sigbus_handler);
-#endif
-}
diff --git a/ldb/mach-os.h b/ldb/mach-os.h
deleted file mode 100644
index d54ffbd053c287da849fb043e1e2256ebe08e9d0..0000000000000000000000000000000000000000
--- a/ldb/mach-os.h
+++ /dev/null
@@ -1,13 +0,0 @@
-#include <mach.h>
-#include "ldb.h"
-
-typedef vm_address_t os_vm_address_t;
-typedef vm_size_t os_vm_size_t;
-typedef vm_offset_t os_vm_offset_t;
-typedef vm_prot_t os_vm_prot_t;
-
-#define OS_VM_PROT_READ VM_PROT_READ
-#define OS_VM_PROT_WRITE VM_PROT_WRITE
-#define OS_VM_PROT_EXECUTE VM_PROT_EXECUTE
-
-#define OS_VM_DEFAULT_PAGESIZE	4096
diff --git a/ldb/mips-arch.c b/ldb/mips-arch.c
deleted file mode 100644
index 8e0761dee1b46b4ff12e85598bc7315e00c1290d..0000000000000000000000000000000000000000
--- a/ldb/mips-arch.c
+++ /dev/null
@@ -1,144 +0,0 @@
-#include <mips/cpu.h>
-
-#include "ldb.h"
-#include "lisp.h"
-#include "globals.h"
-#include "validate.h"
-#include "os.h"
-#include "arch.h"
-#include "lispregs.h"
-#include "signal.h"
-
-char *arch_init()
-{
-    return NULL;
-}
-
-os_vm_address_t arch_get_bad_addr(context)
-struct sigcontext *context;
-{
-    /* Finding the bad address on the mips is easy. */
-    return (os_vm_address_t)context->sc_badvaddr;
-}
-
-void arch_skip_instruction(context)
-struct sigcontext *context;
-{
-    /* Skip the offending instruction */
-    if (context->sc_cause & CAUSE_BD)
-        emulate_branch(context, *(unsigned long *)context->sc_pc);
-    else
-        context->sc_pc += 4;
-}
-
-static void sigtrap_handler(signal, code, context)
-     int signal, code;
-     struct sigcontext *context;
-{
-    switch (code) {
-      case trap_PendingInterrupt:
-	interrupt_handle_pending(context);
-	break;
-
-      case trap_Halt:
-	crap_out("%primitive halt called; the party is over.\n");
-
-      case trap_Error:
-      case trap_Cerror:
-	interrupt_internal_error(signal, code, context, code==trap_Cerror);
-	break;
-
-      case trap_Breakpoint:
-	sigsetmask(context->sc_mask);
-	fake_foreign_function_call(context);
-	handle_breakpoint(signal, code, context);
-	undo_fake_foreign_function_call(context);
-	break;
-
-      case trap_FunctionEndBreakpoint:
-	sigsetmask(context->sc_mask);
-	fake_foreign_function_call(context);
-	handle_function_end_breakpoint(signal, code, context);
-	undo_fake_foreign_function_call(context);
-	break;
-
-      default:
-	interrupt_handle_now(signal, code, context);
-	break;
-    }
-}
-
-#define FIXNUM_VALUE(lispobj) (((int)lispobj)>>2)
-
-static void sigfpe_handler(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-    unsigned long bad_inst;
-    unsigned int op, rs, rt, rd, funct, dest;
-    int immed;
-    long result;
-
-    if (context->sc_cause & CAUSE_BD)
-        bad_inst = *(unsigned long *)(context->sc_pc + 4);
-    else
-        bad_inst = *(unsigned long *)(context->sc_pc);
-
-    op = (bad_inst >> 26) & 0x3f;
-    rs = (bad_inst >> 21) & 0x1f;
-    rt = (bad_inst >> 16) & 0x1f;
-    rd = (bad_inst >> 11) & 0x1f;
-    funct = bad_inst & 0x3f;
-    immed = (((int)(bad_inst & 0xffff)) << 16) >> 16;
-
-    switch (op) {
-        case 0x0: /* SPECIAL */
-            switch (funct) {
-                case 0x20: /* ADD */
-                    result = FIXNUM_VALUE(context->sc_regs[rs]) + FIXNUM_VALUE(context->sc_regs[rt]);
-                    dest = rd;
-                    break;
-
-                case 0x22: /* SUB */
-                    result = FIXNUM_VALUE(context->sc_regs[rs]) - FIXNUM_VALUE(context->sc_regs[rt]);
-                    dest = rd;
-                    break;
-
-                default:
-                    dest = 32;
-                    break;
-            }
-            break;
-
-        case 0x8: /* ADDI */
-            result = FIXNUM_VALUE(context->sc_regs[rs]) + (immed>>2);
-            dest = rt;
-            break;
-
-        default:
-            dest = 32;
-            break;
-    }
-
-    if (dest < 32) {
-        set_global_pointer(saved_global_pointer);
-        current_dynamic_space_free_pointer =
-            (lispobj *) context->sc_regs[ALLOC];
-
-        context->sc_regs[dest] = alloc_number(result);
-
-	context->sc_regs[ALLOC] =
-	    (unsigned long) current_dynamic_space_free_pointer;
-
-        arch_skip_instruction(context);
-
-    }
-    else
-        interrupt_handle_now(signal, code, context);
-}
-
-void arch_install_interrupt_handlers()
-{
-    interrupt_install_low_level_handler(SIGTRAP,sigtrap_handler);
-    interrupt_install_low_level_handler(SIGFPE,sigfpe_handler);
-}
diff --git a/ldb/mips-assem.s b/ldb/mips-assem.s
deleted file mode 100644
index 510a2326c9b68f011974c1459bdcc4237d12ef38..0000000000000000000000000000000000000000
--- a/ldb/mips-assem.s
+++ /dev/null
@@ -1,356 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/mips-assem.s,v 1.14 1992/03/08 18:44:06 wlott Exp $ */
-#include <machine/regdef.h>
-
-#include "lisp.h"
-#include "lispregs.h"
-#include "globals.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
-
-#if !defined(s8)
-#define s8 $30
-#endif
-
-/*
- * Function to transfer control into lisp.
- */
-	.text
-	.globl	call_into_lisp
-	.ent	call_into_lisp
-call_into_lisp:
-#define framesize 12*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, current_flags_register
-
-	/* No longer in foreign call. */
-	sw	zero, foreign_function_call_active
-
-        .set    reorder
-
-	/* Load the rest of the LISP state. */
-	lw	ALLOC, current_dynamic_space_free_pointer
-	lw	BSP, current_binding_stack_pointer
-	lw	CSP, current_control_stack_pointer
-	lw	OCFP, current_control_frame_pointer
-
-        .set    noreorder
-
-	/* 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	CFP, $6
-	sll	NARGS, $7, 2
-	lw	A0, 0(CFP)
-	lw	A1, 4(CFP)
-	lw	A2, 8(CFP)
-	lw	A3, 12(CFP)
-	lw	A4, 16(CFP)
-	lw	A5, 20(CFP)
-
-	/* Calculate LRA */
-	la	LRA, lra + type_OtherPointer
-
-	/* Indirect closure */
-	lw	CODE, 4-1(LEXENV)
-
-	/* Jump into lisp land. */
-	addu	LIP, CODE, 6*4 - type_FunctionPointer
-	j	LIP
-
-	.set	noreorder
-
-	.align	3
-lra:
-	.word	type_ReturnPcHeader
-
-	/* Multiple value return spot, clear stack */
-	move	CSP, OCFP
-	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, current_dynamic_space_free_pointer
-	sw	BSP, current_binding_stack_pointer
-	sw	CSP, current_control_stack_pointer
-	sw	CFP, current_control_frame_pointer
-	sw	FLAGS, current_flags_register
-
-	/* Back in foreign function call */
-	li	t0, 1
-	sw	t0, foreign_function_call_active
-
-	/* 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 up a stack frame. */
-	move	OCFP, CFP
-	move	CFP, CSP
-	addu	CSP, CFP, 32
-	sw	OCFP, 0(CFP)
-	sw	LRA, 4(CFP)
-	sw	CODE, 8(CFP)
-
-	/* Note: the C stack is already set up. */
-
-	/* Set the pseudo-atomic flag. */
-	.set	noreorder
-	or	FLAGS, (1<<flag_Atomic)
-
-	/* Save lisp state. */
-	sw	ALLOC, current_dynamic_space_free_pointer
-	sw	BSP, current_binding_stack_pointer
-	sw	CSP, current_control_stack_pointer
-	sw	CFP, current_control_frame_pointer
-	sw	FLAGS, current_flags_register
-
-	/* Mark us as in C land. */
-	li	t0, 1
-	sw	t0, foreign_function_call_active
-
-	/* Restore GP */
-	lw	gp, saved_global_pointer
-
-	/* Were we interrupted? */
-	and	FLAGS, (0xffff^(1<<flag_Atomic))
-	and	t0, FLAGS, (1<<flag_Interrupted)
-	beq	t0, zero, 1f
-	nop
-
-	/* We were interrupted. Hit the trap. */
-	break	trap_PendingInterrupt
-1:
-
-	.set	reorder
-
-	/* 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, current_flags_register
-
-	/* Mark us at in Lisp land. */
-	sw	zero, foreign_function_call_active
-
-	/* Restore other lisp state. */
-	lw	ALLOC, current_dynamic_space_free_pointer
-	lw	BSP, current_binding_stack_pointer
-
-	/* 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
-
-	/* Restore LRA & CODE (they may have been GC'ed) */
-	lw	CODE, 8(CFP)
-	lw	LRA, 4(CFP)
-
-	/* Reset the lisp stack. */
-	/* Note: OCFP and CFP are in saved regs. */
-	move	CSP, CFP
-	move	CFP, OCFP
-
-	/* Return to LISP. */
-	addu	LIP, LRA, 4-type_OtherPointer
-	j	LIP
-
-	.end	call_into_c
-
-	.text
-	.globl	start_of_tramps
-start_of_tramps:
-
-/*
- * The undefined-function trampoline.
- */
-        .text
-        .globl  undefined_tramp
-        .ent    undefined_tramp
-undefined_tramp:
-        break   10
-        .byte    4
-        .byte    23
-        .byte    254
-        .byte    208
-        .byte    1
-        .align 2
-        .end    undefined_tramp
-
-/*
- * The closure trampoline.
- */
-        .text
-        .globl  closure_tramp
-        .ent    closure_tramp
-closure_tramp:
-        lw      LEXENV, FDEFN_FUNCTION_OFFSET(CNAME)
-        lw      L0, CLOSURE_FUNCTION_OFFSET(LEXENV)
-        add     LIP, L0, FUNCTION_HEADER_CODE_OFFSET
-        j       LIP
-        .end    closure_tramp
-
-	.text
-	.globl	end_of_tramps
-end_of_tramps:
-
-
-/*
- * Function-end breakpoint magic.
- */
-
-	.text
-	.align	2
-	.set	noreorder
-	.globl	function_end_breakpoint_guts
-function_end_breakpoint_guts:
-	.word	type_ReturnPcHeader
-	beq	zero, zero, 1f
-	nop
-	move	OCFP, CSP
-	addu	CSP, 4
-	li	NARGS, 4
-	move	A1, NULLREG
-	move	A2, NULLREG
-	move	A3, NULLREG
-	move	A4, NULLREG
-	move	A5, NULLREG
-1:
-
-	.globl	function_end_breakpoint_trap
-function_end_breakpoint_trap:
-	break	trap_FunctionEndBreakpoint
-	beq	zero, zero, 1b
-	nop
-
-	.globl	function_end_breakpoint_end
-function_end_breakpoint_end:
-	.set	reorder
diff --git a/ldb/mips-lispregs.h b/ldb/mips-lispregs.h
deleted file mode 100644
index 613ce2a0f6d77cc5ec25024f224834560183c244..0000000000000000000000000000000000000000
--- a/ldb/mips-lispregs.h
+++ /dev/null
@@ -1,50 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/mips-lispregs.h,v 1.1 1991/05/24 18:46:15 wlott Exp $ */
-
-#ifdef LANGUAGE_ASSEMBLY
-#define REG(num) $num
-#else
-#define REG(num) num
-#endif
-
-#define NREGS	(32)
-
-#define ZERO    REG(0)
-#define NL3     REG(1)
-#define NL4     REG(2)
-#define FLAGS   REG(3)
-#define NL0     REG(4)
-#define NL1     REG(5)
-#define NL2     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 NFP     REG(16)
-#define OCFP    REG(17)
-#define LRA     REG(18)
-#define L0      REG(19)
-#define NULLREG REG(20)
-#define BSP     REG(21)
-#define CFP     REG(22)
-#define CSP     REG(23)
-#define L1      REG(24)
-#define ALLOC   REG(25)
-#define L2      REG(28)
-#define NSP     REG(29)
-#define CODE    REG(30)
-#define LIP     REG(31)
-
-#define REGNAMES \
-	"ZERO",		"NL3",		"NL4",		"FLAGS", \
-	"NL0",		"NL1",		"NL2",		"NARGS", \
-	"A0",		"A1",		"A2",		"A3", \
-	"A4",		"A5",		"CNAME",       	"LEXENV", \
-	"NFP",		"OCFP",		"LRA",		"L0", \
-	"NULL",		"BSP",		"CFP",		"CSP", \
-	"L1",		"ALLOC",	"K0",		"K1", \
-	"L2",		"NSP",		"CODE",		"LIP"
diff --git a/ldb/monitor.c b/ldb/monitor.c
deleted file mode 100644
index c107b2f543f374a9837cc81c9b575f0c581bdd72..0000000000000000000000000000000000000000
--- a/ldb/monitor.c
+++ /dev/null
@@ -1,494 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/monitor.c,v 1.17 1992/03/08 18:42:41 wlott Exp $ */
-
-#include <stdio.h>
-#include <setjmp.h>
-#include <sys/time.h>
-#include <sys/resource.h>
-#include <signal.h>
-#include "ldb.h"
-#include "lisp.h"
-#include "globals.h"
-#include "vars.h"
-#include "parse.h"
-#include "interrupt.h"
-#include "lispregs.h"
-
-static void call_cmd(), dump_cmd(), print_cmd(), quit(), help();
-static void flush_cmd(), search_cmd(), regs_cmd(), exit_cmd();
-static void timed_call_cmd(), gc_cmd(), print_context_cmd();
-static void backtrace_cmd(), purify_cmd(), catchers_cmd(), save_cmd();
-static void grab_sigs_cmd(), restore_cmd();
-
-static struct cmd {
-    char *cmd, *help;
-    void (*fn)();
-} Cmds[] = {
-    {"help", "Display this info", help},
-    {"?", NULL, help},
-    {"backtrace", "backtrace up to N frames", backtrace_cmd},
-    {"call", "call FUNCTION with ARG1, ARG2, ...", call_cmd},
-    {"catchers", "Print a list of all the active catchers.", catchers_cmd},
-    {"context", "print interrupt context number I.", print_context_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},
-    {"gc", "collect garbage (caveat collector).", gc_cmd},
-    {"grab-signals", "Set the signal handlers to call LDB.", grab_sigs_cmd},
-    {"purify", "purify (caveat purifier).", purify_cmd},
-    {"print", "print object at ADDRESS.", print_cmd},
-    {"p", NULL, print_cmd},
-    {"quit", "quit.", quit},
-    {"regs", "display current lisp regs.", regs_cmd},
-    {"restore", "restore the saved lisp image.", restore_cmd},
-    {"save", "save the current lisp image.", save_cmd},
-    {"search", "search for TYPE starting at ADDRESS for a max of COUNT words.", search_cmd},
-    {"s", NULL, search_cmd},
-    {"time", "call FUNCTION with ARG1, ARG2, ... and time it.", timed_call_cmd},
-    {NULL, NULL, NULL}
-};
-
-
-static jmp_buf curbuf;
-
-
-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("CSP\t=\t0x%08x\n", current_control_stack_pointer);
-    printf("FP\t=\t0x%08x\n", current_control_frame_pointer);
-#ifndef ibmrt
-    printf("BSP\t=\t0x%08x\n", current_binding_stack_pointer);
-#endif
-
-    printf("DYNAMIC\t=\t0x%08x\n", current_dynamic_space);
-#ifdef ibmrt
-    printf("ALLOC\t=\t0x08x\n", SymbolValue(ALLOCATION_POINTER));
-    printf("TRIGGER\t=\t0x08x\n", SymbolValue(INTERNAL_GC_TRIGGER));
-#else
-    printf("ALLOC\t=\t0x%08x\n", current_dynamic_space_free_pointer);
-    printf("TRIGGER\t=\t0x%08x\n", current_auto_gc_trigger);
-#endif
-    printf("STATIC\t=\t0x%08x\n", SymbolValue(STATIC_SPACE_FREE_POINTER));
-    printf("RDONLY\t=\t0x%08x\n", SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
-
-#ifdef MIPS
-    printf("FLAGS\t=\t0x%08x\n", current_flags_register);
-#endif
-}
-
-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 (search_for_type(val, &end, &count)) {
-        printf("found 0x%x at 0x%x:\n", val, end);
-        obj = *end;
-        addr = end;
-        end += 2;
-        if (TypeOf(obj) == type_FunctionHeader)
-            print((long)addr | type_FunctionPointer);
-        else 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();
-
-    lispobj function = parse_lispobj(ptr);
-    lispobj result, *args;
-    int numargs;
-
-    if (LowtagOf(function) != type_FunctionPointer) {
-        printf("0x%x is not a function pointer.\n", function);
-        return;
-    }
-
-    numargs = 0;
-    args = current_control_stack_pointer;
-    while (more_p(ptr)) {
-        current_control_stack_pointer++;
-        current_control_stack_pointer[-1] = parse_lispobj(ptr);
-        numargs++;
-    }
-
-    result = call_into_lisp(function, function, args, numargs);
-
-    print(result);
-}
-
-static double tv_diff(x, y)
-struct timeval *x, *y;
-{
-    return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) -
-	    ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6));
-}
-
-static void timed_call_cmd(ptr)
-char **ptr;
-{
-    extern lispobj call_into_lisp();
-
-    lispobj args[16];
-
-    lispobj function = parse_lispobj(ptr);
-    lispobj result, *argptr;
-    int numargs;
-    struct timeval start_tv, stop_tv;
-    struct rusage start_rusage, stop_rusage;
-    double real_time, system_time, user_time;
-
-    if (LowtagOf(function) != type_FunctionPointer) {
-        printf("0x%x is not a function pointer.\n", function);
-        return;
-    }
-
-    numargs = 0;
-    argptr = args;
-    while (more_p(ptr)) {
-        *argptr++ = parse_lispobj(ptr);
-        numargs++;
-    }
-    while (argptr < args + 6)
-        *argptr++ = NIL;
-
-    getrusage(RUSAGE_SELF, &start_rusage);
-    gettimeofday(&start_tv, (struct timezone *) 0);
-    result = call_into_lisp(function, function, args, numargs);
-    gettimeofday(&stop_tv, (struct timezone *) 0);
-    getrusage(RUSAGE_SELF, &stop_rusage);
-
-    print(result);
-
-    real_time = tv_diff(&stop_tv, &start_tv) * 1000.0;
-    user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime) *
-	    1000.0;
-    system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime) *
-	    1000.0;
-
-    printf("Call took:\n");
-    printf("%20.8f msec of real time\n", real_time);
-    printf("%20.8f msec of user time,\n", user_time);
-    printf("%20.8f msec of system time.\n", system_time);
-}
-
-static void flush_cmd()
-{
-    flush_vars();
-}
-
-static void quit()
-{
-    char buf[10];
-
-    printf("Really quit? [y] ");
-    fflush(stdout);
-    fgets(buf, sizeof(buf), stdin);
-    if (buf[0] == 'y' || buf[0] == 'Y' || buf[0] == '\n')
-        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 int done;
-
-static void exit_cmd()
-{
-    done = TRUE;
-}
-
-static void gc_cmd()
-{
-	collect_garbage();
-}
-
-static void purify_cmd()
-{
-	purify(NIL);
-}
-
-static void print_context(context)
-struct sigcontext *context;
-{
-	int i;
-
-	for (i = 0; i < NREGS; i++) {
-		printf("%s:\t", lisp_register_names[i]);
-		brief_print((lispobj) context->sc_regs[i]);
-	}
-	printf("PC:\t\t  0x%08x\n", context->sc_pc);
-}
-
-static void print_context_cmd(ptr)
-char **ptr;
-{
-	int free;
-
-	free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
-	
-        if (more_p(ptr)) {
-		int index;
-
-		index = parse_number(ptr);
-
-		if ((index >= 0) && (index < free)) {
-			printf("There are %d interrupt contexts.\n", free);
-			printf("Printing context %d\n", index);
-			print_context(lisp_interrupt_contexts[index]);
-		} else {
-			printf("There aren't that many/few contexts.\n");
-			printf("There are %d interrupt contexts.\n", free);
-		}
-	} else {
-		if (free == 0)
-			printf("There are no interrupt contexts!\n");
-		else {
-			printf("There are %d interrupt contexts.\n", free);
-			printf("Printing context %d\n", free - 1);
-			print_context(lisp_interrupt_contexts[free - 1]);
-		}
-	}
-}
-
-static void backtrace_cmd(ptr)
-char **ptr;
-{
-	void backtrace();
-	int n;
-
-        if (more_p(ptr))
-		n = parse_number(ptr);
-	else
-		n = 100;
-	
-	printf("Backtrace:\n");
-	backtrace(n);
-}
-
-static void catchers_cmd()
-{
-    struct catch_block *catch;
-
-    catch = (struct catch_block *)SymbolValue(CURRENT_CATCH_BLOCK);
-
-    if (catch == NULL)
-        printf("There are no active catchers!\n");
-    else {
-        while (catch != NULL) {
-            printf("0x%08x:\n\tuwp: 0x%08x\n\tfp: 0x%08x\n\tcode: 0x%08x\n\tentry: 0x%08x\n\ttag: ", catch, catch->current_uwp, catch->current_cont, catch->current_code, catch->entry_pc);
-            brief_print((lispobj)catch->tag);
-            catch = catch->previous_catch;
-        }
-    }
-}
-
-static void save_cmd(ptr)
-char **ptr;
-{
-    if (more_p(ptr))
-        save(*ptr);
-    else
-        save("lisp.core");
-}
-
-static void restore_cmd(ptr)
-     char **ptr;
-{
-    restore();
-}
-
-static void grab_sigs_cmd()
-{
-    printf("Grabbing signals.\n");
-    test_init();
-}
-
-static void sub_monitor()
-{
-    extern char *egets();
-    struct cmd *cmd, *found;
-    char *line, *ptr, *token;
-    int ambig;
-
-    while (!done) {
-        printf("ldb> ");
-        fflush(stdout);
-        line = egets();
-        if (line == NULL) {
-	    if (isatty(0)) {
-		putchar('\n');
-	        continue;
-	    }
-	    else {
-		fprintf(stderr, "\nEOF on something other than a tty.\n");
-		exit(0);
-	    }
-	}
-        ptr = line;
-        if ((token = parse_token(&ptr)) == NULL)
-            continue;
-        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 {
-            reset_printer();
-            (*found->fn)(&ptr);
-        }
-    }
-}
-
-void ldb_monitor()
-{
-    jmp_buf oldbuf;
-
-    bcopy(curbuf, oldbuf, sizeof(oldbuf));
-
-    printf("LDB monitor\n");
-
-    setjmp(curbuf);
-
-    sub_monitor();
-
-    done = FALSE;
-
-    bcopy(oldbuf, curbuf, sizeof(curbuf));
-}
-
-void throw_to_monitor()
-{
-    longjmp(curbuf, 1);
-}
diff --git a/ldb/os-common.c b/ldb/os-common.c
deleted file mode 100644
index f3c27532b6fec103af4dd0c4ac1d192f0acae2ea..0000000000000000000000000000000000000000
--- a/ldb/os-common.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include <stdio.h>
-
-#include "ldb.h"
-#include "os.h"
-
-void os_zero(addr, length)
-os_vm_address_t addr;
-os_vm_size_t length;
-{
-    os_vm_address_t block_start;
-    os_vm_size_t block_size;
-
-#ifdef DEBUG
-    fprintf(stderr,";;; os_zero: addr: 0x%08x, len: 0x%08x\n",addr,length);
-#endif
-
-    block_start=os_round_up_to_page(addr);
-
-    length-=block_start-addr;
-    block_size=os_trunc_size_to_page(length);
-
-    if(block_start>addr)
-	bzero((char *)addr,block_start-addr);
-    if(block_size<length)
-	bzero((char *)block_start+block_size,length-block_size);
-    
-    if (block_size != 0) {
-	/* Now deallocate and allocate the block so that it */
-	/* faults in  zero-filled. */
-
-	os_invalidate(block_start,block_size);
-	addr=os_validate(block_start,block_size);
-
-	if(addr==NULL || addr!=block_start)
-	    fprintf(stderr,"os_zero: block moved, 0x%08x ==> 0x%08x!\n",block_start,addr);
-    }
-}
-
-os_vm_address_t os_allocate(len)
-os_vm_size_t len;
-{
-    return os_validate((os_vm_address_t)NULL,len);
-}
-
-os_vm_address_t os_allocate_at(addr,len)
-os_vm_address_t addr;
-os_vm_size_t len;
-{
-    return os_validate(addr, len);
-}
-
-void os_deallocate(addr,len)
-os_vm_address_t addr;
-os_vm_size_t len;
-{
-    os_invalidate(addr,len);
-}
-
-os_vm_address_t os_reallocate(addr,old_len,len)
-os_vm_address_t addr;
-os_vm_size_t old_len, len;
-{
-    addr=os_trunc_to_page(addr);
-    len=os_round_up_size_to_page(len);
-    old_len=os_round_up_size_to_page(old_len);
-
-    if(addr==NULL)
-	return os_allocate(len);
-    else{
-	long len_diff=len-old_len;
-
-	if(len_diff<0)
-	    os_invalidate(addr+len,-len_diff);
-	else if(len_diff!=0){
-	    os_vm_address_t new=os_validate(addr+old_len,len_diff);
-
-	    if(new==NULL || new!=addr+old_len){
-		if(new!=NULL)
-		    /* allocated alright, but in the wrong place */
-		    os_invalidate(new,len_diff);
-
-		new=os_allocate(len);
-		
-		if(new!=NULL){
-		    bcopy(addr,new,old_len);
-		    os_invalidate(addr,old_len);
-		}
-		
-		addr=new;
-	    }
-	}
-	
-	return addr;
-    }
-}
diff --git a/ldb/os.h b/ldb/os.h
deleted file mode 100644
index f8e13413dbe892eeaec7f12ed19252f1fb57c116..0000000000000000000000000000000000000000
--- a/ldb/os.h
+++ /dev/null
@@ -1,47 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/os.h,v 1.2 1991/05/24 17:57:40 wlott Exp $
- *
- * Common interface for os-dependent functions.
- *
- */
-
-#if !defined(_OS_H_INCLUDED_)
-
-#define _OS_H_INCLUDED_
-
-#ifdef MACH
-#include "mach-os.h"
-#else
-#ifdef sun
-#include "sunos-os.h"
-#endif
-#endif
-
-#define OS_VM_PROT_ALL (OS_VM_PROT_READ|OS_VM_PROT_WRITE|OS_VM_PROT_EXECUTE)
-
-extern os_vm_size_t os_vm_page_size;
-
-extern void os_install_interrupt_handlers();
-
-extern os_vm_address_t os_allocate(), os_reallocate();
-void os_deallocate();
-
-extern os_vm_address_t os_validate();
-extern void os_invalidate();
-extern void os_zero();
-extern os_vm_address_t os_map();
-extern void os_flush_icache();
-extern void os_protect();
-extern boolean valid_addr();
-
-#define os_trunc_to_page(addr) \
-    (os_vm_address_t)((long)addr&~(os_vm_page_size-1))
-#define os_round_up_to_page(addr) \
-    os_trunc_to_page(addr+(os_vm_page_size-1))
-
-#define os_trunc_size_to_page(size) \
-    (os_vm_size_t)((long)size&~(os_vm_page_size-1))
-#define os_round_up_size_to_page(size) \
-    os_trunc_size_to_page(size+(os_vm_page_size-1))
-
-#endif
diff --git a/ldb/pager.c b/ldb/pager.c
deleted file mode 100644
index 8baa95e7b6f33e57115c76f0624ccd6cb0e1688e..0000000000000000000000000000000000000000
--- a/ldb/pager.c
+++ /dev/null
@@ -1,587 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/pager.c,v 1.2 1991/02/19 12:27:41 ch Exp $
- * 
- * Mach Memory Manager for GC Support
- *
- * Written by Christopher Hoover
- */
-
-#include <stdio.h>
-#include <mach.h>
-#include <mach/message.h>
-#include <mach/mig_errors.h>
-#include <cthreads.h>
-#include "pager.h"
-
-static port_t pager_port;
-static port_set_name_t pager_port_set;
-
-
-/* Marking */
-
-#define PAGE_SIZE (4096)	/* ### Ack!  I want a constant here. */
-#define PAGE_SIZE_L2 (12)	/* log_{2} PAGE_SIZE  */
-
-#define OFFSET_TO_PAGE(offset) ((offset)>>PAGE_SIZE_L2)
-
-#define BITS_PER_BYTE (8)
-#define PAGES_PER_INDEX (sizeof(unsigned long) * BITS_PER_BYTE)
-
-#define PAGE_INDEX(page) ((page) / PAGES_PER_INDEX)
-#define PAGE_BIT(page) ((page) % PAGES_PER_INDEX)
-
-#define MARK(marked_pages,offset)					\
-	{ 								\
-		int page; 						\
-									\
-		page = OFFSET_TO_PAGE(offset); 				\
-	  	marked_pages[PAGE_INDEX(page)] |= (1<<PAGE_BIT(page));	\
-	}
-
-
-/* Pager Object Registry */
-
-static pager_object_t *pager_objects = NULL_PAGER_OBJECT;
-static mutex_t pager_objects_mutex;
-
-static pager_object_t *
-allocate_pager_object()
-{
-	pager_object_t *object;
-
-	object = (pager_object_t *) malloc(sizeof(pager_object_t));
-	
-	if (object == NULL_PAGER_OBJECT)
-		return NULL_PAGER_OBJECT;
-
-	mutex_lock(pager_objects_mutex);
-
-        object->next = pager_objects;
-	object->prev = NULL_PAGER_OBJECT;
-	
-	if (pager_objects != NULL_PAGER_OBJECT)
-		pager_objects->prev = object;
-
-	pager_objects = object;
-
-	mutex_unlock(pager_objects_mutex);
-
-	return object;
-}
-
-static void
-deallocate_pager_object(object)
-pager_object_t *object;
-{
-	mutex_lock(pager_objects_mutex);
-
-	if (object->prev == NULL_PAGER_OBJECT) {
-		/* Deleting item at head of list */
-		pager_objects = object->next;
-		if (pager_objects != NULL_PAGER_OBJECT)
-			pager_objects->prev = NULL_PAGER_OBJECT;
-	} else {
-		pager_object_t *prev;
-		pager_object_t *next;
-
-		prev = object->prev;
-		next = object->next;
-
-		prev->next = next;
-		if (next != NULL_PAGER_OBJECT)
-			next->prev = prev;
-	}
-
-	mutex_unlock(pager_objects_mutex);
-
-	(void) free((char *) object);
-}
-
-static pager_object_t *
-find_pager_object(memory_object)
-memory_object_t memory_object;
-{
-	pager_object_t *p;
-
-	mutex_lock(pager_objects_mutex);
-
-	for (p = pager_objects; p != NULL_PAGER_OBJECT; p = p->next)
-		if (p->object == memory_object)
-			break;
-
-	mutex_unlock(pager_objects_mutex);
-
-	return p;
-}
-
-
-/* Memory Object Allocation */
-
-static kern_return_t
-pager_allocate_memory_object(memory_object, address, size)
-memory_object_t *memory_object;
-vm_address_t address;
-vm_size_t size;
-{
-	kern_return_t kr;
-	pager_object_t *p;
-	port_t port;
-	memory_object_t object;
-
-	pagerlog("pager_allocate_memory_object(memory_object, size = 0x%08x)\n",
-	       size);
-
-	if (size != round_page(size)) {
-		kr = KERN_INVALID_ARGUMENT;
-		goto e0;
-	}
-
-
-	p = allocate_pager_object();
-	if (p == NULL_PAGER_OBJECT) {
-		kr = KERN_RESOURCE_SHORTAGE;
-		goto e0;
-	}
-
-	kr = port_allocate(task_self(), &port);
-	if (kr != KERN_SUCCESS)
-		goto e1;
-
-	object = (memory_object_t) port;
-
-	kr = port_set_add(task_self(), pager_port_set, port);
-	if (kr != KERN_SUCCESS)
-		goto e2;
-
-	p->object = object;
-	p->control = (memory_object_control_t) PORT_NULL;
-	p->name = (memory_object_name_t) PORT_NULL;
-	p->size = size;
-	p->backing_store = address;
-
-	*memory_object = object;
-
-	pagerlog("Allocated memory object %d.  Backing store: addr = 0x%08x, length = 0x%08x\n",
-	       port, address, size);
-
-	return KERN_SUCCESS;
-
- e2:
-	(void) port_deallocate(port);
- e1:
-	deallocate_pager_object(p);
- e0:
-	return kr;
-}
-
-static kern_return_t
-pager_deallocate_memory_object(memory_object)
-memory_object_t memory_object;
-{
-	pager_object_t *object;
-	kern_return_t kr0, kr1, kr2, kr3;
-
-	pagerlog("pager_deallocate_memory_object(memory_object = %d)\n",
-	       memory_object);
-
-	/* Find the pager object associated with this memory object. */
-	object = find_pager_object(memory_object);
-	if (object == NULL_PAGER_OBJECT)
-		return KERN_INVALID_ARGUMENT;
-	
-	/* Roll through these ignoring errors until later. */
-	kr0 = port_deallocate(task_self(), (port_t) object->object);
-	kr1 = port_deallocate(task_self(), (port_t) object->control);
-	kr2 = port_deallocate(task_self(), (port_t) object->name);
-	kr3 = vm_deallocate(task_self(), object->backing_store,
-			    object->size);
-
-	deallocate_pager_object(object);
-	
-	if (kr0 != KERN_SUCCESS)
-		return kr0;
-	else if (kr1 != KERN_SUCCESS)
-		return kr1;
-	else if (kr2 != KERN_SUCCESS)
-		return kr2;
-	else if (kr3 != KERN_SUCCESS)
-		return kr3;
-	else
-		return KERN_SUCCESS;
-
-}	
-
-
-/* Calls from the kernel */
-
-kern_return_t
-memory_object_init(memory_object, memory_control, memory_object_name,
-		   memory_object_page_size)
-memory_object_t memory_object;
-memory_object_control_t memory_control;
-memory_object_name_t memory_object_name;
-vm_size_t memory_object_page_size;
-{
-	kern_return_t;
-	pager_object_t *object;
-
-	pagerlog("memory_object_init(memory_object = %d, memory_control = %d, memory_object_name = %d, memory_object_pager_size = 0x%0x)\n",
-	       memory_object, memory_control, memory_object_name,
-	       memory_object_page_size);
-
-	/* Find the pager object associated with this memory object. */
-	object = find_pager_object(memory_object);
-	if (object == NULL_PAGER_OBJECT) {
-		pagerlog("No pager object for memory object in memory_object_init!\n");
-		return KERN_FAILURE;
-	}
-
-	if (memory_object_page_size != PAGE_SIZE) {
-		pagerlog("Hep me!  Page size, %d bytes, is not %d bytes!",
-			 memory_object_page_size, PAGE_SIZE);
-		return KERN_FAILURE;
-	}
-
-	/* Record the interesting information. */
-	object->control = memory_control;
-	object->name = memory_object_name;
-	object->page_size = memory_object_page_size;
-		
-
-	/* Handshake with kernel. */
-
-	/* ### May want to turn caching on ... probably won't be */
-	/* useful though. */
-	SYSCALL_OR_LOSE(memory_object_set_attributes(memory_control,
-						     TRUE, FALSE,
-						     MEMORY_OBJECT_COPY_DELAY));
-
-	return KERN_SUCCESS;
-}
-
-kern_return_t
-memory_object_terminate(memory_object, memory_control, memory_object_name)
-memory_object_t memory_object;
-memory_object_control_t memory_control;
-memory_object_name_t memory_object_name;
-{
-	pager_object_t *object;
-
-	pagerlog("memory_object_terminate(memory_object = %d, memory_control = %d, memory_object_name = %d)\n",
-	       memory_object, memory_control, memory_object_name);
-
-	/* Find the pager object associated with this memory object. */
-	object = find_pager_object(memory_object);
-	if (object == NULL_PAGER_OBJECT) {
-		pagerlog("No pager object for memory object in memory_object_terminate!\n");
-		return KERN_FAILURE;
-	}
-
-	SYSCALL_OR_LOSE(pager_deallocate_memory_object(memory_object));
-
-	return KERN_SUCCESS;
-}
-
-kern_return_t
-memory_object_data_request(memory_object, memory_control, offset, length,
-			   desired_access)
-memory_object_t memory_object;
-memory_object_control_t memory_control;
-vm_offset_t offset;
-vm_size_t length;
-vm_prot_t desired_access;
-{
-	pager_object_t *object;
-
-#if defined(LOG_REQUESTS)
-	pagerlog("memory_object_data_request(memory_object = %d, memory_control = %d, offset = 0x%08x, length = 0x%08x, desired access = 0x%0x)\n",
-	       memory_object, memory_control, offset, length, desired_access);
-#endif
-
-	/* Find the pager object associated with this memory object. */
-	object = find_pager_object(memory_object);
-	if (object == NULL_PAGER_OBJECT) {
-		pagerlog("No pager object for memory object in memory_object_data_request!\n");
-		return KERN_FAILURE;
-	}
-
-	if ((offset + length) <= object->size) {
-		/* ### The lock value is something we want to play with. */
-		SYSCALL_OR_LOSE(memory_object_data_provided(memory_control,
-							    offset,
-							    (object->backing_store +
-							     offset),
-							    length, VM_PROT_NONE));
-	} else {
-		/* Out of bounds. */
-		pagerlog("Out of bounds memory request in memory_object_data_request\n");
-		SYSCALL_OR_LOSE(memory_object_data_error(memory_control,
-							 offset, length,
-							 KERN_INVALID_ADDRESS));
-	}
-	return KERN_SUCCESS;
-}
-
-kern_return_t
-memory_object_data_write(memory_object, memory_control, offset, data, dataCnt)
-memory_object_t memory_object;
-memory_object_control_t memory_control;
-vm_offset_t offset;
-pointer_t data;
-unsigned int dataCnt;
-{
-	pager_object_t *object;
-
-#if defined(LOG_REQUESTS)
-	pagerlog("memory_object_data_write(memory_object = %d, memory_control = %d, offset = 0x%08x, data = 0x%08x, dataCnt = 0x%08x)\n",
-	       memory_object, memory_control, offset, data, dataCnt);
-#endif
-
-	/* Mark the page as dirty.
-	MARK(object->marked_pages, offset);
-
-	/* Find the pager object associated with this memory object. */
-	object = find_pager_object(memory_object);
-	if (object == NULL_PAGER_OBJECT) {
-		pagerlog("No pager object for memory object in memory_object_data_write!\n");
-		return KERN_FAILURE;
-	}
-
-	bcopy((char *) data, (char *) (object->backing_store + offset), dataCnt);
-
-	SYSCALL_OR_LOSE(vm_deallocate(task_self(), data, dataCnt));
-
-	return KERN_SUCCESS;
-}
-
-kern_return_t
-memory_object_copy(old_memory_object, old_memory_control, offset, length,
-		   new_memory_object)
-memory_object_t old_memory_object;
-memory_object_control_t old_memory_control;
-vm_offset_t offset;
-vm_size_t length;
-memory_object_t new_memory_object;
-{
-	pagerlog("memory_object_copy(old_memory_object = %d, old_memory_control = %d, offset = 0x%08x, length = 0x%08x, new_memory_object = %d)\n",
-	       old_memory_object, old_memory_control, offset, length,
-	       new_memory_object);
-
-	pagerlog("Received memory_object_copy() RPC???\n");
-
-	return KERN_SUCCESS;
-}
-
-kern_return_t
-memory_object_data_unlock(memory_object, memory_control, offset, length,
-			  desired_access)
-memory_object_t memory_object;
-memory_object_control_t memory_control;
-vm_offset_t offset;
-vm_size_t length;
-vm_prot_t desired_access;
-{
-	pagerlog("memory_object_data_unlock(memory_object = %d, memory_control = %d, offset = 0x%08x, length = 0x%08x, desired access = 0x%0x)\n",
-	       memory_object, memory_control, offset, length, desired_access);
-
-	return KERN_SUCCESS;
-}
-
-kern_return_t memory_object_lock_completed(memory_object, memory_control,
-					   offset, length)
-memory_object_t memory_object;
-memory_object_control_t memory_control;
-vm_offset_t offset;
-vm_size_t length;
-{
-	pagerlog("memory_object_lock_completed(memory_object = %d, memory_control = %d, offset = 0x%08x, length = 0x%08x)\n",
-	       memory_object, memory_control, offset, length);
-
-	return KERN_SUCCESS;
-}
-
-
-/* Server Loop */
-
-typedef struct {
-	msg_header_t head;
-	msg_type_t return_code_type;
-	kern_return_t return_code;
-} reply_t;
-
-static
-pager_serve_requests()
-{
-	struct {
-		msg_header_t header;
-		char data[MSG_SIZE_MAX - sizeof(msg_header_t)];
-	} in_msg, out_msg;
-
-	while (1) {
-		kern_return_t kr;
-		boolean_t won;
-		
-		in_msg.header.msg_local_port = pager_port_set;
-		in_msg.header.msg_size = sizeof(in_msg);
-		
-		kr = msg_receive(&in_msg.header, MSG_OPTION_NONE, 0);
-		if (kr != RCV_SUCCESS) {
-			pagerlog("msg_receive() lost.  kr = %d.\n", kr);
-			continue;
-		}
-
-#if DEBUG_MESSAGE
-		pagerlog("Message received on port %d\n",
-		       in_msg.header.msg_local_port);
-#endif
-
-		won = memory_object_server(&in_msg.header, &out_msg.header);
-		if (!won) {
-			pagerlog("memory_objectserver() lost.\n");
-			continue;
-		}
-		if ((((reply_t *) &out_msg)->return_code != MIG_NO_REPLY) &&
-		    ((out_msg.header.msg_remote_port != PORT_NULL))) {
-			kr = msg_send(&out_msg.header, MSG_OPTION_NONE, 0);
-			pagerlog("msg_send() lost.  kr = %d.\n", kr);
-		}
-	}
-}
-
-
-/* Mach Routine Emulation */
-
-kern_return_t
-pager_vm_allocate(task, address, size, anywhere)
-task_t task;
-vm_address_t *address;
-vm_size_t size;
-boolean_t anywhere;
-{
-	kern_return_t kr;
-	memory_object_t object;
-	vm_address_t backing_store;
-
-	pagerlog("pager_vm_allocate(*address = 0x%08x, size = 0x%08x, anywhere = %d)\n",
-	       *address, size, anywhere);
-
-	if (task != task_self())
-		return KERN_INVALID_ARGUMENT;
-
-	/* Emulate vm_allocate() ... */
-
-	if (size == 0) {
-		*address = 0;
-		return KERN_SUCCESS;
-	}
-
-	*address = trunc_page(*address);
-	size = round_page(size);
-
-	kr = vm_allocate(task_self(), &backing_store, size, TRUE);
-	if (kr != KERN_SUCCESS)
-		goto e0;
-
-	/* Now get a memory_object */
-	kr = pager_allocate_memory_object(&object, backing_store, size);
-	if (kr != KERN_SUCCESS)
-		goto e0;
-
-	kr = vm_map(task_self(), address, size, 0, anywhere,
-		    object, 0, FALSE, VM_PROT_ALL, VM_PROT_ALL,
-		    VM_INHERIT_COPY);
-	if (kr != KERN_SUCCESS)
-		goto e1;
-
-	return KERN_SUCCESS;
-
- e1:
-	(void) pager_deallocate_memory_object(object);
- e0:
-	return kr;
-}
-
-kern_return_t
-pager_vm_deallocate(task, address, size)
-task_t task;
-vm_address_t address;
-vm_size_t size;
-{
-	pagerlog("pager_vm_deallocate(address = 0x%08x, size = 0x%08x)\n",
-	       address, size);
-
-	if (task != task_self())
-		return KERN_INVALID_ARGUMENT;
-
-	return vm_deallocate(task_self(), address, size);
-}
-
-kern_return_t
-pager_map_fd(fd, offset, address, anywhere, size)
-int fd;
-vm_offset_t offset;
-vm_address_t *address;
-boolean_t anywhere;
-vm_size_t size;
-{
-	kern_return_t kr;
-	memory_object_t object;
-	vm_address_t backing_store;
-
-	pagerlog("pager_map_fd(fd = %d, offset = 0x%08x, *address = 0x%08x, anywhere = %d, size = 0x%08x)\n",
-	       fd, offset, *address, anywhere, size);
-
-	kr = map_fd(fd, offset, &backing_store, TRUE, size);
-	if (kr != KERN_SUCCESS)
-		goto e0;
-
-	/* Now get a memory_object */
-	kr = pager_allocate_memory_object(&object, backing_store, size);
-	if (kr != KERN_SUCCESS)
-		goto e0;
-
-	(void) vm_deallocate(task_self(), *address, size);
-	kr = vm_map(task_self(), address, size, 0, anywhere,
-		    object, 0, FALSE, VM_PROT_ALL, VM_PROT_ALL,
-		    VM_INHERIT_COPY);
-	if (kr != KERN_SUCCESS)
-		goto e1;
-
-	return KERN_SUCCESS;
-
- e1:
-	(void) pager_deallocate_memory_object(object);
- e0:
-	return kr;
-}
-
-
-/* Initialization */
-
-static
-pager_thread(arg)
-any_t arg;
-{
-	pagerlog("pager_thread() started.\n");
-	
-	pager_serve_requests();
-}
-
-pager_init()
-{
-	pager_objects_mutex = mutex_alloc();
-
-	pagerlog(";;; Lisp pager log started.\n;;;\n");
-
-	SYSCALL_OR_LOSE(port_allocate(task_self(), &pager_port));
-	pagerlog(";;; pager_port = %d\n", pager_port);
-
-	SYSCALL_OR_LOSE(port_set_allocate(task_self(), &pager_port_set));
-	pagerlog(";;; pager_port_set = %d\n", pager_port_set);
-
-	pagerlog(";;;\n");
-
-	SYSCALL_OR_LOSE(port_set_add(task_self(), pager_port_set, pager_port));
-
-	cthread_detach(cthread_fork(pager_thread, (any_t) 0));
-}
diff --git a/ldb/pager.h b/ldb/pager.h
deleted file mode 100644
index c7d883558321ae31a1d8170e987af89d2a6a8a49..0000000000000000000000000000000000000000
--- a/ldb/pager.h
+++ /dev/null
@@ -1,47 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/pager.h,v 1.2 1991/02/19 12:27:47 ch Exp $
- * 
- * pager.h
- */
-
-#if !defined(_PAGER_H_INCLUDED_)
-#define _PAGER_H_INCLUDED_
-
-typedef struct pager_object {
-	memory_object_t object;
-	memory_object_control_t control;
-	memory_object_name_t name;
-	vm_size_t size;
-	vm_address_t backing_store;
-	vm_size_t page_size;
-	unsigned long *marked_pages;
-	struct pager_object *prev;
-	struct pager_object *next;
-} pager_object_t;
-
-#define NULL_PAGER_OBJECT ((pager_object_t *) 0)
-
-#define SYSCALL_OR_LOSE(syscall) {                         	\
-	kern_return_t kr;                                  	\
-                                                           	\
-	if ((kr = (syscall)) != KERN_SUCCESS) {            	\
-		fprintf(stderr, "ERROR:\n");			\
-		fprintf(stderr, "In file \"%s\", line %d:",	\
-			__FILE__, __LINE__);               	\
-		mach_error("", kr);                        	\
-		exit(1);                                   	\
-	}                                                  	\
-}						   
-						   
-#define SYSCALL_OR_WARN(syscall) {                         	\
-	kern_return_t kr;                                  	\
-                                                           	\
-	if ((kr = (syscall)) != KERN_SUCCESS) {            	\
-		fprintf(stderr, "WARNING:\n");			\
-		fprintf(stderr, "In file \"%s\", line %d:",	\
-			__FILE__, __LINE__);               	\
-		mach_error("", kr);                        	\
-	}                                                  	\
-}						   
-						   
-#endif
diff --git a/ldb/pagerlog.c b/ldb/pagerlog.c
deleted file mode 100644
index 08fa2c0228d9cd442f084d368d8cfc085d1085cb..0000000000000000000000000000000000000000
--- a/ldb/pagerlog.c
+++ /dev/null
@@ -1,50 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/pagerlog.c,v 1.2 1991/02/19 12:27:50 ch Exp $
- * 
- * pager log facility
- *
- */
-
-#include <stdio.h>
-#include <varargs.h>
-
-#define PAGERLOG_ENVVAR "PAGERLOG"
-#define PAGERLOG_DEFAULT "./pager.log"
-
-extern char *getenv();
-
-static initialized = 0;
-static FILE *logfile;
-
-static void
-initialize_pagerlog()
-{
-	char *log;
-
-	log = getenv(PAGERLOG_ENVVAR);
-	if (log == NULL)
-		log = PAGERLOG_DEFAULT;
-
-	logfile = fopen(log, "w+");
-	if (logfile == (FILE *) NULL) {
-		fprintf(stderr, "pagerlog: cannot open \"%s\"\n", log);
-		exit(1);
-	}
-	setlinebuf(logfile);
-	initialized = 1;	
-}
-
-/*VARARGS1*/
-pagerlog(fmt, va_alist)
-char *fmt;
-va_dcl
-{
-	va_list pvar;
-	
-	if (!initialized)
-		initialize_pagerlog();
-
-	va_start(pvar);
-	vfprintf(logfile, fmt, pvar);
-	va_end(pvar);
-}
diff --git a/ldb/parse.c b/ldb/parse.c
deleted file mode 100644
index 6d04ccf13fbd941dd82a9ca7badfaec4aebf37cf..0000000000000000000000000000000000000000
--- a/ldb/parse.c
+++ /dev/null
@@ -1,360 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/parse.c,v 1.7 1991/05/24 18:34:59 wlott Exp $ */
-#include <stdio.h>
-#include <ctype.h>
-#include <signal.h>
-#include <strings.h>
-
-#include "ldb.h"
-#include "lisp.h"
-#include "globals.h"
-#include "vars.h"
-#include "parse.h"
-#include "interrupt.h"
-#include "lispregs.h"
-
-static int strcasecmp(s1,s2)
-char *s1,*s2;
-{
-    int c1, c2;
-
-    do{
-	c1=(*s1++);
-	if(isupper(c1))
-	    c1=tolower(c1);
-
-	c2=(*s2++);
-	if(isupper(c2))
-	    c2=tolower(c2);
-    }while(c1==c2 && c1!=0);
-
-    return c1-c2;
-}
-
-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;
-}
-
-static boolean lookup_symbol(name, result)
-char *name;
-lispobj *result;
-{
-    int count;
-
-    /* Search static space */
-    *result = (lispobj) static_space;
-    count = ((lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER) -
-	     static_space);
-    if (search_for_symbol(name, result, &count)) {
-        *result |= type_OtherPointer;
-        return TRUE;
-    }
-
-    /* Search dynamic space */
-    *result = (lispobj) current_dynamic_space;
-#ifndef ibmrt
-    count = current_dynamic_space_free_pointer - current_dynamic_space;
-#else
-    count = (lispobj *)SymbolValue(ALLOCATION_POINTER) - current_dynamic_space;
-#endif
-    if (search_for_symbol(name, result, &count)) {
-        *result |= type_OtherPointer;
-        return TRUE;
-    }
-
-    return FALSE;
-}
-
-static int
-parse_regnum(s)
-char *s;
-{
-	if ((s[1] == 'R') || (s[1] == 'r')) {
-		int regnum;
-
-		if (s[2] == '\0')
-			return -1;
-
-		/* skip the $R part and call atoi on the number */
-		regnum = atoi(s + 2);
-		if ((regnum >= 0) && (regnum < NREGS))
-			return regnum;
-		else
-			return -1;
-	} else {
-		int i;
-
-		for (i = 0; i < NREGS ; i++)
-			if (strcasecmp(s + 1, lisp_register_names[i]) == 0)
-				return i;
-		
-		return -1;
-	}
-}
-
-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 (isalpha(token[1])) {
-		int free;
-		int regnum;
-		struct sigcontext *context;
-
-		free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
-
-		if (free == 0) {
-			printf("Variable ``%s'' is not valid -- there is no current interrupt context.\n", token);
-			throw_to_monitor();
-		}
-
-		context = lisp_interrupt_contexts[free - 1];
-
-		regnum = parse_regnum(token);
-		if (regnum < 0) {
-			printf("Bogus register: ``%s''\n", token);
-			throw_to_monitor();
-		}
-
-		result = context->sc_regs[regnum];
-	} else 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))
-        ;
-    else if (lookup_symbol(token, &result))
-        ;
-    else {
-        printf("Invalid lisp object: ``%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 080586e13144c4d7c54e5e2f4467d4c76a70ed6b..0000000000000000000000000000000000000000
--- a/ldb/print.c
+++ /dev/null
@@ -1,585 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/print.c,v 1.17 1992/03/08 18:39:57 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, brief_depth = 2, cur_depth = 0;
-static int max_length = 5;
-static boolean dont_decend = FALSE, skip_newline = FALSE;
-static cur_clock = 0;
-
-static void print_obj();
-
-#define NEWLINE if (continue_p(TRUE)) 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[] = {
-    "unused 0",
-    "unused 1",
-    "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 header",
-    "funcallable-instance header",
-    "unused function header 1",
-    "unused function header 2",
-    "unused function header 3",
-    "closure function header",
-    "return PC header",
-    "value cell header",
-    "symbol header",
-    "character",
-    "SAP",
-    "unbound marker",
-    "weak pointer",
-    "structure header",
-    "fdefn"
-};
-
-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(newline)
-boolean newline;
-{
-    char buffer[256];
-
-    if (cur_depth >= max_depth || dont_decend)
-        return FALSE;
-
-    if (newline) {
-        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 brief_fixnum(obj)
-lispobj obj;
-{
-    printf("%d", ((long)obj)>>2);
-}
-
-static void print_fixnum(obj)
-lispobj obj;
-{
-    printf(": %d", ((long)obj)>>2);
-}
-
-static void brief_otherimm(obj)
-lispobj obj;
-{
-    int type, c, idx;
-    char buffer[10];
-
-    type = TypeOf(obj);
-    switch (type) {
-        case type_BaseChar:
-            c = (obj>>8)&0xff;
-            switch (c) {
-                case '\0':
-                    printf("#\\Null");
-                    break;
-                case '\n':
-                    printf("#\\Newline");
-                    break;
-                case '\b':
-                    printf("#\\Backspace");
-                    break;
-                case '\177':
-                    printf("#\\Delete");
-                    break;
-                default:
-                    strcpy(buffer, "#\\");
-                    if (c >= 128) {
-                        strcat(buffer, "m-");
-                        c -= 128;
-                    }
-                    if (c < 32) {
-                        strcat(buffer, "c-");
-                        c += '@';
-                    }
-                    printf("%s%c", buffer, c);
-                    break;
-            }
-            break;
-
-        case type_UnboundMarker:
-            printf("<unbound marker>");
-            break;
-
-        default:
-	    idx = type >> 2;
-	    if (idx < (sizeof(subtype_Names) / sizeof(char *)))
-		    printf("%s", subtype_Names[idx]);
-	    else
-		    printf("unknown type (0x%0x)", type);
-            break;
-    }
-}
-
-static void print_otherimm(obj)
-lispobj obj;
-{
-    int type, c, idx;
-
-    type = TypeOf(obj);
-    idx = type >> 2;
-
-    if (idx < (sizeof(subtype_Names) / sizeof(char *)))
-	    printf(", %s", subtype_Names[idx]);
-    else
-	    printf(", unknown type (0x%0x)", type);
-
-    switch (TypeOf(obj)) {
-        case type_BaseChar:
-            printf(": ");
-            brief_otherimm(obj);
-            break;
-
-        case type_Sap:
-        case type_UnboundMarker:
-            break;
-
-        default:
-            printf(": data=%d", (obj>>8)&0xffffff);
-            break;
-    }
-}
-
-static void brief_list(obj)
-lispobj obj;
-{
-    int space = FALSE;
-    int length = 0;
-
-    if (!valid_addr(obj))
-	    printf("(invalid address)");
-    else if (obj == NIL)
-        printf("NIL");
-    else {
-        putchar('(');
-        while (LowtagOf(obj) == type_ListPointer) {
-            struct cons *cons = (struct cons *)PTR(obj);
-
-            if (space)
-                putchar(' ');
-            if (++length >= max_length) {
-                printf("...");
-                obj = NIL;
-                break;
-            }
-            print_obj(NULL, cons->car);
-            obj = cons->cdr;
-            space = TRUE;
-            if (obj == NIL)
-                break;
-        }
-        if (obj != NIL) {
-            printf(" . ");
-            print_obj(NULL, obj);
-        }
-        putchar(')');
-    }
-}
-
-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 brief_struct(obj)
-lispobj obj;
-{
-    printf("#<ptr to ");
-    print_obj(NULL, ((struct structure *)PTR(obj))->slots[0]);
-    printf(" structure>");
-}
-
-static void print_struct(obj)
-lispobj obj;
-{
-    struct structure *structure = (struct structure *)PTR(obj);
-    int i;
-    char buffer[16];
-
-    print_obj("type: ", structure->slots[0]);
-    for (i = 1; i < HeaderValue(structure->header); i++) {
-	sprintf(buffer, "slot %d: ", i);
-	print_obj(buffer, structure->slots[i]);
-    }
-}
-
-static void brief_otherptr(obj)
-lispobj obj;
-{
-    lispobj *ptr, header;
-    int type;
-    struct symbol *symbol;
-    struct vector *vector;
-    char *charptr;
-
-    ptr = (lispobj *) PTR(obj);
-
-    if (!valid_addr(obj)) {
-	    printf("(invalid address)");
-	    return;
-    }
-
-    header = *ptr;
-    type = TypeOf(header);
-    switch (type) {
-        case type_SymbolHeader:
-            symbol = (struct symbol *)ptr;
-            vector = (struct vector *)PTR(symbol->name);
-            for (charptr = (char *)vector->data; *charptr != '\0'; charptr++) {
-                if (*charptr == '"')
-                    putchar('\\');
-                putchar(*charptr);
-            }
-            break;
-
-        case type_SimpleString:
-            vector = (struct vector *)ptr;
-            putchar('"');
-            for (charptr = (char *)vector->data; *charptr != '\0'; charptr++) {
-                if (*charptr == '"')
-                    putchar('\\');
-                putchar(*charptr);
-            }
-            putchar('"');
-            break;
-            
-        default:
-            printf("#<ptr to ");
-            brief_otherimm(header);
-            putchar('>');
-    }
-}
-
-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: ", "unused: ",
-    "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 char *weak_pointer_slots[] = {"value: ", NULL};
-static char *fdefn_slots[] = {"name: ", "function: ", "raw_addr: ", NULL};
-
-static void print_otherptr(obj)
-lispobj obj;
-{
-    if (!valid_addr(obj))
-	    printf("(invalid address)");
-    else {
-        unsigned long *ptr; 
-        unsigned long header;
-        unsigned long length;
-        int count, type, index;
-        boolean raw;
-        char *cptr, buffer[16];
-
-	ptr = (unsigned long *) PTR(obj);
-	if (ptr == (unsigned long *) NULL) {
-		printf(" (NULL Pointer)");
-		return;
-	}
-
-	header = *ptr++;
-	length = (*ptr) >> 2;
-	count = header>>8;
-	type = TypeOf(header);
-
-        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", ((struct single_float *)PTR(obj))->value);
-                break;
-
-            case type_DoubleFloat:
-                NEWLINE;
-                printf("%lf", ((struct double_float *)PTR(obj))->value);
-                break;
-
-            case type_SimpleString:
-                NEWLINE;
-                cptr = (char *)(ptr+1);
-                putchar('\"');
-                while (length-- > 0)
-                    putchar(*cptr++);
-                putchar('\"');
-                break;
-
-            case type_SimpleVector:
-            case type_StructureHeader:
-                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:
-                print_obj("code: ", obj - (count * 4));
-                break;
-
-            case type_ClosureHeader:
-                print_slots(closure_slots, count, ptr);
-                break;
-
-            case type_Sap:
-                NEWLINE;
-                printf("0x%08x", *ptr);
-                break;
-
-            case type_WeakPointer:
-		print_slots(weak_pointer_slots, 1, ptr);
-                break;
-
-            case type_BaseChar:
-            case type_UnboundMarker:
-                NEWLINE;
-                printf("pointer to an immediate?");
-                break;
-
-	      case type_Fdefn:
-		print_slots(fdefn_slots, count, ptr);
-		break;
-		
-            default:
-                NEWLINE;
-                printf("Unknown header object?");
-                break;
-        }
-    }
-}
-
-static void print_obj(prefix, obj)
-char *prefix;
-lispobj obj;
-{
-    static void (*verbose_fns[])() = {print_fixnum, print_otherptr, print_otherimm, print_list, print_fixnum, print_struct, print_otherimm, print_otherptr};
-    static void (*brief_fns[])() = {brief_fixnum, brief_otherptr, brief_otherimm, brief_list, brief_fixnum, brief_struct, brief_otherimm, brief_otherptr};
-    int type = LowtagOf(obj);
-    struct var *var = lookup_by_obj(obj);
-    char buffer[256];
-    boolean verbose = cur_depth < brief_depth;
-
-    
-    if (!continue_p(verbose))
-        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);
-
-    cur_depth++;
-    if (verbose) {
-        if (var != NULL) {
-            sprintf(buffer, "$%s=", var_name(var));
-            newline(buffer);
-        }
-        else
-            newline(NULL);
-        printf("%s0x%08x: ", prefix, obj);
-        if (cur_depth < brief_depth) {
-            fputs(lowtag_Names[type], stdout);
-            (*verbose_fns[type])(obj);
-        }
-        else
-            (*brief_fns[type])(obj);
-    }
-    else {
-        if (dont_decend)
-            printf("$%s", var_name(var));
-        else {
-            if (var != NULL)
-                printf("$%s=", var_name(var));
-            (*brief_fns[type])(obj);
-        }
-    }
-    cur_depth--;
-    dont_decend = FALSE;
-}
-
-void reset_printer()
-{
-    cur_clock++;
-    cur_lines = 0;
-    dont_decend = FALSE;
-}
-
-void print(obj)
-lispobj obj;
-{
-    skip_newline = TRUE;
-    cur_depth = 0;
-    max_depth = 5;
-    max_lines = 20;
-
-    print_obj("", obj);
-
-    putchar('\n');
-}
-
-void brief_print(obj)
-lispobj obj;
-{
-    skip_newline = TRUE;
-    max_depth = 1;
-    max_lines = 5000;
-
-    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/purify.c b/ldb/purify.c
deleted file mode 100644
index 9c2581ed5fa788f2acda8c1a8294e8b0a41475a5..0000000000000000000000000000000000000000
--- a/ldb/purify.c
+++ /dev/null
@@ -1,736 +0,0 @@
-/* Purify. */
-
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/purify.c,v 1.18 1992/04/15 00:40:00 wlott Exp $ */
-
-#include <stdio.h>
-
-#include "lisp.h"
-#include "ldb.h"
-#include "os.h"
-#include "globals.h"
-#include "validate.h"
-#include "interrupt.h"
-#include "gc.h"
-
-/* These hold the original end of the read_only and static spaces so we can */
-/* tell what are forwarding pointers. */
-
-static lispobj *read_only_end, *static_end;
-
-static lispobj *read_only_free, *static_free;
-static lispobj *pscav();
-
-#define LATERBLOCKSIZE 1020
-#define LATERMAXCOUNT 10
-
-static struct later {
-    struct later *next;
-    union {
-        lispobj *ptr;
-        int count;
-    } u[LATERBLOCKSIZE];
-} *later_blocks = NULL;
-static int later_count = 0;
-
-
-#define NWORDS(x,y) (CEILING((x),(y)) / (y))
-
-#ifdef sparc
-#define RAW_ADDR_OFFSET 0
-#else
-#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
-#endif
-
-static boolean forwarding_pointer_p(obj)
-     lispobj obj;
-{
-    lispobj *ptr;
-
-    ptr = (lispobj *)obj;
-
-    return ((static_end <= ptr && ptr <= static_free) ||
-            (read_only_end <= ptr && ptr <= read_only_free));
-}
-
-static boolean dynamic_pointer_p(ptr)
-     lispobj ptr;
-{
-    return ptr >= (lispobj)dynamic_0_space;
-}
-
-static void pscav_later(where, count)
-     lispobj *where;
-     int count;
-{
-    struct later *new;
-
-    if (count > LATERMAXCOUNT) {
-        while (count > LATERMAXCOUNT) {
-            pscav_later(where, LATERMAXCOUNT);
-            count -= LATERMAXCOUNT;
-            where += LATERMAXCOUNT;
-        }
-    }
-    else {
-        if (later_blocks == NULL || later_count == LATERBLOCKSIZE ||
-            (later_count == LATERBLOCKSIZE-1 && count > 1)) {
-            new  = (struct later *)malloc(sizeof(struct later));
-            new->next = later_blocks;
-            if (later_blocks && later_count < LATERBLOCKSIZE)
-                later_blocks->u[later_count].ptr = NULL;
-            later_blocks = new;
-            later_count = 0;
-        }
-
-        if (count != 1)
-            later_blocks->u[later_count++].count = count;
-        later_blocks->u[later_count++].ptr = where;
-    }
-}
-
-static lispobj ptrans_boxed(thing, header, constant)
-     lispobj thing, header;
-     boolean constant;
-{
-    int nwords;
-    lispobj result, *new, *old;
-
-    nwords = 1 + HeaderValue(header);
-
-    /* Allocate it */
-    old = (lispobj *)PTR(thing);
-    if (constant) {
-        new = read_only_free;
-        read_only_free += CEILING(nwords, 2);
-    }
-    else {
-        new = static_free;
-        static_free += CEILING(nwords, 2);
-    }
-
-    /* Copy it. */
-    bcopy(old, new, nwords * sizeof(lispobj));
-
-    /* Deposit forwarding pointer. */
-    result = (lispobj)new | LowtagOf(thing);
-    *old = result;
-        
-    /* Scavenge it. */
-    pscav(new, nwords, constant);
-
-    return result;
-}
-
-static lispobj ptrans_fdefn(thing, header)
-{
-    int nwords;
-    lispobj result, *new, *old, oldfn;
-    struct fdefn *fdefn;
-
-    nwords = 1 + HeaderValue(header);
-
-    /* Allocate it */
-    old = (lispobj *)PTR(thing);
-    new = static_free;
-    static_free += CEILING(nwords, 2);
-
-    /* Copy it. */
-    bcopy(old, new, nwords * sizeof(lispobj));
-
-    /* Deposit forwarding pointer. */
-    result = (lispobj)new | LowtagOf(thing);
-    *old = result;
-
-    /* Scavenge the function. */
-    fdefn = (struct fdefn *)new;
-    oldfn = fdefn->function;
-    pscav(&fdefn->function, 1, FALSE);
-    if ((char *)oldfn + RAW_ADDR_OFFSET == fdefn->raw_addr)
-        fdefn->raw_addr = (char *)fdefn->function + RAW_ADDR_OFFSET;
-
-    return result;
-}
-
-static lispobj ptrans_unboxed(thing, header)
-{
-    int nwords;
-    lispobj result, *new, *old;
-
-    nwords = 1 + HeaderValue(header);
-
-    /* Allocate it */
-    old = (lispobj *)PTR(thing);
-    new = read_only_free;
-    read_only_free += CEILING(nwords, 2);
-
-    /* Copy it. */
-    bcopy(old, new, nwords * sizeof(lispobj));
-
-    /* Deposit forwarding pointer. */
-    result = (lispobj)new | LowtagOf(thing);
-    *old = result;
-
-    return result;
-}
-
-static lispobj ptrans_vector(thing, bits, extra, boxed, constant)
-     lispobj thing;
-     int bits, extra;
-     boolean boxed, constant;
-{
-    struct vector *vector;
-    int nwords;
-    lispobj result, *new;
-
-    vector = (struct vector *)PTR(thing);
-    nwords = 2 + (CEILING((FIXNUM_TO_INT(vector->length)+extra)*bits,32)>>5);
-
-    if (boxed && !constant) {
-        new = static_free;
-        static_free += CEILING(nwords, 2);
-    }
-    else {
-        new = read_only_free;
-        read_only_free += CEILING(nwords, 2);
-    }
-
-    bcopy(vector, new, nwords * sizeof(lispobj));
-
-    result = (lispobj)new | LowtagOf(thing);
-    vector->header = result;
-
-    if (boxed)
-        pscav(new, nwords, constant);
-
-    return result;
-}
-
-
-static lispobj ptrans_code(thing)
-     lispobj thing;
-{
-    struct code *code, *new;
-    int nwords;
-    lispobj func, result;
-
-    code = (struct code *)PTR(thing);
-    nwords = HeaderValue(code->header) + FIXNUM_TO_INT(code->code_size);
-
-    new = (struct code *)read_only_free;
-    read_only_free += CEILING(nwords, 2);
-
-    bcopy(code, new, nwords * sizeof(lispobj));
-    
-    result = (lispobj)new | type_OtherPointer;
-
-    /* Stick in a forwarding pointer for the code object. */
-    *(lispobj *)code = result;
-
-    /* Put in forwarding pointers for all the functions. */
-    for (func = code->entry_points;
-         func != NIL;
-         func = ((struct function_header *)PTR(func))->next) {
-
-        gc_assert(LowtagOf(func) == type_FunctionPointer);
-
-        *(lispobj *)PTR(func) = result + (func - thing);
-    }
-
-    /* Arrange to scavenge the debug info later. */
-    pscav_later(&new->debug_info, 1);
-
-    /* Scavenge the constants. */
-    pscav(new->constants, HeaderValue(new->header)-5, TRUE);
-
-    /* Scavenge all the functions. */
-    pscav(&new->entry_points, 1, TRUE);
-    for (func = new->entry_points;
-         func != NIL;
-         func = ((struct function_header *)PTR(func))->next) {
-        gc_assert(LowtagOf(func) == type_FunctionPointer);
-        gc_assert(!dynamic_pointer_p(func));
-        pscav(&((struct function_header *)PTR(func))->self, 2, TRUE);
-        pscav_later(&((struct function_header *)PTR(func))->name, 3);
-    }
-
-    return result;
-}
-
-static lispobj ptrans_func(thing, header, constant)
-     lispobj thing, header;
-     boolean constant;
-{
-    int nwords;
-    lispobj code, *new, *old, result;
-    struct function_header *function;
-
-    /* THING can either be a function header, a closure function header, */
-    /* a closure, or a funcallable-instance.  If it's a closure or a */
-    /* funcallable-instance, we do the same as ptrans_boxed. */
-    /* Otherwise we have to do something strange, 'cause it is buried inside */
-    /* a code object. */
-
-    if (TypeOf(header) == type_FunctionHeader ||
-        TypeOf(header) == type_ClosureFunctionHeader) {
-
-	/* We can only end up here if the code object has not been */
-        /* scavenged, because if it had been scavenged, forwarding pointers */
-        /* would have been left behind for all the entry points. */
-
-        function = (struct function_header *)PTR(thing);
-        code = PTR(thing) - (HeaderValue(function->header) * sizeof(lispobj)) |
-            type_OtherPointer;
-
-        /* This will cause the function's header to be replaced with a */
-        /* forwarding pointer. */
-        ptrans_code(code);
-
-        /* So we can just return that. */
-        return function->header;
-    }
-    else {
-	/* It's some kind of closure-like thing. */
-        nwords = 1 + HeaderValue(header);
-        old = (lispobj *)PTR(thing);
-
-	/* Allocate the new one. */
-	if (TypeOf(header) == type_FuncallableInstanceHeader) {
-	    /* FINs *must* not go in read_only space. */
-	    new = static_free;
-	    static_free += CEILING(nwords, 2);
-	}
-	else {
-	    /* Closures can always go in read-only space, 'caues */
-	    /* they never change. */
-	    new = read_only_free;
-	    read_only_free += CEILING(nwords, 2);
-	}
-
-        /* Copy it. */
-        bcopy(old, new, nwords * sizeof(lispobj));
-
-        /* Deposit forwarding pointer. */
-        result = (lispobj)new | LowtagOf(thing);
-        *old = result;
-
-        /* Scavenge it. */
-        pscav(new, nwords, constant);
-
-        return result;
-    }
-}
-
-static lispobj ptrans_returnpc(thing, header)
-     lispobj thing, header;
-{
-    lispobj code, new;
-
-    /* Find the corresponding code object. */
-    code = thing - HeaderValue(header)*sizeof(lispobj);
-
-    /* Make sure it's been transported. */
-    new = *(lispobj *)PTR(code);
-    if (!forwarding_pointer_p(new))
-        new = ptrans_code(code);
-
-    /* Maintain the offset: */
-    return new + (thing - code);
-}
-
-#define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
-
-static lispobj ptrans_list(thing, constant)
-     lispobj thing;
-     boolean constant;
-{
-    struct cons *old, *new, *orig;
-    int length;
-
-    if (constant)
-        orig = (struct cons *)read_only_free;
-    else
-        orig = (struct cons *)static_free;
-    length = 0;
-
-    do {
-        /* Allocate a new cons cell. */
-        old = (struct cons *)PTR(thing);
-        if (constant) {
-            new = (struct cons *)read_only_free;
-            read_only_free += WORDS_PER_CONS;
-        }
-        else {
-            new = (struct cons *)static_free;
-            static_free += WORDS_PER_CONS;
-        }
-
-        /* Copy the cons cell and keep a pointer to the cdr. */
-        new->car = old->car;
-        thing = new->cdr = old->cdr;
-
-        /* Set up the forwarding pointer. */
-        *(lispobj *)old = ((lispobj)new) | type_ListPointer;
-
-        /* And count this cell. */
-        length++;
-    } while (LowtagOf(thing) == type_ListPointer &&
-             dynamic_pointer_p(thing) &&
-             !(forwarding_pointer_p(*(lispobj *)PTR(thing))));
-
-    /* Scavenge the list we just copied. */
-    pscav(orig, length * WORDS_PER_CONS, constant);
-
-    return ((lispobj)orig) | type_ListPointer;
-}
-
-static lispobj ptrans_otherptr(thing, header, constant)
-     lispobj thing, header;
-     boolean constant;
-{
-    switch (TypeOf(header)) {
-      case type_Bignum:
-      case type_SingleFloat:
-      case type_DoubleFloat:
-      case type_Sap:
-        return ptrans_unboxed(thing, header);
-
-      case type_Ratio:
-      case type_Complex:
-      case type_SimpleArray:
-      case type_ComplexString:
-      case type_ComplexVector:
-      case type_ComplexArray:
-        return ptrans_boxed(thing, header, constant);
-
-      case type_ValueCellHeader:
-      case type_WeakPointer:
-        return ptrans_boxed(thing, header, FALSE);
-
-      case type_SymbolHeader:
-        return ptrans_boxed(thing, header, FALSE);
-
-      case type_SimpleString:
-        return ptrans_vector(thing, 8, 1, FALSE, constant);
-
-      case type_SimpleBitVector:
-        return ptrans_vector(thing, 1, 0, FALSE, constant);
-
-      case type_SimpleVector:
-        return ptrans_vector(thing, 32, 0, TRUE, constant);
-
-      case type_SimpleArrayUnsignedByte2:
-        return ptrans_vector(thing, 2, 0, FALSE, constant);
-
-      case type_SimpleArrayUnsignedByte4:
-        return ptrans_vector(thing, 4, 0, FALSE, constant);
-
-      case type_SimpleArrayUnsignedByte8:
-        return ptrans_vector(thing, 8, 0, FALSE, constant);
-
-      case type_SimpleArrayUnsignedByte16:
-        return ptrans_vector(thing, 16, 0, FALSE, constant);
-
-      case type_SimpleArrayUnsignedByte32:
-        return ptrans_vector(thing, 32, 0, FALSE, constant);
-
-      case type_SimpleArraySingleFloat:
-        return ptrans_vector(thing, 32, 0, FALSE, constant);
-
-      case type_SimpleArrayDoubleFloat:
-        return ptrans_vector(thing, 64, 0, FALSE, constant);
-
-      case type_CodeHeader:
-        return ptrans_code(thing);
-
-      case type_ReturnPcHeader:
-        return ptrans_returnpc(thing, header);
-
-      case type_Fdefn:
-	return ptrans_fdefn(thing, header);
-
-      default:
-        /* Should only come across other pointers to the above stuff. */
-        gc_abort();
-    }
-}
-
-static int pscav_fdefn(fdefn)
-     struct fdefn *fdefn;
-{
-    boolean fix_func;
-
-    fix_func = ((char *)(fdefn->function+RAW_ADDR_OFFSET) == fdefn->raw_addr);
-    pscav(&fdefn->name, 1, TRUE);
-    pscav(&fdefn->function, 1, FALSE);
-    if (fix_func)
-        fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET);
-    return sizeof(struct fdefn) / sizeof(lispobj);
-}
-
-static lispobj *pscav(addr, nwords, constant)
-     lispobj *addr;
-     int nwords;
-     boolean constant;
-{
-    lispobj thing, *thingp, header;
-    int count;
-    struct vector *vector;
-
-    while (nwords > 0) {
-        thing = *addr;
-        if (Pointerp(thing)) {
-            /* It's a pointer.  Is it something we might have to move? */
-            if (dynamic_pointer_p(thing)) {
-                /* Maybe.  Have we already moved it? */
-                thingp = (lispobj *)PTR(thing);
-                header = *thingp;
-                if (Pointerp(header) && forwarding_pointer_p(header))
-                    /* Yep, so just copy the forwarding pointer. */
-                    thing = header;
-                else {
-                    /* Nope, copy the object. */
-                    switch (LowtagOf(thing)) {
-                      case type_FunctionPointer:
-                        thing = ptrans_func(thing, header, constant);
-                        break;
-                    
-                      case type_ListPointer:
-                        thing = ptrans_list(thing, constant);
-                        break;
-                    
-                      case type_StructurePointer:
-                        thing = ptrans_boxed(thing, header, constant);
-                        break;
-                    
-                      case type_OtherPointer:
-                        thing = ptrans_otherptr(thing, header, constant);
-                        break;
-
-                      default:
-                        /* It was a pointer, but not one of them? */
-                        gc_abort();
-                    }
-                }
-                *addr = thing;
-            }
-            count = 1;
-        }
-        else if (thing & 3) {
-            /* It's an other immediate.  Maybe the header for an unboxed */
-            /* object. */
-            switch (TypeOf(thing)) {
-              case type_Bignum:
-              case type_SingleFloat:
-              case type_DoubleFloat:
-              case type_Sap:
-                /* It's an unboxed simple object. */
-                count = HeaderValue(thing)+1;
-                break;
-
-              case type_SimpleVector:
-                if (HeaderValue(thing) == subtype_VectorValidHashing)
-                    *addr = (subtype_VectorMustRehash<<type_Bits) |
-                        type_SimpleVector;
-                count = 1;
-                break;
-
-              case type_SimpleString:
-                vector = (struct vector *)addr;
-                count = CEILING(NWORDS(FIXNUM_TO_INT(vector->length)+1,4)+2,2);
-                break;
-
-              case type_SimpleBitVector:
-                vector = (struct vector *)addr;
-                count = CEILING(NWORDS(FIXNUM_TO_INT(vector->length),32)+2,2);
-                break;
-
-              case type_SimpleArrayUnsignedByte2:
-                vector = (struct vector *)addr;
-                count = CEILING(NWORDS(FIXNUM_TO_INT(vector->length),16)+2,2);
-                break;
-
-              case type_SimpleArrayUnsignedByte4:
-                vector = (struct vector *)addr;
-                count = CEILING(NWORDS(FIXNUM_TO_INT(vector->length),8)+2,2);
-                break;
-
-              case type_SimpleArrayUnsignedByte8:
-                vector = (struct vector *)addr;
-                count = CEILING(NWORDS(FIXNUM_TO_INT(vector->length),4)+2,2);
-                break;
-
-              case type_SimpleArrayUnsignedByte16:
-                vector = (struct vector *)addr;
-                count = CEILING(NWORDS(FIXNUM_TO_INT(vector->length),2)+2,2);
-                break;
-
-              case type_SimpleArrayUnsignedByte32:
-                vector = (struct vector *)addr;
-                count = CEILING(FIXNUM_TO_INT(vector->length)+2,2);
-                break;
-
-              case type_SimpleArraySingleFloat:
-                vector = (struct vector *)addr;
-                count = CEILING(FIXNUM_TO_INT(vector->length)+2,2);
-                break;
-
-              case type_SimpleArrayDoubleFloat:
-                vector = (struct vector *)addr;
-                count = FIXNUM_TO_INT(vector->length)*2+2;
-                break;
-
-              case type_CodeHeader:
-                gc_abort(); /* No code headers in static space */
-                break;
-
-              case type_FunctionHeader:
-              case type_ClosureFunctionHeader:
-              case type_ReturnPcHeader:
-                /* We should never hit any of these, 'cause they occure */
-                /* buried in the middle of code objects. */
-                gc_abort();
-
-              case type_WeakPointer:
-                /* Weak pointers get preserved during purify, 'cause I don't */
-                /* feel like figuring out how to break them. */
-                pscav(addr+1, 2, constant);
-                count = 4;
-                break;
-
-	      case type_Fdefn:
-		/* We have to handle fdefn objects specially, so we can fix */
-		/* up the raw function address. */
-		count = pscav_fdefn((struct fdefn *)addr);
-		break;
-
-              default:
-                count = 1;
-                break;
-            }
-        }
-        else {
-            /* It's a fixnum. */
-            count = 1;
-        }
-            
-        addr += count;
-        nwords -= count;
-    }
-
-    return addr;
-}
-
-
-int purify(static_roots, read_only_roots)
-lispobj static_roots, read_only_roots;
-{
-    lispobj *clean;
-    int count, i;
-    struct later *laters, *next;
-
-#ifdef PRINTNOISE
-    printf("[Doing purification:");
-    fflush(stdout);
-#endif
-
-    if (FIXNUM_TO_INT(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)) != 0) {
-        printf(" Ack! Can't purify interrupt contexts. ");
-        fflush(stdout);
-        return;
-    }
-
-    read_only_end = read_only_free =
-        (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
-    static_end = static_free =
-        (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER);
-
-#ifdef PRINTNOISE
-    printf(" roots");
-    fflush(stdout);
-#endif
-    pscav(&static_roots, 1, FALSE);
-    pscav(&read_only_roots, 1, TRUE);
-
-#ifdef PRINTNOISE
-    printf(" handlers");
-    fflush(stdout);
-#endif
-    pscav((lispobj *) interrupt_handlers,
-          sizeof(interrupt_handlers) / sizeof(lispobj),
-          FALSE);
-
-#ifdef PRINTNOISE
-    printf(" stack");
-    fflush(stdout);
-#endif
-    pscav(control_stack, current_control_stack_pointer - control_stack, FALSE);
-
-#ifdef PRINTNOISE
-    printf(" bindings");
-    fflush(stdout);
-#endif
-#ifndef ibmrt
-    pscav(binding_stack, current_binding_stack_pointer - binding_stack, FALSE);
-#else
-    pscav(binding_stack, (lispobj *)SymbolValue(BINDING_STACK_POINTER) - binding_stack, FALSE);
-#endif
-
-#ifdef PRINTNOISE
-    printf(" static");
-    fflush(stdout);
-#endif
-    clean = static_space;
-    do {
-        while (clean != static_free)
-            clean = pscav(clean, static_free - clean, FALSE);
-        laters = later_blocks;
-        count = later_count;
-        later_blocks = NULL;
-        later_count = 0;
-        while (laters != NULL) {
-            for (i = 0; i < count; i++) {
-                if (laters->u[i].count == 0)
-                    ;
-                else if (laters->u[i].count <= LATERMAXCOUNT) {
-                    pscav(laters->u[i+1].ptr, laters->u[i].count, TRUE);
-                    i++;
-                }
-                else
-                    pscav(laters->u[i].ptr, 1, TRUE);
-            }
-            next = laters->next;
-            free(laters);
-            laters = next;
-            count = LATERBLOCKSIZE;
-        }
-    } while (clean != static_free || later_blocks != NULL);
-
-
-#ifdef PRINTNOISE
-    printf(" cleanup");
-    fflush(stdout);
-#endif
-    os_zero((os_vm_address_t) current_dynamic_space,
-            (os_vm_size_t) DYNAMIC_SPACE_SIZE);
-
-    /* Zero stack. */
-    os_zero((os_vm_address_t) current_control_stack_pointer,
-            (os_vm_size_t) (CONTROL_STACK_SIZE -
-                            ((current_control_stack_pointer - control_stack) *
-                             sizeof(lispobj))));
-
-#ifndef ibmrt
-    current_dynamic_space_free_pointer = current_dynamic_space;
-#else
-    SetSymbolValue(ALLOCATION_POINTER, (lispobj)current_dynamic_space);
-#endif
-    SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free);
-    SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free);
-
-#ifdef PRINTNOISE
-    printf(" Done.]\n");
-    fflush(stdout);
-#endif
-
-    return 0;
-}
diff --git a/ldb/regnames.c b/ldb/regnames.c
deleted file mode 100644
index 70c5767720e96d5dd8d80865cac120cb1c7cd3ef..0000000000000000000000000000000000000000
--- a/ldb/regnames.c
+++ /dev/null
@@ -1,5 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/regnames.c,v 1.5 1991/05/24 18:38:02 wlott Exp $ */
-
-#include "lispregs.h"
-
-char *lisp_register_names[] = { REGNAMES, 0 };
diff --git a/ldb/rt-arch.c b/ldb/rt-arch.c
deleted file mode 100644
index 5ce30b3001eb2d1ad1bdd74860989079ba0711af..0000000000000000000000000000000000000000
--- a/ldb/rt-arch.c
+++ /dev/null
@@ -1,164 +0,0 @@
-#include <stdio.h>
-#include <mach.h>
-#include <sys/file.h>
-#include <sys/types.h>
-#include <sys/mman.h>
-
-#include "ldb.h"
-#include "lisp.h"
-#include "globals.h"
-#include "validate.h"
-#include "os.h"
-#include "arch.h"
-#include "lispregs.h"
-#include "signal.h"
-
-#define FL_NONE 0
-#define FL_FPA 2
-#define FL_AFPA 4
-#define FL_MC68881 1
-
-#define READ_MC68881_FPCR 0xfc3ec001
-#define WRITE_MC68881_FPCR 0xfc024001
-#define MC68881_ZIC 0xfc1c0003
-#define MC68881_PREC_MASK 0xff3f
-#define MC68881_DOUBLE_PREC 0x0080
-
-/* This is only used during arch_init to find out what kind of FP we have. */
-static sigsys_handler(signal, code, scp)
-int signal, code;
-struct sigcontext *scp;
-{
-    return (-1);
-}
-
-char *arch_init()
-{
-    int hw, i, rc;
-    int fs[5];
-    struct sigvec sv, osv;
-
-    /* Set up the state of the floating point hardware.  On the APC, there is
-       the onboard MC68881 which must be dealt with properly.  The signal
-       handling is necessary to be compatible with facilities version
-       of Mach.  */
-
-    sv.sv_handler = sigsys_handler;
-    sv.sv_mask = sigmask(SIGSYS);
-    sv.sv_onstack = FALSE;
-    rc = sigvec(SIGSYS, &sv, &osv);
-    i = 20;
-    rc = syscall(167, fs, &i);
-    if (rc == 0) {
-	i = fs[0];
-	hw = i & 7;
-	if (i & 1) {
-	    *(int *)READ_MC68881_FPCR = (int) &i;
-	    *(int *)MC68881_ZIC = 0;
-	    i = ((i & MC68881_PREC_MASK) | MC68881_DOUBLE_PREC);
-	    *(int *)WRITE_MC68881_FPCR = (int) &i;
-	    if (i & 2)
-		hw = hw & (~2);
-	}
-    }
-    else
-	hw = FL_FPA;
-
-    sigvec(SIGSYS, &osv, &sv);
-
-    switch (hw) {
-      case FL_FPA:
-	fprintf(stderr, "CMUCL only supports the AFPA and the MC68881 floating point options.\n");
-	exit(1);
-      case FL_AFPA:
-	return "eapc.core";
-      case FL_MC68881:
-	return NULL;
-      default:
-	fprintf(stderr, "CMUCL only supports the AFPA and the MC68881 floating point options.\nUse a different machine.\n");
-	exit(1);
-    }
-}
-
-os_vm_address_t arch_get_bad_addr(context)
-struct sigcontext *context;
-{
-    return 0;
-}
-
-void arch_skip_instruction(context)
-struct sigcontext *context;
-{
-    unsigned long pc = context->sc_iar;
-    unsigned long prev_inst = ((unsigned long *)pc)[-1];
-
-    if ((prev_inst >> 24) == 0x89) {
-	short offset = prev_inst & 0xffff;
-	context->sc_pc = pc - 4 + offset;
-    }
-    else
-	context->sc_pc = pc + 4;
-}
-
-static sigtrap_handler(signal, code, context)
-     int signal, code;
-     struct sigcontext *context;
-{
-    switch (*((char *)context->sc_iar)) {
-      case 0xCC:
-	/* trap-immediate instruction. */
-	switch (*((unsigned short *)context->sc_iar+1)) {
-	  case trap_PendingInterrupt:
-	    interrupt_handle_pending(context);
-	    break;
-
-	  case trap_Halt:
-	    crap_out("%primitive halt called; the party is over.\n");
-
-	  case trap_Error:
-	  case trap_Cerror:
-	    interrupt_internal_error(signal, code, context, code==trap_Cerror);
-	    break;
-
-	  case trap_Breakpoint:
-	    sigsetmask(context->sc_mask);
-	    fake_foreign_function_call(context);
-	    handle_breakpoint(signal, code, context);
-	    undo_fake_foreign_function_call(context);
-	    break;
-
-	  case trap_FunctionEndBreakpoint:
-	    sigsetmask(context->sc_mask);
-	    fake_foreign_function_call(context);
-	    handle_function_end_breakpoint(signal, code, context);
-	    undo_fake_foreign_function_call(context);
-	    break;
-
-	  default:
-	    interrupt_handle_now(signal, code, context);
-	    break;
-	}
-	break;
-
-      case 0xBE:
-	/* Trap Less Than instruction. */
-	if (SymbolValue(ALLOCATION_POINTER)>SymbolValue(INTERNAL_GC_TRIGGER)) {
-	    SetSymbolValue(INTERNAL_GC_TRIGGER, fixnum(-1));
-	    interrupt_maybe_gc(context);
-	    context->sc_iar += 2;
-	}
-	else
-	    interrupt_handle_now(signal, code, context);
-	break;
-
-      default:
-	interrupt_handle_now(signal, code, context);
-	break;
-    }
-}
-
-
-void arch_install_interrupt_handlers()
-{
-    interrupt_install_low_level_handler(SIGTRAP,sigtrap_handler);
-}
diff --git a/ldb/rt-assem.s b/ldb/rt-assem.s
deleted file mode 100644
index 3e09f03f2533b36c0520052036f46744f6736d6e..0000000000000000000000000000000000000000
--- a/ldb/rt-assem.s
+++ /dev/null
@@ -1,260 +0,0 @@
-	.globl	.oVncs
-	.set	.oVncs,0
-
-#define LANGUAGE_ASSEMBLY
-#include "lispregs.h"
-#include "lisp.h"
-#include "globals.h"
-
-	.text
-	.data	1
-	.globl	_call_into_lisp
-_call_into_lisp:
-	.long	_.call_into_lisp
-	.text
-	.align	1
-	.globl	_.call_into_lisp
-_.call_into_lisp:
-/* Save the callee-saves registers. */
-	stm   	r6,-64(r1)
-/* Put the pointer to our data area where we can use it. */
-	mr    	r14,r0
-/* Move the callers stack pointer into our frame pointer. */
-	mr    	r13,r1
-/* And allocate our frame on the stack. */
-	cal   	r1,-64(r1)
-
-/* Set up the lisp state. */
-	mr	CNAME, r2
-	mr	LEXENV, r3
-	mr	CFP, r4
-	mr	NARGS, r5
-	sli	NARGS, 2
-	get	NULLREG, $NIL
-
-/* No longer in foreign function call. */
-/* Note: the atomic flag should still be set. */
-	lis	A0, 0
-	store	A0, _foreign_function_call_active, NL0
-
-/* Load the rest of lisp state. */
-	load	CSP, _current_control_stack_pointer
-	load	OCFP, _current_control_frame_pointer
-
-/* No longer atomic. */
-	store	A0, PSEUDO_ATOMIC_ATOMIC+SYMBOL_VALUE_OFFSET, NL0
-
-/* Were we interrupted? */
-	load	NL0, PSEUDO_ATOMIC_INTERRUPTED+SYMBOL_VALUE_OFFSET
-	ci	NL0, 0
-	je	1f
-
-	ti	7, r0, trap_PendingInterrupt
-1:
-
-/* Load the args. */
-	l	A0, 0(CFP)
-	l	A1, 4(CFP)
-	l	A2, 8(CFP)
-
-/* Calculate LRA. */
-	get	LRA, $lra+type_OtherPointer
-
-/* Indirect closure */
-	l	CODE, CLOSURE_FUNCTION_OFFSET(LEXENV)
-
-	cal	LIP, FUNCTION_HEADER_CODE_OFFSET(CODE)
-	br	LIP
-
-	.align	3
-lra:
-	.long	type_ReturnPcHeader
-
-/* Blow off any extra values. */
-	cal	CSP, 0(OCFP)	/* We must use a 32-bit instruction here */
-
-/* Save the return value. */
-	mr	r2, A0
-
-/* Turn on pseudo-atomic */
-	store	CFP, PSEUDO_ATOMIC_ATOMIC+SYMBOL_VALUE_OFFSET, r3
-
-/* Store lisp state */
-	store	CSP, _current_control_stack_pointer, r3
-	store	CFP, _current_control_frame_pointer, r3
-
-/* No longer in lisp. */
-	store	CFP, _foreign_function_call_active, r3
-
-/* Were we interrupted? */
-	load	r3, PSEUDO_ATOMIC_INTERRUPTED+SYMBOL_VALUE_OFFSET
-	ci	r3, 0
-	je	1f
-
-/* Yep. */
-	ti	7, r0, trap_PendingInterrupt
-
-1:
-/* Restore callee-saves registers. */
-	lm	r6,0(r1)
-/* Return to C */
-	brx	r15
-/* And reset the stack. */
-	ai	r1,64
-
-/* Noise to keep debuggers happy. */
-	.long	0xDF07DF68
-	.short	0x0110
-
-
-/* Call_into_C
-
-On entry:
- NL0 - addr of fn to call
- NSP[0]...NSP[n-1] - args
- LRA, CODE - must be preserved (and GCed if necessary)
-
-*/
-
-	.text
-	.globl	call_into_c
-call_into_c:
-	/* Build a stack frame. */
-	mr	OCFP, CFP
-	mr	CFP, CSP
-	cal	CSP, 32(CSP)
-	st	OCFP, 0(CFP)
-	st	LRA, 4(CFP)
-	st	CODE, 8(CFP)
-	
-	/* Get the text addr we are supposed to jump to */
-	l	r15, 0(NL0)
-	mr	r0, NL0
-
-	/* Set pseudo-atomic. */
-	store	CFP, PSEUDO_ATOMIC_ATOMIC+SYMBOL_VALUE_OFFSET, r3
-
-	/* Save lisp state. */
-	store	CSP, _current_control_stack_pointer, r2
-	store	CFP, _current_control_frame_pointer, r2
-
-	/* Now in foreign function call land */
-	store	CFP, _foreign_function_call_active, r2
-
-	/* Were we interrupted? */
-	load	r3, PSEUDO_ATOMIC_INTERRUPTED+SYMBOL_VALUE_OFFSET
-	ci	r3, 0
-	je	1f
-
-/* Yep. */
-	ti	7, r0, trap_PendingInterrupt
-
-1:
-	/* Get the first 4 args, and adjust the stack pointer.  We need to */
-	/* adjust the stack pointer because r1 is supposed to point at the */
-	/* 5th argument, not the 1st.  This is easier than trying to fix */
-	/* pack to be able to deal with TNs with a negative offset. */
-	l	r2, 0(r1)
-	l	r3, 4(r1)
-	l	r4, 8(r1)
-	l	r5, 12(r1)
-	cal	r1, 16(r1)
-
-	/* And hit it. */
-	balr	r15, r15
-
-	/* Save the second return value (assuming there is one) */
-	mr	NARGS, OCFP
-
-	/* Clear desriptor regs.  We have to do this before we clear the
-	foreign-function-call-active flag even if we are just going to
-	load the saved value back into the reg to make sure we don't keep
-	ahold of any pointers that have been moved by GC. */
-	lis	CODE, 0
-	lis	CNAME, 0
-	lis	LEXENV, 0
-	lis	LRA, 0
-	lis	A0, 0
-	lis	A1, 0
-	lis	A2, 0
-
-/* No longer in foreign function call. */
-/* Note: the atomic flag should still be set. */
-	lis	A0, 0
-	store	A0, _foreign_function_call_active, OCFP
-
-/* Load the rest of lisp state. */
-	load	CSP, _current_control_stack_pointer
-	load	CFP, _current_control_frame_pointer
-
-/* No longer atomic. */
-	store	A0, PSEUDO_ATOMIC_ATOMIC+SYMBOL_VALUE_OFFSET, OCFP
-
-/* Were we interrupted? */
-	load	OCFP, PSEUDO_ATOMIC_INTERRUPTED+SYMBOL_VALUE_OFFSET
-	ci	OCFP, 0
-	je	1f
-
-	ti	7, r0, trap_PendingInterrupt
-1:
-
-	/* Restore OCFP, LRA & CODE (they may have been GC'ed) */
-	l	OCFP, 0(CFP)
-	l	LRA, 4(CFP)
-	l	CODE, 8(CFP)
-
-	/* Reset the stack. */
-	mr	CSP, CFP
-	mr	CFP, OCFP
-	cal	r1, -16(r1)
-
-	/* Restore the second return value */
-	mr	OCFP, NARGS
-
-	/* And return */
-	cal	LIP, (4-type_OtherPointer)(LRA)
-	br	LIP
-
-
-
-	.text
-	.globl	undefined_tramp
-undefined_tramp:
-	ti	7, r0, trap_Error
-	.byte	4
-	.byte	23
-	.byte	254
-	.byte	43
-	.byte	1
-	.align	2
-
-	.globl	closure_tramp
-closure_tramp:
-        l	LEXENV, SYMBOL_FUNCTION_OFFSET(CNAME)
-        l	CNAME, CLOSURE_FUNCTION_OFFSET(LEXENV)
-        cal	LIP, FUNCTION_HEADER_CODE_OFFSET(CNAME)
-        br	LIP
-
-/*
- * Function-end breakpoint magic.
- */
-	.text
-	.align	2
-	.globl	_function_end_breakpoint_guts
-_function_end_breakpoint_guts:
-	.long	type_ReturnPcHeader
-	b	1f
-	mr	OCFP, CSP
-	inc	CSP, 4
-	lis	NARGS, 4
-	mr	A1, NULLREG
-	mr	A2, NULLREG
-1:
-
-	.globl	_function_end_breakpoint_trap
-_function_end_breakpoint_trap:
-	ti	7, r0, trap_FunctionEndBreakpoint
-	b	1b
-
-	.globl	_function_end_breakpoint_end
-_function_end_breakpoint_end:
diff --git a/ldb/rt-lispregs.h b/ldb/rt-lispregs.h
deleted file mode 100644
index c3254700b5336704eb20109a779d16e3d14e3cf6..0000000000000000000000000000000000000000
--- a/ldb/rt-lispregs.h
+++ /dev/null
@@ -1,32 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/rt-lispregs.h,v 1.1 1991/05/24 18:46:09 wlott Exp $ */
-
-#ifdef LANGUAGE_ASSEMBLY
-#define REG(num) r/**/num
-#else
-#define REG(num) num
-#endif
-
-#define NREGS	(16)
-
-#define NARGS	REG(0)
-#define NSP	REG(1)
-#define NL0	REG(2)
-#define OCFP	REG(3)
-#define NFP	REG(4)
-#define CSP	REG(5)
-#define CFP	REG(6)
-#define CODE	REG(7)
-#define NULLREG	REG(8)
-#define CNAME	REG(9)
-#define LEXENV	REG(10)
-#define LRA	REG(11)
-#define A0	REG(12)
-#define A1	REG(13)
-#define A2	REG(14)
-#define LIP	REG(15)
-
-#define REGNAMES \
-	"NARGS",	"NSP",		"NL0",		"OCFP", \
-	"NFP",		"CSP",		"CFP",		"CODE", \
-	"NULL",		"CNAME",	"LEXENV",	"LRA", \
-	"A0",		"A1",		"A2",		"LIP"
diff --git a/ldb/save.c b/ldb/save.c
deleted file mode 100644
index d20f9d11ec03a627f827713a6b37f16c2edadf55..0000000000000000000000000000000000000000
--- a/ldb/save.c
+++ /dev/null
@@ -1,347 +0,0 @@
-#include <stdio.h>
-#include <signal.h>
-#include <sys/file.h>
-
-#include "ldb.h"
-#include "os.h"
-#include "lisp.h"
-#include "core.h"
-#include "globals.h"
-#include "lispregs.h"
-#include "interrupt.h"
-
-#define STACK_SIZE (8*1024)
-
-extern int version;
-
-static FILE *save_file;
-
-/* State that is restored when save returns, and therefore must be setup by either save or restore. */
-
-static boolean return_value;
-static int oldmask;
-static struct sigvec oldsv;
-static struct sigstack oldss;
-
-
-
-static long write_bytes(addr, bytes)
-char *addr;
-long bytes;
-{
-    long count, here, data;
-
-    fflush(save_file);
-    here = ftell(save_file);
-    fseek(save_file, 0, 2);
-    data = (ftell(save_file)+CORE_PAGESIZE-1)&~(CORE_PAGESIZE-1);
-    fseek(save_file, data, 0);
-
-    while (bytes > 0) {
-        count = fwrite(addr, 1, bytes, save_file);
-        if (count > 0) {
-            bytes -= count;
-            addr += count;
-        }
-        else {
-            perror("Error writing to save file");
-            bytes = 0;
-        }
-    }
-    fflush(save_file);
-    fseek(save_file, here, 0);
-    return data/CORE_PAGESIZE - 1;
-}
-
-static void output_space(id, addr, end)
-int id;
-lispobj *addr, *end;
-{
-    int words, bytes, data;
-    static char *names[] = {NULL, "Dynamic", "Static", "Read-Only"};
-
-    putw(id, save_file);
-    words = end - addr;
-    putw(words, save_file);
-
-    bytes = words * sizeof(lispobj);
-
-    printf("Writing %d bytes from the %s space at 0x%08x.\n",
-           bytes, names[id], addr);
-
-    data = write_bytes((char *)addr, bytes);
-
-    putw(data, save_file);
-    putw((os_vm_address_t)((long)addr / CORE_PAGESIZE), save_file);
-    putw((bytes + CORE_PAGESIZE - 1) / CORE_PAGESIZE, save_file);
-}
-
-static long write_stack(name, start, end)
-char *name, *start, *end;
-{
-    long len;
-
-    start = (char *)os_trunc_to_page((os_vm_address_t)start);
-    end = (char *)os_round_up_to_page((os_vm_address_t)end);
-
-    len = end-start;
-
-    printf("Writing %d bytes from the %s stack at 0x%08x.\n", len, name, start);
-
-    return write_bytes(start, len);
-}
-
-static void output_machine_state(context)
-struct sigcontext *context;
-{
-    struct machine_state ms;
-
-    putw(CORE_MACHINE_STATE, save_file);
-    putw(2 + sizeof(ms)/sizeof(long), save_file);
-
-    ms.csp = current_control_stack_pointer;
-    ms.fp = current_control_frame_pointer;
-#ifndef ibmrt
-    ms.bsp = current_binding_stack_pointer;
-#endif
-    ms.number_stack_start = number_stack_start;
-    ms.sigcontext_page = write_bytes((char *)context, sizeof(struct sigcontext));
-    ms.control_stack_page = write_stack("Control",
-       (char *)control_stack,
-       (char *)current_control_stack_pointer);
-#ifndef ibmrt
-    ms.binding_stack_page = write_stack("Binding",
-       (char *)binding_stack,
-       (char *)current_binding_stack_pointer);
-#else
-    ms.binding_stack_page = write_stack("Binding",
-       (char *)binding_stack,
-       (char *)SymbolValue(BINDING_STACK_POINTER));
-#endif
-    ms.number_stack_page = write_stack("Number",
-       (char *)(context->sc_regs[NSP]),
-       number_stack_start);
-
-    fwrite(&ms, sizeof(ms), 1, save_file);
-}
-
-static SIGHDLRTYPE save_handler(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-    if (context->sc_onstack) {
-        printf("Cannot save while executing on a signal stack!\n");
-        return;
-    }
-
-    putw(CORE_MAGIC, save_file);
-
-    putw(CORE_VERSION, save_file);
-    putw(3, save_file);
-    putw(version, save_file);
-
-    putw(CORE_NDIRECTORY, save_file);
-    putw((5*3)+2, save_file);
-
-    output_space(READ_ONLY_SPACE_ID, read_only_space, (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
-    output_space(STATIC_SPACE_ID, static_space, (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER));
-#ifndef ibmrt
-    output_space(DYNAMIC_SPACE_ID, current_dynamic_space, current_dynamic_space_free_pointer);
-#else
-    output_space(DYNAMIC_SPACE_ID, current_dynamic_space, (lispobj *)SymbolValue(ALLOCATION_POINTER));
-#endif
-
-
-    output_machine_state(context);
-
-    putw(CORE_END, save_file);
-    fclose(save_file);
-
-    printf("done.]\n");
-}
-
-extern lispobj save(filename)
-char *filename;
-{
-    int oldmask;
-    struct sigvec oldsv, newsv;
-    struct sigstack oldss, newss;
-    static char signal_stack[STACK_SIZE];
-
-    /* Set the return value. */
-    return_value = TRUE;
-
-    /* Open the file: */
-    unlink(filename);
-    save_file = fopen(filename, "w");
-    if (save_file == NULL) {
-        perror(filename);
-        return;
-    }
-    printf("[Saving current lisp image into %s:\n", filename);
-
-    oldmask = sigblock(sigmask(SIGTERM));
-
-    /* Install the save handler */
-    newsv.sv_handler = save_handler;
-    newsv.sv_mask = 0;
-    newsv.sv_flags = SV_ONSTACK;
-    sigvec(SIGTERM, &newsv, &oldsv);
-    
-    /* Set up the signal stack. */
-    newss.ss_sp = (char *)(((unsigned)signal_stack + STACK_SIZE) & ~7);
-    newss.ss_onstack = 0;
-    sigstack(&newss, &oldss);
-
-    /* Deliver the signal and wait for it to be delivered. */
-    kill(getpid(), SIGTERM);
-
-    sigpause(oldmask);
-
-    /* Restore the state of the world. */
-    sigvec(SIGTERM, &oldsv, NULL);
-    sigstack(&oldss, NULL);
-    sigsetmask(oldmask);
-
-    return return_value;
-}
-
-
-/* State that must be preserved between load and restore. */
-
-static struct sigcontext context;
-static os_vm_address_t number_stack;
-
-
-static os_vm_address_t map_stack(fd, start, end, data_page, name)
-int fd;
-os_vm_address_t start, end;
-long data_page;
-char *name;
-{
-    os_vm_size_t len;
-
-    start = os_trunc_to_page(start);
-    len = os_round_up_to_page(end) - start;
-
-    if (len != 0) {
-        if (start == NULL) {
-            start = os_validate(start, len);
-	    if(start==NULL)
-                fprintf(stderr, "Could not allocate stageing area for the %s stack.\n", name);
-        }
-
-#ifdef PRINTNOISE
-        printf("Mapping %d bytes onto the %s stack at 0x%08x.\n", len, name, start);
-#endif
-        start=os_map(fd, (1+data_page)*CORE_PAGESIZE, start, len);
-    }
-
-    return start;
-}
-
-extern void load(fd, ms)
-int fd;
-struct machine_state *ms;
-{
-    current_control_stack_pointer = ms->csp;
-    current_control_frame_pointer = ms->fp;
-#ifndef ibmrt
-    current_binding_stack_pointer = ms->bsp;
-#endif
-
-    if (ms->number_stack_start > number_stack_start) {
-        fprintf(stderr, "Can't allocate number stack --- probably this is a Sparc 10.\n");
-        fprintf(stderr, "If not, your environment is real big...\n");
-        exit(1);
-    }
-    else
-        number_stack_start = ms->number_stack_start;
-
-    lseek(fd, CORE_PAGESIZE * (1+ms->sigcontext_page), L_SET);
-    read(fd, &context, sizeof(context));
-
-    map_stack(fd,
-              (os_vm_address_t)control_stack,
-              (os_vm_address_t)current_control_stack_pointer,
-              ms->control_stack_page,
-              "Control");
-
-    map_stack(fd,
-              (os_vm_address_t)binding_stack,
-#ifndef ibmrt
-              (os_vm_address_t)current_binding_stack_pointer,
-#else
-	      (os_vm_address_t)SymbolValue(BINDING_STACK_POINTER),
-#endif
-              ms->binding_stack_page,
-              "Binding");
-
-    number_stack = map_stack(fd,
-                             (os_vm_address_t)NULL,
-                             os_round_up_to_page((os_vm_address_t)number_stack_start) - (os_vm_address_t)context.sc_regs[NSP],
-                             ms->number_stack_page,
-                             "Number");
-}
-
-static SIGHDLRTYPE restore_handler(signal, code, old_context)
-int signal, code;
-struct sigcontext *old_context;
-{
-    os_vm_size_t len;
-    os_vm_address_t nsp;
-
-    /* We have to move the number stack into place. */
-    nsp = os_trunc_to_page((os_vm_address_t)context.sc_regs[NSP]);
-    len = (os_vm_address_t)number_stack_start - nsp;
-#ifdef PRINTNOISE
-    printf("Moving the number stack from 0x%08x to 0x%08x.\n", number_stack, nsp);
-#endif
-    bcopy(number_stack, nsp, len);
-
-    os_invalidate(number_stack, os_round_up_to_page(len));
-
-#ifndef ibmrt
-    sigreturn(&context);
-
-    /* We should not get here. */
-#else
-    bcopy(&context, old_context, sizeof(context));
-#endif
-}
-
-
-extern void restore()
-{
-    struct sigvec newsv;
-    struct sigstack newss;
-    static char signal_stack[STACK_SIZE];
-
-    /* Set the return value. */
-    return_value = 0;
-
-    /* Block the signal. */
-    oldmask = sigblock(sigmask(SIGTERM));
-
-    /* Install the handler */
-    newsv.sv_handler = restore_handler;
-    newsv.sv_mask = 0;
-    newsv.sv_flags = SV_ONSTACK;
-    sigvec(SIGTERM, &newsv, &oldsv);
-    
-    /* Set up the signal stack. */
-    newss.ss_sp = (char *)(((unsigned)signal_stack + STACK_SIZE) & ~7);
-    newss.ss_onstack = 0;
-    sigstack(&newss, &oldss);
-
-    /* Deliver the signal and wait for it to be delivered. */
-    kill(getpid(), SIGTERM);
-    sigpause(oldmask);
-
-    /* We should never get here. */
-    sigvec(SIGTERM, &oldsv, NULL);
-    sigstack(&oldss, NULL);
-    sigsetmask(oldmask);
-
-    fprintf(stderr, "Hm, tried to restore, but nothing happened.\n");
-}
diff --git a/ldb/search.c b/ldb/search.c
deleted file mode 100644
index 97431bee3b3924783f49448e3e6e4202f6aa618a..0000000000000000000000000000000000000000
--- a/ldb/search.c
+++ /dev/null
@@ -1,45 +0,0 @@
-
-#include "lisp.h"
-#include "ldb.h"
-
-boolean search_for_type(type, start, count)
-int type;
-lispobj **start;
-int *count;
-{
-    lispobj obj, *addr;
-
-    while ((*count == -1 || (*count > 0)) && valid_addr(*start)) {
-        obj = **start;
-        addr = *start;
-        if (*count != -1)
-            *count -= 2;
-
-        if (TypeOf(obj) == type)
-            return TRUE;
-
-        (*start) += 2;
-    }
-    return FALSE;
-}
-
-
-boolean search_for_symbol(name, start, count)
-char *name;
-lispobj **start;
-int *count;
-{
-    struct symbol *symbol;
-    struct vector *symbol_name;
-
-    while (search_for_type(type_SymbolHeader, start, count)) {
-        symbol = (struct symbol *)PTR((lispobj)*start);
-	if (LowtagOf(symbol->name) == type_OtherPointer) {
-            symbol_name = (struct vector *)PTR(symbol->name);
-            if (valid_addr(symbol_name) && TypeOf(symbol_name->header) == type_SimpleString && strcmp((char *)symbol_name->data, name) == 0)
-                return TRUE;
-	}
-        (*start) += 2;
-    }
-    return FALSE;
-}
diff --git a/ldb/signal.h b/ldb/signal.h
deleted file mode 100644
index a9c77a488066f860d9e7df14af3ebcec5d007482..0000000000000000000000000000000000000000
--- a/ldb/signal.h
+++ /dev/null
@@ -1,32 +0,0 @@
-#ifndef _SIGNAL_H_
-#define _SIGNAL_H_
-
-#include </usr/include/signal.h>
-
-#ifdef sparc
-
-/* We need to fake the existance of a reasonable sigcontext */
-struct lisp_sigcontext {
-    /* This part is identical to the real sigcontext. */
-    int     sc_onstack;		/* sigstack state to restore */
-    int     sc_mask;		/* signal mask to restore */
-    int     sc_sp;                  /* sp to restore */
-    int     sc_pc;                  /* pc to retore */
-    int     sc_npc;                 /* next pc to restore */
-    int     sc_psr;                 /* psr to restore */
-    int     sc_g1;                  /* register that must be restored */
-    int     sc_o0;
-
-    /* And this is the part we have added. */
-    unsigned long sc_regs[32];
-    unsigned long sc_fpregs[32];
-    long sc_y;
-    unsigned long sc_fsr;
-};
-
-#define sigcontext lisp_sigcontext
-
-#endif sparc
-
-
-#endif _SIGNAL_H_
diff --git a/ldb/socket.c b/ldb/socket.c
deleted file mode 100644
index f8c843ebcf384bed2dec992ce8744ec8261a2c07..0000000000000000000000000000000000000000
--- a/ldb/socket.c
+++ /dev/null
@@ -1,144 +0,0 @@
-/* Copyright    Massachusetts Institute of Technology    1988	*/
-/*
- * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived
- * systems.  VMS and System V should plan to have their own version.
- *
- * This code was cribbed from lib/X/XConnDis.c.
- * Compile using   
- *                    % cc -c socket.c -DUNIXCONN
- */
-
-#include <stdio.h>
-#include <X11/Xos.h>
-#include <X11/Xproto.h>
-#include <errno.h>
-#include <netinet/in.h>
-#include <sys/ioctl.h>
-#include <netdb.h> 
-#include <sys/socket.h>
-#ifndef hpux
-#include <netinet/tcp.h>
-#endif
-
-extern int errno;		/* Certain (broken) OS's don't have this */
-				/* decl in errno.h */
-
-#ifdef UNIXCONN
-#include <sys/un.h>
-#ifndef X_UNIX_PATH
-#ifdef hpux
-#define X_UNIX_PATH "/usr/spool/sockets/X11/"
-#define OLD_UNIX_PATH "/tmp/.X11-unix/X"
-#else /* hpux */
-#define X_UNIX_PATH "/tmp/.X11-unix/X"
-#endif /* hpux */
-#endif /* X_UNIX_PATH */
-#endif /* UNIXCONN */
-void bcopy();
-
-/* 
- * Attempts to connect to server, given host and display. Returns file 
- * descriptor (network socket) or 0 if connection fails.
- */
-
-int connect_to_server (host, display)
-     char *host;
-     int display;
-{
-  struct sockaddr_in inaddr;	/* INET socket address. */
-  struct sockaddr *addr;		/* address to connect to */
-  struct hostent *host_ptr;
-  int addrlen;			/* length of address */
-#ifdef UNIXCONN
-  struct sockaddr_un unaddr;	/* UNIX socket address. */
-#endif
-  extern char *getenv();
-  extern struct hostent *gethostbyname();
-  int fd;				/* Network socket */
-  {
-#ifdef UNIXCONN
-    if ((host[0] == '\0') || (strcmp("unix", host) == 0)) {
-	/* Connect locally using Unix domain. */
-	unaddr.sun_family = AF_UNIX;
-	(void) strcpy(unaddr.sun_path, X_UNIX_PATH);
-	sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display);
-	addr = (struct sockaddr *) &unaddr;
-	addrlen = strlen(unaddr.sun_path) + 2;
-	/*
-	 * Open the network connection.
-	 */
-	if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) {
-#ifdef hpux /* this is disgusting */  /* cribbed from X11R4 xlib source */
-  	    if (errno == ENOENT) {  /* No such file or directory */
-	      sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display);
-              addrlen = strlen(unaddr.sun_path) + 2;
-              if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0)
-                return(-1);     /* errno set by most recent system call. */
-	    } else 
-#endif /* hpux */
-	    return(-1);	    /* errno set by system call. */
-        }
-    } else 
-#endif /* UNIXCONN */
-    {
-      /* Get the statistics on the specified host. */
-      if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) 
-	{
-	  if ((host_ptr = gethostbyname(host)) == NULL) 
-	    {
-	      /* No such host! */
-	      errno = EINVAL;
-	      return(-1);
-	    }
-	  /* Check the address type for an internet host. */
-	  if (host_ptr->h_addrtype != AF_INET) 
-	    {
-	      /* Not an Internet host! */
-	      errno = EPROTOTYPE;
-	      return(-1);
-	    }
-	  /* Set up the socket data. */
-	  inaddr.sin_family = host_ptr->h_addrtype;
-	  bcopy((char *)host_ptr->h_addr, 
-		(char *)&inaddr.sin_addr, 
-		sizeof(inaddr.sin_addr));
-	} 
-      else 
-	{
-	  inaddr.sin_family = AF_INET;
-	}
-      addr = (struct sockaddr *) &inaddr;
-      addrlen = sizeof (struct sockaddr_in);
-      inaddr.sin_port = display + X_TCP_PORT;
-      inaddr.sin_port = htons(inaddr.sin_port);
-      /*
-       * Open the network connection.
-       */
-      if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){
-	return(-1);	    /* errno set by system call. */}
-      /* make sure to turn off TCP coalescence */
-#ifdef TCP_NODELAY
-      {
-	int mi = 1;
-	setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int));
-      }
-#endif
-    }
-
-    /*
-     * Changed 9/89 to retry connection if system call was interrupted.  This
-     * is necessary for multiprocessing implementations that use timers,
-     * since the timer results in a SIGALRM.	-- jdi
-     */
-    while (connect(fd, addr, addrlen) == -1) {
-	if (errno != EINTR) {
-  	    (void) close (fd);
-  	    return(-1); 	    /* errno set by system call. */
-	}
-      }
-  }
-  /*
-   * Return the id if the connection succeeded.
-   */
-  return(fd);
-}
diff --git a/ldb/sparc-arch.c b/ldb/sparc-arch.c
deleted file mode 100644
index db76c73263b4ecfddead1d04008ad61673a5d27a..0000000000000000000000000000000000000000
--- a/ldb/sparc-arch.c
+++ /dev/null
@@ -1,201 +0,0 @@
-#include <machine/trap.h>
-
-#include "ldb.h"
-#include "lisp.h"
-#include "globals.h"
-#include "validate.h"
-#include "os.h"
-#include "arch.h"
-#include "lispregs.h"
-#include "signal.h"
-
-char *arch_init()
-{
-    return NULL;
-}
-
-os_vm_address_t arch_get_bad_addr(context)
-struct sigcontext *context;
-{
-    unsigned long badinst;
-    int rs1;
-
-    /* On the sparc, we have to decode the instruction. */
-
-    /* Make sure it's not the pc thats bogus, and that it was lisp code */
-    /* that caused the fault. */
-    if ((context->sc_pc & 3) != 0 ||
-	((context->sc_pc < READ_ONLY_SPACE_START ||
-	  context->sc_pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) &&
-	 ((lispobj *)context->sc_pc < current_dynamic_space &&
-	  (lispobj *)context->sc_pc >=
-	      current_dynamic_space + DYNAMIC_SPACE_SIZE)))
-	return NULL;
-
-    badinst = *(unsigned long *)context->sc_pc;
-
-    if ((badinst >> 30) != 3)
-	/* All load/store instructions have op = 11 (binary) */
-	return NULL;
-
-    rs1 = (badinst>>14)&0x1f;
-
-    if (badinst & (1<<13)) {
-	/* r[rs1] + simm(13) */
-	int simm13 = badinst & 0x1fff;
-
-	if (simm13 & (1<<12))
-	    simm13 |= -1<<13;
-
-	return (os_vm_address_t)(context->sc_regs[rs1] + simm13);
-    }
-    else {
-	/* r[rs1] + r[rs2] */
-	int rs2 = badinst & 0x1f;
-
-	return (os_vm_address_t)(context->sc_regs[rs1] + context->sc_regs[rs2]);
-    }
-
-}
-
-void arch_skip_instruction(context)
-struct sigcontext *context;
-{
-    /* Skip the offending instruction */
-    context->sc_pc = context->sc_npc;
-    context->sc_npc += 4;
-}
-
-static void sigill_handler(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-    int badinst;
-
-    if (code == T_UNIMP_INSTR) {
-	int trap;
-
-	trap = *(unsigned long *)(context->sc_pc) & 0x3fffff;
-
-	switch (trap) {
-	  case trap_PendingInterrupt:
-	    interrupt_handle_pending(context);
-	    break;
-
-	  case trap_Halt:
-	    crap_out("%primitive halt called; the party is over.\n");
-
-	  case trap_Error:
-	  case trap_Cerror:
-	    interrupt_internal_error(signal, code, context, trap == trap_Cerror);
-	    break;
-
-	  case trap_Breakpoint:
-	    sigsetmask(context->sc_mask);
-	    fake_foreign_function_call(context);
-	    handle_breakpoint(signal, code, context);
-	    undo_fake_foreign_function_call(context);
-	    break;
-
-	  case trap_FunctionEndBreakpoint:
-	    sigsetmask(context->sc_mask);
-	    fake_foreign_function_call(context);
-	    handle_function_end_breakpoint(signal, code, context);
-	    undo_fake_foreign_function_call(context);
-	    context->sc_npc = context->sc_pc + 4;
-	    break;
-
-	  default:
-	    interrupt_handle_now(signal, code, context);
-	    break;
-	}
-    }
-    else if (code >= T_SOFTWARE_TRAP + 16 & code < T_SOFTWARE_TRAP + 32)
-	interrupt_internal_error(signal, code, context, FALSE);
-    else
-	interrupt_handle_now(signal, code, context);
-}
-
-static void sigemt_handler(signal, code, context)
-     int signal, code;
-     struct sigcontext *context;
-{
-    unsigned long badinst;
-    boolean subtract, immed;
-    int rd, rs1, op1, rs2, op2, result;
-
-    badinst = *(unsigned long *)context->sc_pc;
-    if ((badinst >> 30) != 2 || ((badinst >> 20) & 0x1f) != 0x11) {
-	/* It wasn't a tagged add.  Pass the signal into lisp. */
-	interrupt_handle_now(signal, code, context);
-	return;
-    }
-	
-    /* Extract the parts of the inst. */
-    subtract = badinst & (1<<19);
-    rs1 = (badinst>>14) & 0x1f;
-    op1 = context->sc_regs[rs1];
-
-    /* If the first arg is $ALLOC then it is really a signal-pending note */
-    /* for the pseudo-atomic noise. */
-    if (rs1 == ALLOC) {
-	/* Perform the op anyway. */
-	op2 = badinst & 0x1fff;
-	if (op2 & (1<<12))
-	    op2 |= -1<<13;
-	if (subtract)
-	    result = op1 - op2;
-	else
-	    result = op1 + op2;
-	context->sc_regs[ALLOC] = result;
-	interrupt_handle_pending(context);
-	return;
-    }
-
-    if ((op1 & 3) != 0) {
-	/* The first arg wan't a fixnum. */
-	interrupt_internal_error(signal, code, context, FALSE);
-	return;
-    }
-
-    if (immed = badinst & (1<<13)) {
-	op2 = badinst & 0x1fff;
-	if (op2 & (1<<12))
-	    op2 |= -1<<13;
-    }
-    else {
-	rs2 = badinst & 0x1f;
-	op2 = context->sc_regs[rs2];
-    }
-
-    if ((op2 & 3) != 0) {
-	/* The second arg wan't a fixnum. */
-	interrupt_internal_error(signal, code, context, FALSE);
-	return;
-    }
-
-    rd = (badinst>>25) & 0x1f;
-    if (rd != 0) {
-	/* Don't bother computing the result unless we are going to use it. */
-	if (subtract)
-	    result = (op1>>2) - (op2>>2);
-	else
-	    result = (op1>>2) + (op2>>2);
-
-        current_dynamic_space_free_pointer =
-            (lispobj *) context->sc_regs[ALLOC];
-
-	context->sc_regs[rd] = alloc_number(result);
-
-	context->sc_regs[ALLOC] =
-	    (unsigned long) current_dynamic_space_free_pointer;
-    }
-
-    arch_skip_instruction(context);
-}
-
-void arch_install_interrupt_handlers()
-{
-    interrupt_install_low_level_handler(SIGILL,sigill_handler);
-    interrupt_install_low_level_handler(SIGEMT,sigemt_handler);
-}
diff --git a/ldb/sparc-assem.s b/ldb/sparc-assem.s
deleted file mode 100644
index a52b541802ef71c6b3d1722ed4ed5c912892ef7c..0000000000000000000000000000000000000000
--- a/ldb/sparc-assem.s
+++ /dev/null
@@ -1,475 +0,0 @@
-
-#include <machine/asm_linkage.h>
-#include <machine/psl.h>
-#include <machine/trap.h>
-
-#define LANGUAGE_ASSEMBLY
-#include "lispregs.h"
-#include "lisp.h"
-#include "globals.h"
-
-#define load(sym, reg) \
-        sethi   %hi(NAME(sym)), reg;    ld      [reg+%lo(NAME(sym))], reg
-#define store(reg, sym) \
-        sethi %hi(NAME(sym)), L0; st reg, [L0+%lo(NAME(sym))]
-
-
-#define FRAMESIZE (SA(WINDOWSIZE+4))
-
-        .seg    "text"
-        .global NAME(call_into_lisp)
-NAME(call_into_lisp):
-        save    %sp, -FRAMESIZE, %sp
-
-	/* Flush all of C's register windows to the stack. */
-	ta	ST_FLUSH_WINDOWS
-
-        /* Save the return address. */
-        st      %i7, [%fp-4]
-
-        /* Clear the descriptor regs. */
-        mov     ZERO, A0
-        mov     ZERO, A1
-        mov     ZERO, A2
-        mov     ZERO, A3
-        mov     ZERO, A4
-        mov     ZERO, A5
-        mov     ZERO, OCFP
-        mov     ZERO, LRA
-        mov     ZERO, L2
-        mov     ZERO, CODE
-
-        /* Establish NIL */
-        set     NIL, NULLREG
-
-	/* Set the pseudo-atomic flag. */
-	set	4, ALLOC
-
-	/* Turn off foreign function call. */
-        sethi   %hi(NAME(foreign_function_call_active)), NL0
-        st      ZERO, [NL0+%lo(NAME(foreign_function_call_active))]
-
-        /* Load the rest of lisp state. */
-        load(current_dynamic_space_free_pointer, NL0)
-	add	NL0, ALLOC, ALLOC
-        load(current_binding_stack_pointer, BSP)
-        load(current_control_stack_pointer, CSP)
-        load(current_control_frame_pointer, OCFP)
-
-        /* No longer atomic, and check for interrupt. */
-	tsubcctv	ALLOC, 4, ALLOC
-
-        /* Pass in the args. */
-        /* Note: CNAME and LEXENV already hold the correct values. */
-        mov     %i2, CFP
-        sll     %i3, 2, NARGS
-        ld      [CFP+0], A0
-        ld      [CFP+4], A1
-        ld      [CFP+8], A2
-        ld      [CFP+12], A3
-        ld      [CFP+16], A4
-        ld      [CFP+20], A5
-
-        /* Calculate LRA */
-        set     lra + type_OtherPointer, LRA
-
-        /* Indirect closure */
-        ld      [LEXENV+CLOSURE_FUNCTION_OFFSET], CODE
-
-        jmp     CODE+FUNCTION_HEADER_CODE_OFFSET
-        nop
-
-        .align  8
-lra:
-        .word   type_ReturnPcHeader
-
-        /* Blow off any extra values. */
-        mov     OCFP, CSP
-        nop
-
-        /* Return the one value. */
-        mov     A0, %i0
-
-        /* Turn on pseudo_atomic */
-	add	ALLOC, 4, ALLOC
-
-        /* Store LISP state */
-	andn	ALLOC, 7, NL1
-        store(NL1,current_dynamic_space_free_pointer)
-        store(BSP,current_binding_stack_pointer)
-        store(CSP,current_control_stack_pointer)
-        store(CFP,current_control_frame_pointer)
-
-        /* No longer in Lisp. */
-        store(NL1,foreign_function_call_active)
-
-        /* Were we interrupted? */
-	tsubcctv	ALLOC, 4, ALLOC
-
-        /* Back to C we go. */
-	ld	[%sp+FRAMESIZE-4], %i7
-        ret
-        restore	%sp, FRAMESIZE, %sp
-
-
-
-        .global _call_into_c
-_call_into_c:
-        /* Build a lisp stack frame */
-        mov     CFP, OCFP
-        mov     CSP, CFP
-        add     CSP, 32, CSP
-        st      OCFP, [CFP]
-        st      CODE, [CFP+8]
-
-        /* Turn on pseudo-atomic. */
-	add	ALLOC, 4, ALLOC
-
-	/* Convert the return address to an offset and save it on the stack. */
-	sub	LIP, CODE, L0
-	add	L0, type_OtherPointer, L0
-	st	L0, [CFP+4]
-
-        /* Store LISP state */
-	andn	ALLOC, 7, L1
-        store(L1,current_dynamic_space_free_pointer)
-        store(BSP,current_binding_stack_pointer)
-        store(CSP,current_control_stack_pointer)
-        store(CFP,current_control_frame_pointer)
-
-        /* No longer in Lisp. */
-        store(CSP,foreign_function_call_active)
-
-        /* Were we interrupted? */
-	tsubcctv	ALLOC, 4, ALLOC
-
-        /* Into C we go. */
-        call    CFUNC
-        nop
-
-        /* Re-establish NIL */
-        set     NIL, NULLREG
-
-	/* Atomic. */
-	set	4, ALLOC
-
-        /* No longer in foreign function call. */
-        sethi   %hi(NAME(foreign_function_call_active)), NL1
-        st      ZERO, [NL1+%lo(NAME(foreign_function_call_active))]
-
-        /* Load the rest of lisp state. */
-        load(current_dynamic_space_free_pointer, NL1)
-	add	NL1, ALLOC, ALLOC
-        load(current_binding_stack_pointer, BSP)
-        load(current_control_stack_pointer, CSP)
-        load(current_control_frame_pointer, CFP)
-
-	/* Get the return address back. */
-	ld	[CFP+4], LIP
-	ld	[CFP+8], CODE
-	add	LIP, CODE, LIP
-	sub	LIP, type_OtherPointer, LIP
-
-        /* No longer atomic. */
-	tsubcctv	ALLOC, 4, ALLOC	
-
-        /* Reset the lisp stack. */
-        /* Note: OCFP is in one of the locals, it gets preserved across C. */
-        mov     CFP, CSP
-        mov     OCFP, CFP
-
-        /* And back into lisp. */
-        ret
-        nop
-
-
-
-
-        .global _undefined_tramp
-        .align  8
-        .byte   0
-_undefined_tramp:
-        .byte   0, 0, type_FunctionHeader
-        .word   _undefined_tramp
-        .word   NIL
-        .word   NIL
-        .word   NIL
-        .word   NIL
-
-	b	1f
-        unimp   trap_Cerror
-	.byte	4, 23, 254, 12, 3
-	.align	4
-1:
-	ld	[CNAME+FDEFN_RAW_ADDR_OFFSET], CODE
-	jmp	CODE+FUNCTION_HEADER_CODE_OFFSET
-	nop
-
-	.global	_closure_tramp
-	.align	8
-	.byte	0
-_closure_tramp:
-	.byte	0, 0, type_FunctionHeader
-	.word	_closure_tramp
-	.word	NIL
-        .word   NIL
-	.word	NIL
-	.word	NIL
-
-	ld	[CNAME+FDEFN_FUNCTION_OFFSET], LEXENV
-	ld	[LEXENV+CLOSURE_FUNCTION_OFFSET], CODE
-	jmp	CODE+FUNCTION_HEADER_CODE_OFFSET
-	nop
-
-
-
-/*
- * Function-end breakpoint magic.
- */
-
-	.text
-	.align	8
-	.global	_function_end_breakpoint_guts
-_function_end_breakpoint_guts:
-	.word	type_ReturnPcHeader
-	b	1f
-	nop
-	mov	CSP, OCFP
-	add	4, CSP, CSP
-	mov	4, NARGS
-	mov	NULLREG, A1
-	mov	NULLREG, A2
-	mov	NULLREG, A3
-	mov	NULLREG, A4
-	mov	NULLREG, A5
-1:
-
-	.global	_function_end_breakpoint_trap
-_function_end_breakpoint_trap:
-	unimp	trap_FunctionEndBreakpoint
-	b	1b
-	nop
-
-	.global	_function_end_breakpoint_end
-_function_end_breakpoint_end:
-
-
-
-
-/****************************************************************\
-
-We need our own version of sigtramp.
-
-\****************************************************************/
-
-	.global	__sigtramp, __sigfunc
-__sigtramp:
-	!
-	! On entry sp points to:
-	! 	0 - 63: window save area
-	!	64: signal number
-	!	68: signal code
-	!	72: pointer to sigcontext
-	!	76: addr parameter
-	!
-	! A sigcontext looks like:
-	!	00: on signal stack flag
-	!	04: old signal mask
-	!	08: old sp
-	!	12: old pc
-	!	16: old npc
-	!	20: old psr
-	!	24: old g1
-	!	28: old o0
-	!
-        ! Out sigcontext has the following added:
-        !       32: regs[32]
-        !       160: fpregs[32]
-        !       288: y
-        !       292: fsr
-        !
-        ! After we allocate space for the new sigcontext, the stack looks like:
-        !       < window save area, etc >
-        !       SCOFF: start of generic sigcontext.
-        !       IREGSOFF: start of lisp sigcontext.
-        !       SIGNUM: signal number
-        !       CODE: signal code
-        !       OSCP: pointer to orig sigcontext
-        !       ADDR: addr parameter (which isn't supplied by the kernel)
-
-#define SCOFF SA(MINFRAME)
-#define IREGSOFF SCOFF+32
-#define FPREGSOFF IREGSOFF+(32*4)
-#define YOFF FPREGSOFF+(32*4)
-#define FSROFF YOFF+4
-#define SCSIZE SA(32+(32*4)+(32*4)+4+4)
-#define SIGNUMOFF SCOFF+SCSIZE
-#define CODEOFF SCOFF+SCSIZE+4
-#define ADDROFF SCOFF+SCSIZE+12
-
-#ifdef MACH
-#define OSCOFF ADDROFF
-#else
-#define OSCOFF SCOFF+SCSIZE+16
-#endif
-
-        ! Allocate space for our sigcontext.
-        sub     %sp, SCSIZE+SA(MINFRAME)-64, %sp
-
-        ! Save integer registers.
-        ! Note: the globals and outs are good, but the locals and ins have
-        ! been trashed.  But luckly, they have been saved on the stack.
-        ! So we need to extract the saved stack pointer from the sigcontext
-        ! to determine where they are.
-        std     %g0, [%sp+IREGSOFF]
-        std     %g2, [%sp+IREGSOFF+8]
-        std     %g4, [%sp+IREGSOFF+16]
-        std     %g6, [%sp+IREGSOFF+24]
-        std     %o0, [%sp+IREGSOFF+32]
-        ld      [%sp + OSCOFF+8], %o0
-        std     %o2, [%sp+IREGSOFF+40]
-        std     %o4, [%sp+IREGSOFF+48]
-        st      %o0, [%sp+IREGSOFF+56]
-        st      %o7, [%sp+IREGSOFF+60]
-
-        ldd     [%o0], %l0
-        ldd     [%o0+8], %l2
-        ldd     [%o0+16], %l4
-        ldd     [%o0+24], %l6
-        ldd     [%o0+32], %i0
-        ldd     [%o0+40], %i2
-        ldd     [%o0+48], %i4
-        ldd     [%o0+56], %i6
-        std     %l0, [%sp+IREGSOFF+64]
-        std     %l2, [%sp+IREGSOFF+72]
-        std     %l4, [%sp+IREGSOFF+80]
-        std     %l6, [%sp+IREGSOFF+88]
-        std     %i0, [%sp+IREGSOFF+96]
-        std     %i2, [%sp+IREGSOFF+104]
-        std     %i4, [%sp+IREGSOFF+112]
-        std     %i6, [%sp+IREGSOFF+120]
-
-        ! Copy the original sigcontext down to our sigcontext.
-        ld      [%sp + OSCOFF], %l0
-        ld      [%sp + OSCOFF+4], %l1
-        ld      [%sp + OSCOFF+8], %l2
-        ld      [%sp + OSCOFF+12], %l3
-        ld      [%sp + OSCOFF+16], %l4
-        ld      [%sp + OSCOFF+20], %l5
-        ld      [%sp + OSCOFF+24], %l6
-        ld      [%sp + OSCOFF+28], %l7
-        std     %l0, [%sp+SCOFF]
-        std     %l2, [%sp+SCOFF+8]
-        std     %l4, [%sp+SCOFF+16]
-        std     %l6, [%sp+SCOFF+24]
-
-        ! Check to see if we need to save the fp regs.
-	set	PSR_EF, %l0
-	mov	%y, %l2			! save y
-	btst	%l0, %l5		! is FPU enabled?
-	bz	1f			! if not skip FPU save
-	st	%l2, [%sp + YOFF]
-
-	std	%f0, [%sp + FPREGSOFF+(0*4)]	! save all fpu registers.
-	std	%f2, [%sp + FPREGSOFF+(2*4)]
-	std	%f4, [%sp + FPREGSOFF+(4*4)]
-	std	%f6, [%sp + FPREGSOFF+(6*4)]
-	std	%f8, [%sp + FPREGSOFF+(8*4)]
-	std	%f10, [%sp + FPREGSOFF+(10*4)]
-	std	%f12, [%sp + FPREGSOFF+(12*4)]
-	std	%f14, [%sp + FPREGSOFF+(14*4)]
-	std	%f16, [%sp + FPREGSOFF+(16*4)]
-	std	%f18, [%sp + FPREGSOFF+(18*4)]
-	std	%f20, [%sp + FPREGSOFF+(20*4)]
-	std	%f22, [%sp + FPREGSOFF+(22*4)]
-	std	%f24, [%sp + FPREGSOFF+(24*4)]
-	std	%f26, [%sp + FPREGSOFF+(26*4)]
-	std	%f28, [%sp + FPREGSOFF+(28*4)]
-	std	%f30, [%sp + FPREGSOFF+(30*4)]
-	st	%fsr, [%sp + FSROFF] ! save old fsr
-1:
-
-	ld	[%sp + SIGNUMOFF], %o0	! get signal number
-	set	__sigfunc, %g1		! get array of function ptrs
-	sll	%o0, 2, %g2		! scale signal number for index
-	ld	[%g1 + %g2], %g1	! get func
-	ld	[%sp + CODEOFF], %o1	! get code
-        add     %sp, SCOFF, %o2         ! compute scp
-	call	%g1			! (*_sigfunc[sig])(sig,code,scp,addr)
-	ld	[%sp + ADDROFF], %o3	! get addr
-
-        ! Recompute scp, and call into _sigreturn
-        add     %sp, SCOFF, %o0
-
-
-        .global _sigreturn
-_sigreturn:
-        ! Move values we can't restore directory into real sigcontext.
-        ld      [%o0+32+(4*1)], %l0     ! g1
-        ld      [%o0+32+(4*8)], %l1     ! o0
-        ld      [%o0+32+(4*14)], %l2    ! sp
-        st      %l0, [%o0+24]
-        st      %l1, [%o0+28]
-        st      %l2, [%o0+8]
-
-	ld	[%o0 + 20], %l2		! get psr
-	set	PSR_EF, %l0
-	ld	[%o0 + 288], %l1        ! restore y
-	btst	%l0, %l2		! is FPU enabled?
-	bz	2f			! if not skip FPU restore
-	mov	%l1, %y
-
-	ldd	[%o0 + 160+(0*4)], %f0	! restore all fpu registers.
-	ldd	[%o0 + 160+(2*4)], %f2
-	ldd	[%o0 + 160+(4*4)], %f4
-	ldd	[%o0 + 160+(6*4)], %f6
-	ldd	[%o0 + 160+(8*4)], %f8
-	ldd	[%o0 + 160+(10*4)], %f10
-	ldd	[%o0 + 160+(12*4)], %f12
-	ldd	[%o0 + 160+(14*4)], %f14
-	ldd	[%o0 + 160+(16*4)], %f16
-	ldd	[%o0 + 160+(18*4)], %f18
-	ldd	[%o0 + 160+(20*4)], %f20
-	ldd	[%o0 + 160+(22*4)], %f22
-	ldd	[%o0 + 160+(24*4)], %f24
-	ldd	[%o0 + 160+(26*4)], %f26
-	ldd	[%o0 + 160+(28*4)], %f28
-	ldd	[%o0 + 160+(30*4)], %f30
-	ld	[%o0 + 160+(33*4)], %fsr	! restore old fsr
-2:
-
-	! The locals and in are restored from the stack, so we have to put
-	! them there.
-	ld	[%o0 + 8], %o1
-        ldd     [%o0 + 32+(16*4)], %l0
-        ldd     [%o0 + 32+(18*4)], %l2
-        ldd     [%o0 + 32+(20*4)], %l4
-        ldd     [%o0 + 32+(22*4)], %l6
-        ldd     [%o0 + 32+(24*4)], %i0
-        ldd     [%o0 + 32+(26*4)], %i2
-        ldd     [%o0 + 32+(28*4)], %i4
-        ldd     [%o0 + 32+(30*4)], %i6
-	std	%l0, [%o1 + (0*4)]
-	std	%l2, [%o1 + (2*4)]
-	std	%l4, [%o1 + (4*4)]
-	std	%l6, [%o1 + (6*4)]
-	std	%i0, [%o1 + (8*4)]
-	std	%i2, [%o1 + (10*4)]
-	std	%i4, [%o1 + (12*4)]
-	std	%i6, [%o1 + (14*4)]
-
-        ! Restore the globals and outs.  Don't restore %g1, %o0, or %sp
-	! 'cause they get restored from the sigcontext.
-        ldd     [%o0 + 32+(2*4)], %g2
-        ldd     [%o0 + 32+(4*4)], %g4
-        ldd     [%o0 + 32+(6*4)], %g6
-        ld      [%o0 + 32+(9*4)], %o1
-        ldd     [%o0 + 32+(10*4)], %o2
-        ldd     [%o0 + 32+(12*4)], %o4
-        ld      [%o0 + 32+(15*4)], %o7
-
-	set	139, %g1		! sigcleanup system call
-	t	0
-	unimp	0			! just in case it returns
-	/*NOTREACHED*/
-
diff --git a/ldb/sparc-lispregs.h b/ldb/sparc-lispregs.h
deleted file mode 100644
index dc9bad42308d69052a3650e3adbe21df06cc49fc..0000000000000000000000000000000000000000
--- a/ldb/sparc-lispregs.h
+++ /dev/null
@@ -1,64 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/sparc-lispregs.h,v 1.1 1991/05/24 18:45:57 wlott Exp $ */
-
-#ifdef LANGUAGE_ASSEMBLY
-
-#define GREG(num) %g/**/num
-#define OREG(num) %o/**/num
-#define LREG(num) %l/**/num
-#define IREG(num) %i/**/num
-
-#else
-
-#define GREG(num) (num)
-#define OREG(num) ((num)+8)
-#define LREG(num) ((num)+16)
-#define IREG(num) ((num)+24)
-
-#endif
-
-#define NREGS	(32)
-
-#define ZERO	GREG(0)
-#define ALLOC	GREG(1)
-#define NULLREG	GREG(2)
-#define CSP	GREG(3)
-#define CFP	GREG(4)
-#define BSP	GREG(5)
-#define NFP	GREG(6)
-#define CFUNC	GREG(7)
-
-#define NL0	OREG(0)
-#define NL1	OREG(1)
-#define NL2	OREG(2)
-#define NL3	OREG(3)
-#define NL4	OREG(4)
-#define NL5	OREG(5)
-#define NSP	OREG(6)
-#define NARGS	OREG(7)
-
-#define A0	LREG(0)
-#define A1	LREG(1)
-#define A2	LREG(2)
-#define A3	LREG(3)
-#define A4	LREG(4)
-#define A5	LREG(5)
-#define OCFP	LREG(6)
-#define LRA	LREG(7)
-
-#define CNAME	IREG(0)
-#define LEXENV	IREG(1)
-#define L0	IREG(2)
-#define L1	IREG(3)
-#define L2	IREG(4)
-#define CODE	IREG(5)
-#define LIP	IREG(7)
-
-#define REGNAMES \
-	"ZERO",		"ALLOC",	"NULL",		"CSP", \
-	"CFP",		"BSP",		"NFP",		"CFUNC", \
-        "NL0",		"NL1",		"NL2",		"NL3", \
-        "NL4",		"NL5",		"NSP",		"NARGS", \
-        "A0",		"A1",		"A2",		"A3", \
-        "A4",		"A5",		"OCFP",		"LRA", \
-        "CNAME",	"LEXENV",	"L0",		"L1", \
-        "L2",		"CODE",		"???",		"LIP"
diff --git a/ldb/sunos-os.c b/ldb/sunos-os.c
deleted file mode 100644
index bd070d545a63eae107a0ef15c0e193a115bd47db..0000000000000000000000000000000000000000
--- a/ldb/sunos-os.c
+++ /dev/null
@@ -1,701 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/sunos-os.c,v 1.3 1992/03/06 12:34:22 wlott Exp $
- *
- * OS-dependent routines.  This file (along with os.h) exports an
- * OS-independent interface to the operating system VM facilities.
- * Suprisingly, this interface looks a lot like the Mach interface
- * (but simpler in some places).  For some operating systems, a subset
- * of these functions will have to be emulated.
- *
- * This is the SunOS version.
- * March 1991, Miles Bader <miles@cogsci.ed.ack.uk> & ted <ted@edu.NMSU>
- *
- */
-
-/* #define DEBUG */
-
-#include <stdio.h>
-
-#include <signal.h>
-#include <sys/file.h>
-
-#include "ldb.h"
-#include "os.h"
-
-/* block size must be larger than the system page size */
-#define SPARSE_BLOCK_SIZE (1<<15)
-#define SPARSE_SIZE_MASK (SPARSE_BLOCK_SIZE-1)
-
-#define PROT_DEFAULT OS_VM_PROT_ALL
-
-#define OFFSET_NONE ((os_vm_offset_t)(~0))
-
-#define EMPTYFILE "/tmp/empty"
-#define ZEROFILE "/dev/zero"
-
-#define MAX_SEGS 64
-
-extern char *getenv();
-
-/* ---------------------------------------------------------------- */
-
-#define ADJ_OFFSET(off,adj) (((off)==OFFSET_NONE) ? OFFSET_NONE : ((off)+(adj)))
-
-long os_vm_page_size=(-1);
-
-static struct segment {
-    os_vm_address_t start;	/* note: start & length are expected to be on page */
-    os_vm_size_t length;        /*       boundaries */
-    long file_offset;
-    short mapped_fd;
-    short protection;
-} addr_map[MAX_SEGS];
-
-static int n_segments=0;
-
-static int zero_fd=(-1), empty_fd=(-1);
-
-static os_vm_address_t last_fault=0;
-static os_vm_size_t real_page_size_difference=0;
-
-void os_init()
-{
-    char *empty_file=getenv("CMUCL_EMPTYFILE");
-
-    if(empty_file==NULL)
-	empty_file=EMPTYFILE;
-
-    empty_fd=open(empty_file,O_RDONLY|O_CREAT);
-    unlink(empty_file);
-
-    zero_fd=open(ZEROFILE,O_RDONLY);
-
-    os_vm_page_size=getpagesize();
-
-    if(os_vm_page_size>OS_VM_DEFAULT_PAGESIZE){
-	fprintf(stderr,"os_init: Pagesize too large (%d > %d)\n",
-		os_vm_page_size,OS_VM_DEFAULT_PAGESIZE);
-	exit(1);
-    }else{
-	/*
-	 * we do this because there are apparently dependencies on
-	 * the pagesize being OS_VM_DEFAULT_PAGESIZE somewhere...
-	 * but since the OS doesn't know we're using this restriction,
-	 * we have to grovel around a bit to enforce it, thus anything
-	 * that uses real_page_size_difference.
-	 */
-	real_page_size_difference=OS_VM_DEFAULT_PAGESIZE-os_vm_page_size;
-	os_vm_page_size=OS_VM_DEFAULT_PAGESIZE;
-    }
-}
-
-/* ---------------------------------------------------------------- */
-
-void seg_force_resident(seg,addr,len)
-struct segment *seg;
-os_vm_address_t addr;
-os_vm_size_t len;
-{
-    int prot=seg->protection;
-
-    if(prot!=0){
-	os_vm_address_t end=addr+len, touch=addr;
-		
-	while(touch<end){
-	    int contents=(*(char *)touch);
-	    if(prot&OS_VM_PROT_WRITE)
-		(*(char *)touch)=contents;
-	    touch=(os_vm_address_t)(((long)touch+SPARSE_BLOCK_SIZE)&~SPARSE_SIZE_MASK);
-	}
-    }
-}
-
-static struct segment *seg_create_nomerge(addr,len,protection,mapped_fd,file_offset)
-os_vm_address_t addr;
-os_vm_size_t len;
-int protection;
-int mapped_fd;
-{
-    int n;
-    struct segment *seg;
-
-    if(len==0)
-	return NULL;
-
-    if(n_segments==MAX_SEGS){
-	fprintf(stderr,"seg_create_nomerge: Out of segments\n");
-	return NULL;
-    }
-
-    for(n=n_segments, seg=addr_map; n>0; n--, seg++)
-	if(addr<seg->start){
-	    seg=(&addr_map[n_segments]);
-	    while(n-->0){
-		seg[0]=seg[-1];
-		seg--;
-	    }
-	    break;
-	}
-
-    n_segments++;
-
-    seg->start=addr;
-    seg->length=len;
-    seg->protection=protection;
-    seg->mapped_fd=mapped_fd;
-    seg->file_offset=file_offset;
-
-    return seg;
-}
-
-/* returns the first segment containing addr */
-static struct segment *seg_find(addr)
-os_vm_address_t addr;
-{
-    int n;
-    struct segment *seg;
-
-    for(n=n_segments, seg=addr_map; n>0; n--, seg++)
-	if(seg->start<=addr && seg->start+seg->length>addr)
-	    return seg;
-
-    return NULL;
-}
-
-/* returns TRUE if the range from addr to addr+len intersects with any segment */
-static boolean collides_with_seg_p(addr,len)
-os_vm_address_t addr;
-os_vm_size_t len;
-{
-    int n;
-    struct segment *seg;
-    os_vm_address_t end=addr+len;
-
-    for(n=n_segments, seg=addr_map; n>0; n--, seg++)
-	if(seg->start>=end)
-	    return FALSE;
-	else if(seg->start+seg->length>addr)
-	    return TRUE;
-
-    return FALSE;
-}
-
-#define seg_last_p(seg) (((seg)-addr_map)>=n_segments-1)
-
-static void seg_destroy(seg)
-struct segment *seg;
-{
-    if(seg!=NULL){
-	int n;
-
-	for(n=seg-addr_map+1; n<n_segments; n++){
-	    seg[0]=seg[1];
-	    seg++;
-	}
-
-	n_segments--;
-    }
-}
-
-static void seg_try_merge_next(seg)
-struct segment *seg;
-{
-    struct segment *nseg=seg+1;
-
-    if(!seg_last_p(seg)
-       && seg->start+seg->length==nseg->start
-       && seg->protection==nseg->protection
-       && seg->mapped_fd==nseg->mapped_fd
-       && ADJ_OFFSET(seg->file_offset,seg->length)==nseg->file_offset)
-    {
-	/* can merge with the next segment */
-#ifdef DEBUG
-	fprintf(stderr,
-		";;; seg_try_merge: Merged 0x%08x[0x%08x] with 0x%08x[0x%08x]\n",
-		seg->start,seg->length,nseg->start,nseg->length);
-#endif
-
-	if(((long)nseg->start&SPARSE_SIZE_MASK)!=0){
-	    /*
-	     * if not on a block boundary, we have to ensure both parts
-	     * of a common block are in a known state
-	     */
-	    seg_force_resident(seg,nseg->start-1,1);
-	    seg_force_resident(nseg,nseg->start,1);
-	}
-
-	seg->length+=nseg->length;
-	seg_destroy(nseg);
-    }
-}
-
-
-/*
- * Try to merge seg with adjacent segments.
- */
-static void seg_try_merge_adjacent(seg)
-struct segment *seg;
-{
-    if(!seg_last_p(seg))
-	seg_try_merge_next(seg);
-    if(seg>addr_map)
-	seg_try_merge_next(seg-1);
-}
-
-static struct segment *seg_create(addr,len,protection,mapped_fd,file_offset)
-os_vm_address_t addr;
-os_vm_size_t len;
-int protection;
-int mapped_fd;
-{
-    struct segment *seg=seg_create_nomerge(addr,len,protection,mapped_fd,file_offset);
-    if(seg!=NULL)
-	seg_try_merge_adjacent(seg);
-    return seg;
-}
-
-/* 
- * Change the attributes of the given range of an existing segment, and return
- * a segment corresponding to the new bit.
- */
-static struct segment *seg_change_range(seg,addr,len,protection,mapped_fd,file_offset)
-struct segment *seg;
-os_vm_address_t addr;
-os_vm_size_t len;
-int protection;
-int mapped_fd;
-{
-    os_vm_address_t end=addr+len;
-
-    if(len==0)
-	return NULL;
-
-    if(protection!=seg->protection
-       || mapped_fd!=seg->mapped_fd
-       || file_offset!=ADJ_OFFSET(seg->file_offset,addr-seg->start))
-    {
-	os_vm_size_t old_len=seg->length, seg_offset=(addr-seg->start);
-	
-	if(old_len<len+seg_offset){
-	    struct segment *next=seg+1;
-	    
-#ifdef DEBUG
-	    fprintf(stderr,
-		    ";;; seg_change_range: region 0x%08x[0x%08x] overflows 0x%08x[0x%08x]\n",
-		    addr,len,
-		    seg->start,old_len);
-#endif
-	    
-	    while(!seg_last_p(seg) && next->start+next->length<=end){
-#ifdef DEBUG
-		fprintf(stderr,
-			";;; seg_change_range: merging extra segment 0x%08x[0x%08x]\n",
-			next->start,
-			next->length);
-#endif
-		seg_destroy(next);
-	    }
-	    
-	    if(!seg_last_p(seg) && next->start<end){
-		next->length-=end-next->start;
-		next->start=end;
-		old_len=next->start-seg->start;
-	    }else
-		old_len=len+seg_offset;
-	    
-#ifdef DEBUG
-	    fprintf(stderr,
-		    ";;; seg_change_range: extended first seg to 0x%08x[0x%08x]\n",
-		    seg->start,
-		    old_len);
-#endif
-	}
-
-	if(seg_offset+len<old_len){
-	    /* add second part of old segment */
-	    seg_create_nomerge(end,
-			       old_len-(seg_offset+len),
-			       seg->protection,
-			       seg->mapped_fd,
-			       ADJ_OFFSET(seg->file_offset,seg_offset+len));
-
-#ifdef DEBUG
-	    fprintf(stderr,
-		    ";;; seg_change_range: Split off end of 0x%08x[0x%08x]: 0x%08x[0x%08x]\n",
-		    seg->start,old_len,
-		    end,old_len-(seg_offset+len));
-#endif
-	}
-
-	if(seg_offset==0){
-	    seg->length=len;
-	    seg->protection=protection;
-	    seg->mapped_fd=mapped_fd;
-	    seg->file_offset=file_offset;
-	}else{
-	    /* adjust first part of remaining old segment */
-	    seg->length=seg_offset;
-
-#ifdef DEBUG
-	    fprintf(stderr,
-		    ";;; seg_change_range: Split off beginning of 0x%08x[0x%08x]: 0x%08x[0x%08x]\n",
-		    seg->start,old_len,
-		    seg->start,seg_offset);
-#endif
-
-	    /* add new middle segment for new protected region */
-	    seg=seg_create_nomerge(addr,len,protection,mapped_fd,file_offset);
-	}
-
-	seg_try_merge_adjacent(seg);
-
-	last_fault=0;
-    }
-
-    return seg;
-}
-
-/* ---------------------------------------------------------------- */
-
-static os_vm_address_t mapin(addr,len,protection,map_fd,offset,is_readable)
-os_vm_address_t addr;
-os_vm_size_t len;
-int protection;
-int map_fd;
-long offset;
-int is_readable;
-{
-    os_vm_address_t real;
-    boolean sparse=(len>=SPARSE_BLOCK_SIZE);
-
-    if(offset!=OFFSET_NONE
-       && (offset<os_vm_page_size || (offset&(os_vm_page_size-1))!=0))
-    {
-	fprintf(stderr,
-		"mapin: file offset (%d) not multiple of pagesize (%d)\n",
-		offset,
-		os_vm_page_size);
-    }
-
-    if(addr==NULL)
-	len+=real_page_size_difference;	/* futz around to get an aligned region */
-
-    last_fault=0;
-    real=(os_vm_address_t)
-	mmap((caddr_t)addr,
-	     (long)len,
-	     sparse ? (is_readable ? PROT_READ|PROT_EXEC : 0) : protection,
-	     (addr==NULL? 0 : MAP_FIXED)|MAP_PRIVATE,
-	     (is_readable || !sparse) ? map_fd : empty_fd,
-	     (off_t)(offset==OFFSET_NONE ? 0 : offset));
-
-    if((long)real==-1){
-	perror("mapin: mmap");
-	return NULL;
-    }
-
-    if(addr==NULL){
-	/*
-	 * now play around with what the os gave us to make it align by
-	 * our standards (which is why we overallocated)
-	 */
-	os_vm_size_t overflow;
-
-	addr=os_round_up_to_page(real);
-	if(addr!=real)
-	    munmap(real,addr-real);
-	
-	overflow=real_page_size_difference-(addr-real);
-	if(overflow!=0)
-	    munmap(addr+len-real_page_size_difference,overflow);
-
-	real=addr;
-    }
-
-
-    return real;
-}
-
-static os_vm_address_t map_and_remember(addr,len,protection,map_fd,offset,is_readable)
-os_vm_address_t addr;
-os_vm_size_t len;
-int protection;
-int map_fd;
-long offset;
-int is_readable;
-{
-    os_vm_address_t real=mapin(addr,len,protection,map_fd,offset,is_readable);
-
-    if(real!=NULL){
-	struct segment *seg=seg_find(real);
-
-	if(seg!=NULL)
-	    seg=seg_change_range(seg,real,len,protection,map_fd,offset);
-	else
-	    seg=seg_create(real,len,protection,map_fd,offset);
-
-	if(seg==NULL){
-	    munmap(real,len);
-	    return NULL;
-	}
-    }
-
-#ifdef DEBUG
-    fprintf(stderr,";;; map_and_remember: 0x%08x[0x%08x] offset: %d, mapped to: %d\n",
-	    real,len,offset,map_fd);
-#endif
-
-    return real;
-}
-
-/* ---------------------------------------------------------------- */
-
-os_vm_address_t os_validate(addr, len)
-os_vm_address_t addr;
-os_vm_size_t len;
-{
-    addr=os_trunc_to_page(addr);
-    len=os_round_up_size_to_page(len);
-
-#ifdef DEBUG
-    fprintf(stderr, ";;; os_validate: 0x%08x[0x%08x]\n",addr,len);
-#endif
-
-    if(addr!=NULL && collides_with_seg_p(addr,len))
-	return NULL;
-
-    return map_and_remember(addr,len,PROT_DEFAULT,zero_fd,OFFSET_NONE,FALSE);
-}
-
-void os_invalidate(addr, len)
-os_vm_address_t addr;
-os_vm_size_t len;
-{
-    struct segment *seg=seg_find(addr);
-
-    addr=os_trunc_to_page(addr);
-    len=os_round_up_size_to_page(len);
-
-#ifdef DEBUG
-    fprintf(stderr, ";;; os_invalidate: 0x%08x[0x%08x]\n",addr,len);
-#endif
-
-    if(seg==NULL)
-	fprintf(stderr, "os_invalidate: Unknown segment: 0x%08x[0x%08x]\n",addr,len);
-    else{
-	seg=seg_change_range(seg,addr,len,0,0,OFFSET_NONE);
-	if(seg!=NULL)
-	    seg_destroy(seg);
-
-	last_fault=0;
-	if(munmap(addr,len)!=0)
-	    perror("os_invalidate: munmap");
-    }
-}
-
-os_vm_address_t os_map(fd, offset, addr, len)
-int fd;
-os_vm_offset_t offset;
-os_vm_address_t addr;
-long len;
-{
-    addr=os_trunc_to_page(addr);
-    len=os_round_up_size_to_page(len);
-
-#ifdef DEBUG
-    fprintf(stderr, ";;; os_map: 0x%08x[0x%08x]\n",addr,len);
-#endif
-
-    return map_and_remember(addr,len,PROT_DEFAULT,fd,offset,TRUE);
-}
-
-void os_flush_icache(address, length)
-os_vm_address_t address;
-os_vm_size_t length;
-{
-#if defined(MACH) && defined(mips)
-	vm_machine_attribute_val_t flush;
-	kern_return_t kr;
-
-	flush = MATTR_VAL_ICACHE_FLUSH;
-
-	kr = vm_machine_attribute(task_self(), address, length,
-				  MATTR_CACHE, &flush);
-	if (kr != KERN_SUCCESS)
-		mach_error("Could not flush the instruction cache", kr);
-#endif
-}
-
-void os_protect(addr, len, prot)
-os_vm_address_t addr;
-os_vm_size_t len;
-int prot;
-{
-    struct segment *seg=seg_find(addr);
-
-    addr=os_trunc_to_page(addr);
-    len=os_round_up_size_to_page(len);
-
-#ifdef DEBUG
-    fprintf(stderr,";;; os_protect: 0x%08x[0x%08x]\n",addr,len);
-#endif
-
-    if(seg!=NULL){
-	int old_prot=seg->protection;
-
-	if(prot!=old_prot){
-	    /*
-	     * oooooh, sick: we have to make sure all the pages being protected have
-	     * faulted in, so they're in a known state...
-	     */
-	    seg_force_resident(seg,addr,len);
-
-	    seg_change_range(seg,addr,len,prot,seg->mapped_fd,seg->file_offset);
-
-	    if(mprotect((caddr_t)addr,(long)len,prot)!=0)
-		perror("os_unprotect: mprotect");
-	}
-    }else
-	fprintf(stderr,"os_protect: Unknown segment: 0x%08x[0x%08x]\n",addr,len);
-}
-
-boolean valid_addr(test)
-os_vm_address_t test;
-{
-    return seg_find(test)!=NULL;
-}
-
-/* ---------------------------------------------------------------- */
-
-static boolean maybe_gc(context)
-struct sigcontext *context;
-{
-    /*
-     * It's necessary to enable recursive SEGVs, since the handle is
-     * used for multiple things (e.g., both gc-trigger & faulting in pages).
-     * We check against recursive gc's though...
-     */
-
-    boolean did_gc;
-    static already_trying=0;
-
-    if(already_trying)
-	return FALSE;
-
-    sigsetmask(context->sc_mask);
-
-    already_trying=TRUE;
-    did_gc=interrupt_maybe_gc(context);
-    already_trying=FALSE;
-
-    return did_gc;
-}
-
-/*
- * The primary point of catching segmentation violations is to allow 
- * read only memory to be re-mapped with more permissions when a write
- * is attempted.  this greatly decreases the residency of the program
- * in swap space since read only areas don't take up room
- *
- * Running into the gc trigger page will also end up here...
- */
-void segv_handler(sig, code, context, addr)
-int sig, code;
-struct sigcontext *context;
-caddr_t addr;
-{
-    if (code == SEGV_PROT) {	/* allow writes to this chunk */
-	struct segment *seg=seg_find(addr);
-
-	if(last_fault==addr){
-	    if(seg!=NULL && maybe_gc(context))
-		/* we just garbage collected */
-		return;
-	    else{
-		/* a *real* protection fault */
-		fprintf(stderr,
-			"segv_handler: Real protection violation: 0x%08x\n",
-			addr);
-		interrupt_handle_now(sig,code,context);
-	    }
-	}else
-	    last_fault=addr;
-
-	if(seg!=NULL){
-	    int err;
-	    /* round down to a page */
-	    os_vm_address_t block=(os_vm_address_t)((long)addr&~SPARSE_SIZE_MASK);
-	    os_vm_size_t length=SPARSE_BLOCK_SIZE;
-
-	    if(block < seg->start){
-		length-=(seg->start - block);
-		block=seg->start;
-	    }
-	    if(block+length > seg->start+seg->length)
-		length=seg->start+seg->length-block;
-
-#if 0
-	    /* unmap it.  probably redundant. */
-	    if(munmap(block,length) == -1)
-		perror("segv_handler: munmap");
-#endif
-
-	    /* and remap it with more permissions */
-	    err=(int)
-		mmap(block,
-		     length,
-		     seg->protection,
-		     MAP_PRIVATE|MAP_FIXED,
-		     seg->mapped_fd,
-		     seg->file_offset==OFFSET_NONE
-		       ? 0
-		       : seg->file_offset+(block-seg->start));
-
-	    if (err == -1) {
-		perror("segv_handler: mmap");
-		interrupt_handle_now(sig,code,context);
-	    }
-	}
-	else{
-	    fprintf(stderr, "segv_handler: 0x%08x not in any segment\n",addr);
-	    interrupt_handle_now(sig,code,context);
-	}
-    }
-    /*
-     * note that we check for a gc-trigger hit even if it's not a PROT error
-     */
-    else if(!maybe_gc(context)){
-	static int nomap_count=0;
-
-	if(code==SEGV_NOMAP){
-	    if(nomap_count==0){
-		fprintf(stderr,
-			"segv_handler: No mapping fault: 0x%08x\n",addr);
-		nomap_count++;
-	    }else{
-		/*
-		 * There should be higher-level protection against stack
-		 * overflow somewhere, but at least this prevents infinite
-		 * puking of error messages...
-		 */
-		fprintf(stderr,
-			"segv_handler: Recursive no mapping fault (stack overflow?)\n");
-		exit(-1);
-	    }
-	}else if(SEGV_CODE(code)==SEGV_OBJERR){
-	    extern int errno;
-	    errno=SEGV_ERRNO(code);
-	    perror("segv_handler: Object error");
-	}
-
-	interrupt_handle_now(sig,code,context);
-
-	if(code==SEGV_NOMAP)
-	    nomap_count--;
-    }
-}
-
-void os_install_interrupt_handlers()
-{
-    interrupt_install_low_level_handler(SIGSEGV,segv_handler);
-}
diff --git a/ldb/sunos-os.h b/ldb/sunos-os.h
deleted file mode 100644
index 85992579bfa93163c8befaa8d9bbea78b1446eb2..0000000000000000000000000000000000000000
--- a/ldb/sunos-os.h
+++ /dev/null
@@ -1,13 +0,0 @@
-#include <sys/types.h>
-#include <sys/mman.h>
-
-typedef caddr_t os_vm_address_t;
-typedef long os_vm_size_t;
-typedef off_t os_vm_offset_t;
-typedef int os_vm_prot_t;
-
-#define OS_VM_PROT_READ PROT_READ
-#define OS_VM_PROT_WRITE PROT_WRITE
-#define OS_VM_PROT_EXECUTE PROT_EXEC
-
-#define OS_VM_DEFAULT_PAGESIZE	8192
diff --git a/ldb/test.c b/ldb/test.c
deleted file mode 100644
index 791003ea58bfe1137dee5759bea5bae812b47efa..0000000000000000000000000000000000000000
--- a/ldb/test.c
+++ /dev/null
@@ -1,264 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/test.c,v 1.11 1991/02/16 01:01:36 wlott Exp $ */
-/* Extra random routines for testing stuff. */
-
-#include <signal.h>
-#ifdef mips
-#include <mips/cpu.h>
-#endif
-
-#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"
-};
-
-static char *errors[] = ERRORS;
-
-#ifdef mips
-#define any_reg_sc 16
-#define descriptor_reg_sc 17
-#define base_char_reg_sc 18
-#define sap_reg_sc 19
-#define signed_reg_sc 20
-#define unsigned_reg_sc 21
-#define non_descr_reg_sc 22
-#define interior_reg_sc 23
-#define single_float_reg_sc 24
-#define double_float_reg_sc 25
-#endif
-
-#ifdef sparc
-#define any_reg_sc 11
-#define descriptor_reg_sc 12
-#define base_char_reg_sc 13
-#define sap_reg_sc 14
-#define signed_reg_sc 15
-#define unsigned_reg_sc 16
-#define non_descr_reg_sc 17
-#define interior_reg_sc 18
-#define single_float_reg_sc 19
-#define double_float_reg_sc 20
-#endif
-
-#ifdef ibmrt
-#define any_reg_sc 10
-#define descriptor_reg_sc 11
-#define base_char_reg_sc 12
-#define sap_reg_sc 13
-#define signed_reg_sc 14
-#define unsigned_reg_sc 15
-#define non_descr_reg_sc 16
-#define word_pointer_reg_sc 17
-#define interior_reg_sc 18
-#define single_68881_reg_sc 19
-#define double_68881_reg_sc 20
-#define single_fpa_reg_sc 21
-#define double_fpa_reg_sc 22
-#define single_afpa_reg_sc 23
-#define double_afpa_reg_sc 24
-#endif
-
-signal_handler(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-    int mask;
-    unsigned long *ptr, bad_inst;
-    unsigned char *cptr;
-    int len, scoffset, sc, offset, ch;
-
-    printf("Hit with %s, code = %d, context = 0x%x\n", signames[signal], code, context);
-
-#ifdef mips
-    if (context->sc_cause & CAUSE_BD)
-        ptr = (unsigned long *)(context->sc_pc + 4);
-    else
-        ptr = (unsigned long *)(context->sc_pc);
-#else
-    ptr = (unsigned long *)(context->sc_pc);
-#endif
-
-    bad_inst = *ptr;
-
-#ifdef mips
-    if ((bad_inst >> 26) == 0 && (bad_inst & 0x3f) == 0xd) {
-        /* It was a break. */
-        switch ((bad_inst >> 16) & 0x3ff) {
-#if 0
-        }
-    }
-#endif
-#endif
-#ifdef sparc
-    if ((bad_inst & 0xc1c00000) == 0) {
-        switch (bad_inst & 0x3fffff) {
-#if 0
-        }
-    }
-#endif
-#endif
-#ifdef ibmrt
-    if ((bad_inst & 0xffff0000) == 0xcc700000) {
-	switch (bad_inst & 0xffff) {
-#if 0
-	}
-    }
-#endif
-#endif
-#if !defined(mips) && !defined(sparc) && !defined(ibmrt)
-    if (0) {
-	switch (0) {
-#endif
-            case trap_Halt:
-                printf("%primitive halt called; the party is over.\n");
-                break;
-
-            case trap_PendingInterrupt:
-                printf("Pending interrupt trap? This should not happen.\n");
-                break;
-
-            case trap_Error:
-            case trap_Cerror:
-                cptr = (unsigned char *)(ptr+1);
-                if (*cptr == 0xff)
-                    cptr++;
-
-                len = *cptr++;
-                printf("Error: %s\n", errors[*cptr++]);
-                len--;
-                while (len > 0) {
-                    scoffset = *cptr++;
-                    len--;
-                    if (scoffset == 253) {
-                        scoffset = *cptr++;
-                        len--;
-                    }
-                    else if (scoffset == 254) {
-                        scoffset = cptr[0] + cptr[1]*256;
-                        cptr += 2;
-                        len -= 2;
-                    }
-                    else if (scoffset == 255) {
-                        scoffset = cptr[0] + (cptr[1]<<8) +
-                            (cptr[2]<<16) + (cptr[3]<<24);
-                            cptr += 4;
-                        len -= 4;
-                    }
-                    sc = scoffset & 0x1f;
-                    offset = scoffset >> 5;
-
-                    printf("    SC: %d, Offset: %d", sc, offset);
-                    switch (sc) {
-                      case any_reg_sc:
-                      case descriptor_reg_sc:
-                        putchar('\t');
-                        brief_print(context->sc_regs[offset]);
-                        break;
-                      case base_char_reg_sc:
-                        ch = context->sc_regs[offset];
-                        switch (ch) {
-                          case '\n': printf("\t'\\n'\n"); break;
-                          case '\b': printf("\t'\\b'\n"); break;
-                          case '\t': printf("\t'\\t'\n"); break;
-                          case '\r': printf("\t'\\r'\n"); break;
-                          default:
-                            if (ch < 32 || ch > 127)
-                                printf("\\%03o", ch);
-                            else
-                                printf("\t'%c'\n", ch);
-                            break;
-                        }
-                        break;
-                      case sap_reg_sc:
-#ifdef ibmrt
-		      case word_pointer_reg_sc:
-#endif
-                        printf("\t0x%08x\n", context->sc_regs[offset]);
-                        break;
-                      case signed_reg_sc:
-                        printf("\t%ld\n", context->sc_regs[offset]);
-                        break;
-                      case unsigned_reg_sc:
-                        printf("\t%lu\n", context->sc_regs[offset]);
-                        break;
-                      case non_descr_reg_sc:
-                      case interior_reg_sc:
-                        printf("\t???\n");
-                        break;
-#ifndef ibmrt
-                      case single_float_reg_sc:
-                        printf("\t%g\n",
-                               *(float *)&context->sc_fpregs[offset]);
-                        break;
-                      case double_float_reg_sc:
-                        printf("\t%g\n",
-                               *(double *)&context->sc_fpregs[offset]);
-                        break;
-#endif
-                      default:
-                        printf("\t???\n");
-                        break;
-                    }
-                }
-                if (code == trap_Cerror) {
-                    printf("Hit a break.  Use ``exit'' to continue.\n");
-#ifdef mips
-                    if (context->sc_cause & CAUSE_BD)
-                        emulate_branch(context, *(unsigned long *)context->sc_pc);
-                    else
-                        context->sc_pc += 4;
-#endif
-#ifdef sparc
-                    context->sc_pc = context->sc_npc;
-                    context->sc_npc = context->sc_npc + 4;
-#endif
-                }
-                break;
-
-            default:
-                printf("Unknown trap type.\n");
-                break;
-        }
-    }
-
-    mask = sigsetmask(0);
-
-    ldb_monitor();
-
-    sigsetmask(mask);
-}
-
-
-
-test_init()
-{
-    install_handler(SIGINT, signal_handler);
-#if defined(mips)||defined(ibmrt)
-    install_handler(SIGTRAP, signal_handler);
-#endif
-#ifdef sparc
-    install_handler(SIGILL, signal_handler);
-#endif
-}
-
-
-#ifdef mips
-cacheflush()
-{
-    /* This is supposed to be defined, but is not. */
-}
-#endif
-
-lispobj debug_print(string)
-lispobj string;
-{
-    printf("%s\n", ((struct vector *)PTR(string))->data);
-
-    return NIL;
-}
diff --git a/ldb/undefineds.src b/ldb/undefineds.src
deleted file mode 100644
index 72a3abea434d08108b7b20c13d361a272e687fc2..0000000000000000000000000000000000000000
--- a/ldb/undefineds.src
+++ /dev/null
@@ -1,163 +0,0 @@
-/* Routines that must be linked into the core for lisp to work. */
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/undefineds.src,v 1.4 1991/09/13 20:43:00 wlott Exp $ */
-
-#ifdef sun
-#ifndef MACH
-#define SUNOS
-#endif
-#endif
-
-/* Pick up all the syscalls. */
-accept
-access
-acct
-adjtime
-bind
-brk
-chdir
-chmod
-chown
-chroot
-close
-connect
-creat
-dup
-dup2
-execve
-exit
-fchmod
-fchown
-fcntl
-flock
-fork
-fstat
-fsync
-ftruncate
-getdtablesize
-getegid
-geteuid
-getgid
-getgroups
-gethostid
-gethostname
-getitimer
-getpagesize
-getpeername
-getpgrp
-getpid
-getppid
-getpriority
-getrlimit
-getrusage
-getsockname
-getsockopt
-gettimeofday
-getuid
-ioctl
-kill
-killpg
-link
-listen
-lseek
-lstat
-mkdir
-mknod
-mount
-open
-pipe
-profil
-ptrace
-#ifndef SUNOS
-quota
-#endif
-read
-readlink
-readv
-reboot
-recv
-recvfrom
-recvmsg
-rename
-rmdir
-sbrk
-select
-send
-sendmsg
-sendto
-setgroups
-#ifndef SUNOS
-sethostid
-#endif
-sethostname
-setitimer
-setpgrp
-setpriority
-#ifndef SUNOS
-setquota
-#endif
-setregid
-setreuid
-setrlimit
-setsockopt
-settimeofday
-shutdown
-sigblock
-sigpause
-#ifndef ibmrt
-sigreturn
-#endif
-sigsetmask
-sigstack
-sigvec
-socket
-socketpair
-stat
-swapon
-symlink
-sync
-syscall
-truncate
-umask
-#ifndef SUNOS
-umount
-#endif
-unlink
-utimes
-vfork
-vhangup
-wait
-wait3
-write
-writev
-
-/* Math routines. */
-cos
-sin
-tan
-acos
-asin
-atan
-atan2
-sinh
-cosh
-tanh
-asinh
-acosh
-atanh
-exp
-expm1
-log
-log10
-log1p
-pow
-cbrt
-sqrt
-hypot
-
-/* Network support. */
-gethostbyname
-gethostbyaddr
-
-/* Other random things. */
-getwd
-ttyname
diff --git a/ldb/validate.c b/ldb/validate.c
deleted file mode 100644
index 15988c427b843c130eef580523df05a505cd0a4f..0000000000000000000000000000000000000000
--- a/ldb/validate.c
+++ /dev/null
@@ -1,63 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/validate.c,v 1.6 1991/09/13 20:42:24 wlott Exp $
- *
- * Memory Validation
- */
-
-#include <stdio.h>
-#include "ldb.h"
-#include "lisp.h"
-#include "os.h"
-#include "globals.h"
-#include "validate.h"
-
-static void ensure_space(start,size)
-lispobj *start;
-unsigned long size;
-{
-    if(os_validate((os_vm_address_t)start,(os_vm_size_t)size)==NULL){
-	fprintf(stderr,
-		"ensure_space: Failed to validate %ld bytes at 0x%08x\n",
-		size,
-		start);
-	exit(1);
-    }
-}
-
-validate()
-{
-#ifdef PRINTNOISE
-	printf("Validating memory ...");
-	fflush(stdout);
-#endif
-
-	/* Read-Only Space */
-	read_only_space = (lispobj *) READ_ONLY_SPACE_START;
-	ensure_space(read_only_space, READ_ONLY_SPACE_SIZE);
-
-	/* Static Space */
-	static_space = (lispobj *) STATIC_SPACE_START;
-	ensure_space(static_space, STATIC_SPACE_SIZE);
-
-	/* Dynamic-0 Space */
-	dynamic_0_space = (lispobj *) DYNAMIC_0_SPACE_START;
-	ensure_space(dynamic_0_space, DYNAMIC_SPACE_SIZE);
-
-	current_dynamic_space = dynamic_0_space;
-
-	/* Dynamic-1 Space */
-	dynamic_1_space = (lispobj *) DYNAMIC_1_SPACE_START;
-	ensure_space(dynamic_1_space, DYNAMIC_SPACE_SIZE);
-
-	/* Control Stack */
-	control_stack = (lispobj *) CONTROL_STACK_START;
-	ensure_space(control_stack, CONTROL_STACK_SIZE);
-
-	/* Binding Stack */
-	binding_stack = (lispobj *) BINDING_STACK_START;
-	ensure_space(binding_stack, BINDING_STACK_SIZE);
-
-#ifdef PRINTNOISE
-	printf(" done.\n");
-#endif
-}
diff --git a/ldb/validate.h b/ldb/validate.h
deleted file mode 100644
index 03a6a500a0920c6c455f72268b9f57be481f592d..0000000000000000000000000000000000000000
--- a/ldb/validate.h
+++ /dev/null
@@ -1,49 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/validate.h,v 1.9 1992/12/17 13:03:13 wlott Exp $ */
-
-#if !defined(_INCLUDE_VALIDATE_H_)
-#define _INCLUDE_VALIDATE_H_
-
-#ifdef sparc
-
-#define READ_ONLY_SPACE_START   (0x00200000)
-#define READ_ONLY_SPACE_SIZE    (0x0bdfe000)
-
-#define STATIC_SPACE_START	(0x0c000000)
-#define STATIC_SPACE_SIZE	(0x03ffe000)
-
-#define DYNAMIC_0_SPACE_START	(0x10000000)
-#define DYNAMIC_1_SPACE_START	(0x18000000)
-#define DYNAMIC_SPACE_SIZE	(0x07ffe000)
-
-#define CONTROL_STACK_START	(0x00100000)
-#define CONTROL_STACK_SIZE	(0x0007e000)
-
-#define BINDING_STACK_START	(0x00180000)
-#define BINDING_STACK_SIZE	(0x0007e000)
-
-#else sparc
-
-#ifdef ibmrt
-#define READ_ONLY_SPACE_START	(0x00100000)
-#define READ_ONLY_SPACE_SIZE    (0x04F00000)
-#else
-#define READ_ONLY_SPACE_START   (0x01000000)
-#define READ_ONLY_SPACE_SIZE    (0x04000000)
-#endif
-
-#define STATIC_SPACE_START	(0x05000000)
-#define STATIC_SPACE_SIZE	(0x02000000)
-
-#define DYNAMIC_0_SPACE_START	(0x07000000)
-#define DYNAMIC_1_SPACE_START	(0x0b000000)
-#define DYNAMIC_SPACE_SIZE	(0x04000000)
-
-#define CONTROL_STACK_START	(0x50000000)
-#define CONTROL_STACK_SIZE	(0x00100000)
-
-#define BINDING_STACK_START	(0x60000000)
-#define BINDING_STACK_SIZE	(0x00100000)
-
-#endif sparc
-
-#endif
diff --git a/ldb/vars.c b/ldb/vars.c
deleted file mode 100644
index b17a7a6e13e53d1d2a3a885a6e7872e80436b0c9..0000000000000000000000000000000000000000
--- a/ldb/vars.c
+++ /dev/null
@@ -1,185 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/vars.c,v 1.2 1992/03/24 04:25:09 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;
-    var->update_fn = NULL;
-
-    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/lisp/Config.parisc_mach b/lisp/Config.parisc_mach
deleted file mode 100644
index 7aa7fee2ad7b4c5d32b56e7eb3ab5d6db557f0be..0000000000000000000000000000000000000000
--- a/lisp/Config.parisc_mach
+++ /dev/null
@@ -1,16 +0,0 @@
-CPPFLAGS = -Dparisc -Dhpux -DMACH \
-	-I. -I/usr/misc/.X11/include -I/usr/mach/include -Ihacks
-LINK.o = /usr/src/mach/bin/cc $(LDFLAGS) $(TARGET_ARCH)
-CC = /usr/src/mach/bin/cc
-NM = hacks/my-nm
-CFLAGS = -g
-ASFLAGS = -g
-UNDEFSYMPATTERN=-u &
-ASSEM_SRC = hppa-assem.S
-ARCH_SRC = hppa-arch.c
-OS_SRC = mach-os.c
-OS_LINK_FLAGS=
-OS_LIBS=-lmach -lthreads
-
-%.o: %.S
-	$(PREPROCESS.S) $< | as -o $@
diff --git a/lisp/Config.pmax_mach b/lisp/Config.pmax_mach
deleted file mode 100644
index 4bf907f48a4cfc08a64dbaaa937b471f0e738405..0000000000000000000000000000000000000000
--- a/lisp/Config.pmax_mach
+++ /dev/null
@@ -1,12 +0,0 @@
-CPPFLAGS = -I. -I/usr/misc/.X11/include
-CC = gcc # -Wall -Wstrict-prototypes -Wmissing-prototypes
-CPP = /usr/cs/lib/cpp
-CFLAGS = -g
-ASFLAGS = -g
-NM = nm -gp
-UNDEFSYMPATTERN=-Xlinker -u -Xlinker &
-ASSEM_SRC = mips-assem.S
-ARCH_SRC = mips-arch.c
-OS_SRC = mach-os.c
-OS_LINK_FLAGS=
-OS_LIBS=-lmach
diff --git a/lisp/Config.sun4_mach b/lisp/Config.sun4_mach
deleted file mode 100644
index 4538db68c5870f1690e512dd80e04c65a0d29ddb..0000000000000000000000000000000000000000
--- a/lisp/Config.sun4_mach
+++ /dev/null
@@ -1,11 +0,0 @@
-CPPFLAGS = -I. -I/usr/misc/.X11/include
-CC = gcc # -Wall -Wstrict-prototypes -Wmissing-prototypes
-CPP = /usr/cs/lib/cpp
-CFLAGS = -g
-ASFLAGS = -g
-NM = nm -gp
-ASSEM_SRC = sparc-assem.S
-ARCH_SRC = sparc-arch.c
-OS_SRC = mach-os.c
-OS_LINK_FLAGS=
-OS_LIBS=-lmach
diff --git a/lisp/Config.sun4c_41 b/lisp/Config.sun4c_41
deleted file mode 100644
index 60e5f09890285c7a308451b9f5f41b8af4cda927..0000000000000000000000000000000000000000
--- a/lisp/Config.sun4c_41
+++ /dev/null
@@ -1,11 +0,0 @@
-CPPFLAGS = -I. -I/usr/misc/.X11/include -DSUNOS
-CC = gcc # -Wall -Wstrict-prototypes -Wmissing-prototypes
-CPP = /lib/cpp
-CFLAGS = -g
-ASFLAGS = -g
-NM = nm -gp
-ASSEM_SRC = sparc-assem.S
-ARCH_SRC = sparc-arch.c
-OS_SRC = sunos-os.c
-OS_LINK_FLAGS=-Bstatic
-OS_LIBS=
diff --git a/lisp/GNUmakefile b/lisp/GNUmakefile
deleted file mode 100644
index 84b8de6dfb988b811bee09a5c209a4c6b3f62621..0000000000000000000000000000000000000000
--- a/lisp/GNUmakefile
+++ /dev/null
@@ -1,52 +0,0 @@
-# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/GNUmakefile,v 1.4 1992/09/08 20:16:06 wlott Exp $
-
-all: lisp.nm
-
-CC = gcc
-
-include Config
-
-SRCS = lisp.c coreparse.c alloc.c monitor.c print.c interr.c os-common.c \
-	vars.c parse.c interrupt.c search.c validate.c gc.c globals.c \
-	dynbind.c breakpoint.c regnames.c backtrace.c save.c purify.c \
-	socket.c undefineds.c ${ARCH_SRC} ${ASSEM_SRC} ${OS_SRC}
-
-OBJS = $(patsubst %.c,%.o,$(patsubst %.S,%.o,$(SRCS)))
-
-### Don't look in RCS for the files, because we might not want the latest.
-%: RCS/%,v
-
-lisp.nm: lisp
-	echo -n 'Map file for lisp version ' > ,lisp.nm
-	cat version >> ,lisp.nm
-	$(NM) lisp >> ,lisp.nm
-	mv ,lisp.nm lisp.nm
-
-lisp: ${OBJS} version
-	echo -n '1 + ' | cat - version | bc > ,version
-	mv ,version version
-	$(CC) ${CFLAGS} -DVERSION=`cat version` -c version.c
-	$(CC) $(CFLAGS) ${OS_LINK_FLAGS} -o ,lisp \
-		${OBJS} version.o \
-		${OS_LIBS} -lm
-	mv -f ,lisp lisp
-
-version:
-	echo 0 > version
-
-### Socket.c needs to be compiled with UNIXCONN defined.
-socket.o: socket.c
-	$(COMPILE.c) -DUNIXCONN socket.c
-
-internals.h:
-	@echo "You must run genesis to create internals.h!"
-	@false
-
-clean:
-	rm -f Depends *.o lisp lisp.nm core
-
-depend:
-	$(CC) -MM -E ${CFLAGS} ${CPPFLAGS} ${SRCS} > ,depends
-	mv ,depends Depends
-
-include Depends
diff --git a/lisp/alloc.c b/lisp/alloc.c
deleted file mode 100644
index 658541e1df11ac9eb7439e740ab1fd6614547cf5..0000000000000000000000000000000000000000
--- a/lisp/alloc.c
+++ /dev/null
@@ -1,116 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/alloc.c,v 1.1 1992/07/28 20:14:02 wlott Exp $ */
-
-#include "lisp.h"
-#include "internals.h"
-#include "alloc.h"
-#include "globals.h"
-#include "gc.h"
-
-#ifdef ibmrt
-#define GET_FREE_POINTER() ((lispobj *)SymbolValue(ALLOCATION_POINTER))
-#define SET_FREE_POINTER(new_value) \
-    (SetSymbolValue(ALLOCATION_POINTER,(lispobj)(new_value)))
-#define GET_GC_TRIGGER() ((lispobj *)SymbolValue(INTERNAL_GC_TRIGGER))
-#define SET_GC_TRIGGER(new_value) \
-    (SetSymbolValue(INTERNAL_GC_TRIGGER,(lispobj)(new_value)))
-#else
-#define GET_FREE_POINTER() current_dynamic_space_free_pointer
-#define SET_FREE_POINTER(new_value) \
-    (current_dynamic_space_free_pointer = (new_value))
-#define GET_GC_TRIGGER() current_auto_gc_trigger
-#define SET_GC_TRIGGER(new_value) \
-    clear_auto_gc_trigger(); set_auto_gc_trigger(new_value);
-#endif
-
-
-
-/****************************************************************
-Allocation Routines.
-****************************************************************/
-
-static lispobj *alloc(int bytes)
-{
-    lispobj *result;
-
-    /* Round to dual word boundry. */
-    bytes = (bytes + lowtag_Mask) & ~lowtag_Mask;
-
-    result = GET_FREE_POINTER();
-    SET_FREE_POINTER(result + (bytes / sizeof(lispobj)));
-
-    if (GET_GC_TRIGGER() && GET_FREE_POINTER() > GET_GC_TRIGGER()) {
-	SET_GC_TRIGGER((char *)GET_FREE_POINTER()
-		       - (char *)current_dynamic_space);
-    }
-
-    return result;
-}
-
-static lispobj *alloc_unboxed(int type, int words)
-{
-    lispobj *result;
-
-    result = alloc((1 + words) * sizeof(lispobj));
-
-    *result = (lispobj) (words << type_Bits) | type;
-
-    return result;
-}
-
-static lispobj alloc_vector(int type, int length, int size)
-{
-    struct vector *result;
-
-    result = (struct vector *)alloc((2 + (length*size + 31) / 32) * sizeof(lispobj));
-
-    result->header = type;
-    result->length = make_fixnum(length);
-
-    return ((lispobj)result)|type_OtherPointer;
-}
-
-lispobj alloc_cons(lispobj car, lispobj cdr)
-{
-    struct cons *ptr = (struct cons *)alloc(sizeof(struct cons));
-
-    ptr->car = car;
-    ptr->cdr = cdr;
-
-    return (lispobj)ptr | type_ListPointer;
-}
-
-lispobj alloc_number(long n)
-{
-    struct bignum *ptr;
-
-    if (-0x20000000 < n && n < 0x20000000)
-        return make_fixnum(n);
-    else {
-        ptr = (struct bignum *)alloc_unboxed(type_Bignum, 1);
-
-        ptr->digits[0] = n;
-
-	return (lispobj) ptr | type_OtherPointer;
-    }
-}
-
-lispobj alloc_string(char *str)
-{
-    int len = strlen(str);
-    lispobj result = alloc_vector(type_SimpleString, len+1, 8);
-    struct vector *vec = (struct vector *)PTR(result);
-
-    vec->length = make_fixnum(len);
-    strcpy((char *)vec->data, str);
-
-    return result;
-}
-
-lispobj alloc_sap(void *ptr)
-{
-    struct sap *sap = (struct sap *)alloc_unboxed(type_Sap, 1);
-
-    sap->pointer = ptr;
-
-    return (lispobj) sap | type_OtherPointer;
-}
diff --git a/lisp/alloc.h b/lisp/alloc.h
deleted file mode 100644
index e4e698271785fd44466eb999cee3eaa97ea9aa9b..0000000000000000000000000000000000000000
--- a/lisp/alloc.h
+++ /dev/null
@@ -1,13 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/alloc.h,v 1.1 1992/07/28 20:14:04 wlott Exp $ */
-
-#ifndef _ALLOC_H_
-#define _ALLOC_H_
-
-#include "lisp.h"
-
-extern lispobj alloc_cons(lispobj car, lispobj cdr);
-extern lispobj alloc_number(long n);
-extern lispobj alloc_string(char *str);
-extern lispobj alloc_sap(void *ptr);
-
-#endif _ALLOC_H_
diff --git a/lisp/arch.h b/lisp/arch.h
deleted file mode 100644
index 8a606d429d15b4877f3cec61438faab4103f8684..0000000000000000000000000000000000000000
--- a/lisp/arch.h
+++ /dev/null
@@ -1,25 +0,0 @@
-#ifndef __ARCH_H__
-#define __ARCH_H__
-
-#include "os.h"
-#include "signal.h"
-
-extern char *arch_init(void);
-extern void arch_skip_instruction(struct sigcontext *scp);
-extern boolean arch_pseudo_atomic_atomic(struct sigcontext *scp);
-extern void arch_set_pseudo_atomic_interrupted(struct sigcontext *scp);
-extern os_vm_address_t arch_get_bad_addr(int signal, int code,
-					 struct sigcontext *scp);
-extern unsigned char *arch_internal_error_arguments(struct sigcontext *scp);
-extern unsigned long arch_install_breakpoint(void *pc);
-extern void arch_remove_breakpoint(void *pc, unsigned long orig_inst);
-extern void arch_install_interrupt_handlers(void);
-extern void arch_do_displaced_inst(struct sigcontext *scp,
-				   unsigned long orig_inst);
-extern lispobj funcall0(lispobj function);
-extern lispobj funcall1(lispobj function, lispobj arg0);
-extern lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1);
-extern lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1,
-			lispobj arg2);
-
-#endif /* __ARCH_H__ */
diff --git a/lisp/backtrace.c b/lisp/backtrace.c
deleted file mode 100644
index 7d3e24086d30e0f33a18bbb188ba1a5601510527..0000000000000000000000000000000000000000
--- a/lisp/backtrace.c
+++ /dev/null
@@ -1,230 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/backtrace.c,v 1.2 1993/01/10 17:22:33 wlott Exp $
- *
- * Simple backtrace facility.  More or less from Rob's lisp version.
- */
-
-#include <stdio.h>
-#include <signal.h>
-#include "lisp.h"
-#include "internals.h"
-#include "globals.h"
-#include "interrupt.h"
-#include "lispregs.h"
-
-#ifndef i386
-
-/* Sigh ... I know what the call frame looks like and it had
-   better not change. */
-
-struct call_frame {
-	struct call_frame *old_cont;
-	lispobj saved_lra;
-        lispobj code;
-	lispobj other_state[5];
-};
-
-struct call_info {
-    struct call_frame *frame;
-    int interrupted;
-    struct code *code;
-    lispobj lra;
-    int pc; /* Note: this is the trace file offset, not the actual pc. */
-};
-
-#define HEADER_LENGTH(header) ((header)>>8)
-
-static int previous_info(struct call_info *info);
-
-static struct code *
-code_pointer(lispobj object)
-{
-    lispobj *headerp, header;
-    int type, len;
-
-    headerp = (lispobj *) PTR(object);
-    header = *headerp;
-    type = TypeOf(header);
-
-    switch (type) {
-        case type_CodeHeader:
-            break;
-        case type_ReturnPcHeader:
-        case type_FunctionHeader:
-        case type_ClosureFunctionHeader:
-            len = HEADER_LENGTH(header);
-            if (len == 0)
-                headerp = NULL;
-            else
-                headerp -= len;
-            break;
-        default:
-            headerp = NULL;
-    }
-
-    return (struct code *) headerp;
-}
-
-static boolean
-cs_valid_pointer_p(struct call_frame *pointer)
-{
-	return (((char *) control_stack <= (char *) pointer) &&
-		((char *) pointer < (char *) current_control_stack_pointer));
-}
-
-static void
-info_from_lisp_state(struct call_info *info)
-{
-    info->frame = (struct call_frame *)current_control_frame_pointer;
-    info->interrupted = 0;
-    info->code = NULL;
-    info->lra = 0;
-    info->pc = 0;
-
-    previous_info(info);
-}
-
-static void
-info_from_sigcontext(struct call_info *info, struct sigcontext *csp)
-{
-    unsigned long pc;
-
-    info->interrupted = 1;
-    if (LowtagOf(SC_REG(csp, reg_CODE)) == type_FunctionPointer) {
-        /* We tried to call a function, but crapped out before $CODE could be fixed up.  Probably an undefined function. */
-        info->frame = (struct call_frame *)SC_REG(csp, reg_OCFP);
-        info->lra = (lispobj)SC_REG(csp, reg_LRA);
-        info->code = code_pointer(info->lra);
-        pc = (unsigned long)PTR(info->lra);
-    }
-    else {
-        info->frame = (struct call_frame *)SC_REG(csp, reg_CFP);
-        info->code = code_pointer(SC_REG(csp, reg_CODE));
-        info->lra = NIL;
-        pc = SC_PC(csp);
-    }
-    if (info->code != NULL)
-        info->pc = pc - (unsigned long) info->code -
-            (HEADER_LENGTH(info->code->header) * sizeof(lispobj));
-    else
-        info->pc = 0;
-}
-
-static int
-previous_info(struct call_info *info)
-{
-    struct call_frame *this_frame;
-    int free;
-    struct sigcontext *csp;
-
-    if (!cs_valid_pointer_p(info->frame)) {
-        printf("Bogus callee value (0x%08x).\n", (unsigned long)info->frame);
-        return 0;
-    }
-
-    this_frame = info->frame;
-    info->lra = this_frame->saved_lra;
-    info->frame = this_frame->old_cont;
-    info->interrupted = 0;
-
-    if (info->frame == NULL || info->frame == this_frame)
-        return 0;
-
-    if (info->lra == NIL) {
-        /* We were interrupted.  Find the correct sigcontext. */
-        free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
-        while (free-- > 0) {
-            csp = lisp_interrupt_contexts[free];
-            if ((struct call_frame *)(SC_REG(csp, reg_CFP)) == info->frame) {
-                info_from_sigcontext(info, csp);
-                break;
-            }
-        }
-    }
-    else {
-        info->code = code_pointer(info->lra);
-        if (info->code != NULL)
-            info->pc = (unsigned long)PTR(info->lra) -
-                (unsigned long)info->code -
-                (HEADER_LENGTH(info->code->header) * sizeof(lispobj));
-        else
-            info->pc = 0;
-    }
-
-    return 1;
-}
-
-void
-backtrace(int nframes)
-{
-    struct call_info info;
-	
-    info_from_lisp_state(&info);
-
-    do {
-        printf("<Frame 0x%08x%s, ", (unsigned long) info.frame,
-                info.interrupted ? " [interrupted]" : "");
-        
-        if (info.code != (struct code *) 0) {
-            lispobj function;
-
-            printf("CODE: 0x%08X, ", (unsigned long) info.code | type_OtherPointer);
-
-            function = info.code->entry_points;
-            while (function != NIL) {
-                struct function *header;
-                lispobj name;
-
-                header = (struct function *) PTR(function);
-                name = header->name;
-
-                if (LowtagOf(name) == type_OtherPointer) {
-                    lispobj *object;
-
-                    object = (lispobj *) PTR(name);
-
-                    if (TypeOf(*object) == type_SymbolHeader) {
-                        struct symbol *symbol;
-
-                        symbol = (struct symbol *) object;
-                        object = (lispobj *) PTR(symbol->name);
-                    }
-                    if (TypeOf(*object) == type_SimpleString) {
-                        struct vector *string;
-
-                        string = (struct vector *) object;
-                        printf("%s, ", (char *) string->data);
-                    } else
-                        printf("(Not simple string???), ");
-                } else
-                    printf("(Not other pointer???), ");
-
-
-                function = header->next;
-            }
-        }
-        else
-            printf("CODE: ???, ");
-
-        if (info.lra != NIL)
-            printf("LRA: 0x%08x, ", (unsigned long)info.lra);
-        else
-            printf("<no LRA>, ");
-
-        if (info.pc)
-            printf("PC: 0x%x>\n", info.pc);
-        else
-            printf("PC: ???>\n");
-
-    } while (--nframes > 0 && previous_info(&info));
-}
-
-#else
-
-void
-backtrace(nframes)
-int nframes;
-{
-    printf("Can't backtrace on the x86.\n");
-}
-
-#endif
diff --git a/lisp/breakpoint.c b/lisp/breakpoint.c
deleted file mode 100644
index d57d80d9825cb2e2e1b3d2d8ce093ebd43ad90ea..0000000000000000000000000000000000000000
--- a/lisp/breakpoint.c
+++ /dev/null
@@ -1,125 +0,0 @@
-#include <stdio.h>
-#include <signal.h>
-
-#include "lisp.h"
-#include "os.h"
-#include "internals.h"
-#include "arch.h"
-#include "lispregs.h"
-#include "globals.h"
-#include "alloc.h"
-#include "breakpoint.h"
-
-#define REAL_LRA_SLOT 0
-#define KNOWN_RETURN_P_SLOT 1
-#define BOGUS_LRA_CONSTANTS 2
-
-static void *compute_pc(lispobj code_obj, int pc_offset)
-{
-    struct code *code;
-
-    code = (struct code *)PTR(code_obj);
-    return (void *)((char *)code + HeaderValue(code->header)*sizeof(lispobj)
-		    + pc_offset);
-}
-
-unsigned long breakpoint_install(lispobj code_obj, int pc_offset)
-{
-    return arch_install_breakpoint(compute_pc(code_obj, pc_offset));
-}
-
-void breakpoint_remove(lispobj code_obj, int pc_offset,
-		       unsigned long orig_inst)
-{
-    arch_remove_breakpoint(compute_pc(code_obj, pc_offset), orig_inst);
-}
-
-void breakpoint_do_displaced_inst(struct sigcontext *scp,
-				  unsigned long orig_inst)
-{
-    undo_fake_foreign_function_call(scp);
-    arch_do_displaced_inst(scp, orig_inst);
-}
-
-static lispobj find_code(struct sigcontext *scp)
-{
-#ifdef reg_CODE
-    lispobj code = SC_REG(scp, reg_CODE), header;
-
-    if (LowtagOf(code) != type_OtherPointer)
-	return NIL;
-
-    header = *(lispobj *)(code-type_OtherPointer);
-
-    if (TypeOf(header) == type_CodeHeader)
-	return code;
-    else
-	return code - HeaderValue(header)*sizeof(lispobj);
-#else
-    return NIL;
-#endif
-}
-
-static int compute_offset(struct sigcontext *scp, lispobj code)
-{
-    if (code == NIL)
-	return 0;
-    else {
-	unsigned long code_start;
-	struct code *codeptr = (struct code *)PTR(code);
-
-	code_start = (unsigned long)codeptr
-	    + HeaderValue(codeptr->header)*sizeof(lispobj);
-	if (SC_PC(scp) < code_start)
-	    return 0;
-	else {
-	    int offset = SC_PC(scp) - code_start;
-	    if (offset >= codeptr->code_size)
-		return 0;
-	    else
-		return make_fixnum(offset);
-	}
-    }
-}
-
-void handle_breakpoint(int signal, int subcode, struct sigcontext *scp)
-{
-    lispobj code;
-
-    fake_foreign_function_call(scp);
-
-    code = find_code(scp);
-    funcall3(SymbolFunction(HANDLE_BREAKPOINT),
-	     compute_offset(scp, code),
-	     code,
-	     alloc_sap(scp));
-
-    undo_fake_foreign_function_call(scp);
-}
-
-void *handle_function_end_breakpoint(int signal, int subcode,
-				     struct sigcontext *scp)
-{
-    lispobj code, lra;
-    struct code *codeptr;
-
-    fake_foreign_function_call(scp);
-
-    code = find_code(scp);
-    codeptr = (struct code *)PTR(code);
-
-    funcall3(SymbolFunction(HANDLE_BREAKPOINT),
-	     compute_offset(scp, code),
-	     code,
-	     alloc_sap(scp));
-
-    lra = codeptr->constants[REAL_LRA_SLOT];
-#ifdef reg_CODE
-    if (codeptr->constants[KNOWN_RETURN_P_SLOT] == NIL)
-	SC_REG(scp, reg_CODE) = lra;
-#endif
-
-    undo_fake_foreign_function_call(scp);
-
-    return (void *)(lra-type_OtherPointer+sizeof(lispobj));
-}
diff --git a/lisp/breakpoint.h b/lisp/breakpoint.h
deleted file mode 100644
index 8f45fe841811b8538162617113904ab43c349b4d..0000000000000000000000000000000000000000
--- a/lisp/breakpoint.h
+++ /dev/null
@@ -1,17 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/breakpoint.h,v 1.1 1992/07/28 20:14:15 wlott Exp $
- */
-
-#ifndef _BREAKPOINT_H_
-#define _BREAKPOINT_H_
-
-extern unsigned long breakpoint_install(lispobj code_obj, int pc_offset);
-extern void breakpoint_remove(lispobj code_obj, int pc_offset,
-			      unsigned long orig_inst);
-extern void breakpoint_do_displaced_inst(struct sigcontext *scp,
-					 unsigned long orig_inst);
-extern void handle_breakpoint(int signal, int subcode, struct sigcontext *scp);
-extern void *handle_function_end_breakpoint(int signal, int subcode,
-					    struct sigcontext *scp);
-
-#endif
diff --git a/lisp/core.h b/lisp/core.h
deleted file mode 100644
index 1010fd0388644a683d0eda5baf4e52c808442133..0000000000000000000000000000000000000000
--- a/lisp/core.h
+++ /dev/null
@@ -1,45 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/core.h,v 1.1 1992/07/28 20:14:19 wlott Exp $ */
-
-#ifndef _CORE_H_
-#define _CORE_H_
-
-#include "lisp.h"
-#include "lispregs.h"
-
-#define CORE_PAGESIZE OS_VM_DEFAULT_PAGESIZE
-#define CORE_MAGIC (('C' << 24) | ('O' << 16) | ('R' << 8) | 'E')
-#define CORE_END 3840
-#define CORE_NDIRECTORY 3861
-#define CORE_VALIDATE 3845
-#define CORE_VERSION 3860
-#define CORE_MACHINE_STATE 3862
-
-#define DYNAMIC_SPACE_ID (1)
-#define STATIC_SPACE_ID (2)
-#define READ_ONLY_SPACE_ID (3)
-
-struct ndir_entry {
-	long identifier;
-	long nwords;
-	long data_page;
-	long address;
-	long page_count;
-};
-
-struct machine_state {
-    lispobj *csp;
-    lispobj *cfp;
-    long control_stack_page;
-
-#ifdef reg_BSP
-    lispobj *bsp;
-#endif
-    long binding_stack_page;
-
-    char *nsp;
-    long number_stack_page;
-};
-
-extern boolean load_core_file(char *file);
-
-#endif
diff --git a/lisp/coreparse.c b/lisp/coreparse.c
deleted file mode 100644
index ec98103a59f3a4f271fff3180517c0bf1ab524de..0000000000000000000000000000000000000000
--- a/lisp/coreparse.c
+++ /dev/null
@@ -1,140 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/coreparse.c,v 1.1 1992/07/28 20:14:21 wlott Exp $ */
-#include <stdio.h>
-#include <sys/types.h>
-#include <sys/file.h>
-
-#include "os.h"
-#include "lisp.h"
-#include "globals.h"
-#include "core.h"
-#include "save.h"
-
-extern int version;
-
-static void process_directory(int fd, long *ptr, int count)
-{
-	long id, offset, len;
-	lispobj *free_pointer;
-	os_vm_address_t addr;
-	struct ndir_entry *entry;
-
-	entry = (struct ndir_entry *) ptr;
-
-	while (count-- > 0) {
-		id = entry->identifier;
-		offset = CORE_PAGESIZE * (1 + entry->data_page);
-		addr = (os_vm_address_t) (CORE_PAGESIZE * entry->address);
-		free_pointer = (lispobj *) addr + entry->nwords;
-		len = CORE_PAGESIZE * entry->page_count;
-
-		if (len != 0) {
-		    os_vm_address_t real_addr;
-#ifdef PRINTNOISE
-		    printf("Mapping %d bytes at 0x%x.\n", len, addr);
-#endif
-		    real_addr=os_map(fd, offset, addr, len);
-		    if(real_addr!=addr)
-			fprintf(stderr,
-		  "process_directory: file mapped in wrong place! (0x%08x != 0x%08x)\n",
-				real_addr,
-				addr);
-		}
-
-#if 0
-		printf("Space ID = %d, free pointer = 0x%08x.\n", id, free_pointer);
-#endif
-
-		switch (id) {
-		case DYNAMIC_SPACE_ID:
-                    if (addr != (os_vm_address_t)dynamic_0_space && addr != (os_vm_address_t)dynamic_1_space)
-                        printf("Strange ... dynamic space lossage.\n");
-                    current_dynamic_space = (lispobj *)addr;
-#ifdef ibmrt
-		    SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer);
-#else
-                    current_dynamic_space_free_pointer = free_pointer;
-#endif
-                    break;
-		case STATIC_SPACE_ID:
-			static_space = (lispobj *) addr;
-			break;
-		case READ_ONLY_SPACE_ID:
-			/* Don't care about read only space */
-			break;
-		default:
-			printf("Strange space ID: %d; ignored.\n", id);
-			break;
-		}
-		entry++;
-	}
-}
-
-boolean load_core_file(char *file)
-{
-    int fd = open(file, O_RDONLY), count;
-    long header[CORE_PAGESIZE / sizeof(long)], val, len, *ptr;
-    boolean restore_state = FALSE;
-
-    if (fd < 0) {
-	    fprintf(stderr, "Could not open file \"%s\".\n", file);
-	    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 may lose big.\n", version, *ptr);
-                }
-                break;
-
-            case CORE_VALIDATE:
-		fprintf(stderr, "Validation no longer supported; ignored.\n");
-                break;
-
-            case CORE_NDIRECTORY:
-                process_directory(fd, ptr,
-				  (len-2) / (sizeof(struct ndir_entry) / sizeof(long)));
-                break;
-
-            case CORE_MACHINE_STATE:
-                restore_state = TRUE;
-                load(fd, (struct machine_state *)ptr);
-                break;
-
-            default:
-                printf("Unknown core file entry: %d; skipping.\n", val);
-                break;
-        }
-
-        ptr += len - 2;
-    }
-
-    return restore_state;
-}
diff --git a/lisp/dynbind.c b/lisp/dynbind.c
deleted file mode 100644
index 839c1bd7b1cc101ef779c853313af280a8e57c1c..0000000000000000000000000000000000000000
--- a/lisp/dynbind.c
+++ /dev/null
@@ -1,68 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/dynbind.c,v 1.1 1992/07/28 20:14:22 wlott Exp $
- * 
- * Support for dynamic binding from C.
- */
-
-#include "lisp.h"
-#include "internals.h"
-#include "globals.h"
-#include "dynbind.h"
-
-#ifdef ibmrt
-#define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER))
-#define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value))
-#else
-#define GetBSP() ((struct binding *)current_binding_stack_pointer)
-#define SetBSP(value) (current_binding_stack_pointer=(lispobj *)(value))
-#endif
-
-void bind_variable(lispobj symbol, lispobj value)
-{
-	lispobj old_value;
-	struct binding *binding;
-
-	old_value = SymbolValue(symbol);
-	binding = GetBSP();
-	SetBSP(binding+1);
-
-	binding->value = old_value;
-	binding->symbol = symbol;
-	SetSymbolValue(symbol, value);
-}
-
-void unbind(void)
-{
-	struct binding *binding;
-	lispobj symbol;
-	
-	binding = GetBSP() - 1;
-		
-	symbol = binding->symbol;
-
-	SetSymbolValue(symbol, binding->value);
-
-	binding->symbol = 0;
-
-	SetBSP(binding);
-}
-
-void unbind_to_here(lispobj *bsp)
-{
-    struct binding *target = (struct binding *)bsp;
-    struct binding *binding = GetBSP();
-    lispobj symbol;
-
-    while (target < binding) {
-	binding--;
-
-	symbol = binding->symbol;
-
-	if (symbol) {
-	    SetSymbolValue(symbol, binding->value);
-	    binding->symbol = 0;
-	}
-
-    }
-    SetBSP(binding);
-}
diff --git a/lisp/dynbind.h b/lisp/dynbind.h
deleted file mode 100644
index ba7e982690ffbd576b34f5dbeddd908ab9480418..0000000000000000000000000000000000000000
--- a/lisp/dynbind.h
+++ /dev/null
@@ -1,10 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/dynbind.h,v 1.1 1992/07/28 20:14:24 wlott Exp $ */
-
-#ifndef _DYNBIND_H_
-#define _DYNBIND_H_
-
-extern void bind_variable(lispobj symbol, lispobj value);
-extern void unbind(void);
-extern void unbind_to_here(lispobj *bsp);
-
-#endif
diff --git a/lisp/gc.h b/lisp/gc.h
deleted file mode 100644
index a1e83f814d2617d94301398231b3df39d70553dd..0000000000000000000000000000000000000000
--- a/lisp/gc.h
+++ /dev/null
@@ -1,22 +0,0 @@
-/*
- * Header file for GC
- *
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gc.h,v 1.1 1992/07/28 20:14:28 wlott Exp $
- */
-
-#ifndef _GC_H_
-#define _GC_H_
-
-extern void gc_init(void);
-extern void collect_garbage(void);
-
-#ifndef ibmrt
-
-#include "os.h"
-
-extern void set_auto_gc_trigger(os_vm_size_t usage);
-extern void clear_auto_gc_trigger(void);
-
-#endif ibmrt
-
-#endif _GC_H_
diff --git a/lisp/globals.c b/lisp/globals.c
deleted file mode 100644
index a8d9595d55501ae2e085c33d2b71223d0ffe9beb..0000000000000000000000000000000000000000
--- a/lisp/globals.c
+++ /dev/null
@@ -1,53 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/globals.c,v 1.1 1992/07/28 20:14:29 wlott Exp $ */
-
-/* Variables everybody needs to look at or frob on. */
-
-#include <stdio.h>
-
-#include "lisp.h"
-#include "internals.h"
-#include "globals.h"
-
-int foreign_function_call_active;
-
-lispobj *current_control_stack_pointer;
-lispobj *current_control_frame_pointer;
-#ifndef BINDING_STACK_POINTER
-lispobj *current_binding_stack_pointer;
-#endif
-
-lispobj *read_only_space;
-lispobj *static_space;
-lispobj *dynamic_0_space;
-lispobj *dynamic_1_space;
-lispobj *control_stack;
-lispobj *binding_stack;
-
-lispobj *current_dynamic_space;
-#ifndef ALLOCATION_POINTER
-lispobj *current_dynamic_space_free_pointer;
-#endif
-#ifndef INTERNAL_GC_TRIGGER
-lispobj *current_auto_gc_trigger;
-#endif
-
-void globals_init(void)
-{
-    /* Space, stack, and free pointer vars are initialized by
-       validate() and coreparse(). */
-
-#ifndef INTERNAL_GC_TRIGGER
-    /* No GC trigger yet */
-    current_auto_gc_trigger = NULL;
-#endif
-
-    /* Set foreign function call active. */
-    foreign_function_call_active = 1;
-
-    /* Initialize the current lisp state. */
-    current_control_stack_pointer = control_stack;
-    current_control_frame_pointer = (lispobj *)0;
-#ifndef BINDING_STACK_POINTER
-    current_binding_stack_pointer = binding_stack;
-#endif
-}
diff --git a/lisp/globals.h b/lisp/globals.h
deleted file mode 100644
index 3167d57a8d4c700c573ce368424bab74ab8cea6a..0000000000000000000000000000000000000000
--- a/lisp/globals.h
+++ /dev/null
@@ -1,62 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/globals.h,v 1.2 1992/09/08 20:18:32 wlott Exp $ */
-
-#if !defined(_INCLUDE_GLOBALS_H_)
-#define _INCLUDED_GLOBALS_H_
-
-#ifndef LANGUAGE_ASSEMBLY
-
-#include "lisp.h"
-
-extern int foreign_function_call_active;
-
-extern lispobj *current_control_stack_pointer;
-extern lispobj *current_control_frame_pointer;
-#ifndef ibmrt
-extern lispobj *current_binding_stack_pointer;
-#endif
-
-extern lispobj *read_only_space;
-extern lispobj *static_space;
-extern lispobj *dynamic_0_space;
-extern lispobj *dynamic_1_space;
-extern lispobj *control_stack;
-extern lispobj *binding_stack;
-
-extern lispobj *current_dynamic_space;
-#ifndef ibmrt
-extern lispobj *current_dynamic_space_free_pointer;
-extern lispobj *current_auto_gc_trigger;
-#endif
-
-extern void globals_init(void);
-
-#else  LANGUAGE_ASSEMBLY
-
-/* These are needed by ./assem.s */
-
-#ifdef mips
-#define EXTERN(name,bytes) .extern name bytes
-#endif
-#ifdef sparc
-#define EXTERN(name,bytes) .global _ ## name
-#endif
-#ifdef ibmrt
-#define EXTERN(name,bytes) .globl _/**/name
-#endif
-
-EXTERN(foreign_function_call_active, 4)
-
-EXTERN(current_control_stack_pointer, 4)
-EXTERN(current_control_frame_pointer, 4)
-#ifndef ibmrt
-EXTERN(current_binding_stack_pointer, 4)
-EXTERN(current_dynamic_space_free_pointer, 4)
-#endif
-
-#ifdef mips
-EXTERN(current_flags_register, 4)
-#endif
-
-#endif LANGUAGE_ASSEMBLY
-
-#endif _INCLUDED_GLOBALS_H_
diff --git a/lisp/hppa-arch.c b/lisp/hppa-arch.c
deleted file mode 100644
index acccd81161d8577c48ab34d0d5115254ad03f8f2..0000000000000000000000000000000000000000
--- a/lisp/hppa-arch.c
+++ /dev/null
@@ -1,281 +0,0 @@
-#include <stdio.h>
-#include <mach.h>
-#include <machine/trap.h>
-
-#include "lisp.h"
-#include "globals.h"
-#include "validate.h"
-#include "os.h"
-#include "arch.h"
-#include "lispregs.h"
-#include "signal.h"
-#include "internals.h"
-#include "breakpoint.h"
-
-char *arch_init(void)
-{
-    return NULL;
-}
-
-os_vm_address_t arch_get_bad_addr(int signal,
-				  int code,
-				  struct sigcontext *scp)
-{
-    struct hp800_thread_state *state;
-    os_vm_address_t addr;
-
-    state = (struct hp800_thread_state *)(scp->sc_ap);
-
-    if (state == NULL)
-	return NULL;
-
-    /* Check the instruction address first. */
-    addr = scp->sc_pcoqh & ~3;
-    if (addr < 0x1000)
-	return addr;
-
-    /* Otherwise, it must have been a data fault. */
-    return state->cr21;
-}
-
-unsigned char *arch_internal_error_arguments(struct sigcontext *scp)
-{
-    return (unsigned char *)((scp->sc_pcoqh&~0x3)+4);
-}
-
-boolean arch_pseudo_atomic_atomic(struct sigcontext *scp)
-{
-    /* Pseudo-atomic-atomic is implemented by oring 0x4 into ALLOC. */
-
-    if (SC_REG(scp, reg_ALLOC) & 0x4)
-	return TRUE;
-    else
-	return FALSE;
-}
-
-void arch_set_pseudo_atomic_interrupted(struct sigcontext *scp)
-{
-    /* Pseudo-atomic-atomic is implemented by oring 0x1 into ALLOC. */
-
-    SC_REG(scp, reg_ALLOC) |= 1;
-}
-
-void arch_skip_instruction(struct sigcontext *scp)
-{
-    /* Skip the offending instruction */
-    scp->sc_pcoqh = scp->sc_pcoqt;
-    scp->sc_pcoqt += 4;
-}
-
-unsigned long arch_install_breakpoint(void *pc)
-{
-    unsigned long *ulpc = (unsigned long *)pc;
-    unsigned long orig_inst = *ulpc;
-
-    *ulpc = trap_Breakpoint;
-    return orig_inst;
-}
-
-void arch_remove_breakpoint(void *pc, unsigned long orig_inst)
-{
-    unsigned long *ulpc = (unsigned long *)pc;
-
-    *ulpc = orig_inst;
-}
-
-void arch_do_displaced_inst(struct sigcontext *scp, unsigned long orig_inst)
-{
-    /* We set the recovery counter to cover one instruction, put the */
-    /* original instruction back in, and then resume.  We will then trap */
-    /* after executing that one instruction, at which time we can put */
-    /* the breakpoint back in. */
-
-    ((struct hp800_thread_state *)scp->sc_ap)->cr0 = 1;
-    scp->sc_ps |= 0x10;
-    *(unsigned long *)SC_PC(scp) = orig_inst;
-
-    undo_fake_foreign_function_call(scp);
-
-    sigreturn(scp);
-}
-
-static void sigtrap_handler(int signal, int code, struct sigcontext *scp)
-{
-    unsigned long bad_inst;
-
-    sigsetmask(scp->sc_mask);
-
-    printf("sigtrap_handler, pc=0x%08x\n", scp->sc_pcoqh);
-
-    bad_inst = *(unsigned long *)(scp->sc_pcoqh & ~3);
-
-    if (bad_inst & 0xfc001fe0)
-	interrupt_handle_now(signal, code, scp);
-    else {
-	int im5 = bad_inst & 0x1f;
-
-	switch (im5) {
-	  case trap_Halt:
-	    fake_foreign_function_call(scp);
-	    lose("%%primitive halt called; the party is over.\n");
-
-	  case trap_PendingInterrupt:
-	    arch_skip_instruction(scp);
-	    interrupt_handle_pending(scp);
-	    break;
-
-	  case trap_Error:
-	  case trap_Cerror:
-	    interrupt_internal_error(signal, code, scp, im5==trap_Cerror);
-	    break;
-
-	  case trap_Breakpoint:
-	    sigsetmask(scp->sc_mask);
-	    fake_foreign_function_call(scp);
-	    handle_breakpoint(signal, code, scp);
-	    undo_fake_foreign_function_call(scp);
-	    break;
-
-	  case trap_FunctionEndBreakpoint:
-	    sigsetmask(scp->sc_mask);
-	    fake_foreign_function_call(scp);
-	    {
-		void *pc;
-		pc = handle_function_end_breakpoint(signal, code, scp);
-		scp->sc_pcoqh = (unsigned long)pc;
-		scp->sc_pcoqt = (unsigned long)pc + 4;
-	    }
-	    undo_fake_foreign_function_call(scp);
-	    break;
-
-	  default:
-	    interrupt_handle_now(signal, code, scp);
-	    break;
-	}
-    }
-}
-
-static void sigfpe_handler(int signal, int code, struct sigcontext *scp)
-{
-    unsigned long badinst;
-    int opcode, r1, r2, t;
-    long op1, op2, res;
-
-    switch (code) {
-      case I_OVFLO:
-	badinst = *(unsigned long *)(SC_PC(scp)&~3);
-	opcode = badinst >> 26;
-
-	if (opcode == 2) {
-	    /* reg/reg inst. */
-	    r1 = (badinst >> 16) & 0x1f;
-	    op1 = fixnum_value(SC_REG(scp, r1));
-	    r2 = (badinst >> 21) & 0x1f;
-	    op2 = fixnum_value(SC_REG(scp, r2));
-	    t = badinst & 0x1f;
-
-	    switch ((badinst >> 5) & 0x7f) {
-	      case 0x70:
-		/* Add and trap on overflow. */
-		res = op1 + op2;
-		break;
-
-	      case 0x60:
-		/* Subtract and trap on overflow. */
-		res = op1 - op2;
-		break;
-
-	      default:
-		goto not_interesting;
-	    }
-	}
-	else if ((opcode & 0x37) == 0x25 && (badinst & (1<<11))) {
-	    /* Add or subtract immediate. */
-	    op1 = ((badinst >> 3) & 0xff) | ((-badinst&1)<<8);
-	    r2 = (badinst >> 16) & 0x1f;
-	    op2 = fixnum_value(SC_REG(scp, r1));
-	    t = (badinst >> 21) & 0x1f;
-	    if (opcode == 0x2d)
-		res = op1 + op2;
-	    else
-		res = op1 - op2;
-	}
-	else
-	    goto not_interesting;
-
-        current_dynamic_space_free_pointer = (lispobj *)SC_REG(scp, reg_ALLOC);
-	SC_REG(scp, t) = alloc_number(res);
-	SC_REG(scp, reg_ALLOC)
-	    = (unsigned long)current_dynamic_space_free_pointer;
-	arch_skip_instruction(scp);
-
-	break;
-
-      case I_COND:
-	badinst = *(unsigned long *)(SC_PC(scp)&~3);
-	if ((badinst&0xfffff800) == (0xb000e000|reg_ALLOC<<21|reg_ALLOC<<16)) {
-	    /* It is an ADDIT,OD i,ALLOC,ALLOC instruction that trapped. */
-	    /* That means that it is the end of a pseudo-atomic.  So do the */
-	    /* add stripping off the pseudo-atomic-interrupted bit, and then */
-	    /* tell the machine-independent code to process the pseudo- */
-	    /* atomic. */
-	    int immed = (badinst>>1)&0xf;
-	    if (badinst & 1)
-		immed |= -1<<4;
-	    SC_REG(scp,reg_ALLOC) += (immed-1);
-	    arch_skip_instruction(scp);
-	    interrupt_handle_pending(scp);
-	    break;
-	}
-	/* else drop-through. */
-      default:
-      not_interesting:
-	interrupt_handle_now(signal, code, scp);
-    }
-}
-
-void arch_install_interrupt_handlers(void)
-{
-    interrupt_install_low_level_handler(SIGTRAP,sigtrap_handler);
-    interrupt_install_low_level_handler(SIGFPE,sigfpe_handler);
-}
-
-lispobj funcall0(lispobj function)
-{
-    lispobj *args = current_control_stack_pointer;
-
-    return call_into_lisp(function, args, 0);
-}
-
-lispobj funcall1(lispobj function, lispobj arg0)
-{
-    lispobj *args = current_control_stack_pointer;
-
-    current_control_stack_pointer += 1;
-    args[0] = arg0;
-
-    return call_into_lisp(function, args, 1);
-}
-
-lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1)
-{
-    lispobj *args = current_control_stack_pointer;
-
-    current_control_stack_pointer += 2;
-    args[0] = arg0;
-    args[1] = arg1;
-
-    return call_into_lisp(function, args, 2);
-}
-
-lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2)
-{
-    lispobj *args = current_control_stack_pointer;
-
-    current_control_stack_pointer += 3;
-    args[0] = arg0;
-    args[1] = arg1;
-    args[2] = arg2;
-
-    return call_into_lisp(function, args, 3);
-}
diff --git a/lisp/hppa-assem.S b/lisp/hppa-assem.S
deleted file mode 100644
index 6221dfc0eaaddb8b053542f6414c5b8412258f78..0000000000000000000000000000000000000000
--- a/lisp/hppa-assem.S
+++ /dev/null
@@ -1,324 +0,0 @@
-#define LANGUAGE_ASSEMBLY
-
-#include <machine/asm.h>
-
-#include "internals.h"
-#include "lispregs.h"
-
-	.import $global$,data
-	.import foreign_function_call_active,data
-	.import current_control_stack_pointer,data
-	.import current_control_frame_pointer,data
-	.import current_binding_stack_pointer,data
-	.import current_dynamic_space_free_pointer,data
-
-	.space	$TEXT$
-	.subspa	$CODE$
-
-
-/*
- * Call-into-lisp
- */
-
-	.export call_into_lisp
-call_into_lisp
-	.proc
-	.callinfo entry_gr=18,save_rp
-	.enter
-	/* arg0=function, arg1=cfp, arg2=nargs */
-
-	/* Clear the descriptor regs, moving in args as approporate. */
-	copy	r0,reg_CODE
-	copy	r0,reg_FDEFN
-	copy	arg0,reg_LEXENV
-	zdep	arg2,29,30,reg_NARGS
-	copy	r0,reg_OCFP
-	copy	r0,reg_LRA
-	copy	r0,reg_A0
-	copy	r0,reg_A1
-	copy	r0,reg_A2
-	copy	r0,reg_A3
-	copy	r0,reg_A4
-	copy	r0,reg_A5
-	copy	r0,reg_L0
-	copy	r0,reg_L1
-	copy	r0,reg_L2
-
-	/* Establish NIL. */
-	ldil	L%NIL,reg_NULL
-	ldo	R%NIL(reg_NULL),reg_NULL
-
-	/* Turn on pseudo-atomic. */
-	ldo	4(r0),reg_ALLOC
-
-	/* No longer in foreign function call land. */
-	addil	L%foreign_function_call_active-$global$,dp
-	stw	r0,R%foreign_function_call_active-$global$(0,r1)
-
-	/* Load lisp state. */
-	addil	L%current_dynamic_space_free_pointer-$global$,dp
-	ldw	R%current_dynamic_space_free_pointer-$global$(0,r1),r1
-	add	reg_ALLOC,r1,reg_ALLOC
-	addil	L%current_binding_stack_pointer-$global$,dp
-	ldw	R%current_binding_stack_pointer-$global$(0,r1),reg_BSP
-	addil	L%current_control_stack_pointer-$global$,dp
-	ldw	R%current_control_stack_pointer-$global$(0,r1),reg_CSP
-	addil	L%current_control_frame_pointer-$global$,dp
-	ldw	R%current_control_frame_pointer-$global$(0,r1),reg_OCFP
-	copy	arg1,reg_CFP
-
-	/* End of pseudo-atomic. */
-	addit,od	-4,reg_ALLOC,reg_ALLOC
-
-	/* Establish lisp arguments. */
-	ldw	0(reg_CFP),reg_A0
-	ldw	4(reg_CFP),reg_A1
-	ldw	8(reg_CFP),reg_A2
-	ldw	12(reg_CFP),reg_A3
-	ldw	16(reg_CFP),reg_A4
-	ldw	20(reg_CFP),reg_A5
-
-	/* Calculate the LRA. */
-	ldil	L%lra+type_OtherPointer,reg_LRA
-	ldo	R%lra+type_OtherPointer(reg_LRA),reg_LRA
-
-	/* Indirect the closure */
-	ldw	CLOSURE_FUNCTION_OFFSET(0,reg_LEXENV),reg_CODE
-	addi	6*4-type_FunctionPointer,reg_CODE,reg_LIP
-
-	/* And into lisp we go. */
-	.export break_here
-break_here
-	be,n	0(sr4,reg_LIP)
-
-	.align	8
-lra
-	.word	type_ReturnPcHeader
-	copy	reg_OCFP,reg_CSP
-
-	/* Copy CFP (r4) into someplace else and restore r4. */
-	copy	reg_CFP,reg_NL1
-	ldw	-64(0,sp),r4
-
-	/* Copy the return value. */
-	copy	reg_A0,ret0
-
-	/* Turn on pseudo-atomic. */
-	addi	4,reg_ALLOC,reg_ALLOC
-
-	/* Store the lisp state. */
-	copy	reg_ALLOC,reg_NL0
-	depi	0,31,3,reg_NL0
-	addil	L%current_dynamic_space_free_pointer-$global$,dp
-	stw	reg_NL0,R%current_dynamic_space_free_pointer-$global$(0,r1)
-	addil	L%current_binding_stack_pointer-$global$,dp
-	stw	reg_BSP,R%current_binding_stack_pointer-$global$(0,r1)
-	addil	L%current_control_stack_pointer-$global$,dp
-	stw	reg_CSP,R%current_control_stack_pointer-$global$(0,r1)
-	addil	L%current_control_frame_pointer-$global$,dp
-	stw	reg_NL1,R%current_control_frame_pointer-$global$(0,r1)
-
-	/* Back in C land.  [CSP is just a handy non-zero value.] */
-	addil	L%foreign_function_call_active-$global$,dp
-	stw	reg_CSP,R%foreign_function_call_active-$global$(0,r1)
-
-	/* Turn off pseudo-atomic and check for traps. */
-	addit,od	-4,reg_ALLOC,reg_ALLOC
-
-	/* And thats all. */
-	.leave
-	.procend
-
-
-/*
- * Call-into-C
- */
-
-	
-	.export call_into_c
-call_into_c
-	/* Set up a lisp stack frame.  Note: we convert the raw return pc into
-	 * a fixnum pc-offset because we don't have ahold of an lra object.
-	 */
-	copy	reg_CFP, reg_OCFP
-	copy	reg_CSP, reg_CFP
-	addi	32, reg_CSP, reg_CSP
-	stw	reg_OCFP, 0(0,reg_CFP)
-	sub	reg_LIP, reg_CODE, reg_NL5
-	addi	3-type_OtherPointer, reg_NL5, reg_NL5
-	stw	reg_NL5, 4(0,reg_CFP)
-	stw	reg_CODE, 8(0,reg_CFP)
-
-	/* Turn on pseudo-atomic. */
-	addi	4, reg_ALLOC, reg_ALLOC
-
-	/* Store the lisp state. */
-	copy	reg_ALLOC,reg_NL5
-	depi	0,31,3,reg_NL5
-	addil	L%current_dynamic_space_free_pointer-$global$,dp
-	stw	reg_NL5,R%current_dynamic_space_free_pointer-$global$(0,r1)
-	addil	L%current_binding_stack_pointer-$global$,dp
-	stw	reg_BSP,R%current_binding_stack_pointer-$global$(0,r1)
-	addil	L%current_control_stack_pointer-$global$,dp
-	stw	reg_CSP,R%current_control_stack_pointer-$global$(0,r1)
-	addil	L%current_control_frame_pointer-$global$,dp
-	stw	reg_CFP,R%current_control_frame_pointer-$global$(0,r1)
-
-	/* Back in C land.  [CSP is just a handy non-zero value.] */
-	addil	L%foreign_function_call_active-$global$,dp
-	stw	reg_CSP,R%foreign_function_call_active-$global$(0,r1)
-
-	/* Turn off pseudo-atomic and check for traps. */
-	addit,od	-4,reg_ALLOC,reg_ALLOC
-
-	/* Now we can call the C function. */
-	ble	0(4,reg_CFUNC)
-	copy	r31, r2
-
-	/* Clear the callee saves descriptor regs. */
-	copy	r0, reg_A5
-	copy	r0, reg_L0
-	copy	r0, reg_L1
-	copy	r0, reg_L2
-
-	/* Turn on pseudo-atomic. */
-	ldi	4, reg_ALLOC
-
-	/* Turn off foreign function call. */
-	addil	L%foreign_function_call_active-$global$,dp
-	stw	r0,R%foreign_function_call_active-$global$(0,r1)
-
-	/* Load ALLOC. */
-	addil	L%current_dynamic_space_free_pointer-$global$,dp
-	ldw	R%current_dynamic_space_free_pointer-$global$(0,r1),r1
-	add	reg_ALLOC,r1,reg_ALLOC
-
-	/* We don't need to load OCFP, CFP, CSP, or BSP because they are
-	 * in caller saves registers.
-	 */
-
-	/* End of pseudo-atomic. */
-	addit,od	-4,reg_ALLOC,reg_ALLOC
-
-	/* Restore CODE.  Even though it is in a callee saves register
-	 * it might have been GC'ed.
-	 */
-	ldw	8(0,reg_CFP), reg_CODE
-
-	/* Restore the return pc. */
-	ldw	4(0,reg_CFP), reg_NL0
-	addi	type_OtherPointer-3, reg_NL0, reg_NL0
-	add	reg_CODE, reg_NL0, reg_LIP
-
-	/* Pop the lisp stack frame, and back we go. */
-	copy	reg_CFP, reg_CSP
-	be	0(4,reg_LIP)
-	copy	reg_OCFP, reg_CFP
-
-
-
-/*
- * Stuff to sanctify a block of memory for execution.
- */
-
-	.EXPORT sanctify_for_execution
-sanctify_for_execution
-	.proc
-	.callinfo
-	.enter
-	/* arg0=start addr, arg1=length in bytes */
-	add	arg0,arg1,arg1
-	ldo	32(arg1),arg1
-	depi	0,31,5,arg0
-	depi	0,31,5,arg1
-	ldsid	(arg0),t1
-	mtsp	t1,sr1
-	ldi	32,t1			; bytes per cache line
-sanctify_loop
-	fdc	0(sr1,arg0)
-	fic,m	t1(sr1,arg0)
-	fdc	0(sr1,arg0)
-	fic,m	t1(sr1,arg0)
-	fdc	0(sr1,arg0)
-	fic,m	t1(sr1,arg0)
-	fdc	0(sr1,arg0)
-	comb,<	arg0,arg1,sanctify_loop
-	fic,m	t1(sr1,arg0)
-	.leave
-	.procend
-
-
-/*
- * Trampolines.
- */
-
-	.EXPORT closure_tramp
-closure_tramp
-	/* reg_FDEFN holds the fdefn object. */
-	ldw	FDEFN_FUNCTION_OFFSET(0,reg_FDEFN),reg_LEXENV
-	ldw	CLOSURE_FUNCTION_OFFSET(0,reg_LEXENV),reg_L0
-	addi	FUNCTION_CODE_OFFSET, reg_L0, reg_LIP
-	bv,n	0(reg_LIP)
-
-	.EXPORT undefined_tramp
-undefined_tramp
-	break	trap_Error,0
-        .byte    4
-        .byte    23
-        .byte    254
-        .byte    46
-        .byte    1
-	.align	4
-
-
-/*
- * Core saving/restoring support
- */
-
-	.export call_on_stack
-call_on_stack
-	/* arg0 = fn to invoke, arg1 = new stack base */
-
-	/* Compute the new stack pointer. */
-	addi	64,arg1,sp
-
-	/* Zero out the previous stack pointer. */
-	stw	r0,-4(0,sp)
-
-	/* Invoke the function. */
-	ble	0(4,arg0)
-	copy	r31, r2
-
-	/* Flame out. */
-	break	0,0
-
-	.export	save_state
-save_state
-	.proc
-	.callinfo entry_gr=18,entry_fr=21,save_rp,calls
-	.enter
-
-	/* Remember the function we want to invoke */
-	copy	arg0,r19
-
-	/* Pass the new stack pointer in as arg0 */
-	copy	sp,arg0
-
-	/* Leave arg1 as arg1. */
-
-	/* do the call. */
-	ble	0(4,r19)
-	copy	r31, r2
-
-_restore_state
-	.leave
-	.procend
-
-	.export	restore_state
-restore_state
-	.proc
-	.callinfo
-	copy	arg0,sp
-	b	_restore_state
-	copy	arg1,ret0
-	.procend
diff --git a/lisp/hppa-assem.s b/lisp/hppa-assem.s
deleted file mode 100644
index 6221dfc0eaaddb8b053542f6414c5b8412258f78..0000000000000000000000000000000000000000
--- a/lisp/hppa-assem.s
+++ /dev/null
@@ -1,324 +0,0 @@
-#define LANGUAGE_ASSEMBLY
-
-#include <machine/asm.h>
-
-#include "internals.h"
-#include "lispregs.h"
-
-	.import $global$,data
-	.import foreign_function_call_active,data
-	.import current_control_stack_pointer,data
-	.import current_control_frame_pointer,data
-	.import current_binding_stack_pointer,data
-	.import current_dynamic_space_free_pointer,data
-
-	.space	$TEXT$
-	.subspa	$CODE$
-
-
-/*
- * Call-into-lisp
- */
-
-	.export call_into_lisp
-call_into_lisp
-	.proc
-	.callinfo entry_gr=18,save_rp
-	.enter
-	/* arg0=function, arg1=cfp, arg2=nargs */
-
-	/* Clear the descriptor regs, moving in args as approporate. */
-	copy	r0,reg_CODE
-	copy	r0,reg_FDEFN
-	copy	arg0,reg_LEXENV
-	zdep	arg2,29,30,reg_NARGS
-	copy	r0,reg_OCFP
-	copy	r0,reg_LRA
-	copy	r0,reg_A0
-	copy	r0,reg_A1
-	copy	r0,reg_A2
-	copy	r0,reg_A3
-	copy	r0,reg_A4
-	copy	r0,reg_A5
-	copy	r0,reg_L0
-	copy	r0,reg_L1
-	copy	r0,reg_L2
-
-	/* Establish NIL. */
-	ldil	L%NIL,reg_NULL
-	ldo	R%NIL(reg_NULL),reg_NULL
-
-	/* Turn on pseudo-atomic. */
-	ldo	4(r0),reg_ALLOC
-
-	/* No longer in foreign function call land. */
-	addil	L%foreign_function_call_active-$global$,dp
-	stw	r0,R%foreign_function_call_active-$global$(0,r1)
-
-	/* Load lisp state. */
-	addil	L%current_dynamic_space_free_pointer-$global$,dp
-	ldw	R%current_dynamic_space_free_pointer-$global$(0,r1),r1
-	add	reg_ALLOC,r1,reg_ALLOC
-	addil	L%current_binding_stack_pointer-$global$,dp
-	ldw	R%current_binding_stack_pointer-$global$(0,r1),reg_BSP
-	addil	L%current_control_stack_pointer-$global$,dp
-	ldw	R%current_control_stack_pointer-$global$(0,r1),reg_CSP
-	addil	L%current_control_frame_pointer-$global$,dp
-	ldw	R%current_control_frame_pointer-$global$(0,r1),reg_OCFP
-	copy	arg1,reg_CFP
-
-	/* End of pseudo-atomic. */
-	addit,od	-4,reg_ALLOC,reg_ALLOC
-
-	/* Establish lisp arguments. */
-	ldw	0(reg_CFP),reg_A0
-	ldw	4(reg_CFP),reg_A1
-	ldw	8(reg_CFP),reg_A2
-	ldw	12(reg_CFP),reg_A3
-	ldw	16(reg_CFP),reg_A4
-	ldw	20(reg_CFP),reg_A5
-
-	/* Calculate the LRA. */
-	ldil	L%lra+type_OtherPointer,reg_LRA
-	ldo	R%lra+type_OtherPointer(reg_LRA),reg_LRA
-
-	/* Indirect the closure */
-	ldw	CLOSURE_FUNCTION_OFFSET(0,reg_LEXENV),reg_CODE
-	addi	6*4-type_FunctionPointer,reg_CODE,reg_LIP
-
-	/* And into lisp we go. */
-	.export break_here
-break_here
-	be,n	0(sr4,reg_LIP)
-
-	.align	8
-lra
-	.word	type_ReturnPcHeader
-	copy	reg_OCFP,reg_CSP
-
-	/* Copy CFP (r4) into someplace else and restore r4. */
-	copy	reg_CFP,reg_NL1
-	ldw	-64(0,sp),r4
-
-	/* Copy the return value. */
-	copy	reg_A0,ret0
-
-	/* Turn on pseudo-atomic. */
-	addi	4,reg_ALLOC,reg_ALLOC
-
-	/* Store the lisp state. */
-	copy	reg_ALLOC,reg_NL0
-	depi	0,31,3,reg_NL0
-	addil	L%current_dynamic_space_free_pointer-$global$,dp
-	stw	reg_NL0,R%current_dynamic_space_free_pointer-$global$(0,r1)
-	addil	L%current_binding_stack_pointer-$global$,dp
-	stw	reg_BSP,R%current_binding_stack_pointer-$global$(0,r1)
-	addil	L%current_control_stack_pointer-$global$,dp
-	stw	reg_CSP,R%current_control_stack_pointer-$global$(0,r1)
-	addil	L%current_control_frame_pointer-$global$,dp
-	stw	reg_NL1,R%current_control_frame_pointer-$global$(0,r1)
-
-	/* Back in C land.  [CSP is just a handy non-zero value.] */
-	addil	L%foreign_function_call_active-$global$,dp
-	stw	reg_CSP,R%foreign_function_call_active-$global$(0,r1)
-
-	/* Turn off pseudo-atomic and check for traps. */
-	addit,od	-4,reg_ALLOC,reg_ALLOC
-
-	/* And thats all. */
-	.leave
-	.procend
-
-
-/*
- * Call-into-C
- */
-
-	
-	.export call_into_c
-call_into_c
-	/* Set up a lisp stack frame.  Note: we convert the raw return pc into
-	 * a fixnum pc-offset because we don't have ahold of an lra object.
-	 */
-	copy	reg_CFP, reg_OCFP
-	copy	reg_CSP, reg_CFP
-	addi	32, reg_CSP, reg_CSP
-	stw	reg_OCFP, 0(0,reg_CFP)
-	sub	reg_LIP, reg_CODE, reg_NL5
-	addi	3-type_OtherPointer, reg_NL5, reg_NL5
-	stw	reg_NL5, 4(0,reg_CFP)
-	stw	reg_CODE, 8(0,reg_CFP)
-
-	/* Turn on pseudo-atomic. */
-	addi	4, reg_ALLOC, reg_ALLOC
-
-	/* Store the lisp state. */
-	copy	reg_ALLOC,reg_NL5
-	depi	0,31,3,reg_NL5
-	addil	L%current_dynamic_space_free_pointer-$global$,dp
-	stw	reg_NL5,R%current_dynamic_space_free_pointer-$global$(0,r1)
-	addil	L%current_binding_stack_pointer-$global$,dp
-	stw	reg_BSP,R%current_binding_stack_pointer-$global$(0,r1)
-	addil	L%current_control_stack_pointer-$global$,dp
-	stw	reg_CSP,R%current_control_stack_pointer-$global$(0,r1)
-	addil	L%current_control_frame_pointer-$global$,dp
-	stw	reg_CFP,R%current_control_frame_pointer-$global$(0,r1)
-
-	/* Back in C land.  [CSP is just a handy non-zero value.] */
-	addil	L%foreign_function_call_active-$global$,dp
-	stw	reg_CSP,R%foreign_function_call_active-$global$(0,r1)
-
-	/* Turn off pseudo-atomic and check for traps. */
-	addit,od	-4,reg_ALLOC,reg_ALLOC
-
-	/* Now we can call the C function. */
-	ble	0(4,reg_CFUNC)
-	copy	r31, r2
-
-	/* Clear the callee saves descriptor regs. */
-	copy	r0, reg_A5
-	copy	r0, reg_L0
-	copy	r0, reg_L1
-	copy	r0, reg_L2
-
-	/* Turn on pseudo-atomic. */
-	ldi	4, reg_ALLOC
-
-	/* Turn off foreign function call. */
-	addil	L%foreign_function_call_active-$global$,dp
-	stw	r0,R%foreign_function_call_active-$global$(0,r1)
-
-	/* Load ALLOC. */
-	addil	L%current_dynamic_space_free_pointer-$global$,dp
-	ldw	R%current_dynamic_space_free_pointer-$global$(0,r1),r1
-	add	reg_ALLOC,r1,reg_ALLOC
-
-	/* We don't need to load OCFP, CFP, CSP, or BSP because they are
-	 * in caller saves registers.
-	 */
-
-	/* End of pseudo-atomic. */
-	addit,od	-4,reg_ALLOC,reg_ALLOC
-
-	/* Restore CODE.  Even though it is in a callee saves register
-	 * it might have been GC'ed.
-	 */
-	ldw	8(0,reg_CFP), reg_CODE
-
-	/* Restore the return pc. */
-	ldw	4(0,reg_CFP), reg_NL0
-	addi	type_OtherPointer-3, reg_NL0, reg_NL0
-	add	reg_CODE, reg_NL0, reg_LIP
-
-	/* Pop the lisp stack frame, and back we go. */
-	copy	reg_CFP, reg_CSP
-	be	0(4,reg_LIP)
-	copy	reg_OCFP, reg_CFP
-
-
-
-/*
- * Stuff to sanctify a block of memory for execution.
- */
-
-	.EXPORT sanctify_for_execution
-sanctify_for_execution
-	.proc
-	.callinfo
-	.enter
-	/* arg0=start addr, arg1=length in bytes */
-	add	arg0,arg1,arg1
-	ldo	32(arg1),arg1
-	depi	0,31,5,arg0
-	depi	0,31,5,arg1
-	ldsid	(arg0),t1
-	mtsp	t1,sr1
-	ldi	32,t1			; bytes per cache line
-sanctify_loop
-	fdc	0(sr1,arg0)
-	fic,m	t1(sr1,arg0)
-	fdc	0(sr1,arg0)
-	fic,m	t1(sr1,arg0)
-	fdc	0(sr1,arg0)
-	fic,m	t1(sr1,arg0)
-	fdc	0(sr1,arg0)
-	comb,<	arg0,arg1,sanctify_loop
-	fic,m	t1(sr1,arg0)
-	.leave
-	.procend
-
-
-/*
- * Trampolines.
- */
-
-	.EXPORT closure_tramp
-closure_tramp
-	/* reg_FDEFN holds the fdefn object. */
-	ldw	FDEFN_FUNCTION_OFFSET(0,reg_FDEFN),reg_LEXENV
-	ldw	CLOSURE_FUNCTION_OFFSET(0,reg_LEXENV),reg_L0
-	addi	FUNCTION_CODE_OFFSET, reg_L0, reg_LIP
-	bv,n	0(reg_LIP)
-
-	.EXPORT undefined_tramp
-undefined_tramp
-	break	trap_Error,0
-        .byte    4
-        .byte    23
-        .byte    254
-        .byte    46
-        .byte    1
-	.align	4
-
-
-/*
- * Core saving/restoring support
- */
-
-	.export call_on_stack
-call_on_stack
-	/* arg0 = fn to invoke, arg1 = new stack base */
-
-	/* Compute the new stack pointer. */
-	addi	64,arg1,sp
-
-	/* Zero out the previous stack pointer. */
-	stw	r0,-4(0,sp)
-
-	/* Invoke the function. */
-	ble	0(4,arg0)
-	copy	r31, r2
-
-	/* Flame out. */
-	break	0,0
-
-	.export	save_state
-save_state
-	.proc
-	.callinfo entry_gr=18,entry_fr=21,save_rp,calls
-	.enter
-
-	/* Remember the function we want to invoke */
-	copy	arg0,r19
-
-	/* Pass the new stack pointer in as arg0 */
-	copy	sp,arg0
-
-	/* Leave arg1 as arg1. */
-
-	/* do the call. */
-	ble	0(4,r19)
-	copy	r31, r2
-
-_restore_state
-	.leave
-	.procend
-
-	.export	restore_state
-restore_state
-	.proc
-	.callinfo
-	copy	arg0,sp
-	b	_restore_state
-	copy	arg1,ret0
-	.procend
diff --git a/lisp/hppa-lispregs.h b/lisp/hppa-lispregs.h
deleted file mode 100644
index 6c9a1d625f8fd06ab3e8e46fef3904bfa6f28905..0000000000000000000000000000000000000000
--- a/lisp/hppa-lispregs.h
+++ /dev/null
@@ -1,59 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/hppa-lispregs.h,v 1.1 1992/09/04 08:16:35 wlott Exp $ */
-
-#define NREGS	(32)
-
-#ifdef LANGUAGE_ASSEMBLY
-#define REG(num) num
-#else
-#define REG(num) num
-#endif
-
-#define reg_ZERO REG(0)
-#define reg_NFP REG(1)
-#define reg_CFUNC REG(2)
-#define reg_CSP REG(3)
-#define reg_CFP REG(4)
-#define reg_BSP REG(5)
-#define reg_NULL REG(6)
-#define reg_ALLOC REG(7)
-#define reg_CODE REG(8)
-#define reg_FDEFN REG(9)
-#define reg_LEXENV REG(10)
-#define reg_NARGS REG(11)
-#define reg_OCFP REG(12)
-#define reg_LRA REG(13)
-#define reg_A0 REG(14)
-#define reg_A1 REG(15)
-#define reg_A2 REG(16)
-#define reg_A3 REG(17)
-#define reg_A4 REG(18)
-#define reg_A5 REG(19)
-#define reg_L0 REG(20)
-#define reg_L1 REG(21)
-#define reg_L2 REG(22)
-#define reg_NL3 REG(23)
-#define reg_NL2 REG(24)
-#define reg_NL1 REG(25)
-#define reg_NL0 REG(26)
-#define reg_DP REG(27)
-#define reg_NL4 REG(28)
-#define reg_NL5 REG(29)
-#define reg_NSP REG(30)
-#define reg_LIP REG(31)
-
-
-#define REGNAMES \
-    "ZERO", "NFP", "CFUNC", "CSP", "CFP", "BSP", "NULL", "ALLOC", \
-    "CODE", "FDEFN", "LEXENV", "NARGS", "OCFP", "LRA", "A0", "A1", \
-    "A2", "A3", "A4", "A5", "L0", "L1", "L2", "NL3", \
-    "NL2", "NL1", "NL0", "DP", "NL4", "NL5", "NSP", "LIP"
-
-#define BOXED_REGISTERS { \
-    reg_CODE, reg_FDEFN, reg_LEXENV, reg_NARGS, reg_OCFP, reg_LRA, \
-    reg_A0, reg_A1, reg_A2, reg_A3, reg_A4, reg_A5, \
-    reg_L0, reg_L1, reg_L2 \
-}
-
-#define SC_REG(sc, n) (((unsigned long *)((sc)->sc_ap))[n])
-#define SC_PC(sc) ((sc)->sc_pcoqh)
-#define SC_NPC(sc) ((sc)->sc_pcoqt)
diff --git a/lisp/hppa-validate.h b/lisp/hppa-validate.h
deleted file mode 100644
index 693f241fa4aa02299a1ab04a7aa2a6501ad2b3c6..0000000000000000000000000000000000000000
--- a/lisp/hppa-validate.h
+++ /dev/null
@@ -1,20 +0,0 @@
-
-#define READ_ONLY_SPACE_START   (0x20000000)
-#define READ_ONLY_SPACE_SIZE    (0x08000000)
-
-#define STATIC_SPACE_START	(0x28000000)
-#define STATIC_SPACE_SIZE	(0x08000000)
-
-#define DYNAMIC_0_SPACE_START	(0x30000000)
-#define DYNAMIC_1_SPACE_START	(0x38000000)
-#define DYNAMIC_SPACE_SIZE	(0x08000000)
-
-#define CONTROL_STACK_START	(0x50000000)
-#define CONTROL_STACK_SIZE	(0x00100000)
-
-#define BINDING_STACK_START	(0x70000000)
-#define BINDING_STACK_SIZE	(0x00100000)
-
-#define NUMBER_STACK_START	(0x60000000)
-#define NUMBER_STACK_SIZE	(0x00100000)
-#define NUMBER_STACK_GROWS_UP
diff --git a/lisp/interr.c b/lisp/interr.c
deleted file mode 100644
index 46773b374cffe79b32a0ef5ddf09b76b51a54a02..0000000000000000000000000000000000000000
--- a/lisp/interr.c
+++ /dev/null
@@ -1,150 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interr.c,v 1.1 1992/07/28 20:14:32 wlott Exp $
- *
- * Stuff to handle internal errors.
- *
- */
-
-#include <stdio.h>
-#include <stdarg.h>
-
-#include "signal.h"
-
-#include "lisp.h"
-#include "internals.h"
-#include "interr.h"
-#include "print.h"
-#include "lispregs.h"
-#include "arch.h"
-
-
-/* Lossage handler. */
-
-static void default_lossage_handler(void)
-{
-    exit(1);
-}
-
-static void (*lossage_handler)(void) = default_lossage_handler;
-
-void set_lossage_handler(void handler(void))
-{
-    lossage_handler = handler;
-}
-
-void lose(char *fmt, ...)
-{
-    va_list ap;
-
-    if (fmt != NULL) {
-	va_start(ap, fmt);
-	vfprintf(stderr, fmt, ap);
-	fflush(stderr);
-	va_end(ap);
-    }
-    lossage_handler();
-}
-
-
-/* Internal error handler for when the Lisp error system doesn't exist. */
-
-static char *errors[] = ERRORS;
-
-void internal_error(struct sigcontext *context)
-{
-    unsigned char *ptr = arch_internal_error_arguments(context);
-    int len, scoffset, sc, offset, ch;
-
-    len = *ptr++;
-    printf("Error: %s\n", errors[*ptr++]);
-    len--;
-    while (len > 0) {
-	scoffset = *ptr++;
-	len--;
-	if (scoffset == 253) {
-	    scoffset = *ptr++;
-	    len--;
-	}
-	else if (scoffset == 254) {
-	    scoffset = ptr[0] + ptr[1]*256;
-	    ptr += 2;
-	    len -= 2;
-	}
-	else if (scoffset == 255) {
-	    scoffset = ptr[0] + (ptr[1]<<8) + (ptr[2]<<16) + (ptr[3]<<24);
-	    ptr += 4;
-	    len -= 4;
-	}
-	sc = scoffset & 0x1f;
-	offset = scoffset >> 5;
-		
-	printf("    SC: %d, Offset: %d", sc, offset);
-	switch (sc) {
-	  case sc_AnyReg:
-	  case sc_DescriptorReg:
-	    putchar('\t');
-	    brief_print(SC_REG(context, offset));
-	    break;
-
-	  case sc_BaseCharReg:
-	    ch = SC_REG(context, offset);
-#ifdef i386
-	    if (offset&1)
-		ch = ch>>8;
-	    ch = ch & 0xff;
-#endif
-	    switch (ch) {
-	      case '\n': printf("\t'\\n'\n"); break;
-	      case '\b': printf("\t'\\b'\n"); break;
-	      case '\t': printf("\t'\\t'\n"); break;
-	      case '\r': printf("\t'\\r'\n"); break;
-	      default:
-		if (ch < 32 || ch > 127)
-		    printf("\\%03o", ch);
-		else
-		    printf("\t'%c'\n", ch);
-		break;
-	    }
-	    break;
-	  case sc_SapReg:
-#ifdef sc_WordPointerReg
-	  case sc_WordPointerReg:
-#endif
-	    printf("\t0x%08x\n", SC_REG(context, offset));
-	    break;
-	  case sc_SignedReg:
-	    printf("\t%ld\n", SC_REG(context, offset));
-	    break;
-	  case sc_UnsignedReg:
-	    printf("\t%lu\n", SC_REG(context, offset));
-	    break;
-#ifdef sc_SingleFloatReg
-	  case sc_SingleFloatReg:
-	    printf("\t%g\n", *(float *)&context->sc_fpregs[offset]);
-	    break;
-#endif
-#ifdef sc_DoubleFloatReg
-	  case sc_DoubleFloatReg:
-	    printf("\t%g\n", *(double *)&context->sc_fpregs[offset]);
-	    break;
-#endif
-	  default:
-	    printf("\t???\n");
-	    break;
-	}
-    }
-
-    lose(NULL);
-}
-
-
-
-
-/* Utility routines used by random pieces of code. */
-
-lispobj debug_print(lispobj string)
-{
-    printf("%s\n", (char *)(((struct vector *)PTR(string))->data));
-
-    return NIL;
-}
diff --git a/lisp/interr.h b/lisp/interr.h
deleted file mode 100644
index 58a9e5de512dc65c0935825e6c0805d5d64c83ba..0000000000000000000000000000000000000000
--- a/lisp/interr.h
+++ /dev/null
@@ -1,16 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interr.h,v 1.1 1992/07/28 20:14:34 wlott Exp $
- */
-
-#ifndef _INTERR_H_
-#define _INTERR_H_
-
-#define crap_out(msg) do { write(2, msg, sizeof(msg)); lose(); } while (0)
-
-extern void lose(char *fmt, ...);
-extern void set_lossage_handler(void fun(void));
-extern void internal_error(struct sigcontext *context);
-
-extern lispobj debug_print(lispobj string);
-
-#endif
diff --git a/lisp/interrupt.c b/lisp/interrupt.c
deleted file mode 100644
index dc698c1cfceca785e9e3b8f7e65034fa598d8563..0000000000000000000000000000000000000000
--- a/lisp/interrupt.c
+++ /dev/null
@@ -1,335 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.c,v 1.2 1992/09/08 20:25:46 wlott Exp $ */
-
-/* Interrupt handing magic. */
-
-#include <stdio.h>
-
-#include <signal.h>
-#ifdef mips
-#include <mips/cpu.h>
-#endif
-
-#include "lisp.h"
-#include "internals.h"
-#include "os.h"
-#include "arch.h"
-#include "globals.h"
-#include "lispregs.h"
-#include "interrupt.h"
-#include "validate.h"
-#include "monitor.h"
-#include "gc.h"
-#include "alloc.h"
-#include "dynbind.h"
-#include "interr.h"
-
-boolean internal_errors_enabled = 0;
-
-struct sigcontext *lisp_interrupt_contexts[MAX_INTERRUPTS];
-
-union interrupt_handler interrupt_handlers[NSIG];
-void (*interrupt_low_level_handlers[NSIG])(int signal, int code,
-					   struct sigcontext *scp) = {0};
-
-static int pending_signal = 0, pending_code = 0, pending_mask = 0;
-static boolean maybe_gc_pending = FALSE;
-
-
-/****************************************************************\
-* Utility routines used by various signal handlers.              *
-\****************************************************************/
-
-void fake_foreign_function_call(struct sigcontext *context)
-{
-    int context_index;
-    lispobj oldcont;
-    
-    /* Get current LISP state from context */
-#ifdef reg_ALLOC
-    current_dynamic_space_free_pointer = (lispobj *)SC_REG(context, reg_ALLOC);
-#endif
-#ifdef reg_BSP
-    current_binding_stack_pointer = (lispobj *)SC_REG(context, reg_BSP);
-#endif
-    
-#ifndef i386
-    /* Build a fake stack frame */
-    current_control_frame_pointer = (lispobj *)SC_REG(context, reg_CSP);
-    if ((lispobj *)SC_REG(context, reg_CFP)==current_control_frame_pointer) {
-        /* There is a small window during call where the callee's frame */
-        /* isn't built yet. */
-        if (LowtagOf(SC_REG(context, reg_CODE)) == type_FunctionPointer) {
-            /* We have called, but not built the new frame, so
-               build it for them. */
-            current_control_frame_pointer[0] = SC_REG(context, reg_OCFP);
-            current_control_frame_pointer[1] = SC_REG(context, reg_LRA);
-            current_control_frame_pointer += 8;
-            /* Build our frame on top of it. */
-            oldcont = (lispobj)SC_REG(context, reg_CFP);
-        }
-        else {
-            /* We haven't yet called, build our frame as if the
-               partial frame wasn't there. */
-            oldcont = (lispobj)SC_REG(context, reg_OCFP);
-        }
-    }
-    /* ### We can't tell if we are still in the caller if it had to
-       reg_ALLOCate the stack frame due to stack arguments. */
-    /* ### Can anything strange happen during return? */
-    else
-        /* Normal case. */
-        oldcont = (lispobj)SC_REG(context, reg_CFP);
-    
-    current_control_stack_pointer = current_control_frame_pointer + 8;
-
-    current_control_frame_pointer[0] = oldcont;
-    current_control_frame_pointer[1] = NIL;
-    current_control_frame_pointer[2] = (lispobj)SC_REG(context, reg_CODE);
-#endif
-    
-    /* Do dynamic binding of the active interrupt context index
-       and save the context in the context array. */
-    context_index = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
-    
-    if (context_index >= MAX_INTERRUPTS) {
-        fprintf(stderr,
-		"Maximum number (%d) of interrupts exceeded.  Exiting.\n",
-                MAX_INTERRUPTS);
-        exit(1);
-    }
-    
-    bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,
-		  make_fixnum(context_index + 1));
-    
-    lisp_interrupt_contexts[context_index] = context;
-    
-    /* No longer in Lisp now. */
-    foreign_function_call_active = 1;
-}
-
-void undo_fake_foreign_function_call(struct sigcontext *context)
-{
-    /* Block all blockable signals */
-    sigblock(BLOCKABLE);
-    
-    /* Going back into lisp. */
-    foreign_function_call_active = 0;
-    
-    /* Undo dynamic binding. */
-    /* ### Do I really need to unbind_to_here()? */
-    unbind();
-    
-#ifdef reg_ALLOC
-    /* Put the dynamic space free pointer back into the context. */
-    SC_REG(context, reg_ALLOC) =
-        (unsigned long) current_dynamic_space_free_pointer;
-#endif
-}
-
-void interrupt_internal_error(int signal, int code, struct sigcontext *context,
-			      boolean continuable)
-{
-    sigsetmask(context->sc_mask);
-    fake_foreign_function_call(context);
-    if (internal_errors_enabled)
-	funcall2(SymbolFunction(INTERNAL_ERROR), alloc_sap(context),
-		 continuable ? T : NIL);
-    else
-	internal_error(context);
-    undo_fake_foreign_function_call(context);
-    if (continuable)
-	arch_skip_instruction(context);
-}
-
-void interrupt_handle_pending(struct sigcontext *context)
-{
-    boolean were_in_lisp = !foreign_function_call_active;
-
-    SetSymbolValue(INTERRUPT_PENDING, NIL);
-
-    if (maybe_gc_pending) {
-	maybe_gc_pending = FALSE;
-	if (were_in_lisp)
-	    fake_foreign_function_call(context);
-	funcall0(SymbolFunction(MAYBE_GC));
-	if (were_in_lisp)
-	    undo_fake_foreign_function_call(context);
-    }
-    if (pending_signal) {
-	int signal, code;
-
-	signal = pending_signal;
-	code = pending_code;
-	pending_signal = 0;
-	pending_code = 0;
-	interrupt_handle_now(signal, code, context);
-    }
-    context->sc_mask = pending_mask;
-    pending_mask = 0;
-}
-
-
-/****************************************************************\
-* interrupt_handle_now, maybe_now_maybe_later                    *
-*    the two main signal handlers.                               *
-\****************************************************************/
-
-void interrupt_handle_now(int signal, int code, struct sigcontext *context)
-{
-    int were_in_lisp;
-    union interrupt_handler handler;
-    
-    handler = interrupt_handlers[signal];
-
-    if(handler.c==SIG_IGN)
-	return;
-
-    were_in_lisp = !foreign_function_call_active;
-    if (were_in_lisp)
-        fake_foreign_function_call(context);
-    
-    /* Allow signals again. */
-    sigsetmask(context->sc_mask);
-
-    if (handler.c==SIG_DFL)
-	/* This can happen if someone tries to ignore or default on of the */
-	/* signals we need for runtime support, and the runtime support */
-	/* decides to pass on it.  */
-	lose("interrupt_handle_now: No handler for signal %d?\n", signal);
-    else if (LowtagOf(handler.lisp) == type_FunctionPointer)
-	funcall3(handler.lisp, make_fixnum(signal), make_fixnum(code),
-	         alloc_sap(context));
-    else
-        (*handler.c)(signal, code, context);
-    
-    if (were_in_lisp)
-        undo_fake_foreign_function_call(context);
-}
-
-static void maybe_now_maybe_later(int signal, int code,
-				  struct sigcontext *context)
-{
-    if (SymbolValue(INTERRUPTS_ENABLED) == NIL) {
-        pending_signal = signal;
-        pending_code = code;
-        pending_mask = context->sc_mask;
-        context->sc_mask |= BLOCKABLE;
-        SetSymbolValue(INTERRUPT_PENDING, T);
-    } else if ((!foreign_function_call_active)
-	       && arch_pseudo_atomic_atomic(context)) {
-        pending_signal = signal;
-        pending_code = code;
-        pending_mask = context->sc_mask;
-        context->sc_mask |= BLOCKABLE;
-	arch_set_pseudo_atomic_interrupted(context);
-    } else
-        interrupt_handle_now(signal, code, context);
-}
-
-/****************************************************************\
-* Stuff to detect and handle hitting the gc trigger.             *
-\****************************************************************/
-
-#ifndef INTERNAL_GC_TRIGGER
-static boolean gc_trigger_hit(int signal, int code, struct sigcontext *context)
-{
-    if (current_auto_gc_trigger == NULL)
-	return FALSE;
-    else{
-	lispobj *badaddr=(lispobj *)arch_get_bad_addr(signal, code, context);
-
-	return (badaddr >= current_auto_gc_trigger &&
-		badaddr < current_dynamic_space + DYNAMIC_SPACE_SIZE);
-    }
-}
-#endif
-
-
-boolean interrupt_maybe_gc(int signal, int code, struct sigcontext *context)
-{
-    if (!foreign_function_call_active
-#ifndef INTERNAL_GC_TRIGGER
-		  && gc_trigger_hit(signal, code, context)
-#endif
-	) {
-#ifndef INTERNAL_GC_TRIGGER
-	clear_auto_gc_trigger();
-#endif
-
-	if (arch_pseudo_atomic_atomic(context)) {
-	    maybe_gc_pending = TRUE;
-	    if (pending_signal == 0) {
-		pending_mask = context->sc_mask;
-		context->sc_mask |= BLOCKABLE;
-	    }
-	    arch_set_pseudo_atomic_interrupted(context);
-	}
-	else {
-	    fake_foreign_function_call(context);
-	    funcall0(SymbolFunction(MAYBE_GC));
-	    undo_fake_foreign_function_call(context);
-	}
-
-	return TRUE;
-    }else
-	return FALSE;
-}
-
-/****************************************************************\
-* Noise to install handlers.                                     *
-\****************************************************************/
-
-void interrupt_install_low_level_handler
-    (int signal,
-     void handler(int signal, int code, struct sigcontext *handler))
-{
-    struct sigvec sv;
-
-    sv.sv_handler=handler;
-    sv.sv_mask=BLOCKABLE;
-    sv.sv_flags=0;
-
-    sigvec(signal,&sv,NULL);
-
-    interrupt_low_level_handlers[signal]=(handler==SIG_DFL ? 0 : handler);
-}
-
-unsigned long install_handler(int signal,
-			      void handler(int signal, int code,
-					   struct sigcontext *handler))
-{
-    struct sigvec sv;
-    int oldmask;
-    union interrupt_handler oldhandler;
-
-    oldmask = sigblock(sigmask(signal));
-
-    if(interrupt_low_level_handlers[signal]==0){
-	if(handler==SIG_DFL || handler==SIG_IGN)
-	    sv.sv_handler = handler;
-	else if (sigmask(signal)&BLOCKABLE)
-	    sv.sv_handler = maybe_now_maybe_later;
-	else
-	    sv.sv_handler = interrupt_handle_now;
-
-	sv.sv_mask = BLOCKABLE;
-	sv.sv_flags = 0;
-
-	sigvec(signal, &sv, NULL);
-    }
-
-    oldhandler = interrupt_handlers[signal];
-    interrupt_handlers[signal].c = handler;
-
-    sigsetmask(oldmask);
-
-    return (unsigned long)oldhandler.lisp;
-}
-
-void interrupt_init(void)
-{
-    int i;
-
-    for (i = 0; i < NSIG; i++)
-        interrupt_handlers[i].c = SIG_DFL;
-}
diff --git a/lisp/interrupt.h b/lisp/interrupt.h
deleted file mode 100644
index 22347878cd98ecdba6fda167ce2b9beafa448085..0000000000000000000000000000000000000000
--- a/lisp/interrupt.h
+++ /dev/null
@@ -1,44 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.h,v 1.2 1992/09/08 20:26:29 wlott Exp $ */
-
-#if !defined(_INCLUDE_INTERRUPT_H_)
-#define _INCLUDE_INTERRUPT_H_
-
-#include <signal.h>
-
-#define MAX_INTERRUPTS (4096)
-
-extern struct sigcontext *lisp_interrupt_contexts[MAX_INTERRUPTS];
-
-union interrupt_handler {
-	lispobj lisp;
-	void (*c)(int signal, int code, struct sigcontext *scp);
-};
-
-extern void interrupt_init(void);
-extern void fake_foreign_function_call(struct sigcontext *context);
-extern void undo_fake_foreign_function_call(struct sigcontext *context);
-extern void interrupt_handle_now(int signal, int code, struct sigcontext *scp);
-extern void interrupt_handle_pending(struct sigcontext *scp);
-extern void interrupt_internal_error(int signal, int code,
-				     struct sigcontext *scp,
-				     boolean continuable);
-extern boolean interrupt_maybe_gc(int sig, int code, struct sigcontext *scp);
-extern void interrupt_install_low_level_handler
-    (int signal,
-     void handler(int signal, int code, struct sigcontext *scp));
-extern unsigned long install_handler(int signal,
-				     void handler(int signal, int code,
-						  struct sigcontext *handler));
-
-extern union interrupt_handler interrupt_handlers[NSIG];
-
-#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))
-
-#endif
diff --git a/lisp/lisp.c b/lisp/lisp.c
deleted file mode 100644
index b235c46ba58afa3d809f40530a3f6ebe7c29bb8b..0000000000000000000000000000000000000000
--- a/lisp/lisp.c
+++ /dev/null
@@ -1,217 +0,0 @@
-/*
- * main() entry point for a stand alone lisp image.
- *
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/lisp.c,v 1.2 1992/09/08 20:25:21 wlott Exp $
- *
- */
-
-#include <stdio.h>
-#include <sys/types.h>
-#include <stdlib.h>
-#include <sys/file.h>
-#include <sys/param.h>
-#include <sys/stat.h>
-
-#include "signal.h"
-
-#include "lisp.h"
-#include "internals.h"
-#include "alloc.h"
-#include "vars.h"
-#include "globals.h"
-#include "os.h"
-#include "arch.h"
-#include "gc.h"
-#include "monitor.h"
-#include "validate.h"
-#include "interrupt.h"
-#include "core.h"
-#include "save.h"
-#include "lispregs.h"
-
-lispobj lisp_nil_reg = NIL;
-char *lisp_csp_reg, *lisp_bsp_reg;
-
-
-/* SIGINT handler that invokes the monitor. */
-
-static void sigint_handler(int signal, int code, struct sigcontext *context)
-{
-    printf("\nSIGINT hit at 0x%08X\n", SC_PC(context));
-    ldb_monitor();
-}
-
-/* Not static, because we want to be able to call it from lisp land. */
-void sigint_init(void)
-{
-    install_handler(SIGINT, sigint_handler);
-}
-
-
-/* Noise to convert argv and argp into lists. */
-
-static lispobj alloc_str_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;
-}
-
-
-/* stuff to start a kernel core */
-
-extern void call_on_stack(void fn(), os_vm_address_t new_sp);
-
-void call_initial_function()
-{
-    funcall0(SymbolFunction(INITIAL_FUNCTION));
-    printf("%%INITIAL-FUNCTION returned?\n");
-}
-
-void call_ldb_monitor()
-{
-    while (1)
-	ldb_monitor();
-}
-
-
-
-/* And here be main. */
-
-void main(int argc, char *argv[], char *envp[])
-{
-    char *arg, **argptr;
-    char *core = NULL, *default_core;
-    boolean restore_state, monitor;
-
-#ifdef MACH
-    mach_init();
-#endif
-#ifdef parisc
-    printf("lisp running, pid=%d\n", getpid());
-#endif
-
-    set_lossage_handler(ldb_monitor);
-
-    define_var("nil", NIL, TRUE);
-    define_var("t", T, TRUE);
-    monitor = FALSE;
-
-    argptr = argv;
-    while ((arg = *++argptr) != NULL) {
-        if (strcmp(arg, "-core") == 0) {
-            if (core != NULL) {
-                fprintf(stderr, "can only specify 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);
-            }
-        }
-	else if (strcmp(arg, "-monitor") == 0) {
-	    monitor = TRUE;
-	}
-    }
-
-    default_core = arch_init();
-    if (default_core == NULL)
-	default_core = "lisp.core";
-
-    /* Note: the /usr/misc/.cmucl/lib/ default path is also wired into */
-    /* the lisp code in .../code/save.lisp. */
-
-    if (core == NULL) {
-	extern char *getenv(char *var);
-	static char buf[MAXPATHLEN];
-	char *lib = getenv("CMUCLLIB");
-
-	if (lib != NULL) {
-	    char *dst;
-	    struct stat statbuf;
-
-	    do {
-		dst = buf;
-		while (*lib != '\0' && *lib != ':')
-		    *dst++ = *lib++;
-		if (dst != buf && dst[-1] != '/')
-		    *dst++ = '/';
-		strcpy(dst, default_core);
-		if (stat(buf, &statbuf) == 0) {
-		    core = buf;
-		    break;
-		}
-	    } while (*lib++ == ':');
-	}
-	if (core == NULL) {
-	    strcpy(buf, "/usr/misc/.cmucl/lib/");
-	    strcat(buf, default_core);
-	    core = buf;
-	}
-    }
-
-    os_init();
-    gc_init();
-    validate();
-    globals_init();
-
-    restore_state = load_core_file(core);
-
-    if (!restore_state) {
-#ifdef BINDING_STACK_POINTER
-	SetSymbolValue(BINDING_STACK_POINTER, (lispobj)binding_stack);
-#endif
-#ifdef INTERNAL_GC_TRIGGER
-	SetSymbolValue(INTERNAL_GC_TRIGGER, fixnum(-1));
-#endif
-    }
-
-    interrupt_init();
-
-    arch_install_interrupt_handlers();
-    os_install_interrupt_handlers();
-
-    /* Convert the argv and envp to something Lisp can grok. */
-    SetSymbolValue(LISP_COMMAND_LINE_LIST, alloc_str_list(argv));
-    SetSymbolValue(LISP_ENVIRONMENT_LIST, alloc_str_list(envp));
-
-#ifdef PSEUDO_ATOMIC_ATOMIC
-    /* Turn on pseudo atomic for when we call into lisp. */
-    SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, fixnum(1));
-    SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, fixnum(0));
-#endif
-
-    /* Pick off sigint until the lisp system gets far enough along to */
-    /* install it's own. */
-    sigint_init();
-
-    if (restore_state) {
-	if (monitor) {
-	    printf("exit ldb monitor to restore\n");
-	    ldb_monitor();
-	}
-	restore();
-    }
-    else
-	call_on_stack(monitor ? call_ldb_monitor : call_initial_function,
-#ifdef NUMBER_STACK_GROWS_UP
-			NUMBER_STACK_START
-#else
-			NUMBER_STACK_START+NUMBER_STACK_SIZE
-#endif
-			);
-}
diff --git a/lisp/lisp.h b/lisp/lisp.h
deleted file mode 100644
index 2ea27b4f251965daf83625448097273cebb49ab1..0000000000000000000000000000000000000000
--- a/lisp/lisp.h
+++ /dev/null
@@ -1,43 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/lisp.h,v 1.1 1992/07/28 20:14:40 wlott Exp $ */
-
-#ifndef _LISP_H_
-#define _LISP_H_
-
-#define lowtag_Bits 3
-#define lowtag_Mask ((1<<lowtag_Bits)-1)
-#define LowtagOf(obj) ((obj)&lowtag_Mask)
-#define type_Bits 8
-#define type_Mask ((1<<type_Bits)-1)
-#define TypeOf(obj) ((obj)&type_Mask)
-#define HeaderValue(obj) ((unsigned long) ((obj)>>type_Bits))
-
-#define Pointerp(obj) ((obj) & 0x01)
-#define PTR(obj) ((obj)&~lowtag_Mask)
-
-#define CONS(obj) ((struct cons *)((obj)-type_ListPointer))
-#define SYMBOL(obj) ((struct symbol *)((obj)-type_OtherPointer))
-#define FDEFN(obj) ((struct fdefn *)((obj)-type_OtherPointer))
-
-typedef unsigned long lispobj;
-
-#define make_fixnum(n) ((lispobj)((n)<<2))
-#define fixnum_value(n) (((long)n)>>2)
-
-#define boolean int
-#ifndef TRUE
-#define TRUE 1
-#endif
-#ifndef FALSE
-#define FALSE 0
-#endif
-
-#define SymbolValue(sym) \
-    (((struct symbol *)((sym)-type_OtherPointer))->value)
-#define SetSymbolValue(sym,val) \
-    (((struct symbol *)((sym)-type_OtherPointer))->value = (val))
-
-/* This only words for static symbols. */
-#define SymbolFunction(sym) \
-    (((struct fdefn *)(SymbolValue(sym)-type_OtherPointer))->function)
-
-#endif _LISP_H_
diff --git a/lisp/lispregs.h b/lisp/lispregs.h
deleted file mode 100644
index 956f072244b1ae104c88475e5f49aff18e54c852..0000000000000000000000000000000000000000
--- a/lisp/lispregs.h
+++ /dev/null
@@ -1,25 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/lispregs.h,v 1.1 1992/07/28 20:14:41 wlott Exp $ */
-
-#ifdef mips
-#include "mips-lispregs.h"
-#endif
-
-#ifdef sparc
-#include "sparc-lispregs.h"
-#endif
-
-#ifdef ibmrt
-#include "rt-lispregs.h"
-#endif
-
-#ifdef i386
-#include "x86-lispregs.h"
-#endif
-
-#ifdef parisc
-#include "hppa-lispregs.h"
-#endif
-
-#ifndef LANGUAGE_ASSEMBLY
-extern char *lisp_register_names[];
-#endif
diff --git a/lisp/mach-os.c b/lisp/mach-os.c
deleted file mode 100644
index 70809902fecae60b817df9979f1019bcfa061e9f..0000000000000000000000000000000000000000
--- a/lisp/mach-os.c
+++ /dev/null
@@ -1,169 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/mach-os.c,v 1.3 1992/09/16 22:26:53 wlott Exp $
- *
- * OS-dependent routines.  This file (along with os.h) exports an
- * OS-independent interface to the operating system VM facilities.
- * Suprisingly, this interface looks a lot like the Mach interface
- * (but simpler in some places).  For some operating systems, a subset
- * of these functions will have to be emulated.
- *
- * This is the Mach version.
- *
- */
-
-#include <stdio.h>
-#include <mach.h>
-#include <sys/file.h>
-#include "./signal.h"
-#include "os.h"
-#include "arch.h"
-#include "interrupt.h"
-
-#define MAX_SEGS 32
-
-static struct segment {
-    vm_address_t start;
-    vm_size_t length;
-} addr_map[MAX_SEGS];
-static int segments = -1;
-
-vm_size_t os_vm_page_size;
-
-#if defined(i386) || defined(parisc)
-mach_port_t task_self()
-{
-    return mach_task_self();
-}
-#endif
-
-void os_init()
-{
-	os_vm_page_size = vm_page_size;
-}
-
-os_vm_address_t os_validate(vm_address_t addr, vm_size_t len)
-{
-    kern_return_t res;
-
-    res = vm_allocate(task_self(), &addr, len, addr==NULL);
-
-    if (res != KERN_SUCCESS)
-	return 0;
-
-    segments = -1;
-
-    vm_protect(task_self(), addr, len, FALSE,
-	       VM_PROT_READ|VM_PROT_WRITE|VM_PROT_EXECUTE);
-
-    return addr;
-}
-
-void os_invalidate(vm_address_t addr, vm_size_t len)
-{
-    kern_return_t res;
-
-    res = vm_deallocate(task_self(), addr, len);
-
-    if (res != KERN_SUCCESS)
-        mach_error("Could not vm_allocate memory: ", res);
-
-    segments = -1;
-}
-
-vm_address_t os_map(int fd, int offset, vm_address_t addr, vm_size_t len)
-{
-    kern_return_t res;
-
-    res = map_fd(fd, offset, &addr, 0, len);
-
-    if (res != KERN_SUCCESS) {
-	char buf[256];
-	sprintf(buf, "Could not map_fd(%d, %d, 0x%08x, 0x%08x): ",
-		fd, offset, addr, len);
-        mach_error(buf, res);
-
-	lseek(fd, offset, L_SET);
-	read(fd, addr, len);
-    }
-
-    segments = -1;
-
-    vm_protect(task_self(), addr, len, FALSE,
-	       VM_PROT_READ|VM_PROT_WRITE|VM_PROT_EXECUTE);
-
-    return addr;
-}
-
-void os_flush_icache(vm_address_t address, vm_size_t length)
-{
-#ifdef mips
-	vm_machine_attribute_val_t flush;
-	kern_return_t kr;
-
-	flush = MATTR_VAL_ICACHE_FLUSH;
-
-	kr = vm_machine_attribute(task_self(), address, length,
-				  MATTR_CACHE, &flush);
-	if (kr != KERN_SUCCESS)
-		mach_error("Could not flush the instruction cache", kr);
-#endif
-}
-
-void os_protect(vm_address_t address, vm_size_t length, vm_prot_t protection)
-{
-	vm_protect(task_self(), address, length, FALSE, protection);
-}
-
-boolean valid_addr(test)
-vm_address_t test;
-{
-    vm_address_t addr;
-    vm_size_t size;
-    int bullshit;
-    int curseg;
-
-    if (segments == -1) {
-        addr = 0;
-        curseg = 0;
-
-        while (1) {
-            if (vm_region(task_self(), &addr, &size, &bullshit, &bullshit, &bullshit, &bullshit, &bullshit, &bullshit) != KERN_SUCCESS)
-                break;
-
-            if (curseg > 0 && addr_map[curseg-1].start + addr_map[curseg-1].length == addr)
-                addr_map[curseg-1].length += size;
-            else {
-                addr_map[curseg].start = addr;
-                addr_map[curseg].length = size;
-                curseg++;
-            }
-
-            addr += size;
-        }
-
-        segments = curseg;
-    }
-    
-    for (curseg = 0; curseg < segments; curseg++)
-        if (addr_map[curseg].start <= test && test < addr_map[curseg].start + addr_map[curseg].length)
-            return TRUE;
-    return FALSE;
-}
-
-#ifndef ibmrt
-static void sigbus_handler(int signal, int code, struct sigcontext *context)
-{
-    if(!interrupt_maybe_gc(signal, code, context))
-	interrupt_handle_now(signal, code, context);
-}
-#endif
-
-void os_install_interrupt_handlers(void)
-{
-#ifndef ibmrt
-    interrupt_install_low_level_handler(SIGBUS,sigbus_handler);
-#endif
-#ifdef mips
-    interrupt_install_low_level_handler(SIGSEGV,sigbus_handler);
-#endif
-}
diff --git a/lisp/mach-os.h b/lisp/mach-os.h
deleted file mode 100644
index ff3b27570db74dcff17ec2508ff2125eb824ed65..0000000000000000000000000000000000000000
--- a/lisp/mach-os.h
+++ /dev/null
@@ -1,12 +0,0 @@
-#include <mach.h>
-
-typedef vm_address_t os_vm_address_t;
-typedef vm_size_t os_vm_size_t;
-typedef vm_offset_t os_vm_offset_t;
-typedef vm_prot_t os_vm_prot_t;
-
-#define OS_VM_PROT_READ VM_PROT_READ
-#define OS_VM_PROT_WRITE VM_PROT_WRITE
-#define OS_VM_PROT_EXECUTE VM_PROT_EXECUTE
-
-#define OS_VM_DEFAULT_PAGESIZE	4096
diff --git a/lisp/mips-arch.c b/lisp/mips-arch.c
deleted file mode 100644
index bc5ac7812d9709f70b6b7a654065792c14a58262..0000000000000000000000000000000000000000
--- a/lisp/mips-arch.c
+++ /dev/null
@@ -1,297 +0,0 @@
-#include <stdio.h>
-#include <mips/cpu.h>
-
-#include "lisp.h"
-#include "globals.h"
-#include "validate.h"
-#include "os.h"
-#include "internals.h"
-#include "arch.h"
-#include "lispregs.h"
-#include "signal.h"
-#include "alloc.h"
-#include "interrupt.h"
-#include "interr.h"
-#include "breakpoint.h"
-
-char *arch_init(void)
-{
-    return NULL;
-}
-
-os_vm_address_t arch_get_bad_addr(int sig, int code, struct sigcontext *scp)
-{
-    /* Finding the bad address on the mips is easy. */
-    return (os_vm_address_t)scp->sc_badvaddr;
-}
-
-void arch_skip_instruction(scp)
-struct sigcontext *scp;
-{
-    /* Skip the offending instruction */
-    if (scp->sc_cause & CAUSE_BD)
-        emulate_branch(scp, *(unsigned long *)scp->sc_pc);
-    else
-        scp->sc_pc += 4;
-}
-
-unsigned char *arch_internal_error_arguments(struct sigcontext *scp)
-{
-    if (scp->sc_cause & CAUSE_BD)
-	return (unsigned char *)(scp->sc_pc+8);
-    else
-	return (unsigned char *)(scp->sc_pc+4);
-}
-
-boolean arch_pseudo_atomic_atomic(struct sigcontext *scp)
-{
-    return (scp->sc_regs[reg_ALLOC] & 1);
-}
-
-#define PSEUDO_ATOMIC_INTERRUPTED_BIAS 0x7f000000
-
-void arch_set_pseudo_atomic_interrupted(struct sigcontext *scp)
-{
-    scp->sc_regs[reg_NL4] += PSEUDO_ATOMIC_INTERRUPTED_BIAS;
-}
-
-unsigned long arch_install_breakpoint(void *pc)
-{
-    unsigned long *ptr = (unsigned long *)pc;
-    unsigned long result = *ptr;
-    *ptr = (trap_Breakpoint << 16) | 0xd;
-
-    os_flush_icache((os_vm_address_t)ptr, sizeof(unsigned long));
-
-    return result;
-}
-
-void arch_remove_breakpoint(void *pc, unsigned long orig_inst)
-{
-    *(unsigned long *)pc = orig_inst;
-
-    os_flush_icache((os_vm_address_t)pc, sizeof(unsigned long));
-}
-
-static unsigned long *skipped_break_addr, displaced_after_inst;
-static int orig_sigmask;
-
-void arch_do_displaced_inst(struct sigcontext *scp,
-				   unsigned long orig_inst)
-{
-    unsigned long *pc = (unsigned long *)scp->sc_pc;
-    unsigned long *break_pc, *next_pc;
-    unsigned long next_inst;
-    int opcode;
-    struct sigcontext tmp;
-
-    orig_sigmask = scp->sc_mask;
-    scp->sc_mask = BLOCKABLE;
-
-    /* Figure out where the breakpoint is, and what happens next. */
-    if (scp->sc_cause & CAUSE_BD) {
-	break_pc = pc+1;
-	next_inst = *pc;
-    }
-    else {
-	break_pc = pc;
-	next_inst = orig_inst;
-    }
-
-    /* Put the original instruction back. */
-    *break_pc = orig_inst;
-    os_flush_icache((os_vm_address_t)break_pc, sizeof(unsigned long));
-    skipped_break_addr = break_pc;
-
-    /* Figure out where it goes. */
-    opcode = next_inst >> 26;
-    if (opcode == 1 || ((opcode & 0x3c) == 0x4) || ((next_inst & 0xf00e0000) == 0x80000000)) {
-	tmp = *scp;
-	emulate_branch(&tmp, next_inst);
-        next_pc = (unsigned long *)tmp.sc_pc;
-    }
-    else
-	next_pc = pc+1;
-
-    displaced_after_inst = *next_pc;
-    *next_pc = (trap_AfterBreakpoint << 16) | 0xd;
-    os_flush_icache((os_vm_address_t)next_pc, sizeof(unsigned long));
-
-    sigreturn(scp);
-}
-
-static void sigtrap_handler(int signal, int code, struct sigcontext *scp)
-{
-    /* Don't disallow recursive breakpoint traps.  Otherwise, we can't */
-    /* use debugger breakpoints anywhere in here. */
-    sigsetmask(scp->sc_mask);
-
-    switch (code) {
-      case trap_PendingInterrupt:
-	arch_skip_instruction(scp);
-	interrupt_handle_pending(scp);
-	break;
-
-      case trap_Halt:
-	fake_foreign_function_call(scp);
-	lose("%%primitive halt called; the party is over.\n");
-
-      case trap_Error:
-      case trap_Cerror:
-	interrupt_internal_error(signal, code, scp, code==trap_Cerror);
-	break;
-
-      case trap_Breakpoint:
-	handle_breakpoint(signal, code, scp);
-	break;
-
-      case trap_FunctionEndBreakpoint:
-	scp->sc_pc = (int)handle_function_end_breakpoint(signal, code, scp);
-	break;
-
-      case trap_AfterBreakpoint:
-	*skipped_break_addr = (trap_Breakpoint << 16) | 0xd;
-	os_flush_icache((os_vm_address_t)skipped_break_addr,
-			sizeof(unsigned long));
-	skipped_break_addr = NULL;
-	*(unsigned long *)scp->sc_pc = displaced_after_inst;
-	os_flush_icache((os_vm_address_t)scp->sc_pc, sizeof(unsigned long));
-	scp->sc_mask = orig_sigmask;
-	break;
-
-      default:
-	interrupt_handle_now(signal, code, scp);
-	break;
-    }
-}
-
-#define FIXNUM_VALUE(lispobj) (((int)lispobj)>>2)
-
-static void sigfpe_handler(int signal, int code, struct sigcontext *scp)
-{
-    unsigned long bad_inst;
-    unsigned int op, rs, rt, rd, funct, dest;
-    int immed;
-    long result;
-
-    if (scp->sc_cause & CAUSE_BD)
-        bad_inst = *(unsigned long *)(scp->sc_pc + 4);
-    else
-        bad_inst = *(unsigned long *)(scp->sc_pc);
-
-    op = (bad_inst >> 26) & 0x3f;
-    rs = (bad_inst >> 21) & 0x1f;
-    rt = (bad_inst >> 16) & 0x1f;
-    rd = (bad_inst >> 11) & 0x1f;
-    funct = bad_inst & 0x3f;
-    immed = (((int)(bad_inst & 0xffff)) << 16) >> 16;
-
-    switch (op) {
-        case 0x0: /* SPECIAL */
-            switch (funct) {
-                case 0x20: /* ADD */
-		    /* Check to see if this is really a pa_interrupted hit */
-		    if (rs == reg_ALLOC && rt == reg_NL4) {
-			scp->sc_regs[reg_ALLOC] +=
-			    (scp->sc_regs[reg_NL4] -
-			     PSEUDO_ATOMIC_INTERRUPTED_BIAS);
-			arch_skip_instruction(scp);
-			interrupt_handle_pending(scp);
-			return;
-		    }
-                    result = FIXNUM_VALUE(scp->sc_regs[rs]) + FIXNUM_VALUE(scp->sc_regs[rt]);
-                    dest = rd;
-                    break;
-
-                case 0x22: /* SUB */
-                    result = FIXNUM_VALUE(scp->sc_regs[rs]) - FIXNUM_VALUE(scp->sc_regs[rt]);
-                    dest = rd;
-                    break;
-
-                default:
-                    dest = 32;
-                    break;
-            }
-            break;
-
-        case 0x8: /* ADDI */
-            result = FIXNUM_VALUE(scp->sc_regs[rs]) + (immed>>2);
-            dest = rt;
-            break;
-
-        default:
-            dest = 32;
-            break;
-    }
-
-    if (dest < 32) {
-        current_dynamic_space_free_pointer =
-            (lispobj *) scp->sc_regs[reg_ALLOC];
-
-        scp->sc_regs[dest] = alloc_number(result);
-
-	scp->sc_regs[reg_ALLOC] =
-	    (unsigned long) current_dynamic_space_free_pointer;
-
-        arch_skip_instruction(scp);
-
-    }
-    else
-        interrupt_handle_now(signal, code, scp);
-}
-
-void arch_install_interrupt_handlers()
-{
-    interrupt_install_low_level_handler(SIGTRAP,sigtrap_handler);
-    interrupt_install_low_level_handler(SIGFPE,sigfpe_handler);
-}
-
-extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
-
-lispobj funcall0(lispobj function)
-{
-    lispobj *args = current_control_stack_pointer;
-
-    return call_into_lisp(function, args, 0);
-}
-
-lispobj funcall1(lispobj function, lispobj arg0)
-{
-    lispobj *args = current_control_stack_pointer;
-
-    current_control_stack_pointer += 1;
-    args[0] = arg0;
-
-    return call_into_lisp(function, args, 1);
-}
-
-lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1)
-{
-    lispobj *args = current_control_stack_pointer;
-
-    current_control_stack_pointer += 2;
-    args[0] = arg0;
-    args[1] = arg1;
-
-    return call_into_lisp(function, args, 2);
-}
-
-lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2)
-{
-    lispobj *args = current_control_stack_pointer;
-
-    current_control_stack_pointer += 3;
-    args[0] = arg0;
-    args[1] = arg1;
-    args[2] = arg2;
-
-    return call_into_lisp(function, args, 3);
-}
-
-
-/* This is apparently called by emulate_branch, but isn't defined.  So */
-/* just do nothing and hope it works... */
-
-void cacheflush(void)
-{
-}
diff --git a/lisp/mips-assem.S b/lisp/mips-assem.S
deleted file mode 100644
index df9b7f53f1e3d0f7bcdee4a63fcb365658491ae9..0000000000000000000000000000000000000000
--- a/lisp/mips-assem.S
+++ /dev/null
@@ -1,363 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/mips-assem.S,v 1.3 1993/01/10 17:27:07 wlott Exp $ */
-#include <machine/regdef.h>
-
-#include "internals.h"
-#include "lispregs.h"
-#include "globals.h"
-
-#if !defined(s8)
-#define s8 $30
-#endif
-
-/*
- * Function to transfer control into lisp.
- */
-	.text
-	.globl	call_into_lisp
-	.ent	call_into_lisp
-call_into_lisp:
-#define framesize 12*4
-	subu	sp, framesize
-	.frame	sp, framesize, ra
-	/* Save all the C regs. */
-	.mask	0xc0ff0000, 0
-	sw	ra, framesize(sp)
-	sw	s8, framesize-4(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	ra, zero
-
-	li	reg_NIL, NIL
-
-	/* Start pseudo-atomic. */
-	.set	noreorder
-	li	reg_NL4, -1
-	li	reg_ALLOC, 1
-        .set    reorder
-
-	/* No longer in foreign call. */
-	sw	zero, foreign_function_call_active
-
-	/* Load the allocation pointer, preserving the low-bit of alloc */
-	lw	v0, current_dynamic_space_free_pointer
-	add	reg_ALLOC, v0
-
-	/* Load the rest of the LISP state. */
-	lw	reg_BSP, current_binding_stack_pointer
-	lw	reg_CSP, current_control_stack_pointer
-	lw	reg_OCFP, current_control_frame_pointer
-
-	/* Check for interrupt */
-        .set    noreorder
-	add	reg_ALLOC, reg_NL4
-	.set	reorder
-
-	/* Pass in args */
-	move	reg_LEXENV, $4
-	move	reg_CFP, $5
-	sll	reg_NARGS, $6, 2
-	lw	reg_A0, 0(reg_CFP)
-	lw	reg_A1, 4(reg_CFP)
-	lw	reg_A2, 8(reg_CFP)
-	lw	reg_A3, 12(reg_CFP)
-	lw	reg_A4, 16(reg_CFP)
-	lw	reg_A5, 20(reg_CFP)
-
-	/* Calculate LRA */
-	la	reg_LRA, lra + type_OtherPointer
-
-	/* Indirect closure */
-	lw	reg_CODE, 4-1(reg_LEXENV)
-
-	/* Jump into lisp land. */
-	addu	reg_LIP, reg_CODE, 6*4 - type_FunctionPointer
-	j	reg_LIP
-
-	.set	noreorder
-	.align	3
-lra:
-	.word	type_ReturnPcHeader
-
-	/* Multiple value return spot, clear stack */
-	move	reg_CSP, reg_OCFP
-	nop
-
-	/* Set pseudo-atomic flag. */
-	li	reg_NL4, -1
-	addu	reg_ALLOC, 1
-	.set	reorder
-
-	/* Pass one return value back to C land. */
-	move	v0, reg_A0
-
-	/* Save LISP registers. */
-	subu	reg_NL0, reg_ALLOC, 1
-	sw	reg_NL0, current_dynamic_space_free_pointer
-	sw	reg_BSP, current_binding_stack_pointer
-	sw	reg_CSP, current_control_stack_pointer
-	sw	reg_CFP, current_control_frame_pointer
-
-	/* Back in foreign function call */
-	sw	reg_CFP, foreign_function_call_active
-
-	/* Check for interrupt */
-	.set	noreorder
-	add	reg_ALLOC, reg_NL4
-	.set	reorder
-
-	/* Restore C regs */
-	lw	ra, framesize(sp)
-	lw	s8, framesize-4(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 up a stack frame. */
-	move	reg_OCFP, reg_CFP
-	move	reg_CFP, reg_CSP
-	addu	reg_CSP, reg_CFP, 32
-	sw	reg_OCFP, 0(reg_CFP)
-	subu	reg_NL4, reg_LIP, reg_CODE
-	addu	reg_NL4, type_OtherPointer
-	sw	reg_NL4, 4(reg_CFP)
-	sw	reg_CODE, 8(reg_CFP)
-
-	/* Note: the C stack is already set up. */
-
-	/* Set the pseudo-atomic flag. */
-	.set	noreorder
-	li	reg_NL4, -1
-	addu	reg_ALLOC, 1
-	.set	reorder
-
-	/* Save lisp state. */
-	subu	t0, reg_ALLOC, 1
-	sw	t0, current_dynamic_space_free_pointer
-	sw	reg_BSP, current_binding_stack_pointer
-	sw	reg_CSP, current_control_stack_pointer
-	sw	reg_CFP, current_control_frame_pointer
-
-	/* Mark us as in C land. */
-	sw	reg_CSP, foreign_function_call_active
-
-	/* Were we interrupted? */
-	.set	noreorder
-	add	reg_ALLOC, reg_NL4
-	.set	reorder
-
-	/* Into C land we go. */
-	jal	reg_CFUNC
-
-	/* 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	ra, zero
-
-	/* Turn on pseudo-atomic. */
-	.set	noreorder
-	li	reg_NL4, -1
-	li	reg_ALLOC, 1
-	.set	reorder
-
-	/* Mark us at in Lisp land. */
-	sw	zero, foreign_function_call_active
-
-	/* Restore ALLOC, preserving pseudo-atomic-atomic */
-	lw	a0, current_dynamic_space_free_pointer
-	addu	reg_ALLOC, a0
-
-	/* Check for interrupt */
-	.set	noreorder
-	add	reg_ALLOC, reg_NL4
-	.set	reorder
-
-	/* Restore LRA & CODE (they may have been GC'ed) */
-	lw	reg_CODE, 8(reg_CFP)
-	lw	a0, 4(reg_CFP)
-	subu	a0, type_OtherPointer
-	addu	reg_LIP, reg_CODE, a0
-
-	/* Reset the lisp stack. */
-	/* Note: OCFP and CFP are in saved regs. */
-	move	reg_CSP, reg_CFP
-	move	reg_CFP, reg_OCFP
-
-	/* Return to LISP. */
-	j	reg_LIP
-
-	.end	call_into_c
-
-	.text
-	.globl	start_of_tramps
-start_of_tramps:
-
-/*
- * The undefined-function trampoline.
- */
-        .text
-        .globl  undefined_tramp
-        .ent    undefined_tramp
-undefined_tramp:
-        break   10
-        .byte    4
-        .byte    23
-        .byte    254
-        .byte    204
-        .byte    1
-        .align 2
-        .end    undefined_tramp
-
-/*
- * The closure trampoline.
- */
-        .text
-        .globl  closure_tramp
-        .ent    closure_tramp
-closure_tramp:
-        lw      reg_LEXENV, FDEFN_FUNCTION_OFFSET(reg_FDEFN)
-        lw      reg_L0, CLOSURE_FUNCTION_OFFSET(reg_LEXENV)
-        addu    reg_LIP, reg_L0, FUNCTION_CODE_OFFSET
-        j       reg_LIP
-        .end    closure_tramp
-
-	.text
-	.globl	end_of_tramps
-end_of_tramps:
-
-
-/*
- * Function-end breakpoint magic.
- */
-
-	.text
-	.align	2
-	.set	noreorder
-	.globl	function_end_breakpoint_guts
-function_end_breakpoint_guts:
-	.word	type_ReturnPcHeader
-	beq	zero, zero, 1f
-	nop
-	move	reg_OCFP, reg_CSP
-	addu	reg_CSP, 4
-	li	reg_NARGS, 4
-	move	reg_A1, reg_NIL
-	move	reg_A2, reg_NIL
-	move	reg_A3, reg_NIL
-	move	reg_A4, reg_NIL
-	move	reg_A5, reg_NIL
-1:
-
-	.globl	function_end_breakpoint_trap
-function_end_breakpoint_trap:
-	break	trap_FunctionEndBreakpoint
-	beq	zero, zero, 1b
-	nop
-
-	.globl	function_end_breakpoint_end
-function_end_breakpoint_end:
-	.set	reorder
-
-
-	.text
-	.align	2
-	.globl	call_on_stack
-	.ent	call_on_stack
-call_on_stack:
-	subu	sp, a1, 16
-	jal	a0
-	break	0
-	.end	call_on_stack
-
-	.globl	save_state
-	.ent	save_state
-save_state:
-	subu	sp, 40
-	.frame	sp, 40, ra
-	/* Save all the C regs. */
-	.mask	0xc0ff0000, 0
-	sw	ra, 40(sp)
-	sw	s8, 40-4(sp)
-	sw	s7, 40-8(sp)
-	sw	s6, 40-12(sp)
-	sw	s5, 40-16(sp)
-	sw	s4, 40-20(sp)
-	sw	s3, 40-24(sp)
-	sw	s2, 40-28(sp)
-	sw	s1, 40-32(sp)
-	sw	s0, 40-36(sp)
-
-	/* Should also save the floating point state. */
-
-	move	t0, a0
-	move	a0, sp
-
-	jal	t0
-
-_restore_state:
-
-	lw	ra, 40(sp)
-	lw	s8, 40-4(sp)
-	lw	s7, 40-8(sp)
-	lw	s6, 40-12(sp)
-	lw	s5, 40-16(sp)
-	lw	s4, 40-20(sp)
-	lw	s3, 40-24(sp)
-	lw	s2, 40-28(sp)
-	lw	s1, 40-32(sp)
-	lw	s0, 40-36(sp)
-
-	addu	sp, 40
-	j	ra
-
-	.globl	restore_state
-restore_state:
-	move	sp, a0
-	move	v0, a1
-	j	_restore_state
-	.end	save_state
diff --git a/lisp/mips-lispregs.h b/lisp/mips-lispregs.h
deleted file mode 100644
index cd6d27e09cd20583e67f01fd8df9da5c2b82ca6d..0000000000000000000000000000000000000000
--- a/lisp/mips-lispregs.h
+++ /dev/null
@@ -1,58 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/mips-lispregs.h,v 1.1 1992/07/28 20:16:54 wlott Exp $ */
-
-#ifdef LANGUAGE_ASSEMBLY
-#define REG(num) $num
-#else
-#define REG(num) num
-#endif
-
-#define NREGS	(32)
-
-#define reg_ZERO    REG(0)
-#define reg_NL3     REG(1)
-#define reg_CFUNC   REG(2)
-#define reg_NL4     REG(3)
-#define reg_NL0     REG(4)
-#define reg_NL1     REG(5)
-#define reg_NL2     REG(6)
-#define reg_NARGS   REG(7)
-#define reg_A0      REG(8)
-#define reg_A1      REG(9)
-#define reg_A2      REG(10)
-#define reg_A3      REG(11)
-#define reg_A4      REG(12)
-#define reg_A5      REG(13)
-#define reg_FDEFN   REG(14)
-#define reg_LEXENV  REG(15)
-#define reg_NFP     REG(16)
-#define reg_OCFP    REG(17)
-#define reg_LRA     REG(18)
-#define reg_L0      REG(19)
-#define reg_NIL     REG(20)
-#define reg_BSP     REG(21)
-#define reg_CFP     REG(22)
-#define reg_CSP     REG(23)
-#define reg_L1      REG(24)
-#define reg_ALLOC   REG(25)
-#define reg_NSP     REG(29)
-#define reg_CODE    REG(30)
-#define reg_LIP     REG(31)
-
-#define REGNAMES \
-	"ZERO",		"NL3",		"CFUNC",	"NL4", \
-	"NL0",		"NL1",		"NL2",		"NARGS", \
-	"A0",		"A1",		"A2",		"A3", \
-	"A4",		"A5",		"FDEFN",       	"LEXENV", \
-	"NFP",		"OCFP",		"LRA",		"L0", \
-	"NIL",		"BSP",		"CFP",		"CSP", \
-	"L1",		"ALLOC",	"K0",		"K1", \
-	"GP",		"NSP",		"CODE",		"LIP"
-
-
-#define BOXED_REGISTERS { \
-    reg_A0, reg_A1, reg_A2, reg_A3, reg_A4, reg_A5, reg_FDEFN, reg_LEXENV, \
-    reg_NFP, reg_OCFP, reg_LRA, reg_L0, reg_L1, reg_CODE \
-}
-
-#define SC_REG(sc, n) ((sc)->sc_regs[n])
-#define SC_PC(sc) ((sc)->sc_pc)
diff --git a/lisp/mips-validate.h b/lisp/mips-validate.h
deleted file mode 100644
index 749ac5b01c5de957c9e84058f5990b7c5053e4b0..0000000000000000000000000000000000000000
--- a/lisp/mips-validate.h
+++ /dev/null
@@ -1,19 +0,0 @@
-
-#define READ_ONLY_SPACE_START   (0x01000000)
-#define READ_ONLY_SPACE_SIZE    (0x04000000)
-
-#define STATIC_SPACE_START	(0x05000000)
-#define STATIC_SPACE_SIZE	(0x02000000)
-
-#define DYNAMIC_0_SPACE_START	(0x07000000)
-#define DYNAMIC_1_SPACE_START	(0x0b000000)
-#define DYNAMIC_SPACE_SIZE	(0x04000000)
-
-#define CONTROL_STACK_START	(0x50000000)
-#define CONTROL_STACK_SIZE	(0x00100000)
-
-#define BINDING_STACK_START	(0x60000000)
-#define BINDING_STACK_SIZE	(0x00100000)
-
-#define NUMBER_STACK_START	(0x70000000)
-#define NUMBER_STACK_SIZE	(0x00100000)
diff --git a/lisp/monitor.c b/lisp/monitor.c
deleted file mode 100644
index 50224b8be2ca5f0f8fb751d27e685f040688b02d..0000000000000000000000000000000000000000
--- a/lisp/monitor.c
+++ /dev/null
@@ -1,482 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/monitor.c,v 1.2 1992/12/17 13:20:45 wlott Exp $ */
-
-#include <stdio.h>
-#include <sys/types.h>
-#include <stdlib.h>
-#include <setjmp.h>
-#include <sys/time.h>
-#include <sys/resource.h>
-#include <signal.h>
-
-#include "lisp.h"
-#include "internals.h"
-#include "globals.h"
-#include "vars.h"
-#include "parse.h"
-#include "interrupt.h"
-#include "lispregs.h"
-#include "os.h"
-#include "monitor.h"
-#include "print.h"
-#include "arch.h"
-#include "gc.h"
-#include "search.h"
-#include "purify.h"
-#include "save.h"
-
-extern boolean isatty(int fd);
-
-typedef void cmd(char **ptr);
-
-static cmd call_cmd, dump_cmd, print_cmd, quit, help;
-static cmd flush_cmd, search_cmd, regs_cmd, exit_cmd;
-static cmd gc_cmd, print_context_cmd;
-static cmd backtrace_cmd, purify_cmd, catchers_cmd, save_cmd;
-static cmd grab_sigs_cmd;
-
-static struct cmd {
-    char *cmd, *help;
-    void (*fn)(char **ptr);
-} Cmds[] = {
-    {"help", "Display this info", help},
-    {"?", NULL, help},
-    {"backtrace", "backtrace up to N frames", backtrace_cmd},
-    {"call", "call FUNCTION with ARG1, ARG2, ...", call_cmd},
-    {"catchers", "Print a list of all the active catchers.", catchers_cmd},
-    {"context", "print interrupt context number I.", print_context_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},
-    {"gc", "collect garbage (caveat collector).", gc_cmd},
-    {"grab-signals", "Set the signal handlers to call LDB.", grab_sigs_cmd},
-    {"purify", "purify (caveat purifier).", purify_cmd},
-    {"print", "print object at ADDRESS.", print_cmd},
-    {"p", NULL, print_cmd},
-    {"quit", "quit.", quit},
-    {"regs", "display current lisp regs.", regs_cmd},
-    {"save", "save the current lisp image.", save_cmd},
-    {"search", "search for TYPE starting at ADDRESS for a max of COUNT words.", search_cmd},
-    {"s", NULL, search_cmd},
-    {NULL, NULL, NULL}
-};
-
-
-static jmp_buf curbuf;
-
-
-static int visable(unsigned char c)
-{
-    if (c < ' ' || c > '~')
-        return ' ';
-    else
-        return c;
-}
-
-static void dump_cmd(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: ", (unsigned long)addr);
-        if (valid_addr((os_vm_address_t)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(char **ptr)
-{
-    lispobj obj = parse_lispobj(ptr);
-    
-    print(obj);
-}
-
-static void regs_cmd(char **ptr)
-{
-    printf("CSP\t=\t0x%08X\n", (unsigned long)current_control_stack_pointer);
-    printf("FP\t=\t0x%08X\n", (unsigned long)current_control_frame_pointer);
-#ifndef ibmrt
-    printf("BSP\t=\t0x%08X\n", (unsigned long)current_binding_stack_pointer);
-#endif
-
-    printf("DYNAMIC\t=\t0x%08X\n", (unsigned long)current_dynamic_space);
-#ifdef ibmrt
-    printf("ALLOC\t=\t0x08X\n", SymbolValue(ALLOCATION_POINTER));
-    printf("TRIGGER\t=\t0x08X\n", SymbolValue(INTERNAL_GC_TRIGGER));
-#else
-    printf("ALLOC\t=\t0x%08X\n",
-	   (unsigned long)current_dynamic_space_free_pointer);
-    printf("TRIGGER\t=\t0x%08X\n", (unsigned long)current_auto_gc_trigger);
-#endif
-    printf("STATIC\t=\t0x%08X\n", SymbolValue(STATIC_SPACE_FREE_POINTER));
-    printf("RDONLY\t=\t0x%08X\n", SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
-
-#ifdef MIPS
-    printf("FLAGS\t=\t0x%08x\n", current_flags_register);
-#endif
-}
-
-static void search_cmd(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%08X\n", val, (unsigned long)end);
-
-    while (search_for_type(val, &end, &count)) {
-        printf("found 0x%x at 0x%08X:\n", val, (unsigned long)end);
-        obj = *end;
-        addr = end;
-        end += 2;
-        if (TypeOf(obj) == type_FunctionHeader)
-            print((long)addr | type_FunctionPointer);
-        else if (LowtagOf(obj) == type_OtherImmediate0 || LowtagOf(obj) == type_OtherImmediate1)
-            print((lispobj)addr | type_OtherPointer);
-        else
-            print((lispobj)addr);
-        if (count == -1)
-            return;
-    }
-}
-
-static void call_cmd(char **ptr)
-{
-    lispobj thing = parse_lispobj(ptr), function, result, cons, args[3];
-    int numargs;
-
-    if (LowtagOf(thing) == type_OtherPointer) {
-	switch (TypeOf(*(lispobj *)(thing-type_OtherPointer))) {
-	  case type_SymbolHeader:
-	    for (cons = SymbolValue(INITIAL_FDEFN_OBJECTS);
-		 cons != NIL;
-		 cons = CONS(cons)->cdr) {
-		if (FDEFN(CONS(cons)->car)->name == thing) {
-		    thing = CONS(cons)->car;
-		    goto fdefn;
-		}
-	    }
-	    printf("symbol 0x%08x is undefined.\n", thing);
-	    return;
-
-	  case type_Fdefn:
-	  fdefn:
-	    function = FDEFN(thing)->function;
-	    if (function == NIL) {
-		printf("fdefn 0x%08x is undefined.\n", thing);
-		return;
-	    }
-	    break;
-	  default:
-	    printf(
-	      "0x%08x is not a function pointer, symbol, or fdefn object.\n",
-		   thing);
-	    return;
-	}
-    }
-    else if (LowtagOf(thing) != type_FunctionPointer) {
-        printf("0x%08x is not a function pointer, symbol, or fdefn object.\n",
-	       thing);
-        return;
-    }
-    else
-	function = thing;
-
-    numargs = 0;
-    while (more_p(ptr)) {
-	if (numargs >= 3) {
-	    printf("Too many arguments.  3 at most.\n");
-	    return;
-	}
-	args[numargs++] = parse_lispobj(ptr);
-    }
-
-    switch (numargs) {
-      case 0:
-	result = funcall0(function);
-	break;
-      case 1:
-	result = funcall1(function, args[0]);
-	break;
-      case 2:
-	result = funcall2(function, args[0], args[1]);
-	break;
-      case 3:
-	result = funcall3(function, args[0], args[1], args[2]);
-	break;
-    }
-
-    print(result);
-}
-
-static void flush_cmd(char **ptr)
-{
-    flush_vars();
-}
-
-static void quit(char **ptr)
-{
-    char buf[10];
-
-    printf("Really quit? [y] ");
-    fflush(stdout);
-    fgets(buf, sizeof(buf), stdin);
-    if (buf[0] == 'y' || buf[0] == 'Y' || buf[0] == '\n')
-        exit(0);
-}
-
-static void help(char **ptr)
-{
-    struct cmd *cmd;
-
-    for (cmd = Cmds; cmd->cmd != NULL; cmd++)
-        if (cmd->help != NULL)
-            printf("%s\t%s\n", cmd->cmd, cmd->help);
-}
-
-static int done;
-
-static void exit_cmd(char **ptr)
-{
-    done = TRUE;
-}
-
-static void gc_cmd(char **ptr)
-{
-    collect_garbage();
-}
-
-static void purify_cmd(char **ptr)
-{
-    purify(NIL, NIL);
-}
-
-static void print_context(struct sigcontext *context)
-{
-	int i;
-
-	for (i = 0; i < NREGS; i++) {
-		printf("%s:\t", lisp_register_names[i]);
-		brief_print((lispobj) SC_REG(context, i));
-	}
-	printf("PC:\t\t  0x%08x\n", SC_PC(context));
-}
-
-static void print_context_cmd(char **ptr)
-{
-	int free;
-
-	free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
-	
-        if (more_p(ptr)) {
-		int index;
-
-		index = parse_number(ptr);
-
-		if ((index >= 0) && (index < free)) {
-			printf("There are %d interrupt contexts.\n", free);
-			printf("Printing context %d\n", index);
-			print_context(lisp_interrupt_contexts[index]);
-		} else {
-			printf("There aren't that many/few contexts.\n");
-			printf("There are %d interrupt contexts.\n", free);
-		}
-	} else {
-		if (free == 0)
-			printf("There are no interrupt contexts!\n");
-		else {
-			printf("There are %d interrupt contexts.\n", free);
-			printf("Printing context %d\n", free - 1);
-			print_context(lisp_interrupt_contexts[free - 1]);
-		}
-	}
-}
-
-static void backtrace_cmd(char **ptr)
-{
-    void backtrace(int frames);
-    int n;
-
-    if (more_p(ptr))
-	n = parse_number(ptr);
-    else
-	n = 100;
-
-    printf("Backtrace:\n");
-    backtrace(n);
-}
-
-static void catchers_cmd(char **ptr)
-{
-    struct catch_block *catch;
-
-    catch = (struct catch_block *)SymbolValue(CURRENT_CATCH_BLOCK);
-
-    if (catch == NULL)
-        printf("There are no active catchers!\n");
-    else {
-        while (catch != NULL) {
-            printf("0x%08X:\n\tuwp: 0x%08X\n\tfp: 0x%08X\n\tcode: 0x%08x\n\tentry: 0x%08x\n\ttag: ", (unsigned long)catch, (unsigned long)(catch->current_uwp), (unsigned long)(catch->current_cont), catch->current_code, catch->entry_pc);
-            brief_print((lispobj)catch->tag);
-            catch = catch->previous_catch;
-        }
-    }
-}
-
-static void save_cmd(char **ptr)
-{
-    if (more_p(ptr))
-        save(*ptr);
-    else
-        save("lisp.core");
-}
-
-static void grab_sigs_cmd(char **ptr)
-{
-    extern void sigint_init(void);
-
-    printf("Grabbing signals.\n");
-    sigint_init();
-}
-
-static void sub_monitor(void)
-{
-    struct cmd *cmd, *found;
-    char buf[256];
-    char *line, *ptr, *token;
-    int ambig;
-
-    while (!done) {
-        printf("ldb> ");
-        fflush(stdout);
-        line = gets(buf);
-        if (line == NULL) {
-	    if (isatty(0)) {
-		putchar('\n');
-	        continue;
-	    }
-	    else {
-		fprintf(stderr, "\nEOF on something other than a tty.\n");
-		exit(0);
-	    }
-	}
-        ptr = line;
-        if ((token = parse_token(&ptr)) == NULL)
-            continue;
-        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 {
-            reset_printer();
-            (*found->fn)(&ptr);
-        }
-    }
-}
-
-void ldb_monitor()
-{
-    jmp_buf oldbuf;
-
-    bcopy(curbuf, oldbuf, sizeof(oldbuf));
-
-    printf("LDB monitor\n");
-
-    setjmp(curbuf);
-
-    sub_monitor();
-
-    done = FALSE;
-
-    bcopy(oldbuf, curbuf, sizeof(curbuf));
-}
-
-void throw_to_monitor()
-{
-    longjmp(curbuf, 1);
-}
diff --git a/lisp/monitor.h b/lisp/monitor.h
deleted file mode 100644
index 152e949559321b34eca063cbae308bbda4616af1..0000000000000000000000000000000000000000
--- a/lisp/monitor.h
+++ /dev/null
@@ -1,4 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/monitor.h,v 1.1 1992/07/28 20:15:08 wlott Exp $ */
-
-extern void ldb_monitor(void);
-extern void throw_to_monitor(void);
diff --git a/lisp/os-common.c b/lisp/os-common.c
deleted file mode 100644
index 2a9377015cce26a4079ff0996c355c0b4cb19dc8..0000000000000000000000000000000000000000
--- a/lisp/os-common.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include <stdio.h>
-
-#include "os.h"
-
-void os_zero(addr, length)
-os_vm_address_t addr;
-os_vm_size_t length;
-{
-    os_vm_address_t block_start;
-    os_vm_size_t block_size;
-
-#ifdef DEBUG
-    fprintf(stderr,";;; os_zero: addr: 0x%08x, len: 0x%08x\n",addr,length);
-#endif
-
-    block_start=os_round_up_to_page(addr);
-
-    length-=block_start-addr;
-    block_size=os_trunc_size_to_page(length);
-
-    if(block_start>addr)
-	bzero((char *)addr,block_start-addr);
-    if(block_size<length)
-	bzero((char *)block_start+block_size,length-block_size);
-    
-    if (block_size != 0) {
-	/* Now deallocate and allocate the block so that it */
-	/* faults in  zero-filled. */
-
-	os_invalidate(block_start,block_size);
-	addr=os_validate(block_start,block_size);
-
-	if(addr==NULL || addr!=block_start)
-	    fprintf(stderr,"os_zero: block moved, 0x%08x ==> 0x%08x!\n",block_start,addr);
-    }
-}
-
-os_vm_address_t os_allocate(len)
-os_vm_size_t len;
-{
-    return os_validate((os_vm_address_t)NULL,len);
-}
-
-os_vm_address_t os_allocate_at(os_vm_address_t addr, os_vm_size_t len)
-{
-    return os_validate(addr, len);
-}
-
-void os_deallocate(addr,len)
-os_vm_address_t addr;
-os_vm_size_t len;
-{
-    os_invalidate(addr,len);
-}
-
-os_vm_address_t os_reallocate(os_vm_address_t addr, os_vm_size_t old_len,
-			      os_vm_size_t len)
-{
-    addr=os_trunc_to_page(addr);
-    len=os_round_up_size_to_page(len);
-    old_len=os_round_up_size_to_page(old_len);
-
-    if(addr==NULL)
-	return os_allocate(len);
-    else{
-	long len_diff=len-old_len;
-
-	if(len_diff<0)
-	    os_invalidate(addr+len,-len_diff);
-	else if(len_diff!=0){
-	    os_vm_address_t new=os_validate(addr+old_len,len_diff);
-
-	    if(new==NULL || new!=addr+old_len){
-		if(new!=NULL)
-		    /* allocated alright, but in the wrong place */
-		    os_invalidate(new,len_diff);
-
-		new=os_allocate(len);
-		
-		if(new!=NULL){
-		    bcopy(addr,new,old_len);
-		    os_invalidate(addr,old_len);
-		}
-		
-		addr=new;
-	    }
-	}
-	
-	return addr;
-    }
-}
diff --git a/lisp/os.h b/lisp/os.h
deleted file mode 100644
index 68d5281e456af2415fbfc7d7173864460970a201..0000000000000000000000000000000000000000
--- a/lisp/os.h
+++ /dev/null
@@ -1,56 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/os.h,v 1.1 1992/07/28 20:15:12 wlott Exp $
- *
- * Common interface for os-dependent functions.
- *
- */
-
-#if !defined(_OS_H_INCLUDED_)
-
-#define _OS_H_INCLUDED_
-
-#include "lisp.h"
-
-#ifdef MACH
-#include "mach-os.h"
-#else
-#ifdef sun
-#include "sunos-os.h"
-#endif
-#endif
-
-#define OS_VM_PROT_ALL (OS_VM_PROT_READ|OS_VM_PROT_WRITE|OS_VM_PROT_EXECUTE)
-
-extern os_vm_size_t os_vm_page_size;
-
-extern void os_init(void);
-extern void os_install_interrupt_handlers(void);
-
-extern os_vm_address_t os_allocate(os_vm_size_t len);
-extern os_vm_address_t os_allocate_at(os_vm_address_t addr, os_vm_size_t len);
-extern os_vm_address_t os_reallocate(os_vm_address_t addr,
-				     os_vm_size_t old_len,
-				     os_vm_size_t len);
-extern void os_deallocate(os_vm_address_t addr, os_vm_size_t len);
-extern void os_zero(os_vm_address_t addr, os_vm_size_t length);
-
-extern os_vm_address_t os_validate(os_vm_address_t addr, os_vm_size_t len);
-extern void os_invalidate(os_vm_address_t addr, os_vm_size_t len);
-extern os_vm_address_t os_map(int fd, int offset, os_vm_address_t addr,
-			      os_vm_size_t len);
-extern void os_flush_icache(os_vm_address_t addr, os_vm_size_t len);
-extern void os_protect(os_vm_address_t addr, os_vm_size_t len,
-		       os_vm_prot_t protection);
-extern boolean valid_addr(os_vm_address_t test);
-
-#define os_trunc_to_page(addr) \
-    (os_vm_address_t)(((long)(addr))&~(os_vm_page_size-1))
-#define os_round_up_to_page(addr) \
-    os_trunc_to_page((addr)+(os_vm_page_size-1))
-
-#define os_trunc_size_to_page(size) \
-    (os_vm_size_t)(((long)(size))&~(os_vm_page_size-1))
-#define os_round_up_size_to_page(size) \
-    os_trunc_size_to_page((size)+(os_vm_page_size-1))
-
-#endif
diff --git a/lisp/parse.c b/lisp/parse.c
deleted file mode 100644
index d89ecac5a29c1ba992fadda468529b4342745308..0000000000000000000000000000000000000000
--- a/lisp/parse.c
+++ /dev/null
@@ -1,361 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/parse.c,v 1.1 1992/07/28 20:15:14 wlott Exp $ */
-#include <stdio.h>
-#include <ctype.h>
-#include <signal.h>
-
-#include "lisp.h"
-#include "internals.h"
-#include "globals.h"
-#include "vars.h"
-#include "parse.h"
-#include "interrupt.h"
-#include "lispregs.h"
-#include "monitor.h"
-#include "arch.h"
-#include "os.h"
-#include "search.h"
-
-#ifndef MACH
-
-static int strcasecmp(s1,s2)
-char *s1,*s2;
-{
-    int c1, c2;
-
-    do{
-	c1=(*s1++);
-	if(isupper(c1))
-	    c1=tolower(c1);
-
-	c2=(*s2++);
-	if(isupper(c2))
-	    c2=tolower(c2);
-    }while(c1==c2 && c1!=0);
-
-    return c1-c2;
-}
-
-#endif
-
-static void skip_ws(char **ptr)
-{
-    while (**ptr <= ' ' && **ptr != '\0')
-        (*ptr)++;
-}
-
-static boolean string_to_long(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(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();
-    }
-    return 0;
-}
-
-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;
-}
-
-static boolean lookup_symbol(char *name, lispobj *result)
-{
-    int count;
-    lispobj *headerptr;
-
-    /* Search static space */
-    headerptr = static_space;
-    count = ((lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER) -
-	     static_space);
-    if (search_for_symbol(name, &headerptr, &count)) {
-        *result = (lispobj)headerptr | type_OtherPointer;
-        return TRUE;
-    }
-
-    /* Search dynamic space */
-    headerptr = current_dynamic_space;
-#ifndef ibmrt
-    count = current_dynamic_space_free_pointer - current_dynamic_space;
-#else
-    count = (lispobj *)SymbolValue(ALLOCATION_POINTER) - current_dynamic_space;
-#endif
-    if (search_for_symbol(name, &headerptr, &count)) {
-        *result = (lispobj)headerptr | type_OtherPointer;
-        return TRUE;
-    }
-
-    return FALSE;
-}
-
-static int
-parse_regnum(char *s)
-{
-	if ((s[1] == 'R') || (s[1] == 'r')) {
-		int regnum;
-
-		if (s[2] == '\0')
-			return -1;
-
-		/* skip the $R part and call atoi on the number */
-		regnum = atoi(s + 2);
-		if ((regnum >= 0) && (regnum < NREGS))
-			return regnum;
-		else
-			return -1;
-	} else {
-		int i;
-
-		for (i = 0; i < NREGS ; i++)
-			if (strcasecmp(s + 1, lisp_register_names[i]) == 0)
-				return i;
-		
-		return -1;
-	}
-}
-
-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 (isalpha(token[1])) {
-		int free;
-		int regnum;
-		struct sigcontext *context;
-
-		free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
-
-		if (free == 0) {
-			printf("Variable ``%s'' is not valid -- there is no current interrupt context.\n", token);
-			throw_to_monitor();
-		}
-
-		context = lisp_interrupt_contexts[free - 1];
-
-		regnum = parse_regnum(token);
-		if (regnum < 0) {
-			printf("Bogus register: ``%s''\n", token);
-			throw_to_monitor();
-		}
-
-		result = SC_REG(context, regnum);
-	} else 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))
-        ;
-    else if (lookup_symbol(token, &result))
-        ;
-    else {
-        printf("Invalid lisp object: ``%s''\n", token);
-        throw_to_monitor();
-    }
-
-    return result;
-}
diff --git a/lisp/parse.h b/lisp/parse.h
deleted file mode 100644
index 37b218582c146c1c1ceb28139c48642e94d35003..0000000000000000000000000000000000000000
--- a/lisp/parse.h
+++ /dev/null
@@ -1,9 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/parse.h,v 1.1 1992/07/28 20:15:16 wlott Exp $ */
-
-/* All parse routines take a char ** as their only argument */
-
-extern boolean more_p(char **ptr);
-extern char *parse_token(char **ptr);
-extern lispobj parse_lispobj(char **ptr);
-extern char *parse_addr(char **ptr);
-extern long parse_number(char **ptr);
diff --git a/lisp/print.h b/lisp/print.h
deleted file mode 100644
index e77adde9499faa5472aaab07624fb247d7b97778..0000000000000000000000000000000000000000
--- a/lisp/print.h
+++ /dev/null
@@ -1,14 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/print.h,v 1.1 1992/07/28 20:15:19 wlott Exp $ */
-
-#ifndef _PRINT_H_
-#define _PRINT_H_
-
-#include "lisp.h"
-
-extern char *lowtag_Names[], *subtype_Names[];
-
-extern void print(lispobj obj);
-extern void brief_print(lispobj obj);
-extern void reset_printer(void);
-
-#endif
diff --git a/lisp/purify.h b/lisp/purify.h
deleted file mode 100644
index f9433a9104c2b21deead424daff5dfd616d078d8..0000000000000000000000000000000000000000
--- a/lisp/purify.h
+++ /dev/null
@@ -1,10 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/purify.h,v 1.1 1992/07/28 20:15:25 wlott Exp $
- */
-
-#if !defined(_PURIFY_H_)
-#define _PURIFY_H_
-
-extern int purify(lispobj static_roots, lispobj read_only_roots);
-
-#endif
diff --git a/lisp/regnames.c b/lisp/regnames.c
deleted file mode 100644
index b88ca363c99d80d7d717f55dee9cd0788190b4da..0000000000000000000000000000000000000000
--- a/lisp/regnames.c
+++ /dev/null
@@ -1,5 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/regnames.c,v 1.1 1992/07/28 20:15:27 wlott Rel $ */
-
-#include "lispregs.h"
-
-char *lisp_register_names[] = { REGNAMES, 0 };
diff --git a/lisp/save.c b/lisp/save.c
deleted file mode 100644
index 33748565e068510c7d59709e500c454df6d86bea..0000000000000000000000000000000000000000
--- a/lisp/save.c
+++ /dev/null
@@ -1,229 +0,0 @@
-
-#include <stdio.h>
-#include <signal.h>
-#include <sys/file.h>
-
-#include "lisp.h"
-#include "os.h"
-#include "internals.h"
-#include "core.h"
-#include "globals.h"
-#include "lispregs.h"
-#include "interrupt.h"
-#include "save.h"
-#include "validate.h"
-
-extern int version;
-
-extern void restore_state(char *stack_ptr, int result);
-extern int save_state(int fn(char *stack_ptr, FILE *file), FILE *file);
-
-static long write_bytes(FILE *file, char *addr, long bytes)
-{
-    long count, here, data;
-
-    fflush(file);
-    here = ftell(file);
-    fseek(file, 0, 2);
-    data = (ftell(file)+CORE_PAGESIZE-1)&~(CORE_PAGESIZE-1);
-    fseek(file, data, 0);
-
-    while (bytes > 0) {
-        count = fwrite(addr, 1, bytes, file);
-        if (count > 0) {
-            bytes -= count;
-            addr += count;
-        }
-        else {
-            perror("Error writing to save file");
-            bytes = 0;
-        }
-    }
-    fflush(file);
-    fseek(file, here, 0);
-    return data/CORE_PAGESIZE - 1;
-}
-
-static void output_space(FILE *file, int id, lispobj *addr, lispobj *end)
-{
-    int words, bytes, data;
-    static char *names[] = {NULL, "Dynamic", "Static", "Read-Only"};
-
-    putw(id, file);
-    words = end - addr;
-    putw(words, file);
-
-    bytes = words * sizeof(lispobj);
-
-    printf("Writing %d bytes from the %s space at 0x%08X.\n",
-           bytes, names[id], (unsigned long)addr);
-
-    data = write_bytes(file, (char *)addr, bytes);
-
-    putw(data, file);
-    putw((os_vm_address_t)((long)addr / CORE_PAGESIZE), file);
-    putw((bytes + CORE_PAGESIZE - 1) / CORE_PAGESIZE, file);
-}
-
-static long write_stack(FILE *file, char *name, char *start, char *end)
-{
-    long len;
-
-    start = (char *)os_trunc_to_page((os_vm_address_t)start);
-    end = (char *)os_round_up_to_page((os_vm_address_t)end);
-
-    len = end-start;
-
-    printf("Writing %d bytes from the %s stack at 0x%08X.\n", len, name,
-	   (unsigned long)start);
-
-    return write_bytes(file, start, len);
-}
-
-static int do_save(char *stack_ptr, FILE *file)
-{
-    struct machine_state ms;
-
-    putw(CORE_MAGIC, file);
-
-    putw(CORE_VERSION, file);
-    putw(3, file);
-    putw(version, file);
-
-    putw(CORE_NDIRECTORY, file);
-    putw((5*3)+2, file);
-
-    output_space(file, READ_ONLY_SPACE_ID, read_only_space,
-		 (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
-    output_space(file, STATIC_SPACE_ID, static_space,
-		 (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER));
-#ifdef reg_ALLOC
-    output_space(file, DYNAMIC_SPACE_ID, current_dynamic_space,
-		 current_dynamic_space_free_pointer);
-#else
-    output_space(file, DYNAMIC_SPACE_ID, current_dynamic_space,
-		 (lispobj *)SymbolValue(ALLOCATION_POINTER));
-#endif
-
-    putw(CORE_MACHINE_STATE, file);
-    putw(2 + sizeof(ms)/sizeof(long), file);
-
-    ms.csp = current_control_stack_pointer;
-    ms.cfp = current_control_frame_pointer;
-    ms.control_stack_page = write_stack(file, "Control",
-       (char *)control_stack,
-       (char *)current_control_stack_pointer);
-
-#ifdef reg_BSP
-    ms.bsp = current_binding_stack_pointer;
-    ms.binding_stack_page = write_stack(file, "Binding",
-       (char *)binding_stack,
-       (char *)current_binding_stack_pointer);
-#else
-    ms.binding_stack_page = write_stack(file, "Binding",
-       (char *)binding_stack,
-       (char *)SymbolValue(BINDING_STACK_POINTER));
-#endif
-
-    ms.nsp = stack_ptr;
-#ifdef NUMBER_STACK_GROWS_UP
-    ms.number_stack_page = write_stack(file, "Number",
-	(char *)NUMBER_STACK_START,
-	stack_ptr);
-#else
-    ms.number_stack_page = write_stack(file, "Number", stack_ptr,
-       (char *)(NUMBER_STACK_START+NUMBER_STACK_SIZE));
-#endif
-
-    fwrite((void *)&ms, sizeof(ms), 1, file);
-
-    putw(CORE_END, file);
-    fclose(file);
-
-    printf("done.]\n");
-
-    return 1;
-}
-
-int save(char *filename)
-{
-    FILE *file;
-
-    /* Open the file: */
-    unlink(filename);
-    file = fopen(filename, "w");
-    if (file == NULL) {
-        perror(filename);
-        return TRUE;
-    }
-    printf("[Saving current lisp image into %s:\n", filename);
-
-    return save_state(do_save, file);
-}
-
-static os_vm_address_t map_stack(int fd, os_vm_address_t start,
-				 os_vm_address_t end,
-				 long data_page,
-				 char *name)
-{
-    os_vm_size_t len;
-
-    start = os_trunc_to_page(start);
-    len = os_round_up_to_page(end) - start;
-
-    if (len != 0) {
-#ifdef PRINTNOISE
-        printf("Mapping %d bytes onto the %s stack at 0x%08x.\n", len, name, start);
-#endif
-        start=os_map(fd, (1+data_page)*CORE_PAGESIZE, start, len);
-    }
-
-    return start;
-}
-
-static char *restored_nsp;
-
-void load(int fd, struct machine_state *ms)
-{
-    current_control_stack_pointer = ms->csp;
-    current_control_frame_pointer = ms->cfp;
-#ifdef reg_BSP
-    current_binding_stack_pointer = ms->bsp;
-#endif
-
-    map_stack(fd,
-              (os_vm_address_t)control_stack,
-              (os_vm_address_t)current_control_stack_pointer,
-              ms->control_stack_page,
-              "Control");
-
-    map_stack(fd,
-              (os_vm_address_t)binding_stack,
-#ifdef reg_BSP
-              (os_vm_address_t)current_binding_stack_pointer,
-#else
-	      (os_vm_address_t)SymbolValue(BINDING_STACK_POINTER),
-#endif
-              ms->binding_stack_page,
-              "Binding");
-
-    map_stack(fd,
-#ifdef NUMBER_STACK_GROWS_UP
-		NUMBER_STACK_START,
-		(os_vm_address_t)ms->nsp,
-#else
-		(os_vm_address_t)ms->nsp,
-		NUMBER_STACK_START+NUMBER_STACK_SIZE,
-#endif
-		ms->number_stack_page,
-		"Number");
-
-    restored_nsp = ms->nsp;
-}
-
-void restore(void)
-{
-    restore_state(restored_nsp, 0);
-
-    fprintf(stderr, "Hm, tried to restore, but nothing happened.\n");
-}
diff --git a/lisp/save.h b/lisp/save.h
deleted file mode 100644
index f197387b135fcdf591b3445ed56814d9585106fd..0000000000000000000000000000000000000000
--- a/lisp/save.h
+++ /dev/null
@@ -1,14 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/save.h,v 1.1 1992/07/28 20:15:30 wlott Exp $
- */
-
-#ifndef _SAVE_H_
-#define _SAVE_H_
-
-#include "core.h"
-
-extern void restore(void);
-extern boolean save(char *filename);
-extern void load(int fd, struct machine_state *ms);
-
-#endif
diff --git a/lisp/search.c b/lisp/search.c
deleted file mode 100644
index 1f879957e16f19a3a4219cc8f9460b31bf4e1112..0000000000000000000000000000000000000000
--- a/lisp/search.c
+++ /dev/null
@@ -1,44 +0,0 @@
-
-#include "lisp.h"
-#include "internals.h"
-#include "os.h"
-#include "search.h"
-
-boolean search_for_type(int type, lispobj **start, int *count)
-{
-    lispobj obj, *addr;
-
-    while ((*count == -1 || (*count > 0)) &&
-	   valid_addr((os_vm_address_t)*start)) {
-        obj = **start;
-        addr = *start;
-        if (*count != -1)
-            *count -= 2;
-
-        if (TypeOf(obj) == type)
-            return TRUE;
-
-        (*start) += 2;
-    }
-    return FALSE;
-}
-
-
-boolean search_for_symbol(char *name, lispobj **start, int *count)
-{
-    struct symbol *symbol;
-    struct vector *symbol_name;
-
-    while (search_for_type(type_SymbolHeader, start, count)) {
-        symbol = (struct symbol *)PTR((lispobj)*start);
-	if (LowtagOf(symbol->name) == type_OtherPointer) {
-            symbol_name = (struct vector *)PTR(symbol->name);
-            if (valid_addr((os_vm_address_t)symbol_name) &&
-		TypeOf(symbol_name->header) == type_SimpleString &&
-		strcmp((char *)symbol_name->data, name) == 0)
-                return TRUE;
-	}
-        (*start) += 2;
-    }
-    return FALSE;
-}
diff --git a/lisp/search.h b/lisp/search.h
deleted file mode 100644
index 0b51b09f04b5e320113de4bd5617882bd341a216..0000000000000000000000000000000000000000
--- a/lisp/search.h
+++ /dev/null
@@ -1,11 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/search.h,v 1.1 1992/07/28 20:15:32 wlott Exp $
- */
-
-#ifndef _SEARCH_H_
-#define _SEARCH_H_
-
-extern boolean search_for_type(int type, lispobj **start, int *count);
-extern boolean search_for_symbol(char *name, lispobj **start, int *count);
-
-#endif
diff --git a/lisp/socket.c b/lisp/socket.c
deleted file mode 100644
index f8c843ebcf384bed2dec992ce8744ec8261a2c07..0000000000000000000000000000000000000000
--- a/lisp/socket.c
+++ /dev/null
@@ -1,144 +0,0 @@
-/* Copyright    Massachusetts Institute of Technology    1988	*/
-/*
- * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived
- * systems.  VMS and System V should plan to have their own version.
- *
- * This code was cribbed from lib/X/XConnDis.c.
- * Compile using   
- *                    % cc -c socket.c -DUNIXCONN
- */
-
-#include <stdio.h>
-#include <X11/Xos.h>
-#include <X11/Xproto.h>
-#include <errno.h>
-#include <netinet/in.h>
-#include <sys/ioctl.h>
-#include <netdb.h> 
-#include <sys/socket.h>
-#ifndef hpux
-#include <netinet/tcp.h>
-#endif
-
-extern int errno;		/* Certain (broken) OS's don't have this */
-				/* decl in errno.h */
-
-#ifdef UNIXCONN
-#include <sys/un.h>
-#ifndef X_UNIX_PATH
-#ifdef hpux
-#define X_UNIX_PATH "/usr/spool/sockets/X11/"
-#define OLD_UNIX_PATH "/tmp/.X11-unix/X"
-#else /* hpux */
-#define X_UNIX_PATH "/tmp/.X11-unix/X"
-#endif /* hpux */
-#endif /* X_UNIX_PATH */
-#endif /* UNIXCONN */
-void bcopy();
-
-/* 
- * Attempts to connect to server, given host and display. Returns file 
- * descriptor (network socket) or 0 if connection fails.
- */
-
-int connect_to_server (host, display)
-     char *host;
-     int display;
-{
-  struct sockaddr_in inaddr;	/* INET socket address. */
-  struct sockaddr *addr;		/* address to connect to */
-  struct hostent *host_ptr;
-  int addrlen;			/* length of address */
-#ifdef UNIXCONN
-  struct sockaddr_un unaddr;	/* UNIX socket address. */
-#endif
-  extern char *getenv();
-  extern struct hostent *gethostbyname();
-  int fd;				/* Network socket */
-  {
-#ifdef UNIXCONN
-    if ((host[0] == '\0') || (strcmp("unix", host) == 0)) {
-	/* Connect locally using Unix domain. */
-	unaddr.sun_family = AF_UNIX;
-	(void) strcpy(unaddr.sun_path, X_UNIX_PATH);
-	sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display);
-	addr = (struct sockaddr *) &unaddr;
-	addrlen = strlen(unaddr.sun_path) + 2;
-	/*
-	 * Open the network connection.
-	 */
-	if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) {
-#ifdef hpux /* this is disgusting */  /* cribbed from X11R4 xlib source */
-  	    if (errno == ENOENT) {  /* No such file or directory */
-	      sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display);
-              addrlen = strlen(unaddr.sun_path) + 2;
-              if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0)
-                return(-1);     /* errno set by most recent system call. */
-	    } else 
-#endif /* hpux */
-	    return(-1);	    /* errno set by system call. */
-        }
-    } else 
-#endif /* UNIXCONN */
-    {
-      /* Get the statistics on the specified host. */
-      if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) 
-	{
-	  if ((host_ptr = gethostbyname(host)) == NULL) 
-	    {
-	      /* No such host! */
-	      errno = EINVAL;
-	      return(-1);
-	    }
-	  /* Check the address type for an internet host. */
-	  if (host_ptr->h_addrtype != AF_INET) 
-	    {
-	      /* Not an Internet host! */
-	      errno = EPROTOTYPE;
-	      return(-1);
-	    }
-	  /* Set up the socket data. */
-	  inaddr.sin_family = host_ptr->h_addrtype;
-	  bcopy((char *)host_ptr->h_addr, 
-		(char *)&inaddr.sin_addr, 
-		sizeof(inaddr.sin_addr));
-	} 
-      else 
-	{
-	  inaddr.sin_family = AF_INET;
-	}
-      addr = (struct sockaddr *) &inaddr;
-      addrlen = sizeof (struct sockaddr_in);
-      inaddr.sin_port = display + X_TCP_PORT;
-      inaddr.sin_port = htons(inaddr.sin_port);
-      /*
-       * Open the network connection.
-       */
-      if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){
-	return(-1);	    /* errno set by system call. */}
-      /* make sure to turn off TCP coalescence */
-#ifdef TCP_NODELAY
-      {
-	int mi = 1;
-	setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int));
-      }
-#endif
-    }
-
-    /*
-     * Changed 9/89 to retry connection if system call was interrupted.  This
-     * is necessary for multiprocessing implementations that use timers,
-     * since the timer results in a SIGALRM.	-- jdi
-     */
-    while (connect(fd, addr, addrlen) == -1) {
-	if (errno != EINTR) {
-  	    (void) close (fd);
-  	    return(-1); 	    /* errno set by system call. */
-	}
-      }
-  }
-  /*
-   * Return the id if the connection succeeded.
-   */
-  return(fd);
-}
diff --git a/lisp/sparc-arch.c b/lisp/sparc-arch.c
deleted file mode 100644
index 70f39d97906ac80564b4f63a7d6d5588fe40374c..0000000000000000000000000000000000000000
--- a/lisp/sparc-arch.c
+++ /dev/null
@@ -1,300 +0,0 @@
-#include <stdio.h>
-#include <machine/trap.h>
-
-#include "lisp.h"
-#include "internals.h"
-#include "globals.h"
-#include "validate.h"
-#include "os.h"
-#include "arch.h"
-#include "lispregs.h"
-#include "signal.h"
-#include "interrupt.h"
-
-char *arch_init()
-{
-    return NULL;
-}
-
-os_vm_address_t arch_get_bad_addr(int signal, int code,
-				  struct sigcontext *context)
-{
-    unsigned long badinst;
-    int rs1;
-
-    /* On the sparc, we have to decode the instruction. */
-
-    /* Make sure it's not the pc thats bogus, and that it was lisp code */
-    /* that caused the fault. */
-    if ((context->sc_pc & 3) != 0 ||
-	((context->sc_pc < READ_ONLY_SPACE_START ||
-	  context->sc_pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) &&
-	 ((lispobj *)context->sc_pc < current_dynamic_space &&
-	  (lispobj *)context->sc_pc >=
-	      current_dynamic_space + DYNAMIC_SPACE_SIZE)))
-	return NULL;
-
-    badinst = *(unsigned long *)context->sc_pc;
-
-    if ((badinst >> 30) != 3)
-	/* All load/store instructions have op = 11 (binary) */
-	return NULL;
-
-    rs1 = (badinst>>14)&0x1f;
-
-    if (badinst & (1<<13)) {
-	/* r[rs1] + simm(13) */
-	int simm13 = badinst & 0x1fff;
-
-	if (simm13 & (1<<12))
-	    simm13 |= -1<<13;
-
-	return (os_vm_address_t)(SC_REG(context, rs1) + simm13);
-    }
-    else {
-	/* r[rs1] + r[rs2] */
-	int rs2 = badinst & 0x1f;
-
-	return (os_vm_address_t)(SC_REG(context, rs1) + SC_REG(context, rs2));
-    }
-
-}
-
-void arch_skip_instruction(context)
-struct sigcontext *context;
-{
-    /* Skip the offending instruction */
-    context->sc_pc = context->sc_npc;
-    context->sc_npc += 4;
-}
-
-unsigned char *arch_internal_error_arguments(struct sigcontext *scp)
-{
-    return (unsigned char *)(scp->sc_pc+4);
-}
-
-boolean arch_pseudo_atomic_atomic(struct sigcontext *scp)
-{
-    return (SC_REG(scp, reg_ALLOC) & 4);
-}
-
-void arch_set_pseudo_atomic_interrupted(struct sigcontext *scp)
-{
-    SC_REG(scp, reg_ALLOC) |= 1;
-}
-
-unsigned long arch_install_breakpoint(void *pc)
-{
-    unsigned long *ptr = (unsigned long *)pc;
-    unsigned long result = *ptr;
-    *ptr = trap_Breakpoint;
-    return result;
-}
-
-void arch_remove_breakpoint(void *pc, unsigned long orig_inst)
-{
-    *(unsigned long *)pc = orig_inst;
-}
-
-static unsigned long *skipped_break_addr, displaced_after_inst;
-static int orig_sigmask;
-
-void arch_do_displaced_inst(struct sigcontext *scp,
-				   unsigned long orig_inst)
-{
-    unsigned long *pc = (unsigned long *)scp->sc_pc;
-    unsigned long *npc = (unsigned long *)scp->sc_npc;
-
-    orig_sigmask = scp->sc_mask;
-    scp->sc_mask = BLOCKABLE;
-
-    *pc = orig_inst;
-    skipped_break_addr = pc;
-    displaced_after_inst = *npc;
-    *npc = trap_AfterBreakpoint;
-
-    sigreturn(scp);
-}
-
-static void sigill_handler(signal, code, scp)
-int signal, code;
-struct sigcontext *scp;
-{
-    int badinst;
-
-    sigsetmask(scp->sc_mask);
-
-    if (code == T_UNIMP_INSTR) {
-	int trap;
-
-	trap = *(unsigned long *)(scp->sc_pc) & 0x3fffff;
-
-	switch (trap) {
-	  case trap_PendingInterrupt:
-	    arch_skip_instruction(scp);
-	    interrupt_handle_pending(scp);
-	    break;
-
-	  case trap_Halt:
-	    fake_foreign_function_call(scp);
-	    lose("%%primitive halt called; the party is over.\n");
-
-	  case trap_Error:
-	  case trap_Cerror:
-	    interrupt_internal_error(signal, code, scp, trap == trap_Cerror);
-	    break;
-
-	  case trap_Breakpoint:
-	    handle_breakpoint(signal, code, scp);
-	    break;
-
-	  case trap_FunctionEndBreakpoint:
-	    scp->sc_pc=(int)handle_function_end_breakpoint(signal, code, scp);
-	    scp->sc_npc=scp->sc_pc + 4;
-	    break;
-
-	  case trap_AfterBreakpoint:
-	    *skipped_break_addr = trap_Breakpoint;
-	    skipped_break_addr = NULL;
-	    *(unsigned long *)scp->sc_pc = displaced_after_inst;
-	    scp->sc_mask = orig_sigmask;
-	    break;
-
-	  default:
-	    interrupt_handle_now(signal, code, scp);
-	    break;
-	}
-    }
-    else if (code >= T_SOFTWARE_TRAP + 16 & code < T_SOFTWARE_TRAP + 32)
-	interrupt_internal_error(signal, code, scp, FALSE);
-    else
-	interrupt_handle_now(signal, code, scp);
-}
-
-static void sigemt_handler(signal, code, scp)
-     int signal, code;
-     struct sigcontext *scp;
-{
-    unsigned long badinst;
-    boolean subtract, immed;
-    int rd, rs1, op1, rs2, op2, result;
-
-    badinst = *(unsigned long *)scp->sc_pc;
-    if ((badinst >> 30) != 2 || ((badinst >> 20) & 0x1f) != 0x11) {
-	/* It wasn't a tagged add.  Pass the signal into lisp. */
-	interrupt_handle_now(signal, code, scp);
-	return;
-    }
-	
-    /* Extract the parts of the inst. */
-    subtract = badinst & (1<<19);
-    rs1 = (badinst>>14) & 0x1f;
-    op1 = SC_REG(scp, rs1);
-
-    /* If the first arg is $ALLOC then it is really a signal-pending note */
-    /* for the pseudo-atomic noise. */
-    if (rs1 == reg_ALLOC) {
-	/* Perform the op anyway. */
-	op2 = badinst & 0x1fff;
-	if (op2 & (1<<12))
-	    op2 |= -1<<13;
-	if (subtract)
-	    result = op1 - op2;
-	else
-	    result = op1 + op2;
-	SC_REG(scp, reg_ALLOC) = result & ~7;
-	arch_skip_instruction(scp);
-	interrupt_handle_pending(scp);
-	return;
-    }
-
-    if ((op1 & 3) != 0) {
-	/* The first arg wan't a fixnum. */
-	interrupt_internal_error(signal, code, scp, FALSE);
-	return;
-    }
-
-    if (immed = badinst & (1<<13)) {
-	op2 = badinst & 0x1fff;
-	if (op2 & (1<<12))
-	    op2 |= -1<<13;
-    }
-    else {
-	rs2 = badinst & 0x1f;
-	op2 = SC_REG(scp, rs2);
-    }
-
-    if ((op2 & 3) != 0) {
-	/* The second arg wan't a fixnum. */
-	interrupt_internal_error(signal, code, scp, FALSE);
-	return;
-    }
-
-    rd = (badinst>>25) & 0x1f;
-    if (rd != 0) {
-	/* Don't bother computing the result unless we are going to use it. */
-	if (subtract)
-	    result = (op1>>2) - (op2>>2);
-	else
-	    result = (op1>>2) + (op2>>2);
-
-        current_dynamic_space_free_pointer =
-            (lispobj *) SC_REG(scp, reg_ALLOC);
-
-	SC_REG(scp, rd) = alloc_number(result);
-
-	SC_REG(scp, reg_ALLOC) =
-	    (unsigned long) current_dynamic_space_free_pointer;
-    }
-
-    arch_skip_instruction(scp);
-}
-
-void arch_install_interrupt_handlers()
-{
-    interrupt_install_low_level_handler(SIGILL,sigill_handler);
-    interrupt_install_low_level_handler(SIGEMT,sigemt_handler);
-}
-
-
-extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
-
-lispobj funcall0(lispobj function)
-{
-    lispobj *args = current_control_stack_pointer;
-
-    return call_into_lisp(function, args, 0);
-}
-
-lispobj funcall1(lispobj function, lispobj arg0)
-{
-    lispobj *args = current_control_stack_pointer;
-
-    current_control_stack_pointer += 1;
-    args[0] = arg0;
-
-    return call_into_lisp(function, args, 1);
-}
-
-lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1)
-{
-    lispobj *args = current_control_stack_pointer;
-
-    current_control_stack_pointer += 2;
-    args[0] = arg0;
-    args[1] = arg1;
-
-    return call_into_lisp(function, args, 2);
-}
-
-lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2)
-{
-    lispobj *args = current_control_stack_pointer;
-
-    current_control_stack_pointer += 3;
-    args[0] = arg0;
-    args[1] = arg1;
-    args[2] = arg2;
-
-    return call_into_lisp(function, args, 3);
-}
diff --git a/lisp/sparc-assem.S b/lisp/sparc-assem.S
deleted file mode 100644
index 4e22039bf63c2bd073d42952e389dd04f54717cf..0000000000000000000000000000000000000000
--- a/lisp/sparc-assem.S
+++ /dev/null
@@ -1,495 +0,0 @@
-
-#include <machine/asm_linkage.h>
-#include <machine/psl.h>
-#include <machine/trap.h>
-
-#define LANGUAGE_ASSEMBLY
-#include "lispregs.h"
-#include "internals.h"
-#include "globals.h"
-
-#define load(sym, reg) \
-        sethi %hi(sym), reg; ld [reg+%lo(sym)], reg
-#define store(reg, sym) \
-        sethi %hi(sym), reg_L0; st reg, [reg_L0+%lo(sym)]
-
-
-#define FRAMESIZE (SA(WINDOWSIZE+4))
-
-        .seg    "text"
-        .global _call_into_lisp
-_call_into_lisp:
-        save    %sp, -FRAMESIZE, %sp
-
-	/* Flush all of C's register windows to the stack. */
-	ta	ST_FLUSH_WINDOWS
-
-        /* Save the return address. */
-        st      %i7, [%fp-4]
-
-        /* Clear the descriptor regs. */
-        mov     reg_ZERO, reg_A0
-        mov     reg_ZERO, reg_A1
-        mov     reg_ZERO, reg_A2
-        mov     reg_ZERO, reg_A3
-        mov     reg_ZERO, reg_A4
-        mov     reg_ZERO, reg_A5
-        mov     reg_ZERO, reg_OCFP
-        mov     reg_ZERO, reg_LRA
-        mov     reg_ZERO, reg_L2
-        mov     reg_ZERO, reg_CODE
-
-        /* Establish NIL */
-        set     NIL, reg_NIL
-
-	/* Set the pseudo-atomic flag. */
-	set	4, reg_ALLOC
-
-	/* Turn off foreign function call. */
-        sethi   %hi(_foreign_function_call_active), reg_NL0
-        st      reg_ZERO, [reg_NL0+%lo(_foreign_function_call_active)]
-
-        /* Load the rest of lisp state. */
-        load(_current_dynamic_space_free_pointer, reg_NL0)
-	add	reg_NL0, reg_ALLOC, reg_ALLOC
-        load(_current_binding_stack_pointer, reg_BSP)
-        load(_current_control_stack_pointer, reg_CSP)
-        load(_current_control_frame_pointer, reg_OCFP)
-
-        /* No longer atomic, and check for interrupt. */
-	tsubcctv	reg_ALLOC, 4, reg_ALLOC
-
-        /* Pass in the args. */
-        sll     %i2, 2, reg_NARGS
-        mov     %i1, reg_CFP
-	mov	%i0, reg_LEXENV
-        ld      [reg_CFP+0], reg_A0
-        ld      [reg_CFP+4], reg_A1
-        ld      [reg_CFP+8], reg_A2
-        ld      [reg_CFP+12], reg_A3
-        ld      [reg_CFP+16], reg_A4
-        ld      [reg_CFP+20], reg_A5
-
-        /* Calculate LRA */
-        set     lra + type_OtherPointer, reg_LRA
-
-        /* Indirect closure */
-        ld      [reg_LEXENV+CLOSURE_FUNCTION_OFFSET], reg_CODE
-
-        jmp     reg_CODE+FUNCTION_CODE_OFFSET
-        nop
-
-        .align  8
-lra:
-        .word   type_ReturnPcHeader
-
-        /* Blow off any extra values. */
-        mov     reg_OCFP, reg_CSP
-        nop
-
-        /* Return the one value. */
-        mov     reg_A0, %i0
-
-        /* Turn on pseudo_atomic */
-	add	reg_ALLOC, 4, reg_ALLOC
-
-        /* Store LISP state */
-	andn	reg_ALLOC, 7, reg_NL1
-        store(reg_NL1,_current_dynamic_space_free_pointer)
-        store(reg_BSP,_current_binding_stack_pointer)
-        store(reg_CSP,_current_control_stack_pointer)
-        store(reg_CFP,_current_control_frame_pointer)
-
-        /* No longer in Lisp. */
-        store(reg_NL1,_foreign_function_call_active)
-
-        /* Were we interrupted? */
-	tsubcctv	reg_ALLOC, 4, reg_ALLOC
-
-        /* Back to C we go. */
-	ld	[%sp+FRAMESIZE-4], %i7
-        ret
-        restore	%sp, FRAMESIZE, %sp
-
-
-
-        .global _call_into_c
-_call_into_c:
-        /* Build a lisp stack frame */
-        mov     reg_CFP, reg_OCFP
-        mov     reg_CSP, reg_CFP
-        add     reg_CSP, 32, reg_CSP
-        st      reg_OCFP, [reg_CFP]
-        st      reg_CODE, [reg_CFP+8]
-
-        /* Turn on pseudo-atomic. */
-	add	reg_ALLOC, 4, reg_ALLOC
-
-	/* Convert the return address to an offset and save it on the stack. */
-	sub	reg_LIP, reg_CODE, reg_L0
-	add	reg_L0, type_OtherPointer, reg_L0
-	st	reg_L0, [reg_CFP+4]
-
-        /* Store LISP state */
-	andn	reg_ALLOC, 7, reg_L1
-        store(reg_L1,_current_dynamic_space_free_pointer)
-        store(reg_BSP,_current_binding_stack_pointer)
-        store(reg_CSP,_current_control_stack_pointer)
-        store(reg_CFP,_current_control_frame_pointer)
-
-        /* No longer in Lisp. */
-        store(reg_CSP,_foreign_function_call_active)
-
-        /* Were we interrupted? */
-	tsubcctv	reg_ALLOC, 4, reg_ALLOC
-
-        /* Into C we go. */
-        call    reg_CFUNC
-        nop
-
-        /* Re-establish NIL */
-        set     NIL, reg_NIL
-
-	/* Atomic. */
-	set	4, reg_ALLOC
-
-        /* No longer in foreign function call. */
-        sethi   %hi(_foreign_function_call_active), reg_NL1
-        st      reg_ZERO, [reg_NL1+%lo(_foreign_function_call_active)]
-
-        /* Load the rest of lisp state. */
-        load(_current_dynamic_space_free_pointer, reg_NL1)
-	add	reg_NL1, reg_ALLOC, reg_ALLOC
-        load(_current_binding_stack_pointer, reg_BSP)
-        load(_current_control_stack_pointer, reg_CSP)
-        load(_current_control_frame_pointer, reg_CFP)
-
-	/* Get the return address back. */
-	ld	[reg_CFP+4], reg_LIP
-	ld	[reg_CFP+8], reg_CODE
-	add	reg_LIP, reg_CODE, reg_LIP
-	sub	reg_LIP, type_OtherPointer, reg_LIP
-
-        /* No longer atomic. */
-	tsubcctv	reg_ALLOC, 4, reg_ALLOC
-
-        /* Reset the lisp stack. */
-        /* Note: OCFP is in one of the locals, it gets preserved across C. */
-        mov     reg_CFP, reg_CSP
-        mov     reg_OCFP, reg_CFP
-
-        /* And back into lisp. */
-        ret
-        nop
-
-
-
-        .global _undefined_tramp
-        .align  8
-        .byte   0
-_undefined_tramp:
-        .byte   0, 0, type_FunctionHeader
-        .word   _undefined_tramp
-        .word   NIL
-        .word   NIL
-        .word   NIL
-        .word   NIL
-
-	b	1f
-        unimp   trap_Cerror
-	.byte	4, 23, 254, 12, 3
-	.align	4
-1:
-	ld	[reg_FDEFN+FDEFN_RAW_ADDR_OFFSET], reg_CODE
-	jmp	reg_CODE+FUNCTION_CODE_OFFSET
-	nop
-
-	.global	_closure_tramp
-	.align	8
-	.byte	0
-_closure_tramp:
-	.byte	0, 0, type_FunctionHeader
-	.word	_closure_tramp
-	.word	NIL
-        .word   NIL
-	.word	NIL
-	.word	NIL
-
-	ld	[reg_FDEFN+FDEFN_FUNCTION_OFFSET], reg_LEXENV
-	ld	[reg_LEXENV+CLOSURE_FUNCTION_OFFSET], reg_CODE
-	jmp	reg_CODE+FUNCTION_CODE_OFFSET
-	nop
-
-
-
-/*
- * Function-end breakpoint magic.
- */
-
-	.text
-	.align	8
-	.global	_function_end_breakpoint_guts
-_function_end_breakpoint_guts:
-	.word	type_ReturnPcHeader
-	b	1f
-	nop
-	mov	reg_CSP, reg_OCFP
-	add	4, reg_CSP, reg_CSP
-	mov	4, reg_NARGS
-	mov	reg_NIL, reg_A1
-	mov	reg_NIL, reg_A2
-	mov	reg_NIL, reg_A3
-	mov	reg_NIL, reg_A4
-	mov	reg_NIL, reg_A5
-1:
-
-	.global	_function_end_breakpoint_trap
-_function_end_breakpoint_trap:
-	unimp	trap_FunctionEndBreakpoint
-	b	1b
-	nop
-
-	.global	_function_end_breakpoint_end
-_function_end_breakpoint_end:
-
-/****************************************************************\
-* State saving and restoring.
-\****************************************************************/
-
-	.global	_call_on_stack
-_call_on_stack:
-	call	%o0
-	sub	%o1, SA(MINFRAME), %sp
-	unimp	0
-
-	.global	_save_state
-_save_state:
-	save	%sp, -(SA(8*4)+SA(MINFRAME)), %sp
-	ta	ST_FLUSH_WINDOWS
-	st	%i7, [%sp+SA(MINFRAME)]
-	st	%g1, [%sp+SA(MINFRAME)+4]
-	std	%g2, [%sp+SA(MINFRAME)+8]
-	std	%g4, [%sp+SA(MINFRAME)+16]
-	std	%g6, [%sp+SA(MINFRAME)+24]
-	! ### Should also save the FP state.
-	mov	%i1, %o1
-	call	%i0
-	mov	%sp, %o0
-	mov	%o0, %i0
-restore_state:
-	ld	[%sp+SA(MINFRAME)+4], %g1
-	ldd	[%sp+SA(MINFRAME)+8], %g2
-	ldd	[%sp+SA(MINFRAME)+16], %g4
-	ldd	[%sp+SA(MINFRAME)+24], %g6
-	ret
-	restore
-
-	.global	_restore_state
-_restore_state:
-	ta	ST_FLUSH_WINDOWS
-	mov	%o0, %fp
-	mov	%o1, %i0
-	restore
-	ld	[%sp+SA(MINFRAME)], %i7
-	b restore_state
-	mov	%o0, %i0
-
-
-/****************************************************************\
-
-We need our own version of sigtramp.
-
-\****************************************************************/
-
-	.global	__sigtramp, __sigfunc
-__sigtramp:
-	!
-	! On entry sp points to:
-	! 	0 - 63: window save area
-	!	64: signal number
-	!	68: signal code
-	!	72: pointer to sigcontext
-	!	76: addr parameter
-	!
-	! A sigcontext looks like:
-#define SC_ONSTACK 0
-#define SC_MASK 4
-#define SC_SP 8
-#define SC_PC 12
-#define SC_NPC 16
-#define SC_PSR 20
-#define SC_G1 24
-#define SC_O0 28
-	!
-	! We change sc_g1 to point to a reg save area:
-#define IREGS_SAVE 0
-#define FPREGS_SAVE (32*4)
-#define Y_SAVE (64*4)
-#define FSR_SAVE (65*4)
-#define REGSAVESIZE (66*4)
-        !
-        ! After we allocate space for the reg save area, the stack looks like:
-        !       < window save area, etc >
-#define REGSAVEOFF SA(MINFRAME)
-#define IREGSOFF REGSAVEOFF+IREGS_SAVE
-#define FPREGSOFF REGSAVEOFF+FPREGS_SAVE
-#define YOFF REGSAVEOFF+Y_SAVE
-#define FSROFF REGSAVEOFF+FSR_SAVE
-#define ORIGSIGNUMOFF REGSAVEOFF+REGSAVESIZE
-#define ORIGCODEOFF ORIGSIGNUMOFF+4
-#define ORIGSCPOFF ORIGSIGNUMOFF+8
-#define ORIGADDROFF ORIGSIGNUMOFF+12
-
-        ! Allocate space for the reg save area.
-        sub     %sp, REGSAVESIZE+SA(MINFRAME)-64, %sp
-
-        ! Save integer registers.
-        ! Note: the globals and outs are good, but the locals and ins have
-        ! been trashed.  But luckly, they have been saved on the stack.
-        ! So we need to extract the saved stack pointer from the sigcontext
-        ! to determine where they are.
-        std     %g0, [%sp+IREGSOFF]
-        std     %g2, [%sp+IREGSOFF+8]
-        std     %g4, [%sp+IREGSOFF+16]
-        std     %g6, [%sp+IREGSOFF+24]
-        std     %o0, [%sp+IREGSOFF+32]
-        std     %o2, [%sp+IREGSOFF+40]
-        ld      [%sp+ORIGSCPOFF], %o2
-	ld	[%o2+SC_SP], %o0
-        std     %o4, [%sp+IREGSOFF+48]
-        st      %o0, [%sp+IREGSOFF+56]
-        st      %o7, [%sp+IREGSOFF+60]
-
-        ldd     [%o0], %l0
-        ldd     [%o0+8], %l2
-        ldd     [%o0+16], %l4
-        ldd     [%o0+24], %l6
-        ldd     [%o0+32], %i0
-        ldd     [%o0+40], %i2
-        ldd     [%o0+48], %i4
-        ldd     [%o0+56], %i6
-        std     %l0, [%sp+IREGSOFF+64]
-        std     %l2, [%sp+IREGSOFF+72]
-        std     %l4, [%sp+IREGSOFF+80]
-        std     %l6, [%sp+IREGSOFF+88]
-        std     %i0, [%sp+IREGSOFF+96]
-        std     %i2, [%sp+IREGSOFF+104]
-        std     %i4, [%sp+IREGSOFF+112]
-        std     %i6, [%sp+IREGSOFF+120]
-
-        ! Check to see if we need to save the fp regs.
-	ld	[%o2+SC_PSR], %l5	! get psr
-	set	PSR_EF, %l0
-	mov	%y, %l2			! save y
-	btst	%l0, %l5		! is FPU enabled?
-	bz	1f			! if not skip FPU save
-	st	%l2, [%sp + YOFF]
-
-	! save all fpu registers.
-	std	%f0, [%sp+FPREGSOFF+(0*4)]
-	std	%f2, [%sp+FPREGSOFF+(2*4)]
-	std	%f4, [%sp+FPREGSOFF+(4*4)]
-	std	%f6, [%sp+FPREGSOFF+(6*4)]
-	std	%f8, [%sp+FPREGSOFF+(8*4)]
-	std	%f10, [%sp+FPREGSOFF+(10*4)]
-	std	%f12, [%sp+FPREGSOFF+(12*4)]
-	std	%f14, [%sp+FPREGSOFF+(14*4)]
-	std	%f16, [%sp+FPREGSOFF+(16*4)]
-	std	%f18, [%sp+FPREGSOFF+(18*4)]
-	std	%f20, [%sp+FPREGSOFF+(20*4)]
-	std	%f22, [%sp+FPREGSOFF+(22*4)]
-	std	%f24, [%sp+FPREGSOFF+(24*4)]
-	std	%f26, [%sp+FPREGSOFF+(26*4)]
-	std	%f28, [%sp+FPREGSOFF+(28*4)]
-	std	%f30, [%sp+FPREGSOFF+(30*4)]
-	st	%fsr, [%sp+FSROFF] ! save old fsr
-1:
-
-	ld	[%sp+ORIGSIGNUMOFF], %o0! get signal number
-	set	__sigfunc, %g1		! get array of function ptrs
-	sll	%o0, 2, %g2		! scale signal number for index
-	ld	[%g1+%g2], %g1		! get func
-	ld	[%sp+ORIGCODEOFF], %o1	! get code
-	! %o2 is already loaded with scp
-	add	%sp, REGSAVEOFF, %o3	! compute pointer to reg save area
-	st	%o3, [%o2 + SC_G1]	! save in sc_g1.
-	call	%g1			! (*_sigfunc[sig])(sig,code,scp,addr)
-	ld	[%sp+ORIGADDROFF], %o3	! get addr
-
-        ! Recompute scp, and drop into _sigreturn
-        ld	[%sp+ORIGSCPOFF], %o0	! get scp
-
-        .global _sigreturn
-_sigreturn:
-	! Load g1 with addr of reg save area (from sc_g1)
-	ld	[%o0+SC_G1], %g1
-
-        ! Move values we cannot restore directory into real sigcontext.
-        ld      [%g1+IREGS_SAVE+(4*1)], %l0	! g1
-        ld      [%g1+IREGS_SAVE+(4*8)], %l1	! o0
-        ld      [%g1+IREGS_SAVE+(4*14)], %l2	! sp
-        st      %l0, [%o0+SC_G1]
-        st      %l1, [%o0+SC_O0]
-        st      %l2, [%o0+SC_SP]
-
-	ld	[%o0+SC_PSR], %l2	! get psr
-	set	PSR_EF, %l0
-	ld	[%g1+Y_SAVE], %l1	! restore y
-	btst	%l0, %l2		! is FPU enabled?
-	bz	2f			! if not skip FPU restore
-	mov	%l1, %y
-
-	ldd	[%g1+FPREGS_SAVE+(0*4)], %f0	! restore all fpu registers.
-	ldd	[%g1+FPREGS_SAVE+(2*4)], %f2
-	ldd	[%g1+FPREGS_SAVE+(4*4)], %f4
-	ldd	[%g1+FPREGS_SAVE+(6*4)], %f6
-	ldd	[%g1+FPREGS_SAVE+(8*4)], %f8
-	ldd	[%g1+FPREGS_SAVE+(10*4)], %f10
-	ldd	[%g1+FPREGS_SAVE+(12*4)], %f12
-	ldd	[%g1+FPREGS_SAVE+(14*4)], %f14
-	ldd	[%g1+FPREGS_SAVE+(16*4)], %f16
-	ldd	[%g1+FPREGS_SAVE+(18*4)], %f18
-	ldd	[%g1+FPREGS_SAVE+(20*4)], %f20
-	ldd	[%g1+FPREGS_SAVE+(22*4)], %f22
-	ldd	[%g1+FPREGS_SAVE+(24*4)], %f24
-	ldd	[%g1+FPREGS_SAVE+(26*4)], %f26
-	ldd	[%g1+FPREGS_SAVE+(28*4)], %f28
-	ldd	[%g1+FPREGS_SAVE+(30*4)], %f30
-	ld	[%g1+FSR_SAVE], %fsr	! restore old fsr
-2:
-
-	! The locals and in are restored from the stack, so we have to put
-	! them there.
-	ld	[%o0+SC_SP], %o1
-        ldd     [%g1+IREGS_SAVE+(16*4)], %l0
-        ldd     [%g1+IREGS_SAVE+(18*4)], %l2
-        ldd     [%g1+IREGS_SAVE+(20*4)], %l4
-        ldd     [%g1+IREGS_SAVE+(22*4)], %l6
-        ldd     [%g1+IREGS_SAVE+(24*4)], %i0
-        ldd     [%g1+IREGS_SAVE+(26*4)], %i2
-        ldd     [%g1+IREGS_SAVE+(28*4)], %i4
-        ldd     [%g1+IREGS_SAVE+(30*4)], %i6
-	std	%l0, [%o1+(0*4)]
-	std	%l2, [%o1+(2*4)]
-	std	%l4, [%o1+(4*4)]
-	std	%l6, [%o1+(6*4)]
-	std	%i0, [%o1+(8*4)]
-	std	%i2, [%o1+(10*4)]
-	std	%i4, [%o1+(12*4)]
-	std	%i6, [%o1+(14*4)]
-
-        ! Restore the globals and outs.  Do not restore %g1, %o0, or %sp
-	! because they get restored from the sigcontext.
-        ldd     [%g1+IREGS_SAVE+(2*4)], %g2
-        ldd     [%g1+IREGS_SAVE+(4*4)], %g4
-        ldd     [%g1+IREGS_SAVE+(6*4)], %g6
-        ld      [%g1+IREGS_SAVE+(9*4)], %o1
-        ldd     [%g1+IREGS_SAVE+(10*4)], %o2
-        ldd     [%g1+IREGS_SAVE+(12*4)], %o4
-        ld      [%g1+IREGS_SAVE+(15*4)], %o7
-
-	set	139, %g1		! sigcleanup system call
-	t	0
-	unimp	0			! just in case it returns
-	/*NOTREACHED*/
-
diff --git a/lisp/sparc-lispregs.h b/lisp/sparc-lispregs.h
deleted file mode 100644
index d85d9f095dbe51e6d7632807388403490967450c..0000000000000000000000000000000000000000
--- a/lisp/sparc-lispregs.h
+++ /dev/null
@@ -1,77 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/sparc-lispregs.h,v 1.1 1992/09/08 20:21:10 wlott Exp $ */
-
-#ifdef LANGUAGE_ASSEMBLY
-
-#define GREG(num) %g ## num
-#define OREG(num) %o ## num
-#define LREG(num) %l ## num
-#define IREG(num) %i ## num
-
-#else
-
-#define GREG(num) (num)
-#define OREG(num) ((num)+8)
-#define LREG(num) ((num)+16)
-#define IREG(num) ((num)+24)
-
-#endif
-
-#define NREGS	(32)
-
-#define reg_ZERO	GREG(0)
-#define reg_ALLOC	GREG(1)
-#define reg_NIL		GREG(2)
-#define reg_CSP		GREG(3)
-#define reg_CFP		GREG(4)
-#define reg_BSP		GREG(5)
-#define reg_NFP		GREG(6)
-#define reg_CFUNC	GREG(7)
-
-#define reg_NL0		OREG(0)
-#define reg_NL1		OREG(1)
-#define reg_NL2		OREG(2)
-#define reg_NL3		OREG(3)
-#define reg_NL4		OREG(4)
-#define reg_NL5		OREG(5)
-#define reg_NSP		OREG(6)
-#define reg_NARGS	OREG(7)
-
-#define reg_A0		LREG(0)
-#define reg_A1		LREG(1)
-#define reg_A2		LREG(2)
-#define reg_A3		LREG(3)
-#define reg_A4		LREG(4)
-#define reg_A5		LREG(5)
-#define reg_OCFP	LREG(6)
-#define reg_LRA		LREG(7)
-
-#define reg_FDEFN	IREG(0)
-#define reg_LEXENV	IREG(1)
-#define reg_L0		IREG(2)
-#define reg_L1		IREG(3)
-#define reg_L2		IREG(4)
-#define reg_CODE	IREG(5)
-#define reg_LIP		IREG(7)
-
-#define REGNAMES \
-	"ZERO",		"ALLOC",	"NULL",		"CSP", \
-	"CFP",		"BSP",		"NFP",		"CFUNC", \
-        "NL0",		"NL1",		"NL2",		"NL3", \
-        "NL4",		"NL5",		"NSP",		"NARGS", \
-        "A0",		"A1",		"A2",		"A3", \
-        "A4",		"A5",		"OCFP",		"LRA", \
-        "FDEFN",	"LEXENV",	"L0",		"L1", \
-        "L2",		"CODE",		"???",		"LIP"
-
-#define BOXED_REGISTERS { \
-    reg_A0, reg_A1, reg_A2, reg_A3, reg_A4, reg_A5, reg_FDEFN, reg_LEXENV, \
-    reg_NFP, reg_OCFP, reg_LRA, reg_L0, reg_L1, reg_CODE \
-}
-
-#ifndef LANGUAGE_ASSEMBLY
-
-#define SC_REG(sc, n) (((int *)((sc)->sc_g1))[n])
-#define SC_PC(sc) ((sc)->sc_pc)
-#define SC_NPC(sc) ((sc)->sc_npc)
-
-#endif
diff --git a/lisp/sparc-validate.h b/lisp/sparc-validate.h
deleted file mode 100644
index 1396a66af1f0616b20591daf735b51df751248c1..0000000000000000000000000000000000000000
--- a/lisp/sparc-validate.h
+++ /dev/null
@@ -1,23 +0,0 @@
-
-#define READ_ONLY_SPACE_START   (0x00200000)
-#define READ_ONLY_SPACE_SIZE    (0x0bdfe000)
-
-#define STATIC_SPACE_START	(0x0c000000)
-#define STATIC_SPACE_SIZE	(0x03ffe000)
-
-#define DYNAMIC_0_SPACE_START	(0x10000000)
-#define DYNAMIC_1_SPACE_START	(0x18000000)
-#define DYNAMIC_SPACE_SIZE	(0x07ffe000)
-
-#define CONTROL_STACK_START	(0x00100000)
-#define CONTROL_STACK_SIZE	(0x0007e000)
-
-#define BINDING_STACK_START	(0x00180000)
-#define BINDING_STACK_SIZE	(0x0007e000)
-
-#ifdef SUNOS
-#define NUMBER_STACK_START	(0xf7ef0000)
-#else
-#define NUMBER_STACK_START	(0xf0000000)
-#endif
-#define NUMBER_STACK_SIZE	(0x00100000)
diff --git a/lisp/sunos-os.c b/lisp/sunos-os.c
deleted file mode 100644
index c3354747004146ec036502502cf7eea35aba5be3..0000000000000000000000000000000000000000
--- a/lisp/sunos-os.c
+++ /dev/null
@@ -1,700 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/sunos-os.c,v 1.1 1992/09/08 20:32:23 wlott Exp $
- *
- * OS-dependent routines.  This file (along with os.h) exports an
- * OS-independent interface to the operating system VM facilities.
- * Suprisingly, this interface looks a lot like the Mach interface
- * (but simpler in some places).  For some operating systems, a subset
- * of these functions will have to be emulated.
- *
- * This is the SunOS version.
- * March 1991, Miles Bader <miles@cogsci.ed.ack.uk> & ted <ted@edu.NMSU>
- *
- */
-
-/* #define DEBUG */
-
-#include <stdio.h>
-
-#include <signal.h>
-#include <sys/file.h>
-
-#include "os.h"
-
-/* block size must be larger than the system page size */
-#define SPARSE_BLOCK_SIZE (1<<15)
-#define SPARSE_SIZE_MASK (SPARSE_BLOCK_SIZE-1)
-
-#define PROT_DEFAULT OS_VM_PROT_ALL
-
-#define OFFSET_NONE ((os_vm_offset_t)(~0))
-
-#define EMPTYFILE "/tmp/empty"
-#define ZEROFILE "/dev/zero"
-
-#define MAX_SEGS 64
-
-extern char *getenv();
-
-/* ---------------------------------------------------------------- */
-
-#define ADJ_OFFSET(off,adj) (((off)==OFFSET_NONE) ? OFFSET_NONE : ((off)+(adj)))
-
-long os_vm_page_size=(-1);
-
-static struct segment {
-    os_vm_address_t start;	/* note: start & length are expected to be on page */
-    os_vm_size_t length;        /*       boundaries */
-    long file_offset;
-    short mapped_fd;
-    short protection;
-} addr_map[MAX_SEGS];
-
-static int n_segments=0;
-
-static int zero_fd=(-1), empty_fd=(-1);
-
-static os_vm_address_t last_fault=0;
-static os_vm_size_t real_page_size_difference=0;
-
-void os_init()
-{
-    char *empty_file=getenv("CMUCL_EMPTYFILE");
-
-    if(empty_file==NULL)
-	empty_file=EMPTYFILE;
-
-    empty_fd=open(empty_file,O_RDONLY|O_CREAT);
-    unlink(empty_file);
-
-    zero_fd=open(ZEROFILE,O_RDONLY);
-
-    os_vm_page_size=getpagesize();
-
-    if(os_vm_page_size>OS_VM_DEFAULT_PAGESIZE){
-	fprintf(stderr,"os_init: Pagesize too large (%d > %d)\n",
-		os_vm_page_size,OS_VM_DEFAULT_PAGESIZE);
-	exit(1);
-    }else{
-	/*
-	 * we do this because there are apparently dependencies on
-	 * the pagesize being OS_VM_DEFAULT_PAGESIZE somewhere...
-	 * but since the OS doesn't know we're using this restriction,
-	 * we have to grovel around a bit to enforce it, thus anything
-	 * that uses real_page_size_difference.
-	 */
-	real_page_size_difference=OS_VM_DEFAULT_PAGESIZE-os_vm_page_size;
-	os_vm_page_size=OS_VM_DEFAULT_PAGESIZE;
-    }
-}
-
-/* ---------------------------------------------------------------- */
-
-void seg_force_resident(struct segment *seg,
-			os_vm_address_t addr,
-			os_vm_size_t len)
-{
-    int prot=seg->protection;
-
-    if(prot!=0){
-	os_vm_address_t end=addr+len, touch=addr;
-		
-	while(touch<end){
-	    int contents=(*(char *)touch);
-	    if(prot&OS_VM_PROT_WRITE)
-		(*(char *)touch)=contents;
-	    touch=(os_vm_address_t)(((long)touch+SPARSE_BLOCK_SIZE)&~SPARSE_SIZE_MASK);
-	}
-    }
-}
-
-static struct segment *seg_create_nomerge(addr,len,protection,mapped_fd,file_offset)
-os_vm_address_t addr;
-os_vm_size_t len;
-int protection;
-int mapped_fd;
-{
-    int n;
-    struct segment *seg;
-
-    if(len==0)
-	return NULL;
-
-    if(n_segments==MAX_SEGS){
-	fprintf(stderr,"seg_create_nomerge: Out of segments\n");
-	return NULL;
-    }
-
-    for(n=n_segments, seg=addr_map; n>0; n--, seg++)
-	if(addr<seg->start){
-	    seg=(&addr_map[n_segments]);
-	    while(n-->0){
-		seg[0]=seg[-1];
-		seg--;
-	    }
-	    break;
-	}
-
-    n_segments++;
-
-    seg->start=addr;
-    seg->length=len;
-    seg->protection=protection;
-    seg->mapped_fd=mapped_fd;
-    seg->file_offset=file_offset;
-
-    return seg;
-}
-
-/* returns the first segment containing addr */
-static struct segment *seg_find(addr)
-os_vm_address_t addr;
-{
-    int n;
-    struct segment *seg;
-
-    for(n=n_segments, seg=addr_map; n>0; n--, seg++)
-	if(seg->start<=addr && seg->start+seg->length>addr)
-	    return seg;
-
-    return NULL;
-}
-
-/* returns TRUE if the range from addr to addr+len intersects with any segment */
-static boolean collides_with_seg_p(addr,len)
-os_vm_address_t addr;
-os_vm_size_t len;
-{
-    int n;
-    struct segment *seg;
-    os_vm_address_t end=addr+len;
-
-    for(n=n_segments, seg=addr_map; n>0; n--, seg++)
-	if(seg->start>=end)
-	    return FALSE;
-	else if(seg->start+seg->length>addr)
-	    return TRUE;
-
-    return FALSE;
-}
-
-#define seg_last_p(seg) (((seg)-addr_map)>=n_segments-1)
-
-static void seg_destroy(seg)
-struct segment *seg;
-{
-    if(seg!=NULL){
-	int n;
-
-	for(n=seg-addr_map+1; n<n_segments; n++){
-	    seg[0]=seg[1];
-	    seg++;
-	}
-
-	n_segments--;
-    }
-}
-
-static void seg_try_merge_next(seg)
-struct segment *seg;
-{
-    struct segment *nseg=seg+1;
-
-    if(!seg_last_p(seg)
-       && seg->start+seg->length==nseg->start
-       && seg->protection==nseg->protection
-       && seg->mapped_fd==nseg->mapped_fd
-       && ADJ_OFFSET(seg->file_offset,seg->length)==nseg->file_offset)
-    {
-	/* can merge with the next segment */
-#ifdef DEBUG
-	fprintf(stderr,
-		";;; seg_try_merge: Merged 0x%08x[0x%08x] with 0x%08x[0x%08x]\n",
-		seg->start,seg->length,nseg->start,nseg->length);
-#endif
-
-	if(((long)nseg->start&SPARSE_SIZE_MASK)!=0){
-	    /*
-	     * if not on a block boundary, we have to ensure both parts
-	     * of a common block are in a known state
-	     */
-	    seg_force_resident(seg,nseg->start-1,1);
-	    seg_force_resident(nseg,nseg->start,1);
-	}
-
-	seg->length+=nseg->length;
-	seg_destroy(nseg);
-    }
-}
-
-
-/*
- * Try to merge seg with adjacent segments.
- */
-static void seg_try_merge_adjacent(seg)
-struct segment *seg;
-{
-    if(!seg_last_p(seg))
-	seg_try_merge_next(seg);
-    if(seg>addr_map)
-	seg_try_merge_next(seg-1);
-}
-
-static struct segment *seg_create(addr,len,protection,mapped_fd,file_offset)
-os_vm_address_t addr;
-os_vm_size_t len;
-int protection;
-int mapped_fd;
-{
-    struct segment *seg=seg_create_nomerge(addr,len,protection,mapped_fd,file_offset);
-    if(seg!=NULL)
-	seg_try_merge_adjacent(seg);
-    return seg;
-}
-
-/* 
- * Change the attributes of the given range of an existing segment, and return
- * a segment corresponding to the new bit.
- */
-static struct segment *seg_change_range(seg,addr,len,protection,mapped_fd,file_offset)
-struct segment *seg;
-os_vm_address_t addr;
-os_vm_size_t len;
-int protection;
-int mapped_fd;
-{
-    os_vm_address_t end=addr+len;
-
-    if(len==0)
-	return NULL;
-
-    if(protection!=seg->protection
-       || mapped_fd!=seg->mapped_fd
-       || file_offset!=ADJ_OFFSET(seg->file_offset,addr-seg->start))
-    {
-	os_vm_size_t old_len=seg->length, seg_offset=(addr-seg->start);
-	
-	if(old_len<len+seg_offset){
-	    struct segment *next=seg+1;
-	    
-#ifdef DEBUG
-	    fprintf(stderr,
-		    ";;; seg_change_range: region 0x%08x[0x%08x] overflows 0x%08x[0x%08x]\n",
-		    addr,len,
-		    seg->start,old_len);
-#endif
-	    
-	    while(!seg_last_p(seg) && next->start+next->length<=end){
-#ifdef DEBUG
-		fprintf(stderr,
-			";;; seg_change_range: merging extra segment 0x%08x[0x%08x]\n",
-			next->start,
-			next->length);
-#endif
-		seg_destroy(next);
-	    }
-	    
-	    if(!seg_last_p(seg) && next->start<end){
-		next->length-=end-next->start;
-		next->start=end;
-		old_len=next->start-seg->start;
-	    }else
-		old_len=len+seg_offset;
-	    
-#ifdef DEBUG
-	    fprintf(stderr,
-		    ";;; seg_change_range: extended first seg to 0x%08x[0x%08x]\n",
-		    seg->start,
-		    old_len);
-#endif
-	}
-
-	if(seg_offset+len<old_len){
-	    /* add second part of old segment */
-	    seg_create_nomerge(end,
-			       old_len-(seg_offset+len),
-			       seg->protection,
-			       seg->mapped_fd,
-			       ADJ_OFFSET(seg->file_offset,seg_offset+len));
-
-#ifdef DEBUG
-	    fprintf(stderr,
-		    ";;; seg_change_range: Split off end of 0x%08x[0x%08x]: 0x%08x[0x%08x]\n",
-		    seg->start,old_len,
-		    end,old_len-(seg_offset+len));
-#endif
-	}
-
-	if(seg_offset==0){
-	    seg->length=len;
-	    seg->protection=protection;
-	    seg->mapped_fd=mapped_fd;
-	    seg->file_offset=file_offset;
-	}else{
-	    /* adjust first part of remaining old segment */
-	    seg->length=seg_offset;
-
-#ifdef DEBUG
-	    fprintf(stderr,
-		    ";;; seg_change_range: Split off beginning of 0x%08x[0x%08x]: 0x%08x[0x%08x]\n",
-		    seg->start,old_len,
-		    seg->start,seg_offset);
-#endif
-
-	    /* add new middle segment for new protected region */
-	    seg=seg_create_nomerge(addr,len,protection,mapped_fd,file_offset);
-	}
-
-	seg_try_merge_adjacent(seg);
-
-	last_fault=0;
-    }
-
-    return seg;
-}
-
-/* ---------------------------------------------------------------- */
-
-static os_vm_address_t mapin(addr,len,protection,map_fd,offset,is_readable)
-os_vm_address_t addr;
-os_vm_size_t len;
-int protection;
-int map_fd;
-long offset;
-int is_readable;
-{
-    os_vm_address_t real;
-    boolean sparse=(len>=SPARSE_BLOCK_SIZE);
-
-    if(offset!=OFFSET_NONE
-       && (offset<os_vm_page_size || (offset&(os_vm_page_size-1))!=0))
-    {
-	fprintf(stderr,
-		"mapin: file offset (%d) not multiple of pagesize (%d)\n",
-		offset,
-		os_vm_page_size);
-    }
-
-    if(addr==NULL)
-	len+=real_page_size_difference;	/* futz around to get an aligned region */
-
-    last_fault=0;
-    real=(os_vm_address_t)
-	mmap((caddr_t)addr,
-	     (long)len,
-	     sparse ? (is_readable ? PROT_READ|PROT_EXEC : 0) : protection,
-	     (addr==NULL? 0 : MAP_FIXED)|MAP_PRIVATE,
-	     (is_readable || !sparse) ? map_fd : empty_fd,
-	     (off_t)(offset==OFFSET_NONE ? 0 : offset));
-
-    if((long)real==-1){
-	perror("mapin: mmap");
-	return NULL;
-    }
-
-    if(addr==NULL){
-	/*
-	 * now play around with what the os gave us to make it align by
-	 * our standards (which is why we overallocated)
-	 */
-	os_vm_size_t overflow;
-
-	addr=os_round_up_to_page(real);
-	if(addr!=real)
-	    munmap(real,addr-real);
-	
-	overflow=real_page_size_difference-(addr-real);
-	if(overflow!=0)
-	    munmap(addr+len-real_page_size_difference,overflow);
-
-	real=addr;
-    }
-
-
-    return real;
-}
-
-static os_vm_address_t map_and_remember(addr,len,protection,map_fd,offset,is_readable)
-os_vm_address_t addr;
-os_vm_size_t len;
-int protection;
-int map_fd;
-long offset;
-int is_readable;
-{
-    os_vm_address_t real=mapin(addr,len,protection,map_fd,offset,is_readable);
-
-    if(real!=NULL){
-	struct segment *seg=seg_find(real);
-
-	if(seg!=NULL)
-	    seg=seg_change_range(seg,real,len,protection,map_fd,offset);
-	else
-	    seg=seg_create(real,len,protection,map_fd,offset);
-
-	if(seg==NULL){
-	    munmap(real,len);
-	    return NULL;
-	}
-    }
-
-#ifdef DEBUG
-    fprintf(stderr,";;; map_and_remember: 0x%08x[0x%08x] offset: %d, mapped to: %d\n",
-	    real,len,offset,map_fd);
-#endif
-
-    return real;
-}
-
-/* ---------------------------------------------------------------- */
-
-os_vm_address_t os_validate(addr, len)
-os_vm_address_t addr;
-os_vm_size_t len;
-{
-    addr=os_trunc_to_page(addr);
-    len=os_round_up_size_to_page(len);
-
-#ifdef DEBUG
-    fprintf(stderr, ";;; os_validate: 0x%08x[0x%08x]\n",addr,len);
-#endif
-
-    if(addr!=NULL && collides_with_seg_p(addr,len))
-	return NULL;
-
-    return map_and_remember(addr,len,PROT_DEFAULT,zero_fd,OFFSET_NONE,FALSE);
-}
-
-void os_invalidate(addr, len)
-os_vm_address_t addr;
-os_vm_size_t len;
-{
-    struct segment *seg=seg_find(addr);
-
-    addr=os_trunc_to_page(addr);
-    len=os_round_up_size_to_page(len);
-
-#ifdef DEBUG
-    fprintf(stderr, ";;; os_invalidate: 0x%08x[0x%08x]\n",addr,len);
-#endif
-
-    if(seg==NULL)
-	fprintf(stderr, "os_invalidate: Unknown segment: 0x%08x[0x%08x]\n",addr,len);
-    else{
-	seg=seg_change_range(seg,addr,len,0,0,OFFSET_NONE);
-	if(seg!=NULL)
-	    seg_destroy(seg);
-
-	last_fault=0;
-	if(munmap(addr,len)!=0)
-	    perror("os_invalidate: munmap");
-    }
-}
-
-os_vm_address_t os_map(fd, offset, addr, len)
-int fd;
-int offset;
-os_vm_address_t addr;
-long len;
-{
-    addr=os_trunc_to_page(addr);
-    len=os_round_up_size_to_page(len);
-
-#ifdef DEBUG
-    fprintf(stderr, ";;; os_map: 0x%08x[0x%08x]\n",addr,len);
-#endif
-
-    return map_and_remember(addr,len,PROT_DEFAULT,fd,offset,TRUE);
-}
-
-void os_flush_icache(address, length)
-os_vm_address_t address;
-os_vm_size_t length;
-{
-#if defined(MACH) && defined(mips)
-	vm_machine_attribute_val_t flush;
-	kern_return_t kr;
-
-	flush = MATTR_VAL_ICACHE_FLUSH;
-
-	kr = vm_machine_attribute(task_self(), address, length,
-				  MATTR_CACHE, &flush);
-	if (kr != KERN_SUCCESS)
-		mach_error("Could not flush the instruction cache", kr);
-#endif
-}
-
-void os_protect(addr, len, prot)
-os_vm_address_t addr;
-os_vm_size_t len;
-int prot;
-{
-    struct segment *seg=seg_find(addr);
-
-    addr=os_trunc_to_page(addr);
-    len=os_round_up_size_to_page(len);
-
-#ifdef DEBUG
-    fprintf(stderr,";;; os_protect: 0x%08x[0x%08x]\n",addr,len);
-#endif
-
-    if(seg!=NULL){
-	int old_prot=seg->protection;
-
-	if(prot!=old_prot){
-	    /*
-	     * oooooh, sick: we have to make sure all the pages being protected have
-	     * faulted in, so they're in a known state...
-	     */
-	    seg_force_resident(seg,addr,len);
-
-	    seg_change_range(seg,addr,len,prot,seg->mapped_fd,seg->file_offset);
-
-	    if(mprotect((caddr_t)addr,(long)len,prot)!=0)
-		perror("os_unprotect: mprotect");
-	}
-    }else
-	fprintf(stderr,"os_protect: Unknown segment: 0x%08x[0x%08x]\n",addr,len);
-}
-
-boolean valid_addr(test)
-os_vm_address_t test;
-{
-    return seg_find(test)!=NULL;
-}
-
-/* ---------------------------------------------------------------- */
-
-static boolean maybe_gc(sig, code, context)
-int sig, code;
-struct sigcontext *context;
-{
-    /*
-     * It's necessary to enable recursive SEGVs, since the handle is
-     * used for multiple things (e.g., both gc-trigger & faulting in pages).
-     * We check against recursive gc's though...
-     */
-
-    boolean did_gc;
-    static already_trying=0;
-
-    if(already_trying)
-	return FALSE;
-
-    sigsetmask(context->sc_mask);
-
-    already_trying=TRUE;
-    did_gc=interrupt_maybe_gc(sig, code, context);
-    already_trying=FALSE;
-
-    return did_gc;
-}
-
-/*
- * The primary point of catching segmentation violations is to allow 
- * read only memory to be re-mapped with more permissions when a write
- * is attempted.  this greatly decreases the residency of the program
- * in swap space since read only areas don't take up room
- *
- * Running into the gc trigger page will also end up here...
- */
-void segv_handler(sig, code, context, addr)
-int sig, code;
-struct sigcontext *context;
-caddr_t addr;
-{
-    if (code == SEGV_PROT) {	/* allow writes to this chunk */
-	struct segment *seg=seg_find(addr);
-
-	if(last_fault==addr){
-	    if(seg!=NULL && maybe_gc(sig, code, context))
-		/* we just garbage collected */
-		return;
-	    else{
-		/* a *real* protection fault */
-		fprintf(stderr,
-			"segv_handler: Real protection violation: 0x%08x\n",
-			addr);
-		interrupt_handle_now(sig,code,context);
-	    }
-	}else
-	    last_fault=addr;
-
-	if(seg!=NULL){
-	    int err;
-	    /* round down to a page */
-	    os_vm_address_t block=(os_vm_address_t)((long)addr&~SPARSE_SIZE_MASK);
-	    os_vm_size_t length=SPARSE_BLOCK_SIZE;
-
-	    if(block < seg->start){
-		length-=(seg->start - block);
-		block=seg->start;
-	    }
-	    if(block+length > seg->start+seg->length)
-		length=seg->start+seg->length-block;
-
-#if 0
-	    /* unmap it.  probably redundant. */
-	    if(munmap(block,length) == -1)
-		perror("segv_handler: munmap");
-#endif
-
-	    /* and remap it with more permissions */
-	    err=(int)
-		mmap(block,
-		     length,
-		     seg->protection,
-		     MAP_PRIVATE|MAP_FIXED,
-		     seg->mapped_fd,
-		     seg->file_offset==OFFSET_NONE
-		       ? 0
-		       : seg->file_offset+(block-seg->start));
-
-	    if (err == -1) {
-		perror("segv_handler: mmap");
-		interrupt_handle_now(sig,code,context);
-	    }
-	}
-	else{
-	    fprintf(stderr, "segv_handler: 0x%08x not in any segment\n",addr);
-	    interrupt_handle_now(sig,code,context);
-	}
-    }
-    /*
-     * note that we check for a gc-trigger hit even if it's not a PROT error
-     */
-    else if(!maybe_gc(sig, code, context)){
-	static int nomap_count=0;
-
-	if(code==SEGV_NOMAP){
-	    if(nomap_count==0){
-		fprintf(stderr,
-			"segv_handler: No mapping fault: 0x%08x\n",addr);
-		nomap_count++;
-	    }else{
-		/*
-		 * There should be higher-level protection against stack
-		 * overflow somewhere, but at least this prevents infinite
-		 * puking of error messages...
-		 */
-		fprintf(stderr,
-			"segv_handler: Recursive no mapping fault (stack overflow?)\n");
-		exit(-1);
-	    }
-	}else if(SEGV_CODE(code)==SEGV_OBJERR){
-	    extern int errno;
-	    errno=SEGV_ERRNO(code);
-	    perror("segv_handler: Object error");
-	}
-
-	interrupt_handle_now(sig,code,context);
-
-	if(code==SEGV_NOMAP)
-	    nomap_count--;
-    }
-}
-
-void os_install_interrupt_handlers()
-{
-    interrupt_install_low_level_handler(SIGSEGV,segv_handler);
-}
diff --git a/lisp/sunos-os.h b/lisp/sunos-os.h
deleted file mode 100644
index 8d2eb79c3ba92957fabc3fee4b387be1e5ffd6e2..0000000000000000000000000000000000000000
--- a/lisp/sunos-os.h
+++ /dev/null
@@ -1,13 +0,0 @@
-#include <sys/types.h>
-#include <sys/mman.h>
-
-typedef unsigned long os_vm_address_t;
-typedef long os_vm_size_t;
-typedef off_t os_vm_offset_t;
-typedef int os_vm_prot_t;
-
-#define OS_VM_PROT_READ PROT_READ
-#define OS_VM_PROT_WRITE PROT_WRITE
-#define OS_VM_PROT_EXECUTE PROT_EXEC
-
-#define OS_VM_DEFAULT_PAGESIZE	8192
diff --git a/lisp/undefineds.c b/lisp/undefineds.c
deleted file mode 100644
index 5770670229c1c6d23c0165263c03b495a1db23f2..0000000000000000000000000000000000000000
--- a/lisp/undefineds.c
+++ /dev/null
@@ -1,18 +0,0 @@
-/* Routines that must be linked into the core for lisp to work. */
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/undefineds.c,v 1.1 1992/09/08 20:19:03 wlott Exp $ */
-
-#ifdef sun
-#ifndef MACH
-#define SUNOS
-#endif
-#endif
-
-typedef int func();
-
-extern func
-#include "undefineds.h"
-;
-
-static func *foo[] = {
-#include "undefineds.h"
-};
diff --git a/lisp/undefineds.h b/lisp/undefineds.h
deleted file mode 100644
index fd755012d06ced7149671d3307cd0db47a2044fe..0000000000000000000000000000000000000000
--- a/lisp/undefineds.h
+++ /dev/null
@@ -1,157 +0,0 @@
-/* Routines that must be linked into the core for lisp to work. */
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/undefineds.h,v 1.1 1992/09/08 20:19:21 wlott Exp $ */
-
-/* Pick up all the syscalls. */
-accept,
-access,
-acct,
-adjtime,
-bind,
-brk,
-chdir,
-chmod,
-chown,
-chroot,
-close,
-connect,
-creat,
-dup,
-dup2,
-execve,
-exit,
-fchmod,
-fchown,
-fcntl,
-flock,
-fork,
-fstat,
-fsync,
-ftruncate,
-getdtablesize,
-getegid,
-geteuid,
-getgid,
-getgroups,
-gethostid,
-gethostname,
-getitimer,
-getpagesize,
-getpeername,
-getpgrp,
-getpid,
-getppid,
-getpriority,
-getrlimit,
-getrusage,
-getsockname,
-getsockopt,
-gettimeofday,
-getuid,
-ioctl,
-kill,
-killpg,
-link,
-listen,
-lseek,
-lstat,
-mkdir,
-mknod,
-mount,
-open,
-pipe,
-profil,
-ptrace,
-#if !defined(SUNOS) && !defined(parisc)
-quota,
-#endif
-read,
-readlink,
-readv,
-reboot,
-recv,
-recvfrom,
-recvmsg,
-rename,
-rmdir,
-sbrk,
-select,
-send,
-sendmsg,
-sendto,
-setgroups,
-#ifndef SUNOS
-sethostid,
-#endif
-sethostname,
-setitimer,
-setpgrp,
-setpriority,
-#if !defined(SUNOS) && !defined(parisc)
-setquota,
-#endif
-setregid,
-setreuid,
-setrlimit,
-setsockopt,
-settimeofday,
-shutdown,
-sigblock,
-sigpause,
-#ifndef ibmrt
-sigreturn,
-#endif
-sigsetmask,
-sigstack,
-sigvec,
-socket,
-socketpair,
-stat,
-swapon,
-symlink,
-sync,
-syscall,
-truncate,
-umask,
-#if !defined(SUNOS) && !defined(parisc)
-umount,
-#endif
-unlink,
-utimes,
-vfork,
-vhangup,
-wait,
-wait3,
-write,
-writev,
-
-/* Math routines. */
-cos,
-sin,
-tan,
-acos,
-asin,
-atan,
-atan2,
-sinh,
-cosh,
-tanh,
-asinh,
-acosh,
-atanh,
-exp,
-expm1,
-log,
-log10,
-log1p,
-pow,
-cbrt,
-sqrt,
-hypot,
-
-/* Network support. */
-gethostbyname,
-gethostbyaddr,
-
-/* Other random things. */
-getwd,
-ttyname
diff --git a/lisp/validate.c b/lisp/validate.c
deleted file mode 100644
index cbde6a116a77ab327fc349d5ced2ef79373a7eb1..0000000000000000000000000000000000000000
--- a/lisp/validate.c
+++ /dev/null
@@ -1,65 +0,0 @@
-/*
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/validate.c,v 1.2 1992/09/08 23:22:52 wlott Exp $
- *
- * Memory Validation
- */
-
-#include <stdio.h>
-#include "lisp.h"
-#include "os.h"
-#include "globals.h"
-#include "validate.h"
-
-static void ensure_space(lispobj *start, unsigned long size)
-{
-    if(os_validate((os_vm_address_t)start,(os_vm_size_t)size)==NULL){
-	fprintf(stderr,
-		"ensure_space: Failed to validate %ld bytes at 0x%08X\n",
-		size,
-		(unsigned long)start);
-	exit(1);
-    }
-}
-
-void validate(void)
-{
-#ifdef PRINTNOISE
-	printf("Validating memory ...");
-	fflush(stdout);
-#endif
-
-	/* Read-Only Space */
-	read_only_space = (lispobj *) READ_ONLY_SPACE_START;
-	ensure_space(read_only_space, READ_ONLY_SPACE_SIZE);
-
-	/* Static Space */
-	static_space = (lispobj *) STATIC_SPACE_START;
-	ensure_space(static_space, STATIC_SPACE_SIZE);
-
-	/* Dynamic-0 Space */
-	dynamic_0_space = (lispobj *) DYNAMIC_0_SPACE_START;
-	ensure_space(dynamic_0_space, DYNAMIC_SPACE_SIZE);
-
-	current_dynamic_space = dynamic_0_space;
-
-	/* Dynamic-1 Space */
-	dynamic_1_space = (lispobj *) DYNAMIC_1_SPACE_START;
-	ensure_space(dynamic_1_space, DYNAMIC_SPACE_SIZE);
-
-	/* Control Stack */
-	control_stack = (lispobj *) CONTROL_STACK_START;
-	ensure_space(control_stack, CONTROL_STACK_SIZE);
-
-	/* Binding Stack */
-	binding_stack = (lispobj *) BINDING_STACK_START;
-	ensure_space(binding_stack, BINDING_STACK_SIZE);
-
-	/* Number stack */
-#ifndef SUNOS
-	ensure_space((lispobj *)NUMBER_STACK_START, NUMBER_STACK_SIZE);
-#endif
-
-#ifdef PRINTNOISE
-	printf(" done.\n");
-#endif
-}
diff --git a/lisp/validate.h b/lisp/validate.h
deleted file mode 100644
index b01d8f59e7be5d80cfc0bd2f99985eb1e58a5050..0000000000000000000000000000000000000000
--- a/lisp/validate.h
+++ /dev/null
@@ -1,28 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/validate.h,v 1.1 1992/07/28 20:15:37 wlott Exp $ */
-
-#if !defined(_INCLUDE_VALIDATE_H_)
-#define _INCLUDE_VALIDATE_H_
-
-#ifdef parisc
-#include "hppa-validate.h"
-#endif parisc
-
-#ifdef mips
-#include "mips-validate.h"
-#endif
-
-#ifdef ibmrt
-#include "rt-validate.h"
-#endif
-
-#ifdef sparc
-#include "sparc-validate.h"
-#endif
-
-#ifdef i386
-#include "x86-validate.h"
-#endif
-
-extern void validate(void);
-
-#endif
diff --git a/lisp/vars.c b/lisp/vars.c
deleted file mode 100644
index 09aacbd760cc874a70ee8791be6760d3877f2f56..0000000000000000000000000000000000000000
--- a/lisp/vars.c
+++ /dev/null
@@ -1,173 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/vars.c,v 1.1 1992/07/28 20:15:38 wlott Exp $ */
-#include <stdio.h>
-#include <sys/types.h>
-#include <stdlib.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;
-    lispobj (*update_fn)(struct var *var);
-    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(char *name)
-{
-    unsigned long value = 0;
-
-    while (*name != '\0') {
-        value = (value << 1) ^ *(unsigned char *)(name++);
-        value = (value & (1-(1<<24))) ^ (value >> 24);
-    }
-
-    return value % NAME_BUCKETS;
-}
-
-static int hash_obj(lispobj obj)
-{
-    return (unsigned 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(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(char *name, lispobj obj, boolean perm)
-{
-    struct var *var = make_var(name, perm);
-    int index;
-
-    var->obj = obj;
-    var->update_fn = NULL;
-
-    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(char *name, lispobj updatefn(struct var *),
-			       boolean perm)
-{
-    struct var *var = make_var(name, perm);
-
-    var->update_fn = updatefn;
-
-    return var;
-}
-
-char *var_name(struct var *var)
-{
-    return var->name;
-}
-
-lispobj var_value(struct var *var)
-{
-    if (var->update_fn != NULL)
-        var->obj = (*var->update_fn)(var);
-    return var->obj;
-}
-
-long var_clock(struct var *var)
-{
-    return var->clock;
-}
-
-void var_setclock(struct var *var, long val)
-{
-    var->clock = val;
-}
diff --git a/lisp/vars.h b/lisp/vars.h
deleted file mode 100644
index 196f7f7bed8278deb877c04e2aa1b86b6351a607..0000000000000000000000000000000000000000
--- a/lisp/vars.h
+++ /dev/null
@@ -1,15 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/vars.h,v 1.1 1992/07/28 20:15:39 wlott Exp $ */
-
-
-extern void flush_vars(void);
-extern struct var *lookup_by_name(char *name);
-extern struct var *lookup_by_obj(lispobj obj);
-extern struct var *define_var(char *name, lispobj obj, boolean perm);
-extern struct var *define_dynamic_var(char *name,
-				      lispobj update_fn(struct var *var),
-				      boolean perm);
-
-extern char *var_name(struct var *var);
-extern lispobj var_value(struct var *var);
-extern long var_clock(struct var *var);
-extern void var_setclock(struct var *var, long value);
diff --git a/lisp/version.c b/lisp/version.c
deleted file mode 100644
index e0f531bac09e8ae4ec2847db70517731a4334f73..0000000000000000000000000000000000000000
--- a/lisp/version.c
+++ /dev/null
@@ -1,2 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/version.c,v 1.1 1992/07/28 20:15:40 wlott Rel $ */
-int version = VERSION;
diff --git a/motif/lisp/callbacks.lisp b/motif/lisp/callbacks.lisp
deleted file mode 100644
index 2eb5dabc6f0f09ce7190d02dea2bfa4180a37c4c..0000000000000000000000000000000000000000
--- a/motif/lisp/callbacks.lisp
+++ /dev/null
@@ -1,457 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Toolkit -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; This file contains all the functions which handle callbacks dispatched
-;;; from the C server.
-;;;
-
-(in-package "TOOLKIT")
-
-
-
-;;;; Functions for registering deferred actions
-
-(defvar *callback-deferred-action* nil)
-
-(defmacro with-callback-deferred-actions (&body forms)
-  `(setf *callback-deferred-action* #'(lambda () ,@forms)))
-
-(declaim (inline invoke-deferred-actions))
-(defun invoke-deferred-actions ()
-  (when *callback-deferred-action*
-    (let ((action *callback-deferred-action*))
-      (setf *callback-deferred-action* nil)
-      (funcall action))))
-
-
-
-;;;; Functions which track all registered callbacks
-;;;
-;;; The actual toolkit functions are provided by functions
-;;; %add-callback, %remove-callback, etc.
-;;;
-;;; The callback hash table is keyed on:
-;;;      (widget-id . callback-name)
-;;; The callback data is (fn . client-data)
-
-(defun add-callback (widget sym-name fn &rest args)
-  "Registers a callback function on the specified widget."
-  (declare (type widget widget)
-	   (type (or symbol function) fn)
-	   (keyword sym-name))
-  (let* ((name (symbol-resource sym-name))
-	 (table (motif-connection-callback-table *motif-connection*))
-	 (key (cons (widget-id widget) name))
-	 (data (cons fn args)))
-
-    (unless (member sym-name (widget-callbacks widget))
-      (%add-callback widget name)
-      (push sym-name (widget-callbacks widget)))
-    (setf (gethash key table) (cons data (gethash key table)))))
-
-
-;; The 'args' list must be EQUAL to the args passed when the callback was
-;; created for this callback to be removed.
-
-(defun remove-callback (widget sym-name fn &rest args)
-  "Removes a callback function from the specified widget."
-  (declare (type widget widget)
-	   (type (or symbol function) fn)
-	   (keyword sym-name))
-  (let* ((name (symbol-resource sym-name))
-	 (table (motif-connection-callback-table *motif-connection*))
-	 (key (cons (widget-id widget) name))
-	 (data (cons fn args))
-	 (new-list (delete data (gethash key table) :test #'equal)))
-
-    (setf (gethash key table) new-list)
-    (unless new-list
-      (%remove-callback widget name)
-      (setf (widget-callbacks widget)
-	    (delete sym-name (widget-callbacks widget) :test #'eq)))))
-
-(defun remove-all-callbacks (widget sym-name)
-  "Removes all callback functions on the specified widget."
-  (declare (type widget widget)
-	   (keyword sym-name))
-  (let* ((name (symbol-resource sym-name))
-	 (table (motif-connection-callback-table *motif-connection*))
-	 (key (cons (widget-id widget) name)))
-    (%remove-callback widget name)
-    (setf (gethash key table) nil)
-    (setf (widget-callbacks widget)
-	  (delete sym-name (widget-callbacks widget) :test #'eq))))
-
-(defun handle-callback (reply)
-  (unwind-protect
-      (let* ((widget (toolkit-read-value reply))
-	     (name (toolkit-read-value reply))
-	     (table (motif-connection-callback-table *motif-connection*))
-	     (calldata (read-callback-info widget reply)))
-	;; Invoke the callback function
-	(dolist (callback (gethash (cons (widget-id widget) name) table))
-	  (apply (car callback)
-		 widget
-		 calldata
-		 (cdr callback))))
-    (unless (motif-connection-terminated *motif-connection*)
-      (terminate-callback)
-      (invoke-deferred-actions))
-    (destroy-message reply)))
-
-
-
-;;;; Functions which deal with protocol callbacks
-;;;
-;;; The protocol table is keyed on:
-;;;           (widget property protocol)
-;;; The data stored in the table is:
-;;;           (fn . call-data)
-
-(defun add-protocol-callback (widget property protocol fn &rest args)
-  "Registers a protocol callback function on the specified widget."
-  (declare (type widget widget)
-	   (type keyword property protocol)
-	   (type (or symbol function) fn))
-  (let* ((table (motif-connection-protocol-table *motif-connection*))
-	 (key (list (widget-id widget) property protocol))
-	 (data (cons fn args)))
-
-    (let ((entry (cons property protocol)))
-      (unless (member entry (widget-protocols widget))
-	(push entry (widget-protocols widget))
-	(%add-protocol-callback widget property protocol)))
-    (setf (gethash key table) (cons data (gethash key table)))))
-
-(defun remove-protocol-callback (widget property protocol fn &rest args)
-  "Removes a protocol callback function on the specified widget."
-  (declare (type widget widget)
-	   (type keyword property protocol)
-	   (type (or symbol function) fn))
-  (let* ((table (motif-connection-protocol-table *motif-connection*))
-	 (key (list (widget-id widget) property protocol))
-	 (data (cons fn args))
-	 (new-list (delete data (gethash key table) :test #'equal)))
-    (setf (gethash key table) new-list)
-    (unless new-list
-      (%remove-protocol-callback widget property protocol)
-      (setf (widget-protocols widget)
-	    (delete (cons property protocol) (widget-protocols widget)
-		    :test #'equal)))))
-
-;; (declaim (inline add-wm-protocol-callback remove-wm-protocol-callback))
-(defun add-wm-protocol-callback (widget protocol fn &rest args)
-  "Registers a window manager protocol callback function on the specified
-   widget."
-  (declare (type widget widget)
-	   (keyword protocol)
-	   (type (or symbol function) fn))
-  (apply #'add-protocol-callback widget :wm-protocols protocol fn args))
-
-(defun remove-wm-protocol-callback (widget protocol fn &rest args)
-  "Removes a window manager protocol callback function on the specified
-   widget."
-  (declare (type widget widget)
-	   (keyword protocol)
-	   (type (or symbol function) fn))
-  (apply #'remove-protocol-callback widget :wm-protocols protocol fn args))
-
-(defun handle-protocol (reply)
-  (unwind-protect
-      (let* ((widget (toolkit-read-value reply))
-	     (property (toolkit-read-value reply))
-	     (protocol (toolkit-read-value reply))
-	     (event (toolkit-read-value reply))
-	     (table (motif-connection-protocol-table *motif-connection*))
-	     (calldata (make-any-callback :reason :cr-protocols :event event)))
-	(dolist (callback (gethash (list (widget-id widget) property protocol)
-				   table))
-	  (apply (car callback)
-		 widget
-		 calldata
-		 (cdr callback))))
-    (unless (motif-connection-terminated *motif-connection*)
-      (terminate-callback)
-      (invoke-deferred-actions))
-    (destroy-message reply)))
-
-				   
-
-;;;; Functions for dealing with call-data info
-
-;;; These structures are used to hold the various callback information.
-;;; When the server begins processing a callback, it will dump the callback
-;;; data into the message in slot order.  The client will unpack the data
-;;; and create a callback structure which will be passed to the Lisp
-;;; callback as the call-data.  It reason field, possibly together with the
-;;; widget class, will be enough to determine what callback structure is
-;;; appropriate.  The event slot is the (XEvent *) received in C.  If the
-;;; client wants access to the event, there will be some sort of macro such
-;;; as (with-event-info ((<callback-struct>) ... <slots to bind>)  ....) or
-;;; something.  This will be added later.
-(defstruct (any-callback
-	    (:print-function print-callback))
-  (reason :cr-none :type keyword)
-  (event  0 :type (unsigned-byte 32)))
-
-(defun print-callback (callback stream d)
-  (declare (ignore d)
-	   (stream stream))
-  (format stream "#<Motif Callback -- ~a>" (any-callback-reason callback)))
-
-(defstruct (button-callback
-	    (:include any-callback)
-	    (:print-function print-callback)
-	    (:constructor make-button-callback (reason event click-count)))
-  (click-count 0 :type fixnum))
-
-(defstruct (drawing-area-callback
-	    (:include any-callback)
-	    (:print-function print-callback)
-	    (:constructor make-drawing-area-callback (reason event window)))
-  window)
-
-(defstruct (drawn-button-callback
-	    (:include any-callback)
-	    (:print-function print-callback)
-	    (:constructor make-drawn-button-callback
-			  (reason event window click-count)))
-  window
-  (click-count 0 :type fixnum))
-
-;;; RowColumnCallbackStruct is weird and probably not necessary
-
-(defstruct (scroll-bar-callback
-	    (:include any-callback)
-	    (:print-function print-callback)
-	    (:constructor make-scroll-bar-callback (reason event value pixel)))
-  (value 0 :type fixnum)
-  (pixel 0 :type fixnum))
-
-(defstruct (toggle-button-callback
-	    (:include any-callback)
-	    (:print-function print-callback)
-	    (:constructor make-toggle-button-callback (reason event set)))
-  (set nil :type (member t nil)))
-
-;;; ListCallbackStruct is fairly complex
-(defstruct (list-callback
-	    (:include any-callback)
-	    (:print-function print-callback)
-	    (:constructor make-list-callback (reason event item item-position)))
-  (item nil :type (or null xmstring))
-  (item-position 0 :type fixnum)
-  (selected-items nil :type list)  ;; a list of strings (maybe array?)
-  (selected-item-positions nil :type list) ;; of integers
-  (selection-type 0 :type fixnum))
-
-;; used for selection-box and command callbacks
-(defstruct (selection-callback
-	    (:include any-callback)
-	    (:print-function print-callback)
-	    (:constructor make-selection-callback (reason event value)))
-  (value nil :type (or null xmstring)))
-
-(defstruct (file-selection-callback
-	    (:include selection-callback)
-	    (:print-function print-callback)
-	    (:constructor make-file-selection-callback
-			  (reason event value mask dir pattern)))
-  (mask nil :type (or null xmstring))
-  (dir nil :type (or null xmstring))
-  (pattern nil :type (or null xmstring)))
-
-(defstruct (scale-callback
-	    (:include any-callback)
-	    (:print-function print-callback)
-	    (:constructor make-scale-callback (reason event value)))
-  (value 0 :type fixnum))
-
-(defstruct (text-callback
-	    (:include any-callback)
-	    (:print-function print-callback)
-	    (:constructor make-text-callback
-			  (reason event)))
-  (doit t :type (member t nil))
-  (curr-insert 0 :type fixnum)
-  (new-insert 0 :type fixnum)
-  (start-pos 0 :type fixnum)
-  (end-pos 0 :type fixnum)
-  (text "" :type simple-string)
-  format ;; ***** Don't yet know what this is
-)
-
-(defun read-callback-info (widget reply)
-  (let* ((reason (toolkit-read-value reply))
-	 (event (toolkit-read-value reply)))
-    (case (widget-type widget)
-      ((:arrow-button :arrow-button-gadget :push-button :push-button-gadget)
-       (make-button-callback reason event (toolkit-read-value reply)))
-      (:drawing-area
-       (make-drawing-area-callback reason event (toolkit-read-value reply)))
-      (:drawn-button
-       (let* ((window (toolkit-read-value reply))
-	      (count (toolkit-read-value reply)))
-	 (make-drawn-button-callback reason event window count)))
-      (:scroll-bar
-       (let* ((value (toolkit-read-value reply))
-	      (pixel (toolkit-read-value reply)))
-	 (make-scroll-bar-callback reason event value pixel)))
-      ((:toggle-button :toggle-button-gadget)
-       (make-toggle-button-callback reason event (toolkit-read-value reply)))
-      (:list
-       (let* ((item (toolkit-read-value reply))
-	      (item-position (toolkit-read-value reply))
-	      (info (make-list-callback reason event item item-position)))
-	 (when (or (eq reason :cr-multiple-select)
-		   (eq reason :cr-extended-select))
-	   (setf (list-callback-selected-items info)
-		 (toolkit-read-value reply))
-	   (setf (list-callback-selected-item-positions info)
-		 (toolkit-read-value reply))
-	   (setf (list-callback-selection-type info)
-		 (toolkit-read-value reply)))
-	 info))
-      (:text
-       (let ((info (make-text-callback reason event)))
-	 (when (member reason '(:cr-losing-focus :cr-modifying-text-value
-						 :cr-moving-insert-cursor))
-	   (setf (text-callback-doit info) (toolkit-read-value reply))
-	   (setf (text-callback-curr-insert info) (toolkit-read-value reply))
-	   (setf (text-callback-new-insert info) (toolkit-read-value reply))
-	   
-	   (case reason
-	     (:cr-losing-focus
-	      (setf (text-callback-start-pos info) (toolkit-read-value reply))
-	      (setf (text-callback-end-pos info) (toolkit-read-value reply)))
-	     (:cr-modifying-text-value
-	      (setf (text-callback-start-pos info) (toolkit-read-value reply))
-	      (setf (text-callback-end-pos info) (toolkit-read-value reply))
-	      (setf (text-callback-text info) (toolkit-read-value reply))
-	      (setf (text-callback-format info) (toolkit-read-value reply))
-	      )))
-	 info))
-      ((:selection-box :command)
-       (make-selection-callback reason event (toolkit-read-value reply)))
-      (:file-selection-box
-       (let* ((value (toolkit-read-value reply))
-	      (mask (toolkit-read-value reply))
-	      (dir (toolkit-read-value reply))
-	      (pattern (toolkit-read-value reply)))
-	 (make-file-selection-callback reason event
-				       value mask dir pattern)))
-      (:scale
-       (make-scale-callback reason event (toolkit-read-value reply)))
-      (t nil))))
-
-(defmacro with-callback-event ((event cback) &body forms)
-  `(let ((,event (transport-event (any-callback-event ,cback))))
-     ,@forms))
-
-
-
-;;;; Action table support
-
-(defmacro with-action-event ((event handle) &body forms)
-  `(let ((,event (transport-event ,handle)))
-     ,@forms))
-
-(defun handle-action (reply)
-  (let* ((widget (toolkit-read-value reply))
-	 (event-handle (toolkit-read-value reply))
-	 (fun-name (toolkit-read-value reply)))
-    (unwind-protect
-	(funcall (read-from-string fun-name) widget event-handle)
-      (unless (motif-connection-terminated *motif-connection*)
-	(terminate-callback)
-	(invoke-deferred-actions))
-      (destroy-message reply))))
-
-
-
-;;;; Functions for managing event handlers
-
-(defun add-event-handler (widget event-mask non-maskable function &rest args)
-  "Registers an event handler function on the specified widget."
-  (declare (type widget widget)
-	   (type (or symbol list) event-mask)
-	   (type (member t nil) non-maskable)
-	   (type (or symbol function) function))
-  (when (symbolp event-mask)
-    (setf event-mask (list event-mask)))
-  (let ((table (motif-connection-event-table *motif-connection*))
-	(data (cons function args)))
-    (dolist (event-class event-mask)
-      (let ((mask (xlib:make-event-mask event-class))
-	    (key (cons (widget-id widget) event-class)))
-
-	(unless (member data (gethash key table) :test #'equal)
-	  (push data (gethash key table)))
-	(unless (member event-class (widget-events widget))
-	  (push event-class (widget-events widget))
-	  (%add-event-handler widget mask nil))))
-    (when non-maskable
-      (let ((mask 0) ; NoEventMask
-	    (key (cons (widget-id widget) :non-maskable-mask)))
-	(unless (member data (gethash key table) :test #'equal)
-	  (push data (gethash key table)))
-	(unless (member :non-maskable-mask (widget-events widget))
-	  (push :non-maskable-mask (widget-events widget))
-	  (%add-event-handler widget mask t))))))
-
-(defun remove-event-handler (widget event-mask non-maskable function &rest args)
-  "Removes an event handler function on the specified widget."
-  (declare (type widget widget)
-	   (type (or symbol list) event-mask)
-	   (type (member t nil) non-maskable)
-	   (type (or symbol function) function))
-  (when (symbolp event-mask)
-    (setf event-mask (list event-mask)))
-  (let ((table (motif-connection-event-table *motif-connection*))
-	(data (cons function args)))
-    (dolist (event-class event-mask)
-      (let* ((mask (xlib:make-event-mask event-class))
-	     (key (cons (widget-id widget) event-class))
-	     (new-list (delete data (gethash key table) :test #'equal)))
-	(unless new-list
-	  (setf (widget-events widget)
-		(delete event-class (widget-events widget)))
-	  (%remove-event-handler widget mask nil))))
-    (when non-maskable
-      (let* ((mask 0) ; NoEventMask
-	     (key (cons (widget-id widget) :non-maskable-mask))
-	     (new-list (delete data (gethash key table) :test #'equal)))
-	(unless new-list
-	  (setf (widget-events widget)
-		(delete :non-maskable-mask (widget-events widget)))
-	  (%remove-event-handler widget mask t))))))
-
-(defun handle-event (reply)
-  (unwind-protect
-      (let* ((widget (toolkit-read-value reply))
-	     (mask (toolkit-read-value reply))
-	     (nonmaskable (toolkit-read-value reply))
-	     (event (toolkit-read-value reply))
-	     (table (motif-connection-event-table *motif-connection*))
-	     (event-class))
-
-	(setf event-class (if nonmaskable
-			      :non-maskable-mask
-			      (car (xlib:make-event-keys mask))))
-	(dolist (handler (gethash (cons (widget-id widget) event-class) table))
-	  (apply (car handler)
-		 widget
-		 event
-		 (cdr handler))))
-    (unless (motif-connection-terminated *motif-connection*)
-      (terminate-callback)
-      (invoke-deferred-actions))
-    (destroy-message reply)))
diff --git a/motif/lisp/conversion.lisp b/motif/lisp/conversion.lisp
deleted file mode 100644
index f2a5e22bf67f2a7bf0dc42e71fb503d33890b7b0..0000000000000000000000000000000000000000
--- a/motif/lisp/conversion.lisp
+++ /dev/null
@@ -1,364 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Toolkit-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; These are the functions necessary for reading/writing Lisp data objects
-;;; into messages for communicating with the C server.
-;;;
-
-(in-package "TOOLKIT-INTERNALS")
-
-
-
-;;;; Type definitions
-
-;;; This table maps normal type tags into the symbol for their type.
-;;; Symbol types include :xid, :int, :widget, etc.
-(defvar *type-table* (make-array 80 :element-type 'cons))
-
-(defvar *enum-table* (make-hash-table :test #'eq))
-
-
-
-;;;; Functions for extracting/creating typed data in messages
-
-(declaim (inline combine-type-and-data))
-(defun combine-type-and-data (type data)
-  (declare (type (unsigned-byte 24) data)
-	   (keyword type))
-  (let ((tag (get type :xtk-type-tag)))
-    (declare (type (unsigned-byte 8) tag))
-    (logior (ash tag 24) data)))
-
-(declaim (inline extract-type-and-data))
-(defun extract-type-and-data (stuff)
-  (declare (type (unsigned-byte 32) stuff))
-  (let ((tag (ash stuff -24))
-	(data (logand stuff #x00FFFFFF)))
-    (declare (type (unsigned-byte 8) tag)
-	     (type (unsigned-byte 24) data))
-    (values tag data)))
-
-
-
-;;;; Interface functions for transporting resource values
-
-;;; In non-CMU Lisps, this can be converted into a (declaim (inline ...))
-;;; and add a (declaim (notinline ..)) after the function.
-; (declaim (maybe-inline toolkit-write-value))
-
-(defun toolkit-write-value (message value &optional (type t))
-  (typecase value
-    (widget (message-write-widget message value))
-    (motif-object (message-write-motif-object message value))
-    (simple-string 
-     (if (eq type :atom)
-	 (message-write-atom message value)
-	 (message-write-string message value)))
-    (xlib:font (message-write-xid message (xlib:font-id value) :font))
-    (xlib:cursor (message-write-xid message (xlib:cursor-id value) :cursor))
-    ((unsigned-byte 24)
-     (message-put-dblword message (combine-type-and-data :short value)))
-    ((signed-byte 32)
-     (message-put-dblword message (combine-type-and-data :int 0))
-     (message-put-dblword message value))
-    ((member t nil)
-     (if (eq type t)
-	 (message-write-boolean message value)
-	 ;; It's a null list
-	 (message-put-dblword message
-			      (combine-type-and-data type 0))))
-    (list
-     (case type
-       (:resource-list (message-write-resource-list message value))
-       (:resource-names (message-write-resource-names message value))
-       (:widget-list (message-write-widget-list message value))
-       (:xm-string-table (message-write-xmstring-table message value))
-       (:string-table (message-write-string-table message value))
-       (:int-list (message-write-int-list message value))
-       (t (toolkit-error "Illegal list type -- ~a for ~s" type value))))
-    (symbol
-     (cond
-      ((eq type :atom) (message-write-atom message value))
-      ((get value :widget-class) (message-write-widget-class message value))
-      ((get value :enum-value) (message-write-enum message value))
-      (t (message-write-function message value))))
-    (function (message-write-function message value))
-    (xlib:color (message-write-color message value))
-    (t
-     (toolkit-error "Unsupported argument type -- ~a for ~a"
-		    (type-of value) value))))
-
-(declaim (inline lookup-function))
-(defun lookup-function (fid)
-  (aref (motif-connection-function-table *motif-connection*) fid))
-
-(defun toolkit-read-value (message)
-  (multiple-value-bind (tag data)
-		       (extract-type-and-data (message-get-dblword message))
-    (declare (type (unsigned-byte 8) tag)
-	     (type (unsigned-byte 24) data))
-    (let ((type (cdr (svref *type-table* tag))))
-      (case type
-	(:widget (find-widget (message-get-dblword message)))
-	(:xm-string (find-motif-object (message-get-dblword message) type))
-	(:short  data)
-	(:atom (xlib:atom-name *x-display* (message-get-dblword message)))
-	(:boolean (not (zerop data)))
-	(:int (message-get-dblword message))
-	(:xid (get-xresource (message-get-dblword message) tag))
-	(:function (lookup-function data))
-	(:string-token (svref *toolkit-string-table* data))
-	((:resource-list :xm-string-table :string-table :int-list)
-	 (message-read-list message data))
-	(:widget-list (break "Shouldn't be reading WidgetList."))
-	(:string (message-read-string message data))
-	(:translation-table
-	 (find-motif-object (message-get-dblword message) type))
-	(:accelerator-table
-	 (find-motif-object (message-get-dblword message) type))
-	(:font-list (find-motif-object (message-get-dblword message) type))
-	(:event (construct-event message))
-	(:float (vm::make-single-float (message-get-dblword message)))
-	(:color (message-read-color message data))
-	(t  ;; assume an enumerated value
-	 (let ((table (gethash type *enum-table*)))
-	   (unless table
-	     (toolkit-error "Unknown or illegal value type -- ~a" type))
-	   (cdr (assoc data table))))))))
-
-
-
-;;;; Functions for reading/writing strings
-
-(defun packet-write-string (packet string start length)
-  (declare (simple-string string)
-	   (fixnum start length))
-  (kernel:copy-to-system-area string
-			      (+ (the fixnum (* start vm:byte-bits))
-				 (the fixnum
-				      (* vm:vector-data-offset vm:word-bits)))
-			      (packet-head packet)
-			      (* (packet-fill packet) vm:byte-bits)
-			      (* length vm:byte-bits))
-  (incf (packet-fill packet) length)
-  (incf (packet-length packet) length))
-
-(defun packet-read-string (packet string start length)
-  (declare (simple-string string)
-	   (fixnum start length))
-  (kernel:copy-from-system-area (packet-head packet)
-				(* (packet-fill packet) vm:byte-bits)
-				string
-				(+ (the fixnum (* start vm:byte-bits))
-				   (the fixnum
-					(* vm:vector-data-offset vm:word-bits)))
-				(* length vm:byte-bits))
-  (incf (packet-fill packet) length))
-
-(defun message-read-string (message length)
-  (declare (fixnum length))
-  ;; length includes the '\0'
-  (let ((string (make-string (1- length) :initial-element #\Space)))
-    (declare (simple-string string))
-    ;;
-    ;; ***** This is of course a gross oversimplification !!!
-    (packet-read-string (message-fill-packet message)
-			string 0 length)
-    (let ((packet (message-fill-packet message)))
-      (let ((pad (- 4 (mod (packet-fill packet) 4))))
-      (unless (> pad 3)
-	(dotimes (i pad)
-	  (packet-get-byte packet))))
-    string)))
-
-(defun message-write-string (message string)
-  (declare (simple-string string))
-  (let ((token (position string *toolkit-string-table* :test #'string=)))
-    (if token
-	(message-put-dblword message
-			     (combine-type-and-data :string-token token))
-	(let ((length (1+ (length string))))
-	  ;; We put the type header here so that we'll spill over into a new
-	  ;; packet if necessary
-	  (message-put-dblword message (combine-type-and-data :string length))
-	  (let ((packet (message-fill-packet message)))
-	    (cond
-	     ((< (+ length (packet-length packet)) *packet-size*)
-	      (packet-write-string packet string 0 length))
-	     ((< length (- *packet-size* *header-size*))
-	      (message-add-packet message)
-	      (setf packet (message-fill-packet message))
-	      (packet-write-string (message-fill-packet message)
-				   string 0 length))
-	     (t
-	      (break "Attempt to write a string larger than *packet-size*.
-		      Come back later to get this to work.")))
-	    (let ((pad (- 4 (mod (packet-fill packet) 4))))
-	      (unless (> pad 3)
-		(dotimes (i pad)
-		  (packet-put-byte packet 0)))))))))
-
-
-
-;;;; Functions for writing most other types
-
-(defun message-write-widget (message widget)
-  (message-put-dblword message (combine-type-and-data :widget 0))
-  (message-put-dblword message (widget-id widget)))
-
-(defun message-write-widget-list (message list)
-  (declare (list list))
-  (let ((length (length list)))
-    (message-put-dblword message
-			 (combine-type-and-data :widget-list length))
-    (dolist (widget list)
-      (message-write-widget message widget))))
-
-(defun message-write-widget-class (message widget-class)
-  (let ((val (get widget-class :widget-class)))
-    (message-put-dblword message
-			 (combine-type-and-data :widget-class val))))
-
-(defun message-write-xid (message id type)
-  (message-put-dblword message (combine-type-and-data type 0))
-  (message-put-dblword message id))
-
-(defun message-write-atom (message atom)
-  (declare (type xlib:xatom atom))
-  (let ((id (xlib:find-atom *x-display* atom)))
-    (unless id
-      (setf id (xlib:intern-atom *x-display* atom))
-      (xlib:display-force-output *x-display*))
-    (message-put-dblword message (combine-type-and-data :atom 0))
-    (message-put-dblword message id)))
-
-(defun message-write-enum (message enum)
-  (let ((val (get enum :enum-value)))
-    (message-put-dblword message (combine-type-and-data :enum val))))
-
-(defun message-write-boolean (message value)
-  (let ((intval (if value 1 0)))
-    (message-put-dblword message (combine-type-and-data :boolean intval))))
-
-(defun message-write-function (message fn)
-  (let ((fn-id (find-function-id fn)))
-    (message-put-dblword message (combine-type-and-data :function fn-id))))
-
-(defun message-write-motif-object (message obj)
-  (message-put-dblword message
-		       (combine-type-and-data (motif-object-type obj) 0))
-  (message-put-dblword message (motif-object-id obj)))
-
-(defun message-write-int-list (message list)
-  (declare (list list))
-  (let ((length (length list)))
-    (message-put-dblword message
-			 (combine-type-and-data :int-list length))
-    (dolist (int list)
-      (message-put-dblword message (combine-type-and-data :int 0))
-      (message-put-dblword message int))))
-
-(defun message-write-xmstring-table (message list)
-  (declare (list list))
-  (let ((length (length list)))
-    (message-put-dblword message
-			 (combine-type-and-data :xm-string-table length))
-    (dolist (string list)
-      (typecase string
-	(simple-string (message-write-string message string))
-	(xmstring (message-write-motif-object message string))
-	(t (toolkit-error "Invalid entry in XmStringTable -- ~s" string))))))
-
-(defun message-write-string-table (message list)
-  (declare (list list))
-  (let ((length (length list)))
-    (message-put-dblword message
-			 (combine-type-and-data :string-table length))
-    (dolist (string list)
-      (message-write-string message string))))
-
-(defun  message-write-resource-names (message list)
-  (declare (list list))
-  (let ((length (length list)))
-    (message-put-dblword message
-			 (combine-type-and-data :resource-names length))
-    (dolist (name list)
-      (message-write-string message name))))
-
-(defun message-write-resource-list (message list)
-  (declare (list list))
-  (let ((length (length list)))
-    (unless (zerop (mod length 2))
-      (toolkit-error "Resource list of odd length -- ~a" list))
-    (message-put-dblword message
-			 (combine-type-and-data :resource-list length))
-    (loop
-      (let ((name (first list))
-	    (value (second list))
-	    (rest (cddr list)))
-	(message-write-string message name)
-	(toolkit-write-value message value)
-	(unless rest (return))
-	(setf list rest)))))
-
-(defun message-read-list (message length)
-  (declare (fixnum length))
-  (let ((list))
-    (dotimes (i length)
-      (push (toolkit-read-value message) list))
-    (nreverse list)))
-
-(defun message-read-color (message red)
-  (let* ((green (message-get-word message))
-	 (blue (message-get-word message)))
-    (xlib:make-color :blue (the single-float (/ blue 65535.0))
-		     :red (the single-float (/ red 65535.0))
-		     :green (the single-float (/ green 65535.0)))))
-
-(defun message-write-color (message color)
-  (let ((green (round (* (xlib:color-green color) 65535)))
-	(red (round (* (xlib:color-red color) 65535)))
-	(blue (round (* (xlib:color-blue color)) 65535)))
-    (declare (type (unsigned-byte 16) green red blue))
-    (message-put-dblword message
-			 (combine-type-and-data :color red))
-    (message-put-word message green)
-    (message-put-word message blue)))
-		     
-
-
-;;;; Functions for handling resource ID's
-
-(defun find-function-id (fn)
-  (declare (type (or symbol function) fn))
-  (let* ((fn-table (motif-connection-function-table *motif-connection*))
-	 (pos (position fn fn-table)))
-    (declare (vector fn-table))
-    (unless pos
-      (setf pos (vector-push-extend fn fn-table)))
-    pos))
-
-(defun get-xresource (xid tag)
-  (let ((kind (car (svref *type-table* tag))))
-    (case kind
-      (:window (xlib::lookup-window *x-display* xid))
-      (:pixmap (xlib::lookup-pixmap *x-display* xid))
-      (:cursor (xlib::lookup-cursor *x-display* xid))
-      (:colormap (xlib::lookup-colormap *x-display* xid))
-      (:font (xlib::lookup-font *x-display* xid))
-      (t
-       (toolkit-error "Unknown X resource type -- ~a" kind)))))
-
-(defun construct-event (message)
-  (let ((packet (message-fill-packet message)))
-    (alien:sap-alien (system:sap+ (packet-head packet)
-				  (packet-fill packet))
-		     xevent)))
diff --git a/motif/lisp/events.lisp b/motif/lisp/events.lisp
deleted file mode 100644
index b16323413cc7a1e69b5bf4fe57973daa03349700..0000000000000000000000000000000000000000
--- a/motif/lisp/events.lisp
+++ /dev/null
@@ -1,876 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Toolkit-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; Alien definitions for all the various XEvent structures.
-;;;
-
-(in-package "TOOLKIT-INTERNALS")
-
-
-
-;;;; Definitions of the various XEvent structures
-;;; We never include the (Display *) because it would be useless in Lisp and
-;;; we add the HANDLE field so that we can pass this event back to C.
-
-(def-alien-type xid (unsigned 32))
-(def-alien-type window xid)
-(def-alien-type colormap xid)
-(def-alien-type drawable xid)
-(def-alien-type atom (unsigned 32))
-(def-alien-type bool (boolean 32))
-(def-alien-type time (unsigned 32))
-
-(def-alien-type x-key-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (root window)
-    (subwindow window)
-    (time time)
-    (x int)
-    (y int)
-    (x-root int)
-    (y-root int)
-    (state unsigned-int)
-    (keycode unsigned-int)
-    (same-screen bool)))
-
-(def-alien-type x-button-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (root window)
-    (subwindow window)
-    (time time)
-    (x int)
-    (y int)
-    (x-root int)
-    (y-root int)
-    (state unsigned-int)
-    (button unsigned-int)
-    (same-screen bool)))
-
-(def-alien-type x-motion-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (root window)
-    (subwindow window)
-    (time time)
-    (x int)
-    (y int)
-    (x-root int)
-    (y-root int)
-    (state unsigned-int)
-    (is-hint char)
-    (same-screen bool)))
-
-(def-alien-type x-crossing-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (root window)
-    (subwindow window)
-    (time time)
-    (x int)
-    (y int)
-    (x-root int)
-    (y-root int)
-    (mode int)
-    (detail int)
-    (same-screen bool)
-    (focus bool)
-    (state unsigned-int)))
-
-(def-alien-type x-focus-change-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (mode int)
-    (detail int)))
-
-(def-alien-type x-keymap-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (key-vector (array char 32))))
-
-(def-alien-type x-expose-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (x int)
-    (y int)
-    (width int)
-    (height int)
-    (count int)))
-
-(def-alien-type x-graphics-expose-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (drawable drawable)
-    (x int)
-    (y int)
-    (width int)
-    (height int)
-    (count int)
-    (major-code int)
-    (minor-code int)))
-
-(def-alien-type x-no-expose-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (drawable drawable)
-    (major-code int)
-    (minor-code int)))
-
-(def-alien-type x-visibility-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (state int)))
-
-(def-alien-type x-create-window-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (parent window)
-    (window window)
-    (x int)
-    (y int)
-    (width int)
-    (height int)
-    (override-redirect bool)))
-
-(def-alien-type x-destroy-window-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (event window)
-    (window window)))
-
-(def-alien-type x-unmap-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (event window)
-    (window window)
-    (from-configure bool)))
-
-(def-alien-type x-map-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (event window)
-    (window window)
-    (override-redirect bool)))
-
-(def-alien-type x-map-request-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (parent window)
-    (window window)))
-
-(def-alien-type x-reparent-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (event window)
-    (parent window)
-    (x int)
-    (y int)
-    (override-redirect bool)))
-
-(def-alien-type x-configure-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (event window)
-    (window window)
-    (x int)
-    (y int)
-    (width int)
-    (height int)
-    (border-width int)
-    (above window)
-    (override-redirect bool)))
-
-(def-alien-type x-gravity-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (event window)
-    (window window)
-    (x int)
-    (y int)))
-
-(def-alien-type x-resize-request-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (width int)
-    (height int)))
-
-(def-alien-type x-configure-request-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (parent window)
-    (window window)
-    (x int)
-    (y int)
-    (width int)
-    (height int)
-    (border-width int)
-    (above window)
-    (detail int)
-    (value-mask unsigned-long)))
-
-(def-alien-type x-circulate-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (event window)
-    (window window)
-    (place int)))
-
-(def-alien-type x-circulate-request-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (parent window)
-    (window window)
-    (place int)))
-
-(def-alien-type x-property-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (atom atom)
-    (time time)
-    (state int)))
-
-(def-alien-type x-selection-clear-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (selection atom)
-    (time time)))
-
-(def-alien-type x-selection-request-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (owner window)
-    (requestor window)
-    (selection atom)
-    (target atom)
-    (property atom)
-    (time time)))
-
-(def-alien-type x-selection-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (requestor window)
-    (selection atom)
-    (target atom)
-    (property atom)
-    (time time)))
-
-(def-alien-type x-colormap-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (colormap colormap)
-    (new bool)
-    (state int)))
-
-(def-alien-type x-client-message-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (message-type atom)
-    (format int)
-    (data (union nil
-		 (b (array char 20))
-		 (s (array short 10))
-		 (l (array long 5))))))
-
-(def-alien-type x-mapping-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)
-    (request int)
-    (first-keycode int)
-    (count int)))
-
-(def-alien-type x-any-event
-  (struct nil
-    (handle unsigned-long)
-    (type int)
-    (serial unsigned-long)
-    (send-event bool)
-    (window window)))
-
-(def-alien-type xevent
-  (union nil
-    (xany x-any-event)
-    (xkey x-key-event)
-    (xbutton x-button-event)
-    (xmotion x-motion-event)
-    (xcrossing x-crossing-event)
-    (xfocus x-focus-change-event)
-    (xexpose x-expose-event)
-    (xgraphicsexpose x-graphics-expose-event)
-    (xnoexpose x-no-expose-event)
-    (xvisibility x-visibility-event)
-    (xcreatewindow x-create-window-event)
-    (xdestroywindow x-destroy-window-event)
-    (xunmap x-unmap-event)
-    (xmap x-map-event)
-    (xmaprequest x-map-request-event)
-    (xreparent x-reparent-event)
-    (xconfigure x-configure-event)
-    (xgravity x-gravity-event)
-    (xresizerequest x-resize-request-event)
-    (xconfigurerequest x-configure-request-event)
-    (xcirculate x-circulate-event)
-    (xcirculaterequest x-circulate-request-event)
-    (xproperty x-property-event)
-    (xselectionclear x-selection-clear-event)
-    (xselectionrequest x-selection-request-event)
-    (xselection x-selection-event)
-    (xcolormap x-colormap-event)
-    (xclient x-client-message-event)
-    (xmapping x-mapping-event)
-    (xkeymap x-keymap-event)))
-
-(deftype toolkit-event () '(alien xevent))
-
-
-
-;;;; Functions for accessing the common fields of all XEvents
-
-(eval-when (compile eval)
-  (defmacro def-event-access (name union-slot slot)
-    `(defun ,name (event)
-       (declare (type toolkit-event event))
-       (alien:slot (alien:slot event ,union-slot) ,slot)))
-  
-  (defmacro def-event-window-access (name union-slot slot)
-    `(defun ,name (event)
-       (declare (type toolkit-event event))
-       (xlib::lookup-window
-	*x-display*
-	(alien:slot (alien:slot event ,union-slot) ,slot))))
-  
-  (defmacro def-event-drawable-access (name union-slot slot)
-    `(defun ,name (event)
-       (declare (type toolkit-event event))
-       (xlib::lookup-drawable
-	*x-display*
-	(alien:slot (alien:slot event ,union-slot) ,slot))))
-  
-  (defmacro def-event-colormap-access (name union-slot slot)
-    `(defun ,name (event)
-       (declare (type toolkit-event event))
-       (xlib::lookup-colormap
-	*x-display*
-	(alien:slot (alien:slot event ,union-slot) ,slot))))
-  
-  (defmacro def-event-atom-access (name union-slot slot)
-    `(defun ,name (event)
-       (declare (type toolkit-event event))
-       (xlib::atom-name *x-display*
-			(alien:slot (alien:slot event ,union-slot) ,slot))))
-) ;; EVAL-WHEN
-
-(declaim (inline event-handle event-serial event-send-event event-window
-		 event-type))
-
-(def-event-access event-handle 'xany 'handle)
-(def-event-access event-serial 'xany 'serial)
-(def-event-access event-send-event 'xany 'send-event)
-(def-event-window-access event-window 'xany 'window)
-(defun event-type (event)
-  (declare (type toolkit-event event))
-  (svref xlib::*event-key-vector*
-	 (alien:slot (alien:slot event 'xany) 'type)))
-
-
-;;;; Functions for accessing the fields of XButton events
-
-(declaim (inline button-event-root button-event-subwindow button-event-time
-		 button-event-x button-event-y button-event-x-root
-		 button-event-y-root button-event-state
-		 button-event-same-screen button-event-button))
-
-(def-event-window-access button-event-root 'xbutton 'root)
-(def-event-window-access button-event-subwindow 'xbutton 'subwindow)
-(def-event-access button-event-time 'xbutton 'time)
-(def-event-access button-event-x 'xbutton 'x)
-(def-event-access button-event-y 'xbutton 'y)
-(def-event-access button-event-x-root 'xbutton 'x-root)
-(def-event-access button-event-y-root 'xbutton 'y-root)
-(def-event-access button-event-state 'xbutton 'state)
-(def-event-access button-event-button 'xbutton 'button)
-(def-event-access button-event-same-screen 'xbutton 'same-screen)
-
-
-
-;;;; Functions for accessing the fields of XKey events
-
-(declaim (inline key-event-root key-event-subwindow key-event-time
-		 key-event-x key-event-y key-event-x-root key-event-y-root
-		 key-event-state key-event-keycode key-event-same-screen))
-
-(def-event-window-access key-event-root 'xkey 'root)
-(def-event-window-access key-event-subwindow 'xkey 'subwindow)
-(def-event-access key-event-time 'xkey 'time)
-(def-event-access key-event-x 'xkey 'x)
-(def-event-access key-event-y 'xkey 'y)
-(def-event-access key-event-x-root 'xkey 'x-root)
-(def-event-access key-event-y-root 'xkey 'y-root)
-(def-event-access key-event-state 'xkey 'state)
-(def-event-access key-event-keycode 'xkey 'keycode)
-(def-event-access key-event-same-screen 'xkey 'same-screen)
-
-
-
-;;;; Functions for accessing XMotion event slots
-
-(declaim (inline motion-event-root motion-event-subwindow motion-event-time
-		 motion-event-x motion-event-y motion-event-x-root
-		 motion-event-y-root motion-event-state motion-event-is-hint
-		 motion-event-same-screen))
-
-(def-event-window-access motion-event-root 'xmotion 'root)
-(def-event-window-access motion-event-subwindow 'xmotion 'subwindow)
-(def-event-access motion-event-time 'xmotion 'time)
-(def-event-access motion-event-x 'xmotion 'x)
-(def-event-access motion-event-y 'xmotion 'y)
-(def-event-access motion-event-x-root 'xmotion 'x-root)
-(def-event-access motion-event-y-root 'xmotion 'y-root)
-(def-event-access motion-event-state 'xmotion 'state)
-(def-event-access motion-event-is-hint 'xmotion 'is-hint)
-(def-event-access motion-event-same-screen 'xmotion 'same-screen)
-
-
-
-;;;; Functions for accessing XCrossingEvent slots
-
-(declaim (inline crossing-event-root crossing-event-subwindow
-		 crossing-event-time crossing-event-x crossing-event-y
-		 crossing-event-x-root crossing-event-y-root
-		 crossing-event-mode crossing-event-detail
-		 crossing-event-same-screen crossing-event-focus
-		 crossing-event-state))
-
-(def-event-window-access crossing-event-root 'xcrossing 'root)
-(def-event-window-access crossing-event-subwindow 'xcrossing 'subwindow)
-(def-event-access crossing-event-time 'xcrossing 'time)
-(def-event-access crossing-event-x 'xcrossing 'x)
-(def-event-access crossing-event-y 'xcrossing 'y)
-(def-event-access crossing-event-x-root 'xcrossing 'x-root)
-(def-event-access crossing-event-y-root 'xcrossing 'y-root)
-(def-event-access crossing-event-mode 'xcrossing 'mode)
-(def-event-access crossing-event-detail 'xcrossing 'detail)
-(def-event-access crossing-event-same-screen 'xcrossing 'same-screen)
-(def-event-access crossing-event-focus 'xcrossing 'focus)
-(def-event-access crossing-event-state 'xcrossing 'state)
-
-
-
-;;;; Functions for accessing XFocusChangeEvent slots
-
-(declaim (inline focus-change-event-mode focus-change-event-detail))
-
-(def-event-access focus-change-event-mode 'xfocus 'mode)
-(def-event-access focus-change-event-detail 'xfocus 'detail)
-
-
-
-;;;; Functions for accessing XKeymapEvent slots
-
-;; **** These need to be added
-
-
-
-;;;; Functions for accessing XExposeEvent slots
-
-(declaim (inline expose-event-x expose-event-y expose-event-width
-		 expose-event-height expose-event-count))
-
-(def-event-access expose-event-x 'xexpose 'x)
-(def-event-access expose-event-y 'xexpose 'y)
-(def-event-access expose-event-width 'xexpose 'width)
-(def-event-access expose-event-height 'xexpose 'height)
-(def-event-access expose-event-count 'xexpose 'count)
-
-
-
-;;;; Functions for accessing XGraphicsExposeEvent structures
-
-(declaim (inline graphics-expose-event-drawable graphics-expose-event-x
-		 graphics-expose-event-y graphics-expose-event-width
-		 graphics-expose-event-height graphics-expose-event-count
-		 graphics-expose-event-major-code
-		 graphics-expose-event-minor-code))
-
-(def-event-drawable-access graphics-expose-event-drawable
-			   'xgraphicsexpose 'drawable)
-(def-event-access graphics-expose-event-x 'xgraphicsexpose 'x)
-(def-event-access graphics-expose-event-y 'xgraphicsexpose 'y)
-(def-event-access graphics-expose-event-width 'xgraphicsexpose 'width)
-(def-event-access graphics-expose-event-height 'xgraphicsexpose 'height)
-(def-event-access graphics-expose-event-count 'xgraphicsexpose 'count)
-(def-event-access graphics-expose-event-major-code
-		  'xgraphicsexpose 'major-code)
-(def-event-access graphics-expose-event-minor-code
-		  'xgraphicsexpose 'minor-code)
-
-
-
-;;;; Functions for accessing XNoExposeEvent slots
-
-(declaim (inline no-expose-event-drawable no-expose-event-major-code
-		 no-expose-event-minor-code))
-
-(def-event-drawable-access no-expose-event-drawable 'xnoexpose 'drawable)
-(def-event-access no-expose-event-major-code 'xnoexpose 'major-code)
-(def-event-access no-expose-event-minor-code 'xnoexpose 'minor-code)
-
-
-
-;;;; Functions for accesssing XVisibilityEvent slots
-
-(declaim (inline visibility-event-state))
-
-(def-event-access visibility-event-state 'xvisibility 'state)
-
-
-
-;;;; Function for accessing XCreateWindowEvent data
-
-(declaim (inline create-window-event-parent create-window-event-window
-		 create-window-event-x create-window-event-y
-		 create-window-event-width create-window-event-height
-		 create-window-event-override-redirect))
-
-(def-event-window-access create-window-event-parent 'xcreatewindow 'parent)
-(def-event-window-access create-window-event-window 'xcreatewindow 'window)
-(def-event-access create-window-event-x 'xcreatewindow 'x)
-(def-event-access create-window-event-y 'xcreatewindow 'y)
-(def-event-access create-window-event-width 'xcreatewindow 'width)
-(def-event-access create-window-event-height 'xcreatewindow 'height)
-(def-event-access create-window-event-override-redirect
-		  'xcreatewindow 'override-redirect)
-
-
-
-;;;; Functions for accessing XDestroyWindowEvent slots
-
-(declaim (inline destroy-window-event-event destroy-window-event-window))
-
-(def-event-window-access destroy-window-event-event 'xdestroywindow 'event)
-(def-event-window-access destroy-window-event-window 'xdestroywindow 'window)
-
-
-
-;;;; Functions for accessing XUnmapEvent structures
-
-(declaim (inline unmap-event-event unmap-event-window
-		 unmap-event-from-configure))
-
-(def-event-window-access unmap-event-event 'xunmap 'event)
-(def-event-window-access unmap-event-window 'xunmap 'window)
-(def-event-access unmap-event-from-configure 'xunmap 'from-configure)
-
-
-
-;;;; Functions for accessing XMapRequestEvent slots
-
-(declaim (inline map-request-event-parent map-request-event-window))
-
-(def-event-window-access map-request-event-parent 'xmaprequest 'parent)
-(def-event-window-access map-request-event-window 'xmaprequest 'window)
-
-
-
-;;;; Functions to access XReparentEvent structures
-
-(declaim (inline reparent-event-event reparent-event-parent
-		 reparent-event-x reparent-event-y
-		 reparent-event-override-redirect))
-
-(def-event-window-access reparent-event-event 'xreparent 'event)
-(def-event-window-access reparent-event-parent 'xreparent 'parent)
-(def-event-access reparent-event-x 'xreparent 'x)
-(def-event-access reparent-event-y 'xreparent 'y)
-(def-event-access reparent-event-override-redirect
-		  'xreparent 'override-redirect)
-
-
-
-;;;; Functions to access XConfigureEvent slots
-
-(declaim (inline configure-event-event configure-event-window
-		 configure-event-x configure-event-y configure-event-width
-		 configure-event-height configure-event-border-width
-		 configure-event-above configure-event-override-redirect))
-
-(def-event-window-access configure-event-event 'xconfigure 'event)
-(def-event-window-access configure-event-window 'xconfigure 'window)
-(def-event-access configure-event-x 'xconfigure 'x)
-(def-event-access configure-event-y 'xconfigure 'y)
-(def-event-access configure-event-width 'xconfigure 'width)
-(def-event-access configure-event-height 'xconfigure 'height)
-(def-event-access configure-event-border-width 'xconfigure 'border-width)
-(def-event-window-access configure-event-above 'xconfigure 'above)
-(def-event-access configure-event-override-redirect
-		  'xconfigure 'override-redirect)
-
-
-
-;;;; Functions for accessing XGravityEvent slots
-
-(declaim (inline gravity-event-event gravity-event-window gravity-event-x
-		 gravity-event-y))
-
-(def-event-window-access gravity-event-event 'xgravity 'event)
-(def-event-window-access gravity-event-window 'xgravity 'window)
-(def-event-access gravity-event-x 'xgravity 'x)
-(def-event-access gravity-event-y 'xgravity 'y)
-
-
-
-;;;; Functions for accessing XResizeRequestEvent structures
-
-(declaim (inline resize-request-event-width resize-request-event-height))
-
-(def-event-access resize-request-event-width 'xresizerequest 'width)
-(def-event-access resize-request-event-height 'xresizerequest 'height)
-
-
-
-;;;; Functions for accessing XConfigureRequestEvent structures
-
-(declaim (inline configure-request-event-parent
-		 configure-request-event-window configure-request-event-x
-		 configure-request-event-y configure-request-event-width
-		 configure-request-event-height
-		 configure-request-event-border-width
-		 configure-request-event-above configure-request-event-detail
-		 configure-request-event-value-mask))
-
-(def-event-window-access configure-request-event-parent
-			 'xconfigurerequest 'parent)
-(def-event-window-access configure-request-event-window
-			 'xconfigurerequest 'window)
-(def-event-access configure-request-event-x 'xconfigurerequest 'x)
-(def-event-access configure-request-event-y 'xconfigurerequest 'y)
-(def-event-access configure-request-event-width 'xconfigurerequest 'width)
-(def-event-access configure-request-event-height 'xconfigurerequest 'height)
-(def-event-access configure-request-event-border-width
-		  'xconfigurerequest 'border-width)
-(def-event-window-access configure-request-event-above
-			 'xconfigurerequest 'above)
-(def-event-access configure-request-event-detail 'xconfigurerequest 'detail)
-(def-event-access configure-request-value-mask 'xconfigurerequest 'value-mask)
-
-
-
-;;;; Functions for accessing XCirculateEvent structures
-
-(declaim (inline circulate-event-event circulate-event-window
-		 circulate-event-place))
-
-(def-event-window-access circulate-event-event 'xcirculate 'event)
-(def-event-window-access circulate-event-window 'xcirculate 'window)
-(def-event-access circulate-event-place 'xcirculate 'place)
-
-
-
-;;;; Functions for accessing XCirculateRequestEvent slots
-
-(declaim (inline circulate-request-event-parent
-		 circulate-request-event-window circulate-request-event-place))
-
-(def-event-window-access circulate-request-event-parent
-			 'xcirculaterequest 'parent)
-(def-event-window-access circulate-request-event-window
-			 'xcirculaterequest 'window)
-(def-event-access circulate-request-event-place 'xcirculaterequest 'place)
-
-
-
-;;;; Functions for accessing XPropertyEvent slots
-
-(declaim (inline property-event-atom property-event-time property-event-state))
-
-(def-event-atom-access property-event-atom 'xproperty 'atom)
-(def-event-access property-event-time 'xproperty 'time)
-(def-event-access property-event-state 'xproperty 'state)
-
-
-
-;;;; Functions for accessing XSelectionClearEvent slots
-
-(declaim (inline selection-clear-event-selection selection-clear-event-time))
-
-(def-event-atom-access selection-clear-event-selection
-		       'xselectionclear 'selection)
-(def-event-access selection-clear-event-time 'xselectionclear 'time)
-
-
-
-;;;; Functions for accessing XSelectionRequestEvent slots
-
-(declaim (inline selection-request-event-owner
-		 selection-request-event-requestor
-		 selection-request-event-selection
-		 selection-request-event-target
-		 selection-request-event-property selection-request-event-time))
-
-(def-event-window-access selection-request-event-owner
-			 'xselectionrequest 'owner)
-(def-event-window-access selection-request-event-requestor
-			 'xselectionrequest 'requestor)
-(def-event-atom-access selection-request-event-selection
-		       'xselectionrequest 'selection)
-(def-event-atom-access selection-request-event-target
-		       'xselectionrequest 'target)
-(def-event-atom-access selection-request-event-property
-		       'xselectionrequest 'property)
-(def-event-access selection-request-event-time 'xselectionrequest 'time)
-
-
-
-;;;; Functions for accessing XSelectionEvent structures
-
-(declaim (inline selection-event-requestor selection-event-selection
-		 selection-event-target selection-event-property
-		 selection-event-time))
-
-(def-event-window-access selection-event-requestor 'xselection 'requestor)
-(def-event-atom-access selection-event-selection 'xselection 'selection)
-(def-event-atom-access selection-event-target 'xselection 'target)
-(def-event-atom-access selection-event-property 'xselection 'property)
-(def-event-access selection-event-time 'xselection 'time)
-
-
-
-;;;; Functions for accessing XColormapEvent structures
-
-(declaim (inline colormap-event-colormap colormap-event-new
-		 colormap-event-state))
-
-(def-event-colormap-access colormap-event-colormap 'xcolormap 'colormap)
-(def-event-access colormap-event-new 'xcolormap 'new)
-(def-event-access colormap-event-state 'xcolormap 'state)
-
-
-
-;;;; Functions for accessing XClientMessageEvent structures
-
-(declaim (inline client-message-event-message-type client-message-event-format))
-
-(def-event-atom-access client-message-event-message-type
-		       'xclient 'message-type)
-(def-event-access client-message-event-format 'xclient 'format)
-;; ***** Need to access client-msg data
-
-
-
-;;;; Functions for accessing XMappingEvent slots
-
-(declaim (inline mapping-event-request mapping-event-first-keycode
-		 mapping-event-count))
-
-(def-event-access mapping-event-request 'xmapping 'request)
-(def-event-access mapping-event-first-keycode 'xmapping 'first-keycode)
-(def-event-access mapping-event-count 'xmapping 'count)
diff --git a/motif/lisp/initial.lisp b/motif/lisp/initial.lisp
deleted file mode 100644
index 6ee8bbe59577d0a7b960df4b8528edd11fa02895..0000000000000000000000000000000000000000
--- a/motif/lisp/initial.lisp
+++ /dev/null
@@ -1,226 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: User -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; This file is the initial startup code for the Motif Toolkit
-;;;
-
-(in-package  "USER")
-
-
-
-;;;; Set up Lisp for the loading of the Motif toolkit
-
-(defpackage "TOOLKIT-INTERNALS"
-  (:nicknames "XTI")
-  (:use "COMMON-LISP" "EXTENSIONS" "ALIEN" "C-CALL")
-  (:export "*MOTIF-CONNECTION*" "*X-DISPLAY*" "MOTIF-CONNECTION"
-	   "MAKE-MOTIF-CONNECTION" "MOTIF-CONNECTION-FD"
-	   "MOTIF-CONNECTION-DISPLAY-NAME" "MOTIF-CONNECTION-DISPLAY"
-	   "MOTIF-CONNECTION-SERIAL" "MOTIF-CONNECTION-WIDGET-TABLE"
-	   "MOTIF-CONNECTION-FUNCTION-TABLE"
-	   "MOTIF-CONNECTION-CALLBACK-TABLE" "MOTIF-CONNECTION-CLOSE-HOOK"
-	   "MOTIF-CONNECTION-PROTOCOL-TABLE" "MOTIF-CONNECTION-TERMINATED"
-	   "MOTIF-CONNECTION-EVENT-TABLE" "TOOLKIT-ERROR"
-	   "TOOLKIT-CERROR" "TOOLKIT-EOF-ERROR" "CONNECT-TO-HOST"
-	   "WAIT-FOR-INPUT" "WAIT-FOR-INPUT-OR-TIMEOUT" "WIDGET"
-	   "MAKE-WIDGET" "WIDGET-ID" "WIDGET-TYPE" "WIDGET-PARENT"
-	   "WIDGET-CHILDREN" "WIDGET-CALLBACKS" "WIDGET-PROTOCOLS"
-	   "WIDGET-EVENTS" "WIDGET-USER-DATA" "MOTIF-OBJECT" "FONT-LIST"
-	   "XMSTRING" "TRANSLATIONS" "ACCELERATORS" "SYMBOL-RESOURCE"
-	   "SYMBOL-CLASS" "SYMBOL-ATOM" "WIDGET-ADD-CHILD" "CREATE-MESSAGE"
-	   "DESTROY-MESSAGE" "TRANSMIT-MESSAGE" "RECEIVE-MESSAGE"
-	   "CREATE-NEXT-MESSAGE" "PREPARE-REQUEST" "*TYPE-TABLE*"
-	   "*ENUM-TABLE*" "TOOLKIT-READ-VALUE" "TOOLKIT-WRITE-VALUE"
-	   "TOOLKIT-EVENT" "EVENT-HANDLE" "EVENT-SERIAL" "EVENT-SEND-EVENT"
-	   "EVENT-WINDOW" "EVENT-TYPE" "BUTTON-EVENT-ROOT"
-	   "BUTTON-EVENT-SUBWINDOW" "BUTTON-EVENT-TIME" "BUTTON-EVENT-X"
-	   "BUTTON-EVENT-Y" "BUTTON-EVENT-X-ROOT" "BUTTON-EVENT-Y-ROOT"
-	   "BUTTON-EVENT-STATE" "BUTTON-EVENT-SAME-SCREEN"
-	   "BUTTON-EVENT-BUTTON" "KEY-EVENT-ROOT" "KEY-EVENT-SUBWINDOW"
-	   "KEY-EVENT-TIME" "KEY-EVENT-X" "KEY-EVENT-Y" "KEY-EVENT-X-ROOT"
-	   "KEY-EVENT-Y-ROOT" "KEY-EVENT-STATE" "KEY-EVENT-KEYCODE"
-	   "KEY-EVENT-SAME-SCREEN" "MOTION-EVENT-ROOT"
-	   "MOTION-EVENT-SUBWINDOW" "MOTION-EVENT-TIME" "MOTION-EVENT-X"
-	   "MOTION-EVENT-Y" "MOTION-EVENT-X-ROOT" "MOTION-EVENT-Y-ROOT"
-	   "MOTION-EVENT-STATE" "MOTION-EVENT-IS-HINT"
-	   "MOTION-EVENT-SAME-SCREEN" "CROSSING-EVENT-ROOT"
-	   "CROSSING-EVENT-SUBWINDOW" "CROSSING-EVENT-TIME"
-	   "CROSSING-EVENT-X" "CROSSING-EVENT-Y" "CROSSING-EVENT-X-ROOT"
-	   "CROSSING-EVENT-Y-ROOT" "CROSSING-EVENT-MODE"
-	   "CROSSING-EVENT-DETAIL" "CROSSING-EVENT-FOCUS"
-	   "CROSSING-EVENT-SAME-SCREEN" "CROSSING-EVENT-STATE"
-	   "FOCUS-CHANGE-EVENT-MODE" "FOCUS-CHANGE-EVENT-DETAIL"
-	   "EXPOSE-EVENT-X" "EXPOSE-EVENT-Y" "EXPOSE-EVENT-WIDTH"
-	   "EXPOSE-EVENT-HEIGHT" "EXPOSE-EVENT-COUNT"
-	   "GRAPHICS-EXPOSE-EVENT-X" "GRAPHICS-EXPOSE-EVENT-DRAWABLE"
-	   "GRAPHICS-EXPOSE-EVENT-Y" "GRAPHICS-EXPOSE-EVENT-WIDTH"
-	   "GRAPHICS-EXPOSE-EVENT-HEIGHT" "GRAPHICS-EXPOSE-EVENT-COUNT"
-	   "GRAPHICS-EXPOSE-EVENT-MAJOR-CODE"
-	   "GRAPHICS-EXPOSE-EVENT-MINOR-CODE" "NO-EXPOSE-EVENT-MINOR-CODE"
-	   "NO-EXPOSE-EVENT-DRAWABLE" "NO-EXPOSE-EVENT-MAJOR-CODE"
-	   "VISIBILITY-EVENT-STATE" "CREATE-WINDOW-EVENT-PARENT"
-	   "CREATE-WINDOW-EVENT-WINDOW" "CREATE-WINDOW-EVENT-X"
-	   "CREATE-WINDOW-EVENT-Y" "CREATE-WINDOW-EVENT-WIDTH"
-	   "CREATE-WINDOW-EVENT-HEIGHT"
-	   "CREATE-WINDOW-EVENT-OVERRIDE-REDIRECT"
-	   "DESTROY-WINDOW-EVENT-EVENT" "DESTROY-WINDOW-EVENT-WINDOW"
-	   "UNMAP-EVENT-EVENT" "UNMAP-EVENT-WINDOW"
-	   "UNMAP-EVENT-FROM-CONFIGURE" "MAP-REQUEST-EVENT-PARENT"
-	   "MAP-REQUEST-EVENT-WINDOW" "REPARENT-EVENT-EVENT"
-	   "REPARENT-EVENT-PARENT" "REPARENT-EVENT-X" "REPARENT-EVENT-Y"
-	   "REPARENT-EVENT-OVERRIDE-REDIRECT" "CONFIGURE-EVENT-EVENT"
-	   "CONFIGURE-EVENT-WINDOW" "CONFIGURE-EVENT-X" "CONFIGURE-EVENT-Y"
-	   "CONFIGURE-EVENT-WIDTH" "CONFIGURE-EVENT-HEIGHT"
-	   "CONFIGURE-EVENT-BORDER-WIDTH" "CONFIGURE-EVENT-ABOVE"
-	   "CONFIGURE-EVENT-OVERRIDE-REDIRECT" "GRAVITY-EVENT-EVENT"
-	   "GRAVITY-EVENT-WINDOW" "GRAVITY-EVENT-X" "GRAVITY-EVENT-Y"
-	   "RESIZE-REQUEST-EVENT-WIDTH" "RESIZE-REQUEST-EVENT-HEIGHT"
-	   "CONFIGURE-REQUEST-EVENT-PARENT"
-	   "CONFIGURE-REQUEST-EVENT-WINDOW" "CONFIGURE-REQUEST-EVENT-X"
-	   "CONFIGURE-REQUEST-EVENT-Y" "CONFIGURE-REQUEST-EVENT-WIDTH"
-	   "CONFIGURE-REQUEST-EVENT-HEIGHT" "CONFIGURE-REQUEST-EVENT-ABOVE"
-	   "CONFIGURE-REQUEST-EVENT-BORDER-WIDTH"
-	   "CONFIGURE-REQUEST-EVENT-DETAIL"
-	   "CONFIGURE-REQUEST-EVENT-VALUE-MASK" "CIRCULATE-EVENT-EVENT"
-	   "CIRCULATE-EVENT-WINDOW" "CIRCULATE-EVENT-PLACE"
-	   "CIRCULATE-REQUEST-EVENT-EVENT" "CIRCULATE-REQUEST-EVENT-WINDOW"
-	   "CIRCULATE-REQUEST-EVENT-PLACE" "PROPERTY-EVENT-ATOM"
-	   "PROPERTY-EVENT-TIME" "PROPERTY-EVENT-STATE"
-	   "SELECTION-CLEAR-EVENT-SELECTION" "SELECTION-CLEAR-EVENT-TIME"
-	   "SELECTION-REQUEST-EVENT-OWNER"
-	   "SELECTION-REQUEST-EVENT-REQUESTOR"
-	   "SELECTION-REQUEST-EVENT-SELECTION"
-	   "SELECTION-REQUEST-EVENT-TARGET"
-	   "SELECTION-REQUEST-EVENT-PROPERTY"
-	   "SELECTION-REQUEST-EVENT-TIME" "SELECTION-EVENT-REQUESTOR"
-	   "SELECTION-EVENT-SELECTION" "SELECTION-EVENT-TARGET"
-	   "SELECTION-EVENT-PROPERTY" "SELECTION-EVENT-TIME"
-	   "COLORMAP-EVENT-COLORMAP" "COLORMAP-EVENT-NEW"
-	   "COLORMAP-EVENT-STATE" "MAPPING-EVENT-REQUEST"
-	   "MAPPING-EVENT-FIRST-KEYCODE" "MAPPING-EVENT-COUNT"))
-
-(defpackage "TOOLKIT"
-  (:nicknames "XT")
-  (:use "COMMON-LISP" "EXTENSIONS" "TOOLKIT-INTERNALS")
-  (:export "ADD-CALLBACK" "REMOVE-CALLBACK" "REMOVE-ALL-CALLBACKS"
-	   "ADD-PROTOCOL-CALLBACK" "REMOVE-PROTOCOL-CALLBACK"
-	   "ADD-WM-PROTOCOL-CALLBACK" "REMOVE-WM-PROTOCOL-CALLBACK"
-	   "WITH-CALLBACK-EVENT" "WITH-ACTION-EVENT" "ADD-EVENT-HANDLER"
-	   "REMOVE-EVENT-HANDLER" "ANY-CALLBACK" "ANY-CALLBACK-REASON"
-	   "ANY-CALLBACK-EVENT" "BUTTON-CALLBACK" "DRAWING-AREA-CALLBACK"
-	   "BUTTON-CALLBACK-CLICK-COUNT" "DRAWING-AREA-CALLBACK-WINDOW"
-	   "DRAWN-BUTTON-CALLBACK" "DRAWN-BUTTON-CALLBACK-WINDOW"
-	   "DRAWN-BUTTON-CALLBACK-CLICK-COUNT" "SCROLL-BAR-CALLBACK"
-	   "SCROLL-BAR-CALLBACK-VALUE" "SCROLL-BAR-CALLBACK-PIXEL"
-	   "TOGGLE-BUTTON-CALLBACK" "TOGGLE-BUTTON-CALLBACK-SET"
-	   "LIST-CALLBACK" "LIST-CALLBACK-ITEM"
-	   "LIST-CALLBACK-ITEM-POSITION" "LIST-CALLBACK-SELECTED-ITEMS"
-	   "LIST-CALLBACK-SELECTED-ITEM-POSITIONS"
-	   "LIST-CALLBACK-SELECTION-TYPE" "SELECTION-CALLBACK"
-	   "SELECTION-CALLBACK-VALUE" "FILE-SELECTION-CALLBACK"
-	   "FILE-SELECTION-CALLBACK-VALUE" "FILE-SELECTION-CALLBACK-MASK"
-	   "FILE-SELECTION-CALLBACK-DIR" "FILE-SELECTION-CALLBACK-PATTERN"
-	   "SCALE-CALLBACK" "SCALE-CALLBACK-VALUE" "TEXT-CALLBACK"
-	   "TEXT-CALLBACK-DOIT" "TEXT-CALLBACK-CURR-INSERT"
-	   "TEXT-CALLBACK-NEW-INSERT" "TEXT-CALLBACK-START-POS"
-	   "TEXT-CALLBACK-END-POS" "TEXT-CALLBACK-TEXT" "WITH-ACTION-EVENT"
-	   "TEXT-CALLBACK-FORMAT" "*DEBUG-MODE*" "*DEFAULT-SERVER-HOST*"
-	   "*CLM-BINARY-DIRECTORY*" "*CLM-BINARY-NAME*"
-	   "*DEFAULT-DISPLAY*" "QUIT-APPLICATION" "WITH-MOTIF-CONNECTION"
-	   "RUN-MOTIF-APPLICATION" "WITH-CLX-REQUESTS"
-	   "BUILD-SIMPLE-FONT-LIST" "BUILD-FONT-LIST" "*MOTIF-CONNECTION*"
-	   "*X-DISPLAY*" "WIDGET" "XMSTRING" "FONT-LIST" "SET-VALUES"
-	   "GET-VALUES" "CREATE-MANAGED-WIDGET" "CREATE-WIDGET"
-	   "CREATE-POPUP-SHELL" "CREATE-APPLICATION-SHELL" "DESTROY-WIDGET"
-	   "*CONVENIENCE-AUTO-MANAGE*" "MANAGE-CHILDREN"
-	   "UNMANAGE-CHILDREN" "WITH-RESOURCE-VALUES" "MENU-POSITION"
-	   "CREATE-ARROW-BUTTON" "CREATE-ARROW-BUTTON-GADGET"
-	   "CREATE-BULLETIN-BOARD" "CREATE-CASCADE-BUTTON"
-	   "CREATE-CASCADE-BUTTON-GADGET" "CREATE-COMMAND"
-	   "CREATE-DIALOG-SHELL" "CREATE-DRAWING-AREA"
-	   "CREATE-DRAWN-BUTTON" "CREATE-FILE-SELECTION-BOX" "CREATE-FORM"
-	   "CREATE-FRAME" "CREATE-LABEL" "CREATE-LABEL-GADGET"
-	   "CREATE-LIST" "CREATE-MAIN-WINDOW" "CREATE-MENU-SHELL"
-	   "CREATE-MESSAGE-BOX" "CREATE-PANED-WINDOW" "CREATE-PUSH-BUTTON"
-	   "CREATE-PUSH-BUTTON-GADGET" "CREATE-ROW-COLUMN" "CREATE-SCALE"
-	   "CREATE-SCROLL-BAR" "CREATE-SCROLLED-WINDOW"
-	   "CREATE-SELECTION-BOX" "CREATE-SEPARATOR"
-	   "CREATE-SEPARATOR-GADGET" "CREATE-TEXT" "CREATE-TOGGLE-BUTTON"
-	   "CREATE-TOGGLE-BUTTON-GADGET" "CREATE-MENU-BAR"
-	   "CREATE-OPTION-MENU" "CREATE-RADIO-BOX" "CREATE-WARNING-DIALOG"
-	   "CREATE-BULLETIN-BOARD-DIALOG" "CREATE-ERROR-DIALOG"
-	   "CREATE-FILE-SELECTION-DIALOG" "CREATE-FORM-DIALOG"
-	   "CREATE-INFORMATION-DIALOG" "CREATE-MESSAGE-DIALOG"
-	   "CREATE-POPUP-MENU" "CREATE-PROMPT-DIALOG"
-	   "CREATE-PULLDOWN-MENU" "CREATE-QUESTION-DIALOG"
-	   "CREATE-SCROLLED-LIST" "CREATE-SCROLLED-TEXT"
-	   "CREATE-SELECTION-DIALOG" "CREATE-WORKIG-DIALOG"
-	   "REALIZE-WIDGET" "UNREALIZE-WIDGET" "MAP-WIDGET" "UNMAP-WIDGET"
-	   "SET-SENSITIVE" "POPUP" "POPDOWN" "MANAGE-CHILD"
-	   "UNMANAGE-CHILD" "PARSE-TRANSLATION-TABLE"
-	   "AUGMENT-TRANSLATIONS" "OVERRIDE-TRANSLATIONS"
-	   "UNINSTALL-TRANSLATIONS" "PARSE-ACCELERATOR-TABLE"
-	   "INSTALL-ACCELERATORS" "INSTALL-ALL-ACCELERATORS" "IS-MANAGED"
-	   "POPUP-SPRING-LOADED" "IS-REALIZED" "WIDGET-WINDOW" "WIDGET-NAME"
-	   "IS-SENSITIVE" "COMMAND-APPEND-VALUE" "COMMAND-ERROR"
-	   "COMMAND-SET-VALUE" "SCALE-GET-VALUE" "SCALE-SET-VALUE"
-	   "TOGGLE-BUTTON-GET-STATE" "TOGGLE-BUTTON-SET-STATE"
-	   "LIST-ADD-ITEM" "LIST-ADD-ITEM-UNSELECTED" "LIST-DELETE-ITEM"
-	   "LIST-DELETE-POS" "LIST-DESELECT-ALL-ITEMS" "LIST-DESELECT-ITEM"
-	   "LIST-DESELECT-POS" "LIST-SELECT-ITEM" "LIST-SELECT-POS"
-	   "LIST-SET-BOTTOM-ITEM" "LIST-SET-BOTTOM-POS"
-	   "LIST-SET-HORIZ-POS" "LIST-SET-ITEM" "LIST-SET-POS"
-	   "ADD-TAB-GROUP" "REMOVE-TAB-GROUP" "PROCESS-TRAVERSAL"
-	   "FONT-LIST-ADD" "FONT-LIST-CREATE" "FONT-LIST-FREE"
-	   "COMPOUND-STRING-BASELINE" "COMPOUND-STRING-BYTE-COMPARE"
-	   "COMPOUND-STRING-COMPARE" "COMPOUND-STRING-CONCAT"
-	   "COMPOUND-STRING-COPY" "COMPOUND-STRING-CREATE"
-	   "COMPOUND-STRING-CREATE-LTOR" "COMPOUND-STRING-CREATE-SIMPLE"
-	   "COMPOUND-STRING-CREATE-EMPTY" "COMPOUND-STRING-CREATE-EXTENT"
-	   "COMPOUND-STRING-FREE" "COMPOUND-STRING-HAS-SUBSTRING"
-	   "COMPOUND-STRING-HEIGHT" "COMPOUND-STRING-LENGTH"
-	   "COMPOUND-LINE-COUNT" "COMPOUND-STRING-NCONCAT"
-	   "COMPOUND-STRING-NCOPY" "COMPOUND-STRING-SEPARATOR-CREATE"
-	   "COMPOUND-STRING-WIDTH" "TEXT-CLEAR-SELECTION" "TEXT-COPY"
-	   "TEXT-CUT" "TEXT-GET-BASELINE" "TEXT-GET-EDITABLE"
-	   "TEXT-GET-INSERTION-POINT" "TEXT-GET-LAST-POSITION"
-	   "TEXT-GET-MAX-LENGTH" "TEXT-GET-SELECTION"
-	   "TEXT-GET-SELECTION-POSITION" "TEXT-GET-STRING"
-	   "TEXT-GET-TOP-CHARACTER" "TEXT-INSERT" "TEXT-PASTE"
-	   "TEXT-POS-TO-XY" "TEXT-REMOVE" "TEXT-REPLACE" "TEXT-SCROLL"
-	   "TEXT-SET-ADD-MODE" "TEXT-SET-EDITABLE" "TEXT-SET-HIGHLIGHT"
-	   "TEXT-SET-INSERTION-POSITION" "TEXT-SET-MAX-LENGTH"
-	   "TEXT-SET-SELECTION" "TEXT-SET-STRING" "TEXT-SET-TOP-CHARACTER"
-	   "TEXT-SHOW-POSITION" "TEXT-XY-TO-POS" "MESSAGE-BOX-GET-CHILD"
-	   "SELECTION-BOX-GET-CHILD" "FILE-SELECTION-BOX-GET-CHILD"
-	   "COMMAND-GET-CHILD" "UPDATE-DISPLAY" "IS-MOTIF-WM-RUNNING"
-	   "LIST-ADD-ITEMS" "LIST-DELETE-ALL-ITEMS" "LIST-DELETE-ITEMS"
-	   "LIST-DELETE-ITEMS-POS" "LIST-ITEM-EXISTS" "LIST-ITEM-POS"
-	   "LIST-REPLACE-ITEMS" "LIST-REPLACE-ITEMS-POS"
-	   "LIST-SET-ADD-MODE" "TRANSLATE-COORDS" "SCROLL-BAR-GET-VALUES"
-	   "SCROLL-BAR-SET-VALUES" "COMPOUND-STRING-GET-LTOR"
-	   "TRACKING-LOCATE" "SCROLLED-WINDOW-SET-AREAS" "CREATE-FONT-CURSOR"
-	   "LIST-GET-SELECTED-POS" "QUIT-APPLICATION-CALLBACK"
-	   "DESTROY-CALLBACK" "MANAGE-CALLBACK" "UNMANAGE-CALLBACK"
-	   "POPUP-CALLBACK" "POPDOWN-CALLBACK" "SET-ITEMS" "GET-ITEMS"
-	   "WITH-CALLBACK-DEFERRED-ACTIONS"))
-
-
-
-;;;; Set up the tables used in defining interface components.
-
-(in-package "TOOLKIT")
-
-(defvar *request-table* (make-array 50 :element-type 'simple-string
-				    :adjustable t :fill-pointer 0))
-(defvar *class-table* (make-array 40 :element-type 'cons
-				  :adjustable t :fill-pointer 0))
-(defvar next-type-tag)
diff --git a/motif/lisp/interface-build.lisp b/motif/lisp/interface-build.lisp
deleted file mode 100644
index e1578e232d8754f7b28bb1969ebae7abb6aab337..0000000000000000000000000000000000000000
--- a/motif/lisp/interface-build.lisp
+++ /dev/null
@@ -1,89 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Toolkit -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; Interface Builder
-;;;
-;;; This defines functions to crunch through the information generated
-;;; about the various request operations and automatically generate the
-;;; interface files for the C server.
-
-(in-package "TOOLKIT")
-
-
-
-;;;; Files where interface information will be stored
-
-(defconstant *string-table-file* "target:motif/server/StringTable.h")
-(defconstant *class-file* "target:motif/server/ClassTable.h")
-(defconstant *interface-file* "target:motif/server/Interface.h")
-(defconstant *type-file* "target:motif/server/TypeTable.h")
-
-
-
-;;;; Functions for building the C interface files
-
-(defun build-class-file (out)
-  (declare (stream out))
-  (write-line "WidgetClass *class_table[] = {" out)
-  (dotimes (index (length *class-table*))
-    (let ((entry (aref *class-table* index)))
-      (format out "  (WidgetClass *)(&~a),~%" (cdr entry))))
-  (format out "  NULL~%};~%~%#define CLASS_TABLE_SIZE ~a~%"
-	  (length *class-table*)))
-
-(defun build-type-file (out)
-  (declare (stream out))
-  (write-line "type_entry type_table[] = {" out)
-  (dotimes (index next-type-tag)
-    (let* ((stuff (svref *type-table* index))
-	   (name (car stuff))
-	   (kind (cdr stuff)))
-      (if (and (eq kind name) (gethash kind *enum-table*))
-	  (setf kind (symbol-atom :enum))
-	  (setf kind (symbol-atom kind)))
-      (format out "  {\"~a\",message_write_~(~a~),message_read_~(~a~)},~%"
-	      (symbol-class name) kind kind)))
-  (format out "  {NULL,NULL,NULL}~%};~%~%#define TYPE_TABLE_SIZE ~a~%"
-	  next-type-tag))
-
-(defun build-interface-file (out)
-  (declare (stream out))
-  (write-line "request_f request_table[] = {" out)
-  (dotimes (index (length *request-table*))
-    (format out "  ~a,~%" (aref *request-table* index)))
-  (format out "  NULL~%};~%"))
-
-(defun build-toolkit-interface ()
-  (with-open-file (out *class-file*
-		       :direction :output :if-exists :supersede
-		       :if-does-not-exist :create)
-    (build-class-file out))
-  (with-open-file (out *type-file*
-		       :direction :output :if-exists :supersede
-		       :if-does-not-exist :create)
-    (build-type-file out))
-  (with-open-file (out *interface-file*
-		       :direction :output :if-exists :supersede
-		       :if-does-not-exist :create)
-    (build-interface-file out)))
-
-(defun build-string-table ()
-  (with-open-file (out *string-table-file*
-		       :direction :output :if-exists :supersede
-		       :if-does-not-exist :create)
-    (declare (stream out))
-    (let ((table xti::*toolkit-string-table*))
-      (declare (simple-vector table))
-      (write-line "String string_table[] = {" out)
-      (dotimes (index (length table))
-	(format out "  \"~a\",~%" (svref table index)))
-      (format out "  NULL~%};~%~%")
-      (format out "#define STRING_TABLE_SIZE ~a~%" (length table)))))
diff --git a/motif/lisp/interface-glue.lisp b/motif/lisp/interface-glue.lisp
deleted file mode 100644
index a2605f739a832f498d8dde50b4bdc1c87672fe29..0000000000000000000000000000000000000000
--- a/motif/lisp/interface-glue.lisp
+++ /dev/null
@@ -1,213 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Toolkit -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; Functions which provide the glue for the interface between the C server
-;;; and the Lisp client.
-
-(in-package "TOOLKIT")
-
-
-
-;;;; Functions for handling server requests
-
-(defvar reply-table
-  (vector :confirm :values :callback :event :error :warning :protocol :action))
-
-(defun wait-for-server-reply (fd)
-  (wait-for-input fd)
-  (loop
-    (let ((reply (dispatch-server-reply fd)))
-      (when reply (return reply)))))
-
-(defun dispatch-server-reply (fd)
-  (let* ((reply (receive-message fd))
-	 (kind (svref reply-table (xti::message-get-dblword reply))))
-    (case kind
-      ((:confirm :values) reply)
-      (:callback (handle-callback reply))
-      (:protocol (handle-protocol reply))
-      (:action   (handle-action reply))
-      (:event    (handle-event reply))
-      (:error
-       (let ((errmsg (toolkit-read-value reply)))
-	 (destroy-message reply)
-	 (toolkit-error "Toolkit Server -- ~a" errmsg)))
-      (:warning
-       (let ((errmsg (toolkit-read-value reply)))
-	 (destroy-message reply)
-	 (warn "Toolkit Server -- ~a" errmsg)
-	 ;; Point out that this was not really a reply
-	 nil))
-      (t 
-       (destroy-message reply)
-       (toolkit-error "Invalid reply type: ~d" kind)))))
-
-(defun send-request-to-server (message options)
-  (let ((fd (motif-connection-fd *motif-connection*)))
-    (unwind-protect
-	(transmit-message message fd)
-      (destroy-message message))
-    (when (eq options :confirm) (wait-for-server-reply fd))))
-
-
-
-;;;; Functions for handling server connections
-
-(defvar *default-server-host* nil
-  "Name of machine where the Motif server resides.  Using the value NIL
-   causes a local connection to be made.")
-
-(defvar *default-display* nil
-  "If non-nil, the display which will be opened.  Otherwise, the DISPLAY
-   environment variable is consulted.")
-
-(defvar *debug-mode* nil
-  "Controls whether the client is in debugging mode.")
-
-(defvar *active-handlers* nil
-  "An alist of (fd . handler) for active X toolkit connections.")
-
-(defvar *default-timeout-interval* 15
-  "Default time, in seconds, which the Lisp process will wait for input on
-   the toolkit connection before assuming a timeout has occured.")
-
-(defvar *clm-binary-directory* "library:"
-  "Directory in which the Motif server resides.")
-
-(defvar *clm-binary-name* "motifd"
-  "Name of the Motif server executable.")
-
-(defun add-toolkit-handler (conn)
-  (let ((fd (motif-connection-fd conn)))
-    (when (assoc fd *active-handlers*)
-      (break "There is already a handler for fd=~d " fd))
-    (push (cons fd
-		(system:add-fd-handler
-		 fd :input
-		 #'(lambda (this-fd)
-		     (declare (ignore this-fd))
-		     (toolkit-handler conn))))
-	  *active-handlers*)))
-
-(defun remove-toolkit-handler (fd)
-  (let ((handler (cdr (assoc fd *active-handlers*))))
-    (unless handler
-      (toolkit-error "Cannot remove handler (fd=~d) because there is none." fd))
-    (system:remove-fd-handler handler)
-    (setf *active-handlers* (remove fd *active-handlers*
-				    :key #'car :test #'=))))
-
-(defvar *local-motif-server* nil)
-
-(defun local-server-status-hook (process)
-  (let ((status (ext:process-status process)))
-    (when (or (eq status :exited)
-	      (eq status :signaled))
-      (setf *local-motif-server* nil))))
-
-(defun verify-local-server-exists ()
-  (when (or (not *local-motif-server*)
-	    (and *local-motif-server*
-		 (not (ext:process-alive-p *local-motif-server*))))
-    (let ((process (ext:run-program (merge-pathnames *clm-binary-name*
-						     *clm-binary-directory*)
-				    '()
-				    :wait nil
-				    :status-hook #'local-server-status-hook)))
-      (unless (and process (ext:process-alive-p process))
-	(toolkit-error "Could not start local Motif server process."))
-      ;;
-      ;; Wait until the server has started up
-      (loop
-	(when (probe-file (format nil "/tmp/.motif_socket-u~a"
-				  (unix:unix-getuid)))
-	  (return))
-	(sleep 1))
-      (setf *local-motif-server* process))))
-
-(defun open-motif-connection (host dpy-name app-name app-class &optional pid)
-  (declare (simple-string app-name app-class))
-  (unless (or host pid)
-    (verify-local-server-exists))
-  (let* ((socket (connect-to-host host pid))
-	 (tmp (system:allocate-system-memory 4))
-	 (conn (make-motif-connection socket))
-	 (display (or dpy-name (cdr (assoc :display *environment-list*))))
-	 (clx-dpy (open-clx-display display))
-	 (greeting (create-message 0)))
-
-    (unless display
-      (toolkit-error "No display name available."))
-
-    ;;
-    ;; Fairly gross means of sending the swap information to the server
-    (setf (system:sap-ref-16 tmp 0) 1)
-    (unwind-protect
-	(unix:unix-write socket tmp 0 2)
-      (system:deallocate-system-memory tmp 4))
-
-    (toolkit-write-value greeting display)
-    (toolkit-write-value greeting app-name)
-    (toolkit-write-value greeting app-class)
-    (transmit-message greeting socket)
-    (destroy-message greeting)
-
-    (setf (motif-connection-display-name conn) display)
-    (setf (motif-connection-display conn) clx-dpy)
-    (add-toolkit-handler conn)
-    conn))
-
-(defun close-motif-connection (connection)
-  (unless (motif-connection-terminated connection)
-    (let ((fd (motif-connection-fd connection))
-	  (hook (motif-connection-close-hook connection)))
-      (when hook
-	(funcall hook connection))
-      (setf (motif-connection-terminated connection) t)
-      (remove-toolkit-handler fd)
-      (close-socket fd)
-      (xlib:close-display (motif-connection-display connection)))))
-
-(defmacro with-motif-connection ((connection) &body forms)
-  `(let ((*motif-connection* ,connection)
-	 (*x-display* (motif-connection-display ,connection)))
-     (handler-case
-	 (restart-case
-	     (progn ,@forms)
-	   (continue ()
-	             :report "Ignore problem and continue."
-	     ())
-	   (kill-app ()
- 	             :report "Close current application."
-	     (quit-server)     
-	     (close-motif-connection ,connection)))
-       (toolkit-eof-error (cond)
-	 (format t "~%Connection to server broken: ~a" cond)
-         (close-motif-connection ,connection)
-	 (signal cond)))))
-
-(defmacro with-clx-requests (&body forms)
-  `(unwind-protect
-       (progn ,@forms)
-     (xlib:display-force-output *x-display*)))
-
-;;; This is the functions which listens for input from the server and calls
-;;; the dispatcher when it detects incoming data.
-(defun toolkit-handler (connection)
-  (unless (motif-connection-terminated connection)
-    (with-motif-connection (connection)
-      (let ((fd (motif-connection-fd connection)))
-	(cond
-	 ((wait-for-input-or-timeout fd *default-timeout-interval*)
-	  (dispatch-server-reply fd))
-	 (t
-	  (warn "Got timeout on fd=~d" fd)))
-	(xlib:display-force-output *x-display*)))))
diff --git a/motif/lisp/internals.lisp b/motif/lisp/internals.lisp
deleted file mode 100644
index fcdebae7df7706fc2107358c66f28acaa70f1e06..0000000000000000000000000000000000000000
--- a/motif/lisp/internals.lisp
+++ /dev/null
@@ -1,214 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Toolkit-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; This file contains internal functions required to support the Motif
-;;; toolkit in Lisp.
-;;;
-
-(in-package "TOOLKIT-INTERNALS")
-
-
-
-;;;; Special TOOLKIT-ERROR
-
-(define-condition toolkit-error (error)
-  ((format-string)
-   (format-arguments))
-  (:documentation "An error has occurred in the X Toolkit code.")
-  (:report (lambda (condition stream)
-	     (declare (stream stream))
-	     (format stream "A Toolkit error has occurred.~%~?"
-		     (toolkit-error-format-string condition)
-		     (toolkit-error-format-arguments condition)))))
-
-(define-condition toolkit-eof-error (toolkit-error)
-  ((string))
-  (:report (lambda (condition stream)
-	     (write-line (toolkit-eof-error-string condition) stream))))
-
-;;; TOOLKIT-ERROR  -- Internal
-;;; TOOLKIT-CERROR -- Internal
-;;;
-;;; These functions act just like ERROR and CERROR except that they signal
-;;; a TOOLKIT-ERROR instead of a SIMPLE-ERROR.  This is mainly intended for
-;;; a graphical debugger which must stop attempting graphical interaction
-;;; when a toolkit error occurs.
-;;;
-(declaim (inline toolkit-error toolkit-cerror))
-(defun toolkit-error (string &rest args)
-  (error 'toolkit-error :format-string string :format-arguments args))
-
-(defun toolkit-cerror (continue-string string &rest args)
-  (cerror continue-string 'toolkit-error
-	  :format-string string :format-arguments args))
-
-
-
-;;;; Internal communication functions
-
-(defvar *xt-tcp-port* 8000)
-
-(defun connect-to-host (host pid)
-  (declare (type (or null simple-string) host))
-  (handler-case
-      (if host
-	  (handler-case
-	      (ext:connect-to-inet-socket host *xt-tcp-port*)
-	    (error ()
-	      (ext:connect-to-inet-socket host (+ *xt-tcp-port*
-						  (unix:unix-getuid)))))
-	  (handler-case
-	      (ext::connect-to-unix-socket
-	       (if pid
-		   (format nil "/tmp/.motif_socket-p~a" pid)
-		   (format nil "/tmp/.motif_socket-u~a" (unix:unix-getuid))))
-	    (error ()
-	      (ext:connect-to-unix-socket "/tmp/.motif_socket"))))
-    (error ()
-      (toolkit-error "Unable to connect to Motif server."))))
-
-(declaim (inline wait-for-input wait-for-input-or-timeout))
-(defun wait-for-input (fd)
-  (system:wait-until-fd-usable fd :input))
-
-(defun wait-for-input-or-timeout (fd interval)
-  (system:wait-until-fd-usable fd :input interval))
-
-
-
-;;;; Toolkit connection stuff
-
-;;; These will be dynamically bound in the context of the event handlers.
-(defvar *motif-connection*)
-(defvar *x-display*)
-
-(defstruct (motif-connection
-	    (:print-function print-motif-connection)
-	    (:constructor make-motif-connection (fd)))
-  fd
-  (display-name "" :type simple-string)
-  display
-  (serial 1 :type fixnum)
-  (terminated nil :type (member t nil))
-  (close-hook nil :type (or symbol function))
-  ;;
-  ;; This maps widget ids (unsigned-byte 32)'s into widget structures
-  (widget-table (make-hash-table :test #'eq) :type hash-table)
-  (function-table (make-array 32 :element-type '(or symbol function)
-			      :adjustable t :fill-pointer 0))
-  (callback-table (make-hash-table :test #'equal) :type hash-table)
-  (protocol-table (make-hash-table :test #'equal) :type hash-table)
-  (event-table (make-hash-table :test #'equal) :type hash-table)
-  ;; This table tracks all the misc. id's we get from the server
-  ;; ie. xm-strings, translations, accelerators, font-lists
-  (id-table (make-hash-table :test #'eq) :type hash-table))
-
-(defun print-motif-connection (c stream d)
-  (declare (ignore d)
-	   (stream stream))
-  (format stream "#<X Toolkit Connection, fd=~a>"
-	  (motif-connection-fd c)))
-
-
-
-;;;; Internal structure definitions
-
-(defstruct (widget
-	    (:print-function print-widget)
-	    (:constructor make-widget (id)))
-  (id          0 :type (unsigned-byte 32))
-  (type      nil :type symbol)
-  (parent    nil :type widget)
-  (children  nil :type list)
-  (callbacks nil :type list)
-  (protocols nil :type list)
-  (events    nil :type list)
-  (user-data nil))
-
-;; A toolkit object is simply a wrapper for a pointer passed from the server
-;; process.  The TYPE field allows us to discriminate the type of the pointer
-;; but still treat all pointers in the same way (ie. instead of having separate
-;; tables for xmstring, font-list, etc.)
-;;
-(defstruct (motif-object
-	    (:print-function print-motif-object)
-	    (:constructor make-motif-object (id)))
-  (id 0 :type (unsigned-byte 32))
-  (type nil :type symbol))
-
-(defun print-widget (w stream d)
-  (declare (ignore d)
-	   (stream stream))
-  (format stream "#<X Toolkit Widget: ~A ~X>" (widget-type w) (widget-id w)))
-
-(defun print-motif-object (obj stream d)
-  (declare (ignore d)
-	   (stream stream))
-  (format stream "#<Motif object: ~A ~X>"
-	  (motif-object-type obj) (motif-object-id obj)))
-
-;;; Some handy type abbreviations for motif-object
-(deftype xmstring () 'motif-object)
-(deftype font-list () 'motif-object)
-(deftype translations () 'motif-object)
-(deftype accelerators () 'motif-object)
-
-
-
-;;;; Tables for tracking stuff
-
-(defvar *toolkit-string-table* (make-array 350 :element-type 'simple-string
-					   :adjustable t :fill-pointer 0))
-
-(defun find-widget (id)
-  (declare (type (unsigned-byte 32) id))
-  (let* ((widget-table (motif-connection-widget-table *motif-connection*))
-	 (widget (gethash id widget-table)))
-    (unless widget
-      (setf widget (make-widget id))
-      (setf (gethash id widget-table) widget))
-    widget))
-
-(defun find-motif-object (id type)
-  (declare (type (unsigned-byte 32) id)
-	   (symbol type))
-  (let* ((table (motif-connection-id-table *motif-connection*))
-	 (object (gethash id table)))
-    (unless object
-      (setf object (make-motif-object id))
-      (setf (gethash id table) object))
-    (setf (motif-object-type object) type)
-    object))
-
-
-
-;;;; Various helpful goodies
-
-;;; Converts a symbol into a resource class
-;;;    ex.  :label-string ===> LabelString
-(defun symbol-class (symbol)
-  (delete #\- (string-capitalize (symbol-name symbol))))
-
-;;; Converts a symbol into a resource base-name.
-;;;    ex.  :label-string ===> labelString
-(defun symbol-resource (symbol)
-  (let ((resource (symbol-class symbol)))
-    (setf (schar resource 0) (char-downcase (schar resource 0)))
-    resource))
-
-;;; Converts a symbol into an atom.
-(defun symbol-atom (symbol)
-  (substitute #\_ #\- (symbol-name symbol)))
-
-(defun widget-add-child (parent child)
-  (declare (type widget parent child))
-  (setf (widget-parent child) parent)
-  (push child (widget-children parent)))
diff --git a/motif/lisp/main.lisp b/motif/lisp/main.lisp
deleted file mode 100644
index a9e96dae039addcf5e578cd85d4cff15b234b258..0000000000000000000000000000000000000000
--- a/motif/lisp/main.lisp
+++ /dev/null
@@ -1,108 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Toolkit -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; Various high-level interface functions for use with the Motif toolkit.
-;;;
-
-(in-package "TOOLKIT")
-
-
-
-;;; These are just randomly placed here at the moment.
-(defconstant string-default-charset ""
-  "The default character set used in building Motif compound strings.")
-
-(defun font-list-add-component (flist charset font-spec)
-  (let ((font (xlib:open-font *x-display* font-spec)))
-    (xlib:display-force-output *x-display*)
-    (font-list-add flist font charset)))
-
-(defun build-simple-font-list (name font-spec)
-  (let ((font (xlib:open-font *x-display* font-spec)))
-    (xlib:display-force-output *x-display*)
-    (font-list-create font name)))
-
-
-(defun build-font-list (specs)
-  (let* ((first (car specs))
-	 (flist (build-simple-font-list (car first) (cadr first)))
-	 (specs (cdr specs)))
-    (dolist (spec specs)
-      (setf flist (font-list-add-component flist (car spec) (cadr spec))))
-    flist))
-
-
-
-;;;; Some standard useful callbacks
-
-(defun quit-application ()
-  "Standard function for quitting an X Toolkit application."
-  (quit-server)
-  (close-motif-connection *motif-connection*)
-  (throw 'lisp::top-level-catcher nil))
-
-(defun quit-application-callback (widget call-data)
-  "Standard callback for quitting an X Toolkit application."
-  (declare (ignore widget call-data))
-  (quit-application))
-
-(defun destroy-callback (widget call-data &rest targets)
-  (declare (ignore call-data))
-  (if targets
-      (dolist (target targets)
-	(destroy-widget target))
-      (destroy-widget widget)))
-
-(defun manage-callback (widget call-data &rest targets)
-  (declare (ignore call-data))
-  (if targets
-      (apply #'manage-children targets)
-      (manage-child widget)))
-
-(defun unmanage-callback (widget call-data &rest targets)
-  (declare (ignore call-data))
-  (if targets
-      (apply #'unmanage-children targets)
-      (unmanage-child widget)))
-
-(defun popup-callback (widget call-data kind &rest targets)
-  (declare (ignore call-data))
-  (if targets
-      (dolist (target targets)
-	(popup target kind))
-      (popup widget kind)))
-
-(defun popdown-callback (widget call-data &rest targets)
-  (declare (ignore call-data))
-  (if targets
-      (dolist (target targets)
-	(popdown target))
-      (popdown widget)))
-
-
-
-;;;; A convenient (and CLM compatible) way to start Motif applications
-
-(defun run-motif-application (init-function
-			      &key
-			      (init-args nil)
-			      (application-class "Lisp")
-			      (application-name "lisp")
-			      (server-host *default-server-host*)
-			      (display *default-display*)
-			      (sync-clx *debug-mode*))
-  (declare (ignore sync-clx))
-  (let ((connection (open-motif-connection server-host display
-					   application-name
-					   application-class)))
-    (with-motif-connection (connection)
-      (apply init-function init-args))
-    connection))
diff --git a/motif/lisp/prototypes.lisp b/motif/lisp/prototypes.lisp
deleted file mode 100644
index c6dfe8680abfbccac0d44ab28da0916808ba5606..0000000000000000000000000000000000000000
--- a/motif/lisp/prototypes.lisp
+++ /dev/null
@@ -1,800 +0,0 @@
-;;;; -*- Mode: Lisp, Fill ; Package: Toolkit -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; This file contains the prototyping code for RPC requests between the
-;;; Lisp client and the C server.
-;;;
-
-(in-package "TOOLKIT")
-
-(declaim (vector *request-table*))
-(eval-when (compile) (setf (fill-pointer *request-table*) 0))
-
-
-
-;;;; Macros for defining toolkit request operations
-
-(eval-when (compile eval)
-(defmacro def-toolkit-request (string-name symbol-name options
-			       doc-string args return &body forms)
-  (declare (simple-string string-name doc-string)
-	   (list args return))
-  (let ((arg-list (mapcar #'car args))
-	(type-list (mapcar #'cadr args))
-	(code (fill-pointer *request-table*)))
-    (vector-push-extend (format nil "R~a" string-name) *request-table*)
-    `(defun ,symbol-name ,arg-list
-       ,doc-string
-       ;; *** This generates lots of warnings at the moment
-       ;; (declare (inline toolkit-write-value))
-       ,(cons 'declare
-	      (mapcar #'(lambda (arg type) (list 'type type arg))
-		      arg-list type-list))
-       (let ((message (prepare-request ,code ,options ,(length args))))
-	 ,(cons 'progn
-		(mapcar #'(lambda (arg)
-			    (let ((name (first arg))
-				  (type (third arg)))
-			      (if type
-				  (list 'toolkit-write-value 'message name type)
-				  (list 'toolkit-write-value 'message name))))
-			args))
-	 (let ((reply (send-request-to-server message ,options)))
-	   ,(if (eq options :confirm)
-		`(multiple-value-prog1
-		     ,(ecase (length return)
-			(0)
-			(1 `(let ((result (toolkit-read-value reply)))
-			      ,@forms
-			      result))
-			(2 `(let* ((first (toolkit-read-value reply))
-				   (second (toolkit-read-value reply)))
-			      ,@forms
-			      (values first second)))
-			(3 `(let* ((first (toolkit-read-value reply))
-				   (second (toolkit-read-value reply))
-				   (third (toolkit-read-value reply)))
-			      ,@forms
-			      (values first second third)))
-			(4 `(let* ((first (toolkit-read-value reply))
-				   (second (toolkit-read-value reply))
-				   (third (toolkit-read-value reply))
-				   (fourth (toolkit-read-value reply)))
-			      ,@forms
-			      (values first second third fourth))))
-		   (destroy-message reply))
-		'(declare (ignore reply))))))))
-) ;; EVAL-WHEN
-
-;;; This is for sending commands to the server, not requesting Motif
-;;; services.  These calls take no arguments and return a value indicating
-;;; whether they were successful.
-(eval-when (compile eval)
-  (defmacro def-toolkit-command (symbol-name options &body forms)
-    (let ((string-name (symbol-class symbol-name))
-	  (code (fill-pointer *request-table*)))
-      (vector-push-extend string-name *request-table*)
-      `(defun ,symbol-name ()
-	 (let* ((message (prepare-request ,code ,options 0))
-		(reply (send-request-to-server message ,options)))
-	   ,(if (eq options :confirm)
-		`(let ((result (toolkit-read-value reply)))
-		   (destroy-message reply)
-		   ,@forms
-		   result)
-		'(declare (ignore reply))))))))
-
-
-
-;;;; Direct commands to server
-
-(def-toolkit-command quit-server :no-confirm)
-
-(def-toolkit-command terminate-callback :no-confirm)
-
-
-
-
-;;;; Request definitions for Xt Intrinsic functions
-
-(def-toolkit-request "TransportEvent" transport-event :confirm
-  ""
-  ((event-handle (unsigned-byte 32))) ((alien xevent)))
-
-(def-toolkit-request "XtAppCreateShell" %create-application-shell :confirm
-  ""
-  ((resources list :resource-list))
-  (widget)
-  (setf (widget-type result) :application-shell))
-
-(def-toolkit-request "XtRealizeWidget" realize-widget :no-confirm
-  "Realizes the given widget."
-  ((widget widget)) ())
-
-(def-toolkit-request "XtCreateManagedWidget" %create-managed-widget :confirm
-  ""
-  ((name simple-string) (widget-class keyword) (parent widget)
-   (resources list :resource-list))
-  (widget)
-  (setf (widget-type result) widget-class)
-  (widget-add-child parent result))
-
-(def-toolkit-request "XtCreateWidget" %create-widget :confirm
-  ""
-  ((name simple-string) (widget-class keyword) (parent widget)
-   (resources list :resource-list))
-  (widget)
-  (setf (widget-type result) widget-class)
-  (widget-add-child parent result))
-
-(def-toolkit-request "XtAddCallback" %add-callback :no-confirm
-  ""
-  ((widget widget) (name simple-string)) ())
-
-(def-toolkit-request "XtRemoveCallback"  %remove-callback :no-confirm
-  ""
-  ((widget widget) (name simple-string)) ())
-
-(def-toolkit-request "XtSetValues" %set-values :no-confirm
-  ""
-  ((widget widget) (resources list :resource-list)) ())
-
-(def-toolkit-request "XtGetValues" %get-values :confirm
-  ""
-  ((widget widget) (resource-names list :resource-names))
-  (list))
-
-(def-toolkit-request "XtUnrealizeWidget" unrealize-widget :no-confirm
-  "Unrealizes the given widget."
-  ((widget widget)) ())
-
-(def-toolkit-request "XtDestroyWidget" %destroy-widget :no-confirm
-  ""
-  ((widget widget)) ())
-
-(def-toolkit-request "XtMapWidget" map-widget :no-confirm
-  "Maps the X window associated with the given widget."
-  ((widget widget)) ())
-
-(def-toolkit-request "XtUnmapWidget" unmap-widget :no-confirm
-  "Unmaps the X window associated with the given widget."
-  ((widget widget)) ())
-
-(def-toolkit-request "XtSetSensitive" set-sensitive :no-confirm
-  "Sets the event sensitivity of the given widget."
-  ((widget widget) (sensitivep (member t nil))) ())
-
-(def-toolkit-request "XtCreatePopupShell" %create-popup-shell :confirm
-  ""
-  ((name simple-string) (class keyword)
-   (parent widget) (resources list :resource-list))
-  (widget)
-  (setf (widget-type result) class)
-  (widget-add-child parent result))
-
-(def-toolkit-request "XtPopup" popup :no-confirm
-  "Pops up a popup dialog shell."
-  ((shell widget) (grab-kind keyword)) ())
-
-(def-toolkit-request "XtPopdown" popdown :no-confirm
-  "Pops down a popup dialog shell."
-  ((shell widget)) ())
-
-(def-toolkit-request "XtManageChild" manage-child :no-confirm
-  "Manages the given child widget."
-  ((child widget)) ())
-
-(def-toolkit-request "XtUnmanageChild" unmanage-child :no-confirm
-  "Unmanages the given child widget."
-  ((child widget)) ())
-
-(def-toolkit-request "XtManageChildren" %manage-children :no-confirm
-  ""
-  ((child-list list :widget-list)) ())
-
-(def-toolkit-request "XtUnmanageChildren" %unmanage-children :no-confirm
-  ""
-  ((child-list list :widget-list)) ())
-
-(def-toolkit-request "XtParseTranslationTable" parse-translation-table :confirm
-  "Compiles a translation table string into its internal representation."
-  ((table simple-string)) (translations))
-
-(def-toolkit-request "XtAugmentTranslations" augment-translations :no-confirm
-  "Augments the translation table of the specified widget with the given
-   translations."
-  ((w widget) (table translations)) ())
-
-(def-toolkit-request "XtOverrideTranslations" override-translations :no-confirm
-  "Overrides the translation table of the specified widget with the given
-   translations."
-  ((w widget) (table translations)) ())
-
-(def-toolkit-request "XtUninstallTranslations" uninstall-translations
-		     :no-confirm
-  "Unintalls all translations on the given widget."
-  ((w widget)) ())
-
-(def-toolkit-request "XtParseAcceleratorTable" parse-accelerator-table :confirm
-  "Parses an accelerator string into its internal representation."
-  ((source simple-string)) (accelerators))
-
-(def-toolkit-request "XtInstallAccelerators" install-accelerators :no-confirm
-  "Installs accelerators from the source widget into the destination widget."
-  ((dest widget) (src widget)) ())
-
-(def-toolkit-request "XtInstallAllAccelerators" install-all-accelerators
-		     :no-confirm
-  "Installs all accelerators from the source widget into the destination
-   widget."
-  ((dest widget) (src widget)) ())
-
-(def-toolkit-request "XtIsManaged" is-managed :confirm
-  "Returns a value indicating whether the specified widget is managed or not."
-  ((widget widget)) ((member t nil)))
-
-(def-toolkit-request "XtPopupSpringLoaded" popup-spring-loaded :no-confirm
-  "Pops up a spring loaded popup dialog shell."
-  ((shell widget)) ())
-
-(def-toolkit-request "XtIsRealized" is-realized :confirm
-  "Returns a value indicating whether the specified widget is realized or not."
-  ((widget widget)) ((member t nil)))
-
-(def-toolkit-request "XtWindow" widget-window :confirm
-  "Returns the X window associated with the given widget."
-  ((widget widget)) (xlib:window))
-
-(def-toolkit-request "XtName" widget-name :confirm
-  "Returns the name of the given widget."
-  ((widget widget)) (string))
-
-(def-toolkit-request "XtIsSensitive" is-sensitive :confirm
-  "Returns the sensitivity state of the given widget."
-  ((widget widget)) ((member t nil)))
-
-(def-toolkit-request "XtAddEventHandler" %add-event-handler :no-confirm
-  ""
-  ((widget widget) (mask (unsigned-byte 32)) (nonmaskable_p (member t nil)))
-  ())
-
-(def-toolkit-request "XtRemoveEventHandler" %remove-event-handler :no-confirm
-  ""
-  ((widget widget) (mask (unsigned-byte 32)) (nonmaskable_p (member t nil)))
-  ())
-
-(def-toolkit-request "XtTranslateCoords" translate-coords :confirm
-  "Translates coordinates (x,y) in the window of the given widget into the
-   corresponding coordinates in the root window."
-  ((widget widget) (x fixnum) (y fixnum))
-  (fixnum fixnum))
-
-(def-toolkit-request "XCreateFontCursor" create-font-cursor :confirm
-  "Creates an X cursor from the standard cursor font."
-  ((shape fixnum))
-  (xlib:cursor))
-
-
-
-;;;; Request definitions for Motif functions
-
-;; We will ask for confirmation here just to resync things
-(def-toolkit-request "XmUpdateDisplay" update-display :confirm
-  "Processes all pending exposure events and synchronizes with the server."
-  ((w widget)) ())
-
-(def-toolkit-request "XmIsMotifWMRunning" is-motif-wm-running :confirm
-  "Specifies if the MWM window manager is running."
-  ((shell widget)) ((member t nil)))
-
-(def-toolkit-request "XmMenuPosition" %menu-position :no-confirm
-  ""
-  ((widget widget) (event-handle (unsigned-byte 32) :event)) ())
-
-(def-toolkit-request "XmCreateMenuBar" %create-menu-bar :confirm
-  ""
-  ((parent widget) (name simple-string) (resources list :resource-list))
-  (widget)
-  (setf (widget-type result) :row-column)
-  (widget-add-child parent result))
-
-(def-toolkit-request "XmCreateOptionMenu" %create-option-menu :confirm
-  ""
-  ((parent widget) (name simple-string) (resources list :resource-list))
-  (widget)
-  (setf (widget-type result) :row-column)
-  (widget-add-child parent result))
-
-(def-toolkit-request "XmCreateRadioBox" %create-radio-box :confirm
-  ""
-  ((parent widget) (name simple-string) (resources list :resource-list))
-  (widget)
-  (setf (widget-type result) :row-column)
-  (widget-add-child parent result))
-
-(macrolet ((def-double-widget-stub (name parent-class child-class)
-	     (let ((strname (format nil "Xm~a"(symbol-class name)))
-		   (fn-name (read-from-string
-			     (format nil "%~a" name))))
-	       `(def-toolkit-request ,strname ,fn-name :confirm
-		  ""
-		  ((parent widget) (name simple-string)
-		   (resources list :resource-list))
-		  (widget widget)
-		  (setf (widget-type second) ,parent-class)
-		  (setf (widget-type first) ,child-class)
-		  (widget-add-child parent second)
-		  (widget-add-child second first)))))
-  
-  (def-double-widget-stub create-warning-dialog :dialog-shell :message-box)
-  (def-double-widget-stub create-bulletin-board-dialog :dialog-shell
-    :bulletin-board)
-  (def-double-widget-stub create-error-dialog :dialog-shell :message-box)
-  (def-double-widget-stub create-file-selection-dialog :dialog-shell
-    :file-selection-box)
-  (def-double-widget-stub create-form-dialog :dialog-shell :form)
-  (def-double-widget-stub create-information-dialog :dialog-shell
-    :message-box)
-  (def-double-widget-stub create-message-dialog :dialog-shell :message-box)
-  (def-double-widget-stub create-popup-menu :menu-shell :row-column)
-  (def-double-widget-stub create-prompt-dialog :dialog-shell :selection-box)
-  (def-double-widget-stub create-pulldown-menu :menu-shell :row-column)
-  (def-double-widget-stub create-question-dialog :dialog-shell :message-box)
-  (def-double-widget-stub create-scrolled-list :scrolled-window :list)
-  (def-double-widget-stub create-scrolled-text :scrolled-window :text)
-  (def-double-widget-stub create-selection-dialog :dialog-shell
-    :selection-box)
-  (def-double-widget-stub create-working-dialog :dialog-shell :message-box))
-
-(def-toolkit-request "XmCommandAppendValue" command-append-value :no-confirm
-  "Appends the given string to the end of the string displayed in the
-   command area of the widget."
-  ((w widget) (command (or simple-string xmstring))) ())
-
-(def-toolkit-request "XmCommandError" command-error :no-confirm
-  "Displays an error message in the Command widget."
-  ((w widget) (error (or simple-string xmstring))) ())
-
-(def-toolkit-request "XmCommandSetValue" command-set-value :no-confirm
-  "Replaces the displayed string in a Command widget."
-  ((w widget) (c (or simple-string xmstring))) ())
-
-(def-toolkit-request "XmScaleGetValue" scale-get-value :confirm
-  "Returns the current slider position."
-  ((w widget)) (fixnum))
-
-(def-toolkit-request "XmScaleSetValue" scale-set-value :no-confirm
-  "Sets the current slider position."
-  ((w widget) (val fixnum)) ())
-
-(def-toolkit-request "XmToggleButtonGetState" toggle-button-get-state :confirm
-  "Obtains the state of a ToggleButton."
-  ((w widget)) ((member t nil)))
-
-(def-toolkit-request "XmToggleButtonSetState" toggle-button-set-state
-		     :no-confirm
-  "Sets the state of a ToggleButton."
-  ((w widget) (state (member t nil)) (notify (member t nil))) ())
-
-(def-toolkit-request "XmListAddItem" list-add-item :no-confirm
-  "Adds an item to the given List widget."
-  ((w widget) (item (or simple-string xmstring)) (pos fixnum)) ())
-
-(def-toolkit-request "XmListAddItemUnselected" list-add-item-unselected
-		     :no-confirm
-  "Adds an item to the List widget as an unselected entry."
-  ((w widget) (item (or simple-string xmstring)) (pos fixnum)) ())
-
-(def-toolkit-request "XmListDeleteItem" list-delete-item :no-confirm
-  "Deletes an item from the given List widget."
-  ((w widget) (item (or simple-string xmstring))) ())
-
-(def-toolkit-request "XmListDeletePos" list-delete-pos :no-confirm
-  "Deletes and item from a List widget at the specified position."
-  ((w widget) (pos fixnum)) ())
-
-(def-toolkit-request "XmListDeselectAllItems" list-deselect-all-items
-		     :no-confirm
-  "Unhighlights and removes all items from the selected list."
-  ((w widget)) ())
-
-(def-toolkit-request "XmListDeselectItem" list-deselect-item :no-confirm
-  "Deselects the specified item from the selected list."
-  ((w widget) (item (or simple-string xmstring))) ())
-
-(def-toolkit-request "XmListDeselectPos" list-deselect-pos :no-confirm
-  "Deselects an item at a specified position in a List widget."
-  ((w widget) (pos fixnum)) ())
-
-(def-toolkit-request "XmListSelectItem" list-select-item :no-confirm
-  "Selects an item in the List widget."
-  ((w widget) (item (or simple-string xmstring)) (notify (member t nil))) ())
-
-(def-toolkit-request "XmListSelectPos" list-select-pos :no-confirm
-  "Selects an item at a specified position in the List widget."
-  ((w widget) (pos fixnum) (notify (member t nil))) ())
-
-(def-toolkit-request "XmListSetBottomItem" list-set-bottom-item :no-confirm
-  "Makes an existing item the last visible in the List widget."
-  ((w widget) (item (or simple-string xmstring))) ())
-
-(def-toolkit-request "XmListSetBottomPos" list-set-bottom-pos :no-confirm
-  "Makes the item at the specified position the last visible item in the
-   given List widget."
-  ((w widget) (pos fixnum)) ())
-
-(def-toolkit-request "XmListSetHorizPos" list-set-horiz-pos :no-confirm
-  "Scrolls to the specified position in the List widget."
-  ((w widget) (pos fixnum)) ())
-
-(def-toolkit-request "XmListSetItem" list-set-item :no-confirm
-  "Makes an existing item the first visible in the List widget."
-  ((w widget) (item (or simple-string xmstring))) ())
-
-(def-toolkit-request "XmListSetPos" list-set-pos :no-confirm
-  "Makes the item at the given position the first visible item in the List."
-  ((w widget) (pos fixnum)) ())
-
-(def-toolkit-request "XmListAddItems" list-add-items :no-confirm
-  "Adds items to the given List widget."
-  ((w widget) (items list :xm-string-table) (pos fixnum)) ())
-
-(def-toolkit-request "XmListDeleteAllItems" list-delete-all-items :no-confirm
-  "Deletes all items from the List widget."
-  ((w widget)) ())
-
-(def-toolkit-request "XmListDeleteItems" list-delete-items :no-confirm
-  "Deletes specified items from the List widget."
-  ((w widget) (items list :xm-string-table)) ())
-
-(def-toolkit-request "XmListDeleteItemsPos" list-delete-items-pos :no-confirm
-  "Deletes items from the list starting at the given position."
-  ((w widget) (item-count fixnum) (pos fixnum)) ())
-
-(def-toolkit-request "XmListItemExists" list-item-exists :confirm
-  "Checks if a specified item is in the List widget."
-  ((w widget) (item (or simple-string xmstring))) ((member t nil)))
-
-(def-toolkit-request "XmListItemPos" list-item-pos :confirm
-  "Returns the position of an item in the List widget."
-  ((w widget) (item (or simple-string xmstring))) (fixnum))
-
-(def-toolkit-request "XmListReplaceItems" list-replace-items :no-confirm
-  "Replaces the specified elements in the list."
-  ((w widget) (old list :xm-string-table) (new list :xm-string-table)) ())
-
-(def-toolkit-request "XmListReplaceItemsPos" list-replace-items-pos :no-confirm
-  "Replaces items in the list, starting at the given position."
-  ((w widget) (new-items list :xm-string-table) (pos fixnum)) ())
-
-(def-toolkit-request "XmListSetAddMode" list-set-add-mode :no-confirm
-  "Sets the state of Add Mode in the list."
-  ((w widget) (mode (member t nil))) ())
-
-(def-toolkit-request "XmListGetSelectedPos" list-get-selected-pos :confirm
-  "Returns the position of every selected item in the given List."
-  ((w widget))
-  (list (member t nil)))
-
-(def-toolkit-request "XmAddTabGroup" add-tab-group :no-confirm
-  "Adds a manager or a primitive widget to the list of tab groups."
-  ((w widget)) ())
-
-(def-toolkit-request "XmRemoveTabGroup" remove-tab-group :no-confirm
-  "Removes a manager or a primitive widget from the list of tab groups."
-  ((w widget)) ())
-
-(def-toolkit-request "XmProcessTraversal" process-traversal :confirm
-  "Determines which component of a widget hierarchy receives keyboard
-   events when a widget has the keyboard focus."
-  ((w widget) (direction keyword)) ((member t nil)))
-
-(def-toolkit-request "XmFontListAdd" font-list-add :confirm
-  "Adds a new font to a font-list and destroys the old list."
-  ((flist font-list) (font xlib:font) (charset simple-string))
-  (font-list))
-
-(def-toolkit-request "XmFontListCreate" font-list-create :confirm
-  "Creates a new font-list with the specified font."
-  ((font xlib:font) (charset simple-string))
-  (font-list))
-
-(def-toolkit-request "XmFontListFree" font-list-free :no-confirm
-  "Destroys the given font-list."
-  ((flist font-list)) ())
-
-(def-toolkit-request "XmStringBaseline" compound-string-basline :confirm
-  "Returns the number of pixels between the top of the character box and
-   the basline of the first line of text."
-  ((flist font-list) (string xmstring)) (fixnum))
-
-(def-toolkit-request "XmStringByteCompare" compound-string-byte-compare
-		     :confirm
-  "Indicates the result of a byte-by-byte comparison of two compound strings."
-  ((s1 xmstring) (s2 xmstring)) ((member t nil)))
-
-(def-toolkit-request "XmStringCompare" compound-string-compare :confirm
-  "Indicates whether two compound strings are semantically equivalent."
-  ((s1 xmstring) (s2 xmstring)) ((member t nil)))
-
-(def-toolkit-request "XmStringConcat" compound-string-concat :confirm
-  "Appends one compound string to another.  The original strings are preserved."
-  ((s1 xmstring) (s2 xmstring)) (xmstring))
-
-(def-toolkit-request "XmStringCopy" compound-string-copy :confirm
-  "Makes a copy of a compound string."
-  ((s xmstring)) (xmstring))
-
-(def-toolkit-request "XmStringCreate" compound-string-create :confirm
-  "Creates a new compound string."
-  ((s simple-string) (charset simple-string)) (xmstring))
-
-(def-toolkit-request "XmStringCreateLtoR" compound-string-create-ltor :confirm
-  "Creates a new compound string and translates newline characters into
-   line separators."
-  ((s simple-string) (charset simple-string)) (xmstring))
-
-(def-toolkit-request "XmStringGetLtoR" compound-string-get-ltor :confirm
-  "Returns True if a segment can be found in the input compound string that
-   matches the specified character set."
-  ((string xmstring) (charset simple-string))
-  (simple-string (member t nil)))
-
-(def-toolkit-request "XmStringCreateSimple" compound-string-create-simple
-		     :confirm
-  "Creates a compound string in the language environment of a widget."
-  ((s simple-string)) (xmstring))
-
-(def-toolkit-request "XmStringEmpty" compound-string-empty :confirm
-  "Provides information on the existence of non-zero length text components."
-  ((s xmstring)) ((member t nil)))
-
-(def-toolkit-request "XmStringExtent" compound-string-extent :confirm
-  "Determines the size of the smallest rectangle that will enclose the
-   given compound string."
-  ((flist font-list) (x xmstring)) (fixnum fixnum))
-
-(def-toolkit-request "XmStringFree" compound-string-free :no-confirm
-  "Recovers memory used by a compound string."
-  ((s xmstring)) ()
-  (remhash (xti::motif-object-id s)
-	   (xti::motif-connection-id-table *motif-connection*)))
-
-(def-toolkit-request "XmStringHasSubstring" compound-string-has-substring
-		     :confirm
-  "Indicates whether one compound string is contained within another."
-  ((string xmstring) (substring xmstring)) ((member t nil)))
-
-(def-toolkit-request "XmStringHeight" compound-string-height :confirm
-  "Returns the line height of the given compound string."
-  ((flist font-list) (string xmstring)) (fixnum))
-
-(def-toolkit-request "XmStringLength" compound-string-length :confirm
-  "Obtains the length of a compound string."
-  ((string xmstring)) (fixnum))
-
-(def-toolkit-request "XmStringLineCount" compound-string-line-count :confirm
-  "Returns the number of separators plus one in the provided compound string."
-  ((string xmstring)) (fixnum))
-
-(def-toolkit-request "XmStringNConcat" compound-string-nconcat :confirm
-  "Appends a specified number of bytes to a compound string."
-  ((s1 xmstring) (s2 xmstring) (num_bytes fixnum)) (xmstring))
-
-(def-toolkit-request "XmStringNCopy" compound-string-ncopy :confirm
-  "Copies a specified number of bytes into a new compound string."
-  ((s string) (num_bytes fixnum)) (xmstring))
-
-(def-toolkit-request "XmStringSeparatorCreate" compound-string-separator-create
-		     :confirm
-  "Creates a compound string with a single component, a separator."
-  () (xmstring))
-
-(def-toolkit-request "XmStringWidth" compound-string-width :confirm
-  "Returns the width of the longest sequence of text components in a
-   compound string."
-  ((flist font-list) (s xmstring)) (fixnum))
-
-(def-toolkit-request "XmTextClearSelection" text-clear-selection :no-confirm
-  "Clears the primary selection."
-  ((w widget)) ())
-
-(def-toolkit-request "XmTextCopy" text-copy :confirm
-  "Copies the primary selection to the clipboard."
-  ((w widget)) ((member t nil)))
-
-(def-toolkit-request "XmTextCut" text-cut :confirm
-  "Copies the primary selection to the clipboard and deletes the selected text."
-  ((w widget)) ((member t nil)))
-
-(def-toolkit-request "XmTextGetBaseline" text-get-basline :confirm
-  "Accesses the x position of the first baseline."
-  ((w widget)) (fixnum))
-
-(def-toolkit-request "XmTextGetEditable" text-get-editable :confirm
-  "Accesses the edit permission state of the Text widget."
-  ((w widget)) ((member t nil)))
-
-(def-toolkit-request "XmTextGetInsertionPosition" text-get-insertion-position 
-		     :confirm
-  "Accesses the positions of the insert cursor."
-  ((w widget)) (fixnum))
-
-(def-toolkit-request "XmTextGetLastPosition" text-get-last-position :confirm
-  "Accesses the positio of the last text character."
-  ((w widget)) (fixnum))
-
-(def-toolkit-request "XmTextGetMaxLength" text-get-max-length :confirm
-  "Accesses the value of the current maximum allowable length of a text
-   string entered from the keyboard."
-  ((w widget)) (fixnum))
-
-(def-toolkit-request "XmTextGetSelection" text-get-selection :confirm
-  "Retrieves the value of the primary selection."
-  ((w widget)) (simple-string))
-
-(def-toolkit-request "XmTextGetSelectionPosition" text-get-selection-position
-		     :confirm
-  "Accesses the position of the primary selection."
-  ((w widget))
-  ((member t nil) fixnum fixnum))
-
-(def-toolkit-request "XmTextGetString" text-get-stringtring :confirm
-  "Accesses the string value of a Text widget."
-  ((w widget)) (simple-string))
-
-(def-toolkit-request "XmTextGetTopCharacter" text-get-top-character :confirm
-  "Accesses the position of the first character displayed."
-  ((w widget)) (fixnum))
-
-(def-toolkit-request "XmTextInsert" text-insert :no-confirm
-  "Inserts a character string into a Text widget."
-  ((w widget) (pos fixnum) (value simple-string)) ())
-
-(def-toolkit-request "XmTextPaste" text-paste :confirm
-  "Inserts the clipboard selection."
-  ((w widget)) ((member t nil)))
-
-(def-toolkit-request "XmTextPosToXY" text-pos-to-xy :confirm
-  "Accesses the x and y position of a character position."
-  ((w widget) (pos fixnum))
-  ((member t nil) fixnum fixnum))
-
-(def-toolkit-request "XmTextRemove" text-remove :confirm
-  "Deletes the primary selection."
-  ((w widget)) ((member t nil)))
-
-(def-toolkit-request "XmTextReplace" text-replace :no-confirm
-  "Replaces part of the text of a Text widget."
-  ((w widget) (from-pos fixnum) (to-pos fixnum) (value simple-string)) ())
-
-(def-toolkit-request "XmTextScroll" text-scroll :no-confirm
-  "Scrolls the text of a Text widget."
-  ((w widget) (lines fixnum)) ())
-
-(def-toolkit-request "XmTextSetAddMode" text-set-add-mode :no-confirm
-  "Sets the state of Add Mode."
-  ((w widget) (state (member t nil))) ())
-
-(def-toolkit-request "XmTextSetEditable" text-set-editable :no-confirm
-  "Sets the edit permission on a Text widget."
-  ((w widget) (editable (member t nil))) ())
-
-(def-toolkit-request "XmTextSetHighlight" text-set-highlight :no-confirm
-  "Highlights text."
-  ((w widget) (left fixnum) (right fixnum) (mode keyword)) ())
-
-(def-toolkit-request "XmTextSetInsertionPosition" text-set-insertion-position
-		     :no-confirm
-  "Sets position of the insert cursor."
-  ((w widget) (pos fixnum)) ())
-
-(def-toolkit-request "XmTextSetMaxLength" text-set-max-length :no-confirm
-  "Sets the value of the current maximum allowable length of a text string
-   entered from the keyboard."
-  ((w widget) (max-length fixnum)) ())
-
-(def-toolkit-request "XmTextSetSelection" text-set-selection :no-confirm
-  "Sets the primary selection of the Text widget."
-  ((w widget) (first fixnum) (last fixnum)) ())
-
-(def-toolkit-request "XmTextSetString" text-set-string :no-confirm
-  "Sets the string value of a Text widget."
-  ((w widget) (value simple-string)) ())
-
-(def-toolkit-request "XmTextSetTopCharacter" text-set-top-character :no-confirm
-  "Sets the position of the first character displayed."
-  ((w widget) (top-char fixnum)) ())
-
-(def-toolkit-request "XmTextShowPosition" text-show-position :no-confirm
-  "Forces text at a given position to be displayed."
-  ((w widget) (pos fixnum)) ())
-
-(def-toolkit-request "XmTextXYToPos" text-xy-to-pos :confirm
-  "Accesses the character position nearest an x and y position."
-  ((w widget) (x fixnum) (y fixnum)) (fixnum))
-
-(def-toolkit-request "XmAddProtocolCallback" %add-protocol-callback
-		     :no-confirm
-  ""
-  ((w widget) (property keyword :atom) (protocol keyword :atom)) ())
-
-(def-toolkit-request "XmRemoveProtocolCallback" %remove-protocol-callback
-		     :no-confirm
-  ""
-  ((w widget) (property keyword :atom) (protocol keyword :atom)) ())
-
-(def-toolkit-request "XmSelectionBoxGetChild" selection-box-get-child :confirm
-  "Accesses a child component of a SelectionBox widget."
-  ((w widget) (child keyword)) (widget)
-  (widget-add-child w result)
-  (setf (widget-type result) :unknown))
-
-(def-toolkit-request "XmFileSelectionBoxGetChild" file-selection-box-get-child
-		     :confirm
-  "Accesses a child component of a FileSelectionBox widget."
-  ((w widget) (child keyword)) (widget)
-  (widget-add-child w result)
-  (setf (widget-type result) :unknown))
-
-(def-toolkit-request "XmMessageBoxGetChild" message-box-get-child :confirm
-  "Accesses a child component of a MessageBox widget."
-  ((w widget) (child keyword)) (widget)
-  (widget-add-child w result)
-  (setf (widget-type result) :unknown))
-
-(def-toolkit-request "XmCommandGetChild" command-get-child :confirm
-  "Accesses a child component of a Command widget."
-  ((w widget) (child keyword))
-  (widget)
-  (widget-add-child w result)
-  (setf (widget-type result) :unknown))
-
-(def-toolkit-request "XmScrolledWindowSetAreas" scrolled-window-set-areas
-		     :no-confirm
-  "Adds or changes a window work region and a horizontal or vertical
-   ScrollBar widget to the ScrolledWindow widget."
-  ((widget widget) (horiz-scroll (or null widget))
-   (vert-scroll (or null widget)) (work-region (or null widget)))
-  ())
-
-(def-toolkit-request "XmTrackingLocate" tracking-locate :confirm
-  "Provides a modal interface for the selection of a component."
-  ((w widget) (cursor xlib:cursor) (confine-to (member t nil)))
-  (widget))
-
-(def-toolkit-request "XmScrollBarGetValues" scroll-bar-get-values :confirm
-  "Returns the ScrollBar's increment values."
-  ((widget widget))
-  (fixnum fixnum fixnum fixnum))
-
-(def-toolkit-request "XmScrollBarSetValues" scroll-bar-set-values :no-confirm
-  "Changes the ScrollBar's increments values and the slider's size and
-   position."
-  ((widget widget) (value fixnum) (slider-size fixnum)
-   (increment fixnum) (page-increment fixnum) (notify (member t nil)))
-  ())
-
-(def-toolkit-request "SetItems" set-items :no-confirm
-  "Set the items of a List widget."
-  ((widget widget) (items list :xm-string-table)) ())
-
-(def-toolkit-request "GetItems" get-items :confirm
-  "Get the items of a List widget."
-  ((widget widget))
-  (list))
-
-(def-toolkit-request "ReturnTextCallbackDoit" return-text-callback-doit
-		     :no-confirm
-  "Return a boolean value determining whether the proposed text action will
-   actually be performed."
-  ((doit (member t nil)))
-  ())
diff --git a/motif/lisp/string-base.lisp b/motif/lisp/string-base.lisp
deleted file mode 100644
index cd0dd18b971640f2fc09ae3077481a71e804533e..0000000000000000000000000000000000000000
--- a/motif/lisp/string-base.lisp
+++ /dev/null
@@ -1,336 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Toolkit-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; This is the database of strings used for tokenizing communications
-;;; between Lisp and C.
-;;;
-
-(in-package "TOOLKIT-INTERNALS")
-
-;;; This table MUST be *SORTED*.
-(setf *toolkit-string-table*
-      (vector
-       "accelerator"
-       "acceleratorText"
-       "accelerators"
-       "activateCallback"
-       "adjustLast"
-       "adjustMargin"
-       "alignment"
-       "allowResize"
-       "allowShellResize"
-       "ancestorSensitive"
-       "applyCallback"
-       "applyLabelString"
-       "armCallback"
-       "armColor"
-       "armPixmap"
-       "autoShowCursorPosition"
-       "automaticSelection"
-       "background"
-       "backgroundPixmap"
-       "bitmap"
-       "blinkRate"
-       "borderColor"
-       "borderPixmap"
-       "borderWidth"
-       "bottomAttachment"
-       "bottomOffset"
-       "bottomPosition"
-       "bottomShadowColor"
-       "bottomShadowPixmap"
-       "bottomWidget"
-       "browseSelectionCallback"
-       "buttonAcceleratorText"
-       "buttonAccelerators"
-       "buttonCount"
-       "buttonMnemonicCharSets"
-       "buttonMnemonics"
-       "buttonSet"
-       "buttonType"
-       "buttons"
-       "cancelButton"
-       "cancelCallback"
-       "cancelLabelString"
-       "cascadePixmap"
-       "cascadingCallback"
-       "children"
-       "clipWindow"
-       "colormap"
-       "columns"
-       "commandChangedCallback"
-       "commandEnteredCallback"
-       "commandWindow"
-       "commandWindowLocation"
-       "createPopupChildProc"
-       "cursorPosition"
-       "cursorPositionVisible"
-       "decrementCallback"
-       "defaultActionCallback"
-       "defaultButton"
-       "defaultButtonShadowThickness"
-       "defaultFontList"
-       "depth"
-       "destroyCallback"
-       "dialogTitle"
-       "disarmCallback"
-       "doubleClickInterval"
-       "dragCallback"
-       "editMode"
-       "editType"
-       "editable"
-       "entryAlignment"
-       "entryBorder"
-       "entryCallback"
-       "entryClass"
-       "exposeCallback"
-       "extendedSelectionCallback"
-       "file"
-       "fillOnArm"
-       "fillOnSelect"
-       "filterLabelString"
-       "focusCallback"
-       "font"
-       "fontList"
-       "forceBars"
-       "foreground"
-       "function"
-       "gainPrimaryCallback"
-       "height"
-       "helpCallback"
-       "helpLabelString"
-       "highlight"
-       "highlightColor"
-       "highlightOnEnter"
-       "highlightPixmap"
-       "highlightThickness"
-       "horizontalScrollBar"
-       "iconMask"
-       "iconName"
-       "iconPixmap"
-       "iconWindow"
-       "increment"
-       "incrementCallback"
-       "index"
-       "indicatorOn"
-       "indicatorSize"
-       "indicatorType"
-       "initialDelay"
-       "initialResourcesPersistent"
-       "innerHeight"
-       "innerWidth"
-       "innerWindow"
-       "inputCallback"
-       "inputCreate"
-       "insertPosition"
-       "internalHeight"
-       "internalWidth"
-       "isAligned"
-       "isHomogeneous"
-       "itemCount"
-       "items"
-       "jumpProc"
-       "justify"
-       "labelInsensitivePixmap"
-       "labelPixmap"
-       "labelString"
-       "labelType"
-       "leftAttachment"
-       "leftOffset"
-       "leftPosition"
-       "leftWidget"
-       "length"
-       "listLabelString"
-       "listMarginHeight"
-       "listMarginWidth"
-       "listSizePolicy"
-       "listSpacing"
-       "listUpdated"
-       "losePrimaryCallback"
-       "losingFocusCallback"
-       "lowerRight"
-       "mainWindowMarginHeight"
-       "mainWindowMarginWidth"
-       "mapCallback"
-       "mappedWhenManaged"
-       "mappingDelay"
-       "marginBottom"
-       "marginHeight"
-       "marginLeft"
-       "marginRight"
-       "marginTop"
-       "marginWidth"
-       "maxLength"
-       "maximum"
-       "menuAccelerator"
-       "menuBar"
-       "menuCursor"
-       "menuEntry"
-       "menuHelpWidget"
-       "menuHistory"
-       "menuPost"
-       "messageString"
-       "messageWindow"
-       "minimum"
-       "mnemonic"
-       "mnemonicCharSet"
-       "modifyVerifyCallback"
-       "motionVerifyCallback"
-       "multiClick"
-       "multipleSelectionCallback"
-       "name"
-       "navigationType"
-       "noMatchCallback"
-       "notify"
-       "numChildren"
-       "numColumns"
-       "okCallback"
-       "okLabelString"
-       "optionLabel"
-       "optionMnemonic"
-       "orientation"
-       "outputCreate"
-       "overrideRedirect"
-       "packing"
-       "pageDecrementCallback"
-       "pageIncrement"
-       "pageIncrementCallback"
-       "paneMaximum"
-       "paneMinimum"
-       "parameter"
-       "pendingDelete"
-       "popdownCallback"
-       "popupCallback"
-       "popupEnabled"
-       "postFromButton"
-       "postFromCount"
-       "postFromList"
-       "processingDirection"
-       "promptString"
-       "radioAlwaysOne"
-       "radioBehavior"
-       "recomputeSize"
-       "refigureMode"
-       "repeatDelay"
-       "resizable"
-       "resize"
-       "resizeCallback"
-       "resizeHeight"
-       "resizeWidth"
-       "reverseVideo"
-       "rightAttachment"
-       "rightOffset"
-       "rightPosition"
-       "rightWidget"
-       "rowColumnType"
-       "rows"
-       "sashHeight"
-       "sashIndent"
-       "sashShadowThickness"
-       "sashWidth"
-       "saveUnder"
-       "scaleMultiple"
-       "screen"
-       "scrollBarDisplayPolicy"
-       "scrollBarPlacement"
-       "scrollDCursor"
-       "scrollHCursor"
-       "scrollHorizontal"
-       "scrollLCursor"
-       "scrollLeftSide"
-       "scrollProc"
-       "scrollRCursor"
-       "scrollTopSide"
-       "scrollUCursor"
-       "scrollVCursor"
-       "scrollVertical"
-       "scrolledWindowMarginHeight"
-       "scrolledWindowMarginWidth"
-       "scrollingPolicy"
-       "selectColor"
-       "selectInsensitivePixmap"
-       "selectPixmap"
-       "selectThreshold"
-       "selectedItemCount"
-       "selectedItems"
-       "selection"
-       "selectionArray"
-       "selectionArrayCount"
-       "selectionLabelString"
-       "selectionPolicy"
-       "sensitive"
-       "separatorOn"
-       "set"
-       "shadow"
-       "shadowThickness"
-       "showArrows"
-       "showAsDefault"
-       "showSeparator"
-       "shown"
-       "simpleCallback"
-       "singleSelectionCallback"
-       "sizePolicy"
-       "skipAdjust"
-       "sliderSize"
-       "source"
-       "space"
-       "spacing"
-       "string"
-       "stringDirection"
-       "subMenuId"
-       "symbolPixmap"
-       "textOptions"
-       "textSink"
-       "textSource"
-       "thickness"
-       "thumb"
-       "thumbProc"
-       "title"
-       "titleString"
-       "toBottomCallback"
-       "toPositionCallback"
-       "toTopCallback"
-       "top"
-       "topAttachment"
-       "topItemPosition"
-       "topOffset"
-       "topPosition"
-       "topShadowColor"
-       "topShadowPixmap"
-       "topWidget"
-       "transient"
-       "translations"
-       "traversalOn"
-       "traversalType"
-       "troughColor"
-       "unitType"
-       "unmapCallback"
-       "unselectPixmap"
-       "update"
-       "updateSliderSize"
-       "useBottom"
-       "useRight"
-       "userData"
-       "value"
-       "valueChangedCallback"
-       "verifyBell"
-       "verticalScrollBar"
-       "visibleItemCount"
-       "visibleWhenOff"
-       "visualPolicy"
-       "whichButton"
-       "width"
-       "window"
-       "windowGroup"
-       "wordWrap"
-       "workWindow"
-       "x"
-       "y"))
diff --git a/motif/lisp/transport.lisp b/motif/lisp/transport.lisp
deleted file mode 100644
index 01f708a7e0c6b2297ffde56a8a709594a22d17fd..0000000000000000000000000000000000000000
--- a/motif/lisp/transport.lisp
+++ /dev/null
@@ -1,308 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Toolkit-Internals -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; Code for transporting packets and messages between the C toolkit server
-;;; and the Lisp client.
-;;;
-
-(in-package "TOOLKIT-INTERNALS")
-
-
-
-;;;; Data structures
-
-(defconstant *header-size* 12)
-
-(defstruct (packet
-	    (:print-function print-packet)
-	    (:constructor make-packet (head)))
-  (head nil :type system:system-area-pointer)
-  (fill *header-size* :type fixnum)
-  (next nil :type (or null packet)))
-
-(defstruct (message
-	    (:print-function print-message)
-	    (:constructor %make-message))
-  (packet-count 0 :type fixnum)
-  (serial (the fixnum 0) :type (unsigned-byte 32))
-  (fill-packet nil :type (or null packet))
-  ;;
-  ;; NOTE:  This list contains the constituent packets in REVERSE order
-  ;; while the message is being constructed.  When it is finished, the list
-  ;; is reversed.
-  (packet-list nil :type list))
-
-(defun print-packet (p stream d)
-  (declare (ignore p d))
-  (write-string "#<X Toolkit Packet>" stream))
-
-(defun print-message (r stream d)
-  (declare (ignore d)
-	   (stream stream))
-  (format stream "#<X Toolkit Message - serial ~d>"(message-serial r)))
-
-(defconstant *packet-size* 4096)
-
-(deftype packet-index () `(integer 0 ,*packet-size*))
-
-
-
-;;;; Memory management and packet accessors
-
-(defmacro packet-serial (packet)
-  `(the (signed-byte 29) (system:signed-sap-ref-32 (packet-head ,packet) 0)))
-
-(defmacro packet-sequence-number (packet)
-  `(system:signed-sap-ref-16 (packet-head ,packet) 4))
-
-(defmacro packet-sequence-length (packet)
-  `(system:signed-sap-ref-16 (packet-head ,packet) 6))
-
-(defmacro packet-length (packet)
-  `(the packet-index (system:signed-sap-ref-32 (packet-head ,packet) 8)))
-
-
-;;; Free-list for keeping empty packet husks around.
-(defvar *free-packets* nil)
-
-(defun create-packet ()
-  (if *free-packets*
-      (let ((packet *free-packets*))
-	(setf *free-packets* (packet-next packet))
-	(setf (packet-length packet) *header-size*)
-	(setf (packet-fill packet) *header-size*)
-	packet)
-      (let* ((buffer (system:allocate-system-memory *packet-size*))
-	     (packet (make-packet buffer)))
-	(setf (packet-length packet) *header-size*)
-	packet)))
-
-(defun destroy-packet (packet)
-  (setf (packet-next packet) *free-packets*)
-  (setf *free-packets* packet))
-
-(declaim (inline make-message))
-(defun make-message (serial)
-  (declare (type (unsigned-byte 29) serial))
-  (let ((message (%make-message)))
-    (setf (message-serial message) serial)
-    message))
-
-
-
-
-;;;; Functions to stuff things into packets
-
-(macrolet ((def-packet-writer (name size)
-	     (let ((sap-ref (ecase size
-			      (1 'system:sap-ref-8)
-			      (2 'system:sap-ref-16)
-			      (4 'system:sap-ref-32)))
-		   (bits (* size 8)))
-	       `(defun ,name (packet data)
-		  (declare (type (signed-byte ,bits) data))
-		  (let ((fill (system:sap+ (packet-head packet)
-					   (packet-fill packet))))
-		    (setf (,sap-ref fill 0) data)
-		    (incf (packet-fill packet) ,size)
-		    (incf (packet-length packet) ,size)))))
-	   (def-packet-reader (name size)
-	     (let ((sap-ref (ecase size
-			      (1 'system:sap-ref-8)
-			      (2 'system:sap-ref-16)
-			      (4 'system:sap-ref-32)))
-		   (bits (* size 8)))
-	       `(defun ,name (packet)
-		  (let* ((fill (system:sap+ (packet-head packet)
-					    (packet-fill packet)))
-			 (data (,sap-ref fill 0)))
-		    (declare (type (signed-byte ,bits) data))
-		    (incf (packet-fill packet) ,size)
-		    data)))))
-  (def-packet-writer packet-put-byte 1)
-  (def-packet-writer packet-put-word 2)
-  (def-packet-writer packet-put-dblword 4)
-
-  (def-packet-reader packet-get-byte 1)
-  (def-packet-reader packet-get-word 2)
-  (def-packet-reader packet-get-dblword 4))
-
-
-
-;;;; Message management and accessors
-
-(defun create-message (serial)
-  (let ((message (make-message serial)))
-    (message-add-packet message)
-    message))
-
-(defun destroy-message (message)
-  (dolist (packet (message-packet-list message))
-    (destroy-packet packet)))
-
-(defun message-add-packet (message)
-  (let ((packet (create-packet)))
-    (push packet (message-packet-list message))
-    (setf (message-fill-packet message) packet)
-    (incf (message-packet-count message))
-    (setf (packet-sequence-number packet) (message-packet-count message))
-    ;; PACKET-SEQUENCE-LENGTH will be set when the message is sent
-    (setf (packet-serial packet) (message-serial message))))
-
-
-(macrolet ((def-message-writer (name size)
-	     (let ((packet-ref (ecase size
-				 (1 'packet-put-byte)
-				 (2 'packet-put-word)
-				 (4 'packet-put-dblword)))
-		   (bits (* size 8)))
-	       `(defun ,name (message data)
-		  (declare (type (signed-byte ,bits) data))
-		  (when (> (packet-length (message-fill-packet message))
-			   (- *packet-size* ,size 1))
-		    (message-add-packet message))
-		  (,packet-ref (message-fill-packet message) data))))
-	   (def-message-reader (name size)
-	     (let ((packet-ref (ecase size
-				 (1 'packet-get-byte)
-				 (2 'packet-get-word)
-				 (4 'packet-get-dblword))))
-	       `(defun ,name (message)
-		  (unless (< (packet-fill (message-fill-packet message))
-			     (- *packet-size* ,size -1))
-		    ;;
-		    ;; This is REALLY gross
-		    (setf (message-fill-packet message)
-			  (cadr (member (message-fill-packet message)
-					(message-packet-list message)))))
-		  (,packet-ref (message-fill-packet message))))))
-
-  (def-message-writer message-put-byte 1)
-  (def-message-writer message-put-word 2)
-  (def-message-writer message-put-dblword 4)
-
-  ;; These accessors should only be used in deciphering complete messages.
-  ;; Hence, it is assumed that the message IS complete (ie. the packets are
-  ;; in normal order).
-  (def-message-reader message-get-byte 1)
-  (def-message-reader message-get-word 2)
-  (def-message-reader message-get-dblword 4))
-
-
-
-;;;; Transmission functions
-
-(defun read-some-bytes (socket packet count)
-  (declare (type packet-index count))
-  (loop
-    (when (zerop count) (return))
-    (multiple-value-bind
-	(bytes-read errnum)
-	(unix:unix-read socket (system:sap+ (packet-head packet)
-					    (packet-fill packet)) count)
-      (declare (type (or null fixnum) bytes-read))
-      (unless bytes-read
-	(toolkit-error "Encountered error reading packet: ~a"
-		       (unix:get-unix-error-msg errnum)))
-      (when (zerop bytes-read)
-	(error 'toolkit-eof-error :string "Hit EOF while reading packet"))
-      (decf count (the fixnum bytes-read))
-      (incf (packet-fill packet) (the fixnum bytes-read)))))
-
-(defun write-some-bytes (socket packet)
-  (let ((fill 0)
-	(count (packet-length packet)))
-    (declare (type packet-index fill count))
-    (loop
-      (when (zerop count) (return))
-      (multiple-value-bind
-	  (bytes-sent errnum)
-	  (unix:unix-write socket (system:sap+ (packet-head packet) fill)
-			   0 count)
-	(declare (type (or null fixnum) bytes-sent))
-	(unless bytes-sent
-	  (toolkit-error "Encountered error writing packet: ~a"
-			 (unix:get-unix-error-msg errnum)))
-	(when (zerop (the fixnum bytes-sent))
-	  (error 'toolkit-eof-error :string "Hit EOF while sending packet."))
-	(decf count (the fixnum bytes-sent))
-	(incf fill (the fixnum bytes-sent))))))
-
-(defun check-packet-sanity (packet)
-  (format t "Packet serial is ~a~%" (packet-serial packet))
-  (format t "Packet current is ~a~%" (packet-sequence-number packet))
-  (format t "Packet total is ~a~%" (packet-sequence-length packet))
-  (format t "Packet length is ~a~%" (packet-length packet)))
-
-(declaim (inline transmit-packet receive-packet))
-(defun transmit-packet (packet socket)
-  (write-some-bytes socket packet ))
-
-(defun receive-packet (socket)
-  (let ((packet (create-packet)))
-    (setf (packet-fill packet) 0)
-    (read-some-bytes socket packet *header-size*)
-    (read-some-bytes socket packet (- (packet-length packet) *header-size*))
-    (setf (packet-fill packet) *header-size*)
-    packet))
-
-(defun transmit-message (message socket)
-  ;; First, reverse the packet list so that the packets go out in the right
-  ;; order
-  (setf (message-packet-list message) (nreverse (message-packet-list message)))
-  (let ((packet-count (message-packet-count message)))
-    (dolist (packet (message-packet-list message))
-      (setf (packet-sequence-length packet) packet-count)
-      (transmit-packet packet socket))))
-
-;;; An a-list of (serial . incomplete message)
-(defvar *pending-msgs* nil)
-
-(defun kill-deferred-message (packet)
-  (declare (ignore packet))
-  (warn "Cannot yet handle killing deferred messages."))
-
-(defun defer-packet (packet)
-  (declare (ignore packet))
-  (warn "Cannot yet handle deferring packets."))
-
-(defun receive-message (socket)
-  (let* ((first (receive-packet socket))
-	 (count (packet-sequence-length first)))
-    (cond
-     ((zerop count) (kill-deferred-message first))
-     ((= count 1)
-      (let ((message (make-message (packet-serial first))))
-	(setf (message-packet-count message) 1)
-	(push first (message-packet-list message))
-	(setf (message-fill-packet message) first)
-	message))
-     (t
-      (defer-packet first)))))
-
-
-
-;;;; Functions for handling requests
-
-(defun create-next-message ()
-  (let ((message (create-message (motif-connection-serial
-				  *motif-connection*))))
-    (incf (motif-connection-serial *motif-connection*))
-    message))
-
-(defun prepare-request (request-op options arg-count)
-  (declare (type (unsigned-byte 16) request-op)
-	   (type (unsigned-byte 8) arg-count))
-  (let ((message (create-next-message)))
-    (message-put-word message request-op)
-    (message-put-byte message (if (eq options :confirm) 1 0))
-    (message-put-byte message arg-count)
-    message))
diff --git a/motif/lisp/widgets.lisp b/motif/lisp/widgets.lisp
deleted file mode 100644
index d3131944eaa65317aa14c373590939ee7acf5145..0000000000000000000000000000000000000000
--- a/motif/lisp/widgets.lisp
+++ /dev/null
@@ -1,235 +0,0 @@
-;;;; -*- Mode: Lisp ; Package: Toolkit -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; These functions provide a nice interface to the underlying primitives
-;;; for manipulating widgets.
-;;;
-
-(in-package "TOOLKIT")
-
-
-
-;;;; Functions for dealing with widget resources
-
-;;; The resource list arguments are of the form:
-;;;      ( ... :<resource-name> <resource-value> ...)
-;;; eg.  (:label-string "Hello world")
-
-;;; This function takes a resource list and converts the resource symbols
-;;; into their appropriate string names
-(defun convert-resource-list (resources)
-  (when (cdr resources)
-    (setf (car resources) (symbol-resource (car resources)))
-    (convert-resource-list (cddr resources))))
-
-(defun convert-resource-names (resources)
-  (when resources
-    (setf (car resources) (symbol-resource (car resources)))
-    (convert-resource-names (cdr resources))))
-
-(declaim (inline set-values get-values))
-(defun set-values (widget &rest resources)
-  "Set the resource values of the specified widget."
-  (declare (type widget widget))
-  (convert-resource-list resources)
-  (%set-values widget resources))
-
-(defun get-values (widget &rest names)
-  "Access the resource values of the specified widget."
-  (declare (type widget widget))
-  (convert-resource-names names)
-  (%get-values widget names))
-
-(defmacro with-resource-values ((widget names bindings) &body forms)
-  `(progn
-     (convert-resource-names ,names)
-     (multiple-value-bind ,bindings
-			  (values-list (%get-values ,widget ,names))
-       ,@forms)))
-
-
-
-;;;; Functions for creating/destroying widgets
-
-(declaim (inline create-managed-widget create-widget create-application-shell
-		 create-popup-shell destroy-widget))
-(defun create-managed-widget (name class parent &rest resources)
-  "Creates a new widget and automatically manages it."
-  (declare (simple-string name)
-	   (keyword class)
-	   (type widget parent))
-  (convert-resource-list resources)
-  (%create-managed-widget name class parent resources))
-
-(defun create-widget (name class parent &rest resources)
-  "Creates a new widget."
-  (declare (simple-string name)
-	   (keyword class)
-	   (type widget parent))
-  (convert-resource-list resources)
-  (%create-widget name class parent resources))
-
-(defun create-application-shell (&rest resources)
-  "Creates an application shell."
-  (convert-resource-list resources)
-  (%create-application-shell resources))
-
-(defun create-popup-shell (name class parent &rest resources)
-  "Creates a popup shell."
-  (declare (simple-string name)
-	   (keyword class)
-	   (type widget parent))
-  (convert-resource-list resources)
-  (%create-popup-shell name class parent resources))
-
-(defun internal-destroy-widget (widget)
-  (declare (type widget widget))
-  (let ((id (widget-id widget)))
-    ;; Destroy all storage for widget's children
-    (dolist (child (widget-children widget))
-      (internal-destroy-widget child))
-    ;; Remove widget's entry in the widget table
-    (remhash id (motif-connection-widget-table *motif-connection*))
-    ;; Destroy all callback information
-    (dolist (cback-name (widget-callbacks widget))
-      (remhash (cons id (symbol-resource cback-name))
-	       (motif-connection-callback-table *motif-connection*)))
-    ;; Destroy all protocol callback information
-    (dolist (entry (widget-protocols widget))
-      (let ((prop (car entry))
-	    (proto (cdr entry)))
-	(remhash (list (widget-id widget) prop proto)
-		 (motif-connection-protocol-table *motif-connection*))))
-    ;; Destroy all event handler information
-    (dolist (event-class (widget-events widget))
-      (remhash (cons (widget-id widget) event-class)
-	       (motif-connection-event-table *motif-connection*)))))
-
-(defun destroy-widget (widget)
-  "Destroys the specified widget and all its descendents."
-  (declare (type widget widget))
-  (let ((parent (widget-parent widget)))
-    (setf (widget-children parent)
-	  (delete widget (widget-children parent))))
-  (internal-destroy-widget widget)
-  (%destroy-widget widget))
-
-(declaim (inline manage-children unmanage-children))
-(defun manage-children (&rest widgets)
-  "Manage multiple children of the same parent."
-  (%manage-children widgets))
-
-(defun unmanage-children (&rest widgets)
-  "Unmanage multiple children of the same parent."
-  (%unmanage-children widgets))
-
-
-
-;;;; Motif widget creation convenience functions
-
-(defvar *convenience-auto-manage* nil
-  "Controls whether widget convenience functions will automatically manage the
-   widgets which they create.")
-
-(eval-when (compile eval)
-  (defmacro def-widget-maker (class)
-    (let ((fn-name (read-from-string (format nil "CREATE-~a" class))))
-      `(progn
-	 (declaim (inline ,fn-name))
-	 (defun ,fn-name (parent name &rest resources)
-	   ,(format nil "Creates a new ~a widget." class)
-	   (declare (type widget parent)
-		    (simple-string name))
-	   (convert-resource-list resources)
-	   (if *convenience-auto-manage*
-	       (%create-managed-widget name ,class parent resources)
-	       (%create-widget name ,class parent resources))))))
-  
-  (defmacro def-creation-wrapper (class)
-    (let ((fn-name (read-from-string (format nil "CREATE-~a" class)))
-	  (other (read-from-string (format nil "%CREATE-~a" class))))
-      `(progn
-	 (declaim (inline ,fn-name))
-	 (defun ,fn-name (parent name &rest resources)
-	   ,(format nil "Creates a new ~a widget." class)
-	   (declare (type widget parent)
-		    (simple-string name))
-	   (convert-resource-list resources)
-	   (,other parent name resources)))))
-  ) ;; EVAL-WHEN
-
-
-(def-widget-maker :arrow-button)
-(def-widget-maker :arrow-button-gadget)
-(def-widget-maker :bulletin-board)
-(def-widget-maker :cascade-button)
-(def-widget-maker :cascade-button-gadget)
-(def-widget-maker :command)
-(def-widget-maker :dialog-shell)
-(def-widget-maker :drawing-area)
-(def-widget-maker :drawn-button)
-(def-widget-maker :file-selection-box)
-(def-widget-maker :form)
-(def-widget-maker :frame)
-(def-widget-maker :label)
-(def-widget-maker :label-gadget)
-(def-widget-maker :list)
-(def-widget-maker :main-window)
-(def-widget-maker :menu-shell)
-(def-widget-maker :message-box)
-(def-widget-maker :paned-window)
-(def-widget-maker :push-button)
-(def-widget-maker :push-button-gadget)
-(def-widget-maker :row-column)
-(def-widget-maker :scale)
-(def-widget-maker :scroll-bar)
-(def-widget-maker :scrolled-window)
-(def-widget-maker :selection-box)
-(def-widget-maker :separator)
-(def-widget-maker :separator-gadget)
-(def-widget-maker :text)
-(def-widget-maker :toggle-button)
-(def-widget-maker :toggle-button-gadget)
-
-
-(def-creation-wrapper :menu-bar)
-(def-creation-wrapper :option-menu)
-(def-creation-wrapper :radio-box)
-(def-creation-wrapper :warning-dialog)
-(def-creation-wrapper :bulletin-board-dialog)
-(def-creation-wrapper :error-dialog)
-(def-creation-wrapper :file-selection-dialog)
-(def-creation-wrapper :form-dialog)
-(def-creation-wrapper :information-dialog)
-(def-creation-wrapper :message-dialog)
-(def-creation-wrapper :popup-menu)
-(def-creation-wrapper :prompt-dialog)
-(def-creation-wrapper :pulldown-menu)
-(def-creation-wrapper :question-dialog)
-(def-creation-wrapper :scrolled-list)
-(def-creation-wrapper :scrolled-text)
-(def-creation-wrapper :selection-dialog)
-(def-creation-wrapper :working-dialog)
-
-
-
-;;;; Misc. widget management functions
-
-(declaim (inline menu-position))
-(defun menu-position (widget event)
-  "Positions a popup menu according to the position in the given XEvent."
-  (declare (type widget widget)
-	   (type (or (unsigned-byte 32) toolkit-event) event))
-
-  (%menu-position widget
-		    (if (typep event 'toolkit-event)
-			(xti:event-handle event)
-			event)))
diff --git a/motif/lisp/xt-types.lisp b/motif/lisp/xt-types.lisp
deleted file mode 100644
index a16e8bee9c74e4acb296473ff2e2731c5a6044db..0000000000000000000000000000000000000000
--- a/motif/lisp/xt-types.lisp
+++ /dev/null
@@ -1,278 +0,0 @@
-;;;; -*- Mode: Lisp, Fill ; Package: Toolkit -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-;;; **********************************************************************
-;;;
-;;; Written by Michael Garland
-;;;
-;;; This file defines the data types allowed in communication between the
-;;; Lisp client and the C server.
-;;;
-
-(in-package "TOOLKIT")
-
-(declaim (vector *class-table*))
-(declaim (simple-vector *type-table*))
-
-(setf (fill-pointer *class-table*) 0)
-(setf next-type-tag 0)
-
-
-
-;;;; Functions for defining data types
-
-;;; enumeration values will have a :enum-value on the symbol plist
-(defun def-toolkit-enum (type values)
-  ;; Values begin at zero by default and increase by one each time
-  (let ((current 0)
-	(values-alist)
-	(main-value))
-    (declare (fixnum current))
-    (dolist (value values)
-      (setf main-value value)
-      (when (listp value)
-	(when (numberp (car value))
-	  (setf current (car value))
-	  (setf value (cdr value)))
-	(setf main-value (car value))
-	(dolist (synonym (cdr value))
-	  (setf (get synonym :enum-value) current)))
-      (setf (get main-value :enum-value) current)
-      (push (cons current main-value) values-alist)
-      (incf current))
-    (setf (gethash type *enum-table*) values-alist)))
-    
-(defun def-toolkit-types (types)
-  (dolist (type types)
-    (let ((name (first type))
-	  (kind (second type)))
-      (setf (get name :xtk-type-tag) next-type-tag)
-      (when (eq kind :enum) (setf kind name))
-      (setf (svref *type-table* next-type-tag) (cons name kind))
-      (incf next-type-tag))))
-
-
-
-;;;; Defining of widget classes
-
-(defun def-motif-classes (shells motif-shells classes)
-  (flet ((register-shell (name format-arg)
-	   (setf (get name :widget-class) (fill-pointer *class-table*))
-	   (vector-push-extend
-	    (cons name (format nil format-arg (symbol-resource name)))
-	    *class-table*))
-	 (register-class (name format-arg)
-	   (setf (get name :widget-class) (fill-pointer *class-table*))
-	   (vector-push-extend
-	    (cons name (format nil format-arg (symbol-class name)))
-	    *class-table*)))
-    (dolist (shell shells)
-      (register-shell shell "~aWidgetClass"))
-    (dolist (motif-shell motif-shells)
-      (register-class motif-shell "xm~aWidgetClass"))
-    (dolist (thing classes)
-      (let ((widget (first thing))
-	    (gadget (second thing)))
-	(register-class widget "xm~aWidgetClass")
-	(when gadget
-	  (register-class gadget "xm~aClass"))))))
-
-
-
-;;;; Widget classes
-
-(def-motif-classes
-  ;; These are the generic Xt shell widget classes
-  '(:override-shell :transient-shell :top-level-shell :application-shell)
-  ;;
-  ;; These are specific Motif shell widget classes
-  '(:dialog-shell :menu-shell)
-  ;;
-  ;; These are the various other widget classes (all Motif)
-  '((:label :label-gadget)
-    (:arrow-button :arrow-button-gadget)
-    (:push-button :push-button-gadget)
-    (:toggle-button :toggle-button-gadget)
-    (:cascade-button :cascade-button-gadget)
-    (:separator :separator-gadget)
-    (:drawn-button)
-    (:menu-shell)
-    (:drawing-area)
-    (:dialog-shell)
-    (:bulletin-board)
-    (:command)
-    (:file-selection-box)
-    (:form)
-    (:message-box)
-    (:selection-box)
-    (:scroll-bar)
-    (:text)
-    (:text-field)
-    (:row-column)
-    (:scale)
-    (:frame)
-    (:list)
-    (:main-window)
-    (:scrolled-window)
-    (:paned-window)))
-
-
-
-;;;; Motif data types
-;;;
-;;; The types MUST be listed in alphabetical order
-;;;
-
-(def-toolkit-types
-  '((:accelerator-table :accelerator-table) (:alignment :enum)
-    (:arrow-direction :enum) (:atom :atom) (:attachment :enum)
-    (:bitmap :xid) (:bool :boolean) (:boolean :boolean) (:callback-reason :enum)
-    (:cardinal :int) (:char :short) (:color :color) (:colormap :xid)
-    (:command-window-location :enum) (:cursor :xid) (:default-button-type :enum)
-    (:dialog-style :enum) (:dialog-type :enum) (:dimension :short)
-    (:edit-mode :enum) (:enum :enum) (:event :event) (:file-type-mask :enum)
-    (:float :float) (:font :xid) (:font-list :font-list)
-    (:function :function) (:grab-kind :enum) (:highlight-mode :enum)
-    (:indicator-type :enum) (:initial-state :int) (:int :int)
-    (:int-list :int-list) (:keyboard-focus-policy :enum) (:label-type :enum)
-    (:list-size-policy :enum) (:multi-click :enum) (:navigation-type :enum)
-    (:packing :enum) (:pixel :int) (:pixmap :xid) (:pointer :int)
-    (:position :short) (:processing-direction :enum) (:resize-policy :enum)
-    (:resource-list :resource-list) (:resource-names :resource-names)
-    (:row-column-type :enum) (:scroll-bar-display-policy :enum)
-    (:scroll-bar-placement :enum) (:scrolling-policy :enum)
-    (:selection-policy :enum) (:separator-type :enum) (:shadow-type :enum)
-    (:short :short) (:string :string) (:string-direction :enum)
-    (:string-table :string-table) (:string-token :string-token)
-    (:translation-table :translation-table) (:traversal-direction :enum)
-    (:unit-type :enum) (:unsigned-char :short) (:visual-policy :enum)
-    (:widget :widget) (:widget-class :widget-class)
-    (:widget-list :widget-list) (:window :xid) (:xm-string :xm-string)
-    (:xm-string-table :xm-string-table)))
-
-(def-toolkit-enum :arrow-direction
-  '(:arrow-up :arrow-down :arrow-left :arrow-right))
-
-(def-toolkit-enum :shadow-type
-  '((5 :shadow-etched-in :etched-in) (:shadow-etched-out :etched-out)
-    (:shadow-in :in) (:shadow-out :out)))
-
-(def-toolkit-enum :alignment
-  '((:alignment-beginning :beginning) (:alignment-center :center)
-    (:alignment-end :end)))
-
-(def-toolkit-enum :attachment
-  '((:attach-none :none) :attach-form
-    (:attach-opposite-form :opposite-form) (:attach-widget :widget)
-    (:attach-opposite-widget :opposite-widget) (:attach-position :position)
-    (:attach-self :self)))
-
-(def-toolkit-enum :resize-policy
-  '((:resize-none :none) (:resize-grow :grow) (:resize-any :any)))
-
-(def-toolkit-enum :separator-type
-  '(:no-line :single-line :double-line :single-dashed-line
-   :double-dashed-line :shadow-etched-in :shadow-etched-out))
-
-(def-toolkit-enum :keyboard-focus-policy
-  '(:explicit :pointer))
-
-(def-toolkit-enum :row-column-type
-  '(:work-area :menu-bar :menu-pulldown :menu-popup :menu-option))
-
-(def-toolkit-enum :orientation
-  '(:no-orientation :vertical :horizontal))
-
-(def-toolkit-enum :grab-kind
-  '(:grab-none :grab-nonexclusive :grab-exclusive))
-
-(def-toolkit-enum :edit-mode
-  '(:multi-line-edit :single-line-edit))
-
-(def-toolkit-enum :callback-reason
-  '(:cr-none :cr-help :cr-value-changed :cr-increment :cr-decrement
-    :cr-page-increment :cr-page-decrement :cr-to-top :cr-to-bottom :cr-drag
-    :cr-activate :cr-arm :cr-disarm (16 :cr-map) :cr-unmap :cr-focus
-    :cr-losing-focus :cr-modifying-text-value :cr-moving-insert-cursor
-    :cr-execute :cr-single-select :cr-multiple-select :cr-extended-select
-    :cr-browse-select :cr-default-action :cr-clipboard-data-request
-    :cr-clipboard-data-delete :cr-cascading :cr-ok :cr-cancel (34 :cr-apply)
-    :cr-no-match :cr-command-entered :cr-command-changed :cr-expose
-    :cr-resize :cr-input :cr-gain-primary :cr-lose-primary :cr-create
-    (6666 :cr-protocols)))
-
-(def-toolkit-enum :default-button-type
-  '(:dialog-none :dialog-apply-button :dialog-cancel-button
-    :dialog-default-button :dialog-ok-button :dialog-filter-label
-    :dialog-filter-text :dialog-help-button
-    (:dialog-list :dialog-history-list :dialog-file-list)
-    (:dialog-list-label :dialog-file-list-label) :dialog-message-label
-    (:dialog-selection-label :dialog-prompt-label) :dialog-symbol-label
-    (:dialog-text :dialog-value-text :dialog-command-text)
-    :dialog-separator :dialog-dir-list :dialog-dir-list-label))
-
-(def-toolkit-enum :dialog-style
-  '((:dialog-modeless :dialog-work-area)
-    (:dialog-primary-application-modal :dialog-application-modal)
-    (:dialog-full-application-modal) (:dialog-system-modal)))
-
-(def-toolkit-enum :dialog-type
-  '(:dialog-work-area
-    (:dialog-error       :dialog-prompt)
-    (:dialog-information :dialog-selection)
-    (:dialog-message     :dialog-command)
-    (:dialog-question    :dialog-file-selection)
-    :dialog-warning :dialog-working))
-
-(def-toolkit-enum :file-type-mask
-  '((1 :file-directory) :file-regular :file-any-type))
-
-(def-toolkit-enum :command-window-location
-  '(:command-above-workspace :command-below-workspace))
-
-(def-toolkit-enum :multi-click '(:multiclick-discard :multiclick-keep))
-
-(def-toolkit-enum :navigation-type
-  '(:none :tab-group :sticky-tab-group :exclusive-tab-group))
-
-(def-toolkit-enum :processing-direction
-  '(:max-on-top :max-on-bottom :max-on-left :max-on-right))
-
-(def-toolkit-enum :list-size-policy '(:variable :constant :resize-if-possible))
-
-(def-toolkit-enum :unit-type
-  '(:pixels :100th-millimeters :1000th-inches :100th-points :100th-font-units))
-
-(def-toolkit-enum :indicator-type '((1 :n-of-many) :one-of-many))
-
-(def-toolkit-enum :selection-policy
-  '(:single-select :multiple-select :extended-select :browse-select))
-
-(def-toolkit-enum :string-direction
-  '(:string-direction-l-to-r :string-direction-r-to-l))
-
-(def-toolkit-enum :scroll-bar-display-policy '(:static :as-needed))
-
-(def-toolkit-enum :scroll-bar-placement
-  '(:bottom-right :top-right :bottom-left :top-left))
-
-(def-toolkit-enum :scrolling-policy '(:automatic :application-defined))
-
-(def-toolkit-enum :visual-policy '(:variable :constant))
-
-(def-toolkit-enum :label-type '((1 :pixmap) :string))
-
-(def-toolkit-enum :packing
-  '(:no-packing :pack-tight :pack-column :pack-none))
-
-(def-toolkit-enum :traversal-direction
-  '(:traverse-current :traverse-next :traverse-next :traverse-prev
-    :traverse-home :traverse-next-tab-group :traverse-prev-tab-group
-    :traverse-up :traverse-down :traverse-left :traverse-right))
-
-(def-toolkit-enum :highlight-mode
-  '(:highlight-normal :highlight-selected :highlight-secondary-selected))
diff --git a/motif/server/GNUmakefile b/motif/server/GNUmakefile
deleted file mode 100644
index 260bf3d5f870b2c2cb4bd4a61add7148ab981ed0..0000000000000000000000000000000000000000
--- a/motif/server/GNUmakefile
+++ /dev/null
@@ -1,33 +0,0 @@
-CC = cc
-#CC = gcc
-
-#
-# Places to look for X and Motif headers
-XHDR  = -I/usr/misc/.X11/include
-XMHDR = -I/usr/misc/.motif/include
-
-#
-# Places to look for X and Motif libraries
-XLIB  = -L/usr/misc/.X11/lib
-XMLIB = -L/usr/misc/.motif/lib
-
-#
-# -G 0 option is for MIPS only
-CFLAGS = -O -G 0 $(XHDR) $(XMHDR)
-LDFLAGS = -G 0 $(XLIB) $(XMLIB)
-LIBS = -lXm -lXt -lX11
-OBJS = main.o server.o translations.o packet.o message.o datatrans.o \
-       requests.o callbacks.o widgets.o resources.o tables.o motif.o \
-       text.o xmstring.o list.o events.o
-TARGET = motifd
-
-
-$(TARGET) : $(OBJS)
-	$(CC) -o $(TARGET) $(LDFLAGS) $(OBJS) $(LIBS)
-	strip $(TARGET)
-
-tables.o : tables.c StringTable.h ClassTable.h TypeTable.h
-	$(CC) $(CFLAGS) -c tables.c
-
-requests.o : requests.c Interface.h
-	$(CC) $(CFLAGS) -c requests.c
diff --git a/motif/server/callbacks.c b/motif/server/callbacks.c
deleted file mode 100644
index d89443e2e19d4df1eebe4ff8e2331bbaa0c91456..0000000000000000000000000000000000000000
--- a/motif/server/callbacks.c
+++ /dev/null
@@ -1,342 +0,0 @@
-#include <stdio.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/StringDefs.h>
-#include <X11/Shell.h>
-
-#include <Xm/Label.h>
-#include <Xm/LabelG.h>
-#include <Xm/ArrowB.h>
-#include <Xm/ArrowBG.h>
-#include <Xm/DrawnB.h>
-#include <Xm/PushB.h>
-#include <Xm/PushBG.h>
-#include <Xm/ToggleB.h>
-#include <Xm/ToggleBG.h>
-#include <Xm/CascadeB.h>
-#include <Xm/CascadeBG.h>
-#include <Xm/MenuShell.h>
-#include <Xm/DrawingA.h>
-#include <Xm/DialogS.h>
-#include <Xm/BulletinB.h>
-#include <Xm/Command.h>
-#include <Xm/FileSB.h>
-#include <Xm/Form.h>
-#include <Xm/MessageB.h>
-#include <Xm/SelectioB.h>
-#include <Xm/ScrollBar.h>
-#include <Xm/Separator.h>
-#include <Xm/SeparatoG.h>
-#include <Xm/Text.h>
-#include <Xm/TextF.h>
-#include <Xm/RowColumn.h>
-#include <Xm/Scale.h>
-#include <Xm/Frame.h>
-#include <Xm/List.h>
-#include <Xm/MainW.h>
-#include <Xm/ScrolledW.h>
-#include <Xm/PanedW.h>
-
-#include "global.h"
-#include "datatrans.h"
-#include "types.h"
-#include "tables.h"
-
-int end_callback_loop = 0;
-extern message_t prepare_reply(message_t m);
-extern void really_write_string(message_t,String,int);
-
-typedef struct protocol_closure {
-  struct protocol_closure *next;
-  Widget widget;
-  Atom property,protocol;
-} ProtocolClosure;
-
-ProtocolClosure *protocol_list = NULL;
-
-XmAnyCallbackStruct *callback_info = NULL;
-
-
-
-int TerminateCallback(message_t message)
-{
-  end_callback_loop--;
-}
-
-
-int RXtAddCallback(message_t message)
-{
-  Widget w;
-  String callback_name;
-  int name_token;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&name_token,ExtRStringToken);
-
-  callback_name = string_table[name_token];
-  XtAddCallback(w,callback_name,CallbackHandler,(caddr_t)name_token);
-}
-
-int RXtRemoveCallback(message_t message)
-{
-  Widget w;
-  int name_token;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&name_token,ExtRStringToken);
-
-  XtRemoveCallback(w,string_table[name_token],
-		   CallbackHandler,(caddr_t)name_token);
-}
-
-int RXmAddProtocolCallback(message_t message)
-{
-  Widget w;
-  Atom prop,protocol;
-  ProtocolClosure *closure;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&prop,XtRAtom);
-  toolkit_read_value(message,&protocol,XtRAtom);
-  closure = XtNew(ProtocolClosure);
-  closure->widget = w;
-  closure->property = prop;
-  closure->protocol = protocol;
-  closure->next = protocol_list;
-  protocol_list = closure;
-  XmAddProtocolCallback(w,prop,protocol,ProtocolHandler,closure);
-}
-
-int RXmRemoveProtocolCallback(message_t message)
-{
-  Widget w;
-  Atom prop,protocol;
-  ProtocolClosure *closure,*current;
-  int found = False;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&prop,XtRAtom);
-  toolkit_read_value(message,&protocol,XtRAtom);
-
-  current = protocol_list;
-  if( current->widget==w && current->property==prop &&
-     current->protocol==protocol ) {
-    protocol_list = current->next;
-    closure = current;
-  }
-  else
-    while( current->next && !found ) {
-      closure = current->next;
-      found = (closure->widget==w && closure->property==prop &&
-	       closure->protocol==protocol);
-      if( found )
-	current->next = closure->next;
-      else
-	current = current->next;
-    }
-
-  if( !found ) XtError("RXmRemoveProtocolCallback:  Unable to find closure.");
-
-  XmRemoveProtocolCallback(w,prop,protocol,ProtocolHandler,closure);
-  XtFree( (char *)closure );
-}
-
-
-int RReturnTextCallbackDoit(message_t message)
-{
-  Boolean doit;
-  XmTextVerifyPtr info = (XmTextVerifyPtr)callback_info;
-
-  toolkit_read_value(message,&doit,XtRBoolean);
-  
-  if( info )
-    info->doit = doit;
-  else
-    XtWarning("RReturnTextCallbackDoit:  No valid callback info exists.");
-}
-
-
-
-void write_button_callback(message_t reply,XmPushButtonCallbackStruct *info)
-{
-  message_write_int(reply,info->click_count,int_tag);
-}
-
-void write_drawing_callback(message_t reply,XmDrawingAreaCallbackStruct *info)
-{
-  message_write_xid(reply,info->window,window_tag);
-}
-
-void write_drawn_button_callback(message_t reply,
-				 XmDrawnButtonCallbackStruct *info)
-{
-  message_write_xid(reply,info->window,window_tag);
-  message_write_int(reply,info->click_count,int_tag);
-}
-
-void write_scrollbar_callback(message_t reply,XmScrollBarCallbackStruct *info)
-{
-  message_write_int(reply,info->value,int_tag);
-  message_write_int(reply,info->pixel,int_tag);
-}
-
-void write_toggle_callback(message_t reply,XmToggleButtonCallbackStruct *info)
-{
-  message_write_boolean(reply,info->set,boolean_tag);
-}
-
-void write_text_callback(message_t reply,XmTextVerifyCallbackStruct *info)
-{
-  message_write_boolean(reply,info->doit,boolean_tag);
-  message_write_int(reply,info->currInsert,int_tag);
-  message_write_int(reply,info->newInsert,int_tag);
-
-  if( info->reason == XmCR_LOSING_FOCUS ) {
-    message_write_int(reply,info->startPos,int_tag);
-    message_write_int(reply,info->endPos,int_tag);
-  } else if( info->reason == XmCR_MODIFYING_TEXT_VALUE ) {
-    message_write_int(reply,info->startPos,int_tag);
-    message_write_int(reply,info->endPos,int_tag);
-    really_write_string(reply,info->text->ptr,info->text->length+1);
-    /* ***** Perhaps this should be an enumerated type ***** */
-    message_write_int(reply,info->text->format,int_tag);
-    printf("modifying_text_value: %s ; length=%d\n",info->text->ptr,
-	   info->text->length);
-  }
-}
-
-void write_list_callback(message_t reply,XmListCallbackStruct *info)
-{
-  StringTable item_table;
-  IntList pos_table;
-
-  message_write_xm_string(reply,info->item,xm_string_tag);
-  message_write_int(reply,info->item_position,int_tag);
-
-  if(info->reason==XmCR_MULTIPLE_SELECT || info->reason==XmCR_EXTENDED_SELECT){
-    item_table.data = (char **)info->selected_items;
-    item_table.length = info->selected_item_count;
-    message_write_xm_string_table(reply,&item_table,xm_string_table_tag);
-
-    pos_table.data = info->selected_item_positions;
-    pos_table.length = info->selected_item_count;
-    message_write_int_list(reply,&pos_table,int_list_tag);
-    message_write_int(reply,info->selection_type,int_tag);
-  }
-}
-
-void write_selection_callback(message_t reply, XmCommandCallbackStruct *info)
-{
-  message_write_xm_string(reply,info->value,xm_string_tag);
-}
-
-void write_fileselection_callback(message_t reply,
-				  XmFileSelectionBoxCallbackStruct *info)
-{
-  message_write_xm_string(reply,info->value,xm_string_tag);
-  message_write_xm_string(reply,info->mask,xm_string_tag);
-  message_write_xm_string(reply,info->dir,xm_string_tag);
-  message_write_xm_string(reply,info->pattern,xm_string_tag);
-}
-
-void write_scale_callback(message_t reply,XmScaleCallbackStruct *info)
-{
-  message_write_int(reply,info->value,int_tag);
-}
-
-void CallbackHandler(Widget *w, int name_token, XmAnyCallbackStruct *info)
-{
-  WidgetClass class = XtClass(*w);
-  int exit_value;
-  XEvent event;
-  message_t reply = message_new(next_serial++);
-  message_add_packet(reply);
-
-  callback_info = info;
-
-  message_put_dblword(reply,CALLBACK_REPLY);
-  message_write_widget(reply,*w,widget_tag);
-  message_write_string_token(reply,name_token,string_token_tag);
-  
-  /* Now, we write the Reason structure into the message */
-  message_write_enum(reply,info->reason,callback_reason_tag);
-  message_write_int(reply,info->event,int_tag);
-
-  if( class==xmArrowButtonWidgetClass || class==xmArrowButtonGadgetClass ||
-     class==xmPushButtonWidgetClass || class==xmPushButtonGadgetClass )
-    write_button_callback(reply,(XmPushButtonCallbackStruct *)info);
-  else if( class==xmDrawingAreaWidgetClass )
-    write_drawing_callback(reply,(XmDrawingAreaCallbackStruct *)info);
-  else if( class==xmDrawnButtonWidgetClass )
-    write_drawn_button_callback(reply,(XmDrawnButtonCallbackStruct *)info);
-  else if( class==xmScrollBarWidgetClass )
-    write_scrollbar_callback(reply,(XmScrollBarCallbackStruct *)info);
-  else if( class==xmToggleButtonWidgetClass ||
-	   class==xmToggleButtonGadgetClass )
-    write_toggle_callback(reply,(XmToggleButtonCallbackStruct *)info);
-  else if( class==xmListWidgetClass )
-    write_list_callback(reply,(XmListCallbackStruct *)info);
-  else if( class==xmSelectionBoxWidgetClass || class==xmCommandWidgetClass )
-    write_selection_callback(reply,(XmCommandCallbackStruct *)info);
-  else if( class==xmFileSelectionBoxWidgetClass )
-    write_fileselection_callback(reply,
-				 (XmFileSelectionBoxCallbackStruct *)info);
-  else if( class==xmScaleWidgetClass )
-    write_scale_callback(reply,(XmScaleCallbackStruct *)info);
-  else if( class==xmTextWidgetClass || class==xmTextFieldWidgetClass )
-    if( info->reason==XmCR_LOSING_FOCUS ||
-        info->reason==XmCR_MODIFYING_TEXT_VALUE ||
-        info->reason==XmCR_MOVING_INSERT_CURSOR )
-      write_text_callback(reply,(XmTextVerifyCallbackStruct *)info);
-
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  exit_value = end_callback_loop++;
-
-/* *** This version handles no events until callbacks are done processing */
-  while( exit_value<end_callback_loop )
-    XtAppProcessEvent(app_context,XtIMAlternateInput);
-
-/* *** Use this version to allow callbacks to occur during callback processing
-   *** In general, this is not something the you want to do.  For instance,
-   *** the callback_info mechanism for supporting modifications to the
-   *** callback structure would no longer work if callbacks could be nested.
-  while( exit_value<end_callback_loop ) {
-    XtAppNextEvent(app_context, &event);
-    XtDispatchEvent(&event);
-  }
-*/
-
-  callback_info = NULL;
-}
-
-
-
-void ProtocolHandler(Widget *w, ProtocolClosure *c, XmAnyCallbackStruct *info)
-{
-  int exit_value;
-  XEvent event;
-  message_t reply = message_new(next_serial++);
-  message_add_packet(reply);
-
-  message_put_dblword(reply,PROTOCOL_REPLY);
-  message_write_widget(reply,*w,widget_tag);
-  message_write_atom(reply,c->property,atom_tag);
-  message_write_atom(reply,c->protocol,atom_tag);
-  message_write_int(reply,info->event,int_tag);
-
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  exit_value = end_callback_loop++;
-  while( exit_value<end_callback_loop )
-    XtAppProcessEvent(app_context,XtIMAlternateInput);
-
-  /* **** The non-blocking version
-  while( exit_value<end_callback_loop ) {
-    XtAppNextEvent(app_context, &event);
-    XtDispatchEvent(&event);
-  }
-  */
-}
diff --git a/motif/server/datatrans.c b/motif/server/datatrans.c
deleted file mode 100644
index 796f431afbb14efaf8bb712f5556e23eae03b3d0..0000000000000000000000000000000000000000
--- a/motif/server/datatrans.c
+++ /dev/null
@@ -1,476 +0,0 @@
-#include <stdio.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/StringDefs.h>
-#include <Xm/Xm.h>
-
-#include "global.h"
-#include "types.h"
-#include "datatrans.h"
-#include "tables.h"
-
-void packet_write_string(packet_t packet,String string,int count)
-{
-  strncpy(packet->fill,string,count);
-  packet->fill += count;
-  packet->length += count;
-}
-
-void message_write_string_token(message_t message,int token,int tag)
-{
-  message_put_dblword(message,combine_type_and_data(tag,token));
-}
-
-void really_write_string(message_t message,String string,int length)
-{
-  int pad,i;
-  packet_t packet;
-
-  message_put_dblword(message,combine_type_and_data(string_tag,length));
-  packet = message->packets;
-  if( length+packet->length < PACKET_SIZE )
-    packet_write_string(packet,string,length);
-  else if( length < (PACKET_SIZE-HEADER_LENGTH) ) {
-    message_add_packet(message);
-    packet_write_string(message->packets,string,length);
-  }
-  else
-    fatal_error("really_write_string:  Attempt to send huge string.");
-  /* Add in the padding bytes at the end of the string */
-  pad = (4-((packet->fill-packet->data)%4))%4;
-  for(i=0;i<pad;i++)
-    packet_put_byte(packet,0);
-}
-
-
-void message_write_string(message_t message,String string,int type_tag)
-{
-  long token = tokenize_string(string);
-
-  if( token >= 0 )
-    message_put_dblword(message,combine_type_and_data(string_token_tag,token));
-  else
-    really_write_string(message,string,strlen(string)+1);
-}
-
-void message_write_short(message_t message,int value,int type_tag)
-{
-  message_put_dblword(message,combine_type_and_data(type_tag,value));
-}
-
-void message_write_boolean(message_t message,int value,int type_tag)
-{
-  message_put_dblword(message,combine_type_and_data(type_tag,value));
-}
-
-void message_write_int(message_t message,int value,int type_tag)
-{
-  message_put_dblword(message,combine_type_and_data(type_tag,0));
-  message_put_dblword(message,value);
-}
-
-void message_write_function(message_t message, int value,int type_tag)
-{
-  message_put_dblword(message,combine_type_and_data(type_tag,value));
-}
-
-void message_write_widget(message_t message,Widget widget,int type_tag)
-{
-  message_put_dblword(message,combine_type_and_data(type_tag,0));
-  message_put_dblword(message,(long)widget);
-}
-
-void message_write_widget_class(message_t message,WidgetClass class,int tag)
-{
-  int i=0;
-
-  do {
-    if( *class_table[i] == class ) {
-      message_put_dblword(message,combine_type_and_data(tag,i));
-      return;
-    }
-  } while( class_table[++i] );
-
-  fatal_error("message_write_widget_class:  Unknown widget class.");
-}
-
-void message_write_xid(message_t message,XID value,int tag)
-{
-  message_put_dblword(message,combine_type_and_data(tag,0));
-  message_put_dblword(message,value);
-}
-
-void message_write_atom(message_t message,Atom value,int tag)
-{
-  message_put_dblword(message,combine_type_and_data(tag,0));
-  message_put_dblword(message,value);
-}
-
-void message_write_enum(message_t message,int enumval,int tag)
-{
-  message_put_dblword(message,combine_type_and_data(tag,enumval));
-}
-
-void warn_bogus_resource(String name)
-{
-  char buf[128];
-
-  sprintf(buf,"Unknown resource: %s",name);
-  XtWarning(buf);
-}
-
-void message_write_resource_list(message_t message,ResourceList *list,int tag)
-{
-  String type;
-  int i,classid = find_widget_class_id(list->class);
-
-  message_put_dblword(message,combine_type_and_data(tag,list->length));
-  /* Note:  We will only write the values, not the names */
-  for(i=0;i<list->length;i++) {
-    type = query_resource_type(classid,list->parent,list->args[i].name);
-
-    if( !type ) {
-      warn_bogus_resource(list->args[i].name);
-      message_write_boolean(message,0,boolean_tag);  /* Sends nil */
-    }
-    else {
-      toolkit_write_value(message,*((long *)(list->args[i].value)),type);
-      if( !strcmp(type,XmRXmString) )
-	/* All XmString's returned as resource values are garbage */
-	register_garbage(*((XmString *)(list->args[i].value)),GarbageXmString);
-    }
-  }
-}
-
-void message_write_int_list(message_t message,IntList *list,int tag)
-{
-  int i;
-
-  message_put_dblword(message,combine_type_and_data(tag,list->length));
-  for(i=0;i<list->length;i++)
-    message_write_int(message,list->data[i],int_tag);
-}
-
-void message_write_widget_list(message_t message,MyWidgetList *list,int tag)
-{
-  fprintf(stderr,">>>>> Warning:write_widget_list:We shouldn't be here!\n");
-}
-
-void message_write_resource_names(message_t message,ResourceList *list,int tag)
-{
-  fprintf(stderr,">>>>> Warning:write_resource_names:We shouldn't be here!\n");
-}
-
-void message_write_xm_string(message_t message,XmString xs,int tag)
-{
-  message_put_dblword(message,combine_type_and_data(tag,0));
-  message_put_dblword(message,(long)xs);
-}
-
-void message_write_translation_table(message_t m,XtTranslations t,int tag)
-{
-  message_put_dblword(m,combine_type_and_data(tag,0));
-  message_put_dblword(m,(unsigned long)t);
-}
-
-void message_write_accelerator_table(message_t m,XtAccelerators a,int tag)
-{
-  message_put_dblword(m,combine_type_and_data(tag,0));
-  message_put_dblword(m,(unsigned long)a);
-}
-
-void message_write_font_list(message_t m,XmFontList flist,int tag)
-{
-  message_put_dblword(m,combine_type_and_data(tag,0));
-  message_put_dblword(m,(unsigned long)flist);
-}
-
-void message_write_string_table(message_t m,StringTable *items,int tag)
-{
-  int i;
-
-  message_put_dblword(m,combine_type_and_data(tag,items->length));
-  for(i=0;i<items->length;i++)
-    message_write_string(m,items->data[i],string_tag);
-}
-
-void message_write_xm_string_table(message_t m,StringTable *items,int tag)
-{
-  int i;
-
-  message_put_dblword(m,combine_type_and_data(tag,items->length));
-  for(i=0;i<items->length;i++)
-    message_write_xm_string(m,(XmString)items->data[i],xm_string_tag);
-}
-
-void message_write_color(message_t m,XColor *color,int tag)
-{
-  message_put_dblword(m,combine_type_and_data(tag,color->red));
-  message_put_word(m,color->green);
-  message_put_word(m,color->blue);
-}
-
-void message_write_float(message_t m,float f,int tag)
-{
-  message_put_dblword(m,combine_type_and_data(tag,0));
-  message_put_dblword(m,f);
-}
-
-
-
-void message_read_widget(message_t message,Widget *w,int tag,int data)
-{
-  *w = (Widget)message_get_dblword(message);
-}
-
-void message_read_widget_class(message_t message,WidgetClass *c,
-			       int tag,int data)
-{
-  *c = *(class_table[data]);
-}
-
-void message_read_function(message_t message,int *f,int tag,int data)
-{
-  *f = data;
-}
-
-String really_read_string(message_t message,int length)
-{
-  int pad,i;
-  packet_t packet=message->packets;
-  String string;
-
-  /* Check to see if the string is in this packet or not */
-  if( length > packet->length-(packet->fill-packet->data) )
-    packet = message->packets = packet->next;
-
-  /***** We will IGNORE strings spanning packets for now *******/
-  string = packet->fill;
-  for(i=0;i<length;i++) packet->fill++;
-  /*
-   * This is a pretty gross way of finding out how many padding bytes
-   * there should be.  The outermost %4 should perhaps be replaced with
-   * an if(pad<4) around the for loop.
-   */
-  pad = (4-((packet->fill-packet->data)%4))%4;
-  for(i=0;i<pad;i++)
-    packet_get_byte(packet);
-
-  return string;
-}
-
-void message_read_string_token(message_t message,int *t,int tag,int data)
-{
-  *t = data;
-}
-
-void message_read_string(message_t message,String *s,int tag,int data)
-{
-  if( tag == string_token_tag )
-    *s = string_table[data];
-  else 
-    *s = really_read_string(message,data);
-}
-
-void message_read_xm_string(message_t message,XmString *xs,int tag,int data)
-{
-  String tmp;
-  XmString xmstring;
-
-  if( tag == string_tag ) {
-    tmp = really_read_string(message,data);
-    xmstring = XmStringCreateLtoR(tmp,XmSTRING_DEFAULT_CHARSET);
-    if( !xmstring )
-      fatal_error("message_read_xm_string:  Failed to convert string.");
-    *xs = xmstring;
-    register_garbage(xmstring,GarbageXmString);
-  }
-  else
-    *xs = (XmString)message_get_dblword(message);
-}
-
-void message_read_boolean(message_t message,int *val,int tag,int data)
-{
-  *val = data;
-}
-
-void message_read_int(message_t message,int *i,int tag,int data)
-{
-  *i = message_get_dblword(message);
-}
-
-void message_read_short(message_t message,int *i,int tag,int data)
-{
-  *i = data;
-}
-
-void message_read_xid(message_t message,XID *id,int tag,int data)
-{
-  *id = message_get_dblword(message);
-}
-
-void message_read_atom(message_t message,Atom *a,int tag,int data)
-{
-  *a = message_get_dblword(message);
-}
-
-void message_read_enum(message_t message,int *enumval,int tag,int data)
-{
-  *enumval = data;
-}
-
-void message_read_resource_names(message_t message,ResourceList *list,
-				 int tag,int length)
-{
-  int i,classid=find_widget_class_id(list->class);
-  String type;
-  long *data;
-
-  list->length = length;
-  if( length>0 ) {
-    list->args = (ArgList)XtMalloc(length*sizeof(Arg));
-    /* Allocate region to store data into */
-    data = (long *)XtMalloc( sizeof(long)*length );
-    bzero(data,sizeof(long)*length);
-    register_garbage(data,GarbageData);
-
-    for(i=0;i<length;i++) {
-      toolkit_read_value(message,&list->args[i].name,XtRString);
-      list->args[i].value = (long)&data[i];
-    }
-  } else list->args = NULL;
-}
-
-
-void message_read_resource_list(message_t message,ResourceList *list,
-				int tag,int length)
-{
-  int i,classid;
-  String name,type;
-
-  length /= 2;
-  list->length = length;
-
-  classid = find_widget_class_id(list->class);
-  if( length > 0 ) {
-    list->args = (ArgList)XtMalloc(length*sizeof(Arg));
-    register_garbage(list->args,GarbageData);
-    for(i=0;i<length;i++) {
-      toolkit_read_value(message,&name,XtRString);
-      type = query_resource_type(classid,list->parent,name);
-      if( !type )
-	warn_bogus_resource(name);
-      toolkit_read_value(message,&(list->args[i].value),type);
-      list->args[i].name = name;
-
-    }
-  } else list->args = NULL;
-}
-
-void message_read_widget_list(message_t message,MyWidgetList *list,
-			      int tag,int length)
-{
-  int i;
-
-  list->length = length;
-  if( length>0 ) {
-    list->widgets = (WidgetList)XtMalloc(length*sizeof(Widget));
-    register_garbage(list->widgets,GarbageData);
-    for(i=0;i<length;i++)
-      toolkit_read_value(message,&(list->widgets[i]),XtRWidget);
-  } else list->widgets = NULL;
-}
-
-void message_read_int_list(message_t message,IntList *list,int tag,int length)
-{
-  fprintf(stderr,">>>>> Warning:message_read_int_list: Shouldn't be here.\n");
-}
-
-void message_read_translation_table(message_t m,XtTranslations *t,
-				    int tag,int data)
-{
-  *t = (XtTranslations)message_get_dblword(m);
-}
-
-void message_read_accelerator_table(message_t m,XtAccelerators *a,
-				    int tag,int data)
-{
-  *a = (XtAccelerators)message_get_dblword(m);
-}
-
-void message_read_font_list(message_t m,XmFontList *flist,int tag,int data)
-{
-  *flist = (XmFontList)message_get_dblword(m);
-}
-
-void message_read_string_table(message_t m,StringTable *items,int tag,int len)
-{
-  int i;
-
-  items->length = len;
-  items->data = (char **)XtMalloc( len*sizeof(char *) );
-  register_garbage(items->data,GarbageData);
-  for(i=0;i<len;i++)
-    toolkit_read_value(m,&(items->data[i]),XtRString);
-}
-
-void message_read_xm_string_table(message_t m,StringTable *items,
-				  int tag,int len)
-{
-  int i;
-
-  items->length = len;
-  items->data = (char **)XtMalloc( len*sizeof(char *) );
-  register_garbage(items->data,GarbageData);
-  for(i=0;i<len;i++)
-    toolkit_read_value(m,&(items->data[i]),XmRXmString);
-}
-
-void message_read_color(message_t m,XColor *color,int tag, int red)
-{
-  color->red = red;
-  color->green = message_get_word(m);
-  color->blue = message_get_word(m);
-}
-
-void message_read_float(message_t m,float *f,int tag,int data)
-{
-  fprintf(stderr,">>>>> Warning:message_read_float: Not implemented.\n");
-}
-
-
-
-void toolkit_write_value(message_t message, caddr_t value, String type)
-{
-  long type_tag;
-  type_writer write_value;
-
-  type_tag = find_type_entry(type);
-  if( type_tag < 0 ) {
-    fprintf(stderr,"Choked on type %s\n",type);
-    fatal_error("Illegal type specified.");
-  }
-    
-  write_value = type_table[type_tag].writer;
-
-  (*write_value)(message,value,type_tag);
-}
-
-void toolkit_read_value(message_t message,char *dest,String type)
-{
-  int tag,data,stuff;
-  type_reader read_value;
-
-  data = message_get_dblword(message);
-  tag = data >> 24;
-  data &= 0x00ffffff;
-
-  read_value = type_table[tag].reader;
-  if((tag == string_tag || tag == string_token_tag) &&
-     !strcmp(type,XmRXmString))
-    read_value = (type_reader)message_read_xm_string;
-  else if( tag == string_token_tag && !strcmp(type,XtRString) )
-    read_value = (type_reader)message_read_string;
-
-  (*read_value)(message,dest,tag,data);
-}
diff --git a/motif/server/datatrans.h b/motif/server/datatrans.h
deleted file mode 100644
index 6d55ef486d606a733cd93017937b9b49bb5ff9fc..0000000000000000000000000000000000000000
--- a/motif/server/datatrans.h
+++ /dev/null
@@ -1,66 +0,0 @@
-#ifndef DATATRANS_H
-#define DATATRANS_H
-
-#include "message.h"
-
-#define combine_type_and_data(type,data) ((type<<24)|data)
-
-extern void message_write_string();
-extern void message_write_widget();
-extern void message_write_widget_class();
-extern void message_write_function();
-extern void message_write_short();
-extern void message_write_boolean();
-extern void message_write_int();
-extern void message_write_xid();
-extern void message_write_atom();
-extern void message_write_string_token();
-extern void message_write_resource_list();
-extern void message_write_xm_string();
-extern void message_write_enum();
-extern void message_write_resource_names();
-extern void message_write_widget_list();
-extern void message_write_translation_table();
-extern void message_write_accelerator_table();
-extern void message_write_font_list();
-extern void message_write_string_table();
-extern void message_write_xm_string_table();
-extern void message_write_int_list();
-#define message_write_event message_write_int
-extern void message_write_color();
-/* GCC complains without the full prototype */
-extern void message_write_float(message_t,float,int);
-
-
-
-extern void message_read_string();
-extern void message_read_widget();
-extern void message_read_widget_class();
-extern void message_read_function();
-extern void message_read_int();
-extern void message_read_short();
-extern void message_read_boolean();
-extern void message_read_xid();
-extern void message_read_atom();
-extern void message_read_string_token();
-extern void message_read_resource_list();
-extern void message_read_xm_string();
-extern void message_read_enum();
-extern void message_read_resource_names();
-extern void message_read_widget_list();
-extern void message_read_translation_table();
-extern void message_read_accelerator_table();
-extern void message_read_font_list();
-extern void message_read_string_table();
-extern void message_read_xm_string_table();
-extern void message_read_int_list();
-#define message_read_event message_read_int
-extern void message_read_color();
-extern void message_read_float();
-
-
-
-extern void toolkit_write_value();
-extern void toolkit_read_value();
-
-#endif
diff --git a/motif/server/events.c b/motif/server/events.c
deleted file mode 100644
index eb08a103e88cf5a283e32ed3aa3fbfe14c564747..0000000000000000000000000000000000000000
--- a/motif/server/events.c
+++ /dev/null
@@ -1,451 +0,0 @@
-#include <stdio.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/StringDefs.h>
-#include <Xm/Xm.h>
-
-#include "global.h"
-#include "datatrans.h"
-#include "types.h"
-#include "tables.h"
-#include "requests.h"
-
-extern int end_callback_loop;
-
-void write_any_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,combine_type_and_data(event_tag,0));
-  message_put_dblword(reply,(unsigned long)event);
-  message_put_dblword(reply,event->xany.type);
-  message_put_dblword(reply,event->xany.serial);
-  message_put_dblword(reply,event->xany.send_event);
-  message_put_dblword(reply,event->xany.window);
-}
-
-void write_key_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xkey.root);
-  message_put_dblword(reply,event->xkey.subwindow);
-  message_put_dblword(reply,event->xkey.time);
-  message_put_dblword(reply,event->xkey.x);
-  message_put_dblword(reply,event->xkey.y);
-  message_put_dblword(reply,event->xkey.x_root);
-  message_put_dblword(reply,event->xkey.y_root);
-  message_put_dblword(reply,event->xkey.state);
-  message_put_dblword(reply,event->xkey.keycode);
-  message_put_dblword(reply,event->xkey.same_screen);
-}
-
-void write_button_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xbutton.root);
-  message_put_dblword(reply,event->xbutton.subwindow);
-  message_put_dblword(reply,event->xbutton.time);
-  message_put_dblword(reply,event->xbutton.x);
-  message_put_dblword(reply,event->xbutton.y);
-  message_put_dblword(reply,event->xbutton.x_root);
-  message_put_dblword(reply,event->xbutton.y_root);
-  message_put_dblword(reply,event->xbutton.state);
-  message_put_dblword(reply,event->xbutton.button);
-  message_put_dblword(reply,event->xbutton.same_screen);
-}
-
-void write_motion_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xmotion.root);
-  message_put_dblword(reply,event->xmotion.subwindow);
-  message_put_dblword(reply,event->xmotion.time);
-  message_put_dblword(reply,event->xmotion.x);
-  message_put_dblword(reply,event->xmotion.y);
-  message_put_dblword(reply,event->xmotion.x_root);
-  message_put_dblword(reply,event->xmotion.y_root);
-  message_put_dblword(reply,event->xmotion.state);
-  message_put_byte(reply,event->xmotion.is_hint);
-  message_put_dblword(reply,event->xmotion.same_screen);
-}
-
-void write_crossing_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xcrossing.root);
-  message_put_dblword(reply,event->xcrossing.subwindow);
-  message_put_dblword(reply,event->xcrossing.time);
-  message_put_dblword(reply,event->xcrossing.x);
-  message_put_dblword(reply,event->xcrossing.y);
-  message_put_dblword(reply,event->xcrossing.x_root);
-  message_put_dblword(reply,event->xcrossing.y_root);
-  message_put_dblword(reply,event->xcrossing.mode);
-  message_put_dblword(reply,event->xcrossing.detail);
-  message_put_dblword(reply,event->xcrossing.same_screen);
-  message_put_dblword(reply,event->xcrossing.focus);
-  message_put_dblword(reply,event->xcrossing.state);
-}
-
-void write_focus_change_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xfocus.mode);
-  message_put_dblword(reply,event->xfocus.detail);
-}
-
-void write_keymap_event(message_t reply,XEvent *event)
-{
-  int i;
-
-  for(i=0;i<32;i++)
-    message_put_byte(reply,event->xkeymap.key_vector[i]);
-}
-
-void write_expose_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xexpose.x);
-  message_put_dblword(reply,event->xexpose.y);
-  message_put_dblword(reply,event->xexpose.width);
-  message_put_dblword(reply,event->xexpose.height);
-  message_put_dblword(reply,event->xexpose.count);
-}
-
-void write_graphics_expose_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xgraphicsexpose.x);
-  message_put_dblword(reply,event->xgraphicsexpose.y);
-  message_put_dblword(reply,event->xgraphicsexpose.width);
-  message_put_dblword(reply,event->xgraphicsexpose.height);
-  message_put_dblword(reply,event->xgraphicsexpose.count);
-  message_put_dblword(reply,event->xgraphicsexpose.major_code);
-  message_put_dblword(reply,event->xgraphicsexpose.minor_code);
-}
-
-void write_no_expose_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xnoexpose.major_code);
-  message_put_dblword(reply,event->xnoexpose.minor_code);
-}
-
-void write_visibility_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xvisibility.state);
-}
-
-void write_create_window_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xcreatewindow.window);
-  message_put_dblword(reply,event->xcreatewindow.x);
-  message_put_dblword(reply,event->xcreatewindow.y);
-  message_put_dblword(reply,event->xcreatewindow.width);
-  message_put_dblword(reply,event->xcreatewindow.height);
-  message_put_dblword(reply,event->xcreatewindow.override_redirect);
-}
-
-void write_destroy_window_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xdestroywindow.window);
-}
-
-void write_unmap_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xunmap.window);
-  message_put_dblword(reply,event->xunmap.from_configure);
-}
-
-void write_map_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xmap.window);
-  message_put_dblword(reply,event->xmap.override_redirect);
-}
-
-void write_map_request_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xmaprequest.window);
-}
-
-void write_reparent_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xreparent.parent);
-  message_put_dblword(reply,event->xreparent.x);
-  message_put_dblword(reply,event->xreparent.y);
-  message_put_dblword(reply,event->xreparent.override_redirect);
-}
-
-void write_configure_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xconfigure.window);
-  message_put_dblword(reply,event->xconfigure.x);
-  message_put_dblword(reply,event->xconfigure.y);
-  message_put_dblword(reply,event->xconfigure.width);
-  message_put_dblword(reply,event->xconfigure.height);
-  message_put_dblword(reply,event->xconfigure.border_width);
-  message_put_dblword(reply,event->xconfigure.above);
-  message_put_dblword(reply,event->xconfigure.override_redirect);
-}
-
-void write_gravity_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xgravity.window);
-  message_put_dblword(reply,event->xgravity.x);
-  message_put_dblword(reply,event->xgravity.y);
-}
-
-void write_resize_request_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xresizerequest.width);
-  message_put_dblword(reply,event->xresizerequest.height);
-}
-
-void write_configure_request_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xconfigurerequest.window);
-  message_put_dblword(reply,event->xconfigurerequest.x);
-  message_put_dblword(reply,event->xconfigurerequest.y);
-  message_put_dblword(reply,event->xconfigurerequest.width);
-  message_put_dblword(reply,event->xconfigurerequest.height);
-  message_put_dblword(reply,event->xconfigurerequest.border_width);
-  message_put_dblword(reply,event->xconfigurerequest.above);
-  message_put_dblword(reply,event->xconfigurerequest.detail);
-  message_put_dblword(reply,event->xconfigurerequest.value_mask);
-}
-
-void write_circulate_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xcirculate.window);
-  message_put_dblword(reply,event->xcirculate.place);
-}
-
-void write_circulate_request_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xcirculaterequest.window);
-  message_put_dblword(reply,event->xcirculaterequest.place);
-}
-
-void write_property_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xproperty.atom);
-  message_put_dblword(reply,event->xproperty.time);
-  message_put_dblword(reply,event->xproperty.state);
-}
-
-void write_selection_clear_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xselectionclear.selection);
-  message_put_dblword(reply,event->xselectionclear.time);
-}
-
-void write_selection_request_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xselectionrequest.requestor);
-  message_put_dblword(reply,event->xselectionrequest.selection);
-  message_put_dblword(reply,event->xselectionrequest.target);
-  message_put_dblword(reply,event->xselectionrequest.property);
-  message_put_dblword(reply,event->xselectionrequest.time);
-}
-
-void write_selection_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xselection.selection);
-  message_put_dblword(reply,event->xselection.target);
-  message_put_dblword(reply,event->xselection.property);
-  message_put_dblword(reply,event->xselection.time);
-}
-
-void write_colormap_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xcolormap.colormap);
-  message_put_dblword(reply,event->xcolormap.new);
-  message_put_dblword(reply,event->xcolormap.state);
-}
-
-/* ***** Client message transport goes here */
-
-void write_mapping_event(message_t reply,XEvent *event)
-{
-  message_put_dblword(reply,event->xmapping.request);
-  message_put_dblword(reply,event->xmapping.first_keycode);
-  message_put_dblword(reply,event->xmapping.count);
-}
-
-
-
-/* Function that writes XEvent structures into messages for transport
-   to the client Lisp */
-
-void write_event(message_t reply,XEvent *event)
-{
-  write_any_event(reply,event);
-
-  switch( event->type ) {
-  case ButtonPress:
-  case ButtonRelease:
-    write_button_event(reply,event);
-    break;
-  case Expose:
-    write_expose_event(reply,event);
-    break;
-  case KeyPress:
-  case KeyRelease:
-    write_key_event(reply,event);
-    break;
-  case MotionNotify:
-    write_motion_event(reply,event);
-    break;
-  case ColormapNotify:
-    write_colormap_event(reply,event);
-    break;
-  case EnterNotify:
-  case LeaveNotify:
-    write_crossing_event(reply,event);
-    break;
-  case GraphicsExpose:
-    write_graphics_expose_event(reply,event);
-    break;
-  case NoExpose:
-    write_no_expose_event(reply,event);
-    break;
-  case FocusIn:
-  case FocusOut:
-    write_focus_change_event(reply,event);
-    break;
-  case KeymapNotify:
-    write_keymap_event(reply,event);
-    break;
-  case PropertyNotify:
-    write_property_event(reply,event);
-    break;
-  case ResizeRequest:
-    write_resize_request_event(reply,event);
-    break;
-  case CirculateNotify:
-    write_circulate_event(reply,event);
-    break;
-  case ConfigureNotify:
-    write_configure_event(reply,event);
-    break;
-  case DestroyNotify:
-    write_destroy_window_event(reply,event);
-    break;
-  case GravityNotify:
-    write_gravity_event(reply,event);
-    break;
-  case MapNotify:
-    write_map_event(reply,event);
-    break;
-  case ReparentNotify:
-    write_reparent_event(reply,event);
-    break;
-  case UnmapNotify:
-    write_unmap_event(reply,event);
-    break;
-  case CreateNotify:
-    write_create_window_event(reply,event);
-    break;
-  case CirculateRequest:
-    write_circulate_request_event(reply,event);
-    break;
-  case ConfigureRequest:
-    write_configure_request_event(reply,event);
-    break;
-  case MapRequest:
-    write_map_request_event(reply,event);
-    break;
-/*case ClientMessage: */
-  case MappingNotify:
-    write_mapping_event(reply,event);
-    break;
-  case SelectionClear:
-    write_selection_clear_event(reply,event);
-    break;
-  case SelectionNotify:
-    write_selection_event(reply,event);
-    break;
-  case SelectionRequest:
-    write_selection_request_event(reply,event);
-    break;
-  case VisibilityNotify:
-    write_visibility_event(reply,event);
-    break;
-  default:
-    printf("Unknown event type %d\n",event->type);
-    break;
-  }
-}
-
-
-
-int RTransportEvent(message_t message)
-{
-  XEvent *event;
-  message_t reply = prepare_reply(message);
-
-  toolkit_read_value(message,&event,XtRInt);
-
-  write_event(reply,event);
-
-  message_send(client_socket,reply);
-  must_confirm=False;
-  message_free(reply);
-}
-
-
-
-int RXtAddEventHandler(message_t message)
-{
-  Widget widget;
-  int mask,non_maskable;
-  XtEventHandler f;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  toolkit_read_value(message,&mask,XtRInt);
-  toolkit_read_value(message,&non_maskable,XtRInt);
-
-  if( non_maskable )
-    f = NonMaskableHandler;
-  else
-    f = EventHandler;
-
-  XtAddEventHandler(widget,mask,non_maskable,f,mask);
-}
-
-int RXtRemoveEventHandler(message_t message)
-{
-  Widget widget;
-  int mask,non_maskable;
-  XtEventHandler f;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  toolkit_read_value(message,&mask,XtRInt);
-  toolkit_read_value(message,&non_maskable,XtRInt);
-
-  if( non_maskable )
-    f = NonMaskableHandler;
-  else
-    f = EventHandler;
-
-  XtRemoveEventHandler(widget,mask,non_maskable,f,mask);
-}
-
-void CoreEventHandler(Widget widget,int mask,int nonmaskable,XEvent *event)
-{
-  int exit_value;
-  message_t reply = message_new(next_serial++);
-
-  message_add_packet(reply);
-  message_put_dblword(reply,EVENT_REPLY);
-  message_write_widget(reply,widget,widget_tag);
-  message_write_int(reply,mask,int_tag);
-  message_write_boolean(reply,nonmaskable,boolean_tag);
-  write_event(reply,event);
-
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  exit_value = end_callback_loop++;
-  while( exit_value<end_callback_loop )
-    XtAppProcessEvent(app_context,XtIMAlternateInput);
-}
-
-void EventHandler(Widget widget,int mask,XEvent *event)
-{
-  CoreEventHandler(widget,mask,False,event);
-}
-
-void NonMaskableHandler(Widget widget,int mask,XEvent *event)
-{
-  CoreEventHandler(widget,mask,True,event);
-}
diff --git a/motif/server/functions.h b/motif/server/functions.h
deleted file mode 100644
index 438b5d5ddac2d2d43bbbd959ea711978dcb9c0bb..0000000000000000000000000000000000000000
--- a/motif/server/functions.h
+++ /dev/null
@@ -1,178 +0,0 @@
-/* In requests.c */
-extern QuitServer();
-
-/* in callbacks.c */
-extern TerminateCallback();
-extern RXtAddCallback();
-extern RXtRemoveCallback();
-extern RXmAddProtocolCallback();
-extern RXmRemoveProtocolCallback();
-extern RReturnTextCallbackDoit();
-
-/* in events.c */
-extern RTransportEvent();
-extern RXtAddEventHandler();
-extern RXtRemoveEventHandler();
-
-/* in widgets.c */
-extern RXtAppCreateShell();
-extern RXtCreateManagedWidget();
-extern RXtCreateWidget();
-extern RXtDestroyWidget();
-extern RXtRealizeWidget();
-extern RXtUnrealizeWidget();
-extern RXtMapWidget();
-extern RXtUnmapWidget();
-extern RXtSetSensitive();
-extern RXtCreatePopupShell();
-extern RXtPopup();
-extern RXtManageChild();
-extern RXtUnmanageChild();
-extern RXtManageChildren();
-extern RXtUnmanageChildren();
-extern RXtPopdown();
-extern RXtIsManaged();
-extern RXtPopupSpringLoaded();
-extern RXtIsRealized();
-extern RXtWindow();
-extern RXtName();
-extern RXtIsSensitive();
-extern RXtTranslateCoords();
-extern RXmCreateMenuBar();
-extern RXmCreateOptionMenu();
-extern RXmCreateRadioBox();
-extern RXmCreateWarningDialog();
-extern RXmCreateBulletinBoardDialog();
-extern RXmCreateErrorDialog();
-extern RXmCreateFileSelectionDialog();
-extern RXmCreateFormDialog();
-extern RXmCreateInformationDialog();
-extern RXmCreateMessageDialog();
-extern RXmCreatePopupMenu();
-extern RXmCreatePromptDialog();
-extern RXmCreatePulldownMenu();
-extern RXmCreateQuestionDialog();
-extern RXmCreateScrolledList();
-extern RXmCreateScrolledText();
-extern RXmCreateSelectionDialog();
-extern RXmCreateWorkingDialog();
-extern RXCreateFontCursor();
-
-/* In resources.c */
-extern RXtSetValues();
-extern RXtGetValues();
-
-/* In motif.c */
-extern RXmUpdateDisplay();
-extern RXmIsMotifWMRunning();
-extern RXmCommandAppendValue();
-extern RXmCommandError();
-extern RXmCommandSetValue();
-extern RXmScaleGetValue();
-extern RXmScaleSetValue();
-extern RXmToggleButtonGetState();
-extern RXmToggleButtonSetState();
-extern RXmAddTabGroup();
-extern RXmRemoveTabGroup();
-extern RXmProcessTraversal();
-extern RXmMessageBoxGetChild();
-extern RXmSelectionBoxGetChild();
-extern RXmFileSelectionBoxGetChild();
-extern RXmCommandGetChild();
-extern RXmScrolledWindowSetAreas();
-extern RXmTrackingLocate();
-extern RXmMenuPosition();
-extern RXmScrollBarGetValues();
-extern RXmScrollBarSetValues();
-
-/* In translations.c */
-extern RXtParseTranslationTable();
-extern RXtAugmentTranslations();
-extern RXtOverrideTranslations();
-extern RXtUninstallTranslations();
-extern RXtParseAcceleratorTable();
-extern RXtInstallAccelerators();
-extern RXtInstallAllAccelerators();
-
-/* In text.c */
-extern RXmTextClearSelection();
-extern RXmTextCopy();
-extern RXmTextCut();
-extern RXmTextGetBaseline();
-extern RXmTextGetEditable();
-extern RXmTextGetInsertionPosition();
-extern RXmTextGetLastPosition();
-extern RXmTextGetMaxLength();
-extern RXmTextGetSelection();
-extern RXmTextGetSelectionPosition();
-extern RXmTextGetString();
-extern RXmTextGetTopCharacter();
-extern RXmTextInsert();
-extern RXmTextPaste();
-extern RXmTextPosToXY();
-extern RXmTextRemove();
-extern RXmTextReplace();
-extern RXmTextScroll();
-extern RXmTextSetAddMode();
-extern RXmTextSetEditable();
-extern RXmTextSetHighlight();
-extern RXmTextSetInsertionPosition();
-extern RXmTextSetMaxLength();
-extern RXmTextSetSelection();
-extern RXmTextSetString();
-extern RXmTextSetTopCharacter();
-extern RXmTextShowPosition();
-extern RXmTextXYToPos();
-
-/* In xmstring.c */
-extern RXmFontListAdd();
-extern RXmFontListCreate();
-extern RXmFontListFree();
-extern RXmStringBaseline();
-extern RXmStringByteCompare();
-extern RXmStringCompare();
-extern RXmStringConcat();
-extern RXmStringCopy();
-extern RXmStringCreate();
-extern RXmStringCreateLtoR();
-extern RXmStringGetLtoR();
-extern RXmStringCreateSimple();
-extern RXmStringEmpty();
-extern RXmStringExtent();
-extern RXmStringFree();
-extern RXmStringHasSubstring();
-extern RXmStringHeight();
-extern RXmStringLength();
-extern RXmStringLineCount();
-extern RXmStringNConcat();
-extern RXmStringNCopy();
-extern RXmStringSeparatorCreate();
-extern RXmStringWidth();
-
-/* In list.c */
-extern RSetItems();
-extern RGetItems();
-extern RXmListAddItem();
-extern RXmListAddItemUnselected();
-extern RXmListDeleteItem();
-extern RXmListDeletePos();
-extern RXmListDeselectAllItems();
-extern RXmListDeselectItem();
-extern RXmListDeselectPos();
-extern RXmListSelectItem();
-extern RXmListSelectPos();
-extern RXmListSetBottomItem();
-extern RXmListSetBottomPos();
-extern RXmListSetHorizPos();
-extern RXmListSetItem();
-extern RXmListSetPos();
-extern RXmListAddItems();
-extern RXmListDeleteAllItems();
-extern RXmListDeleteItems();
-extern RXmListDeleteItemsPos();
-extern RXmListItemExists();
-extern RXmListItemPos();
-extern RXmListReplaceItems();
-extern RXmListReplaceItemsPos();
-extern RXmListSetAddMode();
-extern RXmListGetSelectedPos();
diff --git a/motif/server/global.h b/motif/server/global.h
deleted file mode 100644
index 669bbc9e01105a29aa57d07649fd83a94816bb66..0000000000000000000000000000000000000000
--- a/motif/server/global.h
+++ /dev/null
@@ -1,34 +0,0 @@
-#define PACKET_SIZE 4096
-#define HEADER_LENGTH 12
-
-#define ExtRResourceList "ResourceList"
-#define ExtRStringToken "StringToken"
-#define ExtRGrabKind "GrabKind"
-#define ExtRResourceNames "ResourceNames"
-#define ExtRCallbackReason "CallbackReason"
-#define ExtREvent "Event"
-#define ExtRIntList "IntList"
-
-typedef enum {GarbageData, GarbageXmString} garbage_kind;
-
-extern int global_argc,client_socket;
-extern char **global_argv;
-extern XtAppContext app_context;
-extern Display *display;
-extern String global_app_name,global_app_class;
-
-extern int global_will_trace,will_fork;
-extern Boolean terminate_server,swap_bytes,must_confirm;
-extern long next_serial;
-
-/* Function prototypes */
-
-extern void fatal_error(char *);
-extern void close_sockets();
-extern void register_garbage(void *,garbage_kind);
-
-extern void CallbackHandler();
-extern void ProtocolHandler();
-extern void EventHandler();
-extern void NonMaskableHandler();
-extern void LispActionProc();
diff --git a/motif/server/list.c b/motif/server/list.c
deleted file mode 100644
index 94c6f96be1422147e2ef07202683a1528bdb871f..0000000000000000000000000000000000000000
--- a/motif/server/list.c
+++ /dev/null
@@ -1,348 +0,0 @@
-#include <stdio.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/StringDefs.h>
-#include <Xm/Xm.h>
-
-#include <Xm/List.h>
-#include <Xm/Command.h>
-#include <Xm/SelectioB.h>
-
-#include "global.h"
-#include "datatrans.h"
-#include "types.h"
-#include "tables.h"
-#include "requests.h"
-
-
-/* Functions for interacting with XmList widgets */
-
-void find_items_resources(Widget w, String *items, String *count)
-{
-  if( XtClass(w) == xmListWidgetClass ) {
-    *items = XmNitems;
-    *count = XmNitemCount;
-  }
-  else if( XtClass(w) == xmSelectionBoxWidgetClass ) {
-    *items = XmNlistItems;
-    *count = XmNlistItemCount;
-  }
-  else if( XtClass(w) == xmCommandWidgetClass ) {
-    *items = XmNhistoryItems;
-    *count = XmNhistoryItemCount;
-  }
-  else
-    *items = *count = NULL;
-}
-
-int RSetItems(message_t message)
-{
-  Widget w;
-  StringTable items;
-  String items_name,count_name;
-  Arg args[2];
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&items,XmRXmStringTable);
-
-  find_items_resources(w,&items_name,&count_name);
-  if( !items_name ) {
-    XtWarning("Invalid widget class in SET-ITEMS.  Ignoring request.");
-    return NULL;
-  }
-
-  XtSetArg(args[0], items_name, items.data);
-  XtSetArg(args[1], count_name, items.length);
-  XtSetValues(w, args, 2);
-}
-
-int RGetItems(message_t message)
-{
-  Widget w;
-  StringTable items;
-  String items_name,count_name;
-  Arg args[2];
-  message_t reply=prepare_reply(message);
-
-  toolkit_read_value(message,&w,XtRWidget);
-
-  find_items_resources(w,&items_name,&count_name);
-  if( !items_name ) {
-    XtWarning("Invalid widget class in GET-ITEMS.  Ignoring request.");
-    return NULL;
-  }
-
-  XtSetArg(args[0], items_name, &items.data);
-  XtSetArg(args[1], count_name, &items.length);
-  XtGetValues(w, args, 2);
-
-  message_write_xm_string_table(reply, &items, xm_string_table_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-  must_confirm = False;
-}
-
-int RXmListAddItem(message_t message)
-{
-  Widget w;
-  XmString item;
-  int pos;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&item,XmRXmString);
-  toolkit_read_value(message,&pos,XtRInt);
-  XmListAddItem(w,item,pos);
-}
-
-int RXmListAddItemUnselected(message_t message)
-{
-  Widget w;
-  XmString item;
-  int pos;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&item,XmRXmString);
-  toolkit_read_value(message,&pos,XtRInt);
-  XmListAddItemUnselected(w,item,pos);
-}
-
-int RXmListDeleteItem(message_t message)
-{
-  Widget w;
-  XmString item;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&item,XmRXmString);
-  XmListDeleteItem(w,item);
-}
-
-
-int RXmListDeletePos(message_t message)
-{
-  Widget w;
-  int pos;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&pos,XtRInt);
-  XmListDeletePos(w,pos);
-}
-
-int RXmListDeselectAllItems(message_t message)
-{
-  Widget w;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  XmListDeselectAllItems(w);
-}
-
-int RXmListDeselectItem(message_t message)
-{
-  Widget w;
-  XmString item;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&item,XmRXmString);
-  XmListDeselectItem(w,item);
-}
-
-int RXmListDeselectPos(message_t message)
-{
-  Widget w;
-  int pos;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&pos,XtRInt);
-  XmListDeselectPos(w,pos);
-}
-
-int RXmListSelectItem(message_t message)
-{
-  Widget w;
-  XmString item;
-  Boolean notify;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&item,XmRXmString);
-  toolkit_read_value(message,&notify,XtRBoolean);
-  XmListSelectItem(w,item,notify);
-}
-
-int RXmListSelectPos(message_t message)
-{
-  Widget w;
-  int pos;
-  Boolean notify;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&pos,XtRInt);
-  toolkit_read_value(message,&notify,XtRBoolean);
-  XmListSelectPos(w,pos,notify);
-}
-
-int RXmListSetBottomItem(message_t message)
-{
-  Widget w;
-  XmString item;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&item,XmRXmString);
-  XmListSetBottomItem(w,item);
-}
-
-int RXmListSetBottomPos(message_t message)
-{
-  Widget w;
-  int pos;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&pos,XtRInt);
-  XmListSetBottomPos(w,pos);
-}
-
-int RXmListSetHorizPos(message_t message)
-{
-  Widget w;
-  int pos;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&pos,XtRInt);
-  XmListSetHorizPos(w,pos);
-}
-
-int RXmListSetItem(message_t message)
-{
-  Widget w;
-  XmString item;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&item,XmRXmString);
-  XmListSetItem(w,item);
-}
-
-int RXmListSetPos(message_t message)
-{
-  Widget w;
-  int pos;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&pos,XtRInt);
-  XmListSetPos(w,pos);
-}
-
-int RXmListAddItems(message_t message)
-{
-  Widget w;
-  StringTable items;
-  int pos;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&items,XmRXmStringTable);
-  toolkit_read_value(message,&pos,XtRInt);
-  XmListAddItems(w,(XmString *)items.data,items.length,pos);
-}
-
-int RXmListDeleteAllItems(message_t message)
-{
-  Widget w;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  XmListDeleteAllItems(w);
-}
-
-int RXmListDeleteItems(message_t message)
-{
-  Widget w;
-  StringTable items;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&items,XmRXmStringTable);
-  XmListDeleteItems(w,(XmString *)items.data,items.length);
-}
-
-int RXmListDeleteItemsPos(message_t message)
-{
-  Widget w;
-  int count,pos;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&count,XtRInt);
-  toolkit_read_value(message,&pos,XtRInt);
-  XmListDeleteItemsPos(w,count,pos);
-}
-
-int RXmListItemExists(message_t message)
-{
-  Widget w;
-  XmString item;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&item,XmRXmString);
-  reply_with_boolean(message,XmListItemExists(w,item));
-}
-
-int RXmListItemPos(message_t message)
-{
-  Widget w;
-  XmString item;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&item,XmRXmString);
-  reply_with_integer(message,XmListItemPos(w,item));
-}
-
-int RXmListReplaceItems(message_t message)
-{
-  Widget w;
-  StringTable old,new;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&old,XmRXmStringTable);
-  toolkit_read_value(message,&new,XmRXmStringTable);
-  XmListReplaceItems(w,(XmString *)old.data,old.length,(XmString *)new.data);
-}
-
-int RXmListReplaceItemsPos(message_t message)
-{
-  Widget w;
-  StringTable new;
-  int pos;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&new,XmRXmStringTable);
-  toolkit_read_value(message,&pos,XtRInt);
-  XmListReplaceItemsPos(w,(XmString *)new.data,new.length,pos);
-}
-
-int RXmListSetAddMode(message_t message)
-{
-  Widget w;
-  int state;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&state,XtRBoolean);
-  XmListSetAddMode(w,state);
-}
-
-int RXmListGetSelectedPos(message_t message)
-{
-  Widget w;
-  IntList pos;
-  Boolean result;
-  message_t reply = prepare_reply(message);
-
-  toolkit_read_value(message,&w,XtRWidget);
-
-  result = XmListGetSelectedPos(w,&pos.data,&pos.length);
-  if( !result )
-    pos.length = 0;
-
-  message_write_int_list(reply,&pos,int_list_tag);
-  message_write_boolean(reply,result,boolean_tag);
-
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  must_confirm = False;
-  if( result )
-    register_garbage(pos.data,GarbageData);
-}
diff --git a/motif/server/main.c b/motif/server/main.c
deleted file mode 100644
index 6b04799856b907a1339fa3f7aaffd1a60980a71b..0000000000000000000000000000000000000000
--- a/motif/server/main.c
+++ /dev/null
@@ -1,224 +0,0 @@
-#include <stdio.h>
-#include <ctype.h>
-#include <sys/types.h>
-#include <sys/socket.h>
-#include <sys/un.h>
-#include <netinet/in.h>
-#include <netdb.h>
-#include <arpa/inet.h>
-#include <errno.h>
-#include <signal.h>
-
-#define PORT 8000
-
-#define MAX(x,y) ((x<y)?y:x)
-
-/* Some things (ie. RT) don't define this in errno.h.  Go figure.  */
-extern int errno;
-
-extern void serve_client(int socket);
-
-/* Sockets the server will accept connections on */
-int unix_socket, inet_socket;
-char socket_path[30];
-
-/* Addresses of the server */
-struct sockaddr_in inetAddress;
-struct sockaddr_un unixAddress;
-
-int global_argc;
-char **global_argv;
-int global_will_trace=NULL;
-int will_fork=1;
-int use_inet_socket=1;
-int use_unix_socket=1;
-
-enum { Global, Normal, Local } socket_choice = Normal;
-
-void close_sockets()
-{
-  close(unix_socket);
-  close(inet_socket);
-  unlink(socket_path);
-}
-
-void shutdown()
-{
-  fprintf(stderr,"Caught signal.\n");
-  close_sockets();
-  exit(0);
-}
-
-void main_err(char *message)
-{
-  fprintf(stderr,"%s\n",message);
-  if( errno )
-    perror(NULL);
-
-  close_sockets();
-
-  exit(1);
-}
-
-void create_unix_socket(char *path)
-{
-  unix_socket = socket(AF_UNIX, SOCK_STREAM, 0);
-  if( unix_socket < 0 )
-    main_err("create_unix_socket:  Unable to open Unix domain socket.");
-
-  unixAddress.sun_family = AF_UNIX;
-  strcpy(unixAddress.sun_path, path);
-  if( bind(unix_socket, (struct sockaddr *)&unixAddress,
-	   strlen(path)+2) < 0 ) {
-    main_err("create_unix_socket:  Unable to bind Unix socket.");
-  }
-
-  if( listen(unix_socket,5) < 0 )
-    main_err("create_unix_socket:  Unable to listen on Unix socket.");
-}
-
-void create_inet_socket(int port)
-{
-  inet_socket = socket(AF_INET, SOCK_STREAM, 0);
-  if( inet_socket < 0 )
-    main_err("create_inet_socket:  Unable to open Inet domain socket.");
-
-  bzero((char *)&inetAddress, sizeof(inetAddress));
-  inetAddress.sin_family      = AF_INET;
-  inetAddress.sin_port        = htons(port);
-  inetAddress.sin_addr.s_addr = htonl(INADDR_ANY);
-  if( bind(inet_socket, (struct sockaddr *)&inetAddress,
-	   sizeof(inetAddress)) < 0 ) {
-    main_err("create_inet_socket:  Unable to bind Inet socket.");
-  }
-
-  if( listen(inet_socket,5) < 0 )
-    main_err("create_inet_socket:  Unable to listen on Inet socket.");
-}
-
-
-void start_server(int port, char *path)
-{
-  if( use_unix_socket )
-    create_unix_socket(path);
-  if( use_inet_socket )
-    create_inet_socket(port);
-}
-
-void establish_client(int s)
-{
-  int pid=0,socket;
-  struct sockaddr sa;
-  int sa_length = sizeof(struct sockaddr);
-
-  socket = accept(s, &sa, &sa_length);
-  if( socket < 0 )
-    main_err("establish_client:  Unable to accept client connection.");
-
-  printf("Accepted client on fd %d\n",socket);
-
-  if( will_fork )
-    pid = fork();
-  else
-    printf("Server not forking.\n");
-
-  switch( pid ) {
-  case 0:    /*  The child process */
-    close(unix_socket);
-    close(inet_socket);
-    serve_client(socket);
-    break;
-  case -1:
-    main_err("establish_client:  Fork failed.");
-    break;
-  default:
-    close(socket);
-    break;
-  }
-}
-
-main(int argc, char **argv)
-{
-  fd_set rfds;
-  int nfound,nfds,i;
-  int port = PORT;
-
-  /* This is so resources can be passed to the servers on the command line */
-  global_argc = argc;
-  global_argv = argv;
-
-  /*
-   * - Invoking the server with "-nofork" will ensure that the server
-   *   does fork when handling client connections.
-   * - Invoking the server with "-trace" will make the server print
-   *   out all sorts of useful trace info while it's running.
-   */
-  for(i=1;i<argc;i++) {
-    if( !strcmp(argv[i],"-trace") )
-      global_will_trace = 1;
-    else if( !strcmp(argv[i],"-nofork") )
-      will_fork = 0;
-    else if( !strcmp(argv[i],"-global") )
-      socket_choice = Global;
-    else if( !strcmp(argv[i],"-local") )
-      socket_choice = Local;
-    else if( !strcmp(argv[i],"-noinet") )
-      use_inet_socket = NULL;
-    else if( !strcmp(argv[i],"-nounix") )
-      use_unix_socket = NULL;
-  }
-
-  switch( socket_choice ) {
-  case Global:
-    sprintf(socket_path,"/tmp/.motif_socket");
-    break;
-  case Normal:
-    port += getuid();
-    sprintf(socket_path,"/tmp/.motif_socket-u%d",getuid());
-    break;
-  case Local:
-    use_inet_socket = NULL;
-    sprintf(socket_path,"/tmp/.motif_socket-p%d",getpid());
-    break;
-  }
-
-  printf("Starting server:\n");
-  printf("   will_fork  = %s\n",will_fork?"True":"False");
-  printf("   will_trace = %s\n",global_will_trace?"True":"False");
-  if( use_inet_socket )
-    printf("   port       = %d\n",port);
-  else
-    printf("   No Inet domain socket created.\n");
-  if( use_unix_socket )
-    printf("   path       = %s\n",socket_path);
-  else
-    printf("   No Unix domain socket created.\n");
-
-  start_server(port, socket_path);
-
-  /* Catch signals and remove our sockets before going away. */
-  signal(SIGHUP, shutdown);
-  signal(SIGINT, shutdown);
-  signal(SIGQUIT, shutdown);
-
-  printf("Waiting for connection.\n");
-
-  FD_ZERO(&rfds);
-  nfds = MAX(unix_socket,inet_socket)+1;
-  for(;;) {
-    if( use_unix_socket ) FD_SET(unix_socket, &rfds);
-    if( use_inet_socket ) FD_SET(inet_socket, &rfds);
-    nfound = select(nfds, &rfds, NULL, NULL, 0);
-    if( nfound < 0 )
-      main_err("main:  Unable to select on sockets.");
-
-    if( FD_ISSET(unix_socket, &rfds) ) {
-      printf("Accepting client on Unix socket.\n");
-      establish_client(unix_socket);
-    }
-    if( FD_ISSET(inet_socket, &rfds) ) {
-      printf("Accepting client on Inet socket.\n");
-      establish_client(inet_socket);
-    }
-  }
-}
diff --git a/motif/server/message.c b/motif/server/message.c
deleted file mode 100644
index a0e09c6db46453a9895b41f525818c11d7dce9d4..0000000000000000000000000000000000000000
--- a/motif/server/message.c
+++ /dev/null
@@ -1,218 +0,0 @@
-#include <stdio.h>
-#include <X11/Intrinsic.h>
-
-#include "global.h"
-#include "message.h"
-
-
-message_t pending=NULL;
-
-message_t message_new(long serial) {
-  message_t new;
-
-  new = XtNew(struct message);
-  new->next = NULL;
-  new->packets = NULL;
-  new->serial = serial;
-  new->packet_count = 0;
-
-  return new;
-}
-
-void message_free(message_t message) {
-  packet_t last = message->packets;
-  packet_t current = last;
-
-  do {
-    packet_free(current);
-    current = current->next;
-  } while( current != last );
-
-  XtFree( (char *)message );
-}
-
-void message_add_packet(message_t message) {
-  packet_t new;
-
-  new = packet_new(message->serial,++message->packet_count);
-
-  if( message->packets ) {
-    new->next = message->packets->next;
-    message->packets->next = new;
-  }
-
-  message->packets = new;
-}
-
-
-void message_insert_packet(message_t message, packet_t new) {
-  packet_t scan=message->packets;
-
-  if( !scan )
-    message->packets = new;
-  else
-    if( new->current > scan->current ) {
-      message->packets = new;
-      new->next = scan;
-      scan->next =new;
-    } else {
-      do { scan = scan->next; } while( scan->next->current < new->current );
-      new->next = scan->next;
-      scan->next = new;
-    }
-
-  message->packet_count++;
-}
-
-unsigned char message_get_byte(message_t message) {
-  packet_t packet=message->packets;
-
-  if( (packet->fill-packet->data) >= packet->length )
-    packet = message->packets = packet->next;
-
-  return( packet_get_byte(packet) );
-}
-
-short message_get_word(message_t message) {
-  packet_t packet=message->packets;
-
-  if( (packet->fill-packet->data) >= (packet->length-1) )
-    packet = message->packets = packet->next;
-
-  return( packet_get_word(packet) );
-}
-
-long message_get_dblword(message_t message) {
-  packet_t packet=message->packets;
-
-  if( (packet->fill-packet->data) >= (packet->length-3) )
-    packet = message->packets = packet->next;
-
-  return( packet_get_dblword(packet) );
-}
-
-
-void message_put_byte(message_t message, unsigned char byte) {
-  packet_t packet = message->packets;
-
-  if( packet->length < PACKET_SIZE )
-    packet_put_byte(packet,byte);
-  else {
-    message_add_packet(message);
-    packet_put_byte(message->packets,byte);
-  }
-}
-
-void message_put_word(message_t message, short word) {
-  packet_t packet = message->packets;
-
-  if( packet->length < PACKET_SIZE-1 )
-    packet_put_word(packet,word);
-  else {
-    message_add_packet(message);
-    packet_put_word(message->packets,word);
-  }
-}
-
-void message_put_dblword(message_t message, long dword) {
-  packet_t packet = message->packets;
-
-  if( packet->length < PACKET_SIZE-3 )
-    packet_put_dblword(packet,dword);
-  else {
-    message_add_packet(message);
-    packet_put_dblword(message->packets, dword);
-  }
-}
-
-void message_send(int socket, message_t message){
-  int total = message->packet_count;
-  packet_t first = message->packets->next;
-  packet_t current = first;
-
-  do {
-    current->total = total;
-    packet_send(socket, current);
-
-    current = current->next;
-  } while( current != first );
-}
-
-
-void kill_deferred_message(long serial) {
-  message_t scan = pending;
-  message_t target = NULL;
-
-  if( scan && scan->serial == serial ) {
-    target = scan;
-    scan = target;
-  } else
-    while( scan->next ) {
-      if( scan->next->serial == serial ) {
-	target = scan->next;
-	scan->next = target->next;
-      }
-      scan = scan->next;
-    }
-
-  target->next = NULL;
-}
-
-/*
-* The given packet needs to be held over and joined with it's friends.
-*/
-message_t message_defer_packet(packet_t packet) {
-  message_t current = pending;
-  message_t target = NULL;
-
-  while( current && !target ) {
-    if( current->serial == packet->serial ) target=current;
-    current=current->next;
-  }
-
-  if( !target ) {
-    target = message_new(packet->serial);
-    target->next = pending;
-    pending = target;
-  }
-
-  message_insert_packet(target,packet);
-
-  if( target->packet_count == packet->total ) {
-    /*
-    * It is assumed that single packet requests were handled elsewhere.
-    * Thus, if this request is complete it must have been sitting on the
-    * pending list.
-    */
-    current = pending;
-    if( target == pending )
-      pending = target->next;
-    else {
-      while( current->next != target ) current = current->next;
-      current->next = target->next;
-    }
-    target->next = NULL;
-    return target;
-  } else
-    return NULL;
-}
-
-message_t message_read(int socket) {
-  message_t new;
-  packet_t first = packet_new(0,1); /* The given serial is of course bogus */
-  int count;
-
-  packet_read(socket,first);
-  count=first->total;
-  if( !count && !first->current ) {
-    kill_deferred_message(first->serial);
-    if( global_will_trace )
-      printf("Got cancellation for serial %d\n",first->serial);
-  } else if( count == 1 ) {
-    new = message_new(next_serial++);
-    new->packets = first;
-    new->packet_count = 1;
-    return new;
-  } else
-    return message_defer_packet(first);
-}
diff --git a/motif/server/message.h b/motif/server/message.h
deleted file mode 100644
index ce83efccca222504d038845bc8dc02fa8a9a047e..0000000000000000000000000000000000000000
--- a/motif/server/message.h
+++ /dev/null
@@ -1,28 +0,0 @@
-#ifndef MESSAGE_H
-#define MESSAGE_H
-
-#include "packet.h"
-
-
-typedef struct message {
-  struct message *next;
-  long serial;
-  int packet_count;
-  packet_t packets;
-} *message_t;
-
-extern message_t message_new(long serial);
-extern void message_free(message_t message);
-extern void message_add_packet(message_t message);
-
-extern unsigned char message_get_byte(message_t m);
-extern short message_get_word(message_t m);
-extern long message_get_dblword(message_t m);
-extern void message_put_byte(message_t m, unsigned char c);
-extern void message_put_word(message_t m, short w);
-extern void message_put_dblword(message_t m, long d);
-
-extern message_t message_read(int s);
-extern void message_send(int s, message_t m);
-
-#endif
diff --git a/motif/server/motif.c b/motif/server/motif.c
deleted file mode 100644
index 64de67138c0844d1b41da6391ccee6caa4fcf6ce..0000000000000000000000000000000000000000
--- a/motif/server/motif.c
+++ /dev/null
@@ -1,250 +0,0 @@
-#include <stdio.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/StringDefs.h>
-#include <Xm/Xm.h>
-#include <Xm/Command.h>
-#include <Xm/MessageB.h>
-#include <Xm/FileSB.h>
-#include <Xm/SelectioB.h>
-
-#include "global.h"
-#include "datatrans.h"
-#include "types.h"
-#include "tables.h"
-#include "requests.h"
-
-int RXmUpdateDisplay(message_t message)
-{
-  Widget w;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  XmUpdateDisplay(w);
-}
-
-int RXmIsMotifWMRunning(message_t message)
-{
-  Widget w;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  reply_with_boolean(message,XmIsMotifWMRunning(w));
-}
-
-int RXmScrolledWindowSetAreas(message_t message)
-{
-  Widget w;
-  Widget hscroll,vscroll,work_region;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&hscroll,XtRWidget);
-  toolkit_read_value(message,&vscroll,XtRWidget);
-  toolkit_read_value(message,&work_region,XtRWidget);
-  XmScrolledWindowSetAreas(w,hscroll,vscroll,work_region);
-}
-
-int RXmTrackingLocate(message_t message)
-{
-  Widget w;
-  Cursor cursor;
-  Boolean confine_to;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&cursor,XtRCursor);
-  toolkit_read_value(message,&confine_to,XtRBoolean);
-  XmTrackingLocate(w,cursor,confine_to);
-}
-
-int RXmMenuPosition(message_t message)
-{
-  Widget w;
-  XButtonPressedEvent *event;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&w,ExtREvent);
-
-  XmMenuPosition(w,event);
-}
-
-
-
-/* Functions for accessing XmCommand widgets */
-
-int RXmCommandAppendValue(message_t message)
-{
-  Widget widget;
-  XmString command;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  toolkit_read_value(message,&command,XmRXmString);
-  XmCommandAppendValue(widget,command);
-}
-
-int RXmCommandError(message_t message)
-{
-  Widget widget;
-  XmString error;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  toolkit_read_value(message,&error,XmRXmString);
-  XmCommandError(widget,error);
-}
-
-int RXmCommandSetValue(message_t message)
-{
-  Widget w;
-  XmString value;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&value,XmRXmString);
-  XmCommandSetValue(w,value);
-}
-
-
-
-/* Functions for dealing with XmScale widgets */
-
-int RXmScaleGetValue(message_t message)
-{
-  Widget widget;
-  int value;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  XmScaleGetValue(widget,&value);
-  reply_with_integer(message,value);
-}
-
-int RXmScaleSetValue(message_t message)
-{
-  Widget widget;
-  int value;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  toolkit_read_value(message,&value,XtRInt);
-  XmScaleSetValue(widget,value);
-}
-
-
-
-/* Functions for dealing with XmToggleButton widgets */
-
-int RXmToggleButtonGetState(message_t message)
-{
-  Widget w;
-  int state;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  state = XmToggleButtonGetState(w);
-  reply_with_boolean(message,state);
-}
-
-int RXmToggleButtonSetState(message_t message)
-{
-  Widget w;
-  Boolean state,notify;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&state,XtRBoolean);
-  toolkit_read_value(message,&notify,XtRBoolean);
-  XmToggleButtonSetState(w,state,notify);
-}
-
-
-
-/* Functions for using Tab groups */
-
-int RXmAddTabGroup(message_t message)
-{
-  Widget w;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  XmAddTabGroup(w);
-}
-
-int RXmRemoveTabGroup(message_t message)
-{
-  Widget w;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  XmRemoveTabGroup(w);
-}
-
-int RXmProcessTraversal(message_t message)
-{
-  Widget w;
-  int direction;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&direction,XtRInt);
-  reply_with_boolean(message,XmProcessTraversal(w,direction));
-}
-
-
-
-/* Functions for getting children from Command/[File]SelectionBox/MessageBox */
-
-#define DEFINE_CHILD_QUERY(query_func)                 \
-  Widget w;                                            \
-  int which_child;                                     \
-                                                       \
-  toolkit_read_value(message,&w,XtRWidget);            \
-  toolkit_read_value(message,&which_child,XtREnum);    \
-  reply_with_widget(message,query_func(w,which_child))
-
-int RXmMessageBoxGetChild(message_t message)
-{
-  DEFINE_CHILD_QUERY(XmMessageBoxGetChild);
-}
-
-int RXmSelectionBoxGetChild(message_t message)
-{
-  DEFINE_CHILD_QUERY(XmSelectionBoxGetChild);
-}
-
-int RXmFileSelectionBoxGetChild(message_t message)
-{
-  DEFINE_CHILD_QUERY(XmFileSelectionBoxGetChild);
-}
-
-int RXmCommandGetChild(message_t message)
-{
-  DEFINE_CHILD_QUERY(XmCommandGetChild);
-}
-
-
-
-/* Functions for getting/setting values of XmScrollBar widgets */
-
-int RXmScrollBarGetValues(message_t message)
-{
-  Widget widget;
-  int value,slider_size,increment,page_increment;
-  message_t reply = prepare_reply(message);
-
-  toolkit_read_value(message,&widget,XtRWidget);
-
-  XmScrollBarGetValues(widget,&value,&slider_size,&increment,&page_increment);
-
-  message_write_int(reply,value,int_tag);
-  message_write_int(reply,slider_size,int_tag);
-  message_write_int(reply,increment,int_tag);
-  message_write_int(reply,page_increment,int_tag);
-
-  message_send(client_socket,reply);
-  message_free(reply);
-  must_confirm = False;
-}
-
-int RXmScrollBarSetValues(message_t message)
-{
-  Widget w;
-  int value,slider_size,increment,page_increment,notify;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&value,XtRInt);
-  toolkit_read_value(message,&slider_size,XtRInt);
-  toolkit_read_value(message,&increment,XtRInt);
-  toolkit_read_value(message,&page_increment,XtRInt);
-  toolkit_read_value(message,&notify,XtRBoolean);
-
-  XmScrollBarSetValues(w,value,slider_size,increment,page_increment,notify);
-}
diff --git a/motif/server/packet.c b/motif/server/packet.c
deleted file mode 100644
index 3508e519c10396e6d99f4416a8f70d32346df888..0000000000000000000000000000000000000000
--- a/motif/server/packet.c
+++ /dev/null
@@ -1,175 +0,0 @@
-#include <stdio.h>
-#include <X11/Intrinsic.h>
-
-#include "global.h"
-#include "packet.h"
-
-
-packet_t packet_new(long serial, short current) {
-  packet_t new;
-
-  new = XtNew(struct packet);
-  new->data = XtMalloc(PACKET_SIZE);
-
-  new->fill = new->data+HEADER_LENGTH; /* Advance past header */
-  new->length = HEADER_LENGTH;         /* Length includes header */
-  new->serial = serial;
-  new->current = current;
-  new->next = new;
-
-  return new;
-}
-
-void packet_free(packet_t packet) {
-  XtFree( (char *)packet->data );
-  XtFree( (char *)packet );
-}
-
-
-/* Reads a byte from the packet buffer at the fill pointer */
-unsigned char packet_get_byte(packet_t packet) {
-  return( *(packet->fill++) );
-}
-
-short packet_get_word(packet_t packet) {
-  char tmp[2];
-
-  if( swap_bytes ) {
-    tmp[1]=packet_get_byte(packet);
-    tmp[0]=packet_get_byte(packet);
-  } else {
-    tmp[0] = packet_get_byte(packet);
-    tmp[1] = packet_get_byte(packet);
-  }
-
-  return( *((short *)tmp) );
-}
-
-long packet_get_dblword(packet_t packet) {
-  char tmp[4];
-  int i;
-
-  if( swap_bytes )
-    for(i=3;i>=0;i--) tmp[i] = packet_get_byte(packet);
-  else
-    for(i=0;i<4;i++)  tmp[i] = packet_get_byte(packet);
-
-  return( *((long *)tmp) );
-}
-
-void packet_put_byte(packet_t packet, unsigned char byte) {
-  *(packet->fill++) = byte;
-  packet->length++;
-}
-
-void packet_put_word(packet_t packet, short word) {
-  char *tmp = (char *)&word;
-
-  if( swap_bytes ) {
-    packet_put_byte(packet,tmp[1]);
-    packet_put_byte(packet,tmp[0]);
-  } else {
-    packet_put_byte(packet,tmp[0]);
-    packet_put_byte(packet,tmp[1]);
-  }
-}
-
-void packet_put_dblword(packet_t packet, long dword) {
-  char *tmp = (char *)&dword;
-  int i;
-
-  if( swap_bytes )
-    for(i=3;i>=0;i--) packet_put_byte(packet,tmp[i]);
-  else
-    for(i=0;i<4;i++)  packet_put_byte(packet,tmp[i]);
-}
-
-void packet_build_header(packet_t packet)
-{
-  int length = packet->length;
-
-  packet->fill = packet->data;
-
-  /* These operations will alter the packet length counter.  However, */
-  /* we don't want that to happen, so we just preserve the length */
-  /* temporarily and stick it back in when we're done.  This is sort */
-  /* of a hack, but it works. */
-  packet_put_dblword(packet,packet->serial);
-  packet_put_word(packet,packet->current);
-  packet_put_word(packet,packet->total);
-  packet_put_dblword(packet,length);
-  packet->length = length;
-}
-
-void packet_parse_header(packet_t packet) {
-  packet->fill = packet->data;
-
-  packet->serial  = packet_get_dblword(packet);
-  packet->current = packet_get_word(packet);
-  packet->total   = packet_get_word(packet);
-  packet->length  = packet_get_dblword(packet);
-}
-
-void packet_send(int socket, packet_t packet) {
-  int result, target;
-
-  if( global_will_trace ) {
-    printf("packet_send:  Sending packet --\n");
-    printf("packet_send:     serial = %u\n",packet->serial);
-    printf("packet_send:     length = %u\n",packet->length);
-    printf("packet_send:     this is packet %d of %d\n",packet->current,
-	   packet->total);
-  }
-  packet_build_header(packet);
-
-  target = packet->length;
-  packet->fill = packet->data;
-  while( target ) {
-    result = write(socket, packet->fill, target);
-    if( result == -1 )
-      fatal_error("packet_send:  Error in sending packet.");
-    target -= result;
-    packet->fill += result;
-  }
-
-}
-
-void packet_read(int socket, packet_t packet) {
-  int bytes_read = 0;
-  int result,target;
-
-  packet->fill = packet->data;
-
-  while( bytes_read < HEADER_LENGTH ) {
-    result = read(socket, packet->fill, HEADER_LENGTH-bytes_read);
-    if( result == -1 )
-      fatal_error("packet_read:  Error in reading packet header.");
-    else if( result == 0 )
-      fatal_error("packet_read:  Hit EOF while reading packet header.");
-    bytes_read += result;
-    packet->fill += result;
-  }
-
-  packet_parse_header(packet);
-  target = packet->length-bytes_read;
-
-  if( global_will_trace ) {
-    printf("packet_read:  Receiving packet --\n");
-    printf("packet_read:     serial = %u\n",packet->serial);
-    printf("packet_read:     length = %u\n",packet->length);
-    printf("packet_read:     This is packet %d of %d\n",packet->current,
-	   packet->total);
-  }
-
-  while( target ) {
-    result = read(socket, packet->fill, target);
-    if( result == -1 )
-      fatal_error("packet_read:  Error in reading packet body.");
-    else if( result == 0 )
-      fatal_error("packet_read:  Hit EOF while reading packet body.");
-    target -= result;
-    packet->fill += result;
-  }
-
-  packet->fill = packet->data+HEADER_LENGTH;
-}
diff --git a/motif/server/packet.h b/motif/server/packet.h
deleted file mode 100644
index fffc5dd8f3c0bbba1d12b6810f2cffe71adbc33c..0000000000000000000000000000000000000000
--- a/motif/server/packet.h
+++ /dev/null
@@ -1,26 +0,0 @@
-#ifndef PACKET_H
-#define PACKET_H
-
-typedef struct packet {
-  struct packet *next;
-  long length,serial;
-  short current,total;
-  char *data,*fill;
-} *packet_t;
-
-extern packet_t packet_new(long serial,short current);
-extern void packet_free(packet_t packet);
-
-extern unsigned char packet_get_byte(packet_t p);
-extern short packet_get_word(packet_t p);
-extern long packet_get_dblword(packet_t p);
-extern void packet_put_byte(packet_t p, unsigned char b);
-extern void packet_put_word(packet_t p, short w);
-extern void packet_put_dblword(packet_t p, long d);
-
-extern void packet_build_header(packet_t packet);
-extern void packet_parse_header(packet_t packet);
-extern void packet_send(int socket, packet_t packet);
-extern void packet_read(int socket, packet_t packet);
-
-#endif
diff --git a/motif/server/requests.c b/motif/server/requests.c
deleted file mode 100644
index cef5d9279c9ec6a2d4d9bac75ddc46bd20de0620..0000000000000000000000000000000000000000
--- a/motif/server/requests.c
+++ /dev/null
@@ -1,175 +0,0 @@
-#include <stdio.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/StringDefs.h>
-#include <X11/Shell.h>
-#include <Xm/Xm.h>
-
-#include "global.h"
-#include "datatrans.h"
-#include "types.h"
-#include "functions.h"
-#include "tables.h"
-
-typedef int (*request_f)(message_t);
-Boolean must_confirm = False;
-int processing_depth = 0;
-Garbage garbage_list = NULL;
-
-#include "Interface.h"
-
-void register_garbage(void *stuff,garbage_kind kind)
-{
-  Garbage garbage = XtNew(struct garbage_node);
-
-  garbage->junk = (char *)stuff;
-  garbage->kind = kind;
-  garbage->next = garbage_list;
-  garbage_list = garbage;
-}
-
-void cleanup_garbage()
-{
-  Garbage doomed,current = garbage_list;
-  
-  garbage_list = NULL;
-  while( current ) {
-    if( current->kind == GarbageXmString )
-      XmStringFree( (XmString)current->junk );
-    else
-      XtFree( current->junk );
-
-    doomed = current;
-    current = current->next;
-    XtFree( (char *)doomed );
-  }
-}
-
-void send_confirmation(message_t message,int socket)
-{
-  message_t reply = message_new(message->serial);
-
-  message_add_packet(reply);
-  message_put_dblword(reply,CONFIRM_REPLY);
-  message_send(socket,reply);
-  message_free(reply);
-}
-
-message_t prepare_reply(message_t message)
-{
-  message_t reply;
-
-  reply = message_new(message->serial);
-  /* This is only because the message_new doesn't auto-add one itself, */
-  /* which is something that it really ought to do. */
-  message_add_packet(reply);
-  message_put_dblword(reply,VALUES_REPLY);
-  return reply;
-}
-
-void reply_with_widget(message_t message,Widget widget)
-{
-  message_t reply = prepare_reply(message);
-
-  message_write_widget(reply,widget,widget_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  must_confirm = False;
-}
-
-void reply_with_widgets(message_t message,Widget w1,Widget w2)
-{
-  message_t reply = prepare_reply(message);
-
-  message_write_widget(reply,w1,widget_tag);
-  message_write_widget(reply,w2,widget_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  must_confirm = False;
-}
-
-
-void reply_with_integer(message_t message,long value)
-{
-  message_t reply = prepare_reply(message);
-
-  message_write_int(reply,value,int_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  must_confirm = False;
-}
-
-void reply_with_boolean(message_t message,Boolean value)
-{
-  message_t reply = prepare_reply(message);
-
-  message_write_boolean(reply,value,boolean_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  must_confirm = False;
-}
-
-void reply_with_font_list(message_t message,XmFontList value)
-{
-  message_t reply = prepare_reply(message);
-
-  message_write_font_list(reply,value,font_list_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  must_confirm = False;
-}
-
-void reply_with_xmstring(message_t message,XmString s)
-{
-  message_t reply=prepare_reply(message);
-
-  message_write_xm_string(reply,s,xm_string_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-  must_confirm=False;
-}
-
-void reply_with_string(message_t message,String s)
-{
-  message_t reply=prepare_reply(message);
-
-  message_write_string(reply,s,string_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-  must_confirm=False;
-}
-
-void process_request(message_t message,int socket)
-{
-  int request_op;
-  request_f handler;
-
-  processing_depth++;
-  request_op = message_get_word(message);
-  must_confirm = message_get_byte(message);
-  message_get_byte(message);   /* This is ignored at the moment */
-
-  handler = request_table[request_op];
-  if( global_will_trace )
-    printf("Dispatching request for %d\n",request_op);
-  (*handler)(message);
-  if( must_confirm )
-    send_confirmation(message,socket);
-  processing_depth--;
-  if( !processing_depth )
-    cleanup_garbage();
-}
-
-int QuitServer(message_t message)
-{
-  close(client_socket);
-  if( !will_fork )
-    close_sockets();
-
-  exit(0);
-}
diff --git a/motif/server/requests.h b/motif/server/requests.h
deleted file mode 100644
index 61cb1b1dd1e82c1f072ed3a0d8c3a605c08c10a1..0000000000000000000000000000000000000000
--- a/motif/server/requests.h
+++ /dev/null
@@ -1,8 +0,0 @@
-extern message_t prepare_reply(message_t message);
-extern void reply_with_widget(message_t,Widget);
-extern void reply_with_widgets(message_t,Widget,Widget);
-extern void reply_with_integer(message_t,long);
-extern void reply_with_boolean(message_t,Boolean);
-extern void reply_with_font_list(message_t,XmFontList);
-extern void reply_with_xmstring(message_t,XmString);
-extern void reply_with_string(message_t,String);
diff --git a/motif/server/resources.c b/motif/server/resources.c
deleted file mode 100644
index a01d02a9e15f5464d6a165c6f1ddbb1ca7757152..0000000000000000000000000000000000000000
--- a/motif/server/resources.c
+++ /dev/null
@@ -1,50 +0,0 @@
-#include <stdio.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/StringDefs.h>
-#include <X11/Shell.h>
-#include <Xm/Xm.h>
-
-#include "global.h"
-#include "datatrans.h"
-#include "types.h"
-#include "tables.h"
-
-extern message_t prepare_reply(message_t m);
-
-
-int RXtSetValues(message_t message)
-{
-  Widget w;
-  ResourceList resources;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  resources.class = XtClass(w);
-  resources.parent = XtParent(w);
-  toolkit_read_value(message,&resources,ExtRResourceList);
-
-  XtSetValues(w,resources.args,resources.length);
-  register_garbage(resources.args,GarbageData);
-}
-
-int RXtGetValues(message_t message)
-{
-  message_t reply;
-  Widget w;
-  ResourceList resources;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  resources.class = XtClass(w);
-  resources.parent = XtParent(w);
-  toolkit_read_value(message,&resources,ExtRResourceNames);
-
-  XtGetValues(w,resources.args,resources.length);
-
-  reply = prepare_reply(message);
-  message_write_resource_list(reply,&resources,resource_list_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-  register_garbage(resources.args,GarbageData);
-
-  must_confirm = False;
-}
diff --git a/motif/server/server.c b/motif/server/server.c
deleted file mode 100644
index 54f2c4ea98f6ea099a4a464331927a9f8a66473f..0000000000000000000000000000000000000000
--- a/motif/server/server.c
+++ /dev/null
@@ -1,182 +0,0 @@
-#include <stdio.h>
-#include <ctype.h>
-#include <errno.h>
-#include <setjmp.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/StringDefs.h>
-#include <X11/Shell.h>
-#include <Xm/Xm.h>
-
-#include "global.h"
-#include "types.h"
-#include "datatrans.h"
-#include "tables.h"
-
-extern void process_request(message_t m,int socket);
-
-XtAppContext app_context;
-Display *display;
-
-XtActionsRec LispAction;
-Boolean terminate_server = False;
-Boolean swap_bytes = False;
-String global_app_class = NULL, global_app_name = NULL;
- 
-long next_serial = 0;
-int client_socket;
-jmp_buf env;
-
-void fatal_error(char *message)
-{
-  fprintf(stderr,"%s\n",message);
-  if( errno )
-    perror(NULL);
-
-  close(client_socket);
-  if( !will_fork ) {
-    close_sockets();
-    abort();
-  } else
-    exit(-1);
-}
-
-void MyErrorHandler(String errmsg)
-{
-  message_t reply = message_new(next_serial++);
-  message_add_packet(reply);
-
-  fprintf(stderr,"Error: %s\n",errmsg);
-  message_put_dblword(reply,ERROR_REPLY);
-  message_write_string(reply,errmsg,string_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  longjmp(env,1);
-  exit(-1);
-}
-
-void MyWarningHandler(String errmsg)
-{
-  message_t reply = message_new(next_serial++);
-  message_add_packet(reply);
-
-  fprintf(stderr,"Warning: %s\n",errmsg);
-  message_put_dblword(reply,WARNING_REPLY);
-  message_write_string(reply,errmsg,string_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-}
-
-
-void get_input(caddr_t closure, int *socket, XtInputId *id)
-{
-  message_t message;
-
-  if( global_will_trace )
-    printf("get_input:  Receiving incoming packet.\n");
-  message = message_read(*socket);
-
-  process_request(message,*socket);
-
-  if( global_will_trace )
-    printf("get_input:  Successfully digested packet.  Now freeing.\n");
-
-  message_free(message);
-}
-
-void greet_client(int socket) {
-  short byte;
-  int result,pad;
-  char *dpy_name,*app_class,*app_name;
-  message_t first;
-
-  /* Read byte-swap thing */
-  result = read(socket,&byte,2);
-  if( !result )  fatal_error("greet_client:  Unable to read initial data.");
-  else if( result == 1 )  read(socket,&byte+1,1);
-
-  swap_bytes = (byte!=1);
-  if( global_will_trace )
-    printf("swap_bytes is: %d (from %d)\n",swap_bytes,byte);
-
-  /* Read initial packet */
-  first = message_read(socket);
-  if( !first )
-    fatal_error("greet_client:  No greeting packet sent.");
-
-  toolkit_read_value(first,&dpy_name,XtRString);
-  toolkit_read_value(first,&app_name,XtRString);
-  toolkit_read_value(first,&app_class,XtRString);
-
-  global_app_class = XtNewString(app_class);
-  global_app_name  = XtNewString(app_name);
-
-  if( global_will_trace )
-    printf("Opening display on '%s' for app '%s' class '%s'\n",dpy_name,
-	   app_name,app_class);
-  display = XtOpenDisplay(app_context, dpy_name,
-			  app_name, app_class,
-			  NULL, 0,
-			  &global_argc, global_argv);
-  if( !display )
-    fatal_error("greet_client:  Unable to open display.");
-
-  message_free(first);
-}
-
-
-void serve_client(int socket)
-{
-  XEvent event;
-
-  XtToolkitInitialize();
-  app_context = XtCreateApplicationContext();
-
-  LispAction.string = "Lisp";
-  LispAction.proc   = LispActionProc;
-  XtAppAddActions(app_context, &LispAction, 1);
-
-  string_token_tag = find_type_entry(ExtRStringToken);
-  string_tag = find_type_entry(XtRString);
-  xm_string_tag = find_type_entry(XmRXmString);
-  enum_tag = find_type_entry(XtREnum);
-  int_tag = find_type_entry(XtRInt);
-  window_tag = find_type_entry(XtRWindow);
-  boolean_tag = find_type_entry(XtRBoolean);
-  widget_tag = find_type_entry(XtRWidget);
-  function_tag = find_type_entry(XtRFunction);
-  callback_reason_tag = find_type_entry(ExtRCallbackReason);
-  event_tag = find_type_entry(ExtREvent);
-  resource_list_tag = find_type_entry(ExtRResourceList);
-  translation_table_tag = find_type_entry(XtRTranslationTable);
-  accelerator_table_tag = find_type_entry(XtRAcceleratorTable);
-  atom_tag = find_type_entry(XtRAtom);
-  font_list_tag = find_type_entry(XmRFontList);
-  string_table_tag = find_type_entry(XtRStringTable);
-  xm_string_table_tag = find_type_entry(XmRXmStringTable);
-  int_list_tag = find_type_entry(ExtRIntList);
-  cursor_tag = find_type_entry(XtRCursor);
-
-  client_socket = socket;
-  greet_client(socket);
-
-  XtAppAddInput(app_context, socket, (XtPointer)XtInputReadMask,
-		(XtInputCallbackProc)get_input, (XtPointer)NULL);
-
-  XtAppSetErrorHandler(app_context, MyErrorHandler);
-  XtAppSetWarningHandler(app_context, MyWarningHandler);
-
-  /* Here is where we want to return on errors */
-  if( setjmp(env) )
-    printf("Attempting to recover from error.\n");
-  while( !terminate_server ) {
-    XtAppNextEvent(app_context, &event);
-    XtDispatchEvent(&event);
-  }
-
-  close(socket);
-  XtDestroyApplicationContext(app_context);
-
-  exit(0);
-}
diff --git a/motif/server/tables.c b/motif/server/tables.c
deleted file mode 100644
index fe156d79de138a745e869bdda7b6a32f07d5b0bd..0000000000000000000000000000000000000000
--- a/motif/server/tables.c
+++ /dev/null
@@ -1,253 +0,0 @@
-#include <stdio.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/IntrinsicP.h>
-#include <X11/Core.h>
-#include <X11/CoreP.h>
-#include <X11/StringDefs.h>
-#include <Xm/Xm.h>
-
-#include "global.h"
-#include "datatrans.h"
-#include "tables.h"
-
-extern WidgetClass overrideShellWidgetClass,transientShellWidgetClass,
-  topLevelShellWidgetClass,applicationShellWidgetClass;
-extern WidgetClass xmDialogShellWidgetClass,xmMenuShellWidgetClass;
-extern WidgetClass xmLabelWidgetClass,xmLabelGadgetClass,
-  xmArrowButtonWidgetClass,xmArrowButtonGadgetClass,xmPushButtonWidgetClass,
-  xmPushButtonGadgetClass,xmToggleButtonWidgetClass,xmToggleButtonGadgetClass,
-  xmCascadeButtonWidgetClass,xmCascadeButtonGadgetClass,xmSeparatorWidgetClass,
-  xmSeparatorGadgetClass, xmDrawnButtonWidgetClass, xmMenuShellWidgetClass,
-  xmDrawingAreaWidgetClass,xmDialogShellWidgetClass,xmBulletinBoardWidgetClass,
-  xmCommandWidgetClass, xmFileSelectionBoxWidgetClass, xmFormWidgetClass,
-  xmMessageBoxWidgetClass, xmSelectionBoxWidgetClass, xmScrollBarWidgetClass,
-  xmTextWidgetClass, xmTextFieldWidgetClass, xmRowColumnWidgetClass,
-  xmScaleWidgetClass, xmFrameWidgetClass, xmListWidgetClass,
-  xmMainWindowWidgetClass,xmScrolledWindowWidgetClass,xmPanedWindowWidgetClass;
-
-#include "StringTable.h"
-#include "ClassTable.h"
-#include "TypeTable.h"
-
-typedef struct {
-  String name,type;
-} resource_entry, *resource_entry_list;
-
-typedef struct {
-  resource_entry_list resource_list,constraint_list;
-  int resource_count,constraint_count;
-} class_resources;
-
-class_resources resource_table[CLASS_TABLE_SIZE];
-int string_token_tag,string_tag,xm_string_tag,enum_tag;
-int int_tag,window_tag,boolean_tag,widget_tag,function_tag;
-int callback_reason_tag,event_tag,resource_list_tag;
-int translation_table_tag,accelerator_table_tag;
-int atom_tag,font_list_tag,string_table_tag,xm_string_table_tag;
-int int_list_tag,cursor_tag;
-
-long binary_search(char *table,int length,int entry_size,
-			    char *target, int (*pred)())
-{
-  long start=0,end = length-1;
-  long current = length/2;
-  int result;
-
-  while( start<=end ) {
-    result = (*pred)(target,table+current*entry_size);
-    if( !result )
-      return current;
-    else if( result<0 )
-      end = current-1;
-    else
-      start = current+1;
-
-    current = (start+end)/2;
-  }
-
-  /* Target not found */
-  return (-1);
-}
-
-int resource_pred(String target,resource_entry *current) {
-  return strcmp(target,current->name);
-}
-
-int type_pred(String target,type_entry *current) {
-  return strcmp(target,current->type);
-}
-
-int string_pred(String target, String *current) {
-  return strcmp(target,*current);
-}
-
-int resource_cmp(resource_entry *a,resource_entry *b) {
-  return strcmp(a->name,b->name);
-}
-
-void assure_class_initialized(WidgetClass class)
-{
-  if( !class->core_class.class_inited )
-    XtInitializeWidgetClass(class);
-}
-
-void record_class_resources(WidgetClass class,class_resources *r)
-{
-  XtResourceList resource_list,constraint_list;
-  int resource_count,constraint_count,index,extra=0;
-
-  XtGetResourceList(class,&resource_list,&resource_count);
-  XtGetConstraintResourceList(class,&constraint_list,&constraint_count);
-
-  if( class == xmTextWidgetClass )
-    extra = 14;
-  else if(class == applicationShellWidgetClass ||
-	  class == topLevelShellWidgetClass    ||
-	  class == transientShellWidgetClass   ||
-	  class == xmDialogShellWidgetClass)
-    extra = 4;
-
-  resource_count += extra;
-  r->resource_list =
-    (resource_entry_list)XtMalloc( sizeof(resource_entry)*resource_count );
-  r->constraint_list =
-    (resource_entry_list)XtMalloc( sizeof(resource_entry)*constraint_count );
-
-  for(index=0;index<resource_count-extra;index++) {
-    r->resource_list[index].name =
-      XtNewString(resource_list[index].resource_name);
-    r->resource_list[index].type =
-      XtNewString(resource_list[index].resource_type);
-  }
-
-  if( class == xmTextWidgetClass ) {
-    r->resource_list[index].name   = XmNpendingDelete;
-    r->resource_list[index++].type = XmRBoolean;
-    r->resource_list[index].name   = XmNselectThreshold;
-    r->resource_list[index++].type = XmRInt;
-    r->resource_list[index].name   = XmNblinkRate;
-    r->resource_list[index++].type = XmRInt;
-    r->resource_list[index].name   = XmNcolumns;
-    r->resource_list[index++].type = XmRShort;
-    r->resource_list[index].name   = XmNcursorPositionVisible;
-    r->resource_list[index++].type = XmRBoolean;
-    r->resource_list[index].name   = XmNfontList;
-    r->resource_list[index++].type = XmRFontList;
-    r->resource_list[index].name   = XmNresizeHeight;
-    r->resource_list[index++].type = XmRBoolean;
-    r->resource_list[index].name   = XmNresizeWidth;
-    r->resource_list[index++].type = XmRBoolean;
-    r->resource_list[index].name   = XmNrows;
-    r->resource_list[index++].type = XmRShort;
-    r->resource_list[index].name   = XmNwordWrap;
-    r->resource_list[index++].type = XmRBoolean;
-    r->resource_list[index].name   = XmNscrollHorizontal;
-    r->resource_list[index++].type = XmRBoolean;
-    r->resource_list[index].name   = XmNscrollVertical;
-    r->resource_list[index++].type = XmRBoolean;
-    r->resource_list[index].name   = XmNscrollLeftSide;
-    r->resource_list[index++].type = XmRBoolean;
-    r->resource_list[index].name   = XmNscrollTopSide;
-    r->resource_list[index++].type = XmRBoolean;
-  } else if(class == applicationShellWidgetClass ||
-	    class == topLevelShellWidgetClass    ||
-	    class == transientShellWidgetClass   ||
-	    class == xmDialogShellWidgetClass) {
-    r->resource_list[index].name   = XmNdefaultFontList;
-    r->resource_list[index++].type = XmRFontList;
-    r->resource_list[index].name   = XmNdeleteResponse;
-    r->resource_list[index++].type = XmRDeleteResponse;
-    r->resource_list[index].name   = XmNkeyboardFocusPolicy;
-    r->resource_list[index++].type = XmRKeyboardFocusPolicy;
-    r->resource_list[index].name   = XmNshellUnitType;
-    r->resource_list[index++].type = XmRShellUnitType;
-  }
-
-  for(index=0;index<constraint_count;index++) {
-    r->constraint_list[index].name = 
-      XtNewString(constraint_list[index].resource_name);
-    r->constraint_list[index].type = 
-      XtNewString(constraint_list[index].resource_type);
-  }
-
-  qsort(r->resource_list,resource_count,sizeof(resource_entry),resource_cmp);
-  qsort(r->constraint_list,constraint_count,
-	sizeof(resource_entry),resource_cmp);
-
-  r->resource_count = resource_count;
-  r->constraint_count = constraint_count;
-
-  XtFree( (char *)resource_list );
-  XtFree( (char *)constraint_list );
-}
-
-
-String query_resource_type(int classid,Widget parent,String resource)
-{
-  WidgetClass class;
-  resource_entry_list resources,constraints;
-  int result;
-
-  if( !resource_table[classid].resource_list ) {
-    class = *class_table[classid];
-    assure_class_initialized(class);
-    record_class_resources(class,&resource_table[classid]);
-  }
-
-  resources = resource_table[classid].resource_list;
-  constraints = resource_table[classid].constraint_list;
-
-
-  result = binary_search((char *)resources,
-			 resource_table[classid].resource_count,
-			 sizeof(resource_entry),resource,resource_pred);
-
-  if( result<0 )
-    result = binary_search((char *)constraints,
-			   resource_table[classid].constraint_count,
-			   sizeof(resource_entry),resource,resource_pred);
-  else return resources[result].type;
-
-  if( result<0 ) {
-    if( parent ) {
-      class = XtClass(parent);
-      classid = find_widget_class_id(class);
-      if( !resource_table[classid].resource_list ) {
-	assure_class_initialized(class);
-	record_class_resources(class,&resource_table[classid]);
-      }
-      constraints = resource_table[classid].constraint_list;
-      result = binary_search((char *)constraints,
-			     resource_table[classid].constraint_count,
-			     sizeof(resource_entry),resource,resource_pred);
-    }
-  }
-  else return constraints[result].type;
-
-  if( result<0 ) return NULL;
-  else return constraints[result].type;
-}
-
-long tokenize_string(String string)
-{
-  return binary_search((char *)string_table,STRING_TABLE_SIZE,sizeof(char *),
-		       string,string_pred);
-}
-
-long find_type_entry(String type)
-{
-   return binary_search((char *)type_table,TYPE_TABLE_SIZE,sizeof(type_entry),
-		       type,type_pred);
-}
-
-long find_widget_class_id(WidgetClass class)
-{
-  int id=0;
-
-  while( id<CLASS_TABLE_SIZE )
-    if( *class_table[id] == class ) return id;
-    else id++;
-
-  return (-1);
-}
diff --git a/motif/server/tables.h b/motif/server/tables.h
deleted file mode 100644
index d6a0af60e975f0dad19bd39595aeded20c985a98..0000000000000000000000000000000000000000
--- a/motif/server/tables.h
+++ /dev/null
@@ -1,31 +0,0 @@
-#ifndef TABLES_H
-#define TABLES_H
-
-typedef void (*type_writer)(message_t out,caddr_t src,int type_tag);
-typedef void (*type_reader)(message_t in,caddr_t dest,int type_tag,int data);
-
-typedef struct {
-  String type;
-  type_writer writer;
-  type_reader reader;
-} type_entry;
-
-extern String string_table[];
-extern WidgetClass *class_table[];
-extern type_entry type_table[];
-
-/* These are precomputed */
-extern int string_token_tag,string_tag,xm_string_tag,enum_tag;
-extern int int_tag,window_tag,boolean_tag,widget_tag,function_tag;
-extern int callback_reason_tag,event_tag,resource_list_tag;
-extern int translation_table_tag,accelerator_table_tag;
-extern int atom_tag,font_list_tag,string_table_tag,xm_string_table_tag;
-extern int int_list_tag,cursor_tag;
-
-extern long binary_search(char *tbl,int len,int size,char *t,int (*p)());
-extern long tokenize_string(String s);
-extern long find_type_entry(String type);
-extern long find_widget_class_id(WidgetClass class);
-extern String query_resource_type(int classid,Widget Parent,String rsrc);
-
-#endif
diff --git a/motif/server/text.c b/motif/server/text.c
deleted file mode 100644
index 96a034c2a20517fabfaf1408546fb2e5b85e8bd9..0000000000000000000000000000000000000000
--- a/motif/server/text.c
+++ /dev/null
@@ -1,262 +0,0 @@
-#include <stdio.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/StringDefs.h>
-#include <Xm/Xm.h>
-#include <Xm/Text.h>
-
-#include "global.h"
-#include "datatrans.h"
-#include "types.h"
-#include "tables.h"
-#include "requests.h"
-
-
-/* Functions for using the XmText widgets */
-
-int RXmTextClearSelection(message_t message)
-{
-  Widget w;
-  Time t;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  t = XtLastTimestampProcessed(display);
-  XmTextClearSelection(w,t);
-}
-
-int RXmTextCopy(message_t message)
-{
-  Widget w;
-  Time t;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  t = XtLastTimestampProcessed(display);
-  reply_with_boolean(message,XmTextCopy(w,t));
-}
-
-int RXmTextCut(message_t message)
-{
-  Widget w;
-  Time t;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  t = XtLastTimestampProcessed(display);
-  reply_with_boolean(message,XmTextCut(w,t));
-}
-
-#define DEFINE_TEXT_QUERY(query_func,reply_func) \
-  Widget w;                                      \
-                                                 \
-  toolkit_read_value(message,&w,XtRWidget);      \
-  reply_func(message,query_func(w))
-
-int RXmTextGetBaseline(message_t message)
-{
-  DEFINE_TEXT_QUERY(XmTextGetBaseline,reply_with_integer);
-}
-
-int RXmTextGetEditable(message_t message)
-{
-  DEFINE_TEXT_QUERY(XmTextGetEditable,reply_with_boolean);
-}
-
-int RXmTextGetInsertionPosition(message_t message)
-{
-  DEFINE_TEXT_QUERY(XmTextGetInsertionPosition,reply_with_integer);
-}
-
-int RXmTextGetLastPosition(message_t message)
-{
-  DEFINE_TEXT_QUERY(XmTextGetLastPosition,reply_with_integer);
-}
-
-int RXmTextGetMaxLength(message_t message)
-{
-  DEFINE_TEXT_QUERY(XmTextGetMaxLength,reply_with_integer);
-}
-
-int RXmTextGetTopCharacter(message_t message)
-{
-  DEFINE_TEXT_QUERY(XmTextGetTopCharacter,reply_with_integer);
-}
-
-int RXmTextGetSelection(message_t message)
-{
-  Widget w;
-  char *sel;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  sel = XmTextGetSelection(w);
-  reply_with_string(message,sel);
-  register_garbage(sel,GarbageData);
-}
-
-int RXmTextGetSelectionPosition(message_t message)
-{
-  Widget w;
-  Boolean result;
-  XmTextPosition left,right;
-  message_t reply=prepare_reply(message);
-
-  toolkit_read_value(message,&w,XtRWidget);
-  result=XmTextGetSelectionPosition(w,&left,&right);
-
-  message_write_boolean(reply,result,boolean_tag);
-  message_write_int(reply,left,int_tag);
-  message_write_int(reply,right,int_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-  must_confirm=False;
-}
-
-int RXmTextGetString(message_t message)
-{
-  Widget w;
-  char *s;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  s = XmTextGetString(w);
-  reply_with_string(message,s);
-  register_garbage(s,GarbageData);
-}
-
-int RXmTextInsert(message_t message)
-{
-  Widget w;
-  XmTextPosition pos;
-  String value;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&pos,XtRInt);
-  toolkit_read_value(message,&value,XtRString);
-  XmTextInsert(w,pos,value);
-}
-
-/* These aren't really query functions, but they fit the model of one */
-int RXmTextPaste(message_t message)
-{
-  DEFINE_TEXT_QUERY(XmTextPaste,reply_with_boolean);
-}
-
-int RXmTextRemove(message_t message)
-{
-  DEFINE_TEXT_QUERY(XmTextRemove,reply_with_boolean);
-}
-
-int RXmTextPosToXY(message_t message)
-{
-  Widget w;
-  XmTextPosition pos;
-  Boolean result;
-  Position x,y;
-  message_t reply=prepare_reply(message);
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&pos,XtRInt);
-  result=XmTextPosToXY(w,pos,&x,&y);
-
-  message_write_boolean(reply,result,boolean_tag);
-  message_write_int(reply,x,int_tag);
-  message_write_int(reply,y,int_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-  must_confirm=False;
-}
-
-int RXmTextReplace(message_t message)
-{
-  Widget w;
-  XmTextPosition from,to;
-  String value;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&from,XtRInt);
-  toolkit_read_value(message,&to,XtRInt);
-  toolkit_read_value(message,&value,XtRString);
-  XmTextReplace(w,from,to,value);
-}
-
-#define DEFINE_TEXT_SET(setter,type,reptype)  \
-  Widget w;                                   \
-  type value;                                 \
-                                              \
-  toolkit_read_value(message,&w,XtRWidget);   \
-  toolkit_read_value(message,&value,reptype); \
-  setter(w,value)
-
-int RXmTextScroll(message_t message)
-{
-  DEFINE_TEXT_SET(XmTextScroll,int,XtRInt);
-}
-
-int RXmTextSetAddMode(message_t message)
-{
-  DEFINE_TEXT_SET(XmTextSetAddMode,int,XtRBoolean);
-}
-
-int RXmTextSetEditable(message_t message)
-{
-  DEFINE_TEXT_SET(XmTextSetEditable,int,XtRBoolean);
-}
-
-int RXmTextSetInsertionPosition(message_t message)
-{
-  DEFINE_TEXT_SET(XmTextSetInsertionPosition,XmTextPosition,XtRInt);
-}
-
-int RXmTextSetMaxLength(message_t message)
-{
-  DEFINE_TEXT_SET(XmTextSetMaxLength,int,XtRInt);
-}
-
-int RXmTextSetString(message_t message)
-{
-  DEFINE_TEXT_SET(XmTextSetString,String,XtRString);
-}
-
-int RXmTextSetTopCharacter(message_t message)
-{
-  DEFINE_TEXT_SET(XmTextSetTopCharacter,XmTextPosition,XtRInt);
-}
-
-int RXmTextShowPosition(message_t message)
-{
-  DEFINE_TEXT_SET(XmTextShowPosition,XmTextPosition,XtRInt);
-}
-
-int RXmTextSetHighlight(message_t message)
-{
-  Widget w;
-  XmTextPosition left,right;
-  XmHighlightMode mode;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&left,XtRInt);
-  toolkit_read_value(message,&right,XtRInt);
-  toolkit_read_value(message,&mode,XtREnum);
-  XmTextSetHighlight(w,left,right,mode);
-}
-
-int RXmTextSetSelection(message_t message)
-{
-  Widget w;
-  XmTextPosition first,last;
-  Time t;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&first,XtRInt);
-  toolkit_read_value(message,&last,XtRInt);
-  t = XtLastTimestampProcessed(display);
-  XmTextSetSelection(w,first,last,t);
-}
-
-int RXmTextXYToPos(message_t message)
-{
-  Widget w;
-  Position x,y;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&x,XtRInt);
-  toolkit_read_value(message,&y,XtRInt);
-  reply_with_integer(message,XmTextXYToPos(w,x,y));
-}
diff --git a/motif/server/translations.c b/motif/server/translations.c
deleted file mode 100644
index 29af876d5f858f6bc4b7f396c804f441b001a5e7..0000000000000000000000000000000000000000
--- a/motif/server/translations.c
+++ /dev/null
@@ -1,117 +0,0 @@
-#include <stdio.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/StringDefs.h>
-#include <Xm/Xm.h>
-
-#include "global.h"
-#include "datatrans.h"
-#include "types.h"
-#include "tables.h"
-#include "requests.h"
-
-
-extern int end_callback_loop;
-
-void LispActionProc(Widget w,XEvent *event,String *params,Cardinal *num_params)
-{
-  message_t reply;
-  int exit_value;
-
-  if( *num_params == 0 )
-    XtAppError(app_context,"LispActionProc:  Lisp function not specified.");
-  else if( *num_params > 1 )
-    XtAppWarning(app_context,"LispActionProc:  ignoring extra arguments.");
-
-  reply = message_new(next_serial++);
-  message_add_packet(reply);
-  message_put_dblword(reply,ACTION_REPLY);
-  message_write_widget(reply,w,widget_tag);
-  message_write_int(reply,event,int_tag);
-  message_write_string(reply,params[0],string_tag);
-
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  exit_value = end_callback_loop++;
-  while( exit_value<end_callback_loop )
-    XtAppProcessEvent(app_context,XtIMAlternateInput);
-}
-
-
-
-int RXtParseTranslationTable(message_t message)
-{
-  String table;
-  XtTranslations t;
-  message_t reply = prepare_reply(message);
-
-  toolkit_read_value(message,&table,XtRString);
-  t = XtParseTranslationTable(table);
-  message_write_translation_table(reply,t,translation_table_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-  must_confirm = False;
-}
-
-int RXtAugmentTranslations(message_t message)
-{
-  Widget w;
-  XtTranslations t;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&t,XtRTranslationTable);
-
-  XtAugmentTranslations(w,t);
-}
-
-int RXtOverrideTranslations(message_t message)
-{
-  Widget w;
-  XtTranslations t;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&t,XtRTranslationTable);
-
-  XtOverrideTranslations(w,t);
-}
-
-int RXtUninstallTranslations(message_t message)
-{
-  Widget w;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  XtUninstallTranslations(w);
-}
-
-int RXtParseAcceleratorTable(message_t message)
-{
-  String table;
-  XtAccelerators accel;
-  message_t reply = prepare_reply(message);
-
-  toolkit_read_value(message,&table,XtRString);
-  accel = XtParseAcceleratorTable(table);
-  message_write_accelerator_table(reply,accel,accelerator_table_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-  must_confirm = False;
-}
-
-int RXtInstallAccelerators(message_t message)
-{
-  Widget dest,src;
-
-  toolkit_read_value(message,&dest,XtRWidget);
-  toolkit_read_value(message,&src,XtRWidget);
-  XtInstallAccelerators(dest,src);
-}
-
-int RXtInstallAllAccelerators(message_t message)
-{
-  Widget dest,src;
-
-  toolkit_read_value(message,&dest,XtRWidget);
-  toolkit_read_value(message,&src,XtRWidget);
-  XtInstallAllAccelerators(dest,src);
-}
diff --git a/motif/server/types.h b/motif/server/types.h
deleted file mode 100644
index 24c6ff2bd05112a684039a5384d05c1581c5822a..0000000000000000000000000000000000000000
--- a/motif/server/types.h
+++ /dev/null
@@ -1,41 +0,0 @@
-/*
- * Response tags used in replying to requests.
- *
- */
-
-#define CONFIRM_REPLY  0
-#define VALUES_REPLY   1
-#define CALLBACK_REPLY 2
-#define EVENT_REPLY    3
-#define ERROR_REPLY    4
-#define WARNING_REPLY  5
-#define PROTOCOL_REPLY 6
-#define ACTION_REPLY   7
-
-typedef struct {
-  WidgetClass class;
-  Widget parent;
-  unsigned long length;
-  ArgList args;
-} ResourceList;
-
-typedef struct {
-  int length;
-  WidgetList widgets;
-} MyWidgetList;
-
-typedef struct {
-  int length;
-  char **data; /* This may be either an array of Strings or XmStrings */
-} StringTable;
-
-typedef struct garbage_node {
-  struct garbage_node *next;
-  garbage_kind kind;
-  char *junk;
-} *Garbage;
-
-typedef struct {
-  int length;
-  int *data;
-} IntList;
diff --git a/motif/server/widgets.c b/motif/server/widgets.c
deleted file mode 100644
index 1573e8295c21b5bc047ba558ac80d5b129db6ec6..0000000000000000000000000000000000000000
--- a/motif/server/widgets.c
+++ /dev/null
@@ -1,435 +0,0 @@
-#include <stdio.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/StringDefs.h>
-#include <X11/Shell.h>
-#include <Xm/Xm.h>
-#include <Xm/RowColumn.h>
-#include <Xm/BulletinB.h>
-#include <Xm/MessageB.h>
-#include <Xm/FileSB.h>
-#include <Xm/RowColumn.h>
-#include <Xm/SelectioB.h>
-#include <Xm/List.h>
-#include <Xm/Text.h>
-#include <Xm/Form.h>
-
-#include "global.h"
-#include "datatrans.h"
-#include "types.h"
-#include "tables.h"
-#include "requests.h"
-
-int RXtAppCreateShell(message_t message)
-{
-  Widget shell;
-  ResourceList resources;
-
-  resources.class = applicationShellWidgetClass;
-  resources.parent = NULL;
-  toolkit_read_value(message,&resources,ExtRResourceList);
-  shell = XtAppCreateShell(global_app_name,global_app_class,
-			   applicationShellWidgetClass, display,
-			   resources.args,resources.length);
-
-  reply_with_widget(message,shell);
-}
-
-int RXtRealizeWidget(message_t message)
-{
-  Widget widget;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  XtRealizeWidget(widget);
-}
-
-int RXtUnrealizeWidget(message_t message)
-{
-  Widget widget;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  XtUnrealizeWidget(widget);
-}
-
-int RXtMapWidget(message_t message)
-{
-  Widget widget;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  XtMapWidget(widget);
-}
-
-int RXtUnmapWidget(message_t message)
-{
-  Widget widget;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  XtUnmapWidget(widget);
-}
-
-int RXtSetSensitive(message_t message)
-{
-  Widget widget;
-  int sensitivity;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  toolkit_read_value(message,&sensitivity,XtRBoolean);
-  XtSetSensitive(widget,sensitivity);
-}
-
-int RXtCreateWidget(message_t message)
-{
-  String name;
-  WidgetClass class;
-  Widget w,parent;
-  ResourceList resources;
-
-  toolkit_read_value(message,&name,XtRString);
-  toolkit_read_value(message,&class,XtRWidgetClass);
-  toolkit_read_value(message,&parent,XtRWidget);
-
-  resources.class = class;
-  resources.parent = parent;
-  toolkit_read_value(message,&resources,ExtRResourceList);
-
-  w = XtCreateWidget(name,class,parent,
-		     resources.args,resources.length);
-  reply_with_widget(message,w);
-}
-
-int RXtCreateManagedWidget(message_t message)
-{
-  String name;
-  WidgetClass class;
-  Widget w,parent;
-  ResourceList resources;
-
-  toolkit_read_value(message,&name,XtRString);
-  toolkit_read_value(message,&class,XtRWidgetClass);
-  toolkit_read_value(message,&parent,XtRWidget);
-
-  resources.class = class;
-  resources.parent = parent;
-  toolkit_read_value(message,&resources,ExtRResourceList);
-
-  w = XtCreateManagedWidget(name,class,parent,
-			    resources.args,resources.length);
-  reply_with_widget(message,w);
-}
-
-int RXtDestroyWidget(message_t message)
-{
-  Widget widget;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  XtDestroyWidget(widget);
-}
-
-int RXtCreatePopupShell(message_t message)
-{
-  message_t reply;
-  String name;
-  WidgetClass class;
-  Widget parent,widget;
-  ResourceList resources;
-
-  toolkit_read_value(message,&name,XtRString);
-  toolkit_read_value(message,&class,XtRWidgetClass);
-  toolkit_read_value(message,&parent,XtRWidget);
-
-  resources.class = class;
-  resources.parent = parent;
-  toolkit_read_value(message,&resources,ExtRResourceList);
-
-  widget = XtCreatePopupShell(name,class,parent,
-			      resources.args,resources.length);
-
-  reply_with_widget(message,widget);
-}
-
-int RXtPopup(message_t message)
-{
-  Widget widget;
-  XtGrabKind grab_kind;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  toolkit_read_value(message,&grab_kind,ExtRGrabKind);
-  XtPopup(widget,grab_kind);
-}
-
-int RXtPopdown(message_t message)
-{
-  Widget widget;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  XtPopdown(widget);
-}
-
-int RXtManageChild(message_t message)
-{
-  Widget widget;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  XtManageChild(widget);
-}
-
-int RXtUnmanageChild(message_t message)
-{
-  Widget widget;
-
-  toolkit_read_value(message,&widget,XtRWidget);
-  XtUnmanageChild(widget);
-}
-
-int RXtManageChildren(message_t message)
-{
-  MyWidgetList list;
-
-  toolkit_read_value(message,&list,XtRWidgetList);
-  XtManageChildren(list.widgets,list.length);
-}
-
-int RXtUnmanageChildren(message_t message)
-{
-  MyWidgetList list;
-
-  toolkit_read_value(message,&list,XtRWidgetList);
-  XtUnmanageChildren(list.widgets,list.length);
-}
-
-int RXtIsManaged(message_t message)
-{
-  Widget w;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  reply_with_boolean(message,XtIsManaged(w));
-}
-
-int RXtPopupSpringLoaded(message_t message)
-{
-  Widget w;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  XtPopupSpringLoaded(w);
-}
-
-int RXtIsRealized(message_t message)
-{
-  Widget w;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  reply_with_boolean(message,XtIsRealized(w));
-}
-
-int RXtWindow(message_t message)
-{
-  Widget w;
-  message_t reply=prepare_reply(message);
-
-  toolkit_read_value(message,&w,XtRWidget);
-  message_write_xid(reply,XtWindow(w),window_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-  must_confirm=False;
-}
-
-int RXtName(message_t message)
-{
-  Widget w;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  reply_with_string(message,XtName(w));
-}
-
-int RXtIsSensitive(message_t message)
-{
-  Widget w;
-
-  toolkit_read_value(message,&w,XtRWidget);
-  reply_with_boolean(message,XtIsSensitive(w));
-}
-
-int RXtTranslateCoords(message_t message)
-{
-  Widget w;
-  int x,y,root_x,root_y;
-  message_t reply = prepare_reply(message);
-
-  toolkit_read_value(message,&w,XtRWidget);
-  toolkit_read_value(message,&x,XtRInt);
-  toolkit_read_value(message,&y,XtRInt);
-
-  XtTranslateCoords(w,x,y,&root_x,&root_y);
-
-  message_write_int(reply,root_x,int_tag);
-  message_write_int(reply,root_y,int_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  must_confirm = False;
-}
-
-
-
-int RXmCreateMenuBar(message_t message)
-{
-  String name;
-  Widget widget,parent;
-  ResourceList resources;
-
-  toolkit_read_value(message,&parent,XtRWidget);
-  toolkit_read_value(message,&name,XtRString);
-
-  resources.class = xmRowColumnWidgetClass;
-  resources.parent = parent;
-  toolkit_read_value(message,&resources,ExtRResourceList);
-
-  widget = XmCreateMenuBar(parent,name,resources.args,resources.length);
-  reply_with_widget(message,widget);
-}
-
-int RXmCreateOptionMenu(message_t message)
-{
-  String name;
-  Widget widget,parent;
-  ResourceList resources;
-
-  toolkit_read_value(message,&parent,XtRWidget);
-  toolkit_read_value(message,&name,XtRString);
-
-  resources.class = xmRowColumnWidgetClass;
-  resources.parent = parent;
-  toolkit_read_value(message,&resources,ExtRResourceList);
-
-  widget = XmCreateOptionMenu(parent,name,resources.args,resources.length);
-  reply_with_widget(message,widget);
-}
-
-int RXmCreateRadioBox(message_t message)
-{
-  String name;
-  Widget widget,parent;
-  ResourceList resources;
-
-  toolkit_read_value(message,&parent,XtRWidget);
-  toolkit_read_value(message,&name,XtRString);
-
-  resources.class = xmRowColumnWidgetClass;
-  resources.parent = parent;
-  toolkit_read_value(message,&resources,ExtRResourceList);
-
-  widget = XmCreateRadioBox(parent,name,resources.args,resources.length);
-  reply_with_widget(message,widget);
-}
-
-
-void dialog_maker(message_t message,Widget (*buildfunc)(),WidgetClass class)
-{
-  String name;
-  Widget this,shell,parent;
-  ResourceList resources;
-
-  toolkit_read_value(message,&parent,XtRWidget);
-  toolkit_read_value(message,&name,XtRString);
-  resources.class = class;
-  resources.parent = parent;
-  toolkit_read_value(message,&resources,ExtRResourceList);
-
-  this = (*buildfunc)(parent,name,resources.args,resources.length);
-  shell = XtParent(this);
-  reply_with_widgets(message,this,shell);
-}
-
-int RXmCreateWarningDialog(message_t message)
-{
-  dialog_maker(message,XmCreateWarningDialog,xmMessageBoxWidgetClass);
-}
-
-int RXmCreateBulletinBoardDialog(message_t message)
-{
-  dialog_maker(message,XmCreateBulletinBoardDialog,xmBulletinBoardWidgetClass);
-}
-
-int RXmCreateErrorDialog(message_t message)
-{
-  dialog_maker(message,XmCreateErrorDialog,xmMessageBoxWidgetClass);
-}
-
-int RXmCreateFileSelectionDialog(message_t message)
-{
-  dialog_maker(message,XmCreateFileSelectionDialog,xmFileSelectionBoxWidgetClass);
-}
-
-int RXmCreateFormDialog(message_t message)
-{
-  dialog_maker(message,XmCreateFormDialog,xmFormWidgetClass);
-}
-
-int RXmCreateInformationDialog(message_t message)
-{
-  dialog_maker(message,XmCreateInformationDialog,xmMessageBoxWidgetClass);
-}
-
-int RXmCreateMessageDialog(message_t message)
-{
-  dialog_maker(message,XmCreateMessageDialog,xmMessageBoxWidgetClass);
-}
-
-int RXmCreatePopupMenu(message_t message)
-{
-  dialog_maker(message,XmCreatePopupMenu,xmRowColumnWidgetClass);
-}
-
-int RXmCreatePromptDialog(message_t message)
-{
-  dialog_maker(message,XmCreatePromptDialog,xmSelectionBoxWidgetClass);
-}
-
-int RXmCreatePulldownMenu(message_t message)
-{
-  dialog_maker(message,XmCreatePulldownMenu,xmRowColumnWidgetClass);
-}
-
-int RXmCreateQuestionDialog(message_t message)
-{
-  dialog_maker(message,XmCreateQuestionDialog,xmMessageBoxWidgetClass);
-}
-
-int RXmCreateScrolledList(message_t message)
-{
-  dialog_maker(message,XmCreateScrolledList,xmListWidgetClass);
-}
-
-int RXmCreateScrolledText(message_t message)
-{
-  dialog_maker(message,XmCreateScrolledText,xmTextWidgetClass);
-}
-
-int RXmCreateSelectionDialog(message_t message)
-{
-  dialog_maker(message,XmCreateSelectionDialog,xmSelectionBoxWidgetClass);
-}
-
-int RXmCreateWorkingDialog(message_t message)
-{
-  dialog_maker(message,XmCreateWorkingDialog,xmMessageBoxWidgetClass);
-}
-
-
-
-/* Some random functions */
-
-int RXCreateFontCursor(message_t message)
-{
-  int shape;
-  Cursor crs;
-  message_t reply = prepare_reply(message);
-
-  toolkit_read_value(message,&shape,XtRInt);
-  crs = XCreateFontCursor(display,shape);
-
-  message_write_xid(reply,crs,cursor_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-  must_confirm=False;
-}
diff --git a/motif/server/xmstring.c b/motif/server/xmstring.c
deleted file mode 100644
index 863975cf0afced385742ba3325db0e17babd18b9..0000000000000000000000000000000000000000
--- a/motif/server/xmstring.c
+++ /dev/null
@@ -1,255 +0,0 @@
-#include <stdio.h>
-
-#include <X11/Intrinsic.h>
-#include <X11/StringDefs.h>
-#include <Xm/Xm.h>
-
-#include "global.h"
-#include "datatrans.h"
-#include "types.h"
-#include "tables.h"
-#include "requests.h"
-
-
-/* Functions for building XmFontLists */
-
-int RXmFontListAdd(message_t message)
-{
-  XmFontList oldlist,newlist;
-  XFontStruct *fstruct;
-  Font font;
-  XmStringCharSet charset;
-
-  toolkit_read_value(message,&oldlist,XmRFontList);
-  toolkit_read_value(message,&font,XtRFont);
-  toolkit_read_value(message,&charset,XtRString);
-
-  fstruct = XQueryFont(display,font);
-  newlist = XmFontListAdd(oldlist,fstruct,charset);
-  reply_with_font_list(message,newlist);
-}
-
-#define BOLD_FONT "-*-helvetica-bold-r-normal--11-*"
-
-int RXmFontListCreate(message_t message)
-{
-  XFontStruct *fstruct;
-  Font font;
-  XmStringCharSet charset;
-  XmFontList flist;
-
-  toolkit_read_value(message,&font,XtRFont);
-  toolkit_read_value(message,&charset,XtRString);
-
-  fstruct = XQueryFont(display,font);
-
-  flist = XmFontListCreate(fstruct,charset);
-  reply_with_font_list(message,flist);
-}
-
-int RXmFontListFree(message_t message)
-{
-  XmFontList flist;
-
-  toolkit_read_value(message,&flist,XmRFontList);
-  XmFontListFree(flist);
-}
-
-
-
-/* Functions for using XmStrings */
-
-int RXmStringBaseline(message_t message)
-{
-  XmFontList flist;
-  XmString xs;
-
-  toolkit_read_value(message,&flist,XmRFontList);
-  toolkit_read_value(message,&xs,XmRXmString);
-  reply_with_integer(message,XmStringBaseline(flist,xs));
-}
-
-int RXmStringByteCompare(message_t message)
-{
-  XmString s1,s2;
-
-  toolkit_read_value(message,&s1,XmRXmString);
-  toolkit_read_value(message,&s2,XmRXmString);
-  reply_with_boolean(message,XmStringByteCompare(s1,s2));
-}
-
-int RXmStringCompare(message_t message)
-{
-  XmString s1,s2;
-
-  toolkit_read_value(message,&s1,XmRXmString);
-  toolkit_read_value(message,&s2,XmRXmString);
-  reply_with_boolean(message,XmStringCompare(s1,s2));
-}
-
-int RXmStringConcat(message_t message)
-{
-  XmString s1,s2;
-  
-  toolkit_read_value(message,&s1,XmRXmString);
-  toolkit_read_value(message,&s2,XmRXmString);
-  reply_with_xmstring(message,XmStringConcat(s1,s2));
-}
-
-int RXmStringCopy(message_t message)
-{
-  XmString s;
-
-  toolkit_read_value(message,&s,XmRXmString);
-  reply_with_xmstring(message,XmStringCopy(s));
-}
-
-int RXmStringCreate(message_t message)
-{
-  String s,charset;
-
-  toolkit_read_value(message,&s,XtRString);
-  toolkit_read_value(message,&charset,XtRString);
-  reply_with_xmstring(message,XmStringCreate(s,charset));
-}
-
-int RXmStringCreateLtoR(message_t message)
-{
-  String s,charset;
-
-  toolkit_read_value(message,&s,XtRString);
-  toolkit_read_value(message,&charset,XtRString);
-  reply_with_xmstring(message,XmStringCreateLtoR(s,charset));
-}
-
-int RXmStringGetLtoR(message_t message)
-{
-  XmString xs;
-  String text,charset;
-  Boolean result;
-  message_t reply = prepare_reply(message);
-
-  toolkit_read_value(message,&xs,XmRXmString);
-  toolkit_read_value(message,&charset,XtRString);
-
-  result = XmStringGetLtoR(xs,charset,&text);
-
-  message_write_string(reply,text,string_tag);
-  message_write_boolean(reply,text,boolean_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-
-  must_confirm = False;
-}
-
-int RXmStringCreateSimple(message_t message)
-{
-  String s;
-
-  toolkit_read_value(message,&s,XtRString);
-  reply_with_xmstring(message,XmStringCreateSimple(s));
-}
-
-int RXmStringEmpty(message_t message)
-{
-  XmString s;
-
-  toolkit_read_value(message,&s,XmRXmString);
-  reply_with_boolean(message,XmStringEmpty(s));
-}
-
-int RXmStringExtent(message_t message)
-{
-  XmFontList flist;
-  XmString s;
-  Dimension width,height;
-  message_t reply = prepare_reply(message);
-
-  toolkit_read_value(message,&flist,XmRFontList);
-  toolkit_read_value(message,&s,XmRXmString);
-  XmStringExtent(flist,s,&width,&height);
-  message_write_int(reply,width,int_tag);
-  message_write_int(reply,height,int_tag);
-  message_send(client_socket,reply);
-  message_free(reply);
-  must_confirm=False;
-}
-
-int RXmStringFree(message_t message)
-{
-  XmString s;
-
-  toolkit_read_value(message,&s,XmRXmString);
-  XmStringFree(s);
-}
-
-int RXmStringHasSubstring(message_t message)
-{
-  XmString s,subs;
-
-  toolkit_read_value(message,&s,XmRXmString);
-  toolkit_read_value(message,&subs,XmRXmString);
-  reply_with_boolean(message,XmStringHasSubstring(s,subs));
-}
-
-int RXmStringHeight(message_t message)
-{
-  XmFontList flist;
-  XmString s;
-
-  toolkit_read_value(message,&flist,XmRFontList);
-  toolkit_read_value(message,&s,XmRXmString);
-  reply_with_integer(message,XmStringHeight(flist,s));
-}
-
-int RXmStringLength(message_t message)
-{
-  XmString s;
-
-  toolkit_read_value(message,&s,XmRXmString);
-  reply_with_integer(message,XmStringLength(s));
-}
-
-int RXmStringLineCount(message_t message)
-{
-  XmString s;
-
-  toolkit_read_value(message,&s,XmRXmString);
-  reply_with_integer(message,XmStringLineCount(s));
-}
-
-int RXmStringNConcat(message_t message)
-{
-  XmString s1,s2;
-  int bytes;
-
-  toolkit_read_value(message,&s1,XmRXmString);
-  toolkit_read_value(message,&s2,XmRXmString);
-  toolkit_read_value(message,&bytes,XtRInt);
-  reply_with_xmstring(message,XmStringNConcat(s1,s2,bytes));
-}
-
-int RXmStringNCopy(message_t message)
-{
-  XmString s;
-  int bytes;
-
-  toolkit_read_value(message,&s,XmRXmString);
-  toolkit_read_value(message,&bytes,XtRInt);
-  reply_with_xmstring(message,XmStringNCopy(s,bytes));
-}
-
-int RXmStringSeparatorCreate(message_t message)
-{
-  reply_with_xmstring(message,XmStringSeparatorCreate());
-}
-
-int RXmStringWidth(message_t message)
-{
-  XmFontList flist;
-  XmString s;
-
-  toolkit_read_value(message,&flist,XmRFontList);
-  toolkit_read_value(message,&s,XmRXmString);
-  reply_with_integer(message,XmStringWidth(flist,s));
-}
diff --git a/pcl/12-7-88-notes.text b/pcl/12-7-88-notes.text
deleted file mode 100644
index a9405156f729b5e7e86c3dec7a1fcac56103af4d..0000000000000000000000000000000000000000
--- a/pcl/12-7-88-notes.text
+++ /dev/null
@@ -1,45 +0,0 @@
-Copyright (c) Xerox Corporation 1988. All rights reserved.
-
-
-These notes correspond to the "12/7/88  Can't think of a cute name PCL"
-version of PCL.
-
-Please read this entire file carefully.  You may also be interested in
-looking at previous versions of the notes.text file.  These are called
-xxx-notes.text where xxx is the version of the PCL system the file
-corresponds to.  At least the last two versions of this file contain
-useful information for any PCL user.
-
-This version of PCL has been tested at PARC in the following Common
-Lisps:
-
-  Symbolics 7.2
-  Coral 1.2
-  Lucid 3.0
-  KCL (October 15, 1987)
-  Allegro 3.0.1
-
-These three should work, but haven't been tested just yet.
-
-  EnvOS Medley
-  TI
-
-The notes file hasn't yet been fleshed out yet.
-
-The two major changes in this release are:
-
-  - The generic function cache algorithm has been revised.  In addition
-    generic function caches now expand automatically. Programs that used
-    to run into problems with lots of cache misses shouldn't run into
-    those problems anymore. 
-
-  - the DEFCONSTRUCTOR hack now works.  Please see the construct.lisp
-    file for details.  If you are consing lots of instances, you may be
-    able to get a tremendous performance boost by using this hack.
-
-
-Another important change is that this version includes some KCL patches
-which dramatically improve PCL performance in KCL.  See the kcl-mods.text
-file for more details.
-
-
diff --git a/pcl/3-17-88-notes.text b/pcl/3-17-88-notes.text
deleted file mode 100644
index 7602fb07ecb7b9313df462dee1d2eb3fc6ac0c1a..0000000000000000000000000000000000000000
--- a/pcl/3-17-88-notes.text
+++ /dev/null
@@ -1,167 +0,0 @@
-Copyright (c) Xerox Corporation 1988. All rights reserved.
-
-These notes correspond to the beta test release of March 17th 1988.
-Later versions of this release will run in the usual lisps, but for the
-time being this has only been tested in Symbolics, Lucid, Coral,
-Xerox, Ibuki (01/01), TI and VAXLisp Common Lisps.
-
-Note may not run in all Franz Lisps, I believe it runs on the SUN3
-though.  I will get back to this in a few days when I get the needed
-code from Franz.
-
-***
-This release will run in Lucid 3.0 beta 2, with the boolean.lbin patch.
-
-***
-This release contains a prototype implementation of the make-instance
-behavior documented in the CLOS specification (X3J13 document # 88-002).
-This prototype implementation does not provide high performance, but it
-should conform to the specification with one exception, it does not
-check the validity of the initargs.
-
-All the generic functions in the instance creation protocol are as
-specified in the CLOS specification except that make-instance is called
-mki instead.  This name is a temporary name, it is so that people can
-try out the new make-instance protocol without having to convert all
-their code at once.  In a future release, the name make-instance will be
-switched to the new behavior.
-
-***
-Standard method combination is supported.  General declarative
-method combination is not yet supported, so define-method-combination does
-not yet work, but standard method combination is what generic functions
-do by default now.  :after :before :around and unqualified methods are
-supported.  Error checking is minimal.
-
-***
-call-next-method works with standard-method-combination.
-call-next-method is much faster than it was before, and call-next-method
-behaves as a lexically defined function.  This means it is possible to
-pass around funargs which include call-next-method.
-
-***
-All uses of slot-value within a method body should be optimized.  It
-should no longer be necessary to use with-slots just to get the
-optimization.
-
-***
-There are new macros with-slots* and with-accessors*.  These correspond
-to the macros which will appear in the final specification, with-slots
-and with-accessors.  They work as follows:
-
-(with-slots* ((x x-slot)             
-              (y y-slot))         ===\ (let ((#:g1 (foo)))
-             (foo)                ===/   (swapf (slot-value #:g1 'x-slot)
-  (swapf x y))                                  (slot-value #:g1 'y-slot))) 
-
-(with-accessors* ((x position-x)          
-                  (y position-y)) ===\ (let ((#:g1 (foo)))
-                 (foo)            ===/   (incf (position-x #:g1))
-  (incf x)                               (incf (position-y #:g1)))
-  (incf y))
-
-As an abbreviation, the (<variable-name> <slot-name>) pairs in with-slots*
-can be abbreviated to just <variable-and-slot-name> when the variable
-and slot name are the same.  This means that:
-
-(with-slots* (x y z) <instance-form> &body <body>)
-
-is equivalent to:
-
-(with-slots* ((x x) (y y) (z z)) <instance-form> &body <body>)
-
-You should begin to convert your code to use these macros as soon as
-possible since the old macro with-slots will swap names with with-slots*
-sometime soon.
-
-A trick you may want to use for remembering the order of the first two
-arguments to with-slots* and with-accessors* is that it is "like
-multiple-value-bind".
-
-***
-In addition this release includes the beginnings of support for doing
-some of the compiling which PCL does a load time at compile time
-instead.  To use this support, put the form:
-
-  (pcl::precompile-random-code-segments)
-
-in a file which is compiled after all your other pcl using files are
-loaded.  Then arrange for that file to be loaded before all your
-other pcl using files are loaded.
-
-For example, if your system has two files called "classes" and "methods",
-create a new file called "precom" that contains:
-
-  (in-package 'pcl)
- 
-  (pcl::precompile-random-code-segments)
-
-
-Then you can use the defsystem stuff defined in the file defsys to
-maintain your system as follows:
-
-(defsystem my-very-own-system
-	   "/usr/myname/lisp/"
-  ((classes   (precom)           ()                ())
-   (methods   (precom classes)   (classes)         ())
-   (precom    ()                 (classes methods) (classes methods))))
-
-This defsystem should be read as follows:
-
-* Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries
-  should be in the directory "/usr/me/lisp/".  There are three files
-  in the system, there are named classes, methods and precom.  (The
-  extension the filenames have depends on the lisp you are running in.)
-  
-* For the first file, classes, the (precom) in the line means that
-  the file precom should be loaded before this file is loaded.  The
-  first () means that no other files need to be loaded before this
-  file is compiled.  The second () means that changes in other files
-  don't force this file to be recompiled.
-
-* For the second file, methods, the (precom classes) means that both
-  of the files precom and classes must be loaded before this file
-  can be loaded.  The (classes) means that the file classes must be
-  loaded before this file can be compiled.  The () means that changes
-  in other files don't force this file to be recompiled.
-
-* For the third file, precom, the first () means that no other files
-  need to be loaded before this file is loaded.  The first use of
-  (classes methods)  means that both classes and methods must be
-  loaded before this file can be compiled.  The second use of (classes
-  methods) mean that whenever either classes or methods changes precom
-  must be recompiled.
-
-Then you can compile your system with:
-
- (operate-on-system 'my-very-own-system :compile)
-
-and load your system with:
-
- (operate-on-system 'my-very-own-system :load)
-
-***
-The code walker has gone through some signigificant revision.  The
-principle change is that the function walk-form now takes three required
-arguments, and the walk-function itself now must accept an environment
-argument.  There are other changes having to do with the implementation
-specific representation of macroexpansion environments.  For details see
-the file walk.lisp.
-
-***
-The following functions and macros which used to be supported for
-backward compatibility only are now not supported at all:
-
-WITH* and WITH
-
-DEFMETH
-
-GET-SLOT
-
-MAKE
-
-
-***
-There are other small changes in this release.  If you notice one that
-causes you problems please send me a message about it.
-
diff --git a/pcl/3-19-87-notes.text b/pcl/3-19-87-notes.text
deleted file mode 100644
index ce332f63aa6a693e0faa84463153e2bded62b803..0000000000000000000000000000000000000000
--- a/pcl/3-19-87-notes.text
+++ /dev/null
@@ -1,138 +0,0 @@
-
-
-These notes correspond to *pcl-system-date* 3/19/87 prime.
-
-This release runs in:
-  ExCL
-  Lucid
-  Symbolics Common Lisp (Genera)
-  Vaxlisp (2.0)
-  Xerox Common Lisp (Lyric Release)
-
-CMU Lisp (nee Spice) and KCL should be working soon, I will announce
-another release at that time.  I figured it was better to get some
-people beating on it as soon as possibl.
-
-Xerox Lisp users should FTP all the source files from /pub/pcl/ as well
-as all the dfasl files from /pub/pcl/xerox/.  Included in the xerox
-specific directory is a file called PCL-ENV, which provides some simple
-environment support for using PCL in Xerox Lisp.
-
-
-
-Following is a description of some of the things that are different in
-this release of PCL.  This list isn't in any particular order.  There
-are a number of incompatible changes in this release, please read the
-whole thing carefully.
-
-As usual, please enjoy, and send bug-reports, questions etc. to
-CommonLoops@Xerox.com.
-
-***
-The single most significant change is that discriminator-objects with
-corresponding discriminating functions have been replaced by generic
-function objects.  What does this mean??  Well, in previous releases of
-PCL, if you did:
-
-(defmethod foo ((x class)) 'class)
-(defmethod foo ((x method)) 'method)
-
-Then (discriminator-named 'foo) returned a discriminator object which
-had both of these methods defined on it.  (symbol-function 'foo)
-returned a discriminating function, which (discriminator-named 'foo) had
-put in foo's function cell.
-
-In this release of PCL, the above defmethod's put a generic-function
-object in foo's function cell.  This generic-function object is a
-combination of the discriminator object and discriminating function of
-the previous releases of PCL.  This generic-function object is
-funcallable, funcalling it causes the appropriate method to be looked up
-and called.  This generic function object has accessors which return the
-methods defined on the generic function.  This generic function object
-is mutable.  It is possible to add and remove methods from it.
-
-(defmethod foo ((x class)) 'class)
-(defmethod foo ((x method)) 'method)
-
-(generic-function-methods #'foo)
-(#<Method FOO (METHOD) 3434> #<Method FOO (CLASS) 3245>)
-
-(foo (make 'class))  ==> 'class
-(foo (make 'method)) ==> 'method
-
-(remove-method #'foo (car (generic-function-methods #'foo)))
-
-(foo (make 'class))  ==> 'class
-(foo (make 'method)) ==> no matching method error
-
-
-Note that as part of this change, the name of any function, generic
-function or class which included the string "DISCRIMINATOR" has changed.
-The name changes that happened were:
-  The class essential-discriminator was renamed to generic-function,
-  The class basic-discriminator and the class discrimiantor were
-  combined and renamed to standard-generic-function.
-
-If you went through your code and made the following name changes, you
-would probably win, (this is what I did to PCL and it worked).
-
-  essential-discriminator  ==> generic-function
-  basic-discriminator      ==> standard-generic-function
-  discriminator
-    (when it appears as a specializer)
-         ==> standard-generic-function
-  discriminator
-    (when it appears as part of a variable name or something)
-         ==> generic-function
-
-***
-In most Lisp implementations, method lookup is at least twice as fast as
-it was in the previous release.
-
-***
-The compiler isn't called when PCL is loaded anymore.  In a future
-release, the compiler will also not be called when any other method
-definitions are loaded.  This is part of an effort to get PCL to a state
-where the compiler will never be needed when compiled files are loaded.
-
-***
-PCL now has a mechanism for naming the generic-function's and method
-functions defined by defmethod.  This means that in ports of PCL which
-take advantage of this mechanism, you will see useful function names in
-the debugger rather than the useless gensym names that have been in the
-past few releases.
-
-***
-Compiled files containing defmethod forms should be smaller and load
-faster.
-
-***
-Many of the files in the system have been renamed.  More files will be
-renamed in upcoming releases.
-
-***
-An important part of the bootstrapping code has been re-written.  The
-remainder of this code (the BRAID1 and BRAID2 files) will be re-written
-sometime soon.
-
-The changes made to bootstrapping in this release were done to make
-early methods more understandable, and as part of implementing generic
-function objects.  Also, most users should find that PCL loads in less
-time than it did before.
-
-The changes which will be made to bootstrapping in a future release will
-make understanding the "Braid" stuff easier, and will make it possible
-to implement slot-description objects as described in the CURRENT DRAFT
-of the Common Lisp Object System Chapter 3.
-
-***
-The defsys file has been re-written AGAIN.  This shouldn't affect users
-since there are still the old familiar variables *pcl-pathname-defaults*
-and *pathname-extensions*.
-
-***
-The specialized foo-notes files are all gone.  Most of them were
-hopelessly out of date, and installing pcl is now the same operation for
-any Lisp.  In particular, note that in Vaxlisp, it is no longer
-necessary to push lisp:vaxlisp on the *features* list.
-
diff --git a/pcl/4-21-87-notes.text b/pcl/4-21-87-notes.text
deleted file mode 100644
index b1acd73f55c5c5332bcfbd9545218de38e07734f..0000000000000000000000000000000000000000
--- a/pcl/4-21-87-notes.text
+++ /dev/null
@@ -1,53 +0,0 @@
-
-
-These notes correspond to *pcl-system-date* "4/21/87  April 21rst 1987".
-
-The notes from the last release are stored as 3-19-notes.text
-
-This release runs in:
-  ExCL
-  Lucid
-  Symbolics Common Lisp (Genera)
-  Vaxlisp (2.0)
-  Xerox Common Lisp (Lyric Release)
-  Kyoto Common Lisp (5.2)
-
-CMU Lisp (nee Spice) should be working soon, I will announce another
-release at that time.
-
-Xerox Lisp users should FTP all the source files from /pub/pcl/ as well
-as all the dfasl files from /pub/pcl/xerox/.  Included in the xerox
-specific directory is a file called PCL-ENV, which provides some simple
-environment support for using PCL in Xerox Lisp.
-
-
-The major difference in this release is that defclass conforms to the
-CLOS specification (pretty much I hope).  Previous warnings about what
-would happen when defclass became CLOS defclass now apply.  Once major
-difference is that PCL currently does require that all a classes
-superclasses be defined when a defclass form is evaluated.  This will
-change sometime soon.
-
-Other small changes include:
-
-Some more of the files have been renamed and restructured (as promised).
-
-the defclass parsing protocol has changed
-
-slotd datastructures are now instances of the class
-standard-slot-description.
-
-a performance bug in the ExCL port which causes method lookup and slot
-access to cons needlessly.
-
-a bug in the 3600 port which broke the printer for stack consed closures
-
-make-specializable
-
-a bug in Lucid lisp which made it impossible to say (compile-pcl) has
-been patched around, this is the bug that manifested itself as NAME
-being ubound.
-
-
-As usual, please enjoy and send comments.
-
diff --git a/pcl/4-29-87-notes.text b/pcl/4-29-87-notes.text
deleted file mode 100644
index 307b86e860133d510a382135f74b9884c28f4d48..0000000000000000000000000000000000000000
--- a/pcl/4-29-87-notes.text
+++ /dev/null
@@ -1,80 +0,0 @@
-
-
-These notes correspond to *pcl-system-date* "4/29/87 prime April 29, 1987". 
-
-The notes from the last release are stored as 4-21-notes.text
-
-This release runs in:
-  ExCL
-  Lucid
-  Symbolics Common Lisp (Genera)
-  Vaxlisp (2.0)
-  Xerox Common Lisp (Lyric Release)
-  Kyoto Common Lisp (5.2)
-  TI Common Lisp (Release 3)
-
-CMU Lisp (nee Spice) should be working soon, I will announce another
-release at that time.
-
-TI release 2 should also be working soon, I will announce that when it
-happens.
-
-
-Note once again, that Xerox Lisp users should FTP all the source files
-from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/.
-Included in the xerox specific directory is a file called PCL-ENV, which
-provides some simple environment support for using PCL in Xerox Lisp.
-You must load PCL BEFORE loading pcl-env.
-
-
-MAJOR CHANGES IN THIS RELEASE:  
-
-  make has been renamed to make-instance
-
-  make-instance has been renamed to allocate-instance
-
-for compatibility, make can continue to be used as a synonym for
-make-instance.  unfortunately, code which used to call make-instance
-must be converted.
-
-I would actually suggest that you do both of these name changes right
-away.  Two passes through the code using Query Replace seems to work
-quite well (changing make-instance to allocate-instance and then make to
-make-instance.)  I was able to change all of PCL in about 10 minutes
-that way.
-
----
-
-all functions and generic functions whose name included the string
-"get-slot" have been renamed.  Basically, get-slot was replaced
-everywhere it appeared with slot-value.
-
-get-slot itself still exists for compatibility, but you should start
-converting your code to use slot-value.
-
-
-
-OTHER CHANGES in this release:
-
-There is a new file called PKG which does the exports for PCL.  PCL now
-exports fewer symbols than before.  Specifically, PCL now exports only
-those symbols documented in the CLOS spec chapters 1 and 2.  This means
-that some symbols which may be needed by some programs are not exported.
-
-A good example is print-instance.  print-instance is not exported and
-since print-instance has not yet been renamed to print-object programs
-which define methods on print-instance may want to import that symbol.
-
----
-
-pcl should load faster in this release.  In particular, the file fixup
-should load in less than half the time it did before.  This release
-should load in something like 80% of the time it took in the last
-release.  Remember, these numbers are only for comparison, your mileage
-may vary.
-
----
-
-This release of PCL, as well as the last one, has *pcl-system-date*
-which presents the date in both mm/dd/yy and  Month day year format.
-
diff --git a/pcl/5-22-87-notes.text b/pcl/5-22-87-notes.text
deleted file mode 100644
index 01aed9fd099ffe4a50743b03db6caa5b20ea07db..0000000000000000000000000000000000000000
--- a/pcl/5-22-87-notes.text
+++ /dev/null
@@ -1,126 +0,0 @@
-
-
-These notes correspond to *pcl-system-date* "5/22/87   May 22nd, 1987".
-
-The notes from the last release are stored as 4-29-notes.text
-
-This release runs in:
-  CMU Lisp
-  ExCL
-  Lucid
-  Symbolics Common Lisp (Genera)
-  Vaxlisp (2.0)
-  Xerox Common Lisp (Lyric Release)
-  Kyoto Common Lisp (5.2)
-  TI Common Lisp (Release 3)
-
-TI release 2 should also be working soon, I will announce that when it
-happens.
-
-
-Note once again, that Xerox Lisp users should FTP all the source files
-from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/.
-Included in the xerox specific directory is a file called PCL-ENV, which
-provides some simple environment support for using PCL in Xerox Lisp.
-You must load PCL BEFORE loading pcl-env.
-
-
-MAJOR CHANGES IN THIS RELEASE:  
-
----
-  it is possible to forward reference classes in a defclass (or
-  add-named-class) form.  This means it is possible to say:
-
-  (defclass foo (bar) (i j k))
-
-  (defclass bar () (x y z))
-
-  Rather than having to put the in the "right" order.
-
-  NOTE: the full-on error checking for this is not finished yet.
-        don't try to break it by doing things like:
-
-  (defclass foo (bar) (i j k))
-  (make-instance 'foo)
-  (defclass bar () (x y z))
-
----
-  print-instance has been renamed to print-object
-
----
-  the defclass and class-definition protocol has changed.  some of the
-effects of this change are:
-
-* ADD-NAMED-CLASS is a true functional interface for defclass, so for
-  example,
-
-  (defclass foo () (x y z) (:accessor-prefix foo-))
-
-  is equivalent to:
-
-  (add-named-class (class-prototype (class-named 'class))
-                   'foo
-                   ()
-                   '(x y z)
-                   '((:accessor-prefix foo-)))
-
-* defclass (and add-named-class) now undefined accessor methods, reader
-  methods and constructors which 'went away'.  For example:
-
-  (defclass foo () (x y z) (:reader-prefix foo-))
-
-  defines methods on the generic functions foo-x foo-y and foo-z.
-
-  but if you then evaluated the defclass form:
-
-  (defclass foo () (x y z))
-
-  those reader methods will be removed from the generic functions
-  foo-x foo-y and foo-z.
-
-  Similarly constructors which 'went away' will be undefined.
-
----
-  writer methods generated by the :accessor and :accessor-prefix options
-  now pay attention to the :type slot-option.  So,
-
-  (defclass foo () ((x :accessor foo-x :type symbol)))
-
-  (defvar *foo-1* (make-instance 'foo))
-
-  (setf (foo-x *foo-1*) 'bar)  ; is OK
-
-  (setf (foo-x *foo-1*) 10)    ; signals an error
-
----
-  There are fewer built-in classes.  Specifically, only the following
-  Common Lisp types have classes:
-
-  ARRAY BIT-VECTOR CHARACTER COMPLEX CONS FLOAT INTEGER LIST
-  NULL NUMBER RATIO RATIONAL SEQUENCE STRING SYMBOL T VECTOR
-
-* In a future release the subtypes of FLOAT may have classes, that issue
-  is still under discussion.
-
-* Some ports of PCL also define classes for:
-
-  HASH-TABLE PACKAGE PATHNAME RANDOM-STATE READTABLE STREAM
-
-  it depends on how the type is represented in that Lisp's type system.
-
-
----
-  The with-slots option :use-slot-value is now obsolete.  You should use
-  the :use-accessors option as specified in the CLOS spec instead.
-
-  with-slot forms which did not use the :use-slot-value option are OK,
-  you don't have to touch them.
-
-  with-slot forms which used :USE-SLOT-VALUE T should be changed to say
-  :USE-ACCESSORS NIL.
-
-  with-slot forms which used :USE-SLOT-VALUE NIL should be changed to
-  use neither option, or if you insist :USE-ACCESSORS T
-
-
-
diff --git a/pcl/5-22-89-notes.text b/pcl/5-22-89-notes.text
deleted file mode 100644
index 3f198d8a1d9744f1782846e38f3ef020c5d391d6..0000000000000000000000000000000000000000
--- a/pcl/5-22-89-notes.text
+++ /dev/null
@@ -1,152 +0,0 @@
-Copyright (c) Xerox Corporation 1989. All rights reserved.
-
-These notes correspond to the "5/22/89 Victoria PCL" version of PCL.
-
-Please read this entire file carefully.  Failure to do so guarantees
-that you will have problems porting your code from the previous release
-of PCL.
-
-You may also be interested in looking at previous versions of the
-notes.text file.  These are called xxx-notes.text where xxx is the
-version of the PCL system the file corresponds to.  At least the last
-two versions of this file contain useful information for any PCL user.
-
-This version of PCL has been tested at PARC in the following Common
-Lisps:
-
-  Symbolics 7.2, 7.4
-  Coral 1.2
-  Lucid 3.0
-  IBCL (October 15, 1987)
-  Allegro 3.0.1
-  Golden Common Lisp 3.1
-  EnvOS Medley
-
-These should work, but haven't been tested yet:
-
-  TI
-
-This release is similar to Cinco de Mayo and Passover PCL.  The major
-difference is that this release actually works.
-
-***
-
-*other-exports* flushed.  More exports now on *exports*
-
-The symbol STANDARD is now exported from the PCL package. standard-class
-standard-method standard-generic-function standard-object built-in-class
-structure-class
-
-scoping problem with *next-methods*
-
-
-method and generic function initialization protocol
-
-methods are immutable
-
-type-specifiers --> specializers
-
-load-truename etc.
-
-defgeneric ensure-generic-function define-method-combination
-
-metabraid changes
-
-file namings
-
-***
-
-There are a number of minor and one major difference between this
-release and No Cute Name PCL.
-
-
-- In the last release there was an implementation of the specified CLOS
-initialization protocol.  This implementation had the correct behavior,
-but some of the generic functions had temporary names (*make-instance,
-*initialize-instance and *default-initargs).  This was done to give
-people time to convert their code to the behavior of the new
-initialization protocol.
-
-In this release, all generic functions in the specified initialization
-protocol have their proper names.  The implementation of the old,
-obsolete initialization protocol has disappeared entirely.
-
-The following renamings have happened:
-
-  12/7/88 release                this release
-
-  *make-instance                 make-instance
-  *initialize-instance           initialize-instance
-  *default-initargs              default-initargs
-
-The functions shared-initialize and reinitialize-instance already had
-the proper names.
-
-The new initialization protocol is documented fully in the 88-002R
-specification.
-
-As part of this change, PCL now uses the new initialization protocol to
-create metaobjects internally.  That is it calls make-instance to create
-these metaobjects.  The actual initargs passed are not yet as specified,
-that will be in a later release.
-
-This is the largest change in this release.  If you have not already
-started using the new initialization protocol (with the temporary *xxx
-names) you are going to have to do so now.  In most cases, old methods
-on the generic functions INITIALIZE, INITIALIZE-FROM-DEFAULTS and
-INITIALIZE-FROM-INIT-PLIST must be substantially rewritten to convert
-them to methods on INITIALIZE and SHARED-INITIALIZE.
-
-- slots with :ALLOCATION, :CLASS now inherit properly.  As part of this
-change, some slot description objects now return a class object as the
-result of SLOTD-ALLOCATION.
-
-- There is now a minimal implementation of the DEFGENERIC macro.  This
-implementation supports no options, but it does allow you to define a
-generic function in one place and put some comments there with it.
-
-- The following functions and macros have disappeared.  This table also
-  show briefly what you use instead.
-
-    DEFMETHOD-SETF               (use DEFMETHOD)
-    RUN-SUPER                    (use CALL-NEXT-METHOD)
-    OBSOLETE-WITH-SLOTS          (use WITH-SLOTS or WITH-ACCESSORS)
-    SYMBOL-CLASS                 (use FIND-CLASS)
-    CBOUNDP                      (use FIND-CLASS)
-    CLASS-NAMED                  (use FIND-CLASS)
-    GET-SETF-GENERIC-FUNCTION    (use GDEFINITION)
-
-- In certain ports, method lookup will be faster because of a new scheme
-to deal with interrupts and the cache code.  In other ports it will be
-slightly slower.  In all ports, the cache code now interacts properly
-with interrupts.
-
-- DEFMETHOD should interact properly with TRACE, ADVISE etc. in most
-ports.  two new port-specific functions (in defs.lisp) implement this.
-These are unencapsulated-fdefinition and fdefine-carefully.  If this
-doesn't work properly in your port, fix the definition of these
-functions and send it back so it can be in the next release.
-
-- This release runs in Golden Common Lisp version 3.0.
-
-- Previously, the use of slot-value (or with-slots) in the body of a
-method which had an illegal specializer gave strange errors.  Now it
-gives a more reasonable error message.
-
-- An annoying problem which caused KCL and friends to complain about
-*exports* being unbound has been fixed.
-
-- The walker has been modified to understand the ccl:%stack-block
-special form in Coral Common Lisp.
-
-- The use of defadvice in pre 3.0 releases has been fixed in Lucid Low.
-
-- multiple-value-setq inside of with-slots now returns the correct
-value.
-
-- A minor bug having to do with macroexpansion environments and the KCL
-walker has been fixed.
-
-- A bug in the parsing of defmethod which caused only symbols (rather
-than non-nil atoms) to be used as qualifiers.
-
diff --git a/pcl/8-28-88-notes.text b/pcl/8-28-88-notes.text
deleted file mode 100644
index 854a90bcf9898db40fd430550e881b3419d6f916..0000000000000000000000000000000000000000
--- a/pcl/8-28-88-notes.text
+++ /dev/null
@@ -1,537 +0,0 @@
-Copyright (c) Xerox Corporation 1988. All rights reserved.
-
-
-These notes correspond to the "8/24/88 (beta) AAAI PCL" version of PCL.
-
-Please read this entire document carefully.
-
-There have been a number of changes since the 8/2/88 version of PCL.  As
-usual, these changes are part of our efforts to make PCL conform with
-the CLOS specicification (88-002R).  This release contains the big
-changes which the 7/7 through 8/2 releases were really getting ready
-for.
-
-This version of PCL has been tested at PARC in the following Common
-Lisps:
-
-  Symbolics 7.2
-  Coral 1.2
-  Lucid 3.0
-  Franz ??
-  Xerox Lyric
-  Xerox Medley (aka EnvOS Medley)
-  KCL (October 15, 1987)
-
-
-Most of the changes in this version of PCL fall into one of two
-categories.
-
-The first major set of changes makes the order of arguments to setf
-generic functions and methods conform with the spec.  In addition, these
-changes allow the first argument to defmethod to be of the form (SETF
-<symbol>).
-
-The second major set of changes have to do with slot access and instance
-structure.  Importantly, PCL now checks to see if a slot is bound, and
-calls slot-unbound if the slot is unbound.  This is a major change from
-previous releases in which slot access just returned NIL for slots which
-had not yet been set.  These changes affect all the functions which
-access the slots of an instance.  In addition, the generic functions
-which are called by the slot access functions in exceptional
-circumstances are affected.  This set of changes also include the
-implemenentation of the real initialization protocol as specified by
-88-002R.
-
-In addition, there are a number of other changes.  The most significant
-of these has to do with the symbols which the PCL package exports by
-default.
-
-The rest of this document goes on to first describe the slot access
-changes, then describe the setf generic function changes, and finally
-describe some of the other minor changes.  
-
-At the very end of this file is a new section which lists PCL features
-which are scheduled to disappear in future releases.  Please read this
-section and take it to heart.  This features will be disappearing.
-
-
-*** Changes to slot access and instance structure ***
-
-This release includes a number of changes to the way slot access works
-in PCL.  Some of these changes are incompatible with old behavior.  Code
-which was written with the actual CLOS spec in mind should not be
-affected by these incompatible changes, but some older code may be
-affected.
-
-The basic thrust of the changes to slot access is to bring the following
-functions and generic functions in line with the specification:
-
-   slot-boundp
-   slot-exists-p
-   slot-makunbound
-   slot-missing      
-   slot-unbound
-   slot-value     
-
-   slot-boundp-using-class
-   slot-exists-p-using-class
-   slot-makunbound-using-class
-   slot-value-using-class
-
-   (setf slot-value)
-   (setf slot-value-using-class)
-
-   change-class
-   make-instances-obsolete
-
-   make-instance (temporarily called *make-instance)
-   initialize-instance (temporarily called *initialize-instance)
-   reinitialize-instance
-   update-instance-for-different-class
-   update-instance-for-redefined-class
-   shared-initialize
-
-In this release, these functions accept the specified number of
-arguments, return the specified values, have the specified effects, and
-are called by the rest of PCL in the specified way at the specified
-times (with the exception that PCL does not yet call *make-instance to
-create its own metaobjects).  Because PCL now checks for unbound slots,
-you may notice a slight performance degradation in certain applications.
-
-For complete information, you should of course see the CLOS specification.
-The rest of this note is a short summary of how this new behavior is
-different from the last release.
-
-- Dynamic slots are no longer supported.  Various functions like
-  slot-value-always and remove-slot no longer exist.  Also,
-  slot-value-using-class now only accepts the three arguments as
-  described in the spec.  The two extra arguments having to do with
-  dynamic slots are no longer accepted.
-
-  Shortly, we will release a metaclass which provides the now missing
-  dynamic slot behavior.
-
-- slot-missing now receives and accepts different arguments.
-
-- slot-unbound is now implemented, and is called at the appropriate
-  times.
-
-- the initialization protocol specified in 88-002R is now almost
-  completely implemented.  The only difference is that the current
-  implementation does not currently check the validity of initargs.
-  So, no errors are signalled in improper initargs are supplied.
-
-  Because of name conflicts with the two other initialization protocols
-  PCL currently supports, some of the specified initialization functions
-  do not have their proper name.  The mapping between names in the
-  specification and names in this version of PCL is as follows:
-
-     SPECIFIED                                IN PCL
-
-   make-instance                           *make-instance
-   initialize-instance                     *initialize-instance
-   reinitialize-instance                   <has proper name>
-   update-instance-for-different-class     <has proper name>
-   update-instance-for-redefined-class     <has proper name>
-   shared-initialize                       <has proper name>
-
-
-  In a future release of PCL, these functions will have their proper
-  names, and all the old, obsolete initialization protocols will
-  disappear.
-
-  Convert to using this new wonderful initialization protocol soon.
-
-  Sometime soon we will release a version of PCL which does significant
-  optimization of calls to make-instance.  This should speed up instance
-  creation dramatically, which should significantly improve the
-  performance of some programs.
-
-- The function all-slots no longer exists.  There is a new generic
-  function called slots-to-inspect, which controls the default behavior
-  of describe.  It also controls the default behavior of the inspector
-  in ports which have connected their inspectors to PCL.  It specifies
-  which slots of a given class should be inspected.  See the definition
-  in the file high.lisp for more.
-
-- the metaclass obsolete-class no longer exists.  The mechanism by which
-  instances are marked as being obsolete is now internal, as described
-  in the spec.  The generic-function make-instances-obsolete can be used
-  to force the instances of a class to go through the obsolete instance
-  update protocol (see update-instance-for-redefined-class).
-
-- all-std-class-readers-miss-1, a generic function which was part of
-  the database interface code I sent out a few weeks ago, has a slightly
-  different argument list.  People using the code I sent out a few weeks
-  ago should replace the definition there with:
-
-  (defmethod all-std-class-readers-miss-1
-	     ((class db-class) wrapper slot-name)
-    (declare (ignore wrapper slot-name))
-    ())
-
-- The implementation of the slot access generic functions have been
-  considerably streamlined.  The impenetrable macrology which used to be
-  used is now gone.
-
-- Because the behavior of the underlying slot access generic functions
-  has changed, it is possible that some user code which hacks the
-  underlying instance structure may break.  Most of this code shouldn't
-  break though.  There have been some questions on the mailing list
-  about what is the right way to modify the structure of an instance.
-  I am working on that section of chapter 3 right now, and will answer
-  those questions sometime soon.
-
-
-*** Changes to SETF generic functions ***
-
-This release of PCL includes a significant change related to the order
-of arguments of setf generic functions.  To most user programs, this
-change should be invisible.  Your program should run just fine in the
-new version of PCL.  Even so, there is some conversion you should do to
-your program, since DEFMETHOD-SETF is now obsolete and will be going
-away soon.
-
-Some programs may take some work to adapt to this change.  This will
-be particularly true of programs which manipulated methods for setf
-generic-functions using make-instance, add-method and friends.
-
-Included here is a brief overview of this change to PCL.  Most people
-will find that this is all they need to know about this change.
-
-The CLOS specification assumes a default behavior for SETF in the
-absence of any defsetf or define-modify-macro.  The default behavior is
-to expand forms like:
-
-   (SETF (FOO x y) a)
-
-into:
-
-   (FUNCALL #'(SETF FOO) a x y)
-
-The key point is that by default, setf expands into a call to a function
-with a well-defined name, and that in that call, the new value argument
-comes before all the other arguments.
-
-This requires a change in PCL, because previously, PCL arranged for the
-new-value argument to be the last required argument.  This change
-affects the way automatically generated writer methods work, and the way
-that defmethod with a first argument of the form (SETF <symbol>) works.
-
-An important point is that I cannot implement function names of the form
-(SETF <symbol>) portably in PCL.  As a result, in PCL, I am using names
-of the form |SETF FOO|.  Note that the symbol |SETF FOO| is interned in
-the home package of the symbol FOO.  (See the description of the
-GET-SETF-FUNCTION and GET-SETF-FUNCTION-NAME).
-
-
-The user-visible changes are:
-
-- DEFMETHOD will accept lists of the form (SETF FOO) as a first
-  argument.  This will define methods on the generic function named
-  by the symbol |SETF FOO|.  As specified in the spec, these methods
-  should expect to receive the new-value as their first argument.
-  Calls to defmethod of this form will also arrange for SETF of FOO to
-  expand into an appropriate call to |SETF FOO|.
-
-- Automatically generated writer methods will expect to receive the new
-  value as their first argument.
-
-- DEFMETHOD-SETF will also place the new-value as the first argument.
-  This is for backward compatibility, since defmethod-setf itself will
-  be obsolete, and you should convert your code to stop using it.
-
-- GET-SETF-FUNCTION is a function which takes a function name and
-  returns the setf function for that function if there is one.  Note
-  that it doesn't take an environment argument.  Note that this function
-  is not specified in Common Lisp or CLOS.  PCL will continue to support
-  it as an extra export indefinetely.
-
-- GET-SETF-FUNCTION-NAME is a function which takes a function name
-  and returns the symbol which names the setf function for that
-  function.  Note that this function  is not specified in Common Lisp
-  or CLOS.  PCL will continue to support it as an extra export
-  indefinetely. 
-
-- For convenience, PCL defines a macro called DO-STANDARD-DEFSETF which
-  can be used to do the appropriate defsetf.  This may be helpful for
-  programs which have calls to setf of a generic-function before any
-  of the generic function's method definitions.  A use of this macro
-  looks like:
-
-     (do-standard-defsetf position-x)
-
-  Afterwards, a form like (SETF (POSITION-X P) V) will expand into a
-  form like (|SETF POSITION-X| V P).
-
-  The reason you may have to use do-standard-defsetf is that I cannot
-  portably change every implementations SETF to have the new default
-  behavior.  The proper way to use this is to take an early file in
-  your system, and put a bunch of calls to do-standard-defsetf in it.
-  Note that as soon as PCL sees a defmethod with a name argument of
-  the form (SETF FOO), or it sees a :accessor in a defclass, it will
-  do an appropriate do-standard-defsetf for you.
-
-
-In summary, the only things that will need to be changed in most
-programs is that uses of defmethod-setf should be converted to
-appropriate uses of defmethod.
-
-Here is an example of a typical user program which is affected by this
-change.  
-
-(defclass position ()
-    ((x :initform 0 :accessor pos-x)
-     (y :initform 0 :accessor pos-y)))
-
-(defclass monitored-position (position)
-    ())
-
-(defmethod-setf pos-x :before ((p monitored-position)) (new)
-  (format *trace-output* "~&Changing x coord of ~S to ~D." p new))
-
-(defmethod-setf pos-y :before ((p monitored-position)) (new)
-  (format *trace-output* "~&Changing y coord of ~S to ~D." p new))
-
-
-To bring this program up to date, you should convert the two
-defmethod-setf forms as follows:
-
-(defmethod (setf pos-x) :before (new (p monitored-position))
-  (format *trace-output* "~&Changing x coord of ~S to ~D." p new))
-
-(defmethod (setf pos-y) :before (new (p monitored-position))
-  (format *trace-output* "~&Changing y coord of ~S to ~D." p new))
-
-
-*** Other changes in this release ***
-
-* The symbols exported by the PCL package have now changed.  The PCL
-package now exports the symbols listed in the table of contents of
-chapter 2 of the spec.  This list of symbols is the value of the
-variable pcl::*exports*.
-
-Following is the list of symbols which were exported in the 8/2/88
-version but which are not exported in the 8/18/88 version.
-
-DEFMETHOD-SETF      DEFGENERIC-OPTIONS      DEFGENERIC-OPTIONS-SETF
-CLASS-CHANGED       CLASS-NAMED             SYMBOL-CLASS
-CBOUNDP             GET-METHOD              GET-SETF-GENERIC-FUNCTION
-MAKE-METHOD-CALL 
-
-Following is the list of symbols which are exported in the 8/18/88
-version, but which were not exported in previous versions:
-
-CALL-METHOD         CLASS-NAME              COMPUTE-APPLICABLE-METHODS
-DEFGENERIC          ENSURE-GENERIC-FUNCTION FIND-METHOD
-FUNCTION-KEYWORDS   GENERIC-FLET            GENERIC-LABELS
-INITIALIZE-INSTANCE MAKE-INSTANCES-OBSOLETE NO-APPLICABLE-METHOD
-NO-NEXT-METHOD      REINITIALIZE-INSTANCE   SHARED-INITIALIZE
-SLOT-BOUNDP         SLOT-EXISTS-P           SLOT-MAKUNBOUND
-SLOT-MISSING        SLOT-UNBOUND            SYMBOL-MACROLET
-UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
-UPDATE-INSTANCE-FOR-REDEFINED-CLASS
-WITH-ADDED-METHODS
-
-It should be noted that not all of these newly exported symbols have
-been "implemented" yet.
-
-
-* Any program written using PCL will need to be completely recompiled
-to run with this release of PCL.
-
-* The generic-function generic-function-pretty-arglist now returns a
-nice arglist for any generic function.  It combines all the keyword
-arguments accepted by the methods to get the combined set of keywords.
-In some ports, the environment specific ARGLIST function has been
-connected to this, and so the environments will print out nice arglists
-for generic functions.
-
-* Some bugs in trace-method have been fixed.  Trace-method should now
-work in all ports of PCL.
-
-* NO-MATCHING-METHOD has been renamed to NO-APPLICABLE-METHOD.  In
-addition, it now receives arguments as specified.
-
-* defmethod has been modified to allow macros which expand into
-declarations.
-
-* The :documentation slot option is now accepted in defclass forms.  The
-documentation string put here cannot yet be retrieved using the
-documentation function.  That will happen in a later release.
-
-* The :writer slot option is now implemented.
-
-* Some brain damage in high.lisp which caused method lookup to work
-incorrectly for built in classes.  In addition, it caused the
-class-local-supers and class-direct-subclasses of the built in classes
-to be strange.  People using CLOS browsers should notice this change
-dramatically, as it will make the browse of the built in part of the
-class lattice look right.
-
-
-*** Older Changes ***
-
-Following are changes which appeared in release of PCL from 7/7/88 to
-8/2/88.  Each change is marked with the release it appeared in.
-
-
-
-8/2/88
-Loading defclass forms should be much faster now.  The bug which caused
-all the generic functions in the world to be invalidated whenever a
-class was defined has now been fixed.
-
-Loading defmethod forms should also be much faster.  A bug which caused
-a tremendous amount of needles computation whenever a method was also
-fixed.
-
-
-
-8/2/88
-A bug which caused several slots of the classes T, OBJECT, CLASS and
-STANDARD-CLASS to be unbound has been fixed.
-
-
-
-8/1/88
-load-pcl now adds the symbols :PCL and :PORTABLE-COMMONLOOPS to
-*features*.
-
-PCL still doesn't do any sort of call to PROVIDE because of the total
-lack of uniformity in the behavior of require and provide in the various
-common lisp implementations.
-
-
-8/1/88
-This version of PCL finally fixes the horrible bug that prevented
-the initform for :class allocation slots from being evaluated when the
-class was defined.
-
-
-7/20/88
-PCL now converts the function describe into a generic function of one
-argument.  This is to bring it into conformance with the spec as
-described in 88-002.
-
-In Symbolics Genera, it is actually a function of one required and one
-optional argument.  This is because the 3600 sometimes calls describe
-with more than one argument.
-
-In Lucid Lisp, describe only takes an optional argument.  This argument
-defaults to the value of *.  PCL converts describe to a generic function
-of one required argument so it is not possible to call describe with
-only one argument.
-
-
-7/7/88
-class-named and symbol-class have been replaced by find-class.
-find-class is documented in 88-002R.
-
-
-7/7/88
-with-slots and with-accessors now conform to 88-002R.
-
-The old definition of with-slots is now called obsolete-with-slots.  The
-same is true for with-accessors.
-
-   with-slots    ---> obsolete-with-slots
-   with-accessors --> obsolete-with-accessors
-
-The temporary correct definition of with-slots, with-slots* is now
-called with-slots. The same is true for with-accessors*.
-
-   with-slots*    --> with-slots
-   with-accessors* -> with-accessors
-
-
-7/7/88
-The class-precedence list of the class null now conforms to 88-002R.
-
-In previous releases of PCL, the class precedence-list of the class
-null was: (null list symbol sequence t).  In this release the class
-precedence list of the class null is: (null symbol list sequence t).
-
-This change was made to bring PCL into conformance with the spec.
-
-
-
-7/7/88
-
-print-object now takes only two arguments.
-
-This changes was made to begin bringing print-object in conformance with
-88-002R.  print-object conforms to the spec to the extent that is is
-called at the approrpiate times for PCL instances.  In most
-implementations, it is not called at the appropriate times for other
-instances.  This is not under my control, encourage your vendor to
-provide the proper support for print-object.
-
-
-7/7/88
-This version of PCL now includes a beta test version of a new iteration
-package.  This iteration package was designed by Pavel Curtis and
-implemented by Bill vanMelle.  This iteration package is defined in the
-file iterate.lisp.  Please feel free to experiment with it.  We are all
-very interested in comments on its use.
-
-
-
-*** PCL Features that will be disappearing ***
-
-This section describes features in PCL that will be disappearing in
-future releases.  For each change, I try to give a release date after
-which I will feel free to remove this feature.  This list should not be
-considered complete.  Certain other PCL features will disappear as well.
-The items on this list are the user-interface level items that it is
-possible to give a lot of warning about.  Other changes will have more
-subtle effects, for example when the lambda-list congruence rules are
-implemented.
-
-- :accessor-prefix in defclass 
-
-Can disappear anytime after 8/29.
-
-Warning that this is obsolete has been out for some time.  You should
-use :accessor in each of the slot specifications of the defclass form.
-It is true that this is slightly more cumbersome, but the semantic
-difficulties associated with :accesor-prefix are even worse.
-
-- :constructor in defclass
-
-Can disappear anytime after 8/29.
-
-Warning that this is obsolete has been out for some time.  It will be
-disappearing shortly because the intialization protocol which it goes
-with will be disappearing.  A future release of PCL will support a
-special mechanism for defining functions of the form:
-
-(defun make-foo (x y &optional z)
-  (make-instance 'foo 'x x :y y :z z))
-
-In the case where there are only :after methods on initialize-instance
-and shared-initialize, these functions will run like the wind.  We hope
-to release this facility by 9/15.
-
-- old definition of make-instance, intialize, initialize-from-defaults,
-  initialize-from-init-plist
-
-Can disappear anytime after 8/29.
-
-Convert to using the new initialization protocol as described in the
-spec and above.
-
-- mki, old definition of initialize-instance
-
-Can disappear anytime after 8/29.
-
-Convert to using the new initialization protocol as described in the
-spec and above.
-
-- defmethod-setf
-
-Can disappear anytime after 9/15.
-
-Convert to using (defmethod (setf foo) ...
-
-
diff --git a/pcl/RCSSNAP.last-merge b/pcl/RCSSNAP.last-merge
deleted file mode 100644
index f52f08ee4a4ec46f50b650267a124a501deda53f..0000000000000000000000000000000000000000
--- a/pcl/RCSSNAP.last-merge
+++ /dev/null
@@ -1,84 +0,0 @@
-./RCS/12-7-88-notes.text,v	1.1
-./RCS/3-17-88-notes.text,v	1.1
-./RCS/3-19-87-notes.text,v	1.1
-./RCS/4-21-87-notes.text,v	1.1
-./RCS/4-29-87-notes.text,v	1.1
-./RCS/5-22-87-notes.text,v	1.1
-./RCS/5-22-89-notes.text,v	1.1
-./RCS/8-28-88-notes.text,v	1.1
-./RCS/boot.lisp,v	1.3
-./RCS/braid.lisp,v	1.2
-./RCS/cache.lisp,v	1.2
-./RCS/cloe-low.lisp,v	1.1
-./RCS/cmu-low.lisp,v	1.6
-./RCS/cmu-low.pmaxf,v	1.1
-./RCS/combin.lisp,v	1.2
-./RCS/combin.pmaxf,v	1.1
-./RCS/compat.lisp,v	1.2
-./RCS/compat.pmaxf,v	1.1
-./RCS/construct.lisp,v	1.3
-./RCS/construct.pmaxf,v	1.1
-./RCS/coral-low.lisp,v	1.2
-./RCS/cpatch.lisp,v	1.2
-./RCS/cpl.lisp,v	1.2
-./RCS/cpl.pmaxf,v	1.1
-./RCS/ctypes.lisp,v	1.2
-./RCS/ctypes.pmaxf,v	1.1
-./RCS/defclass.lisp,v	1.5
-./RCS/defcombin.lisp,v	1.2
-./RCS/defs.lisp,v	1.4
-./RCS/defsys.lisp,v	1.4
-./RCS/dfun.lisp,v	1.2
-./RCS/dlap.lisp,v	1.2
-./RCS/env.lisp,v	1.3
-./RCS/excl-low.lisp,v	1.2
-./RCS/fin.lisp,v	1.5
-./RCS/fixup.lisp,v	1.2
-./RCS/fngen.lisp,v	1.2
-./RCS/fsc.lisp,v	1.2
-./RCS/gcl-patches.lisp,v	1.2
-./RCS/genera-low.lisp,v	1.2
-./RCS/get-pcl.text,v	1.2
-./RCS/gold-low.lisp,v	1.2
-./RCS/hp-low.lisp,v	1.2
-./RCS/ibcl-low.lisp,v	1.2
-./RCS/ibcl-patches.lisp,v	1.2
-./RCS/init.lisp,v	1.2
-./RCS/iterate.lisp,v	1.2
-./RCS/kcl-low.lisp,v	1.2
-./RCS/kcl-mods.text,v	1.2
-./RCS/kcl-notes.text,v	1.1
-./RCS/kcl-patches.lisp,v	1.2
-./RCS/lap.lisp,v	1.3
-./RCS/lap.text,v	1.2
-./RCS/low.lisp,v	1.2
-./RCS/lucid-low.lisp,v	1.2
-./RCS/macros.lisp,v	1.2
-./RCS/methods.lisp,v	1.2
-./RCS/notes.text,v	1.1
-./RCS/pcl-env-internal.lisp,v	1.2
-./RCS/pcl-env.lisp,v	1.2
-./RCS/pcl-env.text,v	1.2
-./RCS/pclcom.lisp,v	1.1
-./RCS/pclload.lisp,v	1.2
-./RCS/pkg.lisp,v	1.3
-./RCS/plap.lisp,v	1.4
-./RCS/precom1.lisp,v	1.2
-./RCS/precom2.lisp,v	1.2
-./RCS/precom4.lisp,v	1.2
-./RCS/pyr-low.lisp,v	1.2
-./RCS/pyr-patches.lisp,v	1.2
-./RCS/quadlap.lisp,v	1.2
-./RCS/readme.text,v	1.2
-./RCS/rel-7-2-patches.lisp,v	1.2
-./RCS/rel-8-patches.lisp,v	1.1
-./RCS/slots.lisp,v	1.2
-./RCS/std-class.lisp,v	1.2
-./RCS/sysdef.lisp,v	1.1
-./RCS/ti-low.lisp,v	1.2
-./RCS/ti-patches.lisp,v	1.2
-./RCS/vaxl-low.lisp,v	1.2
-./RCS/vector.lisp,v	1.2
-./RCS/walk.lisp,v	1.5
-./RCS/xerox-low.lisp,v	1.2
-./RCS/xerox-patches.lisp,v	1.2
diff --git a/pcl/bench.lisp b/pcl/bench.lisp
deleted file mode 100644
index 3b0273f208a0ec3c292e704af63e939df0266de5..0000000000000000000000000000000000000000
--- a/pcl/bench.lisp
+++ /dev/null
@@ -1,448 +0,0 @@
-;;;-*- Mode: Lisp; Syntax: Common-lisp; Package: user -*- 
-
-(in-package :bench :use '(:lisp :pcl))
-
-;;;Here are a few homebrew benchmarks for testing out Lisp performance.
-;;; BENCH-THIS-LISP: benchmarks for common lisp.
-;;; BENCH-THIS-CLOS: benchmarks for CLOS.
-;;; BENCH-FLAVORS:    ditto for Symbolics flavors.
-;;; BE SURE TO CHANGE THE PACKAGE DEFINITION TO GET THE CLOS + LISP YOU WANT TO TEST.
-;;;
-;;;Each benchmark is reported as operations per second.  Without-interrupts is used,
-;;;  so the scheduler isn't supposed to get in the way.  Accuracy is generally
-;;;  between one and five percent.
-;;;
-;;;Elapsed time is measured using get-internal-run-time.  Because the accuracy of
-;;;  this number is fairly crude, it is important to use a large number of 
-;;;  iterations to get an accurate benchmark.  The function median-time may
-;;;  complain to you if you didn't pick enough iterations.
-;;;
-;;;July 1992.  Watch out!  In some cases the instruction being timed will be
-;;;  optimized away by a clever compiler.  Beware of benchmarks that are
-;;;  nearly as fast as *speed-of-empty-loop*.
-;;;
-;;;Thanks to Ken Anderson for much of this code.
-;;;
-;;; jeff morrill
-;;; jmorrill@bbn.com
-
-#+Genera
-(eval-when (compile load eval)
-  (import '(clos-internals::allocate-instance)))
-
-(proclaim '(optimize (speed 3) (safety 1) (space 0) #+lucid (compilation-speed 0)))
-
-;;;*********************************************************************
-
-(defvar *min-time* (/ 500 (float internal-time-units-per-second))
-  "At least 2 orders of magnitude larger than our time resolution.")
-
-(defmacro elapsed-time (form)
-  "Returns (1) the result of form and (2) the time (seconds) it takes to evaluate form."
-  ;; Note that this function is completely portable.
-  (let ((start-time (gensym)) (end-time (gensym)))
-    `(let ((,start-time (get-internal-run-time)))
-	 (values ,form
-		 (let ((,end-time (get-internal-run-time)))
-		   (/ (abs (- ,end-time ,start-time))
-		      ,(float internal-time-units-per-second)))))))
-
-(defmacro without-interruption (&body forms)
-  #+genera `(scl:without-interrupts ,@forms)
-  #+lucid `(lcl::with-scheduling-inhibited ,@forms)
-  #+allegro `(excl:without-interrupts ,@forms)
-  #+(and (not genera) (not lucid) (not allegro)) `(progn ,@forms))
-
-(defmacro median-time (form &optional (I 5))
-  "Return the median time it takes to evaluate form."
-  ;; I: number of samples to take.
-  `(without-interruption
-     (let ((results nil))
-       (dotimes (ignore ,I)
-	 (multiple-value-bind (ignore time) (elapsed-time ,form)
-	   (declare (ignore ignore))
-	   (if (< time *min-time*)
-	       (format t "~% Warning.  Evaluating ~S took only ~S seconds.~
-                          ~% You should probably use more iterations." ',form time))
-	   (push time results)))
-       (nth ,(truncate I 2) (sort results #'<)))))
-
-#+debug
-(defun test () (median-time (sleep 1.0)))
-
-;;;*********************************************************************
-
-;;;OPERATIONS-PER-SECOND actually does the work of computing a benchmark.  The amount
-;;;  of time it takes to execute the form N times is recorded, minus the time it
-;;;  takes to execute the empty loop.  OP/S = N/time.  This quantity is recomputed
-;;;  five times and the median value is returned.  Variance in the numbers increases
-;;;  when memory is being allocated (cons, make-instance, etc).
-
-(defmacro repeat (form N)
-  ;; Minimal loop
-  (let ((count (gensym)) (result (gensym)))
-    `(let ((,count ,N) ,result)
-       (loop 
-	 ;; If you don't use the setq, the compiler may decide that since the
-	 ;; result is ignored, FORM can be "compiled out" of the loop.
-	 (setq ,result ,form)
-	 (if (zerop (decf ,count)) (return ,result))))))
-
-(defun nempty (N)
-  "The empty loop."
-  (repeat nil N))
-
-(defun empty-speed (N) (median-time (nempty N)))
-
-(defun compute-empty-iterations (&optional (default 1000000))
-  (format t "~%Computing speed of empty loop...")
-  (let ((time nil))
-    (loop
-      (setq time (empty-speed default))
-      (if (< time *min-time*) (setq default (* default 10)) (return)))
-    (format t "done.")
-    default))
-
-(defvar *empty-iterations*)
-(defvar *speed-of-empty-loop*)
-
-(eval-when (load eval)
-  (setq *empty-iterations* (compute-empty-iterations))
-  (setq *speed-of-empty-loop* (/ (empty-speed *empty-iterations*)
-				 (float *empty-iterations*))))
-
-(defmacro operations-per-second (form N &optional (I 5))
-  "Return the number of times FORM can evaluate in one second."
-  `(let ((time (median-time (repeat ,form ,N) ,I)))
-     (/ (float ,N) (- time (* *speed-of-empty-loop* N)))))
-
-(defmacro bench (pretty-name name N &optional (stream t))
-  `(format ,stream "~%~A: ~30T~S" ,pretty-name (,name ,N)))
-
-;;;****************************************************************************
-
-;;;BENCH-THIS-LISP
-
-(defun Nmult (N)
-  (let ((a 2.1))
-    (operations-per-second (* a a) N)))
-
-(defun Nadd (N)
-  (let ((a 2.1))
-    (operations-per-second (+ a a) N))) 
-
-(defun square (x) (* x x))
-
-(defun funcall-1 (N)
-  ;; inlined
-  (let ((x 2.1))
-    (operations-per-second (funcall #'(lambda (a) (* a a)) x) N)))
-
-(defun f1 (n) n)
-
-(defun funcall-2 (N)
-  (let ((f #'f1) 
-	(x 2.1))
-    (operations-per-second (funcall f x) N)))
-
-(defun funcall-3 (N)
-  (let ((x 2.1))
-    (operations-per-second (f1 x) N)))
-
-(defun funcall-4 (N)
-  (let ((x 2.1))
-    (operations-per-second (funcall #'square x) N)))
-
-(defun funcall-5 (N)
-  (let ((x 2.1)
-	(f #'square))
-    (let ((g #'(lambda (x) 
-		 (operations-per-second (funcall f x) N))))
-      (funcall g x))))
-
-(defun Nsetf (N)
-  (let ((array (make-array 15)))
-    (operations-per-second (setf (aref array 5) t) N)))
-
-(defun Nsymeval (N) (operations-per-second (eval T) N))
-
-(defun Repeatuations (N) (operations-per-second (eval '(* 2.1 2.1)) N))
-
-(defun n-cons (N) (let ((a 1)) (operations-per-second (cons a a) N)))
-
-(defvar *object* t)
-(Defun nspecial (N) (operations-per-second (null *object*) N))
-
-(defun nlexical (N) 
-  (let ((o t))
-    (operations-per-second (null o) N)))
-
-(defun nfree (N) 
-  (let ((o t))
-    (let ((g #'(lambda ()
-		 #+genera (declare (sys:downward-function))
-		 (operations-per-second (null o) N))))
-      (funcall g))))
-
-(defun nfree2 (N) 
-  (let ((o t))
-    (let ((g #'(lambda ()
-		 (let ((f #'(lambda ()
-			      #+genera (declare (sys:downward-function))
-			      (operations-per-second (null o) N))))
-		   (funcall f)))))
-      (funcall g))))
-
-(defun ncompilations (N)
-  (let ((lambda-expression
-	  '(lambda (bar) (let ((baz t)) (if baz (cons bar nil))))))
-    (operations-per-second (compile 'bob lambda-expression) N)))
-
-(defun bench-this-lisp ()
-  (let ((N (/ *empty-iterations* 10)))
-    (bench "(* 2.1 2.1)" nmult N)
-    (bench "(+ 2.1 2.1)" nadd N)
-    (bench "funcall & (* 2.1 2.1)" funcall-3 N)
-    (bench "special reference" nspecial *empty-iterations*)
-    (bench "lexical reference" nlexical *empty-iterations*)
-    ;;  (bench "ivar reference" n-ivar-ref N)
-    (bench "(setf (aref array 5) t)" nsetf N)
-    (bench "(funcall lexical-f x)" funcall-2 N)
-    (bench "(f x)" funcall-3 N) 
-    ;;  (Bench "(eval t)" nsymeval 10000)
-    ;;  (bench "(eval '(* 2.1 2.1))" repeatuations 10000)
-    ;;  (bench "(cons 1 2)" n-cons 100000)
-    ;;  (bench "compile simple function" ncompilations 50)
-    ))
-
-;(bench-this-lisp)
-
-;;;**************************************************************
-
-#+genera
-(progn
-  
-(scl:defflavor bar (a b) ()
-  :initable-instance-variables
-  :writable-instance-variables)
-
-(scl:defflavor frob (c) (bar)
-  :initable-instance-variables
-  :writable-instance-variables)
-
-(scl:defmethod (hop bar) ()
-  a)
-
-(scl:defmethod (set-hop bar) (n)
-  (setq a n))
-
-(scl:defmethod (nohop bar) ()
-  5)
-
-(defun n-ivar-ref (N)
-  (let ((i (scl:make-instance 'bar :a 0 :b 0)))
-    (ivar-ref i N)))
-
-(scl:defmethod (ivar-ref bar) (N)
-  (operations-per-second b N))
-
-
-(defun Ninstances (N) (operations-per-second (flavor:make-instance 'bar) N))
-
-(defun n-svref (N)
-  (let ((instance (flavor:make-instance 'bar :a 1)))
-    (operations-per-second (scl:symbol-value-in-instance instance 'a) N)))
-(defun n-hop (N)
-  (let ((instance (flavor:make-instance 'bar :a 1)))
-    (operations-per-second (hop instance) n)))
-(defun n-gf (N)
-  (let ((instance (flavor:make-instance 'bar :a 1)))
-    (operations-per-second (nohop instance) n)))
-(defun n-set-hop (N)
-  (let ((instance (flavor:make-instance 'bar :a 1)))
-    (operations-per-second (set-hop instance) n)))
-(defun n-type-of (N)
-  (let ((instance (flavor:make-instance 'bar)))
-    (operations-per-second (flavor::%instance-flavor instance) N)))
-
-(defun n-bar-b (N)
-  (let ((instance (flavor:make-instance 'bar :a 0 :b 0)))
-    (operations-per-second (bar-b instance) N)))
-
-(defun n-frob-bar-b (N)
-  (let ((instance (flavor:make-instance 'frob :a 0 :b 0)))
-    (operations-per-second (bar-b instance) N)))
-
-(defun bench-flavors ()
-  (bench "flavor:make-instance (2 slots)" ninstances 5000)
-  (bench "flavor:symbol-value-in-instance" n-svref 100000)
-  (bench "1 method, 1 dispatch" n-gf 100000)
-  (bench "slot symbol in method (access)" n-hop 100000)
-  (bench "slot symbol in method (modify)" n-hop 100000)
-  (bench "slot accessor bar" n-bar-b 100000)
-  (bench "slot accessor frob" n-frob-bar-b 100000) 
-  (bench "instance-flavor" n-type-of 500000))
-
-) ; end of #+genera
-
-;;;**************************************************************
-
-;;;BENCH-THIS-CLOS
-;;; (evolved from Ken Anderson's tests of Symbolics CLOS)
-
-(defmethod strange ((x t)) t)			; default method
-(defmethod area ((x number)) 'green)		; builtin class
-
-(defclass point
-	  ()
-    ((x :initform 0 :accessor x :initarg :x)
-     (y :initform 0 :accessor y :initarg :y)))
-
-(defmethod color ((thing point)) 'red)
-(defmethod address ((thing point)) 'boston)
-(defmethod area ((thing point)) 0)
-(defmethod move-to ((p1 point) (p2 point)) 0)
-
-(defmethod x-offset ((thing point))
-  (with-slots (x y) thing x))
-
-(defmethod set-x-offset ((thing point) new-x)
-  (with-slots (x y) thing (setq x new-x)))
-
-(defclass box
-	  (point)
-    ((width :initform 10 :accessor width :initarg :width)
-     (height :initform 10 :accessor height :initarg :height)))
-
-(defmethod area ((thing box)) 0)
-(defmethod move-to ((box box) (point point)) 0)
-(defmethod address :around ((thing box)) (call-next-method))	
-
-(defvar p (make-instance 'point))
-(defvar b (make-instance 'box))
-
-(defun n-strange (N) (operations-per-second (strange 5) N))
-(defun n-accesses (N)
-  (let ((instance p))
-    (operations-per-second (x instance) N)))
-(defun n-color (N)
-  (let ((instance p))
-    (operations-per-second (color instance) n)))
-(defun n-call-next-method (N)
-  (let ((instance b))
-    (operations-per-second (address instance) n)))
-(defun n-area-1 (N)
-  (let ((instance p))
-    (operations-per-second (area instance) n)))
-(defun n-area-2 (N)
-  (operations-per-second (area 5) n))
-(defun n-move-1 (N)
-  (let ((instance p))
-    (operations-per-second (move-to instance instance) n)))
-(defun n-move-2 (N)
-  (let ((x p) (y b))
-    (operations-per-second (move-to x y) n)))
-(defun n-off (N)
-  (let ((instance p))
-    (operations-per-second (x-offset instance) n)))
-(defun n-setoff (N)
-  (let ((instance p))
-    (operations-per-second (set-x-offset instance 500) n)))
-(defun n-slot-value (N)
-  (let ((instance p))
-    (operations-per-second (slot-value instance 'x) n)))
-
-(defun n-class-of-1 (N)
-  (let ((instance p))
-    (operations-per-second (class-of instance) n)))
-(defun n-class-of-2 (N)
-  (operations-per-second (class-of 5) n))
-
-(defun n-alloc (N)
-  (let ((c (find-class 'point)))
-    (operations-per-second (allocate-instance c) n)))
-
-(defun n-make (N)
-  (operations-per-second (make-instance 'point) n))
-
-(defun n-make-initargs (N)
-  ;; Much slower than n-make!
-  (operations-per-second (make-instance 'point :x 0 :y 5) n))
-
-(defun n-make-variable-initargs (N)
-  ;; Much slower than n-make!
-  (let ((x 0)
-	(y 5))
-    (operations-per-second (make-instance 'point :x x :y y) n)))
-
-(pcl::expanding-make-instance-top-level
-
-(defun n-make1 (N)
-  (operations-per-second (make-instance 'point) n))
-
-(defun n-make-initargs1 (N)
-  ;; Much slower than n-make!
-  (operations-per-second (make-instance 'point :x 0 :y 5) n))
-
-(defun n-make-variable-initargs1 (N)
-  ;; Much slower than n-make!
-  (let ((x 0)
-	(y 5))
-    (operations-per-second (make-instance 'point :x x :y y) n)))
-
-)
-
-(pcl::precompile-random-code-segments)
-
-(defun bench-this-clos ()
-  (let ((N (/ *empty-iterations* 10)))
-    (bench "1 default method" n-strange N)
-    (bench "1 dispatch, 1 method" n-color N)
-    (bench "1 dispatch, :around + primary" n-call-next-method N)
-    (bench "1 dispatch, 3 methods, instance" n-area-1 N)
-    (bench "1 dispatch, 3 methods, noninstance" n-area-2 N)
-    (bench "2 dispatch, 2 methods" n-move-1 N)
-    (bench "slot reader method" n-accesses N)
-    (bench "with-slots (1 access)" n-off N)
-    (bench "with-slots (1 modify)" n-setoff N)
-    (bench "naked slot-value" n-slot-value N)
-    (bench "class-of instance" n-class-of-1 N)
-    (bench "class-of noninstance" n-class-of-2 N)
-    (bench "allocate-instance (2 slots)" n-alloc
-	   #+pcl 5000
-	   #+allegro 100000
-	   #+(and Genera (not pcl)) 100000
-	   #+(and Lucid (not pcl)) 10000)
-    (bench "make-instance (2 slots)" n-make
-	   #+pcl 5000
-	   #+allegro 100000
-	   #+(and Genera (not pcl)) 100000
-	   #+(and Lucid (not pcl)) 10000)
-    (bench "make-instance (2 constant initargs)" n-make-initargs
-	   #+pcl 1000
-	   #+allegro 100000
-	   #+(and Genera (not pcl)) 100000
-	   #+(and Lucid (not pcl)) 10000)
-    (bench "make-instance (2 variable initargs)" n-make-variable-initargs
-	   #+pcl 1000
-	   #+allegro 100000
-	   #+(and Genera (not pcl)) 100000
-	   #+(and Lucid (not pcl)) 10000)
-    
-    (bench "make-instance (2 slots)" n-make1
-	   #+pcl 5000
-	   #+allegro 100000
-	   #+(and Genera (not pcl)) 100000
-	   #+(and Lucid (not pcl)) 10000)
-    (bench "make-instance (2 constant initargs)" n-make-initargs1
-	   #+pcl 1000
-	   #+allegro 100000
-	   #+(and Genera (not pcl)) 100000
-	   #+(and Lucid (not pcl)) 10000)
-    (bench "make-instance (2 variable initargs)" n-make-variable-initargs1
-	   #+pcl 1000
-	   #+allegro 100000
-	   #+(and Genera (not pcl)) 100000
-	   #+(and Lucid (not pcl)) 10000)) )
-
-;(bench-this-clos)
diff --git a/pcl/boot.lisp b/pcl/boot.lisp
deleted file mode 100644
index aeb7ba960a3cd4634c36be3f9f492d2d88a8cf0e..0000000000000000000000000000000000000000
--- a/pcl/boot.lisp
+++ /dev/null
@@ -1,2166 +0,0 @@
-;;;-*-Mode: LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-#|
-
-The CommonLoops evaluator is meta-circular.  
-
-Most of the code in PCL is methods on generic functions, including most of
-the code that actually implements generic functions and method lookup.
-
-So, we have a classic bootstrapping problem.   The solution to this is to
-first get a cheap implementation of generic functions running, these are
-called early generic functions.  These early generic functions and the
-corresponding early methods and early method lookup are used to get enough
-of the system running that it is possible to create real generic functions
-and methods and implement real method lookup.  At that point (done in the
-file FIXUP) the function fix-early-generic-functions is called to convert
-all the early generic functions to real generic functions.
-
-The cheap generic functions are built using the same funcallable-instance
-objects real generic-functions are made out of.  This means that as PCL
-is being bootstrapped, the cheap generic function objects which are being
-created are the same objects which will later be real generic functions.
-This is good because:
-  - we don't cons garbage structure
-  - we can keep pointers to the cheap generic function objects
-    during booting because those pointers will still point to
-    the right object after the generic functions are all fixed
-    up
-
-
-
-This file defines the defmethod macro and the mechanism used to expand it.
-This includes the mechanism for processing the body of a method.  defmethod
-basically expands into a call to load-defmethod, which basically calls
-add-method to add the method to the generic-function.  These expansions can
-be loaded either during bootstrapping or when PCL is fully up and running.
-
-An important effect of this structure is it means we can compile files with
-defmethod forms in them in a completely running PCL, but then load those files
-back in during bootstrapping.  This makes development easier.  It also means
-there is only one set of code for processing defmethod.  Bootstrapping works
-by being sure to have load-method be careful to call only primitives which
-work during bootstrapping.
-
-|#
-
-(proclaim '(notinline make-a-method
-		      add-named-method		      
-		      ensure-generic-function-using-class
-
-		      add-method
-		      remove-method
-		      ))
-
-(defvar *early-functions*
-	'((make-a-method early-make-a-method
-			 real-make-a-method)
-	  (add-named-method early-add-named-method
-			    real-add-named-method)
-	  ))
-
-;;;
-;;; For each of the early functions, arrange to have it point to its early
-;;; definition.  Do this in a way that makes sure that if we redefine one
-;;; of the early definitions the redefinition will take effect.  This makes
-;;; development easier.
-;;;
-;;; The function which generates the redirection closure is pulled out into
-;;; a separate piece of code because of a bug in ExCL which causes this not
-;;; to work if it is inlined.
-;;;
-(eval-when (load eval)
-
-(defun redirect-early-function-internal (real early)
-  (setf (gdefinition real)
-	(set-function-name
-	 #'(lambda (&rest args)
-	     (apply (the function (symbol-function early)) args))
-	 real)))
-
-(dolist (fns *early-functions*)
-  (let ((name (car fns))
-	(early-name (cadr fns)))
-    (redirect-early-function-internal name early-name)))
-
-)
-
-
-;;;
-;;; *generic-function-fixups* is used by fix-early-generic-functions to
-;;; convert the few functions in the bootstrap which are supposed to be
-;;; generic functions but can't be early on.
-;;; 
-(defvar *generic-function-fixups*
-    '((add-method
-	((generic-function method)		        ;lambda-list
-	 (standard-generic-function method)	        ;specializers
-	 real-add-method))			        ;method-function
-      (remove-method
-	((generic-function method)
-	 (standard-generic-function method)
-	 real-remove-method))
-      (get-method
-        ((generic-function qualifiers specializers &optional (errorp t))
-	 (standard-generic-function t t)
-	 real-get-method))
-      (ensure-generic-function-using-class
-	((generic-function function-specifier
-			   &key generic-function-class environment
-			   &allow-other-keys)
-	 (generic-function t)
-	 real-ensure-gf-using-class--generic-function)
-        ((generic-function function-specifier
-			   &key generic-function-class environment
-			   &allow-other-keys)
-	 (null t)
-	 real-ensure-gf-using-class--null))
-      (make-method-lambda
-       ((proto-generic-function proto-method lambda-expression environment)
-	(standard-generic-function standard-method t t)
-	real-make-method-lambda))
-      (make-method-initargs-form
-       ((proto-generic-function proto-method lambda-expression lambda-list environment)
-	(standard-generic-function standard-method t t t)
-	real-make-method-initargs-form))
-      (compute-effective-method
-       ((generic-function combin applicable-methods)
-	(generic-function standard-method-combination t)
-	standard-compute-effective-method))
-      ))
-
-
-;;;
-;;;
-;;;
-(defmacro defgeneric (function-specifier lambda-list &body options)
-  (expand-defgeneric function-specifier lambda-list options))
-
-(defun expand-defgeneric (function-specifier lambda-list options)
-  (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
-  (let ((initargs ()))
-    (flet ((duplicate-option (name)
-	     (error "The option ~S appears more than once." name)))
-      ;;
-      ;; INITARG takes this screwy new argument to get around a bad
-      ;; interaction between lexical macros and setf in the Lucid
-      ;; compiler.
-      ;; 
-      (macrolet ((initarg (key &optional new)
-		   (if new
-		       `(setf (getf initargs ,key) ,new)
-		       `(getf initargs ,key))))
-	(dolist (option options)
-	  (ecase (car option)
-	    (:argument-precedence-order
-	      (if (initarg :argument-precedence-order)
-		  (duplicate-option :argument-precedence-order)
-		  (initarg :argument-precedence-order `',(cdr option))))
-	    (declare
-	      (initarg :declarations
-		       (append (cdr option) (initarg :declarations))))
-	    (:documentation
-	      (if (initarg :documentation)
-		  (duplicate-option :documentation)
-		  (initarg :documentation `',(cadr option))))
-	    (:method-combination
-	      (if (initarg :method-combination)
-		  (duplicate-option :method-combination)
-		  (initarg :method-combination `',(cdr option))))
-	    (:generic-function-class
-	      (if (initarg :generic-function-class)
-		  (duplicate-option :generic-function-class)
-		  (initarg :generic-function-class `',(cadr option))))
-	    (:method-class
-	      (if (initarg :method-class)
-		  (duplicate-option :method-class)
-		  (initarg :method-class `',(cadr option))))
-	    (:method
-	      (error
-		"DEFGENERIC doesn't support the :METHOD option yet."))))
-
-	(let ((declarations (initarg :declarations)))
-	  (when declarations (initarg :declarations `',declarations)))))
-    `(progn
-       (proclaim-defgeneric ',function-specifier ',lambda-list)
-       ,(make-top-level-form `(defgeneric ,function-specifier)
-	  *defgeneric-times*
-	  `(load-defgeneric ',function-specifier ',lambda-list ,@initargs)))))
-
-(defun load-defgeneric (function-specifier lambda-list &rest initargs)
-  (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
-  (apply #'ensure-generic-function
-	 function-specifier
-	 :lambda-list lambda-list
-	 :definition-source `((defgeneric ,function-specifier)
-			      ,(load-truename))
-	 initargs))
-
-
-;;;
-;;;
-;;;
-(defmacro DEFMETHOD (&rest args &environment env)
-  #+(or (not :lucid) :lcl3.0)	
-  (declare (arglist name
-		    {method-qualifier}*
-		    specialized-lambda-list
-		    &body body))
-  (multiple-value-bind (name qualifiers lambda-list body)
-      (parse-defmethod args)
-    (multiple-value-bind (proto-gf proto-method)
-	(prototypes-for-make-method-lambda name)
-      (expand-defmethod name proto-gf proto-method
-			qualifiers lambda-list body env))))
-
-(defun prototypes-for-make-method-lambda (name)
-  (if (not (eq *boot-state* 'complete))	  
-      (values nil nil)
-      (let ((gf? (and (gboundp name)
-		      (gdefinition name))))
-	(if (or (null gf?)
-		(not (generic-function-p gf?)))
-	    (values (class-prototype (find-class 'standard-generic-function))
-		    (class-prototype (find-class 'standard-method)))
-	    (values gf?
-		    (class-prototype (or (generic-function-method-class gf?)
-					 (find-class 'standard-method))))))))
-
-;;;
-;;; takes a name which is either a generic function name or a list specifying
-;;; a setf generic function (like: (SETF <generic-function-name>)).  Returns
-;;; the prototype instance of the method-class for that generic function.
-;;;
-;;; If there is no generic function by that name, this returns the default
-;;; value, the prototype instance of the class STANDARD-METHOD.  This default
-;;; value is also returned if the spec names an ordinary function or even a
-;;; macro.  In effect, this leaves the signalling of the appropriate error
-;;; until load time.
-;;;
-;;; NOTE that during bootstrapping, this function is allowed to return NIL.
-;;; 
-(defun method-prototype-for-gf (name)      
-  (let ((gf? (and (gboundp name)
-		  (gdefinition name))))
-    (cond ((neq *boot-state* 'complete) nil)
-	  ((or (null gf?)
-	       (not (generic-function-p gf?)))	        ;Someone else MIGHT
-						        ;error at load time.
-	   (class-prototype (find-class 'standard-method)))
-	  (t
-	    (class-prototype (or (generic-function-method-class gf?)
-				 (find-class 'standard-method)))))))
-
-
-(defvar *optimize-asv-funcall-p* nil)
-(defvar *asv-readers*)
-(defvar *asv-writers*)
-(defvar *asv-boundps*)
-
-(defun expand-defmethod (name proto-gf proto-method qualifiers lambda-list body env)
-  (when (listp name) (do-standard-defsetf-1 (cadr name)))
-  (let ((*make-instance-function-keys* nil)
-	(*optimize-asv-funcall-p* t)
-	(*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil))
-    (declare (special *make-instance-function-keys*))
-    (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
-	(add-method-declarations name qualifiers lambda-list body env)
-      (multiple-value-bind (method-function-lambda initargs)
-	  (make-method-lambda proto-gf proto-method method-lambda env)
-	(let ((initargs-form (make-method-initargs-form 
-			      proto-gf proto-method
-			      method-function-lambda initargs env)))
-	  `(progn
-	     (proclaim-defgeneric ',name ',lambda-list)
-	     ,@(when *make-instance-function-keys*
-		 `((get-make-instance-functions ',*make-instance-function-keys*)))
-	     ,@(when (or *asv-readers* *asv-writers* *asv-boundps*)
-		 `((initialize-internal-slot-gfs*
-		    ',*asv-readers* ',*asv-writers* ',*asv-boundps*)))
-	     ,(make-defmethod-form name qualifiers specializers
-				   unspecialized-lambda-list
-				   (if proto-method
-				       (class-name (class-of proto-method))
-				       'standard-method)
-				   initargs-form
-	                           (getf (getf initargs ':plist)
-				         ':pv-table-symbol))))))))
-
-(defun interned-symbol-p (x)
-  (and (symbolp x) (symbol-package x)))
-
-(defun make-defmethod-form (name qualifiers specializers
-				 unspecialized-lambda-list method-class-name
-				 initargs-form &optional pv-table-symbol)
-  (let (fn fn-lambda)
-    (if (and (interned-symbol-p (if (consp name)
-				    (and (eq (car name) 'setf) (cadr name))
-				    name))
-	     (every #'interned-symbol-p qualifiers)
-	     (every #'(lambda (s)
-			(if (consp s)
-			    (and (eq (car s) 'eql) 
-				 (constantp (cadr s))
-				 (let ((sv (eval (cadr s))))
-				   (or (interned-symbol-p sv)
-				       (integerp sv)
-				       (standard-char-p sv))))
-			    (interned-symbol-p s)))
-		    specializers)
-	     (consp initargs-form)
-	     (eq (car initargs-form) 'list*)
-	     (memq (cadr initargs-form) '(:function :fast-function))
-	     (consp (setq fn (caddr initargs-form)))
-	     (eq (car fn) 'function)
-	     (consp (setq fn-lambda (cadr fn)))
-	     (eq (car fn-lambda) 'lambda))
-	(let* ((specls (mapcar #'(lambda (specl)
-				   (if (consp specl)
-				       `(,(car specl) ,(eval (cadr specl)))
-				       specl))
-			       specializers))
-	       (mname `(,(if (eq (cadr initargs-form) ':function)
-			     'method 'fast-method)
-			,name ,@qualifiers ,specls))
-	       (mname-sym (intern (let ((*print-pretty* nil))
-				    (format nil "~S" mname)))))
-	  `(eval-when ,*defmethod-times*
-	    (defun ,mname-sym ,(cadr fn-lambda)
-	      ,@(cddr fn-lambda))
-	    ,(make-defmethod-form-internal 
-	      name qualifiers `',specls
-	      unspecialized-lambda-list method-class-name
-	      `(list* ,(cadr initargs-form) #',mname-sym ,@(cdddr initargs-form))
-	      pv-table-symbol)))
-	(make-top-level-form 
-	 `(defmethod ,name ,@qualifiers ,specializers)
-	 *defmethod-times*
-	 (make-defmethod-form-internal 
-	  name qualifiers 
-	  `(list ,@(mapcar #'(lambda (specializer)
-			       (if (consp specializer)
-				   ``(,',(car specializer) ,,(cadr specializer))
-				   `',specializer))
-		    specializers))
-	  unspecialized-lambda-list method-class-name
-	  initargs-form
-	  pv-table-symbol)))))
-
-(defun make-defmethod-form-internal (name qualifiers specializers-form
-					  unspecialized-lambda-list method-class-name
-					  initargs-form &optional pv-table-symbol)
-  `(load-defmethod
-    ',method-class-name
-    ',name
-    ',qualifiers
-    ,specializers-form
-    ',unspecialized-lambda-list
-    ,initargs-form
-    ;;Paper over a bug in KCL by passing the cache-symbol
-    ;;here in addition to in the list.
-    ',pv-table-symbol))
-
-(defmacro make-method-function (method-lambda &environment env)
-  (make-method-function-internal method-lambda env))
-
-(defun make-method-function-internal (method-lambda &optional env)
-  (multiple-value-bind (proto-gf proto-method)
-	(prototypes-for-make-method-lambda nil)
-    (multiple-value-bind (method-function-lambda initargs)
-	(make-method-lambda proto-gf proto-method method-lambda env)
-      (make-method-initargs-form proto-gf proto-method
-				 method-function-lambda initargs env))))
-
-(defun add-method-declarations (name qualifiers lambda-list body env)
-  (multiple-value-bind (parameters unspecialized-lambda-list specializers)
-      (parse-specialized-lambda-list lambda-list)
-    (declare (ignore parameters))
-    (multiple-value-bind (documentation declarations real-body)
-	(extract-declarations body env)
-      (values `(lambda ,unspecialized-lambda-list
-		 ,@(when documentation `(,documentation))
-		 (declare (method-name ,(list name qualifiers specializers)))
-		 (declare (method-lambda-list ,@lambda-list))
-		 ,@declarations
-		 ,@real-body)
-	      unspecialized-lambda-list specializers))))
-
-(defun real-make-method-initargs-form (proto-gf proto-method 
-				       method-lambda initargs env)
-  (declare (ignore proto-gf proto-method))
-  (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
-    (error "The method-lambda argument to make-method-function, ~S,~
-            is not a lambda form" method-lambda))
-  (make-method-initargs-form-internal method-lambda initargs env))
-
-(unless (fboundp 'make-method-initargs-form)
-  (setf (gdefinition 'make-method-initargs-form)
-	(symbol-function 'real-make-method-initargs-form)))
-
-(defun real-make-method-lambda (proto-gf proto-method method-lambda env)
-  (declare (ignore proto-gf proto-method))
-  (make-method-lambda-internal method-lambda env))
-
-(defun make-method-lambda-internal (method-lambda &optional env)
-  (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
-    (error "The method-lambda argument to make-method-lambda, ~S,~
-            is not a lambda form" method-lambda))
-  (multiple-value-bind (documentation declarations real-body)
-      (extract-declarations (cddr method-lambda) env)
-    (let* ((name-decl (get-declaration 'method-name declarations))
-	   (sll-decl (get-declaration 'method-lambda-list declarations))
-	   (method-name (when (consp name-decl) (car name-decl)))
-	   (generic-function-name (when method-name (car method-name)))
-	   (specialized-lambda-list (or sll-decl (cadr method-lambda))))
-      (multiple-value-bind (parameters lambda-list specializers)
-	  (parse-specialized-lambda-list specialized-lambda-list)
-	(let* ((required-parameters
-		(mapcar #'(lambda (r s) (declare (ignore s)) r)
-			parameters
-			specializers))
-	       (slots (mapcar #'list required-parameters))
-	       (calls (list nil))
-	       (parameters-to-reference
-		(make-parameter-references specialized-lambda-list
-					   required-parameters
-					   declarations
-					   method-name
-					   specializers))
-	       (class-declarations
-		`(declare
-		  ,@(remove nil
-			    (mapcar #'(lambda (a s) (and (symbolp s)
-							 (neq s 't)
-							 `(class ,a ,s)))
-				    parameters
-				    specializers))))
-	       (method-lambda
-		  ;; Remove the documentation string and insert the
-		  ;; appropriate class declarations.  The documentation
-		  ;; string is removed to make it easy for us to insert
-		  ;; new declarations later, they will just go after the
-		  ;; cadr of the method lambda.  The class declarations
-		  ;; are inserted to communicate the class of the method's
-		  ;; arguments to the code walk.
-		  `(lambda ,lambda-list
-		     ,class-declarations
-		     ,@declarations
-		     (progn ,@parameters-to-reference)
-		     (block ,(if (listp generic-function-name)
-				 (cadr generic-function-name)
-				 generic-function-name)
-		       ,@real-body)))
-	       (constant-value-p (and (null (cdr real-body))
-				      (constantp (car real-body))))
-	       (constant-value (and constant-value-p
-				    (eval (car real-body))))
-	       (plist (if (and constant-value-p
-			       (or (typep constant-value '(or number character))
-				   (and (symbolp constant-value)
-					(symbol-package constant-value))))
-			  (list :constant-value constant-value)
-			  ()))
-	       (applyp (dolist (p lambda-list nil)
-			 (cond ((memq p '(&optional &rest &key))
-				(return t))
-			       ((eq p '&aux)
-				(return nil))))))
-	    (multiple-value-bind (walked-lambda call-next-method-p closurep
-						next-method-p-p)
-		(walk-method-lambda method-lambda required-parameters env 
-				    slots calls)
-	      (multiple-value-bind (ignore walked-declarations walked-lambda-body)
-		  (extract-declarations (cddr walked-lambda))
-		(declare (ignore ignore))
-		(when (or next-method-p-p call-next-method-p)
-		  (setq plist (list* :needs-next-methods-p 't plist)))
-		(when (some #'cdr slots)
-		  (multiple-value-bind (slot-name-lists call-list)
-		      (slot-name-lists-from-slots slots calls)
-		    (let ((pv-table-symbol (make-symbol "pv-table")))
-		      (setq plist 
-			    `(,@(when slot-name-lists 
-				  `(:slot-name-lists ,slot-name-lists))
-			      ,@(when call-list
-				  `(:call-list ,call-list))
-			      :pv-table-symbol ,pv-table-symbol
-			      ,@plist))
-		      (setq walked-lambda-body
-			    `((pv-binding (,required-parameters ,slot-name-lists
-					   ,pv-table-symbol)
-			       ,@walked-lambda-body))))))
-		(when (and (memq '&key lambda-list)
-			   (not (memq '&allow-other-keys lambda-list)))
-		  (let ((aux (memq '&aux lambda-list)))
-		    (setq lambda-list (nconc (ldiff lambda-list aux)
-					     (list '&allow-other-keys)
-					     aux))))
-		(values `(lambda (.method-args. .next-methods.)
-			   (simple-lexical-method-functions
-			       (,lambda-list .method-args. .next-methods.
-				:call-next-method-p ,call-next-method-p 
-				:next-method-p-p ,next-method-p-p
-				:closurep ,closurep
-				:applyp ,applyp)
-			     ,@walked-declarations
-			     ,@walked-lambda-body))
-			`(,@(when plist 
-			      `(:plist ,plist))
-			  ,@(when documentation 
-			      `(:documentation ,documentation)))))))))))
-		 
-(unless (fboundp 'make-method-lambda)
-  (setf (gdefinition 'make-method-lambda)
-	(symbol-function 'real-make-method-lambda)))
-
-(defmacro simple-lexical-method-functions ((lambda-list method-args next-methods
-							&rest lmf-options) 
-					   &body body)
-  `(progn
-     ,method-args ,next-methods
-     (bind-simple-lexical-method-macros (,method-args ,next-methods)
-       (bind-lexical-method-functions (,@lmf-options)
-         (bind-args (,lambda-list ,method-args)
-	   ,@body)))))
-
-(defmacro fast-lexical-method-functions ((lambda-list next-method-call args rest-arg
-						      &rest lmf-options)
-					 &body body)
- `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call)
-    (bind-lexical-method-functions (,@lmf-options)
-      (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
-        ,@body))))
-
-(defmacro bind-simple-lexical-method-macros ((method-args next-methods) &body body)
-  `(macrolet ((call-next-method-bind (&body body)
-		`(let ((.next-method. (car ,',next-methods))
-		       (,',next-methods (cdr ,',next-methods)))
-		   .next-method. ,',next-methods
-		   ,@body))
-	      (call-next-method-body (cnm-args)
-		`(if .next-method.
-		     (funcall (if (std-instance-p .next-method.)
-				  (method-function .next-method.)
-				  .next-method.) ; for early methods
-			      (or ,cnm-args ,',method-args)
-		              ,',next-methods)
-		     (error "No next method.")))
-	      (next-method-p-body ()
-	        `(not (null .next-method.))))
-     ,@body))
-
-(defstruct method-call
-  (function #'identity :type function)
-  call-method-args)
-
-(defmacro invoke-method-call1 (function args cm-args)
-  `(let ((.function. ,function)
-	 (.args. ,args)
-	 (.cm-args. ,cm-args))
-     (if (and .cm-args. (null (cdr .cm-args.)))
-	 (funcall .function. .args. (car .cm-args.))
-	 (apply .function. .args. .cm-args.))))
-
-(defmacro invoke-method-call (method-call restp &rest required-args+rest-arg)
-  `(invoke-method-call1 (method-call-function ,method-call)
-                        ,(if restp
-			     `(list* ,@required-args+rest-arg)
-			     `(list ,@required-args+rest-arg))
-                        (method-call-call-method-args ,method-call)))
-
-(defstruct fast-method-call
-  (function #'identity :type function)
-  pv-cell
-  next-method-call
-  arg-info)
-
-#-akcl
-(defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
-  `(funcall ,fn ,pv-cell ,next-method-call ,@args))
-
-(defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg)
-  `(fmc-funcall (fast-method-call-function ,method-call)
-                (fast-method-call-pv-cell ,method-call)
-                (fast-method-call-next-method-call ,method-call)
-                ,@required-args+rest-arg))
-
-(defstruct fast-instance-boundp
-  (index 0 :type fixnum))
-
-(eval-when (compile load eval)
-(defvar *allow-emf-call-tracing-p* nil)
-(defvar *enable-emf-call-tracing-p* #-testing nil #+testing t)
-)
-
-(defvar *emf-call-trace-size* 200)
-(defvar *emf-call-trace* nil)
-(defvar emf-call-trace-index 0)
-
-(defun show-emf-call-trace ()
-  (when *emf-call-trace*
-    (let ((j emf-call-trace-index)
-	  (*enable-emf-call-tracing-p* nil))
-      (format t "~&(The oldest entries are printed first)~%")
-      (dotimes (i *emf-call-trace-size*)
-	(let ((ct (aref *emf-call-trace* j)))
-	  (when ct (print ct)))
-	(incf j)
-	(when (= j *emf-call-trace-size*)
-	  (setq j 0))))))
-
-(defun trace-emf-call-internal (emf format args)
-  (unless *emf-call-trace*
-    (setq *emf-call-trace* (make-array *emf-call-trace-size*)))
-  (setf (aref *emf-call-trace* emf-call-trace-index)
-	(list* emf format args))
-  (incf emf-call-trace-index)
-  (when (= emf-call-trace-index *emf-call-trace-size*)
-    (setq emf-call-trace-index 0)))
-
-(defmacro trace-emf-call (emf format args)
-  (when *allow-emf-call-tracing-p*
-    `(when *enable-emf-call-tracing-p*
-       (trace-emf-call-internal ,emf ,format ,args))))
-
-(defmacro invoke-effective-method-function-fast
-    (emf restp &rest required-args+rest-arg)
-  `(progn
-     (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
-     (invoke-fast-method-call ,emf ,@required-args+rest-arg)))
-
-(defmacro invoke-effective-method-function (emf restp &rest required-args+rest-arg)
-  (unless (constantp restp)
-    (error "The restp argument to invoke-effective-method-function is not constant"))
-  (setq restp (eval restp))
-  `(progn
-     (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
-     (cond (#-(or lucid excl) (typep ,emf 'fast-method-call)
-	    #+(or lucid excl) (fast-method-call-p ,emf)
-	     (invoke-fast-method-call ,emf ,@required-args+rest-arg))
-	   ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
-	       `(((typep ,emf 'fixnum)
-		  (let* ((.slots. (get-slots-or-nil
-				   ,(car required-args+rest-arg)))
-			 (value (when .slots. (%instance-ref .slots. ,emf))))
-		    (if (eq value ',*slot-unbound*)
-			(slot-unbound-internal ,(car required-args+rest-arg)
-					       ,emf)
-			value)))))
-	   ,@(when (and (null restp) (= 2 (length required-args+rest-arg)))
-	       `(((typep ,emf 'fixnum)
-		  (let ((.new-value. ,(car required-args+rest-arg))
-			(.slots. (get-slots-or-nil
-				  ,(car required-args+rest-arg))))
-		    (when .slots. ; just to avoid compiler wranings
-		      (setf (%instance-ref .slots. ,emf) .new-value.))))))
-	   #|| 
-	   ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
-	       `(((typep ,emf 'fast-instance-boundp)
-		  (let ((.slots. (get-slots-or-nil
-				  ,(car required-args+rest-arg))))
-		    (and .slots.
-			 (not (eq (%instance-ref
-				   .slots. (fast-instance-boundp-index ,emf))
-				  ',*slot-unbound*)))))))
-	   ||#
-	   (t
-	    (etypecase ,emf
-	      (method-call
-	       (invoke-method-call ,emf ,restp ,@required-args+rest-arg))
-	      (function
-	       ,(if restp
-		    `(apply ,emf ,@required-args+rest-arg)
-		    `(funcall ,emf ,@required-args+rest-arg))))))))
-
-(defun invoke-emf (emf args)
-  (trace-emf-call emf t args)
-  (etypecase emf
-    (fast-method-call
-     (let* ((arg-info (fast-method-call-arg-info emf))
-	    (restp (cdr arg-info))
-	    (nreq (car arg-info)))
-       (if restp
-	   (let* ((rest-args (nthcdr nreq args))
-		  (req-args (ldiff args rest-args)))
-	     (apply (fast-method-call-function emf)
-		    (fast-method-call-pv-cell emf)
-		    (fast-method-call-next-method-call emf)
-		    (nconc req-args (list rest-args))))
-	   (cond ((null args)
-		  (if (eql nreq 0) 
-		      (invoke-fast-method-call emf)
-		      (error "wrong number of args")))
-		 ((null (cdr args))
-		  (if (eql nreq 1) 
-		      (invoke-fast-method-call emf (car args))
-		      (error "wrong number of args")))
-		 ((null (cddr args))
-		  (if (eql nreq 2) 
-		      (invoke-fast-method-call emf (car args) (cadr args))
-		      (error "wrong number of args")))
-		 (t
-		  (apply (fast-method-call-function emf)
-			 (fast-method-call-pv-cell emf)
-			 (fast-method-call-next-method-call emf)
-			 args))))))
-    (method-call 
-     (apply (method-call-function emf)
-	    args
-	    (method-call-call-method-args emf)))
-    (fixnum 
-     (cond ((null args) (error "1 or 2 args expected"))
-	   ((null (cdr args))
-	    (let ((value (%instance-ref (get-slots (car args)) emf)))
-	      (if (eq value *slot-unbound*)
-		  (slot-unbound-internal (car args) emf)
-		  value)))
-	   ((null (cddr args))
-	    (setf (%instance-ref (get-slots (cadr args)) emf)
-		  (car args)))
-	   (t (error "1 or 2 args expected"))))
-    (fast-instance-boundp
-     (if (or (null args) (cdr args))
-	 (error "1 arg expected")
-	 (not (eq (%instance-ref (get-slots (car args)) 
-				 (fast-instance-boundp-index emf))
-		  *slot-unbound*))))
-    (function
-     (apply emf args))))
-
-;; This can be improved alot.
-(defun gf-make-function-from-emf (gf emf)
-  (etypecase emf
-    (fast-method-call (let* ((arg-info (gf-arg-info gf))
-			     (nreq (arg-info-number-required arg-info))
-			     (restp (arg-info-applyp arg-info)))
-			#'(lambda (&rest args)
-			    #+copy-&rest-arg (setq args (copy-list args))
-			    (trace-emf-call emf t args)
-			    (apply (fast-method-call-function emf)
-				   (fast-method-call-pv-cell emf)
-				   (fast-method-call-next-method-call emf)
-				   (if restp
-				       (let* ((rest-args (nthcdr nreq args))
-					      (req-args (ldiff args rest-args)))
-					 (nconc req-args rest-args))
-				       args)))))
-    (method-call #'(lambda (&rest args)
-		     #+copy-&rest-arg (setq args (copy-list args))
-		     (trace-emf-call emf t args)
-		     (apply (method-call-function emf)
-			    args
-			    (method-call-call-method-args emf))))
-    (function emf)))
-
-(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
-					   &body body)
-  `(macrolet ((call-next-method-bind (&body body)
-		`(let () ,@body))
-	      (call-next-method-body (cnm-args)
-		`(if ,',next-method-call
-		     ,(if (and (null ',rest-arg)
-			       (consp cnm-args)
-			       (eq (car cnm-args) 'list))
-			  `(invoke-effective-method-function
-			    ,',next-method-call nil
-			    ,@(cdr cnm-args))
-			  (let ((call `(invoke-effective-method-function
-					,',next-method-call 
-					,',(not (null rest-arg))
-					,@',args 
-					,@',(when rest-arg `(,rest-arg)))))
-			    `(if ,cnm-args
-				 (bind-args ((,@',args ,@',(when rest-arg
-							     `(&rest ,rest-arg)))
-					     ,cnm-args)
-					    ,call)
-				 ,call)))
-		     (error "No next method.")))
-	      (next-method-p-body ()
-	        `(not (null ,',next-method-call))))
-     ,@body))
-
-(defmacro bind-lexical-method-functions 
-    ((&key call-next-method-p next-method-p-p closurep applyp)
-     &body body)
-  (cond ((and (null call-next-method-p) (null next-method-p-p)
-	      (null closurep)
-	      (null applyp))
-	 `(let () ,@body))
-	 ((and (null closurep)
-	       (null applyp))
-	 ;; OK to use MACROLET, and all args are mandatory 
-	 ;; (else APPLYP would be true).
-	 `(call-next-method-bind
-	    (macrolet ((call-next-method (&rest cnm-args)
-			 `(call-next-method-body ,(when cnm-args `(list ,@cnm-args))))
-		       (next-method-p ()
-			 `(next-method-p-body)))
-	       ,@body)))
-	(t
-	 `(call-next-method-bind
-	    (flet (,@(and call-next-method-p
-		       '((call-next-method (&rest cnm-args)
-			  #+Genera
-			  (declare (dbg:invisible-frame :clos-internal))
-			  #+copy-&rest-arg (setq args (copy-list args))
-			  (call-next-method-body cnm-args))))
-		     ,@(and next-method-p-p
-			 '((next-method-p ()
-			    (next-method-p-body)))))
-	      ,@body)))))
-
-(defmacro bind-args ((lambda-list args) &body body)
-  #|| ; Lucid and Allegro don't compile the function inline
-  `(apply #'(lambda ,lambda-list ,@body) ,args)
-  ||#
-  (let ((args-tail '.args-tail.)
-	(key '.key.)
-	(state 'required))
-    (flet ((process-var (var)
-	     (if (memq var lambda-list-keywords)
-		 (progn
-		   (case var
-		     (&optional         (setq state 'optional))
-		     (&key              (setq state 'key))
-		     (&allow-other-keys)
-		     (&rest             (setq state 'rest))
-		     (&aux              (setq state 'aux))
-		     (otherwise
-		      (error "Encountered the non-standard lambda list keyword ~S."
-			     var)))
-		   nil)
-		 (case state
-		   (required `((,var (pop ,args-tail))))
-		   (optional (cond ((not (consp var))
-				    `((,var (when ,args-tail (pop ,args-tail)))))
-				   ((null (cddr var))
-				    `((,(car var) (if ,args-tail
-						      (pop ,args-tail)
-						      ,(cadr var)))))
-				   (t
-				    `((,(caddr var) ,args-tail)
-				      (,(car var) (if ,args-tail
-						      (pop ,args-tail)
-						      ,(cadr var)))))))
-		   (rest `((,var ,args-tail)))
-		   (key (cond ((not (consp var))
-			       `((,var (get-key-arg ,(make-keyword var)
-					            ,args-tail))))
-			      ((null (cddr var))
-			       (multiple-value-bind (keyword variable)
-				   (if (consp (car var))
-				       (values (caar var) (cadar var))
-				       (values (make-keyword (car var)) (car var)))
-				 `((,key (get-key-arg1 ,keyword ,args-tail))
-				   (,variable (if (consp ,key)
-						  (car ,key)
-						  ,(cadr var))))))
-			      (t
-			       (multiple-value-bind (keyword variable)
-				   (if (consp (car var))
-				       (values (caar var) (cadar var))
-				       (values (make-keyword (car var)) (car var)))
-				 `((,key (get-key-arg1 ,keyword ,args-tail))
-				   (,(caddr var) ,key)
-				   (,variable (if (consp ,key)
-						  (car ,key)
-						  ,(cadr var))))))))
-		   (aux `(,var))))))
-      (let ((bindings (mapcan #'process-var lambda-list)))
-	`(let* ((,args-tail ,args)
-		,@bindings)
-	   ,@(unless bindings `((declare (ignore ,args-tail))))
-	   ,@body)))))
-
-(defun get-key-arg (keyword list)
-  (loop (when (atom list) (return nil))
-	(when (eq (car list) keyword) (return (cadr list)))
-	(setq list (cddr list))))
-
-(defun get-key-arg1 (keyword list)
-  (loop (when (atom list) (return nil))
-	(when (eq (car list) keyword) (return (cdr list)))
-	(setq list (cddr list))))
-
-(defun walk-method-lambda (method-lambda required-parameters env slots calls)
-  (let ((call-next-method-p nil)   ;flag indicating that call-next-method
-				   ;should be in the method definition
-	(closurep nil)		   ;flag indicating that #'call-next-method
-				   ;was seen in the body of a method
-	(next-method-p-p nil))     ;flag indicating that next-method-p
-				   ;should be in the method definition
-    (flet ((walk-function (form context env)
-	     (cond ((not (eq context ':eval)) form)
-		   ((not (listp form)) form)
-		   ((eq (car form) 'call-next-method)
-		    (setq call-next-method-p 't)
-		    form)
-		   ((eq (car form) 'next-method-p)
-		    (setq next-method-p-p 't)
-		    form)
-		   ((and (eq (car form) 'function)
-			 (cond ((eq (cadr form) 'call-next-method)
-				(setq call-next-method-p 't)
-				(setq closurep t)
-				form)
-			       ((eq (cadr form) 'next-method-p)
-				(setq next-method-p-p 't)
-				(setq closurep t)
-				form)
-			       (t nil))))
-		   ((and (or (eq (car form) 'slot-value)
-			     (eq (car form) 'set-slot-value)
-			     (eq (car form) 'slot-boundp))
-			 (constantp (caddr form)))
-		    (let ((parameter
-			   (can-optimize-access form
-						required-parameters env)))
-		      (ecase (car form)
-			(slot-value
-			 (optimize-slot-value     slots parameter form))
-			(set-slot-value
-			 (optimize-set-slot-value slots parameter form))
-			(slot-boundp
-			 (optimize-slot-boundp    slots parameter form)))))
-		   ((and (eq (car form) 'apply)
-			 (consp (cadr form))
-			 (eq (car (cadr form)) 'function)
-			 (generic-function-name-p (cadr (cadr form))))
-		    (optimize-generic-function-call 
-		     form required-parameters env slots calls))
-		   ((and (or (symbolp (car form))
-			     (and (consp (car form))
-				  (eq (caar form) 'setf)))
-			 (generic-function-name-p (car form)))
-		    (optimize-generic-function-call 
-		     form required-parameters env slots calls))
-		   ((and (eq (car form) 'asv-funcall)
-			 *optimize-asv-funcall-p*)
-		    (case (fourth form)
-		      (reader (push (third form) *asv-readers*))
-		      (writer (push (third form) *asv-writers*))
-		      (boundp (push (third form) *asv-boundps*)))
-		    `(,(second form) ,@(cddddr form)))
-		   (t form))))
-	  
-      (let ((walked-lambda (walk-form method-lambda env #'walk-function)))
-	(values walked-lambda
-		call-next-method-p closurep next-method-p-p)))))
-
-(defun generic-function-name-p (name)
-  (and (or (symbolp name)
-	   (and (consp name)
-		(eq (car name) 'setf)
-		(consp (cdr name))
-		(symbolp (cadr name))
-		(null (cddr name))))
-       (gboundp name)
-       (if (eq *boot-state* 'complete)
-	   (standard-generic-function-p (gdefinition name))
-	   (funcallable-instance-p (gdefinition name)))))
-
-(defun make-parameter-references (specialized-lambda-list
-				  required-parameters
-				  declarations
-				  method-name
-				  specializers)
-  (flet ((ignoredp (symbol)
-	   (dolist (decl (cdar declarations))
-	     (when (and (eq (car decl) 'ignore)
-			(memq symbol (cdr decl)))
-	       (return t)))))	   
-    (gathering ((references (collecting)))
-      (iterate ((s (list-elements specialized-lambda-list))
-		(p (list-elements required-parameters)))
-	(progn p)
-	(cond ((not (listp s)))
-	      ((ignoredp (car s))
-	       (warn "In defmethod ~S, there is a~%~
-                      redundant ignore declaration for the parameter ~S."
-		     method-name
-		     specializers
-		     (car s)))
-	      (t
-	       (gather (car s) references)))))))
-
-
-(defvar *method-function-plist* (make-hash-table :test #'eq))
-(defvar *mf1* nil) (defvar *mf1p* nil) (defvar *mf1cp* nil)
-(defvar *mf2* nil) (defvar *mf2p* nil) (defvar *mf2cp* nil)
-
-(defun method-function-plist (method-function)
-  (unless (eq method-function *mf1*)
-    (rotatef *mf1* *mf2*)
-    (rotatef *mf1p* *mf2p*)
-    (rotatef *mf1cp* *mf2cp*))
-  (unless (or (eq method-function *mf1*) (null *mf1cp*))
-    (setf (gethash *mf1* *method-function-plist*) *mf1p*))
-  (unless (eq method-function *mf1*)
-    (setf *mf1* method-function
-	  *mf1cp* nil
-	  *mf1p* (gethash method-function *method-function-plist*)))
-  *mf1p*)
-
-(defun #-setf SETF\ PCL\ METHOD-FUNCTION-PLIST #+setf (setf method-function-plist)
-       (val method-function)
-  (unless (eq method-function *mf1*)
-    (rotatef *mf1* *mf2*)
-    (rotatef *mf1cp* *mf2cp*)
-    (rotatef *mf1p* *mf2p*))
-  (unless (or (eq method-function *mf1*) (null *mf1cp*))
-    (setf (gethash *mf1* *method-function-plist*) *mf1p*))
-  (setf *mf1* method-function
-	*mf1cp* t
-	*mf1p* val))
-
-(defun method-function-get (method-function key &optional default)
-  (getf (method-function-plist method-function) key default))
-
-(defun #-setf SETF\ PCL\ METHOD-FUNCTION-GET #+setf (setf method-function-get)
-       (val method-function key)
-  (setf (getf (method-function-plist method-function) key) val))
-
-
-(defun method-function-pv-table (method-function)
-  (method-function-get method-function :pv-table))
-
-(defun method-function-method (method-function)
-  (method-function-get method-function :method))
-
-(defun method-function-needs-next-methods-p (method-function)
-  (method-function-get method-function :needs-next-methods-p t))
-
-
-
-(defmacro method-function-closure-generator (method-function)
-  `(method-function-get ,method-function 'closure-generator))
-
-(defun load-defmethod (class name quals specls ll initargs &optional pv-table-symbol)
-  (when (listp name) (do-standard-defsetf-1 (cadr name)))
-  (setq initargs (copy-tree initargs))
-  (let ((method-spec (or (getf initargs ':method-spec)
-			 (make-method-spec name quals specls))))
-    (setf (getf initargs ':method-spec) method-spec)
-    (record-definition 'method method-spec)
-    (load-defmethod-internal class name quals specls ll initargs pv-table-symbol)))
-
-(defun load-defmethod-internal
-    (method-class gf-spec qualifiers specializers lambda-list 
-		  initargs pv-table-symbol)
-  (when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec)))
-  (when pv-table-symbol
-    (setf (getf (getf initargs ':plist) :pv-table-symbol)
-	  pv-table-symbol))
-  (let ((method (apply #'add-named-method
-		       gf-spec qualifiers specializers lambda-list
-		       :definition-source `((defmethod ,gf-spec
-						,@qualifiers
-					      ,specializers)
-					    ,(load-truename))
-		       initargs)))
-    (unless (or (eq method-class 'standard-method)
-		(eq (find-class method-class nil) (class-of method)))
-      (format *error-output*
-	      "~&At the time the method with qualifiers ~:S and~%~
-               specializers ~:S on the generic function ~S~%~
-               was compiled, the method-class for that generic function was~%~
-               ~S.  But, the method class is now ~S, this~%~
-               may mean that this method was compiled improperly.~%"
-	      qualifiers specializers gf-spec
-	      method-class (class-name (class-of method))))
-    method))
-
-(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
-  `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
-
-(defun initialize-method-function (initargs &optional return-function-p method)
-  (let* ((mf (getf initargs ':function))
-	 (method-spec (getf initargs ':method-spec))
-	 (plist (getf initargs ':plist))
-	 (pv-table-symbol (getf plist ':pv-table-symbol))
-	 (pv-table nil)
-	 (mff (getf initargs ':fast-function)))
-    (flet ((set-mf-property (p v)
-	     (when mf
-	       (setf (method-function-get mf p) v))
-	     (when mff
-	       (setf (method-function-get mff p) v))))
-      (when method-spec
-	(when mf
-	  (setq mf (set-function-name mf method-spec)))
-	(when mff
-	  (let ((name `(,(or (get (car method-spec) 'fast-sym)
-			     (setf (get (car method-spec) 'fast-sym)
-				   (intern (format nil "FAST-~A"
-						   (car method-spec))
-					   *the-pcl-package*)))
-			 ,@(cdr method-spec))))
-	    (set-function-name mff name)
-	    (unless mf
-	      (set-mf-property :name name)))))
-      (when plist
-	(let ((snl (getf plist :slot-name-lists))
-	      (cl (getf plist :call-list)))
-	  (when (or snl cl)
-	    (setq pv-table (intern-pv-table :slot-name-lists snl
-					    :call-list cl))
-	    (when pv-table (set pv-table-symbol pv-table))
-	    (set-mf-property :pv-table pv-table)))    
-	(loop (when (null plist) (return nil))
-	      (set-mf-property (pop plist) (pop plist)))      
-	(when method
-	  (set-mf-property :method method))    
-	(when return-function-p
-	  (or mf (method-function-from-fast-function mff)))))))
-
-
-
-(defun analyze-lambda-list (lambda-list)
-  ;;(declare (values nrequired noptional keysp restp allow-other-keys-p
-  ;;                 keywords keyword-parameters))
-  (flet ((parse-keyword-argument (arg)
-	   (if (listp arg)
-	       (if (listp (car arg))
-		   (caar arg)
-		   (make-keyword (car arg)))
-	       (make-keyword arg))))
-    (let ((nrequired 0)
-	  (noptional 0)
-	  (keysp nil)
-	  (restp nil)
-	  (allow-other-keys-p nil)
-	  (keywords ())
-	  (keyword-parameters ())
-	  (state 'required))
-      (dolist (x lambda-list)
-	(if (memq x lambda-list-keywords)
-	    (case x
-	      (&optional         (setq state 'optional))
-	      (&key              (setq keysp 't
-				       state 'key))
-	      (&allow-other-keys (setq allow-other-keys-p 't))
-	      (&rest             (setq restp 't
-				       state 'rest))
-	      (&aux              (return t))
-	      (otherwise
-		(error "Encountered the non-standard lambda list keyword ~S." x)))
-	    (ecase state
-	      (required  (incf nrequired))
-	      (optional  (incf noptional))
-	      (key       (push (parse-keyword-argument x) keywords)
-			 (push x keyword-parameters))
-	      (rest      ()))))
-      (values nrequired noptional keysp restp allow-other-keys-p
-	      (reverse keywords)
-	      (reverse keyword-parameters)))))
-
-(defun keyword-spec-name (x)
-  (let ((key (if (atom x) x (car x))))
-    (if (atom key)
-	(intern (symbol-name key) (find-package "KEYWORD"))
-	(car key))))
-
-(defun ftype-declaration-from-lambda-list (lambda-list #+cmu name)
-  (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p
-				  keywords keyword-parameters)
-      (analyze-lambda-list lambda-list)
-    (declare (ignore keyword-parameters))
-    (let* (#+cmu (old (c::info function type name))
-	   #+cmu (old-ftype (if (c::function-type-p old) old nil))
-	   #+cmu (old-restp (and old-ftype (c::function-type-rest old-ftype)))
-	   #+cmu (old-keys (and old-ftype
-				(mapcar #'c::key-info-name
-					(c::function-type-keywords old-ftype))))
-	   #+cmu (old-keysp (and old-ftype (c::function-type-keyp old-ftype)))
-	   #+cmu (old-allowp (and old-ftype (c::function-type-allowp old-ftype)))
-	   (keywords #+cmu (union old-keys (mapcar #'keyword-spec-name keywords))
-		     #-cmu (mapcar #'keyword-spec-name keywords)))
-      `(function ,(append (make-list nrequired :initial-element 't)
-			  (when (plusp noptional)
-			    (append '(&optional)
-				    (make-list noptional :initial-element 't)))
-			  (when (or restp #+cmu old-restp)
-			    '(&rest t))
-			  (when (or keysp #+cmu old-keysp)
-			    (append '(&key)
-				    (mapcar #'(lambda (key)
-						`(,key t))
-					    keywords)
-				    (when (or allow-other-keys-p #+cmu old-allowp)
-				      '(&allow-other-keys)))))
-		 *))))
-
-(defun proclaim-defgeneric (spec lambda-list)
-  #-cmu (declare (ignore lambda-list))
-  (when (consp spec)
-    (setq spec (get-setf-function-name (cadr spec))))
-  (let (#+cmu
-	(decl `(ftype ,(ftype-declaration-from-lambda-list lambda-list #+cmu spec)
-		      ,spec)))
-    #+cmu (proclaim decl)
-    #+kcl (setf (get spec 'compiler::proclaimed-closure) t)))
-
-;;;; Early generic-function support
-;;;
-;;;
-(defvar *early-generic-functions* ())
-
-(defun ensure-generic-function (function-specifier
-				&rest all-keys
-				&key environment
-				&allow-other-keys)
-  (declare (ignore environment))
-  #+copy-&rest-arg (setq all-keys (copy-list all-keys))
-  (let ((existing (and (gboundp function-specifier)		       
-		       (gdefinition function-specifier))))
-    (if (and existing
-	     (eq *boot-state* 'complete)
-	     (null (generic-function-p existing)))
-	(generic-clobbers-function function-specifier)
-	(apply #'ensure-generic-function-using-class
-	       existing function-specifier all-keys))))
-
-(defun generic-clobbers-function (function-specifier)
-  #+Lispm (zl:signal 'generic-clobbers-function :name function-specifier)
-  #-Lispm (error "~S already names an ordinary function or a macro,~%~
-                  you may want to replace it with a generic function, but doing so~%~
-                  will require that you decide what to do with the existing function~%~
-                  definition.~%~
-                  The PCL-specific function MAKE-SPECIALIZABLE may be useful to you."
-		 function-specifier))
-
-#+Lispm
-(zl:defflavor generic-clobbers-function (name) (si:error)
-  :initable-instance-variables)
-
-#+Lispm
-(zl:defmethod #+Genera (dbg:report generic-clobbers-function)
-	      #+ti (generic-clobbers-function :report)
-	      (stream)
- (format stream
-	 "~S aready names a ~a"
-	 name
-	 (if (and (symbolp name) (macro-function name)) "macro" "function")))
-
-#+Genera
-(zl:defmethod (sys:proceed generic-clobbers-function :specialize-it) ()
-  "Make it specializable anyway?"
-  (make-specializable name))
-
-#+ti
-(zl:defmethod
-     (generic-clobbers-function :case :proceed-asking-user :specialize-it)
-     (continuation ignore)
-  "Make it specializable anyway?"
-  (make-specializable name)
-  (funcall continuation :specialize-it))
-
-(defvar *sgf-wrapper* 
-  (make-wrapper (early-class-size 'standard-generic-function)))
-
-(defvar *sgf-slots-init*
-  (mapcar #'(lambda (canonical-slot)
-	      (if (memq (getf canonical-slot :name) '(arg-info source))
-		  *slot-unbound*
-		  (let ((initfunction (getf canonical-slot :initfunction)))
-		    (if initfunction
-			(funcall initfunction)
-			*slot-unbound*))))
-	  (early-collect-inheritance 'standard-generic-function)))
-
-(defvar *sgf-method-class-index* 
-  (bootstrap-slot-index 'standard-generic-function 'method-class))
-
-(defun early-gf-p (x)
-  (and (fsc-instance-p x)
-       (eq (instance-ref (get-slots x) *sgf-method-class-index*)
-	   *slot-unbound*)))
-
-(defvar *sgf-methods-index* 
-  (bootstrap-slot-index 'standard-generic-function 'methods))
-
-(defmacro early-gf-methods (gf)
-  `(instance-ref (get-slots ,gf) *sgf-methods-index*))
-
-(defvar *sgf-arg-info-index* 
-  (bootstrap-slot-index 'standard-generic-function 'arg-info))
-
-(defmacro early-gf-arg-info (gf)
-  `(instance-ref (get-slots ,gf) *sgf-arg-info-index*))
-
-(defvar *sgf-dfun-state-index* 
-  (bootstrap-slot-index 'standard-generic-function 'dfun-state))
-
-(defstruct (arg-info
-	     (:conc-name nil)
-	     (:constructor make-arg-info ()))
-  (arg-info-lambda-list :no-lambda-list)
-  arg-info-precedence
-  arg-info-metatypes
-  arg-info-number-optional
-  arg-info-key/rest-p
-  arg-info-keywords ;nil         no keyword or rest allowed
-	            ;(k1 k2 ..)  each method must accept these keyword arguments
-	            ;T           must have &key or &rest
-
-  gf-info-simple-accessor-type ; nil, reader, writer, boundp
-  (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info
-
-  gf-info-static-c-a-m-emf
-  (gf-info-c-a-m-emf-std-p t)
-  gf-info-fast-mf-p)
-
-(defun arg-info-valid-p (arg-info)
-  (not (null (arg-info-number-optional arg-info))))
-
-(defun arg-info-applyp (arg-info)
-  (or (plusp (arg-info-number-optional arg-info))
-      (arg-info-key/rest-p arg-info)))
-
-(defun arg-info-number-required (arg-info)
-  (length (arg-info-metatypes arg-info)))
-
-(defun arg-info-nkeys (arg-info)
-  (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info)))
-
-(defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
-			argument-precedence-order)
-  (let* ((arg-info (if (eq *boot-state* 'complete)
-		       (gf-arg-info gf)
-		       (early-gf-arg-info gf)))
-	 (methods (if (eq *boot-state* 'complete)
-		      (generic-function-methods gf)
-		      (early-gf-methods gf)))
-	 (was-valid-p (integerp (arg-info-number-optional arg-info)))
-	 (first-p (and new-method (null (cdr methods)))))
-    (when (and (not lambda-list-p) methods)      
-      (setq lambda-list (gf-lambda-list gf)))
-    (when (or lambda-list-p
-	      (and first-p (eq (arg-info-lambda-list arg-info) ':no-lambda-list)))
-      (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
-	  (analyze-lambda-list lambda-list)
-	(when (and methods (not first-p))
-	  (let ((gf-nreq (arg-info-number-required arg-info))
-		(gf-nopt (arg-info-number-optional arg-info))
-		(gf-key/rest-p (arg-info-key/rest-p arg-info)))
-	    (unless (and (= nreq gf-nreq)
-			 (= nopt gf-nopt)
-			 (eq (or keysp restp) gf-key/rest-p))
-	      (error "The lambda-list ~S is incompatible with ~
-                     existing methods of ~S."
-		     lambda-list gf))))
-	(when lambda-list-p
-	  (setf (arg-info-lambda-list arg-info) lambda-list))
-	(when (or lambda-list-p argument-precedence-order
-		  (null (arg-info-precedence arg-info)))
-	  (setf (arg-info-precedence arg-info)
-		(compute-precedence lambda-list nreq argument-precedence-order)))
-	(setf (arg-info-metatypes arg-info) (make-list nreq))
-	(setf (arg-info-number-optional arg-info) nopt)
-	(setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
-	(setf (arg-info-keywords arg-info) 
-	      (if lambda-list-p
-		  (if allow-other-keys-p t keywords)
-		  (arg-info-key/rest-p arg-info)))))
-    (when new-method
-      (check-method-arg-info gf arg-info new-method))
-    (set-arg-info1 gf arg-info new-method methods was-valid-p first-p)
-    arg-info))
-
-(defun check-method-arg-info (gf arg-info method)
-  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
-      (analyze-lambda-list (if (consp method)
-			       (early-method-lambda-list method)
-			       (method-lambda-list method)))
-    (flet ((lose (string &rest args)
-	     (error "Attempt to add the method ~S to the generic function ~S.~%~
-                   But ~A" method gf (apply #'format nil string args)))
-	   (compare (x y)
-	     (if (> x y) "more" "fewer")))
-      (let ((gf-nreq (arg-info-number-required arg-info))
-	    (gf-nopt (arg-info-number-optional arg-info))
-	    (gf-key/rest-p (arg-info-key/rest-p arg-info))
-	    (gf-keywords (arg-info-keywords arg-info)))
-	(unless (= nreq gf-nreq)
-	  (lose "the method has ~A required arguments than the generic function."
-		(compare nreq gf-nreq)))
-	(unless (= nopt gf-nopt)
-	  (lose "the method has ~S optional arguments than the generic function."
-		(compare nopt gf-nopt)))
-	(unless (eq (or keysp restp) gf-key/rest-p)
-	  (error "the method and generic function differ in whether they accept~%~
-                  rest or keyword arguments."))
-	(when (consp gf-keywords)
-	  (unless (or (and restp (not keysp))
-		      allow-other-keys-p
-		      (every #'(lambda (k) (memq k keywords)) gf-keywords))
-	    (lose "the method does not accept each of the keyword arguments~%~
-                 ~S." gf-keywords)))))))
-
-(defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)  
-  (let* ((existing-p (and methods (cdr methods) new-method))
-	 (nreq (length (arg-info-metatypes arg-info)))
-	 (metatypes (if existing-p
-			(arg-info-metatypes arg-info)
-			(make-list nreq)))
-	 (type (if existing-p
-		   (gf-info-simple-accessor-type arg-info)
-		   nil)))
-    (when (arg-info-valid-p arg-info)
-      (dolist (method (if new-method (list new-method) methods))
-	(let* ((specializers (if (or (eq *boot-state* 'complete)
-				     (not (consp method)))
-				 (method-specializers method)
-				 (early-method-specializers method t)))
-	       (class (if (or (eq *boot-state* 'complete) (not (consp method)))
-			  (class-of method)
-			  (early-method-class method)))
-	       (new-type (when (and class
-				    (or (not (eq *boot-state* 'complete))
-					(eq (generic-function-method-combination gf)
-					    *standard-method-combination*)))
-			   (cond ((eq class *the-class-standard-reader-method*)
-				  'reader)
-				 ((eq class *the-class-standard-writer-method*)
-				  'writer)
-				 ((eq class *the-class-standard-boundp-method*)
-				  'boundp)))))
-	  (setq metatypes (mapcar #'raise-metatype metatypes specializers))
-	  (setq type (cond ((null type) new-type)
-			   ((eq type new-type) type)
-			   (t nil)))))
-      (setf (arg-info-metatypes arg-info) metatypes)
-      (setf (gf-info-simple-accessor-type arg-info) type)))
-  (when (or (not was-valid-p) first-p)
-    (multiple-value-bind (c-a-m-emf std-p)
-	(if (early-gf-p gf)
-	    (values t t)
-	    (compute-applicable-methods-emf gf))
-      (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
-      (setf (gf-info-c-a-m-emf-std-p arg-info) std-p)
-      (unless (gf-info-c-a-m-emf-std-p arg-info)
-	(setf (gf-info-simple-accessor-type arg-info) t))))
-  (unless was-valid-p
-    (let ((name (if (eq *boot-state* 'complete)
-		    (generic-function-name gf)
-		    (early-gf-name gf))))
-      (setf (gf-precompute-dfun-and-emf-p arg-info) 
-	    (let* ((sym (if (atom name) name (cadr name)))
-		   (pkg-list (cons *the-pcl-package* 
-				   (package-use-list *the-pcl-package*))))
-	      (and sym (symbolp sym)
-		   (not (null (memq (symbol-package sym) pkg-list)))
-		   (not (find #\space (symbol-name sym))))))))
-  (setf (gf-info-fast-mf-p arg-info)
-	(or (not (eq *boot-state* 'complete))
-	    (let* ((method-class (generic-function-method-class gf))
-		   (methods (compute-applicable-methods 
-			     #'make-method-lambda
-			     (list gf (class-prototype method-class)
-				   '(lambda) nil))))
-	      (and methods (null (cdr methods))
-		   (let ((specls (method-specializers (car methods))))
-		     (and (classp (car specls))
-			  (eq 'standard-generic-function (class-name (car specls)))
-			  (classp (cadr specls))
-			  (eq 'standard-method (class-name (cadr specls)))))))))
-  arg-info)
-
-;;;
-;;; This is the early definition of ensure-generic-function-using-class.
-;;; 
-;;; The static-slots field of the funcallable instances used as early generic
-;;; functions is used to store the early methods and early discriminator code
-;;; for the early generic function.  The static slots field of the fins
-;;; contains a list whose:
-;;;    CAR    -   a list of the early methods on this early gf
-;;;    CADR   -   the early discriminator code for this method
-;;;    
-(defun ensure-generic-function-using-class (existing spec &rest keys
-					    &key (lambda-list nil lambda-list-p)
-					    &allow-other-keys)
-  (declare (ignore keys))
-  (cond ((and existing (early-gf-p existing))
-	 existing)
-	((assoc spec *generic-function-fixups* :test #'equal)
-	 (if existing
-	     (make-early-gf spec lambda-list lambda-list-p existing)	       
-	     (error "The function ~S is not already defined" spec)))
-	(existing
-	 (error "~S should be on the list ~S" spec '*generic-function-fixups*))
-	(t
-	 (pushnew spec *early-generic-functions* :test #'equal)
-	 (make-early-gf spec lambda-list lambda-list-p))))
-
-(defun make-early-gf (spec &optional lambda-list lambda-list-p function)
-  (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
-    (set-funcallable-instance-function 
-     fin 
-     (or function
-	 (if (eq spec 'print-object)
-	     #'(lambda (instance stream)
-		 (printing-random-thing (instance stream)
-		   (format stream "std-instance")))
-	     #'(lambda (&rest args)
-		 (declare (ignore args))
-		 (error "The function of the funcallable-instance ~S~
-                         has not been set" fin)))))
-    (setf (gdefinition spec) fin)
-    (bootstrap-set-slot 'standard-generic-function fin 'name spec)
-    (bootstrap-set-slot 'standard-generic-function fin 'source (load-truename))
-    (set-function-name fin spec)
-    (let ((arg-info (make-arg-info)))
-      (setf (early-gf-arg-info fin) arg-info)
-      (when lambda-list-p
-	(proclaim-defgeneric spec lambda-list)
-	(set-arg-info fin :lambda-list lambda-list)))
-    fin))
-
-(defun set-dfun (gf &optional dfun cache info)
-  (when cache
-    (setf (cache-owner cache) gf))
-  (let ((new-state (if (and dfun (or cache info))
-		       (list* dfun cache info)
-		       dfun)))
-    (if (eq *boot-state* 'complete)
-	(setf (gf-dfun-state gf) new-state)
-	(setf (instance-ref (get-slots gf) *sgf-dfun-state-index*) new-state)))
-  dfun)
-
-(defun gf-dfun-cache (gf)
-  (let ((state (if (eq *boot-state* 'complete)
-		   (gf-dfun-state gf)
-		   (instance-ref (get-slots gf) *sgf-dfun-state-index*))))
-    (typecase state
-      (function nil)
-      (cons (cadr state)))))
-
-(defun gf-dfun-info (gf)
-  (let ((state (if (eq *boot-state* 'complete)
-		   (gf-dfun-state gf)
-		   (instance-ref (get-slots gf) *sgf-dfun-state-index*))))
-    (typecase state
-      (function nil)
-      (cons (cddr state)))))
-
-(defvar *sgf-name-index* 
-  (bootstrap-slot-index 'standard-generic-function 'name))
-
-(defun early-gf-name (gf)
-  (instance-ref (get-slots gf) *sgf-name-index*))
-
-(defun gf-lambda-list (gf)
-  (let ((arg-info (if (eq *boot-state* 'complete)
-		      (gf-arg-info gf)
-		      (early-gf-arg-info gf))))
-    (if (eq ':no-lambda-list (arg-info-lambda-list arg-info))
-	(let ((methods (if (eq *boot-state* 'complete)
-			   (generic-function-methods gf)
-			   (early-gf-methods gf))))
-	  (if (null methods)
-	      (progn
-		(warn "No way to determine the lambda list for ~S." gf)
-		nil)
-	      (let* ((method (car (last methods)))
-		     (ll (if (consp method)
-			     (early-method-lambda-list method)
-			     (method-lambda-list method)))
-		     (k (member '&key ll)))
-		(if k 
-		    (append (ldiff ll (cdr k)) '(&allow-other-keys))
-		    ll))))
-	(arg-info-lambda-list arg-info))))
-
-(defmacro real-ensure-gf-internal (gf-class all-keys env)
-  `(progn
-     (cond ((symbolp ,gf-class)
-	    (setq ,gf-class (find-class ,gf-class t ,env)))
-	   ((classp ,gf-class))
-	   (t
-	    (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
-                    class nor a symbol that names a class."
-		   ,gf-class)))
-     (remf ,all-keys :generic-function-class)
-     (remf ,all-keys :environment)
-     (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
-       (unless (eq combin '.shes-not-there.)
-	 (setf (getf ,all-keys :method-combination)
-	       (find-method-combination (class-prototype ,gf-class)
-					(car combin)
-					(cdr combin)))))
-     ))
-     
-(defun real-ensure-gf-using-class--generic-function
-       (existing
-	function-specifier
-	&rest all-keys
-	&key environment (lambda-list nil lambda-list-p)
-	     (generic-function-class 'standard-generic-function gf-class-p)
-	&allow-other-keys)
-  #+copy-&rest-arg (setq all-keys (copy-list all-keys))
-  (real-ensure-gf-internal generic-function-class all-keys environment)
-  (unless (or (null gf-class-p)
-	      (eq (class-of existing) generic-function-class))
-    (change-class existing generic-function-class))
-  (prog1
-      (apply #'reinitialize-instance existing all-keys)
-    (when lambda-list-p
-      (proclaim-defgeneric function-specifier lambda-list))))
-
-(defun real-ensure-gf-using-class--null
-       (existing
-	function-specifier
-	&rest all-keys
-	&key environment (lambda-list nil lambda-list-p)
-	     (generic-function-class 'standard-generic-function)
-	&allow-other-keys)
-  (declare (ignore existing))
-  #+copy-&rest-arg (setq all-keys (copy-list all-keys))
-  (real-ensure-gf-internal generic-function-class all-keys environment)
-  (prog1
-      (setf (gdefinition function-specifier)
-	    (apply #'make-instance generic-function-class 
-		   :name function-specifier all-keys))
-    (when lambda-list-p
-      (proclaim-defgeneric function-specifier lambda-list))))
-
-
-
-(defun get-generic-function-info (gf)
-  ;; values   nreq applyp metatypes nkeys arg-info
-  (multiple-value-bind (applyp metatypes arg-info)
-      (let* ((arg-info (if (early-gf-p gf)
-			   (early-gf-arg-info gf)
-			   (gf-arg-info gf)))
-	     (metatypes (arg-info-metatypes arg-info)))
-	(values (arg-info-applyp arg-info)
-		metatypes
-		arg-info))
-    (values (length metatypes) applyp metatypes
-	    (count-if #'(lambda (x) (neq x 't)) metatypes)
-	    arg-info)))
-
-(defun early-make-a-method (class qualifiers arglist specializers initargs doc
-			    &optional slot-name)
-  (initialize-method-function initargs)
-  (let ((parsed ())
-	(unparsed ()))
-    ;; Figure out whether we got class objects or class names as the
-    ;; specializers and set parsed and unparsed appropriately.  If we
-    ;; got class objects, then we can compute unparsed, but if we got
-    ;; class names we don't try to compute parsed.
-    ;; 
-    ;; Note that the use of not symbolp in this call to every should be
-    ;; read as 'classp' we can't use classp itself because it doesn't
-    ;; exist yet.
-    (if (every #'(lambda (s) (not (symbolp s))) specializers)
-	(setq parsed specializers
-	      unparsed (mapcar #'(lambda (s)
-				   (if (eq s 't) 't (class-name s)))
-			       specializers))
-	(setq unparsed specializers
-	      parsed ()))
-    (list :early-method		  ;This is an early method dammit!
-	  
-	  (getf initargs ':function)
-	  (getf initargs ':fast-function)
-	  
-	  parsed                  ;The parsed specializers.  This is used
-				  ;by early-method-specializers to cache
-				  ;the parse.  Note that this only comes
-				  ;into play when there is more than one
-				  ;early method on an early gf.
-	  
-	  (list class             ;A list to which real-make-a-method
-		qualifiers        ;can be applied to make a real method
-		arglist           ;corresponding to this early one.
-		unparsed
-		initargs
-		doc
-		slot-name)
-	  )))
-
-(defun real-make-a-method
-       (class qualifiers lambda-list specializers initargs doc
-	&optional slot-name)
-  (setq specializers (parse-specializers specializers))
-  (apply #'make-instance class 
-	 :qualifiers qualifiers
-	 :lambda-list lambda-list
-	 :specializers specializers
-	 :documentation doc
-	 :slot-name slot-name
-	 :allow-other-keys t
-	 initargs))
-
-(defun early-method-function (early-method)
-  (values (cadr early-method) (caddr early-method)))
-
-(defun early-method-class (early-method)
-  (find-class (car (fifth early-method))))
-
-(defun early-method-standard-accessor-p (early-method)
-  (let ((class (first (fifth early-method))))
-    (or (eq class 'standard-reader-method)
-        (eq class 'standard-writer-method)
-        (eq class 'standard-boundp-method))))
-
-(defun early-method-standard-accessor-slot-name (early-method)
-  (seventh (fifth early-method)))
-
-;;;
-;;; Fetch the specializers of an early method.  This is basically just a
-;;; simple accessor except that when the second argument is t, this converts
-;;; the specializers from symbols into class objects.  The class objects
-;;; are cached in the early method, this makes bootstrapping faster because
-;;; the class objects only have to be computed once.
-;;; NOTE:
-;;;  the second argument should only be passed as T by early-lookup-method.
-;;;  this is to implement the rule that only when there is more than one
-;;;  early method on a generic function is the conversion from class names
-;;;  to class objects done.
-;;;  the corresponds to the fact that we are only allowed to have one method
-;;;  on any generic function up until the time classes exist.
-;;;  
-(defun early-method-specializers (early-method &optional objectsp)
-  (if (and (listp early-method)
-	   (eq (car early-method) :early-method))
-      (cond ((eq objectsp 't)
-	     (or (fourth early-method)
-		 (setf (fourth early-method)
-		       (mapcar #'find-class (cadddr (fifth early-method))))))
-	    (t
-	     (cadddr (fifth early-method))))
-      (error "~S is not an early-method." early-method)))
-
-(defun early-method-qualifiers (early-method)
-  (cadr (fifth early-method)))
-
-(defun early-method-lambda-list (early-method)
-  (caddr (fifth early-method)))
-
-(defun early-add-named-method (generic-function-name
-			       qualifiers
-			       specializers
-			       arglist
-			       &rest initargs)
-  #+copy-&rest-arg (setq initargs (copy-list initargs))
-  (let* ((gf (ensure-generic-function generic-function-name))
-	 (existing
-	   (dolist (m (early-gf-methods gf))
-	     (when (and (equal (early-method-specializers m) specializers)
-			(equal (early-method-qualifiers m) qualifiers))
-	       (return m))))
-	 (new (make-a-method 'standard-method
-			     qualifiers
-			     arglist
-			     specializers
-			     initargs
-			     ())))
-    (when existing (remove-method gf existing))
-    (add-method gf new)))
-
-;;;
-;;; This is the early version of add-method.  Later this will become a
-;;; generic function.  See fix-early-generic-functions which has special
-;;; knowledge about add-method.
-;;;
-(defun add-method (generic-function method)
-  (when (not (fsc-instance-p generic-function))
-    (error "Early add-method didn't get a funcallable instance."))
-  (when (not (and (listp method) (eq (car method) :early-method)))
-    (error "Early add-method didn't get an early method."))
-  (push method (early-gf-methods generic-function))
-  (set-arg-info generic-function :new-method method)
-  (unless (assoc (early-gf-name generic-function) *generic-function-fixups*
-		 :test #'equal)
-    (update-dfun generic-function)))
-
-;;;
-;;; This is the early version of remove method.
-;;;
-(defun remove-method (generic-function method)
-  (when (not (fsc-instance-p generic-function))
-    (error "Early remove-method didn't get a funcallable instance."))
-  (when (not (and (listp method) (eq (car method) :early-method)))
-    (error "Early remove-method didn't get an early method."))
-  (setf (early-gf-methods generic-function)
-	(remove method (early-gf-methods generic-function)))
-  (set-arg-info generic-function)
-  (unless (assoc (early-gf-name generic-function) *generic-function-fixups*
-		 :test #'equal)
-    (update-dfun generic-function)))
-
-;;;
-;;; And the early version of get-method.
-;;;
-(defun get-method (generic-function qualifiers specializers
-				    &optional (errorp t))
-  (if (early-gf-p generic-function)
-      (or (dolist (m (early-gf-methods generic-function))
-	    (when (and (or (equal (early-method-specializers m nil)
-				  specializers)
-			   (equal (early-method-specializers m 't)
-				  specializers))
-		       (equal (early-method-qualifiers m) qualifiers))
-	      (return m)))
-	  (if errorp
-	      (error "Can't get early method.")
-	      nil))
-      (real-get-method generic-function qualifiers specializers errorp)))
-
-(defvar *fegf-debug-p* nil)
-
-(defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*))
-  (setq *fegf-started-p* t)
-  (let ((accessors nil))
-    ;; Rearrange *early-generic-functions* to speed up fix-early-generic-functions.
-    (dolist (early-gf-spec *early-generic-functions*)
-      (when (every #'early-method-standard-accessor-p
-		   (early-gf-methods (gdefinition early-gf-spec)))
-	(push early-gf-spec accessors)))
-    (dolist (spec (nconc accessors
-			 '(accessor-method-slot-name
-			   generic-function-methods
-			   method-specializers
-			   specializerp
-			   specializer-type
-			   specializer-class
-			   slot-definition-location
-			   slot-definition-name
-			   class-slots
-			   gf-arg-info
-			   class-precedence-list
-			   slot-boundp-using-class
-			   (setf slot-value-using-class)
-			   slot-value-using-class
-			   structure-class-p
-			   standard-class-p
-			   funcallable-standard-class-p
-			   specializerp)))
-      (setq *early-generic-functions* 
-	    (cons spec (delete spec *early-generic-functions* :test #'equal))))
-
-    (dolist (early-gf-spec *early-generic-functions*)
-      (when noisyp (format t "~&~S..." early-gf-spec))
-      (let* ((gf (gdefinition early-gf-spec))
-	     (methods (mapcar #'(lambda (early-method)
-				  (let ((args (copy-list (fifth early-method))))
-				    (setf (fourth args)
-					  (early-method-specializers early-method t))
-				    (apply #'real-make-a-method args)))
-			      (early-gf-methods gf))))
-	(setf (generic-function-method-class gf) *the-class-standard-method*)
-	(setf (generic-function-method-combination gf) *standard-method-combination*)
-	(set-methods gf methods)))
-	  
-    (dolist (fns *early-functions*)
-      (setf (gdefinition (car fns)) (symbol-function (caddr fns))))
-      
-    (dolist (fixup *generic-function-fixups*)
-      (let* ((fspec (car fixup))
-	     (gf (gdefinition fspec))
-	     (methods (mapcar #'(lambda (method)
-				  (let* ((lambda-list (first method))
-					 (specializers (second method))
-					 (method-fn-name (third method))
-					 (fn-name (or method-fn-name fspec))
-					 (fn (symbol-function fn-name))
-					 (initargs 
-					  (list :function
-						(set-function-name
-						 #'(lambda (args next-methods)
-						     (declare (ignore next-methods))
-						     (apply fn args))
-						 `(call ,fn-name)))))
-				    (declare (type function fn))
-				    (make-a-method 'standard-method
-						   ()
-						   lambda-list
-						   specializers
-						   initargs
-						   nil)))
-			      (cdr fixup))))
-	(setf (generic-function-method-class gf) *the-class-standard-method*)
-	(setf (generic-function-method-combination gf) *standard-method-combination*)
-	(set-methods gf methods)))))
-
-
-;;;
-;;; parse-defmethod is used by defmethod to parse the &rest argument into
-;;; the 'real' arguments.  This is where the syntax of defmethod is really
-;;; implemented.
-;;; 
-(defun parse-defmethod (cdr-of-form)
-  ;;(declare (values name qualifiers specialized-lambda-list body))
-  (let ((name (pop cdr-of-form))
-	(qualifiers ())
-	(spec-ll ()))
-    (loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
-	      (push (pop cdr-of-form) qualifiers)
-	      (return (setq qualifiers (nreverse qualifiers)))))
-    (setq spec-ll (pop cdr-of-form))
-    (values name qualifiers spec-ll cdr-of-form)))
-
-(defun parse-specializers (specializers)
-  (flet ((parse (spec)
-	   (let ((result (specializer-from-type spec)))
-	     (if (specializerp result)
-		 result
-		 (if (symbolp spec)
-		     (error "~S used as a specializer,~%~
-                             but is not the name of a class."
-			    spec)
-		     (error "~S is not a legal specializer." spec))))))
-    (mapcar #'parse specializers)))
-
-(defun unparse-specializers (specializers-or-method)
-  (if (listp specializers-or-method)
-      (flet ((unparse (spec)
-	       (if (specializerp spec)
-                   (let ((type (specializer-type spec)))
-                     (if (and (consp type)
-                              (eq (car type) 'class))
-                         (let* ((class (cadr type))
-                                (class-name (class-name class)))
-                           (if (eq class (find-class class-name nil))
-                               class-name
-                               type))
-                         type))
-		   (error "~S is not a legal specializer." spec))))
-	(mapcar #'unparse specializers-or-method))
-      (unparse-specializers (method-specializers specializers-or-method))))
-
-(defun parse-method-or-spec (spec &optional (errorp t))
-  ;;(declare (values generic-function method method-name))
-  (let (gf method name temp)
-    (if (method-p spec)	
-	(setq method spec
-	      gf (method-generic-function method)
-	      temp (and gf (generic-function-name gf))
-	      name (if temp
-		       (intern-function-name
-			 (make-method-spec temp
-					   (method-qualifiers method)
-					   (unparse-specializers
-					     (method-specializers method))))
-		       (make-symbol (format nil "~S" method))))
-	(multiple-value-bind (gf-spec quals specls)
-	    (parse-defmethod spec)
-	  (and (setq gf (and (or errorp (gboundp gf-spec))
-			     (gdefinition gf-spec)))
-	       (let ((nreq (compute-discriminating-function-arglist-info gf)))
-		 (setq specls (append (parse-specializers specls)
-				      (make-list (- nreq (length specls))
-						 :initial-element
-						 *the-class-t*)))
-		 (and 
-		   (setq method (get-method gf quals specls errorp))
-		   (setq name
-			 (intern-function-name (make-method-spec gf-spec
-								 quals
-								 specls))))))))
-    (values gf method name)))
-
-
-
-(defun extract-parameters (specialized-lambda-list)
-  (multiple-value-bind (parameters ignore1 ignore2)
-      (parse-specialized-lambda-list specialized-lambda-list)
-    (declare (ignore ignore1 ignore2))
-    parameters))
-
-(defun extract-lambda-list (specialized-lambda-list)
-  (multiple-value-bind (ignore1 lambda-list ignore2)
-      (parse-specialized-lambda-list specialized-lambda-list)
-    (declare (ignore ignore1 ignore2))
-    lambda-list))
-
-(defun extract-specializer-names (specialized-lambda-list)
-  (multiple-value-bind (ignore1 ignore2 specializers)
-      (parse-specialized-lambda-list specialized-lambda-list)
-    (declare (ignore ignore1 ignore2))
-    specializers))
-
-(defun extract-required-parameters (specialized-lambda-list)
-  (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters)
-      (parse-specialized-lambda-list specialized-lambda-list)
-    (declare (ignore ignore1 ignore2 ignore3))
-    required-parameters))
-
-(defun parse-specialized-lambda-list (arglist &optional post-keyword)
-  ;;(declare (values parameters lambda-list specializers required-parameters))
-  (let ((arg (car arglist)))
-    (cond ((null arglist) (values nil nil nil nil))
-	  ((eq arg '&aux)
-	   (values nil arglist nil))
-	  ((memq arg lambda-list-keywords)
-	   (unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
-	     ;; Warn about non-standard lambda-list-keywords, but then
-	     ;; go on to treat them like a standard lambda-list-keyword
-	     ;; what with the warning its probably ok.
-	     (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
-                    Assuming that the symbols following it are parameters,~%~
-                    and not allowing any parameter specializers to follow~%~
-                    to follow it."
-		   arg))
-	   ;; When we are at a lambda-list-keyword, the parameters don't
-	   ;; include the lambda-list-keyword; the lambda-list does include
-	   ;; the lambda-list-keyword; and no specializers are allowed to
-	   ;; follow the lambda-list-keywords (at least for now).
-	   (multiple-value-bind (parameters lambda-list)
-	       (parse-specialized-lambda-list (cdr arglist) t)
-	     (values parameters
-		     (cons arg lambda-list)
-		     ()
-		     ())))
-	  (post-keyword
-	   ;; After a lambda-list-keyword there can be no specializers.
-	   (multiple-value-bind (parameters lambda-list)
-	       (parse-specialized-lambda-list (cdr arglist) t)	       
-	     (values (cons (if (listp arg) (car arg) arg) parameters)
-		     (cons arg lambda-list)
-		     ()
-		     ())))
-	  (t
-	   (multiple-value-bind (parameters lambda-list specializers required)
-	       (parse-specialized-lambda-list (cdr arglist))
-	     (values (cons (if (listp arg) (car arg) arg) parameters)
-		     (cons (if (listp arg) (car arg) arg) lambda-list)
-		     (cons (if (listp arg) (cadr arg) 't) specializers)
-		     (cons (if (listp arg) (car arg) arg) required)))))))
-
-
-(eval-when (load eval)
-  (setq *boot-state* 'early))
-
-
-#-cmu ;; CMUCL Has a real symbol-macrolet
-(progn
-(defmacro symbol-macrolet (bindings &body body &environment env)
-  (let ((specs (mapcar #'(lambda (binding)
-			   (list (car binding)
-				 (variable-lexical-p (car binding) env)
-				 (cadr binding)))
-		       bindings)))
-    (walk-form `(progn ,@body)
-	       env
-	       #'(lambda (f c e)
-		   (expand-symbol-macrolet-internal specs f c e)))))
-
-(defun expand-symbol-macrolet-internal (specs form context env)
-  (let ((entry nil))
-    (cond ((not (eq context :eval)) form)
-	  ((symbolp form)
-	   (if (and (setq entry (assoc form specs))
-		    (eq (cadr entry) (variable-lexical-p form env)))
-	       (caddr entry)
-	       form))
-	  ((not (listp form)) form)
-	  ((member (car form) '(setq setf))
-	   ;; Have to be careful.  We must only convert the form to a SETF
-	   ;; form when we convert one of the 'logical' variables to a form
-	   ;; Otherwise we will get looping in implementations where setf
-	   ;; is a macro which expands into setq.
-	   (let ((kind (car form)))
-	     (labels ((scan-setf (tail)
-			(if (null tail)
-			    nil
-			    (walker::relist*
-			      tail
-			      (if (and (setq entry (assoc (car tail) specs))
-				       (eq (cadr entry)
-					   (variable-lexical-p (car tail)
-							       env)))
-				  (progn (setq kind 'setf)
-					 (caddr entry))
-				  (car tail))
-			      (cadr tail)
-			      (scan-setf (cddr tail))))))
-	       (let (new-tail)
-		 (setq new-tail (scan-setf (cdr form)))
-		 (walker::recons form kind new-tail)))))
-	  ((eq (car form) 'multiple-value-setq)
-	   (let* ((vars (cadr form))
-		  (gensyms (mapcar #'(lambda (i) (declare (ignore i)) (gensym))
-				   vars)))
-	     `(multiple-value-bind ,gensyms 
-		  ,(caddr form)
-		.,(reverse (mapcar #'(lambda (v g) `(setf ,v ,g))
-				   vars
-				   gensyms)))))
-	  (t form))))
-)
-
-(defmacro with-slots (slots instance &body body)
-  (let ((in (gensym)))
-    `(let ((,in ,instance))
-       #+cmu (declare (ignorable ,in))
-       ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
-                             (third instance)
-                             instance)))
-	   (and (symbolp instance)
-                `((declare (variable-rebinding ,in ,instance)))))
-       ,in
-       (symbol-macrolet ,(mapcar #'(lambda (slot-entry)
-				     (let ((variable-name 
-					    (if (symbolp slot-entry)
-						slot-entry
-						(car slot-entry)))
-					   (slot-name
-					    (if (symbolp slot-entry)
-						slot-entry
-						(cadr slot-entry))))
-				       `(,variable-name
-					  (slot-value ,in ',slot-name))))
-				 slots)
-			,@body))))
-
-(defmacro with-accessors (slots instance &body body)
-  (let ((in (gensym)))
-    `(let ((,in ,instance))
-       #+cmu (declare (ignorable ,in))
-       ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
-                             (third instance)
-                             instance)))
-	   (and (symbolp instance)
-                `((declare (variable-rebinding ,in ,instance)))))
-       ,in
-       (symbol-macrolet ,(mapcar #'(lambda (slot-entry)
-				   (let ((variable-name (car slot-entry))
-					 (accessor-name (cadr slot-entry)))
-				     `(,variable-name
-				        (,accessor-name ,in))))
-			       slots)
-          ,@body))))
-
-
-
diff --git a/pcl/braid.lisp b/pcl/braid.lisp
deleted file mode 100644
index b05bd2db469329e6d8e7f3bd1572ebeb18671925..0000000000000000000000000000000000000000
--- a/pcl/braid.lisp
+++ /dev/null
@@ -1,698 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; Bootstrapping the meta-braid.
-;;;
-;;; The code in this file takes the early definitions that have been saved
-;;; up and actually builds those class objects.  This work is largely driven
-;;; off of those class definitions, but the fact that STANDARD-CLASS is the
-;;; class of all metaclasses in the braid is built into this code pretty
-;;; deeply.
-;;;
-;;; 
-
-(in-package :pcl)
-
-(defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p))
-  #-new-kcl-wrapper (declare (special *slot-unbound*))
-  #-new-kcl-wrapper
-  (let ((instance (%%allocate-instance--class))
-	(no-of-slots (wrapper-no-of-instance-slots wrapper)))
-    (setf (%std-instance-wrapper instance) wrapper)
-    (setf (%std-instance-slots instance) 
-	  (if slots-init-p
-	      (make-array no-of-slots :initial-contents slots-init)
-	      (make-array no-of-slots :initial-element *slot-unbound*)))
-    instance)
-  #+new-kcl-wrapper
-  (apply #'si:make-structure wrapper
-	 (if slots-init-p
-	     slots-init
-	     (let ((no-of-slots (si::s-data-length wrapper)))
-	       (if (< no-of-slots (fill-pointer *init-vector*))
-		   (aref *init-vector* no-of-slots)
-		   (get-init-list no-of-slots))))))
-
-(defmacro allocate-funcallable-instance-slots (wrapper &optional 
-						       slots-init-p slots-init)
-  #-new-kcl-wrapper
-  `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper)))
-     ,(if slots-init-p
-	  `(if ,slots-init-p
-	       (make-array no-of-slots :initial-contents ,slots-init)
-	       (make-array no-of-slots :initial-element *slot-unbound*))
-	  `(make-array no-of-slots :initial-element *slot-unbound*)))
-  #+new-kcl-wrapper
-  (if slots-init-p
-      `(if ,slots-init-p
-	   (allocate-standard-instance ,wrapper ,slots-init)
-	   (allocate-standard-instance ,wrapper))
-      `(allocate-standard-instance ,wrapper)))
-
-(defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p))
-  (let ((fin (allocate-funcallable-instance-1)))
-    (set-funcallable-instance-function
-     fin #'(lambda (&rest args)
-	     (declare (ignore args))
-	     (error "The function of the funcallable-instance ~S has not been set"
-		    fin)))
-    (setf (fsc-instance-wrapper fin) wrapper
-	  (fsc-instance-slots fin) (allocate-funcallable-instance-slots
-				    wrapper slots-init-p slots-init))
-    fin))
-
-(defun allocate-structure-instance (wrapper &optional (slots-init nil slots-init-p))
-  #-new-kcl-wrapper
-  (let* ((class (wrapper-class wrapper))
-	 (constructor (class-defstruct-constructor class)))
-    (if constructor
-	(let ((instance (funcall constructor))
-	      (slots (class-slots class)))
-	  (when slots-init-p
-	    (dolist (slot slots)
-	      (setf (slot-value-using-class class instance slot) (pop slots-init))))
-	  instance)
-	(error "Can't allocate an instance of class ~S" (class-name class))))
-  #+new-kcl-wrapper
-  (if slots-init-p
-      (allocate-standard-instance wrapper slots-init)
-      (allocate-standard-instance wrapper)))
-
-;;;
-;;; bootstrap-meta-braid
-;;;
-;;; This function builds the base metabraid from the early class definitions.
-;;;   
-(defmacro initial-classes-and-wrappers (&rest classes)
-  `(progn
-     ,@(mapcar #'(lambda (class)
-		   (let ((wr (intern (format nil "~A-WRAPPER" class) 
-				     *the-pcl-package*)))
-		     `(setf ,wr ,(if (eq class 'standard-generic-function)
-				     '*sgf-wrapper*
-				     `(make-wrapper (early-class-size ',class)))
-		            ,class (allocate-standard-instance
-				    ,(if (eq class 'standard-generic-function)
-					 'funcallable-standard-class-wrapper
-					 'standard-class-wrapper))
-		            (wrapper-class ,wr) ,class
-		            #+new-kcl-wrapper (si::s-data-name ,wr)
-		                   #+new-kcl-wrapper ',class
-		            (find-class ',class) ,class)))
-	      classes)))		        
-
-(defun bootstrap-meta-braid ()
-  (let* ((name 'class)
-	 (predicate-name (make-type-predicate-name name)))
-    (setf (gdefinition predicate-name)
-	  #'(lambda (x) (declare (ignore x)) t))
-    (do-satisfies-deftype name predicate-name))  
-  (let* ((*create-classes-from-internal-structure-definitions-p* nil)
-	 standard-class-wrapper standard-class
-	 funcallable-standard-class-wrapper funcallable-standard-class
-	 slot-class-wrapper slot-class
-	 built-in-class-wrapper built-in-class
-	 structure-class-wrapper structure-class
-	 standard-direct-slot-definition-wrapper standard-direct-slot-definition
-	 standard-effective-slot-definition-wrapper standard-effective-slot-definition
-	 class-eq-specializer-wrapper class-eq-specializer
-	 standard-generic-function-wrapper standard-generic-function)
-    (initial-classes-and-wrappers 
-     standard-class funcallable-standard-class
-     slot-class built-in-class structure-class
-     standard-direct-slot-definition standard-effective-slot-definition 
-     class-eq-specializer standard-generic-function)
-    ;;
-    ;; First, make a class metaobject for each of the early classes.  For
-    ;; each metaobject we also set its wrapper.  Except for the class T,
-    ;; the wrapper is always that of STANDARD-CLASS.
-    ;; 
-    (dolist (definition *early-class-definitions*)
-      (let* ((name (ecd-class-name definition))
-	     (meta (ecd-metaclass definition))
-	     (wrapper (ecase meta
-			(slot-class slot-class-wrapper)
-			(standard-class standard-class-wrapper)
-			(funcallable-standard-class funcallable-standard-class-wrapper)
-			(built-in-class built-in-class-wrapper)
-			(structure-class structure-class-wrapper)))
-             (class (or (find-class name nil)
-			(allocate-standard-instance wrapper))))
-	(when (or (eq meta 'standard-class) (eq meta 'funcallable-standard-class))
-	  (inform-type-system-about-std-class name))
-        (setf (find-class name) class)))
-    ;;
-    ;;
-    ;;
-    (dolist (definition *early-class-definitions*)
-      (let ((name (ecd-class-name definition))
-	    (meta (ecd-metaclass definition))
-	    (source (ecd-source definition))
-	    (direct-supers (ecd-superclass-names definition))
-	    (direct-slots  (ecd-canonical-slots definition))
-	    (other-initargs (ecd-other-initargs definition)))
-	(let ((direct-default-initargs
-	       (getf other-initargs :direct-default-initargs)))
-	  (multiple-value-bind (slots cpl default-initargs direct-subclasses)
-	      (early-collect-inheritance name)
-	    (let* ((class (find-class name))
-		   (wrapper (cond ((eq class slot-class)
-				   slot-class-wrapper)
-				  ((eq class standard-class) 
-				   standard-class-wrapper)
-				  ((eq class funcallable-standard-class) 
-				   funcallable-standard-class-wrapper)
-				  ((eq class standard-direct-slot-definition) 
-				   standard-direct-slot-definition-wrapper)
-				  ((eq class standard-effective-slot-definition) 
-				   standard-effective-slot-definition-wrapper)
-				  ((eq class built-in-class)  
-				   built-in-class-wrapper)
-				  ((eq class structure-class)
-				   structure-class-wrapper)
-				  ((eq class class-eq-specializer)
-				   class-eq-specializer-wrapper)
-				  ((eq class standard-generic-function)
-				   standard-generic-function-wrapper)
-				  (t (make-wrapper (length slots) class))))
-		   (proto nil))
-	      (when (eq name 't) (setq *the-wrapper-of-t* wrapper))
-	      (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
-			   *the-pcl-package*)
-		   class)
-	      (dolist (slot slots)
-		(unless (eq (getf slot :allocation :instance) :instance)
-		  (error "Slot allocation ~S not supported in bootstrap.")))
-	      
-	      (setf (wrapper-instance-slots-layout wrapper)
-		    (mapcar #'canonical-slot-name slots))
-	      (setf (wrapper-class-slots wrapper)
-		    ())
-	      
-	      (setq proto (if (eq meta 'funcallable-standard-class)
-			      (allocate-funcallable-instance wrapper)
-			      (allocate-standard-instance wrapper)))
-	    
-	      (setq direct-slots
-		    (bootstrap-make-slot-definitions 
-		     name class direct-slots
-		     standard-direct-slot-definition-wrapper nil))
-	      (setq slots
-		    (bootstrap-make-slot-definitions 
-		     name class slots
-		     standard-effective-slot-definition-wrapper t))
-	      
-	      (case meta
-		((standard-class funcallable-standard-class)
-		 (bootstrap-initialize-class 
-		  meta
-		  class name class-eq-specializer-wrapper source
-		  direct-supers direct-subclasses cpl wrapper proto
-		  direct-slots slots direct-default-initargs default-initargs))
-		(built-in-class		; *the-class-t*
-		 (bootstrap-initialize-class 
-		  meta
-		  class name class-eq-specializer-wrapper source
-		  direct-supers direct-subclasses cpl wrapper proto))
-		(slot-class		; *the-class-slot-object*
-		 (bootstrap-initialize-class 
-		  meta
-		  class name class-eq-specializer-wrapper source
-		  direct-supers direct-subclasses cpl wrapper proto))
-		(structure-class	; *the-class-structure-object*
-		 (bootstrap-initialize-class 
-		  meta
-		  class name class-eq-specializer-wrapper source
-		  direct-supers direct-subclasses cpl wrapper))))))))
-
-    (let* ((smc-class (find-class 'standard-method-combination))
-	   (smc-wrapper (bootstrap-get-slot 'standard-class smc-class 'wrapper))
-	   (smc (allocate-standard-instance smc-wrapper)))
-      (flet ((set-slot (name value)
-	       (bootstrap-set-slot 'standard-method-combination smc name value)))
-	(set-slot 'source (load-truename))
-	(set-slot 'type 'standard)
-	(set-slot 'documentation "The standard method combination.")
-	(set-slot 'options ()))
-      (setq *standard-method-combination* smc))))
-
-;;;
-;;; Initialize a class metaobject.
-;;;
-(defun bootstrap-initialize-class
-       (metaclass-name class name
-        class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
-	&optional proto direct-slots slots direct-default-initargs default-initargs)
-  (flet ((classes (names) (mapcar #'find-class names))
-	 (set-slot (slot-name value)
-	   (bootstrap-set-slot metaclass-name class slot-name value)))
-    (set-slot 'name name)
-    (set-slot 'source source)
-    (set-slot 'type (if (eq class (find-class 't))
-			t
-			`(class ,class)))
-    (set-slot 'class-eq-specializer 
-	      (let ((spec (allocate-standard-instance class-eq-wrapper)))
-		(bootstrap-set-slot 'class-eq-specializer spec 'type 
-				    `(class-eq ,class))
-		(bootstrap-set-slot 'class-eq-specializer spec 'object
-				    class)
-		spec))
-    (set-slot 'class-precedence-list (classes cpl))
-    (set-slot 'can-precede-list (classes (cdr cpl)))
-    (set-slot 'incompatible-superclass-list nil)
-    (set-slot 'direct-superclasses (classes direct-supers))
-    (set-slot 'direct-subclasses (classes direct-subclasses))
-    (set-slot 'direct-methods (cons nil nil))
-    (set-slot 'wrapper wrapper)
-    #+new-kcl-wrapper
-    (setf (si::s-data-name wrapper) name)
-    (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
-				  (make-class-predicate-name name)))
-    (set-slot 'plist
-	      `(,@(and direct-default-initargs
-		       `(direct-default-initargs ,direct-default-initargs))
-		,@(and default-initargs
-		       `(default-initargs ,default-initargs))))
-    (when (memq metaclass-name '(standard-class funcallable-standard-class
-				 structure-class slot-class))
-      (set-slot 'direct-slots direct-slots)
-      (set-slot 'slots slots)
-      (set-slot 'initialize-info nil))
-    (if (eq metaclass-name 'structure-class)
-	(let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
-	  (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
-					(make-class-predicate-name name)))
-	  (set-slot 'defstruct-form 
-		    `(defstruct (structure-object (:constructor ,constructor-sym))))
-	  (set-slot 'defstruct-constructor constructor-sym)
-	  (set-slot 'from-defclass-p t)    
-	  (set-slot 'plist nil)
-	  (set-slot 'prototype (funcall constructor-sym)))
-	(set-slot 'prototype (or proto (allocate-standard-instance wrapper))))
-    class))
-
-(defun bootstrap-make-slot-definitions (name class slots wrapper effective-p)
-  (let ((index -1))
-    (mapcar #'(lambda (slot)
-		(incf index)
-		(bootstrap-make-slot-definition
-		  name class slot wrapper effective-p index))
-	    slots)))
-
-(defun bootstrap-make-slot-definition (name class slot wrapper effective-p index)  
-  (let* ((slotd-class-name (if effective-p
-			       'standard-effective-slot-definition
-			       'standard-direct-slot-definition))
-	 (slotd (allocate-standard-instance wrapper))
-	 (slot-name (getf slot :name)))
-    (flet ((get-val (name) (getf slot name))
-	   (set-val (name val) (bootstrap-set-slot slotd-class-name slotd name val)))
-      (set-val 'name         slot-name)
-      (set-val 'initform     (get-val :initform))
-      (set-val 'initfunction (get-val :initfunction))      
-      (set-val 'initargs     (get-val :initargs))
-      (set-val 'readers      (get-val :readers))
-      (set-val 'writers      (get-val :writers))
-      (set-val 'allocation   :instance)
-      (set-val 'type         (or (get-val :type) t))
-      (set-val 'documentation (or (get-val :documentation) ""))
-      (set-val 'class        class)
-      (when effective-p
-	(set-val 'location index)
-	(let ((fsc-p nil))
-	  (set-val 'reader-function (make-optimized-std-reader-method-function 
-				     fsc-p slot-name index))
-	  (set-val 'writer-function (make-optimized-std-writer-method-function 
-				     fsc-p slot-name index))
-	  (set-val 'boundp-function (make-optimized-std-boundp-method-function 
-				     fsc-p slot-name index)))
-	(set-val 'accessor-flags 7)
-	(let ((table (or (gethash slot-name *name->class->slotd-table*)
-			 (setf (gethash slot-name *name->class->slotd-table*)
-			       (make-hash-table :test 'eq :size 5)))))
-	  (setf (gethash class table) slotd)))
-      (when (and (eq name 'standard-class)
-		 (eq slot-name 'slots) effective-p)
-	(setq *the-eslotd-standard-class-slots* slotd))
-      (when (and (eq name 'funcallable-standard-class)
-		 (eq slot-name 'slots) effective-p)
-	(setq *the-eslotd-funcallable-standard-class-slots* slotd))
-      slotd)))
-
-(defun bootstrap-accessor-definitions (early-p)
-  (let ((*early-p* early-p))
-    (dolist (definition *early-class-definitions*)
-      (let ((name (ecd-class-name definition))
-	    (meta (ecd-metaclass definition)))
-	(unless (eq meta 'built-in-class)
-	  (let ((direct-slots  (ecd-canonical-slots definition)))
-	    (dolist (slotd direct-slots)
-	      (let ((slot-name (getf slotd :name))
-		    (readers (getf slotd :readers))
-		    (writers (getf slotd :writers)))
-		(bootstrap-accessor-definitions1 name slot-name readers writers nil)
-		(bootstrap-accessor-definitions1 
-		 'slot-object
-		 slot-name
-		 (list (slot-reader-symbol slot-name))
-		 (list (slot-writer-symbol slot-name))
-		 (list (slot-boundp-symbol slot-name)))))))))))
-
-(defun bootstrap-accessor-definition (class-name accessor-name slot-name type)
-  (multiple-value-bind (accessor-class make-method-function arglist specls doc)
-      (ecase type
-	(reader (values 'standard-reader-method #'make-std-reader-method-function
-			(list class-name) (list class-name)
-			"automatically generated reader method"))
-	(writer (values 'standard-writer-method #'make-std-writer-method-function
-			(list 'new-value class-name) (list 't class-name)
-			"automatically generated writer method"))
-	(boundp (values 'standard-boundp-method #'make-std-boundp-method-function
-			(list class-name) (list class-name)
-			"automatically generated boundp method")))
-    (let ((gf (ensure-generic-function accessor-name)))
-      (if (find specls (early-gf-methods gf) 
-		:key #'early-method-specializers
-		:test #'equal)
-	  (unless (assoc accessor-name *generic-function-fixups*
-			 :test #'equal)
-	    (update-dfun gf))
-	  (add-method gf
-		      (make-a-method accessor-class
-				     ()
-				     arglist specls
-				     (funcall make-method-function
-					      class-name slot-name)
-				     doc
-				     slot-name))))))
-
-(defun bootstrap-accessor-definitions1 (class-name slot-name readers writers boundps)
-  (flet ((do-reader-definition (reader)
-	   (bootstrap-accessor-definition class-name reader slot-name 'reader))
-	 (do-writer-definition (writer)
-	   (bootstrap-accessor-definition class-name writer slot-name 'writer))
-	 (do-boundp-definition (boundp)
-	   (bootstrap-accessor-definition class-name boundp slot-name 'boundp)))
-    (dolist (reader readers) (do-reader-definition reader))
-    (dolist (writer writers) (do-writer-definition writer))
-    (dolist (boundp boundps) (do-boundp-definition boundp))))
-
-(defun bootstrap-class-predicates (early-p)
-  (let ((*early-p* early-p))
-    (dolist (definition *early-class-definitions*)
-      (let* ((name (ecd-class-name definition))
-	     (class (find-class name)))
-	(setf (find-class-predicate name)
-	      (make-class-predicate class (class-predicate-name class)))))))
-
-(defun bootstrap-built-in-classes ()
-  ;;
-  ;; First make sure that all the supers listed in *built-in-class-lattice*
-  ;; are themselves defined by *built-in-class-lattice*.  This is just to
-  ;; check for typos and other sorts of brainos.
-  ;; 
-  (dolist (e *built-in-classes*)
-    (dolist (super (cadr e))
-      (unless (or (eq super 't)
-		  (assq super *built-in-classes*))
-	(error "In *built-in-classes*: ~S has ~S as a super,~%~
-                but ~S is not itself a class in *built-in-classes*."
-	       (car e) super super))))
-
-  ;;
-  ;; In the first pass, we create a skeletal object to be bound to the
-  ;; class name.
-  ;;
-  (let* ((built-in-class (find-class 'built-in-class))
-	 (built-in-class-wrapper (class-wrapper built-in-class)))
-    (dolist (e *built-in-classes*)
-      (let ((class (allocate-standard-instance built-in-class-wrapper)))
-	(setf (find-class (car e)) class))))
-
-  ;;
-  ;; In the second pass, we initialize the class objects.
-  ;;
-  (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer))))
-    (dolist (e *built-in-classes*)
-      (destructuring-bind (name supers subs cpl prototype) e
-	(let* ((class (find-class name))
-	       (wrapper (make-wrapper 0 class)))
-	  (set (get-built-in-class-symbol name) class)
-	  (set (get-built-in-wrapper-symbol name) wrapper)
-
-	  (setf (wrapper-instance-slots-layout wrapper) ()
-		(wrapper-class-slots wrapper) ())
-
-	  (bootstrap-initialize-class 'built-in-class class
-				      name class-eq-wrapper nil
-				      supers subs
-				      (cons name cpl)
-				      wrapper prototype)))))
-  
-  (dolist (e *built-in-classes*)
-    (let* ((name (car e))
-	   (class (find-class name)))
-      (setf (find-class-predicate name)
-	    (make-class-predicate class (class-predicate-name class))))))
-
-
-;;;
-;;;
-;;;
-#-new-kcl-wrapper
-(progn
-(defvar *built-in-or-structure-wrapper-table*
-  (make-hash-table :test 'eq))
-
-(defvar wft-type1 nil)
-(defvar wft-wrapper1 nil)
-(defvar wft-type2 nil)
-(defvar wft-wrapper2 nil)
-
-(defun wrapper-for-structure (x)
-  (let ((type (structure-type x)))
-    (when (symbolp type)
-      (cond ((eq type 'std-instance) 
-	     (return-from wrapper-for-structure (std-instance-wrapper x)))
-	    ((eq type wft-type1) (return-from wrapper-for-structure wft-wrapper1))
-	    ((eq type wft-type2) (return-from wrapper-for-structure wft-wrapper2))
-	    (t (setq wft-type2 wft-type1  wft-wrapper2 wft-wrapper1))))
-    (let* ((cell (find-class-cell type))
-	   (class (or (find-class-cell-class cell)
-		      (let* (#+lucid 
-			     (*structure-type* type)
-			     #+lucid
-			     (*structure-length* (structure-length x type)))
-			(find-class-from-cell type cell))))
-	   (wrapper (if class (class-wrapper class) *the-wrapper-of-t*)))
-      (when (symbolp type)
-	(setq wft-type1 type  wft-wrapper1 wrapper))
-      wrapper)))
-
-(defun built-in-or-structure-wrapper1 (x)
-  (let ((biw (or (built-in-wrapper-of x) *the-wrapper-of-t*)))
-    (or (and (eq biw *the-wrapper-of-t*)
-	     (structurep x)
-	     (let* ((type (type-of x))
-		    #+lucid 
-		    (*structure-type* type)
-		    #+lucid
-		    (*structure-length* (structure-length x type))
-		    (class (find-class type nil)))
-	       (and class (class-wrapper class))))
-	biw)))
-)
-
-#|| ; moved to low.lisp
-(defmacro built-in-or-structure-wrapper (x)
-  (once-only (x)
-    (if (structure-functions-exist-p) ; otherwise structurep is too slow for this
-	`(if (structurep ,x)
-	     (wrapper-for-structure ,x)
-	     (if (symbolp ,x)
-		 (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)
-		 (built-in-wrapper-of ,x)))
-	`(or (and (symbolp ,x)
-		  (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*))
-	     (built-in-or-structure-wrapper1 ,x)))))
-||#
-
-(defmacro wrapper-of-macro (x)
-  `(cond ((std-instance-p ,x)
-	  (std-instance-wrapper ,x))
-         ((fsc-instance-p ,x)
-	  (fsc-instance-wrapper ,x))	      
-         (t
-	  (#+new-kcl-wrapper built-in-wrapper-of
-	   #-new-kcl-wrapper built-in-or-structure-wrapper
-	   ,x))))
-
-(defun class-of (x)
-  (wrapper-class* (wrapper-of-macro x)))
-
-(defun wrapper-of (x)
-  (wrapper-of-macro x))
-
-(defun structure-wrapper (x)
-  (class-wrapper (find-class (structure-type x))))
-
-(defvar find-structure-class nil)
-
-(defun eval-form (form)
-  #'(lambda () (eval form)))
-
-(defun slot-initargs-from-structure-slotd (slotd)
-  `(:name ,(structure-slotd-name slotd)
-    :defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd)
-    :internal-reader-function ,(structure-slotd-reader-function slotd)
-    :internal-writer-function ,(structure-slotd-writer-function slotd)
-    :type ,(or (structure-slotd-type slotd) t)
-    :initform ,(structure-slotd-init-form slotd)
-    :initfunction ,(eval-form (structure-slotd-init-form slotd))))
-
-(defun find-structure-class (symbol)
-  (if (structure-type-p symbol)
-      (unless (eq find-structure-class symbol)
-	(let ((find-structure-class symbol))
-	  (ensure-class symbol
-			:metaclass 'structure-class
-			:name symbol
-			:direct-superclasses
-			(when (structure-type-included-type-name symbol)
-			  (list (structure-type-included-type-name symbol)))
-			:direct-slots
-			(mapcar #'slot-initargs-from-structure-slotd
-				(structure-type-slot-description-list symbol)))))
-      (error "~S is not a legal structure class name." symbol)))
-
-(eval-when (compile eval)
-
-(defun make-built-in-class-subs ()
-  (mapcar #'(lambda (e)
-	      (let ((class (car e))
-		    (class-subs ()))
-		(dolist (s *built-in-classes*)
-		  (when (memq class (cadr s)) (pushnew (car s) class-subs)))
-		(cons class class-subs)))
-	  (cons '(t) *built-in-classes*)))
-
-(defun make-built-in-class-tree ()
-  (let ((subs (make-built-in-class-subs)))
-    (labels ((descend (class)
-	       (cons class (mapcar #'descend (cdr (assq class subs))))))
-      (descend 't))))
-
-(defun make-built-in-wrapper-of-body ()
-  (make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
-				   'x
-				   #'get-built-in-wrapper-symbol))
-
-(defun make-built-in-wrapper-of-body-1 (tree var get-symbol)
-  (let ((*specials* ()))
-    (declare (special *specials*))
-    (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol)))
-      `(locally (declare (special .,*specials*)) ,inner))))
-
-(defun make-built-in-wrapper-of-body-2 (tree var get-symbol)
-  (declare (special *specials*))
-  (let ((symbol (funcall get-symbol (car tree))))
-    (push symbol *specials*)
-    (let ((sub-tests
-	    (mapcar #'(lambda (x)
-			(make-built-in-wrapper-of-body-2 x var get-symbol))
-		    (cdr tree))))
-      `(and (typep ,var ',(car tree))
-	    ,(if sub-tests
-		 `(or ,.sub-tests ,symbol)
-		 symbol)))))
-)
-
-(defun built-in-wrapper-of (x)
-  #.(when (fboundp 'make-built-in-wrapper-of-body) ; so we can at least read this file
-      (make-built-in-wrapper-of-body)))
-
-
-
-(defun method-function-returning-nil (args next-methods)
-  (declare (ignore args next-methods))
-  nil)
-
-(defun method-function-returning-t (args next-methods)
-  (declare (ignore args next-methods))
-  t)
-
-(defun make-class-predicate (class name)
-  (let* ((gf (ensure-generic-function name))
-	 (mlist (if (eq *boot-state* 'complete)
-		    (generic-function-methods gf)
-		    (early-gf-methods gf))))
-    (unless mlist
-      (unless (eq class *the-class-t*)
-	(let* ((default-method-function #'method-function-returning-nil)
-	       (default-method-initargs (list :function
-					      default-method-function))
-	       (default-method (make-a-method 'standard-method
-					      ()
-					      (list 'object)
-					      (list *the-class-t*)
-					      default-method-initargs
-					      "class predicate default method")))
-	  (setf (method-function-get default-method-function :constant-value) nil)
-	  (add-method gf default-method)))
-      (let* ((class-method-function #'method-function-returning-t)
-	     (class-method-initargs (list :function
-					  class-method-function))
-	     (class-method (make-a-method 'standard-method
-					  ()
-					  (list 'object)
-					  (list class)
-					  class-method-initargs
-					  "class predicate class method")))
-	(setf (method-function-get class-method-function :constant-value) t)
-	(add-method gf class-method)))
-    gf))
-
-(eval-when (load eval)
-  (clrhash *find-class*)
-  (bootstrap-meta-braid)
-  (bootstrap-accessor-definitions t)
-  (bootstrap-class-predicates t)
-  (bootstrap-accessor-definitions nil)
-  (bootstrap-class-predicates nil)
-  (bootstrap-built-in-classes)
-  (setq *boot-state* 'braid)
-  )
-
-(deftype slot-object ()
-  '(or standard-object structure-object))
-
-(defmethod no-applicable-method (generic-function &rest args)
-  (cerror "Retry call to ~S"
-	  "No matching method for the generic-function ~S,~@
-          when called with arguments ~S."
-	  generic-function args)
-  (apply generic-function args))
diff --git a/pcl/cache.lisp b/pcl/cache.lisp
deleted file mode 100644
index 268d8bbbd09457e9ccc638e7409510c52e230bed..0000000000000000000000000000000000000000
--- a/pcl/cache.lisp
+++ /dev/null
@@ -1,1484 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; The basics of the PCL wrapper cache mechanism.
-;;;
-
-(in-package :pcl)
-;;;
-;;; The caching algorithm implemented:
-;;;
-;;; << put a paper here >>
-;;;
-;;; For now, understand that as far as most of this code goes, a cache has
-;;; two important properties.  The first is the number of wrappers used as
-;;; keys in each cache line.  Throughout this code, this value is always
-;;; called NKEYS.  The second is whether or not the cache lines of a cache
-;;; store a value.  Throughout this code, this always called VALUEP.
-;;;
-;;; Depending on these values, there are three kinds of caches.
-;;;
-;;; NKEYS = 1, VALUEP = NIL
-;;;
-;;; In this kind of cache, each line is 1 word long.  No cache locking is
-;;; needed since all read's in the cache are a single value.  Nevertheless
-;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will
-;;; not get a first probe hit.
-;;;
-;;; To keep the code simpler, a cache lock count does appear in location 0
-;;; of these caches, that count is incremented whenever data is written to
-;;; the cache.  But, the actual lookup code (see make-dlap) doesn't need to
-;;; do locking when reading the cache.
-;;; 
-;;;
-;;; NKEYS = 1, VALUEP = T
-;;;
-;;; In this kind of cache, each line is 2 words long.  Cache locking must
-;;; be done to ensure the synchronization of cache reads.  Line 0 of the
-;;; cache (location 0) is reserved for the cache lock count.  Location 1
-;;; of the cache is unused (in effect wasted).
-;;; 
-;;; NKEYS > 1
-;;;
-;;; In this kind of cache, the 0 word of the cache holds the lock count.
-;;; The 1 word of the cache is line 0.  Line 0 of these caches is not
-;;; reserved.
-;;;
-;;; This is done because in this sort of cache, the overhead of doing the
-;;; cache probe is high enough that the 1+ required to offset the location
-;;; is not a significant cost.  In addition, because of the larger line
-;;; sizes, the space that would be wasted by reserving line 0 to hold the
-;;; lock count is more significant.
-;;;
-
-;;;
-;;; Caches
-;;;
-;;; A cache is essentially just a vector.  The use of the individual `words'
-;;; in the vector depends on particular properties of the cache as described
-;;; above.
-;;;
-;;; This defines an abstraction for caches in terms of their most obvious
-;;; implementation as simple vectors.  But, please notice that part of the
-;;; implementation of this abstraction, is the function lap-out-cache-ref.
-;;; This means that most port-specific modifications to the implementation
-;;; of caches will require corresponding port-specific modifications to the
-;;; lap code assembler.
-;;;
-(defmacro cache-vector-ref (cache-vector location)
-  `(svref (the simple-vector ,cache-vector)
-          (#-cmu the #+cmu ext:truly-the fixnum ,location)))
-
-(defmacro cache-vector-size (cache-vector)
-  `(array-dimension (the simple-vector ,cache-vector) 0))
-
-(defun allocate-cache-vector (size)
-  (make-array size :adjustable nil))
-
-(defmacro cache-vector-lock-count (cache-vector)
-  `(cache-vector-ref ,cache-vector 0))
-
-(defun flush-cache-vector-internal (cache-vector)
-  (without-interrupts  
-    (fill (the simple-vector cache-vector) nil)
-    (setf (cache-vector-lock-count cache-vector) 0))
-  cache-vector)
-
-(defmacro modify-cache (cache-vector &body body)
-  `(without-interrupts
-     (multiple-value-prog1
-       (progn ,@body)
-       (let ((old-count (cache-vector-lock-count ,cache-vector)))
-	 (declare (fixnum old-count))
-	 (setf (cache-vector-lock-count ,cache-vector)
-	       (if (= old-count most-positive-fixnum)
-		   1 (the fixnum (1+ old-count))))))))
-
-(deftype field-type ()
-  '(integer 0    ;#.(position 'number wrapper-layout)
-            7))  ;#.(position 'number wrapper-layout :from-end t)
-
-(eval-when (compile load eval)
-(defun power-of-two-ceiling (x)
-  (declare (fixnum x))
-  ;;(expt 2 (ceiling (log x 2)))
-  (the fixnum (ash 1 (integer-length (1- x)))))
-
-(defconstant *nkeys-limit* 256)
-)
-
-(defstruct (cache
-	     (:print-function print-cache)
-	     (:constructor make-cache ())
-	     (:copier copy-cache-internal))
-  (owner nil)
-  (nkeys 1 :type (integer 1 #.*nkeys-limit*))
-  (valuep nil :type (member nil t))
-  (nlines 0 :type fixnum)
-  (field 0 :type field-type)
-  (limit-fn #'default-limit-fn :type function)
-  (mask 0 :type fixnum)
-  (size 0 :type fixnum)
-  (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ *nkeys-limit*))))
-  (max-location 0 :type fixnum)
-  (vector #() :type simple-vector)
-  (overflow nil :type list))
-
-(defun print-cache (cache stream depth)
-  (declare (ignore depth))
-  (printing-random-thing (cache stream)
-    (format stream "cache ~D ~S ~D" 
-	    (cache-nkeys cache) (cache-valuep cache) (cache-nlines cache))))
-
-#+akcl
-(si::freeze-defstruct 'cache)
-
-(defmacro cache-lock-count (cache)
-  `(cache-vector-lock-count (cache-vector ,cache)))
-
-
-;;;
-;;; Some facilities for allocation and freeing caches as they are needed.
-;;; This is done on the assumption that a better port of PCL will arrange
-;;; to cons these all the same static area.  Given that, the fact that
-;;; PCL tries to reuse them should be a win.
-;;; 
-(defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql))
-
-;;;
-;;; Return a cache that has had flush-cache-vector-internal called on it.  This
-;;; returns a cache of exactly the size requested, it won't ever return a
-;;; larger cache.
-;;; 
-(defun get-cache-vector (size)
-  (let ((entry (gethash size *free-cache-vectors*)))
-    (without-interrupts
-      (cond ((null entry)
-	     (setf (gethash size *free-cache-vectors*) (cons 0 nil))
-	     (get-cache-vector size))
-	    ((null (cdr entry))
-	     (incf (car entry))
-	     (flush-cache-vector-internal (allocate-cache-vector size)))
-	    (t
-	     (let ((cache (cdr entry)))
-	       (setf (cdr entry) (cache-vector-ref cache 0))
-	       (flush-cache-vector-internal cache)))))))
-
-(defun free-cache-vector (cache-vector)
-  (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
-    (without-interrupts
-      (if (null entry)
-	  (error "Attempt to free a cache-vector not allocated by GET-CACHE-VECTOR.")
-	  (let ((thread (cdr entry)))
-	    (loop (unless thread (return))
-		  (when (eq thread cache-vector) (error "Freeing a cache twice."))
-		  (setq thread (cache-vector-ref thread 0)))	  
-	    (flush-cache-vector-internal cache-vector)		;Help the GC
-	    (setf (cache-vector-ref cache-vector 0) (cdr entry))
-	    (setf (cdr entry) cache-vector)
-	    nil)))))
-
-;;;
-;;; This is just for debugging and analysis.  It shows the state of the free
-;;; cache resource.
-;;; 
-(defun show-free-cache-vectors ()
-  (let ((elements ()))
-    (maphash #'(lambda (s e) (push (list s e) elements)) *free-cache-vectors*)
-    (setq elements (sort elements #'< :key #'car))
-    (dolist (e elements)
-      (let* ((size (car e))
-	     (entry (cadr e))
-	     (allocated (car entry))
-	     (head (cdr entry))
-	     (free 0))
-	(loop (when (null head) (return t))
-	      (setq head (cache-vector-ref head 0))
-	      (incf free))
-	(format t
-		"~&There  ~4D are caches of size ~4D. (~D free  ~3D%)"
-		allocated
-		size
-		free
-		(floor (* 100 (/ free (float allocated)))))))))
-
-
-;;;
-;;; Wrapper cache numbers
-;;; 
-
-;;;
-;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero
-;;; bits wrapper cache numbers will have.
-;;;
-;;; The value of this constant is the number of wrapper cache numbers which
-;;; can be added and still be certain the result will be a fixnum.  This is
-;;; used by all the code that computes primary cache locations from multiple
-;;; wrappers.
-;;;
-;;; The value of this constant is used to derive the next two which are the
-;;; forms of this constant which it is more convenient for the runtime code
-;;; to use.
-;;; 
-(eval-when (compile load eval)
-
-(defconstant wrapper-cache-number-adds-ok 4)
-
-(defconstant wrapper-cache-number-length
-	     (- (integer-length most-positive-fixnum)
-		wrapper-cache-number-adds-ok))
-
-(defconstant wrapper-cache-number-mask
-	     (1- (expt 2 wrapper-cache-number-length)))
-
-
-(defvar *get-wrapper-cache-number* (make-random-state))
-
-(defun get-wrapper-cache-number ()
-  (let ((n 0))
-    (declare (fixnum n))
-    (loop
-      (setq n
-	    (logand wrapper-cache-number-mask
-		    (random most-positive-fixnum *get-wrapper-cache-number*)))
-      (unless (zerop n) (return n)))))
-
-
-(unless (> wrapper-cache-number-length 8)
-  (error "In this implementation of Common Lisp, fixnums are so small that~@
-          wrapper cache numbers end up being only ~D bits long.  This does~@
-          not actually keep PCL from running, but it may degrade cache~@
-          performance.~@
-          You may want to consider changing the value of the constant~@
-          WRAPPER-CACHE-NUMBER-ADDS-OK.")))
-
-
-;;;
-;;; wrappers themselves
-;;;
-;;; This caching algorithm requires that wrappers have more than one wrapper
-;;; cache number.  You should think of these multiple numbers as being in
-;;; columns.  That is, for a given cache, the same column of wrapper cache
-;;; numbers will be used.
-;;;
-;;; If at some point the cache distribution of a cache gets bad, the cache
-;;; can be rehashed by switching to a different column.
-;;;
-;;; The columns are referred to by field number which is that number which,
-;;; when used as a second argument to wrapper-ref, will return that column
-;;; of wrapper cache number.
-;;;
-;;; This code is written to allow flexibility as to how many wrapper cache
-;;; numbers will be in each wrapper, and where they will be located.  It is
-;;; also set up to allow port specific modifications to `pack' the wrapper
-;;; cache numbers on machines where the addressing modes make that a good
-;;; idea.
-;;; 
-#-structure-wrapper
-(progn
-(eval-when (compile load eval)
-(defconstant wrapper-layout
-	     '(number
-	       number
-	       number
-	       number
-	       number
-	       number
-	       number
-	       number
-	       state
-	       instance-slots-layout
-	       class-slots
-	       class
-	       no-of-instance-slots))
-)
-
-(eval-when (compile load eval)
-
-(defun wrapper-field (type)
-  (posq type wrapper-layout))
-
-(defun next-wrapper-field (field-number)
-  (position (nth field-number wrapper-layout)
-	    wrapper-layout
-	    :start (1+ field-number)))
-
-(defmacro first-wrapper-cache-number-index ()
-  `(wrapper-field 'number))
-
-(defmacro next-wrapper-cache-number-index (field-number)
-  `(next-wrapper-field ,field-number))
-
-);eval-when
-
-(defmacro wrapper-cache-number-vector (wrapper)
-  wrapper)
-
-(defmacro cache-number-vector-ref (cnv n)
-  `(svref ,cnv ,n))
-
-
-(defmacro wrapper-ref (wrapper n)
-  `(svref ,wrapper ,n))
-
-(defmacro wrapper-state (wrapper)
-  `(wrapper-ref ,wrapper ,(wrapper-field 'state)))
-
-(defmacro wrapper-instance-slots-layout (wrapper)
-  `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout)))
-
-(defmacro wrapper-class-slots (wrapper)
-  `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots)))
-
-(defmacro wrapper-class (wrapper)
-  `(wrapper-ref ,wrapper ,(wrapper-field 'class)))
-
-(defmacro wrapper-no-of-instance-slots (wrapper)
-  `(wrapper-ref ,wrapper ,(wrapper-field 'no-of-instance-slots)))
-
-(defmacro make-wrapper-internal ()
-  `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil)))
-     ,@(gathering1 (collecting)
-	 (iterate ((i (interval :from 0))
-		   (desc (list-elements wrapper-layout)))
-	   (ecase desc
-	     (number
-	      (gather1 `(setf (wrapper-ref wrapper ,i)
-			      (get-wrapper-cache-number))))
-	     ((state instance-slots-layout class-slots class no-of-instance-slots)))))
-     (setf (wrapper-state wrapper) 't)     
-     wrapper))
-
-(defun make-wrapper (no-of-instance-slots &optional class)
-  (let ((wrapper (make-wrapper-internal)))
-    (setf (wrapper-no-of-instance-slots wrapper) no-of-instance-slots)
-    (setf (wrapper-class wrapper) class)
-    wrapper))
-
-)
-
-; In CMUCL we want to do type checking as early as possible; structures help this.
-#+structure-wrapper
-(eval-when (compile load eval)
-
-(defconstant wrapper-cache-number-vector-length 8)
-
-(deftype cache-number-vector ()
-  `(simple-array fixnum (8)))
-
-(defconstant wrapper-layout (make-list wrapper-cache-number-vector-length
-				       :initial-element 'number))
-
-)
-
-#+structure-wrapper
-(progn
-
-#-new-kcl-wrapper
-(defun make-wrapper-cache-number-vector ()
-  (let ((cnv (make-array #.wrapper-cache-number-vector-length
-			 :element-type 'fixnum)))
-    (dotimes (i #.wrapper-cache-number-vector-length)
-      (setf (aref cnv i) (get-wrapper-cache-number)))
-    cnv))
-
-(defstruct (wrapper
-	     #+new-kcl-wrapper (:include si::basic-wrapper)
-	     (:print-function print-wrapper)
-	     #-new-kcl-wrapper
-	     (:constructor make-wrapper (no-of-instance-slots &optional class))
-	     #+new-kcl-wrapper
-	     (:constructor make-wrapper-internal))
-  #-new-kcl-wrapper
-  (cache-number-vector (make-wrapper-cache-number-vector)
-		       :type cache-number-vector)
-  #-new-kcl-wrapper
-  (state t :type (or (member t) cons)) 
-  ;;  either t or a list (state-sym new-wrapper)
-  ;;           where state-sym is either :flush or :obsolete
-  (instance-slots-layout nil :type list)
-  (class-slots nil :type list)
-  #-new-kcl-wrapper
-  (no-of-instance-slots 0 :type fixnum)
-  #-new-kcl-wrapper
-  (class *the-class-t* :type class))
-
-(unless (boundp '*the-class-t*) (setq *the-class-t* nil))
-
-#+new-kcl-wrapper
-(defmacro wrapper-no-of-instance-slots (wrapper)
-  `(si::s-data-length ,wrapper))
-
-#+new-kcl-wrapper
-(defun make-wrapper (size &optional class)
-  (multiple-value-bind (raw slot-positions)
-      (if (< size 50)
-	  (values si::*all-t-s-type* si::*standard-slot-positions*)
-	  (values (make-array size :element-type 'unsigned-char)
-		  (let ((array (make-array size :element-type 'unsigned-short)))
-		    (dotimes (i size)
-		      (declare (fixnum i))
-		      (setf (aref array i) (* #.(si::size-of t) i))))))
-    (make-wrapper-internal :length size
-			   :raw raw
-			   :print-function 'print-std-instance
-			   :slot-position slot-positions
-			   :size (* size #.(si::size-of t))
-			   :class class)))
-
-(defun print-wrapper (wrapper stream depth)
-  (declare (ignore depth))
-  (printing-random-thing (wrapper stream)
-    (format stream "Wrapper ~S" (wrapper-class wrapper))))
-
-(defmacro first-wrapper-cache-number-index ()
-  0)
-
-(defmacro next-wrapper-cache-number-index (field-number)
-  `(and (< ,field-number #.(1- wrapper-cache-number-vector-length))
-        (1+ ,field-number)))
-
-(defmacro cache-number-vector-ref (cnv n)
-  `(#-kcl svref #+kcl aref ,cnv ,n))
-
-)
-
-(defmacro wrapper-cache-number-vector-ref (wrapper n)
-  `(the fixnum
-        (#-structure-wrapper svref #+structure-wrapper aref
-          (wrapper-cache-number-vector ,wrapper) ,n)))
-
-(defmacro class-no-of-instance-slots (class)
-  `(wrapper-no-of-instance-slots (class-wrapper ,class)))
-
-(defmacro wrapper-class* (wrapper)
-  #-new-kcl-wrapper
-  `(wrapper-class ,wrapper)
-  #+new-kcl-wrapper
-  `(let ((wrapper ,wrapper))
-     (or (wrapper-class wrapper)
-         (find-structure-class (si::s-data-name wrapper)))))
-
-;;;
-;;; The wrapper cache machinery provides general mechanism for trapping on
-;;; the next access to any instance of a given class.  This mechanism is
-;;; used to implement the updating of instances when the class is redefined
-;;; (make-instances-obsolete).  The same mechanism is also used to update
-;;; generic function caches when there is a change to the supers of a class.
-;;;
-;;; Basically, a given wrapper can be valid or invalid.  If it is invalid,
-;;; it means that any attempt to do a wrapper cache lookup using the wrapper
-;;; should trap.  Also, methods on slot-value-using-class check the wrapper
-;;; validity as well.  This is done by calling check-wrapper-validity.
-;;; 
-
-(defmacro invalid-wrapper-p (wrapper)
-  `(neq (wrapper-state ,wrapper) 't))
-
-(defvar *previous-nwrappers* (make-hash-table))
-
-(defun invalidate-wrapper (owrapper state nwrapper)
-  (ecase state
-    ((:flush :obsolete)
-     (let ((new-previous ()))
-       ;;
-       ;; First off, a previous call to invalidate-wrapper may have recorded
-       ;; owrapper as an nwrapper to update to.  Since owrapper is about to
-       ;; be invalid, it no longer makes sense to update to it.
-       ;;
-       ;; We go back and change the previously invalidated wrappers so that
-       ;; they will now update directly to nwrapper.  This corresponds to a
-       ;; kind of transitivity of wrapper updates.
-       ;; 
-       (dolist (previous (gethash owrapper *previous-nwrappers*))
-	 (when (eq state ':obsolete)
-	   (setf (car previous) ':obsolete))
-	 (setf (cadr previous) nwrapper)
-	 (push previous new-previous))
-       
-       (let ((ocnv (wrapper-cache-number-vector owrapper)))
-	 (iterate ((type (list-elements wrapper-layout))
-		   (i (interval :from 0)))
-           (when (eq type 'number) (setf (cache-number-vector-ref ocnv i) 0))))
-       (push (setf (wrapper-state owrapper) (list state nwrapper))
-	     new-previous)
-       
-       (setf (gethash owrapper *previous-nwrappers*) ()
-	     (gethash nwrapper *previous-nwrappers*) new-previous)))))
-
-(defun check-wrapper-validity (instance)
-  (let* ((owrapper (wrapper-of instance))
-	 (state (wrapper-state owrapper)))
-    (if (eq state  't)
-	owrapper
-	(let ((nwrapper
-		(ecase (car state)
-		  (:flush
-		    (flush-cache-trap owrapper (cadr state) instance))
-		  (:obsolete
-		    (obsolete-instance-trap owrapper (cadr state) instance)))))
-	  ;;
-	  ;; This little bit of error checking is superfluous.  It only
-	  ;; checks to see whether the person who implemented the trap
-	  ;; handling screwed up.  Since that person is hacking internal
-	  ;; PCL code, and is not a user, this should be needless.  Also,
-	  ;; since this directly slows down instance update and generic
-	  ;; function cache refilling, feel free to take it out sometime
-	  ;; soon.
-	  ;; 
-	  (cond ((neq nwrapper (wrapper-of instance))
-		 (error "Wrapper returned from trap not wrapper of instance."))
-		((invalid-wrapper-p nwrapper)
-		 (error "Wrapper returned from trap invalid.")))
-	  nwrapper))))
-
-(defmacro check-wrapper-validity1 (object)
-  (let ((owrapper (gensym)))
-    `(let ((,owrapper (cond ((std-instance-p ,object)
-			     (std-instance-wrapper ,object))
-			    ((fsc-instance-p ,object)
-			     (fsc-instance-wrapper ,object))
-			    #+new-kcl-wrapper
-			    (t (built-in-wrapper-of ,object))
-			    #-new-kcl-wrapper
-			    (t (wrapper-of ,object)))))
-       (if (eq 't (wrapper-state ,owrapper))
-	   ,owrapper
-	   (check-wrapper-validity ,object)))))
-
-
-(defvar *free-caches* nil)
-
-(defun get-cache (nkeys valuep limit-fn nlines)
-  (let ((cache (or (without-interrupts (pop *free-caches*)) (make-cache))))
-    (declare (type cache cache))
-    (multiple-value-bind (cache-mask actual-size line-size nlines)
-	(compute-cache-parameters nkeys valuep nlines)
-      (setf (cache-nkeys cache) nkeys
-	    (cache-valuep cache) valuep
-	    (cache-nlines cache) nlines
-	    (cache-field cache) (first-wrapper-cache-number-index)
-	    (cache-limit-fn cache) limit-fn
-	    (cache-mask cache) cache-mask
-	    (cache-size cache) actual-size
-	    (cache-line-size cache) line-size
-	    (cache-max-location cache) (let ((line (1- nlines)))
-					 (if (= nkeys 1)
-					     (* line line-size)
-					     (1+ (* line line-size))))
-	    (cache-vector cache) (get-cache-vector actual-size)
-	    (cache-overflow cache) nil)
-      cache)))
-
-(defun get-cache-from-cache (old-cache new-nlines 
-			     &optional (new-field (first-wrapper-cache-number-index)))
-  (let ((nkeys (cache-nkeys old-cache))
-	(valuep (cache-valuep old-cache))
-	(cache (or (without-interrupts (pop *free-caches*)) (make-cache))))
-    (declare (type cache cache))
-    (multiple-value-bind (cache-mask actual-size line-size nlines)
-	(if (= new-nlines (cache-nlines old-cache))
-	    (values (cache-mask old-cache) (cache-size old-cache) 
-		    (cache-line-size old-cache) (cache-nlines old-cache))
-	    (compute-cache-parameters nkeys valuep new-nlines))
-      (setf (cache-owner cache) (cache-owner old-cache)
-	    (cache-nkeys cache) nkeys
-	    (cache-valuep cache) valuep
-	    (cache-nlines cache) nlines
-	    (cache-field cache) new-field
-	    (cache-limit-fn cache) (cache-limit-fn old-cache)
-	    (cache-mask cache) cache-mask
-	    (cache-size cache) actual-size
-	    (cache-line-size cache) line-size
-	    (cache-max-location cache) (let ((line (1- nlines)))
-					 (if (= nkeys 1)
-					     (* line line-size)
-					     (1+ (* line line-size))))
-	    (cache-vector cache) (get-cache-vector actual-size)
-	    (cache-overflow cache) nil)
-      cache)))
-
-(defun copy-cache (old-cache)
-  (let* ((new-cache (copy-cache-internal old-cache))
-	 (size (cache-size old-cache))
-	 (old-vector (cache-vector old-cache))
-	 (new-vector (get-cache-vector size)))
-    (declare (simple-vector old-vector new-vector))
-    (dotimes (i size)
-      (setf (svref new-vector i) (svref old-vector i)))
-    (setf (cache-vector new-cache) new-vector)
-    new-cache))
-
-(defun free-cache (cache)
-  (free-cache-vector (cache-vector cache))
-  (setf (cache-vector cache) #())
-  (setf (cache-owner cache) nil)
-  (push cache *free-caches*)
-  nil)
-
-(defun compute-line-size (x)
-  (power-of-two-ceiling x))
-
-(defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector)
-  ;;(declare (values cache-mask actual-size line-size nlines))
-  (declare (fixnum nkeys))
-  (if (= nkeys 1)
-      (let* ((line-size (if valuep 2 1))
-	     (cache-size (if (typep nlines-or-cache-vector 'fixnum)
-			     (the fixnum 
-				  (* line-size
-				     (the fixnum 
-					  (power-of-two-ceiling 
-					    nlines-or-cache-vector))))
-			     (cache-vector-size nlines-or-cache-vector))))
-	(declare (fixnum line-size cache-size))
-	(values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
-		cache-size
-		line-size
-		(the fixnum (floor cache-size line-size))))
-      (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys)))
-	     (cache-size (if (typep nlines-or-cache-vector 'fixnum)
-			     (the fixnum
-				  (* line-size
-				     (the fixnum
-					  (power-of-two-ceiling 
-					    nlines-or-cache-vector))))
-			     (1- (cache-vector-size nlines-or-cache-vector)))))
-	(declare (fixnum line-size cache-size))
-	(values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
-		(the fixnum (1+ cache-size))
-		line-size
-		(the fixnum (floor cache-size line-size))))))
-
-
-
-;;;
-;;; The various implementations of computing a primary cache location from
-;;; wrappers.  Because some implementations of this must run fast there are
-;;; several implementations of the same algorithm.
-;;;
-;;; The algorithm is:
-;;;
-;;;  SUM       over the wrapper cache numbers,
-;;;  ENSURING  that the result is a fixnum
-;;;  MASK      the result against the mask argument.
-;;;
-;;;
-
-;;;
-;;; COMPUTE-PRIMARY-CACHE-LOCATION
-;;; 
-;;; The basic functional version.  This is used by the cache miss code to
-;;; compute the primary location of an entry.  
-;;;
-(defun compute-primary-cache-location (field mask wrappers)
-  (declare (type field-type field) (fixnum mask))
-  (if (not (listp wrappers))
-      (logand mask (the fixnum (wrapper-cache-number-vector-ref wrappers field)))
-      (let ((location 0) (i 0))
-	(declare (fixnum location i))
-	(dolist (wrapper wrappers)
-	  ;;
-	  ;; First add the cache number of this wrapper to location.
-	  ;; 
-	  (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper field)))
-	    (declare (fixnum wrapper-cache-number))
-	    (if (zerop wrapper-cache-number)
-		(return-from compute-primary-cache-location 0)
-		(setq location (the fixnum (+ location wrapper-cache-number)))))
-	  ;;
-	  ;; Then, if we are working with lots of wrappers, deal with
-	  ;; the wrapper-cache-number-mask stuff.
-	  ;; 
-	  (when (and (not (zerop i))
-		     (zerop (mod i wrapper-cache-number-adds-ok)))
-	    (setq location
-		  (logand location wrapper-cache-number-mask)))
-	  (incf i))
-	(the fixnum (1+ (logand mask location))))))
-
-;;;
-;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION
-;;;
-;;; This version is called on a cache line.  It fetches the wrappers from
-;;; the cache line and determines the primary location.  Various parts of
-;;; the cache filling code call this to determine whether it is appropriate
-;;; to displace a given cache entry.
-;;; 
-;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol
-;;; invalid to suggest to its caller that it would be provident to blow away
-;;; the cache line in question.
-;;;
-(defun compute-primary-cache-location-from-location (to-cache from-location 
-						     &optional (from-cache to-cache))
-  (declare (type cache to-cache from-cache) (fixnum from-location))
-  (let ((result 0)
-	(cache-vector (cache-vector from-cache))
-	(field (cache-field to-cache))
-	(mask (cache-mask to-cache))
-	(nkeys (cache-nkeys to-cache)))
-    (declare (type field-type field) (fixnum result mask nkeys)
-	     (simple-vector cache-vector))
-    (dotimes (i nkeys)
-      (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location)))
-	     (wcn (wrapper-cache-number-vector-ref wrapper field)))
-	(declare (fixnum wcn))
-	(setq result (+ result wcn)))
-      (when (and (not (zerop i))
-		 (zerop (mod i wrapper-cache-number-adds-ok)))
-	(setq result (logand result wrapper-cache-number-mask))))    
-    (if (= nkeys 1)
-	(logand mask result)
-	(the fixnum (1+ (logand mask result))))))
-
-
-;;;
-;;;  NIL              means nothing so far, no actual arg info has NILs
-;;;                   in the metatype
-;;;  CLASS            seen all sorts of metaclasses
-;;;                   (specifically, more than one of the next 4 values)
-;;;  T                means everything so far is the class T
-;;;  STANDARD-CLASS   seen only standard classes
-;;;  BUILT-IN-CLASS   seen only built in classes
-;;;  STRUCTURE-CLASS  seen only structure classes
-;;;  
-(defun raise-metatype (metatype new-specializer)
-  (let ((slot      (find-class 'slot-class))
-	(standard  (find-class 'standard-class))
-	(fsc       (find-class 'funcallable-standard-class))
-	(structure (find-class 'structure-class))
-	(built-in  (find-class 'built-in-class)))
-    (flet ((specializer->metatype (x)
-	     (let ((meta-specializer 
-		     (if (eq *boot-state* 'complete)
-			 (class-of (specializer-class x))
-			 (class-of x))))
-	       (cond ((eq x *the-class-t*) t)
-		     ((*subtypep meta-specializer standard)  'standard-instance)
-		     ((*subtypep meta-specializer fsc)       'standard-instance)
-		     ((*subtypep meta-specializer structure) 'structure-instance)
-		     ((*subtypep meta-specializer built-in)  'built-in-instance)
-		     ((*subtypep meta-specializer slot)      'slot-instance)
-		     (t (error "PCL can not handle the specializer ~S (meta-specializer ~S)."
-			       new-specializer meta-specializer))))))
-      ;;
-      ;; We implement the following table.  The notation is
-      ;; that X and Y are distinct meta specializer names.
-      ;; 
-      ;;   NIL    <anything>    ===>  <anything>
-      ;;    X      X            ===>      X
-      ;;    X      Y            ===>    CLASS
-      ;;    
-      (let ((new-metatype (specializer->metatype new-specializer)))
-	(cond ((eq new-metatype 'slot-instance) 'class)
-	      ((null metatype) new-metatype)
-	      ((eq metatype new-metatype) new-metatype)
-	      (t 'class))))))
-
-(defmacro with-dfun-wrappers ((args metatypes)
-			      (dfun-wrappers invalid-wrapper-p 
-					     &optional wrappers classes types)
-			      invalid-arguments-form
-			      &body body)
-  `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil)
-	  (,dfun-wrappers nil) (dfun-wrappers-tail nil)
-	  ,@(when wrappers
-	      `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
-     (dolist (mt ,metatypes)
-       (unless args-tail
-	 (setq invalid-arguments-p t)
-	 (return nil))
-       (let* ((arg (pop args-tail))
-	      (wrapper nil)
-	      ,@(when wrappers
-		  `((class *the-class-t*)
-		    (type 't))))
-	 (unless (eq mt 't)
-	   (setq wrapper (wrapper-of arg))
-	   (when (invalid-wrapper-p wrapper)
-	     (setq ,invalid-wrapper-p t)
-	     (setq wrapper (check-wrapper-validity arg)))
-	   (cond ((null ,dfun-wrappers)
-		  (setq ,dfun-wrappers wrapper))
-		 ((not (consp ,dfun-wrappers))
-		  (setq dfun-wrappers-tail (list wrapper))
-		  (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
-		 (t
-		  (let ((new-dfun-wrappers-tail (list wrapper)))
-		    (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
-		    (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
-	   ,@(when wrappers
-	       `((setq class (wrapper-class* wrapper))
-		 (setq type `(class-eq ,class)))))
-	 ,@(when wrappers
-	     `((push wrapper wrappers-rev)
-	       (push class classes-rev)
-	       (push type types-rev)))))
-     (if invalid-arguments-p
-	 ,invalid-arguments-form
-	 (let* (,@(when wrappers
-		    `((,wrappers (nreverse wrappers-rev))
-		      (,classes (nreverse classes-rev))
-		      (,types (mapcar #'(lambda (class)
-					  `(class-eq ,class))
-			              ,classes)))))
-	   ,@body))))
-
-
-;;;
-;;; Some support stuff for getting a hold of symbols that we need when
-;;; building the discriminator codes.  Its ok for these to be interned
-;;; symbols because we don't capture any user code in the scope in which
-;;; these symbols are bound.
-;;; 
-
-(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
-
-(defun dfun-arg-symbol (arg-number)
-  (or (nth arg-number (the list *dfun-arg-symbols*))
-      (intern (format nil ".ARG~A." arg-number) *the-pcl-package*)))
-
-(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
-
-(defun slot-vector-symbol (arg-number)
-  (or (nth arg-number (the list *slot-vector-symbols*))
-      (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*)))
-
-(defun make-dfun-lambda-list (metatypes applyp)
-  (gathering1 (collecting)
-    (iterate ((i (interval :from 0))
-	      (s (list-elements metatypes)))
-      (progn s)
-      (gather1 (dfun-arg-symbol i)))
-    (when applyp
-      (gather1 '&rest)
-      (gather1 '.dfun-rest-arg.))))
-
-(defun make-dlap-lambda-list (metatypes applyp)
-  (gathering1 (collecting)
-    (iterate ((i (interval :from 0))
-	      (s (list-elements metatypes)))
-      (progn s)
-      (gather1 (dfun-arg-symbol i)))
-    (when applyp
-      (gather1 '&rest))))
-
-(defun make-emf-call (metatypes applyp fn-variable &optional emf-type)
-  (let ((required
-	 (gathering1 (collecting)
-	    (iterate ((i (interval :from 0))
-		      (s (list-elements metatypes)))
-	      (progn s)
-	      (gather1 (dfun-arg-symbol i))))))
-    `(,(if (eq emf-type 'fast-method-call)
-	   'invoke-effective-method-function-fast
-	   'invoke-effective-method-function)
-      ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.)))))
-
-(defun make-dfun-call (metatypes applyp fn-variable)
-  (let ((required
-	  (gathering1 (collecting)
-	    (iterate ((i (interval :from 0))
-		      (s (list-elements metatypes)))
-	      (progn s)
-	      (gather1 (dfun-arg-symbol i))))))
-    (if applyp
-	`(function-apply   ,fn-variable ,@required .dfun-rest-arg.)
-	`(function-funcall ,fn-variable ,@required))))
-
-(defun make-dfun-arg-list (metatypes applyp)
-  (let ((required
-	  (gathering1 (collecting)
-	    (iterate ((i (interval :from 0))
-		      (s (list-elements metatypes)))
-	      (progn s)
-	      (gather1 (dfun-arg-symbol i))))))
-    (if applyp
-	`(list* ,@required .dfun-rest-arg.)
-	`(list ,@required))))
-
-(defun make-fast-method-call-lambda-list (metatypes applyp)
-  (gathering1 (collecting)
-    (gather1 '.pv-cell.)
-    (gather1 '.next-method-call.)
-    (iterate ((i (interval :from 0))
-	      (s (list-elements metatypes)))
-      (progn s)
-      (gather1 (dfun-arg-symbol i)))
-    (when applyp
-      (gather1 '.dfun-rest-arg.))))
-
-
-;;;
-;;; Its too bad Common Lisp compilers freak out when you have a defun with
-;;; a lot of LABELS in it.  If I could do that I could make this code much
-;;; easier to read and work with.
-;;;
-;;; Ahh Scheme...
-;;; 
-;;; In the absence of that, the following little macro makes the code that
-;;; follows a little bit more reasonable.  I would like to add that having
-;;; to practically write my own compiler in order to get just this simple
-;;; thing is something of a drag.
-;;;
-(eval-when (compile load eval)
-
-(defvar *cache* nil)
-
-(defconstant *local-cache-functions*
-  '((cache () .cache.)
-    (nkeys () (cache-nkeys .cache.))
-    (line-size () (cache-line-size .cache.))
-    (vector () (cache-vector .cache.))
-    (valuep () (cache-valuep .cache.))
-    (nlines () (cache-nlines .cache.))
-    (max-location () (cache-max-location .cache.))
-    (limit-fn () (cache-limit-fn .cache.))
-    (size () (cache-size .cache.))
-    (mask () (cache-mask .cache.))
-    (field () (cache-field .cache.))
-    (overflow () (cache-overflow .cache.))
-
-    ;;
-    ;; Return T IFF this cache location is reserved.  The only time
-    ;; this is true is for line number 0 of an nkeys=1 cache.  
-    ;;
-    (line-reserved-p (line)
-      (declare (fixnum line))
-      (and (= (nkeys) 1)
-           (= line 0)))
-    ;;
-    (location-reserved-p (location)
-      (declare (fixnum location))
-      (and (= (nkeys) 1)
-           (= location 0)))
-    ;;
-    ;; Given a line number, return the cache location.  This is the
-    ;; value that is the second argument to cache-vector-ref.  Basically,
-    ;; this deals with the offset of nkeys>1 caches and multiplies
-    ;; by line size.  
-    ;; 	  
-    (line-location (line)
-      (declare (fixnum line))
-      (when (line-reserved-p line)
-        (error "line is reserved"))
-      (if (= (nkeys) 1)
-	  (the fixnum (* line (line-size)))
-	  (the fixnum (1+ (the fixnum (* line (line-size)))))))
-    ;;
-    ;; Given a cache location, return the line.  This is the inverse
-    ;; of LINE-LOCATION.
-    ;; 	  
-    (location-line (location)
-      (declare (fixnum location))
-      (if (= (nkeys) 1)
-	  (floor location (line-size))
-	  (floor (the fixnum (1- location)) (line-size))))
-    ;;
-    ;; Given a line number, return the wrappers stored at that line.
-    ;; As usual, if nkeys=1, this returns a single value.  Only when
-    ;; nkeys>1 does it return a list.  An error is signalled if the
-    ;; line is reserved.
-    ;;
-    (line-wrappers (line)
-      (declare (fixnum line))
-      (when (line-reserved-p line) (error "Line is reserved."))
-      (location-wrappers (line-location line)))
-    ;;
-    (location-wrappers (location) ; avoid multiplies caused by line-location
-      (declare (fixnum location))
-      (if (= (nkeys) 1)
-	  (cache-vector-ref (vector) location)
-	  (let ((list (make-list (nkeys)))
-		(vector (vector)))
-	    (declare (simple-vector vector))
-	    (dotimes (i (nkeys) list)
-	      (setf (nth i list) (cache-vector-ref vector (+ location i)))))))
-    ;;
-    ;; Given a line number, return true IFF the line's
-    ;; wrappers are the same as wrappers.
-    ;;
-    (line-matches-wrappers-p (line wrappers)
-      (declare (fixnum line))
-      (and (not (line-reserved-p line))
-           (location-matches-wrappers-p (line-location line) wrappers)))
-    ;;
-    (location-matches-wrappers-p (loc wrappers) ; must not be reserved
-      (declare (fixnum loc))
-      (let ((cache-vector (vector)))
-	(declare (simple-vector cache-vector))
-	(if (= (nkeys) 1)
-	    (eq wrappers (cache-vector-ref cache-vector loc))
-	    (dotimes (i (nkeys) t)
-	      (unless (eq (pop wrappers) (cache-vector-ref cache-vector (+ loc i)))
-		(return nil))))))
-    ;;
-    ;; Given a line number, return the value stored at that line.
-    ;; If valuep is NIL, this returns NIL.  As with line-wrappers,
-    ;; an error is signalled if the line is reserved.
-    ;; 
-    (line-value (line)
-      (declare (fixnum line))
-      (when (line-reserved-p line) (error "Line is reserved."))
-      (location-value (line-location line)))
-    ;;
-    (location-value (loc)
-      (declare (fixnum loc))
-      (and (valuep)
-           (cache-vector-ref (vector) (+ loc (nkeys)))))
-    ;;
-    ;; Given a line number, return true IFF that line has data in
-    ;; it.  The state of the wrappers stored in the line is not
-    ;; checked.  An error is signalled if line is reserved.
-    (line-full-p (line)
-      (when (line-reserved-p line) (error "Line is reserved."))
-      (not (null (cache-vector-ref (vector) (line-location line)))))
-    ;;
-    ;; Given a line number, return true IFF the line is full and
-    ;; there are no invalid wrappers in the line, and the line's
-    ;; wrappers are different from wrappers.
-    ;; An error is signalled if the line is reserved.
-    ;;
-    (line-valid-p (line wrappers)
-      (declare (fixnum line))
-      (when (line-reserved-p line) (error "Line is reserved."))
-      (location-valid-p (line-location line) wrappers))
-    ;;
-    (location-valid-p (loc wrappers)
-      (declare (fixnum loc))
-      (let ((cache-vector (vector))
-	    (wrappers-mismatch-p (null wrappers)))
-	(declare (simple-vector cache-vector))
-	(dotimes (i (nkeys) wrappers-mismatch-p)
-	  (let ((wrapper (cache-vector-ref cache-vector (+ loc i))))
-	    (when (or (null wrapper)
-		      (invalid-wrapper-p wrapper))
-	      (return nil))
-	    (unless (and wrappers
-			 (eq wrapper
-			     (if (consp wrappers) (pop wrappers) wrappers)))
-	      (setq wrappers-mismatch-p t))))))
-    ;;
-    ;; How many unreserved lines separate line-1 and line-2.
-    ;;
-    (line-separation (line-1 line-2)
-     (declare (fixnum line-1 line-2))
-     (let ((diff (the fixnum (- line-2 line-1))))
-       (declare (fixnum diff))
-       (when (minusp diff)
-	 (setq diff (+ diff (nlines)))
-	 (when (line-reserved-p 0)
-	   (setq diff (1- diff))))
-       diff))
-    ;;
-    ;; Given a cache line, get the next cache line.  This will not
-    ;; return a reserved line.
-    ;; 
-    (next-line (line)
-     (declare (fixnum line))
-     (if (= line (the fixnum (1- (nlines))))
-	 (if (line-reserved-p 0) 1 0)
-	 (the fixnum (1+ line))))
-    ;;
-    (next-location (loc)
-      (declare (fixnum loc))
-      (if (= loc (max-location))
-	  (if (= (nkeys) 1)
-	      (line-size)
-	      1)
-	  (the fixnum (+ loc (line-size)))))
-    ;;
-    ;; Given a line which has a valid entry in it, this will return
-    ;; the primary cache line of the wrappers in that line.  We just
-    ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an
-    ;; easier packaging up of the call to it.
-    ;; 
-    (line-primary (line)
-      (declare (fixnum line))
-      (location-line (line-primary-location line)))
-    ;;
-    (line-primary-location (line)
-     (declare (fixnum line))
-     (compute-primary-cache-location-from-location
-       (cache) (line-location line)))
-    ))
-
-(defmacro with-local-cache-functions ((cache) &body body)
-  `(let ((.cache. ,cache))
-     (declare (type cache .cache.))
-     (macrolet ,(mapcar #'(lambda (fn)
-			    `(,(car fn) ,(cadr fn)
-			        `(let (,,@(mapcar #'(lambda (var)
-						      ``(,',var ,,var))
-					          (cadr fn)))
-				    ,@',(cddr fn))))
-			*local-cache-functions*)
-       ,@body)))
-
-)
-
-;;;
-;;; Here is where we actually fill, recache and expand caches.
-;;;
-;;; The functions FILL-CACHE and PROBE-CACHE are the ONLY external
-;;; entrypoints into this code.
-;;;
-;;; FILL-CACHE returns 1 value: a new cache
-;;;
-;;;   a wrapper field number
-;;;   a cache
-;;;   a mask
-;;;   an absolute cache size (the size of the actual vector)
-;;; It tries to re-adjust the cache every time it makes a new fill.  The
-;;; intuition here is that we want uniformity in the number of probes needed to
-;;; find an entry.  Furthermore, adjusting has the nice property of throwing out
-;;; any entries that are invalid.
-;;;
-(defvar *cache-expand-threshold* 1.25)
-
-(defun fill-cache (cache wrappers value &optional free-cache-p)
-  ;;(declare (values cache))
-  (unless wrappers ; fill-cache won't return if wrappers is nil, might as well check.
-    (error "fill-cache: wrappers arg is NIL!"))
-  (or (fill-cache-p nil cache wrappers value)
-      (and (< (ceiling (* (cache-count cache) 1.25))
-	      (if (= (cache-nkeys cache) 1)
-		  (1- (cache-nlines cache))
-		  (cache-nlines cache)))
-	   (adjust-cache cache wrappers value free-cache-p))
-      (expand-cache cache wrappers value free-cache-p)))
-
-(defvar *check-cache-p* nil)
-
-(defmacro maybe-check-cache (cache)
-  `(progn
-     (when *check-cache-p*
-       (check-cache ,cache))
-     ,cache))
-
-(defun check-cache (cache)
-  (with-local-cache-functions (cache)
-    (let ((location (if (= (nkeys) 1) 0 1))
-	  (limit (funcall (limit-fn) (nlines))))
-      (dotimes (i (nlines) cache)
-	(when (and (not (location-reserved-p location))
-		   (line-full-p i))
-	  (let* ((home-loc (compute-primary-cache-location-from-location 
-			    cache location))
-		 (home (location-line (if (location-reserved-p home-loc)
-					  (next-location home-loc)
-					  home-loc)))
-		 (sep (when home (line-separation home i))))
-	    (when (and sep (> sep limit))
-	      (error "bad cache ~S ~@
-                      value at location ~D is ~D lines from its home. limit is ~D."
-		     cache location sep limit))))
-	(setq location (next-location location))))))
-
-(defun probe-cache (cache wrappers &optional default limit-fn)
-  ;;(declare (values value))
-  (unless wrappers (error "probe-cache: wrappers arg is NIL!"))
-  (with-local-cache-functions (cache)
-    (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
-	   (limit (funcall (or limit-fn (limit-fn)) (nlines))))
-      (declare (fixnum location limit))
-      (when (location-reserved-p location)
-	(setq location (next-location location)))
-      (dotimes (i (1+ limit))
-	(when (location-matches-wrappers-p location wrappers)
-	  (return-from probe-cache (or (not (valuep))
-				       (location-value location))))
-	(setq location (next-location location)))
-      (dolist (entry (overflow))
-	(when (equal (car entry) wrappers)
-	  (return-from probe-cache (or (not (valuep))
-				       (cdr entry)))))
-      default)))
-
-(defun map-cache (function cache &optional set-p)
-  (with-local-cache-functions (cache)
-    (let ((set-p (and set-p (valuep))))
-      (dotimes (i (nlines) cache)
-	(unless (or (line-reserved-p i) (not (line-valid-p i nil)))
-	  (let ((value (funcall function (line-wrappers i) (line-value i))))
-	    (when set-p
-	      (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys)))
-		    value)))))
-      (dolist (entry (overflow))
-	(let ((value (funcall function (car entry) (cdr entry))))
-	  (when set-p
-	    (setf (cdr entry) value))))))
-  cache)
-
-(defun cache-count (cache)
-  (with-local-cache-functions (cache)
-    (let ((count 0))
-      (declare (fixnum count))
-      (dotimes (i (nlines) count)
-	(unless (line-reserved-p i)
-	  (when (line-full-p i)
-	    (incf count)))))))
-
-(defun entry-in-cache-p (cache wrappers value)
-  (declare (ignore value))
-  (with-local-cache-functions (cache)
-    (dotimes (i (nlines))
-      (unless (line-reserved-p i)
-	(when (equal (line-wrappers i) wrappers)
-	  (return t))))))
-
-;;;
-;;; returns T or NIL
-;;;
-(defun fill-cache-p (forcep cache wrappers value)
-  (with-local-cache-functions (cache)
-    (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
-	   (primary (location-line location)))
-      (declare (fixnum location primary))
-      (multiple-value-bind (free emptyp)
-	  (find-free-cache-line primary cache wrappers)
-	(when (or forcep emptyp)
-	  (when (not emptyp)
-	    (push (cons (line-wrappers free) (line-value free)) 
-		  (cache-overflow cache)))
-	  ;;(fill-line free wrappers value)
-	  (let ((line free))
-	    (declare (fixnum line))
-	    (when (line-reserved-p line)
-	      (error "Attempt to fill a reserved line."))
-	    (let ((loc (line-location line))
-		  (cache-vector (vector)))
-	      (declare (fixnum loc) (simple-vector cache-vector))
-	      (cond ((= (nkeys) 1)
-		     (setf (cache-vector-ref cache-vector loc) wrappers)
-		     (when (valuep)
-		       (setf (cache-vector-ref cache-vector (1+ loc)) value)))
-		    (t
-		     (let ((i 0))
-		       (declare (fixnum i))
-		       (dolist (w wrappers)
-			 (setf (cache-vector-ref cache-vector (+ loc i)) w)
-			 (setq i (the fixnum (1+ i)))))
-		     (when (valuep)
-		       (setf (cache-vector-ref cache-vector (+ loc (nkeys)))
-			     value))))
-	      (maybe-check-cache cache))))))))
-
-(defun fill-cache-from-cache-p (forcep cache from-cache from-line)
-  (declare (fixnum from-line))
-  (with-local-cache-functions (cache)
-    (let ((primary (location-line (compute-primary-cache-location-from-location
-				   cache (line-location from-line) from-cache))))
-      (declare (fixnum primary))
-      (multiple-value-bind (free emptyp)
-	  (find-free-cache-line primary cache)
-	(when (or forcep emptyp)
-	  (when (not emptyp)
-	    (push (cons (line-wrappers free) (line-value free))
-		  (cache-overflow cache)))
-	  ;;(transfer-line from-cache-vector from-line cache-vector free)
-	  (let ((from-cache-vector (cache-vector from-cache))
-		(to-cache-vector (vector))
-		(to-line free))
-	    (declare (fixnum to-line))
-	    (if (line-reserved-p to-line)
-		(error "transfering something into a reserved cache line.")
-		(let ((from-loc (line-location from-line))
-		      (to-loc (line-location to-line)))
-		  (declare (fixnum from-loc to-loc))
-		  (modify-cache to-cache-vector
-				(dotimes (i (line-size))
-				  (setf (cache-vector-ref to-cache-vector
-							  (+ to-loc i))
-					(cache-vector-ref from-cache-vector
-							  (+ from-loc i)))))))
-	    (maybe-check-cache cache)))))))
-
-;;;
-;;; Returns NIL or (values <field> <cache-vector>)
-;;; 
-;;; This is only called when it isn't possible to put the entry in the cache
-;;; the easy way.  That is, this function assumes that FILL-CACHE-P has been
-;;; called as returned NIL.
-;;;
-;;; If this returns NIL, it means that it wasn't possible to find a wrapper
-;;; field for which all of the entries could be put in the cache (within the
-;;; limit).  
-;;;
-(defun adjust-cache (cache wrappers value free-old-cache-p)
-  (with-local-cache-functions (cache)
-    (let ((ncache (get-cache-from-cache cache (nlines) (field))))
-      (do ((nfield (cache-field ncache) (next-wrapper-cache-number-index nfield)))
-	  ((null nfield) (free-cache ncache) nil)
-	(setf (cache-field ncache) nfield)
-	(labels ((try-one-fill-from-line (line)
-		   (fill-cache-from-cache-p nil ncache cache line))
-		 (try-one-fill (wrappers value)
-		   (fill-cache-p nil ncache wrappers value)))
-	  (if (and (dotimes (i (nlines) t)
-		     (when (and (null (line-reserved-p i))
-				(line-valid-p i wrappers))
-		       (unless (try-one-fill-from-line i) (return nil))))
-		   (dolist (wrappers+value (cache-overflow cache) t)
-		     (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
-		       (return nil)))
-		   (try-one-fill wrappers value))
-	      (progn (when free-old-cache-p (free-cache cache))
-		     (return (maybe-check-cache ncache)))
-	      (flush-cache-vector-internal (cache-vector ncache))))))))
-
-		       
-;;;
-;;; returns: (values <cache>)
-;;;
-(defun expand-cache (cache wrappers value free-old-cache-p)
-  ;;(declare (values cache))
-  (with-local-cache-functions (cache)
-    (let ((ncache (get-cache-from-cache cache (* (nlines) 2))))
-      (labels ((do-one-fill-from-line (line)
-		 (unless (fill-cache-from-cache-p nil ncache cache line)
-		   (do-one-fill (line-wrappers line) (line-value line))))
-	       (do-one-fill (wrappers value)
-		 (setq ncache (or (adjust-cache ncache wrappers value t)
-				  (fill-cache-p t ncache wrappers value))))
-	       (try-one-fill (wrappers value)
-		 (fill-cache-p nil ncache wrappers value)))
-	(dotimes (i (nlines))
-	  (when (and (null (line-reserved-p i))
-		     (line-valid-p i wrappers))
-	    (do-one-fill-from-line i)))
-	(dolist (wrappers+value (cache-overflow cache))
-	  (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
-	    (do-one-fill (car wrappers+value) (cdr wrappers+value))))
-	(unless (try-one-fill wrappers value)
-	  (do-one-fill wrappers value))
-	(when free-old-cache-p (free-cache cache))
-	(maybe-check-cache ncache)))))
-
-
-;;;
-;;; This is the heart of the cache filling mechanism.  It implements the decisions
-;;; about where entries are placed.
-;;; 
-;;; Find a line in the cache at which a new entry can be inserted.
-;;;
-;;;   <line>
-;;;   <empty?>           is <line> in fact empty?
-;;;
-(defun find-free-cache-line (primary cache &optional wrappers)
-  ;;(declare (values line empty?))
-  (declare (fixnum primary))
-  (with-local-cache-functions (cache)
-    (when (line-reserved-p primary) (setq primary (next-line primary)))
-    (let ((limit (funcall (limit-fn) (nlines)))
-	  (wrappedp nil)
-	  (lines nil)
-	  (p primary) (s primary))
-      (declare (fixnum p s limit))
-      (block find-free
-	(loop
-	 ;; Try to find a free line starting at <s>.  <p> is the
-	 ;; primary line of the entry we are finding a free
-	 ;; line for, it is used to compute the seperations.
-	 (do* ((line s (next-line line))
-	       (nsep (line-separation p s) (1+ nsep)))
-	      (())
-	   (declare (fixnum line nsep))
-	   (when (null (line-valid-p line wrappers)) ;If this line is empty or
-	     (push line lines)		;invalid, just use it.
-	     (return-from find-free))
-	   (when (and wrappedp (>= line primary))
-	     ;; have gone all the way around the cache, time to quit
-	     (return-from find-free-cache-line (values primary nil)))
-	   (let ((osep (line-separation (line-primary line) line)))
-	     (when (>= osep limit)
-	       (return-from find-free-cache-line (values primary nil)))
-	     (when (cond ((= nsep limit) t)
-			 ((= nsep osep) (zerop (random 2)))
-			 ((> nsep osep) t)
-			 (t nil))
-	       ;; See if we can displace what is in this line so that we
-	       ;; can use the line.
-	       (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))
-	       (setq p (line-primary line))
-	       (setq s (next-line line))
-	       (push line lines)
-	       (return nil)))
-	   (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)))))
-      ;; Do all the displacing.
-      (loop 
-       (when (null (cdr lines)) (return nil))
-       (let ((dline (pop lines))
-	     (line (car lines)))
-	 (declare (fixnum dline line))
-	 ;;Copy from line to dline (dline is known to be free).
-	 (let ((from-loc (line-location line))
-	       (to-loc (line-location dline))
-	       (cache-vector (vector)))
-	   (declare (fixnum from-loc to-loc) (simple-vector cache-vector))
-	   (modify-cache cache-vector
-			 (dotimes (i (line-size))
-			   (setf (cache-vector-ref cache-vector (+ to-loc i))
-				 (cache-vector-ref cache-vector (+ from-loc i)))
-			   (setf (cache-vector-ref cache-vector (+ from-loc i))
-				 nil))))))
-      (values (car lines) t))))
-
-(defun default-limit-fn (nlines)
-  (case nlines
-    ((1 2 4) 1)
-    ((8 16)  4)
-    (otherwise 6)))
-
-(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms
-
-;;;
-;;; pre-allocate generic function caches.  The hope is that this will put
-;;; them nicely together in memory, and that that may be a win.  Of course
-;;; the first gc copy will probably blow that out, this really wants to be
-;;; wrapped in something that declares the area static.
-;;;
-;;; This preallocation only creates about 25% more caches than PCL itself
-;;; uses.  Some ports may want to preallocate some more of these.
-;;; 
-(eval-when (load)
-  (dolist (n-size '((1 513)(3 257)(3 129)(14 128)(6 65)(2 64)(7 33)(16 32)
-		    (16 17)(32 16)(64 9)(64 8)(6 5)(128 4)(35 2)))
-    (let ((n (car n-size))
-	  (size (cadr n-size)))
-      (mapcar #'free-cache-vector
-	      (mapcar #'get-cache-vector
-		      (make-list n :initial-element size))))))
-
-(defun caches-to-allocate ()
-  (sort (let ((l nil))
-	  (maphash #'(lambda (size entry)
-		       (push (list (car entry) size) l))
-		   pcl::*free-caches*)
-	  l)
-	#'> :key #'cadr))
-
-
diff --git a/pcl/cloe-low.lisp b/pcl/cloe-low.lisp
deleted file mode 100644
index af7459de3466efc5810634e85c4e1369cb1dff70..0000000000000000000000000000000000000000
--- a/pcl/cloe-low.lisp
+++ /dev/null
@@ -1,32 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-(defmacro object-cache-no (object mask)
-  `(logand (sys::address-of ,object) ,mask))
-
diff --git a/pcl/cmu-low.lisp b/pcl/cmu-low.lisp
deleted file mode 100644
index 87bceaa3a92b94bc5eb6663656911175d0378b28..0000000000000000000000000000000000000000
--- a/pcl/cmu-low.lisp
+++ /dev/null
@@ -1,501 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;; 
-;;; This is the CMU Lisp version of the file low.
-;;; 
-
-(in-package :pcl)
-
-(defmacro dotimes ((var count &optional (result nil)) &body body)
-  `(lisp:dotimes (,var (the fixnum ,count) ,result)
-     (declare (fixnum ,var))
-     ,@body))
-
-;;; Just use our without-interrupts.  We don't have the INTERRUPTS-ON/OFF local
-;;; macros spec'ed in low.lisp, but they aren't used.
-;;;
-(defmacro without-interrupts (&rest stuff)
-  `(sys:without-interrupts ,@stuff))
-
-
-;;; Print the object addr in default printers.
-;;;
-(defun printing-random-thing-internal (thing stream)
-  (format stream "{~X}" (sys:%primitive c:make-fixnum thing)))
-
-
-(eval-when (compile load eval)
-  (c:def-source-transform std-instance-p (x)
-    (ext:once-only ((n-x x))
-      `(and (ext:structurep ,n-x)
-            (eq (kernel:structure-ref ,n-x 0) 'std-instance)))))
-
-(defun function-arglist (fcn)
-  "Returns the argument list of a compiled function, if possible."
-  (cond ((symbolp fcn)
-         (when (fboundp fcn)
-           (function-arglist (symbol-function fcn))))
-        ((eval:interpreted-function-p fcn)
-         (eval:interpreted-function-arglist fcn))
-        ((functionp fcn)
-         (let ((lambda-expr (function-lambda-expression fcn)))
-           (if lambda-expr
-               (cadr lambda-expr)
-               (let ((function (kernel:%closure-function fcn)))
-                 (values (read-from-string
-                          (kernel:%function-header-arglist function)))))))))
-
-
-;;; We have this here and in fin.lisp, 'cause PCL wants to compile this
-;;; file first.
-;;; 
-(defsetf funcallable-instance-name set-funcallable-instance-name)
-
-;;; And returns the function, not the *name*.
-(defun set-function-name (fcn new-name)
-  "Set the name of a compiled function object."
-  (cond ((symbolp fcn)
-         (set-function-name (symbol-function fcn) new-name))
-        ((funcallable-instance-p fcn)
-         (setf (funcallable-instance-name fcn) new-name)
-         fcn)
-        ((eval:interpreted-function-p fcn)
-         (setf (eval:interpreted-function-name fcn) new-name)
-         fcn)
-        (t
-         (let ((header (kernel:%closure-function fcn)))
-	   #+cmu17
-	   (setf (c::%function-name header) new-name)
-	   #-cmu17
-           (system:%primitive c::set-function-name header new-name))
-	 fcn)))
-
-(in-package "C")
-
-;;From compiler/ir1util
-(def-source-context pcl:defmethod (name &rest stuff)
-  (let ((arg-pos (position-if #'listp stuff)))
-    (if arg-pos
-	`(pcl:defmethod ,name ,@(subseq stuff 0 arg-pos)
-	   ,(nth-value 2 (pcl::parse-specialized-lambda-list
-			  (elt stuff arg-pos))))
-	`(pcl:defmethod ,name "<illegal syntax>"))))
-
-(define-info-type type kind (member :primitive :defined :structure :class nil)
-  (if (or (info type builtin name)
-	  (info type translator name))
-      :primitive
-      nil))
-(define-info-type type class-info (or pcl::class symbol null) nil)
-
-(in-package "KERNEL")
-
-(export '(clos-type clos-type-class))
-
-(defmacro cold-load-init (&rest forms)
-  `(progn ,@forms))
-
-(defstruct (clos-type (:include ctype
-				 (:class-info (type-class-or-lose 'clos))
-				 (:enumerable t))
-		       (:print-function %print-type))
-  ;;
-  ;; The CLOS class.
-  (class nil))
-
-(define-type-class clos)
-
-(define-type-method (clos :unparse) (x)
-  (clos-type-class x))
-
-(define-type-method (clos :complex-union) (type1 type2)
-  (make-union-type (list type1 type2)))
-
-(define-type-method (clos :simple-=) (type1 type2)
-  (values (eq (clos-type-class type1)
-	      (clos-type-class type2))
-	  t))
-
-(define-type-method (clos :simple-subtypep) (type1 type2)
-  (let ((class1 (pcl:find-class (clos-type-class type1) nil))
-	(class2 (pcl:find-class (clos-type-class type2) nil)))
-    (if (and class1 class2)
-	(values (member class2
-			(pcl:class-precedence-list class2))  t)
-      (values nil nil))))
-
-;; Add the new ctype to its supertypes.
-;;
-(let ((the-type-* (values-specifier-type '*)))
-  (pushnew 'clos (named-type-subclasses the-type-*)))
-(let ((the-type-t (values-specifier-type 't)))
-  (pushnew 'clos (named-type-subclasses the-type-t)))
-
-(defun-cached (values-specifier-type
-	       :hash-function (lambda (x)
-				(the fixnum
-				     (logand (the fixnum (cache-hash-eq x))
-					     #x3FF)))
-	       :hash-bits 10)
-    ((spec eq))
-  (or (info type builtin spec)
-      (let ((expand (type-expand spec)))
-	(if (eq expand spec)
-	    (let* ((lspec (if (atom spec) (list spec) spec))
-		   (fun (info type translator (car lspec))))
-	      (cond
-		(fun (funcall fun lspec))
-		((and (symbolp spec)
-		      (eq (info type kind spec) :structure))
-		 (make-structure-type :name spec))
-		((and (symbolp spec)
-		      (eq (info type kind spec) :class))
-		 (make-clos-type :class spec))
-		((or (and (consp spec) (symbolp (car spec)))
-		     (symbolp spec))
-		 (signal 'parse-unknown-type :specifier spec)
-		 ;;
-		 ;; Inhibit caching...
-		 (return-from values-specifier-type
-		   (make-unknown-type :specifier spec)))
-		(t
-		 (error "Bad thing to be a type specifier: ~S."
-			spec))))
-	    (values-specifier-type expand)))))
-
-(defun ctypep (obj type)
-  (declare (type ctype type))
-  (etypecase type
-    ((or numeric-type named-type member-type array-type)
-     (values (typep obj (type-specifier type)) t))
-    (structure-type
-     (if (structurep obj)
-	 (let* ((name (structure-type-name type))
-		(info (info type structure-info name))
-		(defined-info (info type defined-structure-info name)))
-	   (if (and info defined-info
-		    (equal (c::dd-includes info)
-			   (c::dd-includes defined-info)))
-	       (values (typep obj name) t)
-	       (values nil nil)))
-	 (values nil t)))
-    (clos-type
-     (let ((class (clos-type-class type)))
-       (if (pcl::std-instance-p obj)
-	   (values (pcl::*typep obj class) t)
-	   (values nil t))))
-    (union-type
-     (dolist (mem (union-type-types type) (values nil t))
-       (multiple-value-bind (val win)
-			    (ctypep obj mem)
-	 (unless win (return (values nil nil)))
-	 (when val (return (values t t))))))
-    (function-type
-     (values (functionp obj) t))
-    (unknown-type
-     (values nil nil))
-    (alien-type-type
-     (values (alien-typep obj (alien-type-type-alien-type type)) t))
-    (hairy-type
-     ;; Now the tricky stuff.
-     (let* ((hairy-spec (hairy-type-specifier type))
-	    (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
-       (ecase symbol
-	 (and
-	  (if (atom hairy-spec)
-	      (values t t)
-	      (dolist (spec (cdr hairy-spec) (values t t))
-		(multiple-value-bind (res win)
-				     (ctypep obj (specifier-type spec))
-		  (unless win (return (values nil nil)))
-		  (unless res (return (values nil t)))))))
-	 (not
-	  (multiple-value-bind
-	      (res win)
-	      (ctypep obj (specifier-type (cadr hairy-spec)))
-	    (if win
-		(values (not res) t)
-		(values nil nil))))
-	 (satisfies
-	  (let ((fun (second hairy-spec)))
-	    (cond ((and (consp fun) (eq (car fun) 'lambda))
-		   (values (not (null (funcall (coerce fun 'function) obj)))
-			   t))
-		  ((and (symbolp fun) (fboundp fun))
-		   (values (not (null (funcall fun obj))) t))
-		  (t
-		   (values nil nil))))))))))
-
-(in-package "LISP")
-
-(defun %%typep (object type)
-  (declare (type ctype type))
-  (etypecase type
-    (named-type
-     (ecase (named-type-name type)
-       ((* t)
-	t)
-       ((nil)
-	nil)
-       (character (characterp object))
-       (base-char (base-char-p object))
-       (standard-char (and (characterp object) (standard-char-p object)))
-       (extended-char
-	(and (characterp object) (not (base-char-p object))))
-       (function (functionp object))
-       (cons (consp object))
-       (symbol (symbolp object))
-       (keyword
-	(and (symbolp object)
-	     (eq (symbol-package object)
-		 (symbol-package :foo))))
-       (system-area-pointer (system-area-pointer-p object))
-       (weak-pointer (weak-pointer-p object))
-       (code-component (code-component-p object))
-       (lra (lra-p object))
-       (fdefn (fdefn-p object))
-       (scavenger-hook (scavenger-hook-p object))
-       (structure (structurep object))))
-    (numeric-type
-     (and (numberp object)
-	  (let ((num (if (complexp object) (realpart object) object)))
-	    (ecase (numeric-type-class type)
-	      (integer (integerp num))
-	      (rational (rationalp num))
-	      (float
-	       (ecase (numeric-type-format type)
-		 (short-float (typep object 'short-float))
-		 (single-float (typep object 'single-float))
-		 (double-float (typep object 'double-float))
-		 (long-float (typep object 'long-float))
-		 ((nil) (floatp num))))
-	      ((nil) t)))
-	  (flet ((bound-test (val)
-			     (let ((low (numeric-type-low type))
-				   (high (numeric-type-high type)))
-			       (and (cond ((null low) t)
-					  ((listp low) (> val (car low)))
-					  (t (>= val low)))
-				    (cond ((null high) t)
-					  ((listp high) (< val (car high)))
-					  (t (<= val high)))))))
-	    (ecase (numeric-type-complexp type)
-	      ((nil) t)
-	      (:complex
-	       (and (complexp object)
-		    (bound-test (realpart object))
-		    (bound-test (imagpart object))))
-	      (:real
-	       (and (not (complexp object))
-		    (bound-test object)))))))
-    (array-type
-     (and (arrayp object)
-	  (ecase (array-type-complexp type)
-	    ((t) (not (typep object 'simple-array)))
-	    ((nil) (typep object 'simple-array))
-	    (* t))
-	  (or (eq (array-type-dimensions type) '*)
-	      (do ((want (array-type-dimensions type) (cdr want))
-		   (got (array-dimensions object) (cdr got)))
-		  ((and (null want) (null got)) t)
-		(unless (and want got
-			     (or (eq (car want) '*)
-				 (= (car want) (car got))))
-		  (return nil))))
-	  (or (eq (array-type-element-type type) *wild-type*)
-	      (type= (array-type-specialized-element-type type)
-		     (specifier-type (array-element-type object))))))
-    (member-type
-     (if (member object (member-type-members type)) t))
-    (structure-type
-     (structure-typep object (structure-type-name type)))
-    (clos-type
-     (pcl::*typep object (clos-type-class type)))
-    (union-type
-     (dolist (type (union-type-types type))
-       (when (%%typep object type)
-	 (return t))))
-    (unknown-type
-     ;; Type may be unknown to the compiler (and SPECIFIER-TYPE), yet be
-     ;; a defined structure in the core.
-     (let ((orig-spec (unknown-type-specifier type)))
-       (if (and (symbolp orig-spec)
-		(info type defined-structure-info orig-spec))
-	   (structure-typep object orig-spec)
-	   (error "Unknown type specifier: ~S" orig-spec))))
-    (hairy-type
-     ;; Now the tricky stuff.
-     (let* ((hairy-spec (hairy-type-specifier type))
-	    (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
-       (ecase symbol
-	 (and
-	  (or (atom hairy-spec)
-	      (dolist (spec (cdr hairy-spec) t)
-		(unless (%%typep object (specifier-type spec))
-		  (return nil)))))
-	 (not
-	  (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
-	    (error "Invalid type specifier: ~S" hairy-spec))
-	  (not (%%typep object (specifier-type (cadr hairy-spec)))))
-	 (satisfies
-	  (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
-	    (error "Invalid type specifier: ~S" hairy-spec))
-	  (let ((fn (cadr hairy-spec)))
-	    (if (funcall (typecase fn
-			   (function fn)
-			   (symbol (symbol-function fn))
-			   (t
-			    (coerce fn 'function)))
-			 object)
-		t
-		nil))))))
-    (alien-type-type
-     (alien-internals:alien-typep object (alien-type-type-alien-type type)))
-    (function-type
-     (error "Function types are not a legal argument to TYPEP:~%  ~S"
-	    (type-specifier type)))))
-
-(defun %deftype (name expander &optional doc)
-  (ecase (info type kind name)
-    (:primitive
-     (error "Illegal to redefine standard type: ~S." name))
-    (:structure
-     (warn "Redefining structure type ~S with DEFTYPE." name)
-     (c::undefine-structure (info type structure-info name)))
-    (:class
-     (warn "Redefining class ~S with DEFTYPE." name))
-    ((nil :defined)))
-  (setf (info type kind name) :defined)
-  (setf (info type expander name) expander)
-  (when doc
-    (setf (documentation name 'type) doc))
-  ;; ### Bootstrap hack -- we need to define types before %note-type-defined
-  ;; is defined.
-  (when (fboundp 'c::%note-type-defined)
-    (c::%note-type-defined name))
-  name)
-
-(defun type-of (object)
-  "Return the type of OBJECT."
-  (typecase object
-    ;; First the ones that we can tell by testing the lowtag
-    (fixnum 'fixnum)
-    (function (type-specifier (ctype-of object)))
-    (null 'null)
-    (list 'cons)
-
-    ;; Any other immediates.
-    (character
-     (typecase object
-       (standard-char 'standard-char)
-       (base-char 'base-char)
-       (t 'character)))
-
-    ;; And now for the complicated ones.
-    (number
-     (etypecase object
-       (fixnum 'fixnum)
-       (bignum 'bignum)
-       (float
-	(etypecase object
-	  (double-float 'double-float)
-	  (single-float 'single-float)
-	  (short-float 'short-float)
-	  (long-float 'long-float)))
-       (ratio 'ratio)
-       (complex 'complex)))
-    (symbol
-     (if (eq (symbol-package object)
-	     (symbol-package :foo))
-	 'keyword
-	 'symbol))
-    (structure
-     (let ((name (structure-ref object 0)))
-       (case name
-	 (pcl::std-instance
-	  (pcl:class-name (pcl:class-of object)))
-	 (alien-internals:alien-value
-	  `(alien:alien
-	    ,(alien-internals:unparse-alien-type
-	      (alien-internals:alien-value-type object))))
-	 (t name))))
-    (array (type-specifier (ctype-of object)))
-    (system-area-pointer 'system-area-pointer)
-    (weak-pointer 'weak-pointer)
-    (code-component 'code-component)
-    (lra 'lra)
-    (fdefn 'fdefn)
-    (scavenger-hook 'scavenger-hook)
-    (t
-     (warn "Can't figure out the type of ~S" object)
-     t)))
-
-(in-package "PCL")
-
-(pushnew :structure-wrapper *features*)
-
-(defun structure-functions-exist-p ()
-  t)
-
-(defun structure-instance-p (x)
-  (and (structurep x)
-       (not (eq (kernel:structure-ref x 0) 'std-instance))))
-
-(defun structure-type (x)
-  (kernel:structure-ref x 0))
-
-(defun structure-type-p (type)
-  (not (null (ext:info c::type c::defined-structure-info type))))
-
-(defun structure-type-included-type-name (type)
-  (let ((include (c::dd-include (ext:info c::type c::defined-structure-info type))))
-    (if (consp include)
-	(car include)
-	include)))
-
-(defun structure-type-slot-description-list (type)
-  (nthcdr (length (let ((include (structure-type-included-type-name type)))
-		    (and include (structure-type-slot-description-list include))))
-	  (c::dd-slots (ext:info c::type c::defined-structure-info type))))
-
-(defun structure-slotd-name (slotd)
-  (intern (c::dsd-%name slotd) "USER"))
-
-(defun structure-slotd-accessor-symbol (slotd)
-  (c::dsd-accessor slotd))
-
-(defun structure-slotd-reader-function (slotd)
-  (fdefinition (c::dsd-accessor slotd)))
-
-(defun structure-slotd-writer-function (slotd)
-  (unless (c::dsd-read-only slotd)
-    (fdefinition `(setf ,(c::dsd-accessor slotd)))))
-
-(defun structure-slotd-type (slotd)
-  (c::dsd-type slotd))
-
-(defun structure-slotd-init-form (slotd)
-  (c::dsd-default slotd))
diff --git a/pcl/combin.lisp b/pcl/combin.lisp
deleted file mode 100644
index d6bdd87b556fdc33b811c04d94136ee27ef82f67..0000000000000000000000000000000000000000
--- a/pcl/combin.lisp
+++ /dev/null
@@ -1,403 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-(defun get-method-function (method &optional method-alist wrappers)
-  (let ((fn (cadr (assoc method method-alist))))
-    (if fn
-	(values fn nil nil nil)
-	(multiple-value-bind (mf fmf)
-	    (if (listp method)
-		(early-method-function method)
-		(values nil (method-fast-function method)))
-	  (let* ((pv-table (and fmf (method-function-pv-table fmf))))
-	    (if (and fmf (or (null pv-table) wrappers))
-		(let* ((pv-wrappers (when pv-table 
-				      (pv-wrappers-from-all-wrappers
-				       pv-table wrappers)))
-		       (pv-cell (when (and pv-table pv-wrappers)
-				  (pv-table-lookup pv-table pv-wrappers))))
-		  (values mf t fmf pv-cell))
-		(values 
-		 (or mf (if (listp method)
-			    (setf (cadr method)
-				  (method-function-from-fast-function fmf))
-			    (method-function method)))
-		 t nil nil)))))))
-
-(defun make-effective-method-function (generic-function form &optional 
-				       method-alist wrappers)
-  (funcall (make-effective-method-function1 generic-function form
-					    (not (null method-alist))
-					    (not (null wrappers)))
-	   method-alist wrappers))
-
-(defun make-effective-method-function1 (generic-function form 
-					method-alist-p wrappers-p)
-  (if (and (listp form)
-	   (eq (car form) 'call-method))
-      (make-effective-method-function-simple generic-function form)
-      ;;
-      ;; We have some sort of `real' effective method.  Go off and get a
-      ;; compiled function for it.  Most of the real hair here is done by
-      ;; the GET-FUNCTION mechanism.
-      ;; 
-      (make-effective-method-function-internal generic-function form
-					       method-alist-p wrappers-p)))
-
-(defun make-effective-method-function-type (generic-function form
-					    method-alist-p wrappers-p)
-  (if (and (listp form)
-	   (eq (car form) 'call-method))
-      (let* ((cm-args (cdr form))
-	     (method (car cm-args)))
-	(when method
-	  (if (if (listp method)
-		  (eq (car method) ':early-method)
-		  (method-p method))
-	      (if method-alist-p
-		  't
-		  (multiple-value-bind (mf fmf)
-		      (if (listp method)
-			  (early-method-function method)
-			  (values nil (method-fast-function method)))
-		    (declare (ignore mf))
-		    (let* ((pv-table (and fmf (method-function-pv-table fmf))))
-		      (if (and fmf (or (null pv-table) wrappers-p))
-			  'fast-method-call
-			  'method-call))))
-	      (if (and (consp method) (eq (car method) 'make-method))
-		  (make-effective-method-function-type 
-		   generic-function (cadr method) method-alist-p wrappers-p)
-		  (type-of method)))))
-      'fast-method-call))
-
-(defun make-effective-method-function-simple (generic-function form
-							       &optional no-fmf-p)
-  ;;
-  ;; The effective method is just a call to call-method.  This opens up
-  ;; the possibility of just using the method function of the method as
-  ;; the effective method function.
-  ;;
-  ;; But we have to be careful.  If that method function will ask for
-  ;; the next methods we have to provide them.  We do not look to see
-  ;; if there are next methods, we look at whether the method function
-  ;; asks about them.  If it does, we must tell it whether there are
-  ;; or aren't to prevent the leaky next methods bug.
-  ;; 
-  (let* ((cm-args (cdr form))
-	 (fmf-p (and (null no-fmf-p)
-		     (or (not (eq *boot-state* 'complete))
-			 (gf-fast-method-function-p generic-function))
-		     (null (cddr cm-args))))
-	 (method (car cm-args))
-	 (cm-args1 (cdr cm-args)))
-    #'(lambda (method-alist wrappers)
-	(make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
-						method-alist wrappers))))
-
-(defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers)
-  (multiple-value-bind (mf real-mf-p fmf pv-cell)
-      (get-method-function method method-alist wrappers)
-    (if fmf
-	(let* ((next-methods (car cm-args))
-	       (next (make-effective-method-function-simple1
-		      gf (car next-methods)
-		      (list* (cdr next-methods) (cdr cm-args))
-		      fmf-p method-alist wrappers))
-	       (arg-info (method-function-get fmf ':arg-info)))
-	  (make-fast-method-call :function fmf
-				 :pv-cell pv-cell
-				 :next-method-call next
-				 :arg-info arg-info))
-	(if real-mf-p
-	    (make-method-call :function mf
-			      :call-method-args cm-args)
-	    mf))))
-
-(defun make-effective-method-function-simple1 (gf method cm-args fmf-p
-						  &optional method-alist wrappers)
-  (when method
-    (if (if (listp method)
-	    (eq (car method) ':early-method)
-	    (method-p method))
-	(make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
-	(if (and (consp method) (eq (car method) 'make-method))
-	    (make-effective-method-function gf (cadr method) method-alist wrappers)
-	    method))))
-
-(defvar *global-effective-method-gensyms* ())
-(defvar *rebound-effective-method-gensyms*)
-
-(defun get-effective-method-gensym ()
-  (or (pop *rebound-effective-method-gensyms*)
-      (let ((new (intern (format nil "EFFECTIVE-METHOD-GENSYM-~D" 
-				 (length *global-effective-method-gensyms*))
-			 "PCL")))
-	(setq *global-effective-method-gensyms*
-	      (append *global-effective-method-gensyms* (list new)))
-	new)))
-
-(let ((*rebound-effective-method-gensyms* ()))
-  (dotimes (i 10) (get-effective-method-gensym)))
-
-(defun expand-effective-method-function (gf effective-method &optional env)
-  (declare (ignore env))
-  (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
-      (get-generic-function-info gf)
-    (declare (ignore nreq nkeys arg-info))
-    `(lambda ,(make-fast-method-call-lambda-list metatypes applyp)
-       (declare (ignore .pv-cell. .next-method-call.))
-       ,effective-method)))
-
-(defun expand-emf-call-method (gf form metatypes applyp env)
-  (declare (ignore gf metatypes applyp env))
-  `(call-method ,(cdr form)))
-
-(defmacro call-method (&rest args)
-  (declare (ignore args))
-  `(error "~S outsize of a effective method form" 'call-method))
-
-(defun memf-test-converter (form generic-function method-alist-p wrappers-p)
-  (cond ((and (consp form) (eq (car form) 'call-method))
-	 (case (make-effective-method-function-type 
-		generic-function form method-alist-p wrappers-p)
-	   (fast-method-call
-	    '.fast-call-method.)
-	   (t
-	    '.call-method.)))
-	((and (consp form) (eq (car form) 'call-method-list))
-	 (case (if (every #'(lambda (form)
-			      (eq 'fast-method-call
-				  (make-effective-method-function-type 
-				   generic-function form 
-				   method-alist-p wrappers-p)))
-			  (cdr form))
-		   'fast-method-call
-		   't)
-	   (fast-method-call
-	    '.fast-call-method-list.)
-	   (t
-	    '.call-method-list.)))
-	(t
-	 (default-test-converter form))))
-
-(defun memf-code-converter (form generic-function 
-				 metatypes applyp method-alist-p wrappers-p)
-  (cond ((and (consp form) (eq (car form) 'call-method))
-	 (let ((gensym (get-effective-method-gensym)))
-	   (values (make-emf-call metatypes applyp gensym
-				  (make-effective-method-function-type 
-				   generic-function form method-alist-p wrappers-p))
-		   (list gensym))))
-	((and (consp form) (eq (car form) 'call-method-list))
-	 (let ((gensym (get-effective-method-gensym))
-	       (type (if (every #'(lambda (form)
-				    (eq 'fast-method-call
-					(make-effective-method-function-type 
-					 generic-function form 
-					 method-alist-p wrappers-p)))
-				(cdr form))
-			 'fast-method-call
-			 't)))
-	   (values `(dolist (emf ,gensym nil)
-		      ,(make-emf-call metatypes applyp 'emf type))
-		   (list gensym))))		     
-	(t
-	 (default-code-converter form))))
-
-(defun memf-constant-converter (form generic-function)
-  (cond ((and (consp form) (eq (car form) 'call-method))
-	 (list (cons '.meth.
-		     (make-effective-method-function-simple
-		      generic-function form))))
-	((and (consp form) (eq (car form) 'call-method-list))
-	 (list (cons '.meth-list.
-		     (mapcar #'(lambda (form)
-				 (make-effective-method-function-simple
-				  generic-function form))
-			     (cdr form)))))
-	(t
-	 (default-constant-converter form))))
-
-(defun make-effective-method-function-internal (generic-function effective-method
-					        method-alist-p wrappers-p)
-  (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
-      (get-generic-function-info generic-function)
-    (declare (ignore nkeys arg-info))
-    (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
-	   (name (if (early-gf-p generic-function)
-		     (early-gf-name generic-function)
-		     (generic-function-name generic-function)))
-	   (arg-info (cons nreq applyp))
-	   (effective-method-lambda (expand-effective-method-function
-				     generic-function effective-method)))
-      (multiple-value-bind (cfunction constants)
-	  (get-function1 effective-method-lambda
-			 #'(lambda (form)
-			     (memf-test-converter form generic-function
-						  method-alist-p wrappers-p))
-			 #'(lambda (form)
-			     (memf-code-converter form generic-function
-						  metatypes applyp
-						  method-alist-p wrappers-p))
-			 #'(lambda (form)
-			     (memf-constant-converter form generic-function)))
-	#'(lambda (method-alist wrappers)
-	    (let* ((constants 
-		    (mapcar #'(lambda (constant)
-				(if (consp constant)
-				    (case (car constant)
-				      (.meth.
-				       (funcall (cdr constant)
-						method-alist wrappers))
-				      (.meth-list.
-				       (mapcar #'(lambda (fn)
-						   (funcall fn method-alist wrappers))
-					       (cdr constant)))
-				      (t constant))
-				    constant))
-			    constants))
-		   (function (set-function-name
-			      (apply cfunction constants)
-			      `(combined-method ,name))))
-	      (make-fast-method-call :function function
-				     :arg-info arg-info)))))))
-
-(defmacro call-method-list (&rest calls)
-  `(progn ,@calls))
-
-(defun make-call-methods (methods)
-  `(call-method-list
-    ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
-
-(defun standard-compute-effective-method (generic-function combin applicable-methods)
-  (declare (ignore combin))
-  (let ((before ())
-	(primary ())
-	(after ())
-	(around ()))
-    (dolist (m applicable-methods)
-      (let ((qualifiers (if (listp m)
-			    (early-method-qualifiers m)
-			    (method-qualifiers m))))			    
-	(cond ((member ':before qualifiers)  (push m before))
-	      ((member ':after  qualifiers)  (push m after))
-	      ((member ':around  qualifiers) (push m around))
-	      (t
-	       (push m primary)))))
-    (setq before  (reverse before)
-	  after   (reverse after)
-	  primary (reverse primary)
-	  around  (reverse around))
-    (cond ((null primary)
-	   `(error "No primary method for the generic function ~S." ',generic-function))
-	  ((and (null before) (null after) (null around))
-	   ;;
-	   ;; By returning a single call-method `form' here we enable an important
-	   ;; implementation-specific optimization.
-	   ;; 
-	   `(call-method ,(first primary) ,(rest primary)))
-	  (t
-	   (let ((main-effective-method
-		   (if (or before after)
-		       `(multiple-value-prog1
-			  (progn ,(make-call-methods before)
-				 (call-method ,(first primary) ,(rest primary)))
-			  ,(make-call-methods (reverse after)))
-		       `(call-method ,(first primary) ,(rest primary)))))
-	     (if around
-		 `(call-method ,(first around)
-			       (,@(rest around) (make-method ,main-effective-method)))
-		 main-effective-method))))))
-
-;;;
-;;; The STANDARD method combination type.  This is coded by hand (rather than
-;;; with define-method-combination) for bootstrapping and efficiency reasons.
-;;; Note that the definition of the find-method-combination-method appears in
-;;; the file defcombin.lisp, this is because EQL methods can't appear in the
-;;; bootstrap.
-;;;
-;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
-;;; classes has to appear here for this reason.  This code must conform to
-;;; the code in the file defcombin, look there for more details.
-;;;
-
-(defun compute-effective-method (generic-function combin applicable-methods)
-  (standard-compute-effective-method generic-function combin applicable-methods))
-
-(defvar *invalid-method-error*
-	#'(lambda (&rest args)
-	    (declare (ignore args))
-	    (error
-	      "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
-               of a method combination function (inside the body of~%~
-               DEFINE-METHOD-COMBINATION or a method on the generic~%~
-               function COMPUTE-EFFECTIVE-METHOD).")))
-
-(defvar *method-combination-error*
-	#'(lambda (&rest args)
-	    (declare (ignore args))
-	    (error
-	      "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
-               of a method combination function (inside the body of~%~
-               DEFINE-METHOD-COMBINATION or a method on the generic~%~
-               function COMPUTE-EFFECTIVE-METHOD).")))
-
-;(defmethod compute-effective-method :around        ;issue with magic
-;	   ((generic-function generic-function)     ;generic functions
-;	    (method-combination method-combination)
-;	    applicable-methods)
-;  (declare (ignore applicable-methods))
-;  (flet ((real-invalid-method-error (method format-string &rest args)
-;	   (declare (ignore method))
-;	   (apply #'error format-string args))
-;	 (real-method-combination-error (format-string &rest args)
-;	   (apply #'error format-string args)))
-;    (let ((*invalid-method-error* #'real-invalid-method-error)
-;	  (*method-combination-error* #'real-method-combination-error))
-;      (call-next-method))))
-
-(defun invalid-method-error (&rest args)
-  (declare (arglist method format-string &rest format-arguments))
-  (apply *invalid-method-error* args))
-
-(defun method-combination-error (&rest args)
-  (declare (arglist format-string &rest format-arguments))
-  (apply *method-combination-error* args))
-
-;This definition appears in defcombin.lisp.
-;
-;(defmethod find-method-combination ((generic-function generic-function)
-;				     (type (eql 'standard))
-;				     options)
-;  (when options
-;    (method-combination-error
-;      "The method combination type STANDARD accepts no options."))
-;  *standard-method-combination*)
-
diff --git a/pcl/compat.lisp b/pcl/compat.lisp
deleted file mode 100644
index 606915388599787e139609db4539d203cf61bca7..0000000000000000000000000000000000000000
--- a/pcl/compat.lisp
+++ /dev/null
@@ -1,31 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-()
-
diff --git a/pcl/construct.lisp b/pcl/construct.lisp
deleted file mode 100644
index 17784e2fe792b510c81721bf1d0c3e075501eace..0000000000000000000000000000000000000000
--- a/pcl/construct.lisp
+++ /dev/null
@@ -1,1064 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;;
-;;; This file defines the defconstructor and other make-instance optimization
-;;; mechanisms.
-;;; 
-
-(in-package :pcl)
-
-;;;
-;;; defconstructor is used to define special purpose functions which just
-;;; call make-instance with a symbol as the first argument.  The semantics
-;;; of defconstructor is that it is equivalent to defining a function which
-;;; just calls make-instance. The purpose of defconstructor is to provide
-;;; PCL with a way of noticing these calls to make-instance so that it can
-;;; optimize them.  Specific ports of PCL could just have their compiler
-;;; spot these calls to make-instance and then call this code.  Having the
-;;; special defconstructor facility is the best we can do portably.
-;;; 
-;;;
-;;; A call to defconstructor like:
-;;;
-;;;  (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r)
-;;;
-;;; Is equivalent to a defun like:
-;;;
-;;;  (defun make-foo (a b &rest r)
-;;;    (make-instance 'foo 'a a ':mumble b 'baz r))
-;;;
-;;; Calls like the following are also legal:
-;;;
-;;;  (defconstructor make-foo foo ())
-;;;  (defconstructor make-bar bar () :x *x* :y *y*)
-;;;  (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c))
-;;;
-;;;
-;;; The general idea of this implementation is that the expansion of the
-;;; defconstructor form includes the creation of closure generators which
-;;; can be called to create constructor code for the class.  The ways that
-;;; a constructor can be optimized depends not only on the defconstructor
-;;; form, but also on the state of the class and the generic functions in
-;;; the initialization protocol.  Because of this, the determination of the
-;;; form of constructor code to be used is a two part process.
-;;;
-;;; At compile time, make-constructor-code-generators looks at the actual
-;;; defconstructor form and makes a list of appropriate constructor code
-;;; generators.  All that is really taken into account here is whether
-;;; any initargs are supplied in the call to make-instance, and whether
-;;; any of those are constant.
-;;;
-;;; At constructor code generation time (see note about lazy evaluation)
-;;; compute-constructor-code calls each of the constructor code generators
-;;; to try to get code for this constructor.  Each generator looks at the
-;;; state of the class and initialization protocol generic functions and
-;;; decides whether its type of code is appropriate.  This depends on things
-;;; like whether there are any applicable methods on initialize-instance,
-;;; whether class slots are affected by initialization etc.
-;;; 
-;;;
-;;; Constructor objects are funcallable instances, the protocol followed to
-;;; to compute the constructor code for them is quite similar to the protocol
-;;; followed to compute the discriminator code for a generic function.  When
-;;; the constructor is first loaded, we install as its code a function which
-;;; will compute the actual constructor code the first time it is called.
-;;; 
-;;; If there is an update to the class structure which might invalidate the
-;;; optimized constructor, the special lazy constructor installer is put back
-;;; so that it can compute the appropriate constructor when it is called.
-;;; This is the same kind of lazy evaluation update strategy used elswhere
-;;; in PCL.
-;;;
-;;; To allow for flexibility in the PCL implementation and to allow PCL users
-;;; to specialize this constructor facility for their own metaclasses, there
-;;; is an internal protocol followed by the code which loads and installs
-;;; the constructors.  This is documented in the comments in the code.
-;;;
-;;; This code is also designed so that one of its levels, can be used to
-;;; implement optimization of calls to make-instance which can't go through
-;;; the defconstructor facility.  This has not been implemented yet, but the
-;;; hooks are there.
-;;;
-;;;
-
-(defmacro defconstructor
-	  (name class lambda-list &rest initialization-arguments)
-  (expand-defconstructor class
-			 name
-			 lambda-list
-			 (copy-list initialization-arguments)))
-
-(defun expand-defconstructor (class-name name lambda-list supplied-initargs)
-  (let ((class (find-class class-name nil))
-	(supplied-initarg-names
-	  (gathering1 (collecting)
-	    (iterate ((name (*list-elements supplied-initargs :by #'cddr)))
-	      (gather1 name)))))
-    (when (null class)
-      (error "defconstructor form being compiled (or evaluated) before~@
-              class ~S is defined."
-	     class-name))
-    `(progn
-       ;; In order to avoid undefined function warnings, we want to tell
-       ;; the compile time environment that a function with this name and
-       ;; this argument list has been defined.  The portable way to do this
-       ;; is with defun.
-       (proclaim '(notinline ,name))
-       (defun ,name ,lambda-list
-	 (declare (ignore ,@(extract-parameters lambda-list)))
-	 (error "Constructor ~S not loaded." ',name))
-
-       ,(make-top-level-form `(defconstructor ,name)
-			     '(load eval)
-	  `(load-constructor
-	     ',class-name
-	     ',(class-name (class-of class))
-	     ',name
-	     ',supplied-initarg-names
-	     ;; make-constructor-code-generators is called to return a list
-	     ;; of constructor code generators.  The actual interpretation
-	     ;; of this list is left to compute-constructor-code, but the
-	     ;; general idea is that it should be an plist where the keys
-	     ;; name a kind of constructor code and the values are generator
-	     ;; functions which return the actual constructor code.  The
-	     ;; constructor code is usually a closures over the arguments
-	     ;; to the generator.
-	     ,(make-constructor-code-generators class
-						name
-						lambda-list
-						supplied-initarg-names
-						supplied-initargs))))))
-
-(defun load-constructor (class-name metaclass-name constructor-name
-			 supplied-initarg-names code-generators)
-  (let ((class (find-class class-name nil)))
-    (cond ((null class)
-	   (error "defconstructor form being loaded (or evaluated) before~@
-                   class ~S is defined."
-		  class-name))
-	  ((neq (class-name (class-of class)) metaclass-name)
-	   (error "When defconstructor ~S was compiled, the metaclass of the~@
-                   class ~S was ~S.  The metaclass is now ~S.~@
-                   The constructor must be recompiled."
-		  constructor-name
-		  class-name
-		  metaclass-name
-		  (class-name (class-of class))))
-	  (t
-	   (load-constructor-internal class
-				      constructor-name
-				      supplied-initarg-names
-				      code-generators)
-	   constructor-name))))
-
-;;;
-;;; The actual constructor objects.
-;;; 
-(defclass constructor ()			   
-     ((class					;The class with which this
-	:initarg :class				;constructor is associated.
-	:reader constructor-class)		;The actual class object,
-						;not the class name.
-						;      
-      (name					;The name of this constructor.
-	:initform nil				;This is the symbol in whose
-	:initarg :name				;function cell the constructor
-	:reader constructor-name)		;usually sits.  Of course, this
-						;is optional.  defconstructor
-						;makes named constructors, but
-						;it is possible to manipulate
-						;anonymous constructors also.
-						;
-      (code-type				;The type of code currently in
-	:initform nil				;use by this constructor.  This
-	:accessor constructor-code-type)	;is mostly for debugging and
-						;analysis purposes.
-						;The lazy installer sets this
-						;to LAZY.  The most basic and
-						;least optimized type of code
-						;is called FALLBACK.
-						;
-      (supplied-initarg-names			;The names of the initargs this
-	:initarg :supplied-initarg-names	;constructor supplies when it
-	:reader					;"calls" make-instance.
-	   constructor-supplied-initarg-names)	;
-						;
-      (code-generators				;Generators for the different
-	:initarg :code-generators		;types of code this constructor
-	:reader constructor-code-generators))	;could use.
-  (:metaclass funcallable-standard-class))
-
-
-;;;
-;;; Because the value in the code-type slot should always correspond to the
-;;; funcallable-instance-function of the constructor, this function should
-;;; always be used to set the both at the same time.
-;;;
-(defun set-constructor-code (constructor code type)
-  (set-funcallable-instance-function constructor code)
-  (set-function-name constructor (constructor-name constructor))
-  (setf (constructor-code-type constructor) type))
-
-
-(defmethod print-object ((constructor constructor) stream)
-  (printing-random-thing (constructor stream)
-    (format stream
-	    "~S ~S (~S)"
-	    (or (class-name (class-of constructor)) "Constructor")
-	    (or (slot-value-or-default constructor 'name) "Anonymous")
-	    (slot-value-or-default constructor 'code-type))))
-
-(defmethod describe-object ((constructor constructor) stream)
-  (format stream
-	  "~S is a constructor for the class ~S.~%~
-            The current code type is ~S.~%~
-            Other possible code types are ~S."
-	  constructor (constructor-class constructor)
-	  (constructor-code-type constructor)
-	  (gathering1 (collecting)
-	    (doplist (key val) (constructor-code-generators constructor)
-	      (gather1 key)))))
-
-;;;
-;;; I am not in a hairy enough mood to make this implementation be metacircular
-;;; enough that it can support a defconstructor for constructor objects.
-;;; 
-(defun make-constructor (class name supplied-initarg-names code-generators)
-  (make-instance 'constructor
-		 :class class
-		 :name name
-		 :supplied-initarg-names supplied-initarg-names
-		 :code-generators code-generators))
-
-; This definition actually appears in std-class.lisp.
-;(defmethod class-constructors ((class std-class))
-;  (with-slots (plist) class (getf plist 'constructors)))
-
-(defmethod add-constructor ((class slot-class)
-			    (constructor constructor))
-  (with-slots (plist) class
-    (pushnew constructor (getf plist 'constructors))))
-
-(defmethod remove-constructor ((class slot-class)
-			       (constructor constructor))
-  (with-slots (plist) class
-    (setf (getf plist 'constructors)
-	  (delete constructor (getf plist 'constructors)))))
-
-(defmethod get-constructor ((class slot-class) name &optional (error-p t))
-  (or (dolist (c (class-constructors class))
-	(when (eq (constructor-name c) name) (return c)))
-      (if error-p
-	  (error "Couldn't find a constructor with name ~S for class ~S."
-		 name class)
-	  ())))
-
-;;;
-;;; This is called to actually load a defconstructor constructor.  It must
-;;; install the lazy installer in the function cell of the constructor name,
-;;; and also add this constructor to the list of constructors the class has.
-;;; 
-(defmethod load-constructor-internal
-	   ((class slot-class) name initargs generators)
-  (let ((constructor (make-constructor class name initargs generators))
-	(old (get-constructor class name nil)))
-    (when old (remove-constructor class old))
-    (install-lazy-constructor-installer constructor)
-    (add-constructor class constructor)
-    (setf (gdefinition name) constructor)))
-
-(defmethod install-lazy-constructor-installer ((constructor constructor))
-  (let ((class (constructor-class constructor)))
-    (set-constructor-code constructor
-			  #'(lambda (&rest args)
-			      (multiple-value-bind (code type)
-				  (compute-constructor-code class constructor)
-				(prog1 (apply code args)
-				       (set-constructor-code constructor
-							     code
-							     type))))
-			  'lazy)))
-
-;;;
-;;; The interface to keeping the constructors updated.
-;;;
-;;; add-method and remove-method (for standard-generic-function and -method),
-;;; promise to call maybe-update-constructors on the generic function and
-;;; the method.
-;;; 
-;;; The class update code promises to call update-constructors whenever the
-;;; class is changed.  That is, whenever the supers, slots or options change.
-;;; If user defined classes of constructor needs to be updated in more than
-;;; these circumstances, they should use the dependent updating mechanism to
-;;; make sure update-constructors is called.
-;;;
-;;; Bootstrapping concerns force the definitions of maybe-update-constructors
-;;; and update-constructors to be in the file std-class.  For clarity, they
-;;; also appear below.  Be sure to keep the definition here and there in sync.
-;;; 
-;(defvar *initialization-generic-functions*
-;	 (list #'make-instance
-;	       #'default-initargs
-;	       #'allocate-instance
-;	       #'initialize-instance
-;	       #'shared-initialize))
-;
-;(defmethod maybe-update-constructors
-;	   ((generic-function generic-function)
-;	    (method method))
-;  (when (memq generic-function *initialization-generic-functions*)
-;    (labels ((recurse (class)
-;	       (update-constructors class)
-;	       (dolist (subclass (class-direct-subclasses class))
-;		 (recurse subclass))))
-;      (when (classp (car (method-specializers method)))
-;	(recurse (car (method-specializers method)))))))
-;
-;(defmethod update-constructors ((class slot-class))
-;  (dolist (cons (class-constructors class))
-;    (install-lazy-constructor-installer cons)))
-;
-;(defmethod update-constructors ((class class))
-;  ())
-
-
-
-;;;
-;;; Here is the actual smarts for making the code generators and then trying
-;;; each generator to get constructor code. This extensible mechanism allows
-;;; new kinds of constructor code types to be added. A programmer defining a
-;;; specialization of the constructor class can either use this mechanism to
-;;; define new code types, or can override this mechanism by overriding the
-;;; methods on make-constructor-code-generators and compute-constructor-code.
-;;;
-;;; The function defined by define-constructor-code-type will receive the
-;;; class object, and the 4 original arguments to defconstructor. It can
-;;; return a constructor code generator, or return nil if this type of code
-;;; is determined to not be appropriate after looking at the defconstructor
-;;; arguments.
-;;;
-;;; When compute-constructor-code is called, it first performs basic checks
-;;; to make sure that the basic assumptions common to all the code types are
-;;; valid.  (For details see method definition).  If any of the tests fail,
-;;; the fallback constructor code type is used.  If none of the tests fail,
-;;; the constructor code generators are called in order.  They receive 5
-;;; arguments:
-;;;
-;;;   CLASS        the class the constructor is making instances of
-;;;   WRAPPER      that class's wrapper
-;;;   DEFAULTS     the result of calling class-default-initargs on class
-;;;   INITIALIZE   the applicable methods on initialize-instance
-;;;   SHARED       the applicable methosd on shared-initialize
-;;;
-;;; The first code generator to return code is used.  The code generators are
-;;; called in reverse order of definition, so define-constructor-code-type
-;;; forms which define better code should appear after ones that define less
-;;; good code.  The fallback code type appears first.  Note that redefining a
-;;; code type does not change its position in the list.  To do that,  define
-;;; a new type at the end with the behavior.
-;;; 
-
-(defvar *constructor-code-types* ())
-
-(defmacro define-constructor-code-type (type arglist &body body)
-  (let ((fn-name (intern (format nil
-				 "CONSTRUCTOR-CODE-GENERATOR ~A ~A"
-				 (package-name (symbol-package type))
-				 (symbol-name type))
-			 *the-pcl-package*)))
-    `(progn
-       (defun ,fn-name ,arglist .,body)
-       (load-define-constructor-code-type ',type ',fn-name))))
-
-(defun load-define-constructor-code-type (type generator)
-  (let ((old-entry (assq type *constructor-code-types*)))
-    (if old-entry 
-	(setf (cadr old-entry) generator)
-	(push (list type generator) *constructor-code-types*))
-    type))
-
-(defmethod make-constructor-code-generators
-	   ((class slot-class)
-	    name lambda-list supplied-initarg-names supplied-initargs)
-  (cons 'list
-	(gathering1 (collecting)
-	  (dolist (entry *constructor-code-types*)
-	    (let ((generator
-		    (funcall (cadr entry) class name lambda-list 
-					  supplied-initarg-names
-					  supplied-initargs)))
-	      (when generator
-		(gather1 `',(car entry))
-		(gather1 generator)))))))
-
-(defmethod compute-constructor-code ((class slot-class)
-				     (constructor constructor))
-  (let* ((proto (class-prototype class))
-	 (wrapper (class-wrapper class))
-	 (defaults (class-default-initargs class))
-         (make
-           (compute-applicable-methods (gdefinition 'make-instance) (list class)))
-	 (supplied-initarg-names
-	   (constructor-supplied-initarg-names constructor))
-         (default
-	   (compute-applicable-methods (gdefinition 'default-initargs)
-				       (list class supplied-initarg-names))) ;?
-         (allocate
-           (compute-applicable-methods (gdefinition 'allocate-instance)
-				       (list class)))
-         (initialize
-           (compute-applicable-methods (gdefinition 'initialize-instance)
-				       (list proto)))
-         (shared
-           (compute-applicable-methods (gdefinition 'shared-initialize)
-				       (list proto t)))
-	 (code-generators
-	   (constructor-code-generators constructor)))
-    (flet ((call-code-generator (generator)
-	     (when (null generator)
-	       (unless (setq generator (getf code-generators 'fallback))
-		 (error "No FALLBACK generator?")))
-	     (funcall generator class wrapper defaults initialize shared)))
-      (if (or (cdr make)
-	      (cdr default)
-	      (cdr allocate)
-	      (not (check-initargs-1 class
-				     supplied-initarg-names
-				     (append initialize shared)
-				     nil nil)))
-	  ;; These are basic shared assumptions, if one of the
-	  ;; has been violated, we have to resort to the fallback
-	  ;; case.  Any of these assumptions could be moved out
-	  ;; of here and into the individual code types if there
-	  ;; was a need to do so.
-	  (values (call-code-generator nil) 'fallback)
-	  ;; Otherwise try all the generators until one produces
-	  ;; code for us.
-	  (doplist (type generator) code-generators
-	    (let ((code (call-code-generator generator)))
-	      (when code (return (values code type)))))))))
-
-;;;
-;;; The facilities are useful for debugging, and to measure the performance
-;;; boost from constructors.
-;;; 
-
-(defun map-constructors (fn)
-  (let ((nclasses 0)
-	(nconstructors 0))
-    (labels ((recurse (class)
-	       (incf nclasses)
-	       (dolist (constructor (class-constructors class))
-		 (incf nconstructors)
-		 (funcall fn constructor))
-	       (dolist (subclass (class-direct-subclasses class))
-		 (recurse subclass))))
-      (recurse (find-class 't))
-      (values nclasses nconstructors))))
-
-(defun reset-constructors ()
-  (multiple-value-bind (nclass ncons)
-      (map-constructors #'install-lazy-constructor-installer )
-    (format t "~&~D classes, ~D constructors." nclass ncons)))
-
-(defun disable-constructors ()
-  (multiple-value-bind (nclass ncons)
-      (map-constructors
-	#'(lambda (c)
-	    (let ((gen (getf (constructor-code-generators c) 'fallback)))
-	      (if (null gen)
-		  (error "No fallback constructor for ~S." c)
-		  (set-constructor-code c
-					(funcall gen
-						 (constructor-class c)
-						 () () () ())
-					'fallback)))))
-    (format t "~&~D classes, ~D constructors." nclass ncons)))
-
-(defun enable-constructors ()
-  (reset-constructors))
-
-
-;;;
-;;; Helper functions and utilities that are shared by all of the code types
-;;; and by the main compute-constructor-code method as well.
-;;; 
-
-(defvar *standard-initialize-instance-method*
-        (get-method #'initialize-instance
-		    ()
-		    (list *the-class-slot-object*)))
-
-(defvar *standard-shared-initialize-method*
-        (get-method #'shared-initialize
-		    ()
-		    (list *the-class-slot-object* *the-class-t*)))
-
-(defun non-pcl-initialize-instance-methods-p (methods)
-  (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*))
-	    methods))
-
-(defun non-pcl-shared-initialize-methods-p (methods)
-  (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*))
-	    methods))
-
-(defun non-pcl-or-after-initialize-instance-methods-p (methods)
-  (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*)
-			      (equal '(:after) (method-qualifiers m))))
-	    methods))
-
-(defun non-pcl-or-after-shared-initialize-methods-p (methods)
-  (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*)
-			      (equal '(:after) (method-qualifiers m))))
-	    methods))
-
-;;;
-;;; This returns two values.  The first is a vector which can be used as the
-;;; initial value of the slots vector for the instance. The second is a symbol
-;;; describing the initforms this class has.  
-;;;
-;;;  If the first value is:
-;;;
-;;;    :unsupplied    no slot has an initform
-;;;    :constants     all slots have either a constant initform
-;;;                   or no initform at all
-;;;    t              there is at least one non-constant initform
-;;; 
-(defun compute-constant-vector (class)
-  ;;(declare (values constants flag))
-  (let* ((wrapper (class-wrapper class))
-	 (layout (wrapper-instance-slots-layout wrapper))
-	 (flag :unsupplied)
-	 (constants ()))
-    (dolist (slotd (class-slots class))
-      (let ((name (slot-definition-name slotd))
-	    (initform (slot-definition-initform slotd))
-	    (initfn (slot-definition-initfunction slotd)))
-	(cond ((null (memq name layout)))
-	      ((null initfn)
-	       (push (cons name *slot-unbound*) constants))
-	      ((constantp initform)
-	       (push (cons name (eval initform)) constants)
-	       (when (eq flag ':unsupplied) (setq flag ':constants)))
-	      (t
-	       (push (cons name *slot-unbound*) constants)
-	       (setq flag 't)))))
-    (let* ((constants-alist (sort constants #'(lambda (x y)
-						(memq (car y)
-						      (memq (car x) layout)))))
-	   (constants-list (mapcar #'cdr constants-alist)))
-    (values constants-list flag))))
-
-
-;;;
-;;; This takes a class and a list of initarg-names, and returns an alist
-;;; indicating the positions of the slots those initargs may fill.  The
-;;; order of the initarg-names argument is important of course, since we
-;;; have to respect the rules about the leftmost initarg that fills a slot
-;;; having precedence.  This function allows initarg names to appear twice
-;;; in the list, it only considers the first appearance.
-;;;
-(defun compute-initarg-positions (class initarg-names)
-  (let* ((layout (wrapper-instance-slots-layout (class-wrapper class)))
-	 (positions
-	   (gathering1 (collecting)
-	     (iterate ((slot-name (list-elements layout))
-		       (position (interval :from 0)))
-	       (gather1 (cons slot-name position)))))
-	 (slot-initargs
-	   (mapcar #'(lambda (slotd)
-		       (list (slot-definition-initargs slotd)
-			     (or (cdr (assq (slot-definition-name slotd) positions))
-				 ':class)))
-		   (class-slots class))))
-    ;; Go through each of the initargs, and figure out what position
-    ;; it fills by replacing the entries in slot-initargs it fills.
-    (dolist (initarg initarg-names)
-      (dolist (slot-entry slot-initargs)
-	(let ((slot-initargs (car slot-entry)))
-	  (when (and (listp slot-initargs)
-		     (not (null slot-initargs))
-		     (memq initarg slot-initargs))
-	    (setf (car slot-entry) initarg)))))
-    (gathering1 (collecting)
-      (dolist (initarg initarg-names)
-	(let ((positions (gathering1 (collecting)
-			   (dolist (slot-entry slot-initargs)
-			     (when (eq (car slot-entry) initarg)
-			       (gather1 (cadr slot-entry)))))))
-	  (when positions
-	    (gather1 (cons initarg positions))))))))
-
-
-;;;
-;;; The FALLBACK case allows anything.  This always works, and always appears
-;;; as the last of the generators for a constructor.  It does a full call to
-;;; make-instance.
-;;;
-
-(define-constructor-code-type fallback
-        (class name arglist supplied-initarg-names supplied-initargs)
-  (declare (ignore name supplied-initarg-names))
-  `(function
-     (lambda (&rest ignore)
-       (declare (ignore ignore))
-       (function
-	 (lambda ,arglist
-	   (make-instance
-	     ',(class-name class)
-	     ,@(gathering1 (collecting)
-		 (iterate ((tail (*list-tails supplied-initargs :by #'cddr)))
-		   (gather1 `',(car tail))
-		   (gather1 (cadr tail))))))))))
-
-;;;
-;;; The GENERAL case allows:
-;;;   constant, unsupplied or non-constant initforms
-;;;   constant or non-constant default initargs
-;;;   supplied initargs
-;;;   slot-filling initargs
-;;;   :after methods on shared-initialize and initialize-instance
-;;;   
-(define-constructor-code-type general
-        (class name arglist supplied-initarg-names supplied-initargs)
-  (declare (ignore name))
-  (let ((raw-allocator (raw-instance-allocator class))
-	(slots-fetcher (slots-fetcher class)))
-    `(function
-       (lambda (class .wrapper. defaults init shared)
-	 (multiple-value-bind (.constants.
-			       .constant-initargs.
-			       .initfns-initargs-and-positions.
-			       .supplied-initarg-positions.
-			       .shared-initfns.
-			       .initfns.)
-	     (general-generator-internal class
-					 defaults
-					 init
-					 shared
-					 ',supplied-initarg-names
-					 ',supplied-initargs)
-	   .supplied-initarg-positions.
-	   (when (and .constants.
-		      (null (non-pcl-or-after-initialize-instance-methods-p
-			      init))
-		      (null (non-pcl-or-after-shared-initialize-methods-p
-			      shared)))
-	     (function
-	       (lambda ,arglist
-		 (declare #.*optimize-speed*)
-		 (let* ((.instance. (,raw-allocator .wrapper. .constants.))
-			(.slots. (,slots-fetcher .instance.))
-			(.positions. .supplied-initarg-positions.)
-			(.initargs. .constant-initargs.))		   
-		   .positions.
-		   
-		   (dolist (entry .initfns-initargs-and-positions.)
-		     (let ((val (funcall (car entry)))
-			   (initarg (cadr entry)))
-		       (when initarg
-			 (push val .initargs.)
-			 (push initarg .initargs.))
-		       (dolist (pos (cddr entry))
-			 (setf (%instance-ref .slots. pos) val))))
-
-		   ,@(gathering1 (collecting)
-		       (doplist (initarg value) supplied-initargs
-			 (unless (constantp value)
-			   (gather1 `(let ((.value. ,value))
-				       (push .value. .initargs.)
-				       (push ',initarg .initargs.)
-				       (dolist (.p. (pop .positions.))
-					 (setf (%instance-ref .slots. .p.)
-					       .value.)))))))
-
-		   (dolist (fn .shared-initfns.)
-		     (apply fn .instance. t .initargs.))
-		   (dolist (fn .initfns.)
-		     (apply fn .instance. .initargs.))
-		     
-		   .instance.)))))))))
-
-(defun general-generator-internal
-       (class defaults init shared supplied-initarg-names supplied-initargs)
-  (flet ((bail-out () (return-from general-generator-internal nil)))
-    (let* ((constants (compute-constant-vector class))
-	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
-	   (initarg-positions
-	     (compute-initarg-positions class
-					(append supplied-initarg-names
-						(mapcar #'car defaults))))
-	   (initfns-initargs-and-positions ())
-	   (supplied-initarg-positions ())
-	   (constant-initargs ())
-	   (used-positions ()))
-					       
-      ;;
-      ;; Go through each of the supplied initargs for three reasons.
-      ;;
-      ;;   - If it fills a class slot, bail out.
-      ;;   - If its a constant form, fill the constant vector.
-      ;;   - Otherwise remember the positions no two initargs
-      ;;     will try to fill the same position, since compute
-      ;;     initarg positions already took care of that, but
-      ;;     we do need to know what initforms will and won't
-      ;;     be needed.
-      ;;   
-      (doplist (initarg val) supplied-initargs
-	(let ((positions (cdr (assq initarg initarg-positions))))
-	  (cond ((memq :class positions) (bail-out))
-		((constantp val)
-		 (setq val (eval val))
-		 (push val constant-initargs)
-		 (push initarg constant-initargs)
-		 (dolist (pos positions) (setf (svref constants pos) val)))
-		(t
-		 (push positions supplied-initarg-positions)))
-	  (setq used-positions (append positions used-positions))))
-      ;;
-      ;; Go through each of the default initargs, for three reasons.
-      ;;
-      ;;   - If it fills a class slot, bail out.
-      ;;   - If it is a constant, and it does fill a slot, put that
-      ;;     into the constant vector.
-      ;;   - If it isn't a constant, record its initfn and position.
-      ;;   
-      (dolist (default defaults)
-	(let* ((name (car default))
-	       (initfn (cadr default))
-	       (form (caddr default))
-	       (value ())
-	       (positions (cdr (assq name initarg-positions))))
-	  (unless (memq name supplied-initarg-names)
-	    (cond ((memq :class positions) (bail-out))
-		  ((constantp form)
-		   (setq value (eval form))
-		   (push value constant-initargs)
-		   (push name constant-initargs)
-		   (dolist (pos positions)
-		     (setf (svref constants pos) value)))
-		  (t
-		   (push (list* initfn name positions)
-			 initfns-initargs-and-positions)))
-	    (setq used-positions (append positions used-positions)))))
-      ;;
-      ;; Go through each of the slot initforms:
-      ;;
-      ;;    - If its position has already been filled, do nothing.
-      ;;      The initfn won't need to be called, and the slot won't
-      ;;      need to be touched.
-      ;;    - If it is a class slot, and has an initform, bail out.
-      ;;    - If its a constant or unsupplied, ignore it, it is
-      ;;      already in the constant vector.
-      ;;    - Otherwise, record its initfn and position
-      ;;
-      (dolist (slotd (class-slots class))
-	(let* ((alloc (slot-definition-allocation slotd))
-	       (name (slot-definition-name slotd))
-	       (form (slot-definition-initform slotd))
-	       (initfn (slot-definition-initfunction slotd))
-	       (position (position name layout)))
-	  (cond ((neq alloc :instance)
-		 (unless (null initfn)
-		   (bail-out)))
-		((member position used-positions))
-		((or (constantp form)
-		     (null initfn)))
-		(t
-		 (push (list initfn nil position)
-		       initfns-initargs-and-positions)))))
-
-      (values constants
-	      constant-initargs
-	      (nreverse initfns-initargs-and-positions)
-	      (nreverse supplied-initarg-positions)
-	      (mapcar #'method-function
-		      (remove *standard-shared-initialize-method* shared))
-	      (mapcar #'method-function
-		      (remove *standard-initialize-instance-method* init))))))
-
-
-;;;
-;;; The NO-METHODS case allows:
-;;;   constant, unsupplied or non-constant initforms
-;;;   constant or non-constant default initargs
-;;;   supplied initargs that are arguments to constructor, or constants
-;;;   slot-filling initargs
-;;;
-
-(define-constructor-code-type no-methods
-        (class name arglist supplied-initarg-names supplied-initargs)
-  (declare (ignore name))
-  (let ((raw-allocator (raw-instance-allocator class))
-	(slots-fetcher (slots-fetcher class)))
-    `(function
-       (lambda (class .wrapper. defaults init shared)
-	 (multiple-value-bind (.constants.
-			       .initfns-and-positions.
-			       .supplied-initarg-positions.)
-	     (no-methods-generator-internal class
-					    defaults
-					    ',supplied-initarg-names
-					    ',supplied-initargs)
-	   .initfns-and-positions.
-	   .supplied-initarg-positions.
-	   (when (and .constants.
-		      (null (non-pcl-initialize-instance-methods-p init))
-		      (null (non-pcl-shared-initialize-methods-p shared)))
-	     #'(lambda ,arglist
-		 (declare #.*optimize-speed*)
-		 (let* ((.instance. (,raw-allocator .wrapper. .constants.))
-			(.slots. (,slots-fetcher .instance.))
-			(.positions. .supplied-initarg-positions.))
-		   .positions.
-
-		   (dolist (entry .initfns-and-positions.)
-		     (let ((val (funcall (car entry))))
-		       (dolist (pos (cdr entry))
-			 (setf (%instance-ref .slots. pos) val))))
-		 
-		   ,@(gathering1 (collecting)
-		       (doplist (initarg value) supplied-initargs
-			 (unless (constantp value)
-			   (gather1
-			     `(let ((.value. ,value))
-				(dolist (.p. (pop .positions.))
-				  (setf (%instance-ref .slots. .p.) .value.)))))))
-		     
-		   .instance.))))))))
-
-(defun no-methods-generator-internal
-       (class defaults supplied-initarg-names supplied-initargs)
-  (flet ((bail-out () (return-from no-methods-generator-internal nil)))
-    (let* ((constants	(compute-constant-vector class))
-	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
-	   (initarg-positions
-	     (compute-initarg-positions class
-					(append supplied-initarg-names
-						(mapcar #'car defaults))))
-	   (initfns-and-positions ())
-	   (supplied-initarg-positions ())
-	   (used-positions ()))
-      ;;
-      ;; Go through each of the supplied initargs for three reasons.
-      ;;
-      ;;   - If it fills a class slot, bail out.
-      ;;   - If its a constant form, fill the constant vector.
-      ;;   - Otherwise remember the positions, no two initargs
-      ;;     will try to fill the same position, since compute
-      ;;     initarg positions already took care of that, but
-      ;;     we do need to know what initforms will and won't
-      ;;     be needed.
-      ;;   
-      (doplist (initarg val) supplied-initargs
-	(let ((positions (cdr (assq initarg initarg-positions))))
-	  (cond ((memq :class positions) (bail-out))
-		((constantp val)
-		 (setq val (eval val))
-		 (dolist (pos positions)
-		   (setf (svref constants pos) val)))
-		(t
-		 (push positions supplied-initarg-positions)))
-	  (setq used-positions (append positions used-positions))))
-      ;;
-      ;; Go through each of the default initargs, for three reasons.
-      ;;
-      ;;   - If it fills a class slot, bail out.
-      ;;   - If it is a constant, and it does fill a slot, put that
-      ;;     into the constant vector.
-      ;;   - If it isn't a constant, record its initfn and position.
-      ;;   
-      (dolist (default defaults)
-	(let* ((name (car default))
-	       (initfn (cadr default))
-	       (form (caddr default))
-	       (value ())
-	       (positions (cdr (assq name initarg-positions))))
-	  (unless (memq name supplied-initarg-names)
-	    (cond ((memq :class positions) (bail-out))
-		  ((constantp form)
-		   (setq value (eval form))
-		   (dolist (pos positions)
-		     (setf (svref constants pos) value)))
-		  (t
-		   (push (cons initfn positions)
-			 initfns-and-positions)))
-	    (setq used-positions (append positions used-positions)))))
-      ;;
-      ;; Go through each of the slot initforms:
-      ;;
-      ;;    - If its position has already been filled, do nothing.
-      ;;      The initfn won't need to be called, and the slot won't
-      ;;      need to be touched.
-      ;;    - If it is a class slot, and has an initform, bail out.
-      ;;    - If its a constant or unsupplied, do nothing, we know
-      ;;      that it is already in the constant vector.
-      ;;    - Otherwise, record its initfn and position
-      ;;
-      (dolist (slotd (class-slots class))
-	(let* ((alloc (slot-definition-allocation slotd))
-	       (name (slot-definition-name slotd))
-	       (form (slot-definition-initform slotd))
-	       (initfn (slot-definition-initfunction slotd))
-	       (position (position name layout)))
-	  (cond ((neq alloc :instance)
-		 (unless (null initfn)
-		   (bail-out)))
-		((member position used-positions))
-		((or (constantp form)
-		     (null initfn)))
-		(t
-		 (push (list initfn position) initfns-and-positions)))))
-
-      (values constants
-	      (nreverse initfns-and-positions)
-	      (nreverse supplied-initarg-positions)))))
-
-
-;;;
-;;; The SIMPLE-SLOTS case allows:
-;;;   constant or unsupplied initforms
-;;;   constant default initargs
-;;;   supplied initargs
-;;;   slot filling initargs
-;;;
-
-(define-constructor-code-type simple-slots
-        (class name arglist supplied-initarg-names supplied-initargs)
-  (declare (ignore name))
-  (let ((raw-allocator (raw-instance-allocator class))
-	(slots-fetcher (slots-fetcher class)))
-    `(function
-       (lambda (class .wrapper. defaults init shared)
-	 (when (and (null (non-pcl-initialize-instance-methods-p init))
-		    (null (non-pcl-shared-initialize-methods-p shared)))
-	   (multiple-value-bind (.constants. .supplied-initarg-positions.)
-	       (simple-slots-generator-internal class
-						defaults
-						',supplied-initarg-names
-						',supplied-initargs)
-	     (when .constants.
-	       (function
-		 (lambda ,arglist
-		   (declare #.*optimize-speed*)
-		   (let* ((.instance. (,raw-allocator .wrapper. .constants.))
-			  (.slots. (,slots-fetcher .instance.))
-			  (.positions. .supplied-initarg-positions.))
-		     .positions.
-		 
-		     ,@(gathering1 (collecting)
-			 (doplist (initarg value) supplied-initargs
-			   (unless (constantp value)
-			     (gather1
-			       `(let ((.value. ,value))
-				  (dolist (.p. (pop .positions.))
-				    (setf (%instance-ref .slots. .p.) .value.)))))))
-		     
-		     .instance.))))))))))
-
-(defun simple-slots-generator-internal
-       (class defaults supplied-initarg-names supplied-initargs)
-  (flet ((bail-out () (return-from simple-slots-generator-internal nil)))
-    (let* ((constants (compute-constant-vector class))
-	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
-	   (initarg-positions
-	     (compute-initarg-positions class
-					(append supplied-initarg-names
-						(mapcar #'car defaults))))
-	   (supplied-initarg-positions ())
-	   (used-positions ()))
-      ;;
-      ;; Go through each of the supplied initargs for three reasons.
-      ;;
-      ;;   - If it fills a class slot, bail out.
-      ;;   - If its a constant form, fill the constant vector.
-      ;;   - Otherwise remember the positions, no two initargs
-      ;;     will try to fill the same position, since compute
-      ;;     initarg positions already took care of that, but
-      ;;     we do need to know what initforms will and won't
-      ;;     be needed.
-      ;;   
-      (doplist (initarg val) supplied-initargs
-	(let ((positions (cdr (assq initarg initarg-positions))))
-	  (cond ((memq :class positions) (bail-out))
-		((constantp val)
-		 (setq val (eval val))
-		 (dolist (pos positions)
-		   (setf (svref constants pos) val)))
-		(t
-		 (push positions supplied-initarg-positions)))
-	  (setq used-positions (append used-positions positions))))
-      ;;
-      ;; Go through each of the default initargs for three reasons.
-      ;; 
-      ;;   - If it isn't a constant form, bail out.
-      ;;   - If it fills a class slot, bail out.
-      ;;   - If it is a constant, and it does fill a slot, put that
-      ;;     into the constant vector.
-      ;;   
-      (dolist (default defaults)
-	(let* ((name (car default))
-	       (form (caddr default))
-	       (value ())
-	       (positions (cdr (assq name initarg-positions))))
-	  (unless (memq name supplied-initarg-names)
-	    (cond ((memq :class positions) (bail-out))
-		  ((not (constantp form))
-		   (bail-out))
-		  (t
-		   (setq value (eval form))
-		   (dolist (pos positions)
-		     (setf (svref constants pos) value)))))))
-      ;;
-      ;; Go through each of the slot initforms:
-      ;;
-      ;;    - If its position has already been filled, do nothing.
-      ;;      The initfn won't need to be called, and the slot won't
-      ;;      need to be touched, we are OK.
-      ;;    - If it has a non-constant initform, bail-out.  This
-      ;;      case doesn't handle those.
-      ;;    - If it has a constant or unsupplied initform we don't
-      ;;      really need to do anything, the value is in the
-      ;;      constants vector.
-      ;;
-      (dolist (slotd (class-slots class))
-	(let* ((alloc (slot-definition-allocation slotd))
-	       (name (slot-definition-name slotd))
-	       (form (slot-definition-initform slotd))
-	       (initfn (slot-definition-initfunction slotd))
-	       (position (position name layout)))
-	  (cond ((neq alloc :instance)
-		 (unless (null initfn)
-		   (bail-out)))
-		((member position used-positions))
-		((or (constantp form)
-		     (null initfn)))
-		(t
-		 (bail-out)))))
-      
-      (values constants (nreverse supplied-initarg-positions)))))
-
diff --git a/pcl/coral-low.lisp b/pcl/coral-low.lisp
deleted file mode 100644
index 650dd7517ba49abee36e6ce866c2a149dcef0910..0000000000000000000000000000000000000000
--- a/pcl/coral-low.lisp
+++ /dev/null
@@ -1,63 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-#-:ccl-1.3
-(ccl::add-transform 'std-instance-p 
-                     :inline 
-                     #'(lambda (call)
-                         (ccl::verify-arg-count call 1 1)
-                         (let ((arg (cadr call)))
-                           `(and (eq (ccl::%type-of ,arg) 'structure)
-                                 (eq (%svref ,arg 0) 'std-instance)))))
-
-(eval-when (eval compile load)
-  (proclaim '(inline std-instance-p)))
-
-(defun printing-random-thing-internal (thing stream)
-  (prin1 (ccl::%ptr-to-int thing) stream))
-
-(defun set-function-name-1 (function new-name uninterned-name)
-  (declare (ignore uninterned-name))
-  (cond ((ccl::lfunp function)
-         (ccl::lfun-name function new-name)))
-  function)
-
-
-(defun doctor-dfun-for-the-debugger (gf dfun)
-  #+:ccl-1.3
-  (let* ((gfspec (and (symbolp (generic-function-name gf))
-		      (generic-function-name gf)))
-	 (arglist (generic-function-pretty-arglist gf)))
-    (when gfspec
-      (setf (get gfspec 'ccl::%lambda-list)
-	    (if (and arglist (listp arglist))
-		(format nil "~{~A~^ ~}" arglist)
-		(format nil "~:A" arglist)))))
-  dfun)
-
diff --git a/pcl/cpatch.lisp b/pcl/cpatch.lisp
deleted file mode 100644
index 23641de54edc5fea9b4e3a6a12ca6844d8a90af8..0000000000000000000000000000000000000000
--- a/pcl/cpatch.lisp
+++ /dev/null
@@ -1,32 +0,0 @@
-;;				-[Thu Feb 22 08:38:07 1990 by jkf]-
-;; cpatch.cl
-;;  compiler patch for the fast clos
-;;  
-;; copyright (c) 1990 Franz Inc.
-;;
-
-(in-package :comp)
-
-(def-quad-op tail-funcall qp-end-block
-  ;; u = (argcount function-object)
-  ;;
-  ;; does a tail call to the function-object given
-  ;; never returns
-  )
-
-(defun-in-runtime sys::copy-function (func))
-
-(in-package :hyperion)
-
-(def-quad-hyp r-tail-funcall comp::tail-funcall (u d quad)
-  ;; u = (argcount function)
-  ;;
-  (r-move-single-to-loc (treg-loc (car u)) *count-reg*)
-  (r-move-single-to-loc (treg-loc (cadr u)) *fcnin-reg*)
-  (re restore *zero-reg* *zero-reg*)
-  (re move.l `(d #.r-function-start-adj #.*fcnout-reg*) '#.*ctr2-reg*)
-  (re jmpl '(d 0 #.*ctr2-reg*) *zero-reg*)
-  (re nop))
-  
-  
-
diff --git a/pcl/cpl.lisp b/pcl/cpl.lisp
deleted file mode 100644
index 6d01615bb056e98554089e756886110e05782af6..0000000000000000000000000000000000000000
--- a/pcl/cpl.lisp
+++ /dev/null
@@ -1,313 +0,0 @@
-;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-;;;
-;;; compute-class-precedence-list
-;;;
-;;; Knuth section 2.2.3 has some interesting notes on this.
-;;; 
-;;; What appears here is basically the algorithm presented there.
-;;;
-;;; The key idea is that we use class-precedence-description (CPD) structures
-;;; to store the precedence information as we proceed.  The CPD structure for
-;;; a class stores two critical pieces of information:
-;;; 
-;;;  - a count of the number of "reasons" why the class can't go
-;;;    into the class precedence list yet.
-;;;    
-;;;  - a list of the "reasons" this class prevents others from
-;;;    going in until after it
-;;
-;;; A "reason" is essentially a single local precedence constraint.  If a
-;;; constraint between two classes arises more than once it generates more
-;;; than one reason.  This makes things simpler, linear, and isn't a problem
-;;; as long as we make sure to keep track of each instance of a "reason".
-;;;
-;;; This code is divided into three phases.
-;;; 
-;;;  - the first phase simply generates the CPD's for each of the class
-;;;    and its superclasses.  The remainder of the code will manipulate
-;;;    these CPDs rather than the class objects themselves.  At the end
-;;;    of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs
-;;;    of the direct superclasses of the class.
-;;;
-;;;  - the second phase folds all the local constraints into the CPD
-;;;    structure.  The CPD-COUNT of each CPD is built up, and the
-;;;    CPD-AFTER fields are augmented to include precedence constraints
-;;;    from the CPD-SUPERS field and from the order of classes in other
-;;;    CPD-SUPERS fields.
-;;;
-;;;    After this phase, the CPD-AFTER field of a class includes all the
-;;;    direct superclasses of the class plus any class that immediately
-;;;    follows the class in the direct superclasses of another.  There
-;;;    can be duplicates in this list.  The CPD-COUNT field is equal to
-;;;    the number of times this class appears in the CPD-AFTER field of
-;;;    all the other CPDs.
-;;;
-;;;  - In the third phase, classes are put into the precedence list one
-;;;    at a time, with only those classes with a CPD-COUNT of 0 being
-;;;    candidates for insertion.  When a class is inserted , every CPD
-;;;    in its CPD-AFTER field has its count decremented.
-;;;
-;;;    In the usual case, there is only one candidate for insertion at
-;;;    any point.  If there is more than one, the specified tiebreaker
-;;;    rule is used to choose among them.
-;;;    
-
-(defmethod compute-class-precedence-list ((root slot-class))
-  (compute-std-cpl root (class-direct-superclasses root)))
-
-(defstruct (class-precedence-description
-	     (:conc-name nil)
-	     (:print-function (lambda (obj str depth)
-				(declare (ignore depth))
-				(format str
-					"#<CPD ~S ~D>"
-					(class-name (cpd-class obj))
-					(cpd-count obj))))
-	     (:constructor make-cpd ()))
-  (cpd-class  nil)
-  (cpd-supers ())
-  (cpd-after  ())
-  (cpd-count  0))
-
-(defun compute-std-cpl (class supers)
-  (cond ((null supers)				;First two branches of COND
-	 (list class))				;are implementing the single
-	((null (cdr supers))			;inheritance optimization.
-	 (cons class
-	       (compute-std-cpl (car supers)
-				(class-direct-superclasses (car supers)))))
-	(t
-	 (multiple-value-bind (all-cpds nclasses)
-	     (compute-std-cpl-phase-1 class supers)
-	   (compute-std-cpl-phase-2 all-cpds)
-	   (compute-std-cpl-phase-3 class all-cpds nclasses)))))
-
-(defvar *compute-std-cpl-class->entry-table-size* 60)
-
-(defun compute-std-cpl-phase-1 (class supers)
-  (let ((nclasses 0)
-	(all-cpds ())
-	(table (make-hash-table :size *compute-std-cpl-class->entry-table-size*
-				:test #'eq)))
-    (declare (fixnum nclasses))
-    (labels ((get-cpd (c)
-	       (or (gethash c table)
-		   (setf (gethash c table) (make-cpd))))
-	     (walk (c supers)
-	       (if (forward-referenced-class-p c)
-		   (cpl-forward-referenced-class-error class c)
-		   (let ((cpd (get-cpd c)))
-		     (unless (cpd-class cpd)	;If we have already done this
-						;class before, we can quit.
-		       (setf (cpd-class cpd) c)
-		       (incf nclasses)
-		       (push cpd all-cpds)
-		       (setf (cpd-supers cpd) (mapcar #'get-cpd supers))
-		       (dolist (super supers)
-			 (walk super (class-direct-superclasses super))))))))
-      (walk class supers)
-      (values all-cpds nclasses))))
-
-(defun compute-std-cpl-phase-2 (all-cpds)
-  (dolist (cpd all-cpds)
-    (let ((supers (cpd-supers cpd)))
-      (when supers
-	(setf (cpd-after cpd) (nconc (cpd-after cpd) supers))
-	(incf (cpd-count (car supers)) 1)
-	(do* ((t1 supers t2)
-	      (t2 (cdr t1) (cdr t1)))
-	     ((null t2))
-	  (incf (cpd-count (car t2)) 2)
-	  (push (car t2) (cpd-after (car t1))))))))
-
-(defun compute-std-cpl-phase-3 (class all-cpds nclasses)
-  (let ((candidates ())
-	(next-cpd nil)
-	(rcpl ()))
-    ;;
-    ;; We have to bootstrap the collection of those CPD's that
-    ;; have a zero count.  Once we get going, we will maintain
-    ;; this list incrementally.
-    ;; 
-    (dolist (cpd all-cpds)
-      (when (zerop (cpd-count cpd)) (push cpd candidates)))
-
-    
-    (loop
-      (when (null candidates)
-	;;
-	;; If there are no candidates, and enough classes have been put
-	;; into the precedence list, then we are all done.  Otherwise
-	;; it means there is a consistency problem.
-	(if (zerop nclasses)
-	    (return (reverse rcpl))
-	    (cpl-inconsistent-error class all-cpds)))
-      ;;
-      ;; Try to find the next class to put in from among the candidates.
-      ;; If there is only one, its easy, otherwise we have to use the
-      ;; famous RPG tiebreaker rule.  There is some hair here to avoid
-      ;; having to call DELETE on the list of candidates.  I dunno if
-      ;; its worth it but what the hell.
-      ;; 
-      (setq next-cpd
-	    (if (null (cdr candidates))
-		(prog1 (car candidates)
-		       (setq candidates ()))
-		(block tie-breaker		      
-		  (dolist (c rcpl)
-		    (let ((supers (class-direct-superclasses c)))
-		      (if (memq (cpd-class (car candidates)) supers)
-			  (return-from tie-breaker (pop candidates))
-			  (do ((loc candidates (cdr loc)))
-			      ((null (cdr loc)))
-			    (let ((cpd (cadr loc)))
-			      (when (memq (cpd-class cpd) supers)
-				(setf (cdr loc) (cddr loc))
-				(return-from tie-breaker cpd))))))))))
-      (decf nclasses)
-      (push (cpd-class next-cpd) rcpl)
-      (dolist (after (cpd-after next-cpd))
-	(when (zerop (decf (cpd-count after)))
-	  (push after candidates))))))
-
-;;;
-;;; Support code for signalling nice error messages.
-;;;
-
-(defun cpl-error (class format-string &rest format-args)
-  (error "While computing the class precedence list of the class ~A.~%~A"
-	  (if (class-name class)
-	      (format nil "named ~S" (class-name class))
-	      class)
-	  (apply #'format nil format-string format-args)))
-	  
-
-(defun cpl-forward-referenced-class-error (class forward-class)
-  (flet ((class-or-name (class)
-	   (if (class-name class)
-	       (format nil "named ~S" (class-name class))
-	       class)))
-    (let ((names (mapcar #'class-or-name
-			 (cdr (find-superclass-chain class forward-class)))))
-      (cpl-error class
-		 "The class ~A is a forward referenced class.~@
-                  The class ~A is ~A."
-		 (class-or-name forward-class)
-		 (class-or-name forward-class)
-		 (if (null (cdr names))
-		     (format nil
-			     "a direct superclass of the class ~A"
-			     (class-or-name class))
-		     (format nil
-			     "reached from the class ~A by following~@
-                              the direct superclass chain through: ~A~
-                              ~%  ending at the class ~A"
-			     (class-or-name class)
-			     (format nil
-				     "~{~%  the class ~A,~}"
-				     (butlast names))
-			     (car (last names))))))))
-
-(defun find-superclass-chain (bottom top)
-  (labels ((walk (c chain)
-	     (if (eq c top)
-		 (return-from find-superclass-chain (nreverse chain))
-		 (dolist (super (class-direct-superclasses c))
-		   (walk super (cons super chain))))))
-    (walk bottom (list bottom))))
-
-
-(defun cpl-inconsistent-error (class all-cpds)
-  (let ((reasons (find-cycle-reasons all-cpds)))
-    (cpl-error class
-      "It is not possible to compute the class precedence list because~@
-       there ~A in the local precedence relations.~@
-       ~A because:~{~%  ~A~}."
-      (if (cdr reasons) "are circularities" "is a circularity")
-      (if (cdr reasons) "These arise" "This arises")
-      (format-cycle-reasons (apply #'append reasons)))))
-
-(defun format-cycle-reasons (reasons)
-  (flet ((class-or-name (cpd)
-	   (let ((class (cpd-class cpd)))
-	     (if (class-name class)
-		 (format nil "named ~S" (class-name class))
-		 class))))
-    (mapcar
-      #'(lambda (reason)
-	  (ecase (caddr reason)
-	    (:super
-	      (format
-		nil
-		"the class ~A appears in the supers of the class ~A"
-		(class-or-name (cadr reason))
-		(class-or-name (car reason))))
-	    (:in-supers
-	      (format
-		nil
-		"the class ~A follows the class ~A in the supers of the class ~A"
-		(class-or-name (cadr reason))
-		(class-or-name (car reason))
-		(class-or-name (cadddr reason))))))      
-      reasons)))
-
-(defun find-cycle-reasons (all-cpds)
-  (let ((been-here ())           ;List of classes we have visited.
-	(cycle-reasons ()))
-    
-    (labels ((chase (path)
-	       (if (memq (car path) (cdr path))
-		   (record-cycle (memq (car path) (nreverse path)))
-		   (unless (memq (car path) been-here)
-		     (push (car path) been-here)
-		     (dolist (after (cpd-after (car path)))
-		       (chase (cons after path))))))
-	     (record-cycle (cycle)
-	       (let ((reasons ()))
-		 (do* ((t1 cycle t2)
-		       (t2 (cdr t1) (cdr t1)))
-		      ((null t2))
-		   (let ((c1 (car t1))
-			 (c2 (car t2)))
-		     (if (memq c2 (cpd-supers c1))
-			 (push (list c1 c2 :super) reasons)
-			 (dolist (cpd all-cpds)
-			   (when (memq c2 (memq c1 (cpd-supers cpd)))
-			     (return
-			       (push (list c1 c2 :in-supers cpd) reasons)))))))
-		 (push (nreverse reasons) cycle-reasons))))
-      
-      (dolist (cpd all-cpds)
-	(unless (zerop (cpd-count cpd))
-	  (chase (list cpd))))
-
-      cycle-reasons)))
-
diff --git a/pcl/ctypes.lisp b/pcl/ctypes.lisp
deleted file mode 100644
index bd2c7a6d632a2275ebac8d49ab3299c13ac5c9cf..0000000000000000000000000000000000000000
--- a/pcl/ctypes.lisp
+++ /dev/null
@@ -1,45 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-;;;
-;;; The built-in method combination types as taken from page 1-31 of 88-002R.
-;;; Note that the STANDARD method combination type is defined by hand in the
-;;; file combin.lisp.
-;;;
-
-(define-method-combination +      :identity-with-one-argument t)
-(define-method-combination and    :identity-with-one-argument t)
-(define-method-combination append :identity-with-one-argument nil)
-(define-method-combination list   :identity-with-one-argument nil)
-(define-method-combination max    :identity-with-one-argument t)
-(define-method-combination min    :identity-with-one-argument t)
-(define-method-combination nconc  :identity-with-one-argument t)
-(define-method-combination or     :identity-with-one-argument t)
-(define-method-combination progn  :identity-with-one-argument t)
-
diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp
deleted file mode 100644
index 747be0110cacc562e7468f31b9d15eabe6c5eeba..0000000000000000000000000000000000000000
--- a/pcl/defclass.lisp
+++ /dev/null
@@ -1,460 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-;;;
-;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'.
-;;;
-;;; The original motiviation for this function was to deal with the bug in
-;;; the Genera compiler that prevents lambda expressions in top-level forms
-;;; other than DEFUN from being compiled.
-;;;
-;;; Now this function is used to grab other functionality as well.  This
-;;; includes:
-;;;   - Preventing the grouping of top-level forms.  For example, a
-;;;     DEFCLASS followed by a DEFMETHOD may not want to be grouped
-;;;     into the same top-level form.
-;;;   - Telling the programming environment what the pretty version
-;;;     of the name of this form is.  This is used by WARN.
-;;; 
-(defun make-top-level-form (name times form)
-  (flet ((definition-name ()
-	   (if (and (listp name)
-		    (memq (car name) '(defmethod defclass class method method-combination)))
-	       (format nil "~A~{ ~S~}"
-		       (capitalize-words (car name) ()) (cdr name))
-	       (format nil "~S" name))))
-    (definition-name)
-    #+Genera
-    (progn
-      #-Genera-Release-8
-      (let ((thunk-name (gensym "TOP-LEVEL-FORM")))
-	`(eval-when ,times
-	   (defun ,thunk-name ()
-	     (declare (sys:function-parent
-			,(cond ((listp name)
-				(case (first name)
-				  (defmethod `(method ,@(rest name)))
-				  (otherwise (second name))))
-			       (t name))
-			,(cond ((listp name)
-				(case (first name)
-				  ((defmethod defgeneric) 'defun)
-				  ((defclass) 'defclass)
-				  (otherwise (first name))))
-			       (t 'defun))))
-	     ,form)
-	   (,thunk-name)))
-      #+Genera-Release-8
-      `(compiler-let ((compiler:default-warning-function ',name))
-	 (eval-when ,times
-	   (funcall #'(lambda ()
-			(declare ,(cond ((listp name)
-					 (case (first name)
-					   ((defclass)
-					    `(sys:function-parent ,(second name) defclass))
-					   ((defmethod)
-					    `(sys:function-name (method ,@(rest name))))
-					   ((defgeneric)
-					    `(sys:function-name ,(second name)))
-					   (otherwise
-					     `(sys:function-name ,name))))
-					(t
-					 `(sys:function-name ,name))))
-			,form)))))
-    #+LCL3.0
-    `(compiler-let ((lucid::*compiler-message-string*
-		      (or lucid::*compiler-message-string*
-			  ,(definition-name))))
-       (eval-when ,times ,form))
-    #+cmu
-    (if (member 'compile times)
-        `(eval-when ,times ,form)
-        form)
-    #+kcl
-    (let* ((*print-pretty* nil)
-           (thunk-name (gensym (definition-name))))
-      (gensym "G") ; set the prefix back to something less confusing.
-      `(eval-when ,times
-         (defun ,thunk-name ()
-           ,form)
-         (,thunk-name)))
-    #-(or Genera LCL3.0 cmu kcl)
-    (make-progn `',name `(eval-when ,times ,form))))
-
-(defun make-progn (&rest forms)
-  (let ((progn-form nil))
-    (labels ((collect-forms (forms)
-	       (unless (null forms)
-		 (collect-forms (cdr forms))
-		 (if (and (listp (car forms))
-			  (eq (caar forms) 'progn))
-		     (collect-forms (cdar forms))
-		     (push (car forms) progn-form)))))
-      (collect-forms forms)
-      (cons 'progn progn-form))))
-
-
-
-;;; 
-;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed.
-;;; DEFCLASS always expands into a call to LOAD-DEFCLASS.  Until the meta-
-;;; braid is set up, LOAD-DEFCLASS has a special definition which simply
-;;; collects all class definitions up, when the metabraid is initialized it
-;;; is done from those class definitions.
-;;;
-;;; After the metabraid has been setup, and the protocol for defining classes
-;;; has been defined, the real definition of LOAD-DEFCLASS is installed by the
-;;; file defclass.lisp
-;;; 
-(defmacro DEFCLASS (name direct-superclasses direct-slots &rest options)
-  (declare (indentation 2 4 3 1))
-  (expand-defclass name direct-superclasses direct-slots options))
-
-(defun expand-defclass (name supers slots options)
-  (declare (special *defclass-times* *boot-state* *the-class-structure-class*))
-  (setq supers  (copy-tree supers)
-	slots   (copy-tree slots)
-	options (copy-tree options))
-  (let ((metaclass 'standard-class))
-    (dolist (option options)
-      (if (not (listp option))
-          (error "~S is not a legal defclass option." option)
-          (when (eq (car option) ':metaclass)
-            (unless (legal-class-name-p (cadr option))
-              (error "The value of the :metaclass option (~S) is not a~%~
-                      legal class name."
-                     (cadr option)))
-            (setq metaclass (cadr option))
-	    (setf options (remove option options))
-	    (return t))))
-
-    (let ((*initfunctions* ())
-          (*accessors* ())                         ;Truly a crock, but we got
-          (*readers* ())                           ;to have it to live nicely.
-          (*writers* ()))
-      (declare (special *initfunctions* *accessors* *readers* *writers*))
-      (let ((canonical-slots
-	      (mapcar #'(lambda (spec)
-			  (canonicalize-slot-specification name spec))
-		      slots))
-	    (other-initargs
-	      (mapcar #'(lambda (option)
-			  (canonicalize-defclass-option name option))
-		      options))
-	    (defstruct-p (and (eq *boot-state* 'complete)
-			      (let ((mclass (find-class metaclass nil)))
-				(and mclass
-				     (*subtypep mclass 
-						*the-class-structure-class*))))))
-	(do-standard-defsetfs-for-defclass *accessors*)
-        (let ((defclass-form 
-                 (make-top-level-form `(defclass ,name)
-                   (if defstruct-p '(load eval) *defclass-times*)
-		   `(progn
-		      ,@(mapcar #'(lambda (x)
-				    `(declaim (ftype (function (t) t) ,x)))
-				#+cmu *readers* #-cmu nil)
-		      ,@(mapcar #'(lambda (x)
-				    #-setf (when (consp x)
-					     (setq x (get-setf-function-name (cadr x))))
-				    `(declaim (ftype (function (t t) t) ,x)))
-				#+cmu *writers* #-cmu nil)
-		      (let ,(mapcar #'cdr *initfunctions*)
-			(load-defclass ',name
-				       ',metaclass
-				       ',supers
-				       (list ,@canonical-slots)
-				       (list ,@(apply #'append 
-						      (when defstruct-p
-							'(:from-defclass-p t))
-						      other-initargs))
-				       ',*accessors*))))))
-          (if defstruct-p
-              (progn
-                (eval defclass-form) ; define the class now, so that
-                `(progn              ; the defstruct can be compiled.
-                   ,(class-defstruct-form (find-class name))
-                   ,defclass-form))
-	      (progn
-		(when (and (eq *boot-state* 'complete)
-			   (not (member 'compile *defclass-times*)))
-		  (inform-type-system-about-std-class name))
-		defclass-form)))))))
-
-(defun make-initfunction (initform)
-  (declare (special *initfunctions*))
-  (cond ((or (eq initform 't)
-	     (equal initform ''t))
-	 '(function true))
-	((or (eq initform 'nil)
-	     (equal initform ''nil))
-	 '(function false))
-	((or (eql initform '0)
-	     (equal initform ''0))
-	 '(function zero))
-	(t
-	 (let ((entry (assoc initform *initfunctions* :test #'equal)))
-	   (unless entry
-	     (setq entry (list initform
-			       (gensym)
-			       `(function (lambda () ,initform))))
-	     (push entry *initfunctions*))
-	   (cadr entry)))))
-
-(defun canonicalize-slot-specification (class-name spec)
-  (declare (special *accessors* *readers* *writers*))
-  (cond ((and (symbolp spec)
-	      (not (keywordp spec))
-	      (not (memq spec '(t nil))))		   
-	 `'(:name ,spec))
-	((not (consp spec))
-	 (error "~S is not a legal slot specification." spec))
-	((null (cdr spec))
-	 `'(:name ,(car spec)))
-	((null (cddr spec))
-	 (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
-                 Convert it to ~S"
-		class-name spec (list (car spec) :initform (cadr spec))))
-	(t
-	 (let* ((name (pop spec))
-		(readers ())
-		(writers ())
-		(initargs ())
-		(unsupplied (list nil))
-		(initform (getf spec :initform unsupplied)))
-	   (doplist (key val) spec
-	     (case key
-	       (:accessor (push val *accessors*)
-			  (push val readers)
-			  (push `(setf ,val) writers))
-	       (:reader   (push val readers))
-	       (:writer   (push val writers))
-	       (:initarg  (push val initargs))))
-	   (loop (unless (remf spec :accessor) (return)))
-	   (loop (unless (remf spec :reader)   (return)))
-	   (loop (unless (remf spec :writer)   (return)))
-	   (loop (unless (remf spec :initarg)  (return)))
-           (setq *writers* (append writers *writers*))
-           (setq *readers* (append readers *readers*))
-	   (setq spec `(:name     ',name
-			:readers  ',readers
-			:writers  ',writers
-			:initargs ',initargs
-			',spec))
-	   (if (eq initform unsupplied)
-	       `(list* ,@spec)
-	       `(list* :initfunction ,(make-initfunction initform) ,@spec))))))
-						
-(defun canonicalize-defclass-option (class-name option)  
-  (declare (ignore class-name))
-  (case (car option)
-    (:default-initargs
-      (let ((canonical ()))
-	(let (key val (tail (cdr option)))
-	  (loop (when (null tail) (return nil))
-		(setq key (pop tail)
-		      val (pop tail))
-		(push ``(,',key ,,(make-initfunction val) ,',val) canonical))
-	  `(':direct-default-initargs (list ,@(nreverse canonical))))))
-    (otherwise
-      `(',(car option) ',(cdr option)))))
-
-
-;;;
-;;; This is the early definition of load-defclass.  It just collects up all
-;;; the class definitions in a list.  Later, in the file braid1.lisp, these
-;;; are actually defined.
-;;;
-
-
-;;;
-;;; Each entry in *early-class-definitions* is an early-class-definition.
-;;; 
-;;;
-(defparameter *early-class-definitions* ())
-
-(defun early-class-definition (class-name)
-  (or (find class-name *early-class-definitions* :key #'ecd-class-name)
-      (error "~S is not a class in *early-class-definitions*." class-name)))
-
-(defun make-early-class-definition
-       (name source metaclass
-	superclass-names canonical-slots other-initargs)
-  (list 'early-class-definition
-	name source metaclass
-	superclass-names canonical-slots other-initargs))
-  
-(defun ecd-class-name        (ecd) (nth 1 ecd))
-(defun ecd-source            (ecd) (nth 2 ecd))
-(defun ecd-metaclass         (ecd) (nth 3 ecd))
-(defun ecd-superclass-names  (ecd) (nth 4 ecd))
-(defun ecd-canonical-slots   (ecd) (nth 5 ecd))
-(defun ecd-other-initargs    (ecd) (nth 6 ecd))
-
-(defvar *early-class-slots* nil)
-
-(defun canonical-slot-name (canonical-slot)
-  (getf canonical-slot :name))
-
-(defun early-class-slots (class-name)
-  (cdr (or (assoc class-name *early-class-slots*)
-	   (let ((a (cons class-name
-			  (mapcar #'canonical-slot-name
-				  (early-collect-inheritance class-name)))))
-	     (push a *early-class-slots*)
-	     a))))
-
-(defun early-class-size (class-name)
-  (length (early-class-slots class-name)))
-
-(defun early-collect-inheritance (class-name)
-  ;;(declare (values slots cpl default-initargs direct-subclasses))
-  (let ((cpl (early-collect-cpl class-name)))
-    (values (early-collect-slots cpl)
-	    cpl
-	    (early-collect-default-initargs cpl)
-	    (gathering1 (collecting)
-	      (dolist (definition *early-class-definitions*)
-		(when (memq class-name (ecd-superclass-names definition))
-		  (gather1 (ecd-class-name definition))))))))
-
-(defun early-collect-slots (cpl)
-  (let* ((definitions (mapcar #'early-class-definition cpl))
-	 (super-slots (mapcar #'ecd-canonical-slots definitions))
-	 (slots (apply #'append (reverse super-slots))))
-    (dolist (s1 slots)
-      (let ((name1 (canonical-slot-name s1)))
-	(dolist (s2 (cdr (memq s1 slots)))
-	  (when (eq name1 (canonical-slot-name s2))
-	    (error "More than one early class defines a slot with the~%~
-                    name ~S.  This can't work because the bootstrap~%~
-                    object system doesn't know how to compute effective~%~
-                    slots."
-		   name1)))))
-    slots))
-
-(defun early-collect-cpl (class-name)
-  (labels ((walk (c)
-	     (let* ((definition (early-class-definition c))
-		    (supers (ecd-superclass-names definition)))
-	       (cons c
-		     (apply #'append (mapcar #'early-collect-cpl supers))))))
-    (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
-
-(defun early-collect-default-initargs (cpl)
-  (let ((default-initargs ()))
-    (dolist (class-name cpl)
-      (let* ((definition (early-class-definition class-name))
-	     (others (ecd-other-initargs definition)))
-	(loop (when (null others) (return nil))
-	      (let ((initarg (pop others)))
-		(unless (eq initarg :direct-default-initargs)
-		 (error "The defclass option ~S is not supported by the bootstrap~%~
-                        object system."
-			initarg)))
-	      (setq default-initargs
-		    (nconc default-initargs (reverse (pop others)))))))
-    (reverse default-initargs)))
-
-(defun bootstrap-slot-index (class-name slot-name)
-  (or (position slot-name (early-class-slots class-name))
-      (error "~S not found" slot-name)))
-
-;;;
-;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
-;;; the values of slots during bootstrapping.  During bootstrapping, there
-;;; are only two kinds of objects whose slots we need to access, CLASSes
-;;; and SLOT-DEFINITIONs.  The first argument to these functions tells whether the
-;;; object is a CLASS or a SLOT-DEFINITION.
-;;;
-;;; Note that the way this works it stores the slot in the same place in
-;;; memory that the full object system will expect to find it later.  This
-;;; is critical to the bootstrapping process, the whole changeover to the
-;;; full object system is predicated on this.
-;;;
-;;; One important point is that the layout of standard classes and standard
-;;; slots must be computed the same way in this file as it is by the full
-;;; object system later.
-;;; 
-(defmacro bootstrap-get-slot (type object slot-name)
-  `(instance-ref (get-slots ,object) (bootstrap-slot-index ,type ,slot-name)))
-
-(defun bootstrap-set-slot (type object slot-name new-value)
-  (setf (bootstrap-get-slot type object slot-name) new-value))
-
-(defun early-class-name (class)
-  (bootstrap-get-slot 'class class 'name))
-
-(defun early-class-precedence-list (class)
-  (bootstrap-get-slot 'pcl-class class 'class-precedence-list))
-
-(defun early-class-name-of (instance)
-  (early-class-name (class-of instance)))
-
-(defun early-class-slotds (class)
-  (bootstrap-get-slot 'slot-class class 'slots))
-
-(defun early-slot-definition-name (slotd)
-  (bootstrap-get-slot 'standard-effective-slot-definition slotd 'name))
-
-(defun early-slot-definition-location (slotd)
-  (bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
-
-(defun early-accessor-method-slot-name (method)
-  (bootstrap-get-slot 'standard-accessor-method method 'slot-name))
-
-(unless (fboundp 'class-name-of)
-  (setf (symbol-function 'class-name-of)
-	(symbol-function 'early-class-name-of)))
-  
-(defun early-class-direct-subclasses (class)
-  (bootstrap-get-slot 'class class 'direct-subclasses))
-
-(proclaim '(notinline load-defclass))
-(defun load-defclass
-       (name metaclass supers canonical-slots canonical-options accessor-names)
-  (setq supers  (copy-tree supers)
-	canonical-slots   (copy-tree canonical-slots)
-	canonical-options (copy-tree canonical-options))
-  (do-standard-defsetfs-for-defclass accessor-names)
-  (when (eq metaclass 'standard-class)
-    (inform-type-system-about-std-class name))
-  (let ((ecd
-	  (make-early-class-definition name
-				       (load-truename)
-				       metaclass
-				       supers
-				       canonical-slots
-				       canonical-options))
-	(existing
-	  (find name *early-class-definitions* :key #'ecd-class-name)))
-    (setq *early-class-definitions*
-	  (cons ecd (remove existing *early-class-definitions*)))
-    ecd))
-
diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp
deleted file mode 100644
index 61222ad446af7fe63573dc6594fcbff20596a0ff..0000000000000000000000000000000000000000
--- a/pcl/defcombin.lisp
+++ /dev/null
@@ -1,430 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-;;;
-;;; DEFINE-METHOD-COMBINATION
-;;;
-
-(defmacro define-method-combination (&whole form &rest args)
-  (declare (ignore args))
-  (if (and (cddr form)
-	   (listp (caddr form)))
-      (expand-long-defcombin form)
-      (expand-short-defcombin form)))
-
-
-;;;
-;;; STANDARD method combination
-;;;
-;;; The STANDARD method combination type is implemented directly by the class
-;;; STANDARD-METHOD-COMBINATION.  The method on COMPUTE-EFFECTIVE-METHOD does
-;;; standard method combination directly and is defined by hand in the file
-;;; combin.lisp.  The method for FIND-METHOD-COMBINATION must appear in this
-;;; file for bootstrapping reasons.
-;;;
-;;; A commented out copy of this definition appears in combin.lisp.
-;;; If you change this definition here, be sure to change it there
-;;; also.
-;;;
-(defmethod find-method-combination ((generic-function generic-function)
-				    (type (eql 'standard))
-				    options)
-  (when options
-    (method-combination-error
-      "The method combination type STANDARD accepts no options."))
-  *standard-method-combination*)
-
-
-
-;;;
-;;; short method combinations
-;;;
-;;; Short method combinations all follow the same rule for computing the
-;;; effective method.  So, we just implement that rule once.  Each short
-;;; method combination object just reads the parameters out of the object
-;;; and runs the same rule.
-;;;
-;;;
-(defclass short-method-combination (standard-method-combination)
-     ((operator
-	:reader short-combination-operator
-	:initarg :operator)
-      (identity-with-one-argument
-	:reader short-combination-identity-with-one-argument
-	:initarg :identity-with-one-argument))
-  (:predicate-name short-method-combination-p))
-
-(defun expand-short-defcombin (whole)
-  (let* ((type (cadr whole))
-	 (documentation
-	   (getf (cddr whole) :documentation ""))
-	 (identity-with-one-arg
-	   (getf (cddr whole) :identity-with-one-argument nil))
-	 (operator 
-	   (getf (cddr whole) :operator type)))
-    (make-top-level-form `(define-method-combination ,type)
-			 '(load eval)
-      `(load-short-defcombin
-	 ',type ',operator ',identity-with-one-arg ',documentation))))
-
-(defun load-short-defcombin (type operator ioa doc)
-  (let* ((truename (load-truename))
-	 (specializers
-	   (list (find-class 'generic-function)
-		 (intern-eql-specializer type)
-		 *the-class-t*))
-	 (old-method
-	   (get-method #'find-method-combination () specializers nil))
-	 (new-method nil))
-    (setq new-method
-	  (make-instance 'standard-method
-	    :qualifiers ()
-	    :specializers specializers
-	    :lambda-list '(generic-function type options)
-	    :function #'(lambda (gf type options)
-			  (declare (ignore gf))
-			  (do-short-method-combination
-			    type options operator ioa new-method doc))
-	    :definition-source `((define-method-combination ,type) ,truename)))
-    (when old-method
-      (remove-method #'find-method-combination old-method))
-    (add-method #'find-method-combination new-method)))
-
-(defun do-short-method-combination (type options operator ioa method doc)
-  (cond ((null options) (setq options '(:most-specific-first)))
-	((equal options '(:most-specific-first)))
-	((equal options '(:most-specific-last)))
-	(t
-	 (method-combination-error
-	   "Illegal options to a short method combination type.~%~
-            The method combination type ~S accepts one option which~%~
-            must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
-	   type)))
-  (make-instance 'short-method-combination
-		 :type type
-		 :options options
-		 :operator operator
-		 :identity-with-one-argument ioa
-		 :definition-source method
-		 :documentation doc))
-
-(defmethod compute-effective-method ((generic-function generic-function)
-				     (combin short-method-combination)
-				     applicable-methods)
-  (let ((type (method-combination-type combin))
-	(operator (short-combination-operator combin))
-	(ioa (short-combination-identity-with-one-argument combin))
-	(around ())
-	(primary ()))
-    (dolist (m applicable-methods)
-      (let ((qualifiers (method-qualifiers m)))
-	(flet ((lose (method why)
-		 (invalid-method-error
-		   method
-		   "The method ~S ~A.~%~
-                    The method combination type ~S was defined with the~%~
-                    short form of DEFINE-METHOD-COMBINATION and so requires~%~
-                    all methods have either the single qualifier ~S or the~%~
-                    single qualifier :AROUND."
-		   method why type type)))
-	  (cond ((null qualifiers)
-		 (lose m "has no qualifiers"))
-		((cdr qualifiers)
-		 (lose m "has more than one qualifier"))
-		((eq (car qualifiers) :around)
-		 (push m around))
-		((eq (car qualifiers) type)
-		 (push m primary))
-		(t
-		 (lose m "has an illegal qualifier"))))))
-    (setq around (nreverse around)
-	  primary (nreverse primary))
-    (let ((main-method
-	    (if (and (null (cdr primary))
-		     (not (null ioa)))
-		`(call-method ,(car primary) ())
-		`(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ()))
-				      primary)))))
-      (cond ((null primary)
-	     `(error "No ~S methods for the generic function ~S."
-		     ',type ',generic-function))
-	    ((null around) main-method)
-	    (t
-	     `(call-method ,(car around)
-			   (,@(cdr around) (make-method ,main-method))))))))
-
-
-;;;
-;;; long method combinations
-;;;
-;;;
-
-(defclass long-method-combination (standard-method-combination)
-     ((function :initarg :function
-		:reader long-method-combination-function)))
-
-(defun expand-long-defcombin (form)
-  (let ((type (cadr form))
-	(lambda-list (caddr form))
-	(method-group-specifiers (cadddr form))
-	(body (cddddr form))
-	(arguments-option ())
-	(gf-var nil))
-    (when (and (consp (car body)) (eq (caar body) :arguments))
-      (setq arguments-option (cdr (pop body))))
-    (when (and (consp (car body)) (eq (caar body) :generic-function))
-      (setq gf-var (cadr (pop body))))
-    (multiple-value-bind (documentation function)
-	(make-long-method-combination-function
-	  type lambda-list method-group-specifiers arguments-option gf-var
-	  body)
-      (make-top-level-form `(define-method-combination ,type)
-			   '(load eval)
-	`(load-long-defcombin ',type ',documentation #',function)))))
-
-(defvar *long-method-combination-functions* (make-hash-table :test #'eq))
-
-(defun load-long-defcombin (type doc function)
-  (let* ((specializers
-	   (list (find-class 'generic-function)
-		 (intern-eql-specializer type)
-		 *the-class-t*))
-	 (old-method
-	   (get-method #'find-method-combination () specializers nil))
-	 (new-method
-	   (make-instance 'standard-method
-	     :qualifiers ()
-	     :specializers specializers
-	     :lambda-list '(generic-function type options)
-	     :function #'(lambda (generic-function type options)
-			   (declare (ignore generic-function))
-			   (make-instance 'long-method-combination
-			     :type type
-			     :documentation doc
-			     :options options))
-	     :definition-source `((define-method-combination ,type)
-				  ,(load-truename)))))
-    (setf (gethash type *long-method-combination-functions*) function)
-    (when old-method (remove-method #'find-method-combination old-method))
-    (add-method #'find-method-combination new-method)))
-
-(defmethod compute-effective-method ((generic-function generic-function)
-				     (combin long-method-combination)
-				     applicable-methods)
-  (funcall (gethash (method-combination-type combin)
-		    *long-method-combination-functions*)
-	   generic-function
-	   combin
-	   applicable-methods))
-
-;;;
-;;;
-;;;
-(defun make-long-method-combination-function
-       (type ll method-group-specifiers arguments-option gf-var body)
-  ;;(declare (values documentation function))
-  (declare (ignore type))
-  (multiple-value-bind (documentation declarations real-body)
-      (extract-declarations body)
-
-    (let ((wrapped-body
-	    (wrap-method-group-specifier-bindings method-group-specifiers
-						  declarations
-						  real-body)))
-      (when gf-var
-	(push `(,gf-var .generic-function.) (cadr wrapped-body)))
-      
-      (when arguments-option
-	(setq wrapped-body (deal-with-arguments-option wrapped-body
-						       arguments-option)))
-
-      (when ll
-	(setq wrapped-body
-	      `(apply #'(lambda ,ll ,wrapped-body)
-		      (method-combination-options .method-combination.))))
-
-      (values
-	documentation
-	`(lambda (.generic-function. .method-combination. .applicable-methods.)
-	   (progn .generic-function. .method-combination. .applicable-methods.)
-	   (block .long-method-combination-function. ,wrapped-body))))))
-;;
-;; parse-method-group-specifiers parse the method-group-specifiers
-;;
-
-(defun wrap-method-group-specifier-bindings
-       (method-group-specifiers declarations real-body)
-  (with-gathering ((names (collecting))
-		   (specializer-caches (collecting))
-		   (cond-clauses (collecting))
-		   (required-checks (collecting))
-		   (order-cleanups (collecting)))
-      (dolist (method-group-specifier method-group-specifiers)
-	(multiple-value-bind (name tests description order required)
-	    (parse-method-group-specifier method-group-specifier)
-	  (declare (ignore description))
-	  (let ((specializer-cache (gensym)))
-	    (gather name names)
-	    (gather specializer-cache specializer-caches)
-	    (gather `((or ,@tests)
-		      (if  (equal ,specializer-cache .specializers.)
-			   (return-from .long-method-combination-function.
-			     '(error "More than one method of type ~S ~
-                                      with the same specializers."
-				     ',name))
-			   (setq ,specializer-cache .specializers.))
-		      (push .method. ,name))
-		    cond-clauses)
-	    (when required
-	      (gather `(when (null ,name)
-			 (return-from .long-method-combination-function.
-			   '(error "No ~S methods." ',name)))
-		      required-checks))
-	    (loop (unless (and (constantp order)
-			       (neq order (setq order (eval order))))
-		    (return t)))
-	    (gather (cond ((eq order :most-specific-first)
-			   `(setq ,name (nreverse ,name)))
-			  ((eq order :most-specific-last) ())
-			  (t
-			   `(ecase ,order
-			      (:most-specific-first
-				(setq ,name (nreverse ,name)))
-			      (:most-specific-last))))
-		    order-cleanups))))
-   `(let (,@names ,@specializer-caches)
-      ,@declarations
-      (dolist (.method. .applicable-methods.)
-	(let ((.qualifiers. (method-qualifiers .method.))
-	      (.specializers. (method-specializers .method.)))
-	  (progn .qualifiers. .specializers.)
-	  (cond ,@cond-clauses)))
-      ,@required-checks
-      ,@order-cleanups
-      ,@real-body)))
-   
-(defun parse-method-group-specifier (method-group-specifier)
-  ;;(declare (values name tests description order required))
-  (let* ((name (pop method-group-specifier))
-	 (patterns ())
-	 (tests 
-	   (gathering1 (collecting)
-	     (block collect-tests
-	       (loop
-		 (if (or (null method-group-specifier)
-			 (memq (car method-group-specifier)
-			       '(:description :order :required)))
-		     (return-from collect-tests t)
-		     (let ((pattern (pop method-group-specifier)))
-		       (push pattern patterns)
-		       (gather1 (parse-qualifier-pattern name pattern)))))))))
-    (values name
-	    tests
-	    (getf method-group-specifier :description
-		  (make-default-method-group-description patterns))
-	    (getf method-group-specifier :order :most-specific-first)
-	    (getf method-group-specifier :required nil))))
-
-(defun parse-qualifier-pattern (name pattern)
-  (cond ((eq pattern '()) `(null .qualifiers.))
-	((eq pattern '*) 't)
-	((symbolp pattern) `(,pattern .qualifiers.))
-	((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
-	(t (error "In the method group specifier ~S,~%~
-                   ~S isn't a valid qualifier pattern."
-		  name pattern))))
-
-(defun qualifier-check-runtime (pattern qualifiers)
-  (loop (cond ((and (null pattern) (null qualifiers))
-	       (return t))
-	      ((eq pattern '*) (return t))
-	      ((and pattern qualifiers (eq (car pattern) (car qualifiers)))
-	       (pop pattern)
-	       (pop qualifiers))	      
-	      (t (return nil)))))
-
-(defun make-default-method-group-description (patterns)
-  (if (cdr patterns)
-      (format nil
-	      "methods matching one of the patterns: ~{~S, ~} ~S"
-	      (butlast patterns) (car (last patterns)))
-      (format nil
-	      "methods matching the pattern: ~S"
-	      (car patterns))))
-
-
-
-;;;
-;;; This baby is a complete mess.  I can't believe we put it in this
-;;; way.  No doubt this is a large part of what drives MLY crazy.
-;;;
-;;; At runtime (when the effective-method is run), we bind an intercept
-;;; lambda-list to the arguments to the generic function.
-;;; 
-;;; At compute-effective-method time, the symbols in the :arguments
-;;; option are bound to the symbols in the intercept lambda list.
-;;;
-(defun deal-with-arguments-option (wrapped-body arguments-option)
-  (let* ((intercept-lambda-list
-	   (gathering1 (collecting)
-	     (dolist (arg arguments-option)
-	       (if (memq arg lambda-list-keywords)
-		   (gather1 arg)
-		   (gather1 (gensym))))))
-	 (intercept-rebindings
-	   (gathering1 (collecting)
-	     (iterate ((arg (list-elements arguments-option))
-		       (int (list-elements intercept-lambda-list)))
-	       (unless (memq arg lambda-list-keywords)
-		 (gather1 `(,arg ',int)))))))
-    ;;
-    ;;
-    (setf (cadr wrapped-body)
-	  (append intercept-rebindings (cadr wrapped-body)))
-    ;;
-    ;; Be sure to fill out the intercept lambda list so that it can
-    ;; be too short if it wants to.
-    ;; 
-    (cond ((memq '&rest intercept-lambda-list))
-	  ((memq '&allow-other-keys intercept-lambda-list))
-	  ((memq '&key intercept-lambda-list)
-	   (setq intercept-lambda-list
-		 (append intercept-lambda-list '(&allow-other-keys))))
-	  (t
-	   (setq intercept-lambda-list
-		 (append intercept-lambda-list '(&rest .ignore.)))))
-
-    `(let ((inner-result. ,wrapped-body))
-       `(apply #'(lambda ,',intercept-lambda-list
-		   ,,(when (memq '.ignore. intercept-lambda-list)
-		       ''(declare (ignore .ignore.)))
-		   ,inner-result.)
-	       .combined-method-args.))))
-
-
diff --git a/pcl/defs.lisp b/pcl/defs.lisp
deleted file mode 100644
index 348c1f9dc3d3934557beb04b4605ffa9970723b3..0000000000000000000000000000000000000000
--- a/pcl/defs.lisp
+++ /dev/null
@@ -1,891 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-(eval-when (compile load eval)
-  
-(defvar *defclass-times*   '(load eval))	;Probably have to change this
-						;if you use defconstructor.
-(defvar *defmethod-times*  '(load eval))
-(defvar *defgeneric-times* '(load eval))
-
-(defvar *boot-state* ())			;NIL
-						;EARLY
-						;BRAID
-						;COMPLETE
-(defvar *fegf-started-p* nil)
-
-
-)
-
-(eval-when (load eval)
-  (when (eq *boot-state* 'complete)
-    (error "Trying to load (or compile) PCL in an environment in which it~%~
-            has already been loaded.  This doesn't work, you will have to~%~
-            get a fresh lisp (reboot) and then load PCL."))
-  (when *boot-state*
-    (cerror "Try loading (or compiling) PCL anyways."
-	    "Trying to load (or compile) PCL in an environment in which it~%~
-             has already been partially loaded.  This may not work, you may~%~
-             need to get a fresh lisp (reboot) and then load PCL."))
-  )
-
-
-
-;;;
-;;; This is like fdefinition on the Lispm.  If Common Lisp had something like
-;;; function specs I wouldn't need this.  On the other hand, I don't like the
-;;; way this really works so maybe function specs aren't really right either?
-;;; 
-;;; I also don't understand the real implications of a Lisp-1 on this sort of
-;;; thing.  Certainly some of the lossage in all of this is because these
-;;; SPECs name global definitions.
-;;;
-;;; Note that this implementation is set up so that an implementation which
-;;; has a 'real' function spec mechanism can use that instead and in that way
-;;; get rid of setf generic function names.
-;;;
-(defmacro parse-gspec (spec
-		       (non-setf-var . non-setf-case)
-		       (setf-var . setf-case))
-  (declare (indentation 1 1))
-  (once-only (spec)
-    `(cond (#-setf (symbolp ,spec) #+setf t
-	    (let ((,non-setf-var ,spec)) ,@non-setf-case))
-	   #-setf
-	   ((and (listp ,spec)
-		 (eq (car ,spec) 'setf)
-		 (symbolp (cadr ,spec)))
-	    (let ((,setf-var (cadr ,spec))) ,@setf-case))
-	   #-setf
-	   (t
-	    (error
-	      "Can't understand ~S as a generic function specifier.~%~
-               It must be either a symbol which can name a function or~%~
-               a list like ~S, where the car is the symbol ~S and the cadr~%~
-               is a symbol which can name a generic function."
-	      ,spec '(setf <foo>) 'setf)))))
-
-;;;
-;;; If symbol names a function which is traced or advised, return the
-;;; unadvised, traced etc. definition.  This lets me get at the generic
-;;; function object even when it is traced.
-;;;
-(defun unencapsulated-fdefinition (symbol)
-  #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol))
-  #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol))
-  #+excl  (or (excl::encapsulated-basic-definition symbol)
-	      (symbol-function symbol))
-  #+xerox (il:virginfn symbol)
-  #+setf (fdefinition symbol)
-  #+kcl (symbol-function
-	  (let ((sym (get symbol 'si::traced)) first-form)
-	    (if (and sym
-		     (consp (symbol-function symbol))
-		     (consp (setq first-form (nth 3 (symbol-function symbol))))
-		     (eq (car first-form) 'si::trace-call))
-		sym
-		symbol)))
-  #-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol))
-
-;;;
-;;; If symbol names a function which is traced or advised, redefine
-;;; the `real' definition without affecting the advise.
-;;;
-(defun fdefine-carefully (name new-definition)
-  #+Lispm (si:fdefine name new-definition t t)
-  #+Lucid (let ((lucid::*redefinition-action* nil))
-	    (setf (symbol-function name) new-definition))
-  #+excl  (setf (symbol-function name) new-definition)
-  #+xerox (let ((advisedp (member name il:advisedfns :test #'eq))
-                (brokenp (member name il:brokenfns :test #'eq)))
-	    ;; In XeroxLisp (late of envos) tracing is implemented
-	    ;; as a special case of "breaking".  Advising, however,
-	    ;; is treated specially.
-            (xcl:unadvise-function name :no-error t)
-            (xcl:unbreak-function name :no-error t)
-            (setf (symbol-function name) new-definition)
-            (when brokenp (xcl:rebreak-function name))
-            (when advisedp (xcl:readvise-function name)))
-  #+(and setf (not cmu)) (setf (fdefinition name) new-definition)
-  #+kcl (setf (symbol-function 
-	       (let ((sym (get name 'si::traced)) first-form)
-		 (if (and sym
-			  (consp (symbol-function name))
-			  (consp (setq first-form
-				       (nth 3 (symbol-function name))))
-			  (eq (car first-form) 'si::trace-call))
-		     sym
-		     name)))
-	      new-definition)
-  #+cmu (progn
-	  (c::%%defun name new-definition nil)
-	  (c::note-name-defined name :function)
-	  new-definition)
-  #-(or Lispm Lucid excl Xerox setf kcl cmu)
-  (setf (symbol-function name) new-definition))
-
-(defun gboundp (spec)
-  (parse-gspec spec
-    (name (fboundp name))
-    (name (fboundp (get-setf-function-name name)))))
-
-(defun gmakunbound (spec)
-  (parse-gspec spec
-    (name (fmakunbound name))
-    (name (fmakunbound (get-setf-function-name name)))))
-
-(defun gdefinition (spec)
-  (parse-gspec spec
-    (name (or #-setf (macro-function name)		;??
-	      (unencapsulated-fdefinition name)))
-    (name (unencapsulated-fdefinition (get-setf-function-name name)))))
-
-(defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec)
-  (parse-gspec spec
-    (name (fdefine-carefully name new-value))
-    (name (fdefine-carefully (get-setf-function-name name) new-value))))
-
-
-(proclaim '(special *the-class-t* 
-	            *the-class-vector* *the-class-symbol*
-                    *the-class-string* *the-class-sequence*
-                    *the-class-rational* *the-class-ratio*
-                    *the-class-number* *the-class-null* *the-class-list*
-                    *the-class-integer* *the-class-float* *the-class-cons*
-                    *the-class-complex* *the-class-character*
-                    *the-class-bit-vector* *the-class-array*
-
-                    *the-class-slot-object*
-                    *the-class-standard-object*
-                    *the-class-structure-object*
-                    *the-class-class*
-                    *the-class-generic-function*
-                    *the-class-built-in-class*
-                    *the-class-slot-class*
-                    *the-class-structure-class*
-                    *the-class-standard-class*
-                    *the-class-funcallable-standard-class*
-                    *the-class-method*
-                    *the-class-standard-method*
-	            *the-class-standard-reader-method*
-	            *the-class-standard-writer-method*
-	            *the-class-standard-boundp-method*
-                    *the-class-standard-generic-function*
-                    *the-class-standard-effective-slot-definition*
-
-                    *the-eslotd-standard-class-slots*
-                    *the-eslotd-funcallable-standard-class-slots*))
-
-(proclaim '(special *the-wrapper-of-t*
-                    *the-wrapper-of-vector* *the-wrapper-of-symbol*
-                    *the-wrapper-of-string* *the-wrapper-of-sequence*
-                    *the-wrapper-of-rational* *the-wrapper-of-ratio*
-                    *the-wrapper-of-number* *the-wrapper-of-null*
-                    *the-wrapper-of-list* *the-wrapper-of-integer*
-                    *the-wrapper-of-float* *the-wrapper-of-cons*
-                    *the-wrapper-of-complex* *the-wrapper-of-character*
-                    *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
-
-(defun coerce-to-class (class &optional make-forward-referenced-class-p)
-  (if (symbolp class)
-      (or (find-class class (not make-forward-referenced-class-p))
-	  (ensure-class class))
-      class))
-
-(defun specializer-from-type (type &aux args)
-  (when (consp type)
-    (setq args (cdr type) type (car type)))
-  (cond ((symbolp type)
-	 (or (and (null args) (find-class type))
-	     (ecase type
-	       (class    (coerce-to-class (car args)))
-	       (prototype (make-instance 'class-prototype-specializer
-					 :object (coerce-to-class (car args))))
-	       (class-eq (class-eq-specializer (coerce-to-class (car args))))
-	       (eql      (intern-eql-specializer (car args))))))
-	((specializerp type) type)))
-
-(defun type-from-specializer (specl)
-  (cond ((eq specl 't)
-	 't)
-	((consp specl)
-         (unless (member (car specl) '(class prototype class-eq eql))
-           (error "~S is not a legal specializer type" specl))
-         specl)
-        ((progn
-	   (when (symbolp specl)
-	     ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
-	     (setq specl (find-class specl)))
-	   (or (not (eq *boot-state* 'complete))
-	       (specializerp specl)))
-	 (specializer-type specl))
-        (t
-         (error "~s is neither a type nor a specializer" specl))))
-
-(defun type-class (type)
-  (declare (special *the-class-t*))
-  (setq type (type-from-specializer type))
-  (if (atom type)
-      (if (eq type 't)
-	  *the-class-t*
-	  (error "bad argument to type-class"))
-      (case (car type)
-        (eql (class-of (cadr type)))
-	(prototype (class-of (cadr type))) ;?
-        (class-eq (cadr type))
-        (class (cadr type)))))
-
-(defun class-eq-type (class)
-  (specializer-type (class-eq-specializer class)))
-
-(defun inform-type-system-about-std-class (name)
-  (let ((predicate-name (make-type-predicate-name name)))
-    (setf (gdefinition predicate-name) (make-type-predicate name))
-    (do-satisfies-deftype name predicate-name)))
-
-(defun make-type-predicate (name)
-  (let ((cell (find-class-cell name)))
-    #'(lambda (x)
-	(funcall (the function (find-class-cell-predicate cell)) x))))
-
-
-;This stuff isn't right.  Good thing it isn't used.
-;The satisfies predicate has to be a symbol.  There is no way to
-;construct such a symbol from a class object if class names change.
-(defun class-predicate (class)
-  (when (symbolp class) (setq class (find-class class)))
-  #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
-
-(defun make-class-eq-predicate (class)
-  (when (symbolp class) (setq class (find-class class)))
-  #'(lambda (object) (eq class (class-of object))))
-
-(defun make-eql-predicate (eql-object)
-  #'(lambda (object) (eql eql-object object)))
-
-#|| ; The argument to satisfies must be a symbol.  
-(deftype class (&optional class)
-  (if class
-      `(satisfies ,(class-predicate class))
-      `(satisfies ,(class-predicate 'class))))
-
-(deftype class-eq (class)
-  `(satisfies ,(make-class-eq-predicate class)))
-||#
-
-#-excl
-(deftype eql (type-object)
-  `(member ,type-object))
-
-
-
-;;;
-;;; These functions are a pale imitiation of their namesake.  They accept
-;;; class objects or types where they should.
-;;; 
-(defun *normalize-type (type)
-  (cond ((consp type)
-         (if (member (car type) '(not and or))
-             `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
-             (if (null (cdr type))
-                 (*normalize-type (car type))
-                 type)))
-        ((symbolp type)
-         (let ((class (find-class type nil)))
-           (if class
-               (let ((type (specializer-type class)))
-		 (if (listp type) type `(,type)))
-               `(,type))))
-        ((or (not (eq *boot-state* 'complete))
-	     (specializerp type))
-	 (specializer-type type))
-        (t
-         (error "~s is not a type" type))))
-
-(defun unparse-type-list (tlist)
-  (mapcar #'unparse-type tlist))
-
-(defun unparse-type (type)
-  (if (atom type)
-      (if (specializerp type)
-          (unparse-type (specializer-type type))
-          type)
-      (case (car type)
-        (eql type)
-        (class-eq `(class-eq ,(class-name (cadr type))))
-        (class (class-name (cadr type)))
-        (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
-
-(defun convert-to-system-type (type)
-  (case (car type)
-    ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type))))
-    (class (class-name (cadr type))) ; it had better be a named class
-    (class-eq (class-name (cadr type))) ; this one is impossible to do right
-    (eql type)
-    (t (if (null (cdr type))
-	   (car type)
-	   type))))
-
-(defun *typep (object type)
-  (setq type (*normalize-type type))
-  (cond ((member (car type) '(eql wrapper-eq class-eq class))
-         (specializer-applicable-using-type-p type `(eql ,object)))
-        ((eq (car type) 'not)
-         (not (*typep object (cadr type))))
-        (t
-         (typep object (convert-to-system-type type)))))
-
-(defun *subtypep (type1 type2)
-  (if (equal type1 type2)
-      (values t t)
-      (if (eq *boot-state* 'early)
-	  (values (eq type1 type2) t)
-	  (let ((*in-precompute-effective-methods-p* t)) ; not a descriptive name
-	    (declare (special *in-precompute-effective-methods-p*))
-	    ;; This changes the way class-applicable-using-class-p works.
-	    (setq type1 (*normalize-type type1))
-	    (setq type2 (*normalize-type type2))
-	    (if (member (car type2) '(eql wrapper-eq class-eq class))
-		(multiple-value-bind (app-p maybe-app-p)
-		    (specializer-applicable-using-type-p type2 type1)
-		  (values app-p (or app-p (not maybe-app-p))))
-		(subtypep (convert-to-system-type type1)
-			  (convert-to-system-type type2)))))))
-
-(defun do-satisfies-deftype (name predicate)
-  #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
-  (let* ((specifier `(satisfies ,predicate))
-	 (expand-fn #'(lambda (&rest ignore)
-			(declare (ignore ignore))
-			specifier)))
-    ;; Specific ports can insert their own way of doing this.  Many
-    ;; ports may find the expand-fn defined above useful.
-    ;;
-    (or #+:Genera
-	(setf (get name 'deftype) expand-fn)
-	#+(and :Lucid (not :Prime))
-	(system::define-macro `(deftype ,name) expand-fn nil)
-	#+ExCL
-	(setf (get name 'excl::deftype-expander) expand-fn)
-	#+:coral
-	(setf (get name 'ccl::deftype-expander) expand-fn)))
-  #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
-  ;; This is the default for ports for which we don't know any
-  ;; better.  Note that for most ports, providing this definition
-  ;; should just speed up class definition.  It shouldn't have an
-  ;; effect on performance of most user code.
-  (eval `(deftype ,name () '(satisfies ,predicate))))
-
-(defun make-type-predicate-name (name &optional kind)
-  (if (symbol-package name)
-      (intern (format nil
-		      "~@[~A ~]TYPE-PREDICATE ~A ~A"
-		      kind
-		      (package-name (symbol-package name))
-		      (symbol-name name))
-	      *the-pcl-package*)
-      (make-symbol (format nil
-			   "~@[~A ~]TYPE-PREDICATE ~A"
-			   kind
-			   (symbol-name name)))))
-
-
-
-(defvar *built-in-class-symbols* ())
-(defvar *built-in-wrapper-symbols* ())
-
-(defun get-built-in-class-symbol (class-name)
-  (or (cadr (assq class-name *built-in-class-symbols*))
-      (let ((symbol (intern (format nil
-				    "*THE-CLASS-~A*"
-				    (symbol-name class-name))
-			    *the-pcl-package*)))
-	(push (list class-name symbol) *built-in-class-symbols*)
-	symbol)))
-
-(defun get-built-in-wrapper-symbol (class-name)
-  (or (cadr (assq class-name *built-in-wrapper-symbols*))
-      (let ((symbol (intern (format nil
-				    "*THE-WRAPPER-OF-~A*"
-				    (symbol-name class-name))
-			    *the-pcl-package*)))
-	(push (list class-name symbol) *built-in-wrapper-symbols*)
-	symbol)))
-
-
-
-
-(pushnew 'class *variable-declarations*)
-(pushnew 'variable-rebinding *variable-declarations*)
-
-(defun variable-class (var env)
-  (caddr (variable-declaration 'class var env)))
-
-(defvar *name->class->slotd-table* (make-hash-table))
-
-
-;;;
-;;; This is used by combined methods to communicate the next methods to
-;;; the methods they call.  This variable is captured by a lexical variable
-;;; of the methods to give it the proper lexical scope.
-;;; 
-(defvar *next-methods* nil)
-
-(defvar *not-an-eql-specializer* '(not-an-eql-specializer))
-
-(defvar *umi-gfs*)
-(defvar *umi-complete-classes*)
-(defvar *umi-reorder*)
-
-(defvar *invalidate-discriminating-function-force-p* ())
-(defvar *invalid-dfuns-on-stack* ())
-
-
-(defvar *standard-method-combination*)
-
-(defvar *slotd-unsupplied* (list '*slotd-unsupplied*))	;***
-
-
-(defmacro define-gf-predicate (predicate-name &rest classes)
-  `(progn 
-     (defmethod ,predicate-name ((x t)) nil)
-     ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
-	       classes)))
-
-(defun make-class-predicate-name (name)
-  (intern (format nil "~A::~A class predicate"
-		  (package-name (symbol-package name))
-		  name)
-	  *the-pcl-package*))
-
-(defun plist-value (object name)
-  (getf (object-plist object) name))
-
-(defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)
-  (if new-value
-      (setf (getf (object-plist object) name) new-value)
-      (progn
-        (remf (object-plist object) name)
-        nil)))
-
-
-
-(defvar *built-in-classes*
-  ;;
-  ;; name       supers     subs                     cdr of cpl
-  ;; prototype
-  '(;(t         ()         (number sequence array character symbol) ())
-    (number     (t)        (complex float rational) (t))
-    (complex    (number)   ()                       (number t)
-     #c(1 1))
-    (float      (number)   ()                       (number t)
-     1.0)
-    (rational   (number)   (integer ratio)          (number t))
-    (integer    (rational) ()                       (rational number t)
-     1)
-    (ratio      (rational) ()                       (rational number t)
-     1/2)
-
-    (sequence   (t)        (list vector)            (t))
-    (list       (sequence) (cons null)              (sequence t))
-    (cons       (list)     ()                       (list sequence t)
-     (nil))
-    
-
-    (array      (t)        (vector)                 (t)
-     #2A((NIL)))
-    (vector     (array
-		 sequence) (string bit-vector)      (array sequence t)
-     #())
-    (string     (vector)   ()                       (vector array sequence t)
-     "")
-    (bit-vector (vector)   ()                       (vector array sequence t)
-     #*1)
-    (character  (t)        ()                       (t)
-     #\c)
-   
-    (symbol     (t)        (null)                   (t)
-     symbol)
-    (null       (symbol 
-		 list)     ()                       (symbol list sequence t)
-     nil)))
-
-
-;;;
-;;; The classes that define the kernel of the metabraid.
-;;;
-(defclass t () ()
-  (:metaclass built-in-class))
-
-(defclass slot-object (t) ()
-  (:metaclass slot-class))
-
-(defclass structure-object (slot-object) ()
-  (:metaclass structure-class))
-
-(defstruct (structure-object
-	     (:constructor |STRUCTURE-OBJECT class constructor|)))
-
-(defclass standard-object (slot-object) ())
-
-(defclass metaobject (standard-object) ())
-
-(defclass specializer (metaobject) 
-     ((type
-        :initform nil
-        :reader specializer-type)))
-
-(defclass definition-source-mixin (standard-object)
-     ((source
-	:initform (load-truename)
-	:reader definition-source
-	:initarg :definition-source)))
-
-(defclass plist-mixin (standard-object)
-     ((plist
-	:initform ()
-	:accessor object-plist)))
-
-(defclass documentation-mixin (plist-mixin)
-     ())
-
-(defclass dependent-update-mixin (plist-mixin)
-    ())
-
-;;;
-;;; The class CLASS is a specified basic class.  It is the common superclass
-;;; of any kind of class.  That is any class that can be a metaclass must
-;;; have the class CLASS in its class precedence list.
-;;; 
-(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
-		 specializer)
-     ((name
-	:initform nil
-	:initarg  :name
-	:accessor class-name)
-      (class-eq-specializer
-        :initform nil
-        :reader class-eq-specializer)
-      (direct-superclasses
-	:initform ()
-	:reader class-direct-superclasses)
-      (direct-subclasses
-	:initform ()
-	:reader class-direct-subclasses)
-      (direct-methods
-	:initform (cons nil nil))
-      (predicate-name
-        :initform nil
-	:reader class-predicate-name)))
-
-;;;
-;;; The class PCL-CLASS is an implementation-specific common superclass of
-;;; all specified subclasses of the class CLASS.
-;;; 
-(defclass pcl-class (class)
-     ((class-precedence-list
-	:reader class-precedence-list)
-      (can-precede-list
-        :initform ()
-	:reader class-can-precede-list)
-      (incompatible-superclass-list
-        :initform ()
-	:accessor class-incompatible-superclass-list)
-      (wrapper
-	:initform nil
-	:reader class-wrapper)
-      (prototype
-	:initform nil
-	:reader class-prototype)))
-
-(defclass slot-class (pcl-class)
-     ((direct-slots
-	:initform ()
-	:accessor class-direct-slots)
-      (slots
-        :initform ()
-	:accessor class-slots)
-      (initialize-info
-        :initform nil
-	:accessor class-initialize-info)))
-
-;;;
-;;; The class STD-CLASS is an implementation-specific common superclass of
-;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
-;;; 
-(defclass std-class (slot-class)
-     ())
-
-(defclass standard-class (std-class)
-     ())
-
-(defclass funcallable-standard-class (std-class)
-     ())
-    
-(defclass forward-referenced-class (pcl-class) ())
-
-(defclass built-in-class (pcl-class) ())
-
-(defclass structure-class (slot-class)
-     ((defstruct-form
-        :initform ()
-	:accessor class-defstruct-form)
-      (defstruct-constructor
-        :initform nil
-	:accessor class-defstruct-constructor)
-      (from-defclass-p
-        :initform nil
-	:initarg :from-defclass-p)))
-     
-
-(defclass specializer-with-object (specializer) ())
-
-(defclass exact-class-specializer (specializer) ())
-
-(defclass class-eq-specializer (exact-class-specializer specializer-with-object)
-  ((object :initarg :class :reader specializer-class :reader specializer-object)))
-
-(defclass class-prototype-specializer (specializer-with-object)
-  ((object :initarg :class :reader specializer-class :reader specializer-object)))
-
-(defclass eql-specializer (exact-class-specializer specializer-with-object)
-  ((object :initarg :object :reader specializer-object 
-	   :reader eql-specializer-object)))
-
-(defvar *eql-specializer-table* (make-hash-table :test 'eql))
-
-(defun intern-eql-specializer (object)
-  (or (gethash object *eql-specializer-table*)
-      (setf (gethash object *eql-specializer-table*)
-	    (make-instance 'eql-specializer :object object))))
-
-
-;;;
-;;; Slot definitions.
-;;;
-(defclass slot-definition (metaobject) 
-     ((name
-	:initform nil
-	:initarg :name
-        :accessor slot-definition-name)
-      (initform
-	:initform nil
-	:initarg :initform
-	:accessor slot-definition-initform)
-      (initfunction
-	:initform nil
-	:initarg :initfunction
-	:accessor slot-definition-initfunction)
-      (readers
-	:initform nil
-	:initarg :readers
-	:accessor slot-definition-readers)
-      (writers
-	:initform nil
-	:initarg :writers
-	:accessor slot-definition-writers)
-      (initargs
-	:initform nil
-	:initarg :initargs
-	:accessor slot-definition-initargs)
-      (type
-	:initform t
-	:initarg :type
-	:accessor slot-definition-type)
-      (documentation
-	:initform ""
-	:initarg :documentation)
-      (class
-        :initform nil
-	:initarg :class
-	:accessor slot-definition-class)))
-
-(defclass standard-slot-definition (slot-definition)
-  ((allocation
-    :initform :instance
-    :initarg :allocation
-    :accessor slot-definition-allocation)))
-
-(defclass structure-slot-definition (slot-definition)
-  ((defstruct-accessor-symbol 
-     :initform nil
-     :initarg :defstruct-accessor-symbol
-     :accessor slot-definition-defstruct-accessor-symbol)
-   (internal-reader-function 
-     :initform nil
-     :initarg :internal-reader-function
-     :accessor slot-definition-internal-reader-function)
-   (internal-writer-function 
-     :initform nil
-     :initarg :internal-writer-function
-     :accessor slot-definition-internal-writer-function)))
-
-(defclass direct-slot-definition (slot-definition)
-  ())
-
-(defclass effective-slot-definition (slot-definition)
-  ((reader-function ; #'(lambda (object) ...)
-    :accessor slot-definition-reader-function)
-   (writer-function ; #'(lambda (new-value object) ...)
-    :accessor slot-definition-writer-function)
-   (boundp-function ; #'(lambda (object) ...)
-    :accessor slot-definition-boundp-function)
-   (accessor-flags
-    :initform 0)))
-
-(defclass standard-direct-slot-definition (standard-slot-definition
-					   direct-slot-definition)
-  ())
-
-(defclass standard-effective-slot-definition (standard-slot-definition
-					      effective-slot-definition)
-  ((location ; nil, a fixnum, a cons: (slot-name . value)
-    :initform nil
-    :accessor slot-definition-location)))
-
-(defclass structure-direct-slot-definition (structure-slot-definition
-					    direct-slot-definition)
-  ())
-
-(defclass structure-effective-slot-definition (structure-slot-definition
-					       effective-slot-definition)
-  ())
-
-(defclass method (metaobject) ())
-
-(defclass standard-method (definition-source-mixin plist-mixin method)
-     ((generic-function
-	:initform nil	
-	:accessor method-generic-function)
-;     (qualifiers
-;	:initform ()
-;	:initarg  :qualifiers
-;	:reader method-qualifiers)
-      (specializers
-	:initform ()
-	:initarg  :specializers
-	:reader method-specializers)
-      (lambda-list
-	:initform ()
-	:initarg  :lambda-list
-	:reader method-lambda-list)
-      (function
-	:initform nil
-	:initarg :function)		;no writer
-      (fast-function
-	:initform nil
-	:initarg :fast-function		;no writer
-	:reader method-fast-function)
-;     (documentation
-;	:initform nil
-;	:initarg  :documentation
-;	:reader method-documentation)
-      ))
-
-(defclass standard-accessor-method (standard-method)
-     ((slot-name :initform nil
-		 :initarg :slot-name
-		 :reader accessor-method-slot-name)
-      (slot-definition :initform nil
-		       :initarg :slot-definition
-		       :reader accessor-method-slot-definition)))
-
-(defclass standard-reader-method (standard-accessor-method) ())
-
-(defclass standard-writer-method (standard-accessor-method) ())
-
-(defclass standard-boundp-method (standard-accessor-method) ())
-
-(defclass generic-function (dependent-update-mixin
-			    definition-source-mixin
-			    documentation-mixin
-			    metaobject)
-     ()
-  (:metaclass funcallable-standard-class))
-    
-(defclass standard-generic-function (generic-function)
-     ((name
-	:initform nil
-	:initarg :name
-	:accessor generic-function-name)
-      (methods
-	:initform ()
-	:accessor generic-function-methods)
-      (method-class
-	:initarg :method-class
-	:accessor generic-function-method-class)
-      (method-combination
-	:initarg :method-combination
-	:accessor generic-function-method-combination)
-      (arg-info
-        :initform (make-arg-info)
-	:reader gf-arg-info)
-      (dfun-state
-	:initform ()
-	:accessor gf-dfun-state)
-      (pretty-arglist
-	:initform ()
-	:accessor gf-pretty-arglist)
-      )
-  (:metaclass funcallable-standard-class)
-  (:default-initargs :method-class *the-class-standard-method*
-		     :method-combination *standard-method-combination*))
-
-(defclass method-combination (metaobject) ())
-
-(defclass standard-method-combination
-	  (definition-source-mixin method-combination)
-     ((type          :reader method-combination-type
-	             :initarg :type)
-      (documentation :reader method-combination-documentation
-		     :initarg :documentation)
-      (options       :reader method-combination-options
-	             :initarg :options)))
-
-(defparameter *early-class-predicates*
-  '((specializer specializerp)
-    (exact-class-specializer exact-class-specializer-p)
-    (class-eq-specializer class-eq-specializer-p)
-    (eql-specializer eql-specializer-p)
-    (class classp)
-    (slot-class slot-class-p)
-    (standard-class standard-class-p)
-    (funcallable-standard-class funcallable-standard-class-p)
-    (structure-class structure-class-p)
-    (forward-referenced-class forward-referenced-class-p)
-    (method method-p)
-    (standard-method standard-method-p)
-    (standard-accessor-method standard-accessor-method-p)
-    (standard-reader-method standard-reader-method-p)
-    (standard-writer-method standard-writer-method-p)
-    (standard-boundp-method standard-boundp-method-p)
-    (generic-function generic-function-p)
-    (standard-generic-function standard-generic-function-p)
-    (method-combination method-combination-p)))
-
diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp
deleted file mode 100644
index 210c613e2720a06ba06e16724c730b7739e37d9e..0000000000000000000000000000000000000000
--- a/pcl/defsys.lisp
+++ /dev/null
@@ -1,1063 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; Some support stuff for compiling and loading PCL.  It would be nice if
-;;; there was some portable make-system we could all agree to share for a
-;;; while.  At least until people really get databases and stuff.
-;;;
-;;; ***                                                               ***
-;;; ***        DIRECTIONS FOR INSTALLING PCL AT YOUR SITE             ***
-;;; ***                                                               ***
-;;;
-;;; To get PCL working at your site you should:
-;;; 
-;;;  - Get all the PCL source files from Xerox.  The complete list of source
-;;;    file names can be found in the defsystem for PCL which appears towards
-;;;    the end of this file.
-;;; 
-;;;  - Edit the variable *pcl-directory* below to specify the directory at
-;;;    your site where the pcl sources and binaries will be.  This variable
-;;;    can be found by searching from this point for the string "***" in
-;;;    this file.
-;;; 
-;;;  - Use the function (pcl::compile-pcl) to compile PCL for your site.
-;;; 
-;;;  - Once PCL has been compiled it can be loaded with (pcl::load-pcl).
-;;;    Note that PCL cannot be loaded on top of itself, nor can it be
-;;;    loaded into the same world it was compiled in.
-;;;
-
-(in-package :user)
-
-#+excl
-(eval-when (compile load eval)
-  (when (eq (find-package :lisp) (find-package :common-lisp))
-    (let ((excl::*enable-package-locked-errors* nil))
-      (rename-package :common-lisp :common-lisp '(:cl)))
-    (make-package :lisp :use nil)
-    ((lambda (symbols)
-       (import symbols :lisp)
-       (export symbols :lisp))
-     '(&allow-other-keys &aux &body &environment &key &optional &rest &whole
-       * ** *** *applyhook* *break-on-warnings* *debug-io*
-       *default-pathname-defaults* *error-output* *evalhook* *features*
-       *load-verbose* *macroexpand-hook* *modules* *package* *print-array*
-       *print-base* *print-case* *print-circle* *print-escape*
-       *print-gensym* *print-length* *print-level* *print-pretty*
-       *print-radix* *query-io* *random-state* *read-base*
-       *read-default-float-format* *read-suppress* *readtable*
-       *standard-input* *standard-output* *terminal-io* *trace-output* +
-       ++ +++ - / // /// /= 1+ 1- < <= = > >= abs acons acos acosh adjoin
-       adjust-array adjustable-array-p akcl alpha-char-p alphanumericp and
-       append apply applyhook apropos apropos-list aref array
-       array-dimension array-dimension-limit array-dimensions
-       array-element-type array-has-fill-pointer-p array-in-bounds-p
-       array-rank array-rank-limit array-row-major-index array-total-size
-       array-total-size-limit arrayp ash asin asinh assert assoc assoc-if
-       assoc-if-not atan atanh atom bignum bit bit-and bit-andc1 bit-andc2
-       bit-eqv bit-ior bit-nand bit-nor bit-not bit-orc1 bit-orc2
-       bit-vector bit-vector-p bit-xor block boole boole-1 boole-2
-       boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr
-       boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2
-       boole-set boole-xor both-case-p boundp break butlast byte
-       byte-position byte-size caaaar caaadr caaar caadar caaddr caadr
-       caar cadaar cadadr cadar caddar cadddr caddr cadr
-       call-arguments-limit car case catch ccase cdaaar cdaadr cdaar
-       cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr
-       cddr cdr ceiling cerror char char-bit char-bits char-bits-limit
-       char-code char-code-limit char-control-bit char-downcase char-equal
-       char-font char-font-limit char-greaterp char-hyper-bit char-int
-       char-lessp char-meta-bit char-name char-not-equal char-not-greaterp
-       char-not-lessp char-super-bit char-upcase char/= char< char<= char=
-       char> char>= character characterp check-type cis clear-input
-       clear-output close clrhash code-char coerce common commonp
-       compilation-speed compile compile-file compiled-function
-       compiled-function-p compiler-let complex complexp concatenate cond
-       conjugate cons consp constantp copy-alist copy-list copy-readtable
-       copy-seq copy-symbol copy-tree cos cosh count count-if count-if-not
-       ctypecase decf declaration declare decode-float
-       decode-universal-time defconstant define-modify-macro
-       define-setf-method defmacro defparameter defsetf defstruct deftype
-       defun defvar delete delete-duplicates delete-file delete-if
-       delete-if-not denominator deposit-field describe digit-char
-       digit-char-p directory directory-namestring disassemble do do*
-       do-all-symbols do-external-symbols do-symbols documentation dolist
-       dotimes double-float double-float-epsilon
-       double-float-negative-epsilon dpb dribble ecase ed eighth elt
-       encode-universal-time endp enough-namestring eq eql equal equalp
-       error etypecase eval eval-when evalhook evenp every exp export expt
-       fboundp fceiling ffloor fifth file-author file-length
-       file-namestring file-position file-write-date fill fill-pointer
-       find find-all-symbols find-if find-if-not find-package find-symbol
-       finish-output first fixnum flet float float-digits float-precision
-       float-radix float-sign floatp floor fmakunbound force-output format
-       fourth fresh-line fround ftruncate ftype funcall function functionp
-       gcd gensym gentemp get get-decoded-time
-       get-dispatch-macro-character get-internal-real-time
-       get-internal-run-time get-macro-character get-output-stream-string
-       get-properties get-setf-method get-setf-method-multiple-value
-       get-universal-time getf gethash gfun go graphic-char-p hash-table
-       hash-table-count hash-table-p host-namestring identity if ignore
-       imagpart import in-package incf inline input-stream-p inspect
-       int-char integer integer-decode-float integer-length integerp
-       intern internal-time-units-per-second intersection isqrt keyword
-       keywordp labels lambda lambda-list-keywords lambda-parameters-limit
-       last lcm ldb ldb-test ldiff least-negative-double-float
-       least-negative-long-float least-negative-short-float
-       least-negative-single-float least-positive-double-float
-       least-positive-long-float least-positive-short-float
-       least-positive-single-float length let let*
-       lisp-implementation-type lisp-implementation-version list list*
-       list-all-packages list-length listen listp load locally log logand
-       logandc1 logandc2 logbitp logcount logeqv logior lognand lognor
-       lognot logorc1 logorc2 logtest logxor long-float long-float-epsilon
-       long-float-negative-epsilon long-site-name loop lower-case-p
-       machine-instance machine-type machine-version macro-function
-       macroexpand macroexpand-1 macrolet make-array make-broadcast-stream
-       make-char make-concatenated-stream make-dispatch-macro-character
-       make-echo-stream make-hash-table make-list make-package
-       make-pathname make-random-state make-sequence make-string
-       make-string-input-stream make-string-output-stream make-symbol
-       make-synonym-stream make-two-way-stream makunbound map mapc mapcan
-       mapcar mapcon maphash mapl maplist mask-field max member member-if
-       member-if-not merge merge-pathnames min minusp mips mismatch mod
-       most-negative-double-float most-negative-fixnum
-       most-negative-long-float most-negative-short-float
-       most-negative-single-float most-positive-double-float
-       most-positive-fixnum most-positive-long-float
-       most-positive-short-float most-positive-single-float
-       multiple-value-bind multiple-value-call multiple-value-list
-       multiple-value-prog1 multiple-value-setq multiple-values-limit
-       name-char namestring nbutlast nconc nil nintersection ninth not
-       notany notevery notinline nreconc nreverse nset-difference
-       nset-exclusive-or nstring-capitalize nstring-downcase
-       nstring-upcase nsublis nsubst nsubst-if nsubst-if-not nsubstitute
-       nsubstitute-if nsubstitute-if-not nth nthcdr null number numberp
-       numerator nunion oddp open optimize or otherwise output-stream-p
-       package package-name package-nicknames package-shadowing-symbols
-       package-use-list package-used-by-list packagep pairlis
-       parse-integer parse-namestring pathname pathname-device
-       pathname-directory pathname-host pathname-name pathname-type
-       pathname-version pathnamep peek-char phase pi plusp pop position
-       position-if position-if-not pprint prin1 prin1-to-string princ
-       princ-to-string print probe-file proclaim prog prog* prog1 prog2
-       progn progv provide psetf psetq push pushnew quote random
-       random-state random-state-p rassoc rassoc-if rassoc-if-not ratio
-       rational rationalize rationalp read read-byte read-char
-       read-char-no-hang read-delimited-list read-from-string read-line
-       read-preserving-whitespace readtable readtablep realpart reduce rem
-       remf remhash remove remove-duplicates remove-if remove-if-not
-       remprop rename-file rename-package replace require rest return
-       return-from revappend reverse room rotatef round rplaca rplacd
-       safety satisfies sbit scale-float schar search second sequence set
-       set-char-bit set-difference set-dispatch-macro-character
-       set-exclusive-or set-macro-character set-syntax-from-char setf setq
-       seventh sfun shadow shadowing-import shiftf short-float
-       short-float-epsilon short-float-negative-epsilon short-site-name
-       signed-byte signum simple-array simple-bit-vector
-       simple-bit-vector-p simple-string simple-string-p simple-vector
-       simple-vector-p sin single-float single-float-epsilon
-       single-float-negative-epsilon sinh sixth sleep software-type
-       software-version some sort space special special-form-p speed sqrt
-       stable-sort standard-char standard-char-p step stream
-       stream-element-type streamp string string-capitalize string-char
-       string-char-p string-downcase string-equal string-greaterp
-       string-left-trim string-lessp string-not-equal string-not-greaterp
-       string-not-lessp string-right-trim string-trim string-upcase
-       string/= string< string<= string= string> string>= stringp
-       structure sublis subseq subsetp subst subst-if subst-if-not
-       substitute substitute-if substitute-if-not subtypep svref sxhash
-       symbol symbol-function symbol-name symbol-package symbol-plist
-       symbol-value symbolp t tagbody tailp tan tanh tenth terpri the
-       third throw time trace tree-equal truename truncate type type-of
-       typecase typep unexport unintern union unless unread-char
-       unsigned-byte untrace unuse-package unwind-protect upper-case-p
-       use-package user-homedir-pathname values values-list variable
-       vector vector-pop vector-push vector-push-extend vectorp warn when
-       with-input-from-string with-open-file with-open-stream
-       with-output-to-string write write-byte write-char write-line
-       write-string write-to-string y-or-n-p yes-or-no-p zerop))))
-
-(in-package :walker :use '(:lisp))
-(in-package :iterate :use '(:lisp :walker))
-(in-package :pcl :use '(:walker :iterate :lisp))
-
-(export (intern (symbol-name :iterate)		;Have to do this here,
-		(find-package :iterate))	;because in the defsystem
-	(find-package :iterate))		;(later in this file)
-						;we use the symbol iterate
-						;to name the file
-
-;;;
-;;; Sure, its weird for this to be here, but in order to follow the rules
-;;; about order of export and all that stuff, we can't put it in PKG before
-;;; we want to use it.
-;;; 
-(defvar *the-pcl-package* (find-package :pcl))
-
-(defvar *pcl-system-date* "September 16 92 PCL (e)")
-
-#+cmu
-(setf (getf ext:*herald-items* :pcl)
-      `("    CLOS based on PCL version:  " ,*pcl-system-date*))
-
-;;;
-;;; Various hacks to get people's *features* into better shape.
-;;; 
-(eval-when (compile load eval)
-  #+(and Symbolics Lispm)
-  (multiple-value-bind (major minor) (sct:get-release-version)
-    (etypecase minor
-      (integer)
-      (string (setf minor (parse-integer minor :junk-allowed t))))
-    (pushnew :genera *features*)
-    (ecase major
-      ((6)
-       (pushnew :genera-release-6 *features*))
-      ((7)
-       (pushnew :genera-release-7 *features*)
-       (pushnew :copy-&rest-arg *features*)
-       (ecase minor
-	 ((0 1) (pushnew :genera-release-7-1 *features*))
-	 ((2)   (pushnew :genera-release-7-2  *features*))
-	 ((3)   (pushnew :genera-release-7-3  *features*))
-	 ((4)   (pushnew :genera-release-7-4  *features*))))
-      ((8)
-       (pushnew :genera-release-8 *features*)
-       (ecase minor
-	 ((0) (pushnew :genera-release-8-0 *features*))
-	 ((1) (pushnew :genera-release-8-1 *features*))))))
-  
-  #+CLOE-Runtime
-  (let ((version (lisp-implementation-version)))
-    (when (string-equal version "2.0" :end1 (min 3 (length version)))
-      (pushnew :cloe-release-2 *features*)))
-
-  (dolist (feature *features*)
-    (when (and (symbolp feature)                ;3600!!
-               (equal (symbol-name feature) "CMU"))
-      (pushnew :CMU *features*)))
-  
-  #+TI
-  (if (eq (si:local-binary-file-type) :xld)
-      (pushnew ':ti-release-3 *features*)
-      (pushnew ':ti-release-2 *features*))
-
-  #+Lucid
-  (when (search "IBM RT PC" (machine-type))
-    (pushnew :ibm-rt-pc *features*))
-
-  #+ExCL
-  (cond ((search "sun3" (lisp-implementation-version))
-	 (push :sun3 *features*))
-	((search "sun4" (lisp-implementation-version))
-	 (push :sun4 *features*)))
-
-  #+(and HP Lucid)
-  (push :HP-Lucid *features*)
-  #+(and HP (not Lucid) (not excl))
-  (push :HP-HPLabs *features*)
-
-  #+Xerox
-  (case il:makesysname
-    (:lyric (push :Xerox-Lyric *features*))
-    (otherwise (push :Xerox-Medley *features*)))
-;;;
-;;; For KCL and IBCL, push the symbol :turbo-closure on the list *features*
-;;; if you have installed turbo-closure patch.  See the file kcl-mods.text
-;;; for details.
-;;;
-;;; The xkcl version of KCL has this fixed already.
-;;; 
-
-  #+xkcl(pushnew :turbo-closure *features*)
-
-  )
-
-#+(and excl sun4)
-(eval-when (eval compile load)
-  (pushnew :excl-sun4 *features*))
-
-#+cmu
-(eval-when (compile load eval)
-  (let ((vs (lisp-implementation-version)))
-    (cond ((and (<= 2 (length vs))
-		(eql #\1 (aref vs 0))
-		(let ((d (digit-char-p (aref vs 1))))
-		  (and d (<= 6 d))))
-	   (pushnew :cmu16 *features*))
-	  ((string= "20-Dec-1992" vs)
-	   (pushnew :cmu16 *features*)
-	   (pushnew :cmu17 *features*)
-	   (when (fboundp 'pcl::original-defstruct)
-	     (setf (macro-function 'defstruct)
-		   (macro-function 'pcl::original-defstruct))))
-	  (t
-	   (error "what version of cmucl is this?")))))
-
-;;; Yet Another Sort Of General System Facility and friends.
-;;;
-;;; The entry points are defsystem and operate-on-system.  defsystem is used
-;;; to define a new system and the files with their load/compile constraints.
-;;; Operate-on-system is used to operate on a system defined that has been
-;;; defined by defsystem.  For example:
-#||
-
-(defsystem my-very-own-system
-	   "/usr/myname/lisp/"
-  ((classes   (precom)           ()                ())
-   (methods   (precom classes)   (classes)         ())
-   (precom    ()                 (classes methods) (classes methods))))
-
-This defsystem should be read as follows:
-
-* Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries
-  should be in the directory "/usr/me/lisp/".  There are three files
-  in the system, there are named classes, methods and precom.  (The
-  extension the filenames have depends on the lisp you are running in.)
-  
-* For the first file, classes, the (precom) in the line means that
-  the file precom should be loaded before this file is loaded.  The
-  first () means that no other files need to be loaded before this
-  file is compiled.  The second () means that changes in other files
-  don't force this file to be recompiled.
-
-* For the second file, methods, the (precom classes) means that both
-  of the files precom and classes must be loaded before this file
-  can be loaded.  The (classes) means that the file classes must be
-  loaded before this file can be compiled.  The () means that changes
-  in other files don't force this file to be recompiled.
-
-* For the third file, precom, the first () means that no other files
-  need to be loaded before this file is loaded.  The first use of
-  (classes methods)  means that both classes and methods must be
-  loaded before this file can be compiled.  The second use of (classes
-  methods) mean that whenever either classes or methods changes precom
-  must be recompiled.
-
-Then you can compile your system with:
-
- (operate-on-system 'my-very-own-system :compile)
-
-and load your system with:
-
- (operate-on-system 'my-very-own-system :load)
-
-||#
-
-;;; 
-(defvar *system-directory*)
-
-;;;
-;;; *port* is a list of symbols (in the PCL package) which represent the
-;;; Common Lisp in which we are now running.  Many of the facilities in
-;;; defsys use the value of *port* rather than #+ and #- to conditionalize
-;;; the way they work.
-;;; 
-(defvar *port*
-        '(#+Genera               Genera
-;         #+Genera-Release-6     Rel-6
-;         #+Genera-Release-7-1   Rel-7
-          #+Genera-Release-7-2   Rel-7
-	  #+Genera-Release-7-3   Rel-7
-          #+Genera-Release-7-1   Rel-7-1
-          #+Genera-Release-7-2   Rel-7-2
-	  #+Genera-Release-7-3   Rel-7-2	;OK for now
-	  #+Genera-Release-7-4   Rel-7-2	;OK for now
-	  #+Genera-Release-8	 Rel-8
-	  #+imach                Ivory
-	  #+Cloe-Runtime	 Cloe
-          #+Lucid                Lucid
-          #+Xerox                Xerox
-	  #+Xerox-Lyric          Xerox-Lyric
-	  #+Xerox-Medley         Xerox-Medley
-          #+TI                   TI
-          #+(and dec vax common) Vaxlisp
-          #+KCL                  KCL
-          #+IBCL                 IBCL
-          #+excl                 excl
-	  #+(and excl sun4)      excl-sun4
-          #+:CMU                 CMU
-          #+HP-HPLabs            HP-HPLabs
-          #+:gclisp              gclisp
-          #+pyramid              pyramid
-          #+:coral               coral))
-
-;;;
-;;; When you get a copy of PCL (by tape or by FTP), the sources files will
-;;; have extensions of ".lisp" in particular, this file will be defsys.lisp.
-;;; The preferred way to install pcl is to rename these files to have the
-;;; extension which your lisp likes to use for its files.  Alternately, it
-;;; is possible not to rename the files.  If the files are not renamed to
-;;; the proper convention, the second line of the following defvar should
-;;; be changed to:
-;;;     (let ((files-renamed-p nil)
-;;;
-;;; Note: Something people installing PCL on a machine running Unix
-;;;       might find useful.  If you want to change the extensions
-;;;       of the source files from ".lisp" to ".lsp", *all* you have
-;;;       to do is the following:
-;;;
-;;;       % foreach i (*.lisp)
-;;;       ? mv $i $i:r.lsp
-;;;       ? end
-;;;       %
-;;;
-;;;       I am sure that a lot of people already know that, and some
-;;;       Unix hackers may say, "jeez who doesn't know that".  Those
-;;;       same Unix hackers are invited to fix mv so that I can type
-;;;       "mv *.lisp *.lsp".
-;;;
-(defvar *default-pathname-extensions*
-  (car '(#+(and (not imach) genera)          ("lisp"  . "bin")
-	 #+(and imach genera)                ("lisp"  . "ibin")
-	 #+Cloe-Runtime                      ("l"     . "fasl")
-	 #+(and dec common vax (not ultrix)) ("LSP"   . "FAS")
-	 #+(and dec common vax ultrix)       ("lsp"   . "fas")
-	 #+KCL                               ("lsp"   . "o")
-	 #+IBCL                              ("lsp"   . "o")
-	 #+Xerox                             ("lisp"  . "dfasl")
-	 #+(and Lucid MC68000)               ("lisp"  . "lbin")
-	 #+(and Lucid VAX)                   ("lisp"  . "vbin")
-	 #+(and Lucid Prime)                 ("lisp"  . "pbin")
-	 #+(and Lucid SUNRise)               ("lisp"  . "sbin")
-	 #+(and Lucid SPARC)                 ("lisp"  . "sbin")
-	 #+(and Lucid IBM-RT-PC)             ("lisp"  . "bbin")
-	 #+(and Lucid MIPS)                  ("lisp"  . "mbin")
-	 #+(and Lucid PRISM)                 ("lisp"  . "abin")
-	 #+(and Lucid PA)                    ("lisp"  . "hbin")
-	 #+(and excl SPARC)                  ("cl"    . "sparc")
-	 #+(and excl m68k)                   ("cl"    . "m68k")
-	 #+excl                              ("cl"    . "fasl")
-         #+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*))
-	 #+HP-HPLabs                         ("l"     . "b")
-	 #+TI ("lisp" . #.(string (si::local-binary-file-type)))
-	 #+:gclisp                           ("LSP"   . "F2S")
-	 #+pyramid                           ("clisp" . "o")
-	 #+:coral                            ("lisp"  . "fasl")
-	 #-(or symbolics (and dec common vax) KCL IBCL Xerox 
-	       lucid excl :CMU HP TI :gclisp pyramid coral)
-	                                     ("lisp"  . "lbin"))))
-
-(defvar *pathname-extensions*
-  (let* ((files-renamed-p t)
-	 (proper-extensions *default-pathname-extensions*))
-    (cond ((null proper-extensions) '("l" . "lbin"))
-          ((null files-renamed-p) (cons "lisp" (cdr proper-extensions)))
-          (t proper-extensions))))
-
-(eval-when (compile load eval)
-
-(defun get-system (name)
-  (get name 'system-definition))
-
-(defun set-system (name new-value)
-  (setf (get name 'system-definition) new-value))
-
-(defmacro defsystem (name directory files)
-  `(set-system ',name (list #'(lambda () ,directory)
-			    (make-modules ',files)
-			    ',(mapcar #'car files))))
-
-)
-
-
-;;;
-;;; The internal datastructure used when operating on a system.
-;;; 
-(defstruct (module (:constructor make-module (name))
-                   (:print-function
-                     (lambda (m s d)
-                       (declare (ignore d))
-                       (format s "#<Module ~A>" (module-name m)))))
-  name
-  load-env
-  comp-env
-  recomp-reasons)
-
-(defun make-modules (system-description)
-  (let ((modules ()))
-    (labels ((get-module (name)
-               (or (find name modules :key #'module-name)
-                   (progn (setq modules (cons (make-module name) modules))
-                          (car modules))))
-             (parse-spec (spec)
-               (if (eq spec 't)
-                   (reverse (cdr modules))
-		   (case (car spec)
-		     (+ (append (reverse (cdr modules))
-				(mapcar #'get-module (cdr spec))))
-		     (- (let ((rem (mapcar #'get-module (cdr spec))))
-			  (remove-if #'(lambda (m) (member m rem))
-				     (reverse (cdr modules)))))
-		     (otherwise (mapcar #'get-module spec))))))
-      (dolist (file system-description)
-        (let* ((name (car file))
-               (port (car (cddddr file)))
-               (module nil))
-          (when (or (null port)
-                    (member port *port*))
-            (setq module (get-module name))
-            (setf (module-load-env module) (parse-spec (cadr file))
-                  (module-comp-env module) (parse-spec (caddr file))
-                  (module-recomp-reasons module) (parse-spec (cadddr file))))))
-      (let ((filenames (mapcar #'car system-description)))
-	(sort modules #'(lambda (name1 name2)
-			  (member name2 (member name1 filenames)))
-	      :key #'module-name)))))
-
-
-(defun make-transformations (modules filter make-transform)
-  (declare (type function filter make-transform))
-  (let ((transforms (list nil)))
-    (dolist (m modules)
-      (when (funcall filter m transforms) (funcall make-transform m transforms)))
-    (reverse (cdr transforms))))
-
-(defun make-compile-transformation (module transforms)
-  (unless (dolist (trans transforms)
-	    (and (eq (car trans) ':compile)
-		 (eq (cadr trans) module)
-		 (return t)))
-    (dolist (c (module-comp-env module)) (make-load-transformation c transforms))
-    (setf (cdr transforms)
-	  (remove-if #'(lambda (trans) (and (eq (car trans) :load)
-					    (eq (cadr trans) module)))
-		     (cdr transforms)))
-    (push `(:compile ,module) (cdr transforms))))
-
-(defvar *being-loaded* ())
-
-(defun make-load-transformation (module transforms)
-  (if (assoc module *being-loaded*)
-      (throw module (setf (cdr transforms) (cdr (assoc module *being-loaded*))))
-      (let ((*being-loaded* (cons (cons module (cdr transforms)) *being-loaded*)))
-	(catch module
-	  (unless (dolist (trans transforms)
-		    (when (and (eq (car trans) ':load)
-			       (eq (cadr trans) module))
-		      (return t)))
-	    (dolist (l (module-load-env module))
-	      (make-load-transformation l transforms))
-	    (push `(:load ,module) (cdr transforms)))))))
-
-(defun make-load-without-dependencies-transformation (module transforms)
-  (unless (dolist (trans transforms)
-            (and (eq (car trans) ':load)
-                 (eq (cadr trans) module)
-                 (return trans)))
-    (push `(:load ,module) (cdr transforms))))
-
-(defun compile-filter (module transforms)
-  (or (dolist (r (module-recomp-reasons module))
-        (when (dolist (transform transforms)
-                (when (and (eq (car transform) ':compile)
-                           (eq (cadr transform) r))
-                  (return t)))
-          (return t)))
-      (null (probe-file (make-binary-pathname (module-name module))))
-      (> (file-write-date (make-source-pathname (module-name module)))
-         (file-write-date (make-binary-pathname (module-name module))))))
-
-(defun operation-transformations (name mode &optional arg)
-  (let ((system (get-system name)))
-    (unless system (error "Can't find system with name ~S." name))
-    (let ((*system-directory* (funcall (the function (car system))))
-	  (modules (cadr system)))
-      (ecase mode
-	(:compile
-	  ;; Compile any files that have changed and any other files
-	  ;; that require recompilation when another file has been
-	  ;; recompiled.
-	  (make-transformations
-	   modules
-	   #'compile-filter
-	   #'make-compile-transformation))
-	(:recompile
-	  ;; Force recompilation of all files.
-	  (make-transformations
-	   modules
-	   #'true
-	   #'make-compile-transformation))
-	(:recompile-some
-	  ;; Force recompilation of some files.  Also compile the
-	  ;; files that require recompilation when another file has
-	  ;; been recompiled.
-	  (make-transformations
-	   modules
-	   #'(lambda (m transforms)
-	       (or (member (module-name m) arg)
-		   (compile-filter m transforms)))
-	   #'make-compile-transformation))
-	(:query-compile
-	  ;; Ask the user which files to compile.  Compile those
-	  ;; and any other files which must be recompiled when
-	  ;; another file has been recompiled.
-	  (make-transformations
-	   modules
-	   #'(lambda (m transforms)
-	       (or (compile-filter m transforms)
-		   (y-or-n-p "Compile ~A?"
-			     (module-name m))))
-	   #'make-compile-transformation))
-	(:confirm-compile
-	  ;; Offer the user a chance to prevent a file from being
-	  ;; recompiled.
-	  (make-transformations
-	   modules
-	   #'(lambda (m transforms)
-	       (and (compile-filter m transforms)
-		    (y-or-n-p "Go ahead and compile ~A?"
-			      (module-name m))))
-	   #'make-compile-transformation))
-	(:load
-	  ;; Load the whole system.
-	  (make-transformations
-	   modules
-	   #'true
-	   #'make-load-transformation))
-	(:query-load
-	  ;; Load only those files the user says to load.
-	  (make-transformations
-	   modules
-	   #'(lambda (m transforms)
-	       (declare (ignore transforms))
-	       (y-or-n-p "Load ~A?" (module-name m)))
-	   #'make-load-without-dependencies-transformation))))))
-
-(defun true (&rest ignore)
-  (declare (ignore ignore))
-  't)
-
-(defun operate-on-system (name mode &optional arg print-only)
-  (let ((system (get-system name)))
-    (unless system (error "Can't find system with name ~S." name))
-    (let* ((*system-directory* (funcall (the function (car system))))
-	   (transformations (operation-transformations name mode arg)))
-      (labels ((load-binary (name pathname)
-		 (format t "~&Loading binary of ~A...~%" name)
-		 (or print-only (load pathname)))	       
-	       (load-module (m)
-		 (let* ((name (module-name m))
-			(*load-verbose* nil)
-			(binary (make-binary-pathname name)))
-		   (load-binary name binary)))
-	       (compile-module (m)
-		 (format t "~&Compiling ~A...~%" (module-name m))
-		 (unless print-only
-		   (let  ((name (module-name m)))
-		     (compile-file (make-source-pathname name)
-				   :output-file
-				   (make-pathname :defaults
-						  (make-binary-pathname name)
-						  :version :newest))))))
-	(#+Genera
-	 compiler:compiler-warnings-context-bind
-	 #+TI
-	 COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
-	 #+:LCL3.0
-	 lucid-common-lisp:with-deferred-warnings
-	 #+cmu
-	 with-compilation-unit #+cmu ()
-	 #-(or Genera TI :LCL3.0 cmu)
-	 progn
-           (loop (when (null transformations) (return t))
-		 (let ((transform (pop transformations)))
-		   (ecase (car transform)
-		     (:compile (compile-module (cadr transform)))
-		     (:load (load-module (cadr transform)))))))))))
-
-
-(defun make-source-pathname (name) (make-pathname-internal name :source))
-(defun make-binary-pathname (name) (make-pathname-internal name :binary))
-
-(defun make-pathname-internal (name type)
-  (let* ((extension (ecase type
-                      (:source (car *pathname-extensions*))
-                      (:binary (cdr *pathname-extensions*))))
-         (directory (pathname
-		      (etypecase *system-directory*
-			(string *system-directory*)
-			(pathname *system-directory*)
-			(cons (ecase type
-				(:source (car *system-directory*))
-				(:binary (cdr *system-directory*)))))))
-         (pathname
-           (make-pathname
-             :name (string-downcase (string name))
-             :type extension
-             :defaults directory)))
-
-    #+Genera
-    (setq pathname (zl:send pathname :new-raw-name (pathname-name pathname))
-          pathname (zl:send pathname :new-raw-type (pathname-type pathname)))
-
-    pathname))
-
-(defun system-source-files (name)
-  (let ((system (get-system name)))
-    (unless system (error "Can't find system with name ~S." name))
-    (let ((*system-directory* (funcall (the function (car system))))
-	  (modules (cadr system)))
-      (mapcar #'(lambda (module)
-		  (make-source-pathname (module-name module)))
-	      modules))))
-
-(defun system-binary-files (name)
-  (let ((system (get-system name)))
-    (unless system (error "Can't find system with name ~S." name))
-    (let ((*system-directory* (funcall (the function (car system))))
-	  (modules (cadr system)))
-      (mapcar #'(lambda (module)
-		  (make-binary-pathname (module-name module)))
-	      modules))))
-
-;;; ***                SITE SPECIFIC PCL DIRECTORY                        ***
-;;;
-;;; *pcl-directory* is a variable which specifies the directory pcl is stored
-;;; in at your site.  If the value of the variable is a single pathname, the
-;;; sources and binaries should be stored in that directory.  If the value of
-;;; that directory is a cons, the CAR should be the source directory and the
-;;; CDR should be the binary directory.
-;;;
-;;; By default, the value of *pcl-directory* is set to the directory that
-;;; this file is loaded from.  This makes it simple to keep multiple copies
-;;; of PCL in different places, just load defsys from the same directory as
-;;; the copy of PCL you want to use.
-;;;
-;;; Note that the value of *PCL-DIRECTORY* is set using a DEFVAR.  This is
-;;; done to make it possible for users to set it in their init file and then
-;;; load this file.  The value set in the init file will override the value
-;;; here.
-;;;
-;;; ***                                                                   ***
-
-(defun load-truename (&optional (errorp nil))
-  (flet ((bad-time ()
-	   (when errorp
-	     (error "LOAD-TRUENAME called but a file isn't being loaded."))))
-    #+Lispm  (or sys:fdefine-file-pathname (bad-time))
-    #+excl   excl::*source-pathname*
-    #+Xerox  (pathname (or (il:fullname *standard-input*) (bad-time)))
-    #+(and dec vax common) (truename (sys::source-file #'load-truename))
-    ;;
-    ;; The following use of  `lucid::' is a kludge for 2.1 and 3.0
-    ;; compatibility.  In 2.1 it was in the SYSTEM package, and i
-    ;; 3.0 it's in the LUCID-COMMON-LISP package.
-    ;;
-    #+LUCID (or lucid::*source-pathname* (bad-time))
-    #+akcl   si:*load-pathname*
-    #+cmu17 *load-truename*
-    #-(or Lispm excl Xerox (and dec vax common) LUCID akcl cmu17) nil))
-
-#-(or (and cmu (not cmu17)) Symbolics)
-(defvar *pcl-directory*
-	(or (load-truename t)
-	    (error "Because load-truename is not implemented in this port~%~
-                    of PCL, you must manually edit the definition of the~%~
-                    variable *pcl-directory* in the file defsys.lisp.")))
-
-#+(and cmu (not cmu17))
-(defvar *pcl-directory* (pathname "pcl:"))
-
-#+Genera
-(defvar *pcl-directory*
-	(let ((source (load-truename t)))
-	  (flet ((subdir (name)
-		   (scl:send source :new-pathname :raw-directory
-			     (append (scl:send source :raw-directory)
-				     (list name)))))
-	    (cons source
-		  #+genera-release-7-2       (subdir "rel-7-2")
-		  #+genera-release-7-3       (subdir "rel-7-3") 
-		  #+genera-release-7-4       (subdir "rel-7-4")
-		  #+genera-release-8-0       (subdir "rel-8-0")
-		  #+genera-release-8-1       (subdir "rel-8-1")
-		  ))))
-
-#+Cloe-Runtime
-(defvar *pcl-directory* (pathname "/usr3/hornig/pcl/"))
-
-(defsystem pcl	   
-           *pcl-directory*
-  ;;
-  ;; file         load           compile      files which       port
-  ;;              environment    environment  force the of
-  ;;                                          recompilation
-  ;;                                          of this file
-  ;;                                          
-  (
-;  (rel-6-patches   t            t            ()                rel-6)
-;  (rel-7-1-patches t            t            ()                rel-7-1)
-   (rel-7-2-patches t            t            ()                rel-7-2)
-   (rel-8-patches   t            t            ()                rel-8)
-   (ti-patches      t            t            ()                ti)
-   (pyr-patches     t            t            ()                pyramid)
-   (xerox-patches   t            t            ()                xerox)
-   (kcl-patches     t            t            ()                kcl)
-   (ibcl-patches    t            t            ()                ibcl)
-   (gcl-patches     t            t            ()                gclisp)
-   
-   (pkg             t            t            ())
-   (sys-proclaim    t            t            ()                kcl)
-   (walk            (pkg)        (pkg)        ())
-   (iterate         t            t            ())
-   (macros          t            t            ())
-   (low             (pkg macros) t            (macros))
-   
-   
-   (genera-low     (low)         (low)        (low)            Genera)
-   (cloe-low	   (low)	 (low)	      (low)            Cloe)
-   (lucid-low      (low)         (low)        (low)            Lucid)
-   (Xerox-low      (low)         (low)        (low)            Xerox)
-   (ti-low         (low)         (low)        (low)            TI)
-   (vaxl-low       (low)         (low)        (low)            vaxlisp)
-   (kcl-low        (low)         (low)        (low)            KCL)
-   (ibcl-low       (low)         (low)        (low)            IBCL)
-   (excl-low       (low)         (low)        (low)            excl)
-   (cmu-low        (low)         (low)        (low)            CMU)
-   (hp-low         (low)         (low)        (low)            HP-HPLabs)
-   (gold-low       (low)         (low)        (low)            gclisp) 
-   (pyr-low        (low)         (low)        (low)            pyramid) 
-   (coral-low      (low)         (low)        (low)            coral)
-   
-   (fin         t                                   t (low))
-   (defclass    t                                   t (low))
-   (defs        t                                   t (defclass macros iterate))
-   (fngen       t                                   t (low))
-   (cache       t                                   t (low defs))
-   ;;(lap         t                                   t (low)    excl-sun4)
-   ;;(plap        t                                   t (low)    excl-sun4)
-   ;;(cpatch      t                                   t (low)    excl-sun4)
-   ;;(quadlap     t                                   t (low)    excl-sun4)
-   ;;(dlap        t                                   t (defs low fin cache lap) 
-   ;;	                                                         excl-sun4)
-   ;;#-excl-sun4
-   (dlisp       t                                   t (defs low fin cache))
-   (dlisp2      t                                   t (low fin cache dlisp))
-   (boot        t                                   t (defs fin))
-   (vector      t                                   t (boot defs cache fin))
-   (slots-boot  t                                   t (vector boot defs cache fin))
-   (combin      t                                   t (boot defs))
-   (dfun        t                                   t (boot low cache))
-   (fast-init   t                                   t (boot low))
-   (braid       (+ precom1 precom2)                 t (boot defs low fin cache))
-   (generic-functions t                             t (boot))
-   (slots       t                                   t (vector boot defs low cache fin))
-   (init        t                                   t (vector boot defs low fast-init))
-   (std-class   t                                   t (vector boot defs low cache fin slots))
-   (cpl         t                                   t (vector boot defs low cache fin slots))
-   (fsc         t                                   t (defclass boot defs low fin cache))
-   (methods     t                                   t (defclass boot defs low fin cache))
-   (fixup       t                                   t (boot defs low fin))
-   (defcombin   t                                   t (defclass boot defs low fin))
-   (ctypes      t                                   t (defclass defcombin))
-   #+ignore
-   (construct   t                                   t (defclass boot defs low))
-   (env         t                                   t (defclass boot defs low fin))
-   (compat      t                                   t ())
-   (precom1     (dlisp)                             t (defs low cache fin dfun))
-   (precom2     (dlisp)                             t (defs low cache fin dfun))
-   ))
-
-(defun compile-pcl (&optional m)
-  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
-	#+Lucid (lcl:*redefinition-action* nil)
-	#+excl  (excl::*redefinition-warnings* nil)
-	#+Genera (sys:inhibit-fdefine-warnings t)
-	)
-    (cond ((null m)        (operate-on-system 'pcl :compile))
-	  ((eq m :print)   (operate-on-system 'pcl :compile () t))
-	  ((eq m :query)   (operate-on-system 'pcl :query-compile))
-	  ((eq m :confirm) (operate-on-system 'pcl :confirm-compile))
-	  ((eq m 't)       (operate-on-system 'pcl :recompile))        
-	  ((listp m)       (operate-on-system 'pcl :compile-from m))
-	  ((symbolp m)     (operate-on-system 'pcl :recompile-some `(,m))))))
-
-(defun load-pcl (&optional m)
-  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
-	#+Lucid (lcl:*redefinition-action* nil)
-	#+excl  (excl::*redefinition-warnings* nil)
-	#+Genera (sys:inhibit-fdefine-warnings t)
-	)
-    (cond ((null m)      (operate-on-system 'pcl :load))
-	  ((eq m :query) (operate-on-system 'pcl :query-load)))))
-
-#+Genera
-;;; Make sure Genera bug mail contains the PCL bug data.  A little
-;;; kludgy, but what the heck.  If they didn't mean for people to do
-;;; this, they wouldn't have made private patch notes be flavored
-;;; objects, right?  Right.
-(progn
-  (scl:defflavor pcl-private-patch-info ((description)) ())
-  (scl:defmethod (sct::private-patch-info-description pcl-private-patch-info) ()
-    (or description
-	(setf description (string-append "PCL version: " *pcl-system-date*))))
-  (scl:defmethod (sct::private-patch-info-pathname pcl-private-patch-info) ()
-    *pcl-directory*)
-  (unless (find-if #'(lambda (x) (typep x 'pcl-private-patch-info))
-		   sct::*private-patch-info*)
-    (push (scl:make-instance 'pcl-private-patch-info)
-	  sct::*private-patch-info*)))
-
-(defun bug-report-info (&optional (stream *standard-output*))
-  (format stream "~&PCL system date: ~A~
-                  ~&Lisp Implementation type: ~A~
-                  ~&Lisp Implementation version: ~A~
-                  ~&*features*: ~S"
-	  *pcl-system-date*
-	  (lisp-implementation-type)
-	  (lisp-implementation-version)
-	  *features*))
-
-
-
-;;;;
-;;;
-;;; This stuff is not intended for external use.
-;;; 
-(defun rename-pcl ()
-  (dolist (f (cadr (get-system 'pcl)))
-    (let ((old nil)
-          (new nil))
-      (let ((*system-directory* *default-pathname-defaults*))
-        (setq old (make-source-pathname (car f))))
-      (setq new  (make-source-pathname (car f)))
-      (rename-file old new))))
-
-#+Genera
-(defun edit-pcl ()
-  (dolist (f (cadr (get-system 'pcl)))
-    (let ((*system-directory* *pcl-directory*))
-      (zwei:find-file (make-source-pathname (car f))))))
-
-#+Genera
-(defun hardcopy-pcl (&optional query-p)
-  (let ((files (mapcar #'(lambda (f)
-                           (setq f (car f))
-                           (and (or (not query-p)
-                                    (y-or-n-p "~A? " f))
-                                f))
-		       (cadr (get-system 'pcl))))
-        (b zwei:*interval*))
-    (unwind-protect
-        (dolist (f files)
-          (when f
-            (multiple-value-bind (ignore b)
-                (zwei:find-file (make-source-pathname f))
-              (zwei:hardcopy-buffer b))))
-      (zwei:make-buffer-current b))))
-
-
-;;;
-;;; unido!ztivax!dae@seismo.css.gov
-;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet
-;;; Victor@carmen.uu.se
-;;; mcvax!harlqn.co.uk!chris@uunet.UU.NET
-;;; 
-#+Genera
-(defun mail-pcl (to)
-  (let* ((original-buffer zwei:*interval*)
-	 (*system-directory* (pathname "vaxc:/user/ftp/pub/pcl/")
-			    ;(funcall (car (get-system 'pcl)))
-			     )
-         (files (list* 'defsys
-			'test
-			(caddr (get-system 'pcl))))
-         (total-number (length files))
-         (file nil)
-	 (number-of-lines 0)
-         (i 0)
-         (mail-buffer nil))
-    (unwind-protect
-        (loop
-           (when (null files) (return nil))
-           (setq file (pop files))
-           (incf i)
-           (multiple-value-bind (ignore b)
-               (zwei:find-file (make-source-pathname file))
-	     (setq number-of-lines (zwei:count-lines b))
-             (zwei:com-mail-internal t
-                                     :initial-to to
-                                     :initial-body b
-				     :initial-subject
-                                     (format nil
-				       "PCL file   ~A   (~A of ~A) ~D lines"
-				       file i total-number number-of-lines))
-             (setq mail-buffer zwei:*interval*)
-             (zwei:com-exit-com-mail)
-             (format t "~&Just sent ~A  (~A of ~A)." b i total-number)
-             (zwei:kill-buffer mail-buffer)))
-      (zwei:make-buffer-current original-buffer))))
-
-(defun reset-pcl-package ()		; Try to do this safely
-  (let* ((vars '(*pcl-directory* 
-		 *default-pathname-extensions* 
-		 *pathname-extensions*
-		 *redefined-functions*))
-	 (names (mapcar #'symbol-name vars))
-	 (values (mapcar #'symbol-value vars)))
-    (declare (special *redefined-functions*))
-    (reset-package "PCL")
-    (let ((pkg (find-package "SLOT-ACCESSOR-NAME")))
-      (when pkg
-	(do-symbols (sym pkg)
-	  (makunbound sym)
-	  (fmakunbound sym)
-	  (setf (symbol-plist sym) nil))))
-    (let ((pcl (find-package "PCL")))
-      (mapcar #'(lambda (name value)
-		  (let ((var (intern name pcl)))
-		    (proclaim `(special ,var))
-		    (set var value)))
-	      names values))      
-    (dolist (sym *redefined-functions*)
-      (setf (symbol-function sym) (get sym ':definition-before-pcl)))
-    nil))
-
-(defun reset-package (&optional (package-name "PCL"))
-  (let ((pkg (find-package package-name)))
-    (do-symbols (sym pkg)
-      (when (eq pkg (symbol-package sym))
-	(if (or (constantp sym)
-		#-cmu (member sym '(wrapper cache arg-info pv-table))
-		#+cmu
-		(or (c::info setf inverse sym)
-		    (c::info setf expander sym)
-		    (c::info type kind sym)
-		    (c::info type structure-info sym)
-		    (c::info type defined-structure-info sym)
-		    (c::info function macro-function sym)
-		    (c::info function compiler-macro-function sym)))
-	    (unintern sym pkg)
-	    (progn
-	      (makunbound sym)
-	      (unless (or (eq sym 'reset-pcl-package)
-			  (eq sym 'reset-package))
-		(fmakunbound sym)
-		#+cmu
-		(fmakunbound `(setf ,sym)))
-	      (setf (symbol-plist sym) nil)))))))
diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp
deleted file mode 100644
index ef35e338c6e3ef6df2ea4165459aea8be4fb786d..0000000000000000000000000000000000000000
--- a/pcl/dfun.lisp
+++ /dev/null
@@ -1,1531 +0,0 @@
-;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-Lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-#|
-
-This implementation of method lookup was redone in early August of 89.
-
-It has the following properties:
-
- - It's modularity makes it easy to modify the actual caching algorithm.
-   The caching algorithm is almost completely separated into the files
-   cache.lisp and dlap.lisp.  This file just contains the various uses
-   of it. There will be more tuning as we get more results from Luis'
-   measurements of caching behavior.
-
- - The metacircularity issues have been dealt with properly.  All of
-   PCL now grounds out properly.  Moreover, it is now possible to have
-   metaobject classes which are themselves not instances of standard
-   metaobject classes.
-
-** Modularity of the code **
-
-The actual caching algorithm is isolated in a modest number of functions.
-The code which generates cache lookup code is all found in cache.lisp and
-dlap.lisp.  Certain non-wrapper-caching special cases are in this file.
-
-
-** Handling the metacircularity **
-
-In CLOS, method lookup is the potential source of infinite metacircular
-regress.  The metaobject protocol specification gives us wide flexibility
-in how to address this problem.  PCL uses a technique which handles the
-problem not only for the metacircular language described in Chapter 3, but
-also for the PCL protocol which includes additional generic functions
-which control more aspects of the CLOS implementation.
-
-The source of the metacircular regress can be seen in a number of ways.
-One is that the specified method lookup protocol must, as part of doing
-the method lookup (or at least the cache miss case), itself call generic
-functions.  It is easy to see that if the method lookup for a generic
-function ends up calling that same generic function there can be trouble.
-
-Fortunately, there is an easy solution at hand.  The solution is based on 
-the restriction that portable code cannot change the class of a specified
-metaobject.  This restriction implies that for specified generic functions,
-the method lookup protocol they follow is fixed.  
-
-More precisely, for such specified generic functions, most generic functions
-that are called during their own method lookup will not run portable methods. 
-This allows the implementation to usurp the actual generic function call in
-this case.  In short, method lookup of a standard generic function, in the
-case where the only applicable methods are themselves standard doesn't
-have to do any method lookup to implement itself.
-
-And so, we are saved.
-
-|#
-
-
-;An alist in which each entry is of the form :
-;  (<generator> . (<subentry> ...))
-;Each subentry is of the form:
-;  (<args> <constructor> <system>)
-(defvar *dfun-constructors* ())			
-
-;If this is NIL, then the whole mechanism
-;for caching dfun constructors is turned
-;off.  The only time that makes sense is
-;when debugging LAP code. 
-(defvar *enable-dfun-constructor-caching* t)	
-
-(defun show-dfun-constructors ()
-  (format t "~&DFUN constructor caching is ~A." 
-	  (if *enable-dfun-constructor-caching*
-	      "enabled" "disabled"))
-  (dolist (generator-entry *dfun-constructors*)
-    (dolist (args-entry (cdr generator-entry))
-      (format t "~&~S ~S"
-	      (cons (car generator-entry) (caar args-entry))
-	      (caddr args-entry)))))
-
-(defvar *raise-metatypes-to-class-p* t)
-
-(defun get-dfun-constructor (generator &rest args)
-  (when (and *raise-metatypes-to-class-p*
-	     (member generator '(emit-checking emit-caching
-				 emit-in-checking-cache-p emit-constant-value)))
-    (setq args (cons (mapcar #'(lambda (mt)
-				 (if (eq mt 't)
-				     mt
-				     'class))
-			     (car args))
-		     (cdr args))))						  
-  (let* ((generator-entry (assq generator *dfun-constructors*))
-	 (args-entry (assoc args (cdr generator-entry) :test #'equal)))
-    (if (null *enable-dfun-constructor-caching*)
-	(apply (symbol-function generator) args)
-	(or (cadr args-entry)
-	    (multiple-value-bind (new not-best-p)
-		(apply (symbol-function generator) args)
-	      (let ((entry (list (copy-list args) new (unless not-best-p 'pcl)
-				 not-best-p)))
-		(if generator-entry
-		    (push entry (cdr generator-entry))
-		    (push (list generator entry)
-			  *dfun-constructors*)))
-	      (values new not-best-p))))))
-
-(defun load-precompiled-dfun-constructor (generator args system constructor)
-  (let* ((generator-entry (assq generator *dfun-constructors*))
-	 (args-entry (assoc args (cdr generator-entry) :test #'equal)))
-    (if args-entry
-	(when (fourth args-entry)
-	  (let* ((dfun-type (case generator
-			      (emit-checking 'checking)
-			      (emit-caching 'caching)
-			      (emit-constant-value 'constant-value)
-			      (emit-default-only 'default-method-only)))
-		 (metatypes (car args))
-		 (gfs (when dfun-type (gfs-of-type dfun-type))))
-	    (dolist (gf gfs)
-	      (when (and (equal metatypes (arg-info-metatypes (gf-arg-info gf)))
-			 (let ((gf-name (generic-function-name gf)))
-			   (and (not (eq gf-name 'slot-value-using-class))
-				(not (equal gf-name '(setf slot-value-using-class)))
-				(not (eq gf-name 'slot-boundp-using-class)))))
-		(update-dfun gf)))
-	    (setf (second args-entry) constructor)
-	    (setf (third args-entry) system)
-	    (setf (fourth args-entry) nil)))
-	(let ((entry (list args constructor system nil)))
-	  (if generator-entry
-	      (push entry (cdr generator-entry))
-	      (push (list generator entry) *dfun-constructors*))))))
-
-(defmacro precompile-dfun-constructors (&optional system)
-  (let ((*precompiling-lap* t))
-    `(progn
-       ,@(gathering1 (collecting)
-	   (dolist (generator-entry *dfun-constructors*)
-	     (dolist (args-entry (cdr generator-entry))
-	       (when (or (null (caddr args-entry))
-			 (eq (caddr args-entry) system))
-		 (when system (setf (caddr args-entry) system))
-		 (gather1
-		   (make-top-level-form `(precompile-dfun-constructor 
-					  ,(car generator-entry))
-					'(load)
-		     `(load-precompiled-dfun-constructor
-		       ',(car generator-entry)
-		       ',(car args-entry)
-		       ',system
-		       ,(apply (symbol-function (car generator-entry))
-			       (car args-entry))))))))))))
-
-
-;;;
-;;; When all the methods of a generic function are automatically generated
-;;; reader or writer methods a number of special optimizations are possible.
-;;; These are important because of the large number of generic functions of
-;;; this type.
-;;;
-;;; There are a number of cases:
-;;;
-;;;   ONE-CLASS-ACCESSOR
-;;;     In this case, the accessor generic function has only been called
-;;;     with one class of argument.  There is no cache vector, the wrapper
-;;;     of the one class, and the slot index are stored directly as closure
-;;;     variables of the discriminating function.  This case can convert to
-;;;     either of the next kind.
-;;;
-;;;   TWO-CLASS-ACCESSOR
-;;;     Like above, but two classes.  This is common enough to do specially.
-;;;     There is no cache vector.  The two classes are stored a separate
-;;;     closure variables.
-;;;
-;;;   ONE-INDEX-ACCESSOR
-;;;     In this case, the accessor generic function has seen more than one
-;;;     class of argument, but the index of the slot is the same for all
-;;;     the classes that have been seen.  A cache vector is used to store
-;;;     the wrappers that have been seen, the slot index is stored directly
-;;;     as a closure variable of the discriminating function.  This case
-;;;     can convert to the next kind.
-;;;
-;;;   N-N-ACCESSOR
-;;;     This is the most general case.  In this case, the accessor generic
-;;;     function has seen more than one class of argument and more than one
-;;;     slot index.  A cache vector stores the wrappers and corresponding
-;;;     slot indexes.  Because each cache line is more than one element
-;;;     long, a cache lock count is used.
-;;;
-(defstruct (dfun-info
-	     (:constructor nil)
-	     (:print-function print-dfun-info))
-  (cache nil))
-
-(defun print-dfun-info (dfun-info stream depth)
-  (declare (ignore depth) (stream stream))
-  (printing-random-thing (dfun-info stream)
-    (format stream "~A" (type-of dfun-info))))
-
-(defstruct (no-methods
-	     (:constructor no-methods-dfun-info ())
-	     (:include dfun-info)))
-
-(defstruct (initial
-	     (:constructor initial-dfun-info ())
-	     (:include dfun-info)))
-
-(defstruct (initial-dispatch
-	     (:constructor initial-dispatch-dfun-info ())
-	     (:include dfun-info)))
-
-(defstruct (dispatch
-	     (:constructor dispatch-dfun-info ())
-	     (:include dfun-info)))
-
-(defstruct (default-method-only
-	     (:constructor default-method-only-dfun-info ())
-	     (:include dfun-info)))
-
-;without caching:
-;  dispatch one-class two-class default-method-only
-
-;with caching:
-;  one-index n-n checking caching
-
-;accessor:
-;  one-class two-class one-index n-n
-(defstruct (accessor-dfun-info
-	     (:constructor nil)
-	     (:include dfun-info))
-  accessor-type) ; (member reader writer)
-
-(defmacro dfun-info-accessor-type (di)
-  `(accessor-dfun-info-accessor-type ,di))
-
-(defstruct (one-index-dfun-info
-	     (:constructor nil)
-	     (:include accessor-dfun-info))
-  index)
-
-(defmacro dfun-info-index (di)
-  `(one-index-dfun-info-index ,di))
-
-(defstruct (n-n
-	     (:constructor n-n-dfun-info (accessor-type cache))
-	     (:include accessor-dfun-info)))
-
-(defstruct (one-class
-	     (:constructor one-class-dfun-info (accessor-type index wrapper0))
-	     (:include one-index-dfun-info))
-  wrapper0)
-
-(defmacro dfun-info-wrapper0 (di)
-  `(one-class-wrapper0 ,di))
-
-(defstruct (two-class
-	     (:constructor two-class-dfun-info (accessor-type index wrapper0 wrapper1))
-	     (:include one-class))
-  wrapper1)
-
-(defmacro dfun-info-wrapper1 (di)
-  `(two-class-wrapper1 ,di))
-
-(defstruct (one-index
-	     (:constructor one-index-dfun-info
-			   (accessor-type index cache))
-	     (:include one-index-dfun-info)))	     
-
-(defstruct (checking
-	     (:constructor checking-dfun-info (function cache))
-	     (:include dfun-info))
-  function)
-
-(defmacro dfun-info-function (di)
-  `(checking-function ,di))
-
-(defstruct (caching
-	     (:constructor caching-dfun-info (cache))
-	     (:include dfun-info)))
-
-(defstruct (constant-value
-	     (:constructor constant-value-dfun-info (cache))
-	     (:include dfun-info)))
-
-(defmacro dfun-update (generic-function function &rest args)
-  `(multiple-value-bind (dfun cache info)
-       (funcall ,function ,generic-function ,@args)
-     (update-dfun ,generic-function dfun cache info)))
-
-(defun accessor-miss-function (gf dfun-info)
-  (ecase (dfun-info-accessor-type dfun-info)
-    (reader
-      #'(lambda (arg)
-	   (declare (pcl-fast-call))
-	   (accessor-miss gf nil arg dfun-info)))
-    (writer
-     #'(lambda (new arg)
-	 (declare (pcl-fast-call))
-	 (accessor-miss gf new arg dfun-info)))))
-
-;;;
-;;; ONE-CLASS-ACCESSOR
-;;;
-(defun make-one-class-accessor-dfun (gf type wrapper index)
-  (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer))
-	(dfun-info (one-class-dfun-info type index wrapper)))
-    (values
-     (funcall (get-dfun-constructor emit (consp index))
-	      wrapper index
-	      (accessor-miss-function gf dfun-info))
-     nil
-     dfun-info)))
-
-;;;
-;;; TWO-CLASS-ACCESSOR
-;;;
-(defun make-two-class-accessor-dfun (gf type w0 w1 index)
-  (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer))
-	(dfun-info (two-class-dfun-info type index w0 w1)))
-    (values
-     (funcall (get-dfun-constructor emit (consp index))
-	      w0 w1 index
-	      (accessor-miss-function gf dfun-info))
-     nil
-     dfun-info)))
-
-;;;
-;;; std accessors same index dfun
-;;;
-(defun make-one-index-accessor-dfun (gf type index &optional cache)
-  (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers))
-	 (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4)))
-	 (dfun-info (one-index-dfun-info type index cache)))
-    (declare (type cache cache))
-    (values
-     (funcall (get-dfun-constructor emit (consp index))
-	      cache
-	      index
-	      (accessor-miss-function gf dfun-info))
-     cache
-     dfun-info)))
-
-(defun make-final-one-index-accessor-dfun (gf type index table)
-  (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn)))
-    (make-one-index-accessor-dfun gf type index cache)))
-
-(defun one-index-limit-fn (nlines)
-  (default-limit-fn nlines))
-
-
-(defun make-n-n-accessor-dfun (gf type &optional cache)
-  (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers))
-	 (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2)))
-	 (dfun-info (n-n-dfun-info type cache)))
-    (declare (type cache cache))
-    (values
-     (funcall (get-dfun-constructor emit)
-	      cache
-	      (accessor-miss-function gf dfun-info))
-     cache
-     dfun-info)))
-
-(defun make-final-n-n-accessor-dfun (gf type table)
-  (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn)))
-    (make-n-n-accessor-dfun gf type cache)))
-
-(defun n-n-accessors-limit-fn (nlines)
-  (default-limit-fn nlines))
-
-(defun make-checking-dfun (generic-function function &optional cache)
-  (unless cache
-    (when (use-caching-dfun-p generic-function)
-      (return-from make-checking-dfun (make-caching-dfun generic-function)))
-    (when (use-dispatch-dfun-p generic-function)
-      (return-from make-checking-dfun (make-dispatch-dfun generic-function))))
-  (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info generic-function)
-    (declare (ignore nreq))
-    (if (every #'(lambda (mt) (eq mt 't)) metatypes)
-	(let ((dfun-info (default-method-only-dfun-info)))
-	  (values 
-	   (funcall (get-dfun-constructor 'emit-default-only metatypes applyp)
-		    function)
-	   nil
-	   dfun-info))
-	(let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2)))
-	       (dfun-info (checking-dfun-info function cache)))
-	  (values
-	   (funcall (get-dfun-constructor 'emit-checking metatypes applyp)
-		    cache
-		    function 
-		    #'(lambda (&rest args)
-			(declare (pcl-fast-call))
-			#+copy-&rest-arg (setq args (copy-list args))
-			(checking-miss generic-function args dfun-info)))
-	   cache
-	   dfun-info)))))
-
-(defun make-final-checking-dfun (generic-function function
-						  classes-list new-class)
-  (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function))))
-    (if (every #'(lambda (mt) (eq mt 't)) metatypes)
-	(values #'(lambda (&rest args)
-		    #+copy-&rest-arg (setq args (copy-list args))
-		    (invoke-emf function args))
-		nil (default-method-only-dfun-info))
-	(let ((cache (make-final-ordinary-dfun-internal 
-		      generic-function nil #'checking-limit-fn 
-		      classes-list new-class)))
-	  (make-checking-dfun generic-function function cache)))))
-
-(defun use-default-method-only-dfun-p (generic-function)
-  (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info generic-function)
-    (declare (ignore nreq applyp nkeys))
-    (every #'(lambda (mt) (eq mt 't)) metatypes)))
-
-(defun use-caching-dfun-p (generic-function)
-  (some #'(lambda (method)
-	    (let ((fmf (if (listp method)
-			   (third method)
-			   (method-fast-function method))))
-	      (method-function-get fmf ':slot-name-lists)))
-	(if (early-gf-p generic-function)
-	    (early-gf-methods generic-function)
-	    (generic-function-methods generic-function))))
-
-(defun checking-limit-fn (nlines)
-  (default-limit-fn nlines))
-
-
-;;;
-;;;
-;;;
-(defun make-caching-dfun (generic-function &optional cache)
-  (unless cache
-    (when (use-constant-value-dfun-p generic-function)
-      (return-from make-caching-dfun (make-constant-value-dfun generic-function)))
-    (when (use-dispatch-dfun-p generic-function)
-      (return-from make-caching-dfun (make-dispatch-dfun generic-function))))
-  (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info generic-function)
-    (declare (ignore nreq))
-    (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
-	   (dfun-info (caching-dfun-info cache)))
-      (values
-       (funcall (get-dfun-constructor 'emit-caching metatypes applyp)
-		cache
-		#'(lambda (&rest args)
-		    (declare (pcl-fast-call))
-		    #+copy-&rest-arg (setq args (copy-list args))
-		    (caching-miss generic-function args dfun-info)))
-       cache
-       dfun-info))))
-
-(defun make-final-caching-dfun (generic-function classes-list new-class)
-  (let ((cache (make-final-ordinary-dfun-internal 
-		generic-function t #'caching-limit-fn
-		classes-list new-class)))
-    (make-caching-dfun generic-function cache)))
-
-(defun caching-limit-fn (nlines)
-  (default-limit-fn nlines))
-
-(defun insure-caching-dfun (gf)
-  (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info gf)
-    (declare (ignore nreq nkeys))
-    (when (and metatypes
-	       (not (null (car metatypes)))
-	       (dolist (mt metatypes nil)
-		 (unless (eq mt 't) (return t))))
-      (get-dfun-constructor 'emit-caching metatypes applyp))))
-
-(defun use-constant-value-dfun-p (gf &optional boolean-values-p)
-  (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info gf)
-    (declare (ignore nreq metatypes nkeys))
-    (let* ((early-p (early-gf-p gf))
-	   (methods (if early-p
-			(early-gf-methods gf)
-			(generic-function-methods gf)))
-	   (default '(unknown)))
-      (and (null applyp)
-	   (or (not (eq *boot-state* 'complete))
-	       (compute-applicable-methods-emf-std-p gf))
-	   (notany #'(lambda (method)
-		       (or (and (eq *boot-state* 'complete)
-				(some #'eql-specializer-p
-				      (method-specializers method)))
-			   (let ((value (method-function-get 
-					 (if early-p
-					     (or (third method) (second method))
-					     (or (method-fast-function method)
-						 (method-function method)))
-					 :constant-value default)))
-			     (if boolean-values-p
-				 (not (or (eq value 't) (eq value nil)))
-				 (eq value default)))))
-		   methods)))))
-
-(defun make-constant-value-dfun (generic-function &optional cache)
-  (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info generic-function)
-    (declare (ignore nreq applyp))
-    (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
-	   (dfun-info (constant-value-dfun-info cache)))
-      (values
-       (funcall (get-dfun-constructor 'emit-constant-value metatypes)
-		cache
-		#'(lambda (&rest args)
-		    (declare (pcl-fast-call))
-		    #+copy-&rest-arg (setq args (copy-list args))
-		    (constant-value-miss generic-function args dfun-info)))
-       cache
-       dfun-info))))
-
-(defun make-final-constant-value-dfun (generic-function classes-list new-class)
-  (let ((cache (make-final-ordinary-dfun-internal 
-		generic-function :constant-value #'caching-limit-fn
-		classes-list new-class)))
-    (make-constant-value-dfun generic-function cache)))
-
-(defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
-  (when (eq *boot-state* 'complete)
-    (unless caching-p
-      (let* ((methods (generic-function-methods gf))
-	     (arg-info (gf-arg-info gf))
-	     (mt (arg-info-metatypes arg-info))
-	     (nreq (length mt)))
-	;;Is there a position at which every specializer is eql or non-standard?
-	(dotimes (i nreq nil)
-	  (when (not (eq 't (nth i mt)))
-	    (let ((some-std-class-specl-p nil))
-	      (dolist (method methods)
-		(let ((specl (nth i (method-specializers method))))
-		  (when (and (not (eql-specializer-p specl))
-			     (let ((sclass (specializer-class specl)))
-			       (or (null (class-finalized-p sclass))
-				   (member *the-class-standard-object*
-					   (class-precedence-list sclass)))))
-		    (setq some-std-class-specl-p t))))
-	      (unless some-std-class-specl-p
-		(return-from use-dispatch-dfun-p t)))))))))
-
-(defun make-dispatch-dfun (gf)
-  (values (get-dispatch-function gf) nil (dispatch-dfun-info)))
-
-(defun get-dispatch-function (gf)
-  (let ((methods (generic-function-methods gf)))
-    (function-funcall (get-secondary-dispatch-function1 gf methods nil nil nil 
-							nil nil t)
-		      nil nil)))
-
-(defun make-final-dispatch-dfun (gf)
-  (make-dispatch-dfun gf))
-
-(defun update-dispatch-dfuns ()
-  (dolist (gf (gfs-of-type '(dispatch initial-dispatch)))
-    (dfun-update gf #'make-dispatch-dfun)))
-
-(defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache)
-  (let ((cache (or cache (get-cache nkeys valuep limit-fn
-				    (+ (hash-table-count table) 3)))))
-    (maphash #'(lambda (classes value)
-		 (setq cache (fill-cache cache
-					 (class-wrapper classes)
-					 value
-					 t)))
-	     table)
-    cache))
-
-(defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn
-							   classes-list new-class)
-  (let* ((arg-info (gf-arg-info generic-function))
-	 (nkeys (arg-info-nkeys arg-info))
-	 (new-class (and new-class
-			 (equal (type-of (gf-dfun-info generic-function))
-				(cond ((eq valuep t) 'caching)
-				      ((eq valuep :constant-value) 'constant-value)
-				      ((null valuep) 'checking)))
-			 new-class))
-	 (cache (if new-class
-		    (copy-cache (gf-dfun-cache generic-function))
-		    (get-cache nkeys (not (null valuep)) limit-fn 4))))
-      (make-emf-cache generic-function valuep cache classes-list new-class)))
-
-(defvar *dfun-miss-gfs-on-stack* ())
-
-(defmacro dfun-miss ((gf args wrappers invalidp nemf
-		      &optional type index caching-p applicable)
-		     &body body)
-  (unless applicable (setq applicable (gensym)))
-  `(multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp 
-			 ,@(when type `(,type ,index)))
-       (cache-miss-values ,gf ,args ',(cond (caching-p 'caching)
-					    (type 'accessor)
-					    (t 'checking)))
-     (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
-       (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
-	 ,@body))
-     (invoke-emf ,nemf ,args)))
-
-;;;
-;;; The dynamically adaptive method lookup algorithm is implemented is
-;;; implemented as a kind of state machine.  The kinds of discriminating
-;;; function is the state, the various kinds of reasons for a cache miss
-;;; are the state transitions.
-;;;
-;;; The code which implements the transitions is all in the miss handlers
-;;; for each kind of dfun.  Those appear here.
-;;;
-;;; Note that within the states that cache, there are dfun updates which
-;;; simply select a new cache or cache field.  Those are not considered
-;;; as state transitions.
-;;; 
-(defvar *lazy-dfun-compute-p* t)
-(defvar *early-p* nil)
-
-(defun make-initial-dfun (gf)
-  (let ((initial-dfun 
-	 #'(lambda (&rest args)
-	     #+copy-&rest-arg (setq args (copy-list args))
-	     (initial-dfun gf args))))
-    (multiple-value-bind (dfun cache info)
-	(if (and (eq *boot-state* 'complete)
-		 (compute-applicable-methods-emf-std-p gf))
-	    (let* ((caching-p (use-caching-dfun-p gf))
-		   (classes-list (precompute-effective-methods 
-				  gf caching-p
-				  (not *lazy-dfun-compute-p*))))
-	      (if *lazy-dfun-compute-p*
-		  (cond ((use-dispatch-dfun-p gf caching-p)
-			 (values initial-dfun nil (initial-dispatch-dfun-info)))
-			(caching-p
-			 (insure-caching-dfun gf)
-			 (values initial-dfun nil (initial-dfun-info)))
-			(t
-			 (values initial-dfun nil (initial-dfun-info))))
-		  (make-final-dfun-internal gf classes-list)))
-	    (let ((arg-info (if (early-gf-p gf)
-				(early-gf-arg-info gf)
-				(gf-arg-info gf)))
-		  (type nil))
-	      (if (and (gf-precompute-dfun-and-emf-p arg-info)
-		       (setq type (final-accessor-dfun-type gf)))
-		  (if *early-p*
-		      (values (make-early-accessor gf type) nil nil)
-		      (make-final-accessor-dfun gf type))
-		  (values initial-dfun nil (initial-dfun-info)))))
-      (set-dfun gf dfun cache info))))
-
-(defun make-early-accessor (gf type)
-  (let* ((methods (early-gf-methods gf))
-	 (slot-name (early-method-standard-accessor-slot-name (car methods))))
-    (ecase type
-      (reader #'(lambda (instance)
-		  (let* ((class (class-of instance))
-			 (class-name (bootstrap-get-slot 'class class 'name)))
-		    (bootstrap-get-slot class-name instance slot-name))))
-      (writer #'(lambda (new-value instance)
-		  (let* ((class (class-of instance))
-			 (class-name (bootstrap-get-slot 'class class 'name)))
-		    (bootstrap-set-slot class-name instance slot-name new-value)))))))
-
-(defun initial-dfun (gf args)
-  (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
-    (cond (invalidp)
-	  ((and ntype nindex)
-	   (dfun-update 
-	    gf #'make-one-class-accessor-dfun ntype wrappers nindex))
-	  ((use-caching-dfun-p gf)
-	   (dfun-update gf #'make-caching-dfun))
-	  (t
-	   (dfun-update 
-	    gf #'make-checking-dfun
-	    ;; nemf is suitable only for caching, have to do this:
-	    (cache-miss-values gf args 'checking))))))
-
-(defun make-final-dfun (gf &optional classes-list)
-  (multiple-value-bind (dfun cache info)
-      (make-final-dfun-internal gf classes-list)
-    (set-dfun gf dfun cache info)))
-
-(defvar *new-class* nil)
-
-(defvar *free-hash-tables* (mapcar #'list '(eq equal eql)))
-
-(defmacro with-hash-table ((table test) &body forms)
-  `(let* ((.free. (assoc ',test *free-hash-tables*))
-	  (,table (if (cdr .free.)
-		      (pop (cdr .free.))
-		      (make-hash-table :test ',test))))
-     (multiple-value-prog1
-	 (progn ,@forms)
-       (clrhash ,table)
-       (push ,table (cdr .free.)))))
-
-(defmacro with-eq-hash-table ((table) &body forms)
-  `(with-hash-table (,table eq) ,@forms))
-
-(defun final-accessor-dfun-type (gf)
-  (let ((methods (if (early-gf-p gf)
-		     (early-gf-methods gf)
-		     (generic-function-methods gf))))
-    (cond ((every #'(lambda (method) 
-		      (if (consp method)
-			  (eq *the-class-standard-reader-method*
-			      (early-method-class method))
-			  (standard-reader-method-p method)))
-		  methods)
-	   'reader)
-	  ((every #'(lambda (method) 
-		      (if (consp method)
-			  (eq *the-class-standard-writer-method*
-			      (early-method-class method))
-			  (standard-writer-method-p method)))
-		  methods)
-	   'writer))))
-
-(defun make-final-accessor-dfun (gf type &optional classes-list new-class)
-  (with-eq-hash-table (table)
-    (multiple-value-bind (table all-index first second size no-class-slots-p)
-	(make-accessor-table gf type table)
-      (if table
-	  (cond ((= size 1)
-		 (let ((w (class-wrapper first)))
-		   (make-one-class-accessor-dfun gf type w all-index)))
-		((and (= size 2) (or (integerp all-index) (consp all-index)))
-		 (let ((w0 (class-wrapper first))
-		       (w1 (class-wrapper second)))
-		   (make-two-class-accessor-dfun gf type w0 w1 all-index)))
-		((or (integerp all-index) (consp all-index))
-		 (make-final-one-index-accessor-dfun 
-		  gf type all-index table))
-		(no-class-slots-p
-		 (make-final-n-n-accessor-dfun gf type table))
-		(t
-		 (make-final-caching-dfun gf classes-list new-class)))
-	  (make-final-caching-dfun gf classes-list new-class)))))
-
-(defun make-final-dfun-internal (gf &optional classes-list)
-  (let ((methods (generic-function-methods gf)) type
-	(new-class *new-class*) (*new-class* nil)
-	specls all-same-p)
-    (cond ((null methods)
-	   (values
-	    #'(lambda (&rest args)
-		(apply #'no-applicable-method gf args))
-	    nil
-	    (no-methods-dfun-info)))
-	  ((setq type (final-accessor-dfun-type gf))
-	   (make-final-accessor-dfun gf type classes-list new-class))
-	  ((and (not (and (every #'(lambda (specl) (eq specl *the-class-t*))
-				 (setq specls (method-specializers (car methods))))
-			  (setq all-same-p
-				(every #'(lambda (method)
-					   (and (equal specls
-						       (method-specializers method))))
-				       methods))))
-		(use-constant-value-dfun-p gf))
-	   (make-final-constant-value-dfun gf classes-list new-class))
-	  ((use-dispatch-dfun-p gf)
-	   (make-final-dispatch-dfun gf))
-	  ((and all-same-p (not (use-caching-dfun-p gf)))
-	   (let ((emf (get-secondary-dispatch-function gf methods nil)))
-	     (make-final-checking-dfun gf emf classes-list new-class)))
-	  (t
-	   (make-final-caching-dfun gf classes-list new-class)))))
-
-(defun accessor-miss (gf new object dfun-info)
-  (let* ((ostate (type-of dfun-info))
-	 (otype (dfun-info-accessor-type dfun-info))
-	 oindex ow0 ow1 cache
-	 (args (ecase otype			;The congruence rules assure
-		(reader (list object))		;us that this is safe despite
-		(writer (list new object)))))	;not knowing the new type yet.
-    (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
-      ;;
-      ;; The following lexical functions change the state of the
-      ;; dfun to that which is their name.  They accept arguments
-      ;; which are the parameters of the new state, and get other
-      ;; information from the lexical variables bound above.
-      ;; 
-      (flet ((two-class (index w0 w1)
-	       (when (zerop (random 2)) (psetf w0 w1 w1 w0))
-	       (dfun-update gf #'make-two-class-accessor-dfun ntype w0 w1 index))
-	     (one-index (index &optional cache)
-	       (dfun-update gf #'make-one-index-accessor-dfun ntype index cache))
-	     (n-n (&optional cache)
-	       (if (consp nindex)
-		   (dfun-update gf #'make-checking-dfun nemf)
-		   (dfun-update gf #'make-n-n-accessor-dfun ntype cache)))
-	     (caching () ; because cached accessor emfs are much faster for accessors
-	       (dfun-update gf #'make-caching-dfun))
-	     ;;
-	     (do-fill (update-fn)
-	       (let ((ncache (fill-cache cache wrappers nindex)))
-		 (unless (eq ncache cache)
-		   (funcall update-fn ncache)))))
-	(cond ((null ntype)
-	       (caching))
-	      ((or invalidp
-		   (null nindex)))
-	      ((not (or (std-instance-p object)
-			(fsc-instance-p object)))
-	       (caching))
-	      ((or (neq ntype otype) (listp wrappers))
-	       (caching))
-	      (t
-	       (ecase ostate
-		 (one-class
-		  (setq oindex (dfun-info-index dfun-info))
-		  (setq ow0 (dfun-info-wrapper0 dfun-info))
-		  (unless (eq ow0 wrappers)
-		    (if (eql nindex oindex)
-			(two-class nindex ow0 wrappers)
-			(n-n))))
-		 (two-class
-		  (setq oindex (dfun-info-index dfun-info))
-		  (setq ow0 (dfun-info-wrapper0 dfun-info))
-		  (setq ow1 (dfun-info-wrapper1 dfun-info))
-		  (unless (or (eq ow0 wrappers) (eq ow1 wrappers))
-		    (if (eql nindex oindex)
-			(one-index nindex)
-			(n-n))))
-		 (one-index
-		  (setq oindex (dfun-info-index dfun-info))
-		  (setq cache (dfun-info-cache dfun-info))
-		  (if (eql nindex oindex)
-		      (do-fill #'(lambda (ncache)
-				   (one-index nindex ncache)))
-		      (n-n)))
-		 (n-n
-		  (setq cache (dfun-info-cache dfun-info))
-		  (if (consp nindex)
-		      (caching)
-		      (do-fill #'n-n))))))))))
-
-(defun checking-miss (generic-function args dfun-info)
-  (let ((oemf (dfun-info-function dfun-info))
-	(cache (dfun-info-cache dfun-info)))
-    (dfun-miss (generic-function args wrappers invalidp nemf)
-      (cond (invalidp)
-	    ((eq oemf nemf)
-	     (let ((ncache (fill-cache cache wrappers nil)))
-	       (unless (eq ncache cache)
-		 (dfun-update generic-function #'make-checking-dfun 
-			      nemf ncache))))
-	    (t
-	     (dfun-update generic-function #'make-caching-dfun))))))
-
-(defun caching-miss (generic-function args dfun-info)
-  (let ((ocache (dfun-info-cache dfun-info)))
-    (dfun-miss (generic-function args wrappers invalidp emf nil nil t)
-      (cond (invalidp)
-	    (t
-	     (let ((ncache (fill-cache ocache wrappers emf)))
-	       (unless (eq ncache ocache)
-		 (dfun-update generic-function 
-			      #'make-caching-dfun ncache))))))))
-
-(defun constant-value-miss (generic-function args dfun-info)
-  (let ((ocache (dfun-info-cache dfun-info)))
-    (dfun-miss (generic-function args wrappers invalidp emf nil nil t)
-      (cond (invalidp)
-	    (t
-	     (let* ((function (typecase emf
-				(fast-method-call (fast-method-call-function emf))
-				(method-call (method-call-function emf))))
-		    (value (method-function-get function :constant-value))
-		    (ncache (fill-cache ocache wrappers value)))
-	       (unless (eq ncache ocache)
-		 (dfun-update generic-function
-			      #'make-constant-value-dfun ncache))))))))
-
-;;; Given a generic function and a set of arguments to that generic function,
-;;; returns a mess of values.
-;;;
-;;;  <function>   The compiled effective method function for this set of
-;;;               arguments. 
-;;;
-;;;  <applicable> Sorted list of applicable methods. 
-;;;
-;;;  <wrappers>   Is a single wrapper if the generic function has only
-;;;               one key, that is arg-info-nkeys of the arg-info is 1.
-;;;               Otherwise a list of the wrappers of the specialized
-;;;               arguments to the generic function.
-;;;
-;;;               Note that all these wrappers are valid.  This function
-;;;               does invalid wrapper traps when it finds an invalid
-;;;               wrapper and then returns the new, valid wrapper.
-;;;
-;;;  <invalidp>   True if any of the specialized arguments had an invalid
-;;;               wrapper, false otherwise.
-;;;
-;;;  <type>       READER or WRITER when the only method that would be run
-;;;               is a standard reader or writer method.  To be specific,
-;;;               the value is READER when the method combination is eq to
-;;;               *standard-method-combination*; there are no applicable
-;;;               :before, :after or :around methods; and the most specific
-;;;               primary method is a standard reader method.
-;;;
-;;;  <index>      If <type> is READER or WRITER, and the slot accessed is
-;;;               an :instance slot, this is the index number of that slot
-;;;               in the object argument.
-;;;
-(defun cache-miss-values (gf args state)
-  (if (null (if (early-gf-p gf)
-		(early-gf-methods gf)
-		(generic-function-methods gf)))
-      (apply #'no-applicable-method gf args)
-      (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
-	  (get-generic-function-info gf)
-	(declare (ignore nreq applyp nkeys))
-	(with-dfun-wrappers (args metatypes)
-	  (dfun-wrappers invalid-wrapper-p wrappers classes types)
-	  (error "The function ~S requires at least ~D arguments"
-		 gf (length metatypes))
-	  (multiple-value-bind (emf methods accessor-type index)
-	      (cache-miss-values-internal gf arg-info wrappers classes types state)
-	    (values emf methods
-		    dfun-wrappers
-		    invalid-wrapper-p
-		    accessor-type index))))))
-
-(defun cache-miss-values-internal (gf arg-info wrappers classes types state)
-  (let* ((for-accessor-p (eq state 'accessor))
-	 (for-cache-p (or (eq state 'caching) (eq state 'accessor)))
-	 (cam-std-p (or (null arg-info)
-			(gf-info-c-a-m-emf-std-p arg-info))))
-    (multiple-value-bind (methods all-applicable-and-sorted-p)
-	(if cam-std-p
-	    (compute-applicable-methods-using-types gf types)
-	    (compute-applicable-methods-using-classes gf classes))
-      (let ((emf (if (or cam-std-p all-applicable-and-sorted-p)
-		     (function-funcall (get-secondary-dispatch-function1
-					gf methods types nil (and for-cache-p wrappers)
-					all-applicable-and-sorted-p)
-				       nil (and for-cache-p wrappers))
-		     (default-secondary-dispatch-function gf))))
-	(multiple-value-bind (index accessor-type)
-	    (and for-accessor-p all-applicable-and-sorted-p methods
-		 (accessor-values gf arg-info classes methods))
-	  (values (if (integerp index) index emf)
-		  methods accessor-type index))))))
-
-(defun accessor-values (gf arg-info classes methods)
-  (declare (ignore gf))
-  (let* ((accessor-type (gf-info-simple-accessor-type arg-info))
-	 (accessor-class (case accessor-type
-			   (reader (car classes))
-			   (writer (cadr classes))
-			   (boundp (car classes)))))
-    (accessor-values-internal accessor-type accessor-class methods)))
-
-(defun accessor-values1 (gf accessor-type accessor-class)
-  (let* ((type `(class-eq ,accessor-class))
-	 (types (if (eq accessor-type 'writer) `(t ,type) `(,type)))
-	 (methods (compute-applicable-methods-using-types gf types)))
-    (accessor-values-internal accessor-type accessor-class methods)))
-
-(defun accessor-values-internal (accessor-type accessor-class methods)
-  (let* ((meth (car methods))
-	 (early-p (not (eq *boot-state* 'complete)))
-	 (slot-name (when accessor-class
-		      (if (consp meth)
-			  (and (early-method-standard-accessor-p meth)
-			       (early-method-standard-accessor-slot-name meth))
-			  (and (member *the-class-standard-object*
-				       (if early-p
-					   (early-class-precedence-list accessor-class)
-					   (class-precedence-list accessor-class)))
-			       (if early-p
-				   (not (eq *the-class-standard-method*
-					    (early-method-class meth)))
-				   (standard-accessor-method-p meth))
-			       (if early-p
-				   (early-accessor-method-slot-name meth)
-				   (accessor-method-slot-name meth))))))
-	 (slotd (and accessor-class
-		     (if early-p
-			 (dolist (slot (early-class-slotds accessor-class) nil)
-			   (when (eql slot-name (early-slot-definition-name slot))
-			     (return slot)))
-			 (find-slot-definition accessor-class slot-name)))))
-    (when (and slotd
-	       (or early-p
-		   (slot-accessor-std-p slotd accessor-type)))
-      (values (if early-p
-		  (early-slot-definition-location slotd) 
-		  (slot-definition-location slotd))
-	      accessor-type))))
-
-(defun make-accessor-table (gf type &optional table)
-  (unless table (setq table (make-hash-table :test 'eq)))
-  (let ((methods (if (early-gf-p gf)
-		     (early-gf-methods gf)
-		     (generic-function-methods gf)))
-	(all-index nil)
-	(no-class-slots-p t)
-	(early-p (not (eq *boot-state* 'complete)))
-	first second (size 0))
-    (declare (fixnum size))
-    ;; class -> {(specl slotd)}
-    (dolist (method methods)
-      (let* ((specializers (if (consp method)
-			       (early-method-specializers method t)
-			       (method-specializers method)))
-	     (specl (if (eq type 'reader)
-			(car specializers)
-			(cadr specializers)))
-	     (specl-cpl (if early-p
-			    (early-class-precedence-list specl)
-			    (and (class-finalized-p specl)
-				 (class-precedence-list specl))))
-	     (so-p (member *the-class-standard-object* specl-cpl))
-	     (slot-name (if (consp method)
-			    (and (early-method-standard-accessor-p method)
-				 (early-method-standard-accessor-slot-name method))
-			    (accessor-method-slot-name method))))
-	(when (or (null specl-cpl)
-		  (member *the-class-structure-object* specl-cpl))
-	  (return-from make-accessor-table nil))
-	(maphash #'(lambda (class slotd)
-		     (let ((cpl (if early-p
-				    (early-class-precedence-list class)
-				    (class-precedence-list class))))
-		       (when (memq specl cpl)
-			 (unless (and (or so-p
-					  (member *the-class-standard-object* cpl))
-				      (or early-p
-					  (slot-accessor-std-p slotd type)))
-			   (return-from make-accessor-table nil))
-			 (push (cons specl slotd) (gethash class table)))))
-		 (gethash slot-name *name->class->slotd-table*))))
-    (maphash #'(lambda (class specl+slotd-list)
-		 (dolist (sclass (if early-p
-				    (early-class-precedence-list class)
-				    (class-precedence-list class)) 
-			  (error "This can't happen"))
-		   (let ((a (assq sclass specl+slotd-list)))
-		     (when a
-		       (let* ((slotd (cdr a))
-			      (index (if early-p
-					 (early-slot-definition-location slotd) 
-					 (slot-definition-location slotd))))
-			 (unless index (return-from make-accessor-table nil))
-			 (setf (gethash class table) index)
-			 (when (consp index) (setq no-class-slots-p nil))
-			 (setq all-index (if (or (null all-index)
-						 (eql all-index index))
-					     index t))
-			 (incf size)
-			 (cond ((= size 1) (setq first class))
-			       ((= size 2) (setq second class)))
-			 (return nil))))))
-	     table)
-    (values table all-index first second size no-class-slots-p)))
-
-(defun compute-applicable-methods-using-types (generic-function types)
-  (let ((definite-p t) (possibly-applicable-methods nil))
-    (dolist (method (if (early-gf-p generic-function)
-			(early-gf-methods generic-function)
-			(generic-function-methods generic-function)))
-      (let ((specls (if (consp method)
-			(early-method-specializers method t)
-			(method-specializers method)))
-	    (types types)
-	    (possibly-applicable-p t) (applicable-p t))
-	(dolist (specl specls)
-	  (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p)
-	      (specializer-applicable-using-type-p specl (pop types))
-	    (unless specl-applicable-p
-	      (setq applicable-p nil))
-	    (unless specl-possibly-applicable-p
-	      (setq possibly-applicable-p nil)
-	      (return nil))))
-	(when possibly-applicable-p
-	  (unless applicable-p (setq definite-p nil))
-	  (push method possibly-applicable-methods))))
-    (let ((precedence (arg-info-precedence (if (early-gf-p generic-function)
-					       (early-gf-arg-info generic-function)
-					       (gf-arg-info generic-function)))))
-      (values (sort-applicable-methods precedence
-				       (nreverse possibly-applicable-methods)
-				       types)
-	      definite-p))))
-
-(defun sort-applicable-methods (precedence methods types)
-  (sort-methods methods
-		precedence
-		#'(lambda (class1 class2 index)
-		    (let* ((class (type-class (nth index types)))
-			   (cpl (if (eq *boot-state* 'complete)
-				    (class-precedence-list class)
-				    (early-class-precedence-list class))))
-		      (if (memq class2 (memq class1 cpl))
-			  class1 class2)))))
-
-(defun sort-methods (methods precedence compare-classes-function)
-  (flet ((sorter (method1 method2)
-	   (dolist (index precedence)
-	     (let* ((specl1 (nth index (if (listp method1)
-					   (early-method-specializers method1 t)
-					   (method-specializers method1))))
-		    (specl2 (nth index (if (listp method2)
-					   (early-method-specializers method2 t)
-					   (method-specializers method2))))
-		    (order (order-specializers
-			     specl1 specl2 index compare-classes-function)))
-	       (when order
-		 (return-from sorter (eq order specl1)))))))
-    (stable-sort methods #'sorter)))
-
-(defun order-specializers (specl1 specl2 index compare-classes-function)
-  (let ((type1 (if (eq *boot-state* 'complete)
-		   (specializer-type specl1)
-		   (bootstrap-get-slot 'specializer specl1 'type)))
-	(type2 (if (eq *boot-state* 'complete)
-		   (specializer-type specl2)
-		   (bootstrap-get-slot 'specializer specl2 'type))))
-    (cond ((eq specl1 specl2)
-	   nil)
-	  ((atom type1)
-	   specl2)
-	  ((atom type2)
-	   specl1)
-	  (t
-	   (case (car type1)
-	     (class    (case (car type2)
-			 (class (funcall compare-classes-function specl1 specl2 index))
-			 (t specl2)))
-	     (prototype (case (car type2)
-			 (class (funcall compare-classes-function specl1 specl2 index))
-			 (t specl2)))
-	     (class-eq (case (car type2)
-			 (eql specl2)
-			 (class-eq nil)
-			 (class type1)))
-	     (eql      (case (car type2)
-			 (eql nil)
-			 (t specl1))))))))
-
-(defun map-all-orders (methods precedence function)
-  (let ((choices nil))
-    (flet ((compare-classes-function (class1 class2 index)
-	     (declare (ignore index))
-	     (let ((choice nil))
-	       (dolist (c choices nil)
-		 (when (or (and (eq (first c) class1)
-				(eq (second c) class2))
-			   (and (eq (first c) class2)
-				(eq (second c) class1)))
-		   (return (setq choice c))))
-	       (unless choice
-		 (setq choice
-		       (if (class-might-precede-p class1 class2)
-			   (if (class-might-precede-p class2 class1)
-			       (list class1 class2 nil t)
-			       (list class1 class2 t))
-			   (if (class-might-precede-p class2 class1)
-			       (list class2 class1 t)
-			       (let ((name1 (class-name class1))
-				     (name2 (class-name class2)))
-				 (if (and name1 name2 (symbolp name1) (symbolp name2)
-					  (string< (symbol-name name1)
-						   (symbol-name name2)))
-				     (list class1 class2 t)
-				     (list class2 class1 t))))))
-		 (push choice choices))
-	       (car choice))))
-      (loop (funcall function
-		     (sort-methods methods precedence #'compare-classes-function))
-	    (unless (dolist (c choices nil)
-		      (unless (third c)
-			(rotatef (car c) (cadr c))
-			(return (setf (third c) t))))
-	      (return nil))))))
-
-(defvar *in-precompute-effective-methods-p* nil)
-
-;used only in map-all-orders
-(defun class-might-precede-p (class1 class2)
-  (if (not *in-precompute-effective-methods-p*)
-      (not (member class1 (cdr (class-precedence-list class2))))
-      (class-can-precede-p class1 class2)))
-
-(defun compute-precedence (lambda-list nreq argument-precedence-order)
-  (if (null argument-precedence-order)
-      (let ((list nil))(dotimes (i nreq list) (push (- (1- nreq) i) list)))
-      (mapcar #'(lambda (x) (position x lambda-list)) argument-precedence-order)))
-
-(defun saut-and (specl type)
-  (let ((applicable nil)
-	(possibly-applicable t))
-    (dolist (type (cdr type))
-      (multiple-value-bind (appl poss-appl)
-	  (specializer-applicable-using-type-p specl type)
-	(when appl (return (setq applicable t)))
-	(unless poss-appl (return (setq possibly-applicable nil)))))
-    (values applicable possibly-applicable)))
-
-(defun saut-not (specl type)
-  (let ((ntype (cadr type)))
-    (values nil
-	    (case (car ntype)
-	      (class      (saut-not-class specl ntype))
-	      (class-eq   (saut-not-class-eq specl ntype))
-	      (prototype  (saut-not-prototype specl ntype))
-	      (eql        (saut-not-eql specl ntype))
-	      (t (error "~s cannot handle the second argument ~s"
-			'specializer-applicable-using-type-p type))))))
-
-(defun saut-not-class (specl ntype)
-  (let* ((class (type-class specl))
-	 (cpl (class-precedence-list class)))
-     (not (memq (cadr ntype) cpl))))
-
-(defun saut-not-prototype (specl ntype)
-  (let* ((class (case (car specl)
-		  (eql       (class-of (cadr specl)))
-		  (class-eq  (cadr specl))
-		  (prototype (cadr specl))
-		  (class     (cadr specl))))
-	 (cpl (class-precedence-list class)))
-     (not (memq (cadr ntype) cpl))))
-
-(defun saut-not-class-eq (specl ntype)
-  (let ((class (case (car specl)
-		 (eql      (class-of (cadr specl)))
-		 (class-eq (cadr specl)))))
-    (not (eq class (cadr ntype)))))
-
-(defun saut-not-eql (specl ntype)
-  (case (car specl)
-    (eql (not (eql (cadr specl) (cadr ntype))))
-    (t   t)))
-
-(defun class-applicable-using-class-p (specl type)
-  (let ((pred (memq specl (if (eq *boot-state* 'complete)
-			      (class-precedence-list type)
-			      (early-class-precedence-list type)))))
-    (values pred
-	    (or pred
-		(if (not *in-precompute-effective-methods-p*)
-		    ;; classes might get common subclass
-		    (superclasses-compatible-p specl type)
-		    ;; worry only about existing classes
-		    (classes-have-common-subclass-p specl type))))))
-
-(defun classes-have-common-subclass-p (class1 class2)
-  (or (eq class1 class2)
-      (let ((class1-subs (class-direct-subclasses class1)))
-	(or (memq class2 class1-subs)
-	    (dolist (class1-sub class1-subs nil)
-	      (when (classes-have-common-subclass-p class1-sub class2)
-		(return t)))))))
-
-(defun saut-class (specl type)
-  (case (car specl)
-    (class (class-applicable-using-class-p (cadr specl) (cadr type)))
-    (t     (values nil (let ((class (type-class specl)))
-			 (memq (cadr type)
-			       (class-precedence-list class)))))))
-
-(defun saut-class-eq (specl type)
-  (if (eq (car specl) 'eql)
-      (values nil (eq (class-of (cadr specl)) (cadr type)))
-      (let ((pred (case (car specl)
-		    (class-eq   
-		     (eq (cadr specl) (cadr type)))
-		    (class      
-		     (or (eq (cadr specl) (cadr type))
-			 (memq (cadr specl)
-			       (if (eq *boot-state* 'complete)
-				   (class-precedence-list (cadr type))
-				   (early-class-precedence-list (cadr type)))))))))
-	(values pred pred))))
-
-(defun saut-prototype (specl type)
-  (declare (ignore specl type))
-  (values nil nil)) ; fix this someday
-
-(defun saut-eql (specl type) 
-  (let ((pred (case (car specl)
-		(eql        (eql (cadr specl) (cadr type)))
-		(class-eq   (eq (cadr specl) (class-of (cadr type))))
-		(class      (memq (cadr specl)
-				  (let ((class (class-of (cadr type))))
-				    (if (eq *boot-state* 'complete)
-					(class-precedence-list class)
-					(early-class-precedence-list class))))))))
-    (values pred pred)))
-
-(defun specializer-applicable-using-type-p (specl type)
-  (setq specl (type-from-specializer specl))
-  (when (eq specl 't)
-    (return-from specializer-applicable-using-type-p (values t t)))
-  ;; This is used by c-a-m-u-t and generate-discrimination-net-internal,
-  ;; and has only what they need.
-  (if (or (atom type) (eq (car type) 't))
-      (values nil t)
-      (case (car type)
-	(and        (saut-and specl type))
-	(not        (saut-not specl type))
-	(class      (saut-class specl type))
-	(prototype  (saut-prototype specl type))
-	(class-eq   (saut-class-eq specl type))
-	(eql        (saut-eql specl type))
-	(t          (error "~s cannot handle the second argument ~s"
-			   'specializer-applicable-using-type-p type)))))
-
-(defun map-all-classes (function &optional (root 't))
-  (let ((braid-p (or (eq *boot-state* 'braid)
-		     (eq *boot-state* 'complete))))
-    (labels ((do-class (class)
-	       (mapc #'do-class 
-		     (if braid-p
-			 (class-direct-subclasses class)
-			 (early-class-direct-subclasses class)))
-	       (funcall function class)))
-      (do-class (if (symbolp root)
-		    (find-class root)
-		    root)))))
-
-;;;
-;;; NOTE: We are assuming a restriction on user code that the method
-;;;       combination must not change once it is connected to the
-;;;       generic function.
-;;;
-;;;       This has to be legal, because otherwise any kind of method
-;;;       lookup caching couldn't work.  See this by saying that this
-;;;       cache, is just a backing cache for the fast cache.  If that
-;;;       cache is legal, this one must be too.
-;;;
-;;; Don't clear this table!  
-(defvar *effective-method-table* (make-hash-table :test 'eq))
-
-(defun get-secondary-dispatch-function (gf methods types &optional 
-							 method-alist wrappers)
-  (function-funcall (get-secondary-dispatch-function1 
-		     gf methods types
-		     (not (null method-alist))
-		     (not (null wrappers))
-		     (not (methods-contain-eql-specializer-p methods)))
-		    method-alist wrappers))
-
-(defun get-secondary-dispatch-function1 (gf methods types method-alist-p wrappers-p
-					    &optional all-applicable-p
-					    (all-sorted-p t) function-p)
-  (if (null methods)
-      #'(lambda (method-alist wrappers)
-	  (declare (ignore method-alist wrappers))
-	  #'(lambda (&rest args)
-	      (apply #'no-applicable-method gf args)))
-      (let* ((key (car methods))
-	     (ht-value (or (gethash key *effective-method-table*)
-			   (setf (gethash key *effective-method-table*)
-				 (cons nil nil)))))
-	(if (and (null (cdr methods)) all-applicable-p ; the most common case
-		 (null method-alist-p) wrappers-p (not function-p))
-	    (or (car ht-value)
-		(setf (car ht-value)
-		      (get-secondary-dispatch-function2 
-		       gf methods types method-alist-p wrappers-p
-		       all-applicable-p all-sorted-p function-p)))
-	    (let ((akey (list methods
-			      (if all-applicable-p 'all-applicable types)
-			      method-alist-p wrappers-p function-p)))
-	      (or (cdr (assoc akey (cdr ht-value) :test #'equal))
-		  (let ((value (get-secondary-dispatch-function2 
-				gf methods types method-alist-p wrappers-p
-				all-applicable-p all-sorted-p function-p)))
-		    (push (cons akey value) (cdr ht-value))
-		    value)))))))
-
-(defun get-secondary-dispatch-function2 (gf methods types method-alist-p wrappers-p
-					    all-applicable-p all-sorted-p function-p)
-  (if (and all-applicable-p all-sorted-p (not function-p))
-      (if (eq *boot-state* 'complete)
-	  (let* ((combin (generic-function-method-combination gf))
-		 (effective (compute-effective-method gf combin methods)))
-	    (make-effective-method-function1 gf effective method-alist-p wrappers-p))
-	  (let ((effective (standard-compute-effective-method gf nil methods)))
-	    (make-effective-method-function1 gf effective method-alist-p wrappers-p)))
-      (let ((net (generate-discrimination-net 
-		  gf methods types all-sorted-p)))
-	(compute-secondary-dispatch-function1 gf net function-p))))
-
-(defun get-effective-method-function (gf methods &optional method-alist wrappers)
-  (function-funcall (get-secondary-dispatch-function1 gf methods nil 
-						      (not (null method-alist))
-						      (not (null wrappers))
-						      t)
-		    method-alist wrappers))
-
-(defun get-effective-method-function1 (gf methods &optional (sorted-p t))
-  (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))
-
-(defun methods-contain-eql-specializer-p (methods)
-  (and (eq *boot-state* 'complete)
-       (dolist (method methods nil)
-	 (when (dolist (spec (method-specializers method) nil)
-		 (when (eql-specializer-p spec) (return t)))
-	   (return t)))))
-
-(defun update-dfun (generic-function &optional dfun cache info)
-  (let* ((early-p (early-gf-p generic-function))
-	 (gf-name (if early-p
-		      (early-gf-name generic-function)
-		      (generic-function-name generic-function)))
-	 (ocache (gf-dfun-cache generic-function)))
-    (set-dfun generic-function dfun cache info)
-    (let* ((dfun (if early-p
-		     (or dfun (make-initial-dfun generic-function))
-		     (compute-discriminating-function generic-function)))
-	   (info (gf-dfun-info generic-function)))
-      (unless (eq 'default-method-only (type-of info))
-	(setq dfun (doctor-dfun-for-the-debugger 
-		    generic-function
-		    #+cmu dfun #-cmu (set-function-name dfun gf-name))))
-      (set-funcallable-instance-function generic-function dfun)
-      #+cmu (set-function-name generic-function gf-name)
-      (when (and ocache (not (eq ocache cache))) (free-cache ocache))
-      dfun)))
-
-
-(defvar dfun-count nil)
-(defvar dfun-list nil)
-(defvar *minimum-cache-size-to-list*)
-
-(defun list-dfun (gf)
-  (let* ((sym (type-of (gf-dfun-info gf)))
-	 (a (assq sym dfun-list)))
-    (unless a
-      (push (setq a (list sym)) dfun-list))
-    (push (generic-function-name gf) (cdr a))))
-
-(defun list-all-dfuns ()
-  (setq dfun-list nil)
-  (map-all-generic-functions #'list-dfun)
-  dfun-list)
-
-(defun list-large-cache (gf)
-  (let* ((sym (type-of (gf-dfun-info gf)))
-	 (cache (gf-dfun-cache gf)))
-    (when cache
-      (let ((size (cache-size cache)))
-	(when (>= size *minimum-cache-size-to-list*)
-	  (let ((a (assoc size dfun-list)))
-	    (unless a
-	      (push (setq a (list size)) dfun-list))
-	    (push (let ((name (generic-function-name gf)))
-		    (if (eq sym 'caching) name (list name sym)))
-		  (cdr a))))))))
-
-(defun list-large-caches (&optional (*minimum-cache-size-to-list* 130))
-  (setq dfun-list nil)
-  (map-all-generic-functions #'list-large-cache)
-  (setq dfun-list (sort dfun-list #'< :key #'car))
-  (mapc #'print dfun-list)
-  (values))
-
-
-(defun count-dfun (gf)
-  (let* ((sym (type-of (gf-dfun-info gf)))
-	 (cache (gf-dfun-cache gf))
-	 (a (assq sym dfun-count)))
-    (unless a
-      (push (setq a (list sym 0 nil)) dfun-count))
-    (incf (cadr a))
-    (when cache
-      (let* ((size (cache-size cache))
-	     (b (assoc size (third a))))
-	(unless b 
-	  (push (setq b (cons size 0)) (third a)))
-	(incf (cdr b))))))
-
-(defun count-all-dfuns ()
-  (setq dfun-count (mapcar #'(lambda (type) (list type 0 nil))
-			   '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY
-			     ONE-INDEX N-N CHECKING CACHING 
-			     DISPATCH)))
-  (map-all-generic-functions #'count-dfun)
-  (mapc #'(lambda (type+count+sizes)
-	    (setf (third type+count+sizes)
-		  (sort (third type+count+sizes) #'< :key #'car)))
-	dfun-count)
-  (mapc #'(lambda (type+count+sizes)
-	    (format t "~&There are ~4d dfuns of type ~s"
-		    (cadr type+count+sizes) (car type+count+sizes))
-	    (format t "~%   ~S~%" (caddr type+count+sizes)))
-	dfun-count)
-  (values))
-
-(defun gfs-of-type (type)
-  (unless (consp type) (setq type (list type)))
-  (let ((gf-list nil))
-    (map-all-generic-functions #'(lambda (gf)
-				   (when (memq (type-of (gf-dfun-info gf)) type)
-				     (push gf gf-list))))
-    gf-list))
diff --git a/pcl/dlap.lisp b/pcl/dlap.lisp
deleted file mode 100644
index 88710c107be5d175310fb4ee54e4dec49c2dc40c..0000000000000000000000000000000000000000
--- a/pcl/dlap.lisp
+++ /dev/null
@@ -1,639 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-
-
-(defun emit-one-class-reader (class-slot-p)
-  (emit-reader/writer :reader 1 class-slot-p))
-
-(defun emit-one-class-writer (class-slot-p)
-  (emit-reader/writer :writer 1 class-slot-p))
-
-(defun emit-two-class-reader (class-slot-p)
-  (emit-reader/writer :reader 2 class-slot-p))
-
-(defun emit-two-class-writer (class-slot-p)
-  (emit-reader/writer :writer 2 class-slot-p))
-
-
-
-(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
-  (let ((instance nil)
-	(arglist  ())
-	(closure-variables ())
-	(field (first-wrapper-cache-number-index))) 
-    ;;we need some field to do the fast obsolete check
-    (ecase reader/writer
-      (:reader (setq instance (dfun-arg-symbol 0)
-		     arglist  (list instance)))
-      (:writer (setq instance (dfun-arg-symbol 1)
-		     arglist  (list (dfun-arg-symbol 0) instance))))
-    (ecase 1-or-2-class
-      (1 (setq closure-variables '(wrapper-0 index miss-fn)))
-      (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
-    (generating-lap closure-variables
-		    arglist
-       (with-lap-registers ((inst t)				   ;reg for the instance
-			    (wrapper #-structure-wrapper vector	   ;reg for the wrapper
-				     #+structure-wrapper t)
-			    #+structure-wrapper (cnv fixnum-vector)
-			    (cache-no index))			   ;reg for the cache no
-	  (let ((index cache-no)				   ;This register is used
-								   ;for different values at
-								   ;different times.
-		(slots (and (null class-slot-p)
-			    (allocate-register #-new-kcl-wrapper 'vector
-					       #+new-kcl-wrapper t)))
-		(csv   (and class-slot-p
-			    (allocate-register t))))
-	    (prog1 (flatten-lap
-		     (opcode :move (operand :arg instance) inst)   ;get the instance
-		     (opcode :std-instance-p inst 'std-instance)   ;if not either std-inst
-		     (opcode :fsc-instance-p inst 'fsc-instance)   ;or fsc-instance then
-		     (opcode :go 'trap)				   ;we lose
-
-		     (opcode :label 'fsc-instance)
-		     (opcode :move (operand :fsc-wrapper inst) wrapper)
-		     (and slots
-			  (opcode :move (operand :fsc-slots inst) slots))
-		     (opcode :go 'have-wrapper)
-
-		     (opcode :label 'std-instance)
-		     (opcode :move (operand :std-wrapper inst) wrapper)
-		     (and slots
-			  (opcode :move (operand :std-slots inst) slots))
-
-		     (opcode :label 'have-wrapper)
-		     #-structure-wrapper
-		     (opcode :move (operand :cref wrapper field) cache-no)
-		     #+structure-wrapper
-		     (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
-		     #+structure-wrapper
-		     (opcode :move (operand :cref cnv field) cache-no)
-		     (opcode :izerop cache-no 'trap)		   ;obsolete wrapper?
-
-		     (ecase 1-or-2-class
-		       (1 (emit-check-1-class-wrapper wrapper 'wrapper-0 'trap))
-		       (2 (emit-check-2-class-wrapper wrapper 'wrapper-0 'wrapper-1 'trap)))
-		     
-		     (if class-slot-p
-			 (flatten-lap
-			  (opcode :move (operand :cvar 'index) csv)
-			  (ecase reader/writer
-			   (:reader (emit-get-class-slot csv 'trap inst))
-			   (:writer (emit-set-class-slot csv (car arglist) inst))))
-		       (flatten-lap
-			(opcode :move (operand :cvar 'index) index)
-			(ecase reader/writer
-			   (:reader (emit-get-slot slots index 'trap inst))
-			   (:writer (emit-set-slot slots index (car arglist) inst)))))
-	      
-		     (opcode :label 'trap)
-		     (emit-miss 'miss-fn))
-	      (when slots (deallocate-register slots))
-	      (when csv (deallocate-register csv))))))))
-
-
-
-(defun emit-one-index-readers (class-slot-p)
-  (let ((arglist (list (dfun-arg-symbol 0))))
-    (generating-lap '(field cache-vector mask size index miss-fn)
-		    arglist
-      (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t))
-	(emit-dlap  arglist
-		    '(standard-instance)
-		    'trap
-		    (with-lap-registers ((index index))
-		      (flatten-lap
-			(opcode :move (operand :cvar 'index) index)
-			(if class-slot-p
-			    (emit-get-class-slot index 'trap slots)
-			    (emit-get-slot slots index 'trap))))
-		    (flatten-lap
-		      (opcode :label 'trap)
-		      (emit-miss 'miss-fn))
-		    nil
-		    (and (null class-slot-p) (list slots)))))))
-
-(defun emit-one-index-writers (class-slot-p)
-  (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))))
-    (generating-lap '(field cache-vector mask size index miss-fn)
-		    arglist
-      (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t))
-	(emit-dlap arglist
-		   '(t standard-instance)
-		   'trap
-		   (with-lap-registers ((index index))
-		     (flatten-lap
-		       (opcode :move (operand :cvar 'index) index)
-		       (if class-slot-p
-			   (emit-set-class-slot index (dfun-arg-symbol 0) slots)
-			   (emit-set-slot slots index (dfun-arg-symbol 0)))))
-		   (flatten-lap
-		     (opcode :label 'trap)
-		     (emit-miss 'miss-fn))
-		   nil
-		   (and (null class-slot-p) (list nil slots)))))))
-
-
-
-(defun emit-n-n-readers ()
-  (let ((arglist (list (dfun-arg-symbol 0))))
-    (generating-lap '(field cache-vector mask size miss-fn)
-		    arglist
-      (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t)
-			   (index index))
-	(emit-dlap arglist
-		   '(standard-instance)
-		   'trap
-		   (emit-get-slot slots index 'trap)
-		   (flatten-lap
-		     (opcode :label 'trap)
-		     (emit-miss 'miss-fn))
-		   index
-		   (list slots))))))
-
-(defun emit-n-n-writers ()
-  (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))))
-    (generating-lap '(field cache-vector mask size miss-fn)
-		    arglist
-      (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t)
-			   (index index))
-	(flatten-lap
-	  (emit-dlap arglist
-		     '(t standard-instance)
-		     'trap
-		     (emit-set-slot slots index (dfun-arg-symbol 0))
-		     (flatten-lap
-		       (opcode :label 'trap)
-		       (emit-miss 'miss-fn))
-		     index
-		     (list nil slots)))))))
-  
-
-
-(defun emit-checking (metatypes applyp)
-  (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
-    (generating-lap '(field cache-vector mask size 
-		      #-excl-sun4 emf #+excl-sun4 function 
-		      miss-fn)
-		    dlap-lambda-list
-      (emit-dlap (remove '&rest dlap-lambda-list)
-		 metatypes		 
-		 'trap
-		 (with-lap-registers ((#-excl-sun4 emf #+excl-sun4 function t))
-		   (flatten-lap
-		     (opcode :move (operand :cvar 
-					    #-excl-sun4 'emf #+excl-sun4 'function)
-			     #-excl-sun4 emf 
-			     #+excl-sun4 function)
-		     #-excl-sun4 (opcode :emf-call emf)
-		     #+excl-sun4 (opcode :jmp function)))
-		 (with-lap-registers ((miss-function t))
-		   (flatten-lap
-		     (opcode :label 'trap)
-		     (opcode :move (operand :cvar 'miss-fn) miss-function)
-		     (opcode :jmp miss-function)))
-		 nil))))
-
-(defun emit-caching (metatypes applyp)
-  (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
-    (generating-lap '(field cache-vector mask size miss-fn)
-		    dlap-lambda-list
-      (with-lap-registers ((#-excl-sun4 emf #+excl-sun4 function t))
-	(emit-dlap (remove '&rest dlap-lambda-list)
-		   metatypes
-		   'trap
-		   (flatten-lap
-		    #-excl-sun4 (opcode :emf-call emf)
-		    #+excl-sun4 (opcode :jmp function))
-		   (with-lap-registers ((miss-function t))
-		     (flatten-lap
-		       (opcode :label 'trap)
-		       (opcode :move (operand :cvar 'miss-fn) miss-function)
-		       (opcode :jmp miss-function)))
-		   #-excl-sun4 emf #+excl-sun4 function)))))
-
-(defun emit-constant-value (metatypes)
-  (let ((dlap-lambda-list (make-dlap-lambda-list metatypes nil)))
-    (generating-lap '(field cache-vector mask size miss-fn)
-		    dlap-lambda-list
-      (with-lap-registers ((value t))
-	(emit-dlap dlap-lambda-list
-		   metatypes
-		   'trap
-		   (flatten-lap
-		     (opcode :return value))
-		   (with-lap-registers ((miss-function t))
-		     (flatten-lap
-		       (opcode :label 'trap)
-		       (opcode :move (operand :cvar 'miss-fn) miss-function)
-		       (opcode :jmp miss-function)))
-		   value)))))
-
-
-
-(defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label)
-  (with-lap-registers ((cwrapper #-structure-wrapper vector
-				 #+structure-wrapper t))
-    (flatten-lap
-     (opcode :move (operand :cvar cwrapper-0) cwrapper)
-     (opcode :neq wrapper cwrapper miss-label))))		;wrappers not eq, trap
-
-(defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label)
-  (with-lap-registers ((cwrapper #-structure-wrapper vector
-				 #+structure-wrapper t))
-    (flatten-lap
-     (opcode :move (operand :cvar cwrapper-0) cwrapper)		;This is an OR.  Isn't
-     (opcode :eq wrapper cwrapper 'hit-internal)		;assembly code fun
-     (opcode :move (operand :cvar cwrapper-1) cwrapper)		;
-     (opcode :neq wrapper cwrapper miss-label)			;
-     (opcode :label 'hit-internal))))
-
-(defun emit-get-slot (slots index trap-label &optional temp)
-  (let ((slot-unbound (operand :constant *slot-unbound*)))
-    (with-lap-registers ((val t :reuse temp))
-      (flatten-lap
-	(opcode :move (operand :instance-ref slots index) val)  ;get slot value
-	(opcode :eq val slot-unbound trap-label)		;is the slot unbound?
-	(opcode :return val)))))				;return the slot value
-
-(defun emit-set-slot (slots index new-value-arg &optional temp)
-  (with-lap-registers ((new-val t :reuse temp))
-    (flatten-lap
-      (opcode :move (operand :arg new-value-arg) new-val)	;get new value into a reg
-      (opcode :move new-val (operand :instance-ref slots index));set slot value
-      (opcode :return new-val))))
-
-(defun emit-get-class-slot (index trap-label &optional temp)
-  (let ((slot-unbound (operand :constant *slot-unbound*)))
-    (with-lap-registers ((val t :reuse temp))
-      (flatten-lap
-	(opcode :move (operand :cdr index) val)
-	(opcode :eq val slot-unbound trap-label)
-	(opcode :return val)))))
-
-(defun emit-set-class-slot (index new-value-arg &optional temp)
-  (with-lap-registers ((new-val t :reuse temp))
-    (flatten-lap
-      (opcode :move (operand :arg new-value-arg) new-val)
-      (opcode :move new-val (operand :cdr index))
-      (opcode :return new-val))))
-
-(defun emit-miss (miss-fn)
-  (with-lap-registers ((miss-fn-reg t))
-    (flatten-lap
-     (opcode :move (operand :cvar miss-fn) miss-fn-reg)		;get the miss function
-     (opcode :jmp miss-fn-reg))))				;and call it
-
-
-
-(defun dlap-wrappers (metatypes)
-  (mapcar #'(lambda (x) (and (neq x 't)
-			     (allocate-register #-structure-wrapper 'vector
-						#+structure-wrapper t)))
-	  metatypes))
-
-(defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs)
-  (gathering1 (collecting)
-    (iterate ((mt (list-elements metatypes))
-	      (arg (list-elements args))
-	      (wrapper (list-elements wrappers))
-	      (i (interval :from 0)))
-       (when wrapper
-         (gather1
-	   (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs)))))))
-
-(defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs)
-  (let* ((wrappers (dlap-wrappers metatypes))
-	 (nwrappers (remove nil wrappers))
-	 (wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs)))
-    (prog1 (emit-dlap-internal nwrappers
-			       wrapper-moves
-			       hit
-			       miss
-			       miss-label
-			       value-reg)
-	   (mapc #'deallocate-register nwrappers))))
-
-(defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg)
-  (cond ((cdr wrapper-regs)
-	 (emit-greater-than-1-dlap
-	   wrapper-regs wrapper-moves hit miss miss-label value-reg))
-	((null value-reg)
-	 (emit-1-nil-dlap
-	   (car wrapper-regs) (car wrapper-moves) hit miss miss-label))
-	(t
-	 (emit-1-t-dlap
-	   (car wrapper-regs) (car wrapper-moves) hit miss miss-label value-reg))))
-
-
-
-(defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label)
-  (with-lap-registers ((location index)
-		       (primary index)
-		       (cache-vector vector))
-    (flatten-lap
-      wrapper-move
-      (opcode :move (operand :cvar 'cache-vector) cache-vector)
-      (with-lap-registers ((wrapper-cache-no index))
-	(flatten-lap
-	  (emit-1-wrapper-compute-primary-cache-location wrapper primary wrapper-cache-no)
-	  (opcode :move primary location)
-	  (emit-check-1-wrapper-in-cache cache-vector location wrapper hit)	   ;inline hit code
-	  (opcode :izerop wrapper-cache-no miss-label)))
-      (with-lap-registers ((size index))
-	(flatten-lap
-	  (opcode :move (operand :cvar 'size) size)
-	  (opcode :label 'loop)
-	  (opcode :move (operand :i1+ location) location)
-	  (opcode :fix= location primary miss-label)
-	  (opcode :fix= location size 'set-location-to-min)
-	  (opcode :label 'continue)
-	  (emit-check-1-wrapper-in-cache cache-vector location wrapper hit) 
-	  (opcode :go 'loop)
-	  (opcode :label 'set-location-to-min)
-	  (opcode :izerop primary miss-label)
-	  (opcode :move (operand :constant (index-value->index 0)) location)
-	  (opcode :go 'continue)))
-      miss)))
-
-;;;
-;;; The function below implements CACHE-VECTOR-LOCK-COUNT as the first entry 
-;;; in a cache (svref cache-vector 0).  This should probably be abstracted.
-;;;
-(defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value)
-  (with-lap-registers ((location index)
-		       (primary index)
-		       (cache-vector vector)
-		       (initial-lock-count t))
-    (flatten-lap
-      wrapper-move
-      (opcode :move (operand :cvar 'cache-vector) cache-vector)
-      (with-lap-registers ((wrapper-cache-no index))
-	(flatten-lap
-	  (emit-1-wrapper-compute-primary-cache-location wrapper primary wrapper-cache-no)
-	  (opcode :move primary location)
-	  (opcode :move (operand :cref cache-vector 0) initial-lock-count)	   ;get lock-count
-	  (emit-check-cache-entry cache-vector location wrapper 'hit-internal)
-	  (opcode :izerop wrapper-cache-no miss-label)))    ;check for obsolescence
-      (with-lap-registers ((size index))
-	(flatten-lap
-	  (opcode :move (operand :cvar 'size) size)
-
-	  (opcode :label 'loop)
-	  (opcode :move (operand :i1+ location) location)
-	  (opcode :move (operand :i1+ location) location)
-	  (opcode :label 'continue)
-	  (opcode :fix= location primary miss-label)
-	  (opcode :fix= location size 'set-location-to-min)
-	  (emit-check-cache-entry cache-vector location wrapper 'hit-internal)
-	  (opcode :go 'loop)
-
-	  (opcode :label 'set-location-to-min)
-	  (opcode :izerop primary miss-label)
-	  (opcode :move (operand :constant (index-value->index 2)) location)
-	  (opcode :go 'continue)))
-      (opcode :label 'hit-internal)
-      (opcode :move (operand :i1+ location) location)		   ;position for getting value
-      (opcode :move (emit-cache-vector-ref cache-vector location) value)
-      (emit-lock-count-test initial-lock-count cache-vector 'hit)
-      miss
-      (opcode :label 'hit)
-      hit)))
-
-(defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value)
-  (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
-    (with-lap-registers ((location index)
-			 (primary index)
-			 (cache-vector vector)
-			 (initial-lock-count t)
-			 (next-location index)
-			 (line-size index))	;Line size holds a constant
-						;that can be folded in if there was
-						;a way to add a constant to 
-						;an index register
-      (flatten-lap
-	(apply #'flatten-lap wrapper-moves)
-	(opcode :move (operand :constant cache-line-size) line-size)
-	(opcode :move (operand :cvar 'cache-vector) cache-vector)
-	(emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label)
-	(opcode :move primary location)
-	(opcode :move location next-location)
-	(opcode :move (operand :cref cache-vector 0) initial-lock-count)  ;get the lock-count
-	(with-lap-registers ((size index))
-	  (flatten-lap
-	    (opcode :move (operand :cvar 'size) size)
-	    (opcode :label 'continue)
-	    (opcode :move (operand :i+ location line-size) next-location)
-	    (emit-check-cache-line cache-vector location wrappers 'hit)
-	    (emit-adjust-location location next-location primary size 'continue miss-label)
-	    (opcode :label 'hit)
-	    (and value (opcode :move (emit-cache-vector-ref cache-vector location) value))
-	    (emit-lock-count-test initial-lock-count cache-vector 'hit-internal)
-	    miss
-	    (opcode :label 'hit-internal)
-	    hit))))))
-
-
-
-;;;
-;;; Cache related lap code
-;;;
-
-(defun emit-check-1-wrapper-in-cache (cache-vector location wrapper hit-code)
-  (let ((exit-emit-check-1-wrapper-in-cache 
-	  (make-symbol "exit-emit-check-1-wrapper-in-cache")))
-    (with-lap-registers ((cwrapper #-structure-wrapper vector
-				   #+structure-wrapper t))
-      (flatten-lap
-	(opcode :move (emit-cache-vector-ref cache-vector location) cwrapper)
-	(opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache)
-	hit-code
-	(opcode :label exit-emit-check-1-wrapper-in-cache)))))
-
-(defun emit-check-cache-entry (cache-vector location wrapper hit-label)
-  (with-lap-registers ((cwrapper #-structure-wrapper vector
-				 #+structure-wrapper t))
-    (flatten-lap
-      (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper)
-      (opcode :eq cwrapper wrapper hit-label))))
-
-(defun emit-check-cache-line (cache-vector location wrappers hit-label)
-  (let ((checks
-	  (flatten-lap
-	    (gathering1 (flattening-lap)
-	      (iterate ((wrapper (list-elements wrappers)))
-		(with-lap-registers ((cwrapper #-structure-wrapper vector
-					       #+structure-wrapper t))
-		  (gather1
-		    (flatten-lap
-		      (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper)
-		      (opcode :neq cwrapper wrapper 'exit-emit-check-cache-line)
-		      (opcode :move (operand :i1+ location) location)))))))))
-    (flatten-lap
-      checks
-      (opcode :go hit-label)
-      (opcode :label 'exit-emit-check-cache-line))))
-
-(defun emit-lock-count-test (initial-lock-count cache-vector hit-label)
-  ;;
-  ;; jumps to hit-label if cache-vector-lock-count consistent, otherwise, continues
-  ;; 
-  (with-lap-registers ((new-lock-count t))
-    (flatten-lap
-      (opcode :move (operand :cref cache-vector 0) new-lock-count) ;get new cache-vector-lock-count
-      (opcode :fix= new-lock-count initial-lock-count hit-label))))
-
-
-
-(defun emit-adjust-location (location next-location primary size cont-label miss-label)
-  (flatten-lap
-    (opcode :move next-location location)
-    (opcode :fix= location size 'at-end-of-cache)
-    (opcode :fix= location primary miss-label)
-    (opcode :go cont-label)
-    (opcode :label 'at-end-of-cache)
-    (opcode :fix= primary (operand :constant (index-value->index 1)) miss-label)
-    (opcode :move (operand :constant (index-value->index 1)) location)
-    (opcode :go cont-label)))
-     
-
-;; From cache.lisp
-(defun emit-cache-vector-ref (cache-vector-operand location-operand)
-  (operand :iref cache-vector-operand location-operand))
-
-(defun emit-wrapper-ref (wrapper-operand field-operand)
-  (operand :iref wrapper-operand field-operand))
-
-(defun emit-wrapper-cache-number-vector (wrapper-operand)
-  (operand :wrapper-cache-number-vector wrapper-operand))
-
-(defun emit-cache-number-vector-ref (cnv-operand field-operand)
-  (operand :iref cnv-operand field-operand))
-
-(defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no)
-  (with-lap-registers ((mask index) 
-		       #+structure-wrapper (cnv fixnum-vector))
-    (let ((field wrapper-cache-no))
-      (flatten-lap
-        (opcode :move (operand :cvar 'mask) mask)
-        (opcode :move (operand :cvar 'field) field)
-	#-structure-wrapper
-        (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
-	#+structure-wrapper
-	(opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
-	#+structure-wrapper
-	(opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no)
-        (opcode :move (operand :ilogand wrapper-cache-no mask) primary)))))
-
-(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label)
-  (with-lap-registers ((field index)
-		       (mask index))
-    (let ((add-wrapper-cache-numbers
-	   (flatten-lap
-	    (gathering1 (flattening-lap)
-	       (iterate ((wrapper (list-elements wrappers))
-			 (i (interval :from 1)))
-		 (gather1
-		  (with-lap-registers ((wrapper-cache-no index)
-				       #+structure-wrapper (cnv fixnum-vector))
-		    (flatten-lap
-		     #-structure-wrapper
-		     (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
-		     #+structure-wrapper
-		     (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
-		     #+structure-wrapper
-		     (opcode :move (emit-cache-number-vector-ref cnv field)
-			     wrapper-cache-no)
-		     (opcode :izerop wrapper-cache-no miss-label)
-		     (opcode :move (operand :i+ primary wrapper-cache-no) primary)
-		     (when (zerop (mod i wrapper-cache-number-adds-ok))
-		       (opcode :move (operand :ilogand primary mask) primary))))))))))
-      (flatten-lap
-       (opcode :move (operand :constant 0) primary)
-       (opcode :move (operand :cvar 'field) field)
-       (opcode :move (operand :cvar 'mask) mask)
-       add-wrapper-cache-numbers
-       (opcode :move (operand :ilogand primary mask) primary)
-       (opcode :move (operand :i1+ primary) primary)))))
-
-(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot)
-  (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper")))
-    (with-lap-registers ((arg t))
-      (ecase metatype
-	((standard-instance #+new-kcl-wrapper structure-instance)
-	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
-		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
-	    (flatten-lap
-	      (opcode :move (operand :arg argument) arg)
-	      (opcode :std-instance-p arg get-std-inst-wrapper)	   ;is it a std wrapper?
-	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)	   ;is it a fsc wrapper?
-	      (opcode :go miss-label)
-	      (opcode :label get-fsc-inst-wrapper)
-	      (opcode :move (operand :fsc-wrapper arg) dest)	   ;get fsc wrapper
-	      (and slot
-		   (opcode :move (operand :fsc-slots arg) slot))
-	      (opcode :go exit-emit-fetch-wrapper)
-	      (opcode :label get-std-inst-wrapper)
-	      (opcode :move (operand :std-wrapper arg) dest)	   ;get std wrapper
-	      (and slot
-		   (opcode :move (operand :std-slots arg) slot))
-	      (opcode :label exit-emit-fetch-wrapper))))
-	(class
-	  (when slot (error "Can't do a slot reg for this metatype."))
-	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
-		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
-	    (flatten-lap
-	      (opcode :move (operand :arg argument) arg)
-	      (opcode :std-instance-p arg get-std-inst-wrapper)
-	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)
-	      #-new-kcl-wrapper
-	      (opcode :move (operand :built-in-or-structure-wrapper arg) dest)
-	      #+new-kcl-wrapper
-	      (opcode :move (operand :built-in-wrapper arg) dest)
-	      (opcode :go exit-emit-fetch-wrapper)
-	      (opcode :label get-fsc-inst-wrapper)
-	      (opcode :move (operand :fsc-wrapper arg) dest)
-	      (opcode :go exit-emit-fetch-wrapper)
-	      (opcode :label get-std-inst-wrapper)
-	      (opcode :move (operand :std-wrapper arg) dest)
-	      (opcode :label exit-emit-fetch-wrapper))))
-	((built-in-instance #-new-kcl-wrapper structure-instance)
-	  (when slot (error "Can't do a slot reg for this metatype."))
-	  (let ()
-	    (flatten-lap
-	      (opcode :move (operand :arg argument) arg)
-	      (opcode :std-instance-p arg miss-label)
-	      (opcode :fsc-instance-p arg miss-label)
-	      #-new-kcl-wrapper
-	      (opcode :move (operand :built-in-or-structure-wrapper arg) dest)
-	      #+new-kcl-wrapper
-	      (opcode :move (operand :built-in-wrapper arg) dest))))))))
-
diff --git a/pcl/dlisp.lisp b/pcl/dlisp.lisp
deleted file mode 100644
index f8538ad5f6b1f37f4c698c5d108ef7f1867ea9a4..0000000000000000000000000000000000000000
--- a/pcl/dlisp.lisp
+++ /dev/null
@@ -1,414 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-;;; This file is (almost) functionally equivalent to dlap.lisp,
-;;; but easier to read.
-
-;;; Might generate faster code, too, depending on the compiler and 
-;;; whether an implementation-specific lap assembler was used.
-
-(defun emit-one-class-reader (class-slot-p)
-  (emit-reader/writer :reader 1 class-slot-p))
-
-(defun emit-one-class-writer (class-slot-p)
-  (emit-reader/writer :writer 1 class-slot-p))
-
-(defun emit-two-class-reader (class-slot-p)
-  (emit-reader/writer :reader 2 class-slot-p))
-
-(defun emit-two-class-writer (class-slot-p)
-  (emit-reader/writer :writer 2 class-slot-p))
-
-;;; --------------------------------
-
-(defun emit-one-index-readers (class-slot-p)
-  (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
-
-(defun emit-one-index-writers (class-slot-p)
-  (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
-
-(defun emit-n-n-readers ()
-  (emit-one-or-n-index-reader/writer :reader t nil))
-
-(defun emit-n-n-writers ()
-  (emit-one-or-n-index-reader/writer :writer t nil))
-
-;;; --------------------------------
-
-(defun emit-checking (metatypes applyp)
-  (emit-checking-or-caching nil nil metatypes applyp))
-
-(defun emit-caching (metatypes applyp)
-  (emit-checking-or-caching t nil metatypes applyp))
-
-(defun emit-in-checking-cache-p (metatypes)
-  (emit-checking-or-caching nil t metatypes nil))
-
-(defun emit-constant-value (metatypes)
-  (emit-checking-or-caching t t metatypes nil))
-
-;;; --------------------------------
-
-(defvar *precompiling-lap* nil)
-(defvar *emit-function-p* t)
-
-(defun emit-default-only (metatypes applyp)
-  (when (and (null *precompiling-lap*) *emit-function-p*)
-    (return-from emit-default-only
-      (emit-default-only-function metatypes applyp)))
-  (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
-	 (args (remove '&rest dlap-lambda-list))
-	 (restl (when applyp '(.lap-rest-arg.))))
-    (generating-lisp '(emf)
-		     dlap-lambda-list
-      `(invoke-effective-method-function emf ,applyp ,@args ,@restl))))
-      
-(defmacro emit-default-only-macro (metatypes applyp)
-  (let ((*emit-function-p* nil)
-	(*precompiling-lap* t))
-    (values
-     (emit-default-only metatypes applyp))))
-
-;;; --------------------------------
-
-(defun generating-lisp (closure-variables args form)
-  (let* ((rest (memq '&rest args))
-	 (ldiff (and rest (ldiff args rest)))
-	 (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args))
-	 (lambda `(lambda ,closure-variables
-		    ,@(when (member 'miss-fn closure-variables)
-			`((declare (type function miss-fn))))
-		    #'(lambda ,args
-			#+copy-&rest-arg
-			,@(when rest
-			    `((setq .lap-rest-arg.
-				    (copy-list .lap-rest-arg.))))
-			(let ()
-			  (declare #.*optimize-speed*)
-			  ,form)))))
-    (values (if *precompiling-lap*
-		`#',lambda
-		(compile-lambda lambda))
-	    nil)))
-
-(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
-  (when (and (null *precompiling-lap*) *emit-function-p*)
-    (return-from emit-reader/writer
-      (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))
-  (let ((instance nil)
-	(arglist  ())
-	(closure-variables ())
-	(field (first-wrapper-cache-number-index))
-	(readp (eq reader/writer :reader))
-	(read-form (emit-slot-read-form class-slot-p 'index 'slots)))
-    ;;we need some field to do the fast obsolete check
-    (ecase reader/writer
-      (:reader (setq instance (dfun-arg-symbol 0)
-		     arglist  (list instance)))
-      (:writer (setq instance (dfun-arg-symbol 1)
-		     arglist  (list (dfun-arg-symbol 0) instance))))
-    (ecase 1-or-2-class
-      (1 (setq closure-variables '(wrapper-0 index miss-fn)))
-      (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
-    (generating-lisp closure-variables
-		     arglist
-       `(let* (,@(unless class-slot-p `((slots nil)))
-	       (wrapper (cond ((std-instance-p ,instance)
-			       ,@(unless class-slot-p
-				   `((setq slots (std-instance-slots ,instance))))
-			       (std-instance-wrapper ,instance))
-			      ((fsc-instance-p ,instance)
-			       ,@(unless class-slot-p
-				   `((setq slots (fsc-instance-slots ,instance))))
-			       (fsc-instance-wrapper ,instance))))
-	       ,@(when readp '(value)))
-	  (if (or (null wrapper)
-		  (zerop (wrapper-cache-number-vector-ref wrapper ,field))
-		  (not (or (eq wrapper wrapper-0)
-			   ,@(when (eql 2 1-or-2-class)
-			       `((eq wrapper wrapper-1)))))
-		  ,@(when readp `((eq *slot-unbound* (setq value ,read-form)))))
-	      (funcall miss-fn ,@arglist)
-	      ,(if readp
-		   'value
-		   `(setf ,read-form ,(car arglist))))))))
-
-(defun emit-slot-read-form (class-slot-p index slots)
-  (if class-slot-p
-      `(cdr ,index)
-      `(%instance-ref ,slots ,index)))
-
-(defun emit-boundp-check (value-form miss-fn arglist)
-  `(let ((value ,value-form))
-     (if (eq value *slot-unbound*)
-	 (funcall ,miss-fn ,@arglist)
-	 value)))
-
-(defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
-  (let ((read-form (emit-slot-read-form class-slot-p index slots)))
-    (ecase reader/writer
-      (:reader (emit-boundp-check read-form miss-fn arglist))
-      (:writer `(setf ,read-form ,(car arglist))))))
-
-(defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
-  (let ((*emit-function-p* nil)
-	(*precompiling-lap* t))
-    (values 
-     (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
-
-(defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
-  (when (and (null *precompiling-lap*) *emit-function-p*)
-    (return-from emit-one-or-n-index-reader/writer
-      (emit-one-or-n-index-reader/writer-function
-       reader/writer cached-index-p class-slot-p)))
-  (multiple-value-bind (arglist metatypes)
-      (ecase reader/writer
-	(:reader (values (list (dfun-arg-symbol 0))
-			 '(standard-instance)))
-	(:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
-			 '(t standard-instance))))
-    (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
-		     arglist
-      `(let (,@(unless class-slot-p '(slots))
-	     ,@(when cached-index-p '(index)))
-         ,(emit-dlap arglist metatypes
-		     (emit-slot-access reader/writer class-slot-p
-				       'slots 'index 'miss-fn arglist)
-		     `(funcall miss-fn ,@arglist)
-		     (when cached-index-p 'index)
-		     (unless class-slot-p '(slots)))))))
-
-(defmacro emit-one-or-n-index-reader/writer-macro
-    (reader/writer cached-index-p class-slot-p)
-  (let ((*emit-function-p* nil)
-	(*precompiling-lap* t))
-    (values
-     (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p))))
-
-(defun emit-miss (miss-fn args &optional applyp)
-  (let ((restl (when applyp '(.lap-rest-arg.))))
-    (if restl
-	`(apply ,miss-fn ,@args ,@restl)
-	`(funcall ,miss-fn ,@args ,@restl))))
-
-(defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
-  (when (and (null *precompiling-lap*) *emit-function-p*)
-    (return-from emit-checking-or-caching
-      (emit-checking-or-caching-function
-       cached-emf-p return-value-p metatypes applyp)))
-  (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
-	 (args (remove '&rest dlap-lambda-list))
-	 (restl (when applyp '(.lap-rest-arg.))))
-    (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
-		     dlap-lambda-list
-      `(let (,@(when cached-emf-p '(emf)))
-         ,(emit-dlap args
-	             metatypes
-	             (if return-value-p
-			 (if cached-emf-p 'emf t)
-			 `(invoke-effective-method-function emf ,applyp
-			   ,@args ,@restl))
-	             (emit-miss 'miss-fn args applyp)
-		     (when cached-emf-p 'emf))))))
-
-(defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp)
-  (let ((*emit-function-p* nil)
-	(*precompiling-lap* t))
-    (values
-     (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
-
-(defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
-  (let* ((index -1)
-	 (wrapper-bindings (mapcan #'(lambda (arg mt)
-				       (unless (eq mt 't)
-					 (incf index)
-					 `((,(intern (format nil "WRAPPER-~D" index)
-					             *the-pcl-package*)
-					    ,(emit-fetch-wrapper mt arg 'miss
-					      (pop slot-regs))))))
-				   args metatypes))
-	 (wrappers (mapcar #'car wrapper-bindings)))
-    (declare (fixnum index))
-    (unless wrappers (error "Every metatype is T."))
-    `(block dfun
-       (tagbody
-	  (let ((field (cache-field cache))
-		(cache-vector (cache-vector cache))
-		(mask (cache-mask cache))
-		(size (cache-size cache))
-		(overflow (cache-overflow cache))
-		,@wrapper-bindings)
-	    (declare (fixnum size field mask))
-	    ,(cond ((cdr wrappers)
-		    (emit-greater-than-1-dlap wrappers 'miss value-reg))
-		   (value-reg
-		    (emit-1-t-dlap (car wrappers) 'miss value-reg))
-		   (t
-		    (emit-1-nil-dlap (car wrappers) 'miss)))
-	    (return-from dfun ,hit))
-	miss
-	  (return-from dfun ,miss)))))
-
-(defun emit-1-nil-dlap (wrapper miss-label)
-  `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
-	  (location primary))
-     (declare (fixnum primary location))
-     (block search
-       (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
-	       (return-from search nil))
-	     (setq location (the fixnum (+ location 1)))
-	     (when (= location size)
-	       (setq location 0))
-	     (when (= location primary)
-	       (dolist (entry overflow)
-		 (when (eq (car entry) ,wrapper)
-		   (return-from search nil)))
-	       (go ,miss-label))))))
-
-(defmacro get-cache-vector-lock-count (cache-vector)
-  `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
-     (unless (typep lock-count 'fixnum)
-       (error "my cache got freed somehow"))
-     (the fixnum lock-count)))
-
-(defun emit-1-t-dlap (wrapper miss-label value)
-  `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
-	 (initial-lock-count (get-cache-vector-lock-count cache-vector)))
-     (declare (fixnum primary initial-lock-count))
-     (let ((location primary))
-       (declare (fixnum location))
-       (block search
-	 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
-		 (setq ,value (cache-vector-ref cache-vector (1+ location)))
-		 (return-from search nil))
-	       (setq location (the fixnum (+ location 2)))
-	       (when (= location size)
-		 (setq location 0))
-	       (when (= location primary)
-		 (dolist (entry overflow)
-		   (when (eq (car entry) ,wrapper)
-		     (setq ,value (cdr entry))
-		     (return-from search nil)))
-		 (go ,miss-label))))
-       (unless (= initial-lock-count
-		  (get-cache-vector-lock-count cache-vector))
-	 (go ,miss-label)))))
-
-(defun emit-greater-than-1-dlap (wrappers miss-label value)
-  (declare (type list wrappers))
-  (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
-    `(let ((primary 0) (size-1 (the fixnum (- size 1))))
-       (declare (fixnum primary size-1))
-       ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
-       (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
-	 (declare (fixnum initial-lock-count))
-	 (let ((location primary) (next-location 0))
-	   (declare (fixnum location next-location))
-	   (block search
-	     (loop (setq next-location (the fixnum (+ location ,cache-line-size)))
-		   (when (and ,@(mapcar
-				 #'(lambda (wrapper)
-				     `(eq ,wrapper 
-				       (cache-vector-ref cache-vector
-					(setq location
-					 (the fixnum (+ location 1))))))
-				 wrappers))
-		     ,@(when value
-			 `((setq location (the fixnum (+ location 1)))
-			   (setq ,value (cache-vector-ref cache-vector location))))
-		     (return-from search nil))
-		   (setq location next-location)
-		   (when (= location size-1)
-		     (setq location 0))
-		   (when (= location primary)
-		     (dolist (entry overflow)
-		       (let ((entry-wrappers (car entry)))
-			 (when (and ,@(mapcar #'(lambda (wrapper)
-						  `(eq ,wrapper (pop entry-wrappers)))
-					      wrappers))
-			   ,@(when value
-			       `((setq ,value (cdr entry))))
-			   (return-from search nil))))
-		     (go ,miss-label))))
-	   (unless (= initial-lock-count
-		      (get-cache-vector-lock-count cache-vector))
-	     (go ,miss-label)))))))
-
-(defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
-  `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
-     (declare (fixnum wrapper-cache-no))
-     (when (zerop wrapper-cache-no) (go ,miss-label))
-     ,(let ((form `(#+lucid %logand #-lucid logand
-		    mask wrapper-cache-no)))
-	#+lucid form
-	#-lucid `(the fixnum ,form))))
-
-(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
-  (declare (type list wrappers))
-  ;; this returns 1 less that the actual location
-  `(progn
-     ,@(let ((adds 0) (len (length wrappers)))
-	 (declare (fixnum adds len))
-	 (mapcar #'(lambda (wrapper)
-		     `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref 
-					       ,wrapper field)))
-		        (declare (fixnum wrapper-cache-no))
-		        (when (zerop wrapper-cache-no) (go ,miss-label))
-		        (setq primary (the fixnum (+ primary wrapper-cache-no)))
-		        ,@(progn
-			    (incf adds)
-			    (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
-				      (eql adds len))
-			      `((setq primary
-				      ,(let ((form `(#+lucid %logand #-lucid logand
-						     primary mask)))
-					 #+lucid form
-					 #-lucid `(the fixnum ,form))))))))
-		 wrappers))))
-     
-(defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
-  (ecase metatype
-    ((standard-instance #+new-kcl-wrapper structure-instance)
-     `(cond ((std-instance-p ,argument)
-	     ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
-	     (std-instance-wrapper ,argument))
-	    ((fsc-instance-p ,argument)
-	     ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
-	     (fsc-instance-wrapper ,argument))
-	    (t
-	     (go ,miss-label))))
-    (class
-     (when slot (error "Can't do a slot reg for this metatype."))
-     `(wrapper-of-macro ,argument))
-    ((built-in-instance #-new-kcl-wrapper structure-instance)
-     (when slot (error "Can't do a slot reg for this metatype."))
-     `(#+new-kcl-wrapper built-in-wrapper-of
-       #-new-kcl-wrapper built-in-or-structure-wrapper
-       ,argument))))
-
diff --git a/pcl/dlisp2.lisp b/pcl/dlisp2.lisp
deleted file mode 100644
index b323a66949e143a6d8dd3c4983a3c5916d843b48..0000000000000000000000000000000000000000
--- a/pcl/dlisp2.lisp
+++ /dev/null
@@ -1,180 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-(defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p)
-  (values
-   (ecase reader/writer
-     (:reader (ecase 1-or-2-class
-		(1 (if class-slot-p
-		       (emit-reader/writer-macro :reader 1 t)
-		       (emit-reader/writer-macro :reader 1 nil)))
-		(2 (if class-slot-p
-		       (emit-reader/writer-macro :reader 2 t)
-		       (emit-reader/writer-macro :reader 2 nil)))))
-     (:writer (ecase 1-or-2-class
-		(1 (if class-slot-p
-		       (emit-reader/writer-macro :writer 1 t)
-		       (emit-reader/writer-macro :writer 1 nil)))
-		(2 (if class-slot-p
-		       (emit-reader/writer-macro :writer 2 t)
-		       (emit-reader/writer-macro :writer 2 nil))))))
-   nil))
-
-(defun emit-one-or-n-index-reader/writer-function
-    (reader/writer cached-index-p class-slot-p)
-  (values
-   (ecase reader/writer
-     (:reader (if cached-index-p
-		  (if class-slot-p
-		      (emit-one-or-n-index-reader/writer-macro :reader t t)
-		      (emit-one-or-n-index-reader/writer-macro :reader t nil))
-		  (if class-slot-p
-		      (emit-one-or-n-index-reader/writer-macro :reader nil t)
-		      (emit-one-or-n-index-reader/writer-macro :reader nil nil))))
-     (:writer (if cached-index-p
-		  (if class-slot-p
-		      (emit-one-or-n-index-reader/writer-macro :writer t t)
-		      (emit-one-or-n-index-reader/writer-macro :writer t nil))
-		  (if class-slot-p
-		      (emit-one-or-n-index-reader/writer-macro :writer nil t)
-		      (emit-one-or-n-index-reader/writer-macro :writer nil nil)))))
-   nil))
-
-(eval-when (compile load eval)
-(defparameter checking-or-caching-list
-  '()
-  #||
-  '((T NIL (CLASS) NIL)
-    (T NIL (CLASS CLASS) NIL)
-    (T NIL (CLASS CLASS CLASS) NIL)
-    (T NIL (CLASS CLASS T) NIL)
-    (T NIL (CLASS CLASS T T) NIL)
-    (T NIL (CLASS CLASS T T T) NIL)
-    (T NIL (CLASS T) NIL)
-    (T NIL (CLASS T T) NIL)
-    (T NIL (CLASS T T T) NIL)
-    (T NIL (CLASS T T T T) NIL)
-    (T NIL (CLASS T T T T T) NIL)
-    (T NIL (CLASS T T T T T T) NIL)
-    (T NIL (T CLASS) NIL)
-    (T NIL (T CLASS T) NIL)
-    (T NIL (T T CLASS) NIL)
-    (T NIL (CLASS) T)
-    (T NIL (CLASS CLASS) T)
-    (T NIL (CLASS T) T)
-    (T NIL (CLASS T T) T)
-    (T NIL (CLASS T T T) T)
-    (T NIL (T CLASS) T)
-    (T T (CLASS) NIL)
-    (T T (CLASS CLASS) NIL)
-    (T T (CLASS CLASS CLASS) NIL)
-    (NIL NIL (CLASS) NIL)
-    (NIL NIL (CLASS CLASS) NIL)
-    (NIL NIL (CLASS CLASS T) NIL)
-    (NIL NIL (CLASS CLASS T T) NIL)
-    (NIL NIL (CLASS T) NIL)
-    (NIL NIL (T CLASS T) NIL)
-    (NIL NIL (CLASS) T)
-    (NIL NIL (CLASS CLASS) T)) ||# ))
-
-(defmacro make-checking-or-caching-function-list ()
-  `(list ,@(mapcar #'(lambda (key)
-		       `(cons ',key (emit-checking-or-caching-macro ,@key)))
-		   checking-or-caching-list)))
-
-(defvar checking-or-caching-function-list)
-
-(defun initialize-checking-or-caching-function-list ()
-  (setq checking-or-caching-function-list
-	(make-checking-or-caching-function-list)))
-
-(initialize-checking-or-caching-function-list)
-
-(defmacro emit-checking-or-caching-function-precompiled ()
-  `(cdr (assoc (list cached-emf-p return-value-p metatypes applyp)
-	       checking-or-caching-function-list
-	       :test #'equal)))
-
-(defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp)
-  (let ((fn (emit-checking-or-caching-function-precompiled)))
-    (if fn
-	(values fn nil)
-	(values (emit-checking-or-caching-function-preliminary
-		 cached-emf-p return-value-p metatypes applyp)
-		t))))
-
-(defvar not-in-cache (make-symbol "not in cache"))
-
-(defun emit-checking-or-caching-function-preliminary
-    (cached-emf-p return-value-p metatypes applyp)
-  (declare (ignore applyp))
-  (if cached-emf-p
-      #'(lambda (cache miss-fn)
-	  (declare (type function miss-fn))
-	  #'(lambda (&rest args)
-	      (declare #.*optimize-speed*)
-	      #+copy-&rest-arg (setq args (copy-list args))
-	      (with-dfun-wrappers (args metatypes)
-		(dfun-wrappers invalid-wrapper-p)
-		(apply miss-fn args)
-		(if invalid-wrapper-p
-		    (apply miss-fn args)
-		    (let ((emf (probe-cache cache dfun-wrappers not-in-cache)))
-		      (if (eq emf not-in-cache)
-			  (apply miss-fn args)
-			  (if return-value-p
-			      emf
-			      (invoke-emf emf args))))))))
-      #'(lambda (cache emf miss-fn)
-	  (declare (type function miss-fn))
-	  #'(lambda (&rest args)
-	      (declare #.*optimize-speed*)
-	      #+copy-&rest-arg (setq args (copy-list args))
-	      (with-dfun-wrappers (args metatypes)
-		(dfun-wrappers invalid-wrapper-p)
-		(apply miss-fn args)
-		(if invalid-wrapper-p
-		    (apply miss-fn args)
-		    (let ((found-p (not (eq not-in-cache
-					    (probe-cache cache dfun-wrappers
-							 not-in-cache)))))
-		      (if found-p
-			  (invoke-emf emf args)
-			  (if return-value-p
-			      t
-			      (apply miss-fn args))))))))))
-
-
-(defun emit-default-only-function (metatypes applyp)
-  (declare (ignore metatypes applyp))
-  (values #'(lambda (emf)
-	      #'(lambda (&rest args)
-		  #+copy-&rest-arg (setq args (copy-list args))
-		  (invoke-emf emf args)))
-	  t))
diff --git a/pcl/env.lisp b/pcl/env.lisp
deleted file mode 100644
index 000ee3e7837cc2630d36d0d12b7422169efb10b1..0000000000000000000000000000000000000000
--- a/pcl/env.lisp
+++ /dev/null
@@ -1,331 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; Basic environmental stuff.
-;;;
-
-(in-package :pcl)
-
-#+Lucid
-(progn
-
-(defun pcl-arglist (function &rest other-args)
-  (let ((defn nil))
-    (cond ((and (fsc-instance-p function)
-		(generic-function-p function))
-	   (generic-function-pretty-arglist function))
-	  ((and (symbolp function)
-		(fboundp function)
-		(setq defn (symbol-function function))
-		(fsc-instance-p defn)
-		(generic-function-p defn))
-	   (generic-function-pretty-arglist defn))
-	  (t (apply (original-definition 'sys::arglist)
-		    function other-args)))))
-
-(redefine-function 'sys::arglist 'pcl-arglist)
-
-)
-
-
-;;;
-;;;
-;;;
-
-(defgeneric describe-object (object stream))
-
-#-Genera
-(progn
-
-(defun pcl-describe (object #+Lispm &optional #+Lispm no-complaints)
-  (let (#+Lispm (*describe-no-complaints* no-complaints))
-    #+Lispm (declare (special *describe-no-complaints*))
-    (describe-object object *standard-output*)
-    (values)))
-
-(defmethod describe-object (object stream)
-  (let ((*standard-output* stream))
-    (cond ((or #+kcl (packagep object))
-	   (describe-package object stream))
-	  (t
-	   (funcall (original-definition 'describe) object)))))
-
-(redefine-function 'describe 'pcl-describe)
-
-)
-
-(defmethod describe-object ((object slot-object) stream)
-  (let* ((class (class-of object))
-	 (slotds (slots-to-inspect class object))
-	 (max-slot-name-length 0)
-	 (instance-slotds ())
-	 (class-slotds ())
-	 (other-slotds ()))
-    (flet ((adjust-slot-name-length (name)
-	     (setq max-slot-name-length
-		   (max max-slot-name-length
-			(length (the string (symbol-name name))))))
-	   (describe-slot (name value &optional (allocation () alloc-p))
-	     (if alloc-p
-		 (format stream
-			 "~% ~A ~S ~VT  ~S"
-			 name allocation (+ max-slot-name-length 7) value)
-		 (format stream
-			 "~% ~A~VT  ~S"
-			 name max-slot-name-length value))))
-      ;; Figure out a good width for the slot-name column.
-      (dolist (slotd slotds)
-	(adjust-slot-name-length (slot-definition-name slotd))
-	(case (slot-definition-allocation slotd)
-	  (:instance (push slotd instance-slotds))
-	  (:class  (push slotd class-slotds))
-	  (otherwise (push slotd other-slotds))))
-      (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
-      (format stream "~%~S is an instance of class ~S:" object class)
-
-      (when instance-slotds
-	(format stream "~% The following slots have :INSTANCE allocation:")
-	(dolist (slotd (nreverse instance-slotds))
-	  (describe-slot (slot-definition-name slotd)
-			 (slot-value-or-default object (slot-definition-name slotd)))))
-
-      (when class-slotds
-	(format stream "~% The following slots have :CLASS allocation:")
-	(dolist (slotd (nreverse class-slotds))
-	  (describe-slot (slot-definition-name slotd)
-			 (slot-value-or-default object (slot-definition-name slotd)))))
-
-      (when other-slotds 
-	(format stream "~% The following slots have allocation as shown:")
-	(dolist (slotd (nreverse other-slotds))
-	  (describe-slot (slot-definition-name slotd)
-			 (slot-value-or-default object (slot-definition-name slotd))
-			 (slot-definition-allocation slotd))))
-      (values))))
-
-(defmethod slots-to-inspect ((class slot-class) (object slot-object))
-  (class-slots class))
-
-(defvar *describe-metaobjects-as-objects-p* nil)
-
-(defmethod describe-object ((fun standard-generic-function) stream)
-  (format stream "~A is a generic function.~%" fun)
-  (format stream "Its arguments are:~%  ~S~%"
-          (generic-function-pretty-arglist fun))
-  (format stream "Its methods are:")
-  (dolist (meth (generic-function-methods fun))
-    (format stream "~2%    ~{~S ~}~:S =>~%"
-            (method-qualifiers meth)
-            (unparse-specializers meth))
-    (describe-object (or (method-fast-function meth)
-			 (method-function meth))
-		     stream))
-  (when *describe-metaobjects-as-objects-p*
-    (call-next-method)))
-
-;;;
-;;;
-;;;
-(defmethod describe-object ((class class) stream)
-  (flet ((pretty-class (c) (or (class-name c) c)))
-    (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
-      (ft "~&~S is a class, it is an instance of ~S.~%"
-	  class (pretty-class (class-of class)))
-      (let ((name (class-name class)))
-	(if name
-	    (if (eq class (find-class name nil))
-		(ft "Its proper name is ~S.~%" name)
-		(ft "Its name is ~S, but this is not a proper name.~%" name))
-	    (ft "It has no name (the name is NIL).~%")))
-      (ft "The direct superclasses are: ~:S, and the direct~%~
-           subclasses are: ~:S.  The class precedence list is:~%~S~%~
-           There are ~D methods specialized for this class."
-	  (mapcar #'pretty-class (class-direct-superclasses class))
-	  (mapcar #'pretty-class (class-direct-subclasses class))
-	  (mapcar #'pretty-class (class-precedence-list class))
-	  (length (specializer-direct-methods class)))))
-  (when *describe-metaobjects-as-objects-p*
-    (call-next-method)))
-
-(defun describe-package (object stream)
-  (unless (packagep object) (setq object (find-package object)))
-  (format stream "~&~S is a ~S.~%" object (type-of object))
-  (let ((nick (package-nicknames object)))
-    (when nick
-      (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
-	      (butlast nick) (first (last nick)))))  
-  (let* (#+cmu (internal (lisp::package-internal-symbols object))
-	 (internal-count #+cmu (- (lisp::package-hashtable-size internal)
-				  (lisp::package-hashtable-free internal))
-			 #-cmu 0)
-	 #+cmu (external (lisp::package-external-symbols object))
-	 (external-count #+cmu (- (lisp::package-hashtable-size external)
-				  (lisp::package-hashtable-free external))
-			 #-cmu 0))
-    #-cmu (do-external-symbols (sym object)
-	    (declare (ignore sym))
-	    (incf external-count))
-    #-cmu (do-symbols (sym object)
-	    (declare (ignore sym))
-	    (incf internal-count))
-    #-cmu (decf internal-count external-count)
-    (format stream "It has ~D internal and ~D external symbols (~D total).~%"
-	    internal-count external-count (+ internal-count external-count)))
-  (let ((used (package-use-list object)))
-    (when used
-      (format stream "It uses the packages ~{~S~^, ~}.~%"
-	      (mapcar #'package-name used))))
-  (let ((users (package-use-list object)))
-    (when users
-      (format stream "It is used by the packages ~{~S~^, ~}.~%"
-	      (mapcar #'package-name users)))))
-
-#+cmu
-(defmethod describe-object ((object package) stream)
-  (describe-package object stream))
-
-#+cmu
-(defmethod describe-object ((object hash-table) stream)
-  (format stream "~&~S is an ~a hash table."
-	  object
-	  #-cmu17 (lisp::hash-table-kind object)
-	  #+cmu17 (lisp::hash-table-test object))
-  (format stream "~&Its size is ~d buckets."
-	  (lisp::hash-table-size object))
-  (format stream "~&Its rehash-size is ~d."
-	  (lisp::hash-table-rehash-size object))
-  (format stream "~&Its rehash-threshold is ~d."
-	  (lisp::hash-table-rehash-threshold object))
-  (format stream "~&It currently holds ~d entries."
-	  (lisp::hash-table-number-entries object)))
-
-
-
-;;;
-;;; trace-method and untrace-method accept method specs as arguments.  A
-;;; method-spec should be a list like:
-;;;   (<generic-function-spec> qualifiers* (specializers*))
-;;; where <generic-function-spec> should be either a symbol or a list
-;;; of (SETF <symbol>).
-;;;
-;;;   For example, to trace the method defined by:
-;;;
-;;;     (defmethod foo ((x spaceship)) 'ss)
-;;;
-;;;   You should say:
-;;;
-;;;     (trace-method '(foo (spaceship)))
-;;;
-;;;   You can also provide a method object in the place of the method
-;;;   spec, in which case that method object will be traced.
-;;;
-;;; For untrace-method, if an argument is given, that method is untraced.
-;;; If no argument is given, all traced methods are untraced.
-;;;
-(defclass traced-method (method)
-     ((method :initarg :method)
-      (function :initarg :function
-		:reader method-function)
-      (generic-function :initform nil
-			:accessor method-generic-function)))
-
-(defmethod method-lambda-list ((m traced-method))
-  (with-slots (method) m (method-lambda-list method)))
-
-(defmethod method-specializers ((m traced-method))
-  (with-slots (method) m (method-specializers method)))
-
-(defmethod method-qualifiers ((m traced-method))
-  (with-slots (method) m (method-qualifiers method)))
-
-(defmethod accessor-method-slot-name ((m traced-method))
-  (with-slots (method) m (accessor-method-slot-name method)))
-
-(defvar *traced-methods* ())
-
-(defun trace-method (spec &rest options)
-  #+copy-&rest-arg (setq options (copy-list options))
-  (multiple-value-bind (gf omethod name)
-      (parse-method-or-spec spec)
-    (let* ((tfunction (trace-method-internal (method-function omethod)
-					     name
-					     options))
-	   (tmethod (make-instance 'traced-method
-				   :method omethod
-				   :function tfunction)))
-      (remove-method gf omethod)
-      (add-method gf tmethod)
-      (pushnew tmethod *traced-methods*)
-      tmethod)))
-
-(defun untrace-method (&optional spec)  
-  (flet ((untrace-1 (m)
-	   (let ((gf (method-generic-function m)))
-	     (when gf
-	       (remove-method gf m)
-	       (add-method gf (slot-value m 'method))
-	       (setq *traced-methods* (remove m *traced-methods*))))))
-    (if (not (null spec))
-	(multiple-value-bind (gf method)	    
-	    (parse-method-or-spec spec)
-	  (declare (ignore gf))
-	  (if (memq method *traced-methods*)
-	      (untrace-1 method)
-	      (error "~S is not a traced method?" method)))
-	(dolist (m *traced-methods*) (untrace-1 m)))))
-
-(defun trace-method-internal (ofunction name options)
-  (eval `(untrace ,name))
-  (setf (symbol-function name) ofunction)
-  (eval `(trace ,name ,@options))
-  (symbol-function name))
-
-
-
-
-;(defun compile-method (spec)
-;  (multiple-value-bind (gf method name)
-;      (parse-method-or-spec spec)
-;    (declare (ignore gf))
-;    (compile name (method-function method))
-;    (setf (method-function method) (symbol-function name))))
-
-(defmacro undefmethod (&rest args)
-  #+(or (not :lucid) :lcl3.0)
-  (declare (arglist name {method-qualifier}* specializers))
-  `(undefmethod-1 ',args))
-
-(defun undefmethod-1 (args)
-  (multiple-value-bind (gf method)
-      (parse-method-or-spec args)
-    (when (and gf method)
-      (remove-method gf method)
-      method)))
-
-
-(pushnew :pcl *features*)
-(pushnew :portable-commonloops *features*)
-(pushnew :pcl-structures *features*)
diff --git a/pcl/excl-low.lisp b/pcl/excl-low.lisp
deleted file mode 100644
index 54c734b4def26d41fc3ba078448798afeac3b517..0000000000000000000000000000000000000000
--- a/pcl/excl-low.lisp
+++ /dev/null
@@ -1,136 +0,0 @@
-;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;; 
-;;; This is the EXCL (Franz) lisp version of the file portable-low.
-;;; 
-;;; This is for version 1.1.2.  Many of the special symbols now in the lisp
-;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in
-;;; a later release so this will need to be changed.
-;;; 
-
-(in-package 'pcl)
-
-(defmacro without-interrupts (&body body)
-  `(let ((outer-interrupts excl::*without-interrupts*)
-	 (excl::*without-interrupts* 0))
-     (macrolet ((interrupts-on  ()
-		  '(unless outer-interrupts
-		     (setq excl::*without-interrupts* nil)))
-		(interrupts-off ()
-		  '(setq excl::*without-interrupts* 0)))
-       ,.body)))
-
-(eval-when (compile load eval)
-  (unless (fboundp 'excl::sy_hash)
-    (setf (symbol-function 'excl::sy_hash)
-	  (symbol-function 'excl::_sy_hash-value)))
-  )
-
-(defmacro memq (item list)
-  (let ((list-var (gensym))
-	(item-var (gensym)))
-    `(prog ((,list-var ,list)
-	    (,item-var ,item))
-	start
-	   (cond ((null ,list-var)
-		  (return nil))
-		 ((eq (car ,list-var) ,item-var)
-		  (return ,list-var))
-		 (t
-		  (pop ,list-var)
-		  (go start))))))
-
-(defun std-instance-p (x)
-  (and (excl::structurep x)
-       (locally
-	 (declare #.*optimize-speed*)
-	 (eq (svref x 0) 'std-instance))))
-
-(excl::defcmacro std-instance-p (x)
-  (once-only (x)
-    `(and (excl::structurep ,x)
-	  (locally
-	    (declare #.*optimize-speed*)
-	    (eq (svref ,x 0) 'std-instance)))))
-
-(excl::defcmacro fast-method-call-p (x)
-  (once-only (x)
-    `(and (excl::structurep ,x)
-	  (locally
-	    (declare #.*optimize-speed*)
-	    (eq (svref ,x 0) 'fast-method-call)))))
-
-(defmacro %std-instance-wrapper (x)
-  `(svref ,x 1))
-
-(defmacro %std-instance-slots (x)
-  `(svref ,x 2))
-
-(defun printing-random-thing-internal (thing stream)
-  (format stream "~O" (excl::pointer-to-fixnum thing)))
-
-#-vax
-(defun set-function-name-1 (fn new-name ignore)
-  (declare (ignore ignore))
-  (cond ((excl::function-object-p fn)
-	 (setf (excl::fn_symdef fn) new-name))
-	(t nil))
-  fn)
-
-(defun function-arglist (f)
-  (excl::arglist f))
-
-(defun symbol-append (sym1 sym2 &optional (package *package*))
-   ;; This is a version of symbol-append from macros.cl
-   ;; It insures that all created symbols are of one case and that
-   ;; case is the current prefered case.
-   ;; This special version of symbol-append is not necessary if all you
-   ;; want to do is compile and run pcl in a case-insensitive-upper 
-   ;; version of cl.  
-   ;;
-   (let ((string (string-append sym1 sym2)))
-      (case excl::*current-case-mode*
-	 ((:case-insensitive-lower :case-sensitive-lower)
-	  (setq string (string-downcase string)))
-	 ((:case-insensitive-upper :case-sensitive-upper)
-	  (setq string (string-upcase string))))
-      (intern string package)))
-
-;;; Define inspector hooks for PCL object instances.
-
-(defun (:property pcl::std-instance :inspector-function) (object)
-  (let ((class (class-of object)))
-    (cons (inspect::make-field-def "class" #'class-of :lisp)
-	  (mapcar #'(lambda (slot)
-		      (inspect::make-field-def
-		       (string (slot-definition-name slot))
-		       #'(lambda (x)
-			   (slot-value-using-class class x slot))
-		       :lisp))
-		  (slots-to-inspect class object)))))
-
-(defun (:property pcl::std-instance :inspector-type-function) (x)
-  (class-name (class-of x)))
diff --git a/pcl/extensions.lisp b/pcl/extensions.lisp
deleted file mode 100644
index 32231cf41af32d41286bd9b78d4051f75b7957a4..0000000000000000000000000000000000000000
--- a/pcl/extensions.lisp
+++ /dev/null
@@ -1,496 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*-
-
-;;;
-;;; *************************************************************************
-;;;
-;;;   File: extensions.lisp.
-;;;
-;;;     by Trent E. Lange, Effective Date 04-23-92
-;;;
-;;;
-;;;  This file contains a small set of useful extensions to PCL. 
-;;;
-;;; Permission is granted to any individual or institution to use, copy,
-;;; modify and distribute this document.
-;;;
-;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu
-;;; *************************************************************************
-;;;
-
-(in-package 'pcl)
-
-(eval-when (compile load eval)
-
-(defvar *extensions-exports*
-        '(set-standard-instance-access
-          set-funcallable-instance-access
-
-          funcallable-instance-slot-value
-          set-funcallable-instance-slot-value
-          funcallable-instance-slot-boundp
-          standard-instance-slot-value
-          set-standard-instance-slot-value
-          standard-instance-slot-boundp
-          structure-instance-slot-value
-          set-structure-instance-slot-value
-          structure-instance-slot-boundp
-
-          #+pcl-user-instances
-          user-instance-slot-value
-          #+pcl-user-instances
-          set-user-instance-slot-value
-          #+pcl-user-instances
-          user-instance-slot-boundp
-
-          with-optimized-slots
-          with-standard-instance-slots
-
-          method-needs-next-methods-p
-          map-all-classes
-          finalize-all-classes
-
-          updater
-          record-updater))
-)
-
-(defclass updater ()
-  ((dependent :initarg :dependent :reader dependent)))
-
-(defun record-updater (class dependee dependent &rest initargs)
-  (let ((updater
-         (apply #'make-instance class :dependent dependent initargs)))
-    (add-dependent dependee updater)
-    updater))
-
-
-(defun finalize-all-classes (&optional (root-name 't))
-  "Makes sure that all classes are finalized.  If Root-Name is supplied,
-   then finalizes Root-Name and all of its subclasses and their subclasses."
-  (map-all-classes #'(lambda (class)
-                       (unless (class-finalized-p class)
-                         (finalize-inheritance class)))
-                   root-name))
-
-
-;;;
-;;;
-;;;
-
-
-(defmacro slot-value-from-index (instance wrapper slot-name slots index)
-  "Returns instance's slot-value given slot-name's index."
-  (once-only (index)
-    `(if ,index
-         (let ((val (%svref ,slots ,index)))
-           (if (eq val ',*slot-unbound*)
-               (slot-unbound (wrapper-class ,wrapper) ,instance ,slot-name)
-             val))
-         (if *safe-to-use-slot-value-wrapper-optimizations-p*
-             (get-class-slot-value-1 ,instance ,wrapper ,slot-name)
-             (accessor-slot-value ,instance ,slot-name)))))
-
-(defmacro set-slot-value-from-index
-          (instance wrapper slot-name slots index new-value)
-  "Sets instance's slot-value to new-value given slot-name's index."
-  (once-only (index)
-    `(if ,index
-          (setf (%svref ,slots ,index) ,new-value)
-          (if *safe-to-use-set-slot-value-wrapper-optimizations-p*
-              (set-class-slot-value-1 ,instance ,wrapper ,slot-name ,new-value)
-              (setf (accessor-slot-value ,instance ,slot-name) ,new-value)))))
-
-(defsetf slot-value-from-index set-slot-value-from-index)
-
-(defmacro with-slots-slot-value-from-index
-          (instance wrapper slot-name slots index variable-instance)
-  "Returns instance's slot-value given slot-name's index."
-  (cond
-   ((consp wrapper)
-    `(let ((wrapper ,wrapper))
-       (unless (eq (wrapper-state wrapper) 't)
-         (setf wrapper (wrapper-state-trap wrapper ,instance)))
-       (with-slots-slot-value-from-index
-         ,instance wrapper ,slot-name ,slots ,index ,variable-instance)))
-   (variable-instance
-    `(let ((,instance ,variable-instance))
-       (with-slots-slot-value-from-index
-         ,instance ,wrapper ,slot-name ,slots ,index NIL)))
-   (T `(slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index))))
-
-(defmacro set-with-slots-slot-value-from-index
-          (instance wrapper slot-name slots index variable-instance new-value)
-  "Sets instance's slot-value to new-value given slot-name's index."
-  (cond
-   ((consp wrapper)
-    `(let ((wrapper ,wrapper))
-       (unless (eq (wrapper-state wrapper) 't)
-         (setf wrapper (wrapper-state-trap wrapper ,instance)))
-       (set-with-slots-slot-value-from-index
-         ,instance wrapper ,slot-name ,slots ,index ,variable-instance
-         ,new-value)))
-   (variable-instance
-    `(let ((,instance ,variable-instance))
-       (set-with-slot-slots-value-from-index
-         ,instance ,wrapper ,slot-name ,slots ,index NIL ,new-value)))
-   (T
-    `(setf (slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index)
-           ,new-value))))
-
-(defsetf with-slots-slot-value-from-index
-         set-with-slots-slot-value-from-index)
-
-(defmacro with-slots-slot-value-from-wrapper-and-slots
-    (instance slot-name wrapper slots-layout slots variable-instance)
-  (cond
-   (variable-instance
-    `(let ((,instance ,variable-instance))
-       (with-slots-slot-value-from-wrapper-and-slots
-         ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL)))
-   ((consp wrapper)
-    `(if *safe-to-use-slot-value-wrapper-optimizations-p*
-         (let ((wrapper ,wrapper))
-           (unless (eq (wrapper-state wrapper) 't)
-             (setf wrapper (wrapper-state-trap wrapper ,instance)))
-           (slot-value-from-wrapper-and-slots ,instance ,slot-name
-             wrapper ,slots-layout ,slots NIL))
-         (accessor-slot-value ,instance ,slot-name)))
-   (T
-    `(if *safe-to-use-slot-value-wrapper-optimizations-p*
-         (slot-value-from-wrapper-and-slots
-           ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL)
-         (accessor-slot-value ,instance ,slot-name)))))
-
-(defmacro set-with-slots-slot-value-from-wrapper-and-slots
-    (instance slot-name wrapper slots-layout slots variable-instance new-value)
-  (cond
-   (variable-instance
-    `(let ((,instance ,variable-instance))
-       (set-with-slots-slot-value-from-wrapper-and-slots
-         ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL ,new-value)))
-   ((consp wrapper)
-    `(if *safe-to-use-set-slot-value-wrapper-optimizations-p*
-         (let ((wrapper ,wrapper))
-           (unless (eq (wrapper-state wrapper) 't)
-             (setf wrapper (wrapper-state-trap wrapper ,instance)))
-           (setf (slot-value-from-wrapper-and-slots ,instance ,slot-name
-                    wrapper ,slots-layout ,slots NIL)
-                 ,new-value))
-         (setf (accessor-slot-value ,instance ,slot-name) ,new-value)))
-   (T
-    `(if *safe-to-use-set-slot-value-wrapper-optimizations-p*
-         (setf (slot-value-from-wrapper-and-slots
-                 ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL)
-               ,new-value)
-         (setf (accessor-slot-value ,instance ,slot-name) ,new-value)))))
-
-(defsetf with-slots-slot-value-from-wrapper-and-slots
-         set-with-slots-slot-value-from-wrapper-and-slots)
-
-(defun tree-memq-p (item form)
-  (cond ((consp form)
-         (or (tree-memq-p item (car form))
-             (tree-memq-p item (cdr form))))
-        (T (eq item form)))) 
-
-(defmacro with-optimized-slots (slot-entries instance-form &body body)
-  "Optimized version of With-Slots that is faster because it factors out
-   functions common to all slot accesses on the instance.  It has two
-   extensions to With-Slots: (1) the second value of slot-entries are
-   evaluated as forms rather than considered to be hard slot-names, allowing
-   access of variable slot-names.  (2) if a :variable-instance keyword is
-   the first part of the body, then the instance-form is treated as a variable
-   form, which is always expected to return an instance of the same class.
-   The value of the keyword must be an instance that is the same class as
-   instance-form will always return."
-  ;;  E.g. (with-optimized-slots (foo-slot
-  ;;                         (foo-slot-accessor     'foo-slot)
-  ;;                         (variable-slot-accessor variable-slot))
-  ;;                        instance
-  ;;                        :instance-form (car instances-of-same-class)
-  ;;         (loop for instance in objects-of-same-class
-  ;;               as  variable-slot in variable-slots
-  ;;               collect (list foo-slot
-  ;;                             foo-slot-accessor
-  ;;                             variable-slot-accessor)))
-  ;;   ==> (loop for instance in objects-of-same-class
-  ;;             as  variable-slot in variable-slots
-  ;;             collect (list (slot-value instance 'foo-slot)
-  ;;                           (slot-value instance 'foo-slot)
-  ;;                           (slot-value instance variable-slot)))
-  (build-with-optimized-slots-form slot-entries instance-form body))
-
-(defmacro with-standard-instance-slots (slot-entries instance-form &body body)
-  "Optimized version of With-Slots that assumes that the instance-form
-   evaluates to a standard-instance.  The result is undefined if it does not.
-   With-standard-instance-slots is faster than With-Slots because it factors
-   out functions common to all slot accesses on the instance.  It has two
-   extensions to With-Slots: (1) the second value of slot-entries are
-   evaluated as forms rather than considered to be hard slot-names, allowing
-   access of variable slot-names.  (2) if a :variable-instance keyword is
-   the first part of the body, then the instance-form is treated as a variable
-   form, which is always expected to return an instance of the same class.
-   The value of the keyword must be an instance that is the same class as
-   instance-form will always return."
-  (build-with-optimized-slots-form slot-entries instance-form body 'std-instance))
-
-(defun build-with-optimized-slots-form (slot-entries instance-form body
-                                        &optional instance-type)
-  (let* ((variable-instance
-           (if (eq (car body) :variable-instance)
-               (prog1
-                 (cadr body)
-                 (setf body (cddr body)))))
-         (hard-accessors
-           (let ((collect NIL))
-             (dolist (slot-entry slot-entries (nreverse collect))
-               (when (and (symbolp slot-entry)
-                          (tree-memq-p slot-entry body))
-                 (push (cons slot-entry slot-entry) collect))
-               (when (and (consp slot-entry)
-                          (constantp   (second slot-entry))
-                          (tree-memq-p (car slot-entry) body))
-                 (push (cons (car slot-entry) (second (second slot-entry)))
-                       collect)))))
-         (variable-accessors
-           (let ((collect NIL))
-             (dolist (slot-entry slot-entries (nreverse collect))
-               (when (and (consp slot-entry)
-                          (not (constantp (second slot-entry)))
-                          (tree-memq-p (car slot-entry) body))
-                 (push slot-entry collect))))))
-    (if *safe-to-use-slot-wrapper-optimizations-p*
-        (build-maybe-safe-w-o-s-v hard-accessors variable-accessors
-                                  instance-form body variable-instance
-                                  instance-type)
-        (build-with-accessor-s-v  hard-accessors variable-accessors
-                                  instance-form body variable-instance))))
-
-(defun build-maybe-safe-w-o-s-v (hard-accessors variable-accessors
-                                 instance-form body variable-instance
-                                 instance-type)
-  (let* ((instance-string
-           (if (symbolp instance-form) (symbol-name instance-form) ""))
-         (instance-form-var
-           (if (and variable-instance (simple-eval-access-p instance-form))
-               instance-form
-             (gensym
-               (concatenate 'simple-string instance-string "-INSTANCE-FORM"))))
-         (prototype-form
-           (if variable-instance
-               (if (simple-eval-access-p variable-instance)
-                   variable-instance
-                 (gensym (concatenate 'simple-string "VARIABLE-INSTANCE"
-                                                     instance-string)))
-               instance-form-var))
-         (wrapper-var
-           (gensym (concatenate 'simple-string instance-string "-WRAPPER")))
-         (slots-var
-           (unless variable-instance
-             (gensym (concatenate 'simple-string instance-string "-SLOTS"))))
-         (type-var
-           (when (and variable-instance (not instance-type))
-             (gensym (concatenate 'simple-string instance-string "-TYPE"))))
-         (type-var-std 1)
-         (type-var-fsc 2)
-         #+pcl-user-instances
-         (type-var-user 3)
-         (slot-index-vars
-           (mapcar #'(lambda (slot-entry)
-                         (list (car slot-entry)
-                               (cdr slot-entry)
-                               (gensym (concatenate
-                                         'simple-string
-                                         (if (string= instance-string "")
-                                             "INSTANCE-FORM-"
-                                           instance-string)
-                                         (symbol-name (cdr slot-entry))
-                                         "-INDEX"))))
-                   (remove-duplicates hard-accessors :key #'cdr)))
-         (slots-layout-var
-           (gensym (concatenate 'simple-string "SLOTS-LAYOUT-" instance-string)))
-         (runtime-slots-form
-           (if variable-instance
-               (ecase instance-type
-                 (std-instance  `(std-instance-slots ,instance-form-var))
-                 (fsc-instance  `(fsc-instance-slots ,instance-form-var))
-                 #+pcl-user-instances
-                 (user-instance `(get-user-instance-slots ,instance-form-var))
-                 ((nil)
-                  `(case ,type-var
-                     (,type-var-std  (std-instance-slots ,instance-form-var))
-                     (,type-var-fsc  (fsc-instance-slots ,instance-form-var))
-                     #+pcl-user-instances
-                     (,type-var-user (get-user-instance-slots ,instance-form-var)))))
-                slots-var))
-         (runtime-wrapper-form
-           (if variable-instance
-               (ecase instance-type
-                 (std-instance  `(std-instance-wrapper ,instance-form-var))
-                 (fsc-instance  `(fsc-instance-wrapper ,instance-form-var))
-                 #+pcl-user-instances
-                 (user-instance `(get-user-instance-wrapper ,instance-form-var))
-                 ((nil)
-                  `(case ,type-var
-                     (,type-var-std  (std-instance-wrapper ,instance-form-var))
-                     (,type-var-fsc  (fsc-instance-wrapper ,instance-form-var))
-                     #+pcl-user-instances
-                     (,type-var-user (get-user-instance-wrapper ,instance-form-var)))))
-               wrapper-var)))
-    (declare (type simple-string instance-string)
-             (type list          slot-index-vars))
-    `(let (,@(unless variable-instance
-              `((,instance-form-var ,instance-form)))
-           ,@(when (and variable-instance
-                        (not (eq prototype-form variable-instance)))
-               `((,prototype-form ,variable-instance)))
-           ,wrapper-var ,slots-layout-var
-           ,@(if variable-instance
-                 (if type-var `((type-var 0)))
-                 (list slots-var))
-           ,@(mapcar #'third slot-index-vars))
-       ,@(when type-var `((declare (type index ,type-var))))
-       (when *safe-to-use-slot-wrapper-optimizations-p*
-         ,@(ecase instance-type
-             (std-instance
-              `((setf ,wrapper-var (std-instance-wrapper ,prototype-form))
-                ,@(unless variable-instance
-                   `((setf ,slots-var (std-instance-slots ,prototype-form))))))
-             (fsc-instance
-              `((setf ,wrapper-var (fsc-instance-wrapper ,prototype-form))
-                ,@(unless variable-instance
-                   `((setf ,slots-var (fsc-instance-slots ,prototype-form))))))
-             #+pcl-user-instances
-             (user-instance
-              `((setf ,wrapper-var (get-user-instance-wrapper ,prototype-form))
-                ,@(unless variable-instance
-                   `((setf ,slots-var (get-user-instance-slots ,prototype-form))))))
-             ((nil)
-             `((cond
-                ((std-instance-p ,prototype-form)
-                 (setf ,wrapper-var (std-instance-wrapper ,prototype-form))
-                 ,(if variable-instance
-                      `(setf ,type-var ,type-var-std)
-                    `(setf ,slots-var (std-instance-slots ,prototype-form))))
-                ((fsc-instance-p ,prototype-form)
-                 (setf ,wrapper-var (fsc-instance-wrapper ,prototype-form))
-                 ,(if variable-instance
-                      `(setf ,type-var ,type-var-fsc)
-                    `(setf ,slots-var (fsc-instance-slots ,prototype-form))))
-                #+pcl-user-instances
-                ((get-user-instance-p ,prototype-form)
-                 (setf ,wrapper-var (get-user-instance-wrapper ,prototype-form))
-                 ,(if variable-instance
-                      `(setf ,type-var ,type-var-user)
-                    `(setf ,slots-var (get-user-instance-slots ,prototype-form))))))))
-         ,@(if instance-type
-               (build-w-s-v-find-slot-indices wrapper-var slots-layout-var
-                  prototype-form slot-index-vars)
-               `((when ,wrapper-var
-                  ,@(build-w-s-v-find-slot-indices wrapper-var slots-layout-var
-                       prototype-form slot-index-vars)))))
-       (symbol-macrolet
-         (,@(mapcar
-              #'(lambda (slot-cons)
-                  `(,(car slot-cons)
-                     (with-slots-slot-value-from-index
-                        ,instance-form-var
-                        ,runtime-wrapper-form
-                        ',(cdr slot-cons)
-                        ,runtime-slots-form
-                        ,(third (assoc (car slot-cons) slot-index-vars
-                                       :test #'eq))
-                        ,(when (and variable-instance
-                                    (not (eq variable-instance
-                                             instance-form-var)))
-                           variable-instance))))
-              hard-accessors)
-          ,@(mapcar
-              #'(lambda (variable-cons)
-                  `(,(car variable-cons)
-                    (with-slots-slot-value-from-wrapper-and-slots
-                      ,instance-form-var
-                      ,(second variable-cons)
-                      ,runtime-wrapper-form
-                      ,slots-layout-var
-                      ,runtime-slots-form
-                      ,(when (and variable-instance
-                                  (not (eq variable-instance
-                                           instance-form-var)))
-                         variable-instance))))
-              variable-accessors))
-         ,@body))))
-
-(defun build-w-s-v-find-slot-indices (wrapper-var slots-layout-var
-                                      prototype-form
-                                      slot-index-vars)
-  (declare (type list slot-index-vars))
-  `((unless (eq (wrapper-state ,wrapper-var) 't)
-      (setf ,wrapper-var
-            (wrapper-state-trap ,wrapper-var ,prototype-form)))
-    (setf ,slots-layout-var (wrapper-instance-slots-layout ,wrapper-var))
-    ,@(if (<= (length slot-index-vars) 2)
-          (mapcar
-            #'(lambda (slot-cons)
-                `(setf ,(third slot-cons)
-                       (instance-slot-index-from-slots-layout
-                         ,slots-layout-var ',(second slot-cons))))
-            slot-index-vars)
-          ;; More than two slots, so more efficient to search slots-layout-var
-          ;; only once, rather than once for each with instance-slot-index.
-          (labels
-            ((build-comps (slot-vars index)
-               (if slot-vars
-                   `(if (eq slot-name ',(second (car slot-vars)))
-                        (progn
-                          (setf ,(third (car slot-vars)) ,index)
-                          (if (= matches ,(1- (length slot-index-vars)))
-                              (go end-loop)
-                            (setf matches (the fixnum (1+ matches)))))
-                     ,(build-comps (cdr slot-vars) index)))))
-            `((block nil
-                (let ((slots-left ,slots-layout-var)
-                      (slot-name  NIL)
-                      (index      0)
-                      (matches    0))
-                  (declare (type fixnum index matches))
-                  (when slots-left
-                    (tagbody
-                      begin-instance-slots-loop
-                        (setf slot-name (car slots-left))
-                        ,(build-comps slot-index-vars 'index)
-                        (setf index (the fixnum (1+ index)))
-                        (if (null (setf slots-left (cdr slots-left)))
-                            (go end-loop))
-                        (go begin-instance-slots-loop)
-                      end-loop)))))))))
-
-(defun build-with-accessor-s-v (hard-accessors variable-accessors
-                                instance-form body variable-instance)
-  ;; Build the body for with-optimized-slot-value when it is unsafe
-  ;; and accessor-slot-value must be used.
-  (let ((instance-form-var
-          (if variable-instance instance-form (gensym "INSTANCE-FORM"))))
-  `(let (,@(unless variable-instance
-            `((,instance-form-var ,instance-form))))
-     (symbol-macrolet
-       (,@(mapcar
-            #'(lambda (slot-cons)
-                `(,(car slot-cons)
-                  (accessor-slot-value ,instance-form-var
-                                       ',(cdr slot-cons))))
-            hard-accessors)
-        ,@(mapcar
-            #'(lambda (variable-cons)
-                `(,(car variable-cons)
-                  (accessor-slot-value ,instance-form-var
-                                       ,(second variable-cons))))
-            variable-accessors))
-       ,@body))))
-
-
-#-(or KCL IBCL)
-(export *extensions-exports* *the-pcl-package*)
-
-#+(or KCL IBCL)
-(mapc 'export (list *extensions-exports*) (list *the-pcl-package*))
-
diff --git a/pcl/fast-init.lisp b/pcl/fast-init.lisp
deleted file mode 100644
index 31224265c19e4bfabcb508400c48b497759b5073..0000000000000000000000000000000000000000
--- a/pcl/fast-init.lisp
+++ /dev/null
@@ -1,888 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;;
-;;; This file defines the optimized make-instance functions.
-;;; 
-
-(in-package :pcl)
-
-(defvar *compile-make-instance-functions-p* nil)
-
-(defun update-make-instance-function-table (&optional (class *the-class-t*))
-  (when (symbolp class) (setq class (find-class class)))
-    (when (eq class *the-class-t*) (setq class *the-class-slot-object*))
-    (when (memq *the-class-slot-object* (class-precedence-list class))
-      (map-all-classes #'reset-class-initialize-info class)))
-
-(defun constant-symbol-p (form)
-  (and (constantp form) 
-       (let ((object (eval form)))
-	 (and (symbolp object)
-	      (symbol-package object)))))
-
-(defvar *make-instance-function-keys* nil)
-
-(defun expand-make-instance-form (form)
-  (let ((class (cadr form)) (initargs (cddr form))
-	(keys nil)(allow-other-keys-p nil) key value)
-    (when (and (constant-symbol-p class)
-	       (let ((initargs-tail initargs))
-		 (loop (when (null initargs-tail) (return t))
-		       (unless (constant-symbol-p (car initargs-tail))
-			 (return nil))		       
-		       (setq key (eval (pop initargs-tail)))
-		       (setq value (pop initargs-tail))
-		       (when (eq ':allow-other-keys key)
-			 (setq allow-other-keys-p value))
-		       (push key keys))))
-      (let* ((class (eval class))
-	     (keys (nreverse keys))
-	     (key (list class keys allow-other-keys-p))
-	     (sym (make-instance-function-symbol key)))
-	(push key *make-instance-function-keys*)
-	(when sym
-	  `(,sym ',class (list ,@initargs)))))))
-
-(defmacro expanding-make-instance-top-level (&rest forms &environment env)
-  (let* ((*make-instance-function-keys* nil)
-	 (form (macroexpand `(expanding-make-instance ,@forms) env)))
-    `(progn
-       ,@(when *make-instance-function-keys*
-	   `((get-make-instance-functions ',*make-instance-function-keys*)))
-       ,form)))
-	  
-(defmacro expanding-make-instance (&rest forms &environment env)
-  `(progn
-     ,@(mapcar #'(lambda (form)
-		   (walk-form form env 
-			      #'(lambda (subform context env)
-				  (declare (ignore env))
-				  (or (and (eq context ':eval)
-					   (consp subform)
-					   (eq (car subform) 'make-instance)
-					   (expand-make-instance-form subform))
-				      subform))))
-	       forms)))
-
-(defmacro defconstructor
-	  (name class lambda-list &rest initialization-arguments)
-  `(expanding-make-instance-top-level
-    (defun ,name ,lambda-list
-      (make-instance ',class ,@initialization-arguments))))
-
-(defun get-make-instance-functions (key-list)
-  (dolist (key key-list)
-    (let* ((cell (find-class-cell (car key)))
-	   (make-instance-function-keys 
-	    (find-class-cell-make-instance-function-keys cell))
-	   (mif-key (cons (cadr key) (caddr key))))
-      (unless (find mif-key make-instance-function-keys 
-		    :test #'equal)
-	(push mif-key (find-class-cell-make-instance-function-keys cell))
-	(let ((class (find-class-cell-class cell)))
-	  (when (and class (not (forward-referenced-class-p class)))
-	    (update-initialize-info-internal
-	     (initialize-info class (car mif-key) nil (cdr mif-key))
-	     'make-instance-function)))))))
-
-(defun make-instance-function-symbol (key)
-  (let* ((class (car key))
-	 (symbolp (symbolp class)))
-    (when (or symbolp (classp class))
-      (let* ((class-name (if (symbolp class) class (class-name class)))
-	     (keys (cadr key))
-	     (allow-other-keys-p (caddr key)))
-	(when (and (or symbolp 
-		       (and (symbolp class-name)
-			    (eq class (find-class class-name nil))))
-		   (symbol-package class-name))
-	  (let ((*package* *the-pcl-package*)
-		(*print-length* nil) (*print-level* nil)
-		(*print-circle* nil) (*print-case* :upcase)
-		(*print-pretty* nil))
-	    (intern (format nil "MAKE-INSTANCE ~S ~S ~S"
-			    class-name keys allow-other-keys-p))))))))
-
-(defun make-instance-1 (class initargs)
-  (apply #'make-instance class initargs))
-
-(defmacro define-cached-reader (type name trap)
-  (let ((reader-name (intern (format nil "~A-~A" type name)))
-	(cached-name (intern (format nil "~A-CACHED-~A" type name))))
-    `(defmacro ,reader-name (info)
-       `(let ((value (,',cached-name ,info)))
-	  (if (eq value ':unknown)
-	      (progn
-		(,',trap ,info ',',name)
-		(,',cached-name ,info))
-	      value)))))
-
-(eval-when (compile load eval)
-(defparameter initialize-info-cached-slots
-  '(valid-p				; t or (:invalid key)
-    ri-valid-p
-    initargs-form-list
-    new-keys
-    default-initargs-function
-    shared-initialize-t-function
-    shared-initialize-nil-function
-    constants
-    combined-initialize-function ; allocate-instance + shared-initialize
-    make-instance-function ; nil means use gf
-    make-instance-function-symbol)))
-
-(defmacro define-initialize-info ()
-  (let ((cached-slot-names 
-	 (mapcar #'(lambda (name)
-		     (intern (format nil "CACHED-~A" name)))
-		 initialize-info-cached-slots))
-	(cached-names
-	 (mapcar #'(lambda (name)
-		     (intern (format nil "~A-CACHED-~A" 
-				     'initialize-info name)))
-		 initialize-info-cached-slots)))
-    `(progn
-       (defstruct initialize-info 
-	 key wrapper 
-	 ,@(mapcar #'(lambda (name)
-		       `(,name :unknown))
-		   cached-slot-names))
-       (defmacro reset-initialize-info-internal (info)
-	 `(progn 
-	    ,@(mapcar #'(lambda (cname)
-			  `(setf (,cname ,info) ':unknown))
-		      ',cached-names)))
-       (defun initialize-info-bound-slots (info)
-	 (let ((slots nil))
-	   ,@(mapcar #'(lambda (name cached-name)
-			 `(unless (eq ':unknown (,cached-name info))
-			    (push ',name slots)))
-		     initialize-info-cached-slots cached-names)
-	   slots))
-      ,@(mapcar #'(lambda (name)
-		    `(define-cached-reader initialize-info ,name 
-		      update-initialize-info-internal))
-	        initialize-info-cached-slots))))
-
-(define-initialize-info)
-
-(defvar *initialize-info-cache-class* nil)
-(defvar *initialize-info-cache-initargs* nil)
-(defvar *initialize-info-cache-info* nil)
-
-(defvar *revert-initialize-info-p* nil)
-
-(defun reset-initialize-info (info)
-  (setf (initialize-info-wrapper info)
-	(class-wrapper (car (initialize-info-key info))))
-  (let ((slots-to-revert (if *revert-initialize-info-p*
-			     (initialize-info-bound-slots info)
-			     '(make-instance-function))))
-    (reset-initialize-info-internal info)
-    (dolist (slot slots-to-revert)
-      (update-initialize-info-internal info slot))
-    info))
-
-(defun reset-class-initialize-info (class)
-  (reset-class-initialize-info-1 (class-initialize-info class)))
-
-(defun reset-class-initialize-info-1 (cell)
-  (when (consp cell)
-    (when (car cell)
-      (reset-initialize-info (car cell)))
-    (let ((alist (cdr cell)))
-      (dolist (a alist)
-	(reset-class-initialize-info-1 (cdr a))))))
-
-(defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg)
-  (let ((info nil))
-    (if (and (eq *initialize-info-cache-class* class)
-	     (eq *initialize-info-cache-initargs* initargs))
-	(setq info *initialize-info-cache-info*)
-	(let ((initargs-tail initargs)
-	      (cell (or (class-initialize-info class)
-			(setf (class-initialize-info class) (cons nil nil)))))
-	  (loop (when (null initargs-tail) (return nil))
-		(let ((keyword (pop initargs-tail))
-		      (alist-cell cell))
-		  (when plist-p
-		    (if (eq keyword :allow-other-keys)
-			(setq allow-other-keys-arg (pop initargs-tail))
-			(pop initargs-tail)))
-		  (loop (let ((alist (cdr alist-cell)))
-			  (when (null alist)
-			    (setq cell (cons nil nil))
-			    (setf (cdr alist-cell) (list (cons keyword cell)))
-			    (return nil))
-			  (when (eql keyword (caar alist))
-			    (setq cell (cdar alist))
-			    (return nil))
-			  (setq alist-cell alist)))))
-	  (setq info (or (car cell)
-			 (setf (car cell) (make-initialize-info))))))
-    (let ((wrapper (initialize-info-wrapper info)))
-      (unless (eq wrapper (class-wrapper class))
-	(unless wrapper
-	  (let* ((initargs-tail initargs)
-		 (klist-cell (list nil))
-		 (klist-tail klist-cell))
-	    (loop (when (null initargs-tail) (return nil))
-		  (let ((key (pop initargs-tail)))
-		    (setf (cdr klist-tail) (list key)))
-		  (setf klist-tail (cdr klist-tail))
-		  (when plist-p (pop initargs-tail)))
-	    (setf (initialize-info-key info)
-		  (list class (cdr klist-cell) allow-other-keys-arg))))
-	(reset-initialize-info info)))
-    (setq *initialize-info-cache-class* class)
-    (setq *initialize-info-cache-initargs* initargs)
-    (setq *initialize-info-cache-info* info)    
-    info))
-
-(defun update-initialize-info-internal (info name)
-  (let* ((key (initialize-info-key info))
-	 (class (car key))
-	 (keys (cadr key))
-	 (allow-other-keys-arg (caddr key)))
-    (ecase name
-      ((initargs-form-list new-keys)
-       (multiple-value-bind (initargs-form-list new-keys)
-	   (make-default-initargs-form-list class keys)
-	 (setf (initialize-info-cached-initargs-form-list info) initargs-form-list)
-	 (setf (initialize-info-cached-new-keys info) new-keys)))
-      ((default-initargs-function)
-       (let ((initargs-form-list (initialize-info-initargs-form-list info)))
-	 (setf (initialize-info-cached-default-initargs-function info)
-	       (initialize-instance-simple-function 
-		'default-initargs-function info
-		class initargs-form-list))))
-      ((valid-p ri-valid-p)
-       (flet ((compute-valid-p (methods)
-		(or (not (null allow-other-keys-arg))
-		    (multiple-value-bind (legal allow-other-keys)
-			(check-initargs-values class methods)
-		      (or (not (null allow-other-keys))
-			  (dolist (key keys t)
-			    (unless (member key legal)
-			      (return (cons :invalid key)))))))))
-	 (let ((proto (class-prototype class)))
-	   (setf (initialize-info-cached-valid-p info)
-		 (compute-valid-p
-		  (list (list* 'allocate-instance class nil)
-			(list* 'initialize-instance proto nil)
-			(list* 'shared-initialize proto t nil))))
-	   (setf (initialize-info-cached-ri-valid-p info)
-		 (compute-valid-p 
-		  (list (list* 'reinitialize-instance proto nil)
-			(list* 'shared-initialize proto nil nil)))))))
-      ((shared-initialize-t-function)
-       (multiple-value-bind (initialize-form-list ignore)
-	   (make-shared-initialize-form-list class keys t nil)
-	 (declare (ignore ignore))
-	 (setf (initialize-info-cached-shared-initialize-t-function info)
-	       (initialize-instance-simple-function 
-		'shared-initialize-t-function info
-		class initialize-form-list))))
-      ((shared-initialize-nil-function)
-       (multiple-value-bind (initialize-form-list ignore)
-	   (make-shared-initialize-form-list class keys nil nil)
-	 (declare (ignore ignore))
-	 (setf (initialize-info-cached-shared-initialize-nil-function info)
-	       (initialize-instance-simple-function 
-		'shared-initialize-nil-function info 
-		class initialize-form-list))))
-      ((constants combined-initialize-function)
-       (let ((initargs-form-list (initialize-info-initargs-form-list info))
-	     (new-keys (initialize-info-new-keys info)))
-	 (multiple-value-bind (initialize-form-list constants)
-	     (make-shared-initialize-form-list class new-keys t t)
-	   (setf (initialize-info-cached-constants info) constants)
-	   (setf (initialize-info-cached-combined-initialize-function info)
-		 (initialize-instance-simple-function 
-		  'combined-initialize-function info 
-		  class (append initargs-form-list initialize-form-list))))))
-      ((make-instance-function-symbol)
-       (setf (initialize-info-cached-make-instance-function-symbol info)
-	     (make-instance-function-symbol key)))
-      ((make-instance-function)
-       (let* ((function (get-make-instance-function key))
-	      (symbol (initialize-info-make-instance-function-symbol info)))
-	 (setf (initialize-info-cached-make-instance-function info) function)
-	 (when symbol (setf (gdefinition symbol)
-			    (or function #'make-instance-1)))))))
-  info)
-
-(defun get-make-instance-function (key)
-  (let* ((class (car key))
-	 (keys (cadr key)))
-    (unless (eq *boot-state* 'complete) 
-      (return-from get-make-instance-function nil))
-    (when (symbolp class)
-      (setq class (find-class class)))
-    (when (classp class)
-      (unless (class-finalized-p class) (finalize-inheritance class)))
-    (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys))
-	   (class-and-initargs (list* class initargs))
-	   (make-instance (gdefinition 'make-instance))
-	   (make-instance-methods
-	    (compute-applicable-methods make-instance class-and-initargs))
-	   (std-mi-meth (find-standard-ii-method make-instance-methods 'class))
-	   (class+initargs (list class initargs))
-	   (default-initargs (gdefinition 'default-initargs))
-	   (default-initargs-methods
-	       (compute-applicable-methods default-initargs class+initargs))
-	   (proto (and (classp class) (class-prototype class)))
-	   (initialize-instance-methods
-	    (when proto
-	      (compute-applicable-methods (gdefinition 'initialize-instance)
-					  (list* proto initargs))))
-	   (shared-initialize-methods
-	    (when proto
-	      (compute-applicable-methods (gdefinition 'shared-initialize)
-					  (list* proto t initargs)))))
-      (when (null make-instance-methods)
-	(return-from get-make-instance-function
-	  #'(lambda (class initargs)
-	      (apply #'no-applicable-method make-instance class initargs))))
-      (unless (and (null (cdr make-instance-methods))
-		   (eq (car make-instance-methods) std-mi-meth)
-		   (null (cdr default-initargs-methods))
-		   (eq (car (method-specializers (car default-initargs-methods)))
-		       *the-class-slot-class*)
-		   (flet ((check-meth (meth)
-			    (let ((quals (method-qualifiers meth)))
-			      (if (null quals)
-				  (eq (car (method-specializers meth))
-				      *the-class-slot-object*)
-				  (and (null (cdr quals))
-				       (or (eq (car quals) ':before)
-					   (eq (car quals) ':after)))))))
-		     (and (every #'check-meth initialize-instance-methods)
-			  (every #'check-meth shared-initialize-methods))))
-	(return-from get-make-instance-function nil))
-      (get-make-instance-function-internal 
-       class key (default-initargs class initargs) 
-       initialize-instance-methods shared-initialize-methods))))
-
-(defun get-make-instance-function-internal (class key initargs 
-						  initialize-instance-methods
-						  shared-initialize-methods)
-  (let* ((keys (cadr key))
-	 (allow-other-keys-p (caddr key))
-	 (allocate-instance-methods
-	  (compute-applicable-methods (gdefinition 'allocate-instance)
-				      (list* class initargs))))
-    (unless allow-other-keys-p
-      (unless (check-initargs-1
-	       class initargs
-	       (append allocate-instance-methods
-		       initialize-instance-methods
-		       shared-initialize-methods)
-	       t nil)
-	(return-from get-make-instance-function-internal nil)))
-    (if (or (cdr allocate-instance-methods)
-	    (some #'complicated-instance-creation-method
-		  initialize-instance-methods)
-	    (some #'complicated-instance-creation-method
-		  shared-initialize-methods))
-	(make-instance-function-complex
-	 key class keys
-	 initialize-instance-methods shared-initialize-methods)
-	(make-instance-function-simple
-	 key class keys
-	 initialize-instance-methods shared-initialize-methods))))
-
-(defun complicated-instance-creation-method (m)
-  (let ((qual (method-qualifiers m)))
-    (if qual 
-	(not (and (null (cdr qual)) (eq (car qual) ':after)))
-	(let ((specl (car (method-specializers m))))
-	  (or (not (classp specl))
-	      (not (eq 'slot-object (class-name specl))))))))
-
-(defun find-standard-ii-method (methods class-names)
-  (dolist (m methods)
-    (when (null (method-qualifiers m))
-      (let ((specl (car (method-specializers m))))
-	(when (and (classp specl)
-		   (if (listp class-names)
-		       (member (class-name specl) class-names)
-		       (eq (class-name specl) class-names)))
-	  (return m))))))
-
-(defmacro call-initialize-function (initialize-function instance initargs)
-  `(let ((.function. ,initialize-function))
-     (if (and (consp .function.)
-	      (eq (car .function.) 'call-initialize-instance-simple))
-	 (initialize-instance-simple (cadr .function.) (caddr .function.)
-				     ,instance ,initargs)
-	 (funcall (the function .function.) ,instance ,initargs))))
-
-(defun make-instance-function-simple (key class keys
-					  initialize-instance-methods 
-					  shared-initialize-methods)
-  (multiple-value-bind (initialize-function constants)
-      (get-simple-initialization-function class keys (caddr key))
-    (let* ((wrapper (class-wrapper class))
-	   (lwrapper (list wrapper))
-	   (allocate-function 
-	    (cond ((structure-class-p class)
-		   #'allocate-structure-instance)
-		  ((standard-class-p class)
-		   #'allocate-standard-instance)
-		  ((funcallable-standard-class-p class)
-		   #'allocate-funcallable-instance)
-		  (t 
-		   (error "error in make-instance-function-simple"))))
-	   (std-si-meth (find-standard-ii-method shared-initialize-methods
-						 'slot-object))
-	   (shared-initfns
-	    (nreverse (mapcar #'(lambda (method)
-				  (make-effective-method-function
-				   #'shared-initialize
-				   `(call-method ,method nil)
-				   nil lwrapper))
-			      (remove std-si-meth shared-initialize-methods))))
-	   (std-ii-meth (find-standard-ii-method initialize-instance-methods
-						 'slot-object))
-	   (initialize-initfns 
-	    (nreverse (mapcar #'(lambda (method)
-				  (make-effective-method-function
-				   #'initialize-instance
-				   `(call-method ,method nil)
-				   nil lwrapper))
-			      (remove std-ii-meth
-				      initialize-instance-methods)))))
-      #'(lambda (class1 initargs)
-	  (if (not (eq wrapper (class-wrapper class)))
-	      (let* ((info (initialize-info class1 initargs))
-		     (fn (initialize-info-make-instance-function info)))
-		(declare (type function fn))
-		(funcall fn class1 initargs))
-	      (let* ((instance (funcall allocate-function wrapper constants))
-		     (initargs (call-initialize-function initialize-function
-							 instance initargs)))
-		(dolist (fn shared-initfns)
-		  (invoke-effective-method-function fn t instance t initargs))
-		(dolist (fn initialize-initfns)
-		  (invoke-effective-method-function fn t instance initargs))
-		instance))))))
-
-(defun make-instance-function-complex (key class keys
-					   initialize-instance-methods
-					   shared-initialize-methods)
-  (multiple-value-bind (initargs-function initialize-function)
-      (get-complex-initialization-functions class keys (caddr key))
-    (let* ((wrapper (class-wrapper class))
-	   (shared-initialize
-	    (get-secondary-dispatch-function
-	     #'shared-initialize shared-initialize-methods
-	     `((class-eq ,class) t t)
-	     `((,(find-standard-ii-method shared-initialize-methods 'slot-object)
-		,#'(lambda (instance init-type &rest initargs)
-		     (declare (ignore init-type))
-		     #+copy-&rest-arg (setq initargs (copy-list initargs))
-		     (call-initialize-function initialize-function 
-					       instance initargs)
-		     instance)))
-	     (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
-	   (initialize-instance
-	    (get-secondary-dispatch-function
-	     #'initialize-instance initialize-instance-methods
-	     `((class-eq ,class) t)
-	     `((,(find-standard-ii-method initialize-instance-methods 'slot-object)
-		,#'(lambda (instance &rest initargs)
-		     #+copy-&rest-arg (setq initargs (copy-list initargs))
-		     (invoke-effective-method-function
-		      shared-initialize t instance t initargs))))
-	     (list wrapper *the-wrapper-of-t*))))
-      #'(lambda (class1 initargs)
-	  (if (not (eq wrapper (class-wrapper class)))
-	      (let* ((info (initialize-info class1 initargs))
-		     (fn (initialize-info-make-instance-function info)))
-		(declare (type function fn))
-		(funcall fn class1 initargs))
-	      (let* ((initargs (call-initialize-function initargs-function 
-							 nil initargs))
-		     (instance (apply #'allocate-instance class initargs)))
-		(invoke-effective-method-function
-		 initialize-instance t instance initargs)
-		instance))))))
-
-(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg)
-  (let ((info (initialize-info class keys nil allow-other-keys-arg)))
-    (values (initialize-info-combined-initialize-function info)
-	    (initialize-info-constants info))))
-
-(defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg
-						   separate-p)
-  (let* ((info (initialize-info class keys nil allow-other-keys-arg))
-	 (default-initargs-function (initialize-info-default-initargs-function info)))
-    (if separate-p
-	(values default-initargs-function
-		(initialize-info-shared-initialize-t-function info))
-	(values default-initargs-function
-		(initialize-info-shared-initialize-t-function
-		 (initialize-info class (initialize-info-new-keys info)
-				  nil allow-other-keys-arg))))))
-
-(defun add-forms (forms forms-list)
-  (when forms
-    (setq forms (copy-list forms))
-    (if (null (car forms-list))
-	(setf (car forms-list) forms)
-	(setf (cddr forms-list) forms))
-    (setf (cdr forms-list) (last forms)))
-  (car forms-list))
-
-(defun make-default-initargs-form-list (class keys &optional (separate-p t))
-  (let ((initargs-form-list (cons nil nil))
-	(default-initargs (class-default-initargs class))
-	(nkeys keys))
-    (dolist (default default-initargs)
-      (let ((key (car default))
-	    (function (cadr default)))
-	(unless (member key nkeys)
-	  (add-forms `((funcall ,function) (push-initarg ,key))
-		     initargs-form-list)
-	  (push key nkeys))))
-    (when separate-p
-      (add-forms `((update-initialize-info-cache
-		    ,class ,(initialize-info class nkeys nil)))
-		 initargs-form-list))
-    (add-forms `((finish-pushing-initargs))
-	       initargs-form-list)
-    (values (car initargs-form-list) nkeys)))
-
-(defun make-shared-initialize-form-list (class keys si-slot-names simple-p)
-  (let* ((initialize-form-list (cons nil nil))
-	 (type (cond ((structure-class-p class)
-		      'structure)
-		     ((standard-class-p class)
-		      'standard)
-		     ((funcallable-standard-class-p class)
-		      'funcallable)
-		     (t (error "error in make-shared-initialize-form-list"))))
-	 (wrapper (class-wrapper class))
-	 (constants (when simple-p
-		      (make-list (wrapper-no-of-instance-slots wrapper)
-				 ':initial-element *slot-unbound*)))
-	 (slots (class-slots class))
-	 (slot-names (mapcar #'slot-definition-name slots))
-	 (slots-key (mapcar #'(lambda (slot)
-				(let ((index most-positive-fixnum))
-				  (dolist (key (slot-definition-initargs slot))
-				    (let ((pos (position key keys)))
-				      (when pos (setq index (min index pos)))))
-				  (cons slot index)))
-			    slots))
-	 (slots (stable-sort slots-key #'< :key #'cdr)))
-    (let ((n-popped 0))
-      (dolist (slot+index slots)
-	(let* ((slot (car slot+index))
-	       (name (slot-definition-name slot))
-	       (npop (1+ (- (cdr slot+index) n-popped))))
-	  (unless (eql (cdr slot+index) most-positive-fixnum)
-	    (let* ((pv-offset (1+ (position name slot-names))))
-	      (add-forms `(,@(when (plusp npop)
-			       `((pop-initargs ,(* 2 npop))))
-			   (instance-set ,pv-offset ,slot))
-			 initialize-form-list))
-	    (incf n-popped npop)))))
-    (dolist (slot+index slots)
-      (let* ((slot (car slot+index))
-	     (name (slot-definition-name slot)))
-	(when (and (eql (cdr slot+index) most-positive-fixnum)
-		   (or (eq si-slot-names 't)
-		       (member name si-slot-names)))
-	  (let* ((initform (slot-definition-initform slot))
-		 (initfunction (slot-definition-initfunction slot))
-		 (location (unless (eq type 'structure)
-			     (slot-definition-location slot)))
-		 (pv-offset (1+ (position name slot-names)))
-		 (forms (cond ((null initfunction)
-			       nil)
-			      ((constantp initform)
-			       (let ((value (funcall initfunction)))
-				 (if (and simple-p (integerp location))
-				     (progn (setf (nth location constants) value)
-					    nil)
-				     `((const ,value)
-				       (instance-set ,pv-offset ,slot)))))
-			      (t
-			       `((funcall ,(slot-definition-initfunction slot))
-				 (instance-set ,pv-offset ,slot))))))
-	    (add-forms `(,@(unless (or simple-p (null forms))
-			     `((skip-when-instance-boundp ,pv-offset ,slot
-				,(length forms))))
-			 ,@forms)
-		       initialize-form-list)))))
-    (values (car initialize-form-list) constants)))
-
-(defvar *class-pv-table-table* (make-hash-table :test 'eq))
-
-(defun get-pv-cell-for-class (class)
-  (let* ((slot-names (mapcar #'slot-definition-name (class-slots class)))
-	 (slot-name-lists (list (cons nil slot-names)))
-	 (pv-table (gethash class *class-pv-table-table*)))
-    (unless (and pv-table
-		 (equal slot-name-lists (pv-table-slot-name-lists pv-table)))
-      (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists))
-      (setf (gethash class *class-pv-table-table*) pv-table))
-    (pv-table-lookup pv-table (class-wrapper class))))    
-
-(defvar *initialize-instance-simple-alist* nil)
-(defvar *note-iis-entry-p* nil)
-
-(defvar *compiled-initialize-instance-simple-functions*
-  (make-hash-table :test #'equal))
-
-(defun initialize-instance-simple-function (use info class form-list)
-  (let* ((pv-cell (get-pv-cell-for-class class))
-	 (key (initialize-info-key info))
-	 (sf-key (list* use (class-name (car key)) (cdr key))))
-    (if (or *compile-make-instance-functions-p*
-	    (gethash sf-key *compiled-initialize-instance-simple-functions*))
-	(multiple-value-bind (form args)
-	    (form-list-to-lisp pv-cell form-list)
-	  (let ((entry (assoc form *initialize-instance-simple-alist*
-			      :test #'equal)))
-	    (setf (gethash sf-key
-			   *compiled-initialize-instance-simple-functions*)
-		  t)
-	    (if entry
-		(setf (cdddr entry) (union (list sf-key) (cdddr entry)
-					   :test #'equal))
-		(progn
-		  (setq entry (list* form nil nil (list sf-key)))
-		  (setq *initialize-instance-simple-alist*
-			(nconc *initialize-instance-simple-alist*
-			       (list entry)))))
-	    (unless (or *note-iis-entry-p* (cadr entry))
-	      (setf (cadr entry) (compile-lambda (car entry))))
-	    (if (cadr entry)
-		(apply (the function (cadr entry)) args)
-		`(call-initialize-instance-simple ,pv-cell ,form-list))))
-	#||
-	#'(lambda (instance initargs)
-	    (initialize-instance-simple pv-cell form-list instance initargs))
-	||#
-	`(call-initialize-instance-simple ,pv-cell ,form-list))))
-
-(defun load-precompiled-iis-entry (form function system uses)
-  (let ((entry (assoc form *initialize-instance-simple-alist*
-		      :test #'equal)))
-    (unless entry
-      (setq entry (list* form nil nil nil))
-      (setq *initialize-instance-simple-alist*
-	    (nconc *initialize-instance-simple-alist*
-		   (list entry))))
-    (setf (cadr entry) function)
-    (setf (caddr entry) system)
-    (dolist (use uses)
-      (setf (gethash use *compiled-initialize-instance-simple-functions*) t))
-    (setf (cdddr entry) (union uses (cdddr entry)
-			       :test #'equal))))
-
-(defmacro precompile-iis-functions (&optional system)
-  (let ((index -1))
-    `(progn
-      ,@(gathering1 (collecting)
-	 (dolist (iis-entry *initialize-instance-simple-alist*)
-	   (when (or (null (caddr iis-entry))
-		     (eq (caddr iis-entry) system))
-	     (when system (setf (caddr iis-entry) system))
-	     (gather1
-	      (make-top-level-form
-	       `(precompile-initialize-instance-simple ,system ,(incf index))
-	       '(load)
-	       `(load-precompiled-iis-entry
-		 ',(car iis-entry)
-		 #',(car iis-entry)
-		 ',system
-		 ',(cdddr iis-entry))))))))))
-
-(defun compile-iis-functions (after-p)
-  (let ((*compile-make-instance-functions-p* t)
-	(*revert-initialize-info-p* t)
-	(*note-iis-entry-p* (not after-p)))
-    (declare (special *compile-make-instance-functions-p*))
-    (when (eq *boot-state* 'complete)
-      (update-make-instance-function-table))))
-
-
-;(const const)
-;(funcall function)
-;(push-initarg const)
-;(pop-supplied count) ; a positive odd number 
-;(instance-set pv-offset slotd)
-;(skip-when-instance-boundp pv-offset slotd n)
-
-(defun initialize-instance-simple (pv-cell form-list instance initargs)
-  (let ((pv (car pv-cell))
-	(initargs-tail initargs)
-	(slots (get-slots-or-nil instance))
-	(class (class-of instance))
-	value)
-    (loop (when (null form-list) (return nil))
-	  (let ((form (pop form-list)))
-	    (ecase (car form)
-	      (push-initarg 
-	       (push value initargs)
-	       (push (cadr form) initargs))
-	      (const
-	       (setq value (cadr form)))
-	      (funcall
-	       (setq value (funcall (the function (cadr form)))))
-	      (pop-initargs
-	       (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail))
-	       (setq value (pop initargs-tail)))
-	      (instance-set
-	       (instance-write-internal 
-		pv slots (cadr form) value
-		(setf (slot-value-using-class class instance (caddr form)) value)))
-	      (skip-when-instance-boundp
-	       (when (instance-boundp-internal 
-		      pv slots (cadr form)
-		      (slot-boundp-using-class class instance (caddr form)))
-		 (dotimes (i (cadddr form))
-		   (pop form-list))))
-	      (update-initialize-info-cache
-	       (when (consp initargs)
-		 (setq initargs (cons (car initargs) (cdr initargs))))
-	       (setq *initialize-info-cache-class* (cadr form))
-	       (setq *initialize-info-cache-initargs* initargs)
-	       (setq *initialize-info-cache-info* (caddr form)))
-	      (finish-pushing-initargs
-	       (setq initargs-tail initargs)))))
-    initargs))
-
-(defun add-to-cvector (cvector constant)
-  (or (position constant cvector)
-      (prog1 (fill-pointer cvector)
-	(vector-push-extend constant cvector))))
-
-(defvar *inline-iis-instance-locations-p* t)
-
-(defun first-form-to-lisp (forms cvector pv)
-  (flet ((const (constant)
-	   (cond ((or (numberp constant) (characterp constant))
-		  constant)
-		 ((and (symbolp constant) (symbol-package constant))
-		  `',constant)
-		 (t
-		  `(svref cvector ,(add-to-cvector cvector constant))))))
-    (let ((form (pop (car forms))))
-      (ecase (car form)
-	(push-initarg
-	 `((push value initargs)
-	   (push ,(const (cadr form)) initargs)))
-	(const
-	 `((setq value ,(const (cadr form)))))
-	(funcall
-	 `((setq value (funcall (the function ,(const (cadr form)))))))
-	(pop-initargs
-	 `((setq initargs-tail (,@(let ((pop (1- (cadr form))))
-				    (case pop
-				      (1 `(cdr))
-				      (3 `(cdddr))
-				      (t `(nthcdr ,pop))))
-				initargs-tail))
-	   (setq value (pop initargs-tail))))
-	(instance-set
-	 (let* ((pv-offset (cadr form))
-		(location (pvref pv pv-offset))
-		(default `(setf (slot-value-using-class class instance
-							,(const (caddr form)))
-				value)))
-	   (if *inline-iis-instance-locations-p*
-	       (typecase location
-		 (fixnum `((setf (%instance-ref slots ,(const location)) value)))
-		 (cons `((setf (cdr ,(const location)) value)))
-		 (t `(,default)))
-	       `((instance-write-internal pv slots ,(const pv-offset) value
-		  ,default
-		  ,(typecase location
-		     (fixnum ':instance)
-		     (cons ':class)
-		     (t ':default)))))))
-	(skip-when-instance-boundp
-	 (let* ((pv-offset (cadr form))
-		(location (pvref pv pv-offset))
-		(default `(slot-boundp-using-class class instance
-			   ,(const (caddr form)))))
-	   `((unless ,(if *inline-iis-instance-locations-p*
-			  (typecase location
-			    (fixnum `(not (eq (%instance-ref slots ,(const location))
-					      ',*slot-unbound*)))
-			    (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*)))
-			    (t default))
-			  `(instance-boundp-internal pv slots ,(const pv-offset)
-			    ,default
-			    ,(typecase (pvref pv pv-offset)
-			       (fixnum ':instance)
-			       (cons ':class)
-			       (t ':default))))
-	       ,@(let ((sforms (cons nil nil)))
-		   (dotimes (i (cadddr form) (car sforms))
-		     (add-forms (first-form-to-lisp forms cvector pv) sforms)))))))
-	(update-initialize-info-cache
-	 `((when (consp initargs)
-	     (setq initargs (cons (car initargs) (cdr initargs))))
-	   (setq *initialize-info-cache-class* ,(const (cadr form)))
-	   (setq *initialize-info-cache-initargs* initargs)
-	   (setq *initialize-info-cache-info* ,(const (caddr form)))))
-	(finish-pushing-initargs
-	 `((setq initargs-tail initargs)))))))
-
-(defmacro iis-body (&body forms)
-  `(let ((initargs-tail initargs)
-	 (slots (get-slots-or-nil instance))
-	 (class (class-of instance))
-	 (pv (car pv-cell))
-	 value)
-     initargs instance initargs-tail pv cvector slots class value
-     ,@forms))
-
-(defun form-list-to-lisp (pv-cell form-list)
-  (let* ((forms (list form-list))
-	 (cvector (make-array (floor (length form-list) 2)
-			      :fill-pointer 0 :adjustable t))
-	 (pv (car pv-cell))
-	 (body (let ((rforms (cons nil nil)))
-		 (loop (when (null (car forms)) (return (car rforms)))
-		       (add-forms (first-form-to-lisp forms cvector pv)
-				  rforms))))
-	 (cvector-type `(simple-vector ,(length cvector))))
-    (values
-     `(lambda (pv-cell cvector)
-        (declare (type ,cvector-type cvector))
-        #'(lambda (instance initargs)
-	    (declare #.*optimize-speed*)
-	    (iis-body ,@body)
-	    initargs))
-     (list pv-cell (coerce cvector cvector-type)))))
diff --git a/pcl/fin.lisp b/pcl/fin.lisp
deleted file mode 100644
index 5328c488046c55ac02ea3f46562f9f7b6bad0414..0000000000000000000000000000000000000000
--- a/pcl/fin.lisp
+++ /dev/null
@@ -1,1962 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-  ;;   
-;;;;;; FUNCALLABLE INSTANCES
-  ;;
-
-#|
-
-Generic functions are instances with meta class funcallable-standard-class.
-Instances with this meta class are called funcallable-instances (FINs for
-short).  They behave something like lexical closures in that they have data
-associated with them (which is used to store the slots) and are funcallable.
-When a funcallable instance is funcalled, the function that is invoked is
-called the funcallable-instance-function.  The funcallable-instance-function
-of a funcallable instance can be changed.
-
-This file implements low level code for manipulating funcallable instances.
-
-It is possible to implement funcallable instances in pure Common Lisp.  A
-simple implementation which uses lexical closures as the instances and a
-hash table to record that the lexical closures are funcallable instances
-is easy to write.  Unfortunately, this implementation adds significant
-overhead:
-
-   to generic-function-invocation (1 function call)
-   to slot-access (1 function call or one hash table lookup)
-   to class-of a generic-function (1 hash-table lookup)
-
-In addition, it would prevent the funcallable instances from being garbage
-collected.  In short, the pure Common Lisp implementation really isn't
-practical.
-
-Instead, PCL uses a specially tailored implementation for each Common Lisp and
-makes no attempt to provide a purely portable implementation.  The specially
-tailored implementations are based on the lexical closure's provided by that
-implementation and are fairly short and easy to write.
-
-Some of the implementation dependent code in this file was originally written
-by someone in the employ of the vendor of that Common Lisp.  That code is
-explicitly marked saying who wrote it.
-
-|#
-
-(in-package :pcl)
-
-;;;
-;;; The first part of the file contains the implementation dependent code to
-;;; implement funcallable instances.  Each implementation must provide the
-;;; following functions and macros:
-;;; 
-;;;    ALLOCATE-FUNCALLABLE-INSTANCE-1 ()
-;;;       should create and return a new funcallable instance.  The
-;;;       funcallable-instance-data slots must be initialized to NIL.
-;;;       This is called by allocate-funcallable-instance and by the
-;;;       bootstrapping code.
-;;;
-;;;    FUNCALLABLE-INSTANCE-P (x)
-;;;       the obvious predicate.  This should be an INLINE function.
-;;;       it must be funcallable, but it would be nice if it compiled
-;;;       open.
-;;;
-;;;    SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value)
-;;;       change the fin so that when it is funcalled, the new-value
-;;;       function is called.  Note that it is legal for new-value
-;;;       to be copied before it is installed in the fin, specifically
-;;;       there is no accessor for a FIN's function so this function
-;;;       does not have to preserve the actual new value.  The new-value
-;;;       argument can be any funcallable thing, a closure, lambda
-;;;       compiled code etc.  This function must coerce those values
-;;;       if necessary.
-;;;       NOTE: new-value is almost always a compiled closure.  This
-;;;             is the important case to optimize.
-;;;
-;;;    FUNCALLABLE-INSTANCE-DATA-1 (fin data-name)
-;;;       should return the value of the data named data-name in the fin.
-;;;       data-name is one of the symbols in the list which is the value
-;;;       of funcallable-instance-data.  Since data-name is almost always
-;;;       a quoted symbol and funcallable-instance-data is a constant, it
-;;;       is possible (and worthwhile) to optimize the computation of
-;;;       data-name's offset in the data part of the fin.
-;;;       This must be SETF'able.
-;;;       
-
-(eval-when (compile load eval)
-(defconstant funcallable-instance-data
-             '(wrapper slots)
-  "These are the 'data-slots' which funcallable instances have so that
-   the meta-class funcallable-standard-class can store class, and static
-   slots in them.")
-)
-
-(defmacro funcallable-instance-data-position (data)
-  (if (and (consp data)
-           (eq (car data) 'quote))
-      (or (position (cadr data) funcallable-instance-data :test #'eq)
-          (progn
-            (warn "Unknown funcallable-instance data: ~S." (cadr data))
-            `(error "Unknown funcallable-instance data: ~S." ',(cadr data))))
-      `(position ,data funcallable-instance-data :test #'eq)))
-
-(proclaim '(notinline called-fin-without-function))
-(defun called-fin-without-function (&rest args)
-  (declare (ignore args))
-  (error "Attempt to funcall a funcallable-instance without first~%~
-          setting its funcallable-instance-function."))
-
-
-;;;
-;;; In Lucid Lisp, compiled functions and compiled closures have the same
-;;; representation.  They are called procedures.  A procedure is a basically
-;;; just a constants vector, with one slot which points to the CODE.  This
-;;; means that constants and closure variables are intermixed in the procedure
-;;; vector.
-;;;
-;;; This code was largely written by JonL@Lucid.com.  Problems with it should
-;;; be referred to him.
-;;; 
-#+Lucid
-(progn
-
-(defconstant procedure-is-funcallable-instance-bit-position 10)
-
-(defconstant fin-trampoline-fun-index lucid::procedure-literals)
-
-(defconstant fin-size (+ fin-trampoline-fun-index
-			 (length funcallable-instance-data)
-			 1))
-
-;;;
-;;; The inner closure of this function will have its code vector replaced
-;;;  by a hand-coded fast jump to the function that is stored in the 
-;;;  captured-lexical variable.  In effect, that code is a hand-
-;;;  optimized version of the code for this inner closure function.
-;;;
-(defun make-trampoline (function)
-  (declare (optimize (speed 3) (safety 0)))
-  #'(lambda (&rest args)
-      (apply function args)))
-
-(eval-when (eval) 
-  (compile 'make-trampoline)
-  )
-
-
-(defun binary-assemble (codes)
-  (let* ((ncodes (length codes))
-	 (code-vec #-LCL3.0 (lucid::new-code ncodes)
-		   #+LCL3.0 (lucid::with-current-area 
-				lucid::*READONLY-NON-POINTER-AREA*
-			      (lucid::new-code ncodes))))
-    (declare (fixnum ncodes))
-    (do ((l codes (cdr l))
-	 (i 0 (1+ i)))
-	((null l) nil)
-      (declare (fixnum i))
-      (setf (lucid::code-ref code-vec i) (car l)))
-    code-vec))
-
-;;;
-;;; Egad! Binary patching!
-;;; See comment following definition of MAKE-TRAMPOLINE -- this is just
-;;;  the "hand-optimized" machine instructions to make it work.
-;;;
-(defvar *mattress-pad-code* 
-	(binary-assemble
-		#+MC68000
-		'(#x2A6D #x11 #x246D #x1 #x4EEA #x5)
-		#+SPARC
-		(ecase (lucid::procedure-length #'lucid::false)
-		  (5
-		   '(#xFA07 #x6012 #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0))
-		  (8
-		   `(#xFA07 #x601E #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0)))
-		#+(and BSP (not LCL3.0 ))
-		'(#xCD33 #x11 #xCDA3 #x1 #xC19A #x5 #xE889)
-		#+(and BSP LCL3.0)
-		'(#x7733 #x7153 #xC155 #x5 #xE885)
-		#+I386
-		'(#x87 #xD2 #x8B #x76 #xE #xFF #x66 #xFE)
-		#+VAX
-		'(#xD0 #xAC #x11 #x5C #xD0 #xAC #x1 #x57 #x17 #xA7 #x5)
-		#+PA
-		'(#x4891 #x3C #xE461 #x6530 #x48BF #x3FF9)
-                #+MIPS
-                '(#x8FD4 #x1E #x2785 #x2EEF #xA0 #x8 #x14 #xF000)
-                #-(or MC68000 SPARC BSP I386 VAX PA MIPS)
-		'(0 0 0 0)))
-
-
-(lucid::defsubst funcallable-instance-p (x)
-  (and (lucid::procedurep x)
-       (lucid::logbitp& procedure-is-funcallable-instance-bit-position
-                        (lucid::procedure-ref x lucid::procedure-flags))))
-
-(lucid::defsubst set-funcallable-instance-p (x)
-  (if (not (lucid::procedurep x))
-      (error "Can't make a non-procedure a fin.")
-      (setf (lucid::procedure-ref x lucid::procedure-flags)
-	    (logior (expt 2 procedure-is-funcallable-instance-bit-position)
-		    (the fixnum
-			 (lucid::procedure-ref x lucid::procedure-flags))))))
-
-
-(defun allocate-funcallable-instance-1 ()
-  #+Prime
-  (declare (notinline lucid::new-procedure))    ;fixes a bug in Prime 1.0 in
-                                                ;which new-procedure expands
-                                                ;incorrectly
-  (let ((new-fin (lucid::new-procedure fin-size))
-	(fin-index fin-size))
-    (declare (fixnum fin-index)
-	     (type lucid::procedure new-fin))
-    (dotimes (i (length funcallable-instance-data)) 
-      ;; Initialize the new funcallable-instance.  As part of our contract,
-      ;; we have to make sure the initial value of all the funcallable
-      ;; instance data slots is NIL.
-      (decf fin-index)
-      (setf (lucid::procedure-ref new-fin fin-index) nil))
-    ;;
-    ;; "Assemble" the initial function by installing a fast "trampoline" code;
-    ;; 
-    (setf (lucid::procedure-ref new-fin lucid::procedure-code)
-	  *mattress-pad-code*)
-    ;; Disable argcount checking in the "mattress-pad" code for
-    ;;  ports that go through standardized trampolines
-    #+PA (setf (sys:procedure-ref new-fin lucid::procedure-arg-count) -1)
-    #+MIPS (progn
-	     (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0)
-	     (setf (sys:procedure-ref new-fin lucid::procedure-max-args) 
-		   call-arguments-limit))
-    ;; but start out with the function to be run as an error call.
-    (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index)
-	  #'called-fin-without-function)
-    ;; Then mark it as a "fin"
-    (set-funcallable-instance-p new-fin)
-    new-fin))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (unless (funcallable-instance-p fin)
-    (error "~S is not a funcallable-instance" fin))
-  (if (lucid::procedurep new-value)
-      (progn
-	(setf (lucid::procedure-ref fin fin-trampoline-fun-index) new-value)
-	fin)
-      (progn 
-	(unless (functionp new-value)
-	  (error "~S is not a function." new-value))
-	;; 'new-value' is an interpreted function.  Install a
-	;; trampoline to call the interpreted function.
-	(set-funcallable-instance-function fin
-					   (make-trampoline new-value)))))
-
-(defmacro funcallable-instance-data-1 (instance data)
-  `(lucid::procedure-ref 
-	   ,instance
-	   (the fixnum
-		(- (- fin-size 1)
-		   (the fixnum (funcallable-instance-data-position ,data))))))
-  
-);end of #+Lucid
-
-
-;;;
-;;; In Symbolics Common Lisp, a lexical closure is a pair of an environment
-;;; and an ordinary compiled function.  The environment is represented as
-;;; a CDR-coded list.  I know of no way to add a special bit to say that the
-;;; closure is a FIN, so for now, closures are marked as FINS by storing a
-;;; special marker in the last cell of the environment.
-;;; 
-;;;  The new structure of a fin is:
-;;;     (lex-env lex-fun *marker* fin-data0 fin-data1)
-;;;  The value returned by allocate is a lexical-closure pointing to the start
-;;;  of the fin list.  Benefits are: no longer ever have to copy environments,
-;;;  fins can be much smaller (5 words instead of 18), old environments never
-;;;  get destroyed (so running dcodes dont have the lex env change from under
-;;;  them any longer).
-;;;
-;;;  Most of the fin operations speed up a little (by as much as 30% on a
-;;;  3650), at least one nasty bug is fixed, and so far at least I've not
-;;;  seen any problems at all with this code.   - mike thome (mthome@bbn.com)
-;;;      
-#+(and Genera (not Genera-Release-8))
-(progn
-
-(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
-
-(defun allocate-funcallable-instance-1 ()
-  (let* ((whole-fin (make-list (+ 3 (length funcallable-instance-data))))
-	 (new-fin (sys:%make-pointer-offset sys:dtp-lexical-closure
-					    whole-fin
-					    0)))
-    ;;
-    ;; note that we DO NOT turn the real lex-closure part of the fin into
-    ;; a dotted pair, because (1) the machine doesn't care and (2) if we
-    ;; did the garbage collector would reclaim everything after the lexical
-    ;; function.
-    ;; 
-    (setf (sys:%p-contents-offset new-fin 2) *funcallable-instance-marker*)
-    (setf (si:lexical-closure-function new-fin)
-	  #'(lambda (ignore &rest ignore-them-too)
-	      (declare (ignore ignore ignore-them-too))
-	      (called-fin-without-function)))
-    #+ignore
-    (setf (si:lexical-closure-environment new-fin) nil)
-    new-fin))
-
-(scl:defsubst funcallable-instance-p (x)
-  (declare (inline si:lexical-closure-p))
-  (and (si:lexical-closure-p x)
-       (= (sys:%p-cdr-code (sys:%make-pointer-offset sys:dtp-compiled-function x 1))
-	  sys:cdr-next)
-       (eq (sys:%p-contents-offset x 2) *funcallable-instance-marker*)))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (cond ((not (funcallable-instance-p fin))
-         (error "~S is not a funcallable-instance" fin))
-        ((not (or (functionp new-value)
-		  (and (consp new-value)
-		       (eq (car new-value) 'si:digested-lambda))))
-         (error "~S is not a function." new-value))
-        ((and (si:lexical-closure-p new-value)
-	      (compiled-function-p (si:lexical-closure-function new-value)))
-	 (let ((env (si:lexical-closure-environment new-value))
-	       (fn  (si:lexical-closure-function new-value)))
-	   ;; we only have to copy the pointers!!
-	   (setf (si:lexical-closure-environment fin) env
-		 (si:lexical-closure-function fin)    fn)
-;	   (dbg:set-env->fin env fin)
-	   ))
-        (t
-         (set-funcallable-instance-function fin
-                                            (make-trampoline new-value)))))
-
-(defun make-trampoline (function)
-  (declare (optimize (speed 3) (safety 0)))
-  #'(lambda (&rest args)
-      #+Genera (declare (dbg:invisible-frame :pcl-internals))
-      (apply function args)))
-
-(defmacro funcallable-instance-data-1 (fin data)
-  `(sys:%p-contents-offset ,fin
-			   (+ 3 (funcallable-instance-data-position ,data))))
-
-(defsetf funcallable-instance-data-1 (fin data) (new-value)
-  `(setf (sys:%p-contents-offset ,fin
-				 (+ 3 (funcallable-instance-data-position ,data)))
-	 ,new-value))
-
-;;;
-;;; Make funcallable instances print out properly.
-;;; 
-(defvar *print-lexical-closure* nil)
-
-(defun pcl-print-lexical-closure (exp stream slashify-p &optional (depth 0))
-  (declare (ignore depth))
-  (declare (special *boot-state*))
-  (if (or (eq *print-lexical-closure* exp)
-	  (neq *boot-state* 'complete)
-	  (eq (class-of exp) *the-class-t*))
-      (let ((*print-lexical-closure* nil))
-	(funcall (original-definition 'si:print-lexical-closure)
-		 exp stream slashify-p))
-      (let ((*print-escape* slashify-p)
-	    (*print-lexical-closure* exp))
-	(print-object exp stream))))
-
-(unless (boundp '*boot-state*)
-  (setq *boot-state* nil))
-
-(redefine-function 'si:print-lexical-closure 'pcl-print-lexical-closure)
-
-(defvar *function-name-level* 0)
-
-(defun pcl-function-name (function &rest other-args)
-  (if (and (eq *boot-state* 'complete)
-	   (funcallable-instance-p function)
-	   (generic-function-p function)
-	   (<= *function-name-level* 2))
-      (let ((*function-name-level* (1+ *function-name-level*)))
-	(generic-function-name function))
-      (apply (original-definition 'si:function-name) function other-args)))
-
-(redefine-function 'si:function-name 'pcl-function-name)
-
-(defun pcl-arglist (function &rest other-args)
-  (let ((defn nil))
-    (cond ((and (funcallable-instance-p function)
-		(generic-function-p function))
-	   (generic-function-pretty-arglist function))
-	  ((and (sys:validate-function-spec function)
-		(sys:fdefinedp function)
-		(setq defn (sys:fdefinition function))
-		(funcallable-instance-p defn)
-		(generic-function-p defn))
-	   (generic-function-pretty-arglist defn))
-	  (t (apply (original-definition 'zl:arglist) function other-args)))))
-
-(redefine-function 'zl:arglist 'pcl-arglist)
-
-
-;;;
-;;; This code is adapted from frame-lexical-environment and frame-function.
-;;;
-#||
-dbg:
-(progn
-
-(defvar *old-frame-function*)
-
-(defvar *inside-new-frame-function* nil)
-
-(defun new-frame-function (frame)
-  (let* ((fn (funcall *old-frame-function* frame))
-	 (location (%pointer-plus frame #+imach (defstorage-size stack-frame) #-imach 0))
-	 (env? #+3600 (location-contents location)
-	       #+imach (%memory-read location :cycle-type %memory-scavenge)))
-    (or (when (cl:consp env?)
-	  (let ((l2 (last2 env?)))
-	    (when (eq (car l2) '.this-is-a-dfun.)
-	      (cadr l2))))
-	fn)))
-
-(defun pcl::doctor-dfun-for-the-debugger (gf dfun)
-  (when (sys:lexical-closure-p dfun)
-    (let* ((env (si:lexical-closure-environment dfun))
-	   (l2 (last2 env)))
-      (unless (eq (car l2) '.this-is-a-dfun.)
-	(setf (si:lexical-closure-environment dfun)
-	      (nconc env (list '.this-is-a-dfun. gf))))))
-  dfun)
-
-(defun last2 (l)
-  (labels ((scan (2ago tail)
-	     (if (null tail)
-		 2ago
-		 (if (cl:consp tail)
-		     (scan (cdr 2ago) (cdr tail))
-		     nil))))
-    (and (cl:consp l)
-	 (cl:consp (cdr l))
-	 (scan l (cddr l)))))
-
-(eval-when (load)
-  (unless (boundp '*old-frame-function*)
-    (setq *old-frame-function* #'frame-function)
-    (setf (cl:symbol-function 'frame-function) 'new-frame-function)))
-
-)
-||#
-
-);end of #+Genera
-
-
-
-;;;
-;;; In Genera 8.0, we use a real funcallable instance (from Genera CLOS) for this.
-;;; This minimizes the subprimitive mucking around.
-;;;
-#+(and Genera Genera-Release-8)
-(progn
-
-(clos-internals::ensure-class
-  'pcl-funcallable-instance
-  :direct-superclasses '(clos-internals:funcallable-instance)
-  :slots `((:name function
-	    :initform #'(lambda (ignore &rest ignore-them-too)
-			  (declare (ignore ignore ignore-them-too))
-			  (called-fin-without-function))
-	    :initfunction ,#'(lambda nil
-			       #'(lambda (ignore &rest ignore-them-too)
-				   (declare (ignore ignore ignore-them-too))
-				   (called-fin-without-function))))
-	   ,@(mapcar #'(lambda (slot) `(:name ,slot)) funcallable-instance-data))
-  :metaclass 'clos:funcallable-standard-class)
-
-(defun pcl-funcallable-instance-trampoline (extra-arg &rest args)
-  (apply (sys:%instance-ref (clos-internals::%dispatch-instance-from-extra-argument extra-arg)
-			    3)
-	 args))
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((fin (clos:make-instance 'pcl-funcallable-instance)))
-    (setf (clos-internals::%funcallable-instance-function fin)
-	  #'pcl-funcallable-instance-trampoline)
-    (setf (clos-internals::%funcallable-instance-extra-argument fin)
-	  (sys:%make-pointer sys:dtp-instance
-			     (clos-internals::%funcallable-instance-extra-argument fin)))
-    (setf (clos:slot-value fin 'clos-internals::funcallable-instance) fin)
-    fin))
-
-(scl:defsubst funcallable-instance-p (x)
-  (and (sys:funcallable-instance-p x)
-       (eq (clos-internals::%funcallable-instance-function x)
-	   #'pcl-funcallable-instance-trampoline)))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (setf (clos:slot-value fin 'function) new-value))
-
-(defmacro funcallable-instance-data-1 (fin data)
-  `(clos-internals:%funcallable-instance-ref
-     ,fin (+ 4 (funcallable-instance-data-position ,data))))
-
-(defsetf funcallable-instance-data-1 (fin data) (new-value)
-  `(setf (clos-internals:%funcallable-instance-ref
-	   ,fin (+ 4 (funcallable-instance-data-position ,data)))
-	 ,new-value))
-
-(clos:defmethod clos:print-object ((fin pcl-funcallable-instance) stream)
-  (print-object fin stream))
-
-(clos:defmethod clos-internals:debugging-information-function ((fin pcl-funcallable-instance))
-  nil)
-
-(clos:defmethod clos-internals:function-name-object ((fin pcl-funcallable-instance))
-  (declare (special *boot-state*))
-  (if (and (eq *boot-state* 'complete)
-	   (generic-function-p fin))
-      (generic-function-name fin)
-      fin))
-
-(clos:defmethod clos-internals:arglist-object ((fin pcl-funcallable-instance))
-  (declare (special *boot-state*))
-  (if (and (eq *boot-state* 'complete)
-	   (generic-function-p fin))
-      (generic-function-pretty-arglist fin)
-      '(&rest args)))
-
-);end of #+Genera
-
-
-
-#+Cloe-Runtime
-(progn
-
-(defconstant funcallable-instance-closure-slots 5)
-(defconstant funcallable-instance-closure-size
-	     (+ funcallable-instance-closure-slots (length funcallable-instance-data) 1))
-
-#-CLOE-Release-2 (progn
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((data (system::make-funcallable-structure 'funcallable-instance
-						  funcallable-instance-closure-size)))
-    (setf (system::%trampoline-ref data funcallable-instance-closure-slots)
-	  'funcallable-instance)
-    (set-funcallable-instance-function
-      data
-      #'(lambda (&rest ignore-them-too)
-	  (declare (ignore ignore-them-too))
-	  (called-fin-without-function)))
-    data))
-
-(proclaim '(inline funcallable-instance-p))
-(defun funcallable-instance-p (x)
-  (and (typep x 'system::trampoline)
-       (= (system::%trampoline-data-length x) funcallable-instance-closure-size)
-       (eq (system::%trampoline-ref x funcallable-instance-closure-slots)
-	   'funcallable-instance)))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (when (not (funcallable-instance-p fin))
-    (error "~S is not a funcallable-instance" fin))
-  (etypecase new-value
-    (system::trampoline
-      (let ((length (system::%trampoline-data-length new-value)))
-	(cond ((> length funcallable-instance-closure-slots)
-	       (set-funcallable-instance-function
-		 fin
-		 #'(lambda (&rest args)
-		     (declare (sys:downward-rest-argument))
-		     (apply new-value args))))
-	      (t
-	       (setf (system::%trampoline-function fin)
-		     (system::%trampoline-function new-value))
-	       (dotimes (i length)
-		 (setf (system::%trampoline-ref fin i)
-		       (system::%trampoline-ref new-value i)))))))
-    (compiled-function
-      (setf (system::%trampoline-function fin) new-value))
-    (function
-      (set-funcallable-instance-function
-	fin
-	#'(lambda (&rest args)
-	    (declare (sys:downward-rest-argument))
-	    (apply new-value args))))))
-
-(defmacro funcallable-instance-data-1 (fin data)
-  `(system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots
-				    1 (funcallable-instance-data-position ,data))))
-
-(defsetf funcallable-instance-data-1 (fin data) (new-value)
-  `(setf (system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots
-					  1 (funcallable-instance-data-position ,data)))
-	 ,new-value))
-
-)
-
-#+CLOE-Release-2 (progn
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((data (si::cons-closure funcallable-instance-closure-size)))
-    (setf (si::closure-ref data funcallable-instance-closure-slots) 'funcallable-instance)
-    (set-funcallable-instance-function
-      data
-      #'(lambda (&rest ignore-them-too)
-	  (declare (ignore ignore-them-too))
-	  (error "Called a FIN without first setting its function.")))
-    data))
-
-(proclaim '(inline funcallable-instance-p))
-(defun funcallable-instance-p (x)
-  (and (si::closurep x)
-       (= (si::closure-length x) funcallable-instance-closure-size)
-       (eq (si::closure-ref x funcallable-instance-closure-slots) 'funcallable-instance)))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (when (not (funcallable-instance-p fin))
-    (error "~S is not a funcallable-instance" fin))
-  (etypecase new-value
-    (si::closure
-      (let ((length (si::closure-length new-value)))
-	(cond ((> length funcallable-instance-closure-slots)
-	       (set-funcallable-instance-function
-		 fin
-		 #'(lambda (&rest args)
-		     (declare (sys:downward-rest-argument))
-		     (apply new-value args))))
-	      (t
-	       (setf (si::closure-function fin) (si::closure-function new-value))
-	       (dotimes (i length)
-		 (si::object-set fin (+ i 3) (si::object-ref new-value (+ i 3))))))))
-    (compiled-function
-      (setf (si::closure-function fin) new-value))
-    (function
-      (set-funcallable-instance-function
-	fin
-	#'(lambda (&rest args)
-	    (declare (sys:downward-rest-argument))
-	    (apply new-value args))))))
-
-(defmacro funcallable-instance-data-1 (fin data)
-  `(si::closure-ref ,fin (+ funcallable-instance-closure-slots
-			    1 (funcallable-instance-data-position ,data))))
-
-(defsetf funcallable-instance-data-1 (fin data) (new-value)
-  `(setf (si::closure-ref ,fin (+ funcallable-instance-closure-slots
-				  1 (funcallable-instance-data-position ,data)))
-	 ,new-value))
-
-)
-
-)
-
-
-;;;
-;;;
-;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and
-;;; CCODEP.  The environment is represented as a block.  There is space in
-;;; the top 8 bits of the pointers to the CCODE and the environment to use
-;;; to mark the closure as being a FIN.
-;;;
-;;; To help the debugger figure out when it has found a FIN on the stack, we
-;;; reserve the last element of the closure environment to use to point back
-;;; to the actual fin.
-;;;
-;;; Note that there is code in xerox-low which lets us access the fields of
-;;; compiled-closures and which defines the closure-overlay record.  That
-;;; code is there because there are some clients of it in that file.
-;;;      
-#+Xerox
-(progn
-
-;; Don't be fooled.  We actually allocate one bigger than this to have a place
-;; to store the backpointer to the fin.  -smL
-(defconstant funcallable-instance-closure-size 15)
-
-;; This is only used in the file PCL-ENV.
-(defvar *fin-env-type*
-  (type-of (il:\\allocblock (1+ funcallable-instance-closure-size) t)))
-
-;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL
-
-(defstruct fin-env-pointer
-  (pointer nil :type il:fullxpointer))
-
-(defun fin-env-fin (fin-env)
-  (fin-env-pointer-pointer
-   (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))
-
-(defun |set fin-env-fin| (fin-env new-value)
-  (il:\\rplptr fin-env (* funcallable-instance-closure-size 2)
-	       (make-fin-env-pointer :pointer new-value))
-  new-value)
-
-(defsetf fin-env-fin |set fin-env-fin|)
-
-;; The finalization function that will clean up the backpointer from the
-;; fin-env to the fin.  This needs to be careful to not cons at all.  This
-;; depends on there being no other finalization function on compiled-closures,
-;; since there is only one finalization function per datatype.  Too bad.  -smL
-(defun finalize-fin (fin)
-  ;; This could use the fn funcallable-instance-p, but if we get here we know
-  ;; that this is a closure, so we can skip that test.
-  (when (il:fetch (closure-overlay funcallable-instance-p) il:of fin)
-    (let ((env (il:fetch (il:compiled-closure il:environment) il:of fin)))
-      (when env
-	(setq env
-	      (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))
-	(when (il:typep env 'fin-env-pointer) 
-	  (setf (fin-env-pointer-pointer env) nil)))))
-  nil)					;Return NIL so GC can proceed
-
-(eval-when (load)
-  ;; Install the above finalization function.
-  (when (fboundp 'finalize-fin)
-    (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))
-
-(defun allocate-funcallable-instance-1 ()
-  (let* ((env (il:\\allocblock (1+ funcallable-instance-closure-size) t))
-         (fin (il:make-compiled-closure nil env)))
-    (setf (fin-env-fin env) fin)
-    (il:replace (closure-overlay funcallable-instance-p) il:of fin il:with 't)
-    (set-funcallable-instance-function fin
-      #'(lambda (&rest ignore)
-          (declare (ignore ignore))
-	  (called-fin-without-function)))
-    fin))
-
-(xcl:definline funcallable-instance-p (x)
-  (and (typep x 'il:compiled-closure)
-       (il:fetch (closure-overlay funcallable-instance-p) il:of x)))
-
-(defun set-funcallable-instance-function (fin new)
-  (cond ((not (funcallable-instance-p fin))
-         (error "~S is not a funcallable-instance" fin))
-        ((not (functionp new))
-         (error "~S is not a function." new))
-        ((typep new 'il:compiled-closure)
-         (let* ((fin-env
-                  (il:fetch (il:compiled-closure il:environment) il:of fin))
-                (new-env
-                  (il:fetch (il:compiled-closure il:environment) il:of new))
-                (new-env-size (if new-env (il:\\#blockdatacells new-env) 0))
-                (fin-env-size (- funcallable-instance-closure-size
-                                 (length funcallable-instance-data))))
-           (cond ((and new-env
-		       (<= new-env-size fin-env-size))
-		  (dotimes (i fin-env-size)
-		    (il:\\rplptr fin-env
-				 (* i 2)
-				 (if (< i new-env-size)
-				     (il:\\getbaseptr new-env (* i 2))
-				     nil)))
-		  (setf (compiled-closure-fnheader fin)
-			(compiled-closure-fnheader new)))
-                 (t
-                  (set-funcallable-instance-function
-                    fin
-                    (make-trampoline new))))))
-        (t
-         (set-funcallable-instance-function fin
-                                            (make-trampoline new)))))
-
-(defun make-trampoline (function)
-  #'(lambda (&rest args)
-      (apply function args)))
-
-        
-(defmacro funcallable-instance-data-1 (fin data)
-  `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)
-		    (* (- funcallable-instance-closure-size
-			  (funcallable-instance-data-position ,data)
-			  1)			;Reserve last element to
-						;point back to actual FIN!
-		       2)))
-
-(defsetf funcallable-instance-data-1 (fin data) (new-value)
-  `(il:\\rplptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)
-		(* (- funcallable-instance-closure-size
-		      (funcallable-instance-data-position ,data)
-		      1)
-		   2)
-		,new-value))
-
-);end of #+Xerox
-
-
-;;;
-;;; In Franz Common Lisp ExCL
-;;; This code was originally written by:
-;;;   jkf%franz.uucp@berkeley.edu
-;;; and hacked by:
-;;;   smh%franz.uucp@berkeley.edu
-
-#+ExCL
-(progn
-
-(defconstant funcallable-instance-flag-bit #x1)
-
-(defun funcallable-instance-p (x)
-   (and (excl::function-object-p x)
-        (eq funcallable-instance-flag-bit
-            (logand (excl::fn_flags x)
-                    funcallable-instance-flag-bit))))
-
-(defun make-trampoline (function)
-  #'(lambda (&rest args)
-      (apply function args)))
-
-;; We initialize a fin's procedure function to this because
-;; someone might try to funcall it before it has been set up.
-(defun init-fin-fun (&rest ignore)
-  (declare (ignore ignore))
-  (called-fin-without-function))
-
-
-(eval-when (eval) 
-  (compile 'make-trampoline)
-  (compile 'init-fin-fun))
-
-
-;; new style
-#+(and gsgc (not sun4) (not cray) (not mips))
-(progn
-;; set-funcallable-instance-function must work by overwriting the fin itself
-;; because the fin must maintain EQ identity.
-;; Because the gsgc time needs several of the fields in the function object
-;; at gc time in order to walk the stack frame, it is important never to bash
-;; a function object that is active in a frame on the stack.  Besides, changing
-;; the functions closure vector, not to mention overwriting its constant
-;; vector, would scramble it's execution when that stack frame continues.
-;; Therefore we represent a fin as a funny compiled-function object.
-;; The code vector of this object has some hand-coded instructions which
-;; do a very fast jump into the real fin handler function.  The function
-;; which is the fin object *never* creates a frame on the stack.
-  
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((fin (compiler::.primcall 'sys::new-function))
-	(init #'init-fin-fun)
-	(mattress-fun #'funcallable-instance-mattress-pad))
-    (setf (excl::fn_symdef fin) 'anonymous-fin)
-    (setf (excl::fn_constant fin) init)
-    (setf (excl::fn_code fin)		; this must be before fn_start
-	  (excl::fn_code mattress-fun))
-    (setf (excl::fn_start fin) (excl::fn_start mattress-fun))
-    (setf (excl::fn_flags fin) (logior (excl::fn_flags init)
-				       funcallable-instance-flag-bit))
-    (setf (excl::fn_closure fin)
-      (make-array (length funcallable-instance-data)))
-
-    fin))
-
-;; This function gets its code vector modified with a hand-coded fast jump
-;; to the function that is stored in place of its constant vector.
-;; This function is never linked in and never appears on the stack.
-
-(defun funcallable-instance-mattress-pad ()
-  (declare (optimize (speed 3) (safety 0)))
-  'nil)
-
-(eval-when (eval)
-  (compile 'funcallable-instance-mattress-pad))
-
-
-#+(and excl (target-class s))
-(eval-when (load eval)
-  (let ((codevec (excl::fn_code
-		  (symbol-function 'funcallable-instance-mattress-pad))))
-    ;; The entire code vector wants to be:
-    ;;   move.l  7(a2),a2     ;#x246a0007
-    ;;   jmp     1(a2)        ;#x4eea0001
-    (setf (aref codevec 0) #x246a
-	  (aref codevec 1) #x0007
-	  (aref codevec 2) #x4eea
-	  (aref codevec 3) #x0001))
-)
-
-#+(and excl (target-class a))
-(eval-when (load eval)
-  (let ((codevec (excl::fn_code
-		  (symbol-function 'funcallable-instance-mattress-pad))))
-    ;; The entire code vector wants to be:
-    ;;   l       r5,15(r5)    ;#x5850500f
-    ;;   l       r15,11(r5)   ;#x58f0500b
-    ;;   br      r15          ;#x07ff
-    (setf (aref codevec 0) #x5850
-	  (aref codevec 1) #x500f
-	  (aref codevec 2) #x58f0
-	  (aref codevec 3) #x500b
-	  (aref codevec 4) #x07ff
-	  (aref codevec 5) #x0000))
-  )
-
-#+(and excl (target-class i))
-(eval-when (load eval)
-  (let ((codevec (excl::fn_code
-		  (symbol-function 'funcallable-instance-mattress-pad))))
-    ;; The entire code vector wants to be:
-    ;;   movl  7(edx),edx     ;#x07528b
-    ;;   jmp   *3(edx)        ;#x0362ff
-    (setf (aref codevec 0) #x8b
-	  (aref codevec 1) #x52
-	  (aref codevec 2) #x07
-	  (aref codevec 3) #xff
-	  (aref codevec 4) #x62
-	  (aref codevec 5) #x03))
-)
-
-(defun funcallable-instance-data-1 (instance data)
-  (let ((constant (excl::fn_closure instance)))
-    (svref constant (funcallable-instance-data-position data))))
-
-(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
-
-(defun set-funcallable-instance-data-1 (instance data new-value)
-  (let ((constant (excl::fn_closure instance)))
-    (setf (svref constant (funcallable-instance-data-position data))
-          new-value)))
-
-(defun set-funcallable-instance-function (fin new-function)
-  (unless (funcallable-instance-p fin)
-    (error "~S is not a funcallable-instance" fin))
-  (unless (functionp new-function)
-    (error "~S is not a function." new-function))
-  (setf (excl::fn_constant fin)
-	(if (excl::function-object-p new-function)
-	    new-function
-	    ;; The new-function is an interpreted function.
-	    ;; Install a trampoline to call the interpreted function.
-	    (make-trampoline new-function))))
-
-
-)  ;; end sun3
-
-
-#+(and gsgc (or sun4 mips))
-(progn
-
-(eval-when (compile load eval)
-  (defconstant funcallable-instance-constant-count 15)
-  )
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((new-fin (compiler::.primcall 
-		   'sys::new-function
-		   funcallable-instance-constant-count)))
-    ;; Have to set the procedure function to something for two reasons.
-    ;;   1. someone might try to funcall it.
-    ;;   2. the flag bit that says the procedure is a funcallable
-    ;;      instance is set by set-funcallable-instance-function.
-    (set-funcallable-instance-function new-fin #'init-fin-fun)
-    new-fin))
-
-(defun set-funcallable-instance-function (fin new-value)
-  ;; we actually only check for a function object since
-  ;; this is called before the funcallable instance flag is set
-  (unless (excl::function-object-p fin)
-    (error "~S is not a funcallable-instance" fin))
-
-  (cond ((not (functionp new-value))
-         (error "~S is not a function." new-value))
-        ((not (excl::function-object-p new-value))
-         ;; new-value is an interpreted function.  Install a
-         ;; trampoline to call the interpreted function.
-         (set-funcallable-instance-function fin (make-trampoline new-value)))
-	((> (+ (excl::function-constant-count new-value)
-	       (length funcallable-instance-data))
-	    funcallable-instance-constant-count)
-	 ; can't fit, must trampoline
-	 (set-funcallable-instance-function fin (make-trampoline new-value)))
-        (t
-         ;; tack the instance variables at the end of the constant vector
-	 
-         (setf (excl::fn_code fin)	; this must be before fn_start
-	       (excl::fn_code new-value))
-         (setf (excl::fn_start fin) (excl::fn_start new-value))
-         
-         (setf (excl::fn_closure fin) (excl::fn_closure new-value))
-	 ; only replace the symdef slot if the new value is an 
-	 ; interned symbol or some other object (like a function spec)
-	 (let ((newsym (excl::fn_symdef new-value)))
-	   (excl:if* (and newsym (or (not (symbolp newsym))
-				(symbol-package newsym)))
-	      then (setf (excl::fn_symdef fin) newsym)))
-         (setf (excl::fn_formals fin) (excl::fn_formals new-value))
-         (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))
-	 (setf (excl::fn_locals fin) (excl::fn_locals new-value))
-         (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)
-                                            funcallable-instance-flag-bit))
-	 
-	 ;; on a sun4 we copy over the constants
-	 (dotimes (i (excl::function-constant-count new-value))
-	   (setf (excl::function-constant fin i) 
-		 (excl::function-constant new-value i)))
-	 ;(format t "all done copy from ~s to ~s" new-value fin)
-	 )))
-
-(defmacro funcallable-instance-data-1 (instance data)
-  `(excl::function-constant ,instance 
-			   (- funcallable-instance-constant-count
-			      (funcallable-instance-data-position ,data)
-			      1)))
-
-) ;; end sun4 or mips
-
-#+(and gsgc cray)
-(progn
-
-;; The cray is like the sun4 in that the constant vector is included in the  
-;; function object itself.  But a mattress pad must be used anyway, because
-;; the function start address is copied in the symbol object, and cannot be
-;; updated when the fin is changed.  
-;; We place the funcallable-instance-function into the first constant slot,  
-;; and leave enough constant slots after that for the instance data.
-
-(eval-when (compile load eval)
-  (defconstant fin-fun-slot 0)
-  (defconstant fin-instance-data-slot 1)
-  )
-
-
-;; We initialize a fin's procedure function to this because
-;; someone might try to funcall it before it has been set up.
-(defun init-fin-fun (&rest ignore)
-  (declare (ignore ignore))
-  (called-fin-without-function))
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((fin (compiler::.primcall 'sys::new-function
-			(1+ (length funcallable-instance-data))
-			"funcallable-instance"))
-	(init #'init-fin-fun)
-	(mattress-fun #'funcallable-instance-mattress-pad))
-    (setf (excl::fn_symdef fin) 'anonymous-fin)
-    (setf (excl::function-constant fin fin-fun-slot) init)
-    (setf (excl::fn_code fin)		; this must be before fn_start
-      (excl::fn_code mattress-fun))
-    (setf (excl::fn_start fin) (excl::fn_start mattress-fun))
-    (setf (excl::fn_flags fin) (logior (excl::fn_flags init)
-				       funcallable-instance-flag-bit))
-    
-    fin))
-
-;; This function gets its code vector modified with a hand-coded fast jump
-;; to the function that is stored in place of its constant vector.
-;; This function is never linked in and never appears on the stack.
-
-(defun funcallable-instance-mattress-pad ()
-  (declare (optimize (speed 3) (safety 0)))
-  'nil)
-
-(eval-when (eval)
-  (compile 'funcallable-instance-mattress-pad)
-  (compile 'init-fin-fun))
-
-(eval-when (load eval)
-  (let ((codevec (excl::fn_code
-		  (symbol-function 'funcallable-instance-mattress-pad))))
-    ;; The entire code vector wants to be:
-    ;;   a1  b77
-    ;;   a2  12,a1
-    ;;   a1 1,a2
-    ;;   b77 a2
-    ;;   b76 a1
-    ;;   j   b76
-    (setf (aref codevec 0) #o024177
-	  (aref codevec 1) #o101200 (aref codevec 2) 12
-	  (aref codevec 3) #o102100 (aref codevec 4) 1
-	  (aref codevec 5) #o025277
-	  (aref codevec 6) #o025176
-	  (aref codevec 7) #o005076
-	  ))
-)
-
-(defmacro funcallable-instance-data-1 (instance data)
-  `(excl::function-constant ,instance 
-			    (+ (funcallable-instance-data-position ,data)
-			       fin-instance-dtat-slot)))
-
-
-(defun set-funcallable-instance-function (fin new-function)
-  (unless (funcallable-instance-p fin)
-    (error "~S is not a funcallable-instance" fin))
-  (unless (functionp new-function)
-    (error "~S is not a function." new-function))
-  (setf (excl::function-constant fin fin-fun-slot)
-    (if (excl::function-object-p new-function)
-	new-function
-	;; The new-function is an interpreted function.
-	;; Install a trampoline to call the interpreted function.
-	(make-trampoline new-function))))
-
-) ;; end cray
-
-#-gsgc
-(progn
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((new-fin (compiler::.primcall 'sys::new-function)))
-    ;; Have to set the procedure function to something for two reasons.
-    ;;   1. someone might try to funcall it.
-    ;;   2. the flag bit that says the procedure is a funcallable
-    ;;      instance is set by set-funcallable-instance-function.
-    (set-funcallable-instance-function new-fin #'init-fin-fn)
-    new-fin))
-
-(defun set-funcallable-instance-function (fin new-value)
-  ;; we actually only check for a function object since
-  ;; this is called before the funcallable instance flag is set
-  (unless (excl::function-object-p fin)
-    (error "~S is not a funcallable-instance" fin))
-  (cond ((not (functionp new-value))
-         (error "~S is not a function." new-value))
-        ((not (excl::function-object-p new-value))
-         ;; new-value is an interpreted function.  Install a
-         ;; trampoline to call the interpreted function.
-         (set-funcallable-instance-function fin (make-trampoline new-value)))
-        (t
-         ;; tack the instance variables at the end of the constant vector
-         (setf (excl::fn_start fin) (excl::fn_start new-value))
-         (setf (excl::fn_constant fin) (add-instance-vars
-                                        (excl::fn_constant new-value)
-                                        (excl::fn_constant fin)))
-         (setf (excl::fn_closure fin) (excl::fn_closure new-value))
-	 ;; In versions prior to 2.0. comment the next line and any other
-	 ;; references to fn_symdef or fn_locals.
-	 (setf (excl::fn_symdef fin) (excl::fn_symdef new-value))
-         (setf (excl::fn_code fin) (excl::fn_code new-value))
-         (setf (excl::fn_formals fin) (excl::fn_formals new-value))
-         (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))
-	 (setf (excl::fn_locals fin) (excl::fn_locals new-value))
-         (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)
-                                            funcallable-instance-flag-bit)))))
-
-(defun add-instance-vars (cvec old-cvec)
-  ;; create a constant vector containing everything in the given constant
-  ;; vector plus space for the instance variables
-  (let* ((nconstants (cond (cvec (length cvec)) (t 0)))
-         (ndata (length funcallable-instance-data))
-         (old-cvec-length (if old-cvec (length old-cvec) 0))
-         (new-cvec nil))
-    (cond ((<= (+ nconstants ndata)  old-cvec-length)
-           (setq new-cvec old-cvec))
-          (t
-           (setq new-cvec (make-array (+ nconstants ndata)))
-           (when old-cvec
-             (dotimes (i ndata)
-               (setf (svref new-cvec (- (+ nconstants ndata) i 1))
-                     (svref old-cvec (- old-cvec-length i 1)))))))
-    
-    (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i)))
-    
-    new-cvec))
-
-(defun funcallable-instance-data-1 (instance data)
-  (let ((constant (excl::fn_constant instance)))
-    (svref constant (- (length constant)
-                       (1+ (funcallable-instance-data-position data))))))
-
-(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
-
-(defun set-funcallable-instance-data-1 (instance data new-value)
-  (let ((constant (excl::fn_constant instance)))
-    (setf (svref constant (- (length constant) 
-                             (1+ (funcallable-instance-data-position data))))
-          new-value)))
-
-);end #-gsgc
-
-);end of #+ExCL
-
-
-;;;
-;;; In Vaxlisp
-;;; This code was originally written by:
-;;;    vanroggen%bach.DEC@DECWRL.DEC.COM
-;;; 
-#+(and dec vax common)
-(progn
-
-;;; The following works only in Version 2 of VAXLISP, and will have to
-;;; be replaced for later versions.
-
-(defun allocate-funcallable-instance-1 ()
-  (list 'system::%compiled-closure%
-        ()
-        #'(lambda (&rest args)
-            (declare (ignore args))
-	    (called-fin-without-function))
-        (make-array (length funcallable-instance-data))))
-
-(proclaim '(inline funcallable-instance-p))
-(defun funcallable-instance-p (x)
-  (and (consp x)
-       (eq (car x) 'system::%compiled-closure%)
-       (not (null (cdddr x)))))
-
-(defun set-funcallable-instance-function (fin func)
-  (cond ((not (funcallable-instance-p fin))
-         (error "~S is not a funcallable-instance" fin))
-        ((not (functionp func))
-         (error "~S is not a function" func))
-        ((and (consp func) (eq (car func) 'system::%compiled-closure%))
-         (setf (cadr fin) (cadr func)
-               (caddr fin) (caddr func)))
-        (t (set-funcallable-instance-function fin
-                                              (make-trampoline func)))))
-
-(defun make-trampoline (function)
-  #'(lambda (&rest args)
-      (apply function args)))
-
-(eval-when (eval) (compile 'make-trampoline))
-
-(defmacro funcallable-instance-data-1 (instance data)
-  `(svref (cadddr ,instance)
-          (funcallable-instance-data-position ,data)))
-
-);end of Vaxlisp (and dec vax common)
-
-
-;;;; Implementation of funcallable instances for CMU Common Lisp:
-;;;
-;;;    We represent a FIN like a closure, but the header has a distinct type
-;;; tag.  The FIN data slots are stored at the end of a fixed-length closure
-;;; (at FIN-DATA-OFFSET.)  When the function is set to a closure that has no
-;;; more than FIN-DATA-OFFSET slots, we can just replace the slots in the FIN
-;;; with the closure slots.  If the closure has too many slots, we must
-;;; indirect through a trampoline with a rest arg.  For non-closures, we just
-;;; set the function slot.
-;;;
-;;;    We can get away with this efficient and relatively simple scheme because
-;;; the compiler currently currently only references closure slots during the
-;;; initial call and on entry into the function.  So we don't have to worry
-;;; about bad things happening when the FIN is clobbered (the problem JonL
-;;; flames about somewhere...)
-;;;
-;;;    We also stick in a slot for the function name at the end, but before the
-;;; data slots.
-
-#+CMU
-(import 'kernel:funcallable-instance-p)
-
-#+CMU
-(progn
-
-(eval-when (compile load eval)
-  ;;; The offset of the function's name & the max number of real closure slots.
-  ;;;
-  (defconstant fin-name-slot 14)
-  
-  ;;; The offset of the data slots.
-  ;;;
-  (defconstant fin-data-offset 15))
-
-
-;;; ALLOCATE-FUNCALLABLE-INSTANCE-1  --  Interface
-;;;
-;;;    Allocate a funcallable instance, setting the function to an error
-;;; function and initializing the data slots to NIL.
-;;;
-(defun allocate-funcallable-instance-1 ()
-  (let* ((len (+ (length funcallable-instance-data) fin-data-offset))
-         (res (kernel:%make-funcallable-instance
-               len
-               #'called-fin-without-function)))
-    (dotimes (i (length funcallable-instance-data))
-      (kernel:%set-funcallable-instance-info res (+ i fin-data-offset) nil))
-    (kernel:%set-funcallable-instance-info res fin-name-slot nil)
-    res))
-
-
-;;; FUNCALLABLE-INSTANCE-P  --  Interface
-;;;
-;;;    Return true if X is a funcallable instance.  This is an interpreter
-;;; stub; the compiler directly implements this function.
-;;;
-(defun funcallable-instance-p (x) (funcallable-instance-p x))
-
-
-;;; SET-FUNCALLABLE-INSTANCE-FUNCTION  --  Interface
-;;;
-;;;    Set the function that is called when FIN is called.
-;;;
-(defun set-funcallable-instance-function (fin new-value)
-  (declare (type function new-value))
-  (assert (funcallable-instance-p fin))
-  (ecase (kernel:get-type new-value)
-    (#.vm:closure-header-type
-     (let ((len (- (kernel:get-closure-length new-value)
-                   (1- vm:closure-info-offset))))
-       (cond ((> len fin-name-slot)
-              (set-funcallable-instance-function
-               fin
-               #'(lambda (&rest args)
-                   (apply new-value args))))
-             (t
-              (dotimes (i fin-data-offset)
-                (kernel:%set-funcallable-instance-info
-                 fin i
-                 (if (>= i len)
-                     nil
-                     (kernel:%closure-index-ref new-value i))))
-              (kernel:%set-funcallable-instance-function
-               fin
-               (kernel:%closure-function new-value))))))
-    (#.vm:function-header-type
-     (kernel:%set-funcallable-instance-function fin new-value)))
-  new-value)
-
-
-;;; FUNCALLABLE-INSTANCE-NAME, SET-FUNCALLABLE-INSTANCE-NAME  --  Interface
-;;;
-;;;    Read or set the name slot in a funcallable instance.
-;;;
-(defun funcallable-instance-name (fin)
-  (kernel:%closure-index-ref fin fin-name-slot))
-;;;
-(defun set-funcallable-instance-name (fin new-value)
-  (kernel:%set-funcallable-instance-info fin fin-name-slot new-value)
-  new-value)
-;;;
-(defsetf funcallable-instance-name set-funcallable-instance-name)
-
-
-;;; FUNCALLABLE-INSTANCE-DATA-1  --  Interface
-;;;
-;;;    If the slot is constant, use CLOSURE-REF with the appropriate offset,
-;;; otherwise do a run-time lookup of the slot offset.
-;;;
-(defmacro funcallable-instance-data-1 (fin slot)
-  (if (constantp slot)
-      `(sys:%primitive c:closure-ref ,fin
-                       ,(+ (or (position (eval slot) funcallable-instance-data)
-                               (error "Unknown slot: ~S." (eval slot)))
-                           fin-data-offset))
-      (ext:once-only ((n-slot slot))
-        `(kernel:%closure-index-ref
-          ,fin
-          (+ (or (position ,n-slot funcallable-instance-data)
-                 (error "Unknown slot: ~S." ,n-slot))
-             fin-data-offset)))))
-;;;
-(defmacro %set-funcallable-instance-data-1 (fin slot new-value)
-  (ext:once-only ((n-fin fin)
-                  (n-slot slot)
-                  (n-val new-value))
-    `(progn
-       (kernel:%set-funcallable-instance-info
-        ,n-fin
-	,(if (constantp slot)
-	     (+ (or (position (eval slot) funcallable-instance-data)
-		    (error "Unknown slot: ~S." (eval slot)))
-		fin-data-offset)
-	     `(+ (or (position ,n-slot funcallable-instance-data)
-		     (error "Unknown slot: ~S." ,n-slot))
-		 fin-data-offset))
-        ,n-val)
-       ,n-val)))
-;;;
-(defsetf funcallable-instance-data-1 %set-funcallable-instance-data-1)
-                
-); End of #+cmu progn
-
-
-;;;
-;;; Kyoto Common Lisp (KCL)
-;;;
-;;; In KCL, compiled functions and compiled closures are defined as c structs.
-;;; This means that in order to access their fields, we have to use C code!
-;;; The C code we call and the lisp interface to it is in the file kcl-low.
-;;; The lisp interface to this code implements accessors to compiled closures
-;;; and compiled functions of about the same level of abstraction as that
-;;; which is used by the other implementation dependent versions of FINs in
-;;; this file.
-;;;
-
-#+(and KCL (not IBCL))
-(progn
-
-(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
-
-(defconstant funcallable-instance-closure-size 15)
-
-(defconstant funcallable-instance-closure-size1
-  (1- funcallable-instance-closure-size))
-
-(defconstant funcallable-instance-available-size
-  (- funcallable-instance-closure-size1
-     (length funcallable-instance-data)))
-
-(defmacro funcallable-instance-marker (x)
-  `(car (cclosure-env-nthcdr funcallable-instance-closure-size1 ,x)))
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((fin (allocate-funcallable-instance-2))
-        (env (make-list funcallable-instance-closure-size :initial-element nil)))
-    (setf (%cclosure-env fin) env)
-    #+:turbo-closure (si:turbo-closure fin)
-    (setf (funcallable-instance-marker fin) *funcallable-instance-marker*)
-    fin))
-
-(defun allocate-funcallable-instance-2 ()
-  (let ((what-a-dumb-closure-variable ()))
-    #'(lambda (&rest args)
-        (declare (ignore args))
-        (called-fin-without-function)
-        (setq what-a-dumb-closure-variable
-              (dummy-function what-a-dumb-closure-variable)))))
-
-(defun funcallable-instance-p (x)
-  (eq *funcallable-instance-marker* (funcallable-instance-marker x)))
-
-(si:define-compiler-macro funcallable-instance-p (x)
-  `(eq *funcallable-instance-marker* (funcallable-instance-marker ,x)))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (cond ((not (funcallable-instance-p fin))
-         (error "~S is not a funcallable-instance" fin))
-        ((not (functionp new-value))
-         (error "~S is not a function." new-value))
-        ((and (cclosurep new-value)
-              (<= (length (%cclosure-env new-value))
-                  funcallable-instance-available-size))
-         (%set-cclosure fin new-value funcallable-instance-available-size))
-        (t
-         (set-funcallable-instance-function
-           fin (make-trampoline new-value))))
-  fin)
-
-(defmacro funcallable-instance-data-1 (fin data &environment env)
-  ;; The compiler won't expand macros before deciding on optimizations,
-  ;; so we must do it here.
-  (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
-                                env))
-         (index-form (if (constantp pos-form)
-                         (- funcallable-instance-closure-size
-                            (eval pos-form)
-                            2)
-                         `(- funcallable-instance-closure-size
-                             (funcallable-instance-data-position ,data)
-                             2))))
-    `(car (%cclosure-env-nthcdr ,index-form ,fin))))
-
-
-#+turbo-closure (clines "#define TURBO_CLOSURE")
-
-(clines "
-static make_trampoline_internal();
-static make_turbo_trampoline_internal();
-
-static object
-make_trampoline(function)
-     object function;
-{
-  vs_push(MMcons(function,Cnil));
-#ifdef TURBO_CLOSURE
-  if(type_of(function)==t_cclosure)
-    {if(function->cc.cc_turbo==NULL)turbo_closure(function);
-     vs_head=make_cclosure(make_turbo_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);
-     return vs_pop;}
-#endif
-  vs_head=make_cclosure(make_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);
-  return vs_pop;
-}
-
-static
-make_trampoline_internal(base0)
-     object *base0;
-{super_funcall_no_event(base0[0]->c.c_car);}
-
-static
-make_turbo_trampoline_internal(base0)
-     object *base0;
-{ object function=base0[0]->c.c_car;
-  (*function->cc.cc_self)(function->cc.cc_turbo);
-}
-
-")
-
-(defentry make-trampoline (object) (object make_trampoline))
-)
-
-#+IBCL
-(progn ; From Rainy Day PCL.  
-
-(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
-
-(defconstant funcallable-instance-closure-size 15)
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((fin (allocate-funcallable-instance-2))
-	(env
-	  (make-list funcallable-instance-closure-size :initial-element nil)))
-    (set-cclosure-env fin env)
-    #+:turbo-closure (si:turbo-closure fin)
-    (dotimes (i (1- funcallable-instance-closure-size)) (pop env))
-    (setf (car env) *funcallable-instance-marker*)
-    fin))
-
-(defun allocate-funcallable-instance-2 ()
-  (let ((what-a-dumb-closure-variable ()))
-    #'(lambda (&rest args)
-	(declare (ignore args))
-	(called-fin-without-function)
-	(setq what-a-dumb-closure-variable
-	      (dummy-function what-a-dumb-closure-variable)))))
-
-(defun funcallable-instance-p (x)
-  (and (cclosurep x)
-       (let ((env (cclosure-env x)))
-	 (when (listp env)
-	   (dotimes (i (1- funcallable-instance-closure-size)) (pop env))
-	   (eq (car env) *funcallable-instance-marker*)))))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (cond ((not (funcallable-instance-p fin))
-         (error "~S is not a funcallable-instance" fin))
-        ((not (functionp new-value))
-         (error "~S is not a function." new-value))
-        ((cclosurep new-value)
-         (let* ((fin-env (cclosure-env fin))
-                (new-env (cclosure-env new-value))
-                (new-env-size (length new-env))
-                (fin-env-size (- funcallable-instance-closure-size
-                                 (length funcallable-instance-data)
-				 1)))
-           (cond ((<= new-env-size fin-env-size)
-		  (do ((i 0 (+ i 1))
-		       (new-env-tail new-env (cdr new-env-tail))
-		       (fin-env-tail fin-env (cdr fin-env-tail)))
-		      ((= i fin-env-size))
-		    (setf (car fin-env-tail)
-			  (if (< i new-env-size)
-			      (car new-env-tail)
-			      nil)))		  
-		  (set-cclosure-self fin (cclosure-self new-value))
-		  (set-cclosure-data fin (cclosure-data new-value))
-		  (set-cclosure-start fin (cclosure-start new-value))
-		  (set-cclosure-size fin (cclosure-size new-value)))
-                 (t                 
-                  (set-funcallable-instance-function
-                    fin
-                    (make-trampoline new-value))))))
-	((typep new-value 'compiled-function)
-	 ;; Write NILs into the part of the cclosure environment that is
-	 ;; not being used to store the funcallable-instance-data.  Then
-	 ;; copy over the parts of the compiled function that need to be
-	 ;; copied over.
-	 (let ((env (cclosure-env fin)))
-	   (dotimes (i (- funcallable-instance-closure-size
-			  (length funcallable-instance-data)
-			  1))
-	     (setf (car env) nil)
-	     (pop env)))
-	 (set-cclosure-self fin (cfun-self new-value))
-	 (set-cclosure-data fin (cfun-data new-value))
-	 (set-cclosure-start fin (cfun-start new-value))
-	 (set-cclosure-size fin (cfun-size new-value)))	 
-        (t
-         (set-funcallable-instance-function fin
-                                            (make-trampoline new-value))))
-  fin)
-
-
-(defun make-trampoline (function)
-  #'(lambda (&rest args)
-      (apply function args)))
-
-;; this replaces funcallable-instance-data-1, set-funcallable-instance-data-1
-;; and the defsetf
-(defmacro funcallable-instance-data-1 (fin data &environment env)
-  ;; The compiler won't expand macros before deciding on optimizations,
-  ;; so we must do it here.
-  (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
-				env))
-	 (index-form (if (constantp pos-form)
-			 (- funcallable-instance-closure-size
-			    (eval pos-form)
-			    2)
-			 `(- funcallable-instance-closure-size
-			     (funcallable-instance-data-position ,data)
-			     2))))
-    #+:turbo-closure `(car (tc-cclosure-env-nthcdr ,index-form ,fin))
-    #-:turbo-closure `(nth ,index-form (cclosure-env ,fin))))
-
-)
-
-
-;;;
-;;; In H.P. Common Lisp
-;;; This code was originally written by:
-;;;    kempf@hplabs.hp.com     (James Kempf)
-;;;    dsouza@hplabs.hp.com    (Roy D'Souza)
-;;;
-#+HP-HPLabs
-(progn
-
-(defmacro fin-closure-size ()`(prim::@* 6 prim::bytes-per-word))
-
-(defmacro fin-set-mem-hword ()
-  `(prim::@set-mem-hword
-     (prim::@+ fin (prim::@<< 2 1))
-     (prim::@+ (prim::@<< 2 8)
-	       (prim::@fundef-info-parms (prim::@fundef-info fundef)))))
-
-(defun allocate-funcallable-instance-1()
-  (let* ((fundef
-	   #'(lambda (&rest ignore)
-	       (declare (ignore ignore))
-	       (called-fin-without-function)))
-	 (static-link (vector 'lisp::*undefined* NIL NIL NIL NIL NIL))
-	 (fin (prim::@make-fundef (fin-closure-size))))
-    (fin-set-mem-hword)
-    (prim::@set-svref fin 2 fundef)
-    (prim::@set-svref fin 3 static-link)
-    (prim::@set-svref fin 4 0) 
-    (impl::PlantclosureHook fin)
-    fin))
-
-(defmacro funcallable-instance-p (possible-fin)
-  `(= (fin-closure-size) (prim::@header-inf ,possible-fin)))
-
-(defun set-funcallable-instance-function (fin new-function)
-  (cond ((not (funcallable-instance-p fin))
-	 (error "~S is not a funcallable instance.~%" fin))
-	((not (functionp new-function))
-	 (error "~S is not a function." new-function))
-	(T
-	 (prim::@set-svref fin 2 new-function))))
-
-(defmacro funcallable-instance-data-1 (fin data)
-  `(prim::@svref (prim::@closure-static-link ,fin)
-		 (+ 2 (funcallable-instance-data-position ,data))))
-
-(defsetf funcallable-instance-data-1 (fin data) (new-value)
-  `(prim::@set-svref (prim::@closure-static-link ,fin)
-		     (+ (funcallable-instance-data-position ,data) 2)
-		     ,new-value))
-
-(defun funcallable-instance-name (fin)
-  (prim::@svref (prim::@closure-static-link fin) 1))
-
-(defsetf funcallable-instance-name set-funcallable-instance-name)
-
-(defun set-funcallable-instance-name (fin new-name)
-  (prim::@set-svref (prim::@closure-static-link fin) 1 new-name))
-
-);end #+HP
-
-
-
-;;;
-;;; In Golden Common Lisp.
-;;; This code was originally written by:
-;;;    dan%acorn@Live-Oak.LCS.MIT.edu     (Dan Jacobs)
-;;;
-;;; GCLISP supports named structures that are specially marked as funcallable.
-;;; This allows FUNCALLABLE-INSTANCE-P to be a normal structure predicate,
-;;; and allows ALLOCATE-FUNCALLABLE-INSTANCE-1 to be a normal boa-constructor.
-;;; 
-#+GCLISP
-(progn
-
-(defstruct (%funcallable-instance
-	     (:predicate funcallable-instance-p)
-	     (:copier nil)
-	     (:constructor allocate-funcallable-instance-1 ())
-	     (:print-function
-	      (lambda (struct stream depth)
-		(declare (ignore depth))
-		(print-object struct stream))))
-  (function	#'(lambda (ignore-this &rest ignore-these-too)
-		    (declare (ignore ignore-this ignore-these-too))
-		    (called-fin-without-function))
-		:type function)
-  (%hidden%	'gclisp::funcallable :read-only t)
-  (data		(vector nil nil) :type simple-vector :read-only t))
-
-(proclaim '(inline set-funcallable-instance-function))
-(defun set-funcallable-instance-function (fin new-value)
-  (setf (%funcallable-instance-function fin) new-value))
-
-(defmacro funcallable-instance-data-1 (fin data)
-  `(svref (%funcallable-instance-data ,fin)
-	  (funcallable-instance-data-position ,data)))
-
-)
-
-
-;;;
-;;; Explorer Common Lisp
-;;; This code was originally written by:
-;;;    Dussud%Jenner@csl.ti.com
-;;;    
-#+ti
-(progn
-
-#+(or :ti-release-3 (and :ti-release-2 elroy))
-(defmacro lexical-closure-environment (l)
-  `(cdr (si:%make-pointer si:dtp-list
-			  (cdr (si:%make-pointer si:dtp-list ,l)))))
-
-#-(or :ti-release-3 elroy)
-(defmacro lexical-closure-environment (l)
-  `(caar (si:%make-pointer si:dtp-list
-			   (cdr (si:%make-pointer si:dtp-list ,l)))))
-
-(defmacro lexical-closure-function (l)
-  `(car (si:%make-pointer si:dtp-list ,l)))
-
-
-(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
-
-(defconstant funcallable-instance-closure-size 15) ; NOTE: In order to avoid
-						   ; hassles with the reader,
-(defmacro allocate-funcallable-instance-2 ()       ; these two 15's are the
-  (let ((l ()))					   ; same.  Be sure to keep
-    (dotimes (i 15)				   ; them consistent.
-      (push (list (gensym) nil) l))
-    `(let ,l
-       #'(lambda (ignore &rest ignore-them-too)
-	   (declare (ignore ignore ignore-them-too))
-	   (called-fin-without-function)
-	   (values . ,(mapcar #'car l))))))
-
-(defun allocate-funcallable-instance-1 ()
-  (let* ((new-fin (allocate-funcallable-instance-2)))
-    (setf (car (nthcdr (1- funcallable-instance-closure-size)
-		       (lexical-closure-environment new-fin)))
-	  *funcallable-instance-marker*) 
-    new-fin))
-
-(eval-when (eval) (compile 'allocate-funcallable-instance-1))
-
-(proclaim '(inline funcallable-instance-p))
-(defun funcallable-instance-p (x)
-  (and (typep x #+:ti-release-2 'closure
-	        #+:ti-release-3 'si:lexical-closure)
-       (let ((env (lexical-closure-environment x)))
-	 (eq (nth (1- funcallable-instance-closure-size) env)
-	     *funcallable-instance-marker*))))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (cond ((not (funcallable-instance-p fin))
-	 (error "~S is not a funcallable-instance"))
-	((not (functionp new-value))
-	 (error "~S is not a function."))
-	((typep new-value 'si:lexical-closure)
-	 (let* ((fin-env (lexical-closure-environment fin))
-		(new-env (lexical-closure-environment new-value))
-		(new-env-size (length new-env))
-		(fin-env-size (- funcallable-instance-closure-size
-				 (length funcallable-instance-data)
-				 1)))
-	   (cond ((<= new-env-size fin-env-size)
-		  (do ((i 0 (+ i 1))
-		       (new-env-tail new-env (cdr new-env-tail))
-		       (fin-env-tail fin-env (cdr fin-env-tail)))
-		      ((= i fin-env-size))
-		    (setf (car fin-env-tail)
-			  (if (< i new-env-size)
-			      (car new-env-tail)
-			      nil)))		  
-		  (setf (lexical-closure-function fin)
-			(lexical-closure-function new-value)))
-		 (t
-		  (set-funcallable-instance-function
-		    fin
-		    (make-trampoline new-value))))))
-	(t
-	 (set-funcallable-instance-function fin
-					    (make-trampoline new-value)))))
-
-(defun make-trampoline (function)
-  (let ((tmp))
-    #'(lambda (&rest args) tmp
-	(apply function args))))
-
-(eval-when (eval) (compile 'make-trampoline))
-	
-(defmacro funcallable-instance-data-1 (fin data)
-  `(let ((env (lexical-closure-environment ,fin)))
-     (nth (- funcallable-instance-closure-size
-	     (funcallable-instance-data-position ,data)
-	     2)
-	  env)))
-
-
-(defsetf funcallable-instance-data-1 (fin data) (new-value)
-  `(let ((env (lexical-closure-environment ,fin)))
-     (setf (car (nthcdr (- funcallable-instance-closure-size
-			   (funcallable-instance-data-position ,data)
-			   2)
-			env))
-	   ,new-value)))
-
-);end of code for TI
-
-
-;;; Implemented by Bein@pyramid -- Tue Aug 25 19:05:17 1987
-;;;
-;;; A FIN is a distinct type of object which FUNCALL,EVAL, and APPLY
-;;; recognize as functions. Both Compiled-Function-P and functionp
-;;; recognize FINs as first class functions.
-;;;
-;;; This does not work with PyrLisp versions earlier than 1.1..
-
-#+pyramid
-(progn
-
-(defun make-trampoline (function)
-    #'(lambda (&rest args) (apply function args)))
-
-(defun un-initialized-fin (&rest trash)
-    (declare (ignore trash))
-    (called-fin-without-function))
-
-(eval-when (eval)
-    (compile 'make-trampoline)
-    (compile 'un-initialized-fin))
-
-(defun allocate-funcallable-instance-1 ()
-    (let ((fin (system::alloc-funcallable-instance)))
-      (system::set-fin-function fin #'un-initialized-fin)
-      fin))
-	     
-(defun funcallable-instance-p (object)
-  (typep object 'lisp::funcallable-instance))
-
-(clc::deftransform funcallable-instance-p trans-fin-p (object)
-    `(typep ,object 'lisp::funcallable-instance))
-
-(defun set-funcallable-instance-function (fin new-value)
-    (or (funcallable-instance-p fin)
-	(error "~S is not a funcallable-instance." fin))
-    (cond ((not (functionp new-value))
-	   (error "~S is not a function." new-value))
-	  ((not (lisp::compiled-function-p new-value))
-	   (set-funcallable-instance-function fin
-					      (make-trampoline new-value)))
-	  (t
-	   (system::set-fin-function fin new-value))))
-
-(defun funcallable-instance-data-1 (fin data-name)
-  (system::get-fin-data fin
-			(funcallable-instance-data-position data-name)))
-
-(defun set-funcallable-instance-data-1 (fin data-name value)
-  (system::set-fin-data fin
-			(funcallable-instance-data-position data-name)
-			value))
-
-(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
-
-); End of #+pyramid
-
-
-;;;
-;;; For Coral Lisp
-;;;
-#+:coral
-(progn
-  
-(defconstant ccl::$v_istruct 22)
-(defvar ccl::initial-fin-slots (make-list (length funcallable-instance-data)))
-(defconstant ccl::fin-function 1)
-(defconstant ccl::fin-data (+ ccl::FIN-function 1))
-
-(defun allocate-funcallable-instance-1 ()
-  (apply #'ccl::%gvector 
-         ccl::$v_istruct
-         'ccl::funcallable-instance
-         #'(lambda (&rest ignore)
-             (declare (ignore ignore))
-	     (called-fin-without-function))
-         ccl::initial-fin-slots))
-
-#+:ccl-1.3
-(eval-when (eval compile load)
-
-;;; Make uvector-based objects (like funcallable instances) print better.
-(defun print-uvector-object (obj stream &optional print-level)
-  (declare (ignore print-level))
-  (print-object obj stream))
-
-;;; Inform the print system about funcallable instance uvectors.
-(pushnew (cons 'ccl::funcallable-instance #'print-uvector-object)
-	 ccl:*write-uvector-alist*
-	 :test #'equal)
-
-)
-
-(defun funcallable-instance-p (x)
-  (and (eq (ccl::%type-of x) 'ccl::internal-structure)
-       (eq (ccl::%uvref x 0) 'ccl::funcallable-instance)))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (unless (funcallable-instance-p fin)
-    (error "~S is not a funcallable-instance." fin))
-  (unless (functionp new-value)
-    (error "~S is not a function." new-value))
-  (ccl::%uvset fin ccl::FIN-function new-value))
-
-(defmacro funcallable-instance-data-1 (fin data-name)
-  `(ccl::%uvref ,fin 
-                (+ (funcallable-instance-data-position ,data-name)
-		   ccl::FIN-data)))
-
-(defsetf funcallable-instance-data-1 (fin data) (new-value)
-  `(ccl::%uvset ,fin 
-                (+ (funcallable-instance-data-position ,data) ccl::FIN-data)
-                ,new-value))
-
-); End of #+:coral
-
-
-  
-;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff.
-;;;
-;;;
-
-(defmacro fsc-instance-p (fin)
-  `(funcallable-instance-p ,fin))
-
-(defmacro fsc-instance-class (fin)
-  `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
-
-(defmacro fsc-instance-wrapper (fin)
-  `(funcallable-instance-data-1 ,fin 'wrapper))
-
-(defmacro fsc-instance-slots (fin)
-  `(funcallable-instance-data-1 ,fin 'slots))
-
-
-
diff --git a/pcl/fixup.lisp b/pcl/fixup.lisp
deleted file mode 100644
index 82c4d697434123a27486535157028e925589d22f..0000000000000000000000000000000000000000
--- a/pcl/fixup.lisp
+++ /dev/null
@@ -1,40 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-(fix-early-generic-functions)
-(setq *boot-state* 'complete)
-
-#+Lispm
-(eval-when (load eval)
-  (si:record-source-file-name 'print-std-instance 'defun 't))
-
-(defun print-std-instance (instance stream depth)
-  (declare (ignore depth))
-  (print-object instance stream))
-
diff --git a/pcl/fngen.lisp b/pcl/fngen.lisp
deleted file mode 100644
index 61ae0ac66aa8a66cd2c0042e38ac32d5a20ae346..0000000000000000000000000000000000000000
--- a/pcl/fngen.lisp
+++ /dev/null
@@ -1,214 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-;;;
-;;; GET-FUNCTION is the main user interface to this code. It is like
-;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by 
-;;; reducing the number of times that the compiler needs to be called.  
-;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants 
-;;; can use the same piece of compiled code.  (For example, dispatch dfuns and 
-;;; combined method functions can often be shared, if they differ only 
-;;; by referring to different methods.)
-;;;
-;;; If GET-FUNCTION is called with a lambda expression only, it will return 
-;;; a corresponding function. The optional constant-converter argument
-;;; can be a function which will be called to convert each constant appearing
-;;; in the lambda to whatever value should appear in the function.
-;;;
-;;; There are three internal functions which operate on the lambda argument 
-;;; to GET-FUNCTION:
-;;;   compute-test converts the lambda into a key to be used for lookup,
-;;;   compute-code is used by get-new-function-generator-internal to
-;;;                generate the actual lambda to be compiled, and
-;;;   compute-constants is used to generate the argument list that is
-;;;                to be passed to the compiled function.
-;;;
-;;; Whether the returned function is actually compiled depends on whether
-;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of
-;;; code was precompiled.
-;;; 
-(defun get-function (lambda
-		      &optional (test-converter     #'default-test-converter)
-		                (code-converter     #'default-code-converter)
-				(constant-converter #'default-constant-converter))
-  (function-apply (get-function-generator lambda test-converter code-converter)
-		  (compute-constants      lambda constant-converter)))
-
-(defun get-function1 (lambda
-		      &optional (test-converter     #'default-test-converter)
-		                (code-converter     #'default-code-converter)
-				(constant-converter #'default-constant-converter))
-  (values (the function (get-function-generator lambda test-converter code-converter))
-	  (compute-constants      lambda constant-converter)))
-
-(defun default-constantp (form)
-  (and (constantp form)
-       (not (typep (eval form) '(or symbol fixnum)))))
-
-(defun default-test-converter (form)
-  (if (default-constantp form)
-      '.constant.
-      form))
-
-(defun default-code-converter  (form)
-  (if (default-constantp form)
-      (let ((gensym (gensym))) (values gensym (list gensym)))
-      form))
-
-(defun default-constant-converter (form)
-  (if (default-constantp form)
-      (list (eval form))
-      nil))
-
-
-;;;
-;;; *fgens* is a list of all the function generators we have so far.  Each 
-;;; element is a FGEN structure as implemented below.  Don't ever touch this
-;;; list by hand, use STORE-FGEN.
-;;;
-(defvar *fgens* ())
-
-(defun store-fgen (fgen)
-  (let ((old (lookup-fgen (fgen-test fgen))))
-    (if old
-	(setf (svref old 2) (fgen-generator fgen)
-	      (svref old 4) (or (svref old 4)
-				(fgen-system fgen)))
-	(setq *fgens* (nconc *fgens* (list fgen))))))
-
-(defun lookup-fgen (test)
-  (find test (the list *fgens*) :key #'fgen-test :test #'equal))
-
-(defun make-fgen (test gensyms generator generator-lambda system)
-  (let ((new (make-array 6)))
-    (setf (svref new 0) test
-	  (svref new 1) gensyms
-	  (svref new 2) generator
-	  (svref new 3) generator-lambda
-	  (svref new 4) system)
-    new))
-
-(defun fgen-test             (fgen) (svref fgen 0))
-(defun fgen-gensyms          (fgen) (svref fgen 1))
-(defun fgen-generator        (fgen) (svref fgen 2))
-(defun fgen-generator-lambda (fgen) (svref fgen 3))
-(defun fgen-system           (fgen) (svref fgen 4))
-
-
-
-(defun get-function-generator (lambda test-converter code-converter)
-  (let* ((test (compute-test lambda test-converter))
-	 (fgen (lookup-fgen test)))
-    (if fgen
-	(fgen-generator fgen)
-	(get-new-function-generator lambda test code-converter))))
-
-(defun get-new-function-generator (lambda test code-converter)
-  (multiple-value-bind (gensyms generator-lambda)
-      (get-new-function-generator-internal lambda code-converter)
-    (let* ((generator (compile-lambda generator-lambda))
-	   (fgen (make-fgen test gensyms generator generator-lambda nil)))
-      (store-fgen fgen)
-      generator)))
-
-(defun get-new-function-generator-internal (lambda code-converter)
-  (multiple-value-bind (code gensyms)
-      (compute-code lambda code-converter)
-    (values gensyms `(lambda ,gensyms (function ,code)))))
-
-
-(defun compute-test (lambda test-converter)
-  (let ((walk-form-expand-macros-p t))
-    (walk-form lambda
-	       nil
-	       #'(lambda (f c e)
-		   (declare (ignore e))
-		   (if (neq c :eval)
-		       f
-		       (let ((converted (funcall test-converter f)))
-			 (values converted (neq converted f))))))))
-
-(defun compute-code (lambda code-converter)
-  (let ((walk-form-expand-macros-p t)
-	(gensyms ()))
-    (values (walk-form lambda
-		       nil
-		       #'(lambda (f c e)
-			   (declare (ignore e))
-			   (if (neq c :eval)
-			       f
-			       (multiple-value-bind (converted gens)
-				   (funcall code-converter f)
-				 (when gens (setq gensyms (append gensyms gens)))
-				 (values converted (neq converted f))))))
-	      gensyms)))
-
-(defun compute-constants (lambda constant-converter)
-  (let ((walk-form-expand-macros-p t)) ; doesn't matter here.
-    (macrolet ((appending ()
-		 `(let ((result ()))
-		   (values #'(lambda (value) (setq result (append result value)))
-		    #'(lambda ()result)))))
-      (gathering1 (appending)
-		  (walk-form lambda
-			     nil
-			     #'(lambda (f c e)
-				 (declare (ignore e))
-				 (if (neq c :eval)
-				     f
-				     (let ((consts (funcall constant-converter f)))
-				       (if consts
-					   (progn (gather1 consts) (values f t))
-					   f)))))))))
-
-
-;;;
-;;;
-;;;
-(defmacro precompile-function-generators (&optional system)
-  (let ((index -1))
-    `(progn ,@(gathering1 (collecting)
-		(dolist (fgen *fgens*)
-		  (when (or (null (fgen-system fgen))
-			    (eq (fgen-system fgen) system))
-		    (when system (setf (svref fgen 4) system))
-		    (gather1
-		     (make-top-level-form
-		      `(precompile-function-generators ,system ,(incf index))
-		      '(load)
-		      `(load-function-generator
-			',(fgen-test fgen)
-			',(fgen-gensyms fgen)
-			(function ,(fgen-generator-lambda fgen))
-			',(fgen-generator-lambda fgen)
-			',system)))))))))
-
-(defun load-function-generator (test gensyms generator generator-lambda system)
-  (store-fgen (make-fgen test gensyms generator generator-lambda system)))
-
diff --git a/pcl/fsc.lisp b/pcl/fsc.lisp
deleted file mode 100644
index 6d7f28a5cd1391376f55ddb761ce769a75abd6eb..0000000000000000000000000000000000000000
--- a/pcl/fsc.lisp
+++ /dev/null
@@ -1,100 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; This file contains the definition of the FUNCALLABLE-STANDARD-CLASS
-;;; metaclass.  Much of the implementation of this metaclass is actually
-;;; defined on the class STD-CLASS.  What appears in this file is a modest
-;;; number of simple methods related to the low-level differences in the
-;;; implementation of standard and funcallable-standard instances.
-;;;
-;;; As it happens, none of these differences are the ones reflected in
-;;; the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS
-;;; share all their specified methods at STD-CLASS.
-;;; 
-;;; 
-;;; workings of this metaclass and the standard-class metaclass.
-;;; 
-
-(in-package :pcl)
-
-(defmethod wrapper-fetcher ((class funcallable-standard-class))
-  'fsc-instance-wrapper)
-
-(defmethod slots-fetcher ((class funcallable-standard-class))
-  'fsc-instance-slots)
-
-(defmethod raw-instance-allocator ((class funcallable-standard-class))
-  'allocate-funcallable-instance)
-
-;;;
-;;;
-;;;
-
-(defmethod validate-superclass
-	   ((fsc funcallable-standard-class)
-	    (class standard-class))
-  t) ; was (null (wrapper-instance-slots-layout (class-wrapper class)))
-
-
-(defmethod allocate-instance
-	   ((class funcallable-standard-class) &rest initargs)
-  (declare (ignore initargs))
-  (unless (class-finalized-p class) (finalize-inheritance class))
-  (allocate-funcallable-instance (class-wrapper class)))
-
-(defmethod make-reader-method-function ((class funcallable-standard-class)
-					slot-name)
-  (make-std-reader-method-function (class-name class) slot-name))
-
-(defmethod make-writer-method-function ((class funcallable-standard-class)
-					slot-name)
-  (make-std-writer-method-function (class-name class) slot-name))
-
-;;;;
-;;;; See the comment about reader-function--std and writer-function--sdt.
-;;;;
-;(define-function-template reader-function--fsc () '(slot-name)
-;  `(function
-;     (lambda (instance)
-;       (slot-value-using-class (wrapper-class (get-wrapper instance))
-;			       instance
-;			       slot-name))))
-;
-;(define-function-template writer-function--fsc () '(slot-name)
-;  `(function
-;     (lambda (nv instance)
-;       (setf
-;	 (slot-value-using-class (wrapper-class (get-wrapper instance))
-;				 instance
-;				 slot-name)
-;	 nv))))
-;
-;(eval-when (load)
-;  (pre-make-templated-function-constructor reader-function--fsc)
-;  (pre-make-templated-function-constructor writer-function--fsc))
-
-
-
diff --git a/pcl/gcl-patches.lisp b/pcl/gcl-patches.lisp
deleted file mode 100644
index 9f6f4e7d8a195d1d5a8635be78e06ffc1aef9236..0000000000000000000000000000000000000000
--- a/pcl/gcl-patches.lisp
+++ /dev/null
@@ -1,168 +0,0 @@
-;;; -*- Mode:Lisp; Package:USER; Base:10; Syntax:Common-lisp -*-
-
-(in-package 'user)
-
-(setq c::optimize-speed 3)
-(setq c::optimize-safety 0)
-(setq c::optimize-space 0)
-
-(remprop 'macroexpand 'c::fdesc)
-(remprop 'macroexpand-1 'c::fdesc)
-
-
-;;; this is here to fix the printer so it will find the print
-;;; functions on structures that have 'em.
-
-(in-package 'lisp)
-
-(defun %write-structure (struct output-stream print-vars level)
-  (let* ((name (svref struct 0))
-	 (pfun (or (let ((temp (get name 'structure-descriptor)))
-	 	     (and temp (dd-print-function temp)))
-	 	   (get name :print-function))))
-    (declare (symbol name))
-    (cond
-      (pfun
-	(funcall pfun struct output-stream level))
-      ((and (pv-level print-vars) (>= level (pv-level print-vars)))
-       (write-char #\# output-stream))
-      ((and (pv-circle print-vars)
-            (%write-circle struct output-stream (pv-circle print-vars))))
-      (t
-       (let ((pv-length (pv-length print-vars))
-	     (pv-pretty (pv-pretty print-vars)))
-	 (when pv-pretty
-	   (pp-push-level pv-pretty))
-	 (incf level)
-	 (write-string "#s(" output-stream)
-	 (cond
-	  ((and pv-length (>= 0 pv-length))
-	   (write-string "..."))
-	  (t
-	   (%write-symbol name output-stream print-vars)
-	   (do ((i 0 (1+ i))
-		(n 0)
-		(slots (dd-slots (get name 'structure-descriptor))
-		       (rest slots)))
-	       ((endp slots))
-	     (declare (fixnum i n) (list slots))
-	     (when pv-pretty
-	       (pp-insert-break pv-pretty *structure-keyword-slot-spec* t))
-	     (write-char #\space output-stream)
-	     (when (and pv-length (>= (incf n) pv-length))
-	       (write-string "..." output-stream)
-	       (return))
-	     (write-char #\: output-stream)
-	     (%write-symbol-name
-	      (symbol-name (dsd-name (first slots))) output-stream print-vars)
-	     (when pv-pretty
-	       (pp-insert-break pv-pretty *structure-data-slot-spec* nil))
-	     (write-char #\space output-stream)
-	     (when (and pv-length (>= (incf n) pv-length))
-	       (write-string "..." output-stream)
-	       (return))
-	     (%write-object
-	      (svref struct (dsd-index (first slots)))
-	      output-stream print-vars level))))
-	 (write-char #\) output-stream)
-	 (when pv-pretty
-	   (pp-pop-level pv-pretty)))))))
-
-(eval-when (eval) (compile '%write-structure))
-
-;;;
-;;; Apparently, whoever implemented the TIME macro didn't consider that
-;;; someone might want to use it in a non-null lexical environment.  Of
-;;; course this fix is a loser since it binds a whole mess of variables
-;;; around the evaluation of form, but it will do for now.
-;;;
-(in-package 'lisp)
-
-(DEFmacro TIME (FORM)
-  `(LET (IGNORE START FINISH S-HSEC F-HSEC S-SEC F-SEC S-MIN F-MIN VALS)
-     (FORMAT *trace-output* "~&Evaluating: ~A" ,form)
-     ;; read the start time.
-     (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE S-MIN START)
-       (SYS::%SYSINT #X21 #X2C00 0 0 0))
-     ;; Eval the form.
-     (SETQ VALS (MULTIPLE-VALUE-LIST (progn ,form)))
-     ;; Read the end time.
-     (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE F-MIN FINISH)
-       (SYS::%SYSINT #X21 #X2C00 0 0 0))
-     ;; Unpack start and end times.
-     (SETQ S-HSEC (LOGAND START #X0FF)
-	   F-HSEC (LOGAND FINISH #X0FF)
-	   S-SEC (LSH START -8)
-           F-SEC (LSH FINISH -8)
-	   S-MIN (LOGAND #X0FF S-MIN)
-	   F-MIN (LOGAND #X0FF F-MIN))
-     (SETQ F-HSEC (- F-HSEC S-HSEC))			; calc hundreths
-     (IF (MINUSP F-HSEC)
-         (SETQ F-HSEC (+ F-HSEC 100)
-	       F-SEC (1- F-SEC)))
-     (SETQ F-SEC (- F-SEC S-SEC))			; calc seconds
-     (IF (MINUSP F-SEC)
-         (SETQ F-SEC (+ F-SEC 60)
-	       F-MIN (1- F-MIN)))
-     (SETQ F-MIN (- F-MIN S-MIN))			; calc minutes
-     (IF (MINUSP F-MIN) (INCF F-MIN 60))
-     (FORMAT *trace-output* "~&Elapsed time: ~D:~:[~D~;0~D~].~:[~D~;0~D~]~%"
-       F-MIN (< F-SEC 10.) F-SEC (< F-HSEC 10) F-HSEC)
-     (VALUES-LIST VALS)))
-
-;;;
-;;; Patch to PROGV
-;;; 
-(in-package sys::*compiler-package-load*)
-
-;;; This is a fully portable (though not very efficient)
-;;; implementation of PROGV as a macro.  It does its own special
-;;; binding (shallow binding) by saving the original values in a
-;;; list, and marking things that were originally unbound.
-
-(defun PORTABLE-PROGV-BIND (symbol old-vals place-holder)
-  (let ((val-to-save '#:value-to-save))
-    `(let ((,val-to-save (if (boundp ,symbol)
-			     (symbol-value ,symbol)
-			     ,place-holder)))
-       (if ,old-vals
-	   (rplacd (last ,old-vals) (ncons ,val-to-save))
-	   (setq ,old-vals (ncons ,val-to-save))))))
-
-(defun PORTABLE-PROGV-UNBIND (symbol old-vals place-holder)
-  (let ((val-to-restore '#:value-to-restore))
-    `(let ((,val-to-restore (pop ,old-vals)))
-       (if (eq ,val-to-restore ,place-holder)
-	   (makunbound ,symbol)
-	   (setf (symbol-value ,symbol) ,val-to-restore)))))
-  
-
-(deftransform PROGV PORTABLE-PROGV-TRANSFORM
-	      (symbols-form values-form &rest body)
-  (let ((symbols-lst '#:symbols-list)
-	(values-lst '#:values-list)
-	(syms '#:symbols)
-	(vals '#:values)
-	(sym '#:symbol)
-	(old-vals '#:old-values)
-	(unbound-holder ''#:unbound-holder))
-    `(let ((,symbols-lst ,symbols-form)
-	   (,values-lst ,values-form)
-	   (,old-vals nil))
-       (unless (and (listp ,symbols-lst) (listp ,values-lst))
-	 (error "PROGV: Both symbols and values must be lists"))
-       (unwind-protect
-	   (do ((,syms ,symbols-lst (cdr ,syms))
-		(,vals ,values-lst (cdr ,vals))
-		(,sym nil))
-	       ((null ,syms) (progn ,@body))
-	     (setq ,sym (car ,syms))
-	     (if (symbolp ,sym)
-		 ,(PORTABLE-PROGV-BIND sym old-vals unbound-holder)
-		 (error "PROGV: Object to be bound not a symbol: ~S" ,sym))
-	     (if ,vals
-		 (setf (symbol-value ,sym) (first ,vals))
-		 (makunbound ,sym)))
-	 (dolist (,sym ,symbols-lst)
-	   ,(PORTABLE-PROGV-UNBIND sym old-vals unbound-holder))))))
-
diff --git a/pcl/genera-low.lisp b/pcl/genera-low.lisp
deleted file mode 100644
index 71c939d1330f5bff43b16514989e016cd504ecd2..0000000000000000000000000000000000000000
--- a/pcl/genera-low.lisp
+++ /dev/null
@@ -1,423 +0,0 @@
-;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; This is the 3600 version of the file portable-low.
-;;;
-
-(in-package 'pcl)
-
-(pushnew ':pcl-internals dbg:*all-invisible-frame-types*)
-
-#+IMach						;On the I-Machine these are
-(eval-when (compile load eval)			;faster than the versions
-						;that use :test #'eq.  
-(defmacro memq (item list) `(member ,item ,list))
-(defmacro assq (item list) `(assoc ,item ,list))
-(defmacro rassq (item list) `(rassoc ,item ,list))
-(defmacro delq (item list) `(delete ,item ,list))
-(defmacro posq (item list) `(position ,item ,list))
-
-)
-
-compiler::
-(defoptimizer (cl:the the-just-gets-in-the-way-of-optimizers) (form)
-  (matchp form
-    (('cl:the type subform)
-     (ignore type)
-     subform)
-    (* form)))
-
-(defmacro %ash (x count)
-  (if (and (constantp count) (zerop (eval count)))
-      x
-      `(the fixnum (ash (the fixnum ,x ) ,count))))
-
-;;;
-;;;
-;;;
-
-(defmacro without-interrupts (&body body)
-  `(let ((outer-scheduling-state si:inhibit-scheduling-flag)
-	 (si:inhibit-scheduling-flag t))
-     (macrolet ((interrupts-on  ()
-		  '(when (null outer-scheduling-state)
-		     (setq si:inhibit-scheduling-flag nil)))
-		(interrupts-off ()
-		  '(setq si:inhibit-scheduling-flag t)))
-       (progn outer-scheduling-state)
-       ,.body)))
-
-;;;
-;;; It would appear that #, does not work properly in Genera.  At least I can't get it
-;;; to work when I use it inside of std-instance-p (defined later in this file).  So,
-;;; all of this is just to support that.
-;;;
-;;;     WHEN                       EXPANDS-TO
-;;;   compile to a file          (#:EVAL-AT-LOAD-TIME-MARKER . <form>)
-;;;   compile to core            '<result of evaluating form>
-;;;   not in compiler at all     (progn <form>)
-;;;
-;;; Believe me when I tell you that I don't know why it is I need both a
-;;; transformer and an optimizer to get this to work.  Believe me when I
-;;; tell you that I don't really care why either.
-;;;
-(defmacro load-time-eval (form)
-  ;; The interpreted definition of load-time-eval.  This definition
-  ;; never gets compiled.
-  (let ((value (gensym)))
-    `(multiple-value-bind (,value)
-	 (progn ,form)
-       ,value)))
-
-(compiler:deftransformer (load-time-eval optimize-load-time-eval) (form)
-  (compiler-is-a-loser-internal form))
-
-(compiler:defoptimizer (load-time-eval transform-load-time-eval) (form)
-  (compiler-is-a-loser-internal form))
-
-(defun compiler-is-a-loser-internal (form)  
-  ;; When compiling a call to load-time-eval the compiler will call
-  ;; this optimizer before the macro expansion.
-  (if zl:compiler:(and (boundp '*compile-function*)	;Probably don't need
-						        ;this boundp check
-						        ;but it can't hurt.
-		       (funcall *compile-function* :to-core-p))
-      ;; Compiling to core.
-      ;; Evaluate the form now, and expand into a constant
-      ;; (the result of evaluating the form).
-      `',(eval (cadr form))
-      ;; Compiling to a file.
-      ;; Generate the magic which causes the dumper compiler and loader
-      ;; to do magic and evaluate the form at load time.
-      `',(cons compiler:eval-at-load-time-marker (cadr form))))
-
-;;   
-;;;;;; Memory Block primitives.                ***
-  ;;   
-
-
-(defmacro make-memory-block (size &optional area)
-  `(make-array ,size :area ,area))
-
-(defmacro memory-block-ref (block offset)	;Don't want to go faster yet.
-  `(aref ,block ,offset))
-
-(defvar class-wrapper-area)
-(eval-when (load eval)
-  (si:make-area :name 'class-wrapper-area
-		:room t
-		:gc :static))
-
-(eval-when (compile load eval)
-  (remprop '%%allocate-instance--class 'inline))
-
-(eval-when (compile load eval)
-  
-(scl:defflavor std-instance
-	((wrapper nil)
-	 (slots   nil))
-	()
-  (:constructor %%allocate-instance--class())
-  :ordered-instance-variables)
-
-(defvar *std-instance-flavor* (flavor:find-flavor 'std-instance))
-
-)
-
-#-imach
-(scl:defsubst pcl-%instance-flavor (instance)
-  (declare (compiler:do-not-record-macroexpansions))
-  (sys::%make-pointer sys:dtp-array
-		      (sys:%p-contents-as-locative
-			(sys:follow-structure-forwarding instance))))
-
-#+imach
-(scl:defsubst pcl-%instance-flavor (instance)
-  (sys:%instance-flavor instance))
-
-(scl::defsubst std-instance-p (x)
-  (and (sys:instancep x)
-       (eq (pcl-%instance-flavor x) (load-time-eval *std-instance-flavor*))))
-
-(scl:defmethod (:print-self std-instance) (stream depth slashify)
-  (declare (ignore slashify))
-  (print-std-instance scl:self stream depth))
-
-(scl:defmethod (:describe std-instance) ()
-  (describe-object scl:self *standard-output*))
-
-(defmacro %std-instance-wrapper (std-instance)
-  `(sys:%instance-ref ,std-instance 1))
-
-(defmacro %std-instance-slots (std-instance)
-  `(sys:%instance-ref ,std-instance 2))
-
-(scl:compile-flavor-methods std-instance)
-
-
-(defun printing-random-thing-internal (thing stream)
-  (format stream "~\\si:address\\" (si:%pointer thing)))
-
-;;;
-;;; This is hard, I am sweating.
-;;; 
-(defun function-arglist (function) (zl:arglist function t))
-
-(defun function-pretty-arglist (function) (zl:arglist function))
-
-
-;; New (& complete) fspec handler.
-;;   1. uses a single #'equal htable where stored elements are (fn . plist)
-;;       (maybe we should store the method object instead)
-;;   2. also implements the fspec-plist operators here.
-;;   3. fdefine not only stores the method, but actually does the loading here!
-;;
-
-;;;
-;;;  genera-low.lisp (replaces old method-function-spec-handler)
-;;;
-
-;; New (& complete) fspec handler.
-;;   1. uses a single #'equal htable where stored elements are (fn . plist)
-;;       (maybe we should store the method object instead)
-;;   2. also implements the fspec-plist operators here.
-;;   3. fdefine not only stores the method, but actually does the loading here!
-;;
-
-(defvar *method-htable* (make-hash-table :test #'equal :size 500))
-(sys:define-function-spec-handler method (op spec &optional arg1 arg2)
-  (if (eq op 'sys:validate-function-spec)
-      (and (let ((gspec (cadr spec)))
-	     (or (symbolp gspec)
-		 (and (listp gspec)
-		      (eq (car gspec) 'setf)
-		      (symbolp (cadr gspec))
-		      (null (cddr gspec)))))
-	   (let ((tail (cddr spec)))
-	     (loop (cond ((null tail) (return nil))
-			 ((listp (car tail)) (return t))
-			 ((atom (pop tail)))			 
-			 (t (return nil))))))
-      (let ((table *method-htable*)
-	    (key spec))
-	(case op
-	  ((si:fdefinedp si:fdefinition)
-	   (car (gethash key table nil)))
-	  (si:fundefine
-	    (remhash key table))
-	  (si:fdefine
-	    (let ((old (gethash key table nil))
-		  (quals nil)
-		  (specs nil)
-		  (ptr (cddr spec)))
-	      (setq specs
-		    (loop (cond ((null ptr) (return nil))
-				((listp (car ptr)) (return (car ptr)))
-				(t (push (pop ptr) quals)))))
-	      (setf (gethash key table) (cons arg1 (cdr old)))))
-	  (si:get
-	    (let ((old (gethash key table nil)))
-	      (getf (cdr old) arg1)))
-	  (si:plist
-	    (let ((old (gethash key table nil)))
-	      (cdr old)))
-	  (si:putprop
-	    (let ((old (gethash key table nil)))
-	      (unless old
-		(setf old (cons nil nil))
-		(setf (gethash key table) old))
-	      (setf (getf (cdr old) arg2) arg1)))
-	  (si:remprop
-	    (let ((old (gethash key table nil)))
-	      (when old
-		(remf (cdr old) arg1))))
-	  (otherwise
-	    (si:function-spec-default-handler op spec arg1 arg2))))))
-
-
-#||
-;; this guy is just a stub to make the fspec handler simpler (and so I could trace it
-;; easier).
-(defun pcl-fdefine-helper (gspec qualifiers specializers fn)
-  (let* ((dlist (scl:debugging-info fn))
-	 (class (cadr (assoc 'pcl-method-class dlist)))
-	 (lambda-list (let ((ll-stuff (assoc 'pcl-lambda-list dlist)))
-			(if ll-stuff (cadr ll-stuff) (arglist fn))))
-	 (doc (cadr (assoc 'pcl-documentation dlist)))
-	 (plist (cadr (assoc 'pcl-plist dlist))))
-    (load-defmethod (or class 'standard-method)
-		    gspec
-		    qualifiers
-		    specializers
-		    lambda-list
-		    doc
-		    (getf plist :pv-table-cache-symbol)
-		    plist
-		    fn)))
-||#
-
-;; define a few special declarations to get pushed onto the function's debug-info
-;; list... note that we do not need to do a (proclaim (declarations ...)) here.
-;;
-(eval-when (compile load eval)
-  (setf (get 'pcl-plist 'si:debug-info) t)
-  (setf (get 'pcl-documentation 'si:debug-info) t)
-  (setf (get 'pcl-method-class 'si:debug-info) t)
-  (setf (get 'pcl-lambda-list 'si:debug-info) t)
-)
-
-(eval-when (load eval)
-  (setf
-    (get 'defmethod      'zwei:definition-function-spec-type) 'defun
-    (get 'defmethod-setf 'zwei:definition-function-spec-type) 'defun
-    (get 'method 'si:definition-type-name) "method"
-    (get 'method 'si:definition-type-name) "method"
-
-    (get 'declass 'zwei:definition-function-spec-type) 'defclass
-    (get 'defclass 'si:definition-type-name) "Class"
-    (get 'defclass 'zwei:definition-function-spec-finder-template) '(0 1))
-  )
-
-
-
-(defun (:property defmethod zwei::definition-function-spec-parser) (bp)
-  (zwei:parse-pcl-defmethod-for-zwei bp nil))
-
-;;;
-;;; Previously, if a source file in a PCL-based package contained what looks
-;;; like flavor defmethod forms (i.e. an (IN-PACKAGE 'non-pcl-package) form
-;;; appears at top level, and then a flavor-style defmethod form) appear, the
-;;; parser would break.
-;;;
-;;; Now, if we can't parse the defmethod form, we send it to the flavor
-;;; defmethod parser instead.
-;;; 
-;;; Also now supports multi-line arglist sectionizing.
-;;;
-zwei:
-(defun parse-pcl-defmethod-for-zwei (bp-after-defmethod setfp)
-  (block parser
-    (flet ((barf (&optional (error t))
-	     (return-from parser
-	       (cond ((eq error :flavor)
-		      (funcall (get 'flavor:defmethod
-				    'zwei::definition-function-spec-parser)
-			       bp-after-defmethod))
-		     (t
-		      (values nil nil nil error))))))
-      (let ((bp-after-generic (forward-sexp bp-after-defmethod))
-	    (qualifiers ())
-	    (specializers ())
-	    (spec nil)
-	    (ignore1 nil)
-	    (ignore2 nil))
-	(when bp-after-generic
-	  (multiple-value-bind (generic error-p)
-	      (read-fspec-item-from-interval bp-after-defmethod
-					     bp-after-generic)
-	    (if error-p
-		(barf)				; error here is really bad.... BARF!
-		(progn
-		  (when (listp generic)
-		    (if (and (symbolp (car generic))
-			     (string-equal (cl:symbol-name (car generic)) "SETF"))
-			(setq generic (second generic)	; is a (setf xxx) form
-			      setfp t)
-			(barf :flavor)))	; make a last-ditch-effort with flavor parser
-		  (let* ((bp1 bp-after-generic)
-			 (bp2 (forward-sexp bp1)))
-		      (cl:loop
-			 (if (null bp2)
-			     (barf :more)	; item not closed - need another line!
-			     (multiple-value-bind (item error-p)
-				 (read-fspec-item-from-interval bp1 bp2)
-			       (cond (error-p (barf))	;
-				     ((listp item)
-				      (setq qualifiers (nreverse qualifiers))
-				      (cl:multiple-value-setq (ignore1
-								ignore2
-								specializers)
-					(pcl::parse-specialized-lambda-list item))
-				      (setq spec (pcl::make-method-spec 
-						   (if setfp
-						       `(cl:setf ,generic)
-						       generic)
-						   qualifiers
-						   specializers))
-				      (return (values spec
-						      'defun
-						      (string-interval
-							bp-after-defmethod
-							bp2))))
-				     (t (push item qualifiers)
-					(setq bp1 bp2
-					      bp2 (forward-sexp bp2))))))))))))))))
-
-zwei:
-(progn
-  (defun indent-clos-defmethod (ignore bp defmethod-paren &rest ignore)
-    (let ((here
-	    (forward-over *whitespace-chars* (forward-word defmethod-paren))))
-      (loop until (char-equal (bp-char here) #\()
-	    do (setf here
-		     (forward-over *whitespace-chars* (forward-sexp here))))
-      (if (bp-< here bp)
-	  (values defmethod-paren nil 2)
-	  (values defmethod-paren nil 4))))
-  
-  (defindentation (pcl::defmethod . indent-clos-defmethod)))
-
-;;;
-;;; Teach zwei that when it gets the name of a generic function as an argument
-;;; it should edit all the methods of that generic function.  This works for
-;;; ED as well as meta-point.
-;;;
-(zl:advise (flavor:method :SETUP-FUNCTION-SPECS-TO-EDIT zwei:ZMACS-EDITOR)
-	   :around
-	   setup-function-specs-to-edit-advice
-	   ()
-  (let ((old-definitions (cadddr arglist))
-	(new-definitions ())
-	(new nil))
-    (dolist (old old-definitions)
-      (setq new (setup-function-specs-to-edit-advice-1 old))
-      (push (or new (list old)) new-definitions))
-    (setf (cadddr arglist) (apply #'append (reverse new-definitions)))
-    :do-it))
-
-(defun setup-function-specs-to-edit-advice-1 (spec)
-  (and (or (symbolp spec)
-	   (and (listp spec) (eq (car spec) 'setf)))
-       (gboundp spec)
-       (generic-function-p (gdefinition spec))
-       (mapcar #'(lambda (m)
-		   (make-method-spec spec
-				     (method-qualifiers m)
-				     (unparse-specializers
-				       (method-specializers m))))
-	       (generic-function-methods (gdefinition spec)))))
-
-
diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp
deleted file mode 100644
index 00d71d767c3516c2590c5361f398f865afa5f633..0000000000000000000000000000000000000000
--- a/pcl/generic-functions.lisp
+++ /dev/null
@@ -1,779 +0,0 @@
-;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
-
-(in-package :pcl)
-
-;;; class predicates
-(defgeneric class-eq-specializer-p (object))
-;          (t)
-;          (class-eq-specializer)
-
-(defgeneric classp (object))
-;          (t)
-;          (class)
-
-(defgeneric eql-specializer-p (object))
-;          (t)
-;          (eql-specializer)
-
-(defgeneric exact-class-specializer-p (object))
-;          (t)
-;          (exact-class-specializer)
-
-(defgeneric forward-referenced-class-p (object))
-;          (t)
-;          (forward-referenced-class)
-
-(defgeneric funcallable-standard-class-p (object))
-;          (t)
-;          (funcallable-standard-class)
-
-(defgeneric generic-function-p (object))
-;          (t)
-;          (generic-function)
-
-(defgeneric legal-lambda-list-p (object x))
-;          (standard-method t)
-
-(defgeneric method-combination-p (object))
-;          (t)
-;          (method-combination)
-
-(defgeneric method-p (object))
-;          (t)
-;          (method)
-
-(defgeneric short-method-combination-p (object))
-;          (short-method-combination)
-;          (t)
-
-(defgeneric slot-class-p (object))
-;          (t)
-;          (slot-class)
-
-(defgeneric specializerp (object))
-;          (t)
-;          (specializer)
-
-(defgeneric standard-accessor-method-p (object))
-;          (t)
-;          (standard-accessor-method)
-
-(defgeneric standard-boundp-method-p (object))
-;          (t)
-;          (standard-boundp-method)
-
-(defgeneric standard-class-p (object))
-;          (t)
-;          (standard-class)
-
-(defgeneric standard-generic-function-p (object))
-;          (t)
-;          (standard-generic-function)
-
-(defgeneric standard-method-p (object))
-;          (t)
-;          (standard-method)
-
-(defgeneric standard-reader-method-p (object))
-;          (t)
-;          (standard-reader-method)
-
-(defgeneric standard-writer-method-p (object))
-;          (t)
-;          (standard-writer-method)
-
-(defgeneric structure-class-p (object))
-;          (t)
-;          (structure-class)
-
-
-;;; readers
-(defgeneric accessor-method-slot-definition (standard-accessor-method))
-;          (standard-accessor-method)
-
-(defgeneric class-can-precede-list (pcl-class))
-;          (pcl-class)
-
-(defgeneric class-defstruct-constructor (structure-class))
-;          (structure-class)
-
-(defgeneric class-defstruct-form (structure-class))
-;          (structure-class)
-
-(defgeneric class-direct-subclasses (class))
-;          (class)
-
-(defgeneric class-direct-superclasses (class))
-;          (class)
-
-(defgeneric class-eq-specializer (class))
-;          (class)
-
-(defgeneric class-incompatible-superclass-list (pcl-class))
-;          (pcl-class)
-
-(defgeneric class-initialize-info (slot-class))
-;          (slot-class)
-
-(defgeneric class-name (class))
-;          (class)
-
-(defgeneric class-precedence-list (pcl-class))
-;          (pcl-class)
-
-(defgeneric class-predicate-name (class))
-;          (class)
-
-(defgeneric class-wrapper (pcl-class))
-;          (pcl-class)
-
-(defgeneric definition-source (definition-source-mixin))
-;          (definition-source-mixin)
-
-(defgeneric eql-specializer-object (eql-specializer))
-;          (eql-specializer)
-
-(defgeneric generic-function-method-class (standard-generic-function))
-;          (standard-generic-function)
-
-(defgeneric generic-function-method-combination (standard-generic-function))
-;          (standard-generic-function)
-
-(defgeneric generic-function-methods (standard-generic-function))
-;          (standard-generic-function)
-
-(defgeneric generic-function-name (standard-generic-function))
-;          (standard-generic-function)
-
-(defgeneric gf-arg-info (standard-generic-function))
-;          (standard-generic-function)
-
-(defgeneric gf-dfun-state (standard-generic-function))
-;          (standard-generic-function)
-
-(defgeneric gf-pretty-arglist (standard-generic-function))
-;          (standard-generic-function)
-
-(defgeneric long-method-combination-function (long-method-combination))
-;          (long-method-combination)
-
-(defgeneric method-combination-documentation (standard-method-combination))
-;          (standard-method-combination)
-
-(defgeneric method-combination-options (standard-method-combination))
-;          (standard-method-combination)
-
-(defgeneric method-combination-type (standard-method-combination))
-;          (standard-method-combination)
-
-(defgeneric method-fast-function (standard-method))
-;          (standard-method)
-
-(defgeneric method-generic-function (standard-method))
-;          (traced-method)
-;          (standard-method)
-
-(defgeneric object-plist (plist-mixin))
-;          (plist-mixin)
-
-(defgeneric short-combination-identity-with-one-argument (short-method-combination))
-;          (short-method-combination)
-
-(defgeneric short-combination-operator (short-method-combination))
-;          (short-method-combination)
-
-(defgeneric slot-definition-boundp-function (effective-slot-definition))
-;          (effective-slot-definition)
-
-(defgeneric slot-definition-class (slot-definition))
-;          (slot-definition)
-
-(defgeneric slot-definition-defstruct-accessor-symbol (structure-slot-definition))
-;          (structure-slot-definition)
-
-(defgeneric slot-definition-initargs (slot-definition))
-;          (slot-definition)
-
-(defgeneric slot-definition-initform (slot-definition))
-;          (slot-definition)
-
-(defgeneric slot-definition-initfunction (slot-definition))
-;          (slot-definition)
-
-(defgeneric slot-definition-internal-reader-function (structure-slot-definition))
-;          (structure-slot-definition)
-
-(defgeneric slot-definition-internal-writer-function (structure-slot-definition))
-;          (structure-slot-definition)
-
-(defgeneric slot-definition-location (standard-effective-slot-definition))
-;          (standard-effective-slot-definition)
-
-(defgeneric slot-definition-name (slot-definition))
-;          (slot-definition)
-
-(defgeneric slot-definition-reader-function (effective-slot-definition))
-;          (effective-slot-definition)
-
-(defgeneric slot-definition-readers (slot-definition))
-;          (slot-definition)
-
-(defgeneric slot-definition-type (slot-definition))
-;          (slot-definition)
-
-(defgeneric slot-definition-writer-function (effective-slot-definition))
-;          (effective-slot-definition)
-
-(defgeneric slot-definition-writers (slot-definition))
-;          (slot-definition)
-
-(defgeneric specializer-object (class-eq-specializer))
-;          (eql-specializer)
-;          (class-prototype-specializer)
-;          (class-eq-specializer)
-
-(defgeneric specializer-type (specializer))
-;          (specializer)
-
-
-;;; writers
-(defgeneric (setf class-defstruct-constructor) (new-value structure-class))
-;          (t structure-class)
-
-(defgeneric (setf class-defstruct-form) (new-value structure-class))
-;          (t structure-class)
-
-(defgeneric (setf class-direct-slots) (new-value slot-class))
-;          (t slot-class)
-
-(defgeneric (setf class-incompatible-superclass-list) (new-value pcl-class))
-;          (t pcl-class)
-
-(defgeneric (setf class-initialize-info) (new-value slot-class))
-;          (t slot-class)
-
-(defgeneric (setf class-name) (new-value class))
-;          (t class)
-
-(defgeneric (setf class-slots) (new-value slot-class))
-;          (t slot-class)
-
-(defgeneric (setf generic-function-method-class) (new-value standard-generic-function))
-;          (t standard-generic-function)
-
-(defgeneric (setf generic-function-method-combination) (new-value standard-generic-function))
-;          (t standard-generic-function)
-
-(defgeneric (setf generic-function-methods) (new-value standard-generic-function))
-;          (t standard-generic-function)
-
-(defgeneric (setf generic-function-name) (new-value standard-generic-function))
-;          (t standard-generic-function)
-
-(defgeneric (setf gf-dfun-state) (new-value standard-generic-function))
-;          (t standard-generic-function)
-
-(defgeneric (setf gf-pretty-arglist) (new-value standard-generic-function))
-;          (t standard-generic-function)
-
-(defgeneric (setf method-generic-function) (new-value standard-method))
-;          (t traced-method)
-;          (t standard-method)
-
-(defgeneric (setf object-plist) (new-value plist-mixin))
-;          (t plist-mixin)
-
-(defgeneric (setf slot-definition-allocation) (new-value standard-slot-definition))
-;          (t standard-slot-definition)
-
-(defgeneric (setf slot-definition-boundp-function) (new-value effective-slot-definition))
-;          (t effective-slot-definition)
-
-(defgeneric (setf slot-definition-class) (new-value slot-definition))
-;          (t slot-definition)
-
-(defgeneric (setf slot-definition-defstruct-accessor-symbol) (new-value structure-slot-definition))
-;          (t structure-slot-definition)
-
-(defgeneric (setf slot-definition-initargs) (new-value slot-definition))
-;          (t slot-definition)
-
-(defgeneric (setf slot-definition-initform) (new-value slot-definition))
-;          (t slot-definition)
-
-(defgeneric (setf slot-definition-initfunction) (new-value slot-definition))
-;          (t slot-definition)
-
-(defgeneric (setf slot-definition-internal-reader-function) (new-value structure-slot-definition))
-;          (t structure-slot-definition)
-
-(defgeneric (setf slot-definition-internal-writer-function) (new-value structure-slot-definition))
-;          (t structure-slot-definition)
-
-(defgeneric (setf slot-definition-location) (new-value standard-effective-slot-definition))
-;          (t standard-effective-slot-definition)
-
-(defgeneric (setf slot-definition-name) (new-value slot-definition))
-;          (t slot-definition)
-
-(defgeneric (setf slot-definition-reader-function) (new-value effective-slot-definition))
-;          (t effective-slot-definition)
-
-(defgeneric (setf slot-definition-readers) (new-value slot-definition))
-;          (t slot-definition)
-
-(defgeneric (setf slot-definition-type) (new-value slot-definition))
-;          (t slot-definition)
-
-(defgeneric (setf slot-definition-writer-function) (new-value effective-slot-definition))
-;          (t effective-slot-definition)
-
-(defgeneric (setf slot-definition-writers) (new-value slot-definition))
-;          (t slot-definition)
-
-
-;;; 1 argument 
-(defgeneric accessor-method-class (method))
-;          (standard-accessor-method)
-;          (standard-writer-method)
-
-(defgeneric accessor-method-slot-name (m))
-;          (traced-method)
-;          (standard-accessor-method)
-
-(defgeneric class-constructors (class))
-;          (slot-class)
-
-(defgeneric class-default-initargs (class))
-;          (slot-class)
-;          (built-in-class)
-
-(defgeneric class-direct-default-initargs (class))
-;          (slot-class)
-;          (built-in-class)
-
-(defgeneric class-direct-slots (class))
-;          (slot-class)
-;          (built-in-class)
-
-(defgeneric class-finalized-p (class))
-;          (pcl-class)
-
-(defgeneric class-prototype (class))
-;          (pcl-class)
-;          (std-class)
-;          (structure-class)
-
-(defgeneric class-slot-cells (class))
-;          (std-class)
-
-(defgeneric class-slots (class))
-;          (slot-class)
-;          (built-in-class)
-
-(defgeneric compute-class-precedence-list (root))
-;          (slot-class)
-
-(defgeneric compute-default-initargs (class))
-;          (slot-class)
-
-(defgeneric compute-discriminating-function (gf))
-;          (standard-generic-function)
-
-(defgeneric compute-discriminating-function-arglist-info (generic-function))
-;          (standard-generic-function)
-
-(defgeneric compute-slots (class))
-;          (std-class)
-;  :around (std-class)
-;          (structure-class)
-;  :around (structure-class)
-
-(defgeneric finalize-inheritance (class))
-;          (structure-class)
-;          (std-class)
-
-(defgeneric function-keywords (method))
-;          (standard-method)
-
-(defgeneric generic-function-lambda-list (gf))
-;          (generic-function)
-
-(defgeneric generic-function-pretty-arglist (generic-function))
-;          (standard-generic-function)
-
-(defgeneric gf-fast-method-function-p (gf))
-;          (standard-generic-function)
-
-(defgeneric initialize-internal-slot-functions (slotd))
-;          (effective-slot-definition)
-
-(defgeneric make-instances-obsolete (class))
-;          (std-class)
-;          (symbol)
-
-(defgeneric method-function (method))
-;          (traced-method)
-;          (standard-method)
-
-(defgeneric method-lambda-list (m))
-;          (traced-method)
-;          (standard-method)
-
-(defgeneric method-pretty-arglist (method))
-;          (standard-method)
-
-(defgeneric method-qualifiers (m))
-;          (traced-method)
-;          (standard-method)
-
-(defgeneric method-specializers (m))
-;          (traced-method)
-;          (standard-method)
-
-(defgeneric raw-instance-allocator (class))
-;          (standard-class)
-;          (funcallable-standard-class)
-
-(defgeneric slot-definition-allocation (slotd))
-;          (standard-slot-definition)
-;          (structure-slot-definition)
-
-(defgeneric slots-fetcher (class))
-;          (standard-class)
-;          (funcallable-standard-class)
-
-(defgeneric specializer-class (specializer))
-;          (class-prototype-specializer)
-;          (class-eq-specializer)
-;          (class)
-;          (eql-specializer)
-
-(defgeneric specializer-direct-generic-functions (specializer))
-;          (class)
-;          (specializer-with-object)
-
-(defgeneric specializer-direct-methods (specializer))
-;          (class)
-;          (specializer-with-object)
-
-(defgeneric specializer-method-table (specializer))
-;          (eql-specializer)
-;          (class-eq-specializer)
-
-(defgeneric update-constructors (class))
-;          (slot-class)
-;          (class)
-
-(defgeneric wrapper-fetcher (class))
-;          (standard-class)
-;          (funcallable-standard-class)
-
-
-;;; 2 arguments 
-(defgeneric add-dependent (metaobject dependent))
-;          (dependent-update-mixin t)
-
-(defgeneric add-direct-method (specializer method))
-;          (class method)
-;          (specializer-with-object method)
-
-(defgeneric add-direct-subclass (class subclass))
-;          (class class)
-
-(defgeneric add-method (generic-function method))
-;          (standard-generic-function method)
-
-(defgeneric change-class (instance new-class-name))
-;          (standard-object standard-class)
-;          (standard-object funcallable-standard-class)
-;          (t symbol)
-
-(defgeneric class-slot-value (class slot-name))
-;          (std-class t)
-
-(defgeneric compatible-meta-class-change-p (class proto-new-class))
-;          (t t)
-
-(defgeneric compute-applicable-methods (generic-function arguments))
-;          (generic-function t)
-
-(defgeneric compute-applicable-methods-using-classes (generic-function classes))
-;          (generic-function t)
-
-(defgeneric compute-effective-slot-definition (class dslotds))
-;          (slot-class t)
-
-(defgeneric compute-effective-slot-definition-initargs (class direct-slotds))
-;          (slot-class t)
-;  :around (structure-class t)
-
-(defgeneric default-initargs (class supplied-initargs))
-;          (slot-class t)
-
-(defgeneric describe-object (object stream))
-;          (class t)
-;          (standard-generic-function t)
-;          (slot-object t)
-;          (t t)
-
-(defgeneric direct-slot-definition-class (class initargs))
-;          (structure-class t)
-;          (std-class t)
-
-(defgeneric effective-slot-definition-class (class initargs))
-;          (std-class t)
-;          (structure-class t)
-
-(defgeneric inform-type-system-about-class (class name))
-;          (std-class t)
-;          (structure-class t)
-
-(defgeneric legal-documentation-p (object x))
-;          (standard-method t)
-
-(defgeneric legal-method-function-p (object x))
-;          (standard-method t)
-
-(defgeneric legal-qualifier-p (object x))
-;          (standard-method t)
-
-(defgeneric legal-qualifiers-p (object x))
-;          (standard-method t)
-
-(defgeneric legal-slot-name-p (object x))
-;          (standard-method t)
-
-(defgeneric legal-specializer-p (object x))
-;          (standard-method t)
-
-(defgeneric legal-specializers-p (object x))
-;          (standard-method t)
-
-(defgeneric make-boundp-method-function (class slot-name))
-;          (slot-class t)
-
-(defgeneric make-reader-method-function (class slot-name))
-;          (slot-class t)
-;          (funcallable-standard-class t)
-
-(defgeneric make-writer-method-function (class slot-name))
-;          (slot-class t)
-;          (funcallable-standard-class t)
-
-(defgeneric map-dependents (metaobject function))
-;          (dependent-update-mixin t)
-
-;(defgeneric maybe-update-constructors (generic-function method))
-;           (generic-function method)
-
-(defgeneric print-object (mc stream))
-;          (t t)
-;          (class t)
-;          (slot-definition t)
-;          (standard-method t)
-;          (standard-accessor-method t)
-;          (generic-function t)
-;          (standard-method-combination t)
-
-(defgeneric remove-boundp-method (class generic-function))
-;          (slot-class t)
-
-(defgeneric remove-dependent (metaobject dependent))
-;          (dependent-update-mixin t)
-
-(defgeneric remove-direct-method (specializer method))
-;          (class method)
-;          (specializer-with-object method)
-
-(defgeneric remove-direct-subclass (class subclass))
-;          (class class)
-
-(defgeneric remove-method (generic-function method))
-;          (standard-generic-function method)
-
-(defgeneric remove-reader-method (class generic-function))
-;          (slot-class t)
-
-(defgeneric remove-writer-method (class generic-function))
-;          (slot-class t)
-
-(defgeneric same-specializer-p (specl1 specl2))
-;          (specializer specializer)
-;          (class class)
-;          (class-eq-specializer class-eq-specializer)
-;          (eql-specializer eql-specializer)
-
-(defgeneric slot-accessor-function (slotd type))
-;          (effective-slot-definition t)
-
-(defgeneric slot-accessor-std-p (slotd type))
-;          (effective-slot-definition t)
-
-(defgeneric slots-to-inspect (class object))
-;          (slot-class slot-object)
-
-(defgeneric update-gf-dfun (class gf))
-;          (std-class t)
-
-(defgeneric validate-superclass (fsc class))
-;          (class class)
-;          (class built-in-class)
-;          (slot-class forward-referenced-class)
-;          (funcallable-standard-class standard-class)
-
-
-;;; 3 arguments 
-(defgeneric add-boundp-method (class generic-function slot-name))
-;          (slot-class t t)
-
-(defgeneric add-reader-method (class generic-function slot-name))
-;          (slot-class t t)
-
-(defgeneric add-writer-method (class generic-function slot-name))
-;          (slot-class t t)
-
-(defgeneric (setf class-slot-value) (nv class slot-name))
-;          (t std-class t)
-
-(defgeneric compute-effective-method (generic-function combin applicable-methods))
-;          (generic-function long-method-combination t)
-;          (generic-function short-method-combination t)
-;          (generic-function standard-method-combination t)
-
-(defgeneric compute-slot-accessor-info (slotd type gf))
-;          (effective-slot-definition t t)
-
-(defgeneric find-method-combination (generic-function type options))
-;          (generic-function (eql progn) t)
-;          (generic-function (eql or) t)
-;          (generic-function (eql nconc) t)
-;          (generic-function (eql min) t)
-;          (generic-function (eql max) t)
-;          (generic-function (eql list) t)
-;          (generic-function (eql append) t)
-;          (generic-function (eql and) t)
-;          (generic-function (eql +) t)
-;          (generic-function (eql standard) t)
-
-(defgeneric (setf slot-accessor-function) (function slotd type))
-;          (t effective-slot-definition t)
-
-(defgeneric (setf slot-accessor-std-p) (value slotd type))
-;          (t effective-slot-definition t)
-
-(defgeneric slot-boundp-using-class (class object slotd))
-;          (std-class standard-object standard-effective-slot-definition)
-;          (structure-class structure-object structure-effective-slot-definition)
-
-(defgeneric slot-makunbound-using-class (class object slotd))
-;          (std-class standard-object standard-effective-slot-definition)
-;          (structure-class structure-object structure-effective-slot-definition)
-
-(defgeneric slot-unbound (class instance slot-name))
-;          (t t t)
-
-(defgeneric slot-value-using-class (class object slotd))
-;          (std-class standard-object standard-effective-slot-definition)
-;          (structure-class structure-object structure-effective-slot-definition)
-
-
-;;; 4 arguments 
-(defgeneric make-method-lambda (proto-generic-function proto-method lambda-expression environment))
-;          (standard-generic-function standard-method t t)
-
-(defgeneric (setf slot-value-using-class) (new-value class object slotd))
-;          (t std-class standard-object standard-effective-slot-definition)
-;          (t structure-class structure-object structure-effective-slot-definition)
-
-
-;;; 5 arguments 
-(defgeneric make-method-initargs-form (proto-generic-function proto-method lambda-expression lambda-list environment))
-;          (standard-generic-function standard-method t t t)
-
-
-;;; optional arguments  
-(defgeneric (setf documentation) (new-value slotd &optional doc-type))
-;          (t t)
-;          (t documentation-mixin)
-;          (t standard-slot-definition)
-
-(defgeneric documentation (slotd &optional doc-type))
-;          (t)
-;          (documentation-mixin)
-;          (standard-slot-definition)
-
-(defgeneric get-method (generic-function qualifiers specializers &optional (errorp t)))
-;          (standard-generic-function t t)
-
-(defgeneric remove-named-method (generic-function-name argument-specifiers &optional extra))
-;          (t t)
-
-(defgeneric slot-missing (class instance slot-name operation &optional new-value))
-;          (t t t t)
-
-
-;;; keyword arguments  
-(defgeneric allocate-instance (class &rest initargs))
-;          (standard-class)
-;          (structure-class)
-;          (funcallable-standard-class)
-
-(defgeneric ensure-class-using-class (name class &rest args &key &allow-other-keys))
-;          (t null)
-;          (t pcl-class)
-
-(defgeneric ensure-generic-function-using-class (generic-function function-specifier &key &allow-other-keys))
-;          (null t)
-;          (generic-function t)
-
-(defgeneric initialize-instance (gf &key &allow-other-keys))
-;          (slot-object)
-;  :after  (standard-generic-function)
-
-(defgeneric make-instance (class &rest initargs))
-;          (symbol)
-;          (class)
-
-(defgeneric no-applicable-method (generic-function &rest args))
-;          (t)
-
-(defgeneric reader-method-class (class direct-slot &rest initargs))
-;          (slot-class t)
-
-(defgeneric reinitialize-instance (gf &rest args &key &allow-other-keys))
-;          (slot-object)
-;  :before (slot-class)
-;  :after  (slot-class)
-;          (standard-method)
-;  :after  (standard-generic-function)
-
-(defgeneric shared-initialize (generic-function slot-names &key &allow-other-keys))
-;          (slot-object t)
-;  :after  (documentation-mixin t)
-;  :after  (class-eq-specializer t)
-;  :after  (eql-specializer t)
-;  :after  (std-class t)
-;  :before (class t)
-;  :after  (structure-class t)
-;  :before (built-in-class t)
-;  :after  (standard-slot-definition t)
-;  :after  (structure-slot-definition t)
-;  :before (standard-method t)
-;  :before (standard-accessor-method t)
-;  :after  (standard-method t)
-;  :after  (standard-accessor-method t)
-;  :before (standard-generic-function t)
-
-(defgeneric update-dependent (metaobject dependent &rest initargs))
-
-(defgeneric update-instance-for-different-class (previous current &rest initargs))
-;          (standard-object standard-object)
-
-(defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs))
-;          (standard-object t t t)
-
-(defgeneric writer-method-class (class direct-slot &rest initargs))
-;          (slot-class t)
-
-
diff --git a/pcl/get-pcl.text b/pcl/get-pcl.text
deleted file mode 100644
index e743744db43702338ff6b5b397ba7da9765b985c..0000000000000000000000000000000000000000
--- a/pcl/get-pcl.text
+++ /dev/null
@@ -1,180 +0,0 @@
-Here is the standard information about PCL.  I have also added you to
-the CommonLoops@Xerox.com mailing list.
-
-Portable CommonLoops (PCL) started out as an implementation of
-CommonLoops written entirely in CommonLisp.  It is in the process of
-being converted to an implementation of CLOS.  Currently it implements a
-only a subset of the CLOS specification.  Unfortunately, there is no
-detailed description of the differences between PCL and the CLOS
-specification, the source code is often the best documentation.
-
-  Currently, PCL runs in the following implementations of
-  Common Lisp:
-
-   EnvOS Medley
-   Symbolics (Release 7.2)
-   Lucid (3.0)
-   ExCL (Franz Allegro 3.0.1)
-   KCL (June 3, 1987)
-   AKCL (1.86, June 30, 1987)
-   Ibuki Common Lisp (01/01, October 15, 1987)
-   TI (Release 4.1)
-   Coral Common Lisp (Allegro 1.2)
-   Golden Common Lisp (3.1)
-   CMU
-   VAXLisp (2.0)
-   HP Common Lisp
-   Pyramid Lisp
-
-There are several ways of obtaining a copy of PCL.
-
-*** Arpanet Access to PCL ***
-
-The primary way of getting PCL is by Arpanet FTP.
-
-The files are stored on arisia.xerox.com.  You can copy them using
-anonymous FTP (username "anonymous", password "anonymous"). There are
-several directories which are of interest:
-
-/pcl
-
-This directory contains the PCL sources as well as some rudimentary
-documentation (including this file).  All of these files are combined
-into a single Unix TAR file.  The name of this file is "tarfile".
-
-Extract the individual files from this tarfile by saying:
-
-tar -xf tarfile *
-
-where `tarfile' is the name you have given the tarfile in your
-directory.  Once you have done this, the following files are of special
-interest:
-
-readme.text   READ IT
-
-notes.text    contains notes about the current state of PCL, and some
-              instructions for installing PCL at your site.  You should
-              read this file whenever you get a new version of PCL.
-
-get-pcl.text  contains the latest draft of this message
-
-
-/pcl/doc
-
-This directory contains TeX source files for the most recent draft of
-the CLOS specification.  There are TeX source files for two documents
-called concep.tex and functi.tex.  These correspond to chapter 1 and 2
-of the CLOS specification.
-
-
-/pcl/archive
-
-This directory contains the joint archives of two important mailings
-lists:
-
-  CommonLoops@Xerox.com
-
-    is the mailing list for all PCL users.  It carries announcements
-    of new releases of PCL, bug reports and fixes, and general advice
-    about how to use PCL and CLOS.
-
-  Common-Lisp-Object-System@Sail.Stanford.edu
-
-    is a small mailing list used by the designers of CLOS.
-
-The file cloops.text is always the newest of the archive files.
-
-The file cloops1.text is the oldest of the archive files.  Higher
-numbered versions are more recent versions of the files.
-
-*** Getting PCL on Macintosh floppies *** 
-
-PCL is listed in APDAlog.  It is distributed on Macintosh floppies.
-This makes it possible for people who don't have FTP access to arisia
-(but who do have a Macintosh) to get PCL.
-
-For $40 you receive a version of PCL and a copy of the CLOS spec (X3J13
-document number 88-002R).  The APDAlog catalog number is T0259LL/A and
-you can order by calling:
-
-  From the U.S.   (800)282-2732
-  From Canada     (800)637-0029
-  International   (408)562-3910
-  FAX             (408)562-3971
-
-
-NOTE:  Whenever there is a new release of PCL you want, you should
-probably wait a couple of months before ordering it from APDAlog.  We
-want to let new PCL's stabilize a bit before sending it to them, and it
-will take them some time to integrate the new disks into their
-distribution.
-
-*** Using the BITFTP server at Princeton ***
-
-For people who can't FTP from Internet (Arpanet) hosts, but who have
-mail access to the BITNET, there exists a way to get the PCL files using
-the BITFTP service provided by Princeton Univerity.  If you know exactly
-where to find the files that interest you, this is quite easy.  In
-particular, you have to know:
-
- * the Internet host name of the host that maintains the files (such
-   as `arisia.Xerox.COM')
- * the directory where to find the files, relative to the root of the
-   FTP tree (i.E. `pub')
- * whether the files are binary or ASCII text.
- * the names of the files (say `pcl90.tar.Z' and `pcl90.README')
-
-To do this, send a message to BITFTP@PUCC (or BITFTP@PUCC.BITNET if you
-aren't on BITNET itself).  The subject line of the message will be
-ignored.  The text (body) of the message should be:
-
-        FTP arisia.xerox.com UUENCODE
-        CD pcl
-        BINARY
-        GET tarfile
-        QUIT
-
-Then you wait (probably for about a day when you are in Europe) and
-eventually you will receive E-Mail messages from BITFTP@PUCC (or
-BITFTP2%PUCC...) with subject lines like `uudecoded file tarfile part
-13'.  Then you have to carefully concatenate the contents of ALL of
-these files in the correct order.
-
-  Note: The following works on our Suns and should work on any
-  Berkeley UNIX machine.  If you don't have the `compress' or `zcat'
-  program, you can get a free version (with MIT's X Window System
-  distribution, for example).
-
-The resulting file can be `uudecode'd like this:
-
-        dagobert% uudecode name-of-the-assembled-file
-
-This will give you a file tarfile.Z (it may actually have a different
-name; then you may want to rename it in the first place).  The `.Z' at
-the end means that the file you now have is compressed.  You can
-uncompress it with `uncompress tarfile.  You can untar the uncompressed
-file with `tar -xvf tarfile'.
-
-This will write all files in the tarfile to the current directory.
-
-If you want to know more about the BITFTP service, send a letter to
-`BITFTP@PUCC' that contains the single line `HELP'.
-
-*** Xerox Internet Access to PCL ***
-
-Xerox XNS users can get PCL from {NB:PARC:XEROX}<PCL>
-
-
-
-Send any comments, bug-reports or suggestions for improvements to:
-
-   CommonLoops.pa@Xerox.com
-
-Send mailing list requests or other administrative stuff to:
-
-  CommonLoops-Request@Xerox.com
-
-
-Thanks for your interest in PCL.
-----------
-
diff --git a/pcl/gold-low.lisp b/pcl/gold-low.lisp
deleted file mode 100644
index ee47b6f21fc8f3059adec6c6cf8c10e6fefa2bb6..0000000000000000000000000000000000000000
--- a/pcl/gold-low.lisp
+++ /dev/null
@@ -1,51 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;;
-;;; 
-
-(in-package 'pcl)
-
-;;; fix a bug in gcl macro-expander (or->cond->or->cond->...)
-(setf (get 'cond 'lisp::macro-expander) nil)
-
-;;; fix another bug in gcl3_0 case macro-expander
-(defun lisp::eqv (a b) (eql a b))
-
-(defun printing-random-thing-internal (thing stream)
-  (multiple-value-bind (offaddr baseaddr)
-      (sys:%pointer thing)
-    (princ baseaddr stream)
-    (princ ", " stream)
-    (princ offaddr stream)))
-
-;;;
-;;; This allows the compiler to compile a file with many "DEFMETHODS"
-;;; in succession.
-;;;
-(dolist (x '(defmethod defgeneric defclass precompile-random-code-segments))
-  (setf (get x 'gcl::compile-separately) t))
-
diff --git a/pcl/hp-low.lisp b/pcl/hp-low.lisp
deleted file mode 100644
index d1e807f6841e0cbbbc1a5788bcd3441462b3b910..0000000000000000000000000000000000000000
--- a/pcl/hp-low.lisp
+++ /dev/null
@@ -1,37 +0,0 @@
-;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;; 
-;;; This is the HP Common Lisp version of the file low.
-;;;
-;;; 
-
-(in-package 'pcl)
-
-(defun printing-random-thing-internal (thing stream)
-  (format stream "~O" (prim:@inf thing)))
-
-
-
diff --git a/pcl/ibcl-low.lisp b/pcl/ibcl-low.lisp
deleted file mode 100644
index 2ab3f77ba429c92be8f442e00e294515553b177a..0000000000000000000000000000000000000000
--- a/pcl/ibcl-low.lisp
+++ /dev/null
@@ -1,327 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; The version of low for Kyoto Common Lisp (KCL)
-(in-package 'pcl)
-
-;;;
-;;; The reason these are here is because the KCL compiler does not allow
-;;; LET to return FIXNUM values as values of (c) type int, hence the use
-;;; of LOCALLY (which expands into (LET () (DECLARE ...) ...)) forces
-;;; conversion of ints to objects.
-;;; 
-(defmacro %logand (&rest args)
-  (reduce-variadic-to-binary 'logand args 0 t 'fixnum))
-
-;(defmacro %logxor (&rest args)
-;  (reduce-variadic-to-binary 'logxor args 0 t 'fixnum))
-
-(defmacro %+ (&rest args)
-  (reduce-variadic-to-binary '+ args 0 t 'fixnum))
-
-;(defmacro %- (x y)
-;  `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))
-
-(defmacro %* (&rest args)
-  (reduce-variadic-to-binary '* args 1 t 'fixnum))
-
-(defmacro %/ (x y)
-  `(the fixnum (/ (the fixnum ,x) (the fixnum ,y))))
-
-(defmacro %1+ (x)
-  `(the fixnum (1+ (the fixnum ,x))))
-
-(defmacro %1- (x)
-  `(the fixnum (1- (the fixnum ,x))))
-
-(defmacro %svref (vector index)
-  `(svref (the simple-vector ,vector) (the fixnum ,index)))
-
-(defsetf %svref (vector index) (new-value)
-  `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
-         ,new-value))
-
-
-;;;
-;;; std-instance-p
-;;;
-(si:define-compiler-macro std-instance-p (x)
-  (once-only (x)
-    `(and (si:structurep ,x)
-	  (eq (si:structure-name ,x) 'std-instance))))
-
-(dolist (inline '((si:structurep
-		    ((t) compiler::boolean nil nil "type_of(#0)==t_structure")
-		    compiler::inline-always)
-		  (si:structure-name
-		    ((t) t nil nil "(#0)->str.str_name")
-		    compiler::inline-unsafe)))
-  (setf (get (first inline) (third inline)) (list (second inline))))
-
-(setf (get 'cclosure-env 'compiler::inline-always)
-      (list '((t) t nil nil "(#0)->cc.cc_env")))
-
-;;;
-;;; turbo-closure patch.  See the file kcl-mods.text for details.
-;;;
-#+:turbo-closure
-(progn
-(CLines
-  "object tc_cc_env_nthcdr (n,tc)"
-  "object n,tc;                        "
-  "{return (type_of(tc)==t_cclosure&&  "
-  "         tc->cc.cc_turbo!=NULL&&    "
-  "         type_of(n)==t_fixnum)?     "
-  "         tc->cc.cc_turbo[fix(n)]:   " ; assume that n is in bounds
-  "         Cnil;                      "
-  "}                                   "
-  )
-
-(defentry tc-cclosure-env-nthcdr (object object) (object tc_cc_env_nthcdr))
-
-(setf (get 'tc-cclosure-env-nthcdr 'compiler::inline-unsafe)
-      '(((fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")))
-)
-
-
-;;;; low level stuff to hack compiled functions and compiled closures.
-;;;
-;;; The primary client for this is fsc-low, but since we make some use of
-;;; it here (e.g. to implement set-function-name-1) it all appears here.
-;;;
-
-(eval-when (compile eval)
-
-(defmacro define-cstruct-accessor (accessor structure-type field value-type
-					    field-type tag-name)
-  (let ((setf (intern (concatenate 'string "SET-" (string accessor))))
-	(caccessor (format nil "pcl_get_~A_~A" structure-type field))
-	(csetf     (format nil "pcl_set_~A_~A" structure-type field))
-	(vtype (intern (string-upcase value-type))))
-    `(progn
-       (CLines ,(format nil "~A ~A(~A)                ~%~
-                             object ~A;               ~%~
-                             { return ((~A) ~A->~A.~A); }       ~%~
-                                                      ~%~
-                             ~A ~A(~A, new)           ~%~
-                             object ~A;               ~%~
-                             ~A new;                  ~%~
-                             { return ((~A)(~A->~A.~A = ~Anew)); } ~%~
-                            "
-			value-type caccessor structure-type 
-			structure-type
-			value-type structure-type tag-name field
-			value-type csetf structure-type
-			structure-type 
-			value-type 
-			value-type structure-type tag-name field field-type
-			))
-
-       (defentry ,accessor (object) (,vtype ,caccessor))
-       (defentry ,setf (object ,vtype) (,vtype ,csetf))
-
-
-       (defsetf ,accessor ,setf)
-
-       )))
-)
-;;; 
-;;; struct cfun {                   /*  compiled function header  */
-;;;         short   t, m;
-;;;         object  cf_name;        /*  compiled function name  */
-;;;         int     (*cf_self)();   /*  entry address  */
-;;;         object  cf_data;        /*  data the function uses  */
-;;;                                 /*  for GBC  */
-;;;         char    *cf_start;      /*  start address of the code  */
-;;;         int     cf_size;        /*  code size  */
-;;; };
-;;; add field-type tag-name
-(define-cstruct-accessor cfun-name  "cfun" "cf_name"  "object" "(object)" "cf")
-(define-cstruct-accessor cfun-self  "cfun" "cf_self"  "int" "(int (*)())" 
-                         "cf")
-(define-cstruct-accessor cfun-data  "cfun" "cf_data"  "object" "(object)" "cf")
-(define-cstruct-accessor cfun-start "cfun" "cf_start" "int" "(char *)" "cf")
-(define-cstruct-accessor cfun-size  "cfun" "cf_size"  "int" "(int)" "cf")
-
-(CLines
-  "object pcl_cfunp (x)              "
-  "object x;                         "
-  "{if(x->c.t == (int) t_cfun)       "
-  "  return (Ct);                    "
-  "  else                            "
-  "    return (Cnil);                "
-  "  }                               "
-  )
-
-(defentry cfunp (object) (object pcl_cfunp))
-
-;;; 
-;;; struct cclosure {               /*  compiled closure header  */
-;;;         short   t, m;
-;;;         object  cc_name;        /*  compiled closure name  */
-;;;         int     (*cc_self)();   /*  entry address  */
-;;;         object  cc_env;         /*  environment  */
-;;;         object  cc_data;        /*  data the closure uses  */
-;;;                                 /*  for GBC  */
-;;;         char    *cc_start;      /*  start address of the code  */
-;;;         int     cc_size;        /*  code size  */
-;;; };
-;;; 
-(define-cstruct-accessor cclosure-name "cclosure"  "cc_name"  "object"
-                         "(object)" "cc")          
-(define-cstruct-accessor cclosure-self "cclosure"  "cc_self"  "int" 
-                         "(int (*)())" "cc")
-(define-cstruct-accessor cclosure-data "cclosure"  "cc_data"  "object"
-                          "(object)" "cc")
-(define-cstruct-accessor cclosure-start "cclosure" "cc_start" "int" 
-                         "(char *)" "cc")
-(define-cstruct-accessor cclosure-size "cclosure"  "cc_size"  "int"
-			 "(int)" "cc")
-(define-cstruct-accessor cclosure-env "cclosure"   "cc_env"   "object"
-                         "(object)" "cc")
-
-
-(CLines
-  "object pcl_cclosurep (x)          "
-  "object x;                         "
-  "{if(x->c.t == (int) t_cclosure)   "
-  "  return (Ct);                    "
-  "  else                            "
-  "   return (Cnil);                 "
-  "  }                               "
-  )
-
-(defentry cclosurep (object) (object pcl_cclosurep))
-
-  ;;   
-;;;;;; Load Time Eval
-  ;;
-;;; 
-
-;;; This doesn't work because it looks at a global variable to see if it is
-;;; in the compiler rather than looking at the macroexpansion environment.
-;;; 
-;;; The result is that if in the process of compiling a file, we evaluate a
-;;; form that has a call to load-time-eval, we will get faked into thinking
-;;; that we are compiling that form.
-;;;
-;;; THIS NEEDS TO BE DONE RIGHT!!!
-;;; 
-;(defmacro load-time-eval (form)
-;  ;; In KCL there is no compile-to-core case.  For things that we are 
-;  ;; "compiling to core" we just expand the same way as if were are
-;  ;; compiling a file since the form will be evaluated in just a little
-;  ;; bit when gazonk.o is loaded.
-;  (if (and (boundp 'compiler::*compiler-input*)  ;Hack to see of we are
-;	   compiler::*compiler-input*)		  ;in the compiler!
-;      `'(si:|#,| . ,form)
-;      `(progn ,form)))
-
-(defmacro load-time-eval (form)
-  (read-from-string (format nil "'#,~S" form)))
-
-(defmacro memory-block-ref (block offset)
-  `(svref (the simple-vector ,block) (the fixnum ,offset)))
-
-  ;;   
-;;;;;; Generating CACHE numbers
-  ;;
-;;; This needs more work to be sure it is going as fast as possible.
-;;;   -  The calls to si:address should be open-coded.
-;;;   -  The logand should be open coded.
-;;;   
-
-;(defmacro symbol-cache-no (symbol mask)
-;  (if (and (constantp symbol)
-;	   (constantp mask))
-;      `(load-time-eval (logand (ash (si:address ,symbol) -2) ,mask))
-;      `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
-
-(defmacro object-cache-no (object mask)
-  `(logand (the fixnum (si:address ,object)) ,mask))
-
-  ;;   
-;;;;;; printing-random-thing-internal
-  ;;
-(defun printing-random-thing-internal (thing stream)
-  (format stream "~O" (si:address thing)))
-
-
-(defun set-function-name-1 (fn new-name ignore)
-  (cond ((cclosurep fn)
-	 (setf (cclosure-name fn) new-name))
-	((cfunp fn)
-	 (setf (cfun-name fn) new-name))
-	((and (listp fn)
-	      (eq (car fn) 'lambda-block))
-	 (setf (cadr fn) new-name))
-	((and (listp fn)
-	      (eq (car fn) 'lambda))
-	 (setf (car fn) 'lambda-block
-	       (cdr fn) (cons new-name (cdr fn)))))
-  fn)
-
-
-
-
-#|
-(defconstant most-positive-small-fixnum 1024)  /* should be supplied */
-(defconstant most-negative-small-fixnum -1024) /* by ibuki */
-
-(defmacro symbol-cache-no (symbol mask)
-  (if (constantp mask)
-      (if (and (> mask 0)
-	       (< mask most-positive-small-fixnum))
-	  (if (constantp symbol)
-	      `(load-time-eval (coffset ,symbol ,mask 2))
-	    `(coffset ,symbol ,mask 2))
-	(if (constantp symbol)
-	    `(load-time-eval 
-	       (logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))
-	  `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
-    `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
-
-
-(defmacro object-cache-no (object mask)
-  (if (and (constantp mask)
-	   (> mask 0)
-	   (< mask most-positive-small-fixnum))
-      `(coffset ,object ,mask 4)
-    `(logand (ash (the fixnum (si:address ,object)) -4) ,mask)))
-
-(CLines
-  "object pcl_coffset (sym,mask,lshift)"
-  "object sym,mask,lshift;"
-  "{"
-  "	return(small_fixnum(((int)sym >> fix(lshift)) & fix(mask)));"
-  "}"
-  )
-
-(defentry coffset (object object object) (object pcl_coffset))
-
-
-|#
-
diff --git a/pcl/ibcl-patches.lisp b/pcl/ibcl-patches.lisp
deleted file mode 100644
index 68e071cef1444aa9be506fd869408e3c48f9b71b..0000000000000000000000000000000000000000
--- a/pcl/ibcl-patches.lisp
+++ /dev/null
@@ -1,129 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package 'system)
-
-;;;   This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere
-;;;   in the lambda-list.  The former allows deviation from the CL spec,
-;;;   but what the heck.
-
-(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
-
-(defvar *old-defmacro*)
-
-(defun new-defmacro (whole env)
-  (flet ((call-old-definition (new-whole)
-	   (funcall *old-defmacro* new-whole env)))
-    (if (not (and (consp whole)
-		  (consp (cdr whole))
-		  (consp (cddr whole))
-		  (consp (cdddr whole))))
-	(call-old-definition whole)
-	(let* ((ll (caddr whole))
-	       (env-tail (do ((tail ll (cdr tail)))
-			     ((not (consp tail)) nil)
-			   (when (eq '&environment (car tail))
-			     (return tail)))))
-	  (if env-tail
-	      (call-old-definition (list* (car whole)
-					  (cadr whole)
-					  (append (list '&environment
-							(cadr env-tail))
-						  (ldiff ll env-tail)
-						  (cddr env-tail))
-					  (cdddr whole)))
-	      (call-old-definition whole))))))
-
-(eval-when (load eval)
-  (unless (boundp '*old-defmacro*)
-    (setq *old-defmacro* (macro-function 'defmacro))
-    (setf (macro-function 'defmacro) #'new-defmacro)))
-
-;;;
-;;; setf patches
-;;;
-
-(in-package 'system)
-
-(defun get-setf-method (form)
-  (multiple-value-bind (vars vals stores store-form access-form)
-      (get-setf-method-multiple-value form)
-    (unless (listp vars)
-	    (error 
- "The temporary variables component, ~s, 
-  of the setf-method for ~s is not a list."
-             vars form))
-    (unless (listp vals)
-	    (error 
- "The values forms component, ~s, 
-  of the setf-method for ~s is not a list."
-             vals form))
-    (unless (listp stores)
-	    (error 
- "The store variables component, ~s,  
-  of the setf-method for ~s is not a list."
-             stores form))
-    (unless (= (list-length stores) 1)
-	    (error "Multiple store-variables are not allowed."))
-    (values vars vals stores store-form access-form)))
-
-(defun get-setf-method-multiple-value (form)
-  (cond ((symbolp form)
-	 (let ((store (gensym)))
-	   (values nil nil (list store) `(setq ,form ,store) form)))
-	((or (not (consp form)) (not (symbolp (car form))))
-	 (error "Cannot get the setf-method of ~S." form))
-	((get (car form) 'setf-method)
-	 (apply (get (car form) 'setf-method) (cdr form)))
-	((get (car form) 'setf-update-fn)
-	 (let ((vars (mapcar #'(lambda (x)
-	                         (declare (ignore x))
-	                         (gensym))
-	                     (cdr form)))
-	       (store (gensym)))
-	   (values vars (cdr form) (list store)
-	           `(,(get (car form) 'setf-update-fn)
-		     ,@vars ,store)
-		   (cons (car form) vars))))
-	((get (car form) 'setf-lambda)
-	 (let* ((vars (mapcar #'(lambda (x)
-	                          (declare (ignore x))
-	                          (gensym))
-	                      (cdr form)))
-		(store (gensym))
-		(l (get (car form) 'setf-lambda))
-		(f `(lambda ,(car l) 
-		      (funcall #'(lambda ,(cadr l) ,@(cddr l))
-			       ',store))))
-	   (values vars (cdr form) (list store)
-		   (apply f vars)
-		   (cons (car form) vars))))
-	((macro-function (car form))
-	 (get-setf-method-multiple-value (macroexpand-1 form)))
-	(t
-	 (error "Cannot expand the SETF form ~S." form))))
-
diff --git a/pcl/init.lisp b/pcl/init.lisp
deleted file mode 100644
index ea607bc93a3610b504b2798d373f92f8b6bccdde..0000000000000000000000000000000000000000
--- a/pcl/init.lisp
+++ /dev/null
@@ -1,258 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;;
-;;; This file defines the initialization and related protocols.
-;;; 
-
-(in-package :pcl)
-
-(defmethod make-instance ((class symbol) &rest initargs)
-  (apply #'make-instance (find-class class) initargs))
-
-(defmethod make-instance ((class class) &rest initargs)
-  (unless (class-finalized-p class) (finalize-inheritance class))
-  (setq initargs (default-initargs class initargs))
-  #||
-  (check-initargs-1
-   class initargs
-   (list (list* 'allocate-instance class initargs)
-	 (list* 'initialize-instance (class-prototype class) initargs)
-	 (list* 'shared-initialize (class-prototype class) t initargs)))
-  ||#
-  (let* ((info (initialize-info class initargs))
-	 (valid-p (initialize-info-valid-p info)))
-    (when (and (consp valid-p) (eq (car valid-p) :invalid))
-      (error "Invalid initialization argument ~S for class ~S"
-	     (cdr valid-p) (class-name class))))
-  (let ((instance (apply #'allocate-instance class initargs)))
-    (apply #'initialize-instance instance initargs)
-    instance))
-
-(defvar *default-initargs-flag* (list nil))
-
-(defmethod default-initargs ((class slot-class) supplied-initargs)
-  (call-initialize-function
-   (initialize-info-default-initargs-function
-    (initialize-info class supplied-initargs))
-   nil supplied-initargs)
-  #||
-  ;; This implementation of default initargs is critically dependent
-  ;; on all-default-initargs not having any duplicate initargs in it.
-  (let ((all-default (class-default-initargs class))
-	(miss *default-initargs-flag*))
-    (flet ((getf* (plist key)
-	     (do ()
-		 ((null plist) miss)
-	       (if (eq (car plist) key)
-		   (return (cadr plist))
-		   (setq plist (cddr plist))))))
-      (labels ((default-1 (tail)
-		 (if (null tail)
-		     nil
-		     (if (eq (getf* supplied-initargs (caar tail)) miss)
-			 (list* (caar tail)
-				(funcall (cadar tail))
-				(default-1 (cdr tail)))
-			 (default-1 (cdr tail))))))
-	(append supplied-initargs (default-1 all-default)))))
-  ||#)
-
-(defmethod initialize-instance ((instance slot-object) &rest initargs)
-  (apply #'shared-initialize instance t initargs))
-
-(defmethod reinitialize-instance ((instance slot-object) &rest initargs)
-  #||  
-  (check-initargs-1
-   (class-of instance) initargs
-   (list (list* 'reinitialize-instance instance initargs)
-	 (list* 'shared-initialize instance nil initargs)))
-  ||#
-  (let* ((class (class-of instance))
-	 (info (initialize-info class initargs))
-	 (valid-p (initialize-info-ri-valid-p info)))
-    (when (and (consp valid-p) (eq (car valid-p) :invalid))
-      (error "Invalid initialization argument ~S for class ~S"
-	     (cdr valid-p) (class-name class))))
-  (apply #'shared-initialize instance nil initargs)
-  instance)
-
-(defmethod update-instance-for-different-class ((previous standard-object)
-						(current standard-object)
-						&rest initargs)
-  ;; First we must compute the newly added slots.  The spec defines
-  ;; newly added slots as "those local slots for which no slot of
-  ;; the same name exists in the previous class."
-  (let ((added-slots '())
-	(current-slotds (class-slots (class-of current)))
-	(previous-slot-names (mapcar #'slot-definition-name
-				     (class-slots (class-of previous)))))
-    (dolist (slotd current-slotds)
-      (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
-	       (eq (slot-definition-allocation slotd) ':instance))
-	  (push (slot-definition-name slotd) added-slots)))
-    (check-initargs-1
-     (class-of current) initargs
-     (list (list* 'update-instance-for-different-class previous current initargs)
-	   (list* 'shared-initialize current added-slots initargs)))
-    (apply #'shared-initialize current added-slots initargs)))
-
-(defmethod update-instance-for-redefined-class ((instance standard-object)
-						added-slots
-						discarded-slots
-						property-list
-						&rest initargs)
-  (check-initargs-1
-   (class-of instance) initargs
-   (list (list* 'update-instance-for-redefined-class
-		instance added-slots discarded-slots property-list initargs)
-	 (list* 'shared-initialize instance added-slots initargs)))
-  (apply #'shared-initialize instance added-slots initargs))
-
-(defmethod shared-initialize
-    ((instance slot-object) slot-names &rest initargs)
-  (when (eq slot-names 't)
-    (return-from shared-initialize
-      (call-initialize-function
-       (initialize-info-shared-initialize-t-function
-	(initialize-info (class-of instance) initargs))
-       instance initargs)))
-  (when (eq slot-names 'nil)
-    (return-from shared-initialize
-      (call-initialize-function
-       (initialize-info-shared-initialize-nil-function
-	(initialize-info (class-of instance) initargs))
-       instance initargs)))
-  ;;
-  ;; initialize the instance's slots in a two step process
-  ;;   (1) A slot for which one of the initargs in initargs can set
-  ;;       the slot, should be set by that initarg.  If more than
-  ;;       one initarg in initargs can set the slot, the leftmost
-  ;;       one should set it.
-  ;;
-  ;;   (2) Any slot not set by step 1, may be set from its initform
-  ;;       by step 2.  Only those slots specified by the slot-names
-  ;;       argument are set.  If slot-names is:
-  ;;       T
-  ;;            any slot not set in step 1 is set from its
-  ;;            initform
-  ;;       <list of slot names>
-  ;;            any slot in the list, and not set in step 1
-  ;;            is set from its initform
-  ;;
-  ;;       ()
-  ;;            no slots are set from initforms
-  ;;
-  (let* ((class (class-of instance))
-	 (slotds (class-slots class))
-	 #-new-kcl-wrapper
-	 (std-p (or (std-instance-p instance) (fsc-instance-p instance))))
-    (dolist (slotd slotds)
-      (let ((slot-name (slot-definition-name slotd))
-	    (slot-initargs (slot-definition-initargs slotd)))
-	(unless (progn
-		  ;; Try to initialize the slot from one of the initargs.
-		  ;; If we succeed return T, otherwise return nil.
-		  (doplist (initarg val) initargs
-			   (when (memq initarg slot-initargs)
-			     (setf (slot-value-using-class class instance slotd)
-				   val)
-			     (return 't))))
-	  ;; Try to initialize the slot from its initform.
-	  (if (and slot-names
-		   (or (eq slot-names 't)
-		       (memq slot-name slot-names))
-		   (or #-new-kcl-wrapper (and (not std-p) (eq slot-names 't))
-		       (not (slot-boundp-using-class class instance slotd))))
-	      (let ((initfunction (slot-definition-initfunction slotd)))
-		(when initfunction
-		  (setf (slot-value-using-class class instance slotd)
-			(funcall initfunction))))))))
-    instance))
-
-
-;;; 
-;;; if initargs are valid return nil, otherwise signal an error
-;;;
-(defun check-initargs-1 (class initargs call-list &optional (plist-p t) (error-p t))
-  (multiple-value-bind (legal allow-other-keys)
-      (check-initargs-values class call-list)
-    (unless allow-other-keys
-      (if plist-p
-	  (check-initargs-2-plist initargs class legal error-p)
-	  (check-initargs-2-list initargs class legal error-p)))))
-
-(defun check-initargs-values (class call-list)
-  (let ((methods (mapcan #'(lambda (call)
-			     (if (consp call)
-				 (copy-list (compute-applicable-methods
-					     (gdefinition (car call))
-					     (cdr call)))
-				 (list call)))
-			 call-list))
-	(legal (apply #'append (mapcar #'slot-definition-initargs
-				       (class-slots class)))))
-    ;; Add to the set of slot-filling initargs the set of
-    ;; initargs that are accepted by the methods.  If at
-    ;; any point we come across &allow-other-keys, we can
-    ;; just quit.
-    (dolist (method methods)
-      (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
-	  (analyze-lambda-list (if (consp method)
-				   (early-method-lambda-list method)
-				   (method-lambda-list method)))
-	(declare (ignore nreq nopt keysp restp))
-	(when allow-other-keys
-	  (return-from check-initargs-values (values nil t)))
-	(setq legal (append keys legal))))
-    (values legal nil)))
-
-(defun check-initargs-2-plist (initargs class legal &optional (error-p t))
-  (unless (getf initargs :allow-other-keys)
-    ;; Now check the supplied-initarg-names and the default initargs
-    ;; against the total set that we know are legal.
-    (doplist (key val) initargs
-       (unless (memq key legal)
-	 (if error-p
-	     (error "Invalid initialization argument ~S for class ~S"
-		    key
-		    (class-name class))
-	     (return-from check-initargs-2-plist nil)))))
-  t)
-
-(defun check-initargs-2-list (initkeys class legal &optional (error-p t))
-  (unless (memq :allow-other-keys initkeys)
-    ;; Now check the supplied-initarg-names and the default initargs
-    ;; against the total set that we know are legal.
-    (dolist (key initkeys)
-      (unless (memq key legal)
-	(if error-p
-	    (error "Invalid initialization argument ~S for class ~S"
-		   key
-		   (class-name class))
-	    (return-from check-initargs-2-list nil)))))
-  t)
-
diff --git a/pcl/inline.lisp b/pcl/inline.lisp
deleted file mode 100644
index b884310efe5a0152b3b5fbe80e64b3c75e0608b1..0000000000000000000000000000000000000000
--- a/pcl/inline.lisp
+++ /dev/null
@@ -1,263 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-
-(in-package :pcl)
-
-;; This file contains some of the things that will have to change to support
-;; inlining of methods.
-
-(defun make-method-lambda-internal (method-lambda &optional env)
-  (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
-    (error "The method-lambda argument to make-method-lambda, ~S,~
-            is not a lambda form" method-lambda))
-  (multiple-value-bind (documentation declarations real-body)
-      (extract-declarations (cddr method-lambda) env)
-    (let* ((name-decl (get-declaration 'method-name declarations))
-	   (sll-decl (get-declaration 'method-lambda-list declarations))
-	   (method-name (when (consp name-decl) (car name-decl)))
-	   (generic-function-name (when method-name (car method-name)))
-	   (specialized-lambda-list (or sll-decl (cadr method-lambda))))
-      (multiple-value-bind (parameters lambda-list specializers)
-	  (parse-specialized-lambda-list specialized-lambda-list)
-	(let* ((required-parameters
-		(mapcar #'(lambda (r s) (declare (ignore s)) r)
-			parameters
-			specializers))
-	       (slots (mapcar #'list required-parameters))
-	       (calls (list nil))
-	       (parameters-to-reference
-		(make-parameter-references specialized-lambda-list
-					   required-parameters
-					   declarations
-					   method-name
-					   specializers))
-	       (class-declarations
-		`(declare
-		  ,@(remove nil
-			    (mapcar #'(lambda (a s) (and (symbolp s)
-							 (neq s 't)
-							 `(class ,a ,s)))
-				    parameters
-				    specializers))))
-	       (method-lambda
-		  ;; Remove the documentation string and insert the
-		  ;; appropriate class declarations.  The documentation
-		  ;; string is removed to make it easy for us to insert
-		  ;; new declarations later, they will just go after the
-		  ;; cadr of the method lambda.  The class declarations
-		  ;; are inserted to communicate the class of the method's
-		  ;; arguments to the code walk.
-		  `(lambda ,lambda-list
-		     ,class-declarations
-		     ,@declarations
-		     (progn ,@parameters-to-reference)
-		     (block ,(if (listp generic-function-name)
-				 (cadr generic-function-name)
-				 generic-function-name)
-		       ,@real-body)))
-	       (constant-value-p (and (null (cdr real-body))
-				      (constantp (car real-body))))
-	       (constant-value (and constant-value-p
-				    (eval (car real-body))))
-	       (plist (if (and constant-value-p
-			       (or (typep constant-value '(or number character))
-				   (and (symbolp constant-value)
-					(symbol-package constant-value))))
-			  (list :constant-value constant-value)
-			  ()))
-	       (applyp (dolist (p lambda-list nil)
-			 (cond ((memq p '(&optional &rest &key))
-				(return t))
-			       ((eq p '&aux)
-				(return nil))))))
-	    (multiple-value-bind (walked-lambda call-next-method-p closurep
-						next-method-p-p)
-		(walk-method-lambda method-lambda required-parameters env 
-				    slots calls)
-	      (multiple-value-bind (ignore walked-declarations walked-lambda-body)
-		  (extract-declarations (cddr walked-lambda))
-		(declare (ignore ignore))
-		(when (or next-method-p-p call-next-method-p)
-		  (setq plist (list* :needs-next-methods-p 't plist)))
-		(when (some #'cdr slots)
-		  (multiple-value-bind (slot-name-lists call-list)
-		      (slot-name-lists-from-slots slots calls)
-		    (let ((pv-table-symbol (make-symbol "pv-table")))
-		      (setq plist 
-			    `(,@(when slot-name-lists 
-				  `(:slot-name-lists ,slot-name-lists))
-			      ,@(when call-list
-				  `(:call-list ,call-list))
-			      :pv-table-symbol ,pv-table-symbol
-			      ,@plist))
-		      (setq walked-lambda-body
-			    `((pv-binding (,required-parameters ,slot-name-lists
-					   ,pv-table-symbol)
-			       ,@walked-lambda-body))))))
-		(when (and (memq '&key lambda-list)
-			   (not (memq '&allow-other-keys lambda-list)))
-		  (let ((aux (memq '&aux lambda-list)))
-		    (setq lambda-list (nconc (ldiff lambda-list aux)
-					     (list '&allow-other-keys)
-					     aux))))
-		(values `(lambda (.method-args. .next-methods.)
-			   (simple-lexical-method-functions
-			       (,lambda-list .method-args. .next-methods.
-				:call-next-method-p ,call-next-method-p 
-				:next-method-p-p ,next-method-p-p
-				:closurep ,closurep
-				:applyp ,applyp)
-			     ,@walked-declarations
-			     ,@walked-lambda-body))
-			`(,@(when plist 
-			      `(:plist ,plist))
-			  ,@(when documentation 
-			      `(:documentation ,documentation)))))))))))
-
-(define-inline-function slot-value (instance slot-name) (form closure-p env)
-  :predicate (and (not closure-p) (constantp slot-name))
-  :inline-arguments (required-parameters slots)
-  :inline (optimize-slot-value     
-	   slots
-	   (can-optimize-access form required-parameters env)
-	   form))
-
-;collect information about:
-; uses of the required-parameters
-; uses of call-next-method and next-method-p:
-;   called-p
-;   apply-p
-;   arglist info
-;optimize calls to slot-value, set-slot-value, slot-boundp
-;optimize calls to find-class
-;optimize generic-function calls
-(defun make-walk-function (required-parameters info slots calls)
-  #'(lambda (form context env)
-      (cond ((not (eq context ':eval)) form)
-	    ((not (listp form)) form)
-	    ((eq (car form) 'call-next-method)
-	     (setq call-next-method-p 't)
-	     form)
-	    ((eq (car form) 'next-method-p)
-	     (setq next-method-p-p 't)
-	     form)
-	    ((and (eq (car form) 'function)
-		  (cond ((eq (cadr form) 'call-next-method)
-			 (setq call-next-method-p 't)
-			 (setq closurep t)
-			 form)
-			((eq (cadr form) 'next-method-p)
-			 (setq next-method-p-p 't)
-			 (setq closurep t)
-			 form)
-			(t nil))))
-	    ((and (or (eq (car form) 'slot-value)
-		      (eq (car form) 'set-slot-value)
-		      (eq (car form) 'slot-boundp))
-		  (constantp (caddr form)))
-	     (let ((parameter
-		    (can-optimize-access form
-					 required-parameters env)))
-	       (ecase (car form)
-		 (slot-value
-		  (optimize-slot-value     slots parameter form))
-		 (set-slot-value
-		  (optimize-set-slot-value slots parameter form))
-		 (slot-boundp
-		  (optimize-slot-boundp    slots parameter form)))))
-	    ((and (or (symbolp (car form))
-		      (and (consp (car form))
-			   (eq (caar form) 'setf)))
-		  (gboundp (car form))
-		  (if (eq *boot-state* 'complete)
-		      (standard-generic-function-p (gdefinition (car form)))
-		      (funcallable-instance-p (gdefinition (car form)))))
-	     (optimize-generic-function-call 
-	      form required-parameters env slots calls))
-	    (t form))))
-
-(defun walk-method-lambda (method-lambda required-parameters env slots calls)
-  (let* ((call-next-method-p nil)   ;flag indicating that call-next-method
-				    ;should be in the method definition
-	 (closurep nil)		    ;flag indicating that #'call-next-method
-				    ;was seen in the body of a method
-	 (next-method-p-p nil)      ;flag indicating that next-method-p
-				    ;should be in the method definition
-	 (walk-functions `((call-next-method-p
-			    ,#'(lambda (form closure-p env)
-				 (setq call-next-method-p 't)
-				 (when closure-p
-				   (setq closurep t))
-				 form))
-			   (next-method-p
-			    ,#'(lambda (form closure-p env)
-				 (setq next-method-p-p 't)
-				 (when closure-p
-				   (setq closurep t))
-				 form))
-			   ((slot-value set-slot-value slot-boundp)
-			    ,#'(lambda (form closure-p env)
-				 (if (and (not closure-p)
-					  (constantp (caddr form)))
-				     
-    (let ((walked-lambda (walk-form method-lambda env 
-				    (make-walk-function 
-				     `((call-next-method-p
-					,#'(lambda (form closure-p env)
-					     (setq call-next-method-p 't)
-					     (when closure-p
-					       (setq closurep t))
-					     form))
-				       (next-method-p
-					,#'(lambda (form closure-p env)
-					     (setq next-method-p-p 't)
-					     (when closure-p
-					       (setq closurep t))
-					     form))
-				       ((slot-value set-slot-value slot-boundp)
-					,#'(lambda (form closure-p env)
-					     (
-      (values walked-lambda
-	      call-next-method-p closurep next-method-p-p)))))
-
-(defun initialize-method-function (initargs &optional return-function-p method)
-  (let* ((mf (getf initargs ':function))
-	 (method-spec (getf initargs ':method-spec))
-	 (plist (getf initargs ':plist))
-	 (pv-table-symbol (getf plist ':pv-table-symbol))
-	 (pv-table nil)
-	 (mff (getf initargs ':fast-function)))
-    (flet ((set-mf-property (p v)
-	     (when mf
-	       (setf (method-function-get mf p) v))
-	     (when mff
-	       (setf (method-function-get mff p) v))))
-      (when method-spec
-	(when mf
-	  (setq mf (set-function-name mf method-spec)))
-	(when mff
-	  (let ((name `(,(or (get (car method-spec) 'fast-sym)
-			     (setf (get (car method-spec) 'fast-sym)
-				   (intern (format nil "FAST-~A"
-						   (car method-spec))
-					   *the-pcl-package*)))
-			 ,@(cdr method-spec))))
-	    (set-function-name mff name)
-	    (unless mf
-	      (set-mf-property :name name)))))
-      (when plist
-	(let ((snl (getf plist :slot-name-lists))
-	      (cl (getf plist :call-list)))
-	  (when (or snl cl)
-	    (setq pv-table (intern-pv-table :slot-name-lists snl
-					    :call-list cl))
-	    (when pv-table (set pv-table-symbol pv-table))
-	    (set-mf-property :pv-table pv-table)))    
-	(loop (when (null plist) (return nil))
-	      (set-mf-property (pop plist) (pop plist)))      
-	(when method
-	  (set-mf-property :method method))    
-	(when return-function-p
-	  (or mf (method-function-from-fast-function mff)))))))
-
-
-
diff --git a/pcl/iterate.lisp b/pcl/iterate.lisp
deleted file mode 100644
index d690a953716c6714ff9621f4b92a5a15d0cb5f0a..0000000000000000000000000000000000000000
--- a/pcl/iterate.lisp
+++ /dev/null
@@ -1,1267 +0,0 @@
-;;;-*- Package: ITERATE; Syntax: Common-Lisp; Base: 10 -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;; 
-;;; Original source {pooh/n}<pooh>vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33
-
-(in-package :iterate :use '(:lisp :walker))
-   
-
-(export '(iterate iterate* gathering gather with-gathering interval elements 
-                list-elements list-tails plist-elements eachtime while until 
-                collecting joining maximizing minimizing summing 
-                *iterate-warnings*))
-
-(defvar *iterate-warnings* :any "Controls whether warnings are issued for iterate/gather forms that aren't optimized.
-NIL => never; :USER => those resulting from user code; T => always, even if it's the iteration macro that's suboptimal."
-       )
-
-;;; ITERATE macro
-
-
-(defmacro iterate (clauses &body body &environment env)
-       (optimize-iterate-form clauses body env))
-
-(defun
- simple-expand-iterate-form
- (clauses body)
- 
- ;; Expand ITERATE.  This is the "formal semantics" expansion, which we never
- ;; use.
- (let*
-  ((block-name (gensym))
-   (bound-var-lists (mapcar #'(lambda (clause)
-                                     (let ((names (first clause)))
-                                          (if (listp names)
-                                              names
-                                              (list names))))
-                           clauses))
-   (generator-vars (mapcar #'(lambda (clause)
-                                    (declare (ignore clause))
-                                    (gensym))
-                          clauses)))
-  `(block ,block-name
-       (let*
-        ,(mapcan #'(lambda (gvar clause var-list)
-                                               ; For each clause, bind a
-                                               ; generator temp to the clause,
-                                               ; then bind the specified
-                                               ; var(s)
-                          (cons (list gvar (second clause))
-                                (copy-list var-list)))
-                generator-vars clauses bound-var-lists)
-        
-        ;; Note bug in formal semantics: there can be declarations in the head
-        ;; of BODY; they go here, rather than inside loop
-        (loop
-         ,@(mapcar
-            #'(lambda (var-list gen-var)
-                                               ; Set each bound variable (or
-                                               ; set of vars) to the result of
-                                               ; calling the corresponding
-                                               ; generator
-                     `(multiple-value-setq
-                       ,var-list
-                       (funcall ,gen-var #'(lambda nil (return-from
-                                                        ,block-name)))))
-            bound-var-lists generator-vars)
-         ,@body)))))
-
-(defparameter *iterate-temp-vars-list*
-       '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4 
-               iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8)
-       "Temp var names used by ITERATE expansions.")
-
-(defun
- optimize-iterate-form
- (clauses body iterate-env)
- (let*
-  ((temp-vars *iterate-temp-vars-list*)
-   (block-name (gensym))
-   (finish-form `(return-from ,block-name))
-   (bound-vars (mapcan #'(lambda (clause)
-                                (let ((names (first clause)))
-                                     (if (listp names)
-                                         (copy-list names)
-                                         (list names))))
-                      clauses))
-   iterate-decls generator-decls update-forms bindings leftover-body)
-  (do ((tail bound-vars (cdr tail)))
-      ((null tail))
-                                               ; Check for duplicates
-    (when (member (car tail)
-                 (cdr tail))
-        (warn "Variable appears more than once in ITERATE: ~S" (car tail))))
-  (flet
-   ((get-iterate-temp nil 
-
-           ;; Make temporary var.  Note that it is ok to re-use these symbols
-           ;; in each iterate, because they are not used within BODY.
-           (or (pop temp-vars)
-               (gensym))))
-   (dolist (clause clauses)
-       (cond
-        ((or (not (consp clause))
-             (not (consp (cdr clause))))
-         (warn "Bad syntax in ITERATE: clause not of form (var iterator): ~S" 
-               clause))
-        (t
-         (unless (null (cddr clause))
-                (warn 
-       "Probable parenthesis error in ITERATE clause--more than 2 elements: ~S"
-                      clause))
-         (multiple-value-bind
-          (let-body binding-type let-bindings localdecls otherdecls extra-body)
-          (expand-into-let (second clause)
-                 'iterate iterate-env)
-          
-          ;; We have expanded the generator clause and parsed it into its LET
-          ;; pieces.
-          (prog*
-           ((vars (first clause))
-            gen-args renamed-vars)
-           (setq vars (if (listp vars)
-                          (copy-list vars)
-                          (list vars)))
-                                               ; VARS is now a (fresh) list of
-                                               ; all iteration vars bound in
-                                               ; this clause
-           (cond
-            ((eq let-body :abort)
-                                               ; Already issued a warning
-                                               ; about malformedness
-             )
-            ((null (setq let-body (function-lambda-p let-body 1)))
-                                               ; Not of the expected form
-             (let ((generator (second clause)))
-                  (cond ((and (consp generator)
-                              (fboundp (car generator)))
-                                               ; It looks ok--a macro or
-                                               ; function here--so the guy who
-                                               ; wrote it just didn't do it in
-                                               ; an optimizable way
-                         (maybe-warn :definition "Could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))"
-                                generator))
-                        (t                     ; Perhaps it's just a
-                                               ; misspelling?  Probably user
-                                               ; error
-                           (maybe-warn :user 
-                                "Iterate operator in clause ~S is not fboundp."
-                                  generator)))
-                  (setq let-body :abort)))
-            (t
-             
-             ;; We have something of the form #'(LAMBDA (finisharg) ...),
-             ;; possibly with some LET bindings around it.  LET-BODY =
-             ;; ((finisharg) ...).
-             (setq let-body (cdr let-body))
-             (setq gen-args (pop let-body))
-             (when let-bindings
-                 
-                 ;; The first transformation we want to perform is
-                 ;; "LET-eversion": turn (let* ((generator (let (..bindings..)
-                 ;; #'(lambda ...)))) ..body..) into (let* (..bindings..
-                 ;; (generator #'(lambda ...))) ..body..).  This
-                 ;; transformation is valid if nothing in body refers to any
-                 ;; of the bindings, something we can assure by
-                 ;; alpha-converting the inner let (substituting new names for
-                 ;; each var).  Of course, none of those vars can be special,
-                 ;; but we already checked for that above.
-                 (multiple-value-setq (let-bindings renamed-vars)
-                        (rename-let-bindings let-bindings binding-type 
-                               iterate-env leftover-body #'get-iterate-temp))
-                 (setq leftover-body nil)
-                                               ; If there was any leftover
-                                               ; from previous, it is now
-                                               ; consumed
-                 )
-             
-             ;; The second transformation is substituting the body of the
-             ;; generator (LAMBDA (finish-arg) . gen-body) for its appearance
-             ;; in the update form (funcall generator #'(lambda ()
-             ;; finish-form)), then simplifying that form.  The requirement
-             ;; for this part is that the generator body not refer to any
-             ;; variables that are bound between the generator binding and the
-             ;; appearance in the loop body.  The only variables bound in that
-             ;; interval are generator temporaries, which have unique names so
-             ;; are no problem, and the iteration variables remaining for
-             ;; subsequent clauses.  We'll discover the story as we walk the
-             ;; body.
-             (multiple-value-bind
-              (finishdecl other rest)
-              (parse-declarations let-body gen-args)
-              (declare (ignore finishdecl))
-                                               ; Pull out declares, if any,
-                                               ; separating out the one(s)
-                                               ; referring to the finish arg,
-                                               ; which we will throw away
-              (when other
-                                               ; Combine remaining decls with
-                                               ; decls extracted from the LET,
-                                               ; if any
-                  (setq otherdecls (nconc otherdecls other)))
-              (setq let-body (cond
-                              (otherdecls
-                                               ; There are interesting
-                                               ; declarations, so have to keep
-                                               ; it wrapped.
-                               `(let nil (declare ,@otherdecls)
-                                     ,@rest))
-                              ((null (cdr rest))
-                                               ; Only one form left
-                               (first rest))
-                              (t `(progn ,@rest)))))
-             (unless (eq (setq let-body (iterate-transform-body let-body 
-                                               iterate-env renamed-vars
-                                               (first gen-args)
-                                               finish-form bound-vars clause))
-                         :abort)
-                 
-                 ;; Skip the rest if transformation failed.  Warning has
-                 ;; already been issued.
-                 
-                 ;; Note possible further optimization: if LET-BODY expanded
-                 ;; into (prog1 oldvalue prepare-for-next-iteration), as so
-                 ;; many do, then we could in most cases split the PROG1 into
-                 ;; two pieces: do the (setq var oldvalue) here, and do the
-                 ;; prepare-for-next-iteration at the bottom of the loop. 
-                 ;; This does a slight optimization of the PROG1 and also
-                 ;; rearranges the code in a way that a reasonably clever
-                 ;; compiler might detect how to get rid of redundant
-                 ;; variables altogether (such as happens with INTERVAL and
-                 ;; LIST-TAILS); that would make the whole thing closer to
-                 ;; what you might have coded by hand.  However, to do this
-                 ;; optimization, we need to assure that (a) the
-                 ;; prepare-for-next-iteration refers freely to no vars other
-                 ;; than the internal vars we have extracted from the LET, and
-                 ;; (b) that the code has no side effects.  These are both
-                 ;; true for all the iterators defined by this module, but how
-                 ;; shall we represent side-effect info and/or tap into the
-                 ;; compiler's knowledge of same?
-                 (when localdecls
-                                               ; There were declarations for
-                                               ; the generator locals--have to
-                                               ; keep them for later, and
-                                               ; rename the vars mentioned
-                     (setq
-                      generator-decls
-                      (nconc
-                       generator-decls
-                       (mapcar
-                        #'(lambda
-                           (decl)
-                           (let ((head (car decl)))
-                                (cons head (if (eq head 'type)
-                                               (cons (second decl)
-                                                     (sublis renamed-vars
-                                                            (cddr decl)))
-                                               (sublis renamed-vars
-                                                      (cdr decl))))))
-                        localdecls)))))))
-           
-           ;; Finished analyzing clause now.  LET-BODY is the form which, when
-           ;; evaluated, returns updated values for the iteration variable(s)
-           ;; VARS.
-           (when (eq let-body :abort)
-               
-               ;; Some punt case: go with the formal semantics: bind a var to
-               ;; the generator, then call it in the update section
-               (let
-                ((gvar (get-iterate-temp))
-                 (generator (second clause)))
-                (setq
-                 let-bindings
-                 (list (list gvar
-                             (cond
-                              (leftover-body
-                                               ; Have to use this up
-                               `(progn ,@(prog1 leftover-body (setq 
-                                                                  leftover-body
-                                                                    nil))
-                                       generator))
-                              (t generator)))))
-                (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form)))))
-           (push (mv-setq (copy-list vars)
-                        let-body)
-                 update-forms)
-           (dolist (v vars)
-               (declare (ignore v))
-                                               ; Pop off the vars we have now
-                                               ; bound from the list of vars
-                                               ; to watch out for--we'll bind
-                                               ; them right now
-               (pop bound-vars))
-           (setq bindings
-                 (nconc bindings let-bindings
-                        (cond (extra-body
-                                               ; There was some computation to
-                                               ; do after the bindings--here's
-                                               ; our chance
-                               (cons (list (first vars)
-                                           `(progn ,@extra-body nil))
-                                     (rest vars)))
-                              (t vars))))))))))
-  (do ((tail body (cdr tail)))
-      ((not (and (consp tail)
-                 (consp (car tail))
-                 (eq (caar tail)
-                     'declare)))
-       
-       ;; TAIL now points at first non-declaration.  If there were
-       ;; declarations, pop them off so they appear in the right place
-       (unless (eq tail body)
-           (setq iterate-decls (ldiff body tail))
-           (setq body tail))))
-  `(block ,block-name
-       (let* ,bindings ,@(and generator-decls
-                              `((declare ,@generator-decls)))
-             ,@iterate-decls
-             ,@leftover-body
-             (loop ,@(nreverse update-forms)
-                   ,@body)))))
-
-(defun expand-into-let (clause parent-name env)
-       
-       ;; Return values: Body, LET[*], bindings, localdecls, otherdecls, extra
-       ;; body, where BODY is a single form.  If multiple forms in a LET, the
-       ;; preceding forms are returned as extra body.  Returns :ABORT if it
-       ;; issued a punt warning.
-       (prog ((expansion clause)
-              expandedp binding-type let-bindings let-body)
-             expand
-             (multiple-value-setq (expansion expandedp)
-                    (macroexpand-1 expansion env))
-             (cond ((not (consp expansion))
-                                               ; Shouldn't happen
-                    )
-                   ((symbolp (setq binding-type (first expansion)))
-                    (case binding-type
-                        ((let let*) 
-                           (setq let-bindings (second expansion))
-                                               ; List of variable bindings
-                           (setq let-body (cddr expansion))
-                           (go handle-let))))
-                   ((and (consp binding-type)
-                         (eq (car binding-type)
-                             'lambda)
-                         (not (find-if #'(lambda (x)
-                                                (member x lambda-list-keywords)
-                                                )
-                                     (setq let-bindings (second binding-type)))
-                              )
-                         (eql (length (second expansion))
-                              (length let-bindings))
-                         (null (cddr expansion)))
-                                               ; A simple LAMBDA form can be
-                                               ; treated as LET
-                    (setq let-body (cddr binding-type))
-                    (setq let-bindings (mapcar #'list let-bindings (second
-                                                                    expansion))
-                          )
-                    (setq binding-type 'let)
-                    (go handle-let)))
-             
-             ;; Fall thru if not a LET 
-             (cond (expandedp                  ; try expanding again
-                          (go expand))
-                   (t                          ; Boring--return form as the
-                                               ; body
-                      (return expansion)))
-             handle-let
-             (return (let ((locals (variables-from-let let-bindings))
-                           extra-body specials)
-                          (multiple-value-bind
-                           (localdecls otherdecls let-body)
-                           (parse-declarations let-body locals)
-                           (cond ((setq specials (extract-special-bindings
-                                                  locals localdecls))
-                                  (maybe-warn (cond ((find-if #'variable-globally-special-p
-                                                            specials)
-                                               ; This could be the fault of a
-                                               ; user proclamation
-                                                     :user)
-                                                    (t :definition))
-                                         
-          "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)"
-                                         parent-name clause specials)
-                                  :abort)
-                                 (t (values (cond ((not (consp let-body))
-                                                   
-                                               ; Null body of LET?  unlikely,
-                                               ; but someone else will likely
-                                               ; complain
-                                                   nil)
-                                                  ((null (cdr let-body))
-                                                   
-                                               ; A single expression, which we
-                                               ; hope is (function
-                                               ; (lambda...))
-                                                   (first let-body))
-                                                  (t 
-
-                          ;; More than one expression.  These are forms to
-                          ;; evaluate after the bindings but before the
-                          ;; generator form is returned.  Save them to
-                          ;; evaluate in the next convenient place.  Note that
-                          ;; this is ok, as there is no construct that can
-                          ;; cause a LET to return prematurely (without
-                          ;; returning also from some surrounding construct).
-                                                     (setq extra-body
-                                                           (butlast let-body))
-                                                     (car (last let-body))))
-                                           binding-type let-bindings localdecls
-                                           otherdecls extra-body))))))))
-
-(defun variables-from-let (bindings)
-       
-       ;; Return a list of the variables bound in the first argument to LET[*].
-       (mapcar #'(lambda (binding)
-                        (if (consp binding)
-                            (first binding)
-                            binding))
-              bindings))
-
-(defun iterate-transform-body (let-body iterate-env renamed-vars finish-arg 
-                                     finish-form bound-vars clause)
-       
-
-;;; This is the second major transformation for a single iterate clause. 
-;;; LET-BODY is the body of the iterator after we have extracted its local
-;;; variables and declarations.  We have two main tasks: (1) Substitute
-;;; internal temporaries for occurrences of the LET variables; the alist
-;;; RENAMED-VARS specifies this transformation.  (2) Substitute evaluation of
-;;; FINISH-FORM for any occurrence of (funcall FINISH-ARG).  Along the way, we
-;;; check for forms that would invalidate these transformations: occurrence of
-;;; FINISH-ARG outside of a funcall, and free reference to any element of
-;;; BOUND-VARS.  CLAUSE & TYPE are the original ITERATE clause and its type
-;;; (ITERATE or ITERATE*), for purpose of error messages.  On success, we
-;;; return the transformed body; on failure, :ABORT.
-
-       (walk-form let-body iterate-env
-              #'(lambda (form context env)
-                       (declare (ignore context))
-                       
-                       ;; Need to substitute RENAMED-VARS, as well as turn
-                       ;; (FUNCALL finish-arg) into the finish form
-                       (cond ((symbolp form)
-                              (let (renaming)
-                                   (cond ((and (eq form finish-arg)
-                                               (variable-same-p form env 
-                                                      iterate-env))
-                                               ; An occurrence of the finish
-                                               ; arg outside of FUNCALL
-                                               ; context--I can't handle this
-                                          (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it."
-                                                 (second clause))
-                                          (return-from iterate-transform-body 
-                                                 :abort))
-                                         ((and (setq renaming (assoc form 
-                                                                   renamed-vars
-                                                                     ))
-                                               (variable-same-p form env 
-                                                      iterate-env))
-                                               ; Reference to one of the vars
-                                               ; we're renaming
-                                          (cdr renaming))
-                                         ((and (member form bound-vars)
-                                               (variable-same-p form env 
-                                                      iterate-env))
-                                               ; FORM is a var that is bound
-                                               ; in this same ITERATE, or
-                                               ; bound later in this ITERATE*.
-                                               ; This is a conflict.
-                                          (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable."
-                                                 (second clause)
-                                                 form)
-                                          (return-from iterate-transform-body 
-                                                 :abort))
-                                         (t form))))
-                             ((and (consp form)
-                                   (eq (first form)
-                                       'funcall)
-                                   (eq (second form)
-                                       finish-arg)
-                                   (variable-same-p (second form)
-                                          env iterate-env))
-                                               ; (FUNCALL finish-arg) =>
-                                               ; finish-form
-                              (unless (null (cddr form))
-                                  (maybe-warn :definition 
-        "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored."
-                                         (second clause)
-                                         (cddr form)))
-                              finish-form)
-                             (t form)))))
-
-(defun
- parse-declarations
- (tail locals)
- 
- ;; Extract the declarations from the head of TAIL and divide them into 2
- ;; classes: declares about variables in the list LOCALS, and all other
- ;; declarations.  Returns 3 values: those 2 lists plus the remainder of TAIL.
- (let
-  (localdecls otherdecls form)
-  (loop
-   (unless (and tail (consp (setq form (car tail)))
-                (eq (car form)
-                    'declare))
-       (return (values localdecls otherdecls tail)))
-   (mapc
-    #'(lambda
-       (decl)
-       (case (first decl)
-           ((inline notinline optimize) 
-                                               ; These don't talk about vars
-              (push decl otherdecls))
-           (t                                  ; Assume all other kinds are
-                                               ; for vars
-              (let* ((vars (if (eq (first decl)
-                                   'type)
-                               (cddr decl)
-                               (cdr decl)))
-                     (l (intersection locals vars))
-                     other)
-                    (cond
-                     ((null l)
-                                               ; None talk about LOCALS
-                      (push decl otherdecls))
-                     ((null (setq other (set-difference vars l)))
-                                               ; All talk about LOCALS
-                      (push decl localdecls))
-                     (t                        ; Some of each
-                        (let ((head (cons 'type (and (eq (first decl)
-                                                         'type)
-                                                     (list (second decl))))))
-                             (push (append head other)
-                                   otherdecls)
-                             (push (append head l)
-                                   localdecls))))))))
-    (cdr form))
-   (pop tail))))
-
-(defun extract-special-bindings (vars decls)
-       
-       ;; Return the subset of VARS that are special, either globally or
-       ;; because of a declaration in DECLS
-       (let ((specials (remove-if-not #'variable-globally-special-p vars)))
-            (dolist (d decls)
-                (when (eq (car d)
-                          'special)
-                    (setq specials (union specials (intersection vars
-                                                          (cdr d))))))
-            specials))
-
-(defun function-lambda-p (form &optional nargs)
-       
-       ;; If FORM is #'(LAMBDA bindings . body) and bindings is of length
-       ;; NARGS, return the lambda expression
-       (let (args body)
-            (and (consp form)
-                 (eq (car form)
-                     'function)
-                 (consp (setq form (cdr form)))
-                 (null (cdr form))
-                 (consp (setq form (car form)))
-                 (eq (car form)
-                     'lambda)
-                 (consp (setq body (cdr form)))
-                 (listp (setq args (car body)))
-                 (or (null nargs)
-                     (eql (length args)
-                          nargs))
-                 form)))
-
-(defun
- rename-let-bindings
- (let-bindings binding-type env leftover-body &optional tempvarfn)
- 
- ;; Perform the alpha conversion required for "LET eversion" of (LET[*]
- ;; LET-BINDINGS . body)--rename each of the variables to an internal name. 
- ;; Returns 2 values: a new set of LET bindings and the alist of old var names
- ;; to new (so caller can walk the body doing the rest of the renaming). 
- ;; BINDING-TYPE is one of LET or LET*.  LEFTOVER-BODY is optional list of
- ;; forms that must be eval'ed before the first binding happens.  ENV is the
- ;; macro expansion environment, in case we have to walk a LET*.  TEMPVARFN is
- ;; a function of no args to return a temporary var; if omitted, we use
- ;; GENSYM.
- (let
-  (renamed-vars)
-  (values (mapcar #'(lambda (binding)
-                           (let ((valueform (cond ((not (consp binding))
-                                                   
-                                               ; No initial value
-                                                   nil)
-                                                  ((or (eq binding-type
-                                                           'let)
-                                                       (null renamed-vars))
-                                                   
-                                               ; All bindings are in parallel,
-                                               ; so none can refer to others
-                                                   (second binding))
-                                                  (t 
-                                               ; In a LET*, have to substitute
-                                               ; vars in the 2nd and
-                                               ; subsequent initialization
-                                               ; forms
-                                                     (rename-variables
-                                                      (second binding)
-                                                      renamed-vars env))))
-                                 (newvar (if tempvarfn
-                                             (funcall tempvarfn)
-                                             (gensym))))
-                                (push (cons (if (consp binding)
-                                                (first binding)
-                                                binding)
-                                            newvar)
-                                      renamed-vars)
-                                               ; Add new variable to the list
-                                               ; AFTER we have walked the
-                                               ; initial value form
-                                (when leftover-body
-                                    
-
-                          ;; Previous clause had some computation to do after
-                          ;; its bindings.  Here is the first opportunity to
-                          ;; do it
-                                    (setq valueform `(progn ,@leftover-body
-                                                            ,valueform))
-                                    (setq leftover-body nil))
-                                (list newvar valueform)))
-                 let-bindings)
-         renamed-vars)))
-
-(defun rename-variables (form alist env)
-       
-       ;; Walks FORM, renaming occurrences of the key variables in ALIST with
-       ;; their corresponding values.  ENV is FORM's environment, so we can
-       ;; make sure we are talking about the same variables.
-       (walk-form form env
-              #'(lambda (form context subenv)
-                       (declare (ignore context))
-                       (let (pair)
-                            (cond ((and (symbolp form)
-                                        (setq pair (assoc form alist))
-                                        (variable-same-p form subenv env))
-                                   (cdr pair))
-                                  (t form))))))
-
-(defun
- mv-setq
- (vars expr)
- 
- ;; Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some
- ;; of the simple cases for benefit of compilers that don't, and I don't care
- ;; what the value is, and I know that the variables need not be set in
- ;; parallel, since they can't be used free in EXPR
- (cond
-  ((null vars)
-                                               ; EXPR is a side-effect
-   expr)
-  ((not (consp vars))
-                                               ; This is an error, but I'll
-                                               ; let MULTIPLE-VALUE-SETQ
-                                               ; report it
-   `(multiple-value-setq ,vars ,expr))
-  ((and (listp expr)
-        (eq (car expr)
-            'values))
-   
-   ;; (mv-setq (a b c) (values x y z)) can be reduced to a parallel setq
-   ;; (psetq returns nil, but I don't care about returned value).  Do this
-   ;; even for the single variable case so that we catch (mv-setq (a) (values
-   ;; x y))
-   (pop expr)
-                                               ; VALUES
-   `(setq ,@(mapcon #'(lambda (tail)
-                             (list (car tail)
-                                   (cond ((or (cdr tail)
-                                              (null (cdr expr)))
-                                               ; One result expression for
-                                               ; this var
-                                          (pop expr))
-                                         (t    ; More expressions than vars,
-                                               ; so arrange to evaluate all
-                                               ; the rest now.
-                                            (cons 'prog1 expr)))))
-                   vars)))
-  ((null (cdr vars))
-                                               ; Simple one variable case
-   `(setq ,(car vars)
-          ,expr))
-  (t                                           ; General case--I know nothing
-     `(multiple-value-setq ,vars ,expr))))
-
-(defun variable-same-p (var env1 env2)
-       (eq (variable-lexical-p var env1)
-           (variable-lexical-p var env2)))
-
-(defun maybe-warn (type &rest warn-args)
-       
-       ;; Issue a warning about not being able to optimize this thing.  TYPE
-       ;; is one of :DEFINITION, meaning the definition is at fault, and
-       ;; :USER, meaning the user's code is at fault.
-       (when (case *iterate-warnings*
-                 ((nil) nil)
-                 ((:user) (eq type :user))
-                 (t t))
-           (apply #'warn warn-args)))
-
-
-;; Sample iterators
-
-
-(defmacro
- interval
- (&whole whole &key from downfrom to downto above below by type)
- (cond
-  ((and from downfrom)
-   (error "Can't use both FROM and DOWNFROM in ~S" whole))
-  ((cdr (remove nil (list to downto above below)))
-   (error "Can't use more than one limit keyword in ~S" whole))
-  (t
-   (let*
-    ((down (or downfrom downto above))
-     (limit (or to downto above below))
-     (inc (cond ((null by)
-                 1)
-                ((constantp by)
-                                               ; Can inline this increment
-                 by))))
-    `(let
-      ((from ,(or from downfrom 0))
-       ,@(and limit `((to ,limit)))
-       ,@(and (null inc)
-              `((by ,by))))
-      ,@(and type `((declare (type ,type from ,@(and limit '(to))
-                                   ,@(and (null inc)
-                                          `(by))))))
-      #'(lambda
-         (finish)
-         ,@(cond ((null limit)
-                                               ; We won't use the FINISH arg
-                  '((declare (ignore finish)))))
-         (prog1 ,(cond (limit                  ; Test the limit.  If ok,
-                                               ; return current value and
-                                               ; increment, else quit
-                              `(if (,(cond (above '>)
-                                           (below '<)
-                                           (down '>=)
-                                           (t '<=))
-                                    from to)
-                                   from
-                                   (funcall finish)))
-                       (t                      ; No test
-                          'from))
-             (setq from (,(if down
-                              '-
-                              '+)
-                         from
-                         ,(or inc 'by))))))))))
-
-(defmacro list-elements (list &key (by '#'cdr))
-       `(let ((tail ,list))
-             #'(lambda (finish)
-                      (prog1 (if (endp tail)
-                                 (funcall finish)
-                                 (first tail))
-                          (setq tail (funcall ,by tail))))))
-
-(defmacro list-tails (list &key (by '#'cdr))
-       `(let ((tail ,list))
-             #'(lambda (finish)
-                      (prog1 (if (endp tail)
-                                 (funcall finish)
-                                 tail)
-                          (setq tail (funcall ,by tail))))))
-
-(defmacro
- elements
- (sequence)
- "Generates successive elements of SEQUENCE, with second value being the index.  Use (ELEMENTS (THE type arg)) if you care about the type."
- (let*
-  ((type (and (consp sequence)
-              (eq (first sequence)
-                  'the)
-              (second sequence)))
-   (accessor (if type
-                 (sequence-accessor type)
-                 'elt))
-   (listp (eq type 'list)))
-  
-  ;; If type is given via THE, we may be able to generate a good accessor here
-  ;; for the benefit of implementations that aren't smart about (ELT (THE
-  ;; STRING FOO)).  I'm not bothering to keep the THE inside the body,
-  ;; however, since I assume any compiler that would understand (AREF (THE
-  ;; SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I
-  ;; bound S to (THE SIMPLE-ARRAY foo) and never modified it.
-  
-  ;; If sequence is declared to be a list, it's better to cdr down it, so we
-  ;; have some extra cases here.  Normally folks would write LIST-ELEMENTS,
-  ;; but maybe they wanted to get the index for free...
-  `(let* ((index 0)
-          (s ,sequence)
-          ,@(and (not listp)
-                 '((size (length s)))))
-         #'(lambda (finish)
-                  (values (cond ,(if listp
-                                     '((not (endp s))
-                                       (pop s))
-                                     `((< index size)
-                                       (,accessor s index)))
-                                (t (funcall finish)))
-                         (prog1 index
-                             (setq index (1+ index))))))))
-
-(defmacro
- plist-elements
- (plist)
- "Generates each time 2 items, the indicator and the value."
- `(let ((tail ,plist))
-       #'(lambda (finish)
-                (values (if (endp tail)
-                            (funcall finish)
-                            (first tail))
-                       (prog1 (if (endp (setq tail (cdr tail)))
-                                  (funcall finish)
-                                  (first tail))
-                           (setq tail (cdr tail)))))))
-
-(defun sequence-accessor (type)
-       
-       ;; returns the function with which most efficiently to make accesses to
-       ;; a sequence of type TYPE.
-       (case (if (consp type)
-                                               ; e.g., (VECTOR FLOAT *)
-                 (car type)
-                 type)
-           ((array simple-array vector) 'aref)
-           (simple-vector 'svref)
-           (string 'char)
-           (simple-string 'schar)
-           (bit-vector 'bit)
-           (simple-bit-vector 'sbit)
-           (t 'elt)))
-
-
-;; These "iterators" may be withdrawn
-
-
-(defmacro eachtime (expr)
-       `#'(lambda (finish)
-                 (declare (ignore finish))
-                 ,expr))
-
-(defmacro while (expr)
-       `#'(lambda (finish)
-                 (unless ,expr (funcall finish))))
-
-(defmacro until (expr)
-       `#'(lambda (finish)
-                 (when ,expr (funcall finish))))
-
-                                               ; GATHERING macro
-
-
-(defmacro gathering (clauses &body body &environment env)
-       (or (optimize-gathering-form clauses body env)
-           (simple-expand-gathering-form clauses body env)))
-
-(defmacro with-gathering (clauses gather-body &body use-body)
-       "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour."
-       
-       ;; We may optimize this a little better later for those compilers that
-       ;; don't do a good job on (m-v-bind vars (... (values ...)) ...).
-       `(multiple-value-bind ,(mapcar #'car clauses)
-               (gathering ,clauses ,gather-body)
-               ,@use-body))
-
-(defun
- simple-expand-gathering-form
- (clauses body env)
- (declare (ignore env))
- 
- ;; The "formal semantics" of GATHERING.  We use this only in cases that can't
- ;; be optimized.
- (let
-  ((acc-names (mapcar #'first (if (symbolp clauses)
-                                               ; Shorthand using anonymous
-                                               ; gathering site
-                                  (setq clauses `((*anonymous-gathering-site*
-                                                   (,clauses))))
-                                  clauses)))
-   (realizer-names (mapcar #'(lambda (binding)
-                                    (declare (ignore binding))
-                                    (gensym))
-                          clauses)))
-  `(multiple-value-call
-    #'(lambda
-       ,(mapcan #'list acc-names realizer-names)
-       (flet ((gather (value &optional (accumulator *anonymous-gathering-site*)
-                             )
-                     (funcall accumulator value)))
-             ,@body
-             (values ,@(mapcar #'(lambda (rname)
-                                        `(funcall ,rname))
-                              realizer-names))))
-    ,@(mapcar #'second clauses))))
-
-(defvar *active-gatherers* nil 
-       "List of GATHERING bindings currently active during macro expansion)")
-
-(defvar *anonymous-gathering-site* nil "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site)."
-       )
-
-(defun
- optimize-gathering-form
- (clauses body gathering-env)
- (let*
-  (acc-info leftover-body top-bindings finish-forms top-decls)
-  (dolist (clause (if (symbolp clauses)
-                                               ; A shorthand
-                      `((*anonymous-gathering-site* (,clauses)))
-                      clauses))
-      (multiple-value-bind
-       (let-body binding-type let-bindings localdecls otherdecls extra-body)
-       (expand-into-let (second clause)
-              'gathering gathering-env)
-       (prog*
-        ((acc-var (first clause))
-         renamed-vars accumulator realizer)
-        (when (and (consp let-body)
-                   (eq (car let-body)
-                       'values)
-                   (consp (setq let-body (cdr let-body)))
-                   (setq accumulator (function-lambda-p (car let-body)))
-                   (consp (setq let-body (cdr let-body)))
-                   (setq realizer (function-lambda-p (car let-body)
-                                         0))
-                   (null (cdr let-body)))
-            
-            ;; Macro returned something of the form (VALUES #'(lambda (value)
-            ;; ...) #'(lambda () ...)), a function to accumulate values and a
-            ;; function to realize the result.
-            (when binding-type
-                
-                ;; Gatherer expanded into a LET
-                (cond (otherdecls (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S"
-                                         (second clause)
-                                         `(declare ,@otherdecls))
-                             (go punt)))
-                (when let-bindings
-                    
-                    ;; The first transformation we want to perform is a
-                    ;; variant of "LET-eversion": turn (mv-bind (acc real)
-                    ;; (let (..bindings..) (values #'(lambda ...) #'(lambda
-                    ;; ...))) ..body..) into (let* (..bindings.. (acc
-                    ;; #'(lambda ...)) (real #'(lambda ...))) ..body..).  This
-                    ;; transformation is valid if nothing in body refers to
-                    ;; any of the bindings, something we can assure by
-                    ;; alpha-converting the inner let (substituting new names
-                    ;; for each var).  Of course, none of those vars can be
-                    ;; special, but we already checked for that above.
-                    (multiple-value-setq (let-bindings renamed-vars)
-                           (rename-let-bindings let-bindings binding-type 
-                                  gathering-env leftover-body))
-                    (setq top-bindings (nconc top-bindings let-bindings))
-                    (setq leftover-body nil)
-                                               ; If there was any leftover
-                                               ; from previous, it is now
-                                               ; consumed
-                    ))
-            (setq leftover-body (nconc leftover-body extra-body))
-                                               ; Computation to do after these
-                                               ; bindings
-            (push (cons acc-var (rename-and-capture-variables accumulator 
-                                       renamed-vars gathering-env))
-                  acc-info)
-            (setq realizer (rename-variables realizer renamed-vars 
-                                  gathering-env))
-            (push (cond ((null (cdddr realizer))
-                                               ; Simple (LAMBDA () expr) =>
-                                               ; expr
-                         (third realizer))
-                        (t                     ; There could be declarations
-                                               ; or something, so leave as a
-                                               ; LET
-                           (cons 'let (cdr realizer))))
-                  finish-forms)
-            (unless (null localdecls)
-                                               ; Declarations about the LET
-                                               ; variables also has to
-                                               ; percolate up
-                (setq top-decls (nconc top-decls (sublis renamed-vars 
-                                                        localdecls))))
-            (return))
-        (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))"
-               (second clause))
-        punt
-        (let
-         ((gs (gensym))
-          (expansion `(multiple-value-list ,(second clause))))
-                                               ; Slow way--bind gensym to the
-                                               ; macro expansion, and we will
-                                               ; funcall it in the body
-         (push (list acc-var gs)
-               acc-info)
-         (push `(funcall (cadr ,gs))
-               finish-forms)
-         (setq
-          top-bindings
-          (nconc
-           top-bindings
-           (list (list gs (cond (leftover-body
-                                 `(progn ,@(prog1 leftover-body
-                                                  (setq leftover-body nil))
-                                         ,expansion))
-                                (t expansion))))))))))
-  (setq body (walk-gathering-body body gathering-env acc-info))
-  (cond ((eq body :abort)
-                                               ; Couldn't finish expansion
-         nil)
-        (t `(let* ,top-bindings
-                  ,@(and top-decls `((declare ,@top-decls)))
-                  ,body
-                  ,(cond ((null (cdr finish-forms))
-                                               ; just a single value
-                          (car finish-forms))
-                         (t `(values ,@(reverse finish-forms)))))))))
-
-(defun rename-and-capture-variables (form alist env)
-       
-       ;; Walks FORM, renaming occurrences of the key variables in ALIST with
-       ;; their corresponding values, and capturing any other free variables. 
-       ;; Returns a list of the new form and the list of other closed-over
-       ;; vars.  ENV is FORM's environment, so we can make sure we are talking
-       ;; about the same variables.
-       (let (closed)
-            (list (walk-form
-                   form env
-                   #'(lambda (form context subenv)
-                            (declare (ignore context))
-                            (let (pair)
-                                 (cond ((or (not (symbolp form))
-                                            (not (variable-same-p form subenv 
-                                                        env)))
-                                               ; non-variable or one that has
-                                               ; been rebound
-                                        form)
-                                       ((setq pair (assoc form alist))
-                                               ; One to rename
-                                        (cdr pair))
-                                       (t      ; var is free
-                                          (pushnew form closed)
-                                          form)))))
-                  closed)))
-
-(defun
- walk-gathering-body
- (body gathering-env acc-info)
- 
- ;; Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV. 
- ;; ACC-INFO is a list of information about each of the gathering "bindings"
- ;; in the form, in the form (var gatheringfn freevars env)
- (let
-  ((*active-gatherers* (nconc (mapcar #'car acc-info)
-                              *active-gatherers*)))
-  
-  ;; *ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER
-  ;; targets.  This is so that when we encounter a GATHER not belonging to us
-  ;; we can know whether to warn about it.
-  (walk-form
-   (cons 'progn body)
-   gathering-env
-   #'(lambda
-      (form context env)
-      (declare (ignore context))
-      (let (info site)
-           (cond ((consp form)
-                  (cond
-                   ((not (eq (car form)
-                             'gather))
-                                               ; We only care about GATHER
-                    (when (and (eq (car form)
-                                   'function)
-                               (eq (cadr form)
-                                   'gather))
-                                               ; Passed as functional--can't
-                                               ; macroexpand
-                        (maybe-warn :user 
-                   "Can't optimize GATHERING because of reference to #'GATHER."
-                               )
-                        (return-from walk-gathering-body :abort))
-                    form)
-                   ((setq info (assoc (setq site (if (null (cddr form))
-                                                     
-                                                     '
-                                                     *anonymous-gathering-site*
-                                                     (third form)))
-                                      acc-info))
-                                               ; One of ours--expand (GATHER
-                                               ; value var).  INFO = (var
-                                               ; gatheringfn freevars env)
-                    (unless (null (cdddr form))
-                           (warn "Extra arguments (> 2) in ~S discarded." form)
-                           )
-                    (let ((fn (second info)))
-                         (cond ((symbolp fn)
-                                               ; Unoptimized case--just call
-                                               ; the gatherer.  FN is the
-                                               ; gensym that we bound to the
-                                               ; list of two values returned
-                                               ; from the gatherer.
-                                `(funcall (car ,fn)
-                                        ,(second form)))
-                               (t              ; FN = (lambda (value) ...)
-                                  (dolist (s (third info))
-                                      (unless (or (variable-same-p s env 
-                                                         gathering-env)
-                                                  (and (variable-special-p
-                                                        s env)
-                                                       (variable-special-p
-                                                        s gathering-env)))
-                                          
-
-                          ;; Some var used free in the LAMBDA form has been
-                          ;; rebound between here and the parent GATHERING
-                          ;; form, so can't substitute the lambda.  Ok if it's
-                          ;; a special reference both here and in the LAMBDA,
-                          ;; because then it's not closed over.
-                                          (maybe-warn :user "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it."
-                                                 s)
-                                          (return-from walk-gathering-body 
-                                                 :abort)))
-                                  
-
-                          ;; Return ((lambda (value) ...) actual-value).  In
-                          ;; many cases we could simplify this further by
-                          ;; substitution, but we'd have to be careful (for
-                          ;; example, we would need to alpha-convert any LET
-                          ;; we found inside).  Any decent compiler will do it
-                          ;; for us.
-                                  (list fn (second form))))))
-                   ((and (setq info (member site *active-gatherers*))
-                         (or (eq site '*anonymous-gathering-site*)
-                             (variable-same-p site env (fourth info))))
-                                               ; Some other GATHERING will
-                                               ; take care of this form, so
-                                               ; pass it up for now. 
-                                               ; Environment check is to make
-                                               ; sure nobody shadowed it
-                                               ; between here and there
-                    form)
-                   (t                          ; Nobody's going to handle it
-                      (if (eq site '*anonymous-gathering-site*)
-                                               ; More likely that she forgot
-                                               ; to mention the site than
-                                               ; forget to write an anonymous
-                                               ; gathering.
-                          (warn "There is no gathering site specified in ~S." 
-                                form)
-                          (warn 
-             "The site ~S in ~S is not defined in an enclosing GATHERING form."
-                                site form))
-                                               ; Turn it into something else
-                                               ; so we don't warn twice in the
-                                               ; nested case
-                      `(%orphaned-gather ,@(cdr form)))))
-                 ((and (symbolp form)
-                       (setq info (assoc form acc-info))
-                       (variable-same-p form env gathering-env))
-                                               ; A variable reference to a
-                                               ; gather binding from
-                                               ; environment TEM
-                  (maybe-warn :user "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form."
-                         form)
-                  (return-from walk-gathering-body :abort))
-                 (t form)))))))
-
-
-;; Sample gatherers
-
-
-(defmacro
- collecting
- (&key initial-value)
- `(let* ((head ,initial-value)
-         (tail ,(and initial-value `(last head))))
-        (values #'(lambda (value)
-                         (if (null head)
-                             (setq head (setq tail (list value)))
-                             (setq tail (cdr (rplacd tail (list value))))))
-               #'(lambda nil head))))
-
-(defmacro joining (&key initial-value)
-       `(let ((result ,initial-value))
-             (values #'(lambda (value)
-                              (setq result (nconc result value)))
-                    #'(lambda nil result))))
-
-(defmacro
- maximizing
- (&key initial-value)
- `(let ((result ,initial-value))
-       (values
-        #'(lambda (value)
-                 (when ,(cond ((and (constantp initial-value)
-                                    (not (null (eval initial-value))))
-                                               ; Initial value is given and we
-                                               ; know it's not NIL, so leave
-                                               ; out the null check
-                               '(> value result))
-                              (t '(or (null result)
-                                      (> value result))))
-                       (setq result value)))
-        #'(lambda nil result))))
-
-(defmacro
- minimizing
- (&key initial-value)
- `(let ((result ,initial-value))
-       (values
-        #'(lambda (value)
-                 (when ,(cond ((and (constantp initial-value)
-                                    (not (null (eval initial-value))))
-                                               ; Initial value is given and we
-                                               ; know it's not NIL, so leave
-                                               ; out the null check
-                               '(< value result))
-                              (t '(or (null result)
-                                      (< value result))))
-                       (setq result value)))
-        #'(lambda nil result))))
-
-(defmacro summing (&key (initial-value 0))
-       `(let ((sum ,initial-value))
-             (values #'(lambda (value)
-                              (setq sum (+ sum value)))
-                    #'(lambda nil sum))))
-
-                                               ; Easier to read expanded code
-                                               ; if PROG1 gets left alone
-
-
-(define-walker-template prog1 (nil return walker::repeat (eval)))
-
diff --git a/pcl/kcl-low.lisp b/pcl/kcl-low.lisp
deleted file mode 100644
index 77cb4f5696a7df94b18f4f5bc8ffa5bdea5ace11..0000000000000000000000000000000000000000
--- a/pcl/kcl-low.lisp
+++ /dev/null
@@ -1,438 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; The version of low for Kyoto Common Lisp (KCL)
-(in-package "SI")
-(export '(%structure-name
-          %compiled-function-name
-          %set-compiled-function-name
-	  %instance-ref
-	  %set-instance-ref))
-(in-package 'pcl)
-
-(shadow 'lisp:dotimes)
-
-(defmacro dotimes ((var form &optional (val nil)) &rest body &environment env)
-  (multiple-value-bind (doc decls bod)
-      (extract-declarations body env)
-    (declare (ignore doc))
-    (let ((limit (gensym))
-          (label (gensym)))
-      `(let ((,limit ,form)
-             (,var 0))
-         (declare (fixnum ,limit ,var))
-         ,@decls
-         (block nil
-           (tagbody
-            ,label
-              (when (>= ,var ,limit) (return-from nil ,val))
-              ,@bod
-              (setq ,var (the fixnum (1+ ,var)))
-              (go ,label)))))))
-
-(defun memq (item list) (member item list :test #'eq))
-(defun assq (item list) (assoc item list :test #'eq))
-(defun posq (item list) (position item list :test #'eq))
-
-(si:define-compiler-macro memq (item list) 
-  (let ((var (gensym)))
-    (once-only (item)
-      `(let ((,var ,list))
-         (loop (unless ,var (return nil))
-               (when (eq ,item (car ,var))
-                 (return ,var))
-               (setq ,var (cdr ,var)))))))
-
-(si:define-compiler-macro assq (item list) 
-  (let ((var (gensym)))
-    (once-only (item)
-      `(dolist (,var ,list nil)
-         (when (eq ,item (car ,var))
-           (return ,var))))))
-
-(si:define-compiler-macro posq (item list) 
-  (let ((var (gensym)) (index (gensym)))
-    (once-only (item)
-      `(let ((,var ,list) (,index 0))
-         (declare (fixnum ,index))
-         (dolist (,var ,list nil)
-           (when (eq ,item ,var)
-             (return ,index))
-           (incf ,index))))))
-
-(defun printing-random-thing-internal (thing stream)
-  (format stream "~X" (si:address thing)))
-
-(defmacro %svref (vector index)
-  `(svref (the simple-vector ,vector) (the fixnum ,index)))
-
-(defsetf %svref (vector index) (new-value)
-  `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
-         ,new-value))
-
-
-;;;
-;;; std-instance-p
-;;;
-#-akcl
-(si:define-compiler-macro std-instance-p (x)
-  (once-only (x)
-    `(and (si:structurep ,x)
-          (eq (si:%structure-name ,x) 'std-instance))))
-
-#+akcl
-(progn
-
-#-new-kcl-wrapper
-;; declare that std-instance-p may be computed simply, and will not change.
-(si::freeze-defstruct 'std-instance)
-
-(si::freeze-defstruct 'method-call)
-(si::freeze-defstruct 'fast-method-call)
-
-(defvar *pcl-funcall* 
-  `(lambda (loc)
-     (compiler::wt-nl
-      "{object _funobj = " loc ";"
-      "if(Rset&&type_of(_funobj)!=t_symbol)funcall_no_event(_funobj);
-       else super_funcall(_funobj);}")))
-
-(setq compiler::*super-funcall* *pcl-funcall*)
-
-(defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
-  `(funcall ,fn ,pv-cell ,next-method-call ,@args))
-
-)
-
-;;;
-;;; turbo-closure patch.  See the file kcl-mods.text for details.
-;;;
-#-turbo-closure-env-size
-(clines "
-object cclosure_env_nthcdr (n,cc)
-int n; object cc;
-{  object env;
-   if(n<0)return Cnil;
-   if(type_of(cc)!=t_cclosure)return Cnil;
-   env=cc->cc.cc_env;
-   while(n-->0)
-     {if(type_of(env)!=t_cons)return Cnil;
-      env=env->c.c_cdr;}
-   return env;
-}")
-
-#+turbo-closure-env-size
-(clines "
-object cclosure_env_nthcdr (n,cc)
-int n; object cc;
-{  object env,*turbo;
-   if(n<0)return Cnil;
-   if(type_of(cc)!=t_cclosure)return Cnil;
-   if((turbo=cc->cc.cc_turbo)==NULL)
-     {env=cc->cc.cc_env;
-      while(n-->0)
-        {if(type_of(env)!=t_cons)return Cnil;
-         env=env->c.c_cdr;}
-      return env;}
-   else
-     {if(n>=fix(*(turbo-1)))return Cnil;
-      return turbo[n];}
-}")
-
-;; This is the completely safe version.
-(defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
-;; This is the unsafe but fast version.
-(defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
-
-;;; #+akcl means this is an AKCL newer than 5/11/89 (structures changed)
-(eval-when (compile load eval)
-
-#+new-kcl-wrapper
-(progn
-
-(defun instance-ref (slots index)
-  (si:structure-ref1 slots index))
-
-(defun set-instance-ref (slots index value)
-  (si:structure-set1 slots index value))
-
-(defsetf instance-ref set-instance-ref)
-(defsetf %instance-ref %set-instance-ref)
-)
-
-(defsetf structure-def set-structure-def)
-
-;;((name args-type result-type side-effect-p new-object-p c-expression) ...)
-(defparameter *kcl-function-inlines*
-  '((%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL")
-    (%symbol-function (t) t nil nil "(#0)->s.s_gfdef")
-    #-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure")
-    #-akcl (si:%structure-name (t) t nil nil "(#0)->str.str_name")
-    #+akcl (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]")
-    #+new-kcl-wrapper
-    (si:%instance-ref (t t) t nil nil "(#0)->str.str_self[fix(#1)]")
-    #+new-kcl-wrapper
-    (si:%set-instance-ref (t t t) t t nil "(#0)->str.str_self[fix(#1)]=(#2)")
-    (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name")
-    (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)")
-    (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure")
-    #+akcl (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun")
-    (%cclosure-env (t) t nil nil "(#0)->cc.cc_env")
-    (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)")
-    #+turbo-closure
-    (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")
-    
-    (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))")))
-  
-(defun make-function-inline (inline)
-  (setf (get (car inline) 'compiler::inline-always)
-        (list (if (fboundp 'compiler::flags)
-                  (let ((opt (cdr inline)))
-                    (list (first opt) (second opt)
-                          (logior (if (fourth opt) 1 0) ; allocates-new-storage
-                                  (if (third opt) 2 0)  ; side-effect
-                                  (if nil 4 0) ; constantp
-                                  (if (eq (car inline) 'logxor)
-                                      8 0)) ;result type from args
-                          (fifth opt)))
-                  (cdr inline)))))
-
-(defmacro define-inlines ()
-  `(progn
-    ,@(mapcan #'(lambda (inline)
-                  (let* ((*package* *the-pcl-package*)
-			 (name (intern (format nil "~S inline" (car inline))))
-			 (vars (mapcar #'(lambda (type)
-					   (declare (ignore type))
-					   (gensym))
-				       (cadr inline))))
-                    `((make-function-inline ',(cons name (cdr inline)))
-                      ,@(when (or (every #'(lambda (type) (eq type 't))
-                                         (cadr inline))
-                                  (char= #\% (aref (symbol-name (car inline)) 0)))
-                          `((defun ,(car inline) ,vars
-                              ,@(mapcan #'(lambda (var var-type)
-                                            (unless (eq var-type 't)
-                                              `((declare (type ,var-type ,var)))))
-                                        vars (cadr inline))
-                              (,name ,@vars))
-                            (make-function-inline ',inline))))))
-              *kcl-function-inlines*)))
-
-(define-inlines)
-)
-
-(defsetf si:%compiled-function-name si:%set-compiled-function-name)
-(defsetf %cclosure-env %set-cclosure-env)
-
-(defun set-function-name-1 (fn new-name ignore)
-  (declare (ignore ignore))
-  (cond ((compiled-function-p fn)
-	 (si::turbo-closure fn)
-	 ;;(when (symbolp new-name) (proclaim-defgeneric new-name nil))
-         (setf (si:%compiled-function-name fn) new-name))
-        ((and (listp fn)
-              (eq (car fn) 'lambda-block))
-         (setf (cadr fn) new-name))
-        ((and (listp fn)
-              (eq (car fn) 'lambda))
-         (setf (car fn) 'lambda-block
-               (cdr fn) (cons new-name (cdr fn)))))
-  fn)
-
-
-#+akcl (clines "#define AKCL206") 
-
-(clines "
-#ifdef AKCL206
-use_fast_links();
-#endif
-
-object set_cclosure (result_cc,value_cc,available_size)
-  object result_cc,value_cc; int available_size;
-{
-  object result_env_tail,value_env_tail; int i;
-#ifdef AKCL206
-  /* If we are currently using fast linking,     */
-  /* make sure to remove the link for result_cc. */
-  use_fast_links(3,Cnil,result_cc);
-#endif
-  result_env_tail=result_cc->cc.cc_env;
-  value_env_tail=value_cc->cc.cc_env;
-  for(i=available_size;
-      result_env_tail!=Cnil && i>0;
-      result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail))
-    CMPcar(result_env_tail)=CMPcar(value_env_tail), i--;
-  result_cc->cc.cc_self=value_cc->cc.cc_self;
-  result_cc->cc.cc_data=value_cc->cc.cc_data;
-#ifndef AKCL206
-  result_cc->cc.cc_start=value_cc->cc.cc_start;
-  result_cc->cc.cc_size=value_cc->cc.cc_size;
-#endif
-  return result_cc;
-}")
-
-(defentry %set-cclosure (object object int) (object set_cclosure))
-
-
-(defun structure-functions-exist-p ()
-  t)
-
-(si:define-compiler-macro structure-instance-p (x)
-  (once-only (x)
-    `(and (si:structurep ,x)
-          (not (eq (si:%structure-name ,x) 'std-instance)))))
-
-(defun structure-type (x)
-  (and (si:structurep x)
-       (si:%structure-name x)))
-
-(si:define-compiler-macro structure-type (x)
-  (once-only (x)
-    `(and (si:structurep ,x)
-          (si:%structure-name ,x))))
-
-(defun structure-type-p (type)
-  (or (not (null (gethash type *structure-table*)))
-      (let (#+akcl(s-data nil))
-        (and (symbolp type)
-             #+akcl (setq s-data (get type 'si::s-data))
-             #-akcl (get type 'si::is-a-structure)
-             (null #+akcl (si::s-data-type s-data)
-                   #-akcl (get type 'si::structure-type))))))
-
-(defun structure-type-included-type-name (type)
-  (or (car (gethash type *structure-table*))
-      #+akcl (let ((includes (si::s-data-includes (get type 'si::s-data))))
-	       (when includes
-		 (si::s-data-name includes)))
-      #-akcl (get type 'si::structure-include)))
-
-(defun structure-type-internal-slotds (type)
-  #+akcl (si::s-data-slot-descriptions (get type 'si::s-data))
-  #-akcl (get type 'si::structure-slot-descriptions))
-
-(defun structure-type-slot-description-list (type)
-  (or (cdr (gethash type *structure-table*))
-      (mapcan #'(lambda (slotd)
-		  #-new-kcl-wrapper
-                  (when (and slotd (car slotd))
-                    (let ((offset (fifth slotd)))
-                      (let ((reader #'(lambda (x)
-                                        #+akcl (si:structure-ref1 x offset)
-                                        #-akcl (si:structure-ref x type offset)))
-                            (writer #'(lambda (v x)
-                                        (si:structure-set x type offset v))))
-                        #+turbo-closure (si:turbo-closure reader)
-                        #+turbo-closure (si:turbo-closure writer)
-                        (let* ((reader-sym 
-				(let ((*package* *the-pcl-package*))
-				  (intern (format nil "~s SLOT~D" type offset))))
-			       (writer-sym (get-setf-function-name reader-sym))
-			       (slot-name (first slotd))
-			       (read-only-p (fourth slotd)))
-                          (setf (symbol-function reader-sym) reader)
-                          (setf (symbol-function writer-sym) writer)
-                          (do-standard-defsetf-1 reader-sym)
-                          (list (list slot-name
-                                      reader-sym
-				      reader
-                                      (and (not read-only-p) writer)))))))
-		  #+new-kcl-wrapper
-		  (list slotd))
-              (let ((slotds (structure-type-internal-slotds type))
-                    (inc (structure-type-included-type-name type)))
-                (if inc
-                    (nthcdr (length (structure-type-internal-slotds inc))
-                            slotds)
-                    slotds)))))
-            
-#+new-kcl-wrapper
-(defun si::slot-reader-function (slot)
-  (let ((offset (si::slot-offset slot)))
-    (si:turbo-closure #'(lambda (x)
-			  (si::structure-ref1 x offset)))))				
-
-#+new-kcl-wrapper
-(defun si::slot-writer-function (slot)
-  (let ((offset (si::slot-offset slot)))
-    (si:turbo-closure #'(lambda (x)
-			  (si::structure-set1 x offset)))))
-
-(mapcar #'(lambda (fname value)
-	    (setf (symbol-function fname) (symbol-function value)))
-	'(structure-slotd-name
-	  structure-slotd-accessor-symbol
-	  structure-slotd-reader-function
-	  structure-slotd-writer-function
-	  structure-slotd-type
-	  structure-slotd-init-form)
-	#-new-kcl-wrapper
-	'(first second third fourth function-returning-nil function-returning-nil)
-	#+new-kcl-wrapper
-	'(si::slot-name si::slot-accessor-name 
-	  si::slot-reader-function si::slot-writer-function
-	  si::slot-type si::slot-default-init))
-
-
-;; Construct files sys-proclaim.lisp and sys-package.lisp
-;; The file sys-package.lisp must be loaded first, since the
-;; package sys-proclaim.lisp will refer to symbols and they must
-;; be in the right packages.   sys-proclaim.lisp contains function
-;; declarations and declarations that certain things are closures.
-
-(defun renew-sys-files()
-  ;; packages:
-  (compiler::get-packages "sys-package.lisp")
-  (with-open-file (st "sys-package.lisp"
-		      :direction :output
-		      :if-exists :append)
-    (format st "(in-package 'SI)
-(export '(%structure-name
-          %compiled-function-name
-          %set-compiled-function-name))
-(in-package 'pcl)
-"))
-
-  ;; proclaims
-  (compiler::make-all-proclaims "*.fn")
-  (let ((*package* (find-package 'user)))
-  (with-open-file (st "sys-proclaim.lisp"
-		      :direction :output
-		      :if-exists :append)
-    ;;(format st "~%(IN-PACKAGE \"PCL\")~%")
-    (print
-     `(dolist (v ',
-     
-	       (sloop::sloop for v in-package "PCL"
-			     when (get v 'compiler::proclaimed-closure)
-			     collect v))
-	(setf (get v 'compiler::proclaimed-closure) t))
-     st)
-    (format st "~%")
-    )))
-
-	
diff --git a/pcl/kcl-mods.text b/pcl/kcl-mods.text
deleted file mode 100644
index 741e41ac6cdb6881e083e5ac40ecd772bee1375a..0000000000000000000000000000000000000000
--- a/pcl/kcl-mods.text
+++ /dev/null
@@ -1,224 +0,0 @@
-If you have akcl version 604 or newer, do not make these patches.
-
-
-(1) Turbo closure patch
-
-To make the turbo closure stuff work, make the following changes to KCL.
-These changes can also work for an IBCL.
-
-The three patches in this file add two features (reflected in the
-value of *features*) to your KCL or IBCL:
-  a feature named :TURBO-CLOSURE which increases the speed of the
-     code generated by FUNCALLABLE-INSTANCE-DATA-1
-     (previous versions of the file kcl-mods.text had this feature only), 
-and
-  a feature named :TURBO-CLOSURE-ENV-SIZE which increases the speed
-     of the function FUNCALLABLE-INSTANCE-P.
-
-(This file comprises two features rather than just one to allow the
-PCL system to be work in KCL systems that do not have this patch,
-or that have the old version of this patch.)
-
-
-The first of these patches changes the turbo_closure function to
-store the size of the environment in the turbo structure.
-
-The second of patch fixes a garbage-collector bug in which
-the turbo structure was sometimes ignored, AND also adapts
-the garbage-collector to conform to the change made in the
-first patch.  The bug has been fixed in newer versions of
-AKCL, but it is still necessary to apply this patch, if the
-first and third patches are applied.
-
-The third change pushes :turbo-closure and :turbo-closure-env-size
-on the *features* list so that PCL will know that turbo closures 
-are enabled.
-
-
-Note that these changes have to be made before PCL is compiled, and a
-PCL which is compiled in a KCL/IBCL with these changes can only be run
-in a KCL/IBCL with these changes.
-
-(1-1) edit the function turbo_closure in the file kcl/c/cfun.c,
-change the lines
-----------
-turbo_closure(fun)
-object fun;
-{
-        object l;
-        int n;
-
-        for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr)
-                ;
-        fun->cc.cc_turbo = (object *)alloc_contblock(n*sizeof(object));
-        for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr)
-                fun->cc.cc_turbo[n] = l;
-}
-----------
-to
-----------
-turbo_closure(fun)
-object fun;
-{
-  object l,*block;
-  int n;
-
-  if(fun->cc.cc_turbo==NULL)
-    {for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr);
-     block=(object *)alloc_contblock((1+n)*sizeof(object));
-     *block=make_fixnum(n);
-     fun->cc.cc_turbo = block+1; /* equivalent to &block[1] */
-     for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr)
-       fun->cc.cc_turbo[n] = l;}
-}
-----------
-
-
-(1-2) edit the function mark_object in the file kcl/c/gbc.c,
-Find the lines following case t_cclosure: in mark_object.
-If they look like the ones between the lines marked (KCL),
-make the first change, but if the look like the lines marked
-(AKCL), apply the second change instead, and if the file
-sgbc.c exists, apply the third change to it.
-(1-2-1) Change:
-(KCL)----------
-        case t_cclosure:
-                mark_object(x->cc.cc_name);
-                mark_object(x->cc.cc_env);
-                mark_object(x->cc.cc_data);
-                if (x->cc.cc_start == NULL)
-                        break;
-                if (what_to_collect == t_contiguous) {
-                        if (get_mark_bit((int *)(x->cc.cc_start)))
-                                break;
-                        mark_contblock(x->cc.cc_start, x->cc.cc_size);
-                        if (x->cc.cc_turbo != NULL) {
-                                for (i = 0, y = x->cc.cc_env;
-                                     type_of(y) == t_cons;
-                                     i++, y = y->c.c_cdr);
-                                mark_contblock((char *)(x->cc.cc_turbo),
-                                               i*sizeof(object));
-                        }
-                }
-                break;
-(KCL)----------
-to
-(KCL new)----------
-        case t_cclosure:
-                mark_object(x->cc.cc_name);
-                mark_object(x->cc.cc_env);
-                mark_object(x->cc.cc_data);
-                if (what_to_collect == t_contiguous)
-                        if (x->cc.cc_turbo != NULL) {
-                                mark_contblock((char *)(x->cc.cc_turbo-1),
-                                               (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object));
-                        }
-                if (x->cc.cc_start == NULL)
-                        break;
-                if (what_to_collect == t_contiguous) {
-                        if (get_mark_bit((int *)(x->cc.cc_start)))
-                                break;
-                        mark_contblock(x->cc.cc_start, x->cc.cc_size);
-                }
-                break;
-(KCL new)----------
-(1-2-2) Or, Change:
-(AKCL)----------
-        case t_cclosure:
-                mark_object(x->cc.cc_name);
-                mark_object(x->cc.cc_env);
-                mark_object(x->cc.cc_data);
-                if (what_to_collect == t_contiguous) {
-                  if (x->cc.cc_turbo != NULL) {
-                    for (i = 0, y = x->cc.cc_env;
-                         type_of(y) == t_cons;
-                         i++, y = y->c.c_cdr);
-                    mark_contblock((char *)(x->cc.cc_turbo),
-                                               i*sizeof(object));
-                        }
-                }
-                break;
-(AKCL)----------
-To:
-(AKCL new)----------
-        case t_cclosure:
-                mark_object(x->cc.cc_name);
-                mark_object(x->cc.cc_env);
-                mark_object(x->cc.cc_data);
-                if (what_to_collect == t_contiguous) {
-                  if (x->cc.cc_turbo != NULL)
-                    mark_contblock((char *)(x->cc.cc_turbo-1),
-                                   (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object));
-                }
-                break;
-(AKCL new)----------
-(1-2-3) In sgbc.c (if it exists), Change:
-(AKCL)----------
-        case t_cclosure:
-                sgc_mark_object(x->cc.cc_name);
-                sgc_mark_object(x->cc.cc_env);
-                sgc_mark_object(x->cc.cc_data);
-                if (what_to_collect == t_contiguous) {
-                  if (x->cc.cc_turbo != NULL) {
-                    for (i = 0, y = x->cc.cc_env;
-                         type_of(y) == t_cons;
-                         i++, y = y->c.c_cdr);
-                    mark_contblock((char *)(x->cc.cc_turbo),
-                                               i*sizeof(object));
-                        }
-                }
-                break;
-(AKCL)----------
-To:
-(AKCL new)----------
-        case t_cclosure:
-                sgc_mark_object(x->cc.cc_name);
-                sgc_mark_object(x->cc.cc_env);
-                sgc_mark_object(x->cc.cc_data);
-                if (what_to_collect == t_contiguous) {
-                  if (x->cc.cc_turbo != NULL)
-                    mark_contblock((char *)(x->cc.cc_turbo-1),
-                                   (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object));
-                }
-                break;
-(AKCL new)----------
-
-
-(1-3) edit the function init_main in the file kcl/c/main.c,
-change the lines where setting the value of *features* to add a :turbo-closure
-and a :turbo-closure-env-size into the list in your KCL/IBCL.
-
-For example, in Sun4(SunOS) version of IBCL
-changing the lines:
-----------
-        make_special("*FEATURES*",
-                     make_cons(make_ordinary("SUN4"),
-                     make_cons(make_ordinary("SPARC"),
-                     make_cons(make_ordinary("IEEE-FLOATING-POINT"),
-                     make_cons(make_ordinary("UNIX"),
-                     make_cons(make_ordinary("BSD"),
-                     make_cons(make_ordinary("COMMON"),
-                     make_cons(make_ordinary("IBCL"), Cnil))))))));
-----------
-to
-----------
-        make_special("*FEATURES*",
-                     make_cons(make_ordinary("SUN4"),
-                     make_cons(make_ordinary("SPARC"),
-                     make_cons(make_ordinary("IEEE-FLOATING-POINT"),
-                     make_cons(make_ordinary("UNIX"),
-                     make_cons(make_ordinary("BSD"),
-                     make_cons(make_ordinary("COMMON"),
-                     make_cons(make_ordinary("IBCL"),
-                     make_cons(make_keyword("TURBO-CLOSURE"),
-                     make_cons(make_keyword("TURBO-CLOSURE-ENV-SIZE"),
-                     Cnil))))))))));
-----------
-But, if the C macro ADD_FEATURE is defined at the end of main.c,
-use it instead.
-Insert the lines:
-        ADD_FEATURE("TURBO-CLOSURE");
-        ADD_FEATURE("TURBO-CLOSURE-ENV-SIZE");
-After the line:
-        ADD_FEATURE("AKCL");
-
diff --git a/pcl/kcl-notes.text b/pcl/kcl-notes.text
deleted file mode 100644
index fc8a6831ed4cd0e27c5b13f0a3dab919b6047613..0000000000000000000000000000000000000000
--- a/pcl/kcl-notes.text
+++ /dev/null
@@ -1,39 +0,0 @@
-
-Some notes on using "5/1/90  May Day PCL (REV 4b)" with KCL and AKCL.
-
-1. KCL will try to load the PCL file "init" when it starts up,
-   if you rename the files as is mentioned in defsys.lisp and the 
-   currect directory is the one containing PCL.  I suggest that
-   you do not rename any file except maybe "defsys", and also 
-   that you change the (files-renamed-p t) to (files-renamed-p nil) 
-   in defsys.lisp.
-
-2. Do not comment out the file kcl-patches.lisp, even if you are
-   using AKCL.  It contins a patch to make compiler messages more
-   informative for AKCL, and also sets compiler::*compile-ordinaries*
-   to T, so that methods will get compiled.
-
-3. While fixup.lisp compiles, there will be a pause, because 
-   KCL's compiler is not reentrant, and some uncompiled
-   code is run.  If you want, you can change the form
-   (fix-early-generic-functions) to (fix-early-generic-functions t)
-   in fixup.lisp to see what is happening.
-
-4. (If you are using AKCL 605 or newer, skip this step.)
-   If you want, you can apply the changes in kcl-mods.text
-   to your KCL or AKCL to make PCL run faster.  The file kcl-mods.text
-   is different from what it was in versions of PCL earlier than
-   May Day PCL.  If you do not make these changes, or if you made 
-   the old changes, things will still work.
-
-5. If you are using AKCL, and you previously used the kcl-low.lisp
-   file from rascal.ics.utexas.edu, you should not use it this time.
-   The kcl-low.lisp that comes with May Day PCL works fine.  (If you
-   insist on using an old version of kcl-low.lisp, you will need to
-   use an old version of the KCL part of fin.lisp as well: this is
-   what is done for IBCL, by the way.) 
-
-6. I recommend that you use AKCL version 457 or newer rather than using
-   KCL or an older version of AKCL, because there are some bugs in KCL
-   that cause problems for May Day PCL.
-
diff --git a/pcl/kcl-patches.lisp b/pcl/kcl-patches.lisp
deleted file mode 100644
index c051d9be35d7b7dbd08d8139abc979ba6a239dd8..0000000000000000000000000000000000000000
--- a/pcl/kcl-patches.lisp
+++ /dev/null
@@ -1,362 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-
-(in-package "COMPILER")
-
-#+akcl
-(eval-when (compile load eval)
-
-(when (<= system::*akcl-version* 609)
-  (pushnew :pre_akcl_610 *features*))
-
-(if (and (boundp 'si::*akcl-version*)
-	 (>= si::*akcl-version* 604))
-    (progn
-      (pushnew :turbo-closure *features*)
-      (pushnew :turbo-closure-env-size *features*))
-    (when (fboundp 'si::allocate-growth) 
-      (pushnew :turbo-closure *features*)))
-
-;; patch around compiler bug.
-(when (<= si::*akcl-version* 609)
-  (let ((vcs "static int Vcs;
-"))
-    (unless (search vcs compiler::*cmpinclude-string*)
-      (setq compiler::*cmpinclude-string*
-	    (concatenate 'string vcs compiler::*cmpinclude-string*)))))
-
-(let ((rset "int Rset;
-"))
-  (unless (search rset compiler::*cmpinclude-string*)
-      (setq compiler::*cmpinclude-string*
-	    (concatenate 'string rset compiler::*cmpinclude-string*))))
-
-(when (get 'si::basic-wrapper 'si::s-data)
-  (pushnew :new-kcl-wrapper *features*)
-  (pushnew :structure-wrapper *features*))
-  
-)
-
-
-#+akcl
-(progn
-
-(unless (fboundp 'real-c2lambda-expr-with-key)
-  (setf (symbol-function 'real-c2lambda-expr-with-key)
-	(symbol-function 'c2lambda-expr-with-key)))
-
-(defun c2lambda-expr-with-key (lambda-list body)
-  (declare (special *sup-used*))
-  (setq *sup-used* t)
-  (real-c2lambda-expr-with-key lambda-list body))
-
-
-;There is a bug in the implementation of *print-circle* that
-;causes some akcl debugging commands (including :bt and :bl)
-;to cause the following error when PCL is being used:
-;Unrecoverable error: value stack overflow.
-
-;When a CLOS object is printed, travel_push_object ends up
-;traversing almost the whole class structure, thereby overflowing
-;the value-stack.
-
-;from lsp/debug.lsp.
-;*print-circle* is badly implemented in kcl.
-;it has two separate problems that should be fixed:
-;  1. it traverses the printed object putting all objects found
-;     on the value stack (rather than in a hash table or some
-;     other structure; this is a problem because the size of the value stack
-;     is fixed, and a potentially unbounded number of objects
-;     need to be traversed), and
-;  2. it blindly traverses all slots of any
-;     kind of structure including std-object structures.
-;     This is safe, but not always necessary, and is very time-consuming
-;     for CLOS objects (because it will always traverse every class).
-
-;For now, avoid using *print-circle* T when it will cause problems.
-
-(eval-when (compile eval)
-(defmacro si::f (op &rest args)
-    `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))
-
-(defmacro si::fb (op &rest args)
-    `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))
-)
-
-(defun si::display-env (n env)
-  (do ((v (reverse env) (cdr v)))
-      ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n)))
-    (or (and (consp (car v))
-	     (listp (cdar v)))
-	(return))
-    (let ((*print-circle* (can-use-print-circle-p (cadar v))))
-      (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v)))))
-
-(defun si::display-compiled-env ( plength ihs &aux
-				      (base (si::ihs-vs ihs))
-				      (end (min (si::ihs-vs (1+ ihs)) (si::vs-top))))
-  (format si::*display-string* "")
-  (do ((i base )
-       (v (get (si::ihs-fname ihs) 'si::debug) (cdr v)))
-      ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength)))
-    (let ((*print-circle* (can-use-print-circle-p (si::vs i))))
-    (format si::*display-string* "~a~@[~d~]=~s~@[,~]"
-	    (or (car v)  'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i)
-	    (si::fb < (setq i (si::f + i 1)) end)))))
-
-(clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)")
-(defentry objnull-p (object) (object "objnull_p"))
-
-(defun can-use-print-circle-p (x)
-  (catch 'can-use-print-circle-p
-    (can-use-print-circle-p1 x nil)))
-
-(defun can-use-print-circle-p1 (x so-far)
-  (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe?
-       (if (member x so-far)
-	   (throw 'can-use-print-circle-p t)
-	   (let ((so-far (cons x so-far)))
-	     (flet ((can-use-print-circle-p (x)
-		      (can-use-print-circle-p1 x so-far)))
-	       (typecase x
-		 (vector  (or (not (eq 't (array-element-type x)))
-			      (every #'can-use-print-circle-p x)))
-		 (cons    (and (can-use-print-circle-p (car x))
-			       (can-use-print-circle-p (cdr x))))
-		 (array   (or (not (eq 't (array-element-type x)))
-			      (let* ((rank (array-rank x))
-				     (dimensions (make-list rank)))
-				(dotimes (i rank)
-				  (setf (nth i dimensions) (array-dimension x i)))
-				(or (member 0 dimensions)
-				    (do ((cursor (make-list rank :initial-element 0)))
-					(nil)
-				      (declare (:dynamic-extent cursor))
-				      (unless (can-use-print-circle-p
-					       (apply #'aref x cursor))
-					(return nil))
-				      (when (si::increment-cursor cursor dimensions)
-					(return t)))))))
-		 (t (or (not (si:structurep x))
-			(let* ((def (si:structure-def x))
-			       (name (si::s-data-name def))
-			       (len (si::s-data-length def))
-			       (pfun (si::s-data-print-function def)))
-			  (and (null pfun)
-			       (dotimes (i len t)
-				 (unless (can-use-print-circle-p
-					  (si:structure-ref x name i))
-				   (return nil)))))))))))))
-
-(defun si::apply-display-fun (display-fun  n lis)  
-  (let ((*print-length* si::*debug-print-level*)
-	(*print-level* si::*debug-print-level*)
-	(*print-pretty* nil)
-	(*PRINT-CASE* :downcase)
-	(*print-circle* nil)
-	)
-    (setf (fill-pointer si::*display-string*) 0)
-    (format si::*display-string* "{")
-    (funcall display-fun n lis)
-    (when (si::fb > (fill-pointer si::*display-string*) n)
-      (setf (fill-pointer si::*display-string*) n)
-      (format si::*display-string* "..."))
-
-    (format si::*display-string* "}")
-    )
-  si::*display-string*
-  )
-
-;The old definition of this had a bug:
-;sometimes it returned without calling mv-values.
-(defun si::next-stack-frame (ihs &aux line-info li i k na)
-  (cond ((si::fb < ihs si::*ihs-base*)
-	 (si::mv-values nil nil nil nil nil))
-	((let (fun)
-	   ;; next lower visible ihs
-	   (si::mv-setq (fun i) (si::get-next-visible-fun ihs))
-	   (setq na fun)
-	   (cond ((and (setq line-info (get fun 'si::line-info))
-		       (do ((j (si::f + ihs 1) (si::f - j 1))
-			    (form ))
-			   ((<= j i) nil)
-			 (setq form (si::ihs-fun j))
-			 (cond ((setq li (si::get-line-of-form form line-info))
-				(return-from si::next-stack-frame 
-				  (si::mv-values
-				   i fun li
-				   ;; filename
-				   (car (aref line-info 0))
-				   ;;environment
-				   (list (si::vs (setq k (si::ihs-vs j)))
-					 (si::vs (1+ k))
-					 (si::vs (+ k 2)))))))))))))
-	((and (not (special-form-p na))
-	      (not (get na 'si::dbl-invisible))
-	      (fboundp na))
-	 (si::mv-values i na nil nil
-		    (if (si::ihs-not-interpreted-env i)
-			nil
-			(let ((i (si::ihs-vs i)))
-			  (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2)))))))
-	(t (si::mv-values nil nil nil nil nil))))
-)
-
-#+pre_akcl_610
-(progn
-
-;(proclaim '(optimize (safety 0) (speed 3) (space 1)))
-
-;Not needed... make-top-level-form generates defuns now.
-;(setq compiler::*compile-ordinaries* t)
-
-(eval-when (compile load eval)
-(unless (fboundp 'original-co1typep)
-  (setf (symbol-function 'original-co1typep) #'co1typep))
-)
-
-(defun new-co1typep (f args)
-  (or (original-co1typep f args)
-      (let ((x (car args))
-	    (type (cadr args)))
-	(when (constantp type)
-	  (let ((ntype (si::normalize-type (eval type))))
-	    (when (and (eq (car ntype) 'satisfies)
-		       (cadr ntype)
-		       (symbolp (cadr ntype))
-		       (symbol-package (cadr ntype)))
-	      (c1expr `(the boolean (,(cadr ntype) ,x)))))))))
-
-(setf (symbol-function 'co1typep) #'new-co1typep)
-
-)
-
-#-(or akcl xkcl)
-(progn
-(in-package 'system)
-
-;;;   This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere
-;;;   in the lambda-list.  The former allows deviation from the CL spec,
-;;;   but what the heck.
-
-(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
-
-(defvar *old-defmacro*)
-
-(defun new-defmacro (whole env)
-  (flet ((call-old-definition (new-whole)
-	   (funcall *old-defmacro* new-whole env)))
-    (if (not (and (consp whole)
-		  (consp (cdr whole))
-		  (consp (cddr whole))
-		  (consp (cdddr whole))))
-	(call-old-definition whole)
-	(let* ((ll (caddr whole))
-	       (env-tail (do ((tail ll (cdr tail)))
-			     ((not (consp tail)) nil)
-			   (when (eq '&environment (car tail))
-			     (return tail)))))
-	  (if env-tail
-	      (call-old-definition (list* (car whole)
-					  (cadr whole)
-					  (append (list '&environment
-							(cadr env-tail))
-						  (ldiff ll env-tail)
-						  (cddr env-tail))
-					  (cdddr whole)))
-	      (call-old-definition whole))))))
-
-(eval-when (load eval)
-  (unless (boundp '*old-defmacro*)
-    (setq *old-defmacro* (macro-function 'defmacro))
-    (setf (macro-function 'defmacro) #'new-defmacro)))
-
-;;;
-;;; setf patches
-;;;
-
-(defun get-setf-method (form)
-  (multiple-value-bind (vars vals stores store-form access-form)
-      (get-setf-method-multiple-value form)
-    (unless (listp vars)
-	    (error 
- "The temporary variables component, ~s, 
-  of the setf-method for ~s is not a list."
-             vars form))
-    (unless (listp vals)
-	    (error 
- "The values forms component, ~s, 
-  of the setf-method for ~s is not a list."
-             vals form))
-    (unless (listp stores)
-	    (error 
- "The store variables component, ~s,  
-  of the setf-method for ~s is not a list."
-             stores form))
-    (unless (= (list-length stores) 1)
-	    (error "Multiple store-variables are not allowed."))
-    (values vars vals stores store-form access-form)))
-
-(defun get-setf-method-multiple-value (form)
-  (cond ((symbolp form)
-	 (let ((store (gensym)))
-	   (values nil nil (list store) `(setq ,form ,store) form)))
-	((or (not (consp form)) (not (symbolp (car form))))
-	 (error "Cannot get the setf-method of ~S." form))
-	((get (car form) 'setf-method)
-	 (apply (get (car form) 'setf-method) (cdr form)))
-	((get (car form) 'setf-update-fn)
-	 (let ((vars (mapcar #'(lambda (x)
-	                         (declare (ignore x))
-	                         (gensym))
-	                     (cdr form)))
-	       (store (gensym)))
-	   (values vars (cdr form) (list store)
-	           `(,(get (car form) 'setf-update-fn)
-		     ,@vars ,store)
-		   (cons (car form) vars))))
-	((get (car form) 'setf-lambda)
-	 (let* ((vars (mapcar #'(lambda (x)
-	                          (declare (ignore x))
-	                          (gensym))
-	                      (cdr form)))
-		(store (gensym))
-		(l (get (car form) 'setf-lambda))
-		(f `(lambda ,(car l) 
-		      (funcall #'(lambda ,(cadr l) ,@(cddr l))
-			       ',store))))
-	   (values vars (cdr form) (list store)
-		   (apply f vars)
-		   (cons (car form) vars))))
-	((macro-function (car form))
-	 (get-setf-method-multiple-value (macroexpand-1 form)))
-	(t
-	 (error "Cannot expand the SETF form ~S." form))))
-
-)
-
diff --git a/pcl/lap.lisp b/pcl/lap.lisp
deleted file mode 100644
index 3e250fa5aab22fa5b169e63d5b83b18e4d51d7be..0000000000000000000000000000000000000000
--- a/pcl/lap.lisp
+++ /dev/null
@@ -1,500 +0,0 @@
-;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package 'pcl)
-
-;;;
-;;; This file defines PCL's interface to the LAP mechanism.
-;;;
-;;; The file is divided into two parts.  The first part defines the interface
-;;; used by PCL to create abstract LAP code vectors.  PCL never creates lists
-;;; that represent LAP code directly, it always calls this mechanism to do so.
-;;; This provides a layer of error checking on the LAP code before it gets to
-;;; the implementation-specific assembler.  Note that this error checking is
-;;; syntactic only, but even so is useful to have.  Because of it, no specific
-;;; LAP assembler should worry itself with checking the syntax of the LAP code.
-;;;
-;;; The second part of the file defines the LAP assemblers for each PCL port.
-;;; These are included together in the same file to make it easier to change
-;;; them all should some random change be made in the LAP mechanism.
-;;;
-
-(defvar *make-lap-closure-generator*)
-(defvar *precompile-lap-closure-generator*)
-(defvar *lap-in-lisp*)
-
-(defun make-lap-closure-generator 
-    (closure-variables arguments iregs vregs fvregs tregs lap-code)
-  (funcall *make-lap-closure-generator*
-	   closure-variables arguments iregs 
-	   vregs fvregs tregs lap-code))
-
-(defmacro precompile-lap-closure-generator 
-    (cvars args i-regs v-regs fv-regs t-regs lap)
-  (funcall *precompile-lap-closure-generator* cvars args i-regs 
-	   v-regs fv-regs t-regs lap))
-
-(defmacro lap-in-lisp (cvars args iregs vregs fvregs tregs lap)
-  (declare (ignore cvars args))
-  `(locally (declare #.*optimize-speed*)
-     ,(make-lap-prog iregs vregs fvregs tregs
-		     (flatten-lap lap (opcode :label 'exit-lap-in-lisp)))))
-
-
-;;;
-;;; The following functions and macros are used by PCL when generating LAP
-;;; code:
-;;;
-;;;  GENERATING-LAP
-;;;  WITH-LAP-REGISTERS
-;;;  ALLOCATE-REGISTER
-;;;  DEALLOCATE-REGISTER
-;;;  LAP-FLATTEN
-;;;  OPCODE
-;;;  OPERAND
-;;; 
-(proclaim '(special *generating-lap*))		;CAR   - alist of free registers
-						;CADR  - alist of allocated registers
-						;CADDR - max reg number allocated
-						;
-						;in each alist, the entries have
-						;the form:  (type . (:REG <n>))
-						;
-
-;;;
-;;; This goes around the generation of any lap code.  <body> should return a lap
-;;; code sequence, this macro will take care of converting that to a lap closure
-;;; generator.
-;;; 
-(defmacro generating-lap (closure-variables arguments &body body)
-  `(let* ((*generating-lap* (list () () -1)))
-     (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body))))
-
-(defmacro generating-lap-in-lisp (closure-variables arguments &body body)
-  `(let* ((*generating-lap* (list () () -1)))
-     (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body))))
-
-;;;
-;;; Each register specification looks like:
-;;;
-;;;  (<var> <type> &key :reuse <other-reg>)
-;;;  
-(defmacro with-lap-registers (register-specifications &body body)
-  ;;
-  ;; Given that, for now, there is only one keyword argument and
-  ;; that, for now, we do no error checking, we can be pretty
-  ;; sleazy about how this works.
-  ;;
-  (flet ((make-allocations ()
-	   (gathering1 (collecting)
-	     (dolist (spec register-specifications)
-	       (gather1
-		 `(,(car spec) (or ,(cadddr spec) (allocate-register ',(cadr spec))))))))
-	 (make-deallocations ()
-	   (gathering1 (collecting)
-	     (dolist (spec register-specifications)
-	       (gather1
-		 `(unless ,(cadddr spec) (deallocate-register ,(car spec))))))))
-    `(let ,(make-allocations)
-       (multiple-value-prog1 (progn ,@body)
-			     ,@(make-deallocations)))))
-
-(defun allocate-register (type)
-  (destructuring-bind (free allocated) *generating-lap*
-    (let ((entry (assoc type free)))
-      (cond (entry
-	     (setf (car *generating-lap*)  (delete entry free)
-		   (cadr *generating-lap*) (cons entry allocated))
-	     (cdr entry))
-	    (t
-	     (let ((new `(,type . (:reg ,(incf (caddr *generating-lap*))))))
-	       (setf (cadr *generating-lap*) (cons new allocated))
-	       (cdr new)))))))
-
-(defun deallocate-register (reg)
-  (let ((entry (rassoc reg (cadr *generating-lap*))))
-    (unless entry (error "Attempt to free an unallocated register."))
-    (push entry (car *generating-lap*))
-    (setf (cadr *generating-lap*) (delete entry (cadr *generating-lap*)))))
-
-(defvar *precompiling-lap* nil)
-
-(defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code)
-  (when (cadr *generating-lap*) (error "Registers still allocated when lap being finalized."))
-  (let ((iregs ())
-	(vregs ())
-	(fvregs ())
-	(tregs ()))
-    (dolist (entry (car *generating-lap*))
-      (ecase (car entry)
-	(index  (push (caddr entry) iregs))
-	(vector (push (caddr entry) vregs))
-	(fixnum-vector (push (caddr entry) fvregs))
-	((t)    (push (caddr entry) tregs))))
-    (cond (in-lisp-p
-	   `(lap-in-lisp ,closure-variables ,arguments ,iregs 
-	                 ,vregs ,fvregs ,tregs ,lap-code))
-	  (*precompiling-lap*
-	   `(precompile-lap-closure-generator 
-	     ,closure-variables ,arguments ,iregs
-	     ,vregs ,fvregs ,tregs ,lap))
-	  (t
-	   (make-lap-closure-generator
-	     closure-variables arguments iregs 
-	     vregs fvregs tregs lap-code)))))
-
-(defun flatten-lap (&rest opcodes-or-sequences)
-  (let ((result ()))
-    (dolist (opcode-or-sequence opcodes-or-sequences result)
-      (cond ((null opcode-or-sequence))
-            ((not (consp (car opcode-or-sequence)))     ;its an opcode
-             (setf result (append result (list opcode-or-sequence))))
-            (t
-             (setf result (append result opcode-or-sequence)))))))
-
-(defmacro flattening-lap ()
-  '(let ((result ()))
-    (values #'(lambda (value) (push value result))
-     #'(lambda () (apply #'flatten-lap (reverse result))))))
-
-
-
-;;;
-;;; This code deals with the syntax of the individual opcodes and operands.
-;;; 
-  
-;;;
-;;; The first two of these variables are documented to all ports.  They are
-;;; lists of the symbols which name the lap opcodes and operands.  They can
-;;; be useful to determine whether a port has implemented all the required
-;;; opcodes and operands.
-;;;
-;;; The third of these variables is for use of the emitter only.
-;;; 
-(defvar *lap-operands* ())
-(defvar *lap-opcodes*  ())
-(defvar *lap-emitters* (make-hash-table :test #'eq :size 30))
-
-(defun opcode (name &rest args)
-  (let ((emitter (gethash name *lap-emitters*)))
-    (if emitter
-	(apply emitter args)
-	(error "No opcode named ~S." name))))
-
-(defun operand (name &rest args)
-  (let ((emitter (gethash name *lap-emitters*)))
-    (if emitter
-	(apply emitter args)
-	(error "No operand named ~S." name))))
-
-(defmacro defopcode (name types)
-  (let ((fn-name (symbol-append "LAP Opcode " name *the-pcl-package*))
-	(lambda-list
-	  (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types)))
-    `(progn
-       (eval-when (load eval) (load-defopcode ',name ',fn-name))
-       (defun ,fn-name ,lambda-list
-	 #+Genera (declare (sys:function-parent ,name defopcode))
-	 (defopcode-1 ',name ',types ,@lambda-list)))))
-
-(defmacro defoperand (name types)
-  (let ((fn-name (symbol-append "LAP Operand " name *the-pcl-package*))
-	(lambda-list
-	  (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types)))
-    `(progn
-       (eval-when (load eval) (load-defoperand ',name ',fn-name))
-       (defun ,fn-name ,lambda-list
-	 #+Genera (declare (sys:function-parent ,name defoperand))
-	 (defoperand-1 ',name ',types ,@lambda-list)))))
-
-(defun load-defopcode (name fn-name)
-  (if* (memq name *lap-operands*)
-       (error "LAP opcodes and operands must have disjoint names.")
-       (setf (gethash name *lap-emitters*) fn-name)
-       (pushnew name *lap-opcodes*)))
-
-(defun load-defoperand (name fn-name)
-  (if* (memq name *lap-opcodes*)
-       (error "LAP opcodes and operands must have disjoint names.")
-       (setf (gethash name *lap-emitters*) fn-name)
-       (pushnew name *lap-operands*)))
-
-(defun defopcode-1 (name operand-types &rest args)
-  (iterate ((arg (list-elements args))
-	    (type (list-elements operand-types)))
-    (check-opcode-arg name arg type))
-  (cons name (copy-list args)))
-
-(defun defoperand-1 (name operand-types &rest args)
-  (iterate ((arg (list-elements args))
-	    (type (list-elements operand-types)))
-    (check-operand-arg name arg type))
-  (cons name (copy-list args)))
-
-(defun check-opcode-arg (name arg type)
-  (labels ((usual (x)
-	     (and (consp arg) (eq (car arg) x)))
-	   (check (x)
-	     (ecase x	       
-	       ((:reg :cdr :constant :iref :instance-ref :cvar :arg :lisp :lisp-variable)
-		(usual x))
-	       (:label (symbolp arg))
-	       (:operand (and (consp arg) (memq (car arg) *lap-operands*))))))
-    (unless (if (consp type)
-		(if (eq (car type) 'or)
-		    (some #'check (cdr type))
-		    (error "What type is this?"))
-		(check type))
-      (error "The argument ~S to the opcode ~A is not of type ~S." arg name type))))
-
-(defun check-operand-arg (name arg type)  
-  (flet ((check (x)
-	   (ecase x
-	     (:symbol           (symbolp arg))
-	     (:register-number  (and (integerp arg) (>= arg 0)))
-	     (:t                t)
-	     (:reg              (and (consp arg) (eq (car arg) :reg)))
-	     (:fixnum           (typep arg 'fixnum)))))
-    (unless (if (consp type)
-		(if (eq (car type) 'or)
-		    (some #'check (cdr type))
-		    (error "What type is this?"))
-		(check type))
-      (error "The argument ~S to the operand ~A is not of type ~S." arg name type))))
-
-
-
-;;;
-;;; The actual opcodes.
-;;;
-(defopcode :break ())				;For debugging only.  Not
-(defopcode :beep  ())				;all ports are required to
-(defopcode :print (:reg))			;implement this.
-
-
-(defopcode :move (:operand (or :reg :iref :instance-ref :cdr :lisp-variable)))
-
-(defopcode :eq     ((or :reg :constant) (or :reg :constant) :label))
-(defopcode :neq    ((or :reg :constant) (or :reg :constant) :label))
-(defopcode :fix=   ((or :reg :constant) (or :reg :constant) :label))
-(defopcode :izerop (:reg :label))
-
-(defopcode :std-instance-p       (:reg :label))
-(defopcode :fsc-instance-p       (:reg :label))
-(defopcode :built-in-instance-p  (:reg :label))
-(defopcode :structure-instance-p (:reg :label))
-
-(defopcode :jmp      ((or :reg :constant)))
-(defopcode :emf-call ((or :reg :constant)))
-
-(defopcode :label  (:label))
-(defopcode :go     (:label))
-
-(defopcode :return ((or :reg :constant)))
-
-(defopcode :exit-lap-in-lisp ())
-
-;;;
-;;; The actual operands.
-;;;
-(defoperand :reg  (:register-number))
-(defoperand :cvar (:symbol))
-(defoperand :arg  (:symbol))
-
-(defoperand :cdr  (:reg))
-
-(defoperand :constant (:t))
-
-(defoperand :std-wrapper       (:reg))
-(defoperand :fsc-wrapper       (:reg))
-(defoperand :built-in-wrapper  (:reg))
-(defoperand :structure-wrapper (:reg))
-(defoperand :other-wrapper     (:reg))
-(defoperand :built-in-or-structure-wrapper (:reg))
-
-(defoperand :std-slots (:reg))
-(defoperand :fsc-slots (:reg))
-
-(defoperand :wrapper-cache-number-vector (:reg))
-
-(defoperand :cref (:reg :fixnum))
-
-(defoperand :iref (:reg :reg))
-(defoperand :iset (:reg :reg :reg))
-
-(defoperand :instance-ref (:reg :reg))
-(defoperand :instance-set (:reg :reg :reg))
-
-(defoperand :i1+     (:reg))
-(defoperand :i+      (:reg :reg))
-(defoperand :i-      (:reg :reg))
-(defoperand :ilogand (:reg :reg))
-(defoperand :ilogxor (:reg :reg))
-(defoperand :ishift  (:reg :fixnum))
-
-(defoperand :lisp (:t))
-(defoperand :lisp-variable (:symbol))
-
-
-
-;;;
-;;; LAP tests (there need to be a lot more of these)
-;;;
-#|
-(defun make-lap-test-closure-1 (result)
-  #'(lambda (arg1)
-      (declare (pcl-fast-call))
-      (declare (ignore arg1))
-      result))
-
-(defun make-lap-test-closure-2 (result)
-  #'(lambda (arg1 arg2)
-      (declare (pcl-fast-call))
-      (declare (ignore arg1 arg2))
-      result))
-
-(eval-when (eval)
-  (compile 'make-lap-test-closure-1)
-  (compile 'make-lap-test-closure-2))
-
-(proclaim '(special lap-win lap-lose))
-(eval-when (load eval)
-  (setq lap-win (make-lap-test-closure-1 'win)
-	lap-lose (make-lap-test-closure-1 'lose)))
-
-(defun lap-test-1 ()
-  (let* ((cg (generating-lap '(cache)
-			     '(arg)
-	       (with-lap-registers ((i0 index)
-				    (v0 vector)
-				    (t0 t))
-		 (flatten-lap 
-		   (opcode :move (operand :cvar 'cache) v0)
-		   (opcode :move (operand :arg 'arg) i0)
-		   (opcode :move (operand :iref v0 i0) t0)
-		   (opcode :jmp t0)))))
-	 
-	 (cache (make-array 32))
-	 (closure (funcall cg cache))
-	 (fn0 (make-lap-test-closure-1 'fn0))
-	 (fn1 (make-lap-test-closure-1 'fn1))
-	 (fn2 (make-lap-test-closure-1 'fn2))
-	 (in0 (index-value->index 2))
-	 (in1 (index-value->index 10))
-	 (in2 (index-value->index 27)))
-    
-    (setf (svref cache (index->index-value in0)) fn0
-	  (svref cache (index->index-value in1)) fn1
-	  (svref cache (index->index-value in2)) fn2)
-    
-    (unless (and (eq (funcall closure in0) 'fn0)
-		 (eq (funcall closure in1) 'fn1)
-		 (eq (funcall closure in2) 'fn2))
-      (error "LAP TEST 1 failed."))))
-
-(defun lap-test-2 ()            
-  (let* ((cg (generating-lap '(cache mask) 
-			     '(arg)
-	       (with-lap-registers ((i0 index)
-				    (i1 index)
-				    (i2 index)
-				    (v0 vector)
-				    (t0 t))
-
-		 (flatten-lap		  
-		   (opcode :move (operand :cvar 'cache) v0)
-		   (opcode :move (operand :arg 'arg) i0)
-		   (opcode :move (operand :cvar 'mask) i1)
-		   (opcode :move (operand :ilogand i0 i1) i2)
-		   (opcode :move (operand :iref v0 i2) t0)
-		   (opcode :jmp t0)))))
-	 (cache (make-array 32))
-	 (mask #b00110)
-	 (closure (funcall cg cache mask))
-	 (in0 (index-value->index #b00010))
-	 (in1 (index-value->index #b01010))
-	 (in2 (index-value->index #b10011)))
-    (fill cache lap-lose)
-    (setf (svref cache (index->index-value in0)) lap-win)
-    
-    (unless (and (eq (funcall closure in0) 'win)
-		 (eq (funcall closure in1) 'win)
-		 (eq (funcall closure in2) 'win))
-      (error "LAP TEST 2 failed."))))
-
-(defun lap-test-3 ()            
-  (let* ((cg (generating-lap '(addend) '(arg)
-	       (with-lap-registers
-		 ((i0 index)
-		  (i1 index)
-		  (i2 index))
-
-		 (flatten-lap		  
-		   (opcode :move (operand :cvar 'addend) i0)
-		   (opcode :move (operand :arg 'arg) i1)
-		   (opcode :move (operand :i+ i0 i1) i2)
-		   (opcode :return i2)))))
-	 (closure (funcall cg (index-value->index 5))))
-    
-    (unless (= (index->index-value (funcall closure (index-value->index 2))) 7)
-      (error "LAP TEST 3 failed."))))
-
-(defun lap-test-4 ()            
-  (let* ((cg (generating-lap '(winner loser) '(arg)
-	       (with-lap-registers ((t0 t))
-		 (flatten-lap
-		   (opcode :move (operand :arg 'arg) t0)
-		   (opcode :eq t0 (operand :constant 'foo) 'win)
-		   (opcode :move (operand :cvar 'loser) t0)
-		   (opcode :jmp t0)
-		   (opcode :label 'win)
-		   (opcode :move (operand :cvar 'winner) t0)
-		   (opcode :jmp t0)))))
-	 (closure (funcall cg #'true #'false)))
-    (unless (and (eq (funcall closure 'foo) 't)
-		 (eq (funcall closure 'bar) 'nil))
-      (error "LAP TEST 4 failed."))))
-
-(defun lap-test-5 ()            
-  (let* ((cg (generating-lap '(array) '(arg)
-	       (with-lap-registers ((r0 vector)
-				    (r1 t)
-				    (r2 index))
-		 (flatten-lap
-		   (opcode :move (operand :cvar 'array) r0)
-		   (opcode :move (operand :arg 'arg) r1)
-		   (opcode :move (operand :constant (index-value->index 0)) r2)
-		   (opcode :move r1 (operand :iref r0 r2))
-		   (opcode :return r1)))))
-	 (array (make-array 1))
-	 (closure (funcall cg array)))
-    (unless (and (=  (funcall closure 1)    (svref array 0))
-		 (eq (funcall closure 'foo) (svref array 0)))
-      (error "LAP TEST 5 failed."))))
-
-|#
-
diff --git a/pcl/lap.text b/pcl/lap.text
deleted file mode 100644
index b7419f74fe45c3edb3cc45240bb076dfb56d5798..0000000000000000000000000000000000000000
--- a/pcl/lap.text
+++ /dev/null
@@ -1,655 +0,0 @@
--*- Mode: Text -*-
-
-Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation.
-All rights reserved.
-
-Use and copying of this document is permitted.  Any distribution of this
-document must comply with all applicable United States export control
-laws.
-
-Last updated: 6/3/89 by Gregor
-              10/26/89 by Gregor -- added :RETURN, removed :ISHIFT
-
-This file contains documentation of the PCL abstract LAP code.  Any port
-of PCL is required to implement the abstract LAP code interface.  There
-is a portable, relatively good performance implementation in the file
-lap.lisp, port-specific implementations are in that file as well.
-
-The PCL abstract LAP code mechanism exists to provide PCL with a way to
-create high-performance method lookup functions.  Using this mechanism,
-PCL can produce "LAP closures" which do the method lookup.  By allowing
-PCL to specify these closures using abstract LAP code rather that Lisp
-code we hope to achieve the following:
-
-  * Better runtime performance.  By using abstract LAP code, we
-    will get better machine instruction sequences than we would
-    from compiling Lisp code. 
-
-  * Better load and update time performance.  Because it should
-    be possible to "assemble" the LAP code more quickly than
-    compiling Lisp code, PCL will spend less time building the
-    method lookup code.
-
-  * Ability to use PCL without a compiler.  The LAP assembler will
-    still be required but this should be much smaller than the full
-    lisp compiler.
-
-Of course, not all implementations of the LAP code mechanism will
-satisfy all of these goals.  The first is the most important.
-
-In particular, many PCL ports will use the portable LAP implementation.
-KCL will use the portable implementation in all of its ports.  Other
-Lisps may have custom LAP implementations for some ports and use the
-portable implementation for other ports.
-
-Some Lisps will have a custom LAP implementation but will nonetheless
-require the compiler to be loaded to generate LAP closure constructors.
-
-An important point is why we have chosen to take this route rather than
-have each implementation implement the method lookup codes itself.  This
-was done because we are, at PARC, just beginning to study cache behavior
-for CLOS programs.  As we learn more about this we will want to modify
-the caching strategy PCL uses.  This architecture, because it leaves
-PCL to implement caching behavior makes it possible to do this.  Once
-this study is complete, implementations may want to do their own, ultra
-high performance implementations of caching strategies.
-
-
-
-Production of LAP closures is a two step process.  In the first step, a
-port-specific function is called to take abstract LAP code and produce a
-a "lap closure generator".  Lap closure generators are functions which
-are called with a set of closure variable values and return a LAP
-closure.
-
-The intermediary of the lap closure generators provides an important
-optimization.  Because it is assumed that producing the LAP closure
-generator can take much longer than producing a LAP closure from the
-generator, PCL attempts to make only one closure generator for each
-sequence of LAP code.  Because of the way PCL generates the LAP code
-sequences, this is quite easy for it to do.
-
-The rest of this document is divided into six parts.  
-
-  * the metatypes std-instance and fsc-instance
-
-  * an abstraction for simple vector indices
-
-  * important optimizations
-
-  * the port specific function for making lap closure generators
-
-  * the actual abstract LAP code
-
-  * examples
-
-*** The metatypes STD-INSTANCE and FSC-INSTANCE ***
-
-In PCL, instances with metaclass STANDARD-CLASS are represented using
-the metatype STD-INSTANCE.  (Note that in Cinco de Mayo PCL, this
-metatype is called IWMC-CLASS.)  Each port must implement this metatype.
-The metatype could be implemented by the following DEFSTRUCT.
-
-   (defstruct (std-instance 
-                (:predicate std-instance-p)
-                (:conc-name %std-instance-)
-                (:constructor %allocate-std-instance (wrapper slots))
-                (:constructor %allocate-std-instance-1 ())
-                (:print-function print-std-instance))
-     (wrapper nil)
-     (slots nil))
-
- PCL itself will guarantee correct access to this structure and the
- accessors and constructors.  With this in mind, the following are
- important.
-
- * Being able to type test this structure quickly is critical. See 
-   the :STD-INSTANCE-P opcode.
-
- * The allocation functions should compile inline, do no argument
-   checking and be as fast as possible.
-
- * The accessor functions should compile inline, do no checking of their
-   arguments and be as fast as possible.  SETF of the accessors should
-   do the same.
-
-The port is also required to implement the metatype FSC-INSTANCE (called
-FUNCALLABLE-INSTANCE, or FIN for short, in Cinco de Mayo PCL).  Objects
-with this metatype are used, among other things, to implement generic
-functions.  These objects have field structure associated with them and
-are also functions that can be applied to arguments.  The fields are the
-same as those for STD-INSTANCE, the FSC-INSTANCE metatype has
-predicates, print-functions, constructors and accessors as follows:
-
-  fsc-instance-p
-  print-fsc-instance
-  %fsc-instance-wrapper
-  %fsc-instance-slots
-  %allocate-fsc-instance (wrapper slots)
-  %allocate-fsc-instance-1 ()
-
-In addition, objects of metatype FSC-INSTANCE have a property called the
-funcallable instance function.  When an FSC-INSTANCE is applied to
-arguments, the funcallable instance function is what is actually called.
-The funcallable instance function of an FSC-INSTANCE can be changed
-using the function SET-FUNCALLABLE-INSTANCE-FUNCTION.  There is no
-mechanism for obtaining the funcallable instance function of an
-FSC-INSTANCE.
-
-It is possible to implement the FSC-INSTANCE metatype in pure Common
-Lisp. A simple implementation which uses lexical closures as the
-instances and a hash table to record that the lexical closures are of
-metatype FSC-INSTANCE is easy to write.  Unfortunately, this
-implementation adds significant overhead:
-
-   to generic-function-invocation (1 function call)
-   to slot-access (1 function call or one hash table lookup)
-   to class-of a generic-function (1 hash-table lookup)
-
-In addition, it would prevent the FSC-INSTANCEs from being garbage
-collected.  In short, the pure Common Lisp implementation really isn't
-practical.
-
-Note that previous implementations of FINS were always based on the
-lexical closure metatype.  In some ports, that provides poor
-performance.  Those ports may want to consider reimplementing to use the
-compiled code metatype.  In that implementation strategy, LAP closure
-variables would become constants of the compiled code object.
-
-The following note from JonL is of interest when working on a FIN
-implementation:
-
-  Date: Tue, 16 May 89 05:45:56 PDT
-  From: Jon L White <jonl@lucid.com>
-  
-  This isn't a bug in Lucid's compiler -- it's a lurking bug in PCL
-  that will "bite" most implementations where different settings of
-  the compiler optimization switches will produce morphologically
-  different (but of course functionally equivalent) function objects.
-  
-  The difficulty is in how discriminator codes service cache misses.  
-  They  "call out" to (potentially) random functions that will in some 
-  cases "smash" the function object that was actually running as the 
-  discriminator code.  This is all right providing you don't return to 
-  that function frame, but alas ...
-   
-  I know this is a more extensive problem because the code in the
-  port-independent function 'notice-methods-change' goes out of
-  its way to do a tail-recursive call to the function that is going
-  to smash the possibly-executing discriminator code.  Here is the
-  commentary from that code (sic):
-  
-  ;; In order to prevent this we take a simple measure:  we just
-  ;; make sure that it doesn't try to reference our its own closure
-  ;; variables after it makes the dcode change.  This is done by
-  ;; having notice-methods-change-2 do the work of making the change
-  ;; AND calling the actual generic function (a closure variable)
-  ;; over.  This means that at the time the dcode change is made,
-  ;; there is a pointer to the generic function on the stack where
-  ;; it won't be affected by the change to the closure variables.
-  
-  
-  A similar thing should be done in the construction of standard-accessor, 
-  checking, and  caching dcodes.  In an experimental version here at Lucid, 
-  I rewrote  dcode.lisp to do that, and there is no problem with it.  
-  Although that code is somewhat Lucid-specific, it could be of help to 
-  someone who wanted to rewrite the generic dcode.lisp (no pun intended). 
-  Contact me privately if you are interested.
-  
-  Doing a tail-recursive call out of dcodes when there is a cache miss
-  is a good thing, regardless of other problems.  I think one might as
-  well do it.  However, I should point out that in the presence of 
-  multiprocessing, there is another more serious problem that cannot be
-  solved so simply.  Think about what happens when one process decides
-  to update a dcode while another process is still using it; no such
-  stack-maintenance discipline will fix this case.  A tail-recursive
-  exit from the dcode will *immensely* reduce the likelihood that
-  another process can sneak in during the interval in which the dcode
-  requires consistency in its function; but it can't reduce that
-  likelihood to zero.
-  
-  The more desirable thing to do is to put the whole "dcode" down one 
-  more level of indirection through the symbol-function cell of the 
-  generic function.  This is effectively what PCL's 'make-trampoline' 
-  function does, but unfortunately that is not a very efficient approach 
-  when you consider how most compilers will compile it.  Something akin 
-  to the "mattress-pads" in Steve Haflich's code (in the fin.lisp file) 
-  could probably be done for many other implementations as well.
-
-
-*** Index Operations ***
-
-Indexes are an abstraction for indexes into a simple vector.  This
-abstraction is used to make it possible to generate more efficient
-code to access simple vectors.  The idea being that this may make it
-possible to use alternate addressing modes to address these.
-
-The "index value" of an index is defined to be the fixnum of which that
-index is an alternate form.  So, using the Lisp function SVREF with the
-index value of an index accesses the same element as using the index
-with the appropriate access function or operand.
-
-The format of an index is unspecified, but is assumed to be something
-like a fixnum with certain bits ignored.  Accessing a vector using an
-index must be done using the appropriate special accessor function or
-opcode.
-
-Conversion from index values to indices and vice-versa can be done with
-the following functions:
-
-INDEX-VALUE->INDEX (index-value)
-INDEX->INDEX-VALUE (index)
-
-
-The following constant indicates the maximum index value an index can
-have in a given port.  This must be at least 2^16.
-
-INDEX-VALUE-LIMIT  - a fixnum, must be at least 2^16.
-
-
-MAKE-INDEX-MASK (<cache-size> <line-size>)
-
-This function is used to make index masks.  Because I am lazy, I show an
-implementation of it in the common case where indexes are just fixnums:
-
-  (defun make-index-mask (cache-size line-size)
-    (let ((cache-size-in-bits (floor (log cache-size 2)))
-          (line-size-in-bits (floor (log line-size 2)))
-          (mask 0))
-      (dotimes (i cache-size-in-bits) (setq mask (dpb 1 (byte 1 i) mask)))
-      (dotimes (i line-size-in-bits)  (setq mask (dpb 0 (byte 1 i) mask))) 
-      mask))
-
-*** Optimizations ***
-
-This section discusses two important optimizations related to LAP
-closures.  The first relates to calling LAP closures themselves, the
-second relates to calling other functions from LAP closures.
-
-The important point about calling LAP closures is that almost all of the
-time, LAP closures will be used as the funcallable-instance-function of
-funcallable instances.  It is required that LAP closures be funcallable
-themselves, but usually they will be stored in a FIN and the fin will
-then be funcalled.  This brings up several optimizations, including ones
-having to do with access to the closure variables of a LAP closure.
-
-When a LAP closure is used to do method lookup, the function the LAP
-closure ends up calling has the same number of required arguments as the
-LAP closure itself.  Since the LAP closure must check its required
-arguments to do the lookup, it is redundant for the function called to
-do so as well.  Since LAP closures do all calls in a tail recursive way,
-it should even be possible to optimize out certain parts of the normal
-stack frame initialization.
-
-A similar situation occurs between effective method functions and the
-individual method functions; the difference is that in effective method
-functions, the calls are not necessarily tail recursive.
-
-Consequently, it would be nice to have a way to call certain functions
-and inhibit the checking of required arguments.  This is made possible
-by use of the PCL-FAST-APPLY and PCL-FAST-FUNCALL macros together with
-the PCL-FAST-CALL compiler declaration.
-
-The PCL-FAST-CALL compiler declaration declares that a function may be
-fast called.  Not all callers of the function will necessarily fast call
-it, but most probably will.  The :JMP opcode can only be used to call a
-function compiled with the PCL-FAST-CALL declaration.
-
-The PCL-FAST-APPLY and PCL-FAST-FUNCALL macros are used to fast call a
-function.  The function argument must be a compiled function that has
-the PCL-FAST-CALL compiler declaration in its lambda declarations.
-
-The basic idea is that the PCL-FAST-CALL compiler declaration causes the
-compiler to set up an additional entrypoint to the function.  This
-entrypoint comes after checking of required arguments but before
-processing of other arguments.
-
-Note:  When FAST-APPLY is used, the required arguments will be given as
-separate arguments and all other arguments will appear as a single
-spread argument.  For example:
-
-(let ((fn (compile () '(lambda (a b &optional (c 'z))
-                         (declare (pcl-fast-call))
-                         (list a b c)))))
-
-  (pcl-fast-apply fn 'x 'y ())          ;legal
-  (pcl-fast-apply fn 'x 'y '(foo))      ;legal
-  (pcl-fast-apply fn '(a b c))          ;illegal
-  )
-
-*** Producing LAP Closure Generators ***
-
-Each implementation of the LAP code mechanism must provide a port
-specific function making lap closure generators.  In the portable
-implementation, this function is called PLAP-CLOSURE-GENERATOR.  In
-ExCL it should be called EXCL-LAP-CLOSURE-GENERATOR etc.
-
-At any time, the value of the variable *make-lap-closure-generator* is a
-symbol which names the function currently being used to make lap closure
-generators.
-
-The port specific function must accept arguments as follows:
-
-PLAP-CLOSURE-GENERATOR (<closure-vars>
-                        <args>
-                        <index-registers>
-                        <simple-vector-registers>
-                        <lap-code>)
-
-This returns a lap-closure generator.  A lap-closure generator is a
-function which is called with a number of arguments equal to the length
-of <closure-vars>.  These arguments are the values of the closure
-variables for the lap closure.  These values cannot be changed once the
-LAP closure is created.   PCL takes care of keeping track of
-lap-closure-generators it already has on hand and reusing them.  The
-function RESET-LAP-CLOSURE-GENERATORS can be called to force PCL to
-forget all the lap closure generators it has remembered.
-
-  <args> 
-
-A list of symbols.  This provides a way to name particular arguments to
-the LAP closure. Arguments which will not be referenced by name are
-given as NIL. All required arguments to the LAP closure are explicitly
-included (perhaps as NIL).  If &REST appears at the end of arguments it
-means that non-required arguments are allowed, these will be processed
-by the methods.  If &REST does not appear at the end of arguments, the
-lap closure should signal an error if more than the indicated number of
-arguments are supplied.
-
-Examples:
-
- -  (obj-0 obj-1)
-
-    Specifies a two argument lap closure.  If more or less than
-    two arguments are supplied an error is signalled.  Within
-    the actual lap code, both arguments can be referenced by
-    name (see the :ARG operand).
-
- -  (obj-0 nil &rest)
-
-    Specifies a two or more argument lap closure.  If less than
-    two arguments are supplied an error is signalled.  Within
-    the actual lap code, the first argument can be referenced by
-    name (see the :ARG operand).
-
-
-  <closure-vars>
-
-A list of symbols.  The closure will have these as closure variables.
-Within the lap code these can be accessed using the :CVAR operand.  The
-lap code cannot change these values.  SET-FUNCALLABLE-INSTANCE-FUNCTION
-is permitted to have the special knowledge that there are at most ?? of
-these and to be prepared to do something special when the funcallable
-instance function of a funcallable instance is set to a lap closure.
-
-  <index-registers>
-
-A list of register numbers.  These registers will be used only to hold
-indexes.  Other registers may be used to hold indexes as well, but the
-only values put into these registers will be indexes.
-
-  <simple-vector-registers>
-
-A list of register numbers.  These registers will be used only to hold
-simple-vectors.  Other registers may be used to hold simple-vectors as
-well, but the only values put into these registers will be
-simple-vectors.
-
-
-  <lap-code>
-
-The actual lap code for this closure.  This is a list of LAP code
-opcodes.  See the section "Abstract LAP Code" for more details.
-
-Each implementation must also supply a function named PRE-MAKE-xxx where
-xxx is the same as the name of its make-lap-closure-generator function.
-The macro doesn't evaluate its arguments, and when it appears in a file
-it should try to do some of the work at load time.  It might appear in a
-file like this:
-
-(eval-when (load)
-  (setq 1-arg-std-lap 
-        (pre-make-plap-closure-generator ...)))
-
-*** Abstract LAP Code ***
-
-Each lap code operand has the form: (opcode operand1 ... operandn).
-
-In some cases, the distinction between an operand and an opcode is
-somewhat arbitrary.  In general, opcodes have a significant "action"
-component to their behavior.  Operands select a piece of data to operate
-on.  Some operands select their data in a more complex way, but they are
-operands anyways.
-
-All data must be in a register before it can be operated on.   This
-requirement means that the only place a non-register operand can appear
-is as the first argument to the :move opcode.  (Actually, there is one
-other exception, a :iref operand can be the target of a move as well.)
-Moreover, only register operands can appear as the second argument to
-the :move opcode and this register must not appear in the <from>
-operand.
-
->> The operands are:
- 
- (:reg <n>)
-   
-A pseudo register.  <n> is an integer in the range [0 , 31].
-
-A particular implementation can map this to a real register, a memory
-location or the stack.  The abstract LAP code itself does not include
-the notion of a stack.
-
-PCL will attempt to optimize register use in two ways.  PCL itself will
-attempt to re-use registers whenever possible.  That is, the port should
-not have to worry with doing live register analysis for the registers.
-In addition, PCL will consider lower numbered registers to be "faster"
-than higher numbered ones.
-
-
- (:cvar <name>)
-
-A closure variable of the lap-closure.  <name> is a symbol.
-
-
- (:arg <name>)
-
-An argument to the LAP closure.  <name> is a symbol.
-
- (:std-wrapper <from>)
- (:fsc-wrapper <from>)
- (:built-in-wrapper <from>)
- (:structure-wrapper <from>)
- (:other-wrapper <from>)
-
-Get the class wrapper of <from>.  For std-instances and fsc-instances
-this just fetches the wrapper field.  The specific port is required to
-implement fast access to the wrappers of built-in, structure and other
-metatypes.  A callback mechanism allows the port to ask PCL to generate
-a class and wrapper for objects for which no class and wrapper exists
-yet.  This mechanism is <<to be spec'd out>>.
-
-
- (:std-slots <operand>)
- (:fsc-slots <operand>)
-
-Fetch the slots field of a std-instance or a fsc-instance.
-
- (:constant <constant>)
-
-This just allows inline constants. <constant> can be any Lisp object.
-
-The following operands operate on indexes.  Each is patterned after a
-Lisp function which would have a corresponding effect on the index value
-of the index.
-
- (:i1+ <index>)
- (:i+ <index-1> <index-2>)
- (:i- <index-1> <index-2>)
- (:ilogand <index-1> <index-2>)
- (:ilogxor <index-1> <index-2>)
-
-Like the corresponding Lisp functions.  
-
-
- (:iref <vector> <index>)
-
-Like the SVREF function.  <vector> must be a simple vector.
-
- (:cref <vector> <constant>)
-
-The :cref operand is for constant vector references.  <constant> must be
-a fixnum.
-
->> The opcodes are:
-
- (:move <from> <to>)
-
-A full word move operation.  
-
-
- (:eq <from1> <from2> <label>)
- (:neq <from1> <from2> <label>)
-
-EQ and NOT EQ conditional branches.  If the value contained in <from1>
-is EQ (or not) to the value contained in <from2>, jump to <label>.
-Otherwise continue execution at the next opcode.  <label> is a symbol.
-
- (:fix= <from1> <from2> <label>)
-
-A fixnum = conditional branch.
-
- (:izerop <from> <label>)
-
-Jump to label if and only if the index <from> is 0.
-
- (:std-instance-p <from> <destination-label>)
- (:fsc-instance-p <from> <destination-label>)
- (:built-in-instance-p <from> <destination-label>)
- (:structure-instance-p <from> <destination-label>)
-
-Test the metatype of <from> and dispatch.  If the metatype of from is of
-the specified type execution jumps to <destination-label>.  Otherwise,
-execution proceeds normally at the next opcode.  See the :xxx-wrapper
-operands.
-
- (:jmp <function>)
-
-fcn contains a function to call.  This must be a compiled function,
-which had the PCL-FAST-CALL declaration in it.  The call should be "tail
-recursive" in that whatever values it returns should be returned
-immediately from the LAP closure itself.
-
-Method lookup is implemented by finding a function in the cache and then
-using :JMP to call it.  The various kinds of traps are implemented by
-using :JMP to call a trap function that was stored in one of the closure
-variables.
-
- (:return <value>)
-
-Return immediately from the LAP closure.  <value> is the single value to
-return.
-
-In certain cases of method lookup when all the methods are accessor methods, 
-there is an important optimization which implements the slot access in the 
-discriminating function itself.  This opcode is used in that case.
-
- (:label <label>)
-
-Identifies a point in the lap code.  <label> is a symbol.  This can be
-the target of any of the control transfer opcodes (:GO, :EQ, :NEQ,
-:FIX=, :STD-INSTANCE-P, :FSC-INSTANCE-P, :STRUCTURE-INSTANCE-P,
-:BUILT-IN-INSTANCE-P)
-
- (:go <label>)
-
-Jump to the label <label>.  <label> is a symbol.
-
-*** Examples ***
-
-Here is an example of the use of the abstract LAP mechanism.  It doesn't
-use all operands or opcodes, but it is representative of the LAP
-sequences PCL will use.
-
-Several things are worth noting:
-  * This is, I believe, just about the simplest such sequence.  There
-    are some others of comparable simplicity, but none much simpler.
-
-  * A total of only 5 registers are used.  I haven't checked, but I
-    am pretty sure most all such code sequences will get by with 16
-    or less and many will stay under 8.
-
-(defun make-1-arg-std-dfun ()
-  (let ((cg
-	  (making-lap-closure-generator
-	    (initialize-lap-cvars '(cache mask reflect trap))	
-	    (initialize-lap-args '(a0))
-	    (initialize-lap-registers 4 4 3)
-	    (let ((cache (allocate-lap-register 'simple-vector))
-		  (count (allocate-lap-register))
-		  (wrapper (allocate-lap-register))
-		  (index (allocate-lap-register 'index))
-		  (t1 (allocate-lap-register))
-		  (t2 (allocate-lap-register))
-		  (i1 (allocate-lap-register 'index))
-		  (i2 (allocate-lap-register 'index)))
-
-	      (opcode :move (operand :cvar 'cache) cache)
-	      (opcode :move (operand :arg 'a0) t1)	      
-	      (opcode :std-instance-p t1 'std-instance)
-	      (opcode :go 'trap)
-	      (opcode :label 'std-instance)
-	      ;;
-	      ;; The stable register pattern for the rest of the code is:
-	      ;;   cache    Cache
-	      ;;   count    Cache count
-	      ;;   wrapper  Wrapper
-	      ;;   index    index under consideration
-	      ;;
-	      ;; Whenever we jump to HIT, this pattern must be in force.
-	      ;;
-	      (opcode :move (operand :std-wrapper t1) wrapper);
-	      (opcode :move (operand :cref cache 0) count)    ;
-	      (opcode :move (operand :cref wrapper 0) i2)     ;wrapper-no -> i2
-	      (opcode :move (operand :cvar 'mask) i1)	      ;mask       -> i1
-	      (opcode :move (operand :ilogand i1 i2) index)   ;
-						              ;
-	      (opcode :move (operand :iref cache index) t1)   ;key        -> t1
-	      (opcode :eq t1 wrapper 'hit)                    ;
-	      (opcode :move (operand :cvar 'reflect) i1)      ;reflect    -> i1
-	      (opcode :move index i2)		              ;index      -> i2
-	      (opcode :move (operand :i- i1 i2) index)	      ;
-	      (opcode :move (operand :iref cache index) t1)   ;key        -> t1
-	      (opcode :eq t1 wrapper 'hit)                    ;
-	      (opcode :go 'trap)
-	      
-	      ;;
-	      ;; To do the hit, we use registers as follows:
-	      ;;   0   cache comes in here
-	      ;;   1   cache count comes in here
-	      ;;   2   use this for the function
-	      ;;   3   index comes in here
-	      ;;   4   1+ index, then new count
-	      ;;   
-	      (opcode :label 'hit)
-	      (opcode :move (operand :i1+ index) i1)
-	      (opcode :move (operand :iref cache i1) t1)
-
-	      (opcode :move (operand :cref cache 0) t2)
-	      (opcode :fix= count t2 'call)
-	      (opcode :go 'trap)
-
-	      (opcode :label 'call)
-	      (opcode :jmp t1)
-
-	      (opcode :label 'trap)
-	      (opcode :move (operand :cvar 'trap) t1)
-	      (opcode :jmp t1)))))
-
-    (funcall cg
-	     (make-array 16)
-	     (make-index-mask 16 2)
-	     (- 16 2)
-	     #'(lambda (a)
-		 (declare (pcl-fast-call) (ignore a))
-		 (break "Trap")))))
-
diff --git a/pcl/list-functions.lisp b/pcl/list-functions.lisp
deleted file mode 100644
index f4601a439f50c732bb7105b6b19b0d3695862e7b..0000000000000000000000000000000000000000
--- a/pcl/list-functions.lisp
+++ /dev/null
@@ -1,141 +0,0 @@
-
-(in-package :pcl)
-
-(defvar *defun-list* nil)
-(defvar *defmethod-list* nil)
-(defvar *defmacro-list* nil)
-(defvar *defgeneric-list* nil)
-
-(defun list-functions (&optional print-p)
-  (let ((eof '(eof))
-	(*package* *package*))
-    (setq *defun-list* nil
-	  *defmethod-list* nil
-	  *defmacro-list* nil)
-    (labels ((process-form (form)
-	       (when (consp form)
-		 (case (car form)
-		   ((in-package export import shadow shadowing-import) (eval form))
-		   #+lcl3.0 (lcl:handler-bind (eval form))
-		   (let (when print-p (print form)))
-		   (defun (push (list (cadr form) (caddr form))
-				*defun-list*))
-		   (defmethod (push (list (cadr form) (caddr form)) 
-				    *defmethod-list*))
-		   (defmacro (push (list (cadr form) (caddr form)) 
-				   *defmacro-list*))
-		   (defgeneric (push (list (cadr form) (caddr form)) 
-				     *defgeneric-list*))
-		   (eval-when (mapc #'process-form (cddr form)))
-		   (progn (mapc #'process-form (cdr form)))
-		   ((defvar defparameter defconstant proclaim 
-		     defsetf defstruct deftype define-compiler-macro))
-		   ((define-walker-template defopcode defoperand 
-		     define-method-combination define-constructor-code-type 
-		     defclass))
-		   (t (when print-p (print form)))))))
-      (dolist (file (system-source-files 'pcl))
-	(with-open-file (in file :direction :input)
-	  (loop (let ((form (read in nil eof)))
-		  (when (eq form eof) (return nil))
-		  (process-form form))))))
-    (values (length *defun-list*)
-	    (length *defmethod-list*)
-	    (length *defmacro-list*)
-	    (length *defgeneric-list*))))
-
-(defun list-all-gfs (&key all-p (show-methods-p t) san-p (name "generic-functions"))
-  (let ((keys nil) (opt nil)
-	(gf-vector (make-array 10 :initial-element nil))
-	(readers nil) (writers nil) (cv nil)
-	(*package* *the-pcl-package*)
-	(*print-pretty* nil)
-	(s-a-n (find-package "SLOT-ACCESSOR-NAME"))
-	(lisp-sans (mapcar #'slot-reader-symbol '(function type))))
-    ;; This one has no predefined methods.
-    (defgeneric update-dependent (metaobject dependent &rest initargs))
-    (map-all-generic-functions 
-     #'(lambda (gf)
-	 (when (or all-p
-		   (let ((name (generic-function-name gf)))
-		     (when (consp name) (setq name (cadr name)))
-		     (and (not (find #\: (symbol-name name)))
-			  (or (eq (symbol-package name) *the-pcl-package*)
-			      (and san-p
-				   (memq name lisp-sans)
-				   (and (eq (symbol-package name) s-a-n)
-					(string= "PCL " (symbol-name name)
-						 :end2 4)))))))
-	   (let ((ll (generic-function-lambda-list gf)))
-	     (multiple-value-bind (nrequired noptional 
-					     keysp restp allow-other-keys-p keywords)
-		 (analyze-lambda-list ll)
-	       (cond ((use-constant-value-dfun-p gf t)
-		      (push gf cv))
-		     ((or keysp restp allow-other-keys-p keywords)
-		      (push gf keys))
-		     ((plusp noptional)
-		      (push gf opt))
-		     ((and (= nrequired 1)
-			   (let ((m (generic-function-methods gf)))
-			     (and m
-				  (every #'standard-reader-method-p m))))
-		      (push gf readers))
-		     ((and (= nrequired 2)
-			   (let ((m (generic-function-methods gf)))
-			     (and m
-				  (every #'standard-writer-method-p m))))
-		      (push gf writers))
-		     (t
-		      (push gf (aref gf-vector nrequired)))))))))
-    (with-open-file (out (let* ((system (get-system 'pcl))
-				(*system-directory* (funcall (car system))))
-			   (make-pathname :defaults
-					  (truename (make-source-pathname "defsys"))
-					  :name name))
-			 :direction :output)
-      (format out ";;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-~2%")
-      (format out "(in-package :pcl)~%")
-      (flet ((print-gf-list (list)
-	       (setq list
-		     (sort (mapcar #'generic-function-name list)
-			   #'(lambda (sym1 sym2)
-			       (let* ((s1 (if (consp sym1) (cadr sym1) sym1))
-				      (s2 (if (consp sym2) (cadr sym2) sym2))
-				      (p1 (symbol-package s1))
-				      (p2 (symbol-package s2)))
-				 (if (eq p1 p2)
-				     (string< (symbol-name s1) (symbol-name s2))
-				     (string< (package-name p1) (package-name p2)))))))
-	       (dolist (sym list)
-		 (let* ((*print-case* :downcase)
-			(gf (gdefinition sym))
-			(lambda-list (generic-function-lambda-list gf)))
-		   (format out "~&~S~%" `(defgeneric ,sym ,lambda-list))
-		   (when show-methods-p
-		     (dolist (m (generic-function-methods gf))
-		       (let* ((q (method-qualifiers m))
-			      (qs (if (null q) 
-				      ""
-				      (format nil "~{~S~^ ~}" q)))
-			      (s (unparse-specializers m)))
-			 (format out "~&;  ~7A ~S~%" qs s)))
-		     (terpri out))))))
-	(when cv
-	  (format out "~%;;; class predicates~%")
-	  (print-gf-list cv))
-	(when readers
-	  (format out "~%;;; readers~%")
-	  (print-gf-list readers))
-	(when writers
-	  (format out "~%;;; writers~%")
-	  (print-gf-list writers))
-	(dotimes (i 10)
-	  (when (aref gf-vector i)
-	    (format out "~%;;; ~D argument~:P ~%" i)
-	    (print-gf-list (aref gf-vector i))))
-	(format out "~%;;; optional arguments  ~%")
-	(print-gf-list opt)
-	(format out "~%;;; keyword arguments  ~%")
-	(print-gf-list keys))
-      (terpri out))))
diff --git a/pcl/low.lisp b/pcl/low.lisp
deleted file mode 100644
index 2f8937f662f9534c6b7f8d794dee6dc34083a440..0000000000000000000000000000000000000000
--- a/pcl/low.lisp
+++ /dev/null
@@ -1,445 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; This file contains portable versions of low-level functions and macros
-;;; which are ripe for implementation specific customization.  None of the
-;;; code in this file *has* to be customized for a particular Common Lisp
-;;; implementation. Moreover, in some implementations it may not make any
-;;; sense to customize some of this code.
-;;;
-;;; But, experience suggests that MOST Common Lisp implementors will want
-;;; to customize some of the code in this file to make PCL run better in
-;;; their implementation.  The code in this file has been separated and
-;;; heavily commented to make that easier.
-;;;
-;;; Implementation-specific version of this file already exist for:
-;;; 
-;;;    Symbolics Genera family     genera-low.lisp
-;;;    Lucid Lisp                  lucid-low.lisp
-;;;    Xerox 1100 family           xerox-low.lisp
-;;;    ExCL (Franz)                excl-low.lisp
-;;;    Kyoto Common Lisp           kcl-low.lisp
-;;;    Vaxlisp                     vaxl-low.lisp
-;;;    CMU Lisp                    cmu-low.lisp
-;;;    H.P. Common Lisp            hp-low.lisp
-;;;    Golden Common Lisp          gold-low.lisp
-;;;    Ti Explorer                 ti-low.lisp
-;;;    
-;;;
-;;; These implementation-specific files are loaded after this file.  Because
-;;; none of the macros defined by this file are used in functions defined by
-;;; this file the implementation-specific files can just contain the parts of
-;;; this file they want to change.  They don't have to copy this whole file
-;;; and then change the parts they want.
-;;;
-;;; If you make changes or improvements to these files, or if you need some
-;;; low-level part of PCL re-modularized to make it more portable to your
-;;; system please send mail to CommonLoops.pa@Xerox.com.
-;;;
-;;; Thanks.
-;;; 
-
-(in-package :pcl)
-
-(eval-when (compile load eval)
-(defvar *optimize-speed* '(optimize (speed 3) (safety 0)))
-)
-
-(defmacro %svref (vector index)
-  `(locally (declare #.*optimize-speed*
-		     (inline svref))
-	    (svref (the simple-vector ,vector) (the fixnum ,index))))
-
-(defsetf %svref %set-svref)
-
-(defmacro %set-svref (vector index new-value)
-  `(locally (declare #.*optimize-speed*
-		     (inline svref))
-     (setf (svref (the simple-vector ,vector) (the fixnum ,index))
-	   ,new-value)))
-
-
-;;;
-;;; without-interrupts
-;;; 
-;;; OK, Common Lisp doesn't have this and for good reason.  But For all of
-;;; the Common Lisp's that PCL runs on today, there is a meaningful way to
-;;; implement this.  WHAT I MEAN IS:
-;;;
-;;; I want the body to be evaluated in such a way that no other code that is
-;;; running PCL can be run during that evaluation.  I agree that the body
-;;; won't take *long* to evaluate.  That is to say that I will only use
-;;; without interrupts around relatively small computations.
-;;;
-;;; INTERRUPTS-ON should turn interrupts back on if they were on.
-;;; INTERRUPTS-OFF should turn interrupts back off.
-;;; These are only valid inside the body of WITHOUT-INTERRUPTS.
-;;;
-;;; OK?
-;;;
-(defmacro without-interrupts (&body body)
-  `(macrolet ((interrupts-on () ())
-	      (interrupts-off () ()))
-     (progn ,.body)))
-
-
-;;;
-;;;  Very Low-Level representation of instances with meta-class standard-class.
-;;;
-#-new-kcl-wrapper
-(progn
-(defstruct (std-instance (:predicate std-instance-p)
-			 (:conc-name %std-instance-)
-			 (:constructor %%allocate-instance--class ())
-			 (:print-function print-std-instance))
-  (wrapper nil)
-  (slots nil))
-
-(defmacro %instance-ref (slots index)
-  `(%svref ,slots ,index))
-
-(defmacro instance-ref (slots index)
-  `(svref ,slots ,index))
-)
-
-#+new-kcl-wrapper
-(progn
-(defvar *init-vector* (make-array 40 :fill-pointer 1 :adjustable t 
-				  :initial-element nil))
-
-(defun get-init-list (i)
-  (declare (fixnum i)(special *slot-unbound*))
-  (loop (when (< i (fill-pointer *init-vector*))
-	  (return (aref *init-vector* i)))
-	(vector-push-extend 
-	 (cons *slot-unbound*
-	       (aref *init-vector* (1- (fill-pointer *init-vector*))))
-	 *init-vector*)))
-
-(defmacro %std-instance-wrapper (instance)
-  `(structure-def ,instance))
-
-(defmacro %std-instance-slots (instance)
-  instance)
-
-(defmacro std-instance-p (x)
-  `(structurep ,x))
-)
-
-(defmacro std-instance-wrapper (x) `(%std-instance-wrapper ,x))
-(defmacro std-instance-slots   (x) `(%std-instance-slots ,x))
-
-(defmacro get-wrapper (inst)
-  `(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst))
-	 ((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst))
-	 (t (error "What kind of instance is this?"))))
-
-(defmacro get-instance-wrapper-or-nil (inst)
-  `(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst))
-	 ((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst))))
-
-(defmacro get-slots (inst)
-  `(cond ((std-instance-p ,inst) (std-instance-slots ,inst))
-	 ((fsc-instance-p ,inst) (fsc-instance-slots ,inst))
-	 (t (error "What kind of instance is this?"))))
-
-(defmacro get-slots-or-nil (inst)
-  `(cond ((std-instance-p ,inst) (std-instance-slots ,inst))
-	 ((fsc-instance-p ,inst) (fsc-instance-slots ,inst))))
-
-(defun print-std-instance (instance stream depth) ;A temporary definition used
-  (declare (ignore depth))		          ;for debugging the bootstrap
-  (printing-random-thing (instance stream)        ;code of PCL (See high.lisp).
-    (let ((class (class-of instance)))
-      (if (or (eq class (find-class 'standard-class nil))
-	      (eq class (find-class 'funcallable-standard-class nil))
-	      (eq class (find-class 'built-in-class nil)))
-	  (format stream "~a ~a" (early-class-name class)
-		  (early-class-name instance))
-	  (format stream "~a" (early-class-name class))))))
-
-;;;
-;;; This is the value that we stick into a slot to tell us that it is unbound.
-;;; It may seem gross, but for performance reasons, we make this an interned
-;;; symbol.  That means that the fast check to see if a slot is unbound is to
-;;; say (EQ <val> '..SLOT-UNBOUND..).  That is considerably faster than looking
-;;; at the value of a special variable.  Be careful, there are places in the
-;;; code which actually use ..slot-unbound.. rather than this variable.  So
-;;; much for modularity
-;;; 
-(defvar *slot-unbound* '..slot-unbound..)
-
-(defmacro %allocate-static-slot-storage--class (no-of-slots)
-  #+new-kcl-wrapper (declare (ignore no-of-slots))
-  #-new-kcl-wrapper
-  `(make-array ,no-of-slots :initial-element *slot-unbound*)
-  #+new-kcl-wrapper
-  (error "don't call this"))
-
-(defmacro std-instance-class (instance)
-  `(wrapper-class* (std-instance-wrapper ,instance)))
-
-
-  ;;   
-;;;;;; FUNCTION-ARGLIST
-  ;;
-;;; Given something which is functionp, function-arglist should return the
-;;; argument list for it.  PCL does not count on having this available, but
-;;; MAKE-SPECIALIZABLE works much better if it is available.  Versions of
-;;; function-arglist for each specific port of pcl should be put in the
-;;; appropriate xxx-low file. This is what it should look like:
-;(defun function-arglist (function)
-;  (<system-dependent-arglist-function> function))
-
-(defun function-pretty-arglist (function)
-  (declare (ignore function))
-  ())
-
-(defsetf function-pretty-arglist set-function-pretty-arglist)
-
-(defun set-function-pretty-arglist (function new-value)
-  (declare (ignore function))
-  new-value)
-
-;;;
-;;; set-function-name
-;;; When given a function should give this function the name <new-name>.
-;;; Note that <new-name> is sometimes a list.  Some lisps get the upset
-;;; in the tummy when they start thinking about functions which have
-;;; lists as names.  To deal with that there is set-function-name-intern
-;;; which takes a list spec for a function name and turns it into a symbol
-;;; if need be.
-;;;
-;;; When given a funcallable instance, set-function-name MUST side-effect
-;;; that FIN to give it the name.  When given any other kind of function
-;;; set-function-name is allowed to return new function which is the 'same'
-;;; except that it has the name.
-;;;
-;;; In all cases, set-function-name must return the new (or same) function.
-;;; 
-(defun set-function-name (function new-name)
-  (declare (notinline set-function-name-1 intern-function-name))
-  (set-function-name-1 function
-		       (intern-function-name new-name)
-		       new-name))
-
-(defun set-function-name-1 (function new-name uninterned-name)
-  (declare (ignore new-name uninterned-name))
-  function)
-
-(defun intern-function-name (name)
-  (cond ((symbolp name) name)
-	((listp name)
-	 (intern (let ((*package* *the-pcl-package*)
-		       (*print-case* :upcase)
-		       (*print-pretty* nil)
-		       (*print-gensym* 't))
-		   (format nil "~S" name))
-		 *the-pcl-package*))))
-
-
-;;;
-;;; COMPILE-LAMBDA
-;;;
-;;; This is like the Common Lisp function COMPILE.  In fact, that is what
-;;; it ends up calling.  The difference is that it deals with things like
-;;; watching out for recursive calls to the compiler or not calling the
-;;; compiler in certain cases or allowing the compiler not to be present.
-;;;
-;;; This starts out with several variables and support functions which 
-;;; should be conditionalized for any new port of PCL.  Note that these
-;;; default to reasonable values, many new ports won't need to look at
-;;; these values at all.
-;;;
-;;; *COMPILER-PRESENT-P*        NIL means the compiler is not loaded
-;;;
-;;; *COMPILER-SPEED*            one of :FAST :MEDIUM or :SLOW
-;;;
-;;; *COMPILER-REENTRANT-P*      T   ==> OK to call compiler recursively
-;;;                             NIL ==> not OK
-;;;
-;;; function IN-THE-COMPILER-P  returns T if in the compiler, NIL otherwise
-;;;                             This is not called if *compiler-reentrant-p*
-;;;                             is T, so it only needs to be implemented for
-;;;                             ports which have non-reentrant compilers.
-;;;
-;;;
-(defvar *compiler-present-p* t)
-
-(defvar *compiler-speed*
-	#+(or KCL IBCL GCLisp CMU) :slow
-	#-(or KCL IBCL GCLisp CMU) :fast)
-
-(defvar *compiler-reentrant-p*
-	#+(and (not XKCL) (or KCL IBCL)) nil
-	#-(and (not XKCL) (or KCL IBCL)) t)
-
-(defun in-the-compiler-p ()
-  #+(and (not xkcl) (or KCL IBCL))compiler::*compiler-in-use*
-  #+gclisp (typep (eval '(function (lambda ()))) 'lexical-closure)
-  )
-
-(defvar *compile-lambda-break-p* nil)
-
-(defun compile-lambda (lambda &optional (desirability :fast))
-  (when *compile-lambda-break-p* (break))
-  (cond ((null *compiler-present-p*)
-	 (compile-lambda-uncompiled lambda))
-	((and (null *compiler-reentrant-p*)
-	      (in-the-compiler-p))
-	 (compile-lambda-deferred lambda))
-	((eq desirability :fast)
-	 (compile nil lambda))
-	((and (eq desirability :medium)
-	      (member *compiler-speed* '(:fast :medium)))
-	 (compile nil lambda))
-	((and (eq desirability :slow)
-	      (eq *compiler-speed* ':fast))
-	 (compile nil lambda))
-	(t
-	 (compile-lambda-uncompiled lambda))))
-
-(defun compile-lambda-uncompiled (uncompiled)
-  #'(lambda (&rest args) (apply (coerce uncompiled 'function) args)))
-
-(defun compile-lambda-deferred (uncompiled)
-  (let ((function (coerce uncompiled 'function))
-	(compiled nil))
-    (declare (type (or function null) compiled))
-    #'(lambda (&rest args)
-	(if compiled
-	    (apply compiled args)
-	    (if (in-the-compiler-p)
-		(apply function args)
-		(progn (setq compiled (compile nil uncompiled))
-		       (apply compiled args)))))))
-
-(defmacro precompile-random-code-segments (&optional system)
-  `(progn
-     (eval-when (compile)
-       (update-dispatch-dfuns)
-       (compile-iis-functions nil))
-     (precompile-function-generators ,system)
-     (precompile-dfun-constructors ,system)
-     (precompile-iis-functions ,system)
-     (eval-when (load)
-       (compile-iis-functions t))))
-
-
-
-(defun record-definition (type spec &rest args)
-  (declare (ignore type spec args))
-  ())
-
-(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)
-
-;; From braid.lisp
-#-new-kcl-wrapper
-(defmacro built-in-or-structure-wrapper (x)
-  (once-only (x)
-    (if (structure-functions-exist-p) ; otherwise structurep is too slow for this
-	`(if (structurep ,x)
-	     (wrapper-for-structure ,x)
-	     (if (symbolp ,x)
-		 (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)
-		 (built-in-wrapper-of ,x)))
-	`(or (and (symbolp ,x)
-		  (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*))
-	     (built-in-or-structure-wrapper1 ,x)))))
-
-
-;Low level functions for structures
-
-
-;Functions on arbitrary objects
-
-(defvar *structure-table* (make-hash-table :test 'eq))
-
-(defun declare-structure (name included-name slot-description-list)
-  (setf (gethash name *structure-table*)
-	(cons included-name slot-description-list)))
-
-(unless (fboundp 'structure-functions-exist-p)
-  (setf (symbol-function 'structure-functions-exist-p) 
-	#'(lambda () nil)))
-
-(defun default-structurep (x)
-  (structure-type-p (type-of x)))
-
-(defun default-structure-instance-p (x)
-  (let ((type (type-of x)))
-    (and (not (eq type 'std-instance))
-	 (structure-type-p type))))
-
-(defun default-structure-type (x)
-  (type-of x))
-
-(unless (fboundp 'structurep)
-  (setf (symbol-function 'structurep) #'default-structurep))
-
-; excludes std-instance
-(unless (fboundp 'structure-instance-p)
-  (setf (symbol-function 'structure-instance-p) #'default-structure-instance-p))
-
-; returns a symbol
-(unless (fboundp 'structure-type)
-  (setf (symbol-function 'structure-type) #'default-structure-type))
-
-
-;Functions on symbols naming structures
-
-; Excludes structures types created with the :type option
-(defun structure-type-p (symbol)
-  (not (null (gethash symbol *structure-table*))))
-
-(defun structure-type-included-type-name (symbol)
-  (car (gethash symbol *structure-table*)))
-
-; direct slots only
-; The results of this function are used only by the functions below.
-(defun structure-type-slot-description-list (symbol)
-  (cdr (gethash symbol *structure-table*)))
-
-
-;Functions on slot-descriptions (returned by the function above)
-
-;returns a symbol
-(defun structure-slotd-name (structure-slot-description)
-  (first structure-slot-description))
-
-;returns a symbol
-(defun structure-slotd-accessor-symbol (structure-slot-description)
-  (second structure-slot-description))
-
-;returns a symbol or a list or nil
-(defun structure-slotd-writer-function (structure-slot-description)
-  (third structure-slot-description))
-
-(defun structure-slotd-type (structure-slot-description)
-  (fourth structure-slot-description))
-
-(defun structure-slotd-init-form (structure-slot-description)
-  (fifth structure-slot-description))
diff --git a/pcl/lucid-low.lisp b/pcl/lucid-low.lisp
deleted file mode 100644
index ec473574eacb58a2b9b902d88dfe5de92043a2af..0000000000000000000000000000000000000000
--- a/pcl/lucid-low.lisp
+++ /dev/null
@@ -1,384 +0,0 @@
-;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;; 
-;;; This is the Lucid lisp version of the file portable-low.
-;;;
-;;; Lucid:               (415)329-8400
-;;; 
-
-(in-package 'pcl)
-
-;;; First, import some necessary "internal" or Lucid-specific symbols
-
-(eval-when (eval compile load)
-
-(#-LCL3.0 progn #+LCL3.0 lcl:handler-bind 
-    #+LCL3.0 ((lcl:warning #'(lambda (condition)
-			       (declare (ignore condition))
-			       (lcl:muffle-warning))))
-(let ((importer
-        #+LCL3.0 #'sys:import-from-lucid-pkg
-	#-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID")))
-		   (if (and x (fboundp x))
-		       (symbol-function x)
-		       ;; Only the #'(lambda (x) ...) below is really needed, 
-		       ;;  but when available, the "internal" function 
-		       ;;  'import-from-lucid-pkg' provides better checking.
-		       #'(lambda (name)
-			   (import (intern name "LUCID")))))))
-  ;;
-  ;; We need the following "internal", undocumented Lucid goodies:
-  (mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE"
-		   #-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE"))
-
-  ;;
-  ;; For without-interrupts.
-  ;; 
-  #+LCL3.0
-  (mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER"))
-
-  ;;
-  ;; We import the following symbols, because in 2.1 Lisps they have to be
-  ;;  accessed as SYS:<foo>, whereas in 3.0 lisps, they are homed in the
-  ;;  LUCID-COMMON-LISP package.
-  (mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*"))
-  ;;
-  ;; We import the following symbols, because in 2.1 Lisps they have to be
-  ;;  accessed as LUCID::<foo>, whereas in 3.0 lisps, they have to be
-  ;;  accessed as SYS:<foo>
-  (mapc importer '(
-		   "NEW-STRUCTURE"   	"STRUCTURE-REF"
-		   "STRUCTUREP"         "STRUCTURE-TYPE"  "STRUCTURE-LENGTH"
-		   "PROCEDUREP"     	"PROCEDURE-SYMBOL"
-		   "PROCEDURE-REF" 	"SET-PROCEDURE-REF" 
-		   ))
-; ;;
-; ;;  The following is for the "patch" to the general defstruct printer.
-; (mapc importer '(
-; 	           "OUTPUT-STRUCTURE" 	  "DEFSTRUCT-INFO"
-;		   "OUTPUT-TERSE-OBJECT"  "DEFAULT-STRUCTURE-PRINT" 
-;		   "STRUCTURE-TYPE" 	  "*PRINT-OUTPUT*"
-;		   ))
-  ;;
-  ;; The following is for a "patch" affecting compilation of %logand&.
-  ;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas
-  ;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS
-  ;; on *FEATURES*, so this conditionalizes correctly for APOLLO.
-  #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) 
-  (mapc importer '("COPY-STRUCTURE"  "GET-FDESC"  "SET-FDESC"))
-  
-  nil))
-
-;; end of eval-when
-
-)
-	
-
-;;;
-;;; Patch up for the fact that the PCL package creation in defsys.lisp
-;;;  will probably have an explicit :use list ??
-;;;
-;;;  #+LCL3.0 (use-package *default-make-package-use-list*)
-
-
-
-
-#+lcl3.0
-(progn
-
-(defvar *saved-compilation-speed* 3)
-
-; the production compiler sometimes
-; screws up vars within labels
-
-(defmacro dont-use-production-compiler ()
-  '(eval-when (compile)
-     (setq *saved-compilation-speed* (if LUCID:*USE-SFC* 3 0))
-     (proclaim '(optimize (compilation-speed 3)))))
-
-(defmacro use-previous-compiler ()
-  `(eval-when (compile)
-     (proclaim '(optimize (compilation-speed ,*saved-compilation-speed*)))))
-
-)
-
-(defmacro %logand (x y)
-  #-VAX `(%logand& ,x ,y)
-  #+VAX `(logand&-variable ,x ,y))
-
-;;; Fix for VAX LCL
-#+VAX
-(defun logand&-variable (x y)
-  (logand&-variable x y))
-
-;;; Fix for other LCLs
-#-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX)
-(eval-when (compile load eval)
-
-(let* ((logand&-fdesc (get-fdesc 'logand&))
-       (%logand&-fdesc (copy-structure logand&-fdesc)))
-  (setf (structure-ref %logand&-fdesc 0 t) '%logand&)
-  (setf (structure-ref %logand&-fdesc 7 t) nil)
-  (setf (structure-ref %logand&-fdesc 8 t) nil)
-  (set-fdesc '%logand& %logand&-fdesc))
-
-(eval-when (load)
-  (defun %logand& (x y) (%logand& x y)))
-
-(eval-when (eval)
-  (compile '%logand& '(lambda (x y) (%logand& x y))))
-
-);#-(or LCL3.0 (and APOLLO DOMAIN/OS) VAX)
-
-;;;
-;;; From: JonL
-;;; Date: November 28th, 1988
-;;; 
-;;;  Here's a better attempt to do the without-interrupts macro for LCL3.0.
-;;;  For the 2.1  release, maybe you should just ignore it (i.e, turn it 
-;;;  into a PROGN and "take your chances") since there isn't a uniform way
-;;;  to do inhibition.  2.1 has interrupts, but no multiprocessing.
-;;;
-;;;  The best bet for protecting the cache is merely to inhibit the
-;;;  scheduler, since asynchronous interrupts are only run when "scheduled".
-;;;  Of course, there may be other interrupts, which can cons and which 
-;;;  could cause a GC; but at least they wouldn't be running PCL type code.
-;;;
-;;;  Note that INTERRUPTS-ON shouldn't arbitrarily enable scheduling again,
-;;;  but rather simply restore it to the state outside the scope of the call
-;;;  to WITHOUT-INTERRUPTS.  Note also that an explicit call to 
-;;;  MAYBE-CALL-SHEDULER must be done when "turning interrupts back on", if
-;;;  there are any interrupts/schedulings pending; at least the test to see
-;;;  if any are pending is very fast.
-
-#+LCL3.0
-(defmacro without-interrupts (&body body)
-  `(macrolet ((interrupts-on  ()
-		`(when (null outer-scheduling-state)
-		   (setq lcl:*inhibit-scheduling* nil)
-		   (when *scheduler-wakeup* (maybe-call-scheduler))))
-	      (interrupts-off () 
-		'(setq lcl:*inhibit-scheduling* t)))
-     (let ((outer-scheduling-state lcl:*inhibit-scheduling*))
-       (prog1 (let ((lcl:*inhibit-scheduling* t)) . ,body)
-	      (when (and (null outer-scheduling-state) *scheduler-wakeup*)
-		(maybe-call-scheduler))))))
-
-
-;;; The following should override the definitions provided by lucid-low.
-;;;
-#+(or LCL3.0 (and APOLLO DOMAIN/OS))
-(progn
-(defstruct-simple-predicate std-instance std-instance-p)
-(defstruct-simple-predicate fast-method-call fast-method-call-p)
-(defstruct-simple-predicate method-call method-call-p)
-)
-
-
-
-(defun set-function-name-1 (fn new-name ignore)
-  (declare (ignore ignore))
-  (if (not (procedurep fn))
-      (error "~S is not a procedure." fn)
-      (if (compiled-function-p fn)
-	  ;; This is one of:
-	  ;;   compiled-function, funcallable-instance, compiled-closure
-	  ;;   or a macro.
-	  ;; So just go ahead and set its name.
-	  ;; Only change the name when necessary: maybe it is read-only.
-	  (unless (eq new-name (procedure-ref fn procedure-symbol))
-	    (set-procedure-ref fn procedure-symbol new-name))
-	  ;; This is an interpreted function.
-	  ;; Seems like any number of different things can happen depending
-	  ;; vaguely on what release you are running.  Try to do something
-	  ;; reasonable.
-	  (let ((symbol (procedure-ref fn procedure-symbol)))
-	    (cond ((symbolp symbol)
-		   ;; In fact, this is the name of the procedure.
-		   ;; Just set it.
-		   (set-procedure-ref fn procedure-symbol new-name))
-		  ((and (listp symbol)
-			(eq (car symbol) 'lambda))
-		   (setf (car symbol) 'named-lambda
-			 (cdr symbol) (cons new-name (cdr symbol))))
-		  ((eq (car symbol) 'named-lambda)
-		   (setf (cadr symbol) new-name))))))		  
-  fn)
-
-(defun function-arglist (fn)
-  (arglist fn))
-
-  ;;   
-;;;;;; printing-random-thing-internal
-  ;;
-(defun printing-random-thing-internal (thing stream)
-  (format stream "~O" (%pointer thing)))
-
-
-;;;
-;;; 16-Feb-90 Jon L White
-;;;
-;;; A Patch provide specifically for the benefit of PCL, in the Lucid 3.0
-;;;  release environment.  This adds type optimizers for FUNCALL so that
-;;;  forms such as:
-;;;
-;;;     (FUNCALL (THE PROCEDURE F) ...)
-;;;
-;;;  and:
-;;;
-;;;     (LET ((F (Frobulate)))
-;;;       (DECLARE (TYPE COMPILED-FUNCTION F))
-;;;       (FUNCALL F ...))
-;;;
-;;;  will just jump directly to the procedure code, rather than waste time
-;;;  trying to coerce the functional argument into a procedure.
-;;;
-
-
-(in-package "LUCID")
-
-
-;;; (DECLARE-MACHINE-CLASS COMMON)
-(set-up-compiler-target 'common)
-
-
-(set-function-descriptor 'FUNCALL
-  :TYPE  'LISP
-  :PREDS 'NIL
-  :EFFECTS 'T
-  :OPTIMIZER  #'(lambda (form &optional environment) 
-		  (declare (ignore form environment))
-		  (let* ((fun (second form))
-			 (lambdap (and (consp fun) 
-				       (eq (car fun) 'function)
-				       (consp (second fun))
-				       (memq (car (second fun))
-					     '(lambda internal-lambda)))))
-		    (if (not lambdap) 
-			form
-			(alphatize 
-			  (cons (second fun) (cddr form)) environment))))
-  :FUNCTIONTYPE '(function (function &rest t) (values &rest t))
-  :TYPE-DISPATCH `(((PROCEDURE &REST T) (VALUES &REST T)
-		    ,#'(lambda (anode fun &rest args) 
-			 (declare (ignore anode fun args))
-			 `(FAST-FUNCALL ,fun ,@args)))
-		   ((COMPILED-FUNCTION &REST T)  (VALUES &REST T)
-		    ,#'(lambda (anode fun &rest args) 
-			 (declare (ignore anode fun args))
-			 `(FAST-FUNCALL ,fun ,@args))))
-  :LAMBDALIST '(FN &REST ARGUMENTS)
-  :ARGS '(1 NIL)
-  :VALUES '(0 NIL)
-  )
-
-(def-compiler-macro fast-funcall (&rest args &environment env)
-  (if (COMPILER-OPTION-SET-P :READ-SAFETY ENV)
-      `(FUNCALL-SUBR . ,args)
-      `(&FUNCALL . ,args)))
-
-
-
-(setf (symbol-function 'funcall-subr) #'funcall)
-
-
-;;; (UNDECLARE-MACHINE-CLASS)
-(restore-compiler-params)
-
-
-(in-package 'pcl)
-
-(pushnew :structure-wrapper *features*)
-
-(defun structure-functions-exist-p ()
-  t)
-
-(defun structure-instance-p (x)
-  (and (structurep x)
-       (not (eq 'std-instance (structure-type x)))))
-
-(defvar *structure-type* nil)
-(defvar *structure-length* nil)
-
-(defun structure-type-p (type)
-  (declare (special lucid::*defstructs*))
-  (let ((s-data (gethash type lucid::*defstructs*)))
-    (or (and s-data 
-	     (eq 'structure (structure-ref s-data 1 'defstruct))) ; type - Fix this
-	(and type (eq *structure-type* type)))))
-
-(defun structure-type-included-type-name (type)
-  (declare (special lucid::*defstructs*))
-  (let ((s-data (gethash type lucid::*defstructs*)))
-    (and s-data (structure-ref s-data 6 'defstruct)))) ; include - Fix this
-
-(defun structure-type-slot-description-list (type)
-  (declare (special lucid::*defstructs*))
-  (let ((s-data (gethash type lucid::*defstructs*)))
-    (if s-data
-	(nthcdr (let ((include (structure-ref s-data 6 'defstruct)))
-		  (if include
-		      (let ((inc-s-data (gethash include lucid::*defstructs*)))
-			(if inc-s-data
-			    (length (structure-ref inc-s-data 7 'defstruct))
-			    0))
-		      0))
-		(map 'list
-		     #'(lambda (slotd)
-			 (let* ((ds 'lucid::defstruct-slot)
-				(slot-name (system:structure-ref slotd 0 ds))
-				(position (system:structure-ref slotd 1 ds))
-				(accessor (system:structure-ref slotd 2 ds))
-				(read-only-p (system:structure-ref slotd 5 ds)))
-			   (list slot-name accessor
-				 #'(lambda (x)
-				     (system:structure-ref x position type))
-				 (unless read-only-p
-				   #'(lambda (v x)
-				       (setf (system:structure-ref x position type)
-					     v))))))
-		     (structure-ref s-data 7 'defstruct))) ; slots  - Fix this
-	(let ((result (make-list *structure-length*)))
-	  (dotimes (i *structure-length* result)
-	    (let* ((name (format nil "SLOT~D" i))
-		   (slot-name (intern name (or (symbol-package type) *package*)))
-		   (i i))
-	      (setf (elt result i) (list slot-name nil
-					 #'(lambda (x)
-					     (system:structure-ref x i type))
-					 nil))))))))
-
-(defun structure-slotd-name (slotd)
-  (first slotd))
-
-(defun structure-slotd-accessor-symbol (slotd)
-  (second slotd))
-
-(defun structure-slotd-reader-function (slotd)
-  (third slotd))
-
-(defun structure-slotd-writer-function (slotd)
-  (fourth slotd))
diff --git a/pcl/macros.lisp b/pcl/macros.lisp
deleted file mode 100644
index 117f448e773414bc1683327a83aecb191a8d91a0..0000000000000000000000000000000000000000
--- a/pcl/macros.lisp
+++ /dev/null
@@ -1,743 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; Macros global variable definitions, and other random support stuff used
-;;; by the rest of the system.
-;;;
-;;; For simplicity (not having to use eval-when a lot), this file must be
-;;; loaded before it can be compiled.
-;;;
-
-(in-package :pcl)
-
-(proclaim '(declaration
-	     #-Genera values          ;I use this so that Zwei can remind
-				      ;me what values a function returns.
-	     
-	     #-Genera arglist	      ;Tells me what the pretty arglist
-				      ;of something (which probably takes
-				      ;&rest args) is.
-
-	     #-Genera indentation     ;Tells ZWEI how to indent things
-			              ;like defclass.
-	     class
-	     variable-rebinding
-	     pcl-fast-call
-	     method-name
-	     method-lambda-list
-	     ))
-
-;;; Age old functions which CommonLisp cleaned-up away.  They probably exist
-;;; in other packages in all CommonLisp implementations, but I will leave it
-;;; to the compiler to optimize into calls to them.
-;;;
-;;; Common Lisp BUG:
-;;;    Some Common Lisps define these in the Lisp package which causes
-;;;    all sorts of lossage.  Common Lisp should explictly specify which
-;;;    symbols appear in the Lisp package.
-;;;
-(eval-when (compile load eval)
-
-(defmacro memq (item list) `(member ,item ,list :test #'eq))
-(defmacro assq (item list) `(assoc ,item ,list :test #'eq))
-(defmacro rassq (item list) `(rassoc ,item ,list :test #'eq))
-(defmacro delq (item list) `(delete ,item ,list :test #'eq))
-(defmacro posq (item list) `(position ,item ,list :test #'eq))
-(defmacro neq (x y) `(not (eq ,x ,y)))
-
-
-(defun make-caxr (n form)
-  (if (< n 4)
-      `(,(nth n '(car cadr caddr cadddr)) ,form)
-      (make-caxr (- n 4) `(cddddr ,form))))
-
-(defun make-cdxr (n form)
-  (cond ((zerop n) form)
-	((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
-	(t (make-cdxr (- n 4) `(cddddr ,form)))))
-)
-
-(defun true (&rest ignore) (declare (ignore ignore)) t)
-(defun false (&rest ignore) (declare (ignore ignore)) nil)
-(defun zero (&rest ignore) (declare (ignore ignore)) 0)
-
-(defun make-plist (keys vals)
-  (if (null vals)
-      ()
-      (list* (car keys)
-	     (car vals)
-	     (make-plist (cdr keys) (cdr vals)))))
-
-(defun remtail (list tail)
-  (if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))
-
-;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just
-;;; lifted it from there but I am honest.  Not only that but this one is
-;;; written in Common Lisp.  I feel a lot like bootstrapping, or maybe more
-;;; like rebuilding Rome.
-(defmacro once-only (vars &body body)
-  (let ((gensym-var (gensym))
-        (run-time-vars (gensym))
-        (run-time-vals (gensym))
-        (expand-time-val-forms ()))
-    (dolist (var vars)
-      (push `(if (or (symbolp ,var)
-                     (numberp ,var)
-                     (and (listp ,var)
-			  (member (car ,var) '(quote function))))
-                 ,var
-                 (let ((,gensym-var (gensym)))
-                   (push ,gensym-var ,run-time-vars)
-                   (push ,var ,run-time-vals)
-                   ,gensym-var))
-            expand-time-val-forms))    
-    `(let* (,run-time-vars
-            ,run-time-vals
-            (wrapped-body
-	      (let ,(mapcar #'list vars (reverse expand-time-val-forms))
-		,@body)))
-       `(let ,(mapcar #'list (reverse ,run-time-vars)
-			     (reverse ,run-time-vals))
-	  ,wrapped-body))))
-
-(eval-when (compile load eval)
-(defun extract-declarations (body &optional environment)
-  ;;(declare (values documentation declarations body))
-  (let (documentation declarations form)
-    (when (and (stringp (car body))
-	       (cdr body))
-      (setq documentation (pop body)))
-    (block outer
-      (loop
-	(when (null body) (return-from outer nil))
-	(setq form (car body))
-	(when (block inner
-		(loop (cond ((not (listp form))
-			     (return-from outer nil))
-			    ((eq (car form) 'declare)
-			     (return-from inner 't))
-			    (t
-			     (multiple-value-bind (newform macrop)
-				  (macroexpand-1 form environment)
-			       (if (or (not (eq newform form)) macrop)
-				   (setq form newform)
-				 (return-from outer nil)))))))
-	  (pop body)
-	  (dolist (declaration (cdr form))
-	    (push declaration declarations)))))
-    (values documentation
-	    (and declarations `((declare ,.(nreverse declarations))))
-	    body)))
-)
-
-(defun get-declaration (name declarations &optional default)
-  (dolist (d declarations default)
-    (dolist (form (cdr d))
-      (when (and (consp form) (eq (car form) name))
-	(return-from get-declaration (cdr form))))))
-
-
-#+Lucid
-(eval-when (compile load eval)
-  (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid)))))
-
-(defvar *keyword-package* (find-package 'keyword))
-
-(defun make-keyword (symbol)
-  (intern (symbol-name symbol) *keyword-package*))
-
-(eval-when (compile load eval)
-
-(defun string-append (&rest strings)
-  (setq strings (copy-list strings))		;The explorer can't even
-						;rplaca an &rest arg?
-  (do ((string-loc strings (cdr string-loc)))
-      ((null string-loc)
-       (apply #'concatenate 'string strings))
-    (rplaca string-loc (string (car string-loc)))))
-)
-
-(defun symbol-append (sym1 sym2 &optional (package *package*))
-  (intern (string-append sym1 sym2) package))
-
-(defmacro check-member (place list &key (test #'eql) (pretty-name place))
-  (once-only (place list)
-    `(or (member ,place ,list :test ,test)
-         (error "The value of ~A, ~S is not one of ~S."
-                ',pretty-name ,place ,list))))
-
-(defmacro alist-entry (alist key make-entry-fn)
-  (once-only (alist key)
-    `(or (assq ,key ,alist)
-	 (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))
-		(car ,alist)))))
-
-;;; A simple version of destructuring-bind.
-
-;;; This does no more error checking than CAR and CDR themselves do.  Some
-;;; attempt is made to be smart about preserving intermediate values.  It
-;;; could be better, although the only remaining case should be easy for
-;;; the compiler to spot since it compiles to PUSH POP.
-;;;
-;;; Common Lisp BUG:
-;;;    Common Lisp should have destructuring-bind.
-;;;    
-(defmacro destructuring-bind (pattern form &body body)
-  (multiple-value-bind (ignore declares body)
-      (extract-declarations body)
-    (declare (ignore ignore))
-    (multiple-value-bind (setqs binds)
-	(destructure pattern form)
-      `(let ,binds
-	 ,@declares
-	 ,@setqs
-	 (progn .destructure-form.)
-	 . ,body))))
-
-(eval-when (compile load eval)
-(defun destructure (pattern form)
-  ;;(declare (values setqs binds))
-  (let ((*destructure-vars* ())
-	(setqs ()))
-    (declare (special *destructure-vars*))
-    (setq *destructure-vars* '(.destructure-form.)
-	  setqs (list `(setq .destructure-form. ,form))
-	  form '.destructure-form.)
-    (values (nconc setqs (nreverse (destructure-internal pattern form)))
-	    (delete nil *destructure-vars*))))
-
-(defun destructure-internal (pattern form)
-  ;; When we are called, pattern must be a list.  Form should be a symbol
-  ;; which we are free to setq containing the value to be destructured.
-  ;; Optimizations are performed for the last element of pattern cases.
-  ;; we assume that the compiler is smart about gensyms which are bound
-  ;; but only for a short period of time.
-  (declare (special *destructure-vars*))
-  (let ((gensym (gensym))
-	(pending-pops 0)
-	(var nil)
-	(setqs ()))
-    (labels
-        ((make-pop (var form pop-into)
-	   (prog1 
-	     (cond ((zerop pending-pops)
-		    `(progn ,(and var `(setq ,var (car ,form)))
-			    ,(and pop-into `(setq ,pop-into (cdr ,form)))))
-		   ((null pop-into)
-		    (and var `(setq ,var ,(make-caxr pending-pops form))))
-		   (t
-		    `(progn (setq ,pop-into ,(make-cdxr pending-pops form))
-			    ,(and var `(setq ,var (pop ,pop-into))))))
-	     (setq pending-pops 0))))
-      (do ((pat pattern (cdr pat)))
-	  ((null pat) ())
-	(if (symbolp (setq var (car pat)))
-	    (progn
-	      #-:coral (unless (memq var '(nil ignore))
-			 (push var *destructure-vars*))
-	      #+:coral (push var *destructure-vars*)	      
-	      (cond ((null (cdr pat))
-		     (push (make-pop var form ()) setqs))
-		    ((symbolp (cdr pat))
-		     (push (make-pop var form (cdr pat)) setqs)
-		     (push (cdr pat) *destructure-vars*)
-		     (return ()))
-		    #-:coral
-		    ((memq var '(nil ignore)) (incf pending-pops))
-		    #-:coral
-		    ((memq (cadr pat) '(nil ignore))
-		     (push (make-pop var form ()) setqs)
-		     (incf pending-pops 1))
-		    (t
-		     (push (make-pop var form form) setqs))))
-	    (progn
-	      (push `(let ((,gensym ()))
-		       ,(make-pop gensym
-				  form
-				  (if (symbolp (cdr pat)) (cdr pat) form))
-		       ,@(nreverse
-			   (destructure-internal
-			     (if (consp pat) (car pat) pat)
-			     gensym)))
-		    setqs)
-	      (when (symbolp (cdr pat))
-		(push (cdr pat) *destructure-vars*)
-		(return)))))
-      setqs)))
-)
-
-
-(defmacro collecting-once (&key initial-value)
-   `(let* ((head ,initial-value)
-           (tail ,(and initial-value `(last head))))
-          (values #'(lambda (value)
-                           (if (null head)
-                               (setq head (setq tail (list value)))
-			       (unless (memq value head)
-				 (setq tail
-				       (cdr (rplacd tail (list value)))))))
-		  #'(lambda nil head))))
-
-(defmacro doplist ((key val) plist &body body &environment env)
-  (multiple-value-bind (doc decls bod)
-      (extract-declarations body env)
-    (declare (ignore doc))
-    `(let ((.plist-tail. ,plist) ,key ,val)
-       ,@decls
-       (loop (when (null .plist-tail.) (return nil))
-	     (setq ,key (pop .plist-tail.))
-	     (when (null .plist-tail.)
-	       (error "Malformed plist in doplist, odd number of elements."))
-	     (setq ,val (pop .plist-tail.))
-	     (progn ,@bod)))))
-
-(defmacro if* (condition true &rest false)
-  `(if ,condition ,true (progn ,@false)))
-
-(defmacro dolist-carefully ((var list improper-list-handler) &body body)
-  `(let ((,var nil)
-         (.dolist-carefully. ,list))
-     (loop (when (null .dolist-carefully.) (return nil))
-           (if (consp .dolist-carefully.)
-               (progn
-                 (setq ,var (pop .dolist-carefully.))
-                 ,@body)
-               (,improper-list-handler)))))
-
-  ;;   
-;;;;;; printing-random-thing
-  ;;
-;;; Similar to printing-random-object in the lisp machine but much simpler
-;;; and machine independent.
-(defmacro printing-random-thing ((thing stream) &body body)
-  (once-only (stream)
-  `(progn (format ,stream "#<")
-	  ,@body
-	  (format ,stream " ")
-	  (printing-random-thing-internal ,thing ,stream)
-	  (format ,stream ">"))))
-
-(defun printing-random-thing-internal (thing stream)
-  (declare (ignore thing stream))
-  nil)
-
-  ;;   
-;;;;;; 
-  ;;
-
-(defun capitalize-words (string &optional (dashes-p t))
-  (let ((string (copy-seq (string string))))
-    (declare (string string))
-    (do* ((flag t flag)
-	  (length (length string) length)
-	  (char nil char)
-	  (i 0 (+ i 1)))
-	 ((= i length) string)
-      (setq char (elt string i))
-      (cond ((both-case-p char)
-	     (if flag
-		 (and (setq flag (lower-case-p char))
-		      (setf (elt string i) (char-upcase char)))
-		 (and (not flag) (setf (elt string i) (char-downcase char))))
-	     (setq flag nil))
-	    ((char-equal char #\-)
-	     (setq flag t)
-	     (unless dashes-p (setf (elt string i) #\space)))
-	    (t (setq flag nil))))))
-
-#-(or lucid kcl)
-(eval-when (compile load eval)
-;(warn "****** Things will go faster if you fix define-compiler-macro")
-)
-
-(defmacro define-compiler-macro (name arglist &body body)
-  #+(or lucid kcl)
-  `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro
-	    ,name ,arglist
-	    ,@body)
-  #-(or kcl lucid)
-  (declare (ignore name arglist body))
-  #-(or kcl lucid)
-  nil)
-
-
-;;;
-;;; FIND-CLASS
-;;;
-;;; This is documented in the CLOS specification.
-;;;
-(defvar *find-class* (make-hash-table :test #'eq))
-
-(defun make-constant-function (value)
-  #'(lambda (object)
-      (declare (ignore object))
-      value))
-
-(defun function-returning-nil (x)
-  (declare (ignore x))
-  nil)
-
-(defun function-returning-t (x)
-  (declare (ignore x))
-  t)
-
-(defmacro find-class-cell-class (cell)
-  `(car ,cell))
-
-(defmacro find-class-cell-predicate (cell)
-  `(cadr ,cell))
-
-(defmacro find-class-cell-make-instance-function-keys (cell)
-  `(cddr ,cell))
-
-(defmacro make-find-class-cell (class-name)
-  (declare (ignore class-name))
-  '(list* nil #'function-returning-nil nil))
-
-(defun find-class-cell (symbol &optional dont-create-p)
-  (or (gethash symbol *find-class*)
-      (unless dont-create-p
-	(unless (legal-class-name-p symbol)
-	  (error "~S is not a legal class name." symbol))
-	(setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
-
-(defvar *create-classes-from-internal-structure-definitions-p* t)
-
-(defun find-class-from-cell (symbol cell &optional (errorp t))
-  (or (find-class-cell-class cell)
-      (and *create-classes-from-internal-structure-definitions-p*
-           (structure-type-p symbol)
-           (find-structure-class symbol))
-      (cond ((null errorp) nil)
-	    ((legal-class-name-p symbol)
-	     (error "No class named: ~S." symbol))
-	    (t
-	     (error "~S is not a legal class name." symbol)))))
-
-(defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
-  (unless (find-class-cell-class cell)
-    (find-class-from-cell symbol cell errorp))
-  (find-class-cell-predicate cell))
-
-(defun legal-class-name-p (x)
-  (and (symbolp x)
-       (not (keywordp x))))
-
-(defun find-class (symbol &optional (errorp t) environment)
-  (declare (ignore environment))
-  (find-class-from-cell
-   symbol (find-class-cell symbol errorp) errorp))
-
-(defun find-class-predicate (symbol &optional (errorp t) environment)
-  (declare (ignore environment))
-  (find-class-predicate-from-cell 
-   symbol (find-class-cell symbol errorp) errorp))
-
-#-setf
-(defsetf find-class (symbol &optional (errorp t) environment) (new-value)
-  (declare (ignore errorp environment))
-  `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol))
-
-(defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol)
-  (declare (special *boot-state*))
-  (if (legal-class-name-p symbol)
-      (let ((cell (find-class-cell symbol)))
-	(setf (find-class-cell-class cell) new-value)
-	(when (or (eq *boot-state* 'complete)
-		  (eq *boot-state* 'braid))
-	  (setf (find-class-cell-predicate cell)
-		(symbol-function (class-predicate-name new-value)))
-	  (when (and new-value (not (forward-referenced-class-p new-value)))
-	    (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
-	      (update-initialize-info-internal
-	       (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
-	       'make-instance-function)))))
-      (error "~S is not a legal class name." symbol)))
-
-#-setf
-(defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value)
-  (declare (ignore errorp environment))
-  `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol))
-
-(defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate)
-          (new-value symbol)
-  (if (legal-class-name-p symbol)
-      (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
-      (error "~S is not a legal class name." symbol)))
-
-(defun find-wrapper (symbol)
-  (class-wrapper (find-class symbol)))
-
-#|| ; Anything that used this should use eval instead.
-(defun reduce-constant (old)
-  (let ((new (eval old)))
-    (if (eq new old)
-	new
-	(if (constantp new)
-	    (reduce-constant new)
-	    new))))
-||#
-
-(defmacro gathering1 (gatherer &body body)
-  `(gathering ((.gathering1. ,gatherer))
-     (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
-       ,@body)))
-
-;;;
-;;; 
-;;; 
-(defmacro vectorizing (&key (size 0))
-  `(let* ((limit ,size)
-	  (result (make-array limit))
-	  (index 0))
-     (values #'(lambda (value)
-		 (if (= index limit)
-		     (error "vectorizing more elements than promised.")
-		     (progn
-		       (setf (svref result index) value)
-		       (incf index)
-		       value)))
-	     #'(lambda () result))))
-
-;;;
-;;; These are augmented definitions of list-elements and list-tails from
-;;; iterate.lisp.  These versions provide the extra :by keyword which can
-;;; be used to specify the step function through the list.
-;;;
-(defmacro *list-elements (list &key (by #'cdr))
-  `(let ((tail ,list))
-     #'(lambda (finish)
-	 (if (endp tail)
-	     (funcall finish)
-	     (prog1 (car tail)
-	            (setq tail (funcall ,by tail)))))))
-
-(defmacro *list-tails (list &key (by #'cdr))
-   `(let ((tail ,list))
-      #'(lambda (finish)
-          (prog1 (if (endp tail)
-		     (funcall finish)
-		     tail)
-	         (setq tail (funcall ,by tail))))))
-
-(defmacro function-funcall (form &rest args)
-  #-cmu `(funcall ,form ,@args)
-  #+cmu `(funcall (the function ,form) ,@args))
-
-(defmacro function-apply (form &rest args)
-  #-cmu `(apply ,form ,@args)
-  #+cmu `(apply (the function ,form) ,@args))
-
-
-;;;
-;;; Convert a function name to its standard setf function name.  We have to
-;;; do this hack because not all Common Lisps have yet converted to having
-;;; setf function specs.
-;;;
-;;; In a port that does have setf function specs you can use those just by
-;;; making the obvious simple changes to these functions.  The rest of PCL
-;;; believes that there are function names like (SETF <foo>), this is the
-;;; only place that knows about this hack.
-;;;
-(eval-when (compile load eval)
-; In 15e (and also 16c), using the built in setf mechanism costs 
-; a hash table lookup every time a setf function is called.
-; Uncomment the next line to use the built in setf mechanism.
-;#+cmu (pushnew :setf *features*) 
-)
-
-(eval-when (compile load eval)
-
-#-setf
-(defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
-
-(defun get-setf-function-name (name)
-  #+setf `(setf ,name)
-  #-setf
-  (or (gethash name *setf-function-names*)
-      (setf (gethash name *setf-function-names*)
-	    (let ((pkg (symbol-package name)))
-	      (if pkg
-		  (intern (format nil
-				  "SETF ~A ~A"
-				  (package-name pkg)
-				  (symbol-name name))
-			  *the-pcl-package*)
-		  (make-symbol (format nil "SETF ~A" (symbol-name name))))))))
-
-;;;
-;;; Call this to define a setf macro for a function with the same behavior as
-;;; specified by the SETF function cleanup proposal.  Specifically, this will
-;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
-;;;
-;;; do-standard-defsetf                  A macro interface for use at top level
-;;;                                      in files.  Unfortunately, users may
-;;;                                      have to use this for a while.
-;;;                                      
-;;; do-standard-defsetfs-for-defclass    A special version called by defclass.
-;;; 
-;;; do-standard-defsetf-1                A functional interface called by the
-;;;                                      above, defmethod and defgeneric.
-;;;                                      Since this is all a crock anyways,
-;;;                                      users are free to call this as well.
-;;;
-(defmacro do-standard-defsetf (&rest function-names)
-  `(eval-when (compile load eval)
-     (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
-
-(defun do-standard-defsetfs-for-defclass (accessors)
-  (dolist (name accessors) (do-standard-defsetf-1 name)))
-
-(defun do-standard-defsetf-1 (function-name)
-  #+setf
-  (declare (ignore function-name))
-  #+setf nil
-  #-setf
-  (unless (and (setfboundp function-name)
-	       (get function-name 'standard-setf))
-    (setf (get function-name 'standard-setf) t)
-    (let* ((setf-function-name (get-setf-function-name function-name)))
-    
-      #+Genera
-      (let ((fn #'(lambda (form)
-		    (lt::help-defsetf
-		      '(&rest accessor-args) '(new-value) function-name 'nil
-		      `(`(,',setf-function-name ,new-value .,accessor-args))
-		      form))))
-	(setf (get function-name 'lt::setf-method) fn
-	      (get function-name 'lt::setf-method-internal) fn))
-
-      #+Lucid
-      (lucid::set-simple-setf-method 
-	function-name
-	#'(lambda (form new-value)
-	    (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))
-				     (cdr form)))
-		   (vars (mapcar #'car bindings)))
-	      ;; This may wrap spurious LET bindings around some form,
-	      ;;   but the PQC compiler will unwrap then.
-	      `(LET (,.bindings)
-		 (,setf-function-name ,new-value . ,vars)))))
-      
-      #+kcl
-      (let ((helper (gensym)))
-	(setf (macro-function helper)
-	      #'(lambda (form env)
-		  (declare (ignore env))
-		  (let* ((loc-args (butlast (cdr form)))
-			 (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))
-			 (vars (mapcar #'car bindings)))
-		    `(let ,bindings
-		       (,setf-function-name ,(car (last form)) ,@vars)))))
-	(eval `(defsetf ,function-name ,helper)))
-      #+Xerox
-      (flet ((setf-expander (body env)
-	       (declare (ignore env))
-	       (let ((temps
-		       (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
-			       (cdr body)))
-		     (forms (cdr body))
-		     (vars (list (gensym))))
-		 (values temps
-			 forms
-			 vars
-			 `(,setf-function-name ,@vars ,@temps)
-			 `(,function-name ,@temps)))))
-	(let ((setf-method-expander (intern (concatenate 'string
-						         (symbol-name function-name)
-						         "-setf-expander")
-				     (symbol-package function-name))))
-	  (setf (get function-name :setf-method-expander) setf-method-expander
-		(symbol-function setf-method-expander) #'setf-expander)))
-      
-      #-(or Genera Lucid kcl Xerox)
-      (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
-	       (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args))
-		      (vars (mapcar #'car bindings)))
-		  `(let ,bindings
-		      (,',setf-function-name ,new-value ,@vars)))))
-      
-      )))
-
-(defun setfboundp (symbol)
-  #+Genera (not (null (get-properties (symbol-plist symbol)
-				      'lt::(derived-setf-function trivial-setf-method
-					    setf-equivalence setf-method))))
-  #+Lucid  (locally
-	     (declare (special lucid::*setf-inverse-table*
-			       lucid::*simple-setf-method-table*
-			       lucid::*setf-method-expander-table*))
-	     (or (gethash symbol lucid::*setf-inverse-table*)
-		 (gethash symbol lucid::*simple-setf-method-table*)
-		 (gethash symbol lucid::*setf-method-expander-table*)))
-  #+kcl    (or (get symbol 'si::setf-method)
-	       (get symbol 'si::setf-update-fn)
-	       (get symbol 'si::setf-lambda))
-  #+Xerox  (or (get symbol :setf-inverse)
-	       (get symbol 'il:setf-inverse)
-	       (get symbol 'il:setfn)
-	       (get symbol :shared-setf-inverse)
-	       (get symbol :setf-method-expander)
-	       (get symbol 'il:setf-method-expander))
-  #+:coral (or (get symbol 'ccl::setf-inverse)
-	       (get symbol 'ccl::setf-method-expander))
-  #+cmu (fboundp `(setf ,symbol))
-  #-(or Genera Lucid KCL Xerox :coral cmu) nil)
-
-);eval-when
-
-
-;;;
-;;; PCL, like user code, must endure the fact that we don't have a properly
-;;; working setf.  Many things work because they get mentioned by a defclass
-;;; or defmethod before they are used, but others have to be done by hand.
-;;; 
-(do-standard-defsetf
-  class-wrapper                                 ;***
-  generic-function-name
-  method-function-plist
-  method-function-get
-  plist-value
-  object-plist
-  gdefinition
-  slot-value-using-class
-  )
-
-(defsetf slot-value set-slot-value)
-
-(defvar *redefined-functions* nil)
-
-(defmacro original-definition (name)
-  `(get ,name ':definition-before-pcl))
-
-(defun redefine-function (name new)
-  (pushnew name *redefined-functions*)
-  (unless (original-definition name)
-    (setf (original-definition name)
-	  (symbol-function name)))
-  (setf (symbol-function name)
-	(symbol-function new)))
-
diff --git a/pcl/make-test.lisp b/pcl/make-test.lisp
deleted file mode 100644
index a80a006e1de668fafb3e928f689221cf319b9282..0000000000000000000000000000000000000000
--- a/pcl/make-test.lisp
+++ /dev/null
@@ -1,47 +0,0 @@
-(in-package :pcl)
-
-(defun top-level-form-form (form)
-  #+cmu
-  (if (and (consp form) (eq (car form) 'eval-when))
-      (third form)
-      form)
-  #+kcl
-  (fourth (third form))
-  #+lcl3.0
-  (third (third form)))
-
-(defun make-test ()
-  (let ((table (make-hash-table :test 'eq))
-	(count 0))
-    (labels ((fixup (form)
-	       (if (consp form)
-		   (cons (fixup (car form)) (fixup (cdr form)))
-		   (if (and (symbolp form) (null (symbol-package form)))
-		       (or (gethash form table)
-			   (setf (gethash form table)
-				 (intern (format nil "~A-%-~D" (symbol-name form)
-						 (incf count))
-					 *the-pcl-package*)))
-		       form))))
-      (with-open-file (out "test.lisp"
-			   :direction :output :if-exists :supersede)
-	(declare (type stream out))
-	(let ((*print-case* :downcase)
-	      (*print-pretty* t)
-	      (*package* *the-pcl-package*))
-	  (format out "~S~%" '(in-package :pcl))
-	  (let ((i 0)
-		(f (macroexpand '(PRECOMPILE-FUNCTION-GENERATORS PCL))))
-	    (dolist (form (cdr (top-level-form-form f)))
-	      (let ((name (intern (format nil "FGEN-~D" (incf i)))))
-		(format out "~S~%" `(defun ,name () ,(fixup form))))))
-	  (let ((i 0)
-		(f (macroexpand '(PRECOMPILE-DFUN-CONSTRUCTORS PCL))))
-	    (dolist (form (cdr f))
-	      (let ((name (intern (format nil "DFUN-CONSTR-~D" (incf i))))
-		    (form (top-level-form-form form)))
-		(format out "~S~%" `(defun ,name () 
-				      (list ,(second form)
-				            ,(third form)
-				            ,(fixup (macroexpand (fifth form))))))))))))))
-
diff --git a/pcl/makediff b/pcl/makediff
deleted file mode 100755
index 19e46b2738b19b628837b6851f91c7fdd15f4175..0000000000000000000000000000000000000000
Binary files a/pcl/makediff and /dev/null differ
diff --git a/pcl/makefile.akcl b/pcl/makefile.akcl
deleted file mode 100644
index 057a3f9de1150a2a29841fcdeac56d9e54e4c69d..0000000000000000000000000000000000000000
--- a/pcl/makefile.akcl
+++ /dev/null
@@ -1,32 +0,0 @@
-# makefile for making pcl -- W. Schelter.
-
-#  Directions:
-# make -f makefile.akcl compile
-# make -f makefile.akcl saved_pcl
-
-SHELL=/bin/sh
-
-LISP=akcl
-
-
-SETUP='(load "pkg.lisp")(load "defsys.lisp")' \
-	'(setq pcl::*default-pathname-extensions* (cons "lisp" "o"))' \
-	'(setq pcl::*pathname-extensions* (cons "lisp" "o"))' \
-	'(load "sys-proclaim.lisp")(compiler::emit-fn t)'
-
-compile:
-	echo ${SETUP} '(pcl::compile-pcl)' | ${LISP}
-
-saved_pcl:
-	echo ${SETUP} '(pcl::load-pcl)(si::save-system "saved_pcl")' | ${LISP}
-
-
-# remake the sys-package.lisp and sys-proclaim.lisp files
-# Those files may be empty on a first build.
-remake-sys-files:
-	echo ${SETUP} '(pcl::load-pcl)(in-package "PCL")(renew-sys-files)' | ${LISP}
-	cp sys-proclaim.lisp xxx
-	cat xxx | sed -e "s/COMPILER::CMP-ANON//g" > sys-proclaim.lisp
-
-clean:
-	rm -f *.o
diff --git a/pcl/march-92-notes.text b/pcl/march-92-notes.text
deleted file mode 100644
index 913ee4e9703c5997dc172d32d77c581ef76ea377..0000000000000000000000000000000000000000
--- a/pcl/march-92-notes.text
+++ /dev/null
@@ -1,311 +0,0 @@
-These notes correspond to the "March 92 PCL (beta1)" version of PCL.
-
-  This version of PCL is much closer than previous versions of PCL
-to the metaobject protocol specified in "The Art of the Metaobject Protocol", 
-chapters 5 and 6, by Gregor Kiczales, Jim des Riveres, and Daniel G. Bobrow.
-
-
-[Please read the file may-day-notes.text also.  Most of that file still applies.]
-
-Support for structures
-  You can use structure-class as a metaclass to create new classes.
-  Classes created this way create and evaluate defstruct forms which
-  have generated symbols for the structure accessors and constructor.
-  The generated symbols are used by the primary slot-value-using-class
-  methods and by the primary allocate-instance method for structures.
-  Defmethod optimizes usages of slot-value (when no user-defined 
-  slot-value-using-class methods exist) into direct calls of the
-  generated symbol accessor, which the compiler can then optimize further.
-  Even when there are user-defined methods on slot-value-using-class,
-  PCL does a variety of optimizations.
-  
-  If your implementation's version of the *-low.lisp file
-  contains definitions of certain structure functions (see the end of
-  low.lisp, cmu-low.lisp, lucid-low.lisp, and kcl-low.lisp), then
-  structure classes are supported for all defstructs.  In this case,
-  structure classes are created automatically, when necessary.
-
-New Classes:
-structure-class
-structure-object
-slot-class
-slot-object
-structure-direct-slot-definition
-structure-effective-slot-definition
-
-Improvements to slot-access
-  Optimization for slot-value outsize of defmethod
-  Optimization for slot-value inside of defmethod, but not of a specialized parameter.
-  Optimizations that work even when there are :around methods
-  on slot-value-using-class.
-
-New types: 
-   `(class ,class-object)
-   `(class-eq ,class-object)
-
-New specializer class: class-eq-specializer
-  Every class has a class-eq specializer which represents all
-  the direct instances of that class.
-  This is useful in *subtypep.  For example, here is the way 
-  generic-function initialization checks that the method-class is valid:
-   (and (classp method-class)
-	(*subtypep (class-eq-specializer method-class)
-		   (find-class 'standard-method)))
-  If you want to define methods having class-eq specializers,
-  see "Initialization of method metaobjects".  The default behavior of PCL
-  is to disallow this.
-
-compute-applicable-methods-using-types
-
-caching improvements
-
-no magic-generic-functions list
-  This simplifies some things, but complicates some other things.
-  I wanted to support user-defined classes which are their own metaclass.
-  You can now do:
-(defclass y (standard-class) ())
-(defmethod validate-superclass ((c y) (sc standard-class)) t)
-(defclass y (standard-class) () (:metaclass y))
-
-method-function changes (see the comments for make-method-lambda, below)
-
-final dfuns
-
--------------------------
-
-gfs which obey AMOP ch 6
-  add-dependent
-  add-direct-method
-  add-direct-subclass
-  add-method
-  allocate-instance
-  compute-class-precedence-list
-  compute-default-initargs
-  compute-effective-slot-definition
-[Note: compute-effective-slot-definition relys on 
- compute-effective-slot-definition-initargs and effective-slot-definition-class.
- compute-effective-slot-definition-initargs is quite useful, but is not in
- AMOP ch 6.]
-  compute-slots
-  direct-slot-definition-class
-  effective-slot-definition-class
-  ensure-class
-  ensure-class-using-class
-  ensure-generic-function
-  ensure-generic-function-using-class
-  eql-specializer-object
-  extract-lambda-list
-  extract-specializer-names
-  finalize-inheritance
-  find-method-combination
-  funcallable-standard-instance-access
-  {generic-function-method-class, generic-function-method-combination,
-   generic-function-lambda-list, generic-function-methods, generic-function-name}
-  intern-eql-specializer
-  make-instance
-  map-dependents
-  {method-function, method-generic-function, method-lambda-list,
-   method-specializers, method-qualifiers}
-  {class-default-initargs, class-direct-default-initargs, class-direct-slots,
-   class-direct-subclasses, class-direct-superclasses, class-finalized-p,
-   class-name, class-precedence-list, class-prototype, class-slots}
-  {slot-definition-allocation, slot-definition-initargs, slot-definition-initform,
-   slot-definition-initfunction, slot-definition-name, slot-definition-type}
-  {slot-definition-readers, slot-definition-writers}
-  {slot-definition-location}
-  remove-dependent
-  remove-direct-method
-  remove-direct-subclass
-  remove-method
-  set-funcallable-instance-function
-  (setf slot-value-using-class)
-  slot-boundp-using-class
-  slot-makunbound-using-class
-  specializer-direct-generic-functions
-  specializer-direct-methods
-  standard-instance-access
-  update-dependent
-
-gfs which DO NOT obey AMOP ch 6
-
-accessor-method-slot-definition
-  Not yet defined.  Use accessor-method-slot-name and method-specializers
-  to get the direct-slot-definition.
-
-compute-applicable-methods
-compute-applicable-methods-using-classes
-  Handles class-eq specializers without signalling an error.  
-  But see "Initialization of method metaobjects", below.
-
-compute-discriminating-function
-  [the resulting function works differently different because 
-   compute-effective-method is different, and because make-method-lambda 
-   does not exist.]
-
-compute-effective-method
-  Returns only one value.  The utility of bringing this into conformance with
-  AMOP ch 6 is limited by the lack of make-method-lambda.
-
-generic-function-argument-precedence-order
-  Not yet defined.  Can get this information from the arg-info structure.
-
-generic-function-declarations
-  Not yet defined.
-
-make-method-lambda
-  Does not exist.  This will be hard to add in a way that is compatible with
-  AMOP ch 6.
-  1. In March 92 PCL, there are two kinds of method-functions.  The first kind
-     is what method-function returns (which has no special restrinctions on its use).
-     The second kind is returned by method-function-for-caching, which is used
-     when the wrappers of the required arguments are known.  Each call to
-     method-function-for-caching might return a new function.  Both kinds of
-     method functions can be closures.  March 92 PCL currently uses this scheme
-     to do the pv-lookup ahead of time, thereby eliminating pv caching.
-     (pv-lookup means the lookup of the permutation vectors which are used for
-     fast instance varaible access.)   Method function closures can also be used
-     in the optimization of calls to generic-functions, but this has not yet been
-     implemented.
-  2. Since method-functions can be closures, we would need an extra step between
-     compiling (or coercing) the method-lambda into a function, before it can be 
-     applied to arguments with apply or funcall.     
-
-reader-method-class
-  Not yet defined.  Some bootstrapping considerations are involved, 
-  but adding this will not be very hard.
-
-(setf class-name)
-  Currently just a writer method.  Does not call reinitialize-instance or
-  (setf find-class).
-
-(setf generic-function-name)
-  Currently just a writer method.  Does not call reinitialize-instance.
-
-writer-method-class
-  Not yet defined.  Some bootstrapping considerations are involved, 
-  but adding this will not be very hard.
-
----------------------------
-
-Initialization of method metaobjects
-  The following methods are defined:
-    legal-qualifiers-p (method standard-method) qualifiers
-    legal-lambda-list-p (method standard-method) lambda-list
-    legal-specializers-p (method standard-method) specializers
-    legal-method-function-p (method standard-method) function
-    legal-documentation-p (method standard-method) documentation
-
-    legal-specializer-p (method standard-method) specializer
-
-  You can override them if you want.
-  The method for legal-specializers-p calls legal-specializer-p
-  on each specializer.
-  The method for legal-specializer-p allows any kind of specializer
-  when the variable *allow-experimental-specializers-p* is t
-  (this variable is initially nil).
-
----------------------------
-Optimizations on slot-value
-  Outside of a defmethod when define-compiler-macro is not implemented
-  or the slot-name is not constant, or
-  Inside a defmethod when the slot-name is not a constant:
-(1)   no optimization of slot-value, slot-value-using-class is called.
-      slot-value-using-class has a special dfun, though, which calls
-      the slot's slot-definition-reader-function.  This function is
-      a result of get-accessor-method-function.
-  Outside of a defmethod when define-compiler-macro is implemented and
-  the slot-name is a constant, or
-  Inside a defmethod when the slot-name is a constant but the object is 
-  not either (the value of a parameter specialized to a subclass of structure-object
-  for which no user-defined slot-value-using-class methods apply at defmethod time), 
-  or (the value of a parameter specialized to a subclass of standard-object).
-(2)   PCL arranges to call an automatically created generic function
-      which has one method: a reader method defined on class slot-object.
-  Inside a defmethod when the slot-name is a constant and the object 
-  is (the value of a parameter specialized to a subclass of structure-object
-  for which no user-defined slot-value-using-class methods apply).
-(3)   The slot-value form is converted to a call of the structure slot's 
-      accessor function, which the compiler can then optimize further.
-  Inside a defmethod when the slot-name is a constant and the object 
-  is (the value of a parameter specialized to a subclass of standard-object).
-(4)   The access requires two arefs, a call to (typep x 'fixnum), and a call to eq,
-      in the best case.  If user defined slot-value-using-class methods apply
-      at slot-value execution time, or the slot is unbound, the unoptimized 
-      slot-value function (1) is called.  This was in May Day PCL; what is new here
-      is that the PV (permutation vector) is looked up at defmethod load time
-      rather than at run time, if the effective method is cached.
-
-Generic functions containing only accessor methods for which no user-defined
-methods on slot-value-using-class apply and which involve only standard-classes:
-      A special dfun is called: one-class, two-class, one-index, or n-n.
-      These were all in May Day PCL.
-Generic functions excluded by the above, which contain accessor methods:
-      In place of each accessor method's method-function, a function returned by
-      get-accessor-method-function is used.
-
-get-accessor-method-function (gf type class slotd) ; type is reader, writer, or boundp.
-  If there is only one applicable method,
-      (This method will be the system supplied one)
-      the function that is returned is optimized for the current state of the
-      class.  When the class changes, it must be recomputed.
-  otherwise,
-      a secondary dispatch function for slot-value-using-class is computed
-      (using what is known about the types of the arguments) and converted 
-      into an accessor function.
-
-get-secondary-dispatch-function (gf methods types &optional method-alist wrappers)
-  The types argument describes what is known about the types of the arguments.
-  Method-alist is used (when supplied) to do things like replace the
-  standard slot-value-using-class method function with a function optimized
-  for what is known about the arguments.
-  Wrappers (when supplied) means that the resulting function is guaranteed to
-  be called only whith those wrappers.  Make-effective-method-function calls
-  the generic-function method-function-for-caching with method-alist and
-  wrappers to get a optimized method function.  (PV lookup is done at the time
-  method-function-for-caching is called).
-
-compute-applicable-methods:  Here I tried to stick with the MOP.
-  The function cache-miss-values looks at the second value of the result of 
-  compute-applicable-methods-using-classes.  If this value is null, we aren't 
-  supposed to cache the result of camuc.  So we don't.  Instead we cache a 
-  result of (default-secondary-dispatch-function gf), which in turn calls 
-  compute-applicable-methods each time it is called.
----------------------------
-
-To do:
-
-1.   Make the metaobject protocol function symbols be the external symbols
-  of a package, so they can be used easily.
-
-Problem: sometimes there is no need to call a gf's dfun: the emf that is invoked
-         can be cached in the caller's method closure.
-         make-instance is slow.
-2.  In expand-defmethod-internal, optimize calls to generic-functions.
-  Add the support for this optimization.
-
-3.   Make sure that use-dispatch-dfun-p is doing the right thing.
-
-4.   [When CMUCL improves its setf handling, remove the comment in
-   the file macros.lisp beginning the line ";#+cmu (pushnew :setf *features*)"]
-
-
-
---------------
-1) Generalize expand-defmethod-internal so that it can be used for non-defmethod
-code.  Maybe by (a) having a parameter that says whether it is being called by 
-defmethod, and (b) using the techniques used by the series package (shadowing 
-defun and some others, making the shadowed definitions call e-d-i, making it 
-easy for people to do the relevant package modifications)
-
-2) Extending generic-functions by allowing the user at defgeneric time to supply
-the name of a function which will be supplied (by the system) with a definition
-which will return equivalent results to those returned by the generic function,
-but which will (in some cases) have less checking than the generic function.
-One-class, two-class, and one-index gf dfuns will map to a result of 
-get-optimized-std-accessor-method-function, checking gf dfuns will map to their
-function, and any other dfun will remain the same.
-
-3) Extending expand-defmethod-internal to optimize calls to generic-functions.
-There are a variety of possibilities that need to be considered; one of them
-will be to arrange to call the optimized functions produced by (2) when it
-is known to be safe.  
diff --git a/pcl/may-day-notes.text b/pcl/may-day-notes.text
deleted file mode 100644
index 3e2175e2446047bee455b2fd0117a05c85e4f597..0000000000000000000000000000000000000000
--- a/pcl/may-day-notes.text
+++ /dev/null
@@ -1,98 +0,0 @@
-Copyright (c) Xerox Corporation 1989, 1990. All rights reserved.
-
-These notes correspond to the "5/1/90 May Day PCL (REV 2)" version of PCL.
-
-This version is just Rainy Day PCL with the various patches people have
-mailed out included.  Barring unforseen circumstances, this will be the
-last version of PCL.  We are now working on the Metaobject Protocol.
-
-
-Please read this entire file carefully.  Failure to do so guarantees
-that you will have problems porting your code from the previous release
-of PCL.
-
-You may also be interested in looking at previous versions of the
-notes.text file.  These are called xxx-notes.text where xxx is the
-version of the PCL system the file corresponds to.  At least the last
-two versions of this file contain useful information for any PCL user.
-
-This version of PCL has been tested at PARC in the following Common
-Lisps:
-
-  Symbolics 7.2, 7.4
-  Coral 1.3
-  Lucid 3.0
-  Allegro 3.0.1
-
-These should work, but haven't been tested yet:
-
-  TI
-  Golden Common Lisp 3.1
-  EnvOS Medley
-  IBCL (October 15, 1987)
-
-This release of PCL is substantially different from previous releases.
-The architecture of the runtime system (method lookup and slot access)
-is different, and the metaobject protocol is different.  Much of the
-code in this release is new or modified from the last release.
-
-When it stabilizes, this release should be much faster for all
-applications especially large ones.
-
-This beta version of the new release includes a number of known
-problems.  These include:
-
-* Even less documentation than ever before.  I haven't written much of a
-notes file for what is different yet.  Please send me comments for what
-to include in this file.
-
-* Some known performance problems in development versions of compilers.
-At the very least, you want to compile PCL itself using the highest
-performance compiler settings you have.  
-
-
-=== Notes for this release (such as they are) ===
-
-* There is one major incompatible change in this release.  In this
-release compiling files with defmethod and defclass forms doesn't, by
-default, affect the running lisp image.  The winning part of this is you
-can compile a file without `installing' the class and method definitions
-in the file.  The losing part is that because PCL is a portable program,
-it can't both do this and let a class definition and a method which
-specializes to that class appear in the same file.
-
-So, you can't (by default) have:
-
-  (defclass foo () ())
-  (defmethod bar ((f foo)) 'foo)
-
-in the same file.
-
-But you say you want to do this, almost everyone does.  If you want to
-do this just evaluate the following form before after loading PCL but
-before working with it:
-
-  (pushnew 'compile pcl::*defclass-times*)
-
-You may also want to do:
-
-  (pushnew 'compile pcl::*defmethod-times*)
-
-
-* You probably also want to begin using a precom file for your system.
-Do this by having a file whose only contents is
-
-  (pcl::precompile-random-code-segments <your-system-name>)
-
-don't quote <your-system-name>
-
-for example, for the clim system, the precom file has the one line:
-
-  (pcl::precompile-random-code-segments clim)
-
-compile this file after loading and running your system for a while.
-load it before loading your compiled system.  A future version of this
-feature won't require you to have run your system for a while, it will
-only require that you have loaded it.
-
-
diff --git a/pcl/methods.lisp b/pcl/methods.lisp
deleted file mode 100644
index 625b5bd4ad64951e129c03973e592dafc0309acf..0000000000000000000000000000000000000000
--- a/pcl/methods.lisp
+++ /dev/null
@@ -1,1646 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-(defmethod print-object (instance stream)
-  (printing-random-thing (instance stream)
-    (let ((name (class-name (class-of instance))))
-      (if name
-	  (format stream "~S" name)
-	  (format stream "Instance")))))
-
-(defmethod print-object ((class class) stream)
-  (named-object-print-function class stream))
-
-(defmethod print-object ((slotd slot-definition) stream)
-  (named-object-print-function slotd stream))
-
-(defun named-object-print-function (instance stream
-				    &optional (extra nil extra-p))
-  (printing-random-thing (instance stream)
-    (if extra-p					
-	(format stream "~A ~S ~:S"
-		(capitalize-words (class-name (class-of instance)))
-		(slot-value-or-default instance 'name)
-		extra)
-	(format stream "~A ~S"
-		(capitalize-words (class-name (class-of instance)))
-		(slot-value-or-default instance 'name)))))
-
-(defmethod print-object ((mc standard-method-combination) stream)
-  (printing-random-thing (mc stream)
-    (format stream
-	    "Method-Combination ~S ~S"
-	    (slot-value-or-default mc 'type)
-	    (slot-value-or-default mc 'options))))
-
-
-;;;
-;;;
-;;;
-(defmethod shared-initialize :after ((slotd standard-slot-definition) slot-names &key)
-  (declare (ignore slot-names))
-  (with-slots (allocation class)
-    slotd
-    (setq allocation (if (eq allocation :class) class allocation))))
-
-(defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names 
-				     &key (allocation :instance))
-  (declare (ignore slot-names))
-  (unless (eq allocation :instance)
-    (error "structure slots must have :instance allocation")))
-
-(defmethod inform-type-system-about-class ((class structure-class) (name t))
-  nil)
-
-;;;
-;;; METHODS
-;;;
-;;; Methods themselves are simple inanimate objects.  Most properties of
-;;; methods are immutable, methods cannot be reinitialized.  The following
-;;; properties of methods can be changed:
-;;;   METHOD-GENERIC-FUNCTION
-;;;   METHOD-FUNCTION            ??
-;;;   
-;;;
-
-(defmethod method-function ((method standard-method))
-  (or (slot-value method 'function)
-      (let ((fmf (slot-value method 'fast-function)))
-	(unless fmf ; the :before shared-initialize method prevents this
-	  (error "~S doesn't seem to have a method-function" method))
-	(setf (slot-value method 'function)
-	      (method-function-from-fast-function fmf)))))
-
-(defmethod accessor-method-class ((method standard-accessor-method))
-  (car (slot-value method 'specializers)))
-
-(defmethod accessor-method-class ((method standard-writer-method))
-  (cadr (slot-value method 'specializers)))
-
-(defmethod print-object ((method standard-method) stream)
-  (printing-random-thing (method stream)
-    (if (slot-boundp method 'generic-function)
-	(let ((generic-function (method-generic-function method))
-	      (class-name (capitalize-words (class-name (class-of method)))))
-	  (format stream "~A ~S ~{~S ~}~:S"
-		  class-name
-		  (and generic-function (generic-function-name generic-function))
-		  (method-qualifiers method)
-		  (unparse-specializers method)))
-	(call-next-method))))
-
-(defmethod print-object ((method standard-accessor-method) stream)
-  (printing-random-thing (method stream)
-    (if (slot-boundp method 'generic-function)
-	(let ((generic-function (method-generic-function method))
-	      (class-name (capitalize-words (class-name (class-of method)))))
-	  (format stream "~A ~S, slot:~S, ~:S"
-		  class-name
-		  (and generic-function (generic-function-name generic-function))
-		  (accessor-method-slot-name method)
-		  (unparse-specializers method)))
-	(call-next-method))))
-
-;;;
-;;; INITIALIZATION
-;;;
-;;; Error checking is done in before methods.  Because of the simplicity of
-;;; standard method objects the standard primary method can fill the slots.
-;;;
-;;; Methods are not reinitializable.
-;;; 
-
-(defmethod reinitialize-instance ((method standard-method) &rest initargs)
-  (declare (ignore initargs))
-  (error "Attempt to reinitialize the method ~S.~%~
-          Method objects cannot be reinitialized."
-	 method))
-
-(defmethod legal-documentation-p ((object standard-method) x)
-  (if (or (null x) (stringp x))
-      t
-      "a string or NULL"))
-
-(defmethod legal-lambda-list-p ((object standard-method) x)
-  (declare (ignore x))
-  t)
-
-(defmethod legal-method-function-p ((object standard-method) x)
-  (if (functionp x)
-      t
-      "a function"))
-
-(defmethod legal-qualifiers-p ((object standard-method) x)
-  (flet ((improper-list ()
-	   (return-from legal-qualifiers-p "Is not a proper list.")))
-    (dolist-carefully (q x improper-list)
-      (let ((ok (legal-qualifier-p object q)))
-	(unless (eq ok t)
-	  (return-from legal-qualifiers-p
-	    (format nil "Contains ~S which ~A" q ok)))))
-    t))
-
-(defmethod legal-qualifier-p ((object standard-method) x)
-  (if (and x (atom x))
-      t
-      "is not a non-null atom"))
-
-(defmethod legal-slot-name-p ((object standard-method) x)
-  (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")
-	((keywordp x)      "is a keyword and so cannot be bound")
-	((memq x '(t nil)) "cannot be bound")
-	((constantp x)     "is a constant and so cannot be bound")
-	(t t)))
-
-(defmethod legal-specializers-p ((object standard-method) x)
-  (flet ((improper-list ()
-	   (return-from legal-specializers-p "Is not a proper list.")))
-    (dolist-carefully (s x improper-list)
-      (let ((ok (legal-specializer-p object s)))
-	(unless (eq ok t)
-	  (return-from legal-specializers-p
-	    (format nil "Contains ~S which ~A" s ok)))))
-    t))
-
-(defvar *allow-experimental-specializers-p* nil)
-
-(defmethod legal-specializer-p ((object standard-method) x)
-  (if (if *allow-experimental-specializers-p*
-	  (specializerp x)
-	  (or (classp x)
-	      (eql-specializer-p x)))
-      t
-      "is neither a class object nor an eql specializer"))
-
-(defmethod shared-initialize :before ((method standard-method)
-				      slot-names
-				      &key qualifiers
-					   lambda-list
-					   specializers
-					   function
-				           fast-function
-					   documentation)
-  (declare (ignore slot-names))
-  (flet ((lose (initarg value string)
-	   (error "When initializing the method ~S:~%~
-                   The ~S initialization argument was: ~S.~%~
-                   which ~A."
-		  method initarg value string)))
-    (let ((check-qualifiers    (legal-qualifiers-p method qualifiers))
-	  (check-lambda-list   (legal-lambda-list-p method lambda-list))
-	  (check-specializers  (legal-specializers-p method specializers))
-	  (check-function      (legal-method-function-p method (or function
-								   fast-function)))
-	  (check-documentation (legal-documentation-p method documentation)))
-      (unless (eq check-qualifiers t)
-	(lose :qualifiers qualifiers check-qualifiers))
-      (unless (eq check-lambda-list t)
-	(lose :lambda-list lambda-list check-lambda-list))
-      (unless (eq check-specializers t)
-	(lose :specializers specializers check-specializers))
-      (unless (eq check-function t)
-	(lose :function function check-function))
-      (unless (eq check-documentation t)
-	(lose :documentation documentation check-documentation)))))
-
-(defmethod shared-initialize :before ((method standard-accessor-method)
-				      slot-names
-				      &key slot-name slot-definition)
-  (declare (ignore slot-names))
-  (unless slot-definition
-    (let ((legalp (legal-slot-name-p method slot-name)))
-      (unless (eq legalp t)
-	(error "The value of the :SLOT-NAME initarg ~A." legalp)))))
-
-(defmethod shared-initialize :after ((method standard-method) slot-names
-				     &rest initargs
-				     &key qualifiers method-spec plist)
-  (declare (ignore slot-names method-spec plist))
-  (initialize-method-function initargs nil method)
-  (setf (plist-value method 'qualifiers) qualifiers)
-  #+ignore
-  (setf (slot-value method 'closure-generator) 
-	(method-function-closure-generator (slot-value method 'function))))
-
-(defmethod shared-initialize :after ((method standard-accessor-method)
-				     slot-names
-				     &key)
-  (declare (ignore slot-names))
-  (with-slots (slot-name slot-definition)
-    method
-    (unless slot-definition
-      (let ((class (accessor-method-class method)))
-	(when (slot-class-p class)
-	  (setq slot-definition (find slot-name (class-direct-slots class)
-				      :key #'slot-definition-name)))))
-    (when (and slot-definition (null slot-name))
-      (setq slot-name (slot-definition-name slot-definition)))))
-
-(defmethod method-qualifiers ((method standard-method))
-  (plist-value method 'qualifiers))
-
-
-
-(defvar *the-class-generic-function*          (find-class 'generic-function))
-(defvar *the-class-standard-generic-function* (find-class 'standard-generic-function))
-
-
-
-(defmethod print-object ((generic-function generic-function) stream)
-  (named-object-print-function
-    generic-function
-    stream
-    (if (slot-boundp generic-function 'methods)
-	(list (length (generic-function-methods generic-function)))
-	"?")))
-
-(defmethod shared-initialize :before
-	   ((generic-function standard-generic-function)
-	    slot-names
-	    &key (name nil namep)
-		 (lambda-list () lambda-list-p)
-		 argument-precedence-order
-		 declarations
-		 documentation
-		 (method-class nil method-class-supplied-p)
-		 (method-combination nil method-combination-supplied-p))
-  (declare (ignore slot-names
-		   declarations argument-precedence-order documentation
-		   lambda-list lambda-list-p))
-
-  (when namep
-    (set-function-name generic-function name))
-		   
-  (flet ((initarg-error (initarg value string)
-	   (error "When initializing the generic-function ~S:~%~
-                   The ~S initialization argument was: ~A.~%~
-                   It must be ~A."
-		  generic-function initarg value string)))
-    (cond (method-class-supplied-p
-	   (when (symbolp method-class)
-	     (setq method-class (find-class method-class)))
-	   (unless (and (classp method-class)
-			(*subtypep (class-eq-specializer method-class)
-				   *the-class-method*))
-	     (initarg-error :method-class
-			    method-class
-			    "a subclass of the class METHOD"))
-	   (setf (slot-value generic-function 'method-class) method-class))
-	  ((slot-boundp generic-function 'method-class))
-	  (t
-	   (initarg-error :method-class
-			  "not supplied"
-			  "a subclass of the class METHOD")))
-    (cond (method-combination-supplied-p
-	   (unless (method-combination-p method-combination)
-	     (initarg-error :method-combination
-			    method-combination
-			    "a method combination object")))
-	  ((slot-boundp generic-function 'method-combination))
-	  (t
-	   (initarg-error :method-combination
-			  "not supplied"
-			  "a method combination object")))))
-
-
-#||
-(defmethod reinitialize-instance ((generic-function standard-generic-function)
-				  &rest initargs
-				  &key name
-				       lambda-list
-				       argument-precedence-order
-				       declarations
-				       documentation
-				       method-class
-				       method-combination)
-  (declare (ignore documentation declarations argument-precedence-order
-		   lambda-list name method-class method-combination))
-  (macrolet ((add-initarg (check name slot-name)
-	       `(unless ,check
-		  (push (slot-value generic-function ,slot-name) initargs)
-		  (push ,name initargs))))
-;   (add-initarg name :name 'name)
-;   (add-initarg lambda-list :lambda-list 'lambda-list)
-;   (add-initarg argument-precedence-order
-;		 :argument-precedence-order
-;		 'argument-precedence-order)
-;   (add-initarg declarations :declarations 'declarations)
-;   (add-initarg documentation :documentation 'documentation)
-;   (add-initarg method-class :method-class 'method-class)
-;   (add-initarg method-combination :method-combination 'method-combination)
-    (apply #'call-next-method generic-function initargs)))
-||#
-
-
-;;;
-;;; These three are scheduled for demolition.
-;;; 
-(defmethod remove-named-method (generic-function-name argument-specifiers
-						      &optional extra)
-  (let ((generic-function ())
-	(method ()))
-    (cond ((or (null (fboundp generic-function-name))
-	       (not (generic-function-p
-		      (setq generic-function
-			    (symbol-function generic-function-name)))))
-	   (error "~S does not name a generic-function."
-		  generic-function-name))
-	  ((null (setq method (get-method generic-function
-					  extra
-					  (parse-specializers
-					    argument-specifiers)
-					  nil)))
-	   (error "There is no method for the generic-function ~S~%~
-                   which matches the argument-specifiers ~S."
-		  generic-function
-		  argument-specifiers))
-	  (t
-	   (remove-method generic-function method)))))
-
-(defun real-add-named-method (generic-function-name
-			      qualifiers
-			      specializers
-			      lambda-list
-			      &rest other-initargs)
-  #+copy-&rest-arg (setq other-initargs (copy-list other-initargs))
-  ;; What about changing the class of the generic-function if there is
-  ;; one.  Whose job is that anyways.  Do we need something kind of
-  ;; like class-for-redefinition?
-  (let* ((generic-function
-	   (ensure-generic-function generic-function-name))
-	 (specs (parse-specializers specializers))
-;	 (existing (get-method generic-function qualifiers specs nil))
-	 (proto (method-prototype-for-gf generic-function-name))
-	 (new (apply #'make-instance (class-of proto)
-				     :qualifiers qualifiers
-				     :specializers specs
-				     :lambda-list lambda-list
-				     other-initargs)))
-;   (when existing (remove-method generic-function existing))
-    (add-method generic-function new)))
-
-	
-(defun make-specializable (function-name &key (arglist nil arglistp))
-  (cond ((not (null arglistp)))
-	((not (fboundp function-name)))
-	((fboundp 'function-arglist)
-	 ;; function-arglist exists, get the arglist from it.
-	 (setq arglist (function-arglist function-name)))
-	(t
-	 (error
-	   "The :arglist argument to make-specializable was not supplied~%~
-            and there is no version of FUNCTION-ARGLIST defined for this~%~
-            port of Portable CommonLoops.~%~
-            You must either define a version of FUNCTION-ARGLIST (which~%~
-            should be easy), and send it off to the Portable CommonLoops~%~
-            people or you should call make-specializable again with the~%~
-            :arglist keyword to specify the arglist.")))
-  (let ((original (and (fboundp function-name)
-		       (symbol-function function-name)))
-	(generic-function (make-instance 'standard-generic-function
-					 :name function-name))
-	(nrequireds 0))
-    (if (generic-function-p original)
-	original
-	(progn
-	  (dolist (arg arglist)
-	    (if (memq arg lambda-list-keywords)
-		(return)
-		(incf nrequireds)))
-	  (setf (gdefinition function-name) generic-function)
-	  (set-function-name generic-function function-name)
-	  (when arglistp
-	    (setf (gf-pretty-arglist generic-function) arglist))
-	  (when original
-	    (add-named-method function-name
-			      ()
-			      (make-list nrequireds :initial-element 't)
-			      arglist
-			      (list :function
-				    #'(lambda (args next-methods)
-					(declare (ignore next-methods))
-					(apply original args)))))
-	  generic-function))))
-
-
-
-(defun real-get-method (generic-function qualifiers specializers
-					 &optional (errorp t))
-  (let ((hit
-	  (dolist (method (generic-function-methods generic-function))
-	    (when (and (equal qualifiers (method-qualifiers method))
-		       (every #'same-specializer-p specializers
-			      (method-specializers method)))
-	      (return method)))))
-    (cond (hit hit)
-	  ((null errorp) nil)
-	  (t
-	   (error "No method on ~S with qualifiers ~:S and specializers ~:S."
-		  generic-function qualifiers specializers)))))
-
-
-;;;
-;;; Compute various information about a generic-function's arglist by looking
-;;; at the argument lists of the methods.  The hair for trying not to use
-;;; &rest arguments lives here.
-;;;  The values returned are:
-;;;    number-of-required-arguments
-;;;       the number of required arguments to this generic-function's
-;;;       discriminating function
-;;;    &rest-argument-p
-;;;       whether or not this generic-function's discriminating
-;;;       function takes an &rest argument.
-;;;    specialized-argument-positions
-;;;       a list of the positions of the arguments this generic-function
-;;;       specializes (e.g. for a classical generic-function this is the
-;;;       list: (1)).
-;;;
-(defmethod compute-discriminating-function-arglist-info
-	   ((generic-function standard-generic-function))
-  ;;(declare (values number-of-required-arguments &rest-argument-p
-  ;;                 specialized-argument-postions))
-  (let ((number-required nil)
-        (restp nil)
-        (specialized-positions ())
-	(methods (generic-function-methods generic-function)))
-    (dolist (method methods)
-      (multiple-value-setq (number-required restp specialized-positions)
-        (compute-discriminating-function-arglist-info-internal
-	  generic-function method number-required restp specialized-positions)))
-    (values number-required restp (sort specialized-positions #'<))))
-
-(defun compute-discriminating-function-arglist-info-internal
-       (generic-function method number-of-requireds restp
-	specialized-argument-positions)
-  (declare (ignore generic-function) (type (or null fixnum) number-of-requireds))
-  (let ((requireds 0))
-    (declare (fixnum requireds))
-    ;; Go through this methods arguments seeing how many are required,
-    ;; and whether there is an &rest argument.
-    (dolist (arg (method-lambda-list method))
-      (cond ((eq arg '&aux) (return))
-            ((memq arg '(&optional &rest &key))
-             (return (setq restp t)))
-	    ((memq arg lambda-list-keywords))
-            (t (incf requireds))))
-    ;; Now go through this method's type specifiers to see which
-    ;; argument positions are type specified.  Treat T specially
-    ;; in the usual sort of way.  For efficiency don't bother to
-    ;; keep specialized-argument-positions sorted, rather depend
-    ;; on our caller to do that.
-    (iterate ((type-spec (list-elements (method-specializers method)))
-              (pos (interval :from 0)))
-      (unless (eq type-spec *the-class-t*)
-	(pushnew pos specialized-argument-positions)))
-    ;; Finally merge the values for this method into the values
-    ;; for the exisiting methods and return them.  Note that if
-    ;; num-of-requireds is NIL it means this is the first method
-    ;; and we depend on that.
-    (values (min (or number-of-requireds requireds) requireds)
-            (or restp
-		(and number-of-requireds (/= number-of-requireds requireds)))
-            specialized-argument-positions)))
-
-(defun make-discriminating-function-arglist (number-required-arguments restp)
-  (nconc (gathering ((args (collecting)))
-           (iterate ((i (interval :from 0 :below number-required-arguments)))
-             (gather (intern (format nil "Discriminating Function Arg ~D" i))
-		     args)))
-         (when restp
-               `(&rest ,(intern "Discriminating Function &rest Arg")))))
-
-
-;;;
-;;;
-;;;
-
-(defmethod generic-function-lambda-list ((gf generic-function))
-  (gf-lambda-list gf))
-
-(defmethod gf-fast-method-function-p ((gf standard-generic-function))
-  (gf-info-fast-mf-p (slot-value gf 'arg-info)))
-
-(defmethod initialize-instance :after ((gf standard-generic-function)
-				       &key (lambda-list nil lambda-list-p)
-				       argument-precedence-order)
-  (with-slots (arg-info)
-    gf
-    (if lambda-list-p
-	(set-arg-info gf 
-		      :lambda-list lambda-list
-		      :argument-precedence-order argument-precedence-order)
-	(set-arg-info gf))
-    (when (arg-info-valid-p arg-info)
-      (update-dfun gf))))
-
-(defmethod reinitialize-instance :after ((gf standard-generic-function)
-					 &rest args
-					 &key (lambda-list nil lambda-list-p)
-					 (argument-precedence-order 
-					  nil argument-precedence-order-p))
-  (with-slots (arg-info)
-    gf
-    (if lambda-list-p
-	(if argument-precedence-order-p
-	    (set-arg-info gf 
-			  :lambda-list lambda-list
-			  :argument-precedence-order argument-precedence-order)
-	    (set-arg-info gf 
-			  :lambda-list lambda-list))
-	(set-arg-info gf))
-    (when (and (arg-info-valid-p arg-info)
-	       args
-	       (or lambda-list-p (cddr args)))
-      (update-dfun gf))))
-
-;;;
-;;;
-;;;
-
-(proclaim '(special *lazy-dfun-compute-p*))
-
-(defun set-methods (gf methods)
-  (setf (generic-function-methods gf) nil)
-  (loop (when (null methods) (return gf))
-	(real-add-method gf (pop methods) methods)))
-
-(defun real-add-method (generic-function method &optional skip-dfun-update-p)
-  (if (method-generic-function method)
-      (error "The method ~S is already part of the generic~@
-              function ~S.  It can't be added to another generic~@
-              function until it is removed from the first one."
-	     method (method-generic-function method))
-
-      (let* ((name (generic-function-name generic-function))
-	     (qualifiers   (method-qualifiers method))
-	     (specializers (method-specializers method))
-	     (existing (get-method generic-function qualifiers specializers nil)))
-	;;
-	;; If there is already a method like this one then we must
-	;; get rid of it before proceeding.  Note that we call the
-	;; generic function remove-method to remove it rather than
-	;; doing it in some internal way.
-	;; 
-	(when existing (remove-method generic-function existing))
-	;;
-	(setf (method-generic-function method) generic-function)
-	(pushnew method (generic-function-methods generic-function))
-	(dolist (specializer specializers)
-	  (add-direct-method specializer method))
-	(set-arg-info generic-function :new-method method)
-	(unless skip-dfun-update-p
-	  (when (member name 
-			'(make-instance default-initargs
-			  allocate-instance shared-initialize initialize-instance))
-	    (update-make-instance-function-table (type-class (car specializers))))
-	  (update-dfun generic-function))
-	method)))
-  
-(defun real-remove-method (generic-function method)
-  (if  (neq generic-function (method-generic-function method))
-       (error "The method ~S is attached to the generic function~@
-               ~S.  It can't be removed from the generic function~@
-               to which it is not attached."
-	      method (method-generic-function method))
-       (let* ((name         (generic-function-name generic-function))
-	      (specializers (method-specializers method))
-	      (methods      (generic-function-methods generic-function))
-	      (new-methods  (remove method methods)))	      
-	 (setf (method-generic-function method) nil)
-	 (setf (generic-function-methods generic-function) new-methods)
-	 (dolist (specializer (method-specializers method))
-	   (remove-direct-method specializer method))
-	 (set-arg-info generic-function)
-	 (when (member name '(make-instance default-initargs
-			      allocate-instance shared-initialize initialize-instance))
-	   (update-make-instance-function-table (type-class (car specializers))))
-	 (update-dfun generic-function)
-	 generic-function)))
-
-
-(defun compute-applicable-methods-function (generic-function arguments)
-  (values (compute-applicable-methods-using-types 
-	   generic-function
-	   (types-from-arguments generic-function arguments 'eql))))
-  
-(defmethod compute-applicable-methods 
-    ((generic-function generic-function) arguments)
-  (values (compute-applicable-methods-using-types 
-	   generic-function
-	   (types-from-arguments generic-function arguments 'eql))))
-
-(defmethod compute-applicable-methods-using-classes 
-    ((generic-function generic-function) classes)
-  (compute-applicable-methods-using-types 
-   generic-function
-   (types-from-arguments generic-function classes 'class-eq)))
-
-(defun proclaim-incompatible-superclasses (classes)
-  (setq classes (mapcar #'(lambda (class)
-			    (if (symbolp class)
-				(find-class class)
-				class))
-			classes))
-  (dolist (class classes)
-    (dolist (other-class classes)
-      (unless (eq class other-class)
-	(pushnew other-class (class-incompatible-superclass-list class))))))
-
-(defun superclasses-compatible-p (class1 class2)
-  (let ((cpl1 (class-precedence-list class1))
-	(cpl2 (class-precedence-list class2)))
-    (dolist (sc1 cpl1 t)
-      (dolist (ic (class-incompatible-superclass-list sc1))
-	(when (memq ic cpl2)
-	  (return-from superclasses-compatible-p nil))))))
-
-(mapc
- #'proclaim-incompatible-superclasses
- '(;; superclass class
-   (built-in-class std-class structure-class) ; direct subclasses of pcl-class
-   (standard-class funcallable-standard-class)
-   ;; superclass metaobject
-   (class eql-specializer class-eq-specializer method method-combination
-    generic-function slot-definition)
-   ;; metaclass built-in-class
-   (number sequence character   	; direct subclasses of t, but not array
-    standard-object structure-object)   ;                         or symbol
-   (number array character symbol	; direct subclasses of t, but not sequence
-    standard-object structure-object)
-   (complex float rational)		; direct subclasses of number
-   (integer ratio)			; direct subclasses of rational
-   (list vector)			; direct subclasses of sequence
-   (cons null)				; direct subclasses of list
-   (string bit-vector)			; direct subclasses of vector
-   ))
-
-
-
-
-(defmethod same-specializer-p ((specl1 specializer) (specl2 specializer))
-  nil)
-
-(defmethod same-specializer-p ((specl1 class) (specl2 class))
-  (eq specl1 specl2))
-
-(defmethod specializer-class ((specializer class))
-  specializer)
-
-(defmethod same-specializer-p ((specl1 class-eq-specializer)
-			       (specl2 class-eq-specializer))
-  (eq (specializer-class specl1) (specializer-class specl2)))
-
-(defmethod same-specializer-p ((specl1 eql-specializer)
-			       (specl2 eql-specializer))
-  (eq (specializer-object specl1) (specializer-object specl2)))
-
-(defmethod specializer-class ((specializer eql-specializer))
-  (class-of (slot-value specializer 'object)))
-
-(defvar *in-gf-arg-info-p* nil)
-(setf (gdefinition 'arg-info-reader)
-      (let ((mf (initialize-method-function
-		 (make-internal-reader-method-function
-		  'standard-generic-function 'arg-info)
-		 t)))
-	#'(lambda (&rest args) (funcall mf args nil))))
-
-(defun types-from-arguments (generic-function arguments &optional type-modifier)
-  (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
-      (get-generic-function-info generic-function)
-    (declare (ignore applyp metatypes nkeys))
-    (let ((types-rev nil))
-      (dotimes (i nreq)
-	i
-	(unless arguments
-	  (error "The function ~S requires at least ~D arguments"
-		 (generic-function-name generic-function)
-		 nreq))
-	(let ((arg (pop arguments)))
-	  (push (if type-modifier `(,type-modifier ,arg) arg) types-rev)))
-      (values (nreverse types-rev) arg-info))))
-
-(defun get-wrappers-from-classes (nkeys wrappers classes metatypes)
-  (let* ((w wrappers) (w-tail w) (mt-tail metatypes))
-    (dolist (class (if (listp classes) classes (list classes)))
-      (unless (eq 't (car mt-tail))
-	(let ((c-w (class-wrapper class)))
-	  (unless c-w (return-from get-wrappers-from-classes nil))
-	  (if (eql nkeys 1)
-	      (setq w c-w)
-	      (setf (car w-tail) c-w
-		    w-tail (cdr w-tail)))))
-      (setq mt-tail (cdr mt-tail)))
-    w))
-
-(defun sdfun-for-caching (gf classes)
-  (let ((types (mapcar #'class-eq-type classes)))
-    (multiple-value-bind (methods all-applicable-and-sorted-p)
-	(compute-applicable-methods-using-types gf types)
-      (function-funcall (get-secondary-dispatch-function1 
-			 gf methods types nil t all-applicable-and-sorted-p)
-			nil (mapcar #'class-wrapper classes)))))
-
-(defun value-for-caching (gf classes)
-  (let ((methods (compute-applicable-methods-using-types 
-		   gf (mapcar #'class-eq-type classes))))
-    (method-function-get (or (method-fast-function (car methods))
-			     (method-function (car methods)))
-			 :constant-value)))
-
-(defun default-secondary-dispatch-function (generic-function)
-  #'(lambda (&rest args)
-      #+copy-&rest-arg (setq args (copy-list args))
-      (let ((methods (compute-applicable-methods generic-function args)))
-	(if methods
-	    (let ((emf (get-effective-method-function generic-function methods)))
-	      (invoke-emf emf args))
-	    (apply #'no-applicable-method generic-function args)))))
-
-(defun list-eq (x y)
-  (loop (when (atom x) (return (eq x y)))
-	(when (atom y) (return nil))
-	(unless (eq (car x) (car y)) (return nil))
-	(setq x (cdr x)  y (cdr y))))
-
-(defvar *std-cam-methods* nil)
-
-(defun compute-applicable-methods-emf (generic-function)  
-  (if (eq *boot-state* 'complete)
-      (let* ((cam (gdefinition 'compute-applicable-methods))
-	     (cam-methods (compute-applicable-methods-using-types
-			   cam (list `(eql ,generic-function) t))))
-	(values (get-effective-method-function cam cam-methods)
-		(list-eq cam-methods 
-			 (or *std-cam-methods*
-			     (setq *std-cam-methods*
-				   (compute-applicable-methods-using-types
-				    cam (list `(eql ,cam) t)))))))
-      (values #'compute-applicable-methods-function t)))
-
-(defun compute-applicable-methods-emf-std-p (gf)
-  (gf-info-c-a-m-emf-std-p (gf-arg-info gf)))
-
-(defvar *old-c-a-m-gf-methods* nil)
-
-(defun update-all-c-a-m-gf-info (c-a-m-gf)
-  (let ((methods (generic-function-methods c-a-m-gf)))
-    (if (and *old-c-a-m-gf-methods*
-	     (every #'(lambda (old-method)
-			(member old-method methods))
-		    *old-c-a-m-gf-methods*))
-	(let ((gfs-to-do nil)
-	      (gf-classes-to-do nil))
-	  (dolist (method methods)
-	    (unless (member method *old-c-a-m-gf-methods*)
-	      (let ((specl (car (method-specializers method))))
-		(if (eql-specializer-p specl)
-		    (pushnew (specializer-object specl) gfs-to-do)
-		    (pushnew (specializer-class specl) gf-classes-to-do)))))
-	  (map-all-generic-functions 
-	   #'(lambda (gf)
-	       (when (or (member gf gfs-to-do)
-			 (dolist (class gf-classes-to-do nil)
-			   (member class (class-precedence-list (class-of gf)))))
-		 (update-c-a-m-gf-info gf)))))
-	(map-all-generic-functions #'update-c-a-m-gf-info))
-    (setq *old-c-a-m-gf-methods* methods)))
-
-(defun update-gf-info (gf)
-  (update-c-a-m-gf-info gf)
-  (update-gf-simple-accessor-type gf))
-
-(defun update-c-a-m-gf-info (gf)
-  (unless (early-gf-p gf)
-    (multiple-value-bind (c-a-m-emf std-p)
-	(compute-applicable-methods-emf gf)
-      (let ((arg-info (gf-arg-info gf)))
-	(setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
-	(setf (gf-info-c-a-m-emf-std-p arg-info) std-p)))))
-
-(defun update-gf-simple-accessor-type (gf)
-  (let ((arg-info (gf-arg-info gf)))
-    (setf (gf-info-simple-accessor-type arg-info)
-	  (let* ((methods (generic-function-methods gf))
-		 (class (and methods (class-of (car methods))))
-		 (type (and class (cond ((eq class *the-class-standard-reader-method*)
-					 'reader)
-					((eq class *the-class-standard-writer-method*)
-					 'writer)
-					((eq class *the-class-standard-boundp-method*)
-					 'boundp)))))
-	    (when (and (gf-info-c-a-m-emf-std-p arg-info)
-		       type
-		       (dolist (method (cdr methods) t)
-			 (unless (eq class (class-of method)) (return nil)))
-		       (eq (generic-function-method-combination gf)
-			   *standard-method-combination*))
-	      type)))))
-
-(defun get-accessor-method-function (gf type class slotd)  
-  (let* ((std-method (standard-svuc-method type))
-	 (str-method (structure-svuc-method type))
-	 (types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
-	 (types (if (eq type 'writer) `(t ,@types1) types1))
-	 (methods (compute-applicable-methods-using-types gf types))
-	 (std-p (null (cdr methods))))
-    (values
-     (if std-p
-	 (get-optimized-std-accessor-method-function class slotd type)
-	 (get-accessor-from-svuc-method-function
-	  class slotd
-	  (get-secondary-dispatch-function 
-	   gf methods types
-	   `((,(car (or (member std-method methods)
-			(member str-method methods)
-			(error "error in get-accessor-method-function")))
-	      ,(get-optimized-std-slot-value-using-class-method-function
-		class slotd type)))
-	   (unless (and (eq type 'writer)
-			(dolist (method methods t)
-			  (unless (eq (car (method-specializers method))
-				      *the-class-t*)
-			    (return nil))))
-	     (let ((wrappers (list (wrapper-of class)
-				   (class-wrapper class)
-				   (wrapper-of slotd))))
-	       (if (eq type 'writer)
-		   (cons (class-wrapper *the-class-t*) wrappers)
-		   wrappers))))
-	  type))
-     std-p)))
-
-;used by optimize-slot-value-by-class-p (vector.lisp)
-(defun update-slot-value-gf-info (gf type)
-  (unless *new-class*
-    (update-std-or-str-methods gf type))
-  (when (and (standard-svuc-method type) (structure-svuc-method type))
-    (flet ((update-class (class)
-	     (when (class-finalized-p class)
-	       (dolist (slotd (class-slots class))
-		 (compute-slot-accessor-info slotd type gf)))))
-      (if *new-class*
-	  (update-class *new-class*)
-	  (map-all-classes #'update-class 'slot-object)))))
-
-(defvar *standard-slot-value-using-class-method* nil)
-(defvar *standard-setf-slot-value-using-class-method* nil)
-(defvar *standard-slot-boundp-using-class-method* nil)
-(defvar *structure-slot-value-using-class-method* nil)
-(defvar *structure-setf-slot-value-using-class-method* nil)
-(defvar *structure-slot-boundp-using-class-method* nil)
-
-(defun standard-svuc-method (type)
-  (case type
-    (reader *standard-slot-value-using-class-method*)
-    (writer *standard-setf-slot-value-using-class-method*)
-    (boundp *standard-slot-boundp-using-class-method*)))
-
-(defun set-standard-svuc-method (type method)
-  (case type
-    (reader (setq *standard-slot-value-using-class-method* method))
-    (writer (setq *standard-setf-slot-value-using-class-method* method))
-    (boundp (setq *standard-slot-boundp-using-class-method* method))))
-
-(defun structure-svuc-method (type)
-  (case type
-    (reader *structure-slot-value-using-class-method*)
-    (writer *structure-setf-slot-value-using-class-method*)
-    (boundp *structure-slot-boundp-using-class-method*)))
-
-(defun set-structure-svuc-method (type method)
-  (case type
-    (reader (setq *structure-slot-value-using-class-method* method))
-    (writer (setq *structure-setf-slot-value-using-class-method* method))
-    (boundp (setq *structure-slot-boundp-using-class-method* method))))
-
-(defun update-std-or-str-methods (gf type)
-  (dolist (method (generic-function-methods gf))
-    (let ((specls (method-specializers method)))
-      (when (and (or (not (eq type 'writer))
-		     (eq (pop specls) *the-class-t*))
-		 (every #'classp specls))
-	(cond ((and (eq (class-name (car specls))
-			'std-class)
-		    (eq (class-name (cadr specls)) 
-			'standard-object)
-		    (eq (class-name (caddr specls)) 
-			'standard-effective-slot-definition))
-	       (set-standard-svuc-method type method))
-	      ((and (eq (class-name (car specls))
-			'structure-class)
-		    (eq (class-name (cadr specls))
-			'structure-object)
-		    (eq (class-name (caddr specls)) 
-			'structure-effective-slot-definition))
-	       (set-structure-svuc-method type method)))))))
-
-(defun mec-all-classes-internal (spec precompute-p)
-  (cons (specializer-class spec)
-	(and (classp spec)
-	     precompute-p
-	     (not (or (eq spec *the-class-t*)
-		      (eq spec *the-class-slot-object*)
-		      (eq spec *the-class-standard-object*)
-		      (eq spec *the-class-structure-object*)))
-	     (let ((sc (class-direct-subclasses spec)))
-	       (when sc
-		 (mapcan #'(lambda (class)
-			     (mec-all-classes-internal class precompute-p))
-			 sc))))))
-
-(defun mec-all-classes (spec precompute-p)
-  (let ((classes (mec-all-classes-internal spec precompute-p)))
-    (if (null (cdr classes))
-	classes
-	(let* ((a-classes (cons nil classes))
-	       (tail classes))
-	  (loop (when (null (cdr tail))
-		  (return (cdr a-classes)))
-		(let ((class (cadr tail))
-		      (ttail (cddr tail)))
-		  (if (dolist (c ttail nil)
-			(when (eq class c) (return t)))
-		      (setf (cdr tail) (cddr tail))
-		      (setf tail (cdr tail)))))))))
-
-(defun mec-all-class-lists (spec-list precompute-p)
-  (if (null spec-list)
-      (list nil)
-      (let* ((car-all-classes (mec-all-classes (car spec-list) precompute-p))
-	     (all-class-lists (mec-all-class-lists (cdr spec-list) precompute-p)))
-	(mapcan #'(lambda (list)
-		    (mapcar #'(lambda (c) (cons c list)) car-all-classes))
-		all-class-lists))))
-
-(defun make-emf-cache (generic-function valuep cache classes-list new-class)
-  (let* ((arg-info (gf-arg-info generic-function))
-	 (nkeys (arg-info-nkeys arg-info))
-	 (metatypes (arg-info-metatypes arg-info))
-	 (wrappers (unless (eq nkeys 1) (make-list nkeys)))
-	 (precompute-p (gf-precompute-dfun-and-emf-p arg-info))
-	 (default '(default)))
-    (flet ((add-class-list (classes)
-	     (when (or (null new-class) (memq new-class classes))
-	       (let ((wrappers (get-wrappers-from-classes 
-				nkeys wrappers classes metatypes)))
-		 (when (and wrappers
-			    (eq default (probe-cache cache wrappers default)))
-		   (let ((value (cond ((eq valuep t)
-				       (sdfun-for-caching generic-function classes))
-				      ((eq valuep :constant-value)
-				       (value-for-caching generic-function classes)))))
-		     (setq cache (fill-cache cache wrappers value t))))))))
-      (if classes-list
-	  (mapc #'add-class-list classes-list)
-	  (dolist (method (generic-function-methods generic-function))
-	    (mapc #'add-class-list
-		  (mec-all-class-lists (method-specializers method) precompute-p))))
-      cache)))
-
-(defmacro class-test (arg class)
-  (cond ((eq class *the-class-t*)
-	 't)
-	((eq class *the-class-slot-object*)
-	 #+new-kcl-wrapper
-	 `(or (std-instance-p ,arg)
-	      (fsc-instance-p ,arg))
-	 #-new-kcl-wrapper
-	 `(not (eq *the-class-built-in-class* 
-		   (wrapper-class (std-instance-wrapper (class-of ,arg))))))
-	#-new-kcl-wrapper
-	((eq class *the-class-standard-object*)
-	 `(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
-	((eq class *the-class-structure-object*)
-	 `(memq ',class (class-precedence-list (class-of ,arg))))
-	;; TYPEP is now sometimes faster than doing memq of the cpl
-	(t
-	 `(typep ,arg ',(class-name class)))))
-
-(defmacro class-eq-test (arg class)
-  `(eq (class-of ,arg) ',class))
-
-(defmacro eql-test (arg object)
-  `(eql ,arg ',object))
-
-(defun dnet-methods-p (form)
-  (and (consp form)
-       (or (eq (car form) 'methods)
-	   (eq (car form) 'unordered-methods))))
-
-(defmacro scase (arg &rest clauses) ; This is case, but without gensyms
-  `(let ((.case-arg. ,arg))
-     (cond ,@(mapcar #'(lambda (clause)
-			 (list* (cond ((null (car clause))
-				       nil)
-				      ((consp (car clause))
-				       (if (null (cdar clause))
-					   `(eql .case-arg. ',(caar clause))
-					   `(member .case-arg. ',(car clause))))
-				      ((member (car clause) '(t otherwise))
-				       `t)
-				      (t
-				       `(eql .case-arg. ',(car clause))))
-				nil
-				(cdr clause)))
-		     clauses))))
-
-(defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses))
-
-(defun generate-discrimination-net (generic-function methods types sorted-p)
-  (let* ((arg-info (gf-arg-info generic-function))
-	 (precedence (arg-info-precedence arg-info)))
-    (generate-discrimination-net-internal 
-     generic-function methods types
-     #'(lambda (methods known-types)
-	 (if (or sorted-p
-		 (block one-order-p
-		   (let ((sorted-methods nil))
-		     (map-all-orders 
-		      (copy-list methods) precedence
-		      #'(lambda (methods)
-			  (when sorted-methods (return-from one-order-p nil))
-			  (setq sorted-methods methods)))
-		     (setq methods sorted-methods))
-		   t))
-	     `(methods ,methods ,known-types)
-	     `(unordered-methods ,methods ,known-types)))
-     #'(lambda (position type true-value false-value)
-	 (let ((arg (dfun-arg-symbol position)))
-	   (if (eq (car type) 'eql)
-	       (let* ((false-case-p (and (consp false-value)
-					 (or (eq (car false-value) 'scase)
-					     (eq (car false-value) 'mcase))
-					 (eq arg (cadr false-value))))
-		      (false-clauses (if false-case-p
-					 (cddr false-value)
-					 `((t ,false-value))))
-		      (case-sym (if (and (dnet-methods-p true-value)
-					 (if false-case-p
-					     (eq (car false-value) 'mcase)
-					     (dnet-methods-p false-value)))
-				    'mcase
-				    'scase))
-		      (type-sym `(,(cadr type))))
-		 `(,case-sym ,arg
-		    (,type-sym ,true-value)
-		    ,@false-clauses))
-	       `(if ,(let ((arg (dfun-arg-symbol position)))
-		       (case (car type)
-			 (class    `(class-test    ,arg ,(cadr type)))
-			 (class-eq `(class-eq-test ,arg ,(cadr type)))))
-		    ,true-value
-		    ,false-value))))
-     #'identity)))
-
-(defun class-from-type (type)
-  (if (or (atom type) (eq (car type) 't))
-      *the-class-t*
-      (case (car type)
-	(and (dolist (type (cdr type) *the-class-t*)
-	       (when (and (consp type) (not (eq (car type) 'not)))
-		 (return (class-from-type type)))))
-	(not *the-class-t*)
-        (eql (class-of (cadr type)))
-        (class-eq (cadr type))
-        (class (cadr type)))))
-
-(defun precompute-effective-methods (gf caching-p &optional classes-list-p)
-  (let* ((arg-info (gf-arg-info gf))
-	 (methods (generic-function-methods gf))
-	 (precedence (arg-info-precedence arg-info))
-	 (*in-precompute-effective-methods-p* t)
-	 (classes-list nil))
-    (generate-discrimination-net-internal 
-     gf methods nil
-     #'(lambda (methods known-types)
-	 (when methods
-	   (when classes-list-p
-	     (push (mapcar #'class-from-type known-types) classes-list))
-	   (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p methods))))
-	     (map-all-orders 
-	      methods precedence
-	      #'(lambda (methods)
-		  (get-secondary-dispatch-function1 
-		   gf methods known-types
-		   nil caching-p no-eql-specls-p))))))
-     #'(lambda (position type true-value false-value)
-	 (declare (ignore position type true-value false-value))
-	 nil)
-     #'(lambda (type)
-	 (if (and (consp type) (eq (car type) 'eql))
-	     `(class-eq ,(class-of (cadr type)))
-	     type)))
-    classes-list))
-
-; we know that known-type implies neither new-type nor `(not ,new-type) 
-(defun augment-type (new-type known-type)
-  (if (or (eq known-type 't)
-	  (eq (car new-type) 'eql))
-      new-type
-      (let ((so-far (if (and (consp known-type) (eq (car known-type) 'and))
-			(cdr known-type)
-			(list known-type))))
-	(unless (eq (car new-type) 'not)
-	  (setq so-far
-		(mapcan #'(lambda (type)
-			    (unless (*subtypep new-type type)
-			      (list type)))
-			so-far)))
-	(if (null so-far)
-	    new-type
-	    `(and ,new-type ,@so-far)))))
-
-#+lcl3.0 (dont-use-production-compiler)
-
-(defun generate-discrimination-net-internal 
-    (gf methods types methods-function test-function type-function)
-  (let* ((arg-info (gf-arg-info gf))
-	 (precedence (arg-info-precedence arg-info))
-	 (nreq (arg-info-number-required arg-info))
-	 (metatypes (arg-info-metatypes arg-info)))
-    (labels ((do-column (p-tail contenders known-types)
-	       (if p-tail
-		   (let* ((position (car p-tail))
-			  (known-type (or (nth position types) t)))
-		     (if (eq (nth position metatypes) 't)
-			 (do-column (cdr p-tail) contenders
-				    (cons (cons position known-type) known-types))
-			 (do-methods p-tail contenders 
-				     known-type () known-types)))
-		   (funcall methods-function contenders 
-			    (let ((k-t (make-list nreq)))
-			      (dolist (index+type known-types)
-				(setf (nth (car index+type) k-t) (cdr index+type)))
-			      k-t))))
-	     (do-methods (p-tail contenders known-type winners known-types)
-	       ;;
-               ;; <contenders>
-	       ;;   is a (sorted) list of methods that must be discriminated
-               ;; <known-type>
-	       ;;   is the type of this argument, constructed from tests already made.
-               ;; <winners>
-	       ;;   is a (sorted) list of methods that are potentially applicable
-	       ;;   after the discrimination has been made.
-	       ;;   
-               (if (null contenders)
-		   (do-column (cdr p-tail) winners
-			      (cons (cons (car p-tail) known-type) known-types))
-                   (let* ((position (car p-tail))
-			  (method (car contenders))
-			  (specl (nth position (method-specializers method)))
-                          (type (funcall type-function (type-from-specializer specl))))
-		     (multiple-value-bind (app-p maybe-app-p)
-			 (specializer-applicable-using-type-p type known-type)
-		       (flet ((determined-to-be (truth-value)
-				(if truth-value app-p (not maybe-app-p)))
-			      (do-if (truth &optional implied)
-				(let ((ntype (if truth type `(not ,type))))
-				  (do-methods p-tail
-				    (cdr contenders)
-				    (if implied
-					known-type
-					(augment-type ntype known-type))
-				    (if truth
-					(append winners `(,method))
-					winners)
-				    known-types))))
-			 (cond ((determined-to-be nil) (do-if nil t))
-			       ((determined-to-be t)   (do-if t   t))
-			       (t (funcall test-function position type 
-					   (do-if t) (do-if nil))))))))))
-      (do-column precedence methods ()))))
-
-#+lcl3.0 (use-previous-compiler)
-
-(defun compute-secondary-dispatch-function (generic-function net &optional 
-					    method-alist wrappers)
-  (function-funcall (compute-secondary-dispatch-function1 generic-function net)
-		    method-alist wrappers))
-
-(defvar *eq-case-table-limit* 15)
-(defvar *case-table-limit* 10)
-
-(defun compute-mcase-parameters (case-list)
-  (unless (eq 't (caar (last case-list)))
-    (error "The key for the last case arg to mcase was not T"))
-  (let* ((eq-p (dolist (case case-list t)
-		 (unless (or (eq (car case) 't)
-			     (symbolp (caar case)))
-		   (return nil))))
-	 (len (1- (length case-list)))
-	 (type (cond ((= len 1)
-		      :simple)
-		     ((<= len
-			  (if eq-p
-			      *eq-case-table-limit*
-			      *case-table-limit*))
-		      :assoc)
-		     (t
-		      :hash-table))))
-    (list eq-p type)))
-
-(defmacro mlookup (key info default &optional eq-p type)
-  (unless (or (eq eq-p 't) (null eq-p))
-    (error "Invalid eq-p argument"))
-  (ecase type
-    (:simple
-     `(if (,(if eq-p 'eq 'eql) ,key (car ,info))
-          (cdr ,info)
-          ,default))
-    (:assoc
-     `(dolist (e ,info ,default)
-        (when (,(if eq-p 'eq 'eql) (car e) ,key)
-	  (return (cdr e)))))
-    (:hash-table
-     `(gethash ,key ,info ,default))))
-
-(defun net-test-converter (form)
-  (if (atom form)
-      (default-test-converter form)
-      (case (car form)
-	((invoke-effective-method-function invoke-fast-method-call)
-	 '.call.)
-	(methods
-	 '.methods.)
-	(unordered-methods
-	 '.umethods.)
-	(mcase
-	 `(mlookup ,(cadr form) nil nil ,@(compute-mcase-parameters (cddr form))))
-	(t (default-test-converter form)))))
-
-(defun net-code-converter (form)
-  (if (atom form)
-      (default-code-converter form)
-      (case (car form)
-	((methods unordered-methods)
-	 (let ((gensym (gensym)))
-	   (values gensym
-		   (list gensym))))
-	(mcase
-	 (let ((mp (compute-mcase-parameters (cddr form)))
-	       (gensym (gensym)) (default (gensym)))
-	   (values `(mlookup ,(cadr form) ,gensym ,default ,@mp)
-		   (list gensym default))))
-	(t
-	 (default-code-converter form)))))
-
-(defun net-constant-converter (form generic-function)
-  (or (let ((c (methods-converter form generic-function)))
-	(when c (list c)))
-      (if (atom form)
-	  (default-constant-converter form)
-	  (case (car form)
-	    (mcase
-	     (let* ((mp (compute-mcase-parameters (cddr form)))
-		    (list (mapcar #'(lambda (clause)
-				      (let ((key (car clause))
-					    (meth (cadr clause)))
-					(cons (if (consp key) (car key) key)
-					      (methods-converter
-					       meth generic-function))))
-				  (cddr form)))
-		    (default (car (last list))))
-	       (list (list* ':mcase mp (nbutlast list))
-		     (cdr default))))
-	    (t
-	     (default-constant-converter form))))))
-
-(defun methods-converter (form generic-function)
-  (cond ((and (consp form) (eq (car form) 'methods))
-	 (cons '.methods.
-	       (get-effective-method-function1 generic-function (cadr form))))
-	((and (consp form) (eq (car form) 'unordered-methods))
-	 (default-secondary-dispatch-function generic-function))))
-
-(defun convert-methods (constant method-alist wrappers)
-  (if (and (consp constant)
-	   (eq (car constant) '.methods.))
-      (funcall (cdr constant) method-alist wrappers)
-      constant))
-
-(defun convert-table (constant method-alist wrappers)
-  (cond ((and (consp constant)
-	      (eq (car constant) ':mcase))
-	 (let ((alist (mapcar #'(lambda (k+m)
-				  (cons (car k+m)
-					(convert-methods (cdr k+m)
-							 method-alist wrappers)))
-			      (cddr constant)))
-	       (mp (cadr constant)))
-	   (ecase (cadr mp)
-	     (:simple
-	      (car alist))
-	     (:assoc
-	      alist)
-	     (:hash-table
-	      (let ((table (make-hash-table :test (if (car mp) 'eq 'eql))))
-		(dolist (k+m alist)
-		  (setf (gethash (car k+m) table) (cdr k+m)))
-		table)))))))
-
-(defun compute-secondary-dispatch-function1 (generic-function net
-					     &optional function-p)
-  (if (eq (car net) 'methods)
-      (get-effective-method-function1 generic-function (cadr net))
-      (let* ((name (generic-function-name generic-function))
-	     (arg-info (gf-arg-info generic-function))
-	     (metatypes (arg-info-metatypes arg-info))
-	     (applyp (arg-info-applyp arg-info))
-	     (fmc-arg-info (cons (length metatypes) applyp))
-	     (arglist (if function-p
-			  (make-dfun-lambda-list metatypes applyp)
-			  (make-fast-method-call-lambda-list metatypes applyp))))
-	(multiple-value-bind (cfunction constants)
-	    (get-function1 `(lambda ,arglist
-			      ,@(unless function-p
-				  `((declare (ignore .pv-cell.
-						     .next-method-call.))))
-			      #+copy-&rest-arg
-			      ,@(when (and applyp function-p)
-				  `((setq .dfun-rest-arg.
-					  (copy-list .dfun-rest-arg.))))
-			      (let ((emf ,net))
-			        ,(make-emf-call metatypes applyp 'emf)))
-			   #'net-test-converter
-			   #'net-code-converter
-			   #'(lambda (form)
-			       (net-constant-converter form generic-function)))
-	  #'(lambda (method-alist wrappers)
-	      (let* ((alist (list nil))
-		     (alist-tail alist))
-		(dolist (constant constants)
-		  (let* ((a (or (dolist (a alist nil)
-				  (when (eq (car a) constant)
-				    (return a)))
-				(cons constant
-				      (or (convert-table
-					   constant method-alist wrappers)
-					  (convert-methods
-					   constant method-alist wrappers)))))
-			 (new (list a)))
-		    (setf (cdr alist-tail) new)
-		    (setf alist-tail new)))
-		(let ((function (apply cfunction (mapcar #'cdr (cdr alist)))))
-		  (if function-p
-		      function
-		      (make-fast-method-call
-		       :function (set-function-name function `(sdfun-method ,name))
-		       :arg-info fmc-arg-info)))))))))
-
-(defvar *show-make-unordered-methods-emf-calls* nil)
-
-(defun make-unordered-methods-emf (generic-function methods)
-  (when *show-make-unordered-methods-emf-calls*
-    (format t "~&make-unordered-methods-emf ~s~%" 
-	    (generic-function-name generic-function)))
-  #'(lambda (&rest args)
-      #+copy-&rest-arg (setq args (copy-list args))
-      (let* ((types (types-from-arguments generic-function args 'eql))
-	     (smethods (sort-applicable-methods generic-function methods types))
-	     (emf (get-effective-method-function generic-function smethods)))
-	(invoke-emf emf args))))
-
-
-;;;
-;;; The value returned by compute-discriminating-function is a function
-;;; object.  It is called a discriminating function because it is called
-;;; when the generic function is called and its role is to discriminate
-;;; on the arguments to the generic function and then call appropriate
-;;; method functions.
-;;; 
-;;; A discriminating function can only be called when it is installed as
-;;; the funcallable instance function of the generic function for which
-;;; it was computed.
-;;;
-;;; More precisely, if compute-discriminating-function is called with an
-;;; argument <gf1>, and returns a result <df1>, that result must not be
-;;; passed to apply or funcall directly.  Rather, <df1> must be stored as
-;;; the funcallable instance function of the same generic function <gf1>
-;;; (using set-funcallable-instance-function).  Then the generic function
-;;; can be passed to funcall or apply.
-;;;
-;;; An important exception is that methods on this generic function are
-;;; permitted to return a function which itself ends up calling the value
-;;; returned by a more specific method.  This kind of `encapsulation' of
-;;; discriminating function is critical to many uses of the MOP.
-;;; 
-;;; As an example, the following canonical case is legal:
-;;;
-;;;   (defmethod compute-discriminating-function ((gf my-generic-function))
-;;;     (let ((std (call-next-method)))
-;;;       #'(lambda (arg)
-;;;            (print (list 'call-to-gf gf arg))
-;;;            (funcall std arg))))
-;;;
-;;; Because many discriminating functions would like to use a dynamic
-;;; strategy in which the precise discriminating function changes with
-;;; time it is important to specify how a discriminating function is
-;;; permitted itself to change the funcallable instance function of the
-;;; generic function.
-;;;
-;;; Discriminating functions may set the funcallable instance function
-;;; of the generic function, but the new value must be generated by making
-;;; a call to COMPUTE-DISCRIMINATING-FUNCTION.  This is to ensure that any
-;;; more specific methods which may have encapsulated the discriminating
-;;; function will get a chance to encapsulate the new, inner discriminating
-;;; function.
-;;;
-;;; This implies that if a discriminating function wants to modify itself
-;;; it should first store some information in the generic function proper,
-;;; and then call compute-discriminating-function.  The appropriate method
-;;; on compute-discriminating-function will see the information stored in
-;;; the generic function and generate a discriminating function accordingly.
-;;;
-;;; The following is an example of a discriminating function which modifies
-;;; itself in accordance with this protocol:
-;;;
-;;;   (defmethod compute-discriminating-function ((gf my-generic-function))
-;;;     #'(lambda (arg)
-;;;         (cond (<some condition>
-;;;                <store some info in the generic function>
-;;;                (set-funcallable-instance-function
-;;;                  gf
-;;;                  (compute-discriminating-function gf))
-;;;                (funcall gf arg))
-;;;               (t
-;;;                <call-a-method-of-gf>))))
-;;;
-;;; Whereas this code would not be legal:
-;;;
-;;;   (defmethod compute-discriminating-function ((gf my-generic-function))
-;;;     #'(lambda (arg)
-;;;         (cond (<some condition>
-;;;                (set-funcallable-instance-function
-;;;                  gf
-;;;                  #'(lambda (a) ..))
-;;;                (funcall gf arg))
-;;;               (t
-;;;                <call-a-method-of-gf>))))
-;;;
-;;; NOTE:  All the examples above assume that all instances of the class
-;;;        my-generic-function accept only one argument.
-;;;
-;;;
-;;;
-;;;
-(defun slot-value-using-class-dfun (class object slotd)
-  (declare (ignore class))
-  (function-funcall (slot-definition-reader-function slotd) object))
-
-(defun setf-slot-value-using-class-dfun (new-value class object slotd)
-  (declare (ignore class))
-  (function-funcall (slot-definition-writer-function slotd) new-value object))
-
-(defun slot-boundp-using-class-dfun (class object slotd)
-  (declare (ignore class))
-  (function-funcall (slot-definition-boundp-function slotd) object))
-
-(defmethod compute-discriminating-function ((gf standard-generic-function))
-  (with-slots (dfun-state arg-info) gf
-    (typecase dfun-state
-      (null (let ((name (generic-function-name gf)))
-	      (when (eq name 'compute-applicable-methods)
-		(update-all-c-a-m-gf-info gf))
-	      (cond ((eq name 'slot-value-using-class)
-		     (update-slot-value-gf-info gf 'reader)
-		     #'slot-value-using-class-dfun)
-		    ((equal name '(setf slot-value-using-class))
-		     (update-slot-value-gf-info gf 'writer)
-		     #'setf-slot-value-using-class-dfun)
-		    ((eq name 'slot-boundp-using-class)
-		     (update-slot-value-gf-info gf 'boundp)
-		     #'slot-boundp-using-class-dfun)
-		    ((gf-precompute-dfun-and-emf-p arg-info)
-		     (make-final-dfun gf))
-		    (t
-		     (make-initial-dfun gf)))))
-      (function dfun-state)
-      (cons (car dfun-state)))))
-
-(defmethod update-gf-dfun ((class std-class) gf)
-  (let ((*new-class* class)
-	#|| (name (generic-function-name gf)) ||#
-	(arg-info (gf-arg-info gf)))
-    (cond #||
-	  ((eq name 'slot-value-using-class)
-	   (update-slot-value-gf-info gf 'reader))
-	  ((equal name '(setf slot-value-using-class))
-	   (update-slot-value-gf-info gf 'writer))
-	  ((eq name 'slot-boundp-using-class)
-	   (update-slot-value-gf-info gf 'boundp))
-	  ||#
-	  ((gf-precompute-dfun-and-emf-p arg-info)
-	   (multiple-value-bind (dfun cache info)
-	       (make-final-dfun-internal gf)
-	     (set-dfun gf dfun cache info) ; otherwise cache might get freed twice
-	     (update-dfun gf dfun cache info))))))
-
-;;;
-;;;
-;;;
-(defmethod function-keywords ((method standard-method))
-  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
-      (analyze-lambda-list (if (consp method)
-			       (early-method-lambda-list method)
-			       (method-lambda-list method)))
-    (declare (ignore nreq nopt keysp restp))
-    (values keywords allow-other-keys-p)))
-
-(defun method-ll->generic-function-ll (ll)
-  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters)
-      (analyze-lambda-list ll)
-    (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords))
-    (remove-if #'(lambda (s)
-		   (or (memq s keyword-parameters)
-		       (eq s '&allow-other-keys)))
-	       ll)))
-
-
-;;;
-;;; This is based on the rules of method lambda list congruency defined in
-;;; the spec.  The lambda list it constructs is the pretty union of the
-;;; lambda lists of all the methods.  It doesn't take method applicability
-;;; into account at all yet.
-;;; 
-(defmethod generic-function-pretty-arglist
-	   ((generic-function standard-generic-function))
-  (let ((methods (generic-function-methods generic-function))
-	(arglist ()))      
-    (when methods
-      (multiple-value-bind (required optional rest key allow-other-keys)
-	  (method-pretty-arglist (car methods))
-	(dolist (m (cdr methods))
-	  (multiple-value-bind (method-key-keywords
-				method-allow-other-keys
-				method-key)
-	      (function-keywords m)
-	    ;; we've modified function-keywords to return what we want as
-	    ;;  the third value, no other change here.
-	    (declare (ignore method-key-keywords))
-	    (setq key (union key method-key))
-	    (setq allow-other-keys (or allow-other-keys
-				       method-allow-other-keys))))
-	(when allow-other-keys
-	  (setq arglist '(&allow-other-keys)))
-	(when key
-	  (setq arglist (nconc (list '&key) key arglist)))
-	(when rest
-	  (setq arglist (nconc (list '&rest rest) arglist)))
-	(when optional
-	  (setq arglist (nconc (list '&optional) optional arglist)))
-	(nconc required arglist)))))
-  
-
-(defmethod method-pretty-arglist ((method standard-method))
-  (let ((required ())
-	(optional ())
-	(rest nil)
-	(key ())
-	(allow-other-keys nil)
-	(state 'required)
-	(arglist (method-lambda-list method)))
-    (dolist (arg arglist)
-      (cond ((eq arg '&optional)         (setq state 'optional))
-	    ((eq arg '&rest)             (setq state 'rest))
-	    ((eq arg '&key)              (setq state 'key))
-	    ((eq arg '&allow-other-keys) (setq allow-other-keys 't))
-	    ((memq arg lambda-list-keywords))
-	    (t
-	     (ecase state
-	       (required (push arg required))
-	       (optional (push arg optional))
-	       (key      (push arg key))
-	       (rest     (setq rest arg))))))
-    (values (nreverse required)
-	    (nreverse optional)
-	    rest
-	    (nreverse key)
-	    allow-other-keys)))
-
diff --git a/pcl/misc-kcl-patches.text b/pcl/misc-kcl-patches.text
deleted file mode 100644
index 54bb9c71848d07ad30cb468e45d384ee53d6f7ec..0000000000000000000000000000000000000000
--- a/pcl/misc-kcl-patches.text
+++ /dev/null
@@ -1,340 +0,0 @@
-c/cmpaux.c
-*** c/cmpaux.c    Mon Jul  6 00:14:55 1992
---- ../akcl-1-615/c/cmpaux.c      Thu Jun 18 20:01:07 1992
-***************
-*** 229,239 ****
-      if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0)
-      return x->st.st_self;
-    if (x->st.st_dim == leng
-        && ( leng % sizeof(object))
-       )
-!     { x->st.st_self[leng] = 0;
-        return x->st.st_self;
-      }
-    else
-      {char *res=malloc(leng+1);
-       bcopy(x->st.st_self,res,leng);
---- 229,240 ----
-      if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0)
-      return x->st.st_self;
-    if (x->st.st_dim == leng
-        && ( leng % sizeof(object))
-       )
-!     { if(x->st.st_self[leng] != 0)
-!          x->st.st_self[leng] = 0;
-        return x->st.st_self;
-      }
-    else
-      {char *res=malloc(leng+1);
-       bcopy(x->st.st_self,res,leng);
-c/main.c
-*** c/main.c      Mon Jul  6 00:14:59 1992
---- ../akcl-1-615/c/main.c        Fri Jul  3 02:19:37 1992
-***************
-*** 611,621 ****
-            {catch_fatal = -1;
-             if (sgc_enabled)
-               { sgc_quit();}
-             if (sgc_enabled==0)
-               { install_segmentation_catcher() ;}
-!            FEerror("Caught fatal error [memory may be damaged]"); }
-          printf("\nUnrecoverable error: %s.\n", s);
-          fflush(stdout);
-  #ifdef UNIX
-          abort();
-  #endif
---- 611,621 ----
-            {catch_fatal = -1;
-             if (sgc_enabled)
-               { sgc_quit();}
-             if (sgc_enabled==0)
-               { install_segmentation_catcher() ;}
-!            FEerror("Caught fatal error [memory may be damaged] ~A",1,make_simple_string(s)); }
-          printf("\nUnrecoverable error: %s.\n", s);
-          fflush(stdout);
-  #ifdef UNIX
-          abort();
-  #endif
-***************
-*** 853,872 ****
-  
-  siLsave_system()
-  {
-          int i;
-  
-- #ifdef HAVE_YP_UNBIND
--         extern object truename(),namestring();
-          check_arg(1);
-!         /* prevent subsequent consultation of yp by getting
-!            truename now*/
-!         vs_base[0]=namestring(truename(vs_base[0]));
-!         {char name[200];
-!          char *dom = name;
-!          if (0== getdomainname(dom,sizeof(name)))
-!            yp_unbind(dom);}
-  #endif
-          
-          saving_system = TRUE;
-          GBC(t_contiguous);
-  
---- 853,867 ----
-  
-  siLsave_system()
-  {
-          int i;
-  
-          check_arg(1);
-! #ifdef HAVE_YP_UNBIND
-!         /* see unixsave.c */
-!         {char *dname;
-!          yp_get_default_domain(&dname);}
-  #endif
-          
-          saving_system = TRUE;
-          GBC(t_contiguous);
-  
-c/num_log.c
-*** c/num_log.c   Mon Jul  6 00:15:00 1992
---- ../akcl-1-615/c/num_log.c     Mon Jun 15 21:15:59 1992
-***************
-*** 266,286 ****
-          return(~j);
-  }
-  
-  int
-  big_bitp(x, p)
-! object  x;
-! int     p;
-  { GEN u = MP(x);
-    int ans ;
-    int i = p /32;
-    if (signe(u) < 0)
-      {  save_avma;
-         u = complementi(u);
-         restore_avma;
-     }
-!   if (i < lgef(u))
-      { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));}
-    else if (big_sign(x) < 0) ans = 1;
-    else ans = 0;
-    return ans;
-  }
---- 266,286 ----
-          return(~j);
-  }
-  
-  int
-  big_bitp(x, p)
-! object  x;
-! int     p;
-  { GEN u = MP(x);
-    int ans ;
-    int i = p /32;
-    if (signe(u) < 0)
-      {  save_avma;
-         u = complementi(u);
-         restore_avma;
-     }
-!   if (i < lgef(u) -MP_CODE_WORDS)
-      { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));}
-    else if (big_sign(x) < 0) ans = 1;
-    else ans = 0;
-    return ans;
-  }
-c/unixsave.c
-*** c/unixsave.c  Mon Jul  6 00:15:07 1992
---- ../akcl-1-615/c/unixsave.c    Fri Jul  3 02:52:36 1992
-***************
-*** 71,81 ****
---- 71,160 ----
-                          break;
-                  } else
-                          break;
-  }
-  
-+ #include "page.h"
-  
-+ /* string is aligned on a word boundary */
-+ int
-+ find_string_in_memory(string,length,other_p,function)
-+      char *string;
-+      int length,other_p;
-+      int *function();
-+ {
-+   int *imem_first,*imem_last,*imem,word;
-+   char *mem;
-+   int len,page_first,page_last,i;
-+   int maxpage = page(heap_end);
-+   if(((int)string & 3) == 0 && length >= 4) /* just to be safe */
-+     {word=*(int *)string;
-+      for (page_first = 0;  page_first < maxpage;  page_first++)
-+        if ((enum type)type_map[page_first] != t_other)
-+          break;
-+      for (;  page_first < maxpage;  page_first++)
-+        if (((enum type)type_map[page_first] == t_other)?other_p:!other_p)
-+          {for (page_last = page_first+1;  page_last < maxpage;  page_last++)
-+             if ( !(((enum type)type_map[page_last] == t_other)?other_p:!other_p) )
-+               break;
-+           imem_first=(int *)pagetochar(page_first);
-+           imem_last=(int *)( ( ((int)pagetochar(page_last)) - length) &~3 );
-+           for (imem = imem_first; imem <= imem_last; imem++)
-+             if (*imem == word)
-+               {mem=(char *)imem;
-+                for(i=4; i<length && mem[i]==string[i]; i++);
-+                if(i>=length)
-+                  if((*function)(mem))
-+                    return TRUE;}}}
-+   return FALSE;
-+ }
-+ 
-+ int 
-+ fsim_first(address)
-+      char *address;
-+ {
-+   return TRUE;
-+ }
-+ 
-+ int 
-+ fsim_reset_pointer(address)
-+      char **address;
-+ {
-+   *address = NULL;
-+   return FALSE;
-+ }
-+ 
-+ #define t_other_PAGES TRUE
-+ #define NOT_t_other_PAGES FALSE
-+ 
-+ int
-+ reset_other_pointers(address)
-+      char *address;
-+ {
-+   int word=(int)address;
-+   find_string_in_memory(&word,4,t_other_PAGES,fsim_reset_pointer);
-+ }
-+ 
-+ int
-+ maybe_reset_pointers(address)
-+      char *address;
-+ {
-+   int word=(int)address;
-+   if(!find_string_in_memory(&word,4,NOT_t_other_PAGES,fsim_first))
-+     reset_other_pointers(address);
-+   return FALSE;
-+ }
-+ 
-+ reset_other_pointers_to_string(string)
-+      char *string;
-+ {
-+   int length=strlen(string)+1;
-+   find_string_in_memory(string,length,t_other_PAGES,maybe_reset_pointers);
-+ }
-+ 
-+ bool saving_system;
-+ 
-  memory_save(original_file, save_file)
-  char *original_file, *save_file;
-  {       MEM_SAVE_LOCALS;
-          char *data_begin, *data_end;
-          int original_data;
-***************
-*** 100,110 ****
---- 179,206 ----
-          n = open(save_file, O_CREAT|O_WRONLY, 0777);
-          if (n != 1 || (save = fdopen(n, "w")) != stdout) {
-                  fprintf(stderr, "Can't open the save file.\n");
-                  exit(1);
-          }
-+ 
-          setbuf(save, stdout_buf);
-+ 
-+ #ifdef HAVE_YP_UNBIND
-+ /* yp_get_default_domain() caches the result of getdomainname() in
-+    a malloc'ed block of memory; and gethostbyname saves the result of
-+    yp_get_default_domain() in yet another chunk of memory.  These
-+    cached values will cause problems if the saved image is run on a
-+    machine having a different local domainname.  [When getdomainname 
-+    is called (by CLX, for example) KCL will wait forever.]  There doesn't
-+    seem to be any way to uncache these things (apparently yp_unbind does 
-+    not do this), nor any good way to find these blocks of memory.         */
-+    
-+         if(saving_system)
-+           {char *dname;
-+            yp_get_default_domain(&dname);
-+            reset_other_pointers(dname);}
-+ #endif
-  
-          READ_HEADER;
-          FILECPY_HEADER;
-  
-          for (n = header.a_data, p = data_begin;  ;  n -= BUFSIZ, p += BUFSIZ)
-cmpnew/cmpcall.lsp
-*** cmpnew/cmpcall.lsp    Mon Jul  6 00:15:13 1992
---- ../akcl-1-615/cmpnew/cmpcall.lsp      Thu Jun 18 21:43:24 1992
-***************
-*** 118,127 ****
---- 118,128 ----
-                          ;;; responsible for maintaining this condition.
-        (let ((*vs* *vs*) (form (caddr funob)))
-             (declare (object form))
-             (cond ((and (listp args)
-                         *use-sfuncall*
-+                        (<= (length (cdr args)) 10)
-                         ;;Determine if only one value at most is required:
-                         (or
-                          (eq *value-to-go* 'trash)
-                          (and (consp *value-to-go*)
-                               (eq (car *value-to-go*) 'var))
-lsp/autoload.lsp
-*** lsp/autoload.lsp      Mon Jul  6 00:15:27 1992
---- ../akcl-1-615/lsp/autoload.lsp        Tue Jun 16 02:36:45 1992
-***************
-*** 430,440 ****
-          '(cons
-            fixnum bignum ratio short-float long-float complex
-            character symbol package hash-table
-            array vector string bit-vector
-            structure stream random-state readtable pathname
-!           cfun cclosure sfun gfun cfdata spice fat-string ))
-  
-  (defun room (&optional x)
-    (let ((l (multiple-value-list (si:room-report)))
-          maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage
-          rbused rbfree nrbpage
---- 430,440 ----
-          '(cons
-            fixnum bignum ratio short-float long-float complex
-            character symbol package hash-table
-            array vector string bit-vector
-            structure stream random-state readtable pathname
-!           cfun cclosure sfun gfun vfun cfdata spice fat-string dclosure))
-  
-  (defun room (&optional x)
-    (let ((l (multiple-value-list (si:room-report)))
-          maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage
-          rbused rbfree nrbpage
-lsp/cmpinit.lsp
-*** lsp/cmpinit.lsp       Mon Jul  6 00:15:28 1992
---- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992
-***************
-*** 4,12 ****
-  (setq compiler::*eval-when-defaults* '(compile eval load))
-  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
-  ;(or (get 'si::s-data 'si::s-data)
-  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
-  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
-! 
-! 
-  
-  ;;;;;
---- 4,13 ----
-  (setq compiler::*eval-when-defaults* '(compile eval load))
-  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
-  ;(or (get 'si::s-data 'si::s-data)
-  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
-  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
-! (unless (get 'si::basic-wrapper 'si::s-data)
-!   (setf (get 'si::s-data 'si::s-data) nil)
-!   (load "../lsp/defstruct.lsp"))
-  
-  ;;;;;
diff --git a/pcl/new-kcl-wrapper.text b/pcl/new-kcl-wrapper.text
deleted file mode 100644
index 7f161a6c5b5451b79176dee53f436e02b303403b..0000000000000000000000000000000000000000
--- a/pcl/new-kcl-wrapper.text
+++ /dev/null
@@ -1,2157 +0,0 @@
-The new-kcl-wrapper modifications make the storage of standard-objects
-and structure objects much more similar than before.  These changes should 
-greatly speed up WRAPPER-OF for structure objects and should speed up
-WRAPPER-OF for standard-instances also (but not funcallable instances).
-
-Look first at the defstructs defined here (scan this file for "(defstruct (").
-Then look at cache.lisp, at the "#+structure-wrapper" for the new definition of
-the wrapper structure.  Finally, look in low.lisp, at the 
-"#+new-structure-wrapper" for the definition of %allocate-instance--class.
-
-You need to have akcl-1-615 to use this file.
-
-This file contains new versions of the files V/c/structure.c and 
-V/lsp/defstruct.lsp, as well as small changes to the files c/gbc.c, c/sgbc.c, 
-cmpnew/cmpinit.lsp, lsp/cmpinit.lsp, and lsp/describe.lsp.
-
--- The gbc changes allow the garbage collector to work correctly even when
-structures which define other structures (ones which can be the value of 
-STRUCTURE-DEF) are not allocated in static storage. 
-
-
-c/gbc.c
-*** c/gbc.c       Tue Jun 30 04:11:00 1992
---- ../akcl-1-615/c/gbc.c Tue Jun 30 02:48:04 1992
-***************
-*** 427,453 ****
-                          break;
-                  goto COPY_STRING;
-  
-          case t_structure:
-                  mark_object(x->str.str_def);
-                  p = x->str.str_self;
-                  if (p == NULL)
-!                         break;
-!                 {object def=x->str.str_def;
-!                  unsigned char * s_type = &SLOT_TYPE(def,0);
-!                  unsigned short *s_pos= & SLOT_POS(def,0);
-!                  for (i = 0, j = S_DATA(def)->length;  i < j;  i++)
-                     if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i]));
-                   if ((int)what_to_collect >= (int)t_contiguous) {
-                       if (inheap(x->str.str_self)) {
-                         if (what_to_collect == t_contiguous)
-                           mark_contblock((char *)p,
-!                                         S_DATA(def)->size);
-  
-                       } else
-!                        x->str.str_self = (object *)
-!                          copy_relblock((char *)p, S_DATA(def)->size);
-                     }}
-                  break;
-  
-          case t_stream:
-                  switch (x->sm.sm_mode) {
---- 427,461 ----
-                          break;
-                  goto COPY_STRING;
-  
-          case t_structure:
-+                 x->d.m = 2; 
-                  mark_object(x->str.str_def);
-                  p = x->str.str_self;
-                  if (p == NULL)
-!                         {x->d.m = TRUE; break;}
-!                 {object def=x->str.str_def;
-!                  struct s_data *sdef=S_DATA(def);
-!                  unsigned char *s_type;
-!                  unsigned short *s_pos;
-!                  if((int)what_to_collect >= (int)t_contiguous &&
-!                     !inheap(sdef) && def->d.m==TRUE)
-!                    sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start));
-!                  s_type = sdef->raw->ust.ust_self;
-!                  s_pos = &USHORT(sdef->slot_position,0);
-!                  for (i = 0, j = sdef->length;  i < j;  i++)
-                     if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i]));
-                   if ((int)what_to_collect >= (int)t_contiguous) {
-                       if (inheap(x->str.str_self)) {
-                         if (what_to_collect == t_contiguous)
-                           mark_contblock((char *)p,
-!                                         sdef->size);
-  
-                       } else
-!                         x->str.str_self = (object *)
-!                          copy_relblock((char *)p, sdef->size);
-                     }}
-+                 x->d.m = TRUE; 
-                  break;
-  
-          case t_stream:
-                  switch (x->sm.sm_mode) {
-*** c/sgbc.c      Mon Jun 15 21:16:01 1992
---- akcl-1-615/c/sgbc.c   Wed Jul  1 18:37:24 1992
-***************
-*** 355,386 ****
-                  if (cp == NULL)
-                          break;
-                  goto COPY_STRING;
-  
-          case t_structure:
-                  sgc_mark_object(x->str.str_def);
-                  p = x->str.str_self;
-                  if (p == NULL)
-!                         break;
-!                 {object def=x->str.str_def;
-!                  unsigned char * s_type = &SLOT_TYPE(def,0);
-!                  unsigned short *s_pos= & SLOT_POS(def,0);
-!                  for (i = 0, j = S_DATA(def)->length;  i < j;  i++)
-                     if (s_type[i]==0 &&
-                         ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i]))
-                         )
-                       sgc_mark_object(STREF(object,x,s_pos[i]));
-                   if ((int)what_to_collect >= (int)t_contiguous) {
-                       if (inheap(x->str.str_self)) {
-                         if (what_to_collect == t_contiguous)
-                           mark_contblock((char *)p,
-!                                         S_DATA(def)->size);
-  
-                       } else if(SGC_RELBLOCK_P(p))
-                         x->str.str_self = (object *)
-!                          copy_relblock((char *)p, S_DATA(def)->size);
-                     }}
-                  break;
-  
-          case t_stream:
-                  switch (x->sm.sm_mode) {
-                  case smm_input:
---- 355,394 ----
-                  if (cp == NULL)
-                          break;
-                  goto COPY_STRING;
-  
-          case t_structure:
-+                 x->d.m = 2;
-                  sgc_mark_object(x->str.str_def);
-                  p = x->str.str_self;
-                  if (p == NULL)
-!                         {x->d.m = TRUE; break;}
-!                 {object def=x->str.str_def;
-!                  struct s_data *sdef=S_DATA(def);
-!                  unsigned char *s_type;
-!                  unsigned short *s_pos;
-!                  if((int)what_to_collect >= (int)t_contiguous &&
-!                     !inheap(sdef) && def->d.m==TRUE)
-!                    sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start));
-!                  s_type = sdef->raw->ust.ust_self;
-!                  s_pos = &USHORT(sdef->slot_position,0);
-!                  for (i = 0, j = sdef->length;  i < j;  i++)
-                     if (s_type[i]==0 &&
-                         ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i]))
-                         )
-                       sgc_mark_object(STREF(object,x,s_pos[i]));
-                   if ((int)what_to_collect >= (int)t_contiguous) {
-                       if (inheap(x->str.str_self)) {
-                         if (what_to_collect == t_contiguous)
-                           mark_contblock((char *)p,
-!                                         sdef->size);
-  
-                       } else if(SGC_RELBLOCK_P(p))
-                         x->str.str_self = (object *)
-!                          copy_relblock((char *)p, sdef->size);
-                     }}
-+                 x->d.m = TRUE; 
-                  break;
-  
-          case t_stream:
-                  switch (x->sm.sm_mode) {
-                  case smm_input:
-cmpnew/cmpinit.lsp
-*** cmpnew/cmpinit.lsp    Tue Jun 30 04:11:13 1992
---- ../akcl-1-615/cmpnew/cmpinit.lsp      Mon Jun 22 18:41:51 1992
-***************
-*** 4,7 ****
---- 4,10 ----
-  (load "sys-proclaim.lisp")
-  (setq compiler::*eval-when-defaults* '(compile eval load))
-  
-  ;(dolist (v '( cmpeval cmpopt cmptype cmpbind cmpinline cmploc cmpvar cmptop cmplet cmpcall cmpmulti cmplam cmplabel          cmpeval))   (load (format nil "~(~a~).lsp" v)))
-+ (unless (get 'si::basic-wrapper 'si::s-data)
-+   (setf (get 'si::s-data 'si::s-data) nil)
-+   (load "../lsp/defstruct.lsp"))
-lsp/cmpinit.lsp
-*** lsp/cmpinit.lsp       Tue Jun 30 04:11:26 1992
---- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992
-***************
-*** 5,12 ****
-  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
-  ;(or (get 'si::s-data 'si::s-data)
-  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
-  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
-! 
-! 
-  
-  ;;;;;
---- 5,13 ----
-  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
-  ;(or (get 'si::s-data 'si::s-data)
-  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
-  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
-! (unless (get 'si::basic-wrapper 'si::s-data)
-!   (setf (get 'si::s-data 'si::s-data) nil)
-!   (load "../lsp/defstruct.lsp"))
-  
-  ;;;;;
-lsp/describe.lsp
-*** lsp/describe.lsp      Tue Jun 30 04:11:27 1992
---- ../akcl-1-615/lsp/describe.lsp        Tue Jun 23 16:39:07 1992
-***************
-*** 266,282 ****
-  
-  (defun inspect-structure (x &aux name)
-    (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name   :Slot Value"
-            (setq name (type-of x)))
-!   (let* ((sd (get name 'si::s-data))
-           (spos (s-data-slot-position sd)))
-      (dolist (v (s-data-slot-descriptions sd))
-              (format t "~%~4d:~@[[~s] ~]~20a:~s"   
-!                     (aref spos (nth 4 v))
-!                     (let ((type (nth 2 v)))
-                        (if (eq t type) nil type))
-!                     (car v)
-!                     (structure-ref1 x (nth 4 v))))))
-      
-    
-  (defun inspect-object (object &aux (*inspect-level* *inspect-level*))
-    (inspect-indent)
---- 266,282 ----
-  
-  (defun inspect-structure (x &aux name)
-    (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name   :Slot Value"
-            (setq name (type-of x)))
-!   (let* ((sd (structure-def x))
-           (spos (s-data-slot-position sd)))
-      (dolist (v (s-data-slot-descriptions sd))
-              (format t "~%~4d:~@[[~s] ~]~20a:~s"   
-!                     (aref spos (slot-offset v))
-!                     (let ((type (slot-type v)))
-                        (if (eq t type) nil type))
-!                     (slot-name v)
-!                     (structure-ref1 x (slot-offset v))))))
-      
-    
-  (defun inspect-object (object &aux (*inspect-level* *inspect-level*))
-    (inspect-indent)
-==============================================================================
-=============================== c/structure.c ================================
-Changes file for /kcl/c/structure.c
-Usage \n@s[Original text\n@s|Replacement Text\n@s]
-See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
-for a program to merge change files.  Anything not between
- "\n@s[" and  "\n@s]" is a simply a comment.
-This file was constructed using emacs and  merge.el
- by (Bill Schelter)  wfs@carl.ma.utexas.edu 
-
-
-****Change:(orig (15 17 d))
-@s[object siSstructure_print_function;
-object siSstructure_slot_descriptions;
-object siSstructure_include;
-
-@s|
-@s]
-
-
-****Change:(orig (18 18 a))
-@s[
-
-@s|
-#define COERCE_DEF(x) if (type_of(x)==t_symbol) \
-  x=getf(x->s.s_plist,siLs_data,Cnil)
-
-#define check_type_structure(x) \
-  if(type_of((x))!=t_structure) \
-    FEwrong_type_argument(Sstructure,(x)) 
-
-
-
-@s]
-
-
-****Change:(orig (22 31 c))
-@s[{
-	do {
-		if (type_of(x) != t_symbol)
-		        return(FALSE);
-
-@s,       } while (x != Cnil);
-	return(FALSE);
-}
-
-@s|{ if (x==y) return 1;
-  if (type_of(x)!= t_structure
-      || type_of(y)!=t_structure)
-    FEerror("bad call to structure_subtypep",0);
-  {if (S_DATA(y)->included == Cnil) return 0;
-   while ((x=S_DATA(x)->includes) != Cnil)
-     { if (x==y) return 1;}
-   return 0;
- }}
-
-@s]
-
-
-****Change:(orig (32 32 a))
-@s[
-
-@s|
-static
-bad_raw_type()
-{           FEerror("Bad raw struct type",0);}
-
-
-
-@s]
-
-
-****Change:(orig (34 34 c))
-@s[structure_ref(x, name, n)
-
-@s|structure_ref(x, name, i)
-
-@s]
-
-
-****Change:(orig (36 38 c))
-@s[object x, name;
-int n;
-{
-	int i;
-
-@s|object x, name;
-int i;
-{unsigned short *s_pos;
- COERCE_DEF(name);
- if (type_of(x) != t_structure ||
-     (type_of(name)!=t_structure) ||
-     !structure_subtypep(x->str.str_def, name))
-   FEwrong_type_argument((type_of(name)==t_structure ?
-		          S_DATA(name)->name : name),
-		         x);
- s_pos = &SLOT_POS(x->str.str_def,0);
- switch((SLOT_TYPE(x->str.str_def,i)))
-   {
-   case aet_object: return(STREF(object,x,s_pos[i]));
-   case aet_fix:  return(make_fixnum((STREF(int,x,s_pos[i]))));
-   case aet_ch:  return(code_char(STREF(char,x,s_pos[i])));
-   case aet_bit:
-   case aet_char: return(make_fixnum(STREF(char,x,s_pos[i])));
-   case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i])));
-   case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i])));
-   case aet_uchar: return(make_fixnum(STREF(unsigned char,x,s_pos[i])));
-   case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i])));
-   case aet_short: return(make_fixnum(STREF(short,x,s_pos[i])));
-   default:
-     bad_raw_type();
-     return 0;
-   }}
-
-@s]
-
-
-****Change:(orig (40 43 c))
-@s[       if (type_of(x) != t_structure ||
-	    !structure_subtypep(x->str.str_name, name))
-		FEwrong_type_argument(name, x);
-	return(x->str.str_self[n]);
-
-@s|
-void
-siLstructure_ref1()
-{object x=vs_base[0];
- int n=fix(vs_base[1]);
- object def;
- check_type_structure(x);
- def=x->str.str_def;
- if(n>= S_DATA(def)->length)
-   FEerror("Structure ref out of bounds",0);
- vs_base[0]=structure_ref(x,x->str.str_def,n);
- vs_top=vs_base+1;
-
-@s]
-
-
-****Change:(orig (45 45 a))
-@s[}
-
-
-@s|}
-
-void
-siLstructure_set1()
-{object x=vs_base[0];
- int n=fix(vs_base[1]);
- object v=vs_base[2];
- object def;
- check_type_structure(x);
- def=x->str.str_def;
- if(n>= S_DATA(def)->length)
-   FEerror("Structure ref out of bounds",0);
- vs_base[0]=structure_set(x,x->str.str_def,n,v);
- vs_top=vs_base+1;
-}  
-
-
-
-@s]
-
-
-****Change:(orig (47 47 c))
-@s[structure_set(x, name, n, v)
-
-@s|structure_set(x, name, i, v)
-
-@s]
-
-
-****Change:(orig (49 51 c))
-@s[object x, name, v;
-int n;
-{
-	int i;
-
-@s|object x, name, v;
-int i;
-{unsigned short *s_pos;
- 
- COERCE_DEF(name);
- if (type_of(x) != t_structure ||
-     type_of(name) != t_structure ||
-     !structure_subtypep(x->str.str_def, name))
-   FEwrong_type_argument((type_of(name)==t_structure ?
-		          S_DATA(name)->name : name)
-		         , x);
-
-@s]
-
-
-****Change:(orig (53 57 c))
-@s[       if (type_of(x) != t_structure ||
-	    !structure_subtypep(x->str.str_name, name))
-		FEwrong_type_argument(name, x);
-	x->str.str_self[n] = v;
-
-@s,       return(v);
-
-@s|#ifdef SGC
- /* make sure the structure header is on a writable page */
- if (x->d.m) FEerror("bad gc field",0); else  x->d.m = 0;
-#endif   
- 
- s_pos= & SLOT_POS(x->str.str_def,0);
- switch(SLOT_TYPE(x->str.str_def,i)){
-   
-   case aet_object: STREF(object,x,s_pos[i])=v; break;
-   case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
-   case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
-   case aet_bit:
-   case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
-   case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
-   case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
-   case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
-   case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
-   case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
- default:
-   bad_raw_type();
-
-   }
- return(v);
-
-@s]
-
-
-****Change:(orig (59 59 a))
-@s[}
-
-
-@s|}
-
-void
-siLstructure_subtype_p()
-{object x,y;
- check_arg(2);
- x=vs_base[0];
- y=vs_base[1];
- if (type_of(x)!=t_structure)
-   {vs_base[0]=Cnil; goto BOTTOM;}
- x=x->str.str_def;
- COERCE_DEF(y);
- if (structure_subtypep(x,y)) vs_base[0]=Ct;
- else vs_base[0]=Cnil;
- BOTTOM:
- vs_top=vs_base+1;
-}
- 
-static object
-slot_name(x)
-     object x;
-{
-  if(type_of(x)==t_cons)
-    return car(x);
-  if(type_of(x)==t_structure)
-    return x->str.str_self[0];
-  return Cnil;
-}
-
-
-@s]
-
-
-****Change:(orig (64 64 a))
-@s[object x;
-{
-	object *p, s;
-
-@s|object x;
-{
-	object *p, s;
-	struct s_data *def=S_DATA(x->str.str_def);
-
-@s]
-
-
-****Change:(orig (66 69 c))
-@s[
-	s = getf(x->str.str_name->s.s_plist,
-	         siSstructure_slot_descriptions, Cnil);
-	vs_push(x->str.str_name);
-
-@s|       
-	s = def->slot_descriptions;
-	vs_push(def->name);
-
-@s]
-
-
-****Change:(orig (72 73 c))
-@s[       for (i=0, n=x->str.str_length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
-		*p = make_cons(car(s->c.c_car), Cnil);
-
-@s|       for (i=0, n=def->length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
-		*p = make_cons(slot_name(s->c.c_car), Cnil);
-
-@s]
-
-
-****Change:(orig (75 75 c))
-@s[               *p = make_cons(x->str.str_self[i], Cnil);
-
-@s|               *p = make_cons(structure_ref(x,x->str.str_def,i), Cnil);
-
-@s]
-
-
-****Change:(orig (81 81 a))
-@s[       stack_cons();
-	return(vs_pop);
-}
-
-
-@s|       stack_cons();
-	return(vs_pop);
-}
-
-void
-
-@s]
-
-
-****Change:(orig (84 85 c))
-@s[       object x;
-	int narg, i;
-
-@s|  object x,name,*base;
-  struct s_data *def;
-  int narg, i,size;
-  base=vs_base;
-  if ((narg = vs_top - base) == 0)
-    too_few_arguments();
-  x = alloc_object(t_structure);
-  name=base[0];
-  COERCE_DEF(name);
-  if (type_of(name)!=t_structure  ||
-      (def=S_DATA(name))->length != --narg)
-    FEerror("Bad make_structure args for type ~a",1,
-	    base[0]);
-  x->str.str_def = name;
-  x->str.str_self = NULL;
-  size=S_DATA(name)->size;
-  base[0] = x;
-  x->str.str_self = (object *)
-    (def->staticp == Cnil ? alloc_relblock(size)
-     : alloc_contblock(size));
-  /* There may be holes in the structure.
-     We want them zero, so that equal can work better.
-     */
-  if (S_DATA(name)->has_holes != Cnil)
-    bzero(x->str.str_self,size);
-  {unsigned char *s_type;
-   unsigned short *s_pos;
-   s_pos= (&SLOT_POS(x->str.str_def,0));
-   s_type = (&(SLOT_TYPE(x->str.str_def,0)));
-   base=base+1;
-   for (i = 0;  i < narg;  i++)
-     {object v=base[i];
-      switch(s_type[i]){
-	     
-      case aet_object: STREF(object,x,s_pos[i])=v; break;
-      case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
-      case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
-      case aet_bit:
-      case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
-      case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
-      case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
-      case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
-      case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
-      case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
-      default:
-	bad_raw_type();
-
-@s]
-
-
-****Change:(orig (87 97 c))
-@s[       if ((narg = vs_top - vs_base) == 0)
-		too_few_arguments();
-	x = alloc_object(t_structure);
-	x->str.str_name = vs_base[0];
-
-@s,               x->str.str_self[i] = vs_top[i];
-
-@s|      }}
-   vs_top = base;
-   vs_base=base-1;
-
- }
-
-@s]
-
-
-****Change:(orig (99 99 a))
-@s[}
-
-
-@s|}
-
-void
-
-@s]
-
-
-****Change:(orig (103 103 c))
-@s[       object x, y;
-	int i, j;
-
-@s|       object x, y;
-	struct s_data *def;
-
-@s]
-
-
-****Change:(orig (105 105 c))
-@s[
-	check_arg(2);
-
-@s|
-	if (vs_top-vs_base < 1) too_few_arguments();
-
-@s]
-
-
-****Change:(orig (107 110 c))
-@s[       if (type_of(x) != t_structure || x->str.str_name != vs_base[1])
-		FEwrong_type_argument(vs_base[1], x);
-	vs_base[1] = y = alloc_object(t_structure);
-	y->str.str_name = x->str.str_name;
-
-@s|       check_type_structure(x);
-	vs_base[0] = y = alloc_object(t_structure);
-	def=S_DATA(y->str.str_def = x->str.str_def);
-
-@s]
-
-
-****Change:(orig (112 116 c))
-@s[       y->str.str_length = j = x->str.str_length;
-	y->str.str_self = (object *)alloc_relblock(sizeof(object)*j);
-	for (i = 0;  i < j;  i++)
-		y->str.str_self[i] = x->str.str_self[i];
-
-@s,       vs_base++;
-
-@s|       y->str.str_self = (object *)alloc_relblock(def->size);
-	bcopy(x->str.str_self,y->str.str_self,def->size);
-	vs_top=vs_base+1;
-
-@s]
-
-
-****Change:(orig (118 118 a))
-@s[}
-
-
-@s|}
-
-void
-siLcopy_structure_header()
-{
-	object x, y;
-
-	if (vs_top-vs_base < 1) too_few_arguments();
-	x = vs_base[0];
-	check_type_structure(x);
-	vs_base[0] = y = alloc_object(t_structure);
-	y->str.str_def = x->str.str_def;
-	y->str.str_self = x->str.str_self;
-	vs_top=vs_base+1;
-}
-
-
-void
-
-@s]
-
-
-****Change:(orig (122 124 c))
-@s[       if (type_of(vs_base[0]) != t_structure)
-		FEwrong_type_argument(Sstructure, vs_base[0]);
-	vs_base[0] = vs_base[0]->str.str_name;
-
-@s|       check_type_structure(vs_base[0]);
-	vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name;
-
-@s]
-
-
-****Change:(orig (127 127 c))
-@s[}
-
-siLstructure_ref()
-
-@s|}
-
-#define FIND_SLOT(str,name) ((type_of(name)==t_fixnum)?fix(name): \
-		             structure_slot_position(str,name))
-
-object
-structure_ref_new(x, name, i)
-     object x,name,i;
-
-@s]
-
-
-****Change:(orig (129 131 c))
-@s[       object x;
-	int i;
-	check_arg(3);
-
-@s|  return structure_ref(x,name,FIND_SLOT(x,i));
-}
-
-@s]
-
-
-****Change:(orig (133 144 c))
-@s[       x = vs_base[0];
-	if (type_of(x) != t_structure ||
-	    !structure_subtypep(x->str.str_name, vs_base[1]))
-		FEwrong_type_argument(vs_base[1], x);
-
-@s,       vs_base[0] = x->str.str_self[i];
-	vs_top = vs_base+1;
-
-@s|object
-structure_set_new(x, name, i, v)
-     object x,name,i,v;
-{
-  return structure_set(x,name,FIND_SLOT(x,i),v);
-
-@s]
-
-
-****Change:(orig (146 146 a))
-@s[}
-
-
-@s|}
-
-void
-siLstructure_ref()
-{
-  check_arg(3);
-  vs_base[0]=structure_ref_new(vs_base[0],vs_base[1],vs_base[2]);
-  vs_top=vs_base+1;
-}
-
-void
-
-@s]
-
-
-****Change:(orig (149 150 d))
-@s[siLstructure_set()
-{
-	object x;
-	int i;
-
-@s|siLstructure_set()
-{
-
-@s]
-
-
-****Change:(orig (152 163 c))
-@s[
-	x = vs_base[0];
-	if (type_of(x) != t_structure ||
-	    !structure_subtypep(x->str.str_name, vs_base[1]))
-
-@s,       x->str.str_self[i] = vs_base[3];
-
-@s|       structure_set_new(vs_base[0],vs_base[1],vs_base[2],vs_base[3]);
-
-@s]
-
-
-****Change:(orig (166 166 a))
-@s[       vs_base = vs_top-1;
-}
-
-
-@s|       vs_base = vs_top-1;
-}
-
-void
-
-@s]
-
-
-****Change:(orig (228 228 c))
-@s[init_structure_function()
-
-@s|void
-siLmake_s_data_structure()
-{object x,y,raw,*base;
- int i;
- check_arg(5);
- x=vs_base[0];
- base=vs_base;
- raw=vs_base[1];
- y=alloc_object(t_structure);
- y->str.str_def=y;
- y->str.str_self = (object *)( x->v.v_self);
- S_DATA(y)->name  =siLs_data;
- S_DATA(y)->length=(raw->v.v_dim);
- S_DATA(y)->raw   =raw;
- for(i=3; i<raw->v.v_dim; i++)
-   y->str.str_self[i]=Cnil;
- S_DATA(y)->slot_position=base[2];
- S_DATA(y)->slot_descriptions=base[3];
- S_DATA(y)->staticp=base[4];
- S_DATA(y)->size = (raw->v.v_dim)*sizeof(object);
- vs_base[0]=y;
- vs_top=vs_base+1;
-}
-
-object siSstructure_init,siSstructure_init_named;
-object siSname,siSdefault_init;
-object siSraw,siSslot_position,siSsize,siSstaticp,siSslot_descriptions;
-
-static object
-slot_value(str,name)
-     object str,name;
-
-@s]
-
-
-****Change:(orig (230 237 c))
-@s[       siSstructure_print_function
-	= make_si_ordinary("STRUCTURE-PRINT-FUNCTION");
-	enter_mark_origin(&siSstructure_print_function);
-	siSstructure_slot_descriptions
-
-@s,       enter_mark_origin(&siSstructure_include);
-
-@s| top:
-  if(type_of(str)==t_structure)
-    return structure_ref_new(str,str->str.str_def,name);
-  if(str->c.c_car==siSstructure_init_named)
-    {object new=get(str->c.c_cdr,siLs_data);
-     str->c.c_car=siSstructure_init;
-     str->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);}
-  if(siSstructure_init!=car(str))
-    FEerror("Illegal call to SI:MAKE-STRUCTURES 1",0);
-  {object key=intern(coerce_to_string(name),keyword_package);
-   object value=getf(cdddr(str),key,NULL);
-   if(value!=NULL)
-     return value;
-   else
-     {object slots;
-      if(str==caddr(str)&&name==siSslot_descriptions)
-	FEerror("Illegal call to SI:MAKE-STRUCTURES 2",0);
-      slots=slot_value(caddr(str),siSslot_descriptions);
-      for(;!endp(slots);slots=cdr(slots))
-	if(name==slot_value(car(slots),siSname))
-	  {object result,form=slot_value(car(slots),siSdefault_init);
-	   object *old_vs_base=vs_base,*old_vs_top=vs_top;
-	   vs_base=vs_top;vs_push(form);Leval();result=vs_base[0];
-	   vs_base=old_vs_base; vs_top=old_vs_top;
-	   return result;}
-      FEerror("Illegal call to SI:MAKE-STRUCTURES 3",0);}}
-  return Cnil;
-}
-
-@s]
-
-
-****Change:(orig (238 238 a))
-@s[
-
-@s|
-int 
-structure_slot_position(str,name)
-     object str,name;
-{
-  if(type_of(name)==t_fixnum)
-    return fix(name);
-  else
-    {object slotd_list;
-     int pos;
-     check_type_structure(str);
-     slotd_list=S_DATA(str->str.str_def)->slot_descriptions;
-     for(pos=0; type_of(slotd_list)==t_cons; pos++,slotd_list=cdr(slotd_list))
-       {object slotd=car(slotd_list);
-	if(name==((type_of(slotd)==t_structure)?
-		  slotd->str.str_self[0]:slot_value(slotd,siSname)))
-	  return pos;}
-     FEerror("Slot ~S not found in structure ~S",2,name,str);
-     return 0;}  
-}
-
-static object
-make_structures_internal(value)
-     object value;
-{
-  object str,def;
-  int def_index,i,ind;
-
-  switch(type_of(value))
-    {case t_cons:
-       if(value->c.c_car==siSstructure_init_named)
-	 {object new=get(value->c.c_cdr,siLs_data);
-	  value->c.c_car=siSstructure_init;
-	  value->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);}
-       if(car(value)!=siSstructure_init)
-	 {value->c.c_car=make_structures_internal(value->c.c_car);
-	  value->c.c_cdr=make_structures_internal(value->c.c_cdr);
-	  break;}
-       if(type_of(cadr(value))==t_structure)
-	 {value=value->c.c_cdr->c.c_car;
-	  break;}
-       {object def=caddr(value),plist=cdddr(value),result;
-	object slots,slots_tail;
-	int size,staticp,len,i;
-	if(def!=value)def=make_structures_internal(def);
-	result=alloc_object(t_structure);
-	result->str.str_def=(def==value)?result:def;
-	result->str.str_self=NULL;
-	value->c.c_cdr->c.c_car=result;
-	size=fixint(slot_value(def,siSsize));
-	staticp=Cnil!=slot_value(def,siSstaticp);
-	slots=slot_value(def,siSslot_descriptions);
-	len=length(slots);
-	result->str.str_self=(object *)(staticp?alloc_contblock(size):
-		                                alloc_relblock(size));
-	bzero(result->str.str_self,size);
-	if(def==value)
-	  {S_DATA(result)->raw=slot_value(def,siSraw);
-	   S_DATA(result)->slot_position=slot_value(def,siSslot_position);}
-	for(i=0,slots_tail=slots; i<len; i++,slots_tail=cdr(slots_tail))
-	  {object svalue=slot_value(value,slot_value(car(slots_tail),siSname));
-	   structure_set(result,result->str.str_def,i,svalue);}
-	for(i=0,slots_tail=slots; i<len; i++,slots_tail=cdr(slots_tail))
-	  {object svalue=structure_ref(result,result->str.str_def,i);
-	   svalue=make_structures_internal(svalue);
-	   structure_set(result,result->str.str_def,i,svalue);}
-	value=result;
-	break;}
-     case t_vector:
-       if ((enum aelttype)value->v.v_elttype == aet_object)
-	 {int i,len=value->v.v_dim;
-	  for(i=0; i<len; i++)
-	    value->v.v_self[i]=make_structures_internal(value->v.v_self[i]);}
-       break;
-     case t_symbol:
-       {object plist=value->s.s_plist,next;
-	for(;!endp(plist);plist=cddr(plist))
-	  {next=plist->c.c_cdr;
-	   if(plist->c.c_car==siLs_data&&
-	      type_of(next->c.c_car)==t_cons)
-	     next->c.c_car=make_structures_internal(next->c.c_car);}
-	break;}}
-  return value;   
-}
-
-void
-siLmake_structures()
-{
-  check_arg(1);
-  vs_base[0]=make_structures_internal(vs_base[0]);
-}
-
-void
-siLstructure_def()
-{check_arg(1);
- check_type_structure(vs_base[0]);
-  vs_base[0]=vs_base[0]->str.str_def;
-}
-
-short aet_sizes [] = {
-sizeof(object),  /* aet_object  t  */
-sizeof(char),  /* aet_ch  string-char  */
-sizeof(char),  /* aet_bit  bit  */
-sizeof(fixnum),  /* aet_fix  fixnum  */
-sizeof(float),  /* aet_sf  short-float  */
-sizeof(double),  /* aet_lf  long-float  */
-sizeof(char),  /* aet_char  signed char */
-sizeof(char),  /* aet_uchar  unsigned char */
-sizeof(short),  /* aet_short  signed short */
-sizeof(short)  /* aet_ushort  unsigned short   */
-};
-
-  
-
-
-
-void
-siLsize_of() 
-{ object x= vs_base[0];
-  int i;
-  i= aet_sizes[get_aelttype(x)];
-  vs_base[0]=make_fixnum(i);
-}
-  
-void
-siLaet_type()
-{vs_base[0]=make_fixnum(get_aelttype(vs_base[0]));}
-
-
-/* Return N such that something of type ARG can be aligned on
-   an address which is a multiple of N */
-
-
-void
-siLalignment()
-{struct {double x; int y; double z;
-	 float x1; int y1; float z1;}
- joe;
- joe.z=3.0;
- 
- if (vs_base[0]==Slong_float)
-   {vs_base[0]=make_fixnum((int)&joe.z- (int)&joe.y); return;}
- else
-   if (vs_base[0]==Sshort_float)
-     {vs_base[0]=make_fixnum((int)&(joe.z1)-(int)&(joe.y1)); return;}
-   else
-     {siLsize_of();}
-}
-   
-void
-swap_structure_contents(str1,str2)
-   object str1,str2;
-{
-  object def1,*self1;
-  check_type_structure(str1);
-  check_type_structure(str2);
-  def1=str1->str.str_def;
-  self1=str1->str.str_self;
-  str1->str.str_def=str2->str.str_def;
-  str1->str.str_self=str2->str.str_self;
-  str2->str.str_def=def1;
-  str2->str.str_self=self1;
-}
-
-void
-siLswap_structure_contents()
-{
-  check_arg(2);
-  swap_structure_contents(vs_base[0],vs_base[1]);
-  vs_base[0]=Cnil;
-  vs_top=vs_base+1;
-}
-
-void
-siLset_structure_def()
-{check_arg(2);
- check_type_structure(vs_base[0]);
- check_type_structure(vs_base[1]);
- vs_base[0]->str.str_def=vs_base[1];
- vs_base[0]=vs_base[1];
- vs_top=vs_base+1;
-}
-
-init_structure_function()
-{
-        siLs_data=make_si_ordinary("S-DATA");
-	siSstructure_init=make_si_ordinary("STRUCTURE-INIT");
-	siSstructure_init_named=make_si_ordinary("STRUCTURE-INIT-NAMED");
-	siSname=make_si_ordinary("NAME");
-	siSdefault_init=make_si_ordinary("DEFAULT-INIT");
-	siSraw=make_si_ordinary("RAW");
-	siSslot_position=make_si_ordinary("SLOT-POSITION");
-	siSsize=make_si_ordinary("SIZE");
-	siSstaticp=make_si_ordinary("STATICP");
-	siSslot_descriptions=make_si_ordinary("SLOT-DESCRIPTIONS");
-
-@s]
-
-
-****Change:(orig (239 239 a))
-@s[       make_si_function("MAKE-STRUCTURE", siLmake_structure);
-
-@s|       make_si_function("MAKE-STRUCTURE", siLmake_structure);
-	make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure);
-
-@s]
-
-
-****Change:(orig (240 240 a))
-@s[       make_si_function("COPY-STRUCTURE", siLcopy_structure);
-
-@s|       make_si_function("COPY-STRUCTURE", siLcopy_structure);
-	make_si_function("COPY-STRUCTURE-HEADER", siLcopy_structure_header);
-
-@s]
-
-
-****Change:(orig (242 242 a))
-@s[       make_si_function("STRUCTURE-REF", siLstructure_ref);
-
-@s|       make_si_function("STRUCTURE-REF", siLstructure_ref);
-	make_si_function("STRUCTURE-DEF", siLstructure_def);
-	make_si_function("STRUCTURE-REF1", siLstructure_ref1);
-	make_si_function("STRUCTURE-SET1", siLstructure_set1);
-
-@s]
-
-
-****Change:(orig (245 245 c))
-@s[       make_si_function("STRUCTUREP", siLstructurep);
-
-
-@s|       make_si_function("STRUCTUREP", siLstructurep);
-	make_si_function("SIZE-OF", siLsize_of);
-	make_si_function("ALIGNMENT",siLalignment);
-	make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p);
-
-@s]
-
-
-****Change:(orig (247 247 a))
-@s[       make_si_function("LIST-NTH", siLlist_nth);
-
-@s|       make_si_function("LIST-NTH", siLlist_nth);
-	make_si_function("AET-TYPE",siLaet_type);
-	make_si_function("SWAP-STRUCTURE-CONTENTS",siLswap_structure_contents);
-	make_si_function("SET-STRUCTURE-DEF", siLset_structure_def);
-	make_si_function("MAKE-STRUCTURES", siLmake_structures);
-
-
-@s]
-
-==============================================================================
-============================== V/lsp/defstruct.lsp =============================
-Changes file for /kcl/lsp/defstruct.lsp
-Usage \n@s[Original text\n@s|Replacement Text\n@s]
-See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
-for a program to merge change files.  Anything not between
- "\n@s[" and  "\n@s]" is a simply a comment.
-This file was constructed using emacs and  merge.el
- by (Bill Schelter)  wfs@carl.ma.utexas.edu 
-
-
-****Change:(orig (20 71 c))
-@s[(defun make-access-function (name conc-name type named
-                             slot-name default-init slot-type read-only
-                             offset)
-  (declare (ignore named default-init slot-type))
-
-@s,          ((error "~S is an illegal structure type." type)))))
-
-@s|(defvar *accessors* (make-array 10 :adjustable t))
-(defvar *list-accessors* (make-array 2 :adjustable t))
-(defvar *vector-accessors* (make-array 2 :adjustable t))
-
-@s]
-
-
-****Change:(orig (72 72 a))
-@s[
-
-@s|
-(or (fboundp 'record-fn) (setf (symbol-function 'record-fn)
-		               #'(lambda (&rest l) l nil)))
-
-@s]
-
-
-****Change:(orig (73 73 a))
-@s[
-
-@s|
-(defun boot-slot-value (str name)
-  (if (structurep str)
-      (structure-ref str (structure-def str) name)
-      (getf (cdddr str) (intern (string name) :keyword))))
-
-(defun boot-set-slot-value (str name new-value)
-  (if (structurep str)
-      (structure-set str (structure-def str) name new-value)
-      (setf (getf (cdddr str) (intern (string name) :keyword)) new-value)))
-
-(defun boot-subtypep (type1 type2)
-  (or (eq type1 type2)
-      (let* ((s-data (get type1 's-data))
-	     (include (boot-s-data-name (boot-slot-value s-data 'includes))))
-	(boot-subtypep include type2))))
-
-(defun make-slot-boot (&rest args)
-  (if (get 's-data 's-data)
-      (apply #'make-slot args)
-      (list* 'structure-init
-	     nil
-	     '(structure-init-named . slot)
-	     args)))
-
-(defun make-s-data-boot (&rest args)
-  (if (get 's-data 's-data)
-      (apply #'make-s-data args)
-      (list* 'structure-init
-	     nil
-	     '(structure-init-named . s-data)
-	     args)))
-
-(defun make-boot-accessor (slot accessor)
-  (setf (symbol-function accessor) 
-	#'(lambda (object)
-	    (boot-slot-value object slot)))
-  (let ((writer (intern (format nil "SET ~A" accessor))))
-    (setf (symbol-function writer)
-	  #'(lambda (object value)
-	      (boot-set-slot-value object slot value)))
-    (eval `(defsetf ,accessor ,writer))))
-
-(defmacro defstructboot (name &rest slots)
-  (let ((conc-name (if (listp name)
-		       (string (second (assoc :conc-name (cdr name))))
-		       (format nil "~A-" name))))
-    `(progn
-       ,@(mapcar #'(lambda (slot)
-		     (let ((fname (intern (format nil "~A~A" conc-name slot))))
-		       `(make-boot-accessor ',slot ',fname)))
-	         slots))))
-
-(defstructboot (slot (:conc-name boot-slot-))
-  name default-init type read-only offset accessor-name type-changed)
-
-(defstructboot (s-data-internal (:conc-name boot-s-data-))
-  name length raw included includes staticp print-function
-  slot-descriptions slot-position size has-holes)
-
-(defstructboot (basic-wrapper (:conc-name boot-wrapper-))
-  cache-number-vector state class)
-
-(defstructboot (s-data (:conc-name boot-s-data-))
-  frozen documentation constructors offset
-  named type conc-name)
-
-(defun make-access-function (name conc-name type named include no-fun slot)
-  (declare (ignore named))
-  
-  (let* ((slot-name (boot-slot-name slot))
-	 (slot-type (boot-slot-type slot))
-	 (read-only (boot-slot-read-only slot))
-	 (offset (boot-slot-offset slot))
-	 (access-function
-	  (intern (si:string-concatenate (string conc-name)
-		                         (string slot-name))))
-	accsrs dont-overwrite)
-    (unless (boot-slot-accessor-name slot)
-      (setf (boot-slot-accessor-name slot) access-function))
-    (ecase type
-      ((nil)
-       (setf accsrs *accessors*))
-      (list
-	(setf accsrs *list-accessors*))
-      (vector
-	(setf accsrs *vector-accessors*)))
-    (or (> (length  accsrs) offset)
-	(adjust-array accsrs (+ offset 10)))
-    (unless
-     dont-overwrite
-     (record-fn access-function 'defun '(t) slot-type)
-     (or no-fun
-	 (and (fboundp access-function)
-	      (eq (aref accsrs offset) (symbol-function access-function)))
-	 (setf (symbol-function access-function)
-	   (or (aref accsrs offset)
-	       (setf (aref accsrs offset)
-		     (cond  ((eq accsrs *accessors*)
-		                #'(lambda (x)
-		                    (or (structurep x)
-		                        (error "~a is not a structure" x))
-		                    (structure-ref1 x offset)))
-		               ((eq accsrs *list-accessors*)
-		                #'(lambda(x)
-		                    (si:list-nth offset x)))
-		               ((eq accsrs *vector-accessors*)
-		                #'(lambda(x)
-		                    (aref x offset)))))))))
-    (cond (read-only
-	    (remprop access-function 'structure-access)
-	    (setf (get access-function 'struct-read-only) t))
-	  (t (remprop access-function 'setf-update-fn)
-	     (remprop access-function 'setf-lambda)
-	     (remprop access-function 'setf-documentation)
-	     (let ((tem (get access-function 'structure-access)))
-	       (cond ((and (consp tem) include
-		           (if (consp (get include 's-data))
-		               (boot-subtypep include (car tem))
-		               (subtypep include (car tem)))
-		           (eql (cdr tem) offset))
-		      ;; don't change overwrite accessor of subtype.
-		      (setq dont-overwrite t)
-		      )
-		     (t  (setf (get access-function 'structure-access)
-		               (cons (if type type name) offset)))))))
-    nil))
-
-
-@s]
-
-
-****Change:(orig (80 89 c))
-@s[                     (cond ((null x)
-                            ;; If the slot-description is NIL,
-                            ;;  it is in the padding of initial-offset.
-                            nil)
-
-@s,                           (t (car x))))
-
-@s|                    (or (boot-slot-name x)
-		         (and (boot-slot-default-init x)
-		              ;; If the slot name is NIL,
-		              ;;  it is the structure name.
-		              ;;  This is for typed structures with names.
-		              (list 'quote (boot-slot-default-init x)))))
-
-@s]
-
-
-****Change:(orig (94 97 c))
-@s[                     (cond ((null x) nil)
-                           ((null (car x)) nil)
-                           ((null (cadr x)) (list (car x)))
-                           (t (list (list  (car x) (cadr x))))))
-
-@s|                    (when (boot-slot-name x)
-		       (if (boot-slot-default-init x)
-		           (list (list (boot-slot-name x) (boot-slot-default-init x)))
-		           (list (boot-slot-name x)))))
-
-@s]
-
-
-****Change:(orig (248 248 d))
-@s[          ((error "~S is an illegal structure type" type)))))
-
-
-
-@s|          ((error "~S is an illegal structure type" type)))))
-
-
-@s]
-
-
-****Change:(orig (252 265 d))
-@s[
-(defun make-copier (name copier type named)
-  (declare (ignore named))
-  (cond ((null type)
-
-@s,        ((error "~S is an illegal structure type." type))))
-
-
-
-@s|
-@s]
-
-
-****Change:(orig (267 275 c))
-@s[  (cond ((null type)
-         ;; If TYPE is NIL, the predicate searches the link
-         ;;  of structure-include, until there is no included structure.
-         `(defun ,predicate (x)
-
-@s,                   (setq n (get n 'structure-include))))))
-
-@s|  (cond ((null type))
-	 ; done in define-structure
-
-@s]
-
-
-****Change:(orig (282 283 c))
-@s[                 (> (length x) ,name-offset)
-                 (eq (elt x ,name-offset) ',name))))
-
-@s|                 (> (the fixnum (length x)) ,name-offset)
-                 (eq (aref (the (vector t) x) ,name-offset) ',name))))
-
-@s]
-
-
-****Change:(orig (294 294 a))
-@s[                         ((= i 0) (and (consp y) (eq (car y) ',name)))
-
-@s|                         ((= i 0) (and (consp y) (eq (car y) ',name)))
-		         (declare (fixnum i))
-
-@s]
-
-
-****Change:(orig (300 301 c))
-@s[;;;  and returns a list of the form:
-;;;        (slot-name default-init slot-type read-only offset)
-
-@s|;;;  and returns a slot.
-
-@s]
-
-
-****Change:(orig (325 325 c))
-@s[    (list slot-name default-init slot-type read-only offset)))
-
-@s|    (make-slot-boot :name slot-name
-		    :default-init default-init
-		    :type slot-type
-		    :read-only read-only
-		    :offset offset)))
-
-@s]
-
-
-****Change:(orig (335 335 c))
-@s[      (let ((sds (member (caar olds) news :key #'car)))
-
-@s|      (let* ((old (car olds))
-	     (sds (member (boot-slot-name old) news :key #'slot-name))
-	     (new (car sds)))
-
-@s]
-
-
-****Change:(orig (337 348 c))
-@s[               (when (and (null (cadddr (car sds)))
-                          (cadddr (car olds)))
-                     ;; If read-only is true in the old
-                     ;;  and false in the new, signal an error.
-
-@s,                           (car (cddddr (car olds))))
-
-@s|               (when (and (null (boot-slot-read-only new))
-                          (boot-slot-read-only old))
-		 ;; If read-only is true in the old
-		 ;;  and false in the new, signal an error.
-		 (error "~S is an illegal include slot-description."
-		        new))
-	       ;; If
-	       (setf (boot-slot-type new)
-		     (best-array-element-type (boot-slot-type new)))
-	       (when (not (equal (normalize-type (or (boot-slot-type new) t))
-		                 (normalize-type (or (boot-slot-type old) t))))
-		 (error "Type mismmatch for included slot ~a" new))
-	       (cons (make-slot :name (boot-slot-name new)
-		                :default-init (boot-slot-default-init new)
-		                :type (boot-slot-type new)
-		                :read-only (boot-slot-read-only new)
-		                :offset (boot-slot-offset old))
-
-@s]
-
-
-****Change:(orig (353 353 a))
-@s[                     (overwrite-slot-descriptions news (cdr olds))))))))
-
-
-@s|                     (overwrite-slot-descriptions news (cdr olds))))))))
-
-(defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t))
-
-@s]
-
-
-****Change:(orig (355 355 c))
-@s[;;; The DEFSTRUCT macro.
-
-@s|(defun make-t-type (n include slot-descriptions &aux i)
-  (let ((res  (make-array n :element-type 'unsigned-char :static t)))
-    (when include
-      (let ((tem (get include 's-data))raw)
-	(or tem (error "Included structure undefined ~a" include))
-	(setq raw (boot-s-data-raw tem))
-	(dotimes (i (min n (length raw)))
-	  (setf (aref res i) (aref raw i)))))
-    (dolist (v slot-descriptions)
-      (setq i (boot-slot-offset v))
-      (let ((type (boot-slot-type v)))
-	(cond ((<= (the fixnum (alignment type)) #. (alignment t))
-	       (setf (aref res i) (aet-type type))))))
-    (cond ((< n (length *all-t-s-type*))
-	   (dotimes (i n)
-	     (cond ((not (eql (the fixnum (aref res i)) 0))
-		    (return-from make-t-type res))))
-	   *all-t-s-type*)
-	  (t res))))
-
-@s]
-
-
-****Change:(orig (356 356 a))
-@s[
-
-@s|
-(defvar *standard-slot-positions*
-  (let ((ar (make-array 50 :element-type 'unsigned-short
-		        :static t))) 
-    (dotimes (i 50)
-	     (declare (fixnum i))
-	     (setf (aref ar i)(* #. (size-of t) i)))
-    ar))
-
-(eval-when (compile )
-(proclaim '(function round-up (fixnum fixnum ) fixnum))
-)
-
-(defun round-up (a b)
-  (declare (fixnum a b))
-  (setq a (ceiling a b))
-  (the fixnum (* a b)))
-
-
-(defun get-slot-pos (leng include slot-descriptions &aux type small-types
-		          has-holes) 
-  (declare (special *standard-slot-positions*)) include
-  (dolist (v slot-descriptions)
-    (when (boot-slot-name v)
-      (setf type (best-array-element-type (boot-slot-type v))
-	    (boot-slot-type v) type)
-      (let ((val (boot-slot-default-init v)))
-	(unless (typep val type)
-	  (if (and (symbolp val)
-		   (constantp val))
-	      (setf val (symbol-value val)))
-	  (and (constantp val)
-	       (setf (boot-slot-default-init v) (coerce val type)))))
-      (cond ((memq type '(signed-char unsigned-char
-		          short unsigned-short
-		          long-float
-		          bit))
-	     (setq small-types t)))))
-  (cond ((and (null small-types)
-	      (< leng (length *standard-slot-positions*))
-	      (list  *standard-slot-positions* (* leng #. (size-of t)) nil)))
-	(t (let ((ar (make-array leng :element-type 'unsigned-short
-		                 :static t))
-		 (pos 0)(i 0)(align 0)type (next-pos 0))
-	     (declare (fixnum pos i align next-pos))
-	     ;; A default array.
-		   
-	     (dolist (v slot-descriptions)
-	       (setq type (boot-slot-type v))
-	       (setq align (alignment type))
-	       (unless (<= align #. (alignment t))
-		 (setq type t)
-		 (setf (boot-slot-type v) t)
-		 (setq align #. (alignment t))
-		 (setf (boot-slot-type-changed v) t))
-	       (setq next-pos (round-up pos align))      
-	       (or (eql pos next-pos) (setq has-holes t))
-	       (setq pos next-pos)
-	       (setf (aref ar i) pos)
-	       (incf pos (size-of type))
-	       (incf i))
-	     (list ar (round-up pos (size-of t)) has-holes)
-	     ))))
-
-
-(defun define-structure (name conc-name type named slot-descriptions copier
-		              static include print-function constructors
-		              offset predicate &optional documentation no-funs
-		              &aux leng)
-  (and (consp type) (eq (car type) 'vector)(setq type 'vector))
-  (setq leng (length slot-descriptions))
-  (setq slot-descriptions 
-	(mapcar #'(lambda (info)
-		    (make-slot-boot :name (first info)
-		                    :default-init (second info)
-		                    :type (third info)
-		                    :read-only (fourth info)
-		                    :offset (fifth info)
-		                    :accessor-name (sixth info)
-		                    :type-changed (seventh info)))
-		slot-descriptions))
-  (dolist (x slot-descriptions)
-    (when (boot-slot-name x)
-      (make-access-function name conc-name type named include no-funs x)))
-  (when (and copier (not no-funs))
-    (setf (symbol-function copier)
-	  (ecase type
-	    ((nil) #'si::copy-structure)
-	    (list #'copy-list)
-	    (vector #'copy-seq))))
-  (let ((include-str (and include (get include 's-data))))
-    (when (and (eq include 's-data-internal)
-	       (not (eq name 'basic-wrapper)))
-      (error "only ~s can include ~s" 'basic-wrapper 's-data-internal))
-    (when include-str
-      (cond ((and (not (consp include-str))
-		  (s-data-frozen include-str)
-		  (or (not (s-data-included include-str))
-		      (not (let ((te (get name 's-data)))
-		             (and te
-		                  (eq (s-data-includes te)
-		                      include-str))))))
-	     (warn " ~a was frozen but now included"
-		   include)))
-      (let ((old-included (boot-slot-value include-str 'included)))
-	(unless (member name old-included)
-	  (boot-set-slot-value include-str 'included (cons name old-included)))))
-    (let* ((tem (get name 's-data))
-	   (g-s-p (and (null type)
-		       (get-slot-pos leng include slot-descriptions)))
-	   (slot-position (car g-s-p))
-	   (size (if g-s-p (cadr g-s-p) 0))
-	   (has-holes (caddr g-s-p))
-	   (def (make-s-data-boot :name name
-		                  :length leng
-		                  :raw
-		                  (and (null type)
-		                       (make-t-type leng include 
-		                                    slot-descriptions))
-		                  :slot-position slot-position
-		                  :size size
-		                  :has-holes has-holes
-		                  :staticp static
-		                  :includes include-str
-		                  :print-function print-function
-		                  :slot-descriptions slot-descriptions
-		                  :constructors constructors
-		                  :offset offset
-		                  :type type
-		                  :named named
-		                  :documentation documentation
-		                  :conc-name conc-name)))
-      (check-s-data tem def name)
-      (when (and (consp def) (eq name 's-data))
-	(make-structures def))))
-  (when documentation
-    (setf (get name 'structure-documentation)
-	  documentation))
-  (when (and  (null type)  predicate)
-    (record-fn predicate 'defun '(t) t)
-    (or no-funs
-	(setf (symbol-function predicate)
-	      #'(lambda (x)
-		  (si::structure-subtype-p x name))))
-    (setf (get predicate 'compiler::co1)
-	  'compiler::co1structure-predicate)
-    (setf (get predicate 'struct-predicate) name))
-  nil)
-
-(defun check-s-data (old new name)
-  (unless (and old (member name '(slot s-data-internal basic-wrapper s-data)))
-    (when (and old (eq (structure-def old) (get 's-data 's-data)))
-      (boot-set-slot-value new 'included (boot-slot-value old 'included))
-      (boot-set-slot-value new 'frozen (boot-slot-value old 'frozen)))
-    (unless (and old
-		 (eq (structure-def old) (get 's-data 's-data))
-		 (let ((new-cnv (boot-slot-value new 'cache-number-vector))
-		       (old-cnv (boot-slot-value old 'cache-number-vector)))
-		   (boot-set-slot-value new 'cache-number-vector old-cnv)
-		   (prog1 (equalp new old)
-		     (boot-set-slot-value new 'cache-number-vector new-cnv))))
-      (when old
-	(warn "structure ~a is changing" name)
-	(when (eq (structure-def old) (get 's-data 's-data))
-	  (boot-set-slot-value old 'state (list ':obsolete new))))
-      (setf (get name 's-data) new))))
-
-
-@s]
-
-
-****Change:(orig (364 364 c))
-@s[        predicate predicate-specified
-        include
-
-@s|        predicate predicate-specified
-        include include-s-data
-
-@s]
-
-
-****Change:(orig (367 367 c))
-@s[        offset name-offset
-        documentation)
-
-@s|        offset name-offset
-        documentation
-	static)
-
-@s]
-
-
-****Change:(orig (370 370 c))
-@s[          ;; The defstruct options are supplied.
-
-@s|         ;; The defstruct options are supplied.
-
-@s]
-
-
-****Change:(orig (390 425 c))
-@s[      (cond ((and (consp (car os)) (not (endp (cdar os))))
-             (setq o (caar os) v (cadar os))
-             (case o
-               (:conc-name
-
-@s,               (t (error "~S is an illegal defstruct option." o))))))
-
-@s|       (cond ((and (consp (car os)) (not (endp (cdar os))))
-	       (setq o (caar os) v (cadar os))
-	       (case o
-		 (:conc-name
-		   (if (null v)
-		       (setq conc-name "")
-		     (setq conc-name v)))
-		 (:constructor
-		   (if (null v)
-		       (setq no-constructor t)
-		     (if (endp (cddar os))
-		         (setq constructors (cons v constructors))
-		       (setq constructors (cons (cdar os) constructors)))))
-		 (:copier (setq copier v))
-		 (:static (setq static v))
-		 (:predicate
-		   (setq predicate v)
-		   (setq predicate-specified t))
-		 (:include
-		   (setq include (cdar os))
-		   (unless (setq include-s-data (get v 's-data))
-		           (error "~S is an illegal included structure." v)))
-		 (:print-function
-		  (and (consp v) (eq (car v) 'function)
-		       (setq v (second v)))
-		  (setq print-function v))
-		 (:type (setq type v))
-		 (:initial-offset (setq initial-offset v))
-		 (t (error "~S is an illegal defstruct option." o))))
-	      (t
-		(if (consp (car os))
-		    (setq o (caar os))
-		  (setq o (car os)))
-		(case o
-		  (:constructor
-		    (setq constructors
-		          (cons default-constructor constructors)))
-		  ((:conc-name :copier :predicate :print-function))
-		  (:named (setq named t))
-		  (t (error "~S is an illegal defstruct option." o))))))
-
-@s]
-
-
-****Change:(orig (426 426 a))
-@s[
-
-@s|
-    (setq conc-name (intern (string conc-name)))
-
-    (and include-s-data (not print-function)
-	 (setq print-function (boot-s-data-print-function include-s-data)))
-
-
-@s]
-
-
-****Change:(orig (434 435 c))
-@s[    (when include
-          (unless (equal type (get (car include) 'structure-type))
-
-@s|    (when include-s-data
-          (unless (equal type (boot-s-data-type include-s-data))
-
-@s]
-
-
-****Change:(orig (442 443 c))
-@s[          (t
-           (setq offset (get (car include) 'structure-offset))))
-
-@s|          (t 
-	    (setq offset (boot-s-data-offset include-s-data))))
-
-@s]
-
-
-****Change:(orig (457 458 c))
-@s[      (setq sds (cons (parse-slot-description (car ds) offset) sds))
-      (setq offset (1+ offset)))
-
-@s|       (setq sds (cons (parse-slot-description (car ds) offset) sds))
-	(setq offset (1+ offset)))
-
-@s]
-
-
-****Change:(orig (464 464 c))
-@s[                (cons (list nil name) slot-descriptions)))
-
-@s|                (cons (make-slot :default-init name) slot-descriptions)))
-
-@s]
-
-
-****Change:(orig (469 469 c))
-@s[                (append (make-list initial-offset) slot-descriptions)))
-
-@s|                (append (mapcar #'make-named-slot (make-list initial-offset))
-		        slot-descriptions)))
-
-@s]
-
-
-****Change:(orig (473 486 c))
-@s[    (cond ((null include))
-          ((endp (cdr include))
-           (setq slot-descriptions
-                 (append (get (car include) 'structure-slot-descriptions)
-
-@s,                         slot-descriptions))))
-
-@s|    (let ((include-slot-descriptions 
-	   (and include
-		(boot-s-data-slot-descriptions include-s-data))))
-      (cond ((null include))
-	    ((endp (cdr include))
-	     (setq slot-descriptions
-		   (append include-slot-descriptions
-		           slot-descriptions)))
-	    (t
-	     (setq slot-descriptions
-		   (append (overwrite-slot-descriptions
-		            (mapcar #'(lambda (sd)
-		                        (parse-slot-description sd 0))
-		                    (cdr include))
-		            include-slot-descriptions)
-		           slot-descriptions)))))
-
-@s]
-
-
-****Change:(orig (489 492 c))
-@s[           ;; If a constructor option is NIL,
-           ;;  no constructor should have been specified.
-           (when constructors
-                 (error "Contradictory constructor options.")))
-
-@s|           ;; If a constructor option is NIL,
-	    ;;  no constructor should have been specified.
-	    (when constructors
-		  (error "Contradictory constructor options.")))
-
-@s]
-
-
-****Change:(orig (494 495 c))
-@s[           ;; If no constructor is specified,
-           ;;  the default-constructor is made.
-
-@s|          ;; If no constructor is specified,
-	   ;;  the default-constructor is made.
-
-@s]
-
-
-****Change:(orig (497 497 a))
-@s[           (setq constructors (list default-constructor))))
-
-
-@s|           (setq constructors (list default-constructor))))
-
-    ;; We need a default constructor for the sharp-s-reader
-    (or (member t (mapcar 'symbolp  constructors))
-	(push (intern (string-concatenate "__si::" default-constructor))
-		      constructors))
-
-
-@s]
-
-
-****Change:(orig (509 509 c))
-@s[          (error "An print function is supplied to a typed structure."))
-
-@s|          (error "A print function is supplied to a typed structure."))
-    
-    `(progn
-       (define-structure ',name  ',conc-name ',type ',named
-		         ',(mapcar #'(lambda (slotd)
-		                       (list (boot-slot-name slotd)
-		                             (boot-slot-default-init slotd)
-		                             (boot-slot-type slotd)
-		                             (boot-slot-read-only slotd)
-		                             (boot-slot-offset slotd)
-		                             (boot-slot-accessor-name slotd)
-		                             (boot-slot-type-changed slotd)))
-		                   slot-descriptions)
-		         ',copier ',static ',include ',print-function ',constructors 
-		         ',offset ',predicate ',documentation)
-
-@s]
-
-
-****Change:(orig (511 542 c))
-@s[    `(progn (si:putprop ',name
-                        '(defstruct ,name ,@slots)
-                        'defstruct-form)
-            (si:putprop ',name t 'is-a-structure)
-
-@s,            (si:putprop ',name ,documentation 'structure-documentation)
-            ',name)))
-
-@s|       ,@(mapcar #'(lambda (constructor)
-		     (make-constructor name constructor type named
-		                       slot-descriptions))
-		 constructors)
-       ,@(if (and type predicate)
-	     (list (make-predicate name predicate type named
-		                   name-offset)))
-       ',name
-       )))
-
-@s]
-
-
-****Change:(orig (544 544 a))
-@s[
-
-
-@s|
-
-(eval-when (compile load eval)
-
-(defconstant wrapper-cache-number-adds-ok 4)
-
-(defconstant wrapper-cache-number-length
-	     (- (integer-length most-positive-fixnum)
-		wrapper-cache-number-adds-ok))
-
-(defconstant wrapper-cache-number-mask
-	     (1- (expt 2 wrapper-cache-number-length)))
-
-
-(defvar *get-wrapper-cache-number* (make-random-state))
-
-(defun get-wrapper-cache-number ()
-  (let ((n 0))
-    (declare (fixnum n))
-    (loop
-      (setq n
-	    (logand wrapper-cache-number-mask
-		    (random most-positive-fixnum *get-wrapper-cache-number*)))
-      (unless (zerop n) (return n)))))
-
-)
-
-(eval-when (compile load eval)
-
-(defconstant wrapper-cache-number-vector-length 8)
-
-(deftype cache-number-vector ()
-  `(simple-array fixnum (8)))
-
-(defconstant wrapper-layout (make-list wrapper-cache-number-vector-length
-		                       :initial-element 'number))
-
-)
-
-(defun make-wrapper-cache-number-vector ()
-  (let ((cnv (make-array #.wrapper-cache-number-vector-length
-		         :element-type 'fixnum)))
-    (dotimes (i #.wrapper-cache-number-vector-length)
-      (setf (aref cnv i) (get-wrapper-cache-number)))
-    cnv))
-
-(defstruct (slot
-	     (:static t)
-	     (:constructor make-slot)
-	     (:constructor make-named-slot (name)))
-  name
-  default-init
-  (type t)
-  read-only
-  offset
-  accessor-name
-  type-changed)
-
-;; All of the fields of s-data-internal must coincide with 
-;; the C structure s_data (see object.h).
-(defstruct (s-data-internal
-	     (:conc-name s-data-)
-	     (:constructor nil)
-	     (:static t))
-  ;; all of these slots are used by c code
-  name                    ; a symbol
-  (length 0 :type fixnum) ; length of slot-descriptions
-  raw                     ; a static array of unsigned-short (enum aelttype)
-  included                ; a list of the names of structures including this one
-  includes                ; nil or a s-data structure
-  staticp         ; t or nil
-  print-function  ; nil, a symbol, or a lambda expression
-  slot-descriptions       ; a list of slots
-  slot-position           ; a static array of unsigned-short
-  (size 0 :type fixnum) ; total size to allocate
-  has-holes)              ; t or nil
-
-(defstruct (basic-wrapper (:include s-data-internal)
-		          (:conc-name wrapper-)
-		          (:constructor nil)
-		          (:static t))
-  (cache-number-vector (make-wrapper-cache-number-vector))
-  (state t) ;  either t or a list (state-sym new-wrapper)
-  ;;           where state-sym is either :flush or :obsolete
-  (class nil))
-
-;(get name 'si::s-data) ;returns one of these:
-(defstruct (s-data (:include basic-wrapper)
-		   (:static t))
-  ;; these slots are used only from lisp
-  frozen          ; t or nil ; t means won't include this
-  documentation 
-  constructors            ; a list of either a symbol or a list symbol, arglist
-  offset          ; the total number of slots and placeholders
-  named                   ; t or nil
-  type                    ; one of: nil, list, or vector
-  conc-name)              ; an interned symbol
-
-#|| 
-(import '(si::wrapper-state si::wrapper-class si::basic-wrapper))
-
-(defstruct (wrapper (:include basic-wrapper)
-		    (:print-function print-wrapper)
-		    (:constructor make-wrapper-internal)
-		    (:predicate wrapper-p)
-		    (:conc-name wrapper-))
-  (class-slots nil :type list))
-
-(defun print-wrapper (instance stream depth)
-  (printing-random-thing (wrapper stream)
-    (format stream "Wrapper ~S" (wrapper-class wrapper))))
-||#
-
-(defun update-wrapper-state (old new same-p)
-  (unless (consp old)
-    (setf (wrapper-state old) 
-	  (list (if same-p ':flush ':obsolete) new))))
-
-(defun freeze-defstruct (name)
-  (let ((tem (and (symbolp name) (get name 's-data))))
-    (if tem (setf (s-data-frozen tem) t))))
-
-
-
-@s]
-
-
-****Change:(orig (551 553 c))
-@s[  (let ((l (read stream)))
-    (unless (get (car l) 'is-a-structure)
-            (error "~S is not a structure." (car l)))
-
-@s|  (let* ((l (prog1 (read stream t nil t)
-	      (if *read-suppress*
-		  (return-from sharp-s-reader nil))))
-	 (sd
-	   (or (get (car l) 's-data)
-	       
-	       (error "~S is not a structure." (car l)))))
-    
-
-@s]
-
-
-****Change:(orig (558 558 c))
-@s[         (do ((cs (get (car l) 'structure-constructors) (cdr cs)))
-
-@s|         (do ((cs (s-data-constructors sd) (cdr cs)))
-
-@s]
-
-
-****Change:(orig (571 571 d))
-@s[(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
-
-
-
-@s|(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
-
-
-@s]
-
-
-****Change:(orig (582 582 c))
-@s[(defstruct person name age sex)
-
-@s|(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
-		                                        sex)
-(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
-		                                        sex)
-(defstruct person1 name (age 20 :type fixnum)
-		                                        sex)
-
-@s]
-
-
-****Change:(orig (584 584 c))
-@s[(defstruct (astronaut (:include person (age 45))
-
-@s|(defstruct joe a (a1 0 :type (mod  30)) (a2 0 :type (mod  30))
-  (a3 0 :type (mod  30)) (a4 0 :type (mod 30)) )
-
-;(defstruct person name age sex)
-
-(defstruct (astronaut (:include person (age 45 :type fixnum))
-
-@s]
-
-
-****Change:(orig (605 605 a))
-@s[  associative
-  identity)
-
-@s|  associative
-  identity)
-
-
-@s]
-
-==============================================================================
diff --git a/pcl/notes.text b/pcl/notes.text
deleted file mode 100644
index fef7419e721c4715d538af336b51a93ffd8284b5..0000000000000000000000000000000000000000
--- a/pcl/notes.text
+++ /dev/null
@@ -1,280 +0,0 @@
-These notes correspond to the "August 5 92 PCL" version of PCL.
-
-  This version of PCL is much closer than previous versions of PCL
-to the metaobject protocol specified in "The Art of the Metaobject Protocol", 
-chapters 5 and 6, by Gregor Kiczales, Jim des Riveres, and Daniel G. Bobrow.
-
-
-[Please read the file may-day-notes.text also.  Most of that file still applies.]
-
-Support for structures
-  You can use structure-class as a metaclass to create new classes.
-  Classes created this way create and evaluate defstruct forms which
-  have generated symbols for the structure accessors and constructor.
-  The generated symbols are used by the primary slot-value-using-class
-  methods and by the primary allocate-instance method for structures.
-  Defmethod optimizes usages of slot-value (when no user-defined 
-  slot-value-using-class methods exist) into direct calls of the
-  generated symbol accessor, which the compiler can then optimize further.
-  Even when there are user-defined methods on slot-value-using-class,
-  PCL does a variety of optimizations.
-  
-  If your implementation's version of the *-low.lisp file
-  contains definitions of certain structure functions (see the end of
-  low.lisp, cmu-low.lisp, lucid-low.lisp, and kcl-low.lisp), then
-  structure classes are supported for all defstructs.  In this case,
-  structure classes are created automatically, when necessary.
-
-New Classes:
-structure-class
-structure-object
-slot-class
-slot-object
-structure-direct-slot-definition
-structure-effective-slot-definition
-
-Improvements to slot-access
-  Optimization for slot-value outsize of defmethod
-  Optimization for slot-value inside of defmethod, but not of a specialized parameter.
-  Optimizations that work even when there are :around methods
-  on slot-value-using-class.
-
-New types: 
-   `(class ,class-object)
-   `(class-eq ,class-object)
-
-New specializer class: class-eq-specializer
-  Every class has a class-eq specializer which represents all
-  the direct instances of that class.
-  This is useful in *subtypep.  For example, here is the way 
-  generic-function initialization checks that the method-class is valid:
-   (and (classp method-class)
-	(*subtypep (class-eq-specializer method-class)
-		   (find-class 'standard-method)))
-  If you want to define methods having class-eq specializers,
-  see "Initialization of method metaobjects".  The default behavior of PCL
-  is to disallow this.
-
-compute-applicable-methods-using-types
-
-caching improvements
-
-no magic-generic-functions list
-  This simplifies some things, but complicates some other things.
-  I wanted to support user-defined classes which are their own metaclass.
-  You can now do:
-(defclass y (standard-class) ())
-(defmethod validate-superclass ((c y) (sc standard-class)) t)
-(defclass y (standard-class) () (:metaclass y))
-
-method-function changes (see the comments for make-method-lambda, below)
-
-final dfuns
-
--------------------------
-
-gfs which obey AMOP ch 6
-  accessor-method-slot-definition
-  add-dependent
-  add-direct-method
-  add-direct-subclass
-  add-method
-  allocate-instance
-  compute-class-precedence-list
-  compute-default-initargs
-  compute-discriminating-function  
-  compute-effective-slot-definition
-[Note: compute-effective-slot-definition relys on 
- compute-effective-slot-definition-initargs and effective-slot-definition-class.
- compute-effective-slot-definition-initargs is quite useful, but is not in
- AMOP ch 6.]
-  compute-slots
-  direct-slot-definition-class
-  effective-slot-definition-class
-  ensure-class
-  ensure-class-using-class
-  ensure-generic-function
-  ensure-generic-function-using-class
-  eql-specializer-object
-  extract-lambda-list
-  extract-specializer-names
-  finalize-inheritance
-  find-method-combination
-  funcallable-standard-instance-access
-  {generic-function-method-class, generic-function-method-combination,
-   generic-function-lambda-list, generic-function-methods, generic-function-name}
-  intern-eql-specializer
-  make-instance
-  make-method-lambda
-  map-dependents
-  {method-function, method-generic-function, method-lambda-list,
-   method-specializers, method-qualifiers}
-  {class-default-initargs, class-direct-default-initargs, class-direct-slots,
-   class-direct-subclasses, class-direct-superclasses, class-finalized-p,
-   class-name, class-precedence-list, class-prototype, class-slots}
-  {slot-definition-allocation, slot-definition-initargs, slot-definition-initform,
-   slot-definition-initfunction, slot-definition-name, slot-definition-type}
-  {slot-definition-readers, slot-definition-writers}
-  {slot-definition-location}
-  remove-dependent
-  remove-direct-method
-  remove-direct-subclass
-  remove-method
-  set-funcallable-instance-function
-  (setf slot-value-using-class)
-  slot-boundp-using-class
-  slot-makunbound-using-class
-  specializer-direct-generic-functions
-  specializer-direct-methods
-  standard-instance-access
-  update-dependent
-
-gfs which DO NOT obey AMOP ch 6
-
-compute-applicable-methods
-compute-applicable-methods-using-classes
-  Handles class-eq specializers without signalling an error.  
-  But see "Initialization of method metaobjects", below.
-
-compute-effective-method
-  Returns only one value. 
-
-generic-function-argument-precedence-order
-  Not yet defined.  Can get this information from the arg-info structure.
-
-generic-function-declarations
-  Not yet defined.
-
-reader-method-class
-  Not yet defined.  Some bootstrapping considerations are involved, 
-  but adding this will not be very hard.
-
-(setf class-name)
-  Currently just a writer method.  Does not call reinitialize-instance or
-  (setf find-class).
-
-(setf generic-function-name)
-  Currently just a writer method.  Does not call reinitialize-instance.
-
-writer-method-class
-  Not yet defined.  Some bootstrapping considerations are involved, 
-  but adding this will not be very hard.
-
----------------------------
-
-Initialization of method metaobjects
-  The following methods are defined:
-    legal-qualifiers-p (method standard-method) qualifiers
-    legal-lambda-list-p (method standard-method) lambda-list
-    legal-specializers-p (method standard-method) specializers
-    legal-method-function-p (method standard-method) function
-    legal-documentation-p (method standard-method) documentation
-
-    legal-specializer-p (method standard-method) specializer
-
-  You can override them if you want.
-  The method for legal-specializers-p calls legal-specializer-p
-  on each specializer.
-  The method for legal-specializer-p allows any kind of specializer
-  when the variable *allow-experimental-specializers-p* is t
-  (this variable is initially nil).
-
----------------------------
-Optimizations on slot-value
-  Outside of a defmethod when define-compiler-macro is not implemented
-  or the slot-name is not constant, or
-  Inside a defmethod when the slot-name is not a constant:
-(1)   no optimization of slot-value, slot-value-using-class is called.
-      slot-value-using-class has a special dfun, though, which calls
-      the slot's slot-definition-reader-function.  This function is
-      a result of get-accessor-method-function.
-  Outside of a defmethod when define-compiler-macro is implemented and
-  the slot-name is a constant, or
-  Inside a defmethod when the slot-name is a constant but the object is 
-  not either (the value of a parameter specialized to a subclass of structure-object
-  for which no user-defined slot-value-using-class methods apply at defmethod time), 
-  or (the value of a parameter specialized to a subclass of standard-object).
-(2)   PCL arranges to call an automatically created generic function
-      which has one method: a reader method defined on class slot-object.
-  Inside a defmethod when the slot-name is a constant and the object 
-  is (the value of a parameter specialized to a subclass of structure-object
-  for which no user-defined slot-value-using-class methods apply).
-(3)   The slot-value form is converted to a call of the structure slot's 
-      accessor function, which the compiler can then optimize further.
-  Inside a defmethod when the slot-name is a constant and the object 
-  is (the value of a parameter specialized to a subclass of standard-object).
-(4)   The access requires two arefs, a call to (typep x 'fixnum), and a call to eq,
-      in the best case.  If user defined slot-value-using-class methods apply
-      at slot-value execution time, or the slot is unbound, the unoptimized 
-      slot-value function (1) is called.  This was in May Day PCL; what is new here
-      is that the PV (permutation vector) is looked up at defmethod load time
-      rather than at run time, if the effective method is cached.
-
-Generic functions containing only accessor methods for which no user-defined
-methods on slot-value-using-class apply and which involve only standard-classes:
-      A special dfun is called: one-class, two-class, one-index, or n-n.
-      These were all in May Day PCL.
-Generic functions excluded by the above, which contain accessor methods:
-      In place of each accessor method's method-function, a function returned by
-      get-accessor-method-function is used.
-
-get-accessor-method-function (gf type class slotd) ; type is reader, writer, or boundp.
-  If there is only one applicable method,
-      (This method will be the system supplied one)
-      the function that is returned is optimized for the current state of the
-      class.  When the class changes, it must be recomputed.
-  otherwise,
-      a secondary dispatch function for slot-value-using-class is computed
-      (using what is known about the types of the arguments) and converted 
-      into an accessor function.
-
-get-secondary-dispatch-function (gf methods types &optional method-alist wrappers)
-  The types argument describes what is known about the types of the arguments.
-  Method-alist is used (when supplied) to do things like replace the
-  standard slot-value-using-class method function with a function optimized
-  for what is known about the arguments.
-  Wrappers (when supplied) means that the resulting function is guaranteed to
-  be called only whith those wrappers.  Make-effective-method-function calls
-  the generic-function method-function-for-caching with method-alist and
-  wrappers to get a optimized method function.  (PV lookup is done at the time
-  method-function-for-caching is called).
-
-compute-applicable-methods:  Here I tried to stick with the MOP.
-  The function cache-miss-values looks at the second value of the result of 
-  compute-applicable-methods-using-classes.  If this value is null, we aren't 
-  supposed to cache the result of camuc.  So we don't.  Instead we cache a 
-  result of (default-secondary-dispatch-function gf), which in turn calls 
-  compute-applicable-methods each time it is called.
----------------------------
-
-To do:
-
-Problem: sometimes there is no need to call a gf's dfun: the emf that is invoked
-         can be cached in the caller's method closure.
-1.  In expand-defmethod-internal, optimize calls to generic-functions.
-  Add the support for this optimization.
-
-2.   [When CMUCL improves its setf handling, remove the comment in
-   the file macros.lisp beginning the line ";#+cmu (pushnew :setf *features*)"]
-
-
-
---------------
-1) Generalize expand-defmethod-internal so that it can be used for non-defmethod
-code.  Maybe by (a) having a parameter that says whether it is being called by 
-defmethod, and (b) using the techniques used by the series package (shadowing 
-defun and some others, making the shadowed definitions call e-d-i, making it 
-easy for people to do the relevant package modifications)
-
-2) Extending generic-functions by allowing the user at defgeneric time to supply
-the name of a function which will be supplied (by the system) with a definition
-which will return equivalent results to those returned by the generic function,
-but which will (in some cases) have less checking than the generic function.
-One-class, two-class, and one-index gf dfuns will map to a result of 
-get-optimized-std-accessor-method-function, checking gf dfuns will map to their
-function, and any other dfun will remain the same.
-
-3) Extending expand-defmethod-internal to optimize calls to generic-functions.
-There are a variety of possibilities that need to be considered; one of them
-will be to arrange to call the optimized functions produced by (2) when it
-is known to be safe.  
diff --git a/pcl/pcl-env-internal.lisp b/pcl/pcl-env-internal.lisp
deleted file mode 100644
index 86b947bff006d5701fad6296f9f789c8f5ed9d64..0000000000000000000000000000000000000000
--- a/pcl/pcl-env-internal.lisp
+++ /dev/null
@@ -1,261 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL")
-(il:filecreated "28-Aug-87 18:42:36" il:{phylum}<pcl>pcl-env-internal.\;1 8356   
-
-      il:|changes| il:|to:|  (il:vars il:pcl-env-internalcoms)
-                             (il:props (il:pcl-env-internal il:makefile-environment))
-                             (il:functions stack-eql stack-pointer-frame stack-frame-valid-p 
-                                    stack-frame-fn-header stack-frame-pc fnheader-debugging-info 
-                                    stack-frame-name compiled-closure-fnheader compiled-closure-env)
-)
-
-
-; Copyright (c) 1987 by Xerox Corporation.  All rights reserved.
-
-(il:prettycomprint il:pcl-env-internalcoms)
-
-(il:rpaqq il:pcl-env-internalcoms (
-
-(il:* il:|;;;| "***************************************")
-
-                                   
-
-(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation.  All rights reserved.")
-
-                                   
-
-(il:* il:|;;;| "")
-
-                                   
-
-(il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws.")
-
-                                   
-
-(il:* il:|;;;| " ")
-
-                                   
-
-(il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no  warranty about the software, its performance or its conformity to any  specification.")
-
-                                   
-
-(il:* il:|;;;| " ")
-
-                                   
-
-(il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:")
-
-                                   
-
-(il:* il:|;;;| "   CommonLoops Coordinator")
-
-                                   
-
-(il:* il:|;;;| "   Xerox Artifical Intelligence Systems")
-
-                                   
-
-(il:* il:|;;;| "   2400 Hanover St.")
-
-                                   
-
-(il:* il:|;;;| "   Palo Alto, CA 94303")
-
-                                   
-
-(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
-
-                                   
-
-(il:* il:|;;;| "")
-
-                                   
-
-(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
-
-                                   
-
-(il:* il:|;;;| " *************************************************************************")
-
-                                   
-
-(il:* il:|;;;| "")
-
-                                   (il:declare\: il:dontcopy (il:prop il:makefile-environment 
-                                                                    il:pcl-env-internal))
-                                                             (il:* il:\; 
-                                                             "We're off to hack the system...")
-
-                                   (il:declare\: il:eval@compile il:dontcopy (il:files pcl::abc)
-                                          
-          
-          (il:* il:|;;| "The Deltas and The East and The Freeze")
-)
-                                   (il:functions stack-eql stack-pointer-frame stack-frame-valid-p 
-                                          stack-frame-fn-header stack-frame-pc 
-                                          fnheader-debugging-info stack-frame-name 
-                                          compiled-closure-fnheader compiled-closure-env)))
-
-
-
-(il:* il:|;;;| "***************************************")
-
-
-
-
-(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation.  All rights reserved.")
-
-
-
-
-(il:* il:|;;;| "")
-
-
-
-
-(il:* il:|;;;| 
-"Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws."
-)
-
-
-
-
-(il:* il:|;;;| " ")
-
-
-
-
-(il:* il:|;;;| 
-"This software is made available AS IS, and Xerox Corporation makes no  warranty about the software, its performance or its conformity to any  specification."
-)
-
-
-
-
-(il:* il:|;;;| " ")
-
-
-
-
-(il:* il:|;;;| 
-"Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:"
-)
-
-
-
-
-(il:* il:|;;;| "   CommonLoops Coordinator")
-
-
-
-
-(il:* il:|;;;| "   Xerox Artifical Intelligence Systems")
-
-
-
-
-(il:* il:|;;;| "   2400 Hanover St.")
-
-
-
-
-(il:* il:|;;;| "   Palo Alto, CA 94303")
-
-
-
-
-(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
-
-
-
-
-(il:* il:|;;;| "")
-
-
-
-
-(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
-
-
-
-
-(il:* il:|;;;| " *************************************************************************")
-
-
-
-
-(il:* il:|;;;| "")
-
-(il:declare\: il:dontcopy 
-
-(il:putprops il:pcl-env-internal il:makefile-environment (:package "XCL" :readtable "XCL"))
-)
-
-
-
-(il:* il:\; "We're off to hack the system...")
-
-(il:declare\: il:eval@compile il:dontcopy 
-(il:filesload pcl::abc)
-)
-
-(defun stack-eql (x y) "Test two stack pointers for equality" (and (il:stackp x)
-                                                                   (il:stackp y)
-                                                                   (eql (il:fetch (il:stackp il:edfxp
-                                                                                         )
-                                                                           il:of x)
-                                                                        (il:fetch (il:stackp il:edfxp
-                                                                                         )
-                                                                           il:of y))))
-
-
-(defun stack-pointer-frame (stack-pointer) (il:|fetch| (il:stackp il:edfxp) il:|of| stack-pointer))
-
-
-(defun stack-frame-valid-p (frame) (not (il:|fetch| (il:fx il:invalidp) il:|of| frame)))
-
-
-(defun stack-frame-fn-header (frame) (il:|fetch| (il:fx il:fnheader) il:|of| frame))
-
-
-(defun stack-frame-pc (frame) (il:|fetch| (il:fx il:pc) il:|of| frame))
-
-
-(defun fnheader-debugging-info (fnheader) (let* ((start-pc (il:fetch (il:fnheader il:startpc)
-                                                              il:of fnheader))
-                                                 (name-table-words
-                                                  (let ((size (il:fetch (il:fnheader il:ntsize)
-                                                                 il:of fnheader)))
-                                                       (if (zerop size)
-                                                           il:wordsperquad
-                                                           (* size 2))))
-                                                 (past-name-table-in-words (+ (il:fetch (il:fnheader
-                                                                                         
-                                                                                     il:overheadwords
-                                                                                         )
-                                                                                 il:of fnheader)
-                                                                              name-table-words)))
-                                                (and (= (- start-pc (* il:bytesperword 
-                                                                       past-name-table-in-words))
-                                                        il:bytespercell)
-          
-          (il:* il:|;;| "It's got a debugging-info list.")
-
-                                                     (il:\\getbaseptr fnheader 
-                                                            past-name-table-in-words))))
-
-
-(defun stack-frame-name (frame) (il:|fetch| (il:fx il:framename) il:|of| frame))
-
-
-(defun compiled-closure-fnheader (closure) (il:|fetch| (il:compiled-closure il:fnheader) il:|of|
-                                                                                         closure))
-
-
-(defun compiled-closure-env (closure) (il:fetch (il:compiled-closure il:environment) il:of closure))
-
-(il:putprops il:pcl-env-internal il:copyright ("Xerox Corporation" 1987))
-(il:declare\: il:dontcopy
-  (il:filemap (nil)))
-il:stop
-
diff --git a/pcl/pcl-env.lisp b/pcl/pcl-env.lisp
deleted file mode 100644
index 7bf4b476e0ab0cf40c8d8f1967e524542b669ad7..0000000000000000000000000000000000000000
--- a/pcl/pcl-env.lisp
+++ /dev/null
@@ -1,1629 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.com)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; Xerox-Lisp specific environment hacking for PCL
-
-(in-package "PCL")
-
-;; 
-;; Protect the Corporation
-;; 
-(eval-when (eval load)
-  (format *terminal-io*
-    "~&;PCL-ENV Copyright (c) 1987, 1988, 1989, by ~
-        Xerox Corporation.  All rights reserved.~%"))
-
-
-;;; Make funcallable instances (FINs) print by calling print-object.
-
-(eval-when (eval load)
-  (il:defprint 'il:compiled-closure 'il:print-closure))
-
-(defun il:print-closure (x &optional stream depth)
-  ;; See the IRM, section 25.3.3.  Unfortunatly, that documentation is
-  ;; not correct.  In particular, it makes no mention of the third argument.
-  (cond ((not (funcallable-instance-p x))
-	 ;; IL:\CCLOSURE.DEFPRINT is the orginal system function for
-	 ;; printing closures
-	 (il:\\cclosure.defprint x stream))
-	((streamp stream)
-	 ;; Use the standard PCL printing method, then return T to tell
-	 ;; the printer that we have done the printing ourselves.
-	 (print-object x stream)
-	 t)
-	(t 
-	 ;; Internal printing (again, see the IRM section 25.3.3). 
-	 ;; Return a list containing the string of characters that
-	 ;; would be printed, if the object were being printed for
-	 ;; real.
-	 (with-output-to-string (stream)
-	   (list (print-object x stream))))))
-
-
-;;; Naming methods
-
-(defun gf-named (gf-name)
-  (let ((spec (cond ((symbolp gf-name) gf-name)
-		    ((and (consp gf-name)
-			  (eq (first gf-name) 'setf)
-			  (symbolp (second gf-name))
-			  (null (cddr gf-name)))
-		     (get-setf-function-name (second gf-name)))
-		    (t nil))))
-    (if (and (fboundp spec)
-	     (generic-function-p (symbol-function spec)))
-	(symbol-function spec)
-	nil)))
-
-(defun generic-function-method-names (gf-name hasdefp)
-  (if hasdefp
-      (let ((names nil))
-        (maphash #'(lambda (key value)
-                     (declare (ignore value))
-                     (when (and (consp key) (eql (car key) gf-name))
-                       (pushnew key names)))
-                 (gethash 'methods xcl:*definition-hash-table*))
-        names)
-      (let ((gf (gf-named gf-name)))
-        (when gf
-          (mapcar #'full-method-name (generic-function-methods gf))))))
-
-(defun full-method-name (method)
-  "Return the full name of the method"
-  (let ((specializers (mapcar #'(lambda (x)
-		                  (cond ((eq x 't) t)
-		                        ((consp x) x)
-		                        (t (class-name x))))
-		       (method-type-specifiers method))))
-    ;; Now go through some hair to make sure that specializer is
-    ;; really right.  Once PCL returns the right value for
-    ;; specializers this can be taken out.
-    (let* ((arglist (method-arglist method))
-	   (number-required (or (position-if
-				  #'(lambda (x) (member x lambda-list-keywords))
-				  arglist)
-				(length arglist)))
-	   (diff (- number-required (length specializers))))
-      (when (> diff 0)
-	(setq specializers (nconc (copy-list specializers)
-				  (make-list diff :initial-element 't)))))
-    (make-full-method-name (generic-function-name
-			       (method-generic-function method))
-			   (method-qualifiers method)
-			   specializers)))
-
-(defun make-full-method-name (generic-function-name qualifiers arg-types)
-  "Return the full name of a method, given the generic-function name, the method
-qualifiers, and the arg-types"
-  ;; The name of the method is:
-  ;;      (<generic-function-name> <qualifier-1> .. 
-  ;;         (<arg-specializer-1>..))
-  (labels ((remove-trailing-ts (l)
-	     (if (null l)
-		 nil
-		 (let ((tail (remove-trailing-ts (cdr l))))
-		   (if (null tail)
-		       (if (eq (car l) 't)
-			   nil
-			   (list (car l)))
-		       (if (eq l tail)
-			   l
-			   (cons (car l) tail)))))))
-    `(,generic-function-name ,@qualifiers
-      ,(remove-trailing-ts arg-types))))
-
-(defun parse-full-method-name (method-name)
-  "Parse the method name, returning the gf-name, the qualifiers, and the
-arg-types."
-  (values (first method-name)
-	  (butlast (rest method-name))
-	  (car (last method-name))))
-
-(defun prompt-for-full-method-name (gf-name &optional has-def-p)
-  "Prompt the user for the full name of a method on the given generic function name"
-  (let ((method-names (generic-function-method-names gf-name has-def-p)))
-    (cond ((null method-names)
-	   nil)
-	  ((null (cdr method-names))
-	   (car method-names))
-	  (t (il:menu
-	      (il:create
-	       il:menu il:items il:_	;If HAS-DEF-P, include only
-					; those methods that have a
-					; symbolic def'n that we can
-					; find
-	       (remove-if #'null
-			  (mapcar #'(lambda (m)
-				      (if (or (not has-def-p)
-					      (il:hasdef m 'methods))
-					  `(,(with-output-to-string (s)
-					       (dolist (x m)
-						 (format s "~A " x))
-					       s)
-					    ',m)
-					  nil))
-				  method-names))
-	       il:title il:_ "Which method?"))))))
-
-
-;;; Converting generic defining macros into DEFDEFINER macros
-
-(defmacro make-defdefiner (definer-name definer-type type-description &body 
-					definer-options)
-  "Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE"
-  (let ((old-definer-macro-name (intern (string-append definer-name
-						       " old definition")
-					(symbol-package definer-name)))
-	(old-definer-macro-expander (intern (string-append definer-name 
-							   " old expander")
-					    (symbol-package definer-name))))
-    `(progn 
-      ;; First, move the current defining function off to some safe
-      ;; place
-      (unmake-defdefiner ',definer-name)
-      (cond ((not (fboundp ',definer-name))
-	     (error "~A has no definition!" ',definer-name))
-	    ((fboundp ',old-definer-macro-name))
-	    ((macro-function ',definer-name)
-					; We have to move the macro
-					; expansion function as well,
-					; so it won't get clobbered
-					; when the original macro is
-					; redefined.  See AR 7410.
-	     (let* ((expansion-function (macro-function ',definer-name)))
-	       (setf (symbol-function ',old-definer-macro-expander)
-		     (loop (if (symbolp expansion-function)
-			       (setq expansion-function
-				     (symbol-function expansion-function))
-			       (return expansion-function))))
-	       (setf (macro-function ',old-definer-macro-name)
-		     ',old-definer-macro-expander)
-	       (setf (get ',definer-name 'make-defdefiner) expansion-function)))
-	    (t (error "~A does not name a macro." ',definer-name)))
-      ;; Make sure the type is defined
-      (xcl:def-define-type ,definer-type ,type-description)
-      ;; Now redefine the definer, using DEFEDFINER and the original def'n
-      (xcl:defdefiner ,(if definer-options
-			   (cons definer-name definer-options)
-			   definer-name)
-	  ,definer-type	(&body b) `(,',old-definer-macro-name ,@,'b)))))
-
-(defun unmake-defdefiner (definer-name)
-  (let ((old-expander (get definer-name 'make-defdefiner)))
-    (when old-expander
-      (setf (macro-function definer-name old-expander))
-      (remprop definer-name 'make-defdefiner))))
-
-
-;;; For tricking ED into being able to use just the generic-function-name
-;;; instead of the full method name
-
-(defun source-manager-method-edit-fn (name type source editcoms options)
-  "Edit a method of the given name"
-  (let ((full-name (if (gf-named name)
-					;If given the name of a
-					; generic-function, try to get
-					; the full method name
-		       (prompt-for-full-method-name name t)
-					; Otherwise it should name the
-					; method
-		       name)))
-    (when (not (null full-name))
-      (il:default.editdef full-name type source editcoms options))
-    (or full-name name)))		;Return the name
-
-(defun source-manager-method-hasdef-fn (name type &optional source)
-  "Is there a method defined with the given name?"
-  (cond ((not (eq type 'methods)) nil)
-	((or (symbolp name)
-	     (and (consp name)
-		  (eq (first name) 'setf)
-		  (symbolp (second name))
-		  (null (cddr name))))
-	 ;; If passed in the name of a generic-function, pretend that
-	 ;; there is a method by that name if there is a generic function
-	 ;; by that name, and there is a method whose source we can find.
-	 (if (and (not (null (gf-named name)))
-		  (find-if #'(lambda (m)
-			       (il:hasdef m type source))
-			   (generic-function-method-names name t)))
-	     name
-	     nil))
-	((and (consp name) (>= (length name) 2))
-	 ;; Standard methods are named (gf-name {qualifiers}* ({specializers}*))
-	 (when (il:getdef name type source '(il:nocopy il:noerror))
-	   name))
-	(t
-	 ;; Nothing else can name a method
-	 nil)))
-
-;;; Initialize the PCL env
-
-(defun initialize-pcl-env nil
-  "Initialize the Xerox PCL environment" 
-  ;; Set up SourceManager DEFDEFINERS for classes and methods.
-  ;;
-  ;; Make sure to define methods before classes, so that (IL:FILES?) will build
-  ;; filecoms that have classes before methods. 
-  (unless (il:hasdef 'methods 'il:filepkgtype)
-    (make-defdefiner defmethod methods "methods"
-		     (:name (lambda (form)
-			      (multiple-value-bind (name qualifiers arglist)
-				  (parse-defmethod (cdr form))
-				(make-full-method-name name qualifiers
-				    (extract-specializer-names
-					arglist)))))
-		     (:undefiner
-		      (lambda (method-name)
-			(multiple-value-bind
-			      (name qualifiers arg-types)
-			    (parse-full-method-name method-name)
-			  (let* ((gf (gf-named name))
-				 (method (when gf
-					   (get-method gf qualifiers
-						       (mapcar #'find-class 
-							       arg-types)))))
-			    (when method (remove-method gf method))))))))
-  ;; Include support for DEFGENERIC, if that is defined
-  (unless (or (not (fboundp 'defgeneric))
-	      (il:hasdef 'generic-functions 'il:filepkgtype))
-    (make-defdefiner defgeneric generic-functions "generic-function definitions"))
-  ;; DEFCLASS FileManager stuff
-  (unless (il:hasdef 'classes 'il:filepkgtype)
-    (make-defdefiner defclass classes "class definitions"
-		     (:undefiner (lambda (name)
-				   (when (find-class name t)
-				     (setf (find-class name) nil)))))
-    ;; CLASSES "include" TYPES.
-    (il:filepkgcom 'classes 'il:contents
-		   #'(lambda (com name type &optional reason)
-		       (declare (ignore name reason))
-		       (if (member type '(il:types classes) :test #'eq)
-			   (cdr com)
-			   nil))))
-  ;; Set up the hooks so that ED can be handed the name of a generic function,
-  ;; and end up editing a method instead
-  (il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn
-		  'il:hasdef 'source-manager-method-hasdef-fn)
-  ;; Set up the inspect macro.  The right way to do this is to
-  ;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now...
-  (push '((il:function pcl-object-p) . \\internal-inspect-object)
-	il:inspectmacros)
-  ;; Unmark any SourceManager changes caused by this loadup
-  (dolist (com (il:filepkgchanges))
-    (dolist (name (cdr com))
-      (when (and (symbolp name)
-		 (eq (symbol-package name) (find-package "PCL")))
-	(il:unmarkaschanged name (car com))))))
-
-(eval-when (eval load)
-  (initialize-pcl-env))
-
-
-;;; Inspecting PCL objects
-
-(defun pcl-object-p (x)
-  "Is the datum a PCL object?"
-  (or (std-instance-p x)
-      (fsc-instance-p x)))
-
-(defun \\internal-inspect-object (x type where)
-  (inspect-object x type where))
-
-(defun \\internal-inspect-slot-names (x)
-  (inspect-slot-names x))
-
-(defun \\internal-inspect-slot-value (x slot-name)
-  (inspect-slot-value x slot-name))
-
-(defun \\internal-inspect-setf-slot-value (x slot-name value)
-  (inspect-setf-slot-value x slot-name value))
-
-(defun \\internal-inspect-slot-name-command (slot-name x window)
-  (inspect-slot-name-command slot-name x window))
-
-(defun \\internal-inspect-title (x y)
-  (inspect-title x y))
-
-(defmethod inspect-object (x type where)
-  "Open an insect window on the object x"
-  (il:inspectw.create x '\\internal-inspect-slot-names
-              '\\internal-inspect-slot-value
-              '\\internal-inspect-setf-slot-value
-              '\\internal-inspect-slot-name-command nil nil 
-              '\\internal-inspect-title nil where
-              #'(lambda (n v)		;Same effect as NIL, but avoids bug in
-		  (declare (ignore v))	; INSPECTW.CREATE
-		  n)))
-
-(defmethod inspect-slot-names (x)
-  "Return a list of names of slots of the object that should be shown in the
-inspector"
-  (mapcar #'(lambda (slotd) (slot-value slotd 'name))
-	  (slots-to-inspect (class-of x) x)))
-
-(defmethod inspect-slot-value (x slot-name)
-  (cond ((not (slot-exists-p x slot-name)) "** no such slot **")
-	((not (slot-boundp x slot-name)) "** slot not bound **")
-	(t (slot-value x slot-name))))
-
-(defmethod inspect-setf-slot-value (x slot-name value)
-  "Used by the inspector to set the value fo a slot"
-  ;; Make this UNDO-able
-  (il:undosave `(inspect-setf-slot-value ,x ,slot-name
-		 ,(slot-value x slot-name)))
-  ;; Then change the value
-  (setf (slot-value x slot-name) value))
-
-(defmethod inspect-slot-name-command (slot-name x window)
-  "Allows the user to select a menu item to change a slot value in an inspect
-window"
-  ;; This code is a very slightly hacked version of the system function
-  ;; DEFAULT.INSPECTW.PROPCOMMANDFN.  We have to do this because the
-  ;; standard version makes some nasty assumptions about
-  ;; structure-objects that are not true for PCL objects.
-  (declare (special il:|SetPropertyMenu|))
-  (case (il:menu (cond ((typep il:|SetPropertyMenu| 'il:menu)
-			il:|SetPropertyMenu|)
-		       (t (il:setq il:|SetPropertyMenu|
-				   (il:|create| il:menu il:items il:_
-				       '((set 'set 
-					  "Allows a new value to be entered"
-					  )))))))
-    (set 
-     ;; The user want to set the value
-     (il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name 
-								window))
-		       il:newvalue il:pwindow)
-		   (il:ttydisplaystream (il:setq il:pwindow
-						 (il:getpromptwindow window 3)))
-		   (il:clearbuf t t)
-		   (il:resetlst
-		    (il:resetsave (il:\\itemw.flipitem il:oldvalueitem window)
-				  (list 'il:\\itemw.flipitem 
-					il:oldvalueitem window))
-		    (il:resetsave (il:tty.process (il:this.process)))
-		    (il:resetsave (il:printlevel 4 3))
-		    (il:|printout| t "Enter the new " 
-			slot-name " for " x t 
-			"The expression read will be EVALuated."
-			t "> ")
-		    (il:setq il:newvalue (il:lispx (il:lispxread t t)
-						   '>))
-					; clear tty buffer because it
-					; sometimes has stuff left.
-		    (il:clearbuf t t))
-		   (il:closew il:pwindow)
-		   (return (il:inspectw.replace window slot-name il:newvalue)))))))
-
-(defmethod inspect-title (x window)
-  "Return the title to use in an inspect window viewing x"
-  (format nil "Inspecting a ~A" (class-name (class-of x))))
-
-(defmethod inspect-title ((x standard-class) window)
-  (format nil "Inspecting the class ~A" (class-name x)))
-
-
-;;;  Debugger support for PCL
-
-
-(il:filesload pcl-env-internal)
-
-;; Non-PCL specific changes to the debugger
-
-;; Redefining the standard INTERESTING-FRAME-P function.  Now functions can be
-;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP
-;; property.
-
-(dolist (fn '(si::*unwind-protect* il:*env*
-	      evalhook xcl::nohook xcl::undohook
-	      xcl::execa0001 xcl::execa0001a0002
-	      xcl::|interpret-UNDOABLY|
-	      cl::|interpret-IF| cl::|interpret-FLET|
-	      cl::|interpret-LET| cl::|interpret-LETA0001|
-	      cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001|
-	      il:do-event il:eval-input
-	      apply t))
-  (setf (get fn 'xcl::uninterestingp) t))
-
-(defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg)
-  "Return TRUE iff the frame should be visible for a short backtrace."
-  (declare (special il:openfns))
-  (let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos)))
-    (typecase xcl::name
-      (symbol (case xcl::name
-		(il:*env*
-		 ;; *ENV* is used by ENVEVAL etc.
-		 nil)
-		(il:errorset
-		 (or (<= (il:stknargs xcl::pos) 1)
-		     (not (eq (il:stkarg 2 xcl::pos nil)
-			      'il:internal))))
-		(il:eval
-		 (or (<= (il:stknargs xcl::pos) 1)
-		     (not (eq (il:stkarg 2 xcl::pos nil)
-			      'xcl::internal))))
-		(il:apply
-		 (or (<= (il:stknargs xcl::pos) 2)
-		     (not (il:stkarg 3 xcl::pos nil))))
-		(otherwise
-		 (cond ((get xcl::name 'xcl::uninterestingp)
-			;; Explicitly declared uninteresting.
-			nil)
-		       ((eq (il:chcon1 xcl::name) (char-code #\\))
-			;; Implicitly declared uninteresting by starting the
-			;; name with a "\".
-			nil)
-		       ((or (member xcl::name il:openfns :test #'eq)
-			    (eq xcl::name 'funcall))
-			;;The function won't be seen when compiled, so only show
-			;;it if INTERPFLG it true
-			xcl::interpflg)
-		       (t 
-			;; Interesting by default.
-			t)))))
-       (cons (case (car xcl::name)
-	       (:broken t)
-	       (otherwise nil)))
-       (otherwise nil))))
-
-(setq il:*short-backtrace-filter* 'xcl::interesting-frame-p)
-
-
-(eval-when (eval compile)
-  (il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name))))
-
-
-;;  Change the frame inspector to open up lexical environments
-
-  ;; Since the DEFSTRUCT is going to build the accessors in the package that is
-  ;; current at read-time, and we want the accessors to reside in the IL
-  ;; package, we have got to make sure that the defstruct happens when the
-  ;; package is IL.
-
-(in-package "IL")
-
-(cl:defstruct (frame-prop-name (:type cl:list))
-  (label-fn 'nill)
-  (value-fn
-   (function
-    (lambda (prop-name framespec)
-     (frame-prop-name-data prop-name))))
-  (setf-fn 'nill)
-  (inspect-fn
-   (function
-    (lambda (value prop-name framespec window)
-     (default.inspectw.valuecommandfn value prop-name (car framespec) window))))
-  (data nil))
-
-(cl:in-package "PCL")
-
-(defun il:debugger-stack-frame-prop-names (il:framespec) 
-  ;; Frame prop-names are structures of the form
-  ;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA)
-  (let ((il:pos (car il:framespec))
-	(il:backtrace-item (cadr il:framespec)))
-    (il:if (eq 'eval (il:stkname il:pos))
-     il:then
-     (let ((il:expression (il:stkarg 1 il:pos))
-	   (il:environment (il:stkarg 2 il:pos)))
-       `(,(il:make-frame-prop-name :inspect-fn
-	   (il:function
-	    (il:lambda (il:value il:prop-name il:framespec il:window)
-	      (il:inspect/as/function il:value (car il:framespec) il:window)))
-	   :data il:expression)
-	 ,(il:make-frame-prop-name :data "ENVIRONMENT")
-	 ,@(il:for il:aspect il:in
-	    `((,(and il:environment (il:environment-vars il:environment))
-	       "vars")
-	      (,(and il:environment (il:environment-functions il:environment))
-	       "functions")
-	      (,(and il:environment (il:environment-blocks il:environment))
-	       "blocks")
-	      (,(and il:environment (il:environment-tagbodies il:environment))
-	       "tag bodies"))
-	    il:bind il:group-name il:p-list
-	    il:eachtime (il:setq il:group-name (cadr il:aspect))
-	                (il:setq il:p-list (car il:aspect))
-	    il:when (not (null il:p-list))
-	    il:join
-	    `(,(il:make-frame-prop-name :data il:group-name)
-	      ,@(il:for il:p il:on il:p-list il:by cddr il:collect
-		 (il:make-frame-prop-name :label-fn
-		  (il:function (il:lambda (il:prop-name il:framespec)
-				 (car (il:frame-prop-name-data il:prop-name))))
-		  :value-fn
-		  (il:function (il:lambda (il:prop-name il:framespec)
-				 (cadr (il:frame-prop-name-data il:prop-name))))
-		  :setf-fn
-		  (il:function (il:lambda (il:prop-name il:framespec il:new-value)
-				 (il:change (cadr (il:frame-prop-name-data
-						   il:prop-name))
-					    il:new-value)))
-		  :data il:p))))))
-     il:else
-     (flet ((il:build-name (&key il:arg-name il:arg-number)
-	      (il:make-frame-prop-name :label-fn
-		  (il:function (il:lambda (il:prop-name il:framespec)
-				 (car (il:frame-prop-name-data il:prop-name))))
-		  :value-fn
-		  (il:function (il:lambda (il:prop-name il:framespec)
-				 (il:stkarg (cadr (il:frame-prop-name-data
-						   il:prop-name))
-					    (car il:framespec))))
-		  :setf-fn
-		  (il:function (il:lambda (il:prop-name il:framespec il:new-value)
-				 (il:setstkarg (cadr (il:frame-prop-name-data
-						      il:prop-name))
-					       (car il:framespec)
-					       il:new-value)))
-		  :data
-		  (list il:arg-name il:arg-number))))
-       (let ((il:nargs (il:stknargs il:pos t))
-	     (il:nargs1 (il:stknargs il:pos))
-	     (il:fnname (il:stkname il:pos))
-	     il:argname
-	     (il:arglist))
-	 (and (il:litatom il:fnname)
-	      (il:ccodep il:fnname)
-	      (il:setq il:arglist (il:listp (il:smartarglist il:fnname))))
-	 `(,(il:make-frame-prop-name :inspect-fn
-	     (il:function (il:lambda (il:value il:prop-name il:framespec
-					       il:window)
-			    (il:inspect/as/function il:value
-						    (car il:framespec)
-						    il:window)))
-	     :data
-	     (il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item))
-	   ,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect
-	      (progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist))
-					 lambda-list-keywords)
-			       il:do
-			       (il:setq il:mode il:argname))
-		     (il:build-name :arg-name
-				    (or (il:stkargname il:i il:pos)
-					; special
-					(if (case il:mode
-					      ((nil &optional) il:argname)
-					      (t nil))
-					    (string il:argname)
-					    (il:concat "arg " (- il:i 1))))
-				    :arg-number il:i)))
-	   ,@(let* ((il:novalue "No value")
-		    (il:slots (il:for il:pvar il:from 0 il:as il:i il:from
-				      (il:add1 il:nargs1)
-				      il:to il:nargs il:by 1 il:when
-				      (and (il:neq il:novalue (il:stkarg il:i il:pos
-									 il:novalue))
-					   (or (il:setq il:argname (il:stkargname
-								    il:i il:pos))
-					       (il:setq il:argname (il:concat 
-								    "local " 
-								    il:pvar)))
-					   )
-				      il:collect
-				      (il:build-name :arg-name il:argname 
-						     :arg-number il:i))))
-               (and il:slots (cons (il:make-frame-prop-name :data "locals")
-                                   il:slots)))))))))
-
-(defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name)
-  (il:apply* (il:frame-prop-name-value-fn il:prop-name)
-	     il:prop-name il:framespec))
-
-(defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue)
-  (il:apply* (il:frame-prop-name-setf-fn il:prop-name)
-	     il:prop-name il:framespec il:newvalue))
-
-(defun il:debugger-stack-frame-value-command (il:datum il:prop-name 
-						       il:framespec il:window)
-  (il:apply* (il:frame-prop-name-inspect-fn il:prop-name)
-	     il:datum il:prop-name il:framespec il:window))
-
-(defun il:debugger-stack-frame-title (il:framespec &optional il:window)
-  (declare (ignore il:window))
-  (il:concat (il:stkname (car il:framespec)) "  Frame"))
-
-(defun il:debugger-stack-frame-property (il:prop-name il:framespec)
-  (il:apply* (il:frame-prop-name-label-fn il:prop-name)
-	     il:prop-name il:framespec))
-
-;; Teaching the debugger that there are other file-manager types that can
-;; appear on the stack
-
-(defvar xcl::*function-types* '(il:fns il:functions)
-  "Manager types that can appear on the stack")
-
-;; Redefine a couple of system functions to use the above stuff
-
-#+Xerox-Lyric
-(progn
-
-(defun il:attach-backtrace-menu (&optional (il:ttywindow
-					    (il:wfromds (il:ttydisplaystream)))
-					   il:skip)
-  (let ((il:bkmenu (il:|create| il:menu
-		       il:items il:_
-		       (il:collect-backtrace-items il:ttywindow il:skip)
-		       il:whenselectedfn il:_
-		       (il:function il:backtrace-item-selected)
-		       il:whenheldfn il:_
-		       #'(il:lambda (il:item il:menu il:button)
-			   (declare (ignore il:item il:menu))
-			   (case il:button
-			     (il:left (il:promptprint 
-				       "Open a frame inspector on this stack frame"
-				       ))
-			     (il:middle (il:promptprint 
-					 "Inspect/Edit this function"))
-			     ))
-		       il:menuoutlinesize il:_ 0
-		       il:menufont il:_ il:backtracefont
-		       il:menucolumns il:_ 1))
-	(il:ttyregion (il:windowprop il:ttywindow 'il:region))
-	il:btw)
-    (cond
-      ((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow)
-			   il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu))
-					  (eql (il:|fetch| (il:menu il:whenselectedfn)
-						   il:|of| (car il:btw))
-					       (il:function il:backtrace-item-selected)))
-			   il:|do|                       
-			   (return il:atw)))       
-       (il:deletemenu (car (il:windowprop il:btw 'il:menu))
-		      nil il:btw)
-       (il:windowprop il:btw 'il:extent nil)
-       (il:clearw il:btw))
-      ((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region)
-						      (il:widthifwindow (il:imin (il:|fetch| (il:menu 
-											      il:imagewidth
-											      )
-										     il:|of| il:bkmenu)
-										 il:|MaxBkMenuWidth|))
-						      (il:|fetch| (il:region il:height) il:|of| il:ttyregion
-							  )
-						      'il:left)))   
-       (il:attachwindow il:btw il:ttywindow (cond
-					      ((il:igreaterp (il:|fetch| (il:region il:left)
-								 il:|of| (il:windowprop
-									  il:btw
-									  'il:region))
-							     (il:|fetch| (il:region il:left)
-								 il:|of| il:ttyregion))
-					       'il:right)
-					      (t 'il:left))
-			nil
-			'il:localclose)
-       (il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process))
-
-       ))
-    (il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position
-				     il:xcoord il:_ 0
-				     il:ycoord il:_ (il:idifference (il:windowprop
-								     il:btw
-								     'il:height)
-								    (il:|fetch| (il:menu il:imageheight
-											 ) il:|of| 
-											   il:bkmenu
-											   ))))))
-
-(defun il:backtrace-item-selected (il:item il:menu il:button)
-  (il:resetlst
-   (prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow
-		     (il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item)
-
-				    ))
-      (cond
-	((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu))
-	 (il:menudeselect il:olditem il:menu)        
-	 ))
-      (il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu)
-					   'il:mainwindow))
-      (il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position))
-      (il:setq il:pos (il:stknth (- il:framespecn)
-				 il:bkpos))
-      (let ((il:lp (il:windowprop il:ttywindow 'il:lastpos)))
-	(and il:lp (il:stknth 0 il:pos il:lp)))
-      (il:menuselect il:item il:menu)                
-      (if (eq il:button 'il:middle)
-	  (progn 
-
-
-	    (il:resetsave nil (list 'il:relstk il:pos))
-	    (il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name)
-					il:|of| il:item)
-				    il:pos il:ttywindow))
-	  (progn 
-
-
-	    (il:setq il:framewindow
-		     (xcl:with-profile (il:process.eval
-						  (il:windowprop il:ttywindow 'il:process)
-						  '(let ((il:profile (xcl:copy-profile (xcl:find-profile
-											"READ-PRINT"))))
-						    (setf (xcl::profile-entry-value '
-							   xcl:*eval-function* il:profile)
-						     xcl:*eval-function*)
-						    (xcl:save-profile il:profile))
-						  t)
-		       (il:inspectw.create (list il:pos il:item)
-				   'il:debugger-stack-frame-prop-names
-				   'il:debugger-stack-frame-fetchfn
-				   'il:debugger-stack-frame-storefn nil '
-				   il:debugger-stack-frame-value-command nil '
-				   il:debugger-stack-frame-title nil (
-								      il:make-frame-inspect-window
-								      il:ttywindow)
-				   'il:debugger-stack-frame-property)))
-	    (cond
-	      ((not (il:windowprop il:framewindow 'il:mainwindow))
-	       (il:attachwindow il:framewindow il:ttywindow
-				(cond
-				  ((il:igreaterp (il:|fetch| (il:region il:bottom)
-						     il:|of| (il:windowprop il:framewindow
-									    'il:region))
-						 (il:|fetch| (il:region il:bottom)
-						     il:|of| (il:windowprop il:ttywindow 'il:region)))
-				   'il:top)
-				  (t 'il:bottom))
-				nil
-				'il:localclose)
-	       (il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow
-									 ))))))
-      (return))))
-
-(defun il:collect-backtrace-items (xcl::tty-window xcl::skip)
-   (let* ((xcl::items (cons nil nil))
-          (xcl::items-tail xcl::items))
-         (macrolet ((xcl::collect-item (xcl::new-item)
-                           `(progn (setf (rest xcl::items-tail)
-                                         (cons ,xcl::new-item nil))
-                                   (pop xcl::items-tail))))
-                (let* ((xcl::filter-fn (cond
-                                          ((null xcl::skip)
-                                           #'xcl:true)
-                                          ((eq xcl::skip t)
-                                           il:*short-backtrace-filter*)
-                                          (t xcl::skip)))
-                       (xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window '
-                                                           il:stack-position)))
-                       (xcl::next-frame xcl::top-frame)
-                       (xcl::frame-number 0)
-                       xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label)
-                      (loop (when (null xcl::next-frame)
-                                  (return))
-                            (multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed 
-                                                        xcl::use-frame xcl::label)
-                                   (funcall xcl::filter-fn xcl::next-frame))
-                            (when (null xcl::last-frame-consumed)
-                                                            
-                                (setf xcl::last-frame-consumed xcl::next-frame))
-                            (when xcl::interesting-p        
-                                (when (null xcl::use-frame)
-                                      (setf xcl::use-frame xcl::last-frame-consumed))
-                                                             
-                                (when (null xcl::label)
-                                    (setf xcl::label (il:stkname xcl::use-frame))
-                                    (if (member xcl::label '(eval il:eval il:apply apply)
-                                               :test
-                                               'eq)
-                                        (setf xcl::label (il:stkarg 1 xcl::use-frame))))
-                                                            
-                                (loop (cond
-                                         ((not (typep xcl::next-frame 'il:stackp))
-                                          (error "~%Use-frame ~S not found" xcl::use-frame))
-                                         ((xcl::stack-eql xcl::next-frame xcl::use-frame)
-                                          (return))
-                                         (t (incf xcl::frame-number)
-                                            (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
-                                                                         xcl::next-frame)))))
-                                                             
-                                (xcl::collect-item (il:|create| il:bkmenuitem
-                                                          il:label il:_ (let ((*print-level* 2)
-                                                                              (*print-length* 3)
-                                                                              (*print-escape* t)
-                                                                              (*print-gensym* t)
-                                                                              (*print-pretty* nil)
-                                                                              (*print-circle* nil)
-                                                                              (*print-radix* 10)
-                                                                              (*print-array* nil)
-                                                                              (il:*print-structure*
-                                                                               nil))
-                                                                             (prin1-to-string 
-                                                                                    xcl::label))
-                                                          il:bkmenuinfo il:_ xcl::frame-number
-                                                          il:frame-name il:_ xcl::label)))
-                                                             
-                            (loop (cond
-                                     ((not (typep xcl::next-frame 'il:stackp))
-                                      (error "~%Last-frame-consumed ~S not found" 
-                                             xcl::last-frame-consumed))
-                                     ((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed
-                                                    )
-                                          (incf xcl::frame-number)
-                                          (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
-                                                             
-                                                                       xcl::next-frame)))
-                                      (return)))))))
-         (rest xcl::items)))
-
-)
-#+Xerox-Medley
-(progn
-
-(defun dbg::attach-backtrace-menu (&optional tty-window skip)
-  (declare (special il:\\term.ofd il:backtracefont))
-  (or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream))))
-  (prog (btw bkmenu
-	     (tty-region (il:windowprop tty-window 'il:region))
-	     ;; And, for the FORMAT below...
-	     (*print-level* 2)
-	     (*print-length* 3)
-	     (*print-escape* t)
-	     (*print-gensym* t)
-	     (*print-pretty* nil)
-	     (*print-circle* nil)
-	     (*print-radix* 10)
-	     (*print-array* nil)
-	     (il:*print-structure* nil))
-     (setq bkmenu
-	   (il:|create| il:menu
-	       il:items il:_ (dbg::collect-backtrace-items tty-window skip)
-	       il:whenselectedfn il:_ 'dbg::backtrace-item-selected
-	       il:menuoutlinesize il:_ 0
-	       il:menufont il:_ il:backtracefont 
-	       il:menucolumns il:_ 1
-	       il:whenheldfn il:_
-	       #'(il:lambda (item menu button)
-		   (declare (ignore item menu))
-		   (case button
-		     (il:left
-		      (il:promptprint
-		       "Open a frame inspector on this stack frame"))
-		     (il:middle
-		      (il:promptprint "Inspect/Edit this function"))))))
-     (cond ((setq btw
-		  (dolist (atw  (il:attachedwindows tty-window))
-		    ;; Test for an attached window that has a backtrace menu in
-		    ;; it.
-		    (when (and (setq btw (il:windowprop atw 'il:menu))
-			   (eq (il:|fetch| (il:menu il:whenselectedfn)
-				   il:|of| (car btw))
-			       'dbg::backtrace-item-selected))
-		      (return atw))))
-	    ;; If there is alread a backtrace window, delete the old menu from
-	    ;; it.
-	    (il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw)
-	    (il:windowprop btw 'il:extent nil)
-	    (il:clearw btw))
-	   ((setq btw
-		  (il:createw (dbg::region-next-to
-			       (il:windowprop tty-window 'il:region)
-			       (il:widthifwindow
-				(il:imin (il:|fetch| (il:menu il:imagewidth)
-					     il:|of| bkmenu)
-					 il:|MaxBkMenuWidth|))
-			       (il:|fetch| (il:region il:height)
-				   il:|of| tty-region)
-			       :left)))
-					; put bt window at left of TTY
-					; window unless ttywindow is
-					; near left edge.
-	    (il:attachwindow btw tty-window
-			     (if (il:igreaterp (il:|fetch| (il:region il:left)
-						   il:|of|
-						   (il:windowprop btw
-								  'il:region))
-					       (il:|fetch| (il:region il:left)
-						   il:|of| tty-region))
-				 'il:right
-				 'il:left)
-			     nil
-			     'il:localclose)
-	    ;; So that button clicks will switch the TTY
-	    (il:windowprop btw 'il:process
-			   (il:windowprop tty-window 'il:process))))
-     (il:addmenu bkmenu btw (il:|create| il:position
-				il:xcoord il:_ 0 
-				il:ycoord il:_ (- (il:windowprop btw 'il:height)
-						  (il:|fetch| (il:menu 
-							       il:imageheight)
-						      il:|of| bkmenu))))
-     ;; IL:ADDMENU sets up buttoneventfn for window that we don't
-     ;; want.  We want to catch middle button events before the menu
-     ;; handler, so that we can pop up edit/inspect menu for the frame
-     ;; currently selected.  So replace the buttoneventfn, and can
-     ;; nuke the cursorin and cursormoved guys, cause don't need them.
-     (il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn)
-     (il:windowprop btw 'il:cursorinfn nil)
-     (il:windowprop btw 'il:cursormovedfn nil)))
-
-(defun dbg::collect-backtrace-items (tty-window skip)
-  (xcl:with-collection
-      ;;
-      ;; There are a number of possibilities for the values returned by the
-      ;; filter-fn.
-      ;;
-      ;; (1) INTERESTING-P is false, and the other values are all NIL.  This
-      ;; is the simple case where the stack frame NEXT-POS should be ignored
-      ;; completly, and processing should continue with the next frame.
-      ;;
-      ;; (2) INTERESTING-P is true, and the other values are all NIL.  This
-      ;; is the simple case where the stack frame NEXT-POS should appear in
-      ;; the backtrace as is, and processing should continue with the next
-      ;; frame.
-      ;;
-      ;; [Note that these two cases take care of old values of the
-      ;; filter-fn.]
-      ;;
-      ;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack
-      ;; frame.  In that case, ignore all stack frames from NEXT-POS to
-      ;; LAST-FRAME-CONSUMED, inclusive.
-      ;;
-      ;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack
-      ;; frame.  In this case, the backtrace should include a single entry
-      ;; coresponding to the frame USE-FRAME (which defaults to
-      ;; LAST-FRAME-CONSUMED), and processing should continue with the next
-      ;; frame after LAST-FRAME-CONSUMED.  If LABEL is non-NIL, it will be
-      ;; the label that appears in the backtrace menu; otherwise the name of
-      ;; USE-FRAME will be used (or the form being EVALed if the frame is an
-      ;; EVAL frame).
-      ;;
-      (let* ((filter (cond ((null skip) #'xcl:true)
-			   ((eq skip t) il:*short-backtrace-filter*)
-			   (t skip)))
-	     (top-frame (il:stknth 0 (il:getwindowprop tty-window
-					      'dbg::stack-position)))
-	     (next-frame top-frame)
-	     (frame-number 0)
-	     interestingp last-frame-consumed frame-to-use label-to-use)
-	(loop (when (null next-frame) (return))
-	      ;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED,
-	      ;; FRAME-TO-USE, and LABEL-TO-USE
-	      (multiple-value-setq (interestingp last-frame-consumed 
-						 frame-to-use label-to-use)
-		(funcall filter next-frame))
-	      (when (null last-frame-consumed)
-		(setf last-frame-consumed next-frame))
-	      (when interestingp
-		(when (null frame-to-use)
-		  (setf frame-to-use last-frame-consumed))
-		(when (null label-to-use)
-		  (setf label-to-use (il:stkname frame-to-use))
-		  (if (member label-to-use '(eval il:eval il:apply apply)
-			      :test 'eq)
-		      (setf label-to-use (il:stkarg 1 frame-to-use))))
-
-		;; Walk the stack until we find the frame to use
-		(loop (cond ((not (typep next-frame 'il:stackp))
-			     (error "~%Use-frame ~S not found" frame-to-use))
-			    ((xcl::stack-eql next-frame frame-to-use)
-			     (return))
-			    (t (incf frame-number)
-			       (setf next-frame
-				     (il:stknth -1 next-frame next-frame)))))
-
-		;; Add the menu item to the list under construction
-		(xcl:collect (il:|create| il:bkmenuitem
-				 il:label il:_ (let ((*print-level* 2)
-						     (*print-length* 3)
-						     (*print-escape* t)
-						     (*print-gensym* t)
-						     (*print-pretty* nil)
-						     (*print-circle* nil)
-						     (*print-radix* 10)
-						     (*print-array* nil)
-						     (il:*print-structure* nil))
-						 (prin1-to-string label-to-use))
-				 il:bkmenuinfo il:_ frame-number
-				 il:frame-name il:_ label-to-use)))
-
-	      ;; Update NEXT-POS
-	      (loop (cond ((not (typep next-frame 'il:stackp))
-			   (error "~%Last-frame-consumed ~S not found" 
-				  last-frame-consumed))
-			  ((prog1
-			       (xcl::stack-eql next-frame last-frame-consumed)
-			     (incf frame-number)
-			     (setf next-frame (il:stknth -1 next-frame
-							 next-frame)))
-			   (return))))))))
-
-(defun dbg::backtrace-menu-buttoneventfn (window &aux menu)
-  (setq menu (car (il:listp (il:windowprop window 'il:menu))))
-  (unless (or (il:lastmousestate il:up) (null menu))
-    (il:totopw window)
-    (cond ((il:lastmousestate il:middle)
-	   ;; look for a selected frame in this menu, and then pop up
-	   ;; the editor invoke menu for that frame.  don't change the
-	   ;; selection, just present the edit menu.
-	   (let* ((selection (il:menu.handler menu
-					  (il:windowprop window 'il:dsp)))
-		  (tty-window (il:windowprop window 'il:mainwindow))
-		  (last-pos (il:windowprop tty-window 'dbg::lastpos)))
-                        
-	     ;; don't have to worry about releasing POS because we
-	     ;; only look at it here (nobody here hangs on to it)
-	     ;; and we will be around for less time than LASTPOS. 
-	     ;; The debugger is responsible for releasing LASTPOS.
-	     (il:inspect/as/function (cond
-				       ((and selection
-					     (il:|fetch| (il:bkmenuitem il:frame-name)
-						 il:|of| (car selection))))
-				       ((and (symbolp (il:stkname last-pos))
-					     (il:getd (il:stkname last-pos)))
-					(il:stkname last-pos))
-				       (t 'il:nill))
-				     last-pos tty-window)))
-	  (t (let ((selection (il:menu.handler menu
-					   (il:windowprop window 'il:dsp))))
-	       (when selection
-		 (il:doselecteditem menu (car selection) (cdr selection))))))))
-
-;; This function isn't really redefined, but it needs to be recomiled since we
-;; changed the def'n of the BKMENUITEM record.
-
-(defun dbg::backtrace-item-selected (item menu button)
-  ;;When a frame name is selected in the backtrace menu, this is the function
-  ;;that gets called.
-  (declare (special il:brkenv) (ignore button))
-  (let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item))
-	 (tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow))
-	 (bkpos (il:windowprop tty-window 'dbg::stack-position))
-	 (pos (il:stknth (- frame-spec) bkpos)))
-    (let ((lp (il:windowprop tty-window 'dbg::lastpos)))
-      (and lp (il:stknth 0 pos lp)))
-    ;; change the item selected from OLDITEM to ITEM.  Only do this on left
-    ;; buttons now.  Middle just pops up the edit menu, doesn't select. -woz
-    (let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu)))
-      (when old-item (il:menudeselect old-item menu))
-      (il:menuselect item menu))
-    ;; Change the lexical environment so it is the one in effect as of this
-    ;; frame.
-    (il:process.eval (il:windowprop tty-window (quote dbg::process))
-	       `(setq il:brkenv ',(il:find-lexical-environment pos))
-	       t)
-    (let ((frame-window (xcl:with-profile
-			    (il:process.eval (il:windowprop tty-window
-							    'il:process)
-				       `(let ((profile (xcl:copy-profile
-							(xcl:find-profile
-							 "READ-PRINT"))))
-					 (setf
-					  (xcl::profile-entry-value
-					   'xcl:*eval-function* profile)
-					  xcl:*eval-function*)
-					 (xcl:save-profile profile))
-				       t)
-			  (il:inspectw.create pos
-				      #'(lambda (pos)
-					  (dbg::stack-frame-properties pos t))
-				      'dbg::stack-frame-fetchfn
-				      'dbg::stack-frame-storefn
-				      nil
-				      'dbg::stack-frame-value-command
-				      nil
-				      (format nil "~S  Frame" (il:stkname pos))
-				      nil (dbg::make-frame-inspect-window
-					   tty-window)
-				      'dbg::stack-frame-property))))
-      (when (not (il:windowprop frame-window 'il:mainwindow))
-	(il:attachwindow frame-window tty-window
-			 (if (> (il:|fetch| (il:region il:bottom) il:|of|
-				    (il:windowprop frame-window 'il:region))
-				(il:|fetch| (il:region il:bottom) il:|of|
-				    (il:windowprop tty-window 'il:region)))
-			     'il:top 'il:bottom)
-			 nil 'il:localclose)
-	(il:windowaddprop frame-window 'il:closefn 'il:detachwindow)))))
-
-)					;end of Xerox-Medley
-
-(defun il:select.fns.editor (&optional function)
-    ;; gives the user a menu choice of editors.
-    (il:menu (il:|create| il:menu
-		 il:items il:_ (cond ((il:ccodep function)
-				      '((il:|InspectCode| 'il:inspectcode 
-					 "Shows the compiled code.")
-					(il:|DisplayEdit| 'ed 
-					 "Edit it with the display editor")
-					(il:|TtyEdit| 'il:ef 
-					 "Edit it with the standard editor")))
-				     ((il:closure-p function)
-				      '((il:|Inspect| 'inspect 
-					 "Inspect this object")))
-				     (t '((il:|DisplayEdit| 'ed 
-					   "Edit it with the display editor")
-					  (il:|TtyEdit| 'il:ef 
-					   "Edit it with the standard editor"))))
-		 il:centerflg il:_ t)))
-
-;; 
-
-
-;; PCL specific extensions to the debugger
-
-
-;; There are some new things that act as functions, and that we want to be
-;; able to edit from a backtrace window
-
-(pushnew 'methods xcl::*function-types*)
-
-(eval-when (eval compile load)
-  (unless (generic-function-p (symbol-function 'il:inspect/as/function))
-    (make-specializable 'il:inspect/as/function)))
-
-(defmethod il:inspect/as/function (name stack-pointer debugger-window)
-  ;; Calls an editor on function NAME.  STKP and WINDOW are the stack pointer
-  ;; and window of the break in which this inspect command was called.
-  (declare (ignore debugger-window))
-  (let ((editor (il:select.fns.editor name)))
-    (case editor
-      ((nil) 
-       ;; No editor chosen, so don't do anything
-       nil)
-      (il:inspectcode 
-       ;; Inspect the compiled code
-       (let ((frame (xcl::stack-pointer-frame stack-pointer)))
-	 (if (and (il:stackp stack-pointer)
-		  (xcl::stack-frame-valid-p frame))
-	     (il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame)))
-			       (cond ((eq (il:\\get-compiled-code-base name)
-					  code-base)
-				      name)
-				     (t 
-				      ;; Function executing in this frame is not
-				      ;; the one in the definition cell of its
-				      ;; name, so fetch the real code.  Have to
-				      ;; pass a CCODEP
-				      (il:make-compiled-closure code-base))))
-                             nil nil nil (xcl::stack-frame-pc frame))
-	     (il:inspectcode name))))
-      (ed 
-       ;; Use the standard editor.
-       ;; This used to take care to apply the editor in the debugger
-       ;; process, so forms evaluated in the editor happen in the
-       ;; context of the break.  But that doesn't count for much any
-       ;; more, now that lexical variables are the way to go.  Better to
-       ;; use the LEX debugger command (thank you, Herbie) and
-       ;; shift-select pieces of code from the editor into the debugger
-       ;; window. 
-       (ed name `(,@xcl::*function-types* :display)))
-      (otherwise (funcall editor name)))))
-
-(defmethod il:inspect/as/function ((name standard-object) stkp window)
-  (when (il:menu (il:|create| il:menu
-		     il:items il:_ '(("Inspect" t "Inspect this object"))))
-    (inspect name)))
-
-(defmethod il:inspect/as/function ((x standard-method) stkp window)
-  (let* ((generic-function-name (slot-value (slot-value x 'generic-function)
-					    'name))
-	 (method-name (full-method-name x))
-	 (editor (il:select.fns.editor method-name)))
-    (il:allow.button.events)
-    (case editor
-      (ed (ed method-name '(:display methods)))
-      (il:inspectcode (il:inspectcode (slot-value x 'function)))
-      ((nil) nil)
-      (otherwise (funcall editor method-name)))))
-
-;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods
-;; and generic-functions on the stack.
-
-(defun interesting-frame-p (stack-pos &optional interp-flag)
-  ;; Return up to four values:  INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and
-  ;; LABEL.  See the function IL:COLLECT-BACKTRACE-ITEMS for a full description
-  ;; of how these values are used.
-  (labels
-      ((function-matches-frame-p (function frame)
-	   "Is the function being called in this frame?"
-	   (let* ((frame-name (il:stkname frame))
-		  (code-being-run (cond
-				    ((typep frame-name 'il:closure)
-				     frame-name)
-				    ((and (consp frame-name)
-					  (eq 'il:\\interpreter
-					      (xcl::stack-frame-name
-					       (il:\\stackargptr frame))))
-				     frame-name)
-				    (t (xcl::stack-frame-fn-header
-					(il:\\stackargptr frame))))))
-	     (or (eq function code-being-run)
-		 (and (typep function 'il:compiled-closure)
-		      (eq (xcl::compiled-closure-fnheader function)
-			  code-being-run)))))
-       (generic-function-from-frame (frame)
-	 "If this the frame of a generic function return the gf, otherwise
-          return NIL."
-	 ;; Generic functions are implemented as compiled closures.  On the
-	 ;; stack, we only see the fnheader for the the closure.  This could
-	 ;; be a discriminator code, or in the default method only case it
-	 ;; will be the actual method function.  To tell if this is a generic
-	 ;; function frame, we have to check very carefully to see if the
-	 ;; right stuff is on the stack.  Specifically, the closure's ccode,
-	 ;; and the first local variable has to be a ptrhunk big enough to be
-	 ;; a FIN environment, and fin-env-fin of that ptrhunk has to point
-	 ;; to a generic function whose ccode and environment match. 
-	 (let ((n-args (il:stknargs frame))
-	       (env nil)
-	       (gf nil))
-	   (if (and ;; is there at least one local?
-		(> (il:stknargs frame t) n-args)
-		;; and does the local contain something that might be
-		;; the closure environment of a funcallable instance?
-		(setf env (il:stkarg (1+ n-args) frame))
-		;; and does the local contain something that might be
-		;; the closure environment of a funcallable instance?
-		(typep env *fin-env-type*)
-		(setf gf (fin-env-fin env))
-		;; whose fin-env-fin points to a generic function?
-		(generic-function-p gf)
-		;; whose environment is the same as env?
-		(eq (xcl::compiled-closure-env gf) env)
-		;; and whose code is the same as the code for this
-		;; frame? 
-		(function-matches-frame-p gf frame))
-	       gf
-	       nil))))
-    (let ((frame-name (il:stkname stack-pos)))
-      ;; See if there is a generic-function on the stack at this
-      ;; location.
-      (let ((gf (generic-function-from-frame stack-pos)))
-	(when gf
-	  (return-from interesting-frame-p (values t stack-pos stack-pos gf))))
-      ;; See if this is an interpreted method.  The method body is
-      ;; wrapped in a (BLOCK <function-name> ...).  We look for an
-      ;; interpreted call to BLOCK whose block-name is the name of
-      ;; generic-function.
-      (when (and (eq frame-name 'eval)
-		 (consp (il:stkarg 1 stack-pos))
-		 (eq (first (il:stkarg 1 stack-pos)) 'block)
-		 (symbolp (second (il:stkarg 1 stack-pos)))
-		 (fboundp (second (il:stkarg 1 stack-pos)))
-		 (generic-function-p
-		     (symbol-function (second (il:stkarg 1 stack-pos)))))
-	(let* ((form (il:stkarg 1 stack-pos))
-	       (block-name (second form))
-	       (generic-function (symbol-function block-name))
-	       (methods (generic-function-methods (symbol-function block-name))))
-	  ;; If this is really a method being called from a
-	  ;; generic-function, the g-f should be no more than a
-	  ;; few(?) frames up the stack.  Check for the method call
-	  ;; by looking for a call to APPLY, where the function
-	  ;; being applied is the code in one of the methods.
-	  (do ((i 100 (1- i))
-	       (previous-pos stack-pos current-pos)
-	       (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos))
-	       (found-method nil)
-	       (method-pos))
-	      ((or (null current-pos) (<= i 0)) nil)
-	    (cond ((equalp generic-function
-			   (generic-function-from-frame current-pos))
-		   (if found-method
-		       (return-from interesting-frame-p
-			 (values t previous-pos method-pos found-method))
-		       (return)))
-		  (found-method nil)
-		  ((eq (il:stkname current-pos) 'apply)
-		   (dolist (method methods)
-		     (when (eq (method-function method)
-			       (il:stkarg 1 current-pos))
-		       (setq method-pos current-pos)
-		       (setq found-method method)
-		       (return))))))))
-      ;; Try to handle compiled methods
-      (when (and (symbolp frame-name)
-		 (not (fboundp frame-name))
-		 (eq (il:chcon1 frame-name)
-		     (il:charcode il:\())
-		 (or (string-equal "(method " (symbol-name frame-name)
-			      :start2 0 :end2 13)
-		     (string-equal "(method " (symbol-name frame-name)
-			      :start2 0 :end2 12)
-		     (string-equal "(method " (symbol-name frame-name)
-			      :start2 0 :end2 8)))
-	;; Looks like a name that PCL consed up.  See if there is a
-	;; GF nearby up the stack.  If there is, use it to help
-	;; determine which method we have.
-	(do ((i 30 (1- i))
-	     (current-pos (il:stknth -1 stack-pos)
-			  (il:stknth -1 current-pos))
-	     (gf))
-	    ((or (null current-pos)
-		 (<= i 0))
-	     nil)
-	  (setq gf (generic-function-from-frame current-pos))
-	  (when gf
-	    (dolist (method (generic-function-methods gf))
-	      (when (function-matches-frame-p (method-function method)
-					      stack-pos)
-		(return-from interesting-frame-p
-		  (values t stack-pos stack-pos method))))
-	    (return))))
-      ;; If we haven't already returned, use the default method.
-      (xcl::interesting-frame-p stack-pos interp-flag))))
-
-
-(setq il:*short-backtrace-filter* 'interesting-frame-p)
-
-;;; Support for undo
-
- (defun undoable-setf-slot-value (object slot-name new-value)
-    (if (slot-boundp object slot-name)
-      (il:undosave (list 'undoable-setf-slot-value
-                         object slot-name (slot-value object slot-name)))
-      (il:undosave (list 'slot-makunbound object slot-name)))
-    (setf (slot-value object slot-name) new-value))
-
-  (setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value)
-
-
-;;; Support for ?= and friends
-
-;; The arglists for generic-functions are built using gensyms, and don't reflect
-;; any keywords (they are all included in an &REST arg).  Rather then use the
-;; arglist in the code, we use the one that PCL kindly keeps in the generic-function.
-
-(xcl:advise-function 'il:smartarglist
-  '(if (and il:explainflg
-	(symbolp il:fn)
-	(fboundp il:fn)
-	(generic-function-p (symbol-function il:fn)))
-    (generic-function-pretty-arglist (symbol-function il:fn))
-    (xcl:inner))
-  :when :around :priority :last)
-
-(setf (get 'defclass 'il:argnames)
-      '(nil (class-name (#\{ superclass-name #\} #\*)
-	     (#\{ slot-specifier #\} #\*)
-	     #\{ slot-option #\} #\*)))
-
-(setf (get 'defmethod 'il:argnames)
-      '(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\*
-	     specialized-lambda-list #\{ declaration #\| doc-string #\} #\*
-	     #\{ form #\} #\*)))
-
-;;; Prettyprinting support, the result of Harley Davis.
-
-;; Support the standard Prettyprinter.  This is really minimal right now.  If
-;; anybody wants to fix this, I'd be happy to include their code.  In fact,
-;; there is almost no support for Commonlisp in the standard Prettyprinter, so
-;; the field is wide open to hackers with time on their hands.
-
-
-(setf (get 'defmethod :definition-print-template) ;Not quite right, since it
-      '(:name :arglist :body))		          ; doesn't handle qualifiers,
-		          		          ; but it will have to do.
-
-(defun defclass-prettyprint (form)
-  (let ((left (il:dspxposition))
-	(char-width (il:charwidth (il:charcode x) *standard-output*)))
-    (xcl:destructuring-bind (defclass name supers slots . options) form
-      (princ "(")
-      (prin1 defclass)
-      (princ " ")
-      (prin1 name)
-      (princ " ")
-      (if (null supers)
-	  (princ "()")			;Print "()" instead of "nil"
-	  (il:sequential.prettyprint (list supers) (il:dspxposition)))
-      (if (null slots)
-	  (progn (il:prinendline (+ left (* 4 char-width)) *standard-output*)
-		 (princ "()"))
-	  (il:sequential.prettyprint (list slots) (+ left (* 4 char-width))))
-      (when options
-	(il:sequential.prettyprint options (+ left (* 2 char-width))))
-      (princ ")")
-      nil)))
-
-(let ((pprint-macro (assoc 'defclass il:prettyprintmacros)))
-  (if (null pprint-macro)
-      (push (cons 'defclass 'defclass-prettyprint)
-	    il:prettyprintmacros)
-      (setf (cdr pprint-macro) 'defclass-prettyprint)))
-
-(defun binder-prettyprint (form)
-  ;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS
-  ;; that are of the form (fn (var ...) form &rest body).
-  ;; This code is far from correct, but it's better than nothing.
-  (if (and (consp form)
-	   (not (null (cdddr form))))
-      ;; I have no idea what I'm doing here.  Seems I can copy and edit somebody
-      ;; elses code without understanding it.
-      (let ((body-indent (+ (il:dspxposition)
-			    (* 2 (il:charwidth (il:charcode x)
-					       *standard-output*))))
-	    (form-indent (+ (il:dspxposition)
-			    (* 4 (il:charwidth (il:charcode x)
-					       *standard-output*)))))
-	(princ "(")
-	(prin1 (first form))
-	(princ " ")
-	(il:superprint (second form) form nil *standard-output*)
-	(il:sequential.prettyprint (list (third form)) form-indent)
-	(il:sequential.prettyprint (cdddr form) body-indent)
-	(princ ")")
-	nil)				;Return NIL to indicate that we did
-					; the printing
-      t))				;Return true to use default printing
-
-
-(dolist (fn '(multiple-value-bind with-accessors with-slots))
-  (let ((pprint-macro (assoc fn 'il:prettyprintmacros)))
-    (if (null pprint-macro)
-	(push (cons fn 'binder-prettyprint)
-	      il:prettyprintmacros)
-	(setf (cdr pprint-macro) 'binder-prettyprint))))
-
-
-
-;; SEdit has its own prettyprinter, so we need to support that too.  This is due
-;; to Harley Davis.  Really.
-
-(push (cons :slot-spec
-	    '(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
-		break sedit::from-indent . 0)
-	       (sedit::set-indent . 1)
-	       (sedit::next-inline? 1 break sedit::from-indent . 1)
-	       (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
-		break sedit::from-indent . 0))
-	      ((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
-		break sedit::from-indent . 0)
-	       (sedit::set-indent . 1)
-	       (sedit::next-inline? 1 break sedit::from-indent . 1)
-	       (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
-		break sedit::from-indent . 0))))
-    sedit:*indent-alist*)
-
-(setf (sedit:get-format :slot-spec)
-      '(:indent :slot-spec :inline t))
-
-(setf (sedit:get-format :slot-spec-list)
-      '(:indent :binding-list :args (:slot-spec) :inline nil))
-
-(setf (sedit:get-format 'defclass)
-      '(:indent ((2) 1)
-	:args (:keyword nil nil :slot-spec-list nil)
-	:sublists (4)))
-
-(setf (sedit:get-format 'defmethod)
-      '(:indent ((2))
-	:args (:keyword nil :lambda-list nil)
-	:sublists (3)))
-
-(setf (sedit:get-format 'defgeneric) 'defun)
-
-(setf (sedit:get-format 'generic-flet) 'flet)
-
-(setf (sedit:get-format 'generic-labels) 'flet)
-
-(setf (sedit:get-format 'call-next-method)
-      '(:indent (1) :args (:keyword nil)))
-
-(setf (sedit:get-format 'symbol-macrolet) 'let)
-
-(setf (sedit:get-format 'with-accessors)
-      '(:indent ((1) 1)
-	:args (:keyword :binding-list nil)
-	:sublists (2)
-	:miser :never))
-
-(setf (sedit:get-format 'with-slots) 'with-accessors)
-
-(setf (sedit:get-format 'make-instance)
-      '(:indent ((1))
-	:args (:keyword nil :slot-spec-list)))
-
-(setf (sedit:get-format '*make-instance) 'make-instance)
-
-;;; PrettyFileIndex stuff, the product of Harley Davis.
-
-(defvar *pfi-class-type* '(class defclass pfi-class-namer))
-
-(defvar *pfi-method-type* '(method defmethod pfi-method-namer)
-  "Handles method for prettyfileindex")
-
-(defvar *pfi-index-accessors* nil
-  "t -> each slot accessor gets a listing in the index.")
-
-(defvar *pfi-method-index* :group
-  ":group, :separate, :both, or nil")
-
-(defun pfi-add-class-type ()
-  (pushnew *pfi-class-type* il:*pfi-types*))
-
-(defun pfi-add-method-type ()
-  (pushnew *pfi-method-type* il:*pfi-types*))
-
-(defun pfi-class-namer (expression entry)
-  (let ((class-name (second expression)))
-    ;; Following adds all slot readers/writers/accessors as separate entries in
-    ;; the index.  Probably a mistake.
-    (if *pfi-index-accessors*
-	(let ((slot-list (fourth expression))
-	      (accessor-names nil))
-	  (labels ((add-accessor (method-index name-index)
-		     (push (case *pfi-method-index*
-			     (:group method-index)
-			     (:separate name-index)
-			     ((t :both) (list method-index name-index))
-			     ((nil) nil)
-			     (otherwise (error "Illegal value for *pfi-method-index*: ~S"
-					       *pfi-method-index*)))
-			   accessor-names))
-		   (add-reader (reader-name)
-		     (add-accessor `(method (,reader-name (,class-name)))
-				   `(,reader-name (,class-name))))
-		   (add-writer (writer-name)
-		     (add-accessor `(method ((setf ,writer-name) (t ,class-name)))
-				   `((setf ,writer-name) (t ,class-name)))))
-	    (dolist (slot-def slot-list)
-	      (do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args))
-		    (slot-arg (first  rest-slot-args)  (first rest-slot-args)))
-		   ((null rest-slot-args))
- 		(case slot-arg
-		  (:reader (add-reader (second rest-slot-args)))
-		  (:writer (add-writer (second rest-slot-args)))
-		  (:accessor (add-reader (second rest-slot-args))
-			     (add-writer (second rest-slot-args)))
-		  (otherwise nil))))
-	    (cons `(class (,class-name)) accessor-names)))
-	class-name)))
-
-(defun pfi-method-namer (expression entry)
-  (let ((method-name (second expression))
-	(specializers nil)
-	(qualifiers nil)
-	lambda-list)
-    (do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers))
-	  (qualifier (first rest-qualifiers) (first rest-qualifiers)))
-	 ((listp qualifier) (setq lambda-list qualifier)
-	                    (setq qualifiers (reverse qualifiers)) qualifiers)
-      (push qualifier qualifiers))
-    (do* ((rest-lambda-list lambda-list (cdr rest-lambda-list))
-	  (arg (first rest-lambda-list) (first rest-lambda-list)))
-	 ((or (member arg lambda-list-keywords) (null rest-lambda-list))
-	  (setq specializers (reverse specializers)))
-      (push (if (listp arg) (second arg) t) specializers))
-    (let ((method-index `(method (,method-name ,@qualifiers ,specializers)))
-	  (name-index `(,method-name ,@qualifiers ,specializers)))
-      (case *pfi-method-index*
-	(:group method-index)
-	(:separate name-index)
-	((t :both) (list method-index name-index))
-	((nil) nil)
-	(otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*))))))
-
-(defun pfi-install-pcl ()
-  (pfi-add-method-type)
-  (pfi-add-class-type))
-
-(eval-when (eval load)
-  (when (boundp (quote il:*pfi-types*))
-    (pfi-install-pcl))
-  )
-
diff --git a/pcl/pcl-env.text b/pcl/pcl-env.text
deleted file mode 100644
index 25e090f2f2a337cf657ec2e26e243baff1cfabb5..0000000000000000000000000000000000000000
--- a/pcl/pcl-env.text
+++ /dev/null
@@ -1,105 +0,0 @@
-A (very) few words about PCL-ENV.  If you require more information, consult the
-source code.  While it is not particularly well documented, it is the final
-arbiter of truth regarding its own functionality.
-
-The file PCL-ENV.LISP defines some low-level facilities to integrate PCL into
-the XeroxLisp environment.  The first order of business is teaching the
-FileManager (nee FilePackage) about CLOS defineing forms.  This in turn brings
-us to the issue of names.
-
-
-o  Names and the FileManager
-
-For the FileManager to keep track of defining forms, it needs to know how to
-extract a (unique) name and FileManager type from the form.  PCL-ENV includes
-FileManager support for the definers DEFCLASS, DEFGENERIC, and DEFMETHOD.
-
-DEFCLASS
-The name of a DEFCLASS form is the name of the class defined by the form.  The
-FileManager type is PCL::CLASSES.  There is a FileManager "undefiner" provided
-for DEFCLASS.
-
-DEFGENERIC
-The name of a DEFGENERIC form is the name of the generic-function defined by the
-form.  The FileManager type is PCL::GENERIC-FUNCTIONS.
-
-DEFMETHOD
-The name of a DEFMETHOD form is a list of the form
-(<gf-name> {<qualifier>}* ({<specializer>*})).  The FileManager type is
-PCL::METHODS.  There is a FileManager "undefiner" provided for DEFMETHOD.
-However, note that if a generic-function was created as a side-effect of the
-DEFMETHOD, the undefiner will leave the generic-function defined (albet with no
-methods).
-
-When editing, it would be onerous to require the programmer to type in the full name of a
-method.  PCL-ENV arranges it so that (ED <gf-name>) will ask the programmer
-which method on that generic-function should be edited.  (If there is only one
-method, it is assumed that that is the method to be edited.)  As of the
-Victoria-Day release, EQL specialized methods are handled correctly.
-
-
-o  Inspecting CLOS objects (and metaobjects)
-
-PCL-ENV defines a protocol that is used to inspect objects, and arranges that
-the standard INSPECT function uses this protocol.  Programmers can use this
-protocol by defining additional methods on the following generic-functions.
-
-INSPECT-SLOT-NAMES object
-Returns a list of "slots" to include in the inspector.  The default method
-returns a list of all slots on the object.
-
-INSPECT-SLOT-VALUE object slot-name
-Returns the value to associated with the slot-name in the inspector.  Slot-name
-is one of the items returned by INSPECT-SLOT-NAMES.  The default method returns
-(SLOT-VALUE object slot-name).
-
-INSPECT-SETF-SLOT-VALUE object slot-name new-value
-Sets the value associated with the slot-name in the inspector.  Slot-name is one
-of the items returned by INSPECT-SLOT-NAMES.  The default method executes
-(SETF (SLOT-VALUE object slot-name) new-value).
-
-INSPECT-TITLE object inspect-window
-Returns the title to use in the inspect-window when inspecting object.  The
-default returns the string "Inspecting the class <class-name>" when the object
-is a class, or "Inspecting a <class-name>" otherwise.
-
-
-o  Debugging and the Stack
-
-Debugging in PCL is complicated by generic-functions and methods appear on the
-stack not as single objects, but as collections of functions that the programmer
-did not directly call.  PCL-ENV redefines a number of internal debugger
-functions to simplify the presentation of the stack, and allow the programmer to
-access to the original defining forms from the stack.  These changes only affect
-the "short" display backtrace (brought up by BT in a break window); the full
-backtrace (brought up by BT!) is unaffected.
-
-
-o  Misc
-
-Prettyprinting
-
-The support for standard Prettyprinting is pretty minimal.  Only DEFMETHOD,
-DEFCLASS, WITH-ACCESSORS, and WITH-SLOTS are supported, and they aren't really
-done right.  Thanks to Harley Davis, PCL-ENV defines SEdit pretty-print specs
-for the forms DEFCLASS, DEFMETHOD, DEFGENERIC, GENERIC-FLET, GENERIC-LABELS,
-CALL-NEXT-METHOD, SYMBOL-MACROLET, WITH-ACCESSORS, WITH-SLOTS, and
-MAKE-INSTANCE.
-
-?=
-
-The function SMARTARGLIST is changed to return appropriate values for the
-arglists of generic-functions.  The macros DEFCLASS and DEFMETHOD have "pretty"
-arglists defined.
-
-PrettyFileIndex
-
-Again thanks to Harley Davis, PCL-ENV teaches PRETTY-FILE-INDEX about classes,
-methods, and accessors.  The variables PCL::*PFI-INDEX-ACCESSORS* and
-PCL::*PFI-METHOD-INDEX* may be changed by the user to tailor the computation of
-the file index.  Note that the file PRETTY-FILE-INDEX must be loaded before
-PCL-ENV for this to take effect.
-
-
---- smL								25-May-89
-
diff --git a/pcl/pclcom.lisp b/pcl/pclcom.lisp
deleted file mode 100644
index 6a95674bc46e4aef42baaf191dd4d89295c7a945..0000000000000000000000000000000000000000
--- a/pcl/pclcom.lisp
+++ /dev/null
@@ -1,9 +0,0 @@
-;;I think this isn't used; instead, "target:tools/pclcom.lisp" is used.
-(setq ext:*gc-verbose* nil)
-(setq c:*suppress-values-declaration* t)
-(setf (search-list "pcl:") '("build:pcl/"))
-(load "pcl:defsys")
-(in-package "PCL")
-(import 'kernel:funcallable-instance-p)
-(with-compilation-unit ()
-  (pcl::compile-pcl))
diff --git a/pcl/pclload.lisp b/pcl/pclload.lisp
deleted file mode 100644
index c35579e92f754e6079b879630662ffcb9d870d3b..0000000000000000000000000000000000000000
--- a/pcl/pclload.lisp
+++ /dev/null
@@ -1,10 +0,0 @@
-(in-package "PCL")
-(import 'kernel:funcallable-instance-p)
-(load "pcl:defsys")
-(load-pcl)
-
-;; hack, hack...
-#+nil
-(ignore-errors
- (with-output-to-string (*standard-output*)
-   (describe #'print-object)))
diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp
deleted file mode 100644
index b09f2f47a3bf5add580cba95c1a1ed49b951d4bf..0000000000000000000000000000000000000000
--- a/pcl/pkg.lisp
+++ /dev/null
@@ -1,366 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package ':walker :use '(:lisp))
-
-(export '(define-walker-template
-	  walk-form
-	  walk-form-expand-macros-p
-	  nested-walk-form
-	  variable-lexical-p
-	  variable-special-p
-	  variable-globally-special-p
-	  *variable-declarations*
-	  variable-declaration
-	  macroexpand-all
-	  ))
-
-(in-package :iterate :use '(:lisp :walker))
-
-(export '(iterate iterate* gathering gather with-gathering interval elements 
-	  list-elements list-tails plist-elements eachtime while until 
-	  collecting joining maximizing minimizing summing 
-	  *iterate-warnings*))
-
-(in-package :pcl :use '(:lisp :walker :iterate))
-
-;;;
-;;; Some CommonLisps have more symbols in the Lisp package than the ones that
-;;; are explicitly specified in CLtL.  This causes trouble. Any Lisp that has
-;;; extra symbols in the Lisp package should shadow those symbols in the PCL
-;;; package.
-;;;
-#+TI
-(shadow '(string-append once-only destructuring-bind
-	  memq assq delq neq true false
-	  without-interrupts
-	  defmethod)
-	*the-pcl-package*)
-
-#+CMU
-(shadow '(destructuring-bind)
-        *the-pcl-package*)
-
-#+GCLisp
-(shadow '(string-append memq assq delq neq make-instance)
-	*the-pcl-package*)
-
-#+Genera
-(shadowing-import '(zl:arglist zwei:indentation) *the-pcl-package*)
-
-#+Lucid 
-(import '(#-LCL3.0 system:arglist #+LCL3.0 lcl:arglist
-	  system:structurep system:structure-type system:structure-length)
-	*the-pcl-package*)
-  
-#+lucid
-(#-LCL3.0 progn #+LCL3.0 lcl:handler-bind 
-    #+LCL3.0 ((lcl:warning #'(lambda (condition)
-			       (declare (ignore condition))
-			       (lcl:muffle-warning))))
-(let ((importer
-        #+LCL3.0 #'sys:import-from-lucid-pkg
-	#-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID")))
-		   (if (and x (fboundp x))
-		       (symbol-function x)
-		       ;; Only the #'(lambda (x) ...) below is really needed, 
-		       ;;  but when available, the "internal" function 
-		       ;;  'import-from-lucid-pkg' provides better checking.
-		       #'(lambda (name)
-			   (import (intern name "LUCID")))))))
-  ;;
-  ;; We need the following "internal", undocumented Lucid goodies:
-  (mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE"
-		   #-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE"))
-
-  ;;
-  ;; For without-interrupts.
-  ;; 
-  #+LCL3.0
-  (mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER"))
-
-  ;;
-  ;; We import the following symbols, because in 2.1 Lisps they have to be
-  ;;  accessed as SYS:<foo>, whereas in 3.0 lisps, they are homed in the
-  ;;  LUCID-COMMON-LISP package.
-  (mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*"))
-  ;;
-  ;; We import the following symbols, because in 2.1 Lisps they have to be
-  ;;  accessed as LUCID::<foo>, whereas in 3.0 lisps, they have to be
-  ;;  accessed as SYS:<foo>
-  (mapc importer '(
-		   "NEW-STRUCTURE"   	"STRUCTURE-REF"
-		   "STRUCTUREP"         "STRUCTURE-TYPE"  "STRUCTURE-LENGTH"
-		   "PROCEDUREP"     	"PROCEDURE-SYMBOL"
-		   "PROCEDURE-REF" 	"SET-PROCEDURE-REF" 
-		   ))
-; ;;
-; ;;  The following is for the "patch" to the general defstruct printer.
-; (mapc importer '(
-; 	           "OUTPUT-STRUCTURE" 	  "DEFSTRUCT-INFO"
-;		   "OUTPUT-TERSE-OBJECT"  "DEFAULT-STRUCTURE-PRINT" 
-;		   "STRUCTURE-TYPE" 	  "*PRINT-OUTPUT*"
-;		   ))
-  ;;
-  ;; The following is for a "patch" affecting compilation of %logand&.
-  ;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas
-  ;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS
-  ;; on *FEATURES*, so this conditionalizes correctly for APOLLO.
-  #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) 
-  (mapc importer '("COPY-STRUCTURE"  "GET-FDESC"  "SET-FDESC"))
-  
-  nil))
-
-#+kcl
-(progn
-(import '(si:structurep si:structure-def si:structure-ref))
-(shadow 'lisp:dotimes)
-)
-#+kcl
-(in-package "SI")
-#+kcl
-(export '(%structure-name
-          %compiled-function-name
-          %set-compiled-function-name
-	  %instance-ref
-	  %set-instance-ref))
-#+kcl
-(in-package 'pcl)
-
-#+cmu (shadow 'lisp:dotimes)
-
-#+cmu
-(import '(kernel:funcallable-instance-p ext:structurep)
-	*the-pcl-package*)
-
-
-(shadow 'documentation)
-
-
-;;;						
-;;; These come from the index pages of 88-002R.
-;;;
-;;;
-(eval-when (compile load eval)  
-  
-(defvar *exports* '(add-method
-		    built-in-class
-		    call-method
-		    call-next-method
-		    change-class
-		    class-name
-		    class-of
-		    compute-applicable-methods
-		    defclass
-		    defgeneric
-		    define-method-combination
-		    defmethod
-		    ensure-generic-function
-		    find-class
-		    find-method
-		    function-keywords
-		    generic-flet
-		    generic-labels
-		    initialize-instance
-		    invalid-method-error
-		    make-instance
-		    make-instances-obsolete
-		    method-combination-error
-		    method-qualifiers
-		    next-method-p
-		    no-applicable-method
-		    no-next-method
-		    print-object
-		    reinitialize-instance
-		    remove-method
-		    shared-initialize
-		    slot-boundp
-		    slot-exists-p
-		    slot-makunbound
-		    slot-missing
-		    slot-unbound
-		    slot-value
-		    standard
-		    standard-class
-		    standard-generic-function
-		    standard-method
-		    standard-object
-		    structure-class
-		    #-cmu symbol-macrolet
-		    update-instance-for-different-class
-		    update-instance-for-redefined-class
-		    with-accessors
-		    with-added-methods
-		    with-slots
-		    ))
-
-);eval-when 
-
-#-(or KCL IBCL CMU)
-(export *exports* *the-pcl-package*)
-
-#+CMU
-(export '#.*exports* *the-pcl-package*)
-
-#+(or KCL IBCL)
-(mapc 'export (list *exports*) (list *the-pcl-package*))
-
-
-(eval-when (compile load eval)  
-  
-(defvar *class-exports*
-        '(standard-instance
-          funcallable-standard-instance
-          generic-function
-          standard-generic-function
-          method
-          standard-method
-          standard-accessor-method
-          standard-reader-method
-          standard-writer-method
-          method-combination
-          slot-definition
-          direct-slot-definition
-          effective-slot-definition
-          standard-slot-definition
-          standard-direct-slot-definition
-          standard-effective-slot-definition
-          specializer
-          eql-specializer
-          built-in-class
-          forward-referenced-class
-          standard-class
-          funcallable-standard-class))
-
-(defvar *chapter-6-exports*
-        '(add-dependent
-          add-direct-method
-          add-direct-subclass
-          add-method
-          allocate-instance
-          class-default-initargs
-          class-direct-default-initargs
-          class-direct-slots
-          class-direct-subclasses
-          class-direct-superclasses
-          class-finalized-p
-          class-precedence-list
-          class-prototype
-          class-slots
-          compute-applicable-methods
-          compute-applicable-methods-using-classes
-          compute-class-precedence-list
-          compute-discriminating-function
-          compute-effective-method
-          compute-effective-slot-definition
-          compute-slots
-          direct-slot-definition-class
-          effective-slot-definition-class
-          ensure-class
-          ensure-class-using-class
-          ensure-generic-function
-          ensure-generic-function-using-class
-          eql-specializer-instance
-          extract-lambda-list
-          extract-specializer-names
-          finalize-inheritance
-          find-method-combination
-          funcallable-standard-instance-access
-          generic-function-argument-precedence-order
-          generic-function-declarations
-          generic-function-lambda-list
-          generic-function-method-class
-          generic-function-method-combination
-          generic-function-methods
-          generic-function-name
-          intern-eql-specializer
-          make-instance
-          make-method-lambda
-          map-dependents
-          method-function
-          method-generic-function
-          method-lambda-list
-          method-specializers
-          method-qualifiers
-          accessor-method-slot-definition
-          reader-method-class
-          remove-dependent
-          remove-direct-method
-          remove-direct-subclass
-          remove-method
-          set-funcallable-instance-function
-          slot-boundp-using-class
-          slot-definition-allocation
-          slot-definition-initargs
-          slot-definition-initform
-          slot-definition-initfunction
-          slot-definition-location
-          slot-definition-name
-          slot-definition-readers
-          slot-definition-writers
-          slot-definition-type
-          slot-makunbound-using-class
-          slot-value-using-class
-          specializer-direct-generic-function
-          specializer-direct-methods
-          standard-instance-access
-          update-dependent
-          validate-superclass
-          writer-method-class
-          ))
-
-);eval-when 
-
-#-(or KCL IBCL)
-(export *class-exports* *the-pcl-package*)
-
-#+(or KCL IBCL)
-(mapc 'export (list *class-exports*) (list *the-pcl-package*))
-
-#-(or KCL IBCL)
-(export *chapter-6-exports* *the-pcl-package*)
-
-#+(or KCL IBCL)
-(mapc 'export (list *chapter-6-exports*) (list *the-pcl-package*))
-
-(defvar *slot-accessor-name-package*
-  (or (find-package :slot-accessor-name)
-      (make-package :slot-accessor-name 
-		    :use '()
-		    :nicknames '(:s-a-n))))
-
-#+kcl
-(when (get 'si::basic-wrapper 'si::s-data)
-  (import (mapcar #'(lambda (s) (intern (symbol-name s) "SI"))
-		  '(:copy-structure-header :swap-structure-contents :set-structure-def
-		    :%instance-ref :%set-instance-ref
-		    
-		    :cache-number-vector :cache-number-vector-length
-		    :wrapper-cache-number-adds-ok :wrapper-cache-number-length
-		    :wrapper-cache-number-mask :wrapper-cache-number-vector-length
-		    :wrapper-layout :wrapper-cache-number-vector
-		    :wrapper-state :wrapper-class :wrapper-length))))
diff --git a/pcl/plap.lisp b/pcl/plap.lisp
deleted file mode 100644
index 622dd5c3cf04120c7158ce990ff0d31eaf9dfe4c..0000000000000000000000000000000000000000
--- a/pcl/plap.lisp
+++ /dev/null
@@ -1,369 +0,0 @@
-;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package 'pcl)
-
-;;;
-;;; The portable implementation of the LAP assembler.
-;;;
-;;; The portable implementation of the LAP assembler works by translating
-;;; LAP code back into Lisp code and then compiling that Lisp code.  Note
-;;; that this implementation is actually going to get a lot of use.  Some
-;;; implementations (KCL) won't implement a native LAP assembler at all.
-;;; Other implementations may not implement native LAP assemblers for all
-;;; of their ports.  All of this implies that this portable LAP assembler
-;;; needs to generate the best code it possibly can.
-;;; 
-
-
-;;;
-;;; 
-;;;
-
-(defmacro lap-case (operand &body cases)
-  (once-only (operand)
-    `(ecase (car ,operand)
-       ,@(mapcar #'(lambda (case)
-		     `(,(car case)
-		       (apply #'(lambda ,(cadr case) ,@(cddr case))
-			      (cdr ,operand))))
-		 cases))))
-
-(defvar *lap-args*)
-(defvar *lap-rest-p*)
-(defvar *lap-i-regs*)
-(defvar *lap-v-regs*)
-(defvar *lap-fv-regs*)
-(defvar *lap-t-regs*)
-
-(defvar *lap-optimize-declaration* '#.*optimize-speed*)
-
-
-(eval-when (load eval)
-  (setq *make-lap-closure-generator*
-	#'(lambda (closure-var-names arg-names index-regs 
-		   vector-regs fixnum-vector-regs t-regs lap-code)
-	    (compile-lambda
-	      (make-lap-closure-generator-lambda
-		closure-var-names arg-names index-regs 
-		vector-regs fixnum-vector-regs t-regs lap-code)))
-
-	*precompile-lap-closure-generator*
-	#'(lambda (cvars args i-regs v-regs fv-regs t-regs lap)
-	    `(function
-	       ,(make-lap-closure-generator-lambda cvars args i-regs 
-		 v-regs fv-regs t-regs lap)))
-	*lap-in-lisp*
-	#'(lambda (cvars args iregs vregs fvregs tregs lap)
-	    (declare (ignore cvars args))
-	    (make-lap-prog
-	      iregs vregs fvregs tregs 
-	      (flatten-lap lap ;(opcode :label 'exit-lap-in-lisp)
-			   )))))
-
-(defun make-lap-closure-generator-lambda (cvars args i-regs v-regs fv-regs t-regs lap)
-  (let* ((rest (memq '&rest args))
-	 (ldiff (and rest (ldiff args rest))))
-    (when rest (setq args (append ldiff '(&rest .lap-rest-arg.))))
-    (let* ((*lap-args* (if rest ldiff args))
-	   (*lap-rest-p* (not (null rest))))
-      `(lambda ,cvars
-	 #'(lambda ,args
-	     #-CMU (declare ,*lap-optimize-declaration*)
-	     #-CMU ,(make-lap-prog-internal i-regs v-regs fv-regs t-regs lap)
-	     #+CMU
-             ;;
-             ;; Use LOCALLY instead of a declare on the lambda so that we don't
-             ;; suppress arg count checking...
-             (locally (declare ,*lap-optimize-declaration*)
-	       ,(make-lap-prog-internal i-regs v-regs fv-regs t-regs lap)))))))
-
-(defun make-lap-prog (i-regs v-regs fv-regs t-regs lap)
-  (let* ((*lap-args* 'lap-in-lisp)
-	 (*lap-rest-p* 'lap-in-lisp))
-    (make-lap-prog-internal i-regs v-regs fv-regs t-regs lap)))
-
-(defun make-lap-prog-internal (i-regs v-regs fv-regs t-regs lap)
-  (let* ((*lap-i-regs* i-regs)
-	 (*lap-v-regs* v-regs)
-	 (*lap-fv-regs* fv-regs)
-	 (*lap-t-regs* t-regs)
-	 (code (mapcar #'lap-opcode lap)))
-    `(prog ,(mapcar #'(lambda (reg)
-			`(,(lap-reg reg)
-			  ,(lap-reg-initial-value-form reg)))
-		    (append i-regs v-regs fv-regs t-regs))
-	   (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*))
-		    (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*))
-		    (type #+structure-wrapper cache-number-vector
-		          #-structure-wrapper (simple-array fixnum)
-		          ,@(mapcar #'lap-reg *lap-fv-regs*))
-	            #-cmu ,*lap-optimize-declaration*)
-	   ,.code)))
-
-(defvar *empty-vector* '#())
-(defvar *empty-fixnum-vector*
-  (make-array 8
-	      :element-type 'fixnum
-	      :initial-element 0))
- 
-(defun lap-reg-initial-value-form (reg)
-  (cond ((member reg *lap-i-regs*) 0)
-        ((member reg *lap-v-regs*) '*empty-vector*)
-        ((member reg *lap-fv-regs*) '*empty-fixnum-vector*)
-        ((member reg *lap-t-regs*) nil)
-        (t
-         (error "What kind of register is ~S?" reg))))
-
-(defun lap-opcode (opcode)    
-  (lap-case opcode
-    (:move (from to)
-     `(setf ,(lap-operand to) ,(lap-operand from)))
-      
-    ((:eq :neq :fix=) (arg1 arg2 label)
-     `(when ,(lap-operands (ecase (car opcode)
-			     (:eq 'eq) (:neq 'neq) (:fix= 'RUNTIME\ FIX=))
-			   arg1
-			   arg2)
-	(go ,label)))
-
-    ((:izerop) (arg label)
-     `(when ,(lap-operands 'RUNTIME\ IZEROP arg)
-	(go ,label)))
-
-    (:std-instance-p (from label)
-     `(when ,(lap-operands 'RUNTIME\ STD-INSTANCE-P from) (go ,label)))
-    (:fsc-instance-p (from label)
-     `(when ,(lap-operands 'RUNTIME\ FSC-INSTANCE-P from) (go ,label)))
-    (:built-in-instance-p (from label)
-     (declare (ignore from))
-     `(when ,t (go ,label)))			                ;***
-    (:structure-instance-p (from label)
-     `(when ,(lap-operands 'RUNTIME\ STRUCTURE-INSTANCE-P from) (go ,label)))	;***
-    
-    ((:jmp :emf-call) (fn)
-     (if (eq *lap-args* 'lap-in-lisp)
-	 (error "Can't do a :JMP in LAP-IN-LISP.")
-	 `(return
-	    ,(if (eq (car opcode) :jmp)
-		 (if *lap-rest-p*
-		     `(RUNTIME\ APPLY ,(lap-operand fn) ,@*lap-args* .lap-rest-arg.)
-		     `(RUNTIME\ FUNCALL ,(lap-operand fn) ,@*lap-args*))
-		 `(RUNTIME\ EMF-CALL ,(lap-operand fn) ,*lap-rest-p* ,@*lap-args*
-		                     ,@(when *lap-rest-p* `(.lap-rest-arg.)))))))
-
-    (:return (value)
-     `(return ,(lap-operand value)))
-      
-    (:label (label) label)
-    (:go   (label)  `(go ,label))
-
-    (:exit-lap-in-lisp () `(go exit-lap-in-lisp))
-    
-    (:break ()      `(break))
-    (:beep  ()      #+Genera`(zl:beep))
-    (:print (val)   (lap-operands 'print val))
-    ))
-
-(defun lap-operand (operand)
-  (lap-case operand
-    (:reg (n) (lap-reg n))
-    (:cdr (reg) (lap-operands 'cdr reg))
-    ((:cvar :arg) (name) name)
-    (:constant (c) `',c)
-    ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper
-      :built-in-or-structure-wrapper :std-slots :fsc-slots
-      :wrapper-cache-number-vector)
-     (x)
-     (lap-operands (ecase (car operand)
-		     (:std-wrapper       'RUNTIME\ STD-WRAPPER)
-		     (:fsc-wrapper       'RUNTIME\ FSC-WRAPPER)
-		     (:built-in-wrapper  'RUNTIME\ BUILT-IN-WRAPPER)
-		     (:structure-wrapper 'RUNTIME\ STRUCTURE-WRAPPER)
-		     (:built-in-or-structure-wrapper
-		                         'RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER)
-		     (:std-slots         'RUNTIME\ STD-SLOTS)
-		     (:fsc-slots         'RUNTIME\ FSC-SLOTS)
-		     (:wrapper-cache-number-vector 
-		      'RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR))
-		   x))
-    
-     
-    (:i1+     (index)         (lap-operands 'RUNTIME\ I1+ index))
-    (:i+      (index1 index2) (lap-operands 'RUNTIME\ I+ index1 index2))
-    (:i-      (index1 index2) (lap-operands 'RUNTIME\ I- index1 index2))
-    (:ilogand (index1 index2) (lap-operands 'RUNTIME\ ILOGAND index1 index2))
-    (:ilogxor (index1 index2) (lap-operands 'RUNTIME\ ILOGXOR index1 index2))
-    
-    (:iref    (vector index)       (lap-operands 'RUNTIME\ IREF vector index))
-    (:iset    (vector index value) (lap-operands 'RUNTIME\ ISET vector index value))
-
-    (:instance-ref (vector index)
-		   (lap-operands 'RUNTIME\ INSTANCE-REF vector index))
-    (:instance-set (vector index value)
-		   (lap-operands 'RUNTIME\ INSTANCE-SET vector index value))
-
-    (:cref   (vector i)       `(RUNTIME\ SVREF ,(lap-operand vector) ,i))
-    (:lisp-variable (symbol) symbol)
-    (:lisp          (form)   form)
-    ))
-
-(defun lap-operands (fn &rest regs)
-  (cons fn (mapcar #'lap-operand regs)))
-
-(defun lap-reg (n) (intern (format nil "REG~D" n) *the-pcl-package*))
-
-
-;;;
-;;; Runtime Implementations of the operands and opcodes.
-;;;
-;;; In those ports of PCL which choose not to completely re-implement the
-;;; LAP code generator, it may still be provident to consider reimplementing
-;;; one or more of these to get the compiler to produce better code.  That
-;;; is why they are split out.
-;;; 
-(proclaim '(declaration pcl-fast-call))
-
-(defmacro RUNTIME\ FUNCALL (fn &rest args)
-  #+CMU `(funcall (the function ,fn) ,.args)
-  #-CMU `(funcall ,fn ,.args))
-
-(defmacro RUNTIME\ APPLY (fn &rest args)
-  #+CMU `(apply (the function ,fn) ,.args)
-  #-CMU `(apply ,fn ,.args))
-
-(defmacro RUNTIME\ EMF-CALL (emf restp &rest required-args+rest-arg)
-  `(invoke-effective-method-function ,emf ,restp ,@required-args+rest-arg))
-
-(defmacro RUNTIME\ STD-WRAPPER (x)
-  `(std-instance-wrapper ,x))
-
-(defmacro RUNTIME\ FSC-WRAPPER (x)
-  `(fsc-instance-wrapper ,x))
-
-(defmacro RUNTIME\ BUILT-IN-WRAPPER (x)
-  `(built-in-wrapper-of ,x))
-
-(defmacro RUNTIME\ STRUCTURE-WRAPPER (x)
-  `(built-in-or-structure-wrapper ,x))
-
-(defmacro RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER (x)
-  `(built-in-or-structure-wrapper ,x))
-
-(defmacro RUNTIME\ STRUCTURE-INSTANCE-P (x)
-  `(structure-instance-p ,x))
-
-(defmacro RUNTIME\ STD-SLOTS (x)
-  `(std-instance-slots (the std-instance ,x)))
-
-(defmacro RUNTIME\ FSC-SLOTS (x)
-  `(fsc-instance-slots ,x))
-
-(defmacro RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR (x)
-  `(wrapper-cache-number-vector ,x))
-
-(defmacro RUNTIME\ STD-INSTANCE-P (x)
-  `(std-instance-p ,x))
-
-(defmacro RUNTIME\ FSC-INSTANCE-P (x)
-  `(fsc-instance-p ,x))
-
-(defmacro RUNTIME\ IZEROP (x)
-  `(zerop (the fixnum ,x)))
-
-(defmacro RUNTIME\ FIX= (x y)
-  `(= (the fixnum ,x) (the fixnum ,y)))
-
-;;;
-;;; These are the implementations of the index operands.  The portable
-;;; assembler generates Lisp code that uses these macros.  Even though
-;;; the variables holding the arguments and results have type declarations
-;;; on them, we put type declarations in here.
-;;;
-;;; Some compilers are so stupid...
-;;;
-(defmacro RUNTIME\ IREF (vector index)
-  #-structure-wrapper
-  `(svref (the simple-vector ,vector) (the fixnum ,index))
-  #+structure-wrapper
-  `(aref ,vector (the fixnum ,index)))
-
-(defmacro RUNTIME\ ISET (vector index value)
-  `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value))
-
-(defmacro RUNTIME\ INSTANCE-REF (vector index)
-  #-new-kcl-wrapper
-  `(svref (the simple-vector ,vector) (the fixnum ,index))
-  #+new-kcl-wrapper
-  `(%instance-ref ,vector (the fixnum ,index)))
-
-(defmacro RUNTIME\ INSTANCE-SET (vector index value)
-  #-new-kcl-wrapper
-  `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value)
-  #+new-kcl-wrapper
-  `(setf (%instance-ref ,vector (the fixnum ,index)) ,value))
-
-(defmacro RUNTIME\ SVREF (vector fixnum)
-  #-structure-wrapper
-  `(svref (the simple-vector ,vector) (the fixnum ,fixnum))
-  #+structure-wrapper
-  `(aref ,vector (the fixnum ,fixnum)))
-
-(defmacro RUNTIME\ I+ (index1 index2)
-  `(the fixnum (+ (the fixnum ,index1) (the fixnum ,index2))))
-
-(defmacro RUNTIME\ I- (index1 index2)  
-  `(the fixnum (- (the fixnum ,index1) (the fixnum ,index2))))
-
-(defmacro RUNTIME\ I1+ (index)
-  `(the fixnum (1+ (the fixnum ,index))))
-
-(defmacro RUNTIME\ ILOGAND (index1 index2)
-  #-Lucid `(the fixnum (logand (the fixnum ,index1) (the fixnum ,index2)))
-  #+Lucid `(%logand ,index1 ,index2))
-
-(defmacro RUNTIME\ ILOGXOR (index1 index2)
-  `(the fixnum (logxor (the fixnum ,index1) (the fixnum ,index2))))
-
-;;;
-;;; In the portable implementation, indexes are just fixnums.
-;;; 
-
-(defconstant index-value-limit most-positive-fixnum)
-
-(defun index-value->index (index-value) index-value)
-(defun index->index-value (index) index)
-
-(defun make-index-mask (cache-size line-size)
-  (let ((cache-size-in-bits (floor (log cache-size 2)))
-	(line-size-in-bits (floor (log line-size 2)))
-	(mask 0))
-    (dotimes (i cache-size-in-bits) (setq mask (dpb 1 (byte 1 i) mask)))
-    (dotimes (i line-size-in-bits)  (setq mask (dpb 0 (byte 1 i) mask)))
-    mask))
-
-
diff --git a/pcl/precom1.lisp b/pcl/precom1.lisp
deleted file mode 100644
index 0c550d95d6a308b367e7a9f384bbedc668c63332..0000000000000000000000000000000000000000
--- a/pcl/precom1.lisp
+++ /dev/null
@@ -1,51 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-;;;
-;;; pre-allocate generic function caches.  The hope is that this will put
-;;; them nicely together in memory, and that that may be a win.  Of course
-;;; the first gc copy will probably blow that out, this really wants to be
-;;; wrapped in something that declares the area static.
-;;;
-;;; This preallocation only creates about 25% more caches than PCL itself
-;;; uses need.  Some ports may want to preallocate some more of these.
-;;; 
-(eval-when (load)
-  (flet ((allocate (n size)
-	   (mapcar #'free-cache-vector
-		   (mapcar #'get-cache-vector
-			   (make-list n :initial-element size)))))
-    (allocate 128 4)
-    (allocate 64 8)
-    (allocate 64 9)
-    (allocate 32 16)
-    (allocate 16 17)
-    (allocate 16 32)
-    (allocate 1  64)))
-
diff --git a/pcl/precom2.lisp b/pcl/precom2.lisp
deleted file mode 100644
index 97ab8f9ebfa9566267107039f105a1cd76eebd34..0000000000000000000000000000000000000000
--- a/pcl/precom2.lisp
+++ /dev/null
@@ -1,31 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-(precompile-random-code-segments pcl)
-
diff --git a/pcl/precom4.lisp b/pcl/precom4.lisp
deleted file mode 100644
index fe13ee147afb36448d55c2cfa8c4aab1451e4412..0000000000000000000000000000000000000000
--- a/pcl/precom4.lisp
+++ /dev/null
@@ -1,32 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package 'pcl)
-
-(precompile-function-generators pcl)		;this is half of a call to
-						;precompile-random-code-segments
-
diff --git a/pcl/pyr-low.lisp b/pcl/pyr-low.lisp
deleted file mode 100644
index 935a7d3433aee9e9c577ea7e11247511fded56fd..0000000000000000000000000000000000000000
--- a/pcl/pyr-low.lisp
+++ /dev/null
@@ -1,50 +0,0 @@
-;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;; 
-;;; This is the Pyramid version of low.lisp -- it runs with versions 1.1
-;;; and newer -- Created by David Bein Mon May  4 11:22:30 1987
-;;;
-(in-package 'pcl)
-
-  ;;   
-;;;;;; Cache No's
-  ;;  
-
-;;; The purpose behind the shift is that the bottom 2 bits are always 0
-;;; We use the same scheme for symbols and objects although a good
-;;; case may be made for shifting objects more since they will
-;;; be aligned differently...
-
-;(defmacro symbol-cache-no (symbol mask)
-;  `(logand (the fixnum (ash (lisp::%sp-make-fixnum ,symbol) -2))
-;	  (the fixnum ,mask)))
-
-(defmacro object-cache-no (symbol mask)
-  `(logand (the fixnum (ash (lisp::%sp-make-fixnum ,symbol) -2))
-	  (the fixnum ,mask)))
-
-
-
diff --git a/pcl/pyr-patches.lisp b/pcl/pyr-patches.lisp
deleted file mode 100644
index 32647fe97a331f75b302ded7531e16266ebb3ada..0000000000000000000000000000000000000000
--- a/pcl/pyr-patches.lisp
+++ /dev/null
@@ -1,9 +0,0 @@
-(in-package 'pcl)
-
-;;; This next kludge disables macro memoization (the default) since somewhere
-;;; in PCL, the memoization is getting in the way.
-
-(eval-when (load eval)
-    (format t "~&;;; Resetting *MACROEXPAND-HOOK* to #'FUNCALL~%")
-    (setq lisp::*macroexpand-hook* #'funcall))
-
diff --git a/pcl/quadlap.lisp b/pcl/quadlap.lisp
deleted file mode 100644
index 695222bd35f1e91e59696eab80d022a41df7d073..0000000000000000000000000000000000000000
--- a/pcl/quadlap.lisp
+++ /dev/null
@@ -1,619 +0,0 @@
-;;				-[Thu Mar  1 10:54:27 1990 by jkf]-
-;; pcl to quad translation
-;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.5 1992/11/09 15:21:37 ram Exp $
-;;
-;; copyright (c) 1990 Franz Inc.
-;;
-(in-package :compiler)
-
-
-
-
-(defvar *arg-to-treg* nil)
-(defvar *cvar-to-index* nil)
-(defvar *reg-array* nil)
-(defvar *closure-treg* nil)
-(defvar *nargs-treg* nil)
-
-(defvar *debug-sparc* nil)
-
-(defmacro pcl-make-lambda (&key required)
-  `(list 'lambda nil :unknown-type 0 compiler::.function-level. 
-	,required nil nil nil nil nil nil nil nil nil 
-	nil 'compiler::none nil nil nil 
-	nil nil nil nil nil nil 0 nil))
-
-(defmacro pcl-make-varrec (&key name loc contour-level)
-  `(list ,name nil 0 nil ,loc nil t compiler::.function-level. nil nil :unknown-type nil nil ,contour-level))
-
-(defmacro pcl-make-lap (&key lap constants cframe-size locals)
-  `(list nil ,constants ,lap nil nil ,cframe-size ,locals nil nil nil))
-
-
-(defstruct preg 
-  ;; pseudo reg descritpor
-  treg		; associated treg
-  index 	; :index if this is an index type reg
-  		; :vector if this is a vector type reg
-  )
-
-
-(defun pcl::excl-lap-closure-generator (closure-vars-names
-				   arg-names
-				   index-regs
-				   vector-regs
-				   fixnum-vector-regs
-				   t-regs
-				   lap-code)
-  (let ((function (pcl::excl-lap-closure-gen closure-vars-names
-				   arg-names
-				   index-regs
-				   (append vector-regs fixnum-vector-regs)
-				   t-regs
-				   lap-code)))
-    #'(lambda (&rest closure-vals)
-	(insert-closure-vals function closure-vals))))
-
-
-(defun pcl::excl-lap-closure-gen
-    (closure-vars-names arg-names index-regs vector-regs t-regs lap-code)
-  (let ((*quads* nil)
-	(*treg-num* 0)
-	(*all-tregs* nil)
-	(*bb-count* 0)
-	*treg-bv-size*
-	*treg-vector*
-	(*next-catch-frame* 0)
-	(*max-catch-frame* -1)
-	*catch-labels*
-	*top-label*
-	*mv-treg*
-	*mv-treg-target*
-	*zero-treg*
-	*nil-treg*
-	*bbs* *bb* lap
-	;; bbs
-	*cross-block-regs*
-	*const-tregs* *move-tregs*
-	*actuals*
-	*ignore-argcount*
-	*binds-specs*
-	*bvl-current-bv* ; for bitvector cacher
-	*bvl-used-bvs*
-	*bvl-index*
-	(*inhibit-call-count* t)
-	
-	; this fcn
-	*arg-to-treg*
-	*cvar-to-index* 
-	*reg-array*
-	minargs
-	maxargs
-	*closure-treg*
-
-	node
-	otherargregs
-	
-	*nargs-treg*
-	)
-
-    (if* *debug-sparc* 
-       then (format t ">>** << Generating sparc lap code~%"))
-    
-    (setq *nil-treg* 
-      #+allegro-v4.0 (new-reg :global t)
-      #-allegro-v4.0 (new-reg)
-      *mv-treg* (new-reg)
-      *mv-treg-target* (list *mv-treg*)
-      *zero-treg* (comp::new-reg))
-    
-    ; examine given args
-    
-    (setq minargs 0  maxargs 0)
-    (let (requireds)
-      (dolist (arg arg-names)
-	(if* (eq '&rest arg)
-	   then (setq maxargs nil)
-	   else (if* (null arg)
-		   then ; we want a name even though we won't use it
-			(setq arg (gensym)))
-		(incf minargs)
-		(incf maxargs)
-		(push (cons arg (new-reg)) *arg-to-treg*)
-		(push (pcl-make-varrec :name arg 
-				   :loc (cdr (car *arg-to-treg*))
-				   :contour-level 0)
-		      requireds)
-		))
-      (setq node (pcl-make-lambda :required  (nreverse requireds))))
-    (setq *arg-to-treg* (nreverse *arg-to-treg*))
-    
-    ; build closure vector list
-    (let ((index -1))
-      (dolist (cvar closure-vars-names)
-	(push (cons cvar (incf index)) *cvar-to-index*)))
-    
-    (let ((maxreg (max (apply #'max (cons -1 index-regs))
-		       (apply #'max (cons -1 vector-regs))
-		       (apply #'max (cons -1 t-regs)))))
-      (setq *reg-array* (make-array (1+ maxreg))))
-    
-    (dolist (index index-regs)
-      (setf (svref *reg-array* index)
-	(make-preg :treg (new-reg)
-		   :index :index)))
-    
-    (dolist (vector vector-regs)
-      (setf (svref *reg-array* vector) 
-	(make-preg :treg (new-reg)
-		   :index :vector)))
-    
-    (dolist (tr t-regs)
-      (setf (svref *reg-array* tr) (make-preg :treg (new-reg))))
-    
-
-    (if* closure-vars-names
-       then (setq *closure-treg* (new-reg)))
-    (setq *nargs-treg* (new-reg))
-        
-    ;; (md-allocate-global-tregs)
-    
-    ; function entry
-    (qe nop :arg :first-block)
-    (qe entry)
-    (qe argcount :arg (list minargs maxargs))
-    (qe lambda :d (mapcar #'cdr *arg-to-treg*))
-    (qe register :arg :nargs :d (list *nargs-treg*))
-
-    (if* *closure-treg*
-       then ; put the first closure vector in *closure-treg*
-	    (qe extract-closure-vec :d (list *closure-treg*))
-	    (let ((offsetreg (new-reg)))
-	      (qe const :arg (mdparam 'md-cons-car-adj) :d (list offsetreg))
-	      (qe ref :u (list *closure-treg* offsetreg) 
-		  :d (list *closure-treg*)
-		  :arg :long))
-	    )
-
-    (excl-gen-quads lap-code)
-
-    (if* *debug-sparc*
-       then (do-quad-list (quad next *quads*)
-	      (format t "~a~%" quad))
-
-	    (format t "basic blocks~%"))
-    
-    (setq *bbs* (qc-compute-basic-blocks *quads*))
-    
-    (excl::target-class-case
-     ((:r :m) (setq *actuals* (qc-compute-actuals *bbs*))))
-    
-    (qc-live-variable-analysis *bbs*)
-    
-    (setq *treg-bv-size* (* 16 (truncate (+ *treg-num* 15) 16)))
-      
-    (qc-build-treg-vector)
-    
-
-    (let ((*dump-bbs* nil)
-	  (r::*local-regs*
-	   ; use the in registers that aren't in use
-	   (append r::*local-regs*
-		   (if* maxargs
-		      then (nthcdr maxargs r::*in-regs* )))))
-      (unwind-protect
-	  (progn
-	    ; machine specific code generation
-	    (multiple-value-bind (lap-code literals size-struct locals)
-		#+(target-class r m e)
-		(progn
-		  #+allegro-v4.0 
-		  (md-codegen node *bbs*
-			      nil otherargregs)
-		  #-allegro-v4.0 
-		  (md-codegen node *bbs*
-			      *nil-treg* *mv-treg* *zero-treg*
-			      nil otherargregs))
-		  
-		#-(target-class r m e) (md-codegen node *bbs*)
-		(setq lap
-		  (pcl-make-lap :lap lap-code
-			    :constants literals
-			    :cframe-size size-struct
-			    :locals  locals)))
-
-	     
-	    lap)
-	(giveback-bvs)))
-    
-    #+ignore 
-    (progn (format t "sparc code pre optimization~%")
-	   (dolist (instr (lap-lap lap))
-	     (format t "> ~a~%" instr)))
-    (md-optimize lap) ; peephole optimize
-    (if* *debug-sparc*
-       then (format t "sparc code post optimization~%")
-	    (dolist (instr (lap-lap lap))
-	      (format t "> ~a~%" instr)))
-    (md-assemble lap)
-    (setq last-lap lap)
- 
-    (nl-runtime-make-a-fcnobj lap)))
-
-(defun qe-slot-access (operand offset dest)
-  ;; access a slot in a structure
-  (let ((temp (new-reg)))
-    (qe const :arg offset :d (list temp))
-    (qe ref :u (list (get-treg-of operand) temp) 
-	:d (list (get-treg-of dest))
-	:arg :long)))
-
-
-(defun get-treg-of (operand &optional res-operand)
-  ;; get the appropriate treg for the operand
-  (let ((prefer-treg (and res-operand (simple-get-treg-of res-operand))))
-    (if* (numberp operand)
-       then (let ((treg (new-reg)))
-	      (qe const :arg operand :d (list treg))
-	      treg)
-     elseif (consp operand)
-       then (ecase (car operand)
-	      (:reg 
-	       (preg-treg (svref *reg-array* (cadr operand))))
-	      (:arg 
-	       (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq))))
-		 (if* (null x)
-		    then (error "where is arg ~s" operand)
-		    else x)))
-	      (:cvar
-	       (let ((res-treg (or prefer-treg (new-reg)))
-		     (temp-treg (new-reg)))
-		 (qe const :arg (+ (mdparam 'md-svector-data0-adj)
-				   (* 4 (cdr (assoc (cadr operand)
-						    *cvar-to-index*
-						    :test #'eq))))
-		     :d (list temp-treg))
-		 (qe ref :u (list *closure-treg* temp-treg)
-		     :d (list res-treg)
-		     :arg :long)
-		 res-treg))
-	      (:constant
-	       (let ((treg (or prefer-treg (new-reg))))
-		 (qe const :arg (if* (fixnump (cadr operand))
-				   then (* 8 (cadr operand)) ; md!!
-				   else (cadr operand))
-		     :d (list treg))
-		 treg))
-	      (:index-constant
-	       ; operand invented by jkf to denote an index type constant
-	       (let ((treg (or prefer-treg (new-reg))))
-		 (qe const :arg (if* (fixnump (cadr operand))
-				   then (* 4 (cadr operand)) ; md!!
-				   else (cadr operand))
-		     :d (list treg))
-		 treg)))
-       else (error "bad operand: ~s" operand))))
-
-(defun simple-get-treg-of (operand)
-  ;; get the treg if it is so simple that we don't have to 
-  ;; emit any instructions to access it.
-  ;; return nil if we can't do it.
-  (if* (numberp operand)
-     then nil
-   elseif (consp operand)
-     then (case (car operand)
-	    (:reg 
-	     (preg-treg (svref *reg-array* (cadr operand))))
-	    (:arg 
-	     (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq))))
-	       (if* (null x)
-		  then nil
-		  else x))))
-	      
-     else nil))
-
-(defun index-p (operand)
-  ;; determine if the result of this operand is an index value
-  ;* it would be better if conversion between lisp values and
-  ;  index values were made explicit in the lap code
-  (and (consp operand)
-       (or (and (eq :reg (car operand))
-		(eq :index (preg-index (svref *reg-array* (cadr operand)))))
-	   (member (car operand)
-		   '(:i+ :i- :ilogand :ilogxor :i1+)
-		   :test #'eq))
-       t))
-
-(defun gen-index-treg (operand)
-  ;; return the non-index type operand in a index treg
-  (if* (and (consp operand)
-	    (eq ':constant (car operand)))
-     then (get-treg-of `(:index-constant ,(cadr operand)))
-     else (let ((treg (get-treg-of operand))
-		(new-reg (new-reg))
-		(shift-reg (new-reg)))
-	    (qe const :arg 1 :d (list shift-reg))
-	    (qe lsr :u (list treg shift-reg) :d (list new-reg))
-	    new-reg)))
-
-		
-	    
-  
-  
-(defun vector-preg-p (operand)
-  (and (consp operand)
-       (eq :reg (car operand))
-       (eq :vector (preg-index (svref *reg-array* (cadr operand))))))
-       
-	    
-	  
-(defun excl-gen-quads (laps)
-  ;; generate quads from the lap
-  (dolist (lap laps)
-    (if* *debug-sparc* then (format t ">> ~a~%" lap))
-    (block again
-      (let ((opcode (car lap))
-	    (op1    (cadr lap))
-	    (op2    (caddr lap)))
-	(case opcode
-	  (:move
-	   ; can be either simple (both args registers)
-	   ; or one arg can be complex and the other simple
-	   (case (car op2)
-	     ((:iref :instance-ref)
-	      ;; assume that this is a lisp store
-	      ;;(warn "assuming lisp store in ~s" lap)
-	      (let (op1-treg)
-		(if* (not (vector-preg-p (cadr op2)))
-		   then ; must offset before store
-			(error "must use vector register in ~s" lap)
-		   else (setq op1-treg (get-treg-of (cadr op2))))
-				       
-				      
-		
-		(qe set :u (list op1-treg
-				 (get-treg-of (caddr op2))
-				 (get-treg-of op1))
-		    :arg :lisp)
-		(return-from again)))
-	     (:cdr
-	      ;; it certainly is a lisp stoer
-	      (let (op1-treg const-reg)
-		(setq op1-treg (get-treg-of (cadr op2)))
-	        (setq const-reg (new-reg))
-		(qe const :arg (mdparam 'md-cons-cdr-adj) 
-		    :d (list const-reg))
-				       
-				      
-		
-		(qe set :u (list op1-treg
-				 const-reg
-				 (get-treg-of op1))
-		    :arg :lisp)
-		(return-from again))))
-	 
-	   ; the 'to'address is simple, the from address may not be
-	 
-	   (let ((index1 (index-p op1))
-		 (index2 (index-p op2))
-		 (vector1 (vector-preg-p op1))
-		 (vector2 (vector-preg-p op2)))
-	     (ecase (car op1)
-	       ((:reg :cvar :arg :constant :lisp-symbol)
-		(qe move 
-		    :u (list (get-treg-of op1 op2))
-		    :d (list (get-treg-of op2))))
-	       (:std-wrapper
-		(qe-slot-access (cadr op1) 
-				(+ (* 1 4)
-				   (comp::mdparam 'md-svector-data0-adj))
-				op2))
-	       (:std-slots
-		(qe-slot-access (cadr op1) 
-				(+ (* 2 4)
-				   (comp::mdparam 'md-svector-data0-adj))
-				op2))
-	       (:fsc-wrapper
-		(qe-slot-access (cadr op1) 
-				(+ (* (- 15 1) 4)
-				   (comp::mdparam 'md-function-const0-adj))
-				op2))
-	       (:fsc-slots
-		(qe-slot-access (cadr op1) 
-				(+ (* (- 15 2) 4)
-				   (comp::mdparam 'md-function-const0-adj))
-				op2))
-	       ((:built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper)
-		(qe call :arg 'pcl::built-in-or-structure-wrapper
-		    :u (list (get-treg-of (cadr op1)))
-		    :d (list (get-treg-of op2))))
-	       (:other-wrapper
-		(warn "do other-wrapper"))
-	       ((:i+ :i- :ilogand :ilogxor)
-		(qe arith :arg (cdr (assoc (car op1) 
-					   '((:i+ . :+)
-					     (:i- . :-)
-					     (:ilogand . :logand)
-					     (:ilogxor . :logxor))
-					   :test #'eq))
-		    :u (list (get-treg-of (cadr op1))
-			     (get-treg-of (caddr op1)))
-		    :d (list (get-treg-of op2))))
-	       (:i1+
-		(let ((const-reg (new-reg)))
-		  (qe const :arg 4 ; an index value of 1
-		      :d (list const-reg))
-		  (qe arith :arg :+
-		      :u (list const-reg
-			       (get-treg-of (cadr op1)))
-		      :d (list (get-treg-of op2)))))
-		      
-	       ((:iref :cref :instance-ref)
-		(let (op1-treg)
-		  (if* (not (vector-preg-p (cadr op1)))
-		     then ; must offset before store
-			  (error "must use vector register in ~s" lap)
-		     else (setq op1-treg (get-treg-of (cadr op1))))
-				       
-		  (qe ref :u (list op1-treg
-				   (get-treg-of (caddr op1) op2))
-		      :d (list (get-treg-of op2))
-		      :arg :long)))
-	       (:cdr
-		(let ((const-reg (new-reg)))
-		  (qe const :arg (mdparam 'md-cons-cdr-adj)
-		      :d (list const-reg))
-		  (qe ref :arg :long
-		      :u (list (get-treg-of (cadr op1))
-			       const-reg)
-		      :d (list (get-treg-of op2))))))
-	     (if* (not (eq index1 index2))
-		then (let ((shiftamt (new-reg)))
-		       (qe const :arg 1 :d (list shiftamt))
-		       (if* (and index1 (not index2))
-			  then ; converting from index to non-index
-			       (qe lsl :u (list (get-treg-of op2) shiftamt)
-				   :d (list (get-treg-of op2)))
-			elseif (and (not index1) index2)
-			       ; converting to an index
-			  then (qe lsr :u (list (get-treg-of op2) shiftamt)
-				   :d (list (get-treg-of op2)))))
-	      elseif (and vector2 (not vector1))
-		then ; add vector offset
-		     (let ((tempreg (new-reg))
-			   (vreg (get-treg-of op2)))
-		       (qe const :arg (mdparam 'md-svector-data0-adj)
-			   :d (list tempreg))
-		       (qe arith :arg :+ :u (list vreg tempreg)
-			   :d (list vreg))))))
-	  (:fix=
-	   (let (tr1 tr2)
-	     (if* (index-p op1)
-		then (setq tr1 (get-treg-of op1))
-		     (if* (not (index-p op2))
-			then (setq tr2 (gen-index-treg op2))
-			else (setq tr2 (get-treg-of op2)))
-	      elseif (index-p op2)
-		then ; assert: op1 isn't an index treg
-		     (setq tr1 (gen-index-treg op1))
-		     (setq tr2 (get-treg-of op2))
-		else (setq tr1 (get-treg-of op1)
-			   tr2 (get-treg-of op2)))
-	   
-		   
-		   
-	     (qe bcc :u (list tr1 tr2)
-		 :arg (cadddr lap)
-		 :arg2 :eq )))
-	  ((:eq :neq :fix=)
-	   (if* (not (eq (index-p op1) (index-p op2)))
-	      then (error "non matching operands indexwise in: ~s" lap))
-	   (qe bcc :u (list (get-treg-of op1)
-			    (get-treg-of op2))
-	       :arg (cadddr lap)
-	       :arg2 (cdr (assoc opcode '((:eq . :eq)
-					  (:neq . :ne))
-				 :test #'eq))))
-	  (:izerop 
-	   (qe bcc :u (list (get-treg-of op1)
-			    *zero-treg*)
-	       :arg (caddr lap)
-	       :arg2 :eq))
-	  (:std-instance-p
-	   (let ((treg (get-treg-of op1))
-		 (tempreg (new-reg))
-		 (temp2reg (new-reg))
-		 (offsetreg (new-reg))
-		 (nope (pc-genlab)))
-	     (qe typecheck :u (list treg)
-		 :arg nope
-		 :arg2 '(not structure))
-	     (qe const :arg 'pcl::std-instance :d (list tempreg))
-	     (qe const :arg (mdparam 'md-svector-data0-adj) 
-		 :d (list offsetreg))
-	     (qe ref :u (list treg offsetreg) 
-		 :d (list temp2reg)
-		 :arg :long)
-	     (qe bcc :arg2 :eq :u (list tempreg temp2reg)
-		 :arg (caddr lap))
-	     (qe label :arg nope)))
-	  
-	  (:fsc-instance-p
-	   (let ((treg (get-treg-of op1))
-		 (nope (pc-genlab))
-		 (offsetreg (new-reg))
-		 (tempreg (new-reg))
-		 (checkreg (new-reg)))
-	     (qe typecheck :u (list treg)
-		 :arg nope
-		 :arg2 '(not compiled-function))
-	     (qe const :arg (mdparam 'md-function-flags-adj)
-		 :d (list offsetreg))
-	     (qe ref :u (list treg offsetreg) :d (list tempreg)
-		 :arg :ubyte)
-	     (qe const :arg pcl::funcallable-instance-flag-bit
-		 :d (list checkreg))
-	     (qe bcc :u (list checkreg tempreg)
-		 :arg (caddr lap)
-		 :arg2 :bit-and)
-	     (qe label :arg nope)))
-	  (:built-in-instance-p
-	   ; always true
-	   (qe bra :arg (caddr lap)))
-	  (:jmp
-	   (qe tail-funcall :u (list *nargs-treg* (get-treg-of op1))))
-	  (:structure-instance-p
-	   ; always true
-	   (qe bra :arg (caddr lap)))
-	  
-	  (:return
-	    (let (op-treg)
-	      (if* (index-p op1)
-		 then ; convert to lisp before returning
-		      (let ((shiftamt (new-reg)))
-			(setq op-treg (new-reg))
-			(qe const :arg 1 :d (list shiftamt))
-			(qe lsl :u (list (get-treg-of op1) shiftamt)
-			    :d (list op-treg)))
-		 else (setq op-treg (get-treg-of op1)))
-
-	      (qe move :u (list op-treg) :d *mv-treg-target*)
-	      (qe return :u *mv-treg-target*)))
-
-	  (:go
-	   (qe bra :arg (cadr lap)))
-	   
-	  (:label 
-	   (qe label :arg (cadr lap)))
-	     
-	   
-	   
-	  (t (warn "ignoring ~s" lap)))))))
-
-
-(defun insert-closure-vals (function closure-vals)
-  ;;  build a fucntion from the lap and insert 
-  (let ((newfun (sys::copy-function function)))
-    (setf (excl::fn_closure newfun) (list (apply 'vector closure-vals)))
-    newfun))
-
-  
-	     
-; test case:
-; (pcl::defclass foo () (a b c))
-; (pcl::defmethod barx ((a foo) b c)  a )
-; (apply 'pcl::excl-lap-closure-generator pcl::*tcase*)
-;
-; to turn it on
-
-(if* (not (and (boundp 'user::noquad)
-	       (symbol-value 'user::noquad)))
-   then (setq pcl::*make-lap-closure-generator* 
-	  'pcl::excl-lap-closure-generator))
-
-
-
-
-
-  
-
diff --git a/pcl/readme.text b/pcl/readme.text
deleted file mode 100644
index ce9dc700fd125262b482c319ab3e59d9e70a0415..0000000000000000000000000000000000000000
--- a/pcl/readme.text
+++ /dev/null
@@ -1,11 +0,0 @@
-Please read the file get-pcl.text carefully, it contains the most up to
-date version of the message you received when you first asked about PCL.
-You should read it when you get each new release because it will contain
-any new information about PCL distribution or documentation.
-
-Also whenever there is a new release, you should read the notes.text
-file carefully.
-
-To install PCL at your site, follow the instructions in the defsys.lisp
-file.
-
diff --git a/pcl/rel-7-2-patches.lisp b/pcl/rel-7-2-patches.lisp
deleted file mode 100644
index 9c9587bd6bcef4cdeec2a3f6538502dfe67dafdd..0000000000000000000000000000000000000000
--- a/pcl/rel-7-2-patches.lisp
+++ /dev/null
@@ -1,387 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*-
-
-;=====================================
-(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
-(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179")
-(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
-  "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
-
-;;; Does simple constant folding.  This works for everything that doesn't have
-;;; side-effects.
-;;; ALL operands must be constant.
-;;; Note that commutative-constant-folder can hack this case perfectly well
-;;; by himself for the functions he handles.
-(defun constant-fold-optimizer (form)
-  (let ((eval-when-load-p nil))
-    (flet ((constant-form-p (x)
-	     (when (constant-form-p x)
-	       (cond ((and (listp x)
-			   (eq (car x) 'quote)
-			   (listp (cadr x))
-			   (eq (caadr x) eval-at-load-time-marker))
-		      (setq eval-when-load-p t)
-		      (cdadr x))
-		     (t x)))))
-      (if (every (cdr form) #'constant-form-p)
-	  (if eval-when-load-p
-	      (list 'quote
-		    (list* eval-at-load-time-marker
-			   (car form)
-			   (mapcar #'constant-form-p (cdr form))))
-	      (condition-case (error-object)
-		   (multiple-value-call #'(lambda (&rest values)
-					    (if (= (length values) 1)
-						`',(first values)
-						`(values ,@(mapcar #'(lambda (x) `',x)
-								   values))))
-					(eval form))
-		 (error
-		   (phase-1-warning "Constant form left unoptimized: ~S~%because: ~~A~"
-				    form error-object)
-		   form)))
-	  form))))
-
-
-;=====================================
-(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
-(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85")
-(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
-  "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
-
-;;;
-;;; The damn compiler doesn't compile random forms that appear at top level.
-;;; Its difficult to do because you have to get an associated function spec
-;;; to go with those forms.  This handles that by defining a special form,
-;;; top-level-form that compiles its body.  It takes a list of eval-when
-;;; times just like eval when does.  It also takes a name which it uses
-;;; to construct a function spec for the top-level-form function it has
-;;; to create.
-;;; 
-;
-;si::
-;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal))
-;
-;si::
-;(define-function-spec-handler pcl::top-level-form
-;			      (operation fspec &optional arg1 arg2)
-;  (let ((name (cadr fspec)))
-;    (selectq operation
-;      (validate-function-spec (and (= (length fspec) 2)
-;				   (or (symbolp name)
-;				       (listp name))))
-;      (fdefine
-;       (setf (gethash name *top-level-form-fdefinitions*) arg1))
-;      ((fdefinition fdefinedp)
-;       (gethash name *top-level-form-fdefinitions*)) 
-;      (fdefinition-location 
-;       (ferror "It is not possible to get the fdefinition-location of ~s."
-;	       fspec))
-;      (fundefine (remhash name *top-level-form-fdefinitions*))
-;      (otherwise (function-spec-default-handler operation fspec arg1 arg2)))))
-;
-;;;
-;;; This is basically stolen from PROGN (surprised?)
-;;; 
-;(si:define-special-form pcl::top-level-form (name times
-;						  &body body
-;						  &environment env)
-;  (declare lt:(arg-template . body) (ignore name))
-;  (si:check-eval-when-times times)
-;  (when (member 'eval times) (si:eval-body body env)))
-;
-;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage)
-;  (lt::mapforms-list original-form form (cddr form) 'eval usage))
-
-;;; This is the normal function for looking at each form read from the file and calling
-;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it.
-;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time.  It is
-;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...).
-;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL))
-;  (CATCH-ERROR-RESTART
-;     (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM)
-;    (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA)))
-;      (LET ((ERROR-MESSAGE-HOOK
-;	      #'(LAMBDA ()
-;		  (DECLARE (SYS:DOWNWARD-FUNCTION))
-;		  (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\"
-;			  DBG:*ERROR-MESSAGE-PRINLEVEL*
-;			  DBG:*ERROR-MESSAGE-PRINLENGTH*
-;			  FORM))))
-;	(SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM)))
-;      (WHEN (LISTP FORM)			;Ignore atoms at top-level
-;	(LET ((FUNCTION (FIRST FORM)))
-;	  (SELECTQ FUNCTION
-;	    ((QUOTE))				;and quoted constants e.g. 'COMPILE
-;	    ((PROGN)
-;	     (DOLIST (FORM (CDR FORM))
-;	       (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)))
-;	    ((EVAL-WHEN)
-;	     (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM))
-;	     (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM))
-;				  (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM)))))
-;		   (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM))))
-;		   (FORMS (CDDR FORM)))
-;	       (COND (LOAD-P
-;		      (DOLIST (FORM FORMS)
-;			(COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE))))
-;		     (COMPILE-P
-;		      (DOLIST (FORM FORMS)
-;			(FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL))))))
-;	    ((DEFUN)
-;	     (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T)))
-;	       (IF (EQ (CDR TEM) (CDR FORM))
-;		   (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)
-;		   (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO))))
-;	    ((MACRO)
-;	     (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T))
-;	    ((DECLARE)
-;	     (DOLIST (FORM (CDR FORM))
-;	       (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T)
-;			;; (DECLARE (SPECIAL ... has load-time action as well.
-;			;; All other DECLARE's do not.
-;			(MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL)))))
-;	    ((COMPILER-LET)
-;	     (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM)
-;				    #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO))
-;	    ((SI:DEFINE-SPECIAL-FORM)
-;	     (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))
-;	    ((MULTIPLE-DEFINITION)
-;	     (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM)
-;	       (LET ((NAME-VALID (AND (NOT (NULL NAME))
-;				      (OR (SYMBOLP NAME)
-;					  (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE)))))
-;		     (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE))))
-;		 (UNLESS (AND NAME-VALID TYPE-VALID)
-;		   (WARN "(~S ~S ~S ...) is invalid because~@
-;			  ~:[~S is not valid as a definition name~;~*~]~
-;			  ~:[~&~S is not valid as a definition type~;~*~]"
-;			 'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE)))
-;	       (LET* ((COMPILED-BODY NIL)
-;		      (COMPILE-FUNCTION *COMPILE-FUNCTION*)
-;		      (*COMPILE-FUNCTION*
-;			(LAMBDA (OPERATION &REST ARGS)
-;			  (DECLARE (SYS:DOWNWARD-FUNCTION))
-;			  (SELECTQ OPERATION
-;			    (:DUMP-FORM
-;			     (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM
-;					    (FIRST ARGS))
-;				   COMPILED-BODY))
-;			    (:INSTALL-DEFINITION
-;			     (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS))
-;				   COMPILED-BODY))
-;			    (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS)))))
-;		      (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE)
-;					    ,@LOCAL-DECLARATIONS)))
-;		 (DOLIST (FORM BODY)
-;		   (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))
-;		 (FUNCALL COMPILE-FUNCTION :DUMP-FORM
-;			  `(LOAD-MULTIPLE-DEFINITION
-;			     ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL)))))
-;	    ((pcl::top-level-form)
-;	     (destructuring-bind (name times . body)
-;				 (cdr form)
-;	       (si:check-eval-when-times times)
-;	       (let ((compile-p (or (memq 'compile times)
-;				    (and compile-time-too (memq 'eval times))))
-;		     (load-p (or (memq 'load times)
-;				 (memq 'cl:load times)))
-;		     (fspec `(pcl::top-level-form ,name)))
-;		 (cond (load-p
-;			(compile-from-stream-1
-;			  `(progn (defun ,fspec () . ,body)
-;				  (funcall (function ,fspec)))
-;			  (and compile-p ':force)))
-;		       (compile-p
-;			(dolist (b body)
-;			  (funcall *compile-form-function* form ':force nil)))))))
-;	    (OTHERWISE
-;	     (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM))))
-;	       (IF TEM
-;		   (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T)
-;		   (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))))))))))
-;
-;
-
-
-dw::
-(defun symbol-flavor-or-cl-type (symbol)
-  (declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent
-		   non-atomic-deftype))
-  (multiple-value-bind (result foundp)
-      (gethash symbol *flavor-or-cl-type-cache*)
-    (let ((frob
-	    (if foundp result
-	      (setf (gethash symbol *flavor-or-cl-type-cache*)
-		    (or (get symbol 'flavor:flavor)
-			(not (null (defstruct-type-p symbol)))
-			(let* ((deftype (get symbol 'deftype))
-			       (descriptor (symbol-presentation-type-descriptor symbol))
-			       (typep
-				 (unless (and descriptor
-					      (presentation-type-explicit-type-function
-						descriptor))
-				   ;; Don't override the one defined in the presentation-type.
-				   (get symbol 'typep)))
-			       (atomic-subtype-parent (find-atomic-subtype-parent symbol))
-			       (non-atomic-deftype
-				 (when (and (not descriptor) deftype)
-				   (not (member (first (type-arglist symbol))
-						'(&rest &key &optional))))))
-			  (if (or typep (not (atom deftype))
-				  non-atomic-deftype
-				  ;; deftype overrides atomic-subtype-parent.
-				  (and (not deftype) atomic-subtype-parent))
-			      (list-in-area *handler-dynamic-area*
-					    deftype typep atomic-subtype-parent
-					    non-atomic-deftype)
-			    deftype)))))))
-      (locally (declare (inline compiled-function-p))
-        (etypecase frob
-	  (array (values frob))
-	  (null (values nil))
-	  ((member t) (values nil t))
-	  (compiled-function (values nil nil frob))
-	  (lexical-closure (values nil nil frob))
-	  (list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype)
-		    frob
-		  (values nil nil deftype typep atomic-subtype-parent non-atomic-deftype)))
-	  (symbol (values nil nil nil nil frob)))))))
-
-;;;
-;;; The variable zwei::*sectionize-line-lookahead* controls how many lines the parser
-;;;  is willing to look ahead while trying to parse a definition.  Even 2 lines is enough
-;;;  for just about all cases, but there isn't much overhead, and 10 should be enough
-;;;  to satisfy pretty much everyone... but feel free to change it.
-;;;        - MT 880921
-;;;
-
-zwei:
-(defvar *sectionize-line-lookahead* 3)
-
-zwei:
-(DEFMETHOD (:SECTIONIZE-BUFFER MAJOR-MODE :DEFAULT)
-	   (FIRST-BP LAST-BP BUFFER STREAM INT-STREAM ADDED-COMPLETIONS)
-  ADDED-COMPLETIONS ;ignored, obsolete
-  (WHEN STREAM
-    (SEND-IF-HANDLES STREAM :SET-RETURN-DIAGRAMS-AS-LINES T))
-  (INCF *SECTIONIZE-BUFFER*)
-  (LET ((BUFFER-TICK (OR (SEND-IF-HANDLES BUFFER :SAVE-TICK) *TICK*))
-	OLD-CHANGED-SECTIONS)
-    (TICK)
-    ;; Flush old section nodes.  Also collect the names of those that are modified, they are
-    ;; the ones that will be modified again after a revert buffer.
-    (DOLIST (NODE (NODE-INFERIORS BUFFER))
-      (AND (> (NODE-TICK NODE) BUFFER-TICK)
-	   (PUSH (LIST (SECTION-NODE-FUNCTION-SPEC NODE)
-		       (SECTION-NODE-DEFINITION-TYPE NODE))
-		 OLD-CHANGED-SECTIONS))
-      (FLUSH-BP (INTERVAL-FIRST-BP NODE))
-      (FLUSH-BP (INTERVAL-LAST-BP NODE)))
-    (DO ((LINE (BP-LINE FIRST-BP) (LINE-NEXT INT-LINE))
-	 (LIMIT (BP-LINE LAST-BP))
-	 (EOFFLG)
-	 (ABNORMAL T)
-	 (DEFINITION-LIST NIL)
-	 (BP (COPY-BP FIRST-BP))
-	 (FUNCTION-SPEC)
-	 (DEFINITION-TYPE)
-	 (STR)
-	 (INT-LINE)
-	 (first-time t)
-	 (future-line)				; we actually read into future line
-	 (future-int-line)
-	 (PREV-NODE-START-BP FIRST-BP)
-	 (PREV-NODE-DEFINITION-LINE NIL)
-	 (PREV-NODE-FUNCTION-SPEC NIL)
-	 (PREV-NODE-TYPE 'HEADER)
-	 (PREVIOUS-NODE NIL)
-	 (NODE-LIST NIL)
-	 (STATE (SEND SELF :INITIAL-SECTIONIZATION-STATE)))
-	(NIL)
-      ;; If we have a stream, read another line.
-      (when (AND STREAM (NOT EOFFLG))
-	(let ((lookahead (if future-line 1 *sectionize-line-lookahead*)))
-	  (dotimes (i lookahead)		; startup lookahead
-	    (MULTIPLE-VALUE (future-LINE EOFFLG)
-	      (LET ((DEFAULT-CONS-AREA *LINE-AREA*))
-		(SEND STREAM ':LINE-IN LINE-LEADER-SIZE)))
-	    (IF future-LINE (SETQ future-INT-LINE (FUNCALL INT-STREAM ':LINE-OUT future-LINE)))
-	    (when first-time
-	      (setq first-time nil)
-	      (setq line future-line)
-	      (setq int-line future-int-line))
-	    (when eofflg
-	      (return)))))
-
-      (SETQ INT-LINE LINE)
-
-      (when int-line
-	(MOVE-BP BP INT-LINE 0))		;Record as potentially start-bp for a section
-
-      ;; See if the line is the start of a defun.
-      (WHEN (AND LINE
-		 (LET (ERR)
-		   (MULTIPLE-VALUE (FUNCTION-SPEC DEFINITION-TYPE STR ERR STATE)
-		     (SEND SELF ':SECTION-NAME INT-LINE BP STATE))
-		   (NOT ERR)))
-	(PUSH (LIST FUNCTION-SPEC DEFINITION-TYPE) DEFINITION-LIST)
-	(SECTION-COMPLETION FUNCTION-SPEC STR NIL)
-	;; List methods under both names for user ease.
-	(LET ((OTHER-COMPLETION (SEND SELF ':OTHER-SECTION-NAME-COMPLETION
-				      FUNCTION-SPEC INT-LINE)))
-	  (WHEN OTHER-COMPLETION
-	    (SECTION-COMPLETION FUNCTION-SPEC OTHER-COMPLETION NIL)))
-	(LET ((PREV-NODE-END-BP (BACKWARD-OVER-COMMENT-LINES BP ':FORM-AS-BLANK)))
-	  ;; Don't make a section node if it's completely empty.  This avoids making
-	  ;; a useless Buffer Header section node. Just set all the PREV variables
-	  ;; so that the next definition provokes the *right thing*
-	  (UNLESS (BP-= PREV-NODE-END-BP PREV-NODE-START-BP)
-	    (SETQ PREVIOUS-NODE
-		  (ADD-SECTION-NODE PREV-NODE-START-BP
-				    (SETQ PREV-NODE-START-BP PREV-NODE-END-BP)
-				    PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE
-				    PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE
-				    (IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS
-					      THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC)
-							   (EQ PREV-NODE-TYPE TYPE)))
-					*TICK* BUFFER-TICK)
-				    BUFFER-TICK))
-	    (PUSH PREVIOUS-NODE NODE-LIST)))
-	(SETQ PREV-NODE-FUNCTION-SPEC FUNCTION-SPEC
-	      PREV-NODE-TYPE DEFINITION-TYPE
-	      PREV-NODE-DEFINITION-LINE INT-LINE))
-      ;; After processing the last line, exit.
-      (WHEN (OR #+ignore EOFFLG (null line) (AND (NULL STREAM) (EQ LINE LIMIT)))
-	;; If reading a stream, we should not have inserted a CR
-	;; after the eof line.
-	(WHEN STREAM
-	  (DELETE-INTERVAL (FORWARD-CHAR LAST-BP -1 T) LAST-BP T))
-	;; The rest of the buffer is part of the last node
-	(UNLESS (SEND SELF ':SECTION-NAME-TRIVIAL-P)
-	  ;; ---oh dear, what sort of section will this be? A non-empty HEADER
-	  ;; ---node.  Well, ok for now.
-	  (PUSH (ADD-SECTION-NODE PREV-NODE-START-BP LAST-BP
-				  PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE
-				  PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE
-				  (IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS
-					    THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC)
-							 (EQ PREV-NODE-TYPE TYPE)))
-				      *TICK* BUFFER-TICK)
-				  BUFFER-TICK)
-		NODE-LIST)
-	  (SETF (LINE-NODE (BP-LINE LAST-BP)) (CAR NODE-LIST)))
-	(SETF (NODE-INFERIORS BUFFER) (NREVERSE NODE-LIST))
-	(SETF (NAMED-BUFFER-WITH-SECTIONS-FIRST-SECTION BUFFER) (CAR (NODE-INFERIORS BUFFER)))
-	(SETQ ABNORMAL NIL)			;timing windows here
-	;; Speed up completion if enabled.
-	(WHEN SI:*ENABLE-AARRAY-SORTING-AFTER-LOADS*
-	  (SI:SORT-AARRAY *ZMACS-COMPLETION-AARRAY*))
-	(SETQ *ZMACS-COMPLETION-AARRAY*
-	      (FOLLOW-STRUCTURE-FORWARDING *ZMACS-COMPLETION-AARRAY*))
-	(RETURN
-	  (VALUES 
-	    (CL:SETF (ZMACS-SECTION-LIST BUFFER)
-		     (NREVERSE DEFINITION-LIST))
-	    ABNORMAL))))))
-
-
diff --git a/pcl/rel-8-patches.lisp b/pcl/rel-8-patches.lisp
deleted file mode 100644
index 99b85b25e70dc57b9a96c0856ba7cadb6c718203..0000000000000000000000000000000000000000
--- a/pcl/rel-8-patches.lisp
+++ /dev/null
@@ -1,255 +0,0 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*-
-
-;=====================================
-(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
-(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179")
-(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
-  "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
-
-;;; Does simple constant folding.  This works for everything that doesn't have
-;;; side-effects.
-;;; ALL operands must be constant.
-;;; Note that commutative-constant-folder can hack this case perfectly well
-;;; by himself for the functions he handles.
-(defun constant-fold-optimizer (form)
-  (let ((eval-when-load-p nil))
-    (flet ((constant-form-p (x)
-	     (when (constant-form-p x)
-	       (cond ((and (listp x)
-			   (eq (car x) 'quote)
-			   (listp (cadr x))
-			   (eq (caadr x) eval-at-load-time-marker))
-		      (setq eval-when-load-p t)
-		      (cdadr x))
-		     (t x)))))
-      (if (every (cdr form) #'constant-form-p)
-	  (if eval-when-load-p
-	      (list 'quote
-		    (list* eval-at-load-time-marker
-			   (car form)
-			   (mapcar #'constant-form-p (cdr form))))
-	      (condition-case (error-object)
-		   (multiple-value-call #'(lambda (&rest values)
-					    (if (= (length values) 1)
-						`',(first values)
-						`(values ,@(mapcar #'(lambda (x) `',x)
-								   values))))
-					(eval form))
-		 (error
-		   (phase-1-warning "Constant form left unoptimized: ~S~%because: ~~A~"
-				    form error-object)
-		   form)))
-	  form))))
-
-
-;=====================================
-(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
-(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85")
-(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
-  "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
-
-;;;
-;;; The damn compiler doesn't compile random forms that appear at top level.
-;;; Its difficult to do because you have to get an associated function spec
-;;; to go with those forms.  This handles that by defining a special form,
-;;; top-level-form that compiles its body.  It takes a list of eval-when
-;;; times just like eval when does.  It also takes a name which it uses
-;;; to construct a function spec for the top-level-form function it has
-;;; to create.
-;;; 
-;
-;si::
-;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal))
-;
-;si::
-;(define-function-spec-handler pcl::top-level-form
-;			      (operation fspec &optional arg1 arg2)
-;  (let ((name (cadr fspec)))
-;    (selectq operation
-;      (validate-function-spec (and (= (length fspec) 2)
-;				   (or (symbolp name)
-;				       (listp name))))
-;      (fdefine
-;       (setf (gethash name *top-level-form-fdefinitions*) arg1))
-;      ((fdefinition fdefinedp)
-;       (gethash name *top-level-form-fdefinitions*)) 
-;      (fdefinition-location 
-;       (ferror "It is not possible to get the fdefinition-location of ~s."
-;	       fspec))
-;      (fundefine (remhash name *top-level-form-fdefinitions*))
-;      (otherwise (function-spec-default-handler operation fspec arg1 arg2)))))
-;
-;;;
-;;; This is basically stolen from PROGN (surprised?)
-;;; 
-;(si:define-special-form pcl::top-level-form (name times
-;						  &body body
-;						  &environment env)
-;  (declare lt:(arg-template . body) (ignore name))
-;  (si:check-eval-when-times times)
-;  (when (member 'eval times) (si:eval-body body env)))
-;
-;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage)
-;  (lt::mapforms-list original-form form (cddr form) 'eval usage))
-
-;;; This is the normal function for looking at each form read from the file and calling
-;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it.
-;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time.  It is
-;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...).
-;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL))
-;  (CATCH-ERROR-RESTART
-;     (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM)
-;    (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA)))
-;      (LET ((ERROR-MESSAGE-HOOK
-;	      #'(LAMBDA ()
-;		  (DECLARE (SYS:DOWNWARD-FUNCTION))
-;		  (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\"
-;			  DBG:*ERROR-MESSAGE-PRINLEVEL*
-;			  DBG:*ERROR-MESSAGE-PRINLENGTH*
-;			  FORM))))
-;	(SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM)))
-;      (WHEN (LISTP FORM)			;Ignore atoms at top-level
-;	(LET ((FUNCTION (FIRST FORM)))
-;	  (SELECTQ FUNCTION
-;	    ((QUOTE))				;and quoted constants e.g. 'COMPILE
-;	    ((PROGN)
-;	     (DOLIST (FORM (CDR FORM))
-;	       (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)))
-;	    ((EVAL-WHEN)
-;	     (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM))
-;	     (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM))
-;				  (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM)))))
-;		   (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM))))
-;		   (FORMS (CDDR FORM)))
-;	       (COND (LOAD-P
-;		      (DOLIST (FORM FORMS)
-;			(COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE))))
-;		     (COMPILE-P
-;		      (DOLIST (FORM FORMS)
-;			(FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL))))))
-;	    ((DEFUN)
-;	     (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T)))
-;	       (IF (EQ (CDR TEM) (CDR FORM))
-;		   (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)
-;		   (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO))))
-;	    ((MACRO)
-;	     (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T))
-;	    ((DECLARE)
-;	     (DOLIST (FORM (CDR FORM))
-;	       (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T)
-;			;; (DECLARE (SPECIAL ... has load-time action as well.
-;			;; All other DECLARE's do not.
-;			(MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL)))))
-;	    ((COMPILER-LET)
-;	     (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM)
-;				    #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO))
-;	    ((SI:DEFINE-SPECIAL-FORM)
-;	     (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))
-;	    ((MULTIPLE-DEFINITION)
-;	     (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM)
-;	       (LET ((NAME-VALID (AND (NOT (NULL NAME))
-;				      (OR (SYMBOLP NAME)
-;					  (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE)))))
-;		     (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE))))
-;		 (UNLESS (AND NAME-VALID TYPE-VALID)
-;		   (WARN "(~S ~S ~S ...) is invalid because~@
-;			  ~:[~S is not valid as a definition name~;~*~]~
-;			  ~:[~&~S is not valid as a definition type~;~*~]"
-;			 'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE)))
-;	       (LET* ((COMPILED-BODY NIL)
-;		      (COMPILE-FUNCTION *COMPILE-FUNCTION*)
-;		      (*COMPILE-FUNCTION*
-;			(LAMBDA (OPERATION &REST ARGS)
-;			  (DECLARE (SYS:DOWNWARD-FUNCTION))
-;			  (SELECTQ OPERATION
-;			    (:DUMP-FORM
-;			     (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM
-;					    (FIRST ARGS))
-;				   COMPILED-BODY))
-;			    (:INSTALL-DEFINITION
-;			     (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS))
-;				   COMPILED-BODY))
-;			    (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS)))))
-;		      (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE)
-;					    ,@LOCAL-DECLARATIONS)))
-;		 (DOLIST (FORM BODY)
-;		   (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))
-;		 (FUNCALL COMPILE-FUNCTION :DUMP-FORM
-;			  `(LOAD-MULTIPLE-DEFINITION
-;			     ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL)))))
-;	    ((pcl::top-level-form)
-;	     (destructuring-bind (name times . body)
-;				 (cdr form)
-;	       (si:check-eval-when-times times)
-;	       (let ((compile-p (or (memq 'compile times)
-;				    (and compile-time-too (memq 'eval times))))
-;		     (load-p (or (memq 'load times)
-;				 (memq 'cl:load times)))
-;		     (fspec `(pcl::top-level-form ,name)))
-;		 (cond (load-p
-;			(compile-from-stream-1
-;			  `(progn (defun ,fspec () . ,body)
-;				  (funcall (function ,fspec)))
-;			  (and compile-p ':force)))
-;		       (compile-p
-;			(dolist (b body)
-;			  (funcall *compile-form-function* form ':force nil)))))))
-;	    (OTHERWISE
-;	     (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM))))
-;	       (IF TEM
-;		   (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T)
-;		   (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))))))))))
-;
-;
-
-
-dw::
-(defun symbol-flavor-or-cl-type (symbol)
-  (declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent
-		   non-atomic-deftype))
-  (multiple-value-bind (result foundp)
-      (gethash symbol *flavor-or-cl-type-cache*)
-    (let ((frob
-	    (if foundp result
-	      (setf (gethash symbol *flavor-or-cl-type-cache*)
-		    (or (get symbol 'flavor:flavor)
-			(let ((class (get symbol 'clos-internals::class-for-name)))
-			  (when (and class
-				     (not (typep class 'clos:built-in-class)))
-			    class))
-			(not (null (defstruct-type-p symbol)))
-			(let* ((deftype (get symbol 'deftype))
-			       (descriptor (symbol-presentation-type-descriptor symbol))
-			       (typep
-				 (unless (and descriptor
-					      (presentation-type-explicit-type-function
-						descriptor))
-				   ;; Don't override the one defined in the presentation-type.
-				   (get symbol 'typep)))
-			       (atomic-subtype-parent (find-atomic-subtype-parent symbol))
-			       (non-atomic-deftype
-				 (when (and (not descriptor) deftype)
-				   (not (member (first (type-arglist symbol))
-						'(&rest &key &optional))))))
-			  (if (or typep (not (atom deftype))
-				  non-atomic-deftype
-				  ;; deftype overrides atomic-subtype-parent.
-				  (and (not deftype) atomic-subtype-parent))
-			      (list-in-area *handler-dynamic-area*
-					    deftype typep atomic-subtype-parent
-					    non-atomic-deftype)
-			    deftype)))))))
-      (locally (declare (inline compiled-function-p))
-        (etypecase frob
-	  (array (values frob))
-	  (instance (values frob))
-	  (null (values nil))
-	  ((member t) (values nil t))
-	  (compiled-function (values nil nil frob))
-	  (lexical-closure (values nil nil frob))
-	  (list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype)
-		    frob
-		  (values nil nil deftype typep atomic-subtype-parent non-atomic-deftype)))
-	  (symbol (values nil nil nil nil frob)))))))
-
-
diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp
deleted file mode 100644
index 56a897169348ae4e97acaea5118ee31216cca742..0000000000000000000000000000000000000000
--- a/pcl/slots-boot.lisp
+++ /dev/null
@@ -1,409 +0,0 @@
-;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-(defmacro slot-symbol (slot-name type)
-  `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
-       (or (get ,slot-name ',(ecase type
-			       (reader 'reader-symbol)
-			       (writer 'writer-symbol)
-			       (boundp 'boundp-symbol)))
-	   (intern (format nil "~A ~A slot ~a" 
-			   (package-name (symbol-package ,slot-name))
-			   (symbol-name ,slot-name)
-			   ,(symbol-name type))
-	           *slot-accessor-name-package*))
-       (progn 
-	 (error "non-symbol and non-interned symbol slot name accessors~
-                 are not yet implemented")
-	 ;;(make-symbol (format nil "~a ~a" ,slot-name ,type))
-	 )))
-
-(defun slot-reader-symbol (slot-name)
-  (slot-symbol slot-name reader))
-
-(defun slot-writer-symbol (slot-name)
-  (slot-symbol slot-name writer))
-
-(defun slot-boundp-symbol (slot-name)
-  (slot-symbol slot-name boundp))
-
-(defmacro asv-funcall (sym slot-name type &rest args)
-  (declare (ignore type))
-  `(if (#-akcl fboundp #+akcl %fboundp ',sym)
-       (,sym ,@args)
-       (no-slot ',sym ',slot-name)))
-
-(defun no-slot (slot-name sym)
-  (error "No class has a slot named ~S (~s has no function binding)
-          (or maybe your files were compiled with an old version of PCL:~
-          try recompiling.)"
-	 slot-name sym))
-
-(defmacro accessor-slot-value (object slot-name)
-  (unless (constantp slot-name)
-    (error "~s requires its slot-name argument to be a constant" 
-	   'accessor-slot-value))
-  (let* ((slot-name (eval slot-name))
-	 (sym (slot-reader-symbol slot-name)))
-    `(asv-funcall ,sym ,slot-name reader ,object)))
-
-(defmacro accessor-set-slot-value (object slot-name new-value &environment env)
-  (unless (constantp slot-name)
-    (error "~s requires its slot-name argument to be a constant" 
-	   'accessor-set-slot-value))
-  (setq object (macroexpand object env))
-  (setq slot-name (macroexpand slot-name env))
-  (let* ((slot-name (eval slot-name))
-	 (bindings (unless (or (constantp new-value) (atom new-value))
-		     (let ((object-var (gensym)))
-		       (prog1 `((,object-var ,object))
-			 (setq object object-var)))))
-	 (sym (slot-writer-symbol slot-name))
-	 (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
-    (if bindings
-	`(let ,bindings ,form)
-	form)))
-
-(defconstant *optimize-slot-boundp* nil)
-
-(defmacro accessor-slot-boundp (object slot-name)
-  (unless (constantp slot-name)
-    (error "~s requires its slot-name argument to be a constant" 
-	   'accessor-slot-boundp))
-  (let* ((slot-name (eval slot-name))
-	 (sym (slot-boundp-symbol slot-name)))
-    (if (not *optimize-slot-boundp*)
-	`(slot-boundp-normal ,object ',slot-name)
-	`(asv-funcall ,sym ,slot-name boundp ,object))))
-
-
-(defun structure-slot-boundp (object)
-  (declare (ignore object))
-  t)
-
-(defun make-structure-slot-boundp-function (slotd)
-  (let* ((reader (slot-definition-internal-reader-function slotd))
-	 (fun #'(lambda (object)
-		  (not (eq (funcall reader object) *slot-unbound*)))))
-    (declare (type function reader))
-    #+(and kcl turbo-closure) (si:turbo-closure fun)
-    fun))		    
-
-(defun get-optimized-std-accessor-method-function (class slotd name)
-  (if (structure-class-p class)
-      (ecase name
-	(reader (slot-definition-internal-reader-function slotd))
-	(writer (slot-definition-internal-writer-function slotd))
-	(boundp (make-structure-slot-boundp-function slotd)))
-      (let* ((fsc-p (cond ((standard-class-p class) nil)
-			  ((funcallable-standard-class-p class) t)
-			  (t (error "~S is not a standard-class" class))))
-	     (slot-name (slot-definition-name slotd))
-	     (index (slot-definition-location slotd))
-	     (function (ecase name
-			 (reader #'make-optimized-std-reader-method-function)
-			 (writer #'make-optimized-std-writer-method-function)
-			 (boundp #'make-optimized-std-boundp-method-function)))
-	     (value (funcall function fsc-p slot-name index)))
-	(declare (type function function))
-	(values value index))))
-
-(defun make-optimized-std-reader-method-function (fsc-p slot-name index)
-  (declare #.*optimize-speed*)
-  (set-function-name
-   (etypecase index
-     (fixnum (if fsc-p
-		 #'(lambda (instance)
-		     (let ((value (%instance-ref (fsc-instance-slots instance) index)))
-		       (if (eq value *slot-unbound*)
-			   (slot-unbound (class-of instance) instance slot-name)
-			   value)))
-		 #'(lambda (instance)
-		     (let ((value (%instance-ref (std-instance-slots instance) index)))
-		       (if (eq value *slot-unbound*)
-			   (slot-unbound (class-of instance) instance slot-name)
-			   value)))))
-     (cons   #'(lambda (instance)
-		 (let ((value (cdr index)))
-		   (if (eq value *slot-unbound*)
-		       (slot-unbound (class-of instance) instance slot-name)
-		       value)))))
-   `(reader ,slot-name)))
-
-(defun make-optimized-std-writer-method-function (fsc-p slot-name index)
-  (declare #.*optimize-speed*)
-  (set-function-name
-   (etypecase index
-     (fixnum (if fsc-p
-		 #'(lambda (nv instance)
-		     (setf (%instance-ref (fsc-instance-slots instance) index) nv))
-		 #'(lambda (nv instance)
-		     (setf (%instance-ref (std-instance-slots instance) index) nv))))
-     (cons   #'(lambda (nv instance)
-		 (declare (ignore instance))
-		 (setf (cdr index) nv))))
-   `(writer ,slot-name)))
-
-(defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
-  (declare #.*optimize-speed*)
-  (set-function-name
-   (etypecase index
-     (fixnum (if fsc-p
-		 #'(lambda (instance)
-		     (not (eq *slot-unbound*
-			      (%instance-ref (fsc-instance-slots instance) index))))
-		 #'(lambda (instance)
-		     (not (eq *slot-unbound* 
-			      (%instance-ref (std-instance-slots instance) index))))))
-     (cons   #'(lambda (instance)
-		 (declare (ignore instance))
-		 (not (eq *slot-unbound* (cdr index))))))
-   `(boundp ,slot-name)))
-
-(defun make-optimized-structure-slot-value-using-class-method-function (function)
-  #+cmu (declare (type function function))
-  #'(lambda (class object slotd)
-      (let ((value (funcall function object)))
-	(if (eq value *slot-unbound*)
-	    (slot-unbound class object (slot-definition-name slotd))
-	    value))))	    
-
-(defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
-  #+cmu (declare (type function function))
-  #'(lambda (nv class object slotd)
-      (declare (ignore class slotd))
-      (funcall function nv object)))
-
-(defun make-optimized-structure-slot-boundp-using-class-method-function (function)
-  #+cmu (declare (type function function))
-  #'(lambda (class object slotd)
-      (declare (ignore class slotd))
-      (not (eq (funcall function object) *slot-unbound*))))
-
-(defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
-  (if (structure-class-p class)
-      (ecase name
-	(reader (make-optimized-structure-slot-value-using-class-method-function
-		 (slot-definition-internal-reader-function slotd)))
-	(writer (make-optimized-structure-setf-slot-value-using-class-method-function
-		 (slot-definition-internal-writer-function slotd)))
-	(boundp (make-optimized-structure-slot-boundp-using-class-method-function
-		 (slot-definition-internal-writer-function slotd))))
-      (let* ((fsc-p (cond ((standard-class-p class) nil)
-			  ((funcallable-standard-class-p class) t)
-			  (t (error "~S is not a standard-class" class))))
-	     (slot-name (slot-definition-name slotd))
-	     (index (slot-definition-location slotd))
-	     (function 
-	      (ecase name
-		(reader 
-		 #'make-optimized-std-slot-value-using-class-method-function)
-		(writer 
-		 #'make-optimized-std-setf-slot-value-using-class-method-function)
-		(boundp 
-		 #'make-optimized-std-slot-boundp-using-class-method-function))))
-	#+cmu (declare (type function function))
-	(values (funcall function fsc-p slot-name index) index))))
-
-(defun make-optimized-std-slot-value-using-class-method-function
-    (fsc-p slot-name index)
-  (declare #.*optimize-speed*)
-  (etypecase index
-    (fixnum (if fsc-p
-		#'(lambda (class instance slotd)
-		    (declare (ignore slotd))
-		    (unless (fsc-instance-p instance) (error "not fsc"))
-		    (let ((value (%instance-ref (fsc-instance-slots instance) index)))
-		      (if (eq value *slot-unbound*)
-			  (slot-unbound class instance slot-name)
-			  value)))
-		#'(lambda (class instance slotd)
-		    (declare (ignore slotd))
-		    (unless (std-instance-p instance) (error "not std"))
-		    (let ((value (%instance-ref (std-instance-slots instance) index)))
-		      (if (eq value *slot-unbound*)
-			  (slot-unbound class instance slot-name)
-			  value)))))
-    (cons   #'(lambda (class instance slotd)
-		(declare (ignore slotd))
-		(let ((value (cdr index)))
-		  (if (eq value *slot-unbound*)
-		      (slot-unbound class instance slot-name)
-		      value))))))
-
-(defun make-optimized-std-setf-slot-value-using-class-method-function
-    (fsc-p slot-name index)
-  (declare #.*optimize-speed*)
-  (declare (ignore slot-name))
-  (etypecase index
-    (fixnum (if fsc-p
-		#'(lambda (nv class instance slotd)
-		    (declare (ignore class slotd))
-		    (setf (%instance-ref (fsc-instance-slots instance) index) nv))
-		#'(lambda (nv class instance slotd)
-		    (declare (ignore class slotd))
-		    (setf (%instance-ref (std-instance-slots instance) index) nv))))
-    (cons   #'(lambda (nv class instance slotd)
-		(declare (ignore class instance slotd))
-		(setf (cdr index) nv)))))
-
-(defun make-optimized-std-slot-boundp-using-class-method-function
-    (fsc-p slot-name index)
-  (declare #.*optimize-speed*)
-  (declare (ignore slot-name))
-  (etypecase index
-    (fixnum (if fsc-p
-		#'(lambda (class instance slotd)
-		    (declare (ignore class slotd))
-		    (not (eq *slot-unbound* 
-			     (%instance-ref (fsc-instance-slots instance) index))))
-		#'(lambda (class instance slotd)
-		    (declare (ignore class slotd))
-		    (not (eq *slot-unbound* 
-			     (%instance-ref (std-instance-slots instance) index))))))
-    (cons   #'(lambda (class instance slotd)
-		(declare (ignore class instance slotd))
-		(not (eq *slot-unbound* (cdr index)))))))
-
-(defun get-accessor-from-svuc-method-function (class slotd sdfun name)
-  (macrolet ((emf-funcall (emf &rest args)
-	       `(invoke-effective-method-function ,emf nil ,@args)))
-    (set-function-name
-     (case name
-       (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd)))
-       (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd)))
-       (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd))))
-     `(,name ,(class-name class) ,(slot-definition-name slotd)))))
-
-(defun make-internal-reader-method-function (class-name slot-name)
-  (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
-	 (make-method-function
-	  (lambda (instance)
-	    (let ((wrapper (cond ((std-instance-p instance) 
-				  (std-instance-wrapper instance))
-				 ((fsc-instance-p instance) 
-				  (fsc-instance-wrapper instance)))))
-	      (if wrapper
-		  (let* ((class (wrapper-class* wrapper))
-			 (index (or (instance-slot-index wrapper slot-name)
-				    (assq slot-name (wrapper-class-slots wrapper)))))
-		    (typecase index
-		      (fixnum 	
-		       (let ((value (%instance-ref (get-slots instance) index)))
-			 (if (eq value *slot-unbound*)
-			     (slot-unbound (class-of instance) instance slot-name)
-			     value)))
-		      (cons
-		       (let ((value (cdr index)))
-			 (if (eq value *slot-unbound*)
-			     (slot-unbound (class-of instance) instance slot-name)
-			     value)))
-		      (t
-		       (error "The wrapper for class ~S does not have the slot ~S"
-			      class slot-name))))
-		  (slot-value instance slot-name)))))))
-
-
-(defun make-std-reader-method-function (class-name slot-name)
-  (let* ((pv-table-symbol (gensym))
-	 (initargs (copy-tree
-		    (make-method-function
-		     (lambda (instance)
-		       (pv-binding1 (.pv. .calls.
-					  (symbol-value pv-table-symbol)
-					  (instance) (instance-slots))
-			 (instance-read-internal 
-			  .pv. instance-slots 1
-			  (slot-value instance slot-name))))))))
-    (setf (getf (getf initargs ':plist) ':slot-name-lists)
-	  (list (list nil slot-name)))
-    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
-    (list* ':method-spec `(reader-method ,class-name ,slot-name)
-	   initargs)))
-
-(defun make-std-writer-method-function (class-name slot-name)
-  (let* ((pv-table-symbol (gensym))
-	 (initargs (copy-tree
-		    (make-method-function
-		     (lambda (nv instance)
-		       (pv-binding1 (.pv. .calls.
-					  (symbol-value pv-table-symbol)
-					  (instance) (instance-slots))
-			 (instance-write-internal 
-			  .pv. instance-slots 1 nv
-			  (setf (slot-value instance slot-name) nv))))))))
-    (setf (getf (getf initargs ':plist) ':slot-name-lists)
-	  (list nil (list nil slot-name)))
-    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
-    (list* ':method-spec `(writer-method ,class-name ,slot-name)
-	   initargs)))
-
-(defun make-std-boundp-method-function (class-name slot-name)
-  (let* ((pv-table-symbol (gensym))
-	 (initargs (copy-tree
-		    (make-method-function
-		     (lambda (instance)
-		       (pv-binding1 (.pv. .calls.
-					  (symbol-value pv-table-symbol)
-					  (instance) (instance-slots))
-			  (instance-boundp-internal 
-			   .pv. instance-slots 1
-			   (slot-boundp instance slot-name))))))))
-    (setf (getf (getf initargs ':plist) ':slot-name-lists)
-	  (list (list nil slot-name)))
-    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
-    (list* ':method-spec `(boundp-method ,class-name ,slot-name)
-	   initargs)))
-
-(defun initialize-internal-slot-gfs (slot-name &optional type)
-  (when (or (null type) (eq type 'reader))
-    (let* ((name (slot-reader-symbol slot-name))
-	   (gf (ensure-generic-function name)))
-      (unless (generic-function-methods gf)
-	(add-reader-method *the-class-slot-object* gf slot-name))))
-  (when (or (null type) (eq type 'writer))
-    (let* ((name (slot-writer-symbol slot-name))
-	   (gf (ensure-generic-function name)))
-      (unless (generic-function-methods gf)
-	(add-writer-method *the-class-slot-object* gf slot-name))))
-  (when (and *optimize-slot-boundp*
-	     (or (null type) (eq type 'boundp)))
-    (let* ((name (slot-boundp-symbol slot-name))
-	   (gf (ensure-generic-function name)))
-      (unless (generic-function-methods gf)
-	(add-boundp-method *the-class-slot-object* gf slot-name))))
-  nil)
-
-(defun initialize-internal-slot-gfs* (readers writers boundps)
-  (dolist (reader readers)
-    (initialize-internal-slot-gfs reader 'reader))
-  (dolist (writer writers)
-    (initialize-internal-slot-gfs writer 'writer))
-  (dolist (boundp boundps)
-    (initialize-internal-slot-gfs boundp 'boundp)))
diff --git a/pcl/slots.lisp b/pcl/slots.lisp
deleted file mode 100644
index 6cb3c866e7634ba7247234b74fa25a8782832ebc..0000000000000000000000000000000000000000
--- a/pcl/slots.lisp
+++ /dev/null
@@ -1,385 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-(defmethod wrapper-fetcher ((class standard-class))
-  'std-instance-wrapper)
-
-(defmethod slots-fetcher ((class standard-class))
-  'std-instance-slots)
-
-(defmethod raw-instance-allocator ((class standard-class))
-  'allocate-standard-instance)
-
-;;;
-;;; These four functions work on std-instances and fsc-instances.  These are
-;;; instances for which it is possible to change the wrapper and the slots.
-;;;
-;;; For these kinds of instances, most specified methods from the instance
-;;; structure protocol are promoted to the implementation-specific class
-;;; std-class.  Many of these methods call these four functions.
-;;;
-
-(defun set-wrapper (inst new)
-  (cond ((std-instance-p inst)
-	 #+new-kcl-wrapper
-	 (set-structure-def inst new)
-	 #-new-kcl-wrapper
-	 (setf (std-instance-wrapper inst) new))
-	((fsc-instance-p inst)
-	 (setf (fsc-instance-wrapper inst) new))
-	(t
-	 (error "What kind of instance is this?"))))
-
-#+ignore ; can't do this when using #+new-kcl-wrapper
-(defun set-slots (inst new)
-  (cond ((std-instance-p inst)
-	 (setf (std-instance-slots inst) new))
-	((fsc-instance-p inst)
-	 (setf (fsc-instance-slots inst) new))
-	(t
-	 (error "What kind of instance is this?"))))
-
-(defun swap-wrappers-and-slots (i1 i2)
-  (without-interrupts
-   (cond ((std-instance-p i1)
-	  #+new-kcl-wrapper
-	  (swap-structure-contents i1 i2)
-	  #-new-kcl-wrapper
-	  (let ((w1 (std-instance-wrapper i1))
-		(s1 (std-instance-slots i1)))
-	    (setf (std-instance-wrapper i1) (std-instance-wrapper i2))
-	    (setf (std-instance-slots i1) (std-instance-slots i2))
-	    (setf (std-instance-wrapper i2) w1)
-	    (setf (std-instance-slots i2) s1)))
-	 ((fsc-instance-p i1)
-	  (let ((w1 (fsc-instance-wrapper i1))
-		(s1 (fsc-instance-slots i1)))
-	    (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2))
-	    (setf (fsc-instance-slots i1) (fsc-instance-slots i2))
-	    (setf (fsc-instance-wrapper i2) w1)
-	    (setf (fsc-instance-slots i2) s1)))
-	 (t
-	  (error "What kind of instance is this?")))))
-
-
-
-
-
-
-(defun get-class-slot-value-1 (object wrapper slot-name)
-  (let ((entry (assoc slot-name (wrapper-class-slots wrapper))))
-    (if (null entry)
-	(slot-missing (wrapper-class wrapper) object slot-name 'slot-value)
-	(if (eq (cdr entry) *slot-unbound*)
-	    (slot-unbound (wrapper-class wrapper) object slot-name)
-	    (cdr entry)))))
-
-(defun set-class-slot-value-1 (new-value object wrapper slot-name)
-  (let ((entry (assoc slot-name (wrapper-class-slots wrapper))))
-    (if (null entry)
-	(slot-missing (wrapper-class wrapper)
-		      object
-		      slot-name
-		      'setf
-		      new-value)
-	(setf (cdr entry) new-value))))
-
-(defmethod class-slot-value ((class std-class) slot-name)
-  (let ((wrapper (class-wrapper class))
-	(prototype (class-prototype class)))
-    (get-class-slot-value-1 prototype wrapper slot-name)))
-
-(defmethod (setf class-slot-value) (nv (class std-class) slot-name)
-  (let ((wrapper (class-wrapper class))
-	(prototype (class-prototype class)))
-    (set-class-slot-value-1 nv prototype wrapper slot-name)))
-
-
-
-(defun find-slot-definition (class slot-name)
-  (dolist (slot (class-slots class) nil)
-    (when (eql slot-name (slot-definition-name slot))
-      (return slot))))
-
-(defun slot-value (object slot-name)
-  (let* ((class (class-of object))
-	 (slot-definition (find-slot-definition class slot-name)))
-    (if (null slot-definition)
-	(slot-missing class object slot-name 'slot-value)
-	(slot-value-using-class class object slot-definition))))
-
-(setf (gdefinition 'slot-value-normal) #'slot-value)
-
-(define-compiler-macro slot-value (object-form slot-name-form)
-  (if (and (constantp slot-name-form)
-	   (let ((slot-name (eval slot-name-form)))
-	     (and (symbolp slot-name) (symbol-package slot-name))))
-      `(accessor-slot-value ,object-form ,slot-name-form)
-      `(slot-value-normal ,object-form ,slot-name-form)))
-
-(defun set-slot-value (object slot-name new-value)
-  (let* ((class (class-of object))
-	 (slot-definition (find-slot-definition class slot-name)))
-    (if (null slot-definition)
-	(slot-missing class object slot-name 'setf)
-	(setf (slot-value-using-class class object slot-definition) 
-	      new-value))))
-
-(setf (gdefinition 'set-slot-value-normal) #'set-slot-value)
-
-(define-compiler-macro set-slot-value (object-form slot-name-form new-value-form)
-  (if (and (constantp slot-name-form)
-	   (let ((slot-name (eval slot-name-form)))
-	     (and (symbolp slot-name) (symbol-package slot-name))))
-      `(accessor-set-slot-value ,object-form ,slot-name-form ,new-value-form)
-      `(set-slot-value-normal ,object-form ,slot-name-form ,new-value-form)))
-
-(defconstant *optimize-slot-boundp* nil)
-
-(defun slot-boundp (object slot-name)
-  (let* ((class (class-of object))
-	 (slot-definition (find-slot-definition class slot-name)))
-    (if (null slot-definition)
-	(slot-missing class object slot-name 'slot-boundp)
-	(slot-boundp-using-class class object slot-definition))))
-
-(setf (gdefinition 'slot-boundp-normal) #'slot-boundp)
-
-(define-compiler-macro slot-boundp (object-form slot-name-form)
-  (if (and (constantp slot-name-form)
-	   (let ((slot-name (eval slot-name-form)))
-	     (and (symbolp slot-name) (symbol-package slot-name))))
-      `(accessor-slot-boundp ,object-form ,slot-name-form)
-      `(slot-boundp-normal ,object-form ,slot-name-form)))
-
-(defun slot-makunbound (object slot-name)
-  (let* ((class (class-of object))
-         (slot-definition (find-slot-definition class slot-name)))
-    (if (null slot-definition)
-        (slot-missing class object slot-name 'slot-makunbound)
-        (slot-makunbound-using-class class object slot-definition))))
-
-(defun slot-exists-p (object slot-name)
-  (let ((class (class-of object)))
-    (not (null (find-slot-definition class slot-name)))))
-
-;;;
-;;; This isn't documented, but is used within PCL in a number of print
-;;; object methods (see named-object-print-function).
-;;; 
-(defun slot-value-or-default (object slot-name &optional (default "unbound"))
-  (if (slot-boundp object slot-name)
-      (slot-value object slot-name)
-      default))
-
-
-;;;
-;;; 
-;;; 
-(defun standard-instance-access (instance location)
-  (%instance-ref (std-instance-slots instance) location))
-
-(defun funcallable-standard-instance-access (instance location)
-  (%instance-ref (fsc-instance-slots instance) location))
-
-(defmethod slot-value-using-class ((class std-class)
-                                   (object standard-object)
-                                   (slotd standard-effective-slot-definition))
-  (let* ((location (slot-definition-location slotd))
-	 (value (typecase location
-		  (fixnum 
-		   (cond ((std-instance-p object)
-			  (unless (eq 't (wrapper-state (std-instance-wrapper object)))
-			    (check-wrapper-validity object))
-			  (%instance-ref (std-instance-slots object) location))
-			 ((fsc-instance-p object)
-			  (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
-			    (check-wrapper-validity object))
-			  (%instance-ref (fsc-instance-slots object) location))
-			 (t (error "What kind of instance is this?"))))
-		  (cons
-		   (cdr location))
-		  (t
-		   (error "The slot ~s has neither :instance nor :class allocation, ~@
-                           so it can't be read by the default ~s method."
-			  slotd 'slot-value-using-class)))))
-    (if (eq value *slot-unbound*)
-	(slot-unbound class object (slot-definition-name slotd))
-	value)))
-
-(defmethod (setf slot-value-using-class)
-	   (new-value (class std-class)
-		      (object standard-object)
-		      (slotd standard-effective-slot-definition))
-  (let ((location (slot-definition-location slotd)))
-    (typecase location
-      (fixnum 
-       (cond ((std-instance-p object)
-	      (unless (eq 't (wrapper-state (std-instance-wrapper object)))
-		(check-wrapper-validity object))
-	      (setf (%instance-ref (std-instance-slots object) location) new-value))
-	     ((fsc-instance-p object)
-	      (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
-		(check-wrapper-validity object))
-	      (setf (%instance-ref (fsc-instance-slots object) location) new-value))
-	     (t (error "What kind of instance is this?"))))
-      (cons
-       (setf (cdr location) new-value))
-      (t
-       (error "The slot ~s has neither :instance nor :class allocation, ~@
-                           so it can't be written by the default ~s method."
-	      slotd '(setf slot-value-using-class))))))
-
-(defmethod slot-boundp-using-class
-	   ((class std-class) 
-	    (object standard-object) 
-	    (slotd standard-effective-slot-definition))
-  (let* ((location (slot-definition-location slotd))
-	 (value (typecase location
-		  (fixnum 
-		   (cond ((std-instance-p object)
-			  (unless (eq 't (wrapper-state (std-instance-wrapper object)))
-			    (check-wrapper-validity object))
-			  (%instance-ref (std-instance-slots object) location))
-			 ((fsc-instance-p object)
-			  (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
-			    (check-wrapper-validity object))
-			  (%instance-ref (fsc-instance-slots object) location))
-			 (t (error "What kind of instance is this?"))))
-		  (cons
-		   (cdr location))
-		  (t
-		   (error "The slot ~s has neither :instance nor :class allocation, ~@
-                           so it can't be read by the default ~s method."
-			  slotd 'slot-boundp-using-class)))))
-    (not (eq value *slot-unbound*))))
-
-(defmethod slot-makunbound-using-class
-	   ((class std-class)
-	    (object standard-object) 
-	    (slotd standard-effective-slot-definition))
-  (let ((location (slot-definition-location slotd)))
-    (typecase location
-      (fixnum 
-       (cond ((std-instance-p object)
-	      (unless (eq 't (wrapper-state (std-instance-wrapper object)))
-		(check-wrapper-validity object))
-	      (setf (%instance-ref (std-instance-slots object) location) *slot-unbound*))
-	     ((fsc-instance-p object)
-	      (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
-		(check-wrapper-validity object))
-	      (setf (%instance-ref (fsc-instance-slots object) location) *slot-unbound*))
-	     (t (error "What kind of instance is this?"))))
-      (cons
-       (setf (cdr location) *slot-unbound*))
-      (t
-       (error "The slot ~s has neither :instance nor :class allocation, ~@
-                           so it can't be written by the default ~s method."
-	      slotd 'slot-makunbound-using-class))))
-  nil)
-
-(defmethod slot-value-using-class
-    ((class structure-class)
-     (object structure-object)
-     (slotd structure-effective-slot-definition))
-  (let* ((function (slot-definition-internal-reader-function slotd))
-	 (value (funcall function object)))
-    #+cmu (declare (type function function))
-    (if (eq value *slot-unbound*)
-	(slot-unbound class object (slot-definition-name slotd))
-	value)))
-
-(defmethod (setf slot-value-using-class)
-    (new-value (class structure-class)
-	       (object structure-object)
-	       (slotd structure-effective-slot-definition))
-  (let ((function (slot-definition-internal-writer-function slotd)))
-    #+cmu (declare (type function function))
-    (funcall function new-value object)))
-
-(defmethod slot-boundp-using-class
-	   ((class structure-class) 
-	    (object structure-object)
-	    (slotd structure-effective-slot-definition))
-  #-new-kcl-wrapper t
-  #+new-kcl-wrapper
-  (let* ((function (slot-definition-internal-reader-function slotd))
-	 (value (funcall function object)))
-    #+cmu (declare (type function function))
-    (not (eq value *slot-unbound*))))
-
-(defmethod slot-makunbound-using-class
-	   ((class structure-class)
-	    (object structure-object)
-	    (slotd structure-effective-slot-definition))
-  (error "Structure slots can't be unbound"))
-
-
-(defmethod slot-missing
-	   ((class t) instance slot-name operation &optional new-value)
-  (error "When attempting to ~A,~%the slot ~S is missing from the object ~S."
-	 (ecase operation
-	   (slot-value "read the slot's value (slot-value)")
-	   (setf (format nil
-			 "set the slot's value to ~S (setf of slot-value)"
-			 new-value))
-	   (slot-boundp "test to see if slot is bound (slot-boundp)")
-	   (slot-makunbound "make the slot unbound (slot-makunbound)"))
-	 slot-name
-	 instance))
-
-(defmethod slot-unbound ((class t) instance slot-name)
-  (error "The slot ~S is unbound in the object ~S." slot-name instance))
-
-(defun slot-unbound-internal (instance position)
-  (slot-unbound (class-of instance) instance 
-		(etypecase position
-		  (fixnum 
-		   (nth position 
-			(wrapper-instance-slots-layout (wrapper-of instance))))
-		  (cons
-		   (car position)))))
-
-
-(defmethod allocate-instance ((class standard-class) &rest initargs)
-  (declare (ignore initargs))
-  (unless (class-finalized-p class) (finalize-inheritance class))
-  (allocate-standard-instance (class-wrapper class)))
-
-(defmethod allocate-instance ((class structure-class) &rest initargs)
-  (declare (ignore initargs))
-  #-new-kcl-wrapper
-  (let ((constructor (class-defstruct-constructor class)))
-    (if constructor
-	(funcall constructor)
-	(error "Can't allocate an instance of class ~S" (class-name class))))
-  #+new-kcl-wrapper
-  (allocate-standard-instance (class-wrapper class)))
-
-
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
deleted file mode 100644
index 50e29e5716bf6e629d008a813714fde260b405e0..0000000000000000000000000000000000000000
--- a/pcl/std-class.lisp
+++ /dev/null
@@ -1,1266 +0,0 @@
-;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-(defmethod slot-accessor-function ((slotd effective-slot-definition) type)
-  (ecase type
-    (reader (slot-definition-reader-function slotd))
-    (writer (slot-definition-writer-function slotd))
-    (boundp (slot-definition-boundp-function slotd))))
-
-(defmethod (setf slot-accessor-function) (function 
-					  (slotd effective-slot-definition) type)
-  (ecase type
-    (reader (setf (slot-definition-reader-function slotd) function))
-    (writer (setf (slot-definition-writer-function slotd) function))
-    (boundp (setf (slot-definition-boundp-function slotd) function))))
-
-(defconstant *slotd-reader-function-std-p* 1)
-(defconstant *slotd-writer-function-std-p* 2)
-(defconstant *slotd-boundp-function-std-p* 4)
-(defconstant *slotd-all-function-std-p* 7)
-
-(defmethod slot-accessor-std-p ((slotd effective-slot-definition) type)
-  (let ((flags (slot-value slotd 'accessor-flags)))
-    (declare (type fixnum flags))
-    (if (eq type 'all)
-	(eql *slotd-all-function-std-p* flags)
-	(let ((mask (ecase type
-		      (reader *slotd-reader-function-std-p*)
-		      (writer *slotd-writer-function-std-p*)
-		      (boundp *slotd-boundp-function-std-p*))))
-	  (declare (type fixnum mask))
-	  (not (zerop (the fixnum (logand mask flags))))))))
-
-(defmethod (setf slot-accessor-std-p) (value (slotd effective-slot-definition) type)
-  (let ((mask (ecase type
-		(reader *slotd-reader-function-std-p*)
-		(writer *slotd-writer-function-std-p*)
-		(boundp *slotd-boundp-function-std-p*)))
-	(flags (slot-value slotd 'accessor-flags)))
-    (declare (type fixnum mask flags))
-    (setf (slot-value slotd 'accessor-flags)
-	  (if value
-	      (the fixnum (logior mask flags))
-	      (the fixnum (logand (the fixnum (lognot mask)) flags)))))
-  value)
-
-(defmethod initialize-internal-slot-functions ((slotd effective-slot-definition))
-  (let* ((name (slot-value slotd 'name))
-	 (class (slot-value slotd 'class)))
-    (let ((table (or (gethash name *name->class->slotd-table*)
-		     (setf (gethash name *name->class->slotd-table*)
-			   (make-hash-table :test 'eq :size 5)))))
-      (setf (gethash class table) slotd))
-    (dolist (type '(reader writer boundp))
-      (let* ((gf-name (ecase type
-			      (reader 'slot-value-using-class)
-			      (writer '(setf slot-value-using-class))
-			      (boundp 'slot-boundp-using-class)))
-	     (gf (gdefinition gf-name)))
-	(compute-slot-accessor-info slotd type gf)))
-    (initialize-internal-slot-gfs name)))
-
-(defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf)
-  (let* ((name (slot-value slotd 'name))
-	 (class (slot-value slotd 'class))
-	 (old-slotd (find-slot-definition class name))
-	 (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
-    (multiple-value-bind (function std-p)
-	(if (eq *boot-state* 'complete)
-	    (get-accessor-method-function gf type class slotd)
-	    (get-optimized-std-accessor-method-function class slotd type))
-      #+kcl (si:turbo-closure function)
-      (setf (slot-accessor-std-p slotd type) std-p)
-      (setf (slot-accessor-function slotd type) function))
-    (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
-      (push (cons class name) *pv-table-cache-update-info*))))
-
-(defmethod slot-definition-allocation ((slotd structure-slot-definition))
-  :instance)
-
-
-
-(defmethod shared-initialize :after ((object documentation-mixin)
-                                     slot-names
-                                     &key (documentation nil documentation-p))
-  (declare (ignore slot-names))
-  (when documentation-p
-    (setf (plist-value object 'documentation) documentation)))
-
-(defmethod documentation (object &optional doc-type)
-  (lisp:documentation object doc-type))
-
-(defmethod (setf documentation) (new-value object &optional doc-type)
-  (declare (ignore new-value doc-type))
-  (error "Can't change the documentation of ~S." object))
-
-
-(defmethod documentation ((object documentation-mixin) &optional doc-type)
-  (declare (ignore doc-type))
-  (plist-value object 'documentation))
-
-(defmethod (setf documentation) (new-value (object documentation-mixin) &optional doc-type)
-  (declare (ignore doc-type))
-  (setf (plist-value object 'documentation) new-value))
-
-
-(defmethod documentation ((slotd standard-slot-definition) &optional doc-type)
-  (declare (ignore doc-type))
-  (slot-value slotd 'documentation))
-
-(defmethod (setf documentation) (new-value (slotd standard-slot-definition) &optional doc-type)
-  (declare (ignore doc-type))
-  (setf (slot-value slotd 'documentation) new-value))
-
-
-;;;
-;;; Various class accessors that are a little more complicated than can be
-;;; done with automatically generated reader methods.
-;;;
-(defmethod class-finalized-p ((class pcl-class))
-  (with-slots (wrapper) class
-    (not (null wrapper))))
-
-(defmethod class-prototype ((class std-class))
-  (with-slots (prototype) class
-    (or prototype (setq prototype (allocate-instance class)))))
-
-(defmethod class-prototype ((class structure-class))
-  (with-slots (prototype wrapper defstruct-constructor) class
-    (or prototype 
-	(setq prototype 
-	      (if #-new-kcl-wrapper defstruct-constructor #+new-kcl-wrapper nil 
-		  (allocate-instance class)
-		  (allocate-standard-instance wrapper))))))
-
-(defmethod class-direct-default-initargs ((class slot-class))
-  (plist-value class 'direct-default-initargs))
-
-(defmethod class-default-initargs ((class slot-class))
-  (plist-value class 'default-initargs))
-
-(defmethod class-constructors ((class slot-class))
-  (plist-value class 'constructors))
-
-(defmethod class-slot-cells ((class std-class))
-  (plist-value class 'class-slot-cells))
-
-
-;;;
-;;; Class accessors that are even a little bit more complicated than those
-;;; above.  These have a protocol for updating them, we must implement that
-;;; protocol.
-;;; 
-
-;;;
-;;; Maintaining the direct subclasses backpointers.  The update methods are
-;;; here, the values are read by an automatically generated reader method.
-;;; 
-(defmethod add-direct-subclass ((class class) (subclass class))
-  (with-slots (direct-subclasses) class
-    (pushnew subclass direct-subclasses)
-    subclass))
-
-(defmethod remove-direct-subclass ((class class) (subclass class))
-  (with-slots (direct-subclasses) class
-    (setq direct-subclasses (remove subclass direct-subclasses))
-    subclass))
-
-;;;
-;;; Maintaining the direct-methods and direct-generic-functions backpointers.
-;;;
-;;; There are four generic functions involved, each has one method for the
-;;; class case and another method for the damned EQL specializers. All of
-;;; these are specified methods and appear in their specified place in the
-;;; class graph.
-;;;
-;;;   ADD-DIRECT-METHOD
-;;;   REMOVE-DIRECT-METHOD
-;;;   SPECIALIZER-DIRECT-METHODS
-;;;   SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
-;;;
-;;; In each case, we maintain one value which is a cons.  The car is the list
-;;; methods.  The cdr is a list of the generic functions.  The cdr is always
-;;; computed lazily.
-;;;
-
-(defmethod add-direct-method ((specializer class) (method method))
-  (with-slots (direct-methods) specializer
-    (setf (car direct-methods) (adjoin method (car direct-methods))	;PUSH
-	  (cdr direct-methods) ()))
-  method)
-
-(defmethod remove-direct-method ((specializer class) (method method))
-  (with-slots (direct-methods) specializer
-    (setf (car direct-methods) (remove method (car direct-methods))
-	  (cdr direct-methods) ()))
-  method)
-
-(defmethod specializer-direct-methods ((specializer class))
-  (with-slots (direct-methods) specializer
-    (car direct-methods)))
-
-(defmethod specializer-direct-generic-functions ((specializer class))
-  (with-slots (direct-methods) specializer
-    (or (cdr direct-methods)
-	(setf (cdr direct-methods)
-	      (gathering1 (collecting-once)
-		(dolist (m (car direct-methods))
-		  (gather1 (method-generic-function m))))))))
-
-
-
-;;;
-;;; This hash table is used to store the direct methods and direct generic
-;;; functions of EQL specializers.  Each value in the table is the cons.
-;;; 
-(defvar *eql-specializer-methods* (make-hash-table :test #'eql))
-(defvar *class-eq-specializer-methods* (make-hash-table :test #'eq))
-
-(defmethod specializer-method-table ((specializer eql-specializer))
-  *eql-specializer-methods*)
-
-(defmethod specializer-method-table ((specializer class-eq-specializer))
-  *class-eq-specializer-methods*)
-
-(defmethod add-direct-method ((specializer specializer-with-object) (method method))
-  (let* ((object (specializer-object specializer))
-	 (table (specializer-method-table specializer))
-	 (entry (gethash object table)))
-    (unless entry
-      (setq entry
-	    (setf (gethash object table)
-		  (cons nil nil))))
-    (setf (car entry) (adjoin method (car entry))
-	  (cdr entry) ())
-    method))
-
-(defmethod remove-direct-method ((specializer specializer-with-object) (method method))
-  (let* ((object (specializer-object specializer))
-	 (entry (gethash object (specializer-method-table specializer))))
-    (when entry
-      (setf (car entry) (remove method (car entry))
-	    (cdr entry) ()))
-    method))
-
-(defmethod specializer-direct-methods ((specializer specializer-with-object))  
-  (car (gethash (specializer-object specializer)
-		(specializer-method-table specializer))))
-
-(defmethod specializer-direct-generic-functions ((specializer specializer-with-object))
-  (let* ((object (specializer-object specializer))
-	 (entry (gethash object (specializer-method-table specializer))))
-    (when entry
-      (or (cdr entry)
-	  (setf (cdr entry)
-		(gathering1 (collecting-once)
-		  (dolist (m (car entry))
-		    (gather1 (method-generic-function m)))))))))
-
-(defun map-specializers (function)
-  (map-all-classes #'(lambda (class)
-		       (funcall function (class-eq-specializer class))
-		       (funcall function class)))
-  (maphash #'(lambda (object methods)
-	       (declare (ignore methods))
-	       (intern-eql-specializer object))
-	   *eql-specializer-methods*)
-  (maphash #'(lambda (object specl)
-	       (declare (ignore object))
-	       (funcall function specl))
-	   *eql-specializer-table*)
-  nil)
-
-(defun map-all-generic-functions (function)
-  (let ((all-generic-functions (make-hash-table :test 'eq)))
-    (map-specializers #'(lambda (specl)
-			  (dolist (gf (specializer-direct-generic-functions specl))
-			    (unless (gethash gf all-generic-functions)
-			      (setf (gethash gf all-generic-functions) t)
-			      (funcall function gf))))))
-  nil)
-
-(defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key)
-  (declare (ignore slot-names))
-  (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
-
-(defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
-  (declare (ignore slot-names))
-  (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
-
-
-
-(defun real-load-defclass (name metaclass-name supers slots other accessors)
-  (do-standard-defsetfs-for-defclass accessors)	                ;***
-  (apply #'ensure-class name :metaclass metaclass-name
-			     :direct-superclasses supers
-			     :direct-slots slots
-			     :definition-source `((defclass ,name)
-						  ,(load-truename))
-			     other))
-
-(setf (gdefinition 'load-defclass) #'real-load-defclass)
-
-(defun ensure-class (name &rest all)
-  (apply #'ensure-class-using-class name (find-class name nil) all))
-
-(defmethod ensure-class-using-class (name (class null) &rest args &key)
-  (multiple-value-bind (meta initargs)
-      (ensure-class-values class args)
-    (inform-type-system-about-class (class-prototype meta) name);***
-    (setf class (apply #'make-instance meta :name name initargs)
-	  (find-class name) class)
-    (inform-type-system-about-class class name)	                ;***
-    class))
-
-(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
-  (multiple-value-bind (meta initargs)
-      (ensure-class-values class args)
-    (unless (eq (class-of class) meta) (change-class class meta))
-    (apply #'reinitialize-instance class initargs)
-    (setf (find-class name) class)
-    (inform-type-system-about-class class name)	                ;***
-    class))
-
-(defmethod class-predicate-name ((class t))
-  'function-returning-nil)
-
-(defun ensure-class-values (class args)
-  (let* ((initargs (copy-list args))
-	 (unsupplied (list 1))
-	 (supplied-meta   (getf initargs :metaclass unsupplied))
-	 (supplied-supers (getf initargs :direct-superclasses unsupplied))
-	 (supplied-slots  (getf initargs :direct-slots unsupplied))
-	 (meta
-	   (cond ((neq supplied-meta unsupplied)
-		  (find-class supplied-meta))
-		 ((or (null class)
-		      (forward-referenced-class-p class))
-		  *the-class-standard-class*)
-		 (t
-		  (class-of class)))))  
-    (flet ((fix-super (s)
-	     (cond ((classp s) s)
-		   ((not (legal-class-name-p s))
-		    (error "~S is not a class or a legal class name." s))
-		   (t
-		    (or (find-class s nil)
-			(setf (find-class s)
-			      (make-instance 'forward-referenced-class
-					     :name s)))))))      
-      (loop (unless (remf initargs :metaclass) (return)))
-      (loop (unless (remf initargs :direct-superclasses) (return)))
-      (loop (unless (remf initargs :direct-slots) (return)))
-      (values meta
-	      (list* :direct-superclasses
-		     (and (neq supplied-supers unsupplied)
-			  (mapcar #'fix-super supplied-supers))
-		     :direct-slots
-		     (and (neq supplied-slots unsupplied) supplied-slots)
-		     initargs)))))
-
-
-;;;
-;;;
-;;;
-#|| ; since it doesn't do anything
-(defmethod shared-initialize :before ((class std-class)
-				      slot-names
-				      &key direct-superclasses)
-  (declare (ignore slot-names))
-  ;; *** error checking
-  )
-||#
-  
-(defmethod shared-initialize :after
-	   ((class std-class)
-	    slot-names
-	    &key (direct-superclasses nil direct-superclasses-p)
-		 (direct-slots nil direct-slots-p)
-		 (direct-default-initargs nil direct-default-initargs-p)
-	         (predicate-name nil predicate-name-p))
-  (declare (ignore slot-names))
-  (if direct-superclasses-p
-      (progn
-        (setq direct-superclasses (or direct-superclasses
-                                      (list *the-class-standard-object*)))
-        (dolist (superclass direct-superclasses)
-	  (unless (validate-superclass class superclass)
-	    (error "The class ~S was specified as a~%super-class of the class ~S;~%~
-                    but the meta-classes ~S and~%~S are incompatible."
-		   superclass class (class-of superclass) (class-of class))))
-        (setf (slot-value class 'direct-superclasses) direct-superclasses))
-      (setq direct-superclasses (slot-value class 'direct-superclasses)))
-  (setq direct-slots
-	(if direct-slots-p
-	    (setf (slot-value class 'direct-slots)
-		  (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots))
-	    (slot-value class 'direct-slots)))
-  (if direct-default-initargs-p
-      (setf (plist-value class 'direct-default-initargs) direct-default-initargs)
-      (setq direct-default-initargs (plist-value class 'direct-default-initargs)))
-  (setf (plist-value class 'class-slot-cells)
-	(gathering1 (collecting)
-	  (dolist (dslotd direct-slots)
-	    (when (eq (slot-definition-allocation dslotd) class)
-	      (let ((initfunction (slot-definition-initfunction dslotd)))
-		(gather1 (cons (slot-definition-name dslotd)
-			       (if initfunction 
-				   (funcall initfunction)
-				   *slot-unbound*))))))))
-  (setq predicate-name (if predicate-name-p
-			   (setf (slot-value class 'predicate-name)
-				 (car predicate-name))
-			   (or (slot-value class 'predicate-name)
-			       (setf (slot-value class 'predicate-name)
-				     (make-class-predicate-name (class-name class))))))
-  (add-direct-subclasses class direct-superclasses)
-  (update-class class nil)
-  (make-class-predicate class predicate-name)
-  (add-slot-accessors class direct-slots))
-
-(defmethod shared-initialize :before ((class class) slot-names &key name)
-  (declare (ignore slot-names name))
-  (setf (slot-value class 'type) `(class ,class))
-  (setf (slot-value class 'class-eq-specializer)
-	(make-instance 'class-eq-specializer :class class)))
-
-(defmethod reinitialize-instance :before ((class slot-class) &key)
-  (remove-direct-subclasses class (class-direct-superclasses class))
-  (remove-slot-accessors    class (class-direct-slots class)))
-
-(defmethod reinitialize-instance :after ((class slot-class)
-					 &rest initargs
-					 &key)
-  (map-dependents class
-		  #'(lambda (dependent)
-		      (apply #'update-dependent class dependent initargs))))
-
-(defmethod shared-initialize :after 
-      ((class structure-class)
-       slot-names
-       &key (direct-superclasses nil direct-superclasses-p)
-            (direct-slots nil direct-slots-p)
-            direct-default-initargs
-            (predicate-name nil predicate-name-p))
-  (declare (ignore slot-names direct-default-initargs))
-  (if direct-superclasses-p
-      (setf (slot-value class 'direct-superclasses)
-	    (or direct-superclasses
-		(setq direct-superclasses
-		      (and (not (eq (class-name class) 'structure-object))
-			   (list *the-class-structure-object*)))))
-      (setq direct-superclasses (slot-value class 'direct-superclasses)))
-  (let* ((name (class-name class))
-	 (from-defclass-p (slot-value class 'from-defclass-p))
-	 (defstruct-p (or from-defclass-p (not (structure-type-p name)))))
-    (if direct-slots-p
-	(setf (slot-value class 'direct-slots)
-	      (setq direct-slots
-		    (mapcar #'(lambda (pl)
-				(when defstruct-p
-				  (let* ((slot-name (getf pl :name))
-					 (acc-name (format nil "~s structure class ~a" 
-							   name slot-name))
-					 (accessor (intern acc-name)))
-				    (setq pl (list* :defstruct-accessor-symbol accessor
-						    pl))))
-				(make-direct-slotd class pl))
-			    direct-slots)))
-	(setq direct-slots (slot-value class 'direct-slots)))
-    (when defstruct-p
-      (let* ((include (car (slot-value class 'direct-superclasses)))
-	     (conc-name (intern (format nil "~s structure class " name)))
-	     (constructor (intern (format nil "~a constructor" conc-name)))
-	     (defstruct `(defstruct (,name
-				      ,@(when include
-					  `((:include ,(class-name include))))
-				      (:print-function print-std-instance)
-				      (:predicate nil)
-				      (:conc-name ,conc-name)
-				      (:constructor ,constructor ()))
-			   ,@(mapcar #'(lambda (slot)
-					 `(,(slot-definition-name slot)
-					   *slot-unbound*))
-			             direct-slots)))
-	     (reader-names (mapcar #'(lambda (slotd)
-				       (intern (format nil "~A~A reader" conc-name 
-						       (slot-definition-name slotd))))
-				   direct-slots))
-	     (writer-names (mapcar #'(lambda (slotd)
-				       (intern (format nil "~A~A writer" conc-name 
-						       (slot-definition-name slotd))))
-				   direct-slots))
-	     (readers-init 
-	      (mapcar #'(lambda (slotd reader-name)
-			  (let ((accessor 
-				 (slot-definition-defstruct-accessor-symbol slotd)))
-			    `(defun ,reader-name (obj)
-			       (declare (type ,name obj))
-			       (,accessor obj))))
-		      direct-slots reader-names))
-	     (writers-init 
-	      (mapcar #'(lambda (slotd writer-name)
-			  (let ((accessor 
-				 (slot-definition-defstruct-accessor-symbol slotd)))
-			    `(defun ,writer-name (nv obj)
-			       (declare (type ,name obj))
-			       (setf (,accessor obj) nv))))
-		      direct-slots writer-names))
-	     (defstruct-form
-	       `(progn
-		  ,defstruct
-		  ,@readers-init ,@writers-init
-		  (declare-structure ',name nil nil))))
-	(unless (structure-type-p name) (eval defstruct-form))
-	(mapc #'(lambda (dslotd reader-name writer-name)
-		  (let* ((reader (gdefinition reader-name))
-			 (writer (when (gboundp writer-name)
-				   (gdefinition writer-name))))
-		    (setf (slot-value dslotd 'internal-reader-function) reader)
-		    (setf (slot-value dslotd 'internal-writer-function) writer)))
-	      direct-slots reader-names writer-names)
-	(setf (slot-value class 'defstruct-form) defstruct-form)
-	(setf (slot-value class 'defstruct-constructor) constructor))))
-  (add-direct-subclasses class direct-superclasses)
-  (setf (slot-value class 'class-precedence-list) 
-	(compute-class-precedence-list class))
-  (setf (slot-value class 'slots) (compute-slots class))
-  #-new-kcl-wrapper
-  (unless (slot-value class 'wrapper) 
-    (setf (slot-value class 'wrapper) (make-wrapper 0 class)))
-  #+new-kcl-wrapper
-  (let ((wrapper (get (class-name class) 'si::s-data)))
-    (setf (slot-value class 'wrapper) wrapper)
-    (setf (wrapper-class wrapper) class))
-  (update-pv-table-cache-info class)
-  (setq predicate-name (if predicate-name-p
-			   (setf (slot-value class 'predicate-name)
-				 (car predicate-name))
-			   (or (slot-value class 'predicate-name)
-			       (setf (slot-value class 'predicate-name)
-				     (make-class-predicate-name (class-name class))))))
-  (make-class-predicate class predicate-name)
-  (add-slot-accessors class direct-slots))
-
-(defmethod direct-slot-definition-class ((class structure-class) initargs)
-  (declare (ignore initargs))
-  (find-class 'structure-direct-slot-definition))
-
-(defmethod finalize-inheritance ((class structure-class))
-  nil) ; always finalized
- 
-(defun add-slot-accessors (class dslotds)
-  (fix-slot-accessors class dslotds 'add))
-
-(defun remove-slot-accessors (class dslotds)
-  (fix-slot-accessors class dslotds 'remove))
-
-(defun fix-slot-accessors (class dslotds add/remove)  
-  (flet ((fix (gfspec name r/w)
-	   (let ((gf (ensure-generic-function gfspec)))
-	     (case r/w
-	       (r (if (eq add/remove 'add)
-		      (add-reader-method class gf name)
-		      (remove-reader-method class gf)))
-	       (w (if (eq add/remove 'add)
-		      (add-writer-method class gf name)
-		      (remove-writer-method class gf)))))))
-    (dolist (dslotd dslotds)
-      (let ((slot-name (slot-definition-name dslotd)))
-	(dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r))
-	(dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w))))))
-
-
-(defun add-direct-subclasses (class new)
-  (dolist (n new)
-    (unless (memq class (class-direct-subclasses class))
-      (add-direct-subclass n class))))
-
-(defun remove-direct-subclasses (class new)
-  (let ((old (class-direct-superclasses class)))
-    (dolist (o (set-difference old new))
-      (remove-direct-subclass o class))))
-
-
-;;;
-;;;
-;;;
-(defmethod finalize-inheritance ((class std-class))
-  (update-class class t))
-
-
-(defun class-has-a-forward-referenced-superclass-p (class)
-  (or (forward-referenced-class-p class)
-      (some #'class-has-a-forward-referenced-superclass-p
-	    (class-direct-superclasses class))))	 
-      
-;;;
-;;; Called by :after shared-initialize whenever a class is initialized or 
-;;; reinitialized.  The class may or may not be finalized.
-;;; 
-(defun update-class (class finalizep)  
-  (when (or finalizep (class-finalized-p class)
-	    (not (class-has-a-forward-referenced-superclass-p class)))
-    (update-cpl class (compute-class-precedence-list class))
-    (update-slots class (compute-slots class))
-    (update-gfs-of-class class)
-    (update-inits class (compute-default-initargs class))
-    (update-make-instance-function-table class))
-  (unless finalizep
-    (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
-
-(defun update-cpl (class cpl)
-  (when (class-finalized-p class)
-    (unless (equal (class-precedence-list class) cpl)
-      (force-cache-flushes class)))
-  (setf (slot-value class 'class-precedence-list) cpl)
-  (update-class-can-precede-p cpl))
-
-(defun update-class-can-precede-p (cpl)
-  (when cpl
-    (let ((first (car cpl)))
-      (dolist (c (cdr cpl))
-	(pushnew c (slot-value first 'can-precede-list))))
-    (update-class-can-precede-p (cdr cpl))))
-
-(defun class-can-precede-p (class1 class2)
-  (member class2 (class-can-precede-list class1)))
-
-(defun update-slots (class eslotds)
-  (let ((instance-slots ())
-	(class-slots    ()))
-    (dolist (eslotd eslotds)
-      (let ((alloc (slot-definition-allocation eslotd)))
-	(cond ((eq alloc :instance) (push eslotd instance-slots))
-	      ((classp alloc)       (push eslotd class-slots)))))
-    ;;
-    ;; If there is a change in the shape of the instances then the
-    ;; old class is now obsolete.
-    ;;
-    (let* ((nlayout (mapcar #'slot-definition-name
-			    (sort instance-slots #'< :key #'slot-definition-location)))
-	   (nslots (length nlayout))
-	   (nwrapper-class-slots (compute-class-slots class-slots))
-	   (owrapper (class-wrapper class))
-	   (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
-	   (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
-	   (nwrapper
-	    (cond ((null owrapper)
-		   (make-wrapper nslots class))
-		  ((and (equal nlayout olayout)
-			(not
-			 (iterate ((o (list-elements owrapper-class-slots))
-				   (n (list-elements nwrapper-class-slots)))
-				  (unless (eq (car o) (car n)) (return t)))))
-		   owrapper)
-		  (t
-		   ;;
-		   ;; This will initialize the new wrapper to have the same
-		   ;; state as the old wrapper.  We will then have to change
-		   ;; that.  This may seem like wasted work (it is), but the
-		   ;; spec requires that we call make-instances-obsolete.
-		   ;;
-		   (make-instances-obsolete class)
-		   (class-wrapper class)))))
-      (with-slots (wrapper slots) class
-	#+new-kcl-wrapper
-	(setf (si::s-data-name nwrapper) (class-name class))
-	(setf slots eslotds
-	      (wrapper-instance-slots-layout nwrapper) nlayout
-	      (wrapper-class-slots nwrapper) nwrapper-class-slots
-	      (wrapper-no-of-instance-slots nwrapper) nslots
-	      wrapper nwrapper))
-      (unless (eq owrapper nwrapper)
-	(update-pv-table-cache-info class)))))
-
-(defun compute-class-slots (eslotds)
-  (gathering1 (collecting)
-    (dolist (eslotd eslotds)
-      (gather1
-	(assoc (slot-definition-name eslotd)
-	       (class-slot-cells (slot-definition-allocation eslotd)))))))
-
-(defun compute-layout (cpl instance-eslotds)
-  (let* ((names
-	   (gathering1 (collecting)
-	     (dolist (eslotd instance-eslotds)
-	       (when (eq (slot-definition-allocation eslotd) :instance)
-		 (gather1 (slot-definition-name eslotd))))))
-	 (order ()))
-    (labels ((rwalk (tail)
-	       (when tail
-		 (rwalk (cdr tail))
-		 (dolist (ss (class-slots (car tail)))
-		   (let ((n (slot-definition-name ss)))
-		     (when (member n names)
-		       (setq order (cons n order)
-			     names (remove n names))))))))
-      (rwalk (if (slot-boundp (car cpl) 'slots)
-		 cpl
-		 (cdr cpl)))
-      (reverse (append names order)))))
-
-(defun update-gfs-of-class (class)
-  (when (and (class-finalized-p class)
-	     (let ((cpl (class-precedence-list class)))
-	       (or (member *the-class-slot-class* cpl)
-		   (member *the-class-standard-effective-slot-definition* cpl))))
-    (let ((gf-table (make-hash-table :test 'eq)))
-      (labels ((collect-gfs (class)
-		 (dolist (gf (specializer-direct-generic-functions class))
-		   (setf (gethash gf gf-table) t))
-		 (mapc #'collect-gfs (class-direct-superclasses class))))
-	(collect-gfs class)
-	(maphash #'(lambda (gf ignore)
-		     (declare (ignore ignore))
-		     (update-gf-dfun class gf))
-		 gf-table)))))
-
-(defun update-inits (class inits)
-  (setf (plist-value class 'default-initargs) inits))
-
-
-;;;
-;;;
-;;;
-(defmethod compute-default-initargs ((class slot-class))
-  (let ((cpl (class-precedence-list class))
-	(direct (class-direct-default-initargs class)))
-    (labels ((walk (tail)
-	       (if (null tail)
-		   nil
-		   (let ((c (pop tail)))
-		     (append (if (eq c class)
-				 direct 
-				 (class-direct-default-initargs c))
-			     (walk tail))))))
-      (let ((initargs (walk cpl)))
-	(delete-duplicates initargs :test #'eq :key #'car :from-end t)))))
-
-
-;;;
-;;; Protocols for constructing direct and effective slot definitions.
-;;;
-;;; 
-;;;
-;;;
-(defmethod direct-slot-definition-class ((class std-class) initargs)
-  (declare (ignore initargs))
-  (find-class 'standard-direct-slot-definition))
-
-(defun make-direct-slotd (class initargs)
-  (let ((initargs (list* :class class initargs)))
-    (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
-
-;;;
-;;;
-;;;
-(defmethod compute-slots ((class std-class))
-  ;;
-  ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
-  ;; for each different slot name we find in our superclasses.  Each
-  ;; call receives the class and a list of the dslotds with that name.
-  ;; The list is in most-specific-first order.
-  ;;
-  (let ((name-dslotds-alist ()))
-    (dolist (c (class-precedence-list class))
-      (let ((dslotds (class-direct-slots c)))
-	(dolist (d dslotds)
-	  (let* ((name (slot-definition-name d))
-		 (entry (assq name name-dslotds-alist)))
-	    (if entry
-		(push d (cdr entry))
-		(push (list name d) name-dslotds-alist))))))
-    (mapcar #'(lambda (direct)
-		(compute-effective-slot-definition class
-						   (nreverse (cdr direct))))
-	    name-dslotds-alist)))
-
-(defmethod compute-slots :around ((class std-class))
-  (let ((eslotds (call-next-method))
-	(cpl (class-precedence-list class))
-	(instance-slots ())
-	(class-slots    ()))
-    (dolist (eslotd eslotds)
-      (let ((alloc (slot-definition-allocation eslotd)))
-	(cond ((eq alloc :instance) (push eslotd instance-slots))
-	      ((classp alloc)       (push eslotd class-slots)))))
-    (let ((nlayout (compute-layout cpl instance-slots)))
-      (dolist (eslotd instance-slots)
-	(setf (slot-definition-location eslotd) 
-	      (position (slot-definition-name eslotd) nlayout))))
-    (dolist (eslotd class-slots)
-      (setf (slot-definition-location eslotd) 
-	    (assoc (slot-definition-name eslotd)
-		   (class-slot-cells (slot-definition-allocation eslotd)))))
-    (mapc #'initialize-internal-slot-functions eslotds)
-    eslotds))
-
-(defmethod compute-slots ((class structure-class))
-  (mapcan #'(lambda (superclass)
-	      (mapcar #'(lambda (dslotd)
-			  (compute-effective-slot-definition class
-							     (list dslotd)))
-		      (class-direct-slots superclass)))
-	  (reverse (slot-value class 'class-precedence-list))))
-
-(defmethod compute-slots :around ((class structure-class))
-  (let ((eslotds (call-next-method)))
-    (mapc #'initialize-internal-slot-functions eslotds)
-    eslotds))
-
-(defmethod compute-effective-slot-definition ((class slot-class) dslotds)
-  (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
-	 (class (effective-slot-definition-class class initargs)))
-    (apply #'make-instance class initargs)))
-
-(defmethod effective-slot-definition-class ((class std-class) initargs)
-  (declare (ignore initargs))
-  (find-class 'standard-effective-slot-definition))
-
-(defmethod effective-slot-definition-class ((class structure-class) initargs)
-  (declare (ignore initargs))
-  (find-class 'structure-effective-slot-definition))
-
-(defmethod compute-effective-slot-definition-initargs 
-    ((class slot-class) direct-slotds)
-  (let* ((name nil)
-	 (initfunction nil)
-	 (initform nil)
-	 (initargs nil)
-	 (allocation nil)
-	 (type t)
-	 (namep  nil)
-	 (initp  nil)
-	 (allocp nil))
-
-    (dolist (slotd direct-slotds)
-      (when slotd
-	(unless namep
-	  (setq name (slot-definition-name slotd)
-		namep t))
-	(unless initp
-	  (when (slot-definition-initfunction slotd)
-	    (setq initform (slot-definition-initform slotd)
-		  initfunction (slot-definition-initfunction slotd)
-		  initp t)))
-	(unless allocp
-	  (setq allocation (slot-definition-allocation slotd)
-		allocp t))
-	(setq initargs (append (slot-definition-initargs slotd) initargs))
-	(let ((slotd-type (slot-definition-type slotd)))
-	  (setq type (cond ((eq type 't) slotd-type)
-			   ((*subtypep type slotd-type) type)
-			   (t `(and ,type ,slotd-type)))))))
-    (list :name name
-	  :initform initform
-	  :initfunction initfunction
-	  :initargs initargs
-	  :allocation allocation
-	  :type type
-	  :class class)))
-
-(defmethod compute-effective-slot-definition-initargs :around
-    ((class structure-class) direct-slotds)
-  (let ((slotd (car direct-slotds)))
-    (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
-	   :internal-reader-function (slot-definition-internal-reader-function slotd)
-	   :internal-writer-function (slot-definition-internal-writer-function slotd)
-	   (call-next-method))))
-
-;;;
-;;; NOTE: For bootstrapping considerations, these can't use make-instance
-;;;       to make the method object.  They have to use make-a-method which
-;;;       is a specially bootstrapped mechanism for making standard methods.
-;;;
-(defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
-  (declare (ignore direct-slot initargs))
-  (find-class 'standard-reader-method))
-
-(defmethod add-reader-method ((class slot-class) generic-function slot-name)
-  (add-method generic-function 
-	      (make-a-method 'standard-reader-method
-			     ()
-			     (list (or (class-name class) 'object))
-			     (list class)
-			     (make-reader-method-function class slot-name)
-			     "automatically generated reader method"
-			     slot-name)))
-
-(defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
-  (declare (ignore direct-slot initargs))
-  (find-class 'standard-writer-method))
-
-(defmethod add-writer-method ((class slot-class) generic-function slot-name)
-  (add-method generic-function
-	      (make-a-method 'standard-writer-method
-			     ()
-			     (list 'new-value (or (class-name class) 'object))
-			     (list *the-class-t* class)
-			     (make-writer-method-function class slot-name)
-			     "automatically generated writer method"
-			     slot-name)))
-
-(defmethod add-boundp-method ((class slot-class) generic-function slot-name)
-  (add-method generic-function 
-	      (make-a-method 'standard-boundp-method
-			     ()
-			     (list (or (class-name class) 'object))
-			     (list class)
-			     (make-boundp-method-function class slot-name)
-			     "automatically generated boundp method"
-			     slot-name)))
-
-(defmethod remove-reader-method ((class slot-class) generic-function)
-  (let ((method (get-method generic-function () (list class) nil)))
-    (when method (remove-method generic-function method))))
-
-(defmethod remove-writer-method ((class slot-class) generic-function)
-  (let ((method
-	  (get-method generic-function () (list *the-class-t* class) nil)))
-    (when method (remove-method generic-function method))))
-
-(defmethod remove-boundp-method ((class slot-class) generic-function)
-  (let ((method (get-method generic-function () (list class) nil)))
-    (when method (remove-method generic-function method))))
-
-
-;;;
-;;; make-reader-method-function and make-write-method function are NOT part of
-;;; the standard protocol.  They are however useful, PCL makes uses makes use
-;;; of them internally and documents them for PCL users.
-;;;
-;;; *** This needs work to make type testing by the writer functions which
-;;; *** do type testing faster.  The idea would be to have one constructor
-;;; *** for each possible type test.  In order to do this it would be nice
-;;; *** to have help from inform-type-system-about-class and friends.
-;;;
-;;; *** There is a subtle bug here which is going to have to be fixed.
-;;; *** Namely, the simplistic use of the template has to be fixed.  We
-;;; *** have to give the optimize-slot-value method the user might have
-;;; *** defined for this metclass a chance to run.
-;;;
-(defmethod make-reader-method-function ((class slot-class) slot-name)
-  (make-std-reader-method-function (class-name class) slot-name))
-
-(defmethod make-writer-method-function ((class slot-class) slot-name)
-  (make-std-writer-method-function (class-name class) slot-name))
-
-(defmethod make-boundp-method-function ((class slot-class) slot-name)
-  (make-std-boundp-method-function (class-name class) slot-name))
-
-
-;;;; inform-type-system-about-class
-;;;; make-type-predicate
-;;;
-;;; These are NOT part of the standard protocol.  They are internal mechanism
-;;; which PCL uses to *try* and tell the type system about class definitions.
-;;; In a more fully integrated implementation of CLOS, the type system would
-;;; know about class objects and class names in a more fundamental way and
-;;; the mechanism used to inform the type system about new classes would be
-;;; different.
-;;;
-(defmethod inform-type-system-about-class ((class std-class) name)
-  (inform-type-system-about-std-class name))
-
-
-(defmethod compatible-meta-class-change-p (class proto-new-class)
-  (eq (class-of class) (class-of proto-new-class)))
-
-(defmethod validate-superclass ((class class) (new-super class))
-  (or (eq new-super *the-class-t*)
-      (eq (class-of class) (class-of new-super))))
-
-
-
-;;;
-;;;
-;;;
-(defun force-cache-flushes (class)
-  (let* ((owrapper (class-wrapper class))
-	 (state (wrapper-state owrapper)))
-    ;;
-    ;; We only need to do something if the state is still T.  If the
-    ;; state isn't T, it will be FLUSH or OBSOLETE, and both of those
-    ;; will already be doing what we want.  In particular, we must be
-    ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
-    ;; means do what FLUSH does and then some.
-    ;; 
-    (when (eq state 't)
-      (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
-				    class)))
-	(setf (wrapper-instance-slots-layout nwrapper)
-	      (wrapper-instance-slots-layout owrapper))
-	(setf (wrapper-class-slots nwrapper)
-	      (wrapper-class-slots owrapper))
-	(without-interrupts
-	  (setf (slot-value class 'wrapper) nwrapper)
-	  (invalidate-wrapper owrapper ':flush nwrapper))
-	(update-constructors class)))))		;??? ***
-
-(defun flush-cache-trap (owrapper nwrapper instance)
-  (declare (ignore owrapper))
-  (set-wrapper instance nwrapper))
-
-
-
-;;;
-;;; make-instances-obsolete can be called by user code.  It will cause the
-;;; next access to the instance (as defined in 88-002R) to trap through the
-;;; update-instance-for-redefined-class mechanism.
-;;; 
-(defmethod make-instances-obsolete ((class std-class))
-  (let* ((owrapper (class-wrapper class))
-	 (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
-				 class)))
-      (setf (wrapper-instance-slots-layout nwrapper)
-	    (wrapper-instance-slots-layout owrapper))
-      (setf (wrapper-class-slots nwrapper)
-	    (wrapper-class-slots owrapper))
-      (without-interrupts
-	(setf (slot-value class 'wrapper) nwrapper)
-	(invalidate-wrapper owrapper ':obsolete nwrapper)
-	class)))
-
-(defmethod make-instances-obsolete ((class symbol))
-  (make-instances-obsolete (find-class class)))
-
-
-;;;
-;;; obsolete-instance-trap is the internal trap that is called when we see
-;;; an obsolete instance.  The times when it is called are:
-;;;   - when the instance is involved in method lookup
-;;;   - when attempting to access a slot of an instance
-;;;
-;;; It is not called by class-of, wrapper-of, or any of the low-level instance
-;;; access macros.
-;;;
-;;; Of course these times when it is called are an internal implementation
-;;; detail of PCL and are not part of the documented description of when the
-;;; obsolete instance update happens.  The documented description is as it
-;;; appears in 88-002R.
-;;;
-;;; This has to return the new wrapper, so it counts on all the methods on
-;;; obsolete-instance-trap-internal to return the new wrapper.  It also does
-;;; a little internal error checking to make sure that the traps are only
-;;; happening when they should, and that the trap methods are computing
-;;; apropriate new wrappers.
-;;; 
-(defun obsolete-instance-trap (owrapper nwrapper instance)  
-  ;;
-  ;; local  --> local        transfer 
-  ;; local  --> shared       discard
-  ;; local  -->  --          discard
-  ;; shared --> local        transfer
-  ;; shared --> shared       discard
-  ;; shared -->  --          discard
-  ;;  --    --> local        add
-  ;;  --    --> shared        --
-  ;;
-  (let* ((class (wrapper-class* nwrapper))
-	 (guts (allocate-instance class))	;??? allocate-instance ???
-	 (olayout (wrapper-instance-slots-layout owrapper))
-	 (nlayout (wrapper-instance-slots-layout nwrapper))
-	 (oslots (get-slots instance))
-	 (nslots (get-slots guts))
-	 (oclass-slots (wrapper-class-slots owrapper))
-	 (added ())
-	 (discarded ())
-	 (plist ()))
-    ;;
-    ;; Go through all the old local slots.
-    ;; 
-    (iterate ((name (list-elements olayout))
-	      (opos (interval :from 0)))
-      (let ((npos (posq name nlayout)))
-	(if npos
-	    (setf (instance-ref nslots npos) (instance-ref oslots opos))
-	    (progn (push name discarded)
-		   (unless (eq (instance-ref oslots opos) *slot-unbound*)
-		     (setf (getf plist name) (instance-ref oslots opos)))))))
-    ;;
-    ;; Go through all the old shared slots.
-    ;;
-    (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
-      (let ((name (car oclass-slot-and-val))
-	    (val (cdr oclass-slot-and-val)))
-	(let ((npos (posq name nlayout)))
-	  (if npos
-	      (setf (instance-ref nslots npos) (cdr oclass-slot-and-val))
-	      (progn (push name discarded)
-		     (unless (eq val *slot-unbound*)
-		       (setf (getf plist name) val)))))))
-    ;;
-    ;; Go through all the new local slots to compute the added slots.
-    ;; 
-    (dolist (nlocal nlayout)
-      (unless (or (memq nlocal olayout)
-		  (assq nlocal oclass-slots))
-	(push nlocal added)))
-      
-    (swap-wrappers-and-slots instance guts)
-
-    (update-instance-for-redefined-class instance
-					 added
-					 discarded
-					 plist)
-    nwrapper))
-
-
-
-;;;
-;;;
-;;;
-(defmacro copy-instance-internal (instance)
-  `(#+new-kcl-wrapper if #-new-kcl-wrapper progn
-			 #+new-kcl-wrapper (not (std-instance-p ,instance))
-      (let* ((class (class-of instance))
-	     (copy (allocate-instance class)))
-	 (if (std-instance-p ,instance)
-	     (setf (std-instance-slots ,instance) (std-instance-slots ,instance))
-	     (setf (fsc-instance-slots ,instance) (fsc-instance-slots ,instance)))
-	 copy)
-      #+new-kcl-wrapper
-      (copy-structure-header ,instance)))
-
-(defun change-class-internal (instance new-class)
-  (let* ((old-class (class-of instance))
-	 (copy (copy-instance-internal instance))
-	 (guts (allocate-instance new-class))
-	 (new-wrapper (get-wrapper guts))
-	 (old-wrapper (class-wrapper old-class))
-	 (old-layout (wrapper-instance-slots-layout old-wrapper))
-	 (new-layout (wrapper-instance-slots-layout new-wrapper))
-	 (old-slots (get-slots instance))
-	 (new-slots (get-slots guts))
-	 (old-class-slots (wrapper-class-slots old-wrapper)))
-
-    ;;
-    ;; "The values of local slots specified by both the class Cto and
-    ;; Cfrom are retained.  If such a local slot was unbound, it remains
-    ;; unbound."
-    ;;     
-    (iterate ((new-slot (list-elements new-layout))
-	      (new-position (interval :from 0)))
-      (let ((old-position (posq new-slot old-layout)))
-	(when old-position
-	  (setf (instance-ref new-slots new-position)
-		(instance-ref old-slots old-position)))))
-
-    ;;
-    ;; "The values of slots specified as shared in the class Cfrom and
-    ;; as local in the class Cto are retained."
-    ;;
-    (iterate ((slot-and-val (list-elements old-class-slots)))
-      (let ((position (posq (car slot-and-val) new-layout)))
-	(when position
-	  (setf (instance-ref new-slots position) (cdr slot-and-val)))))
-
-    ;; Make the copy point to the old instance's storage, and make the
-    ;; old instance point to the new storage.
-    (swap-wrappers-and-slots instance guts)
-
-    (update-instance-for-different-class copy instance)
-    instance))
-
-(defmethod change-class ((instance standard-object)
-			 (new-class standard-class))
-  (unless (std-instance-p instance)
-    (error "Can't change the class of ~S to ~S~@
-            because it isn't already an instance with metaclass~%~S."
-	   instance
-	   new-class
-	   'standard-class))
-  (change-class-internal instance new-class))
-
-(defmethod change-class ((instance standard-object)
-			 (new-class funcallable-standard-class))
-  (unless (fsc-instance-p instance)
-    (error "Can't change the class of ~S to ~S~@
-            because it isn't already an instance with metaclass~%~S."
-	   instance
-	   new-class
-	   'funcallable-standard-class))
-  (change-class-internal instance new-class))
-
-(defmethod change-class ((instance t) (new-class-name symbol))
-  (change-class instance (find-class new-class-name)))
-
-
-
-;;;
-;;; The metaclass BUILT-IN-CLASS
-;;;
-;;; This metaclass is something of a weird creature.  By this point, all
-;;; instances of it which will exist have been created, and no instance
-;;; is ever created by calling MAKE-INSTANCE.
-;;;
-;;; But, there are other parts of the protcol we must follow and those
-;;; definitions appear here.
-;;; 
-(defmethod shared-initialize :before
-	   ((class built-in-class) slot-names &rest initargs)
-  (declare (ignore slot-names initargs))
-  (error "Attempt to initialize or reinitialize a built in class."))
-
-(defmethod class-direct-slots            ((class built-in-class)) ())
-(defmethod class-slots                   ((class built-in-class)) ())
-(defmethod class-direct-default-initargs ((class built-in-class)) ())
-(defmethod class-default-initargs        ((class built-in-class)) ())
-
-(defmethod validate-superclass ((c class) (s built-in-class))
-  (eq s *the-class-t*))
-
-
-
-;;;
-;;;
-;;;
-
-(defmethod validate-superclass ((c slot-class)
-						(f forward-referenced-class))
-  't)
-
-
-;;;
-;;;
-;;;
-
-(defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
-  (pushnew dependent (plist-value metaobject 'dependents)))
-
-(defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
-  (setf (plist-value metaobject 'dependents)
-	(delete dependent (plist-value metaobject 'dependents))))
-
-(defmethod map-dependents ((metaobject dependent-update-mixin) function)
-  (dolist (dependent (plist-value metaobject 'dependents))
-    (funcall function dependent)))
-
diff --git a/pcl/structure-class.lisp b/pcl/structure-class.lisp
deleted file mode 100644
index 75f678c442c21de2007e64f3ea91ed61933fa2f0..0000000000000000000000000000000000000000
--- a/pcl/structure-class.lisp
+++ /dev/null
@@ -1,340 +0,0 @@
-;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package 'pcl)
-
-(defmethod initialize-internal-slot-functions :after
-          ((slotd structure-effective-slot-definition))
-  (let ((name (slot-definition-name slotd)))
-    (initialize-internal-slot-reader-gfs name)
-    (initialize-internal-slot-writer-gfs name)
-    (initialize-internal-slot-boundp-gfs name)))
-
-(defmethod slot-definition-allocation ((slotd structure-slot-definition))
-  :instance)
-
-(defmethod class-prototype ((class structure-class))
-  (with-slots (prototype) class
-    (or prototype
-        (setq prototype (make-class-prototype class)))))
-
-(defmethod make-class-prototype ((class structure-class))
-  (with-slots (wrapper defstruct-constructor) class
-    (if defstruct-constructor
-        (make-instance class)
-      (let* ((proto (%allocate-instance--class *empty-vector*)))
-         (shared-initialize proto T :check-initargs-legality-p NIL)
-         (setf (std-instance-wrapper proto) wrapper)
-         proto))))
-
-
-(defmethod make-direct-slotd ((class structure-class)
-                              &rest initargs
-                              &key
-                              (name (error "Slot needs a name."))
-                              (conc-name (class-defstruct-conc-name class))
-                              (defstruct-accessor-symbol () acc-sym-p)
-                              &allow-other-keys)
-  (declare (ignore defstruct-accessor-symbol))
-  (declare (type symbol        name)
-           (type simple-string conc-name))
-  (let ((initargs (list* :class class :allow-other-keys T initargs)))
-    (unless acc-sym-p
-      (setf initargs
-            (list* :defstruct-accessor-symbol
-                   (intern (concatenate 'simple-string conc-name (symbol-name name))
-                           (symbol-package (class-name class)))
-                   initargs)))
-    (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
-
-(defun slot-definition-defstruct-slot-description (slot)
-  (let ((type (slot-definition-type slot)))
-    `(,(slot-definition-name slot) ,(slot-definition-initform slot)
-      ,@(unless (eq type t) `(:type ,type)))))
-
-(defmethod shared-initialize :after 
-      ((class structure-class)
-       slot-names
-       &key (direct-superclasses nil direct-superclasses-p)
-            (direct-slots nil direct-slots-p)
-            direct-default-initargs
-            (predicate-name   nil predicate-name-p))
-  (declare (ignore slot-names direct-default-initargs))
-  (let* ((name (class-name class))
-         (from-defclass-p (slot-value class 'from-defclass-p))
-         (defstruct-form (defstruct-form name))
-         (conc-name
-           (or (if defstruct-form (defstruct-form-conc-name defstruct-form))
-               (slot-value class 'defstruct-conc-name)
-               (format nil #-excl "~s structure class "
-                           #+excl "~s_STRUCTURE.CLASS_"
-                           name)))
-         (defstruct-predicate
-           (if defstruct-form (defstruct-form-predicate-name defstruct-form)))
-         (pred-name  ;; Predicate name for class
-           (or (if predicate-name-p (car predicate-name))
-               (if defstruct-form defstruct-predicate)
-               (slot-value class 'predicate-name)
-               (make-class-predicate-name name)))
-         (constructor
-           (or (if defstruct-form (defstruct-form-constructor defstruct-form))
-               (slot-value class 'defstruct-constructor)
-               (if from-defclass-p
-                   (list (intern (format nil "~aconstructor" conc-name)
-                                 (symbol-package name))
-                         ())))))
-    (declare (type symbol        name defstruct-predicate pred-name)
-             (type boolean       from-defclass-p)
-             (type simple-string conc-name))
-    (if direct-superclasses-p
-        (setf (slot-value class 'direct-superclasses)
-	      (or direct-superclasses
-		  (setq direct-superclasses
-                        (if (eq name 'structure-object)
-                            nil
-			    (list *the-class-structure-object*)))))
-        (setq direct-superclasses (slot-value class 'direct-superclasses)))
-    (setq direct-slots
-          (if direct-slots-p
-	      (setf (slot-value class 'direct-slots)
-		    (mapcar #'(lambda (pl)
-                                (apply #'make-direct-slotd class
-                                        :conc-name conc-name pl))
-			    direct-slots))
-	      (slot-value class 'direct-slots)))
-    (when from-defclass-p
-      (do-defstruct-from-defclass
-        class direct-superclasses direct-slots conc-name pred-name constructor))
-    (compile-structure-class-internals
-        class direct-slots conc-name pred-name constructor)
-    (setf (slot-value class 'predicate-name) pred-name)
-    (setf (slot-value class 'defstruct-conc-name) conc-name)
-    (unless (extract-required-parameters (second constructor))
-      (setf (slot-value class 'defstruct-constructor) (car constructor)))
-    (when (and defstruct-predicate (not from-defclass-p))
-      (setf (symbol-function pred-name) (symbol-function defstruct-predicate)))
-    (unless (or from-defclass-p (slot-value class 'documentation))
-      (setf (slot-value class 'documentation)
-            (format nil "~S structure class made from Defstruct" name)))
-    (setf (find-class name) class)
-    (update-structure-class class direct-superclasses direct-slots)))
-
-(defun update-structure-class (class direct-superclasses direct-slots)
-  (add-direct-subclasses class direct-superclasses)
-  (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class))
-  (let* ((eslotds (compute-slots class))
-         (internal-slotds (mapcar #'slot-definition-internal-slotd eslotds)))
-    (setf (slot-value class 'slots) eslotds)
-    (setf (slot-value class 'internal-slotds) internal-slotds)
-    (setf (slot-value class 'side-effect-internal-slotds) internal-slotds))
-  (unless (slot-value class 'wrapper)
-    (setf (slot-value class 'finalized-p) T)
-    (setf (slot-value class 'wrapper) (make-wrapper class)))
-  (unless (slot-boundp class 'prototype)
-    (setf (slot-value class 'prototype) nil))
-  (setf (slot-value class 'default-initargs) nil)
-  (add-slot-accessors class direct-slots))
-
-(defmethod do-defstruct-from-defclass ((class structure-class)
-                                       direct-superclasses direct-slots
-                                       conc-name predicate constructor)
-  (declare (type simple-string conc-name))
-  (let* ((name (class-name class))
-         (original-defstruct-form
-          `(original-defstruct
-              (,name
-		 ,@(when direct-superclasses
-		   `((:include ,(class-name (car direct-superclasses)))))
-		 (:print-function print-std-instance)
-		 (:predicate ,predicate)
-		 (:conc-name ,(intern conc-name (symbol-package name)))
-		 (:constructor ,@constructor))
-            ,@(mapcar #'slot-definition-defstruct-slot-description
-                      direct-slots))))
-    (eval original-defstruct-form)
-    (store-defstruct-form (cdr original-defstruct-form))))
-
-(defmethod compile-structure-class-internals ((class structure-class)
-                                              direct-slots conc-name
-                                              predicate-name constructor)
-  (declare (type simple-string conc-name))
-  (let* ((name    (class-name class))
-         (package (symbol-package name))
-         (direct-slots-needing-internals
-           (if (slot-value class 'from-defclass-p)
-               direct-slots
-               (remove-if #'slot-definition-internal-reader-function
-                          direct-slots)))
-	 (reader-names
-           (mapcar #'(lambda (slotd)
-		       (intern (format nil "~A~A reader" conc-name
-				       (slot-definition-name slotd))
-                                package))
-		   direct-slots-needing-internals))
-	 (writer-names
-           (mapcar #'(lambda (slotd)
-		       (intern (format nil "~A~A writer" conc-name 
-				       (slot-definition-name slotd))
-                               package))
-		   direct-slots-needing-internals))
-         (defstruct-accessor-names
-           (mapcar #'slot-definition-defstruct-accessor-symbol
-                   direct-slots-needing-internals))
-	 (readers-init
-	   (mapcar #'(lambda (defstruct-accessor reader-name)
-		       `(progn
-                          (force-compile ',defstruct-accessor)
-                          (defun ,reader-name (obj)
-		            (declare (type ,name obj) #.*optimize-speed*)
-			    (,defstruct-accessor obj))
-                          (force-compile ',reader-name)))
-		   defstruct-accessor-names reader-names))
-	 (writers-init
-	   (mapcar #'(lambda (defstruct-accessor writer-name)
-		       `(progn
-                          (force-compile ',defstruct-accessor)
-                          (defun ,writer-name (nv obj)
-			    (declare (type ,name obj) #.*optimize-speed*)
-			    (setf (,defstruct-accessor obj) nv))
-                          (force-compile ',writer-name)))
-		   defstruct-accessor-names writer-names))
-	 (defstruct-extras-form
-	   `(progn
-              ,@(when (car constructor)
-                  `((force-compile ',(car constructor))))
-              ,@(when (fboundp predicate-name)
-                  `((force-compile ',predicate-name)))
-	      ,@readers-init
-              ,@writers-init)))
-    (declare (type package package))
-    (eval defstruct-extras-form)
-    (mapc #'(lambda (dslotd reader-name writer-name)
-	      (setf (slot-value dslotd 'internal-reader-function)
-                    (gdefinition reader-name))
-	      (setf (slot-value dslotd 'internal-writer-function)
-                    (gdefinition writer-name)))
-	  direct-slots-needing-internals reader-names writer-names)))
-
-(defmethod reinitialize-instance :after ((class structure-class)
-					 &rest initargs
-					 &key)
-  (map-dependents class
-		  #'(lambda (dependent)
-		      (apply #'update-dependent class dependent initargs))))
-
-(defmethod direct-slot-definition-class ((class structure-class) initargs)
-  (declare (ignore initargs))
-  (find-class 'structure-direct-slot-definition))
-
-(defmethod effective-slot-definition-class ((class structure-class) initargs)
-  (declare (ignore initargs))
-  (find-class 'structure-effective-slot-definition))
-
-(defmethod finalize-inheritance ((class structure-class))
-  nil) ; always finalized
-
-
-(defmethod compute-slots ((class structure-class))
-  (mapcan #'(lambda (superclass)
-	      (mapcar #'(lambda (dslotd)
-			  (compute-effective-slot-definition
-			     class (slot-definition-name dslotd) (list dslotd)))
-		      (class-direct-slots superclass)))
-	  (reverse (slot-value class 'class-precedence-list))))
-
-(defmethod compute-slots :around ((class structure-class))
-  (let ((eslotds (call-next-method)))
-    (mapc #'initialize-internal-slot-functions eslotds)
-    eslotds))
-
-(defmethod compute-effective-slot-definition ((class structure-class)
-                                              name dslotds)
-  (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
-	 (class (effective-slot-definition-class class initargs))
-         (slot-definition (apply #'make-instance class initargs))
-         (internal-slotd
-           (make-internal-slotd
-             :name name
-             :slot-definition slot-definition
-             :initargs        (slot-definition-initargs     slot-definition)
-             :initfunction    (slot-definition-initfunction slot-definition))))
-    (setf (fast-slot-value slot-definition 'internal-slotd) internal-slotd)
-    slot-definition))
-
-(defmethod compute-effective-slot-definition-initargs :around
-    ((class structure-class) direct-slotds)
-  (let ((slotd (car direct-slotds)))
-    (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
-	   :internal-reader-function (slot-definition-internal-reader-function slotd)
-	   :internal-writer-function (slot-definition-internal-writer-function slotd)
-	   (call-next-method))))
-
-
-(defmethod make-optimized-reader-method-function ((class structure-class)
-                                                  generic-function
-                                                  reader-method-prototype
-                                                  slot-name)
-  (declare (ignore generic-function reader-method-prototype))
-  (make-structure-instance-reader-method-function slot-name))
-
-(defmethod make-optimized-writer-method-function ((class structure-class)
-                                                  generic-function
-                                                  writer-method-prototype
-                                                  slot-name)
-  (declare (ignore generic-function writer-method-prototype))
-  (make-structure-instance-writer-method-function slot-name))
-
-(defmethod make-optimized-boundp-method-function ((class structure-class)
-                                                  generic-function
-                                                  boundp-method-prototype
-                                                  slot-name)
-  (declare (ignore generic-function boundp-method-prototype))
-  (make-structure-instance-boundp-method-function slot-name))
-
-
-(defun make-structure-instance-reader-method-function (slot-name)
-  (declare #.*optimize-speed*)
-  #'(lambda (instance)
-      (structure-instance-slot-value instance slot-name)))
-
-(defun make-structure-instance-writer-method-function (slot-name)
-  (declare #.*optimize-speed*)
-  #'(lambda (nv instance)
-      (setf (structure-instance-slot-value instance slot-name) nv)))
-
-(defun make-structure-instance-boundp-method-function (slot-name)
-  (declare #.*optimize-speed*)
-  #'(lambda (instance)
-      (structure-instance-slot-boundp instance slot-name)))
-
-(defmethod wrapper-fetcher ((class structure-class))
-  'wrapper-for-structure)
-
-(defmethod slots-fetcher ((class structure-class))
-  NIL)
-
-
diff --git a/pcl/sys-package.lisp b/pcl/sys-package.lisp
deleted file mode 100644
index c04430e8c08aa394a30dbffaf4999119332ab2c8..0000000000000000000000000000000000000000
--- a/pcl/sys-package.lisp
+++ /dev/null
@@ -1,149 +0,0 @@
-
-
-;;; Definitions for package SLOT-ACCESSOR-NAME of type ESTABLISH
-(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE LISP::NIL :NICKNAMES
-    '("S-A-N"))
-
-;;; Definitions for package PCL of type ESTABLISH
-(LISP::IN-PACKAGE "PCL" :USE LISP::NIL)
-
-;;; Definitions for package ITERATE of type ESTABLISH
-(LISP::IN-PACKAGE "ITERATE" :USE LISP::NIL)
-
-;;; Definitions for package WALKER of type ESTABLISH
-(LISP::IN-PACKAGE "WALKER" :USE LISP::NIL)
-
-;;; Definitions for package SLOT-ACCESSOR-NAME of type EXPORT
-(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE 'LISP::NIL :NICKNAMES
-    '("S-A-N"))
-(LISP::IMPORT 'LISP::NIL)
-(LISP::EXPORT 'LISP::NIL)
-
-;;; Definitions for package PCL of type EXPORT
-(LISP::IN-PACKAGE "PCL" :USE '("LISP" "ITERATE" "WALKER"))
-(LISP::IMPORT 'LISP::NIL)
-(LISP::EXPORT
-    '(PCL::CLASS-PRECEDENCE-LIST PCL::SLOT-DEFINITION
-         PCL::COMPUTE-APPLICABLE-METHODS-USING-CLASSES
-         PCL::SLOT-DEFINITION-WRITERS PCL::CLASS-OF
-         PCL::NO-APPLICABLE-METHOD PCL::STANDARD-WRITER-METHOD
-         PCL::ENSURE-CLASS-USING-CLASS PCL::ENSURE-GENERIC-FUNCTION
-         PCL::FIND-METHOD-COMBINATION PCL::UPDATE-DEPENDENT
-         PCL::MAP-DEPENDENTS PCL::SLOT-MISSING PCL::SPECIALIZER
-         PCL::CALL-NEXT-METHOD PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS
-         PCL::SLOT-MAKUNBOUND-USING-CLASS PCL::MAKE-INSTANCES-OBSOLETE
-         PCL::INTERN-EQL-SPECIALIZER PCL::REMOVE-DIRECT-SUBCLASS
-         PCL::METHOD-GENERIC-FUNCTION PCL::METHOD-QUALIFIERS
-         PCL::FUNCALLABLE-STANDARD-CLASS PCL::EXTRACT-LAMBDA-LIST
-         PCL::STANDARD-CLASS PCL::PRINT-OBJECT PCL::STRUCTURE-CLASS
-         PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION
-         PCL::GENERIC-FUNCTION-DECLARATIONS PCL::MAKE-INSTANCE
-         PCL::METHOD-LAMBDA-LIST PCL::DEFGENERIC
-         PCL::REMOVE-DIRECT-METHOD PCL::STANDARD-DIRECT-SLOT-DEFINITION
-         PCL::GENERIC-FUNCTION-METHODS PCL::VALIDATE-SUPERCLASS
-         PCL::REINITIALIZE-INSTANCE PCL::STANDARD-METHOD
-         PCL::STANDARD-ACCESSOR-METHOD
-         PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS
-         PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES
-         PCL::INITIALIZE-INSTANCE PCL::GENERIC-FLET PCL::SLOT-UNBOUND
-         PCL::STANDARD-INSTANCE PCL::SLOT-DEFINITION-TYPE
-         PCL::COMPUTE-EFFECTIVE-METHOD PCL::ALLOCATE-INSTANCE
-         PCL::SYMBOL-MACROLET PCL::GENERIC-FUNCTION
-         PCL::GENERIC-FUNCTION-METHOD-COMBINATION
-         PCL::SPECIALIZER-DIRECT-METHODS PCL::ADD-DIRECT-SUBCLASS
-         PCL::WRITER-METHOD-CLASS PCL::SLOT-DEFINITION-INITARGS
-         PCL::METHOD-SPECIALIZERS PCL::GENERIC-FUNCTION-METHOD-CLASS
-         PCL::ADD-METHOD PCL::WITH-ACCESSORS
-         PCL::SLOT-DEFINITION-ALLOCATION
-         PCL::SLOT-DEFINITION-INITFUNCTION
-         PCL::SLOT-DEFINITION-LOCATION PCL::ADD-DIRECT-METHOD
-         PCL::SLOT-BOUNDP PCL::EQL-SPECIALIZER PCL::SHARED-INITIALIZE
-         PCL::STANDARD-GENERIC-FUNCTION
-         PCL::ACCESSOR-METHOD-SLOT-DEFINITION
-         PCL::SLOT-BOUNDP-USING-CLASS PCL::ADD-DEPENDENT
-         PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTION
-         PCL::WITH-ADDED-METHODS PCL::COMPUTE-CLASS-PRECEDENCE-LIST
-         PCL::REMOVE-DEPENDENT PCL::NEXT-METHOD-P
-         PCL::GENERIC-FUNCTION-NAME PCL::SLOT-VALUE
-         PCL::EFFECTIVE-SLOT-DEFINITION PCL::CLASS-FINALIZED-P
-         PCL::COMPUTE-DISCRIMINATING-FUNCTION PCL::STANDARD-OBJECT
-         PCL::CLASS-DEFAULT-INITARGS PCL::CLASS-DIRECT-SLOTS
-         PCL::FUNCALLABLE-STANDARD-INSTANCE-ACCESS PCL::BUILT-IN-CLASS
-         PCL::NO-NEXT-METHOD PCL::SLOT-MAKUNBOUND
-         PCL::STANDARD-READER-METHOD PCL::GENERIC-FUNCTION-LAMBDA-LIST
-         PCL::GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER
-         PCL::INVALID-METHOD-ERROR PCL::METHOD-COMBINATION-ERROR
-         PCL::SLOT-EXISTS-P PCL::FINALIZE-INHERITANCE
-         PCL::SLOT-DEFINITION-NAME
-         PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION PCL::COMPUTE-SLOTS
-         PCL::CLASS-SLOTS PCL::EFFECTIVE-SLOT-DEFINITION-CLASS
-         PCL::STANDARD-INSTANCE-ACCESS PCL::WITH-SLOTS
-         PCL::DIRECT-SLOT-DEFINITION PCL::DEFINE-METHOD-COMBINATION
-         PCL::MAKE-METHOD-LAMBDA PCL::ENSURE-CLASS
-         PCL::DIRECT-SLOT-DEFINITION-CLASS PCL::METHOD-FUNCTION
-         PCL::STANDARD-SLOT-DEFINITION PCL::CHANGE-CLASS PCL::DEFMETHOD
-         PCL::UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
-         PCL::UPDATE-INSTANCE-FOR-REDEFINED-CLASS
-         PCL::FORWARD-REFERENCED-CLASS PCL::SLOT-DEFINITION-INITFORM
-         PCL::REMOVE-METHOD PCL::READER-METHOD-CLASS PCL::CALL-METHOD
-         PCL::CLASS-PROTOTYPE PCL::CLASS-NAME PCL::FIND-CLASS
-         PCL::DEFCLASS PCL::COMPUTE-APPLICABLE-METHODS
-         PCL::SLOT-VALUE-USING-CLASS PCL::METHOD-COMBINATION
-         PCL::EQL-SPECIALIZER-INSTANCE PCL::GENERIC-LABELS PCL::METHOD
-         PCL::SLOT-DEFINITION-READERS
-         PCL::CLASS-DIRECT-DEFAULT-INITARGS
-         PCL::CLASS-DIRECT-SUBCLASSES PCL::CLASS-DIRECT-SUPERCLASSES
-         PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION))
-
-;;; Definitions for package ITERATE of type EXPORT
-(LISP::IN-PACKAGE "ITERATE" :USE '("WALKER" "LISP"))
-(LISP::IMPORT 'LISP::NIL)
-(LISP::EXPORT
-    '(ITERATE::SUMMING ITERATE::MINIMIZING ITERATE::PLIST-ELEMENTS
-         ITERATE::ITERATE* ITERATE::MAXIMIZING ITERATE::LIST-TAILS
-         ITERATE::*ITERATE-WARNINGS* ITERATE::GATHERING
-         ITERATE::EACHTIME ITERATE::ELEMENTS ITERATE::GATHER
-         ITERATE::LIST-ELEMENTS ITERATE::WHILE ITERATE::ITERATE
-         ITERATE::UNTIL ITERATE::JOINING ITERATE::COLLECTING
-         ITERATE::WITH-GATHERING ITERATE::INTERVAL))
-
-;;; Definitions for package WALKER of type EXPORT
-(LISP::IN-PACKAGE "WALKER" :USE '("LISP"))
-(LISP::IMPORT 'LISP::NIL)
-(LISP::EXPORT
-    '(WALKER::DEFINE-WALKER-TEMPLATE WALKER::*VARIABLE-DECLARATIONS*
-         WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION
-         WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P
-         WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM
-         WALKER::MACROEXPAND-ALL WALKER::VARIABLE-GLOBALLY-SPECIAL-P))
-
-;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW
-(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME")
-(LISP::SHADOW 'LISP::NIL)
-(LISP::SHADOWING-IMPORT 'LISP::NIL)
-(LISP::IMPORT 'LISP::NIL)
-
-;;; Definitions for package PCL of type SHADOW
-(LISP::IN-PACKAGE "PCL")
-(LISP::SHADOW '(PCL::DOTIMES PCL::DOCUMENTATION))
-(LISP::SHADOWING-IMPORT 'LISP::NIL)
-(LISP::IMPORT
-    '(SYSTEM::STRUCTURE-REF SYSTEM::STRUCTURE-DEF SYSTEM::STRUCTUREP))
-
-;;; Definitions for package ITERATE of type SHADOW
-(LISP::IN-PACKAGE "ITERATE")
-(LISP::SHADOW 'LISP::NIL)
-(LISP::SHADOWING-IMPORT 'LISP::NIL)
-(LISP::IMPORT 'LISP::NIL)
-
-;;; Definitions for package WALKER of type SHADOW
-(LISP::IN-PACKAGE "WALKER")
-(LISP::SHADOW 'LISP::NIL)
-(LISP::SHADOWING-IMPORT 'LISP::NIL)
-(LISP::IMPORT 'LISP::NIL)
-
-(in-package 'SI)
-(export '(%structure-name
-          %compiled-function-name
-          %set-compiled-function-name))
-(in-package 'pcl)
diff --git a/pcl/sys-proclaim.lisp b/pcl/sys-proclaim.lisp
deleted file mode 100644
index c1d1f92f6382d769f683ec0ee0ae358997e3af6e..0000000000000000000000000000000000000000
--- a/pcl/sys-proclaim.lisp
+++ /dev/null
@@ -1,818 +0,0 @@
-
-(IN-PACKAGE "USER") 
-(PROCLAIM '(FTYPE (FUNCTION (*) FIXNUM) PCL::ZERO)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T FIXNUM *) FIXNUM)
-            PCL::COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) FIXNUM) PCL::FAST-INSTANCE-BOUNDP-INDEX
-            PCL::ONE-INDEX-LIMIT-FN PCL::N-N-ACCESSORS-LIMIT-FN
-            PCL::CHECKING-LIMIT-FN PCL::PV-CACHE-LIMIT-FN
-            PCL::CACHE-NLINES PCL::CACHE-MAX-LOCATION PCL::CACHE-SIZE
-            PCL::CACHE-MASK PCL::ARG-INFO-NUMBER-REQUIRED
-            PCL::DEFAULT-LIMIT-FN PCL::CACHE-COUNT
-            PCL::CACHING-LIMIT-FN PCL::PV-TABLE-PV-SIZE
-            PCL::EARLY-CLASS-SIZE)) 
-(PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) PCL::POWER-OF-TWO-CEILING)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) FUNCTION) PCL::CACHE-LIMIT-FN
-            PCL::METHOD-CALL-FUNCTION PCL::FAST-METHOD-CALL-FUNCTION)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) PCL::FIELD-TYPE) PCL::CACHE-FIELD)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) LIST) PCL::CACHE-OVERFLOW
-            PCL::PV-TABLE-SLOT-NAME-LISTS PCL::PV-TABLE-CALL-LIST)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) PCL::CACHE-VALUEP)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) PCL::CACHE-VECTOR)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) (VALUES T T)) PCL::MAKE-CLASS-PREDICATE-NAME
-            PCL::MAKE-KEYWORD)) 
-(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) PCL::%CCLOSURE-ENV-NTHCDR)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (FIXNUM FIXNUM T) FIXNUM)
-            PCL::COMPUTE-PRIMARY-CACHE-LOCATION)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) PCL::CACHE-LINE-SIZE)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) PCL::CACHE-NKEYS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) (OR PCL::CACHE NULL)) PCL::PV-TABLE-CACHE)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T) *) PCL::MEMF-CODE-CONVERTER
-            PCL::REAL-LOAD-DEFCLASS PCL::CACHE-MISS-VALUES-INTERNAL
-            PCL::GENERATE-DISCRIMINATION-NET-INTERNAL
-            PCL::MAKE-LONG-METHOD-COMBINATION-FUNCTION
-            PCL::DO-SHORT-METHOD-COMBINATION
-            WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T) *)
-            PCL::GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            ITERATE::WALK-GATHERING-BODY
-            PCL::CACHE-MISS-VALUES
-            PCL::MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION
-            PCL::OPTIMIZE-SLOT-VALUE-BY-CLASS-P PCL::ACCESSOR-VALUES1
-            PCL::EMIT-READER/WRITER
-            PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER
-            WALKER::WALK-MULTIPLE-VALUE-SETQ PCL::GENERATING-LISP
-            PCL::EMIT-READER/WRITER-FUNCTION
-            PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION
-            WALKER::WALK-LET-IF PCL::SET-SLOT-VALUE
-            PCL::CONVERT-METHODS PCL::SLOT-VALUE-USING-CLASS-DFUN
-            PCL::SLOT-BOUNDP-USING-CLASS-DFUN
-            PCL::CHECK-METHOD-ARG-INFO PCL::LOAD-LONG-DEFCOMBIN
-            PCL::MAKE-FINAL-N-N-ACCESSOR-DFUN
-            PCL::MAKE-FINAL-CACHING-DFUN
-            PCL::MAKE-FINAL-CONSTANT-VALUE-DFUN
-            PCL::GET-CLASS-SLOT-VALUE-1 PCL::ACCESSOR-VALUES-INTERNAL
-            PCL::MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION
-            PCL::MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION
-            ITERATE::EXPAND-INTO-LET WALKER::WALK-FORM-INTERNAL
-            ITERATE::RENAME-VARIABLES
-            PCL::CONSTANT-VALUE-MISS PCL::CACHING-MISS
-            PCL::CHECKING-MISS
-            PCL::GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T) *)
-            PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL
-            PCL::ADD-METHOD-DECLARATIONS PCL::WALK-METHOD-LAMBDA
-            PCL::MAKE-TWO-CLASS-ACCESSOR-DFUN
-            WALKER::WALK-TEMPLATE-HANDLE-REPEAT)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T) *)
-            PCL::GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION
-            PCL::BOOTSTRAP-ACCESSOR-DEFINITION
-            PCL::GET-ACCESSOR-METHOD-FUNCTION
-            PCL::EMIT-CHECKING-OR-CACHING
-            PCL::EMIT-CHECKING-OR-CACHING-FUNCTION
-            PCL::SETF-SLOT-VALUE-USING-CLASS-DFUN
-            PCL::LOAD-SHORT-DEFCOMBIN
-            PCL::INITIALIZE-INSTANCE-SIMPLE-FUNCTION
-            PCL::MAKE-SHARED-INITIALIZE-FORM-LIST
-            PCL::MAKE-ONE-CLASS-ACCESSOR-DFUN
-            PCL::MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN
-            PCL::MAKE-FINAL-CHECKING-DFUN PCL::ACCESSOR-VALUES
-            PCL::SET-CLASS-SLOT-VALUE-1
-            PCL::GENERATE-DISCRIMINATION-NET
-            PCL::REAL-MAKE-METHOD-LAMBDA
-            PCL::ORDER-SPECIALIZERS WALKER::WALK-TEMPLATE
-            PCL::ACCESSOR-MISS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T) *)
-            ITERATE::ITERATE-TRANSFORM-BODY)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T *) *) PCL::SLOT-VALUE-OR-DEFAULT
-            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION
-            PCL::GET-EFFECTIVE-METHOD-FUNCTION
-            PCL::MAKE-N-N-ACCESSOR-DFUN WALKER:NESTED-WALK-FORM
-            PCL::MAKE-CHECKING-DFUN PCL::LOAD-DEFGENERIC
-            PCL::TYPES-FROM-ARGUMENTS
-            PCL::MAKE-DEFAULT-INITARGS-FORM-LIST
-            PCL::MAKE-FINAL-ACCESSOR-DFUN PCL::MAKE-ACCESSOR-TABLE
-            PCL::GET-SIMPLE-INITIALIZATION-FUNCTION
-            PCL::GET-COMPLEX-INITIALIZATION-FUNCTIONS
-            PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T *) *)
-            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1
-            ITERATE::RENAME-LET-BINDINGS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T *) *) PCL::MAKE-ONE-INDEX-ACCESSOR-DFUN
-            WALKER::WALK-DECLARATIONS
-            PCL::GET-SECONDARY-DISPATCH-FUNCTION)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T *) *) PCL::REAL-MAKE-A-METHOD)) 
-(PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PCL::PRINT-DFUN-INFO)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T) T) ITERATE::SIMPLE-EXPAND-GATHERING-FORM
-            ITERATE::RENAME-AND-CAPTURE-VARIABLES
-            ITERATE::VARIABLE-SAME-P
-            PCL::GET-FUNCTION-GENERATOR
-            WALKER:VARIABLE-DECLARATION PCL::GET-NEW-FUNCTION-GENERATOR
-            PCL::TRACE-METHOD-INTERNAL PCL::ONE-INDEX-DFUN-INFO
-            PCL::ONE-CLASS-DFUN-INFO
-            PCL::MAP-ALL-ORDERS SYSTEM::APPLY-DISPLAY-FUN
-            PCL::NOTE-PV-TABLE-REFERENCE
-            WALKER::RELIST-INTERNAL
-            PCL::MAKE-DFUN-CALL
-            WALKER::WALK-TAGBODY-1 WALKER::WALK-LAMBDA
-            PCL::OPTIMIZE-GF-CALL-INTERNAL
-            PCL::SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P
-            WALKER::WALK-COMPILER-LET PCL::SKIP-FAST-SLOT-ACCESS-P
-            WALKER::WALK-UNEXPECTED-DECLARE WALKER::WALK-FLET
-            WALKER::WALK-IF
-            WALKER::WALK-LABELS WALKER::WALK-LET WALKER::WALK-LET*
-            WALKER::WALK-LOCALLY
-            WALKER::WALK-MACROLET
-            PCL::FIX-SLOT-ACCESSORS WALKER::WALK-MULTIPLE-VALUE-BIND
-            PCL:COMPUTE-EFFECTIVE-METHOD WALKER::WALK-SETQ
-            WALKER::WALK-SYMBOL-MACROLET PCL::EMIT-SLOT-READ-FORM
-            WALKER::WALK-TAGBODY PCL::EMIT-BOUNDP-CHECK WALKER::WALK-DO
-            WALKER::WALK-DO* WALKER::WALK-PROG
-            WALKER::WALK-NAMED-LAMBDA WALKER::WALK-PROG*
-            PCL::EXPAND-DEFGENERIC PCL::EMIT-GREATER-THAN-1-DLAP
-            PCL::EMIT-1-T-DLAP
-            PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL
-            PCL::ENTRY-IN-CACHE-P PCL::CONVERT-TABLE
-            PCL::MAKE-METHOD-SPEC PCL::TRACE-EMF-CALL-INTERNAL
-            PCL::FLUSH-CACHE-TRAP PCL::SET-FUNCTION-NAME-1
-            PCL::OBSOLETE-INSTANCE-TRAP
-            PCL::COMPUTE-PRECEDENCE PCL::PRINT-STD-INSTANCE
-            PCL::|SETF PCL METHOD-FUNCTION-GET|
-            PCL::|SETF PCL PLIST-VALUE|
-            WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL
-            PCL::CAN-OPTIMIZE-ACCESS PCL::OPTIMIZE-SLOT-VALUE
-            PCL::OPTIMIZE-SET-SLOT-VALUE PCL::DECLARE-STRUCTURE
-            PCL::OPTIMIZE-SLOT-BOUNDP
-            PCL::PRINT-CACHE PCL::COMPUTE-STD-CPL-PHASE-3
-            PCL::FIRST-FORM-TO-LISP
-            ITERATE::OPTIMIZE-ITERATE-FORM
-            PCL::WRAP-METHOD-GROUP-SPECIFIER-BINDINGS
-            PCL::MAKE-TOP-LEVEL-FORM PCL::INVALIDATE-WRAPPER
-            PCL::STANDARD-COMPUTE-EFFECTIVE-METHOD
-            PCL::MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            PCL::MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            PCL::MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION
-            WALKER::RECONS ITERATE::OPTIMIZE-GATHERING-FORM)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T) T) PCL::MAKE-EFFECTIVE-METHOD-FUNCTION1
-            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL
-            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE
-            PCL::MEMF-TEST-CONVERTER
-            PCL::LOAD-PRECOMPILED-DFUN-CONSTRUCTOR
-            PCL::TWO-CLASS-DFUN-INFO
-            WALKER::WALK-LET/LET* WALKER::WALK-PROG/PROG*
-            WALKER::WALK-DO/DO*
-            WALKER::WALK-BINDINGS-2 PCL::OPTIMIZE-READER
-            PCL::OPTIMIZE-WRITER
-            PCL::EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY
-            PCL::MAYBE-EXPAND-ACCESSOR-FORM
-            PCL::INITIALIZE-INSTANCE-SIMPLE
-            PCL::GET-WRAPPERS-FROM-CLASSES
-            PCL::LOAD-PRECOMPILED-IIS-ENTRY
-            PCL::FILL-CACHE-P
-            PCL::ADJUST-CACHE
-            PCL::EXPAND-CACHE
-            PCL::EXPAND-SYMBOL-MACROLET-INTERNAL
-            PCL::BOOTSTRAP-SET-SLOT PCL::EXPAND-DEFCLASS PCL::GET-CACHE
-            )) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T) T) PCL::LOAD-FUNCTION-GENERATOR
-            PCL::EXPAND-EMF-CALL-METHOD PCL::MAKE-FGEN
-            PCL::BOOTSTRAP-MAKE-SLOT-DEFINITIONS
-            PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS1
-            PCL::MAKE-FINAL-ORDINARY-DFUN-INTERNAL PCL::COMPUTE-PV-SLOT
-            WALKER::WALK-BINDINGS-1
-            PCL::OPTIMIZE-INSTANCE-ACCESS
-            PCL::OPTIMIZE-ACCESSOR-CALL
-            PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL1
-            PCL::UPDATE-SLOTS-IN-PV
-            PCL::MAKE-PARAMETER-REFERENCES
-            PCL::MAKE-EMF-CACHE
-            PCL::GET-MAKE-INSTANCE-FUNCTION-INTERNAL
-            PCL::MAKE-INSTANCE-FUNCTION-COMPLEX
-            PCL::MAKE-INSTANCE-FUNCTION-SIMPLE
-            PCL::OPTIMIZE-GENERIC-FUNCTION-CALL
-            PCL::REAL-MAKE-METHOD-INITARGS-FORM
-            )) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T *) T)
-            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE
-            PCL::MAKE-EMF-FROM-METHOD
-            PCL::EXPAND-EFFECTIVE-METHOD-FUNCTION
-            PCL::NAMED-OBJECT-PRINT-FUNCTION PCL::FIND-CLASS-FROM-CELL
-            PCL::FIND-CLASS-PREDICATE-FROM-CELL PCL::INITIALIZE-INFO
-            PCL::GET-EFFECTIVE-METHOD-FUNCTION1 PCL::GET-DECLARATION
-            PCL::GET-METHOD-FUNCTION-PV-CELL
-            PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS PCL::EMIT-MISS
-            PCL::METHOD-FUNCTION-GET PCL::PROBE-CACHE PCL::MAP-CACHE
-            PCL::GET-CACHE-FROM-CACHE PCL::PRECOMPUTE-EFFECTIVE-METHODS
-            PCL::RECORD-DEFINITION WALKER::CONVERT-MACRO-TO-LAMBDA
-            PCL::CPL-ERROR PCL::REAL-ADD-METHOD
-            PCL::REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION
-            PCL::REAL-ENSURE-GF-USING-CLASS--NULL
-            PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION1)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T T) T)
-            PCL::GET-SECONDARY-DISPATCH-FUNCTION2)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T) T)
-            PCL::BOOTSTRAP-MAKE-SLOT-DEFINITION PCL::EMIT-SLOT-ACCESS
-            PCL::OPTIMIZE-GF-CALL PCL::SET-ARG-INFO1 PCL::LOAD-DEFCLASS
-            PCL::MAKE-EARLY-CLASS-DEFINITION)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T *) T) PCL::FILL-DFUN-CACHE
-            PCL::EARLY-ADD-NAMED-METHOD PCL::REAL-ADD-NAMED-METHOD)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T *) T) PCL::LOAD-DEFMETHOD
-            PCL::MAKE-DEFMETHOD-FORM PCL::MAKE-DEFMETHOD-FORM-INTERNAL
-            PCL::EARLY-MAKE-A-METHOD)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T *) T) PCL::CHECK-INITARGS-2-PLIST
-            PCL::CHECK-INITARGS-2-LIST WALKER::WALK-ARGLIST
-            PCL::MAKE-EMF-CALL PCL::CAN-OPTIMIZE-ACCESS1
-            PCL::EMIT-FETCH-WRAPPER PCL::FILL-CACHE
-            PCL::REAL-GET-METHOD PCL::CHECK-INITARGS-1 PCL::GET-METHOD)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T *) T) PCL::EMIT-DLAP
-            PCL::GET-SECONDARY-DISPATCH-FUNCTION1)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T FIXNUM) T) PCL::FILL-CACHE-FROM-CACHE-P)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T) T) PCL::EXPAND-DEFMETHOD
-            PCL::LOAD-DEFMETHOD-INTERNAL
-            )) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T T T *) T)
-            PCL::BOOTSTRAP-INITIALIZE-CLASS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION NIL *) PCL::COUNT-ALL-DFUNS PCL::RENEW-SYS-FILES
-            PCL::EMIT-N-N-READERS PCL::EMIT-N-N-WRITERS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION NIL T) PCL::GET-EFFECTIVE-METHOD-GENSYM
-            PCL::SHOW-EMF-CALL-TRACE PCL::BOOTSTRAP-META-BRAID
-            PCL::BOOTSTRAP-BUILT-IN-CLASSES PCL::LIST-ALL-DFUNS
-            PCL::DEFAULT-METHOD-ONLY-DFUN-INFO
-            PCL::INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST
-            PCL::CACHES-TO-ALLOCATE PCL::UPDATE-DISPATCH-DFUNS
-            PCL::MAKE-CACHE PCL::RESET-PCL-PACKAGE
-            PCL::IN-THE-COMPILER-P PCL::STRUCTURE-FUNCTIONS-EXIST-P
-            PCL::ALLOCATE-FUNCALLABLE-INSTANCE-2
-            PCL::%%ALLOCATE-INSTANCE--CLASS
-            PCL::ALLOCATE-FUNCALLABLE-INSTANCE-1
-            PCL::DISPATCH-DFUN-INFO PCL::INITIAL-DISPATCH-DFUN-INFO
-            PCL::INITIAL-DFUN-INFO PCL::NO-METHODS-DFUN-INFO
-            PCL::SHOW-FREE-CACHE-VECTORS PCL::MAKE-CPD
-            PCL::MAKE-ARG-INFO PCL::SHOW-DFUN-CONSTRUCTORS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (*) *) PCL::UNTRACE-METHOD
-            PCL:INVALID-METHOD-ERROR PCL:METHOD-COMBINATION-ERROR
-            PCL::LIST-LARGE-CACHES
-            PCL::UPDATE-MAKE-INSTANCE-FUNCTION-TABLE)) 
-(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) PCL::FIND-FREE-CACHE-LINE)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (FIXNUM T T) *) PCL::COMPUTE-CACHE-PARAMETERS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (*) T) PCL::|__si::MAKE-DFUN-INFO|
-            PCL::|__si::MAKE-NO-METHODS| PCL::|__si::MAKE-INITIAL|
-            PCL::|__si::MAKE-INITIAL-DISPATCH|
-            PCL::|__si::MAKE-DISPATCH|
-            PCL::|__si::MAKE-DEFAULT-METHOD-ONLY|
-            PCL::|__si::MAKE-ACCESSOR-DFUN-INFO|
-            PCL::|__si::MAKE-ONE-INDEX-DFUN-INFO|
-            PCL::MAKE-FAST-METHOD-CALL PCL::|__si::MAKE-N-N|
-            PCL::MAKE-FAST-INSTANCE-BOUNDP PCL::|__si::MAKE-ONE-CLASS|
-            PCL::|__si::MAKE-TWO-CLASS| PCL::|__si::MAKE-ONE-INDEX|
-            PCL::|__si::MAKE-CHECKING| PCL::|__si::MAKE-ARG-INFO|
-            PCL::FIX-EARLY-GENERIC-FUNCTIONS PCL::STRING-APPEND
-            PCL::|__si::MAKE-CACHING| PCL::|__si::MAKE-CONSTANT-VALUE|
-            PCL::FALSE PCL::|STRUCTURE-OBJECT class constructor|
-            PCL::PV-WRAPPERS-FROM-PV-ARGS PCL::MAKE-PV-TABLE
-            PCL::|__si::MAKE-PV-TABLE| PCL::INTERN-PV-TABLE
-            PCL::CALLED-FIN-WITHOUT-FUNCTION
-            PCL::|__si::MAKE-STD-INSTANCE| PCL::TRUE
-            PCL::MAKE-INITIALIZE-INFO PCL::|__si::MAKE-CACHE|
-            PCL::MAKE-PROGN WALKER::UNBOUND-LEXICAL-FUNCTION
-            PCL::|__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION|
-            PCL::MAKE-METHOD-CALL)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) *) PCL::TYPE-FROM-SPECIALIZER
-            PCL::*NORMALIZE-TYPE PCL::UNPARSE-TYPE
-            PCL::DEFAULT-CODE-CONVERTER PCL::CONVERT-TO-SYSTEM-TYPE
-            PCL::EMIT-CONSTANT-VALUE PCL::SFUN-P PCL::PCL-DESCRIBE
-            PCL::GET-GENERIC-FUNCTION-INFO PCL::EARLY-METHOD-FUNCTION
-            PCL::EARLY-METHOD-STANDARD-ACCESSOR-SLOT-NAME
-            PCL::SPECIALIZER-FROM-TYPE PCL::CLASS-EQ-TYPE
-            COMPILER::CAN-USE-PRINT-CIRCLE-P PCL::STRUCTURE-WRAPPER
-            PCL::FIND-STRUCTURE-CLASS PCL::MAKE-DISPATCH-DFUN
-            PCL::FIND-WRAPPER PCL::PARSE-DEFMETHOD
-            PCL::PROTOTYPES-FOR-MAKE-METHOD-LAMBDA
-            PCL::FORCE-CACHE-FLUSHES PCL::EMIT-ONE-CLASS-READER
-            PCL::EMIT-ONE-CLASS-WRITER PCL::EMIT-TWO-CLASS-READER
-            PCL::EMIT-TWO-CLASS-WRITER PCL::EMIT-ONE-INDEX-READERS
-            PCL::EMIT-ONE-INDEX-WRITERS PCL::NET-CODE-CONVERTER
-            PCL::EMIT-IN-CHECKING-CACHE-P PCL::COMPILE-IIS-FUNCTIONS
-            PCL::ANALYZE-LAMBDA-LIST
-            PCL::COMPUTE-APPLICABLE-METHODS-EMF
-            PCL::GET-DISPATCH-FUNCTION PCL::INSURE-CACHING-DFUN
-            PCL::%FBOUNDP PCL::CCLOSUREP PCL::GENERIC-FUNCTION-NAME-P
-            PCL::MAKE-FINAL-DISPATCH-DFUN
-            PCL::STRUCTURE-SLOTD-INIT-FORM
-            PCL::PARSE-METHOD-GROUP-SPECIFIER
-            PCL::METHOD-PROTOTYPE-FOR-GF
-            PCL::EARLY-COLLECT-INHERITANCE)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) T) PCL::UNENCAPSULATED-FDEFINITION
-            PCL::DFUN-INFO-P PCL::NO-METHODS-P
-            PCL::MAKE-TYPE-PREDICATE
-            PCL::DEFAULT-TEST-CONVERTER PCL::INITIAL-P
-            PCL::UNPARSE-TYPE-LIST PCL::MAKE-CALL-METHODS
-            PCL::DEFAULT-CONSTANT-CONVERTER PCL::INITIAL-DISPATCH-P
-            PCL::DISPATCH-P PCL::GBOUNDP PCL::GMAKUNBOUND
-            PCL::DEFAULT-CONSTANTP PCL::DEFAULT-METHOD-ONLY-P
-            PCL::FGEN-TEST PCL::LOOKUP-FGEN PCL::ACCESSOR-DFUN-INFO-P
-            PCL::FGEN-GENERATOR PCL::FGEN-SYSTEM
-            PCL::ONE-INDEX-DFUN-INFO-P PCL::FAST-METHOD-CALL-P
-            PCL::N-N-P PCL::FAST-INSTANCE-BOUNDP-P
-            PCL::METHOD-FUNCTION-PV-TABLE PCL::METHOD-FUNCTION-METHOD
-            PCL::STORE-FGEN PCL::ONE-CLASS-P
-            PCL::METHOD-FUNCTION-NEEDS-NEXT-METHODS-P
-            PCL::FTYPE-DECLARATION-FROM-LAMBDA-LIST PCL::FGEN-GENSYMS
-            PCL::TWO-CLASS-P PCL::ARG-INFO-LAMBDA-LIST
-            PCL::ARG-INFO-PRECEDENCE PCL::ARG-INFO-METATYPES
-            PCL::FGEN-GENERATOR-LAMBDA SYSTEM:%STRUCTURE-NAME
-            PCL::ARG-INFO-NUMBER-OPTIONAL
-            SYSTEM:%COMPILED-FUNCTION-NAME PCL::ARG-INFO-KEY/REST-P
-            PCL::ONE-INDEX-P PCL::ARG-INFO-KEYWORDS
-            PCL::GF-INFO-SIMPLE-ACCESSOR-TYPE
-            PCL::GF-PRECOMPUTE-DFUN-AND-EMF-P
-            PCL::GF-INFO-STATIC-C-A-M-EMF PCL::CHECKING-P
-            PCL::GF-INFO-C-A-M-EMF-STD-P PCL::GF-INFO-FAST-MF-P
-            PCL::UNDEFMETHOD-1 PCL::ARG-INFO-P
-            PCL::FAST-METHOD-CALL-ARG-INFO PCL::ARG-INFO-NKEYS
-            PCL::GF-DFUN-CACHE PCL:CLASS-OF PCL::GF-DFUN-INFO
-            PCL::FUNCTION-RETURNING-NIL
-            PCL::ACCESSOR-DFUN-INFO-ACCESSOR-TYPE PCL::EVAL-FORM
-            PCL::ONE-INDEX-DFUN-INFO-INDEX
-            PCL::SLOT-INITARGS-FROM-STRUCTURE-SLOTD PCL::TYPE-CLASS
-            PCL::ONE-CLASS-WRAPPER0 PCL::EXTRACT-PARAMETERS
-            PCL::CLASS-PREDICATE PCL::EXTRACT-REQUIRED-PARAMETERS
-            PCL::MAKE-CLASS-EQ-PREDICATE PCL::TWO-CLASS-WRAPPER1
-            PCL::MAKE-EQL-PREDICATE PCL::CHECKING-FUNCTION
-            PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS
-            PCL::INITIALIZE-INFO-KEY PCL::BOOTSTRAP-CLASS-PREDICATES
-            PCL::GET-BUILT-IN-CLASS-SYMBOL PCL::INITIALIZE-INFO-WRAPPER
-            PCL::GET-BUILT-IN-WRAPPER-SYMBOL PCL::DO-STANDARD-DEFSETF-1
-            PCL::CACHING-P PCL::GFS-OF-TYPE PCL::LEGAL-CLASS-NAME-P
-            PCL::STRUCTURE-TYPE-P PCL::CONSTANT-VALUE-P
-            PCL::USE-DEFAULT-METHOD-ONLY-DFUN-P
-            SYSTEM::NEXT-STACK-FRAME PCL::WRAPPER-FIELD
-            PCL::NEXT-WRAPPER-FIELD PCL::SETFBOUNDP
-            PCL::GET-SETF-FUNCTION-NAME PCL::USE-CACHING-DFUN-P
-            PCL::MAKE-PV-TYPE-DECLARATION
-            PCL::MAKE-CALLS-TYPE-DECLARATION PCL::MAP-SPECIALIZERS
-            WALKER:VARIABLE-GLOBALLY-SPECIAL-P PCL::SLOT-VECTOR-SYMBOL
-            PCL::MAKE-PERMUTATION-VECTOR PCL::STRUCTURE-OBJECT-P
-            PCL::EXPAND-MAKE-INSTANCE-FORM PCL::MAKE-CONSTANT-FUNCTION
-            PCL::FUNCTION-RETURNING-T PCL::SORT-SLOTS PCL::SORT-CALLS
-            PCL::SYMBOL-PKG-NAME
-            PCL::CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P
-            PCL::INITIALIZE-INFO-BOUND-SLOTS
-            PCL::INITIALIZE-INFO-CACHED-VALID-P
-            PCL::GET-MAKE-INSTANCE-FUNCTIONS
-            PCL::INITIALIZE-INFO-CACHED-RI-VALID-P
-            PCL::INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST
-            PCL::INITIALIZE-INFO-CACHED-NEW-KEYS
-            PCL::UPDATE-C-A-M-GF-INFO
-            PCL::INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION
-            PCL::UPDATE-GF-SIMPLE-ACCESSOR-TYPE
-            PCL::UPDATE-GFS-OF-CLASS
-            PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION
-            PCL::DO-STANDARD-DEFSETFS-FOR-DEFCLASS
-            PCL::STANDARD-SVUC-METHOD
-            PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION
-            PCL:EXTRACT-LAMBDA-LIST PCL::%CCLOSURE-ENV
-            PCL::STRUCTURE-SVUC-METHOD
-            PCL::INITIALIZE-INFO-CACHED-CONSTANTS
-            PCL:EXTRACT-SPECIALIZER-NAMES PCL::METHOD-FUNCTION-PLIST
-            PCL::INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION
-            PCL::INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION
-            PCL::INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION-SYMBOL
-            PCL::INTERNED-SYMBOL-P PCL::GDEFINITION
-            PCL::UPDATE-CLASS-CAN-PRECEDE-P PCL::%STD-INSTANCE-WRAPPER
-            PCL::%STD-INSTANCE-SLOTS PCL::PV-TABLEP PCL::STD-INSTANCE-P
-            PCL::COMPUTE-MCASE-PARAMETERS PCL::COMPUTE-CLASS-SLOTS
-            PCL::MAKE-PV-TABLE-TYPE-DECLARATION PCL::NET-TEST-CONVERTER
-            PCL:INTERN-EQL-SPECIALIZER
-            PCL::MAKE-INSTANCE-FUNCTION-SYMBOL
-            PCL::UPDATE-ALL-C-A-M-GF-INFO
-            PCL::UPDATE-PV-TABLE-CACHE-INFO PCL::DFUN-INFO-CACHE
-            PCL::NO-METHODS-CACHE PCL::ARG-INFO-APPLYP
-            PCL::INITIAL-CACHE PCL::INITIAL-DISPATCH-CACHE
-            PCL::CHECK-CACHE PCL::DISPATCH-CACHE PCL::CLASS-FROM-TYPE
-            PCL::DEFAULT-METHOD-ONLY-CACHE PCL::DNET-METHODS-P
-            PCL::ACCESSOR-DFUN-INFO-CACHE
-            PCL::METHOD-FUNCTION-FROM-FAST-FUNCTION
-            PCL::ONE-INDEX-DFUN-INFO-CACHE
-            PCL::ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE
-            PCL::METHOD-CALL-CALL-METHOD-ARGS PCL::KEYWORD-SPEC-NAME
-            PCL::N-N-CACHE PCL::GENERIC-CLOBBERS-FUNCTION
-            PCL::N-N-ACCESSOR-TYPE PCL::FAST-METHOD-CALL-PV-CELL
-            PCL::WRAPPER-FOR-STRUCTURE PCL::ONE-CLASS-CACHE
-            PCL::FAST-METHOD-CALL-NEXT-METHOD-CALL
-            PCL::ONE-CLASS-ACCESSOR-TYPE PCL::ONE-CLASS-INDEX
-            PCL::BUILT-IN-WRAPPER-OF PCL::TWO-CLASS-CACHE
-            PCL::BUILT-IN-OR-STRUCTURE-WRAPPER1
-            PCL::TWO-CLASS-ACCESSOR-TYPE PCL::TWO-CLASS-INDEX
-            PCL::ALLOCATE-CACHE-VECTOR PCL::TWO-CLASS-WRAPPER0
-            PCL::FLUSH-CACHE-VECTOR-INTERNAL PCL::ONE-INDEX-CACHE
-            PCL::EARLY-CLASS-NAME PCL::ONE-INDEX-ACCESSOR-TYPE
-            PCL::ONE-INDEX-INDEX PCL::INTERN-FUNCTION-NAME
-            PCL::CHECKING-CACHE PCL::COMPILE-LAMBDA-UNCOMPILED
-            PCL::GF-LAMBDA-LIST PCL::CACHING-CACHE
-            PCL::CONSTANT-VALUE-CACHE PCL::COMPILE-LAMBDA-DEFERRED
-            PCL::FUNCALLABLE-INSTANCE-P
-            PCL::RESET-CLASS-INITIALIZE-INFO PCL::GET-CACHE-VECTOR
-            PCL::CONSTANT-SYMBOL-P PCL::FREE-CACHE-VECTOR
-            PCL::EARLY-METHOD-LAMBDA-LIST PCL::ARG-INFO-VALID-P
-            PCL::DFUN-ARG-SYMBOL PCL::EARLY-METHOD-CLASS
-            PCL::EARLY-GF-P PCL::EARLY-GF-NAME PCL::CACHING-DFUN-INFO
-            PCL::COMPUTE-APPLICABLE-METHODS-EMF-STD-P
-            PCL::CONSTANT-VALUE-DFUN-INFO
-            PCL::RESET-CLASS-INITIALIZE-INFO-1 PCL::FREE-CACHE
-            PCL::PARSE-SPECIALIZERS PCL::RESET-INITIALIZE-INFO
-            PCL::EARLY-METHOD-QUALIFIERS
-            PCL::PROCLAIM-INCOMPATIBLE-SUPERCLASSES PCL::WRAPPER-OF
-            PCL::EARLY-METHOD-STANDARD-ACCESSOR-P
-            PCL::FUNCTION-PRETTY-ARGLIST
-            PCL::GET-MAKE-INSTANCE-FUNCTION PCL::CHECK-WRAPPER-VALIDITY
-            PCL::UNPARSE-SPECIALIZERS PCL::%SYMBOL-FUNCTION
-            PCL::FINAL-ACCESSOR-DFUN-TYPE
-            PCL::COMPLICATED-INSTANCE-CREATION-METHOD
-            PCL::DEFAULT-STRUCTUREP PCL::UPDATE-GF-INFO
-            PCL::CACHE-OWNER PCL::DEFAULT-STRUCTURE-INSTANCE-P
-            PCL::DEFAULT-STRUCTURE-TYPE PCL::STRUCTURE-TYPE
-            PCL::COMPUTE-STD-CPL-PHASE-2 PCL::GET-PV-CELL-FOR-CLASS
-            PCL::STRUCTURE-TYPE-INCLUDED-TYPE-NAME
-            PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST PCL::CACHE-P
-            PCL::STRUCTURE-SLOTD-NAME
-            PCL::STRUCTURE-SLOTD-ACCESSOR-SYMBOL
-            PCL::DEFAULT-SECONDARY-DISPATCH-FUNCTION
-            PCL::STRUCTURE-SLOTD-WRITER-FUNCTION
-            PCL::FIND-CYCLE-REASONS PCL::EARLY-CLASS-DEFINITION
-            PCL::ECD-SOURCE PCL::STRUCTURE-SLOTD-TYPE
-            PCL::FORMAT-CYCLE-REASONS PCL::ECD-METACLASS PCL::CPD-CLASS
-            PCL::EARLY-CLASS-PRECEDENCE-LIST
-            PCL::METHODS-CONTAIN-EQL-SPECIALIZER-P PCL::CPD-SUPERS
-            PCL::EXPAND-LONG-DEFCOMBIN PCL::EARLY-CLASS-NAME-OF
-            PCL::CPD-AFTER PCL::EXPAND-SHORT-DEFCOMBIN
-            PCL::EARLY-CLASS-SLOTDS PCL::CPD-COUNT
-            PCL::EARLY-SLOT-DEFINITION-NAME PCL::SLOT-READER-SYMBOL
-            PCL::EARLY-SLOT-DEFINITION-LOCATION WALKER::ENV-LOCK
-            PCL::MAKE-INITIAL-DFUN PCL::EARLY-ACCESSOR-METHOD-SLOT-NAME
-            PCL::SLOT-WRITER-SYMBOL WALKER::ENV-DECLARATIONS
-            WALKER::ENV-LEXICAL-VARIABLES PCL::LIST-DFUN
-            PCL::SLOT-BOUNDP-SYMBOL PCL::MAP-ALL-GENERIC-FUNCTIONS
-            PCL::MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION
-            PCL::EARLY-CLASS-DIRECT-SUBCLASSES
-            PCL::MAKE-FUNCTION-INLINE PCL::LIST-LARGE-CACHE
-            PCL::CLASS-PRECEDENCE-DESCRIPTION-P
-            PCL::INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS
-            PCL::MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION
-            PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            WALKER::ENV-WALK-FUNCTION
-            WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE
-            PCL::COUNT-DFUN PCL::MAKE-INITFUNCTION
-            PCL::MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            ITERATE::VARIABLES-FROM-LET WALKER::ENV-WALK-FORM
-            PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION
-            PCL::INITIALIZE-INFO-P PCL::ECD-CLASS-NAME PCL::COPY-CACHE
-            PCL::COMPUTE-LINE-SIZE PCL::CANONICAL-SLOT-NAME
-            WALKER::GET-WALKER-TEMPLATE PCL::EARLY-CLASS-SLOTS
-            PCL::STRUCTURE-TYPE-INTERNAL-SLOTDS PCL::EARLY-COLLECT-CPL
-            PCL::EARLY-COLLECT-SLOTS
-            PCL::METHOD-LL->GENERIC-FUNCTION-LL
-            PCL::EARLY-COLLECT-DEFAULT-INITARGS
-            PCL::ECD-SUPERCLASS-NAMES PCL::METHOD-CALL-P
-            PCL::STRUCTURE-SLOT-BOUNDP ITERATE::SEQUENCE-ACCESSOR
-            PCL::ECD-CANONICAL-SLOTS PCL::ECD-OTHER-INITARGS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T *) *) PCL::COERCE-TO-CLASS
-            PCL::GET-METHOD-FUNCTION WALKER:MACROEXPAND-ALL
-            PCL::GET-FUNCTION PCL::GET-FUNCTION1
-            PCL:ENSURE-GENERIC-FUNCTION PCL::PARSE-METHOD-OR-SPEC
-            PCL::EXTRACT-DECLARATIONS PCL::GET-DFUN-CONSTRUCTOR
-            PCL::MAP-ALL-CLASSES PCL::MAKE-CACHING-DFUN
-            WALKER:WALK-FORM PCL:ENSURE-CLASS
-            PCL::MAKE-METHOD-FUNCTION-INTERNAL
-            PCL::PARSE-SPECIALIZED-LAMBDA-LIST
-            PCL::MAKE-METHOD-LAMBDA-INTERNAL
-            PCL::MAKE-CONSTANT-VALUE-DFUN PCL::MAKE-FINAL-DFUN-INTERNAL
-            PCL::COMPILE-LAMBDA)) 
-(PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) PCL::SYMBOL-APPEND)) 
-(PROCLAIM '(FTYPE (FUNCTION (T *) STRING) PCL::CAPITALIZE-WORDS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T) *) PCL::SAUT-CLASS
-            PCL::SPECIALIZER-APPLICABLE-USING-TYPE-P PCL::*TYPEP
-            PCL::COMPUTE-TEST PCL::GET-NEW-FUNCTION-GENERATOR-INTERNAL
-            PCL::COMPUTE-CODE PCL::CLASS-APPLICABLE-USING-CLASS-P
-            PCL::SAUT-AND PCL::SAUT-NOT PCL::SAUT-PROTOTYPE
-            COMPILER::CAN-USE-PRINT-CIRCLE-P1 PCL:SLOT-BOUNDP
-            PCL::DESTRUCTURE PCL:SLOT-MAKUNBOUND PCL:SLOT-VALUE
-            PCL::ENSURE-CLASS-VALUES PCL::MAKE-DIRECT-SLOTD
-            PCL::GENERATE-FAST-CLASS-SLOT-ACCESS-P
-            PCL::MUTATE-SLOTS-AND-CALLS PCL::INVOKE-EMF
-            PCL::EMIT-DEFAULT-ONLY-FUNCTION PCL::SPLIT-DECLARATIONS
-            PCL::EMIT-DEFAULT-ONLY COMPILER::C2LAMBDA-EXPR-WITH-KEY
-            PCL::SLOT-NAME-LISTS-FROM-SLOTS PCL::EMIT-CHECKING
-            PCL::UPDATE-SLOT-VALUE-GF-INFO PCL::EMIT-CACHING
-            PCL::SDFUN-FOR-CACHING PCL::SLOT-UNBOUND-INTERNAL
-            PCL::MAKE-INSTANCE-1 PCL::SET-FUNCTION-NAME
-            PCL::COMPUTE-STD-CPL-PHASE-1 PCL::FORM-LIST-TO-LISP
-            PCL::FIND-SUPERCLASS-CHAIN PCL::SAUT-CLASS-EQ
-            PCL::COMPUTE-APPLICABLE-METHODS-USING-TYPES
-            PCL::CHECK-INITARGS-VALUES PCL::SAUT-EQL PCL::*SUBTYPEP
-            ITERATE::PARSE-DECLARATIONS PCL::INITIAL-DFUN)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T *) T) PCL::MAKE-TYPE-PREDICATE-NAME
-            PCL::SET-DFUN PCL:FIND-CLASS PCL::TRACE-METHOD
-            PCL::FIND-CLASS-CELL PCL::MAKE-FINAL-DFUN
-            PCL::PV-TABLE-LOOKUP-PV-ARGS PCL::USE-DISPATCH-DFUN-P
-            WALKER::RELIST* WALKER::RELIST PCL::FIND-CLASS-PREDICATE
-            PCL::EARLY-METHOD-SPECIALIZERS
-            PCL::USE-CONSTANT-VALUE-DFUN-P PCL::MAKE-EARLY-GF
-            PCL::ALLOCATE-FUNCALLABLE-INSTANCE PCL::SET-ARG-INFO
-            PCL::INITIALIZE-METHOD-FUNCTION PCL::UPDATE-DFUN
-            PCL::MAKE-SPECIALIZABLE PCL::ALLOCATE-STRUCTURE-INSTANCE
-            PCL::ALLOCATE-STANDARD-INSTANCE
-            WALKER::WALKER-ENVIRONMENT-BIND-1
-            ITERATE::FUNCTION-LAMBDA-P ITERATE::MAYBE-WARN
-            PCL::MAKE-WRAPPER)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T) (*)) PCL::SORT-APPLICABLE-METHODS
-            PCL::SORT-METHODS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T) T) PCL::FDEFINE-CAREFULLY
-            PCL::MAKE-INTERNAL-READER-METHOD-FUNCTION
-            PCL::MAKE-STD-READER-METHOD-FUNCTION
-            PCL::MAKE-STD-WRITER-METHOD-FUNCTION
-            ITERATE::SIMPLE-EXPAND-ITERATE-FORM
-            PCL::MAKE-STD-BOUNDP-METHOD-FUNCTION
-            PCL::DO-SATISFIES-DEFTYPE PCL::MEMF-CONSTANT-CONVERTER
-            PCL::COMPUTE-CONSTANTS PCL::CLASS-CAN-PRECEDE-P
-            PCL::SAUT-NOT-CLASS PCL::SAUT-NOT-CLASS-EQ
-            PCL::SAUT-NOT-PROTOTYPE PCL::GF-MAKE-FUNCTION-FROM-EMF
-            PCL::SAUT-NOT-EQL PCL::SUPERCLASSES-COMPATIBLE-P
-            PCL::CLASSES-HAVE-COMMON-SUBCLASS-P
-            SYSTEM:%SET-COMPILED-FUNCTION-NAME PCL:ADD-METHOD
-            SYSTEM::DISPLAY-ENV PCL::DESCRIBE-PACKAGE
-            SYSTEM::DISPLAY-COMPILED-ENV
-            PCL::PRINTING-RANDOM-THING-INTERNAL
-            PCL::MAKE-CLASS-PREDICATE
-            PCL::METHOD-FUNCTION-RETURNING-NIL
-            PCL::METHOD-FUNCTION-RETURNING-T PCL::VARIABLE-CLASS
-            PCL::MAKE-PLIST PCL::REMTAIL PCL:REMOVE-METHOD
-            PCL:SLOT-EXISTS-P PCL::DESTRUCTURE-INTERNAL
-            PCL::ACCESSOR-MISS-FUNCTION
-            PCL::UPDATE-INITIALIZE-INFO-INTERNAL PCL::N-N-DFUN-INFO
-            PCL::MAKE-CAXR PCL::MAKE-CDXR WALKER:VARIABLE-LEXICAL-P
-            WALKER:VARIABLE-SPECIAL-P PCL::CHECKING-DFUN-INFO
-            PCL::MAKE-PV-TABLE-INTERNAL PCL::FIND-SLOT-DEFINITION
-            WALKER::WALK-REPEAT-EVAL WALKER::NOTE-DECLARATION
-            PCL::MAKE-DFUN-LAMBDA-LIST WALKER::NOTE-LEXICAL-BINDING
-            PCL::MAKE-DLAP-LAMBDA-LIST PCL::ADD-DIRECT-SUBCLASSES
-            PCL::COMPUTE-PV PCL::MAKE-DFUN-ARG-LIST PCL::COMPUTE-CALLS
-            PCL::MAKE-FAST-METHOD-CALL-LAMBDA-LIST
-            PCL::UPDATE-ALL-PV-TABLE-CACHES PCL::UPDATE-CLASS
-            PCL::MAP-PV-TABLE-REFERENCES-OF PCL::ADD-SLOT-ACCESSORS
-            WALKER::ENVIRONMENT-FUNCTION PCL::REMOVE-DIRECT-SUBCLASSES
-            PCL::REMOVE-SLOT-ACCESSORS PCL::SYMBOL-LESSP
-            PCL::SYMBOL-OR-CONS-LESSP PCL::|SETF PCL FIND-CLASS|
-            PCL::|SETF PCL FIND-CLASS-PREDICATE|
-            PCL::PV-WRAPPERS-FROM-ALL-ARGS PCL::PV-TABLE-LOOKUP
-            PCL::PROCLAIM-DEFGENERIC PCL::UPDATE-CPL PCL::LIST-EQ
-            PCL::UPDATE-SLOTS PCL::COMPUTE-APPLICABLE-METHODS-FUNCTION
-            PCL::COMPUTE-EMF-FROM-WRAPPERS PCL::UPDATE-INITS
-            PCL::UPDATE-STD-OR-STR-METHODS
-            PCL::SET-STANDARD-SVUC-METHOD PCL::EMIT-1-NIL-DLAP
-            PCL::PLIST-VALUE PCL::SET-STRUCTURE-SVUC-METHOD
-            PCL::EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION
-            PCL:FUNCALLABLE-STANDARD-INSTANCE-ACCESS
-            PCL::MEC-ALL-CLASSES-INTERNAL
-            PCL::EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION
-            PCL::MEC-ALL-CLASSES PCL::%SET-CCLOSURE-ENV
-            PCL::MEC-ALL-CLASS-LISTS PCL::REDEFINE-FUNCTION
-            PCL::METHODS-CONVERTER PCL::COMPUTE-LAYOUT PCL::NO-SLOT
-            PCL::PV-WRAPPERS-FROM-ALL-WRAPPERS
-            PCL::NET-CONSTANT-CONVERTER PCL::AUGMENT-TYPE
-            PCL::CHANGE-CLASS-INTERNAL
-            PCL:SET-FUNCALLABLE-INSTANCE-FUNCTION
-            PCL::VALUE-FOR-CACHING PCL:STANDARD-INSTANCE-ACCESS
-            PCL::|SETF PCL METHOD-FUNCTION-PLIST| PCL::GET-KEY-ARG
-            PCL::GET-KEY-ARG1 PCL::SET-METHODS
-            PCL::SET-FUNCTION-PRETTY-ARGLIST
-            PCL::FIND-STANDARD-II-METHOD PCL::MAKE-EARLY-ACCESSOR
-            PCL::DOCTOR-DFUN-FOR-THE-DEBUGGER PCL::COMPUTE-STD-CPL
-            PCL::|SETF PCL GDEFINITION|
-            PCL::MAKE-DISCRIMINATING-FUNCTION-ARGLIST PCL::ADD-FORMS
-            PCL::CPL-INCONSISTENT-ERROR
-            PCL::REDIRECT-EARLY-FUNCTION-INTERNAL PCL::ADD-TO-CVECTOR
-            PCL::BOOTSTRAP-SLOT-INDEX PCL::QUALIFIER-CHECK-RUNTIME
-            PCL::CPL-FORWARD-REFERENCED-CLASS-ERROR
-            PCL::REAL-REMOVE-METHOD WALKER::ENVIRONMENT-MACRO
-            PCL::CANONICALIZE-SLOT-SPECIFICATION
-            PCL::CANONICALIZE-DEFCLASS-OPTION PCL::SET-WRAPPER
-            PCL::DEAL-WITH-ARGUMENTS-OPTION
-            PCL::PARSE-QUALIFIER-PATTERN PCL::SWAP-WRAPPERS-AND-SLOTS
-            ITERATE::MV-SETQ PCL::MAKE-UNORDERED-METHODS-EMF
-            PCL::CLASS-MIGHT-PRECEDE-P
-            ITERATE::EXTRACT-SPECIAL-BINDINGS
-            WALKER::VARIABLE-SYMBOL-MACRO-P PCL::RAISE-METATYPE)) 
-(PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) PCL::GET-WRAPPER-CACHE-NUMBER)) 
-(DOLIST (PCL::V '(PCL::ADD-READER-METHOD
-                     PCL::SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT
-                     PCL::REMOVE-READER-METHOD PCL::EQL-SPECIALIZER-P
-                     PCL::OBJECT-PLIST
-                     PCL::SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL
-                     PCL::SPECIALIZER-TYPE PCL::GF-DFUN-STATE
-                     PCL::CLASS-DEFSTRUCT-CONSTRUCTOR
-                     PCL::METHOD-FAST-FUNCTION PCL::SPECIALIZERP
-                     PCL::EXACT-CLASS-SPECIALIZER-P
-                     PCL::COMPATIBLE-META-CLASS-CHANGE-P
-                     PCL::UPDATE-GF-DFUN PCL::SPECIALIZER-OBJECT
-                     PCL::ACCESSOR-METHOD-SLOT-NAME
-                     PCL::SPECIALIZER-CLASS PCL::CLASS-EQ-SPECIALIZER-P
-                     PCL::SLOTS-FETCHER PCL::REMOVE-WRITER-METHOD
-                     PCL::STRUCTURE-CLASS-P PCL::UPDATE-CONSTRUCTORS
-                     PCL::DOCUMENTATION PCL::METHOD-PRETTY-ARGLIST
-                     PCL::CLASS-EQ-SPECIALIZER
-                     PCL::INFORM-TYPE-SYSTEM-ABOUT-CLASS
-                     PCL::ACCESSOR-METHOD-CLASS
-                     PCL::GENERIC-FUNCTION-PRETTY-ARGLIST
-                     PCL::MAKE-BOUNDP-METHOD-FUNCTION
-                     PCL::CLASS-PREDICATE-NAME PCL::CLASSP
-                     PCL::LEGAL-QUALIFIERS-P PCL::ADD-BOUNDP-METHOD
-                     PCL::LEGAL-LAMBDA-LIST-P
-                     PCL::|SETF PCL GENERIC-FUNCTION-NAME|
-                     PCL::DESCRIBE-OBJECT PCL::CLASS-INITIALIZE-INFO
-                     PCL::MAKE-WRITER-METHOD-FUNCTION
-                     PCL::|SETF PCL GF-DFUN-STATE|
-                     PCL::|SETF PCL SLOT-DEFINITION-NAME|
-                     PCL::|SETF PCL CLASS-NAME|
-                     PCL::INITIALIZE-INTERNAL-SLOT-FUNCTIONS
-                     PCL::|SETF PCL SLOT-DEFINITION-TYPE|
-                     PCL::METHOD-COMBINATION-P
-                     PCL::|SETF PCL GENERIC-FUNCTION-METHODS|
-                     PCL::|SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION|
-                     PCL::|SETF PCL METHOD-GENERIC-FUNCTION|
-                     PCL::|SETF PCL SLOT-ACCESSOR-STD-P|
-                     PCL::LEGAL-SPECIALIZERS-P
-                     PCL::|SETF PCL OBJECT-PLIST|
-                     PCL::|SETF PCL SLOT-DEFINITION-INITFORM|
-                     PCL::|SETF PCL CLASS-DEFSTRUCT-FORM|
-                     PCL::|SETF PCL GENERIC-FUNCTION-METHOD-CLASS|
-                     PCL::SLOT-ACCESSOR-STD-P
-                     PCL::|SETF PCL GF-PRETTY-ARGLIST|
-                     PCL::|SETF PCL SLOT-ACCESSOR-FUNCTION|
-                     PCL::|SETF PCL SLOT-DEFINITION-LOCATION|
-                     PCL::|SETF PCL SLOT-DEFINITION-READER-FUNCTION|
-                     PCL::|SETF PCL SLOT-DEFINITION-WRITER-FUNCTION|
-                     PCL::|SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION|
-                     PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION|
-                     PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION|
-                     PCL::|SETF PCL SLOT-DEFINITION-ALLOCATION|
-                     PCL::|SETF PCL SLOT-DEFINITION-INITFUNCTION|
-                     PCL::METHOD-COMBINATION-OPTIONS
-                     PCL::|SETF PCL SLOT-DEFINITION-READERS|
-                     PCL::|SETF PCL DOCUMENTATION|
-                     PCL::FUNCALLABLE-STANDARD-CLASS-P
-                     PCL::|SETF PCL SLOT-DEFINITION-CLASS|
-                     PCL::|SETF PCL SLOT-VALUE-USING-CLASS|
-                     PCL::CLASS-CAN-PRECEDE-LIST
-                     PCL::|SETF PCL CLASS-DIRECT-SLOTS|
-                     PCL::|SETF PCL CLASS-SLOTS|
-                     PCL::SLOT-ACCESSOR-FUNCTION
-                     PCL::|SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST|
-                     PCL::|SETF PCL SLOT-DEFINITION-WRITERS|
-                     PCL::SLOT-CLASS-P PCL::MAKE-READER-METHOD-FUNCTION
-                     PCL::LEGAL-METHOD-FUNCTION-P PCL::GET-METHOD
-                     PCL::SHORT-METHOD-COMBINATION-P PCL::GF-ARG-INFO
-                     PCL::SPECIALIZER-METHOD-TABLE
-                     PCL::MAKE-METHOD-INITARGS-FORM
-                     PCL::CLASS-DEFSTRUCT-FORM PCL::GF-PRETTY-ARGLIST
-                     PCL::SAME-SPECIALIZER-P
-                     PCL::SLOT-DEFINITION-BOUNDP-FUNCTION
-                     PCL::SLOT-DEFINITION-WRITER-FUNCTION
-                     PCL::SLOT-DEFINITION-READER-FUNCTION
-                     PCL::SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION
-                     PCL::SLOT-DEFINITION-INTERNAL-READER-FUNCTION
-                     PCL::SLOT-DEFINITION-CLASS
-                     PCL::EQL-SPECIALIZER-OBJECT
-                     PCL::CLASS-CONSTRUCTORS PCL::SLOTS-TO-INSPECT
-                     PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
-                     PCL::ADD-WRITER-METHOD
-                     PCL::LONG-METHOD-COMBINATION-FUNCTION
-                     PCL::GENERIC-FUNCTION-P PCL::LEGAL-SLOT-NAME-P
-                     PCL::CLASS-WRAPPER PCL::DEFINITION-SOURCE
-                     PCL::DEFAULT-INITARGS PCL::CLASS-SLOT-VALUE
-                     PCL::FORWARD-REFERENCED-CLASS-P
-                     PCL::GF-FAST-METHOD-FUNCTION-P
-                     PCL::LEGAL-QUALIFIER-P PCL::METHOD-P
-                     PCL::CLASS-SLOT-CELLS
-                     PCL::STANDARD-ACCESSOR-METHOD-P
-                     PCL::STANDARD-GENERIC-FUNCTION-P
-                     PCL::STANDARD-READER-METHOD-P
-                     PCL::STANDARD-METHOD-P
-                     PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS
-                     PCL::COMPUTE-DEFAULT-INITARGS
-                     PCL::|SETF PCL CLASS-SLOT-VALUE|
-                     PCL::METHOD-COMBINATION-TYPE PCL::STANDARD-CLASS-P
-                     PCL::LEGAL-SPECIALIZER-P
-                     PCL::COMPUTE-SLOT-ACCESSOR-INFO
-                     PCL::STANDARD-BOUNDP-METHOD-P
-                     PCL::RAW-INSTANCE-ALLOCATOR
-                     PCL::|SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL|
-                     PCL::|SETF PCL CLASS-INITIALIZE-INFO|
-                     PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO
-                     PCL::STANDARD-WRITER-METHOD-P
-                     PCL::CLASS-INCOMPATIBLE-SUPERCLASS-LIST
-                     PCL::WRAPPER-FETCHER
-                     PCL::METHOD-COMBINATION-DOCUMENTATION
-                     PCL::|SETF PCL SLOT-DEFINITION-INITARGS|
-                     PCL::REMOVE-BOUNDP-METHOD
-                     PCL::|SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR|
-                     PCL::SHORT-COMBINATION-OPERATOR
-                     PCL::REMOVE-NAMED-METHOD
-                     PCL::LEGAL-DOCUMENTATION-P
-                     PCL:CLASS-DIRECT-SUPERCLASSES
-                     PCL:CLASS-DIRECT-SUBCLASSES
-                     PCL:CLASS-DIRECT-DEFAULT-INITARGS
-                     PCL:SLOT-DEFINITION-READERS
-                     PCL:SLOT-VALUE-USING-CLASS
-                     PCL:COMPUTE-APPLICABLE-METHODS PCL:CLASS-NAME
-                     PCL:CLASS-PROTOTYPE PCL:READER-METHOD-CLASS
-                     PCL:REMOVE-METHOD PCL:SLOT-DEFINITION-INITFORM
-                     PCL:UPDATE-INSTANCE-FOR-REDEFINED-CLASS
-                     PCL:UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
-                     PCL:CHANGE-CLASS PCL:METHOD-FUNCTION
-                     PCL:DIRECT-SLOT-DEFINITION-CLASS
-                     PCL:MAKE-METHOD-LAMBDA
-                     PCL:EFFECTIVE-SLOT-DEFINITION-CLASS
-                     PCL:CLASS-SLOTS PCL:COMPUTE-SLOTS
-                     PCL:SLOT-DEFINITION-NAME PCL:FINALIZE-INHERITANCE
-                     PCL:GENERIC-FUNCTION-LAMBDA-LIST
-                     PCL:CLASS-DIRECT-SLOTS PCL:CLASS-DEFAULT-INITARGS
-                     PCL:COMPUTE-DISCRIMINATING-FUNCTION
-                     PCL:CLASS-FINALIZED-P PCL:GENERIC-FUNCTION-NAME
-                     PCL:REMOVE-DEPENDENT
-                     PCL:COMPUTE-CLASS-PRECEDENCE-LIST
-                     PCL:ADD-DEPENDENT PCL:SLOT-BOUNDP-USING-CLASS
-                     PCL:ACCESSOR-METHOD-SLOT-DEFINITION
-                     PCL:SHARED-INITIALIZE PCL:ADD-DIRECT-METHOD
-                     PCL:SLOT-DEFINITION-LOCATION
-                     PCL:SLOT-DEFINITION-INITFUNCTION
-                     PCL:SLOT-DEFINITION-ALLOCATION PCL:ADD-METHOD
-                     PCL:GENERIC-FUNCTION-METHOD-CLASS
-                     PCL:METHOD-SPECIALIZERS
-                     PCL:SLOT-DEFINITION-INITARGS
-                     PCL:WRITER-METHOD-CLASS PCL:ADD-DIRECT-SUBCLASS
-                     PCL:SPECIALIZER-DIRECT-METHODS
-                     PCL:GENERIC-FUNCTION-METHOD-COMBINATION
-                     PCL:ALLOCATE-INSTANCE PCL:COMPUTE-EFFECTIVE-METHOD
-                     PCL:SLOT-DEFINITION-TYPE PCL:SLOT-UNBOUND
-                     PCL:INITIALIZE-INSTANCE PCL:FUNCTION-KEYWORDS
-                     PCL:REINITIALIZE-INSTANCE PCL:VALIDATE-SUPERCLASS
-                     PCL:GENERIC-FUNCTION-METHODS
-                     PCL:REMOVE-DIRECT-METHOD PCL:METHOD-LAMBDA-LIST
-                     PCL:MAKE-INSTANCE
-                     PCL:COMPUTE-EFFECTIVE-SLOT-DEFINITION
-                     PCL:PRINT-OBJECT PCL:METHOD-QUALIFIERS
-                     PCL:METHOD-GENERIC-FUNCTION
-                     PCL:REMOVE-DIRECT-SUBCLASS
-                     PCL:MAKE-INSTANCES-OBSOLETE
-                     PCL:SLOT-MAKUNBOUND-USING-CLASS
-                     PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS
-                     PCL:SLOT-MISSING PCL:MAP-DEPENDENTS
-                     PCL:FIND-METHOD-COMBINATION
-                     PCL:ENSURE-CLASS-USING-CLASS
-                     PCL:NO-APPLICABLE-METHOD
-                     PCL:SLOT-DEFINITION-WRITERS
-                     PCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES
-                     PCL:CLASS-PRECEDENCE-LIST))
-  (SETF (GET PCL::V 'COMPILER::PROCLAIMED-CLOSURE) T)) 
diff --git a/pcl/sysdef.lisp b/pcl/sysdef.lisp
deleted file mode 100644
index 9da68cd546d86fa3fe767d01564c52a6077fcec2..0000000000000000000000000000000000000000
--- a/pcl/sysdef.lisp
+++ /dev/null
@@ -1,121 +0,0 @@
-;;; -*- Mode: Lisp; Base: 10; Syntax: Common-Lisp; Package: DSYS -*-
-;;; File: sysdef.lisp 
-;;; Author: Richard Harris
-
-(in-package "DSYS")
-
-(defvar *pcl-compiled-p* nil)
-(defvar *pcl-loaded-p* nil)
-
-(unless (boundp 'pcl::*redefined-functions*)
-  (setq pcl::*redefined-functions* nil))
-
-(defun reset-pcl-package ()
-  (pcl::reset-pcl-package)
-  (let ((defsys (subfile '("pcl") :name "defsys")))
-    (setq pcl::*pcl-directory* defsys)
-    (load-file defsys))
-  (mapc #'(lambda (path)
-	    (setf (lfi-fwd (get-loaded-file-info path)) 0))
-	(pcl-binary-files)))
-
-(defun pcl-binary-files ()
-  (pcl::system-binary-files 'pcl::pcl))
-
-(defun maybe-load-defsys (&optional compile-defsys-p)
-  (let ((defsys (subfile '("pcl") :name "defsys"))
-	(*use-default-pathname-type* nil)
-	(*skip-load-if-loaded-p* t)
-	(*skip-compile-file-fwd* 0))
-    (set 'pcl::*pcl-directory* defsys)
-    (when compile-defsys-p
-      (compile-file defsys))
-    (let ((b-s 'pcl::*boot-state*))
-      (when (and (boundp b-s) (symbol-value b-s))
-	#+ignore (reset-pcl-package)))
-    (load-file defsys)))  
-
-(defun maybe-load-pcl (&optional force-p)
-  (unless (and (null force-p)
-	       (fboundp 'pcl::system-binary-files)
-	       (every #'(lambda (path)
-			  (let* ((path-fwd (file-write-date path))
-				 (lfi (get-loaded-file-info path)))
-			    (and lfi path-fwd (= path-fwd (lfi-fwd lfi)))))
-		      (pcl-binary-files)))
-    (let ((b-s 'pcl::*boot-state*))
-      (when (and (boundp b-s) (symbol-value b-s))
-	(reset-pcl-package)))
-    (pcl::load-pcl)))
-
-(defsystem pcl
-    (:pretty-name "PCL")
-  #+akcl
-  (:forms 
-   :compile (let ((cfn (subfile '("pcl") :name "collectfn" :type "lisp")))
-	      (unless (probe-file cfn)
-		(run-unix-command 
-		 (format nil "ln -s ~A ~A"
-			 (namestring (merge-pathnames "../cmpnew/collectfn.lsp" 
-						      si::*system-directory*))
-			 (namestring cfn))))))
-				     
-  #+akcl
-  "collectfn"
-  (:forms 
-   :compile
-   (progn
-     (maybe-load-defsys t)
-     (if (and (fboundp 'pcl::operation-transformations)
-	      (or (null (probe-file (subfile '("pcl") :name "defsys" :type "lisp")))
-		  (every #'(lambda (trans)
-			     (eq (car trans) :load))
-			 (pcl::operation-transformations 'pcl::pcl :compile))))
-	 (maybe-load-pcl)
-	 (let ((b-s 'pcl::*boot-state*))
-	   (when (and (boundp b-s) (symbol-value b-s))
-	     (reset-pcl-package))
-	   #+akcl (compiler::emit-fn t)
-	   #+akcl (load (merge-pathnames "../lsp/sys-proclaim.lisp" 
-					 si::*system-directory*))
-	   (#+cmu with-compilation-unit #-cmu progn
-	    #+cmu (:optimize 
-		   '(optimize (user::debug-info #+(and small (not testing)) .5
-			                        #-(and small (not testing)) 2)
-		              (speed #+testing 1 #-testing 2)
-		              (safety #+testing 3 #-testing 0)
-		              #+ignore (user::inhibit-warnings 2))
-		   :context-declarations
-		   '(#+ignore
-		     (:external (declare (user::optimize-interface 
-					  (safety 2) (debug-info 1))))))
-	     (proclaim #+testing *testing-declaration* 
-		       #-testing *fast-declaration*)
-	     (pcl::compile-pcl))
-	   (reset-pcl-package)
-	   (maybe-load-pcl t)))
-     #+cmu (purify))
-   :load
-   (progn 
-     (maybe-load-pcl)
-     #+cmu (purify))))
-
-(defparameter *pcl-files*
-  '((("systems") "lisp"
-     "pcl")
-    (("pcl") "lisp"
-     "sysdef"
-     "boot" "braid" "cache" "cloe-low" "cmu-low" "combin" "compat"
-     "construct" "coral-low" "cpatch" "cpl" "ctypes" "defclass" "defcombin"
-     "defs" "defsys" "dfun" "dlap" "env" "excl-low" "fin" "fixup" "fngen" "fsc"
-     "gcl-patches" "genera-low" "gold-low" "hp-low" "ibcl-low" "ibcl-patches"
-     "init" "iterate" "kcl-low" "kcl-patches" "lap" "low" "lucid-low" "macros"
-     "methods" "pcl-env-internal" "pcl-env" "pkg" "plap" "precom1" "precom2"
-     "precom4" "pyr-low" "pyr-patches" "quadlap" "rel-7-2-patches" "rel-8-patches"
-     "slots" "std-class" "sys-proclaim" "ti-low" "ti-patches" "vaxl-low" "vector" "walk"
-     "xerox-low" "xerox-patches")
-    (("pcl") "text"
-     "12-7-88-notes" "3-17-88-notes" "3-19-87-notes" "4-21-87-notes"
-     "4-29-87-notes" "5-22-87-notes" "5-22-89-notes" "8-28-88-notes"
-     "get-pcl" "kcl-mods" "kcl-notes" "lap" "notes" "pcl-env" "readme")))
-
diff --git a/pcl/ti-low.lisp b/pcl/ti-low.lisp
deleted file mode 100644
index 95f5e842e2848d8984f0a96e335ae51a7bf11e13..0000000000000000000000000000000000000000
--- a/pcl/ti-low.lisp
+++ /dev/null
@@ -1,83 +0,0 @@
-;;; -*- Mode:LISP; Package:(PCL (Lisp WALKER)); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; This is the 3600 version of the file portable-low.
-;;;
-
-(in-package 'pcl)
-
-(defmacro without-interrupts (&body body)
-  `(let ((outer-scheduling-state si:inhibit-scheduling-flag)
-	 (si:inhibit-scheduling-flag t))
-     (macrolet ((interrupts-on  ()
-		  '(when (null outer-scheduling-state)
-		     (setq si:inhibit-scheduling-flag nil)))
-		(interrupts-off ()
-		  '(setq si:inhibit-scheduling-flag t)))
-       ,.body)))
-
-(si:defsubst std-instance-p (x)
-  (si:typep-structure-or-flavor x 'std-instance))
-
-  ;;   
-;;;;;; printing-random-thing-internal
-  ;;
-(defun printing-random-thing-internal (thing stream)
-  (format stream "~O" (si:%pointer thing)))
-
-(eval-when (compile load eval)             ;There seems to be some bug with
-  (setq si::inhibit-displacing-flag t))	   ;macrolet'd macros or something.
-					   ;This gets around it but its not
-					   ;really the right fix.
-
-(defun function-arglist (f)
-  (sys::arglist f t))
-
-(defun record-definition (type spec &rest ignore)
-  (if (eql type 'method)
-      (sys:record-source-file-name spec 'defun :no-query)
-      (sys:record-source-file-name spec type :no-query)))
-
-(ticl:defprop method method-function-spec-handler sys:function-spec-handler)
-(defun method-function-spec-handler
-       (function function-spec &optional arg1 arg2)
-  (let ((symbol (second function-spec)))
-    (case function
-      (sys:validate-function-spec t)
-      (otherwise
-	(sys:function-spec-default-handler
-	  function function-spec arg1 arg2)))))
-
-;;;Edited by Reed Hastings         13 Aug 87  16:59
-;;;Edited by Reed Hastings         2 Nov 87  22:58
-(defun set-function-name (function new-name)
-  (when (si:get-debug-info-struct function)
-    (setf (si:get-debug-info-field (si:get-debug-info-struct function) :name)
-	  new-name))
-  function)
-
-
-
diff --git a/pcl/ti-patches.lisp b/pcl/ti-patches.lisp
deleted file mode 100644
index c18986109eda0ff9e4c8f596a86dcf5aef0bb0d3..0000000000000000000000000000000000000000
--- a/pcl/ti-patches.lisp
+++ /dev/null
@@ -1,105 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-
-(in-package 'pcl)
-
-;;;
-;;; This little bit of magic keeps the dumper from dumping the lexical
-;;; definition of call-next-method when it dumps method functions that
-;;; come from defmethod forms.
-;;; 
-(proclaim '(notinline nil))
-
-(eval-when (load)
-  (setf (get 'function 'si:type-predicate) 'functionp))
-
-;; fix defsetf to deal with do-standard-defsetf
-
-#!C
-; From file SETF.LISP#> KERNEL; VIRGO:
-#8R SYSTEM#:
-(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
-                          (SI:*LISP-MODE* :COMMON-LISP)
-                          (*READTABLE* COMMON-LISP-READTABLE)
-                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
-  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; SETF.#"
-
-
-(defmacro defsetf (access-function arg1 &optional arg2  &environment env &body body)
-  "Define a SETF expander for ACCESS-FUNCTION.
-DEFSETF has two forms:
-
-The simple form  (DEFSETF access-function update-function [doc-string])
-can be used as follows: After (DEFSETF GETFROB PUTFROB),
-\(SETF (GETFROB A 3) FOO) ==> (PUTFROB A 3 FOO).
-
-The complex form is like DEFMACRO:
-
-\(DEFSETF access-function access-lambda-list newvalue-lambda-list body...)
-
-except there are TWO lambda-lists.
-The first one represents the argument forms to the ACCESS-FUNCTION.
-Only &OPTIONAL and &REST are allowed here.
-The second has only one argument, representing the value to be stored.
-The body of the DEFSETF definition must then compute a
-replacement for the SETF form, just as for any other macro.
-When the body is executed, the args in the lambda-lists will not
-really contain the value-expression or parts of the form to be set;
-they will contain gensymmed variables which SETF may or may not
-eliminate by substitution."
-  ;; REF and VAL are arguments to the expansion function
-  (if (null body)
-      `(defdecl ,access-function setf-method ,arg1)
-      (multiple-value-bind (body decls doc-string)
-	  (parse-body body env t)
-	(let* ((access-ll arg1)
-	       (value-names arg2)
-	       (expansion
-		 (let (all-arg-names)
-		   (dolist (x access-ll)
-		     (cond ((symbolp x)
-			    (if (not (member x lambda-list-keywords :test #'eq))
-				(push x all-arg-names)
-				(when (eq x '&rest) (return))))  ;;9/20/88 clm
-			   (t			; it's a list after &optional
-			    (push (car x) all-arg-names))))
-		   (setq all-arg-names (reverse all-arg-names))
-		   `(let ((tempvars (mapcar #'(lambda (ignore) (gensym)) ',all-arg-names))
-			  (storevar (gensym)))
-		      (values tempvars (list . ,all-arg-names) (list storevar)
-			      (let ((,(car value-names) storevar)
-				    . ,(loop for arg in all-arg-names
-					     for i = 0 then (1+ i)
-					     collect `(,arg (nth ,i tempvars))))
-				 ,@decls . ,body)
-			      `(,',access-function . ,tempvars))))))
-	  `(define-setf-method ,access-function ,arg1
-	    ,@doc-string ,expansion)
-	  ))))
-))
-
-
diff --git a/pcl/time.lisp b/pcl/time.lisp
deleted file mode 100644
index 06aefc4ca4403aebce4918af0168b395b76503c8..0000000000000000000000000000000000000000
--- a/pcl/time.lisp
+++ /dev/null
@@ -1,156 +0,0 @@
-(in-package "PCL")
-
-(proclaim '(optimize (speed 3)(safety 0)(compilation-speed 0)))
-
-(defvar *tests*)
-(setq *tests* nil)
-
-(defvar m (car (generic-function-methods #'shared-initialize)))
-(defvar gf #'shared-initialize)
-(defvar c (find-class 'standard-class))
-
-(defclass str ()
-  ((slot :initform nil :reader str-slot))
-  (:metaclass structure-class))
-
-(defvar str (make-instance 'str))
-
-
-(push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (standard)"
-	    '(time-slot-value m 'plist 10000))
-      *tests*)
-(push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (standard)"
-	    '(time-slot-value m 'generic-function 10000))
-      *tests*)
-(push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (structure)"
-	    '(time-slot-value str 'slot 10000))
-      *tests*)
-(defun time-slot-value (object slot-name n)
-  (time (dotimes (i n) (slot-value object slot-name))))
-
-
-(push (cons "Time optimized slot-value outside of a defmethod. Case (2). (standard)"
-	    '(time-slot-value-function m 10000))
-      *tests*)
-(defun time-slot-value-function (object n)
-  (time (dotimes (i n) (slot-value object 'function))))
-
-
-(push (cons "Time optimized slot-value outside of a defmethod. Case (2). (structure)"
-	    '(time-slot-value-slot str 10000))
-      *tests*)
-(defun time-slot-value-slot (object n)
-  (time (dotimes (i n) (slot-value object 'slot))))
-
-
-(push (cons "Time one-class dfun."
-	    '(time-generic-function-methods gf 10000))
-      *tests*)
-(defun time-generic-function-methods (object n)
-  (time (dotimes (i n) (generic-function-methods object))))
-
-
-(push (cons "Time one-index dfun."
-	    '(time-class-precedence-list c 10000))
-      *tests*)
-(defun time-class-precedence-list (object n)
-  (time (dotimes (i n) (class-precedence-list object))))
-
-
-(push (cons "Time n-n dfun."
-	    '(time-method-function m 10000))
-      *tests*)
-(defun time-method-function (object n)
-  (time (dotimes (i n) (method-function object))))
-
-
-(push (cons "Time caching dfun."
-	    '(time-class-slots c 10000))
-      *tests*)
-(defun time-class-slots (object n)
-  (time (dotimes (i n) (class-slots object))))
-
-
-(push (cons "Time typep for classes."
-	    '(time-typep-standard-object m 10000))
-      *tests*)
-(defun time-typep-standard-object (object n)
-  (time (dotimes (i n) (typep object 'standard-object))))
-
-
-(push (cons "Time default-initargs."
-	    '(time-default-initargs (find-class 'plist-mixin) 1000))
-      *tests*)
-(defun time-default-initargs (class n)
-  (time (dotimes (i n) (default-initargs class nil))))
-
-
-(push (cons "Time make-instance."
-	    '(time-make-instance (find-class 'plist-mixin) 1000))
-      *tests*)
-(defun time-make-instance (class n)
-  (time (dotimes (i n) (make-instance class))))
-
-(push (cons "Time constant-keys make-instance."
-	    '(time-constant-keys-make-instance 1000))
-      *tests*)
-
-(expanding-make-instance-top-level
-(defun constant-keys-make-instance (n)
-  (dotimes (i n) (make-instance 'plist-mixin))))
-
-(precompile-random-code-segments)
-
-(defun time-constant-keys-make-instance (n)
-  (time (constant-keys-make-instance n)))
-
-(defun expand-all-macros (form)
-  (walk-form form nil #'(lambda (form context env)
-			  (if (and (eq context :eval)
-				   (consp form)
-				   (symbolp (car form))
-				   (not (special-form-p (car form)))
-				   (macro-function (car form)))
-			      (values (macroexpand form env))
-			      form))))
-
-(push (cons "Macroexpand meth-structure-slot-value"
-	    '(pprint (multiple-value-bind (pgf pm)
-			 (prototypes-for-make-method-lambda 
-			  'meth-structure-slot-value)
-		       (expand-defmethod
-			'meth-structure-slot-value pgf pm
-			nil '((object str))
-			'(#'(lambda () (slot-value object 'slot)))
-			nil))))
-      *tests*)
-
-#-kcl
-(push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)."
-	    '(disassemble (meth-structure-slot-value str)))
-      *tests*)
-(defmethod meth-structure-slot-value ((object str))
-  #'(lambda () (slot-value object 'slot)))
-
-
-#|| ; interesting, but long.  (produces 100 lines of output)
-(push (cons "Macroexpand meth-standard-slot-value"
-	    '(pprint (expand-all-macros
-		     (expand-defmethod-internal 'meth-standard-slot-value
-		      nil '((object standard-method))
-		      '(#'(lambda () (slot-value object 'function)))
-		      nil))))
-      *tests*)
-(push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)."
-	    '(disassemble (meth-standard-slot-value m)))
-      *tests*)
-(defmethod meth-standard-slot-value ((object standard-method))
-  #'(lambda () (slot-value object 'function)))
-||#
-
-
-(defun do-tests ()
-  (dolist (doc+form (reverse *tests*))
-    (format t "~&~%~A~%" (car doc+form))    
-    (pprint (cdr doc+form))
-    (eval (cdr doc+form))))
diff --git a/pcl/user-instances.lisp b/pcl/user-instances.lisp
deleted file mode 100644
index 1600efc741ffb0c54e0d400671cb6a010adbbc19..0000000000000000000000000000000000000000
--- a/pcl/user-instances.lisp
+++ /dev/null
@@ -1,684 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*-
-
-;;;
-;;; *************************************************************************
-;;;
-;;;   File: user-instances.lisp.
-;;;
-;;;     by Trent E. Lange, Effective Date 06-02-92
-;;;
-;;;
-;;;  This file contains a metaclass (User-Vector-Class) whose instances
-;;; are stored as simple-vectors, saving space over PCL's standard instance
-;;; representations of PCL at the cost of some class redefinition flexibiliity.
-;;;
-;;; Permission is granted to any individual or institution to use, copy,
-;;; modify and distribute this document.
-;;;
-;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu
-;;; *************************************************************************
-;;;
-
-(in-package 'pcl)
-
-;;;   This file builds on the PCL-USER-INSTANCES feature of July 92 PCL
-;;; to define the USER-VECTOR-CLASS metaclass whose instances are simple
-;;; vectors.  The first element of the instance vector is the instance's
-;;; class wrapper (providing internal PCL information about the instance's
-;;; class).  The remaining elements of the instance vector are the instance's
-;;; slots themselves.
-;;;
-;;;   The space overhead of user-vector-instances is only two vector cells
-;;; (one for the vector, one for the wrapper).  This is contrast to standard
-;;; PCL instances, which have a total overhead of four cells.  (Standard
-;;; instances in PCL are represented as instances of structure STD-INSTANCE
-;;; having two slots, one for the wrapper and one holding a simple-vector
-;;; which is the instance's slots).  This two-cell space savings per instance
-;;; comes at the cost of losing some class redefinition flexibility, since
-;;; simple-vectors cannot have their sizes changed dynamically.
-;;; All current instances of user-instance-vectors therefore become
-;;; permanently obsolete if the classes' instance slots change.
-;;;
-;;;   This code requires July 92 PCL or later compiled with the
-;;; PCL-USER-INSTANCES feature turned on (see PCL's low.lisp file).
-;;;
-
-#-pcl-user-instances
-(eval-when (compile load eval)
-(error "Cannot use user-instances, since PCL was compiled without
-        PCL-USER-INSTANCES on the *features* list (see pcl file low.lisp.)")
-)
-
-(eval-when (compile load eval)
-(defclass user-vector-class-mixin () ()
-  (:documentation
-    "Use this mixin for metaclasses whose instances are USER-INSTANCES
-     instantiated as simple-vectors.  This saves space over the standard
-     instances used by standard-class, at the cost of losing the ability to
-     redefine the slots in a class and still have old instances updated correctly."))
-
-(defclass user-vector-class (user-vector-class-mixin standard-class) ()
-  (:documentation
-    "A metaclass whose instances are USER-INSTANCES instantiated as simple-vectors.
-     This saves space over the standard instances used by standard-class, at the
-     cost of losing the ability to redefine the slots in a class and still have old
-     instances updated correctly."))
-
-(defmethod validate-superclass ((class user-vector-class-mixin)
-                                (new-super T))
-  (or (typep new-super 'user-vector-class-mixin)
-      (eq new-super (find-class 'standard-object))))
-
-(defclass user-vector-object (standard-object) ()
-  (:metaclass user-vector-class))
-)
-
-;;;
-;;;
-;;; Instance allocation stuff.
-;;;
-
-(defmacro user-vector-instance-p (object)
-  (once-only (object)
-    `(the boolean
-          (and (simple-vector-p ,object)
-               (plusp (length (the simple-vector ,object)))
-               (wrapper-p (%svref ,object 0))))))
-
-(defmacro user-vector-instance-wrapper (object)
-  `(%svref ,object 0))
-
-(defsetf user-vector-instance-wrapper (object) (new-value)
-  `(setf (%svref ,object 0) ,new-value))
-
-(defmacro user-vector-instance-slots (instance)
-  ;; The slots vector of user-vector instances is the instance itself.
-  instance)
-
-(defmacro set-user-vector-instance-slots (instance new-value)
-  `(progn
-     (warn "Attempt to set user-vector-instance-slots of ~S to ~S"
-           ,instance ,new-value)
-     ,new-value))
-
-(defun user-instance-p (x)
-  "Is X a user instance, specifically a user-vector-instance?"
-  (user-vector-instance-p x))
-
-(defun user-instance-slots (x)
-  "Return the slots of this user-vector-instance."
-  (user-vector-instance-slots x))
-
-(defun user-instance-wrapper (x)
-  "Return the wrapper of this user-vector-instance."
-  (user-vector-instance-wrapper x))
-
-(defun set-user-instance-wrapper (x new)
-  (setf (user-vector-instance-wrapper x) new))
-
-(defmacro get-user-instance-p (x)
-  `(user-vector-instance-p ,x))
-
-(defmacro get-user-instance-wrapper (x)
-  `(user-vector-instance-wrapper ,x))
-
-(defmacro get-user-instance-slots (x)
-  `(user-vector-instance-slots ,x))
-
-(eval-when (eval #+cmu load)
-  (force-compile 'user-instance-p)
-  (force-compile 'user-instance-slots)
-  (force-compile 'user-instance-wrapper)
-  (force-compile 'set-user-instance-wrapper))
-
-
-;;;
-;;; Methods needed for user-vector-class-mixin.
-;;;
-
-(defconstant *not-a-slot* (gensym "NOT-A-SLOT"))
-
-(defmethod allocate-instance ((class user-vector-class-mixin) &rest initargs)
-  (declare (ignore initargs))
-  (unless (class-finalized-p class) (finalize-inheritance class))
-  (let* ((class-wrapper (class-wrapper class))
-         (copy-instance (wrapper-allocate-static-slot-storage-copy
-                           class-wrapper))
-         (instance      (copy-simple-vector copy-instance)))
-    (declare (type simple-vector copy-instance instance))
-    (setf (user-vector-instance-wrapper instance) class-wrapper)
-    instance))
-
-(defmethod make-instances-obsolete ((class user-vector-class-mixin))
-  "The slots of user-vector-instances are stored in the instance vector
-   themselves (a simple-vector), so old instances cannot be updated properly."
-  (setf (slot-value class 'prototype) NIL)
-  (warn "Obsoleting user-vector class ~A, all current instances will be invalid..."
-        class))
-
-(defmethod compute-layout :around ((class user-vector-class-mixin)
-                                    cpl instance-eslotds)
-  ;; First element of user-vector-instance is actually its wrapper.
-  (declare (ignore cpl instance-eslotds))
-  (cons *not-a-slot* (call-next-method)))
-
-(defmethod compute-instance-layout :around ((class user-vector-class-mixin)
-                                            instance-eslotds)
-  ;; First element of user-vector-instance is actually its wrapper.
-  (declare (ignore instance-eslotds))
-  (cons *not-a-slot* (call-next-method)))
-
-(defmethod wrapper-fetcher ((class user-vector-class-mixin))
-  'user-vector-instance-wrapper)
-
-(defmethod slots-fetcher ((class user-vector-class-mixin))
-  'user-vector-instance-slots)
-
-(defmethod raw-instance-allocator ((class user-vector-class-mixin))
-  'allocate-user-vector-instance)
-
-
-;;;
-;;; The following functions and methods are not strictly necessary for
-;;; user-vector-instances, but do speed things up a bit.
-;;;
-
-;;; Inform PCL that it is still safe to use its standard slot-value
-;;; optimizations with user-vector-class-mixin's slot-value-using-class
-;;; methods:
-
-(pushnew
-  '(user-vector-class-mixin standard-object standard-effective-slot-definition)
-   *safe-slot-value-using-class-specializers*)
-
-(pushnew
-  '(T user-vector-class-mixin standard-object standard-effective-slot-definition)
-   *safe-set-slot-value-using-class-specializers*)
-
-(pushnew
-  '(user-vector-class-mixin standard-object standard-effective-slot-definition)
-  *safe-slot-boundp-using-class-specializers*)
-
-(defmethod slot-value-using-class
-  ((class user-vector-class-mixin)
-   (object standard-object)
-   (slotd standard-effective-slot-definition))
-  (let* ((location (slot-definition-location slotd))
-	 (value
-           (typecase location
-	      (fixnum
-                (%svref (user-vector-instance-slots object) location))
-	      (cons
-	        (cdr location))
-	      (t
-	       (error
-                 "The slot ~s has neither :instance nor :class allocation, ~@
-                              so it can't be read by the default ~s method."
-		  slotd 'slot-value-using-class)))))
-    (if (eq value *slot-unbound*)
-	(slot-unbound class object (slot-definition-name slotd))
-	value)))
-
-(defmethod (setf slot-value-using-class)
-	   (new-value (class user-vector-class-mixin)
-                      (object standard-object)
-		      (slotd standard-effective-slot-definition))
-  (let ((location (slot-definition-location slotd)))
-    (typecase location
-      (fixnum
-        (setf (%svref (user-vector-instance-slots object) location) new-value))
-      (cons
-        (setf (cdr location) new-value))
-      (t
-       (error "The slot ~s has neither :instance nor :class allocation, ~@
-                           so it can't be written by the default ~s method."
-	      slotd '(setf slot-value-using-class))))))
-
-(defmethod slot-boundp-using-class
-  ((class user-vector-class-mixin)
-   (object standard-object)
-   (slotd standard-effective-slot-definition))
-  (let* ((location (slot-definition-location slotd))
-	 (value
-           (typecase location
-	     (fixnum
-               (%svref (user-vector-instance-slots object) location))
-	     (cons
-	       (cdr location))
-	     (t
-	       (error
-                 "The slot ~s has neither :instance nor :class allocation, ~@
-                              so it can't be read by the default ~s method."
-		 slotd 'slot-boundp-using-class)))))
-    (not (eq value *slot-unbound*))))
-
-
-
-(defmethod make-optimized-reader-method-function
-           ((class user-vector-class-mixin)
-            generic-function
-            reader-method-prototype
-            slot-name)
-  (declare (ignore generic-function reader-method-prototype))
-  (make-user-vector-instance-reader-method-function slot-name))
-
-(defmethod make-optimized-writer-method-function
-           ((class user-vector-class-mixin)
-            generic-function
-            reader-method-prototype
-            slot-name)
-  (declare (ignore generic-function reader-method-prototype))
-  (make-user-vector-instance-writer-method-function slot-name))
-
-(defmethod make-optimized-method-function
-           ((class user-vector-class-mixin)
-            generic-function
-            boundp-method-prototype
-            slot-name)
-  (declare (ignore generic-function boundp-method-prototype))
-  (make-user-vector-instance-boundp-method-function slot-name))
-
-(defun make-user-vector-instance-reader-method-function (slot-name)
-  (declare #.*optimize-speed*)
-  #'(lambda (instance)
-      (user-instance-slot-value instance slot-name)))
-
-(defun make-user-vector-instance-writer-method-function (slot-name)
-  (declare #.*optimize-speed*)
-  #'(lambda (nv instance)
-      (setf (user-instance-slot-value instance slot-name) nv)))
-
-(defun make-user-vector-instance-boundp-method-function (slot-name)
-  (declare #.*optimize-speed*)
-  #'(lambda (instance)
-      (user-instance-slot-boundp instance slot-name)))
-
-
-(defun make-optimized-user-reader-method-function (slot-name index)
-  (declare #.*optimize-speed*)
-  (progn slot-name)
-  #'(lambda (instance)
-      (let ((value (%svref (user-vector-instance-slots instance) index)))
-        (if (eq value *slot-unbound*)
-            (slot-unbound (class-of instance) instance slot-name)
-            value))))
-
-(defun make-optimized-user-writer-method-function (index)
-  (declare #.*optimize-speed*)
-  #'(lambda (nv instance)
-      (setf (%svref (user-vector-instance-slots instance) index) nv)))
-
-(defun make-optimized-user-boundp-method-function (index)
-  (declare #.*optimize-speed*)
-  #'(lambda (instance)
-      (not (eq (%svref (user-vector-instance-slots instance) index)
-               *slot-unbound*))))
-
-
-
-(defmacro with-user-instance-slots (slot-entries instance-form &body body)
-  "Optimized version of With-Slots that assumes that the instance-form
-   evaluates to a user-vector-instance.  The result is undefined if it does not.
-   With-user-vector-instance-slots is faster than With-Slots because it factors
-   out functions common to all slot accesses on the instance.  It has two
-   extensions to With-Slots: (1) the second value of slot-entries are
-   evaluated as forms rather than considered to be hard slot-names, allowing
-   access of variable slot-names.  (2) if a :variable-instance keyword is
-   the first part of the body, then the instance-form is treated as a variable
-   form, which is always expected to return an instance of the same class.
-   The value of the keyword must be an instance that is the same class as
-   instance-form will always return."
-  (build-with-optimized-slots-form slot-entries instance-form body 'user-instance))
-
-
-
-;;;
-;;;  Lisp and CLOS print compatability functions:
-;;;
-;;;  This gets really ugly because most lisps don't use PRINT-OBJECT
-;;;  for the printed representation of their objects like they're supposed
-;;;  to.  (And if the lisp did, it wouldn't be using PCL.).  And since
-;;;  user-vector-instances are implemented as simple-vectors, the only
-;;;  way to get their printed representations to look right is to make
-;;;  PRINT-OBJECT object to work.
-;;;    We therefore have to patch the standard lisp printing functions.
-;;;  If all goes well, then everything is honky-dory.  If it doesn't, then
-;;;  debugging can get pretty messy since we were screwing with the standard
-;;;  printing functions.  Things should work, but if they don't, then calling
-;;;  RESTORE-LISP-PRINTERS will get things back to normal.
-
-(defvar *old-write* NIL)
-(defvar *old-princ* NIL)
-(defvar *old-prin1* NIL)
-(defvar *old-print* NIL)
-
-;; Structure dummy-print-instance is a structure whose sole purpose
-;; in life is to act as a placeholder to allow the print-object of 
-;; user-vector-class objects to be printed.
-
-(defstruct (dummy-print-instance
-              (:print-function print-dummy-print-instance))
-  (print-object-string nil))
-
-(declaim (type list *dummy-print-instance-garbage*))
-(defvar      *dummy-print-instance-garbage* NIL)
-(defconstant *dummy-print-instance-garbage-limit* 100)
-
-(defmacro pure-array-p (x &optional (test-user-vector-instance-p T))
-  "Returns whether item is a 'pure' array -- i.e. not a string, and
-   not something holding a CLOS instance."
-  (once-only (x)
-    `(the boolean
-          (locally (declare (inline arrayp stringp typep))
-            (and (arrayp ,x)
-                 (not (stringp ,x))
-                 #-(or cmu (and lucid pcl))
-                 (not (typep ,x 'structure))
-                 ,@(when test-user-vector-instance-p
-                     `((not (user-vector-instance-p ,x))))
-                 #-(or cmu (and lucid pcl))
-                 (not (typep ,x 'standard-object)))))))
-
-(defun copy-any-array (old-array &rest keys-passed &key key dimensions)
-  ;; Returns a copy of old-array.  If :key is provided, then the
-  ;; elements of the new-array are the result of key applied to
-  ;; old-array's elements.  If :dimensions is provided, and it is
-  ;; different than old-array's dimensions, then the new-array is created
-  ;; with those dimensions, and everything that can be copied from
-  ;; old-array is copied into it.  It is an error if the rank of
-  ;; the array specified by dimensionss is different than that of the
-  ;; old-array.
-  (declare (type array              old-array)
-           (type (or function null) key)
-           (type list               dimensions keys-passed))
-  (cond
-    ((simple-vector-p old-array)
-     (apply #'copy-array-contents
-            old-array
-            (make-array (the index
-                             (if dimensions
-                                 (car dimensions)
-                               (length (the simple-vector old-array)))))
-            keys-passed))
-    ((vectorp old-array)
-     (apply #'copy-array-contents
-            old-array
-            (make-array (the index
-                             (if dimensions
-                                 (car dimensions)
-                               (length (the vector old-array))))
-                        :element-type (array-element-type old-array)
-                        :adjustable   (adjustable-array-p old-array))
-            keys-passed))
-    ((arrayp old-array)
-     (let* ((old-dimensions (array-dimensions   old-array))
-            (new-dimensions (or dimensions old-dimensions))
-            (element-type   (array-element-type old-array))
-            (new-array
-              (make-array new-dimensions
-                          :element-type element-type
-                          :adjustable   (adjustable-array-p old-array))))
-       (declare (type list  old-dimensions new-dimensions)
-                (type array new-array))
-       (if (or (null dimensions) (equal new-dimensions old-dimensions))
-           (let* ((displaced-old-array
-                    (make-array (array-total-size old-array)
-                      :element-type element-type
-                      :displaced-to old-array))
-                  (displaced-new-array
-                    (make-array (array-total-size new-array)
-                      :element-type element-type
-                      :displaced-to new-array)))
-             (declare (type array displaced-old-array displaced-new-array))
-             (copy-array-contents displaced-old-array
-                                  displaced-new-array
-                                  :key key))
-         (let ((first-dimension
-                  (min (the index (car new-dimensions))
-                       (the index (car old-dimensions)))))
-            (declare (type index first-dimension))
-            (walk-dimensions
-              (mapcar #'min (cdr new-dimensions) (cdr old-dimensions))
-              #'(lambda (post-indices)
-                 (copy-array-contents old-array new-array
-                                      :key key
-                                      :length first-dimension
-                                      :post-indices post-indices)))))
-       new-array))))
-
-(defun copy-array-contents
-       (old-array new-array &key key length post-indices &allow-other-keys)
-  ;; Copies the contents of old-array into new-array, using key if
-  ;; supplied.  Only the first :length items are copied (defaulting
-  ;; to the length of the old-array).  If :post-indices are passed, then
-  ;; they are used as "post" indices to an aref.
-  (macrolet
-   ((do-copy (aref old new key key-type len post-indices)
-     (let ((atype (if (eq aref #'svref) 'simple-vector 'array)))
-       `(dotimes (i (the index ,len))
-          (setf ,(if post-indices
-                     `(apply #'aref (the ,atype ,new) i ,post-indices)
-                    `(,aref (the ,atype ,new) i))
-                ,(if key-type
-                     `(funcall
-                        (the ,key-type ,key)
-                        ,(if post-indices
-                             `(apply #'aref (the ,atype ,old)
-                                     i ,post-indices)
-                           `(,aref (the ,atype ,old) i)))
-                   (if post-indices
-                      `(apply #'aref (the ,atype ,old) i ,post-indices)
-                    `(,aref (the ,atype ,old) i)))))))
-     (expand-on-key (aref key old new len post-ind)
-       `(cond
-         ((null ,key)
-          (do-copy ,aref ,old ,new ,key NIL ,len ,post-ind))
-         ((compiled-function-p ,key)
-          (do-copy ,aref ,old ,new ,key compiled-function ,len ,post-ind))
-         (T
-          (do-copy ,aref ,old ,new ,key function ,len ,post-ind)))))
-    (if (simple-vector-p old-array)
-        (progn
-          (when post-indices
-            (error "Can't pass post-indices given to COPY-ARRAY-CONTENTS
-                    from simple-vector"))
-          
-          (unless length
-            (setf length (min (length (the simple-vector old-array))
-                              (length (the simple-vector new-array)))))
-          (expand-on-key svref key old-array new-array length NIL))
-       (progn
-         (unless length
-           (setf length (min (the index (car (array-dimensions old-array)))
-                             (the index (car (array-dimensions new-array))))))
-         (if post-indices
-             (expand-on-key #'aref key old-array new-array length post-indices)
-             (expand-on-key aref key old-array new-array length NIL)))))
-  new-array)
-
-(declaim (ftype (function (list function) T) walk-dimensions))
-(defun walk-dimensions (dimensions fn)
-  (declare (type list     dimensions)
-           (type function fn))
-  ;; Given a list of dimensions (e.g. '(3 2 8)), this function walks
-  ;; through every possible combination from 0 to 1- each of those
-  ;; dimensions, and calling fn on each of them.
-  (let ((compiled-p (compiled-function-p fn)))
-    (labels
-      ((doit (dims apply-dims)
-         (declare (type list dims apply-dims))
-         (if (cdr dims)
-             (let ((last-dim  NIL)
-                   (dims-left NIL))
-                (loop (when (null (cdr dims))
-                        (setf last-dim (car dims))
-                        (return))
-                      (if dims-left
-                          (nconc dims-left (list (car dims)))
-                        (setf dims-left (list (car dims))))
-                      (setf dims (cdr dims)))
-                 (dotimes (i (the index last-dim))
-                   (doit dims-left (cons i apply-dims))))
-           (if compiled-p 
-               (dotimes (i (the index (car dims)))
-                 (funcall (the compiled-function fn) (cons i apply-dims)))
-             (dotimes (i (the index (car dims)))
-               (funcall fn (cons i apply-dims)))))))
-      (doit dimensions NIL))))
-
-(defmacro funcall-printer (applyer print-function object keys)
-  `(progn
-     (if (or (arrayp ,object) (consp ,object))
-         (multiple-value-bind (converted-item garbage)
-           (convert-user-vector-instances-to-dummy-print-instances ,object)
-           (,applyer (the compiled-function ,print-function)
-                     converted-item ,keys)
-           (deallocate-dummy-print-instances garbage))
-       (,applyer (the compiled-function ,print-function)
-                ,object ,keys))
-     ,object))
-
-(defun print-dummy-print-instance (instance stream depth)
-  (declare (ignore depth))
-  (let ((*print-pretty* NIL))
-    (funcall (the compiled-function *old-princ*)
-             (dummy-print-instance-print-object-string instance)
-             stream)))
-
-(defun allocate-dummy-print-instance (print-object-string)
-  (if *dummy-print-instance-garbage*
-      (let ((instance (pop *dummy-print-instance-garbage*)))
-        (setf (dummy-print-instance-print-object-string instance)
-              print-object-string)
-        instance)
-    (make-dummy-print-instance :print-object-string print-object-string)))
-
-(defun dummy-print-instance-of (user-vector-instance)
-  (allocate-dummy-print-instance 
-    (with-output-to-string (str)
-      (print-object user-vector-instance str))))
-
-(defun deallocate-dummy-print-instances (dummies)
-  (let ((count (length *dummy-print-instance-garbage*)))
-    (declare (type index count))
-    (dolist (dummy dummies)
-      (when (> count *dummy-print-instance-garbage-limit*)
-        (return))
-      (push dummy *dummy-print-instance-garbage*)
-      (setf count (the index (1+ count))))))
-   
-(defun convert-user-vector-instances-to-dummy-print-instances (item)
-  (let ((print-length
-          (or *print-length* 1000))
-        (print-level
-          (or *print-level* 1000))
-        (dummy-print-instances-used NIL))
-    (declare (fixnum print-length print-level))
-    (labels
-      ((doit (item level length)
-         (declare (fixnum level length))
-         (labels
-           ((user-vector-instance-visible-within-p (item level length)
-              (declare (fixnum level length))
-              (cond
-                ((>= length print-length) NIL)
-                ((> level print-level) NIL)
-                ((= level print-level) (user-vector-instance-p item))
-                (T (cond
-                    ((user-vector-instance-p item) T)
-                    ((consp item)
-                     (or (user-vector-instance-visible-within-p
-                           (car item) (the fixnum (1+ level)) 0)
-                         (user-vector-instance-visible-within-p
-                           (cdr item) level (the fixnum (1+ length)))))
-                    ((and *print-array* (pure-array-p item))
-                     (let ((next-level (the fixnum (1+ level))))
-                       (declare (fixnum next-level))
-                       (dotimes (i (1- (length (the array item))) NIL)
-                         (unless (< i print-length)
-                           (return NIL))
-                         (if (user-vector-instance-visible-within-p
-                               (aref item i) next-level 0)
-                             (return T))))))))))
-            ;; doit body
-            (cond
-              ((user-vector-instance-p item)
-               (let ((dummy (dummy-print-instance-of item)))
-                 (push dummy dummy-print-instances-used)
-                 dummy))
-              ((consp item)
-               (if (user-vector-instance-visible-within-p item level length)
-                   (cons (doit (car item) (the fixnum (1+ level)) length)
-                         (doit (cdr item) level (the fixnum (1+ length))))
-                 item))
-              ((and *print-array* (pure-array-p item NIL))
-               (if (user-vector-instance-visible-within-p item level length)
-                   (copy-any-array
-                     item
-                     :key
-                     #'(lambda (item)
-                         (if (user-vector-instance-p item)
-                             (let ((dummy (dummy-print-instance-of item)))
-                               (push dummy dummy-print-instances-used)
-                               dummy)
-                           item))
-                     :dimensions
-                       (mapcar #'1+ (array-dimensions item)))
-                    item))
-              (T item)))))
-
-      ;; convert-user-vector-instances-to-dummy-print-instances body
-
-      (let ((converted (doit item 0 0)))
-        (values converted dummy-print-instances-used)))))
-
-(force-compile 'convert-user-vector-instances-to-dummy-print-instances)
-
-(unless *old-write* (setf *old-write* (symbol-function 'write)))
-(defun new-write (object &rest keys-passed)
-  (declare (list keys-passed))
-  (funcall-printer apply *old-write* object keys-passed))
-(force-compile 'write)
-(setf (symbol-function 'write) (symbol-function 'new-write))
-
-(unless *old-princ* (setf *old-princ* (symbol-function 'princ)))
-(defun princ (object &optional stream)
-  (funcall-printer funcall *old-princ* object stream))
-(force-compile 'princ)
-
-(unless *old-prin1* (setf *old-prin1* (symbol-function 'prin1)))
-(defun prin1 (object &optional stream)
-  (funcall-printer funcall *old-prin1* object stream))
-(force-compile 'prin1)
-
-(unless *old-print* (setf *old-print* (symbol-function 'print)))
-(defun print (object &optional stream)
-  (funcall-printer funcall *old-print* object stream))
-(force-compile 'print)
-
-(defun new-write-to-string (object &rest keys-passed)
-  (declare (list keys-passed))
-  (with-output-to-string (string-stream)
-    (apply #'write object :stream string-stream keys-passed)))
-(force-compile 'write-to-string)
-(setf (symbol-function 'write-to-string)
-      (symbol-function 'new-write-to-string))
-
-(defun princ-to-string (object)
-  (with-output-to-string (string-stream)
-    (funcall-printer funcall *old-princ* object string-stream)
-    string-stream))
-(force-compile 'princ-to-string)
-
-(defun prin1-to-string (object)
-  (with-output-to-string (string-stream)
-    (funcall-printer funcall *old-prin1* object string-stream)
-    string-stream))
-(force-compile 'prin1-to-string)
- 
-(defun restore-lisp-printers ()
-  (setf (symbol-function 'write) *old-write*)
-  (setf (symbol-function 'princ) *old-princ*)
-  (setf (symbol-function 'prin1) *old-prin1*)
-  (setf (symbol-function 'print) *old-print*))
-
diff --git a/pcl/vaxl-low.lisp b/pcl/vaxl-low.lisp
deleted file mode 100644
index ae9383bb5d4b432448051303561ef52424a1dbda..0000000000000000000000000000000000000000
--- a/pcl/vaxl-low.lisp
+++ /dev/null
@@ -1,80 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; The version of low for VAXLisp
-;;; 
-(in-package 'pcl)
-
-(defmacro without-interrupts (&body body)
-  `(macrolet ((interrupts-on  ()
-	       `(when (null outer-scheduling-state)
-		  (setq system::*critical-section-p* nil)
-		  (when (system::%sp-interrupt-queued-p)
-		    (system::interrupt-dequeuer t))))
-	      (interrupts-off ()
-	       `(setq system::*critical-section-p* t)))
-     (let ((outer-scheduling-state system::*critical-section-p*))
-       (prog1 (let ((system::*critical-section-p* t)) ,@body)
-	      (when (and (null outer-scheduling-state)
-			 (system::%sp-interrupt-queued-p))
-		(system::interrupt-dequeuer t))))))
-
-
-  ;;   
-;;;;;; Load Time Eval
-  ;;
-(defmacro load-time-eval (form)
-  `(progn ,form))
-
-  ;;   
-;;;;;; Generating CACHE numbers
-  ;;
-;;; How are symbols in VAXLisp actually arranged in memory?
-;;; Should we be shifting the address?
-;;; Are they relocated?
-;;; etc.
-
-;(defmacro symbol-cache-no (symbol mask)
-;  `(logand (the fixnum (system::%sp-pointer->fixnum ,symbol)) ,mask))
-
-(defmacro object-cache-no (object mask)
-  `(logand (the fixnum (system::%sp-pointer->fixnum ,object)) ,mask))
-
-  ;;   
-;;;;;; printing-random-thing-internal
-  ;;
-(defun printing-random-thing-internal (thing stream)
-  (format stream "~O" (system::%sp-pointer->fixnum thing)))
-
-
-(defun function-arglist (fn)
-  (system::function-lambda-vars (symbol-function fn)))
-
-(defun set-function-name-1 (fn name ignore)
-  (cond ((system::slisp-compiled-function-p fn)
-	 (system::%sp-b-store fn 3 name)))
-  fn)
-
diff --git a/pcl/vector.lisp b/pcl/vector.lisp
deleted file mode 100644
index c85aecff4da2cc59f147fb686e86d02fff4c148b..0000000000000000000000000000000000000000
--- a/pcl/vector.lisp
+++ /dev/null
@@ -1,1083 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; Permutation vectors.
-;;;
-
-(in-package :pcl)
-
-(defmacro instance-slot-index (wrapper slot-name)
-  `(let ((pos 0))
-     (declare (fixnum pos))
-     (block loop
-       (dolist (sn (wrapper-instance-slots-layout ,wrapper))
-	 (when (eq ,slot-name sn) (return-from loop pos))
-	 (incf pos)))))
-
-
-;;;
-;;;
-;;;
-(defun pv-cache-limit-fn (nlines)
-  (default-limit-fn nlines))
-
-(defstruct (pv-table
-	     (:predicate pv-tablep)
-	     (:constructor make-pv-table-internal
-			   (slot-name-lists call-list)))
-  (cache nil :type (or cache null))
-  (pv-size 0 :type fixnum)
-  (slot-name-lists nil :type list)
-  (call-list nil :type list))
-
-(defvar *initial-pv-table* (make-pv-table-internal nil nil))
-
-; help new slot-value-using-class methods affect fast iv access
-(defvar *all-pv-table-list* nil) 
-
-(defun make-pv-table (&key slot-name-lists call-list)
-  (let ((pv-table (make-pv-table-internal slot-name-lists call-list)))
-    (push pv-table *all-pv-table-list*)
-    pv-table))
-
-(defun make-pv-table-type-declaration (var)
-  `(type pv-table ,var))
-
-(defvar *slot-name-lists-inner* (make-hash-table :test #'equal))
-(defvar *slot-name-lists-outer* (make-hash-table :test #'equal))
-
-;entries in this are lists of (table . pv-offset-list)
-(defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal))
-
-(defun intern-pv-table (&key slot-name-lists call-list)
-  (let ((new-p nil))
-    (flet ((inner (x)
-	     (or (gethash x *slot-name-lists-inner*)
-		 (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
-	   (outer (x)
-	     (or (gethash x *slot-name-lists-outer*)
-		 (setf (gethash x *slot-name-lists-outer*)
-		       (let ((snl (copy-list (cdr x)))
-			     (cl (car x)))
-			 (setq new-p t)
-			 (make-pv-table :slot-name-lists snl
-					:call-list cl))))))
-    (let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists)))))
-      (when new-p
-	(let ((pv-index 1))
-	  (dolist (slot-name-list slot-name-lists)
-	    (dolist (slot-name (cdr slot-name-list))
-	      (note-pv-table-reference slot-name pv-index pv-table)
-	      (incf pv-index)))
-	  (dolist (gf-call call-list)
-	    (note-pv-table-reference gf-call pv-index pv-table)
-	    (incf pv-index))
-	  (setf (pv-table-pv-size pv-table) pv-index)))
-      pv-table))))
-
-(defun note-pv-table-reference (ref pv-offset pv-table)
-  (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
-    (when (listp entry)
-      (let ((table-entry (assq pv-table entry)))
-	(when (and (null table-entry)
-		   (> (length entry) 8))
-	  (let ((new-table-table (make-hash-table :size 16 :test 'eq)))
-	    (dolist (table-entry entry)
-	      (setf (gethash (car table-entry) new-table-table)
-		    (cdr table-entry)))
-	    (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table)))
-	(when (listp entry)
-	  (if (null table-entry)
-	      (let ((new (cons pv-table pv-offset)))
-		(if (consp entry)
-		    (push new (cdr entry))
-		    (setf (gethash ref *pv-key-to-pv-table-table*) (list new))))
-	      (push pv-offset (cdr table-entry)))
-	  (return-from note-pv-table-reference nil))))
-    (let ((list (gethash pv-table entry)))
-      (if (consp list)
-	  (push pv-offset (cdr list))
-	  (setf (gethash pv-table entry) (list pv-offset)))))
-  nil)
-
-(defun map-pv-table-references-of (ref function)
-  (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
-    (if (listp entry)
-	(dolist (table+pv-offset-list entry)
-	  (funcall function
-		   (car table+pv-offset-list) (cdr table+pv-offset-list)))
-	(maphash function entry)))
-  ref)
-
-
-(defvar *pvs* (make-hash-table :test #'equal))
-
-(defun optimize-slot-value-by-class-p (class slot-name type)
-  (or (not (eq *boot-state* 'complete))
-      (let ((slotd (find-slot-definition class slot-name)))
-	(and slotd 
-	     (slot-accessor-std-p slotd type)))))
-
-(defun compute-pv-slot (slot-name wrapper class class-slots class-slot-p-cell)
-  (if (symbolp slot-name)
-      (when (optimize-slot-value-by-class-p class slot-name 'all)
-	(or (instance-slot-index wrapper slot-name)
-	    (let ((cell (assq slot-name class-slots)))
-	      (when cell
-		(setf (car class-slot-p-cell) t)
-		cell))))
-      (when (consp slot-name)
-	(dolist (type '(reader writer) nil)
-	  (when (eq (car slot-name) type)
-	    (return
-	      (let* ((gf-name (cadr slot-name))
-		     (gf (gdefinition gf-name))
-		     (location 
-		      (when (eq *boot-state* 'complete)
-			(accessor-values1 gf type class))))
-		(when (consp location)
-		  (setf (car class-slot-p-cell) t))
-		location)))))))
-
-(defun compute-pv (slot-name-lists wrappers)
-  (unless (listp wrappers) (setq wrappers (list wrappers)))
-  (let* ((not-simple-p-cell (list nil))
-	 (elements
-	  (gathering1 (collecting)
-	    (iterate ((slot-names (list-elements slot-name-lists)))
-	      (when slot-names
-		(let* ((wrapper     (pop wrappers))
-		       (class       (wrapper-class* wrapper))
-		       (class-slots (wrapper-class-slots wrapper)))
-		  (dolist (slot-name (cdr slot-names))
-		    (gather1
-		     (compute-pv-slot slot-name wrapper class 
-				      class-slots not-simple-p-cell)))))))))
-    (if (car not-simple-p-cell)
-	(make-permutation-vector (cons t elements))
-	(or (gethash elements *pvs*)
-	    (setf (gethash elements *pvs*)
-		  (make-permutation-vector (cons nil elements)))))))
-
-(defun compute-calls (call-list wrappers)
-  (declare (ignore call-list wrappers))
-  #||
-  (map 'vector
-       #'(lambda (call)
-	   (compute-emf-from-wrappers call wrappers))
-       call-list)
-  ||#  
-  '#())
-
-#|| ; Need to finish this, then write the maintenance functions.
-(defun compute-emf-from-wrappers (call wrappers)
-  (when call
-    (destructuring-bind (gf-name nreq restp arg-info) call
-      (if (eq gf-name 'make-instance)
-	  (error "should not get here") ; there is another mechanism for this.
-	  #'(lambda (&rest args)
-	      (if (not (eq *boot-state* 'complete))
-		  (apply (gdefinition gf-name) args)
-		  (let* ((gf (gdefinition gf-name))
-			 (arg-info (arg-info-reader gf))
-			 (classes '?)
-			 (types '?)
-			 (emf (cache-miss-values-internal gf arg-info 
-							  wrappers classes types 
-							  'caching)))
-		    (update-all-pv-tables call wrappers emf)
-		    #+copy-&rest-arg (setq args (copy-list args))
-		    (invoke-emf emf args))))))))
-||#
-
-(defun make-permutation-vector (indexes)
-  (make-array (length indexes) :initial-contents indexes))
-
-(defun pv-table-lookup (pv-table pv-wrappers)
-  (let* ((slot-name-lists (pv-table-slot-name-lists pv-table))
-	 (call-list (pv-table-call-list pv-table))
-	 (cache (or (pv-table-cache pv-table)
-		    (setf (pv-table-cache pv-table)
-			  (get-cache (- (length slot-name-lists)
-					(count nil slot-name-lists))
-				     t
-				     #'pv-cache-limit-fn
-				     2)))))
-    (or (probe-cache cache pv-wrappers)
-	(let* ((pv (compute-pv slot-name-lists pv-wrappers))
-	       (calls (compute-calls call-list pv-wrappers))
-	       (pv-cell (cons pv calls))
-	       (new-cache (fill-cache cache pv-wrappers pv-cell)))
-	  (unless (eq new-cache cache)
-	    (setf (pv-table-cache pv-table) new-cache)
-	    (free-cache cache))
-	  pv-cell))))
-
-(defun make-pv-type-declaration (var)
-  `(type simple-vector ,var))
-
-(defvar *empty-pv* #())
-
-(defmacro pvref (pv index)
-  `(svref ,pv ,index))
-
-(defmacro copy-pv (pv)
-  `(copy-seq ,pv))
-
-(defun make-calls-type-declaration (var)
-  `(type simple-vector ,var))
-
-(defmacro callsref (calls index)
-  `(svref ,calls ,index))
-
-(defvar *pv-table-cache-update-info* nil)
-
-;called by: 
-;(method shared-initialize :after (structure-class t))
-;update-slots
-(defun update-pv-table-cache-info (class)
-  (let ((slot-names-for-pv-table-update nil)
-	(new-icui nil))
-    (dolist (icu *pv-table-cache-update-info*)
-      (if (eq (car icu) class)
-	  (pushnew (cdr icu) slot-names-for-pv-table-update)
-	  (push icu new-icui)))
-    (setq *pv-table-cache-update-info* new-icui)
-    (when slot-names-for-pv-table-update
-      (update-all-pv-table-caches class slot-names-for-pv-table-update))))
-
-(defun update-all-pv-table-caches (class slot-names)
-  (let* ((cwrapper (class-wrapper class))
-	 (class-slots (wrapper-class-slots cwrapper))
-	 (class-slot-p-cell (list nil))
-	 (new-values (mapcar #'(lambda (slot-name)
-				 (cons slot-name
-				       (compute-pv-slot 
-					slot-name cwrapper class 
-					class-slots class-slot-p-cell)))
-			     slot-names))
-	 (pv-tables nil))
-    (dolist (slot-name slot-names)
-      (map-pv-table-references-of
-       slot-name
-       #'(lambda (pv-table pv-offset-list)
-	   (declare (ignore pv-offset-list))
-	   (pushnew pv-table pv-tables))))
-    (dolist (pv-table pv-tables)
-      (let* ((cache (pv-table-cache pv-table))
-	     (slot-name-lists (pv-table-slot-name-lists pv-table))
-	     (pv-size (pv-table-pv-size pv-table))
-	     (pv-map (make-array pv-size)))
-	(let ((map-index 1)(param-index 0))
-	  (dolist (slot-name-list slot-name-lists)
-	    (dolist (slot-name (cdr slot-name-list))
-	      (let ((a (assoc slot-name new-values)))
-		(setf (svref pv-map map-index)
-		      (and a (cons param-index (cdr a)))))
-	      (incf map-index))
-	    (incf param-index)))
-	(when cache
-	  (map-cache #'(lambda (wrappers pv-cell)
-			 (setf (car pv-cell)
-			       (update-slots-in-pv wrappers (car pv-cell)
-						   cwrapper pv-size pv-map)))
-		     cache))))))
-
-(defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)
-  (if (not (if (atom wrappers)
-	       (eq cwrapper wrappers)
-	       (dolist (wrapper wrappers nil)
-		 (when (eq wrapper cwrapper)
-		   (return t)))))
-      pv
-      (let* ((old-intern-p (listp (pvref pv 0)))
-	     (new-pv (if old-intern-p
-			 (copy-pv pv)
-			 pv))
-	     (new-intern-p t))
-	(if (atom wrappers)
-	    (dotimes (i pv-size)
-	      (when (consp (let ((map (svref pv-map i)))
-			     (if map
-				 (setf (pvref new-pv i) (cdr map))
-				 (pvref new-pv i))))
-		(setq new-intern-p nil)))
-	    (let ((param 0))
-	      (dolist (wrapper wrappers)
-		(when (eq wrapper cwrapper)
-		  (dotimes (i pv-size)
-		    (when (consp (let ((map (svref pv-map i)))
-				   (if (and map (= (car map) param))
-				       (setf (pvref new-pv i) (cdr map))
-				       (pvref new-pv i))))
-		      (setq new-intern-p nil))))
-		(incf param))))
-	(when new-intern-p
-	  (setq new-pv (let ((list-pv (coerce pv 'list)))
-			 (or (gethash (cdr list-pv) *pvs*)
-			     (setf (gethash (cdr list-pv) *pvs*)
-				   (if old-intern-p
-				       new-pv
-				       (make-permutation-vector list-pv)))))))
-	new-pv)))
-
-
-(defun maybe-expand-accessor-form (form required-parameters slots env)
-  (let* ((fname (car form))
-	 #||(len (length form))||#
-	 (gf (if (symbolp fname)
-		 (unencapsulated-fdefinition fname)
-		 (gdefinition fname))))
-    (macrolet ((maybe-optimize-reader ()
-		 `(let ((parameter
-			 (can-optimize-access1 (cadr form)
-					       required-parameters env)))
-		   (when parameter
-		     (optimize-reader slots parameter gf-name form))))
-	       (maybe-optimize-writer ()
-		 `(let ((parameter
-			 (can-optimize-access1 (caddr form)
-					       required-parameters env)))
-		   (when parameter
-		     (optimize-writer slots parameter gf-name form)))))
-      (unless (and (consp (cadr form))
-		   (eq 'instance-accessor-parameter (caadr form)))
-	(or #||
-	    (cond ((and (= len 2) (symbolp fname))
-		   (let ((gf-name (gethash fname *gf-declared-reader-table*)))
-		     (when gf-name
-		       (maybe-optimize-reader))))
-		  ((= len 3)
-		   (let ((gf-name (gethash fname *gf-declared-writer-table*)))
-		     (when gf-name
-		       (maybe-optimize-writer)))))
-	    ||#
-	    (when (and (eq *boot-state* 'complete)
-		       (generic-function-p gf))
-	      (let ((methods (generic-function-methods gf)))
-		(when methods
-		  (let* ((gf-name (generic-function-name gf))
-			 (arg-info (gf-arg-info gf))
-			 (metatypes (arg-info-metatypes arg-info))
-			 (nreq (length metatypes))
-			 (applyp (arg-info-applyp arg-info)))
-		    (when (null applyp)
-		      (cond ((= nreq 1)
-			     (when (some #'standard-reader-method-p methods)
-			       (maybe-optimize-reader)))
-			    ((and (= nreq 2)
-				  (consp gf-name)
-				  (eq (car gf-name) 'setf))
-			     (when (some #'standard-writer-method-p methods)
-			       (maybe-optimize-writer))))))))))))))
-
-(defun optimize-generic-function-call (form required-parameters env slots calls)
-  (declare (ignore required-parameters env slots calls))
-  (or (and (eq (car form) 'make-instance)
-	   (expand-make-instance-form form))
-      #||
-      (maybe-expand-accessor-form form required-parameters slots env)
-      (let* ((fname (car form))
-	     (len (length form))
-	     (gf (if (symbolp fname)
-		     (and (fboundp fname)
-			  (unencapsulated-fdefinition fname))
-		     (and (gboundp fname)
-			  (gdefinition fname))))
-	     (gf-name (and (fsc-instance-p gf)
-			   (if (early-gf-p gf)
-			       (early-gf-name gf)
-			       (generic-function-name gf)))))
-	(when gf-name
-	  (multiple-value-bind (nreq restp)
-	      (get-generic-function-info gf)
-	    (optimize-gf-call slots calls form nreq restp env))))
-      ||#
-      form))
-
-
-
-(defun can-optimize-access (form required-parameters env)
-  (let ((type (ecase (car form)
-		(slot-value 'reader)
-		(set-slot-value 'writer)
-		(slot-boundp 'boundp)))
-	(var (cadr form))
-	(slot-name (eval (caddr form)))) ; known to be constant
-    (can-optimize-access1 var required-parameters env type slot-name)))
-
-(defun can-optimize-access1 (var required-parameters env &optional type slot-name)
-  (when (and (consp var) (eq 'the (car var)))
-    (setq var (caddr var)))
-  (when (symbolp var)
-    (let* ((rebound? (caddr (variable-declaration 'variable-rebinding var env)))
-	   (parameter-or-nil (car (memq (or rebound? var) required-parameters))))
-      (when parameter-or-nil
-	(let* ((class-name (caddr (variable-declaration 
-				   'class parameter-or-nil env)))
-	       (class (find-class class-name nil)))
-	  (when (or (not (eq *boot-state* 'complete))
-		    (and class (not (class-finalized-p class))))
-	    (setq class nil))
-	  (when (and class-name (not (eq class-name 't)))
-	    (when (or (null type)
-		      (not (and class
-				(memq *the-class-structure-object*
-				      (class-precedence-list class))))
-		      (optimize-slot-value-by-class-p class slot-name type))
-	      (cons parameter-or-nil (or class class-name)))))))))
-
-(defun optimize-slot-value (slots sparameter form)
-  (if sparameter
-      (destructuring-bind (ignore ignore slot-name-form) form
-	(let ((slot-name (eval slot-name-form)))
-	  (optimize-instance-access slots :read sparameter slot-name nil)))
-      `(accessor-slot-value ,@(cdr form))))
-
-(defun optimize-set-slot-value (slots sparameter form)
-  (if sparameter
-      (destructuring-bind (ignore ignore slot-name-form new-value) form
-	(let ((slot-name (eval slot-name-form)))
-	  (optimize-instance-access slots :write sparameter slot-name new-value)))
-      `(accessor-set-slot-value ,@(cdr form))))
-
-(defun optimize-slot-boundp (slots sparameter form)
-  (if sparameter
-      (destructuring-bind (ignore ignore slot-name-form new-value) form
-	(let ((slot-name (eval slot-name-form)))
-	  (optimize-instance-access slots :boundp sparameter slot-name new-value)))
-      `(accessor-slot-boundp ,@(cdr form))))
-
-(defun optimize-reader (slots sparameter gf-name form)
-  (if sparameter
-      (optimize-accessor-call slots :read sparameter gf-name nil)
-      form))
-
-(defun optimize-writer (slots sparameter gf-name form)
-  (if sparameter
-      (destructuring-bind (ignore ignore new-value) form
-	(optimize-accessor-call slots :write sparameter gf-name new-value))
-      form))
-;;;
-;;; The <slots> argument is an alist, the CAR of each entry is the name of
-;;; a required parameter to the function.  The alist is in order, so the
-;;; position of an entry in the alist corresponds to the argument's position
-;;; in the lambda list.
-;;; 
-(defun optimize-instance-access (slots read/write sparameter slot-name new-value)
-  (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
-	(parameter (if (consp sparameter) (car sparameter) sparameter)))
-    (if (and (eq *boot-state* 'complete)
-	     (classp class)
-	     (memq *the-class-structure-object* (class-precedence-list class)))
-	(let ((slotd (find-slot-definition class slot-name)))
-	  (ecase read/write
-	    (:read
-	     `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter))
-	    (:write
-	     `(setf (,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)
-	       ,new-value))
-	    (:boundp
-	     'T)))
-	(let* ((parameter-entry (assq parameter slots))
-	       (slot-entry      (assq slot-name (cdr parameter-entry)))
-	       (position (posq parameter-entry slots))
-	       (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
-	  (unless parameter-entry
-	    (error "Internal error in slot optimization."))
-	  (unless slot-entry
-	    (setq slot-entry (list slot-name))
-	    (push slot-entry (cdr parameter-entry)))
-	  (push pv-offset-form (cdr slot-entry))
-	  (ecase read/write
-	    (:read
-	     `(instance-read ,pv-offset-form ,parameter ,position 
-		             ',slot-name ',class))
-	    (:write
-	     `(let ((.new-value. ,new-value)) 
-	        (instance-write ,pv-offset-form ,parameter ,position 
-		                ',slot-name ',class .new-value.)))
-	    (:boundp
-	     `(instance-boundp ,pv-offset-form ,parameter ,position 
-		               ',slot-name ',class)))))))
-
-(defun optimize-accessor-call (slots read/write sparameter gf-name new-value)
-  (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
-	 (parameter (if (consp sparameter) (car sparameter) sparameter))
-	 (parameter-entry (assq parameter slots))
-	 (name (case read/write
-		 (:read `(reader ,gf-name))
-		 (:write `(writer ,gf-name))))
-	 (slot-entry      (assoc name (cdr parameter-entry) :test #'equal))
-	 (position (posq parameter-entry slots))
-	 (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
-    (unless parameter-entry
-      (error "Internal error in slot optimization."))
-    (unless slot-entry
-      (setq slot-entry (list name))
-      (push slot-entry (cdr parameter-entry)))
-    (push pv-offset-form (cdr slot-entry))
-    (ecase read/write
-      (:read
-       `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class))
-      (:write
-       `(let ((.new-value. ,new-value)) 
-	  (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class
-	                   .new-value.))))))
-
-(defvar *unspecific-arg* '..unspecific-arg..)
-
-(defun optimize-gf-call-internal (form slots env)
-  (when (and (consp form)
-	     (eq (car form) 'the))
-    (setq form (caddr form)))
-  (or (and (symbolp form)
-	   (let* ((rebound? (caddr (variable-declaration 'variable-rebinding
-							 form env)))
-		  (parameter-or-nil (car (assq (or rebound? form) slots))))
-	     (when parameter-or-nil
-	       (let* ((class-name (caddr (variable-declaration 
-					  'class parameter-or-nil env))))
-		 (when (and class-name (not (eq class-name 't)))
-		   (position parameter-or-nil slots :key #'car))))))
-      (if (constantp form)
-	  (let ((form (eval form)))
-	    (if (symbolp form)
-		form
-		*unspecific-arg*))
-	  *unspecific-arg*)))
-
-(defun optimize-gf-call (slots calls gf-call-form nreq restp env)
-  (unless (eq (car gf-call-form) 'make-instance) ; needs more work
-    (let* ((args (cdr gf-call-form))
-	   (all-args-p (eq (car gf-call-form) 'make-instance))
-	   (non-required-args (nthcdr nreq args))
-	   (required-args (ldiff args non-required-args))
-	   (call-spec (list (car gf-call-form) nreq restp
-			    (mapcar #'(lambda (form)
-					(optimize-gf-call-internal form slots env))
-				    (if all-args-p
-					args
-					required-args))))
-	   (call-entry (assoc call-spec calls :test #'equal))
-	   (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
-      (unless (some #'integerp 
-		    (let ((spec-args (cdr call-spec)))
-		      (if all-args-p 
-			  (ldiff spec-args (nthcdr nreq spec-args))
-			  spec-args)))
-	(return-from optimize-gf-call nil))
-      (unless call-entry
-	(setq call-entry (list call-spec))
-	(push call-entry (cdr calls)))
-      (push pv-offset-form (cdr call-entry))
-      (if (eq (car call-spec) 'make-instance)
-	  `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form))
-	  `(let ((.emf. (pv-ref .pv. ,pv-offset-form)))
-	    (invoke-effective-method-function .emf. ,restp
-	     ,@required-args ,@(when restp `((list ,@non-required-args)))))))))
-      
-
-(define-walker-template pv-offset) ; These forms get munged by mutate slots.
-(defmacro pv-offset (arg) arg)
-(define-walker-template instance-accessor-parameter)
-(defmacro instance-accessor-parameter (x) x)
-
-;; It is safe for these two functions to be wrong.
-;; They just try to guess what the most likely case will be.
-(defun generate-fast-class-slot-access-p (class-form slot-name-form)
-  (let ((class (and (constantp class-form) (eval class-form)))
-	(slot-name (and (constantp slot-name-form) (eval slot-name-form))))
-    (and (eq *boot-state* 'complete)
-	 (standard-class-p class)
-	 (not (eq class *the-class-t*)) ; shouldn't happen, though.
-	 (let ((slotd (find-slot-definition class slot-name)))
-	   (and slotd (classp (slot-definition-allocation slotd)))))))
-
-(defun skip-fast-slot-access-p (class-form slot-name-form type)
-  (let ((class (and (constantp class-form) (eval class-form)))
-	(slot-name (and (constantp slot-name-form) (eval slot-name-form))))
-    (and (eq *boot-state* 'complete)
-	 (standard-class-p class)
-	 (not (eq class *the-class-t*)) ; shouldn't happen, though.
-	 (let ((slotd (find-slot-definition class slot-name)))
-	   (and slotd (skip-optimize-slot-value-by-class-p class slot-name type))))))
-
-(defun skip-optimize-slot-value-by-class-p (class slot-name type)
-  (let ((slotd (find-slot-definition class slot-name)))
-    (and slotd
-	 (eq *boot-state* 'complete)
-	 (not (slot-accessor-std-p slotd type)))))
-
-(defmacro instance-read-internal (pv slots pv-offset default &optional type)
-  (unless (member type '(nil :instance :class :default))
-    (error "Illegal type argument to ~S: ~S" 'instance-read-internal type))
-  (if (eq type ':default)
-      default
-      (let* ((index (gensym))
-	     (value index))
-	`(locally (declare #.*optimize-speed*)
-	  (let ((,index (pvref ,pv ,pv-offset)))
-	    (setq ,value (typecase ,index
-			   ,@(when (or (null type) (eq type ':instance))
-			       `((fixnum (%instance-ref ,slots ,index))))
-			   ,@(when (or (null type) (eq type ':class))
-			       `((cons (cdr ,index))))
-			   (t ',*slot-unbound*)))
-	    (if (eq ,value ',*slot-unbound*)
-		,default
-		,value))))))
-
-(defmacro instance-read (pv-offset parameter position slot-name class)
-  (if (skip-fast-slot-access-p class slot-name 'reader)
-      `(accessor-slot-value ,parameter ,slot-name)
-      `(instance-read-internal .pv. ,(slot-vector-symbol position)
-	,pv-offset (accessor-slot-value ,parameter ,slot-name)
-	,(if (generate-fast-class-slot-access-p class slot-name)
-	     ':class ':instance))))
-
-(defmacro instance-reader (pv-offset parameter position gf-name class)
-  (declare (ignore class))
-  `(instance-read-internal .pv. ,(slot-vector-symbol position)
-    ,pv-offset 
-    (,gf-name (instance-accessor-parameter ,parameter))
-    :instance))
-
-(defmacro instance-write-internal (pv slots pv-offset new-value default
-				      &optional type)
-  (unless (member type '(nil :instance :class :default))
-    (error "Illegal type argument to ~S: ~S" 'instance-write-internal type))
-  (if (eq type ':default)
-      default
-      (let* ((index (gensym)))
-	`(locally (declare #.*optimize-speed*)
-	  (let ((,index (pvref ,pv ,pv-offset)))
-	    (typecase ,index
-	      ,@(when (or (null type) (eq type ':instance))
-		  `((fixnum (setf (%instance-ref ,slots ,index) ,new-value))))
-	      ,@(when (or (null type) (eq type ':class))
-		  `((cons (setf (cdr ,index) ,new-value))))
-	      (t ,default)))))))
-
-(defmacro instance-write (pv-offset parameter position slot-name class new-value)
-  (if (skip-fast-slot-access-p class slot-name 'writer)
-      `(accessor-set-slot-value ,parameter ,slot-name ,new-value)
-      `(instance-write-internal .pv. ,(slot-vector-symbol position)
-	,pv-offset ,new-value
-	(accessor-set-slot-value ,parameter ,slot-name ,new-value)
-	,(if (generate-fast-class-slot-access-p class slot-name)
-	     ':class ':instance))))
-
-(defmacro instance-writer (pv-offset parameter position gf-name class new-value)
-  (declare (ignore class))
-  `(instance-write-internal .pv. ,(slot-vector-symbol position)
-    ,pv-offset ,new-value
-    (,(if (consp gf-name)
-	  (get-setf-function-name gf-name)
-	  gf-name)
-     (instance-accessor-parameter ,parameter)
-     ,new-value)
-    :instance))
-
-(defmacro instance-boundp-internal (pv slots pv-offset default
-				       &optional type)
-  (unless (member type '(nil :instance :class :default))
-    (error "Illegal type argument to ~S: ~S" 'instance-boundp-internal type))
-  (if (eq type ':default)
-      default
-      (let* ((index (gensym)))
-	`(locally (declare #.*optimize-speed*)
-	  (let ((,index (pvref ,pv ,pv-offset)))
-	    (typecase ,index
-	      ,@(when (or (null type) (eq type ':instance))
-		  `((fixnum (not (eq (%instance-ref ,slots ,index) ',*slot-unbound*)))))
-	      ,@(when (or (null type) (eq type ':class))
-		  `((cons (not (eq (cdr ,index) ',*slot-unbound*)))))
-	      (t ,default)))))))
-
-(defmacro instance-boundp (pv-offset parameter position slot-name class)
-  (if (skip-fast-slot-access-p class slot-name 'boundp)
-      `(accessor-slot-boundp ,parameter ,slot-name)
-      `(instance-boundp-internal .pv. ,(slot-vector-symbol position)
-	,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
-	,(if (generate-fast-class-slot-access-p class slot-name)
-	     ':class ':instance))))
-
-;;;
-;;; This magic function has quite a job to do indeed.
-;;;
-;;; The careful reader will recall that <slots> contains all of the optimized
-;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.  Each of these is
-;;; a call to either INSTANCE-READ or INSTANCE-WRITE.
-;;;
-;;; At the time these calls were produced, the first argument was specified as
-;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset
-;;; arguments into the actual number that is the correct offset into the pv.
-;;;
-;;; But first, oh but first, we sort <slots> a bit so that for each argument
-;;; we have the slots in alphabetical order.  This canonicalizes the PV-TABLE's a
-;;; bit and will hopefully lead to having fewer PV's floating around.  Even
-;;; if the gain is only modest, it costs nothing.
-;;;  
-(defun slot-name-lists-from-slots (slots calls)
-  (multiple-value-bind (slots calls)
-      (mutate-slots-and-calls slots calls)
-    (let* ((slot-name-lists
-	    (mapcar #'(lambda (parameter-entry)
-			(cons nil (mapcar #'car (cdr parameter-entry))))
-		    slots))
-	   (call-list
-	    (mapcar #'car calls)))
-      (dolist (call call-list)
-	(dolist (arg (cdr call))
-	  (when (integerp arg)
-	    (setf (car (nth arg slot-name-lists)) t))))
-      (setq slot-name-lists (mapcar #'(lambda (r+snl)
-					(when (or (car r+snl) (cdr r+snl))
-					  r+snl))
-				    slot-name-lists))
-      (let ((cvt (apply #'vector
-			(let ((i -1))
-			  (mapcar #'(lambda (r+snl)
-				      (when r+snl (incf i)))
-				  slot-name-lists)))))
-	(setq call-list (mapcar #'(lambda (call)
-				    (cons (car call) 
-					  (mapcar #'(lambda (arg)
-						      (if (integerp arg)
-							  (svref cvt arg)
-							  arg))
-						  (cdr call))))
-				call-list)))
-      (values slot-name-lists call-list))))
-
-(defun mutate-slots-and-calls (slots calls)
-  (let ((sorted-slots (sort-slots slots))
-	(sorted-calls (sort-calls (cdr calls)))
-	(pv-offset 0))  ; index 0 is for info
-    (dolist (parameter-entry sorted-slots)
-      (dolist (slot-entry (cdr parameter-entry))
-	(incf pv-offset)	
-	(dolist (form (cdr slot-entry))
-	  (setf (cadr form) pv-offset))))
-    (dolist (call-entry sorted-calls)
-      (incf pv-offset)
-      (dolist (form (cdr call-entry))
-	(setf (cadr form) pv-offset)))
-    (values sorted-slots sorted-calls)))
-
-(defun symbol-pkg-name (sym) 
-  (let ((pkg (symbol-package sym)))
-    (if pkg (package-name pkg) "")))
-
-(defun symbol-lessp (a b)
-  (if (eq (symbol-package a)
-	  (symbol-package b))
-      (string-lessp (symbol-name a)
-		    (symbol-name b))
-      (string-lessp (symbol-pkg-name a)
-		    (symbol-pkg-name b))))
-
-(defun symbol-or-cons-lessp (a b)
-  (etypecase a
-    (symbol (etypecase b
-	      (symbol (symbol-lessp a b))
-	      (cons t)))
-    (cons   (etypecase b
-	      (symbol nil)
-	      (cons (if (eq (car a) (car b))
-			(symbol-or-cons-lessp (cdr a) (cdr b))
-			(symbol-or-cons-lessp (car a) (car b))))))))
-
-(defun sort-slots (slots)
-  (mapcar #'(lambda (parameter-entry)
-	      (cons (car parameter-entry)
-		    (sort (cdr parameter-entry)	;slot entries
-			  #'symbol-or-cons-lessp
-			  :key #'car)))
-	  slots))
-
-(defun sort-calls (calls)
-  (sort calls #'symbol-or-cons-lessp :key #'car))
-
-
-;;;
-;;; This needs to work in terms of metatypes and also needs to work for
-;;; automatically generated reader and writer functions.
-;;; -- Automatically generated reader and writer functions use this stuff too.
-
-(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol)
-		      &body body)
-  (with-gathering ((slot-vars (collecting))
-		   (pv-parameters (collecting)))
-    (iterate ((slots (list-elements slot-name-lists))
-	      (required-parameter (list-elements required-parameters))
-	      (i (interval :from 0)))
-      (when slots
-	(gather required-parameter pv-parameters)
-	(gather (slot-vector-symbol i) slot-vars)))
-    `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars)
-       ,@body)))
-
-(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) 
-		       &body body)
-  `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
-     (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
-	       slot-vars pv-parameters))
-	,@body)))
-
-;This gets used only when the default make-method-lambda is overriden.
-(defmacro pv-env ((pv calls pv-table-symbol pv-parameters)
-		  &rest forms)
-  `(let* ((.pv-table. ,pv-table-symbol)
-	  (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
-	  (,pv (car .pv-cell.))
-	  (,calls (cdr .pv-cell.)))
-     (declare ,(make-pv-type-declaration pv))
-     (declare ,(make-calls-type-declaration calls))
-     ,@(when (symbolp pv-table-symbol)
-	 `((declare (special ,pv-table-symbol))))
-     ,pv ,calls
-     ,@forms))
-
-(defvar *non-variable-declarations*
-  '(method-name method-lambda-list
-    optimize ftype inline notinline))
-
-(defvar *variable-declarations-with-argument*
-  '(class
-    type))
-
-(defvar *variable-declarations-without-argument*
-  '(ignore special dynamic-extent
-    array atom base-char bignum bit bit-vector character common compiled-function
-    complex cons double-float extended-char fixnum float function hash-table integer
-    keyword list long-float nil null number package pathname random-state ratio
-    rational readtable sequence short-float signed-byte simple-array
-    simple-bit-vector simple-string simple-vector single-float standard-char
-    stream string-char symbol t unsigned-byte vector))
-
-(defun split-declarations (body args)
-  (let ((inner-decls nil) (outer-decls nil) decl)
-    (loop (when (null body) (return nil))
-	  (setq decl (car body))
-	  (unless (and (consp decl)
-		       (eq (car decl) 'declare))
-	    (return nil))
-	  (dolist (form (cdr decl))
-	    (when (consp form)
-	      (let ((declaration-name (car form)))
-		(if (member declaration-name *non-variable-declarations*)
-		    (push `(declare ,form) outer-decls)
-		    (let ((arg-p
-			   (member declaration-name
-				   *variable-declarations-with-argument*))
-			  (non-arg-p
-			   (member declaration-name
-				   *variable-declarations-without-argument*))
-			  (dname (list (pop form)))
-			  (inners nil) (outers nil))
-		      (unless (or arg-p non-arg-p)
-			(warn "The declaration ~S is not understood by ~S.~@
-                               Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
-                        (Assuming it is a variable declarations without argument)."
-			      declaration-name 'split-declarations
-			      declaration-name
-			      '*non-variable-declarations*
-			      '*variable-declarations-with-argument*
-			      '*variable-declarations-without-argument*)
-			(push declaration-name
-			      *variable-declarations-without-argument*))
-		      (when arg-p
-			(setq dname (append dname (list (pop form)))))
-		      (dolist (var form)
-			(if (member var args)
-			    (push var outers)
-			    (push var inners)))
-		      (when outers
-			(push `(declare (,@dname ,@outers)) outer-decls))
-		      (when inners
-			(push `(declare (,@dname ,@inners)) inner-decls)))))))
-	  (setq body (cdr body)))
-    (values outer-decls inner-decls body)))
-
-(defun make-method-initargs-form-internal (method-lambda initargs env)
-  (declare (ignore env))
-  (let (method-lambda-args lmf lmf-params)
-    (if (not (and (= 3 (length method-lambda))
-		  (= 2 (length (setq method-lambda-args (cadr method-lambda))))
-		  (consp (setq lmf (third method-lambda)))
-		  (eq 'simple-lexical-method-functions (car lmf))
-		  (eq (car method-lambda-args) (cadr (setq lmf-params (cadr lmf))))
-		  (eq (cadr method-lambda-args) (caddr lmf-params))))
-	`(list* :function #',method-lambda
-	        ',initargs)
-	(let* ((lambda-list (car lmf-params))
-	       (nreq 0)(restp nil)(args nil))
-	  (dolist (arg lambda-list)
-	    (when (member arg '(&optional &rest &key))
-	      (setq restp t)(return nil))
-	    (when (eq arg '&aux) (return nil))
-	    (incf nreq)(push arg args))
-	  (setq args (nreverse args))
-	  (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp))
-	  (make-method-initargs-form-internal1
-	   initargs (cddr lmf) args lmf-params restp)))))
-
-(defun make-method-initargs-form-internal1 
-    (initargs body req-args lmf-params restp)
-  (multiple-value-bind (outer-decls inner-decls body)
-      (split-declarations body req-args)
-    (let* ((rest-arg (when restp '.rest-arg.))
-	   (args+rest-arg (if restp (append req-args (list rest-arg)) req-args)))
-      `(list* :fast-function
-	#'(lambda (.pv-cell. .next-method-call. ,@args+rest-arg)
-	    ,@outer-decls
-	    .pv-cell. .next-method-call.
-	    (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
-				&rest forms)
-			 (declare (ignore pv-table-symbol pv-parameters))
-			 `(let ((,pv (car .pv-cell.))
-				(,calls (cdr .pv-cell.)))
-			   (declare ,(make-pv-type-declaration pv)
-			    ,(make-calls-type-declaration calls))
-			   ,pv ,calls
-			   ,@forms)))
-	      (fast-lexical-method-functions 
-	       (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
-		 ,@(cdddr lmf-params))
-	       ,@inner-decls
-	       ,@body)))
-	',initargs))))
-
-;use arrays and hash tables and the fngen stuff to make this much better.
-;It doesn't really matter, though, because a function returned by this
-;will get called only when the user explicitly funcalls a result of method-function. 
-;BUT, this is needed to make early methods work.
-(defun method-function-from-fast-function (fmf)
-  (declare (type function fmf))
-  (let* ((method-function nil) (pv-table nil)
-	 (arg-info (method-function-get fmf ':arg-info))
-	 (nreq (car arg-info))
-	 (restp (cdr arg-info)))
-    (setq method-function
-	  #'(lambda (method-args next-methods)
-	      (unless pv-table
-		(setq pv-table (method-function-pv-table fmf)))
-	      (let* ((pv-cell (when pv-table
-				(get-method-function-pv-cell 
-				 method-function method-args pv-table)))
-		     (nm (car next-methods))
-		     (nms (cdr next-methods))
-		     (nmc (when nm
-			    (make-method-call :function (if (std-instance-p nm)
-							    (method-function nm)
-							    nm)
-					      :call-method-args (list nms)))))
-		(if restp
-		    (let* ((rest (nthcdr nreq method-args))
-			   (args (ldiff method-args rest)))
-		      (apply fmf pv-cell nmc (nconc args (list rest))))
-		    (apply fmf pv-cell nmc method-args)))))
-    (let* ((fname (method-function-get fmf :name))
-	   (name `(,(or (get (car fname) 'method-sym)
-			(setf (get (car fname) 'method-sym)
-			      (let ((str (symbol-name (car fname))))
-				(if (string= "FAST-" str :end2 5)
-				    (intern (subseq str 5) *the-pcl-package*)
-				    (car fname)))))
-		    ,@(cdr fname))))
-      (set-function-name method-function name))      
-    (setf (method-function-get method-function :fast-function) fmf)
-    method-function))
-
-(defun get-method-function-pv-cell (method-function method-args &optional pv-table)
-  (let ((pv-table (or pv-table (method-function-pv-table method-function))))
-    (when pv-table
-      (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
-	(when pv-wrappers
-	  (pv-table-lookup pv-table pv-wrappers))))))
-
-(defun pv-table-lookup-pv-args (pv-table &rest pv-parameters)
-  (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
-
-(defun pv-wrappers-from-pv-args (&rest args)
-  (let* ((nkeys (length args))
-	 (pv-wrappers (make-list nkeys))
-	 w (w-t pv-wrappers))
-    (dolist (arg args)
-      (setq w (cond ((std-instance-p arg)
-		     (std-instance-wrapper arg))
-		    ((fsc-instance-p arg)
-		     (fsc-instance-wrapper arg))
-		    (t
-		     #+new-kcl-wrapper
-		     (built-in-wrapper-of arg)
-		     #-new-kcl-wrapper
-		     (built-in-or-structure-wrapper arg))))
-      (unless (eq 't (wrapper-state w))
-	(setq w (check-wrapper-validity arg)))
-      (setf (car w-t) w))
-      (setq w-t (cdr w-t))
-      (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
-      pv-wrappers))
-
-(defun pv-wrappers-from-all-args (pv-table args)
-  (let ((nkeys 0)
-	(slot-name-lists (pv-table-slot-name-lists pv-table)))
-    (dolist (sn slot-name-lists)
-      (when sn (incf nkeys)))
-    (let* ((pv-wrappers (make-list nkeys))
-	   (pv-w-t pv-wrappers))
-      (dolist (sn slot-name-lists)
-	(when sn
-	  (let* ((arg (car args))
-		 (w (wrapper-of arg)))
-	    (unless w ; can-optimize-access prevents this from happening.
-	      (error "error in pv-wrappers-from-all-args"))
-	    (setf (car pv-w-t) w)
-	    (setq pv-w-t (cdr pv-w-t))))
-	(setq args (cdr args)))
-      (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
-      pv-wrappers)))
-
-(defun pv-wrappers-from-all-wrappers (pv-table wrappers)
-  (let ((nkeys 0)
-	(slot-name-lists (pv-table-slot-name-lists pv-table)))
-    (dolist (sn slot-name-lists)
-      (when sn (incf nkeys)))
-    (let* ((pv-wrappers (make-list nkeys))
-	   (pv-w-t pv-wrappers))
-      (dolist (sn slot-name-lists)
-	(when sn
-	  (let ((w (car wrappers)))
-	    (unless w ; can-optimize-access prevents this from happening.
-	      (error "error in pv-wrappers-from-all-wrappers"))
-	    (setf (car pv-w-t) w)
-	    (setq pv-w-t (cdr pv-w-t))))
-	(setq wrappers (cdr wrappers)))
-      (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
-      pv-wrappers)))
diff --git a/pcl/walk.lisp b/pcl/walk.lisp
deleted file mode 100644
index 237612395c346941a29bdca898ba80ef2ed8a043..0000000000000000000000000000000000000000
--- a/pcl/walk.lisp
+++ /dev/null
@@ -1,2183 +0,0 @@
-;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;; 
-;;; A simple code walker, based IN PART on: (roll the credits)
-;;;   Larry Masinter's Masterscope
-;;;   Moon's Common Lisp code walker
-;;;   Gary Drescher's code walker
-;;;   Larry Masinter's simple code walker
-;;;   .
-;;;   .
-;;;   boy, thats fair (I hope).
-;;;
-;;; For now at least, this code walker really only does what PCL needs it to
-;;; do.  Maybe it will grow up someday.
-;;;
-
-;;;
-;;; This code walker used to be completely portable.  Now it is just "Real
-;;; easy to port".  This change had to happen because the hack that made it
-;;; completely portable kept breaking in different releases of different
-;;; Common Lisps, and in addition it never worked entirely anyways.  So,
-;;; its now easy to port.  To port this walker, all you have to write is one
-;;; simple macro and two simple functions.  These macros and functions are
-;;; used by the walker to manipluate the macroexpansion environments of
-;;; the Common Lisp it is running in.
-;;;
-;;; The code which implements the macroexpansion environment manipulation
-;;; mechanisms is in the first part of the file, the real walker follows it.
-;;; 
-
-(in-package :walker)
-
-;;;
-;;; The user entry points are walk-form and nested-walked-form.  In addition,
-;;; it is legal for user code to call the variable information functions:
-;;; variable-lexical-p, variable-special-p and variable-class.  Some users
-;;; will need to call define-walker-template, they will have to figure that
-;;; out for themselves.
-;;; 
-(export '(define-walker-template
-	  walk-form
-	  walk-form-expand-macros-p
-	  nested-walk-form
-	  variable-lexical-p
-	  variable-special-p
-	  variable-globally-special-p
-	  *variable-declarations*
-	  variable-declaration
-	  macroexpand-all
-	  ))
-
-
-
-;;;
-;;; On the following pages are implementations of the implementation specific
-;;; environment hacking functions for each of the implementations this walker
-;;; has been ported to.  If you add a new one, so this walker can run in a new
-;;; implementation of Common Lisp, please send the changes back to us so that
-;;; others can also use this walker in that implementation of Common Lisp.
-;;;
-;;; This code just hacks 'macroexpansion environments'.  That is, it is only
-;;; concerned with the function binding of symbols in the environment.  The
-;;; walker needs to be able to tell if the symbol names a lexical macro or
-;;; function, and it needs to be able to build environments which contain
-;;; lexical macro or function bindings.  It must be able, when walking a
-;;; macrolet, flet or labels form to construct an environment which reflects
-;;; the bindings created by that form.  Note that the environment created
-;;; does NOT have to be sufficient to evaluate the body, merely to walk its
-;;; body.  This means that definitions do not have to be supplied for lexical
-;;; functions, only the fact that that function is bound is important.  For
-;;; macros, the macroexpansion function must be supplied.
-;;;
-;;; This code is organized in a way that lets it work in implementations that
-;;; stack cons their environments.  That is reflected in the fact that the
-;;; only operation that lets a user build a new environment is a with-body
-;;; macro which executes its body with the specified symbol bound to the new
-;;; environment.  No code in this walker or in PCL will hold a pointer to
-;;; these environments after the body returns.  Other user code is free to do
-;;; so in implementations where it works, but that code is not considered
-;;; portable.
-;;;
-;;; There are 3 environment hacking tools.  One macro which is used for
-;;; creating new environments, and two functions which are used to access the
-;;; bindings of existing environments.
-;;;
-;;; WITH-AUGMENTED-ENVIRONMENT
-;;;
-;;; ENVIRONMENT-FUNCTION
-;;;
-;;; ENVIRONMENT-MACRO
-;;; 
-
-(defun unbound-lexical-function (&rest args)
-  (declare (ignore args))
-  (error "The evaluator was called to evaluate a form in a macroexpansion~%~
-          environment constructed by the PCL portable code walker.  These~%~
-          environments are only useful for macroexpansion, they cannot be~%~
-          used for evaluation.~%~
-          This error should never occur when using PCL.~%~
-          This most likely source of this error is a program which tries to~%~
-          to use the PCL portable code walker to build its own evaluator."))
-
-
-;;;
-;;; In Coral Common Lisp, the macroexpansion environment is just a list
-;;; of environment entries.  The cadr of each element specifies the type
-;;; of the element.  The only types that interest us are CCL::MACRO and
-;;; FUNCTION.  In these cases the element is interpreted as follows.
-;;;
-;;;   (<function-name> CCL::MACRO . macroexpansion-function)
-;;;   
-;;;   (<function-name> FUNCTION . <fn>)
-;;;   
-;;;   When in the compiler, <fn> is a gensym which will be
-;;;   a variable which bound at run-time to the function.
-;;;   When in the interpreter, <fn> is the actual function.
-;;;   
-;;;
-#+:Coral
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env
-							,functions
-							,macros)))
-     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  (dolist (f functions)
-    (push (list* f 'function (gensym)) env))
-  (dolist (m macros)
-    (push (list* (car m) 'ccl::macro (cadr m)) env))
-  env)
-
-(defun environment-function (env fn)
-  (let ((entry (assoc fn env :test #'equal)))
-    (and entry
-	 (eq (cadr entry) 'function)
-	 (cddr entry))))
-
-(defun environment-macro (env macro)
-  (let ((entry (assoc macro env :test #'equal)))
-    (and entry
-	 (eq (cadr entry) 'ccl::macro)
-	 (cddr entry))))
-
-);#+:Coral
-
-
-;;;
-;;; Franz Common Lisp is a lot like Coral Lisp.  The macroexpansion
-;;; environment is just a list of entries.  The cadr of each element
-;;; specifies the type of the element.  The types that interest us
-;;; are FUNCTION, EXCL::MACRO, and COMPILER::FUNCTION-VALUE.  These
-;;; are interpreted as follows:
-;;;
-;;;   (<function-name> FUNCTION . <a lexical closure>)
-;;;
-;;;      This happens in the interpreter with lexically
-;;;      bound functions.
-;;;
-;;;   (<function-name> COMPILER::FUNCTION-VALUE . <gensym>)
-;;;
-;;;      This happens in the compiler.  The gensym represents
-;;;      a variable which will be bound at run time to the
-;;;      function object.
-;;;
-;;;   (<function-name> EXCL::MACRO . <a lambda>)
-;;;
-;;;      In both interpreter and compiler, this is the
-;;;      representation used for macro definitions.
-;;;   
-;;;
-#+:ExCL
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env
-							,functions
-							,macros)))
-     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  (let (#+allegro-v4.1 (env-tail (cdr env)) #+allegro-v4.1 (env (car env)))
-    (dolist (f functions)
-      (push (list* f 'function #'unbound-lexical-function) env))
-    (dolist (m macros)
-      (push (list* (car m) 'excl::macro (cadr m)) env))
-    #-allegro-v4.1 env #+allegro-v4.1 (cons env env-tail)))
-
-(defun environment-function (env fn)
-  (let* (#+allegro-v4.1 (env (car env))
-	 (entry (assoc fn env :test #'equal)))
-    (and entry
-	 (or (eq (cadr entry) 'function)
-	     (eq (cadr entry) 'compiler::function-value))
-	 (cddr entry))))
-
-(defun environment-macro (env macro)
-  (let* (#+allegro-v4.1 (env (car env))
-	 (entry (assoc macro env :test #'equal)))
-    (and entry
-	 (eq (cadr entry) 'excl::macro)
-	 (cddr entry))))
-
-);#+:ExCL
-
-
-#+Lucid
-(progn
-  
-(proclaim '(inline
-	    %alphalex-p
-	    add-contour-to-env-shape
-	    make-function-variable
-	    make-sfc-contour
-	    sfc-contour-type
-	    sfc-contour-elements
-	    add-sfc-contour
-	    add-function-contour
-	    add-macrolet-contour
-	    find-variable-in-contour
-	    find-alist-element-in-contour
-	    find-macrolet-in-contour))
-
-(defun %alphalex-p (object)
-  #-Prime
-  (eq (cadddr (cddddr object)) 'lucid::%alphalex)
-  #+Prime
-  (eq (caddr (cddddr object)) 'lucid::%alphalex))
-
-#+Prime 
-(defun lucid::augment-lexenv-fvars-dummy (lexical vars)
-  (lucid::augment-lexenv-fvars-aux lexical vars '() '() 'flet '()))
-
-(defconstant function-contour 1)
-(defconstant macrolet-contour 5)
-
-(defstruct lucid::contour
-  type
-  elements)
-
-(defun add-contour-to-env-shape (contour-type elements env-shape)
-  (cons (make-contour :type contour-type
-		      :elements elements)
-	env-shape))
-
-(defstruct (variable (:constructor make-variable (name source-type)))
-  name
-  (identifier nil)
-  source-type)
-
-(defconstant function-sfc-contour 1)
-(defconstant macrolet-sfc-contour 8)
-(defconstant function-variable-type 1)
-
-(defun make-function-variable (name)
-  (make-variable name function-variable-type))
-
-(defun make-sfc-contour (type elements)
-  (cons type elements))
-
-(defun sfc-contour-type (sfc-contour)
-  (car sfc-contour))
-
-(defun sfc-contour-elements (sfc-contour)
-  (cdr sfc-contour))
-
-(defun add-sfc-contour (element-list environment type)
-  (cons (make-sfc-contour type element-list) environment))
-
-(defun add-function-contour (variable-list environment)
-  (add-sfc-contour variable-list environment function-sfc-contour))
-
-(defun add-macrolet-contour (alist environment)
-  (add-sfc-contour alist environment macrolet-sfc-contour))
-
-(defun find-variable-in-contour (name contour)
-  (dolist (element (sfc-contour-elements contour) nil)
-    (when (eq (variable-name element) name)
-      (return element))))
-
-(defun find-alist-element-in-contour (name contour)
-  (cdr (assoc name (sfc-contour-elements contour))))
-
-(defun find-macrolet-in-contour (name contour)
-  (find-alist-element-in-contour name contour))
-
-(defmacro do-sfc-contours ((contour-var environment &optional result)
-			   &body body)
-  `(dolist (,contour-var ,environment ,result) ,@body))
-
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)     
-  `(let* ((,new-env (with-augmented-environment-internal ,old-env
-							 ,functions
-							 ,macros)))
-     ,@body))
-
-;;;
-;;; with-augmented-environment-internal is where the real work of augmenting
-;;; the environment happens.
-;;; 
-(defun with-augmented-environment-internal (env functions macros)
-  (let ((function-names (mapcar #'first functions))
-	(macro-names (mapcar #'first macros))
-	(macro-functions (mapcar #'second macros)))
-    (cond ((or (null env)
-	       (contour-p (first env)))
-	   (when function-names
-	     (setq env (add-contour-to-env-shape function-contour
-						 function-names
-						 env)))
-	   (when macro-names
-	     (setq env (add-contour-to-env-shape macrolet-contour
-						 (pairlis macro-names
-							  macro-functions)
-						 env))))
-	  ((%alphalex-p env)
-	   (when function-names
-	     (setq env (lucid::augment-lexenv-fvars-dummy env function-names)))
-	   (when macro-names
-	     (setq env (lucid::augment-lexenv-mvars env
-						    macro-names
-						    macro-functions))))
-	  (t
-	   (when function-names
-	     (setq env (add-function-contour
-			 (mapcar #'make-function-variable function-names)
-			 env)))
-	   (when macro-names
-	     (setq env (add-macrolet-contour
-			 (pairlis macro-names macro-functions)
-			 env)))))
-    env))
-	 
-
-(defun environment-function (env fn)
-  (cond ((null env) nil)
-	((contour-p (first env))
-	 (if (lucid::find-lexical-function fn env)
-	     t
-	     nil))
-	((%alphalex-p env)
-	 (if (lucid::lexenv-fvar fn env)
-	     t
-	     nil))
-	(t (do-sfc-contours (contour env nil)
-	     (let ((type (sfc-contour-type contour)))
-	       (cond ((eql type function-sfc-contour)
-		      (when (find-variable-in-contour fn contour)
-			(return t)))
-		     ((eql type macrolet-sfc-contour)
-		      (when (find-macrolet-in-contour fn contour)
-			(return nil)))))))))
-		      
-(defun environment-macro (env macro)
-  (cond ((null env) nil)
-	((contour-p (first env))
-	 (lucid::find-lexical-macro macro env))
-	((%alphalex-p env)
-	 (lucid::lexenv-mvar macro env))
-	(t (do-sfc-contours (contour env nil)
-	     (let ((type (sfc-contour-type contour)))
-	       (cond ((eql type function-sfc-contour)
-		      (when (find-variable-in-contour macro contour)
-			(return nil)))
-		     ((eql type macrolet-sfc-contour)
-		      (let ((fn (find-macrolet-in-contour macro contour)))
-			(when fn
-			  (return fn))))))))))
-  
-
-);#+Lucid
-
-
-
-;;;
-;;; On the 3600, the documentation for how the environments are represented
-;;; is in sys:sys;eval.lisp.  That total information is not repeated here.
-;;; The important points are that:
-;;;    si:env-variables returns a list of which each element is:
-;;;
-;;;		(symbol value)
-;;;	     or (symbol . locative)
-;;;
-;;;	The first form is for lexical variables, the second for
-;;;	special and instance variables.  In either case CADR of
-;;;	the entry is the value and SETF of CADR is used to change
-;;;	the value.  Variables are looked up with ASSQ.
-;;;
-;;;    si:env-functions returns a list of which each element is:
-;;;     
-;;;		(symbol definition)
-;;;
-;;;	where definition is anything that could go in a function cell.
-;;;	This is used for both local functions and local macros.
-;;;
-;;; The 3600 stack conses its environments (at least in the interpreter).
-;;; This means that code written using this walker and running on the 3600
-;;; must not hold on to the environment after the walk-function returns.
-;;; No code in this walker or in PCL does that.
-;;;
-#+Genera
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  (let ((funs (make-symbol "FNS"))
-	(macs (make-symbol "MACROS"))
-	(new  (make-symbol "NEW")))
-    `(let ((,funs ,functions)
-	   (,macs ,macros)
-	   (,new ()))
-       (dolist (f ,funs)
-	 (push `(,(car f) ,#'unbound-lexical-function) ,new))
-       (dolist (m ,macs)
-	 (push `(,(car m) (special ,(cadr m))) ,new))
-       (let* ((.old-env. ,old-env)
-	      (.old-vars. (pop .old-env.))
-	      (.old-funs. (pop .old-env.))
-	      (.old-blks. (pop .old-env.))
-	      (.old-tags. (pop .old-env.))
-	      (.old-dcls. (pop .old-env.)))
-	 (si:with-interpreter-environment (,new-env
-					   .old-env.
-					   .old-vars.
-					   (append ,new .old-funs.)
-					   .old-blks.
-					   .old-tags.
-					   .old-dcls.)
-	   ,@body)))))
-  
-
-(defun environment-function (env fn)
-  (if (null env)
-      (values nil nil)
-      (let ((entry (assoc fn (si:env-functions env) :test #'equal)))
-	(if (and entry
-		 (or (not (listp (cadr entry)))
-		     (not (eq (caadr entry) 'special))))
-	    (values (cadr entry) t)
-	    (environment-function (si:env-parent env) fn)))))
-
-(defun environment-macro (env macro)
-  (if (null env)
-      (values nil nil)
-      (let ((entry (assoc macro (si:env-functions env) :test #'equal)))
-	(if (and entry
-		 (listp (cadr entry))
-		 (eq (caadr entry) 'special))
-	    (values (cadadr entry) t)
-	    (environment-macro (si:env-parent env) macro)))))
-
-);#+Genera
-
-#+Cloe-Runtime
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros)))
-     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  functions
-  (dolist (m macros)
-    (setf env `(,(first m) (compiler::macro . ,(second m)) ,@env)))
-  env)
-
-(defun environment-function (env fn)
-  nil)
-
-(defun environment-macro (env macro)
-  (let ((entry (getf env macro)))
-    (if (and (consp entry)
-	     (eq (car entry) 'compiler::macro))
-	(values (cdr entry) t)
-	(values nil nil))))
-
-);#+Cloe-Runtime
-
-
-;;;
-;;; In Xerox Lisp, the compiler and interpreter use different structures for
-;;; the environment.  This doesn't cause a serious problem, the parts of the
-;;; environments we are concerned with are fairly similar.
-;;; 
-#+:Xerox
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)     
-  `(let* ((,new-env (with-augmented-environment-internal ,old-env
-							 ,functions
-							 ,macros)))
-     ,@body))
-
-;;;
-;;; with-augmented-environment-internal is where the real work of augmenting
-;;; the environment happens.  Before it gets there, env had better not be NIL
-;;; anymore because we have to know what kind of environment we are supposed
-;;; to be building up.  This is probably never a real concern in practice.
-;;; It better not be because we don't do anything about it.
-;;; 
-(defun with-augmented-environment-internal (env functions macros)
-  (cond
-     ((compiler::env-p env)
-	(dolist (f functions)
-	   (setq env (compiler::copy-env-with-function
-		       env f :function)))
-	(dolist (m macros)
-	   (setq env (compiler::copy-env-with-function
-	 	  env (car m) :macro (cadr m)))))
-     (t (setq env (if (il:environment-p env)
-		    (il:\\copy-environment env)
-		    (il:\\make-environment)))
-	;; The functions field of the environment is a plist of function names
-	;; and conses like (:function . fn) or (:macro . expansion-fn).
-	;; Note that we can't smash existing entries in this plist since these
-	;; are likely shared with older environments.
-	(dolist (f functions)
-	  (setf (il:environment-functions env)
-		(list* f (cons :function #'unbound-lexical-function)
-		       (il:environment-functions env))))
-	(dolist (m macros)
-	  (setf (il:environment-functions env)
-		(list* (car m) (cons :macro (cadr m))
-		       (il:environment-functions env))))))
-  env)
-
-(defun environment-function (env fn)
-  (cond ((compiler::env-p env) (eq (compiler:env-fboundp env fn) :function))
-	((il:environment-p env) (eq (getf (il:environment-functions env) fn)
-				    :function))
-	(t nil)))
-
-(defun environment-macro (env macro) 
-  (cond ((compiler::env-p env)
-	 (multiple-value-bind (type def)
-	     (compiler:env-fboundp env macro)
-	   (when (eq type :macro) def)))
-	((il:environment-p env)
-	 (xcl:destructuring-bind (type . def)
-	     (getf (il:environment-functions env) macro)
-	   (when (eq type :macro) def)))
-	(t nil)))
-
-);#+:Xerox
-
-
-;;;
-;;; In IBUKI Common Lisp, the macroexpansion environment is a three element
-;;; list.  The second element describes lexical functions and macros.  The 
-;;; function entries in this list have the form 
-;;;     (<name> . (FUNCTION . (<function-value> . nil))
-;;; The macro entries have the form 
-;;;     (<name> . (MACRO . (<macro-value> . nil)).
-;;;
-;;;
-#+(or KCL IBCL)
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-	  `(let ((,new-env (with-augmented-environment-internal ,old-env
-								,functions
-								,macros)))
-	     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  (let ((first (first env))
-	(lexicals (second env))
-	(third (third env)))
-    (dolist (f functions)
-      (push `(,(car f) .  (function  . (,#'unbound-lexical-function . nil)))
-	    lexicals))
-    (dolist (m macros)
-      (push `(,(car m)  .  (macro . ( ,(cadr m) . nil))) 
-	    lexicals))
-    (list first lexicals third)))
-
-(defun environment-function (env fn)
-  (when env
-	(let ((entry (assoc fn (second env))))
-	  (and entry
-	       (eq (cadr entry) 'function)
-	       (caddr entry)))))
-
-(defun environment-macro (env macro)
-  (when env
-	(let ((entry (assoc macro (second env))))
-	  (and entry
-	       (eq (cadr entry) 'macro)
-	       (caddr entry)))))
-);#+(or KCL IBCL)
-
-
-;;;   --- TI Explorer --
-
-;;; An environment is a two element list, whose car we can ignore and
-;;; whose cadr is list of the local-definitions-frames. Each
-;;; local-definitions-frame holds either macros or functions, but not
-;;; both.  Each frame is a plist of <name> <def> <name> <def> ...  where
-;;; <name> is a locative to the function cell of the symbol that names
-;;; the function or macro, and <def> is the new def or NIL if this is function
-;;; redefinition or (cons 'ticl:macro <macro-expansion-function>) if this is a macro
-;;; redefinition.
-;;;
-;;; Here's an example.  For the form:
-;;; (defun foo ()
-;;;   (macrolet ((bar (a b) (list a b))
-;;;	         (bar2 (a b) (list a b)))
-;;;     (flet ((some-local-fn (c d) (print (list c d)))
-;;;	       (another (c d) (print (list c d))))
-;;;       (bar (some-local-fn 1 2) 3))))
-
-;;; the environment arg to macroexpand-1 when called on
-;;; (bar (some-local-fn 1 2) 3)
-;;;is 
-;;;(NIL ((#<DTP-LOCATIVE 4710602> NIL
-;;;       #<DTP-LOCATIVE 4710671> NIL)
-;;;      (#<DTP-LOCATIVE 7346562>
-;;;       (TICL:MACRO TICL:NAMED-LAMBDA (BAR (:DESCRIPTIVE-ARGLIST (A B)))
-;;;		   (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*)
-;;;		   (BLOCK BAR ....))
-;;;       #<DTP-LOCATIVE 4710664>
-;;;       (TICL:MACRO TICL:NAMED-LAMBDA (BAR2 (:DESCRIPTIVE-ARGLIST (A B)))
-;;;		   (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*)
-;;;		   (BLOCK BAR2 ....))))
-#+TI
-(progn 
-
-;;; from sys:site;macros.lisp
-(eval-when (compile load eval)
-  
-(DEFMACRO MACRO-DEF? (thing)
-  `(AND (CONSP ,thing) (EQ (CAR ,thing) 'TICL::MACRO)))
-
-;; the following macro generates code to check the 'local' environment
-;; for a macro definition for THE SYMBOL <name>. Such a definition would
-;; be set up only by a MACROLET. If a macro definition for <name> is
-;; found, its expander function is returned.
-
-(DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment)
-  `(IF ,local-function-environment
-       (LET ((vcell (ticl::LOCF (SYMBOL-FUNCTION ,name))))
-	 (DOLIST (frame  ,local-function-environment)
-	   ;; <value> is nil or a locative
-	   (LET ((value (sys::GET-LOCATION-OR-NIL (ticl::LOCF frame)
-						  vcell))) 
-	     (When value (RETURN (CAR value))))))
-       nil)))
-
- 
-;;;Edited by Reed Hastings         13 Jan 88  16:29
-(defun environment-macro (env macro)
-  "returns what macro-function would, ie. the expansion function"
-  ;;some code picked off macroexpand-1
-  (let* ((local-definitions (cadr env))
-	 (local-def (find-local-definition macro local-definitions)))
-    (if (macro-def? local-def)
-	(cdr local-def))))
-
-;;;Edited by Reed Hastings         13 Jan 88  16:29
-;;;Edited by Reed Hastings         7 Mar 88  19:07
-(defun environment-function (env fn)
-  (let* ((local-definitions (cadr env)))
-    (dolist (frame local-definitions)
-      (let ((val (getf frame
-		       (ticl::locf (symbol-function fn))
-		       :not-found-marker)))
-	(cond ((eq val :not-found-marker))
-	      ((functionp val) (return t))
-	      ((and (listp val)
-		    (eq (car val) 'ticl::macro))
-	       (return nil))
-	      (t
-	       (error "we are confused")))))))
-	     
-
-;;;Edited by Reed Hastings         13 Jan 88  16:29
-;;;Edited by Reed Hastings         7 Mar 88  19:07
-(defun with-augmented-environment-internal (env functions macros)
-  (let ((local-definitions (cadr env))
-	(new-local-fns-frame
-	  (mapcan #'(lambda (fn)
-		      (list (ticl:locf (symbol-function (car fn)))
-			    #'unbound-lexical-function))
-		  functions))
-	 (new-local-macros-frame
-	   (mapcan #'(lambda (m)
-		       (list (ticl:locf (symbol-function (car m))) (cons 'ticl::macro (cadr m))))
-		   macros)))
-    (when new-local-fns-frame 
-      (push new-local-fns-frame local-definitions))
-    (when new-local-macros-frame
-      (push new-local-macros-frame local-definitions))   
-    `(,(car env) ,local-definitions)))
-
-
-;;;Edited by Reed Hastings         7 Mar 88  19:07
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env
-							,functions
-							,macros)))
-     ,@body))
-
-);#+TI
-
-
-#+(and dec vax common)
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env
-							,functions
-							,macros)))
-     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  #'(lambda (op &optional (arg nil arg-p))
-      (cond ((eq op :macro-function) 
-	     (unless arg-p (error "Invalid environment use."))
-	     (lookup-macro-function arg env functions macros))
-            (arg-p
-	     (error "Invalid environment operation: ~S ~S" op arg))
-            (t
-	     (lookup-macro-function op env functions macros)))))
-
-(defun lookup-macro-function (name env fns macros)
-  (let ((m (assoc name macros)))
-    (cond (m                (cadr m))
-          ((assoc name fns) :function)
-          (env              (funcall env name))
-          (t                nil))))
-
-(defun environment-macro (env macro)
-  (let ((m (and env (funcall env macro))))
-    (and (not (eq m :function)) 
-         m)))
-
-;;; Nobody calls environment-function.  What would it return, anyway?
-);#+(and dec vax common)
-
-
-;;;
-;;; In Golden Common Lisp, the macroexpansion environment is just a list
-;;; of environment entries.  Unless the car of the list is :compiler-menv 
-;;; it is an interpreted environment.  The cadr of each element specifies 
-;;; the type of the element.  The only types that interest us are GCL:MACRO
-;;; and FUNCTION.  In these cases the element is interpreted as follows.
-;;;
-;;; Compiled:
-;;;   (<function-name> <gensym> macroexpansion-function)
-;;;   (<function-name> <fn>)
-;;;   
-;;; Interpreted:
-;;;   (<function-name> GCL:MACRO macroexpansion-function)
-;;;   (<function-name> <fn>)
-;;;   
-;;;   When in the compiler, <fn> is a gensym which will be
-;;;   a variable which bound at run-time to the function.
-;;;   When in the interpreter, <fn> is the actual function.
-;;;   
-;;;
-#+gclisp
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env
-							,functions
-							,macros)))
-     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  (let ((new-entries nil))
-    (dolist (f functions)
-      (push (cons (car f) nil) new-entries))
-    (dolist (m macros)
-      (push (cons (car m)
-		  (if (eq :compiler-menv (car env))
-		      (if (eq (caadr m) 'lisp::lambda)
-			  `(,(gensym) ,(cadr m))
-			`(,(gensym) ,@(cadr m)))
-		    `(gclisp:MACRO ,@(cadr m))))
-	      new-entries))
-    (if (eq :compiler-menv (car env))
-	`(:compiler-menv ,@new-entries ,@(cdr env))
-      (append new-entries env))))
-
-(defun environment-function (env fn)
-  (let ((entry (lisp::lexical-function fn env)))
-    (and entry 
-	 (eq entry 'lisp::lexical-function)
-	 fn)))
-
-(defun environment-macro (env macro)
-  (let ((entry (assoc macro (if (eq :compiler-menv (first env))
-				 (rest env)
-			       env))))
-    (and entry
-	 (consp entry)
-	 (symbolp (car entry))			;name
-	 (symbolp (cadr entry))			;gcl:macro or gensym
-	 (nthcdr 2 entry))))
-
-);#+gclisp
-
-
-;;;; CMU Common Lisp version of environment frobbing stuff.
-
-;;; In CMU Common Lisp, the environment is represented with a structure
-;;; that holds alists for the functional things, variables, blocks, etc.
-;;; Only the c::lexenv-functions slot is relevent.  It holds:
-;;; Alist (name . what), where What is either a Functional (a local function)
-;;; or a list (MACRO . <function>) (a local macro, with the specifier
-;;; expander.)    Note that Name may be a (SETF <name>) function.
-
-#+:CMU
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env
-							,functions
-							,macros)))
-     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  ;; Note: In order to record the correct function definition, we would
-  ;; have to create an interpreted closure, but the with-new-definition
-  ;; macro down below makes no distinction between flet and labels, so
-  ;; we have no idea what to use for the environment.  So we just blow it
-  ;; off, 'cause anything real we do would be wrong.  We still have to
-  ;; make an entry so we can tell functions from macros.
-  (let ((env (or env (c::make-null-environment))))
-    (c::make-lexenv 
-      :default env
-      :functions
-      (append (mapcar #'(lambda (f)
-			  (cons (car f) (c::make-functional :lexenv env)))
-		      functions)
-	      (mapcar #'(lambda (m)
-			  (list* (car m) 'c::macro
-				 (coerce (cadr m) 'function)))
-		      macros)))))
-
-(defun environment-function (env fn)
-  (when env
-    (let ((entry (assoc fn (c::lexenv-functions env) :test #'equal)))
-      (and entry
-	   (c::functional-p (cdr entry))
-	   (cdr entry)))))
-
-(defun environment-macro (env macro)
-  (when env
-    (let ((entry (assoc macro (c::lexenv-functions env) :test #'eq)))
-      (and entry 
-	   (eq (cadr entry) 'c::macro)
-	   (function-lambda-expression (cddr entry))))))
-
-); end of #+:CMU
-
-
-
-(defmacro with-new-definition-in-environment
-	  ((new-env old-env macrolet/flet/labels-form) &body body)
-  (let ((functions (make-symbol "Functions"))
-	(macros (make-symbol "Macros")))
-    `(let ((,functions ())
-	   (,macros ()))
-       (ecase (car ,macrolet/flet/labels-form)
-	 ((flet labels)
-	  (dolist (fn (cadr ,macrolet/flet/labels-form))
-	    (push fn ,functions)))
-	 ((macrolet)
-	  (dolist (mac (cadr ,macrolet/flet/labels-form))
-	    (push (list (car mac)
-			(convert-macro-to-lambda (cadr mac)
-						 (cddr mac)
-						 (string (car mac))))
-		  ,macros))))
-       (with-augmented-environment
-	      (,new-env ,old-env :functions ,functions :macros ,macros)
-	 ,@body))))
-
-#-Genera
-(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro"))
-  (let ((gensym (make-symbol name)))
-    (eval `(defmacro ,gensym ,llist ,@body))
-    (macro-function gensym)))
-
-#+Genera
-(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro"))
-  (si:defmacro-1
-    'sys:named-lambda 'sys:special (make-symbol name) llist body))
-
-
-
-
-
-;;;
-;;; Now comes the real walker.
-;;;
-;;; As the walker walks over the code, it communicates information to itself
-;;; about the walk.  This information includes the walk function, variable
-;;; bindings, declarations in effect etc.  This information is inherently
-;;; lexical, so the walker passes it around in the actual environment the
-;;; walker passes to macroexpansion functions.  This is what makes the
-;;; nested-walk-form facility work properly.
-;;;
-(defmacro walker-environment-bind ((var env &rest key-args)
-				      &body body)
-  `(with-augmented-environment
-     (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args))
-     .,body))
-
-(defvar *key-to-walker-environment* (gensym))
-
-(defun env-lock (env)
-  (environment-macro env *key-to-walker-environment*))
-
-(defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
-					   (walk-form nil wfop)
-					   (declarations nil decp)
-					   (lexical-variables nil lexp))
-  (let ((lock (environment-macro env *key-to-walker-environment*)))
-    (list
-      (list *key-to-walker-environment*
-	    (list (if wfnp walk-function     (car lock))
-		  (if wfop walk-form         (cadr lock))
-		  (if decp declarations      (caddr lock))
-		  (if lexp lexical-variables (cadddr lock)))))))
-		  
-(defun env-walk-function (env)
-  (car (env-lock env)))
-
-(defun env-walk-form (env)
-  (cadr (env-lock env)))
-
-(defun env-declarations (env)
-  (caddr (env-lock env)))
-
-(defun env-lexical-variables (env)
-  (cadddr (env-lock env)))
-
-
-(defun note-declaration (declaration env)
-  (push declaration (caddr (env-lock env))))
-
-(defun note-lexical-binding (thing env)
-  (push (list thing :lexical-var) (cadddr (env-lock env))))
-
-
-(defun VARIABLE-LEXICAL-P (var env)
-  (let ((entry (member var (env-lexical-variables env) :key #'car)))
-    (when (eq (cadar entry) :lexical-var)
-      entry)))
-
-(defun variable-symbol-macro-p (var env)
-  (let ((entry (member var (env-lexical-variables env) :key #'car)))
-    (when (eq (cadar entry) :macro)
-      entry)))
-
-
-(defvar *VARIABLE-DECLARATIONS* '(special))
-
-(defun VARIABLE-DECLARATION (declaration var env)
-  (if (not (member declaration *variable-declarations*))
-      (error "~S is not a recognized variable declaration." declaration)
-      (let ((id (or (variable-lexical-p var env) var)))
-	(dolist (decl (env-declarations env))
-	  (when (and (eq (car decl) declaration)
-		     (eq (cadr decl) id))
-	    (return decl))))))
-
-(defun VARIABLE-SPECIAL-P (var env)
-  (or (not (null (variable-declaration 'special var env)))
-      (variable-globally-special-p var)))
-
-;;;
-;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been
-;;; declared globally special.  Any particular CommonLisp implementation
-;;; should customize this function accordingly and send their customization
-;;; back.
-;;;
-;;; The default version of variable-globally-special-p is probably pretty
-;;; slow, so it uses *globally-special-variables* as a cache to remember
-;;; variables that it has already figured out are globally special.
-;;;
-;;; This would need to be reworked if an unspecial declaration got added to
-;;; Common Lisp.
-;;;
-;;; Common Lisp nit:
-;;;   variable-globally-special-p should be defined in Common Lisp.
-;;;
-#-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
-      GCLisp TI pyramid)
-(defvar *globally-special-variables* ())
-
-(defun variable-globally-special-p (symbol)
-  #+Genera                      (si:special-variable-p symbol)
-  #+Cloe-Runtime		(compiler::specialp symbol)
-  #+Lucid                       (lucid::proclaimed-special-p symbol)
-  #+TI                          (get symbol 'special)
-  #+Xerox                       (il:variable-globally-special-p symbol)
-  #+(and dec vax common)        (get symbol 'system::globally-special)
-  #+(or KCL IBCL)               (si:specialp symbol)
-  #+excl                        (get symbol 'excl::.globally-special.)
-  #+:CMU			(eq (ext:info variable kind symbol) :special)
-  #+HP-HPLabs                   (member (get symbol 'impl:vartype)
-					'(impl:fluid impl:global)
-					:test #'eq)
-  #+:GCLISP                     (gclisp::special-p symbol)
-  #+pyramid			(or (get symbol 'lisp::globally-special)
-				    (get symbol
-					 'clc::globally-special-in-compiler))
-  #+:CORAL                      (ccl::proclaimed-special-p symbol)
-  #-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
-	GCLisp TI pyramid :CORAL)
-  (or (not (null (member symbol *globally-special-variables* :test #'eq)))
-      (when (eval `(flet ((ref () ,symbol))
-		     (let ((,symbol '#,(list nil)))
-		       (and (boundp ',symbol) (eq ,symbol (ref))))))
-	(push symbol *globally-special-variables*)
-	t)))
-
-
-  ;;   
-;;;;;; Handling of special forms (the infamous 24).
-  ;;
-;;;
-;;; and I quote...
-;;; 
-;;;     The set of special forms is purposely kept very small because
-;;;     any program analyzing program (read code walker) must have
-;;;     special knowledge about every type of special form. Such a
-;;;     program needs no special knowledge about macros...
-;;;
-;;; So all we have to do here is a define a way to store and retrieve
-;;; templates which describe how to walk the 24 special forms and we are all
-;;; set...
-;;;
-;;; Well, its a nice concept, and I have to admit to being naive enough that
-;;; I believed it for a while, but not everyone takes having only 24 special
-;;; forms as seriously as might be nice.  There are (at least) 3 ways to
-;;; lose:
-;;
-;;;   1 - Implementation x implements a Common Lisp special form as a macro
-;;;       which expands into a special form which:
-;;;         - Is a common lisp special form (not likely)
-;;;         - Is not a common lisp special form (on the 3600 IF --> COND).
-;;;
-;;;     * We can safe ourselves from this case (second subcase really) by
-;;;       checking to see if there is a template defined for something
-;;;       before we check to see if we we can macroexpand it.
-;;;
-;;;   2 - Implementation x implements a Common Lisp macro as a special form.
-;;;
-;;;     * This is a screw, but not so bad, we save ourselves from it by
-;;;       defining extra templates for the macros which are *likely* to
-;;;       be implemented as special forms.  (DO, DO* ...)
-;;;
-;;;   3 - Implementation x has a special form which is not on the list of
-;;;       Common Lisp special forms.
-;;;
-;;;     * This is a bad sort of a screw and happens more than I would like
-;;;       to think, especially in the implementations which provide more
-;;;       than just Common Lisp (3600, Xerox etc.).
-;;;       The fix is not terribly staisfactory, but will have to do for
-;;;       now.  There is a hook in get walker-template which can get a
-;;;       template from the implementation's own walker.  That template
-;;;       has to be converted, and so it may be that the right way to do
-;;;       this would actually be for that implementation to provide an
-;;;       interface to its walker which looks like the interface to this
-;;;       walker.
-;;;
-
-(eval-when (compile load eval)
-
-(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because
-  `(get ,x 'walker-template))		   ;Golden Common Lisp doesn't hack
-					   ;compile time definition of macros
-					   ;right for setf.
-
-(defmacro define-walker-template
-	  (name &optional (template '(nil repeat (eval))))
-  `(eval-when (load eval)
-     (setf (get-walker-template-internal ',name) ',template)))
-)
-
-(defun get-walker-template (x)
-  (cond ((symbolp x)
-	 (or (get-walker-template-internal x)
-	     (get-implementation-dependent-walker-template x)))
-	((and (listp x) (eq (car x) 'lambda))
-	 '(lambda repeat (eval)))
-	(t
-	 (error "Can't get template for ~S" x))))
-
-(defun get-implementation-dependent-walker-template (x)
-  (declare (ignore x))
-  ())
-
-
-  ;;   
-;;;;;; The actual templates
-  ;;   
-
-(define-walker-template BLOCK                (NIL NIL REPEAT (EVAL)))
-(define-walker-template CATCH                (NIL EVAL REPEAT (EVAL)))
-(define-walker-template COMPILER-LET         walk-compiler-let)
-(define-walker-template DECLARE              walk-unexpected-declare)
-(define-walker-template EVAL-WHEN            (NIL QUOTE REPEAT (EVAL)))
-(define-walker-template FLET                 walk-flet)
-(define-walker-template FUNCTION             (NIL CALL))
-(define-walker-template GO                   (NIL QUOTE))
-(define-walker-template IF                   walk-if)
-(define-walker-template LABELS               walk-labels)
-(define-walker-template LAMBDA               walk-lambda)
-(define-walker-template LET                  walk-let)
-(define-walker-template LET*                 walk-let*)
-(define-walker-template LOCALLY              walk-locally)
-(define-walker-template MACROLET             walk-macrolet)
-(define-walker-template MULTIPLE-VALUE-CALL  (NIL EVAL REPEAT (EVAL)))
-(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL)))
-(define-walker-template MULTIPLE-VALUE-SETQ  walk-multiple-value-setq)
-(define-walker-template MULTIPLE-VALUE-BIND  walk-multiple-value-bind)
-(define-walker-template PROGN                (NIL REPEAT (EVAL)))
-(define-walker-template PROGV                (NIL EVAL EVAL REPEAT (EVAL)))
-(define-walker-template QUOTE                (NIL QUOTE))
-(define-walker-template RETURN-FROM          (NIL QUOTE REPEAT (RETURN)))
-(define-walker-template SETQ                 walk-setq)
-(define-walker-template SYMBOL-MACROLET      walk-symbol-macrolet)
-(define-walker-template TAGBODY              walk-tagbody)
-(define-walker-template THE                  (NIL QUOTE EVAL))
-#+cmu(define-walker-template EXT:TRULY-THE   (NIL QUOTE EVAL))
-(define-walker-template THROW                (NIL EVAL EVAL))
-(define-walker-template UNWIND-PROTECT       (NIL RETURN REPEAT (EVAL)))
-
-;;; The new special form.
-;(define-walker-template pcl::LOAD-TIME-EVAL       (NIL EVAL))
-
-;;;
-;;; And the extra templates...
-;;;
-(define-walker-template DO      walk-do)
-(define-walker-template DO*     walk-do*)
-(define-walker-template PROG    walk-prog)
-(define-walker-template PROG*   walk-prog*)
-(define-walker-template COND    (NIL REPEAT ((TEST REPEAT (EVAL)))))
-
-#+Genera
-(progn
-  (define-walker-template zl::named-lambda walk-named-lambda)
-  (define-walker-template SCL:LETF walk-let)
-  (define-walker-template SCL:LETF* walk-let*)
-  )
-
-#+Lucid
-(progn
-  (define-walker-template #+LCL3.0 lucid-common-lisp:named-lambda
-			  #-LCL3.0 sys:named-lambda walk-named-lambda)
-  )
-
-#+(or KCL IBCL)
-(progn
-  (define-walker-template lambda-block walk-named-lambda);Not really right,
-							 ;we don't hack block
-						         ;names anyways.
-  )
-
-#+TI
-(progn
-  (define-walker-template TICL::LET-IF walk-let-if)
-  )
-
-#+:Coral
-(progn
-  (define-walker-template ccl:%stack-block walk-let)
-  )
-
-
-
-(defvar walk-form-expand-macros-p nil)
-
-(defun macroexpand-all (form &optional environment)
-  (let ((walk-form-expand-macros-p t))
-    (walk-form form environment)))
-
-(defun WALK-FORM (form
-		  &optional environment
-			    (walk-function
-			      #'(lambda (subform context env)
-				  (declare (ignore context env))
-				  subform)))
-  (walker-environment-bind (new-env environment :walk-function walk-function)
-    (walk-form-internal form :eval new-env)))
-
-;;;
-;;; nested-walk-form provides an interface that allows nested macros, each
-;;; of which must walk their body to just do one walk of the body of the
-;;; inner macro.  That inner walk is done with a walk function which is the
-;;; composition of the two walk functions.
-;;;
-;;; This facility works by having the walker annotate the environment that
-;;; it passes to macroexpand-1 to know which form is being macroexpanded.
-;;; If then the &whole argument to the macroexpansion function is eq to
-;;; the env-walk-form of the environment, nested-walk-form can be certain
-;;; that there are no intervening layers and that a nested walk is alright.
-;;;
-;;; There are some semantic problems with this facility.  In particular, if
-;;; the outer walk function returns T as its walk-no-more-p value, this will
-;;; prevent the inner walk function from getting a chance to walk the subforms
-;;; of the form.  This is almost never what you want, since it destroys the
-;;; equivalence between this nested-walk-form function and two seperate
-;;; walk-forms.
-;;;
-(defun NESTED-WALK-FORM (whole
-			 form
-			 &optional environment
-				   (walk-function
-				     #'(lambda (subform context env)
-					 (declare (ignore context env))
-					 subform)))
-  (if (eq whole (env-walk-form environment))
-      (let ((outer-walk-function (env-walk-function environment)))
-	(throw whole
-	  (walk-form
-	    form
-	    environment
-	    #'(lambda (f c e)
-		;; First loop to make sure the inner walk function
-		;; has done all it wants to do with this form.
-		;; Basically, what we are doing here is providing
-		;; the same contract walk-form-internal normally
-		;; provides to the inner walk function.
-		(let ((inner-result nil)
-		      (inner-no-more-p nil)
-		      (outer-result nil)
-		      (outer-no-more-p nil))
-		  (loop
-		    (multiple-value-setq (inner-result inner-no-more-p)
-					 (funcall walk-function f c e))
-		    (cond (inner-no-more-p (return))
-			  ((not (eq inner-result f)))
-			  ((not (consp inner-result)) (return))
-			  ((get-walker-template (car inner-result)) (return))
-			  (t
-			   (multiple-value-bind (expansion macrop)
-			       (walker-environment-bind
-				     (new-env e :walk-form inner-result)
-				 (macroexpand-1 inner-result new-env))
-			     (if macrop
-				 (setq inner-result expansion)
-				 (return)))))
-		    (setq f inner-result))
-		  (multiple-value-setq (outer-result outer-no-more-p)
-				       (funcall outer-walk-function
-						inner-result
-						c
-						e))
-		  (values outer-result
-			  (and inner-no-more-p outer-no-more-p)))))))
-      (walk-form form environment walk-function)))
-
-;;;
-;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It
-;;; takes a form and the current context and walks the form calling itself or
-;;; the appropriate template recursively.
-;;;
-;;;   "It is recommended that a program-analyzing-program process a form
-;;;    that is a list whose car is a symbol as follows:
-;;;
-;;;     1. If the program has particular knowledge about the symbol,
-;;;        process the form using special-purpose code.  All of the
-;;;        standard special forms should fall into this category.
-;;;     2. Otherwise, if macro-function is true of the symbol apply
-;;;        either macroexpand or macroexpand-1 and start over.
-;;;     3. Otherwise, assume it is a function call. "
-;;;     
-
-(defun walk-form-internal (form context env)
-  ;; First apply the walk-function to perform whatever translation
-  ;; the user wants to this form.  If the second value returned
-  ;; by walk-function is T then we don't recurse...
-  (catch form
-    (multiple-value-bind (newform walk-no-more-p)
-      (funcall (env-walk-function env) form context env)
-      (catch newform
-	(cond
-	 (walk-no-more-p newform)
-	 ((not (eq form newform))
-	  (walk-form-internal newform context env))
-	 ((not (consp newform))
-	  (let ((symmac (car (variable-symbol-macro-p newform env))))
-	    (if symmac
-		(let ((newnewform (walk-form-internal (cddr symmac)
-						      context env)))
-		  (if (eq newnewform (cddr symmac))
-		      (if walk-form-expand-macros-p newnewform newform)
-		      newnewform))
-		newform)))
-	 (t
-	  (let* ((fn (car newform))
-		 (template (get-walker-template fn)))
-	    (if template
-		(if (symbolp template)
-		    (funcall template newform context env)
-		    (walk-template newform template context env))
-		(multiple-value-bind
-		    (newnewform macrop)
-		    (walker-environment-bind
-			(new-env env :walk-form newform)
-		      (macroexpand-1 newform new-env))
-		  (cond
-		   (macrop
-		    (let ((newnewnewform (walk-form-internal newnewform context
-							     env)))
-		      (if (eq newnewnewform newnewform)
-			  (if walk-form-expand-macros-p newnewform newform)
-			  newnewnewform)))
-		   ((and (symbolp fn)
-			 (not (fboundp fn))
-			 (special-form-p fn))
-		    (error
-		     "~S is a special form, not defined in the CommonLisp.~%~
-		      manual This code walker doesn't know how to walk it.~%~
-		      Define a template for this special form and try again."
-		     fn))
-		   (t
-		    ;; Otherwise, walk the form as if its just a standard 
-		    ;; functioncall using a template for standard function
-		    ;; call.
-		    (walk-template
-		     newnewform '(call repeat (eval)) context env))))))))))))
-
-(defun walk-template (form template context env)
-  (if (atom template)
-      (ecase template
-        ((EVAL FUNCTION TEST EFFECT RETURN)
-         (walk-form-internal form :EVAL env))
-        ((QUOTE NIL) form)
-        (SET
-          (walk-form-internal form :SET env))
-        ((LAMBDA CALL)
-	 (cond ((or (symbolp form)
-		    (and (listp form)
-			 (= (length form) 2)
-			 (eq (car form) 'setf)))
-		form)
-	       #+Lispm
-	       ((sys:validate-function-spec form) form)
-	       (t (walk-form-internal form context env)))))
-      (case (car template)
-        (REPEAT
-          (walk-template-handle-repeat form
-                                       (cdr template)
-				       ;; For the case where nothing happens
-				       ;; after the repeat optimize out the
-				       ;; call to length.
-				       (if (null (cddr template))
-					   ()
-					   (nthcdr (- (length form)
-						      (length
-							(cddr template)))
-						   form))
-                                       context
-				       env))
-        (IF
-	  (walk-template form
-			 (if (if (listp (cadr template))
-				 (eval (cadr template))
-				 (funcall (cadr template) form))
-			     (caddr template)
-			     (cadddr template))
-			 context
-			 env))
-        (REMOTE
-          (walk-template form (cadr template) context env))
-        (otherwise
-          (cond ((atom form) form)
-                (t (recons form
-                           (walk-template
-			     (car form) (car template) context env)
-                           (walk-template
-			     (cdr form) (cdr template) context env))))))))
-
-(defun walk-template-handle-repeat (form template stop-form context env)
-  (if (eq form stop-form)
-      (walk-template form (cdr template) context env)
-      (walk-template-handle-repeat-1 form
-				     template
-				     (car template)
-				     stop-form
-				     context
-				     env)))
-
-(defun walk-template-handle-repeat-1 (form template repeat-template
-					   stop-form context env)
-  (cond ((null form) ())
-        ((eq form stop-form)
-         (if (null repeat-template)
-             (walk-template stop-form (cdr template) context env)       
-             (error "While handling repeat:
-                     ~%~Ran into stop while still in repeat template.")))
-        ((null repeat-template)
-         (walk-template-handle-repeat-1
-	   form template (car template) stop-form context env))
-        (t
-         (recons form
-                 (walk-template (car form) (car repeat-template) context env)
-                 (walk-template-handle-repeat-1 (cdr form)
-						template
-						(cdr repeat-template)
-						stop-form
-						context
-						env)))))
-
-(defun walk-repeat-eval (form env)
-  (and form
-       (recons form
-	       (walk-form-internal (car form) :eval env)
-	       (walk-repeat-eval (cdr form) env))))
-
-(defun recons (x car cdr)
-  (if (or (not (eq (car x) car))
-          (not (eq (cdr x) cdr)))
-      (cons car cdr)
-      x))
-
-(defun relist (x &rest args)
-  (if (null args)
-      nil
-      (relist-internal x args nil)))
-
-(defun relist* (x &rest args)
-  (relist-internal x args 't))
-
-(defun relist-internal (x args *p)
-  (if (null (cdr args))
-      (if *p
-	  (car args)
-	  (recons x (car args) nil))
-      (recons x
-	      (car args)
-	      (relist-internal (cdr x) (cdr args) *p))))
-
-
-  ;;   
-;;;;;; Special walkers
-  ;;
-
-(defun walk-declarations (body fn env
-			       &optional doc-string-p declarations old-body
-			       &aux (form (car body)) macrop new-form)
-  (cond ((and (stringp form)			;might be a doc string
-              (cdr body)			;isn't the returned value
-              (null doc-string-p)		;no doc string yet
-              (null declarations))		;no declarations yet
-         (recons body
-                 form
-                 (walk-declarations (cdr body) fn env t)))
-        ((and (listp form) (eq (car form) 'declare))
-         ;; Got ourselves a real live declaration.  Record it, look for more.
-         (dolist (declaration (cdr form))
-	   (let ((type (car declaration))
-		 (name (cadr declaration))
-		 (args (cddr declaration)))
-	     (if (member type *variable-declarations*)
-		 (note-declaration `(,type
-				     ,(or (variable-lexical-p name env) name)
-				     ,.args)
-				   env)
-		 (note-declaration declaration env))
-	     (push declaration declarations)))
-         (recons body
-                 form
-                 (walk-declarations
-		   (cdr body) fn env doc-string-p declarations)))
-        ((and form
-	      (listp form)
-	      (null (get-walker-template (car form)))
-	      (progn
-		(multiple-value-setq (new-form macrop)
-				     (macroexpand-1 form env))
-		macrop))
-	 ;; This form was a call to a macro.  Maybe it expanded
-	 ;; into a declare?  Recurse to find out.
-	 (walk-declarations (recons body new-form (cdr body))
-			    fn env doc-string-p declarations
-			    (or old-body body)))
-	(t
-	 ;; Now that we have walked and recorded the declarations,
-	 ;; call the function our caller provided to expand the body.
-	 ;; We call that function rather than passing the real-body
-	 ;; back, because we are RECONSING up the new body.
-	 (funcall fn (or old-body body) env))))
-
-
-(defun walk-unexpected-declare (form context env)
-  (declare (ignore context env))
-  (warn "Encountered declare ~S in a place where a declare was not expected."
-	form)
-  form)
-
-(defun walk-arglist (arglist context env &optional (destructuringp nil)
-					 &aux arg)
-  (cond ((null arglist) ())
-        ((symbolp (setq arg (car arglist)))
-         (or (member arg lambda-list-keywords)
-             (note-lexical-binding arg env))
-         (recons arglist
-                 arg
-                 (walk-arglist (cdr arglist)
-                               context
-			       env
-                               (and destructuringp
-				    (not (member arg
-						 lambda-list-keywords))))))
-        ((consp arg)
-         (prog1 (recons arglist
-			(if destructuringp
-			    (walk-arglist arg context env destructuringp)
-			    (relist* arg
-				     (car arg)
-				     (walk-form-internal (cadr arg) :eval env)
-				     (cddr arg)))
-			(walk-arglist (cdr arglist) context env nil))
-                (if (symbolp (car arg))
-                    (note-lexical-binding (car arg) env)
-                    (note-lexical-binding (cadar arg) env))
-                (or (null (cddr arg))
-                    (not (symbolp (caddr arg)))
-                    (note-lexical-binding (caddr arg) env))))
-          (t
-	   (error "Can't understand something in the arglist ~S" arglist))))
-
-(defun walk-let (form context env)
-  (walk-let/let* form context env nil))
-
-(defun walk-let* (form context env)
-  (walk-let/let* form context env t))
-
-(defun walk-prog (form context env)
-  (walk-prog/prog* form context env nil))
-
-(defun walk-prog* (form context env)
-  (walk-prog/prog* form context env t))
-
-(defun walk-do (form context env)
-  (walk-do/do* form context env nil))
-
-(defun walk-do* (form context env)
-  (walk-do/do* form context env t))
-
-(defun walk-let/let* (form context old-env sequentialp)
-  (walker-environment-bind (new-env old-env)
-    (let* ((let/let* (car form))
-	   (bindings (cadr form))
-	   (body (cddr form))
-	   (walked-bindings 
-	     (walk-bindings-1 bindings
-			      old-env
-			      new-env
-			      context
-			      sequentialp))
-	   (walked-body
-	     (walk-declarations body #'walk-repeat-eval new-env)))
-      (relist*
-	form let/let* walked-bindings walked-body))))
-
-(defun walk-locally (form context env)
-  (declare (ignore context))
-  (let* ((locally (car form))
-	 (body (cdr form))
-	 (walked-body
-	  (walk-declarations body #'walk-repeat-eval env)))
-    (relist*
-     form locally walked-body)))
-
-(defun walk-prog/prog* (form context old-env sequentialp)
-  (walker-environment-bind (new-env old-env)
-    (let* ((possible-block-name (second form))
-	   (blocked-prog (and (symbolp possible-block-name)
-			      (not (eq possible-block-name 'nil)))))
-      (multiple-value-bind (let/let* block-name bindings body)
-	  (if blocked-prog
-	      (values (car form) (cadr form) (caddr form) (cdddr form))
-	      (values (car form) nil	     (cadr  form) (cddr  form)))
-	(let* ((walked-bindings 
-		 (walk-bindings-1 bindings
-				  old-env
-				  new-env
-				  context
-				  sequentialp))
-	       (walked-body
-		 (walk-declarations 
-		   body
-		   #'(lambda (real-body real-env)
-		       (walk-tagbody-1 real-body context real-env))
-		   new-env)))
-	  (if block-name
-	      (relist*
-		form let/let* block-name walked-bindings walked-body)
-	      (relist*
-		form let/let* walked-bindings walked-body)))))))
-
-(defun walk-do/do* (form context old-env sequentialp)
-  (walker-environment-bind (new-env old-env)
-    (let* ((do/do* (car form))
-	   (bindings (cadr form))
-	   (end-test (caddr form))
-	   (body (cdddr form))
-	   (walked-bindings (walk-bindings-1 bindings
-					     old-env
-					     new-env
-					     context
-					     sequentialp))
-	   (walked-body
-	     (walk-declarations body #'walk-repeat-eval new-env)))
-      (relist* form
-	       do/do*
-	       (walk-bindings-2 bindings walked-bindings context new-env)
-	       (walk-template end-test '(test repeat (eval)) context new-env)
-	       walked-body))))
-
-(defun walk-let-if (form context env)
-  (let ((test (cadr form))
-	(bindings (caddr form))
-	(body (cdddr form)))
-    (walk-form-internal
-      `(let ()
-	 (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x))
-				     bindings)))
-	 (flet ((.let-if-dummy. () ,@body))
-	   (if ,test
-	       (let ,bindings (.let-if-dummy.))
-	       (.let-if-dummy.))))
-      context
-      env)))
-
-(defun walk-multiple-value-setq (form context env)
-  (let ((vars (cadr form)))
-    (if (some #'(lambda (var)
-		  (variable-symbol-macro-p var env))
-	      vars)
-	(let* ((temps (mapcar #'(lambda (var) (declare (ignore var)) (gensym)) vars))
-	       (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp)) vars temps))
-	       (expanded `(multiple-value-bind ,temps 
-			       ,(caddr form)
-			     ,@sets))
-	       (walked (walk-form-internal expanded context env)))
-	  (if (eq walked expanded)
-	      form
-	      walked))
-	(walk-template form '(nil (repeat (set)) eval) context env))))
-
-(defun walk-multiple-value-bind (form context old-env)
-  (walker-environment-bind (new-env old-env)
-    (let* ((mvb (car form))
-	   (bindings (cadr form))
-	   (mv-form (walk-template (caddr form) 'eval context old-env))
-	   (body (cdddr form))
-	   walked-bindings
-	   (walked-body
-	     (walk-declarations 
-	       body
-	       #'(lambda (real-body real-env)
-		   (setq walked-bindings
-			 (walk-bindings-1 bindings
-					  old-env
-					  new-env
-					  context
-					  nil))
-		   (walk-repeat-eval real-body real-env))
-	       new-env)))
-      (relist* form mvb walked-bindings mv-form walked-body))))
-
-(defun walk-bindings-1 (bindings old-env new-env context sequentialp)
-  (and bindings
-       (let ((binding (car bindings)))
-         (recons bindings
-                 (if (symbolp binding)
-                     (prog1 binding
-                            (note-lexical-binding binding new-env))
-                     (prog1 (relist* binding
-				     (car binding)
-				     (walk-form-internal (cadr binding)
-							 context
-							 (if sequentialp
-							     new-env
-							     old-env))
-				     (cddr binding))	;save cddr for DO/DO*
-						        ;it is the next value
-						        ;form. Don't walk it
-						        ;now though.
-                            (note-lexical-binding (car binding) new-env)))
-                 (walk-bindings-1 (cdr bindings)
-				  old-env
-				  new-env
-				  context
-				  sequentialp)))))
-
-(defun walk-bindings-2 (bindings walked-bindings context env)
-  (and bindings
-       (let ((binding (car bindings))
-             (walked-binding (car walked-bindings)))
-         (recons bindings
-		 (if (symbolp binding)
-		     binding
-		     (relist* binding
-			      (car walked-binding)
-			      (cadr walked-binding)
-			      (walk-template (cddr binding)
-					     '(eval)
-					     context
-					     env)))		 
-                 (walk-bindings-2 (cdr bindings)
-				  (cdr walked-bindings)
-				  context
-				  env)))))
-
-(defun walk-lambda (form context old-env)
-  (walker-environment-bind (new-env old-env)
-    (let* ((arglist (cadr form))
-           (body (cddr form))
-           (walked-arglist (walk-arglist arglist context new-env))
-           (walked-body
-             (walk-declarations body #'walk-repeat-eval new-env)))
-      (relist* form
-               (car form)
-	       walked-arglist
-               walked-body))))
-
-(defun walk-named-lambda (form context old-env)
-  (walker-environment-bind (new-env old-env)
-    (let* ((name (cadr form))
-	   (arglist (caddr form))
-           (body (cdddr form))
-           (walked-arglist (walk-arglist arglist context new-env))
-           (walked-body
-             (walk-declarations body #'walk-repeat-eval new-env)))
-      (relist* form
-               (car form)
-	       name
-	       walked-arglist
-               walked-body))))  
-
-(defun walk-setq (form context env)
-  (if (cdddr form)
-      (let* ((expanded (let ((rforms nil)
-			     (tail (cdr form)))
-			 (loop (when (null tail) (return (nreverse rforms)))
-			       (let ((var (pop tail)) (val (pop tail)))
-				 (push `(setq ,var ,val) rforms)))))
-	     (walked (walk-repeat-eval expanded env)))
-	(if (eq expanded walked)
-	    form
-	    `(progn ,@walked)))
-      (let* ((var (cadr form))
-	     (val (caddr form))
-	     (symmac (car (variable-symbol-macro-p var env))))
-	(if symmac
-	    (let* ((expanded `(setf ,(cddr symmac) ,val))
-		   (walked (walk-form-internal expanded context env)))
-	      (if (eq expanded walked)
-		  form
-		  walked))
-	    (relist form 'setq
-		    (walk-form-internal var :set env)
-		    (walk-form-internal val :eval env))))))
-
-(defun walk-symbol-macrolet (form context old-env)
-  (declare (ignore context))
-  (let* ((bindings (cadr form)))
-    (walker-environment-bind
-	(new-env old-env
-		 :lexical-variables
-		 (append (mapcar #'(lambda (binding)
-				     `(,(car binding)
-				       :macro . ,(cadr binding)))
-				 bindings)
-			 (env-lexical-variables old-env)))
-      (relist* form 'symbol-macrolet bindings
-	       (walk-repeat-eval (cddr form) new-env)))))
-
-(defun walk-tagbody (form context env)
-  (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
-
-(defun walk-tagbody-1 (form context env)
-  (and form
-       (recons form
-               (walk-form-internal (car form)
-				   (if (symbolp (car form)) 'quote context)
-				   env)
-               (walk-tagbody-1 (cdr form) context env))))
-
-(defun walk-compiler-let (form context old-env)
-  (declare (ignore context))
-  (let ((vars ())
-	(vals ()))
-    (dolist (binding (cadr form))
-      (cond ((symbolp binding) (push binding vars) (push nil vals))
-	    (t
-	     (push (car binding) vars)
-	     (push (eval (cadr binding)) vals))))
-    (relist* form
-	     (car form)
-	     (cadr form)
-	     (progv vars vals (walk-repeat-eval (cddr form) old-env)))))
-
-(defun walk-macrolet (form context old-env)
-  (walker-environment-bind (macro-env
-			    nil
-			    :walk-function (env-walk-function old-env))
-    (labels ((walk-definitions (definitions)
-	       (and definitions
-		    (let ((definition (car definitions)))
-		      (recons definitions
-                              (relist* definition
-                                       (car definition)
-                                       (walk-arglist (cadr definition)
-						     context
-						     macro-env
-						     t)
-                                       (walk-declarations (cddr definition)
-							  #'walk-repeat-eval
-							  macro-env))
-			      (walk-definitions (cdr definitions)))))))
-      (with-new-definition-in-environment (new-env old-env form)
-	(relist* form
-		 (car form)
-		 (walk-definitions (cadr form))
-		 (walk-declarations (cddr form)
-				    #'walk-repeat-eval
-				    new-env))))))
-
-(defun walk-flet (form context old-env)
-  (labels ((walk-definitions (definitions)
-	     (if (null definitions)
-		 ()
-		 (recons definitions
-			 (walk-lambda (car definitions) context old-env)
-			 (walk-definitions (cdr definitions))))))
-    (recons form
-	    (car form)
-	    (recons (cdr form)
-		    (walk-definitions (cadr form))
-		    (with-new-definition-in-environment (new-env old-env form)
-		      (walk-declarations (cddr form)
-					 #'walk-repeat-eval
-					 new-env))))))
-
-(defun walk-labels (form context old-env)
-  (with-new-definition-in-environment (new-env old-env form)
-    (labels ((walk-definitions (definitions)
-	       (if (null definitions)
-		   ()
-		   (recons definitions
-			   (walk-lambda (car definitions) context new-env)
-			   (walk-definitions (cdr definitions))))))
-      (recons form
-	      (car form)
-	      (recons (cdr form)
-		      (walk-definitions (cadr form))
-		      (walk-declarations (cddr form)
-					 #'walk-repeat-eval
-					 new-env))))))
-
-(defun walk-if (form context env)
-  (let ((predicate (cadr form))
-	(arm1 (caddr form))
-	(arm2 
-	  (if (cddddr form)
-	      (progn
-		(warn "In the form:~%~S~%~
-                       IF only accepts three arguments, you are using ~D.~%~
-                       It is true that some Common Lisps support this, but ~
-                       it is not~%~
-                       truly legal Common Lisp.  For now, this code ~
-                       walker is interpreting ~%~
-                       the extra arguments as extra else clauses. ~
-                       Even if this is what~%~
-                       you intended, you should fix your source code."
-		      form
-		      (length (cdr form)))
-		(cons 'progn (cdddr form)))
-	      (cadddr form))))
-    (relist form
-	    'if
-	    (walk-form-internal predicate context env)
-	    (walk-form-internal arm1 context env)
-	    (walk-form-internal arm2 context env))))
-
-
-;;;
-;;; Tests tests tests
-;;;
-
-#|
-;;; 
-;;; Here are some examples of the kinds of things you should be able to do
-;;; with your implementation of the macroexpansion environment hacking
-;;; mechanism.
-;;; 
-;;; with-lexical-macros is kind of like macrolet, but it only takes names
-;;; of the macros and actual macroexpansion functions to use to macroexpand
-;;; them.  The win about that is that for macros which want to wrap several
-;;; macrolets around their body, they can do this but have the macroexpansion
-;;; functions be compiled.  See the WITH-RPUSH example.
-;;;
-;;; If the implementation had a special way of communicating the augmented
-;;; environment back to the evaluator that would be totally great.  It would
-;;; mean that we could just augment the environment then pass control back
-;;; to the implementations own compiler or interpreter.  We wouldn't have
-;;; to call the actual walker.  That would make this much faster.  Since the
-;;; principal client of this is defmethod it would make compiling defmethods
-;;; faster and that would certainly be a win.
-;;;
-(defmacro with-lexical-macros (macros &body body &environment old-env)
-  (with-augmented-environment (new-env old-env :macros macros)
-    (walk-form (cons 'progn body) :environment new-env)))
-
-(defun expand-rpush (form env)
-  `(push ,(caddr form) ,(cadr form)))
-
-(defmacro with-rpush (&body body)
-  `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
-
-
-;;;
-;;; Unfortunately, I don't have an automatic tester for the walker.  
-;;; Instead there is this set of test cases with a description of
-;;; how each one should go.
-;;; 
-(defmacro take-it-out-for-a-test-walk (form)
-  `(take-it-out-for-a-test-walk-1 ',form))
-
-(defun take-it-out-for-a-test-walk-1 (form)
-  (terpri)
-  (terpri)
-  (let ((copy-of-form (copy-tree form))
-	(result (walk-form form nil
-		  #'(lambda (x y env)
-		      (format t "~&Form: ~S ~3T Context: ~A" x y)
-		      (when (symbolp x)
-			(let ((lexical (variable-lexical-p x env))
-			      (special (variable-special-p x env)))
-			  (when lexical
-			    (format t ";~3T")
-			    (format t "lexically bound"))
-			  (when special
-			    (format t ";~3T")
-			    (format t "declared special"))
-			  (when (boundp x)
-			    (format t ";~3T")
-			    (format t "bound: ~S " (eval x)))))
-		      x))))
-    (cond ((not (equal result copy-of-form))
-	   (format t "~%Warning: Result not EQUAL to copy of start."))
-	  ((not (eq result form))
-	   (format t "~%Warning: Result not EQ to copy of start.")))
-    (pprint result)
-    result))
-
-(defmacro foo (&rest ignore) ''global-foo)
-
-(defmacro bar (&rest ignore) ''global-bar)
-
-(take-it-out-for-a-test-walk (list arg1 arg2 arg3))
-(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5)))
-
-(take-it-out-for-a-test-walk (progn (foo) (bar 1)))
-
-(take-it-out-for-a-test-walk (block block-name a b c))
-(take-it-out-for-a-test-walk (block block-name (list a) b c))
-
-(take-it-out-for-a-test-walk (catch catch-tag (list a) b c))
-;;;
-;;; This is a fairly simple macrolet case.  While walking the body of the
-;;; macro, x should be lexically bound. In the body of the macrolet form
-;;; itself, x should not be bound.
-;;; 
-(take-it-out-for-a-test-walk
-  (macrolet ((foo (x) (list x) ''inner))
-    x
-    (foo 1)))
-
-;;;
-;;; A slightly more complex macrolet case.  In the body of the macro x
-;;; should not be lexically bound.  In the body of the macrolet form itself
-;;; x should be bound.  Note that THIS CASE WILL CAUSE AN ERROR when it
-;;; tries to macroexpand the call to foo.
-;;; 
-(take-it-out-for-a-test-walk
-     (let ((x 1))
-       (macrolet ((foo () (list x) ''inner))
-	 x
-	 (foo))))
-
-;;;
-;;; A truly hairy use of compiler-let and macrolet.  In the body of the
-;;; macro x should not be lexically bound.  In the body of the macrolet
-;;; itself x should not be lexically bound.  But the macro should expand
-;;; into 1.
-;;; 
-(take-it-out-for-a-test-walk
-  (compiler-let ((x 1))
-    (let ((x 2))
-      (macrolet ((foo () x))
-	x
-	(foo)))))
-
-
-(take-it-out-for-a-test-walk
-  (flet ((foo (x) (list x y))
-	 (bar (x) (list x y)))
-    (foo 1)))
-
-(take-it-out-for-a-test-walk
-  (let ((y 2))
-    (flet ((foo (x) (list x y))
-	   (bar (x) (list x y)))
-      (foo 1))))
-
-(take-it-out-for-a-test-walk
-  (labels ((foo (x) (bar x))
-	   (bar (x) (foo x)))
-    (foo 1)))
-
-(take-it-out-for-a-test-walk
-  (flet ((foo (x) (foo x)))
-    (foo 1)))
-
-(take-it-out-for-a-test-walk
-  (flet ((foo (x) (foo x)))
-    (flet ((bar (x) (foo x)))
-      (bar 1))))
-
-(take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b))
-(take-it-out-for-a-test-walk (prog () (declare (special a b))))
-(take-it-out-for-a-test-walk (let (a b c)
-                               (declare (special a b))
-                               (foo a) b c))
-(take-it-out-for-a-test-walk (let (a b c)
-                               (declare (special a) (special b))
-                               (foo a) b c))
-(take-it-out-for-a-test-walk (let (a b c)
-                               (declare (special a))
-                               (declare (special b))
-                               (foo a) b c))
-(take-it-out-for-a-test-walk (let (a b c)
-                               (declare (special a))
-                               (declare (special b))
-                               (let ((a 1))
-                                 (foo a) b c)))
-(take-it-out-for-a-test-walk (eval-when ()
-                               a
-                               (foo a)))
-(take-it-out-for-a-test-walk (eval-when (eval when load)
-                               a
-                               (foo a)))
-
-(take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b)))
-(take-it-out-for-a-test-walk (multiple-value-bind (a b)
-				 (foo a b)
-			       (declare (special a))
-			       (list a b)))
-(take-it-out-for-a-test-walk (progn (function foo)))
-(take-it-out-for-a-test-walk (progn a b (go a)))
-(take-it-out-for-a-test-walk (if a b c))
-(take-it-out-for-a-test-walk (if a b))
-(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
-(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
-			      1 2))
-(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
-(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
-(take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
-                               (declare (special a b))
-                               (list a b c)))
-(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
-                               (declare (special a b))
-                               (list a b c)))
-(take-it-out-for-a-test-walk (let ((a 1) (b 2))
-                               (foo bar)
-                               (declare (special a))
-                               (foo a b)))
-(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
-(take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
-(take-it-out-for-a-test-walk (progn a b c))
-(take-it-out-for-a-test-walk (progv vars vals a b c))
-(take-it-out-for-a-test-walk (quote a))
-(take-it-out-for-a-test-walk (return-from block-name a b c))
-(take-it-out-for-a-test-walk (setq a 1))
-(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
-(take-it-out-for-a-test-walk (tagbody a b c (go a)))
-(take-it-out-for-a-test-walk (the foo (foo-form a b c)))
-(take-it-out-for-a-test-walk (throw tag-form a))
-(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
-
-(defmacro flet-1 (a b) ''outer)
-(defmacro labels-1 (a b) ''outer)
-
-(take-it-out-for-a-test-walk
-  (flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
-    (flet-1 1 2)
-    (foo 1 2)))
-(take-it-out-for-a-test-walk
-  (labels ((label-1 (a b) () (label-1 a b)(list a b)))
-    (label-1 1 2)
-    (foo 1 2)))
-(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
-                               (macrolet-1 a b)
-                               (foo 1 2)))
-
-(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
-                               (foo 1)))
-
-(take-it-out-for-a-test-walk (progn (bar 1)
-                                    (macrolet ((bar (a)
-						 `(inner-bar-expanded ,a)))
-                                      (bar 2))))
-
-(take-it-out-for-a-test-walk (progn (bar 1)
-                                    (macrolet ((bar (s)
-						 (bar s)
-						 `(inner-bar-expanded ,s)))
-                                      (bar 2))))
-
-(take-it-out-for-a-test-walk (cond (a b)
-                                   ((foo bar) a (foo a))))
-
-
-(let ((the-lexical-variables ()))
-  (walk-form '(let ((a 1) (b 2))
-		#'(lambda (x) (list a b x y)))
-	     ()
-	     #'(lambda (form context env)
-		 (when (and (symbolp form)
-			    (variable-lexical-p form env))
-		   (push form the-lexical-variables))
-		 form))
-  (or (and (= (length the-lexical-variables) 3)
-	   (member 'a the-lexical-variables)
-	   (member 'b the-lexical-variables)
-	   (member 'x the-lexical-variables))
-      (error "Walker didn't do lexical variables of a closure properly.")))
-    
-|#
-
-()
-
diff --git a/pcl/xerox-low.lisp b/pcl/xerox-low.lisp
deleted file mode 100644
index 861884a5a820627ea057cc02479d85c8b58a9138..0000000000000000000000000000000000000000
--- a/pcl/xerox-low.lisp
+++ /dev/null
@@ -1,173 +0,0 @@
-;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;; This is the 1100 (Xerox version) of the file portable-low.
-;;;
-
-(in-package 'pcl)
-
-(defmacro load-time-eval (form)
-  `(il:LOADTIMECONSTANT ,form))
-
-;;;
-;;; make the pointer from an instance to its class wrapper be an xpointer.
-;;; this prevents instance creation from spending a lot of time incrementing
-;;; the large refcount of the class-wrapper.  This is safe because there will
-;;; always be some other pointer to the wrapper to keep it around.
-;;; 
-#+Xerox-Medley
-(defstruct (std-instance (:predicate std-instance-p)
-			 (:conc-name %std-instance-)
-			 (:constructor %%allocate-instance--class ())
-			 (:fast-accessors t)
-			 (:print-function %print-std-instance))
-  (wrapper nil :type il:fullxpointer)
-  (slots nil))
-
-#+Xerox-Lyric
-(eval-when (eval load compile)
-  (il:datatype std-instance
-	       ((wrapper il:fullxpointer)
-	        slots))
-
-  (xcl:definline std-instance-p (x)
-    (typep x 'std-instance))
-  
-  (xcl:definline %%allocate-instance--class ()
-    (il:create std-instance))
-
-  (xcl:definline %std-instance-wrapper (x) 
-    (il:fetch (std-instance wrapper) il:of x))
-
-  (xcl:definline %std-instance-slots (x) 
-    (il:fetch (std-instance slots) il:of x))
-
-  (xcl:definline set-%std-instance-wrapper (x value) 
-    (il:replace (std-instance wrapper) il:of x il:with value))
-
-  (xcl:definline set-%std-instance-slots (x value) 
-    (il:replace (std-instance slots) il:of x il:with value))
-
-  (defsetf %std-instance-wrapper set-%std-instance-wrapper)
-
-  (defsetf %std-instance-slots set-%std-instance-slots)
-
-  (il:defprint 'std-instance '%print-std-instance)
-
-  )
-
-(defun %print-std-instance (instance &optional stream depth)  
-  ;; See the IRM, section 25.3.3.  Unfortunatly, that documentation is
-  ;; not correct.  In particular, it makes no mention of the third argument.
-  (cond ((streamp stream)
-	 ;; Use the standard PCL printing method, then return T to tell
-	 ;; the printer that we have done the printing ourselves.
-	 (print-std-instance instance stream depth)
-	 t)
-	(t 
-	 ;; Internal printing (again, see the IRM section 25.3.3). 
-	 ;; Return a list containing the string of characters that
-	 ;; would be printed, if the object were being printed for
-	 ;; real.
-	 (list (with-output-to-string (stream)
-		 (print-std-instance instance stream depth))))))
-
-  ;;   
-;;;;;; FUNCTION-ARGLIST
-  ;;
-
-(defun function-arglist (x)
-  ;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and
-  ;; strings instead of symbols.  How silly.
-  (let ((arglist (il:arglist x)))
-    (when (symbolp arglist)
-      ;; This could be due to trying to extract the arglist of an interpreted
-      ;; function (though why that should be hard is beyond me).  On the other
-      ;; hand, if the function is compiled, it helps to ask for the "smart"
-      ;; arglist.
-      (setq arglist 
-	    (if (consp (symbol-function x))
-		(second (symbol-function x))
-		(il:arglist x t))))
-    (if (symbolp arglist)
-	;; Probably never get here, but just in case
-	(list '&rest 'rest)
-	;; Make sure there are no strings where there should be symbols
-	(if (some #'stringp arglist)
-	    (mapcar #'(lambda (a) (if (symbolp a) a (intern a))) arglist)
-	    arglist))))
-
-(defun printing-random-thing-internal (thing stream)
-  (let ((*print-base* 8))
-    (princ (il:\\hiloc thing) stream)
-    (princ "," stream)
-    (princ (il:\\loloc thing) stream)))
-
-(defun record-definition (name type &optional parent-name parent-type)
-  (declare (ignore type parent-name))
-  ())
-
-
-;;;
-;;; FIN uses this too!
-;;;
-(eval-when (compile load eval)
-  (il:datatype il:compiled-closure (il:fnheader il:environment))
-
-  (il:blockrecord closure-overlay ((funcallable-instance-p il:flag)))  
-
-  )
-
-(defun compiled-closure-fnheader (compiled-closure)
-  (il:fetch (il:compiled-closure il:fnheader) il:of compiled-closure))
-
-(defun set-compiled-closure-fnheader (compiled-closure nv)
-  (il:replace (il:compiled-closure il:fnheader) il:of compiled-closure nv))
-
-(defsetf compiled-closure-fnheader set-compiled-closure-fnheader)
-
-;;;
-;;; In Lyric, and until the format of FNHEADER changes, getting the name from
-;;; a compiled closure looks like this:
-;;; 
-;;; (fetchfield '(nil 4 pointer)
-;;;             (fetch (compiled-closure fnheader) closure))
-;;;
-;;; Of course this is completely non-robust, but it will work for now.  This
-;;; is not the place to go into a long tyrade about what is wrong with having
-;;; record package definitions go away when you ship the sysout; there isn't
-;;; enough diskspace.
-;;;             
-(defun set-function-name-1 (fn new-name uninterned-name)
-  (cond ((typep fn 'il:compiled-closure)
-	 (il:\\rplptr (compiled-closure-fnheader fn) 4 new-name)
-	 (when (and (consp uninterned-name)
-		    (eq (car uninterned-name) 'method))
-	   (let ((debug (si::compiled-function-debugging-info fn)))
-	     (when debug (setf (cdr debug) uninterned-name)))))
-	(t nil))
-  fn)
-
diff --git a/pcl/xerox-patches.lisp b/pcl/xerox-patches.lisp
deleted file mode 100644
index 87ed713c0d581f0a3773cfdf7523b07d0858c9d2..0000000000000000000000000000000000000000
--- a/pcl/xerox-patches.lisp
+++ /dev/null
@@ -1,248 +0,0 @@
-;;; -*- Mode: Lisp; Package: XCL-USER; Base: 10.; Syntax: Common-Lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
-;;; All rights reserved.
-;;;
-;;; Use and copying of this software and preparation of derivative works
-;;; based upon this software are permitted.  Any distribution of this
-;;; software or derivative works must comply with all applicable United
-;;; States export control laws.
-;;; 
-;;; This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any
-;;; specification.
-;;; 
-;;; Any person obtaining a copy of this software is requested to send their
-;;; name and post office or electronic mail address to:
-;;;   CommonLoops Coordinator
-;;;   Xerox PARC
-;;;   3333 Coyote Hill Rd.
-;;;   Palo Alto, CA 94304
-;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
-;;;
-;;; Suggestions, comments and requests for improvements are also welcome.
-;;; *************************************************************************
-;;;
-;;;
-
-(in-package "XCL-USER")
-
-
-;;; Patch a bug with Lambda-substitution
-
-#+Xerox-Lyric
-(defun compiler::meta-call-lambda-substitute (node)
-  (let* ((fn (compiler::call-fn node))
-	 (var-list (compiler::lambda-required fn))
-	 (spec-effects
-	  (il:for var il:in var-list
-	      il:unless (eq (compiler::variable-scope var) :lexical)
-	      il:collect (compiler::effects-representation var)))
-	 ;; Bind *SUBST-OCCURED* just so that META-SUBST-VAR-REF ahs a binding
-	 ;; to set even when nobody cares.
-	 (compiler::*subst-occurred* nil))
-    (il:for var il:in var-list
-      il:as tail il:on (compiler::call-args node)
-      il:when
-	(and (eq (compiler::variable-scope var) :lexical)
-	     (compiler::substitutable-p (car tail) var)
-	     (dolist (compiler::spec-effect spec-effects t)
-	       (when
-		   (not (compiler::null-effects-intersection compiler::spec-effect
-							     (compiler::node-affected (car tail))))
-		 (return nil)))
-	     (dolist (compiler::later-arg (cdr tail) t)
-	       (when (not (compiler::passable (car tail) compiler::later-arg))
-		 (return nil))))
-	il:do
-	  (setf (compiler::lambda-body fn)
-		(compiler::meta-substitute (car tail) var
-					   (compiler::lambda-body fn))))
-    (when (null (compiler::node-meta-p (compiler::lambda-body fn)))
-      (setf (compiler::node-meta-p fn) nil)
-      (setq compiler::*made-changes* t))))
-
-;;; Some simple optimizations missing from the compiler.
-
-
-;; Shift by a constant.
-
-;; Unfortunately, these cause the compiler to generate spurious warning
-;; messages about "Unknown function IL:LLSH1 called from ..."  It's not often
-;; you come across a place where COMPILER-LET is really needed.
-
-#+Xerox-Lyric
-(progn
-
-(defvar *ignore-shift-by-constant-optimization* nil
-  "Marker used for informing the shift-by-constant optimizers that they are in
- the shift function, and should not optimize.")
-
-(defun il:lrsh1 (x)
-  (compiler-let ((*ignore-shift-by-constant-optimization* t))
-    (il:lrsh x 1)))
-
-(defun il:lrsh8 (x)
-  (compiler-let ((*ignore-shift-by-constant-optimization* t))
-    (il:lrsh x 8)))
-
-(defun il:llsh1 (x)
-  (compiler-let ((*ignore-shift-by-constant-optimization* t))
-    (il:llsh x 1)))
-
-(defun il:llsh8 (x)
-  (compiler-let ((*ignore-shift-by-constant-optimization* t))
-    (il:llsh x 8)))
-
-(defoptimizer il:lrsh il:right-shift-by-constant (x n &environment env)
-  (if (and (constantp n)
-	   (not *ignore-shift-by-constant-optimization*))
-      (let ((shift-factor (eval n)))
-	(cond
-	  ((not (numberp shift-factor))
-	   (error "Non-numeric arg to ~S, ~S" 'il:lrsh shift-factor))
-	  ((= shift-factor 0)
-	   x)
-	  ((< shift-factor 0)
-	   `(il:llsh ,x ,(- shift-factor)))
-	  ((< shift-factor 8)
-	   `(il:lrsh (il:lrsh1 ,x) ,(1- shift-factor)))
-	  (t `(il:lrsh (il:lrsh8 ,x) ,(- shift-factor 8)))))
-      'compiler:pass))
-
-(defoptimizer il:llsh il:left-shift-by-constant (x n &environment env)
-  (if (and (constantp n)
-	   (not *ignore-shift-by-constant-optimization*))
-      (let ((shift-factor (eval n)))
-	(cond
-	  ((not (numberp shift-factor))
-	   (error "Non-numeric arg to ~S, ~S" 'il:llsh shift-factor))
-	  ((= shift-factor 0)
-	   x)
-	  ((< shift-factor 0)
-	   `(il:lrsh ,x ,(- shift-factor)))
-	  ((< shift-factor 8)
-	   `(il:llsh (il:llsh1 ,x) ,(1- shift-factor)))
-	  (t `(il:llsh (il:llsh8 ,x) ,(- shift-factor 8)))))
-      'compiler:pass))
-
-)
-
-
-;; Simple TYPEP optimiziation
-
-#+Xerox-Lyric
-(defoptimizer typep type-t-test (object type)
-  "Everything is of type T"
-  (if (and (constantp type) (eq (eval type) t))
-      `(progn ,object t)
-      'compiler:pass))
-
-;;; Declare side-effects (actually, lack of side-effects) info for some
-;;; internal arithmetic functions.  These are needed because the compiler runs
-;;; the optimizers before checking the side-effects, so side-effect
-;;; declarations on the "real" functions are oft times ignored.
-
-#+Xerox-Lyric
-(progn
-
-(il:putprops cl::%+ compiler::side-effects-data (:none . :none))
-(il:putprops cl::%- compiler::side-effects-data (:none . :none))
-(il:putprops cl::%* compiler::side-effects-data (:none . :none))
-(il:putprops cl::%/ compiler::side-effects-data (:none . :none))
-(il:putprops cl::%logior compiler::side-effects-data (:none . :none))
-(il:putprops cl::%logeqv compiler::side-effects-data (:none . :none))
-(il:putprops cl::%= compiler::side-effects-data (:none . :none))
-(il:putprops cl::%> compiler::side-effects-data (:none . :none))
-(il:putprops cl::%< compiler::side-effects-data (:none . :none))
-(il:putprops cl::%>= compiler::side-effects-data (:none . :none))
-(il:putprops cl::%<= compiler::side-effects-data (:none . :none))
-(il:putprops cl::%/= compiler::side-effects-data (:none . :none))
-(il:putprops il:lrsh1 compiler::side-effects-data (:none . :none))
-(il:putprops il:lrsh8 compiler::side-effects-data (:none . :none))
-(il:putprops il:llsh1 compiler::side-effects-data (:none . :none))
-(il:putprops il:llsh8 compiler::side-effects-data (:none . :none))
-
-)
-
-;;; Fix a nit in the compiler
-#+Xerox-Lyric
-(progn
-
-(il:unadvise 'compile)
-(il:advise 'compile ':around '(let (compiler::*input-stream*) (inner)))
-
-)
-
-;;; While no person would generate code like (logor x), macro can (and do).
-
-(defun optimize-logical-op-1-arg (form env ctxt)
-  (declare (ignore env ctxt))
-  (if (= 2 (length form))
-      (second form)
-      'compiler::pass))
-
-(xcl:defoptimizer logior optimize-logical-op-1-arg)
-(xcl:defoptimizer logxor optimize-logical-op-1-arg)
-(xcl:defoptimizer logand optimize-logical-op-1-arg)
-(xcl:defoptimizer logeqv optimize-logical-op-1-arg)
-
-
-#+Xerox-Medley
-
-;; A bug compiling LABELS
-
-(defun compiler::meta-call-labels (compiler::node compiler:context)
-  ;; This is similar to META-CALL-LAMBDA, but we have some extra information.
-  ;; There are only required arguments, and we have the correct number of them.
-  (let ((compiler::*made-changes* nil))
-    ;; First, substitute the functions wherever possible.
-    (dolist (compiler::fn-pair (compiler::labels-funs compiler::node)
-	     (when (null (compiler::node-meta-p (compiler::labels-body compiler::node)))
-	       (setf (compiler::node-meta-p compiler::node) nil)
-	       (setq compiler::*made-changes* t)))
-      (when (compiler::substitutable-p (cdr compiler::fn-pair)
-				       (car compiler::fn-pair))
-	(let ((compiler::*subst-occurred* nil))
-	  ;; First try substituting into the body.
-	  (setf (compiler::labels-body compiler::node)
-		(compiler::meta-substitute (cdr compiler::fn-pair)
-					   (car compiler::fn-pair)
-					   (compiler::labels-body compiler::node))) 
-	  (when (not compiler::*subst-occurred*)
-	    ;; Wasn't in the body - try the other functions.
-	    (dolist (compiler::target-pair (compiler::labels-funs compiler::node))
-	      (unless (eq compiler::target-pair compiler::fn-pair)
-		(setf (cdr compiler::target-pair)
-		      (compiler::meta-substitute (cdr compiler::fn-pair)
-						 (car compiler::fn-pair)
-						 (cdr compiler::target-pair)))
-		(when compiler::*subst-occurred* ;Found it, we can stop now.
-		  (setf (compiler::node-meta-p compiler::node) nil)
-		  (setq compiler::*made-changes* t) (return)))))
-	  ;; May need to reanalyze the node, since things might have changed.
-	  ;; Note that reanalyzing the parts of the node this way means the the
-	  ;; state in the enclosing loop is not lost.
-	  (dolist (compiler::fns (compiler::labels-funs compiler::node))
-	    (compiler::meval (cdr compiler::fns) :argument))
-	  (compiler::meval (compiler::labels-body compiler::node) :return))))
-    ;; Now remove any functions that aren't referenced.
-    (dolist (compiler::fn-pair (prog1 (compiler::labels-funs compiler::node)
-				 (setf (compiler::labels-funs compiler::node) nil)))
-      (cond ((null (compiler::variable-read-refs (car compiler::fn-pair)))
-	     (compiler::release-tree (cdr compiler::fn-pair))
-	     (setq compiler::*made-changes* t))
-	    (t (push compiler::fn-pair (compiler::labels-funs compiler::node)))))
-    ;; If there aren't any functions left, replace the node with its body.
-    (when (null (compiler::labels-funs compiler::node))
-      (let ((compiler::body (compiler::labels-body compiler::node)))
-	(setf (compiler::labels-body compiler::node) nil)
-	(compiler::release-tree compiler::node)
-	(setq compiler::node compiler::body compiler::*made-changes* t)))
-    ;; Finally, set the meta-p flag if everythings OK.
-    (if (null compiler::*made-changes*)
-	(setf (compiler::node-meta-p compiler::node) compiler:context)
-	(setf (compiler::node-meta-p compiler::node) nil)))
-  compiler::node)
-
diff --git a/tests/arg-test.lisp b/tests/arg-test.lisp
deleted file mode 100644
index b617309d09f3cc3b2bfc71ccdaa6c09331ae8b03..0000000000000000000000000000000000000000
--- a/tests/arg-test.lisp
+++ /dev/null
@@ -1,17 +0,0 @@
-;;;
-;;; Some stuff to test hairy lambda arguments...
-
-(defun optional-test (arg1 arg2 &optional opt1 (opt2 arg1 2-p) (opt3 opt1))
-  (list arg1 arg2 opt1 opt2 2-p opt3))
-
-(defun supplied-test (arg1 arg2 &optional (opt1 nil 1-p) (opt2 (length opt1)))
-  (list arg1 arg2 opt1 1-p opt2))
-
-(defun rest-test (&rest rest)
-  rest)
-
-(defun key-test (&key key1 (key2 'foo) (key3 (length key1)) (key4 nil 4-p))
-  (list key1 key2 key3 key4 4-p))
-
-(defun aux-test (arg1 &aux aux1 (aux2) (aux3 arg1))
-  (list arg1 aux1 aux2 aux3))
diff --git a/tests/block-test.lisp b/tests/block-test.lisp
deleted file mode 100644
index 132ca6d86614108b538c68e39f7f5ed2934f028d..0000000000000000000000000000000000000000
--- a/tests/block-test.lisp
+++ /dev/null
@@ -1,4 +0,0 @@
-(in-package 'c)
-
-(defun foo (x)
-  (return-from foo x))
diff --git a/tests/byte.lisp b/tests/byte.lisp
deleted file mode 100644
index 91b9bbf7deb7e57f09fddeed1fd33222d4181874..0000000000000000000000000000000000000000
--- a/tests/byte.lisp
+++ /dev/null
@@ -1,5 +0,0 @@
-(in-package 'c)
-
-(defun foo (x)
-  (declare (fixnum x))
-  (ldb (byte 3 5) x))
diff --git a/tests/call-test.lisp b/tests/call-test.lisp
deleted file mode 100644
index c4365c2f9a00c83500a59633bed6ef6adb90808f..0000000000000000000000000000000000000000
--- a/tests/call-test.lisp
+++ /dev/null
@@ -1,7 +0,0 @@
-
-(defun foo (x)
-  (write-string x))
-
-(defun bar (x y)
-  (print x)
-  (write-string y))
diff --git a/tests/char-test.lisp b/tests/char-test.lisp
deleted file mode 100644
index efa1ac88a43226b040469a5517600c7e8685ea7c..0000000000000000000000000000000000000000
--- a/tests/char-test.lisp
+++ /dev/null
@@ -1,8 +0,0 @@
-(in-package 'c)
-
-(defun test (x y)
-  (declare (simple-string x y))
-  (declare (optimize speed))
-  (dotimes (i 10)
-    (setf (aref x i)
-	  (code-char (char-code (aref y i))))))
diff --git a/tests/check-test.lisp b/tests/check-test.lisp
deleted file mode 100644
index 32b2684d738151c4a691198549f9958fa81e9220..0000000000000000000000000000000000000000
--- a/tests/check-test.lisp
+++ /dev/null
@@ -1,12 +0,0 @@
-
-(defun seq-test (x)
-  (the sequence x))
-
-(defun hair (x)
-  (+ x 3))
-
-(defun foo (x)
-  (the simple-string x))
-
-(defun aref-test (x)
-  (aref '#(1 2 3) x))
diff --git a/tests/circular.lisp b/tests/circular.lisp
deleted file mode 100644
index c7f7f70ebb292d9111bbb985c549aed55ad45231..0000000000000000000000000000000000000000
--- a/tests/circular.lisp
+++ /dev/null
@@ -1,9 +0,0 @@
-(defun test ()
-  (let ((*print-circle* t))
-    (declare (special *print-circle*))
-    (print '#1=(#1#))
-    (print '#1=(a . #1#))
-    (print '(a b #1=(c d (e . #1#))))
-    (print '#1=#(#1#))
-    (print '(a b (c d) #1=(c d) #1#))
-    (values)))
diff --git a/tests/copy-prop.lisp b/tests/copy-prop.lisp
deleted file mode 100644
index 00a66bb471c5a77049f29b160fd11686b7942d2a..0000000000000000000000000000000000000000
--- a/tests/copy-prop.lisp
+++ /dev/null
@@ -1,5 +0,0 @@
-(defun foo (n)
-  (dotimes (i n)
-    (print (+ i 3))))
-
-(defun ident (x) x)
diff --git a/tests/dead-code.lisp b/tests/dead-code.lisp
deleted file mode 100644
index 80ebb0fdd27a8cc8d6055beb884d50765fcfb0c1..0000000000000000000000000000000000000000
--- a/tests/dead-code.lisp
+++ /dev/null
@@ -1,23 +0,0 @@
-(defun foo ()
-  (if t
-      (write-line "True.")
-      (write-line "False.")))
-
-(defstruct foo a b)
-
-(defun lose (x)
-  (let ((a (foo-a x))
-	(b (if x (foo-b x) :none)))
-    (list a b)))
-
-(defun count-a (string)
-  (do ((pos 0 (position #\a string :start (1+ pos)))
-       (count 0 (1+ count)))
-      ((null pos) count)
-    (declare (fixnum pos))))
-
-(defmacro t-and-f (var form)
-  `(if ,var ,form ,form))
-
-(defun foo (x)
-  (t-and-f x (if x "True." "False.")))
diff --git a/tests/delete-note.lisp b/tests/delete-note.lisp
deleted file mode 100644
index a153c0544d68840a4cf2d27afd27ab6b62e03b05..0000000000000000000000000000000000000000
--- a/tests/delete-note.lisp
+++ /dev/null
@@ -1,9 +0,0 @@
-(defun foo (s)
-  (do ((i 0 (position #\space s :start i))
-       (count 0 (1+ count)))
-      ((null i) count)
-    (declare (fixnum i count))))
-
-(defun mm (x l)
-  (declare (inline member))
-  (member x l :key #'(lambda (x) (car (fnord x)))))
diff --git a/tests/derive.lisp b/tests/derive.lisp
deleted file mode 100644
index d8b72d6f4ba57036f2deebdee7159cc7a47a130d..0000000000000000000000000000000000000000
--- a/tests/derive.lisp
+++ /dev/null
@@ -1,18 +0,0 @@
-(in-package 'c)
-
-(defun foo (x y z r)
-  (declare (type (unsigned-byte 8) x)
-	   (type (unsigned-byte 4) y)
-	   (type (signed-byte 8) z)
-	   (type unsigned-byte r))
-  (values
-   (+ x y)
-   (+ y z)
-   (+ z r)
-   (- x y)
-   (- y z)
-   (- z r)
-   (* x y)
-   (* y z)
-   (* z r)
-   (ash z -2)))
diff --git a/tests/dynamic-type.lisp b/tests/dynamic-type.lisp
deleted file mode 100644
index 3765cec6cce83e430867f99576297b4f2d528cb6..0000000000000000000000000000000000000000
--- a/tests/dynamic-type.lisp
+++ /dev/null
@@ -1,7 +0,0 @@
-(defun foo (x)
-  (+ (car x) x))
-
-(defun memq (e l)
-  (do ((current l (cdr current)))
-      ((atom current) nil)
-    (when (eq (car current) e) (return current))))
diff --git a/tests/eff-note.lisp b/tests/eff-note.lisp
deleted file mode 100644
index 3b9954e778cf68cb0dd51a49030e7f4de9b051eb..0000000000000000000000000000000000000000
--- a/tests/eff-note.lisp
+++ /dev/null
@@ -1,21 +0,0 @@
-(proclaim '(optimize (speed 3) (safety 0)))
-
-(defun eff-note (x y z)
-  (declare (fixnum x y z))
-  (the fixnum (+ x y z)))
-
-(defun eff-note (x y z)
-  (declare (fixnum x y z))
-  (the fixnum (+ (the fixnum (+ x y)) z)))
-
-(proclaim '(optimize (speed 1) (safety 1) (c::brevity 0)))
-
-(defun eff-note (x y z)
-  (declare (type (unsigned-byte 18) x y z))
-  (+ x y z))
-
-(defun three-p (x)
-  (= x 3))
-
-(defun eol-pos (x)
-  (position #\newline x))
diff --git a/tests/error-test.lisp b/tests/error-test.lisp
deleted file mode 100644
index 67d527deca2695cdb0312cff88cb44e5cfb0401f..0000000000000000000000000000000000000000
--- a/tests/error-test.lisp
+++ /dev/null
@@ -1,17 +0,0 @@
-(defun raz (foo)
-  (let ((x (case foo
-	     (:this 13)
-	     (:that 9)
-	     (:the-other 42))))
-    (declare (fixnum x))
-    (+ x 55 x)))
-
-(defun bar (x)
-  (let (a)
-    (declare (fixnum a))
-    (setq a (foo x))
-    a))
-
-(defstruct (foo (:print-function fnord))
-  (a (make-symbol "FOO") :type float)
-  (b nil :type fixnum))
diff --git a/tests/error.lisp b/tests/error.lisp
deleted file mode 100644
index 7870b273f37bfbf6be99605ca624d19d33e02d80..0000000000000000000000000000000000000000
--- a/tests/error.lisp
+++ /dev/null
@@ -1,6 +0,0 @@
-(,foo)
-#1#
-(defun foo ()
-  "foo"
-  (fonrod)
-
diff --git a/tests/examples.lisp b/tests/examples.lisp
deleted file mode 100644
index 7ca0805f7daf7aa40d0ea021c325a659841aeab4..0000000000000000000000000000000000000000
--- a/tests/examples.lisp
+++ /dev/null
@@ -1,19 +0,0 @@
-(defun bar (x)
-  (let (a)
-    (declare (fixnum a))
-    (setq a (foo x))
-    a))
-
-(defun foo (e l)
-  (do ((current l (cdr current))
-       ((atom current) nil))
-      (when (eq (car current) e) (return current))))
-
-(defun raz (foo)
-  (let ((x (case foo
-	     (:this 13)
-	     (:that 9)
-	     (:the-other 42))))
-    (declare (fixnum x))
-    (foo x)))
-
diff --git a/tests/float.lisp b/tests/float.lisp
deleted file mode 100644
index 64ed4c2b938775e1d217caf5f6fcdaa02aed4ca0..0000000000000000000000000000000000000000
--- a/tests/float.lisp
+++ /dev/null
@@ -1,15 +0,0 @@
-
-(in-package "KERNEL")
-(use-package "VM")
-
-(defun decode-single-float (x)
-  (declare (single-float x))
-  (let ((bits (single-float-bits (abs x))))
-    (values (make-single-float
-	     (dpb single-float-bias single-float-exponent-byte bits))
-	    (truly-the single-float-exponent
-		       (- (ldb single-float-exponent-byte bits)
-			  single-float-bias))
-	    (float-sign x))))
-
-
diff --git a/tests/flush.lisp b/tests/flush.lisp
deleted file mode 100644
index d4befc272706b054990adbeced131651f14f5f26..0000000000000000000000000000000000000000
--- a/tests/flush.lisp
+++ /dev/null
@@ -1,7 +0,0 @@
-(defun foo ()
-  (loop)
-  (fnord 1
-	 (if (zlibber)
-	     (globber)
-	     (frobboz))
-	 :two))
diff --git a/tests/ftype-assert.lisp b/tests/ftype-assert.lisp
deleted file mode 100644
index 6a9515646ebdf0946cedb35c1529c8f1392a9976..0000000000000000000000000000000000000000
--- a/tests/ftype-assert.lisp
+++ /dev/null
@@ -1,57 +0,0 @@
-(proclaim '(ftype (function (fixnum fixnum) fixnum) m+))
-
-(defun m+ (x y)
-  (+ x y))
-
-
-(proclaim '(ftype (function (fixnum cons) fixnum) error1))
-
-(defun error1 (x y)
-  (declare (fixnum x y))
-  (+ x y))
-
-
-(proclaim '(ftype (function (t &optional list
-			       &key (b fixnum) (c bit)))
-		  error2))
-
-(defun error2 (a &key b) (list a b))
-
-(defun error2 (a &optional y &key (b 13) (c 0.0))
-  (declare (float c))
-  (list a y b c))
-
-(defun error2 (a &optional y &key (b 3) (c 0) (d 4)) (list a y b c d))
-(defun error2 (a &optional y &key (b 3)) (list a y b))
-(defun error2 (a y &key b c &allow-other-keys) (list a y b c))
-
-(proclaim '(ftype (function (fixnum float &key (do-we-ever bit))) yow!))
-
-(defun yow! (x y)
-  (+ x y))
-
-(defun error2 (a &optional y &key (b 13) (c 0.0))
-  (list a y b c))
-
-(defun defun-test (a &optional y &key b c)
-  (list a y b c))
-
-(defun defun-test (a &optional y &key b d)
-  (list a y b d))
-
-(defun defun-test (a &optional y &rest foo &key b d)
-  (list foo a y b d))
-
-(defun foo (a b)
-  (declare (fixnum a))
-  (list a b))
-
-(defun foo (a)
-  (declare (float a))
-  (list a))
-
-(defun gronk (&optional d)
-  (list d))
-
-(defun gronk (&optional d &rest c &key)
-  (list d c))
diff --git a/tests/local-call-type.lisp b/tests/local-call-type.lisp
deleted file mode 100644
index 14bfe3896c69c4150419a589744d12a42eb50dbb..0000000000000000000000000000000000000000
--- a/tests/local-call-type.lisp
+++ /dev/null
@@ -1,11 +0,0 @@
-(defun ! (n)
-  (declare (integer n))
-  (if (zerop n)
-      1
-      (* (! (1- n)) n)))
-
-(defun ! (n res)
-  (declare (integer n res))
-  (if (zerop n)
-      res
-      (! (1- n) (* n res))))
diff --git a/tests/macro-example.lisp b/tests/macro-example.lisp
deleted file mode 100644
index bd0e55321adc46449145a9dc6dcfa819d2bf2a76..0000000000000000000000000000000000000000
--- a/tests/macro-example.lisp
+++ /dev/null
@@ -1,2 +0,0 @@
-(defun foo (n)
-  (dotimes (i n (or *undefined* n))))
diff --git a/tests/misdecl.lisp b/tests/misdecl.lisp
deleted file mode 100644
index 4f2740d74bb0fdc2485949f824cb78ea19afc626..0000000000000000000000000000000000000000
--- a/tests/misdecl.lisp
+++ /dev/null
@@ -1,5 +0,0 @@
-
-(defun foo (x y)
-  x
-  (declare (fixnum y))
-  y)
diff --git a/tests/mixed-compare.lisp b/tests/mixed-compare.lisp
deleted file mode 100644
index 8e29e40152bada0b0a200eb75461af311bb465ad..0000000000000000000000000000000000000000
--- a/tests/mixed-compare.lisp
+++ /dev/null
@@ -1,2 +0,0 @@
-(defun foo (x y)
-  (< (the single-float x) (the rational y)))
diff --git a/tests/mv-bind.lisp b/tests/mv-bind.lisp
deleted file mode 100644
index 6a21ae440b3395542f372cc56d3547652d0e4f15..0000000000000000000000000000000000000000
--- a/tests/mv-bind.lisp
+++ /dev/null
@@ -1,9 +0,0 @@
-;;; -*- Package: C -*-
-
-(in-package 'c)
-
-(defun foo (x)
-  (multiple-value-bind (y z)
-		       (glortzx x)
-    (declare (type fixnum y z))
-    (the fixnum (+ y z))))
diff --git a/tests/nlx-hair.lisp b/tests/nlx-hair.lisp
deleted file mode 100644
index 420b848f3217ed65ab85ea28cb2a34819d5cd246..0000000000000000000000000000000000000000
--- a/tests/nlx-hair.lisp
+++ /dev/null
@@ -1,12 +0,0 @@
-(in-package 'c)
-
-(defun hair ()
-  (multiple-value-bind
-      (x y z)
-      (block foo
-	(hair-aux #'(lambda () (return-from foo (values 1 2 3)))))
-    (declare (type frob x y z))
-    (values x y z)))
-
-(defun hair-aux (fun)
-  (funcall fun))
diff --git a/tests/nlx-test.lisp b/tests/nlx-test.lisp
deleted file mode 100644
index 0b6571223f88225ed593b130939ed9267e678ea2..0000000000000000000000000000000000000000
--- a/tests/nlx-test.lisp
+++ /dev/null
@@ -1,81 +0,0 @@
-(in-package 'c)
-
-(eval-when (compile eval)
-  (defmacro dbg-write (string)
-    `(system:%primitive write-string ,string 0 ,(length string)))
-  
-  (defmacro receive-values (n form)
-    (collect ((vars))
-      (dotimes (i n)
-	(vars (gensym)))
-      `(multiple-value-bind ,(vars)
-			    ,form
-	 (dbg-write "vars =")
-	 (system:%primitive print ',n)
-	 ,@(mapcar #'(lambda (x)
-		       `(system:%primitive print ,x))
-		   (vars)))))
-  
-  (defmacro receive-any-values (form)
-    (once-only ((n-res `(multiple-value-list ,form)))
-      `(progn
-	 (dbg-write "result =")
-	 (system:%primitive print ,n-res)))))
-
-
-(proclaim '(special *foo*))
-
-(defun nlx-test (n)
-  (let ((*foo* 'nlx-test))
-    (multiple-value-prog1
-	(block foo
-	  (nlx-test-aux
-	   #'(lambda ()
-	       (dbg-write "In escape: ")
-	       (system:%primitive print *foo*)
-	       (return-from foo (n-values n)))))
-      (dbg-write "After unwind: ")
-      (system:%primitive print *foo*))))
-
-(defun nlx-test-aux (fun)
-  (let ((*foo* 'nlx-test-aux))
-    (unwind-protect 
-	(funcall fun)
-      (dbg-write "Unwind: ")
-      (%primitive print *foo*)
-      (dbg-write "
-"))))
-
-
-(defun n-values (n)
-  (declare (type (integer 0 5) n))
-  (dbg-write "values =")
-  (system:%primitive print n)
-  (ecase n
-    (0 (values))
-    (1 (values 0))
-    (2 (values 0 1))
-    (3 (values 0 1 2))
-    (4 (values 0 1 2 3))
-    (5 (values 0 1 2 3 4))))
-
-
-(defun list (&rest x)
-  x)
-
-
-(defun lisp::%initial-function ()
-  (dbg-write "Starting...
-")
-  (let ((*foo* 'lisp::%initial-function))
-    (dbg-write "Before NLX-Test: ")
-    (system:%primitive print *foo*)
-    (receive-any-values (nlx-test 5))
-    (dbg-write "After NLX-Test: ")
-    (system:%primitive print *foo*))
-
-
-  (dbg-write "
-done.
-")
-  (system:%primitive halt))
diff --git a/tests/pred-test.lisp b/tests/pred-test.lisp
deleted file mode 100644
index b55a1c2dcb75f68d63bfe8148b5364e00bd49042..0000000000000000000000000000000000000000
--- a/tests/pred-test.lisp
+++ /dev/null
@@ -1,9 +0,0 @@
-;;; -*- Package: C -*-
-(in-package 'c)
-
-(defun sequence-test (x)
-  (typep x 'sequence))
-
-(defun bit-test (x)
-  (typep x 'bit))
-
diff --git a/tests/read-eof.lisp b/tests/read-eof.lisp
deleted file mode 100644
index a763f7b5044fc8fd37008f1aa87100121310aeab..0000000000000000000000000000000000000000
--- a/tests/read-eof.lisp
+++ /dev/null
@@ -1,7 +0,0 @@
-"flug"
-"glog"
-
-;;; This is a test.
-(defun test ()
-  foo
-  (bar (baz a b))
diff --git a/tests/rep-change.lisp b/tests/rep-change.lisp
deleted file mode 100644
index eef876684f0c7d8b8c36487b7e8f03b6de1fddde..0000000000000000000000000000000000000000
--- a/tests/rep-change.lisp
+++ /dev/null
@@ -1,6 +0,0 @@
-(defun foo (x)
-  (etypecase x
-    (single-float
-     (let ((x x))
-       (declare (single-float x))
-       (+ x x)))))
diff --git a/tests/source-test.lisp b/tests/source-test.lisp
deleted file mode 100644
index f9deae8fda6af57b7a66cfe1d06f4fdb97cd9cad..0000000000000000000000000000000000000000
--- a/tests/source-test.lisp
+++ /dev/null
@@ -1,7 +0,0 @@
-
-(defmacro zoq (x)
-  `(roq (ploq (+ ,x 3))))
-
-(defun foo (y)
-  (declare (symbol y))
-  (zoq y))
diff --git a/tests/spill-test.lisp b/tests/spill-test.lisp
deleted file mode 100644
index cca9d6f9257722865c719a2c314c4d645b02c869..0000000000000000000000000000000000000000
--- a/tests/spill-test.lisp
+++ /dev/null
@@ -1,8 +0,0 @@
-(defun test (x y)
-  (snork (list y y y))
-  (prog1 (car x)
-    (snork 3)
-    (snork (list y y y))))
-
-(defun snork (x)
-  (funcall 'identity x))
diff --git a/tests/stack.lisp b/tests/stack.lisp
deleted file mode 100644
index b55a05d7a2c92e26bde9a7c48a04d3ff69943e06..0000000000000000000000000000000000000000
--- a/tests/stack.lisp
+++ /dev/null
@@ -1,54 +0,0 @@
-;;; Some tests of unknown stack values.
-;;;
-
-(defun twisted ()
-  (block nil
-    (tagbody
-      (return
-       (multiple-value-prog1 (foo)
-	 (when (bar)
-	   (go UNWIND))))
-      
-     UNWIND
-      (return
-       (multiple-value-prog1 (baz)
-	 (bletch))))))
-
-(defun nested ()
-  (multiple-value-call #'foo
-    :foo
-    (if (bar)
-	(multiple-value-prog1 (grinch) (finch))
-	(bletch)) 
-    (quaz)))
-
-(defun dead-generator ()
-  (multiple-value-call #'foo
-    (if (bar)
-	(multiple-value-prog1 (grinch) (return-from dead-generator nil))
-	(finch))
-    (quaz)))
-
-(defun deleted-use ()
-  (multiple-value-call #'foo
-    (multiple-value-prog1 (grinch) (return-from deleted-use nil))
-    (quaz)))
-
-(defun backward ()
-  (tagbody
-   FOO
-    (multiple-value-call #'foo
-      :foo
-      (if (bar)
-	  (baz)
-	  (go FOO))
-      (if (zab) 1 2)
-      (quaz))))
-
-(defun dead-nested ()
-  (multiple-value-prog1 (foo)
-    (block punt
-      (multiple-value-call #'bar
-	(multiple-value-prog1 (baz)
-	  (when (gronk)
-	    (return-from punt)))))))
diff --git a/tests/struct-test.lisp b/tests/struct-test.lisp
deleted file mode 100644
index a6fd991662ed3040d4855166acbe2e9af60f7dbf..0000000000000000000000000000000000000000
--- a/tests/struct-test.lisp
+++ /dev/null
@@ -1,7 +0,0 @@
-(in-package 'c)
-
-(defstruct test
-  (a nil :type fixnum))
-
-(defun test (x y)
-  (setf (test-a x) (test-a y)))
diff --git a/tests/tagbody.lisp b/tests/tagbody.lisp
deleted file mode 100644
index 86567926068535db26ed9ca58e5e6f45d3c7a62a..0000000000000000000000000000000000000000
--- a/tests/tagbody.lisp
+++ /dev/null
@@ -1,6 +0,0 @@
-(in-package 'c)
-
-(defun foo ()
-  (tagbody
-   A
-    (when (frob) (go a))))
diff --git a/tests/tlf-test.lisp b/tests/tlf-test.lisp
deleted file mode 100644
index efc31fc0702039bc72fa9b42e7702d7e33ade2a1..0000000000000000000000000000000000000000
--- a/tests/tlf-test.lisp
+++ /dev/null
@@ -1,24 +0,0 @@
-;;; TAK -- A vanilla version of the TAKeuchi function.
-
-(eval-when (compile eval)
-  (defmacro dbg-write (string)
-    `(system:%primitive write-string ,string 0 ,(length string))))
-
-(dbg-write "Form1
-")
-(dbg-write "Form2
-")
-
-(defun lisp::%initial-function ()
-  (dbg-write "Starting...
-")
-  (dolist (fun lisp::*lisp-initialization-functions*)
-    (funcall fun))
-
-  (dbg-write "
-done.
-")
-  (system:%primitive halt))
-
-(dbg-write "Form1
-")
diff --git a/tests/top-level-nlx.lisp b/tests/top-level-nlx.lisp
deleted file mode 100644
index 8b7403c05f445527099de2d41a79a4bc55369d78..0000000000000000000000000000000000000000
--- a/tests/top-level-nlx.lisp
+++ /dev/null
@@ -1,23 +0,0 @@
-(let ((count 0))
-  (block crock
-    (defun test (x)
-      (if x
-	  (return-from crock (values 2 2))
-	  (print 'yow!)))
-    (test nil)
-    (defun increment ()
-      (incf count))
-    (unwind-protect
-	(test t)
-      (print "Unwound."))))
-
-(catch 'goo
-  (unwind-protect
-      (throw 'goo nil)
-    (print "Unwound.")))
-
-(collect ((stuff))
-  (dotimes (i 10)
-    (stuff #'(lambda (x)
-	       (when x (return i)))))
-  (defparameter *stuff* (stuff)))
diff --git a/tests/transform.lisp b/tests/transform.lisp
deleted file mode 100644
index 7ef0d13ca066c8f508bc94bac4fb85d0a58e833e..0000000000000000000000000000000000000000
--- a/tests/transform.lisp
+++ /dev/null
@@ -1,5 +0,0 @@
-
-(defun foo ()
-  (zerop x))
-
-(defun foo (x) (logand 1 x))
diff --git a/tests/undef-test.lisp b/tests/undef-test.lisp
deleted file mode 100644
index 9489e9ca6a1bb6797b81ce5e908abc763177c917..0000000000000000000000000000000000000000
--- a/tests/undef-test.lisp
+++ /dev/null
@@ -1,6 +0,0 @@
-
-(defun foo (x y)
-  (zoz x)
-  (if (typep x 'zoo)
-      (fnox x)
-      *zork*))
diff --git a/tests/values-note.lisp b/tests/values-note.lisp
deleted file mode 100644
index 58e19ba204d905b8871a38c08c289a5c621d2c5d..0000000000000000000000000000000000000000
--- a/tests/values-note.lisp
+++ /dev/null
@@ -1,30 +0,0 @@
-(defun grue (x)
-  (declare (fixnum x))
-  (cond ((minusp x)
-	 (values x t))
-	((oddp x)
-	 nil)
-	(t
-	 (grue (grue (1- x))))))
-
-(defun blue (x)
-  (declare (fixnum x))
-  (cond ((minusp x)
-	 (values x t))
-	((= x 42)
-	 (snoo x))
-	((evenp x)
-	 (values (list (snoo x) (snoo x)) nil))
-	(t
-	 (blue (1- x)))))
-
-(defun snoo (x)
-  (declare (fixnum x))
-  (if (zerop x)
-      :yow!
-      (snoo (1- x))))
-
-(defun no-problem (x)
-  (if (eq x :foo)
-      (values :bar t)
-      (values :zoom!)))
diff --git a/tests/values-test.lisp b/tests/values-test.lisp
deleted file mode 100644
index 3b294eaa5eb1c91fbba75383e0c0bf071275593c..0000000000000000000000000000000000000000
--- a/tests/values-test.lisp
+++ /dev/null
@@ -1,2 +0,0 @@
-(defun foo ()
-  (values 1 2))
diff --git a/tests/values.lisp b/tests/values.lisp
deleted file mode 100644
index 43403556965f0290ef6c02c8cfc50d909f18f77d..0000000000000000000000000000000000000000
--- a/tests/values.lisp
+++ /dev/null
@@ -1,41 +0,0 @@
-(eval-when (compile eval)
-  (defmacro dbg-write (string)
-    `(system:%primitive write-string ,string 0 ,(length string)))
-
-  (defmacro receive-values (n form)
-    (c::collect ((vars))
-      (dotimes (i n)
-	(vars (gensym)))
-      `(multiple-value-bind ,(vars)
-			    ,form
-	 (dbg-write "vars =")
-	 (system:%primitive print ',n)
-	 ,@(mapcar #'(lambda (x)
-		       `(system:%primitive print ,x))
-		   (vars))))))
-
-(defun n-values (n)
-  (dbg-write "values =")
-  (system:%primitive print n)
-  (ecase n
-    (0 (values))
-    (1 (values 0))
-    (2 (values 0 1))
-    (3 (values 0 1 2))
-    (4 (values 0 1 2 3))
-    (5 (values 0 1 2 3 4))))
-
-
-(defun lisp::%initial-function ()
-  (dbg-write "Starting...
-")
-
-  (receive-values 3 (n-values 1))
-  (receive-values 3 (n-values 2))
-  (receive-values 5 (n-values 3))
-  (receive-values 1 (n-values 5))
-
-  (dbg-write "
-done.
-")
-  (system:%primitive halt))
diff --git a/tools/chop.c b/tools/chop.c
deleted file mode 100644
index 2962f2de30dc7c8b13fb7128d950773845598119..0000000000000000000000000000000000000000
--- a/tools/chop.c
+++ /dev/null
@@ -1,48 +0,0 @@
-#include <stdio.h>
-
-#define BUFFERSIZE (1<<21)
-
-char buffer[BUFFERSIZE];
-
-void chop(infile)
-char *infile;
-{
-    FILE *in, *out;
-    char outfile[1024];
-    int count, bytes;
-
-    count = 0;
-
-    in = fopen(infile, "r");
-    if (in == NULL) {
-	perror(infile);
-	return;
-    }
-
-    while ((bytes = fread(buffer, 1, BUFFERSIZE, in)) != 0) {
-	sprintf(outfile, "%s.%d", infile, count++);
-	out = fopen(outfile, "w+");
-	if (out == NULL) {
-	    perror(outfile);
-	    fclose(in);
-	    return;
-	}
-	fwrite(buffer, 1, bytes, out);
-	fclose(out);
-    }
-
-    fclose(in);
-}
-
-main(argc, argv)
-int argc;
-char *argv[];
-{
-    if (argc < 2) {
-	fprintf(stderr, "usage: chop file...\n");
-	exit(1);
-    }
-
-    while (*++argv != NULL)
-	chop(*argv);
-}
diff --git a/tools/clmcom.lisp b/tools/clmcom.lisp
deleted file mode 100644
index 2568b14d5ce81c3418ad8cc9a08dc8713bf38bad..0000000000000000000000000000000000000000
--- a/tools/clmcom.lisp
+++ /dev/null
@@ -1,40 +0,0 @@
-;;; File for compiling the Motif toolkit and related interface
-;;; stuff.
-;;;
-
-(in-package "USER")
-
-(pushnew :motif-toolkit *features*)
-
-(with-compilation-unit
-    (:optimize '(optimize (speed 3) (safety 1) (ext:inhibit-warnings 3)))
-
- (comf "target:motif/lisp/initial" :load t)
- (comf "target:motif/lisp/internals" :load t)
- (comf "target:motif/lisp/transport" :load t)
- (comf "target:motif/lisp/events" :load t)
- (comf "target:motif/lisp/conversion" :load t))
-
-(with-compilation-unit
-    (:optimize '(optimize (speed 2) (ext:inhibit-warnings 2)))
-
-  (comf "target:motif/lisp/interface-glue" :load t)
-  (comf "target:motif/lisp/xt-types" :load t)
-  (comf "target:motif/lisp/string-base" :load t)
-  (comf "target:motif/lisp/prototypes" :load t)
-  (comf "target:motif/lisp/interface-build" :load t)
-  (comf "target:motif/lisp/callbacks" :load t)
-  (comf "target:motif/lisp/widgets" :load t)
-  (comf "target:motif/lisp/main" :load t))
-
-(xt::build-toolkit-interface)
-
-(with-compilation-unit
-    ()
-  (comf "target:interface/initial" :load t)
-  (comf "target:interface/interface" :load t)
-  (comf "target:interface/inspect" :load t)
-  ;; We don't want to fall into the Motif debugger while compiling.
-  ;; It may be that the motifd server hasn't been (re)compiled yet.
-  (let ((interface:*interface-style* :tty))
-    (comf "target:interface/debug" :load t)))
diff --git a/tools/clxcom.lisp b/tools/clxcom.lisp
deleted file mode 100644
index 80e9d9dde90fb664f9a4e1cd844330fc922e74b3..0000000000000000000000000000000000000000
--- a/tools/clxcom.lisp
+++ /dev/null
@@ -1,90 +0,0 @@
-(in-package "USER")
-
-#+bootstrap
-(unless (find-package "OLD-XLIB")
-  (when (find-package "XLIB")
-    (rename-package (find-package "XLIB") "OLD-XLIB"))
-  
-  (make-package "XLIB" :use '("LISP")))
-
-(with-compiler-log-file
-    ("target:compile-clx.log"
-     :optimize
-     '(optimize (debug-info #-small 2 #+small .5) 
-		(speed 2) (inhibit-warnings 2)
-		(safety #-small 1 #+small 0))
-     :optimize-interface
-     '(optimize-interface (debug-info .5))
-     :context-declarations
-     '(((:and :external :global)
-	(declare (optimize-interface (safety 2) (debug-info 1))))
-       ((:and :external :macro)
-	(declare (optimize (safety 2))))))
-  (let ((c::*suppress-values-declaration* t))
-    (comf "target:clx/package" :load t)
-    (comf "target:clx/defsystem" :load t)
-    (comf "target:clx/depdefs" :load t)
-    (comf "target:clx/clx" :load t)
-    (comf "target:clx/dependent" :load t)
-    (comf "target:clx/macros")	; these are just macros
-    (load "target:clx/macros")
-    (comf "target:clx/bufmac")	; these are just macros
-    (load "target:clx/bufmac")
-    (comf "target:clx/buffer" :load t)
-    (comf "target:clx/display" :load t)
-    (comf "target:clx/gcontext" :load t)
-    (comf "target:clx/input" :load t)
-    (comf "target:clx/requests" :load t)
-    (comf "target:clx/fonts" :load t)
-    (comf "target:clx/graphics" :load t)
-    (comf "target:clx/text" :load t)
-    (comf "target:clx/attributes" :load t)
-    (comf "target:clx/translate" :load t)
-    (comf "target:clx/keysyms" :load t)
-    (comf "target:clx/manager" :load t)
-    (comf "target:clx/image" :load t)
-    (comf "target:clx/resource" :load t))
-  (comf "target:code/clx-ext")
-  (comf "target:hemlock/charmacs" :load t)
-  (comf "target:hemlock/key-event" :load t)
-  (comf "target:hemlock/keysym-defs" :load t)
-
-  #+pcl
-  (comf "target:code/inspect"))
-
-(ext:run-program
- "cat"
- (mapcar #'(lambda (x)
-	     (namestring
-	      (truename
-	       (make-pathname
-		:defaults x
-		:type (c:backend-fasl-file-type c:*target-backend*)))))
-	 '(
-	   "target:clx/package"
-	   "target:clx/depdefs"
-	   "target:clx/clx"
-	   "target:clx/dependent"
-	   "target:clx/macros"
-	   "target:clx/bufmac"
-	   "target:clx/buffer"
-	   "target:clx/display"
-	   "target:clx/gcontext"
-	   "target:clx/input"
-	   "target:clx/requests"
-	   "target:clx/fonts"
-	   "target:clx/graphics"
-	   "target:clx/text"
-	   "target:clx/attributes"
-	   "target:clx/translate"
-	   "target:clx/keysyms"
-	   "target:clx/manager"
-	   "target:clx/image"
-	   "target:clx/resource"
-	   "target:code/clx-ext"
-	   "target:hemlock/charmacs"
-	   "target:hemlock/key-event"
-	   "target:hemlock/keysym-defs"))
- :if-output-exists :supersede
- :output (make-pathname :defaults "target:clx/clx-library"
-			:type (c:backend-fasl-file-type c:*target-backend*)))
diff --git a/tools/comcom.lisp b/tools/comcom.lisp
deleted file mode 100644
index a1cdb9235986f2417de0713f0af6191f1292eadc..0000000000000000000000000000000000000000
--- a/tools/comcom.lisp
+++ /dev/null
@@ -1,311 +0,0 @@
-;;; -*- Package: User -*-
-;;;
-(in-package "USER")
-
-#+bootstrap
-(copy-packages (cons (c::backend-name c::*target-backend*) '("NEW-ASSEM" "C")))
-
-(defparameter *load-stuff*
-  #+bootstrap t
-  #-bootstrap (eq c:*backend* c:*native-backend*))
-
-;;; Import so that these types which appear in the globldb are the same...
-#+bootstrap
-(import '(old-c::approximate-function-type
-	  old-c::function-info old-c::defstruct-description
-	  old-c::defstruct-slot-description)
-	"C")
-
-(with-compiler-log-file
-    ("target:compile-compiler.log"
-     :optimize
-     '(optimize (speed 2) (space 2) (inhibit-warnings 2)
-		(safety #+small 0 #-small 1)
-		(debug-info #+small .5 #-small 2))
-     :optimize-interface
-     '(optimize-interface (safety #+small 1 #-small 2)
-			  (debug-info #+small .5 #-small 2))
-     :context-declarations
-     '(#+small
-       ((:or :macro
-	     (:match "$SOURCE-TRANSFORM-" "$IR1-CONVERT-"
-		     "$PRIMITIVE-TRANSLATE-" "$PARSE-"))
-	(declare (optimize (safety 1))))
-       (:external (declare (optimize-interface (safety 2) (debug-info 1))))))
-
-(comf "target:compiler/macros" :load *load-stuff*)
-(comf "target:compiler/generic/vm-macs" :load *load-stuff* :proceed t)
-(comf "target:compiler/backend" :load *load-stuff* :proceed t)
-
-(defvar c::*target-backend* (c::make-backend))
-
-(when (c:target-featurep :pmax)
-  (comf "target:compiler/mips/parms" :proceed t))
-(when (c:target-featurep :sparc)
-  (comf "target:compiler/sparc/parms" :proceed t))
-(when (c:target-featurep :rt)
-  (comf "target:compiler/rt/params" :proceed t))
-(when (c:target-featurep :hppa)
-  (comf "target:compiler/hppa/parms" :proceed t))
-(when (c:target-featurep :x86)
-  (comf "target:compiler/hppa/x86" :proceed t))
-(comf "target:compiler/generic/objdef" :proceed t)
-(comf "target:compiler/generic/interr")
-
-(comf "target:code/struct") ; For defstruct description structures.
-(comf "target:compiler/proclaim") ; For COOKIE structure.
-(comf "target:compiler/globals")
-
-(comf "target:compiler/type")
-(comf "target:compiler/generic/vm-type")
-(comf "target:compiler/type-init")
-(comf "target:compiler/sset")
-(comf "target:compiler/node")
-(comf "target:compiler/ctype")
-(comf "target:compiler/vop" :proceed t)
-(comf "target:compiler/vmdef")
-(comf "target:compiler/meta-vmdef" :load *load-stuff* :proceed t)
-
-(comf "target:compiler/disassem")
-(comf "target:compiler/new-assem")
-(comf "target:compiler/alloc")
-(comf "target:compiler/knownfun")
-(comf "target:compiler/fndb")
-(comf "target:compiler/generic/vm-fndb")
-(comf "target:compiler/main")
-
-(with-compilation-unit
-    (:optimize '(optimize (debug-info 2) (safety 1)))
-  (comf "target:compiler/ir1tran")
-  (comf "target:compiler/ir1util")
-  (comf "target:compiler/ir1opt"))
-
-(comf "target:compiler/ir1final")
-(comf "target:compiler/srctran")
-(comf "target:compiler/array-tran")
-(comf "target:compiler/seqtran")
-(comf "target:compiler/typetran")
-(comf "target:compiler/generic/vm-typetran")
-(comf "target:compiler/float-tran")
-(comf "target:compiler/saptran")
-(comf "target:compiler/locall")
-(comf "target:compiler/dfo")
-(comf "target:compiler/checkgen")
-(comf "target:compiler/constraint")
-(comf "target:compiler/envanal")
-
-(comf "target:compiler/tn")
-(comf "target:compiler/bit-util")
-(comf "target:compiler/life")
-
-(comf "target:code/debug-info")
-
-(comf "target:compiler/debug-dump")
-(comf "target:compiler/generic/utils")
-(comf "target:assembly/assemfile" :load *load-stuff*)
-
-(with-compilation-unit
-    (:optimize '(optimize (safety #+small 0 #-small 1) #+small (debug-info 1)))
-
-(when (c:target-featurep :pmax)
-  (comf "target:compiler/mips/insts")
-  (comf "target:compiler/mips/macros" :load *load-stuff*)
-  (comf "target:compiler/mips/vm")
-  (comf "target:compiler/generic/primtype")
-  (comf "target:assembly/mips/support" :load *load-stuff*)
-  (comf "target:compiler/mips/move")
-  (comf "target:compiler/mips/float")
-  (comf "target:compiler/mips/sap")
-  (comf "target:compiler/mips/system")
-  (comf "target:compiler/mips/char")
-  (comf "target:compiler/mips/memory")
-  (comf "target:compiler/mips/static-fn")
-  (comf "target:compiler/mips/arith")
-  (comf "target:compiler/mips/subprim")
-  (comf "target:compiler/mips/debug")
-  (comf "target:compiler/mips/c-call")
-  (comf "target:compiler/mips/cell")
-  (comf "target:compiler/mips/values")
-  (comf "target:compiler/mips/alloc")
-  (comf "target:compiler/mips/call")
-  (comf "target:compiler/mips/nlx")
-  (comf "target:compiler/mips/print")
-  (comf "target:compiler/mips/array")
-  (comf "target:compiler/mips/pred")
-  (comf "target:compiler/mips/type-vops")
-
-  (comf "target:assembly/mips/assem-rtns")
-  (comf "target:assembly/mips/array")
-  (comf "target:assembly/mips/arith")
-  (comf "target:assembly/mips/alloc"))
-
-(when (c:target-featurep :sparc)
-  (comf "target:compiler/sparc/insts")
-  (comf "target:compiler/sparc/macros" :load *load-stuff*)
-  (comf "target:compiler/sparc/vm")
-  (comf "target:compiler/generic/primtype")
-  (comf "target:compiler/sparc/move")
-  (comf "target:compiler/sparc/float")
-  (comf "target:compiler/sparc/sap")
-  (comf "target:compiler/sparc/system")
-  (comf "target:compiler/sparc/char")
-  (comf "target:compiler/sparc/memory")
-  (comf "target:compiler/sparc/static-fn")
-  (comf "target:compiler/sparc/arith")
-  (comf "target:compiler/sparc/subprim")
-  (comf "target:compiler/sparc/debug")
-  (comf "target:compiler/sparc/c-call")
-  (comf "target:compiler/sparc/cell")
-  (comf "target:compiler/sparc/values")
-  (comf "target:compiler/sparc/alloc")
-  (comf "target:compiler/sparc/call")
-  (comf "target:compiler/sparc/nlx")
-  (comf "target:compiler/sparc/print")
-  (comf "target:compiler/sparc/array")
-  (comf "target:compiler/sparc/pred")
-  (comf "target:compiler/sparc/type-vops")
-
-  (comf "target:assembly/sparc/support" :load *load-stuff*)
-  (comf "target:assembly/sparc/assem-rtns")
-  (comf "target:assembly/sparc/array")
-  (comf "target:assembly/sparc/arith")
-  (comf "target:assembly/sparc/alloc"))
-
-(when (c:target-featurep :rt)
-  (comf "target:compiler/rt/insts")
-  (comf "target:compiler/rt/macros" :load *load-stuff*)
-  (comf "target:compiler/rt/vm")
-  (comf "target:compiler/rt/move")
-  (if (c:target-featurep :afpa)
-      (comf "target:compiler/rt/afpa")
-      (comf "target:compiler/rt/mc68881"))
-  (comf "target:compiler/rt/sap")
-  (comf "target:compiler/rt/system")
-  (comf "target:compiler/rt/char")
-  (comf "target:compiler/rt/memory")
-  (comf "target:compiler/rt/static-fn")
-  (comf "target:compiler/rt/arith")
-  (comf "target:compiler/rt/subprim")
-  (comf "target:compiler/rt/debug")
-  (comf "target:compiler/rt/c-call")
-  (comf "target:compiler/rt/cell")
-  (comf "target:compiler/rt/values")
-  (comf "target:compiler/rt/alloc")
-  (comf "target:compiler/rt/call")
-  (comf "target:compiler/rt/nlx")
-  (comf "target:compiler/rt/print")
-  (comf "target:compiler/rt/array")
-  (comf "target:compiler/rt/pred")
-  (comf "target:compiler/rt/type-vops")
-
-  (comf "target:assembly/rt/support" :load *load-stuff*)
-  (comf "target:assembly/rt/assem-rtns")
-  (comf "target:assembly/rt/array")
-  (comf "target:assembly/rt/arith")
-  (comf "target:assembly/rt/alloc"))
-
-(when (c:target-featurep :hppa)
-  (comf "target:compiler/hppa/insts")
-  (comf "target:compiler/hppa/macros" :load *load-stuff*)
-  (comf "target:compiler/hppa/vm")
-  (comf "target:compiler/generic/primtype")
-  (comf "target:assembly/hppa/support" :load *load-stuff*)
-  (comf "target:compiler/hppa/move")
-  (comf "target:compiler/hppa/float")
-  (comf "target:compiler/hppa/sap")
-  (comf "target:compiler/hppa/system")
-  (comf "target:compiler/hppa/char")
-  (comf "target:compiler/hppa/memory")
-  (comf "target:compiler/hppa/static-fn")
-  (comf "target:compiler/hppa/arith")
-  (comf "target:compiler/hppa/subprim")
-  (comf "target:compiler/hppa/debug")
-  (comf "target:compiler/hppa/c-call")
-  (comf "target:compiler/hppa/cell")
-  (comf "target:compiler/hppa/values")
-  (comf "target:compiler/hppa/alloc")
-  (comf "target:compiler/hppa/call")
-  (comf "target:compiler/hppa/nlx")
-  (comf "target:compiler/hppa/print")
-  (comf "target:compiler/hppa/array")
-  (comf "target:compiler/hppa/pred")
-  (comf "target:compiler/hppa/type-vops")
-
-  (comf "target:assembly/hppa/assem-rtns")
-  (comf "target:assembly/hppa/array")
-  (comf "target:assembly/hppa/arith")
-  (comf "target:assembly/hppa/alloc"))
-
-(when (c:target-featurep :x86)
-  (comf "target:compiler/x86/insts")
-  (comf "target:compiler/x86/macros" :load *load-stuff*)
-  (comf "target:compiler/x86/vm")
-  (comf "target:compiler/generic/primtype")
-  (comf "target:assembly/x86/support" :load *load-stuff*)
-  (comf "target:compiler/x86/move")
-  (comf "target:compiler/x86/float")
-  (comf "target:compiler/x86/sap")
-  (comf "target:compiler/x86/system")
-  (comf "target:compiler/x86/char")
-  (comf "target:compiler/x86/memory")
-  (comf "target:compiler/x86/static-fn")
-  (comf "target:compiler/x86/arith")
-  (comf "target:compiler/x86/subprim")
-  (comf "target:compiler/x86/debug")
-  (comf "target:compiler/x86/c-call")
-  (comf "target:compiler/x86/cell")
-  (comf "target:compiler/x86/values")
-  (comf "target:compiler/x86/alloc")
-  (comf "target:compiler/x86/call")
-  (comf "target:compiler/x86/nlx")
-  (comf "target:compiler/x86/print")
-  (comf "target:compiler/x86/array")
-  (comf "target:compiler/x86/pred")
-  (comf "target:compiler/x86/type-vops")
-
-  (comf "target:assembly/x86/assem-rtns")
-  (comf "target:assembly/x86/array")
-  (comf "target:assembly/x86/arith")
-  (comf "target:assembly/x86/alloc"))
-
-(comf "target:compiler/pseudo-vops")
-
-); with-compilation-unit for back end.
-
-(comf "target:compiler/aliencomp")
-(comf "target:compiler/ltv")
-(comf "target:compiler/gtn")
-(with-compilation-unit
-    (:optimize '(optimize (debug-info 2) (safety 1)))
-  (comf "target:compiler/ltn"))
-(comf "target:compiler/stack")
-(comf "target:compiler/control")
-(comf "target:compiler/entry")
-(with-compilation-unit
-    (:optimize '(optimize (debug-info 2) (safety 1)))
-  (comf "target:compiler/ir2tran")
-  (comf "target:compiler/generic/vm-ir2tran"))
-(comf "target:compiler/copyprop")
-(with-compilation-unit
-    (:optimize '(optimize (debug-info 2) (safety 1)))
-  (comf "target:compiler/represent"))
-(comf "target:compiler/generic/vm-tran")
-(with-compilation-unit
-    (:optimize '(optimize (debug-info 2) (safety 1)))
-  (comf "target:compiler/pack"))
-(comf "target:compiler/codegen")
-(with-compilation-unit
-    (:optimize '(optimize (debug-info 2) (safety 2)))
-  (comf "target:compiler/debug"))
-(comf "target:compiler/statcount")
-(comf "target:compiler/dyncount")
-
-(comf "target:compiler/dump")
-
-(comf "target:compiler/generic/core")
-(comf "target:compiler/generic/new-genesis")
-
-(comf "target:compiler/eval-comp")
-(comf "target:compiler/eval")
-
-); with-compiler-error-log
diff --git a/tools/compile-all b/tools/compile-all
deleted file mode 100755
index 17a467d75dea9f24a7809b2a23072c7b23e6e912..0000000000000000000000000000000000000000
--- a/tools/compile-all
+++ /dev/null
@@ -1,247 +0,0 @@
-#!/bin/csh -f
-#
-#  compile-all -- script to compile everything
-#
-# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/Attic/compile-all,v 1.11 1992/11/11 15:37:47 garland Exp $
-
-set features = ()
-set misfeatures = ()
-set target = "@sys"
-set subdir = alpha
-set core = ""
-set clean = 0
-set update = 1
-set interactive = "nil"
-set bootstrap = "target:bootstrap"
-
-set systems = ""
-set nosystems = ""
-
-while ($#argv > 0)
-	if ("$argv[1]" !~ -*) then
-		set features = ($features $argv[1])
-	else
-		switch ($argv[1])
-
-# Select what system to compile, and how:
-			case "-target":
-				set target = $argv[2]
-				shift
-				breaksw
-			case "-release":
-				set subdir = $argv[2]
-				shift
-				breaksw
-			case "-lisp":
-				set lispdir = $argv[2]
-				shift
-				breaksw
-			case "-core":
-				set core = " -core $argv[2]"
-				shift
-				breaksw
-			case "-bootstrap":
-				set bootstrap = $argv[2]
-				shift
-				breaksw
-			case "-misfeature":
-			        set misfeatures = ($misfeatures $argv[2])
-				shift
-				breaksw
-			case "-interactive":
-				set interactive = "t"
-				breaksw
-
-# Source tree management:
-			case "-clean":
-				set clean = 1
-				breaksw
-			case "-noupdate":
-			        set update = 0
-				breaksw
-
-# Select what to compile:
-			case "-compile":
-			        set systems = $argv[2]
-				shift
-				breaksw
-			case "-nocompile":
-			        set nosystems = $argv[2]
-				shift
-				breaksw
-			default:
-				echo "Bogus switch: $argv[1]"
-				cat <<END_HELP
-Try these:
-  -target	[@sys]	
-	The machine to compile for: pmax_mach, sun4c_41 ...
-
-  -release	[alpha]
-	Which source tree to compile: alpha, exp/foo...
-
-  -lisp		[/afs/cs/misc/cmucl/@sys/<release> or /usr/misc/.cmucl/]
-	The directory to run Lisp out of.
-
-  -core		[<lisp>/lib/lisp.core]
-	The core file to run.
-
-  -bootstrap	[target:bootstrap]
-	File to load into lisp before compiling.
-
-  -interactive <no arg>
-	Print compiler output to terminal instead of log files.
-
-  -misfeature <feature>
-	Remove <feature> from the features when compiling.  May be used more
-	than once.
-
-  -clean <no arg>
-	Delete all *.*f, *.assem, *.log and *.log.OLD in the destination.
-
-  -noupdate <no arg>
-	If specified, inhibits rcsupdate of the source tree.
-
-  -compile	[All systems]
-	A comma-separated list of system names, e.g. "code,compiler".  Order is
-	not significant.  All systems are compiled by default.
-  
-  -nocompile	[No systems]
-	A comma-separated list of systems *not* to compile.  Only meaningful
-	when -compile is not specified.
-
-END_HELP
-
-				exit
-		endsw
-	endif
-	shift
-end
-
-if (! $?lispdir) then
-	set lispdir = /afs/cs/misc/cmucl/@sys/$subdir
-	if (! -e $lispdir) then
-		echo "Release $subdir not installed; using /usr/misc/.cmucl"
-		set lispdir = /usr/misc/.cmucl
-	endif
-endif
-setenv CMUCLLIB "$lispdir/lib"
-set lisp = "$lispdir/bin/lisp$core"
-
-if ($systems == "") then
-    if ($nosystems == "") then
-        echo "Will compile all systems ..."
-    else
-        echo "Will compile all systems except for: $nosystems ..."
-    endif
-else
-    echo "Will compile these systems: $systems ..."
-endif
-
-set src = ()
-set thissrc = /afs/cs/project/clisp/src/$subdir
-
-nother_source:
-
-set src = ($src \"$thissrc/\")
-
-if (-e $thissrc/FEATURES) then
-        set tmp = (`cat $thissrc/FEATURES`)
-        echo "Features from $thissrc/FEATURES file:" $tmp
-	set features = ($features $tmp)
-endif
-
-if (-e $thissrc/MISFEATURES) then
-        set tmp = (`cat $thissrc/MISFEATURES`)
-        echo "Misfeatures from $thissrc/MISFEATURES file:" $tmp
-	set misfeatures = ($misfeatures $tmp)
-endif
-
-if $update then
-    echo "Updating source directory $thissrc ..."
-    (cd $thissrc; rcsupdate -q)
-endif
-
-if (-e $thissrc/SHADOW) then
-    set thissrc = `cat $thissrc/SHADOW`
-    goto nother_source
-endif
-
-echo "Source directory(ies): $src"
-
-set dest = /afs/cs/project/clisp/build/$target/$subdir
-echo "Target directory: $dest"
-
-if $clean then
-    echo "Cleaning up binaries and logs in $dest ..."
-    (cd  $dest;\
-     find . \( -name '*.*f' -o -name '*.assem' \) -print -exec rm {} \; ;\
-     rm *.log *.log.OLD)
-else
-    if ({(echo $dest/*.log>/dev/null)}) then
-	echo "Preserving log files in $dest as .OLD ..."
-	foreach foo ( $dest/*.log )
-	    set old = "${foo}.OLD"
-	    if (-e $old) then
-	        echo "" >>$old
-		date >>$old
-		echo "_________________________________________">>$old
-		cat $foo >>$old
-		rm $foo
-	    else
-		mv $foo $old
-	    endif
-        end
-    endif
-endif
-
-if ($?LISP) then
-	echo "LISP environment variable override: $LISP"
-	set lisp = "$LISP"
-endif
-
-echo "Compiling setup and bootstrap ..."
-$lisp -noinit -eval '(eval (read))' << EOF
-(progn
-  (setf *features*
-	(set-difference (list* $features *features*) '($misfeatures)))
-  (setf (search-list "target:") '("$dest/" $src))
-  (setq *compile-verbose* nil *compile-print* nil) 
-  (load "target:tools/setup" :if-source-newer :load-source)
-  (setf *interactive* $interactive *gc-verbose* nil)
-  (comf "target:tools/setup" :load t)
-  (when (probe-file "${bootstrap}.lisp") (comf "$bootstrap"))
-  (quit))
-EOF
-
-set sysinfo = ("code worldcom"\
-	       "compiler comcom"\
-	       "clx clxcom"\
-	       "hemlock hemcom"\
-	       "pcl pclcom"\
-               "clm clmcom"\
-	       "genesis worldbuild")
-
-while ($#sysinfo > 0)
-    set system_vec = ($sysinfo[1]:x)
-    set this_system = $system_vec[1]
-    set this_comfile = $system_vec[2]
-    shift sysinfo
-    if ($systems =~ *${this_system}* || \
-        ($systems == "" && $nosystems !~ *${this_system}*)) then
-	echo "Compiling $this_system ..."
-	$lisp -noinit -eval '(eval (read))' << EOF
-(progn
-  (setf *features*
-	(set-difference (list* $features *features*) '($misfeatures)))
-  (setf (search-list "target:") '("$dest/" $src))
-  (setq *compile-verbose* nil *compile-print* nil)
-  (load "target:tools/setup")
-  (load "$bootstrap" :if-does-not-exist nil)
-  (setf *interactive* $interactive *gc-verbose* nil)
-  (load "target:tools/$this_comfile")
-  (quit))
-EOF
-   endif
-end
-
-echo "Done..."
diff --git a/tools/config b/tools/config
deleted file mode 100755
index 373ebedaaec7021ad4b834a95dd129e29b754616..0000000000000000000000000000000000000000
--- a/tools/config
+++ /dev/null
@@ -1,5 +0,0 @@
-#!/bin/sh
-#
-# This file script invokes CMU CL with the Lisp configuration script, which
-# will go into an interactive dialog to determine what systems to load.
-lisp -eval '(load (open "library:config.lisp"))' -noinit
diff --git a/tools/config.lisp b/tools/config.lisp
deleted file mode 100644
index eec146a2609e22f2590230b2affba363d811ba29..0000000000000000000000000000000000000000
--- a/tools/config.lisp
+++ /dev/null
@@ -1,96 +0,0 @@
-;;; -*- Mode: Lisp; Package: System -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/config.lisp,v 1.1 1992/05/29 14:08:34 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; Utility to load subsystems and save a new core.
-;;;
-(in-package "USER")
-
-
-(block abort
-  (let ((output-file #p"library:lisp.core")
-	(load-clx t)
-	(load-hemlock t)
-	(other ()))
-    (loop
-      (fresh-line)
-      (format t " 1: specify result file (currently ~S)~%"
-	      (namestring output-file))
-      (format t " 2: ~:[enable~;disable~] loading of the CLX X library.~%"
-	      load-clx)
-      (format t " 3: ~:[enable~;disable~] loading the Hemlock editor~
-		 ~:[ (forces loading of CLX.)~;.~]~%"
-	      load-hemlock load-hemlock)
-      (format t " 4: specify some site-specific file to load.~@
-		 ~@[    Current files:~%~{      ~S~%~}~]"
-	      (mapcar #'namestring other))
-      (format t " 5: configure according to current options.~%")
-      (format t " 6: abort the configuration process.~%")
-      (format t "~%Option number: ")
-      (force-output)
-      (flet ((file-prompt (prompt)
-	       (format t prompt)
-	       (force-output)
-	       (pathname (string-trim " 	" (read-line)))))
-	(let ((res (ignore-errors (read-from-string (read-line)))))
-	  (case res
-	    (1
-	     (setq output-file (file-prompt "Result core file name: ")))
-	    (2
-	     (unless (setq load-clx (not load-clx))
-	       (setq load-hemlock nil)))
-	    (3
-	     (when (setq load-hemlock (not load-hemlock))
-	       (setq load-clx t)))
-	    (4
-	     (setq other
-		   (append other
-			   (list (file-prompt "File(s) to load ~
-					       (can have wildcards): ")))))
-	    (5 (return))
-	    (6
-	     (format t "~%Aborted.~%")
-	     (return-from abort))))))
-    
-    (gc-off)
-    (when load-clx
-      (load "library:subsystems/clx-library"))
-    (when load-hemlock
-      (load "library:subsystems/hemlock-library"))
-    (dolist (f other) (load f))
-    
-    (setq *info-environment*
-	  (list* (make-info-environment :name "Working")
-		 (compact-info-environment (first *info-environment*)
-					   :name "Auxiliary")
-		 (rest *info-environment*)))
-    
-    (when (probe-file output-file)
-      (multiple-value-bind
-	  (ignore old new)
-	  (rename-file output-file
-		       (concatenate 'string (namestring output-file)
-				    ".BAK"))
-	(declare (ignore ignore))
-	(format t "~&Saved ~S as ~S.~%" (namestring old) (namestring new))))
-    
-    ;;
-    ;; Enable the garbage collector.  But first fake it into thinking that
-    ;; we don't need to garbage collect.  The save-lisp is going to call
-    ;; purify so any garbage will be collected then.
-    (setf lisp::*need-to-collect-garbage* nil)
-    (gc-on)
-    ;;
-    ;; Save the lisp.
-    (save-lisp output-file)))
-
-(quit)
diff --git a/tools/do-worldbuild b/tools/do-worldbuild
deleted file mode 100755
index 8c1aa731a3f7e39d131dd6293726a8bf570e39a9..0000000000000000000000000000000000000000
--- a/tools/do-worldbuild
+++ /dev/null
@@ -1,29 +0,0 @@
-#!/bin/csh -fx
-#
-#  do-worldbuild -- script to run worldbuild
-#
-# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/Attic/do-worldbuild,v 1.3 1992/02/26 01:11:18 wlott Exp $
-
-if ($#argv) then
-	set subdir = $argv[1]
-else
-	set subdir = alpha
-endif
-
-set dest = /afs/cs/project/clisp/build/@sys/$subdir
-set src = /afs/cs/project/clisp/src/$subdir
-
-if ($?LISP) then
-	set lisp = "$LISP"
-else
-	set lisp = lisp
-endif
-
-$lisp -noinit << EOF
-(setf (search-list "target:") '("$dest/" "$src/"))
-(load "target:bootstrap" :if-does-not-exist nil)
-(load "target:tools/setup")
-(load "target:compiler/generic/genesis")
-(load "target:tools/worldbuild")
-(quit)
-EOF
diff --git a/tools/dupsrcs.c b/tools/dupsrcs.c
deleted file mode 100644
index 078186be2cb5d9720313cbf62ff6392103728578..0000000000000000000000000000000000000000
--- a/tools/dupsrcs.c
+++ /dev/null
@@ -1,83 +0,0 @@
-#include <stdio.h>
-#include <sys/types.h>
-#include <sys/dir.h>
-#include <sys/stat.h>
-#include <sys/errno.h>
-#include <sys/param.h>
-
-/* Duplicates a source tree. */
-
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/Attic/dupsrcs.c,v 1.2 1991/11/07 22:55:36 wlott Exp $ */
-
-void duptree(srcdir, dstdir)
-char *srcdir, *dstdir;
-{
-    DIR *dir;
-    struct direct *entry;
-    char srcpath[MAXPATHLEN], dstpath[MAXPATHLEN];
-    struct stat buf;
-
-    printf("Duplicating %s\n  into %s\n", srcdir, dstdir);
-
-    /* Make sure the dstdir is there. */
-    if (mkdir(dstdir) == 0)
-	printf("Creating %s\n", dstdir);
-
-    dir = opendir(srcdir);
-    if (dir == NULL) {
-	perror(srcdir);
-	return;
-    }
-
-    while ((entry = readdir(dir)) != NULL) {
-	if (strncmp(entry->d_name, "RCS", 3) == 0)
-	    continue;
-	if (entry->d_name[0] == '.')
-	    continue;
-	sprintf(srcpath, "%s/%s", srcdir, entry->d_name);
-	sprintf(dstpath, "%s/%s", dstdir, entry->d_name);
-	if (stat(srcpath, &buf) < 0) {
-	    perror(srcpath);
-	    continue;
-	}
-	if ((buf.st_mode & S_IFMT) == S_IFDIR)
-	    duptree(srcpath, dstpath);
-	else
-	    if (symlink(srcpath, dstpath) == 0)
-		printf("Linked %s\n", dstpath);
-	    else
-		if (errno != EEXIST)
-		    perror(dstpath);
-    }
-
-    closedir(dir);
-}
-
-main(argc, argv)
-int argc;
-char *argv[];
-{
-    char *subdir;
-    char srcdir[MAXPATHLEN], dstdir[MAXPATHLEN];
-
-    if (argc > 2) {
-	fprintf(stderr, "usage: dupsrcs [ subdir ]\n");
-	exit(1);
-    }
-
-    if (argc == 2)
-	subdir = argv[1];
-    else
-	subdir = "alpha";
-
-    getwd(dstdir);
-
-    sprintf(srcdir, "/afs/cs/project/clisp/src/%s", subdir);
-    if (chdir(srcdir) < 0) {
-	perror(srcdir);
-	exit(1);
-    }
-    getwd(srcdir);
-
-    duptree(srcdir, dstdir);
-}
diff --git a/tools/fixheader b/tools/fixheader
deleted file mode 100755
index 059032d566ca6660d2e10a230268b20d6ff81f20..0000000000000000000000000000000000000000
--- a/tools/fixheader
+++ /dev/null
@@ -1,39 +0,0 @@
-#!/bin/csh -f
-#
-# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/Attic/fixheader,v 1.2 1992/02/03 01:46:58 ram Exp $
-
-set quotehack = \$"Header: "\$
-
-foreach file ($argv)
-	set range = (`fgrep -n ';;; ***********' $file | sed -e '3,$d' -e 's/:.*//'`)
-	if ($#range < 2) then
-		echo '**********' $file'': Could not find the header comment.
-		goto nextfile
-	endif
-	if ($range[2] > 12) then
-		echo '**********' $file'': Large header comment, you deal with it.
-		goto nextfile
-	endif
-
-	echo fixing $file
-
-	ed $file <<END_OF_ED_STUFF
-$range[1],$range[2]d
-$range[1]i
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$quotehack")
-;;;
-;;; **********************************************************************
-.
-w
-q
-END_OF_ED_STUFF
-
-	nextfile:
-end
diff --git a/tools/hemcom.lisp b/tools/hemcom.lisp
deleted file mode 100644
index bbf59b8eac8072f53eac2880e715d5c182933ae0..0000000000000000000000000000000000000000
--- a/tools/hemcom.lisp
+++ /dev/null
@@ -1,167 +0,0 @@
-;;;
-;;; This file compiles all of Hemlock.
-;;;
-
-(when (ext:get-command-line-switch "slave")
-  (error "Cannot compile Hemlock in a slave due to its clobbering needed
-	  typescript routines by renaming the package."))
-
-
-;;; Blast the old packages in case they are around.  We do this solely to
-;;; prove Hemlock can compile cleanly without its having to exist already.
-;;;
-(when (find-package "ED")
-  (rename-package (find-package "ED") "OLD-ED"))
-;;;
-(when (find-package "HI")
-  (rename-package (find-package "HI") "OLD-HI"))
-
-
-;;; Stuff to set up the packages Hemlock uses.
-;;;
-(in-package "HEMLOCK-INTERNALS"
-	    :nicknames '("HI")
-	    :use '("LISP" "EXTENSIONS" "SYSTEM"))
-;;;
-(in-package "HEMLOCK"
-	    :nicknames '("ED")
-	    :use '("LISP" "HEMLOCK-INTERNALS" "EXTENSIONS" "SYSTEM"))
-;;;
-(in-package "SYSTEM")
-(export '(%sp-byte-blt %sp-find-character %sp-find-character-with-attribute
-		       %sp-reverse-find-character-with-attribute))
-
-(in-package "HEMLOCK-INTERNALS")
-
-
-(pushnew :command-bits *features*)
-(pushnew :buffered-lines *features*)
-
-(defparameter the-log-file "hem:lossage.log")
-
-(when (probe-file the-log-file)
-  (delete-file the-log-file))
-
-(defun cf (file &key load)
-  (write-line file)
-  (finish-output nil)
-  (let ((*error-output* (open the-log-file
-			      :direction :output 
-			      :if-exists :append
-			      :if-does-not-exist :create)))
-    (unwind-protect
-	(progn
-	  (compile-file file :error-file nil)
-	  (terpri *error-output*) (terpri *error-output*)
-	  (when load
-	    (let ((fasl (make-pathname :device (pathname-device file)
-				       :directory (pathname-directory file)
-				       :name (pathname-name file)
-				       :type "fasl")))
-	      (write-string "Loading ")
-	      (write-line (namestring fasl))
-	      (load fasl))))
-      (close *error-output*))))
-
-(cf "hem:struct.lisp")
-(cf "hem:struct-ed.lisp")
-(cf "hem:rompsite.lisp")
-(cf "hem:charmacs.lisp")
-
-(cf "hem:key-event.lisp" :load t)
-;;;
-;;; This is necessary since all the #k uses in Hemlock will expand into
-;;; EXT:MAKE-KEY-EVENT calls with keysyms and bits from the compiling Lisp, not
-;;; for the Lisp new code will run in.  This destroys the compiling Lisp with
-;;; respect to running code with #k's compiled for it, but it causes the
-;;; compilation to see new keysyms, modifiers, and CLX modifier maps correctly
-;;; for the new system.
-;;;
-(ext::re-initialize-key-events)
-(cf "hem:keysym-defs.lisp" :load t)
-
-(cf "hem:input.lisp")
-(cf "hem:macros.lisp")
-(cf "hem:line.lisp")
-(cf "hem:ring.lisp")
-(cf "hem:table.lisp")
-(cf "hem:htext1.lisp")
-(cf "hem:htext2.lisp")
-(cf "hem:htext3.lisp")
-(cf "hem:htext4.lisp")
-(cf "hem:search1.lisp")
-(cf "hem:search2.lisp")
-(cf "hem:linimage.lisp")
-(cf "hem:cursor.lisp")
-(cf "hem:syntax.lisp")
-(cf "hem:winimage.lisp")
-(cf "hem:hunk-draw.lisp")
-;(cf "hem:bit-stream.lisp")
-(cf "hem:termcap.lisp")
-(cf "hem:display.lisp")
-(cf "hem:bit-display.lisp")
-(cf "hem:tty-disp-rt.lisp")
-(cf "hem:tty-display.lisp")
-;(cf "hem:tty-stream.lisp")
-(cf "hem:pop-up-stream.lisp")
-(cf "hem:screen.lisp")
-(cf "hem:bit-screen.lisp")
-(cf "hem:tty-screen.lisp")
-(cf "hem:window.lisp")
-(cf "hem:font.lisp")
-(cf "hem:interp.lisp")
-(cf "hem:vars.lisp")
-(cf "hem:buffer.lisp")
-(cf "hem:files.lisp")
-(cf "hem:streams.lisp")
-(cf "hem:echo.lisp")
-(cf "hem:main.lisp")
-(cf "hem:echocoms.lisp")
-(cf "hem:defsyn.lisp")
-(cf "hem:command.lisp")
-(cf "hem:morecoms.lisp")
-(cf "hem:undo.lisp")
-(cf "hem:killcoms.lisp")
-(cf "hem:searchcoms.lisp")
-(cf "hem:filecoms.lisp")
-(cf "hem:indent.lisp")
-(cf "hem:lispmode.lisp")
-(cf "hem:comments.lisp")
-(cf "hem:fill.lisp")
-(cf "hem:text.lisp")
-(cf "hem:doccoms.lisp")
-(cf "hem:srccom.lisp")
-(cf "hem:group.lisp")
-(cf "hem:spell-rt.lisp")
-(cf "hem:spell-corr.lisp")
-(cf "hem:spell-aug.lisp")
-(cf "hem:spell-build.lisp")
-(cf "hem:spellcoms.lisp")
-(cf "hem:abbrev.lisp")
-(cf "hem:overwrite.lisp")
-(cf "hem:gosmacs.lisp")
-(cf "hem:ts-buf.lisp")
-(cf "hem:ts-stream.lisp")
-(cf "hem:eval-server.lisp")
-(cf "hem:lispbuf.lisp")
-(cf "hem:lispeval.lisp")
-(cf "hem:kbdmac.lisp")
-(cf "hem:icom.lisp")
-(cf "hem:hi-integrity.lisp")
-(cf "hem:ed-integrity.lisp")
-(cf "hem:scribe.lisp")
-(cf "hem:pascal.lisp")
-(cf "hem:edit-defs.lisp")
-(cf "hem:auto-save.lisp")
-(cf "hem:register.lisp")
-(cf "hem:xcoms.lisp")
-(cf "hem:unixcoms.lisp")
-(cf "hem:mh.lisp")
-(cf "hem:highlight.lisp")
-(cf "hem:dired.lisp")
-(cf "hem:diredcoms.lisp")
-(cf "hem:bufed.lisp")
-(cf "hem:lisp-lib.lisp")
-(cf "hem:completion.lisp")
-(cf "hem:shell.lisp")
-(cf "hem:bindings.lisp")
diff --git a/tools/hemload.lisp b/tools/hemload.lisp
deleted file mode 100644
index a9011d0e5e4742fd797856b44517463ad064bab9..0000000000000000000000000000000000000000
--- a/tools/hemload.lisp
+++ /dev/null
@@ -1,124 +0,0 @@
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/hemload.lisp,v 1.3 1991/07/29 08:56:59 chiles Rel $")
-;;;
-;;; **********************************************************************
-;;;
-;;; This file loads all of Hemlock.
-;;;
-
-;;; Stuff to set up the packages Hemlock uses.
-;;;
-(in-package "HEMLOCK-INTERNALS"
-	    :nicknames '("HI")
-	    :use '("LISP" "EXTENSIONS" "SYSTEM"))
-;;;
-(in-package "HEMLOCK"
-	    :nicknames '("ED")
-	    :use '("LISP" "HEMLOCK-INTERNALS" "EXTENSIONS" "SYSTEM"))
-;;;
-(in-package "SYSTEM")
-(export '(%sp-byte-blt %sp-find-character %sp-find-character-with-attribute
-		       %sp-reverse-find-character-with-attribute))
-;;;
-(in-package "HI")
-
-
-(defun build-hemlock ()
-  (load "hem:struct")
-;  (load "hem:struct-ed")
-  (load "hem:charmacs")
-  (load "hem:key-event")
-  (ext::re-initialize-key-events)
-  (load "hem:keysym-defs")
-  (load "hem:input")
-  (load "hem:line")
-  (load "hem:ring")
-  (load "hem:vars")
-  (load "hem:buffer")
-  (load "hem:macros")
-  (load "hem:interp")
-  (load "hem:syntax")
-  (load "hem:htext1")
-  (load "hem:htext2")
-  (load "hem:htext3")
-  (load "hem:htext4")
-  (load "hem:files")
-  (load "hem:search1")
-  (load "hem:search2")
-  (load "hem:table")
-  #+clx (load "hem:hunk-draw")
-;  (load "hem:bit-stream")
-  (load "hem:window")
-  (load "hem:screen")
-  (load "hem:winimage")
-  (load "hem:linimage")
-  (load "hem:display")
-  (load "hem:termcap")
-  #+clx (load "hem:bit-display")
-  (load "hem:tty-disp-rt")
-  (load "hem:tty-display")
-;  (load "hem:tty-stream")
-  (load "hem:pop-up-stream")
-  #+clx (load "hem:bit-screen")
-  (load "hem:tty-screen")
-  (load "hem:cursor")
-  (load "hem:font")
-  (load "hem:streams")
-  (load "hem:main")
-  (load "hem:hacks")
-  (%init-hemlock)
-  (load "hem:echo")
-  (load "hem:echocoms")
-  (load "hem:command")
-  (load "hem:indent")
-  (load "hem:comments")
-  (load "hem:morecoms")
-  (load "hem:undo")
-  (load "hem:killcoms")
-  (load "hem:searchcoms")
-  (load "hem:filecoms")
-  (load "hem:doccoms")
-  (load "hem:srccom")
-  (load "hem:group")
-  (load "hem:fill")
-  (load "hem:text")
-  (load "hem:lispmode")
-  (load "hem:ts-buf")
-  (load "hem:ts-stream")
-  (load "hem:eval-server")
-  (load "hem:lispbuf")
-  (load "hem:lispeval")
-  (load "hem:spell-rt")
-  (load "hem:spell-corr")
-  (load "hem:spell-aug")
-  (load "hem:spellcoms")
-  (load "hem:overwrite")
-  (load "hem:abbrev")
-  (load "hem:icom")
-  (load "hem:kbdmac")
-  (load "hem:defsyn")
-  (load "hem:scribe")
-  (load "hem:pascal")
-  (load "hem:edit-defs")
-  (load "hem:auto-save")
-  (load "hem:register")
-  (load "hem:xcoms")
-  (load "hem:unixcoms")
-  (load "hem:mh")
-  (load "hem:highlight")
-  (load "hem:dired")
-  (load "hem:diredcoms")
-  (load "hem:bufed")
-  (load "hem:lisp-lib")
-  (load "hem:completion")
-  (load "hem:shell")
-  (load "hem:debug")
-  (load "hem:netnews")
-  (load "hem:bindings"))
diff --git a/tools/inst-lisp b/tools/inst-lisp
deleted file mode 100755
index cc4234704220c446e66125e31e53e06432f719f3..0000000000000000000000000000000000000000
--- a/tools/inst-lisp
+++ /dev/null
@@ -1,19 +0,0 @@
-#!/bin/csh -fx
-#
-# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/Attic/inst-lisp,v 1.4 1992/09/08 22:28:25 wlott Exp $
-#
-# Utility for installing an alpha core.
-#
-
-if ($#argv) then
-	set subdir = $argv[1]
-else
-	set subdir = alpha
-endif
-
-set src = /afs/cs/project/clisp/build/@sys/$subdir
-set dst = /afs/cs/project/clisp-3/alphas/@sys
-
-rm -f $dst/lisp $dst/lisp.core
-cp -p $src/lisp/lisp $dst/lisp
-cp -p lisp.core $dst/lisp.core
diff --git a/tools/mk-lisp b/tools/mk-lisp
deleted file mode 100755
index 568fcd6944b81c04b838742e36021432d8364f69..0000000000000000000000000000000000000000
--- a/tools/mk-lisp
+++ /dev/null
@@ -1,80 +0,0 @@
-#!/bin/csh -f
-#
-#  mk-lisp -- script for building full lisp cores.
-#
-# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/Attic/mk-lisp,v 1.15 1992/09/08 22:28:09 wlott Exp $
-
-if ($#argv) then
-    if ($argv[1] == "-now") then
-	set later = 0
-	shift
-    else
-	set later = 1
-    endif
-else
-    set later = 1
-endif
-
-if ($later) then
-    set delay = (205 45 15 0)
-    set msg = ("in 5 minutes" "in 1 minute" "in 15 seconds" "now")
-  nextmsg:
-    foreach name (`who | sed -e 's/\([^ ]*\)  *\([^ ]*\) .*/\1:\2/'`)
-	echo Building core $msg[1] | write `echo $name | sed -e 's/:/ /'`
-    end
-    sleep $delay[1]
-    shift delay
-    shift msg
-    if ($#delay) goto nextmsg
-endif
-
-if ($#argv) then
-	set subdir = $argv[1]
-	set features = ($argv[2-])
-else
-	set subdir = alpha
-	set features = ()
-endif
-
-if $?CMUCL_ROOT then
-	set root = $CMUCL_ROOT
-else
-	set root = /afs/cs/project/clisp
-endif
-
-set dest = $root/build/@sys/$subdir
-set src = $root/src/$subdir
-
-if (-e $dest/lisp/kernel.core) then
-	set core = $dest/lisp/kernel.core
-else
-	if (-e /usr/tmp/kernel.core) then
-		set core = /usr/tmp/kernel.core
-	else
-		echo Can\'t find the kernel.core
-	endif
-endif
-
-if (-e $src/VERSION) then
-	set version = `cat $src/VERSION`
-else
-	set version = `/bin/date | awk '{print $3 "-" $2 "-" $6}'`
-endif
-
-if (-e $src/FEATURES) then
-	set features = ($features `cat $src/FEATURES`)
-endif
-
-echo Building lisp.core version $version from the \`\`$subdir\'\' subdir.
-echo "Features: $features"
-
-$dest/lisp/lisp -core $core << EOF
-(setf *features* (list* $features *features*))
-(setf (search-list "lisp:") '("$dest/" "$src/"))
-(in-package "USER")
-(load (open "lisp:tools/worldload.lisp"))
-$version
-(quit)
-EOF
-
-echo 
diff --git a/tools/pclcom.lisp b/tools/pclcom.lisp
deleted file mode 100644
index 6c9e5fa0954ffc03af27207e5d9b9dfac2895808..0000000000000000000000000000000000000000
--- a/tools/pclcom.lisp
+++ /dev/null
@@ -1,31 +0,0 @@
-
-(in-package "USER")
-
-(when (find-package "PCL")
-  (rename-package "PCL" "OLD-PCL")
-  (make-package "PCL"))
-(when (find-package  "SLOT-ACCESSOR-NAME")
-  (rename-package "SLOT-ACCESSOR-NAME" "OLD-SLOT-ACCESSOR-NAME"))
-
-(setf c:*suppress-values-declaration* t)
-(pushnew :setf *features*)
-
-(setf (search-list "pcl:") '("target:pcl/"))
-
-(let ((obj (make-pathname :defaults "pcl:defsys"
-			  :type (c:backend-fasl-file-type c:*backend*))))
-  (when (< (or (file-write-date obj) 0)
-	   (file-write-date "pcl:defsys.lisp"))
-    (compile-file "pcl:defsys")))
-
-(load "pcl:defsys" :verbose t)
-
-(import 'kernel:funcallable-instance-p (find-package "PCL"))
-
-(with-compilation-unit
-    (:optimize '(optimize (debug-info #+small .5 #-small 2)
-			  (speed 2)
-			  (inhibit-warnings 2))
-     :context-declarations
-     '((:external (declare (optimize-interface (safety 2) (debug-info 1))))))
- (pcl::compile-pcl))
diff --git a/tools/rcsupdate.c b/tools/rcsupdate.c
deleted file mode 100644
index 897c21308ab0bc62b88084ca57689e9d16134528..0000000000000000000000000000000000000000
--- a/tools/rcsupdate.c
+++ /dev/null
@@ -1,339 +0,0 @@
-/* rcsupdate: utility to update a tree of RCS files.
-
-$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/Attic/rcsupdate.c,v 1.3 1992/03/03 10:18:39 wlott Exp $
-
-*/
-#include <sys/types.h>
-#include <sys/param.h>
-#include <sys/time.h>
-#include <sys/stat.h>
-#include <sys/dir.h>
-#include <stdio.h>
-#include <strings.h>
-#include <errno.h>
-
-static int quiet = 1;
-
-extern int errno;
-
-#define MAXRCSFILES 1000
-
-static char lastcache[MAXPATHLEN] = "";
-static struct cache_entry {
-    char *file;
-    long modtime, rcstime;
-} cache[MAXRCSFILES], *last_entry;
-static int dirty = 0; 
-
-void write_cache()
-{
-    FILE *file;
-    char bak[MAXPATHLEN];
-    struct cache_entry *entry;
-
-    if (dirty) {
-        strcpy(bak, lastcache);
-        strcat(bak, ".BAK");
-        rename(lastcache, bak);
-        file = fopen(lastcache, "w");
-        for (entry = cache; entry != last_entry; entry++) {
-            fprintf(file, "%s %ld %ld\n", entry->file, entry->modtime,
-                    entry->rcstime);
-            free(entry->file);
-        }
-        fclose(file);
-    }
-    lastcache[0] = '\0';
-    last_entry = cache;
-    dirty = 0;
-}
-
-void read_cache(cachefile)
-char *cachefile;
-{
-    FILE *file;
-    char line[MAXPATHLEN+80], name[MAXPATHLEN];
-    long modtime, rcstime;
-
-    write_cache();
-
-    if ((file = fopen(cachefile, "r")) != NULL) {
-        while (fgets(line, sizeof(line), file) != NULL) {
-            sscanf(line, "%s %ld %ld", name, &modtime, &rcstime);
-            last_entry->file = (char *)malloc(strlen(name)+1);
-            strcpy(last_entry->file, name);
-            last_entry->modtime = modtime;
-            last_entry->rcstime = rcstime;
-            last_entry++;
-        }
-        fclose(file);
-    }
-    strcpy(lastcache, cachefile);
-}
-
-long last_ci_time(localfile, rcsfile)
-char *localfile, *rcsfile;
-{
-    char cachefile[MAXPATHLEN], *ptr, *name, buf[MAXPATHLEN];
-    FILE *stream;
-    struct cache_entry *entry;
-    int reload_entry;
-    struct stat statbuf;
-    long modtime;
-
-    if (stat(rcsfile, &statbuf) < 0)
-        return -1;
-
-    strcpy(cachefile, localfile);
-    ptr = rindex(cachefile, '/');
-    if (ptr == NULL)
-        ptr = cachefile;
-    else
-        ptr++;
-    strcpy(ptr, ".rcsci_time_cache");
-
-    if (strcmp(cachefile, lastcache) != 0)
-        read_cache(cachefile);
-
-    name = rindex(rcsfile, '/');
-    if (name == NULL)
-        name = rcsfile;
-    else
-        name++;
-
-    reload_entry = 0;
-    for (entry = cache; entry != last_entry; entry++)
-        if (strcmp(name, entry->file) == 0)
-            break;
-    if (entry == last_entry) {
-        reload_entry = 1;
-        entry->file = (char *)malloc(strlen(name)+1);
-        strcpy(entry->file, name);
-        last_entry++;
-    }
-    else {
-        if (entry->rcstime != statbuf.st_mtime)
-            reload_entry = 1;
-    }
-    if (reload_entry) {
-        fflush(stdout);
-
-        sprintf(buf, "rcstime %s", rcsfile);
-        stream = popen(buf, "r");
-        if (stream == NULL)
-	    return -1;
-
-        fgets(buf, sizeof(buf), stream);
-	if (pclose(stream)) {
-	    /* There is no associated time. */
-	    entry->rcstime = statbuf.st_mtime;
-	    entry->modtime = 0;
-	} else {
-	    modtime = atoi(buf);
-	    if (modtime == 0) {
-		printf("bogus: ``%s''\n", buf);
-		return 0;
-	    }
-
-	    entry->rcstime = statbuf.st_mtime;
-	    entry->modtime = modtime;
-	}
-        dirty = 1;
-    }
-
-    return entry->modtime;
-}
-
-void update(localfile, rcsfile)
-char *localfile, *rcsfile;
-{
-    struct stat statbuf;
-    long localtime, rcstime;
-    char buf[MAXPATHLEN+40];
-    
-    if (stat(localfile, &statbuf) < 0) {
-        switch (errno) {
-          case ENOENT:
-	    if (!quiet) {
-		printf("local: <doesn't exist>\trcs: ");
-		fflush(stdout);
-	    }
-            localtime = 0;
-            break;
-
-          default:
-	    if (quiet)
-		perror(localfile);
-	    else
-		perror("oops");
-            return;
-        }
-    }
-    else {
-        localtime = statbuf.st_mtime;
-	if (!quiet) {
-	    printf("local: %ld\trcs: ", localtime);
-	    fflush(stdout);
-	}
-    }
-    
-    rcstime = last_ci_time(localfile, rcsfile);
-    if (rcstime < 0) {
-	if (quiet)
-	    perror(rcsfile);
-	else
-	    perror("oops");
-    }
-    else {
-	if (!quiet)
-	    printf("%ld\t", rcstime);
-
-	if (localtime < rcstime) {
-	    if (!quiet)
-		printf("out of date.\n");
-	    sprintf(buf, "rcsco %s %s", localfile, rcsfile);
-	    system(buf);
-	}
-	else
-	    if (!quiet)
-		printf("up to date.\n");
-	fflush(stdout);
-    }
-}
-
-void update_rcs_files(dirname)
-     char *dirname;
-{
-    char localfile[MAXPATHLEN], rcsfile[MAXPATHLEN];
-    char *localptr, *rcsptr;
-    DIR *rcsdir;
-    struct direct *entry;
-
-    strcpy(rcsfile, dirname);
-    strcat(rcsfile, "/RCS");
-
-    rcsdir = opendir(rcsfile);
-    if (rcsdir == NULL)
-        return;
-
-    rcsptr = rcsfile + strlen(rcsfile);
-    *rcsptr++ = '/';
-
-    strcpy(localfile, dirname);
-    localptr = localfile + strlen(localfile);
-    *localptr++ = '/';
-
-    while ((entry = readdir(rcsdir)) != NULL) {
-        if (strcmp(entry->d_name + entry->d_namlen - 2, ",v") == 0) {
-            strcpy(rcsptr, entry->d_name);
-            strcpy(localptr, entry->d_name);
-            localptr[entry->d_namlen - 2] = '\0';
-	    if (!quiet)
-		printf("%s:\t", localfile);
-            update(localfile, rcsfile);
-        }
-    }
-
-    closedir(rcsdir);
-}
-
-void update_directory(dirname)
-     char *dirname;
-{
-    DIR *dir;
-    struct stat buf;
-    struct direct *entry;
-    char subdir[MAXPATHLEN], *subptr;
-
-    printf("Updating %s:\n", dirname);
-
-    update_rcs_files(dirname);
-
-    dir = opendir(dirname);
-    if (dir == NULL) {
-        fprintf(stderr, "couldn't open ``%s''?\n", dirname);
-        return;
-    }
-
-    strcpy(subdir, dirname);
-    subptr = subdir + strlen(dirname);
-    *subptr++ = '/';
-
-    while ((entry = readdir(dir)) != NULL) {
-        if (strcmp(entry->d_name, "RCS") != 0
-            && strcmp(entry->d_name, "..") != 0
-            && strcmp(entry->d_name, ".") != 0) {
-            strcpy(subptr, entry->d_name);
-            if (stat(subdir, &buf) != -1 && (buf.st_mode & S_IFMT) == S_IFDIR)
-                update_directory(subdir);
-        }
-    }
-
-    closedir(dir);
-}
-
-main(argc, argv)
-int argc;
-char *argv[];
-{
-    char localfile[MAXPATHLEN], rcsfile[MAXPATHLEN], *ptr;
-    int len;
-    struct stat buf;
-    int did_anything = 0;
-
-    while (*++argv != NULL) {
-	if (strcmp(*argv, "-q") == 0)
-	    quiet = 1;
-	else if (strcmp(*argv, "-v") == 0)
-	    quiet = 0;
-	else if (stat(*argv, &buf)!=-1 && (buf.st_mode&S_IFMT)==S_IFDIR) {
-	    update_directory(*argv);
-	    did_anything = 1;
-	}
-	else {
-	    len = strlen(*argv);
-
-	    /* Determine the two names. */
-	    strcpy(rcsfile, *argv);
-	    strcpy(localfile, *argv);
-	    if (strcmp(",v", localfile + len-2) == 0) {
-		localfile[len-2] = '\0';
-		ptr = rindex(localfile, '/');
-		if (ptr == NULL)
-		    ptr = localfile;
-		else
-		    ptr -= 3;
-		if (strncmp(ptr, "RCS/", 4) == 0)
-		    strcpy(ptr, ptr+4);
-	    } else {
-		ptr = rindex(rcsfile, '/');
-		if (ptr == NULL)
-		    ptr = rcsfile;
-		else
-		    ptr++;
-		strcpy(ptr, "RCS/");
-		strcat(ptr, localfile + (ptr - rcsfile));
-		strcat(ptr, ",v");
-	    }
-                
-	    /* Display the file we are working on: */
-	    if (!quiet) {
-		ptr = rindex(localfile, '/');
-		if (ptr == NULL)
-		    ptr = localfile;
-		printf("%s:\t", ptr);
-		fflush(stdout);
-	    }
-                
-	    /* Update it. */
-	    update(localfile, rcsfile);
-	    did_anything = 1;
-	}
-    }
-    if (!did_anything)
-	update_directory(".");
-
-    write_cache();
-
-    exit(0);
-}
diff --git a/tools/sample-wrapper b/tools/sample-wrapper
deleted file mode 100755
index 224269cf1fd8d833da9e4f4a2aef1a483b004e67..0000000000000000000000000000000000000000
--- a/tools/sample-wrapper
+++ /dev/null
@@ -1,15 +0,0 @@
-#!/bin/sh
-#
-# Set up CMUCLLIB environment variable to point to run-time files.
-CMUCLLIB=/<<your-cmucl-path>>/lib
-export CMUCLLIB
-
-#
-# If /tmp is a "tmpfs" filesystem (mounted on "swap") then uncomment the
-# following two lines, and fill in an alternate path:
-#CMUCL_EMPTYFILE=/<<your-temp-path>>/empty
-#export CMUCL_EMPTYFILE
-
-#
-# Run Lisp with these environment variables set.
-exec /<<your-cmucl-path>>/bin/lisp "$@"
diff --git a/tools/setup.lisp b/tools/setup.lisp
deleted file mode 100644
index 7c781afd43469950023ae3de9888b64cf9955a31..0000000000000000000000000000000000000000
--- a/tools/setup.lisp
+++ /dev/null
@@ -1,235 +0,0 @@
-;;; -*- Package: USER -*-
-;;;
-;;;    Set up package environment and search lists for compiler.  Also some
-;;; compilation utilities.
-;;;
-(in-package "USER")
-
-
-;;; DUMP-PACKAGE-STATE  --  Public
-;;;
-(defun dump-package-state (packages file)
-  (declare (type (or list package symbol string) packages)
-	   (type (or pathname symbol string) file))
-  (let* ((packages (lisp::package-listify packages)))
-    (collect ((forms))
-      (dolist (pkg packages)
-	(let ((nicks (package-nicknames pkg))
-	      (name (package-name pkg))
-	      (shad (package-shadowing-symbols pkg)))
-	  (forms `(if (find-package ,name)
-		      (rename-package ,name ,name ',nicks)
-		      (make-package ,name :nicknames ',nicks :use nil)))
-	  (when shad
-	    (forms `(shadow ',(mapcar #'string shad) ,name)))))
-
-      (dolist (pkg packages)
-	(forms `(use-package ',(mapcar #'package-name
-				       (package-use-list pkg))
-			     ,(package-name pkg))))
-
-      (dolist (old packages)
-	(collect ((exports))
-	  (let ((imports (make-hash-table :test #'eq)))
-	    (do-symbols (sym old)
-	      (let ((pkg (symbol-package sym))
-		    (name (symbol-name sym)))
-		(multiple-value-bind (found how)
-				     (find-symbol name old)
-		  (assert (and (eq found sym) how))
-		  (cond
-		   ((not pkg)
-		    (warn "Not dumping uninterned symbol ~S." sym))
-		   ((eq how :inherited))
-		   (t
-		    (unless (eq pkg old)
-		      (pushnew name (gethash pkg imports) :test #'string=))
-		    (when (eq how :external)
-		      (exports name)))))))
-	    (collect ((import-froms))
-	      (maphash #'(lambda (pkg raw-names)
-			   (let ((names (sort (delete-duplicates raw-names
-								 :test
-								 #'string=)
-					      #'string<))
-				 (pkg-name (package-name pkg)))
-			     (when names
-			       (import-froms `(:import-from ,pkg-name ,@names))
-			       (dolist (name names)
-				 (forms `(intern ,name ,pkg-name))))))
-		       imports)
-	      (forms `(defpackage ,(package-name old)
-			,@(import-froms)
-			,@(when (exports)
-			    `((:export
-			       ,@(sort (delete-duplicates (exports)
-							  :test #'string=)
-				       #'string<))))))))))
-
-      (with-open-file (s file :direction :output :if-exists :new-version)
-	(dolist (form (forms))
-	  (write form :stream s :pretty t)
-	  (terpri s)))))
-
-  (values))
-  
-
-;;; COPY-PACKAGES  --  Public
-;;;
-(defun copy-packages (packages)
-  "Rename all the of the Named packages to OLD-Name, and then create new
-  packages for each name that have the same names, nicknames, imports, shadows
-  and exports.  If any of the OLD-Name packages already exist, then we quietly
-  do nothing."
-  (let* ((packages (lisp::package-listify packages))
-	 (names (mapcar #'package-name packages))
-	 (new-names (mapcar #'(lambda (x)
-				(concatenate 'string "OLD-" x))
-			    names)))
-    (unless (some #'find-package new-names)
-      (collect ((new-packages))
-	(flet ((trans-pkg (x)
-		 (or (cdr (assoc x (new-packages))) x)))
-	  (loop for pkg in packages and new in new-names do
-	    (let ((nicks (package-nicknames pkg))
-		  (name (package-name pkg)))
-	      (rename-package pkg new)
-	      (let ((new-pkg (make-package name :nicknames nicks :use nil))
-		    (shad (package-shadowing-symbols pkg)))
-		(when shad
-		  (shadow shad new-pkg))
-		(new-packages (cons pkg new-pkg)))))
-	  
-	  (loop for (old . new) in (new-packages) do
-	    (dolist (use (package-use-list old))
-	      (use-package (trans-pkg use) new)))
-	  
-	  (loop for (old . new) in (new-packages) do
-	    (do-symbols (sym old)
-	      (let ((pkg (symbol-package sym))
-		    (name (symbol-name sym)))
-		(multiple-value-bind (found how)
-				     (find-symbol name old)
-		  (assert (and (eq found sym) how))
-		  (cond
-		   ((not pkg)
-		    (warn "Not copying uninterned symbol ~S." sym))
-		   ((or (eq how :inherited)
-			(and (eq how :internal) (eq pkg old))))
-		   (t
-		    (let* ((npkg (trans-pkg pkg))
-			   (nsym (intern name npkg)))
-		      (multiple-value-bind (ignore new-how)
-					   (find-symbol name new)
-			(declare (ignore ignore))
-			(unless new-how (import nsym new)))
-		      (when (eq how :external)
-			(export nsym new)))))))))))))
-  (values))
-
-
-;;;; Compile utility:
-
-;;; Switches:
-;;;
-(defvar *interactive* t) ; Batch compilation mode?
-
-(defvar *log-file* nil)
-(defvar *last-file-position*)
-
-(defmacro with-compiler-log-file ((name &rest wcu-keys) &body forms)
-  `(if *interactive*
-       (with-compilation-unit (,@wcu-keys)
-	 ,@forms)
-       (let ((*log-file* (open ,name :direction :output
-			       :if-exists :append
-			       :if-does-not-exist :create)))
-	 (unwind-protect
-	     (let ((*error-output* *log-file*)
-		   (*last-file-position* (file-position *log-file*)))
-	       (with-compilation-unit (,@wcu-keys)
-		 ,@forms))
-	   (close *log-file*)))))
-
-
-(defun comf (name &key always-once proceed load output-file assem)
-  (declare (ignore always-once))
-  (when (and *log-file*
-	     (> (- (file-position *log-file*) *last-file-position*) 10000))
-    (setq *last-file-position* (file-position *log-file*))
-    (force-output *log-file*))
-
-  (let* ((src (pathname (concatenate 'string name ".lisp")))
-	 (obj (if output-file
-		  (pathname output-file)
-		  (make-pathname :defaults src
-				 :type
-				 (if assem
-				     "assem"
-				     (c:backend-fasl-file-type c:*backend*))))))
-
-    (unless (and (probe-file obj)
-		 (>= (file-write-date obj) (file-write-date src)))
-      (write-line name)
-      (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
-	      (ext:format-universal-time nil (get-universal-time))
-	      name)
-      (catch 'blow-this-file
-	(cond
-	 (*interactive*
-	  (if assem
-	      (c::assemble-file src :output-file obj)
-	      (compile-file 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))))
-	    (if assem
-		(c::assemble-file src :output-file obj)
-		(compile-file src  :error-file nil  :output-file obj))
-	    (when load
-	      (load name :verbose t)))))))))
-
-
-
-;;; CAT-IF-ANYTHING-CHAGNED
-
-(defun cat-if-anything-changed (output-file &rest input-files)
-  (flet ((add-correct-type (pathname)
-	   (make-pathname :type (c:backend-fasl-file-type c:*target-backend*)
-			  :defaults pathname)))
-    (let* ((output-file (add-correct-type output-file))
-	   (write-date (file-write-date output-file))
-	   (input-namestrings
-	    (mapcar #'(lambda (file)
-			(let ((file (add-correct-type file)))
-			  (let ((src-write-date (file-write-date file)))
-			    (unless src-write-date
-			      (error "Missing file: ~S" file))
-			    (when (and write-date
-				       (> src-write-date write-date))
-			      (setf write-date nil)))
-			  (unix-namestring file)))
-		    input-files)))
-      (cond ((null write-date)
-	     (format t "~S out of date.~%" (namestring output-file))
-	     (run-program "/bin/cat" input-namestrings
-			  :output output-file
-			  :if-output-exists :supersede
-			  :error t))
-	    (t
-	     (format t "~S up to date.~%" (namestring output-file)))))))
diff --git a/tools/snapshot-update.lisp b/tools/snapshot-update.lisp
deleted file mode 100644
index 7619ee6bfd5d3b9f8d336708f60bf669c8159ee0..0000000000000000000000000000000000000000
--- a/tools/snapshot-update.lisp
+++ /dev/null
@@ -1,50 +0,0 @@
-;;; -*- Package: User -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/Attic/snapshot-update.lisp,v 1.2 1992/02/24 14:23:25 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;;    A hack to generate a log of the changes since a particular snapshot.  We
-;;; generate a shell script and run it to avoid many calls to run-program.
-;;;
-(in-package "USER")
-
-(defun snapshot-updates (&key (snapshot-file "RCSSNAP")
-			      (output
-			       (make-pathname
-				:defaults (pathname snapshot-file)
-				:type "updates"))
-			      from)
-  "Write to :OUTPUT a summary of the RCS change long entries since the
-   since the specified :SNAPSHOT was made.  :OUTPUT is passed through to
-   run-program, and should be a stream or pathname.  If true, :FROM is a string
-   in RCS date format.  Only revisions after that date will be reported."
-  (with-open-file (script "/tmp/update-script" :direction :output)
-    (with-open-file (in snapshot-file :direction :input)
-      (loop
-	(let ((line (read-line in nil nil)))
-	  (unless line (return))
-	  (let* ((tab (position #\tab line))
-		 (dot (position #\. line :from-end t)))
-	    (format script "rlog -r~A~D- ~@['-d>~A' ~]~A~%"
-		    (subseq line (1+ tab) (1+ dot))
-		    (1+ (parse-integer (subseq line (1+ dot))))
-		    from
-		    (subseq line 0 tab)))))))
-
-  (let ((cmd (format nil
-		     "cd ~A; csh /tmp/update-script | ~
-		      sed -n -e '/^RCS file:/p' -e '/^------/,/^======/p' | ~
-		      sed -e '/^RCS file:/{;:again\\~@
-		          N;s/^RCS file.*\nRCS file/RCS file/;t again\\~@
-		          }'"
-		     (directory-namestring (truename snapshot-file)))))
-    (run-program "csh" (list "-c" cmd) :output output
-		 :if-output-exists :supersede)))
diff --git a/tools/updates b/tools/updates
deleted file mode 100755
index 46b66682535489af91d094b664ba7c48fe99a8d6..0000000000000000000000000000000000000000
--- a/tools/updates
+++ /dev/null
@@ -1,39 +0,0 @@
-#!/bin/csh -f
-
-set from = ""
-set to = ""
-set mtime = ()
-set dirs = ()
-
-while ($#argv > 0)
-	if ("$argv[1]" !~ -*) then
-		set dirs = ($dirs $argv[1])
-	else
-		switch ($argv[1])
-			case "-from":
-				set from = $argv[2]
-				shift
-				breaksw
-			case "-to":
-				set to = $argv[2]
-				shift
-				breaksw
-			case "-mtime":
-			        set mtime = ($argv[1-2])
-				shift
-				breaksw
-			default:
-				echo "Bogus switch: $argv[1]"
-				exit
-		endsw
-	endif
-	shift
-end
-
-if ($#dirs == 0) set dirs = .
-
-find $dirs -follow -name '*,v' $mtime -exec rlog  "-d$from<$to" '{}' \; | \
-    sed -n -e '/^RCS file:/p' -e '/^------/,/^======/p' | \
-    sed -e '/^RCS file:/{;:again\
-	N;s/^RCS file.*\nRCS file/RCS file/;t again\
-	}' 
diff --git a/tools/worldbuild.lisp b/tools/worldbuild.lisp
deleted file mode 100644
index 1fe1eef3e11dd90cc77860221f9d9f4feede5b0f..0000000000000000000000000000000000000000
--- a/tools/worldbuild.lisp
+++ /dev/null
@@ -1,141 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; 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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.16 1992/09/08 22:27:14 wlott Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; When loaded, this file builds a core image from all the .fasl files that
-;;; are part of the kernel CMU Common Lisp system.
-
-(in-package "LISP")
-
-(unless (fboundp 'genesis)
-  (load "target:compiler/generic/new-genesis"))
-
-(defparameter lisp-files
-  `(,@(when (c:backend-featurep :pmax)
-	'("target:assembly/mips/assem-rtns.assem"
-	  "target:assembly/mips/array.assem"
-	  "target:assembly/mips/arith.assem"
-	  "target:assembly/mips/alloc.assem"))
-    ,@(when (c:backend-featurep :sparc)
-	'("target:assembly/sparc/assem-rtns.assem"
-	  "target:assembly/sparc/array.assem"
-	  "target:assembly/sparc/arith.assem"
-	  "target:assembly/sparc/alloc.assem"))
-    ,@(when (c:backend-featurep :rt)
-	'("target:assembly/rt/assem-rtns.assem"
-	  "target:assembly/rt/array.assem"
-	  "target:assembly/rt/arith.assem"
-	  "target:assembly/rt/alloc.assem"))
-    ,@(when (c:backend-featurep :hppa)
-	'("target:assembly/hppa/assem-rtns.assem"
-	  "target:assembly/hppa/array.assem"
-	  "target:assembly/hppa/arith.assem"
-	  "target:assembly/hppa/alloc.assem"))
-    ,@(when (c:backend-featurep :x86)
-	'("target:assembly/x86/assem-rtns.assem"
-	  "target:assembly/x86/array.assem"
-	  "target:assembly/x86/arith.assem"
-	  "target:assembly/x86/alloc.assem"))
-
-    "target:code/fdefinition"
-    "target:code/eval"
-
-    "target:code/type-boot"
-    "target:code/struct"
-    "target:code/error"
-    "target:compiler/type"
-    "target:compiler/generic/vm-type"
-    "target:compiler/type-init"
-
-    "target:code/defstruct"
-    "target:compiler/proclaim"
-    "target:compiler/globaldb"
-    "target:code/pred"
-
-    "target:code/pathname"
-    "target:code/filesys"
-
-    "target:code/kernel"
-    "target:code/bit-bash"
-    "target:code/array"
-    "target:code/char"
-    "target:code/lispinit"
-    "target:code/seq"
-    "target:code/numbers"
-    "target:code/float"
-    "target:code/float-trap"
-    "target:code/irrat"
-    "target:code/bignum"
-    "target:code/defmacro"
-    "target:code/list"
-    "target:code/hash"
-    "target:code/macros"
-    "target:code/sysmacs"
-    "target:code/symbol"
-    "target:code/string"
-    "target:code/mipsstrops"
-    "target:code/misc"
-    "target:code/gc"
-    "target:code/save"
-    "target:code/extensions"
-    "target:code/alieneval"
-    "target:code/c-call"
-    "target:code/sap"
-    "target:code/unix"
-    ,@(when (c:backend-featurep :mach)
-	'("target:code/mach"
-	  "target:code/mach-os"))
-    ,@(when (c:backend-featurep :sunos)
-	'("target:code/sunos-os"))
-    "target:code/serve-event"
-    "target:code/stream"
-    "target:code/fd-stream"
-    "target:code/print"
-    "target:code/pprint"
-    "target:code/format"
-    "target:code/package"
-    "target:code/reader"
-    "target:code/backq"
-    "target:code/sharpm"
-    "target:code/load"
-    ,@(when (c:backend-featurep :pmax)
-	'("target:code/pmax-vm"))
-    ,@(when (c:backend-featurep :sparc)
-	'("target:code/sparc-vm"))
-    ,@(when (c:backend-featurep :rt)
-	'("target:code/rt-vm"))
-    ,@(when (c:backend-featurep :hppa)
-	'("target:code/hppa-vm"))
-    ,@(when (c:backend-featurep :x86)
-	'("target:code/x86-vm"))
-
-    "target:code/signal"
-    "target:code/interr"
-    "target:code/debug-info"
-    "target:code/debug-int"
-    "target:code/debug"
-    ))
-
-(if (c:target-featurep '(and :mach :sparc))
-    (setf *genesis-core-name* "/usr/tmp/kernel.core")
-    (setf *genesis-core-name* "target:lisp/kernel.core"))
-(setf *genesis-c-header-name* "target:lisp/internals.h")
-(setf *genesis-map-name* nil)
-(setf *genesis-symbol-table* "target:lisp/lisp.nm")
-
-(when (boundp '*target-page-size*)
-  (locally
-   (declare (optimize (inhibit-warnings 3)))
-   (setf *target-page-size*
-	 (c:backend-page-size c:*backend*))))
-
-(genesis lisp-files)
diff --git a/tools/worldload.lisp b/tools/worldload.lisp
deleted file mode 100644
index 11f027e28e1f83a35da340082ad96fc313096065..0000000000000000000000000000000000000000
--- a/tools/worldload.lisp
+++ /dev/null
@@ -1,187 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.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 or slisp-group@cs.cmu.edu.
-;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.51 1992/12/16 10:50:25 ram Exp $")
-;;;
-;;; **********************************************************************
-;;;
-;;; 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.
-;;;
-;;; ####### NOTE: HACK ALERT!!!!
-;;; 
-;;; This file must be loaded by:
-;;;    (load (open "...worldload.lisp"))
-;;;
-;;; The OPEN call is needed to prevent the stream buffer from the previous
-;;; incarnation (which is no longer valid) from being added to the stream
-;;; buffer freelist.  If you don't do this, you will probably get a memory
-;;; access violation when you first try to do file I/O in the new core.
-;;;
-
-;;; Define a bunch of search lists relative to lisp:
-;;;
-(setf (ext:search-list "code:") '("lisp:code/"))
-(setf (ext:search-list "c:") '("lisp:compiler/"))
-(setf (ext:search-list "vm:")
-      '(#+pmax "c:mips/"
-        #+sparc "c:sparc/"
-	#+rt "c:rt/"
-	#+hppa "c:hppa/"
-	#+x86 "c:x86/"
-	"c:generic/"))
-(setf (ext:search-list "assem:")
-      '(#+pmax "lisp:assembly/mips/"
-	#+sparc "lisp:assembly/sparc/"
-	#+rt "lisp:assembly/rt/"
-	#+hppa "lisp:assembly/hppa/"
-	#+x86 "lisp:assembly/x86/"
-	"lisp:assembly/"))
-(setf (ext:search-list "hem:") '("lisp:hemlock/"))
-(setf (ext:search-list "clx:") '("lisp:clx/"))
-(setf (ext:search-list "pcl:") '("lisp:pcl/"))
-(setf (ext:search-list "tools:") '("lisp:tools/"))
-
-;;; Make sure the core will start up in the user package.
-(lisp::assert-user-package)
-
-;;; We want to be in the LISP package for the rest of the file.
-(in-package "LISP")
-
-;;; Make sure the package structure is correct.
-;;;
-(load "code:exports")
-
-;;; Get some data on this core.
-;;;
-(write-string "What is the current lisp-implementation-version? ")
-(force-output)
-(set '*lisp-implementation-version* (read-line))
-
-;;; Load random code sources.
-
-(load "code:format-time")
-(load "code:parse-time")
-(load "code:purify")
-(load "code:commandline")
-(load "code:sort")
-(load "code:time")
-(load "code:tty-inspect")
-(load "code:describe")
-(load "code:rand")
-(load "code:ntrace")
-(load "code:profile")
-(load "code:weak")
-(load "code:final")
-(load "code:sysmacs")
-(load "code:run-program")
-(load "code:query")
-(load "code:loop")
-(load "code:internet")
-(load "code:wire")
-(load "code:remote")
-(load "code:foreign")
-(load "code:setf-funs")
-(load "code:module")
-
-(setq *info-environment*
-      (list* (make-info-environment)
-	     (compact-info-environment (first *info-environment*)
-				       :name "Kernel")
-	     (rest *info-environment*)))
-(purify :root-structures
-	`(lisp::%top-level extensions:save-lisp ,lisp::fop-codes))
-
-;;; Load the compiler.
-#-no-compiler
-(progn
-  (load "c:loadcom.lisp")
-  (setq *info-environment*
-	(list* (make-info-environment)
-	       (compact-info-environment (first *info-environment*)
-					 :name "Compiler")
-	       (rest *info-environment*)))
-  (load "c:loadbackend.lisp")
-  ;; If we want a small core, blow away the meta-compile time VOP info.
-  #+small (setf (c::backend-parsed-vops c:*backend*)
-		(make-hash-table :test #'eq))
-  (setq *info-environment*
-	(list* (make-info-environment)
-	       (compact-info-environment
-		(first *info-environment*)
-		:name
-		(concatenate 'string (c:backend-name c:*backend*) " backend"))
-	       (rest *info-environment*)))
-  (purify :root-structures '(compile-file)))
-
-#-no-compiler
-;;; Depends on backend definition for object format info...
-(load "code:room")
-
-;;; The pretty printer is part of the kernel core, but we can't turn in on
-;;; until after the compiler is loaded because it compiles some lambdas
-;;; to help with the dispatching.
-;;; 
-#-no-pp
-(pp::pprint-init)
-
-;;; CLX.
-;;;
-#-no-clx
-(load "clx:clx-library")
-
-;;; Hemlock.
-;;;
-#-no-hemlock
-(load "lisp:hemlock/hemlock-library")
-
-#-(and no-clx no-hemlock)
-(purify :root-structures `(ed #-no-hemlock ,hi::*global-command-table*))
-
-;;; PCL.
-;;;
-#-no-pcl (load "pcl:pclload")
-#-(or no-pcl no-clx) (load "code:inspect")
-
-;;; Don't include the search lists used for loading in the resultant core.
-;;;
-(lisp::clear-all-search-lists)
-
-;; set up the initial info environment.
-(setq *info-environment*
-      (list* (make-info-environment :name "Working")
-	     (compact-info-environment (first *info-environment*)
-				       :name "Auxiliary")
-	     (rest *info-environment*)))
-
-;;; Okay, build the thing!
-;;;
-(progn
-  ;; We want to be in the USER package when the command line switches run.
-  (in-package "USER")
-  ;; Clean random top-level specials.
-  (setq - nil)
-  (setq + nil)
-  (setq * nil)
-  (setq / nil)
-  (setq ++ nil)
-  (setq ** nil)
-  (setq // nil)
-  (setq +++ nil)
-  (setq *** nil)
-  (setq /// nil)
-  ;; 
-  ;; Enable the garbage collector.  But first fake it into thinking that
-  ;; we don't need to garbage collect.  The save-lisp is going to call purify
-  ;; so any garbage will be collected then.
-  (setf *need-to-collect-garbage* nil)
-  (gc-on)
-  ;;
-  ;; Save the lisp.
-  (save-lisp "lisp.core"))